aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--.gitattributes3
-rw-r--r--.gitignore13
-rw-r--r--.gitlab-ci.yml240
-rw-r--r--.gitmodules3
-rw-r--r--Changelog100
-rw-r--r--INSTALL.md62
-rw-r--r--INSTALL_CROSS.md5
-rw-r--r--LICENSE27
-rw-r--r--Makefile77
-rw-r--r--Makefile.extr6
-rw-r--r--Makefile.menhir6
-rw-r--r--MenhirLib/Alphabet.v247
-rw-r--r--MenhirLib/Automaton.v (renamed from cparser/MenhirLib/Automaton.v)37
-rw-r--r--MenhirLib/Grammar.v162
-rw-r--r--MenhirLib/Interpreter.v453
-rw-r--r--MenhirLib/Interpreter_complete.v825
-rw-r--r--MenhirLib/Interpreter_correct.v175
-rw-r--r--MenhirLib/Main.v79
-rw-r--r--MenhirLib/Validator_classes.v75
-rw-r--r--MenhirLib/Validator_complete.v394
-rw-r--r--MenhirLib/Validator_safe.v234
-rw-r--r--VERSION2
-rw-r--r--aarch64/Archi.v88
-rw-r--r--aarch64/Asm.v1312
-rw-r--r--aarch64/AsmToJSON.ml24
-rw-r--r--aarch64/Asmexpand.ml453
-rw-r--r--aarch64/Asmgen.v1172
-rw-r--r--aarch64/Asmgenproof.v1101
-rw-r--r--aarch64/Asmgenproof1.v2138
-rw-r--r--aarch64/Builtins1.v (renamed from cparser/Builtins.mli)26
-rw-r--r--aarch64/CBuiltins.ml72
-rw-r--r--aarch64/CSE2deps.v20
-rw-r--r--aarch64/CSE2depsproof.v128
-rw-r--r--aarch64/CombineOp.v137
-rw-r--r--aarch64/CombineOpproof.v161
-rw-r--r--aarch64/ConstpropOp.vp401
-rw-r--r--aarch64/ConstpropOpproof.v838
-rw-r--r--aarch64/Conventions1.v285
-rw-r--r--aarch64/DuplicateOpcodeHeuristic.ml27
-rw-r--r--aarch64/Machregs.v210
-rw-r--r--aarch64/Machregsaux.ml40
-rw-r--r--aarch64/NeedOp.v253
-rw-r--r--aarch64/Op.v1848
-rw-r--r--aarch64/PrintOp.ml247
-rw-r--r--aarch64/SelectLong.vp478
-rw-r--r--aarch64/SelectLongproof.v767
-rw-r--r--aarch64/SelectOp.vp573
-rw-r--r--aarch64/SelectOpproof.v1093
-rw-r--r--aarch64/Stacklayout.v140
-rw-r--r--aarch64/TargetPrinter.ml592
-rw-r--r--aarch64/ValueAOp.v319
-rw-r--r--aarch64/extractionMachdep.v24
-rw-r--r--arm/Archi.v66
-rw-r--r--arm/Asm.v9
-rw-r--r--arm/AsmToJSON.ml43
-rw-r--r--arm/Asmexpand.ml7
-rw-r--r--arm/Asmgen.v29
-rw-r--r--arm/Asmgenproof.v8
-rw-r--r--arm/Asmgenproof1.v60
-rw-r--r--arm/Builtins1.v33
-rw-r--r--arm/CBuiltins.ml4
-rw-r--r--arm/CSE2deps.v20
-rw-r--r--arm/CSE2depsproof.v129
-rw-r--r--arm/ConstpropOp.vp12
-rw-r--r--arm/ConstpropOpproof.v26
-rw-r--r--arm/Conventions1.v238
-rw-r--r--arm/DuplicateOpcodeHeuristic.ml22
-rw-r--r--arm/NeedOp.v5
-rw-r--r--arm/Op.v105
-rw-r--r--arm/PrintOp.ml4
-rw-r--r--arm/SelectOp.vp23
-rw-r--r--arm/SelectOpproof.v47
-rw-r--r--arm/TargetPrinter.ml16
-rw-r--r--arm/ValueAOp.v2
-rw-r--r--backend/Allnontrap.v26
-rw-r--r--backend/Allnontrapproof.v215
-rw-r--r--backend/Allocation.v34
-rw-r--r--backend/Allocproof.v136
-rw-r--r--backend/Asmexpandaux.ml2
-rw-r--r--backend/Asmexpandaux.mli4
-rw-r--r--backend/Asmgenproof0.v49
-rw-r--r--backend/Bounds.v6
-rw-r--r--backend/CSE.v31
-rw-r--r--backend/CSE2.v514
-rw-r--r--backend/CSE2proof.v1740
-rw-r--r--backend/CSEdomain.v13
-rw-r--r--backend/CSEproof.v184
-rw-r--r--backend/CleanupLabelsproof.v12
-rw-r--r--backend/Cminor.v84
-rw-r--r--backend/Cminortyping.v803
-rw-r--r--backend/Constprop.v54
-rw-r--r--backend/Constpropproof.v103
-rw-r--r--backend/Conventions.v69
-rw-r--r--backend/Deadcode.v8
-rw-r--r--backend/Deadcodeproof.v83
-rw-r--r--backend/Debugvar.v2
-rw-r--r--backend/Debugvarproof.v16
-rw-r--r--backend/Duplicate.v203
-rw-r--r--backend/Duplicateaux.ml648
-rw-r--r--backend/Duplicateproof.v523
-rw-r--r--backend/ForwardMoves.v333
-rw-r--r--backend/ForwardMovesproof.v801
-rw-r--r--backend/IRC.ml1
-rw-r--r--backend/Inlining.v8
-rw-r--r--backend/Inliningaux.ml13
-rw-r--r--backend/Inliningproof.v70
-rw-r--r--backend/Inliningspec.v12
-rw-r--r--backend/Json.ml52
-rw-r--r--backend/JsonAST.ml18
-rw-r--r--backend/JsonAST.mli2
-rw-r--r--backend/LTL.v27
-rw-r--r--backend/Linear.v23
-rw-r--r--backend/Linearize.v6
-rw-r--r--backend/Linearizeaux.ml421
-rw-r--r--backend/Linearizeproof.v48
-rw-r--r--backend/Lineartyping.v23
-rw-r--r--backend/Liveness.v4
-rw-r--r--backend/Mach.v19
-rw-r--r--backend/NeedDomain.v91
-rw-r--r--backend/OpHelpers.v20
-rw-r--r--backend/OpHelpersproof.v2
-rw-r--r--backend/PrintAsm.ml6
-rw-r--r--backend/PrintAsmaux.ml39
-rw-r--r--backend/PrintCminor.ml6
-rw-r--r--backend/PrintLTL.ml14
-rw-r--r--backend/PrintLTLin.ml115
-rw-r--r--backend/PrintMach.ml5
-rw-r--r--backend/PrintRTL.ml14
-rw-r--r--backend/PrintXTL.ml11
-rw-r--r--backend/RTL.v57
-rw-r--r--backend/RTLgen.v20
-rw-r--r--backend/RTLgenproof.v4
-rw-r--r--backend/RTLgenspec.v18
-rw-r--r--backend/RTLtyping.v67
-rw-r--r--backend/Regalloc.ml46
-rw-r--r--backend/Renumber.v4
-rw-r--r--backend/Renumberproof.v12
-rw-r--r--backend/SelectDivproof.v54
-rw-r--r--backend/Selection.v206
-rw-r--r--backend/Selectionaux.ml115
-rw-r--r--backend/Selectionproof.v529
-rw-r--r--backend/SplitLongproof.v104
-rw-r--r--backend/Splitting.ml8
-rw-r--r--backend/Stacking.v4
-rw-r--r--backend/Stackingproof.v40
-rw-r--r--backend/Tailcall.v2
-rw-r--r--backend/Tailcallproof.v47
-rw-r--r--backend/Tunneling.v4
-rw-r--r--backend/Tunnelingproof.v25
-rw-r--r--backend/Unusedglob.v6
-rw-r--r--backend/Unusedglobproof.v40
-rw-r--r--backend/ValueAnalysis.v98
-rw-r--r--backend/ValueDomain.v154
-rw-r--r--backend/XTL.ml10
-rw-r--r--backend/XTL.mli4
-rw-r--r--cfrontend/C2C.ml111
-rw-r--r--cfrontend/Cexec.v128
-rw-r--r--cfrontend/Clight.v2
-rw-r--r--cfrontend/Cminorgenproof.v2
-rw-r--r--cfrontend/Cop.v29
-rw-r--r--cfrontend/Csem.v69
-rw-r--r--cfrontend/Cshmgen.v39
-rw-r--r--cfrontend/Cshmgenproof.v133
-rw-r--r--cfrontend/Cstrategy.v10
-rw-r--r--cfrontend/Csyntax.v14
-rw-r--r--cfrontend/Ctypes.v19
-rw-r--r--cfrontend/Ctyping.v158
-rw-r--r--cfrontend/PrintClight.ml54
-rw-r--r--cfrontend/PrintCsyntax.ml12
-rw-r--r--cfrontend/SimplExprspec.v2
-rw-r--r--cfrontend/SimplLocalsproof.v2
-rw-r--r--common/AST.v112
-rw-r--r--common/Builtins.v58
-rw-r--r--common/Builtins0.v531
-rw-r--r--common/Errors.v2
-rw-r--r--common/Events.v217
-rw-r--r--common/Memdata.v46
-rw-r--r--common/Memory.v199
-rw-r--r--common/Memtype.v9
-rw-r--r--common/PrintAST.ml12
-rw-r--r--common/Sections.ml29
-rw-r--r--common/Sections.mli4
-rw-r--r--common/Separation.v4
-rw-r--r--common/Smallstep.v173
-rw-r--r--common/Switch.v6
-rw-r--r--common/Values.v298
-rwxr-xr-xconfig_aarch64.sh1
-rwxr-xr-xconfig_arm.sh1
-rwxr-xr-xconfig_armhf.sh1
-rwxr-xr-xconfig_ia32.sh1
-rwxr-xr-xconfig_k1c.sh1
-rwxr-xr-xconfig_ppc.sh1
-rwxr-xr-xconfig_ppc64.sh1
-rwxr-xr-xconfig_rv32.sh1
-rwxr-xr-xconfig_rv64.sh1
-rwxr-xr-xconfig_simple.sh11
-rwxr-xr-xconfig_x86_64.sh1
-rwxr-xr-xconfigure98
-rwxr-xr-xcoq2
-rw-r--r--cparser/Builtins.ml54
-rw-r--r--cparser/C.mli7
-rw-r--r--cparser/Cabs.v54
-rw-r--r--cparser/Cabshelper.ml13
-rw-r--r--cparser/Ceval.ml2
-rw-r--r--cparser/Checks.ml362
-rw-r--r--cparser/Checks.mli2
-rw-r--r--cparser/Cutil.ml15
-rw-r--r--cparser/Cutil.mli4
-rw-r--r--cparser/Diagnostics.ml170
-rw-r--r--cparser/Diagnostics.mli12
-rw-r--r--cparser/Elab.ml493
-rw-r--r--cparser/Elab.mli4
-rw-r--r--cparser/Env.ml40
-rw-r--r--cparser/Env.mli7
-rw-r--r--cparser/GCC.ml4
-rw-r--r--cparser/Lexer.mll258
-rw-r--r--cparser/Machine.ml43
-rw-r--r--cparser/Machine.mli2
-rw-r--r--cparser/MenhirLib/Alphabet.v320
-rw-r--r--cparser/MenhirLib/Grammar.v166
-rw-r--r--cparser/MenhirLib/Interpreter.v228
-rw-r--r--cparser/MenhirLib/Interpreter_complete.v686
-rw-r--r--cparser/MenhirLib/Interpreter_correct.v228
-rw-r--r--cparser/MenhirLib/Interpreter_safe.v275
-rw-r--r--cparser/MenhirLib/Main.v92
-rw-r--r--cparser/MenhirLib/Tuples.v49
-rw-r--r--cparser/MenhirLib/Validator_complete.v542
-rw-r--r--cparser/MenhirLib/Validator_safe.v414
-rw-r--r--cparser/PackedStructs.ml2
-rw-r--r--cparser/Parse.ml13
-rw-r--r--cparser/Parser.vy595
-rw-r--r--cparser/Rename.ml2
-rw-r--r--cparser/StructPassing.ml11
-rw-r--r--cparser/Transform.ml2
-rw-r--r--cparser/Unblock.ml4
-rw-r--r--cparser/handcrafted.messages4
-rw-r--r--cparser/pre_parser.mly10
-rw-r--r--debug/Debug.ml6
-rw-r--r--debug/Debug.mli4
-rw-r--r--debug/DebugInformation.ml23
-rw-r--r--debug/DebugInformation.mli2
-rw-r--r--debug/DwarfPrinter.ml83
-rw-r--r--debug/DwarfPrinter.mli2
-rw-r--r--debug/DwarfTypes.mli31
-rw-r--r--debug/Dwarfgen.ml100
-rw-r--r--doc/ccomp.136
-rw-r--r--doc/index-mppa_k1c.html380
-rw-r--r--doc/index.html7
-rw-r--r--driver/Clflags.ml14
-rw-r--r--driver/Commandline.ml14
-rw-r--r--driver/Commandline.mli8
-rw-r--r--driver/CommonOptions.ml4
-rw-r--r--driver/Compiler.v94
-rw-r--r--driver/Compopts.v25
-rw-r--r--driver/Configuration.ml8
-rw-r--r--driver/Driver.ml56
-rw-r--r--driver/Frontend.ml33
-rw-r--r--driver/Interp.ml6
-rw-r--r--exportclight/Clightgen.ml33
-rw-r--r--exportclight/Clightnorm.ml2
-rw-r--r--exportclight/ExportClight.ml20
-rw-r--r--extraction/extraction.v47
-rw-r--r--flocq/Appli/Fappli_IEEE.v1920
-rw-r--r--flocq/Calc/Bracket.v (renamed from flocq/Calc/Fcalc_bracket.v)148
-rw-r--r--flocq/Calc/Div.v159
-rw-r--r--flocq/Calc/Fcalc_digits.v63
-rw-r--r--flocq/Calc/Fcalc_div.v165
-rw-r--r--flocq/Calc/Fcalc_sqrt.v244
-rw-r--r--flocq/Calc/Operations.v (renamed from flocq/Calc/Fcalc_ops.v)23
-rw-r--r--flocq/Calc/Round.v (renamed from flocq/Calc/Fcalc_round.v)565
-rw-r--r--flocq/Calc/Sqrt.v201
-rw-r--r--flocq/Core/Core.v (renamed from flocq/Core/Fcore.v)16
-rw-r--r--flocq/Core/Defs.v (renamed from flocq/Core/Fcore_defs.v)36
-rw-r--r--flocq/Core/Digits.v (renamed from flocq/Core/Fcore_digits.v)211
-rw-r--r--flocq/Core/FIX.v (renamed from flocq/Core/Fcore_FIX.v)30
-rw-r--r--flocq/Core/FLT.v (renamed from flocq/Core/Fcore_FLT.v)182
-rw-r--r--flocq/Core/FLX.v362
-rw-r--r--flocq/Core/FTZ.v (renamed from flocq/Core/Fcore_FTZ.v)109
-rw-r--r--flocq/Core/Fcore_FLX.v271
-rw-r--r--flocq/Core/Float_prop.v (renamed from flocq/Core/Fcore_float_prop.v)228
-rw-r--r--flocq/Core/Generic_fmt.v (renamed from flocq/Core/Fcore_generic_fmt.v)793
-rw-r--r--flocq/Core/Raux.v (renamed from flocq/Core/Fcore_Raux.v)964
-rw-r--r--flocq/Core/Round_NE.v (renamed from flocq/Core/Fcore_rnd_ne.v)185
-rw-r--r--flocq/Core/Round_pred.v (renamed from flocq/Core/Fcore_rnd.v)176
-rw-r--r--flocq/Core/Ulp.v (renamed from flocq/Core/Fcore_ulp.v)925
-rw-r--r--flocq/Core/Zaux.v (renamed from flocq/Core/Fcore_Zaux.v)238
-rw-r--r--flocq/IEEE754/Binary.v2935
-rw-r--r--flocq/IEEE754/Bits.v (renamed from flocq/Appli/Fappli_IEEE_bits.v)327
-rw-r--r--flocq/Prop/Div_sqrt_error.v872
-rw-r--r--flocq/Prop/Double_rounding.v (renamed from flocq/Appli/Fappli_double_round.v)2598
-rw-r--r--flocq/Prop/Fprop_div_sqrt_error.v300
-rw-r--r--flocq/Prop/Mult_error.v (renamed from flocq/Prop/Fprop_mult_error.v)175
-rw-r--r--flocq/Prop/Plus_error.v (renamed from flocq/Prop/Fprop_plus_error.v)394
-rw-r--r--flocq/Prop/Relative.v (renamed from flocq/Prop/Fprop_relative.v)505
-rw-r--r--flocq/Prop/Round_odd.v (renamed from flocq/Appli/Fappli_rnd_odd.v)618
-rw-r--r--flocq/Prop/Sterbenz.v (renamed from flocq/Prop/Fprop_Sterbenz.v)64
-rw-r--r--flocq/Version.v (renamed from flocq/Flocq_version.v)6
-rw-r--r--lib/BoolEqual.v9
-rw-r--r--lib/Camlcoq.ml51
-rw-r--r--lib/Coqlib.v131
-rw-r--r--lib/Floats.v495
-rw-r--r--lib/Heaps.v8
-rw-r--r--lib/IEEE754_extra.v (renamed from lib/Fappli_IEEE_extra.v)431
-rw-r--r--lib/Integers.v1595
-rw-r--r--lib/IntvSets.v2
-rw-r--r--lib/Maps.v163
-rw-r--r--lib/Ordered.v10
-rw-r--r--lib/Zbits.v1101
-rw-r--r--mppa_k1c/Archi.v42
-rw-r--r--mppa_k1c/Asm.v1489
-rw-r--r--mppa_k1c/Asmaux.v4
-rw-r--r--mppa_k1c/Asmblock.v79
-rw-r--r--mppa_k1c/Asmblockdeps.v463
-rw-r--r--mppa_k1c/Asmblockgen.v328
-rw-r--r--mppa_k1c/Asmblockgenproof.v3601
-rw-r--r--mppa_k1c/Asmblockgenproof1.v863
-rw-r--r--mppa_k1c/Asmblockprops.v343
-rw-r--r--mppa_k1c/Asmexpand.ml111
-rw-r--r--mppa_k1c/Asmgen.v13
-rw-r--r--mppa_k1c/Asmgenproof.v6
-rw-r--r--mppa_k1c/Asmvliw.v240
-rw-r--r--mppa_k1c/Builtins1.v66
-rw-r--r--mppa_k1c/CBuiltins.ml40
-rw-r--r--mppa_k1c/CSE2deps.v20
-rw-r--r--mppa_k1c/CSE2depsproof.v127
-rw-r--r--mppa_k1c/ConstpropOp.vp2
-rw-r--r--mppa_k1c/Conventions1.v31
-rw-r--r--mppa_k1c/DuplicateOpcodeHeuristic.ml27
-rw-r--r--mppa_k1c/ExtFloats.v39
-rw-r--r--mppa_k1c/ExtValues.v169
-rw-r--r--mppa_k1c/InstructionScheduler.ml98
-rw-r--r--mppa_k1c/Machregs.v8
-rw-r--r--mppa_k1c/NeedOp.v286
-rw-r--r--mppa_k1c/Op.v582
-rw-r--r--mppa_k1c/Peephole.v9
-rw-r--r--mppa_k1c/PostpassScheduling.v72
-rw-r--r--mppa_k1c/PostpassSchedulingOracle.ml952
-rw-r--r--mppa_k1c/PostpassSchedulingproof.v266
-rw-r--r--mppa_k1c/PrintOp.ml82
-rw-r--r--mppa_k1c/SelectLong.vp51
-rw-r--r--mppa_k1c/SelectLongproof.v225
-rw-r--r--mppa_k1c/SelectOp.vp173
-rw-r--r--mppa_k1c/SelectOpproof.v540
-rw-r--r--mppa_k1c/TargetPrinter.ml122
-rw-r--r--mppa_k1c/ValueAOp.v285
-rw-r--r--mppa_k1c/abstractbb/AbstractBasicBlocksDef.v205
-rw-r--r--mppa_k1c/abstractbb/DepTreeTheory.v456
-rw-r--r--mppa_k1c/abstractbb/ImpDep.v960
-rw-r--r--mppa_k1c/abstractbb/ImpSimuTest.v1246
-rw-r--r--mppa_k1c/abstractbb/Impure/ImpConfig.v10
-rw-r--r--mppa_k1c/abstractbb/Impure/ImpCore.v2
-rw-r--r--mppa_k1c/abstractbb/Impure/ImpHCons.v106
-rw-r--r--mppa_k1c/abstractbb/Impure/ImpLoops.v8
-rw-r--r--mppa_k1c/abstractbb/Impure/ImpPrelude.v51
-rw-r--r--mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml37
-rw-r--r--mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli5
-rw-r--r--mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml2
-rw-r--r--mppa_k1c/abstractbb/Parallelizability.v12
-rw-r--r--mppa_k1c/abstractbb/SeqSimuTheory.v384
-rw-r--r--mppa_k1c/lib/Asmblockgenproof0.v (renamed from mppa_k1c/Asmblockgenproof0.v)225
-rw-r--r--mppa_k1c/lib/ForwardSimulationBlock.v6
-rw-r--r--mppa_k1c/lib/Machblock.v21
-rw-r--r--mppa_k1c/lib/Machblockgen.v23
-rw-r--r--mppa_k1c/lib/Machblockgenproof.v28
-rwxr-xr-xpg20
-rw-r--r--powerpc/Archi.v44
-rw-r--r--powerpc/Asm.v16
-rw-r--r--powerpc/AsmToJSON.ml64
-rw-r--r--powerpc/Asmexpand.ml107
-rw-r--r--powerpc/Asmgen.v81
-rw-r--r--powerpc/Asmgenproof.v45
-rw-r--r--powerpc/Asmgenproof1.v237
-rw-r--r--powerpc/Builtins1.v33
-rw-r--r--powerpc/CBuiltins.ml4
-rw-r--r--powerpc/CSE2deps.v20
-rw-r--r--powerpc/CSE2depsproof.v135
-rw-r--r--powerpc/ConstpropOp.vp13
-rw-r--r--powerpc/ConstpropOpproof.v28
-rw-r--r--powerpc/Conventions1.v177
-rw-r--r--powerpc/DuplicateOpcodeHeuristic.ml27
-rw-r--r--powerpc/Machregs.v6
-rw-r--r--powerpc/NeedOp.v5
-rw-r--r--powerpc/Op.v109
-rw-r--r--powerpc/PrintOp.ml4
-rw-r--r--powerpc/SelectLongproof.v10
-rw-r--r--powerpc/SelectOp.vp27
-rw-r--r--powerpc/SelectOpproof.v51
-rw-r--r--powerpc/TargetPrinter.ml24
-rw-r--r--powerpc/ValueAOp.v2
-rw-r--r--powerpc/extractionMachdep.v3
-rw-r--r--riscV/Archi.v39
-rw-r--r--riscV/Asm.v2
-rw-r--r--riscV/Asmexpand.ml42
-rw-r--r--riscV/Asmgen.v45
-rw-r--r--riscV/Asmgenproof.v12
-rw-r--r--riscV/Asmgenproof1.v92
-rw-r--r--riscV/Builtins1.v33
-rw-r--r--riscV/CBuiltins.ml7
-rw-r--r--riscV/CSE2deps.v20
-rw-r--r--riscV/CSE2depsproof.v127
-rw-r--r--riscV/Conventions1.v350
-rw-r--r--riscV/DuplicateOpcodeHeuristic.ml27
-rw-r--r--riscV/Op.v70
-rw-r--r--riscV/SelectOp.vp18
-rw-r--r--riscV/SelectOpproof.v51
-rw-r--r--riscV/TargetPrinter.ml8
-rw-r--r--runtime/Makefile10
-rw-r--r--runtime/aarch64/sysdeps.h45
-rw-r--r--runtime/aarch64/vararg.S109
-rw-r--r--runtime/arm/i64_stof.S9
-rw-r--r--runtime/include/ccomp_k1c_fixes.h6
-rw-r--r--runtime/include/math.h19
-rw-r--r--runtime/mppa_k1c/i32_divmod.s (renamed from runtime/mppa_k1c/i32_divmod.S)0
-rw-r--r--runtime/mppa_k1c/i64_sdiv.c24
-rw-r--r--runtime/mppa_k1c/i64_udivmod_stsud.s (renamed from runtime/mppa_k1c/i64_udivmod_stsud.S)33
-rw-r--r--runtime/mppa_k1c/vararg.s (renamed from runtime/mppa_k1c/vararg.S)6
-rw-r--r--runtime/powerpc/i64_stof.s17
-rw-r--r--runtime/powerpc/i64_utof.s10
-rw-r--r--runtime/powerpc64/i64_utof.s10
-rw-r--r--test/Makefile10
-rw-r--r--test/c/Makefile55
-rw-r--r--test/c/Results/binarytrees-mppa_k1c4
-rw-r--r--test/c/Results/chomp-mppa_k1c9
-rw-r--r--test/c/Results/fannkuch-mppa_k1c31
-rw-r--r--test/c/Results/fft-mppa_k1c1
-rw-r--r--test/c/Results/fftsp-mppa_k1c1
-rw-r--r--test/c/Results/fftw-mppa_k1c16
-rw-r--r--test/c/Results/fib-mppa_k1c1
-rw-r--r--test/c/Results/integr-mppa_k1c1
-rw-r--r--test/c/Results/knucleotide-mppa_k1c0
-rw-r--r--test/c/Results/lists-mppa_k1c2
-rw-r--r--test/c/Results/mandelbrot-mppa_k1cbin0 -> 409 bytes
-rw-r--r--test/c/Results/nbody-mppa_k1c2
-rw-r--r--test/c/Results/nsieve-mppa_k1c3
-rw-r--r--test/c/Results/nsievebits-mppa_k1c3
-rw-r--r--test/c/Results/perlin-mppa_k1c1
-rw-r--r--test/c/Results/qsort-mppa_k1c1
-rw-r--r--test/c/Results/sha1-mppa_k1c2
-rw-r--r--test/c/Results/spectral-mppa_k1c1
-rw-r--r--test/c/Results/vmach-mppa_k1c2
-rwxr-xr-xtest/c/Runtest71
-rw-r--r--test/c/aes.c14
-rw-r--r--test/c/almabench.c7
-rw-r--r--test/c/binarytrees.c6
-rw-r--r--test/c/chomp.c11
-rw-r--r--test/c/fannkuch.c8
-rw-r--r--test/c/fft.c7
-rw-r--r--test/c/fftsp.c4
-rw-r--r--test/c/fftw.c4
-rw-r--r--test/c/fib.c4
-rw-r--r--test/c/integr.c4
-rw-r--r--test/c/knucleotide.c6
-rw-r--r--test/c/lists.c8
-rw-r--r--test/c/mandelbrot.c14
-rw-r--r--test/c/nbody.c4
-rw-r--r--test/c/nsieve.c8
-rw-r--r--test/c/nsievebits.c8
-rw-r--r--test/c/perlin.c15
-rw-r--r--test/c/qsort.c4
-rw-r--r--test/c/sha1.c4
-rw-r--r--test/c/sha3.c5
-rw-r--r--test/c/siphash24.c8
-rw-r--r--test/c/spectral.c4
-rw-r--r--test/c/vmach.c29
-rw-r--r--test/clightgen/issue319.c12
-rw-r--r--test/compression/Makefile19
-rw-r--r--test/cse2/globals.c8
-rw-r--r--test/cse2/indexed_addr.c6
-rw-r--r--test/endian.h8
-rw-r--r--test/monniaux/.gitignore14
-rw-r--r--test/monniaux/Asmblockdeps.patch20
-rw-r--r--test/monniaux/BearSSL/conf/KalrayCompCert.mk2
-rw-r--r--test/monniaux/BearSSL/mk/mkT0.cmd32
-rw-r--r--test/monniaux/Makefile39
-rw-r--r--test/monniaux/PostpassSchedulingOracle.patch33
-rw-r--r--test/monniaux/README.md171
-rw-r--r--test/monniaux/benches.sh4
-rw-r--r--test/monniaux/binary_search/Makefile4
-rw-r--r--test/monniaux/binary_search/binary_search.c17
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized01204
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized02203
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized03291
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized04288
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized05287
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized06287
-rw-r--r--test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized07372
-rw-r--r--test/monniaux/binary_search/make.proto2
-rw-r--r--test/monniaux/bitsliced-aes/Makefile4
-rw-r--r--test/monniaux/bitsliced-aes/bs.c4
-rw-r--r--test/monniaux/bitsliced-aes/bs.ccomp.k1c.s.optimized3268
-rw-r--r--test/monniaux/bitsliced-aes/make.proto4
-rw-r--r--test/monniaux/bitsliced-tea/Makefile3
-rw-r--r--test/monniaux/bitsliced-tea/bstea.h11
-rw-r--r--test/monniaux/bitsliced-tea/make.proto4
-rwxr-xr-xtest/monniaux/build_benches.sh21
-rw-r--r--test/monniaux/builtins/fma.c14
-rwxr-xr-xtest/monniaux/clean_benches.sh6
-rw-r--r--test/monniaux/clock.c4
-rw-r--r--test/monniaux/complex/Makefile4
-rw-r--r--test/monniaux/complex/complex_mat.c6
-rw-r--r--test/monniaux/complex/make.proto2
-rw-r--r--test/monniaux/cse2/loopaccess.c7
-rw-r--r--test/monniaux/cse2/loopinvariant.c7
-rw-r--r--test/monniaux/cse2/loopload.c5
-rw-r--r--test/monniaux/csmith/Makefile4
-rw-r--r--test/monniaux/cycles.h87
-rw-r--r--test/monniaux/float_mat/Makefile4
-rw-r--r--test/monniaux/float_mat/float_mat_run.c16
-rw-r--r--test/monniaux/float_mat/make.proto3
-rw-r--r--test/monniaux/genann/Makefile4
-rw-r--r--test/monniaux/genann/example/iris.data150
-rw-r--r--test/monniaux/genann/example4shorter.c141
-rw-r--r--test/monniaux/genann/genann.c415
-rw-r--r--test/monniaux/genann/genann.h109
-rwxr-xr-xtest/monniaux/generate_makefiles.sh8
-rwxr-xr-xtest/monniaux/gengraphs.py94
-rwxr-xr-xtest/monniaux/genmake.py136
-rw-r--r--test/monniaux/glibc_qsort/Makefile3
-rw-r--r--test/monniaux/glibc_qsort/glibc_qsort_run.c2
-rw-r--r--test/monniaux/glibc_qsort/make.proto3
-rw-r--r--test/monniaux/glpk-4.65/Makefile6
-rw-r--r--test/monniaux/glpk-4.65/config.h31
-rw-r--r--test/monniaux/glpk-4.65/examples/glpsol.c1598
-rw-r--r--test/monniaux/glpk-4.65/examples/prod.mod331
-rw-r--r--test/monniaux/glpk-4.65/src/amd/COPYING502
-rw-r--r--test/monniaux/glpk-4.65/src/amd/README58
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd.h67
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_1.c181
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_2.c1842
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_aat.c185
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_control.c64
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_defaults.c38
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_dump.c180
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_info.c120
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_internal.h117
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_order.c200
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_post_tree.c121
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_postorder.c207
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_preprocess.c119
-rw-r--r--test/monniaux/glpk-4.65/src/amd/amd_valid.c93
-rw-r--r--test/monniaux/glpk-4.65/src/api/advbas.c155
-rw-r--r--test/monniaux/glpk-4.65/src/api/asnhall.c163
-rw-r--r--test/monniaux/glpk-4.65/src/api/asnlp.c104
-rw-r--r--test/monniaux/glpk-4.65/src/api/asnokalg.c154
-rw-r--r--test/monniaux/glpk-4.65/src/api/ckasn.c78
-rw-r--r--test/monniaux/glpk-4.65/src/api/ckcnf.c82
-rw-r--r--test/monniaux/glpk-4.65/src/api/cplex.c1283
-rw-r--r--test/monniaux/glpk-4.65/src/api/cpp.c185
-rw-r--r--test/monniaux/glpk-4.65/src/api/cpxbas.c269
-rw-r--r--test/monniaux/glpk-4.65/src/api/graph.c504
-rw-r--r--test/monniaux/glpk-4.65/src/api/gridgen.c769
-rw-r--r--test/monniaux/glpk-4.65/src/api/intfeas1.c267
-rw-r--r--test/monniaux/glpk-4.65/src/api/maxffalg.c130
-rw-r--r--test/monniaux/glpk-4.65/src/api/maxflp.c114
-rw-r--r--test/monniaux/glpk-4.65/src/api/mcflp.c114
-rw-r--r--test/monniaux/glpk-4.65/src/api/mcfokalg.c221
-rw-r--r--test/monniaux/glpk-4.65/src/api/mcfrelax.c251
-rw-r--r--test/monniaux/glpk-4.65/src/api/minisat1.c161
-rw-r--r--test/monniaux/glpk-4.65/src/api/mpl.c269
-rw-r--r--test/monniaux/glpk-4.65/src/api/mps.c1452
-rw-r--r--test/monniaux/glpk-4.65/src/api/netgen.c1020
-rw-r--r--test/monniaux/glpk-4.65/src/api/npp.c143
-rw-r--r--test/monniaux/glpk-4.65/src/api/pript.c186
-rw-r--r--test/monniaux/glpk-4.65/src/api/prmip.c155
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob.h286
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob1.c1588
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob2.c491
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob3.c166
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob4.c156
-rw-r--r--test/monniaux/glpk-4.65/src/api/prob5.c168
-rw-r--r--test/monniaux/glpk-4.65/src/api/prrngs.c302
-rw-r--r--test/monniaux/glpk-4.65/src/api/prsol.c202
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdasn.c164
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdcc.c162
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdcnf.c136
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdipt.c185
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdmaxf.c163
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdmcf.c186
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdmip.c172
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdprob.c377
-rw-r--r--test/monniaux/glpk-4.65/src/api/rdsol.c225
-rw-r--r--test/monniaux/glpk-4.65/src/api/rmfgen.c368
-rw-r--r--test/monniaux/glpk-4.65/src/api/strong.c110
-rw-r--r--test/monniaux/glpk-4.65/src/api/topsort.c123
-rw-r--r--test/monniaux/glpk-4.65/src/api/wcliqex.c122
-rw-r--r--test/monniaux/glpk-4.65/src/api/weak.c150
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrasn.c107
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrcc.c102
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrcnf.c87
-rw-r--r--test/monniaux/glpk-4.65/src/api/wript.c124
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrmaxf.c104
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrmcf.c122
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrmip.c122
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrprob.c166
-rw-r--r--test/monniaux/glpk-4.65/src/api/wrsol.c174
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/btf.c569
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/btf.h207
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/btfint.c407
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/btfint.h73
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/fhv.c586
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/fhv.h114
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/fhvint.c168
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/fhvint.h78
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/ifu.c392
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/ifu.h99
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/luf.c713
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/luf.h227
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/lufint.c182
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/lufint.h73
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/scf.c523
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/scf.h211
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/scfint.c255
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/scfint.h89
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/sgf.c1443
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/sgf.h203
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/sva.c572
-rw-r--r--test/monniaux/glpk-4.65/src/bflib/sva.h161
-rw-r--r--test/monniaux/glpk-4.65/src/colamd/COPYING502
-rw-r--r--test/monniaux/glpk-4.65/src/colamd/README98
-rw-r--r--test/monniaux/glpk-4.65/src/colamd/colamd.c3622
-rw-r--r--test/monniaux/glpk-4.65/src/colamd/colamd.h69
-rw-r--r--test/monniaux/glpk-4.65/src/draft/bfd.c544
-rw-r--r--test/monniaux/glpk-4.65/src/draft/bfd.h107
-rw-r--r--test/monniaux/glpk-4.65/src/draft/bfx.c89
-rw-r--r--test/monniaux/glpk-4.65/src/draft/bfx.h67
-rw-r--r--test/monniaux/glpk-4.65/src/draft/draft.h22
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi06.c860
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi07.c499
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi08.c388
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi09.c798
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi10.c305
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi12.c2185
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpapi13.c710
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glphbm.c533
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glphbm.h127
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios01.c1685
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios02.c826
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios03.c1512
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios07.c551
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios09.c664
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios11.c435
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpios12.c177
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpipm.c1144
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpipm.h36
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpmat.c924
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpmat.h198
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glprgr.c173
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glprgr.h34
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpscl.c478
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpspm.c847
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpspm.h165
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpssx.h437
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpssx01.c839
-rw-r--r--test/monniaux/glpk-4.65/src/draft/glpssx02.c523
-rw-r--r--test/monniaux/glpk-4.65/src/draft/ios.h547
-rw-r--r--test/monniaux/glpk-4.65/src/draft/lux.c1030
-rw-r--r--test/monniaux/glpk-4.65/src/draft/lux.h220
-rw-r--r--test/monniaux/glpk-4.65/src/env/alloc.c252
-rw-r--r--test/monniaux/glpk-4.65/src/env/dlsup.c167
-rw-r--r--test/monniaux/glpk-4.65/src/env/env.c316
-rw-r--r--test/monniaux/glpk-4.65/src/env/env.h274
-rw-r--r--test/monniaux/glpk-4.65/src/env/error.c200
-rw-r--r--test/monniaux/glpk-4.65/src/env/stdc.c98
-rw-r--r--test/monniaux/glpk-4.65/src/env/stdc.h73
-rw-r--r--test/monniaux/glpk-4.65/src/env/stdout.c262
-rw-r--r--test/monniaux/glpk-4.65/src/env/stream.c517
-rw-r--r--test/monniaux/glpk-4.65/src/env/time.c150
-rw-r--r--test/monniaux/glpk-4.65/src/env/tls.c128
-rw-r--r--test/monniaux/glpk-4.65/src/glpk.h1175
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/cfg.c409
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/cfg.h138
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/cfg1.c703
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/cfg2.c91
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/clqcut.c134
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/covgen.c885
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/fpump.c360
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/gmicut.c284
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/gmigen.c142
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/mirgen.c1529
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/spv.c303
-rw-r--r--test/monniaux/glpk-4.65/src/intopt/spv.h83
-rw-r--r--test/monniaux/glpk-4.65/src/minisat/LICENSE20
-rw-r--r--test/monniaux/glpk-4.65/src/minisat/README22
-rw-r--r--test/monniaux/glpk-4.65/src/minisat/minisat.c1315
-rw-r--r--test/monniaux/glpk-4.65/src/minisat/minisat.h230
-rw-r--r--test/monniaux/glpk-4.65/src/misc/avl.c405
-rw-r--r--test/monniaux/glpk-4.65/src/misc/avl.h73
-rw-r--r--test/monniaux/glpk-4.65/src/misc/bignum.c286
-rw-r--r--test/monniaux/glpk-4.65/src/misc/bignum.h37
-rw-r--r--test/monniaux/glpk-4.65/src/misc/dimacs.c147
-rw-r--r--test/monniaux/glpk-4.65/src/misc/dimacs.h81
-rw-r--r--test/monniaux/glpk-4.65/src/misc/dmp.c243
-rw-r--r--test/monniaux/glpk-4.65/src/misc/dmp.h63
-rw-r--r--test/monniaux/glpk-4.65/src/misc/ffalg.c221
-rw-r--r--test/monniaux/glpk-4.65/src/misc/ffalg.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/fp2rat.c164
-rw-r--r--test/monniaux/glpk-4.65/src/misc/fvs.c137
-rw-r--r--test/monniaux/glpk-4.65/src/misc/fvs.h76
-rw-r--r--test/monniaux/glpk-4.65/src/misc/gcd.c102
-rw-r--r--test/monniaux/glpk-4.65/src/misc/jd.c152
-rw-r--r--test/monniaux/glpk-4.65/src/misc/jd.h32
-rw-r--r--test/monniaux/glpk-4.65/src/misc/keller.c235
-rw-r--r--test/monniaux/glpk-4.65/src/misc/keller.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/ks.c466
-rw-r--r--test/monniaux/glpk-4.65/src/misc/ks.h44
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mc13d.c314
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mc13d.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mc21a.c301
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mc21a.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/misc.h61
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mt1.c1110
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mt1.f277
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mt1.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mygmp.c1162
-rw-r--r--test/monniaux/glpk-4.65/src/misc/mygmp.h254
-rw-r--r--test/monniaux/glpk-4.65/src/misc/okalg.c382
-rw-r--r--test/monniaux/glpk-4.65/src/misc/okalg.h35
-rw-r--r--test/monniaux/glpk-4.65/src/misc/qmd.c584
-rw-r--r--test/monniaux/glpk-4.65/src/misc/qmd.h58
-rw-r--r--test/monniaux/glpk-4.65/src/misc/relax4.c2850
-rw-r--r--test/monniaux/glpk-4.65/src/misc/relax4.h102
-rw-r--r--test/monniaux/glpk-4.65/src/misc/rng.c227
-rw-r--r--test/monniaux/glpk-4.65/src/misc/rng.h67
-rw-r--r--test/monniaux/glpk-4.65/src/misc/rng1.c73
-rw-r--r--test/monniaux/glpk-4.65/src/misc/round2n.c64
-rw-r--r--test/monniaux/glpk-4.65/src/misc/str2int.c92
-rw-r--r--test/monniaux/glpk-4.65/src/misc/str2num.c110
-rw-r--r--test/monniaux/glpk-4.65/src/misc/strspx.c60
-rw-r--r--test/monniaux/glpk-4.65/src/misc/strtrim.c62
-rw-r--r--test/monniaux/glpk-4.65/src/misc/triang.c311
-rw-r--r--test/monniaux/glpk-4.65/src/misc/triang.h34
-rw-r--r--test/monniaux/glpk-4.65/src/misc/wclique.c242
-rw-r--r--test/monniaux/glpk-4.65/src/misc/wclique.h33
-rw-r--r--test/monniaux/glpk-4.65/src/misc/wclique1.c317
-rw-r--r--test/monniaux/glpk-4.65/src/misc/wclique1.h34
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl.h2598
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl1.c4718
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl2.c1202
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl3.c6100
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl4.c1426
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl5.c566
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mpl6.c1039
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mplsql.c1659
-rw-r--r--test/monniaux/glpk-4.65/src/mpl/mplsql.h63
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp.h645
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp1.c937
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp2.c1433
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp3.c2861
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp4.c1414
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp5.c809
-rw-r--r--test/monniaux/glpk-4.65/src/npp/npp6.c1500
-rw-r--r--test/monniaux/glpk-4.65/src/proxy/main.c.disabled87
-rw-r--r--test/monniaux/glpk-4.65/src/proxy/proxy.c1073
-rw-r--r--test/monniaux/glpk-4.65/src/proxy/proxy.h36
-rw-r--r--test/monniaux/glpk-4.65/src/proxy/proxy1.c88
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/simplex.h39
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxat.c265
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxat.h80
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxchuzc.c381
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxchuzc.h85
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxchuzr.c594
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxchuzr.h77
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxlp.c819
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxlp.h234
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxnt.c303
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxnt.h96
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxprim.c1860
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxprob.c679
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spxprob.h64
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spychuzc.c567
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spychuzc.h85
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spychuzr.c483
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spychuzr.h97
-rw-r--r--test/monniaux/glpk-4.65/src/simplex/spydual.c2101
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/README45
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/adler32.c169
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/compress.c80
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/crc32.c442
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/crc32.h441
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/deflate.c1834
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/deflate.h342
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/gzclose.c25
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/gzguts.h74
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/gzlib.c537
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/gzread.c653
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/gzwrite.c531
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inffast.c340
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inffast.h11
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inffixed.h94
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inflate.c1480
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inflate.h122
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inftrees.c330
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/inftrees.h62
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/trees.c1244
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/trees.h128
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/uncompr.c59
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zconf.h168
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zio.c92
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zio.h37
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zlib.h1613
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zutil.c318
-rw-r--r--test/monniaux/glpk-4.65/src/zlib/zutil.h93
-rw-r--r--test/monniaux/heapsort/Makefile3
-rw-r--r--test/monniaux/heapsort/heapsort_run.c2
-rw-r--r--test/monniaux/heapsort/make.proto3
-rw-r--r--test/monniaux/heptagon_radio_transmitter/Makefile3
-rw-r--r--test/monniaux/idea/Makefile3
-rw-r--r--test/monniaux/idea/make.proto2
-rw-r--r--test/monniaux/jpeg-6b/Makefile365
-rw-r--r--test/monniaux/jpeg-6b/Makefile.orig319
-rw-r--r--test/monniaux/jpeg-6b/cjpeg.c13
-rw-r--r--test/monniaux/jpeg-6b/djpeg.c14
-rw-r--r--test/monniaux/latency/latency.s27
-rw-r--r--test/monniaux/lustrev4_lustrec_heater_control/Makefile3
-rw-r--r--test/monniaux/lustrev4_lustrec_heater_control/arrow.h34
-rw-r--r--test/monniaux/lustrev4_lustrec_heater_control/heater_control.h2
-rw-r--r--test/monniaux/lustrev4_lustrec_heater_control/heater_control.lus126
-rw-r--r--test/monniaux/lustrev4_lv4_heater_control/Makefile3
-rw-r--r--test/monniaux/lustrev4_lv4_heater_control/make.proto3
-rw-r--r--test/monniaux/lustrev4_lv6-en-2cgc_heater_control/Makefile3
-rw-r--r--test/monniaux/lustrev6-convertible-en-2cgc/Makefile3
-rw-r--r--test/monniaux/minisat/LICENSE20
-rw-r--r--test/monniaux/minisat/Makefile36
-rw-r--r--test/monniaux/minisat/README15
-rw-r--r--test/monniaux/minisat/main.c222
-rw-r--r--test/monniaux/minisat/make.proto2
-rw-r--r--test/monniaux/minisat/solver.c1191
-rw-r--r--test/monniaux/minisat/solver.h137
l---------test/monniaux/minisat/sudoku.sat1
-rw-r--r--test/monniaux/minisat/vec.h84
-rw-r--r--test/monniaux/moves/array.c18
-rw-r--r--test/monniaux/ncompress/Makefile54
-rw-r--r--test/monniaux/number_theoretic_transform/Makefile3
-rw-r--r--test/monniaux/number_theoretic_transform/make.proto2
-rw-r--r--test/monniaux/ocaml/Makefile29
-rw-r--r--test/monniaux/ocaml/byterun/caml/version.h6
-rw-r--r--test/monniaux/ocaml/byterun/prims.c1153
-rw-r--r--test/monniaux/ocaml/config/Makefile2
-rw-r--r--test/monniaux/pcre2-10.32/Makefile38
-rw-r--r--test/monniaux/pcre2-10.32/bsp_frequency.c1
-rw-r--r--test/monniaux/pcre2-10.32/pcre2test.c2
-rw-r--r--test/monniaux/pcre2-10.32/testdata/testinput618
-rw-r--r--test/monniaux/picosat-965/Makefile40
-rw-r--r--test/monniaux/predicated/predicated.s13
-rw-r--r--test/monniaux/quicksort/Makefile3
-rw-r--r--test/monniaux/quicksort/make.proto3
-rw-r--r--test/monniaux/quicksort/quicksort_run.c2
-rw-r--r--test/monniaux/rules.mk223
-rwxr-xr-xtest/monniaux/run_benches.sh15
-rw-r--r--test/monniaux/sandbox/Makefile148
-rw-r--r--test/monniaux/sandbox/example.c42
-rw-r--r--test/monniaux/sandbox/f.c3
-rw-r--r--test/monniaux/sandbox/f.h1
-rw-r--r--test/monniaux/sandbox/sha-256.c387
-rw-r--r--test/monniaux/sandbox/sha-256.h2
-rw-r--r--test/monniaux/sandbox/sha-256_run.c286
-rw-r--r--test/monniaux/sha-2/Makefile3
-rw-r--r--test/monniaux/sha-2/make.proto3
-rw-r--r--test/monniaux/sha-2/sha-256_run.c2
-rw-r--r--test/monniaux/tacle-bench-lift/Makefile4
-rw-r--r--test/monniaux/tacle-bench-lift/make.proto4
-rw-r--r--test/monniaux/tacle-bench-powerwindow/Makefile4
-rw-r--r--test/monniaux/tacle-bench-powerwindow/make.proto8
-rw-r--r--test/monniaux/ternary.h23
-rw-r--r--test/monniaux/tiff-4.0.10/Makefile7
-rw-r--r--test/monniaux/tiff-4.0.10/example_bw.pbmbin0 -> 18262 bytes
-rw-r--r--test/monniaux/tiff-4.0.10/example_bw.pbm.bz2bin0 -> 4301 bytes
-rw-r--r--test/monniaux/tiff-4.0.10/make.proto4
-rw-r--r--test/monniaux/tiff-4.0.10/ppm2tiff.c411
-rw-r--r--test/monniaux/tiff-4.0.10/t4.h290
-rw-r--r--test/monniaux/tiff-4.0.10/tif_aux.c374
-rw-r--r--test/monniaux/tiff-4.0.10/tif_close.c138
-rw-r--r--test/monniaux/tiff-4.0.10/tif_codec.c171
-rw-r--r--test/monniaux/tiff-4.0.10/tif_color.c307
-rw-r--r--test/monniaux/tiff-4.0.10/tif_compress.c302
-rw-r--r--test/monniaux/tiff-4.0.10/tif_config.h369
-rw-r--r--test/monniaux/tiff-4.0.10/tif_config.vc.h137
-rw-r--r--test/monniaux/tiff-4.0.10/tif_config.wince.h69
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dir.c1768
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dir.h311
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dirinfo.c1081
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dirread.c5874
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dirwrite.c3025
-rw-r--r--test/monniaux/tiff-4.0.10/tif_dumpmode.c141
-rw-r--r--test/monniaux/tiff-4.0.10/tif_error.c86
-rw-r--r--test/monniaux/tiff-4.0.10/tif_extension.c116
-rw-r--r--test/monniaux/tiff-4.0.10/tif_fax3.c1646
-rw-r--r--test/monniaux/tiff-4.0.10/tif_fax3.h538
-rw-r--r--test/monniaux/tiff-4.0.10/tif_fax3sm.c1260
-rw-r--r--test/monniaux/tiff-4.0.10/tif_flush.c116
-rw-r--r--test/monniaux/tiff-4.0.10/tif_getimage.c3046
-rw-r--r--test/monniaux/tiff-4.0.10/tif_jbig.c232
-rw-r--r--test/monniaux/tiff-4.0.10/tif_jpeg.c2599
-rw-r--r--test/monniaux/tiff-4.0.10/tif_jpeg_12.c69
-rw-r--r--test/monniaux/tiff-4.0.10/tif_luv.c1765
-rw-r--r--test/monniaux/tiff-4.0.10/tif_lzma.c500
-rw-r--r--test/monniaux/tiff-4.0.10/tif_lzw.c1230
-rw-r--r--test/monniaux/tiff-4.0.10/tif_next.c187
-rw-r--r--test/monniaux/tiff-4.0.10/tif_ojpeg.c2561
-rw-r--r--test/monniaux/tiff-4.0.10/tif_open.c723
-rw-r--r--test/monniaux/tiff-4.0.10/tif_packbits.c309
-rw-r--r--test/monniaux/tiff-4.0.10/tif_pixarlog.c1483
-rw-r--r--test/monniaux/tiff-4.0.10/tif_predict.c879
-rw-r--r--test/monniaux/tiff-4.0.10/tif_predict.h81
-rw-r--r--test/monniaux/tiff-4.0.10/tif_print.c720
-rw-r--r--test/monniaux/tiff-4.0.10/tif_read.c1577
-rw-r--r--test/monniaux/tiff-4.0.10/tif_strip.c387
-rw-r--r--test/monniaux/tiff-4.0.10/tif_swab.c310
-rw-r--r--test/monniaux/tiff-4.0.10/tif_thunder.c206
-rw-r--r--test/monniaux/tiff-4.0.10/tif_tile.c320
-rw-r--r--test/monniaux/tiff-4.0.10/tif_unix.c384
-rw-r--r--test/monniaux/tiff-4.0.10/tif_version.c39
-rw-r--r--test/monniaux/tiff-4.0.10/tif_warning.c87
-rw-r--r--test/monniaux/tiff-4.0.10/tif_webp.c684
-rw-r--r--test/monniaux/tiff-4.0.10/tif_write.c834
-rw-r--r--test/monniaux/tiff-4.0.10/tif_zip.c474
-rw-r--r--test/monniaux/tiff-4.0.10/tif_zstd.c440
-rw-r--r--test/monniaux/tiff-4.0.10/tiff.h695
-rw-r--r--test/monniaux/tiff-4.0.10/tiffconf.h119
-rw-r--r--test/monniaux/tiff-4.0.10/tiffconf.vc.h152
-rw-r--r--test/monniaux/tiff-4.0.10/tiffconf.wince.h110
-rw-r--r--test/monniaux/tiff-4.0.10/tiffio.h558
-rw-r--r--test/monniaux/tiff-4.0.10/tiffiop.h454
-rw-r--r--test/monniaux/tiff-4.0.10/tiffvers.h9
-rw-r--r--test/monniaux/tiff-4.0.10/uvcode.h180
-rw-r--r--test/monniaux/too_slow/Makefile3
-rw-r--r--test/monniaux/too_slow/make.proto3
-rwxr-xr-xtest/monniaux/vocabulary.sh2
-rw-r--r--test/monniaux/xor_and_mat/Makefile23
-rw-r--r--test/monniaux/xor_and_mat/int_mat_run.c46
-rw-r--r--test/monniaux/yarpgen/Makefile130
-rw-r--r--test/monniaux/yarpgen/Makefile.old52
-rw-r--r--test/monniaux/zlib-1.2.11/Makefile62
-rw-r--r--test/monniaux/zlib-1.2.11/adler32.c186
-rw-r--r--test/monniaux/zlib-1.2.11/compress.c86
-rw-r--r--test/monniaux/zlib-1.2.11/crc32.c442
-rw-r--r--test/monniaux/zlib-1.2.11/crc32.h441
-rw-r--r--test/monniaux/zlib-1.2.11/deflate.c2163
-rw-r--r--test/monniaux/zlib-1.2.11/deflate.h349
-rw-r--r--test/monniaux/zlib-1.2.11/gzclose.c25
-rw-r--r--test/monniaux/zlib-1.2.11/gzguts.h218
-rw-r--r--test/monniaux/zlib-1.2.11/gzlib.c637
-rw-r--r--test/monniaux/zlib-1.2.11/gzread.c654
-rw-r--r--test/monniaux/zlib-1.2.11/gzwrite.c665
-rw-r--r--test/monniaux/zlib-1.2.11/infback.c640
-rw-r--r--test/monniaux/zlib-1.2.11/inffast.c323
-rw-r--r--test/monniaux/zlib-1.2.11/inffast.h11
-rw-r--r--test/monniaux/zlib-1.2.11/inffixed.h94
-rw-r--r--test/monniaux/zlib-1.2.11/inflate.c1561
-rw-r--r--test/monniaux/zlib-1.2.11/inflate.h125
-rw-r--r--test/monniaux/zlib-1.2.11/inftrees.c304
-rw-r--r--test/monniaux/zlib-1.2.11/inftrees.h62
-rw-r--r--test/monniaux/zlib-1.2.11/make.proto4
-rw-r--r--test/monniaux/zlib-1.2.11/minigzip.c663
-rw-r--r--test/monniaux/zlib-1.2.11/trees.c1203
-rw-r--r--test/monniaux/zlib-1.2.11/trees.h128
-rw-r--r--test/monniaux/zlib-1.2.11/uncompr.c93
-rw-r--r--test/monniaux/zlib-1.2.11/zconf.h534
-rw-r--r--test/monniaux/zlib-1.2.11/zlib.h1912
-rw-r--r--test/monniaux/zlib-1.2.11/zlib_small.txt539
-rw-r--r--test/monniaux/zlib-1.2.11/zutil.c325
-rw-r--r--test/monniaux/zlib-1.2.11/zutil.h271
m---------test/mppa/asm_coverage0
-rwxr-xr-xtest/mppa/check.sh6
-rwxr-xr-x[-rw-r--r--]test/mppa/coverage.sh21
-rw-r--r--test/mppa/coverage_helper.py70
-rwxr-xr-xtest/mppa/hardcheck.sh6
-rwxr-xr-xtest/mppa/hardtest.sh6
-rw-r--r--test/mppa/instr/Makefile78
-rw-r--r--test/mppa/instr/builtin32.c12
-rw-r--r--test/mppa/instr/builtin64.c17
-rw-r--r--test/mppa/instr/i32.c68
-rw-r--r--test/mppa/instr/i64.c62
-rw-r--r--test/mppa/interop/Makefile141
-rw-r--r--test/mppa/interop/common.c10
-rw-r--r--test/mppa/interop/vaarg_common.c12
-rw-r--r--test/mppa/lib/Makefile4
-rw-r--r--test/mppa/mmult/Makefile2
-rw-r--r--test/mppa/prng/Makefile2
-rwxr-xr-xtest/mppa/simucheck.sh6
-rwxr-xr-xtest/mppa/simutest.sh (renamed from test/mppa/test.sh)2
-rw-r--r--test/mppa/sort/Makefile2
-rw-r--r--test/raytracer/Makefile4
-rw-r--r--test/regression/Makefile18
-rw-r--r--test/regression/Results/builtins-aarch6415
-rw-r--r--test/regression/Results/floats-lit2
-rw-r--r--test/regression/Results/ifconv26
-rw-r--r--test/regression/Results/int64874
-rw-r--r--test/regression/Results/interop18
-rw-r--r--test/regression/Results/varargs2-mppa_k1c11
-rw-r--r--test/regression/builtins-aarch64.c47
-rw-r--r--test/regression/builtins-arm.c11
-rw-r--r--test/regression/builtins-mppa_k1c.c72
-rw-r--r--test/regression/builtins-powerpc.c15
-rw-r--r--test/regression/builtins-riscV.c14
-rw-r--r--test/regression/builtins-x86.c19
-rw-r--r--test/regression/extasm.c24
-rw-r--r--test/regression/floats-basics.c14
-rw-r--r--test/regression/floats-lit.c559
-rw-r--r--test/regression/floats.c12
-rw-r--r--test/regression/ifconv.c149
-rw-r--r--test/regression/int64.c3
-rw-r--r--test/regression/interop1.c15
-rw-r--r--test/regression/packedstruct1.c16
-rw-r--r--test/regression/varargs2.c16
-rw-r--r--test/spass/Makefile5
-rw-r--r--tools/ndfun.ml21
-rw-r--r--tools/xtime.ml101
-rw-r--r--x86/Asm.v11
-rw-r--r--x86/Asmexpand.ml4
-rw-r--r--x86/Asmgen.v45
-rw-r--r--x86/Asmgenproof.v27
-rw-r--r--x86/Asmgenproof1.v172
-rw-r--r--x86/Builtins1.v54
-rw-r--r--x86/CBuiltins.ml9
-rw-r--r--x86/CSE2deps.v24
-rw-r--r--x86/CSE2depsproof.v253
-rw-r--r--x86/ConstpropOp.vp12
-rw-r--r--x86/ConstpropOpproof.v26
-rw-r--r--x86/Conventions1.v187
-rw-r--r--x86/DuplicateOpcodeHeuristic.ml27
-rw-r--r--x86/Machregs.v1
-rw-r--r--x86/NeedOp.v5
-rw-r--r--x86/Op.v117
-rw-r--r--x86/PrintOp.ml4
-rw-r--r--x86/SelectOp.vp64
-rw-r--r--x86/SelectOpproof.v76
-rw-r--r--x86/TargetPrinter.ml52
-rw-r--r--x86/ValueAOp.v23
-rw-r--r--x86_32/Archi.v38
-rw-r--r--x86_64/Archi.v38
1031 files changed, 248508 insertions, 29150 deletions
diff --git a/.gitattributes b/.gitattributes
new file mode 100644
index 00000000..02ab53c1
--- /dev/null
+++ b/.gitattributes
@@ -0,0 +1,3 @@
+# Files that should be ignored by Github linguist
+test/* linguist-vendored
+doc/* linguist-documentation
diff --git a/.gitignore b/.gitignore
index f5911e69..e886bc10 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,6 +5,8 @@
**.out
**.tok
*.vo
+*.vok
+*.vos
*.glob
*.o
*.a
@@ -45,6 +47,12 @@
/riscV/ConstpropOp.v
/riscV/SelectOp.v
/riscV/SelectLong.v
+/mppa_k1c/ConstpropOp.v
+/mppa_k1c/SelectOp.v
+/mppa_k1c/SelectLong.v
+/aarch64/ConstpropOp.v
+/aarch64/SelectOp.v
+/aarch64/SelectLong.v
/backend/SelectDiv.v
/backend/SplitLong.v
/cparser/Parser.v
@@ -78,5 +86,8 @@ runtime/mppa_k1c/i64_udivmod.s
runtime/mppa_k1c/i64_umod.s
# Test generated data
/test/clightgen/*.v
-# Coq cache
+# Coq caches
.lia.cache
+.nia.cache
+.nra.cache
+.csdp.cache
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
new file mode 100644
index 00000000..1f854fc3
--- /dev/null
+++ b/.gitlab-ci.yml
@@ -0,0 +1,240 @@
+stages:
+ - build
+
+check-admitted:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_x86_64.sh
+ - make check-admitted
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_x86_64:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_x86_64.sh
+ - make -j "$NJOBS"
+ - make -C test all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_ia32:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-multilib
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_ia32.sh
+ - make -j "$NJOBS"
+ - make -C test all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen BITS=32 TARGET_CC='gcc -m32'
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_aarch64:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-aarch64-linux-gnu qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_aarch64.sh
+ - make -j "$NJOBS"
+ - make -C test CCOMPOPTS='-static' SIMU='qemu-aarch64' EXECUTE='qemu-aarch64' all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='aarch64-linux-gnu-gcc' EXECUTE='qemu-aarch64' CCOMPOPTS='-static' TARGET_CFLAGS='-static'
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_arm:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-arm-linux-gnueabi qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_arm.sh
+ - make -j "$NJOBS"
+ - make -C test CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabi-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+
+build_armhf:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-arm-linux-gnueabihf qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_armhf.sh
+ - make -j "$NJOBS"
+ - make -C test CCOMPOPTS=-static SIMU='qemu-arm' EXECUTE='qemu-arm' all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='arm-linux-gnueabihf-gcc' EXECUTE='qemu-arm' CCOMPOPTS='-static' TARGET_CFLAGS='-static' BITS=32
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_ppc:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-powerpc-linux-gnu qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_ppc.sh
+ - make -j "$NJOBS"
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_ppc64:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-powerpc64-linux-gnu
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_ppc64.sh
+ - make -j "$NJOBS"
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_rv64:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_rv64.sh
+ - make -j "$NJOBS"
+ - make -C test CCOMPOPTS=-static SIMU='qemu-riscv64' EXECUTE='qemu-riscv64' all test
+ - ulimit -s65536 && make -C test/monniaux/yarpgen TARGET_CC='riscv64-linux-gnu-gcc' EXECUTE='qemu-riscv64' CCOMPOPTS='-static' TARGET_CFLAGS='-static'
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_rv32:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - sudo apt-get -o Acquire::Check-Valid-Until=false -o Acquire::Check-Date=false update
+ - sudo apt-get -y install gcc-riscv64-linux-gnu qemu-user
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_rv32.sh -no-runtime-lib
+ - make -j "$NJOBS"
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
+
+build_k1c:
+ stage: build
+ image: "coqorg/coq"
+ before_script:
+ - opam switch 4.07.1+flambda
+ - eval `opam config env`
+ - opam install -y menhir
+ script:
+ - ./config_k1c.sh -no-runtime-lib
+ - make -j "$NJOBS"
+ rules:
+ - if: '$CI_COMMIT_BRANCH == "mppa-work"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "mppa-k1c"'
+ when: always
+ - if: '$CI_COMMIT_BRANCH == "master"'
+ when: always
+ - when: manual
diff --git a/.gitmodules b/.gitmodules
index 955c7fc2..e69de29b 100644
--- a/.gitmodules
+++ b/.gitmodules
@@ -1,3 +0,0 @@
-[submodule "test/mppa/asm_coverage"]
- path = test/mppa/asm_coverage
- url = git@gricad-gitlab.univ-grenoble-alpes.fr:sixcy/asm-scanner.git
diff --git a/Changelog b/Changelog
index e5e701d0..8cf4e548 100644
--- a/Changelog
+++ b/Changelog
@@ -1,3 +1,103 @@
+Release 3.7, 2020-03-31
+=======================
+
+ISO C conformance:
+- Functions declared `extern` then implemented `inline` remain `extern`
+- The type of a wide char constant is `wchar_t`, not `int`
+- Support vertical tabs and treat them as whitespace
+- Define the semantics of `free(NULL)`
+
+Bug fixing:
+- Take sign into account for conversions from 32-bit integers to 64-bit pointers
+- PowerPC: more precise determination of small data accesses
+- AArch64: when addressing global variables, check for correct alignment
+- PowerPC, ARM: double rounding error in int64->float32 conversions
+
+ABI conformance:
+- x86, AArch64: re-normalize values of small integer types returned by
+ function calls
+- PowerPC: `float` arguments passed on stack are passed in 64-bit format
+- RISC-V: use the new ELF psABI instead of the old ABI from ISA 2.1
+
+Usability and diagnostics:
+- Unknown builtin functions trigger a specific error message
+- Improved error messages
+
+Coq formalization:
+- Revised modeling of the PowerPC/EREF `isel` instruction
+- Weaker `ec_readonly` condition over external calls
+ (permissions can be dropped on read-only locations)
+
+Coq and OCaml development:
+- Compatibility with Coq version 8.10.1, 8.10.2, 8.11.0
+- Compatibility with OCaml 4.10 and up
+- Compatibility with Menhir 20200123 and up
+- Coq versions prior to 8.8.0 are no longer supported
+- OCaml versions prior to 4.05.0 are no longer supported
+
+
+Release 3.6, 2019-09-17
+=======================
+
+New features and optimizations:
+- New port targeting the AArch64 architecture: ARMv8 in 64-bit mode.
+- New optimization: if-conversion. Some `if`/`else` statements
+ and `a ? b : c` conditional expressions are compiled to branchless
+ conditional move instructions, when supported by the target processor
+- New optimization flag: `-Obranchless`, to favor the generation of
+ branchless instruction sequences, even if probably slower than branches.
+- Built-in functions can now be given a formal semantics within
+ CompCert, instead of being treated as I/O interactions.
+ Currently, `__builtin_fsqrt` and `__builtin_bswap*` have semantics.
+- Extend constant propagation and CSE optimizations to built-in
+ functions that have known semantics.
+- New "polymorphic" built-in function: `__builtin_sel(a,b,c)`.
+ Similar to `a ? b : c` but `b` and `c` are always evaluated,
+ and a branchless conditional move instruction is produced if possible.
+- x86 64 bits: faster, branchless instruction sequences are produced
+ for conversions between `double` and `unsigned int`.
+- `__builtin_bswap64` is now available for all platforms.
+
+Usability and diagnostics:
+- Improved the DWARF debug information generated in -g mode.
+- Added options -fcommon and -fno-common to control the generation
+ of "common" declarations for uninitialized global.
+- Check for reserved keywords `_Complex` and `_Imaginary`.
+- Reject function declarations with multiple `void` parameters.
+- Define macros `__COMPCERT_MAJOR__`, `__COMPCERT_MINOR__`, and
+ `__COMPCERT_VERSION__` with CompCert's version number. (#284)
+- Prepend `$(DESTDIR)` to the installation target. (#169)
+- Extended inline asm: print register names according to the
+ types of the corresponding arguments (e.g. for x86_64,
+ `%eax` if int and `%rax` if long).
+
+Bug fixing:
+- Introduce distinct scopes for iteration and selection statements,
+ as required by ISO C99.
+- Handle dependencies in sequences of declarations
+ (e.g. `int * x, sz = sizeof(x);`). (#267)
+- Corrected the check for overflow in integer literals.
+- On x86, __builtin_fma was producing wrong code in some cases.
+- `float` arguments to `__builtin_annot` and `__builtin_ais_annot`
+ were uselessly promoted to type `double`.
+
+Coq formalization and development:
+- Improved C parser based on Menhir version 20190626:
+ fewer run-time checks, faster validation, no axioms. (#276)
+- Compatibility with Coq versions 8.9.1 and 8.10.0.
+- Compatibility with OCaml versions 4.08.0 and 4.08.1.
+- Updated to Flocq version 3.1.
+- Revised the construction of NaN payloads in processor descriptions
+ so as to accommodate FMA.
+- Removed some definitions and lemmas from lib/Coqlib.v, using Coq's
+ standard library instead.
+
+The clightgen tool:
+- Fix normalization of Clight `switch` statements. (#285)
+- Add more tracing options: `-dprepro`, `-dall`. (#298)
+- Fix the output of `-dclight`. (#314)
+
+
Release 3.5, 2019-02-27
=======================
diff --git a/INSTALL.md b/INSTALL.md
new file mode 100644
index 00000000..bcfec78f
--- /dev/null
+++ b/INSTALL.md
@@ -0,0 +1,62 @@
+# CompCert Install Instructions
+
+## Dependencies
+### Additional dependencies
+Replace with the package manager for your distribution
+```
+sudo <pkg-manager> install -y mercurial darcs ocaml
+
+```
+
+### Opam
+```
+sh <(curl -sL https://raw.githubusercontent.com/ocaml/opam/master/shell/install.sh)
+```
+
+## Post-install
+Run
+```
+eval `opam config env`
+```
+Add this to your `.bashrc` or `.bash_profile`
+```
+. /nfs/home/mschuh/.opam/opam-init/init.sh > /dev/null 2> /dev/null || true
+```
+Switch to last compiler version
+```
+opam switch 4.07.0
+```
+Install dependecies available through opam
+```
+opam install coq menhir
+```
+
+## Compilation
+Pre-compilation configure replace the placeholder with your desired platform
+(for Kalray it is k1c-cos or k1c-mbr)
+```
+./configure <platform>
+```
+If using Kalray's platform, make sure that the k1 tools are on your path
+Compile (adapt -j# to the number of cores and available RAM)
+```
+make -j12
+make install
+```
+
+## Utilization
+`ccomp` binaries are installed at `$(HOME)/.usr/bin`
+Make sure to add that to your path to ease its use
+Now you may use it like a regular compiler
+```
+ccomp -O3 test.c -S
+ccomp -O3 test.c -o test.bin
+```
+
+## Changing platform
+If you decide to change the platform, for instance from k1c-cos to k1c-mbr, you
+should change the `compcert.ini` file with the respective tools and then run
+```
+make install
+```
+
diff --git a/INSTALL_CROSS.md b/INSTALL_CROSS.md
new file mode 100644
index 00000000..0c2fce60
--- /dev/null
+++ b/INSTALL_CROSS.md
@@ -0,0 +1,5 @@
+It is possible to compile Coq on one architecture and then the resulting OCaml on another architecture.
+
+- Remove all '*.cm*' files.
+- Fix the path to MenhirLib in Makefile.config
+- make again
diff --git a/LICENSE b/LICENSE
index 5c7d7294..5a7ae79f 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,6 +1,6 @@
All files in this distribution are part of the CompCert verified compiler.
-The CompCert verified compiler is Copyright by Institut National de
+The CompCert verified compiler is Copyright by Institut National de
Recherche en Informatique et en Automatique (INRIA) and
AbsInt Angewandte Informatik GmbH.
@@ -9,12 +9,12 @@ INRIA Non-Commercial License Agreement given below or under the terms
of a Software Usage Agreement of AbsInt Angewandte Informatik GmbH.
The latter is a separate contract document.
-The INRIA Non-Commercial License Agreement is a non-free license that
-grants you the right to use the CompCert verified compiler for
-educational, research or evaluation purposes only, but prohibits
+The INRIA Non-Commercial License Agreement is a non-free license that
+grants you the right to use the CompCert verified compiler for
+educational, research or evaluation purposes only, but prohibits
any commercial use.
-For commercial use you need a Software Usage Agreement from
+For commercial use you need a Software Usage Agreement from
AbsInt Angewandte Informatik GmbH.
The following files in this distribution are dual-licensed both under
@@ -38,7 +38,7 @@ option) any later version:
cfrontend/Ctyping.v
cfrontend/PrintClight.ml
cfrontend/PrintCsyntax.ml
-
+
backend/Cminor.v
backend/PrintCminor.ml
@@ -46,7 +46,7 @@ option) any later version:
all files in the exportclight/ directory
- the Archi.v, CBuiltins.ml, and extractionMachdep.v files
+ the Archi.v, CBuiltins.ml, and extractionMachdep.v files
in directories arm, powerpc, riscV, x86, x86_32, x86_64
extraction/extraction.v
@@ -64,11 +64,14 @@ non-commercial contexts, subject to the terms of the GNU General
Public License.
The files contained in the flocq/ directory and its subdirectories are
-taken from the Flocq project, http://flocq.gforge.inria.fr/
-These files are Copyright 2010-2017 INRIA and distributed under the
-terms of the GNU Lesser General Public Licence, either version 3 of
-the licence, or (at your option) any later version. A copy of the GNU
-Lesser General Public Licence version 3 is included below.
+taken from the Flocq project, http://flocq.gforge.inria.fr/. The files
+contained in the MenhirLib directory are taken from the Menhir
+project, http://gallium.inria.fr/~fpottier/menhir/. The files from the
+Flocq project and the files in the MenhirLib directory are Copyright
+2010-2019 INRIA and distributed under the terms of the GNU Lesser
+General Public Licence, either version 3 of the licence, or (at your
+option) any later version. A copy of the GNU Lesser General Public
+Licence version 3 is included below.
The files contained in the runtime/ directory and its subdirectories
are Copyright 2013-2017 INRIA and distributed under the terms of the BSD
diff --git a/Makefile b/Makefile
index d8cd428a..2cd40800 100644
--- a/Makefile
+++ b/Makefile
@@ -24,13 +24,15 @@ endif
BACKENDLIB?=Asmgenproof0.v Asmgenproof1.v
DIRS=lib common $(ARCHDIRS) backend cfrontend driver \
- flocq/Core flocq/Prop flocq/Calc flocq/Appli exportclight \
- cparser cparser/MenhirLib
+ flocq/Core flocq/Prop flocq/Calc flocq/IEEE754 \
+ exportclight MenhirLib cparser
-RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight cparser
+RECDIRS=lib common $(ARCHDIRS) backend cfrontend driver flocq exportclight \
+ MenhirLib cparser
COQINCLUDES=$(foreach d, $(RECDIRS), -R $(d) $(subst /,.,compcert.$(d)))
+COQCOPTS ?= -w -undeclared-scope
COQC="$(COQBIN)coqc" -q $(COQINCLUDES) $(COQCOPTS)
COQDEP="$(COQBIN)coqdep" $(COQINCLUDES)
COQDOC="$(COQBIN)coqdoc"
@@ -45,20 +47,17 @@ GPATH=$(DIRS)
# Flocq
FLOCQ=\
- Fcore_Raux.v Fcore_Zaux.v Fcore_defs.v Fcore_digits.v \
- Fcore_float_prop.v Fcore_FIX.v Fcore_FLT.v Fcore_FLX.v \
- Fcore_FTZ.v Fcore_generic_fmt.v Fcore_rnd.v Fcore_rnd_ne.v \
- Fcore_ulp.v Fcore.v \
- Fcalc_bracket.v Fcalc_digits.v Fcalc_div.v Fcalc_ops.v \
- Fcalc_round.v Fcalc_sqrt.v \
- Fprop_div_sqrt_error.v Fprop_mult_error.v Fprop_plus_error.v \
- Fprop_relative.v Fprop_Sterbenz.v \
- Fappli_rnd_odd.v Fappli_double_round.v Fappli_IEEE.v Fappli_IEEE_bits.v
+ Raux.v Zaux.v Defs.v Digits.v Float_prop.v FIX.v FLT.v FLX.v FTZ.v \
+ Generic_fmt.v Round_pred.v Round_NE.v Ulp.v Core.v \
+ Bracket.v Div.v Operations.v Round.v Sqrt.v \
+ Div_sqrt_error.v Mult_error.v Plus_error.v \
+ Relative.v Sterbenz.v Round_odd.v Double_rounding.v \
+ Binary.v Bits.v
# General-purpose libraries (in lib/)
VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \
- Iteration.v Integers.v Archi.v Fappli_IEEE_extra.v Floats.v \
+ Iteration.v Zbits.v Integers.v Archi.v IEEE754_extra.v Floats.v \
Parmov.v UnionFind.v Wfsimpl.v \
Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v BoolEqual.v
@@ -67,12 +66,12 @@ VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \
COMMON=Errors.v AST.v Linking.v \
Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \
Values.v Smallstep.v Behaviors.v Switch.v Determinism.v Unityping.v \
- Separation.v
+ Separation.v Builtins0.v Builtins1.v Builtins.v
# Back-end modules (in backend/, $(ARCH)/)
BACKEND=\
- Cminor.v Op.v CminorSel.v OpHelpers.v OpHelpersproof.v \
+ Cminor.v Cminortyping.v Op.v CminorSel.v OpHelpers.v OpHelpersproof.v \
SelectOp.v SelectDiv.v SplitLong.v SelectLong.v Selection.v \
SelectOpproof.v SelectDivproof.v SplitLongproof.v \
SelectLongproof.v Selectionproof.v \
@@ -81,14 +80,19 @@ BACKEND=\
Tailcall.v Tailcallproof.v \
Inlining.v Inliningspec.v Inliningproof.v \
Renumber.v Renumberproof.v \
+ Duplicate.v Duplicateproof.v \
RTLtyping.v \
Kildall.v Liveness.v \
ValueDomain.v ValueAOp.v ValueAnalysis.v \
ConstpropOp.v Constprop.v ConstpropOpproof.v Constpropproof.v \
CSEdomain.v CombineOp.v CSE.v CombineOpproof.v CSEproof.v \
+ CSE2deps.v CSE2depsproof.v \
+ CSE2.v CSE2proof.v \
NeedDomain.v NeedOp.v Deadcode.v Deadcodeproof.v \
Unusedglob.v Unusedglobproof.v \
Machregs.v Locations.v Conventions1.v Conventions.v LTL.v \
+ ForwardMoves.v ForwardMovesproof.v \
+ Allnontrap.v Allnontrapproof.v \
Allocation.v Allocproof.v \
Tunneling.v Tunnelingproof.v \
Linear.v Lineartyping.v \
@@ -109,16 +113,16 @@ CFRONTEND=Ctypes.v Cop.v Csyntax.v Csem.v Ctyping.v Cstrategy.v Cexec.v \
Cshmgen.v Cshmgenproof.v \
Csharpminor.v Cminorgen.v Cminorgenproof.v
-# LR(1) parser validator
-
-PARSERVALIDATOR=Alphabet.v Interpreter_complete.v Interpreter.v \
- Validator_complete.v Automaton.v Interpreter_correct.v Main.v \
- Validator_safe.v Grammar.v Interpreter_safe.v Tuples.v
-
# Parser
PARSER=Cabs.v Parser.v
+# MenhirLib
+
+MENHIRLIB=Alphabet.v Automaton.v Grammar.v Interpreter_complete.v \
+ Interpreter_correct.v Interpreter.v Main.v Validator_complete.v \
+ Validator_safe.v Validator_classes.v
+
# Putting everything together (in driver/)
DRIVER=Compopts.v Compiler.v Complements.v
@@ -126,7 +130,7 @@ DRIVER=Compopts.v Compiler.v Complements.v
# All source files
FILES=$(VLIB) $(COMMON) $(BACKEND) $(CFRONTEND) $(DRIVER) $(FLOCQ) \
- $(PARSERVALIDATOR) $(PARSER)
+ $(MENHIRLIB) $(PARSER)
# Generated source files
@@ -148,7 +152,6 @@ ifeq ($(CLIGHTGEN),true)
$(MAKE) clightgen
endif
-
proof: $(FILES:.v=.vo)
# Turn off some warnings for compiling Flocq
@@ -232,7 +235,7 @@ driver/Version.ml: VERSION
cparser/Parser.v: cparser/Parser.vy
@rm -f $@
- $(MENHIR) $(MENHIR_FLAGS) --coq cparser/Parser.vy
+ $(MENHIR) --coq --coq-lib-path compcert.MenhirLib --coq-no-version-check cparser/Parser.vy
@chmod a-w $@
depend: $(GENERATED) depend1
@@ -242,29 +245,29 @@ depend1: $(FILES) exportclight/Clightdefs.v
@$(COQDEP) $^ > .depend
install:
- install -d $(BINDIR)
- install -m 0755 ./ccomp $(BINDIR)
- install -d $(SHAREDIR)
- install -m 0644 ./compcert.ini $(SHAREDIR)
- install -d $(MANDIR)/man1
- install -m 0644 ./doc/ccomp.1 $(MANDIR)/man1
+ install -d $(DESTDIR)$(BINDIR)
+ install -m 0755 ./ccomp $(DESTDIR)$(BINDIR)
+ install -d $(DESTDIR)$(SHAREDIR)
+ install -m 0644 ./compcert.ini $(DESTDIR)$(SHAREDIR)
+ install -d $(DESTDIR)$(MANDIR)/man1
+ install -m 0644 ./doc/ccomp.1 $(DESTDIR)$(MANDIR)/man1
$(MAKE) -C runtime install
ifeq ($(CLIGHTGEN),true)
- install -m 0755 ./clightgen $(BINDIR)
+ install -m 0755 ./clightgen $(DESTDIR)$(BINDIR)
endif
ifeq ($(INSTALL_COQDEV),true)
- install -d $(COQDEVDIR)
+ install -d $(DESTDIR)$(COQDEVDIR)
for d in $(DIRS); do \
- install -d $(COQDEVDIR)/$$d && \
- install -m 0644 $$d/*.vo $(COQDEVDIR)/$$d/; \
+ install -d $(DESTDIR)$(COQDEVDIR)/$$d && \
+ install -m 0644 $$d/*.vo $(DESTDIR)$(COQDEVDIR)/$$d/; \
done
- install -m 0644 ./VERSION $(COQDEVDIR)
- @(echo "To use, pass the following to coq_makefile or add the following to _CoqProject:"; echo "-R $(COQDEVDIR) compcert") > $(COQDEVDIR)/README
+ install -m 0644 ./VERSION $(DESTDIR)$(COQDEVDIR)
+ @(echo "To use, pass the following to coq_makefile or add the following to _CoqProject:"; echo "-R $(COQDEVDIR) compcert") > $(DESTDIR)$(COQDEVDIR)/README
endif
clean:
- rm -f $(patsubst %, %/*.vo, $(DIRS))
+ rm -f $(patsubst %, %/*.vo*, $(DIRS))
rm -f $(patsubst %, %/.*.aux, $(DIRS))
rm -rf doc/html doc/*.glob
rm -f driver/Version.ml
diff --git a/Makefile.extr b/Makefile.extr
index d6a94d2e..f2d06def 100644
--- a/Makefile.extr
+++ b/Makefile.extr
@@ -50,12 +50,12 @@ INCLUDES=$(patsubst %,-I %, $(DIRS))
# Control of warnings:
WARNINGS=-w +a-4-9-27-42 -strict-sequence -safe-string -warn-error +a #Deprication returns with ocaml 4.03
-extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45
-extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45
+extraction/%.cmx: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67
+extraction/%.cmo: WARNINGS +=-w -20-27-32..34-39-41-44..45-60-67
cparser/pre_parser.cmx: WARNINGS += -w -41
cparser/pre_parser.cmo: WARNINGS += -w -41
-COMPFLAGS+=-g $(INCLUDES) $(MENHIR_INCLUDES) $(WARNINGS)
+COMPFLAGS+=-g $(INCLUDES) -I "$(MENHIR_DIR)" $(WARNINGS)
# Using .opt compilers if available
diff --git a/Makefile.menhir b/Makefile.menhir
index 98bfc750..7909b2f6 100644
--- a/Makefile.menhir
+++ b/Makefile.menhir
@@ -41,7 +41,11 @@ MENHIR_FLAGS = -v --no-stdlib -la 1
# Using Menhir in --table mode requires MenhirLib.
ifeq ($(MENHIR_TABLE),true)
- MENHIR_LIBS = menhirLib.cmx
+ ifeq ($(wildcard $(MENHIR_DIR)/menhirLib.cmxa),)
+ MENHIR_LIBS = menhirLib.cmx
+ else
+ MENHIR_LIBS = menhirLib.cmxa
+ endif
else
MENHIR_LIBS =
endif
diff --git a/MenhirLib/Alphabet.v b/MenhirLib/Alphabet.v
new file mode 100644
index 00000000..29070e3d
--- /dev/null
+++ b/MenhirLib/Alphabet.v
@@ -0,0 +1,247 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import Omega List Syntax Relations RelationClasses.
+
+Local Obligation Tactic := intros.
+
+(** A comparable type is equiped with a [compare] function, that define an order
+ relation. **)
+Class Comparable (A:Type) := {
+ compare : A -> A -> comparison;
+ compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
+ compare_trans : forall x y z c,
+ (compare x y) = c -> (compare y z) = c -> (compare x z) = c
+}.
+
+Theorem compare_refl {A:Type} (C: Comparable A) :
+ forall x, compare x x = Eq.
+Proof.
+intros.
+pose proof (compare_antisym x x).
+destruct (compare x x); intuition; try discriminate.
+Qed.
+
+(** The corresponding order is a strict order. **)
+Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
+ fun x y => compare x y = Lt.
+
+Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
+ StrictOrder (comparableLt C).
+Proof.
+apply Build_StrictOrder.
+unfold Irreflexive, Reflexive, complement, comparableLt.
+intros.
+pose proof H.
+rewrite <- compare_antisym in H.
+rewrite H0 in H.
+discriminate H.
+unfold Transitive, comparableLt.
+intros x y z.
+apply compare_trans.
+Qed.
+
+(** nat is comparable. **)
+Program Instance natComparable : Comparable nat :=
+ { compare := Nat.compare }.
+Next Obligation.
+symmetry.
+destruct (Nat.compare x y) as [] eqn:?.
+rewrite Nat.compare_eq_iff in Heqc.
+destruct Heqc.
+rewrite Nat.compare_eq_iff.
+trivial.
+rewrite <- nat_compare_lt in *.
+rewrite <- nat_compare_gt in *.
+trivial.
+rewrite <- nat_compare_lt in *.
+rewrite <- nat_compare_gt in *.
+trivial.
+Qed.
+Next Obligation.
+destruct c.
+rewrite Nat.compare_eq_iff in *; destruct H; assumption.
+rewrite <- nat_compare_lt in *.
+apply (Nat.lt_trans _ _ _ H H0).
+rewrite <- nat_compare_gt in *.
+apply (gt_trans _ _ _ H H0).
+Qed.
+
+(** A pair of comparable is comparable. **)
+Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
+ Comparable (A*B) :=
+ { compare := fun x y =>
+ let (xa, xb) := x in let (ya, yb) := y in
+ match compare xa ya return comparison with
+ | Eq => compare xb yb
+ | x => x
+ end }.
+Next Obligation.
+destruct x, y.
+rewrite <- (compare_antisym a a0).
+rewrite <- (compare_antisym b b0).
+destruct (compare a a0); intuition.
+Qed.
+Next Obligation.
+destruct x, y, z.
+destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
+try (rewrite <- H0 in H; discriminate);
+try (destruct (compare a a1) as [] eqn:?;
+ try (rewrite <- compare_antisym in Heqc0;
+ rewrite CompOpp_iff in Heqc0;
+ rewrite (compare_trans _ _ _ _ Heqc0 Heqc2) in Heqc1;
+ discriminate);
+ try (rewrite <- compare_antisym in Heqc1;
+ rewrite CompOpp_iff in Heqc1;
+ rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
+ discriminate);
+ assumption);
+rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
+try assumption.
+apply (compare_trans _ _ _ _ H H0).
+Qed.
+
+(** Special case of comparable, where equality is Leibniz equality. **)
+Class ComparableLeibnizEq {A:Type} (C: Comparable A) :=
+ compare_eq : forall x y, compare x y = Eq -> x = y.
+
+(** Boolean equality for a [Comparable]. **)
+Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
+ match compare x y with
+ | Eq => true
+ | _ => false
+ end.
+
+Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableLeibnizEq C} :
+ forall x y, compare_eqb x y = true <-> x = y.
+Proof.
+unfold compare_eqb.
+intuition.
+apply compare_eq.
+destruct (compare x y); intuition; discriminate.
+destruct H.
+rewrite compare_refl; intuition.
+Qed.
+
+Instance NComparableLeibnizEq : ComparableLeibnizEq natComparable := Nat.compare_eq.
+
+(** A pair of ComparableLeibnizEq is ComparableLeibnizEq **)
+Instance PairComparableLeibnizEq
+ {A:Type} {CA:Comparable A} (UA:ComparableLeibnizEq CA)
+ {B:Type} {CB:Comparable B} (UB:ComparableLeibnizEq CB) :
+ ComparableLeibnizEq (PairComparable CA CB).
+Proof.
+intros x y; destruct x, y; simpl.
+pose proof (compare_eq a a0); pose proof (compare_eq b b0).
+destruct (compare a a0); try discriminate.
+intuition.
+destruct H2, H0.
+reflexivity.
+Qed.
+
+(** An [Finite] type is a type with the list of all elements. **)
+Class Finite (A:Type) := {
+ all_list : list A;
+ all_list_forall : forall x:A, In x all_list
+}.
+
+(** An alphabet is both [ComparableLeibnizEq] and [Finite]. **)
+Class Alphabet (A:Type) := {
+ AlphabetComparable :> Comparable A;
+ AlphabetComparableLeibnizEq :> ComparableLeibnizEq AlphabetComparable;
+ AlphabetFinite :> Finite A
+}.
+
+(** The [Numbered] class provides a conveniant way to build [Alphabet] instances,
+ with a good computationnal complexity. It is mainly a injection from it to
+ [positive] **)
+Class Numbered (A:Type) := {
+ inj : A -> positive;
+ surj : positive -> A;
+ surj_inj_compat : forall x, surj (inj x) = x;
+ inj_bound : positive;
+ inj_bound_spec : forall x, (inj x < Pos.succ inj_bound)%positive
+}.
+
+Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
+ { AlphabetComparable := {| compare := fun x y => Pos.compare (inj x) (inj y) |};
+ AlphabetFinite :=
+ {| all_list := fst (Pos.iter
+ (fun '(l, p) => (surj p::l, Pos.succ p))
+ ([], 1%positive) inj_bound) |} }.
+Next Obligation. simpl. now rewrite <- Pos.compare_antisym. Qed.
+Next Obligation.
+ match goal with c : comparison |- _ => destruct c end.
+ - rewrite Pos.compare_eq_iff in *. congruence.
+ - rewrite Pos.compare_lt_iff in *. eauto using Pos.lt_trans.
+ - rewrite Pos.compare_gt_iff in *. eauto using Pos.lt_trans.
+Qed.
+Next Obligation.
+ intros x y. unfold compare. intros Hxy.
+ assert (Hxy' : inj x = inj y).
+ (* We do not use [Pos.compare_eq_iff] directly to make sure the
+ proof is executable. *)
+ { destruct (Pos.eq_dec (inj x) (inj y)) as [|[]]; [now auto|].
+ now apply Pos.compare_eq_iff. }
+ (* Using rewrite here leads to non-executable proofs. *)
+ transitivity (surj (inj x)).
+ { apply eq_sym, surj_inj_compat. }
+ transitivity (surj (inj y)); cycle 1.
+ { apply surj_inj_compat. }
+ apply f_equal, Hxy'.
+Defined.
+Next Obligation.
+ rewrite <-(surj_inj_compat x).
+ generalize (inj_bound_spec x). generalize (inj x). clear x. intros x.
+ match goal with |- ?Hx -> In ?s (fst ?p) =>
+ assert ((Hx -> In s (fst p)) /\ snd p = Pos.succ inj_bound); [|now intuition] end.
+ rewrite Pos.lt_succ_r.
+ induction inj_bound as [|y [IH1 IH2]] using Pos.peano_ind;
+ (split; [intros Hx|]); simpl.
+ - rewrite (Pos.le_antisym _ _ Hx); auto using Pos.le_1_l.
+ - auto.
+ - rewrite Pos.iter_succ. destruct Pos.iter; simpl in *. subst.
+ rewrite Pos.le_lteq in Hx. destruct Hx as [?%Pos.lt_succ_r| ->]; now auto.
+ - rewrite Pos.iter_succ. destruct Pos.iter. simpl in IH2. subst. reflexivity.
+Qed.
+
+(** Definitions of [FSet]/[FMap] from [Comparable] **)
+Require Import OrderedTypeAlt.
+Require FSetAVL.
+Require FMapAVL.
+Import OrderedType.
+
+Module Type ComparableM.
+ Parameter t : Type.
+ Declare Instance tComparable : Comparable t.
+End ComparableM.
+
+Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
+ Definition t := C.t.
+ Definition compare : t -> t -> comparison := compare.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
+ Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed.
+ Lemma compare_trans c x y z :
+ (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+ Proof.
+ apply compare_trans.
+ Qed.
+End OrderedTypeAlt_from_ComparableM.
+
+Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
+ Module Alt := OrderedTypeAlt_from_ComparableM C.
+ Include (OrderedType_from_Alt Alt).
+End OrderedType_from_ComparableM.
diff --git a/cparser/MenhirLib/Automaton.v b/MenhirLib/Automaton.v
index fc995298..d5a19f35 100644
--- a/cparser/MenhirLib/Automaton.v
+++ b/MenhirLib/Automaton.v
@@ -1,23 +1,20 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
Require Grammar.
-Require Import Orders.
Require Export Alphabet.
-Require Export List.
-Require Export Syntax.
+From Coq Require Import Orders.
+From Coq Require Export List Syntax.
Module Type AutInit.
(** The grammar of the automaton. **)
@@ -102,9 +99,9 @@ Module Types(Import Init:AutInit).
T term = last_symb_of_non_init_state s -> lookahead_action term
| Reduce_act: production -> lookahead_action term
| Fail_act: lookahead_action term.
- Arguments Shift_act [term].
- Arguments Reduce_act [term].
- Arguments Fail_act [term].
+ Arguments Shift_act {term}.
+ Arguments Reduce_act {term}.
+ Arguments Fail_act {term}.
Inductive action :=
| Default_reduce_act: production -> action
diff --git a/MenhirLib/Grammar.v b/MenhirLib/Grammar.v
new file mode 100644
index 00000000..a371318b
--- /dev/null
+++ b/MenhirLib/Grammar.v
@@ -0,0 +1,162 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax Orders.
+Require Import Alphabet.
+
+(** The terminal non-terminal alphabets of the grammar. **)
+Module Type Alphs.
+ Parameters terminal nonterminal : Type.
+ Declare Instance TerminalAlph: Alphabet terminal.
+ Declare Instance NonTerminalAlph: Alphabet nonterminal.
+End Alphs.
+
+(** Definition of the alphabet of symbols, given the alphabet of terminals
+ and the alphabet of non terminals **)
+Module Symbol(Import A:Alphs).
+
+ Inductive symbol :=
+ | T: terminal -> symbol
+ | NT: nonterminal -> symbol.
+
+ Program Instance SymbolAlph : Alphabet symbol :=
+ { AlphabetComparable := {| compare := fun x y =>
+ match x, y return comparison with
+ | T _, NT _ => Gt
+ | NT _, T _ => Lt
+ | T x, T y => compare x y
+ | NT x, NT y => compare x y
+ end |};
+ AlphabetFinite := {| all_list :=
+ map T all_list++map NT all_list |} }.
+ Next Obligation.
+ destruct x; destruct y; intuition; apply compare_antisym.
+ Qed.
+ Next Obligation.
+ destruct x; destruct y; destruct z; intuition; try discriminate.
+ apply (compare_trans _ t0); intuition.
+ apply (compare_trans _ n0); intuition.
+ Qed.
+ Next Obligation.
+ intros x y.
+ destruct x; destruct y; try discriminate; intros.
+ rewrite (compare_eq t t0); now intuition.
+ rewrite (compare_eq n n0); now intuition.
+ Defined.
+ Next Obligation.
+ rewrite in_app_iff.
+ destruct x; [left | right]; apply in_map; apply all_list_forall.
+ Qed.
+
+End Symbol.
+
+(** A curryfied function with multiple parameters **)
+Definition arrows_right: Type -> list Type -> Type :=
+ fold_right (fun A B => A -> B).
+
+Module Type T.
+ Include Alphs <+ Symbol.
+
+ (** [symbol_semantic_type] maps a symbols to the type of its semantic
+ values. **)
+ Parameter symbol_semantic_type: symbol -> Type.
+
+ (** The type of productions identifiers **)
+ Parameter production : Type.
+ Declare Instance ProductionAlph : Alphabet production.
+
+ (** Accessors for productions: left hand side, right hand side,
+ and semantic action. The semantic actions are given in the form
+ of curryfied functions, that take arguments in the reverse order. **)
+ Parameter prod_lhs: production -> nonterminal.
+ (* The RHS of a production is given in reversed order, so that symbols *)
+ Parameter prod_rhs_rev: production -> list symbol.
+ Parameter prod_action:
+ forall p:production,
+ arrows_right
+ (symbol_semantic_type (NT (prod_lhs p)))
+ (map symbol_semantic_type (prod_rhs_rev p)).
+
+ (** Tokens are the atomic elements of the input stream: they contain
+ a terminal and a semantic value of the type corresponding to this
+ terminal. *)
+ Parameter token : Type.
+ Parameter token_term : token -> terminal.
+ Parameter token_sem :
+ forall tok : token, symbol_semantic_type (T (token_term tok)).
+End T.
+
+Module Defs(Import G:T).
+
+ (** The semantics of a grammar is defined in two stages. First, we
+ define the notion of parse tree, which represents one way of
+ recognizing a word with a head symbol. Semantic values are stored
+ at the leaves.
+
+ This notion is defined in two mutually recursive flavours:
+ either for a single head symbol, or for a list of head symbols. *)
+ Inductive parse_tree:
+ forall (head_symbol:symbol) (word:list token), Type :=
+
+ (** Parse tree for a terminal symbol. *)
+ | Terminal_pt:
+ forall (tok:token), parse_tree (T (token_term tok)) [tok]
+
+ (** Parse tree for a non-terminal symbol. *)
+ | Non_terminal_pt:
+ forall (prod:production) {word:list token},
+ parse_tree_list (prod_rhs_rev prod) word ->
+ parse_tree (NT (prod_lhs prod)) word
+
+ (* Note : the list head_symbols_rev is reversed. *)
+ with parse_tree_list:
+ forall (head_symbols_rev:list symbol) (word:list token), Type :=
+
+ | Nil_ptl: parse_tree_list [] []
+
+ | Cons_ptl:
+ forall {head_symbolsq:list symbol} {wordq:list token},
+ parse_tree_list head_symbolsq wordq ->
+
+ forall {head_symbolt:symbol} {wordt:list token},
+ parse_tree head_symbolt wordt ->
+
+ parse_tree_list (head_symbolt::head_symbolsq) (wordq++wordt).
+
+ (** We can now finish the definition of the semantics of a grammar,
+ by giving the semantic value assotiated with a parse tree. *)
+ Fixpoint pt_sem {head_symbol word} (tree:parse_tree head_symbol word) :
+ symbol_semantic_type head_symbol :=
+ match tree with
+ | Terminal_pt tok => token_sem tok
+ | Non_terminal_pt prod ptl => ptl_sem ptl (prod_action prod)
+ end
+ with ptl_sem {A head_symbols word} (tree:parse_tree_list head_symbols word) :
+ arrows_right A (map symbol_semantic_type head_symbols) -> A :=
+ match tree with
+ | Nil_ptl => fun act => act
+ | Cons_ptl q t => fun act => ptl_sem q (act (pt_sem t))
+ end.
+
+ Fixpoint pt_size {head_symbol word} (tree:parse_tree head_symbol word) :=
+ match tree with
+ | Terminal_pt _ => 1
+ | Non_terminal_pt _ l => S (ptl_size l)
+ end
+ with ptl_size {head_symbols word} (tree:parse_tree_list head_symbols word) :=
+ match tree with
+ | Nil_ptl => 0
+ | Cons_ptl q t =>
+ pt_size t + ptl_size q
+ end.
+End Defs.
diff --git a/MenhirLib/Interpreter.v b/MenhirLib/Interpreter.v
new file mode 100644
index 00000000..568597ba
--- /dev/null
+++ b/MenhirLib/Interpreter.v
@@ -0,0 +1,453 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax.
+From Coq.ssr Require Import ssreflect.
+Require Automaton.
+Require Import Alphabet Grammar Validator_safe.
+
+Module Make(Import A:Automaton.T).
+Module Import ValidSafe := Validator_safe.Make A.
+
+(** A few helpers for dependent types. *)
+
+(** Decidable propositions. *)
+Class Decidable (P : Prop) := decide : {P} + {~P}.
+Arguments decide _ {_}.
+
+(** A [Comparable] type has decidable equality. *)
+Instance comparable_decidable_eq T `{ComparableLeibnizEq T} (x y : T) :
+ Decidable (x = y).
+Proof.
+ unfold Decidable.
+ destruct (compare x y) eqn:EQ; [left; apply compare_eq; intuition | ..];
+ right; intros ->; by rewrite compare_refl in EQ.
+Defined.
+
+Instance list_decidable_eq T :
+ (forall x y : T, Decidable (x = y)) ->
+ (forall l1 l2 : list T, Decidable (l1 = l2)).
+Proof. unfold Decidable. decide equality. Defined.
+
+Ltac subst_existT :=
+ repeat
+ match goal with
+ | _ => progress subst
+ | H : @existT ?A ?P ?x ?y1 = @existT ?A ?P ?x ?y2 |- _ =>
+ let DEC := fresh in
+ assert (DEC : forall u1 u2 : A, Decidable (u1 = u2)) by apply _;
+ apply Eqdep_dec.inj_pair2_eq_dec in H; [|by apply DEC];
+ clear DEC
+ end.
+
+(** The interpreter is written using dependent types. In order to
+ avoid reducing proof terms while executing the parser, we thunk all
+ the propositions behind an arrow.
+ Note that thunkP is still in Prop so that it is erased by
+ extraction.
+ *)
+Definition thunkP (P : Prop) : Prop := True -> P.
+
+(** Sometimes, we actually need a reduced proof in a program (for
+ example when using an equality to cast a value). In that case,
+ instead of reducing the proof we already have, we reprove the
+ assertion by using decidability. *)
+Definition reprove {P} `{Decidable P} (p : thunkP P) : P :=
+ match decide P with
+ | left p => p
+ | right np => False_ind _ (np (p I))
+ end.
+
+(** Combination of reprove with eq_rect. *)
+Definition cast {T : Type} (F : T -> Type) {x y : T} (eq : thunkP (x = y))
+ {DEC : unit -> Decidable (x = y)}:
+ F x -> F y :=
+ fun a => eq_rect x F a y (@reprove _ (DEC ()) eq).
+
+Lemma cast_eq T F (x : T) (eq : thunkP (x = x)) `{forall x y, Decidable (x = y)} a :
+ cast F eq a = a.
+Proof. by rewrite /cast -Eqdep_dec.eq_rect_eq_dec. Qed.
+
+(** Input buffers and operations on them. **)
+CoInductive buffer : Type :=
+ Buf_cons { buf_head : token; buf_tail : buffer }.
+
+Delimit Scope buffer_scope with buf.
+Bind Scope buffer_scope with buffer.
+
+Infix "::" := Buf_cons (at level 60, right associativity) : buffer_scope.
+
+(** Concatenation of a list and an input buffer **)
+Fixpoint app_buf (l:list token) (buf:buffer) :=
+ match l with
+ | nil => buf
+ | cons t q => (t :: app_buf q buf)%buf
+ end.
+Infix "++" := app_buf (at level 60, right associativity) : buffer_scope.
+
+Lemma app_buf_assoc (l1 l2:list token) (buf:buffer) :
+ (l1 ++ (l2 ++ buf) = (l1 ++ l2) ++ buf)%buf.
+Proof. induction l1 as [|?? IH]=>//=. rewrite IH //. Qed.
+
+(** The type of a non initial state: the type of semantic values associated
+ with the last symbol of this state. *)
+Definition noninitstate_type state :=
+ symbol_semantic_type (last_symb_of_non_init_state state).
+
+(** The stack of the automaton : it can be either nil or contains a non
+ initial state, a semantic value for the symbol associted with this state,
+ and a nested stack. **)
+Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *)
+
+Section Interpreter.
+
+Hypothesis safe: safe.
+
+(* Properties of the automaton deduced from safety validation. *)
+Proposition shift_head_symbs: shift_head_symbs.
+Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
+Proposition goto_head_symbs: goto_head_symbs.
+Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
+Proposition shift_past_state: shift_past_state.
+Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
+Proposition goto_past_state: goto_past_state.
+Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
+Proposition reduce_ok: reduce_ok.
+Proof. pose proof safe; unfold ValidSafe.safe in H; intuition. Qed.
+
+Variable init : initstate.
+
+(** The top state of a stack **)
+Definition state_of_stack (stack:stack): state :=
+ match stack with
+ | [] => init
+ | existT _ s _::_ => s
+ end.
+
+(** The stack of states of an automaton stack **)
+Definition state_stack_of_stack (stack:stack) :=
+ (List.map
+ (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell))
+ stack ++ [singleton_state_pred init])%list.
+
+(** The stack of symbols of an automaton stack **)
+Definition symb_stack_of_stack (stack:stack) :=
+ List.map
+ (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell))
+ stack.
+
+(** The stack invariant : it basically states that the assumptions on the
+ states are true. **)
+Inductive stack_invariant: stack -> Prop :=
+ | stack_invariant_constr:
+ forall stack,
+ prefix (head_symbs_of_state (state_of_stack stack))
+ (symb_stack_of_stack stack) ->
+ prefix_pred (head_states_of_state (state_of_stack stack))
+ (state_stack_of_stack stack) ->
+ stack_invariant_next stack ->
+ stack_invariant stack
+with stack_invariant_next: stack -> Prop :=
+ | stack_invariant_next_nil:
+ stack_invariant_next []
+ | stack_invariant_next_cons:
+ forall state_cur st stack_rec,
+ stack_invariant stack_rec ->
+ stack_invariant_next (existT _ state_cur st::stack_rec).
+
+(** [pop] pops some symbols from the stack. It returns the popped semantic
+ values using [sem_popped] as an accumulator and discards the popped
+ states.**)
+Fixpoint pop (symbols_to_pop:list symbol) {A:Type} (stk:stack) :
+ thunkP (prefix symbols_to_pop (symb_stack_of_stack stk)) ->
+ forall (action:arrows_right A (map symbol_semantic_type symbols_to_pop)),
+ stack * A.
+unshelve refine
+ (match symbols_to_pop
+ return
+ (thunkP (prefix symbols_to_pop (symb_stack_of_stack stk))) ->
+ forall (action:arrows_right A (map _ symbols_to_pop)), stack * A
+ with
+ | [] => fun _ action => (stk, action)
+ | t::q => fun Hp action =>
+ match stk
+ return thunkP (prefix (t::q) (symb_stack_of_stack stk)) -> stack * A
+ with
+ | existT _ state_cur sem::stack_rec => fun Hp =>
+ let sem_conv := cast symbol_semantic_type _ sem in
+ pop q _ stack_rec _ (action sem_conv)
+ | [] => fun Hp => False_rect _ _
+ end Hp
+ end).
+Proof.
+ - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
+ - clear -Hp. abstract (specialize (Hp I); now inversion Hp).
+ - simpl in Hp. clear -Hp. abstract (intros _ ; specialize (Hp I); now inversion Hp).
+Defined.
+
+(* Equivalent declarative specification for pop, so that we avoid
+ (part of) the dependent types nightmare. *)
+Inductive pop_spec {A:Type} :
+ forall (symbols_to_pop:list symbol) (stk : stack)
+ (action : arrows_right A (map symbol_semantic_type symbols_to_pop))
+ (stk' : stack) (sem : A),
+ Prop :=
+ | Nil_pop_spec stk sem : pop_spec [] stk sem stk sem
+ | Cons_pop_spec symbols_to_pop st stk action sem stk' res :
+ pop_spec symbols_to_pop stk (action sem) stk' res ->
+ pop_spec (last_symb_of_non_init_state st::symbols_to_pop)
+ (existT _ st sem :: stk) action stk' res.
+
+Lemma pop_spec_ok {A:Type} symbols_to_pop stk Hp action stk' res:
+ pop symbols_to_pop stk Hp action = (stk', res) <->
+ pop_spec (A:=A) symbols_to_pop stk action stk' res.
+Proof.
+ revert stk Hp action.
+ induction symbols_to_pop as [|t symbols_to_pop IH]=>stk Hp action /=.
+ - split.
+ + intros [= <- <-]. constructor.
+ + intros H. inversion H. by subst_existT.
+ - destruct stk as [|[st sem]]=>/=; [by destruct pop_subproof0|].
+ remember (pop_subproof t symbols_to_pop stk st Hp) as EQ eqn:eq. clear eq.
+ generalize EQ. revert Hp action. rewrite <-(EQ I)=>Hp action ?.
+ rewrite cast_eq. rewrite IH. split.
+ + intros. by constructor.
+ + intros H. inversion H. by subst_existT.
+Qed.
+
+
+Lemma pop_preserves_invariant symbols_to_pop stk Hp A action :
+ stack_invariant stk ->
+ stack_invariant (fst (pop symbols_to_pop stk Hp (A:=A) action)).
+Proof.
+ revert stk Hp A action. induction symbols_to_pop as [|t q IH]=>//=.
+ intros stk Hp A action Hi.
+ destruct Hi as [stack Hp' Hpp [|state st stk']].
+ - destruct pop_subproof0.
+ - now apply IH.
+Qed.
+
+Lemma pop_state_valid symbols_to_pop stk Hp A action lpred :
+ prefix_pred lpred (state_stack_of_stack stk) ->
+ let stk' := fst (pop symbols_to_pop stk Hp (A:=A) action) in
+ state_valid_after_pop (state_of_stack stk') symbols_to_pop lpred.
+Proof.
+ revert stk Hp A action lpred. induction symbols_to_pop as [|t q IH]=>/=.
+ - intros stk Hp A a lpred Hpp. destruct lpred as [|pred lpred]; constructor.
+ inversion Hpp as [|? lpred' ? pred' Himpl Hpp' eq1 eq2]; subst.
+ specialize (Himpl (state_of_stack stk)).
+ destruct (pred' (state_of_stack stk)) as [] eqn:Heqpred'=>//.
+ destruct stk as [|[]]; simpl in *.
+ + inversion eq2; subst; clear eq2.
+ unfold singleton_state_pred in Heqpred'.
+ now rewrite compare_refl in Heqpred'; discriminate.
+ + inversion eq2; subst; clear eq2.
+ unfold singleton_state_pred in Heqpred'.
+ now rewrite compare_refl in Heqpred'; discriminate.
+ - intros stk Hp A a lpred Hpp. destruct stk as [|[] stk]=>//=.
+ + destruct pop_subproof0.
+ + destruct lpred as [|pred lpred]; [by constructor|].
+ constructor. apply IH. by inversion Hpp.
+Qed.
+
+(** [step_result] represents the result of one step of the automaton : it can
+ fail, accept or progress. [Fail_sr] means that the input is incorrect.
+ [Accept_sr] means that this is the last step of the automaton, and it
+ returns the semantic value of the input word. [Progress_sr] means that
+ some progress has been made, but new steps are needed in order to accept
+ a word.
+
+ For [Accept_sr] and [Progress_sr], the result contains the new input buffer.
+
+ [Fail_sr] means that the input word is rejected by the automaton. It is
+ different to [Err] (from the error monad), which mean that the automaton is
+ bogus and has perfomed a forbidden action. **)
+Inductive step_result :=
+ | Fail_sr: step_result
+ | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> buffer -> step_result
+ | Progress_sr: stack -> buffer -> step_result.
+
+(** [reduce_step] does a reduce action :
+ - pops some elements from the stack
+ - execute the action of the production
+ - follows the goto for the produced non terminal symbol **)
+Definition reduce_step stk prod (buffer : buffer)
+ (Hval : thunkP (valid_for_reduce (state_of_stack stk) prod))
+ (Hi : thunkP (stack_invariant stk))
+ : step_result.
+refine
+ ((let '(stk', sem) as ss := pop (prod_rhs_rev prod) stk _ (prod_action prod)
+ return thunkP (state_valid_after_pop (state_of_stack (fst ss)) _
+ (head_states_of_state (state_of_stack stk))) -> _
+ in fun Hval' =>
+ match goto_table (state_of_stack stk') (prod_lhs prod) as goto
+ return (thunkP (goto = None ->
+ match state_of_stack stk' with
+ | Init i => prod_lhs prod = start_nt i
+ | Ninit _ => False
+ end)) -> _
+ with
+ | Some (exist _ state_new e) => fun _ =>
+ let sem := eq_rect _ _ sem _ e in
+ Progress_sr (existT noninitstate_type state_new sem::stk') buffer
+ | None => fun Hval =>
+ let sem := cast symbol_semantic_type _ sem in
+ Accept_sr sem buffer
+ end (fun _ => _))
+ (fun _ => pop_state_valid _ _ _ _ _ _ _)).
+Proof.
+ - clear -Hi Hval.
+ abstract (intros _; destruct Hi=>//; eapply prefix_trans; [by apply Hval|eassumption]).
+ - clear -Hval.
+ abstract (intros _; f_equal; specialize (Hval I eq_refl); destruct stk' as [|[]]=>//).
+ - simpl in Hval'. clear -Hval Hval'.
+ abstract (move : Hval => /(_ I) [_ /(_ _ (Hval' I))] Hval2 Hgoto; by rewrite Hgoto in Hval2).
+ - clear -Hi. abstract by destruct Hi.
+Defined.
+
+Lemma reduce_step_stack_invariant_preserved stk prod buffer Hv Hi stk' buffer':
+ reduce_step stk prod buffer Hv Hi = Progress_sr stk' buffer' ->
+ stack_invariant stk'.
+Proof.
+ unfold reduce_step.
+ match goal with
+ | |- context [pop ?symbols_to_pop stk ?Hp ?action] =>
+ assert (Hi':=pop_preserves_invariant symbols_to_pop stk Hp _ action (Hi I));
+ generalize (pop_state_valid symbols_to_pop stk Hp _ action)
+ end.
+ destruct pop as [stk0 sem]=>/=. simpl in Hi'. intros Hv'.
+ assert (Hgoto1:=goto_head_symbs (state_of_stack stk0) (prod_lhs prod)).
+ assert (Hgoto2:=goto_past_state (state_of_stack stk0) (prod_lhs prod)).
+ match goal with | |- context [fun _ : True => ?X] => generalize X end.
+ destruct goto_table as [[state_new e]|] eqn:EQgoto=>//.
+ intros _ [= <- <-]. constructor=>/=.
+ - constructor. eapply prefix_trans. apply Hgoto1. by destruct Hi'.
+ - unfold state_stack_of_stack; simpl; constructor.
+ + intros ?. by destruct singleton_state_pred.
+ + eapply prefix_pred_trans. apply Hgoto2. by destruct Hi'.
+ - by constructor.
+Qed.
+
+(** One step of parsing. **)
+Definition step stk buffer (Hi : thunkP (stack_invariant stk)): step_result :=
+ match action_table (state_of_stack stk) as a return
+ thunkP
+ match a return Prop with
+ | Default_reduce_act prod => _
+ | Lookahead_act awt => forall t : terminal,
+ match awt t with
+ | Reduce_act p => _
+ | _ => True
+ end
+ end -> _
+ with
+ | Default_reduce_act prod => fun Hv =>
+ reduce_step stk prod buffer Hv Hi
+ | Lookahead_act awt => fun Hv =>
+ match buf_head buffer with
+ | tok =>
+ match awt (token_term tok) as a return
+ thunkP match a return Prop with Reduce_act p => _ | _ => _ end -> _
+ with
+ | Shift_act state_new e => fun _ =>
+ let sem_conv := eq_rect _ symbol_semantic_type (token_sem tok) _ e in
+ Progress_sr (existT noninitstate_type state_new sem_conv::stk)
+ (buf_tail buffer)
+ | Reduce_act prod => fun Hv =>
+ reduce_step stk prod buffer Hv Hi
+ | Fail_act => fun _ =>
+ Fail_sr
+ end (fun _ => Hv I (token_term tok))
+ end
+ end (fun _ => reduce_ok _).
+
+Lemma step_stack_invariant_preserved stk buffer Hi stk' buffer':
+ step stk buffer Hi = Progress_sr stk' buffer' ->
+ stack_invariant stk'.
+Proof.
+ unfold step.
+ generalize (reduce_ok (state_of_stack stk))=>Hred.
+ assert (Hshift1 := shift_head_symbs (state_of_stack stk)).
+ assert (Hshift2 := shift_past_state (state_of_stack stk)).
+ destruct action_table as [prod|awt]=>/=.
+ - eauto using reduce_step_stack_invariant_preserved.
+ - set (term := token_term (buf_head buffer)).
+ generalize (Hred term). clear Hred. intros Hred.
+ specialize (Hshift1 term). specialize (Hshift2 term).
+ destruct (awt term) as [state_new e|prod|]=>//.
+ + intros [= <- <-]. constructor=>/=.
+ * constructor. eapply prefix_trans. apply Hshift1. by destruct Hi.
+ * unfold state_stack_of_stack; simpl; constructor.
+ -- intros ?. by destruct singleton_state_pred.
+ -- eapply prefix_pred_trans. apply Hshift2. by destruct Hi.
+ * constructor; by apply Hi.
+ + eauto using reduce_step_stack_invariant_preserved.
+Qed.
+
+(** The parsing use a [nat] fuel parameter [log_n_steps], so that we
+ do not have to prove terminaison, which is difficult.
+
+ Note that [log_n_steps] is *not* the fuel in the conventionnal
+ sense: this parameter contains the logarithm (in base 2) of the
+ number of steps to perform. Hence, a value of, e.g., 50 will
+ usually be enough to ensure termination. *)
+Fixpoint parse_fix stk buffer (log_n_steps : nat) (Hi : thunkP (stack_invariant stk)):
+ { sr : step_result |
+ forall stk' buffer', sr = Progress_sr stk' buffer' -> stack_invariant stk' } :=
+ match log_n_steps with
+ | O => exist _ (step stk buffer Hi)
+ (step_stack_invariant_preserved _ _ Hi)
+ | S log_n_steps =>
+ match parse_fix stk buffer log_n_steps Hi with
+ | exist _ (Progress_sr stk buffer) Hi' =>
+ parse_fix stk buffer log_n_steps (fun _ => Hi' _ buffer eq_refl)
+ | sr => sr
+ end
+ end.
+
+(** The final result of a parsing is either a failure (the automaton
+ has rejected the input word), either a timeout (the automaton has
+ spent all the given [2^log_n_steps]), either a parsed semantic value
+ with a rest of the input buffer.
+
+ Note that we do not make parse_result depend on start_nt for the
+ result type, so that this inductive is extracted without the use
+ of Obj.t in OCaml. **)
+Inductive parse_result {A : Type} :=
+ | Fail_pr: parse_result
+ | Timeout_pr: parse_result
+ | Parsed_pr: A -> buffer -> parse_result.
+Global Arguments parse_result _ : clear implicits.
+
+Definition parse (buffer : buffer) (log_n_steps : nat):
+ parse_result (symbol_semantic_type (NT (start_nt init))).
+refine (match proj1_sig (parse_fix [] buffer log_n_steps _) with
+ | Fail_sr => Fail_pr
+ | Accept_sr sem buffer' => Parsed_pr sem buffer'
+ | Progress_sr _ _ => Timeout_pr
+ end).
+Proof.
+ abstract (repeat constructor; intros; by destruct singleton_state_pred).
+Defined.
+
+End Interpreter.
+
+Arguments Fail_sr {init}.
+Arguments Accept_sr {init} _ _.
+Arguments Progress_sr {init} _ _.
+
+End Make.
+
+Module Type T(A:Automaton.T).
+ Include (Make A).
+End T.
diff --git a/MenhirLib/Interpreter_complete.v b/MenhirLib/Interpreter_complete.v
new file mode 100644
index 00000000..ec69592b
--- /dev/null
+++ b/MenhirLib/Interpreter_complete.v
@@ -0,0 +1,825 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax Arith.
+From Coq.ssr Require Import ssreflect.
+Require Import Alphabet Grammar.
+Require Automaton Interpreter Validator_complete.
+
+Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
+Module Import Valid := Validator_complete.Make A.
+
+(** * Completeness Proof **)
+
+Section Completeness_Proof.
+
+Hypothesis safe: Inter.ValidSafe.safe.
+Hypothesis complete: complete.
+
+(* Properties of the automaton deduced from completeness validation. *)
+Proposition nullable_stable: nullable_stable.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition first_stable: first_stable.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition start_future: start_future.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition terminal_shift: terminal_shift.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition end_reduce: end_reduce.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition start_goto: start_goto.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition non_terminal_goto: non_terminal_goto.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+Proposition non_terminal_closed: non_terminal_closed.
+Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
+
+(** If the nullable predicate has been validated, then it is correct. **)
+Lemma nullable_correct head word :
+ word = [] -> parse_tree head word -> nullable_symb head = true
+with nullable_correct_list heads word :
+ word = [] ->
+ parse_tree_list heads word -> nullable_word heads = true.
+Proof.
+ - destruct 2=>//. assert (Hnull := nullable_stable prod).
+ erewrite nullable_correct_list in Hnull; eauto.
+ - intros Hword. destruct 1=>//=. destruct (app_eq_nil _ _ Hword).
+ eauto using andb_true_intro.
+Qed.
+
+(** Auxiliary lemma for first_correct. *)
+Lemma first_word_set_app t word1 word2 :
+ TerminalSet.In t (first_word_set (word1 ++ word2)) <->
+ TerminalSet.In t (first_word_set word1) \/
+ TerminalSet.In t (first_word_set word2) /\ nullable_word (rev word1) = true.
+Proof.
+ induction word1 as [|s word1 IH]=>/=.
+ - split; [tauto|]. move=>[/TerminalSet.empty_1 ?|[? _]]//.
+ - rewrite /nullable_word forallb_app /=. destruct nullable_symb=>/=.
+ + rewrite Bool.andb_true_r. split.
+ * move=>/TerminalSet.union_1. rewrite IH.
+ move=>[?|[?|[??]]]; auto using TerminalSet.union_2, TerminalSet.union_3.
+ * destruct IH.
+ move=>[/TerminalSet.union_1 [?|?]|[??]];
+ auto using TerminalSet.union_2, TerminalSet.union_3.
+ + rewrite Bool.andb_false_r. by intuition.
+Qed.
+
+(** If the first predicate has been validated, then it is correct. **)
+Lemma first_correct head word t q :
+ word = t::q ->
+ parse_tree head word ->
+ TerminalSet.In (token_term t) (first_symb_set head)
+with first_correct_list heads word t q :
+ word = t::q ->
+ parse_tree_list heads word ->
+ TerminalSet.In (token_term t) (first_word_set (rev' heads)).
+Proof.
+ - intros Hword. destruct 1=>//.
+ + inversion Hword. subst. apply TerminalSet.singleton_2, compare_refl.
+ + eapply first_stable. eauto.
+ - intros Hword. destruct 1 as [|symq wordq ptl symt wordt pt]=>//=.
+ rewrite /rev' -rev_alt /= first_word_set_app /= rev_involutive rev_alt.
+ destruct wordq; [right|left].
+ + destruct nullable_symb; eauto using TerminalSet.union_2, nullable_correct_list.
+ + inversion Hword. subst. fold (rev' symq). eauto.
+Qed.
+
+(** A PTL is compatible with a stack if the top of the stack contains
+ data representing to this PTL. *)
+Fixpoint ptl_stack_compat {symbs word}
+ (stk0 : stack) (ptl : parse_tree_list symbs word) (stk : stack) : Prop :=
+ match ptl with
+ | Nil_ptl => stk0 = stk
+ | @Cons_ptl _ _ ptl sym _ pt =>
+ match stk with
+ | [] => False
+ | existT _ _ sem::stk =>
+ ptl_stack_compat stk0 ptl stk /\
+ exists e,
+ sem = eq_rect _ symbol_semantic_type (pt_sem pt) _ e
+ end
+ end.
+
+(** .. and when a PTL is compatible with a stack, then calling the pop
+ function return the semantic value of this PTL. *)
+Lemma pop_stack_compat_pop_spec {A symbs word}
+ (ptl:parse_tree_list symbs word) (stk:stack) (stk0:stack) action :
+ ptl_stack_compat stk0 ptl stk ->
+ pop_spec symbs stk action stk0 (ptl_sem (A:=A) ptl action).
+Proof.
+ revert stk. induction ptl=>stk /= Hstk.
+ - subst. constructor.
+ - destruct stk as [|[st sem] stk]=>//. destruct Hstk as [Hstk [??]]. subst.
+ simpl. constructor. eauto.
+Qed.
+
+Variable init: initstate.
+
+(** In order to prove compleness, we first fix a word to be parsed
+ together with the content of the parser at the end of the parsing. *)
+Variable full_word: list token.
+Variable buffer_end: buffer.
+
+(** Completeness is proved by following the traversal of the parse
+ tree which is performed by the parser. Each step of parsing
+ correspond to one step of traversal. In order to represent the state
+ of the traversal, we define the notion of "dotted" parse tree, which
+ is a parse tree with one dot on one of its node. The place of the
+ dot represents the place of the next action to be executed.
+
+ Such a dotted parse tree is decomposed into two part: a "regular"
+ parse tree, which is the parse tree placed under the dot, and a
+ "parse tree zipper", which is the part of the parse tree placed
+ above the dot. Therefore, a parse tree zipper is a parse tree with a
+ hole. Moreover, for easier manipulation, a parse tree zipper is
+ represented "upside down". That is, the root of the parse tree is
+ actually a leaf of the zipper, while the root of the zipper is the
+ hole.
+ *)
+Inductive pt_zipper:
+ forall (hole_symb:symbol) (hole_word:list token), Type :=
+| Top_ptz:
+ pt_zipper (NT (start_nt init)) full_word
+| Cons_ptl_ptz:
+ forall {head_symbolsq:list symbol} {wordq:list token},
+ parse_tree_list head_symbolsq wordq ->
+
+ forall {head_symbolt:symbol} {wordt:list token},
+
+ ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) ->
+ pt_zipper head_symbolt wordt
+with ptl_zipper:
+ forall (hole_symbs:list symbol) (hole_word:list token), Type :=
+| Non_terminal_pt_ptlz:
+ forall {p:production} {word:list token},
+ pt_zipper (NT (prod_lhs p)) word ->
+ ptl_zipper (prod_rhs_rev p) word
+
+| Cons_ptl_ptlz:
+ forall {head_symbolsq:list symbol} {wordq:list token},
+
+ forall {head_symbolt:symbol} {wordt:list token},
+ parse_tree head_symbolt wordt ->
+
+ ptl_zipper (head_symbolt::head_symbolsq) (wordq++wordt) ->
+
+ ptl_zipper head_symbolsq wordq.
+
+(** A dotted parse tree is the combination of a parse tree zipper with
+ a parse tree. It can be intwo flavors, depending on which is the next
+ action to be executed (shift or reduce). *)
+Inductive pt_dot: Type :=
+| Reduce_ptd: forall {prod word},
+ parse_tree_list (prod_rhs_rev prod) word ->
+ pt_zipper (NT (prod_lhs prod)) word ->
+ pt_dot
+| Shift_ptd: forall (tok : token) {symbolsq wordq},
+ parse_tree_list symbolsq wordq ->
+ ptl_zipper (T (token_term tok)::symbolsq) (wordq++[tok]) ->
+ pt_dot.
+
+(** We can compute the full semantic value of a parse tree when
+ represented as a dotted ptd. *)
+
+Fixpoint ptlz_sem {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word) :
+ (forall A, arrows_right A (map symbol_semantic_type hole_symbs) -> A) ->
+ (symbol_semantic_type (NT (start_nt init))) :=
+ match ptlz with
+ | @Non_terminal_pt_ptlz prod _ ptz =>
+ fun k => ptz_sem ptz (k _ (prod_action prod))
+ | Cons_ptl_ptlz pt ptlz =>
+ fun k => ptlz_sem ptlz (fun _ f => k _ (f (pt_sem pt)))
+ end
+with ptz_sem {hole_symb hole_word}
+ (ptz:pt_zipper hole_symb hole_word):
+ symbol_semantic_type hole_symb -> symbol_semantic_type (NT (start_nt init)) :=
+ match ptz with
+ | Top_ptz => fun sem => sem
+ | Cons_ptl_ptz ptl ptlz =>
+ fun sem => ptlz_sem ptlz (fun _ f => ptl_sem ptl (f sem))
+ end.
+
+Definition ptd_sem (ptd : pt_dot) :=
+ match ptd with
+ | @Reduce_ptd prod _ ptl ptz =>
+ ptz_sem ptz (ptl_sem ptl (prod_action prod))
+ | Shift_ptd tok ptl ptlz =>
+ ptlz_sem ptlz (fun _ f => ptl_sem ptl (f (token_sem tok)))
+ end.
+
+(** The buffer associated with a dotted parse tree corresponds to the
+ buffer left to be read by the parser when at the state represented
+ by the dotted parse tree. *)
+Fixpoint ptlz_buffer {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word): buffer :=
+ match ptlz with
+ | Non_terminal_pt_ptlz ptz =>
+ ptz_buffer ptz
+ | @Cons_ptl_ptlz _ _ _ wordt _ ptlz' =>
+ wordt ++ ptlz_buffer ptlz'
+ end
+with ptz_buffer {hole_symb hole_word}
+ (ptz:pt_zipper hole_symb hole_word): buffer :=
+ match ptz with
+ | Top_ptz => buffer_end
+ | Cons_ptl_ptz _ ptlz =>
+ ptlz_buffer ptlz
+ end.
+
+Definition ptd_buffer (ptd:pt_dot) :=
+ match ptd with
+ | Reduce_ptd _ ptz => ptz_buffer ptz
+ | @Shift_ptd tok _ wordq _ ptlz => (tok::ptlz_buffer ptlz)%buf
+ end.
+
+(** We are now ready to define the main invariant of the proof of
+ completeness: we need to specify when a stack is compatible with a
+ dotted parse tree. Informally, a stack is compatible with a dotted
+ parse tree when it is the concatenation stack fragments which are
+ compatible with each of the partially recognized productions
+ appearing in the parse tree zipper. Moreover, the head of each of
+ these stack fragment contains a state which has an item predicted by
+ the corresponding zipper.
+
+ More formally, the compatibility relation first needs the following
+ auxiliary definitions: *)
+Fixpoint ptlz_prod {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word): production :=
+ match ptlz with
+ | @Non_terminal_pt_ptlz prod _ _ => prod
+ | Cons_ptl_ptlz _ ptlz' => ptlz_prod ptlz'
+ end.
+
+Fixpoint ptlz_future {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word): list symbol :=
+ match ptlz with
+ | Non_terminal_pt_ptlz _ => []
+ | @Cons_ptl_ptlz _ _ s _ _ ptlz' => s::ptlz_future ptlz'
+ end.
+
+Fixpoint ptlz_lookahead {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word) : terminal :=
+ match ptlz with
+ | Non_terminal_pt_ptlz ptz => token_term (buf_head (ptz_buffer ptz))
+ | Cons_ptl_ptlz _ ptlz' => ptlz_lookahead ptlz'
+ end.
+
+Fixpoint ptz_stack_compat {hole_symb hole_word}
+ (stk : stack) (ptz : pt_zipper hole_symb hole_word) : Prop :=
+ match ptz with
+ | Top_ptz => stk = []
+ | Cons_ptl_ptz ptl ptlz =>
+ exists stk0,
+ state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
+ (hole_symb::ptlz_future ptlz) (ptlz_lookahead ptlz) /\
+ ptl_stack_compat stk0 ptl stk /\
+ ptlz_stack_compat stk0 ptlz
+ end
+with ptlz_stack_compat {hole_symbs hole_word}
+ (stk : stack) (ptlz : ptl_zipper hole_symbs hole_word) : Prop :=
+ match ptlz with
+ | Non_terminal_pt_ptlz ptz => ptz_stack_compat stk ptz
+ | Cons_ptl_ptlz _ ptlz => ptlz_stack_compat stk ptlz
+ end.
+
+Definition ptd_stack_compat (ptd:pt_dot) (stk:stack): Prop :=
+ match ptd with
+ | @Reduce_ptd prod _ ptl ptz =>
+ exists stk0,
+ state_has_future (state_of_stack init stk) prod []
+ (token_term (buf_head (ptz_buffer ptz))) /\
+ ptl_stack_compat stk0 ptl stk /\
+ ptz_stack_compat stk0 ptz
+ | Shift_ptd tok ptl ptlz =>
+ exists stk0,
+ state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
+ (T (token_term tok) :: ptlz_future ptlz) (ptlz_lookahead ptlz) /\
+ ptl_stack_compat stk0 ptl stk /\
+ ptlz_stack_compat stk0 ptlz
+ end.
+
+Lemma ptz_stack_compat_cons_state_has_future {symbsq wordq symbt wordt} stk
+ (ptl : parse_tree_list symbsq wordq)
+ (ptlz : ptl_zipper (symbt :: symbsq) (wordq ++ wordt)) :
+ ptz_stack_compat stk (Cons_ptl_ptz ptl ptlz) ->
+ state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
+ (symbt::ptlz_future ptlz) (ptlz_lookahead ptlz).
+Proof. move=>[stk0 [? [? ?]]] //. Qed.
+
+Lemma ptlz_future_ptlz_prod hole_symbs hole_word
+ (ptlz:ptl_zipper hole_symbs hole_word) :
+ rev_append (ptlz_future ptlz) hole_symbs = prod_rhs_rev (ptlz_prod ptlz).
+Proof. induction ptlz=>//=. Qed.
+
+Lemma ptlz_future_first {symbs word} (ptlz : ptl_zipper symbs word) :
+ TerminalSet.In (token_term (buf_head (ptlz_buffer ptlz)))
+ (first_word_set (ptlz_future ptlz)) \/
+ token_term (buf_head (ptlz_buffer ptlz)) = ptlz_lookahead ptlz /\
+ nullable_word (ptlz_future ptlz) = true.
+Proof.
+ induction ptlz as [|??? [|tok] pt ptlz IH]; [by auto| |]=>/=.
+ - rewrite (nullable_correct _ _ eq_refl pt).
+ destruct IH as [|[??]]; [left|right]=>/=; auto using TerminalSet.union_3.
+ - left. destruct nullable_symb; eauto using TerminalSet.union_2, first_correct.
+Qed.
+
+(** We now want to define what is the next dotted parse tree which is
+ to be handled after one action. Such dotted parse is built in two
+ steps: Not only we have to perform the action by completing the
+ parse tree, but we also have to prepare for the following step by
+ moving the dot down to place it in front of the next action to be
+ performed.
+*)
+Fixpoint build_pt_dot_from_pt {symb word}
+ (pt : parse_tree symb word) (ptz : pt_zipper symb word)
+ : pt_dot :=
+ match pt in parse_tree symb word
+ return pt_zipper symb word -> pt_dot
+ with
+ | Terminal_pt tok =>
+ fun ptz =>
+ let X :=
+ match ptz in pt_zipper symb word
+ return match symb with T term => True | NT _ => False end ->
+ { symbsq : list symbol &
+ { wordq : list token &
+ (parse_tree_list symbsq wordq *
+ ptl_zipper (symb :: symbsq) (wordq ++ word))%type } }
+ with
+ | Top_ptz => fun F => False_rect _ F
+ | Cons_ptl_ptz ptl ptlz => fun _ =>
+ existT _ _ (existT _ _ (ptl, ptlz))
+ end I
+ in
+ Shift_ptd tok (fst (projT2 (projT2 X))) (snd (projT2 (projT2 X)))
+ | Non_terminal_pt prod ptl => fun ptz =>
+ let is_notnil :=
+ match ptl in parse_tree_list w _
+ return option (match w return Prop with [] => False | _ => True end)
+ with
+ | Nil_ptl => None
+ | _ => Some I
+ end
+ in
+ match is_notnil with
+ | None => Reduce_ptd ptl ptz
+ | Some H => build_pt_dot_from_pt_rec ptl H (Non_terminal_pt_ptlz ptz)
+ end
+ end ptz
+with build_pt_dot_from_pt_rec {symbs word}
+ (ptl : parse_tree_list symbs word)
+ (Hsymbs : match symbs with [] => False | _ => True end)
+ (ptlz : ptl_zipper symbs word)
+ : pt_dot :=
+ match ptl in parse_tree_list symbs word
+ return match symbs with [] => False | _ => True end ->
+ ptl_zipper symbs word ->
+ pt_dot
+ with
+ | Nil_ptl => fun Hsymbs _ => False_rect _ Hsymbs
+ | Cons_ptl ptl' pt => fun _ =>
+ match ptl' in parse_tree_list symbsq wordq
+ return parse_tree_list symbsq wordq ->
+ ptl_zipper (_ :: symbsq) (wordq ++ _) ->
+ pt_dot
+ with
+ | Nil_ptl => fun _ ptlz =>
+ build_pt_dot_from_pt pt (Cons_ptl_ptz Nil_ptl ptlz)
+ | _ => fun ptl' ptlz =>
+ build_pt_dot_from_pt_rec ptl' I (Cons_ptl_ptlz pt ptlz)
+ end ptl'
+ end Hsymbs ptlz.
+
+Definition build_pt_dot_from_ptl {symbs word}
+ (ptl : parse_tree_list symbs word)
+ (ptlz : ptl_zipper symbs word)
+ : pt_dot :=
+ match ptlz in ptl_zipper symbs word
+ return parse_tree_list symbs word -> pt_dot
+ with
+ | Non_terminal_pt_ptlz ptz => fun ptl =>
+ Reduce_ptd ptl ptz
+ | Cons_ptl_ptlz pt ptlz => fun ptl =>
+ build_pt_dot_from_pt pt (Cons_ptl_ptz ptl ptlz)
+ end ptl.
+
+Definition next_ptd (ptd:pt_dot) : option pt_dot :=
+ match ptd with
+ | Shift_ptd tok ptl ptlz =>
+ Some (build_pt_dot_from_ptl (Cons_ptl ptl (Terminal_pt tok)) ptlz)
+ | Reduce_ptd ptl ptz =>
+ match ptz in pt_zipper symb word
+ return parse_tree symb word -> _
+ with
+ | Top_ptz => fun _ => None
+ | Cons_ptl_ptz ptl' ptlz => fun pt =>
+ Some (build_pt_dot_from_ptl (Cons_ptl ptl' pt) ptlz)
+ end (Non_terminal_pt _ ptl)
+ end.
+
+Fixpoint next_ptd_iter (ptd:pt_dot) (log_n_steps:nat) : option pt_dot :=
+ match log_n_steps with
+ | O => next_ptd ptd
+ | S log_n_steps =>
+ match next_ptd_iter ptd log_n_steps with
+ | None => None
+ | Some ptd => next_ptd_iter ptd log_n_steps
+ end
+ end.
+
+(** We prove that these functions behave well w.r.t. semantic values. *)
+Lemma sem_build_from_pt {symb word}
+ (pt : parse_tree symb word) (ptz : pt_zipper symb word) :
+ ptz_sem ptz (pt_sem pt)
+ = ptd_sem (build_pt_dot_from_pt pt ptz)
+with sem_build_from_pt_rec {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
+ Hsymbs :
+ ptlz_sem ptlz (fun _ f => ptl_sem ptl f)
+ = ptd_sem (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
+Proof.
+ - destruct pt as [tok|prod word ptl]=>/=.
+ + revert ptz. generalize [tok].
+ generalize (token_sem tok). generalize I.
+ change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
+ generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
+ + match goal with
+ | |- context [match ?X with Some H => _ | None => _ end] => destruct X=>//
+ end.
+ by rewrite -sem_build_from_pt_rec.
+ - destruct ptl; [contradiction|].
+ specialize (sem_build_from_pt_rec _ _ ptl)=>/=. destruct ptl.
+ + by rewrite -sem_build_from_pt.
+ + by rewrite -sem_build_from_pt_rec.
+Qed.
+
+Lemma sem_build_from_ptl {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
+ ptlz_sem ptlz (fun _ f => ptl_sem ptl f)
+ = ptd_sem (build_pt_dot_from_ptl ptl ptlz).
+Proof. destruct ptlz=>//=. by rewrite -sem_build_from_pt. Qed.
+
+Lemma sem_next_ptd (ptd : pt_dot) :
+ match next_ptd ptd with
+ | None => True
+ | Some ptd' => ptd_sem ptd = ptd_sem ptd'
+ end.
+Proof.
+ destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz] =>/=.
+ - change (ptl_sem ptl (prod_action prod))
+ with (pt_sem (Non_terminal_pt prod ptl)).
+ generalize (Non_terminal_pt prod ptl). clear ptl.
+ destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -sem_build_from_ptl.
+ - by rewrite -sem_build_from_ptl.
+Qed.
+
+Lemma sem_next_ptd_iter (ptd : pt_dot) (log_n_steps : nat) :
+ match next_ptd_iter ptd log_n_steps with
+ | None => True
+ | Some ptd' => ptd_sem ptd = ptd_sem ptd'
+ end.
+Proof.
+ revert ptd.
+ induction log_n_steps as [|log_n_steps IH]; [by apply sem_next_ptd|]=>/= ptd.
+ assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|]=>//.
+ specialize (IH ptd'). destruct next_ptd_iter=>//. congruence.
+Qed.
+
+(** We prove that these functions behave well w.r.t. xxx_buffer. *)
+Lemma ptd_buffer_build_from_pt {symb word}
+ (pt : parse_tree symb word) (ptz : pt_zipper symb word) :
+ (word ++ ptz_buffer ptz)%buf = ptd_buffer (build_pt_dot_from_pt pt ptz)
+with ptd_buffer_build_from_pt_rec {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
+ Hsymbs :
+ (word ++ ptlz_buffer ptlz)%buf = ptd_buffer (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
+Proof.
+ - destruct pt as [tok|prod word ptl]=>/=.
+ + f_equal. revert ptz. generalize [tok].
+ generalize (token_sem tok). generalize I.
+ change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
+ generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
+ + match goal with
+ | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
+ end.
+ * by rewrite -ptd_buffer_build_from_pt_rec.
+ * rewrite [X in (X ++ _)%buf](_ : word = []) //. clear -EQ. by destruct ptl.
+ - destruct ptl as [|?? ptl ?? pt]; [contradiction|].
+ specialize (ptd_buffer_build_from_pt_rec _ _ ptl).
+ destruct ptl.
+ + by rewrite /= -ptd_buffer_build_from_pt.
+ + by rewrite -ptd_buffer_build_from_pt_rec //= app_buf_assoc.
+Qed.
+
+Lemma ptd_buffer_build_from_ptl {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
+ ptlz_buffer ptlz = ptd_buffer (build_pt_dot_from_ptl ptl ptlz).
+Proof.
+ destruct ptlz as [|???? pt]=>//=. by rewrite -ptd_buffer_build_from_pt.
+Qed.
+
+(** We prove that these functions behave well w.r.t. xxx_stack_compat. *)
+Lemma ptd_stack_compat_build_from_pt {symb word}
+ (pt : parse_tree symb word) (ptz : pt_zipper symb word)
+ (stk: stack) :
+ ptz_stack_compat stk ptz ->
+ ptd_stack_compat (build_pt_dot_from_pt pt ptz) stk
+with ptd_stack_compat_build_from_pt_rec {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
+ (stk : stack) Hsymbs :
+ ptlz_stack_compat stk ptlz ->
+ state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
+ (rev' (prod_rhs_rev (ptlz_prod ptlz))) (ptlz_lookahead ptlz) ->
+ ptd_stack_compat (build_pt_dot_from_pt_rec ptl Hsymbs ptlz) stk.
+Proof.
+ - intros Hstk. destruct pt as [tok|prod word ptl]=>/=.
+ + revert ptz Hstk. generalize [tok]. generalize (token_sem tok). generalize I.
+ change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
+ generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
+ + assert (state_has_future (state_of_stack init stk) prod
+ (rev' (prod_rhs_rev prod)) (token_term (buf_head (ptz_buffer ptz)))).
+ { revert ptz Hstk. remember (NT (prod_lhs prod)) eqn:EQ=>ptz.
+ destruct ptz as [|?? ptl0 ?? ptlz0].
+ - intros ->. apply start_future. congruence.
+ - subst. intros (stk0 & Hfut & _). apply non_terminal_closed in Hfut.
+ specialize (Hfut prod eq_refl).
+ destruct (ptlz_future_first ptlz0) as [Hfirst|[Hfirst Hnull]].
+ + destruct Hfut as [_ Hfut]. auto.
+ + destruct Hfut as [Hfut _]. by rewrite Hnull -Hfirst in Hfut. }
+ match goal with
+ | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
+ end.
+ * by apply ptd_stack_compat_build_from_pt_rec.
+ * exists stk. destruct ptl=>//.
+ - intros Hstk Hfut. destruct ptl as [|?? ptl ?? pt]; [contradiction|].
+ specialize (ptd_stack_compat_build_from_pt_rec _ _ ptl). destruct ptl.
+ + eapply ptd_stack_compat_build_from_pt=>//. exists stk.
+ split; [|split]=>//; [].
+ by rewrite -ptlz_future_ptlz_prod rev_append_rev /rev' -rev_alt
+ rev_app_distr rev_involutive in Hfut.
+ + by apply ptd_stack_compat_build_from_pt_rec.
+Qed.
+
+Lemma ptd_stack_compat_build_from_ptl {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
+ (stk stk0: stack) :
+ ptlz_stack_compat stk0 ptlz ->
+ ptl_stack_compat stk0 ptl stk ->
+ state_has_future (state_of_stack init stk) (ptlz_prod ptlz)
+ (ptlz_future ptlz) (ptlz_lookahead ptlz) ->
+ ptd_stack_compat (build_pt_dot_from_ptl ptl ptlz) stk.
+Proof.
+ intros Hstk0 Hstk Hfut. destruct ptlz=>/=.
+ - eauto.
+ - apply ptd_stack_compat_build_from_pt=>/=. eauto.
+Qed.
+
+(** We can now proceed by proving that the invariant is preserved by
+ each step of parsing. We also prove that each step of parsing
+ follows next_ptd.
+
+ We start with reduce steps: *)
+Lemma reduce_step_next_ptd (prod : production) (word : list token)
+ (ptl : parse_tree_list (prod_rhs_rev prod) word)
+ (ptz : pt_zipper (NT (prod_lhs prod)) word)
+ (stk : stack)
+ Hval Hi :
+ ptd_stack_compat (Reduce_ptd ptl ptz) stk ->
+ match next_ptd (Reduce_ptd ptl ptz) with
+ | None =>
+ reduce_step init stk prod (ptz_buffer ptz) Hval Hi =
+ Accept_sr (ptd_sem (Reduce_ptd ptl ptz)) buffer_end
+ | Some ptd =>
+ exists stk',
+ reduce_step init stk prod (ptz_buffer ptz) Hval Hi =
+ Progress_sr stk' (ptd_buffer ptd) /\
+ ptd_stack_compat ptd stk'
+ end.
+Proof.
+ intros (stk0 & _ & Hstk & Hstk0).
+ apply pop_stack_compat_pop_spec with (action := prod_action prod) in Hstk.
+ rewrite <-pop_spec_ok with (Hp := reduce_step_subproof init stk prod Hval Hi) in Hstk.
+ unfold reduce_step.
+ match goal with
+ | |- context [pop_state_valid init ?A stk ?B ?C ?D ?E ?F] =>
+ generalize (pop_state_valid init A stk B C D E F)
+ end.
+ rewrite Hstk /=. intros Hv.
+ generalize (reduce_step_subproof1 init stk prod Hval stk0 (fun _ : True => Hv)).
+ clear Hval Hstk Hi Hv stk.
+ assert (Hgoto := fun fut prod' =>
+ non_terminal_goto (state_of_stack init stk0) prod' (NT (prod_lhs prod)::fut)).
+ simpl in Hgoto.
+ destruct goto_table as [[st Hst]|] eqn:Hgoto'.
+ - intros _.
+ assert (match ptz with Top_ptz => False | _ => True end).
+ { revert ptz Hst Hstk0 Hgoto'.
+ generalize (eq_refl (NT (prod_lhs prod))).
+ generalize (NT (prod_lhs prod)) at 1 3 5.
+ intros nt Hnt ptz. destruct ptz=>//. injection Hnt=> <- /= Hst -> /= Hg.
+ assert (Hsg := start_goto init). by rewrite Hg in Hsg. }
+ clear Hgoto'.
+
+ change (ptl_sem ptl (prod_action prod))
+ with (pt_sem (Non_terminal_pt prod ptl)).
+ generalize (Non_terminal_pt prod ptl). clear ptl.
+ destruct ptz as [|?? ptl ? ? ptlz]=>// pt.
+
+ subst=>/=. eexists _. split.
+ + f_equal. apply ptd_buffer_build_from_ptl.
+ + destruct Hstk0 as (stk0' & Hfut & Hstk0' & Hstk0).
+ apply (ptd_stack_compat_build_from_ptl _ _ _ stk0'); auto; [].
+ split=>//. by exists eq_refl.
+ - intros Hv. generalize (reduce_step_subproof0 _ prod _ (fun _ => Hv)).
+ intros EQnt. clear Hv Hgoto'.
+
+ change (ptl_sem ptl (prod_action prod))
+ with (pt_sem (Non_terminal_pt prod ptl)).
+ generalize (Non_terminal_pt prod ptl). clear ptl. destruct ptz.
+ + intros pt. f_equal. by rewrite cast_eq.
+ + edestruct Hgoto. eapply ptz_stack_compat_cons_state_has_future, Hstk0.
+Qed.
+
+Lemma step_next_ptd (ptd : pt_dot) (stk : stack) Hi :
+ ptd_stack_compat ptd stk ->
+ match next_ptd ptd with
+ | None =>
+ step safe init stk (ptd_buffer ptd) Hi =
+ Accept_sr (ptd_sem ptd) buffer_end
+ | Some ptd' =>
+ exists stk',
+ step safe init stk (ptd_buffer ptd) Hi =
+ Progress_sr stk' (ptd_buffer ptd') /\
+ ptd_stack_compat ptd' stk'
+ end.
+Proof.
+ intros Hstk. unfold step.
+ generalize (reduce_ok safe (state_of_stack init stk)).
+ destruct ptd as [prod word ptl ptz|tok symbs word ptl ptlz].
+ - assert (Hfut : state_has_future (state_of_stack init stk) prod []
+ (token_term (buf_head (ptz_buffer ptz)))).
+ { destruct Hstk as (? & ? & ?)=>//. }
+ assert (Hact := end_reduce _ _ _ _ Hfut).
+ destruct action_table as [?|awt]=>Hval /=.
+ + subst. by apply reduce_step_next_ptd.
+ + set (term := token_term (buf_head (ptz_buffer ptz))) in *.
+ generalize (Hval term). clear Hval. destruct (awt term)=>//. subst.
+ intros Hval. by apply reduce_step_next_ptd.
+ - destruct Hstk as (stk0 & Hfut & Hstk & Hstk0).
+ assert (Hact := terminal_shift _ _ _ _ Hfut). simpl in Hact. clear Hfut.
+ destruct action_table as [?|awt]=>//= /(_ (token_term tok)).
+ destruct awt as [st' EQ| |]=>// _. eexists. split.
+ + f_equal. rewrite -ptd_buffer_build_from_ptl //.
+ + apply (ptd_stack_compat_build_from_ptl _ _ _ stk0); simpl; eauto.
+Qed.
+
+(** We prove the completeness of the parser main loop. *)
+Lemma parse_fix_next_ptd_iter (ptd : pt_dot) (stk : stack) (log_n_steps : nat) Hi :
+ ptd_stack_compat ptd stk ->
+ match next_ptd_iter ptd log_n_steps with
+ | None =>
+ proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) =
+ Accept_sr (ptd_sem ptd) buffer_end
+ | Some ptd' =>
+ exists stk',
+ proj1_sig (parse_fix safe init stk (ptd_buffer ptd) log_n_steps Hi) =
+ Progress_sr stk' (ptd_buffer ptd') /\
+ ptd_stack_compat ptd' stk'
+ end.
+Proof.
+ revert ptd stk Hi.
+ induction log_n_steps as [|log_n_steps IH]; [by apply step_next_ptd|].
+ move => /= ptd stk Hi Hstk. assert (IH1 := IH ptd stk Hi Hstk).
+ assert (EQsem := sem_next_ptd_iter ptd log_n_steps).
+ destruct parse_fix as [sr Hi']. simpl in IH1.
+ destruct next_ptd_iter as [ptd'|].
+ - rewrite EQsem. destruct IH1 as (stk' & -> & Hstk'). by apply IH.
+ - by subst.
+Qed.
+
+(** The parser is defined by recursion over a fuel parameter. In the
+ completeness proof, we need to predict how much fuel is going to be
+ needed in order to prove that enough fuel gives rise to a successful
+ parsing.
+
+ To do so, of a dotted parse tree, which is the number of actions
+ left to be executed before complete parsing when the current state
+ is represented by the dotted parse tree. *)
+Fixpoint ptlz_cost {hole_symbs hole_word}
+ (ptlz:ptl_zipper hole_symbs hole_word) :=
+ match ptlz with
+ | Non_terminal_pt_ptlz ptz => ptz_cost ptz
+ | Cons_ptl_ptlz pt ptlz' => pt_size pt + ptlz_cost ptlz'
+ end
+with ptz_cost {hole_symb hole_word} (ptz:pt_zipper hole_symb hole_word) :=
+ match ptz with
+ | Top_ptz => 0
+ | Cons_ptl_ptz ptl ptlz' => 1 + ptlz_cost ptlz'
+ end.
+
+Definition ptd_cost (ptd:pt_dot) :=
+ match ptd with
+ | Reduce_ptd ptl ptz => ptz_cost ptz
+ | Shift_ptd _ ptl ptlz => 1 + ptlz_cost ptlz
+ end.
+
+Lemma ptd_cost_build_from_pt {symb word}
+ (pt : parse_tree symb word) (ptz : pt_zipper symb word) :
+ pt_size pt + ptz_cost ptz = S (ptd_cost (build_pt_dot_from_pt pt ptz))
+with ptd_cost_build_from_pt_rec {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word)
+ Hsymbs :
+ ptl_size ptl + ptlz_cost ptlz = ptd_cost (build_pt_dot_from_pt_rec ptl Hsymbs ptlz).
+Proof.
+ - destruct pt as [tok|prod word ptl']=>/=.
+ + revert ptz. generalize [tok]. generalize (token_sem tok). generalize I.
+ change True with (match T (token_term tok) with T _ => True | NT _ => False end) at 1.
+ generalize (T (token_term tok)) => symb HT sem word ptz. by destruct ptz.
+ + match goal with
+ | |- context [match ?X with Some H => _ | None => _ end] => destruct X eqn:EQ
+ end.
+ * rewrite -ptd_cost_build_from_pt_rec /= plus_n_Sm //.
+ * simpl. by destruct ptl'.
+ - destruct ptl as [|?? ptl ?? pt]; [contradiction|].
+ specialize (ptd_cost_build_from_pt_rec _ _ ptl). destruct ptl.
+ + apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring.
+ + rewrite -ptd_cost_build_from_pt_rec //=. ring.
+Qed.
+
+Lemma ptd_cost_build_from_ptl {symbs word}
+ (ptl : parse_tree_list symbs word) (ptlz : ptl_zipper symbs word) :
+ ptlz_cost ptlz = ptd_cost (build_pt_dot_from_ptl ptl ptlz).
+Proof.
+ destruct ptlz=>//. apply eq_add_S. rewrite -ptd_cost_build_from_pt /=. ring.
+Qed.
+
+Lemma next_ptd_cost ptd:
+ match next_ptd ptd with
+ | None => ptd_cost ptd = 0
+ | Some ptd' => ptd_cost ptd = S (ptd_cost ptd')
+ end.
+Proof.
+ destruct ptd as [prod word ptl ptz|tok symbq wordq ptl ptlz] =>/=.
+ - generalize (Non_terminal_pt prod ptl). clear ptl.
+ destruct ptz as [|?? ptl ?? ptlz]=>// pt. by rewrite -ptd_cost_build_from_ptl.
+ - by rewrite -ptd_cost_build_from_ptl.
+Qed.
+
+Lemma next_ptd_iter_cost ptd log_n_steps :
+ match next_ptd_iter ptd log_n_steps with
+ | None => ptd_cost ptd < 2^log_n_steps
+ | Some ptd' => ptd_cost ptd = 2^log_n_steps + ptd_cost ptd'
+ end.
+Proof.
+ revert ptd. induction log_n_steps as [|log_n_steps IH]=>ptd /=.
+ - assert (Hptd := next_ptd_cost ptd). destruct next_ptd=>//. by rewrite Hptd.
+ - rewrite Nat.add_0_r. assert (IH1 := IH ptd). destruct next_ptd_iter as [ptd'|].
+ + specialize (IH ptd'). destruct next_ptd_iter as [ptd''|].
+ * by rewrite IH1 IH -!plus_assoc.
+ * rewrite IH1. by apply plus_lt_compat_l.
+ + by apply lt_plus_trans.
+Qed.
+
+(** We now prove the top-level parsing function. The only thing that
+ is left to be done is the initialization. To do so, we define the
+ initial dotted parse tree, depending on a full (top-level) parse tree. *)
+
+Variable full_pt : parse_tree (NT (start_nt init)) full_word.
+
+Theorem parse_complete log_n_steps:
+ match parse safe init (full_word ++ buffer_end) log_n_steps with
+ | Parsed_pr sem buff =>
+ sem = pt_sem full_pt /\ buff = buffer_end /\ pt_size full_pt <= 2^log_n_steps
+ | Timeout_pr => 2^log_n_steps < pt_size full_pt
+ | Fail_pr => False
+ end.
+Proof.
+ assert (Hstk : ptd_stack_compat (build_pt_dot_from_pt full_pt Top_ptz) []) by
+ by apply ptd_stack_compat_build_from_pt.
+ unfold parse.
+ assert (Hparse := parse_fix_next_ptd_iter _ _ log_n_steps (parse_subproof init) Hstk).
+ rewrite -ptd_buffer_build_from_pt -sem_build_from_pt /= in Hparse.
+ assert (Hcost := next_ptd_iter_cost (build_pt_dot_from_pt full_pt Top_ptz) log_n_steps).
+ destruct next_ptd_iter.
+ - destruct Hparse as (? & -> & ?). apply (f_equal S) in Hcost.
+ rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost. rewrite Hcost.
+ apply le_lt_n_Sm, le_plus_l.
+ - rewrite Hparse. split; [|split]=>//. apply lt_le_S in Hcost.
+ by rewrite -ptd_cost_build_from_pt Nat.add_0_r in Hcost.
+Qed.
+
+End Completeness_Proof.
+
+End Make.
diff --git a/MenhirLib/Interpreter_correct.v b/MenhirLib/Interpreter_correct.v
new file mode 100644
index 00000000..1325f610
--- /dev/null
+++ b/MenhirLib/Interpreter_correct.v
@@ -0,0 +1,175 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax.
+Require Import Alphabet.
+Require Grammar Automaton Interpreter.
+From Coq.ssr Require Import ssreflect.
+
+Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
+
+(** * Correctness of the interpreter **)
+
+(** We prove that, in any case, if the interpreter accepts returning a
+ semantic value, then this is a semantic value of the input **)
+
+Section Init.
+
+Variable init:initstate.
+
+(** [word_has_stack_semantics] relates a word with a stack, stating that the
+ word is a concatenation of words that have the semantic values stored in
+ the stack. **)
+Inductive word_has_stack_semantics:
+ forall (word:list token) (stack:stack), Prop :=
+ | Nil_stack_whss: word_has_stack_semantics [] []
+ | Cons_stack_whss:
+ forall (wordq:list token) (stackq:stack),
+ word_has_stack_semantics wordq stackq ->
+
+ forall (wordt:list token) (s:noninitstate)
+ (pt:parse_tree (last_symb_of_non_init_state s) wordt),
+
+ word_has_stack_semantics
+ (wordq++wordt) (existT noninitstate_type s (pt_sem pt)::stackq).
+
+(** [pop] preserves the invariant **)
+Lemma pop_spec_ptl A symbols_to_pop action word_stk stk (res : A) stk' :
+ pop_spec symbols_to_pop stk action stk' res ->
+ word_has_stack_semantics word_stk stk ->
+ exists word_stk' word_res (ptl:parse_tree_list symbols_to_pop word_res),
+ (word_stk' ++ word_res = word_stk)%list /\
+ word_has_stack_semantics word_stk' stk' /\
+ ptl_sem ptl action = res.
+Proof.
+ intros Hspec. revert word_stk.
+ induction Hspec as [stk sem|symbols_to_pop st stk action sem stk' res Hspec IH];
+ intros word_stk Hword_stk.
+ - exists word_stk, [], Nil_ptl. rewrite -app_nil_end. eauto.
+ - inversion Hword_stk. subst_existT.
+ edestruct IH as (word_stk' & word_res & ptl & ? & Hword_stk'' & ?); [eassumption|].
+ subst. eexists word_stk', (word_res ++ _)%list, (Cons_ptl ptl _).
+ split; [|split]=>//. rewrite app_assoc //.
+Qed.
+
+(** [reduce_step] preserves the invariant **)
+Lemma reduce_step_invariant (stk:stack) (prod:production) Hv Hi word buffer :
+ word_has_stack_semantics word stk ->
+ match reduce_step init stk prod buffer Hv Hi with
+ | Accept_sr sem buffer_new =>
+ exists pt : parse_tree (NT (start_nt init)) word,
+ buffer = buffer_new /\ pt_sem pt = sem
+ | Progress_sr stk' buffer_new =>
+ buffer = buffer_new /\ word_has_stack_semantics word stk'
+ | Fail_sr => True
+ end.
+Proof.
+ intros Hword_stk. unfold reduce_step.
+ match goal with
+ | |- context [pop_state_valid init ?stp stk ?x1 ?x2 ?x3 ?x4 ?x5] =>
+ generalize (pop_state_valid init stp stk x1 x2 x3 x4 x5)
+ end.
+ destruct pop as [stk' sem] eqn:Hpop=>/= Hv'.
+ apply pop_spec_ok in Hpop. apply pop_spec_ptl with (word_stk := word) in Hpop=>//.
+ destruct Hpop as (word1 & word2 & ptl & <- & Hword1 & <-).
+ generalize (reduce_step_subproof1 init stk prod Hv stk' (fun _ : True => Hv')).
+ destruct goto_table as [[st' EQ]|].
+ - intros _. split=>//.
+ change (ptl_sem ptl (prod_action prod)) with (pt_sem (Non_terminal_pt prod ptl)).
+ generalize (Non_terminal_pt prod ptl). rewrite ->EQ. intros pt. by constructor.
+ - intros Hstk'. destruct Hword1; [|by destruct Hstk'].
+ generalize (reduce_step_subproof0 init prod [] (fun _ : True => Hstk')).
+ simpl in Hstk'. rewrite -Hstk' // => EQ. rewrite cast_eq.
+ exists (Non_terminal_pt prod ptl). by split.
+Qed.
+
+(** [step] preserves the invariant **)
+Lemma step_invariant stk word buffer safe Hi :
+ word_has_stack_semantics word stk ->
+ match step safe init stk buffer Hi with
+ | Accept_sr sem buffer_new =>
+ exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
+ (word ++ buffer = word_new ++ buffer_new)%buf /\
+ pt_sem pt = sem
+ | Progress_sr stk_new buffer_new =>
+ exists word_new,
+ (word ++ buffer = word_new ++ buffer_new)%buf /\
+ word_has_stack_semantics word_new stk_new
+ | Fail_sr => True
+ end.
+Proof.
+ intros Hword_stk. unfold step.
+ generalize (reduce_ok safe (state_of_stack init stk)).
+ destruct action_table as [prod|awt].
+ - intros Hv.
+ apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word buffer) in Hword_stk.
+ destruct reduce_step=>//.
+ + destruct Hword_stk as (pt & <- & <-); eauto.
+ + destruct Hword_stk as [<- ?]; eauto.
+ - destruct buffer as [tok buffer]=>/=.
+ move=> /(_ (token_term tok)) Hv. destruct (awt (token_term tok)) as [st EQ|prod|]=>//.
+ + eexists _. split; [by apply app_buf_assoc with (l2 := [_])|].
+ change (token_sem tok) with (pt_sem (Terminal_pt tok)).
+ generalize (Terminal_pt tok). generalize [tok].
+ rewrite -> EQ=>word' pt /=. by constructor.
+ + apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word (tok::buffer))
+ in Hword_stk.
+ destruct reduce_step=>//.
+ * destruct Hword_stk as (pt & <- & <-); eauto.
+ * destruct Hword_stk as [<- ?]; eauto.
+Qed.
+
+(** [step] preserves the invariant **)
+Lemma parse_fix_invariant stk word buffer safe log_n_steps Hi :
+ word_has_stack_semantics word stk ->
+ match proj1_sig (parse_fix safe init stk buffer log_n_steps Hi) with
+ | Accept_sr sem buffer_new =>
+ exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
+ (word ++ buffer = word_new ++ buffer_new)%buf /\
+ pt_sem pt = sem
+ | Progress_sr stk_new buffer_new =>
+ exists word_new,
+ (word ++ buffer = word_new ++ buffer_new)%buf /\
+ word_has_stack_semantics word_new stk_new
+ | Fail_sr => True
+ end.
+Proof.
+ revert stk word buffer Hi.
+ induction log_n_steps as [|log_n_steps IH]=>/= stk word buffer Hi Hstk;
+ [by apply step_invariant|].
+ assert (IH1 := IH stk word buffer Hi Hstk).
+ destruct parse_fix as [[] Hi']=>/=; try by apply IH1.
+ destruct IH1 as (word' & -> & Hstk')=>//. by apply IH.
+Qed.
+
+(** The interpreter is correct : if it returns a semantic value, then the input
+ word has this semantic value.
+**)
+Theorem parse_correct safe buffer log_n_steps:
+ match parse safe init buffer log_n_steps with
+ | Parsed_pr sem buffer_new =>
+ exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
+ buffer = (word_new ++ buffer_new)%buf /\
+ pt_sem pt = sem
+ | _ => True
+ end.
+Proof.
+ unfold parse.
+ assert (Hparse := parse_fix_invariant [] [] buffer safe log_n_steps
+ (parse_subproof init)).
+ destruct proj1_sig=>//. apply Hparse. constructor.
+Qed.
+
+End Init.
+
+End Make.
diff --git a/MenhirLib/Main.v b/MenhirLib/Main.v
new file mode 100644
index 00000000..f6158074
--- /dev/null
+++ b/MenhirLib/Main.v
@@ -0,0 +1,79 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+Require Grammar Automaton Interpreter_correct Interpreter_complete.
+From Coq Require Import Syntax Arith.
+
+Module Make(Export Aut:Automaton.T).
+Export Aut.Gram.
+Export Aut.GramDefs.
+
+Module Import Inter := Interpreter.Make Aut.
+Module Correct := Interpreter_correct.Make Aut Inter.
+Module Complete := Interpreter_complete.Make Aut Inter.
+
+Definition complete_validator:unit->bool := Complete.Valid.is_complete.
+Definition safe_validator:unit->bool := ValidSafe.is_safe.
+Definition parse (safe:safe_validator ()=true) init log_n_steps buffer :
+ parse_result (symbol_semantic_type (NT (start_nt init))):=
+ parse (ValidSafe.safe_is_validator safe) init buffer log_n_steps.
+
+(** Correction theorem. **)
+Theorem parse_correct
+ (safe:safe_validator ()= true) init log_n_steps buffer:
+ match parse safe init log_n_steps buffer with
+ | Parsed_pr sem buffer_new =>
+ exists word (pt : parse_tree (NT (start_nt init)) word),
+ buffer = (word ++ buffer_new)%buf /\
+ pt_sem pt = sem
+ | _ => True
+ end.
+Proof. apply Correct.parse_correct. Qed.
+
+(** Completeness theorem. **)
+Theorem parse_complete
+ (safe:safe_validator () = true) init log_n_steps word buffer_end:
+ complete_validator () = true ->
+ forall tree:parse_tree (NT (start_nt init)) word,
+ match parse safe init log_n_steps (word ++ buffer_end) with
+ | Fail_pr => False
+ | Parsed_pr sem_res buffer_end_res =>
+ sem_res = pt_sem tree /\ buffer_end_res = buffer_end /\
+ pt_size tree <= 2^log_n_steps
+ | Timeout_pr => 2^log_n_steps < pt_size tree
+ end.
+Proof.
+ intros. now apply Complete.parse_complete, Complete.Valid.complete_is_validator.
+Qed.
+
+(** Unambiguity theorem. **)
+Theorem unambiguity:
+ safe_validator () = true -> complete_validator () = true -> inhabited token ->
+ forall init word,
+ forall (tree1 tree2:parse_tree (NT (start_nt init)) word),
+ pt_sem tree1 = pt_sem tree2.
+Proof.
+ intros Hsafe Hcomp [tok] init word tree1 tree2.
+ pose (buf_end := cofix buf_end := (tok :: buf_end)%buf).
+ assert (Hcomp1 := parse_complete Hsafe init (pt_size tree1) word buf_end
+ Hcomp tree1).
+ assert (Hcomp2 := parse_complete Hsafe init (pt_size tree1) word buf_end
+ Hcomp tree2).
+ destruct parse.
+ - destruct Hcomp1.
+ - exfalso. eapply PeanoNat.Nat.lt_irrefl. etransitivity; [|apply Hcomp1].
+ eapply Nat.pow_gt_lin_r. constructor.
+ - destruct Hcomp1 as [-> _], Hcomp2 as [-> _]. reflexivity.
+Qed.
+
+End Make.
diff --git a/MenhirLib/Validator_classes.v b/MenhirLib/Validator_classes.v
new file mode 100644
index 00000000..d8063123
--- /dev/null
+++ b/MenhirLib/Validator_classes.v
@@ -0,0 +1,75 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List.
+From Coq.ssr Require Import ssreflect.
+Require Import Alphabet.
+
+Class IsValidator (P : Prop) (b : bool) :=
+ is_validator : b = true -> P.
+Hint Mode IsValidator + - : typeclass_instances.
+
+Instance is_validator_true : IsValidator True true.
+Proof. done. Qed.
+
+Instance is_validator_false : IsValidator False false.
+Proof. done. Qed.
+
+Instance is_validator_eq_true b :
+ IsValidator (b = true) b.
+Proof. done. Qed.
+
+Instance is_validator_and P1 b1 P2 b2 `{IsValidator P1 b1} `{IsValidator P2 b2}:
+ IsValidator (P1 /\ P2) (if b1 then b2 else false).
+Proof. by split; destruct b1, b2; apply is_validator. Qed.
+
+Instance is_validator_comparable_leibniz_eq A (C:Comparable A) (x y : A) :
+ ComparableLeibnizEq C ->
+ IsValidator (x = y) (compare_eqb x y).
+Proof. intros ??. by apply compare_eqb_iff. Qed.
+
+Instance is_validator_comparable_eq_impl A `(Comparable A) (x y : A) P b :
+ IsValidator P b ->
+ IsValidator (x = y -> P) (if compare_eqb x y then b else true).
+Proof.
+ intros Hval Val ->. rewrite /compare_eqb compare_refl in Val. auto.
+Qed.
+
+Lemma is_validator_forall_finite A P b `(Finite A) :
+ (forall (x : A), IsValidator (P x) (b x)) ->
+ IsValidator (forall (x : A), P x) (forallb b all_list).
+Proof.
+ move=> ? /forallb_forall Hb ?.
+ apply is_validator, Hb, all_list_forall.
+Qed.
+
+(* We do not use an instance directly here, because we need somehow to
+ force Coq to instantiate b with a lambda. *)
+Hint Extern 2 (IsValidator (forall x : ?A, _) _) =>
+ eapply (is_validator_forall_finite _ _ (fun (x:A) => _))
+ : typeclass_instances.
+
+(* Hint for synthetizing pattern-matching. *)
+Hint Extern 2 (IsValidator (match ?u with _ => _ end) ?b0) =>
+ let b := fresh "b" in
+ unshelve notypeclasses refine (let b : bool := _ in _);
+ [destruct u; intros; shelve|]; (* Synthetize `match .. with` in the validator. *)
+ unify b b0;
+ unfold b; destruct u; clear b
+ : typeclass_instances.
+
+(* Hint for unfolding definitions. This is necessary because many
+ hints for IsValidator use [Hint Extern], which do not automatically
+ unfold identifiers. *)
+Hint Extern 100 (IsValidator ?X _) => unfold X
+ : typeclass_instances.
diff --git a/MenhirLib/Validator_complete.v b/MenhirLib/Validator_complete.v
new file mode 100644
index 00000000..ebb74500
--- /dev/null
+++ b/MenhirLib/Validator_complete.v
@@ -0,0 +1,394 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax Derive.
+From Coq.ssr Require Import ssreflect.
+Require Automaton.
+Require Import Alphabet Validator_classes.
+
+Module Make(Import A:Automaton.T).
+
+(** We instantiate some sets/map. **)
+Module TerminalComparableM <: ComparableM.
+ Definition t := terminal.
+ Instance tComparable : Comparable t := _.
+End TerminalComparableM.
+Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM.
+Module StateProdPosComparableM <: ComparableM.
+ Definition t := (state*production*nat)%type.
+ Instance tComparable : Comparable t := _.
+End StateProdPosComparableM.
+Module StateProdPosOrderedType :=
+ OrderedType_from_ComparableM StateProdPosComparableM.
+
+Module TerminalSet := FSetAVL.Make TerminalOrderedType.
+Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.
+
+(** Nullable predicate for symbols and list of symbols. **)
+Definition nullable_symb (symbol:symbol) :=
+ match symbol with
+ | NT nt => nullable_nterm nt
+ | _ => false
+ end.
+
+Definition nullable_word (word:list symbol) :=
+ forallb nullable_symb word.
+
+(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
+Definition first_nterm_set (nterm:nonterminal) :=
+ fold_left (fun acc t => TerminalSet.add t acc)
+ (first_nterm nterm) TerminalSet.empty.
+
+Definition first_symb_set (symbol:symbol) :=
+ match symbol with
+ | NT nt => first_nterm_set nt
+ | T t => TerminalSet.singleton t
+ end.
+
+Fixpoint first_word_set (word:list symbol) :=
+ match word with
+ | [] => TerminalSet.empty
+ | t::q =>
+ if nullable_symb t then
+ TerminalSet.union (first_symb_set t) (first_word_set q)
+ else
+ first_symb_set t
+ end.
+
+(** Small helper for finding the part of an item that is after the dot. **)
+Definition future_of_prod prod dot_pos : list symbol :=
+ (fix loop n lst :=
+ match n with
+ | O => lst
+ | S x => match loop x lst with [] => [] | _::q => q end
+ end)
+ dot_pos (rev' (prod_rhs_rev prod)).
+
+(** We build a fast map to store all the items of all the states. **)
+Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
+ fold_left (fun acc state =>
+ fold_left (fun acc item =>
+ let key := (state, prod_item item, dot_pos_item item) in
+ let data := fold_left (fun acc t => TerminalSet.add t acc)
+ (lookaheads_item item) TerminalSet.empty
+ in
+ let old :=
+ match StateProdPosMap.find key acc with
+ | Some x => x | None => TerminalSet.empty
+ end
+ in
+ StateProdPosMap.add key (TerminalSet.union data old) acc
+ ) (items_of_state state) acc
+ ) all_list (StateProdPosMap.empty TerminalSet.t).
+
+(** We need to avoid computing items_map each time we need it. To that
+ purpose, we declare a typeclass specifying that some map is equal to
+ items_map. *)
+Class IsItemsMap m := is_items_map : m = items_map ().
+
+(** Accessor. **)
+Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
+ match StateProdPosMap.find (state, prod, dot_pos) items_map with
+ | None => TerminalSet.empty
+ | Some x => x
+ end.
+
+Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
+ exists dot_pos:nat,
+ fut = future_of_prod prod dot_pos /\
+ TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).
+
+(** Iterator over items. **)
+Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
+ StateProdPosMap.fold (fun key set acc =>
+ match key with (st, p, pos) => (acc && P st p pos set)%bool end
+ ) items_map true.
+
+(** Typeclass instances for synthetizing the validator. *)
+
+Instance is_validator_subset S1 S2 :
+ IsValidator (TerminalSet.Subset S1 S2) (TerminalSet.subset S1 S2).
+Proof. intros ?. by apply TerminalSet.subset_2. Qed.
+
+(* While the specification of the validator always quantify over
+ possible lookahead tokens individually, the validator usually
+ handles lookahead sets directly instead, for better performances.
+
+ For instance, the validator for [state_has_future], which speaks
+ about one single lookahead token is a subset operation:
+*)
+Lemma is_validator_state_has_future_subset st prod pos lookahead lset im fut :
+ TerminalSet.In lookahead lset ->
+ fut = future_of_prod prod pos ->
+ IsItemsMap im ->
+ IsValidator (state_has_future st prod fut lookahead)
+ (TerminalSet.subset lset (find_items_map im st prod pos)).
+Proof.
+ intros ? -> -> HSS%TerminalSet.subset_2. exists pos. split=>//. by apply HSS.
+Qed.
+(* We do not declare this lemma as an instance, and use [Hint Extern]
+ instead, because the typeclass mechanism has trouble instantiating
+ some evars if we do not explicitely call [eassumption]. *)
+Hint Extern 2 (IsValidator (state_has_future _ _ _ _) _) =>
+ eapply is_validator_state_has_future_subset; [eassumption|eassumption || reflexivity|]
+: typeclass_instances.
+
+(* As said previously, we manipulate lookahead terminal sets instead of
+ lookahead individually. Hence, when we quantify over a lookahead set
+ in the specification, we do not do anything in the executable
+ validator.
+
+ This instance is used for [non_terminal_closed]. *)
+Instance is_validator_forall_lookahead_set lset P b:
+ (forall lookahead, TerminalSet.In lookahead lset -> IsValidator (P lookahead) b) ->
+ IsValidator (forall lookahead, TerminalSet.In lookahead lset -> P lookahead) b.
+Proof. unfold IsValidator. firstorder. Qed.
+
+
+(* Dually, we sometimes still need to explicitelly iterate over a
+ lookahead set. This is what this lemma allows.
+ Used only in [end_reduce]. *)
+Lemma is_validator_iterate_lset P b lookahead lset :
+ TerminalSet.In lookahead lset ->
+ IsValidator P (b lookahead) ->
+ IsValidator P (TerminalSet.fold (fun lookahead acc =>
+ if acc then b lookahead else false) lset true).
+Proof.
+ intros Hlset%TerminalSet.elements_1 Hval Val. apply Hval.
+ revert Val. rewrite TerminalSet.fold_1. generalize true at 1. clear -Hlset.
+ induction Hlset as [? l <-%compare_eq|? l ? IH]=> /= b' Val.
+ - destruct (b lookahead). by destruct b'. exfalso. by induction l; destruct b'.
+ - eauto.
+Qed.
+Hint Extern 100 (IsValidator _ _) =>
+ match goal with
+ | H : TerminalSet.In ?lookahead ?lset |- _ =>
+ eapply (is_validator_iterate_lset _ (fun lookahead => _) _ _ H); clear H
+ end
+: typeclass_instances.
+
+(* We often quantify over all the items of all the states of the
+ automaton. This lemma and the accompanying [Hint Resolve]
+ declaration allow generating the corresponding executable
+ validator.
+
+ Note that it turns out that, in all the uses of this pattern, the
+ first thing we do for each item is pattern-matching over the
+ future. This lemma also embbed this pattern-matching, which makes
+ it possible to get the hypothesis [fut' = future_of_prod prod (S pos)]
+ in the non-nil branch.
+
+ Moreover, note, again, that while the specification quantifies over
+ lookahead terminals individually, the code provides lookahead sets
+ instead. *)
+Lemma is_validator_forall_items P1 b1 P2 b2 im :
+ IsItemsMap im ->
+
+ (forall st prod lookahead lset pos,
+ TerminalSet.In lookahead lset ->
+ [] = future_of_prod prod pos ->
+ IsValidator (P1 st prod lookahead) (b1 st prod pos lset)) ->
+
+ (forall st prod pos lookahead lset s fut',
+ TerminalSet.In lookahead lset ->
+ fut' = future_of_prod prod (S pos) ->
+ IsValidator (P2 st prod lookahead s fut') (b2 st prod pos lset s fut')) ->
+
+ IsValidator (forall st prod fut lookahead,
+ state_has_future st prod fut lookahead ->
+ match fut with
+ | [] => P1 st prod lookahead
+ | s :: fut' => P2 st prod lookahead s fut'
+ end)
+ (forallb_items im (fun st prod pos lset =>
+ match future_of_prod prod pos with
+ | [] => b1 st prod pos lset
+ | s :: fut' => b2 st prod pos lset s fut'
+ end)).
+Proof.
+ intros -> Hval1 Hval2 Val st prod fut lookahead (pos & -> & Hlookahead).
+ rewrite /forallb_items StateProdPosMap.fold_1 in Val.
+ assert (match future_of_prod prod pos with
+ | [] => b1 st prod pos (find_items_map (items_map ()) st prod pos)
+ | s :: fut' => b2 st prod pos (find_items_map (items_map ()) st prod pos) s fut'
+ end = true).
+ - unfold find_items_map in *.
+ assert (Hfind := @StateProdPosMap.find_2 _ (items_map ()) (st, prod, pos)).
+ destruct StateProdPosMap.find as [lset|]; [|by edestruct (TerminalSet.empty_1); eauto].
+ specialize (Hfind _ eq_refl). apply StateProdPosMap.elements_1 in Hfind.
+ revert Val. generalize true at 1.
+ induction Hfind as [[? ?] l [?%compare_eq ?]|??? IH]=>?.
+ + simpl in *; subst.
+ match goal with |- _ -> ?X = true => destruct X end; [done|].
+ rewrite Bool.andb_false_r. clear. induction l as [|[[[??]?]?] l IH]=>//.
+ + apply IH.
+ - destruct future_of_prod eqn:EQ. by eapply Hval1; eauto.
+ eapply Hval2 with (pos := pos); eauto; [].
+ revert EQ. unfold future_of_prod=>-> //.
+Qed.
+(* We need a hint for expplicitely instantiating b1 and b2 with lambdas. *)
+Hint Extern 0 (IsValidator
+ (forall st prod fut lookahead,
+ state_has_future st prod fut lookahead -> _)
+ _) =>
+ eapply (is_validator_forall_items _ (fun st prod pos lset => _)
+ _ (fun st prod pos lset s fut' => _))
+ : typeclass_instances.
+
+(* Used in [start_future] only. *)
+Instance is_validator_forall_state_has_future im st prod :
+ IsItemsMap im ->
+ IsValidator
+ (forall look, state_has_future st prod (rev' (prod_rhs_rev prod)) look)
+ (let lookaheads := find_items_map im st prod 0 in
+ forallb (fun t => TerminalSet.mem t lookaheads) all_list).
+Proof.
+ move=> -> /forallb_forall Val look.
+ specialize (Val look (all_list_forall _)). exists 0. split=>//.
+ by apply TerminalSet.mem_2.
+Qed.
+
+(** * Validation for completeness **)
+
+(** The nullable predicate is a fixpoint : it is correct. **)
+Definition nullable_stable :=
+ forall p:production,
+ if nullable_word (prod_rhs_rev p) then
+ nullable_nterm (prod_lhs p) = true
+ else True.
+
+(** The first predicate is a fixpoint : it is correct. **)
+Definition first_stable:=
+ forall (p:production),
+ TerminalSet.Subset (first_word_set (rev' (prod_rhs_rev p)))
+ (first_nterm_set (prod_lhs p)).
+
+(** The initial state has all the S=>.u items, where S is the start non-terminal **)
+Definition start_future :=
+ forall (init:initstate) (p:production),
+ prod_lhs p = start_nt init ->
+ forall (t:terminal),
+ state_has_future init p (rev' (prod_rhs_rev p)) t.
+
+(** If a state contains an item of the form A->_.av[[b]], where a is a
+ terminal, then reading an a does a [Shift_act], to a state containing
+ an item of the form A->_.v[[b]]. **)
+Definition terminal_shift :=
+ forall (s1:state) prod fut lookahead,
+ state_has_future s1 prod fut lookahead ->
+ match fut with
+ | T t::q =>
+ match action_table s1 with
+ | Lookahead_act awp =>
+ match awp t with
+ | Shift_act s2 _ =>
+ state_has_future s2 prod q lookahead
+ | _ => False
+ end
+ | _ => False
+ end
+ | _ => True
+ end.
+
+(** If a state contains an item of the form A->_.[[a]], then either we do a
+ [Default_reduce_act] of the corresponding production, either a is a
+ terminal (ie. there is a lookahead terminal), and reading a does a
+ [Reduce_act] of the corresponding production. **)
+Definition end_reduce :=
+ forall (s:state) prod fut lookahead,
+ state_has_future s prod fut lookahead ->
+ match fut with
+ | [] =>
+ match action_table s with
+ | Default_reduce_act p => p = prod
+ | Lookahead_act awt =>
+ match awt lookahead with
+ | Reduce_act p => p = prod
+ | _ => False
+ end
+ end
+ | _ => True
+ end.
+
+Definition is_end_reduce items_map :=
+ forallb_items items_map (fun s prod pos lset =>
+ match future_of_prod prod pos with
+ | [] =>
+ match action_table s with
+ | Default_reduce_act p => compare_eqb p prod
+ | Lookahead_act awt =>
+ TerminalSet.fold (fun lookahead acc =>
+ match awt lookahead with
+ | Reduce_act p => (acc && compare_eqb p prod)%bool
+ | _ => false
+ end) lset true
+ end
+ | _ => true
+ end).
+
+(** If a state contains an item of the form A->_.Bv[[b]], where B is a
+ non terminal, then the goto table says we have to go to a state containing
+ an item of the form A->_.v[[b]]. **)
+Definition non_terminal_goto :=
+ forall (s1:state) prod fut lookahead,
+ state_has_future s1 prod fut lookahead ->
+ match fut with
+ | NT nt::q =>
+ match goto_table s1 nt with
+ | Some (exist _ s2 _) =>
+ state_has_future s2 prod q lookahead
+ | None => False
+ end
+ | _ => True
+ end.
+
+Definition start_goto :=
+ forall (init:initstate),
+ match goto_table init (start_nt init) with
+ | None => True
+ | Some _ => False
+ end.
+
+(** Closure property of item sets : if a state contains an item of the form
+ A->_.Bv[[b]], then for each production B->u and each terminal a of
+ first(vb), the state contains an item of the form B->_.u[[a]] **)
+Definition non_terminal_closed :=
+ forall s1 prod fut lookahead,
+ state_has_future s1 prod fut lookahead ->
+ match fut with
+ | NT nt::q =>
+ forall p, prod_lhs p = nt ->
+ (if nullable_word q then
+ state_has_future s1 p (future_of_prod p 0) lookahead
+ else True) /\
+ (forall lookahead2,
+ TerminalSet.In lookahead2 (first_word_set q) ->
+ state_has_future s1 p (future_of_prod p 0) lookahead2)
+ | _ => True
+ end.
+
+(** The automaton is complete **)
+Definition complete :=
+ nullable_stable /\ first_stable /\ start_future /\ terminal_shift
+ /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed.
+
+Derive is_complete_0
+SuchThat (forall im, IsItemsMap im -> IsValidator complete (is_complete_0 im))
+As complete_0_is_validator.
+Proof. intros im. subst is_complete_0. instantiate (1:=fun im => _). apply _. Qed.
+
+Definition is_complete (_:unit) := is_complete_0 (items_map ()).
+Lemma complete_is_validator : IsValidator complete (is_complete ()).
+Proof. by apply complete_0_is_validator. Qed.
+
+End Make.
diff --git a/MenhirLib/Validator_safe.v b/MenhirLib/Validator_safe.v
new file mode 100644
index 00000000..628d2009
--- /dev/null
+++ b/MenhirLib/Validator_safe.v
@@ -0,0 +1,234 @@
+(****************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud *)
+(* *)
+(* Copyright Inria. All rights reserved. This file is distributed under *)
+(* the terms of the GNU Lesser General Public License as published by the *)
+(* Free Software Foundation, either version 3 of the License, or (at your *)
+(* option) any later version, as described in the file LICENSE. *)
+(* *)
+(****************************************************************************)
+
+From Coq Require Import List Syntax Derive.
+From Coq.ssr Require Import ssreflect.
+Require Automaton.
+Require Import Alphabet Validator_classes.
+
+Module Make(Import A:Automaton.T).
+
+(** The singleton predicate for states **)
+Definition singleton_state_pred (state:state) :=
+ (fun state' => match compare state state' with Eq => true |_ => false end).
+
+(** [past_state_of_non_init_state], extended for all states. **)
+Definition past_state_of_state (state:state) :=
+ match state with
+ | Init _ => []
+ | Ninit nis => past_state_of_non_init_state nis
+ end.
+
+(** Concatenations of last and past **)
+Definition head_symbs_of_state (state:state) :=
+ match state with
+ | Init _ => []
+ | Ninit s =>
+ last_symb_of_non_init_state s::past_symb_of_non_init_state s
+ end.
+Definition head_states_of_state (state:state) :=
+ singleton_state_pred state::past_state_of_state state.
+
+(** * Validation for correctness **)
+
+(** Prefix predicate between two lists of symbols. **)
+Inductive prefix: list symbol -> list symbol -> Prop :=
+| prefix_nil: forall l, prefix [] l
+| prefix_cons: forall l1 l2 x, prefix l1 l2 -> prefix (x::l1) (x::l2).
+
+(** [prefix] is transitive **)
+Lemma prefix_trans:
+ forall (l1 l2 l3:list symbol), prefix l1 l2 -> prefix l2 l3 -> prefix l1 l3.
+Proof.
+ intros l1 l2 l3 H1 H2. revert l3 H2.
+ induction H1; [now constructor|]. inversion 1. subst. constructor. eauto.
+Qed.
+
+Fixpoint is_prefix (l1 l2:list symbol) :=
+ match l1, l2 with
+ | [], _ => true
+ | t1::q1, t2::q2 => (compare_eqb t1 t2 && is_prefix q1 q2)%bool
+ | _::_, [] => false
+ end.
+
+Instance prefix_is_validator l1 l2 : IsValidator (prefix l1 l2) (is_prefix l1 l2).
+Proof.
+ revert l2. induction l1 as [|x1 l1 IH]=>l2 Hpref.
+ - constructor.
+ - destruct l2 as [|x2 l2]=>//.
+ move: Hpref=> /andb_prop [/compare_eqb_iff -> /IH ?]. by constructor.
+Qed.
+
+(** If we shift, then the known top symbols of the destination state is
+ a prefix of the known top symbols of the source state, with the new
+ symbol added. **)
+Definition shift_head_symbs :=
+ forall s,
+ match action_table s with
+ | Lookahead_act awp => forall t,
+ match awp t with
+ | Shift_act s2 _ =>
+ prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
+ | _ => True
+ end
+ | _ => True
+ end.
+
+(** When a goto happens, then the known top symbols of the destination state
+ is a prefix of the known top symbols of the source state, with the new
+ symbol added. **)
+Definition goto_head_symbs :=
+ forall s nt,
+ match goto_table s nt with
+ | Some (exist _ s2 _) =>
+ prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
+ | None => True
+ end.
+
+(** We have to say the same kind of checks for the assumptions about the
+ states stack. However, theses assumptions are predicates. So we define
+ a notion of "prefix" over predicates lists, that means, basically, that
+ an assumption entails another **)
+Inductive prefix_pred: list (state->bool) -> list (state->bool) -> Prop :=
+ | prefix_pred_nil: forall l, prefix_pred [] l
+ | prefix_pred_cons: forall l1 l2 f1 f2,
+ (forall x, implb (f2 x) (f1 x) = true) ->
+ prefix_pred l1 l2 -> prefix_pred (f1::l1) (f2::l2).
+
+(** [prefix_pred] is transitive **)
+Lemma prefix_pred_trans:
+ forall (l1 l2 l3:list (state->bool)),
+ prefix_pred l1 l2 -> prefix_pred l2 l3 -> prefix_pred l1 l3.
+Proof.
+ intros l1 l2 l3 H1 H2. revert l3 H2.
+ induction H1 as [|l1 l2 f1 f2 Hf2f1]; [now constructor|].
+ intros l3. inversion 1 as [|??? f3 Hf3f2]. subst. constructor; [|now eauto].
+ intros x. specialize (Hf3f2 x). specialize (Hf2f1 x).
+ repeat destruct (_ x); auto.
+Qed.
+
+Fixpoint is_prefix_pred (l1 l2:list (state->bool)) :=
+ match l1, l2 with
+ | [], _ => true
+ | f1::q1, f2::q2 =>
+ (forallb (fun x => implb (f2 x) (f1 x)) all_list
+ && is_prefix_pred q1 q2)%bool
+ | _::_, [] => false
+ end.
+
+Instance prefix_pred_is_validator l1 l2 :
+ IsValidator (prefix_pred l1 l2) (is_prefix_pred l1 l2).
+Proof.
+ revert l2. induction l1 as [|x1 l1 IH]=>l2 Hpref.
+ - constructor.
+ - destruct l2 as [|x2 l2]=>//.
+ move: Hpref=> /andb_prop [/forallb_forall ? /IH ?].
+ constructor; auto using all_list_forall.
+Qed.
+
+(** The assumptions about state stack is conserved when we shift **)
+Definition shift_past_state :=
+ forall s,
+ match action_table s with
+ | Lookahead_act awp => forall t,
+ match awp t with
+ | Shift_act s2 _ =>
+ prefix_pred (past_state_of_non_init_state s2)
+ (head_states_of_state s)
+ | _ => True
+ end
+ | _ => True
+ end.
+
+(** The assumptions about state stack is conserved when we do a goto **)
+Definition goto_past_state :=
+ forall s nt,
+ match goto_table s nt with
+ | Some (exist _ s2 _) =>
+ prefix_pred (past_state_of_non_init_state s2)
+ (head_states_of_state s)
+ | None => True
+ end.
+
+(** What states are possible after having popped these symbols from the
+ stack, given the annotation of the current state ? **)
+Inductive state_valid_after_pop (s:state):
+ list symbol -> list (state -> bool) -> Prop :=
+ | state_valid_after_pop_nil1:
+ forall p pl, p s = true -> state_valid_after_pop s [] (p::pl)
+ | state_valid_after_pop_nil2:
+ forall sl, state_valid_after_pop s sl []
+ | state_valid_after_pop_cons:
+ forall st sq p pl, state_valid_after_pop s sq pl ->
+ state_valid_after_pop s (st::sq) (p::pl).
+
+Fixpoint is_state_valid_after_pop (state:state) (to_pop:list symbol) annot :=
+ match annot, to_pop with
+ | [], _ => true
+ | p::_, [] => p state
+ | p::pl, s::sl => is_state_valid_after_pop state sl pl
+ end.
+
+Instance impl_is_state_valid_after_pop_is_validator state sl pl P b :
+ IsValidator P b ->
+ IsValidator (state_valid_after_pop state sl pl -> P)
+ (if is_state_valid_after_pop state sl pl then b else true).
+Proof.
+ destruct (is_state_valid_after_pop _ sl pl) eqn:EQ.
+ - intros ???. by eapply is_validator.
+ - intros _ _ Hsvap. exfalso. induction Hsvap=>//; [simpl in EQ; congruence|].
+ by destruct sl.
+Qed.
+
+(** A state is valid for reducing a production when :
+ - The assumptions on the state are such that we will find the right hand
+ side of the production on the stack.
+ - We will be able to do a goto after having popped the right hand side.
+**)
+Definition valid_for_reduce (state:state) prod :=
+ prefix (prod_rhs_rev prod) (head_symbs_of_state state) /\
+ forall state_new,
+ state_valid_after_pop state_new
+ (prod_rhs_rev prod) (head_states_of_state state) ->
+ match goto_table state_new (prod_lhs prod) with
+ | None =>
+ match state_new with
+ | Init i => prod_lhs prod = start_nt i
+ | Ninit _ => False
+ end
+ | _ => True
+ end.
+
+(** All the states that does a reduce are valid for reduction **)
+Definition reduce_ok :=
+ forall s,
+ match action_table s with
+ | Lookahead_act awp =>
+ forall t, match awp t with
+ | Reduce_act p => valid_for_reduce s p
+ | _ => True
+ end
+ | Default_reduce_act p => valid_for_reduce s p
+ end.
+
+(** The automaton is safe **)
+Definition safe :=
+ shift_head_symbs /\ goto_head_symbs /\ shift_past_state /\
+ goto_past_state /\ reduce_ok.
+
+Derive is_safe
+SuchThat (IsValidator safe (is_safe ()))
+As safe_is_validator.
+Proof. subst is_safe. instantiate (1:=fun _ => _). apply _. Qed.
+
+End Make.
diff --git a/VERSION b/VERSION
index d4563a62..b60e8d9b 100644
--- a/VERSION
+++ b/VERSION
@@ -1,3 +1,3 @@
-version=3.5
+version=3.7
buildnr=
tag=
diff --git a/aarch64/Archi.v b/aarch64/Archi.v
new file mode 100644
index 00000000..aef4ab77
--- /dev/null
+++ b/aarch64/Archi.v
@@ -0,0 +1,88 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Architecture-dependent parameters for AArch64 *)
+
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
+
+Definition ptr64 := true.
+
+Definition big_endian := false.
+
+Definition align_int64 := 8%Z.
+Definition align_float64 := 8%Z.
+
+Definition splitlong := false.
+
+Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
+Proof.
+ unfold splitlong, ptr64; congruence.
+Qed.
+
+Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (false, iter_nat 22 _ xO xH).
+
+(** Choose the first signaling NaN, if any;
+ otherwise choose the first NaN;
+ otherwise use default. *)
+
+Definition choose_nan (is_signaling: positive -> bool)
+ (default: bool * positive)
+ (l0: list (bool * positive)) : bool * positive :=
+ let fix choose_snan (l1: list (bool * positive)) :=
+ match l1 with
+ | nil =>
+ match l0 with nil => default | n :: _ => n end
+ | ((s, p) as n) :: l1 =>
+ if is_signaling p then n else choose_snan l1
+ end
+ in choose_snan l0.
+
+Lemma choose_nan_idem: forall is_signaling default n,
+ choose_nan is_signaling default (n :: n :: nil) =
+ choose_nan is_signaling default (n :: nil).
+Proof.
+ intros. destruct n as [s p]; unfold choose_nan; simpl.
+ destruct (is_signaling p); auto.
+Qed.
+
+Definition choose_nan_64 :=
+ choose_nan (fun p => negb (Pos.testbit p 51)) default_nan_64.
+
+Definition choose_nan_32 :=
+ choose_nan (fun p => negb (Pos.testbit p 22)) default_nan_32.
+
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. intros; apply choose_nan_idem. Qed.
+
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. intros; apply choose_nan_idem. Qed.
+
+Definition fma_order {A: Type} (x y z: A) := (z, x, y).
+
+Definition fma_invalid_mul_is_nan := true.
+
+Definition float_of_single_preserves_sNaN := false.
+
+Global Opaque ptr64 big_endian splitlong
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
+ float_of_single_preserves_sNaN.
+
+(** Whether to generate position-independent code or not *)
+
+Parameter pic_code: unit -> bool.
diff --git a/aarch64/Asm.v b/aarch64/Asm.v
new file mode 100644
index 00000000..47cd3051
--- /dev/null
+++ b/aarch64/Asm.v
@@ -0,0 +1,1312 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Abstract syntax and semantics for AArch64 assembly language *)
+
+Require Import Coqlib Zbits Maps.
+Require Import AST Integers Floats.
+Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Locations Conventions.
+Require Stacklayout.
+
+(** * Abstract syntax *)
+
+(** Integer registers, floating-point registers. *)
+
+(** In assembly files, [Xn] denotes the full 64-bit register
+ and [Wn] the low 32 bits of [Xn]. *)
+
+Inductive ireg: Type :=
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7
+ | X8 | X9 | X10 | X11 | X12 | X13 | X14 | X15
+ | X16 | X17 | X18 | X19 | X20 | X21 | X22 | X23
+ | X24 | X25 | X26 | X27 | X28 | X29 | X30.
+
+Inductive ireg0: Type :=
+ | RR0 (r: ireg) | XZR.
+
+Inductive iregsp: Type :=
+ | RR1 (r: ireg) | XSP.
+
+Coercion RR0: ireg >-> ireg0.
+Coercion RR1: ireg >-> iregsp.
+
+Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+(** In assembly files, [Dn] denotes the low 64-bit of a vector register,
+ and [Sn] the low 32 bits. *)
+
+Inductive freg: Type :=
+ | D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7
+ | D8 | D9 | D10 | D11 | D12 | D13 | D14 | D15
+ | D16 | D17 | D18 | D19 | D20 | D21 | D22 | D23
+ | D24 | D25 | D26 | D27 | D28 | D29 | D30 | D31.
+
+Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+(** Bits in the condition register. *)
+
+Inductive crbit: Type :=
+ | CN: crbit (**r negative *)
+ | CZ: crbit (**r zero *)
+ | CC: crbit (**r carry *)
+ | CV: crbit. (**r overflow *)
+
+Lemma crbit_eq: forall (x y: crbit), {x=y} + {x<>y}.
+Proof. decide equality. Defined.
+
+(** We model the following registers of the ARM architecture. *)
+
+Inductive preg: Type :=
+ | IR: ireg -> preg (**r 64- or 32-bit integer registers *)
+ | FR: freg -> preg (**r double- or single-precision float registers *)
+ | CR: crbit -> preg (**r bits in the condition register *)
+ | SP: preg (**r register X31 used as stack pointer *)
+ | PC: preg. (**r program counter *)
+
+Coercion IR: ireg >-> preg.
+Coercion FR: freg >-> preg.
+Coercion CR: crbit >-> preg.
+
+Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}.
+Proof. decide equality. apply ireg_eq. apply freg_eq. apply crbit_eq. Defined.
+
+Module PregEq.
+ Definition t := preg.
+ Definition eq := preg_eq.
+End PregEq.
+
+Module Pregmap := EMap(PregEq).
+
+Definition preg_of_iregsp (r: iregsp) : preg :=
+ match r with RR1 r => IR r | XSP => SP end.
+
+Coercion preg_of_iregsp: iregsp >-> preg.
+
+(** Conventional name for return address ([RA]) *)
+
+Notation "'RA'" := X30 (only parsing) : asm.
+
+(** The instruction set. Most instructions correspond exactly to
+ actual AArch64 instructions. See the ARM reference manuals for more
+ details. Some instructions, described below, are
+ pseudo-instructions: they expand to canned instruction sequences
+ during the printing of the assembly code. *)
+
+Definition label := positive.
+
+Inductive isize: Type :=
+ | W (**r 32-bit integer operation *)
+ | X. (**r 64-bit integer operation *)
+
+Inductive fsize: Type :=
+ | S (**r 32-bit, single-precision FP operation *)
+ | D. (**r 64-bit, double-precision FP operation *)
+
+Inductive testcond : Type :=
+ | TCeq: testcond (**r equal *)
+ | TCne: testcond (**r not equal *)
+ | TChs: testcond (**r unsigned higher or same *)
+ | TClo: testcond (**r unsigned lower *)
+ | TCmi: testcond (**r negative *)
+ | TCpl: testcond (**r positive *)
+ | TChi: testcond (**r unsigned higher *)
+ | TCls: testcond (**r unsigned lower or same *)
+ | TCge: testcond (**r signed greater or equal *)
+ | TClt: testcond (**r signed less than *)
+ | TCgt: testcond (**r signed greater *)
+ | TCle: testcond. (**r signed less than or equal *)
+
+Inductive addressing: Type :=
+ | ADimm (base: iregsp) (n: int64) (**r base plus immediate offset *)
+ | ADreg (base: iregsp) (r: ireg) (**r base plus reg *)
+ | ADlsl (base: iregsp) (r: ireg) (n: int) (**r base plus reg LSL n *)
+ | ADsxt (base: iregsp) (r: ireg) (n: int) (**r base plus SIGN-EXT(reg) LSL n *)
+ | ADuxt (base: iregsp) (r: ireg) (n: int) (**r base plus ZERO-EXT(reg) LSL n *)
+ | ADadr (base: iregsp) (id: ident) (ofs: ptrofs) (**r base plus low address of [id + ofs] *)
+ | ADpostincr (base: iregsp) (n: int64). (**r base plus offset; base is updated after *)
+
+Inductive shift_op: Type :=
+ | SOnone
+ | SOlsl (n: int)
+ | SOlsr (n: int)
+ | SOasr (n: int)
+ | SOror (n: int).
+
+Inductive extend_op: Type :=
+ | EOsxtb (n: int)
+ | EOsxth (n: int)
+ | EOsxtw (n: int)
+ | EOuxtb (n: int)
+ | EOuxth (n: int)
+ | EOuxtw (n: int)
+ | EOuxtx (n: int).
+
+Inductive instruction: Type :=
+ (** Branches *)
+ | Pb (lbl: label) (**r branch *)
+ | Pbc (c: testcond) (lbl: label) (**r conditional branch *)
+ | Pbl (id: ident) (sg: signature) (**r jump to function and link *)
+ | Pbs (id: ident) (sg: signature) (**r jump to function *)
+ | Pblr (r: ireg) (sg: signature) (**r indirect jump and link *)
+ | Pbr (r: ireg) (sg: signature) (**r indirect jump *)
+ | Pret (r: ireg) (**r return *)
+ | Pcbnz (sz: isize) (r: ireg) (lbl: label) (**r branch if not zero *)
+ | Pcbz (sz: isize) (r: ireg) (lbl: label) (**r branch if zero *)
+ | Ptbnz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is not zero *)
+ | Ptbz (sz: isize) (r: ireg) (n: int) (lbl: label) (**r branch if bit n is zero *)
+ (** Memory loads and stores *)
+ | Pldrw (rd: ireg) (a: addressing) (**r load int32 *)
+ | Pldrw_a (rd: ireg) (a: addressing) (**r load int32 as any32 *)
+ | Pldrx (rd: ireg) (a: addressing) (**r load int64 *)
+ | Pldrx_a (rd: ireg) (a: addressing) (**r load int64 as any64 *)
+ | Pldrb (sz: isize) (rd: ireg) (a: addressing) (**r load int8, zero-extend *)
+ | Pldrsb (sz: isize) (rd: ireg) (a: addressing) (**r load int8, sign-extend *)
+ | Pldrh (sz: isize) (rd: ireg) (a: addressing) (**r load int16, zero-extend *)
+ | Pldrsh (sz: isize) (rd: ireg) (a: addressing) (**r load int16, sign-extend *)
+ | Pldrzw (rd: ireg) (a: addressing) (**r load int32, zero-extend to int64 *)
+ | Pldrsw (rd: ireg) (a: addressing) (**r load int32, sign-extend to int64 *)
+ | Pldp (rd1 rd2: ireg) (a: addressing) (**r load two int64 *)
+ | Pstrw (rs: ireg) (a: addressing) (**r store int32 *)
+ | Pstrw_a (rs: ireg) (a: addressing) (**r store int32 as any32 *)
+ | Pstrx (rs: ireg) (a: addressing) (**r store int64 *)
+ | Pstrx_a (rs: ireg) (a: addressing) (**r store int64 as any64 *)
+ | Pstrb (rs: ireg) (a: addressing) (**r store int8 *)
+ | Pstrh (rs: ireg) (a: addressing) (**r store int16 *)
+ | Pstp (rs1 rs2: ireg) (a: addressing) (**r store two int64 *)
+ (** Integer arithmetic, immediate *)
+ | Paddimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r addition *)
+ | Psubimm (sz: isize) (rd: iregsp) (r1: iregsp) (n: Z) (**r subtraction *)
+ | Pcmpimm (sz: isize) (r1: ireg) (n: Z) (**r compare *)
+ | Pcmnimm (sz: isize) (r1: ireg) (n: Z) (**r compare negative *)
+ (** Move integer register *)
+ | Pmov (rd: iregsp) (r1: iregsp)
+ (** Logical, immediate *)
+ | Pandimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r and *)
+ | Peorimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r xor *)
+ | Porrimm (sz: isize) (rd: ireg) (r1: ireg0) (n: Z) (**r or *)
+ | Ptstimm (sz: isize) (r1: ireg) (n: Z) (**r and, then set flags *)
+ (** Move wide immediate *)
+ | Pmovz (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r move [n << pos] to [rd] *)
+ | Pmovn (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r move [NOT(n << pos)] to [rd] *)
+ | Pmovk (sz: isize) (rd: ireg) (n: Z) (pos: Z) (**r insert 16 bits of [n] at [pos] in rd *)
+ (** PC-relative addressing *)
+ | Padrp (rd: ireg) (id: ident) (ofs: ptrofs) (**r set [rd] to high address of [id + ofs] *)
+ | Paddadr (rd: ireg) (r1: ireg) (id: ident) (ofs: ptrofs) (**r add the low address of [id + ofs] *)
+ (** Bit-field operations *)
+ | Psbfiz (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r sign extend and shift left *)
+ | Psbfx (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r shift right and sign extend *)
+ | Pubfiz (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r zero extend and shift left *)
+ | Pubfx (sz: isize) (rd: ireg) (r1: ireg) (r: int) (s: Z) (**r shift right and zero extend *)
+ (** Integer arithmetic, shifted register *)
+ | Padd (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r addition *)
+ | Psub (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r subtraction *)
+ | Pcmp (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r compare *)
+ | Pcmn (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r compare negative *)
+ (** Integer arithmetic, extending register *)
+ | Paddext (rd: iregsp) (r1: iregsp) (r2: ireg) (x: extend_op) (**r int64-int32 add *)
+ | Psubext (rd: iregsp) (r1: iregsp) (r2: ireg) (x: extend_op) (**r int64-int32 sub *)
+ | Pcmpext (r1: ireg) (r2: ireg) (x: extend_op) (**r int64-int32 cmp *)
+ | Pcmnext (r1: ireg) (r2: ireg) (x: extend_op) (**r int64-int32 cmn *)
+ (** Logical, shifted register *)
+ | Pand (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and *)
+ | Pbic (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and-not *)
+ | Peon (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r xor-not *)
+ | Peor (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r xor *)
+ | Porr (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r or *)
+ | Porn (sz: isize) (rd: ireg) (r1: ireg0) (r2: ireg) (s: shift_op) (**r or-not *)
+ | Ptst (sz: isize) (r1: ireg0) (r2: ireg) (s: shift_op) (**r and, then set flags *)
+ (** Variable shifts *)
+ | Pasrv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r arithmetic right shift *)
+ | Plslv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r left shift *)
+ | Plsrv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r logical right shift *)
+ | Prorv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r rotate right *)
+ (** Bit operations *)
+ | Pcls (sz: isize) (rd r1: ireg) (**r count leading sign bits *)
+ | Pclz (sz: isize) (rd r1: ireg) (**r count leading zero bits *)
+ | Prev (sz: isize) (rd r1: ireg) (**r reverse bytes *)
+ | Prev16 (sz: isize) (rd r1: ireg) (**r reverse bytes in each 16-bit word *)
+ (** Conditional data processing *)
+ | Pcsel (rd: ireg) (r1 r2: ireg) (c: testcond) (**r int conditional move *)
+ | Pcset (rd: ireg) (c: testcond) (**r set to 1/0 if cond is true/false *)
+(*
+ | Pcsetm (rd: ireg) (c: testcond) (**r set to -1/0 if cond is true/false *)
+*)
+ (** Integer multiply/divide *)
+ | Pmadd (sz: isize) (rd: ireg) (r1 r2: ireg) (r3: ireg0) (**r multiply-add *)
+ | Pmsub (sz: isize) (rd: ireg) (r1 r2: ireg) (r3: ireg0) (**r multiply-sub *)
+ | Psmulh (rd: ireg) (r1 r2: ireg) (**r signed multiply high *)
+ | Pumulh (rd: ireg) (r1 r2: ireg) (**r unsigned multiply high *)
+ | Psdiv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r signed division *)
+ | Pudiv (sz: isize) (rd: ireg) (r1 r2: ireg) (**r unsigned division *)
+ (** Floating-point loads and stores *)
+ | Pldrs (rd: freg) (a: addressing) (**r load float32 (single precision) *)
+ | Pldrd (rd: freg) (a: addressing) (**r load float64 (double precision) *)
+ | Pldrd_a (rd: freg) (a: addressing) (**r load float64 as any64 *)
+ | Pstrs (rs: freg) (a: addressing) (**r store float32 *)
+ | Pstrd (rs: freg) (a: addressing) (**r store float64 *)
+ | Pstrd_a (rs: freg) (a: addressing) (**r store float64 as any64 *)
+ (** Floating-point move *)
+ | Pfmov (rd r1: freg)
+ | Pfmovimms (rd: freg) (f: float32) (**r load float32 constant *)
+ | Pfmovimmd (rd: freg) (f: float) (**r load float64 constant *)
+ | Pfmovi (fsz: fsize) (rd: freg) (r1: ireg0) (**r copy int reg to FP reg *)
+ (** Floating-point conversions *)
+ | Pfcvtds (rd r1: freg) (**r convert float32 to float64 *)
+ | Pfcvtsd (rd r1: freg) (**r convert float64 to float32 *)
+ | Pfcvtzs (isz: isize) (fsz: fsize) (rd: ireg) (r1: freg) (**r convert float to signed int *)
+ | Pfcvtzu (isz: isize) (fsz: fsize) (rd: ireg) (r1: freg) (**r convert float to unsigned int *)
+ | Pscvtf (fsz: fsize) (isz: isize) (rd: freg) (r1: ireg) (**r convert signed int to float *)
+ | Pucvtf (fsz: fsize) (isz: isize) (rd: freg) (r1: ireg) (**r convert unsigned int to float *)
+ (** Floating-point arithmetic *)
+ | Pfabs (sz: fsize) (rd r1: freg) (**r absolute value *)
+ | Pfneg (sz: fsize) (rd r1: freg) (**r negation *)
+ | Pfsqrt (sz: fsize) (rd r1: freg) (**r square root *)
+ | Pfadd (sz: fsize) (rd r1 r2: freg) (**r addition *)
+ | Pfdiv (sz: fsize) (rd r1 r2: freg) (**r division *)
+ | Pfmul (sz: fsize) (rd r1 r2: freg) (**r multiplication *)
+ | Pfnmul (sz: fsize) (rd r1 r2: freg) (**r multiply-negate *)
+ | Pfsub (sz: fsize) (rd r1 r2: freg) (**r subtraction *)
+ | Pfmadd (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = r3 + r1 * r2] *)
+ | Pfmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = r3 - r1 * r2] *)
+ | Pfnmadd (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 - r1 * r2] *)
+ | Pfnmsub (sz: fsize) (rd r1 r2 r3: freg) (**r [rd = - r3 + r1 * r2] *)
+ (** Floating-point comparison *)
+ | Pfcmp (sz: fsize) (r1 r2: freg) (**r compare [r1] and [r2] *)
+ | Pfcmp0 (sz: fsize) (r1: freg) (**r compare [r1] and [+0.0] *)
+ (** Floating-point conditional select *)
+ | Pfsel (rd r1 r2: freg) (cond: testcond)
+ (** Pseudo-instructions *)
+ | Pallocframe (sz: Z) (linkofs: ptrofs) (**r allocate new stack frame *)
+ | Pfreeframe (sz: Z) (linkofs: ptrofs) (**r deallocate stack frame and restore previous frame *)
+ | Plabel (lbl: label) (**r define a code label *)
+ | Ploadsymbol (rd: ireg) (id: ident) (**r load the address of [id] *)
+ | Pcvtsw2x (rd: ireg) (r1: ireg) (**r sign-extend 32-bit int to 64-bit *)
+ | Pcvtuw2x (rd: ireg) (r1: ireg) (**r zero-extend 32-bit int to 64-bit *)
+ | Pcvtx2w (rd: ireg) (**r retype a 64-bit int as a 32-bit int *)
+ | Pbtbl (r1: ireg) (tbl: list label) (**r N-way branch through a jump table *)
+ | Pbuiltin (ef: external_function)
+ (args: list (builtin_arg preg)) (res: builtin_res preg) (**r built-in function (pseudo) *)
+ | Pnop (**r no operation *)
+ | Pcfi_adjust (ofs: int) (**r .cfi_adjust debug directive *)
+ | Pcfi_rel_offset (ofs: int) (**r .cfi_rel_offset debug directive *)
+.
+
+Definition code := list instruction.
+Record function : Type := mkfunction { fn_sig: signature; fn_code: code }.
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef unit.
+
+(** * Operational semantics *)
+
+(** The semantics operates over a single mapping from registers
+ (type [preg]) to values. We maintain (but do not enforce)
+ the convention that integer registers are mapped to values of
+ type [Tint], float registers to values of type [Tfloat],
+ and condition bits to either [Vzero] or [Vone]. *)
+
+Definition regset := Pregmap.t val.
+Definition genv := Genv.t fundef unit.
+
+(** The value of an [ireg0] is either the value of the integer register,
+ or 0. *)
+
+Definition ir0w (rs: regset) (r: ireg0) : val :=
+ match r with RR0 r => rs (IR r) | XZR => Vint Int.zero end.
+Definition ir0x (rs: regset) (r: ireg0) : val :=
+ match r with RR0 r => rs (IR r) | XZR => Vlong Int64.zero end.
+
+(** Concise notations for accessing and updating the values of registers. *)
+
+Notation "a # b" := (a b) (at level 1, only parsing) : asm.
+Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level) : asm.
+Notation "a ## b" := (ir0w a b) (at level 1, only parsing) : asm.
+Notation "a ### b" := (ir0x a b) (at level 1, only parsing) : asm.
+
+Open Scope asm.
+
+(** Undefining some registers *)
+
+Fixpoint undef_regs (l: list preg) (rs: regset) : regset :=
+ match l with
+ | nil => rs
+ | r :: l' => undef_regs l' (rs#r <- Vundef)
+ end.
+
+(** Undefining the condition codes *)
+
+Definition undef_flags (rs: regset) : regset :=
+ fun r => match r with CR _ => Vundef | _ => rs r end.
+
+(** Assigning a register pair *)
+
+Definition set_pair (p: rpair preg) (v: val) (rs: regset) : regset :=
+ match p with
+ | One r => rs#r <- v
+ | Twolong rhi rlo => rs#rhi <- (Val.hiword v) #rlo <- (Val.loword v)
+ end.
+
+(** Assigning the result of a builtin *)
+
+Fixpoint set_res (res: builtin_res preg) (v: val) (rs: regset) : regset :=
+ match res with
+ | BR r => rs#r <- v
+ | BR_none => rs
+ | BR_splitlong hi lo => set_res lo (Val.loword v) (set_res hi (Val.hiword v) rs)
+ end.
+
+(** The two functions below axiomatize how the linker processes
+ symbolic references [symbol + offset]. It computes the
+ difference between the address and the PC, and splits it into:
+ - 12 low bits usable as an offset in an addressing mode;
+ - 21 high bits usable as argument to the ADRP instruction.
+
+ In CompCert's model, we cannot really describe PC-relative addressing,
+ but we can claim that the address of [symbol + offset] decomposes
+ as the sum of
+ - a low part, usable as an offset in an addressing mode;
+ - a high part, usable as argument to the ADRP instruction. *)
+
+Parameter symbol_low: genv -> ident -> ptrofs -> val.
+Parameter symbol_high: genv -> ident -> ptrofs -> val.
+
+Axiom symbol_high_low:
+ forall (ge: genv) (id: ident) (ofs: ptrofs),
+ Val.addl (symbol_high ge id ofs) (symbol_low ge id ofs) = Genv.symbol_address ge id ofs.
+
+Section RELSEM.
+
+Variable ge: genv.
+
+(** Looking up instructions in a code sequence by position. *)
+
+Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction :=
+ match c with
+ | nil => None
+ | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il
+ end.
+
+(** Position corresponding to a label *)
+
+Definition is_label (lbl: label) (instr: instruction) : bool :=
+ match instr with
+ | Plabel lbl' => if peq lbl lbl' then true else false
+ | _ => false
+ end.
+
+Lemma is_label_correct:
+ forall lbl instr,
+ if is_label lbl instr then instr = Plabel lbl else instr <> Plabel lbl.
+Proof.
+ intros. destruct instr; simpl; try discriminate. destruct (peq lbl lbl0); congruence.
+Qed.
+
+Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z :=
+ match c with
+ | nil => None
+ | instr :: c' =>
+ if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c'
+ end.
+
+(** The semantics is purely small-step and defined as a function
+ from the current state (a register set + a memory state)
+ to either [Next rs' m'] where [rs'] and [m'] are the updated register
+ set and memory state after execution of the instruction at [rs#PC],
+ or [Stuck] if the processor is stuck. *)
+
+Inductive outcome: Type :=
+ | Next: regset -> mem -> outcome
+ | Stuck: outcome.
+
+(** Manipulations over the [PC] register: continuing with the next
+ instruction ([nextinstr]) or branching to a label ([goto_label]). *)
+
+Definition nextinstr (rs: regset) :=
+ rs#PC <- (Val.offset_ptr rs#PC Ptrofs.one).
+
+Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) :=
+ match label_pos lbl 0 (fn_code f) with
+ | None => Stuck
+ | Some pos =>
+ match rs#PC with
+ | Vptr b ofs => Next (rs#PC <- (Vptr b (Ptrofs.repr pos))) m
+ | _ => Stuck
+ end
+ end.
+
+(** Testing a condition *)
+
+Definition eval_testcond (c: testcond) (rs: regset) : option bool :=
+ match c with
+ | TCeq => (**r equal *)
+ match rs#CZ with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | TCne => (**r not equal *)
+ match rs#CZ with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | TClo => (**r unsigned less than *)
+ match rs#CC with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | TCls => (**r unsigned less or equal *)
+ match rs#CC, rs#CZ with
+ | Vint c, Vint z => Some (Int.eq c Int.zero || Int.eq z Int.one)
+ | _, _ => None
+ end
+ | TChs => (**r unsigned greater or equal *)
+ match rs#CC with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ | TChi => (**r unsigned greater *)
+ match rs#CC, rs#CZ with
+ | Vint c, Vint z => Some (Int.eq c Int.one && Int.eq z Int.zero)
+ | _, _ => None
+ end
+ | TClt => (**r signed less than *)
+ match rs#CV, rs#CN with
+ | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.one)
+ | _, _ => None
+ end
+ | TCle => (**r signed less or equal *)
+ match rs#CV, rs#CN, rs#CZ with
+ | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.one || Int.eq z Int.one)
+ | _, _, _ => None
+ end
+ | TCge => (**r signed greater or equal *)
+ match rs#CV, rs#CN with
+ | Vint o, Vint s => Some (Int.eq (Int.xor o s) Int.zero)
+ | _, _ => None
+ end
+ | TCgt => (**r signed greater *)
+ match rs#CV, rs#CN, rs#CZ with
+ | Vint o, Vint s, Vint z => Some (Int.eq (Int.xor o s) Int.zero && Int.eq z Int.zero)
+ | _, _, _ => None
+ end
+ | TCpl => (**r positive *)
+ match rs#CN with
+ | Vint n => Some (Int.eq n Int.zero)
+ | _ => None
+ end
+ | TCmi => (**r negative *)
+ match rs#CN with
+ | Vint n => Some (Int.eq n Int.one)
+ | _ => None
+ end
+ end.
+
+(** Integer "is zero?" test *)
+
+Definition eval_testzero (sz: isize) (v: val) (m: mem): option bool :=
+ match sz with
+ | W => Val.cmpu_bool (Mem.valid_pointer m) Ceq v (Vint Int.zero)
+ | X => Val.cmplu_bool (Mem.valid_pointer m) Ceq v (Vlong Int64.zero)
+ end.
+
+(** Integer "bit is set?" test *)
+
+Definition eval_testbit (sz: isize) (v: val) (n: int): option bool :=
+ match sz with
+ | W => Val.cmp_bool Cne (Val.and v (Vint (Int.shl Int.one n))) (Vint Int.zero)
+ | X => Val.cmpl_bool Cne (Val.andl v (Vlong (Int64.shl' Int64.one n))) (Vlong Int64.zero)
+ end.
+
+(** Evaluating an addressing mode *)
+
+Definition eval_addressing (a: addressing) (rs: regset): val :=
+ match a with
+ | ADimm base n => Val.addl rs#base (Vlong n)
+ | ADreg base r => Val.addl rs#base rs#r
+ | ADlsl base r n => Val.addl rs#base (Val.shll rs#r (Vint n))
+ | ADsxt base r n => Val.addl rs#base (Val.shll (Val.longofint rs#r) (Vint n))
+ | ADuxt base r n => Val.addl rs#base (Val.shll (Val.longofintu rs#r) (Vint n))
+ | ADadr base id ofs => Val.addl rs#base (symbol_low ge id ofs)
+ | ADpostincr base n => Vundef (* not modeled yet *)
+ end.
+
+(** Auxiliaries for memory accesses *)
+
+Definition exec_load (chunk: memory_chunk) (transf: val -> val)
+ (a: addressing) (r: preg) (rs: regset) (m: mem) :=
+ match Mem.loadv chunk m (eval_addressing a rs) with
+ | None => Stuck
+ | Some v => Next (nextinstr (rs#r <- (transf v))) m
+ end.
+
+Definition exec_store (chunk: memory_chunk)
+ (a: addressing) (v: val)
+ (rs: regset) (m: mem) :=
+ match Mem.storev chunk m (eval_addressing a rs) v with
+ | None => Stuck
+ | Some m' => Next (nextinstr rs) m'
+ end.
+
+(** Comparisons *)
+
+Definition compare_int (rs: regset) (v1 v2: val) (m: mem) :=
+ rs#CN <- (Val.negative (Val.sub v1 v2))
+ #CZ <- (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2)
+ #CC <- (Val.cmpu (Mem.valid_pointer m) Cge v1 v2)
+ #CV <- (Val.sub_overflow v1 v2).
+
+Definition compare_long (rs: regset) (v1 v2: val) (m: mem) :=
+ rs#CN <- (Val.negativel (Val.subl v1 v2))
+ #CZ <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2))
+ #CC <- (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2))
+ #CV <- (Val.subl_overflow v1 v2).
+
+(** Semantics of [fcmp] instructions:
+<<
+== N=0 Z=1 C=1 V=0
+< N=1 Z=0 C=0 V=0
+> N=0 Z=0 C=1 V=0
+unord N=0 Z=0 C=1 V=1
+>>
+*)
+
+Definition compare_float (rs: regset) (v1 v2: val) :=
+ match v1, v2 with
+ | Vfloat f1, Vfloat f2 =>
+ rs#CN <- (Val.of_bool (Float.cmp Clt f1 f2))
+ #CZ <- (Val.of_bool (Float.cmp Ceq f1 f2))
+ #CC <- (Val.of_bool (negb (Float.cmp Clt f1 f2)))
+ #CV <- (Val.of_bool (negb (Float.ordered f1 f2)))
+ | _, _ =>
+ rs#CN <- Vundef
+ #CZ <- Vundef
+ #CC <- Vundef
+ #CV <- Vundef
+ end.
+
+Definition compare_single (rs: regset) (v1 v2: val) :=
+ match v1, v2 with
+ | Vsingle f1, Vsingle f2 =>
+ rs#CN <- (Val.of_bool (Float32.cmp Clt f1 f2))
+ #CZ <- (Val.of_bool (Float32.cmp Ceq f1 f2))
+ #CC <- (Val.of_bool (negb (Float32.cmp Clt f1 f2)))
+ #CV <- (Val.of_bool (negb (Float32.ordered f1 f2)))
+ | _, _ =>
+ rs#CN <- Vundef
+ #CZ <- Vundef
+ #CC <- Vundef
+ #CV <- Vundef
+ end.
+
+(** Insertion of bits into an integer *)
+
+Definition insert_in_int (x: val) (y: Z) (pos: Z) (len: Z) : val :=
+ match x with
+ | Vint n => Vint (Int.repr (Zinsert (Int.unsigned n) y pos len))
+ | _ => Vundef
+ end.
+
+Definition insert_in_long (x: val) (y: Z) (pos: Z) (len: Z) : val :=
+ match x with
+ | Vlong n => Vlong (Int64.repr (Zinsert (Int64.unsigned n) y pos len))
+ | _ => Vundef
+ end.
+
+(** Evaluation of shifted operands *)
+
+Definition eval_shift_op_int (v: val) (s: shift_op): val :=
+ match s with
+ | SOnone => v
+ | SOlsl n => Val.shl v (Vint n)
+ | SOlsr n => Val.shru v (Vint n)
+ | SOasr n => Val.shr v (Vint n)
+ | SOror n => Val.ror v (Vint n)
+ end.
+
+Definition eval_shift_op_long (v: val) (s: shift_op): val :=
+ match s with
+ | SOnone => v
+ | SOlsl n => Val.shll v (Vint n)
+ | SOlsr n => Val.shrlu v (Vint n)
+ | SOasr n => Val.shrl v (Vint n)
+ | SOror n => Val.rorl v (Vint n)
+ end.
+
+(** Evaluation of sign- or zero- extended operands *)
+
+Definition eval_extend (v: val) (x: extend_op): val :=
+ match x with
+ | EOsxtb n => Val.shll (Val.longofint (Val.sign_ext 8 v)) (Vint n)
+ | EOsxth n => Val.shll (Val.longofint (Val.sign_ext 16 v)) (Vint n)
+ | EOsxtw n => Val.shll (Val.longofint v) (Vint n)
+ | EOuxtb n => Val.shll (Val.longofintu (Val.zero_ext 8 v)) (Vint n)
+ | EOuxth n => Val.shll (Val.longofintu (Val.zero_ext 16 v)) (Vint n)
+ | EOuxtw n => Val.shll (Val.longofintu v) (Vint n)
+ | EOuxtx n => Val.shll v (Vint n)
+ end.
+
+(** Bit-level conversion from integers to FP numbers *)
+
+Definition float32_of_bits (v: val): val :=
+ match v with
+ | Vint n => Vsingle (Float32.of_bits n)
+ | _ => Vundef
+ end.
+
+Definition float64_of_bits (v: val): val :=
+ match v with
+ | Vlong n => Vfloat (Float.of_bits n)
+ | _ => Vundef
+ end.
+
+(** Execution of a single instruction [i] in initial state
+ [rs] and [m]. Return updated state. For instructions
+ that correspond to actual AArch64 instructions, the cases are
+ straightforward transliterations of the informal descriptions
+ given in the ARMv8 reference manuals. For pseudo-instructions,
+ refer to the informal descriptions given above.
+
+ Note that we set to [Vundef] the registers used as temporaries by
+ the expansions of the pseudo-instructions, so that the code we
+ generate cannot use those registers to hold values that must
+ survive the execution of the pseudo-instruction.
+*)
+
+Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : outcome :=
+ match i with
+ (** Branches *)
+ | Pb lbl =>
+ goto_label f lbl rs m
+ | Pbc cond lbl =>
+ match eval_testcond cond rs with
+ | Some true => goto_label f lbl rs m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Pbl id sg =>
+ Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (Genv.symbol_address ge id Ptrofs.zero)) m
+ | Pbs id sg =>
+ Next (rs#PC <- (Genv.symbol_address ge id Ptrofs.zero)) m
+ | Pblr r sg =>
+ Next (rs#RA <- (Val.offset_ptr rs#PC Ptrofs.one) #PC <- (rs#r)) m
+ | Pbr r sg =>
+ Next (rs#PC <- (rs#r)) m
+ | Pret r =>
+ Next (rs#PC <- (rs#r)) m
+ | Pcbnz sz r lbl =>
+ match eval_testzero sz rs#r m with
+ | Some true => Next (nextinstr rs) m
+ | Some false => goto_label f lbl rs m
+ | None => Stuck
+ end
+ | Pcbz sz r lbl =>
+ match eval_testzero sz rs#r m with
+ | Some true => goto_label f lbl rs m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Ptbnz sz r n lbl =>
+ match eval_testbit sz rs#r n with
+ | Some true => goto_label f lbl rs m
+ | Some false => Next (nextinstr rs) m
+ | None => Stuck
+ end
+ | Ptbz sz r n lbl =>
+ match eval_testbit sz rs#r n with
+ | Some true => Next (nextinstr rs) m
+ | Some false => goto_label f lbl rs m
+ | None => Stuck
+ end
+ (** Memory loads and stores *)
+ | Pldrw rd a =>
+ exec_load Mint32 (fun v => v) a rd rs m
+ | Pldrw_a rd a =>
+ exec_load Many32 (fun v => v) a rd rs m
+ | Pldrx rd a =>
+ exec_load Mint64 (fun v => v) a rd rs m
+ | Pldrx_a rd a =>
+ exec_load Many64 (fun v => v) a rd rs m
+ | Pldrb W rd a =>
+ exec_load Mint8unsigned (fun v => v) a rd rs m
+ | Pldrb X rd a =>
+ exec_load Mint8unsigned Val.longofintu a rd rs m
+ | Pldrsb W rd a =>
+ exec_load Mint8signed (fun v => v) a rd rs m
+ | Pldrsb X rd a =>
+ exec_load Mint8signed Val.longofint a rd rs m
+ | Pldrh W rd a =>
+ exec_load Mint16unsigned (fun v => v) a rd rs m
+ | Pldrh X rd a =>
+ exec_load Mint16unsigned Val.longofintu a rd rs m
+ | Pldrsh W rd a =>
+ exec_load Mint16signed (fun v => v) a rd rs m
+ | Pldrsh X rd a =>
+ exec_load Mint16signed Val.longofint a rd rs m
+ | Pldrzw rd a =>
+ exec_load Mint32 Val.longofintu a rd rs m
+ | Pldrsw rd a =>
+ exec_load Mint32 Val.longofint a rd rs m
+ | Pstrw r a =>
+ exec_store Mint32 a rs#r rs m
+ | Pstrw_a r a =>
+ exec_store Many32 a rs#r rs m
+ | Pstrx r a =>
+ exec_store Mint64 a rs#r rs m
+ | Pstrx_a r a =>
+ exec_store Many64 a rs#r rs m
+ | Pstrb r a =>
+ exec_store Mint8unsigned a rs#r rs m
+ | Pstrh r a =>
+ exec_store Mint16unsigned a rs#r rs m
+ (** Integer arithmetic, immediate *)
+ | Paddimm W rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.add rs#r1 (Vint (Int.repr n))))) m
+ | Paddimm X rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.addl rs#r1 (Vlong (Int64.repr n))))) m
+ | Psubimm W rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.sub rs#r1 (Vint (Int.repr n))))) m
+ | Psubimm X rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.subl rs#r1 (Vlong (Int64.repr n))))) m
+ | Pcmpimm W r1 n =>
+ Next (nextinstr (compare_int rs rs#r1 (Vint (Int.repr n)) m)) m
+ | Pcmpimm X r1 n =>
+ Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.repr n)) m)) m
+ | Pcmnimm W r1 n =>
+ Next (nextinstr (compare_int rs rs#r1 (Vint (Int.neg (Int.repr n))) m)) m
+ | Pcmnimm X r1 n =>
+ Next (nextinstr (compare_long rs rs#r1 (Vlong (Int64.neg (Int64.repr n))) m)) m
+ (** Move integer register *)
+ | Pmov rd r1 =>
+ Next (nextinstr (rs#rd <- (rs#r1))) m
+ (** Logical, immediate *)
+ | Pandimm W rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.and rs##r1 (Vint (Int.repr n))))) m
+ | Pandimm X rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.andl rs###r1 (Vlong (Int64.repr n))))) m
+ | Peorimm W rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.xor rs##r1 (Vint (Int.repr n))))) m
+ | Peorimm X rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (Vlong (Int64.repr n))))) m
+ | Porrimm W rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.or rs##r1 (Vint (Int.repr n))))) m
+ | Porrimm X rd r1 n =>
+ Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Vlong (Int64.repr n))))) m
+ | Ptstimm W r1 n =>
+ Next (nextinstr (compare_int rs (Val.and rs#r1 (Vint (Int.repr n))) (Vint Int.zero) m)) m
+ | Ptstimm X r1 n =>
+ Next (nextinstr (compare_long rs (Val.andl rs#r1 (Vlong (Int64.repr n))) (Vlong Int64.zero) m)) m
+ (** Move wide immediate *)
+ | Pmovz W rd n pos =>
+ Next (nextinstr (rs#rd <- (Vint (Int.repr (Z.shiftl n pos))))) m
+ | Pmovz X rd n pos =>
+ Next (nextinstr (rs#rd <- (Vlong (Int64.repr (Z.shiftl n pos))))) m
+ | Pmovn W rd n pos =>
+ Next (nextinstr (rs#rd <- (Vint (Int.repr (Z.lnot (Z.shiftl n pos)))))) m
+ | Pmovn X rd n pos =>
+ Next (nextinstr (rs#rd <- (Vlong (Int64.repr (Z.lnot (Z.shiftl n pos)))))) m
+ | Pmovk W rd n pos =>
+ Next (nextinstr (rs#rd <- (insert_in_int rs#rd n pos 16))) m
+ | Pmovk X rd n pos =>
+ Next (nextinstr (rs#rd <- (insert_in_long rs#rd n pos 16))) m
+ (** PC-relative addressing *)
+ | Padrp rd id ofs =>
+ Next (nextinstr (rs#rd <- (symbol_high ge id ofs))) m
+ | Paddadr rd r1 id ofs =>
+ Next (nextinstr (rs#rd <- (Val.addl rs#r1 (symbol_low ge id ofs)))) m
+ (** Bit-field operations *)
+ | Psbfiz W rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.shl (Val.sign_ext s rs#r1) (Vint r)))) m
+ | Psbfiz X rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.shll (Val.sign_ext_l s rs#r1) (Vint r)))) m
+ | Psbfx W rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext s (Val.shr rs#r1 (Vint r))))) m
+ | Psbfx X rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.sign_ext_l s (Val.shrl rs#r1 (Vint r))))) m
+ | Pubfiz W rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.shl (Val.zero_ext s rs#r1) (Vint r)))) m
+ | Pubfiz X rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.shll (Val.zero_ext_l s rs#r1) (Vint r)))) m
+ | Pubfx W rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext s (Val.shru rs#r1 (Vint r))))) m
+ | Pubfx X rd r1 r s =>
+ Next (nextinstr (rs#rd <- (Val.zero_ext_l s (Val.shrlu rs#r1 (Vint r))))) m
+ (** Integer arithmetic, shifted register *)
+ | Padd W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.add rs##r1 (eval_shift_op_int rs#r2 s)))) m
+ | Padd X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.addl rs###r1 (eval_shift_op_long rs#r2 s)))) m
+ | Psub W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.sub rs##r1 (eval_shift_op_int rs#r2 s)))) m
+ | Psub X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.subl rs###r1 (eval_shift_op_long rs#r2 s)))) m
+ | Pcmp W r1 r2 s =>
+ Next (nextinstr (compare_int rs rs##r1 (eval_shift_op_int rs#r2 s) m)) m
+ | Pcmp X r1 r2 s =>
+ Next (nextinstr (compare_long rs rs###r1 (eval_shift_op_long rs#r2 s) m)) m
+ | Pcmn W r1 r2 s =>
+ Next (nextinstr (compare_int rs rs##r1 (Val.neg (eval_shift_op_int rs#r2 s)) m)) m
+ | Pcmn X r1 r2 s =>
+ Next (nextinstr (compare_long rs rs###r1 (Val.negl (eval_shift_op_long rs#r2 s)) m)) m
+ (** Integer arithmetic, extending register *)
+ | Paddext rd r1 r2 x =>
+ Next (nextinstr (rs#rd <- (Val.addl rs#r1 (eval_extend rs#r2 x)))) m
+ | Psubext rd r1 r2 x =>
+ Next (nextinstr (rs#rd <- (Val.subl rs#r1 (eval_extend rs#r2 x)))) m
+ | Pcmpext r1 r2 x =>
+ Next (nextinstr (compare_long rs rs#r1 (eval_extend rs#r2 x) m)) m
+ | Pcmnext r1 r2 x =>
+ Next (nextinstr (compare_long rs rs#r1 (Val.negl (eval_extend rs#r2 x)) m)) m
+ (** Logical, shifted register *)
+ | Pand W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.and rs##r1 (eval_shift_op_int rs#r2 s)))) m
+ | Pand X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)))) m
+ | Pbic W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.and rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m
+ | Pbic X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.andl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m
+ | Peon W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.xor rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m
+ | Peon X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m
+ | Peor W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.xor rs##r1 (eval_shift_op_int rs#r2 s)))) m
+ | Peor X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.xorl rs###r1 (eval_shift_op_long rs#r2 s)))) m
+ | Porr W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.or rs##r1 (eval_shift_op_int rs#r2 s)))) m
+ | Porr X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.orl rs###r1 (eval_shift_op_long rs#r2 s)))) m
+ | Porn W rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.or rs##r1 (Val.notint (eval_shift_op_int rs#r2 s))))) m
+ | Porn X rd r1 r2 s =>
+ Next (nextinstr (rs#rd <- (Val.orl rs###r1 (Val.notl (eval_shift_op_long rs#r2 s))))) m
+ | Ptst W r1 r2 s =>
+ Next (nextinstr (compare_int rs (Val.and rs##r1 (eval_shift_op_int rs#r2 s)) (Vint Int.zero) m)) m
+ | Ptst X r1 r2 s =>
+ Next (nextinstr (compare_long rs (Val.andl rs###r1 (eval_shift_op_long rs#r2 s)) (Vlong Int64.zero) m)) m
+ (** Variable shifts *)
+ | Pasrv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2))) m
+ | Pasrv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shrl rs#r1 rs#r2))) m
+ | Plslv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m
+ | Plslv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shll rs#r1 rs#r2))) m
+ | Plsrv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m
+ | Plsrv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.shrlu rs#r1 rs#r2))) m
+ | Prorv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.ror rs#r1 rs#r2))) m
+ | Prorv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.rorl rs#r1 rs#r2))) m
+ (** Conditional data processing *)
+ | Pcsel rd r1 r2 cond =>
+ let v :=
+ match eval_testcond cond rs with
+ | Some true => rs#r1
+ | Some false => rs#r2
+ | None => Vundef
+ end in
+ Next (nextinstr (rs#rd <- v)) m
+ | Pcset rd cond =>
+ let v :=
+ match eval_testcond cond rs with
+ | Some true => Vint Int.one
+ | Some false => Vint Int.zero
+ | None => Vundef
+ end in
+ Next (nextinstr (rs#rd <- v)) m
+ (** Integer multiply/divide *)
+ | Pmadd W rd r1 r2 r3 =>
+ Next (nextinstr (rs#rd <- (Val.add rs##r3 (Val.mul rs#r1 rs#r2)))) m
+ | Pmadd X rd r1 r2 r3 =>
+ Next (nextinstr (rs#rd <- (Val.addl rs###r3 (Val.mull rs#r1 rs#r2)))) m
+ | Pmsub W rd r1 r2 r3 =>
+ Next (nextinstr (rs#rd <- (Val.sub rs##r3 (Val.mul rs#r1 rs#r2)))) m
+ | Pmsub X rd r1 r2 r3 =>
+ Next (nextinstr (rs#rd <- (Val.subl rs###r3 (Val.mull rs#r1 rs#r2)))) m
+ | Psmulh rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.mullhs rs#r1 rs#r2))) m
+ | Pumulh rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.mullhu rs#r1 rs#r2))) m
+ | Psdiv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divs rs#r1 rs#r2)))) m
+ | Psdiv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divls rs#r1 rs#r2)))) m
+ | Pudiv W rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divu rs#r1 rs#r2)))) m
+ | Pudiv X rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.divlu rs#r1 rs#r2)))) m
+ (** Floating-point loads and stores *)
+ | Pldrs rd a =>
+ exec_load Mfloat32 (fun v => v) a rd rs m
+ | Pldrd rd a =>
+ exec_load Mfloat64 (fun v => v) a rd rs m
+ | Pldrd_a rd a =>
+ exec_load Many64 (fun v => v) a rd rs m
+ | Pstrs r a =>
+ exec_store Mfloat32 a rs#r rs m
+ | Pstrd r a =>
+ exec_store Mfloat64 a rs#r rs m
+ | Pstrd_a r a =>
+ exec_store Many64 a rs#r rs m
+ (** Floating-point move *)
+ | Pfmov rd r1 =>
+ Next (nextinstr (rs#rd <- (rs#r1))) m
+ | Pfmovimms rd f =>
+ Next (nextinstr (rs#rd <- (Vsingle f))) m
+ | Pfmovimmd rd f =>
+ Next (nextinstr (rs#rd <- (Vfloat f))) m
+ | Pfmovi S rd r1 =>
+ Next (nextinstr (rs#rd <- (float32_of_bits rs##r1))) m
+ | Pfmovi D rd r1 =>
+ Next (nextinstr (rs#rd <- (float64_of_bits rs###r1))) m
+ (** Floating-point conversions *)
+ | Pfcvtds rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.floatofsingle rs#r1))) m
+ | Pfcvtsd rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m
+ | Pfcvtzs W S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intofsingle rs#r1)))) m
+ | Pfcvtzs W D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intoffloat rs#r1)))) m
+ | Pfcvtzs X S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longofsingle rs#r1)))) m
+ | Pfcvtzs X D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longoffloat rs#r1)))) m
+ | Pfcvtzu W S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intuofsingle rs#r1)))) m
+ | Pfcvtzu W D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.intuoffloat rs#r1)))) m
+ | Pfcvtzu X S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longuofsingle rs#r1)))) m
+ | Pfcvtzu X D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.longuoffloat rs#r1)))) m
+ | Pscvtf S W rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofint rs#r1)))) m
+ | Pscvtf D W rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofint rs#r1)))) m
+ | Pscvtf S X rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflong rs#r1)))) m
+ | Pscvtf D X rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflong rs#r1)))) m
+ | Pucvtf S W rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleofintu rs#r1)))) m
+ | Pucvtf D W rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatofintu rs#r1)))) m
+ | Pucvtf S X rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.singleoflongu rs#r1)))) m
+ | Pucvtf D X rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.maketotal (Val.floatoflongu rs#r1)))) m
+ (** Floating-point arithmetic *)
+ | Pfabs S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.absfs rs#r1))) m
+ | Pfabs D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.absf rs#r1))) m
+ | Pfneg S rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.negfs rs#r1))) m
+ | Pfneg D rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.negf rs#r1))) m
+ | Pfadd S rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.addfs rs#r1 rs#r2))) m
+ | Pfadd D rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m
+ | Pfdiv S rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.divfs rs#r1 rs#r2))) m
+ | Pfdiv D rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m
+ | Pfmul S rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.mulfs rs#r1 rs#r2))) m
+ | Pfmul D rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m
+ | Pfnmul S rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.negfs (Val.mulfs rs#r1 rs#r2)))) m
+ | Pfnmul D rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.negf (Val.mulf rs#r1 rs#r2)))) m
+ | Pfsub S rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.subfs rs#r1 rs#r2))) m
+ | Pfsub D rd r1 r2 =>
+ Next (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
+ (** Floating-point comparison *)
+ | Pfcmp S r1 r2 =>
+ Next (nextinstr (compare_single rs rs#r1 rs#r2)) m
+ | Pfcmp D r1 r2 =>
+ Next (nextinstr (compare_float rs rs#r1 rs#r2)) m
+ | Pfcmp0 S r1 =>
+ Next (nextinstr (compare_single rs rs#r1 (Vsingle Float32.zero))) m
+ | Pfcmp0 D r1 =>
+ Next (nextinstr (compare_float rs rs#r1 (Vfloat Float.zero))) m
+ (** Floating-point conditional select *)
+ | Pfsel rd r1 r2 cond =>
+ let v :=
+ match eval_testcond cond rs with
+ | Some true => rs#r1
+ | Some false => rs#r2
+ | None => Vundef
+ end in
+ Next (nextinstr (rs#rd <- v)) m
+ (** Pseudo-instructions *)
+ | Pallocframe sz pos =>
+ let (m1, stk) := Mem.alloc m 0 sz in
+ let sp := (Vptr stk Ptrofs.zero) in
+ match Mem.storev Mint64 m1 (Val.offset_ptr sp pos) rs#SP with
+ | None => Stuck
+ | Some m2 => Next (nextinstr (rs #X29 <- (rs#SP) #SP <- sp #X16 <- Vundef)) m2
+ end
+ | Pfreeframe sz pos =>
+ match Mem.loadv Mint64 m (Val.offset_ptr rs#SP pos) with
+ | None => Stuck
+ | Some v =>
+ match rs#SP with
+ | Vptr stk ofs =>
+ match Mem.free m stk 0 sz with
+ | None => Stuck
+ | Some m' => Next (nextinstr (rs#SP <- v #X16 <- Vundef)) m'
+ end
+ | _ => Stuck
+ end
+ end
+ | Plabel lbl =>
+ Next (nextinstr rs) m
+ | Ploadsymbol rd id =>
+ Next (nextinstr (rs#rd <- (Genv.symbol_address ge id Ptrofs.zero))) m
+ | Pcvtsw2x rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.longofint rs#r1))) m
+ | Pcvtuw2x rd r1 =>
+ Next (nextinstr (rs#rd <- (Val.longofintu rs#r1))) m
+ | Pcvtx2w rd =>
+ Next (nextinstr (rs#rd <- (Val.loword rs#rd))) m
+ | Pbtbl r tbl =>
+ match (rs#X16 <- Vundef)#r with
+ | Vint n =>
+ match list_nth_z tbl (Int.unsigned n) with
+ | None => Stuck
+ | Some lbl => goto_label f lbl (rs#X16 <- Vundef #X17 <- Vundef) m
+ end
+ | _ => Stuck
+ end
+ | Pbuiltin ef args res => Stuck (**r treated specially below *)
+ (** The following instructions and directives are not generated directly
+ by Asmgen, so we do not model them. *)
+ | Pldp _ _ _
+ | Pstp _ _ _
+ | Pcls _ _ _
+ | Pclz _ _ _
+ | Prev _ _ _
+ | Prev16 _ _ _
+ | Pfsqrt _ _ _
+ | Pfmadd _ _ _ _ _
+ | Pfmsub _ _ _ _ _
+ | Pfnmadd _ _ _ _ _
+ | Pfnmsub _ _ _ _ _
+ | Pnop
+ | Pcfi_adjust _
+ | Pcfi_rel_offset _ =>
+ Stuck
+ end.
+
+(** Translation of the LTL/Linear/Mach view of machine registers
+ to the AArch64 view. Note that no LTL register maps to [X16],
+ [X18], nor [X30].
+ [X18] is reserved as the platform register and never used by the
+ code generated by CompCert.
+ [X30] is used for the return address, and can also be used as temporary.
+ [X16] can be used as temporary. *)
+
+Definition preg_of (r: mreg) : preg :=
+ match r with
+ | R0 => X0 | R1 => X1 | R2 => X2 | R3 => X3
+ | R4 => X4 | R5 => X5 | R6 => X6 | R7 => X7
+ | R8 => X8 | R9 => X9 | R10 => X10 | R11 => X11
+ | R12 => X12 | R13 => X13 | R14 => X14 | R15 => X15
+ | R17 => X17 | R19 => X19
+ | R20 => X20 | R21 => X21 | R22 => X22 | R23 => X23
+ | R24 => X24 | R25 => X25 | R26 => X26 | R27 => X27
+ | R28 => X28 | R29 => X29
+ | F0 => D0 | F1 => D1 | F2 => D2 | F3 => D3
+ | F4 => D4 | F5 => D5 | F6 => D6 | F7 => D7
+ | F8 => D8 | F9 => D9 | F10 => D10 | F11 => D11
+ | F12 => D12 | F13 => D13 | F14 => D14 | F15 => D15
+ | F16 => D16 | F17 => D17 | F18 => D18 | F19 => D19
+ | F20 => D20 | F21 => D21 | F22 => D22 | F23 => D23
+ | F24 => D24 | F25 => D25 | F26 => D26 | F27 => D27
+ | F28 => D28 | F29 => D29 | F30 => D30 | F31 => D31
+ end.
+
+(** Undefine all registers except SP and callee-save registers *)
+
+Definition undef_caller_save_regs (rs: regset) : regset :=
+ fun r =>
+ if preg_eq r SP
+ || In_dec preg_eq r (List.map preg_of (List.filter is_callee_save all_mregs))
+ then rs r
+ else Vundef.
+
+(** Extract the values of the arguments of an external call.
+ We exploit the calling conventions from module [Conventions], except that
+ we use AArch64 registers instead of locations. *)
+
+Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop :=
+ | extcall_arg_reg: forall r,
+ extcall_arg rs m (R r) (rs (preg_of r))
+ | extcall_arg_stack: forall ofs ty bofs v,
+ bofs = Stacklayout.fe_ofs_arg + 4 * ofs ->
+ Mem.loadv (chunk_of_type ty) m
+ (Val.offset_ptr rs#SP (Ptrofs.repr bofs)) = Some v ->
+ extcall_arg rs m (Locations.S Outgoing ofs ty) v.
+
+Inductive extcall_arg_pair (rs: regset) (m: mem): rpair loc -> val -> Prop :=
+ | extcall_arg_one: forall l v,
+ extcall_arg rs m l v ->
+ extcall_arg_pair rs m (One l) v
+ | extcall_arg_twolong: forall hi lo vhi vlo,
+ extcall_arg rs m hi vhi ->
+ extcall_arg rs m lo vlo ->
+ extcall_arg_pair rs m (Twolong hi lo) (Val.longofwords vhi vlo).
+
+Definition extcall_arguments
+ (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop :=
+ list_forall2 (extcall_arg_pair rs m) (loc_arguments sg) args.
+
+Definition loc_external_result (sg: signature) : rpair preg :=
+ map_rpair preg_of (loc_result sg).
+
+(** Execution of the instruction at [rs#PC]. *)
+
+Inductive state: Type :=
+ | State: regset -> mem -> state.
+
+Inductive step: state -> trace -> state -> Prop :=
+ | exec_step_internal:
+ forall b ofs f i rs m rs' m',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some i ->
+ exec_instr f i rs m = Next rs' m' ->
+ step (State rs m) E0 (State rs' m')
+ | exec_step_builtin:
+ forall b ofs f ef args res rs m vargs t vres rs' m',
+ rs PC = Vptr b ofs ->
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ find_instr (Ptrofs.unsigned ofs) f.(fn_code) = Some (Pbuiltin ef args res) ->
+ eval_builtin_args ge rs rs#SP m args vargs ->
+ external_call ef ge vargs m t vres m' ->
+ rs' = nextinstr
+ (set_res res vres
+ (undef_regs (map preg_of (destroyed_by_builtin ef)) rs)) ->
+ step (State rs m) t (State rs' m')
+ | exec_step_external:
+ forall b ef args res rs m t rs' m',
+ rs PC = Vptr b Ptrofs.zero ->
+ Genv.find_funct_ptr ge b = Some (External ef) ->
+ external_call ef ge args m t res m' ->
+ extcall_arguments rs m (ef_sig ef) args ->
+ rs' = (set_pair (loc_external_result (ef_sig ef)) res (undef_caller_save_regs rs)) #PC <- (rs RA) ->
+ step (State rs m) t (State rs' m').
+
+End RELSEM.
+
+(** Execution of whole programs. *)
+
+Inductive initial_state (p: program): state -> Prop :=
+ | initial_state_intro: forall m0,
+ Genv.init_mem p = Some m0 ->
+ let ge := Genv.globalenv p in
+ let rs0 :=
+ (Pregmap.init Vundef)
+ # PC <- (Genv.symbol_address ge p.(prog_main) Ptrofs.zero)
+ # RA <- Vnullptr
+ # SP <- Vnullptr in
+ initial_state p (State rs0 m0).
+
+Inductive final_state: state -> int -> Prop :=
+ | final_state_intro: forall rs m r,
+ rs#PC = Vnullptr ->
+ rs#X0 = Vint r ->
+ final_state (State rs m) r.
+
+Definition semantics (p: program) :=
+ Semantics step (initial_state p) final_state (Genv.globalenv p).
+
+(** Determinacy of the [Asm] semantics. *)
+
+Remark extcall_arguments_determ:
+ forall rs m sg args1 args2,
+ extcall_arguments rs m sg args1 -> extcall_arguments rs m sg args2 -> args1 = args2.
+Proof.
+ intros until m.
+ assert (A: forall l v1 v2,
+ extcall_arg rs m l v1 -> extcall_arg rs m l v2 -> v1 = v2).
+ { intros. inv H; inv H0; congruence. }
+ assert (B: forall p v1 v2,
+ extcall_arg_pair rs m p v1 -> extcall_arg_pair rs m p v2 -> v1 = v2).
+ { intros. inv H; inv H0.
+ eapply A; eauto.
+ f_equal; eapply A; eauto. }
+ assert (C: forall ll vl1, list_forall2 (extcall_arg_pair rs m) ll vl1 ->
+ forall vl2, list_forall2 (extcall_arg_pair rs m) ll vl2 -> vl1 = vl2).
+ {
+ induction 1; intros vl2 EA; inv EA.
+ auto.
+ f_equal; eauto. }
+ intros. eapply C; eauto.
+Qed.
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+Ltac Equalities :=
+ match goal with
+ | [ H1: ?a = ?b, H2: ?a = ?c |- _ ] =>
+ rewrite H1 in H2; inv H2; Equalities
+ | _ => idtac
+ end.
+ intros; constructor; simpl; intros.
+- (* determ *)
+ inv H; inv H0; Equalities.
+ split. constructor. auto.
+ discriminate.
+ discriminate.
+ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
+ exploit external_call_determ. eexact H5. eexact H11. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
+ assert (args0 = args) by (eapply extcall_arguments_determ; eauto). subst args0.
+ exploit external_call_determ. eexact H3. eexact H8. intros [A B].
+ split. auto. intros. destruct B; auto. subst. auto.
+- (* trace length *)
+ red; intros. inv H; simpl.
+ omega.
+ eapply external_call_trace_length; eauto.
+ eapply external_call_trace_length; eauto.
+- (* initial states *)
+ inv H; inv H0. f_equal. congruence.
+- (* final no step *)
+ inv H. red; intros; red; intros. inv H; rewrite H0 in *; discriminate.
+- (* final states *)
+ inv H; inv H0. congruence.
+Qed.
+
+(** Classification functions for processor registers (used in Asmgenproof). *)
+
+Definition data_preg (r: preg) : bool :=
+ match r with
+ | IR X16 => false
+ | IR X30 => false
+ | IR _ => true
+ | FR _ => true
+ | CR _ => false
+ | SP => true
+ | PC => false
+ end.
diff --git a/aarch64/AsmToJSON.ml b/aarch64/AsmToJSON.ml
new file mode 100644
index 00000000..b7cfc152
--- /dev/null
+++ b/aarch64/AsmToJSON.ml
@@ -0,0 +1,24 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Functions to serialize AArch64 Asm to JSON *)
+
+(* Dummy function *)
+
+let destination: string option ref = ref None
+
+let sdump_folder = ref ""
+
+let print_if prog sourcename =
+ ()
+
+let pp_mnemonics pp = ()
diff --git a/aarch64/Asmexpand.ml b/aarch64/Asmexpand.ml
new file mode 100644
index 00000000..471ad501
--- /dev/null
+++ b/aarch64/Asmexpand.ml
@@ -0,0 +1,453 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Expanding built-ins and some pseudo-instructions by rewriting
+ of the AArch64 assembly code. *)
+
+open Asm
+open Asmexpandaux
+open AST
+open Camlcoq
+module Ptrofs = Integers.Ptrofs
+
+exception Error of string
+
+(* Useful constants *)
+
+let _0 = Z.zero
+let _1 = Z.one
+let _2 = Z.of_sint 2
+let _4 = Z.of_sint 4
+let _8 = Z.of_sint 8
+let _16 = Z.of_sint 16
+let _m1 = Z.of_sint (-1)
+
+(* Emit instruction sequences that set or offset a register by a constant. *)
+
+let expand_loadimm32 (dst: ireg) n =
+ List.iter emit (Asmgen.loadimm32 dst n [])
+
+let expand_addimm64 (dst: iregsp) (src: iregsp) n =
+ List.iter emit (Asmgen.addimm64 dst src n [])
+
+let expand_storeptr (src: ireg) (base: iregsp) ofs =
+ List.iter emit (Asmgen.storeptr src base ofs [])
+
+(* Handling of varargs *)
+
+(* Determine the number of int registers, FP registers, and stack locations
+ used to pass the fixed parameters. *)
+
+let rec next_arg_locations ir fr stk = function
+ | [] ->
+ (ir, fr, stk)
+ | (Tint | Tlong | Tany32 | Tany64) :: l ->
+ if ir < 8
+ then next_arg_locations (ir + 1) fr stk l
+ else next_arg_locations ir fr (stk + 8) l
+ | (Tfloat | Tsingle) :: l ->
+ if fr < 8
+ then next_arg_locations ir (fr + 1) stk l
+ else next_arg_locations ir fr (stk + 8) l
+
+(* Allocate memory on the stack and use it to save the registers
+ used for parameter passing. As an optimization, do not save
+ the registers used to pass the fixed parameters. *)
+
+let int_param_regs = [| X0; X1; X2; X3; X4; X5; X6; X7 |]
+let float_param_regs = [| D0; D1; D2; D3; D4; D5; D6; D7 |]
+let size_save_register_area = 8*8 + 8*16
+
+let save_parameter_registers ir fr =
+ emit (Psubimm(X, XSP, XSP, Z.of_uint size_save_register_area));
+ let i = ref ir in
+ while !i < 8 do
+ let pos = 8*16 + !i*8 in
+ if !i land 1 = 0 then begin
+ emit (Pstp(int_param_regs.(!i), int_param_regs.(!i + 1),
+ ADimm(XSP, Z.of_uint pos)));
+ i := !i + 2
+ end else begin
+ emit (Pstrx(int_param_regs.(!i), ADimm(XSP, Z.of_uint pos)));
+ i := !i + 1
+ end
+ done;
+ for i = fr to 7 do
+ let pos = i*16 in
+ emit (Pstrd(float_param_regs.(i), ADimm(XSP, Z.of_uint pos)))
+ done
+
+(* Initialize a va_list as per va_start.
+ Register r points to the following struct:
+
+ typedef struct __va_list {
+ void *__stack; // next stack parameter
+ void *__gr_top; // top of the save area for int regs
+ void *__vr_top; // top of the save area for float regs
+ int__gr_offs; // offset from gr_top to next int reg
+ int__vr_offs; // offset from gr_top to next FP reg
+ }
+*)
+
+let current_function_stacksize = ref 0L
+
+let expand_builtin_va_start r =
+ if not (is_current_function_variadic ()) then
+ invalid_arg "Fatal error: va_start used in non-vararg function";
+ let (ir, fr, stk) =
+ next_arg_locations 0 0 0 (get_current_function_args ()) in
+ let stack_ofs = Int64.(add !current_function_stacksize (of_int stk))
+ and gr_top_ofs = !current_function_stacksize
+ and vr_top_ofs = Int64.(sub !current_function_stacksize 64L)
+ and gr_offs = - ((8 - ir) * 8)
+ and vr_offs = - ((8 - fr) * 16) in
+ (* va->__stack = sp + stack_ofs *)
+ expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 stack_ofs);
+ emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 0L)));
+ (* va->__gr_top = sp + gr_top_ofs *)
+ if gr_top_ofs <> stack_ofs then
+ expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 gr_top_ofs);
+ emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 8L)));
+ (* va->__vr_top = sp + vr_top_ofs *)
+ expand_addimm64 (RR1 X16) XSP (coqint_of_camlint64 vr_top_ofs);
+ emit (Pstrx(X16, ADimm(RR1 r, coqint_of_camlint64 16L)));
+ (* va->__gr_offs = gr_offs *)
+ expand_loadimm32 X16 (coqint_of_camlint (Int32.of_int gr_offs));
+ emit (Pstrw(X16, ADimm(RR1 r, coqint_of_camlint64 24L)));
+ (* va->__vr_offs = vr_offs *)
+ expand_loadimm32 X16 (coqint_of_camlint (Int32.of_int vr_offs));
+ emit (Pstrw(X16, ADimm(RR1 r, coqint_of_camlint64 28L)))
+
+(* Handling of annotations *)
+
+let expand_annot_val kind txt targ args res =
+ emit (Pbuiltin (EF_annot(kind,txt,[targ]), args, BR_none));
+ match args, res with
+ | [BA(IR src)], BR(IR dst) ->
+ if dst <> src then emit (Pmov (RR1 dst, RR1 src))
+ | [BA(FR src)], BR(FR dst) ->
+ if dst <> src then emit (Pfmov (dst, src))
+ | _, _ ->
+ raise (Error "ill-formed __builtin_annot_val")
+
+(* Handling of memcpy *)
+
+(* We assume unaligned memory accesses are efficient. Hence we use
+ memory accesses as wide as we can, up to 16 bytes.
+ Temporary registers used: x15 x16 x17 x29 x30. *)
+
+let offset_in_range ofs =
+ (* The 512 upper bound comes from ldp/stp. Single-register load/store
+ instructions support bigger offsets. *)
+ let ofs = Z.to_int64 ofs in 0L <= ofs && ofs < 512L
+
+let memcpy_small_arg sz arg tmp =
+ match arg with
+ | BA (IR r) ->
+ (RR1 r, _0)
+ | BA_addrstack ofs ->
+ if offset_in_range ofs
+ && offset_in_range (Ptrofs.add ofs (Ptrofs.repr (Z.of_uint sz)))
+ then (XSP, ofs)
+ else begin expand_addimm64 (RR1 tmp) XSP ofs; (RR1 tmp, _0) end
+ | _ ->
+ assert false
+
+let expand_builtin_memcpy_small sz al src dst =
+ let (tsrc, tdst) =
+ if dst <> BA (IR X17) then (X17, X29) else (X29, X17) in
+ let (rsrc, osrc) = memcpy_small_arg sz src tsrc in
+ let (rdst, odst) = memcpy_small_arg sz dst tdst in
+ let rec copy osrc odst sz =
+ if sz >= 16 then begin
+ emit (Pldp(X16, X30, ADimm(rsrc, osrc)));
+ emit (Pstp(X16, X30, ADimm(rdst, odst)));
+ copy (Ptrofs.add osrc _16) (Ptrofs.add odst _16) (sz - 16)
+ end
+ else if sz >= 8 then begin
+ emit (Pldrx(X16, ADimm(rsrc, osrc)));
+ emit (Pstrx(X16, ADimm(rdst, odst)));
+ copy (Ptrofs.add osrc _8) (Ptrofs.add odst _8) (sz - 8)
+ end
+ else if sz >= 4 then begin
+ emit (Pldrw(X16, ADimm(rsrc, osrc)));
+ emit (Pstrw(X16, ADimm(rdst, odst)));
+ copy (Ptrofs.add osrc _4) (Ptrofs.add odst _4) (sz - 4)
+ end
+ else if sz >= 2 then begin
+ emit (Pldrh(W, X16, ADimm(rsrc, osrc)));
+ emit (Pstrh(X16, ADimm(rdst, odst)));
+ copy (Ptrofs.add osrc _2) (Ptrofs.add odst _2) (sz - 2)
+ end
+ else if sz >= 1 then begin
+ emit (Pldrb(W, X16, ADimm(rsrc, osrc)));
+ emit (Pstrb(X16, ADimm(rdst, odst)));
+ copy (Ptrofs.add osrc _1) (Ptrofs.add odst _1) (sz - 1)
+ end
+ in copy osrc odst sz
+
+let memcpy_big_arg arg tmp =
+ match arg with
+ | BA (IR r) -> emit (Pmov(RR1 tmp, RR1 r))
+ | BA_addrstack ofs -> expand_addimm64 (RR1 tmp) XSP ofs
+ | _ -> assert false
+
+let expand_builtin_memcpy_big sz al src dst =
+ assert (sz >= 16);
+ memcpy_big_arg src X30;
+ memcpy_big_arg dst X29;
+ let lbl = new_label () in
+ expand_loadimm32 X15 (Z.of_uint (sz / 16));
+ emit (Plabel lbl);
+ emit (Pldp(X16, X17, ADpostincr(RR1 X30, _16)));
+ emit (Pstp(X16, X17, ADpostincr(RR1 X29, _16)));
+ emit (Psubimm(W, RR1 X15, RR1 X15, _1));
+ emit (Pcbnz(W, X15, lbl));
+ if sz mod 16 >= 8 then begin
+ emit (Pldrx(X16, ADpostincr(RR1 X30, _8)));
+ emit (Pstrx(X16, ADpostincr(RR1 X29, _8)))
+ end;
+ if sz mod 8 >= 4 then begin
+ emit (Pldrw(X16, ADpostincr(RR1 X30, _4)));
+ emit (Pstrw(X16, ADpostincr(RR1 X29, _4)))
+ end;
+ if sz mod 4 >= 2 then begin
+ emit (Pldrh(W, X16, ADpostincr(RR1 X30, _2)));
+ emit (Pstrh(X16, ADpostincr(RR1 X29, _2)))
+ end;
+ if sz mod 2 >= 1 then begin
+ emit (Pldrb(W, X16, ADpostincr(RR1 X30, _1)));
+ emit (Pstrb(X16, ADpostincr(RR1 X29, _1)))
+ end
+
+let expand_builtin_memcpy sz al args =
+ let (dst, src) =
+ match args with [d; s] -> (d, s) | _ -> assert false in
+ if sz < 64
+ then expand_builtin_memcpy_small sz al src dst
+ else expand_builtin_memcpy_big sz al src dst
+
+(* Handling of volatile reads and writes *)
+
+let expand_builtin_vload_common chunk base ofs res =
+ let addr = ADimm(base, ofs) in
+ match chunk, res with
+ | Mint8unsigned, BR(IR res) ->
+ emit (Pldrb(W, res, addr))
+ | Mint8signed, BR(IR res) ->
+ emit (Pldrsb(W, res, addr))
+ | Mint16unsigned, BR(IR res) ->
+ emit (Pldrh(W, res, addr))
+ | Mint16signed, BR(IR res) ->
+ emit (Pldrsh(W, res, addr))
+ | Mint32, BR(IR res) ->
+ emit (Pldrw(res, addr))
+ | Mint64, BR(IR res) ->
+ emit (Pldrx(res, addr))
+ | Mfloat32, BR(FR res) ->
+ emit (Pldrs(res, addr))
+ | Mfloat64, BR(FR res) ->
+ emit (Pldrd(res, addr))
+ | _ ->
+ assert false
+
+let expand_builtin_vload chunk args res =
+ match args with
+ | [BA(IR addr)] ->
+ expand_builtin_vload_common chunk (RR1 addr) _0 res
+ | [BA_addrstack ofs] ->
+ if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then
+ expand_builtin_vload_common chunk XSP ofs res
+ else begin
+ expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *)
+ expand_builtin_vload_common chunk (RR1 X16) _0 res
+ end
+ | [BA_addptr(BA(IR addr), BA_long ofs)] ->
+ if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then
+ expand_builtin_vload_common chunk (RR1 addr) ofs res
+ else begin
+ expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *)
+ expand_builtin_vload_common chunk (RR1 X16) _0 res
+ end
+ | _ ->
+ assert false
+
+let expand_builtin_vstore_common chunk base ofs src =
+ let addr = ADimm(base, ofs) in
+ match chunk, src with
+ | (Mint8signed | Mint8unsigned), BA(IR src) ->
+ emit (Pstrb(src, addr))
+ | (Mint16signed | Mint16unsigned), BA(IR src) ->
+ emit (Pstrh(src, addr))
+ | Mint32, BA(IR src) ->
+ emit (Pstrw(src, addr))
+ | Mint64, BA(IR src) ->
+ emit (Pstrx(src, addr))
+ | Mfloat32, BA(FR src) ->
+ emit (Pstrs(src, addr))
+ | Mfloat64, BA(FR src) ->
+ emit (Pstrd(src, addr))
+ | _ ->
+ assert false
+
+let expand_builtin_vstore chunk args =
+ match args with
+ | [BA(IR addr); src] ->
+ expand_builtin_vstore_common chunk (RR1 addr) _0 src
+ | [BA_addrstack ofs; src] ->
+ if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then
+ expand_builtin_vstore_common chunk XSP ofs src
+ else begin
+ expand_addimm64 (RR1 X16) XSP ofs; (* X16 <- SP + ofs *)
+ expand_builtin_vstore_common chunk (RR1 X16) _0 src
+ end
+ | [BA_addptr(BA(IR addr), BA_long ofs); src] ->
+ if offset_in_range (Z.add ofs (Memdata.size_chunk chunk)) then
+ expand_builtin_vstore_common chunk (RR1 addr) ofs src
+ else begin
+ expand_addimm64 (RR1 X16) (RR1 addr) ofs; (* X16 <- addr + ofs *)
+ expand_builtin_vstore_common chunk (RR1 X16) _0 src
+ end
+ | _ ->
+ assert false
+
+(* Handling of compiler-inlined builtins *)
+
+let expand_builtin_inline name args res =
+ match name, args, res with
+ (* Synchronization *)
+ | "__builtin_membar", [], _ ->
+ ()
+ | "__builtin_nop", [], _ ->
+ emit Pnop
+ (* Byte swap *)
+ | ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) ->
+ emit (Prev(W, res, a1))
+ | "__builtin_bswap64", [BA(IR a1)], BR(IR res) ->
+ emit (Prev(X, res, a1))
+ | "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
+ emit (Prev16(W, res, a1));
+ emit (Pandimm(W, res, RR0 res, Z.of_uint 0xFFFF))
+ (* Count leading zeros and leading sign bits *)
+ | "__builtin_clz", [BA(IR a1)], BR(IR res) ->
+ emit (Pclz(W, res, a1))
+ | ("__builtin_clzl" | "__builtin_clzll"), [BA(IR a1)], BR(IR res) ->
+ emit (Pclz(X, res, a1))
+ | "__builtin_cls", [BA(IR a1)], BR(IR res) ->
+ emit (Pcls(W, res, a1))
+ | ("__builtin_clsl" | "__builtin_clsll"), [BA(IR a1)], BR(IR res) ->
+ emit (Pcls(X, res, a1))
+ (* Float arithmetic *)
+ | "__builtin_fabs", [BA(FR a1)], BR(FR res) ->
+ emit (Pfabs(D, res, a1))
+ | "__builtin_fsqrt", [BA(FR a1)], BR(FR res) ->
+ emit (Pfsqrt(D, res, a1))
+ | "__builtin_fmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) ->
+ emit (Pfmadd(D, res, a1, a2, a3))
+ | "__builtin_fmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) ->
+ emit (Pfmsub(D, res, a1, a2, a3))
+ | "__builtin_fnmadd", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) ->
+ emit (Pfnmadd(D, res, a1, a2, a3))
+ | "__builtin_fnmsub", [BA(FR a1); BA(FR a2); BA(FR a3)], BR(FR res) ->
+ emit (Pfnmsub(D, res, a1, a2, a3))
+ (* Vararg *)
+ | "__builtin_va_start", [BA(IR a)], _ ->
+ expand_builtin_va_start a
+ (* Catch-all *)
+ | _ ->
+ raise (Error ("unrecognized builtin " ^ name))
+
+(* Expansion of instructions *)
+
+let expand_instruction instr =
+ match instr with
+ | Pallocframe (sz, ofs) ->
+ emit (Pmov (RR1 X29, XSP));
+ if is_current_function_variadic() then begin
+ let (ir, fr, _) =
+ next_arg_locations 0 0 0 (get_current_function_args ()) in
+ save_parameter_registers ir fr;
+ current_function_stacksize :=
+ Int64.(add (Z.to_int64 sz) (of_int size_save_register_area))
+ end else begin
+ current_function_stacksize := Z.to_int64 sz
+ end;
+ expand_addimm64 XSP XSP (Ptrofs.repr (Z.neg sz));
+ expand_storeptr X29 XSP ofs
+ | Pfreeframe (sz, ofs) ->
+ expand_addimm64 XSP XSP (coqint_of_camlint64 !current_function_stacksize)
+ | Pcvtx2w rd ->
+ (* no code generated, the upper 32 bits of rd will be ignored *)
+ ()
+ | Pbuiltin (ef,args,res) ->
+ begin match ef with
+ | EF_builtin (name,sg) ->
+ expand_builtin_inline (camlstring_of_coqstring name) args res
+ | EF_vload chunk ->
+ expand_builtin_vload chunk args res
+ | EF_vstore chunk ->
+ expand_builtin_vstore chunk args
+ | EF_annot_val (kind,txt,targ) ->
+ expand_annot_val kind txt targ args res
+ | EF_memcpy(sz, al) ->
+ expand_builtin_memcpy (Z.to_int sz) (Z.to_int al) args
+ | EF_annot _ | EF_debug _ | EF_inline_asm _ ->
+ emit instr
+ | _ ->
+ assert false
+ end
+ | _ ->
+ emit instr
+
+let int_reg_to_dwarf = function
+ | X0 -> 0 | X1 -> 1 | X2 -> 2 | X3 -> 3 | X4 -> 4
+ | X5 -> 5 | X6 -> 6 | X7 -> 7 | X8 -> 8 | X9 -> 9
+ | X10 -> 10 | X11 -> 11 | X12 -> 12 | X13 -> 13 | X14 -> 14
+ | X15 -> 15 | X16 -> 16 | X17 -> 17 | X18 -> 18 | X19 -> 19
+ | X20 -> 20 | X21 -> 21 | X22 -> 22 | X23 -> 23 | X24 -> 24
+ | X25 -> 25 | X26 -> 26 | X27 -> 27 | X28 -> 28 | X29 -> 29
+ | X30 -> 30
+
+let float_reg_to_dwarf = function
+ | D0 -> 64 | D1 -> 65 | D2 -> 66 | D3 -> 67 | D4 -> 68
+ | D5 -> 69 | D6 -> 70 | D7 -> 71 | D8 -> 72 | D9 -> 73
+ | D10 -> 74 | D11 -> 75 | D12 -> 76 | D13 -> 77 | D14 -> 78
+ | D15 -> 79 | D16 -> 80 | D17 -> 81 | D18 -> 82 | D19 -> 83
+ | D20 -> 84 | D21 -> 85 | D22 -> 86 | D23 -> 87 | D24 -> 88
+ | D25 -> 89 | D26 -> 90 | D27 -> 91 | D28 -> 92 | D29 -> 93
+ | D30 -> 94 | D31 -> 95
+
+let preg_to_dwarf = function
+ | IR r -> int_reg_to_dwarf r
+ | FR r -> float_reg_to_dwarf r
+ | SP -> 31
+ | _ -> assert false
+
+let expand_function id fn =
+ try
+ set_current_function fn;
+ expand id (* sp= *) 31 preg_to_dwarf expand_instruction fn.fn_code;
+ Errors.OK (get_current_function ())
+ with Error s ->
+ Errors.Error (Errors.msg (coqstring_of_camlstring s))
+
+let expand_fundef id = function
+ | Internal f ->
+ begin match expand_function id f with
+ | Errors.OK tf -> Errors.OK (Internal tf)
+ | Errors.Error msg -> Errors.Error msg
+ end
+ | External ef ->
+ Errors.OK (External ef)
+
+let expand_program (p: Asm.program) : Asm.program Errors.res =
+ AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p
diff --git a/aarch64/Asmgen.v b/aarch64/Asmgen.v
new file mode 100644
index 00000000..024c9a17
--- /dev/null
+++ b/aarch64/Asmgen.v
@@ -0,0 +1,1172 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Translation from Mach to AArch64. *)
+
+Require Import Recdef Coqlib Zwf Zbits.
+Require Import Errors AST Integers Floats Op.
+Require Import Locations Mach Asm.
+
+Local Open Scope string_scope.
+Local Open Scope list_scope.
+Local Open Scope error_monad_scope.
+
+(** Alignment check for symbols *)
+
+Parameter symbol_is_aligned : ident -> Z -> bool.
+(** [symbol_is_aligned id sz] checks whether the symbol [id] is [sz] aligned *)
+
+(** Extracting integer or float registers. *)
+
+Definition ireg_of (r: mreg) : res ireg :=
+ match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.
+
+Definition freg_of (r: mreg) : res freg :=
+ match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.
+
+(** Recognition of immediate arguments for logical integer operations.*)
+
+(** Valid immediate arguments are repetitions of a bit pattern [B]
+ of length [e] = 2, 4, 8, 16, 32 or 64.
+ The bit pattern [B] must be of the form [0*1*0*] or [1*0*1*]
+ but must not be all zeros or all ones. *)
+
+(** The following automaton recognizes [0*1*0*|1*0*1*].
+<<
+ 0 1 0
+ / \ / \ / \
+ \ / \ / \ /
+ -0--> [B] --1--> [D] --0--> [F]
+ /
+ [A]
+ \
+ -1--> [C] --0--> [E] --1--> [G]
+ / \ / \ / \
+ \ / \ / \ /
+ 1 0 1
+>>
+*)
+
+Module Automaton.
+
+Inductive state : Type := SA | SB | SC | SD | SE | SF | SG | Sbad.
+
+Definition start := SA.
+
+Definition next (s: state) (b: bool) :=
+ match s, b with
+ | SA,false => SB | SA,true => SC
+ | SB,false => SB | SB,true => SD
+ | SC,false => SE | SC,true => SC
+ | SD,false => SF | SD,true => SD
+ | SE,false => SE | SE,true => SG
+ | SF,false => SF | SF,true => Sbad
+ | SG,false => Sbad | SG,true => SG
+ | Sbad,_ => Sbad
+ end.
+
+Definition accepting (s: state) :=
+ match s with
+ | SA | SB | SC | SD | SE | SF | SG => true
+ | Sbad => false
+ end.
+
+Fixpoint run (len: nat) (s: state) (x: Z) : bool :=
+ match len with
+ | Datatypes.O => accepting s
+ | Datatypes.S len => run len (next s (Z.odd x)) (Z.div2 x)
+ end.
+
+End Automaton.
+
+(** The following function determines the candidate length [e],
+ ensuring that [x] is a repetition [BB...B]
+ of a bit pattern [B] of length [e]. *)
+
+Definition logical_imm_length (x: Z) (sixtyfour: bool) : nat :=
+ (** [test n] checks that the low [2n] bits of [x] are of the
+ form [BB], that is, two occurrences of the same [n] bits *)
+ let test (n: Z) : bool :=
+ Z.eqb (Zzero_ext n x) (Zzero_ext n (Z.shiftr x n)) in
+ (** If [test n] fails, we know that the candidate length [e] is
+ at least [2n]. Hence we test with decreasing values of [n]:
+ 32, 16, 8, 4, 2. *)
+ if sixtyfour && negb (test 32) then 64%nat
+ else if negb (test 16) then 32%nat
+ else if negb (test 8) then 16%nat
+ else if negb (test 4) then 8%nat
+ else if negb (test 2) then 4%nat
+ else 2%nat.
+
+(** A valid logical immediate is
+- neither [0] nor [-1];
+- composed of a repetition [BBBBB] of a bit-pattern [B] of length [e]
+- the low [e] bits of the number, that is, [B], match [0*1*0*] or [1*0*1*].
+*)
+
+Definition is_logical_imm32 (x: int) : bool :=
+ negb (Int.eq x Int.zero) && negb (Int.eq x Int.mone) &&
+ Automaton.run (logical_imm_length (Int.unsigned x) false)
+ Automaton.start (Int.unsigned x).
+
+Definition is_logical_imm64 (x: int64) : bool :=
+ negb (Int64.eq x Int64.zero) && negb (Int64.eq x Int64.mone) &&
+ Automaton.run (logical_imm_length (Int64.unsigned x) true)
+ Automaton.start (Int64.unsigned x).
+
+(** Arithmetic immediates are 12-bit unsigned numbers, possibly shifted left 12 bits *)
+
+Definition is_arith_imm32 (x: int) : bool :=
+ Int.eq x (Int.zero_ext 12 x)
+ || Int.eq x (Int.shl (Int.zero_ext 12 (Int.shru x (Int.repr 12))) (Int.repr 12)).
+
+Definition is_arith_imm64 (x: int64) : bool :=
+ Int64.eq x (Int64.zero_ext 12 x)
+ || Int64.eq x (Int64.shl (Int64.zero_ext 12 (Int64.shru x (Int64.repr 12))) (Int64.repr 12)).
+
+(** Decompose integer literals into 16-bit fragments *)
+
+Fixpoint decompose_int (N: nat) (n p: Z) {struct N} : list (Z * Z) :=
+ match N with
+ | Datatypes.O => nil
+ | Datatypes.S N =>
+ let frag := Zzero_ext 16 (Z.shiftr n p) in
+ if Z.eqb frag 0 then
+ decompose_int N n (p + 16)
+ else
+ (frag, p) :: decompose_int N (Z.ldiff n (Z.shiftl 65535 p)) (p + 16)
+ end.
+
+Definition negate_decomposition (l: list (Z * Z)) :=
+ List.map (fun np => (Z.lxor (fst np) 65535, snd np)) l.
+
+Definition loadimm_k (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
+ List.fold_right (fun np k => Pmovk sz rd (fst np) (snd np) :: k) k l.
+
+Definition loadimm_z (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
+ match l with
+ | nil => Pmovz sz rd 0 0 :: k
+ | (n1, p1) :: l => Pmovz sz rd n1 p1 :: loadimm_k sz rd l k
+ end.
+
+Definition loadimm_n (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
+ match l with
+ | nil => Pmovn sz rd 0 0 :: k
+ | (n1, p1) :: l => Pmovn sz rd n1 p1 :: loadimm_k sz rd (negate_decomposition l) k
+ end.
+
+Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: code) : code :=
+ let N := match sz with W => 2%nat | X => 4%nat end in
+ let dz := decompose_int N n 0 in
+ let dn := decompose_int N (Z.lnot n) 0 in
+ if Nat.leb (List.length dz) (List.length dn)
+ then loadimm_z sz rd dz k
+ else loadimm_n sz rd dn k.
+
+Definition loadimm32 (rd: ireg) (n: int) (k: code) : code :=
+ if is_logical_imm32 n
+ then Porrimm W rd XZR (Int.unsigned n) :: k
+ else loadimm W rd (Int.unsigned n) k.
+
+Definition loadimm64 (rd: ireg) (n: int64) (k: code) : code :=
+ if is_logical_imm64 n
+ then Porrimm X rd XZR (Int64.unsigned n) :: k
+ else loadimm X rd (Int64.unsigned n) k.
+
+(** Add immediate *)
+
+Definition addimm_aux (insn: iregsp -> iregsp -> Z -> instruction)
+ (rd r1: iregsp) (n: Z) (k: code) :=
+ let nlo := Zzero_ext 12 n in
+ let nhi := n - nlo in
+ if Z.eqb nhi 0 then
+ insn rd r1 nlo :: k
+ else if Z.eqb nlo 0 then
+ insn rd r1 nhi :: k
+ else
+ insn rd r1 nhi :: insn rd rd nlo :: k.
+
+Definition addimm32 (rd r1: ireg) (n: int) (k: code) : code :=
+ let m := Int.neg n in
+ if Int.eq n (Int.zero_ext 24 n) then
+ addimm_aux (Paddimm W) rd r1 (Int.unsigned n) k
+ else if Int.eq m (Int.zero_ext 24 m) then
+ addimm_aux (Psubimm W) rd r1 (Int.unsigned m) k
+ else if Int.lt n Int.zero then
+ loadimm32 X16 m (Psub W rd r1 X16 SOnone :: k)
+ else
+ loadimm32 X16 n (Padd W rd r1 X16 SOnone :: k).
+
+Definition addimm64 (rd r1: iregsp) (n: int64) (k: code) : code :=
+ let m := Int64.neg n in
+ if Int64.eq n (Int64.zero_ext 24 n) then
+ addimm_aux (Paddimm X) rd r1 (Int64.unsigned n) k
+ else if Int64.eq m (Int64.zero_ext 24 m) then
+ addimm_aux (Psubimm X) rd r1 (Int64.unsigned m) k
+ else if Int64.lt n Int64.zero then
+ loadimm64 X16 m (Psubext rd r1 X16 (EOuxtx Int.zero) :: k)
+ else
+ loadimm64 X16 n (Paddext rd r1 X16 (EOuxtx Int.zero) :: k).
+
+(** Logical immediate *)
+
+Definition logicalimm32
+ (insn1: ireg -> ireg0 -> Z -> instruction)
+ (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
+ (rd r1: ireg) (n: int) (k: code) : code :=
+ if is_logical_imm32 n
+ then insn1 rd r1 (Int.unsigned n) :: k
+ else loadimm32 X16 n (insn2 rd r1 X16 SOnone :: k).
+
+Definition logicalimm64
+ (insn1: ireg -> ireg0 -> Z -> instruction)
+ (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
+ (rd r1: ireg) (n: int64) (k: code) : code :=
+ if is_logical_imm64 n
+ then insn1 rd r1 (Int64.unsigned n) :: k
+ else loadimm64 X16 n (insn2 rd r1 X16 SOnone :: k).
+
+(** Sign- or zero-extended arithmetic *)
+
+Definition transl_extension (ex: extension) (a: int) : extend_op :=
+ match ex with Xsgn32 => EOsxtw a | Xuns32 => EOuxtw a end.
+
+Definition move_extended_base
+ (rd: ireg) (r1: ireg) (ex: extension) (k: code) : code :=
+ match ex with
+ | Xsgn32 => Pcvtsw2x rd r1 :: k
+ | Xuns32 => Pcvtuw2x rd r1 :: k
+ end.
+
+Definition move_extended
+ (rd: ireg) (r1: ireg) (ex: extension) (a: int) (k: code) : code :=
+ if Int.eq a Int.zero then
+ move_extended_base rd r1 ex k
+ else
+ move_extended_base rd r1 ex (Padd X rd XZR rd (SOlsl a) :: k).
+
+Definition arith_extended
+ (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction)
+ (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction)
+ (rd r1 r2: ireg) (ex: extension) (a: int) (k: code) : code :=
+ if Int.ltu a (Int.repr 5) then
+ insnX rd r1 r2 (transl_extension ex a) :: k
+ else
+ move_extended_base X16 r2 ex (insnS rd r1 X16 (SOlsl a) :: k).
+
+(** Extended right shift *)
+
+Definition shrx32 (rd r1: ireg) (n: int) (k: code) : code :=
+ if Int.eq n Int.zero then
+ Pmov rd r1 :: k
+ else if Int.eq n Int.one then
+ Padd W X16 r1 r1 (SOlsr (Int.repr 31)) ::
+ Porr W rd XZR X16 (SOasr n) :: k
+ else
+ Porr W X16 XZR r1 (SOasr (Int.repr 31)) ::
+ Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) ::
+ Porr W rd XZR X16 (SOasr n) :: k.
+
+Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code :=
+ if Int.eq n Int.zero then
+ Pmov rd r1 :: k
+ else if Int.eq n Int.one then
+ Padd X X16 r1 r1 (SOlsr (Int.repr 63)) ::
+ Porr X rd XZR X16 (SOasr n) :: k
+ else
+ Porr X X16 XZR r1 (SOasr (Int.repr 63)) ::
+ Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) ::
+ Porr X rd XZR X16 (SOasr n) :: k.
+
+(** Load the address [id + ofs] in [rd] *)
+
+Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: code) : code :=
+ if Archi.pic_code tt then
+ if Ptrofs.eq ofs Ptrofs.zero then
+ Ploadsymbol rd id :: k
+ else
+ Ploadsymbol rd id :: addimm64 rd rd (Ptrofs.to_int64 ofs) k
+ else
+ Padrp rd id ofs :: Paddadr rd rd id ofs :: k.
+
+(** Translate a shifted operand *)
+
+Definition transl_shift (s: Op.shift) (a: int): Asm.shift_op :=
+ match s with
+ | Slsl => SOlsl a
+ | Slsr => SOlsr a
+ | Sasr => SOasr a
+ | Sror => SOror a
+ end.
+
+(** Translation of a condition. Prepends to [k] the instructions
+ that evaluate the condition and leave its boolean result in one of
+ the bits of the condition register. The bit in question is
+ determined by the [crbit_for_cond] function. *)
+
+Definition transl_cond
+ (cond: condition) (args: list mreg) (k: code) :=
+ match cond, args with
+ | (Ccomp c | Ccompu c), a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp W r1 r2 SOnone :: k)
+ | (Ccompshift c s a | Ccompushift c s a), a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp W r1 r2 (transl_shift s a) :: k)
+ | (Ccompimm c n | Ccompuimm c n), a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if is_arith_imm32 n then
+ Pcmpimm W r1 (Int.unsigned n) :: k
+ else if is_arith_imm32 (Int.neg n) then
+ Pcmnimm W r1 (Int.unsigned (Int.neg n)) :: k
+ else
+ loadimm32 X16 n (Pcmp W r1 X16 SOnone :: k))
+ | (Cmaskzero n | Cmasknotzero n), a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if is_logical_imm32 n then
+ Ptstimm W r1 (Int.unsigned n) :: k
+ else
+ loadimm32 X16 n (Ptst W r1 X16 SOnone :: k))
+ | (Ccompl c | Ccomplu c), a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp X r1 r2 SOnone :: k)
+ | (Ccomplshift c s a | Ccomplushift c s a), a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pcmp X r1 r2 (transl_shift s a) :: k)
+ | (Ccomplimm c n | Ccompluimm c n), a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if is_arith_imm64 n then
+ Pcmpimm X r1 (Int64.unsigned n) :: k
+ else if is_arith_imm64 (Int64.neg n) then
+ Pcmnimm X r1 (Int64.unsigned (Int64.neg n)) :: k
+ else
+ loadimm64 X16 n (Pcmp X r1 X16 SOnone :: k))
+ | (Cmasklzero n | Cmasklnotzero n), a1 :: nil =>
+ do r1 <- ireg_of a1;
+ OK (if is_logical_imm64 n then
+ Ptstimm X r1 (Int64.unsigned n) :: k
+ else
+ loadimm64 X16 n (Ptst X r1 X16 SOnone :: k))
+ | Ccompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmp D r1 r2 :: k)
+ | Cnotcompf cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmp D r1 r2 :: k)
+ | Ccompfzero cmp, a1 :: nil =>
+ do r1 <- freg_of a1;
+ OK (Pfcmp0 D r1 :: k)
+ | Cnotcompfzero cmp, a1 :: nil =>
+ do r1 <- freg_of a1;
+ OK (Pfcmp0 D r1 :: k)
+ | Ccompfs cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmp S r1 r2 :: k)
+ | Cnotcompfs cmp, a1 :: a2 :: nil =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ OK (Pfcmp S r1 r2 :: k)
+ | Ccompfszero cmp, a1 :: nil =>
+ do r1 <- freg_of a1;
+ OK (Pfcmp0 S r1 :: k)
+ | Cnotcompfszero cmp, a1 :: nil =>
+ do r1 <- freg_of a1;
+ OK (Pfcmp0 S r1 :: k)
+ | _, _ =>
+ Error(msg "Asmgen.transl_cond")
+ end.
+
+Definition cond_for_signed_cmp (cmp: comparison) :=
+ match cmp with
+ | Ceq => TCeq
+ | Cne => TCne
+ | Clt => TClt
+ | Cle => TCle
+ | Cgt => TCgt
+ | Cge => TCge
+ end.
+
+Definition cond_for_unsigned_cmp (cmp: comparison) :=
+ match cmp with
+ | Ceq => TCeq
+ | Cne => TCne
+ | Clt => TClo
+ | Cle => TCls
+ | Cgt => TChi
+ | Cge => TChs
+ end.
+
+Definition cond_for_float_cmp (cmp: comparison) :=
+ match cmp with
+ | Ceq => TCeq
+ | Cne => TCne
+ | Clt => TCmi
+ | Cle => TCls
+ | Cgt => TCgt
+ | Cge => TCge
+ end.
+
+Definition cond_for_float_not_cmp (cmp: comparison) :=
+ match cmp with
+ | Ceq => TCne
+ | Cne => TCeq
+ | Clt => TCpl
+ | Cle => TChi
+ | Cgt => TCle
+ | Cge => TClt
+ end.
+
+Definition cond_for_cond (cond: condition) :=
+ match cond with
+ | Ccomp cmp => cond_for_signed_cmp cmp
+ | Ccompu cmp => cond_for_unsigned_cmp cmp
+ | Ccompshift cmp s a => cond_for_signed_cmp cmp
+ | Ccompushift cmp s a => cond_for_unsigned_cmp cmp
+ | Ccompimm cmp n => cond_for_signed_cmp cmp
+ | Ccompuimm cmp n => cond_for_unsigned_cmp cmp
+ | Cmaskzero n => TCeq
+ | Cmasknotzero n => TCne
+ | Ccompl cmp => cond_for_signed_cmp cmp
+ | Ccomplu cmp => cond_for_unsigned_cmp cmp
+ | Ccomplshift cmp s a => cond_for_signed_cmp cmp
+ | Ccomplushift cmp s a => cond_for_unsigned_cmp cmp
+ | Ccomplimm cmp n => cond_for_signed_cmp cmp
+ | Ccompluimm cmp n => cond_for_unsigned_cmp cmp
+ | Cmasklzero n => TCeq
+ | Cmasklnotzero n => TCne
+ | Ccompf cmp => cond_for_float_cmp cmp
+ | Cnotcompf cmp => cond_for_float_not_cmp cmp
+ | Ccompfzero cmp => cond_for_float_cmp cmp
+ | Cnotcompfzero cmp => cond_for_float_not_cmp cmp
+ | Ccompfs cmp => cond_for_float_cmp cmp
+ | Cnotcompfs cmp => cond_for_float_not_cmp cmp
+ | Ccompfszero cmp => cond_for_float_cmp cmp
+ | Cnotcompfszero cmp => cond_for_float_not_cmp cmp
+ end.
+
+(** Translation of a conditional branch. Prepends to [k] the instructions
+ that evaluate the condition and ranch to [lbl] if it holds.
+ We recognize some conditional branches that can be implemented
+ without setting then testing condition flags. *)
+
+Definition transl_cond_branch_default
+ (c: condition) (args: list mreg) (lbl: label) (k: code) :=
+ transl_cond c args (Pbc (cond_for_cond c) lbl :: k).
+
+Definition transl_cond_branch
+ (c: condition) (args: list mreg) (lbl: label) (k: code) :=
+ match args, c with
+ | a1 :: nil, (Ccompimm Cne n | Ccompuimm Cne n) =>
+ if Int.eq n Int.zero
+ then (do r1 <- ireg_of a1; OK (Pcbnz W r1 lbl :: k))
+ else transl_cond_branch_default c args lbl k
+ | a1 :: nil, (Ccompimm Ceq n | Ccompuimm Ceq n) =>
+ if Int.eq n Int.zero
+ then (do r1 <- ireg_of a1; OK (Pcbz W r1 lbl :: k))
+ else transl_cond_branch_default c args lbl k
+ | a1 :: nil, (Ccomplimm Cne n | Ccompluimm Cne n) =>
+ if Int64.eq n Int64.zero
+ then (do r1 <- ireg_of a1; OK (Pcbnz X r1 lbl :: k))
+ else transl_cond_branch_default c args lbl k
+ | a1 :: nil, (Ccomplimm Ceq n | Ccompluimm Ceq n) =>
+ if Int64.eq n Int64.zero
+ then (do r1 <- ireg_of a1; OK (Pcbz X r1 lbl :: k))
+ else transl_cond_branch_default c args lbl k
+ | a1 :: nil, Cmaskzero n =>
+ match Int.is_power2 n with
+ | Some bit => do r1 <- ireg_of a1; OK (Ptbz W r1 bit lbl :: k)
+ | None => transl_cond_branch_default c args lbl k
+ end
+ | a1 :: nil, Cmasknotzero n =>
+ match Int.is_power2 n with
+ | Some bit => do r1 <- ireg_of a1; OK (Ptbnz W r1 bit lbl :: k)
+ | None => transl_cond_branch_default c args lbl k
+ end
+ | a1 :: nil, Cmasklzero n =>
+ match Int64.is_power2' n with
+ | Some bit => do r1 <- ireg_of a1; OK (Ptbz X r1 bit lbl :: k)
+ | None => transl_cond_branch_default c args lbl k
+ end
+ | a1 :: nil, Cmasklnotzero n =>
+ match Int64.is_power2' n with
+ | Some bit => do r1 <- ireg_of a1; OK (Ptbnz X r1 bit lbl :: k)
+ | None => transl_cond_branch_default c args lbl k
+ end
+ | _, _ =>
+ transl_cond_branch_default c args lbl k
+ end.
+
+(** Translation of the arithmetic operation [res <- op(args)].
+ The corresponding instructions are prepended to [k]. *)
+
+Definition transl_op
+ (op: operation) (args: list mreg) (res: mreg) (k: code) :=
+ match op, args with
+ | Omove, a1 :: nil =>
+ match preg_of res, preg_of a1 with
+ | IR r, IR a => OK (Pmov r a :: k)
+ | FR r, FR a => OK (Pfmov r a :: k)
+ | _ , _ => Error(msg "Asmgen.Omove")
+ end
+ | Ointconst n, nil =>
+ do rd <- ireg_of res;
+ OK (loadimm32 rd n k)
+ | Olongconst n, nil =>
+ do rd <- ireg_of res;
+ OK (loadimm64 rd n k)
+ | Ofloatconst f, nil =>
+ do rd <- freg_of res;
+ OK (if Float.eq_dec f Float.zero
+ then Pfmovi D rd XZR :: k
+ else Pfmovimmd rd f :: k)
+ | Osingleconst f, nil =>
+ do rd <- freg_of res;
+ OK (if Float32.eq_dec f Float32.zero
+ then Pfmovi S rd XZR :: k
+ else Pfmovimms rd f :: k)
+ | Oaddrsymbol id ofs, nil =>
+ do rd <- ireg_of res;
+ OK (loadsymbol rd id ofs k)
+ | Oaddrstack ofs, nil =>
+ do rd <- ireg_of res;
+ OK (addimm64 rd XSP (Ptrofs.to_int64 ofs) k)
+(** 32-bit integer arithmetic *)
+ | Oshift s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porr W rd XZR r1 (transl_shift s a) :: k)
+ | Oadd, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd W rd r1 r2 SOnone :: k)
+ | Oaddshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd W rd r1 r2 (transl_shift s a) :: k)
+ | Oaddimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (addimm32 rd r1 n k)
+ | Oneg, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psub W rd XZR r1 SOnone :: k)
+ | Onegshift s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psub W rd XZR r1 (transl_shift s a) :: k)
+ | Osub, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub W rd r1 r2 SOnone :: k)
+ | Osubshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub W rd r1 r2 (transl_shift s a) :: k)
+ | Omul, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pmadd W rd r1 r2 XZR :: k)
+ | Omuladd, a1 :: a2 :: a3 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
+ OK (Pmadd W rd r2 r3 r1 :: k)
+ | Omulsub, a1 :: a2 :: a3 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
+ OK (Pmsub W rd r2 r3 r1 :: k)
+ | Odiv, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psdiv W rd r1 r2 :: k)
+ | Odivu, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pudiv W rd r1 r2 :: k)
+ | Oand, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand W rd r1 r2 SOnone :: k)
+ | Oandshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand W rd r1 r2 (transl_shift s a) :: k)
+ | Oandimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm32 (Pandimm W) (Pand W) rd r1 n k)
+ | Oor, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr W rd r1 r2 SOnone :: k)
+ | Oorshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr W rd r1 r2 (transl_shift s a) :: k)
+ | Oorimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm32 (Porrimm W) (Porr W) rd r1 n k)
+ | Oxor, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor W rd r1 r2 SOnone :: k)
+ | Oxorshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor W rd r1 r2 (transl_shift s a) :: k)
+ | Oxorimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm32 (Peorimm W) (Peor W) rd r1 n k)
+ | Onot, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porn W rd XZR r1 SOnone :: k)
+ | Onotshift s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porn W rd XZR r1 (transl_shift s a) :: k)
+ | Obic, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic W rd r1 r2 SOnone :: k)
+ | Obicshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic W rd r1 r2 (transl_shift s a) :: k)
+ | Oorn, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porn W rd r1 r2 SOnone :: k)
+ | Oornshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porn W rd r1 r2 (transl_shift s a) :: k)
+ | Oeqv, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peon W rd r1 r2 SOnone :: k)
+ | Oeqvshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peon W rd r1 r2 (transl_shift s a) :: k)
+ | Oshl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Plslv W rd r1 r2 :: k)
+ | Oshr, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pasrv W rd r1 r2 :: k)
+ | Oshru, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Plsrv W rd r1 r2 :: k)
+ | Oshrximm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (shrx32 rd r1 n k)
+ | Ozext s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfiz W rd r1 Int.zero s :: k)
+ | Osext s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfiz W rd r1 Int.zero s :: k)
+ | Oshlzext s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
+ | Oshlsext s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
+ | Ozextshr a s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
+ | Osextshr a s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
+(** 64-bit integer arithmetic *)
+ | Oshiftl s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porr X rd XZR r1 (transl_shift s a) :: k)
+ | Oextend x a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (move_extended rd r1 x a k)
+ (* [Omakelong] and [Ohighlong] should not occur *)
+ | Olowlong, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ assertion (ireg_eq rd r1);
+ OK (Pcvtx2w rd :: k)
+ | Oaddl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd X rd r1 r2 SOnone :: k)
+ | Oaddlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Padd X rd r1 r2 (transl_shift s a) :: k)
+ | Oaddlext x a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (arith_extended Paddext (Padd X) rd r1 r2 x a k)
+ | Oaddlimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (addimm64 rd r1 n k)
+ | Onegl, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psub X rd XZR r1 SOnone :: k)
+ | Oneglshift s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psub X rd XZR r1 (transl_shift s a) :: k)
+ | Osubl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub X rd r1 r2 SOnone :: k)
+ | Osublshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psub X rd r1 r2 (transl_shift s a) :: k)
+ | Osublext x a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (arith_extended Psubext (Psub X) rd r1 r2 x a k)
+ | Omull, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pmadd X rd r1 r2 XZR :: k)
+ | Omulladd, a1 :: a2 :: a3 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
+ OK (Pmadd X rd r2 r3 r1 :: k)
+ | Omullsub, a1 :: a2 :: a3 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
+ OK (Pmsub X rd r2 r3 r1 :: k)
+ | Omullhs, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psmulh rd r1 r2 :: k)
+ | Omullhu, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pumulh rd r1 r2 :: k)
+ | Odivl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Psdiv X rd r1 r2 :: k)
+ | Odivlu, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pudiv X rd r1 r2 :: k)
+ | Oandl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand X rd r1 r2 SOnone :: k)
+ | Oandlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pand X rd r1 r2 (transl_shift s a) :: k)
+ | Oandlimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm64 (Pandimm X) (Pand X) rd r1 n k)
+ | Oorl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr X rd r1 r2 SOnone :: k)
+ | Oorlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porr X rd r1 r2 (transl_shift s a) :: k)
+ | Oorlimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm64 (Porrimm X) (Porr X) rd r1 n k)
+ | Oxorl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor X rd r1 r2 SOnone :: k)
+ | Oxorlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peor X rd r1 r2 (transl_shift s a) :: k)
+ | Oxorlimm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (logicalimm64 (Peorimm X) (Peor X) rd r1 n k)
+ | Onotl, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porn X rd XZR r1 SOnone :: k)
+ | Onotlshift s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Porn X rd XZR r1 (transl_shift s a) :: k)
+ | Obicl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic X rd r1 r2 SOnone :: k)
+ | Obiclshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pbic X rd r1 r2 (transl_shift s a) :: k)
+ | Oornl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porn X rd r1 r2 SOnone :: k)
+ | Oornlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Porn X rd r1 r2 (transl_shift s a) :: k)
+ | Oeqvl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peon X rd r1 r2 SOnone :: k)
+ | Oeqvlshift s a, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Peon X rd r1 r2 (transl_shift s a) :: k)
+ | Oshll, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Plslv X rd r1 r2 :: k)
+ | Oshrl, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Pasrv X rd r1 r2 :: k)
+ | Oshrlu, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (Plsrv X rd r1 r2 :: k)
+ | Oshrlximm n, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (shrx64 rd r1 n k)
+ | Ozextl s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfiz X rd r1 Int.zero s :: k)
+ | Osextl s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfiz X rd r1 Int.zero s :: k)
+ | Oshllzext s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
+ | Oshllsext s a, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
+ | Ozextshrl a s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Pubfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
+ | Osextshrl a s, a1 :: nil =>
+ do rd <- ireg_of res; do r1 <- ireg_of a1;
+ OK (Psbfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
+(** 64-bit floating-point arithmetic *)
+ | Onegf, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfneg D rd rs :: k)
+ | Oabsf, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfabs D rd rs :: k)
+ | Oaddf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfadd D rd rs1 rs2 :: k)
+ | Osubf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfsub D rd rs1 rs2 :: k)
+ | Omulf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfmul D rd rs1 rs2 :: k)
+ | Odivf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfdiv D rd rs1 rs2 :: k)
+(** 32-bit floating-point arithmetic *)
+ | Onegfs, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfneg S rd rs :: k)
+ | Oabsfs, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfabs S rd rs :: k)
+ | Oaddfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfadd S rd rs1 rs2 :: k)
+ | Osubfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfsub S rd rs1 rs2 :: k)
+ | Omulfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfmul S rd rs1 rs2 :: k)
+ | Odivfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfdiv S rd rs1 rs2 :: k)
+ | Osingleoffloat, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfcvtsd rd rs :: k)
+ | Ofloatofsingle, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfcvtds rd rs :: k)
+(** Conversions between int and float *)
+ | Ointoffloat, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzs W D rd rs :: k)
+ | Ointuoffloat, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzu W D rd rs :: k)
+ | Ofloatofint, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pscvtf D W rd rs :: k)
+ | Ofloatofintu, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pucvtf D W rd rs :: k)
+ | Ointofsingle, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzs W S rd rs :: k)
+ | Ointuofsingle, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzu W S rd rs :: k)
+ | Osingleofint, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pscvtf S W rd rs :: k)
+ | Osingleofintu, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pucvtf S W rd rs :: k)
+ | Olongoffloat, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzs X D rd rs :: k)
+ | Olonguoffloat, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzu X D rd rs :: k)
+ | Ofloatoflong, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pscvtf D X rd rs :: k)
+ | Ofloatoflongu, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pucvtf D X rd rs :: k)
+ | Olongofsingle, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzs X S rd rs :: k)
+ | Olonguofsingle, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- freg_of a1;
+ OK (Pfcvtzu X S rd rs :: k)
+ | Osingleoflong, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pscvtf S X rd rs :: k)
+ | Osingleoflongu, a1 :: nil =>
+ do rd <- freg_of res; do rs <- ireg_of a1;
+ OK (Pucvtf S X rd rs :: k)
+(** Boolean tests *)
+ | Ocmp c, _ =>
+ do rd <- ireg_of res;
+ transl_cond c args (Pcset rd (cond_for_cond c) :: k)
+(** Conditional move *)
+ | Osel cmp ty, a1 :: a2 :: args =>
+ match preg_of res with
+ | IR r =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) :: k)
+ | FR r =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ transl_cond cmp args (Pfsel r r1 r2 (cond_for_cond cmp) :: k)
+ | _ =>
+ Error(msg "Asmgen.Osel")
+ end
+ | _, _ =>
+ Error(msg "Asmgen.transl_op")
+ end.
+
+(** Translation of addressing modes *)
+
+Definition offset_representable (sz: Z) (ofs: int64) : bool :=
+ let isz := Int64.repr sz in
+ (** either unscaled 9-bit signed *)
+ Int64.eq ofs (Int64.sign_ext 9 ofs) ||
+ (** or scaled 12-bit unsigned *)
+ (Int64.eq (Int64.modu ofs isz) Int64.zero
+ && Int64.ltu ofs (Int64.shl isz (Int64.repr 12))).
+
+Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg)
+ (insn: Asm.addressing -> instruction) (k: code) : res code :=
+ match addr, args with
+ | Aindexed ofs, a1 :: nil =>
+ do r1 <- ireg_of a1;
+ if offset_representable sz ofs then
+ OK (insn (ADimm r1 ofs) :: k)
+ else
+ OK (loadimm64 X16 ofs (insn (ADreg r1 X16) :: k))
+ | Aindexed2, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ OK (insn (ADreg r1 r2) :: k)
+ | Aindexed2shift a, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ if Int.eq a Int.zero then
+ OK (insn (ADreg r1 r2) :: k)
+ else if Int.eq (Int.shl Int.one a) (Int.repr sz) then
+ OK (insn (ADlsl r1 r2 a) :: k)
+ else
+ OK (Padd X X16 r1 r2 (SOlsl a) :: insn (ADimm X16 Int64.zero) :: k)
+ | Aindexed2ext x a, a1 :: a2 :: nil =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ if Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz) then
+ OK (insn (match x with Xsgn32 => ADsxt r1 r2 a
+ | Xuns32 => ADuxt r1 r2 a end) :: k)
+ else
+ OK (arith_extended Paddext (Padd X) X16 r1 r2 x a
+ (insn (ADimm X16 Int64.zero) :: k))
+ | Aglobal id ofs, nil =>
+ assertion (negb (Archi.pic_code tt));
+ if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz
+ then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k)
+ else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k))
+ | Ainstack ofs, nil =>
+ let ofs := Ptrofs.to_int64 ofs in
+ if offset_representable sz ofs then
+ OK (insn (ADimm XSP ofs) :: k)
+ else
+ OK (loadimm64 X16 ofs (insn (ADreg XSP X16) :: k))
+ | _, _ =>
+ Error(msg "Asmgen.transl_addressing")
+ end.
+
+(** Translation of loads and stores *)
+
+Definition transl_load (trap: trapping_mode)
+ (chunk: memory_chunk) (addr: Op.addressing)
+ (args: list mreg) (dst: mreg) (k: code) : res code :=
+ match trap with
+ | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on aarch64")
+ | TRAP =>
+ match chunk with
+ | Mint8unsigned =>
+ do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrb W rd) k
+ | Mint8signed =>
+ do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrsb W rd) k
+ | Mint16unsigned =>
+ do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrh W rd) k
+ | Mint16signed =>
+ do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrsh W rd) k
+ | Mint32 =>
+ do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw rd) k
+ | Mint64 =>
+ do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx rd) k
+ | Mfloat32 =>
+ do rd <- freg_of dst; transl_addressing 4 addr args (Pldrs rd) k
+ | Mfloat64 =>
+ do rd <- freg_of dst; transl_addressing 8 addr args (Pldrd rd) k
+ | Many32 =>
+ do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw_a rd) k
+ | Many64 =>
+ do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx_a rd) k
+ end
+ end.
+
+Definition transl_store (chunk: memory_chunk) (addr: Op.addressing)
+ (args: list mreg) (src: mreg) (k: code) : res code :=
+ match chunk with
+ | Mint8unsigned | Mint8signed =>
+ do r1 <- ireg_of src; transl_addressing 1 addr args (Pstrb r1) k
+ | Mint16unsigned | Mint16signed =>
+ do r1 <- ireg_of src; transl_addressing 2 addr args (Pstrh r1) k
+ | Mint32 =>
+ do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw r1) k
+ | Mint64 =>
+ do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx r1) k
+ | Mfloat32 =>
+ do r1 <- freg_of src; transl_addressing 4 addr args (Pstrs r1) k
+ | Mfloat64 =>
+ do r1 <- freg_of src; transl_addressing 8 addr args (Pstrd r1) k
+ | Many32 =>
+ do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw_a r1) k
+ | Many64 =>
+ do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx_a r1) k
+ end.
+
+(** Register-indexed loads and stores *)
+
+Definition indexed_memory_access (insn: Asm.addressing -> instruction)
+ (sz: Z) (base: iregsp) (ofs: ptrofs) (k: code) :=
+ let ofs := Ptrofs.to_int64 ofs in
+ if offset_representable sz ofs
+ then insn (ADimm base ofs) :: k
+ else loadimm64 X16 ofs (insn (ADreg base X16) :: k).
+
+Definition loadind (base: iregsp) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) :=
+ match ty, preg_of dst with
+ | Tint, IR rd => OK (indexed_memory_access (Pldrw rd) 4 base ofs k)
+ | Tlong, IR rd => OK (indexed_memory_access (Pldrx rd) 8 base ofs k)
+ | Tsingle, FR rd => OK (indexed_memory_access (Pldrs rd) 4 base ofs k)
+ | Tfloat, FR rd => OK (indexed_memory_access (Pldrd rd) 8 base ofs k)
+ | Tany32, IR rd => OK (indexed_memory_access (Pldrw_a rd) 4 base ofs k)
+ | Tany64, IR rd => OK (indexed_memory_access (Pldrx_a rd) 8 base ofs k)
+ | Tany64, FR rd => OK (indexed_memory_access (Pldrd_a rd) 8 base ofs k)
+ | _, _ => Error (msg "Asmgen.loadind")
+ end.
+
+Definition storeind (src: mreg) (base: iregsp) (ofs: ptrofs) (ty: typ) (k: code) :=
+ match ty, preg_of src with
+ | Tint, IR rd => OK (indexed_memory_access (Pstrw rd) 4 base ofs k)
+ | Tlong, IR rd => OK (indexed_memory_access (Pstrx rd) 8 base ofs k)
+ | Tsingle, FR rd => OK (indexed_memory_access (Pstrs rd) 4 base ofs k)
+ | Tfloat, FR rd => OK (indexed_memory_access (Pstrd rd) 8 base ofs k)
+ | Tany32, IR rd => OK (indexed_memory_access (Pstrw_a rd) 4 base ofs k)
+ | Tany64, IR rd => OK (indexed_memory_access (Pstrx_a rd) 8 base ofs k)
+ | Tany64, FR rd => OK (indexed_memory_access (Pstrd_a rd) 8 base ofs k)
+ | _, _ => Error (msg "Asmgen.storeind")
+ end.
+
+Definition loadptr (base: iregsp) (ofs: ptrofs) (dst: ireg) (k: code) :=
+ indexed_memory_access (Pldrx dst) 8 base ofs k.
+
+Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) :=
+ indexed_memory_access (Pstrx src) 8 base ofs k.
+
+(** Function epilogue *)
+
+Definition make_epilogue (f: Mach.function) (k: code) :=
+ (* FIXME
+ Cannot be used because memcpy destroys X30;
+ issue being discussed with X. Leroy *)
+ (* if is_leaf_function f
+ then Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k
+ else*) loadptr XSP f.(fn_retaddr_ofs) RA
+ (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k).
+
+(** Translation of a Mach instruction. *)
+
+Definition transl_instr (f: Mach.function) (i: Mach.instruction)
+ (r29_is_parent: bool) (k: code) : res code :=
+ match i with
+ | Mgetstack ofs ty dst =>
+ loadind XSP ofs ty dst k
+ | Msetstack src ofs ty =>
+ storeind src XSP ofs ty k
+ | Mgetparam ofs ty dst =>
+ (* load via the frame pointer if it is valid *)
+ do c <- loadind X29 ofs ty dst k;
+ OK (if r29_is_parent then c else loadptr XSP f.(fn_link_ofs) X29 c)
+ | Mop op args res =>
+ transl_op op args res k
+ | Mload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
+ | Mstore chunk addr args src =>
+ transl_store chunk addr args src k
+ | Mcall sig (inl r) =>
+ do r1 <- ireg_of r; OK (Pblr r1 sig :: k)
+ | Mcall sig (inr symb) =>
+ OK (Pbl symb sig :: k)
+ | Mtailcall sig (inl r) =>
+ do r1 <- ireg_of r;
+ OK (make_epilogue f (Pbr r1 sig :: k))
+ | Mtailcall sig (inr symb) =>
+ OK (make_epilogue f (Pbs symb sig :: k))
+ | Mbuiltin ef args res =>
+ OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k)
+ | Mlabel lbl =>
+ OK (Plabel lbl :: k)
+ | Mgoto lbl =>
+ OK (Pb lbl :: k)
+ | Mcond cond args lbl =>
+ transl_cond_branch cond args lbl k
+ | Mjumptable arg tbl =>
+ do r <- ireg_of arg;
+ OK (Pbtbl r tbl :: k)
+ | Mreturn =>
+ OK (make_epilogue f (Pret RA :: k))
+ end.
+
+(** Translation of a code sequence *)
+
+Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
+ match i with
+ | Msetstack src ofs ty => before
+ | Mgetparam ofs ty dst => negb (mreg_eq dst R29)
+ | Mop op args res => before && negb (mreg_eq res R29)
+ | _ => false
+ end.
+
+(** This is the naive definition that we no longer use because it
+ is not tail-recursive. It is kept as specification. *)
+
+Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
+ match il with
+ | nil => OK nil
+ | i1 :: il' =>
+ do k <- transl_code f il' (it1_is_parent it1p i1);
+ transl_instr f i1 it1p k
+ end.
+
+(** This is an equivalent definition in continuation-passing style
+ that runs in constant stack space. *)
+
+Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
+ (it1p: bool) (k: code -> res code) :=
+ match il with
+ | nil => k nil
+ | i1 :: il' =>
+ transl_code_rec f il' (it1_is_parent it1p i1)
+ (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2)
+ end.
+
+Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
+ transl_code_rec f il it1p (fun c => OK c).
+
+(** Translation of a whole function. Note that we must check
+ that the generated code contains less than [2^32] instructions,
+ otherwise the offset part of the [PC] code pointer could wrap
+ around, leading to incorrect executions. *)
+
+Definition transl_function (f: Mach.function) :=
+ do c <- transl_code' f f.(Mach.fn_code) true;
+ OK (mkfunction f.(Mach.fn_sig)
+ (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
+ storeptr RA XSP f.(fn_retaddr_ofs) c)).
+
+Definition transf_function (f: Mach.function) : res Asm.function :=
+ do tf <- transl_function f;
+ if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code))
+ then Error (msg "code size exceeded")
+ else OK tf.
+
+Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
+ transf_partial_fundef transf_function f.
+
+Definition transf_program (p: Mach.program) : res Asm.program :=
+ transform_partial_program transf_fundef p.
diff --git a/aarch64/Asmgenproof.v b/aarch64/Asmgenproof.v
new file mode 100644
index 00000000..6831509f
--- /dev/null
+++ b/aarch64/Asmgenproof.v
@@ -0,0 +1,1101 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for AArch64 code generation. *)
+
+Require Import Coqlib Errors.
+Require Import Integers Floats AST Linking.
+Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Op Locations Mach Conventions Asm.
+Require Import Asmgen Asmgenproof0 Asmgenproof1.
+
+Definition match_prog (p: Mach.program) (tp: Asm.program) :=
+ match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = OK tp -> match_prog p tp.
+Proof.
+ intros. eapply match_transform_partial_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Mach.program.
+Variable tprog: Asm.program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+Lemma functions_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial TRANSF).
+
+Lemma functions_transl:
+ forall fb f tf,
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge fb = Some (Internal tf).
+Proof.
+ intros. exploit functions_translated; eauto. intros [tf' [A B]].
+ monadInv B. rewrite H0 in EQ; inv EQ; auto.
+Qed.
+
+(** * Properties of control flow *)
+
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> list_length_z tf.(fn_code) <= Ptrofs.max_unsigned.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0.
+ omega.
+Qed.
+
+Lemma exec_straight_exec:
+ forall fb f c ep tf tc c' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ exec_straight tge tf tc rs m c' rs' m' ->
+ plus step tge (State rs m) E0 (State rs' m').
+Proof.
+ intros. inv H.
+ eapply exec_straight_steps_1; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+Qed.
+
+Lemma exec_straight_at:
+ forall fb f c ep tf tc c' ep' tc' rs m rs' m',
+ transl_code_at_pc ge (rs PC) fb f c ep tf tc ->
+ transl_code f c' ep' = OK tc' ->
+ exec_straight tge tf tc rs m tc' rs' m' ->
+ transl_code_at_pc ge (rs' PC) fb f c' ep' tf tc'.
+Proof.
+ intros. inv H.
+ exploit exec_straight_steps_2; eauto.
+ eapply transf_function_no_overflow; eauto.
+ eapply functions_transl; eauto.
+ intros [ofs' [PC' CT']].
+ rewrite PC'. constructor; auto.
+Qed.
+
+(** The following lemmas show that the translation from Mach to Asm
+ preserves labels, in the sense that the following diagram commutes:
+<<
+ translation
+ Mach code ------------------------ Asm instr sequence
+ | |
+ | Mach.find_label lbl find_label lbl |
+ | |
+ v v
+ Mach code tail ------------------- Asm instr seq tail
+ translation
+>>
+ The proof demands many boring lemmas showing that Asm constructor
+ functions do not introduce new labels.
+*)
+
+Section TRANSL_LABEL.
+
+Remark loadimm_z_label: forall sz rd l k, tail_nolabel k (loadimm_z sz rd l k).
+Proof.
+ intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel.
+ induction l as [ | [n p] l]; simpl; TailNoLabel.
+Qed.
+
+Remark loadimm_n_label: forall sz rd l k, tail_nolabel k (loadimm_n sz rd l k).
+Proof.
+ intros; destruct l as [ | [n1 p1] l]; simpl; TailNoLabel.
+ induction l as [ | [n p] l]; simpl; TailNoLabel.
+Qed.
+
+Remark loadimm_label: forall sz rd n k, tail_nolabel k (loadimm sz rd n k).
+Proof.
+ unfold loadimm; intros. destruct Nat.leb; [apply loadimm_z_label|apply loadimm_n_label].
+Qed.
+Hint Resolve loadimm_label: labels.
+
+Remark loadimm32_label: forall r n k, tail_nolabel k (loadimm32 r n k).
+Proof.
+ unfold loadimm32; intros. destruct (is_logical_imm32 n); TailNoLabel.
+Qed.
+Hint Resolve loadimm32_label: labels.
+
+Remark loadimm64_label: forall r n k, tail_nolabel k (loadimm64 r n k).
+Proof.
+ unfold loadimm64; intros. destruct (is_logical_imm64 n); TailNoLabel.
+Qed.
+Hint Resolve loadimm64_label: labels.
+
+Remark addimm_aux: forall insn rd r1 n k,
+ (forall rd r1 n, nolabel (insn rd r1 n)) ->
+ tail_nolabel k (addimm_aux insn rd r1 n k).
+Proof.
+ unfold addimm_aux; intros.
+ destruct Z.eqb. TailNoLabel. destruct Z.eqb; TailNoLabel.
+Qed.
+
+Remark addimm32_label: forall rd r1 n k, tail_nolabel k (addimm32 rd r1 n k).
+Proof.
+ unfold addimm32; intros.
+ destruct Int.eq. apply addimm_aux; intros; red; auto.
+ destruct Int.eq. apply addimm_aux; intros; red; auto.
+ destruct Int.lt; eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+Hint Resolve addimm32_label: labels.
+
+Remark addimm64_label: forall rd r1 n k, tail_nolabel k (addimm64 rd r1 n k).
+Proof.
+ unfold addimm64; intros.
+ destruct Int64.eq. apply addimm_aux; intros; red; auto.
+ destruct Int64.eq. apply addimm_aux; intros; red; auto.
+ destruct Int64.lt; eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+Hint Resolve addimm64_label: labels.
+
+Remark logicalimm32_label: forall insn1 insn2 rd r1 n k,
+ (forall rd r1 n, nolabel (insn1 rd r1 n)) ->
+ (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) ->
+ tail_nolabel k (logicalimm32 insn1 insn2 rd r1 n k).
+Proof.
+ unfold logicalimm32; intros.
+ destruct (is_logical_imm32 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+
+Remark logicalimm64_label: forall insn1 insn2 rd r1 n k,
+ (forall rd r1 n, nolabel (insn1 rd r1 n)) ->
+ (forall rd r1 r2 s, nolabel (insn2 rd r1 r2 s)) ->
+ tail_nolabel k (logicalimm64 insn1 insn2 rd r1 n k).
+Proof.
+ unfold logicalimm64; intros.
+ destruct (is_logical_imm64 n). TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+
+Remark move_extended_label: forall rd r1 ex a k, tail_nolabel k (move_extended rd r1 ex a k).
+Proof.
+ unfold move_extended, move_extended_base; intros. destruct Int.eq, ex; TailNoLabel.
+Qed.
+Hint Resolve move_extended_label: labels.
+
+Remark arith_extended_label: forall insnX insnS rd r1 r2 ex a k,
+ (forall rd r1 r2 x, nolabel (insnX rd r1 r2 x)) ->
+ (forall rd r1 r2 s, nolabel (insnS rd r1 r2 s)) ->
+ tail_nolabel k (arith_extended insnX insnS rd r1 r2 ex a k).
+Proof.
+ unfold arith_extended; intros. destruct Int.ltu.
+ TailNoLabel.
+ destruct ex; simpl; TailNoLabel.
+Qed.
+
+Remark loadsymbol_label: forall r id ofs k, tail_nolabel k (loadsymbol r id ofs k).
+Proof.
+ intros; unfold loadsymbol.
+ destruct (Archi.pic_code tt); TailNoLabel. destruct Ptrofs.eq; TailNoLabel.
+Qed.
+Hint Resolve loadsymbol_label: labels.
+
+Remark transl_cond_label: forall cond args k c,
+ transl_cond cond args k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_cond; intros; destruct cond; TailNoLabel.
+- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_arith_imm32; TailNoLabel. destruct is_arith_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_logical_imm32; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_arith_imm64; TailNoLabel. destruct is_arith_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+- destruct is_logical_imm64; TailNoLabel. eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+
+Remark transl_cond_branch_default_label: forall cond args lbl k c,
+ transl_cond_branch_default cond args lbl k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_cond_branch_default; intros.
+ eapply tail_nolabel_trans; [eapply transl_cond_label;eauto|TailNoLabel].
+Qed.
+Hint Resolve transl_cond_branch_default_label: labels.
+
+Remark transl_cond_branch_label: forall cond args lbl k c,
+ transl_cond_branch cond args lbl k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_cond_branch; intros; destruct args; TailNoLabel; destruct cond; TailNoLabel.
+- destruct c0; TailNoLabel.
+- destruct c0; TailNoLabel.
+- destruct (Int.is_power2 n); TailNoLabel.
+- destruct (Int.is_power2 n); TailNoLabel.
+- destruct c0; TailNoLabel.
+- destruct c0; TailNoLabel.
+- destruct (Int64.is_power2' n); TailNoLabel.
+- destruct (Int64.is_power2' n); TailNoLabel.
+Qed.
+
+Remark transl_op_label:
+ forall op args r k c,
+ transl_op op args r k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_op; intros; destruct op; TailNoLabel.
+- destruct (preg_of r); try discriminate; destruct (preg_of m); inv H; TailNoLabel.
+- destruct (Float.eq_dec n Float.zero); TailNoLabel.
+- destruct (Float32.eq_dec n Float32.zero); TailNoLabel.
+- apply logicalimm32_label; unfold nolabel; auto.
+- apply logicalimm32_label; unfold nolabel; auto.
+- apply logicalimm32_label; unfold nolabel; auto.
+- unfold shrx32. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel.
+- apply arith_extended_label; unfold nolabel; auto.
+- apply arith_extended_label; unfold nolabel; auto.
+- apply logicalimm64_label; unfold nolabel; auto.
+- apply logicalimm64_label; unfold nolabel; auto.
+- apply logicalimm64_label; unfold nolabel; auto.
+- unfold shrx64. destruct (Int.eq _ _); try destruct (Int.eq _ _); TailNoLabel.
+- eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel.
+- destruct (preg_of r); try discriminate; TailNoLabel;
+ (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto | TailNoLabel]).
+Qed.
+
+Remark transl_addressing_label:
+ forall sz addr args insn k c,
+ transl_addressing sz addr args insn k = OK c ->
+ (forall ad, nolabel (insn ad)) ->
+ tail_nolabel k c.
+Proof.
+ unfold transl_addressing; intros; destruct addr; TailNoLabel;
+ eapply tail_nolabel_trans; TailNoLabel.
+ eapply tail_nolabel_trans. apply arith_extended_label; unfold nolabel; auto. TailNoLabel.
+Qed.
+
+Remark transl_load_label:
+ forall trap chunk addr args dst k c,
+ transl_load trap chunk addr args dst k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_load; intros; destruct trap; try discriminate; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto.
+Qed.
+
+Remark transl_store_label:
+ forall chunk addr args src k c,
+ transl_store chunk addr args src k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_store; intros; destruct chunk; TailNoLabel; eapply transl_addressing_label; eauto; unfold nolabel; auto.
+Qed.
+
+Remark indexed_memory_access_label:
+ forall insn sz base ofs k,
+ (forall ad, nolabel (insn ad)) ->
+ tail_nolabel k (indexed_memory_access insn sz base ofs k).
+Proof.
+ unfold indexed_memory_access; intros. destruct offset_representable.
+ TailNoLabel.
+ eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+
+Remark loadind_label:
+ forall base ofs ty dst k c,
+ loadind base ofs ty dst k = OK c -> tail_nolabel k c.
+Proof.
+ unfold loadind; intros.
+ destruct ty, (preg_of dst); inv H; apply indexed_memory_access_label; intros; exact I.
+Qed.
+
+Remark storeind_label:
+ forall src base ofs ty k c,
+ storeind src base ofs ty k = OK c -> tail_nolabel k c.
+Proof.
+ unfold storeind; intros.
+ destruct ty, (preg_of src); inv H; apply indexed_memory_access_label; intros; exact I.
+Qed.
+
+Remark loadptr_label:
+ forall base ofs dst k, tail_nolabel k (loadptr base ofs dst k).
+Proof.
+ intros. apply indexed_memory_access_label. unfold nolabel; auto.
+Qed.
+
+Remark storeptr_label:
+ forall src base ofs k, tail_nolabel k (storeptr src base ofs k).
+Proof.
+ intros. apply indexed_memory_access_label. unfold nolabel; auto.
+Qed.
+
+Remark make_epilogue_label:
+ forall f k, tail_nolabel k (make_epilogue f k).
+Proof.
+ unfold make_epilogue; intros.
+ (* FIXME destruct is_leaf_function.
+ { TailNoLabel. } *)
+ eapply tail_nolabel_trans.
+ apply loadptr_label.
+ TailNoLabel.
+Qed.
+
+Lemma transl_instr_label:
+ forall f i ep k c,
+ transl_instr f i ep k = OK c ->
+ match i with Mlabel lbl => c = Plabel lbl :: k | _ => tail_nolabel k c end.
+Proof.
+ unfold transl_instr; intros; destruct i; TailNoLabel.
+- eapply loadind_label; eauto.
+- eapply storeind_label; eauto.
+- destruct ep. eapply loadind_label; eauto.
+ eapply tail_nolabel_trans. apply loadptr_label. eapply loadind_label; eauto.
+- eapply transl_op_label; eauto.
+- eapply transl_load_label; eauto.
+- eapply transl_store_label; eauto.
+- destruct s0; monadInv H; TailNoLabel.
+- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]).
+- eapply transl_cond_branch_label; eauto.
+- eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel].
+Qed.
+
+Lemma transl_instr_label':
+ forall lbl f i ep k c,
+ transl_instr f i ep k = OK c ->
+ find_label lbl c = if Mach.is_label lbl i then Some k else find_label lbl k.
+Proof.
+ intros. exploit transl_instr_label; eauto.
+ destruct i; try (intros [A B]; apply B).
+ intros. subst c. simpl. auto.
+Qed.
+
+Lemma transl_code_label:
+ forall lbl f c ep tc,
+ transl_code f c ep = OK tc ->
+ match Mach.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_code f c' false = OK tc'
+ end.
+Proof.
+ induction c; simpl; intros.
+ inv H. auto.
+ monadInv H. rewrite (transl_instr_label' lbl _ _ _ _ _ EQ0).
+ generalize (Mach.is_label_correct lbl a).
+ destruct (Mach.is_label lbl a); intros.
+ subst a. simpl in EQ. exists x; auto.
+ eapply IHc; eauto.
+Qed.
+
+Lemma transl_find_label:
+ forall lbl f tf,
+ transf_function f = OK tf ->
+ match Mach.find_label lbl f.(Mach.fn_code) with
+ | None => find_label lbl tf.(fn_code) = None
+ | Some c => exists tc, find_label lbl tf.(fn_code) = Some tc /\ transl_code f c false = OK tc
+ end.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0.
+ monadInv EQ. rewrite transl_code'_transl_code in EQ0. unfold fn_code.
+ simpl. destruct (storeptr_label X30 XSP (fn_retaddr_ofs f) x) as [A B]; rewrite B.
+ eapply transl_code_label; eauto.
+Qed.
+
+End TRANSL_LABEL.
+
+(** A valid branch in a piece of Mach code translates to a valid ``go to''
+ transition in the generated Asm code. *)
+
+Lemma find_label_goto_label:
+ forall f tf lbl rs m c' b ofs,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
+ rs PC = Vptr b ofs ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
+ /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros [tc [A B]].
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
+ split. unfold goto_label. rewrite P. rewrite H1. auto.
+ split. rewrite Pregmap.gss. constructor; auto.
+ rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
+ intros. apply Pregmap.gso; auto.
+Qed.
+
+(** Existence of return addresses *)
+
+Lemma return_address_exists:
+ forall f sg ros c, is_tail (Mcall sg ros :: c) f.(Mach.fn_code) ->
+ exists ra, return_address_offset f c ra.
+Proof.
+ intros. eapply Asmgenproof0.return_address_exists; eauto.
+- intros. exploit transl_instr_label; eauto.
+ destruct i; try (intros [A B]; apply A). intros. subst c0. repeat constructor.
+- intros. monadInv H0.
+ destruct (zlt Ptrofs.max_unsigned (list_length_z x.(fn_code))); inv EQ0. monadInv EQ.
+ rewrite transl_code'_transl_code in EQ0.
+ exists x; exists true; split; auto. unfold fn_code.
+ constructor. apply (storeptr_label X30 XSP (fn_retaddr_ofs f0) x).
+- exact transf_function_no_overflow.
+Qed.
+
+(** * Proof of semantic preservation *)
+
+(** Semantic preservation is proved using simulation diagrams
+ of the following form.
+<<
+ st1 --------------- st2
+ | |
+ t| *|t
+ | |
+ v v
+ st1'--------------- st2'
+>>
+ The invariant is the [match_states] predicate below, which includes:
+- The Asm code pointed by the PC register is the translation of
+ the current Mach code sequence.
+- Mach register values and Asm register values agree.
+*)
+
+Inductive match_states: Mach.state -> Asm.state -> Prop :=
+ | match_states_intro:
+ forall s fb sp c ep ms m m' rs f tf tc
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
+ (AG: agree ms sp rs)
+ (DXP: ep = true -> rs#X29 = parent_sp s)
+ (LEAF: is_leaf_function f = true -> rs#RA = parent_ra s),
+ match_states (Mach.State s fb sp c ms m)
+ (Asm.State rs m')
+ | match_states_call:
+ forall s fb ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = Vptr fb Ptrofs.zero)
+ (ATLR: rs RA = parent_ra s),
+ match_states (Mach.Callstate s fb ms m)
+ (Asm.State rs m')
+ | match_states_return:
+ forall s ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = parent_ra s),
+ match_states (Mach.Returnstate s ms m)
+ (Asm.State rs m').
+
+Lemma exec_straight_steps:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2,
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists rs2,
+ exec_straight tge tf c rs1 m1' k rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ (it1_is_parent ep i = true -> rs2#X29 = parent_sp s)
+ /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c ms2 m2) st'.
+Proof.
+ intros. inversion H2. subst. monadInv H7.
+ exploit H3; eauto. intros [rs2 [A [B [C D]]]].
+ exists (State rs2 m2'); split.
+ - eapply exec_straight_exec; eauto.
+ - econstructor; eauto. eapply exec_straight_at; eauto.
+Qed.
+
+Lemma exec_straight_steps_goto:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ it1_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2'
+ /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c' ms2 m2) st'.
+Proof.
+ intros. inversion H3. subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+ rewrite OTH by congruence; auto.
+Qed.
+
+Lemma exec_straight_opt_steps_goto:
+ forall s fb f rs1 i c ep tf tc m1' m2 m2' sp ms2 lbl c',
+ match_stack ge s ->
+ Mem.extends m2 m2' ->
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ Mach.find_label lbl f.(Mach.fn_code) = Some c' ->
+ transl_code_at_pc ge (rs1 PC) fb f (i :: c) ep tf tc ->
+ it1_is_parent ep i = false ->
+ (forall k c (TR: transl_instr f i ep k = OK c),
+ exists jmp, exists k', exists rs2,
+ exec_straight_opt tge tf c rs1 m1' (jmp :: k') rs2 m2'
+ /\ agree ms2 sp rs2
+ /\ exec_instr tge tf jmp rs2 m2' = goto_label tf lbl rs2 m2'
+ /\ (is_leaf_function f = true -> rs2#RA = parent_ra s)) ->
+ exists st',
+ plus step tge (State rs1 m1') E0 st' /\
+ match_states (Mach.State s fb sp c' ms2 m2) st'.
+Proof.
+ intros. inversion H3. subst. monadInv H9.
+ exploit H5; eauto. intros [jmp [k' [rs2 [A [B [C D]]]]]].
+ generalize (functions_transl _ _ _ H7 H8); intro FN.
+ generalize (transf_function_no_overflow _ _ H8); intro NOOV.
+ inv A.
+- exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+ rewrite OTH by congruence; auto.
+- exploit exec_straight_steps_2; eauto.
+ intros [ofs' [PC2 CT2]].
+ exploit find_label_goto_label; eauto.
+ intros [tc' [rs3 [GOTO [AT' OTH]]]].
+ exists (State rs3 m2'); split.
+ eapply plus_right'.
+ eapply exec_straight_steps_1; eauto.
+ econstructor; eauto.
+ eapply find_instr_tail. eauto.
+ rewrite C. eexact GOTO.
+ traceEq.
+ econstructor; eauto.
+ apply agree_exten with rs2; auto with asmgen.
+ congruence.
+ rewrite OTH by congruence; auto.
+Qed.
+
+(** We need to show that, in the simulation diagram, we cannot
+ take infinitely many Mach transitions that correspond to zero
+ transitions on the Asm side. Actually, all Mach transitions
+ correspond to at least one Asm transition, except the
+ transition from [Machsem.Returnstate] to [Machsem.State].
+ So, the following integer measure will suffice to rule out
+ the unwanted behaviour. *)
+
+Definition measure (s: Mach.state) : nat :=
+ match s with
+ | Mach.State _ _ _ _ _ _ => 0%nat
+ | Mach.Callstate _ _ _ _ => 0%nat
+ | Mach.Returnstate _ _ _ => 1%nat
+ end.
+
+Remark preg_of_not_X29: forall r, negb (mreg_eq r R29) = true -> IR X29 <> preg_of r.
+Proof.
+ intros. change (IR X29) with (preg_of R29). red; intros.
+ exploit preg_of_injective; eauto. intros; subst r; discriminate.
+Qed.
+
+Lemma sp_val': forall ms sp rs, agree ms sp rs -> sp = rs XSP.
+Proof.
+ intros. eapply sp_val; eauto.
+Qed.
+
+(** This is the simulation diagram. We prove it by case analysis on the Mach transition. *)
+
+Theorem step_simulation:
+ forall S1 t S2, Mach.step return_address_offset ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1') (WF: wf_state ge S1),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
+Proof.
+ induction 1; intros; inv MS.
+
+- (* Mlabel *)
+ left; eapply exec_straight_steps; eauto; intros.
+ monadInv TR. econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ split. { apply agree_nextinstr; auto. }
+ split. { simpl; congruence. }
+ rewrite nextinstr_inv by congruence; assumption.
+
+- (* Mgetstack *)
+ unfold load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ exploit loadind_correct; eauto with asmgen. intros [rs' [P [Q [R S]]]].
+ exists rs'; split. eauto.
+ split. { eapply agree_set_mreg; eauto with asmgen. congruence. }
+ split. { simpl; congruence. }
+ rewrite S. assumption.
+
+- (* Msetstack *)
+ unfold store_stack in H.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto).
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ left; eapply exec_straight_steps; eauto.
+ rewrite (sp_val _ _ _ AG) in A. intros. simpl in TR.
+ exploit storeind_correct; eauto with asmgen. intros [rs' [P [Q R]]].
+ exists rs'; split. eauto.
+ split. eapply agree_undef_regs; eauto with asmgen.
+ simpl; intros.
+ split. rewrite Q; auto with asmgen.
+ rewrite R. assumption.
+
+- (* Mgetparam *)
+ assert (f0 = f) by congruence; subst f0.
+ unfold load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ intros [parent' [A B]]. rewrite (sp_val' _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ intros [v' [C D]].
+Opaque loadind.
+ left; eapply exec_straight_steps; eauto; intros. monadInv TR.
+ destruct ep.
+(* X30 contains parent *)
+ exploit loadind_correct. eexact EQ.
+ instantiate (2 := rs0). simpl; rewrite DXP; eauto. simpl; congruence.
+ intros [rs1 [P [Q [R S]]]].
+ exists rs1; split. eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
+ simpl; split; intros.
+ { rewrite R; auto with asmgen.
+ apply preg_of_not_X29; auto.
+ }
+ { rewrite S; auto. }
+
+(* X30 does not contain parent *)
+ exploit loadptr_correct. eexact A. simpl; congruence. intros [rs1 [P [Q R]]].
+ exploit loadind_correct. eexact EQ. instantiate (2 := rs1). simpl; rewrite Q. eauto. simpl; congruence.
+ intros [rs2 [S [T [U V]]]].
+ exists rs2; split. eapply exec_straight_trans; eauto.
+ split. eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
+ instantiate (1 := rs1#X29 <- (rs2#X29)). intros.
+ rewrite Pregmap.gso; auto with asmgen.
+ congruence.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r' X29). congruence. auto with asmgen.
+ split; simpl; intros. rewrite U; auto with asmgen.
+ apply preg_of_not_X29; auto.
+ rewrite V. rewrite R by congruence. auto.
+
+- (* Mop *)
+ assert (eval_operation tge sp op (map rs args) m = Some v).
+ { rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. }
+ exploit eval_operation_lessdef. eapply preg_vals; eauto. eauto. eexact H0.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q [R S]]]].
+ exists rs2; split. eauto. split.
+ apply agree_set_undef_mreg with rs0; auto.
+ apply Val.lessdef_trans with v'; auto.
+ split; simpl; intros. InvBooleans.
+ rewrite R; auto. apply preg_of_not_X29; auto.
+Local Transparent destroyed_by_op.
+ destruct op; try exact I; simpl; congruence.
+ rewrite S.
+ auto.
+- (* Mload *)
+ destruct trap.
+ {
+ assert (Op.eval_addressing tge sp addr (map rs args) = Some a).
+ { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. }
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ left; eapply exec_straight_steps; eauto; intros. simpl in TR.
+ exploit transl_load_correct; eauto. intros [rs2 [P [Q [R S]]]].
+ exists rs2; split. eauto.
+ split. eapply agree_set_undef_mreg; eauto. congruence.
+ split. simpl; congruence.
+ rewrite S. assumption.
+ }
+
+ (* Mload notrap1 *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mstore *)
+ assert (Op.eval_addressing tge sp addr (map rs args) = Some a).
+ { rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. }
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (rs src) (rs0 (preg_of src))) by (eapply preg_val; eauto).
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ left; eapply exec_straight_steps; eauto.
+ intros. simpl in TR. exploit transl_store_correct; eauto. intros [rs2 [P [Q R]]].
+ exists rs2; split. eauto.
+ split. eapply agree_undef_regs; eauto with asmgen.
+ split. simpl; congruence.
+ rewrite R. assumption.
+
+- (* Mcall *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ { eapply transf_function_no_overflow; eauto. }
+ destruct ros as [rf|fid]; simpl in H; monadInv H5.
++ (* Indirect call *)
+ assert (rs rf = Vptr f' Ptrofs.zero).
+ { destruct (rs rf); try discriminate.
+ revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
+ assert (rs0 x0 = Vptr f' Ptrofs.zero).
+ { exploit ireg_val; eauto. rewrite H5; intros LD; inv LD; auto. }
+ generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
+ { econstructor; eauto. }
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. Simpl. rewrite <- H2; simpl; eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ eapply agree_sp_def; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. rewrite <- H2. auto.
++ (* Direct call *)
+ generalize (code_tail_next_int _ _ _ _ NOOV H6). intro CT1.
+ assert (TCA: transl_code_at_pc ge (Vptr fb (Ptrofs.add ofs Ptrofs.one)) fb f c false tf x).
+ econstructor; eauto.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_internal. eauto.
+ eapply functions_transl; eauto. eapply find_instr_tail; eauto.
+ simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. eauto.
+ econstructor; eauto.
+ econstructor; eauto.
+ eapply agree_sp_def; eauto.
+ simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. rewrite <- H2. auto.
+
+- (* Mtailcall *)
+ assert (f0 = f) by congruence. subst f0.
+ inversion AT; subst.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ { eapply transf_function_no_overflow; eauto. }
+ exploit Mem.loadv_extends. eauto. eexact H1. auto. simpl. intros [parent' [A B]].
+ destruct ros as [rf|fid]; simpl in H; monadInv H7.
++ (* Indirect call *)
+ assert (rs rf = Vptr f' Ptrofs.zero).
+ { destruct (rs rf); try discriminate.
+ revert H; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
+ assert (rs0 x0 = Vptr f' Ptrofs.zero).
+ { exploit ireg_val; eauto. rewrite H7; intros LD; inv LD; auto. }
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_steps_2; eauto using functions_transl.
+ intros (ofs' & P & Q).
+ left; econstructor; split.
+ (* execution *)
+ eapply plus_right'. eapply exec_straight_exec; eauto.
+ econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
+ simpl. reflexivity.
+ traceEq.
+ (* match states *)
+ econstructor; eauto.
+ apply agree_set_other; auto with asmgen.
+ Simpl. rewrite Z by (rewrite <- (ireg_of_eq _ _ EQ1); eauto with asmgen). assumption.
++ (* Direct call *)
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_steps_2; eauto using functions_transl.
+ intros (ofs' & P & Q).
+ left; econstructor; split.
+ (* execution *)
+ eapply plus_right'. eapply exec_straight_exec; eauto.
+ econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
+ simpl. reflexivity.
+ traceEq.
+ (* match states *)
+ econstructor; eauto.
+ apply agree_set_other; auto with asmgen.
+ Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H. auto.
+
+- (* Mbuiltin *)
+ inv AT. monadInv H4.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H3); intro NOOV.
+ exploit builtin_args_match; eauto. intros [vargs' [P Q]].
+ exploit external_call_mem_extends; eauto.
+ intros [vres' [m2' [A [B [C D]]]]].
+ left. econstructor; split. apply plus_one.
+ eapply exec_step_builtin. eauto. eauto.
+ eapply find_instr_tail; eauto.
+ erewrite <- sp_val by eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eauto.
+ econstructor; eauto.
+ instantiate (2 := tf); instantiate (1 := x).
+ unfold nextinstr. rewrite Pregmap.gss.
+ rewrite set_res_other. rewrite undef_regs_other_2.
+ rewrite <- H1. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
+ rewrite preg_notin_charact. intros. auto with asmgen.
+ auto with asmgen.
+ apply agree_nextinstr. eapply agree_set_res; auto.
+ eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.
+ congruence.
+
+ Simpl.
+ rewrite set_res_other by trivial.
+ rewrite undef_regs_other.
+ assumption.
+ intro.
+ rewrite in_map_iff.
+ intros (x0 & PREG & IN).
+ subst r'.
+ intro.
+ apply (preg_of_not_RA x0).
+ congruence.
+
+- (* Mgoto *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT. monadInv H4.
+ exploit find_label_goto_label; eauto. intros [tc' [rs' [GOTO [AT2 INV]]]].
+ left; exists (State rs' m'); split.
+ apply plus_one. econstructor; eauto.
+ eapply functions_transl; eauto.
+ eapply find_instr_tail; eauto.
+ simpl; eauto.
+ econstructor; eauto.
+ eapply agree_exten; eauto with asmgen.
+ congruence.
+
+ rewrite INV by congruence.
+ assumption.
+
+- (* Mcond true *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_opt_steps_goto; eauto.
+ intros. simpl in TR.
+ exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D).
+ exists jmp; exists k; exists rs'.
+ split. eexact A.
+ split. apply agree_exten with rs0; auto with asmgen.
+ split.
+ exact B.
+ rewrite D. exact LEAF.
+
+- (* Mcond false *)
+ exploit eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto. intros EC.
+ left; eapply exec_straight_steps; eauto. intros. simpl in TR.
+ exploit transl_cond_branch_correct; eauto. intros (rs' & jmp & A & B & C & D).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A. apply exec_straight_one. eexact B. auto.
+ split. apply agree_exten with rs0; auto. intros. Simpl.
+ split.
+ simpl; congruence.
+ Simpl. rewrite D.
+ exact LEAF.
+
+- (* Mjumptable *)
+ assert (f0 = f) by congruence. subst f0.
+ inv AT. monadInv H6.
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H5); intro NOOV.
+ exploit find_label_goto_label. eauto. eauto.
+ instantiate (2 := rs0#X16 <- Vundef #X17 <- Vundef).
+ Simpl. eauto.
+ eauto.
+ intros [tc' [rs' [A [B C]]]].
+ exploit ireg_val; eauto. rewrite H. intros LD; inv LD.
+ left; econstructor; split.
+ apply plus_one. econstructor; eauto.
+ eapply find_instr_tail; eauto.
+ simpl. Simpl. rewrite <- H9. unfold Mach.label in H0; unfold label; rewrite H0. eexact A.
+ econstructor; eauto.
+ eapply agree_undef_regs; eauto.
+ simpl. intros. rewrite C; auto with asmgen. Simpl.
+ congruence.
+
+ rewrite C by congruence.
+ repeat rewrite Pregmap.gso by congruence.
+ assumption.
+
+- (* Mreturn *)
+ assert (f0 = f) by congruence. subst f0.
+ inversion AT; subst. simpl in H6; monadInv H6.
+ assert (NOOV: list_length_z tf.(fn_code) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_steps_2; eauto using functions_transl.
+ intros (ofs' & P & Q).
+ left; econstructor; split.
+ (* execution *)
+ eapply plus_right'. eapply exec_straight_exec; eauto.
+ econstructor. eexact P. eapply functions_transl; eauto. eapply find_instr_tail. eexact Q.
+ simpl. reflexivity.
+ traceEq.
+ (* match states *)
+ econstructor; eauto.
+ apply agree_set_other; auto with asmgen.
+
+- (* internal function *)
+
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Ptrofs.max_unsigned (list_length_z x0.(fn_code))); inversion EQ1. clear EQ1. subst x0.
+ unfold store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
+ intros [m1' [C D]].
+ exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ simpl chunk_of_type in F.
+ exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
+ intros [m3' [P Q]].
+ change (chunk_of_type Tptr) with Mint64 in *.
+ (* Execution of function prologue *)
+ monadInv EQ0. rewrite transl_code'_transl_code in EQ1.
+ set (tfbody := Pallocframe (fn_stacksize f) (fn_link_ofs f) ::
+ storeptr RA XSP (fn_retaddr_ofs f) x0) in *.
+ set (tf := {| fn_sig := Mach.fn_sig f; fn_code := tfbody |}) in *.
+ set (rs2 := nextinstr (rs0#X29 <- (parent_sp s) #SP <- sp #X16 <- Vundef)).
+ exploit (storeptr_correct tge tf XSP (fn_retaddr_ofs f) RA x0 m2' m3' rs2).
+ simpl preg_of_iregsp. change (rs2 X30) with (rs0 X30). rewrite ATLR.
+ change (rs2 X2) with sp. eexact P.
+ simpl; congruence. congruence.
+ intros (rs3 & U & V & W).
+ assert (EXEC_PROLOGUE:
+ exec_straight tge tf
+ tf.(fn_code) rs0 m'
+ x0 rs3 m3').
+ { change (fn_code tf) with tfbody; unfold tfbody.
+ apply exec_straight_step with rs2 m2'.
+ unfold exec_instr. rewrite C. fold sp.
+ rewrite <- (sp_val _ _ _ AG). rewrite F. reflexivity.
+ reflexivity.
+ eexact U. }
+ exploit exec_straight_steps_2; eauto using functions_transl. omega. constructor.
+ intros (ofs' & X & Y).
+ left; exists (State rs3 m3'); split.
+ eapply exec_straight_steps_1; eauto. omega. constructor.
+ econstructor; eauto.
+ rewrite X; econstructor; eauto.
+ apply agree_exten with rs2; eauto with asmgen.
+ unfold rs2.
+ apply agree_nextinstr. apply agree_set_other; auto with asmgen.
+ apply agree_change_sp with (parent_sp s).
+ apply agree_undef_regs with rs0. auto.
+Local Transparent destroyed_at_function_entry. simpl.
+ simpl; intros; Simpl.
+ unfold sp; congruence.
+ intros. rewrite V by auto with asmgen. reflexivity.
+
+ rewrite W.
+ unfold rs2.
+ Simpl.
+
+- (* external function *)
+ exploit functions_translated; eauto.
+ intros [tf [A B]]. simpl in B. inv B.
+ exploit extcall_arguments_match; eauto.
+ intros [args' [C D]].
+ exploit external_call_mem_extends; eauto.
+ intros [res' [m2' [P [Q [R S]]]]].
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ econstructor; eauto.
+ unfold loc_external_result. apply agree_set_other; auto. apply agree_set_pair; auto.
+ apply agree_undef_caller_save_regs; auto.
+
+- (* return *)
+ inv STACKS. simpl in *.
+ right. split. omega. split. auto.
+ rewrite <- ATPC in H5.
+ econstructor; eauto. congruence.
+ inv WF.
+ inv STACK.
+ inv H1.
+ congruence.
+Qed.
+
+Lemma transf_initial_states:
+ forall st1, Mach.initial_state prog st1 ->
+ exists st2, Asm.initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+ intros. inversion H. unfold ge0 in *.
+ econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf_partial TRANSF); eauto.
+ replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
+ with (Vptr fb Ptrofs.zero).
+ econstructor; eauto.
+ constructor.
+ apply Mem.extends_refl.
+ split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
+ intros. rewrite Regmap.gi. auto.
+ unfold Genv.symbol_address.
+ rewrite (match_program_main TRANSF).
+ rewrite symbols_preserved.
+ unfold ge; rewrite H1. auto.
+Qed.
+
+Lemma transf_final_states:
+ forall st1 st2 r,
+ match_states st1 st2 -> Mach.final_state st1 r -> Asm.final_state st2 r.
+Proof.
+ intros. inv H0. inv H. constructor. assumption.
+ compute in H1. inv H1.
+ generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog).
+Proof.
+ eapply forward_simulation_star with (measure := measure)
+ (match_states := fun S1 S2 => match_states S1 S2 /\ wf_state ge S1).
+ - apply senv_preserved.
+ - simpl; intros. exploit transf_initial_states; eauto.
+ intros (s2 & A & B).
+ exists s2; intuition auto. apply wf_initial; auto.
+ - simpl; intros. destruct H as [MS WF]. eapply transf_final_states; eauto.
+ - simpl; intros. destruct H0 as [MS WF].
+ exploit step_simulation; eauto. intros [ (s2' & A & B) | (A & B & C) ].
+ + left; exists s2'; intuition auto. eapply wf_step; eauto.
+ + right; intuition auto. eapply wf_step; eauto.
+Qed.
+
+End PRESERVATION.
diff --git a/aarch64/Asmgenproof1.v b/aarch64/Asmgenproof1.v
new file mode 100644
index 00000000..0e36bd05
--- /dev/null
+++ b/aarch64/Asmgenproof1.v
@@ -0,0 +1,2138 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for AArch64 code generation: auxiliary results. *)
+
+Require Import Recdef Coqlib Zwf Zbits.
+Require Import Maps Errors AST Integers Floats Values Memory Globalenvs.
+Require Import Op Locations Mach Asm Conventions.
+Require Import Asmgen.
+Require Import Asmgenproof0.
+
+Local Transparent Archi.ptr64.
+
+(** Properties of registers *)
+
+Lemma preg_of_not_RA:
+ forall r, (preg_of r) <> RA.
+Proof.
+ destruct r; discriminate.
+Qed.
+
+Lemma RA_not_written:
+ forall (rs : regset) dst v,
+ rs # (preg_of dst) <- v RA = rs RA.
+Proof.
+ intros.
+ apply Pregmap.gso.
+ intro.
+ symmetry in H.
+ exact (preg_of_not_RA dst H).
+Qed.
+
+Hint Resolve RA_not_written : asmgen.
+
+Lemma RA_not_written2:
+ forall (rs : regset) dst v i,
+ preg_of dst = i ->
+ rs # i <- v RA = rs RA.
+Proof.
+ intros.
+ subst i.
+ apply RA_not_written.
+Qed.
+
+Hint Resolve RA_not_written2 : asmgen.
+
+Lemma RA_not_written3:
+ forall (rs : regset) dst v i,
+ ireg_of dst = OK i ->
+ rs # i <- v RA = rs RA.
+Proof.
+ intros.
+ unfold ireg_of in H.
+ destruct preg_of eqn:PREG; try discriminate.
+ replace i0 with i in * by congruence.
+ eapply RA_not_written2; eassumption.
+Qed.
+
+Hint Resolve RA_not_written3 : asmgen.
+
+Lemma preg_of_iregsp_not_PC: forall r, preg_of_iregsp r <> PC.
+Proof.
+ destruct r; simpl; congruence.
+Qed.
+Hint Resolve preg_of_iregsp_not_PC: asmgen.
+
+Lemma preg_of_not_X16: forall r, preg_of r <> X16.
+Proof.
+ destruct r; simpl; congruence.
+Qed.
+
+Lemma ireg_of_not_X16: forall r x, ireg_of r = OK x -> x <> X16.
+Proof.
+ unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H.
+ red; intros; subst x. elim (preg_of_not_X16 r); auto.
+Qed.
+
+Lemma ireg_of_not_RA: forall r x, ireg_of r = OK x -> x <> RA.
+Proof.
+ unfold ireg_of; intros. destruct (preg_of r) eqn:E; inv H.
+ red; intros; subst x. elim (preg_of_not_RA r); auto.
+Qed.
+
+Lemma ireg_of_not_RA': forall r x, ireg_of r = OK x -> RA <> x.
+Proof.
+ intros. intro.
+ apply (ireg_of_not_RA r x); auto.
+Qed.
+
+Lemma ireg_of_not_RA'': forall r x, ireg_of r = OK x -> IR RA <> IR x.
+Proof.
+ intros. intro.
+ apply (ireg_of_not_RA' r x); auto. congruence.
+Qed.
+
+Hint Resolve ireg_of_not_RA ireg_of_not_RA' ireg_of_not_RA'' : asmgen.
+
+Lemma ireg_of_not_X16': forall r x, ireg_of r = OK x -> IR x <> IR X16.
+Proof.
+ intros. apply ireg_of_not_X16 in H. congruence.
+Qed.
+
+Hint Resolve preg_of_not_X16 ireg_of_not_X16 ireg_of_not_X16': asmgen.
+
+(** Useful simplification tactic *)
+
+
+Ltac Simplif :=
+ ((rewrite nextinstr_inv by eauto with asmgen)
+ || (rewrite nextinstr_inv1 by eauto with asmgen)
+ || (rewrite Pregmap.gss)
+ || (rewrite nextinstr_pc)
+ || (rewrite Pregmap.gso by eauto with asmgen)); auto with asmgen.
+
+Ltac Simpl := repeat Simplif.
+
+(** * Correctness of ARM constructor functions *)
+
+Section CONSTRUCTORS.
+
+Variable ge: genv.
+Variable fn: function.
+
+(** Decomposition of integer literals *)
+
+Inductive wf_decomposition: list (Z * Z) -> Prop :=
+ | wf_decomp_nil:
+ wf_decomposition nil
+ | wf_decomp_cons: forall m n p l,
+ n = Zzero_ext 16 m -> 0 <= p -> wf_decomposition l ->
+ wf_decomposition ((n, p) :: l).
+
+Lemma decompose_int_wf:
+ forall N n p, 0 <= p -> wf_decomposition (decompose_int N n p).
+Proof.
+Local Opaque Zzero_ext.
+ induction N as [ | N]; simpl; intros.
+- constructor.
+- set (frag := Zzero_ext 16 (Z.shiftr n p)) in *. destruct (Z.eqb frag 0).
++ apply IHN. omega.
++ econstructor. reflexivity. omega. apply IHN; omega.
+Qed.
+
+Fixpoint recompose_int (accu: Z) (l: list (Z * Z)) : Z :=
+ match l with
+ | nil => accu
+ | (n, p) :: l => recompose_int (Zinsert accu n p 16) l
+ end.
+
+Lemma decompose_int_correct:
+ forall N n p accu,
+ 0 <= p ->
+ (forall i, p <= i -> Z.testbit accu i = false) ->
+ (forall i, 0 <= i < p + Z.of_nat N * 16 ->
+ Z.testbit (recompose_int accu (decompose_int N n p)) i =
+ if zlt i p then Z.testbit accu i else Z.testbit n i).
+Proof.
+ induction N as [ | N]; intros until accu; intros PPOS ABOVE i RANGE.
+- simpl. rewrite zlt_true; auto. xomega.
+- rewrite inj_S in RANGE. simpl.
+ set (frag := Zzero_ext 16 (Z.shiftr n p)).
+ assert (FRAG: forall i, p <= i < p + 16 -> Z.testbit n i = Z.testbit frag (i - p)).
+ { unfold frag; intros. rewrite Zzero_ext_spec by omega. rewrite zlt_true by omega.
+ rewrite Z.shiftr_spec by omega. f_equal; omega. }
+ destruct (Z.eqb_spec frag 0).
++ rewrite IHN.
+* destruct (zlt i p). rewrite zlt_true by omega. auto.
+ destruct (zlt i (p + 16)); auto.
+ rewrite ABOVE by omega. rewrite FRAG by omega. rewrite e, Z.testbit_0_l. auto.
+* omega.
+* intros; apply ABOVE; omega.
+* xomega.
++ simpl. rewrite IHN.
+* destruct (zlt i (p + 16)).
+** rewrite Zinsert_spec by omega. unfold proj_sumbool.
+ rewrite zlt_true by omega.
+ destruct (zlt i p).
+ rewrite zle_false by omega. auto.
+ rewrite zle_true by omega. simpl. symmetry; apply FRAG; omega.
+** rewrite Z.ldiff_spec, Z.shiftl_spec by omega.
+ change 65535 with (two_p 16 - 1). rewrite Ztestbit_two_p_m1 by omega.
+ rewrite zlt_false by omega. rewrite zlt_false by omega. apply andb_true_r.
+* omega.
+* intros. rewrite Zinsert_spec by omega. unfold proj_sumbool.
+ rewrite zle_true by omega. rewrite zlt_false by omega. simpl.
+ apply ABOVE. omega.
+* xomega.
+Qed.
+
+Corollary decompose_int_eqmod: forall N n,
+ eqmod (two_power_nat (N * 16)%nat) (recompose_int 0 (decompose_int N n 0)) n.
+Proof.
+ intros; apply eqmod_same_bits; intros.
+ rewrite decompose_int_correct. apply zlt_false; omega.
+ omega. intros; apply Z.testbit_0_l. xomega.
+Qed.
+
+Corollary decompose_notint_eqmod: forall N n,
+ eqmod (two_power_nat (N * 16)%nat)
+ (Z.lnot (recompose_int 0 (decompose_int N (Z.lnot n) 0))) n.
+Proof.
+ intros; apply eqmod_same_bits; intros.
+ rewrite Z.lnot_spec, decompose_int_correct.
+ rewrite zlt_false by omega. rewrite Z.lnot_spec by omega. apply negb_involutive.
+ omega. intros; apply Z.testbit_0_l. xomega. omega.
+Qed.
+
+Lemma negate_decomposition_wf:
+ forall l, wf_decomposition l -> wf_decomposition (negate_decomposition l).
+Proof.
+ induction 1; simpl; econstructor; auto.
+ instantiate (1 := (Z.lnot m)).
+ apply equal_same_bits; intros.
+ rewrite H. change 65535 with (two_p 16 - 1).
+ rewrite Z.lxor_spec, !Zzero_ext_spec, Z.lnot_spec, Ztestbit_two_p_m1 by omega.
+ destruct (zlt i 16).
+ apply xorb_true_r.
+ auto.
+Qed.
+
+Lemma Zinsert_eqmod:
+ forall n x1 x2 y p l, 0 <= p -> 0 <= l ->
+ eqmod (two_power_nat n) x1 x2 ->
+ eqmod (two_power_nat n) (Zinsert x1 y p l) (Zinsert x2 y p l).
+Proof.
+ intros. apply eqmod_same_bits; intros. rewrite ! Zinsert_spec by omega.
+ destruct (zle p i && zlt i (p + l)); auto.
+ apply same_bits_eqmod with n; auto.
+Qed.
+
+Lemma Zinsert_0_l:
+ forall y p l,
+ 0 <= p -> 0 <= l ->
+ Z.shiftl (Zzero_ext l y) p = Zinsert 0 (Zzero_ext l y) p l.
+Proof.
+ intros. apply equal_same_bits; intros.
+ rewrite Zinsert_spec by omega. unfold proj_sumbool.
+ destruct (zlt i p); [rewrite zle_false by omega|rewrite zle_true by omega]; simpl.
+- rewrite Z.testbit_0_l, Z.shiftl_spec_low by auto. auto.
+- rewrite Z.shiftl_spec by omega.
+ destruct (zlt i (p + l)); auto.
+ rewrite Zzero_ext_spec, zlt_false, Z.testbit_0_l by omega. auto.
+Qed.
+
+Lemma recompose_int_negated:
+ forall l, wf_decomposition l ->
+ forall accu, recompose_int (Z.lnot accu) (negate_decomposition l) = Z.lnot (recompose_int accu l).
+Proof.
+ induction 1; intros accu; simpl.
+- auto.
+- rewrite <- IHwf_decomposition. f_equal. apply equal_same_bits; intros.
+ rewrite Z.lnot_spec, ! Zinsert_spec, Z.lxor_spec, Z.lnot_spec by omega.
+ unfold proj_sumbool.
+ destruct (zle p i); simpl; auto.
+ destruct (zlt i (p + 16)); simpl; auto.
+ change 65535 with (two_p 16 - 1).
+ rewrite Ztestbit_two_p_m1 by omega. rewrite zlt_true by omega.
+ apply xorb_true_r.
+Qed.
+
+Lemma exec_loadimm_k_w:
+ forall (rd: ireg) k m l,
+ wf_decomposition l ->
+ rd <> RA ->
+ forall (rs: regset) accu,
+ rs#rd = Vint (Int.repr accu) ->
+ exists rs',
+ exec_straight_opt ge fn (loadimm_k W rd l k) rs m k rs' m
+ /\ rs'#rd = Vint (Int.repr (recompose_int accu l))
+ /\ (forall r, r <> PC -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ induction 1; intros RD_NOT_RA rs accu ACCU; simpl.
+- exists rs; split. apply exec_straight_opt_refl. auto.
+- destruct (IHwf_decomposition RD_NOT_RA
+ (nextinstr (rs#rd <- (insert_in_int rs#rd n p 16)))
+ (Zinsert accu n p 16))
+ as (rs' & P & Q & R & S).
+ Simpl. rewrite ACCU. simpl. f_equal. apply Int.eqm_samerepr.
+ apply Zinsert_eqmod. auto. omega. apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
+ exists rs'; split.
+ eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P.
+ split. exact Q.
+ split.
+ { intros; Simpl.
+ rewrite R by auto. Simpl. }
+ { rewrite S. Simpl. }
+Qed.
+
+Lemma exec_loadimm_z_w:
+ forall rd l k rs m,
+ wf_decomposition l ->
+ rd <> RA ->
+ exists rs',
+ exec_straight ge fn (loadimm_z W rd l k) rs m k rs' m
+ /\ rs'#rd = Vint (Int.repr (recompose_int 0 l))
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm_z; destruct 1; intro RD_NOT_RA.
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl.
+ intros; Simpl.
+- set (accu0 := Zinsert 0 n p 16).
+ set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))).
+ destruct (exec_loadimm_k_w rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R & S); auto.
+ unfold rs1; Simpl.
+ exists rs2; split.
+ eapply exec_straight_opt_step; eauto.
+ simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega.
+ reflexivity.
+ split. exact Q.
+ intros. rewrite R by auto. unfold rs1; Simpl.
+Qed.
+
+Lemma exec_loadimm_n_w:
+ forall rd l k rs m,
+ wf_decomposition l ->
+ rd <> RA ->
+ exists rs',
+ exec_straight ge fn (loadimm_n W rd l k) rs m k rs' m
+ /\ rs'#rd = Vint (Int.repr (Z.lnot (recompose_int 0 l)))
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm_n; destruct 1; intro RD_NOT_RA.
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl.
+ intros; Simpl.
+- set (accu0 := Z.lnot (Zinsert 0 n p 16)).
+ set (rs1 := nextinstr (rs#rd <- (Vint (Int.repr accu0)))).
+ destruct (exec_loadimm_k_w rd k m (negate_decomposition l)
+ (negate_decomposition_wf l H1)
+ RD_NOT_RA rs1 accu0)
+ as (rs2 & P & Q & R & S).
+ unfold rs1; Simpl.
+ exists rs2; split.
+ eapply exec_straight_opt_step; eauto.
+ simpl. unfold rs1. do 5 f_equal.
+ unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega.
+ reflexivity.
+ split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q.
+ intros. rewrite R by auto. unfold rs1; Simpl.
+Qed.
+
+Lemma exec_loadimm32:
+ forall rd n k rs m
+ (RD_NOT_RA : rd <> RA),
+ exists rs',
+ exec_straight ge fn (loadimm32 rd n k) rs m k rs' m
+ /\ rs'#rd = Vint n
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm32, loadimm; intros.
+ destruct (is_logical_imm32 n).
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. rewrite Int.repr_unsigned, Int.or_zero_l; auto.
+ intros; Simpl.
+- set (dz := decompose_int 2%nat (Int.unsigned n) 0).
+ set (dn := decompose_int 2%nat (Z.lnot (Int.unsigned n)) 0).
+ assert (A: Int.repr (recompose_int 0 dz) = n).
+ { transitivity (Int.repr (Int.unsigned n)).
+ apply Int.eqm_samerepr. apply decompose_int_eqmod.
+ apply Int.repr_unsigned. }
+ assert (B: Int.repr (Z.lnot (recompose_int 0 dn)) = n).
+ { transitivity (Int.repr (Int.unsigned n)).
+ apply Int.eqm_samerepr. apply decompose_notint_eqmod.
+ apply Int.repr_unsigned. }
+ destruct Nat.leb.
++ rewrite <- A. apply exec_loadimm_z_w. apply decompose_int_wf; omega. trivial.
++ rewrite <- B. apply exec_loadimm_n_w. apply decompose_int_wf; omega. trivial.
+Qed.
+
+Lemma exec_loadimm_k_x:
+ forall (rd: ireg) k m l,
+ wf_decomposition l ->
+ rd <> RA ->
+ forall (rs: regset) accu,
+ rs#rd = Vlong (Int64.repr accu) ->
+ exists rs',
+ exec_straight_opt ge fn (loadimm_k X rd l k) rs m k rs' m
+ /\ rs'#rd = Vlong (Int64.repr (recompose_int accu l))
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ induction 1; intros RD_NOT_RA rs accu ACCU; simpl.
+- exists rs; split. apply exec_straight_opt_refl. auto.
+- destruct (IHwf_decomposition RD_NOT_RA
+ (nextinstr (rs#rd <- (insert_in_long rs#rd n p 16)))
+ (Zinsert accu n p 16))
+ as (rs' & P & Q & R).
+ Simpl. rewrite ACCU. simpl. f_equal. apply Int64.eqm_samerepr.
+ apply Zinsert_eqmod. auto. omega. apply Int64.eqm_sym; apply Int64.eqm_unsigned_repr.
+ exists rs'; split.
+ eapply exec_straight_opt_step_opt. simpl; eauto. auto. exact P.
+ split. exact Q. intros; Simpl. rewrite R by auto. Simpl.
+Qed.
+
+Lemma exec_loadimm_z_x:
+ forall rd l k rs m,
+ wf_decomposition l ->
+ rd <> RA ->
+ exists rs',
+ exec_straight ge fn (loadimm_z X rd l k) rs m k rs' m
+ /\ rs'#rd = Vlong (Int64.repr (recompose_int 0 l))
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm_z; destruct 1; intro RD_NOT_RA.
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl.
+ intros; Simpl.
+- set (accu0 := Zinsert 0 n p 16).
+ set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))).
+ destruct (exec_loadimm_k_x rd k m l H1 RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R); auto.
+ unfold rs1; Simpl.
+ exists rs2; split.
+ eapply exec_straight_opt_step; eauto.
+ simpl. unfold rs1. do 5 f_equal. unfold accu0. rewrite H. apply Zinsert_0_l; omega.
+ reflexivity.
+ split. exact Q.
+ intros. rewrite R by auto. unfold rs1; Simpl.
+Qed.
+
+Lemma exec_loadimm_n_x:
+ forall rd l k rs m,
+ wf_decomposition l ->
+ rd <> RA ->
+ exists rs',
+ exec_straight ge fn (loadimm_n X rd l k) rs m k rs' m
+ /\ rs'#rd = Vlong (Int64.repr (Z.lnot (recompose_int 0 l)))
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm_n; destruct 1; intro RD_NOT_RA.
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl.
+ intros; Simpl.
+- set (accu0 := Z.lnot (Zinsert 0 n p 16)).
+ set (rs1 := nextinstr (rs#rd <- (Vlong (Int64.repr accu0)))).
+ destruct (exec_loadimm_k_x rd k m (negate_decomposition l)
+ (negate_decomposition_wf l H1)
+ RD_NOT_RA rs1 accu0) as (rs2 & P & Q & R).
+ unfold rs1; Simpl.
+ exists rs2; split.
+ eapply exec_straight_opt_step; eauto.
+ simpl. unfold rs1. do 5 f_equal.
+ unfold accu0. f_equal. rewrite H. apply Zinsert_0_l; omega.
+ reflexivity.
+ split. unfold accu0 in Q; rewrite recompose_int_negated in Q by auto. exact Q.
+ intros. rewrite R by auto. unfold rs1; Simpl.
+Qed.
+
+Lemma exec_loadimm64:
+ forall rd n k rs m,
+ rd <> RA ->
+ exists rs',
+ exec_straight ge fn (loadimm64 rd n k) rs m k rs' m
+ /\ rs'#rd = Vlong n
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold loadimm64, loadimm; intros until m; intro RD_NOT_RA.
+ destruct (is_logical_imm64 n).
+- econstructor; split.
+ apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. rewrite Int64.repr_unsigned, Int64.or_zero_l; auto.
+ intros; Simpl.
+- set (dz := decompose_int 4%nat (Int64.unsigned n) 0).
+ set (dn := decompose_int 4%nat (Z.lnot (Int64.unsigned n)) 0).
+ assert (A: Int64.repr (recompose_int 0 dz) = n).
+ { transitivity (Int64.repr (Int64.unsigned n)).
+ apply Int64.eqm_samerepr. apply decompose_int_eqmod.
+ apply Int64.repr_unsigned. }
+ assert (B: Int64.repr (Z.lnot (recompose_int 0 dn)) = n).
+ { transitivity (Int64.repr (Int64.unsigned n)).
+ apply Int64.eqm_samerepr. apply decompose_notint_eqmod.
+ apply Int64.repr_unsigned. }
+ destruct Nat.leb.
++ rewrite <- A. apply exec_loadimm_z_x. apply decompose_int_wf; omega. trivial.
++ rewrite <- B. apply exec_loadimm_n_x. apply decompose_int_wf; omega. trivial.
+Qed.
+
+(** Add immediate *)
+
+Lemma exec_addimm_aux_32:
+ forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val),
+ (forall rd r1 n rs m,
+ exec_instr ge fn (insn rd r1 n) rs m =
+ Next (nextinstr (rs#rd <- (sem rs#r1 (Vint (Int.repr n))))) m) ->
+ (forall v n1 n2, sem (sem v (Vint n1)) (Vint n2) = sem v (Vint (Int.add n1 n2))) ->
+ forall rd r1 n k rs m,
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (addimm_aux insn rd r1 (Int.unsigned n) k) rs m k rs' m
+ /\ rs'#rd = sem rs#r1 (Vint n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros insn sem SEM ASSOC; intros until m; intro RD_NOT_RA. unfold addimm_aux.
+ set (nlo := Zzero_ext 12 (Int.unsigned n)). set (nhi := Int.unsigned n - nlo).
+ assert (E: Int.unsigned n = nhi + nlo) by (unfold nhi; omega).
+ rewrite <- (Int.repr_unsigned n).
+ destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)].
+- econstructor; split. apply exec_straight_one. apply SEM. Simpl.
+ split. Simpl. do 3 f_equal; omega.
+ split; intros; Simpl.
+- econstructor; split. apply exec_straight_one. apply SEM. Simpl.
+ split. Simpl. do 3 f_equal; omega.
+ split; intros; Simpl.
+- econstructor; split. eapply exec_straight_two.
+ apply SEM. apply SEM. Simpl. Simpl.
+ split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int.eqm_samerepr.
+ rewrite E. auto with ints.
+ split; intros; Simpl.
+Qed.
+
+Lemma exec_addimm32:
+ forall rd r1 n k rs m,
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (addimm32 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = Val.add rs#r1 (Vint n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros. unfold addimm32. set (nn := Int.neg n).
+ destruct (Int.eq n (Int.zero_ext 24 n)); [| destruct (Int.eq nn (Int.zero_ext 24 nn))].
+- apply exec_addimm_aux_32 with (sem := Val.add); auto. intros; apply Val.add_assoc.
+- rewrite <- Val.sub_opp_add.
+ apply exec_addimm_aux_32 with (sem := Val.sub); auto.
+ intros. rewrite ! Val.sub_add_opp, Val.add_assoc. rewrite Int.neg_add_distr. auto.
+- destruct (Int.lt n Int.zero).
++ rewrite <- Val.sub_opp_add; fold nn.
+ edestruct (exec_loadimm32 X16 nn) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. rewrite B, C; eauto with asmgen.
+ split; intros; Simpl.
++ edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. rewrite B, C; eauto with asmgen.
+ split; intros; Simpl.
+Qed.
+
+Lemma exec_addimm_aux_64:
+ forall (insn: iregsp -> iregsp -> Z -> instruction) (sem: val -> val -> val),
+ (forall rd r1 n rs m,
+ exec_instr ge fn (insn rd r1 n) rs m =
+ Next (nextinstr (rs#rd <- (sem rs#r1 (Vlong (Int64.repr n))))) m) ->
+ (forall v n1 n2, sem (sem v (Vlong n1)) (Vlong n2) = sem v (Vlong (Int64.add n1 n2))) ->
+ forall rd r1 n k rs m,
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (addimm_aux insn rd r1 (Int64.unsigned n) k) rs m k rs' m
+ /\ rs'#rd = sem rs#r1 (Vlong n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros insn sem SEM ASSOC; intros. unfold addimm_aux.
+ set (nlo := Zzero_ext 12 (Int64.unsigned n)). set (nhi := Int64.unsigned n - nlo).
+ assert (E: Int64.unsigned n = nhi + nlo) by (unfold nhi; omega).
+ rewrite <- (Int64.repr_unsigned n).
+ destruct (Z.eqb_spec nhi 0); [|destruct (Z.eqb_spec nlo 0)].
+- econstructor; split. apply exec_straight_one. apply SEM. Simpl.
+ split. Simpl. do 3 f_equal; omega.
+ split; intros; Simpl.
+- econstructor; split. apply exec_straight_one. apply SEM. Simpl.
+ split. Simpl. do 3 f_equal; omega.
+ split; intros; Simpl.
+- econstructor; split. eapply exec_straight_two.
+ apply SEM. apply SEM. Simpl. Simpl.
+ split. Simpl. rewrite ASSOC. do 2 f_equal. apply Int64.eqm_samerepr.
+ rewrite E. auto with ints.
+ split; intros; Simpl.
+Qed.
+
+Lemma exec_addimm64:
+ forall rd r1 n k rs m,
+ preg_of_iregsp r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (addimm64 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = Val.addl rs#r1 (Vlong n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros.
+ unfold addimm64. set (nn := Int64.neg n).
+ destruct (Int64.eq n (Int64.zero_ext 24 n)); [| destruct (Int64.eq nn (Int64.zero_ext 24 nn))].
+- apply exec_addimm_aux_64 with (sem := Val.addl); auto. intros; apply Val.addl_assoc.
+- rewrite <- Val.subl_opp_addl.
+ apply exec_addimm_aux_64 with (sem := Val.subl); auto.
+ intros. rewrite ! Val.subl_addl_opp, Val.addl_assoc. rewrite Int64.neg_add_distr. auto.
+- destruct (Int64.lt n Int64.zero).
++ rewrite <- Val.subl_opp_addl; fold nn.
+ edestruct (exec_loadimm64 X16 nn) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl.
+ split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto.
+ split; intros; Simpl.
++ edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. eapply exec_straight_one. simpl; eauto. Simpl.
+ split. Simpl. rewrite B, C; eauto with asmgen. simpl. rewrite Int64.shl'_zero. auto.
+ split; intros; Simpl.
+Qed.
+
+(** Logical immediate *)
+
+Lemma exec_logicalimm32:
+ forall (insn1: ireg -> ireg0 -> Z -> instruction)
+ (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
+ (sem: val -> val -> val),
+ (forall rd r1 n rs m,
+ exec_instr ge fn (insn1 rd r1 n) rs m =
+ Next (nextinstr (rs#rd <- (sem rs##r1 (Vint (Int.repr n))))) m) ->
+ (forall rd r1 r2 s rs m,
+ exec_instr ge fn (insn2 rd r1 r2 s) rs m =
+ Next (nextinstr (rs#rd <- (sem rs##r1 (eval_shift_op_int rs#r2 s)))) m) ->
+ forall rd r1 n k rs m,
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (logicalimm32 insn1 insn2 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = sem rs#r1 (Vint n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros until sem; intros SEM1 SEM2; intros. unfold logicalimm32.
+ destruct (is_logical_imm32 n).
+- econstructor; split.
+ apply exec_straight_one. apply SEM1. reflexivity.
+ split. Simpl. rewrite Int.repr_unsigned; auto.
+ split; intros; Simpl.
+- edestruct (exec_loadimm32 X16 n) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. apply SEM2. reflexivity.
+ split. Simpl. f_equal; auto. apply C; auto with asmgen.
+ split; intros; Simpl.
+Qed.
+
+Lemma exec_logicalimm64:
+ forall (insn1: ireg -> ireg0 -> Z -> instruction)
+ (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
+ (sem: val -> val -> val),
+ (forall rd r1 n rs m,
+ exec_instr ge fn (insn1 rd r1 n) rs m =
+ Next (nextinstr (rs#rd <- (sem rs###r1 (Vlong (Int64.repr n))))) m) ->
+ (forall rd r1 r2 s rs m,
+ exec_instr ge fn (insn2 rd r1 r2 s) rs m =
+ Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) ->
+ forall rd r1 n k rs m,
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (logicalimm64 insn1 insn2 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = sem rs#r1 (Vlong n)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros until sem; intros SEM1 SEM2; intros. unfold logicalimm64.
+ destruct (is_logical_imm64 n).
+- econstructor; split.
+ apply exec_straight_one. apply SEM1. reflexivity.
+ split. Simpl. rewrite Int64.repr_unsigned. auto.
+ split; intros; Simpl.
+- edestruct (exec_loadimm64 X16 n) as (rs1 & A & B & C). congruence.
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. apply SEM2. reflexivity.
+ split. Simpl. f_equal; auto. apply C; auto with asmgen.
+ split; intros; Simpl.
+Qed.
+
+(** Load address of symbol *)
+
+Lemma exec_loadsymbol: forall rd s ofs k rs m,
+ rd <> X16 \/ Archi.pic_code tt = false ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (loadsymbol rd s ofs k) rs m k rs' m
+ /\ rs'#rd = Genv.symbol_address ge s ofs
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs'#RA = rs#RA.
+Proof.
+ unfold loadsymbol; intros. destruct (Archi.pic_code tt).
+- predSpec Ptrofs.eq Ptrofs.eq_spec ofs Ptrofs.zero.
++ subst ofs. econstructor; split.
+ apply exec_straight_one; [simpl; eauto | reflexivity].
+ split. Simpl. split; intros; Simpl.
+
++ exploit exec_addimm64. instantiate (1 := rd). simpl. destruct H; congruence.
+ instantiate (1 := rd). assumption.
+ intros (rs1 & A & B & C & D).
+ econstructor; split.
+ econstructor. simpl; eauto. auto. eexact A.
+ split. simpl in B; rewrite B. Simpl.
+ rewrite <- Genv.shift_symbol_address_64 by auto.
+ rewrite Ptrofs.add_zero_l, Ptrofs.of_int64_to_int64 by auto. auto.
+ split; intros. rewrite C by auto; Simpl.
+ rewrite D. Simpl.
+- econstructor; split.
+ eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ split. Simpl. rewrite symbol_high_low; auto.
+ split; intros; Simpl.
+Qed.
+
+(** Shifted operands *)
+
+Remark transl_shift_not_none:
+ forall s a, transl_shift s a <> SOnone.
+Proof.
+ destruct s; intros; simpl; congruence.
+Qed.
+
+Remark or_zero_eval_shift_op_int:
+ forall v s, s <> SOnone -> Val.or (Vint Int.zero) (eval_shift_op_int v s) = eval_shift_op_int v s.
+Proof.
+ intros; destruct s; try congruence; destruct v; auto; simpl;
+ destruct (Int.ltu n Int.iwordsize); auto; rewrite Int.or_zero_l; auto.
+Qed.
+
+Remark or_zero_eval_shift_op_long:
+ forall v s, s <> SOnone -> Val.orl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s.
+Proof.
+ intros; destruct s; try congruence; destruct v; auto; simpl;
+ destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.or_zero_l; auto.
+Qed.
+
+Remark add_zero_eval_shift_op_long:
+ forall v s, s <> SOnone -> Val.addl (Vlong Int64.zero) (eval_shift_op_long v s) = eval_shift_op_long v s.
+Proof.
+ intros; destruct s; try congruence; destruct v; auto; simpl;
+ destruct (Int.ltu n Int64.iwordsize'); auto; rewrite Int64.add_zero_l; auto.
+Qed.
+
+Lemma transl_eval_shift: forall s v (a: amount32),
+ eval_shift_op_int v (transl_shift s a) = eval_shift s v a.
+Proof.
+ intros. destruct s; simpl; auto.
+Qed.
+
+Lemma transl_eval_shift': forall s v (a: amount32),
+ Val.or (Vint Int.zero) (eval_shift_op_int v (transl_shift s a)) = eval_shift s v a.
+Proof.
+ intros. rewrite or_zero_eval_shift_op_int by (apply transl_shift_not_none).
+ apply transl_eval_shift.
+Qed.
+
+Lemma transl_eval_shiftl: forall s v (a: amount64),
+ eval_shift_op_long v (transl_shift s a) = eval_shiftl s v a.
+Proof.
+ intros. destruct s; simpl; auto.
+Qed.
+
+Lemma transl_eval_shiftl': forall s v (a: amount64),
+ Val.orl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a.
+Proof.
+ intros. rewrite or_zero_eval_shift_op_long by (apply transl_shift_not_none).
+ apply transl_eval_shiftl.
+Qed.
+
+Lemma transl_eval_shiftl'': forall s v (a: amount64),
+ Val.addl (Vlong Int64.zero) (eval_shift_op_long v (transl_shift s a)) = eval_shiftl s v a.
+Proof.
+ intros. rewrite add_zero_eval_shift_op_long by (apply transl_shift_not_none).
+ apply transl_eval_shiftl.
+Qed.
+
+(** Zero- and Sign- extensions *)
+
+Lemma exec_move_extended_base: forall rd r1 ex k rs m,
+ exists rs',
+ exec_straight ge fn (move_extended_base rd r1 ex k) rs m k rs' m
+ /\ rs' rd = match ex with Xsgn32 => Val.longofint rs#r1 | Xuns32 => Val.longofintu rs#r1 end
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold move_extended_base; destruct ex; econstructor;
+ (split; [apply exec_straight_one; [simpl;eauto|auto] | split; [Simpl|intros;Simpl]]).
+Qed.
+
+Lemma exec_move_extended: forall rd r1 ex (a: amount64) k rs m,
+ exists rs',
+ exec_straight ge fn (move_extended rd r1 ex a k) rs m k rs' m
+ /\ rs' rd = Op.eval_extend ex rs#r1 a
+ /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
+Proof.
+ unfold move_extended; intros. predSpec Int.eq Int.eq_spec a Int.zero.
+- exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C).
+ exists rs'; split. eexact A. split. unfold Op.eval_extend. rewrite H. rewrite B.
+ destruct ex, (rs r1); simpl; auto; rewrite Int64.shl'_zero; auto.
+ auto.
+- Local Opaque Val.addl.
+ exploit (exec_move_extended_base rd r1 ex). intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ unfold exec_instr. change (SOlsl a) with (transl_shift Slsl a). rewrite transl_eval_shiftl''. eauto. auto.
+ split. Simpl. rewrite B. auto.
+ intros; Simpl.
+Qed.
+
+Lemma exec_arith_extended:
+ forall (sem: val -> val -> val)
+ (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction)
+ (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction),
+ (forall rd r1 r2 x rs m,
+ exec_instr ge fn (insnX rd r1 r2 x) rs m =
+ Next (nextinstr (rs#rd <- (sem rs#r1 (eval_extend rs#r2 x)))) m) ->
+ (forall rd r1 r2 s rs m,
+ exec_instr ge fn (insnS rd r1 r2 s) rs m =
+ Next (nextinstr (rs#rd <- (sem rs###r1 (eval_shift_op_long rs#r2 s)))) m) ->
+ forall (rd r1 r2: ireg) (ex: extension) (a: amount64) (k: code) rs m,
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (arith_extended insnX insnS rd r1 r2 ex a k) rs m k rs' m
+ /\ rs'#rd = sem rs#r1 (Op.eval_extend ex rs#r2 a)
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros sem insnX insnS EX ES; intros. unfold arith_extended. destruct (Int.ltu a (Int.repr 5)).
+- econstructor; split.
+ apply exec_straight_one. rewrite EX; eauto. auto.
+ split. Simpl. f_equal. destruct ex; auto.
+ split; intros; Simpl.
+- exploit (exec_move_extended_base X16 r2 ex). intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ rewrite ES. eauto. auto.
+ split. Simpl. unfold ir0x. rewrite C by eauto with asmgen. f_equal.
+ rewrite B. destruct ex; auto.
+ split; intros; Simpl.
+Qed.
+
+(** Extended right shift *)
+
+Lemma exec_shrx32: forall (rd r1: ireg) (n: int) k v (rs: regset) m,
+ Val.shrx rs#r1 (Vint n) = Some v ->
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (shrx32 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = v
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ unfold shrx32; intros. apply Val.shrx_shr_3 in H.
+ destruct (Int.eq n Int.zero) eqn:E.
+- econstructor; split. apply exec_straight_one; [simpl;eauto|auto].
+ split. Simpl. subst v; auto.
+ split; intros; Simpl.
+- generalize (Int.eq_spec n Int.one).
+ destruct (Int.eq n Int.one); intro ONE.
+ * subst n.
+ econstructor; split. eapply exec_straight_two.
+ all: simpl; auto.
+ split.
+ ** subst v; Simpl.
+ destruct (Val.add _ _); simpl; trivial.
+ change (Int.ltu Int.one Int.iwordsize) with true; simpl.
+ rewrite Int.or_zero_l.
+ reflexivity.
+ ** split; intros; Simpl.
+ * econstructor; split. eapply exec_straight_three.
+ unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto.
+ simpl; eauto.
+ unfold exec_instr. rewrite or_zero_eval_shift_op_int by congruence. eauto.
+ auto. auto. auto.
+ split. subst v; Simpl.
+ split; intros; Simpl.
+Qed.
+
+Lemma exec_shrx64: forall (rd r1: ireg) (n: int) k v (rs: regset) m,
+ Val.shrxl rs#r1 (Vint n) = Some v ->
+ r1 <> X16 ->
+ (IR RA) <> (preg_of_iregsp (RR1 rd)) ->
+ exists rs',
+ exec_straight ge fn (shrx64 rd r1 n k) rs m k rs' m
+ /\ rs'#rd = v
+ /\ (forall r, data_preg r = true -> r <> rd -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ unfold shrx64; intros. apply Val.shrxl_shrl_3 in H.
+ destruct (Int.eq n Int.zero) eqn:E.
+- econstructor; split. apply exec_straight_one; [simpl;eauto|auto].
+ split. Simpl. subst v; auto.
+ split; intros; Simpl.
+- generalize (Int.eq_spec n Int.one).
+ destruct (Int.eq n Int.one); intro ONE.
+ * subst n.
+ econstructor; split. eapply exec_straight_two.
+ all: simpl; auto.
+ split.
+ ** subst v; Simpl.
+ destruct (Val.addl _ _); simpl; trivial.
+ change (Int.ltu Int.one Int64.iwordsize') with true; simpl.
+ rewrite Int64.or_zero_l.
+ reflexivity.
+ ** split; intros; Simpl.
+ * econstructor; split. eapply exec_straight_three.
+ unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto.
+ simpl; eauto.
+ unfold exec_instr. rewrite or_zero_eval_shift_op_long by congruence. eauto.
+ auto. auto. auto.
+ split. subst v; Simpl.
+ split; intros; Simpl.
+Qed.
+
+(** Condition bits *)
+
+Lemma compare_int_spec: forall rs v1 v2 m,
+ let rs' := compare_int rs v1 v2 m in
+ rs'#CN = (Val.negative (Val.sub v1 v2))
+ /\ rs'#CZ = (Val.cmpu (Mem.valid_pointer m) Ceq v1 v2)
+ /\ rs'#CC = (Val.cmpu (Mem.valid_pointer m) Cge v1 v2)
+ /\ rs'#CV = (Val.sub_overflow v1 v2).
+Proof.
+ intros; unfold rs'; auto.
+Qed.
+
+Lemma eval_testcond_compare_sint: forall c v1 v2 b rs m,
+ Val.cmp_bool c v1 v2 = Some b ->
+ eval_testcond (cond_for_signed_cmp c) (compare_int rs v1 v2 m) = Some b.
+Proof.
+ intros. generalize (compare_int_spec rs v1 v2 m).
+ set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+ destruct v1; try discriminate; destruct v2; try discriminate.
+ simpl in H; inv H.
+ unfold Val.cmpu; simpl. destruct c; simpl.
+- destruct (Int.eq i i0); auto.
+- destruct (Int.eq i i0); auto.
+- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto.
+- rewrite Int.lt_sub_overflow, Int.not_lt.
+ destruct (Int.eq i i0), (Int.lt i i0); auto.
+- rewrite Int.lt_sub_overflow, (Int.lt_not i).
+ destruct (Int.eq i i0), (Int.lt i i0); auto.
+- rewrite Int.lt_sub_overflow. destruct (Int.lt i i0); auto.
+Qed.
+
+Lemma eval_testcond_compare_uint: forall c v1 v2 b rs m,
+ Val.cmpu_bool (Mem.valid_pointer m) c v1 v2 = Some b ->
+ eval_testcond (cond_for_unsigned_cmp c) (compare_int rs v1 v2 m) = Some b.
+Proof.
+ intros. generalize (compare_int_spec rs v1 v2 m).
+ set (rs' := compare_int rs v1 v2 m). intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+ destruct v1; try discriminate; destruct v2; try discriminate.
+ simpl in H; inv H.
+ unfold Val.cmpu; simpl. destruct c; simpl.
+- destruct (Int.eq i i0); auto.
+- destruct (Int.eq i i0); auto.
+- destruct (Int.ltu i i0); auto.
+- rewrite (Int.not_ltu i). destruct (Int.eq i i0), (Int.ltu i i0); auto.
+- rewrite (Int.ltu_not i). destruct (Int.eq i i0), (Int.ltu i i0); auto.
+- destruct (Int.ltu i i0); auto.
+Qed.
+
+Lemma compare_long_spec: forall rs v1 v2 m,
+ let rs' := compare_long rs v1 v2 m in
+ rs'#CN = (Val.negativel (Val.subl v1 v2))
+ /\ rs'#CZ = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Ceq v1 v2))
+ /\ rs'#CC = (Val.maketotal (Val.cmplu (Mem.valid_pointer m) Cge v1 v2))
+ /\ rs'#CV = (Val.subl_overflow v1 v2).
+Proof.
+ intros; unfold rs'; auto.
+Qed.
+
+Remark int64_sub_overflow:
+ forall x y,
+ Int.xor (Int.repr (Int64.unsigned (Int64.sub_overflow x y Int64.zero)))
+ (Int.repr (Int64.unsigned (Int64.negative (Int64.sub x y)))) =
+ (if Int64.lt x y then Int.one else Int.zero).
+Proof.
+ intros.
+ transitivity (Int.repr (Int64.unsigned (if Int64.lt x y then Int64.one else Int64.zero))).
+ rewrite <- (Int64.lt_sub_overflow x y).
+ unfold Int64.sub_overflow, Int64.negative.
+ set (s := Int64.signed x - Int64.signed y - Int64.signed Int64.zero).
+ destruct (zle Int64.min_signed s && zle s Int64.max_signed);
+ destruct (Int64.lt (Int64.sub x y) Int64.zero);
+ auto.
+ destruct (Int64.lt x y); auto.
+Qed.
+
+Lemma eval_testcond_compare_slong: forall c v1 v2 b rs m,
+ Val.cmpl_bool c v1 v2 = Some b ->
+ eval_testcond (cond_for_signed_cmp c) (compare_long rs v1 v2 m) = Some b.
+Proof.
+ intros. generalize (compare_long_spec rs v1 v2 m).
+ set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+ destruct v1; try discriminate; destruct v2; try discriminate.
+ simpl in H; inv H.
+ unfold Val.cmplu; simpl. destruct c; simpl.
+- destruct (Int64.eq i i0); auto.
+- destruct (Int64.eq i i0); auto.
+- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto.
+- rewrite int64_sub_overflow, Int64.not_lt.
+ destruct (Int64.eq i i0), (Int64.lt i i0); auto.
+- rewrite int64_sub_overflow, (Int64.lt_not i).
+ destruct (Int64.eq i i0), (Int64.lt i i0); auto.
+- rewrite int64_sub_overflow. destruct (Int64.lt i i0); auto.
+Qed.
+
+Lemma eval_testcond_compare_ulong: forall c v1 v2 b rs m,
+ Val.cmplu_bool (Mem.valid_pointer m) c v1 v2 = Some b ->
+ eval_testcond (cond_for_unsigned_cmp c) (compare_long rs v1 v2 m) = Some b.
+Proof.
+ intros. generalize (compare_long_spec rs v1 v2 m).
+ set (rs' := compare_long rs v1 v2 m). intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E; unfold Val.cmplu.
+ destruct v1; try discriminate; destruct v2; try discriminate; simpl in H.
+- (* int-int *)
+ inv H. destruct c; simpl.
++ destruct (Int64.eq i i0); auto.
++ destruct (Int64.eq i i0); auto.
++ destruct (Int64.ltu i i0); auto.
++ rewrite (Int64.not_ltu i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto.
++ rewrite (Int64.ltu_not i). destruct (Int64.eq i i0), (Int64.ltu i i0); auto.
++ destruct (Int64.ltu i i0); auto.
+- (* int-ptr *)
+ simpl.
+ destruct (Int64.eq i Int64.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i0)
+ || Mem.valid_pointer m b0 (Ptrofs.unsigned i0 - 1))); try discriminate.
+ destruct c; simpl in H; inv H; reflexivity.
+- (* ptr-int *)
+ simpl.
+ destruct (Int64.eq i0 Int64.zero &&
+ (Mem.valid_pointer m b0 (Ptrofs.unsigned i)
+ || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1))); try discriminate.
+ destruct c; simpl in H; inv H; reflexivity.
+- (* ptr-ptr *)
+ simpl.
+ destruct (eq_block b0 b1).
++ destruct ((Mem.valid_pointer m b0 (Ptrofs.unsigned i)
+ || Mem.valid_pointer m b0 (Ptrofs.unsigned i - 1)) &&
+ (Mem.valid_pointer m b1 (Ptrofs.unsigned i0)
+ || Mem.valid_pointer m b1 (Ptrofs.unsigned i0 - 1)));
+ inv H.
+ destruct c; simpl.
+* destruct (Ptrofs.eq i i0); auto.
+* destruct (Ptrofs.eq i i0); auto.
+* destruct (Ptrofs.ltu i i0); auto.
+* rewrite (Ptrofs.not_ltu i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto.
+* rewrite (Ptrofs.ltu_not i). destruct (Ptrofs.eq i i0), (Ptrofs.ltu i i0); auto.
+* destruct (Ptrofs.ltu i i0); auto.
++ destruct (Mem.valid_pointer m b0 (Ptrofs.unsigned i) &&
+ Mem.valid_pointer m b1 (Ptrofs.unsigned i0)); try discriminate.
+ destruct c; simpl in H; inv H; reflexivity.
+Qed.
+
+Lemma compare_float_spec: forall rs f1 f2,
+ let rs' := compare_float rs (Vfloat f1) (Vfloat f2) in
+ rs'#CN = (Val.of_bool (Float.cmp Clt f1 f2))
+ /\ rs'#CZ = (Val.of_bool (Float.cmp Ceq f1 f2))
+ /\ rs'#CC = (Val.of_bool (negb (Float.cmp Clt f1 f2)))
+ /\ rs'#CV = (Val.of_bool (negb (Float.ordered f1 f2))).
+Proof.
+ intros; auto.
+Qed.
+
+Lemma eval_testcond_compare_float: forall c v1 v2 b rs,
+ Val.cmpf_bool c v1 v2 = Some b ->
+ eval_testcond (cond_for_float_cmp c) (compare_float rs v1 v2) = Some b.
+Proof.
+ intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H.
+ generalize (compare_float_spec rs f f0).
+ set (rs' := compare_float rs (Vfloat f) (Vfloat f0)).
+ intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+Local Transparent Float.cmp Float.ordered.
+ unfold Float.cmp, Float.ordered;
+ destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity.
+Qed.
+
+Lemma eval_testcond_compare_not_float: forall c v1 v2 b rs,
+ option_map negb (Val.cmpf_bool c v1 v2) = Some b ->
+ eval_testcond (cond_for_float_not_cmp c) (compare_float rs v1 v2) = Some b.
+Proof.
+ intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H.
+ generalize (compare_float_spec rs f f0).
+ set (rs' := compare_float rs (Vfloat f) (Vfloat f0)).
+ intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+Local Transparent Float.cmp Float.ordered.
+ unfold Float.cmp, Float.ordered;
+ destruct c; destruct (Float.compare f f0) as [[]|]; reflexivity.
+Qed.
+
+Lemma compare_single_spec: forall rs f1 f2,
+ let rs' := compare_single rs (Vsingle f1) (Vsingle f2) in
+ rs'#CN = (Val.of_bool (Float32.cmp Clt f1 f2))
+ /\ rs'#CZ = (Val.of_bool (Float32.cmp Ceq f1 f2))
+ /\ rs'#CC = (Val.of_bool (negb (Float32.cmp Clt f1 f2)))
+ /\ rs'#CV = (Val.of_bool (negb (Float32.ordered f1 f2))).
+Proof.
+ intros; auto.
+Qed.
+
+Lemma eval_testcond_compare_single: forall c v1 v2 b rs,
+ Val.cmpfs_bool c v1 v2 = Some b ->
+ eval_testcond (cond_for_float_cmp c) (compare_single rs v1 v2) = Some b.
+Proof.
+ intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H.
+ generalize (compare_single_spec rs f f0).
+ set (rs' := compare_single rs (Vsingle f) (Vsingle f0)).
+ intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+Local Transparent Float32.cmp Float32.ordered.
+ unfold Float32.cmp, Float32.ordered;
+ destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity.
+Qed.
+
+Lemma eval_testcond_compare_not_single: forall c v1 v2 b rs,
+ option_map negb (Val.cmpfs_bool c v1 v2) = Some b ->
+ eval_testcond (cond_for_float_not_cmp c) (compare_single rs v1 v2) = Some b.
+Proof.
+ intros. destruct v1; try discriminate; destruct v2; simpl in H; inv H.
+ generalize (compare_single_spec rs f f0).
+ set (rs' := compare_single rs (Vsingle f) (Vsingle f0)).
+ intros (B & C & D & E).
+ unfold eval_testcond; rewrite B, C, D, E.
+Local Transparent Float32.cmp Float32.ordered.
+ unfold Float32.cmp, Float32.ordered;
+ destruct c; destruct (Float32.compare f f0) as [[]|]; reflexivity.
+Qed.
+
+Remark compare_float_inv: forall rs v1 v2 r,
+ match r with CR _ => False | _ => True end ->
+ (nextinstr (compare_float rs v1 v2))#r = (nextinstr rs)#r.
+Proof.
+ intros; unfold compare_float.
+ destruct r; try contradiction; destruct v1; auto; destruct v2; auto.
+Qed.
+
+Remark compare_single_inv: forall rs v1 v2 r,
+ match r with CR _ => False | _ => True end ->
+ (nextinstr (compare_single rs v1 v2))#r = (nextinstr rs)#r.
+Proof.
+ intros; unfold compare_single.
+ destruct r; try contradiction; destruct v1; auto; destruct v2; auto.
+Qed.
+
+(** Translation of conditionals *)
+
+Ltac ArgsInv :=
+ repeat (match goal with
+ | [ H: Error _ = OK _ |- _ ] => discriminate
+ | [ H: match ?args with nil => _ | _ :: _ => _ end = OK _ |- _ ] => destruct args
+ | [ H: bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+ | [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
+ end);
+ subst;
+ repeat (match goal with
+ | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *
+ | [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
+ end).
+
+Lemma compare_int_RA:
+ forall rs a b m,
+ compare_int rs a b m X30 = rs X30.
+Proof.
+ unfold compare_int.
+ intros.
+ repeat rewrite Pregmap.gso by congruence.
+ trivial.
+Qed.
+
+Hint Resolve compare_int_RA : asmgen.
+
+Lemma compare_long_RA:
+ forall rs a b m,
+ compare_long rs a b m X30 = rs X30.
+Proof.
+ unfold compare_long.
+ intros.
+ repeat rewrite Pregmap.gso by congruence.
+ trivial.
+Qed.
+
+Hint Resolve compare_long_RA : asmgen.
+
+Lemma compare_float_RA:
+ forall rs a b,
+ compare_float rs a b X30 = rs X30.
+Proof.
+ unfold compare_float.
+ intros.
+ destruct a; destruct b.
+ all: repeat rewrite Pregmap.gso by congruence; trivial.
+Qed.
+
+Hint Resolve compare_float_RA : asmgen.
+
+
+Lemma compare_single_RA:
+ forall rs a b,
+ compare_single rs a b X30 = rs X30.
+Proof.
+ unfold compare_single.
+ intros.
+ destruct a; destruct b.
+ all: repeat rewrite Pregmap.gso by congruence; trivial.
+Qed.
+
+Hint Resolve compare_single_RA : asmgen.
+
+
+Lemma transl_cond_correct:
+ forall cond args k c rs m,
+ transl_cond cond args k = OK c ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ (forall b,
+ eval_condition cond (map rs (map preg_of args)) m = Some b ->
+ eval_testcond (cond_for_cond cond) rs' = Some b)
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros until m; intros TR. destruct cond; simpl in TR; ArgsInv.
+- (* Ccomp *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_sint; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccompu *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_uint; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccompimm *)
+ destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))].
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_sint; auto.
+ destruct r; reflexivity || discriminate.
++ econstructor; split.
+ apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_sint; auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_sint; auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate.
+ auto with asmgen.
+ Simpl. rewrite compare_int_RA.
+ apply C; congruence.
+- (* Ccompuimm *)
+ destruct (is_arith_imm32 n); [|destruct (is_arith_imm32 (Int.neg n))].
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int.repr_unsigned. apply eval_testcond_compare_uint; auto.
+ destruct r; reflexivity || discriminate.
++ econstructor; split.
+ apply exec_straight_one. simpl. rewrite Int.repr_unsigned, Int.neg_involutive. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_uint; auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_uint; auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_int_RA.
+ apply C; congruence.
+- (* Ccompshift *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_sint; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccompushift *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite transl_eval_shift. apply eval_testcond_compare_uint; auto.
+ destruct r; reflexivity || discriminate.
+- (* Cmaskzero *)
+ destruct (is_logical_imm32 n).
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Ceq); auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply (eval_testcond_compare_sint Ceq); auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_int_RA.
+ apply C; congruence.
+
+- (* Cmasknotzero *)
+ destruct (is_logical_imm32 n).
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int.repr_unsigned. apply (eval_testcond_compare_sint Cne); auto.
+ destruct r; reflexivity || discriminate.
+
++ exploit (exec_loadimm32 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply (eval_testcond_compare_sint Cne); auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_int_RA.
+ apply C; congruence.
+
+- (* Ccompl *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_slong; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccomplu *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_ulong; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccomplimm *)
+ destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))].
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_slong; auto.
+ destruct r; reflexivity || discriminate.
++ econstructor; split.
+ apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_slong; auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_slong; auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_long_RA.
+ apply C; congruence.
+
+- (* Ccompluimm *)
+ destruct (is_arith_imm64 n); [|destruct (is_arith_imm64 (Int64.neg n))].
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int64.repr_unsigned. apply eval_testcond_compare_ulong; auto.
+ destruct r; reflexivity || discriminate.
++ econstructor; split.
+ apply exec_straight_one. simpl. rewrite Int64.repr_unsigned, Int64.neg_involutive. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_ulong; auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one.
+ simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply eval_testcond_compare_ulong; auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_long_RA.
+ apply C; congruence.
+
+- (* Ccomplshift *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_slong; auto.
+ destruct r; reflexivity || discriminate.
+- (* Ccomplushift *)
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite transl_eval_shiftl. apply eval_testcond_compare_ulong; auto.
+ destruct r; reflexivity || discriminate.
+- (* Cmasklzero *)
+ destruct (is_logical_imm64 n).
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Ceq); auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply (eval_testcond_compare_slong Ceq); auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_long_RA.
+ apply C; congruence.
+
+- (* Cmasknotzero *)
+ destruct (is_logical_imm64 n).
++ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ repeat split; intros. rewrite Int64.repr_unsigned. apply (eval_testcond_compare_slong Cne); auto.
+ destruct r; reflexivity || discriminate.
++ exploit (exec_loadimm64 X16 n). congruence. intros (rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A.
+ apply exec_straight_one. simpl. rewrite B, C by eauto with asmgen. eauto. auto.
+ repeat split; intros. apply (eval_testcond_compare_slong Cne); auto.
+ transitivity (rs' r). destruct r; reflexivity || discriminate. auto with asmgen.
+ Simpl. rewrite compare_long_RA.
+ apply C; congruence.
+
+- (* Ccompf *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_float_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_float; auto.
+ destruct r; discriminate || rewrite compare_float_inv; auto.
+ Simpl.
+- (* Cnotcompf *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_float_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_not_float; auto.
+ destruct r; discriminate || rewrite compare_float_inv; auto.
+ Simpl.
+- (* Ccompfzero *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_float_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_float; auto.
+ destruct r; discriminate || rewrite compare_float_inv; auto.
+ Simpl.
+- (* Cnotcompfzero *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_float_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_not_float; auto.
+ destruct r; discriminate || rewrite compare_float_inv; auto.
+ Simpl.
+- (* Ccompfs *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_single_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_single; auto.
+ destruct r; discriminate || rewrite compare_single_inv; auto.
+ Simpl.
+- (* Cnotcompfs *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_single_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_not_single; auto.
+ destruct r; discriminate || rewrite compare_single_inv; auto.
+ Simpl.
+- (* Ccompfszero *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_single_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_single; auto.
+ destruct r; discriminate || rewrite compare_single_inv; auto.
+ Simpl.
+- (* Cnotcompfszero *)
+ econstructor; split. apply exec_straight_one. simpl; eauto.
+ rewrite compare_single_inv; auto.
+ repeat split; intros. apply eval_testcond_compare_not_single; auto.
+ destruct r; discriminate || rewrite compare_single_inv; auto.
+ Simpl.
+Qed.
+
+(** Translation of conditional branches *)
+
+Lemma transl_cond_branch_correct:
+ forall cond args lbl k c rs m b,
+ transl_cond_branch cond args lbl k = OK c ->
+ eval_condition cond (map rs (map preg_of args)) m = Some b ->
+ exists rs' insn,
+ exec_straight_opt ge fn c rs m (insn :: k) rs' m
+ /\ exec_instr ge fn insn rs' m =
+ (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m)
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros until b; intros TR EV.
+ assert (DFL:
+ transl_cond_branch_default cond args lbl k = OK c ->
+ exists rs' insn,
+ exec_straight_opt ge fn c rs m (insn :: k) rs' m
+ /\ exec_instr ge fn insn rs' m =
+ (if b then goto_label fn lbl rs' m else Next (nextinstr rs') m)
+ /\ (forall r, data_preg r = true -> rs'#r = rs#r)
+ /\ rs' # RA = rs # RA ).
+ {
+ unfold transl_cond_branch_default; intros.
+ exploit transl_cond_correct; eauto. intros (rs' & A & B & C & D).
+ exists rs', (Pbc (cond_for_cond cond) lbl); split.
+ apply exec_straight_opt_intro. eexact A.
+ repeat split; auto. simpl. rewrite (B b) by auto. auto.
+ }
+Local Opaque transl_cond transl_cond_branch_default.
+ destruct args as [ | a1 args]; simpl in TR; auto.
+ destruct args as [ | a2 args]; simpl in TR; auto.
+ destruct cond; simpl in TR; auto.
+- (* Ccompimm *)
+ destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto;
+ apply Int.same_if_eq in N0; subst n; ArgsInv.
++ (* Ccompimm Cne 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto.
++ (* Ccompimm Ceq 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int.eq i Int.zero); auto.
+- (* Ccompuimm *)
+ destruct c0; auto; destruct (Int.eq n Int.zero) eqn:N0; auto;
+ apply Int.same_if_eq in N0; subst n; ArgsInv.
++ (* Ccompuimm Cne 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. rewrite EV. auto.
++ (* Ccompuimm Ceq 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. rewrite (Val.negate_cmpu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto.
+- (* Cmaskzero *)
+ destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv.
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl.
+ erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto.
+ rewrite (Val.negate_cmp_bool Ceq), EV. destruct b; auto.
+- (* Cmasknotzero *)
+ destruct (Int.is_power2 n) as [bit|] eqn:P2; auto. ArgsInv.
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl.
+ erewrite <- Int.mul_pow2, Int.mul_commut, Int.mul_one by eauto.
+ rewrite EV. auto.
+- (* Ccomplimm *)
+ destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto;
+ apply Int64.same_if_eq in N0; subst n; ArgsInv.
++ (* Ccomplimm Cne 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. auto.
++ (* Ccomplimm Ceq 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. destruct (rs x); simpl in EV; inv EV. simpl. destruct (Int64.eq i Int64.zero); auto.
+- (* Ccompluimm *)
+ destruct c0; auto; destruct (Int64.eq n Int64.zero) eqn:N0; auto;
+ apply Int64.same_if_eq in N0; subst n; ArgsInv.
++ (* Ccompluimm Cne 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. rewrite EV. auto.
++ (* Ccompluimm Ceq 0 *)
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl. rewrite (Val.negate_cmplu_bool (Mem.valid_pointer m) Cne), EV. destruct b; auto.
+- (* Cmasklzero *)
+ destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv.
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl.
+ erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto.
+ rewrite (Val.negate_cmpl_bool Ceq), EV. destruct b; auto.
+- (* Cmasklnotzero *)
+ destruct (Int64.is_power2' n) as [bit|] eqn:P2; auto. ArgsInv.
+ do 2 econstructor; split.
+ apply exec_straight_opt_refl.
+ split; auto. simpl.
+ erewrite <- Int64.mul_pow2', Int64.mul_commut, Int64.mul_one by eauto.
+ rewrite EV. auto.
+Qed.
+
+(** Translation of arithmetic operations *)
+
+Ltac SimplEval H :=
+ match type of H with
+ | Some _ = None _ => discriminate
+ | Some _ = Some _ => inv H
+ | ?a = Some ?b => let A := fresh in assert (A: Val.maketotal a = b) by (rewrite H; reflexivity)
+end.
+
+Ltac TranslOpSimpl :=
+ econstructor; split;
+ [ apply exec_straight_one; [simpl; eauto | reflexivity]
+ | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl;
+ apply Val.lessdef_same; Simpl; fail
+ | split; [ intros; Simpl; fail
+ | intros; Simpl; eauto with asmgen; fail] ]].
+
+Ltac TranslOpBase :=
+ econstructor; split;
+ [ apply exec_straight_one; [simpl; eauto | reflexivity]
+ | split; [ rewrite ? transl_eval_shift, ? transl_eval_shiftl; Simpl
+ | split; [ intros; Simpl; fail
+ | intros; Simpl; eapply RA_not_written2; eauto] ]].
+
+Lemma transl_op_correct:
+ forall op args res k (rs: regset) m v c,
+ transl_op op args res k = OK c ->
+ eval_operation ge (rs#SP) op (map rs (map preg_of args)) m = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef v rs'#(preg_of res)
+ /\ (forall r, data_preg r = true -> r <> preg_of res -> preg_notin r (destroyed_by_op op) -> rs' r = rs r)
+ /\ rs' RA = rs RA.
+Proof.
+Local Opaque Int.eq Int64.eq Val.add Val.addl Int.zwordsize Int64.zwordsize.
+ intros until c; intros TR EV.
+ unfold transl_op in TR; destruct op; ArgsInv; simpl in EV; SimplEval EV; try TranslOpSimpl.
+- (* move *)
+ destruct (preg_of res) eqn:RR; try discriminate; destruct (preg_of m0) eqn:R1; inv TR.
+ all: TranslOpSimpl.
+- (* intconst *)
+ exploit exec_loadimm32. apply (ireg_of_not_RA res); eassumption.
+ intros (rs' & A & B & C).
+ exists rs'; split. eexact A. split. rewrite B; auto.
+ split. intros; auto with asmgen.
+ apply C. congruence.
+ eapply ireg_of_not_RA''; eauto.
+- (* longconst *)
+ exploit exec_loadimm64. apply (ireg_of_not_RA res); eassumption.
+ intros (rs' & A & B & C).
+ exists rs'; split. eexact A. split. rewrite B; auto.
+ split. intros; auto with asmgen.
+ apply C. congruence.
+ eapply ireg_of_not_RA''; eauto.
+- (* floatconst *)
+ destruct (Float.eq_dec n Float.zero).
++ subst n. TranslOpSimpl.
++ TranslOpSimpl.
+- (* singleconst *)
+ destruct (Float32.eq_dec n Float32.zero).
++ subst n. TranslOpSimpl.
++ TranslOpSimpl.
+- (* loadsymbol *)
+ exploit (exec_loadsymbol x id ofs). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* addrstack *)
+ exploit (exec_addimm64 x XSP (Ptrofs.to_int64 ofs)). simpl; eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. simpl in B; rewrite B.
+Local Transparent Val.addl.
+ destruct (rs SP); simpl; auto. rewrite Ptrofs.of_int64_to_int64 by auto. auto.
+ auto.
+- (* shift *)
+ rewrite <- transl_eval_shift'. TranslOpSimpl.
+- (* addimm *)
+ exploit (exec_addimm32 x x0 n). eauto with asmgen. eapply ireg_of_not_RA''; eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto. auto.
+- (* mul *)
+ TranslOpBase.
+Local Transparent Val.add.
+ destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int.add_zero_l; auto.
+- (* andimm *)
+ exploit (exec_logicalimm32 (Pandimm W) (Pand W)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* orimm *)
+ exploit (exec_logicalimm32 (Porrimm W) (Porr W)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* xorimm *)
+ exploit (exec_logicalimm32 (Peorimm W) (Peor W)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto. auto.
+- (* not *)
+ TranslOpBase.
+ destruct (rs x0); auto. simpl. rewrite Int.or_zero_l; auto.
+- (* notshift *)
+ TranslOpBase.
+ destruct (eval_shift s (rs x0) a); auto. simpl. rewrite Int.or_zero_l; auto.
+- (* shrx *)
+ exploit (exec_shrx32 x x0 n); eauto with asmgen. apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ econstructor; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* zero-ext *)
+ TranslOpBase.
+ destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto.
+- (* sign-ext *)
+ TranslOpBase.
+ destruct (rs x0); auto; simpl. rewrite Int.shl_zero. auto.
+- (* shlzext *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite <- Int.shl_zero_ext_min; auto using a32_range.
+- (* shlsext *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite <- Int.shl_sign_ext_min; auto using a32_range.
+- (* zextshr *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.zero_ext_shru_min; auto using a32_range.
+- (* sextshr *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite ! a32_range; simpl. rewrite <- Int.sign_ext_shr_min; auto using a32_range.
+- (* shiftl *)
+ rewrite <- transl_eval_shiftl'. TranslOpSimpl.
+- (* extend *)
+ exploit (exec_move_extended x0 x1 x a k). intros (rs' & A & B & C).
+ econstructor; split. eexact A.
+ split. rewrite B; auto.
+ split; eauto with asmgen.
+- (* addext *)
+ exploit (exec_arith_extended Val.addl Paddext (Padd X)).
+ auto. auto. instantiate (1 := x1). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ econstructor; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* addlimm *)
+ exploit (exec_addimm64 x x0 n). simpl. generalize (ireg_of_not_X16 _ _ EQ1). congruence.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. simpl in B; rewrite B; auto. auto.
+- (* subext *)
+ exploit (exec_arith_extended Val.subl Psubext (Psub X)).
+ auto. auto. instantiate (1 := x1). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ econstructor; split. eexact A. split. rewrite B; auto.
+ split; auto.
+- (* mull *)
+ TranslOpBase.
+ destruct (rs x0); auto; destruct (rs x1); auto. simpl. rewrite Int64.add_zero_l; auto.
+- (* andlimm *)
+ exploit (exec_logicalimm64 (Pandimm X) (Pand X)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto. auto.
+- (* orlimm *)
+ exploit (exec_logicalimm64 (Porrimm X) (Porr X)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto. auto.
+- (* xorlimm *)
+ exploit (exec_logicalimm64 (Peorimm X) (Peor X)).
+ intros; reflexivity. intros; reflexivity. instantiate (1 := x0). eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption.
+ intros (rs' & A & B & C & D).
+ exists rs'; split. eexact A. split. rewrite B; auto. auto.
+- (* notl *)
+ TranslOpBase.
+ destruct (rs x0); auto. simpl. rewrite Int64.or_zero_l; auto.
+- (* notlshift *)
+ TranslOpBase.
+ destruct (eval_shiftl s (rs x0) a); auto. simpl. rewrite Int64.or_zero_l; auto.
+- (* shrx *)
+ exploit (exec_shrx64 x x0 n); eauto with asmgen.
+ apply (ireg_of_not_RA'' res); eassumption. intros (rs' & A & B & C & D ).
+ econstructor; split. eexact A. split. rewrite B; auto. auto.
+- (* zero-ext-l *)
+ TranslOpBase.
+ destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto.
+- (* sign-ext-l *)
+ TranslOpBase.
+ destruct (rs x0); auto; simpl. rewrite Int64.shl'_zero. auto.
+- (* shllzext *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_zero_ext_min; auto using a64_range.
+- (* shllsext *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite <- Int64.shl'_sign_ext_min; auto using a64_range.
+- (* zextshrl *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.zero_ext_shru'_min; auto using a64_range.
+- (* sextshrl *)
+ TranslOpBase.
+ destruct (rs x0); simpl; auto. rewrite ! a64_range; simpl. rewrite <- Int64.sign_ext_shr'_min; auto using a64_range.
+- (* condition *)
+ exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *.
+ rewrite (B b) by auto. auto.
+ auto.
+ split; intros; Simpl.
+- (* select *)
+ destruct (preg_of res) eqn:RES; monadInv TR.
+ + (* integer *)
+ generalize (ireg_of_eq _ _ EQ) (ireg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2.
+ exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *.
+ rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize.
+ rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen.
+ auto.
+ split; intros; Simpl.
+ rewrite <- D.
+ eapply RA_not_written2; eassumption.
+ + (* FP *)
+ generalize (freg_of_eq _ _ EQ) (freg_of_eq _ _ EQ1); intros E1 E2; rewrite E1, E2.
+ exploit (transl_cond_correct cond args); eauto. intros (rs' & A & B & C & D).
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split. Simpl. destruct (eval_condition cond (map rs (map preg_of args)) m) as [b|]; simpl in *.
+ rewrite (B b) by auto. rewrite !C. apply Val.lessdef_normalize.
+ rewrite <- E2; auto with asmgen. rewrite <- E1; auto with asmgen.
+ auto.
+ split; intros; Simpl.
+Qed.
+
+(** Translation of addressing modes, loads, stores *)
+
+Lemma transl_addressing_correct:
+ forall sz addr args (insn: Asm.addressing -> instruction) k (rs: regset) m c b o,
+ transl_addressing sz addr args insn k = OK c ->
+ Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some (Vptr b o) ->
+ exists ad rs',
+ exec_straight_opt ge fn c rs m (insn ad :: k) rs' m
+ /\ Asm.eval_addressing ge ad rs' = Vptr b o
+ /\ (forall r, data_preg r = true -> rs' r = rs r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros until o; intros TR EV.
+ unfold transl_addressing in TR; destruct addr; ArgsInv; SimplEval EV.
+- (* Aindexed *)
+ destruct (offset_representable sz ofs); inv EQ0.
++ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ auto.
++ exploit (exec_loadimm64 X16 ofs). congruence. intros (rs' & A & B & C).
+ econstructor; exists rs'; split. apply exec_straight_opt_intro; eexact A.
+ split. simpl. rewrite B, C by eauto with asmgen. auto.
+ split; eauto with asmgen.
+- (* Aindexed2 *)
+ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ auto.
+- (* Aindexed2shift *)
+ destruct (Int.eq a Int.zero) eqn:E; [|destruct (Int.eq (Int.shl Int.one a) (Int.repr sz))]; inv EQ2.
++ apply Int.same_if_eq in E. rewrite E.
+ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ split; auto. simpl.
+ rewrite Val.addl_commut in H0. destruct (rs x0); try discriminate.
+ unfold Val.shll. rewrite Int64.shl'_zero. auto.
++ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ auto.
++ econstructor; econstructor; split.
+ apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto.
+ split. simpl. Simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero. auto.
+ split; intros; Simpl.
+- (* Aindexed2ext *)
+ destruct (Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz)); inv EQ2.
++ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ split; auto. destruct x; auto.
++ exploit (exec_arith_extended Val.addl Paddext (Padd X)); auto.
+ instantiate (1 := x0). eauto with asmgen.
+ instantiate (1 := X16). simpl. congruence.
+ intros (rs' & A & B & C & D).
+ econstructor; exists rs'; split.
+ apply exec_straight_opt_intro. eexact A.
+ split. simpl. rewrite B. rewrite Val.addl_assoc. f_equal.
+ unfold Op.eval_extend; destruct x, (rs x1); simpl; auto; rewrite ! a64_range;
+ simpl; rewrite Int64.add_zero; auto.
+ split; intros.
+ apply C; eauto with asmgen.
+ trivial.
+- (* Aglobal *)
+ destruct (Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz); inv TR.
++ econstructor; econstructor; split.
+ apply exec_straight_opt_intro. apply exec_straight_one. simpl; eauto. auto.
+ split. simpl. Simpl. rewrite symbol_high_low. simpl in EV. congruence.
+ split; intros; Simpl.
++ exploit (exec_loadsymbol X16 id ofs). auto.
+ simpl. congruence.
+ intros (rs' & A & B & C & D).
+ econstructor; exists rs'; split.
+ apply exec_straight_opt_intro. eexact A.
+ split. simpl.
+ rewrite B. rewrite <- Genv.shift_symbol_address_64, Ptrofs.add_zero by auto.
+ simpl in EV. congruence.
+ split; auto with asmgen.
+- (* Ainstrack *)
+ assert (E: Val.addl (rs SP) (Vlong (Ptrofs.to_int64 ofs)) = Vptr b o).
+ { simpl in EV. inv EV. destruct (rs SP); simpl in H1; inv H1. simpl.
+ rewrite Ptrofs.of_int64_to_int64 by auto. auto. }
+ destruct (offset_representable sz (Ptrofs.to_int64 ofs)); inv TR.
++ econstructor; econstructor; split. apply exec_straight_opt_refl.
+ auto.
++ exploit (exec_loadimm64 X16 (Ptrofs.to_int64 ofs)).
+ simpl. congruence.
+ intros (rs' & A & B & C).
+ econstructor; exists rs'; split.
+ apply exec_straight_opt_intro. eexact A.
+ split. simpl. rewrite B, C by eauto with asmgen. auto.
+ auto with asmgen.
+Qed.
+
+Lemma transl_load_correct:
+ forall chunk addr args dst k c (rs: regset) m vaddr v,
+ transl_load TRAP chunk addr args dst k = OK c ->
+ Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr ->
+ Mem.loadv chunk m vaddr = Some v ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros. destruct vaddr; try discriminate.
+ assert (A: exists sz insn,
+ transl_addressing sz addr args insn k = OK c
+ /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m =
+ exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m)).
+ {
+ destruct chunk; monadInv H;
+ try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ);
+ do 2 econstructor; (split; [eassumption|auto]).
+ }
+ destruct A as (sz & insn & B & C).
+ exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S).
+ assert (X: exec_load ge chunk (fun v => v) ad (preg_of dst) rs' m =
+ Next (nextinstr (rs'#(preg_of dst) <- v)) m).
+ { unfold exec_load. rewrite Q, H1. auto. }
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact P.
+ apply exec_straight_one. rewrite C, X; eauto. Simpl.
+ split. Simpl.
+ split; intros; Simpl.
+ rewrite <- S.
+ apply RA_not_written.
+Qed.
+
+Lemma transl_store_correct:
+ forall chunk addr args src k c (rs: regset) m vaddr m',
+ transl_store chunk addr args src k = OK c ->
+ Op.eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some vaddr ->
+ Mem.storev chunk m vaddr rs#(preg_of src) = Some m' ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ (forall r, data_preg r = true -> rs' r = rs r)
+ /\ rs' # RA = rs # RA.
+Proof.
+ intros. destruct vaddr; try discriminate.
+ set (chunk' := match chunk with Mint8signed => Mint8unsigned
+ | Mint16signed => Mint16unsigned
+ | _ => chunk end).
+ assert (A: exists sz insn,
+ transl_addressing sz addr args insn k = OK c
+ /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m =
+ exec_store ge chunk' ad rs'#(preg_of src) rs' m)).
+ {
+ unfold chunk'; destruct chunk; monadInv H;
+ try rewrite (ireg_of_eq _ _ EQ); try rewrite (freg_of_eq _ _ EQ);
+ do 2 econstructor; (split; [eassumption|auto]).
+ }
+ destruct A as (sz & insn & B & C).
+ exploit transl_addressing_correct. eexact B. eexact H0. intros (ad & rs' & P & Q & R & S).
+ assert (X: Mem.storev chunk' m (Vptr b i) rs#(preg_of src) = Some m').
+ { rewrite <- H1. unfold chunk'. destruct chunk; auto; simpl; symmetry.
+ apply Mem.store_signed_unsigned_8.
+ apply Mem.store_signed_unsigned_16. }
+ assert (Y: exec_store ge chunk' ad rs'#(preg_of src) rs' m =
+ Next (nextinstr rs') m').
+ { unfold exec_store. rewrite Q, R, X by auto with asmgen. auto. }
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact P.
+ apply exec_straight_one. rewrite C, Y; eauto. Simpl.
+ split; intros; Simpl.
+Qed.
+
+(** Translation of indexed memory accesses *)
+
+Lemma indexed_memory_access_correct: forall insn sz (base: iregsp) ofs k (rs: regset) m b i,
+ preg_of_iregsp base <> IR X16 ->
+ Val.offset_ptr rs#base ofs = Vptr b i ->
+ exists ad rs',
+ exec_straight_opt ge fn (indexed_memory_access insn sz base ofs k) rs m (insn ad :: k) rs' m
+ /\ Asm.eval_addressing ge ad rs' = Vptr b i
+ /\ forall r, r <> PC -> r <> X16 -> rs' r = rs r.
+Proof.
+ unfold indexed_memory_access; intros.
+ assert (Val.addl rs#base (Vlong (Ptrofs.to_int64 ofs)) = Vptr b i).
+ { destruct (rs base); try discriminate. simpl in *. rewrite Ptrofs.of_int64_to_int64 by auto. auto. }
+ destruct offset_representable.
+- econstructor; econstructor; split. apply exec_straight_opt_refl. auto.
+- exploit (exec_loadimm64 X16); eauto.
+ simpl. congruence.
+ intros (rs' & A & B & C).
+ econstructor; econstructor; split. apply exec_straight_opt_intro; eexact A.
+ split. simpl. rewrite B, C by eauto with asmgen. auto. auto.
+Qed.
+
+Lemma loadptr_correct: forall (base: iregsp) ofs dst k m v (rs: regset),
+ Mem.loadv Mint64 m (Val.offset_ptr rs#base ofs) = Some v ->
+ preg_of_iregsp base <> IR X16 ->
+ exists rs',
+ exec_straight ge fn (loadptr base ofs dst k) rs m k rs' m
+ /\ rs'#dst = v
+ /\ (forall r, r <> PC -> r <> X16 -> r <> dst -> rs' r = rs r).
+Proof.
+ intros.
+ destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate.
+ exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A.
+ apply exec_straight_one. simpl. unfold exec_load. rewrite B, H. eauto. auto.
+ split. Simpl.
+ intros; Simpl.
+Qed.
+
+Lemma storeptr_correct: forall (base: iregsp) ofs (src: ireg) k m m' (rs: regset),
+ Mem.storev Mint64 m (Val.offset_ptr rs#base ofs) rs#src = Some m' ->
+ preg_of_iregsp base <> IR X16 ->
+ src <> X16 ->
+ exists rs',
+ exec_straight ge fn (storeptr src base ofs k) rs m k rs' m'
+ /\ (forall r, r <> PC -> r <> X16 -> rs' r = rs r)
+ /\ rs' RA = rs RA.
+Proof.
+ intros.
+ destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate.
+ exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A.
+ apply exec_straight_one. simpl. unfold exec_store. rewrite B, C, H by eauto with asmgen. eauto. auto.
+ split; intros; Simpl.
+Qed.
+
+Lemma loadind_correct: forall (base: iregsp) ofs ty dst k c (rs: regset) m v,
+ loadind base ofs ty dst k = OK c ->
+ Mem.loadv (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) = Some v ->
+ preg_of_iregsp base <> IR X16 ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ rs'#(preg_of dst) = v
+ /\ (forall r, data_preg r = true -> r <> preg_of dst -> rs' r = rs r)
+ /\ rs' RA = rs RA.
+Proof.
+ intros.
+ destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate.
+ assert (X: exists sz insn,
+ c = indexed_memory_access insn sz base ofs k
+ /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m =
+ exec_load ge (chunk_of_type ty) (fun v => v) ad (preg_of dst) rs' m)).
+ {
+ unfold loadind in H; destruct ty; destruct (preg_of dst); inv H; do 2 econstructor; eauto.
+ }
+ destruct X as (sz & insn & EQ & SEM). subst c.
+ exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A.
+ apply exec_straight_one. rewrite SEM. unfold exec_load. rewrite B, H0. eauto. Simpl.
+ split. Simpl.
+ split. intros; Simpl.
+ Simpl. rewrite RA_not_written.
+ apply C; congruence.
+Qed.
+
+Lemma storeind_correct: forall (base: iregsp) ofs ty src k c (rs: regset) m m',
+ storeind src base ofs ty k = OK c ->
+ Mem.storev (chunk_of_type ty) m (Val.offset_ptr rs#base ofs) rs#(preg_of src) = Some m' ->
+ preg_of_iregsp base <> IR X16 ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m'
+ /\ (forall r, data_preg r = true -> rs' r = rs r)
+ /\ rs' RA = rs RA.
+Proof.
+ intros.
+ destruct (Val.offset_ptr rs#base ofs) eqn:V; try discriminate.
+ assert (X: exists sz insn,
+ c = indexed_memory_access insn sz base ofs k
+ /\ (forall ad rs', exec_instr ge fn (insn ad) rs' m =
+ exec_store ge (chunk_of_type ty) ad rs'#(preg_of src) rs' m)).
+ {
+ unfold storeind in H; destruct ty; destruct (preg_of src); inv H; do 2 econstructor; eauto.
+ }
+ destruct X as (sz & insn & EQ & SEM). subst c.
+ exploit indexed_memory_access_correct; eauto. intros (ad & rs' & A & B & C).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A.
+ apply exec_straight_one. rewrite SEM.
+ unfold exec_store. rewrite B, C, H0 by eauto with asmgen. eauto.
+ Simpl.
+ split. intros; Simpl.
+ Simpl.
+Qed.
+
+Lemma make_epilogue_correct:
+ forall ge0 f m stk soff cs m' ms rs k tm,
+ (is_leaf_function f = true -> rs # (IR RA) = parent_ra cs) ->
+ load_stack m (Vptr stk soff) Tptr f.(fn_link_ofs) = Some (parent_sp cs) ->
+ ((* FIXME is_leaf_function f = false -> *) load_stack m (Vptr stk soff) Tptr f.(fn_retaddr_ofs) = Some (parent_ra cs)) ->
+ Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
+ agree ms (Vptr stk soff) rs ->
+ Mem.extends m tm ->
+ match_stack ge0 cs ->
+ exists rs', exists tm',
+ exec_straight ge fn (make_epilogue f k) rs tm k rs' tm'
+ /\ agree ms (parent_sp cs) rs'
+ /\ Mem.extends m' tm'
+ /\ rs'#RA = parent_ra cs
+ /\ rs'#SP = parent_sp cs
+ /\ (forall r, r <> PC -> r <> SP -> r <> RA -> r <> X16 -> rs'#r = rs#r).
+Proof.
+ intros until tm; intros LEAF_RA LP LRA FREE AG MEXT MCS.
+
+ (* FIXME
+ Cannot be used at this point
+ destruct (is_leaf_function f) eqn:IS_LEAF.
+ {
+ exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP').
+ exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'.
+ exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT').
+ unfold make_epilogue.
+ rewrite IS_LEAF.
+
+ econstructor; econstructor; split.
+ apply exec_straight_one. simpl.
+ rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'.
+ rewrite FREE'. eauto. auto.
+ split. apply agree_nextinstr. apply agree_set_other; auto.
+ apply agree_change_sp with (Vptr stk soff).
+ apply agree_exten with rs; auto.
+ eapply parent_sp_def; eauto.
+ split. auto.
+ split. Simpl.
+ split. Simpl.
+ intros. Simpl.
+ }
+ lapply LRA. 2: reflexivity.
+ clear LRA. intro LRA. *)
+ exploit Mem.loadv_extends. eauto. eexact LP. auto. simpl. intros (parent' & LP' & LDP').
+ exploit Mem.loadv_extends. eauto. eexact LRA. auto. simpl. intros (ra' & LRA' & LDRA').
+ exploit lessdef_parent_sp; eauto. intros EQ; subst parent'; clear LDP'.
+ exploit lessdef_parent_ra; eauto. intros EQ; subst ra'; clear LDRA'.
+ exploit Mem.free_parallel_extends; eauto. intros (tm' & FREE' & MEXT').
+ unfold make_epilogue.
+ (* FIXME rewrite IS_LEAF. *)
+ exploit (loadptr_correct XSP (fn_retaddr_ofs f)).
+ instantiate (2 := rs). simpl. rewrite <- (sp_val _ _ _ AG). simpl. eexact LRA'. simpl; congruence.
+ intros (rs1 & A1 & B1 & C1).
+
+ econstructor; econstructor; split.
+ eapply exec_straight_trans. eexact A1. apply exec_straight_one. simpl.
+ simpl; rewrite (C1 SP) by auto with asmgen. rewrite <- (sp_val _ _ _ AG). simpl; rewrite LP'.
+ rewrite FREE'. eauto. auto.
+ split. apply agree_nextinstr. apply agree_set_other; auto.
+ apply agree_change_sp with (Vptr stk soff).
+ apply agree_exten with rs; auto. intros; apply C1; auto with asmgen.
+ eapply parent_sp_def; eauto.
+ split. auto.
+ split. Simpl.
+ split. Simpl.
+ intros. Simpl.
+Qed.
+
+End CONSTRUCTORS.
diff --git a/cparser/Builtins.mli b/aarch64/Builtins1.v
index 7f9d78a9..53c83d7e 100644
--- a/cparser/Builtins.mli
+++ b/aarch64/Builtins1.v
@@ -2,7 +2,7 @@
(* *)
(* The Compcert verified compiler *)
(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
(* *)
(* Copyright Institut National de Recherche en Informatique et en *)
(* Automatique. All rights reserved. This file is distributed *)
@@ -13,13 +13,21 @@
(* *)
(* *********************************************************************)
-val environment: unit -> Env.t
-val identifiers: unit -> C.ident list
-val declarations: unit -> C.globdecl list
+(** Platform-specific built-in functions *)
-type t = {
- typedefs: (string * C.typ) list;
- functions: (string * (C.typ * C.typ list * bool)) list
-}
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Import Builtins0.
-val set: t -> unit
+Inductive platform_builtin : Type := .
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with end.
diff --git a/aarch64/CBuiltins.ml b/aarch64/CBuiltins.ml
new file mode 100644
index 00000000..fdc1372d
--- /dev/null
+++ b/aarch64/CBuiltins.ml
@@ -0,0 +1,72 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Processor-dependent builtin C functions *)
+
+open C
+
+(* va_list is a struct of size 32 and alignment 8, passed by reference *)
+
+let va_list_type = TArray(TInt(IULong, []), Some 4L, [])
+let size_va_list = 32
+let va_list_scalar = false
+
+let builtins = {
+ builtin_typedefs = [
+ "__builtin_va_list", va_list_type
+ ];
+ builtin_functions = [
+ (* Synchronization *)
+ "__builtin_fence",
+ (TVoid [], [], false);
+ (* Integer arithmetic *)
+ "__builtin_bswap64",
+ (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
+ "__builtin_clz",
+ (TInt(IInt, []), [TInt(IUInt, [])], false);
+ "__builtin_clzl",
+ (TInt(IInt, []), [TInt(IULong, [])], false);
+ "__builtin_clzll",
+ (TInt(IInt, []), [TInt(IULongLong, [])], false);
+ "__builtin_cls",
+ (TInt(IInt, []), [TInt(IInt, [])], false);
+ "__builtin_clsl",
+ (TInt(IInt, []), [TInt(ILong, [])], false);
+ "__builtin_clsll",
+ (TInt(IInt, []), [TInt(ILongLong, [])], false);
+ (* Float arithmetic *)
+ "__builtin_fmadd",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fmsub",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fnmadd",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fnmsub",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])],
+ false);
+ "__builtin_fmax",
+ (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ "__builtin_fmin",
+ (TFloat(FDouble, []), [TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ ]
+}
+
+(* Expand memory references inside extended asm statements. Used in C2C. *)
+
+let asm_mem_argument arg = Printf.sprintf "[%s]" arg
diff --git a/aarch64/CSE2deps.v b/aarch64/CSE2deps.v
new file mode 100644
index 00000000..90b514a2
--- /dev/null
+++ b/aarch64/CSE2deps.v
@@ -0,0 +1,20 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs (Int64.unsigned ofs') chunk' (Int64.unsigned ofs) chunk)
+ else true | _, _, _, _ => true
+ end.
diff --git a/aarch64/CSE2depsproof.v b/aarch64/CSE2depsproof.v
new file mode 100644
index 00000000..4aac23af
--- /dev/null
+++ b/aarch64/CSE2depsproof.v
@@ -0,0 +1,128 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Lemma ptrofs_size :
+ Ptrofs.wordsize = 64%nat.
+Proof.
+ unfold Ptrofs.wordsize.
+ unfold Wordsize_Ptrofs.wordsize.
+ trivial.
+Qed.
+
+Lemma ptrofs_modulus :
+ Ptrofs.modulus = 18446744073709551616.
+Proof.
+ reflexivity.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : int64.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= Int64.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= Int64.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : Int64.unsigned ofsw + size_chunk chunkw <= Int64.unsigned ofsr
+ \/ Int64.unsigned ofsr + size_chunk chunkr <= Int64.unsigned ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in *.
+
+ rewrite ptrofs_modulus in *.
+ simpl in *.
+ inv ADDRR.
+ inv ADDRW.
+
+ destruct base; try discriminate.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: unfold Ptrofs.of_int64.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.repr (Int64.unsigned ofsr))) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.repr (Int64.unsigned ofsw))) as [OFSW | OFSW];
+ rewrite OFSW).
+ all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia).
+
+ all: try rewrite ptrofs_modulus in *.
+
+ all: intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs (Int64.unsigned ofsr) chunkr (Int64.unsigned ofsw) chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs (Int64.unsigned ofs0) chunk' (Int64.unsigned ofs) chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/aarch64/CombineOp.v b/aarch64/CombineOp.v
new file mode 100644
index 00000000..4d78c9a0
--- /dev/null
+++ b/aarch64/CombineOp.v
@@ -0,0 +1,137 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Recognition of combined operations, addressing modes and conditions
+ during the [CSE] phase. *)
+
+Require Import Coqlib.
+Require Import AST Integers.
+Require Import Op.
+Require Import CSEdomain.
+
+Section COMBINE.
+
+Variable get: valnum -> option rhs.
+
+Function combine_compimm_ne_0 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (c, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_eq_0 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_eq_1 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (c, ys)
+ | _ => None
+ end.
+
+Function combine_compimm_ne_1 (x: valnum) : option(condition * list valnum) :=
+ match get x with
+ | Some(Op (Ocmp c) ys) => Some (negate_condition c, ys)
+ | _ => None
+ end.
+
+Function combine_cond (cond: condition) (args: list valnum) : option(condition * list valnum) :=
+ match cond, args with
+ | Ccompimm Cne n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
+ else None
+ | Ccompimm Ceq n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
+ else None
+ | Ccompuimm Cne n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_ne_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_ne_1 x
+ else None
+ | Ccompuimm Ceq n, x::nil =>
+ if Int.eq_dec n Int.zero then combine_compimm_eq_0 x
+ else if Int.eq_dec n Int.one then combine_compimm_eq_1 x
+ else None
+ | _, _ => None
+ end.
+
+Function combine_addr (addr: addressing) (args: list valnum) : option(addressing * list valnum) :=
+ match addr, args with
+ | Aindexed n, x::nil =>
+ match get x with
+ | Some(Op (Oaddlimm m) ys) =>
+ Some(Aindexed (Int64.add m n), ys)
+ | _ => None
+ end
+ | _, _ => None
+ end.
+
+Function combine_op (op: operation) (args: list valnum) : option(operation * list valnum) :=
+ match op, args with
+ | Oaddimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oaddimm m) ys) => Some(Oaddimm (Int.add m n), ys)
+ | _ => None
+ end
+ | Oandimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oandimm m) ys) =>
+ Some(let p := Int.and m n in
+ if Int.eq p m then (Omove, x :: nil) else (Oandimm p, ys))
+ | _ => None
+ end
+ | Oorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oorimm m) ys) => Some(Oorimm (Int.or m n), ys)
+ | _ => None
+ end
+ | Oxorimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oxorimm m) ys) => Some(Oxorimm (Int.xor m n), ys)
+ | _ => None
+ end
+ | Oaddlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oaddlimm m) ys) => Some(Oaddlimm (Int64.add m n), ys)
+ | _ => None
+ end
+ | Oandlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oandlimm m) ys) =>
+ Some(let p := Int64.and m n in
+ if Int64.eq p m then (Omove, x :: nil) else (Oandlimm p, ys))
+ | _ => None
+ end
+ | Oorlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oorlimm m) ys) => Some(Oorlimm (Int64.or m n), ys)
+ | _ => None
+ end
+ | Oxorlimm n, x :: nil =>
+ match get x with
+ | Some(Op (Oxorlimm m) ys) => Some(Oxorlimm (Int64.xor m n), ys)
+ | _ => None
+ end
+ | Ocmp cond, _ =>
+ match combine_cond cond args with
+ | Some(cond', args') => Some(Ocmp cond', args')
+ | None => None
+ end
+ | _, _ => None
+ end.
+
+End COMBINE.
+
+
diff --git a/aarch64/CombineOpproof.v b/aarch64/CombineOpproof.v
new file mode 100644
index 00000000..7d13b964
--- /dev/null
+++ b/aarch64/CombineOpproof.v
@@ -0,0 +1,161 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+Require Import FunInd.
+Require Import Coqlib.
+Require Import AST Integers Values Memory.
+Require Import Op Registers RTL.
+Require Import CSEdomain.
+Require Import CombineOp.
+
+Section COMBINE.
+
+Variable ge: genv.
+Variable sp: val.
+Variable m: mem.
+Variable get: valnum -> option rhs.
+Variable valu: valnum -> val.
+Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).
+
+Lemma get_op_sound:
+ forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
+Proof.
+ intros. exploit get_sound; eauto. intros REV; inv REV; auto.
+Qed.
+
+Ltac UseGetSound :=
+ match goal with
+ | [ H: get _ = Some _ |- _ ] =>
+ let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
+ end.
+
+Lemma combine_compimm_ne_0_sound:
+ forall x cond args,
+ combine_compimm_ne_0 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
+Proof.
+ intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Lemma combine_compimm_eq_0_sound:
+ forall x cond args,
+ combine_compimm_eq_0 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
+Proof.
+ intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ rewrite eval_negate_condition.
+ destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Lemma combine_compimm_eq_1_sound:
+ forall x cond args,
+ combine_compimm_eq_1 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
+Proof.
+ intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Lemma combine_compimm_ne_1_sound:
+ forall x cond args,
+ combine_compimm_ne_1 get x = Some(cond, args) ->
+ eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
+ eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
+Proof.
+ intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
+ (* of cmp *)
+ UseGetSound. rewrite <- H.
+ rewrite eval_negate_condition.
+ destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
+Qed.
+
+Theorem combine_cond_sound:
+ forall cond args cond' args',
+ combine_cond get cond args = Some(cond', args') ->
+ eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
+Proof.
+ intros. functional inversion H; subst.
+ (* compimm ne zero *)
+ - simpl; eapply combine_compimm_ne_0_sound; eauto.
+ (* compimm ne one *)
+ - simpl; eapply combine_compimm_ne_1_sound; eauto.
+ (* compimm eq zero *)
+ - simpl; eapply combine_compimm_eq_0_sound; eauto.
+ (* compimm eq one *)
+ - simpl; eapply combine_compimm_eq_1_sound; eauto.
+ (* compuimm ne zero *)
+ - simpl; eapply combine_compimm_ne_0_sound; eauto.
+ (* compuimm ne one *)
+ - simpl; eapply combine_compimm_ne_1_sound; eauto.
+ (* compuimm eq zero *)
+ - simpl; eapply combine_compimm_eq_0_sound; eauto.
+ (* compuimm eq one *)
+ - simpl; eapply combine_compimm_eq_1_sound; eauto.
+Qed.
+
+Theorem combine_addr_sound:
+ forall addr args addr' args',
+ combine_addr get addr args = Some(addr', args') ->
+ eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
+Proof.
+ intros. functional inversion H; subst.
+- (* indexed - addimml *)
+ UseGetSound. simpl. rewrite <- H0. rewrite Val.addl_assoc. auto.
+Qed.
+
+Theorem combine_op_sound:
+ forall op args op' args',
+ combine_op get op args = Some(op', args') ->
+ eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
+Proof.
+ intros. functional inversion H; subst.
+ (* addimm - addimm *)
+ - UseGetSound. FuncInv. simpl.
+ rewrite <- H0. rewrite Val.add_assoc. auto.
+ (* andimm - andimm *)
+ - UseGetSound; simpl.
+ generalize (Int.eq_spec p m0); rewrite H7; intros.
+ rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto.
+ - UseGetSound; simpl.
+ rewrite <- H0. rewrite Val.and_assoc. auto.
+ (* orimm - orimm *)
+ - UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
+ (* xorimm - xorimm *)
+ - UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
+ (* addlimm - addlimm *)
+ - UseGetSound. FuncInv. simpl.
+ rewrite <- H0. rewrite Val.addl_assoc. auto.
+ (* andlimm - andlimm *)
+ - UseGetSound; simpl.
+ generalize (Int64.eq_spec p m0); rewrite H7; intros.
+ rewrite <- H0. rewrite Val.andl_assoc. simpl. fold p. rewrite H1. auto.
+ - UseGetSound; simpl.
+ rewrite <- H0. rewrite Val.andl_assoc. auto.
+ (* orlimm - orlimm *)
+ - UseGetSound. simpl. rewrite <- H0. rewrite Val.orl_assoc. auto.
+ (* xorlimm - xorlimm *)
+ - UseGetSound. simpl. rewrite <- H0. rewrite Val.xorl_assoc. auto.
+ (* cmp *)
+ - simpl. decEq; decEq. eapply combine_cond_sound; eauto.
+Qed.
+
+End COMBINE.
diff --git a/aarch64/ConstpropOp.vp b/aarch64/ConstpropOp.vp
new file mode 100644
index 00000000..c0a2c6bf
--- /dev/null
+++ b/aarch64/ConstpropOp.vp
@@ -0,0 +1,401 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Strength reduction for operators and conditions.
+ This is the machine-dependent part of [Constprop]. *)
+
+Require Archi.
+Require Import Coqlib Compopts.
+Require Import AST Integers Floats.
+Require Import Op Registers.
+Require Import ValueDomain ValueAOp.
+
+(** * Converting known values to constants *)
+
+Definition const_for_result (a: aval) : option operation :=
+ match a with
+ | I n => Some(Ointconst n)
+ | L n => Some(Olongconst n)
+ | F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None
+ | FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None
+ | Ptr(Gl id ofs) => Some(Oaddrsymbol id ofs)
+ | Ptr(Stk ofs) => Some(Oaddrstack ofs)
+ | _ => None
+ end.
+
+(** * Operator strength reduction *)
+
+Definition eval_static_shift (s: shift) (v: int) (n: amount32) : int :=
+ match s with
+ | Slsl => Int.shl v n
+ | Slsr => Int.shru v n
+ | Sasr => Int.shr v n
+ | Sror => Int.ror v n
+ end.
+
+Definition eval_static_shiftl (s: shift) (v: int64) (n: amount64) : int64 :=
+ match s with
+ | Slsl => Int64.shl' v n
+ | Slsr => Int64.shru' v n
+ | Sasr => Int64.shr' v n
+ | Sror => Int64.ror v (Int64.repr (Int.unsigned n))
+ end.
+
+Definition eval_static_extend (x: extension) (v: int) (n: amount64) : int64 :=
+ Int64.shl' (match x with Xsgn32 => Int64.repr (Int.signed v)
+ | Xuns32 => Int64.repr (Int.unsigned v) end)
+ n.
+
+Nondetfunction cond_strength_reduction
+ (cond: condition) (args: list reg) (vl: list aval) :=
+ match cond, args, vl with
+ | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Ccompimm (swap_comparison c) n1, r2 :: nil)
+ | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompimm c n2, r1 :: nil)
+ | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
+ (Ccompuimm (swap_comparison c) n1, r2 :: nil)
+ | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompuimm c n2, r1 :: nil)
+ | Ccompshift c s a, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompimm c (eval_static_shift s n2 a), r1 :: nil)
+ | Ccompushift c s a, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Ccompuimm c (eval_static_shift s n2 a), r1 :: nil)
+ | Ccompl c, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Ccomplimm (swap_comparison c) n1, r2 :: nil)
+ | Ccompl c, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccomplimm c n2, r1 :: nil)
+ | Ccomplu c, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Ccompluimm (swap_comparison c) n1, r2 :: nil)
+ | Ccomplu c, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccompluimm c n2, r1 :: nil)
+ | Ccomplshift c s a, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccomplimm c (eval_static_shiftl s n2 a), r1 :: nil)
+ | Ccomplushift c s a, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Ccompluimm c (eval_static_shiftl s n2 a), r1 :: nil)
+ | Ccompf c, r1 :: r2 :: nil, F n1 :: v2 :: nil =>
+ if Float.eq_dec n1 Float.zero
+ then (Ccompfzero (swap_comparison c), r2 :: nil)
+ else (cond, args)
+ | Ccompf c, r1 :: r2 :: nil, v1 :: F n2 :: nil =>
+ if Float.eq_dec n2 Float.zero
+ then (Ccompfzero c, r1 :: nil)
+ else (cond, args)
+ | Cnotcompf c, r1 :: r2 :: nil, F n1 :: v2 :: nil =>
+ if Float.eq_dec n1 Float.zero
+ then (Cnotcompfzero (swap_comparison c), r2 :: nil)
+ else (cond, args)
+ | Cnotcompf c, r1 :: r2 :: nil, v1 :: F n2 :: nil =>
+ if Float.eq_dec n2 Float.zero
+ then (Cnotcompfzero c, r1 :: nil)
+ else (cond, args)
+ | Ccompfs c, r1 :: r2 :: nil, FS n1 :: v2 :: nil =>
+ if Float32.eq_dec n1 Float32.zero
+ then (Ccompfszero (swap_comparison c), r2 :: nil)
+ else (cond, args)
+ | Ccompfs c, r1 :: r2 :: nil, v1 :: FS n2 :: nil =>
+ if Float32.eq_dec n2 Float32.zero
+ then (Ccompfszero c, r1 :: nil)
+ else (cond, args)
+ | Cnotcompfs c, r1 :: r2 :: nil, FS n1 :: v2 :: nil =>
+ if Float32.eq_dec n1 Float32.zero
+ then (Cnotcompfszero (swap_comparison c), r2 :: nil)
+ else (cond, args)
+ | Cnotcompfs c, r1 :: r2 :: nil, v1 :: FS n2 :: nil =>
+ if Float32.eq_dec n2 Float32.zero
+ then (Cnotcompfszero c, r1 :: nil)
+ else (cond, args)
+ | _, _, _ =>
+ (cond, args)
+ end.
+
+Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) :=
+ let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args').
+
+Definition make_cmp_imm_eq (c: condition) (args: list reg) (vl: list aval)
+ (n: int) (r1: reg) (v1: aval) :=
+ if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil)
+ else if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil)
+ else make_cmp_base c args vl.
+
+Definition make_cmp_imm_ne (c: condition) (args: list reg) (vl: list aval)
+ (n: int) (r1: reg) (v1: aval) :=
+ if Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1) then (Omove, r1 :: nil)
+ else if Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1) then (Oxorimm Int.one, r1 :: nil)
+ else make_cmp_base c args vl.
+
+Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
+ match c, args, vl with
+ | Ccompimm Ceq n, r1 :: nil, v1 :: nil =>
+ make_cmp_imm_eq c args vl n r1 v1
+ | Ccompimm Cne n, r1 :: nil, v1 :: nil =>
+ make_cmp_imm_ne c args vl n r1 v1
+ | Ccompuimm Ceq n, r1 :: nil, v1 :: nil =>
+ make_cmp_imm_eq c args vl n r1 v1
+ | Ccompuimm Cne n, r1 :: nil, v1 :: nil =>
+ make_cmp_imm_ne c args vl n r1 v1
+ | _, _, _ =>
+ make_cmp_base c args vl
+ end.
+
+Definition make_select (c: condition) (ty: typ)
+ (r1 r2: reg) (args: list reg) (vl: list aval) :=
+ match resolve_branch (eval_static_condition c vl) with
+ | Some b => (Omove, (if b then r1 else r2) :: nil)
+ | None =>
+ let (c', args') := cond_strength_reduction c args vl in
+ (Osel c' ty, r1 :: r2 :: args')
+ end.
+
+Definition make_addimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero
+ then (Omove, r :: nil)
+ else (Oaddimm n, r :: nil).
+
+Definition make_shlimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshift Slsl (mk_amount32 n), r1 :: nil)
+ else (Oshl, r1 :: r2 :: nil).
+
+Definition make_shrimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshift Sasr (mk_amount32 n), r1 :: nil)
+ else (Oshr, r1 :: r2 :: nil).
+
+Definition make_shruimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int.iwordsize then (Oshift Slsr (mk_amount32 n), r1 :: nil)
+ else (Oshru, r1 :: r2 :: nil).
+
+Definition make_mulimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then
+ (Ointconst Int.zero, nil)
+ else if Int.eq n Int.one then
+ (Omove, r1 :: nil)
+ else
+ match Int.is_power2 n with
+ | Some l => (Oshift Slsl (mk_amount32 l), r1 :: nil)
+ | None => (Omul, r1 :: r2 :: nil)
+ end.
+
+Definition make_andimm (n: int) (r: reg) (a: aval) :=
+ if Int.eq n Int.zero then (Ointconst Int.zero, nil)
+ else if Int.eq n Int.mone then (Omove, r :: nil)
+ else if match a with Uns _ m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero
+ | _ => false end
+ then (Omove, r :: nil)
+ else (Oandimm n, r :: nil).
+
+Definition make_orimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero then (Omove, r :: nil)
+ else if Int.eq n Int.mone then (Ointconst Int.mone, nil)
+ else (Oorimm n, r :: nil).
+
+Definition make_xorimm (n: int) (r: reg) :=
+ if Int.eq n Int.zero then (Omove, r :: nil)
+ else (Oxorimm n, r :: nil).
+
+Definition make_divimm n (r1 r2: reg) :=
+ if Int.eq n Int.one then
+ (Omove, r1 :: nil)
+ else
+ match Int.is_power2 n with
+ | Some l => if Int.ltu l (Int.repr 31)
+ then (Oshrximm l, r1 :: nil)
+ else (Odiv, r1 :: r2 :: nil)
+ | None => (Odiv, r1 :: r2 :: nil)
+ end.
+
+Definition make_divuimm n (r1 r2: reg) :=
+ if Int.eq n Int.one then
+ (Omove, r1 :: nil)
+ else
+ match Int.is_power2 n with
+ | Some l => (Oshift Slsr (mk_amount32 l), r1 :: nil)
+ | None => (Odivu, r1 :: r2 :: nil)
+ end.
+
+Definition make_addlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero
+ then (Omove, r :: nil)
+ else (Oaddlimm n, r :: nil).
+
+Definition make_shllimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshiftl Slsl (mk_amount64 n), r1 :: nil)
+ else (Oshll, r1 :: r2 :: nil).
+
+Definition make_shrlimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshiftl Sasr (mk_amount64 n), r1 :: nil)
+ else (Oshrl, r1 :: r2 :: nil).
+
+Definition make_shrluimm (n: int) (r1 r2: reg) :=
+ if Int.eq n Int.zero then (Omove, r1 :: nil)
+ else if Int.ltu n Int64.iwordsize' then (Oshiftl Slsr (mk_amount64 n), r1 :: nil)
+ else (Oshrlu, r1 :: r2 :: nil).
+
+Definition make_mullimm (n: int64) (r1 r2: reg) :=
+ if Int64.eq n Int64.zero then
+ (Olongconst Int64.zero, nil)
+ else if Int64.eq n Int64.one then
+ (Omove, r1 :: nil)
+ else
+ match Int64.is_power2' n with
+ | Some l => (Oshiftl Slsl (mk_amount64 l), r1 :: nil)
+ | None => (Omull, r1 :: r2 :: nil)
+ end.
+
+Definition make_andlimm (n: int64) (r: reg) (a: aval) :=
+ if Int64.eq n Int64.zero then (Olongconst Int64.zero, nil)
+ else if Int64.eq n Int64.mone then (Omove, r :: nil)
+ else (Oandlimm n, r :: nil).
+
+Definition make_orlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero then (Omove, r :: nil)
+ else if Int64.eq n Int64.mone then (Olongconst Int64.mone, nil)
+ else (Oorlimm n, r :: nil).
+
+Definition make_xorlimm (n: int64) (r: reg) :=
+ if Int64.eq n Int64.zero then (Omove, r :: nil)
+ else (Oxorlimm n, r :: nil).
+
+Definition make_divlimm n (r1 r2: reg) :=
+ match Int64.is_power2' n with
+ | Some l => if Int.ltu l (Int.repr 63)
+ then (Oshrlximm l, r1 :: nil)
+ else (Odivl, r1 :: r2 :: nil)
+ | None => (Odivl, r1 :: r2 :: nil)
+ end.
+
+Definition make_divluimm n (r1 r2: reg) :=
+ match Int64.is_power2' n with
+ | Some l => (Oshiftl Slsr (mk_amount64 l), r1 :: nil)
+ | None => (Odivlu, r1 :: r2 :: nil)
+ end.
+
+Definition make_mulfimm (n: float) (r r1 r2: reg) :=
+ if Float.eq_dec n (Float.of_int (Int.repr 2))
+ then (Oaddf, r :: r :: nil)
+ else (Omulf, r1 :: r2 :: nil).
+
+Definition make_mulfsimm (n: float32) (r r1 r2: reg) :=
+ if Float32.eq_dec n (Float32.of_int (Int.repr 2))
+ then (Oaddfs, r :: r :: nil)
+ else (Omulfs, r1 :: r2 :: nil).
+
+Definition make_zext (s: Z) (r: reg) (a: aval) :=
+ if vincl a (Uns Ptop s) then (Omove, r :: nil) else (Ozext s, r :: nil).
+
+Definition make_sext (s: Z) (r: reg) (a: aval) :=
+ if vincl a (Sgn Ptop s) then (Omove, r :: nil) else (Osext s, r :: nil).
+
+Nondetfunction op_strength_reduction
+ (op: operation) (args: list reg) (vl: list aval) :=
+ match op, args, vl with
+ | Oadd, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_addimm n1 r2
+ | Oadd, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm n2 r1
+ | Oaddshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (eval_static_shift s n2 a) r1
+ | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1
+ | Osubshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg (eval_static_shift s n2 a)) r1
+ | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2 r1
+ | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1 r2
+ | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2
+ | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2
+ | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2
+ | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1
+ | Oandshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (eval_static_shift s n2 a) r1 v1
+ | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1
+ | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2
+ | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1
+ | Oorshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (eval_static_shift s n2 a) r1
+ | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2
+ | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1
+ | Oxorshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (eval_static_shift s n2 a) r1
+ | Obic, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not n2) r1 v1
+ | Obicshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm (Int.not (eval_static_shift s n2 a)) r1 v1
+ | Oorn, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (Int.not n2) r1
+ | Oornshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm (Int.not (eval_static_shift s n2 a)) r1
+ | Oeqv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (Int.not n2) r1
+ | Oeqvshift s a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm (Int.not (eval_static_shift s n2 a)) r1
+ | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2
+ | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2
+ | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2
+ | Ozext s, r1 :: nil, v1 :: nil => make_zext s r1 v1
+ | Osext s, r1 :: nil, v1 :: nil => make_sext s r1 v1
+
+ | Oaddl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_addlimm n1 r2
+ | Oaddl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm n2 r1
+ | Oaddlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (eval_static_shiftl s n2 a) r1
+ | Oaddlext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addlimm (eval_static_extend x n2 a) r1
+ | Osubl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg n2) r1
+ | Osublshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_addlimm (Int64.neg (eval_static_shiftl s n2 a)) r1
+ | Osublext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addlimm (Int64.neg (eval_static_extend x n2 a)) r1
+ | Omull, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_mullimm n1 r2 r1
+ | Omull, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_mullimm n2 r1 r2
+ | Odivl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divlimm n2 r1 r2
+ | Odivlu, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_divluimm n2 r1 r2
+ | Oandl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_andlimm n1 r2 v2
+ | Oandl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm n2 r1 v1
+ | Oandlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (eval_static_shiftl s n2 a) r1 v1
+ | Oandlimm n, r1 :: nil, v1 :: nil => make_andlimm n r1 v1
+ | Oorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_orlimm n1 r2
+ | Oorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm n2 r1
+ | Oorlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (eval_static_shiftl s n2 a) r1
+ | Oxorl, r1 :: r2 :: nil, L n1 :: v2 :: nil => make_xorlimm n1 r2
+ | Oxorl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm n2 r1
+ | Oxorlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (eval_static_shiftl s n2 a) r1
+ | Obicl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (Int64.not n2) r1 v1
+ | Obiclshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_andlimm (Int64.not (eval_static_shiftl s n2 a)) r1 v1
+ | Oornl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (Int64.not n2) r1
+ | Oornlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_orlimm (Int64.not (eval_static_shiftl s n2 a)) r1
+ | Oeqvl, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (Int64.not n2) r1
+ | Oeqvlshift s a, r1 :: r2 :: nil, v1 :: L n2 :: nil => make_xorlimm (Int64.not (eval_static_shiftl s n2 a)) r1
+ | Oshll, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shllimm n2 r1 r2
+ | Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2
+ | Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2
+ | Ocmp c, args, vl => make_cmp c args vl
+ | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl
+ | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
+ | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
+ | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
+ | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2
+ | _, _, _ => (op, args)
+ end.
+
+Nondetfunction addr_strength_reduction
+ (addr: addressing) (args: list reg) (vl: list aval) :=
+ match addr, args, vl with
+ | Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil =>
+ (Aglobal symb (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil)
+ | Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil =>
+ (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 n)), nil)
+ | Aindexed2, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil =>
+ (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 n2)), nil)
+ | Aindexed2, r1 :: r2 :: nil, L n1 :: Ptr(Stk n2) :: nil =>
+ (Ainstack (Ptrofs.add (Ptrofs.of_int64 n1) n2), nil)
+ | Aindexed2, r1 :: r2 :: nil, L n1 :: v2 :: nil =>
+ (Aindexed n1, r2 :: nil)
+ | Aindexed2, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Aindexed n2, r1 :: nil)
+ | Aindexed2shift a, r1 :: r2 :: nil, Ptr(Stk n1) :: L n2 :: nil =>
+ (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 (Int64.shl' n2 a))), nil)
+ | Aindexed2shift a, r1 :: r2 :: nil, v1 :: L n2 :: nil =>
+ (Aindexed (Int64.shl' n2 a), r1 :: nil)
+ | Aindexed2ext x a, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil =>
+ (Ainstack (Ptrofs.add n1 (Ptrofs.of_int64 (eval_static_extend x n2 a))), nil)
+ | Aindexed2ext x a, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
+ (Aindexed (eval_static_extend x n2 a), r1 :: nil)
+ | _, _, _ =>
+ (addr, args)
+ end.
+
diff --git a/aarch64/ConstpropOpproof.v b/aarch64/ConstpropOpproof.v
new file mode 100644
index 00000000..deab7cd4
--- /dev/null
+++ b/aarch64/ConstpropOpproof.v
@@ -0,0 +1,838 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for operator strength reduction. *)
+
+Require Import Coqlib Compopts.
+Require Import Integers Floats Values Memory Globalenvs Events.
+Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis.
+Require Import ConstpropOp.
+
+Local Transparent Archi.ptr64.
+
+Section STRENGTH_REDUCTION.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+Variable ae: AE.t.
+Variable e: regset.
+Variable m: mem.
+Hypothesis MATCH: ematch bc e ae.
+
+Lemma match_G:
+ forall r id ofs,
+ AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef e#r (Genv.symbol_address ge id ofs).
+Proof.
+ intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Lemma match_S:
+ forall r ofs,
+ AE.get r ae = Ptr(Stk ofs) -> Val.lessdef e#r (Vptr sp ofs).
+Proof.
+ intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
+Qed.
+
+Ltac InvApproxRegs :=
+ match goal with
+ | [ H: _ :: _ = _ :: _ |- _ ] =>
+ injection H; clear H; intros; InvApproxRegs
+ | [ H: ?v = AE.get ?r ae |- _ ] =>
+ generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
+ | _ => idtac
+ end.
+
+Ltac SimplVM :=
+ match goal with
+ | [ H: vmatch _ ?v (I ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vint n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (L ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vlong n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (F ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vfloat n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (FS ?n) |- _ ] =>
+ let E := fresh in
+ assert (E: v = Vsingle n) by (inversion H; auto);
+ rewrite E in *; clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Genv.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
+ clear H; SimplVM
+ | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
+ let E := fresh in
+ assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
+ clear H; SimplVM
+ | _ => idtac
+ end.
+
+Lemma const_for_result_correct:
+ forall a op v,
+ const_for_result a = Some op ->
+ vmatch bc v a ->
+ exists v', eval_operation ge (Vptr sp Ptrofs.zero) op nil m = Some v' /\ Val.lessdef v v'.
+Proof.
+ unfold const_for_result; intros; destruct a; inv H; SimplVM.
+- (* integer *)
+ exists (Vint n); auto.
+- (* long *)
+ exists (Vlong n); auto.
+- (* float *)
+ destruct (Compopts.generate_float_constants tt); inv H2. exists (Vfloat f); auto.
+- (* single *)
+ destruct (Compopts.generate_float_constants tt); inv H2. exists (Vsingle f); auto.
+- (* pointer *)
+ destruct p; try discriminate; SimplVM.
+ + (* global *)
+ inv H2. exists (Genv.symbol_address ge id ofs); auto.
+ + (* stack *)
+ inv H2. exists (Vptr sp ofs); split; auto. simpl. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+Lemma eval_static_shift_correct: forall s v a,
+ eval_shift s (Vint v) a = Vint (eval_static_shift s v a).
+Proof.
+ intros; destruct s; simpl; rewrite ? a32_range; auto.
+Qed.
+
+Lemma eval_static_shiftl_correct: forall s v a,
+ eval_shiftl s (Vlong v) a = Vlong (eval_static_shiftl s v a).
+Proof.
+ intros; destruct s; simpl; rewrite ? a64_range; auto.
+Qed.
+
+Lemma eval_static_extend_correct: forall x v a,
+ eval_extend x (Vint v) a = Vlong (eval_static_extend x v a).
+Proof.
+ unfold eval_extend, eval_static_extend; intros; destruct x; simpl; rewrite ? a64_range; auto.
+Qed.
+
+Lemma cond_strength_reduction_correct:
+ forall cond args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (cond', args') := cond_strength_reduction cond args vl in
+ eval_condition cond' e##args' m = eval_condition cond e##args m.
+Proof.
+ intros until vl. unfold cond_strength_reduction.
+ case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
+- apply Val.swap_cmp_bool.
+- auto.
+- apply Val.swap_cmpu_bool.
+- auto.
+- rewrite eval_static_shift_correct; auto.
+- rewrite eval_static_shift_correct; auto.
+- apply Val.swap_cmpl_bool.
+- auto.
+- apply Val.swap_cmplu_bool.
+- auto.
+- rewrite eval_static_shiftl_correct; auto.
+- rewrite eval_static_shiftl_correct; auto.
+- destruct (Float.eq_dec n1 Float.zero).
+ subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float.eq_dec n2 Float.zero).
+ subst n2. simpl. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float.eq_dec n1 Float.zero).
+ subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float.cmp_swap. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float.eq_dec n2 Float.zero); simpl; auto.
+ subst n2; auto.
+ rewrite H1; auto.
+- destruct (Float32.eq_dec n1 Float32.zero).
+ subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float32.eq_dec n2 Float32.zero).
+ subst n2. simpl. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float32.eq_dec n1 Float32.zero).
+ subst n1. simpl. destruct (e#r2); simpl; auto. rewrite Float32.cmp_swap. auto.
+ simpl. rewrite H1; auto.
+- destruct (Float32.eq_dec n2 Float32.zero); simpl; auto.
+ subst n2; auto.
+ rewrite H1; auto.
+- auto.
+Qed.
+
+Lemma make_cmp_base_correct:
+ forall c args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_cmp_base c args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
+Proof.
+ intros. unfold make_cmp_base.
+ generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ. auto.
+Qed.
+
+Lemma make_cmp_correct:
+ forall c args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_cmp c args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.of_optbool (eval_condition c e##args m)) v.
+Proof.
+ intros c args vl.
+ assert (Y: forall r, vincl (AE.get r ae) (Uns Ptop 1) = true ->
+ e#r = Vundef \/ e#r = Vint Int.zero \/ e#r = Vint Int.one).
+ { intros. apply vmatch_Uns_1 with bc Ptop. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. }
+ unfold make_cmp. case (make_cmp_match c args vl); intros.
+- unfold make_cmp_imm_eq.
+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
++ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+* simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+* apply make_cmp_base_correct; auto.
+- unfold make_cmp_imm_ne.
+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
++ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+* simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+* apply make_cmp_base_correct; auto.
+- unfold make_cmp_imm_eq.
+ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
++ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
++ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
+* simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+* apply make_cmp_base_correct; auto.
+- unfold make_cmp_imm_ne.
+ destruct (Int.eq_dec n Int.zero && vincl v1 (Uns Ptop 1)) eqn:E0.
++ simpl in H; inv H. InvBooleans. subst n.
+ exists (e#r1); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
++ destruct (Int.eq_dec n Int.one && vincl v1 (Uns Ptop 1)) eqn:E1.
+* simpl in H; inv H. InvBooleans. subst n.
+ exists (Val.xor e#r1 (Vint Int.one)); split; auto. simpl.
+ exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
+* apply make_cmp_base_correct; auto.
+- apply make_cmp_base_correct; auto.
+Qed.
+
+Lemma make_select_correct:
+ forall c ty r1 r2 args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_select c ty r1 r2 args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v.
+Proof.
+ unfold make_select; intros.
+ destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB.
+- exists (if b then e#r1 else e#r2); split.
++ simpl. destruct b; auto.
++ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto.
+ assert (b = b').
+ { eapply resolve_branch_sound; eauto.
+ rewrite <- EC. apply eval_static_condition_sound with bc.
+ subst vl. exact (aregs_sound _ _ _ args MATCH). }
+ subst b'. apply Val.lessdef_normalize.
+- generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ; auto.
+Qed.
+
+Lemma make_addimm_correct:
+ forall n r,
+ let (op, args) := make_addimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.add e#r (Vint n)) v.
+Proof.
+ intros. unfold make_addimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst. exists (e#r); split; auto.
+ destruct (e#r); simpl; rewrite ?Int.add_zero; auto.
+ exists (Val.add e#r (Vint n)); split; auto.
+Qed.
+
+Lemma make_shlimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shlimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shl e#r1 (Vint n)) v.
+Proof.
+Local Opaque mk_amount32.
+ intros; unfold make_shlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shl_zero. auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shr e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shr_zero. auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shruimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shruimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shru e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shruimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.shru_zero. auto.
+ destruct (Int.ltu n Int.iwordsize) eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount32_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_mulimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_mulimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mul e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_mulimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (Vint Int.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int.mul_one; auto.
+ destruct (Int.is_power2 n) eqn:?; intros.
+ rewrite (Val.mul_pow2 e#r1 _ _ Heqo). econstructor; split. simpl; eauto.
+ rewrite mk_amount32_eq; auto. eapply Int.is_power2_range; eauto.
+ econstructor; split; eauto. simpl. rewrite H; auto.
+Qed.
+
+Lemma make_divimm_correct:
+ forall n r1 r2 v,
+ Val.divs e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
+ let (op, args) := make_divimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divimm.
+ predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H.
+ destruct (e#r1) eqn:?;
+ try (rewrite Val.divs_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto);
+ inv H; auto.
+ destruct (Int.is_power2 n) eqn:?.
+ destruct (Int.ltu i (Int.repr 31)) eqn:?.
+ exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
+ exists v; auto.
+ exists v; auto.
+Qed.
+
+Lemma make_divuimm_correct:
+ forall n r1 r2 v,
+ Val.divu e#r1 e#r2 = Some v ->
+ e#r2 = Vint n ->
+ let (op, args) := make_divuimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divuimm.
+ predSpec Int.eq Int.eq_spec n Int.one; intros. subst. rewrite H0 in H.
+ destruct (e#r1) eqn:?;
+ try (rewrite Val.divu_one in H; exists (Vint i); split; simpl; try rewrite Heqv0; auto);
+ inv H; auto.
+ destruct (Int.is_power2 n) eqn:?.
+ econstructor; split. simpl; eauto.
+ rewrite mk_amount32_eq by (eapply Int.is_power2_range; eauto).
+ rewrite H0 in H. erewrite Val.divu_pow2 by eauto. auto.
+ exists v; auto.
+Qed.
+
+Lemma make_andimm_correct:
+ forall n r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_andimm n r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.and e#r (Vint n)) v.
+Proof.
+ intros; unfold make_andimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (Vint Int.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.and_mone; auto.
+ destruct (match x with Uns _ k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
+ | _ => false end) eqn:UNS.
+ destruct x; try congruence.
+ exists (e#r); split; auto.
+ inv H; auto. simpl. replace (Int.and i n) with i; auto.
+ generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
+ Int.bit_solve. destruct (zlt i0 n0).
+ replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
+ rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
+ rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto.
+ rewrite Int.bits_not by auto. apply negb_involutive.
+ rewrite H6 by auto. auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_orimm_correct:
+ forall n r,
+ let (op, args) := make_orimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.or e#r (Vint n)) v.
+Proof.
+ intros; unfold make_orimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (Vint Int.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int.or_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_xorimm_correct:
+ forall n r,
+ let (op, args) := make_xorimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xor e#r (Vint n)) v.
+Proof.
+ intros; unfold make_xorimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int.xor_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone; intros.
+ subst n. exists (Val.notint e#r); split; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_addlimm_correct:
+ forall n r,
+ let (op, args) := make_addlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.addl e#r (Vlong n)) v.
+Proof.
+ intros. unfold make_addlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst. exists (e#r); split; auto.
+ destruct (e#r); simpl; auto; rewrite ? Int64.add_zero, ? Ptrofs.add_zero; auto.
+ exists (Val.addl e#r (Vlong n)); split; auto.
+Qed.
+
+Lemma make_shllimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shllimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shll e#r1 (Vint n)) v.
+Proof.
+Local Opaque mk_amount64.
+ intros; unfold make_shllimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shl'. rewrite Z.shiftl_0_r, Int64.repr_unsigned. auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrlimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrlimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrl e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shr'. rewrite Z.shiftr_0_r, Int64.repr_signed. auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_shrluimm_correct:
+ forall n r1 r2,
+ e#r2 = Vint n ->
+ let (op, args) := make_shrluimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.shrlu e#r1 (Vint n)) v.
+Proof.
+ intros; unfold make_shrluimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto.
+ unfold Int64.shru'. rewrite Z.shiftr_0_r, Int64.repr_unsigned. auto.
+ destruct (Int.ltu n Int64.iwordsize') eqn:L.
+ econstructor; split. simpl. eauto. rewrite mk_amount64_eq; auto.
+ econstructor; split. simpl. eauto. rewrite H; auto.
+Qed.
+
+Lemma make_mullimm_correct:
+ forall n r1 r2,
+ e#r2 = Vlong n ->
+ let (op, args) := make_mullimm n r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mull e#r1 (Vlong n)) v.
+Proof.
+ intros; unfold make_mullimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros. subst.
+ exists (Vlong Int64.zero); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.one; intros. subst.
+ exists (e#r1); split; auto. destruct (e#r1); simpl; auto. rewrite Int64.mul_one; auto.
+ destruct (Int64.is_power2' n) eqn:?; intros.
+ econstructor; split. simpl; eauto.
+ rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto).
+ destruct (e#r1); simpl; auto.
+ erewrite Int64.is_power2'_range by eauto.
+ erewrite Int64.mul_pow2' by eauto. auto.
+ econstructor; split; eauto. simpl; rewrite H; auto.
+Qed.
+
+Lemma make_divlimm_correct:
+ forall n r1 r2 v,
+ Val.divls e#r1 e#r2 = Some v ->
+ e#r2 = Vlong n ->
+ let (op, args) := make_divlimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divlimm.
+ destruct (Int64.is_power2' n) eqn:?. destruct (Int.ltu i (Int.repr 63)) eqn:?.
+ rewrite H0 in H. econstructor; split. simpl; eauto. eapply Val.divls_pow2; eauto. auto.
+ exists v; auto.
+ exists v; auto.
+Qed.
+
+Lemma make_divluimm_correct:
+ forall n r1 r2 v,
+ Val.divlu e#r1 e#r2 = Some v ->
+ e#r2 = Vlong n ->
+ let (op, args) := make_divluimm n r1 r2 in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some w /\ Val.lessdef v w.
+Proof.
+ intros; unfold make_divluimm.
+ destruct (Int64.is_power2' n) eqn:?.
+ econstructor; split. simpl; eauto.
+ rewrite mk_amount64_eq by (eapply Int64.is_power2'_range; eauto).
+ rewrite H0 in H. destruct (e#r1); inv H. destruct (Int64.eq n Int64.zero); inv H2.
+ simpl.
+ erewrite Int64.is_power2'_range by eauto.
+ erewrite Int64.divu_pow2' by eauto. auto.
+ exists v; auto.
+Qed.
+
+Lemma make_andlimm_correct:
+ forall n r x,
+ let (op, args) := make_andlimm n r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.andl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_andlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (Vlong Int64.zero); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.and_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_orlimm_correct:
+ forall n r,
+ let (op, args) := make_orlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.orl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_orlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (Vlong Int64.mone); split; auto. destruct (e#r); simpl; auto. rewrite Int64.or_mone; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_xorlimm_correct:
+ forall n r,
+ let (op, args) := make_xorlimm n r in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.xorl e#r (Vlong n)) v.
+Proof.
+ intros; unfold make_xorlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero; intros.
+ subst n. exists (e#r); split; auto. destruct (e#r); simpl; auto. rewrite Int64.xor_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone; intros.
+ subst n. exists (Val.notl e#r); split; auto.
+ econstructor; split; eauto. auto.
+Qed.
+
+Lemma make_mulfimm_correct:
+ forall n r1 r2,
+ e#r2 = Vfloat n ->
+ let (op, args) := make_mulfimm n r1 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfimm.
+ destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r1); simpl; auto. rewrite Float.mul2_add; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfimm_correct_2:
+ forall n r1 r2,
+ e#r1 = Vfloat n ->
+ let (op, args) := make_mulfimm n r2 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulf e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfimm.
+ destruct (Float.eq_dec n (Float.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r2); simpl; auto. rewrite Float.mul2_add; auto.
+ rewrite Float.mul_commut; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfsimm_correct:
+ forall n r1 r2,
+ e#r2 = Vsingle n ->
+ let (op, args) := make_mulfsimm n r1 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfsimm.
+ destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r1); simpl; auto. rewrite Float32.mul2_add; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_mulfsimm_correct_2:
+ forall n r1 r2,
+ e#r1 = Vsingle n ->
+ let (op, args) := make_mulfsimm n r2 r1 r2 in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.mulfs e#r1 e#r2) v.
+Proof.
+ intros; unfold make_mulfsimm.
+ destruct (Float32.eq_dec n (Float32.of_int (Int.repr 2))); intros.
+ simpl. econstructor; split. eauto. rewrite H; subst n.
+ destruct (e#r2); simpl; auto. rewrite Float32.mul2_add; auto.
+ rewrite Float32.mul_commut; auto.
+ simpl. econstructor; split; eauto.
+Qed.
+
+Lemma make_zext_correct:
+ forall s r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_zext s r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.zero_ext s e#r) v.
+Proof.
+ intros; unfold make_zext. destruct (vincl x (Uns Ptop s)) eqn:INCL.
+- exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Uns Ptop s)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_uns_zero_ext in H4 by auto. rewrite H4; auto.
+- econstructor; split; simpl; eauto.
+Qed.
+
+Lemma make_sext_correct:
+ forall s r x,
+ vmatch bc e#r x ->
+ let (op, args) := make_sext s r x in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v /\ Val.lessdef (Val.sign_ext s e#r) v.
+Proof.
+ intros; unfold make_sext. destruct (vincl x (Sgn Ptop s)) eqn:INCL.
+- exists e#r; split; auto.
+ assert (V: vmatch bc e#r (Sgn Ptop s)).
+ { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
+ inv V; simpl; auto. rewrite is_sgn_sign_ext in H4 by auto. rewrite H4; auto.
+- econstructor; split; simpl; eauto.
+Qed.
+
+Lemma op_strength_reduction_correct:
+ forall op args vl v,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_operation ge (Vptr sp Ptrofs.zero) op e##args m = Some v ->
+ let (op', args') := op_strength_reduction op args vl in
+ exists w, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some w /\ Val.lessdef v w.
+Proof.
+ intros until v; unfold op_strength_reduction;
+ case (op_strength_reduction_match op args vl); simpl; intros.
+- (* add 1 *)
+ rewrite Val.add_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto.
+- (* add 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_addimm_correct; auto.
+- (* addshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_addimm_correct; auto.
+- (* sub *)
+ InvApproxRegs; SimplVM; inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
+- (* subshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct, Val.sub_add_opp. apply make_addimm_correct; auto.
+- (* mul 1 *)
+ rewrite Val.mul_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
+- (* mul 2*)
+ InvApproxRegs; SimplVM; inv H0. apply make_mulimm_correct; auto.
+- (* divs *)
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divimm_correct; auto.
+- (* divu *)
+ assert (e#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divuimm_correct; auto.
+- (* and 1 *)
+ rewrite Val.and_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+- (* and 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+- (* andshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
+- (* andimm *)
+ inv H; inv H0. apply make_andimm_correct; auto.
+- (* or 1 *)
+ rewrite Val.or_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+- (* or 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+- (* orshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct; auto.
+- (* xor 1 *)
+ rewrite Val.xor_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+- (* xor 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+- (* xorshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct; auto.
+- (* bic *)
+ InvApproxRegs; SimplVM; inv H0. apply make_andimm_correct; auto.
+- (* bicshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
+- (* orn *)
+ InvApproxRegs; SimplVM; inv H0. apply make_orimm_correct; auto.
+- (* ornshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct; auto.
+- (* eor *)
+ InvApproxRegs; SimplVM; inv H0. apply make_xorimm_correct; auto.
+- (* eorshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct; auto.
+- (* shl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shlimm_correct; auto.
+- (* shr *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrimm_correct; auto.
+- (* shru *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shruimm_correct; auto.
+- (* zext *)
+ InvApproxRegs; SimplVM; inv H0. apply make_zext_correct; auto.
+- (* sext *)
+ InvApproxRegs; SimplVM; inv H0. apply make_sext_correct; auto.
+- (* addl 1 *)
+ rewrite Val.addl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto.
+- (* addl 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_addlimm_correct; auto.
+- (* addshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_addlimm_correct; auto.
+- (* addext *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct. apply make_addlimm_correct; auto.
+- (* subl *)
+ InvApproxRegs; SimplVM; inv H0. rewrite Val.subl_addl_opp. apply make_addlimm_correct; auto.
+- (* sublshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct, Val.subl_addl_opp. apply make_addlimm_correct; auto.
+- (* sublextend *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_extend_correct, Val.subl_addl_opp. apply make_addlimm_correct; auto.
+- (* mull 1 *)
+ rewrite Val.mull_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
+- (* mull 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_mullimm_correct; auto.
+- (* divl *)
+ assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divlimm_correct; auto.
+- (* divlu *)
+ assert (e#r2 = Vlong n2). clear H0. InvApproxRegs; SimplVM; auto.
+ apply make_divluimm_correct; auto.
+- (* andl 1 *)
+ rewrite Val.andl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
+- (* andl 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
+- (* andlshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_andlimm_correct; auto.
+- (* andlimm *)
+ inv H; inv H0. apply make_andlimm_correct; auto.
+- (* orl 1 *)
+ rewrite Val.orl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
+- (* orl 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
+- (* orlshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_orlimm_correct; auto.
+- (* xorl 1 *)
+ rewrite Val.xorl_commut in H0. InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
+- (* xorl 2 *)
+ InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
+- (* xorlshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_xorlimm_correct; auto.
+- (* bicl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_andlimm_correct; auto.
+- (* biclshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_andlimm_correct; auto.
+- (* ornl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_orlimm_correct; auto.
+- (* ornlshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_orlimm_correct; auto.
+- (* eorl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_xorlimm_correct; auto.
+- (* eorlshift *)
+ InvApproxRegs; SimplVM; inv H0. rewrite eval_static_shiftl_correct. apply make_xorlimm_correct; auto.
+- (* shll *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shllimm_correct; auto.
+- (* shrl *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrlimm_correct; auto.
+- (* shrlu *)
+ InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto.
+- (* cond *)
+ inv H0. apply make_cmp_correct; auto.
+- (* select *)
+ inv H0. apply make_select_correct; congruence.
+- (* mulf 1 *)
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
+- (* mulf 2 *)
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2).
+ rewrite <- H2. apply make_mulfimm_correct_2; auto.
+- (* mulfs 1 *)
+ InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfsimm_correct; auto.
+- (* mulfs 2 *)
+ InvApproxRegs; SimplVM; inv H0. fold (Val.mulfs (Vsingle n1) e#r2).
+ rewrite <- H2. apply make_mulfsimm_correct_2; auto.
+- (* default *)
+ exists v; auto.
+Qed.
+
+Lemma addr_strength_reduction_correct:
+ forall addr args vl res,
+ vl = map (fun r => AE.get r ae) args ->
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr e##args = Some res ->
+ let (addr', args') := addr_strength_reduction addr args vl in
+ exists res', eval_addressing ge (Vptr sp Ptrofs.zero) addr' e##args' = Some res' /\ Val.lessdef res res'.
+Proof.
+ intros until res. unfold addr_strength_reduction.
+ destruct (addr_strength_reduction_match addr args vl); simpl;
+ intros VL EA; InvApproxRegs; SimplVM; try (inv EA).
+- econstructor; split; eauto. inv H0; simpl; auto. rewrite H2.
+ unfold Genv.symbol_address. destruct (Genv.find_symbol ge symb); auto.
+- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
+ inv H0; auto. rewrite H2; auto.
+- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
+ inv H; auto. rewrite H3; auto.
+- rewrite Ptrofs.add_zero_l. econstructor; split; eauto.
+ inv H0; auto. rewrite H3. rewrite Ptrofs.add_commut; auto.
+- econstructor; split; eauto. rewrite Val.addl_commut. auto.
+- econstructor; split; eauto.
+- rewrite Ptrofs.add_zero_l. rewrite a64_range. econstructor; split; eauto.
+ inv H; auto. rewrite H3; auto.
+- rewrite a64_range. econstructor; split; eauto.
+- rewrite Ptrofs.add_zero_l, eval_static_extend_correct.
+ econstructor; split; eauto. inv H; auto. rewrite H3; auto.
+- rewrite eval_static_extend_correct.
+ econstructor; split; eauto.
+- exists res; auto.
+Qed.
+
+End STRENGTH_REDUCTION.
diff --git a/aarch64/Conventions1.v b/aarch64/Conventions1.v
new file mode 100644
index 00000000..efda835d
--- /dev/null
+++ b/aarch64/Conventions1.v
@@ -0,0 +1,285 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Function calling conventions and other conventions regarding the use of
+ machine registers and stack slots. *)
+
+Require Import Coqlib Decidableplus.
+Require Import AST Events Locations.
+Require Archi.
+
+(** * Classification of machine registers *)
+
+(** Machine registers (type [mreg] in module [Locations]) are divided in:
+- Callee-save registers, whose value is preserved across a function call.
+- Caller-save registers that can be modified during a function call.
+
+ We follow the Procedure Call Standard for the ARM 64-bit Architecture
+ (AArch64) document: R19-R28 and F8-F15 are callee-save. *)
+
+Definition is_callee_save (r: mreg): bool :=
+ match r with
+ | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 => false
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 => false
+ | R17 => false
+ | R19 | R20 | R21 | R22 | R23 => true
+ | R24 | R25 | R26 | R27 | R28 => true
+ | R29 => false
+ | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 => false
+ | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 => true
+ | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 => false
+ | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => false
+ end.
+
+Definition int_caller_save_regs :=
+ R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7
+ :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15
+ :: R17 :: R29 :: nil.
+
+Definition float_caller_save_regs :=
+ F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7
+ :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23
+ :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil.
+
+Definition int_callee_save_regs :=
+ R19 :: R20 :: R21 :: R22 :: R23
+ :: R24 :: R25 :: R26 :: R27 :: R28 :: nil.
+
+Definition float_callee_save_regs :=
+ F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: nil.
+
+Definition destroyed_at_call :=
+ List.filter (fun r => negb (is_callee_save r)) all_mregs.
+
+Definition dummy_int_reg := R0. (**r Used in [Coloring]. *)
+Definition dummy_float_reg := F0. (**r Used in [Coloring]. *)
+
+Definition callee_save_type := mreg_type.
+
+Definition is_float_reg (r: mreg): bool :=
+ match r with
+ | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
+ | R17 | R19 | R20 | R21 | R22 | R23
+ | R24 | R25 | R26 | R27 | R28
+ | R29 => false
+ | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7
+ | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15
+ | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23
+ | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true
+ end.
+
+(** * Function calling conventions *)
+
+(** The functions in this section determine the locations (machine registers
+ and stack slots) used to communicate arguments and results between the
+ caller and the callee during function calls. These locations are functions
+ of the signature of the function and of the call instruction.
+ Agreement between the caller and the callee on the locations to use
+ is guaranteed by our dynamic semantics for Cminor and RTL, which demand
+ that the signature of the call instruction is identical to that of the
+ called function.
+
+ Calling conventions are largely arbitrary: they must respect the properties
+ proved in this section (such as no overlapping between the locations
+ of function arguments), but this leaves much liberty in choosing actual
+ locations. *)
+
+(** ** Location of function result *)
+
+(** The result value of a function is passed back to the caller in
+ registers [R0] or [F0], depending on the type of the
+ returned value. We treat a function without result as a function
+ with one integer result. *)
+
+Definition loc_result (s: signature) : rpair mreg :=
+ match proj_sig_res s with
+ | Tint | Tlong | Tany32 | Tany64 => One R0
+ | Tfloat | Tsingle => One F0
+ end.
+
+(** The result registers have types compatible with that given in the signature. *)
+
+Lemma loc_result_type:
+ forall sig,
+ subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
+Proof.
+ intros. unfold loc_result. destruct (proj_sig_res sig); auto.
+Qed.
+
+(** The result locations are caller-save registers *)
+
+Lemma loc_result_caller_save:
+ forall (s: signature),
+ forall_rpair (fun r => is_callee_save r = false) (loc_result s).
+Proof.
+ intros.
+ unfold loc_result. destruct (proj_sig_res s); simpl; auto.
+Qed.
+
+(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
+
+Lemma loc_result_pair:
+ forall sg,
+ match loc_result sg with
+ | One _ => True
+ | Twolong r1 r2 =>
+ r1 <> r2 /\ proj_sig_res sg = Tlong
+ /\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
+ /\ Archi.ptr64 = false
+ end.
+Proof.
+ intros; unfold loc_result; destruct (proj_sig_res sg); exact I.
+Qed.
+
+(** The location of the result depends only on the result part of the signature *)
+
+Lemma loc_result_exten:
+ forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
+Proof.
+ intros. unfold loc_result, proj_sig_res. rewrite H; auto.
+Qed.
+
+(** ** Location of function arguments *)
+
+(**
+- The first 8 integer arguments are passed in registers [R0...R7].
+- The first 8 FP arguments are passed in registers [F0...F7].
+- Extra arguments are passed on the stack, in [Outgoing] slots of size
+ 64 bits (2 words), consecutively assigned, starting at word offset 0.
+**)
+
+Definition int_param_regs :=
+ R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7 :: nil.
+
+Definition float_param_regs :=
+ F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: nil.
+
+Fixpoint loc_arguments_rec
+ (tyl: list typ) (ir fr ofs: Z) {struct tyl} : list (rpair loc) :=
+ match tyl with
+ | nil => nil
+ | (Tint | Tlong | Tany32 | Tany64) as ty :: tys =>
+ match list_nth_z int_param_regs ir with
+ | None =>
+ One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2)
+ | Some ireg =>
+ One (R ireg) :: loc_arguments_rec tys (ir + 1) fr ofs
+ end
+ | (Tfloat | Tsingle) as ty :: tys =>
+ match list_nth_z float_param_regs fr with
+ | None =>
+ One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + 2)
+ | Some freg =>
+ One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs
+ end
+ end.
+
+(** [loc_arguments s] returns the list of locations where to store arguments
+ when calling a function with signature [s]. *)
+
+Definition loc_arguments (s: signature) : list (rpair loc) :=
+ loc_arguments_rec s.(sig_args) 0 0 0.
+
+(** Argument locations are either caller-save registers or [Outgoing]
+ stack slots at nonnegative offsets. *)
+
+Definition loc_argument_acceptable (l: loc) : Prop :=
+ match l with
+ | R r => is_callee_save r = false
+ | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs)
+ | _ => False
+ end.
+
+Definition loc_argument_charact (ofs: Z) (l: loc) : Prop :=
+ match l with
+ | R r => In r int_param_regs \/ In r float_param_regs
+ | S Outgoing ofs' ty => ofs' >= ofs /\ (2 | ofs')
+ | _ => False
+ end.
+
+Remark loc_arguments_rec_charact:
+ forall tyl ir fr ofs p,
+ In p (loc_arguments_rec tyl ir fr ofs) -> (2 | ofs) -> forall_rpair (loc_argument_charact ofs) p.
+Proof.
+ assert (X: forall ofs1 ofs2 l, loc_argument_charact ofs2 l -> ofs1 <= ofs2 -> loc_argument_charact ofs1 l).
+ { destruct l; simpl; intros; auto. destruct sl; auto. intuition omega. }
+ assert (Y: forall ofs1 ofs2 p, forall_rpair (loc_argument_charact ofs2) p -> ofs1 <= ofs2 -> forall_rpair (loc_argument_charact ofs1) p).
+ { destruct p; simpl; intuition eauto. }
+ assert (Z: forall ofs, (2 | ofs) -> (2 | ofs + 2)).
+ { intros. apply Z.divide_add_r; auto. apply Z.divide_refl. }
+Opaque list_nth_z.
+ induction tyl; simpl loc_arguments_rec; intros.
+- contradiction.
+- assert (A: forall ty, In p
+ match list_nth_z int_param_regs ir with
+ | Some ireg => One (R ireg) :: loc_arguments_rec tyl (ir + 1) fr ofs
+ | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2)
+ end ->
+ forall_rpair (loc_argument_charact ofs) p).
+ { intros. destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H1.
+ subst. left. eapply list_nth_z_in; eauto.
+ eapply IHtyl; eauto.
+ subst. split. omega. assumption.
+ eapply Y; eauto. omega. }
+ assert (B: forall ty, In p
+ match list_nth_z float_param_regs fr with
+ | Some ireg => One (R ireg) :: loc_arguments_rec tyl ir (fr + 1) ofs
+ | None => One (S Outgoing ofs ty) :: loc_arguments_rec tyl ir fr (ofs + 2)
+ end ->
+ forall_rpair (loc_argument_charact ofs) p).
+ { intros. destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H1.
+ subst. right. eapply list_nth_z_in; eauto.
+ eapply IHtyl; eauto.
+ subst. split. omega. assumption.
+ eapply Y; eauto. omega. }
+ destruct a; eauto.
+Qed.
+
+Lemma loc_arguments_acceptable:
+ forall (s: signature) (p: rpair loc),
+ In p (loc_arguments s) -> forall_rpair loc_argument_acceptable p.
+Proof.
+ unfold loc_arguments; intros.
+ assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (X: forall l, loc_argument_charact 0 l -> loc_argument_acceptable l).
+ { unfold loc_argument_charact, loc_argument_acceptable.
+ destruct l as [r | [] ofs ty]; auto. intros [C|C]; auto.
+ intros [C D]. split; auto. apply Z.divide_trans with 2; auto.
+ exists (2 / typealign ty); destruct ty; reflexivity.
+ }
+ exploit loc_arguments_rec_charact; eauto using Z.divide_0_r.
+ unfold forall_rpair; destruct p; intuition auto.
+Qed.
+
+Hint Resolve loc_arguments_acceptable: locs.
+
+Lemma loc_arguments_main:
+ loc_arguments signature_main = nil.
+Proof.
+ unfold loc_arguments; reflexivity.
+Qed.
+
+(** ** Normalization of function results *)
+
+(** According to the AAPCS64 ABI specification, "padding bits" in the return
+ value of a function have unpredictable values and must be ignored.
+ Consequently, we force normalization of return values of small integer
+ types (8- and 16-bit integers), so that the top bits (the "padding bits")
+ are proper sign- or zero-extensions of the small integer value. *)
+
+Definition return_value_needs_normalization (t: rettype) : bool :=
+ match t with
+ | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true
+ | _ => false
+ end.
diff --git a/aarch64/DuplicateOpcodeHeuristic.ml b/aarch64/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..5fc2156c
--- /dev/null
+++ b/aarch64/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,27 @@
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c | Ccompfs c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c | Cnotcompfs c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
+
diff --git a/aarch64/Machregs.v b/aarch64/Machregs.v
new file mode 100644
index 00000000..b2a2308e
--- /dev/null
+++ b/aarch64/Machregs.v
@@ -0,0 +1,210 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+Require Import String.
+Require Import Coqlib Decidableplus Maps.
+Require Import AST Op.
+
+(** ** Machine registers *)
+
+(** Integer register 16 is reserved as temporary and for call veeners.
+ Integer register 18 is reserved as the platform register.
+ Integer register 30 is reserved for the return address. *)
+
+Inductive mreg: Type :=
+ (** Allocatable integer regs *)
+ | R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7
+ | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
+ | R17 | R19 | R20 | R21 | R22 | R23
+ | R24 | R25 | R26 | R27 | R28 | R29
+ (** Allocatable floating-point regs *)
+ | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7
+ | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15
+ | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23
+ | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31.
+
+Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
+Proof. decide equality. Defined.
+Global Opaque mreg_eq.
+
+Definition all_mregs :=
+ R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7
+ :: R8 :: R9 :: R10 :: R11 :: R12 :: R13 :: R14 :: R15
+ :: R17 :: R19 :: R20 :: R21 :: R22 :: R23
+ :: R24 :: R25 :: R26 :: R27 :: R28 :: R29
+ :: F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7
+ :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15
+ :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: F23
+ :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31
+ :: nil.
+
+Lemma all_mregs_complete:
+ forall (r: mreg), In r all_mregs.
+Proof.
+ assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity).
+ intros. specialize (H r). InvBooleans. auto.
+Qed.
+
+Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq.
+
+Instance Finite_mreg : Finite mreg := {
+ Finite_elements := all_mregs;
+ Finite_elements_spec := all_mregs_complete
+}.
+
+Definition mreg_type (r: mreg): typ := Tany64.
+
+Open Scope positive_scope.
+
+Module IndexedMreg <: INDEXED_TYPE.
+ Definition t := mreg.
+ Definition eq := mreg_eq.
+ Definition index (r: mreg): positive :=
+ match r with
+ | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4
+ | R4 => 5 | R5 => 6 | R6 => 7 | R7 => 8
+ | R8 => 9 | R9 => 10 | R10 => 11 | R11 => 12
+ | R12 => 13 | R13 => 14 | R14 => 15 | R15 => 16
+ | R17 => 17 | R19 => 19
+ | R20 => 20 | R21 => 21 | R22 => 22 | R23 => 23
+ | R24 => 24 | R25 => 25 | R26 => 26 | R27 => 27
+ | R28 => 28 | R29 => 29
+ | F0 => 32 | F1 => 33 | F2 => 34 | F3 => 35
+ | F4 => 36 | F5 => 37 | F6 => 38 | F7 => 39
+ | F8 => 40 | F9 => 41 | F10 => 42 | F11 => 43
+ | F12 => 44 | F13 => 45 | F14 => 46 | F15 => 47
+ | F16 => 48 | F17 => 49 | F18 => 50 | F19 => 51
+ | F20 => 52 | F21 => 53 | F22 => 54 | F23 => 55
+ | F24 => 56 | F25 => 57 | F26 => 58 | F27 => 59
+ | F28 => 60 | F29 => 61 | F30 => 62 | F31 => 63
+ end.
+ Lemma index_inj:
+ forall r1 r2, index r1 = index r2 -> r1 = r2.
+ Proof.
+ decide_goal.
+ Qed.
+End IndexedMreg.
+
+Definition is_stack_reg (r: mreg) : bool := false.
+
+(** ** Names of registers *)
+
+Local Open Scope string_scope.
+
+Definition register_names :=
+ ("X0", R0) :: ("X1", R1) :: ("X2", R2) :: ("X3", R3)
+ :: ("X4", R4) :: ("X5", R5) :: ("X6", R6) :: ("X7", R7)
+ :: ("X8", R8) :: ("X9", R9) :: ("X10", R10) :: ("X11", R11)
+ :: ("X12", R12) :: ("X13", R13) :: ("X14", R14) :: ("X15", R15)
+ :: ("X17", R17) :: ("X19", R19)
+ :: ("X20", R20) :: ("X21", R21) :: ("X22", R22) :: ("X23", R23)
+ :: ("X24", R24) :: ("X25", R25) :: ("X26", R26) :: ("X27", R27)
+ :: ("X28", R28) :: ("X29", R29)
+ :: ("D0", F0) :: ("D1", F1) :: ("D2", F2) :: ("D3", F3)
+ :: ("D4", F4) :: ("D5", F5) :: ("D6", F6) :: ("D7", F7)
+ :: ("D8", F8) :: ("D9", F9) :: ("D10", F10) :: ("D11", F11)
+ :: ("D12", F12) :: ("D13", F13) :: ("D14", F14) :: ("D15", F15)
+ :: ("D16", F16) :: ("D17", F17) :: ("D18", F18) :: ("D19", F19)
+ :: ("D20", F20) :: ("D21", F21) :: ("D22", F22) :: ("D23", F23)
+ :: ("D24", F24) :: ("D25", F25) :: ("D26", F26) :: ("D27", F27)
+ :: ("D28", F28) :: ("D29", F29) :: ("D30", F30) :: ("D31", F31)
+ :: nil.
+
+Definition register_by_name (s: string) : option mreg :=
+ let fix assoc (l: list (string * mreg)) : option mreg :=
+ match l with
+ | nil => None
+ | (s1, r1) :: l' => if string_dec s s1 then Some r1 else assoc l'
+ end
+ in assoc register_names.
+
+(** ** Destroyed registers, preferred registers *)
+
+Definition destroyed_by_op (op: operation): list mreg :=
+ match op with
+ | Oshrximm _ | Oshrlximm _ => R17 :: nil
+ | _ => nil
+ end.
+
+Definition destroyed_by_load (chunk: memory_chunk) (addr: addressing): list mreg :=
+ nil.
+
+Definition destroyed_by_store (chunk: memory_chunk) (addr: addressing): list mreg := nil.
+
+Definition destroyed_by_cond (cond: condition): list mreg := nil.
+
+Definition destroyed_by_jumptable: list mreg := R17 :: nil.
+
+Fixpoint destroyed_by_clobber (cl: list string): list mreg :=
+ match cl with
+ | nil => nil
+ | c1 :: cl =>
+ match register_by_name c1 with
+ | Some r => r :: destroyed_by_clobber cl
+ | None => destroyed_by_clobber cl
+ end
+ end.
+
+Definition destroyed_by_builtin (ef: external_function): list mreg :=
+ match ef with
+ | EF_memcpy sz al => R15 :: R17 :: R29 :: nil
+ | EF_inline_asm txt sg clob => destroyed_by_clobber clob
+ | _ => nil
+ end.
+
+Definition destroyed_by_setstack (ty: typ): list mreg := nil.
+
+Definition destroyed_at_function_entry: list mreg := R29 :: nil.
+
+Definition destroyed_at_indirect_call: list mreg := nil.
+
+Definition temp_for_parent_frame: mreg := R29.
+
+Definition mregs_for_operation (op: operation): list (option mreg) * option mreg :=
+ (nil, None).
+
+Definition mregs_for_builtin (ef: external_function): list (option mreg) * list(option mreg) :=
+ (nil, nil).
+
+Global Opaque
+ destroyed_by_op destroyed_by_load destroyed_by_store
+ destroyed_by_cond destroyed_by_jumptable destroyed_by_builtin
+ destroyed_by_setstack destroyed_at_function_entry temp_for_parent_frame
+ destroyed_at_indirect_call
+ mregs_for_operation mregs_for_builtin.
+
+(** Two-address operations. Return [true] if the first argument and
+ the result must be in the same location *and* are unconstrained
+ by [mregs_for_operation]. There is one for AArch64: [Olowlong],
+ which is actually a no-operation in the generated asm code. *)
+
+Definition two_address_op (op: operation) : bool :=
+ match op with
+ | Olowlong => true
+ | _ => false
+ end.
+
+Global Opaque two_address_op.
+
+(* Constraints on constant propagation for builtins *)
+
+Definition builtin_constraints (ef: external_function) :
+ list builtin_arg_constraint :=
+ match ef with
+ | EF_vload _ => OK_addressing :: nil
+ | EF_vstore _ => OK_addressing :: OK_default :: nil
+ | EF_memcpy _ _ => OK_addrstack :: OK_addrstack :: nil
+ | EF_annot kind txt targs => map (fun _ => OK_all) targs
+ | EF_debug kind txt targs => map (fun _ => OK_all) targs
+ | _ => nil
+ end.
+
diff --git a/aarch64/Machregsaux.ml b/aarch64/Machregsaux.ml
new file mode 100644
index 00000000..f13a9ff5
--- /dev/null
+++ b/aarch64/Machregsaux.ml
@@ -0,0 +1,40 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Auxiliary functions on machine registers *)
+
+open Camlcoq
+open Machregs
+
+let register_names : (mreg, string) Hashtbl.t = Hashtbl.create 31
+
+let _ =
+ List.iter
+ (fun (s, r) -> Hashtbl.add register_names r (camlstring_of_coqstring s))
+ Machregs.register_names
+
+let is_scratch_register s =
+ s = "X16" || s = "x16" || s = "X30" || s = "x30"
+
+
+let name_of_register r =
+ try Some (Hashtbl.find register_names r) with Not_found -> None
+
+let register_by_name s =
+ Machregs.register_by_name (coqstring_uppercase_ascii_of_camlstring s)
+
+let can_reserve_register r = Conventions1.is_callee_save r
+
+let class_of_type = function
+ | AST.Tint | AST.Tlong -> 0
+ | AST.Tfloat | AST.Tsingle -> 1
+ | AST.Tany32 | AST.Tany64 -> assert false
diff --git a/aarch64/NeedOp.v b/aarch64/NeedOp.v
new file mode 100644
index 00000000..8fcab9e1
--- /dev/null
+++ b/aarch64/NeedOp.v
@@ -0,0 +1,253 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+Require Import Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs.
+Require Import Op RTL.
+Require Import NeedDomain.
+
+(** Neededness analysis for AArch64 operators *)
+
+Definition needs_of_shift (s: shift) (a: amount32) (nv: nval) :=
+ match s with
+ | Slsl => shlimm nv a
+ | Sasr => shrimm nv a
+ | Slsr => shruimm nv a
+ | Sror => ror nv a
+ end.
+
+Definition zero_ext' (s: Z) (nv: nval) :=
+ if zle 0 s then zero_ext s nv else default nv.
+Definition sign_ext' (s: Z) (nv: nval) :=
+ if zlt 0 s then sign_ext s nv else default nv.
+
+Definition op1 (nv: nval) := nv :: nil.
+Definition op2 (nv: nval) := nv :: nv :: nil.
+Definition op1shift (s: shift) (a: amount32) (nv: nval) :=
+ needs_of_shift s a nv :: nil.
+Definition op2shift (s: shift) (a: amount32) (nv: nval) :=
+ nv :: needs_of_shift s a nv :: nil.
+
+Definition needs_of_condition (cond: condition): list nval := nil.
+
+Definition needs_of_operation (op: operation) (nv: nval): list nval :=
+ match op with
+ | Omove => nv :: nil
+ | Ointconst _ => nil
+ | Olongconst _ => nil
+ | Ofloatconst _ => nil
+ | Osingleconst _ => nil
+ | Oaddrsymbol _ _ => nil
+ | Oaddrstack _ => nil
+ | Oshift s a => op1shift s a nv
+ | Oadd | Osub | Omul => op2 (modarith nv)
+ | Oaddshift s a | Osubshift s a => op2shift s a (modarith nv)
+ | Oaddimm _ => op1 (modarith nv)
+ | Oneg => op1 (modarith nv)
+ | Onegshift s a => op1shift s a (modarith nv)
+ | Omuladd | Omulsub =>
+ let n := modarith nv in n :: n :: n :: nil
+ | Odiv | Odivu => op2 (default nv)
+ | Oand | Oor | Oxor => op2 (bitwise nv)
+ | Oandshift s a | Oorshift s a | Oxorshift s a => op2shift s a (bitwise nv)
+ | Oandimm n => op1 (andimm nv n)
+ | Oorimm n => op1 (orimm nv n)
+ | Oxorimm n => op1 (bitwise nv)
+ | Onot => op1 (bitwise nv)
+ | Onotshift s a => needs_of_shift s a (bitwise nv) :: nil
+ | Obic | Oorn | Oeqv =>
+ let n := bitwise nv in n :: bitwise n :: nil
+ | Obicshift s a | Oornshift s a | Oeqvshift s a =>
+ let n := bitwise nv in n :: needs_of_shift s a (bitwise n) :: nil
+ | Oshl | Oshr | Oshru => op2 (default nv)
+ | Oshrximm _ => op1 (default nv)
+ | Ozext s => op1 (zero_ext' s nv)
+ | Osext s => op1 (sign_ext' s nv)
+ | Oshlzext s a => op1 (zero_ext' s (shlimm nv a))
+ | Oshlsext s a => op1 (sign_ext' s (shlimm nv a))
+ | Ozextshr a s => op1 (shruimm (zero_ext' s nv) a)
+ | Osextshr a s => op1 (shrimm (sign_ext' s nv) a)
+
+ | Oshiftl _ _ | Oextend _ _ => op1 (default nv)
+ | Omakelong | Olowlong | Ohighlong => op1 (default nv)
+ | Oaddl | Osubl | Omull => op2 (default nv)
+ | Oaddlshift _ _ | Oaddlext _ _ | Osublshift _ _ | Osublext _ _ => op2 (default nv)
+ | Oaddlimm _ => op1 (default nv)
+ | Onegl => op1 (default nv)
+ | Oneglshift _ _ => op1 (default nv)
+ | Omulladd | Omullsub => let n := default nv in n :: n :: n :: nil
+ | Omullhs | Omullhu | Odivl | Odivlu => op2 (default nv)
+ | Oandl | Oorl | Oxorl | Obicl | Oornl | Oeqvl => op2 (default nv)
+ | Oandlshift _ _ | Oorlshift _ _ | Oxorlshift _ _
+ | Obiclshift _ _ | Oornlshift _ _ | Oeqvlshift _ _ => op2 (default nv)
+ | Oandlimm _ | Oorlimm _ | Oxorlimm _ => op1 (default nv)
+ | Onotl => op1 (default nv)
+ | Onotlshift _ _ => op1 (default nv)
+ | Oshll | Oshrl | Oshrlu => op2 (default nv)
+ | Oshrlximm _ => op1 (default nv)
+ | Ozextl _ | Osextl _
+ | Oshllzext _ _ | Oshllsext _ _ | Ozextshrl _ _ | Osextshrl _ _ => op1 (default nv)
+ | Onegf | Oabsf => op1 (default nv)
+ | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
+ | Onegfs | Oabsfs => op1 (default nv)
+ | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
+ | Ofloatofsingle | Osingleoffloat => op1 (default nv)
+ | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => op1 (default nv)
+ | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv)
+ | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv)
+ | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv)
+ | Ocmp c => needs_of_condition c
+ | Osel c ty => nv :: nv :: needs_of_condition c
+ end.
+
+Definition operation_is_redundant (op: operation) (nv: nval): bool :=
+ match op with
+ | Ozext s => zle 0 s && zero_ext_redundant s nv
+ | Osext s => zlt 0 s && sign_ext_redundant s nv
+ | Oandimm n => andimm_redundant nv n
+ | Oorimm n => orimm_redundant nv n
+ | _ => false
+ end.
+
+Ltac InvAgree :=
+ match goal with
+ | [H: vagree_list nil _ _ |- _ ] => inv H; InvAgree
+ | [H: vagree_list (_::_) _ _ |- _ ] => inv H; InvAgree
+ | _ => idtac
+ end.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, Some ?x = Some v /\ _ ] => exists x; split; auto
+ | _ => idtac
+ end.
+
+Lemma shift_sound:
+ forall v w s a x,
+ vagree v w (needs_of_shift s a x) ->
+ vagree (eval_shift s v a) (eval_shift s w a) x.
+Proof.
+ intros until x; destruct s; simpl; intros.
+- apply shlimm_sound; auto.
+- apply shruimm_sound; auto.
+- apply shrimm_sound; auto.
+- apply ror_sound; auto.
+Qed.
+
+Lemma zero_ext'_sound:
+ forall v w x n,
+ vagree v w (zero_ext' n x) ->
+ vagree (Val.zero_ext n v) (Val.zero_ext n w) x.
+Proof.
+ unfold zero_ext'; intros. destruct (zle 0 n).
+- apply zero_ext_sound; auto.
+- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto).
+ destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.zero_ext_lessdef; auto.
+Qed.
+
+Lemma sign_ext'_sound:
+ forall v w x n,
+ vagree v w (sign_ext' n x) ->
+ vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
+Proof.
+ unfold sign_ext'; intros. destruct (zlt 0 n).
+- apply sign_ext_sound; auto.
+- assert (E: x = Nothing \/ Val.lessdef v w) by (destruct x; auto).
+ destruct E. subst x; simpl; auto. apply vagree_lessdef; apply Val.sign_ext_lessdef; auto.
+Qed.
+
+Section SOUNDNESS.
+
+Variable ge: genv.
+Variable sp: block.
+Variables m m': mem.
+Hypothesis PERM: forall b ofs k p, Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.
+
+Lemma needs_of_condition_sound:
+ forall cond args b args',
+ eval_condition cond args m = Some b ->
+ vagree_list args args' (needs_of_condition cond) ->
+ eval_condition cond args' m' = Some b.
+Proof.
+ intros. unfold needs_of_condition in H0.
+ eapply default_needs_of_condition_sound; eauto.
+Qed.
+
+Lemma needs_of_operation_sound:
+ forall op args v nv args',
+ eval_operation ge (Vptr sp Ptrofs.zero) op args m = Some v ->
+ vagree_list args args' (needs_of_operation op nv) ->
+ nv <> Nothing ->
+ exists v',
+ eval_operation ge (Vptr sp Ptrofs.zero) op args' m' = Some v'
+ /\ vagree v v' nv.
+Proof.
+ unfold needs_of_operation; intros; destruct op; try (eapply default_needs_of_operation_sound; eauto; fail);
+ simpl in *; FuncInv; InvAgree; TrivialExists.
+- apply shift_sound; auto.
+- apply add_sound; auto.
+- apply add_sound; auto using shift_sound.
+- apply add_sound; auto with na.
+- apply neg_sound; auto.
+- apply neg_sound; auto using shift_sound.
+- apply sub_sound; auto.
+- apply sub_sound; auto using shift_sound.
+- apply mul_sound; auto.
+- apply add_sound; auto. apply mul_sound; rewrite modarith_idem; auto.
+- apply sub_sound; auto. apply mul_sound; rewrite modarith_idem; auto.
+- apply and_sound; auto.
+- apply and_sound; auto using shift_sound.
+- apply andimm_sound; auto.
+- apply or_sound; auto.
+- apply or_sound; auto using shift_sound.
+- apply orimm_sound; auto.
+- apply xor_sound; auto.
+- apply xor_sound; auto using shift_sound.
+- apply xor_sound; auto with na.
+- apply notint_sound; auto.
+- apply notint_sound; auto using shift_sound.
+- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
+- apply and_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
+- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
+- apply or_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
+- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto.
+- apply xor_sound; auto. apply notint_sound; rewrite bitwise_idem; auto using shift_sound.
+- apply zero_ext'_sound; auto.
+- apply sign_ext'_sound; auto.
+- apply shlimm_sound; apply zero_ext'_sound; auto.
+- apply shlimm_sound; apply sign_ext'_sound; auto.
+- apply zero_ext'_sound; apply shruimm_sound; auto.
+- apply sign_ext'_sound; apply shrimm_sound; auto.
+- destruct (eval_condition cond args m) as [b|] eqn:EC.
+ erewrite needs_of_condition_sound by eauto.
+ apply select_sound; auto.
+ simpl; auto with na.
+Qed.
+
+Lemma operation_is_redundant_sound:
+ forall op nv arg1 args v arg1' args',
+ operation_is_redundant op nv = true ->
+ eval_operation ge (Vptr sp Ptrofs.zero) op (arg1 :: args) m = Some v ->
+ vagree_list (arg1 :: args) (arg1' :: args') (needs_of_operation op nv) ->
+ vagree v arg1' nv.
+Proof.
+ intros. destruct op; simpl in *; try discriminate; inv H1; FuncInv; subst.
+- apply andimm_redundant_sound; auto.
+- apply orimm_redundant_sound; auto.
+- InvBooleans. unfold zero_ext' in H5; rewrite zle_true in H5 by auto.
+ apply zero_ext_redundant_sound; auto.
+- InvBooleans. unfold sign_ext' in H5; rewrite zlt_true in H5 by auto.
+ apply sign_ext_redundant_sound; auto.
+Qed.
+
+End SOUNDNESS.
diff --git a/aarch64/Op.v b/aarch64/Op.v
new file mode 100644
index 00000000..c0b9d435
--- /dev/null
+++ b/aarch64/Op.v
@@ -0,0 +1,1848 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Operators and addressing modes. The abstract syntax and dynamic
+ semantics for the CminorSel, RTL, LTL and Mach languages depend on the
+ following types, defined in this library:
+- [condition]: boolean conditions for conditional branches;
+- [operation]: arithmetic and logical operations;
+- [addressing]: addressing modes for load and store operations.
+
+ These types are processor-specific and correspond roughly to what the
+ processor can compute in one instruction. In other terms, these
+ types reflect the state of the program after instruction selection.
+ For a processor-independent set of operations, see the abstract
+ syntax and dynamic semantics of the Cminor language.
+*)
+
+Require Import Axioms Coqlib BoolEqual.
+Require Import AST Integers Floats Values Memory Globalenvs Events.
+
+Set Implicit Arguments.
+Local Transparent Archi.ptr64.
+
+(** Shift amounts *)
+
+Record amount32 : Type := {
+ a32_amount :> int;
+ a32_range : Int.ltu a32_amount Int.iwordsize = true }.
+
+Record amount64 : Type := {
+ a64_amount :> int;
+ a64_range : Int.ltu a64_amount Int64.iwordsize' = true }.
+
+(** Shifted operands *)
+
+Inductive shift : Type :=
+ | Slsl (**r left shift *)
+ | Slsr (**r right unsigned shift *)
+ | Sasr (**r right signed shift *)
+ | Sror. (**r rotate right *)
+
+(** Sign- or zero-extended operands *)
+
+Inductive extension : Type :=
+ | Xsgn32 (**r from signed 32-bit integer to 64-bit integer *)
+ | Xuns32. (**r from unsigned 32-bit integer to 64-bit integer *)
+
+(** Conditions (boolean-valued operators). *)
+
+Inductive condition: Type :=
+(** Tests over 32-bit integers *)
+ | Ccomp (c: comparison) (**r signed comparison *)
+ | Ccompu (c: comparison) (**r unsigned comparison *)
+ | Ccompimm (c: comparison) (n: int) (**r signed comparison with constant *)
+ | Ccompuimm (c: comparison) (n: int) (**r unsigned comparison with constant *)
+ | Ccompshift (c: comparison) (s: shift) (a: amount32) (**r signed comparison with shift *)
+ | Ccompushift (c: comparison) (s: shift) (a: amount32)(**r unsigned comparison width shift *)
+ | Cmaskzero (n: int) (**r test [(arg & n) == 0] *)
+ | Cmasknotzero (n: int) (**r test [(arg & n) != 0] *)
+(** Tests over 64-bit integers *)
+ | Ccompl (c: comparison) (**r signed comparison *)
+ | Ccomplu (c: comparison) (**r unsigned comparison *)
+ | Ccomplimm (c: comparison) (n: int64) (**r signed comparison with constant *)
+ | Ccompluimm (c: comparison) (n: int64) (**r unsigned comparison with constant *)
+ | Ccomplshift (c: comparison) (s: shift) (a: amount64)(**r signed comparison with shift *)
+ | Ccomplushift (c: comparison) (s: shift) (a: amount64)(**r unsigned comparison width shift *)
+ | Cmasklzero (n: int64) (**r test [(arg & n) == 0] *)
+ | Cmasklnotzero (n: int64) (**r test [(arg & n) != 0] *)
+(** Tests over 64-bit floating-point numbers *)
+ | Ccompf (c: comparison) (**r FP comparison *)
+ | Cnotcompf (c: comparison) (**r negation of an FP comparison *)
+ | Ccompfzero (c: comparison) (**r comparison with 0.0 *)
+ | Cnotcompfzero (c: comparison) (**r negation of comparison with 0.0 *)
+(** Tests over 32-bit floating-point numbers *)
+ | Ccompfs (c: comparison) (**r FP comparison *)
+ | Cnotcompfs (c: comparison) (**r negation of an FP comparison *)
+ | Ccompfszero (c: comparison) (**r equal to 0.0 *)
+ | Cnotcompfszero (c: comparison). (**r not equal to 0.0 *)
+
+(** Arithmetic and logical operations. In the descriptions, [rd] is the
+ result of the operation and [r1], [r2], etc, are the arguments. *)
+
+Inductive operation : Type :=
+ | Omove (**r [rd = r1] *)
+ | Ointconst (n: int) (**r [rd] is set to the given integer constant *)
+ | Olongconst (n: int64) (**r [rd] is set to the given integer constant *)
+ | Ofloatconst (n: float) (**r [rd] is set to the given float constant *)
+ | Osingleconst (n: float32) (**r [rd] is set to the given float constant *)
+ | Oaddrsymbol (id: ident) (ofs: ptrofs) (**r [rd] is set to the address of the symbol plus the given offset *)
+ | Oaddrstack (ofs: ptrofs) (**r [rd] is set to the stack pointer plus the given offset *)
+(** 32-bit integer arithmetic *)
+ | Oshift (s: shift) (a: amount32) (**r shift or rotate by immediate quantity *)
+ | Oadd (**r [rd = r1 + r2] *)
+ | Oaddshift (s: shift) (a: amount32) (**r [rd = r1 + shifted r2] *)
+ | Oaddimm (n: int) (**r [rd = r1 + n] *)
+ | Oneg (**r [rd = - r1] *)
+ | Onegshift (s: shift) (a: amount32) (**r [rd = - shifted r1] *)
+ | Osub (**r [rd = r1 - r2] *)
+ | Osubshift (s: shift) (a: amount32) (**r [rd = r1 - shifted r2] *)
+ | Omul (**r [rd = r1 * r2] *)
+ | Omuladd (**r [rd = r1 + r2 * r3] *)
+ | Omulsub (**r [rd = r1 - r2 * r3] *)
+ | Odiv (**r [rd = r1 / r2] (signed) *)
+ | Odivu (**r [rd = r1 / r2] (unsigned) *)
+ | Oand (**r [rd = r1 & r2] *)
+ | Oandshift (s: shift) (a: amount32) (**r [rd = r1 & shifted r2] *)
+ | Oandimm (n: int) (**r [rd = r1 & n] *)
+ | Oor (**r [rd = r1 | r2] *)
+ | Oorshift (s: shift) (a: amount32) (**r [rd = r1 | shifted r2] *)
+ | Oorimm (n: int) (**r [rd = r1 | n] *)
+ | Oxor (**r [rd = r1 ^ r2] *)
+ | Oxorshift (s: shift) (a: amount32) (**r [rd = r1 ^ shifted r2] *)
+ | Oxorimm (n: int) (**r [rd = r1 ^ n] *)
+ | Onot (**r [rd = ~r1] *)
+ | Onotshift (s: shift) (a: amount32) (**r [rd = ~ shifted r1] *)
+ | Obic (**r [rd = r1 & ~r2] *)
+ | Obicshift (s: shift) (a: amount32) (**r [rd = r1 ^ ~ shifted r2] *)
+ | Oorn (**r [rd = r1 | ~r2] *)
+ | Oornshift (s: shift) (a: amount32) (**r [rd = r1 | ~ shifted r2] *)
+ | Oeqv (**r [rd = r1 ^ ~r2] *)
+ | Oeqvshift (s: shift) (a: amount32) (**r [rd = r1 | ~ shifted r2] *)
+ | Oshl (**r [rd = r1 << r2] *)
+ | Oshr (**r [rd = r1 >> r2] (signed) *)
+ | Oshru (**r [rd = r1 >> r2] (unsigned) *)
+ | Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *)
+ | Ozext (s: Z) (**r [rd = zero_ext(r1,s)] *)
+ | Osext (s: Z) (**r [rd = sign_ext(r1,s)] *)
+ | Oshlzext (s: Z) (a: amount32) (**r [rd = zero_ext(r1,s) << a] *)
+ | Oshlsext (s: Z) (a: amount32) (**r [rd = sign_ext(r1,s) << a] *)
+ | Ozextshr (a: amount32) (s: Z) (**r [rd = zero_ext(r1 >> a, s)] *)
+ | Osextshr (a: amount32) (s: Z) (**r [rd = sign_ext(r1 >> a, s)] *)
+(** 64-bit integer arithmetic *)
+ | Oshiftl (s: shift) (a: amount64) (**r shift or rotate by immediate quantity *)
+ | Oextend (x: extension) (a: amount64) (**r convert from 32 to 64 bits and shift *)
+ | Omakelong (**r [rd = r1 << 32 | r2] *)
+ | Olowlong (**r [rd = low-word(r1)] *)
+ | Ohighlong (**r [rd = high-word(r1)] *)
+ | Oaddl (**r [rd = r1 + r2] *)
+ | Oaddlshift (s: shift) (a: amount64) (**r [rd = r1 + shifted r2] *)
+ | Oaddlext (x: extension) (a: amount64) (**r [rd = r1 + shifted, converted r2] *)
+ | Oaddlimm (n: int64) (**r [rd = r1 + n] *)
+ | Onegl (**r [rd = - r1] *)
+ | Oneglshift (s: shift) (a: amount64) (**r [rd = - shifted r1] *)
+ | Osubl (**r [rd = r1 - r2] *)
+ | Osublshift (s: shift) (a: amount64) (**r [rd = r1 - shifted r2] *)
+ | Osublext (x: extension) (a: amount64) (**r [rd = r1 - shifted, converted r2] *)
+ | Omull (**r [rd = r1 * r2] *)
+ | Omulladd (**r [rd = r1 + r2 * r3] *)
+ | Omullsub (**r [rd = r1 - r2 * r3] *)
+ | Omullhs (**r [rd = high part of r1 * r2 (signed)] *)
+ | Omullhu (**r [rd = high part of r1 * r2 (unsigned)] *)
+ | Odivl (**r [rd = r1 / r2] (signed) *)
+ | Odivlu (**r [rd = r1 / r2] (unsigned) *)
+ | Oandl (**r [rd = r1 & r2] *)
+ | Oandlshift (s: shift) (a: amount64) (**r [rd = r1 & shifted r2] *)
+ | Oandlimm (n: int64) (**r [rd = r1 & n] *)
+ | Oorl (**r [rd = r1 | r2] *)
+ | Oorlshift (s: shift) (a: amount64) (**r [rd = r1 | shifted r2] *)
+ | Oorlimm (n: int64) (**r [rd = r1 | n] *)
+ | Oxorl (**r [rd = r1 ^ r2] *)
+ | Oxorlshift (s: shift) (a: amount64) (**r [rd = r1 ^ shifted r2] *)
+ | Oxorlimm (n: int64) (**r [rd = r1 ^ n] *)
+ | Onotl (**r [rd = ~r1] *)
+ | Onotlshift (s: shift) (a: amount64) (**r [rd = ~ shifted r1] *)
+ | Obicl (**r [rd = r1 & ~r2] *)
+ | Obiclshift (s: shift) (a: amount64) (**r [rd = r1 ^ ~ shifted r2] *)
+ | Oornl (**r [rd = r1 | ~r2] *)
+ | Oornlshift (s: shift) (a: amount64) (**r [rd = r1 | ~ shifted r2] *)
+ | Oeqvl (**r [rd = r1 ^ ~r2] *)
+ | Oeqvlshift (s: shift) (a: amount64) (**r [rd = r1 | ~ shifted r2] *)
+ | Oshll (**r [rd = r1 << r2] *)
+ | Oshrl (**r [rd = r1 >> r2] (signed) *)
+ | Oshrlu (**r [rd = r1 >> r2] (unsigned) *)
+ | Oshrlximm (n: int) (**r [rd = r1 / 2^n] (signed) *)
+ | Ozextl (s: Z) (**r [rd = zero_ext(r1,s)] *)
+ | Osextl (s: Z) (**r [rd = sign_ext(r1,s)] *)
+ | Oshllzext (s: Z) (a: amount64) (**r [rd = zero_ext(r1,s) << a] *)
+ | Oshllsext (s: Z) (a: amount64) (**r [rd = sign_ext(r1,s) << a] *)
+ | Ozextshrl (a: amount64) (s: Z) (**r [rd = zero_ext(r1 >> a, s)] *)
+ | Osextshrl (a: amount64) (s: Z) (**r [rd = sign_ext(r1 >> a, s)] *)
+(** 64-bit floating-point arithmetic *)
+ | Onegf (**r [rd = - r1] *)
+ | Oabsf (**r [rd = abs(r1)] *)
+ | Oaddf (**r [rd = r1 + r2] *)
+ | Osubf (**r [rd = r1 - r2] *)
+ | Omulf (**r [rd = r1 * r2] *)
+ | Odivf (**r [rd = r1 / r2] *)
+(** 32-bit floating-point arithmetic *)
+ | Onegfs (**r [rd = - r1] *)
+ | Oabsfs (**r [rd = abs(r1)] *)
+ | Oaddfs (**r [rd = r1 + r2] *)
+ | Osubfs (**r [rd = r1 - r2] *)
+ | Omulfs (**r [rd = r1 * r2] *)
+ | Odivfs (**r [rd = r1 / r2] *)
+ | Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *)
+ | Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *)
+(** Conversions between int and float *)
+ | Ointoffloat (**r [rd = signed_int_of_float64(r1)] *)
+ | Ointuoffloat (**r [rd = unsigned_int_of_float64(r1)] *)
+ | Ofloatofint (**r [rd = float64_of_signed_int(r1)] *)
+ | Ofloatofintu (**r [rd = float64_of_unsigned_int(r1)] *)
+ | Ointofsingle (**r [rd = signed_int_of_float32(r1)] *)
+ | Ointuofsingle (**r [rd = unsigned_int_of_float32(r1)] *)
+ | Osingleofint (**r [rd = float32_of_signed_int(r1)] *)
+ | Osingleofintu (**r [rd = float32_of_unsigned_int(r1)] *)
+ | Olongoffloat (**r [rd = signed_long_of_float64(r1)] *)
+ | Olonguoffloat (**r [rd = unsigned_long_of_float64(r1)] *)
+ | Ofloatoflong (**r [rd = float64_of_signed_long(r1)] *)
+ | Ofloatoflongu (**r [rd = float64_of_unsigned_long(r1)] *)
+ | Olongofsingle (**r [rd = signed_long_of_float32(r1)] *)
+ | Olonguofsingle (**r [rd = unsigned_long_of_float32(r1)] *)
+ | Osingleoflong (**r [rd = float32_of_signed_long(r1)] *)
+ | Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *)
+(** Boolean tests *)
+ | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Osel (cond: condition) (ty: typ). (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *)
+
+(** Addressing modes. [r1], [r2], etc, are the arguments to the addressing. *)
+
+Inductive addressing: Type :=
+ | Aindexed (ofs: int64) (**r Address is [r1 + offset] *)
+ | Aindexed2 (**r Address is [r1 + r2] *)
+ | Aindexed2shift (a: amount64) (**r Address is [r1 + r2 << a] *)
+ | Aindexed2ext (x: extension) (a: amount64) (**r Address is [r1 + sign-or-zero-ext(r2) << a] *)
+ | Aglobal (id: ident) (ofs: ptrofs) (**r Address is [global + offset] *)
+ | Ainstack (ofs: ptrofs). (**r Address is [stack_pointer + offset] *)
+
+(** Comparison functions (used in modules [CSE] and [Allocation]). *)
+
+Definition eq_amount32 (x y: amount32): {x=y} + {x<>y}.
+Proof.
+ destruct x as [x Px], y as [y Py].
+ destruct (Int.eq_dec x y).
+- subst y. assert (Px = Py) by (apply proof_irr). subst Py. left; auto.
+- right; congruence.
+Defined.
+
+Definition eq_amount64 (x y: amount64): {x=y} + {x<>y}.
+Proof.
+ destruct x as [x Px], y as [y Py].
+ destruct (Int.eq_dec x y).
+- subst y. assert (Px = Py) by (apply proof_irr). subst Py. left; auto.
+- right; congruence.
+Defined.
+
+Definition eq_shift (x y: shift): {x=y} + {x<>y}.
+Proof.
+ decide equality.
+Defined.
+
+Definition eq_extension (x y: extension): {x=y} + {x<>y}.
+Proof.
+ decide equality.
+Defined.
+
+Definition eq_condition (x y: condition) : {x=y} + {x<>y}.
+Proof.
+ assert (forall (x y: comparison), {x=y}+{x<>y}) by decide equality.
+ generalize Int.eq_dec Int64.eq_dec eq_shift eq_amount32 eq_amount64; intro.
+ decide equality.
+Defined.
+
+Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}.
+Proof.
+ generalize ident_eq Int64.eq_dec Ptrofs.eq_dec eq_extension eq_amount64; intros.
+ decide equality.
+Defined.
+
+Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}.
+Proof.
+ intros.
+ generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec
+ zeq ident_eq eq_shift eq_extension eq_amount32 eq_amount64
+ typ_eq eq_condition;
+ decide equality.
+Defined.
+
+(** Alternative:
+
+Definition beq_operation: forall (x y: operation), bool.
+Proof.
+ generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec
+ zeq ident_eq eq_shift eq_extension eq_amount32 eq_amount64
+ eq_condition typ_eq; boolean_equality.
+Defined.
+
+Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}.
+Proof.
+ decidable_equality_from beq_operation.
+Defined.
+*)
+
+(** * Evaluation functions *)
+
+(** Evaluation of conditions, operators and addressing modes applied
+ to lists of values. Return [None] when the computation can trigger an
+ error, e.g. integer division by zero. [eval_condition] returns a boolean,
+ [eval_operation] and [eval_addressing] return a value. *)
+
+Definition eval_shift (s: shift) (v: val) (n: amount32) : val :=
+ match s with
+ | Slsl => Val.shl v (Vint n)
+ | Slsr => Val.shru v (Vint n)
+ | Sasr => Val.shr v (Vint n)
+ | Sror => Val.ror v (Vint n)
+ end.
+
+Definition eval_shiftl (s: shift) (v: val) (n: amount64) : val :=
+ match s with
+ | Slsl => Val.shll v (Vint n)
+ | Slsr => Val.shrlu v (Vint n)
+ | Sasr => Val.shrl v (Vint n)
+ | Sror => Val.rorl v (Vint n)
+ end.
+
+Definition eval_extend (x: extension) (v: val) (n: amount64) : val :=
+ Val.shll
+ (match x with
+ | Xsgn32 => Val.longofint v
+ | Xuns32 => Val.longofintu v
+ end)
+ (Vint n).
+
+Definition eval_condition (cond: condition) (vl: list val) (m: mem): option bool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2
+ | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n)
+ | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n)
+ | Ccompshift c s a, v1 :: v2 :: nil => Val.cmp_bool c v1 (eval_shift s v2 a)
+ | Ccompushift c s a, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (eval_shift s v2 a)
+ | Cmaskzero n, v1 :: nil => Val.cmp_bool Ceq (Val.and v1 (Vint n)) (Vint Int.zero)
+ | Cmasknotzero n, v1 :: nil => Val.cmp_bool Cne (Val.and v1 (Vint n)) (Vint Int.zero)
+
+ | Ccompl c, v1 :: v2 :: nil => Val.cmpl_bool c v1 v2
+ | Ccomplu c, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 v2
+ | Ccomplimm c n, v1 :: nil => Val.cmpl_bool c v1 (Vlong n)
+ | Ccompluimm c n, v1 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong n)
+ | Ccomplshift c s a, v1 :: v2 :: nil => Val.cmpl_bool c v1 (eval_shiftl s v2 a)
+ | Ccomplushift c s a, v1 :: v2 :: nil => Val.cmplu_bool (Mem.valid_pointer m) c v1 (eval_shiftl s v2 a)
+ | Cmasklzero n, v1 :: nil => Val.cmpl_bool Ceq (Val.andl v1 (Vlong n)) (Vlong Int64.zero)
+ | Cmasklnotzero n, v1 :: nil => Val.cmpl_bool Cne (Val.andl v1 (Vlong n)) (Vlong Int64.zero)
+
+ | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2)
+ | Ccompfzero c, v1 :: nil => Val.cmpf_bool c v1 (Vfloat Float.zero)
+ | Cnotcompfzero c, v1 :: nil => option_map negb (Val.cmpf_bool c v1 (Vfloat Float.zero))
+
+ | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2
+ | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2)
+ | Ccompfszero c, v1 :: nil => Val.cmpfs_bool c v1 (Vsingle Float32.zero)
+ | Cnotcompfszero c, v1 :: nil => option_map negb (Val.cmpfs_bool c v1 (Vsingle Float32.zero))
+
+ | _, _ => None
+ end.
+
+Definition eval_operation
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (op: operation) (vl: list val) (m: mem): option val :=
+ match op, vl with
+ | Omove, v1::nil => Some v1
+ | Ointconst n, nil => Some (Vint n)
+ | Olongconst n, nil => Some (Vlong n)
+ | Ofloatconst n, nil => Some (Vfloat n)
+ | Osingleconst n, nil => Some (Vsingle n)
+ | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs)
+ | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs)
+
+ | Oshift s a, v1 :: nil => Some (eval_shift s v1 a)
+ | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2)
+ | Oaddshift s a, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2 a))
+ | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n))
+ | Oneg, v1 :: nil => Some (Val.neg v1)
+ | Onegshift s a, v1 :: nil => Some (Val.neg (eval_shift s v1 a))
+ | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2)
+ | Osubshift s a, v1 :: v2 :: nil => Some (Val.sub v1 (eval_shift s v2 a))
+ | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2)
+ | Omuladd, v1 :: v2 :: v3 :: nil => Some (Val.add v1 (Val.mul v2 v3))
+ | Omulsub, v1 :: v2 :: v3 :: nil => Some (Val.sub v1 (Val.mul v2 v3))
+ | Odiv, v1 :: v2 :: nil => Val.divs v1 v2
+ | Odivu, v1 :: v2 :: nil => Val.divu v1 v2
+ | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2)
+ | Oandshift s a, v1 :: v2 :: nil => Some (Val.and v1 (eval_shift s v2 a))
+ | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n))
+ | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2)
+ | Oorshift s a, v1 :: v2 :: nil => Some (Val.or v1 (eval_shift s v2 a))
+ | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n))
+ | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2)
+ | Oxorshift s a, v1 :: v2 :: nil => Some (Val.xor v1 (eval_shift s v2 a))
+ | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n))
+ | Onot, v1 :: nil => Some (Val.notint v1)
+ | Onotshift s a, v1 :: nil => Some (Val.notint (eval_shift s v1 a))
+ | Obic, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint v2))
+ | Obicshift s a, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint (eval_shift s v2 a)))
+ | Oorn, v1 :: v2 :: nil => Some (Val.or v1 (Val.notint v2))
+ | Oornshift s a, v1 :: v2 :: nil => Some (Val.or v1 (Val.notint (eval_shift s v2 a)))
+ | Oeqv, v1 :: v2 :: nil => Some (Val.xor v1 (Val.notint v2))
+ | Oeqvshift s a, v1 :: v2 :: nil => Some (Val.xor v1 (Val.notint (eval_shift s v2 a)))
+ | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2)
+ | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2)
+ | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2)
+ | Oshrximm n, v1::nil => Val.shrx v1 (Vint n)
+ | Ozext s, v1 :: nil => Some (Val.zero_ext s v1)
+ | Osext s, v1 :: nil => Some (Val.sign_ext s v1)
+ | Oshlzext s a, v1 :: nil => Some (Val.shl (Val.zero_ext s v1) (Vint a))
+ | Oshlsext s a, v1 :: nil => Some (Val.shl (Val.sign_ext s v1) (Vint a))
+ | Ozextshr a s, v1 :: nil => Some (Val.zero_ext s (Val.shru v1 (Vint a)))
+ | Osextshr a s, v1 :: nil => Some (Val.sign_ext s (Val.shr v1 (Vint a)))
+
+ | Oshiftl s a, v1 :: nil => Some (eval_shiftl s v1 a)
+ | Oextend x a, v1 :: nil => Some (eval_extend x v1 a)
+ | Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2)
+ | Olowlong, v1::nil => Some (Val.loword v1)
+ | Ohighlong, v1::nil => Some (Val.hiword v1)
+ | Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2)
+ | Oaddlshift s a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_shiftl s v2 a))
+ | Oaddlext x a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_extend x v2 a))
+ | Oaddlimm n, v1 :: nil => Some (Val.addl v1 (Vlong n))
+ | Onegl, v1 :: nil => Some (Val.negl v1)
+ | Oneglshift s a, v1 :: nil => Some (Val.negl (eval_shiftl s v1 a))
+ | Osubl, v1 :: v2 :: nil => Some (Val.subl v1 v2)
+ | Osublshift s a, v1 :: v2 :: nil => Some (Val.subl v1 (eval_shiftl s v2 a))
+ | Osublext x a, v1 :: v2 :: nil => Some (Val.subl v1 (eval_extend x v2 a))
+ | Omull, v1 :: v2 :: nil => Some (Val.mull v1 v2)
+ | Omulladd, v1 :: v2 :: v3 :: nil => Some (Val.addl v1 (Val.mull v2 v3))
+ | Omullsub, v1 :: v2 :: v3 :: nil => Some (Val.subl v1 (Val.mull v2 v3))
+ | Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2)
+ | Omullhu, v1::v2::nil => Some (Val.mullhu v1 v2)
+ | Odivl, v1 :: v2 :: nil => Val.divls v1 v2
+ | Odivlu, v1 :: v2 :: nil => Val.divlu v1 v2
+ | Oandl, v1 :: v2 :: nil => Some (Val.andl v1 v2)
+ | Oandlshift s a, v1 :: v2 :: nil => Some (Val.andl v1 (eval_shiftl s v2 a))
+ | Oandlimm n, v1 :: nil => Some (Val.andl v1 (Vlong n))
+ | Oorl, v1 :: v2 :: nil => Some (Val.orl v1 v2)
+ | Oorlshift s a, v1 :: v2 :: nil => Some (Val.orl v1 (eval_shiftl s v2 a))
+ | Oorlimm n, v1 :: nil => Some (Val.orl v1 (Vlong n))
+ | Oxorl, v1 :: v2 :: nil => Some (Val.xorl v1 v2)
+ | Oxorlshift s a, v1 :: v2 :: nil => Some (Val.xorl v1 (eval_shiftl s v2 a))
+ | Oxorlimm n, v1 :: nil => Some (Val.xorl v1 (Vlong n))
+ | Onotl, v1 :: nil => Some (Val.notl v1)
+ | Onotlshift s a, v1 :: nil => Some (Val.notl (eval_shiftl s v1 a))
+ | Obicl, v1 :: v2 :: nil => Some (Val.andl v1 (Val.notl v2))
+ | Obiclshift s a, v1 :: v2 :: nil => Some (Val.andl v1 (Val.notl (eval_shiftl s v2 a)))
+ | Oornl, v1 :: v2 :: nil => Some (Val.orl v1 (Val.notl v2))
+ | Oornlshift s a, v1 :: v2 :: nil => Some (Val.orl v1 (Val.notl (eval_shiftl s v2 a)))
+ | Oeqvl, v1 :: v2 :: nil => Some (Val.xorl v1 (Val.notl v2))
+ | Oeqvlshift s a, v1 :: v2 :: nil => Some (Val.xorl v1 (Val.notl (eval_shiftl s v2 a)))
+ | Oshll, v1 :: v2 :: nil => Some (Val.shll v1 v2)
+ | Oshrl, v1 :: v2 :: nil => Some (Val.shrl v1 v2)
+ | Oshrlu, v1 :: v2 :: nil => Some (Val.shrlu v1 v2)
+ | Oshrlximm n, v1::nil => Val.shrxl v1 (Vint n)
+ | Ozextl s, v1 :: nil => Some (Val.zero_ext_l s v1)
+ | Osextl s, v1 :: nil => Some (Val.sign_ext_l s v1)
+ | Oshllzext s a, v1 :: nil => Some (Val.shll (Val.zero_ext_l s v1) (Vint a))
+ | Oshllsext s a, v1 :: nil => Some (Val.shll (Val.sign_ext_l s v1) (Vint a))
+ | Ozextshrl a s, v1 :: nil => Some (Val.zero_ext_l s (Val.shrlu v1 (Vint a)))
+ | Osextshrl a s, v1 :: nil => Some (Val.sign_ext_l s (Val.shrl v1 (Vint a)))
+
+ | Onegf, v1::nil => Some (Val.negf v1)
+ | Oabsf, v1::nil => Some (Val.absf v1)
+ | Oaddf, v1::v2::nil => Some (Val.addf v1 v2)
+ | Osubf, v1::v2::nil => Some (Val.subf v1 v2)
+ | Omulf, v1::v2::nil => Some (Val.mulf v1 v2)
+ | Odivf, v1::v2::nil => Some (Val.divf v1 v2)
+
+ | Onegfs, v1::nil => Some (Val.negfs v1)
+ | Oabsfs, v1::nil => Some (Val.absfs v1)
+ | Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2)
+ | Osubfs, v1::v2::nil => Some (Val.subfs v1 v2)
+ | Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2)
+ | Odivfs, v1::v2::nil => Some (Val.divfs v1 v2)
+
+ | Osingleoffloat, v1::nil => Some (Val.singleoffloat v1)
+ | Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1)
+ | Ointoffloat, v1::nil => Val.intoffloat v1
+ | Ointuoffloat, v1::nil => Val.intuoffloat v1
+ | Ofloatofint, v1::nil => Val.floatofint v1
+ | Ofloatofintu, v1::nil => Val.floatofintu v1
+ | Ointofsingle, v1::nil => Val.intofsingle v1
+ | Ointuofsingle, v1::nil => Val.intuofsingle v1
+ | Osingleofint, v1::nil => Val.singleofint v1
+ | Osingleofintu, v1::nil => Val.singleofintu v1
+ | Olongoffloat, v1::nil => Val.longoffloat v1
+ | Olonguoffloat, v1::nil => Val.longuoffloat v1
+ | Ofloatoflong, v1::nil => Val.floatoflong v1
+ | Ofloatoflongu, v1::nil => Val.floatoflongu v1
+ | Olongofsingle, v1::nil => Val.longofsingle v1
+ | Olonguofsingle, v1::nil => Val.longuofsingle v1
+ | Osingleoflong, v1::nil => Val.singleoflong v1
+ | Osingleoflongu, v1::nil => Val.singleoflongu v1
+
+ | Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m))
+ | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty)
+ | _, _ => None
+ end.
+
+Definition eval_addressing
+ (F V: Type) (genv: Genv.t F V) (sp: val)
+ (addr: addressing) (vl: list val) : option val :=
+ match addr, vl with
+ | Aindexed n, v1 :: nil => Some (Val.addl v1 (Vlong n))
+ | Aindexed2, v1 :: v2 :: nil => Some (Val.addl v1 v2)
+ | Aindexed2shift a, v1 :: v2 :: nil => Some (Val.addl v1 (Val.shll v2 (Vint a)))
+ | Aindexed2ext x a, v1 :: v2 :: nil => Some (Val.addl v1 (eval_extend x v2 a))
+ | Aglobal s ofs, nil => Some (Genv.symbol_address genv s ofs)
+ | Ainstack n, nil => Some (Val.offset_ptr sp n)
+ | _, _ => None
+ end.
+
+Remark eval_addressing_Ainstack:
+ forall (F V: Type) (genv: Genv.t F V) sp ofs,
+ eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs).
+Proof.
+ intros. reflexivity.
+Qed.
+
+Remark eval_addressing_Ainstack_inv:
+ forall (F V: Type) (genv: Genv.t F V) sp ofs vl v,
+ eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs.
+Proof.
+ unfold eval_addressing; intros; destruct vl; inv H; auto.
+Qed.
+
+Ltac FuncInv :=
+ match goal with
+ | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ =>
+ destruct x; simpl in H; FuncInv
+ | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ =>
+ destruct v; simpl in H; FuncInv
+ | H: (if Archi.ptr64 then _ else _) = Some _ |- _ =>
+ change Archi.ptr64 with true in H; simpl in H; FuncInv
+ | H: (Some _ = Some _) |- _ =>
+ injection H; intros; clear H; FuncInv
+ | H: (None = Some _) |- _ =>
+ discriminate H
+ | _ =>
+ idtac
+ end.
+
+(** * Static typing of conditions, operators and addressing modes. *)
+
+Definition type_of_condition (c: condition) : list typ :=
+ match c with
+ | Ccomp _ => Tint :: Tint :: nil
+ | Ccompu _ => Tint :: Tint :: nil
+ | Ccompimm _ _ => Tint :: nil
+ | Ccompuimm _ _ => Tint :: nil
+ | Ccompshift _ _ _ => Tint :: Tint :: nil
+ | Ccompushift _ _ _ => Tint :: Tint :: nil
+ | Cmaskzero _ => Tint :: nil
+ | Cmasknotzero _ => Tint :: nil
+ | Ccompl _ => Tlong :: Tlong :: nil
+ | Ccomplu _ => Tlong :: Tlong :: nil
+ | Ccomplimm _ _ => Tlong :: nil
+ | Ccompluimm _ _ => Tlong :: nil
+ | Ccomplshift _ _ _ => Tlong :: Tlong :: nil
+ | Ccomplushift _ _ _ => Tlong :: Tlong :: nil
+ | Cmasklzero _ => Tlong :: nil
+ | Cmasklnotzero _ => Tlong :: nil
+ | Ccompf _ => Tfloat :: Tfloat :: nil
+ | Cnotcompf _ => Tfloat :: Tfloat :: nil
+ | Ccompfzero _ => Tfloat :: nil
+ | Cnotcompfzero _ => Tfloat :: nil
+ | Ccompfs _ => Tsingle :: Tsingle :: nil
+ | Cnotcompfs _ => Tsingle :: Tsingle :: nil
+ | Ccompfszero _ => Tsingle :: nil
+ | Cnotcompfszero _ => Tsingle :: nil
+ end.
+
+Definition type_of_operation (op: operation) : list typ * typ :=
+ match op with
+ | Omove => (nil, Tint) (* treated specially *)
+ | Ointconst _ => (nil, Tint)
+ | Olongconst _ => (nil, Tlong)
+ | Ofloatconst f => (nil, Tfloat)
+ | Osingleconst f => (nil, Tsingle)
+ | Oaddrsymbol _ _ => (nil, Tptr)
+ | Oaddrstack _ => (nil, Tptr)
+
+ | Oshift _ _ => (Tint :: nil, Tint)
+ | Oadd => (Tint :: Tint :: nil, Tint)
+ | Oaddshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oaddimm _ => (Tint :: nil, Tint)
+ | Oneg => (Tint :: nil, Tint)
+ | Onegshift _ _ => (Tint :: nil, Tint)
+ | Osub => (Tint :: Tint :: nil, Tint)
+ | Osubshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Omul => (Tint :: Tint :: nil, Tint)
+ | Omuladd => (Tint :: Tint :: Tint :: nil, Tint)
+ | Omulsub => (Tint :: Tint :: Tint :: nil, Tint)
+ | Odiv => (Tint :: Tint :: nil, Tint)
+ | Odivu => (Tint :: Tint :: nil, Tint)
+ | Oand => (Tint :: Tint :: nil, Tint)
+ | Oandshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oandimm _ => (Tint :: nil, Tint)
+ | Oor => (Tint :: Tint :: nil, Tint)
+ | Oorshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oorimm _ => (Tint :: nil, Tint)
+ | Oxor => (Tint :: Tint :: nil, Tint)
+ | Oxorshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oxorimm _ => (Tint :: nil, Tint)
+ | Onot => (Tint :: nil, Tint)
+ | Onotshift _ _ => (Tint :: nil, Tint)
+ | Obic => (Tint :: Tint :: nil, Tint)
+ | Obicshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oorn => (Tint :: Tint :: nil, Tint)
+ | Oornshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oeqv => (Tint :: Tint :: nil, Tint)
+ | Oeqvshift _ _ => (Tint :: Tint :: nil, Tint)
+ | Oshl => (Tint :: Tint :: nil, Tint)
+ | Oshr => (Tint :: Tint :: nil, Tint)
+ | Oshru => (Tint :: Tint :: nil, Tint)
+ | Oshrximm _ => (Tint :: nil, Tint)
+ | Ozext _ => (Tint :: nil, Tint)
+ | Osext _ => (Tint :: nil, Tint)
+ | Oshlzext _ _ => (Tint :: nil, Tint)
+ | Oshlsext _ _ => (Tint :: nil, Tint)
+ | Ozextshr _ _ => (Tint :: nil, Tint)
+ | Osextshr _ _ => (Tint :: nil, Tint)
+
+ | Oshiftl _ _ => (Tlong :: nil, Tlong)
+ | Oextend _ _ => (Tint :: nil, Tlong)
+ | Omakelong => (Tint :: Tint :: nil, Tlong)
+ | Olowlong => (Tlong :: nil, Tint)
+ | Ohighlong => (Tlong :: nil, Tint)
+ | Oaddl => (Tlong :: Tlong :: nil, Tlong)
+ | Oaddlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oaddlext _ _ => (Tlong :: Tint :: nil, Tlong)
+ | Oaddlimm _ => (Tlong :: nil, Tlong)
+ | Onegl => (Tlong :: nil, Tlong)
+ | Oneglshift _ _ => (Tlong :: nil, Tlong)
+ | Osubl => (Tlong :: Tlong :: nil, Tlong)
+ | Osublshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Osublext _ _ => (Tlong :: Tint :: nil, Tlong)
+ | Omull => (Tlong :: Tlong :: nil, Tlong)
+ | Omulladd => (Tlong :: Tlong :: Tlong :: nil, Tlong)
+ | Omullsub => (Tlong :: Tlong :: Tlong :: nil, Tlong)
+ | Omullhs => (Tlong :: Tlong :: nil, Tlong)
+ | Omullhu => (Tlong :: Tlong :: nil, Tlong)
+ | Odivl => (Tlong :: Tlong :: nil, Tlong)
+ | Odivlu => (Tlong :: Tlong :: nil, Tlong)
+ | Oandl => (Tlong :: Tlong :: nil, Tlong)
+ | Oandlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oandlimm _ => (Tlong :: nil, Tlong)
+ | Oorl => (Tlong :: Tlong :: nil, Tlong)
+ | Oorlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oorlimm _ => (Tlong :: nil, Tlong)
+ | Oxorl => (Tlong :: Tlong :: nil, Tlong)
+ | Oxorlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oxorlimm _ => (Tlong :: nil, Tlong)
+ | Onotl => (Tlong :: nil, Tlong)
+ | Onotlshift _ _ => (Tlong :: nil, Tlong)
+ | Obicl => (Tlong :: Tlong :: nil, Tlong)
+ | Obiclshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oornl => (Tlong :: Tlong :: nil, Tlong)
+ | Oornlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oeqvl => (Tlong :: Tlong :: nil, Tlong)
+ | Oeqvlshift _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oshll => (Tlong :: Tint :: nil, Tlong)
+ | Oshrl => (Tlong :: Tint :: nil, Tlong)
+ | Oshrlu => (Tlong :: Tint :: nil, Tlong)
+ | Oshrlximm _ => (Tlong :: nil, Tlong)
+ | Ozextl _ => (Tlong :: nil, Tlong)
+ | Osextl _ => (Tlong :: nil, Tlong)
+ | Oshllzext _ _ => (Tlong :: nil, Tlong)
+ | Oshllsext _ _ => (Tlong :: nil, Tlong)
+ | Ozextshrl _ _ => (Tlong :: nil, Tlong)
+ | Osextshrl _ _ => (Tlong :: nil, Tlong)
+
+ | Onegf => (Tfloat :: nil, Tfloat)
+ | Oabsf => (Tfloat :: nil, Tfloat)
+ | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Osubf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Omulf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
+
+ | Onegfs => (Tsingle :: nil, Tsingle)
+ | Oabsfs => (Tsingle :: nil, Tsingle)
+ | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Osingleoffloat => (Tfloat :: nil, Tsingle)
+ | Ofloatofsingle => (Tsingle :: nil, Tfloat)
+
+ | Ointoffloat => (Tfloat :: nil, Tint)
+ | Ointuoffloat => (Tfloat :: nil, Tint)
+ | Ofloatofint => (Tint :: nil, Tfloat)
+ | Ofloatofintu => (Tint :: nil, Tfloat)
+ | Ointofsingle => (Tsingle :: nil, Tint)
+ | Ointuofsingle => (Tsingle :: nil, Tint)
+ | Osingleofint => (Tint :: nil, Tsingle)
+ | Osingleofintu => (Tint :: nil, Tsingle)
+ | Olongoffloat => (Tfloat :: nil, Tlong)
+ | Olonguoffloat => (Tfloat :: nil, Tlong)
+ | Ofloatoflong => (Tlong :: nil, Tfloat)
+ | Ofloatoflongu => (Tlong :: nil, Tfloat)
+ | Olongofsingle => (Tsingle :: nil, Tlong)
+ | Olonguofsingle => (Tsingle :: nil, Tlong)
+ | Osingleoflong => (Tlong :: nil, Tsingle)
+ | Osingleoflongu => (Tlong :: nil, Tsingle)
+
+ | Ocmp c => (type_of_condition c, Tint)
+ | Osel c ty => (ty :: ty :: type_of_condition c, ty)
+ end.
+
+Definition type_of_addressing (addr: addressing) : list typ :=
+ match addr with
+ | Aindexed _ => Tptr :: nil
+ | Aindexed2 => Tptr :: Tlong :: nil
+ | Aindexed2shift _ => Tptr :: Tlong :: nil
+ | Aindexed2ext _ _ => Tptr :: Tint :: nil
+ | Aglobal _ _ => nil
+ | Ainstack _ => nil
+ end.
+
+(** Weak type soundness results for [eval_operation]:
+ the result values, when defined, are always of the type predicted
+ by [type_of_operation]. *)
+
+Section SOUNDNESS.
+
+Variable A V: Type.
+Variable genv: Genv.t A V.
+
+Remark type_add:
+ forall v1 v2, Val.has_type (Val.add v1 v2) Tint.
+Proof.
+ intros. unfold Val.has_type, Val.add. destruct v1, v2; simpl; auto.
+Qed.
+
+Remark type_sub:
+ forall v1 v2, Val.has_type (Val.sub v1 v2) Tint.
+Proof.
+ intros. unfold Val.has_type, Val.add. destruct v1, v2; simpl; auto.
+Qed.
+
+Remark type_addl:
+ forall v1 v2, Val.has_type (Val.addl v1 v2) Tlong.
+Proof.
+ intros. unfold Val.has_type, Val.addl. destruct v1, v2; simpl; auto.
+Qed.
+
+Remark type_subl:
+ forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong.
+Proof.
+ intros. unfold Val.has_type, Val.addl. destruct v1, v2; simpl; auto.
+ destruct (eq_block b b0); auto.
+Qed.
+
+Lemma type_of_operation_sound:
+ forall op vl sp v m,
+ op <> Omove ->
+ eval_operation genv sp op vl m = Some v ->
+ Val.has_type v (snd (type_of_operation op)).
+Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
+ intros.
+ destruct op; simpl; simpl in H0; FuncInv; subst; simpl.
+ (* move *)
+ - congruence.
+ (* intconst, longconst, floatconst, singleconst *)
+ - exact I.
+ - exact I.
+ - exact I.
+ - exact I.
+ (* addrsymbol *)
+ - unfold Genv.symbol_address. destruct (Genv.find_symbol genv id)...
+ (* addrstack *)
+ - destruct sp...
+ (* 32-bit integer operations *)
+ - destruct s, v0; try exact I; simpl; rewrite a32_range...
+ - apply type_add.
+ - apply type_add.
+ - apply type_add.
+ - destruct v0...
+ - destruct (eval_shift s v0 a)...
+ - apply type_sub.
+ - apply type_sub.
+ - destruct v0... destruct v1...
+ - apply type_add.
+ - apply type_sub.
+ - destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2...
+ - destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int.eq i0 Int.zero); inv H2...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0...
+ - destruct v0...
+ - destruct (eval_shift s v0 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shift s v1 a)...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int.iwordsize)...
+ - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 31)); inv H0...
+ - destruct v0...
+ - destruct v0...
+ - destruct (Val.zero_ext s v0)... simpl; rewrite a32_range...
+ - destruct (Val.sign_ext s v0)... simpl; rewrite a32_range...
+ - destruct (Val.shru v0 (Vint a))...
+ - destruct (Val.shr v0 (Vint a))...
+ (* 64-bit integer operations *)
+ - destruct s, v0; try exact I; simpl; rewrite a64_range...
+ - unfold eval_extend. destruct (match x with
+ | Xsgn32 => Val.longofint v0
+ | Xuns32 => Val.longofintu v0
+ end)...
+ simpl; rewrite a64_range...
+ - destruct v0... destruct v1...
+ - destruct v0...
+ - destruct v0...
+ - apply type_addl.
+ - apply type_addl.
+ - apply type_addl.
+ - apply type_addl.
+ - destruct v0...
+ - destruct (eval_shiftl s v0 a)...
+ - apply type_subl.
+ - apply type_subl.
+ - apply type_subl.
+ - destruct v0... destruct v1...
+ - apply type_addl.
+ - apply type_subl.
+ - destruct v0... destruct v1...
+ - destruct v0... destruct v1...
+ - destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int64.eq i0 Int64.zero || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2...
+ - destruct v0; destruct v1; simpl in *; inv H0.
+ destruct (Int64.eq i0 Int64.zero); inv H2...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0...
+ - destruct v0...
+ - destruct (eval_shiftl s v0 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0... destruct v1...
+ - destruct v0... destruct (eval_shiftl s v1 a)...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ - destruct v0; destruct v1; simpl... destruct (Int.ltu i0 Int64.iwordsize')...
+ - destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0...
+ - destruct v0...
+ - destruct v0...
+ - destruct (Val.zero_ext_l s v0)... simpl; rewrite a64_range...
+ - destruct (Val.sign_ext_l s v0)... simpl; rewrite a64_range...
+ - destruct (Val.shrlu v0 (Vint a))...
+ - destruct (Val.shrl v0 (Vint a))...
+
+ (* 64-bit FP *)
+ - destruct v0...
+ - destruct v0...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ (* 32-bit FP *)
+ - destruct v0...
+ - destruct v0...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ (* singleoffloat, floatofsingle *)
+ - destruct v0...
+ - destruct v0...
+ (* intoffloat, intuoffloat *)
+ - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); inv H2...
+ - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); inv H2...
+ (* floatofint, floatofintu *)
+ - destruct v0; simpl in H0; inv H0...
+ - destruct v0; simpl in H0; inv H0...
+ (* intofsingle, intuofsingle *)
+ - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); inv H2...
+ - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); inv H2...
+ (* singleofint, singleofintu *)
+ - destruct v0; simpl in H0; inv H0...
+ - destruct v0; simpl in H0; inv H0...
+ (* longoffloat, longuoffloat *)
+ - destruct v0; simpl in H0; inv H0. destruct (Float.to_long f); inv H2...
+ - destruct v0; simpl in H0; inv H0. destruct (Float.to_longu f); inv H2...
+ (* floatoflong, floatoflongu *)
+ - destruct v0; simpl in H0; inv H0...
+ - destruct v0; simpl in H0; inv H0...
+ (* longofsingle, longuofsingle *)
+ - destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2...
+ - destruct v0; simpl in H0; inv H0. destruct (Float32.to_longu f); inv H2...
+ (* singleoflong, singleoflongu *)
+ - destruct v0; simpl in H0; inv H0...
+ - destruct v0; simpl in H0; inv H0...
+ (* cmp *)
+ - destruct (eval_condition cond vl m) as [[]|]...
+ - unfold Val.select. destruct (eval_condition cond vl m). apply Val.normalize_type. exact I.
+Qed.
+
+
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivu | Odivl | Odivlu
+ | Oshrximm _ | Oshrlximm _
+ | Ointoffloat | Ointuoffloat
+ | Ointofsingle | Ointuofsingle
+ | Ofloatofint | Ofloatofintu
+ | Osingleofint | Osingleofintu
+ | Olongoffloat | Olonguoffloat
+ | Olongofsingle | Olonguofsingle
+ | Ofloatoflong | Ofloatoflongu
+ | Osingleoflong | Osingleoflongu => true
+ | _ => false
+ end.
+
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
+End SOUNDNESS.
+
+(** * Manipulating and transforming operations *)
+
+(** Constructing shift amounts *)
+
+Section SHIFT_AMOUNT.
+
+Variable l: Z.
+Hypothesis l_range: 0 <= l < 32.
+Variable N: int.
+Hypothesis N_eq: Int.unsigned N = two_p l.
+
+Remark mk_amount_range:
+ forall n, Int.ltu (Int.zero_ext l n) N = true.
+Proof.
+ intros; unfold Int.ltu. apply zlt_true. rewrite N_eq. apply (Int.zero_ext_range l n). assumption.
+Qed.
+
+Remark mk_amount_eq:
+ forall n, Int.ltu n N = true -> Int.zero_ext l n = n.
+Proof.
+ intros.
+ transitivity (Int.repr (Int.unsigned (Int.zero_ext l n))).
+ symmetry; apply Int.repr_unsigned.
+ transitivity (Int.repr (Int.unsigned n)).
+ f_equal. rewrite Int.zero_ext_mod. apply Int.ltu_inv in H. rewrite N_eq in H.
+ apply Z.mod_small. assumption. assumption.
+ apply Int.repr_unsigned.
+Qed.
+
+End SHIFT_AMOUNT.
+
+Program Definition mk_amount32 (n: int): amount32 :=
+ {| a32_amount := Int.zero_ext 5 n |}.
+Next Obligation.
+ apply mk_amount_range. omega. reflexivity.
+Qed.
+
+Lemma mk_amount32_eq: forall n,
+ Int.ltu n Int.iwordsize = true -> a32_amount (mk_amount32 n) = n.
+Proof.
+ intros. eapply mk_amount_eq; eauto. omega. reflexivity.
+Qed.
+
+Program Definition mk_amount64 (n: int): amount64 :=
+ {| a64_amount := Int.zero_ext 6 n |}.
+Next Obligation.
+ apply mk_amount_range. omega. reflexivity.
+Qed.
+
+Lemma mk_amount64_eq: forall n,
+ Int.ltu n Int64.iwordsize' = true -> a64_amount (mk_amount64 n) = n.
+Proof.
+ intros. eapply mk_amount_eq; eauto. omega. reflexivity.
+Qed.
+
+(** Recognition of move operations. *)
+
+Definition is_move_operation
+ (A: Type) (op: operation) (args: list A) : option A :=
+ match op, args with
+ | Omove, arg :: nil => Some arg
+ | _, _ => None
+ end.
+
+Lemma is_move_operation_correct:
+ forall (A: Type) (op: operation) (args: list A) (a: A),
+ is_move_operation op args = Some a ->
+ op = Omove /\ args = a :: nil.
+Proof.
+ intros until a. unfold is_move_operation; destruct op;
+ try (intros; discriminate).
+ destruct args. intros; discriminate.
+ destruct args. intros. intuition congruence.
+ intros; discriminate.
+Qed.
+
+(** [negate_condition cond] returns a condition that is logically
+ equivalent to the negation of [cond]. *)
+
+Definition negate_condition (cond: condition): condition :=
+ match cond with
+ | Ccomp c => Ccomp (negate_comparison c)
+ | Ccompu c => Ccompu (negate_comparison c)
+ | Ccompimm c n => Ccompimm (negate_comparison c) n
+ | Ccompuimm c n => Ccompuimm (negate_comparison c) n
+ | Ccompshift c s a => Ccompshift (negate_comparison c) s a
+ | Ccompushift c s a => Ccompushift (negate_comparison c) s a
+ | Cmaskzero n => Cmasknotzero n
+ | Cmasknotzero n => Cmaskzero n
+ | Ccompl c => Ccompl (negate_comparison c)
+ | Ccomplu c => Ccomplu (negate_comparison c)
+ | Ccomplimm c n => Ccomplimm (negate_comparison c) n
+ | Ccompluimm c n => Ccompluimm (negate_comparison c) n
+ | Ccomplshift c s a => Ccomplshift (negate_comparison c) s a
+ | Ccomplushift c s a => Ccomplushift (negate_comparison c) s a
+ | Cmasklzero n => Cmasklnotzero n
+ | Cmasklnotzero n => Cmasklzero n
+ | Ccompf c => Cnotcompf c
+ | Cnotcompf c => Ccompf c
+ | Ccompfzero c => Cnotcompfzero c
+ | Cnotcompfzero c => Ccompfzero c
+ | Ccompfs c => Cnotcompfs c
+ | Cnotcompfs c => Ccompfs c
+ | Ccompfszero c => Cnotcompfszero c
+ | Cnotcompfszero c => Ccompfszero c
+ end.
+
+Lemma eval_negate_condition:
+ forall cond vl m,
+ eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m).
+Proof.
+ intros. destruct cond; simpl.
+ repeat (destruct vl; auto). apply Val.negate_cmp_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmp_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmp_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
+ repeat (destruct vl; auto). apply (Val.negate_cmp_bool Ceq).
+ repeat (destruct vl; auto). apply (Val.negate_cmp_bool Cne).
+ repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
+ repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
+ repeat (destruct vl; auto). apply (Val.negate_cmpl_bool Ceq).
+ repeat (destruct vl; auto). apply (Val.negate_cmpl_bool Cne).
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0) as [[]|]; auto.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpf_bool c v (Vfloat Float.zero)) as [[]|]; auto.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0) as [[]|]; auto.
+ repeat (destruct vl; auto).
+ repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v (Vsingle Float32.zero)) as [[]|]; auto.
+Qed.
+
+(** Shifting stack-relative references. This is used in [Stacking]. *)
+
+Definition shift_stack_addressing (delta: Z) (addr: addressing) :=
+ match addr with
+ | Ainstack ofs => Ainstack (Ptrofs.add ofs (Ptrofs.repr delta))
+ | _ => addr
+ end.
+
+Definition shift_stack_operation (delta: Z) (op: operation) :=
+ match op with
+ | Oaddrstack ofs => Oaddrstack (Ptrofs.add ofs (Ptrofs.repr delta))
+ | _ => op
+ end.
+
+Lemma type_shift_stack_addressing:
+ forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
+Proof.
+ intros. destruct addr; auto.
+Qed.
+
+Lemma type_shift_stack_operation:
+ forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
+Proof.
+ intros. destruct op; auto.
+Qed.
+
+Lemma eval_shift_stack_addressing:
+ forall F V (ge: Genv.t F V) sp addr vl delta,
+ eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl =
+ eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl.
+Proof.
+ intros. destruct addr; simpl; auto. destruct vl; auto.
+ rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto.
+Qed.
+
+Lemma eval_shift_stack_operation:
+ forall F V (ge: Genv.t F V) sp op vl m delta,
+ eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m =
+ eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m.
+Proof.
+ intros. destruct op; simpl; auto. destruct vl; auto.
+ rewrite Ptrofs.add_zero_l, Ptrofs.add_commut; auto.
+Qed.
+
+(** Offset an addressing mode [addr] by a quantity [delta], so that
+ it designates the pointer [delta] bytes past the pointer designated
+ by [addr]. May be undefined, in which case [None] is returned. *)
+
+Definition offset_addressing (addr: addressing) (delta: Z) : option addressing :=
+ match addr with
+ | Aindexed n => Some(Aindexed (Int64.add n (Int64.repr delta)))
+ | Aindexed2 => None
+ | Aindexed2shift _ => None
+ | Aindexed2ext _ _ => None
+ | Aglobal id n => Some(Aglobal id (Ptrofs.add n (Ptrofs.repr delta)))
+ | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta)))
+ end.
+
+Lemma eval_offset_addressing:
+ forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v,
+ offset_addressing addr delta = Some addr' ->
+ eval_addressing ge sp addr args = Some v ->
+ Archi.ptr64 = false ->
+ eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))).
+Proof.
+ intros. discriminate.
+Qed.
+
+(** Operations that are so cheap to recompute that CSE should not factor them out. *)
+
+Definition is_trivial_op (op: operation) : bool :=
+ match op with
+ | Omove => true
+ | Ointconst n => Int.eq (Int.sign_ext 16 n) n
+ | Olongconst n => Int64.eq (Int64.sign_ext 16 n) n
+ | Oaddrstack _ => true
+ | _ => false
+ end.
+
+(** Operations that depend on the memory state. *)
+
+Definition cond_depends_on_memory (c: condition) : bool :=
+ match c with
+ | Ccomplu _ | Ccompluimm _ _ | Ccomplushift _ _ _ => true
+ | _ => false
+ end.
+
+Lemma cond_depends_on_memory_correct:
+ forall c args m1 m2,
+ cond_depends_on_memory c = false ->
+ eval_condition c args m1 = eval_condition c args m2.
+Proof.
+ intros; destruct c; simpl; discriminate || reflexivity.
+Qed.
+
+Definition op_depends_on_memory (op: operation) : bool :=
+ match op with
+ | Ocmp c => cond_depends_on_memory c
+ | Osel c yu => cond_depends_on_memory c
+ | _ => false
+ end.
+
+Lemma op_depends_on_memory_correct:
+ forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
+ op_depends_on_memory op = false ->
+ eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
+Proof.
+ intros. destruct op; auto.
+ simpl. rewrite (cond_depends_on_memory_correct cond args m1 m2 H). auto.
+ simpl. destruct args; auto. destruct args; auto.
+ rewrite (cond_depends_on_memory_correct cond args m1 m2 H). auto.
+Qed.
+
+(** Global variables mentioned in an operation or addressing mode *)
+
+Definition globals_addressing (addr: addressing) : list ident :=
+ match addr with
+ | Aglobal s ofs => s :: nil
+ | _ => nil
+ end.
+
+Definition globals_operation (op: operation) : list ident :=
+ match op with
+ | Oaddrsymbol s ofs => s :: nil
+ | _ => nil
+ end.
+
+(** * Invariance and compatibility properties. *)
+
+(** [eval_operation] and [eval_addressing] depend on a global environment
+ for resolving references to global symbols. We show that they give
+ the same results if a global environment is replaced by another that
+ assigns the same addresses to the same symbols. *)
+
+Section GENV_TRANSF.
+
+Variable F1 F2 V1 V2: Type.
+Variable ge1: Genv.t F1 V1.
+Variable ge2: Genv.t F2 V2.
+Hypothesis agree_on_symbols:
+ forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s.
+
+Lemma eval_addressing_preserved:
+ forall sp addr vl,
+ eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl.
+Proof.
+ intros.
+ unfold eval_addressing; destruct addr; auto. destruct vl; auto.
+ unfold Genv.symbol_address. rewrite agree_on_symbols; auto.
+Qed.
+
+Lemma eval_operation_preserved:
+ forall sp op vl m,
+ eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m.
+Proof.
+ intros.
+ unfold eval_operation; destruct op; auto. destruct vl; auto.
+ unfold Genv.symbol_address. rewrite agree_on_symbols; auto.
+Qed.
+
+End GENV_TRANSF.
+
+(** Compatibility of the evaluation functions with value injections. *)
+
+Section EVAL_COMPAT.
+
+Variable F1 F2 V1 V2: Type.
+Variable ge1: Genv.t F1 V1.
+Variable ge2: Genv.t F2 V2.
+Variable f: meminj.
+
+Variable m1: mem.
+Variable m2: mem.
+
+Hypothesis valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+
+Hypothesis weak_valid_pointer_inj:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+
+Hypothesis weak_valid_pointer_no_overflow:
+ forall b1 ofs b2 delta,
+ f b1 = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
+
+Hypothesis valid_different_pointers_inj:
+ forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ b1 <> b2 ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
+ Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
+ f b1 = Some (b1', delta1) ->
+ f b2 = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).
+
+Ltac InvInject :=
+ match goal with
+ | [ H: Val.inject _ (Vint _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject _ (Vfloat _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject _ (Vptr _ _) _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject_list _ nil _ |- _ ] =>
+ inv H; InvInject
+ | [ H: Val.inject_list _ (_ :: _) _ |- _ ] =>
+ inv H; InvInject
+ | _ => idtac
+ end.
+
+Lemma eval_shift_inject:
+ forall v1 v2 s a,
+ Val.inject f v1 v2 -> Val.inject f (eval_shift s v1 a) (eval_shift s v2 a).
+Proof.
+ intros; inv H; destruct s; simpl; auto; rewrite a32_range; auto.
+Qed.
+
+Lemma eval_shiftl_inject:
+ forall v1 v2 s a,
+ Val.inject f v1 v2 -> Val.inject f (eval_shiftl s v1 a) (eval_shiftl s v2 a).
+Proof.
+ intros; inv H; destruct s; simpl; auto; rewrite a64_range; auto.
+Qed.
+
+Lemma eval_extend_inject:
+ forall v1 v2 x a,
+ Val.inject f v1 v2 -> Val.inject f (eval_extend x v1 a) (eval_extend x v2 a).
+Proof.
+ unfold eval_extend; intros; inv H; destruct x; simpl; auto; rewrite a64_range; auto.
+Qed.
+
+Lemma eval_condition_inj:
+ forall cond vl1 vl2 b,
+ Val.inject_list f vl1 vl2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl; auto.
+(* 32-bit integers *)
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
+- revert H0. generalize (eval_shift_inject s a H2); intros J; inv H3; inv J; simpl; congruence.
+- eauto 3 using Val.cmpu_bool_inject, Mem.valid_pointer_implies, eval_shift_inject.
+- inv H3; inv H0; auto.
+- inv H3; inv H0; auto.
+(* 64-bit integers *)
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies.
+- inv H3; simpl in H0; inv H0; auto.
+- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies.
+- revert H0. generalize (eval_shiftl_inject s a H2); intros J; inv H3; inv J; simpl; congruence.
+- eauto 3 using Val.cmplu_bool_inject, Mem.valid_pointer_implies, eval_shiftl_inject.
+- inv H3; inv H0; auto.
+- inv H3; inv H0; auto.
+(* 64-bit floats *)
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; simpl in H0; inv H0; auto.
+- inv H3; simpl in H0; inv H0; auto.
+(* 32-bit floats *)
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; inv H2; simpl in H0; inv H0; auto.
+- inv H3; simpl in H0; inv H0; auto.
+- inv H3; simpl in H0; inv H0; auto.
+Qed.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] =>
+ exists v1; split; auto
+ | _ => idtac
+ end.
+
+Lemma eval_operation_inj:
+ forall op sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_operation op) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_operation ge1 sp1 op vl1 m1 = Some v1 ->
+ exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists.
+ (* addrsymbol *)
+ - apply GL; simpl; auto.
+ (* addrstack *)
+ - apply Val.offset_ptr_inject; auto.
+ (* shift *)
+ - apply eval_shift_inject; auto.
+ (* add *)
+ - apply Val.add_inject; auto.
+ - apply Val.add_inject; auto using eval_shift_inject.
+ - apply Val.add_inject; auto.
+ (* neg, sub *)
+ - inv H4; simpl; auto.
+ - generalize (eval_shift_inject s a H4); intros J; inv J; simpl; auto.
+ - apply Val.sub_inject; auto.
+ - apply Val.sub_inject; auto using eval_shift_inject.
+ (* mul, muladd, mulsub *)
+ - inv H4; inv H2; simpl; auto.
+ - apply Val.add_inject; auto. inv H2; inv H3; simpl; auto.
+ - apply Val.sub_inject; auto. inv H2; inv H3; simpl; auto.
+ (* div, divu *)
+ - inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero
+ || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2.
+ TrivialExists.
+ - inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int.eq i0 Int.zero); inv H2. TrivialExists.
+ (* and*)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* or *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* xor *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* not *)
+ - inv H4; simpl; auto.
+ - generalize (eval_shift_inject s a H4); intros J; inv J; simpl; auto.
+ (* bic *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* nor *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* eqv *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shift_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* shl *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ (* shr *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ (* shru *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
+ (* shrx *)
+ - inv H4; simpl in H1; try discriminate. simpl.
+ destruct (Int.ltu n (Int.repr 31)); inv H1. TrivialExists.
+ (* shift-ext *)
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto; rewrite a32_range; auto.
+ - inv H4; simpl; auto; rewrite a32_range; auto.
+ - inv H4; simpl; auto; rewrite a32_range; simpl; auto.
+ - inv H4; simpl; auto; rewrite a32_range; simpl; auto.
+
+ (* shiftl *)
+ - apply eval_shiftl_inject; auto.
+ (* extend *)
+ - apply eval_extend_inject; auto.
+ (* makelong, low, high *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ (* addl *)
+ - apply Val.addl_inject; auto.
+ - apply Val.addl_inject; auto using eval_shiftl_inject.
+ - apply Val.addl_inject; auto using eval_extend_inject.
+ - apply Val.addl_inject; auto.
+ (* negl, subl *)
+ - inv H4; simpl; auto.
+ - generalize (eval_shiftl_inject s a H4); intros J; inv J; simpl; auto.
+ - apply Val.subl_inject; auto.
+ - apply Val.subl_inject; auto using eval_shiftl_inject.
+ - apply Val.subl_inject; auto using eval_extend_inject.
+ (* mull, mulladd, mullsub, mullhs, mullhu *)
+ - inv H4; inv H2; simpl; auto.
+ - apply Val.addl_inject; auto. inv H2; inv H3; simpl; auto.
+ - apply Val.subl_inject; auto. inv H2; inv H3; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* divl, divlu *)
+ - inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero
+ || Int64.eq i (Int64.repr Int64.min_signed) && Int64.eq i0 Int64.mone); inv H2.
+ TrivialExists.
+ - inv H4; inv H3; simpl in H1; inv H1. simpl.
+ destruct (Int64.eq i0 Int64.zero); inv H2. TrivialExists.
+ (* andl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* orl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* xorl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ - inv H4; simpl; auto.
+ (* notl *)
+ - inv H4; simpl; auto.
+ - generalize (eval_shiftl_inject s a H4); intros J; inv J; simpl; auto.
+ (* bicl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* norl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* eqvl *)
+ - inv H4; inv H2; simpl; auto.
+ - generalize (eval_shiftl_inject s a H2); intros J; inv H4; inv J; simpl; auto.
+ (* shll *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ (* shrl *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ (* shrlu *)
+ - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int64.iwordsize'); auto.
+ (* shrlx *)
+ - inv H4; simpl in H1; try discriminate. simpl.
+ destruct (Int.ltu n (Int.repr 63)); inv H1. TrivialExists.
+ (* shift-ext *)
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto; rewrite a64_range; auto.
+ - inv H4; simpl; auto; rewrite a64_range; auto.
+ - inv H4; simpl; auto; rewrite a64_range; simpl; auto.
+ - inv H4; simpl; auto; rewrite a64_range; simpl; auto.
+
+ (* negf, absf *)
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ (* addf, subf *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* mulf, divf *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* negfs, absfs *)
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ (* addfs, subfs *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* mulfs, divfs *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* singleoffloat, floatofsingle *)
+ - inv H4; simpl; auto.
+ - inv H4; simpl; auto.
+ (* intoffloat, intuoffloat *)
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ (* floatofint, floatofintu *)
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ (* intofsingle, intuofsingle *)
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2.
+ exists (Vint i); auto.
+ (* singleofint, singleofintu *)
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ (* longoffloat, longuoffloat *)
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_long f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_longu f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ (* floatoflong, floatoflongu *)
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ (* longofsingle, longuofsingle *)
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_long f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_longu f0); simpl in H2; inv H2.
+ exists (Vlong i); auto.
+ (* singleoflong, singleoflongu *)
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ - inv H4; simpl in H1; inv H1. simpl. TrivialExists.
+ (* cmp, sel *)
+ - subst v1. destruct (eval_condition cond vl1 m1) eqn:?.
+ exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
+ destruct b; simpl; constructor.
+ simpl; constructor.
+ - apply Val.select_inject; auto.
+ destruct (eval_condition cond vl1 m1) eqn:?; auto.
+ right; symmetry; eapply eval_condition_inj; eauto.
+Qed.
+
+Lemma eval_addressing_inj:
+ forall addr sp1 vl1 sp2 vl2 v1,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = Some v1 ->
+ exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2.
+Proof.
+ intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists.
+- apply Val.addl_inject; auto.
+- apply Val.addl_inject; auto.
+- apply Val.addl_inject; auto. inv H3; simpl; auto; rewrite a64_range; auto.
+- apply Val.addl_inject; auto using eval_extend_inject.
+- apply H; simpl; auto.
+- apply Val.offset_ptr_inject; auto.
+Qed.
+
+
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *;
+ inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
+Qed.
+End EVAL_COMPAT.
+
+(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
+
+Section EVAL_LESSDEF.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+
+Remark valid_pointer_extends:
+ forall m1 m2, Mem.extends m1 m2 ->
+ forall b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+Proof.
+ intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto.
+Qed.
+
+Remark weak_valid_pointer_extends:
+ forall m1 m2, Mem.extends m1 m2 ->
+ forall b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
+Proof.
+ intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto.
+Qed.
+
+Remark weak_valid_pointer_no_overflow_extends:
+ forall m1 b1 ofs b2 delta,
+ Some(b1, 0) = Some(b2, delta) ->
+ Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
+ 0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
+Proof.
+ intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2.
+Qed.
+
+Remark valid_different_pointers_extends:
+ forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
+ b1 <> b2 ->
+ Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
+ Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
+ Some(b1, 0) = Some (b1', delta1) ->
+ Some(b2, 0) = Some (b2', delta2) ->
+ b1' <> b2' \/
+ Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)).
+Proof.
+ intros. inv H2; inv H3. auto.
+Qed.
+
+Lemma eval_condition_lessdef:
+ forall cond vl1 vl2 b m1 m2,
+ Val.lessdef_list vl1 vl2 ->
+ Mem.extends m1 m2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1).
+ apply valid_pointer_extends; auto.
+ apply weak_valid_pointer_extends; auto.
+ apply weak_valid_pointer_no_overflow_extends.
+ apply valid_different_pointers_extends; auto.
+ rewrite <- val_inject_list_lessdef. eauto. auto.
+Qed.
+
+Lemma eval_operation_lessdef:
+ forall sp op vl1 vl2 v1 m1 m2,
+ Val.lessdef_list vl1 vl2 ->
+ Mem.extends m1 m2 ->
+ eval_operation genv sp op vl1 m1 = Some v1 ->
+ exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ intros. rewrite val_inject_list_lessdef in H.
+ assert (exists v2 : val,
+ eval_operation genv sp op vl2 m2 = Some v2
+ /\ Val.inject (fun b => Some(b, 0)) v1 v2).
+ eapply eval_operation_inj with (m1 := m1) (sp1 := sp).
+ apply valid_pointer_extends; auto.
+ apply weak_valid_pointer_extends; auto.
+ apply weak_valid_pointer_no_overflow_extends.
+ apply valid_different_pointers_extends; auto.
+ intros. apply val_inject_lessdef. auto.
+ apply val_inject_lessdef; auto.
+ eauto.
+ auto.
+ destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
+Qed.
+
+Lemma eval_addressing_lessdef:
+ forall sp addr vl1 vl2 v1,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = Some v1 ->
+ exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2.
+Proof.
+ intros. rewrite val_inject_list_lessdef in H.
+ assert (exists v2 : val,
+ eval_addressing genv sp addr vl2 = Some v2
+ /\ Val.inject (fun b => Some(b, 0)) v1 v2).
+ eapply eval_addressing_inj with (sp1 := sp).
+ intros. rewrite <- val_inject_lessdef; auto.
+ rewrite <- val_inject_lessdef; auto.
+ eauto. auto.
+ destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
+Qed.
+
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros. rewrite val_inject_list_lessdef in H.
+ eapply eval_addressing_inj_none with (sp1 := sp).
+ intros. rewrite <- val_inject_lessdef; auto.
+ rewrite <- val_inject_lessdef; auto.
+ eauto. auto.
+Qed.
+End EVAL_LESSDEF.
+
+(** Compatibility of the evaluation functions with memory injections. *)
+
+Section EVAL_INJECT.
+
+Variable F V: Type.
+Variable genv: Genv.t F V.
+Variable f: meminj.
+Hypothesis globals: meminj_preserves_globals genv f.
+Variable sp1: block.
+Variable sp2: block.
+Variable delta: Z.
+Hypothesis sp_inj: f sp1 = Some(sp2, delta).
+
+Remark symbol_address_inject:
+ forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs).
+Proof.
+ intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto.
+ exploit (proj1 globals); eauto. intros.
+ econstructor; eauto. rewrite Ptrofs.add_zero; auto.
+Qed.
+
+Lemma eval_condition_inject:
+ forall cond vl1 vl2 b m1 m2,
+ Val.inject_list f vl1 vl2 ->
+ Mem.inject f m1 m2 ->
+ eval_condition cond vl1 m1 = Some b ->
+ eval_condition cond vl2 m2 = Some b.
+Proof.
+ intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto.
+ intros; eapply Mem.valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
+ intros; eapply Mem.different_pointers_inject; eauto.
+Qed.
+
+Lemma eval_addressing_inject:
+ forall addr vl1 vl2 v1,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 ->
+ exists v2,
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2
+ /\ Val.inject f v1 v2.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+Lemma eval_operation_inject:
+ forall op vl1 vl2 v1 m1 m2,
+ Val.inject_list f vl1 vl2 ->
+ Mem.inject f m1 m2 ->
+ eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 ->
+ exists v2,
+ eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2
+ /\ Val.inject f v1 v2.
+Proof.
+ intros.
+ rewrite eval_shift_stack_operation. simpl.
+ eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto.
+ intros; eapply Mem.valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
+ intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
+ intros; eapply Mem.different_pointers_inject; eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
+End EVAL_INJECT.
+
+(** * Handling of builtin arguments *)
+
+Definition builtin_arg_ok_1
+ (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) :=
+ match c, ba with
+ | OK_all, _ => true
+ | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true
+ | OK_addrstack, BA_addrstack _ => true
+ | OK_addressing, BA_addrstack _ => true
+ | OK_addressing, BA_addptr (BA _) (BA_int _) => true
+ | OK_addressing, BA_addptr (BA _) (BA_long _) => true
+ | _, _ => false
+ end.
+
+Definition builtin_arg_ok
+ (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) :=
+ match ba with
+ | (BA _ | BA_splitlong (BA _) (BA _)) => true
+ | _ => builtin_arg_ok_1 ba c
+ end.
diff --git a/aarch64/PrintOp.ml b/aarch64/PrintOp.ml
new file mode 100644
index 00000000..2d45e446
--- /dev/null
+++ b/aarch64/PrintOp.ml
@@ -0,0 +1,247 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Pretty-printing of operators, conditions, addressing modes *)
+
+open Printf
+open Camlcoq
+open Integers
+open Op
+
+let comparison_name = function
+ | Ceq -> "=="
+ | Cne -> "!="
+ | Clt -> "<"
+ | Cle -> "<="
+ | Cgt -> ">"
+ | Cge -> ">="
+
+let shift pp (s, a) =
+ match s with
+ | Slsl -> fprintf pp "<< %ld" (camlint_of_coqint a)
+ | Slsr -> fprintf pp ">>u %ld" (camlint_of_coqint a)
+ | Sasr -> fprintf pp ">>s %ld" (camlint_of_coqint a)
+ | Sror -> fprintf pp "ror %ld" (camlint_of_coqint a)
+
+let shiftl pp (s, a) =
+ match s with
+ | Slsl -> fprintf pp "<<l %ld" (camlint_of_coqint a)
+ | Slsr -> fprintf pp ">>lu %ld" (camlint_of_coqint a)
+ | Sasr -> fprintf pp ">>ls %ld" (camlint_of_coqint a)
+ | Sror -> fprintf pp "rorl %ld" (camlint_of_coqint a)
+
+let extend_name = function
+ | Xsgn32 -> "sext"
+ | Xuns32 -> "zext"
+
+let print_condition reg pp = function
+ | (Ccomp c, [r1;r2]) ->
+ fprintf pp "%a %ss %a" reg r1 (comparison_name c) reg r2
+ | (Ccompu c, [r1;r2]) ->
+ fprintf pp "%a %su %a" reg r1 (comparison_name c) reg r2
+ | (Ccompimm(c, n), [r1]) ->
+ fprintf pp "%a %ss %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompuimm(c, n), [r1]) ->
+ fprintf pp "%a %su %ld" reg r1 (comparison_name c) (camlint_of_coqint n)
+ | (Ccompshift(c, s, a), [r1;r2]) ->
+ fprintf pp "%a %ss %a %a" reg r1 (comparison_name c) reg r2 shift (s, a)
+ | (Ccompushift(c, s, a), [r1;r2]) ->
+ fprintf pp "%a %su %a %a" reg r1 (comparison_name c) reg r2 shift (s, a)
+ | (Cmaskzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx == 0" reg r1 (camlint_of_coqint n)
+ | (Cmasknotzero n, [r1]) ->
+ fprintf pp "%a & 0x%lx != 0" reg r1 (camlint_of_coqint n)
+ | (Ccompl c, [r1;r2]) ->
+ fprintf pp "%a %sls %a" reg r1 (comparison_name c) reg r2
+ | (Ccomplu c, [r1;r2]) ->
+ fprintf pp "%a %slu %a" reg r1 (comparison_name c) reg r2
+ | (Ccomplimm(c, n), [r1]) ->
+ fprintf pp "%a %sls %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n)
+ | (Ccompluimm(c, n), [r1]) ->
+ fprintf pp "%a %slu %Ld" reg r1 (comparison_name c) (camlint64_of_coqint n)
+ | (Ccomplshift(c, s, a), [r1;r2]) ->
+ fprintf pp "%a %sls %a %a" reg r1 (comparison_name c) reg r2 shift (s, a)
+ | (Ccomplushift(c, s, a), [r1;r2]) ->
+ fprintf pp "%a %slu %a %a" reg r1 (comparison_name c) reg r2 shift (s, a)
+ | (Cmasklzero n, [r1]) ->
+ fprintf pp "%a &l 0x%Lx == 0" reg r1 (camlint64_of_coqint n)
+ | (Cmasklnotzero n, [r1]) ->
+ fprintf pp "%a &l 0x%Lx != 0" reg r1 (camlint64_of_coqint n)
+ | (Ccompf c, [r1;r2]) ->
+ fprintf pp "%a %sf %a" reg r1 (comparison_name c) reg r2
+ | (Cnotcompf c, [r1;r2]) ->
+ fprintf pp "%a not(%sf) %a" reg r1 (comparison_name c) reg r2
+ | (Ccompfzero c, [r1]) ->
+ fprintf pp "%a %sf 0.0" reg r1 (comparison_name c)
+ | (Cnotcompfzero c, [r1]) ->
+ fprintf pp "%a not(%sf) 0.0" reg r1 (comparison_name c)
+ | (Ccompfs c, [r1;r2]) ->
+ fprintf pp "%a %sfs %a" reg r1 (comparison_name c) reg r2
+ | (Cnotcompfs c, [r1;r2]) ->
+ fprintf pp "%a not(%sfs) %a" reg r1 (comparison_name c) reg r2
+ | (Ccompfszero c, [r1]) ->
+ fprintf pp "%a %sfs 0.0" reg r1 (comparison_name c)
+ | (Cnotcompfszero c, [r1]) ->
+ fprintf pp "%a not(%sfs) 0.0" reg r1 (comparison_name c)
+ | _ ->
+ fprintf pp "<bad condition>"
+
+let print_operation reg pp = function
+ | Omove, [r1] -> reg pp r1
+ | Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n)
+ | Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n)
+ | Ofloatconst n, [] -> fprintf pp "%F" (camlfloat_of_coqfloat n)
+ | Osingleconst n, [] -> fprintf pp "%Ff" (camlfloat_of_coqfloat32 n)
+ | Oaddrsymbol(id, ofs), [] ->
+ fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs)
+ | Oaddrstack ofs, [] ->
+ fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs)
+(* 32-bit integer arithmetic *)
+ | Oshift(s, a), [r1] -> fprintf pp "%a %a" reg r1 shift (s,a)
+ | Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2
+ | Oaddshift(s, a), [r1;r2] -> fprintf pp "%a + %a %a" reg r1 reg r2 shift (s,a)
+ | Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n)
+ | Oneg, [r1] -> fprintf pp "- %a" reg r1
+ | Onegshift(s, a), [r1] -> fprintf pp "- (%a %a)" reg r1 shift (s,a)
+ | Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2
+ | Osubshift(s, a), [r1;r2] -> fprintf pp "%a - %a %a" reg r1 reg r2 shift (s,a)
+ | Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2
+ | Omuladd, [r1;r2;r3] -> fprintf pp "%a + %a * %a" reg r3 reg r1 reg r2
+ | Omulsub, [r1;r2;r3] -> fprintf pp "%a - %a * %a" reg r3 reg r1 reg r2
+ | Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2
+ | Odivu, [r1;r2] -> fprintf pp "%a /u %a" reg r1 reg r2
+ | Oand, [r1;r2] -> fprintf pp "%a & %a" reg r1 reg r2
+ | Oandshift(s, a), [r1;r2] -> fprintf pp "%a & %a %a" reg r1 reg r2 shift (s,a)
+ | Oandimm n, [r1] -> fprintf pp "%a & %ld" reg r1 (camlint_of_coqint n)
+ | Oor, [r1;r2] -> fprintf pp "%a | %a" reg r1 reg r2
+ | Oorshift(s, a), [r1;r2] -> fprintf pp "%a | %a %a" reg r1 reg r2 shift (s,a)
+ | Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n)
+ | Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2
+ | Oxorshift(s, a), [r1;r2] -> fprintf pp "%a ^ %a %a" reg r1 reg r2 shift (s,a)
+ | Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n)
+ | Onot, [r1] -> fprintf pp "~ %a" reg r1
+ | Onotshift(s, a), [r1] -> fprintf pp "~ (%a %a)" reg r1 shift (s,a)
+ | Obic, [r1;r2] -> fprintf pp "%a & ~ %a" reg r1 reg r2
+ | Obicshift(s, a), [r1;r2] -> fprintf pp "%a & ~ %a %a" reg r1 reg r2 shift (s,a)
+ | Oorn, [r1;r2] -> fprintf pp "%a | ~ %a" reg r1 reg r2
+ | Oornshift(s, a), [r1;r2] -> fprintf pp "%a | ~ %a %a" reg r1 reg r2 shift (s,a)
+ | Oeqv, [r1;r2] -> fprintf pp "%a ^ ~ %a" reg r1 reg r2
+ | Oeqvshift(s, a), [r1;r2] -> fprintf pp "%a ^ ~ %a %a" reg r1 reg r2 shift (s,a)
+ | Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2
+ | Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2
+ | Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2
+ | Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n)
+ | Ozext s, [r1] -> fprintf pp "zext(%d, %a)" (Z.to_int s) reg r1
+ | Osext s, [r1] -> fprintf pp "sext(%d, %a)" (Z.to_int s) reg r1
+ | Oshlzext(s, a), [r1] -> fprintf pp "zext(%d, %a) << %ld" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Oshlsext(s, a), [r1] -> fprintf pp "sext(%d, %a) << %ld" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Ozextshr(a, s), [r1] -> fprintf pp "zext(%d, %a >>u %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Osextshr(a, s), [r1] -> fprintf pp "sext(%d, %a >>s %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a)
+(* 64-bit integer arithmetic *)
+ | Oshiftl(s, a), [r1] -> fprintf pp "%a %a" reg r1 shiftl (s,a)
+ | Oextend(x, a), [r1] -> fprintf pp "%s(32, %a) <<l %ld" (extend_name x) reg r1 (camlint_of_coqint a)
+ | Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2
+ | Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1
+ | Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1
+ | Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2
+ | Oaddlshift(s, a), [r1;r2] -> fprintf pp "%a +l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oaddlext(x, a), [r1;r2] -> fprintf pp "%a +l %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a)
+ | Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n)
+ | Onegl, [r1] -> fprintf pp "-l %a" reg r1
+ | Oneglshift(s, a), [r1] -> fprintf pp "-l (%a %a)" reg r1 shiftl (s,a)
+ | Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2
+ | Osublext(x, a), [r1;r2] -> fprintf pp "%a +l %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a)
+ | Osublshift(s, a), [r1;r2] -> fprintf pp "%a -l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2
+ | Omulladd, [r1;r2;r3] -> fprintf pp "%a +l %a *l %a" reg r3 reg r1 reg r2
+ | Omullsub, [r1;r2;r3] -> fprintf pp "%a -l %a *l %a" reg r3 reg r1 reg r2
+ | Omullhs, [r1;r2] -> fprintf pp "%a *hls %a" reg r1 reg r2
+ | Omullhu, [r1;r2] -> fprintf pp "%a *hlu %a" reg r1 reg r2
+ | Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2
+ | Odivlu, [r1;r2] -> fprintf pp "%a /lu %a" reg r1 reg r2
+ | Oandl, [r1;r2] -> fprintf pp "%a &l %a" reg r1 reg r2
+ | Oandlshift(s, a), [r1;r2] -> fprintf pp "%a &l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2
+ | Oorlshift(s, a), [r1;r2] -> fprintf pp "%a |l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2
+ | Oxorlshift(s, a), [r1;r2] -> fprintf pp "%a ^l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n)
+ | Onotl, [r1] -> fprintf pp "~l %a" reg r1
+ | Onotlshift(s, a), [r1] -> fprintf pp "~l (%a %a)" reg r1 shiftl (s,a)
+ | Obicl, [r1;r2] -> fprintf pp "%a &l ~l %a" reg r1 reg r2
+ | Obiclshift(s, a), [r1;r2] -> fprintf pp "%a &l ~l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oornl, [r1;r2] -> fprintf pp "%a |l ~l %a" reg r1 reg r2
+ | Oornlshift(s, a), [r1;r2] -> fprintf pp "%a |l ~l %a %a" reg r1 reg r2 shiftl (s,a)
+ | Oeqvl, [r1;r2] -> fprintf pp "%a ^l ~l %a" reg r1 reg r2
+ | Oeqvlshift(s, a), [r1;r2] -> fprintf pp "%a ^l ~l %a %a" reg r1 reg r2 shift (s,a)
+ | Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2
+ | Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2
+ | Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2
+ | Oshrlximm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n)
+ | Ozextl s, [r1] -> fprintf pp "zextl(%d, %a)" (Z.to_int s) reg r1
+ | Osextl s, [r1] -> fprintf pp "sextl(%d, %a)" (Z.to_int s) reg r1
+ | Oshllzext(s, a), [r1] -> fprintf pp "zextl(%d, %a) <<l %ld" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Oshllsext(s, a), [r1] -> fprintf pp "sextl(%d, %a) <<l %ld" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Ozextshrl(a, s), [r1] -> fprintf pp "zextl(%d, %a >>lu %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a)
+ | Osextshrl(a, s), [r1] -> fprintf pp "sextl(%d, %a >>ls %ld)" (Z.to_int s) reg r1 (camlint_of_coqint a)
+(* 64-bit floating-point arithmetic *)
+ | Onegf, [r1] -> fprintf pp "negf(%a)" reg r1
+ | Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1
+ | Oaddf, [r1;r2] -> fprintf pp "%a +f %a" reg r1 reg r2
+ | Osubf, [r1;r2] -> fprintf pp "%a -f %a" reg r1 reg r2
+ | Omulf, [r1;r2] -> fprintf pp "%a *f %a" reg r1 reg r2
+ | Odivf, [r1;r2] -> fprintf pp "%a /f %a" reg r1 reg r2
+(* 32-bit floating-point arithmetic *)
+ | Onegfs, [r1] -> fprintf pp "negfs(%a)" reg r1
+ | Oabsfs, [r1] -> fprintf pp "absfs(%a)" reg r1
+ | Oaddfs, [r1;r2] -> fprintf pp "%a +fs %a" reg r1 reg r2
+ | Osubfs, [r1;r2] -> fprintf pp "%a -fs %a" reg r1 reg r2
+ | Omulfs, [r1;r2] -> fprintf pp "%a *fs %a" reg r1 reg r2
+ | Odivfs, [r1;r2] -> fprintf pp "%a /fs %a" reg r1 reg r2
+ | Osingleoffloat, [r1] -> fprintf pp "singleoffloat(%a)" reg r1
+ | Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1
+(* Conversions between int and float *)
+ | Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
+ | Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1
+ | Ofloatofint, [r1] -> fprintf pp "floatofint(%a)" reg r1
+ | Ofloatofintu, [r1] -> fprintf pp "floatofintu(%a)" reg r1
+ | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1
+ | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1
+ | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1
+ | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1
+ | Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1
+ | Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1
+ | Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1
+ | Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1
+ | Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1
+ | Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1
+ | Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1
+ | Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1
+(* Boolean tests *)
+ | Ocmp c, args -> print_condition reg pp (c, args)
+ | Osel (c, ty), r1::r2::args ->
+ fprintf pp "%a ?%s %a : %a"
+ (print_condition reg) (c, args)
+ (PrintAST.name_of_type ty) reg r1 reg r2
+ | _ -> fprintf pp "<bad operator>"
+
+let print_addressing reg pp = function
+ | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_coqint n)
+ | Aindexed2, [r1; r2] -> fprintf pp "%a + %a" reg r1 reg r2
+ | Aindexed2shift a, [r1; r2] -> fprintf pp "%a + %a << %ld" reg r1 reg r2 (camlint_of_coqint a)
+ | Aindexed2ext(x, a), [r1; r2] -> fprintf pp "%a + %s(%a) << %ld" reg r1 (extend_name x) reg r2 (camlint_of_coqint a)
+ | Aglobal(id, ofs), [] ->
+ fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs)
+ | Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs)
+ | _ -> fprintf pp "<bad addressing>"
diff --git a/aarch64/SelectLong.vp b/aarch64/SelectLong.vp
new file mode 100644
index 00000000..ddf6e212
--- /dev/null
+++ b/aarch64/SelectLong.vp
@@ -0,0 +1,478 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Instruction selection for 64-bit integer operations *)
+
+Require Import Coqlib Zbits.
+Require Import Compopts AST Integers Floats.
+Require Import Op CminorSel SelectOp.
+
+Local Open Scope cminorsel_scope.
+
+(** ** Constants **)
+
+Definition longconst (n: int64) : expr :=
+ Eop (Olongconst n) Enil.
+
+(** ** Conversions *)
+
+Nondetfunction intoflong (e: expr) :=
+ match e with
+ | Eop (Olongconst n) Enil => Eop (Ointconst (Int.repr (Int64.unsigned n))) Enil
+ | _ => Eop Olowlong (e ::: Enil)
+ end.
+
+Nondetfunction longofint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => longconst (Int64.repr (Int.signed n))
+ | _ => Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e ::: Enil)
+ end.
+
+Nondetfunction longofintu (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => longconst (Int64.repr (Int.unsigned n))
+ | _ => Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e ::: Enil)
+ end.
+
+(** ** Integer addition and pointer addition *)
+
+Nondetfunction addlimm (n: int64) (e: expr) :=
+ if Int64.eq n Int64.zero then e else
+ match e with
+ | Eop (Olongconst m) Enil => longconst (Int64.add n m)
+ | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil
+ | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil
+ | Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil)
+ | _ => Eop (Oaddlimm n) (e ::: Enil)
+ end.
+
+Nondetfunction addl (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => addlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => addlimm n2 t1
+ | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) =>
+ addlimm (Int64.add n1 n2) (Eop Oaddl (t1:::t2:::Enil))
+ | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddrstack n2) Enil =>
+ Eop Oaddl (Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n1) n2)) Enil ::: t1 ::: Enil)
+ | Eop (Oaddrstack n1) Enil, Eop (Oaddlimm n2) (t2:::Enil) =>
+ Eop Oaddl (Eop (Oaddrstack (Ptrofs.add n1 (Ptrofs.of_int64 n2))) Enil ::: t2 ::: Enil)
+ | Eop (Oaddlimm n1) (t1:::Enil), t2 =>
+ addlimm n1 (Eop Oaddl (t1:::t2:::Enil))
+ | t1, Eop (Oaddlimm n2) (t2:::Enil) =>
+ addlimm n2 (Eop Oaddl (t1:::t2:::Enil))
+ | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Oaddlshift s a) (t2 ::: t1 ::: Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Oaddlshift s a) (t1 ::: t2 ::: Enil)
+ | Eop (Oextend x a) (t1:::Enil), t2 =>
+ Eop (Oaddlext x a) (t2 ::: t1 ::: Enil)
+ | t1, Eop (Oextend x a) (t2:::Enil) =>
+ Eop (Oaddlext x a) (t1 ::: t2 ::: Enil)
+ | Eop Omull (t1:::t2:::Enil), t3 =>
+ Eop Omulladd (t3:::t1:::t2:::Enil)
+ | t1, Eop Omull (t2:::t3:::Enil) =>
+ Eop Omulladd (t1:::t2:::t3:::Enil)
+ | _, _ => Eop Oaddl (e1:::e2:::Enil)
+ end.
+
+(** ** Opposite *)
+
+Nondetfunction negl (e: expr) :=
+ match e with
+ | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.neg n)) Enil
+ | Eop (Oshiftl s a) (t1:::Enil) ?? arith_shift s => Eop (Oneglshift s a) (t1:::Enil)
+ | _ => Eop Onegl (e ::: Enil)
+ end.
+
+(** ** Integer and pointer subtraction *)
+
+Nondetfunction subl (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | t1, Eop (Olongconst n2) Enil =>
+ addlimm (Int64.neg n2) t1
+ | Eop (Oaddlimm n1) (t1:::Enil), Eop (Oaddlimm n2) (t2:::Enil) =>
+ addlimm (Int64.sub n1 n2) (Eop Osubl (t1:::t2:::Enil))
+ | Eop (Oaddlimm n1) (t1:::Enil), t2 =>
+ addlimm n1 (Eop Osubl (t1:::t2:::Enil))
+ | t1, Eop (Oaddlimm n2) (t2:::Enil) =>
+ addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil))
+ | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Osublshift s a) (t1:::t2::: Enil)
+ | t1, Eop (Oextend x a) (t2:::Enil) =>
+ Eop (Osublext x a) (t1 ::: t2 ::: Enil)
+ | t1, Eop Omull (t2:::t3:::Enil) =>
+ Eop Omullsub (t1:::t2:::t3:::Enil)
+ | _, _ => Eop Osubl (e1:::e2:::Enil)
+ end.
+
+(** ** Immediate shift left *)
+
+Definition shllimm_base (e1: expr) (n: int) :=
+ Eop (Oshiftl Slsl (mk_amount64 n)) (e1 ::: Enil).
+
+Nondetfunction shllimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshll (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst (Int64.shl' n1 n)) Enil
+ | Eop (Oshiftl Slsl a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then shllimm_base t1 (Int.add a n)
+ else shllimm_base e1 n
+ | Eop (Ozextl s) (t1:::Enil) =>
+ Eop (Oshllzext s (mk_amount64 n)) (t1:::Enil)
+ | Eop (Osextl s) (t1:::Enil) =>
+ Eop (Oshllsext s (mk_amount64 n)) (t1:::Enil)
+ | Eop (Oshllzext s a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then Eop (Oshllzext s (mk_amount64 (Int.add a n))) (t1:::Enil)
+ else shllimm_base e1 n
+ | Eop (Oshllsext s a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then Eop (Oshllsext s (mk_amount64 (Int.add a n))) (t1:::Enil)
+ else shllimm_base e1 n
+ | Eop (Oextend x a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then Eop (Oextend x (mk_amount64 (Int.add a n))) (t1:::Enil)
+ else shllimm_base e1 n
+ | _ =>
+ shllimm_base e1 n
+ end.
+
+(** ** Immediate shift right (logical) *)
+
+Definition shrluimm_base (e1: expr) (n: int) :=
+ Eop (Oshiftl Slsr (mk_amount64 n)) (e1 ::: Enil).
+
+Nondetfunction shrluimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshrlu (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst (Int64.shru' n1 n)) Enil
+ | Eop (Oshiftl Slsl a) (t1:::Enil) =>
+ if Int.ltu n a
+ then Eop (Oshllzext (Int64.zwordsize - Int.unsigned a) (mk_amount64 (Int.sub a n))) (t1:::Enil)
+ else Eop (Ozextshrl (mk_amount64 (Int.sub n a)) (Int64.zwordsize - Int.unsigned n)) (t1:::Enil)
+ | Eop (Oshiftl Slsr a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then shrluimm_base t1 (Int.add a n)
+ else shrluimm_base e1 n
+ | Eop (Ozextl s) (t1:::Enil) =>
+ if zlt (Int.unsigned n) s
+ then Eop (Ozextshrl (mk_amount64 n) (s - Int.unsigned n)) (t1:::Enil)
+ else Eop (Olongconst Int64.zero) Enil
+ | _ =>
+ shrluimm_base e1 n
+ end.
+
+(** ** Immediate shift right (arithmetic) *)
+
+Definition shrlimm_base (e1: expr) (n: int) :=
+ Eop (Oshiftl Sasr (mk_amount64 n)) (e1 ::: Enil).
+
+Nondetfunction shrlimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int64.iwordsize') then
+ Eop Oshrl (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Olongconst n1) Enil =>
+ Eop (Olongconst (Int64.shr' n1 n)) Enil
+ | Eop (Oshiftl Slsl a) (t1:::Enil) =>
+ if Int.ltu n a
+ then Eop (Oshllsext (Int64.zwordsize - Int.unsigned a) (mk_amount64 (Int.sub a n))) (t1:::Enil)
+ else Eop (Osextshrl (mk_amount64 (Int.sub n a)) (Int64.zwordsize - Int.unsigned n)) (t1:::Enil)
+ | Eop (Oshiftl Sasr a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int64.iwordsize'
+ then shrlimm_base t1 (Int.add a n)
+ else shrlimm_base e1 n
+ | Eop (Osextl s) (t1:::Enil) =>
+ if zlt (Int.unsigned n) s && zlt s Int64.zwordsize
+ then Eop (Osextshrl (mk_amount64 n) (s - Int.unsigned n)) (t1:::Enil)
+ else shrlimm_base e1 n
+ | _ =>
+ shrlimm_base e1 n
+ end.
+
+(** ** Integer multiply *)
+
+Definition mullimm_base (n1: int64) (e2: expr) :=
+ match Int64.one_bits' n1 with
+ | i :: nil =>
+ shllimm e2 i
+ | i :: j :: nil =>
+ Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j))
+ | _ =>
+ Eop Omull (Eop (Olongconst n1) Enil ::: e2 ::: Enil)
+ end.
+
+Nondetfunction mullimm (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then Eop (Olongconst Int64.zero) Enil
+ else if Int64.eq n1 Int64.one then e2
+ else match e2 with
+ | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.mul n1 n2)) Enil
+ | Eop (Oaddlimm n2) (t2:::Enil) => addlimm (Int64.mul n1 n2) (mullimm_base n1 t2)
+ | _ => mullimm_base n1 e2
+ end.
+
+Nondetfunction mull (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => mullimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => mullimm n2 t1
+ | _, _ => Eop Omull (e1:::e2:::Enil)
+ end.
+
+Definition mullhs (e1: expr) (n2: int64) :=
+ Eop Omullhs (e1 ::: longconst n2 ::: Enil).
+
+Definition mullhu (e1: expr) (n2: int64) :=
+ Eop Omullhu (e1 ::: longconst n2 ::: Enil).
+
+(** ** Integer conversions *)
+
+Nondetfunction zero_ext_l (sz: Z) (e: expr) :=
+ match e with
+ | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.zero_ext sz n)) Enil
+ | Eop (Oshiftl Slsr a) (t1:::Enil) => Eop (Ozextshrl a sz) (t1:::Enil)
+ | Eop (Oshiftl Slsl a) (t1:::Enil) =>
+ if zlt (Int.unsigned a) sz
+ then Eop (Oshllzext (sz - Int.unsigned a) a) (t1:::Enil)
+ else Eop (Ozextl sz) (e:::Enil)
+ | _ => Eop (Ozextl sz) (e:::Enil)
+ end.
+
+(** ** Bitwise not *)
+
+Nondetfunction notl (e: expr) :=
+ match e with
+ | Eop (Olongconst n) Enil => Eop (Olongconst (Int64.not n)) Enil
+ | Eop (Oshiftl s a) (t1:::Enil) => Eop (Onotlshift s a) (t1:::Enil)
+ | Eop Onotl (t1:::Enil) => t1
+ | Eop (Onotlshift s a) (t1:::Enil) => Eop (Oshiftl s a) (t1:::Enil)
+ | Eop Obicl (t1:::t2:::Enil) => Eop Oornl (t2:::t1:::Enil)
+ | Eop Oornl (t1:::t2:::Enil) => Eop Obicl (t2:::t1:::Enil)
+ | Eop Oxorl (t1:::t2:::Enil) => Eop Oeqvl (t1:::t2:::Enil)
+ | Eop Oeqvl (t1:::t2:::Enil) => Eop Oxorl (t1:::t2:::Enil)
+ | _ => Eop Onotl (e:::Enil)
+ end.
+
+(** ** Bitwise and *)
+
+Definition andlimm_base (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then Eop (Olongconst Int64.zero) Enil else
+ if Int64.eq n1 Int64.mone then e2 else
+ match Z_is_power2m1 (Int64.unsigned n1) with
+ | Some s => zero_ext_l s e2
+ | None => Eop (Oandlimm n1) (e2 ::: Enil)
+ end.
+
+Nondetfunction andlimm (n1: int64) (e2: expr) :=
+ match e2 with
+ | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.and n1 n2)) Enil
+ | Eop (Oandlimm n2) (t2:::Enil) => andlimm_base (Int64.and n1 n2) t2
+ | Eop (Ozextl s) (t2:::Enil) =>
+ if zle 0 s
+ then andlimm_base (Int64.and n1 (Int64.repr (two_p s - 1))) t2
+ else andlimm_base n1 e2
+ | _ => andlimm_base n1 e2
+ end.
+
+Nondetfunction andl (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => andlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => andlimm n2 t1
+ | Eop Onotl (t1:::Enil), t2 => Eop Obicl (t2:::t1:::Enil)
+ | t1, Eop Onotl (t2:::Enil) => Eop Obicl (t1:::t2:::Enil)
+ | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Obiclshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Obiclshift s a) (t1:::t2:::Enil)
+ | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oandlshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oandlshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oandl (e1:::e2:::Enil)
+ end.
+
+(** ** Bitwise or *)
+
+Nondetfunction orlimm (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then e2
+ else if Int64.eq n1 Int64.mone then Eop (Olongconst Int64.mone) Enil
+ else match e2 with
+ | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.or n1 n2)) Enil
+ | Eop (Oorlimm n2) (t2:::Enil) => Eop (Oorlimm (Int64.or n1 n2)) (t2:::Enil)
+ | _ => Eop (Oorlimm n1) (e2:::Enil)
+ end.
+
+Nondetfunction orl (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => orlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => orlimm n2 t1
+ | Eop Onotl (t1:::Enil), t2 => Eop Oornl (t2:::t1:::Enil)
+ | t1, Eop Onotl (t2:::Enil) => Eop Oornl (t1:::t2:::Enil)
+ | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Oornlshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Oornlshift s a) (t1:::t2:::Enil)
+ | Eop (Oshiftl Slsl a1) (t1:::Enil), Eop (Oshiftl Slsr a2) (t2:::Enil) =>
+ if Int.eq (Int.add a1 a2) Int64.iwordsize' && same_expr_pure t1 t2
+ then Eop (Oshiftl Sror a2) (t2:::Enil)
+ else Eop (Oorlshift Slsr a2) (Eop (Oshiftl Slsl a1) (t1:::Enil):::t2:::Enil)
+ | Eop (Oshiftl Slsr a1) (t1:::Enil), Eop (Oshiftl Slsl a2) (t2:::Enil) =>
+ if Int.eq (Int.add a2 a1) Int64.iwordsize' && same_expr_pure t1 t2
+ then Eop (Oshiftl Sror a1) (t1:::Enil)
+ else Eop (Oorlshift Slsl a2) (Eop (Oshiftl Slsr a1) (t1:::Enil):::t2:::Enil)
+ | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oorlshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oorlshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oorl (e1:::e2:::Enil)
+ end.
+
+(** ** Bitwise xor *)
+
+Definition xorlimm_base (n1: int64) (e2: expr) :=
+ if Int64.eq n1 Int64.zero then e2 else
+ if Int64.eq n1 Int64.mone then notl e2 else
+ Eop (Oxorlimm n1) (e2:::Enil).
+
+Nondetfunction xorlimm (n1: int64) (e2: expr) :=
+ match e2 with
+ | Eop (Olongconst n2) Enil => Eop (Olongconst (Int64.xor n1 n2)) Enil
+ | Eop (Oxorlimm n2) (t2:::Enil) => xorlimm_base (Int64.xor n1 n2) t2
+ | _ => xorlimm_base n1 e2
+ end.
+
+Nondetfunction xorl (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 => xorlimm n1 t2
+ | t1, Eop (Olongconst n2) Enil => xorlimm n2 t1
+ | Eop Onotl (t1:::Enil), t2 => Eop Oeqvl (t2:::t1:::Enil)
+ | t1, Eop Onotl (t2:::Enil) => Eop Oeqvl (t1:::t2:::Enil)
+ | Eop (Onotlshift s a) (t1:::Enil), t2 => Eop (Oeqvlshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotlshift s a) (t2:::Enil) => Eop (Oeqvlshift s a) (t1:::t2:::Enil)
+ | Eop (Oshiftl s a) (t1:::Enil), t2 => Eop (Oxorlshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) => Eop (Oxorlshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oxorl (e1:::e2:::Enil)
+ end.
+
+(** ** Integer division and modulus *)
+
+Definition modl_aux (divop: operation) (e1 e2: expr) :=
+ Elet e1
+ (Elet (lift e2)
+ (Eop Omullsub (Eletvar 1 :::
+ Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) :::
+ Eletvar 0 :::
+ Enil))).
+
+Definition divls_base (e1: expr) (e2: expr) := Eop Odivl (e1:::e2:::Enil).
+Definition modls_base := modl_aux Odivl.
+Definition divlu_base (e1: expr) (e2: expr) := Eop Odivlu (e1:::e2:::Enil).
+Definition modlu_base := modl_aux Odivlu.
+
+Definition shrxlimm (e1: expr) (n2: int) :=
+ if Int.eq n2 Int.zero then e1 else Eop (Oshrlximm n2) (e1:::Enil).
+
+(** ** General shifts *)
+
+Nondetfunction shll (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shllimm e1 n2
+ | _ => Eop Oshll (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shrl (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shrlimm e1 n2
+ | _ => Eop Oshrl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shrlu (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shrluimm e1 n2
+ | _ => Eop Oshrlu (e1:::e2:::Enil)
+ end.
+
+(** ** Comparisons *)
+
+Nondetfunction complimm (default: comparison -> int64 -> condition)
+ (sem: comparison -> int64 -> int64 -> bool)
+ (c: comparison) (e1: expr) (n2: int64) :=
+ match c, e1 with
+ | c, Eop (Olongconst n1) Enil =>
+ Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil
+ | Ceq, Eop (Oandlimm m) (t1:::Enil) =>
+ if Int64.eq n2 Int64.zero
+ then Eop (Ocmp (Cmasklzero m)) (t1:::Enil)
+ else Eop (Ocmp (default c n2)) (e1:::Enil)
+ | Cne, Eop (Oandlimm m) (t1:::Enil) =>
+ if Int64.eq n2 Int64.zero
+ then Eop (Ocmp (Cmasklnotzero m)) (t1:::Enil)
+ else Eop (Ocmp (default c n2)) (e1:::Enil)
+ | _, _ =>
+ Eop (Ocmp (default c n2)) (e1:::Enil)
+ end.
+
+Nondetfunction cmpl (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 =>
+ complimm Ccomplimm Int64.cmp (swap_comparison c) t2 n1
+ | t1, Eop (Olongconst n2) Enil =>
+ complimm Ccomplimm Int64.cmp c t1 n2
+ | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Ocmp (Ccomplshift (swap_comparison c) s a)) (t2:::t1:::Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Ocmp (Ccomplshift c s a)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Ocmp (Ccompl c)) (e1:::e2:::Enil)
+ end.
+
+Nondetfunction cmplu (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Olongconst n1) Enil, t2 =>
+ complimm Ccompluimm Int64.cmpu (swap_comparison c) t2 n1
+ | t1, Eop (Olongconst n2) Enil =>
+ complimm Ccompluimm Int64.cmpu c t1 n2
+ | Eop (Oshiftl s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Ocmp (Ccomplushift (swap_comparison c) s a)) (t2:::t1:::Enil)
+ | t1, Eop (Oshiftl s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Ocmp (Ccomplushift c s a)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Ocmp (Ccomplu c)) (e1:::e2:::Enil)
+ end.
+
+(** ** Floating-point conversions *)
+
+Definition longoffloat (e: expr) :=
+ Eop Olongoffloat (e:::Enil).
+
+Definition longuoffloat (e: expr) :=
+ Eop Olonguoffloat (e:::Enil).
+
+Definition floatoflong (e: expr) :=
+ Eop Ofloatoflong (e:::Enil).
+
+Definition floatoflongu (e: expr) :=
+ Eop Ofloatoflongu (e:::Enil).
+
+Definition longofsingle (e: expr) :=
+ Eop Olongofsingle (e:::Enil).
+
+Definition longuofsingle (e: expr) :=
+ Eop Olonguofsingle (e:::Enil).
+
+Definition singleoflong (e: expr) :=
+ Eop Osingleoflong (e:::Enil).
+
+Definition singleoflongu (e: expr) :=
+ Eop Osingleoflongu (e:::Enil).
+
diff --git a/aarch64/SelectLongproof.v b/aarch64/SelectLongproof.v
new file mode 100644
index 00000000..60dc1a12
--- /dev/null
+++ b/aarch64/SelectLongproof.v
@@ -0,0 +1,767 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness of instruction selection for 64-bit integer operators *)
+
+Require Import Coqlib Zbits.
+Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import Cminor Op CminorSel.
+Require Import SelectOp SelectLong SelectOpproof.
+Require Import OpHelpers OpHelpersproof.
+
+Local Open Scope cminorsel_scope.
+Local Transparent Archi.ptr64.
+
+(** * Correctness of the smart constructors *)
+
+Section CMCONSTR.
+Variable prog: program.
+Variable hf: helper_functions.
+Hypothesis HELPERS: helper_functions_declared prog hf.
+Let ge := Genv.globalenv prog.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
+ forall le a x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.
+
+Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
+ forall le a x b y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.
+
+Definition partial_unary_constructor_sound (cstr: expr -> expr) (sem: val -> option val) : Prop :=
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ sem x = Some y ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef y v.
+
+Definition partial_binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> option val) : Prop :=
+ forall le a x b y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ sem x y = Some z ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef z v.
+
+(** ** Constants *)
+
+Theorem eval_longconst:
+ forall le n, eval_expr ge sp e m le (longconst n) (Vlong n).
+Proof.
+ intros; EvalOp.
+Qed.
+
+(** ** Conversions *)
+
+Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword.
+Proof.
+ unfold intoflong; red; intros until x; destruct (intoflong_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu.
+Proof.
+ unfold longofintu; red; intros until x; destruct (longofintu_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by reflexivity.
+ destruct x; simpl; auto. rewrite Int64.shl'_zero. auto.
+Qed.
+
+Theorem eval_longofint: unary_constructor_sound longofint Val.longofint.
+Proof.
+ unfold longofint; red; intros until x; destruct (longofint_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by reflexivity.
+ destruct x; simpl; auto. rewrite Int64.shl'_zero. auto.
+Qed.
+
+(** ** Addition, opposite, subtraction *)
+
+Theorem eval_addlimm:
+ forall n, unary_constructor_sound (addlimm n) (fun x => Val.addl x (Vlong n)).
+Proof.
+ red; unfold addlimm; intros until x.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+- subst n. intros. exists x; split; auto.
+ destruct x; simpl; auto.
+ rewrite Int64.add_zero; auto.
+ rewrite Ptrofs.add_zero; auto.
+- case (addlimm_match a); intros; InvEval; subst.
++ rewrite Int64.add_commut; TrivialExists.
++ TrivialExists. simpl. rewrite Ptrofs.add_commut, Genv.shift_symbol_address_64; auto.
++ econstructor; split. EvalOp. destruct sp; simpl; auto.
+ rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0); auto.
++ rewrite Val.addl_assoc, Int64.add_commut; TrivialExists.
++ TrivialExists.
+Qed.
+
+Theorem eval_addl: binary_constructor_sound addl Val.addl.
+Proof.
+ red; intros until y.
+ unfold addl; case (addl_match a b); intros; InvEval; subst.
+- rewrite Val.addl_commut. apply eval_addlimm; auto.
+- apply eval_addlimm; auto.
+- replace (Val.addl (Val.addl v1 (Vlong n1)) (Val.addl v0 (Vlong n2)))
+ with (Val.addl (Val.addl v1 v0) (Val.addl (Vlong n1) (Vlong n2))).
+ apply eval_addlimm. EvalOp.
+ repeat rewrite Val.addl_assoc. decEq. apply Val.addl_permut.
+- TrivialExists. simpl.
+ rewrite Val.addl_commut, Val.addl_assoc. f_equal; f_equal.
+ destruct sp; simpl; auto. rewrite Ptrofs.add_assoc, (Ptrofs.add_commut n2). auto.
+- TrivialExists. simpl.
+ rewrite <- (Val.addl_commut v1), <- (Val.addl_commut (Val.addl v1 (Vlong n2))).
+ rewrite Val.addl_assoc. f_equal; f_equal.
+ destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. auto.
+- replace (Val.addl (Val.addl v1 (Vlong n1)) y)
+ with (Val.addl (Val.addl v1 y) (Vlong n1)).
+ apply eval_addlimm. EvalOp.
+ repeat rewrite Val.addl_assoc. decEq. apply Val.addl_commut.
+- rewrite <- Val.addl_assoc. apply eval_addlimm. EvalOp.
+- rewrite Val.addl_commut. TrivialExists.
+- TrivialExists.
+- rewrite Val.addl_commut. TrivialExists.
+- TrivialExists.
+- rewrite Val.addl_commut. TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_negl: unary_constructor_sound negl (fun v => Val.subl (Vlong Int64.zero) v).
+Proof.
+ red; intros until x; unfold negl. case (negl_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_subl: binary_constructor_sound subl Val.subl.
+Proof.
+ red; intros until y; unfold subl; case (subl_match a b); intros; InvEval; subst.
+- rewrite Val.subl_addl_opp. apply eval_addlimm; auto.
+- rewrite Val.subl_addl_l. rewrite Val.subl_addl_r.
+ rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp.
+ apply eval_addlimm; EvalOp.
+- rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp.
+- rewrite Val.subl_addl_r. apply eval_addlimm; EvalOp.
+- TrivialExists.
+- TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+(** ** Immediate shifts *)
+
+Remark eval_shllimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int64.iwordsize' = true ->
+ eval_expr ge sp e m le (shllimm_base a n) (Val.shll x (Vint n)).
+Proof.
+Local Opaque mk_amount64.
+ unfold shlimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto.
+Qed.
+
+Theorem eval_shllimm:
+ forall n, unary_constructor_sound (fun a => shllimm a n)
+ (fun x => Val.shll x (Vint n)).
+Proof.
+ red; intros until x; unfold shllimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shl'_zero; auto.
+- destruct (shllimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* econstructor; split. eapply eval_shllimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2.
+ rewrite Int64.shl'_shl'; auto using a64_range.
+* econstructor; split; [|eauto]. apply eval_shllimm_base; auto. EvalOp.
++ TrivialExists. simpl. rewrite mk_amount64_eq; auto.
++ TrivialExists. simpl. rewrite mk_amount64_eq; auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* TrivialExists. simpl. rewrite mk_amount64_eq by auto.
+ destruct (Val.zero_ext_l s v1); simpl; auto.
+ rewrite a64_range; simpl; rewrite L, L2.
+ rewrite Int64.shl'_shl'; auto using a64_range.
+* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* TrivialExists. simpl. rewrite mk_amount64_eq by auto.
+ destruct (Val.sign_ext_l s v1); simpl; auto.
+ rewrite a64_range; simpl; rewrite L, L2.
+ rewrite Int64.shl'_shl'; auto using a64_range.
+* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* TrivialExists. simpl. unfold eval_extend. rewrite mk_amount64_eq by auto.
+ destruct (match x0 with Xsgn32 => Val.longofint v1 | Xuns32 => Val.longofintu v1 end); simpl; auto.
+ rewrite a64_range; simpl; rewrite L, L2.
+ rewrite Int64.shl'_shl'; auto using a64_range.
+* econstructor; split. eapply eval_shllimm_base; eauto. EvalOp; simpl; eauto. auto.
++ econstructor; eauto using eval_shllimm_base.
+- intros; TrivialExists.
+Qed.
+
+Remark eval_shrluimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int64.iwordsize' = true ->
+ eval_expr ge sp e m le (shrluimm_base a n) (Val.shrlu x (Vint n)).
+Proof.
+ unfold shrluimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto.
+Qed.
+
+Remark sub_shift_amount:
+ forall y z,
+ Int.ltu y Int64.iwordsize' = true -> Int.ltu z Int64.iwordsize' = true -> Int.unsigned y <= Int.unsigned z ->
+ Int.ltu (Int.sub z y) Int64.iwordsize' = true.
+Proof.
+ intros. unfold Int.ltu; apply zlt_true.
+ apply Int.ltu_inv in H. apply Int.ltu_inv in H0.
+ change (Int.unsigned Int64.iwordsize') with Int64.zwordsize in *.
+ unfold Int.sub; rewrite Int.unsigned_repr. omega.
+ assert (Int64.zwordsize < Int.max_unsigned) by reflexivity. omega.
+Qed.
+
+Theorem eval_shrluimm:
+ forall n, unary_constructor_sound (fun a => shrluimm a n)
+ (fun x => Val.shrlu x (Vint n)).
+Proof.
+Local Opaque Int64.zwordsize.
+ red; intros until x; unfold shrluimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shru'_zero; auto.
+- destruct (shrluimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu n a) eqn:L2.
+* assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true).
+ { apply sub_shift_amount; auto using a64_range.
+ apply Int.ltu_inv in L2. omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto.
+ simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto.
+* assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true).
+ { apply sub_shift_amount; auto using a64_range.
+ unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto.
+ simpl. rewrite L. rewrite Int64.shru'_shl', L2 by auto using a64_range. auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* econstructor; split. eapply eval_shrluimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2.
+ rewrite Int64.shru'_shru'; auto using a64_range.
+* econstructor; split; [|eauto]. apply eval_shrluimm_base; auto. EvalOp.
++ destruct (zlt (Int.unsigned n) s).
+* econstructor; split. EvalOp. rewrite mk_amount64_eq by auto.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ set (s' := s - Int.unsigned n).
+ replace s with (s' + Int.unsigned n) by (unfold s'; omega).
+ rewrite Int64.shru'_zero_ext. auto. unfold s'; omega.
+* econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ rewrite Int64.shru'_zero_ext_0 by omega. auto.
++ econstructor; eauto using eval_shrluimm_base.
+- intros; TrivialExists.
+Qed.
+
+Remark eval_shrlimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int64.iwordsize' = true ->
+ eval_expr ge sp e m le (shrlimm_base a n) (Val.shrl x (Vint n)).
+Proof.
+ unfold shrlimm_base; intros; EvalOp. simpl. rewrite mk_amount64_eq by auto. auto.
+Qed.
+
+Theorem eval_shrlimm:
+ forall n, unary_constructor_sound (fun a => shrlimm a n)
+ (fun x => Val.shrl x (Vint n)).
+Proof.
+ red; intros until x; unfold shrlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int64.iwordsize') eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int64.shr'_zero; auto.
+- destruct (shrlimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu n a) eqn:L2.
+* assert (L3: Int.ltu (Int.sub a n) Int64.iwordsize' = true).
+ { apply sub_shift_amount; auto using a64_range.
+ apply Int.ltu_inv in L2. omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto.
+ simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto.
+* assert (L3: Int.ltu (Int.sub n a) Int64.iwordsize' = true).
+ { apply sub_shift_amount; auto using a64_range.
+ unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount64_eq, L3, a64_range by auto.
+ simpl. rewrite L. rewrite Int64.shr'_shl', L2 by auto using a64_range. auto.
++ destruct (Int.ltu (Int.add a n) Int64.iwordsize') eqn:L2.
+* econstructor; split. eapply eval_shrlimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a64_range; simpl. rewrite L, L2.
+ rewrite Int64.shr'_shr'; auto using a64_range.
+* econstructor; split; [|eauto]. apply eval_shrlimm_base; auto. EvalOp.
++ destruct (zlt (Int.unsigned n) s && zlt s Int64.zwordsize) eqn:E.
+* InvBooleans. econstructor; split. EvalOp. rewrite mk_amount64_eq by auto.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ set (s' := s - Int.unsigned n).
+ replace s with (s' + Int.unsigned n) by (unfold s'; omega).
+ rewrite Int64.shr'_sign_ext. auto. unfold s'; omega. unfold s'; omega.
+* econstructor; split; [|eauto]. apply eval_shrlimm_base; auto. EvalOp.
++ econstructor; eauto using eval_shrlimm_base.
+- intros; TrivialExists.
+Qed.
+
+(** ** Multiplication *)
+
+Lemma eval_mullimm_base:
+ forall n, unary_constructor_sound (mullimm_base n) (fun x => Val.mull x (Vlong n)).
+Proof.
+ intros; red; intros; unfold mullimm_base.
+ assert (DFL: exists v, eval_expr ge sp e m le (Eop Omull (Eop (Olongconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mull x (Vlong n)) v).
+ { rewrite Val.mull_commut; TrivialExists. }
+ generalize (Int64.one_bits'_decomp n); generalize (Int64.one_bits'_range n);
+ destruct (Int64.one_bits' n) as [ | i [ | j []]]; intros P Q.
+- apply DFL.
+- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)).
+ apply eval_shllimm; auto.
+ simpl in Q. destruct x; auto; simpl. rewrite P by auto with coqlib.
+ rewrite Q, Int64.add_zero, Int64.shl'_mul. auto.
+- exploit (eval_shllimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]].
+ exploit (eval_shllimm j (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]].
+ exploit (eval_addl (x :: le)). eexact A1. eexact A2. intros [v [A B]].
+ exists v; split. econstructor; eauto.
+ simpl in Q. rewrite Q, Int64.add_zero. eapply Val.lessdef_trans; [|eexact B].
+ eapply Val.lessdef_trans; [|eapply Val.addl_lessdef; eauto].
+ destruct x; simpl; auto; rewrite ! P by auto with coqlib.
+ rewrite Int64.mul_add_distr_r, <- ! Int64.shl'_mul. auto.
+- apply DFL.
+Qed.
+
+Theorem eval_mullimm:
+ forall n, unary_constructor_sound (mullimm n) (fun x => Val.mull x (Vlong n)).
+Proof.
+ intros; red; intros until x; unfold mullimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ intros. exists (Vlong Int64.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int64.mul_zero. auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.one.
+ intros. exists x; split; auto.
+ destruct x; simpl; auto. subst n. rewrite Int64.mul_one. auto.
+ case (mullimm_match a); intros; InvEval; subst.
+- TrivialExists. simpl. rewrite Int64.mul_commut; auto.
+- rewrite Val.mull_addl_distr_l.
+ exploit eval_mullimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]].
+ exploit (eval_addlimm (Int64.mul n n2) le (mullimm_base n t2) v'). auto. intros [v'' [A2 B2]].
+ exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.addl_lessdef; eauto.
+ rewrite Val.mull_commut; auto.
+- apply eval_mullimm_base; auto.
+Qed.
+
+Theorem eval_mull: binary_constructor_sound mull Val.mull.
+Proof.
+ red; intros until y; unfold mull; case (mull_match a b); intros; InvEval; subst.
+- rewrite Val.mull_commut. apply eval_mullimm; auto.
+- apply eval_mullimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_mullhu:
+ forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
+Proof.
+ unfold mullhu; red; intros; TrivialExists.
+Qed.
+
+Theorem eval_mullhs:
+ forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
+Proof.
+ unfold mullhs; red; intros; TrivialExists.
+Qed.
+
+(** Integer conversions *)
+
+Theorem eval_zero_ext_l:
+ forall sz, 0 <= sz -> unary_constructor_sound (zero_ext_l sz) (Val.zero_ext_l sz).
+Proof.
+ intros; red; intros until x; unfold zero_ext_l; case (zero_ext_l_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- destruct (zlt (Int.unsigned a0) sz).
++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a64_range; simpl.
+ apply Val.lessdef_same. f_equal. rewrite Int64.shl'_zero_ext by omega. f_equal. omega.
++ TrivialExists.
+- TrivialExists.
+Qed.
+
+(** Bitwise not, and, or, xor *)
+
+Theorem eval_notl: unary_constructor_sound notl Val.notl.
+Proof.
+ assert (INV: forall v, Val.lessdef (Val.notl (Val.notl v)) v).
+ { destruct v; auto. simpl; rewrite Int64.not_involutive; auto. }
+ unfold notl; red; intros until x; case (notl_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- exists v1; auto.
+- exists (eval_shiftl s v1 a0); split; auto. EvalOp.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ rewrite Int64.not_and_or_not, Int64.not_involutive, Int64.or_commut. auto.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ rewrite Int64.not_or_and_not, Int64.not_involutive, Int64.and_commut. auto.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ unfold Int64.not; rewrite ! Int64.xor_assoc. auto.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ unfold Int64.not; rewrite ! Int64.xor_assoc, Int64.xor_idem, Int64.xor_zero. auto.
+- TrivialExists.
+Qed.
+
+Lemma eval_andlimm_base:
+ forall n, unary_constructor_sound (andlimm_base n) (fun x => Val.andl x (Vlong n)).
+Proof.
+ intros; red; intros. unfold andlimm_base.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ exists (Vlong Int64.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int64.and_zero. auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ exists x; split; auto.
+ subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto.
+ destruct (Z_is_power2m1 (Int64.unsigned n)) as [s|] eqn:P.
+ assert (0 <= s) by (eapply Z_is_power2m1_nonneg; eauto).
+ rewrite <- (Int64.repr_unsigned n), (Z_is_power2m1_sound _ _ P), <- Val.zero_ext_andl by auto.
+ apply eval_zero_ext_l; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_andlimm:
+ forall n, unary_constructor_sound (andlimm n) (fun x => Val.andl x (Vlong n)).
+Proof.
+ intros; red; intros until x. unfold andlimm.
+ case (andlimm_match a); intros; InvEval; subst.
+- rewrite Int64.and_commut; TrivialExists.
+- rewrite Val.andl_assoc, Int64.and_commut. apply eval_andlimm_base; auto.
+- destruct (zle 0 s).
++ replace (Val.zero_ext_l s v1) with (Val.andl v1 (Vlong (Int64.repr (two_p s - 1)))).
+ rewrite Val.andl_assoc, Int64.and_commut.
+ apply eval_andlimm_base; auto.
+ destruct v1; simpl; auto. rewrite Int64.zero_ext_and by auto. auto.
++ apply eval_andlimm_base. EvalOp.
+- apply eval_andlimm_base; auto.
+Qed.
+
+Theorem eval_andl: binary_constructor_sound andl Val.andl.
+Proof.
+ red; intros until y; unfold andl; case (andl_match a b); intros; InvEval; subst.
+- rewrite Val.andl_commut; apply eval_andlimm; auto.
+- apply eval_andlimm; auto.
+- rewrite Val.andl_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.andl_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.andl_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_orlimm:
+ forall n, unary_constructor_sound (orlimm n) (fun x => Val.orl x (Vlong n)).
+Proof.
+ intros; red; intros until x. unfold orlimm.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ intros. subst. exists x; split; auto.
+ destruct x; simpl; auto. rewrite Int64.or_zero; auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ intros. exists (Vlong Int64.mone); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int64.or_mone. auto.
+ destruct (orlimm_match a); intros; InvEval; subst.
+- rewrite Int64.or_commut; TrivialExists.
+- rewrite Val.orl_assoc, Int64.or_commut; TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_orl: binary_constructor_sound orl Val.orl.
+Proof.
+ red; intros until y; unfold orl; case (orl_match a b); intros; InvEval; subst.
+- rewrite Val.orl_commut. apply eval_orlimm; auto.
+- apply eval_orlimm; auto.
+- rewrite Val.orl_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.orl_commut; TrivialExists.
+- TrivialExists.
+- (* shl - shru *)
+ destruct (Int.eq (Int.add a1 a2) Int64.iwordsize' && same_expr_pure t1 t2) eqn:?.
++ InvBooleans. apply Int.same_if_eq in H.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst.
+ econstructor; split. EvalOp.
+ destruct v0; simpl; auto. rewrite ! a64_range. simpl. rewrite <- Int64.or_ror'; auto using a64_range.
++ TrivialExists.
+- (* shru - shl *)
+ destruct (Int.eq (Int.add a2 a1) Int64.iwordsize' && same_expr_pure t1 t2) eqn:?.
++ InvBooleans. apply Int.same_if_eq in H.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst.
+ econstructor; split. EvalOp.
+ destruct v0; simpl; auto. rewrite ! a64_range. simpl.
+ rewrite Int64.or_commut, <- Int64.or_ror'; auto using a64_range.
++ TrivialExists.
+- rewrite Val.orl_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Lemma eval_xorlimm_base:
+ forall n, unary_constructor_sound (xorlimm_base n) (fun x => Val.xorl x (Vlong n)).
+Proof.
+ intros; red; intros. unfold xorlimm_base.
+ predSpec Int64.eq Int64.eq_spec n Int64.zero.
+ intros. exists x; split. auto.
+ destruct x; simpl; auto. subst n. rewrite Int64.xor_zero. auto.
+ predSpec Int64.eq Int64.eq_spec n Int64.mone.
+ subst n. change (Val.xorl x (Vlong Int64.mone)) with (Val.notl x). apply eval_notl; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_xorlimm:
+ forall n, unary_constructor_sound (xorlimm n) (fun x => Val.xorl x (Vlong n)).
+Proof.
+ intros; red; intros until x. unfold xorlimm.
+ destruct (xorlimm_match a); intros; InvEval; subst.
+- rewrite Int64.xor_commut; TrivialExists.
+- rewrite Val.xorl_assoc; simpl. rewrite (Int64.xor_commut n2). apply eval_xorlimm_base; auto.
+- apply eval_xorlimm_base; auto.
+Qed.
+
+Theorem eval_xorl: binary_constructor_sound xorl Val.xorl.
+Proof.
+ red; intros until y; unfold xorl; case (xorl_match a b); intros; InvEval; subst.
+- rewrite Val.xorl_commut; apply eval_xorlimm; auto.
+- apply eval_xorlimm; auto.
+- rewrite Val.xorl_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.xorl_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.xorl_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+(** ** Integer division and modulus *)
+
+Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls.
+Proof.
+ red; intros; unfold divls_base; TrivialExists.
+Qed.
+
+Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls.
+Proof.
+ red; intros; unfold modls_base, modl_aux.
+ exploit Val.modls_divls; eauto. intros (q & A & B). subst z.
+ TrivialExists. repeat (econstructor; eauto with evalexpr). exact A.
+Qed.
+
+Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu.
+Proof.
+ red; intros; unfold divlu_base; TrivialExists.
+Qed.
+
+Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu.
+Proof.
+ red; intros; unfold modlu_base, modl_aux.
+ exploit Val.modlu_divlu; eauto. intros (q & A & B). subst z.
+ TrivialExists. repeat (econstructor; eauto with evalexpr). exact A.
+Qed.
+
+Theorem eval_shrxlimm:
+ forall le a n x z,
+ eval_expr ge sp e m le a x ->
+ Val.shrxl x (Vint n) = Some z ->
+ exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold shrxlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. exists x; split; auto.
+ destruct x; simpl in H0; try discriminate.
+ change (Int.ltu Int.zero (Int.repr 63)) with true in H0; inv H0.
+ rewrite Int64.shrx'_zero. auto.
+- TrivialExists.
+Qed.
+
+(** General shifts *)
+
+Theorem eval_shll: binary_constructor_sound shll Val.shll.
+Proof.
+ red; intros until y; unfold shll; case (shll_match b); intros.
+ InvEval. apply eval_shllimm; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
+Proof.
+ red; intros until y; unfold shrl; case (shrl_match b); intros.
+ InvEval. apply eval_shrlimm; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
+Proof.
+ red; intros until y; unfold shrlu; case (shrlu_match b); intros.
+ InvEval. apply eval_shrluimm; auto.
+ TrivialExists.
+Qed.
+
+(** Comparisons *)
+
+Remark option_map_of_bool_inv: forall ov w,
+ option_map Val.of_bool ov = Some w -> Val.of_optbool ov = w.
+Proof.
+ intros. destruct ov; inv H; auto.
+Qed.
+
+Section COMP_IMM.
+
+Variable default: comparison -> int64 -> condition.
+Variable intsem: comparison -> int64 -> int64 -> bool.
+Variable sem: comparison -> val -> val -> option val.
+
+Hypothesis sem_int: forall c x y,
+ sem c (Vlong x) (Vlong y) = Some (Val.of_bool (intsem c x y)).
+Hypothesis sem_undef: forall c v,
+ sem c Vundef v = None.
+Hypothesis sem_eq: forall x y,
+ sem Ceq (Vlong x) (Vlong y) = Some (Val.of_bool (Int64.eq x y)).
+Hypothesis sem_ne: forall x y,
+ sem Cne (Vlong x) (Vlong y) = Some (Val.of_bool (negb (Int64.eq x y))).
+Hypothesis sem_default: forall c v n,
+ sem c v (Vlong n) = option_map Val.of_bool (eval_condition (default c n) (v :: nil) m).
+
+Lemma eval_complimm_default: forall le a x c n2 v,
+ sem c x (Vlong n2) = Some v ->
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le (Eop (Ocmp (default c n2)) (a:::Enil)) v.
+Proof.
+ intros. EvalOp. simpl. rewrite sem_default in H. apply option_map_of_bool_inv in H.
+ congruence.
+Qed.
+
+Lemma eval_complimm:
+ forall le c a n2 x v,
+ eval_expr ge sp e m le a x ->
+ sem c x (Vlong n2) = Some v ->
+ eval_expr ge sp e m le (complimm default intsem c a n2) v.
+Proof.
+ intros until x; unfold complimm; case (complimm_match c a); intros; InvEval; subst.
+- (* constant *)
+ rewrite sem_int in H0; inv H0. EvalOp. destruct (intsem c0 n1 n2); auto.
+- (* mask zero *)
+ predSpec Int64.eq Int64.eq_spec n2 Int64.zero.
++ subst n2. destruct v1; simpl in H0; rewrite ? sem_undef, ? sem_eq in H0; inv H0.
+ EvalOp.
++ eapply eval_complimm_default; eauto. EvalOp.
+- (* mask not zero *)
+ predSpec Int64.eq Int64.eq_spec n2 Int64.zero.
++ subst n2. destruct v1; simpl in H0; rewrite ? sem_undef, ? sem_ne in H0; inv H0.
+ EvalOp.
++ eapply eval_complimm_default; eauto. EvalOp.
+- (* default *)
+ eapply eval_complimm_default; eauto.
+Qed.
+
+Hypothesis sem_swap:
+ forall c x y, sem (swap_comparison c) x y = sem c y x.
+
+Lemma eval_complimm_swap:
+ forall le c a n2 x v,
+ eval_expr ge sp e m le a x ->
+ sem c (Vlong n2) x = Some v ->
+ eval_expr ge sp e m le (complimm default intsem (swap_comparison c) a n2) v.
+Proof.
+ intros. eapply eval_complimm; eauto. rewrite sem_swap; auto.
+Qed.
+
+End COMP_IMM.
+
+Theorem eval_cmpl:
+ forall c le a x b y v,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.cmpl c x y = Some v ->
+ eval_expr ge sp e m le (cmpl c a b) v.
+Proof.
+ intros until y; unfold cmpl; case (cmpl_match a b); intros; InvEval; subst.
+- apply eval_complimm_swap with (sem := Val.cmpl) (x := y); auto.
+ intros; unfold Val.cmpl; rewrite Val.swap_cmpl_bool; auto.
+- apply eval_complimm with (sem := Val.cmpl) (x := x); auto.
+- EvalOp. simpl. rewrite Val.swap_cmpl_bool. apply option_map_of_bool_inv in H1. congruence.
+- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence.
+- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence.
+Qed.
+
+Theorem eval_cmplu:
+ forall c le a x b y v,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.cmplu (Mem.valid_pointer m) c x y = Some v ->
+ eval_expr ge sp e m le (cmplu c a b) v.
+Proof.
+ intros until y; unfold cmplu; case (cmplu_match a b); intros; InvEval; subst.
+- apply eval_complimm_swap with (sem := Val.cmplu (Mem.valid_pointer m)) (x := y); auto.
+ intros; unfold Val.cmplu; rewrite Val.swap_cmplu_bool; auto.
+- apply eval_complimm with (sem := Val.cmplu (Mem.valid_pointer m)) (x := x); auto.
+- EvalOp. simpl. rewrite Val.swap_cmplu_bool. apply option_map_of_bool_inv in H1. congruence.
+- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence.
+- EvalOp. simpl. apply option_map_of_bool_inv in H1. congruence.
+Qed.
+
+
+(** Floating-point conversions *)
+
+Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_longuoffloat: partial_unary_constructor_sound longuoffloat Val.longuoffloat.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_floatoflongu: partial_unary_constructor_sound floatoflongu Val.floatoflongu.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_longuofsingle: partial_unary_constructor_sound longuofsingle Val.longuofsingle.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_singleoflongu: partial_unary_constructor_sound singleoflongu Val.singleoflongu.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+End CMCONSTR.
diff --git a/aarch64/SelectOp.vp b/aarch64/SelectOp.vp
new file mode 100644
index 00000000..f9e5a1c4
--- /dev/null
+++ b/aarch64/SelectOp.vp
@@ -0,0 +1,573 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Instruction selection for operators *)
+
+Require Import Coqlib Zbits.
+Require Import Compopts AST Integers Floats Builtins.
+Require Import Op CminorSel.
+
+Local Open Scope cminorsel_scope.
+
+(** "ror" shifted operands are not supported by arithmetic operations *)
+
+Definition arith_shift (s: shift) :=
+ match s with Sror => false | _ => true end.
+
+(** ** Constants **)
+
+Definition addrsymbol (id: ident) (ofs: ptrofs) :=
+ Eop (Oaddrsymbol id ofs) Enil.
+
+Definition addrstack (ofs: ptrofs) :=
+ Eop (Oaddrstack ofs) Enil.
+
+(** ** Integer addition *)
+
+Nondetfunction addimm (n: int) (e: expr) :=
+ if Int.eq n Int.zero then e else
+ match e with
+ | Eop (Ointconst m) Enil => Eop (Ointconst (Int.add n m)) Enil
+ | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil)
+ | _ => Eop (Oaddimm n) (e ::: Enil)
+ end.
+
+Nondetfunction add (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => addimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => addimm n2 t1
+ | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) =>
+ addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil))
+ | Eop (Oaddimm n1) (t1:::Enil), t2 =>
+ addimm n1 (Eop Oadd (t1:::t2:::Enil))
+ | t1, Eop (Oaddimm n2) (t2:::Enil) =>
+ addimm n2 (Eop Oadd (t1:::t2:::Enil))
+ | Eop (Oshift s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Oaddshift s a) (t2 ::: t1 ::: Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Oaddshift s a) (t1 ::: t2 ::: Enil)
+ | Eop Omul (t1:::t2:::Enil), t3 =>
+ Eop Omuladd (t3:::t1:::t2:::Enil)
+ | t1, Eop Omul (t2:::t3:::Enil) =>
+ Eop Omuladd (t1:::t2:::t3:::Enil)
+ | _, _ => Eop Oadd (e1:::e2:::Enil)
+ end.
+
+(** ** Opposite *)
+
+Nondetfunction negint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.neg n)) Enil
+ | Eop (Oshift s a) (t1:::Enil) ?? arith_shift s => Eop (Onegshift s a) (t1:::Enil)
+ | _ => Eop Oneg (e ::: Enil)
+ end.
+
+(** ** Integer and pointer subtraction *)
+
+Nondetfunction sub (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | t1, Eop (Ointconst n2) Enil =>
+ addimm (Int.neg n2) t1
+ | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) =>
+ addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil))
+ | Eop (Oaddimm n1) (t1:::Enil), t2 =>
+ addimm n1 (Eop Osub (t1:::t2:::Enil))
+ | t1, Eop (Oaddimm n2) (t2:::Enil) =>
+ addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil))
+ | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Osubshift s a) (t1:::t2::: Enil)
+ | t1, Eop Omul (t2:::t3:::Enil) =>
+ Eop Omulsub (t1:::t2:::t3:::Enil)
+ | _, _ => Eop Osub (e1:::e2:::Enil)
+ end.
+
+(** ** Immediate shift left *)
+
+Definition shlimm_base (e1: expr) (n: int) :=
+ Eop (Oshift Slsl (mk_amount32 n)) (e1 ::: Enil).
+
+Nondetfunction shlimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst (Int.shl n1 n)) Enil
+ | Eop (Oshift Slsl a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int.iwordsize
+ then shlimm_base t1 (Int.add a n)
+ else shlimm_base e1 n
+ | Eop (Ozext s) (t1:::Enil) =>
+ Eop (Oshlzext s (mk_amount32 n)) (t1:::Enil)
+ | Eop (Osext s) (t1:::Enil) =>
+ Eop (Oshlsext s (mk_amount32 n)) (t1:::Enil)
+ | Eop (Oshlzext s a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int.iwordsize
+ then Eop (Oshlzext s (mk_amount32 (Int.add a n))) (t1:::Enil)
+ else shlimm_base e1 n
+ | Eop (Oshlsext s a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int.iwordsize
+ then Eop (Oshlsext s (mk_amount32 (Int.add a n))) (t1:::Enil)
+ else shlimm_base e1 n
+ | _ =>
+ shlimm_base e1 n
+ end.
+
+(** ** Immediate shift right (logical) *)
+
+Definition shruimm_base (e1: expr) (n: int) :=
+ Eop (Oshift Slsr (mk_amount32 n)) (e1 ::: Enil).
+
+Nondetfunction shruimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst (Int.shru n1 n)) Enil
+ | Eop (Oshift Slsl a) (t1:::Enil) =>
+ if Int.ltu n a
+ then Eop (Oshlzext (Int.zwordsize - Int.unsigned a) (mk_amount32 (Int.sub a n))) (t1:::Enil)
+ else Eop (Ozextshr (mk_amount32 (Int.sub n a)) (Int.zwordsize - Int.unsigned n)) (t1:::Enil)
+ | Eop (Oshift Slsr a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int.iwordsize
+ then shruimm_base t1 (Int.add a n)
+ else shruimm_base e1 n
+ | Eop (Ozext s) (t1:::Enil) =>
+ if zlt (Int.unsigned n) s
+ then Eop (Ozextshr (mk_amount32 n) (s - Int.unsigned n)) (t1:::Enil)
+ else Eop (Ointconst Int.zero) Enil
+ | _ =>
+ shruimm_base e1 n
+ end.
+
+(** ** Immediate shift right (arithmetic) *)
+
+Definition shrimm_base (e1: expr) (n: int) :=
+ Eop (Oshift Sasr (mk_amount32 n)) (e1 ::: Enil).
+
+Nondetfunction shrimm (e1: expr) (n: int) :=
+ if Int.eq n Int.zero then
+ e1
+ else if negb (Int.ltu n Int.iwordsize) then
+ Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil)
+ else match e1 with
+ | Eop (Ointconst n1) Enil =>
+ Eop (Ointconst (Int.shr n1 n)) Enil
+ | Eop (Oshift Slsl a) (t1:::Enil) =>
+ if Int.ltu n a
+ then Eop (Oshlsext (Int.zwordsize - Int.unsigned a) (mk_amount32 (Int.sub a n))) (t1:::Enil)
+ else Eop (Osextshr (mk_amount32 (Int.sub n a)) (Int.zwordsize - Int.unsigned n)) (t1:::Enil)
+ | Eop (Oshift Sasr a) (t1:::Enil) =>
+ if Int.ltu (Int.add a n) Int.iwordsize
+ then shrimm_base t1 (Int.add a n)
+ else shrimm_base e1 n
+ | Eop (Osext s) (t1:::Enil) =>
+ if zlt (Int.unsigned n) s && zlt s Int.zwordsize
+ then Eop (Osextshr (mk_amount32 n) (s - Int.unsigned n)) (t1:::Enil)
+ else shrimm_base e1 n
+ | _ =>
+ shrimm_base e1 n
+ end.
+
+(** ** Integer multiply *)
+
+Definition mulimm_base (n1: int) (e2: expr) :=
+ match Int.one_bits n1 with
+ | i :: nil =>
+ shlimm e2 i
+ | i :: j :: nil =>
+ Elet e2 (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j))
+ | _ =>
+ Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil)
+ end.
+
+Nondetfunction mulimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil
+ else if Int.eq n1 Int.one then e2
+ else match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.mul n1 n2)) Enil
+ | Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.mul n1 n2) (mulimm_base n1 t2)
+ | _ => mulimm_base n1 e2
+ end.
+
+Nondetfunction mul (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => mulimm n2 t1
+ | _, _ => Eop Omul (e1:::e2:::Enil)
+ end.
+
+Definition mulhs (e1: expr) (e2: expr) :=
+ Eop Olowlong
+ (Eop (Oshiftl Sasr (mk_amount64 (Int.repr 32)))
+ (Eop Omull (Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e1 ::: Enil) :::
+ Eop (Oextend Xsgn32 (mk_amount64 Int.zero)) (e2 ::: Enil) ::: Enil) ::: Enil)
+ ::: Enil).
+
+Definition mulhu (e1: expr) (e2: expr) :=
+ Eop Olowlong
+ (Eop (Oshiftl Slsr (mk_amount64 (Int.repr 32)))
+ (Eop Omull (Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e1 ::: Enil) :::
+ Eop (Oextend Xuns32 (mk_amount64 Int.zero)) (e2 ::: Enil) ::: Enil) ::: Enil)
+ ::: Enil).
+
+(** ** Integer conversions *)
+
+Nondetfunction zero_ext (sz: Z) (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.zero_ext sz n)) Enil
+ | Eop (Oshift Slsr a) (t1:::Enil) => Eop (Ozextshr a sz) (t1:::Enil)
+ | Eop (Oshift Slsl a) (t1:::Enil) =>
+ if zlt (Int.unsigned a) sz
+ then Eop (Oshlzext (sz - Int.unsigned a) a) (t1:::Enil)
+ else Eop (Ozext sz) (e:::Enil)
+ | _ => Eop (Ozext sz) (e:::Enil)
+ end.
+
+Nondetfunction sign_ext (sz: Z) (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.sign_ext sz n)) Enil
+ | Eop (Oshift Sasr a) (t1:::Enil) => Eop (Osextshr a sz) (t1:::Enil)
+ | Eop (Oshift Slsl a) (t1:::Enil) =>
+ if zlt (Int.unsigned a) sz
+ then Eop (Oshlsext (sz - Int.unsigned a) a) (t1:::Enil)
+ else Eop (Osext sz) (e:::Enil)
+ | _ => Eop (Osext sz) (e:::Enil)
+ end.
+
+Definition cast8unsigned (e: expr) := zero_ext 8 e.
+Definition cast8signed (e: expr) := sign_ext 8 e.
+Definition cast16unsigned (e: expr) := zero_ext 16 e.
+Definition cast16signed (e: expr) := sign_ext 16 e.
+
+(** ** Bitwise not *)
+
+Nondetfunction notint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ointconst (Int.not n)) Enil
+ | Eop (Oshift s a) (t1:::Enil) => Eop (Onotshift s a) (t1:::Enil)
+ | Eop Onot (t1:::Enil) => t1
+ | Eop (Onotshift s a) (t1:::Enil) => Eop (Oshift s a) (t1:::Enil)
+ | Eop Obic (t1:::t2:::Enil) => Eop Oorn (t2:::t1:::Enil)
+ | Eop Oorn (t1:::t2:::Enil) => Eop Obic (t2:::t1:::Enil)
+ | Eop Oxor (t1:::t2:::Enil) => Eop Oeqv (t1:::t2:::Enil)
+ | Eop Oeqv (t1:::t2:::Enil) => Eop Oxor (t1:::t2:::Enil)
+ | _ => Eop Onot (e:::Enil)
+ end.
+
+(** ** Bitwise and *)
+
+Definition andimm_base (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then Eop (Ointconst Int.zero) Enil else
+ if Int.eq n1 Int.mone then e2 else
+ match Z_is_power2m1 (Int.unsigned n1) with
+ | Some s => zero_ext s e2
+ | None => Eop (Oandimm n1) (e2 ::: Enil)
+ end.
+
+Nondetfunction andimm (n1: int) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.and n1 n2)) Enil
+ | Eop (Oandimm n2) (t2:::Enil) => andimm_base (Int.and n1 n2) t2
+ | Eop (Ozext s) (t2:::Enil) =>
+ if zle 0 s
+ then andimm_base (Int.and n1 (Int.repr (two_p s - 1))) t2
+ else andimm_base n1 e2
+ | _ => andimm_base n1 e2
+ end.
+
+Nondetfunction and (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => andimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => andimm n2 t1
+ | Eop Onot (t1:::Enil), t2 => Eop Obic (t2:::t1:::Enil)
+ | t1, Eop Onot (t2:::Enil) => Eop Obic (t1:::t2:::Enil)
+ | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Obicshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Obicshift s a) (t1:::t2:::Enil)
+ | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oandshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oandshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oand (e1:::e2:::Enil)
+ end.
+
+(** ** Bitwise or *)
+
+Nondetfunction orimm (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then e2
+ else if Int.eq n1 Int.mone then Eop (Ointconst Int.mone) Enil
+ else match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.or n1 n2)) Enil
+ | Eop (Oorimm n2) (t2:::Enil) => Eop (Oorimm (Int.or n1 n2)) (t2:::Enil)
+ | _ => Eop (Oorimm n1) (e2:::Enil)
+ end.
+
+Definition same_expr_pure (e1 e2: expr) :=
+ match e1, e2 with
+ | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false
+ | _, _ => false
+ end.
+
+Nondetfunction or (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => orimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => orimm n2 t1
+ | Eop Onot (t1:::Enil), t2 => Eop Oorn (t2:::t1:::Enil)
+ | t1, Eop Onot (t2:::Enil) => Eop Oorn (t1:::t2:::Enil)
+ | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Oornshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Oornshift s a) (t1:::t2:::Enil)
+ | Eop (Oshift Slsl a1) (t1:::Enil), Eop (Oshift Slsr a2) (t2:::Enil) =>
+ if Int.eq (Int.add a1 a2) Int.iwordsize && same_expr_pure t1 t2
+ then Eop (Oshift Sror a2) (t2:::Enil)
+ else Eop (Oorshift Slsr a2) (Eop (Oshift Slsl a1) (t1:::Enil):::t2:::Enil)
+ | Eop (Oshift Slsr a1) (t1:::Enil), Eop (Oshift Slsl a2) (t2:::Enil) =>
+ if Int.eq (Int.add a2 a1) Int.iwordsize && same_expr_pure t1 t2
+ then Eop (Oshift Sror a1) (t1:::Enil)
+ else Eop (Oorshift Slsl a2) (Eop (Oshift Slsr a1) (t1:::Enil):::t2:::Enil)
+ | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oorshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oorshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oor (e1:::e2:::Enil)
+ end.
+
+(** ** Bitwise xor *)
+
+Definition xorimm_base (n1: int) (e2: expr) :=
+ if Int.eq n1 Int.zero then e2 else
+ if Int.eq n1 Int.mone then notint e2 else
+ Eop (Oxorimm n1) (e2:::Enil).
+
+Nondetfunction xorimm (n1: int) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => Eop (Ointconst (Int.xor n1 n2)) Enil
+ | Eop (Oxorimm n2) (t2:::Enil) => xorimm_base (Int.xor n1 n2) t2
+ | _ => xorimm_base n1 e2
+ end.
+
+Nondetfunction xor (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 => xorimm n1 t2
+ | t1, Eop (Ointconst n2) Enil => xorimm n2 t1
+ | Eop Onot (t1:::Enil), t2 => Eop Oeqv (t2:::t1:::Enil)
+ | t1, Eop Onot (t2:::Enil) => Eop Oeqv (t1:::t2:::Enil)
+ | Eop (Onotshift s a) (t1:::Enil), t2 => Eop (Oeqvshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Onotshift s a) (t2:::Enil) => Eop (Oeqvshift s a) (t1:::t2:::Enil)
+ | Eop (Oshift s a) (t1:::Enil), t2 => Eop (Oxorshift s a) (t2:::t1:::Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) => Eop (Oxorshift s a) (t1:::t2:::Enil)
+ | _, _ => Eop Oxor (e1:::e2:::Enil)
+ end.
+
+(** ** Integer division and modulus *)
+
+Definition mod_aux (divop: operation) (e1 e2: expr) :=
+ Elet e1
+ (Elet (lift e2)
+ (Eop Omulsub (Eletvar 1 :::
+ Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) :::
+ Eletvar 0 :::
+ Enil))).
+
+Definition divs_base (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil).
+Definition mods_base := mod_aux Odiv.
+Definition divu_base (e1: expr) (e2: expr) := Eop Odivu (e1:::e2:::Enil).
+Definition modu_base := mod_aux Odivu.
+
+Definition shrximm (e1: expr) (n2: int) :=
+ if Int.eq n2 Int.zero then e1 else Eop (Oshrximm n2) (e1:::Enil).
+
+(** ** General shifts *)
+
+Nondetfunction shl (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shlimm e1 n2
+ | _ => Eop Oshl (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shr (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shrimm e1 n2
+ | _ => Eop Oshr (e1:::e2:::Enil)
+ end.
+
+Nondetfunction shru (e1: expr) (e2: expr) :=
+ match e2 with
+ | Eop (Ointconst n2) Enil => shruimm e1 n2
+ | _ => Eop Oshru (e1:::e2:::Enil)
+ end.
+
+(** ** Floating-point arithmetic *)
+
+Definition negf (e: expr) := Eop Onegf (e ::: Enil).
+Definition absf (e: expr) := Eop Oabsf (e ::: Enil).
+Definition addf (e1 e2: expr) := Eop Oaddf (e1 ::: e2 ::: Enil).
+Definition subf (e1 e2: expr) := Eop Osubf (e1 ::: e2 ::: Enil).
+Definition mulf (e1 e2: expr) := Eop Omulf (e1 ::: e2 ::: Enil).
+
+Definition negfs (e: expr) := Eop Onegfs (e ::: Enil).
+Definition absfs (e: expr) := Eop Oabsfs (e ::: Enil).
+Definition addfs (e1 e2: expr) := Eop Oaddfs (e1 ::: e2 ::: Enil).
+Definition subfs (e1 e2: expr) := Eop Osubfs (e1 ::: e2 ::: Enil).
+Definition mulfs (e1 e2: expr) := Eop Omulfs (e1 ::: e2 ::: Enil).
+
+(** ** Comparisons *)
+
+Nondetfunction compimm (default: comparison -> int -> condition)
+ (sem: comparison -> int -> int -> bool)
+ (c: comparison) (e1: expr) (n2: int) :=
+ match c, e1 with
+ | c, Eop (Ointconst n1) Enil =>
+ Eop (Ointconst (if sem c n1 n2 then Int.one else Int.zero)) Enil
+ | Ceq, Eop (Ocmp c) el =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp (negate_condition c)) el
+ else if Int.eq_dec n2 Int.one then
+ Eop (Ocmp c) el
+ else
+ Eop (Ointconst Int.zero) Enil
+ | Cne, Eop (Ocmp c) el =>
+ if Int.eq_dec n2 Int.zero then
+ Eop (Ocmp c) el
+ else if Int.eq_dec n2 Int.one then
+ Eop (Ocmp (negate_condition c)) el
+ else
+ Eop (Ointconst Int.one) Enil
+ | Ceq, Eop (Oandimm m) (t1:::Enil) =>
+ if Int.eq n2 Int.zero
+ then Eop (Ocmp (Cmaskzero m)) (t1:::Enil)
+ else Eop (Ocmp (default c n2)) (e1:::Enil)
+ | Cne, Eop (Oandimm m) (t1:::Enil) =>
+ if Int.eq n2 Int.zero
+ then Eop (Ocmp (Cmasknotzero m)) (t1:::Enil)
+ else Eop (Ocmp (default c n2)) (e1:::Enil)
+ | _, _ =>
+ Eop (Ocmp (default c n2)) (e1:::Enil)
+ end.
+
+Nondetfunction comp (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ compimm Ccompimm Int.cmp (swap_comparison c) t2 n1
+ | t1, Eop (Ointconst n2) Enil =>
+ compimm Ccompimm Int.cmp c t1 n2
+ | Eop (Oshift s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Ocmp (Ccompshift (swap_comparison c) s a)) (t2:::t1:::Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Ocmp (Ccompshift c s a)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil)
+ end.
+
+Nondetfunction compu (c: comparison) (e1: expr) (e2: expr) :=
+ match e1, e2 with
+ | Eop (Ointconst n1) Enil, t2 =>
+ compimm Ccompuimm Int.cmpu (swap_comparison c) t2 n1
+ | t1, Eop (Ointconst n2) Enil =>
+ compimm Ccompuimm Int.cmpu c t1 n2
+ | Eop (Oshift s a) (t1:::Enil), t2 ?? arith_shift s =>
+ Eop (Ocmp (Ccompushift (swap_comparison c) s a)) (t2:::t1:::Enil)
+ | t1, Eop (Oshift s a) (t2:::Enil) ?? arith_shift s =>
+ Eop (Ocmp (Ccompushift c s a)) (t1:::t2:::Enil)
+ | _, _ =>
+ Eop (Ocmp (Ccompu c)) (e1:::e2:::Enil)
+ end.
+
+Definition compf (c: comparison) (e1: expr) (e2: expr) :=
+ Eop (Ocmp (Ccompf c)) (e1:::e2:::Enil).
+
+Definition compfs (c: comparison) (e1: expr) (e2: expr) :=
+ Eop (Ocmp (Ccompfs c)) (e1:::e2:::Enil).
+
+(** ** Floating-point conversions *)
+
+Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil).
+Definition intuoffloat (e: expr) := Eop Ointuoffloat (e ::: Enil).
+
+Nondetfunction floatofintu (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil
+ | _ => Eop Ofloatofintu (e ::: Enil)
+ end.
+
+Nondetfunction floatofint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_int n)) Enil
+ | _ => Eop Ofloatofint (e ::: Enil)
+ end.
+
+Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil).
+Definition intuofsingle (e: expr) := Eop Ointuofsingle (e ::: Enil).
+
+Nondetfunction singleofint (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_int n)) Enil
+ | _ => Eop Osingleofint (e ::: Enil)
+ end.
+
+Nondetfunction singleofintu (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => Eop (Osingleconst (Float32.of_intu n)) Enil
+ | _ => Eop Osingleofintu (e ::: Enil)
+ end.
+
+Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
+Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil).
+
+(** ** Selection *)
+
+Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) :=
+ if match ty with
+ | Tint => true
+ | Tlong => true
+ | Tfloat => true
+ | Tsingle => true
+ | _ => false
+ end
+ then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args))
+ else None.
+
+(** ** Recognition of addressing modes for load and store operations *)
+
+Nondetfunction addressing (chunk: memory_chunk) (e: expr) :=
+ match e with
+ | Eop (Oaddrstack n) Enil => (Ainstack n, Enil)
+ | Eop (Oaddrsymbol id ofs) Enil => (Aglobal id ofs, Enil)
+ | Eop (Oaddlimm n) (e1:::Enil) => (Aindexed n, e1:::Enil)
+ | Eop (Oaddlshift Slsl a) (e1:::e2:::Enil) => (Aindexed2shift a, e1:::e2:::Enil)
+ | Eop (Oaddlext x a) (e1:::e2:::Enil) => (Aindexed2ext x a, e1:::e2:::Enil)
+ | Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil)
+ | _ => (Aindexed Int64.zero, e:::Enil)
+ end.
+
+(* floats *)
+Definition divf_base (e1: expr) (e2: expr) :=
+ Eop Odivf (e1 ::: e2 ::: Enil).
+
+Definition divfs_base (e1: expr) (e2: expr) :=
+ Eop Odivfs (e1 ::: e2 ::: Enil).
+
+(** ** Arguments of builtins *)
+
+Nondetfunction builtin_arg (e: expr) :=
+ match e with
+ | Eop (Ointconst n) Enil => BA_int n
+ | Eop (Olongconst n) Enil => BA_long n
+ | Eop (Oaddrsymbol id ofs) Enil => BA_addrglobal id ofs
+ | Eop (Oaddrstack ofs) Enil => BA_addrstack ofs
+ | Eload chunk (Ainstack ofs) Enil => BA_loadstack chunk ofs
+ | Eop (Oaddlimm n) (e1:::Enil) => BA_addptr (BA e1) (BA_long n)
+ | _ => BA e
+ end.
+
+(** Platform-specific known builtins *)
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ None.
diff --git a/aarch64/SelectOpproof.v b/aarch64/SelectOpproof.v
new file mode 100644
index 00000000..54c6a9fd
--- /dev/null
+++ b/aarch64/SelectOpproof.v
@@ -0,0 +1,1093 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness of instruction selection for operators *)
+
+Require Import Coqlib Zbits.
+Require Import AST Integers Floats Values Memory Builtins Globalenvs.
+Require Import Cminor Op CminorSel.
+Require Import SelectOp.
+Require Import OpHelpers OpHelpersproof.
+
+Local Open Scope cminorsel_scope.
+Local Transparent Archi.ptr64.
+
+(** * Useful lemmas and tactics *)
+
+(** The following are trivial lemmas and custom tactics that help
+ perform backward (inversion) and forward reasoning over the evaluation
+ of operator applications. *)
+
+Ltac EvalOp :=
+ eauto with evalexpr;
+ match goal with
+ | [ |- eval_expr _ _ _ _ _ _ _ ] => eapply eval_Eop; [EvalOp|try reflexivity; auto]
+ | [ |- eval_exprlist _ _ _ _ _ _ _ ] => econstructor; EvalOp
+ | _ => idtac
+ end.
+
+Ltac InvEval1 :=
+ match goal with
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] =>
+ inv H; InvEval1
+ | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] =>
+ inv H; InvEval1
+ | _ =>
+ idtac
+ end.
+
+Ltac InvEval2 :=
+ match goal with
+ | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] =>
+ simpl in H; inv H
+ | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] =>
+ simpl in H; FuncInv
+ | _ =>
+ idtac
+ end.
+
+Ltac InvEval := InvEval1; InvEval2; InvEval2.
+
+Ltac TrivialExists :=
+ match goal with
+ | [ |- exists v, _ /\ Val.lessdef ?a v ] => exists a; split; [EvalOp | auto]
+ end.
+
+(** * Correctness of the smart constructors *)
+
+Section CMCONSTR.
+Variable prog: program.
+Variable hf: helper_functions.
+Hypothesis HELPERS: helper_functions_declared prog hf.
+Let ge := Genv.globalenv prog.
+Variable sp: val.
+Variable e: env.
+Variable m: mem.
+
+(** We now show that the code generated by "smart constructor" functions
+ such as [Selection.notint] behaves as expected. Continuing the
+ [notint] example, we show that if the expression [e]
+ evaluates to some integer value [Vint n], then [Selection.notint e]
+ evaluates to a value [Vint (Int.not n)] which is indeed the integer
+ negation of the value of [e].
+
+ All proofs follow a common pattern:
+- Reasoning by case over the result of the classification functions
+ (such as [add_match] for integer addition), gathering additional
+ information on the shape of the argument expressions in the non-default
+ cases.
+- Inversion of the evaluations of the arguments, exploiting the additional
+ information thus gathered.
+- Equational reasoning over the arithmetic operations performed,
+ using the lemmas from the [Int] and [Float] modules.
+- Construction of an evaluation derivation for the expression returned
+ by the smart constructor.
+*)
+
+Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
+ forall le a x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.
+
+Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
+ forall le a x b y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.
+
+(** ** Constants *)
+
+Theorem eval_addrsymbol:
+ forall le id ofs,
+ exists v, eval_expr ge sp e m le (addrsymbol id ofs) v /\ Val.lessdef (Genv.symbol_address ge id ofs) v.
+Proof.
+ intros. unfold addrsymbol. TrivialExists.
+Qed.
+
+Theorem eval_addrstack:
+ forall le ofs,
+ exists v, eval_expr ge sp e m le (addrstack ofs) v /\ Val.lessdef (Val.offset_ptr sp ofs) v.
+Proof.
+ intros. unfold addrstack. TrivialExists.
+Qed.
+
+(** ** Addition, opposite, subtraction *)
+
+Theorem eval_addimm:
+ forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)).
+Proof.
+ red; unfold addimm; intros until x.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. intros. exists x; split; auto.
+ destruct x; simpl; auto. rewrite Int.add_zero; auto.
+- case (addimm_match a); intros; InvEval; simpl; TrivialExists; simpl.
++ rewrite Int.add_commut. auto.
++ subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto.
+Qed.
+
+Theorem eval_add: binary_constructor_sound add Val.add.
+Proof.
+ red; intros until y.
+ unfold add; case (add_match a b); intros; InvEval; subst.
+- rewrite Val.add_commut. apply eval_addimm; auto.
+- apply eval_addimm; auto.
+- replace (Val.add (Val.add v1 (Vint n1)) (Val.add v0 (Vint n2)))
+ with (Val.add (Val.add v1 v0) (Val.add (Vint n1) (Vint n2))).
+ apply eval_addimm. EvalOp.
+ repeat rewrite Val.add_assoc. decEq. apply Val.add_permut.
+- replace (Val.add (Val.add v1 (Vint n1)) y)
+ with (Val.add (Val.add v1 y) (Vint n1)).
+ apply eval_addimm. EvalOp.
+ repeat rewrite Val.add_assoc. decEq. apply Val.add_commut.
+- rewrite <- Val.add_assoc. apply eval_addimm. EvalOp.
+- rewrite Val.add_commut. TrivialExists.
+- TrivialExists.
+- rewrite Val.add_commut. TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_negint: unary_constructor_sound negint (fun v => Val.sub Vzero v).
+Proof.
+ red; intros until x; unfold negint. case (negint_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_sub: binary_constructor_sound sub Val.sub.
+Proof.
+ red; intros until y; unfold sub; case (sub_match a b); intros; InvEval; subst.
+- rewrite Val.sub_add_opp. apply eval_addimm; auto.
+- rewrite Val.sub_add_l. rewrite Val.sub_add_r.
+ rewrite Val.add_assoc. simpl. rewrite Int.add_commut. rewrite <- Int.sub_add_opp.
+ apply eval_addimm; EvalOp.
+- rewrite Val.sub_add_l. apply eval_addimm; EvalOp.
+- rewrite Val.sub_add_r. apply eval_addimm; EvalOp.
+- TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+(** ** Immediate shifts *)
+
+Remark eval_shlimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shlimm_base a n) (Val.shl x (Vint n)).
+Proof.
+Local Opaque mk_amount32.
+ unfold shlimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. auto.
+Qed.
+
+Theorem eval_shlimm:
+ forall n, unary_constructor_sound (fun a => shlimm a n)
+ (fun x => Val.shl x (Vint n)).
+Proof.
+ red; intros until x; unfold shlimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shl_zero; auto.
+- destruct (shlimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2.
+* econstructor; split. eapply eval_shlimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2.
+ rewrite Int.shl_shl; auto using a32_range.
+* econstructor; split; [|eauto]. apply eval_shlimm_base; auto. EvalOp.
++ TrivialExists. simpl. rewrite mk_amount32_eq; auto.
++ TrivialExists. simpl. rewrite mk_amount32_eq; auto.
++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2.
+* TrivialExists. simpl. rewrite mk_amount32_eq by auto.
+ destruct (Val.zero_ext s v1); simpl; auto.
+ rewrite a32_range; simpl; rewrite L, L2.
+ rewrite Int.shl_shl; auto using a32_range.
+* econstructor; split. eapply eval_shlimm_base; eauto. EvalOp; simpl; eauto. auto.
++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2.
+* TrivialExists. simpl. rewrite mk_amount32_eq by auto.
+ destruct (Val.sign_ext s v1); simpl; auto.
+ rewrite a32_range; simpl; rewrite L, L2.
+ rewrite Int.shl_shl; auto using a32_range.
+* econstructor; split. eapply eval_shlimm_base; eauto. EvalOp; simpl; eauto. auto.
++ econstructor; eauto using eval_shlimm_base.
+- intros; TrivialExists.
+Qed.
+
+Remark eval_shruimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shruimm_base a n) (Val.shru x (Vint n)).
+Proof.
+ unfold shruimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. auto.
+Qed.
+
+Remark sub_shift_amount:
+ forall y z,
+ Int.ltu y Int.iwordsize = true -> Int.ltu z Int.iwordsize = true -> Int.unsigned y <= Int.unsigned z ->
+ Int.ltu (Int.sub z y) Int.iwordsize = true.
+Proof.
+ intros. unfold Int.ltu; apply zlt_true. rewrite Int.unsigned_repr_wordsize.
+ apply Int.ltu_iwordsize_inv in H. apply Int.ltu_iwordsize_inv in H0.
+ unfold Int.sub; rewrite Int.unsigned_repr. omega.
+ generalize Int.wordsize_max_unsigned; omega.
+Qed.
+
+Theorem eval_shruimm:
+ forall n, unary_constructor_sound (fun a => shruimm a n)
+ (fun x => Val.shru x (Vint n)).
+Proof.
+Local Opaque Int.zwordsize.
+ red; intros until x; unfold shruimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shru_zero; auto.
+- destruct (shruimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu n a) eqn:L2.
+* assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true).
+ { apply sub_shift_amount; auto using a32_range.
+ apply Int.ltu_inv in L2. omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto.
+ simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto.
+* assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true).
+ { apply sub_shift_amount; auto using a32_range.
+ unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto.
+ simpl. rewrite L. rewrite Int.shru_shl, L2 by auto using a32_range. auto.
++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2.
+* econstructor; split. eapply eval_shruimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2.
+ rewrite Int.shru_shru; auto using a32_range.
+* econstructor; split; [|eauto]. apply eval_shruimm_base; auto. EvalOp.
++ destruct (zlt (Int.unsigned n) s).
+* econstructor; split. EvalOp. rewrite mk_amount32_eq by auto.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ set (s' := s - Int.unsigned n).
+ replace s with (s' + Int.unsigned n) by (unfold s'; omega).
+ rewrite Int.shru_zero_ext. auto. unfold s'; omega.
+* econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ rewrite Int.shru_zero_ext_0 by omega. auto.
++ econstructor; eauto using eval_shruimm_base.
+- intros; TrivialExists.
+Qed.
+
+Remark eval_shrimm_base: forall le a n x,
+ eval_expr ge sp e m le a x ->
+ Int.ltu n Int.iwordsize = true ->
+ eval_expr ge sp e m le (shrimm_base a n) (Val.shr x (Vint n)).
+Proof.
+ unfold shrimm_base; intros; EvalOp. simpl. rewrite mk_amount32_eq by auto. auto.
+Qed.
+
+Theorem eval_shrimm:
+ forall n, unary_constructor_sound (fun a => shrimm a n)
+ (fun x => Val.shr x (Vint n)).
+Proof.
+ red; intros until x; unfold shrimm.
+ predSpec Int.eq Int.eq_spec n Int.zero; [| destruct (Int.ltu n Int.iwordsize) eqn:L]; simpl.
+- intros; subst. exists x; split; auto. destruct x; simpl; auto. rewrite Int.shr_zero; auto.
+- destruct (shrimm_match a); intros; InvEval; subst.
++ TrivialExists. simpl; rewrite L; auto.
++ destruct (Int.ltu n a) eqn:L2.
+* assert (L3: Int.ltu (Int.sub a n) Int.iwordsize = true).
+ { apply sub_shift_amount; auto using a32_range.
+ apply Int.ltu_inv in L2. omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto.
+ simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto.
+* assert (L3: Int.ltu (Int.sub n a) Int.iwordsize = true).
+ { apply sub_shift_amount; auto using a32_range.
+ unfold Int.ltu in L2. destruct zlt in L2; discriminate || omega. }
+ econstructor; split. EvalOp.
+ destruct v1; simpl; auto. rewrite mk_amount32_eq, L3, a32_range by auto.
+ simpl. rewrite L. rewrite Int.shr_shl, L2 by auto using a32_range. auto.
++ destruct (Int.ltu (Int.add a n) Int.iwordsize) eqn:L2.
+* econstructor; split. eapply eval_shrimm_base; eauto.
+ destruct v1; simpl; auto. rewrite a32_range; simpl. rewrite L, L2.
+ rewrite Int.shr_shr; auto using a32_range.
+* econstructor; split; [|eauto]. apply eval_shrimm_base; auto. EvalOp.
++ destruct (zlt (Int.unsigned n) s && zlt s Int.zwordsize) eqn:E.
+* InvBooleans. econstructor; split. EvalOp. rewrite mk_amount32_eq by auto.
+ destruct v1; simpl; auto. rewrite ! L; simpl.
+ set (s' := s - Int.unsigned n).
+ replace s with (s' + Int.unsigned n) by (unfold s'; omega).
+ rewrite Int.shr_sign_ext. auto. unfold s'; omega. unfold s'; omega.
+* econstructor; split; [|eauto]. apply eval_shrimm_base; auto. EvalOp.
++ econstructor; eauto using eval_shrimm_base.
+- intros; TrivialExists.
+Qed.
+
+(** ** Multiplication *)
+
+Lemma eval_mulimm_base:
+ forall n, unary_constructor_sound (mulimm_base n) (fun x => Val.mul x (Vint n)).
+Proof.
+ intros; red; intros; unfold mulimm_base.
+ assert (DFL: exists v, eval_expr ge sp e m le (Eop Omul (Eop (Ointconst n) Enil ::: a ::: Enil)) v /\ Val.lessdef (Val.mul x (Vint n)) v).
+ { rewrite Val.mul_commut; TrivialExists. }
+ generalize (Int.one_bits_decomp n); generalize (Int.one_bits_range n);
+ destruct (Int.one_bits n) as [ | i [ | j []]]; intros P Q.
+- apply DFL.
+- replace (Val.mul x (Vint n)) with (Val.shl x (Vint i)).
+ apply eval_shlimm; auto.
+ simpl in Q. rewrite <- Val.shl_mul, Q, Int.add_zero. simpl. rewrite P by auto with coqlib. auto.
+- exploit (eval_shlimm i (x :: le) (Eletvar 0) x). constructor; auto. intros [v1 [A1 B1]].
+ exploit (eval_shlimm j (x :: le) (Eletvar 0) x). constructor; auto. intros [v2 [A2 B2]].
+ exploit (eval_add (x :: le)). eexact A1. eexact A2. intros [v [A B]].
+ exists v; split. econstructor; eauto.
+ simpl in Q. rewrite Q, Int.add_zero.
+ replace (Vint (Int.add (Int.shl Int.one i) (Int.shl Int.one j)))
+ with (Val.add (Val.shl Vone (Vint i)) (Val.shl Vone (Vint j))).
+ rewrite Val.mul_add_distr_r.
+ repeat rewrite Val.shl_mul. eapply Val.lessdef_trans; [|eauto]. apply Val.add_lessdef; auto.
+ simpl. repeat rewrite P by auto with coqlib. auto.
+- apply DFL.
+Qed.
+
+Theorem eval_mulimm:
+ forall n, unary_constructor_sound (mulimm n) (fun x => Val.mul x (Vint n)).
+Proof.
+ intros; red; intros until x; unfold mulimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists (Vint Int.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.mul_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.one.
+ intros. exists x; split; auto.
+ destruct x; simpl; auto. subst n. rewrite Int.mul_one. auto.
+ case (mulimm_match a); intros; InvEval; subst.
+- TrivialExists. simpl. rewrite Int.mul_commut; auto.
+- rewrite Val.mul_add_distr_l.
+ exploit eval_mulimm_base; eauto. instantiate (1 := n). intros [v' [A1 B1]].
+ exploit (eval_addimm (Int.mul n n2) le (mulimm_base n t2) v'). auto. intros [v'' [A2 B2]].
+ exists v''; split; auto. eapply Val.lessdef_trans. eapply Val.add_lessdef; eauto.
+ rewrite Val.mul_commut; auto.
+- apply eval_mulimm_base; auto.
+Qed.
+
+Theorem eval_mul: binary_constructor_sound mul Val.mul.
+Proof.
+ red; intros until y; unfold mul; case (mul_match a b); intros; InvEval; subst.
+- rewrite Val.mul_commut. apply eval_mulimm; auto.
+- apply eval_mulimm; auto.
+- TrivialExists.
+Qed.
+
+Theorem eval_mulhs: binary_constructor_sound mulhs Val.mulhs.
+Proof.
+ unfold mulhs; red; intros. econstructor; split. EvalOp.
+ unfold eval_shiftl, eval_extend. rewrite ! mk_amount64_eq by auto.
+ destruct x; simpl; auto. destruct y; simpl; auto.
+ change (Int.ltu Int.zero Int64.iwordsize') with true; simpl.
+ rewrite ! Int64.shl'_zero.
+ change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
+ apply Val.lessdef_same. f_equal.
+ transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)).
+ unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity.
+ apply Int.same_bits_eq; intros n N.
+ change Int.zwordsize with 32 in *.
+ assert (N1: 0 <= n < 64) by omega.
+ rewrite Int64.bits_loword by auto.
+ rewrite Int64.bits_shr' by auto.
+ change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64.
+ rewrite zlt_true by omega.
+ rewrite Int.testbit_repr by auto.
+ unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega).
+ transitivity (Z.testbit (Int.signed i * Int.signed i0) (n + 32)).
+ rewrite Z.shiftr_spec by omega. auto.
+ apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr.
+ change Int64.zwordsize with 64; omega.
+Qed.
+
+Theorem eval_mulhu: binary_constructor_sound mulhu Val.mulhu.
+Proof.
+ unfold mulhu; red; intros. econstructor; split. EvalOp.
+ unfold eval_shiftl, eval_extend. rewrite ! mk_amount64_eq by auto.
+ destruct x; simpl; auto. destruct y; simpl; auto.
+ change (Int.ltu Int.zero Int64.iwordsize') with true; simpl.
+ rewrite ! Int64.shl'_zero.
+ change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
+ apply Val.lessdef_same. f_equal.
+ transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)).
+ unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity.
+ apply Int.same_bits_eq; intros n N.
+ change Int.zwordsize with 32 in *.
+ assert (N1: 0 <= n < 64) by omega.
+ rewrite Int64.bits_loword by auto.
+ rewrite Int64.bits_shru' by auto.
+ change (Int.unsigned (Int.repr 32)) with 32. change Int64.zwordsize with 64.
+ rewrite zlt_true by omega.
+ rewrite Int.testbit_repr by auto.
+ unfold Int64.mul. rewrite Int64.testbit_repr by (change Int64.zwordsize with 64; omega).
+ transitivity (Z.testbit (Int.unsigned i * Int.unsigned i0) (n + 32)).
+ rewrite Z.shiftr_spec by omega. auto.
+ apply Int64.same_bits_eqm. apply Int64.eqm_mult; apply Int64.eqm_unsigned_repr.
+ change Int64.zwordsize with 64; omega.
+Qed.
+
+(** Integer conversions *)
+
+Theorem eval_zero_ext:
+ forall sz, 0 <= sz -> unary_constructor_sound (zero_ext sz) (Val.zero_ext sz).
+Proof.
+ intros; red; intros until x; unfold zero_ext; case (zero_ext_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- destruct (zlt (Int.unsigned a0) sz).
++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl.
+ apply Val.lessdef_same. f_equal. rewrite Int.shl_zero_ext by omega. f_equal. omega.
++ TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_sign_ext:
+ forall sz, 0 < sz -> unary_constructor_sound (sign_ext sz) (Val.sign_ext sz).
+Proof.
+ intros; red; intros until x; unfold sign_ext; case (sign_ext_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- destruct (zlt (Int.unsigned a0) sz).
++ econstructor; split. EvalOp. destruct v1; simpl; auto. rewrite a32_range; simpl.
+ apply Val.lessdef_same. f_equal. rewrite Int.shl_sign_ext by omega. f_equal. omega.
++ TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8).
+Proof.
+ apply eval_sign_ext; omega.
+Qed.
+
+Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
+Proof.
+ apply eval_zero_ext; omega.
+Qed.
+
+Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
+Proof.
+ apply eval_sign_ext; omega.
+Qed.
+
+Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
+Proof.
+ apply eval_zero_ext; omega.
+Qed.
+
+(** Bitwise not, and, or, xor *)
+
+Theorem eval_notint: unary_constructor_sound notint Val.notint.
+Proof.
+ assert (INV: forall v, Val.lessdef (Val.notint (Val.notint v)) v).
+ { destruct v; auto. simpl; rewrite Int.not_involutive; auto. }
+ unfold notint; red; intros until x; case (notint_match a); intros; InvEval; subst.
+- TrivialExists.
+- TrivialExists.
+- exists v1; auto.
+- exists (eval_shift s v1 a0); split; auto. EvalOp.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ rewrite Int.not_and_or_not, Int.not_involutive, Int.or_commut. auto.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ rewrite Int.not_or_and_not, Int.not_involutive, Int.and_commut. auto.
+- econstructor; split. EvalOp.
+ rewrite ! Val.not_xor, Val.xor_assoc; auto.
+- econstructor; split. EvalOp.
+ destruct v1; simpl; auto; destruct v0; simpl; auto.
+ unfold Int.not; rewrite ! Int.xor_assoc, Int.xor_idem, Int.xor_zero. auto.
+- TrivialExists.
+Qed.
+
+Lemma eval_andimm_base:
+ forall n, unary_constructor_sound (andimm_base n) (fun x => Val.and x (Vint n)).
+Proof.
+ intros; red; intros. unfold andimm_base.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ exists (Vint Int.zero); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.and_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ exists x; split; auto.
+ subst. destruct x; simpl; auto. rewrite Int.and_mone; auto.
+ destruct (Z_is_power2m1 (Int.unsigned n)) as [s|] eqn:P.
+ assert (0 <= s) by (eapply Z_is_power2m1_nonneg; eauto).
+ rewrite <- (Int.repr_unsigned n), (Z_is_power2m1_sound _ _ P), <- Val.zero_ext_and by auto.
+ apply eval_zero_ext; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_andimm:
+ forall n, unary_constructor_sound (andimm n) (fun x => Val.and x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold andimm.
+ case (andimm_match a); intros; InvEval; subst.
+- rewrite Int.and_commut; TrivialExists.
+- rewrite Val.and_assoc, Int.and_commut. apply eval_andimm_base; auto.
+- destruct (zle 0 s).
++ rewrite Val.zero_ext_and, Val.and_assoc, Int.and_commut by auto.
+ apply eval_andimm_base; auto.
++ apply eval_andimm_base. EvalOp.
+- apply eval_andimm_base; auto.
+Qed.
+
+Theorem eval_and: binary_constructor_sound and Val.and.
+Proof.
+ red; intros until y; unfold and; case (and_match a b); intros; InvEval; subst.
+- rewrite Val.and_commut; apply eval_andimm; auto.
+- apply eval_andimm; auto.
+- rewrite Val.and_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.and_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.and_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_orimm:
+ forall n, unary_constructor_sound (orimm n) (fun x => Val.or x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold orimm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. subst. exists x; split; auto.
+ destruct x; simpl; auto. rewrite Int.or_zero; auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ intros. exists (Vint Int.mone); split. EvalOp.
+ destruct x; simpl; auto. subst n. rewrite Int.or_mone. auto.
+ destruct (orimm_match a); intros; InvEval; subst.
+- rewrite Int.or_commut; TrivialExists.
+- rewrite Val.or_assoc, Int.or_commut; TrivialExists.
+- TrivialExists.
+Qed.
+
+Remark eval_same_expr:
+ forall a1 a2 le v1 v2,
+ same_expr_pure a1 a2 = true ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ a1 = a2 /\ v1 = v2.
+Proof.
+ intros. destruct a1; try discriminate. destruct a2; try discriminate.
+ simpl in H; destruct (ident_eq i i0); inv H.
+ split. auto. inv H0; inv H1; congruence.
+Qed.
+
+Theorem eval_or: binary_constructor_sound or Val.or.
+Proof.
+ red; intros until y; unfold or; case (or_match a b); intros; InvEval; subst.
+- rewrite Val.or_commut. apply eval_orimm; auto.
+- apply eval_orimm; auto.
+- rewrite Val.or_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.or_commut; TrivialExists.
+- TrivialExists.
+- (* shl - shru *)
+ destruct (Int.eq (Int.add a1 a2) Int.iwordsize && same_expr_pure t1 t2) eqn:?.
++ InvBooleans. apply Int.same_if_eq in H.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst.
+ econstructor; split. EvalOp.
+ destruct v0; simpl; auto. rewrite ! a32_range. simpl. rewrite <- Int.or_ror; auto using a32_range.
++ TrivialExists.
+- (* shru - shl *)
+ destruct (Int.eq (Int.add a2 a1) Int.iwordsize && same_expr_pure t1 t2) eqn:?.
++ InvBooleans. apply Int.same_if_eq in H.
+ exploit eval_same_expr; eauto. intros [EQ1 EQ2]. subst.
+ econstructor; split. EvalOp.
+ destruct v0; simpl; auto. rewrite ! a32_range. simpl.
+ rewrite Int.or_commut, <- Int.or_ror; auto using a32_range.
++ TrivialExists.
+- rewrite Val.or_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Lemma eval_xorimm_base:
+ forall n, unary_constructor_sound (xorimm_base n) (fun x => Val.xor x (Vint n)).
+Proof.
+ intros; red; intros. unfold xorimm_base.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+ intros. exists x; split. auto.
+ destruct x; simpl; auto. subst n. rewrite Int.xor_zero. auto.
+ predSpec Int.eq Int.eq_spec n Int.mone.
+ subst n. rewrite <- Val.not_xor. apply eval_notint; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_xorimm:
+ forall n, unary_constructor_sound (xorimm n) (fun x => Val.xor x (Vint n)).
+Proof.
+ intros; red; intros until x. unfold xorimm.
+ destruct (xorimm_match a); intros; InvEval; subst.
+- rewrite Int.xor_commut; TrivialExists.
+- rewrite Val.xor_assoc; simpl. rewrite (Int.xor_commut n2). apply eval_xorimm_base; auto.
+- apply eval_xorimm_base; auto.
+Qed.
+
+Theorem eval_xor: binary_constructor_sound xor Val.xor.
+Proof.
+ red; intros until y; unfold xor; case (xor_match a b); intros; InvEval; subst.
+- rewrite Val.xor_commut; apply eval_xorimm; auto.
+- apply eval_xorimm; auto.
+- rewrite Val.xor_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.xor_commut; TrivialExists.
+- TrivialExists.
+- rewrite Val.xor_commut; TrivialExists.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+(** ** Integer division and modulus *)
+
+Theorem eval_divs_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.divs x y = Some z ->
+ exists v, eval_expr ge sp e m le (divs_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold divs_base; TrivialExists.
+Qed.
+
+Theorem eval_mods_base:
+ forall le a b x y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.mods x y = Some z ->
+ exists v, eval_expr ge sp e m le (mods_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold mods_base, mod_aux.
+ exploit Val.mods_divs; eauto. intros (q & A & B). subst z.
+ TrivialExists. repeat (econstructor; eauto with evalexpr). exact A.
+Qed.
+
+Theorem eval_divu_base:
+ forall le a x b y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.divu x y = Some z ->
+ exists v, eval_expr ge sp e m le (divu_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold divu_base; TrivialExists.
+Qed.
+
+Theorem eval_modu_base:
+ forall le a x b y z,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ Val.modu x y = Some z ->
+ exists v, eval_expr ge sp e m le (modu_base a b) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold modu_base, mod_aux.
+ exploit Val.modu_divu; eauto. intros (q & A & B). subst z.
+ TrivialExists. repeat (econstructor; eauto with evalexpr). exact A.
+Qed.
+
+Theorem eval_shrximm:
+ forall le a n x z,
+ eval_expr ge sp e m le a x ->
+ Val.shrx x (Vint n) = Some z ->
+ exists v, eval_expr ge sp e m le (shrximm a n) v /\ Val.lessdef z v.
+Proof.
+ intros; unfold shrximm.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. exists x; split; auto.
+ destruct x; simpl in H0; try discriminate.
+ change (Int.ltu Int.zero (Int.repr 31)) with true in H0; inv H0.
+ rewrite Int.shrx_zero by (compute; auto). auto.
+- TrivialExists.
+Qed.
+
+(** General shifts *)
+
+Theorem eval_shl: binary_constructor_sound shl Val.shl.
+Proof.
+ red; intros until y; unfold shl; case (shl_match b); intros.
+ InvEval. apply eval_shlimm; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_shr: binary_constructor_sound shr Val.shr.
+Proof.
+ red; intros until y; unfold shr; case (shr_match b); intros.
+ InvEval. apply eval_shrimm; auto.
+ TrivialExists.
+Qed.
+
+Theorem eval_shru: binary_constructor_sound shru Val.shru.
+Proof.
+ red; intros until y; unfold shru; case (shru_match b); intros.
+ InvEval. apply eval_shruimm; auto.
+ TrivialExists.
+Qed.
+
+(** Floating-point operations *)
+
+Theorem eval_negf: unary_constructor_sound negf Val.negf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_absf: unary_constructor_sound absf Val.absf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_addf: binary_constructor_sound addf Val.addf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_subf: binary_constructor_sound subf Val.subf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_mulf: binary_constructor_sound mulf Val.mulf.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_negfs: unary_constructor_sound negfs Val.negfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_absfs: unary_constructor_sound absfs Val.absfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_addfs: binary_constructor_sound addfs Val.addfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_subfs: binary_constructor_sound subfs Val.subfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_mulfs: binary_constructor_sound mulfs Val.mulfs.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Section COMP_IMM.
+
+Variable default: comparison -> int -> condition.
+Variable intsem: comparison -> int -> int -> bool.
+Variable sem: comparison -> val -> val -> val.
+
+Hypothesis sem_int: forall c x y, sem c (Vint x) (Vint y) = Val.of_bool (intsem c x y).
+Hypothesis sem_undef: forall c v, sem c Vundef v = Vundef.
+Hypothesis sem_eq: forall x y, sem Ceq (Vint x) (Vint y) = Val.of_bool (Int.eq x y).
+Hypothesis sem_ne: forall x y, sem Cne (Vint x) (Vint y) = Val.of_bool (negb (Int.eq x y)).
+Hypothesis sem_default: forall c v n, sem c v (Vint n) = Val.of_optbool (eval_condition (default c n) (v :: nil) m).
+
+Lemma eval_compimm:
+ forall le c a n2 x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (compimm default intsem c a n2) v
+ /\ Val.lessdef (sem c x (Vint n2)) v.
+Proof.
+ intros until x.
+ unfold compimm; case (compimm_match c a); intros; InvEval; subst.
+- (* constant *)
+ rewrite sem_int. TrivialExists. simpl. destruct (intsem c0 n1 n2); auto.
+- (* eq cmp *)
+ inv H. simpl in H5. inv H5.
+ destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists.
+ simpl. rewrite eval_negate_condition.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto.
+ rewrite sem_undef; auto.
+ destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists.
+ simpl. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_eq; auto.
+ rewrite sem_undef; auto.
+ exists (Vint Int.zero); split. EvalOp.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; rewrite sem_eq; rewrite Int.eq_false; auto.
+ rewrite sem_undef; auto.
+- (* ne cmp *)
+ inv H. simpl in H5. inv H5.
+ destruct (Int.eq_dec n2 Int.zero). subst n2. TrivialExists.
+ simpl. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto.
+ rewrite sem_undef; auto.
+ destruct (Int.eq_dec n2 Int.one). subst n2. TrivialExists.
+ simpl. rewrite eval_negate_condition. destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; simpl; rewrite sem_ne; auto.
+ rewrite sem_undef; auto.
+ exists (Vint Int.one); split. EvalOp.
+ destruct (eval_condition c0 vl m); simpl.
+ unfold Vtrue, Vfalse. destruct b; rewrite sem_ne; rewrite Int.eq_false; auto.
+ rewrite sem_undef; auto.
+- (* mask zero *)
+ predSpec Int.eq Int.eq_spec n2 Int.zero.
++ subst n2. econstructor; split. EvalOp. simpl.
+ destruct v1; simpl; try (rewrite sem_undef; auto).
+ rewrite sem_eq. destruct (Int.eq (Int.and i m0) Int.zero); auto.
++ TrivialExists. simpl. rewrite sem_default. auto.
+- (* mask not zero *)
+ predSpec Int.eq Int.eq_spec n2 Int.zero.
++ subst n2. econstructor; split. EvalOp. simpl.
+ destruct v1; simpl; try (rewrite sem_undef; auto).
+ rewrite sem_ne. destruct (Int.eq (Int.and i m0) Int.zero); auto.
++ TrivialExists. simpl. rewrite sem_default. auto.
+- (* default *)
+ TrivialExists. simpl. rewrite sem_default. auto.
+Qed.
+
+Hypothesis sem_swap:
+ forall c x y, sem (swap_comparison c) x y = sem c y x.
+
+Lemma eval_compimm_swap:
+ forall le c a n2 x,
+ eval_expr ge sp e m le a x ->
+ exists v, eval_expr ge sp e m le (compimm default intsem (swap_comparison c) a n2) v
+ /\ Val.lessdef (sem c (Vint n2) x) v.
+Proof.
+ intros. rewrite <- sem_swap. eapply eval_compimm; eauto.
+Qed.
+
+End COMP_IMM.
+
+Theorem eval_comp:
+ forall c, binary_constructor_sound (comp c) (Val.cmp c).
+Proof.
+ intros; red; intros until y. unfold comp; case (comp_match a b); intros; InvEval; subst.
+- eapply eval_compimm_swap; eauto.
+ intros. unfold Val.cmp. rewrite Val.swap_cmp_bool; auto.
+- eapply eval_compimm; eauto.
+- TrivialExists. simpl. rewrite Val.swap_cmp_bool. auto.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_compu:
+ forall c, binary_constructor_sound (compu c) (Val.cmpu (Mem.valid_pointer m) c).
+Proof.
+ intros; red; intros until y. unfold compu; case (compu_match a b); intros; InvEval; subst.
+- eapply eval_compimm_swap; eauto.
+ intros. unfold Val.cmpu. rewrite Val.swap_cmpu_bool; auto.
+- eapply eval_compimm; eauto.
+- TrivialExists. simpl. rewrite Val.swap_cmpu_bool. auto.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_compf:
+ forall c, binary_constructor_sound (compf c) (Val.cmpf c).
+Proof.
+ intros; red; intros. unfold compf. TrivialExists.
+Qed.
+
+Theorem eval_compfs:
+ forall c, binary_constructor_sound (compfs c) (Val.cmpfs c).
+Proof.
+ intros; red; intros. unfold compfs. TrivialExists.
+Qed.
+
+(** Floating-point conversions *)
+
+Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_floatofsingle: unary_constructor_sound floatofsingle Val.floatofsingle.
+Proof.
+ red; intros; TrivialExists.
+Qed.
+
+Theorem eval_intoffloat:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intoffloat x = Some y ->
+ exists v, eval_expr ge sp e m le (intoffloat a) v /\ Val.lessdef y v.
+Proof.
+ intros; TrivialExists.
+Qed.
+
+Theorem eval_floatofint:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.floatofint x = Some y ->
+ exists v, eval_expr ge sp e m le (floatofint a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold floatofint. case (floatofint_match a); intros; InvEval.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_intuoffloat:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intuoffloat x = Some y ->
+ exists v, eval_expr ge sp e m le (intuoffloat a) v /\ Val.lessdef y v.
+Proof.
+ intros; TrivialExists.
+Qed.
+
+Theorem eval_floatofintu:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.floatofintu x = Some y ->
+ exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold floatofintu. case (floatofintu_match a); intros; InvEval.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_intofsingle:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intofsingle x = Some y ->
+ exists v, eval_expr ge sp e m le (intofsingle a) v /\ Val.lessdef y v.
+Proof.
+ intros; TrivialExists.
+Qed.
+
+Theorem eval_singleofint:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.singleofint x = Some y ->
+ exists v, eval_expr ge sp e m le (singleofint a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold singleofint. case (singleofint_match a); intros; InvEval.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+Theorem eval_intuofsingle:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.intuofsingle x = Some y ->
+ exists v, eval_expr ge sp e m le (intuofsingle a) v /\ Val.lessdef y v.
+Proof.
+ intros; TrivialExists.
+Qed.
+
+Theorem eval_singleofintu:
+ forall le a x y,
+ eval_expr ge sp e m le a x ->
+ Val.singleofintu x = Some y ->
+ exists v, eval_expr ge sp e m le (singleofintu a) v /\ Val.lessdef y v.
+Proof.
+ intros until y; unfold singleofintu. case (singleofintu_match a); intros; InvEval.
+- TrivialExists.
+- TrivialExists.
+Qed.
+
+(** Selection *)
+
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select; intros.
+ destruct (match ty with Tint | Tlong | Tfloat | Tsingle => true | _ => false end); inv H.
+ rewrite <- H3; TrivialExists.
+Qed.
+
+(** Addressing modes *)
+
+Theorem eval_addressing:
+ forall le chunk a v b ofs,
+ eval_expr ge sp e m le a v ->
+ v = Vptr b ofs ->
+ match addressing chunk a with (mode, args) =>
+ exists vl,
+ eval_exprlist ge sp e m le args vl /\
+ eval_addressing ge sp mode vl = Some v
+ end.
+Proof.
+ intros until v. unfold addressing; case (addressing_match a); intros; InvEval.
+- econstructor; split. EvalOp. simpl; auto.
+- econstructor; split. EvalOp. simpl; auto.
+- econstructor; split. EvalOp. simpl.
+ destruct v1; try discriminate. rewrite <- H; auto.
+- econstructor; split. EvalOp. simpl. congruence.
+- econstructor; split. EvalOp. simpl. congruence.
+- econstructor; split. EvalOp. simpl. congruence.
+- econstructor; split. EvalOp. simpl. rewrite H0. simpl. rewrite Ptrofs.add_zero; auto.
+Qed.
+
+(** Builtins *)
+
+Theorem eval_builtin_arg:
+ forall a v,
+ eval_expr ge sp e m nil a v ->
+ CminorSel.eval_builtin_arg ge sp e m (builtin_arg a) v.
+Proof.
+ intros until v. unfold builtin_arg; case (builtin_arg_match a); intros; InvEval.
+- constructor.
+- constructor.
+- constructor.
+- constructor.
+- inv H. InvEval. simpl in H6. inv H6. constructor; auto.
+- subst v. repeat constructor; auto.
+- constructor; auto.
+Qed.
+
+Theorem eval_divf_base:
+ forall le a b x y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (divf_base a b) v /\ Val.lessdef (Val.divf x y) v.
+Proof.
+ intros; unfold divf_base.
+ TrivialExists.
+Qed.
+
+Theorem eval_divfs_base:
+ forall le a b x y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v.
+Proof.
+ intros; unfold divfs_base.
+ TrivialExists.
+Qed.
+
+(** Platform-specific known builtins *)
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros. discriminate.
+Qed.
+
+End CMCONSTR.
diff --git a/aarch64/Stacklayout.v b/aarch64/Stacklayout.v
new file mode 100644
index 00000000..86ba9f45
--- /dev/null
+++ b/aarch64/Stacklayout.v
@@ -0,0 +1,140 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Machine- and ABI-dependent layout information for activation records. *)
+
+Require Import Coqlib.
+Require Import AST Memory Separation.
+Require Import Bounds.
+
+Local Open Scope sep_scope.
+
+(** The general shape of activation records is as follows,
+ from bottom (lowest offsets) to top:
+- Space for outgoing arguments to function calls.
+- Back link to parent frame
+- Return address
+- Saved values of callee-save registers used by the function.
+- Local stack slots.
+- Space for the stack-allocated data declared in Cminor.
+
+The stack pointer is kept 16-aligned.
+*)
+
+Definition fe_ofs_arg := 0.
+
+Definition make_env (b: bounds) : frame_env :=
+ let olink := align (4 * b.(bound_outgoing)) 8 in (* back link *)
+ let oretaddr := olink + 8 in (* return address *)
+ let ocs := oretaddr + 8 in (* callee-saves *)
+ let ol := align (size_callee_save_area b ocs) 8 in (* locals *)
+ let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
+ let sz := align (ostkdata + b.(bound_stack_data)) 16 in
+ {| fe_size := sz;
+ fe_ofs_link := olink;
+ fe_ofs_retaddr := oretaddr;
+ fe_ofs_local := ol;
+ fe_ofs_callee_save := ocs;
+ fe_stack_data := ostkdata;
+ fe_used_callee_save := b.(used_callee_save) |}.
+
+Lemma frame_env_separated:
+ forall b sp m P,
+ let fe := make_env b in
+ m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
+ m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
+ ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
+ ** range sp (fe_ofs_link fe) (fe_ofs_link fe + size_chunk Mptr)
+ ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + size_chunk Mptr)
+ ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
+ ** P.
+Proof.
+Local Opaque Z.add Z.mul sepconj range.
+ intros; simpl.
+ set (olink := align (4 * b.(bound_outgoing)) 8).
+ set (oretaddr := olink + 8).
+ set (ocs := oretaddr + 8).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ change (size_chunk Mptr) with 8.
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= 4 * b.(bound_outgoing)) by omega.
+ assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega).
+ assert (olink + 8 <= oretaddr) by (unfold oretaddr; omega).
+ assert (oretaddr + 8 <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+(* Reorder as:
+ outgoing
+ back link
+ retaddr
+ callee-save
+ local *)
+ rewrite sep_swap12.
+ rewrite sep_swap23.
+ rewrite sep_swap34.
+ rewrite sep_swap45.
+(* Apply range_split and range_split2 repeatedly *)
+ unfold fe_ofs_arg.
+ apply range_split_2. fold olink; omega. omega.
+ apply range_split. omega.
+ apply range_split. omega.
+ apply range_split_2. fold ol. omega. omega.
+ apply range_drop_right with ostkdata. omega.
+ eapply sep_drop2. eexact H.
+Qed.
+
+Lemma frame_env_range:
+ forall b,
+ let fe := make_env b in
+ 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
+Proof.
+ intros; simpl.
+ set (olink := align (4 * b.(bound_outgoing)) 8).
+ set (oretaddr := olink + 8).
+ set (ocs := oretaddr + 8).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= 4 * b.(bound_outgoing)) by omega.
+ assert (4 * b.(bound_outgoing) <= olink) by (apply align_le; omega).
+ assert (olink + 8 <= oretaddr) by (unfold oretaddr; omega).
+ assert (oretaddr + 8 <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+ split. omega. apply align_le. omega.
+Qed.
+
+Lemma frame_env_aligned:
+ forall b,
+ let fe := make_env b in
+ (8 | fe_ofs_arg)
+ /\ (8 | fe_ofs_local fe)
+ /\ (8 | fe_stack_data fe)
+ /\ (align_chunk Mptr | fe_ofs_link fe)
+ /\ (align_chunk Mptr | fe_ofs_retaddr fe).
+Proof.
+ intros; simpl.
+ set (olink := align (4 * b.(bound_outgoing)) 8).
+ set (oretaddr := olink + 8).
+ set (ocs := oretaddr + 8).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ change (align_chunk Mptr) with 8.
+ split. apply Z.divide_0_r.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl.
+Qed.
diff --git a/aarch64/TargetPrinter.ml b/aarch64/TargetPrinter.ml
new file mode 100644
index 00000000..e54673dd
--- /dev/null
+++ b/aarch64/TargetPrinter.ml
@@ -0,0 +1,592 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Printing AArch64 assembly code in asm syntax *)
+
+open Printf
+open Camlcoq
+open Sections
+open AST
+open Asm
+open AisAnnot
+open PrintAsmaux
+open Fileinfo
+
+(* Recognition of FP numbers that are supported by the fmov #imm instructions:
+ "a normalized binary floating point encoding with 1 sign bit,
+ 4 bits of fraction and a 3-bit exponent"
+*)
+
+let is_immediate_float64 bits =
+ let exp = (Int64.(to_int (shift_right_logical bits 52)) land 0x7FF) - 1023 in
+ let mant = Int64.logand bits 0xF_FFFF_FFFF_FFFFL in
+ exp >= -3 && exp <= 4 && Int64.logand mant 0xF_0000_0000_0000L = mant
+
+let is_immediate_float32 bits =
+ let exp = (Int32.(to_int (shift_right_logical bits 23)) land 0xFF) - 127 in
+ let mant = Int32.logand bits 0x7F_FFFFl in
+ exp >= -3 && exp <= 4 && Int32.logand mant 0x78_0000l = mant
+
+(* Module containing the printing functions *)
+
+module Target : TARGET =
+ struct
+
+(* Basic printing functions *)
+
+ let comment = "//"
+
+ let symbol = elf_symbol
+ let symbol_offset = elf_symbol_offset
+ let label = elf_label
+
+ let print_label oc lbl = label oc (transl_label lbl)
+
+ let intsz oc (sz, n) =
+ match sz with X -> coqint64 oc n | W -> coqint oc n
+
+ let xreg_name = function
+ | X0 -> "x0" | X1 -> "x1" | X2 -> "x2" | X3 -> "x3"
+ | X4 -> "x4" | X5 -> "x5" | X6 -> "x6" | X7 -> "x7"
+ | X8 -> "x8" | X9 -> "x9" | X10 -> "x10" | X11 -> "x11"
+ | X12 -> "x12" | X13 -> "x13" | X14 -> "x14" | X15 -> "x15"
+ | X16 -> "x16" | X17 -> "x17" | X18 -> "x18" | X19 -> "x19"
+ | X20 -> "x20" | X21 -> "x21" | X22 -> "x22" | X23 -> "x23"
+ | X24 -> "x24" | X25 -> "x25" | X26 -> "x26" | X27 -> "x27"
+ | X28 -> "x28" | X29 -> "x29" | X30 -> "x30"
+
+ let wreg_name = function
+ | X0 -> "w0" | X1 -> "w1" | X2 -> "w2" | X3 -> "w3"
+ | X4 -> "w4" | X5 -> "w5" | X6 -> "w6" | X7 -> "w7"
+ | X8 -> "w8" | X9 -> "w9" | X10 -> "w10" | X11 -> "w11"
+ | X12 -> "w12" | X13 -> "w13" | X14 -> "w14" | X15 -> "w15"
+ | X16 -> "w16" | X17 -> "w17" | X18 -> "w18" | X19 -> "w19"
+ | X20 -> "w20" | X21 -> "w21" | X22 -> "w22" | X23 -> "w23"
+ | X24 -> "w24" | X25 -> "w25" | X26 -> "w26" | X27 -> "w27"
+ | X28 -> "w28" | X29 -> "w29" | X30 -> "w30"
+
+ let xreg0_name = function RR0 r -> xreg_name r | XZR -> "xzr"
+ let wreg0_name = function RR0 r -> wreg_name r | XZR -> "wzr"
+
+ let xregsp_name = function RR1 r -> xreg_name r | XSP -> "sp"
+ let wregsp_name = function RR1 r -> wreg_name r | XSP -> "wsp"
+
+ let dreg_name = function
+ | D0 -> "d0" | D1 -> "d1" | D2 -> "d2" | D3 -> "d3"
+ | D4 -> "d4" | D5 -> "d5" | D6 -> "d6" | D7 -> "d7"
+ | D8 -> "d8" | D9 -> "d9" | D10 -> "d10" | D11 -> "d11"
+ | D12 -> "d12" | D13 -> "d13" | D14 -> "d14" | D15 -> "d15"
+ | D16 -> "d16" | D17 -> "d17" | D18 -> "d18" | D19 -> "d19"
+ | D20 -> "d20" | D21 -> "d21" | D22 -> "d22" | D23 -> "d23"
+ | D24 -> "d24" | D25 -> "d25" | D26 -> "d26" | D27 -> "d27"
+ | D28 -> "d28" | D29 -> "d29" | D30 -> "d30" | D31 -> "d31"
+
+ let sreg_name = function
+ | D0 -> "s0" | D1 -> "s1" | D2 -> "s2" | D3 -> "s3"
+ | D4 -> "s4" | D5 -> "s5" | D6 -> "s6" | D7 -> "s7"
+ | D8 -> "s8" | D9 -> "s9" | D10 -> "s10" | D11 -> "s11"
+ | D12 -> "s12" | D13 -> "s13" | D14 -> "s14" | D15 -> "s15"
+ | D16 -> "s16" | D17 -> "s17" | D18 -> "s18" | D19 -> "s19"
+ | D20 -> "s20" | D21 -> "s21" | D22 -> "s22" | D23 -> "s23"
+ | D24 -> "s24" | D25 -> "s25" | D26 -> "s26" | D27 -> "s27"
+ | D28 -> "s28" | D29 -> "s29" | D30 -> "s30" | D31 -> "s31"
+
+ let xreg oc r = output_string oc (xreg_name r)
+ let wreg oc r = output_string oc (wreg_name r)
+ let ireg oc (sz, r) =
+ output_string oc (match sz with X -> xreg_name r | W -> wreg_name r)
+
+ let xreg0 oc r = output_string oc (xreg0_name r)
+ let wreg0 oc r = output_string oc (wreg0_name r)
+ let ireg0 oc (sz, r) =
+ output_string oc (match sz with X -> xreg0_name r | W -> wreg0_name r)
+
+ let xregsp oc r = output_string oc (xregsp_name r)
+ let iregsp oc (sz, r) =
+ output_string oc (match sz with X -> xregsp_name r | W -> wregsp_name r)
+
+ let dreg oc r = output_string oc (dreg_name r)
+ let sreg oc r = output_string oc (sreg_name r)
+ let freg oc (sz, r) =
+ output_string oc (match sz with D -> dreg_name r | S -> sreg_name r)
+
+ let preg_asm oc ty = function
+ | IR r -> if ty = Tint then wreg oc r else xreg oc r
+ | FR r -> if ty = Tsingle then sreg oc r else dreg oc r
+ | _ -> assert false
+
+ let preg_annot = function
+ | IR r -> xreg_name r
+ | FR r -> dreg_name r
+ | _ -> assert false
+
+(* Names of sections *)
+
+ let name_of_section = function
+ | Section_text -> ".text"
+ | Section_data i | Section_small_data i ->
+ if i then ".data" else common_section ()
+ | Section_const i | Section_small_const i ->
+ if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM"
+ | Section_string -> ".section .rodata"
+ | Section_literal -> ".section .rodata"
+ | Section_jumptable -> ".section .rodata"
+ | Section_debug_info _ -> ".section .debug_info,\"\",%progbits"
+ | Section_debug_loc -> ".section .debug_loc,\"\",%progbits"
+ | Section_debug_abbrev -> ".section .debug_abbrev,\"\",%progbits"
+ | Section_debug_line _ -> ".section .debug_line,\"\",%progbits"
+ | Section_debug_ranges -> ".section .debug_ranges,\"\",%progbits"
+ | Section_debug_str -> ".section .debug_str,\"MS\",%progbits,1"
+ | Section_user(s, wr, ex) ->
+ sprintf ".section \"%s\",\"a%s%s\",%%progbits"
+ s (if wr then "w" else "") (if ex then "x" else "")
+ | Section_ais_annotation -> sprintf ".section \"__compcert_ais_annotations\",\"\",@note"
+
+ let section oc sec =
+ fprintf oc " %s\n" (name_of_section sec)
+
+(* Associate labels to floating-point constants and to symbols. *)
+
+ let emit_constants oc lit =
+ if exists_constants () then begin
+ section oc lit;
+ if Hashtbl.length literal64_labels > 0 then
+ begin
+ fprintf oc " .balign 8\n";
+ Hashtbl.iter
+ (fun bf lbl -> fprintf oc "%a: .quad 0x%Lx\n" label lbl bf)
+ literal64_labels
+ end;
+ if Hashtbl.length literal32_labels > 0 then
+ begin
+ fprintf oc " .balign 4\n";
+ Hashtbl.iter
+ (fun bf lbl ->
+ fprintf oc "%a: .long 0x%lx\n" label lbl bf)
+ literal32_labels
+ end;
+ reset_literals ()
+ end
+
+(* Emit .file / .loc debugging directives *)
+
+ let print_file_line oc file line =
+ print_file_line oc comment file line
+
+(* Name of testable condition *)
+
+ let condition_name = function
+ | TCeq -> "eq"
+ | TCne -> "ne"
+ | TChs -> "hs"
+ | TClo -> "lo"
+ | TCmi -> "mi"
+ | TCpl -> "pl"
+ | TChi -> "hi"
+ | TCls -> "ls"
+ | TCge -> "ge"
+ | TClt -> "lt"
+ | TCgt -> "gt"
+ | TCle -> "le"
+
+(* Print an addressing mode *)
+
+ let addressing oc = function
+ | ADimm(base, n) -> fprintf oc "[%a, #%a]" xregsp base coqint64 n
+ | ADreg(base, r) -> fprintf oc "[%a, %a]" xregsp base xreg r
+ | ADlsl(base, r, n) -> fprintf oc "[%a, %a, lsl #%a]" xregsp base xreg r coqint n
+ | ADsxt(base, r, n) -> fprintf oc "[%a, %a, sxtw #%a]" xregsp base wreg r coqint n
+ | ADuxt(base, r, n) -> fprintf oc "[%a, %a, uxtw #%a]" xregsp base wreg r coqint n
+ | ADadr(base, id, ofs) -> fprintf oc "[%a, #:lo12:%a]" xregsp base symbol_offset (id, ofs)
+ | ADpostincr(base, n) -> fprintf oc "[%a], #%a" xregsp base coqint64 n
+
+(* Print a shifted operand *)
+ let shiftop oc = function
+ | SOnone -> ()
+ | SOlsl n -> fprintf oc ", lsl #%a" coqint n
+ | SOlsr n -> fprintf oc ", lsr #%a" coqint n
+ | SOasr n -> fprintf oc ", asr #%a" coqint n
+ | SOror n -> fprintf oc ", ror #%a" coqint n
+
+(* Print a sign- or zero-extended operand *)
+ let extendop oc = function
+ | EOsxtb n -> fprintf oc ", sxtb #%a" coqint n
+ | EOsxth n -> fprintf oc ", sxth #%a" coqint n
+ | EOsxtw n -> fprintf oc ", sxtw #%a" coqint n
+ | EOuxtb n -> fprintf oc ", uxtb #%a" coqint n
+ | EOuxth n -> fprintf oc ", uxth #%a" coqint n
+ | EOuxtw n -> fprintf oc ", uxtw #%a" coqint n
+ | EOuxtx n -> fprintf oc ", uxtx #%a" coqint n
+
+(* Printing of instructions *)
+ let print_instruction oc = function
+ (* Branches *)
+ | Pb lbl ->
+ fprintf oc " b %a\n" print_label lbl
+ | Pbc(c, lbl) ->
+ fprintf oc " b.%s %a\n" (condition_name c) print_label lbl
+ | Pbl(id, sg) ->
+ fprintf oc " bl %a\n" symbol id
+ | Pbs(id, sg) ->
+ fprintf oc " b %a\n" symbol id
+ | Pblr(r, sg) ->
+ fprintf oc " blr %a\n" xreg r
+ | Pbr(r, sg) ->
+ fprintf oc " br %a\n" xreg r
+ | Pret r ->
+ fprintf oc " ret %a\n" xreg r
+ | Pcbnz(sz, r, lbl) ->
+ fprintf oc " cbnz %a, %a\n" ireg (sz, r) print_label lbl
+ | Pcbz(sz, r, lbl) ->
+ fprintf oc " cbz %a, %a\n" ireg (sz, r) print_label lbl
+ | Ptbnz(sz, r, n, lbl) ->
+ fprintf oc " tbnz %a, #%a, %a\n" ireg (sz, r) coqint n print_label lbl
+ | Ptbz(sz, r, n, lbl) ->
+ fprintf oc " tbz %a, #%a, %a\n" ireg (sz, r) coqint n print_label lbl
+ (* Memory loads and stores *)
+ | Pldrw(rd, a) | Pldrw_a(rd, a) ->
+ fprintf oc " ldr %a, %a\n" wreg rd addressing a
+ | Pldrx(rd, a) | Pldrx_a(rd, a) ->
+ fprintf oc " ldr %a, %a\n" xreg rd addressing a
+ | Pldrb(sz, rd, a) ->
+ fprintf oc " ldrb %a, %a\n" wreg rd addressing a
+ | Pldrsb(sz, rd, a) ->
+ fprintf oc " ldrsb %a, %a\n" ireg (sz, rd) addressing a
+ | Pldrh(sz, rd, a) ->
+ fprintf oc " ldrh %a, %a\n" wreg rd addressing a
+ | Pldrsh(sz, rd, a) ->
+ fprintf oc " ldrsh %a, %a\n" ireg (sz, rd) addressing a
+ | Pldrzw(rd, a) ->
+ fprintf oc " ldr %a, %a\n" wreg rd addressing a
+ (* the upper 32 bits of Xrd are set to 0, performing zero-extension *)
+ | Pldrsw(rd, a) ->
+ fprintf oc " ldrsw %a, %a\n" xreg rd addressing a
+ | Pldp(rd1, rd2, a) ->
+ fprintf oc " ldp %a, %a, %a\n" xreg rd1 xreg rd2 addressing a
+ | Pstrw(rs, a) | Pstrw_a(rs, a) ->
+ fprintf oc " str %a, %a\n" wreg rs addressing a
+ | Pstrx(rs, a) | Pstrx_a(rs, a) ->
+ fprintf oc " str %a, %a\n" xreg rs addressing a
+ | Pstrb(rs, a) ->
+ fprintf oc " strb %a, %a\n" wreg rs addressing a
+ | Pstrh(rs, a) ->
+ fprintf oc " strh %a, %a\n" wreg rs addressing a
+ | Pstp(rs1, rs2, a) ->
+ fprintf oc " stp %a, %a, %a\n" xreg rs1 xreg rs2 addressing a
+ (* Integer arithmetic, immediate *)
+ | Paddimm(sz, rd, r1, n) ->
+ fprintf oc " add %a, %a, #%a\n" iregsp (sz, rd) iregsp (sz, r1) intsz (sz, n)
+ | Psubimm(sz, rd, r1, n) ->
+ fprintf oc " sub %a, %a, #%a\n" iregsp (sz, rd) iregsp (sz, r1) intsz (sz, n)
+ | Pcmpimm(sz, r1, n) ->
+ fprintf oc " cmp %a, #%a\n" ireg (sz, r1) intsz (sz, n)
+ | Pcmnimm(sz, r1, n) ->
+ fprintf oc " cmn %a, #%a\n" ireg (sz, r1) intsz (sz, n)
+ (* Move integer register *)
+ | Pmov(rd, r1) ->
+ fprintf oc " mov %a, %a\n" xregsp rd xregsp r1
+ (* Logical, immediate *)
+ | Pandimm(sz, rd, r1, n) ->
+ fprintf oc " and %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n)
+ | Peorimm(sz, rd, r1, n) ->
+ fprintf oc " eor %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n)
+ | Porrimm(sz, rd, r1, n) ->
+ fprintf oc " orr %a, %a, #%a\n" ireg (sz, rd) ireg0 (sz, r1) intsz (sz, n)
+ | Ptstimm(sz, r1, n) ->
+ fprintf oc " tst %a, #%a\n" ireg (sz, r1) intsz (sz, n)
+ (* Move wide immediate *)
+ | Pmovz(sz, rd, n, pos) ->
+ fprintf oc " movz %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos)
+ | Pmovn(sz, rd, n, pos) ->
+ fprintf oc " movn %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos)
+ | Pmovk(sz, rd, n, pos) ->
+ fprintf oc " movk %a, #%d, lsl #%d\n" ireg (sz, rd) (Z.to_int n) (Z.to_int pos)
+ (* PC-relative addressing *)
+ | Padrp(rd, id, ofs) ->
+ fprintf oc " adrp %a, %a\n" xreg rd symbol_offset (id, ofs)
+ | Paddadr(rd, r1, id, ofs) ->
+ fprintf oc " add %a, %a, #:lo12:%a\n" xreg rd xreg r1 symbol_offset (id, ofs)
+ (* Bit-field operations *)
+ | Psbfiz(sz, rd, r1, r, s) ->
+ fprintf oc " sbfiz %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s)
+ | Psbfx(sz, rd, r1, r, s) ->
+ fprintf oc " sbfx %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s)
+ | Pubfiz(sz, rd, r1, r, s) ->
+ fprintf oc " ubfiz %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s)
+ | Pubfx(sz, rd, r1, r, s) ->
+ fprintf oc " ubfx %a, %a, %a, %d\n" ireg (sz, rd) ireg (sz, r1) coqint r (Z.to_int s)
+ (* Integer arithmetic, shifted register *)
+ | Padd(sz, rd, r1, r2, s) ->
+ fprintf oc " add %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Psub(sz, rd, r1, r2, s) ->
+ fprintf oc " sub %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Pcmp(sz, r1, r2, s) ->
+ fprintf oc " cmp %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Pcmn(sz, r1, r2, s) ->
+ fprintf oc " cmn %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ (* Integer arithmetic, extending register *)
+ | Paddext(rd, r1, r2, x) ->
+ fprintf oc " add %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x
+ | Psubext(rd, r1, r2, x) ->
+ fprintf oc " sub %a, %a, %a%a\n" xregsp rd xregsp r1 wreg r2 extendop x
+ | Pcmpext(r1, r2, x) ->
+ fprintf oc " cmp %a, %a%a\n" xreg r1 wreg r2 extendop x
+ | Pcmnext(r1, r2, x) ->
+ fprintf oc " cmn %a, %a%a\n" xreg r1 wreg r2 extendop x
+ (* Logical, shifted register *)
+ | Pand(sz, rd, r1, r2, s) ->
+ fprintf oc " and %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Pbic(sz, rd, r1, r2, s) ->
+ fprintf oc " bic %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Peon(sz, rd, r1, r2, s) ->
+ fprintf oc " eon %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Peor(sz, rd, r1, r2, s) ->
+ fprintf oc " eor %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Porr(sz, rd, r1, r2, s) ->
+ fprintf oc " orr %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Porn(sz, rd, r1, r2, s) ->
+ fprintf oc " orn %a, %a, %a%a\n" ireg (sz, rd) ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ | Ptst(sz, r1, r2, s) ->
+ fprintf oc " tst %a, %a%a\n" ireg0 (sz, r1) ireg (sz, r2) shiftop s
+ (* Variable shifts *)
+ | Pasrv(sz, rd, r1, r2) ->
+ fprintf oc " asr %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ | Plslv(sz, rd, r1, r2) ->
+ fprintf oc " lsl %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ | Plsrv(sz, rd, r1, r2) ->
+ fprintf oc " lsr %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ | Prorv(sz, rd, r1, r2) ->
+ fprintf oc " ror %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ (* Bit operations *)
+ | Pcls(sz, rd, r1) ->
+ fprintf oc " cls %a, %a\n" ireg (sz, rd) ireg (sz, r1)
+ | Pclz(sz, rd, r1) ->
+ fprintf oc " clz %a, %a\n" ireg (sz, rd) ireg (sz, r1)
+ | Prev(sz, rd, r1) ->
+ fprintf oc " rev %a, %a\n" ireg (sz, rd) ireg (sz, r1)
+ | Prev16(sz, rd, r1) ->
+ fprintf oc " rev16 %a, %a\n" ireg (sz, rd) ireg (sz, r1)
+ (* Conditional data processing *)
+ | Pcsel(rd, r1, r2, c) ->
+ fprintf oc " csel %a, %a, %a, %s\n" xreg rd xreg r1 xreg r2 (condition_name c)
+ | Pcset(rd, c) ->
+ fprintf oc " cset %a, %s\n" xreg rd (condition_name c)
+ (* Integer multiply/divide *)
+ | Pmadd(sz, rd, r1, r2, r3) ->
+ fprintf oc " madd %a, %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) ireg0 (sz, r3)
+ | Pmsub(sz, rd, r1, r2, r3) ->
+ fprintf oc " msub %a, %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2) ireg0 (sz, r3)
+ | Psmulh(rd, r1, r2) ->
+ fprintf oc " smulh %a, %a, %a\n" xreg rd xreg r1 xreg r2
+ | Pumulh(rd, r1, r2) ->
+ fprintf oc " umulh %a, %a, %a\n" xreg rd xreg r1 xreg r2
+ | Psdiv(sz, rd, r1, r2) ->
+ fprintf oc " sdiv %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ | Pudiv(sz, rd, r1, r2) ->
+ fprintf oc " udiv %a, %a, %a\n" ireg (sz, rd) ireg (sz, r1) ireg (sz, r2)
+ (* Floating-point loads and stores *)
+ | Pldrs(rd, a) ->
+ fprintf oc " ldr %a, %a\n" sreg rd addressing a
+ | Pldrd(rd, a) | Pldrd_a(rd, a) ->
+ fprintf oc " ldr %a, %a\n" dreg rd addressing a
+ | Pstrs(rd, a) ->
+ fprintf oc " str %a, %a\n" sreg rd addressing a
+ | Pstrd(rd, a) | Pstrd_a(rd, a) ->
+ fprintf oc " str %a, %a\n" dreg rd addressing a
+ (* Floating-point move *)
+ | Pfmov(rd, r1) ->
+ fprintf oc " fmov %a, %a\n" dreg rd dreg r1
+ | Pfmovimmd(rd, f) ->
+ let d = camlint64_of_coqint (Floats.Float.to_bits f) in
+ if is_immediate_float64 d then
+ fprintf oc " fmov %a, #%.7f\n" dreg rd (Int64.float_of_bits d)
+ else begin
+ let lbl = label_literal64 d in
+ fprintf oc " adrp x16, %a\n" label lbl;
+ fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" dreg rd label lbl comment (Int64.float_of_bits d)
+ end
+ | Pfmovimms(rd, f) ->
+ let d = camlint_of_coqint (Floats.Float32.to_bits f) in
+ if is_immediate_float32 d then
+ fprintf oc " fmov %a, #%.7f\n" sreg rd (Int32.float_of_bits d)
+ else begin
+ let lbl = label_literal32 d in
+ fprintf oc " adrp x16, %a\n" label lbl;
+ fprintf oc " ldr %a, [x16, #:lo12:%a] %s %.18g\n" sreg rd label lbl comment (Int32.float_of_bits d)
+ end
+ | Pfmovi(D, rd, r1) ->
+ fprintf oc " fmov %a, %a\n" dreg rd xreg0 r1
+ | Pfmovi(S, rd, r1) ->
+ fprintf oc " fmov %a, %a\n" sreg rd wreg0 r1
+ (* Floating-point conversions *)
+ | Pfcvtds(rd, r1) ->
+ fprintf oc " fcvt %a, %a\n" dreg rd sreg r1
+ | Pfcvtsd(rd, r1) ->
+ fprintf oc " fcvt %a, %a\n" sreg rd dreg r1
+ | Pfcvtzs(isz, fsz, rd, r1) ->
+ fprintf oc " fcvtzs %a, %a\n" ireg (isz, rd) freg (fsz, r1)
+ | Pfcvtzu(isz, fsz, rd, r1) ->
+ fprintf oc " fcvtzu %a, %a\n" ireg (isz, rd) freg (fsz, r1)
+ | Pscvtf(fsz, isz, rd, r1) ->
+ fprintf oc " scvtf %a, %a\n" freg (fsz, rd) ireg (isz, r1)
+ | Pucvtf(fsz, isz, rd, r1) ->
+ fprintf oc " ucvtf %a, %a\n" freg (fsz, rd) ireg (isz, r1)
+ (* Floating-point arithmetic *)
+ | Pfabs(sz, rd, r1) ->
+ fprintf oc " fabs %a, %a\n" freg (sz, rd) freg (sz, r1)
+ | Pfneg(sz, rd, r1) ->
+ fprintf oc " fneg %a, %a\n" freg (sz, rd) freg (sz, r1)
+ | Pfsqrt(sz, rd, r1) ->
+ fprintf oc " fsqrt %a, %a\n" freg (sz, rd) freg (sz, r1)
+ | Pfadd(sz, rd, r1, r2) ->
+ fprintf oc " fadd %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2)
+ | Pfdiv(sz, rd, r1, r2) ->
+ fprintf oc " fdiv %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2)
+ | Pfmul(sz, rd, r1, r2) ->
+ fprintf oc " fmul %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2)
+ | Pfnmul(sz, rd, r1, r2) ->
+ fprintf oc " fnmul %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2)
+ | Pfsub(sz, rd, r1, r2) ->
+ fprintf oc " fsub %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2)
+ | Pfmadd(sz, rd, r1, r2, r3) ->
+ fprintf oc " fmadd %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3)
+ | Pfmsub(sz, rd, r1, r2, r3) ->
+ fprintf oc " fmsub %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3)
+ | Pfnmadd(sz, rd, r1, r2, r3) ->
+ fprintf oc " fnmadd %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3)
+ | Pfnmsub(sz, rd, r1, r2, r3) ->
+ fprintf oc " fnmsub %a, %a, %a, %a\n" freg (sz, rd) freg (sz, r1) freg (sz, r2) freg (sz, r3)
+ (* Floating-point comparison *)
+ | Pfcmp(sz, r1, r2) ->
+ fprintf oc " fcmp %a, %a\n" freg (sz, r1) freg (sz, r2)
+ | Pfcmp0(sz, r1) ->
+ fprintf oc " fcmp %a, #0.0\n" freg (sz, r1)
+ (* Floating-point conditional select *)
+ | Pfsel(rd, r1, r2, c) ->
+ fprintf oc " fcsel %a, %a, %a, %s\n" dreg rd dreg r1 dreg r2 (condition_name c)
+ (* No-op *)
+ | Pnop ->
+ fprintf oc " nop\n"
+ (* Pseudo-instructions expanded in Asmexpand *)
+ | Pallocframe(sz, linkofs) -> assert false
+ | Pfreeframe(sz, linkofs) -> assert false
+ | Pcvtx2w rd -> assert false
+ (* Pseudo-instructions not yet expanded *)
+ | Plabel lbl ->
+ fprintf oc "%a:\n" print_label lbl
+ | Ploadsymbol(rd, id) ->
+ fprintf oc " adrp %a, :got:%a\n" xreg rd symbol id;
+ fprintf oc " ldr %a, [%a, #:got_lo12:%a]\n" xreg rd xreg rd symbol id
+ | Pcvtsw2x(rd, r1) ->
+ fprintf oc " sxtw %a, %a\n" xreg rd wreg r1
+ | Pcvtuw2x(rd, r1) ->
+ fprintf oc " uxtw %a, %a\n" xreg rd wreg r1
+ | Pbtbl(r1, tbl) ->
+ let lbl = new_label() in
+ fprintf oc " adr x16, %a\n" label lbl;
+ fprintf oc " add x16, x16, %a, uxtw #2\n" wreg r1;
+ fprintf oc " br x16\n";
+ fprintf oc "%a:" label lbl;
+ List.iter (fun l -> fprintf oc " b %a\n" print_label l) tbl
+ | Pcfi_adjust sz ->
+ cfi_adjust oc (camlint_of_coqint sz)
+ | Pcfi_rel_offset ofs ->
+ cfi_rel_offset oc "lr" (camlint_of_coqint ofs)
+ | Pbuiltin(ef, args, res) ->
+ begin match ef with
+ | EF_annot(kind,txt, targs) ->
+ begin match (P.to_int kind) with
+ | 1 -> let annot = annot_text preg_annot "sp" (camlstring_of_coqstring txt) args in
+ fprintf oc "%s annotation: %S\n" comment annot
+ | 2 -> let lbl = new_label () in
+ fprintf oc "%a:\n" label lbl;
+ add_ais_annot lbl preg_annot "sp" (camlstring_of_coqstring txt) args
+ | _ -> assert false
+ end
+ | EF_debug(kind, txt, targs) ->
+ print_debug_info comment print_file_line preg_annot "sp" oc
+ (P.to_int kind) (extern_atom txt) args
+ | EF_inline_asm(txt, sg, clob) ->
+ fprintf oc "%s begin inline assembly\n\t" comment;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
+ fprintf oc "%s end inline assembly\n" comment
+ | _ ->
+ assert false
+ end
+
+ let get_section_names name =
+ let (text, lit) =
+ match C2C.atom_sections name with
+ | t :: l :: _ -> (t, l)
+ | _ -> (Section_text, Section_literal) in
+ text,lit,Section_jumptable
+
+ let print_align oc alignment =
+ fprintf oc " .balign %d\n" alignment
+
+ let print_jumptable oc jmptbl =
+ let print_tbl oc (lbl, tbl) =
+ fprintf oc "%a:\n" label lbl;
+ List.iter
+ (fun l -> fprintf oc " .long %a - %a\n"
+ print_label l label lbl)
+ tbl in
+ if !jumptables <> [] then
+ begin
+ section oc jmptbl;
+ fprintf oc " .balign 4\n";
+ List.iter (print_tbl oc) !jumptables;
+ jumptables := []
+ end
+
+ let print_fun_info = elf_print_fun_info
+
+ let print_optional_fun_info _ = ()
+
+ let print_var_info = elf_print_var_info
+
+ let print_comm_symb oc sz name align =
+ if C2C.atom_is_static name then
+ fprintf oc " .local %a\n" symbol name;
+ fprintf oc " .comm %a, %s, %d\n"
+ symbol name
+ (Z.to_string sz)
+ align
+
+ let print_instructions oc fn =
+ current_function_sig := fn.fn_sig;
+ List.iter (print_instruction oc) fn.fn_code
+
+(* Data *)
+
+ let address = ".quad"
+
+ let print_prologue oc =
+ if !Clflags.option_g then begin
+ section oc Section_text;
+ end
+
+ let print_epilogue oc =
+ if !Clflags.option_g then begin
+ Debug.compute_gnu_file_enum (fun f -> ignore (print_file oc f));
+ section oc Section_text;
+ end
+
+ let default_falignment = 2
+
+ let cfi_startproc oc = ()
+ let cfi_endproc oc = ()
+
+ end
+
+let sel_target () =
+ (module Target:TARGET)
diff --git a/aarch64/ValueAOp.v b/aarch64/ValueAOp.v
new file mode 100644
index 00000000..e0d98c85
--- /dev/null
+++ b/aarch64/ValueAOp.v
@@ -0,0 +1,319 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+Require Import Coqlib Compopts.
+Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import Op RTL ValueDomain.
+
+(** Value analysis for AArch64 operators *)
+
+Definition eval_static_shift (s: shift) (v: aval) (n: amount32) : aval :=
+ match s with
+ | Slsl => shl v (I n)
+ | Slsr => shru v (I n)
+ | Sasr => shr v (I n)
+ | Sror => ror v (I n)
+ end.
+
+Definition eval_static_shiftl (s: shift) (v: aval) (n: amount64) : aval :=
+ match s with
+ | Slsl => shll v (I n)
+ | Slsr => shrlu v (I n)
+ | Sasr => shrl v (I n)
+ | Sror => rorl v (I n)
+ end.
+
+Definition eval_static_extend (x: extension) (v: aval) (n: amount64) : aval :=
+ shll (match x with Xsgn32 => longofint v | Xuns32 => longofintu v end) (I n).
+
+Definition eval_static_condition (cond: condition) (vl: list aval): abool :=
+ match cond, vl with
+ | Ccomp c, v1 :: v2 :: nil => cmp_bool c v1 v2
+ | Ccompu c, v1 :: v2 :: nil => cmpu_bool c v1 v2
+ | Ccompimm c n, v1 :: nil => cmp_bool c v1 (I n)
+ | Ccompuimm c n, v1 :: nil => cmpu_bool c v1 (I n)
+ | Ccompshift c s a, v1 :: v2 :: nil => cmp_bool c v1 (eval_static_shift s v2 a)
+ | Ccompushift c s a, v1 :: v2 :: nil => cmpu_bool c v1 (eval_static_shift s v2 a)
+ | Cmaskzero m, v1 :: nil => maskzero v1 m
+ | Cmasknotzero m, v1 :: nil => cnot (maskzero v1 m)
+ | Ccompl c, v1 :: v2 :: nil => cmpl_bool c v1 v2
+ | Ccomplu c, v1 :: v2 :: nil => cmplu_bool c v1 v2
+ | Ccomplimm c n, v1 :: nil => cmpl_bool c v1 (L n)
+ | Ccompluimm c n, v1 :: nil => cmplu_bool c v1 (L n)
+ | Ccomplshift c s a, v1 :: v2 :: nil => cmpl_bool c v1 (eval_static_shiftl s v2 a)
+ | Ccomplushift c s a, v1 :: v2 :: nil => cmplu_bool c v1 (eval_static_shiftl s v2 a)
+ | Cmasklzero m, v1 :: nil => cmpl_bool Ceq (andl v1 (L m)) (L Int64.zero)
+ | Cmasklnotzero m, v1 :: nil => cmpl_bool Cne (andl v1 (L m)) (L Int64.zero)
+ | Ccompf c, v1 :: v2 :: nil => cmpf_bool c v1 v2
+ | Cnotcompf c, v1 :: v2 :: nil => cnot (cmpf_bool c v1 v2)
+ | Ccompfzero c, v1 :: nil => cmpf_bool c v1 (F Float.zero)
+ | Cnotcompfzero c, v1 :: nil => cnot (cmpf_bool c v1 (F Float.zero))
+ | Ccompfs c, v1 :: v2 :: nil => cmpfs_bool c v1 v2
+ | Cnotcompfs c, v1 :: v2 :: nil => cnot (cmpfs_bool c v1 v2)
+ | Ccompfszero c, v1 :: nil => cmpfs_bool c v1 (FS Float32.zero)
+ | Cnotcompfszero c, v1 :: nil => cnot (cmpfs_bool c v1 (FS Float32.zero))
+ | _, _ => Bnone
+ end.
+
+Definition eval_static_addressing (addr: addressing) (vl: list aval): aval :=
+ match addr, vl with
+ | Aindexed n, v1 :: nil => addl v1 (L n)
+ | Aindexed2, v1 :: v2 :: nil => addl v1 v2
+ | Aindexed2shift a, v1 :: v2 :: nil => addl v1 (shll v2 (I a))
+ | Aindexed2ext x a, v1 :: v2 :: nil => addl v1 (eval_static_extend x v2 a)
+ | Aglobal s ofs, nil => Ptr (Gl s ofs)
+ | Ainstack ofs, nil => Ptr (Stk ofs)
+ | _, _ => Vbot
+ end.
+
+Definition eval_static_operation (op: operation) (vl: list aval): aval :=
+ match op, vl with
+ | Omove, v1::nil => v1
+ | Ointconst n, nil => I n
+ | Olongconst n, nil => L n
+ | Ofloatconst n, nil => if propagate_float_constants tt then F n else ntop
+ | Osingleconst n, nil => if propagate_float_constants tt then FS n else ntop
+ | Oaddrsymbol id ofs, nil => Ptr (Gl id ofs)
+ | Oaddrstack ofs, nil => Ptr (Stk ofs)
+
+ | Oshift s a, v1::nil => eval_static_shift s v1 a
+ | Oadd, v1::v2::nil => add v1 v2
+ | Oaddshift s a, v1::v2::nil => add v1 (eval_static_shift s v2 a)
+ | Oaddimm n, v1::nil => add v1 (I n)
+ | Oneg, v1::nil => neg v1
+ | Onegshift s a, v1::nil => neg (eval_static_shift s v1 a)
+ | Osub, v1::v2::nil => sub v1 v2
+ | Osubshift s a, v1::v2::nil => sub v1 (eval_static_shift s v2 a)
+ | Omul, v1::v2::nil => mul v1 v2
+ | Omuladd, v1::v2::v3::nil => add v1 (mul v2 v3)
+ | Omulsub, v1::v2::v3::nil => sub v1 (mul v2 v3)
+ | Odiv, v1::v2::nil => divs v1 v2
+ | Odivu, v1::v2::nil => divu v1 v2
+ | Oand, v1::v2::nil => and v1 v2
+ | Oandshift s a, v1::v2::nil => and v1 (eval_static_shift s v2 a)
+ | Oandimm n, v1::nil => and v1 (I n)
+ | Oor, v1::v2::nil => or v1 v2
+ | Oorshift s a, v1::v2::nil => or v1 (eval_static_shift s v2 a)
+ | Oorimm n, v1::nil => or v1 (I n)
+ | Oxor, v1::v2::nil => xor v1 v2
+ | Oxorshift s a, v1::v2::nil => xor v1 (eval_static_shift s v2 a)
+ | Oxorimm n, v1::nil => xor v1 (I n)
+ | Onot, v1::nil => notint v1
+ | Onotshift s a, v1::nil => notint (eval_static_shift s v1 a)
+ | Obic, v1::v2::nil => and v1 (notint v2)
+ | Obicshift s a, v1::v2::nil => and v1 (notint (eval_static_shift s v2 a))
+ | Oorn, v1::v2::nil => or v1 (notint v2)
+ | Oornshift s a, v1::v2::nil => or v1 (notint (eval_static_shift s v2 a))
+ | Oeqv, v1::v2::nil => xor v1 (notint v2)
+ | Oeqvshift s a, v1::v2::nil => xor v1 (notint (eval_static_shift s v2 a))
+ | Oshl, v1::v2::nil => shl v1 v2
+ | Oshr, v1::v2::nil => shr v1 v2
+ | Oshru, v1::v2::nil => shru v1 v2
+ | Oshrximm n, v1::nil => shrx v1 (I n)
+ | Ozext s, v1::nil => zero_ext s v1
+ | Osext s, v1::nil => sign_ext s v1
+ | Oshlzext s a, v1::nil => shl (zero_ext s v1) (I a)
+ | Oshlsext s a, v1::nil => shl (sign_ext s v1) (I a)
+ | Ozextshr a s, v1::nil => zero_ext s (shru v1 (I a))
+ | Osextshr a s, v1::nil => sign_ext s (shr v1 (I a))
+
+ | Oshiftl s a, v1::nil => eval_static_shiftl s v1 a
+ | Oextend x a, v1::nil => eval_static_extend x v1 a
+ | Omakelong, v1::v2::nil => longofwords v1 v2
+ | Olowlong, v1::nil => loword v1
+ | Ohighlong, v1::nil => hiword v1
+ | Oaddl, v1::v2::nil => addl v1 v2
+ | Oaddlshift s a, v1::v2::nil => addl v1 (eval_static_shiftl s v2 a)
+ | Oaddlext x a, v1::v2::nil => addl v1 (eval_static_extend x v2 a)
+ | Oaddlimm n, v1::nil => addl v1 (L n)
+ | Onegl, v1::nil => negl v1
+ | Oneglshift s a, v1::nil => negl (eval_static_shiftl s v1 a)
+ | Osubl, v1::v2::nil => subl v1 v2
+ | Osublshift s a, v1::v2::nil => subl v1 (eval_static_shiftl s v2 a)
+ | Osublext x a, v1::v2::nil => subl v1 (eval_static_extend x v2 a)
+ | Omull, v1::v2::nil => mull v1 v2
+ | Omulladd, v1::v2::v3::nil => addl v1 (mull v2 v3)
+ | Omullsub, v1::v2::v3::nil => subl v1 (mull v2 v3)
+ | Omullhs, v1::v2::nil => mullhs v1 v2
+ | Omullhu, v1::v2::nil => mullhu v1 v2
+ | Odivl, v1::v2::nil => divls v1 v2
+ | Odivlu, v1::v2::nil => divlu v1 v2
+ | Oandl, v1::v2::nil => andl v1 v2
+ | Oandlshift s a, v1::v2::nil => andl v1 (eval_static_shiftl s v2 a)
+ | Oandlimm n, v1::nil => andl v1 (L n)
+ | Oorl, v1::v2::nil => orl v1 v2
+ | Oorlshift s a, v1::v2::nil => orl v1 (eval_static_shiftl s v2 a)
+ | Oorlimm n, v1::nil => orl v1 (L n)
+ | Oxorl, v1::v2::nil => xorl v1 v2
+ | Oxorlshift s a, v1::v2::nil => xorl v1 (eval_static_shiftl s v2 a)
+ | Oxorlimm n, v1::nil => xorl v1 (L n)
+ | Onotl, v1::nil => notl v1
+ | Onotlshift s a, v1::nil => notl (eval_static_shiftl s v1 a)
+ | Obicl, v1::v2::nil => andl v1 (notl v2)
+ | Obiclshift s a, v1::v2::nil => andl v1 (notl (eval_static_shiftl s v2 a))
+ | Oornl, v1::v2::nil => orl v1 (notl v2)
+ | Oornlshift s a, v1::v2::nil => orl v1 (notl (eval_static_shiftl s v2 a))
+ | Oeqvl, v1::v2::nil => xorl v1 (notl v2)
+ | Oeqvlshift s a, v1::v2::nil => xorl v1 (notl (eval_static_shiftl s v2 a))
+ | Oshll, v1::v2::nil => shll v1 v2
+ | Oshrl, v1::v2::nil => shrl v1 v2
+ | Oshrlu, v1::v2::nil => shrlu v1 v2
+ | Oshrlximm n, v1::nil => shrxl v1 (I n)
+ | Ozextl s, v1::nil => zero_ext_l s v1
+ | Osextl s, v1::nil => sign_ext_l s v1
+ | Oshllzext s a, v1::nil => shll (zero_ext_l s v1) (I a)
+ | Oshllsext s a, v1::nil => shll (sign_ext_l s v1) (I a)
+ | Ozextshrl a s, v1::nil => zero_ext_l s (shrlu v1 (I a))
+ | Osextshrl a s, v1::nil => sign_ext_l s (shrl v1 (I a))
+
+ | Onegf, v1::nil => negf v1
+ | Oabsf, v1::nil => absf v1
+ | Oaddf, v1::v2::nil => addf v1 v2
+ | Osubf, v1::v2::nil => subf v1 v2
+ | Omulf, v1::v2::nil => mulf v1 v2
+ | Odivf, v1::v2::nil => divf v1 v2
+
+ | Onegfs, v1::nil => negfs v1
+ | Oabsfs, v1::nil => absfs v1
+ | Oaddfs, v1::v2::nil => addfs v1 v2
+ | Osubfs, v1::v2::nil => subfs v1 v2
+ | Omulfs, v1::v2::nil => mulfs v1 v2
+ | Odivfs, v1::v2::nil => divfs v1 v2
+
+ | Osingleoffloat, v1::nil => singleoffloat v1
+ | Ofloatofsingle, v1::nil => floatofsingle v1
+ | Ointoffloat, v1::nil => intoffloat v1
+ | Ointuoffloat, v1::nil => intuoffloat v1
+ | Ofloatofint, v1::nil => floatofint v1
+ | Ofloatofintu, v1::nil => floatofintu v1
+ | Ointofsingle, v1::nil => intofsingle v1
+ | Ointuofsingle, v1::nil => intuofsingle v1
+ | Osingleofint, v1::nil => singleofint v1
+ | Osingleofintu, v1::nil => singleofintu v1
+ | Olongoffloat, v1::nil => longoffloat v1
+ | Olonguoffloat, v1::nil => longuoffloat v1
+ | Ofloatoflong, v1::nil => floatoflong v1
+ | Ofloatoflongu, v1::nil => floatoflongu v1
+ | Olongofsingle, v1::nil => longofsingle v1
+ | Olonguofsingle, v1::nil => longuofsingle v1
+ | Osingleoflong, v1::nil => singleoflong v1
+ | Osingleoflongu, v1::nil => singleoflongu v1
+
+ | Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2
+
+ | _, _ => Vbot
+ end.
+
+Section SOUNDNESS.
+
+Variable bc: block_classification.
+Variable ge: genv.
+Hypothesis GENV: genv_match bc ge.
+Variable sp: block.
+Hypothesis STACK: bc sp = BCstack.
+
+Ltac InvHyps :=
+ match goal with
+ | [H: None = Some _ |- _ ] => discriminate
+ | [H: Some _ = Some _ |- _] => inv H
+ | [H1: match ?vl with nil => _ | _ :: _ => _ end = Some _ ,
+ H2: list_forall2 _ ?vl _ |- _ ] => inv H2; InvHyps
+ | _ => idtac
+ end.
+
+Lemma eval_static_shift_sound: forall v av s n,
+ vmatch bc v av -> vmatch bc (eval_shift s v n) (eval_static_shift s av n).
+Proof.
+ intros. unfold eval_shift, eval_static_shift; destruct s; auto with va.
+Qed.
+
+Lemma eval_static_shiftl_sound: forall v av s n,
+ vmatch bc v av -> vmatch bc (eval_shiftl s v n) (eval_static_shiftl s av n).
+Proof.
+ intros. unfold eval_shiftl, eval_static_shiftl; destruct s; auto with va.
+Qed.
+
+Lemma eval_static_extend_sound: forall v av x n,
+ vmatch bc v av -> vmatch bc (eval_extend x v n) (eval_static_extend x av n).
+Proof.
+ intros. unfold eval_extend, eval_static_extend; destruct x; auto with va.
+Qed.
+
+Hint Resolve eval_static_shift_sound eval_static_shiftl_sound eval_static_extend_sound: va.
+
+Theorem eval_static_condition_sound:
+ forall cond vargs m aargs,
+ list_forall2 (vmatch bc) vargs aargs ->
+ cmatch (eval_condition cond vargs m) (eval_static_condition cond aargs).
+Proof.
+ intros until aargs; intros VM. inv VM.
+ destruct cond; auto with va.
+ inv H0.
+ destruct cond; simpl; eauto with va.
+ replace (Val.cmp_bool Ceq (Val.and a1 (Vint n)) (Vint Int.zero))
+ with (Val.maskzero_bool a1 n) by (destruct a1; auto).
+ eauto with va.
+ replace (Val.cmp_bool Cne (Val.and a1 (Vint n)) (Vint Int.zero))
+ with (option_map negb (Val.maskzero_bool a1 n)) by (destruct a1; auto).
+ eauto with va.
+ inv H2.
+ destruct cond; simpl; eauto with va.
+ destruct cond; auto with va.
+Qed.
+
+Lemma symbol_address_sound:
+ forall id ofs,
+ vmatch bc (Genv.symbol_address ge id ofs) (Ptr (Gl id ofs)).
+Proof.
+ intros; apply symbol_address_sound; apply GENV.
+Qed.
+
+Lemma symbol_address_sound_2:
+ forall id ofs,
+ vmatch bc (Genv.symbol_address ge id ofs) (Ifptr (Gl id ofs)).
+Proof.
+ intros. unfold Genv.symbol_address. destruct (Genv.find_symbol ge id) as [b|] eqn:F.
+ constructor. constructor. apply GENV; auto.
+ constructor.
+Qed.
+
+Hint Resolve symbol_address_sound symbol_address_sound_2: va.
+
+Theorem eval_static_addressing_sound:
+ forall addr vargs vres aargs,
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_addressing addr aargs).
+Proof.
+ unfold eval_addressing, eval_static_addressing; intros;
+ destruct addr; InvHyps; eauto with va.
+ rewrite Ptrofs.add_zero_l; eauto with va.
+Qed.
+
+Theorem eval_static_operation_sound:
+ forall op vargs m vres aargs,
+ eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ vmatch bc vres (eval_static_operation op aargs).
+Proof.
+ unfold eval_operation, eval_static_operation; intros;
+ destruct op; InvHyps; eauto with va.
+ destruct (propagate_float_constants tt); constructor.
+ destruct (propagate_float_constants tt); constructor.
+ rewrite Ptrofs.add_zero_l; eauto with va.
+ apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+ apply select_sound; eauto using eval_static_condition_sound.
+Qed.
+
+End SOUNDNESS.
+
diff --git a/aarch64/extractionMachdep.v b/aarch64/extractionMachdep.v
new file mode 100644
index 00000000..e82056e2
--- /dev/null
+++ b/aarch64/extractionMachdep.v
@@ -0,0 +1,24 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Additional extraction directives specific to the AArch64 port *)
+
+Require Archi Asm.
+
+(* Archi *)
+
+Extract Constant Archi.pic_code => "fun () -> false". (* for the time being *)
+
+(* Asm *)
+Extract Constant Asm.symbol_low => "fun _ _ _ -> assert false".
+Extract Constant Asm.symbol_high => "fun _ _ _ -> assert false".
+Extract Constant Asmgen.symbol_is_aligned => "C2C.atom_is_aligned".
diff --git a/arm/Archi.v b/arm/Archi.v
index 353731e0..16d6c71d 100644
--- a/arm/Archi.v
+++ b/arm/Archi.v
@@ -16,9 +16,9 @@
(** Architecture-dependent parameters for ARM *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
Definition ptr64 := false.
@@ -34,29 +34,57 @@ Proof.
unfold splitlong, ptr64; congruence.
Qed.
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (false, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (false, iter_nat 22 _ xO xH).
+
+(** Choose the first signaling NaN, if any;
+ otherwise choose the first NaN;
+ otherwise use default. *)
+
+Definition choose_nan (is_signaling: positive -> bool)
+ (default: bool * positive)
+ (l0: list (bool * positive)) : bool * positive :=
+ let fix choose_snan (l1: list (bool * positive)) :=
+ match l1 with
+ | nil =>
+ match l0 with nil => default | n :: _ => n end
+ | ((s, p) as n) :: l1 =>
+ if is_signaling p then n else choose_snan l1
+ end
+ in choose_snan l0.
+
+Lemma choose_nan_idem: forall is_signaling default n,
+ choose_nan is_signaling default (n :: n :: nil) =
+ choose_nan is_signaling default (n :: nil).
+Proof.
+ intros. destruct n as [s p]; unfold choose_nan; simpl.
+ destruct (is_signaling p); auto.
+Qed.
+
+Definition choose_nan_64 :=
+ choose_nan (fun p => negb (Pos.testbit p 51)) default_nan_64.
+
+Definition choose_nan_32 :=
+ choose_nan (fun p => negb (Pos.testbit p 22)) default_nan_32.
+
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. intros; apply choose_nan_idem. Qed.
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- (** Choose second NaN if pl2 is sNaN but pl1 is qNan.
- In all other cases, choose first NaN *)
- (Pos.testbit (proj1_sig pl1) 51 &&
- negb (Pos.testbit (proj1_sig pl2) 51))%bool.
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. intros; apply choose_nan_idem. Qed.
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (false, iter_nat 22 _ xO xH).
+Definition fma_order {A: Type} (x y z: A) := (z, x, y).
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- (** Choose second NaN if pl2 is sNaN but pl1 is qNan.
- In all other cases, choose first NaN *)
- (Pos.testbit (proj1_sig pl1) 22 &&
- negb (Pos.testbit (proj1_sig pl2) 22))%bool.
+Definition fma_invalid_mul_is_nan := true.
Definition float_of_single_preserves_sNaN := false.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
float_of_single_preserves_sNaN.
(** Which ABI to use: either the standard ARM EABI with floats passed
diff --git a/arm/Asm.v b/arm/Asm.v
index e6d1b4fc..194074ac 100644
--- a/arm/Asm.v
+++ b/arm/Asm.v
@@ -220,6 +220,7 @@ Inductive instruction : Type :=
| Plabel: label -> instruction (**r define a code label *)
| Ploadsymbol: ireg -> ident -> ptrofs -> instruction (**r load the address of a symbol *)
| Pmovite: testcond -> ireg -> shift_op -> shift_op -> instruction (**r integer conditional move *)
+ | Pfmovite: testcond -> freg -> freg -> freg -> instruction (**r FP conditional move *)
| Pbtbl: ireg -> list label -> instruction (**r N-way branch through a jump table *)
| Pbuiltin: external_function -> list (builtin_arg preg) -> builtin_res preg -> instruction (**r built-in function (pseudo) *)
| Padc: ireg -> ireg -> shift_op -> instruction (**r add with carry *)
@@ -783,6 +784,14 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out
| None => Vundef
end in
Next (nextinstr (rs#r1 <- v)) m
+ | Pfmovite cond r1 ifso ifnot =>
+ let v :=
+ match eval_testcond cond rs with
+ | Some true => rs#ifso
+ | Some false => rs#ifnot
+ | None => Vundef
+ end in
+ Next (nextinstr (rs#r1 <- v)) m
| Pbtbl r tbl =>
match rs#r with
| Vint n =>
diff --git a/arm/AsmToJSON.ml b/arm/AsmToJSON.ml
index 3874e141..e850fed6 100644
--- a/arm/AsmToJSON.ml
+++ b/arm/AsmToJSON.ml
@@ -19,21 +19,25 @@ open BinNums
open Camlcoq
open Json
-let mnemonic_names = [ "Padc"; "Padd"; "Padds"; "Pand";"Pannot"; "Pasr"; "Pb"; "Pbc"; "Pbic"; "Pblreg";
- "Pblsymb"; "Pbne"; "Pbreg"; "Pbsymb"; "Pbtbl"; "Pclz"; "Pcmp"; "Pcmn"; "Pconstants"; "Pfcpy_iif";
- "Pfcpy_fii"; "Pfcpy_fi"; "Pfcpy_sf"; "Pflid_lbl"; "Pflis_lbl"; "Pdmb"; "Pdsb"; "Peor"; "Pfabsd";
- "Pfabss"; "Pfaddd"; "Pfadds"; "Pfcmpd"; "Pfcmps"; "Pfcmpzd"; "Pfcmpzs";
- "Pfcpyd"; "Pfcpy_fs"; "Pfcpy_if";"Pfcvtds"; "Pfcvtsd"; "Pfdivd"; "Pfdivs"; "Pfldd";
- "Pflid"; "Pflds"; "Pflid_imm"; "Pflis_imm"; "Pfmuld"; "Pfmuls"; "Pfnegd";
- "Pfnegs"; "Pfsitod"; "Pfsitos"; "Pfsqrt"; "Pfstd";
- "Pfsts"; "Pfsubd"; "Pfsubs"; "Pftosizd"; "Pftosizs"; "Pftouizd";
- "Pftouizs"; "Pfuitod"; "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr";
- "Ploadsymbol_lbl"; "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb";
- "Pldrsh"; "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite";
- "Pmovt"; "Pmovw"; "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr";
- "Ppush"; "Prev"; "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull";
- "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs"; "Pudiv";
- "Pumull" ]
+module StringSet = Set.Make(String)
+
+let mnemonic_names = StringSet.of_list
+ [ "Padc"; "Padd"; "Padds"; "Pand";"Pannot"; "Pasr"; "Pb"; "Pbc"; "Pbic";
+ "Pblreg"; "Pblsymb"; "Pbne"; "Pbreg"; "Pbsymb"; "Pbtbl"; "Pclz"; "Pcmp";
+ "Pcmn"; "Pconstants"; "Pfcpy_iif"; "Pfcpy_fii"; "Pfcpy_fi"; "Pfcpy_sf";
+ "Pflid_lbl"; "Pflis_lbl"; "Pdmb"; "Pdsb"; "Peor"; "Pfabsd"; "Pfabss";
+ "Pfaddd"; "Pfadds"; "Pfcmpd"; "Pfcmps"; "Pfcmpzd"; "Pfcmpzs"; "Pfcpyd";
+ "Pfcpy_fs"; "Pfcpy_if";"Pfcvtds"; "Pfcvtsd"; "Pfdivd"; "Pfdivs"; "Pfldd";
+ "Pflid"; "Pflds"; "Pflid_imm"; "Pflis_imm"; "Pfmuld"; "Pfmuls"; "Pfnegd";
+ "Pfnegs"; "Pfsitod"; "Pfsitos"; "Pfsqrt"; "Pfstd"; "Pfsts"; "Pfsubd";
+ "Pfsubs"; "Pftosizd"; "Pftosizs"; "Pftouizd"; "Pftouizs"; "Pfuitod";
+ "Pfuitos"; "Pinlineasm"; "Pisb"; "Plabel"; "Pldr"; "Ploadsymbol_lbl";
+ "Pldr_p"; "Pldrb"; "Pldrb_p"; "Pldrh"; "Pldrh_p"; "Pldrsb"; "Pldrsh";
+ "Plsl"; "Plsr"; "Pmla"; "Pmov"; "Pmovite"; "Pfmovite"; "Pmovt"; "Pmovw";
+ "Pmul"; "Pmvn"; "Ploadsymbol_imm"; "Pnop"; "Porr"; "Ppush"; "Prev";
+ "Prev16"; "Prsb"; "Prsbs"; "Prsc"; "Psbc"; "Psbfx"; "Psdiv"; "Psmull";
+ "Pstr"; "Pstr_p"; "Pstrb"; "Pstrb_p"; "Pstrh"; "Pstrh_p"; "Psub"; "Psubs";
+ "Pudiv";"Pumull" ]
type instruction_arg =
| ALabel of positive
@@ -143,7 +147,7 @@ let pp_instructions pp ic =
| _ -> true) ic in
let instruction pp n args =
- assert (List.mem n mnemonic_names);
+ assert (StringSet.mem n mnemonic_names);
pp_jobject_start pp;
pp_jmember ~first:true pp "Instruction Name" pp_jstring n;
pp_jmember pp "Args" (pp_jarray pp_arg) args;
@@ -259,7 +263,8 @@ let pp_instructions pp ic =
| Pmla(r1, r2, r3, r4) -> instruction pp "Pmla" [Ireg r1; Ireg r2; Ireg r3; Ireg r4]
| Pmov(r1, so) -> instruction pp "Pmov" [Ireg r1; Shift so]
| Pmovite(cond, r1, so1, so2) -> instruction pp "Pmovite" [Ireg r1; Condition (TargetPrinter.condition_name cond); Shift so1; Condition (TargetPrinter.neg_condition_name cond); Shift so2]
- | Pmovt(r1, n) -> instruction pp "Pmovt" [Ireg r1; Long n]
+ | Pfmovite(cond, r1, r2, r3) -> instruction pp "Pfmovite" [DFreg r1; Condition (TargetPrinter.condition_name cond); DFreg r2; Condition (TargetPrinter.neg_condition_name cond); DFreg r3]
+ | Pmovt(r1, n) -> instruction pp "Pmovt" [Ireg r1; Long n]
| Pmovw(r1, n) -> instruction pp "Pmovw" [Ireg r1; Long n]
| Pmul(r1, r2, r3) -> instruction pp "Pmul" [Ireg r1; Ireg r2; Ireg r3]
| Pmvn(r1, so) -> instruction pp "Pmvn" [Ireg r1; Shift so]
@@ -312,8 +317,8 @@ let print_if prog sourcename =
| Some f ->
let f = Filename.concat !sdump_folder f in
let oc = open_out_bin f in
- JsonAST.pp_ast (Format.formatter_of_out_channel oc) pp_instructions prog sourcename;
+ JsonAST.pp_ast oc pp_instructions prog sourcename;
close_out oc
let pp_mnemonics pp =
- JsonAST.pp_mnemonics pp mnemonic_names
+ JsonAST.pp_mnemonics pp (StringSet.elements mnemonic_names)
diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml
index d9424d11..89aab5c7 100644
--- a/arm/Asmexpand.ml
+++ b/arm/Asmexpand.ml
@@ -18,7 +18,7 @@ open Asm
open Asmexpandaux
open AST
open Camlcoq
-open Integers
+open! Integers
exception Error of string
@@ -304,6 +304,11 @@ let expand_builtin_va_start r =
let expand_builtin_inline name args res =
match name, args, res with
(* Integer arithmetic *)
+ | "__builtin_bswap64" , [BA_splitlong(BA(IR ah), BA(IR al))],
+ BR_splitlong(BR(IR rh), BR(IR rl)) ->
+ expand_int64_arith (rl = al) rl (fun rl ->
+ emit (Prev (rl, ah));
+ emit (Prev (rh, al)))
| ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) ->
emit (Prev (res, a1))
| "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
diff --git a/arm/Asmgen.v b/arm/Asmgen.v
index f12ea870..f428feea 100644
--- a/arm/Asmgen.v
+++ b/arm/Asmgen.v
@@ -481,6 +481,9 @@ Definition transl_op
do r <- ireg_of res; do r1 <- ireg_of a1;
if Int.eq n Int.zero then
OK (Pmov r (SOreg r1) :: k)
+ else if Int.eq n Int.one then
+ OK (Padd IR14 r1 (SOlsr r1 (Int.repr 31)) ::
+ Pmov r (SOasr IR14 n) :: k)
else
OK (Pmov IR14 (SOasr r1 (Int.repr 31)) ::
Padd IR14 r1 (SOlsr IR14 (Int.sub Int.iwordsize n)) ::
@@ -555,6 +558,19 @@ Definition transl_op
do r <- ireg_of res;
transl_cond cmp args
(Pmovite (cond_for_cond cmp) r (SOimm Int.one) (SOimm Int.zero) :: k)
+ | Osel cmp ty, a1 :: a2 :: args =>
+ match preg_of res with
+ | IR r =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2;
+ transl_cond cmp args
+ (Pmovite (cond_for_cond cmp) r (SOreg r1) (SOreg r2) :: k)
+ | FR r =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2;
+ transl_cond cmp args
+ (Pfmovite (cond_for_cond cmp) r r1 r2 :: k)
+ | _ =>
+ Error(msg "Asmgen.Osel")
+ end
| _, _ =>
Error(msg "Asmgen.transl_op")
end.
@@ -676,8 +692,12 @@ Definition transl_memory_access_float
None
mk_immed addr args k.
-Definition transl_load (chunk: memory_chunk) (addr: addressing)
- (args: list mreg) (dst: mreg) (k: code) :=
+Definition transl_load (trap : trapping_mode)
+ (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (dst: mreg) (k: code) :=
+ match trap with
+ | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on Arm")
+ | TRAP =>
match chunk with
| Mint8signed =>
transl_memory_access_int Pldrsb mk_immed_mem_small dst addr args k
@@ -695,6 +715,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing)
transl_memory_access_float Pfldd mk_immed_mem_float dst addr args k
| _ =>
Error (msg "Asmgen.transl_load")
+ end
end.
Definition transl_store (chunk: memory_chunk) (addr: addressing)
@@ -734,8 +755,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction)
else loadind_int IR13 f.(fn_link_ofs) IR12 c)
| Mop op args res =>
transl_op op args res k
- | Mload chunk addr args dst =>
- transl_load chunk addr args dst k
+ | Mload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
| Mstore chunk addr args src =>
transl_store chunk addr args src k
| Mcall sig (inl arg) =>
diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v
index 2c001f45..92ae524f 100644
--- a/arm/Asmgenproof.v
+++ b/arm/Asmgenproof.v
@@ -270,6 +270,7 @@ Opaque Int.eq.
destruct Archi.thumb2_support; TailNoLabel.
eapply tail_nolabel_trans; TailNoLabel.
eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel.
+ destruct (preg_of r); monadInv H; (eapply tail_nolabel_trans; [eapply transl_cond_label; eauto|TailNoLabel]).
Qed.
Remark transl_memory_access_label:
@@ -302,6 +303,7 @@ Proof.
eapply tail_nolabel_trans. 2: eapply loadind_label; eauto. unfold loadind_int; TailNoLabel.
eapply transl_op_label; eauto.
unfold transl_load, transl_memory_access_int, transl_memory_access_float in H.
+ destruct t; try discriminate.
destruct m; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto.
unfold transl_store, transl_memory_access_int, transl_memory_access_float in H.
destruct m; monadInv H; eapply transl_memory_access_label; eauto; simpl; auto.
@@ -617,6 +619,12 @@ Opaque loadind.
split. eapply agree_set_undef_mreg; eauto. congruence.
simpl; congruence.
+- (* Mload notrap1 *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
- (* Mstore *)
assert (eval_addressing tge sp addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v
index 98cd5eea..cdac697e 100644
--- a/arm/Asmgenproof1.v
+++ b/arm/Asmgenproof1.v
@@ -16,6 +16,7 @@ Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
+Require Import Zbits.
Require Import Integers.
Require Import Floats.
Require Import Values.
@@ -355,7 +356,7 @@ Proof.
rewrite Int.and_assoc. change 65535 with (two_p 16 - 1). rewrite Int.and_idem.
apply Int.same_bits_eq; intros.
rewrite Int.bits_or, Int.bits_and, Int.bits_shl, Int.testbit_repr by auto.
- rewrite Int.Ztestbit_two_p_m1 by omega. change (Int.unsigned (Int.repr 16)) with 16.
+ rewrite Ztestbit_two_p_m1 by omega. change (Int.unsigned (Int.repr 16)) with 16.
destruct (zlt i 16).
rewrite andb_true_r, orb_false_r; auto.
rewrite andb_false_r; simpl. rewrite Int.bits_shru by omega.
@@ -1188,7 +1189,7 @@ Lemma transl_op_correct_same:
forall op args res k c (rs: regset) m v,
transl_op op args res k = OK c ->
eval_operation ge rs#IR13 op (map rs (map preg_of args)) m = Some v ->
- match op with Ocmp _ => False | Oaddrstack _ => False | _ => True end ->
+ match op with Ocmp _ => False | Osel _ _ => False | Oaddrstack _ => False | _ => True end ->
exists rs',
exec_straight ge fn c rs m k rs' m
/\ rs'#(preg_of res) = v
@@ -1263,15 +1264,32 @@ Local Transparent destroyed_by_op.
destruct (rs x0) eqn: X0; simpl in H0; try discriminate.
destruct (Int.ltu i (Int.repr 31)) eqn: LTU; inv H0.
revert EQ2. predSpec Int.eq Int.eq_spec i Int.zero; intros EQ2.
+ {
(* i = 0 *)
inv EQ2. econstructor.
split. apply exec_straight_one. simpl. reflexivity. auto.
split. Simpl. unfold Int.shrx. rewrite Int.shl_zero. unfold Int.divs.
change (Int.signed Int.one) with 1. rewrite Z.quot_1_r. rewrite Int.repr_signed. auto.
intros. Simpl.
- (* i <> 0 *)
- inv EQ2.
- assert (LTU': Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize = true).
+ }
+ { (* i <> 0 *)
+ revert EQ2. predSpec Int.eq Int.eq_spec i Int.one; intros EQ2.
+ {
+ inv EQ2.
+ econstructor; split.
+ eapply exec_straight_two; simpl; reflexivity.
+ split.
+ { rewrite X0.
+ rewrite Int.shrx1_shr by reflexivity.
+ Simpl.
+ }
+ { intros.
+ Simpl.
+ }
+ }
+ clear H0.
+ inv EQ2.
+ assert (LTU': Int.ltu (Int.sub Int.iwordsize i) Int.iwordsize = true).
{
generalize (Int.ltu_inv _ _ LTU). intros.
unfold Int.sub, Int.ltu. rewrite Int.unsigned_repr_wordsize.
@@ -1305,6 +1323,7 @@ Local Transparent destroyed_by_op.
rewrite LTU'; simpl. rewrite LTU''; simpl.
f_equal. symmetry. apply Int.shrx_shr_2. assumption.
intros. unfold rs3; Simpl. unfold rs2; Simpl. unfold rs1; Simpl.
+ }
(* intoffloat *)
econstructor; split. apply exec_straight_one; simpl. rewrite H0; simpl. eauto. auto.
Transparent destroyed_by_op.
@@ -1332,6 +1351,8 @@ Transparent destroyed_by_op.
intuition Simpl.
(* Ocmp *)
contradiction.
+ (* Osel *)
+ contradiction.
Qed.
Lemma transl_op_correct:
@@ -1368,6 +1389,27 @@ Proof.
split; intros; Simpl.
destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto.
destruct B as [B1 B2]; rewrite B1. destruct b; auto.
+- (* Osel *)
+ clear SAME. simpl in H. ArgsInv. simpl in H0; inv H0.
+ assert (D1: data_preg (preg_of m0) = true) by auto with asmgen.
+ assert (D2: data_preg (preg_of m1) = true) by auto with asmgen.
+ destruct (preg_of res) eqn:RES; monadInv H.
++ inv EQ2. rewrite (ireg_of_eq _ _ EQ), (ireg_of_eq _ _ EQ1) in *.
+ exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split; intros; Simpl.
+ rewrite ! C by auto.
+ destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto.
+ destruct B as [B1 B2]; rewrite B1. destruct b; apply Val.lessdef_normalize.
++ inv EQ2. rewrite (freg_of_eq _ _ EQ), (freg_of_eq _ _ EQ1) in *.
+ exploit transl_cond_correct; eauto. instantiate (1 := rs). instantiate (1 := m). intros [rs1 [A [B C]]].
+ econstructor; split.
+ eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto. auto.
+ split; intros; Simpl.
+ rewrite ! C by auto.
+ destruct (eval_condition c0 rs ## (preg_of ## args) m) as [b|]; simpl; auto.
+ destruct B as [B1 B2]; rewrite B1. destruct b; apply Val.lessdef_normalize.
Qed.
(** Translation of loads and stores. *)
@@ -1516,8 +1558,8 @@ Proof.
Qed.
Lemma transl_load_correct:
- forall chunk addr args dst k c (rs: regset) a m v,
- transl_load chunk addr args dst k = OK c ->
+ forall trap chunk addr args dst k c (rs: regset) a m v,
+ transl_load trap chunk addr args dst k = OK c ->
eval_addressing ge (rs#SP) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
@@ -1525,7 +1567,9 @@ Lemma transl_load_correct:
/\ rs'#(preg_of dst) = v
/\ forall r, data_preg r = true -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
- intros. destruct chunk; simpl in H.
+ intros.
+ destruct trap; try (simpl in *; discriminate).
+ destruct chunk; simpl in H.
eapply transl_load_int_correct; eauto.
eapply transl_load_int_correct; eauto.
eapply transl_load_int_correct; eauto.
diff --git a/arm/Builtins1.v b/arm/Builtins1.v
new file mode 100644
index 00000000..53c83d7e
--- /dev/null
+++ b/arm/Builtins1.v
@@ -0,0 +1,33 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Platform-specific built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Import Builtins0.
+
+Inductive platform_builtin : Type := .
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with end.
diff --git a/arm/CBuiltins.ml b/arm/CBuiltins.ml
index ec4f4aaa..d6a1ea35 100644
--- a/arm/CBuiltins.ml
+++ b/arm/CBuiltins.ml
@@ -18,10 +18,10 @@
open C
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list", TPtr(TVoid [], [])
];
- Builtins.functions = [
+ builtin_functions = [
(* Integer arithmetic *)
"__builtin_clz",
(TInt(IInt, []), [TInt(IUInt, [])], false);
diff --git a/arm/CSE2deps.v b/arm/CSE2deps.v
new file mode 100644
index 00000000..9db51bbb
--- /dev/null
+++ b/arm/CSE2deps.v
@@ -0,0 +1,20 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk)
+ else true | _, _, _, _ => true
+ end.
diff --git a/arm/CSE2depsproof.v b/arm/CSE2depsproof.v
new file mode 100644
index 00000000..61fe5980
--- /dev/null
+++ b/arm/CSE2depsproof.v
@@ -0,0 +1,129 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Lemma ptrofs_size :
+ Ptrofs.wordsize = 32%nat.
+Proof.
+ unfold Ptrofs.wordsize.
+ unfold Wordsize_Ptrofs.wordsize.
+ trivial.
+Qed.
+
+Lemma ptrofs_modulus :
+ Ptrofs.modulus = 4294967296.
+Proof.
+ unfold Ptrofs.modulus.
+ rewrite ptrofs_size.
+ destruct Archi.ptr64; reflexivity.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : int.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr
+ \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in *.
+
+ rewrite ptrofs_modulus in *.
+ simpl in *.
+ inv ADDRR.
+ inv ADDRW.
+ destruct base; try discriminate.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsr)) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW];
+ rewrite OFSW).
+
+ all: try rewrite ptrofs_modulus in *.
+
+ all: unfold Ptrofs.of_int.
+
+ all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia).
+ all: intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/arm/ConstpropOp.vp b/arm/ConstpropOp.vp
index d62240ef..8555d3aa 100644
--- a/arm/ConstpropOp.vp
+++ b/arm/ConstpropOp.vp
@@ -20,7 +20,7 @@ Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Registers.
-Require Import ValueDomain.
+Require Import ValueDomain ValueAOp.
(** * Converting known values to constants *)
@@ -131,6 +131,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
make_cmp_base c args vl
end.
+Definition make_select (c: condition) (ty: typ)
+ (r1 r2: reg) (args: list reg) (vl: list aval) :=
+ match resolve_branch (eval_static_condition c vl) with
+ | Some b => (Omove, (if b then r1 else r2) :: nil)
+ | None =>
+ let (c', args') := cond_strength_reduction c args vl in
+ (Osel c' ty, r1 :: r2 :: args')
+ end.
+
Definition make_addimm (n: int) (r: reg) :=
if Int.eq n Int.zero
then (Omove, r :: nil)
@@ -284,6 +293,7 @@ Nondetfunction op_strength_reduction
| Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2
| Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2
| Ocmp c, args, vl => make_cmp c args vl
+ | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl
| Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
| Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
| Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v
index 079ba2be..a4f5c29c 100644
--- a/arm/ConstpropOpproof.v
+++ b/arm/ConstpropOpproof.v
@@ -24,7 +24,7 @@ Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
-Require Import ValueDomain.
+Require Import ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.
Local Transparent Archi.ptr64.
@@ -234,6 +234,28 @@ Proof.
- apply make_cmp_base_correct; auto.
Qed.
+Lemma make_select_correct:
+ forall c ty r1 r2 args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_select c ty r1 r2 args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v
+ /\ Val.lessdef (Val.select (eval_condition c rs##args m) rs#r1 rs#r2 ty) v.
+Proof.
+ unfold make_select; intros.
+ destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB.
+- exists (if b then rs#r1 else rs#r2); split.
++ simpl. destruct b; auto.
++ destruct (eval_condition c rs##args m) as [b'|] eqn:EC; simpl; auto.
+ assert (b = b').
+ { eapply resolve_branch_sound; eauto.
+ rewrite <- EC. apply eval_static_condition_sound with bc.
+ subst vl. exact (aregs_sound _ _ _ args MATCH). }
+ subst b'. apply Val.lessdef_normalize.
+- generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ; auto.
+Qed.
+
Lemma make_addimm_correct:
forall n r,
let (op, args) := make_addimm n r in
@@ -616,6 +638,8 @@ Proof.
InvApproxRegs; SimplVM. inv H0. apply make_shruimm_correct; auto.
(* cmp *)
inv H0. apply make_cmp_correct; auto.
+(* select *)
+ inv H0. apply make_select_correct; congruence.
(* mulf *)
InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2).
diff --git a/arm/Conventions1.v b/arm/Conventions1.v
index c5277e8d..fe49a781 100644
--- a/arm/Conventions1.v
+++ b/arm/Conventions1.v
@@ -104,13 +104,12 @@ Definition is_float_reg (r: mreg): bool :=
representation with a single LDM instruction. *)
Definition loc_result (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One R0
- | Some (Tint | Tany32) => One R0
- | Some (Tfloat | Tsingle | Tany64) => One F0
- | Some Tlong => if Archi.big_endian
- then Twolong R0 R1
- else Twolong R1 R0
+ match proj_sig_res s with
+ | Tint | Tany32 => One R0
+ | Tfloat | Tsingle | Tany64 => One F0
+ | Tlong => if Archi.big_endian
+ then Twolong R0 R1
+ else Twolong R1 R0
end.
(** The result registers have types compatible with that given in the signature. *)
@@ -119,7 +118,7 @@ Lemma loc_result_type:
forall sig,
subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
Proof.
- intros. unfold proj_sig_res, loc_result. destruct (sig_res sig) as [[]|]; destruct Archi.big_endian; auto.
+ intros. unfold loc_result. destruct (proj_sig_res sig); destruct Archi.big_endian; auto.
Qed.
(** The result locations are caller-save registers *)
@@ -129,7 +128,7 @@ Lemma loc_result_caller_save:
forall_rpair (fun r => is_callee_save r = false) (loc_result s).
Proof.
intros.
- unfold loc_result. destruct (sig_res s) as [[]|]; destruct Archi.big_endian; simpl; auto.
+ unfold loc_result. destruct (proj_sig_res s); destruct Archi.big_endian; simpl; auto.
Qed.
(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
@@ -139,14 +138,13 @@ Lemma loc_result_pair:
match loc_result sg with
| One _ => True
| Twolong r1 r2 =>
- r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ r1 <> r2 /\ proj_sig_res sg = Tlong
/\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
/\ Archi.ptr64 = false
end.
Proof.
- intros; unfold loc_result; destruct (sig_res sg) as [[]|]; destruct Archi.big_endian; auto.
- intuition congruence.
- intuition congruence.
+ intros; unfold loc_result; destruct (proj_sig_res sg); auto.
+ destruct Archi.big_endian; intuition congruence.
Qed.
(** The location of the result depends only on the result part of the signature *)
@@ -154,7 +152,7 @@ Qed.
Lemma loc_result_exten:
forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
Proof.
- intros. unfold loc_result. rewrite H; auto.
+ intros. unfold loc_result, proj_sig_res. rewrite H; auto.
Qed.
(** ** Location of function arguments *)
@@ -271,48 +269,6 @@ Definition loc_arguments (s: signature) : list (rpair loc) :=
else loc_arguments_hf s.(sig_args) 0 0 0
end.
-(** [size_arguments s] returns the number of [Outgoing] slots used
- to call a function with signature [s]. *)
-
-Fixpoint size_arguments_hf (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
- match tyl with
- | nil => ofs
- | (Tint|Tany32) :: tys =>
- if zlt ir 4
- then size_arguments_hf tys (ir + 1) fr ofs
- else size_arguments_hf tys ir fr (ofs + 1)
- | (Tfloat|Tany64) :: tys =>
- if zlt fr 8
- then size_arguments_hf tys ir (fr + 1) ofs
- else size_arguments_hf tys ir fr (align ofs 2 + 2)
- | Tsingle :: tys =>
- if zlt fr 8
- then size_arguments_hf tys ir (fr + 1) ofs
- else size_arguments_hf tys ir fr (ofs + 1)
- | Tlong :: tys =>
- let ir := align ir 2 in
- if zlt ir 4
- then size_arguments_hf tys (ir + 2) fr ofs
- else size_arguments_hf tys ir fr (align ofs 2 + 2)
- end.
-
-Fixpoint size_arguments_sf (tyl: list typ) (ofs: Z) {struct tyl} : Z :=
- match tyl with
- | nil => Z.max 0 ofs
- | (Tint | Tsingle | Tany32) :: tys => size_arguments_sf tys (ofs + 1)
- | (Tfloat | Tlong | Tany64) :: tys => size_arguments_sf tys (align ofs 2 + 2)
- end.
-
-Definition size_arguments (s: signature) : Z :=
- match Archi.abi with
- | Archi.Softfloat =>
- size_arguments_sf s.(sig_args) (-4)
- | Archi.Hardfloat =>
- if s.(sig_cc).(cc_vararg)
- then size_arguments_sf s.(sig_args) (-4)
- else size_arguments_hf s.(sig_args) 0 0 0
- end.
-
(** Argument locations are either non-temporary registers or [Outgoing]
stack slots at nonnegative offsets. *)
@@ -473,173 +429,15 @@ Qed.
Hint Resolve loc_arguments_acceptable: locs.
-(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
-
-Remark size_arguments_hf_above:
- forall tyl ir fr ofs0,
- ofs0 <= size_arguments_hf tyl ir fr ofs0.
-Proof.
- induction tyl; simpl; intros.
- omega.
- destruct a.
- destruct (zlt ir 4); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega.
- destruct (zlt fr 8); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- set (ir' := align ir 2).
- destruct (zlt ir' 4); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- destruct (zlt fr 8); eauto.
- apply Z.le_trans with (ofs0 + 1); eauto. omega.
- destruct (zlt ir 4); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega.
- destruct (zlt fr 8); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
-Qed.
-
-Remark size_arguments_sf_above:
- forall tyl ofs0,
- Z.max 0 ofs0 <= size_arguments_sf tyl ofs0.
-Proof.
- induction tyl; simpl; intros.
- omega.
- destruct a; (eapply Z.le_trans; [idtac|eauto]).
- xomega.
- assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
- assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
- xomega.
- xomega.
- assert (ofs0 <= align ofs0 2) by (apply align_le; omega). xomega.
-Qed.
-
-Lemma size_arguments_above:
- forall s, size_arguments s >= 0.
-Proof.
- intros; unfold size_arguments. apply Z.le_ge.
- assert (0 <= size_arguments_sf (sig_args s) (-4)).
- { change 0 with (Z.max 0 (-4)). apply size_arguments_sf_above. }
- assert (0 <= size_arguments_hf (sig_args s) 0 0 0).
- { apply size_arguments_hf_above. }
- destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto.
-Qed.
-
-Lemma loc_arguments_hf_bounded:
- forall ofs ty tyl ir fr ofs0,
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_hf tyl ir fr ofs0)) ->
- ofs + typesize ty <= size_arguments_hf tyl ir fr ofs0.
-Proof.
- induction tyl; simpl; intros.
- elim H.
- destruct a.
-- (* int *)
- destruct (zlt ir 4); destruct H.
- discriminate.
- eauto.
- inv H. apply size_arguments_hf_above.
- eauto.
-- (* float *)
- destruct (zlt fr 8); destruct H.
- discriminate.
- eauto.
- inv H. apply size_arguments_hf_above.
- eauto.
-- (* long *)
- destruct (zlt (align ir 2) 4).
- destruct H. discriminate. destruct H. discriminate. eauto.
- destruct Archi.big_endian.
- destruct H. inv H.
- eapply Z.le_trans. 2: apply size_arguments_hf_above. simpl; omega.
- destruct H. inv H.
- rewrite <- Z.add_assoc. simpl. apply size_arguments_hf_above.
- eauto.
- destruct H. inv H.
- rewrite <- Z.add_assoc. simpl. apply size_arguments_hf_above.
- destruct H. inv H.
- eapply Z.le_trans. 2: apply size_arguments_hf_above. simpl; omega.
- eauto.
-- (* float *)
- destruct (zlt fr 8); destruct H.
- discriminate.
- eauto.
- inv H. apply size_arguments_hf_above.
- eauto.
-- (* any32 *)
- destruct (zlt ir 4); destruct H.
- discriminate.
- eauto.
- inv H. apply size_arguments_hf_above.
- eauto.
-- (* any64 *)
- destruct (zlt fr 8); destruct H.
- discriminate.
- eauto.
- inv H. apply size_arguments_hf_above.
- eauto.
-Qed.
-
-Lemma loc_arguments_sf_bounded:
- forall ofs ty tyl ofs0,
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_sf tyl ofs0)) ->
- Z.max 0 (ofs + typesize ty) <= size_arguments_sf tyl ofs0.
-Proof.
- induction tyl; simpl; intros.
- elim H.
- destruct a.
-- (* int *)
- destruct H.
- destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
- eauto.
-- (* float *)
- destruct H.
- destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above.
- eauto.
-- (* long *)
- destruct H.
- destruct Archi.big_endian.
- destruct (zlt (align ofs0 2) 0); inv H.
- eapply Z.le_trans. 2: apply size_arguments_sf_above. simpl; xomega.
- destruct (zlt (align ofs0 2) 0); inv H.
- rewrite <- Z.add_assoc. simpl. apply size_arguments_sf_above.
- destruct H.
- destruct Archi.big_endian.
- destruct (zlt (align ofs0 2) 0); inv H.
- rewrite <- Z.add_assoc. simpl. apply size_arguments_sf_above.
- destruct (zlt (align ofs0 2) 0); inv H.
- eapply Z.le_trans. 2: apply size_arguments_sf_above. simpl; xomega.
- eauto.
-- (* float *)
- destruct H.
- destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
- eauto.
-- (* any32 *)
- destruct H.
- destruct (zlt ofs0 0); inv H. apply size_arguments_sf_above.
- eauto.
-- (* any64 *)
- destruct H.
- destruct (zlt (align ofs0 2) 0); inv H. apply size_arguments_sf_above.
- eauto.
-Qed.
-
-Lemma loc_arguments_bounded:
- forall (s: signature) (ofs: Z) (ty: typ),
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
- ofs + typesize ty <= size_arguments s.
-Proof.
- unfold loc_arguments, size_arguments; intros.
- assert (In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_sf (sig_args s) (-4))) ->
- ofs + typesize ty <= size_arguments_sf (sig_args s) (-4)).
- { intros. eapply Z.le_trans. 2: eapply loc_arguments_sf_bounded; eauto. xomega. }
- assert (In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_hf (sig_args s) 0 0 0)) ->
- ofs + typesize ty <= size_arguments_hf (sig_args s) 0 0 0).
- { intros. eapply loc_arguments_hf_bounded; eauto. }
- destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; eauto.
-Qed.
-
Lemma loc_arguments_main:
loc_arguments signature_main = nil.
Proof.
unfold loc_arguments.
destruct Archi.abi; reflexivity.
Qed.
+
+(** ** Normalization of function results *)
+
+(** No normalization needed. *)
+
+Definition return_value_needs_normalization (t: rettype) := false.
diff --git a/arm/DuplicateOpcodeHeuristic.ml b/arm/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..9b6a6409
--- /dev/null
+++ b/arm/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,22 @@
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c | Ccompfs c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c | Cnotcompfs c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
+
diff --git a/arm/NeedOp.v b/arm/NeedOp.v
index dee7cae1..c70c7e40 100644
--- a/arm/NeedOp.v
+++ b/arm/NeedOp.v
@@ -83,6 +83,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Omakelong => op2 (default nv)
| Olowlong | Ohighlong => op1 (default nv)
| Ocmp c => needs_of_condition c
+ | Osel c ty => nv :: nv :: needs_of_condition c
end.
Definition operation_is_redundant (op: operation) (nv: nval): bool :=
@@ -183,6 +184,10 @@ Proof.
- apply notint_sound; auto.
- apply notint_sound. apply needs_of_shift_sound; auto.
- apply needs_of_shift_sound; auto.
+- destruct (eval_condition c args m) as [b|] eqn:EC.
+ erewrite needs_of_condition_sound by eauto.
+ apply select_sound; auto.
+ simpl; auto with na.
Qed.
Lemma operation_is_redundant_sound:
diff --git a/arm/Op.v b/arm/Op.v
index 60c214d0..671bdbe4 100644
--- a/arm/Op.v
+++ b/arm/Op.v
@@ -140,7 +140,9 @@ Inductive operation : Type :=
| Olowlong: operation (**r [rd = low-word(r1)] *)
| Ohighlong: operation (**r [rd = high-word(r1)] *)
(*c Boolean tests: *)
- | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Ocmp: condition -> operation (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Osel: condition -> typ -> operation.
+ (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *)
(** Addressing modes. [r1], [r2], etc, are the arguments to the
addressing. *)
@@ -174,7 +176,7 @@ Defined.
Definition eq_operation (x y: operation): {x=y} + {x<>y}.
Proof.
- generalize Int.eq_dec Ptrofs.eq_dec ident_eq; intros.
+ generalize Int.eq_dec Ptrofs.eq_dec ident_eq typ_eq; intros.
generalize Float.eq_dec Float32.eq_dec; intros.
generalize eq_shift; intro.
generalize eq_condition; intro.
@@ -294,6 +296,7 @@ Definition eval_operation
| Olowlong, v1::nil => Some(Val.loword v1)
| Ohighlong, v1::nil => Some(Val.hiword v1)
| Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m))
+ | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty)
| _, _ => None
end.
@@ -419,6 +422,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Olowlong => (Tlong :: nil, Tint)
| Ohighlong => (Tlong :: nil, Tint)
| Ocmp c => (type_of_condition c, Tint)
+ | Osel c ty => (ty :: ty :: type_of_condition c, ty)
end.
Definition type_of_addressing (addr: addressing) : list typ :=
@@ -511,8 +515,35 @@ Proof with (try exact I; try reflexivity).
destruct v0...
destruct v0...
destruct (eval_condition c vl m)... destruct b...
+ unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I.
Qed.
+
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivu
+ | Oshrximm _
+ | Ointoffloat | Ointuoffloat
+ | Ointofsingle | Ointuofsingle
+ | Ofloatofint | Ofloatofintu
+ | Osingleofint | Osingleofintu => true
+ | _ => false
+ end.
+
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
End SOUNDNESS.
(** * Manipulating and transforming operations *)
@@ -532,7 +563,7 @@ Lemma mk_shift_amount_eq:
forall n, Int.ltu n Int.iwordsize = true -> s_amount (mk_shift_amount n) = n.
Proof.
intros; simpl. unfold Int.modu. transitivity (Int.repr (Int.unsigned n)).
- decEq. apply Zmod_small. apply Int.ltu_inv; auto.
+ decEq. apply Z.mod_small. apply Int.ltu_inv; auto.
apply Int.repr_unsigned.
Qed.
@@ -682,19 +713,37 @@ Definition is_trivial_op (op: operation) : bool :=
(** Operations that depend on the memory state. *)
+Definition condition_depends_on_memory (c: condition) : bool :=
+ match c with
+ | Ccompu _ | Ccompushift _ _| Ccompuimm _ _ => true
+ | _ => false
+ end.
+
Definition op_depends_on_memory (op: operation) : bool :=
match op with
- | Ocmp (Ccompu _ | Ccompushift _ _| Ccompuimm _ _) => true
+ | Ocmp c => condition_depends_on_memory c
+ | Osel c ty => condition_depends_on_memory c
| _ => false
end.
+Lemma condition_depends_on_memory_correct:
+ forall c args m1 m2,
+ condition_depends_on_memory c = false ->
+ eval_condition c args m1 = eval_condition c args m2.
+Proof.
+ intros. destruct c; simpl; auto; discriminate.
+Qed.
+
Lemma op_depends_on_memory_correct:
forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
op_depends_on_memory op = false ->
eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
- intros until m2. destruct op; simpl; try congruence.
- intros. destruct c; simpl; auto; congruence.
+ intros until m2. destruct op; simpl; try congruence; intros C.
+- f_equal; f_equal; apply condition_depends_on_memory_correct; auto.
+- destruct args; auto. destruct args; auto.
+ rewrite (condition_depends_on_memory_correct c args m1 m2 C).
+ auto.
Qed.
(** Global variables mentioned in an operation or addressing mode *)
@@ -929,6 +978,10 @@ Proof.
exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
destruct b; simpl; constructor.
simpl; constructor.
+
+ apply Val.select_inject; auto.
+ destruct (eval_condition c vl1 m1) eqn:?; auto.
+ right; symmetry; eapply eval_condition_inj; eauto.
Qed.
Lemma eval_addressing_inj:
@@ -948,6 +1001,20 @@ Proof.
apply Val.offset_ptr_inject; auto.
Qed.
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *;
+ inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
+Qed.
End EVAL_COMPAT.
(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
@@ -1053,6 +1120,19 @@ Proof.
destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros. rewrite val_inject_list_lessdef in H.
+ eapply eval_addressing_inj_none with (sp1 := sp).
+ intros. rewrite <- val_inject_lessdef; auto.
+ rewrite <- val_inject_lessdef; auto.
+ eauto. auto.
+Qed.
+
End EVAL_LESSDEF.
(** Compatibility of the evaluation functions with memory injections. *)
@@ -1105,6 +1185,19 @@ Proof.
econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
Lemma eval_operation_inject:
forall op vl1 vl2 v1 m1 m2,
Val.inject_list f vl1 vl2 ->
diff --git a/arm/PrintOp.ml b/arm/PrintOp.ml
index 642fff80..d74acf3f 100644
--- a/arm/PrintOp.ml
+++ b/arm/PrintOp.ml
@@ -129,6 +129,10 @@ let print_operation reg pp = function
| Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1
| Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1
| Ocmp c, args -> print_condition reg pp (c, args)
+ | Osel (c, ty), r1::r2::args ->
+ fprintf pp "%a ?%s %a : %a"
+ (print_condition reg) (c, args)
+ (PrintAST.name_of_type ty) reg r1 reg r2
| _ -> fprintf pp "<bad operator>"
let print_addressing reg pp = function
diff --git a/arm/SelectOp.vp b/arm/SelectOp.vp
index f3f01730..5506157c 100644
--- a/arm/SelectOp.vp
+++ b/arm/SelectOp.vp
@@ -38,12 +38,8 @@
Require Import Coqlib.
Require Import Compopts.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import OpHelpers.
-Require Import CminorSel.
+Require Import AST Integers Floats Builtins.
+Require Import Op OpHelpers CminorSel.
Local Open Scope cminorsel_scope.
@@ -383,6 +379,16 @@ Definition compf (c: comparison) (e1: expr) (e2: expr) :=
Definition compfs (c: comparison) (e1: expr) (e2: expr) :=
Eop (Ocmp (Ccompfs c)) (e1 ::: e2 ::: Enil).
+Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) :=
+ if match ty with
+ | Tint => true
+ | Tfloat => true
+ | Tsingle => true
+ | _ => false
+ end
+ then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args))
+ else None.
+
(** ** Integer conversions *)
Definition cast8unsigned (e: expr) := andimm (Int.repr 255) e.
@@ -516,3 +522,8 @@ Definition divf_base (e1: expr) (e2: expr) :=
Definition divfs_base (e1: expr) (e2: expr) :=
Eop Odivfs (e1 ::: e2 ::: Enil).
+
+(** Platform-specific known builtins *)
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ None.
diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v
index 212bcfd7..56534c04 100644
--- a/arm/SelectOpproof.v
+++ b/arm/SelectOpproof.v
@@ -13,16 +13,9 @@
(** Correctness of instruction selection for operators *)
Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import Memory.
-Require Import Globalenvs.
-Require Import Cminor.
-Require Import Op.
-Require Import CminorSel.
+Require Import AST Integers Floats.
+Require Import Values Memory Builtins Globalenvs.
+Require Import Cminor Op CminorSel.
Require Import SelectOp.
Require Import OpHelpers OpHelpersproof.
@@ -738,6 +731,22 @@ Proof.
intros; red; intros. unfold compfs. TrivialExists.
Qed.
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select; intros.
+ destruct (match ty with Tint | Tfloat | Tsingle => true | _ => false end); inv H.
+ rewrite <- H3; TrivialExists.
+Qed.
+
Theorem eval_cast8signed: unary_constructor_sound cast8signed (Val.sign_ext 8).
Proof.
red; intros until x. unfold cast8signed; case (cast8signed_match a); intros.
@@ -748,7 +757,7 @@ Qed.
Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm. omega.
Qed.
Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
@@ -761,7 +770,7 @@ Qed.
Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm. omega.
Qed.
Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat.
@@ -896,7 +905,6 @@ Proof.
- constructor; auto.
Qed.
-
(* floating-point division without HELPERS *)
Theorem eval_divf_base:
forall le a b x y,
@@ -917,4 +925,17 @@ Proof.
intros; unfold divfs_base.
TrivialExists.
Qed.
+
+(** Platform-specific known builtins *)
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros. discriminate.
+Qed.
+
End CMCONSTR.
diff --git a/arm/TargetPrinter.ml b/arm/TargetPrinter.ml
index bf37b0e4..03e06a65 100644
--- a/arm/TargetPrinter.ml
+++ b/arm/TargetPrinter.ml
@@ -113,9 +113,9 @@ struct
let freg_single oc r = output_string oc (single_float_reg_name r)
let freg_param_single oc r = output_string oc (single_param_reg_name r)
- let preg oc = function
+ let preg_asm oc ty = function
| IR r -> ireg oc r
- | FR r -> freg oc r
+ | FR r -> if ty = Tsingle then freg_single oc r else freg oc r
| _ -> assert false
(* In Thumb2 mode, some arithmetic instructions have shorter encodings
@@ -148,9 +148,9 @@ struct
let name_of_section = function
| Section_text -> ".text"
| Section_data i | Section_small_data i ->
- if i then ".data" else "COMM"
+ if i then ".data" else common_section ()
| Section_const i | Section_small_const i ->
- if i then ".section .rodata" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM"
| Section_string -> ".section .rodata"
| Section_literal -> ".text"
| Section_jumptable -> ".text"
@@ -443,6 +443,12 @@ struct
(condition_name cond) ireg r1 shift_op ifso;
fprintf oc " mov%s %a, %a\n"
(neg_condition_name cond) ireg r1 shift_op ifnot
+ | Pfmovite(cond, r1, ifso, ifnot) ->
+ fprintf oc " ite %s\n" (condition_name cond);
+ fprintf oc " vmov%s.f64 %a, %a\n"
+ (condition_name cond) freg r1 freg ifso;
+ fprintf oc " vmov%s.f64 %a, %a\n"
+ (neg_condition_name cond) freg r1 freg ifnot
| Pbtbl(r, tbl) ->
if !Clflags.option_mthumb then begin
fprintf oc " lsl r14, %a, #2\n" ireg r;
@@ -474,7 +480,7 @@ struct
(P.to_int kind) (extern_atom txt) args
| EF_inline_asm(txt, sg, clob) ->
fprintf oc "%s begin inline assembly\n\t" comment;
- print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
fprintf oc "%s end inline assembly\n" comment
| _ ->
assert false
diff --git a/arm/ValueAOp.v b/arm/ValueAOp.v
index e19ddd6d..a3fd9d7d 100644
--- a/arm/ValueAOp.v
+++ b/arm/ValueAOp.v
@@ -127,6 +127,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Olowlong, v1::nil => loword v1
| Ohighlong, v1::nil => hiword v1
| Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2
| _, _ => Vbot
end.
@@ -205,6 +206,7 @@ Proof.
rewrite Ptrofs.add_zero_l; eauto with va.
fold (Val.sub (Vint i) a1). auto with va.
apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+ apply select_sound; auto. eapply eval_static_condition_sound; eauto.
Qed.
End SOUNDNESS.
diff --git a/backend/Allnontrap.v b/backend/Allnontrap.v
new file mode 100644
index 00000000..acf03eca
--- /dev/null
+++ b/backend/Allnontrap.v
@@ -0,0 +1,26 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL.
+
+
+Definition transf_ros (ros: reg + ident) : reg + ident := ros.
+
+Definition transf_instr (pc: node) (instr: instruction) :=
+ match instr with
+ | Iload trap chunk addr args dst s => Iload NOTRAP chunk addr args dst s
+ | _ => instr
+ end.
+
+Definition transf_function (f: function) : function :=
+ {| fn_sig := f.(fn_sig);
+ fn_params := f.(fn_params);
+ fn_stacksize := f.(fn_stacksize);
+ fn_code := PTree.map transf_instr f.(fn_code);
+ fn_entrypoint := f.(fn_entrypoint) |}.
+
+Definition transf_fundef (fd: fundef) : fundef :=
+ AST.transf_fundef transf_function fd.
+
+Definition transf_program (p: program) : program :=
+ transform_program transf_fundef p.
+
diff --git a/backend/Allnontrapproof.v b/backend/Allnontrapproof.v
new file mode 100644
index 00000000..92e5a88c
--- /dev/null
+++ b/backend/Allnontrapproof.v
@@ -0,0 +1,215 @@
+Require Import FunInd.
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import Allnontrap.
+
+
+Definition match_prog (p tp: RTL.program) :=
+ match_program (fun ctx f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p, match_prog p (transf_program p).
+Proof.
+ intros. eapply match_transform_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variables prog tprog: program.
+Hypothesis TRANSL: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma functions_translated:
+ forall v f,
+ Genv.find_funct ge v = Some f ->
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_transf TRANSL).
+
+Lemma function_ptr_translated:
+ forall v f,
+ Genv.find_funct_ptr ge v = Some f ->
+ Genv.find_funct_ptr tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_ptr_transf TRANSL).
+
+Lemma symbols_preserved:
+ forall id,
+ Genv.find_symbol tge id = Genv.find_symbol ge id.
+Proof (Genv.find_symbol_transf TRANSL).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_transf TRANSL).
+
+Lemma sig_preserved:
+ forall f, funsig (transf_fundef f) = funsig f.
+Proof.
+ destruct f; reflexivity.
+Qed.
+
+Lemma find_function_translated:
+ forall ros rs fd,
+ find_function ge ros rs = Some fd ->
+ find_function tge ros rs = Some (transf_fundef fd).
+Proof.
+ unfold find_function; intros. destruct ros as [r|id].
+ eapply functions_translated; eauto.
+ rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence.
+ eapply function_ptr_translated; eauto.
+Qed.
+
+Lemma transf_function_at:
+ forall f pc i,
+ f.(fn_code)!pc = Some i ->
+ (transf_function f).(fn_code)!pc = Some(transf_instr pc i).
+Proof.
+ intros until i. intro Hcode.
+ unfold transf_function; simpl.
+ rewrite PTree.gmap.
+ unfold option_map.
+ rewrite Hcode.
+ reflexivity.
+Qed.
+
+Ltac TR_AT :=
+ match goal with
+ | [ A: (fn_code _)!_ = Some _ |- _ ] =>
+ generalize (transf_function_at _ _ _ A); intros
+ end.
+
+
+Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop :=
+ | match_frames_intro: forall res f sp pc rs,
+ match_frames (Stackframe res f sp pc rs)
+ (Stackframe res (transf_function f) sp pc rs).
+
+Inductive match_states: RTL.state -> RTL.state -> Prop :=
+ | match_regular_states: forall stk f sp pc rs m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (State stk f sp pc rs m)
+ (State stk' (transf_function f) sp pc rs m)
+ | match_callstates: forall stk f args m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Callstate stk f args m)
+ (Callstate stk' (transf_fundef f) args m)
+ | match_returnstates: forall stk v m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Returnstate stk v m)
+ (Returnstate stk' v m).
+
+Lemma step_simulation:
+ forall S1 t S2, RTL.step ge S1 t S2 ->
+ forall S1', match_states S1 S1' ->
+ exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ induction 1; intros S1' MS; inv MS; try TR_AT.
+- (* nop *)
+ econstructor; split. eapply exec_Inop; eauto.
+ constructor; auto.
+- (* op *)
+ econstructor; split.
+ eapply exec_Iop with (v := v); eauto.
+ rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved.
+ constructor; auto.
+(* load *)
+- econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload; eauto.
+ constructor; auto.
+- (* load notrap1 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = None).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap1; eauto.
+ constructor; auto.
+- (* load notrap2 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap2; eauto.
+ constructor; auto.
+- (* store *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Istore; eauto.
+ constructor; auto.
+(* call *)
+- econstructor; split.
+ eapply exec_Icall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ constructor. constructor; auto. constructor.
+(* tailcall *)
+- econstructor; split.
+ eapply exec_Itailcall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ constructor. auto.
+(* builtin *)
+- econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+(* cond *)
+- econstructor; split.
+ eapply exec_Icond; eauto.
+ constructor; auto.
+(* jumptbl *)
+- econstructor; split.
+ eapply exec_Ijumptable; eauto.
+ constructor; auto.
+(* return *)
+- econstructor; split.
+ eapply exec_Ireturn; eauto.
+ constructor; auto.
+(* internal function *)
+- simpl. econstructor; split.
+ eapply exec_function_internal; eauto.
+ constructor; auto.
+(* external function *)
+- econstructor; split.
+ eapply exec_function_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+(* return *)
+- inv STACKS. inv H1.
+ econstructor; split.
+ eapply exec_return; eauto.
+ constructor; auto.
+Qed.
+
+Lemma transf_initial_states:
+ forall S1, RTL.initial_state prog S1 ->
+ exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2.
+Proof.
+ intros. inv H. econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf TRANSL); eauto.
+ rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto.
+ eapply function_ptr_translated; eauto.
+ rewrite <- H3; apply sig_preserved.
+ constructor. constructor.
+Qed.
+
+Lemma transf_final_states:
+ forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r.
+Proof.
+ intros. inv H0. inv H. inv STACKS. constructor.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
+Proof.
+ eapply forward_simulation_step.
+ apply senv_preserved.
+ eexact transf_initial_states.
+ eexact transf_final_states.
+ exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/backend/Allocation.v b/backend/Allocation.v
index cf62295d..2323c050 100644
--- a/backend/Allocation.v
+++ b/backend/Allocation.v
@@ -36,7 +36,7 @@ Require Import Op Registers RTL Locations Conventions RTLtyping LTL.
- a [Lbranch s] instruction.
The [block_shape] type below describes all possible cases of structural
- maching between an RTL instruction and an LTL basic block.
+ matching between an RTL instruction and an LTL basic block.
*)
Inductive move: Type :=
@@ -58,7 +58,7 @@ Inductive block_shape: Type :=
(mv2: moves) (s: node)
| BSopdead (op: operation) (args: list reg) (res: reg)
(mv: moves) (s: node)
- | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
+ | BSload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
(mv1: moves) (args': list mreg) (dst': mreg)
(mv2: moves) (s: node)
| BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
@@ -226,15 +226,19 @@ Definition pair_instr_block
| operation_other _ _ =>
pair_Iop_block op args res s b
end
- | Iload chunk addr args dst s =>
+ | Iload trap chunk addr args dst s =>
let (mv1, b1) := extract_moves nil b in
match b1 with
- | Lload chunk' addr' args' dst' :: b2 =>
+ | Lload trap' chunk' addr' args' dst' :: b2 =>
+ assertion (trapping_mode_eq trap' trap);
if chunk_eq chunk Mint64 && Archi.splitlong then
+ (* TODO: do not support non trapping split loads *)
+ assertion (trapping_mode_eq trap TRAP);
assertion (chunk_eq chunk' Mint32);
let (mv2, b3) := extract_moves nil b2 in
match b3 with
- | Lload chunk'' addr'' args'' dst'' :: b4 =>
+ | Lload trap'' chunk'' addr'' args'' dst'' :: b4 =>
+ assertion (trapping_mode_eq trap'' TRAP);
let (mv3, b5) := extract_moves nil b4 in
assertion (chunk_eq chunk'' Mint32);
assertion (eq_addressing addr addr');
@@ -254,7 +258,7 @@ Definition pair_instr_block
assertion (chunk_eq chunk chunk');
assertion (eq_addressing addr addr');
assertion (check_succ s b3);
- Some(BSload chunk addr args dst mv1 args' dst' mv2 s))
+ Some(BSload trap chunk addr args dst mv1 args' dst' mv2 s))
| _ =>
assertion (check_succ s b1);
Some(BSloaddead chunk addr args dst mv1 s)
@@ -310,10 +314,10 @@ Definition pair_instr_block
Some(BSbuiltin ef args res mv1 args' res' mv2 s)
| _ => None
end
- | Icond cond args s1 s2 =>
+ | Icond cond args s1 s2 i =>
let (mv1, b1) := extract_moves nil b in
match b1 with
- | Lcond cond' args' s1' s2' :: b2 =>
+ | Lcond cond' args' s1' s2' i' :: b2 =>
assertion (eq_condition cond cond');
assertion (peq s1 s1');
assertion (peq s2 s2');
@@ -734,11 +738,11 @@ Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list (rpair loc)
(** [add_equations_res] is similar but is specialized to the case where
there is only one pseudo-register. *)
-Function add_equations_res (r: reg) (oty: option typ) (p: rpair mreg) (e: eqs) : option eqs :=
- match p, oty with
+Function add_equations_res (r: reg) (ty: typ) (p: rpair mreg) (e: eqs) : option eqs :=
+ match p, ty with
| One mr, _ =>
Some (add_equation (Eq Full r (R mr)) e)
- | Twolong mr1 mr2, Some Tlong =>
+ | Twolong mr1 mr2, Tlong =>
if Archi.ptr64 then None else
Some (add_equation (Eq Low r (R mr2)) (add_equation (Eq High r (R mr1)) e))
| _, _ =>
@@ -1023,7 +1027,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv)
| BSopdead op args res mv s =>
assertion (reg_unconstrained res e);
track_moves env mv e
- | BSload chunk addr args dst mv1 args' dst' mv2 s =>
+ | BSload trap chunk addr args dst mv1 args' dst' mv2 s =>
do e1 <- track_moves env mv2 e;
do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1;
track_moves env mv1 e2
@@ -1084,7 +1088,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv)
| BStailcall sg ros args mv1 ros' =>
let args' := loc_arguments sg in
assertion (tailcall_is_possible sg);
- assertion (opt_typ_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res));
+ assertion (rettype_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res));
assertion (ros_compatible_tailcall ros');
do e1 <- add_equation_ros ros ros' empty_eqs;
do e2 <- add_equations_args args (sig_args sg) args' e1;
@@ -1114,7 +1118,7 @@ Definition transfer_aux (f: RTL.function) (env: regenv)
track_moves env mv empty_eqs
| BSreturn (Some arg) mv =>
let arg' := loc_result (RTL.fn_sig f) in
- do e1 <- add_equations_res arg (sig_res (RTL.fn_sig f)) arg' empty_eqs;
+ do e1 <- add_equations_res arg (proj_sig_res (RTL.fn_sig f)) arg' empty_eqs;
track_moves env mv e1
end.
@@ -1263,7 +1267,7 @@ Definition successors_block_shape (bsh: block_shape) : list node :=
| BShighlong src dst mv s => s :: nil
| BSop op args res mv1 args' res' mv2 s => s :: nil
| BSopdead op args res mv s => s :: nil
- | BSload chunk addr args dst mv1 args' dst' mv2 s => s :: nil
+ | BSload trap chunk addr args dst mv1 args' dst' mv2 s => s :: nil
| BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil
| BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil
| BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil
diff --git a/backend/Allocproof.v b/backend/Allocproof.v
index 1804f46b..3c7df58a 100644
--- a/backend/Allocproof.v
+++ b/backend/Allocproof.v
@@ -96,44 +96,44 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr
expand_block_shape (BSopdead op args res mv s)
(Iop op args res s)
(expand_moves mv (Lbranch s :: k))
- | ebs_load: forall chunk addr args dst mv1 args' dst' mv2 s k,
+ | ebs_load: forall trap chunk addr args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
- expand_block_shape (BSload chunk addr args dst mv1 args' dst' mv2 s)
- (Iload chunk addr args dst s)
+ expand_block_shape (BSload trap chunk addr args dst mv1 args' dst' mv2 s)
+ (Iload trap chunk addr args dst s)
(expand_moves mv1
- (Lload chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k)))
+ (Lload trap chunk addr args' dst' :: expand_moves mv2 (Lbranch s :: k)))
| ebs_load2: forall addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s k,
wf_moves mv1 -> wf_moves mv2 -> wf_moves mv3 ->
Archi.splitlong = true ->
offset_addressing addr 4 = Some addr2 ->
expand_block_shape (BSload2 addr addr2 args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s)
- (Iload Mint64 addr args dst s)
+ (Iload TRAP Mint64 addr args dst s)
(expand_moves mv1
- (Lload Mint32 addr args1' dst1' ::
+ (Lload TRAP Mint32 addr args1' dst1' ::
expand_moves mv2
- (Lload Mint32 addr2 args2' dst2' ::
+ (Lload TRAP Mint32 addr2 args2' dst2' ::
expand_moves mv3 (Lbranch s :: k))))
| ebs_load2_1: forall addr args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
Archi.splitlong = true ->
expand_block_shape (BSload2_1 addr args dst mv1 args' dst' mv2 s)
- (Iload Mint64 addr args dst s)
+ (Iload TRAP Mint64 addr args dst s)
(expand_moves mv1
- (Lload Mint32 addr args' dst' ::
+ (Lload TRAP Mint32 addr args' dst' ::
expand_moves mv2 (Lbranch s :: k)))
| ebs_load2_2: forall addr addr2 args dst mv1 args' dst' mv2 s k,
wf_moves mv1 -> wf_moves mv2 ->
Archi.splitlong = true ->
offset_addressing addr 4 = Some addr2 ->
expand_block_shape (BSload2_2 addr addr2 args dst mv1 args' dst' mv2 s)
- (Iload Mint64 addr args dst s)
+ (Iload TRAP Mint64 addr args dst s)
(expand_moves mv1
- (Lload Mint32 addr2 args' dst' ::
+ (Lload TRAP Mint32 addr2 args' dst' ::
expand_moves mv2 (Lbranch s :: k)))
- | ebs_load_dead: forall chunk addr args dst mv s k,
+ | ebs_load_dead: forall trap chunk addr args dst mv s k,
wf_moves mv ->
expand_block_shape (BSloaddead chunk addr args dst mv s)
- (Iload chunk addr args dst s)
+ (Iload trap chunk addr args dst s)
(expand_moves mv (Lbranch s :: k))
| ebs_store: forall chunk addr args src mv1 args' src' s k,
wf_moves mv1 ->
@@ -169,11 +169,11 @@ Inductive expand_block_shape: block_shape -> RTL.instruction -> LTL.bblock -> Pr
(Ibuiltin ef args res s)
(expand_moves mv1
(Lbuiltin ef args' res' :: expand_moves mv2 (Lbranch s :: k)))
- | ebs_cond: forall cond args mv args' s1 s2 k,
+ | ebs_cond: forall cond args mv args' s1 s2 k i i',
wf_moves mv ->
expand_block_shape (BScond cond args mv args' s1 s2)
- (Icond cond args s1 s2)
- (expand_moves mv (Lcond cond args' s1 s2 :: k))
+ (Icond cond args s1 s2 i)
+ (expand_moves mv (Lcond cond args' s1 s2 i' :: k))
| ebs_jumptable: forall arg mv arg' tbl k,
wf_moves mv ->
expand_block_shape (BSjumptable arg mv arg' tbl)
@@ -1301,10 +1301,10 @@ Proof.
Qed.
Lemma add_equations_res_lessdef:
- forall r oty l e e' rs ls,
- add_equations_res r oty l e = Some e' ->
+ forall r ty l e e' rs ls,
+ add_equations_res r ty l e = Some e' ->
satisf rs ls e' ->
- Val.has_type rs#r (match oty with Some ty => ty | None => Tint end) ->
+ Val.has_type rs#r ty ->
Val.lessdef rs#r (Locmap.getpair (map_rpair R l) ls).
Proof.
intros. functional inversion H; simpl.
@@ -1892,7 +1892,7 @@ Qed.
Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> signature -> Prop :=
| match_stackframes_nil: forall sg,
- sg.(sig_res) = Some Tint ->
+ sg.(sig_res) = Tint ->
match_stackframes nil nil sg
| match_stackframes_cons:
forall res f sp pc rs s tf bb ls ts sg an e env
@@ -1970,8 +1970,8 @@ Ltac UseShape :=
end.
Remark addressing_not_long:
- forall env f addr args dst s r,
- wt_instr f env (Iload Mint64 addr args dst s) -> Archi.splitlong = true ->
+ forall trap env f addr args dst s r,
+ wt_instr f env (Iload trap Mint64 addr args dst s) -> Archi.splitlong = true ->
In r args -> r <> dst.
Proof.
intros. inv H.
@@ -1981,7 +1981,7 @@ Proof.
{ rewrite <- H5. apply in_map; auto. }
assert (C: env r = Tint).
{ apply A in B. rewrite B. unfold Tptr. rewrite Archi.splitlong_ptr32 by auto. auto. }
- red; intros; subst r. rewrite C in H8; discriminate.
+ red; intros; subst r. rewrite C in H9; discriminate.
Qed.
(** The proof of semantic preservation is a simulation argument of the
@@ -2082,8 +2082,8 @@ Proof.
econstructor; eauto.
eapply wt_exec_Iop; eauto.
-(* load regular *)
-- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
+(* load regular TRAP *)
+- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]].
exploit transfer_use_def_satisf; eauto. intros [X Y].
exploit eval_addressing_lessdef; eauto. intros [a' [F G]].
@@ -2100,7 +2100,7 @@ Proof.
econstructor; eauto.
(* load pair *)
-- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
+- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2).
set (v2' := if Archi.big_endian then v2 else v1) in *.
set (v1' := if Archi.big_endian then v1 else v2) in *.
@@ -2155,7 +2155,7 @@ Proof.
econstructor; eauto.
(* load first word of a pair *)
-- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
+- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2).
set (v2' := if Archi.big_endian then v2 else v1) in *.
set (v1' := if Archi.big_endian then v1 else v2) in *.
@@ -2185,7 +2185,7 @@ Proof.
econstructor; eauto.
(* load second word of a pair *)
-- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
+- generalize (wt_exec_Iload _ _ _ _ _ _ _ _ _ _ _ _ WTI H1 WTRS). intros WTRS'.
exploit loadv_int64_split; eauto. intros (v1 & v2 & LOAD1 & LOAD2 & V1 & V2).
set (v2' := if Archi.big_endian then v2 else v1) in *.
set (v1' := if Archi.big_endian then v1 else v2) in *.
@@ -2229,6 +2229,79 @@ Proof.
econstructor; eauto.
eapply wt_exec_Iload; eauto.
+- (* load notrap1 *)
+ generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS).
+ intro WTRS'.
+ exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]].
+ exploit transfer_use_def_satisf; eauto. intros [X Y].
+ exploit eval_addressing_lessdef_none; eauto. intro Haddr.
+ exploit (exec_moves mv2); eauto. intros [ls2 [A2 B2]].
+ econstructor; split.
+ eapply plus_left. econstructor; eauto.
+ eapply star_trans. eexact A1.
+ eapply star_left. eapply exec_Lload_notrap1. rewrite <- Haddr.
+ apply eval_addressing_preserved. exact symbols_preserved. eauto.
+
+ eapply star_right. eexact A2. constructor.
+ eauto. eauto. eauto. traceEq.
+ exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]].
+ econstructor; eauto.
+
+(* load notrap1 dead *)
+- exploit exec_moves; eauto. intros [ls1 [X Y]].
+ econstructor; split.
+ eapply plus_left. econstructor; eauto.
+ eapply star_right. eexact X. econstructor; eauto.
+ eauto. traceEq.
+ exploit satisf_successors. eauto. eauto. simpl; eauto. eauto.
+ eapply reg_unconstrained_satisf; eauto.
+ intros [enext [U V]].
+ econstructor; eauto.
+ eapply wt_exec_Iload_notrap; eauto.
+
+(* load regular notrap2 *)
+- generalize (wt_exec_Iload_notrap _ _ _ _ _ _ _ _ WTI WTRS).
+ intro WTRS'.
+ exploit (exec_moves mv1); eauto. intros [ls1 [A1 B1]].
+ exploit transfer_use_def_satisf; eauto. intros [X Y].
+ exploit eval_addressing_lessdef; eauto. intros [a' [F G]].
+ destruct (Mem.loadv chunk m' a') as [v' |] eqn:Hload.
+ { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]].
+ econstructor; split.
+ eapply plus_left. econstructor; eauto.
+ eapply star_trans. eexact A1.
+ eapply star_left. econstructor. instantiate (1 := a'). rewrite <- F.
+ apply eval_addressing_preserved. exact symbols_preserved. eauto. eauto.
+ eapply star_right. eexact A2. constructor.
+ eauto. eauto. eauto. traceEq.
+ exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]].
+ econstructor; eauto.
+ }
+ { exploit (exec_moves mv2 env (rs # dst <- Vundef)); eauto. intros [ls2 [A2 B2]].
+ econstructor; split.
+ eapply plus_left. econstructor; eauto.
+ eapply star_trans. eexact A1.
+ eapply star_left. eapply exec_Lload_notrap2. rewrite <- F.
+ apply eval_addressing_preserved. exact symbols_preserved. assumption.
+ eauto.
+ eapply star_right. eexact A2. constructor.
+ eauto. eauto. eauto. traceEq.
+ exploit satisf_successors; eauto. simpl; eauto. intros [enext [U V]].
+ econstructor; eauto.
+ }
+
+- (* load notrap2 dead *)
+ exploit exec_moves; eauto. intros [ls1 [X Y]].
+ econstructor; split.
+ eapply plus_left. econstructor; eauto.
+ eapply star_right. eexact X. econstructor; eauto.
+ eauto. traceEq.
+ exploit satisf_successors. eauto. eauto. simpl; eauto. eauto.
+ eapply reg_unconstrained_satisf; eauto.
+ intros [enext [U V]].
+ econstructor; eauto.
+ eapply wt_exec_Iload_notrap; eauto.
+
(* store *)
- exploit exec_moves; eauto. intros [ls1 [X Y]].
exploit add_equations_lessdef; eauto. intros LD. simpl in LD. inv LD.
@@ -2425,13 +2498,13 @@ Proof.
(return_regs (parent_locset ts) ls1))
with (Locmap.getpair (map_rpair R (loc_result (RTL.fn_sig f))) ls1).
eapply add_equations_res_lessdef; eauto.
- rewrite H13. apply WTRS.
+ rewrite <- H14. apply WTRS.
generalize (loc_result_caller_save (RTL.fn_sig f)).
destruct (loc_result (RTL.fn_sig f)); simpl.
intros A; rewrite A; auto.
intros [A B]; rewrite A, B; auto.
apply return_regs_agree_callee_save.
- unfold proj_sig_res. rewrite <- H11; rewrite H13. apply WTRS.
+ rewrite <- H11, <- H14. apply WTRS.
(* internal function *)
- monadInv FUN. simpl in *.
@@ -2463,7 +2536,8 @@ Proof.
simpl. destruct (loc_result (ef_sig ef)) eqn:RES; simpl.
rewrite Locmap.gss; auto.
generalize (loc_result_pair (ef_sig ef)); rewrite RES; intros (A & B & C & D & E).
- exploit external_call_well_typed; eauto. unfold proj_sig_res; rewrite B. intros WTRES'.
+ assert (WTRES': Val.has_type v' Tlong).
+ { rewrite <- B. eapply external_call_well_typed; eauto. }
rewrite Locmap.gss. rewrite Locmap.gso by (red; auto). rewrite Locmap.gss.
rewrite val_longofwords_eq_1 by auto. auto.
red; intros. rewrite (AG l H0).
diff --git a/backend/Asmexpandaux.ml b/backend/Asmexpandaux.ml
index b1d822db..cc171cae 100644
--- a/backend/Asmexpandaux.ml
+++ b/backend/Asmexpandaux.ml
@@ -100,7 +100,7 @@ let translate_annot sp preg_to_dwarf annot =
| a::_ -> aux a)
let builtin_nop =
- let signature ={sig_args = []; sig_res = None; sig_cc = cc_default} in
+ let signature ={sig_args = []; sig_res = Tvoid; sig_cc = cc_default} in
let name = coqstring_of_camlstring "__builtin_nop" in
Pbuiltin(EF_builtin(name,signature),[],BR_none)
diff --git a/backend/Asmexpandaux.mli b/backend/Asmexpandaux.mli
index d80b4aec..e2320418 100644
--- a/backend/Asmexpandaux.mli
+++ b/backend/Asmexpandaux.mli
@@ -22,7 +22,7 @@ val emit: instruction -> unit
val new_label: unit -> label
(* Compute a fresh label *)
val is_current_function_variadic: unit -> bool
- (* Test wether the current function is a variadic function *)
+ (* Test whether the current function is a variadic function *)
val get_current_function_args: unit -> typ list
(* Get the types of the current function arguments *)
val get_current_function_sig: unit -> signature
@@ -33,4 +33,4 @@ val get_current_function: unit -> coq_function
(* Get the current function *)
val expand: positive -> int -> (preg -> int) -> (instruction -> unit) -> instruction list -> unit
(* Expand the instruction sequence of a function. Takes the function id, the register number of the stackpointer, a
- function to get the dwarf mapping of varibale names and for the expansion of simple instructions *)
+ function to get the dwarf mapping of variable names and for the expansion of simple instructions *)
diff --git a/backend/Asmgenproof0.v b/backend/Asmgenproof0.v
index 70c4323c..3638c465 100644
--- a/backend/Asmgenproof0.v
+++ b/backend/Asmgenproof0.v
@@ -897,6 +897,55 @@ Proof.
apply code_tail_next_int with i; auto.
Qed.
+(** A variant that supports zero steps of execution *)
+
+Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop :=
+ | exec_straight_opt_refl: forall c rs m,
+ exec_straight_opt c rs m c rs m
+ | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2,
+ exec_straight c1 rs1 m1 c2 rs2 m2 ->
+ exec_straight_opt c1 rs1 m1 c2 rs2 m2.
+
+Lemma exec_straight_opt_left:
+ forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2,
+ exec_straight c1 rs1 m1 c2 rs2 m2 ->
+ exec_straight_opt c2 rs2 m2 c3 rs3 m3 ->
+ exec_straight c1 rs1 m1 c3 rs3 m3.
+Proof.
+ destruct 2; intros. auto. eapply exec_straight_trans; eauto.
+Qed.
+
+Lemma exec_straight_opt_right:
+ forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2,
+ exec_straight_opt c1 rs1 m1 c2 rs2 m2 ->
+ exec_straight c2 rs2 m2 c3 rs3 m3 ->
+ exec_straight c1 rs1 m1 c3 rs3 m3.
+Proof.
+ destruct 1; intros. auto. eapply exec_straight_trans; eauto.
+Qed.
+
+Lemma exec_straight_opt_step:
+ forall i c rs1 m1 rs2 m2 c' rs3 m3,
+ exec_instr ge fn i rs1 m1 = Next rs2 m2 ->
+ rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one ->
+ exec_straight_opt c rs2 m2 c' rs3 m3 ->
+ exec_straight (i :: c) rs1 m1 c' rs3 m3.
+Proof.
+ intros. inv H1.
+- apply exec_straight_one; auto.
+- eapply exec_straight_step; eauto.
+Qed.
+
+Lemma exec_straight_opt_step_opt:
+ forall i c rs1 m1 rs2 m2 c' rs3 m3,
+ exec_instr ge fn i rs1 m1 = Next rs2 m2 ->
+ rs2#PC = Val.offset_ptr rs1#PC Ptrofs.one ->
+ exec_straight_opt c rs2 m2 c' rs3 m3 ->
+ exec_straight_opt (i :: c) rs1 m1 c' rs3 m3.
+Proof.
+ intros. apply exec_straight_opt_intro. eapply exec_straight_opt_step; eauto.
+Qed.
+
End STRAIGHTLINE.
(** * Properties of the Mach call stack *)
diff --git a/backend/Bounds.v b/backend/Bounds.v
index fa695234..b8c12166 100644
--- a/backend/Bounds.v
+++ b/backend/Bounds.v
@@ -67,7 +67,7 @@ Definition instr_within_bounds (i: instruction) :=
| Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r
| Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty
| Lop op args res => mreg_within_bounds res
- | Lload chunk addr args dst => mreg_within_bounds dst
+ | Lload trap chunk addr args dst => mreg_within_bounds dst
| Lcall sig ros => size_arguments sig <= bound_outgoing b
| Lbuiltin ef args res =>
(forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r)
@@ -104,7 +104,7 @@ Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t :=
| Lgetstack sl ofs ty r => record_reg u r
| Lsetstack r sl ofs ty => record_reg u r
| Lop op args res => record_reg u res
- | Lload chunk addr args dst => record_reg u dst
+ | Lload trap chunk addr args dst => record_reg u dst
| Lstore chunk addr args src => u
| Lcall sig ros => u
| Ltailcall sig ros => u
@@ -280,7 +280,7 @@ Definition defined_by_instr (r': mreg) (i: instruction) :=
match i with
| Lgetstack sl ofs ty r => r' = r
| Lop op args res => r' = res
- | Lload chunk addr args dst => r' = dst
+ | Lload trap chunk addr args dst => r' = dst
| Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef)
| _ => False
end.
diff --git a/backend/CSE.v b/backend/CSE.v
index 6d3f6f33..1936d4e4 100644
--- a/backend/CSE.v
+++ b/backend/CSE.v
@@ -14,7 +14,7 @@
proceeds by value numbering over extended basic blocks. *)
Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
-Require Import AST Linking.
+Require Import AST Linking Builtins.
Require Import Values Memory.
Require Import Op Registers RTL.
Require Import ValueDomain ValueAnalysis CSEdomain CombineOp.
@@ -444,10 +444,10 @@ Module Solver := BBlock_solver(Numbering).
([EF_external], [EF_runtime], [EF_malloc], [EF_free]).
- Forget equations involving loads but keep equations over registers.
This is appropriate for builtins that can modify memory,
- e.g. volatile stores, or [EF_builtin]
+ e.g. volatile stores, or [EF_builtin] for unknown builtin functions.
- Keep all equations, taking advantage of the fact that neither memory
- nor registers are modified. This is appropriate for annotations
- and for volatile loads.
+ nor registers are modified. This is appropriate for annotations,
+ volatile loads, and known builtin functions.
*)
Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numbering) :=
@@ -459,8 +459,10 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb
before
| Iop op args res s =>
add_op before res op args
- | Iload chunk addr args dst s =>
- add_load before dst chunk addr args
+ | Iload TRAP chunk addr args dst s =>
+ add_load before dst chunk addr args
+ | Iload NOTRAP _ _ _ dst _ =>
+ set_unknown before dst
| Istore chunk addr args src s =>
let app := approx!!pc in
let n := kill_loads_after_store app before chunk addr args in
@@ -473,8 +475,13 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb
match ef with
| EF_external _ _ | EF_runtime _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ =>
empty_numbering
- | EF_builtin _ _ | EF_vstore _ =>
+ | EF_vstore _ =>
set_res_unknown (kill_all_loads before) res
+ | EF_builtin name sg =>
+ match lookup_builtin_function name sg with
+ | Some bf => set_res_unknown before res
+ | None => set_res_unknown (kill_all_loads before) res
+ end
| EF_memcpy sz al =>
match args with
| dst :: src :: nil =>
@@ -489,7 +496,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb
| EF_vload _ | EF_annot _ _ _ | EF_annot_val _ _ _ | EF_debug _ _ _ =>
set_res_unknown before res
end
- | Icond cond args ifso ifnot =>
+ | Icond cond args ifso ifnot _ =>
before
| Ijumptable arg tbl =>
before
@@ -529,23 +536,23 @@ Definition transf_instr (n: numbering) (instr: instruction) :=
let (op', args') := reduce _ combine_op n1 op args vl in
Iop op' args' res s
end
- | Iload chunk addr args dst s =>
+ | Iload TRAP chunk addr args dst s =>
let (n1, vl) := valnum_regs n args in
match find_rhs n1 (Load chunk addr vl) with
| Some r =>
Iop Omove (r :: nil) dst s
| None =>
let (addr', args') := reduce _ combine_addr n1 addr args vl in
- Iload chunk addr' args' dst s
+ Iload TRAP chunk addr' args' dst s
end
| Istore chunk addr args src s =>
let (n1, vl) := valnum_regs n args in
let (addr', args') := reduce _ combine_addr n1 addr args vl in
Istore chunk addr' args' src s
- | Icond cond args s1 s2 =>
+ | Icond cond args s1 s2 i =>
let (n1, vl) := valnum_regs n args in
let (cond', args') := reduce _ combine_cond n1 cond args vl in
- Icond cond' args' s1 s2
+ Icond cond' args' s1 s2 i
| _ =>
instr
end.
diff --git a/backend/CSE2.v b/backend/CSE2.v
new file mode 100644
index 00000000..d9fe5799
--- /dev/null
+++ b/backend/CSE2.v
@@ -0,0 +1,514 @@
+(*
+Replace available expressions by the register containing their value.
+
+David Monniaux, CNRS, VERIMAG
+ *)
+
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps CSE2deps.
+
+(* Static analysis *)
+
+Inductive sym_val : Type :=
+| SMove (src : reg)
+| SOp (op : operation) (args : list reg)
+| SLoad (chunk : memory_chunk) (addr : addressing) (args : list reg).
+
+Definition eq_args (x y : list reg) : { x = y } + { x <> y } :=
+ list_eq_dec peq x y.
+
+Definition eq_sym_val : forall x y : sym_val,
+ {x = y} + { x <> y }.
+Proof.
+ generalize eq_operation.
+ generalize eq_args.
+ generalize peq.
+ generalize eq_addressing.
+ generalize chunk_eq.
+ decide equality.
+Defined.
+
+Module RELATION.
+
+Definition t := (PTree.t sym_val).
+Definition eq (r1 r2 : t) :=
+ forall x, (PTree.get x r1) = (PTree.get x r2).
+
+Definition top : t := PTree.empty sym_val.
+
+Lemma eq_refl: forall x, eq x x.
+Proof.
+ unfold eq.
+ intros; reflexivity.
+Qed.
+
+Lemma eq_sym: forall x y, eq x y -> eq y x.
+Proof.
+ unfold eq.
+ intros; eauto.
+Qed.
+
+Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+Proof.
+ unfold eq.
+ intros; congruence.
+Qed.
+
+Definition sym_val_beq (x y : sym_val) :=
+ if eq_sym_val x y then true else false.
+
+Definition beq (r1 r2 : t) := PTree.beq sym_val_beq r1 r2.
+
+Lemma beq_correct: forall r1 r2, beq r1 r2 = true -> eq r1 r2.
+Proof.
+ unfold beq, eq. intros r1 r2 EQ x.
+ pose proof (PTree.beq_correct sym_val_beq r1 r2) as CORRECT.
+ destruct CORRECT as [CORRECTF CORRECTB].
+ pose proof (CORRECTF EQ x) as EQx.
+ clear CORRECTF CORRECTB EQ.
+ unfold sym_val_beq in *.
+ destruct (r1 ! x) as [R1x | ] in *;
+ destruct (r2 ! x) as [R2x | ] in *;
+ trivial; try contradiction.
+ destruct (eq_sym_val R1x R2x) in *; congruence.
+Qed.
+
+Definition ge (r1 r2 : t) :=
+ forall x,
+ match PTree.get x r1 with
+ | None => True
+ | Some v => (PTree.get x r2) = Some v
+ end.
+
+Lemma ge_refl: forall r1 r2, eq r1 r2 -> ge r1 r2.
+Proof.
+ unfold eq, ge.
+ intros r1 r2 EQ x.
+ pose proof (EQ x) as EQx.
+ clear EQ.
+ destruct (r1 ! x).
+ - congruence.
+ - trivial.
+Qed.
+
+Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+Proof.
+ unfold ge.
+ intros r1 r2 r3 GE12 GE23 x.
+ pose proof (GE12 x) as GE12x; clear GE12.
+ pose proof (GE23 x) as GE23x; clear GE23.
+ destruct (r1 ! x); trivial.
+ destruct (r2 ! x); congruence.
+Qed.
+
+Definition lub (r1 r2 : t) :=
+ PTree.combine
+ (fun ov1 ov2 =>
+ match ov1, ov2 with
+ | (Some v1), (Some v2) =>
+ if eq_sym_val v1 v2
+ then ov1
+ else None
+ | None, _
+ | _, None => None
+ end)
+ r1 r2.
+
+Lemma ge_lub_left: forall x y, ge (lub x y) x.
+Proof.
+ unfold ge, lub.
+ intros r1 r2 x.
+ rewrite PTree.gcombine by reflexivity.
+ destruct (_ ! _); trivial.
+ destruct (_ ! _); trivial.
+ destruct (eq_sym_val _ _); trivial.
+Qed.
+
+Lemma ge_lub_right: forall x y, ge (lub x y) y.
+Proof.
+ unfold ge, lub.
+ intros r1 r2 x.
+ rewrite PTree.gcombine by reflexivity.
+ destruct (_ ! _); trivial.
+ destruct (_ ! _); trivial.
+ destruct (eq_sym_val _ _); trivial.
+ congruence.
+Qed.
+
+End RELATION.
+
+Module Type SEMILATTICE_WITHOUT_BOTTOM.
+
+ Parameter t: Type.
+ Parameter eq: t -> t -> Prop.
+ Axiom eq_refl: forall x, eq x x.
+ Axiom eq_sym: forall x y, eq x y -> eq y x.
+ Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Parameter beq: t -> t -> bool.
+ Axiom beq_correct: forall x y, beq x y = true -> eq x y.
+ Parameter ge: t -> t -> Prop.
+ Axiom ge_refl: forall x y, eq x y -> ge x y.
+ Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Parameter lub: t -> t -> t.
+ Axiom ge_lub_left: forall x y, ge (lub x y) x.
+ Axiom ge_lub_right: forall x y, ge (lub x y) y.
+
+End SEMILATTICE_WITHOUT_BOTTOM.
+
+Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM).
+ Definition t := option L.t.
+ Definition eq (a b : t) :=
+ match a, b with
+ | None, None => True
+ | Some x, Some y => L.eq x y
+ | Some _, None | None, Some _ => False
+ end.
+
+ Lemma eq_refl: forall x, eq x x.
+ Proof.
+ unfold eq; destruct x; trivial.
+ apply L.eq_refl.
+ Qed.
+
+ Lemma eq_sym: forall x y, eq x y -> eq y x.
+ Proof.
+ unfold eq; destruct x; destruct y; trivial.
+ apply L.eq_sym.
+ Qed.
+
+ Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Proof.
+ unfold eq; destruct x; destruct y; destruct z; trivial.
+ - apply L.eq_trans.
+ - contradiction.
+ Qed.
+
+ Definition beq (x y : t) :=
+ match x, y with
+ | None, None => true
+ | Some x, Some y => L.beq x y
+ | Some _, None | None, Some _ => false
+ end.
+
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof.
+ unfold beq, eq.
+ destruct x; destruct y; trivial; try congruence.
+ apply L.beq_correct.
+ Qed.
+
+ Definition ge (x y : t) :=
+ match x, y with
+ | None, Some _ => False
+ | _, None => True
+ | Some a, Some b => L.ge a b
+ end.
+
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof.
+ unfold eq, ge.
+ destruct x; destruct y; trivial.
+ apply L.ge_refl.
+ Qed.
+
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof.
+ unfold ge.
+ destruct x; destruct y; destruct z; trivial; try contradiction.
+ apply L.ge_trans.
+ Qed.
+
+ Definition bot: t := None.
+ Lemma ge_bot: forall x, ge x bot.
+ Proof.
+ unfold ge, bot.
+ destruct x; trivial.
+ Qed.
+
+ Definition lub (a b : t) :=
+ match a, b with
+ | None, _ => b
+ | _, None => a
+ | (Some x), (Some y) => Some (L.lub x y)
+ end.
+
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof.
+ unfold ge, lub.
+ destruct x; destruct y; trivial.
+ - apply L.ge_lub_left.
+ - apply L.ge_refl.
+ apply L.eq_refl.
+ Qed.
+
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof.
+ unfold ge, lub.
+ destruct x; destruct y; trivial.
+ - apply L.ge_lub_right.
+ - apply L.ge_refl.
+ apply L.eq_refl.
+ Qed.
+End ADD_BOTTOM.
+
+Module RB := ADD_BOTTOM(RELATION).
+Module DS := Dataflow_Solver(RB)(NodeSetForward).
+
+Definition kill_sym_val (dst : reg) (sv : sym_val) :=
+ match sv with
+ | SMove src => if peq dst src then true else false
+ | SOp op args => List.existsb (peq dst) args
+ | SLoad chunk addr args => List.existsb (peq dst) args
+ end.
+
+Definition kill_reg (dst : reg) (rel : RELATION.t) :=
+ PTree.filter1 (fun x => negb (kill_sym_val dst x))
+ (PTree.remove dst rel).
+
+Definition kill_sym_val_mem (sv: sym_val) :=
+ match sv with
+ | SMove _ => false
+ | SOp op _ => op_depends_on_memory op
+ | SLoad _ _ _ => true
+ end.
+
+Definition kill_sym_val_store chunk addr args (sv: sym_val) :=
+ match sv with
+ | SMove _ => false
+ | SOp op _ => op_depends_on_memory op
+ | SLoad chunk' addr' args' => may_overlap chunk addr args chunk' addr' args'
+ end.
+
+Definition kill_mem (rel : RELATION.t) :=
+ PTree.filter1 (fun x => negb (kill_sym_val_mem x)) rel.
+
+Definition forward_move (rel : RELATION.t) (x : reg) : reg :=
+ match rel ! x with
+ | Some (SMove org) => org
+ | _ => x
+ end.
+
+Definition kill_store1 chunk addr args rel :=
+ PTree.filter1 (fun x => negb (kill_sym_val_store chunk addr args x)) rel.
+
+Definition kill_store chunk addr args rel :=
+ kill_store1 chunk addr (List.map (forward_move rel) args) rel.
+
+Definition move (src dst : reg) (rel : RELATION.t) :=
+ PTree.set dst (SMove (forward_move rel src)) (kill_reg dst rel).
+
+Definition find_op_fold op args (already : option reg) x sv :=
+ match already with
+ | Some found => already
+ | None =>
+ match sv with
+ | (SOp op' args') =>
+ if (eq_operation op op') && (eq_args args args')
+ then Some x
+ else None
+ | _ => None
+ end
+ end.
+
+Definition find_op (rel : RELATION.t) (op : operation) (args : list reg) :=
+ PTree.fold (find_op_fold op args) rel None.
+
+Definition find_load_fold chunk addr args (already : option reg) x sv :=
+ match already with
+ | Some found => already
+ | None =>
+ match sv with
+ | (SLoad chunk' addr' args') =>
+ if (chunk_eq chunk chunk') &&
+ (eq_addressing addr addr') &&
+ (eq_args args args')
+ then Some x
+ else None
+ | _ => None
+ end
+ end.
+
+Definition find_load (rel : RELATION.t) (chunk : memory_chunk) (addr : addressing) (args : list reg) :=
+ PTree.fold (find_load_fold chunk addr args) rel None.
+
+Definition oper2 (op: operation) (dst : reg) (args : list reg)
+ (rel : RELATION.t) :=
+ let rel' := kill_reg dst rel in
+ PTree.set dst (SOp op (List.map (forward_move rel') args)) rel'.
+
+Definition oper1 (op: operation) (dst : reg) (args : list reg)
+ (rel : RELATION.t) :=
+ if List.in_dec peq dst args
+ then kill_reg dst rel
+ else oper2 op dst args rel.
+
+Definition oper (op: operation) (dst : reg) (args : list reg)
+ (rel : RELATION.t) :=
+ match find_op rel op (List.map (forward_move rel) args) with
+ | Some r => move r dst rel
+ | None => oper1 op dst args rel
+ end.
+
+Definition gen_oper (op: operation) (dst : reg) (args : list reg)
+ (rel : RELATION.t) :=
+ match op, args with
+ | Omove, src::nil => move src dst rel
+ | _, _ => oper op dst args rel
+ end.
+
+Definition load2 (chunk: memory_chunk) (addr : addressing)
+ (dst : reg) (args : list reg) (rel : RELATION.t) :=
+ let rel' := kill_reg dst rel in
+ PTree.set dst (SLoad chunk addr (List.map (forward_move rel') args)) rel'.
+
+Definition load1 (chunk: memory_chunk) (addr : addressing)
+ (dst : reg) (args : list reg) (rel : RELATION.t) :=
+ if List.in_dec peq dst args
+ then kill_reg dst rel
+ else load2 chunk addr dst args rel.
+
+Definition load (chunk: memory_chunk) (addr : addressing)
+ (dst : reg) (args : list reg) (rel : RELATION.t) :=
+ match find_load rel chunk addr (List.map (forward_move rel) args) with
+ | Some r => move r dst rel
+ | None => load1 chunk addr dst args rel
+ end.
+
+Fixpoint kill_builtin_res res rel :=
+ match res with
+ | BR r => kill_reg r rel
+ | _ => rel
+ end.
+
+Definition apply_external_call ef (rel : RELATION.t) : RELATION.t :=
+ match ef with
+ | EF_builtin name sg
+ | EF_runtime name sg =>
+ match Builtins.lookup_builtin_function name sg with
+ | Some bf => rel
+ | None => kill_mem rel
+ end
+ | EF_malloc (* FIXME *)
+ | EF_external _ _
+ | EF_vstore _
+ | EF_free (* FIXME *)
+ | EF_memcpy _ _ (* FIXME *)
+ | EF_inline_asm _ _ _ => kill_mem rel
+ | _ => rel
+ end.
+
+Definition apply_instr instr (rel : RELATION.t) : RB.t :=
+ match instr with
+ | Inop _
+ | Icond _ _ _ _ _
+ | Ijumptable _ _ => Some rel
+ | Istore chunk addr args _ _ => Some (kill_store chunk addr args rel)
+ | Iop op args dst _ => Some (gen_oper op dst args rel)
+ | Iload trap chunk addr args dst _ => Some (load chunk addr dst args rel)
+ | Icall _ _ _ dst _ => Some (kill_reg dst (kill_mem rel))
+ | Ibuiltin ef _ res _ => Some (kill_builtin_res res (apply_external_call ef rel))
+ | Itailcall _ _ _ | Ireturn _ => RB.bot
+ end.
+
+Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t :=
+ match ro with
+ | None => None
+ | Some x =>
+ match code ! pc with
+ | None => RB.bot
+ | Some instr => apply_instr instr x
+ end
+ end.
+
+Definition forward_map (f : RTL.function) := DS.fixpoint
+ (RTL.fn_code f) RTL.successors_instr
+ (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top).
+
+Definition forward_move_b (rb : RB.t) (x : reg) :=
+ match rb with
+ | None => x
+ | Some rel => forward_move rel x
+ end.
+
+Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg :=
+ match fmap with
+ | None => x
+ | Some inv => forward_move_b (PMap.get pc inv) x
+ end.
+
+Definition subst_args fmap pc := List.map (subst_arg fmap pc).
+
+(* Transform *)
+Definition find_op_in_fmap fmap pc op args :=
+ match fmap with
+ | None => None
+ | Some map =>
+ match PMap.get pc map with
+ | Some rel => find_op rel op args
+ | None => None
+ end
+ end.
+
+Definition find_load_in_fmap fmap pc chunk addr args :=
+ match fmap with
+ | None => None
+ | Some map =>
+ match PMap.get pc map with
+ | Some rel => find_load rel chunk addr args
+ | None => None
+ end
+ end.
+
+Definition transf_instr (fmap : option (PMap.t RB.t))
+ (pc: node) (instr: instruction) :=
+ match instr with
+ | Iop op args dst s =>
+ let args' := subst_args fmap pc args in
+ match (if is_trivial_op op then None else find_op_in_fmap fmap pc op args') with
+ | None => Iop op args' dst s
+ | Some src => Iop Omove (src::nil) dst s
+ end
+ | Iload trap chunk addr args dst s =>
+ let args' := subst_args fmap pc args in
+ match find_load_in_fmap fmap pc chunk addr args' with
+ | None => Iload trap chunk addr args' dst s
+ | Some src => Iop Omove (src::nil) dst s
+ end
+ | Istore chunk addr args src s =>
+ Istore chunk addr (subst_args fmap pc args) src s
+ | Icall sig ros args dst s =>
+ Icall sig ros (subst_args fmap pc args) dst s
+ | Itailcall sig ros args =>
+ Itailcall sig ros (subst_args fmap pc args)
+ | Icond cond args s1 s2 i =>
+ Icond cond (subst_args fmap pc args) s1 s2 i
+ | Ijumptable arg tbl =>
+ Ijumptable (subst_arg fmap pc arg) tbl
+ | Ireturn (Some arg) =>
+ Ireturn (Some (subst_arg fmap pc arg))
+ | _ => instr
+ end.
+
+Definition transf_function (f: function) : function :=
+ {| fn_sig := f.(fn_sig);
+ fn_params := f.(fn_params);
+ fn_stacksize := f.(fn_stacksize);
+ fn_code := PTree.map (transf_instr (forward_map f)) f.(fn_code);
+ fn_entrypoint := f.(fn_entrypoint) |}.
+
+
+Definition transf_fundef (fd: fundef) : fundef :=
+ AST.transf_fundef transf_function fd.
+
+Definition transf_program (p: program) : program :=
+ transform_program transf_fundef p.
+
+Definition match_prog (p tp: RTL.program) :=
+ match_program (fun ctx f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p, match_prog p (transf_program p).
+Proof.
+ intros. eapply match_transform_program; eauto.
+Qed.
diff --git a/backend/CSE2proof.v b/backend/CSE2proof.v
new file mode 100644
index 00000000..9e0ad909
--- /dev/null
+++ b/backend/CSE2proof.v
@@ -0,0 +1,1740 @@
+(*
+Replace available expressions by the register containing their value.
+
+Proofs.
+
+David Monniaux, CNRS, VERIMAG
+ *)
+
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps CSE2depsproof.
+Require Import Lia.
+
+Lemma args_unaffected:
+ forall rs : regset,
+ forall dst : reg,
+ forall v,
+ forall args : list reg,
+ existsb (fun y : reg => peq dst y) args = false ->
+ (rs # dst <- v ## args) = (rs ## args).
+Proof.
+ induction args; simpl; trivial.
+ destruct (peq dst a) as [EQ | NEQ]; simpl.
+ { discriminate.
+ }
+ intro EXIST.
+ f_equal.
+ {
+ apply Regmap.gso.
+ congruence.
+ }
+ apply IHargs.
+ assumption.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section SAME_MEMORY.
+ Variable m : mem.
+
+Definition sem_sym_val sym rs (v : option val) : Prop :=
+ match sym with
+ | SMove src => v = Some (rs # src)
+ | SOp op args =>
+ v = (eval_operation genv sp op (rs ## args) m)
+ | SLoad chunk addr args =>
+ match eval_addressing genv sp addr rs##args with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => v = Some dat
+ | None => v = None \/ v = Some Vundef
+ end
+ | None => v = None \/ v = Some Vundef
+ end
+ end.
+
+Definition sem_reg (rel : RELATION.t) (x : reg) (rs : regset) (v : val) : Prop :=
+ match rel ! x with
+ | None => True
+ | Some sym => sem_sym_val sym rs (Some (rs # x))
+ end.
+
+Definition sem_rel (rel : RELATION.t) (rs : regset) :=
+ forall x : reg, (sem_reg rel x rs (rs # x)).
+
+Definition sem_rel_b (relb : RB.t) (rs : regset) :=
+ match relb with
+ | Some rel => sem_rel rel rs
+ | None => False
+ end.
+
+Definition fmap_sem (fmap : option (PMap.t RB.t))
+ (pc : node) (rs : regset) :=
+ match fmap with
+ | None => True
+ | Some m => sem_rel_b (PMap.get pc m) rs
+ end.
+
+Lemma subst_arg_ok:
+ forall f,
+ forall pc,
+ forall rs,
+ forall arg,
+ fmap_sem (forward_map f) pc rs ->
+ rs # (subst_arg (forward_map f) pc arg) = rs # arg.
+Proof.
+ intros until arg.
+ intro SEM.
+ unfold fmap_sem in SEM.
+ destruct (forward_map f) as [map |]in *; trivial.
+ simpl.
+ unfold sem_rel_b, sem_rel, sem_reg in *.
+ destruct (map # pc).
+ 2: contradiction.
+ pose proof (SEM arg) as SEMarg.
+ simpl. unfold forward_move.
+ unfold sem_sym_val in *.
+ destruct (t ! arg); trivial.
+ destruct s; congruence.
+Qed.
+
+Lemma subst_args_ok:
+ forall f,
+ forall pc,
+ forall rs,
+ fmap_sem (forward_map f) pc rs ->
+ forall args,
+ rs ## (subst_args (forward_map f) pc args) = rs ## args.
+Proof.
+ induction args; trivial.
+ simpl.
+ f_equal.
+ apply subst_arg_ok; assumption.
+ assumption.
+Qed.
+
+Lemma kill_reg_sound :
+ forall rel : RELATION.t,
+ forall dst : reg,
+ forall rs,
+ forall v,
+ sem_rel rel rs ->
+ sem_rel (kill_reg dst rel) (rs # dst <- v).
+Proof.
+ unfold sem_rel, kill_reg, sem_reg, sem_sym_val.
+ intros until v.
+ intros REL x.
+ rewrite PTree.gfilter1.
+ destruct (Pos.eq_dec dst x).
+ {
+ subst x.
+ rewrite PTree.grs.
+ trivial.
+ }
+ rewrite PTree.gro by congruence.
+ rewrite Regmap.gso by congruence.
+ destruct (rel ! x) as [relx | ] eqn:RELx; trivial.
+ unfold kill_sym_val.
+ pose proof (REL x) as RELinstx.
+ rewrite RELx in RELinstx.
+ destruct relx eqn:SYMVAL.
+ {
+ destruct (peq dst src); simpl.
+ { reflexivity. }
+ rewrite Regmap.gso by congruence.
+ assumption.
+ }
+ { destruct existsb eqn:EXISTS; simpl.
+ { reflexivity. }
+ rewrite args_unaffected by exact EXISTS.
+ assumption.
+ }
+ { destruct existsb eqn:EXISTS; simpl.
+ { reflexivity. }
+ rewrite args_unaffected by exact EXISTS.
+ assumption.
+ }
+Qed.
+
+Lemma write_same:
+ forall rs : regset,
+ forall src dst : reg,
+ (rs # dst <- (rs # src)) # src = rs # src.
+Proof.
+ intros.
+ destruct (peq src dst).
+ {
+ subst dst.
+ apply Regmap.gss.
+ }
+ rewrite Regmap.gso by congruence.
+ reflexivity.
+Qed.
+
+Lemma move_sound :
+ forall rel : RELATION.t,
+ forall src dst : reg,
+ forall rs,
+ sem_rel rel rs ->
+ sem_rel (move src dst rel) (rs # dst <- (rs # src)).
+Proof.
+ intros until rs. intros REL x.
+ pose proof (kill_reg_sound rel dst rs (rs # src) REL x) as KILL.
+ pose proof (REL src) as RELsrc.
+ unfold move.
+ destruct (peq x dst).
+ {
+ subst x.
+ unfold sem_reg.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ unfold sem_reg in *.
+ simpl.
+ unfold forward_move.
+ destruct (rel ! src) as [ sv |]; simpl.
+ destruct sv eqn:SV; simpl in *.
+ {
+ destruct (peq dst src0).
+ {
+ subst src0.
+ rewrite Regmap.gss.
+ reflexivity.
+ }
+ rewrite Regmap.gso by congruence.
+ assumption.
+ }
+ all: f_equal; symmetry; apply write_same.
+ }
+ rewrite Regmap.gso by congruence.
+ unfold sem_reg.
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso in KILL by congruence.
+ exact KILL.
+Qed.
+
+Lemma move_cases_neq:
+ forall dst rel a,
+ a <> dst ->
+ (forward_move (kill_reg dst rel) a) <> dst.
+Proof.
+ intros until a. intro NEQ.
+ unfold kill_reg, forward_move.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by congruence.
+ destruct (rel ! a); simpl.
+ 2: congruence.
+ destruct s.
+ {
+ unfold kill_sym_val.
+ destruct peq; simpl; congruence.
+ }
+ all: simpl;
+ destruct negb; simpl; congruence.
+Qed.
+
+Lemma args_replace_dst :
+ forall rel,
+ forall args : list reg,
+ forall dst : reg,
+ forall rs : regset,
+ forall v,
+ (sem_rel rel rs) ->
+ not (In dst args) ->
+ (rs # dst <- v)
+ ## (map
+ (forward_move (kill_reg dst rel)) args) = rs ## args.
+Proof.
+ induction args; simpl.
+ 1: reflexivity.
+ intros until v.
+ intros REL NOT_IN.
+ rewrite IHargs by auto.
+ f_equal.
+ pose proof (REL a) as RELa.
+ rewrite Regmap.gso by (apply move_cases_neq; auto).
+ unfold kill_reg.
+ unfold sem_reg in RELa.
+ unfold forward_move.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by auto.
+ destruct (rel ! a); simpl; trivial.
+ destruct s; simpl in *; destruct negb; simpl; congruence.
+Qed.
+
+Lemma oper2_sound :
+ forall rel : RELATION.t,
+ forall op : operation,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall v,
+ sem_rel rel rs ->
+ not (In dst args) ->
+ eval_operation genv sp op (rs ## args) m = Some v ->
+ sem_rel (oper2 op dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL NOT_IN EVAL x.
+ pose proof (kill_reg_sound rel dst rs v REL x) as KILL.
+ unfold oper2.
+ destruct (peq x dst).
+ {
+ subst x.
+ unfold sem_reg.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ simpl.
+ rewrite args_replace_dst by auto.
+ symmetry.
+ assumption.
+ }
+ rewrite Regmap.gso by congruence.
+ unfold sem_reg.
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso in KILL by congruence.
+ exact KILL.
+Qed.
+
+Lemma oper1_sound :
+ forall rel : RELATION.t,
+ forall op : operation,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall v,
+ sem_rel rel rs ->
+ eval_operation genv sp op (rs ## args) m = Some v ->
+ sem_rel (oper1 op dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL EVAL.
+ unfold oper1.
+ destruct in_dec.
+ {
+ apply kill_reg_sound; auto.
+ }
+ apply oper2_sound; auto.
+Qed.
+
+Lemma find_op_sound :
+ forall rel : RELATION.t,
+ forall op : operation,
+ forall src : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ find_op rel op args = Some src ->
+ (eval_operation genv sp op (rs ## args) m) = Some (rs # src).
+Proof.
+ intros until rs.
+ unfold find_op.
+ rewrite PTree.fold_spec.
+ intro REL.
+ assert (
+ forall start,
+ match start with
+ | None => True
+ | Some src => eval_operation genv sp op rs ## args m = Some rs # src
+ end -> fold_left
+ (fun (a : option reg) (p : positive * sym_val) =>
+ find_op_fold op args a (fst p) (snd p)) (PTree.elements rel) start =
+ Some src ->
+ eval_operation genv sp op rs ## args m = Some rs # src) as REC.
+ {
+ unfold sem_rel, sem_reg in REL.
+ generalize (PTree.elements_complete rel).
+ generalize (PTree.elements rel).
+ induction l; simpl.
+ {
+ intros.
+ subst start.
+ assumption.
+ }
+ destruct a as [r sv]; simpl.
+ intros COMPLETE start GEN.
+ apply IHl.
+ {
+ intros.
+ apply COMPLETE.
+ right.
+ assumption.
+ }
+ unfold find_op_fold.
+ destruct start.
+ assumption.
+ destruct sv; trivial.
+ destruct eq_operation; trivial.
+ subst op0.
+ destruct eq_args; trivial.
+ subst args0.
+ simpl.
+ assert ((rel ! r) = Some (SOp op args)) as RELatr.
+ {
+ apply COMPLETE.
+ left.
+ reflexivity.
+ }
+ pose proof (REL r) as RELr.
+ rewrite RELatr in RELr.
+ simpl in RELr.
+ symmetry.
+ assumption.
+ }
+ apply REC; auto.
+Qed.
+
+
+Lemma find_load_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall src : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ find_load rel chunk addr args = Some src ->
+ match eval_addressing genv sp addr rs##args with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end.
+Proof.
+ intros until rs.
+ unfold find_load.
+ rewrite PTree.fold_spec.
+ intro REL.
+ assert (
+ forall start,
+ match start with
+ | None => True
+ | Some src =>
+ match eval_addressing genv sp addr rs##args with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end
+ end ->
+ fold_left
+ (fun (a : option reg) (p : positive * sym_val) =>
+ find_load_fold chunk addr args a (fst p) (snd p)) (PTree.elements rel) start =
+ Some src ->
+ match eval_addressing genv sp addr rs##args with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end) as REC.
+
+ {
+ unfold sem_rel, sem_reg in REL.
+ generalize (PTree.elements_complete rel).
+ generalize (PTree.elements rel).
+ induction l; simpl.
+ {
+ intros.
+ subst start.
+ assumption.
+ }
+ destruct a as [r sv]; simpl.
+ intros COMPLETE start GEN.
+ apply IHl.
+ {
+ intros.
+ apply COMPLETE.
+ right.
+ assumption.
+ }
+ unfold find_load_fold.
+ destruct start.
+ assumption.
+ destruct sv; trivial.
+ destruct chunk_eq; trivial.
+ subst chunk0.
+ destruct eq_addressing; trivial.
+ subst addr0.
+ destruct eq_args; trivial.
+ subst args0.
+ simpl.
+ assert ((rel ! r) = Some (SLoad chunk addr args)) as RELatr.
+ {
+ apply COMPLETE.
+ left.
+ reflexivity.
+ }
+ pose proof (REL r) as RELr.
+ rewrite RELatr in RELr.
+ simpl in RELr.
+ destruct eval_addressing.
+ { destruct Mem.loadv.
+ congruence.
+ destruct RELr; congruence.
+ }
+ destruct RELr; congruence.
+ }
+ apply REC; auto.
+Qed.
+
+
+Lemma find_load_sound' :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall src : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ forall v,
+ sem_rel rel rs ->
+ find_load rel chunk addr args = Some src ->
+ eval_addressing genv sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ v = rs # src.
+Proof.
+ intros until v. intros REL FINDLOAD ADDR LOAD.
+ pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z.
+ destruct eval_addressing in *.
+ {
+ replace a with v0 in * by congruence.
+ destruct Mem.loadv in * ; congruence.
+ }
+ discriminate.
+Qed.
+
+Lemma find_load_notrap1_sound' :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall src : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ find_load rel chunk addr args = Some src ->
+ eval_addressing genv sp addr rs##args = None ->
+ rs # src = Vundef.
+Proof.
+ intros until rs. intros REL FINDLOAD ADDR.
+ pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z.
+ rewrite ADDR in Z.
+ assumption.
+Qed.
+
+Lemma find_load_notrap2_sound' :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall src : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ sem_rel rel rs ->
+ find_load rel chunk addr args = Some src ->
+ eval_addressing genv sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = None ->
+ rs # src = Vundef.
+Proof.
+ intros until a. intros REL FINDLOAD ADDR LOAD.
+ pose proof (find_load_sound rel chunk addr src args rs REL FINDLOAD) as Z.
+ rewrite ADDR in Z.
+ destruct Mem.loadv.
+ discriminate.
+ assumption.
+Qed.
+
+Lemma forward_move_map:
+ forall rel args rs,
+ sem_rel rel rs ->
+ rs ## (map (forward_move rel) args) = rs ## args.
+Proof.
+ induction args; simpl; trivial.
+ intros rs REL.
+ f_equal.
+ 2: (apply IHargs; assumption).
+ unfold forward_move, sem_rel, sem_reg, sem_sym_val in *.
+ pose proof (REL a) as RELa.
+ destruct (rel ! a); trivial.
+ destruct s; congruence.
+Qed.
+
+
+Lemma forward_move_rs:
+ forall rel arg rs,
+ sem_rel rel rs ->
+ rs # (forward_move rel arg) = rs # arg.
+Proof.
+ unfold forward_move, sem_rel, sem_reg, sem_sym_val in *.
+ intros until rs.
+ intro REL.
+ pose proof (REL arg) as RELarg.
+ destruct (rel ! arg); trivial.
+ destruct s; congruence.
+Qed.
+
+Lemma oper_sound :
+ forall rel : RELATION.t,
+ forall op : operation,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall v,
+ sem_rel rel rs ->
+ eval_operation genv sp op (rs ## args) m = Some v ->
+ sem_rel (oper op dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL EVAL.
+ unfold oper.
+ destruct find_op eqn:FIND.
+ {
+ assert (eval_operation genv sp op rs ## (map (forward_move rel) args) m = Some rs # r) as FIND_OP.
+ {
+ apply (find_op_sound rel); trivial.
+ }
+ rewrite forward_move_map in FIND_OP by assumption.
+ replace v with (rs # r) by congruence.
+ apply move_sound; auto.
+ }
+ apply oper1_sound; trivial.
+Qed.
+
+Lemma gen_oper_sound :
+ forall rel : RELATION.t,
+ forall op : operation,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall v,
+ sem_rel rel rs ->
+ eval_operation genv sp op (rs ## args) m = Some v ->
+ sem_rel (gen_oper op dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL EVAL.
+ unfold gen_oper.
+ destruct op.
+ { destruct args as [ | h0 t0].
+ apply oper_sound; auto.
+ destruct t0.
+ {
+ simpl in *.
+ replace v with (rs # h0) by congruence.
+ apply move_sound; auto.
+ }
+ apply oper_sound; auto.
+ }
+ all: apply oper_sound; auto.
+Qed.
+
+
+Lemma load2_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ forall v,
+ sem_rel rel rs ->
+ not (In dst args) ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ sem_rel (load2 chunk addr dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL NOT_IN ADDR LOAD x.
+ pose proof (kill_reg_sound rel dst rs v REL x) as KILL.
+ unfold load2.
+ destruct (peq x dst).
+ {
+ subst x.
+ unfold sem_reg.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ simpl.
+ rewrite args_replace_dst by auto.
+ destruct eval_addressing.
+ {
+ replace a with v0 in * by congruence.
+ destruct Mem.loadv; congruence.
+ }
+ discriminate.
+ }
+ rewrite Regmap.gso by congruence.
+ unfold sem_reg.
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso in KILL by congruence.
+ exact KILL.
+Qed.
+
+Lemma load2_notrap1_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ not (In dst args) ->
+ eval_addressing genv sp addr (rs ## args) = None ->
+ sem_rel (load2 chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until rs.
+ intros REL NOT_IN ADDR x.
+ pose proof (kill_reg_sound rel dst rs Vundef REL x) as KILL.
+ unfold load2.
+ destruct (peq x dst).
+ {
+ subst x.
+ unfold sem_reg.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ simpl.
+ rewrite args_replace_dst by auto.
+ rewrite ADDR.
+ right.
+ trivial.
+ }
+ rewrite Regmap.gso by congruence.
+ unfold sem_reg.
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso in KILL by congruence.
+ exact KILL.
+Qed.
+
+Lemma load2_notrap2_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ sem_rel rel rs ->
+ not (In dst args) ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = None ->
+ sem_rel (load2 chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until a.
+ intros REL NOT_IN ADDR LOAD x.
+ pose proof (kill_reg_sound rel dst rs Vundef REL x) as KILL.
+ unfold load2.
+ destruct (peq x dst).
+ {
+ subst x.
+ unfold sem_reg.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ simpl.
+ rewrite args_replace_dst by auto.
+ rewrite ADDR.
+ rewrite LOAD.
+ right; trivial.
+ }
+ rewrite Regmap.gso by congruence.
+ unfold sem_reg.
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso in KILL by congruence.
+ exact KILL.
+Qed.
+
+Lemma load1_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ forall v,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ sem_rel (load1 chunk addr dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL ADDR LOAD.
+ unfold load1.
+ destruct in_dec.
+ {
+ apply kill_reg_sound; auto.
+ }
+ apply load2_sound with (a := a); auto.
+Qed.
+
+Lemma load1_notrap1_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = None ->
+ sem_rel (load1 chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until rs.
+ intros REL ADDR LOAD.
+ unfold load1.
+ destruct in_dec.
+ {
+ apply kill_reg_sound; auto.
+ }
+ apply load2_notrap1_sound; auto.
+Qed.
+
+Lemma load1_notrap2_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = None ->
+ sem_rel (load1 chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until a.
+ intros REL ADDR LOAD.
+ unfold load1.
+ destruct in_dec.
+ {
+ apply kill_reg_sound; auto.
+ }
+ apply load2_notrap2_sound with (a := a); auto.
+Qed.
+
+Lemma load_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ forall v,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = Some v ->
+ sem_rel (load chunk addr dst args rel) (rs # dst <- v).
+Proof.
+ intros until v.
+ intros REL ADDR LOAD.
+ unfold load.
+ destruct find_load as [src | ] eqn:FIND.
+ {
+ assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end) as FIND_LOAD.
+ {
+ apply (find_load_sound rel); trivial.
+ }
+ rewrite forward_move_map in FIND_LOAD by assumption.
+ destruct eval_addressing in *.
+ 2: discriminate.
+ replace v0 with a in * by congruence.
+ destruct Mem.loadv in *.
+ 2: discriminate.
+ replace v with (rs # src) by congruence.
+ apply move_sound; auto.
+ }
+ apply load1_sound with (a := a); trivial.
+Qed.
+
+Lemma load_notrap1_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = None ->
+ sem_rel (load chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until rs.
+ intros REL ADDR.
+ unfold load.
+ destruct find_load as [src | ] eqn:FIND.
+ {
+ assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end) as FIND_LOAD.
+ {
+ apply (find_load_sound rel); trivial.
+ }
+ rewrite forward_move_map in FIND_LOAD by assumption.
+ destruct eval_addressing in *.
+ discriminate.
+ rewrite <- FIND_LOAD.
+ apply move_sound; auto.
+ }
+ apply load1_notrap1_sound; trivial.
+Qed.
+
+Lemma load_notrap2_sound :
+ forall rel : RELATION.t,
+ forall chunk : memory_chunk,
+ forall addr : addressing,
+ forall dst : reg,
+ forall args: list reg,
+ forall rs : regset,
+ forall a,
+ sem_rel rel rs ->
+ eval_addressing genv sp addr (rs ## args) = Some a ->
+ Mem.loadv chunk m a = None ->
+ sem_rel (load chunk addr dst args rel) (rs # dst <- Vundef).
+Proof.
+ intros until a.
+ intros REL ADDR.
+ unfold load.
+ destruct find_load as [src | ] eqn:FIND.
+ {
+ assert (match eval_addressing genv sp addr rs## (map (forward_move rel) args) with
+ | Some a => match Mem.loadv chunk m a with
+ | Some dat => rs#src = dat
+ | None => rs#src = Vundef
+ end
+ | None => rs#src = Vundef
+ end) as FIND_LOAD.
+ {
+ apply (find_load_sound rel); trivial.
+ }
+ rewrite forward_move_map in FIND_LOAD by assumption.
+ rewrite ADDR in FIND_LOAD.
+ destruct Mem.loadv; intro.
+ discriminate.
+ rewrite <- FIND_LOAD.
+ apply move_sound; auto.
+ }
+ apply load1_notrap2_sound; trivial.
+Qed.
+
+Lemma kill_reg_weaken:
+ forall res mpc rs,
+ sem_rel mpc rs ->
+ sem_rel (kill_reg res mpc) rs.
+Proof.
+ intros until rs.
+ intros REL x.
+ pose proof (REL x) as RELx.
+ unfold kill_reg, sem_reg in *.
+ rewrite PTree.gfilter1.
+ destruct (peq res x).
+ { subst x.
+ rewrite PTree.grs.
+ reflexivity.
+ }
+ rewrite PTree.gro by congruence.
+ destruct (mpc ! x) as [sv | ]; trivial.
+ destruct negb; trivial.
+Qed.
+
+Lemma top_ok:
+ forall rs, sem_rel RELATION.top rs.
+Proof.
+ unfold sem_rel, sem_reg, RELATION.top.
+ intros.
+ rewrite PTree.gempty.
+ reflexivity.
+Qed.
+
+Lemma sem_rel_ge:
+ forall r1 r2 : RELATION.t,
+ (RELATION.ge r1 r2) ->
+ forall rs : regset,
+ (sem_rel r2 rs) -> (sem_rel r1 rs).
+Proof.
+ intros r1 r2 GE rs RE x.
+ pose proof (RE x) as REx.
+ pose proof (GE x) as GEx.
+ unfold sem_reg in *.
+ destruct (r1 ! x) as [r1x | ] in *;
+ destruct (r2 ! x) as [r2x | ] in *;
+ congruence.
+Qed.
+End SAME_MEMORY.
+
+Lemma kill_mem_sound :
+ forall m m' : mem,
+ forall rel : RELATION.t,
+ forall rs,
+ sem_rel m rel rs -> sem_rel m' (kill_mem rel) rs.
+Proof.
+ unfold sem_rel, sem_reg.
+ intros until rs.
+ intros SEM x.
+ pose proof (SEM x) as SEMx.
+ unfold kill_mem.
+ rewrite PTree.gfilter1.
+ unfold kill_sym_val_mem.
+ destruct (rel ! x) as [ sv | ].
+ 2: reflexivity.
+ destruct sv; simpl in *; trivial.
+ {
+ destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial.
+ rewrite SEMx.
+ apply op_depends_on_memory_correct; auto.
+ }
+Qed.
+
+Lemma kill_store_sound :
+ forall m m' : mem,
+ forall rel : RELATION.t,
+ forall chunk addr args a v rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (Mem.storev chunk m a v) = Some m' ->
+ sem_rel m rel rs -> sem_rel m' (kill_store chunk addr args rel) rs.
+Proof.
+ unfold sem_rel, sem_reg.
+ intros until rs.
+ intros ADDR STORE SEM x.
+ pose proof (SEM x) as SEMx.
+ unfold kill_store, kill_store1.
+ rewrite PTree.gfilter1.
+ destruct (rel ! x) as [ sv | ].
+ 2: reflexivity.
+ destruct sv; simpl in *; trivial.
+ {
+ destruct op_depends_on_memory eqn:DEPENDS; simpl; trivial.
+ rewrite SEMx.
+ apply op_depends_on_memory_correct; auto.
+ }
+ destruct may_overlap eqn:OVERLAP; simpl; trivial.
+ destruct (eval_addressing genv sp addr0 rs ## args0) eqn:ADDR0.
+ {
+ erewrite may_overlap_sound with (args := (map (forward_move rel) args)).
+ all: try eassumption.
+
+ erewrite forward_move_map by eassumption.
+ assumption.
+ }
+ intuition congruence.
+Qed.
+
+Lemma kill_builtin_res_sound:
+ forall res (m : mem) (rs : regset) vres (rel : RELATION.t)
+ (REL : sem_rel m rel rs),
+ (sem_rel m (kill_builtin_res res rel) (regmap_setres res vres rs)).
+Proof.
+ destruct res; simpl; intros; trivial.
+ apply kill_reg_sound; trivial.
+Qed.
+End SOUNDNESS.
+
+Definition match_prog (p tp: RTL.program) :=
+ match_program (fun cu f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p, match_prog p (transf_program p).
+Proof.
+ intros. apply match_transform_program; auto.
+Qed.
+
+Section PRESERVATION.
+
+Variables prog tprog: program.
+Hypothesis TRANSL: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma functions_translated:
+ forall v f,
+ Genv.find_funct ge v = Some f ->
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_transf TRANSL).
+
+Lemma function_ptr_translated:
+ forall v f,
+ Genv.find_funct_ptr ge v = Some f ->
+ Genv.find_funct_ptr tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_ptr_transf TRANSL).
+
+Lemma symbols_preserved:
+ forall id,
+ Genv.find_symbol tge id = Genv.find_symbol ge id.
+Proof (Genv.find_symbol_transf TRANSL).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_transf TRANSL).
+
+Lemma sig_preserved:
+ forall f, funsig (transf_fundef f) = funsig f.
+Proof.
+ destruct f; trivial.
+Qed.
+
+Lemma find_function_translated:
+ forall ros rs fd,
+ find_function ge ros rs = Some fd ->
+ find_function tge ros rs = Some (transf_fundef fd).
+Proof.
+ unfold find_function; intros. destruct ros as [r|id].
+ eapply functions_translated; eauto.
+ rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence.
+ eapply function_ptr_translated; eauto.
+Qed.
+
+Lemma transf_function_at:
+ forall (f : function) (pc : node) (i : instruction),
+ (fn_code f)!pc = Some i ->
+ (fn_code (transf_function f))!pc =
+ Some(transf_instr (forward_map f) pc i).
+Proof.
+ intros until i. intro CODE.
+ unfold transf_function; simpl.
+ rewrite PTree.gmap.
+ unfold option_map.
+ rewrite CODE.
+ reflexivity.
+Qed.
+
+Definition is_killed_in_map (map : PMap.t RB.t) pc res :=
+ match PMap.get pc map with
+ | None => True
+ | Some rel => exists rel', RELATION.ge rel (kill_reg res rel')
+ end.
+
+Definition is_killed_in_fmap fmap pc res :=
+ match fmap with
+ | None => True
+ | Some map => is_killed_in_map map pc res
+ end.
+
+Lemma external_call_sound:
+ forall ef (rel : RELATION.t) sp (m m' : mem) (rs : regset) vargs t vres
+ (REL : sem_rel fundef unit ge sp m rel rs)
+ (CALL : external_call ef ge vargs m t vres m'),
+ sem_rel fundef unit ge sp m' (apply_external_call ef rel) rs.
+Proof.
+ destruct ef; intros; simpl in *.
+ all: eauto using kill_mem_sound.
+ all: unfold builtin_or_external_sem in *.
+ 1, 2: destruct (Builtins.lookup_builtin_function name sg);
+ eauto using kill_mem_sound;
+ inv CALL; eauto using kill_mem_sound.
+ all: inv CALL.
+ all: eauto using kill_mem_sound.
+Qed.
+
+Definition sem_rel_b' := sem_rel_b fundef unit ge.
+Definition fmap_sem' := fmap_sem fundef unit ge.
+Definition subst_arg_ok' := subst_arg_ok fundef unit ge.
+Definition subst_args_ok' := subst_args_ok fundef unit ge.
+Definition kill_mem_sound' := kill_mem_sound fundef unit ge.
+Definition kill_store_sound' := kill_store_sound fundef unit ge.
+
+Lemma sem_rel_b_ge:
+ forall rb1 rb2 : RB.t,
+ (RB.ge rb1 rb2) ->
+ forall sp m,
+ forall rs : regset,
+ (sem_rel_b' sp m rb2 rs) -> (sem_rel_b' sp m rb1 rs).
+Proof.
+ unfold sem_rel_b', sem_rel_b.
+ destruct rb1 as [r1 | ];
+ destruct rb2 as [r2 | ]; simpl;
+ intros GE sp m rs RE; try contradiction.
+ apply sem_rel_ge with (r2 := r2); assumption.
+Qed.
+
+Lemma apply_instr'_bot :
+ forall code,
+ forall pc,
+ RB.eq (apply_instr' code pc RB.bot) RB.bot.
+Proof.
+ reflexivity.
+Qed.
+
+Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop :=
+| match_frames_intro: forall res f sp pc rs,
+ (forall m : mem,
+ forall vres, (fmap_sem' sp m (forward_map f) pc rs # res <- vres)) ->
+ match_frames (Stackframe res f sp pc rs)
+ (Stackframe res (transf_function f) sp pc rs).
+
+Inductive match_states: RTL.state -> RTL.state -> Prop :=
+ | match_regular_states: forall stk f sp pc rs m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ (fmap_sem' sp m (forward_map f) pc rs) ->
+ match_states (State stk f sp pc rs m)
+ (State stk' (transf_function f) sp pc rs m)
+ | match_callstates: forall stk f args m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Callstate stk f args m)
+ (Callstate stk' (transf_fundef f) args m)
+ | match_returnstates: forall stk v m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Returnstate stk v m)
+ (Returnstate stk' v m).
+
+Ltac TR_AT :=
+ match goal with
+ | [ A: (fn_code _)!_ = Some _ |- _ ] =>
+ generalize (transf_function_at _ _ _ A); intros
+ end.
+
+Lemma step_simulation:
+ forall S1 t S2, RTL.step ge S1 t S2 ->
+ forall S1', match_states S1 S1' ->
+ exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ induction 1; intros S1' MS; inv MS; try TR_AT.
+- (* nop *)
+ econstructor; split. eapply exec_Inop; eauto.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply sem_rel_b_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ unfold sem_rel_b in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+- (* op *)
+ unfold transf_instr in *.
+ destruct (if is_trivial_op op then None else find_op_in_fmap (forward_map f) pc op
+ (subst_args (forward_map f) pc args)) eqn:FIND_OP.
+ {
+ destruct (is_trivial_op op).
+ discriminate.
+ unfold find_op_in_fmap, fmap_sem', fmap_sem in *.
+ destruct (forward_map f) as [map |] eqn:MAP.
+ 2: discriminate.
+ change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *.
+ destruct (map # pc) as [mpc | ] eqn:MPC.
+ 2: discriminate.
+ econstructor; split.
+ {
+ eapply exec_Iop with (v := v); eauto.
+ simpl.
+ rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0.
+ {
+ rewrite MAP in H0.
+ rewrite find_op_sound with (rel := mpc) (src := r) in H0 by assumption.
+ assumption.
+ }
+ unfold fmap_sem. rewrite MAP. rewrite MPC. assumption.
+ }
+ constructor; eauto.
+ unfold fmap_sem', fmap_sem in *.
+ rewrite MAP.
+ apply sem_rel_b_ge with (rb2 := Some (gen_oper op res args mpc)).
+ {
+ replace (Some (gen_oper op res args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ unfold sem_rel_b', sem_rel_b.
+ apply gen_oper_sound; auto.
+ }
+ {
+ econstructor; split.
+ {
+ eapply exec_Iop with (v := v); eauto.
+ rewrite (subst_args_ok' sp m) by assumption.
+ rewrite <- H0.
+ apply eval_operation_preserved. exact symbols_preserved.
+ }
+ constructor; eauto.
+ unfold fmap_sem', fmap_sem in *.
+ unfold find_op_in_fmap, fmap_sem', fmap_sem in *.
+ destruct (forward_map f) as [map |] eqn:MAP.
+ 2: constructor.
+ change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *.
+ destruct (map # pc) as [mpc | ] eqn:MPC.
+ 2: contradiction.
+
+ apply sem_rel_b_ge with (rb2 := Some (gen_oper op res args mpc)).
+ {
+ replace (Some (gen_oper op res args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ unfold sem_rel_b', sem_rel_b.
+ apply gen_oper_sound; auto.
+ }
+
+(* load *)
+- unfold transf_instr in *.
+ destruct find_load_in_fmap eqn:FIND_LOAD.
+ {
+ unfold find_load_in_fmap, fmap_sem', fmap_sem in *.
+ destruct (forward_map f) as [map |] eqn:MAP.
+ 2: discriminate.
+ change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *.
+ destruct (map # pc) as [mpc | ] eqn:MPC.
+ 2: discriminate.
+ econstructor; split.
+ {
+ eapply exec_Iop with (v := v); eauto.
+ simpl.
+ rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0.
+ {
+ f_equal.
+ symmetry.
+ rewrite MAP in H0.
+ eapply find_load_sound' with (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs).
+ all: eassumption.
+ }
+ unfold fmap_sem. rewrite MAP. rewrite MPC. assumption.
+ }
+ constructor; eauto.
+ unfold fmap_sem', fmap_sem in *.
+ rewrite MAP.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ unfold sem_rel_b', sem_rel_b.
+ apply load_sound with (a := a); auto.
+ }
+ {
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0.
+ apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload; eauto.
+ rewrite (subst_args_ok' sp m); assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ apply load_sound with (a := a); assumption.
+ }
+
+- (* load notrap1 *)
+ unfold transf_instr in *.
+ destruct find_load_in_fmap eqn:FIND_LOAD.
+ {
+ unfold find_load_in_fmap, fmap_sem', fmap_sem in *.
+ destruct (forward_map f) as [map |] eqn:MAP.
+ 2: discriminate.
+ change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *.
+ destruct (map # pc) as [mpc | ] eqn:MPC.
+ 2: discriminate.
+ econstructor; split.
+ {
+ eapply exec_Iop with (v := (default_notrap_load_value chunk)); eauto.
+ simpl.
+ rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0.
+ {
+ f_equal.
+ rewrite MAP in H0.
+ eapply find_load_notrap1_sound' with (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs).
+ all: eassumption.
+ }
+ unfold fmap_sem. rewrite MAP. rewrite MPC. assumption.
+ }
+ constructor; eauto.
+ unfold fmap_sem', fmap_sem in *.
+ rewrite MAP.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ unfold sem_rel_b', sem_rel_b.
+ apply load_notrap1_sound; auto.
+ }
+ {
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = None).
+ rewrite <- H0.
+ apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap1; eauto.
+ rewrite (subst_args_ok' sp m); assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ apply load_notrap1_sound; assumption.
+ }
+
+(* load notrap2 *)
+- unfold transf_instr in *.
+ destruct find_load_in_fmap eqn:FIND_LOAD.
+ {
+ unfold find_load_in_fmap, fmap_sem', fmap_sem in *.
+ destruct (forward_map f) as [map |] eqn:MAP.
+ 2: discriminate.
+ change (@PMap.get (option RELATION.t) pc map) with (map # pc) in *.
+ destruct (map # pc) as [mpc | ] eqn:MPC.
+ 2: discriminate.
+ econstructor; split.
+ {
+ eapply exec_Iop with (v := (default_notrap_load_value chunk)); eauto.
+ simpl.
+ rewrite <- subst_args_ok with (genv := ge) (f := f) (pc := pc) (sp := sp) (m := m) in H0.
+ {
+ f_equal.
+ rewrite MAP in H0.
+ eapply find_load_notrap2_sound' with (genv := ge) (sp := sp) (addr := addr) (args := subst_args (Some map) pc args) (rel := mpc) (src := r) (rs := rs).
+ all: try eassumption.
+ }
+ unfold fmap_sem. rewrite MAP. rewrite MPC. assumption.
+ }
+ constructor; eauto.
+ unfold fmap_sem', fmap_sem in *.
+ rewrite MAP.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ unfold sem_rel_b', sem_rel_b.
+ apply load_notrap2_sound with (a := a); auto.
+ }
+ {
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0.
+ apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap2; eauto.
+ rewrite (subst_args_ok' sp m); assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply sem_rel_b_ge with (rb2 := Some (load chunk addr dst args mpc)).
+ {
+ replace (Some (load chunk addr dst args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ simpl.
+ reflexivity.
+ }
+ apply load_notrap2_sound with (a := a); assumption.
+ }
+
+- (* store *)
+ econstructor. split.
+ {
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Istore; eauto.
+ rewrite (subst_args_ok' sp m); assumption.
+ }
+
+ constructor; auto.
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply sem_rel_b_ge with (rb2 := Some (kill_store chunk addr args mpc)); trivial.
+ {
+ replace (Some (kill_store chunk addr args mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ unfold sem_rel_b in *.
+ rewrite MPC.
+ rewrite H.
+ reflexivity.
+ }
+ eapply (kill_store_sound' sp m); eassumption.
+
+(* call *)
+- econstructor; split.
+ eapply exec_Icall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ rewrite (subst_args_ok' sp m) by assumption.
+ constructor. constructor; auto.
+
+ constructor.
+ {
+ intros m' vres.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply sem_rel_b_ge with (rb2 := Some (kill_reg res (kill_mem mpc))).
+ {
+ replace (Some (kill_reg res (kill_mem mpc))) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_reg_sound.
+ apply (kill_mem_sound' sp m).
+ assumption.
+ }
+
+(* tailcall *)
+- econstructor; split.
+ eapply exec_Itailcall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ rewrite (subst_args_ok' (Vptr stk Ptrofs.zero) m) by assumption.
+ constructor. auto.
+
+(* builtin *)
+- econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+
+ apply sem_rel_b_ge with (rb2 := Some (kill_builtin_res res (apply_external_call ef mpc))).
+ {
+ replace (Some (kill_builtin_res res (apply_external_call ef mpc))) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_builtin_res_sound.
+ eapply external_call_sound with (m := m); eassumption.
+
+(* cond *)
+- econstructor; split.
+ eapply exec_Icond; eauto.
+ rewrite (subst_args_ok' sp m); eassumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply sem_rel_b_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl.
+ destruct b; tauto.
+ }
+ unfold apply_instr'.
+ unfold sem_rel_b in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+
+(* jumptbl *)
+- econstructor; split.
+ eapply exec_Ijumptable; eauto.
+ rewrite (subst_arg_ok' sp m); eassumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply sem_rel_b_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl.
+ apply list_nth_z_in with (n := Int.unsigned n).
+ assumption.
+ }
+ unfold apply_instr'.
+ unfold sem_rel_b in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+
+(* return *)
+- destruct or as [arg | ].
+ {
+ econstructor; split.
+ eapply exec_Ireturn; eauto.
+ unfold regmap_optget.
+ rewrite (subst_arg_ok' (Vptr stk Ptrofs.zero) m) by eassumption.
+ constructor; auto.
+ }
+ econstructor; split.
+ eapply exec_Ireturn; eauto.
+ constructor; auto.
+
+
+(* internal function *)
+- simpl. econstructor; split.
+ eapply exec_function_internal; eauto.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem', fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply sem_rel_b_ge with (rb2 := Some RELATION.top).
+ {
+ eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption.
+ }
+ apply top_ok.
+
+(* external function *)
+- econstructor; split.
+ eapply exec_function_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+
+(* return *)
+- inv STACKS. inv H1.
+ econstructor; split.
+ eapply exec_return; eauto.
+ constructor; auto.
+Qed.
+
+
+Lemma transf_initial_states:
+ forall S1, RTL.initial_state prog S1 ->
+ exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2.
+Proof.
+ intros. inv H. econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf TRANSL); eauto.
+ rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto.
+ eapply function_ptr_translated; eauto.
+ rewrite <- H3; apply sig_preserved.
+ constructor. constructor.
+Qed.
+
+Lemma transf_final_states:
+ forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r.
+Proof.
+ intros. inv H0. inv H. inv STACKS. constructor.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
+Proof.
+ eapply forward_simulation_step.
+ apply senv_preserved.
+ eexact transf_initial_states.
+ eexact transf_final_states.
+ exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/backend/CSEdomain.v b/backend/CSEdomain.v
index 9b1243c8..34ec0118 100644
--- a/backend/CSEdomain.v
+++ b/backend/CSEdomain.v
@@ -43,7 +43,7 @@ Definition eq_list_valnum: forall (x y: list valnum), {x=y}+{x<>y} := list_eq_de
Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}.
Proof.
- generalize chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum.
+ generalize trapping_mode_eq chunk_eq eq_operation eq_addressing eq_valnum eq_list_valnum.
decide equality.
Defined.
@@ -109,7 +109,16 @@ Inductive rhs_eval_to (valu: valuation) (ge: genv) (sp: val) (m: mem):
| load_eval_to: forall chunk addr vl a v,
eval_addressing ge sp addr (map valu vl) = Some a ->
Mem.loadv chunk m a = Some v ->
- rhs_eval_to valu ge sp m (Load chunk addr vl) v.
+ rhs_eval_to valu ge sp m (Load chunk addr vl) v
+(* | load_notrap1_eval_to: forall chunk addr vl,
+ eval_addressing ge sp addr (map valu vl) = None ->
+ rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl)
+ (default_notrap_load_value chunk)
+ | load_notrap2_eval_to: forall chunk addr vl a,
+ eval_addressing ge sp addr (map valu vl) = Some a ->
+ Mem.loadv chunk m a = None ->
+ rhs_eval_to valu ge sp m (Load NOTRAP chunk addr vl)
+ (default_notrap_load_value chunk) *).
Inductive equation_holds (valu: valuation) (ge: genv) (sp: val) (m: mem):
equation -> Prop :=
diff --git a/backend/CSEproof.v b/backend/CSEproof.v
index d6bde348..5bbb7508 100644
--- a/backend/CSEproof.v
+++ b/backend/CSEproof.v
@@ -14,7 +14,7 @@
Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
Require Import AST Linking.
-Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Values Memory Builtins Events Globalenvs Smallstep.
Require Import Op Registers RTL.
Require Import ValueDomain ValueAOp ValueAnalysis.
Require Import CSEdomain CombineOp CombineOpproof CSE.
@@ -71,7 +71,11 @@ Lemma rhs_eval_to_exten:
Proof.
intros. inv H; simpl in *.
- constructor. rewrite valnums_val_exten by assumption. auto.
-- econstructor; eauto. rewrite valnums_val_exten by assumption. auto.
+- eapply load_eval_to; eauto. rewrite valnums_val_exten by assumption. auto.
+(*
+- apply load_notrap1_eval_to; auto. rewrite valnums_val_exten by assumption. assumption.
+- eapply load_notrap2_eval_to; eauto. rewrite valnums_val_exten by assumption. assumption.
+*)
Qed.
Lemma equation_holds_exten:
@@ -393,6 +397,39 @@ Proof.
+ intros. apply Regmap.gso; auto.
Qed.
+(*
+Lemma add_load_holds_none1:
+ forall valu1 ge sp rs m n addr (args: list reg) chunk dst,
+ numbering_holds valu1 ge sp rs m n ->
+ eval_addressing ge sp addr rs##args = None ->
+ exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst chunk addr args).
+Proof.
+ unfold add_load; intros.
+ destruct (valnum_regs n args) as [n1 vl] eqn:VN.
+ exploit valnum_regs_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ eapply add_rhs_holds; eauto.
++ rewrite Regmap.gss; auto. eapply load_notrap1_eval_to. rewrite <- B; eauto.
++ intros. apply Regmap.gso; auto.
+Qed.
+
+Lemma add_load_holds_none2:
+ forall valu1 ge sp rs m n addr (args: list reg) a chunk dst,
+ numbering_holds valu1 ge sp rs m n ->
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = None ->
+ exists valu2, numbering_holds valu2 ge sp (rs#dst <- (default_notrap_load_value chunk)) m (add_load n dst NOTRAP chunk addr args).
+Proof.
+ unfold add_load; intros.
+ destruct (valnum_regs n args) as [n1 vl] eqn:VN.
+ exploit valnum_regs_holds; eauto.
+ intros (valu2 & A & B & C & D & E).
+ eapply add_rhs_holds; eauto.
++ rewrite Regmap.gss; auto. eapply load_notrap2_eval_to. rewrite <- B; eauto. assumption.
++ intros. apply Regmap.gso; auto.
+Qed.
+ *)
+
Lemma set_unknown_holds:
forall valu ge sp rs m n r v,
numbering_holds valu ge sp rs m n ->
@@ -456,8 +493,8 @@ Lemma kill_all_loads_hold:
Proof.
intros. eapply kill_equations_hold; eauto.
unfold filter_loads; intros. inv H1.
- constructor. rewrite <- H2. apply op_depends_on_memory_correct; auto.
- discriminate.
+ 1: constructor; rewrite <- H2; apply op_depends_on_memory_correct; auto.
+ all: discriminate.
Qed.
Lemma kill_loads_after_store_holds:
@@ -486,6 +523,20 @@ Proof.
apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
erewrite <- regs_valnums_sound by eauto. eauto with va.
apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va.
+(*
+- eapply load_notrap1_eval_to; assumption.
+- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate.
+ eapply load_notrap2_eval_to; eauto.
+ rewrite <- H9.
+ destruct a; simpl in H1; try discriminate.
+ destruct a0; simpl in H9; try discriminate; simpl; trivial.
+ rewrite negb_false_iff in H6. unfold aaddressing in H6.
+ eapply Mem.load_store_other. eauto.
+ eapply pdisjoint_sound; eauto.
+ apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
+ erewrite <- regs_valnums_sound by eauto. eauto with va.
+ apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va.
+*)
Qed.
Lemma store_normalized_range_sound:
@@ -544,7 +595,7 @@ Lemma kill_loads_after_storebytes_holds:
bc sp = BCstack ->
ematch bc rs ae ->
approx = VA.State ae am ->
- length bytes = nat_of_Z sz -> sz >= 0 ->
+ length bytes = Z.to_nat sz -> sz >= 0 ->
numbering_holds valu ge (Vptr sp Ptrofs.zero) rs m'
(kill_loads_after_storebytes approx n dst sz).
Proof.
@@ -557,11 +608,24 @@ Proof.
simpl.
rewrite negb_false_iff in H8.
eapply Mem.load_storebytes_other. eauto.
- rewrite H6. rewrite nat_of_Z_eq by auto.
+ rewrite H6. rewrite Z2Nat.id by omega.
+ eapply pdisjoint_sound. eauto.
+ unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
+ erewrite <- regs_valnums_sound by eauto. eauto with va.
+ auto.
+(*
+- eapply load_notrap1_eval_to; assumption.
+- destruct (regs_valnums n vl) as [rl|] eqn:RV; try discriminate.
+ eapply load_notrap2_eval_to; eauto. rewrite <- H11.
+ destruct a; simpl in H10; try discriminate; simpl; trivial.
+ rewrite negb_false_iff in H8.
+ eapply Mem.load_storebytes_other. eauto.
+ rewrite H6. rewrite Z2Nat.id by omega.
eapply pdisjoint_sound. eauto.
unfold aaddressing. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto.
erewrite <- regs_valnums_sound by eauto. eauto with va.
auto.
+*)
Qed.
Lemma load_memcpy:
@@ -598,9 +662,9 @@ Proof.
exploit Mem.storebytes_split; eauto. intros (m2 & SB2 & SB3).
clear SB23.
assert (L1: Z.of_nat (length bytes1) = n1).
- { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n1; omega. }
+ { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n1; omega. }
assert (L2: Z.of_nat (length bytes2) = n2).
- { erewrite Mem.loadbytes_length by eauto. apply nat_of_Z_eq. unfold n2; omega. }
+ { erewrite Mem.loadbytes_length by eauto. apply Z2Nat.id. unfold n2; omega. }
rewrite L1 in *. rewrite L2 in *.
assert (LB': Mem.loadbytes m2 b2 (ofs2 + n1) n2 = Some bytes2).
{ rewrite <- L2. eapply Mem.loadbytes_storebytes_same; eauto. }
@@ -1034,6 +1098,10 @@ Proof.
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
destruct SAT as [valu1 NH1].
exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
+ destruct trap.
+
+ (* TRAP *)
+ {
destruct (find_rhs n1 (Load chunk addr vl)) as [r|] eqn:?.
+ (* replaced by move *)
exploit find_rhs_sound; eauto. intros (v' & EV & LD).
@@ -1063,7 +1131,103 @@ Proof.
unfold transfer; rewrite H.
eapply add_load_holds; eauto.
apply set_reg_lessdef; auto.
+ }
+
+ (* NOTRAP *)
+ {
+ assert (exists a' : val,
+ eval_addressing ge sp addr rs' ## args = Some a' /\ Val.lessdef a a')
+ as Haa'.
+ apply eval_addressing_lessdef with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ destruct Haa' as [a' [Ha'1 Ha'2]].
+
+ assert (
+ exists v' : val,
+ Mem.loadv chunk m' a' = Some v' /\ Val.lessdef v v') as Hload' by
+ (apply Mem.loadv_extends with (m1 := m) (addr1 := a); assumption).
+ destruct Hload' as [v' [Hv'1 Hv'2]].
+
+ econstructor. split.
+ eapply exec_Iload; eauto.
+ try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved).
+
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; eauto.
+ unfold transfer. rewrite H.
+ exists valu1.
+ apply set_unknown_holds.
+ assumption.
+ apply set_reg_lessdef; assumption.
+ }
+- (* Iload notrap 1*)
+ destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
+ destruct SAT as [valu1 NH1].
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
+
+ econstructor. split.
+ eapply exec_Iload_notrap1; eauto.
+ rewrite eval_addressing_preserved with (ge1 := ge).
+ apply eval_addressing_lessdef_none with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ exact symbols_preserved.
+
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; eauto.
+ unfold transfer. rewrite H.
+ exists valu1.
+ apply set_unknown_holds.
+ assumption.
+ apply set_reg_lessdef.
+ constructor. assumption.
+
+- (* Iload notrap 2*)
+ destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
+ destruct SAT as [valu1 NH1].
+ exploit valnum_regs_holds; eauto. intros (valu2 & NH2 & EQ & AG & P & Q).
+
+ assert (exists a' : val,
+ eval_addressing ge sp addr rs' ## args = Some a' /\ Val.lessdef a a')
+ as Haa'.
+ apply eval_addressing_lessdef with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ destruct Haa' as [a' [Ha'1 Ha'2]].
+
+ destruct (Mem.loadv chunk m' a') eqn:Hload'.
+
+ {
+ econstructor. split.
+ eapply exec_Iload; eauto.
+ try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved).
+
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; eauto.
+ unfold transfer. rewrite H.
+ exists valu1.
+ apply set_unknown_holds.
+ assumption.
+ unfold default_notrap_load_value.
+ apply set_reg_lessdef; eauto.
+ }
+ {
+ econstructor. split.
+ eapply exec_Iload_notrap2; eauto.
+ try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved).
+
+ econstructor; eauto.
+ eapply analysis_correct_1; eauto. simpl; eauto.
+ unfold transfer. rewrite H.
+ exists valu1.
+ apply set_unknown_holds.
+ assumption.
+ apply set_reg_lessdef.
+ constructor. assumption.
+ }
+
- (* Istore *)
destruct (valnum_regs approx!!pc args) as [n1 vl] eqn:?.
destruct SAT as [valu1 NH1].
@@ -1129,7 +1293,9 @@ Proof.
{ exists valu. apply set_res_unknown_holds. eapply kill_all_loads_hold; eauto. }
destruct ef.
+ apply CASE1.
- + apply CASE3.
+ + destruct (lookup_builtin_function name sg) as [bf|] eqn:LK.
+ ++ apply CASE2. simpl in H1; red in H1; rewrite LK in H1; inv H1. auto.
+ ++ apply CASE3.
+ apply CASE1.
+ apply CASE2; inv H1; auto.
+ apply CASE3.
diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v
index e92be2b4..84ca403e 100644
--- a/backend/CleanupLabelsproof.v
+++ b/backend/CleanupLabelsproof.v
@@ -255,6 +255,18 @@ Proof.
left; econstructor; split.
econstructor; eauto.
econstructor; eauto with coqlib.
+(* Lload notrap1 *)
+ assert (eval_addressing tge sp addr (LTL.reglist rs args) = None).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ left; econstructor; split.
+ eapply exec_Lload_notrap1; eauto.
+ econstructor; eauto with coqlib.
+(* Lload notrap2 *)
+ assert (eval_addressing tge sp addr (LTL.reglist rs args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ left; econstructor; split.
+ eapply exec_Lload_notrap2; eauto.
+ econstructor; eauto with coqlib.
(* Lstore *)
assert (eval_addressing tge sp addr (LTL.reglist rs args) = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
diff --git a/backend/Cminor.v b/backend/Cminor.v
index 11941da3..91a4c104 100644
--- a/backend/Cminor.v
+++ b/backend/Cminor.v
@@ -591,6 +591,70 @@ Proof.
red; intros; inv H; simpl; try omega; eapply external_call_trace_length; eauto.
Qed.
+(** This semantics is determinate. *)
+
+Lemma eval_expr_determ:
+ forall ge sp e m a v, eval_expr ge sp e m a v ->
+ forall v', eval_expr ge sp e m a v' -> v' = v.
+Proof.
+ induction 1; intros v' E'; inv E'.
+- congruence.
+- congruence.
+- assert (v0 = v1) by eauto. congruence.
+- assert (v0 = v1) by eauto. assert (v3 = v2) by eauto. congruence.
+- assert (vaddr0 = vaddr) by eauto. congruence.
+Qed.
+
+Lemma eval_exprlist_determ:
+ forall ge sp e m al vl, eval_exprlist ge sp e m al vl ->
+ forall vl', eval_exprlist ge sp e m al vl' -> vl' = vl.
+Proof.
+ induction 1; intros vl' E'; inv E'.
+ - auto.
+ - f_equal; eauto using eval_expr_determ.
+Qed.
+
+Ltac Determ :=
+ try congruence;
+ match goal with
+ | [ |- match_traces _ E0 E0 /\ (_ -> _) ] =>
+ split; [constructor|intros _; Determ]
+ | [ H: is_call_cont ?k |- _ ] =>
+ contradiction || (clear H; Determ)
+ | [ H1: eval_expr _ _ _ _ ?a ?v1, H2: eval_expr _ _ _ _ ?a ?v2 |- _ ] =>
+ assert (v1 = v2) by (eapply eval_expr_determ; eauto);
+ clear H1 H2; Determ
+ | [ H1: eval_exprlist _ _ _ _ ?a ?v1, H2: eval_exprlist _ _ _ _ ?a ?v2 |- _ ] =>
+ assert (v1 = v2) by (eapply eval_exprlist_determ; eauto);
+ clear H1 H2; Determ
+ | _ => idtac
+ end.
+
+Lemma semantics_determinate:
+ forall (p: program), determinate (semantics p).
+Proof.
+ intros. constructor; set (ge := Genv.globalenv p); simpl; intros.
+- (* determ *)
+ inv H; inv H0; Determ.
+ + subst vargs0. exploit external_call_determ. eexact H2. eexact H13.
+ intros (A & B). split; intros; auto.
+ apply B in H; destruct H; congruence.
+ + subst v0. assert (b0 = b) by (inv H2; inv H13; auto). subst b0; auto.
+ + assert (n0 = n) by (inv H2; inv H14; auto). subst n0; auto.
+ + exploit external_call_determ. eexact H1. eexact H7.
+ intros (A & B). split; intros; auto.
+ apply B in H; destruct H; congruence.
+- (* single event *)
+ red; simpl. destruct 1; simpl; try omega;
+ eapply external_call_trace_length; eauto.
+- (* initial states *)
+ inv H; inv H0. unfold ge0, ge1 in *. congruence.
+- (* nostep final state *)
+ red; intros; red; intros. inv H; inv H0.
+- (* final states *)
+ inv H; inv H0; auto.
+Qed.
+
(** * Alternate operational semantics (big-step) *)
(** We now define another semantics for Cminor without [goto] that follows
@@ -612,12 +676,24 @@ Definition outcome_block (out: outcome) : outcome :=
| out => out
end.
+(*
+Definition outcome_result_value
+ (out: outcome) (retsig: rettype) (vres: val) : Prop :=
+ match out with
+ | Out_normal => vres = Vundef
+ | Out_return None => vres = Vundef
+ | Out_return (Some v) => retsig <> Tvoid /\ vres = v
+ | Out_tailcall_return v => vres = v
+ | _ => False
+ end.
+*)
+
Definition outcome_result_value
- (out: outcome) (retsig: option typ) (vres: val) : Prop :=
+ (out: outcome) (vres: val) : Prop :=
match out with
| Out_normal => vres = Vundef
| Out_return None => vres = Vundef
- | Out_return (Some v) => retsig <> None /\ vres = v
+ | Out_return (Some v) => vres = v
| Out_tailcall_return v => vres = v
| _ => False
end.
@@ -647,7 +723,7 @@ Inductive eval_funcall:
Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) ->
set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e ->
exec_stmt f (Vptr sp Ptrofs.zero) e m1 f.(fn_body) t e2 m2 out ->
- outcome_result_value out f.(fn_sig).(sig_res) vres ->
+ outcome_result_value out vres ->
outcome_free_mem out m2 sp f.(fn_stackspace) m3 ->
eval_funcall m (Internal f) vargs t m3 vres
| eval_funcall_external:
@@ -931,7 +1007,7 @@ Proof.
subst vres. replace k with (call_cont k') by congruence.
apply star_one. apply step_return_0; auto.
(* Out_return Some *)
- destruct H3. subst vres.
+ subst vres.
replace k with (call_cont k') by congruence.
apply star_one. eapply step_return_1; eauto.
(* Out_tailcall_return *)
diff --git a/backend/Cminortyping.v b/backend/Cminortyping.v
new file mode 100644
index 00000000..92ec45f2
--- /dev/null
+++ b/backend/Cminortyping.v
@@ -0,0 +1,803 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+Require Import Coqlib Maps Errors.
+Require Import AST Integers Floats Values Memory Globalenvs Events Smallstep.
+Require Import Cminor.
+Require Import Unityping.
+
+Local Open Scope string_scope.
+Local Open Scope error_monad_scope.
+
+(** * Type inference algorithm *)
+
+Definition type_constant (c: constant) : typ :=
+ match c with
+ | Ointconst _ => Tint
+ | Ofloatconst _ => Tfloat
+ | Osingleconst _ => Tsingle
+ | Olongconst _ => Tlong
+ | Oaddrsymbol _ _ => Tptr
+ | Oaddrstack _ => Tptr
+ end.
+
+Definition type_unop (op: unary_operation) : typ * typ :=
+ match op with
+ | Ocast8unsigned | Ocast8signed | Ocast16unsigned | Ocast16signed
+ | Onegint | Onotint => (Tint, Tint)
+ | Onegf | Oabsf => (Tfloat, Tfloat)
+ | Onegfs | Oabsfs => (Tsingle, Tsingle)
+ | Osingleoffloat => (Tfloat, Tsingle)
+ | Ofloatofsingle => (Tsingle, Tfloat)
+ | Ointoffloat | Ointuoffloat => (Tfloat, Tint)
+ | Ofloatofint | Ofloatofintu => (Tint, Tfloat)
+ | Ointofsingle | Ointuofsingle => (Tsingle, Tint)
+ | Osingleofint | Osingleofintu => (Tint, Tsingle)
+ | Onegl | Onotl => (Tlong, Tlong)
+ | Ointoflong => (Tlong, Tint)
+ | Olongofint | Olongofintu => (Tint, Tlong)
+ | Olongoffloat | Olonguoffloat => (Tfloat, Tlong)
+ | Ofloatoflong | Ofloatoflongu => (Tlong, Tfloat)
+ | Olongofsingle | Olonguofsingle => (Tsingle, Tlong)
+ | Osingleoflong | Osingleoflongu => (Tlong, Tsingle)
+ end.
+
+Definition type_binop (op: binary_operation) : typ * typ * typ :=
+ match op with
+ | Oadd | Osub | Omul | Odiv | Odivu | Omod | Omodu
+ | Oand | Oor | Oxor | Oshl | Oshr | Oshru => (Tint, Tint, Tint)
+ | Oaddf | Osubf | Omulf | Odivf => (Tfloat, Tfloat, Tfloat)
+ | Oaddfs| Osubfs| Omulfs| Odivfs => (Tsingle, Tsingle, Tsingle)
+ | Oaddl | Osubl | Omull | Odivl | Odivlu | Omodl | Omodlu
+ | Oandl | Oorl | Oxorl => (Tlong, Tlong, Tlong)
+ | Oshll | Oshrl | Oshrlu => (Tlong, Tint, Tlong)
+ | Ocmp _ | Ocmpu _ => (Tint, Tint, Tint)
+ | Ocmpf _ => (Tfloat, Tfloat, Tint)
+ | Ocmpfs _ => (Tsingle, Tsingle, Tint)
+ | Ocmpl _ | Ocmplu _ => (Tlong, Tlong, Tint)
+ end.
+
+Module RTLtypes <: TYPE_ALGEBRA.
+
+Definition t := typ.
+Definition eq := typ_eq.
+Definition default := Tint.
+
+End RTLtypes.
+
+Module S := UniSolver(RTLtypes).
+
+Definition expect (e: S.typenv) (t1 t2: typ) : res S.typenv :=
+ if typ_eq t1 t2 then OK e else Error (msg "type mismatch").
+
+Fixpoint type_expr (e: S.typenv) (a: expr) (t: typ) : res S.typenv :=
+ match a with
+ | Evar id => S.set e id t
+ | Econst c => expect e (type_constant c) t
+ | Eunop op a1 =>
+ let '(targ1, tres) := type_unop op in
+ do e1 <- type_expr e a1 targ1;
+ expect e1 tres t
+ | Ebinop op a1 a2 =>
+ let '(targ1, targ2, tres) := type_binop op in
+ do e1 <- type_expr e a1 targ1;
+ do e2 <- type_expr e1 a2 targ2;
+ expect e2 tres t
+ | Eload chunk a1 =>
+ do e1 <- type_expr e a1 Tptr;
+ expect e1 (type_of_chunk chunk) t
+ end.
+
+Fixpoint type_exprlist (e: S.typenv) (al: list expr) (tl: list typ) : res S.typenv :=
+ match al, tl with
+ | nil, nil => OK e
+ | a :: al, t :: tl => do e1 <- type_expr e a t; type_exprlist e1 al tl
+ | _, _ => Error (msg "arity mismatch")
+ end.
+
+Definition type_assign (e: S.typenv) (id: ident) (a: expr) : res S.typenv :=
+ match a with
+ | Evar id' =>
+ do (changed, e1) <- S.move e id id'; OK e1
+ | Econst c =>
+ S.set e id (type_constant c)
+ | Eunop op a1 =>
+ let '(targ1, tres) := type_unop op in
+ do e1 <- type_expr e a1 targ1;
+ S.set e1 id tres
+ | Ebinop op a1 a2 =>
+ let '(targ1, targ2, tres) := type_binop op in
+ do e1 <- type_expr e a1 targ1;
+ do e2 <- type_expr e1 a2 targ2;
+ S.set e2 id tres
+ | Eload chunk a1 =>
+ do e1 <- type_expr e a1 Tptr;
+ S.set e1 id (type_of_chunk chunk)
+ end.
+
+Definition opt_set (e: S.typenv) (optid: option ident) (ty: typ) : res S.typenv :=
+ match optid with
+ | None => OK e
+ | Some id => S.set e id ty
+ end.
+
+Fixpoint type_stmt (tret: rettype) (e: S.typenv) (s: stmt) : res S.typenv :=
+ match s with
+ | Sskip => OK e
+ | Sassign id a => type_assign e id a
+ | Sstore chunk a1 a2 =>
+ do e1 <- type_expr e a1 Tptr; type_expr e1 a2 (type_of_chunk chunk)
+ | Scall optid sg fn args =>
+ do e1 <- type_expr e fn Tptr;
+ do e2 <- type_exprlist e1 args sg.(sig_args);
+ opt_set e2 optid (proj_sig_res sg)
+ | Stailcall sg fn args =>
+ assertion (rettype_eq sg.(sig_res) tret);
+ do e1 <- type_expr e fn Tptr;
+ type_exprlist e1 args sg.(sig_args)
+ | Sbuiltin optid ef args =>
+ let sg := ef_sig ef in
+ do e1 <- type_exprlist e args sg.(sig_args);
+ opt_set e1 optid (proj_sig_res sg)
+ | Sseq s1 s2 =>
+ do e1 <- type_stmt tret e s1; type_stmt tret e1 s2
+ | Sifthenelse a s1 s2 =>
+ do e1 <- type_expr e a Tint;
+ do e2 <- type_stmt tret e1 s1;
+ type_stmt tret e2 s2
+ | Sloop s1 =>
+ type_stmt tret e s1
+ | Sblock s1 =>
+ type_stmt tret e s1
+ | Sexit n =>
+ OK e
+ | Sswitch sz a tbl dfl =>
+ type_expr e a (if sz then Tlong else Tint)
+ | Sreturn opta =>
+ match opta with
+ | None => OK e
+ | Some a => type_expr e a (proj_rettype tret)
+(*
+ if rettype_eq tret Tvoid
+ then Error (msg "inconsistent return")
+ else type_expr e a (proj_rettype tret)
+*)
+ end
+ | Slabel lbl s1 =>
+ type_stmt tret e s1
+ | Sgoto lbl =>
+ OK e
+ end.
+
+Definition typenv := ident -> typ.
+
+Definition type_function (f: function) : res typenv :=
+ do e1 <- S.set_list S.initial f.(fn_params) f.(fn_sig).(sig_args);
+ do e2 <- type_stmt f.(fn_sig).(sig_res) e1 f.(fn_body);
+ S.solve e2.
+
+(** * Relational specification of the type system *)
+
+Section SPEC.
+
+Variable env: ident -> typ.
+Variable tret: rettype.
+
+Inductive wt_expr: expr -> typ -> Prop :=
+ | wt_Evar: forall id,
+ wt_expr (Evar id) (env id)
+ | wt_Econst: forall c,
+ wt_expr (Econst c) (type_constant c)
+ | wt_Eunop: forall op a1 targ1 tres,
+ type_unop op = (targ1, tres) ->
+ wt_expr a1 targ1 ->
+ wt_expr (Eunop op a1) tres
+ | wt_Ebinop: forall op a1 a2 targ1 targ2 tres,
+ type_binop op = (targ1, targ2, tres) ->
+ wt_expr a1 targ1 -> wt_expr a2 targ2 ->
+ wt_expr (Ebinop op a1 a2) tres
+ | wt_Eload: forall chunk a1,
+ wt_expr a1 Tptr ->
+ wt_expr (Eload chunk a1) (type_of_chunk chunk).
+
+Definition wt_opt_assign (optid: option ident) (ty: rettype) : Prop :=
+ match optid with
+ | Some id => proj_rettype ty = env id
+ | _ => True
+ end.
+
+Inductive wt_stmt: stmt -> Prop :=
+ | wt_Sskip:
+ wt_stmt Sskip
+ | wt_Sassign: forall id a,
+ wt_expr a (env id) ->
+ wt_stmt (Sassign id a)
+ | wt_Sstore: forall chunk a1 a2,
+ wt_expr a1 Tptr -> wt_expr a2 (type_of_chunk chunk) ->
+ wt_stmt (Sstore chunk a1 a2)
+ | wt_Scall: forall optid sg a1 al,
+ wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) ->
+ wt_opt_assign optid sg.(sig_res) ->
+ wt_stmt (Scall optid sg a1 al)
+ | wt_Stailcall: forall sg a1 al,
+ wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) ->
+ sg.(sig_res) = tret ->
+ wt_stmt (Stailcall sg a1 al)
+ | wt_Sbuiltin: forall optid ef al,
+ list_forall2 wt_expr al (ef_sig ef).(sig_args) ->
+ wt_opt_assign optid (ef_sig ef).(sig_res) ->
+ wt_stmt (Sbuiltin optid ef al)
+ | wt_Sseq: forall s1 s2,
+ wt_stmt s1 -> wt_stmt s2 ->
+ wt_stmt (Sseq s1 s2)
+ | wt_Sifthenelse: forall a s1 s2,
+ wt_expr a Tint -> wt_stmt s1 -> wt_stmt s2 ->
+ wt_stmt (Sifthenelse a s1 s2)
+ | wt_Sloop: forall s1,
+ wt_stmt s1 ->
+ wt_stmt (Sloop s1)
+ | wt_Sblock: forall s1,
+ wt_stmt s1 ->
+ wt_stmt (Sblock s1)
+ | wt_Sexit: forall n,
+ wt_stmt (Sexit n)
+ | wt_Sswitch: forall (sz: bool) a tbl dfl,
+ wt_expr a (if sz then Tlong else Tint) ->
+ wt_stmt (Sswitch sz a tbl dfl)
+ | wt_Sreturn_none:
+ wt_stmt (Sreturn None)
+ | wt_Sreturn_some: forall a,
+ wt_expr a (proj_rettype tret) ->
+ wt_stmt (Sreturn (Some a))
+ | wt_Slabel: forall lbl s1,
+ wt_stmt s1 ->
+ wt_stmt (Slabel lbl s1)
+ | wt_Sgoto: forall lbl,
+ wt_stmt (Sgoto lbl).
+
+End SPEC.
+
+Inductive wt_function (env: typenv) (f: function) : Prop :=
+ wt_function_intro:
+ type_function f = OK env -> (**r to ensure uniqueness of [env] *)
+ List.map env f.(fn_params) = f.(fn_sig).(sig_args) ->
+ wt_stmt env f.(fn_sig).(sig_res) f.(fn_body) ->
+ wt_function env f.
+
+Inductive wt_fundef: fundef -> Prop :=
+ | wt_fundef_internal: forall env f,
+ wt_function env f ->
+ wt_fundef (Internal f)
+ | wt_fundef_external: forall ef,
+ wt_fundef (External ef).
+
+Definition wt_program (p: program): Prop :=
+ forall i f, In (i, Gfun f) (prog_defs p) -> wt_fundef f.
+
+(** * Soundness of type inference *)
+
+Lemma expect_incr: forall te e t1 t2 e',
+ expect e t1 t2 = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto.
+Qed.
+Hint Resolve expect_incr: ty.
+
+Lemma expect_sound: forall e t1 t2 e',
+ expect e t1 t2 = OK e' -> t1 = t2.
+Proof.
+ unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto.
+Qed.
+
+Lemma type_expr_incr: forall te a t e e',
+ type_expr e a t = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty.
+- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty.
+- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty.
+Qed.
+Hint Resolve type_expr_incr: ty.
+
+Lemma type_expr_sound: forall te a t e e',
+ type_expr e a t = OK e' -> S.satisf te e' -> wt_expr te a t.
+Proof.
+ induction a; simpl; intros until e'; intros T SAT; try (monadInv T).
+- erewrite <- S.set_sound by eauto. constructor.
+- erewrite <- expect_sound by eauto. constructor.
+- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T.
+ erewrite <- expect_sound by eauto. econstructor; eauto with ty.
+- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T.
+ erewrite <- expect_sound by eauto. econstructor; eauto with ty.
+- erewrite <- expect_sound by eauto. econstructor; eauto with ty.
+Qed.
+
+Lemma type_exprlist_incr: forall te al tl e e',
+ type_exprlist e al tl = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T; eauto with ty.
+Qed.
+Hint Resolve type_exprlist_incr: ty.
+
+Lemma type_exprlist_sound: forall te al tl e e',
+ type_exprlist e al tl = OK e' -> S.satisf te e' -> list_forall2 (wt_expr te) al tl.
+Proof.
+ induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T.
+- constructor.
+- constructor; eauto using type_expr_sound with ty.
+Qed.
+
+Lemma type_assign_incr: forall te id a e e',
+ type_assign e id a = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty.
+- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty.
+- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty.
+Qed.
+Hint Resolve type_assign_incr: ty.
+
+Lemma type_assign_sound: forall te id a e e',
+ type_assign e id a = OK e' -> S.satisf te e' -> wt_expr te a (te id).
+Proof.
+ induction a; simpl; intros until e'; intros T SAT; try (monadInv T).
+- erewrite S.move_sound by eauto. constructor.
+- erewrite S.set_sound by eauto. constructor.
+- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T.
+ erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
+- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T.
+ erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
+- erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
+Qed.
+
+Lemma opt_set_incr: forall te optid optty e e',
+ opt_set e optid optty = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ unfold opt_set; intros. destruct optid, optty; try (monadInv H); eauto with ty.
+Qed.
+Hint Resolve opt_set_incr: ty.
+
+Lemma opt_set_sound: forall te optid sg e e',
+ opt_set e optid (proj_sig_res sg) = OK e' -> S.satisf te e' ->
+ wt_opt_assign te optid sg.(sig_res).
+Proof.
+ unfold opt_set; intros; red. destruct optid.
+- erewrite S.set_sound by eauto. auto.
+- inv H. auto.
+Qed.
+
+Lemma type_stmt_incr: forall te tret s e e',
+ type_stmt tret e s = OK e' -> S.satisf te e' -> S.satisf te e.
+Proof.
+ induction s; simpl; intros e1 e2 T SAT; try (monadInv T); eauto with ty.
+- destruct tret, o; try (monadInv T); eauto with ty.
+Qed.
+Hint Resolve type_stmt_incr: ty.
+
+Lemma type_stmt_sound: forall te tret s e e',
+ type_stmt tret e s = OK e' -> S.satisf te e' -> wt_stmt te tret s.
+Proof.
+ induction s; simpl; intros e1 e2 T SAT; try (monadInv T).
+- constructor.
+- constructor; eauto using type_assign_sound.
+- constructor; eauto using type_expr_sound with ty.
+- constructor; eauto using type_expr_sound, type_exprlist_sound, opt_set_sound with ty.
+- constructor; eauto using type_expr_sound, type_exprlist_sound with ty.
+- constructor; eauto using type_exprlist_sound, opt_set_sound with ty.
+- constructor; eauto with ty.
+- constructor; eauto using type_expr_sound with ty.
+- constructor; eauto.
+- constructor; eauto.
+- constructor.
+- constructor; eauto using type_expr_sound with ty.
+- destruct o; try (monadInv T); econstructor; eauto using type_expr_sound with ty.
+- constructor; eauto.
+- constructor.
+Qed.
+
+Theorem type_function_sound: forall f env,
+ type_function f = OK env -> wt_function env f.
+Proof.
+ intros. generalize H; unfold type_function; intros T; monadInv T.
+ assert (S.satisf env x0) by (apply S.solve_sound; auto).
+ constructor; eauto using S.set_list_sound, type_stmt_sound with ty.
+Qed.
+
+(** * Semantic soundness of the type system *)
+
+Definition wt_env (env: typenv) (e: Cminor.env) : Prop :=
+ forall id v, e!id = Some v -> Val.has_type v (env id).
+
+Definition def_env (f: function) (e: Cminor.env) : Prop :=
+ forall id, In id f.(fn_params) \/ In id f.(fn_vars) -> exists v, e!id = Some v.
+
+Inductive wt_cont_call: cont -> rettype -> Prop :=
+ | wt_cont_Kstop:
+ wt_cont_call Kstop Tint
+ | wt_cont_Kcall: forall optid f sp e k tret env
+ (WT_FN: wt_function env f)
+ (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k)
+ (WT_ENV: wt_env env e)
+ (DEF_ENV: def_env f e)
+ (WT_DEST: wt_opt_assign env optid tret),
+ wt_cont_call (Kcall optid f sp e k) tret
+
+with wt_cont: typenv -> rettype -> cont -> Prop :=
+ | wt_cont_Kseq: forall env tret s k,
+ wt_stmt env tret s ->
+ wt_cont env tret k ->
+ wt_cont env tret (Kseq s k)
+ | wt_cont_Kblock: forall env tret k,
+ wt_cont env tret k ->
+ wt_cont env tret (Kblock k)
+ | wt_cont_other: forall env tret k,
+ wt_cont_call k tret ->
+ wt_cont env tret k.
+
+Inductive wt_state: state -> Prop :=
+ | wt_normal_state: forall f s k sp e m env
+ (WT_FN: wt_function env f)
+ (WT_STMT: wt_stmt env f.(fn_sig).(sig_res) s)
+ (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k)
+ (WT_ENV: wt_env env e)
+ (DEF_ENV: def_env f e),
+ wt_state (State f s k sp e m)
+ | wt_call_state: forall f args k m
+ (WT_FD: wt_fundef f)
+ (WT_ARGS: Val.has_type_list args (funsig f).(sig_args))
+ (WT_CONT: wt_cont_call k (funsig f).(sig_res)),
+ wt_state (Callstate f args k m)
+ | wt_return_state: forall v k m tret
+ (WT_RES: Val.has_type v (proj_rettype tret))
+ (WT_CONT: wt_cont_call k tret),
+ wt_state (Returnstate v k m).
+
+Lemma wt_is_call_cont:
+ forall env tret k, wt_cont env tret k -> is_call_cont k -> wt_cont_call k tret.
+Proof.
+ destruct 1; intros ICC; contradiction || auto.
+Qed.
+
+Lemma call_cont_wt:
+ forall env tret k, wt_cont env tret k -> wt_cont_call (call_cont k) tret.
+Proof.
+ induction 1; simpl; auto. inversion H; subst; auto.
+Qed.
+
+Lemma wt_env_assign: forall env id e v,
+ wt_env env e -> Val.has_type v (env id) -> wt_env env (PTree.set id v e).
+Proof.
+ intros; red; intros. rewrite PTree.gsspec in H1; destruct (peq id0 id).
+- congruence.
+- auto.
+Qed.
+
+Lemma def_env_assign: forall f e id v,
+ def_env f e -> def_env f (PTree.set id v e).
+Proof.
+ intros; red; intros i IN. rewrite PTree.gsspec. destruct (peq i id).
+ exists v; auto.
+ auto.
+Qed.
+
+Lemma wt_env_set_params: forall env il vl,
+ Val.has_type_list vl (map env il) -> wt_env env (set_params vl il).
+Proof.
+ induction il as [ | i il]; destruct vl as [ | vl]; simpl; intros; try contradiction.
+- red; intros. rewrite PTree.gempty in H0; discriminate.
+- destruct H. apply wt_env_assign; auto.
+Qed.
+
+Lemma def_set_params: forall id il vl,
+ In id il -> exists v, PTree.get id (set_params vl il) = Some v.
+Proof.
+ induction il as [ | i il]; simpl; intros.
+- contradiction.
+- destruct vl as [ | v vl]; rewrite PTree.gsspec; destruct (peq id i).
+ econstructor; eauto.
+ apply IHil; intuition congruence.
+ econstructor; eauto.
+ apply IHil; intuition congruence.
+Qed.
+
+Lemma wt_env_set_locals: forall env il e,
+ wt_env env e -> wt_env env (set_locals il e).
+Proof.
+ induction il as [ | i il]; simpl; intros.
+- auto.
+- apply wt_env_assign; auto. exact I.
+Qed.
+
+Lemma def_set_locals: forall id il e,
+ (exists v, PTree.get id e = Some v) \/ In id il ->
+ exists v, PTree.get id (set_locals il e) = Some v.
+Proof.
+ induction il as [ | i il]; simpl; intros.
+- tauto.
+- rewrite PTree.gsspec; destruct (peq id i).
+ econstructor; eauto.
+ apply IHil; intuition congruence.
+Qed.
+
+Lemma wt_find_label: forall env tret lbl s k,
+ wt_stmt env tret s -> wt_cont env tret k ->
+ match find_label lbl s k with
+ | Some (s', k') => wt_stmt env tret s' /\ wt_cont env tret k'
+ | None => True
+ end.
+Proof.
+ induction s; intros k WS WK; simpl; auto.
+- inv WS. assert (wt_cont env tret (Kseq s2 k)) by (constructor; auto).
+ specialize (IHs1 _ H1 H). destruct (find_label lbl s1 (Kseq s2 k)).
+ auto. apply IHs2; auto.
+- inv WS. specialize (IHs1 _ H3 WK). destruct (find_label lbl s1 k).
+ auto. apply IHs2; auto.
+- inversion WS; subst. apply IHs; auto. constructor; auto.
+- inv WS. apply IHs; auto. constructor; auto.
+- inv WS. destruct (ident_eq lbl l). auto. apply IHs; auto.
+Qed.
+
+Section SUBJECT_REDUCTION.
+
+Variable p: program.
+
+Hypothesis wt_p: wt_program p.
+
+Let ge := Genv.globalenv p.
+
+Ltac VHT :=
+ match goal with
+ | [ |- Val.has_type (if Archi.ptr64 then _ else _) _] => unfold Val.has_type; destruct Archi.ptr64 eqn:?; VHT
+ | [ |- Val.has_type (match ?v with _ => _ end) _] => destruct v; VHT
+ | [ |- Val.has_type (Vptr _ _) Tptr ] => apply Val.Vptr_has_type
+ | [ |- Val.has_type _ _ ] => exact I
+ | [ |- Val.has_type (?f _ _ _ _ _) _ ] => unfold f; VHT
+ | [ |- Val.has_type (?f _ _ _ _) _ ] => unfold f; VHT
+ | [ |- Val.has_type (?f _ _) _ ] => unfold f; VHT
+ | [ |- Val.has_type (?f _ _ _) _ ] => unfold f; VHT
+ | [ |- Val.has_type (?f _) _ ] => unfold f; VHT
+ | [ |- True ] => exact I
+ | [ |- ?x = ?x ] => reflexivity
+ | _ => idtac
+ end.
+
+Ltac VHT' :=
+ match goal with
+ | [ H: None = Some _ |- _ ] => discriminate
+ | [ H: Some _ = Some _ |- _ ] => inv H; VHT
+ | [ H: match ?x with _ => _ end = Some _ |- _ ] => destruct x; VHT'
+ | [ H: ?f _ _ _ _ = Some _ |- _ ] => unfold f in H; VHT'
+ | [ H: ?f _ _ _ = Some _ |- _ ] => unfold f in H; VHT'
+ | [ H: ?f _ _ = Some _ |- _ ] => unfold f in H; VHT'
+ | [ H: ?f _ = Some _ |- _ ] => unfold f in H; VHT'
+ | _ => idtac
+ end.
+
+Lemma type_constant_sound: forall sp cst v,
+ eval_constant ge sp cst = Some v ->
+ Val.has_type v (type_constant cst).
+Proof.
+ intros until v; intros EV. destruct cst; simpl in *; inv EV; VHT.
+Qed.
+
+Lemma type_unop_sound: forall op v1 v,
+ eval_unop op v1 = Some v -> Val.has_type v (snd (type_unop op)).
+Proof.
+ unfold eval_unop; intros op v1 v EV; destruct op; simpl; VHT'.
+Qed.
+
+Lemma type_binop_sound: forall op v1 v2 m v,
+ eval_binop op v1 v2 m = Some v -> Val.has_type v (snd (type_binop op)).
+Proof.
+ unfold eval_binop; intros op v1 v2 m v EV; destruct op; simpl; VHT';
+ destruct (eq_block b b0); VHT.
+Qed.
+
+Lemma wt_eval_expr: forall env sp e m a v,
+ eval_expr ge sp e m a v ->
+ forall t,
+ wt_expr env a t ->
+ wt_env env e ->
+ Val.has_type v t.
+Proof.
+ induction 1; intros t WT ENV.
+- inv WT. apply ENV; auto.
+- inv WT. eapply type_constant_sound; eauto.
+- inv WT. replace t with (snd (type_unop op)) by (rewrite H3; auto). eapply type_unop_sound; eauto.
+- inv WT. replace t with (snd (type_binop op)) by (rewrite H5; auto). eapply type_binop_sound; eauto.
+- inv WT. destruct vaddr; try discriminate. eapply Mem.load_type; eauto.
+Qed.
+
+Lemma wt_eval_exprlist: forall env sp e m al vl,
+ eval_exprlist ge sp e m al vl ->
+ forall tl,
+ list_forall2 (wt_expr env) al tl ->
+ wt_env env e ->
+ Val.has_type_list vl tl.
+Proof.
+ induction 1; intros tl WT ENV; inv WT; simpl.
+- auto.
+- split. eapply wt_eval_expr; eauto. eauto.
+Qed.
+
+Lemma wt_find_funct: forall v fd,
+ Genv.find_funct ge v = Some fd -> wt_fundef fd.
+Proof.
+ intros. eapply Genv.find_funct_prop; eauto.
+Qed.
+
+Lemma subject_reduction:
+ forall st1 t st2, step ge st1 t st2 ->
+ forall (WT: wt_state st1), wt_state st2.
+Proof.
+ destruct 1; intros; inv WT.
+- inv WT_CONT. econstructor; eauto. inv H.
+- inv WT_CONT. econstructor; eauto. inv H.
+- econstructor; eauto using wt_is_call_cont. exact I.
+- inv WT_STMT. econstructor; eauto using wt_Sskip.
+ apply wt_env_assign; auto. eapply wt_eval_expr; eauto.
+ apply def_env_assign; auto.
+- econstructor; eauto using wt_Sskip.
+- inv WT_STMT. econstructor; eauto.
+ eapply wt_find_funct; eauto.
+ eapply wt_eval_exprlist; eauto.
+ econstructor; eauto.
+- inv WT_STMT. econstructor; eauto.
+ eapply wt_find_funct; eauto.
+ eapply wt_eval_exprlist; eauto.
+ rewrite H8; eapply call_cont_wt; eauto.
+- inv WT_STMT. exploit external_call_well_typed; eauto. intros TRES.
+ econstructor; eauto using wt_Sskip.
+ destruct optid; auto. apply wt_env_assign; auto. rewrite <- H5; auto.
+ destruct optid; auto. apply def_env_assign; auto.
+- inv WT_STMT. econstructor; eauto. econstructor; eauto.
+- inv WT_STMT. destruct b; econstructor; eauto.
+- inv WT_STMT. econstructor; eauto. econstructor; eauto. constructor; auto.
+- inv WT_STMT. econstructor; eauto. econstructor; eauto.
+- inv WT_CONT. econstructor; eauto. inv H.
+- inv WT_CONT. econstructor; eauto using wt_Sskip. inv H.
+- inv WT_CONT. econstructor; eauto using wt_Sexit. inv H.
+- econstructor; eauto using wt_Sexit.
+- inv WT_STMT. econstructor; eauto using call_cont_wt. exact I.
+- inv WT_STMT. econstructor; eauto using call_cont_wt.
+ eapply wt_eval_expr; eauto.
+- inv WT_STMT. econstructor; eauto.
+- inversion WT_FN; subst.
+ assert (WT_CK: wt_cont env (sig_res (fn_sig f)) (call_cont k)).
+ { constructor. eapply call_cont_wt; eauto. }
+ generalize (wt_find_label _ _ lbl _ _ H2 WT_CK).
+ rewrite H. intros [WT_STMT' WT_CONT']. econstructor; eauto.
+- inv WT_FD. inversion H1; subst. econstructor; eauto.
+ constructor; auto.
+ apply wt_env_set_locals. apply wt_env_set_params. rewrite H2; auto.
+ red; intros. apply def_set_locals. destruct H4; auto. left; apply def_set_params; auto.
+- exploit external_call_well_typed; eauto. intros.
+ econstructor; eauto.
+- inv WT_CONT. econstructor; eauto using wt_Sskip.
+ red in WT_DEST.
+ destruct optid. rewrite WT_DEST in WT_RES. apply wt_env_assign; auto. assumption.
+ destruct optid. apply def_env_assign; auto. assumption.
+Qed.
+
+Lemma subject_reduction_star:
+ forall st1 t st2, star step ge st1 t st2 ->
+ forall (WT: wt_state st1), wt_state st2.
+Proof.
+ induction 1; eauto using subject_reduction.
+Qed.
+
+Lemma wt_initial_state:
+ forall S, initial_state p S -> wt_state S.
+Proof.
+ intros. inv H. constructor. eapply Genv.find_funct_ptr_prop; eauto.
+ rewrite H3; constructor.
+ rewrite H3; constructor.
+Qed.
+
+End SUBJECT_REDUCTION.
+
+(** * Safe expressions *)
+
+(** Function parameters and declared local variables are always defined
+ throughout the execution of a function. The following [known_idents]
+ data structure represents the set of those variables, with efficient membership. *)
+
+Definition known_idents := PTree.t unit.
+
+Definition is_known (ki: known_idents) (id: ident) :=
+ match ki!id with Some _ => true | None => false end.
+
+Definition known_id (f: function) : known_idents :=
+ let add (ki: known_idents) (id: ident) := PTree.set id tt ki in
+ List.fold_left add f.(fn_vars)
+ (List.fold_left add f.(fn_params) (PTree.empty unit)).
+
+(** A Cminor expression is safe if it always evaluates to a value,
+ never causing a run-time error. *)
+
+Definition safe_unop (op: unary_operation) : bool :=
+ match op with
+ | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => false
+ | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => false
+ | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => false
+ | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => false
+ | _ => true
+ end.
+
+Definition safe_binop (op: binary_operation) : bool :=
+ match op with
+ | Odiv | Odivu | Omod | Omodu => false
+ | Odivl | Odivlu | Omodl | Omodlu => false
+ | Ocmpl _ | Ocmplu _ => false
+ | _ => true
+ end.
+
+Fixpoint safe_expr (ki: known_idents) (a: expr) : bool :=
+ match a with
+ | Evar v => is_known ki v
+ | Econst c => true
+ | Eunop op e1 => safe_unop op && safe_expr ki e1
+ | Ebinop op e1 e2 => safe_binop op && safe_expr ki e1 && safe_expr ki e2
+ | Eload chunk e => false
+ end.
+
+(** Soundness of [known_id]. *)
+
+Lemma known_id_sound_1:
+ forall f id x, (known_id f)!id = Some x -> In id f.(fn_params) \/ In id f.(fn_vars).
+Proof.
+ unfold known_id.
+ set (add := fun (ki: known_idents) (id: ident) => PTree.set id tt ki).
+ intros.
+ assert (REC: forall l ki, (fold_left add l ki)!id = Some x -> In id l \/ ki!id = Some x).
+ { induction l as [ | i l ]; simpl; intros.
+ - auto.
+ - apply IHl in H0. destruct H0; auto. unfold add in H0; rewrite PTree.gsspec in H0.
+ destruct (peq id i); auto. }
+ apply REC in H. destruct H; auto. apply REC in H. destruct H; auto.
+ rewrite PTree.gempty in H; discriminate.
+Qed.
+
+Lemma known_id_sound_2:
+ forall f id, is_known (known_id f) id = true -> In id f.(fn_params) \/ In id f.(fn_vars).
+Proof.
+ unfold is_known; intros. destruct (known_id f)!id eqn:E; try discriminate.
+ eapply known_id_sound_1; eauto.
+Qed.
+
+(** Expressions that satisfy [safe_expr] always evaluate to a value. *)
+
+Lemma eval_safe_expr:
+ forall ge f sp e m a,
+ def_env f e ->
+ safe_expr (known_id f) a = true ->
+ exists v, eval_expr ge sp e m a v.
+Proof.
+ induction a; simpl; intros.
+ - apply known_id_sound_2 in H0.
+ destruct (H i H0) as [v E].
+ exists v; constructor; auto.
+ - destruct (eval_constant ge sp c) as [v|] eqn:E.
+ exists v; constructor; auto.
+ destruct c; discriminate.
+ - InvBooleans. destruct IHa as [v1 E1]; auto.
+ destruct (eval_unop u v1) as [v|] eqn:E.
+ exists v; econstructor; eauto.
+ destruct u; discriminate.
+ - InvBooleans.
+ destruct IHa1 as [v1 E1]; auto.
+ destruct IHa2 as [v2 E2]; auto.
+ destruct (eval_binop b v1 v2 m) as [v|] eqn:E.
+ exists v; econstructor; eauto.
+ destruct b; discriminate.
+ - discriminate.
+Qed.
+
+
diff --git a/backend/Constprop.v b/backend/Constprop.v
index d8211ffe..0be9438c 100644
--- a/backend/Constprop.v
+++ b/backend/Constprop.v
@@ -15,7 +15,7 @@
and the corresponding code rewriting. *)
Require Import Coqlib Maps Integers Floats Lattice Kildall.
-Require Import AST Linking.
+Require Import AST Linking Builtins.
Require Compopts Machregs.
Require Import Op Registers RTL.
Require Import Liveness ValueDomain ValueAOp ValueAnalysis.
@@ -69,7 +69,7 @@ Fixpoint successor_rec (n: nat) (f: function) (ae: AE.t) (pc: node) : node :=
match f.(fn_code)!pc with
| Some (Inop s) =>
successor_rec n' f ae s
- | Some (Icond cond args s1 s2) =>
+ | Some (Icond cond args s1 s2 _) =>
match resolve_branch (eval_static_condition cond (aregs ae args)) with
| Some b => successor_rec n' f ae (if b then s1 else s2)
| None => pc
@@ -139,6 +139,30 @@ Definition builtin_strength_reduction
| _ => builtin_args_strength_reduction ae al (Machregs.builtin_constraints ef)
end.
+(*
+Definition transf_builtin
+ (ae: AE.t) (am: amem) (rm: romem)
+ (ef: external_function)
+ (args: list (builtin_arg reg)) (res: builtin_res reg) (s: node) :=
+ let dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res s in
+ match ef, res with
+ | EF_builtin name sg, BR rd =>
+ match lookup_builtin_function name sg with
+ | Some bf =>
+ match eval_static_builtin_function ae am rm bf args with
+ | Some a =>
+ match const_for_result a with
+ | Some cop => Iop cop nil rd s
+ | None => dfl
+ end
+ | None => dfl
+ end
+ | None => dfl
+ end
+ | _, _ => dfl
+ end.
+*)
+
Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
(pc: node) (instr: instruction) :=
match an!!pc with
@@ -157,7 +181,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
let (op', args') := op_strength_reduction op args aargs in
Iop op' args' res s'
end
- | Iload chunk addr args dst s =>
+ | Iload TRAP chunk addr args dst s =>
let aargs := aregs ae args in
let a := ValueDomain.loadv chunk rm am (eval_static_addressing addr aargs) in
match const_for_result a with
@@ -165,7 +189,7 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
Iop cop nil dst s
| None =>
let (addr', args') := addr_strength_reduction addr args aargs in
- Iload chunk addr' args' dst s
+ Iload TRAP chunk addr' args' dst s
end
| Istore chunk addr args src s =>
let aargs := aregs ae args in
@@ -176,15 +200,31 @@ Definition transf_instr (f: function) (an: PMap.t VA.t) (rm: romem)
| Itailcall sig ros args =>
Itailcall sig (transf_ros ae ros) args
| Ibuiltin ef args res s =>
- Ibuiltin ef (builtin_strength_reduction ae ef args) res s
- | Icond cond args s1 s2 =>
+ let dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res s in
+ match ef, res with
+ | EF_builtin name sg, BR rd =>
+ match lookup_builtin_function name sg with
+ | Some bf =>
+ match eval_static_builtin_function ae am rm bf args with
+ | Some a =>
+ match const_for_result a with
+ | Some cop => Iop cop nil rd s
+ | None => dfl
+ end
+ | None => dfl
+ end
+ | None => dfl
+ end
+ | _, _ => dfl
+ end
+ | Icond cond args s1 s2 i =>
let aargs := aregs ae args in
match resolve_branch (eval_static_condition cond aargs) with
| Some b =>
if b then Inop s1 else Inop s2
| None =>
let (cond', args') := cond_strength_reduction cond args aargs in
- Icond cond' args' s1 s2
+ Icond cond' args' s1 s2 i
end
| Ijumptable arg tbl =>
match areg ae arg with
diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v
index e28519ca..60663503 100644
--- a/backend/Constpropproof.v
+++ b/backend/Constpropproof.v
@@ -14,7 +14,7 @@
Require Import Coqlib Maps Integers Floats Lattice Kildall.
Require Import AST Linking.
-Require Import Values Events Memory Globalenvs Smallstep.
+Require Import Values Builtins Events Memory Globalenvs Smallstep.
Require Compopts Machregs.
Require Import Op Registers RTL.
Require Import Liveness ValueDomain ValueAOp ValueAnalysis.
@@ -142,8 +142,8 @@ Inductive match_pc (f: function) (rs: regset) (m: mem): nat -> node -> node -> P
f.(fn_code)!pc = Some (Inop s) ->
match_pc f rs m n s pcx ->
match_pc f rs m (S n) pc pcx
- | match_pc_cond: forall n pc cond args s1 s2 pcx,
- f.(fn_code)!pc = Some (Icond cond args s1 s2) ->
+ | match_pc_cond: forall n pc cond args s1 s2 pcx i,
+ f.(fn_code)!pc = Some (Icond cond args s1 s2 i) ->
(forall b,
eval_condition cond rs##args m = Some b ->
match_pc f rs m n (if b then s1 else s2) pcx) ->
@@ -406,6 +406,8 @@ Proof.
assert (VM1: vmatch bc a aa) by (eapply eval_static_addressing_sound; eauto with va).
set (av := loadv chunk (romem_for cu) am aa).
assert (VM2: vmatch bc v av) by (eapply loadv_sound; eauto).
+ destruct trap.
+ {
destruct (const_for_result av) as [cop|] eqn:?; intros.
+ (* constant-propagated *)
exploit const_for_result_correct; eauto. intros (v' & A & B).
@@ -431,6 +433,59 @@ Proof.
left; econstructor; econstructor; split.
eapply exec_Iload; eauto.
eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
+ }
+ {
+ assert (exists v2 : val,
+ eval_addressing ge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = Some v2 /\ Val.lessdef a v2) as Hexist2.
+ apply eval_addressing_lessdef with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ destruct Hexist2 as [v2 [Heval2 Hlessdef2]].
+ destruct (Mem.loadv_extends chunk m m' a v2 v MEM H1 Hlessdef2) as [vX [Hvx1 Hvx2]].
+ left; econstructor; econstructor; split.
+ eapply exec_Iload with (a := v2); eauto.
+ try (erewrite eval_addressing_preserved with (ge1:=ge); auto;
+ exact symbols_preserved).
+ eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
+
+ }
+
+- (* Iload notrap1 *)
+ rename pc'0 into pc. TransfInstr.
+ assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = None).
+ rewrite eval_addressing_preserved with (ge1 := ge); eauto.
+ apply eval_addressing_lessdef_none with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ exact symbols_preserved.
+
+ left; econstructor; econstructor; split.
+ eapply exec_Iload_notrap1; eauto.
+ eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
+
+- (* Iload notrap2 *)
+ rename pc'0 into pc. TransfInstr.
+ assert (exists v2 : val,
+ eval_addressing ge (Vptr sp0 Ptrofs.zero) addr (rs' ## args) = Some v2 /\ Val.lessdef a v2) as Hexist2.
+ apply eval_addressing_lessdef with (vl1 := rs ## args).
+ apply regs_lessdef_regs; assumption.
+ assumption.
+ destruct Hexist2 as [a' [Heval' Hlessdef']].
+ destruct (Mem.loadv chunk m' a') eqn:Hload'.
+ {
+ left; econstructor; econstructor; split.
+ eapply exec_Iload; eauto.
+
+ try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved).
+ eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
+ }
+ {
+ left; econstructor; econstructor; split.
+ eapply exec_Iload_notrap2; eauto.
+
+ try (rewrite eval_addressing_preserved with (ge1 := ge); auto; exact symbols_preserved).
+ eapply match_states_succ; eauto. apply set_reg_lessdef; auto.
+ }
- (* Istore *)
rename pc'0 into pc. TransfInstr.
@@ -474,19 +529,41 @@ Proof.
- (* Ibuiltin *)
rename pc'0 into pc. TransfInstr; intros.
Opaque builtin_strength_reduction.
- exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q).
- exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)).
+ set (dfl := Ibuiltin ef (builtin_strength_reduction ae ef args) res pc') in *.
+ set (rm := romem_for cu) in *.
+ assert (DFL: (fn_code (transf_function rm f))!pc = Some dfl ->
+ exists (n2 : nat) (s2' : state),
+ step tge
+ (State s' (transf_function rm f) (Vptr sp0 Ptrofs.zero) pc rs' m'0) t s2' /\
+ match_states n2
+ (State s f (Vptr sp0 Ptrofs.zero) pc' (regmap_setres res vres rs) m') s2').
+ {
+ exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q).
+ exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)).
apply REGS. eauto. eexact P.
- intros (vargs'' & U & V).
- exploit external_call_mem_extends; eauto.
- intros [v' [m2' [A [B [C D]]]]].
+ intros (vargs'' & U & V).
+ exploit external_call_mem_extends; eauto.
+ intros (v' & m2' & A & B & C & D).
+ econstructor; econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eapply match_states_succ; eauto.
+ apply set_res_lessdef; auto.
+ }
+ destruct ef; auto.
+ destruct res; auto.
+ destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto.
+ destruct (eval_static_builtin_function ae am rm bf args) as [a|] eqn:ES; auto.
+ destruct (const_for_result a) as [cop|] eqn:CR; auto.
+ clear DFL. simpl in H1; red in H1; rewrite LK in H1; inv H1.
+ exploit const_for_result_correct; eauto.
+ eapply eval_static_builtin_function_sound; eauto.
+ intros (v' & A & B).
left; econstructor; econstructor; split.
- eapply exec_Ibuiltin; eauto.
- eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto.
- eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eapply exec_Iop; eauto.
eapply match_states_succ; eauto.
- apply set_res_lessdef; auto.
-
+ apply set_reg_lessdef; auto.
- (* Icond, preserved *)
rename pc'0 into pc. TransfInstr.
set (ac := eval_static_condition cond (aregs ae args)).
diff --git a/backend/Conventions.v b/backend/Conventions.v
index 989bfa05..14ffb587 100644
--- a/backend/Conventions.v
+++ b/backend/Conventions.v
@@ -34,6 +34,73 @@ Proof.
apply IHpl; auto.
Qed.
+(** ** Stack size of function arguments *)
+
+(** [size_arguments s] returns the number of [Outgoing] slots used
+ to call a function with signature [s]. *)
+
+Definition max_outgoing_1 (accu: Z) (l: loc) : Z :=
+ match l with
+ | S Outgoing ofs ty => Z.max accu (ofs + typesize ty)
+ | _ => accu
+ end.
+
+Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z :=
+ match rl with
+ | One l => max_outgoing_1 accu l
+ | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2
+ end.
+
+Definition size_arguments (s: signature) : Z :=
+ List.fold_left max_outgoing_2 (loc_arguments s) 0.
+
+(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
+
+Remark fold_max_outgoing_above:
+ forall l n, fold_left max_outgoing_2 l n >= n.
+Proof.
+ assert (A: forall n l, max_outgoing_1 n l >= n).
+ { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. }
+ induction l; simpl; intros.
+ - omega.
+ - eapply Zge_trans. eauto.
+ destruct a; simpl. apply A. eapply Zge_trans; eauto.
+Qed.
+
+Lemma size_arguments_above:
+ forall s, size_arguments s >= 0.
+Proof.
+ intros. apply fold_max_outgoing_above.
+Qed.
+
+Lemma loc_arguments_bounded:
+ forall (s: signature) (ofs: Z) (ty: typ),
+ In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
+ ofs + typesize ty <= size_arguments s.
+Proof.
+ intros until ty.
+ assert (A: forall n l, n <= max_outgoing_1 n l).
+ { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. }
+ assert (B: forall p n,
+ In (S Outgoing ofs ty) (regs_of_rpair p) ->
+ ofs + typesize ty <= max_outgoing_2 n p).
+ { intros. destruct p; simpl in H; intuition; subst; simpl.
+ - xomega.
+ - eapply Z.le_trans. 2: apply A. xomega.
+ - xomega. }
+ assert (C: forall l n,
+ In (S Outgoing ofs ty) (regs_of_rpairs l) ->
+ ofs + typesize ty <= fold_left max_outgoing_2 l n).
+ { induction l; simpl; intros.
+ - contradiction.
+ - rewrite in_app_iff in H. destruct H.
+ + eapply Z.le_trans. eapply B; eauto.
+ apply Z.ge_le. apply fold_max_outgoing_above.
+ + apply IHl; auto.
+ }
+ apply C.
+Qed.
+
(** ** Location of function parameters *)
(** A function finds the values of its parameter in the same locations
@@ -128,8 +195,6 @@ Definition callee_save_loc (l: loc) :=
| S sl ofs ty => sl <> Outgoing
end.
-Hint Unfold callee_save_loc.
-
Definition agree_callee_save (ls1 ls2: Locmap.t) : Prop :=
forall l, callee_save_loc l -> ls1 l = ls2 l.
diff --git a/backend/Deadcode.v b/backend/Deadcode.v
index 2286876e..3412a6fa 100644
--- a/backend/Deadcode.v
+++ b/backend/Deadcode.v
@@ -123,7 +123,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t)
if is_dead nres then after
else if is_int_zero nres then (kill res ne, nm)
else (add_needs args (needs_of_operation op nres) (kill res ne), nm)
- | Some (Iload chunk addr args dst s) =>
+ | Some (Iload trap chunk addr args dst s) =>
let ndst := nreg ne dst in
if is_dead ndst then after
else if is_int_zero ndst then (kill dst ne, nm)
@@ -142,7 +142,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t)
nmem_dead_stack f.(fn_stacksize))
| Some(Ibuiltin ef args res s) =>
transfer_builtin approx!!pc ef args res ne nm
- | Some(Icond cond args s1 s2) =>
+ | Some(Icond cond args s1 s2 _) =>
if peq s1 s2 then after else
(add_needs args (needs_of_condition cond) ne, nm)
| Some(Ijumptable arg tbl) =>
@@ -175,7 +175,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t)
end
else
instr
- | Iload chunk addr args dst s =>
+ | Iload trap chunk addr args dst s =>
let ndst := nreg (fst an!!pc) dst in
if is_dead ndst then
Inop s
@@ -192,7 +192,7 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t)
if nmem_contains (snd an!!pc) (aaddr_arg approx!!pc dst) sz
then instr
else Inop s
- | Icond cond args s1 s2 =>
+ | Icond cond args s1 s2 _ =>
if peq s1 s2 then Inop s1 else instr
| _ =>
instr
diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v
index 199ac922..6919fe78 100644
--- a/backend/Deadcodeproof.v
+++ b/backend/Deadcodeproof.v
@@ -106,7 +106,7 @@ Local Transparent Mem.loadbytes.
unfold Mem.loadbytes; intros. destruct H.
destruct (Mem.range_perm_dec m1 b ofs (ofs + n) Cur Readable); inv H0.
rewrite pred_dec_true. econstructor; split; eauto.
- apply GETN. intros. rewrite nat_of_Z_max in H.
+ apply GETN. intros. rewrite Z_to_nat_max in H.
assert (ofs <= i < ofs + n) by xomega.
apply ma_memval0; auto.
red; intros; eauto.
@@ -829,6 +829,83 @@ Ltac UseTransfer :=
apply eagree_update; eauto 2 with na.
eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+- (* load notrap1 *)
+ TransfInstr; UseTransfer.
+ destruct (is_dead (nreg ne dst)) eqn:DEAD;
+ [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO];
+ simpl in *.
++ (* dead instruction, turned into a nop *)
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update_dead; auto with na.
++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
+ econstructor; split.
+ eapply exec_Iop with (v := Vint Int.zero); eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; auto.
+ rewrite is_int_zero_sound by auto.
+ unfold default_notrap_load_value.
+ constructor.
++ (* preserved *)
+ exploit eval_addressing_lessdef_none. eapply add_needs_all_lessdef; eauto. eassumption.
+ intro Hnone'.
+ assert (eval_addressing tge (Vptr sp0 Ptrofs.zero) addr te ## args = None) as Hnone2'.
+ erewrite eval_addressing_preserved with (ge1 := ge).
+ assumption.
+ exact symbols_preserved.
+
+ econstructor; split.
+ eapply exec_Iload_notrap1; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto 2 with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+
+- (* load notrap2 *)
+ TransfInstr; UseTransfer.
+
+ destruct (is_dead (nreg ne dst)) eqn:DEAD;
+ [idtac|destruct (is_int_zero (nreg ne dst)) eqn:INTZERO];
+ simpl in *.
++ (* dead instruction, turned into a nop *)
+ econstructor; split.
+ eapply exec_Inop; eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update_dead; auto with na.
++ (* instruction with needs = [I Int.zero], turned into a load immediate of zero. *)
+ econstructor; split.
+ eapply exec_Iop with (v := Vint Int.zero); eauto.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; auto.
+ rewrite is_int_zero_sound by auto.
+ unfold default_notrap_load_value.
+ constructor.
++ (* preserved *)
+ exploit eval_addressing_lessdef. eapply add_needs_all_lessdef; eauto. eauto.
+ intros (ta & U & V).
+ destruct (Mem.loadv chunk tm ta) eqn:Hchunk2.
+ {
+ econstructor; split.
+ eapply exec_Iload. eauto.
+ erewrite eval_addressing_preserved with (ge1 := ge).
+ eassumption.
+ exact symbols_preserved.
+ eassumption.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto 2 with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+ }
+ {
+ econstructor; split.
+ eapply exec_Iload_notrap2. eauto.
+ erewrite eval_addressing_preserved with (ge1 := ge).
+ eassumption.
+ exact symbols_preserved.
+ eassumption.
+ eapply match_succ_states; eauto. simpl; auto.
+ apply eagree_update; eauto 2 with na.
+ eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto.
+ }
- (* store *)
TransfInstr; UseTransfer.
destruct (nmem_contains nm (aaddressing (vanalyze cu f) # pc addr args)
@@ -966,7 +1043,7 @@ Ltac UseTransfer :=
intros. eapply nlive_remove; eauto.
unfold adst, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto.
erewrite Mem.loadbytes_length in H1 by eauto.
- rewrite nat_of_Z_eq in H1 by omega. auto.
+ rewrite Z2Nat.id in H1 by omega. auto.
eauto.
intros (tm' & A & B).
econstructor; split.
@@ -993,7 +1070,7 @@ Ltac UseTransfer :=
intros (bc & A & B & C).
intros. eapply nlive_contains; eauto.
erewrite Mem.loadbytes_length in H0 by eauto.
- rewrite nat_of_Z_eq in H0 by omega. auto.
+ rewrite Z2Nat.id in H0 by omega. auto.
+ (* annot *)
destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x2) as (ne1, nm1) eqn:TR.
InvSoundState.
diff --git a/backend/Debugvar.v b/backend/Debugvar.v
index 1f361030..56908855 100644
--- a/backend/Debugvar.v
+++ b/backend/Debugvar.v
@@ -233,7 +233,7 @@ Definition transfer (lm: labelmap) (before: option avail) (i: instruction):
(lm, Some (kill (S sl ofs ty) s))
| Lop op args dst =>
(lm, Some (kill (R dst) s))
- | Lload chunk addr args dst =>
+ | Lload trap chunk addr args dst =>
(lm, Some (kill (R dst) s))
| Lstore chunk addr args src =>
(lm, before)
diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v
index d31c63ec..95020637 100644
--- a/backend/Debugvarproof.v
+++ b/backend/Debugvarproof.v
@@ -449,6 +449,22 @@ Proof.
eauto. eauto.
apply eval_add_delta_ranges. traceEq.
constructor; auto.
+- (* load notrap1 *)
+ econstructor; split.
+ eapply plus_left.
+ eapply exec_Lload_notrap1.
+ rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
+ eauto. eauto.
+ apply eval_add_delta_ranges. traceEq.
+ constructor; auto.
+- (* load notrap2 *)
+ econstructor; split.
+ eapply plus_left.
+ eapply exec_Lload_notrap2.
+ rewrite <- H; apply eval_addressing_preserved; exact symbols_preserved.
+ eauto. eauto.
+ apply eval_add_delta_ranges. traceEq.
+ constructor; auto.
- (* store *)
econstructor; split.
eapply plus_left.
diff --git a/backend/Duplicate.v b/backend/Duplicate.v
new file mode 100644
index 00000000..af85efe4
--- /dev/null
+++ b/backend/Duplicate.v
@@ -0,0 +1,203 @@
+(** RTL node duplication using external oracle. Used to form superblock
+ structures *)
+
+Require Import AST RTL Maps Globalenvs.
+Require Import Coqlib Errors Op.
+
+Local Open Scope error_monad_scope.
+Local Open Scope positive_scope.
+
+(** External oracle returning the new RTL code (entry point unchanged),
+ along with the new entrypoint, and a mapping of new nodes to old nodes *)
+Axiom duplicate_aux: function -> code * node * (PTree.t node).
+
+Extract Constant duplicate_aux => "Duplicateaux.duplicate_aux".
+
+(** * Verification of node duplications *)
+
+Definition verify_is_copy dupmap n n' :=
+ match dupmap!n' with
+ | None => Error(msg "verify_is_copy None")
+ | Some revn => match (Pos.compare n revn) with Eq => OK tt | _ => Error(msg "verify_is_copy invalid map") end
+ end.
+
+Fixpoint verify_is_copy_list dupmap ln ln' :=
+ match ln with
+ | n::ln => match ln' with
+ | n'::ln' => do u <- verify_is_copy dupmap n n';
+ verify_is_copy_list dupmap ln ln'
+ | nil => Error (msg "verify_is_copy_list: ln' bigger than ln") end
+ | nil => match ln' with
+ | n :: ln' => Error (msg "verify_is_copy_list: ln bigger than ln'")
+ | nil => OK tt end
+ end.
+
+Definition verify_mapping_entrypoint dupmap (f f': function): res unit :=
+ verify_is_copy dupmap (fn_entrypoint f) (fn_entrypoint f').
+
+Lemma product_eq {A B: Type} :
+ (forall (a b: A), {a=b} + {a<>b}) ->
+ (forall (c d: B), {c=d} + {c<>d}) ->
+ forall (x y: A+B), {x=y} + {x<>y}.
+Proof.
+ intros H H'. intros. decide equality.
+Qed.
+
+(** FIXME Ideally i would like to put this in AST.v but i get an "illegal application"
+ * error when doing so *)
+Remark builtin_arg_eq_pos: forall (a b: builtin_arg positive), {a=b} + {a<>b}.
+Proof.
+ intros.
+ apply (builtin_arg_eq Pos.eq_dec).
+Defined.
+Global Opaque builtin_arg_eq_pos.
+
+Remark builtin_res_eq_pos: forall (a b: builtin_res positive), {a=b} + {a<>b}.
+Proof. intros. apply (builtin_res_eq Pos.eq_dec). Qed.
+Global Opaque builtin_res_eq_pos.
+
+Definition verify_match_inst dupmap inst tinst :=
+ match inst with
+ | Inop n => match tinst with Inop n' => do u <- verify_is_copy dupmap n n'; OK tt | _ => Error(msg "verify_match_inst Inop") end
+
+ | Iop op lr r n => match tinst with
+ Iop op' lr' r' n' =>
+ do u <- verify_is_copy dupmap n n';
+ if (eq_operation op op') then
+ if (list_eq_dec Pos.eq_dec lr lr') then
+ if (Pos.eq_dec r r') then
+ OK tt
+ else Error (msg "Different r in Iop")
+ else Error (msg "Different lr in Iop")
+ else Error(msg "Different operations in Iop")
+ | _ => Error(msg "verify_match_inst Inop") end
+
+ | Iload tm m a lr r n => match tinst with
+ | Iload tm' m' a' lr' r' n' =>
+ do u <- verify_is_copy dupmap n n';
+ if (trapping_mode_eq tm tm') then
+ if (chunk_eq m m') then
+ if (eq_addressing a a') then
+ if (list_eq_dec Pos.eq_dec lr lr') then
+ if (Pos.eq_dec r r') then OK tt
+ else Error (msg "Different r in Iload")
+ else Error (msg "Different lr in Iload")
+ else Error (msg "Different addressing in Iload")
+ else Error (msg "Different mchunk in Iload")
+ else Error (msg "Different trapping_mode in Iload")
+ | _ => Error (msg "verify_match_inst Iload") end
+
+ | Istore m a lr r n => match tinst with
+ | Istore m' a' lr' r' n' =>
+ do u <- verify_is_copy dupmap n n';
+ if (chunk_eq m m') then
+ if (eq_addressing a a') then
+ if (list_eq_dec Pos.eq_dec lr lr') then
+ if (Pos.eq_dec r r') then OK tt
+ else Error (msg "Different r in Istore")
+ else Error (msg "Different lr in Istore")
+ else Error (msg "Different addressing in Istore")
+ else Error (msg "Different mchunk in Istore")
+ | _ => Error (msg "verify_match_inst Istore") end
+
+ | Icall s ri lr r n => match tinst with
+ | Icall s' ri' lr' r' n' =>
+ do u <- verify_is_copy dupmap n n';
+ if (signature_eq s s') then
+ if (product_eq Pos.eq_dec ident_eq ri ri') then
+ if (list_eq_dec Pos.eq_dec lr lr') then
+ if (Pos.eq_dec r r') then OK tt
+ else Error (msg "Different r r' in Icall")
+ else Error (msg "Different lr in Icall")
+ else Error (msg "Different ri in Icall")
+ else Error (msg "Different signatures in Icall")
+ | _ => Error (msg "verify_match_inst Icall") end
+
+ | Itailcall s ri lr => match tinst with
+ | Itailcall s' ri' lr' =>
+ if (signature_eq s s') then
+ if (product_eq Pos.eq_dec ident_eq ri ri') then
+ if (list_eq_dec Pos.eq_dec lr lr') then OK tt
+ else Error (msg "Different lr in Itailcall")
+ else Error (msg "Different ri in Itailcall")
+ else Error (msg "Different signatures in Itailcall")
+ | _ => Error (msg "verify_match_inst Itailcall") end
+
+ | Ibuiltin ef lbar brr n => match tinst with
+ | Ibuiltin ef' lbar' brr' n' =>
+ do u <- verify_is_copy dupmap n n';
+ if (external_function_eq ef ef') then
+ if (list_eq_dec builtin_arg_eq_pos lbar lbar') then
+ if (builtin_res_eq_pos brr brr') then OK tt
+ else Error (msg "Different brr in Ibuiltin")
+ else Error (msg "Different lbar in Ibuiltin")
+ else Error (msg "Different ef in Ibuiltin")
+ | _ => Error (msg "verify_match_inst Ibuiltin") end
+
+ | Icond cond lr n1 n2 i => match tinst with
+ | Icond cond' lr' n1' n2' i' =>
+ if (list_eq_dec Pos.eq_dec lr lr') then
+ if (eq_condition cond cond') then
+ do u1 <- verify_is_copy dupmap n1 n1';
+ do u2 <- verify_is_copy dupmap n2 n2'; OK tt
+ else if (eq_condition (negate_condition cond) cond') then
+ do u1 <- verify_is_copy dupmap n1 n2';
+ do u2 <- verify_is_copy dupmap n2 n1'; OK tt
+ else Error (msg "Incompatible conditions in Icond")
+ else Error (msg "Different lr in Icond")
+ | _ => Error (msg "verify_match_inst Icond") end
+
+ | Ijumptable r ln => match tinst with
+ | Ijumptable r' ln' =>
+ do u <- verify_is_copy_list dupmap ln ln';
+ if (Pos.eq_dec r r') then OK tt
+ else Error (msg "Different r in Ijumptable")
+ | _ => Error (msg "verify_match_inst Ijumptable") end
+
+ | Ireturn or => match tinst with
+ | Ireturn or' =>
+ if (option_eq Pos.eq_dec or or') then OK tt
+ else Error (msg "Different or in Ireturn")
+ | _ => Error (msg "verify_match_inst Ireturn") end
+ end.
+
+Definition verify_mapping_mn dupmap f f' (m: positive*positive) :=
+ let (tn, n) := m in
+ match (fn_code f)!n with
+ | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code f)!n")
+ | Some inst => match (fn_code f')!tn with
+ | None => Error (msg "verify_mapping_mn: Could not get an instruction at (fn_code xf)!tn")
+ | Some tinst => verify_match_inst dupmap inst tinst
+ end
+ end.
+
+Fixpoint verify_mapping_mn_rec dupmap f f' lm :=
+ match lm with
+ | nil => OK tt
+ | m :: lm => do u <- verify_mapping_mn dupmap f f' m;
+ do u2 <- verify_mapping_mn_rec dupmap f f' lm;
+ OK tt
+ end.
+
+Definition verify_mapping_match_nodes dupmap (f f': function): res unit :=
+ verify_mapping_mn_rec dupmap f f' (PTree.elements dupmap).
+
+(** Verifies that the [dupmap] of the translated function [f'] is giving correct information in regards to [f] *)
+Definition verify_mapping dupmap (f f': function) : res unit :=
+ do u <- verify_mapping_entrypoint dupmap f f';
+ do v <- verify_mapping_match_nodes dupmap f f'; OK tt.
+
+(** * Entry points *)
+
+Definition transf_function (f: function) : res function :=
+ let (tcte, dupmap) := duplicate_aux f in
+ let (tc, te) := tcte in
+ let f' := mkfunction (fn_sig f) (fn_params f) (fn_stacksize f) tc te in
+ do u <- verify_mapping dupmap f f';
+ OK f'.
+
+Definition transf_fundef (f: fundef) : res fundef :=
+ transf_partial_fundef transf_function f.
+
+Definition transf_program (p: program) : res program :=
+ transform_partial_program transf_fundef p.
diff --git a/backend/Duplicateaux.ml b/backend/Duplicateaux.ml
new file mode 100644
index 00000000..89f187da
--- /dev/null
+++ b/backend/Duplicateaux.ml
@@ -0,0 +1,648 @@
+(* Oracle for Duplicate pass.
+ * - Add static prediction information to Icond nodes
+ * - Performs tail duplication on interesting traces to form superblocks
+ * - (TODO: perform partial loop unrolling inside innermost loops)
+ *)
+
+open RTL
+open Maps
+open Camlcoq
+
+let debug_flag = ref false
+
+let debug fmt =
+ if !debug_flag then Printf.eprintf fmt
+ else Printf.ifprintf stderr fmt
+
+let get_some = function
+| None -> failwith "Did not get some"
+| Some thing -> thing
+
+let rtl_successors = function
+| Itailcall _ | Ireturn _ -> []
+| Icall(_,_,_,_,n) | Ibuiltin(_,_,_,n) | Inop n | Iop (_,_,_,n)
+| Iload (_,_,_,_,_,n) | Istore (_,_,_,_,n) -> [n]
+| Icond (_,_,n1,n2,_) -> [n1; n2]
+| Ijumptable (_,ln) -> ln
+
+let bfs code entrypoint = begin
+ debug "bfs\n";
+ let visited = ref (PTree.map (fun n i -> false) code)
+ and bfs_list = ref []
+ and to_visit = Queue.create ()
+ and node = ref entrypoint
+ in begin
+ Queue.add entrypoint to_visit;
+ while not (Queue.is_empty to_visit) do
+ node := Queue.pop to_visit;
+ if not (get_some @@ PTree.get !node !visited) then begin
+ visited := PTree.set !node true !visited;
+ match PTree.get !node code with
+ | None -> failwith "No such node"
+ | Some i ->
+ bfs_list := !node :: !bfs_list;
+ let succ = rtl_successors i in
+ List.iter (fun n -> Queue.add n to_visit) succ
+ end
+ done;
+ List.rev !bfs_list
+ end
+end
+
+let optbool o = match o with Some _ -> true | None -> false
+
+let ptree_get_some n ptree = get_some @@ PTree.get n ptree
+
+let get_predecessors_rtl code = begin
+ debug "get_predecessors_rtl\n";
+ let preds = ref (PTree.map (fun n i -> []) code) in
+ let process_inst (node, i) =
+ let succ = rtl_successors i
+ in List.iter (fun s ->
+ let previous_preds = ptree_get_some s !preds in
+ if optbool @@ List.find_opt (fun e -> e == node) previous_preds then ()
+ else preds := PTree.set s (node::previous_preds) !preds) succ
+ in begin
+ List.iter process_inst (PTree.elements code);
+ !preds
+ end
+end
+
+module PInt = struct
+ type t = P.t
+ let compare x y = compare (P.to_int x) (P.to_int y)
+end
+
+module PSet = Set.Make(PInt)
+
+let print_intlist l =
+ let rec f = function
+ | [] -> ()
+ | n::ln -> (Printf.printf "%d " (P.to_int n); f ln)
+ in begin
+ if !debug_flag then begin
+ Printf.printf "[";
+ f l;
+ Printf.printf "]"
+ end
+ end
+
+let print_intset s =
+ let seq = PSet.to_seq s
+ in begin
+ if !debug_flag then begin
+ Printf.printf "{";
+ Seq.iter (fun n ->
+ Printf.printf "%d " (P.to_int n)
+ ) seq;
+ Printf.printf "}"
+ end
+ end
+
+type vstate = Unvisited | Processed | Visited
+
+(** Getting loop branches with a DFS visit :
+ * Each node is either Unvisited, Visited, or Processed
+ * pre-order: node becomes Processed
+ * post-order: node becomes Visited
+ *
+ * If we come accross an edge to a Processed node, it's a loop!
+ *)
+let get_loop_headers code entrypoint = begin
+ debug "get_loop_headers\n";
+ let visited = ref (PTree.map (fun n i -> Unvisited) code)
+ and is_loop_header = ref (PTree.map (fun n i -> false) code)
+ in let rec dfs_visit code = function
+ | [] -> ()
+ | node :: ln ->
+ match (get_some @@ PTree.get node !visited) with
+ | Visited -> ()
+ | Processed -> begin
+ debug "Node %d is a loop header\n" (P.to_int node);
+ is_loop_header := PTree.set node true !is_loop_header;
+ visited := PTree.set node Visited !visited
+ end
+ | Unvisited -> begin
+ visited := PTree.set node Processed !visited;
+ match PTree.get node code with
+ | None -> failwith "No such node"
+ | Some i -> let next_visits = rtl_successors i in dfs_visit code next_visits;
+ visited := PTree.set node Visited !visited;
+ dfs_visit code ln
+ end
+ in begin
+ dfs_visit code [entrypoint];
+ !is_loop_header
+ end
+end
+
+let ptree_printbool pt =
+ let elements = PTree.elements pt
+ in begin
+ if !debug_flag then begin
+ Printf.printf "[";
+ List.iter (fun (n, b) ->
+ if b then Printf.printf "%d, " (P.to_int n) else ()
+ ) elements;
+ Printf.printf "]"
+ end
+ end
+
+(* Looks ahead (until a branch) to see if a node further down verifies
+ * the given predicate *)
+let rec look_ahead code node is_loop_header predicate =
+ if (predicate node) then true
+ else match (rtl_successors @@ get_some @@ PTree.get node code) with
+ | [n] -> if (predicate n) then true
+ else (
+ if (get_some @@ PTree.get n is_loop_header) then false
+ else look_ahead code n is_loop_header predicate
+ )
+ | _ -> false
+
+let do_call_heuristic code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tCall heuristic..\n";
+ let predicate n = (function
+ | Icall _ -> true
+ | _ -> false) @@ get_some @@ PTree.get n code
+ in let ifso_call = look_ahead code ifso is_loop_header predicate
+ in let ifnot_call = look_ahead code ifnot is_loop_header predicate
+ in if ifso_call && ifnot_call then None
+ else if ifso_call then Some false
+ else if ifnot_call then Some true
+ else None
+ end
+
+let do_opcode_heuristic code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tOpcode heuristic..\n";
+ DuplicateOpcodeHeuristic.opcode_heuristic code cond ifso ifnot is_loop_header
+ end
+
+let do_return_heuristic code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tReturn heuristic..\n";
+ let predicate n = (function
+ | Ireturn _ -> true
+ | _ -> false) @@ get_some @@ PTree.get n code
+ in let ifso_return = look_ahead code ifso is_loop_header predicate
+ in let ifnot_return = look_ahead code ifnot is_loop_header predicate
+ in if ifso_return && ifnot_return then None
+ else if ifso_return then Some false
+ else if ifnot_return then Some true
+ else None
+ end
+
+let do_store_heuristic code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tStore heuristic..\n";
+ let predicate n = (function
+ | Istore _ -> true
+ | _ -> false) @@ get_some @@ PTree.get n code
+ in let ifso_store = look_ahead code ifso is_loop_header predicate
+ in let ifnot_store = look_ahead code ifnot is_loop_header predicate
+ in if ifso_store && ifnot_store then None
+ else if ifso_store then Some false
+ else if ifnot_store then Some true
+ else None
+ end
+
+let do_loop_heuristic code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tLoop heuristic..\n";
+ let predicate n = get_some @@ PTree.get n is_loop_header in
+ let ifso_loop = look_ahead code ifso is_loop_header predicate in
+ let ifnot_loop = look_ahead code ifnot is_loop_header predicate in
+ if ifso_loop && ifnot_loop then None (* TODO - take the innermost loop ? *)
+ else if ifso_loop then Some true
+ else if ifnot_loop then Some false
+ else None
+ end
+
+let do_loop2_heuristic loop_info n code cond ifso ifnot is_loop_header =
+ begin
+ debug "\tLoop2 heuristic..\n";
+ match get_some @@ PTree.get n loop_info with
+ | None -> None
+ | Some b -> Some b
+ end
+
+(* Returns a PTree of either None or Some b where b determines the node following the loop, for a cb instruction *)
+(* It uses the fact that loops in CompCert are done by a branch (backedge) instruction followed by a cb *)
+let get_loop_info is_loop_header bfs_order code =
+ let loop_info = ref (PTree.map (fun n i -> None) code) in
+ let mark_path s n =
+ let visited = ref (PTree.map (fun n i -> false) code) in
+ let rec explore src dest =
+ if (get_some @@ PTree.get src !visited) then false
+ else if src == dest then true
+ else begin
+ visited := PTree.set src true !visited;
+ match rtl_successors @@ get_some @@ PTree.get src code with
+ | [] -> false
+ | [s] -> explore s dest
+ | [s1; s2] -> (explore s1 dest) || (explore s2 dest)
+ | _ -> false
+ end
+ in let rec advance_to_cb src =
+ if (get_some @@ PTree.get src !visited) then None
+ else begin
+ visited := PTree.set src true !visited;
+ match get_some @@ PTree.get src code with
+ | Inop s | Iop (_, _, _, s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s)
+ | Ibuiltin (_,_,_,s) -> advance_to_cb s
+ | Icond _ -> Some src
+ | Ijumptable _ | Itailcall _ | Ireturn _ -> None
+ end
+ in begin
+ debug "Marking path from %d to %d\n" (P.to_int n) (P.to_int s);
+ match advance_to_cb s with
+ | None -> (debug "Nothing found\n")
+ | Some s -> ( debug "Advancing to %d\n" (P.to_int s);
+ match get_some @@ PTree.get s !loop_info with
+ | None | Some _ -> begin
+ match get_some @@ PTree.get s code with
+ | Icond (_, _, n1, n2, _) ->
+ let b1 = explore n1 n in
+ let b2 = explore n2 n in
+ if (b1 && b2) then (debug "both true\n")
+ else if b1 then (debug "true privileged\n"; loop_info := PTree.set s (Some true) !loop_info)
+ else if b2 then (debug "false privileged\n"; loop_info := PTree.set s (Some false) !loop_info)
+ else (debug "none true\n")
+ | _ -> ( debug "not an icond\n" )
+ end
+ (* | Some _ -> ( debug "already loop info there\n" ) FIXME - we don't know yet whether a branch to a loop head is a backedge or not *)
+ )
+ end
+ in begin
+ List.iter (fun n ->
+ match get_some @@ PTree.get n code with
+ | Inop s | Iop (_,_,_,s) | Iload (_,_,_,_,_,s) | Istore (_,_,_,_,s) | Icall (_,_,_,_,s)
+ | Ibuiltin (_, _, _, s) ->
+ if get_some @@ PTree.get s is_loop_header then mark_path s n
+ | Icond _ -> () (* loop backedges are never Icond in CompCert RTL.3 *)
+ | Ijumptable _ -> ()
+ | Itailcall _ | Ireturn _ -> ()
+ ) bfs_order;
+ !loop_info
+ end
+
+(* Remark - compared to the original paper, we don't use the store heuristic *)
+let get_directions code entrypoint = begin
+ debug "get_directions\n";
+ let bfs_order = bfs code entrypoint in
+ let is_loop_header = get_loop_headers code entrypoint in
+ let loop_info = get_loop_info is_loop_header bfs_order code in
+ let directions = ref (PTree.map (fun n i -> None) code) in (* None <=> no predicted direction *)
+ begin
+ (* ptree_printbool is_loop_header; *)
+ (* debug "\n"; *)
+ List.iter (fun n ->
+ match (get_some @@ PTree.get n code) with
+ | Icond (cond, lr, ifso, ifnot, _) ->
+ (* debug "Analyzing %d.." (P.to_int n); *)
+ let heuristics = [ do_opcode_heuristic;
+ do_return_heuristic; do_loop2_heuristic loop_info n; do_loop_heuristic; do_call_heuristic;
+ (* do_store_heuristic *) ] in
+ let preferred = ref None in
+ begin
+ debug "Deciding condition for RTL node %d\n" (P.to_int n);
+ List.iter (fun do_heur ->
+ match !preferred with
+ | None -> preferred := do_heur code cond ifso ifnot is_loop_header
+ | Some _ -> ()
+ ) heuristics;
+ directions := PTree.set n !preferred !directions;
+ (match !preferred with | Some false -> debug "\tFALLTHROUGH\n"
+ | Some true -> debug "\tBRANCH\n"
+ | None -> debug "\tUNSURE\n");
+ debug "---------------------------------------\n"
+ end
+ | _ -> ()
+ ) bfs_order;
+ !directions
+ end
+end
+
+let update_direction direction = function
+| Icond (cond, lr, n, n', _) -> Icond (cond, lr, n, n', direction)
+| i -> i
+
+let rec update_direction_rec directions = function
+| [] -> PTree.empty
+| m::lm -> let (n, i) = m
+ in let direction = get_some @@ PTree.get n directions
+ in PTree.set n (update_direction direction i) (update_direction_rec directions lm)
+
+(* Uses branch prediction to write prediction annotations in Icond *)
+let update_directions code entrypoint = begin
+ debug "Update_directions\n";
+ let directions = get_directions code entrypoint
+ in begin
+ (* debug "Ifso directions: ";
+ ptree_printbool directions;
+ debug "\n"; *)
+ update_direction_rec directions (PTree.elements code)
+ end
+end
+
+(** Trace selection *)
+
+let rec exists_false_rec = function
+ | [] -> false
+ | m::lm -> let (_, b) = m in if b then exists_false_rec lm else true
+
+let exists_false boolmap = exists_false_rec (PTree.elements boolmap)
+
+(* DFS using prediction info to guide the exploration *)
+let dfs code entrypoint = begin
+ debug "dfs\n";
+ let visited = ref (PTree.map (fun n i -> false) code) in
+ let rec dfs_list code = function
+ | [] -> []
+ | node :: ln ->
+ if get_some @@ PTree.get node !visited then dfs_list code ln
+ else begin
+ visited := PTree.set node true !visited;
+ let next_nodes = (match get_some @@ PTree.get node code with
+ | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n)
+ | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> [n]
+ | Ijumptable (_, ln) -> ln
+ | Itailcall _ | Ireturn _ -> []
+ | Icond (_, _, n1, n2, info) -> (match info with
+ | Some false -> [n2; n1]
+ | _ -> [n1; n2]
+ )
+ ) in node :: dfs_list code (next_nodes @ ln)
+ end
+ in dfs_list code [entrypoint]
+end
+
+let rec select_unvisited_node is_visited = function
+| [] -> failwith "Empty list"
+| n :: ln -> if not (ptree_get_some n is_visited) then n else select_unvisited_node is_visited ln
+
+let best_successor_of node code is_visited =
+ match (PTree.get node code) with
+ | None -> failwith "No such node in the code"
+ | Some i ->
+ let next_node = match i with
+ | Inop n | Iop (_,_,_,n) | Iload (_,_,_,_,_,n) | Istore(_,_,_,_,n)
+ | Icall (_,_,_,_,n) | Ibuiltin (_,_,_,n) -> Some n
+ | Icond (_, _, n1, n2, ob) -> (match ob with None -> None | Some false -> Some n2 | Some true -> Some n1)
+ | _ -> None
+ in match next_node with
+ | None -> None
+ | Some n -> if not (ptree_get_some n is_visited) then Some n else None
+
+(* FIXME - could be improved by selecting in priority the predicted paths *)
+let best_predecessor_of node predecessors code order is_visited =
+ match (PTree.get node predecessors) with
+ | None -> failwith "No predecessor list found"
+ | Some lp ->
+ try Some (List.find (fun n ->
+ if (List.mem n lp) && (not (ptree_get_some n is_visited)) then
+ match ptree_get_some n code with
+ | Icond (_, _, n1, n2, ob) -> (match ob with
+ | None -> false
+ | Some false -> n == n2
+ | Some true -> n == n1
+ )
+ | _ -> true
+ else false
+ ) order)
+ with Not_found -> None
+
+let print_trace t = print_intlist t
+
+let print_traces traces =
+ let rec f = function
+ | [] -> ()
+ | t::lt -> Printf.printf "\n\t"; print_trace t; Printf.printf ",\n"; f lt
+ in begin
+ if !debug_flag then begin
+ Printf.printf "Traces: {";
+ f traces;
+ Printf.printf "}\n";
+ end
+ end
+
+(* Dumb (but linear) trace selection *)
+let select_traces_linear code entrypoint =
+ let is_visited = ref (PTree.map (fun n i -> false) code) in
+ let bfs_order = bfs code entrypoint in
+ let rec go_through node = begin
+ is_visited := PTree.set node true !is_visited;
+ let next_node = match (get_some @@ PTree.get node code) with
+ | Icall(_, _, _, _, n) | Ibuiltin (_, _, _, n) | Iop (_, _, _, n)
+ | Iload (_, _, _, _, _, n) | Istore (_, _, _, _, n) | Inop n -> Some n
+ | Ijumptable _ | Itailcall _ | Ireturn _ -> None
+ | Icond (_, _, n1, n2, info) -> (match info with
+ | Some false -> Some n2
+ | Some true -> Some n1
+ | None -> None
+ )
+ in match next_node with
+ | None -> [node]
+ | Some n ->
+ if not (get_some @@ PTree.get n !is_visited) then node :: go_through n
+ else [node]
+ end
+ in let traces = ref [] in begin
+ List.iter (fun n ->
+ if not (get_some @@ PTree.get n !is_visited) then
+ traces := (go_through n) :: !traces
+ ) bfs_order;
+ !traces
+ end
+
+
+(* Algorithm mostly inspired from Chang and Hwu 1988
+ * "Trace Selection for Compiling Large C Application Programs to Microcode" *)
+let select_traces_chang code entrypoint = begin
+ debug "select_traces\n";
+ let order = dfs code entrypoint in
+ let predecessors = get_predecessors_rtl code in
+ let traces = ref [] in
+ let is_visited = ref (PTree.map (fun n i -> false) code) in begin (* mark all nodes visited *)
+ debug "Length: %d\n" (List.length order);
+ while exists_false !is_visited do (* while (there are unvisited nodes) *)
+ let seed = select_unvisited_node !is_visited order in
+ let trace = ref [seed] in
+ let current = ref seed in begin
+ is_visited := PTree.set seed true !is_visited; (* mark seed visited *)
+ let quit_loop = ref false in begin
+ while not !quit_loop do
+ let s = best_successor_of !current code !is_visited in
+ match s with
+ | None -> quit_loop := true (* if (s==0) exit loop *)
+ | Some succ -> begin
+ trace := !trace @ [succ];
+ is_visited := PTree.set succ true !is_visited; (* mark s visited *)
+ current := succ
+ end
+ done;
+ current := seed;
+ quit_loop := false;
+ while not !quit_loop do
+ let s = best_predecessor_of !current predecessors code order !is_visited in
+ match s with
+ | None -> quit_loop := true (* if (s==0) exit loop *)
+ | Some pred -> begin
+ trace := pred :: !trace;
+ is_visited := PTree.set pred true !is_visited; (* mark s visited *)
+ current := pred
+ end
+ done;
+ traces := !trace :: !traces;
+ end
+ end
+ done;
+ (* debug "DFS: \t"; print_intlist order; debug "\n"; *)
+ debug "Traces: "; print_traces !traces;
+ !traces
+ end
+end
+
+let select_traces code entrypoint =
+ let length = List.length @@ PTree.elements code in
+ if (length < 5000) then select_traces_chang code entrypoint
+ else select_traces_linear code entrypoint
+
+let rec make_identity_ptree_rec = function
+| [] -> PTree.empty
+| m::lm -> let (n, _) = m in PTree.set n n (make_identity_ptree_rec lm)
+
+let make_identity_ptree code = make_identity_ptree_rec (PTree.elements code)
+
+(* Change the pointers of preds nodes to point to n' instead of n *)
+let rec change_pointers code n n' = function
+ | [] -> code
+ | pred :: preds ->
+ let new_pred_inst = match ptree_get_some pred code with
+ | Icall(a, b, c, d, n0) -> assert (n0 == n); Icall(a, b, c, d, n')
+ | Ibuiltin(a, b, c, n0) -> assert (n0 == n); Ibuiltin(a, b, c, n')
+ | Ijumptable(a, ln) -> assert (optbool @@ List.find_opt (fun e -> e == n) ln);
+ Ijumptable(a, List.map (fun e -> if (e == n) then n' else e) ln)
+ | Icond(a, b, n1, n2, i) -> assert (n1 == n || n2 == n);
+ let n1' = if (n1 == n) then n' else n1
+ in let n2' = if (n2 == n) then n' else n2
+ in Icond(a, b, n1', n2', i)
+ | Inop n0 -> assert (n0 == n); Inop n'
+ | Iop (a, b, c, n0) -> assert (n0 == n); Iop (a, b, c, n')
+ | Iload (a, b, c, d, e, n0) -> assert (n0 == n); Iload (a, b, c, d, e, n')
+ | Istore (a, b, c, d, n0) -> assert (n0 == n); Istore (a, b, c, d, n')
+ | Itailcall _ | Ireturn _ -> failwith "That instruction cannot be a predecessor"
+ in let new_code = PTree.set pred new_pred_inst code
+ in change_pointers new_code n n' preds
+
+(* parent: parent of n to keep as parent
+ * preds: all the other parents of n
+ * n': the integer which should contain the duplicate of n
+ * returns: new code, new ptree *)
+let duplicate code ptree parent n preds n' =
+ debug "Duplicating node %d into %d..\n" (P.to_int n) (P.to_int n');
+ match PTree.get n' code with
+ | Some _ -> failwith "The PTree already has a node n'"
+ | None ->
+ let c' = change_pointers code n n' preds
+ in let new_code = PTree.set n' (ptree_get_some n code) c'
+ and new_ptree = PTree.set n' n ptree
+ in (new_code, new_ptree)
+
+let rec maxint = function
+ | [] -> 0
+ | i :: l -> assert (i >= 0); let m = maxint l in if i > m then i else m
+
+let is_empty = function
+ | [] -> true
+ | _ -> false
+
+(* code: RTL code
+ * preds: mapping node -> predecessors
+ * ptree: the revmap
+ * trace: the trace to follow tail duplication on *)
+let tail_duplicate code preds ptree trace =
+ (* next_int: unused integer that can be used for the next duplication *)
+ let next_int = ref (maxint (List.map (fun e -> let (n, _) = e in P.to_int n) (PTree.elements code)) + 1)
+ (* last_node and last_duplicate store resp. the last processed node of the trace, and its duplication *)
+ in let last_node = ref None
+ in let last_duplicate = ref None
+ in let nb_duplicated = ref 0
+ (* recursive function on a trace *)
+ in let rec f code ptree is_first = function
+ | [] -> (code, ptree)
+ | n :: t ->
+ let (new_code, new_ptree) =
+ if is_first then (code, ptree) (* first node is never duplicated regardless of its inputs *)
+ else
+ let node_preds = ptree_get_some n preds
+ in let node_preds_nolast = List.filter (fun e -> e <> get_some !last_node) node_preds
+ in let final_node_preds = match !last_duplicate with
+ | None -> node_preds_nolast
+ | Some n' -> n' :: node_preds_nolast
+ in if not (is_empty final_node_preds) then
+ let n' = !next_int
+ in let (newc, newp) = duplicate code ptree !last_node n final_node_preds (P.of_int n')
+ in begin
+ next_int := !next_int + 1;
+ nb_duplicated := !nb_duplicated + 1;
+ last_duplicate := Some (P.of_int n');
+ (newc, newp)
+ end
+ else (code, ptree)
+ in begin
+ last_node := Some n;
+ f new_code new_ptree false t
+ end
+ in let new_code, new_ptree = f code ptree true trace
+ in (new_code, new_ptree, !nb_duplicated)
+
+let superblockify_traces code preds traces =
+ let max_nb_duplicated = !Clflags.option_fduplicate (* FIXME - should be architecture dependent *)
+ in let ptree = make_identity_ptree code
+ in let rec f code ptree = function
+ | [] -> (code, ptree, 0)
+ | trace :: traces ->
+ let new_code, new_ptree, nb_duplicated = tail_duplicate code preds ptree trace
+ in if (nb_duplicated < max_nb_duplicated)
+ then (debug "End duplication\n"; f new_code new_ptree traces)
+ else (debug "Too many duplicated nodes, aborting tail duplication\n"; (code, ptree, 0))
+ in let new_code, new_ptree, _ = f code ptree traces
+ in (new_code, new_ptree)
+
+let rec invert_iconds_trace code = function
+ | [] -> code
+ | n :: ln ->
+ let code' = match ptree_get_some n code with
+ | Icond (c, lr, ifso, ifnot, info) -> (match info with
+ | Some true -> begin
+ (* debug "Reversing ifso/ifnot for node %d\n" (P.to_int n); *)
+ PTree.set n (Icond (Op.negate_condition c, lr, ifnot, ifso, Some false)) code
+ end
+ | _ -> code)
+ | _ -> code
+ in invert_iconds_trace code' ln
+
+let rec invert_iconds code = function
+ | [] -> code
+ | t :: ts ->
+ let code' = if !Clflags.option_finvertcond then invert_iconds_trace code t
+ else code
+ in invert_iconds code' ts
+
+let duplicate_aux f =
+ let entrypoint = f.fn_entrypoint in
+ if !Clflags.option_fduplicate < 0 then
+ ((f.fn_code, entrypoint), make_identity_ptree f.fn_code)
+ else
+ let code = update_directions (f.fn_code) entrypoint in
+ let traces = select_traces code entrypoint in
+ let icond_code = invert_iconds code traces in
+ let preds = get_predecessors_rtl icond_code in
+ if !Clflags.option_fduplicate >= 1 then
+ let (new_code, pTreeId) = ((* print_traces traces; *) superblockify_traces icond_code preds traces) in
+ ((new_code, f.fn_entrypoint), pTreeId)
+ else
+ ((icond_code, entrypoint), make_identity_ptree code)
diff --git a/backend/Duplicateproof.v b/backend/Duplicateproof.v
new file mode 100644
index 00000000..6b598dc7
--- /dev/null
+++ b/backend/Duplicateproof.v
@@ -0,0 +1,523 @@
+(** Correctness proof for code duplication *)
+Require Import AST Linking Errors Globalenvs Smallstep.
+Require Import Coqlib Maps Events Values.
+Require Import Op RTL Duplicate.
+
+Local Open Scope positive_scope.
+
+(** * Definition of [match_states] (independently of the translation) *)
+
+(* est-ce plus simple de prendre dupmap: node -> node, avec un noeud hors CFG à la place de None ? *)
+Inductive match_inst (dupmap: PTree.t node): instruction -> instruction -> Prop :=
+ | match_inst_nop: forall n n',
+ dupmap!n' = (Some n) -> match_inst dupmap (Inop n) (Inop n')
+ | match_inst_op: forall n n' op lr r,
+ dupmap!n' = (Some n) -> match_inst dupmap (Iop op lr r n) (Iop op lr r n')
+ | match_inst_load: forall n n' tm m a lr r,
+ dupmap!n' = (Some n) -> match_inst dupmap (Iload tm m a lr r n) (Iload tm m a lr r n')
+ | match_inst_store: forall n n' m a lr r,
+ dupmap!n' = (Some n) -> match_inst dupmap (Istore m a lr r n) (Istore m a lr r n')
+ | match_inst_call: forall n n' s ri lr r,
+ dupmap!n' = (Some n) -> match_inst dupmap (Icall s ri lr r n) (Icall s ri lr r n')
+ | match_inst_tailcall: forall s ri lr,
+ match_inst dupmap (Itailcall s ri lr) (Itailcall s ri lr)
+ | match_inst_builtin: forall n n' ef la br,
+ dupmap!n' = (Some n) -> match_inst dupmap (Ibuiltin ef la br n) (Ibuiltin ef la br n')
+ | match_inst_cond: forall ifso ifso' ifnot ifnot' c lr i i',
+ dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) ->
+ match_inst dupmap (Icond c lr ifso ifnot i) (Icond c lr ifso' ifnot' i')
+ | match_inst_revcond: forall ifso ifso' ifnot ifnot' c lr i i',
+ dupmap!ifso' = (Some ifso) -> dupmap!ifnot' = (Some ifnot) ->
+ match_inst dupmap (Icond c lr ifso ifnot i) (Icond (negate_condition c) lr ifnot' ifso' i')
+ | match_inst_jumptable: forall ln ln' r,
+ list_forall2 (fun n n' => (dupmap!n' = (Some n))) ln ln' ->
+ match_inst dupmap (Ijumptable r ln) (Ijumptable r ln')
+ | match_inst_return: forall or, match_inst dupmap (Ireturn or) (Ireturn or).
+
+Record match_function dupmap f f': Prop := {
+ dupmap_correct: forall n n', dupmap!n' = Some n ->
+ (forall i, (fn_code f)!n = Some i -> exists i', (fn_code f')!n' = Some i' /\ match_inst dupmap i i');
+ dupmap_entrypoint: dupmap!(fn_entrypoint f') = Some (fn_entrypoint f);
+ preserv_fnsig: fn_sig f = fn_sig f';
+ preserv_fnparams: fn_params f = fn_params f';
+ preserv_fnstacksize: fn_stacksize f = fn_stacksize f'
+}.
+
+Inductive match_fundef: RTL.fundef -> RTL.fundef -> Prop :=
+ | match_Internal dupmap f f': match_function dupmap f f' -> match_fundef (Internal f) (Internal f')
+ | match_External ef: match_fundef (External ef) (External ef).
+
+Inductive match_stackframes: stackframe -> stackframe -> Prop :=
+ | match_stackframe_intro
+ dupmap res f sp pc rs f' pc'
+ (TRANSF: match_function dupmap f f')
+ (DUPLIC: dupmap!pc' = Some pc):
+ match_stackframes (Stackframe res f sp pc rs) (Stackframe res f' sp pc' rs).
+
+Inductive match_states: state -> state -> Prop :=
+ | match_states_intro
+ dupmap st f sp pc rs m st' f' pc'
+ (STACKS: list_forall2 match_stackframes st st')
+ (TRANSF: match_function dupmap f f')
+ (DUPLIC: dupmap!pc' = Some pc):
+ match_states (State st f sp pc rs m) (State st' f' sp pc' rs m)
+ | match_states_call:
+ forall st st' f f' args m
+ (STACKS: list_forall2 match_stackframes st st')
+ (TRANSF: match_fundef f f'),
+ match_states (Callstate st f args m) (Callstate st' f' args m)
+ | match_states_return:
+ forall st st' v m
+ (STACKS: list_forall2 match_stackframes st st'),
+ match_states (Returnstate st v m) (Returnstate st' v m).
+
+(** * Auxiliary properties *)
+
+
+Theorem transf_function_preserves:
+ forall f f',
+ transf_function f = OK f' ->
+ fn_sig f = fn_sig f' /\ fn_params f = fn_params f' /\ fn_stacksize f = fn_stacksize f'.
+Proof.
+ intros. unfold transf_function in H. destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te). monadInv H.
+ repeat (split; try reflexivity).
+Qed.
+
+
+Lemma verify_mapping_mn_rec_step:
+ forall dupmap lb b f f',
+ In b lb ->
+ verify_mapping_mn_rec dupmap f f' lb = OK tt ->
+ verify_mapping_mn dupmap f f' b = OK tt.
+Proof.
+ induction lb; intros.
+ - monadInv H0. inversion H.
+ - inversion H.
+ + subst. monadInv H0. destruct x. assumption.
+ + monadInv H0. destruct x0. eapply IHlb; assumption.
+Qed.
+
+Lemma verify_is_copy_correct:
+ forall dupmap n n',
+ verify_is_copy dupmap n n' = OK tt ->
+ dupmap ! n' = Some n.
+Proof.
+ intros. unfold verify_is_copy in H. destruct (_ ! n') eqn:REVM; [|inversion H].
+ destruct (n ?= p) eqn:NP; try (inversion H; fail).
+ eapply Pos.compare_eq in NP. subst.
+ reflexivity.
+Qed.
+
+Lemma verify_is_copy_list_correct:
+ forall dupmap ln ln',
+ verify_is_copy_list dupmap ln ln' = OK tt ->
+ list_forall2 (fun n n' => dupmap ! n' = Some n) ln ln'.
+Proof.
+ induction ln.
+ - intros. destruct ln'; monadInv H. constructor.
+ - intros. destruct ln'; monadInv H. destruct x. apply verify_is_copy_correct in EQ.
+ eapply IHln in EQ0. constructor; assumption.
+Qed.
+
+Lemma verify_match_inst_correct:
+ forall dupmap i i',
+ verify_match_inst dupmap i i' = OK tt ->
+ match_inst dupmap i i'.
+Proof.
+ intros. unfold verify_match_inst in H.
+ destruct i; try (inversion H; fail).
+(* Inop *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ constructor; eauto.
+(* Iop *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ destruct (eq_operation _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate.
+ destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst.
+ constructor. assumption.
+(* Iload *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ destruct (trapping_mode_eq _ _); try discriminate.
+ destruct (chunk_eq _ _); try discriminate.
+ destruct (eq_addressing _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate.
+ destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst.
+ constructor. assumption.
+(* Istore *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ destruct (chunk_eq _ _); try discriminate.
+ destruct (eq_addressing _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate.
+ destruct (Pos.eq_dec _ _); try discriminate. clear EQ0. subst.
+ constructor. assumption.
+(* Icall *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ destruct (signature_eq _ _); try discriminate.
+ destruct (product_eq _ _ _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate.
+ destruct (Pos.eq_dec _ _); try discriminate. subst.
+ constructor. assumption.
+(* Itailcall *)
+ - destruct i'; try (inversion H; fail).
+ destruct (signature_eq _ _); try discriminate.
+ destruct (product_eq _ _ _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate. subst. clear H.
+ constructor.
+(* Ibuiltin *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_correct in EQ.
+ destruct (external_function_eq _ _); try discriminate.
+ destruct (list_eq_dec _ _ _); try discriminate.
+ destruct (builtin_res_eq_pos _ _); try discriminate. subst.
+ constructor. assumption.
+(* Icond *)
+ - destruct i'; try (inversion H; fail).
+ destruct (list_eq_dec _ _ _); try discriminate. subst.
+ destruct (eq_condition _ _); try discriminate.
+ + monadInv H. destruct x. eapply verify_is_copy_correct in EQ.
+ destruct x0. eapply verify_is_copy_correct in EQ1.
+ constructor; assumption.
+ + destruct (eq_condition _ _); try discriminate.
+ monadInv H. destruct x. eapply verify_is_copy_correct in EQ.
+ destruct x0. eapply verify_is_copy_correct in EQ1.
+ constructor; assumption.
+(* Ijumptable *)
+ - destruct i'; try (inversion H; fail). monadInv H.
+ destruct x. eapply verify_is_copy_list_correct in EQ.
+ destruct (Pos.eq_dec _ _); try discriminate. subst.
+ constructor. assumption.
+(* Ireturn *)
+ - destruct i'; try (inversion H; fail).
+ destruct (option_eq _ _ _); try discriminate. subst. clear H.
+ constructor.
+Qed.
+
+
+Lemma verify_mapping_mn_correct mp n n' i f f' tc:
+ mp ! n' = Some n ->
+ (fn_code f) ! n = Some i ->
+ (fn_code f') = tc ->
+ verify_mapping_mn mp f f' (n', n) = OK tt ->
+ exists i',
+ tc ! n' = Some i'
+ /\ match_inst mp i i'.
+Proof.
+ unfold verify_mapping_mn; intros H H0 H1 H2. rewrite H0 in H2. clear H0. rewrite H1 in H2. clear H1.
+ destruct (tc ! n') eqn:TCN; [| inversion H2].
+ exists i0. split; auto.
+ eapply verify_match_inst_correct. assumption.
+Qed.
+
+
+Lemma verify_mapping_mn_rec_correct:
+ forall mp n n' i f f' tc,
+ mp ! n' = Some n ->
+ (fn_code f) ! n = Some i ->
+ (fn_code f') = tc ->
+ verify_mapping_mn_rec mp f f' (PTree.elements mp) = OK tt ->
+ exists i',
+ tc ! n' = Some i'
+ /\ match_inst mp i i'.
+Proof.
+ intros. exploit PTree.elements_correct. eapply H. intros IN.
+ eapply verify_mapping_mn_rec_step in H2; eauto.
+ eapply verify_mapping_mn_correct; eauto.
+Qed.
+
+Theorem transf_function_correct f f':
+ transf_function f = OK f' -> exists dupmap, match_function dupmap f f'.
+Proof.
+ unfold transf_function.
+ intros TRANSF.
+ destruct (duplicate_aux _) as (tcte & mp). destruct tcte as (tc & te).
+ monadInv TRANSF.
+ unfold verify_mapping in EQ. monadInv EQ.
+ exists mp; constructor 1; simpl; auto.
+ + (* correct *)
+ intros until n'. intros REVM i FNC.
+ unfold verify_mapping_match_nodes in EQ. simpl in EQ. destruct x1.
+ eapply verify_mapping_mn_rec_correct; eauto.
+ simpl; eauto.
+ + (* entrypoint *)
+ intros. unfold verify_mapping_entrypoint in EQ0. simpl in EQ0.
+ eapply verify_is_copy_correct; eauto.
+ destruct x0; auto.
+Qed.
+
+Lemma transf_fundef_correct f f':
+ transf_fundef f = OK f' -> match_fundef f f'.
+Proof.
+ intros TRANSF; destruct f; simpl; monadInv TRANSF.
+ + exploit transf_function_correct; eauto.
+ intros (dupmap & MATCH_F).
+ eapply match_Internal; eauto.
+ + eapply match_External.
+Qed.
+
+(** * Preservation proof *)
+
+Definition match_prog (p tp: program) :=
+ match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+
+Lemma transf_program_match:
+ forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog.
+Proof.
+ intros. eapply match_transform_partial_program_contextual; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: program.
+Variable tprog: program.
+
+Hypothesis TRANSL: match_prog prog tprog.
+
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved s: Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof.
+ rewrite <- (Genv.find_symbol_match TRANSL). reflexivity.
+Qed.
+
+(* UNUSED LEMMA ?
+Lemma senv_transitivity x y z: Senv.equiv x y -> Senv.equiv y z -> Senv.equiv x z.
+Proof.
+ unfold Senv.equiv. intuition congruence.
+Qed.
+*)
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof.
+ eapply (Genv.senv_match TRANSL).
+Qed.
+
+Lemma functions_translated:
+ forall (v: val) (f: fundef),
+ Genv.find_funct ge v = Some f ->
+ exists tf cunit, transf_fundef f = OK tf /\ Genv.find_funct tge v = Some tf /\ linkorder cunit prog.
+Proof.
+ intros. exploit (Genv.find_funct_match TRANSL); eauto.
+ intros (cu & tf & A & B & C).
+ repeat eexists; intuition eauto.
+ + unfold incl; auto.
+ + eapply linkorder_refl.
+Qed.
+
+Lemma function_ptr_translated:
+ forall v f,
+ Genv.find_funct_ptr ge v = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
+Proof.
+ intros.
+ exploit (Genv.find_funct_ptr_transf_partial TRANSL); eauto.
+Qed.
+
+Lemma function_sig_translated:
+ forall f tf, transf_fundef f = OK tf -> funsig tf = funsig f.
+Proof.
+ intros. destruct f.
+ - simpl in H. monadInv H. simpl. symmetry. apply transf_function_preserves. assumption.
+ - simpl in H. monadInv H. reflexivity.
+Qed.
+
+Lemma list_nth_z_dupmap:
+ forall dupmap ln ln' (pc pc': node) val,
+ list_nth_z ln val = Some pc ->
+ list_forall2 (fun n n' => dupmap!n' = Some n) ln ln' ->
+ exists pc',
+ list_nth_z ln' val = Some pc'
+ /\ dupmap!pc' = Some pc.
+Proof.
+ induction ln; intros until val; intros LNZ LFA.
+ - inv LNZ.
+ - inv LNZ. destruct (zeq val 0) eqn:ZEQ.
+ + inv H0. destruct ln'; inv LFA.
+ simpl. exists p. split; auto.
+ + inv LFA. simpl. rewrite ZEQ. exploit IHln. 2: eapply H0. all: eauto.
+ intros (pc'1 & LNZ & REV). exists pc'1. split; auto. congruence.
+Qed.
+
+Theorem transf_initial_states:
+ forall s1, initial_state prog s1 ->
+ exists s2, initial_state tprog s2 /\ match_states s1 s2.
+Proof.
+ intros. inv H.
+ exploit function_ptr_translated; eauto. intros (tf & FIND & TRANSF).
+ eexists. split.
+ - econstructor; eauto.
+ + eapply (Genv.init_mem_transf_partial TRANSL); eauto.
+ + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto.
+ symmetry. eapply match_program_main. eauto.
+ + destruct f.
+ * monadInv TRANSF. rewrite <- H3. symmetry; eapply transf_function_preserves. assumption.
+ * monadInv TRANSF. assumption.
+ - constructor; eauto.
+ + constructor.
+ + apply transf_fundef_correct; auto.
+Qed.
+
+Theorem transf_final_states:
+ forall s1 s2 r,
+ match_states s1 s2 -> final_state s1 r -> final_state s2 r.
+Proof.
+ intros. inv H0. inv H. inv STACKS. constructor.
+Qed.
+
+Theorem step_simulation:
+ forall s1 t s1', step ge s1 t s1' ->
+ forall s2 (MS: match_states s1 s2),
+ exists s2',
+ step tge s2 t s2'
+ /\ match_states s1' s2'.
+Proof.
+ Local Hint Resolve transf_fundef_correct: core.
+ induction 1; intros; inv MS.
+(* Inop *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3).
+ inv H3.
+ eexists. split.
+ + eapply exec_Inop; eauto.
+ + econstructor; eauto.
+(* Iop *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Iop; eauto. erewrite eval_operation_preserved; eauto.
+ + econstructor; eauto.
+(* Iload *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Iload; eauto; (* is the follow still needed?*) erewrite eval_addressing_preserved; eauto.
+ + econstructor; eauto.
+(* Iload notrap1 *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Iload_notrap1; eauto; erewrite eval_addressing_preserved; eauto.
+ + econstructor; eauto.
+(* Iload notrap2 *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Iload_notrap2; eauto; erewrite eval_addressing_preserved; eauto.
+ + econstructor; eauto.
+
+(* Istore *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Istore; eauto; erewrite eval_addressing_preserved; eauto.
+ + econstructor; eauto.
+(* Icall *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ destruct ros.
+ * simpl in H0. apply functions_translated in H0.
+ destruct H0 as (tf & cunit & TFUN & GFIND & LO).
+ eexists. split.
+ + eapply exec_Icall. eassumption. simpl. eassumption.
+ apply function_sig_translated. assumption.
+ + repeat (econstructor; eauto).
+ * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate.
+ apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF).
+ eexists. split.
+ + eapply exec_Icall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS.
+ eassumption. apply function_sig_translated. assumption.
+ + repeat (econstructor; eauto).
+(* Itailcall *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H10 & H11). inv H11.
+ pose symbols_preserved as SYMPRES.
+ destruct ros.
+ * simpl in H0. apply functions_translated in H0.
+ destruct H0 as (tf & cunit & TFUN & GFIND & LO).
+ eexists. split.
+ + eapply exec_Itailcall. eassumption. simpl. eassumption.
+ apply function_sig_translated. assumption.
+ erewrite <- preserv_fnstacksize; eauto.
+ + repeat (constructor; auto).
+ * simpl in H0. destruct (Genv.find_symbol _ _) eqn:GFS; try discriminate.
+ apply function_ptr_translated in H0. destruct H0 as (tf & GFF & TF).
+ eexists. split.
+ + eapply exec_Itailcall. eassumption. simpl. rewrite symbols_preserved. rewrite GFS.
+ eassumption. apply function_sig_translated. assumption.
+ erewrite <- preserv_fnstacksize; eauto.
+ + repeat (constructor; auto).
+(* Ibuiltin *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved; eauto.
+ eapply external_call_symbols_preserved; eauto. eapply senv_preserved.
+ + econstructor; eauto.
+(* Icond *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ * (* match_inst_cond *)
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Icond; eauto.
+ + econstructor; eauto. destruct b; auto.
+ * (* match_inst_revcond *)
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Icond; eauto. rewrite eval_negate_condition. rewrite H0. simpl. eauto.
+ + econstructor; eauto. destruct b; auto.
+(* Ijumptable *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ exploit list_nth_z_dupmap; eauto. intros (pc'1 & LNZ & REVM).
+ eexists. split.
+ + eapply exec_Ijumptable; eauto.
+ + econstructor; eauto.
+(* Ireturn *)
+ - eapply dupmap_correct in DUPLIC; eauto.
+ destruct DUPLIC as (i' & H2 & H3). inv H3.
+ pose symbols_preserved as SYMPRES.
+ eexists. split.
+ + eapply exec_Ireturn; eauto. erewrite <- preserv_fnstacksize; eauto.
+ + econstructor; eauto.
+(* exec_function_internal *)
+ - inversion TRANSF as [dupmap f0 f0' MATCHF|]; subst. eexists. split.
+ + eapply exec_function_internal. erewrite <- preserv_fnstacksize; eauto.
+ + erewrite preserv_fnparams; eauto.
+ econstructor; eauto. apply dupmap_entrypoint. assumption.
+(* exec_function_external *)
+ - inversion TRANSF as [|]; subst. eexists. split.
+ + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ + constructor. assumption.
+(* exec_return *)
+ - inv STACKS. destruct b1 as [res' f' sp' pc' rs']. eexists. split.
+ + constructor.
+ + inv H1. econstructor; eauto.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (semantics prog) (semantics tprog).
+Proof.
+ eapply forward_simulation_step with match_states.
+ - eapply senv_preserved.
+ - eapply transf_initial_states.
+ - eapply transf_final_states.
+ - eapply step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/backend/ForwardMoves.v b/backend/ForwardMoves.v
new file mode 100644
index 00000000..7cfd411f
--- /dev/null
+++ b/backend/ForwardMoves.v
@@ -0,0 +1,333 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+(* Static analysis *)
+
+Module RELATION.
+
+Definition t := (PTree.t reg).
+Definition eq (r1 r2 : t) :=
+ forall x, (PTree.get x r1) = (PTree.get x r2).
+
+Definition top : t := PTree.empty reg.
+
+Lemma eq_refl: forall x, eq x x.
+Proof.
+ unfold eq.
+ intros; reflexivity.
+Qed.
+
+Lemma eq_sym: forall x y, eq x y -> eq y x.
+Proof.
+ unfold eq.
+ intros; eauto.
+Qed.
+
+Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+Proof.
+ unfold eq.
+ intros; congruence.
+Qed.
+
+Definition reg_beq (x y : reg) :=
+ if Pos.eq_dec x y then true else false.
+
+Definition beq (r1 r2 : t) := PTree.beq reg_beq r1 r2.
+
+Lemma beq_correct: forall r1 r2, beq r1 r2 = true -> eq r1 r2.
+Proof.
+ unfold beq, eq. intros r1 r2 EQ x.
+ pose proof (PTree.beq_correct reg_beq r1 r2) as CORRECT.
+ destruct CORRECT as [CORRECTF CORRECTB].
+ pose proof (CORRECTF EQ x) as EQx.
+ clear CORRECTF CORRECTB EQ.
+ unfold reg_beq in *.
+ destruct (r1 ! x) as [R1x | ] in *;
+ destruct (r2 ! x) as [R2x | ] in *;
+ trivial; try contradiction.
+ destruct (Pos.eq_dec R1x R2x) in *; congruence.
+Qed.
+
+Definition ge (r1 r2 : t) :=
+ forall x,
+ match PTree.get x r1 with
+ | None => True
+ | Some v => (PTree.get x r2) = Some v
+ end.
+
+Lemma ge_refl: forall r1 r2, eq r1 r2 -> ge r1 r2.
+Proof.
+ unfold eq, ge.
+ intros r1 r2 EQ x.
+ pose proof (EQ x) as EQx.
+ clear EQ.
+ destruct (r1 ! x).
+ - congruence.
+ - trivial.
+Qed.
+
+Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+Proof.
+ unfold ge.
+ intros r1 r2 r3 GE12 GE23 x.
+ pose proof (GE12 x) as GE12x; clear GE12.
+ pose proof (GE23 x) as GE23x; clear GE23.
+ destruct (r1 ! x); trivial.
+ destruct (r2 ! x); congruence.
+Qed.
+
+Definition lub (r1 r2 : t) :=
+ PTree.combine
+ (fun ov1 ov2 =>
+ match ov1, ov2 with
+ | (Some v1), (Some v2) =>
+ if Pos.eq_dec v1 v2
+ then ov1
+ else None
+ | None, _
+ | _, None => None
+ end)
+ r1 r2.
+
+Lemma ge_lub_left: forall x y, ge (lub x y) x.
+Proof.
+ unfold ge, lub.
+ intros r1 r2 x.
+ rewrite PTree.gcombine by reflexivity.
+ destruct (_ ! _); trivial.
+ destruct (_ ! _); trivial.
+ destruct (Pos.eq_dec _ _); trivial.
+Qed.
+
+Lemma ge_lub_right: forall x y, ge (lub x y) y.
+Proof.
+ unfold ge, lub.
+ intros r1 r2 x.
+ rewrite PTree.gcombine by reflexivity.
+ destruct (_ ! _); trivial.
+ destruct (_ ! _); trivial.
+ destruct (Pos.eq_dec _ _); trivial.
+ congruence.
+Qed.
+
+End RELATION.
+
+Module Type SEMILATTICE_WITHOUT_BOTTOM.
+
+ Parameter t: Type.
+ Parameter eq: t -> t -> Prop.
+ Axiom eq_refl: forall x, eq x x.
+ Axiom eq_sym: forall x y, eq x y -> eq y x.
+ Axiom eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Parameter beq: t -> t -> bool.
+ Axiom beq_correct: forall x y, beq x y = true -> eq x y.
+ Parameter ge: t -> t -> Prop.
+ Axiom ge_refl: forall x y, eq x y -> ge x y.
+ Axiom ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Parameter lub: t -> t -> t.
+ Axiom ge_lub_left: forall x y, ge (lub x y) x.
+ Axiom ge_lub_right: forall x y, ge (lub x y) y.
+
+End SEMILATTICE_WITHOUT_BOTTOM.
+
+Module ADD_BOTTOM(L : SEMILATTICE_WITHOUT_BOTTOM).
+ Definition t := option L.t.
+ Definition eq (a b : t) :=
+ match a, b with
+ | None, None => True
+ | Some x, Some y => L.eq x y
+ | Some _, None | None, Some _ => False
+ end.
+
+ Lemma eq_refl: forall x, eq x x.
+ Proof.
+ unfold eq; destruct x; trivial.
+ apply L.eq_refl.
+ Qed.
+
+ Lemma eq_sym: forall x y, eq x y -> eq y x.
+ Proof.
+ unfold eq; destruct x; destruct y; trivial.
+ apply L.eq_sym.
+ Qed.
+
+ Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
+ Proof.
+ unfold eq; destruct x; destruct y; destruct z; trivial.
+ - apply L.eq_trans.
+ - contradiction.
+ Qed.
+
+ Definition beq (x y : t) :=
+ match x, y with
+ | None, None => true
+ | Some x, Some y => L.beq x y
+ | Some _, None | None, Some _ => false
+ end.
+
+ Lemma beq_correct: forall x y, beq x y = true -> eq x y.
+ Proof.
+ unfold beq, eq.
+ destruct x; destruct y; trivial; try congruence.
+ apply L.beq_correct.
+ Qed.
+
+ Definition ge (x y : t) :=
+ match x, y with
+ | None, Some _ => False
+ | _, None => True
+ | Some a, Some b => L.ge a b
+ end.
+
+ Lemma ge_refl: forall x y, eq x y -> ge x y.
+ Proof.
+ unfold eq, ge.
+ destruct x; destruct y; trivial.
+ apply L.ge_refl.
+ Qed.
+
+ Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
+ Proof.
+ unfold ge.
+ destruct x; destruct y; destruct z; trivial; try contradiction.
+ apply L.ge_trans.
+ Qed.
+
+ Definition bot: t := None.
+ Lemma ge_bot: forall x, ge x bot.
+ Proof.
+ unfold ge, bot.
+ destruct x; trivial.
+ Qed.
+
+ Definition lub (a b : t) :=
+ match a, b with
+ | None, _ => b
+ | _, None => a
+ | (Some x), (Some y) => Some (L.lub x y)
+ end.
+
+ Lemma ge_lub_left: forall x y, ge (lub x y) x.
+ Proof.
+ unfold ge, lub.
+ destruct x; destruct y; trivial.
+ - apply L.ge_lub_left.
+ - apply L.ge_refl.
+ apply L.eq_refl.
+ Qed.
+
+ Lemma ge_lub_right: forall x y, ge (lub x y) y.
+ Proof.
+ unfold ge, lub.
+ destruct x; destruct y; trivial.
+ - apply L.ge_lub_right.
+ - apply L.ge_refl.
+ apply L.eq_refl.
+ Qed.
+End ADD_BOTTOM.
+
+Module RB := ADD_BOTTOM(RELATION).
+Module DS := Dataflow_Solver(RB)(NodeSetForward).
+
+Definition kill (dst : reg) (rel : RELATION.t) :=
+ PTree.filter1 (fun x => if Pos.eq_dec dst x then false else true)
+ (PTree.remove dst rel).
+
+Definition move (src dst : reg) (rel : RELATION.t) :=
+ PTree.set dst (match PTree.get src rel with
+ | Some src' => src'
+ | None => src
+ end) (kill dst rel).
+
+Fixpoint kill_builtin_res (res : builtin_res reg) (rel : RELATION.t) :=
+ match res with
+ | BR z => kill z rel
+ | BR_none => rel
+ | BR_splitlong hi lo => kill_builtin_res hi (kill_builtin_res lo rel)
+ end.
+
+Definition apply_instr instr x :=
+ match instr with
+ | Inop _
+ | Icond _ _ _ _ _
+ | Ijumptable _ _
+ | Istore _ _ _ _ _ => Some x
+ | Iop Omove (src :: nil) dst _ => Some (move src dst x)
+ | Iop _ _ dst _
+ | Iload _ _ _ _ dst _
+ | Icall _ _ _ dst _ => Some (kill dst x)
+ | Ibuiltin _ _ res _ => Some (RELATION.top) (* TODO (kill_builtin_res res x) *)
+ | Itailcall _ _ _ | Ireturn _ => RB.bot
+ end.
+
+Definition apply_instr' code (pc : node) (ro : RB.t) : RB.t :=
+ match ro with
+ | None => None
+ | Some x =>
+ match code ! pc with
+ | None => RB.bot
+ | Some instr => apply_instr instr x
+ end
+ end.
+
+Definition forward_map (f : RTL.function) := DS.fixpoint
+ (RTL.fn_code f) RTL.successors_instr
+ (apply_instr' (RTL.fn_code f)) (RTL.fn_entrypoint f) (Some RELATION.top).
+
+Definition get_r (rel : RELATION.t) (x : reg) :=
+ match PTree.get x rel with
+ | None => x
+ | Some src => src
+ end.
+
+Definition get_rb (rb : RB.t) (x : reg) :=
+ match rb with
+ | None => x
+ | Some rel => get_r rel x
+ end.
+
+Definition subst_arg (fmap : option (PMap.t RB.t)) (pc : node) (x : reg) : reg :=
+ match fmap with
+ | None => x
+ | Some inv => get_rb (PMap.get pc inv) x
+ end.
+
+Definition subst_args fmap pc := List.map (subst_arg fmap pc).
+
+(* Transform *)
+Definition transf_instr (fmap : option (PMap.t RB.t))
+ (pc: node) (instr: instruction) :=
+ match instr with
+ | Iop op args dst s =>
+ Iop op (subst_args fmap pc args) dst s
+ | Iload trap chunk addr args dst s =>
+ Iload trap chunk addr (subst_args fmap pc args) dst s
+ | Istore chunk addr args src s =>
+ Istore chunk addr (subst_args fmap pc args) src s
+ | Icall sig ros args dst s =>
+ Icall sig ros (subst_args fmap pc args) dst s
+ | Itailcall sig ros args =>
+ Itailcall sig ros (subst_args fmap pc args)
+ | Icond cond args s1 s2 i =>
+ Icond cond (subst_args fmap pc args) s1 s2 i
+ | Ijumptable arg tbl =>
+ Ijumptable (subst_arg fmap pc arg) tbl
+ | Ireturn (Some arg) =>
+ Ireturn (Some (subst_arg fmap pc arg))
+ | _ => instr
+ end.
+
+Definition transf_function (f: function) : function :=
+ {| fn_sig := f.(fn_sig);
+ fn_params := f.(fn_params);
+ fn_stacksize := f.(fn_stacksize);
+ fn_code := PTree.map (transf_instr (forward_map f)) f.(fn_code);
+ fn_entrypoint := f.(fn_entrypoint) |}.
+
+
+Definition transf_fundef (fd: fundef) : fundef :=
+ AST.transf_fundef transf_function fd.
+
+Definition transf_program (p: program) : program :=
+ transform_program transf_fundef p.
diff --git a/backend/ForwardMovesproof.v b/backend/ForwardMovesproof.v
new file mode 100644
index 00000000..826d4250
--- /dev/null
+++ b/backend/ForwardMovesproof.v
@@ -0,0 +1,801 @@
+Require Import FunInd.
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import ForwardMoves.
+
+
+Definition match_prog (p tp: RTL.program) :=
+ match_program (fun ctx f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p, match_prog p (transf_program p).
+Proof.
+ intros. eapply match_transform_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variables prog tprog: program.
+Hypothesis TRANSL: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma functions_translated:
+ forall v f,
+ Genv.find_funct ge v = Some f ->
+ Genv.find_funct tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_transf TRANSL).
+
+Lemma function_ptr_translated:
+ forall v f,
+ Genv.find_funct_ptr ge v = Some f ->
+ Genv.find_funct_ptr tge v = Some (transf_fundef f).
+Proof (Genv.find_funct_ptr_transf TRANSL).
+
+Lemma symbols_preserved:
+ forall id,
+ Genv.find_symbol tge id = Genv.find_symbol ge id.
+Proof (Genv.find_symbol_transf TRANSL).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_transf TRANSL).
+
+Lemma sig_preserved:
+ forall f, funsig (transf_fundef f) = funsig f.
+Proof.
+ destruct f; trivial.
+Qed.
+
+Lemma find_function_translated:
+ forall ros rs fd,
+ find_function ge ros rs = Some fd ->
+ find_function tge ros rs = Some (transf_fundef fd).
+Proof.
+ unfold find_function; intros. destruct ros as [r|id].
+ eapply functions_translated; eauto.
+ rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try congruence.
+ eapply function_ptr_translated; eauto.
+Qed.
+
+Lemma transf_function_at:
+ forall f pc i,
+ f.(fn_code)!pc = Some i ->
+ (transf_function f).(fn_code)!pc =
+ Some(transf_instr (forward_map f) pc i).
+Proof.
+ intros until i. intro CODE.
+ unfold transf_function; simpl.
+ rewrite PTree.gmap.
+ unfold option_map.
+ rewrite CODE.
+ reflexivity.
+Qed.
+
+(*
+Definition fmap_sem (fmap : option (PMap.t RB.t)) (pc : node) (rs : regset) :=
+ forall x : reg,
+ (rs # (subst_arg fmap pc x)) = (rs # x).
+ *)
+
+Lemma apply_instr'_bot :
+ forall code,
+ forall pc,
+ RB.eq (apply_instr' code pc RB.bot) RB.bot.
+Proof.
+ reflexivity.
+Qed.
+
+Definition get_rb_sem (rb : RB.t) (rs : regset) :=
+ match rb with
+ | None => False
+ | Some rel =>
+ forall x : reg,
+ (rs # (get_r rel x)) = (rs # x)
+ end.
+
+Lemma get_rb_sem_ge:
+ forall rb1 rb2 : RB.t,
+ (RB.ge rb1 rb2) ->
+ forall rs : regset,
+ (get_rb_sem rb2 rs) -> (get_rb_sem rb1 rs).
+Proof.
+ destruct rb1 as [r1 | ];
+ destruct rb2 as [r2 | ];
+ unfold get_rb_sem;
+ simpl;
+ intros GE rs RB2RS;
+ try contradiction.
+ unfold RELATION.ge in GE.
+ unfold get_r in *.
+ intro x.
+ pose proof (GE x) as GEx.
+ pose proof (RB2RS x) as RB2RSx.
+ destruct (r1 ! x) as [r1x | ] in *;
+ destruct (r2 ! x) as [r2x | ] in *;
+ congruence.
+Qed.
+
+Definition fmap_sem (fmap : option (PMap.t RB.t))
+ (pc : node) (rs : regset) :=
+ match fmap with
+ | None => True
+ | Some m => get_rb_sem (PMap.get pc m) rs
+ end.
+
+Lemma subst_arg_ok:
+ forall f,
+ forall pc,
+ forall rs,
+ forall arg,
+ fmap_sem (forward_map f) pc rs ->
+ rs # (subst_arg (forward_map f) pc arg) = rs # arg.
+Proof.
+ intros until arg.
+ intro SEM.
+ unfold fmap_sem in SEM.
+ destruct (forward_map f) as [map |]in *; trivial.
+ simpl.
+ unfold get_rb_sem in *.
+ destruct (map # pc).
+ 2: contradiction.
+ apply SEM.
+Qed.
+
+Lemma subst_args_ok:
+ forall f,
+ forall pc,
+ forall rs,
+ fmap_sem (forward_map f) pc rs ->
+ forall args,
+ rs ## (subst_args (forward_map f) pc args) = rs ## args.
+Proof.
+ induction args; trivial.
+ simpl.
+ f_equal.
+ apply subst_arg_ok; assumption.
+ assumption.
+Qed.
+
+Lemma kill_ok:
+ forall dst,
+ forall mpc,
+ forall rs,
+ forall v,
+ get_rb_sem (Some mpc) rs ->
+ get_rb_sem (Some (kill dst mpc)) rs # dst <- v.
+Proof.
+ unfold get_rb_sem.
+ intros until v.
+ intros SEM x.
+ destruct (Pos.eq_dec x dst) as [EQ | NEQ].
+ {
+ subst dst.
+ rewrite Regmap.gss.
+ unfold kill, get_r.
+ rewrite PTree.gfilter1.
+ rewrite PTree.grs.
+ apply Regmap.gss.
+ }
+ rewrite (Regmap.gso v rs NEQ).
+ unfold kill, get_r in *.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by assumption.
+ pose proof (SEM x) as SEMx.
+ destruct (mpc ! x).
+ {
+ destruct (Pos.eq_dec dst r).
+ {
+ subst dst.
+ rewrite Regmap.gso by assumption.
+ reflexivity.
+ }
+ rewrite Regmap.gso by congruence.
+ assumption.
+ }
+ rewrite Regmap.gso by assumption.
+ reflexivity.
+Qed.
+
+Lemma kill_weaken:
+ forall dst,
+ forall mpc,
+ forall rs,
+ get_rb_sem (Some mpc) rs ->
+ get_rb_sem (Some (kill dst mpc)) rs.
+Proof.
+ unfold get_rb_sem.
+ intros until rs.
+ intros SEM x.
+ destruct (Pos.eq_dec x dst) as [EQ | NEQ].
+ {
+ subst dst.
+ unfold kill, get_r.
+ rewrite PTree.gfilter1.
+ rewrite PTree.grs.
+ reflexivity.
+ }
+ unfold kill, get_r in *.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by assumption.
+ pose proof (SEM x) as SEMx.
+ destruct (mpc ! x).
+ {
+ destruct (Pos.eq_dec dst r).
+ {
+ reflexivity.
+ }
+ assumption.
+ }
+ reflexivity.
+Qed.
+
+Lemma top_ok :
+ forall rs, get_rb_sem (Some RELATION.top) rs.
+Proof.
+ unfold get_rb_sem, RELATION.top.
+ intros.
+ unfold get_r.
+ rewrite PTree.gempty.
+ reflexivity.
+Qed.
+
+Lemma move_ok:
+ forall mpc : RELATION.t,
+ forall src res : reg,
+ forall rs : regset,
+ get_rb_sem (Some mpc) rs ->
+ get_rb_sem (Some (move src res mpc)) (rs # res <- (rs # src)).
+Proof.
+ unfold get_rb_sem, move.
+ intros until rs.
+ intros SEM x.
+ unfold get_r in *.
+ destruct (Pos.eq_dec res x).
+ {
+ subst res.
+ rewrite PTree.gss.
+ rewrite Regmap.gss.
+ pose proof (SEM src) as SEMsrc.
+ destruct (mpc ! src) as [mpcsrc | ] in *.
+ {
+ destruct (Pos.eq_dec x mpcsrc).
+ {
+ subst mpcsrc.
+ rewrite Regmap.gss.
+ reflexivity.
+ }
+ rewrite Regmap.gso by congruence.
+ assumption.
+ }
+ destruct (Pos.eq_dec x src).
+ {
+ subst src.
+ rewrite Regmap.gss.
+ reflexivity.
+ }
+ rewrite Regmap.gso by congruence.
+ reflexivity.
+ }
+ rewrite PTree.gso by congruence.
+ rewrite Regmap.gso with (i := x) by congruence.
+ unfold kill.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by congruence.
+ pose proof (SEM x) as SEMx.
+ destruct (mpc ! x) as [ r |].
+ {
+ destruct (Pos.eq_dec res r).
+ {
+ subst r.
+ rewrite Regmap.gso by congruence.
+ trivial.
+ }
+ rewrite Regmap.gso by congruence.
+ assumption.
+ }
+ rewrite Regmap.gso by congruence.
+ reflexivity.
+Qed.
+
+Ltac TR_AT :=
+ match goal with
+ | [ A: (fn_code _)!_ = Some _ |- _ ] =>
+ generalize (transf_function_at _ _ _ A); intros
+ end.
+
+Definition is_killed_in_map (map : PMap.t RB.t) pc res :=
+ match PMap.get pc map with
+ | None => True
+ | Some rel => exists rel', RELATION.ge rel (kill res rel')
+ end.
+
+Definition is_killed_in_fmap fmap pc res :=
+ match fmap with
+ | None => True
+ | Some map => is_killed_in_map map pc res
+ end.
+
+Definition killed_twice:
+ forall rel : RELATION.t,
+ forall res,
+ RELATION.eq (kill res rel) (kill res (kill res rel)).
+Proof.
+ unfold kill, RELATION.eq.
+ intros.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gfilter1.
+ destruct (Pos.eq_dec res x).
+ {
+ subst res.
+ rewrite PTree.grs.
+ rewrite PTree.grs.
+ reflexivity.
+ }
+ rewrite PTree.gro by congruence.
+ rewrite PTree.gro by congruence.
+ rewrite PTree.gfilter1.
+ rewrite PTree.gro by congruence.
+ destruct (rel ! x) as [relx | ]; trivial.
+ destruct (Pos.eq_dec res relx); trivial.
+ destruct (Pos.eq_dec res relx); congruence.
+Qed.
+
+Lemma get_rb_killed:
+ forall mpc,
+ forall rs,
+ forall rel,
+ forall res,
+ forall vres,
+ (get_rb_sem (Some mpc) rs) ->
+ (RELATION.ge mpc (kill res rel)) ->
+ (get_rb_sem (Some mpc) rs # res <- vres).
+Proof.
+ simpl.
+ intros until vres.
+ intros SEM GE x.
+ pose proof (GE x) as GEx.
+ pose proof (SEM x) as SEMx.
+ unfold get_r in *.
+ destruct (mpc ! x) as [mpcx | ] in *; trivial.
+ unfold kill in GEx.
+ rewrite PTree.gfilter1 in GEx.
+ destruct (Pos.eq_dec res x) as [ | res_NE_x].
+ {
+ subst res.
+ rewrite PTree.grs in GEx.
+ discriminate.
+ }
+ rewrite PTree.gro in GEx by congruence.
+ rewrite Regmap.gso with (i := x) by congruence.
+ destruct (rel ! x) as [relx | ]; try discriminate.
+ destruct (Pos.eq_dec res relx) as [ res_EQ_relx | res_NE_relx] in *; try discriminate.
+ rewrite Regmap.gso by congruence.
+ congruence.
+Qed.
+
+Inductive match_frames: RTL.stackframe -> RTL.stackframe -> Prop :=
+| match_frames_intro: forall res f sp pc rs,
+ (fmap_sem (forward_map f) pc rs) ->
+ (is_killed_in_fmap (forward_map f) pc res) ->
+ match_frames (Stackframe res f sp pc rs)
+ (Stackframe res (transf_function f) sp pc rs).
+
+Inductive match_states: RTL.state -> RTL.state -> Prop :=
+ | match_regular_states: forall stk f sp pc rs m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ (fmap_sem (forward_map f) pc rs) ->
+ match_states (State stk f sp pc rs m)
+ (State stk' (transf_function f) sp pc rs m)
+ | match_callstates: forall stk f args m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Callstate stk f args m)
+ (Callstate stk' (transf_fundef f) args m)
+ | match_returnstates: forall stk v m stk'
+ (STACKS: list_forall2 match_frames stk stk'),
+ match_states (Returnstate stk v m)
+ (Returnstate stk' v m).
+
+Lemma op_cases:
+ forall op,
+ forall args,
+ forall dst,
+ forall s,
+ forall x,
+ (exists src, op=Omove /\ args = src :: nil /\
+ (apply_instr (Iop op args dst s) x) = Some (move src dst x))
+ \/
+ (apply_instr (Iop op args dst s) x) = Some (kill dst x).
+Proof.
+ destruct op; try (right; simpl; reflexivity).
+ destruct args as [| arg0 args0t]; try (right; simpl; reflexivity).
+ destruct args0t as [| arg1 args1t]; try (right; simpl; reflexivity).
+ left.
+ eauto.
+Qed.
+
+Lemma step_simulation:
+ forall S1 t S2, RTL.step ge S1 t S2 ->
+ forall S1', match_states S1 S1' ->
+ exists S2', RTL.step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ induction 1; intros S1' MS; inv MS; try TR_AT.
+- (* nop *)
+ econstructor; split. eapply exec_Inop; eauto.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply get_rb_sem_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ unfold get_rb_sem in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+- (* op *)
+ econstructor; split.
+ eapply exec_Iop with (v := v); eauto.
+ rewrite <- H0.
+ rewrite subst_args_ok by assumption.
+ apply eval_operation_preserved. exact symbols_preserved.
+ constructor; auto.
+
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE.
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr' in GE.
+ rewrite MPC in GE.
+ rewrite H in GE.
+
+ destruct (op_cases op args res pc' mpc) as [[src [OP [ARGS MOVE]]] | KILL].
+ {
+ subst op.
+ subst args.
+ rewrite MOVE in GE.
+ simpl in H0.
+ simpl in GE.
+ apply get_rb_sem_ge with (rb2 := Some (move src res mpc)).
+ assumption.
+ replace v with (rs # src) by congruence.
+ apply move_ok.
+ assumption.
+ }
+ rewrite KILL in GE.
+ apply get_rb_sem_ge with (rb2 := Some (kill res mpc)).
+ assumption.
+ apply kill_ok.
+ assumption.
+
+(* load *)
+- econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0.
+ apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload; eauto.
+ rewrite subst_args_ok; assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)).
+ {
+ replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_ok.
+ assumption.
+
+- (* load notrap1 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = None).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap1; eauto.
+ rewrite subst_args_ok; assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)).
+ {
+ replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_ok.
+ assumption.
+
+- (* load notrap2 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap2; eauto.
+ rewrite subst_args_ok; assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply get_rb_sem_ge with (rb2 := Some (kill dst mpc)).
+ {
+ replace (Some (kill dst mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_ok.
+ assumption.
+
+- (* store *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Istore; eauto.
+ rewrite subst_args_ok; assumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply get_rb_sem_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ unfold get_rb_sem in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+
+(* call *)
+- econstructor; split.
+ eapply exec_Icall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ rewrite subst_args_ok by assumption.
+ constructor. constructor; auto. constructor.
+
+ {
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+ apply get_rb_sem_ge with (rb2 := Some (kill res mpc)).
+ {
+ replace (Some (kill res mpc)) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply kill_weaken.
+ assumption.
+ }
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ assert (RB.ge (map # pc') (apply_instr' (fn_code f) pc (map # pc))) as GE.
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr' in GE.
+ unfold fmap_sem in *.
+ destruct (map # pc) as [mpc |] in *; try contradiction.
+ rewrite H in GE.
+ simpl in GE.
+ unfold is_killed_in_fmap, is_killed_in_map.
+ unfold RB.ge in GE.
+ destruct (map # pc') as [mpc'|] eqn:MPC' in *; trivial.
+ eauto.
+
+(* tailcall *)
+- econstructor; split.
+ eapply exec_Itailcall with (fd := transf_fundef fd); eauto.
+ eapply find_function_translated; eauto.
+ apply sig_preserved.
+ rewrite subst_args_ok by assumption.
+ constructor. auto.
+
+(* builtin *)
+- econstructor; split.
+ eapply exec_Ibuiltin; eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ destruct (map # pc) as [mpc |] eqn:MPC in *; try contradiction.
+
+ apply get_rb_sem_ge with (rb2 := Some RELATION.top).
+ {
+ replace (Some RELATION.top) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl. tauto.
+ }
+ unfold apply_instr'.
+ rewrite H.
+ rewrite MPC.
+ reflexivity.
+ }
+ apply top_ok.
+
+(* cond *)
+- econstructor; split.
+ eapply exec_Icond; eauto.
+ rewrite subst_args_ok; eassumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply get_rb_sem_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl.
+ destruct b; tauto.
+ }
+ unfold apply_instr'.
+ unfold get_rb_sem in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+
+(* jumptbl *)
+- econstructor; split.
+ eapply exec_Ijumptable; eauto.
+ rewrite subst_arg_ok; eassumption.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply get_rb_sem_ge with (rb2 := map # pc); trivial.
+ replace (map # pc) with (apply_instr' (fn_code f) pc (map # pc)).
+ {
+ eapply DS.fixpoint_solution with (code := fn_code f) (successors := successors_instr); try eassumption.
+ 2: apply apply_instr'_bot.
+ simpl.
+ apply list_nth_z_in with (n := Int.unsigned n).
+ assumption.
+ }
+ unfold apply_instr'.
+ unfold get_rb_sem in *.
+ destruct (map # pc) in *; try contradiction.
+ rewrite H.
+ reflexivity.
+
+(* return *)
+- destruct or as [arg | ].
+ {
+ econstructor; split.
+ eapply exec_Ireturn; eauto.
+ unfold regmap_optget.
+ rewrite subst_arg_ok by eassumption.
+ constructor; auto.
+ }
+ econstructor; split.
+ eapply exec_Ireturn; eauto.
+ constructor; auto.
+
+
+(* internal function *)
+- simpl. econstructor; split.
+ eapply exec_function_internal; eauto.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ apply get_rb_sem_ge with (rb2 := Some RELATION.top).
+ {
+ eapply DS.fixpoint_entry with (code := fn_code f) (successors := successors_instr); try eassumption.
+ }
+ apply top_ok.
+
+(* external function *)
+- econstructor; split.
+ eapply exec_function_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ constructor; auto.
+
+(* return *)
+- inv STACKS. inv H1.
+ econstructor; split.
+ eapply exec_return; eauto.
+ constructor; auto.
+
+ simpl in *.
+ unfold fmap_sem in *.
+ destruct (forward_map _) as [map |] eqn:MAP in *; trivial.
+ unfold is_killed_in_fmap in H8.
+ unfold is_killed_in_map in H8.
+ destruct (map # pc) as [mpc |] in *; try contradiction.
+ destruct H8 as [rel' RGE].
+ eapply get_rb_killed; eauto.
+Qed.
+
+
+Lemma transf_initial_states:
+ forall S1, RTL.initial_state prog S1 ->
+ exists S2, RTL.initial_state tprog S2 /\ match_states S1 S2.
+Proof.
+ intros. inv H. econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf TRANSL); eauto.
+ rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto.
+ eapply function_ptr_translated; eauto.
+ rewrite <- H3; apply sig_preserved.
+ constructor. constructor.
+Qed.
+
+Lemma transf_final_states:
+ forall S1 S2 r, match_states S1 S2 -> RTL.final_state S1 r -> RTL.final_state S2 r.
+Proof.
+ intros. inv H0. inv H. inv STACKS. constructor.
+Qed.
+
+Theorem transf_program_correct:
+ forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
+Proof.
+ eapply forward_simulation_step.
+ apply senv_preserved.
+ eexact transf_initial_states.
+ eexact transf_final_states.
+ exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/backend/IRC.ml b/backend/IRC.ml
index 67da47da..785b0a2d 100644
--- a/backend/IRC.ml
+++ b/backend/IRC.ml
@@ -238,7 +238,6 @@ type graph = {
according to their types. A variable can be forced into class 2
by giving it a negative spill cost. *)
-
let class_of_reg r =
if Conventions1.is_float_reg r then 1 else 0
diff --git a/backend/Inlining.v b/backend/Inlining.v
index f7ee4166..8c7e1898 100644
--- a/backend/Inlining.v
+++ b/backend/Inlining.v
@@ -364,9 +364,9 @@ Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
| Iop op args res s =>
set_instr (spc ctx pc)
(Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s))
- | Iload chunk addr args dst s =>
+ | Iload trap chunk addr args dst s =>
set_instr (spc ctx pc)
- (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
+ (Iload trap chunk (saddr ctx addr) (sregs ctx args) (sreg ctx dst) (spc ctx s))
| Istore chunk addr args src s =>
set_instr (spc ctx pc)
(Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s))
@@ -397,9 +397,9 @@ Definition expand_instr (ctx: context) (pc: node) (i: instruction): mon unit :=
| Ibuiltin ef args res s =>
set_instr (spc ctx pc)
(Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s))
- | Icond cond args s1 s2 =>
+ | Icond cond args s1 s2 info =>
set_instr (spc ctx pc)
- (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2))
+ (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2) info)
| Ijumptable r tbl =>
set_instr (spc ctx pc)
(Ijumptable (sreg ctx r) (List.map (spc ctx) tbl))
diff --git a/backend/Inliningaux.ml b/backend/Inliningaux.ml
index 842e0c93..cf308962 100644
--- a/backend/Inliningaux.ml
+++ b/backend/Inliningaux.ml
@@ -16,8 +16,9 @@ open FSetAVL
open Maps
open Op
open Ordered
-open !RTL
-
+open! RTL
+open Camlcoq
+
module PSet = Make(OrderedPositive)
type inlining_info = {
@@ -57,7 +58,7 @@ let used_in_globvar io gv =
let fun_inline_analysis id io fn =
let inst io nid = function
| Iop (op, args, dest, succ) -> used_id io (globals_operation op)
- | Iload (chunk, addr, args, dest, succ)
+ | Iload (_, chunk, addr, args, dest, succ)
| Istore (chunk, addr, args, dest, succ) -> used_id io (globals_addressing addr)
| Ibuiltin (ef, args, dest, succ) -> used_id io (globals_of_builtin_args args)
| Icall (_, Coq_inr cid, _, _, _)
@@ -83,13 +84,15 @@ let static_called_once id io =
else
false
-(* To be considered: heuristics based on size of function? *)
+(* D. Monniaux: attempt at heuristic based on size *)
+let small_enough (f : coq_function) =
+ P.to_int (RTL.max_pc_function f) <= !Clflags.option_inline_auto_threshold
let should_inline (io: inlining_info) (id: ident) (f: coq_function) =
if !Clflags.option_finline then begin
match C2C.atom_inline id with
| C2C.Inline -> true
| C2C.Noinline -> false
- | C2C.No_specifier -> static_called_once id io
+ | C2C.No_specifier -> static_called_once id io || small_enough f
end else
false
diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v
index 2dcb8956..c4efaf18 100644
--- a/backend/Inliningproof.v
+++ b/backend/Inliningproof.v
@@ -744,7 +744,7 @@ Lemma match_stacks_free_right:
match_stacks F m m1' stk stk' sp.
Proof.
intros. eapply match_stacks_invariant; eauto.
- intros. eapply Mem.perm_free_1; eauto.
+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
intros. eapply Mem.perm_free_3; eauto.
Qed.
@@ -755,13 +755,13 @@ Proof.
assert (2 <= sz -> (2 | n)). intros.
destruct (zle sz 1). omegaContradiction.
destruct (zle sz 2). auto.
- destruct (zle sz 4). apply Zdivides_trans with 4; auto. exists 2; auto.
- apply Zdivides_trans with 8; auto. exists 4; auto.
+ destruct (zle sz 4). apply Z.divide_trans with 4; auto. exists 2; auto.
+ apply Z.divide_trans with 8; auto. exists 4; auto.
assert (4 <= sz -> (4 | n)). intros.
destruct (zle sz 1). omegaContradiction.
destruct (zle sz 2). omegaContradiction.
destruct (zle sz 4). auto.
- apply Zdivides_trans with 8; auto. exists 2; auto.
+ apply Z.divide_trans with 8; auto. exists 2; auto.
assert (8 <= sz -> (8 | n)). intros.
destruct (zle sz 1). omegaContradiction.
destruct (zle sz 2). omegaContradiction.
@@ -929,6 +929,15 @@ Proof.
intros. inv H. eauto.
Qed.
+Lemma eval_addressing_none:
+ forall sp' ctx addr rs,
+ eval_addressing ge (Vptr sp' (Ptrofs.repr (dstk ctx))) addr rs = None ->
+ eval_addressing ge (Vptr sp' Ptrofs.zero) (saddr ctx addr) rs = None.
+Proof.
+ intros until rs; intro Heval.
+ destruct addr; destruct rs as [| r0 rs1]; simpl in *; trivial; discriminate.
+Qed.
+
Theorem step_simulation:
forall S1 t S2,
step ge S1 t S2 ->
@@ -976,6 +985,51 @@ Proof.
apply match_stacks_inside_set_reg; auto.
apply agree_set_reg; auto.
+- (* load notrap1 *)
+ exploit tr_funbody_inv; eauto. intros TR; inv TR.
+ left; econstructor; split.
+ eapply plus_one. eapply exec_Iload_notrap1. eassumption.
+ rewrite eval_addressing_preserved with (ge1:=ge) (ge2:=tge).
+ exploit eval_addressing_inj_none.
+ 4: eassumption.
+ intros. eapply symbol_address_inject.
+ eapply match_stacks_inside_globals; eauto.
+ eauto.
+ instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto.
+ rewrite Ptrofs.add_zero_l.
+ apply eval_addressing_none.
+ exact symbols_preserved.
+ econstructor; eauto.
+ apply match_stacks_inside_set_reg; auto.
+ apply agree_set_reg; auto.
+
+- (* load notrap2 *)
+ exploit tr_funbody_inv; eauto. intros TR; inv TR.
+
+ exploit eval_addressing_inject.
+ eapply match_stacks_inside_globals; eauto.
+ eexact SP.
+ instantiate (2 := rs##args). instantiate (1 := rs'##(sregs ctx args)). eapply agree_val_regs; eauto.
+ eauto.
+ fold (saddr ctx addr). intros [a' [P Q]].
+
+ destruct (Mem.loadv chunk m' a') eqn:Hload'.
+ + left; econstructor; split.
+ eapply plus_one.
+ eapply exec_Iload; eauto.
+ try (rewrite <- P; apply eval_addressing_preserved; exact symbols_preserved).
+ econstructor; eauto.
+ apply match_stacks_inside_set_reg; auto.
+ apply agree_set_reg; auto.
+
+ + left; econstructor; split.
+ eapply plus_one.
+ eapply exec_Iload_notrap2; eauto.
+ try (rewrite <- P; apply eval_addressing_preserved; exact symbols_preserved).
+ econstructor; eauto.
+ apply match_stacks_inside_set_reg; auto.
+ apply agree_set_reg; auto.
+
- (* store *)
exploit tr_funbody_inv; eauto. intros TR; inv TR.
exploit eval_addressing_inject.
@@ -1043,7 +1097,7 @@ Proof.
eapply match_stacks_bound with (bound := sp').
eapply match_stacks_invariant; eauto.
intros. eapply Mem.perm_free_3; eauto.
- intros. eapply Mem.perm_free_1; eauto.
+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
intros. eapply Mem.perm_free_3; eauto.
erewrite Mem.nextblock_free; eauto. red in VB; xomega.
eapply agree_val_regs; eauto.
@@ -1135,7 +1189,7 @@ Proof.
eapply match_stacks_bound with (bound := sp').
eapply match_stacks_invariant; eauto.
intros. eapply Mem.perm_free_3; eauto.
- intros. eapply Mem.perm_free_1; eauto.
+ intros. eapply Mem.perm_free_1; eauto with ordered_type.
intros. eapply Mem.perm_free_3; eauto.
erewrite Mem.nextblock_free; eauto. red in VB; xomega.
destruct or; simpl. apply agree_val_reg; auto. auto.
@@ -1182,7 +1236,7 @@ Proof.
subst b1. rewrite D in H8; inv H8. eelim Plt_strict; eauto.
intros. eapply Mem.perm_alloc_1; eauto.
intros. exploit Mem.perm_alloc_inv. eexact A. eauto.
- rewrite dec_eq_false; auto.
+ rewrite dec_eq_false; auto with ordered_type.
auto. auto. auto. eauto. auto.
rewrite H5. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto.
eapply Mem.valid_new_block; eauto.
@@ -1249,7 +1303,7 @@ Proof.
eapply external_call_nextblock; eauto.
auto. auto.
-- (* return fron noninlined function *)
+- (* return from noninlined function *)
inv MS0.
+ (* normal case *)
left; econstructor; split.
diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v
index c345c942..eba026ec 100644
--- a/backend/Inliningspec.v
+++ b/backend/Inliningspec.v
@@ -270,10 +270,10 @@ Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
Ple res ctx.(mreg) ->
c!(spc ctx pc) = Some (Iop (sop ctx op) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
tr_instr ctx pc (Iop op args res s) c
- | tr_load: forall ctx pc c chunk addr args res s,
+ | tr_load: forall ctx pc c trap chunk addr args res s,
Ple res ctx.(mreg) ->
- c!(spc ctx pc) = Some (Iload chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
- tr_instr ctx pc (Iload chunk addr args res s) c
+ c!(spc ctx pc) = Some (Iload trap chunk (saddr ctx addr) (sregs ctx args) (sreg ctx res) (spc ctx s)) ->
+ tr_instr ctx pc (Iload trap chunk addr args res s) c
| tr_store: forall ctx pc c chunk addr args src s,
c!(spc ctx pc) = Some (Istore chunk (saddr ctx addr) (sregs ctx args) (sreg ctx src) (spc ctx s)) ->
tr_instr ctx pc (Istore chunk addr args src s) c
@@ -312,9 +312,9 @@ Inductive tr_instr: context -> node -> instruction -> code -> Prop :=
match res with BR r => Ple r ctx.(mreg) | _ => True end ->
c!(spc ctx pc) = Some (Ibuiltin ef (map (sbuiltinarg ctx) args) (sbuiltinres ctx res) (spc ctx s)) ->
tr_instr ctx pc (Ibuiltin ef args res s) c
- | tr_cond: forall ctx pc cond args s1 s2 c,
- c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2)) ->
- tr_instr ctx pc (Icond cond args s1 s2) c
+ | tr_cond: forall ctx pc cond args s1 s2 c i,
+ c!(spc ctx pc) = Some (Icond cond (sregs ctx args) (spc ctx s1) (spc ctx s2) i) ->
+ tr_instr ctx pc (Icond cond args s1 s2 i) c
| tr_jumptable: forall ctx pc r tbl c,
c!(spc ctx pc) = Some (Ijumptable (sreg ctx r) (List.map (spc ctx) tbl)) ->
tr_instr ctx pc (Ijumptable r tbl) c
diff --git a/backend/Json.ml b/backend/Json.ml
index b8f66c08..bd4d6ff9 100644
--- a/backend/Json.ml
+++ b/backend/Json.ml
@@ -10,7 +10,6 @@
(* *)
(* *********************************************************************)
-open Format
open Camlcoq
@@ -18,16 +17,21 @@ open Camlcoq
(* Print a string as json string *)
let pp_jstring oc s =
- fprintf oc "\"%s\"" s
+ output_string oc "\"";
+ output_string oc s;
+ output_string oc "\""
(* Print a bool as json bool *)
-let pp_jbool oc = fprintf oc "%B"
+let pp_jbool oc b = output_string oc (string_of_bool b)
(* Print an int as json int *)
-let pp_jint oc = fprintf oc "%d"
+let pp_jint oc i = output_string oc (string_of_int i)
(* Print an int32 as json int *)
-let pp_jint32 oc = fprintf oc "%ld"
+let pp_jint32 oc i = output_string oc (Int32.to_string i)
+
+(* Print an int64 as json int *)
+let pp_jint64 oc i = output_string oc (Int64.to_string i)
(* Print optional value *)
let pp_jopt pp_elem oc = function
@@ -36,15 +40,19 @@ let pp_jopt pp_elem oc = function
(* Print opening and closing curly braces for json dictionaries *)
let pp_jobject_start pp =
- fprintf pp "@[<v 1>{"
+ output_string pp "\n{"
let pp_jobject_end pp =
- fprintf pp "@;<0 -1>}@]"
+ output_string pp "}"
(* Print a member of a json dictionary *)
let pp_jmember ?(first=false) pp name pp_mem mem =
- let sep = if first then "" else "," in
- fprintf pp "%s@ \"%s\": %a" sep name pp_mem mem
+ if not first then output_string pp ",";
+ output_string pp " ";
+ pp_jstring pp name;
+ output_string pp " :";
+ pp_mem pp mem;
+ output_string pp "\n"
(* Print singleton object *)
let pp_jsingle_object pp name pp_mem mem =
@@ -54,29 +62,31 @@ let pp_jsingle_object pp name pp_mem mem =
(* Print a list as json array *)
let pp_jarray elem pp l =
- match l with
- | [] -> fprintf pp "[]";
+ let pp_sep () = output_string pp ", " in
+ output_string pp "[";
+ begin match l with
+ | [] -> ()
| hd::tail ->
- fprintf pp "@[<v 1>[";
- fprintf pp "%a" elem hd;
- List.iter (fun l -> fprintf pp ",@ %a" elem l) tail;
- fprintf pp "@;<0 -1>]@]"
+ elem pp hd;
+ List.iter (fun l -> pp_sep (); elem pp l) tail;
+ end;
+ output_string pp "]"
(* Helper functions for printing coq integer and floats *)
let pp_int pp i =
- fprintf pp "%ld" (camlint_of_coqint i)
+ pp_jint32 pp (camlint_of_coqint i)
let pp_int64 pp i =
- fprintf pp "%Ld" (camlint64_of_coqint i)
+ pp_jint64 pp (camlint64_of_coqint i)
let pp_float32 pp f =
- fprintf pp "%ld" (camlint_of_coqint (Floats.Float32.to_bits f))
+ pp_jint32 pp (camlint_of_coqint (Floats.Float32.to_bits f))
let pp_float64 pp f =
- fprintf pp "%Ld" (camlint64_of_coqint (Floats.Float.to_bits f))
+ pp_jint64 pp (camlint64_of_coqint (Floats.Float.to_bits f))
let pp_z pp z =
- fprintf pp "%s" (Z.to_string z)
+ output_string pp (Z.to_string z)
(* Helper functions for printing assembler constructs *)
let pp_atom pp a =
@@ -106,4 +116,4 @@ let reset_id () =
let pp_id_const pp () =
let i = next_id () in
- pp_jsingle_object pp "Integer" (fun pp i -> fprintf pp "%d" i) i
+ pp_jsingle_object pp "Integer" pp_jint i
diff --git a/backend/JsonAST.ml b/backend/JsonAST.ml
index 3469bdc6..8905e252 100644
--- a/backend/JsonAST.ml
+++ b/backend/JsonAST.ml
@@ -15,7 +15,6 @@ open Asm
open AST
open C2C
open Json
-open Format
open Sections
@@ -54,8 +53,8 @@ let pp_section pp sec =
| Section_ais_annotation -> () (* There should be no info in the debug sections *)
let pp_int_opt pp = function
- | None -> fprintf pp "0"
- | Some i -> fprintf pp "%d" i
+ | None -> output_string pp "0"
+ | Some i -> pp_jint pp i
let pp_fundef pp_inst pp (name,fn) =
let alignment = atom_alignof name
@@ -119,19 +118,18 @@ let pp_program pp pp_inst prog =
pp_jobject_end pp
let pp_mnemonics pp mnemonic_names =
- let mnemonic_names = List.sort (String.compare) mnemonic_names in
- let new_line pp () = pp_print_string pp "\n" in
- pp_print_list ~pp_sep:new_line pp_print_string pp mnemonic_names
+ let new_line pp () = Format.pp_print_string pp "\n" in
+ Format.pp_print_list ~pp_sep:new_line Format.pp_print_string pp mnemonic_names
-let jdump_magic_number = "CompCertJDUMP" ^ Version.version
+let jdump_magic_number = "CompCertJDUMPRelease: " ^ Version.version
let pp_ast pp pp_inst ast sourcename =
let get_args () =
let buf = Buffer.create 100 in
Buffer.add_string buf Sys.executable_name;
- for i = 1 to (Array.length !Commandline.argv - 1) do
+ for i = 1 to (Array.length Commandline.argv - 1) do
Buffer.add_string buf " ";
- Buffer.add_string buf (Responsefile.gnu_quote !Commandline.argv.(i));
+ Buffer.add_string buf (Responsefile.gnu_quote Commandline.argv.(i));
done;
Buffer.contents buf in
let dump_compile_info pp () =
@@ -153,4 +151,4 @@ let pp_ast pp pp_inst ast sourcename =
pp_jmember pp "Compilation Unit" pp_jstring sourcename;
pp_jmember pp "Asm Ast" (fun pp prog -> pp_program pp pp_inst prog) ast;
pp_jobject_end pp;
- Format.pp_print_flush pp ()
+ flush pp
diff --git a/backend/JsonAST.mli b/backend/JsonAST.mli
index 7afdce51..c32439e4 100644
--- a/backend/JsonAST.mli
+++ b/backend/JsonAST.mli
@@ -13,4 +13,4 @@
val pp_mnemonics : Format.formatter -> string list -> unit
-val pp_ast : Format.formatter -> (Format.formatter -> Asm.code -> unit) -> (Asm.coq_function AST.fundef, 'a) AST.program -> string -> unit
+val pp_ast : out_channel -> (out_channel -> Asm.code -> unit) -> (Asm.coq_function AST.fundef, 'a) AST.program -> string -> unit
diff --git a/backend/LTL.v b/backend/LTL.v
index 5e7eec8c..3edd60a2 100644
--- a/backend/LTL.v
+++ b/backend/LTL.v
@@ -29,7 +29,7 @@ Definition node := positive.
Inductive instruction: Type :=
| Lop (op: operation) (args: list mreg) (res: mreg)
- | Lload (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg)
+ | Lload (trap : trapping_mode) (chunk: memory_chunk) (addr: addressing) (args: list mreg) (dst: mreg)
| Lgetstack (sl: slot) (ofs: Z) (ty: typ) (dst: mreg)
| Lsetstack (src: mreg) (sl: slot) (ofs: Z) (ty: typ)
| Lstore (chunk: memory_chunk) (addr: addressing) (args: list mreg) (src: mreg)
@@ -37,7 +37,7 @@ Inductive instruction: Type :=
| Ltailcall (sg: signature) (ros: mreg + ident)
| Lbuiltin (ef: external_function) (args: list (builtin_arg loc)) (res: builtin_res mreg)
| Lbranch (s: node)
- | Lcond (cond: condition) (args: list mreg) (s1 s2: node)
+ | Lcond (cond: condition) (args: list mreg) (s1 s2: node) (info: option bool)
| Ljumptable (arg: mreg) (tbl: list node)
| Lreturn.
@@ -209,11 +209,24 @@ Inductive step: state -> trace -> state -> Prop :=
rs' = Locmap.set (R res) v (undef_regs (destroyed_by_op op) rs) ->
step (Block s f sp (Lop op args res :: bb) rs m)
E0 (Block s f sp bb rs' m)
- | exec_Lload: forall s f sp chunk addr args dst bb rs m a v rs',
+ | exec_Lload: forall s f sp trap chunk addr args dst bb rs m a v rs',
eval_addressing ge sp addr (reglist rs args) = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) ->
- step (Block s f sp (Lload chunk addr args dst :: bb) rs m)
+ step (Block s f sp (Lload trap chunk addr args dst :: bb) rs m)
+ E0 (Block s f sp bb rs' m)
+ | exec_Lload_notrap1: forall s f sp chunk addr args dst bb rs m rs',
+ eval_addressing ge sp addr (reglist rs args) = None ->
+ rs' = Locmap.set (R dst) (default_notrap_load_value chunk)
+ (undef_regs (destroyed_by_load chunk addr) rs) ->
+ step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m)
+ E0 (Block s f sp bb rs' m)
+ | exec_Lload_notrap2: forall s f sp chunk addr args dst bb rs m a rs',
+ eval_addressing ge sp addr (reglist rs args) = Some a ->
+ Mem.loadv chunk m a = None ->
+ rs' = Locmap.set (R dst) (default_notrap_load_value chunk)
+ (undef_regs (destroyed_by_load chunk addr) rs) ->
+ step (Block s f sp (Lload NOTRAP chunk addr args dst :: bb) rs m)
E0 (Block s f sp bb rs' m)
| exec_Lgetstack: forall s f sp sl ofs ty dst bb rs m rs',
rs' = Locmap.set (R dst) (rs (S sl ofs ty)) (undef_regs (destroyed_by_getstack sl) rs) ->
@@ -250,11 +263,11 @@ Inductive step: state -> trace -> state -> Prop :=
| exec_Lbranch: forall s f sp pc bb rs m,
step (Block s f sp (Lbranch pc :: bb) rs m)
E0 (State s f sp pc rs m)
- | exec_Lcond: forall s f sp cond args pc1 pc2 bb rs b pc rs' m,
+ | exec_Lcond: forall s f sp cond args pc1 pc2 bb rs b pc rs' m i,
eval_condition cond (reglist rs args) m = Some b ->
pc = (if b then pc1 else pc2) ->
rs' = undef_regs (destroyed_by_cond cond) rs ->
- step (Block s f sp (Lcond cond args pc1 pc2 :: bb) rs m)
+ step (Block s f sp (Lcond cond args pc1 pc2 i :: bb) rs m)
E0 (State s f sp pc rs' m)
| exec_Ljumptable: forall s f sp arg tbl bb rs m n pc rs',
rs (R arg) = Vint n ->
@@ -315,7 +328,7 @@ Fixpoint successors_block (b: bblock) : list node :=
| nil => nil (**r should never happen *)
| Ltailcall _ _ :: _ => nil
| Lbranch s :: _ => s :: nil
- | Lcond _ _ s1 s2 :: _ => s1 :: s2 :: nil
+ | Lcond _ _ s1 s2 _ :: _ => s1 :: s2 :: nil
| Ljumptable _ tbl :: _ => tbl
| Lreturn :: _ => nil
| instr :: b' => successors_block b'
diff --git a/backend/Linear.v b/backend/Linear.v
index 447c6ba6..1443f795 100644
--- a/backend/Linear.v
+++ b/backend/Linear.v
@@ -28,7 +28,7 @@ Inductive instruction: Type :=
| Lgetstack: slot -> Z -> typ -> mreg -> instruction
| Lsetstack: mreg -> slot -> Z -> typ -> instruction
| Lop: operation -> list mreg -> mreg -> instruction
- | Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction
+ | Lload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Lcall: signature -> mreg + ident -> instruction
| Ltailcall: signature -> mreg + ident -> instruction
@@ -160,11 +160,28 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp (Lop op args res :: b) rs m)
E0 (State s f sp b rs' m)
| exec_Lload:
- forall s f sp chunk addr args dst b rs m a v rs',
+ forall s f sp trap chunk addr args dst b rs m a v rs',
eval_addressing ge sp addr (reglist rs args) = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = Locmap.set (R dst) v (undef_regs (destroyed_by_load chunk addr) rs) ->
- step (State s f sp (Lload chunk addr args dst :: b) rs m)
+ step (State s f sp (Lload trap chunk addr args dst :: b) rs m)
+ E0 (State s f sp b rs' m)
+ | exec_Lload_notrap1:
+ forall s f sp chunk addr args dst b rs m rs',
+ eval_addressing ge sp addr (reglist rs args) = None ->
+ rs' = Locmap.set (R dst)
+ (default_notrap_load_value chunk)
+ (undef_regs (destroyed_by_load chunk addr) rs) ->
+ step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m)
+ E0 (State s f sp b rs' m)
+ | exec_Lload_notrap2:
+ forall s f sp chunk addr args dst b rs m a rs',
+ eval_addressing ge sp addr (reglist rs args) = Some a ->
+ Mem.loadv chunk m a = None ->
+ rs' = Locmap.set (R dst)
+ (default_notrap_load_value chunk)
+ (undef_regs (destroyed_by_load chunk addr) rs) ->
+ step (State s f sp (Lload NOTRAP chunk addr args dst :: b) rs m)
E0 (State s f sp b rs' m)
| exec_Lstore:
forall s f sp chunk addr args src b rs m m' a rs',
diff --git a/backend/Linearize.v b/backend/Linearize.v
index 2cfa4d3c..66b36428 100644
--- a/backend/Linearize.v
+++ b/backend/Linearize.v
@@ -163,8 +163,8 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code :=
| nil => k
| LTL.Lop op args res :: b' =>
Lop op args res :: linearize_block b' k
- | LTL.Lload chunk addr args dst :: b' =>
- Lload chunk addr args dst :: linearize_block b' k
+ | LTL.Lload trap chunk addr args dst :: b' =>
+ Lload trap chunk addr args dst :: linearize_block b' k
| LTL.Lgetstack sl ofs ty dst :: b' =>
Lgetstack sl ofs ty dst :: linearize_block b' k
| LTL.Lsetstack src sl ofs ty :: b' =>
@@ -179,7 +179,7 @@ Fixpoint linearize_block (b: LTL.bblock) (k: code) : code :=
Lbuiltin ef args res :: linearize_block b' k
| LTL.Lbranch s :: b' =>
add_branch s k
- | LTL.Lcond cond args s1 s2 :: b' =>
+ | LTL.Lcond cond args s1 s2 _ :: b' =>
if starts_with s1 k then
Lcond (negate_condition cond) args s2 :: add_branch s1 k
else
diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml
index 46d5c3f1..9d5a5ba6 100644
--- a/backend/Linearizeaux.ml
+++ b/backend/Linearizeaux.ml
@@ -1,4 +1,4 @@
-(* *********************************************************************)
+
(* *)
(* The Compcert verified compiler *)
(* *)
@@ -12,7 +12,12 @@
open LTL
open Maps
-open Camlcoq
+
+let debug_flag = ref false
+
+let debug fmt =
+ if !debug_flag then Printf.eprintf fmt
+ else Printf.ifprintf stderr fmt
(* Trivial enumeration, in decreasing order of PC *)
@@ -29,6 +34,8 @@ let enumerate_aux f reach =
(* More clever enumeration that flattens basic blocks *)
+open Camlcoq
+
module IntSet = Set.Make(struct type t = int let compare = compare end)
(* Determine join points: reachable nodes that have > 1 predecessor *)
@@ -80,7 +87,7 @@ let basic_blocks f joins =
| [] -> assert false
| Lbranch s :: _ -> next_in_block blk minpc s
| Ltailcall (sig0, ros) :: _ -> end_block blk minpc
- | Lcond (cond, args, ifso, ifnot) :: _ ->
+ | Lcond (cond, args, ifso, ifnot, _) :: _ ->
end_block blk minpc; start_block ifso; start_block ifnot
| Ljumptable(arg, tbl) :: _ ->
end_block blk minpc; List.iter start_block tbl
@@ -106,9 +113,413 @@ let flatten_blocks blks =
let cmp_minpc (mpc1, _) (mpc2, _) =
if mpc1 = mpc2 then 0 else if mpc1 > mpc2 then -1 else 1
in
- List.flatten (List.map Pervasives.snd (List.sort cmp_minpc blks))
+ List.flatten (List.map snd (List.sort cmp_minpc blks))
(* Build the enumeration *)
-let enumerate_aux f reach =
+let enumerate_aux_flat f reach =
flatten_blocks (basic_blocks f (join_points f))
+
+(**
+ * Alternate enumeration based on traces as identified by Duplicate.v
+ *
+ * This is a slight alteration to the above heuristic, ensuring that any
+ * superblock will be contiguous in memory, while still following the original
+ * heuristic
+ *)
+
+let get_some = function
+| None -> failwith "Did not get some"
+| Some thing -> thing
+
+exception EmptyList
+
+let rec last_element = function
+ | [] -> raise EmptyList
+ | e :: [] -> e
+ | e' :: e :: l -> last_element (e::l)
+
+let print_plist l =
+ let rec f = function
+ | [] -> ()
+ | n :: l -> Printf.printf "%d, " (P.to_int n); f l
+ in begin
+ if !debug_flag then begin
+ Printf.printf "[";
+ f l;
+ Printf.printf "]"
+ end
+ end
+
+(* adapted from the above join_points function, but with PTree *)
+let get_join_points code entry =
+ let reached = ref (PTree.map (fun n i -> false) code) in
+ let reached_twice = ref (PTree.map (fun n i -> false) code) in
+ let rec traverse pc =
+ if get_some @@ PTree.get pc !reached then begin
+ if not (get_some @@ PTree.get pc !reached_twice) then
+ reached_twice := PTree.set pc true !reached_twice
+ end else begin
+ reached := PTree.set pc true !reached;
+ traverse_succs (successors_block @@ get_some @@ PTree.get pc code)
+ end
+ and traverse_succs = function
+ | [] -> ()
+ | [pc] -> traverse pc
+ | pc :: l -> traverse pc; traverse_succs l
+ in traverse entry; !reached_twice
+
+let forward_sequences code entry =
+ let visited = ref (PTree.map (fun n i -> false) code) in
+ let join_points = get_join_points code entry in
+ (* returns the list of traversed nodes, and a list of nodes to start traversing next *)
+ let rec traverse_fallthrough code node =
+ (* debug "Traversing %d..\n" (P.to_int node); *)
+ if not (get_some @@ PTree.get node !visited) then begin
+ visited := PTree.set node true !visited;
+ match PTree.get node code with
+ | None -> failwith "No such node"
+ | Some bb ->
+ let ln, rem = match (last_element bb) with
+ | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
+ | Lbuiltin _ -> assert false
+ | Ltailcall _ | Lreturn -> begin (* debug "STOP tailcall/return\n"; *) ([], []) end
+ | Lbranch n ->
+ if get_some @@ PTree.get n join_points then ([], [n])
+ else let ln, rem = traverse_fallthrough code n in (ln, rem)
+ | Lcond (_, _, ifso, ifnot, info) -> (match info with
+ | None -> begin (* debug "STOP Lcond None\n"; *) ([], [ifso; ifnot]) end
+ | Some false ->
+ if get_some @@ PTree.get ifnot join_points then ([], [ifso; ifnot])
+ else let ln, rem = traverse_fallthrough code ifnot in (ln, [ifso] @ rem)
+ | Some true ->
+ if get_some @@ PTree.get ifso join_points then ([], [ifso; ifnot])
+ else let ln, rem = traverse_fallthrough code ifso in (ln, [ifnot] @ rem)
+ )
+ | Ljumptable(_, ln) -> begin (* debug "STOP Ljumptable\n"; *) ([], ln) end
+ in ([node] @ ln, rem)
+ end
+ else ([], [])
+ in let rec f code = function
+ | [] -> []
+ | node :: ln ->
+ let fs, rem_from_node = traverse_fallthrough code node
+ in [fs] @ ((f code rem_from_node) @ (f code ln))
+ in (f code [entry])
+
+(** Unused code
+module PInt = struct
+ type t = P.t
+ let compare x y = compare (P.to_int x) (P.to_int y)
+end
+
+module PSet = Set.Make(PInt)
+
+module LPInt = struct
+ type t = P.t list
+ let rec compare x y =
+ match x with
+ | [] -> ( match y with
+ | [] -> 0
+ | _ -> 1 )
+ | e :: l -> match y with
+ | [] -> -1
+ | e' :: l' ->
+ let e_cmp = PInt.compare e e' in
+ if e_cmp == 0 then compare l l' else e_cmp
+end
+
+module LPSet = Set.Make(LPInt)
+
+let iter_lpset f s = Seq.iter f (LPSet.to_seq s)
+
+let first_of = function
+ | [] -> None
+ | e :: l -> Some e
+
+let rec last_of = function
+ | [] -> None
+ | e :: l -> (match l with [] -> Some e | e :: l -> last_of l)
+
+let can_be_merged code s s' =
+ let last_s = get_some @@ last_of s in
+ let first_s' = get_some @@ first_of s' in
+ match get_some @@ PTree.get last_s code with
+ | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
+ | Lbuiltin _ | Ltailcall _ | Lreturn -> false
+ | Lbranch n -> n == first_s'
+ | Lcond (_, _, ifso, ifnot, info) -> (match info with
+ | None -> false
+ | Some false -> ifnot == first_s'
+ | Some true -> failwith "Inconsistency detected - ifnot is not the preferred branch")
+ | Ljumptable (_, ln) ->
+ match ln with
+ | [] -> false
+ | n :: ln -> n == first_s'
+
+let merge s s' = Some s
+
+let try_merge code (fs: (BinNums.positive list) list) =
+ let seqs = ref (LPSet.of_list fs) in
+ let oldLength = ref (LPSet.cardinal !seqs) in
+ let continue = ref true in
+ let found = ref false in
+ while !continue do
+ begin
+ found := false;
+ iter_lpset (fun s ->
+ if !found then ()
+ else iter_lpset (fun s' ->
+ if (!found || s == s') then ()
+ else if (can_be_merged code s s') then
+ begin
+ seqs := LPSet.remove s !seqs;
+ seqs := LPSet.remove s' !seqs;
+ seqs := LPSet.add (get_some (merge s s')) !seqs;
+ found := true;
+ end
+ else ()
+ ) !seqs
+ ) !seqs;
+ if !oldLength == LPSet.cardinal !seqs then
+ continue := false
+ else
+ oldLength := LPSet.cardinal !seqs
+ end
+ done;
+ !seqs
+*)
+
+(** Code adapted from Duplicateaux.get_loop_headers
+ *
+ * Getting loop branches with a DFS visit :
+ * Each node is either Unvisited, Visited, or Processed
+ * pre-order: node becomes Processed
+ * post-order: node becomes Visited
+ *
+ * If we come accross an edge to a Processed node, it's a loop!
+ *)
+type pos = BinNums.positive
+
+module PP = struct
+ type t = pos * pos
+ let compare a b =
+ let ax, ay = a in
+ let bx, by = b in
+ let dx = compare ax bx in
+ if (dx == 0) then compare ay by
+ else dx
+end
+
+module PPMap = Map.Make(PP)
+
+type vstate = Unvisited | Processed | Visited
+
+let get_loop_edges code entry =
+ let visited = ref (PTree.map (fun n i -> Unvisited) code) in
+ let is_loop_edge = ref PPMap.empty
+ in let rec dfs_visit code from = function
+ | [] -> ()
+ | node :: ln ->
+ match (get_some @@ PTree.get node !visited) with
+ | Visited -> ()
+ | Processed -> begin
+ let from_node = get_some from in
+ is_loop_edge := PPMap.add (from_node, node) true !is_loop_edge;
+ visited := PTree.set node Visited !visited
+ end
+ | Unvisited -> begin
+ visited := PTree.set node Processed !visited;
+ let bb = get_some @@ PTree.get node code in
+ let next_visits = (match (last_element bb) with
+ | Lop _ | Lload _ | Lgetstack _ | Lsetstack _ | Lstore _ | Lcall _
+ | Lbuiltin _ -> assert false
+ | Ltailcall _ | Lreturn -> []
+ | Lbranch n -> [n]
+ | Lcond (_, _, ifso, ifnot, _) -> [ifso; ifnot]
+ | Ljumptable(_, ln) -> ln
+ ) in dfs_visit code (Some node) next_visits;
+ visited := PTree.set node Visited !visited;
+ dfs_visit code from ln
+ end
+ in begin
+ dfs_visit code None [entry];
+ !is_loop_edge
+ end
+
+let ppmap_is_true pp ppmap = PPMap.mem pp ppmap && PPMap.find pp ppmap
+
+module Int = struct
+ type t = int
+ let compare x y = compare x y
+end
+
+module ISet = Set.Make(Int)
+
+let print_iset s = begin
+ if !debug_flag then begin
+ Printf.printf "{";
+ ISet.iter (fun e -> Printf.printf "%d, " e) s;
+ Printf.printf "}"
+ end
+end
+
+let print_depmap dm = begin
+ if !debug_flag then begin
+ Printf.printf "[|";
+ Array.iter (fun s -> print_iset s; Printf.printf ", ") dm;
+ Printf.printf "|]\n"
+ end
+end
+
+let construct_depmap code entry fs =
+ let is_loop_edge = get_loop_edges code entry in
+ let visited = ref (PTree.map (fun n i -> false) code) in
+ let depmap = Array.map (fun e -> ISet.empty) fs in
+ let find_index_of_node n =
+ let index = ref 0 in
+ begin
+ Array.iteri (fun i s ->
+ match List.find_opt (fun e -> e == n) s with
+ | Some _ -> index := i
+ | None -> ()
+ ) fs;
+ !index
+ end
+ in let check_and_update_depmap from target =
+ (* debug "From %d to %d\n" (P.to_int from) (P.to_int target); *)
+ if not (ppmap_is_true (from, target) is_loop_edge) then
+ let in_index_fs = find_index_of_node from in
+ let out_index_fs = find_index_of_node target in
+ if out_index_fs != in_index_fs then
+ depmap.(out_index_fs) <- ISet.add in_index_fs depmap.(out_index_fs)
+ else ()
+ else ()
+ in let rec dfs_visit code = function
+ | [] -> ()
+ | node :: ln ->
+ begin
+ match (get_some @@ PTree.get node !visited) with
+ | true -> ()
+ | false -> begin
+ visited := PTree.set node true !visited;
+ let bb = get_some @@ PTree.get node code in
+ let next_visits =
+ match (last_element bb) with
+ | Ltailcall _ | Lreturn -> []
+ | Lbranch n -> (check_and_update_depmap node n; [n])
+ | Lcond (_, _, ifso, ifnot, _) -> begin
+ check_and_update_depmap node ifso;
+ check_and_update_depmap node ifnot;
+ [ifso; ifnot]
+ end
+ | Ljumptable(_, ln) -> begin
+ List.iter (fun n -> check_and_update_depmap node n) ln;
+ ln
+ end
+ (* end of bblocks should not be another value than one of the above *)
+ | _ -> failwith "last_element gave an invalid output"
+ in dfs_visit code next_visits
+ end;
+ dfs_visit code ln
+ end
+ in begin
+ dfs_visit code [entry];
+ depmap
+ end
+
+let print_sequence s =
+ if !debug_flag then begin
+ Printf.printf "[";
+ List.iter (fun n -> Printf.printf "%d, " (P.to_int n)) s;
+ Printf.printf "]\n"
+ end
+
+let print_ssequence ofs =
+ if !debug_flag then begin
+ Printf.printf "[";
+ List.iter (fun s -> print_sequence s) ofs;
+ Printf.printf "]\n"
+ end
+
+let order_sequences code entry fs =
+ let fs_a = Array.of_list fs in
+ let depmap = construct_depmap code entry fs_a in
+ let fs_evaluated = Array.map (fun e -> false) fs_a in
+ let ordered_fs = ref [] in
+ let evaluate s_id =
+ begin
+ assert (not fs_evaluated.(s_id));
+ ordered_fs := fs_a.(s_id) :: !ordered_fs;
+ fs_evaluated.(s_id) <- true;
+ (* debug "++++++\n";
+ debug "Scheduling %d\n" s_id;
+ debug "Initial depmap: "; print_depmap depmap; *)
+ Array.iteri (fun i deps ->
+ depmap.(i) <- ISet.remove s_id deps
+ ) depmap;
+ (* debug "Final depmap: "; print_depmap depmap; *)
+ end
+ in let choose_best_of candidates =
+ let current_best_id = ref None in
+ let current_best_score = ref None in
+ begin
+ List.iter (fun id ->
+ match !current_best_id with
+ | None -> begin
+ current_best_id := Some id;
+ match fs_a.(id) with
+ | [] -> current_best_score := None
+ | n::l -> current_best_score := Some (P.to_int n)
+ end
+ | Some b -> begin
+ match fs_a.(id) with
+ | [] -> ()
+ | n::l -> let nscore = P.to_int n in
+ match !current_best_score with
+ | None -> (current_best_id := Some id; current_best_score := Some nscore)
+ | Some bs -> if nscore > bs then (current_best_id := Some id; current_best_score := Some nscore)
+ end
+ ) candidates;
+ !current_best_id
+ end
+ in let select_next () =
+ let candidates = ref [] in
+ begin
+ Array.iteri (fun i deps ->
+ begin
+ (* debug "Deps of %d: " i; print_iset deps; debug "\n"; *)
+ (* FIXME - if we keep it that way (no dependency check), remove all the unneeded stuff *)
+ if ((* deps == ISet.empty && *) not fs_evaluated.(i)) then
+ candidates := i :: !candidates
+ end
+ ) depmap;
+ if not (List.length !candidates > 0) then begin
+ Array.iteri (fun i deps ->
+ if (not fs_evaluated.(i)) then candidates := i :: !candidates
+ ) depmap;
+ end;
+ get_some (choose_best_of !candidates)
+ end
+ in begin
+ debug "-------------------------------\n";
+ debug "depmap: "; print_depmap depmap;
+ debug "forward sequences identified: "; print_ssequence fs;
+ while List.length !ordered_fs != List.length fs do
+ let next_id = select_next () in
+ evaluate next_id
+ done;
+ debug "forward sequences ordered: "; print_ssequence (List.rev (!ordered_fs));
+ List.rev (!ordered_fs)
+ end
+
+let enumerate_aux_trace f reach =
+ let code = f.fn_code in
+ let entry = f.fn_entrypoint in
+ let fs = forward_sequences code entry in
+ let ofs = order_sequences code entry fs in
+ List.flatten ofs
+
+let enumerate_aux f reach =
+ if !Clflags.option_ftracelinearize then enumerate_aux_trace f reach
+ else enumerate_aux_flat f reach
diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v
index 10a3d8b2..18dc52a5 100644
--- a/backend/Linearizeproof.v
+++ b/backend/Linearizeproof.v
@@ -585,45 +585,61 @@ Proof.
intros; eapply reachable_successors; eauto.
eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.
- (* Lop *)
+- (* Lop *)
left; econstructor; split. simpl.
apply plus_one. econstructor; eauto.
instantiate (1 := v); rewrite <- H; apply eval_operation_preserved.
exact symbols_preserved.
econstructor; eauto.
- (* Lload *)
+- (* Lload *)
left; econstructor; split. simpl.
- apply plus_one. econstructor.
+ apply plus_one. eapply exec_Lload.
instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
exact symbols_preserved. eauto. eauto.
econstructor; eauto.
- (* Lgetstack *)
+- (* Lload notrap1 *)
+ left; econstructor; split. simpl.
+ apply plus_one. eapply exec_Lload_notrap1.
+ rewrite <- H.
+ apply eval_addressing_preserved.
+ exact symbols_preserved. eauto.
+ econstructor; eauto.
+
+- (* Lload notrap2 *)
+ left; econstructor; split. simpl.
+ apply plus_one. eapply exec_Lload_notrap2.
+ rewrite <- H.
+ apply eval_addressing_preserved.
+ exact symbols_preserved. eauto. eauto.
+ econstructor; eauto.
+
+- (* Lgetstack *)
left; econstructor; split. simpl.
apply plus_one. econstructor; eauto.
econstructor; eauto.
- (* Lsetstack *)
+- (* Lsetstack *)
left; econstructor; split. simpl.
apply plus_one. econstructor; eauto.
econstructor; eauto.
- (* Lstore *)
+- (* Lstore *)
left; econstructor; split. simpl.
apply plus_one. econstructor.
instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
exact symbols_preserved. eauto. eauto.
econstructor; eauto.
- (* Lcall *)
+- (* Lcall *)
exploit find_function_translated; eauto. intros [tfd [A B]].
left; econstructor; split. simpl.
apply plus_one. econstructor; eauto.
symmetry; eapply sig_preserved; eauto.
econstructor; eauto. constructor; auto. econstructor; eauto.
- (* Ltailcall *)
+- (* Ltailcall *)
exploit find_function_translated; eauto. intros [tfd [A B]].
left; econstructor; split. simpl.
apply plus_one. econstructor; eauto.
@@ -633,18 +649,18 @@ Proof.
rewrite (match_parent_locset _ _ STACKS).
econstructor; eauto.
- (* Lbuiltin *)
+- (* Lbuiltin *)
left; econstructor; split. simpl.
apply plus_one. eapply exec_Lbuiltin; eauto.
eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
eapply external_call_symbols_preserved; eauto. apply senv_preserved.
econstructor; eauto.
- (* Lbranch *)
+- (* Lbranch *)
assert ((reachable f)!!pc = true). apply REACH; simpl; auto.
right; split. simpl; omega. split. auto. simpl. econstructor; eauto.
- (* Lcond *)
+- (* Lcond *)
assert (REACH1: (reachable f)!!pc1 = true) by (apply REACH; simpl; auto).
assert (REACH2: (reachable f)!!pc2 = true) by (apply REACH; simpl; auto).
simpl linearize_block.
@@ -670,18 +686,18 @@ Proof.
apply plus_one. eapply exec_Lcond_false. eauto. eauto.
econstructor; eauto.
- (* Ljumptable *)
+- (* Ljumptable *)
assert (REACH': (reachable f)!!pc = true).
apply REACH. simpl. eapply list_nth_z_in; eauto.
right; split. simpl; omega. split. auto. econstructor; eauto.
- (* Lreturn *)
+- (* Lreturn *)
left; econstructor; split.
simpl. apply plus_one. econstructor; eauto.
rewrite (stacksize_preserved _ _ TRF). eauto.
rewrite (match_parent_locset _ _ STACKS). econstructor; eauto.
- (* internal functions *)
+- (* internal functions *)
assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true).
apply reachable_entrypoint.
monadInv H7.
@@ -691,13 +707,13 @@ Proof.
generalize EQ; intro EQ'; monadInv EQ'. simpl.
econstructor; eauto. simpl. eapply is_tail_add_branch. constructor.
- (* external function *)
+- (* external function *)
monadInv H8. left; econstructor; split.
apply plus_one. eapply exec_function_external; eauto.
eapply external_call_symbols_preserved; eauto. apply senv_preserved.
econstructor; eauto.
- (* return *)
+- (* return *)
inv H3. inv H1.
left; econstructor; split.
apply plus_one. econstructor.
diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v
index bc9fb3ca..3fe61470 100644
--- a/backend/Lineartyping.v
+++ b/backend/Lineartyping.v
@@ -39,7 +39,7 @@ Definition slot_valid (sl: slot) (ofs: Z) (ty: typ): bool :=
| Outgoing => zle 0 ofs
| Incoming => In_dec Loc.eq (S Incoming ofs ty) (regs_of_rpairs (loc_parameters funct.(fn_sig)))
end
- && Zdivide_dec (typealign ty) ofs (typealign_pos ty).
+ && Zdivide_dec (typealign ty) ofs.
Definition slot_writable (sl: slot) : bool :=
match sl with
@@ -76,7 +76,7 @@ Definition wt_instr (i: instruction) : bool :=
let (targs, tres) := type_of_operation op in
subtype tres (mreg_type res)
end
- | Lload chunk addr args dst =>
+ | Lload trap chunk addr args dst =>
subtype (type_of_chunk chunk) (mreg_type dst)
| Ltailcall sg ros =>
zeq (size_arguments sg) 0
@@ -321,17 +321,34 @@ Local Opaque mreg_type.
+ (* other ops *)
destruct (type_of_operation op) as [ty_args ty_res] eqn:TYOP. InvBooleans.
econstructor; eauto.
+
apply wt_setreg; auto; try (apply wt_undef_regs; auto).
eapply Val.has_subtype; eauto.
+
change ty_res with (snd (ty_args, ty_res)). rewrite <- TYOP. eapply type_of_operation_sound; eauto.
red; intros; subst op. simpl in ISMOVE.
- destruct args; try discriminate. destruct args; discriminate.
+ destruct args; try discriminate. destruct args; discriminate.
+ (* no longer needed apply wt_undef_regs; auto. *)
- (* load *)
simpl in *; InvBooleans.
econstructor; eauto.
apply wt_setreg. eapply Val.has_subtype; eauto.
destruct a; simpl in H0; try discriminate. eapply Mem.load_type; eauto.
apply wt_undef_regs; auto.
+- (* load notrap1 *)
+ simpl in *; InvBooleans.
+ econstructor; eauto.
+ apply wt_setreg. eapply Val.has_subtype; eauto.
+ unfold default_notrap_load_value.
+ constructor.
+ apply wt_undef_regs; auto.
+- (* load notrap2 *)
+ simpl in *; InvBooleans.
+ econstructor; eauto.
+ apply wt_setreg. eapply Val.has_subtype; eauto.
+ unfold default_notrap_load_value.
+ constructor.
+ apply wt_undef_regs; auto.
- (* store *)
simpl in *; InvBooleans.
econstructor. eauto. eauto. eauto.
diff --git a/backend/Liveness.v b/backend/Liveness.v
index 16533158..9652b363 100644
--- a/backend/Liveness.v
+++ b/backend/Liveness.v
@@ -79,7 +79,7 @@ Definition transfer
reg_list_live args (reg_dead res after)
else
after
- | Iload chunk addr args dst s =>
+ | Iload trap chunk addr args dst s =>
if Regset.mem dst after then
reg_list_live args (reg_dead dst after)
else
@@ -94,7 +94,7 @@ Definition transfer
| Ibuiltin ef args res s =>
reg_list_live (params_of_builtin_args args)
(reg_list_dead (params_of_builtin_res res) after)
- | Icond cond args ifso ifnot =>
+ | Icond cond args ifso ifnot _ =>
reg_list_live args after
| Ijumptable arg tbl =>
reg_live arg after
diff --git a/backend/Mach.v b/backend/Mach.v
index 9fdee9eb..1c6fdb18 100644
--- a/backend/Mach.v
+++ b/backend/Mach.v
@@ -56,7 +56,7 @@ Inductive instruction: Type :=
| Msetstack: mreg -> ptrofs -> typ -> instruction
| Mgetparam: ptrofs -> typ -> mreg -> instruction
| Mop: operation -> list mreg -> mreg -> instruction
- | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction
+ | Mload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction
| Mcall: signature -> mreg + ident -> instruction
| Mtailcall: signature -> mreg + ident -> instruction
@@ -321,11 +321,24 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp (Mop op args res :: c) rs m)
E0 (State s f sp c rs' m)
| exec_Mload:
- forall s f sp chunk addr args dst c rs m a v rs',
+ forall s f sp trap chunk addr args dst c rs m a v rs',
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) ->
- step (State s f sp (Mload chunk addr args dst :: c) rs m)
+ step (State s f sp (Mload trap chunk addr args dst :: c) rs m)
+ E0 (State s f sp c rs' m)
+ | exec_Mload_notrap1:
+ forall s f sp chunk addr args dst c rs m rs',
+ eval_addressing ge sp addr rs##args = None ->
+ rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) ->
+ step (State s f sp (Mload NOTRAP chunk addr args dst :: c) rs m)
+ E0 (State s f sp c rs' m)
+ | exec_Mload_notrap2:
+ forall s f sp chunk addr args dst c rs m a rs',
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = None ->
+ rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) ->
+ step (State s f sp (Mload NOTRAP chunk addr args dst :: c) rs m)
E0 (State s f sp c rs' m)
| exec_Mstore:
forall s f sp chunk addr args src c rs m m' a rs',
diff --git a/backend/NeedDomain.v b/backend/NeedDomain.v
index d431f3d8..3c2d8e20 100644
--- a/backend/NeedDomain.v
+++ b/backend/NeedDomain.v
@@ -16,6 +16,7 @@ Require Import Coqlib.
Require Import Maps.
Require Import IntvSets.
Require Import AST.
+Require Import Zbits.
Require Import Integers.
Require Import Floats.
Require Import Values.
@@ -300,13 +301,13 @@ Proof.
rewrite Int.bits_ror.
replace (((i - Int.unsigned amount) mod Int.zwordsize + Int.unsigned amount)
mod Int.zwordsize) with i. auto.
- apply Int.eqmod_small_eq with Int.zwordsize; auto.
- apply Int.eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount).
- apply Int.eqmod_refl2; omega.
- eapply Int.eqmod_trans. 2: apply Int.eqmod_mod; auto.
- apply Int.eqmod_add.
- apply Int.eqmod_mod; auto.
- apply Int.eqmod_refl.
+ apply eqmod_small_eq with Int.zwordsize; auto.
+ apply eqmod_trans with ((i - Int.unsigned amount) + Int.unsigned amount).
+ apply eqmod_refl2; omega.
+ eapply eqmod_trans. 2: apply eqmod_mod; auto.
+ apply eqmod_add.
+ apply eqmod_mod; auto.
+ apply eqmod_refl.
apply Z_mod_lt; auto.
apply Z_mod_lt; auto.
Qed.
@@ -324,16 +325,16 @@ Qed.
Lemma eqmod_iagree:
forall m x y,
- Int.eqmod (two_p (Int.size m)) x y ->
+ eqmod (two_p (Int.size m)) x y ->
iagree (Int.repr x) (Int.repr y) m.
Proof.
- intros. set (p := nat_of_Z (Int.size m)).
+ intros. set (p := Z.to_nat (Int.size m)).
generalize (Int.size_range m); intros RANGE.
- assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
+ assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. }
rewrite EQ in H; rewrite <- two_power_nat_two_p in H.
red; intros. rewrite ! Int.testbit_repr by auto.
destruct (zlt i (Int.size m)).
- eapply Int.same_bits_eqmod; eauto. omega.
+ eapply same_bits_eqmod; eauto. omega.
assert (Int.testbit m i = false) by (eapply Int.bits_size_2; omega).
congruence.
Qed.
@@ -343,13 +344,13 @@ Definition complete_mask (m: int) := Int.zero_ext (Int.size m) Int.mone.
Lemma iagree_eqmod:
forall x y m,
iagree x y (complete_mask m) ->
- Int.eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y).
+ eqmod (two_p (Int.size m)) (Int.unsigned x) (Int.unsigned y).
Proof.
- intros. set (p := nat_of_Z (Int.size m)).
+ intros. set (p := Z.to_nat (Int.size m)).
generalize (Int.size_range m); intros RANGE.
- assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply nat_of_Z_eq. omega. }
+ assert (EQ: Int.size m = Z.of_nat p). { symmetry; apply Z2Nat.id. omega. }
rewrite EQ; rewrite <- two_power_nat_two_p.
- apply Int.eqmod_same_bits. intros. apply H. omega.
+ apply eqmod_same_bits. intros. apply H. omega.
unfold complete_mask. rewrite Int.bits_zero_ext by omega.
rewrite zlt_true by omega. rewrite Int.bits_mone by omega. auto.
Qed.
@@ -362,7 +363,7 @@ Proof.
+ assert (Int.unsigned m <> 0).
{ red; intros; elim n. rewrite <- (Int.repr_unsigned m). rewrite H; auto. }
assert (0 < Int.size m).
- { apply Int.Zsize_pos'. generalize (Int.unsigned_range m); omega. }
+ { apply Zsize_pos'. generalize (Int.unsigned_range m); omega. }
generalize (Int.size_range m); intros.
f_equal. apply Int.bits_size_4. tauto.
rewrite Int.bits_zero_ext by omega. rewrite zlt_true by omega.
@@ -593,7 +594,8 @@ Proof.
Qed.
(** Modular arithmetic operations: add, mul, opposite.
- (But not subtraction because of the pointer - pointer case. *)
+ Also subtraction, but only on 64-bit targets, otherwise
+ the pointer - pointer case does not fit. *)
Definition modarith (x: nval) :=
match x with
@@ -610,7 +612,20 @@ Proof.
unfold modarith; intros. destruct x; simpl in *.
- auto.
- unfold Val.add; InvAgree.
- apply eqmod_iagree. apply Int.eqmod_add; apply iagree_eqmod; auto.
+ apply eqmod_iagree. apply eqmod_add; apply iagree_eqmod; auto.
+- inv H; auto. inv H0; auto. destruct w1; auto.
+Qed.
+
+Lemma sub_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (modarith x) -> vagree v2 w2 (modarith x) ->
+ Archi.ptr64 = true ->
+ vagree (Val.sub v1 v2) (Val.sub w1 w2) x.
+Proof.
+ unfold modarith; intros. destruct x; simpl in *.
+- auto.
+- unfold Val.sub; rewrite H1; InvAgree.
+ apply eqmod_iagree. apply eqmod_sub; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.
@@ -626,7 +641,7 @@ Lemma mul_sound:
Proof.
unfold mul, add; intros. destruct x; simpl in *.
- auto.
-- unfold Val.mul; InvAgree. apply eqmod_iagree. apply Int.eqmod_mult; apply iagree_eqmod; auto.
+- unfold Val.mul; InvAgree. apply eqmod_iagree. apply eqmod_mult; apply iagree_eqmod; auto.
- inv H; auto. inv H0; auto. destruct w1; auto.
Qed.
@@ -638,7 +653,7 @@ Proof.
intros; destruct x; simpl in *.
- auto.
- unfold Val.neg; InvAgree.
- apply eqmod_iagree. apply Int.eqmod_neg. apply iagree_eqmod; auto.
+ apply eqmod_iagree. apply eqmod_neg. apply iagree_eqmod; auto.
- inv H; simpl; auto.
Qed.
@@ -679,7 +694,7 @@ Definition sign_ext (n: Z) (x: nval) :=
Lemma sign_ext_sound:
forall v w x n,
vagree v w (sign_ext n x) ->
- 0 < n < Int.zwordsize ->
+ 0 < n ->
vagree (Val.sign_ext n v) (Val.sign_ext n w) x.
Proof.
unfold sign_ext; intros. destruct x; simpl in *.
@@ -785,6 +800,34 @@ Proof.
inv H0. rewrite iagree_and_eq in H. rewrite H. auto.
Qed.
+(** The needs of a select *)
+
+Lemma normalize_sound:
+ forall v w x ty,
+ vagree v w x ->
+ vagree (Val.normalize v ty) (Val.normalize w ty) x.
+Proof.
+ intros. destruct x; simpl in *.
+- auto.
+- unfold Val.normalize. destruct v.
+ auto.
+ destruct w; try contradiction. destruct ty; auto.
+ destruct ty; auto.
+ destruct ty; auto.
+ destruct ty; auto.
+ destruct ty; destruct Archi.ptr64; auto.
+- apply Val.normalize_lessdef; auto.
+Qed.
+
+Lemma select_sound:
+ forall ob v1 v2 w1 w2 ty x,
+ vagree v1 w1 x -> vagree v2 w2 x ->
+ vagree (Val.select ob v1 v2 ty) (Val.select ob w1 w2 ty) x.
+Proof.
+ unfold Val.select; intros. destruct ob as [b|]; auto with na.
+ apply normalize_sound. destruct b; auto.
+Qed.
+
(** The default abstraction: if the result is unused, the arguments are
unused; otherwise, the arguments are needed in full. *)
@@ -860,7 +903,8 @@ Lemma default_needs_of_operation_sound:
eval_operation ge (Vptr sp Ptrofs.zero) op args1 m1 = Some v1 ->
vagree_list args1 args2 nil
\/ vagree_list args1 args2 (default nv :: nil)
- \/ vagree_list args1 args2 (default nv :: default nv :: nil) ->
+ \/ vagree_list args1 args2 (default nv :: default nv :: nil)
+ \/ vagree_list args1 args2 (default nv :: default nv :: default nv :: nil) ->
nv <> Nothing ->
exists v2,
eval_operation ge (Vptr sp Ptrofs.zero) op args2 m2 = Some v2
@@ -872,7 +916,8 @@ Proof.
{
destruct H0. auto with na.
destruct H0. inv H0; constructor; auto with na.
- inv H0; constructor; auto with na. inv H8; constructor; auto with na.
+ destruct H0. inv H0. constructor. inv H8; constructor; auto with na.
+ inv H0; constructor; auto with na. inv H8; constructor; auto with na. inv H9; constructor; auto with na.
}
exploit (@eval_operation_inj _ _ _ _ ge ge inject_id).
eassumption. auto. auto. auto.
diff --git a/backend/OpHelpers.v b/backend/OpHelpers.v
index 53414dab..b9b97903 100644
--- a/backend/OpHelpers.v
+++ b/backend/OpHelpers.v
@@ -6,16 +6,16 @@ Require Import Op CminorSel.
runtime library functions. The following type class collects
the names of these functions. *)
-Definition sig_l_l := mksignature (Tlong :: nil) (Some Tlong) cc_default.
-Definition sig_l_f := mksignature (Tlong :: nil) (Some Tfloat) cc_default.
-Definition sig_l_s := mksignature (Tlong :: nil) (Some Tsingle) cc_default.
-Definition sig_f_l := mksignature (Tfloat :: nil) (Some Tlong) cc_default.
-Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) (Some Tlong) cc_default.
-Definition sig_li_l := mksignature (Tlong :: Tint :: nil) (Some Tlong) cc_default.
-Definition sig_ii_l := mksignature (Tint :: Tint :: nil) (Some Tlong) cc_default.
-Definition sig_ii_i := mksignature (Tint :: Tint :: nil) (Some Tint) cc_default.
-Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) (Some Tfloat) cc_default.
-Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) (Some Tsingle) cc_default.
+Definition sig_l_l := mksignature (Tlong :: nil) Tlong cc_default.
+Definition sig_l_f := mksignature (Tlong :: nil) Tfloat cc_default.
+Definition sig_l_s := mksignature (Tlong :: nil) Tsingle cc_default.
+Definition sig_f_l := mksignature (Tfloat :: nil) Tlong cc_default.
+Definition sig_ll_l := mksignature (Tlong :: Tlong :: nil) Tlong cc_default.
+Definition sig_li_l := mksignature (Tlong :: Tint :: nil) Tlong cc_default.
+Definition sig_ii_l := mksignature (Tint :: Tint :: nil) Tlong cc_default.
+Definition sig_ii_i := mksignature (Tint :: Tint :: nil) Tint cc_default.
+Definition sig_ff_f := mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default.
+Definition sig_ss_s := mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default.
Class helper_functions := mk_helper_functions {
i64_dtos: ident; (**r float64 -> signed long *)
diff --git a/backend/OpHelpersproof.v b/backend/OpHelpersproof.v
index 63040c5f..08da8a36 100644
--- a/backend/OpHelpersproof.v
+++ b/backend/OpHelpersproof.v
@@ -75,4 +75,4 @@ Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F)
/\ helper_declared p i32_umod "__compcert_i32_umod" sig_ii_i
/\ helper_declared p f32_div "__compcert_f32_div" sig_ss_s
/\ helper_declared p f64_div "__compcert_f64_div" sig_ff_f
-.
+. \ No newline at end of file
diff --git a/backend/PrintAsm.ml b/backend/PrintAsm.ml
index 92d465d5..155f5e55 100644
--- a/backend/PrintAsm.ml
+++ b/backend/PrintAsm.ml
@@ -13,7 +13,6 @@
open AST
open Camlcoq
-open DwarfPrinter
open PrintAsmaux
open Printf
open Sections
@@ -40,6 +39,7 @@ module Printer(Target:TARGET) =
let print_function oc name fn =
Hashtbl.clear current_function_labels;
+ Debug.symbol_printed (extern_atom name);
let (text, lit, jmptbl) = Target.get_section_names name in
Target.section oc text;
let alignment =
@@ -117,7 +117,7 @@ module Printer(Target:TARGET) =
match v.gvar_init with
| [] -> ()
| _ ->
- Debug.variable_printed (extern_atom name);
+ Debug.symbol_printed (extern_atom name);
let sec =
match C2C.atom_sections name with
| [s] -> s
@@ -176,7 +176,7 @@ module Printer(Target:TARGET) =
let address = Target.address
end
- module DebugPrinter = DwarfPrinter (DwarfTarget)
+ module DebugPrinter = DwarfPrinter.DwarfPrinter (DwarfTarget)
end
let print_program oc p =
diff --git a/backend/PrintAsmaux.ml b/backend/PrintAsmaux.ml
index f9ed569f..d82e6f84 100644
--- a/backend/PrintAsmaux.ml
+++ b/backend/PrintAsmaux.ml
@@ -99,7 +99,7 @@ let exists_constants () =
let current_function_stacksize = ref 0l
let current_function_sig =
- ref { sig_args = []; sig_res = None; sig_cc = cc_default }
+ ref { sig_args = []; sig_res = Tvoid; sig_cc = cc_default }
(* Functions for printing of symbol names *)
let elf_symbol oc symb =
@@ -245,14 +245,15 @@ let print_debug_info comment print_line preg_string sp_name oc kind txt args =
(** Inline assembly *)
-let print_asm_argument print_preg oc modifier = function
- | BA r -> print_preg oc r
+let print_asm_argument print_preg oc modifier typ = function
+ | BA r -> print_preg oc typ r
| BA_splitlong(BA hi, BA lo) ->
begin match modifier with
- | "R" -> print_preg oc hi
- | "Q" -> print_preg oc lo
- | _ -> fprintf oc "%a:%a" print_preg hi print_preg lo
- (* Probably not what was intended *)
+ | "R" -> print_preg oc Tint hi
+ | "Q" -> print_preg oc Tint lo
+ | _ -> print_preg oc Tint hi; fprintf oc ":"; print_preg oc Tint lo
+ (* This case (printing a split long in full) should never
+ happen because of the checks done in ExtendedAsm.ml *)
end
| _ -> failwith "bad asm argument"
@@ -265,8 +266,10 @@ let re_asm_param_1 = Str.regexp "%%\\|%[QR]?[0-9]+"
let re_asm_param_2 = Str.regexp "%\\([QR]?\\)\\([0-9]+\\)"
let print_inline_asm print_preg oc txt sg args res =
- let operands =
- if sg.sig_res = None then args else builtin_arg_of_res res :: args in
+ let (operands, ty_operands) =
+ match sg.sig_res with
+ | Tvoid -> (args, sg.sig_args)
+ | tres -> (builtin_arg_of_res res :: args, proj_rettype tres :: sg.sig_args) in
let print_fragment = function
| Str.Text s ->
output_string oc s
@@ -277,7 +280,9 @@ let print_inline_asm print_preg oc txt sg args res =
let modifier = Str.matched_group 1 s
and number = int_of_string (Str.matched_group 2 s) in
try
- print_asm_argument print_preg oc modifier (List.nth operands number)
+ print_asm_argument print_preg oc modifier
+ (List.nth ty_operands number)
+ (List.nth operands number)
with Failure _ ->
fprintf oc "<bad parameter %s>" s in
List.iter print_fragment (Str.full_split re_asm_param_1 txt);
@@ -289,12 +294,20 @@ let print_inline_asm print_preg oc txt sg args res =
let print_version_and_options oc comment =
let version_string =
if Version.buildnr <> "" && Version.tag <> "" then
- sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
+ sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
else
Version.version in
fprintf oc "%s File generated by CompCert %s\n" comment version_string;
fprintf oc "%s Command line:" comment;
- for i = 1 to Array.length Sys.argv - 1 do
- fprintf oc " %s" Sys.argv.(i)
+ for i = 1 to Array.length Commandline.argv - 1 do
+ fprintf oc " %s" Commandline.argv.(i)
done;
fprintf oc "\n"
+(** Get the name of the common section if it is used otherwise the given section
+ name, with bss as default *)
+
+let common_section ?(sec = ".bss") () =
+ if !Clflags.option_fcommon then
+ "COMM"
+ else
+ sec
diff --git a/backend/PrintCminor.ml b/backend/PrintCminor.ml
index f68c1267..c9a6d399 100644
--- a/backend/PrintCminor.ml
+++ b/backend/PrintCminor.ml
@@ -16,7 +16,7 @@
(** Pretty-printer for Cminor *)
open Format
-open Camlcoq
+open! Camlcoq
open Integers
open AST
open PrintAST
@@ -193,9 +193,7 @@ let print_sig p sg =
List.iter
(fun t -> fprintf p "%s ->@ " (name_of_type t))
sg.sig_args;
- match sg.sig_res with
- | None -> fprintf p "void"
- | Some ty -> fprintf p "%s" (name_of_type ty)
+ fprintf p "%s" (name_of_rettype sg.sig_res)
let rec just_skips s =
match s with
diff --git a/backend/PrintLTL.ml b/backend/PrintLTL.ml
index d0557073..d8f2ac12 100644
--- a/backend/PrintLTL.ml
+++ b/backend/PrintLTL.ml
@@ -61,9 +61,10 @@ let print_succ pp s dfl =
let print_instruction pp succ = function
| Lop(op, args, res) ->
fprintf pp "%a = %a" mreg res (print_operation mreg) (op, args)
- | Lload(chunk, addr, args, dst) ->
- fprintf pp "%a = %s[%a]"
- mreg dst (name_of_chunk chunk) (print_addressing mreg) (addr, args)
+ | Lload(trap,chunk, addr, args, dst) ->
+ fprintf pp "%a = %s[%a]%a"
+ mreg dst (name_of_chunk chunk) (print_addressing mreg) (addr, args)
+ print_trapping_mode trap
| Lgetstack(sl, ofs, ty, dst) ->
fprintf pp "%a = %a" mreg dst slot (sl, ofs, ty)
| Lsetstack(src, sl, ofs, ty) ->
@@ -82,10 +83,11 @@ let print_instruction pp succ = function
(print_builtin_args loc) args
| Lbranch s ->
print_succ pp s succ
- | Lcond(cond, args, s1, s2) ->
- fprintf pp "if (%a) goto %d else goto %d"
+ | Lcond(cond, args, s1, s2, info) ->
+ fprintf pp "if (%a) goto %d else goto %d (prediction: %s)"
(print_condition mreg) (cond, args)
(P.to_int s1) (P.to_int s2)
+ (match info with None -> "none" | Some true -> "branch" | Some false -> "fallthrough")
| Ljumptable(arg, tbl) ->
let tbl = Array.of_list tbl in
fprintf pp "jumptable (%a)" mreg arg;
@@ -112,7 +114,7 @@ let print_function pp id f =
fprintf pp "%s() {\n" (extern_atom id);
let instrs =
List.sort
- (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1)
+ (fun (pc1, _) (pc2, _) -> compare pc2 pc1)
(List.rev_map
(fun (pc, i) -> (P.to_int pc, i))
(PTree.elements f.fn_code)) in
diff --git a/backend/PrintLTLin.ml b/backend/PrintLTLin.ml
deleted file mode 100644
index 4e8efd16..00000000
--- a/backend/PrintLTLin.ml
+++ /dev/null
@@ -1,115 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Pretty-printer for LTLin code *)
-
-open Format
-open Camlcoq
-open Datatypes
-open Maps
-open AST
-open Integers
-open Locations
-open Machregsaux
-open LTLin
-open PrintAST
-open PrintOp
-
-let reg pp loc =
- match loc with
- | R r ->
- begin match name_of_register r with
- | Some s -> fprintf pp "%s" s
- | None -> fprintf pp "<unknown reg>"
- end
- | S (Local(ofs, ty)) ->
- fprintf pp "local(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs)
- | S (Incoming(ofs, ty)) ->
- fprintf pp "incoming(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs)
- | S (Outgoing(ofs, ty)) ->
- fprintf pp "outgoing(%s,%ld)" (name_of_type ty) (camlint_of_coqint ofs)
-
-let rec regs pp = function
- | [] -> ()
- | [r] -> reg pp r
- | r1::rl -> fprintf pp "%a, %a" reg r1 regs rl
-
-let ros pp = function
- | Coq_inl r -> reg pp r
- | Coq_inr s -> fprintf pp "\"%s\"" (extern_atom s)
-
-let print_instruction pp i =
- match i with
- | Lop(op, args, res) ->
- fprintf pp "%a = %a@ "
- reg res (PrintOp.print_operation reg) (op, args)
- | Lload(chunk, addr, args, dst) ->
- fprintf pp "%a = %s[%a]@ "
- reg dst (name_of_chunk chunk)
- (PrintOp.print_addressing reg) (addr, args)
- | Lstore(chunk, addr, args, src) ->
- fprintf pp "%s[%a] = %a@ "
- (name_of_chunk chunk)
- (PrintOp.print_addressing reg) (addr, args)
- reg src
- | Lcall(sg, fn, args, res) ->
- fprintf pp "%a = %a(%a)@ "
- reg res ros fn regs args
- | Ltailcall(sg, fn, args) ->
- fprintf pp "tailcall %a(%a)@ "
- ros fn regs args
- | Lbuiltin(ef, args, res) ->
- fprintf pp "%a = builtin %s(%a)@ "
- reg res (name_of_external ef) regs args
- | Llabel lbl ->
- fprintf pp "%ld:@ " (P.to_int32 lbl)
- | Lgoto lbl ->
- fprintf pp "goto %ld@ " (P.to_int32 lbl)
- | Lcond(cond, args, lbl) ->
- fprintf pp "if (%a) goto %ld@ "
- (PrintOp.print_condition reg) (cond, args)
- (P.to_int32 lbl)
- | Ljumptable(arg, tbl) ->
- let tbl = Array.of_list tbl in
- fprintf pp "@[<v 2>jumptable (%a)" reg arg;
- for i = 0 to Array.length tbl - 1 do
- fprintf pp "@ case %d: goto %ld" i (P.to_int32 tbl.(i))
- done;
- fprintf pp "@]@ "
- | Lreturn None ->
- fprintf pp "return@ "
- | Lreturn (Some arg) ->
- fprintf pp "return %a@ " reg arg
-
-let print_function pp id f =
- fprintf pp "@[<v 2>%s(%a) {@ " (extern_atom id) regs f.fn_params;
- List.iter (print_instruction pp) f.fn_code;
- fprintf pp "@;<0 -2>}@]@."
-
-let print_globdef pp (id, gd) =
- match gd with
- | Gfun(Internal f) -> print_function pp id f
- | _ -> ()
-
-let print_program pp prog =
- List.iter (print_globdef pp) prog.prog_defs
-
-let destination : string option ref = ref None
-
-let print_if prog =
- match !destination with
- | None -> ()
- | Some f ->
- let oc = open_out f in
- let pp = formatter_of_out_channel oc in
- print_program pp prog;
- close_out oc
diff --git a/backend/PrintMach.ml b/backend/PrintMach.ml
index 517f3037..70e65832 100644
--- a/backend/PrintMach.ml
+++ b/backend/PrintMach.ml
@@ -48,10 +48,11 @@ let print_instruction pp i =
| Mop(op, args, res) ->
fprintf pp "\t%a = %a\n"
reg res (PrintOp.print_operation reg) (op, args)
- | Mload(chunk, addr, args, dst) ->
- fprintf pp "\t%a = %s[%a]\n"
+ | Mload(trap, chunk, addr, args, dst) ->
+ fprintf pp "\t%a = %s[%a]%a\n"
reg dst (name_of_chunk chunk)
(PrintOp.print_addressing reg) (addr, args)
+ print_trapping_mode trap
| Mstore(chunk, addr, args, src) ->
fprintf pp "\t%s[%a] = %a\n"
(name_of_chunk chunk)
diff --git a/backend/PrintRTL.ml b/backend/PrintRTL.ml
index ba336b0a..b2ef05ca 100644
--- a/backend/PrintRTL.ml
+++ b/backend/PrintRTL.ml
@@ -50,10 +50,11 @@ let print_instruction pp (pc, i) =
fprintf pp "%a = %a\n"
reg res (PrintOp.print_operation reg) (op, args);
print_succ pp s (pc - 1)
- | Iload(chunk, addr, args, dst, s) ->
- fprintf pp "%a = %s[%a]\n"
+ | Iload(trap, chunk, addr, args, dst, s) ->
+ fprintf pp "%a = %s[%a]%a\n"
reg dst (name_of_chunk chunk)
- (PrintOp.print_addressing reg) (addr, args);
+ (PrintOp.print_addressing reg) (addr, args)
+ print_trapping_mode trap;
print_succ pp s (pc - 1)
| Istore(chunk, addr, args, src, s) ->
fprintf pp "%s[%a] = %a\n"
@@ -74,10 +75,11 @@ let print_instruction pp (pc, i) =
(name_of_external ef)
(print_builtin_args reg) args;
print_succ pp s (pc - 1)
- | Icond(cond, args, s1, s2) ->
- fprintf pp "if (%a) goto %d else goto %d\n"
+ | Icond(cond, args, s1, s2, info) ->
+ fprintf pp "if (%a) goto %d else goto %d (prediction: %s)\n"
(PrintOp.print_condition reg) (cond, args)
(P.to_int s1) (P.to_int s2)
+ (match info with None -> "none" | Some true -> "branch" | Some false -> "fallthrough")
| Ijumptable(arg, tbl) ->
let tbl = Array.of_list tbl in
fprintf pp "jumptable (%a)\n" reg arg;
@@ -93,7 +95,7 @@ let print_function pp id f =
fprintf pp "%s(%a) {\n" (extern_atom id) regs f.fn_params;
let instrs =
List.sort
- (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1)
+ (fun (pc1, _) (pc2, _) -> compare pc2 pc1)
(List.rev_map
(fun (pc, i) -> (P.to_int pc, i))
(PTree.elements f.fn_code)) in
diff --git a/backend/PrintXTL.ml b/backend/PrintXTL.ml
index cc1f7d49..d1b79623 100644
--- a/backend/PrintXTL.ml
+++ b/backend/PrintXTL.ml
@@ -86,9 +86,10 @@ let print_instruction pp succ = function
fprintf pp "(%a) = (%a) using %a, %a" vars dsts vars srcs var t1 var t2
| Xop(op, args, res) ->
fprintf pp "%a = %a" var res (print_operation var) (op, args)
- | Xload(chunk, addr, args, dst) ->
- fprintf pp "%a = %s[%a]"
- var dst (name_of_chunk chunk) (print_addressing var) (addr, args)
+ | Xload(trap, chunk, addr, args, dst) ->
+ fprintf pp "%a = %s[%a]%a"
+ var dst (name_of_chunk chunk) (print_addressing var) (addr, args)
+ print_trapping_mode trap
| Xstore(chunk, addr, args, src) ->
fprintf pp "%s[%a] = %a"
(name_of_chunk chunk) (print_addressing var) (addr, args) var src
@@ -103,7 +104,7 @@ let print_instruction pp succ = function
(print_builtin_args var) args
| Xbranch s ->
print_succ pp s succ
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, _) ->
fprintf pp "if (%a) goto %d else goto %d"
(print_condition var) (cond, args)
(P.to_int s1) (P.to_int s2)
@@ -138,7 +139,7 @@ let print_function pp ?alloc ?live f =
fprintf pp "f() {\n";
let instrs =
List.sort
- (fun (pc1, _) (pc2, _) -> Pervasives.compare pc2 pc1)
+ (fun (pc1, _) (pc2, _) -> compare pc2 pc1)
(List.map
(fun (pc, i) -> (P.to_int pc, i))
(PTree.elements f.fn_code)) in
diff --git a/backend/RTL.v b/backend/RTL.v
index 16723d96..dec59ca2 100644
--- a/backend/RTL.v
+++ b/backend/RTL.v
@@ -43,11 +43,12 @@ Inductive instruction: Type :=
(** [Iop op args dest succ] performs the arithmetic operation [op]
over the values of registers [args], stores the result in [dest],
and branches to [succ]. *)
- | Iload: memory_chunk -> addressing -> list reg -> reg -> node -> instruction
- (** [Iload chunk addr args dest succ] loads a [chunk] quantity from
+ | Iload: trapping_mode -> memory_chunk -> addressing -> list reg -> reg -> node -> instruction
+ (** [Iload trap chunk addr args dest succ] loads a [chunk] quantity from
the address determined by the addressing mode [addr] and the
values of the [args] registers, stores the quantity just read
- into [dest], and branches to [succ]. *)
+ into [dest], and branches to [succ].
+ If trap=NOTRAP, then failures lead to a default value written to [dest]. *)
| Istore: memory_chunk -> addressing -> list reg -> reg -> node -> instruction
(** [Istore chunk addr args src succ] stores the value of register
[src] in the [chunk] quantity at the
@@ -66,14 +67,15 @@ Inductive instruction: Type :=
(** [Ibuiltin ef args dest succ] calls the built-in function
identified by [ef], giving it the values of [args] as arguments.
It stores the return value in [dest] and branches to [succ]. *)
- | Icond: condition -> list reg -> node -> node -> instruction
- (** [Icond cond args ifso ifnot] evaluates the boolean condition
+ | Icond: condition -> list reg -> node -> node -> option bool -> instruction
+ (** [Icond cond args ifso ifnot info] evaluates the boolean condition
[cond] over the values of registers [args]. If the condition
is true, it transitions to [ifso]. If the condition is false,
- it transitions to [ifnot]. *)
+ it transitions to [ifnot]. [info] is a ghost field there to provide
+ information relative to branch prediction. *)
| Ijumptable: reg -> list node -> instruction
(** [Ijumptable arg tbl] transitions to the node that is the [n]-th
- element of the list [tbl], where [n] is the signed integer
+ element of the list [tbl], where [n] is the unsigned integer
value of register [arg]. *)
| Ireturn: option reg -> instruction.
(** [Ireturn] terminates the execution of the current function
@@ -212,12 +214,25 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp pc rs m)
E0 (State s f sp pc' (rs#res <- v) m)
| exec_Iload:
- forall s f sp pc rs m chunk addr args dst pc' a v,
- (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
+ forall s f sp pc rs m trap chunk addr args dst pc' a v,
+ (fn_code f)!pc = Some(Iload trap chunk addr args dst pc') ->
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
step (State s f sp pc rs m)
E0 (State s f sp pc' (rs#dst <- v) m)
+ | exec_Iload_notrap1:
+ forall s f sp pc rs m chunk addr args dst pc',
+ (fn_code f)!pc = Some(Iload NOTRAP chunk addr args dst pc') ->
+ eval_addressing ge sp addr rs##args = None ->
+ step (State s f sp pc rs m)
+ E0 (State s f sp pc' (rs#dst <- (default_notrap_load_value chunk)) m)
+ | exec_Iload_notrap2:
+ forall s f sp pc rs m chunk addr args dst pc' a,
+ (fn_code f)!pc = Some(Iload NOTRAP chunk addr args dst pc') ->
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = None->
+ step (State s f sp pc rs m)
+ E0 (State s f sp pc' (rs#dst <- (default_notrap_load_value chunk)) m)
| exec_Istore:
forall s f sp pc rs m chunk addr args src pc' a m',
(fn_code f)!pc = Some(Istore chunk addr args src pc') ->
@@ -248,8 +263,8 @@ Inductive step: state -> trace -> state -> Prop :=
step (State s f sp pc rs m)
t (State s f sp pc' (regmap_setres res vres rs) m')
| exec_Icond:
- forall s f sp pc rs m cond args ifso ifnot b pc',
- (fn_code f)!pc = Some(Icond cond args ifso ifnot) ->
+ forall s f sp pc rs m cond args ifso ifnot b pc' predb,
+ (fn_code f)!pc = Some(Icond cond args ifso ifnot predb) ->
eval_condition cond rs##args m = Some b ->
pc' = (if b then ifso else ifnot) ->
step (State s f sp pc rs m)
@@ -299,8 +314,8 @@ Proof.
Qed.
Lemma exec_Iload':
- forall s f sp pc rs m chunk addr args dst pc' rs' a v,
- (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
+ forall s f sp pc rs m trap chunk addr args dst pc' rs' a v,
+ (fn_code f)!pc = Some(Iload trap chunk addr args dst pc') ->
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = (rs#dst <- v) ->
@@ -384,12 +399,12 @@ Definition successors_instr (i: instruction) : list node :=
match i with
| Inop s => s :: nil
| Iop op args res s => s :: nil
- | Iload chunk addr args dst s => s :: nil
+ | Iload trap chunk addr args dst s => s :: nil
| Istore chunk addr args src s => s :: nil
| Icall sig ros args res s => s :: nil
| Itailcall sig ros args => nil
| Ibuiltin ef args res s => s :: nil
- | Icond cond args ifso ifnot => ifso :: ifnot :: nil
+ | Icond cond args ifso ifnot _ => ifso :: ifnot :: nil
| Ijumptable arg tbl => tbl
| Ireturn optarg => nil
end.
@@ -403,14 +418,14 @@ Definition instr_uses (i: instruction) : list reg :=
match i with
| Inop s => nil
| Iop op args res s => args
- | Iload chunk addr args dst s => args
+ | Iload trap chunk addr args dst s => args
| Istore chunk addr args src s => src :: args
| Icall sig (inl r) args res s => r :: args
| Icall sig (inr id) args res s => args
| Itailcall sig (inl r) args => r :: args
| Itailcall sig (inr id) args => args
| Ibuiltin ef args res s => params_of_builtin_args args
- | Icond cond args ifso ifnot => args
+ | Icond cond args ifso ifnot _ => args
| Ijumptable arg tbl => arg :: nil
| Ireturn None => nil
| Ireturn (Some arg) => arg :: nil
@@ -422,13 +437,13 @@ Definition instr_defs (i: instruction) : option reg :=
match i with
| Inop s => None
| Iop op args res s => Some res
- | Iload chunk addr args dst s => Some dst
+ | Iload trap chunk addr args dst s => Some dst
| Istore chunk addr args src s => None
| Icall sig ros args res s => Some res
| Itailcall sig ros args => None
| Ibuiltin ef args res s =>
match res with BR r => Some r | _ => None end
- | Icond cond args ifso ifnot => None
+ | Icond cond args ifso ifnot _ => None
| Ijumptable arg tbl => None
| Ireturn optarg => None
end.
@@ -462,7 +477,7 @@ Definition max_reg_instr (m: positive) (pc: node) (i: instruction) :=
match i with
| Inop s => m
| Iop op args res s => fold_left Pos.max args (Pos.max res m)
- | Iload chunk addr args dst s => fold_left Pos.max args (Pos.max dst m)
+ | Iload trap chunk addr args dst s => fold_left Pos.max args (Pos.max dst m)
| Istore chunk addr args src s => fold_left Pos.max args (Pos.max src m)
| Icall sig (inl r) args res s => fold_left Pos.max args (Pos.max r (Pos.max res m))
| Icall sig (inr id) args res s => fold_left Pos.max args (Pos.max res m)
@@ -471,7 +486,7 @@ Definition max_reg_instr (m: positive) (pc: node) (i: instruction) :=
| Ibuiltin ef args res s =>
fold_left Pos.max (params_of_builtin_args args)
(fold_left Pos.max (params_of_builtin_res res) m)
- | Icond cond args ifso ifnot => fold_left Pos.max args m
+ | Icond cond args ifso ifnot _ => fold_left Pos.max args m
| Ijumptable arg tbl => Pos.max arg m
| Ireturn None => m
| Ireturn (Some arg) => Pos.max arg m
diff --git a/backend/RTLgen.v b/backend/RTLgen.v
index 9d7a8506..ac98f3a1 100644
--- a/backend/RTLgen.v
+++ b/backend/RTLgen.v
@@ -410,12 +410,11 @@ Fixpoint convert_builtin_args {A: Type} (al: list (builtin_arg expr)) (rl: list
a1' :: convert_builtin_args al rl1
end.
-Definition convert_builtin_res (map: mapping) (oty: option typ) (r: builtin_res ident) : mon (builtin_res reg) :=
- match r, oty with
- | BR id, _ => do r <- find_var map id; ret (BR r)
- | BR_none, None => ret BR_none
- | BR_none, Some _ => do r <- new_reg; ret (BR r)
- | _, _ => error (Errors.msg "RTLgen: bad builtin_res")
+Definition convert_builtin_res (map: mapping) (ty: rettype) (r: builtin_res ident) : mon (builtin_res reg) :=
+ match r with
+ | BR id => do r <- find_var map id; ret (BR r)
+ | BR_none => if rettype_eq ty Tvoid then ret BR_none else (do r <- new_reg; ret (BR r))
+ | _ => error (Errors.msg "RTLgen: bad builtin_res")
end.
(** Translation of an expression. [transl_expr map a rd nd]
@@ -436,7 +435,7 @@ Fixpoint transl_expr (map: mapping) (a: expr) (rd: reg) (nd: node)
transl_exprlist map al rl no
| Eload chunk addr al =>
do rl <- alloc_regs map al;
- do no <- add_instr (Iload chunk addr rl rd nd);
+ do no <- add_instr (Iload TRAP chunk addr rl rd nd);
transl_exprlist map al rl no
| Econdition a b c =>
do nfalse <- transl_expr map c rd nd;
@@ -480,7 +479,7 @@ with transl_condexpr (map: mapping) (a: condexpr) (ntrue nfalse: node)
match a with
| CEcond c al =>
do rl <- alloc_regs map al;
- do nt <- add_instr (Icond c rl ntrue nfalse);
+ do nt <- add_instr (Icond c rl ntrue nfalse None);
transl_exprlist map al rl nt
| CEcondition a b c =>
do nc <- transl_condexpr map c ntrue nfalse;
@@ -667,10 +666,7 @@ Fixpoint reserve_labels (s: stmt) (ms: labelmap * state)
(** Translation of a CminorSel function. *)
Definition ret_reg (sig: signature) (rd: reg) : option reg :=
- match sig.(sig_res) with
- | None => None
- | Some ty => Some rd
- end.
+ if rettype_eq sig.(sig_res) Tvoid then None else Some rd.
Definition transl_fun (f: CminorSel.function) (ngoto: labelmap): mon (node * list reg) :=
do (rparams, map1) <- add_vars init_mapping f.(CminorSel.fn_params);
diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v
index b003eb10..b94ec22f 100644
--- a/backend/RTLgenproof.v
+++ b/backend/RTLgenproof.v
@@ -704,7 +704,7 @@ Proof.
intros; red; intros. inv TE.
exploit H0; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]].
exploit external_call_mem_extends; eauto.
- intros [v' [tm2 [A [B [C [D E]]]]]].
+ intros [v' [tm2 [A [B [C D]]]]].
exists (rs1#rd <- v'); exists tm2.
(* Exec *)
split. eapply star_right. eexact EX1.
@@ -736,7 +736,7 @@ Proof.
intros; red; intros. inv TE.
exploit H3; eauto. intros [rs1 [tm1 [EX1 [ME1 [RR1 [RO1 EXT1]]]]]].
exploit external_call_mem_extends; eauto.
- intros [v' [tm2 [A [B [C [D E]]]]]].
+ intros [v' [tm2 [A [B [C D]]]]].
exploit function_ptr_translated; eauto. simpl. intros [tf [P Q]]. inv Q.
exists (rs1#rd <- v'); exists tm2.
(* Exec *)
diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v
index 17022a7d..30ad7d82 100644
--- a/backend/RTLgenspec.v
+++ b/backend/RTLgenspec.v
@@ -639,8 +639,8 @@ Lemma new_reg_return_ok:
map_valid map s1 ->
return_reg_ok s2 map (ret_reg sig r).
Proof.
- intros. unfold ret_reg. destruct (sig_res sig); constructor.
- eauto with rtlg. eauto with rtlg.
+ intros. unfold ret_reg.
+ destruct (rettype_eq (sig_res sig) Tvoid); constructor; eauto with rtlg.
Qed.
(** * Relational specification of the translation *)
@@ -707,7 +707,7 @@ Inductive tr_expr (c: code):
tr_expr c map pr (Eop op al) ns nd rd dst
| tr_Eload: forall map pr chunk addr al ns nd rd n1 rl dst,
tr_exprlist c map pr al ns n1 rl ->
- c!n1 = Some (Iload chunk addr rl rd nd) ->
+ c!n1 = Some (Iload TRAP chunk addr rl rd nd) ->
reg_map_ok map rd dst -> ~In rd pr ->
tr_expr c map pr (Eload chunk addr al) ns nd rd dst
| tr_Econdition: forall map pr a ifso ifnot ns nd rd ntrue nfalse dst,
@@ -744,9 +744,9 @@ Inductive tr_expr (c: code):
with tr_condition (c: code):
mapping -> list reg -> condexpr -> node -> node -> node -> Prop :=
- | tr_CEcond: forall map pr cond bl ns ntrue nfalse n1 rl,
+ | tr_CEcond: forall map pr cond bl ns ntrue nfalse n1 rl i,
tr_exprlist c map pr bl ns n1 rl ->
- c!n1 = Some (Icond cond rl ntrue nfalse) ->
+ c!n1 = Some (Icond cond rl ntrue nfalse i) ->
tr_condition c map pr (CEcond cond bl) ns ntrue nfalse
| tr_CEcondition: forall map pr a1 a2 a3 ns ntrue nfalse n2 n3,
tr_condition c map pr a1 ns n2 n3 ->
@@ -1224,9 +1224,9 @@ Lemma convert_builtin_res_charact:
Proof.
destruct res; simpl; intros.
- monadInv TR. constructor. unfold find_var in EQ. destruct (map_vars map)!x; inv EQ; auto.
-- destruct oty; monadInv TR.
-+ constructor. eauto with rtlg.
+- destruct (rettype_eq oty Tvoid); monadInv TR.
+ constructor.
++ constructor. eauto with rtlg.
- monadInv TR.
Qed.
@@ -1350,7 +1350,7 @@ Proof.
intros [C D].
eapply tr_function_intro; eauto with rtlg.
eapply transl_stmt_charact; eauto with rtlg.
- unfold ret_reg. destruct (sig_res (CminorSel.fn_sig f)).
- constructor. eauto with rtlg. eauto with rtlg.
+ unfold ret_reg. destruct (rettype_eq (sig_res (CminorSel.fn_sig f)) Tvoid).
constructor.
+ constructor; eauto with rtlg.
Qed.
diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v
index 8336d1bf..15ed6d8a 100644
--- a/backend/RTLtyping.v
+++ b/backend/RTLtyping.v
@@ -104,11 +104,11 @@ Inductive wt_instr : instruction -> Prop :=
valid_successor s ->
wt_instr (Iop op args res s)
| wt_Iload:
- forall chunk addr args dst s,
+ forall trap chunk addr args dst s,
map env args = type_of_addressing addr ->
env dst = type_of_chunk chunk ->
valid_successor s ->
- wt_instr (Iload chunk addr args dst s)
+ wt_instr (Iload trap chunk addr args dst s)
| wt_Istore:
forall chunk addr args src s,
map env args = type_of_addressing addr ->
@@ -139,11 +139,11 @@ Inductive wt_instr : instruction -> Prop :=
valid_successor s ->
wt_instr (Ibuiltin ef args res s)
| wt_Icond:
- forall cond args s1 s2,
+ forall cond args s1 s2 i,
map env args = type_of_condition cond ->
valid_successor s1 ->
valid_successor s2 ->
- wt_instr (Icond cond args s1 s2)
+ wt_instr (Icond cond args s1 s2 i)
| wt_Ijumptable:
forall arg tbl,
env arg = Tint ->
@@ -151,11 +151,12 @@ Inductive wt_instr : instruction -> Prop :=
list_length_z tbl * 4 <= Int.max_unsigned ->
wt_instr (Ijumptable arg tbl)
| wt_Ireturn_none:
- funct.(fn_sig).(sig_res) = None ->
+ funct.(fn_sig).(sig_res) = Tvoid ->
wt_instr (Ireturn None)
| wt_Ireturn_some:
forall arg ty,
- funct.(fn_sig).(sig_res) = Some ty ->
+ funct.(fn_sig).(sig_res) <> Tvoid ->
+ env arg = proj_sig_res funct.(fn_sig) ->
env arg = ty ->
wt_instr (Ireturn (Some arg)).
@@ -282,7 +283,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
else
(let (targs, tres) := type_of_operation op in
do e1 <- S.set_list e args targs; S.set e1 res tres)
- | Iload chunk addr args dst s =>
+ | Iload trap chunk addr args dst s =>
do x <- check_successor s;
do e1 <- S.set_list e args (type_of_addressing addr);
S.set e1 dst (type_of_chunk chunk)
@@ -298,7 +299,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
| Itailcall sig ros args =>
do e1 <- type_ros e ros;
do e2 <- S.set_list e1 args sig.(sig_args);
- if opt_typ_eq sig.(sig_res) f.(fn_sig).(sig_res) then
+ if rettype_eq sig.(sig_res) f.(fn_sig).(sig_res) then
if tailcall_is_possible sig
then OK e2
else Error(msg "tailcall not possible")
@@ -312,7 +313,7 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
| _ => type_builtin_args e args sig.(sig_args)
end;
type_builtin_res e1 res (proj_sig_res sig)
- | Icond cond args s1 s2 =>
+ | Icond cond args s1 s2 _ =>
do x1 <- check_successor s1;
do x2 <- check_successor s2;
S.set_list e args (type_of_condition cond)
@@ -323,9 +324,9 @@ Definition type_instr (e: S.typenv) (i: instruction) : res S.typenv :=
then OK e1
else Error(msg "jumptable too big")
| Ireturn optres =>
- match optres, f.(fn_sig).(sig_res) with
- | None, None => OK e
- | Some r, Some t => S.set e r t
+ match optres, rettype_eq f.(fn_sig).(sig_res) Tvoid with
+ | None, left _ => OK e
+ | Some r, right _ => S.set e r (proj_sig_res f.(fn_sig))
| _, _ => Error(msg "bad return")
end
end.
@@ -468,7 +469,7 @@ Proof.
destruct l; try discriminate. destruct l; monadInv EQ0. eauto with ty.
destruct (type_of_operation o) as [targs tres] eqn:TYOP. monadInv EQ0. eauto with ty.
- (* tailcall *)
- destruct (opt_typ_eq (sig_res s) (sig_res (fn_sig f))); try discriminate.
+ destruct (rettype_eq (sig_res s) (sig_res (fn_sig f))); try discriminate.
destruct (tailcall_is_possible s) eqn:TCIP; inv EQ2.
eauto with ty.
- (* builtin *)
@@ -477,7 +478,8 @@ Proof.
destruct (zle (list_length_z l * 4) Int.max_unsigned); inv EQ2.
eauto with ty.
- (* return *)
- simpl in H. destruct o as [r|] eqn: RET; destruct (sig_res (fn_sig f)) as [t|] eqn: RES; try discriminate.
+ simpl in H.
+ destruct o as [r|] eqn: RET; destruct (rettype_eq (sig_res (fn_sig f)) Tvoid); try discriminate.
eauto with ty.
inv H; auto with ty.
Qed.
@@ -519,7 +521,7 @@ Proof.
eapply S.set_sound; eauto with ty.
eauto with ty.
- (* tailcall *)
- destruct (opt_typ_eq (sig_res s) (sig_res (fn_sig f))); try discriminate.
+ destruct (rettype_eq (sig_res s) (sig_res (fn_sig f))); try discriminate.
destruct (tailcall_is_possible s) eqn:TCIP; inv EQ2.
constructor.
eapply type_ros_sound; eauto with ty.
@@ -543,8 +545,9 @@ Proof.
eapply check_successors_sound; eauto.
auto.
- (* return *)
- simpl in H. destruct o as [r|] eqn: RET; destruct (sig_res (fn_sig f)) as [t|] eqn: RES; try discriminate.
- econstructor. eauto. eapply S.set_sound; eauto with ty.
+ simpl in H.
+ destruct o as [r|] eqn: RET; destruct (rettype_eq (sig_res (fn_sig f)) Tvoid); try discriminate.
+ econstructor. auto. eapply S.set_sound; eauto with ty. eauto.
inv H. constructor. auto.
Qed.
@@ -721,9 +724,9 @@ Proof.
rewrite check_successor_complete by auto; simpl.
apply IHtbl0; intros; auto.
- (* return none *)
- rewrite H0. exists e; auto.
+ rewrite H0, dec_eq_true. exists e; auto.
- (* return some *)
- rewrite H0. apply S.set_complete; auto.
+ rewrite dec_eq_false by auto. apply S.set_complete; auto.
Qed.
Lemma type_code_complete:
@@ -841,14 +844,24 @@ Proof.
Qed.
Lemma wt_exec_Iload:
- forall env f chunk addr args dst s m a v rs,
- wt_instr f env (Iload chunk addr args dst s) ->
+ forall env f trap chunk addr args dst s m a v rs,
+ wt_instr f env (Iload trap chunk addr args dst s) ->
Mem.loadv chunk m a = Some v ->
wt_regset env rs ->
wt_regset env (rs#dst <- v).
Proof.
intros. destruct a; simpl in H0; try discriminate. inv H.
- eapply wt_regset_assign; eauto. rewrite H8; eapply Mem.load_type; eauto.
+ eapply wt_regset_assign; eauto. rewrite H9; eapply Mem.load_type; eauto.
+Qed.
+
+Lemma wt_exec_Iload_notrap:
+ forall env f chunk addr args dst s rs,
+ wt_instr f env (Iload NOTRAP chunk addr args dst s) ->
+ wt_regset env rs ->
+ wt_regset env (rs#dst <- (default_notrap_load_value chunk)).
+Proof.
+ intros.
+ eapply wt_regset_assign; eauto. simpl. trivial.
Qed.
Lemma wt_exec_Ibuiltin:
@@ -872,7 +885,7 @@ Qed.
Inductive wt_stackframes: list stackframe -> signature -> Prop :=
| wt_stackframes_nil: forall sg,
- sg.(sig_res) = Some Tint ->
+ sg.(sig_res) = Tint ->
wt_stackframes nil sg
| wt_stackframes_cons:
forall s res f sp pc rs env sg,
@@ -930,6 +943,10 @@ Proof.
econstructor; eauto. eapply wt_exec_Iop; eauto.
(* Iload *)
econstructor; eauto. eapply wt_exec_Iload; eauto.
+ (* Iload notrap1*)
+ econstructor; eauto. eapply wt_exec_Iload_notrap; eauto.
+ (* Iload notrap2*)
+ econstructor; eauto. eapply wt_exec_Iload_notrap; eauto.
(* Istore *)
econstructor; eauto.
(* Icall *)
@@ -964,13 +981,13 @@ Proof.
econstructor; eauto.
(* Ireturn *)
econstructor; eauto.
- inv WTI; simpl. auto. unfold proj_sig_res; rewrite H2. auto.
+ inv WTI; simpl. auto. rewrite <- H3. auto.
(* internal function *)
simpl in *. inv H5.
econstructor; eauto.
inv H1. apply wt_init_regs; auto. rewrite wt_params0. auto.
(* external function *)
- econstructor; eauto. simpl.
+ econstructor; eauto.
eapply external_call_well_typed; eauto.
(* return *)
inv H1. econstructor; eauto.
diff --git a/backend/Regalloc.ml b/backend/Regalloc.ml
index 7db8a866..ffe26933 100644
--- a/backend/Regalloc.ml
+++ b/backend/Regalloc.ml
@@ -249,18 +249,18 @@ let block_of_RTL_instr funsig tyenv = function
else
let t = new_temp (tyenv res) in (t :: args2', t) in
movelist args1 args3 (Xop(op, args3, res3) :: move res3 res1 [Xbranch s])
- | RTL.Iload(chunk, addr, args, dst, s) ->
+ | RTL.Iload(trap, chunk, addr, args, dst, s) ->
if Archi.splitlong && chunk = Mint64 then begin
match offset_addressing addr (coqint_of_camlint 4l) with
| None -> assert false
| Some addr' ->
- [Xload(Mint32, addr, vregs tyenv args,
+ [Xload(trap, Mint32, addr, vregs tyenv args,
V((if Archi.big_endian then dst else twin_reg dst), Tint));
- Xload(Mint32, addr', vregs tyenv args,
+ Xload(trap, Mint32, addr', vregs tyenv args,
V((if Archi.big_endian then twin_reg dst else dst), Tint));
Xbranch s]
end else
- [Xload(chunk, addr, vregs tyenv args, vreg tyenv dst); Xbranch s]
+ [Xload(trap, chunk, addr, vregs tyenv args, vreg tyenv dst); Xbranch s]
| RTL.Istore(chunk, addr, args, src, s) ->
if Archi.splitlong && chunk = Mint64 then begin
match offset_addressing addr (coqint_of_camlint 4l) with
@@ -295,8 +295,8 @@ let block_of_RTL_instr funsig tyenv = function
(Xbuiltin(ef, args2, res2) ::
movelist (params_of_builtin_res res2) (params_of_builtin_res res1)
[Xbranch s])
- | RTL.Icond(cond, args, s1, s2) ->
- [Xcond(cond, vregs tyenv args, s1, s2)]
+ | RTL.Icond(cond, args, s1, s2, i) ->
+ [Xcond(cond, vregs tyenv args, s1, s2, i)]
| RTL.Ijumptable(arg, tbl) ->
[Xjumptable(vreg tyenv arg, tbl)]
| RTL.Ireturn None ->
@@ -364,7 +364,7 @@ let live_before instr after =
if VSet.mem res after
then vset_addlist args (VSet.remove res after)
else after
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
if VSet.mem dst after
then vset_addlist args (VSet.remove dst after)
else after
@@ -380,7 +380,7 @@ let live_before instr after =
vset_addargs args (vset_removeres res after)
| Xbranch s ->
after
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, _) ->
List.fold_right VSet.add args after
| Xjumptable(arg, tbl) ->
VSet.add arg after
@@ -459,7 +459,7 @@ let dce_instr instr after k =
if VSet.mem res after
then instr :: k
else k
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
if VSet.mem dst after
then instr :: k
else k
@@ -550,7 +550,7 @@ let spill_costs f =
(* temps must not be spilled *)
| Xop(op, args, res) ->
charge_list 10 1 args; charge 10 1 res
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
charge_list 10 1 args; charge 10 1 dst
| Xstore(chunk, addr, args, src) ->
charge_list 10 1 args; charge 10 1 src
@@ -575,7 +575,7 @@ let spill_costs f =
charge_list 10 1 (params_of_builtin_res res)
end
| Xbranch _ -> ()
- | Xcond(cond, args, _, _) ->
+ | Xcond(cond, args, _, _, _) ->
charge_list 10 1 args
| Xjumptable(arg, _) ->
charge 10 1 arg
@@ -677,7 +677,7 @@ let add_interfs_instr g instr live =
(vset_addlist (res :: argl) (VSet.remove res live))
end;
add_interfs_destroyed g (VSet.remove res live) (destroyed_by_op op)
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
add_interfs_def g dst live;
add_interfs_destroyed g (VSet.remove dst live)
(destroyed_by_load chunk addr)
@@ -718,7 +718,7 @@ let add_interfs_instr g instr live =
end
| Xbranch s ->
()
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, _) ->
add_interfs_destroyed g live (destroyed_by_cond cond)
| Xjumptable(arg, tbl) ->
add_interfs_destroyed g live destroyed_by_jumptable
@@ -782,7 +782,7 @@ let tospill_instr alloc instr ts =
ts
| Xop(op, args, res) ->
addlist_tospill alloc args (add_tospill alloc res ts)
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
addlist_tospill alloc args (add_tospill alloc dst ts)
| Xstore(chunk, addr, args, src) ->
addlist_tospill alloc args (add_tospill alloc src ts)
@@ -797,7 +797,7 @@ let tospill_instr alloc instr ts =
(addlist_tospill alloc (params_of_builtin_res res) ts)
| Xbranch s ->
ts
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, _) ->
addlist_tospill alloc args ts
| Xjumptable(arg, tbl) ->
add_tospill alloc arg ts
@@ -964,10 +964,10 @@ let spill_instr tospill eqs instr =
add res tmp (kill tmp (kill res eqs2)))
end
end
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
let (args', c1, eqs1) = reload_vars tospill eqs args in
let (dst', c2, eqs2) = save_var tospill eqs1 dst in
- (c1 @ Xload(chunk, addr, args', dst') :: c2, eqs2)
+ (c1 @ Xload(trap, chunk, addr, args', dst') :: c2, eqs2)
| Xstore(chunk, addr, args, src) ->
let (args', c1, eqs1) = reload_vars tospill eqs args in
let (src', c2, eqs2) = reload_var tospill eqs1 src in
@@ -990,9 +990,9 @@ let spill_instr tospill eqs instr =
(c1 @ Xbuiltin(ef, args', res') :: c2, eqs2)
| Xbranch s ->
([instr], eqs)
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, i) ->
let (args', c1, eqs1) = reload_vars tospill eqs args in
- (c1 @ [Xcond(cond, args', s1, s2)], eqs1)
+ (c1 @ [Xcond(cond, args', s1, s2, i)], eqs1)
| Xjumptable(arg, tbl) ->
let (arg', c1, eqs1) = reload_var tospill eqs arg in
(c1 @ [Xjumptable(arg', tbl)], eqs1)
@@ -1115,8 +1115,8 @@ let transl_instr alloc instr k =
LTL.Lop(Omove, [rarg1], rres) ::
LTL.Lop(op, rres :: rargl, rres) :: k
end
- | Xload(chunk, addr, args, dst) ->
- LTL.Lload(chunk, addr, mregs_of alloc args, mreg_of alloc dst) :: k
+ | Xload(trap, chunk, addr, args, dst) ->
+ LTL.Lload(trap, chunk, addr, mregs_of alloc args, mreg_of alloc dst) :: k
| Xstore(chunk, addr, args, src) ->
LTL.Lstore(chunk, addr, mregs_of alloc args, mreg_of alloc src) :: k
| Xcall(sg, vos, args, res) ->
@@ -1128,8 +1128,8 @@ let transl_instr alloc instr k =
AST.map_builtin_res (mreg_of alloc) res) :: k
| Xbranch s ->
LTL.Lbranch s :: []
- | Xcond(cond, args, s1, s2) ->
- LTL.Lcond(cond, mregs_of alloc args, s1, s2) :: []
+ | Xcond(cond, args, s1, s2, i) ->
+ LTL.Lcond(cond, mregs_of alloc args, s1, s2, i) :: []
| Xjumptable(arg, tbl) ->
LTL.Ljumptable(mreg_of alloc arg, tbl) :: []
| Xreturn optarg ->
diff --git a/backend/Renumber.v b/backend/Renumber.v
index 10f58251..2727b979 100644
--- a/backend/Renumber.v
+++ b/backend/Renumber.v
@@ -43,12 +43,12 @@ Definition renum_instr (i: instruction) : instruction :=
match i with
| Inop s => Inop (renum_pc s)
| Iop op args res s => Iop op args res (renum_pc s)
- | Iload chunk addr args res s => Iload chunk addr args res (renum_pc s)
+ | Iload trap chunk addr args res s => Iload trap chunk addr args res (renum_pc s)
| Istore chunk addr args src s => Istore chunk addr args src (renum_pc s)
| Icall sg ros args res s => Icall sg ros args res (renum_pc s)
| Itailcall sg ros args => i
| Ibuiltin ef args res s => Ibuiltin ef args res (renum_pc s)
- | Icond cond args s1 s2 => Icond cond args (renum_pc s1) (renum_pc s2)
+ | Icond cond args s1 s2 info => Icond cond args (renum_pc s1) (renum_pc s2) info
| Ijumptable arg tbl => Ijumptable arg (List.map renum_pc tbl)
| Ireturn or => i
end.
diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v
index 7cda9425..2e161965 100644
--- a/backend/Renumberproof.v
+++ b/backend/Renumberproof.v
@@ -175,6 +175,18 @@ Proof.
rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
eapply exec_Iload; eauto.
constructor; auto. eapply reach_succ; eauto. simpl; auto.
+ (* load notrap1 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = None).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap1; eauto.
+ constructor; auto. eapply reach_succ; eauto. simpl; auto.
+ (* load notrap2 *)
+ econstructor; split.
+ assert (eval_addressing tge sp addr rs ## args = Some a).
+ rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved.
+ eapply exec_Iload_notrap2; eauto.
+ constructor; auto. eapply reach_succ; eauto. simpl; auto.
(* store *)
econstructor; split.
assert (eval_addressing tge sp addr rs ## args = Some a).
diff --git a/backend/SelectDivproof.v b/backend/SelectDivproof.v
index e2249ddb..1873da4d 100644
--- a/backend/SelectDivproof.v
+++ b/backend/SelectDivproof.v
@@ -12,7 +12,7 @@
(** Correctness of instruction selection for integer division *)
-Require Import Zquot Coqlib.
+Require Import Zquot Coqlib Zbits.
Require Import AST Integers Floats Values Memory Globalenvs Events.
Require Import Cminor Op CminorSel.
Require Import OpHelpers OpHelpersproof.
@@ -58,13 +58,13 @@ Proof.
apply Z.mul_nonneg_nonneg; omega.
assert (k * n <= two_p (N + l) - two_p l).
apply Z.le_trans with (two_p l * n).
- apply Zmult_le_compat_r. omega. omega.
+ apply Z.mul_le_mono_nonneg_r; omega.
replace (N + l) with (l + N) by omega.
rewrite two_p_is_exp.
replace (two_p l * two_p N - two_p l)
with (two_p l * (two_p N - 1))
by ring.
- apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
+ apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
omega. omega.
assert (0 <= two_p (N + l) * r).
apply Z.mul_nonneg_nonneg.
@@ -73,7 +73,7 @@ Proof.
assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
replace (two_p (N + l) * d - two_p (N + l))
with (two_p (N + l) * (d - 1)) by ring.
- apply Zmult_le_compat_l.
+ apply Z.mul_le_mono_nonneg_l.
omega.
exploit (two_p_gt_ZERO (N + l)). omega. omega.
assert (0 <= m * n - two_p (N + l) * q).
@@ -139,13 +139,13 @@ Proof.
rewrite H2.
assert (k * n <= two_p (N + l)).
rewrite Z.add_comm. rewrite two_p_is_exp; try omega.
- apply Z.le_trans with (two_p l * n). apply Zmult_le_compat_r. omega. omega.
- apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
+ apply Z.le_trans with (two_p l * n). apply Z.mul_le_mono_nonneg_r; omega.
+ apply Z.mul_le_mono_nonneg_l. omega. exploit (two_p_gt_ZERO l). omega. omega.
assert (two_p (N + l) * r <= two_p (N + l) * d - two_p (N + l)).
replace (two_p (N + l) * d - two_p (N + l))
with (two_p (N + l) * (d - 1))
by ring.
- apply Zmult_le_compat_l. omega. exploit (two_p_gt_ZERO (N + l)). omega. omega.
+ apply Z.mul_le_mono_nonneg_l. exploit (two_p_gt_ZERO (N + l)). omega. omega. omega.
omega.
Qed.
@@ -247,10 +247,11 @@ Proof.
unfold Int.max_signed; omega.
apply Zdiv_interval_1. generalize Int.min_signed_neg; omega. apply Int.half_modulus_pos.
apply Int.modulus_pos.
- split. apply Z.le_trans with (Int.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int.min_signed_neg; omega.
- apply Zmult_le_compat_r. unfold n; generalize (Int.signed_range x); tauto. tauto.
+ split. apply Z.le_trans with (Int.min_signed * m).
+ apply Z.mul_le_mono_nonpos_l. generalize Int.min_signed_neg; omega. omega.
+ apply Z.mul_le_mono_nonneg_r. omega. unfold n; generalize (Int.signed_range x); tauto.
apply Z.le_lt_trans with (Int.half_modulus * m).
- apply Zmult_le_compat_r. generalize (Int.signed_range x); unfold n, Int.max_signed; omega. tauto.
+ apply Z.mul_le_mono_nonneg_r. tauto. generalize (Int.signed_range x); unfold n, Int.max_signed; omega.
apply Zmult_lt_compat_l. generalize Int.half_modulus_pos; omega. tauto.
assert (32 < Int.max_unsigned) by (compute; auto). omega.
unfold Int.lt; fold n. rewrite Int.signed_zero. destruct (zlt n 0); apply Int.eqm_unsigned_repr.
@@ -291,7 +292,7 @@ Proof.
apply Int.eqm_sym. eapply Int.eqm_trans. apply Int.eqm_signed_unsigned.
apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl2.
apply (f_equal (fun x => n * x / Int.modulus)).
- rewrite Int.signed_repr_eq. rewrite Zmod_small by assumption.
+ rewrite Int.signed_repr_eq. rewrite Z.mod_small by assumption.
apply zlt_false. assumption.
Qed.
@@ -378,7 +379,7 @@ Qed.
Remark int64_shr'_div_two_p:
forall x y, Int64.shr' x y = Int64.repr (Int64.signed x / two_p (Int.unsigned y)).
Proof.
- intros; unfold Int64.shr'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
+ intros; unfold Int64.shr'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.
Lemma divls_mul_shift_gen:
@@ -401,8 +402,9 @@ Proof.
unfold Int64.max_signed; omega.
apply Zdiv_interval_1. generalize Int64.min_signed_neg; omega. apply Int64.half_modulus_pos.
apply Int64.modulus_pos.
- split. apply Z.le_trans with (Int64.min_signed * m). apply Zmult_le_compat_l_neg. omega. generalize Int64.min_signed_neg; omega.
- apply Zmult_le_compat_r. unfold n; generalize (Int64.signed_range x); tauto. tauto.
+ split. apply Z.le_trans with (Int64.min_signed * m).
+ apply Z.mul_le_mono_nonpos_l. generalize Int64.min_signed_neg; omega. omega.
+ apply Z.mul_le_mono_nonneg_r. tauto. unfold n; generalize (Int64.signed_range x); tauto.
apply Z.le_lt_trans with (Int64.half_modulus * m).
apply Zmult_le_compat_r. generalize (Int64.signed_range x); unfold n, Int64.max_signed; omega. tauto.
apply Zmult_lt_compat_l. generalize Int64.half_modulus_pos; omega. tauto.
@@ -445,14 +447,14 @@ Proof.
apply Int64.eqm_sym. eapply Int64.eqm_trans. apply Int64.eqm_signed_unsigned.
apply Int64.eqm_unsigned_repr_l. apply Int64.eqm_refl2.
apply (f_equal (fun x => n * x / Int64.modulus)).
- rewrite Int64.signed_repr_eq. rewrite Zmod_small by assumption.
+ rewrite Int64.signed_repr_eq. rewrite Z.mod_small by assumption.
apply zlt_false. assumption.
Qed.
Remark int64_shru'_div_two_p:
forall x y, Int64.shru' x y = Int64.repr (Int64.unsigned x / two_p (Int.unsigned y)).
Proof.
- intros; unfold Int64.shru'. rewrite Int64.Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
+ intros; unfold Int64.shru'. rewrite Zshiftr_div_two_p; auto. generalize (Int.unsigned_range y); omega.
Qed.
Theorem divlu_mul_shift:
@@ -762,8 +764,8 @@ Lemma eval_divlu_mull:
Proof.
intros. unfold divlu_mull. exploit (divlu_mul_shift x); eauto. intros [A B].
assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)) by (constructor; auto).
- exploit eval_mullhu. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
- exploit eval_shrluimm. eauto. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2).
+ exploit eval_mullhu. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
+ exploit eval_shrluimm. try apply HELPERS. eexact A1. instantiate (1 := Int.repr p). intros (v2 & A2 & B2).
simpl in B1; inv B1. simpl in B2. replace (Int.ltu (Int.repr p) Int64.iwordsize') with true in B2. inv B2.
rewrite B. assumption.
unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true; auto. tauto.
@@ -833,17 +835,17 @@ Proof.
intros. unfold divls_mull.
assert (A0: eval_expr ge sp e m le (Eletvar O) (Vlong x)).
{ constructor; auto. }
- exploit eval_mullhs. eauto. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
- exploit eval_addl; auto; try apply HELPERS. eexact A1. eexact A0. intros (v2 & A2 & B2).
- exploit eval_shrluimm. eauto. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3).
+ exploit eval_mullhs. try apply HELPERS. eexact A0. instantiate (1 := Int64.repr M). intros (v1 & A1 & B1).
+ exploit eval_addl. auto. eexact A1. eexact A0. intros (v2 & A2 & B2).
+ exploit eval_shrluimm. try apply HELPERS. eexact A0. instantiate (1 := Int.repr 63). intros (v3 & A3 & B3).
set (a4 := if zlt M Int64.half_modulus
then mullhs (Eletvar 0) (Int64.repr M)
else addl (mullhs (Eletvar 0) (Int64.repr M)) (Eletvar 0)).
set (v4 := if zlt M Int64.half_modulus then v1 else v2).
assert (A4: eval_expr ge sp e m le a4 v4).
{ unfold a4, v4; destruct (zlt M Int64.half_modulus); auto. }
- exploit eval_shrlimm. eauto. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5).
- exploit eval_addl; auto; try apply HELPERS. eexact A5. eexact A3. intros (v6 & A6 & B6).
+ exploit eval_shrlimm. try apply HELPERS. eexact A4. instantiate (1 := Int.repr p). intros (v5 & A5 & B5).
+ exploit eval_addl. auto. eexact A5. eexact A3. intros (v6 & A6 & B6).
assert (RANGE: forall x, 0 <= x < 64 -> Int.ltu (Int.repr x) Int64.iwordsize' = true).
{ intros. unfold Int.ltu. rewrite Int.unsigned_repr. rewrite zlt_true by tauto. auto.
assert (64 < Int.max_unsigned) by (compute; auto). omega. }
@@ -947,8 +949,7 @@ Proof.
intros until y. unfold divf. destruct (divf_match b); intros.
- unfold divfimm. destruct (Float.exact_inverse n2) as [n2' | ] eqn:EINV.
+ inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
- EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
- simpl; eauto.
+ repeat (econstructor; eauto).
destruct x; simpl; auto. erewrite Float.div_mul_inverse; eauto.
+ apply eval_divf_base; trivial.
- apply eval_divf_base; trivial.
@@ -963,8 +964,7 @@ Proof.
intros until y. unfold divfs. destruct (divfs_match b); intros.
- unfold divfsimm. destruct (Float32.exact_inverse n2) as [n2' | ] eqn:EINV.
+ inv H0. inv H4. simpl in H6. inv H6. econstructor; split.
- EvalOp. constructor. eauto. constructor. EvalOp. simpl; eauto. constructor.
- simpl; eauto.
+ repeat (econstructor; eauto).
destruct x; simpl; auto. erewrite Float32.div_mul_inverse; eauto.
+ apply eval_divfs_base; trivial.
- apply eval_divfs_base; trivial.
diff --git a/backend/Selection.v b/backend/Selection.v
index 3b0948a8..4ab3331e 100644
--- a/backend/Selection.v
+++ b/backend/Selection.v
@@ -24,9 +24,9 @@
Require String.
Require Import Coqlib Maps.
-Require Import AST Errors Integers Globalenvs Switch.
+Require Import AST Errors Integers Globalenvs Builtins Switch.
Require Cminor.
-Require Import Op CminorSel OpHelpers.
+Require Import Op CminorSel OpHelpers Cminortyping.
Require Import SelectOp SplitLong SelectLong SelectDiv.
Require Machregs.
@@ -43,6 +43,12 @@ Function condexpr_of_expr (e: expr) : condexpr :=
| _ => CEcond (Ccompuimm Cne Int.zero) (e ::: Enil)
end.
+Function condition_of_expr (e: expr) : condition * exprlist :=
+ match e with
+ | Eop (Ocmp c) el => (c, el)
+ | _ => (Ccompuimm Cne Int.zero, e ::: Enil)
+ end.
+
(** Conversion of loads and stores *)
Definition load (chunk: memory_chunk) (e1: expr) :=
@@ -156,6 +162,13 @@ Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr :=
| Cminor.Ocmplu c => cmplu c arg1 arg2
end.
+Definition sel_select (ty: typ) (cnd ifso ifnot: expr) : expr :=
+ let (cond, args) := condition_of_expr cnd in
+ match SelectOp.select ty cond args ifso ifnot with
+ | Some a => a
+ | None => Econdition (condexpr_of_expr cnd) ifso ifnot
+ end.
+
(** Conversion from Cminor expression to Cminorsel expressions *)
Fixpoint sel_expr (a: Cminor.expr) : expr :=
@@ -173,6 +186,10 @@ Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist :=
| a :: bl => Econs (sel_expr a) (sel_exprlist bl)
end.
+Definition sel_select_opt (ty: typ) (arg1 arg2 arg3: Cminor.expr) : option expr :=
+ let (cond, args) := condition_of_expr (sel_expr arg1) in
+ SelectOp.select ty cond args (sel_expr arg2) (sel_expr arg3).
+
(** Recognition of immediate calls and calls to built-in functions
that should be inlined *)
@@ -221,6 +238,43 @@ Definition sel_builtin_res (optid: option ident) : builtin_res ident :=
| Some id => BR id
end.
+(** Known builtin functions *)
+
+Function sel_known_builtin (bf: builtin_function) (args: exprlist) :=
+ match bf, args with
+ | BI_platform b, _ =>
+ SelectOp.platform_builtin b args
+ | BI_standard (BI_select ty), a1 ::: a2 ::: a3 ::: Enil =>
+ Some (sel_select ty a1 a2 a3)
+ | BI_standard BI_fabs, a1 ::: Enil =>
+ Some (SelectOp.absf a1)
+ | _, _ =>
+ None
+ end.
+
+(** Builtin functions in general *)
+
+Definition sel_builtin_default (optid: option ident) (ef: external_function)
+ (args: list Cminor.expr) :=
+ Sbuiltin (sel_builtin_res optid) ef
+ (sel_builtin_args args (Machregs.builtin_constraints ef)).
+
+Definition sel_builtin (optid: option ident) (ef: external_function)
+ (args: list Cminor.expr) :=
+ match optid, ef with
+ | Some id, EF_builtin name sg =>
+ match lookup_builtin_function name sg with
+ | Some bf =>
+ match sel_known_builtin bf (sel_exprlist args) with
+ | Some a => Sassign id a
+ | None => sel_builtin_default optid ef args
+ end
+ | None => sel_builtin_default optid ef args
+ end
+ | _, _ =>
+ sel_builtin_default optid ef args
+ end.
+
(** Conversion of Cminor [switch] statements to decision trees. *)
Parameter compile_switch: Z -> nat -> table -> comptree.
@@ -267,72 +321,63 @@ Definition sel_switch_long :=
(fun arg ofs => subl arg (longconst (Int64.repr ofs)))
lowlong.
+(** "If conversion": conversion of certain if-then-else statements
+ into branchless conditional move instructions. *)
+
+(** Recognition of "then" and "else" statements that support if-conversion.
+ Basically we are interested in assignments to local variables [id = e].
+ However the front-end may have put [skip] statements around these
+ assignments. *)
+
+Inductive stmt_class : Type :=
+ | SCskip
+ | SCassign (id: ident) (a: Cminor.expr)
+ | SCother.
+
+Function classify_stmt (s: Cminor.stmt) : stmt_class :=
+ match s with
+ | Cminor.Sskip => SCskip
+ | Cminor.Sassign id a => SCassign id a
+ | Cminor.Sseq Cminor.Sskip s => classify_stmt s
+ | Cminor.Sseq s Cminor.Sskip => classify_stmt s
+ | _ => SCother
+ end.
-Definition sel_builtin_default optid ef args :=
- OK (Sbuiltin (sel_builtin_res optid) ef
- (sel_builtin_args args
- (Machregs.builtin_constraints ef))).
-
-Definition sel_builtin optid ef args :=
- match ef with
- | EF_builtin name sign =>
- (if String.string_dec name "__builtin_ternary_uint"
- || String.string_dec name "__builtin_ternary_int"
- then
- match optid with
- | None => OK Sskip
- | Some id =>
- match args with
- | a1::a2::a3::nil =>
- OK (Sassign id (select (sel_expr a3) (sel_expr a2) (sel_expr a1)))
- | _ => Error (msg "__builtin_ternary_(u)int: arguments")
- end
- end
- else
- if String.string_dec name "__builtin_ternary_ulong"
- || String.string_dec name "__builtin_ternary_long"
- then
- match optid with
- | None => OK Sskip
- | Some id =>
- match args with
- | a1::a2::a3::nil =>
- OK (Sassign id (selectl (sel_expr a3) (sel_expr a2) (sel_expr a1)))
- | _ => Error (msg "__builtin_ternary_(u)long: arguments")
- end
- end
- else
- if String.string_dec name "__builtin_ternary_double"
- then
- match optid with
- | None => OK Sskip
- | Some id =>
- match args with
- | a1::a2::a3::nil =>
- OK (Sassign id (selectf (sel_expr a3) (sel_expr a2) (sel_expr a1)))
- | _ => Error (msg "__builtin_ternary_double: arguments")
- end
- end
- else
- if String.string_dec name "__builtin_ternary_float"
- then
- match optid with
- | None => OK Sskip
- | Some id =>
- match args with
- | a1::a2::a3::nil =>
- OK (Sassign id (selectfs (sel_expr a3) (sel_expr a2) (sel_expr a1)))
- | _ => Error (msg "__builtin_ternary_float: arguments")
- end
- end
- else
- sel_builtin_default optid ef args)
- | _ => sel_builtin_default optid ef args
+(** External heuristic to limit the amount of if-conversion performed.
+ Arguments are: the condition, the "then" and the "else" expressions,
+ and the type at which selection is done. *)
+
+Parameter if_conversion_heuristic:
+ Cminor.expr -> Cminor.expr -> Cminor.expr -> AST.typ -> bool.
+
+Definition if_conversion_base
+ (ki: known_idents) (env: typenv)
+ (cond: Cminor.expr) (id: ident) (ifso ifnot: Cminor.expr) : option stmt :=
+ let ty := env id in
+ if is_known ki id
+ && safe_expr ki ifso && safe_expr ki ifnot
+ && if_conversion_heuristic cond ifso ifnot ty
+ then option_map
+ (fun sel => Sassign id sel)
+ (sel_select_opt ty cond ifso ifnot)
+ else None.
+
+Definition if_conversion
+ (ki: known_idents) (env: typenv)
+ (cond: Cminor.expr) (ifso ifnot: Cminor.stmt) : option stmt :=
+ match classify_stmt ifso, classify_stmt ifnot with
+ | SCskip, SCassign id a =>
+ if_conversion_base ki env cond id (Cminor.Evar id) a
+ | SCassign id a, SCskip =>
+ if_conversion_base ki env cond id a (Cminor.Evar id)
+ | SCassign id1 a1, SCassign id2 a2 =>
+ if ident_eq id1 id2 then if_conversion_base ki env cond id1 a1 a2 else None
+ | _, _ => None
end.
(** Conversion from Cminor statements to Cminorsel statements. *)
-Fixpoint sel_stmt (s: Cminor.stmt) : res stmt :=
+Fixpoint sel_stmt (ki: known_idents) (env: typenv) (s: Cminor.stmt) : res stmt :=
match s with
| Cminor.Sskip => OK Sskip
| Cminor.Sassign id e => OK (Sassign id (sel_expr e))
@@ -341,31 +386,29 @@ Fixpoint sel_stmt (s: Cminor.stmt) : res stmt :=
OK (match classify_call fn with
| Call_default => Scall optid sg (inl _ (sel_expr fn)) (sel_exprlist args)
| Call_imm id => Scall optid sg (inr _ id) (sel_exprlist args)
- | Call_builtin ef => (Sbuiltin (sel_builtin_res optid) ef
- (sel_builtin_args args
- (Machregs.builtin_constraints ef)))
- (* sel_builtin_default optid ef args *)
- (* THIS IS WHERE TO ACTIVATE OUR OWN BUILTINS
- change sel_builtin_default to sel_builtin *)
+ | Call_builtin ef => sel_builtin optid ef args
end)
| Cminor.Sbuiltin optid ef args =>
- OK (Sbuiltin (sel_builtin_res optid) ef
- (sel_builtin_args args (Machregs.builtin_constraints ef)))
+ OK (sel_builtin optid ef args)
| Cminor.Stailcall sg fn args =>
OK (match classify_call fn with
| Call_imm id => Stailcall sg (inr _ id) (sel_exprlist args)
| _ => Stailcall sg (inl _ (sel_expr fn)) (sel_exprlist args)
end)
| Cminor.Sseq s1 s2 =>
- do s1' <- sel_stmt s1; do s2' <- sel_stmt s2;
+ do s1' <- sel_stmt ki env s1; do s2' <- sel_stmt ki env s2;
OK (Sseq s1' s2')
| Cminor.Sifthenelse e ifso ifnot =>
- do ifso' <- sel_stmt ifso; do ifnot' <- sel_stmt ifnot;
- OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot')
+ match if_conversion ki env e ifso ifnot with
+ | Some s => OK s
+ | None =>
+ do ifso' <- sel_stmt ki env ifso; do ifnot' <- sel_stmt ki env ifnot;
+ OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot')
+ end
| Cminor.Sloop body =>
- do body' <- sel_stmt body; OK (Sloop body')
+ do body' <- sel_stmt ki env body; OK (Sloop body')
| Cminor.Sblock body =>
- do body' <- sel_stmt body; OK (Sblock body')
+ do body' <- sel_stmt ki env body; OK (Sblock body')
| Cminor.Sexit n => OK (Sexit n)
| Cminor.Sswitch false e cases dfl =>
let t := compile_switch Int.modulus dfl cases in
@@ -380,7 +423,7 @@ Fixpoint sel_stmt (s: Cminor.stmt) : res stmt :=
| Cminor.Sreturn None => OK (Sreturn None)
| Cminor.Sreturn (Some e) => OK (Sreturn (Some (sel_expr e)))
| Cminor.Slabel lbl body =>
- do body' <- sel_stmt body; OK (Slabel lbl body')
+ do body' <- sel_stmt ki env body; OK (Slabel lbl body')
| Cminor.Sgoto lbl => OK (Sgoto lbl)
end.
@@ -388,8 +431,15 @@ End SELECTION.
(** Conversion of functions. *)
+Definition known_id (f: Cminor.function) : known_idents :=
+ let add (ki: known_idents) (id: ident) := PTree.set id tt ki in
+ List.fold_left add f.(Cminor.fn_vars)
+ (List.fold_left add f.(Cminor.fn_params) (PTree.empty unit)).
+
Definition sel_function (dm: PTree.t globdef) (hf: helper_functions) (f: Cminor.function) : res function :=
- do body' <- sel_stmt dm f.(Cminor.fn_body);
+ let ki := known_id f in
+ do env <- Cminortyping.type_function f;
+ do body' <- sel_stmt dm ki env f.(Cminor.fn_body);
OK (mkfunction
f.(Cminor.fn_sig)
f.(Cminor.fn_params)
diff --git a/backend/Selectionaux.ml b/backend/Selectionaux.ml
new file mode 100644
index 00000000..26a79fd7
--- /dev/null
+++ b/backend/Selectionaux.ml
@@ -0,0 +1,115 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+open AST
+open Cminor
+
+(* Heuristics to guide if conversion *)
+
+(* Estimate a cost for evaluating a safe expression.
+ Unsafe operators need not be estimated.
+ Basic integer operations (add, and, ...) have cost 1 by convention.
+ The other costs are rough estimates. *)
+
+let cost_unop = function
+ | Ocast8unsigned | Ocast8signed
+ | Ocast16unsigned | Ocast16signed
+ | Onegint | Onotint -> 1
+ | Onegf | Oabsf -> 1
+ | Onegfs | Oabsfs -> 1
+ | Osingleoffloat | Ofloatofsingle -> 2
+ | Ointoffloat | Ointuoffloat
+ | Ofloatofint | Ofloatofintu
+ | Ointofsingle | Ointuofsingle
+ | Osingleofint | Osingleofintu -> assert false
+ | Onegl | Onotl -> if Archi.splitlong then 2 else 1
+ | Ointoflong | Olongofint | Olongofintu -> 1
+ | Olongoffloat | Olonguoffloat
+ | Ofloatoflong | Ofloatoflongu
+ | Olongofsingle | Olonguofsingle
+ | Osingleoflong | Osingleoflongu -> assert false
+
+let cost_binop = function
+ | Oadd | Osub -> 1
+ | Omul -> 2
+ | Odiv | Odivu | Omod | Omodu -> assert false
+ | Oand | Oor | Oxor | Oshl | Oshr | Oshru -> 1
+ | Oaddf | Osubf | Omulf -> 2
+ | Odivf -> 10
+ | Oaddfs| Osubfs| Omulfs -> 2
+ | Odivfs -> 10
+ | Oaddl | Osubl -> if Archi.splitlong then 3 else 1
+ | Omull -> if Archi.splitlong then 6 else 2
+ | Odivl | Odivlu | Omodl | Omodlu -> assert false
+ | Oandl | Oorl | Oxorl -> if Archi.splitlong then 2 else 1
+ | Oshll | Oshrl | Oshrlu -> if Archi.splitlong then 4 else 1
+ | Ocmp _ | Ocmpu _ -> 2
+ | Ocmpf _ | Ocmpfs _ -> 2
+ | Ocmpl _ | Ocmplu _ -> assert false
+
+let rec cost_expr = function
+ | Evar _ -> 0
+ | Econst _ -> 1
+ | Eunop(op, e1) -> cost_unop op + cost_expr e1
+ | Ebinop(op, e1, e2) -> cost_binop op + cost_expr e1 + cost_expr e2
+ | Eload(_, e1) -> assert false
+
+(* Does the target architecture support an efficient "conditional move"
+ at the given type? *)
+
+let fast_cmove ty =
+ match Configuration.arch, Configuration.model with
+ | "aarch64", _ ->
+ (match ty with Tint | Tlong | Tfloat | Tsingle -> true | _ -> false)
+ | "arm", _ ->
+ (match ty with Tint | Tfloat | Tsingle -> true | _ -> false)
+ | "powerpc", "e5500" ->
+ (match ty with Tint | Tlong -> true | _ -> false)
+ | "powerpc", _ -> false
+ | "riscV", _ -> false
+ | "x86", _ ->
+ (match ty with Tint -> true | Tlong -> Archi.ptr64 | _ -> false)
+ | "mppa_k1c", _ -> true
+ | a, m -> failwith (Printf.sprintf "fast_cmove: unknown arch %s %s" a m)
+
+(* The if-conversion heuristic depend on the
+ -fif-conversion and -Obranchless flags.
+
+With [-fno-if-conversion] or [-0O], if-conversion is turned off entirely.
+With [-Obranchless], if-conversion is performed whenever semantically
+correct, regardless of how much it could cost.
+Otherwise (and by default), optimization is performed when it seems beneficial.
+
+If-conversion seems beneficial if:
+- the target architecture supports an efficient "conditional move" instruction
+ (not an emulation that takes several instructions)
+- the total cost the "then" and "else" branches is not too high
+- the cost difference between the "then" and "else" branches is low enough.
+
+Intuition: on a modern processor, the "then" and the "else" branches
+can generally be computed in parallel, there is enough ILP for that.
+So, the bad case is if the most taken branch is much cheaper than the
+other branch. Another bad case is if both branches are big: since the
+code for one branch precedes entirely the code for the other branch,
+if the first branch contains a lot of instructions,
+dynamic reordering of instructions will not look ahead far enough
+to execute instructions from the other branch in parallel with
+instructions from the first branch.
+*)
+
+let if_conversion_heuristic cond ifso ifnot ty =
+ if not !Clflags.option_fifconversion then false else
+ if !Clflags.option_Obranchless then true else
+ if not (fast_cmove ty) then false else
+ let c1 = cost_expr ifso and c2 = cost_expr ifnot in
+ c1 + c2 <= 24 && abs (c1 - c2) <= 8
+
diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v
index 23d10382..aa53c9cb 100644
--- a/backend/Selectionproof.v
+++ b/backend/Selectionproof.v
@@ -14,8 +14,9 @@
Require Import FunInd.
Require Import Coqlib Maps.
-Require Import AST Linking Errors Integers Values Memory Events Globalenvs Smallstep.
-Require Import Switch Cminor Op CminorSel.
+Require Import AST Linking Errors Integers.
+Require Import Values Memory Builtins Events Globalenvs Smallstep.
+Require Import Switch Cminor Op CminorSel Cminortyping.
Require Import OpHelpers OpHelpersproof.
Require Import SelectOp SelectDiv SplitLong SelectLong Selection.
Require Import SelectOpproof SelectDivproof SplitLongproof SelectLongproof.
@@ -120,6 +121,16 @@ Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
Hypothesis TRANSF: match_prog prog tprog.
+Lemma wt_prog : wt_program prog.
+Proof.
+ red; intros. destruct TRANSF as [A _].
+ exploit list_forall2_in_left; eauto.
+ intros ((i' & gd') & B & (C & D)). simpl in *. inv D.
+ destruct H2 as (hf & P & Q). destruct f; monadInv Q.
+- monadInv EQ. econstructor; apply type_function_sound; eauto.
+- constructor.
+Qed.
+
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof (Genv.find_symbol_match TRANSF).
@@ -203,6 +214,22 @@ Proof.
simpl. inv H0. auto.
Qed.
+Lemma eval_condition_of_expr:
+ forall a le v b,
+ eval_expr tge sp e m le a v ->
+ Val.bool_of_val v b ->
+ exists vl,
+ eval_exprlist tge sp e m le (snd (condition_of_expr a)) vl
+ /\ eval_condition (fst (condition_of_expr a)) vl m = Some b.
+Proof.
+ intros a; functional induction (condition_of_expr a); intros; simpl.
+- inv H. exists vl; split; auto.
+ simpl in H6. inv H6. apply Val.bool_of_val_of_optbool in H0. auto.
+- exists (v :: nil); split.
+ constructor; auto; constructor.
+ inv H0; simpl; auto.
+Qed.
+
Lemma eval_load:
forall le a v chunk v',
eval_expr tge sp e m le a v ->
@@ -325,6 +352,52 @@ Proof.
exists v; split; auto. eapply eval_cmplu; eauto.
Qed.
+Lemma eval_sel_select:
+ forall le a1 a2 a3 v1 v2 v3 b ty,
+ eval_expr tge sp e m le a1 v1 ->
+ eval_expr tge sp e m le a2 v2 ->
+ eval_expr tge sp e m le a3 v3 ->
+ Val.bool_of_val v1 b ->
+ exists v, eval_expr tge sp e m le (sel_select ty a1 a2 a3) v
+ /\ Val.lessdef (Val.select (Some b) v2 v3 ty) v.
+Proof.
+ unfold sel_select; intros.
+ specialize (eval_condition_of_expr _ _ _ _ H H2).
+ destruct (condition_of_expr a1) as [cond args]; simpl fst; simpl snd. intros (vl & A & B).
+ destruct (select ty cond args a2 a3) as [a|] eqn:SEL.
+- eapply eval_select; eauto.
+- exists (if b then v2 else v3); split.
+ econstructor; eauto. eapply eval_condexpr_of_expr; eauto. destruct b; auto.
+ apply Val.lessdef_normalize.
+Qed.
+
+(** Known built-in functions *)
+
+Lemma eval_sel_known_builtin:
+ forall bf args a vl v le,
+ sel_known_builtin bf args = Some a ->
+ eval_exprlist tge sp e m le args vl ->
+ builtin_function_sem bf vl = Some v ->
+ exists v', eval_expr tge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros until le; intros SEL ARGS SEM.
+ destruct bf as [bf|bf]; simpl in SEL.
+- destruct bf; try discriminate.
++ (* select *)
+ inv ARGS; try discriminate. inv H0; try discriminate. inv H2; try discriminate. inv H3; try discriminate.
+ inv SEL.
+ simpl in SEM. destruct v1; inv SEM.
+ replace (Val.normalize (if Int.eq i Int.zero then v2 else v0) t)
+ with (Val.select (Some (negb (Int.eq i Int.zero))) v0 v2 t)
+ by (destruct (Int.eq i Int.zero); reflexivity).
+ eapply eval_sel_select; eauto. constructor.
++ (* fabs *)
+ inv ARGS; try discriminate. inv H0; try discriminate.
+ inv SEL.
+ simpl in SEM; inv SEM. apply eval_absf; auto.
+- eapply eval_platform_builtin; eauto.
+Qed.
+
End CMCONSTR.
(** Recognition of calls to built-in functions *)
@@ -461,7 +534,7 @@ Qed.
End SEL_SWITCH.
-Section SEL_SWITH_INT.
+Section SEL_SWITCH_INT.
Variable cunit: Cminor.program.
Variable hf: helper_functions.
@@ -507,7 +580,7 @@ Proof.
unfold Int.sub. rewrite Int.unsigned_repr_eq. f_equal. f_equal.
apply Int.unsigned_repr. unfold Int.max_unsigned; omega.
- intros until i0; intros EVAL R. exists v; split; auto.
- inv R. rewrite Zmod_small by (apply Int.unsigned_range). constructor.
+ inv R. rewrite Z.mod_small by (apply Int.unsigned_range). constructor.
- constructor.
- apply Int.unsigned_range.
Qed.
@@ -548,7 +621,7 @@ Proof.
- apply Int64.unsigned_range.
Qed.
-End SEL_SWITH_INT.
+End SEL_SWITCH_INT.
(** Compatibility of evaluation functions with the "less defined than" relation. *)
@@ -699,6 +772,29 @@ Proof.
exists (v1' :: vl'); split; auto. constructor; eauto.
Qed.
+Lemma sel_select_opt_correct:
+ forall ty cond a1 a2 a sp e m vcond v1 v2 b e' m' le,
+ sel_select_opt ty cond a1 a2 = Some a ->
+ Cminor.eval_expr ge sp e m cond vcond ->
+ Cminor.eval_expr ge sp e m a1 v1 ->
+ Cminor.eval_expr ge sp e m a2 v2 ->
+ Val.bool_of_val vcond b ->
+ env_lessdef e e' -> Mem.extends m m' ->
+ exists v', eval_expr tge sp e' m' le a v' /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v'.
+Proof.
+ unfold sel_select_opt; intros.
+ destruct (condition_of_expr (sel_expr cond)) as [cnd args] eqn:C.
+ exploit sel_expr_correct. eexact H0. eauto. eauto. intros (vcond' & EVC & LDC).
+ exploit sel_expr_correct. eexact H1. eauto. eauto. intros (v1' & EV1 & LD1).
+ exploit sel_expr_correct. eexact H2. eauto. eauto. intros (v2' & EV2 & LD2).
+ assert (Val.bool_of_val vcond' b) by (inv H3; inv LDC; constructor).
+ exploit eval_condition_of_expr. eexact EVC. eauto. rewrite C. intros (vargs' & EVARGS & EVCOND).
+ exploit eval_select; eauto. intros (v' & X & Y).
+ exists v'; split; eauto.
+ eapply Val.lessdef_trans; [|eexact Y].
+ apply Val.select_lessdef; auto.
+Qed.
+
Lemma sel_builtin_arg_correct:
forall sp e e' m m' a v c,
env_lessdef e e' -> Mem.extends m m' ->
@@ -742,37 +838,219 @@ Proof.
intros. destruct oid; simpl; auto. apply set_var_lessdef; auto.
Qed.
+Lemma sel_builtin_default_correct:
+ forall optid ef al sp e1 m1 vl t v m2 e1' m1' f k,
+ Cminor.eval_exprlist ge sp e1 m1 al vl ->
+ external_call ef ge vl m1 t v m2 ->
+ env_lessdef e1 e1' -> Mem.extends m1 m1' ->
+ exists e2' m2',
+ step tge (State f (sel_builtin_default optid ef al) k sp e1' m1')
+ t (State f Sskip k sp e2' m2')
+ /\ env_lessdef (set_optvar optid v e1) e2'
+ /\ Mem.extends m2 m2'.
+Proof.
+ intros. unfold sel_builtin_default.
+ exploit sel_builtin_args_correct; eauto. intros (vl' & A & B).
+ exploit external_call_mem_extends; eauto. intros (v' & m2' & D & E & F & _).
+ econstructor; exists m2'; split.
+ econstructor. eexact A. eapply external_call_symbols_preserved. eexact senv_preserved. eexact D.
+ split; auto. apply sel_builtin_res_correct; auto.
+Qed.
+
+Lemma sel_builtin_correct:
+ forall optid ef al sp e1 m1 vl t v m2 e1' m1' f k,
+ Cminor.eval_exprlist ge sp e1 m1 al vl ->
+ external_call ef ge vl m1 t v m2 ->
+ env_lessdef e1 e1' -> Mem.extends m1 m1' ->
+ exists e2' m2',
+ step tge (State f (sel_builtin optid ef al) k sp e1' m1')
+ t (State f Sskip k sp e2' m2')
+ /\ env_lessdef (set_optvar optid v e1) e2'
+ /\ Mem.extends m2 m2'.
+Proof.
+ intros.
+ exploit sel_exprlist_correct; eauto. intros (vl' & A & B).
+ exploit external_call_mem_extends; eauto. intros (v' & m2' & D & E & F & _).
+ unfold sel_builtin.
+ destruct optid as [id|]; eauto using sel_builtin_default_correct.
+ destruct ef; eauto using sel_builtin_default_correct.
+ destruct (lookup_builtin_function name sg) as [bf|] eqn:LKUP; eauto using sel_builtin_default_correct.
+ destruct (sel_known_builtin bf (sel_exprlist al)) as [a|] eqn:SKB; eauto using sel_builtin_default_correct.
+ simpl in D. red in D. rewrite LKUP in D. inv D.
+ exploit eval_sel_known_builtin; eauto. intros (v'' & U & V).
+ econstructor; exists m2'; split.
+ econstructor. eexact U.
+ split; auto. apply set_var_lessdef; auto. apply Val.lessdef_trans with v'; auto.
+Qed.
+
+(** If-conversion *)
+
+Lemma classify_stmt_sound_1:
+ forall f sp e m s k,
+ classify_stmt s = SCskip ->
+ star Cminor.step ge (Cminor.State f s k sp e m) E0 (Cminor.State f Cminor.Sskip k sp e m).
+Proof.
+ intros until s; functional induction (classify_stmt s); intros; try discriminate.
+ - apply star_refl.
+ - eapply star_trans; eauto. eapply star_two. constructor. constructor.
+ traceEq. traceEq.
+ - eapply star_left. constructor.
+ eapply star_right. eauto. constructor.
+ traceEq. traceEq.
+Qed.
+
+Lemma classify_stmt_sound_2:
+ forall f sp e m a id v,
+ Cminor.eval_expr ge sp e m a v ->
+ forall s k,
+ classify_stmt s = SCassign id a ->
+ star Cminor.step ge (Cminor.State f s k sp e m) E0 (Cminor.State f Cminor.Sskip k sp (PTree.set id v e) m).
+Proof.
+ intros until s; functional induction (classify_stmt s); intros; try discriminate.
+ - inv H0. apply star_one. constructor; auto.
+ - eapply star_trans; eauto. eapply star_two. constructor. constructor.
+ traceEq. traceEq.
+ - eapply star_left. constructor.
+ eapply star_right. eauto. constructor.
+ traceEq. traceEq.
+Qed.
+
+Lemma classify_stmt_wt:
+ forall env tyret id a s,
+ classify_stmt s = SCassign id a ->
+ wt_stmt env tyret s ->
+ wt_expr env a (env id).
+Proof.
+ intros until s; functional induction (classify_stmt s); intros CL WT;
+ try discriminate.
+- inv CL; inv WT; auto.
+- inv WT; eauto.
+- inv WT; eauto.
+Qed.
+
+Lemma eval_select_safe_exprs:
+ forall a1 a2 f env ty e e' m m' sp cond vb b id s,
+ safe_expr (known_id f) a1 = true ->
+ safe_expr (known_id f) a2 = true ->
+ option_map (fun sel => Sassign id sel) (sel_select_opt ty cond a1 a2) = Some s ->
+ Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b ->
+ wt_expr env a1 ty ->
+ wt_expr env a2 ty ->
+ def_env f e -> wt_env env e ->
+ Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b ->
+ env_lessdef e e' -> Mem.extends m m' ->
+ exists a' v1 v2 v',
+ s = Sassign id a'
+ /\ Cminor.eval_expr ge sp e m a1 v1
+ /\ Cminor.eval_expr ge sp e m a2 v2
+ /\ eval_expr tge sp e' m' nil a' v'
+ /\ Val.lessdef (if b then v1 else v2) v'.
+Proof.
+ intros.
+ destruct (sel_select_opt ty cond a1 a2) as [a'|] eqn:SSO; simpl in H1; inv H1.
+ destruct (eval_safe_expr ge f sp e m a1) as (v1 & EV1); auto.
+ destruct (eval_safe_expr ge f sp e m a2) as (v2 & EV2); auto.
+ assert (TY1: Val.has_type v1 ty) by (eapply wt_eval_expr; eauto).
+ assert (TY2: Val.has_type v2 ty) by (eapply wt_eval_expr; eauto).
+ exploit sel_select_opt_correct; eauto. intros (v' & EV' & LD).
+ exists a', v1, v2, v'; intuition eauto.
+ apply Val.lessdef_trans with (Val.select (Some b) v1 v2 ty).
+ simpl. rewrite Val.normalize_idem; auto. destruct b; auto.
+ assumption.
+Qed.
+
+Lemma if_conversion_correct:
+ forall f env tyret cond ifso ifnot s vb b k f' k' sp e m e' m',
+ if_conversion (known_id f) env cond ifso ifnot = Some s ->
+ def_env f e -> wt_env env e ->
+ wt_stmt env tyret ifso ->
+ wt_stmt env tyret ifnot ->
+ Cminor.eval_expr ge sp e m cond vb -> Val.bool_of_val vb b ->
+ env_lessdef e e' -> Mem.extends m m' ->
+ let s0 := if b then ifso else ifnot in
+ exists e1 e1',
+ step tge (State f' s k' sp e' m') E0 (State f' Sskip k' sp e1' m')
+ /\ star Cminor.step ge (Cminor.State f s0 k sp e m) E0 (Cminor.State f Cminor.Sskip k sp e1 m)
+ /\ env_lessdef e1 e1'.
+Proof.
+ unfold if_conversion; intros until m'; intros IFC DE WTE WT1 WT2 EVC BOV ELD MEXT.
+ set (s0 := if b then ifso else ifnot). set (ki := known_id f) in *.
+ destruct (classify_stmt ifso) eqn:IFSO; try discriminate;
+ destruct (classify_stmt ifnot) eqn:IFNOT; try discriminate;
+ unfold if_conversion_base in IFC.
+- destruct (is_known ki id && safe_expr ki (Cminor.Evar id) && safe_expr ki a
+ && if_conversion_heuristic cond (Cminor.Evar id) a (env id)) eqn:B; inv IFC.
+ InvBooleans.
+ exploit (eval_select_safe_exprs (Cminor.Evar id) a); eauto.
+ constructor. eapply classify_stmt_wt; eauto.
+ intros (a' & v1 & v2 & v' & A & B & C & D & E).
+ exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e').
+ split. subst s. constructor; auto.
+ split. unfold s0; destruct b.
+ rewrite PTree.gsident by (inv B; auto). apply classify_stmt_sound_1; auto.
+ eapply classify_stmt_sound_2; eauto.
+ apply set_var_lessdef; auto.
+- destruct (is_known ki id && safe_expr ki a && safe_expr ki (Cminor.Evar id)
+ && if_conversion_heuristic cond a (Cminor.Evar id) (env id)) eqn:B; inv IFC.
+ InvBooleans.
+ exploit (eval_select_safe_exprs a (Cminor.Evar id)); eauto.
+ eapply classify_stmt_wt; eauto. constructor.
+ intros (a' & v1 & v2 & v' & A & B & C & D & E).
+ exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e').
+ split. subst s. constructor; auto.
+ split. unfold s0; destruct b.
+ eapply classify_stmt_sound_2; eauto.
+ rewrite PTree.gsident by (inv C; auto). apply classify_stmt_sound_1; auto.
+ apply set_var_lessdef; auto.
+- destruct (ident_eq id id0); try discriminate. subst id0.
+ destruct (is_known ki id && safe_expr ki a && safe_expr ki a0
+ && if_conversion_heuristic cond a a0 (env id)) eqn:B; inv IFC.
+ InvBooleans.
+ exploit (eval_select_safe_exprs a a0); eauto.
+ eapply classify_stmt_wt; eauto. eapply classify_stmt_wt; eauto.
+ intros (a' & v1 & v2 & v' & A & B & C & D & E).
+ exists (PTree.set id (if b then v1 else v2) e), (PTree.set id v' e').
+ split. subst s. constructor; auto.
+ split. unfold s0; destruct b; eapply classify_stmt_sound_2; eauto.
+ apply set_var_lessdef; auto.
+Qed.
+
End EXPRESSIONS.
(** Semantic preservation for functions and statements. *)
-Inductive match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop :=
- | match_cont_stop: forall cunit hf,
- match_cont cunit hf Cminor.Kstop Kstop
- | match_cont_seq: forall cunit hf s s' k k',
- sel_stmt (prog_defmap cunit) s = OK s' ->
- match_cont cunit hf k k' ->
- match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k')
- | match_cont_block: forall cunit hf k k',
- match_cont cunit hf k k' ->
- match_cont cunit hf (Cminor.Kblock k) (Kblock k')
- | match_cont_call: forall cunit' hf' cunit hf id f sp e k f' e' k',
+Inductive match_cont: Cminor.program -> helper_functions -> known_idents -> typenv -> Cminor.cont -> CminorSel.cont -> Prop :=
+ | match_cont_seq: forall cunit hf ki env s s' k k',
+ sel_stmt (prog_defmap cunit) ki env s = OK s' ->
+ match_cont cunit hf ki env k k' ->
+ match_cont cunit hf ki env (Cminor.Kseq s k) (Kseq s' k')
+ | match_cont_block: forall cunit hf ki env k k',
+ match_cont cunit hf ki env k k' ->
+ match_cont cunit hf ki env (Cminor.Kblock k) (Kblock k')
+ | match_cont_other: forall cunit hf ki env k k',
+ match_call_cont k k' ->
+ match_cont cunit hf ki env k k'
+
+with match_call_cont: Cminor.cont -> CminorSel.cont -> Prop :=
+ | match_cont_stop:
+ match_call_cont Cminor.Kstop Kstop
+ | match_cont_call: forall cunit hf env id f sp e k f' e' k',
linkorder cunit prog ->
helper_functions_declared cunit hf ->
sel_function (prog_defmap cunit) hf f = OK f' ->
- match_cont cunit hf k k' -> env_lessdef e e' ->
- match_cont cunit' hf' (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k').
-
-Definition match_call_cont (k: Cminor.cont) (k': CminorSel.cont) : Prop :=
- forall cunit hf, match_cont cunit hf k k'.
+ type_function f = OK env ->
+ match_cont cunit hf (known_id f) env k k' ->
+ env_lessdef e e' ->
+ match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k').
Inductive match_states: Cminor.state -> CminorSel.state -> Prop :=
- | match_state: forall cunit hf f f' s k s' k' sp e m e' m'
+ | match_state: forall cunit hf f f' s k s' k' sp e m e' m' env
(LINK: linkorder cunit prog)
(HF: helper_functions_declared cunit hf)
(TF: sel_function (prog_defmap cunit) hf f = OK f')
- (TS: sel_stmt (prog_defmap cunit) s = OK s')
- (MC: match_cont cunit hf k k')
+ (TYF: type_function f = OK env)
+ (TS: sel_stmt (prog_defmap cunit) (known_id f) env s = OK s')
+ (MC: match_cont cunit hf (known_id f) env k k')
(LD: env_lessdef e e')
(ME: Mem.extends m m'),
match_states
@@ -794,48 +1072,49 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop :=
match_states
(Cminor.Returnstate v k m)
(Returnstate v' k' m')
- | match_builtin_1: forall cunit hf ef args args' optid f sp e k m al f' e' k' m'
+ | match_builtin_1: forall cunit hf ef args optid f sp e k m al f' e' k' m' env
(LINK: linkorder cunit prog)
(HF: helper_functions_declared cunit hf)
(TF: sel_function (prog_defmap cunit) hf f = OK f')
- (MC: match_cont cunit hf k k')
- (LDA: Val.lessdef_list args args')
+ (TYF: type_function f = OK env)
+ (MC: match_cont cunit hf (known_id f) env k k')
+ (EA: Cminor.eval_exprlist ge sp e m al args)
(LDE: env_lessdef e e')
- (ME: Mem.extends m m')
- (EA: list_forall2 (CminorSel.eval_builtin_arg tge sp e' m') al args'),
+ (ME: Mem.extends m m'),
match_states
(Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m)
- (State f' (Sbuiltin (sel_builtin_res optid) ef al) k' sp e' m')
- | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k'
+ (State f' (sel_builtin optid ef al) k' sp e' m')
+ | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' env
(LINK: linkorder cunit prog)
(HF: helper_functions_declared cunit hf)
(TF: sel_function (prog_defmap cunit) hf f = OK f')
- (MC: match_cont cunit hf k k')
+ (TYF: type_function f = OK env)
+ (MC: match_cont cunit hf (known_id f) env k k')
(LDV: Val.lessdef v v')
- (LDE: env_lessdef e e')
+ (LDE: env_lessdef (set_optvar optid v e) e')
(ME: Mem.extends m m'),
match_states
(Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m)
- (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m').
+ (State f' Sskip k' sp e' m').
Remark call_cont_commut:
- forall cunit hf k k', match_cont cunit hf k k' -> match_call_cont (Cminor.call_cont k) (call_cont k').
+ forall cunit hf ki env k k',
+ match_cont cunit hf ki env k k' -> match_call_cont (Cminor.call_cont k) (call_cont k').
Proof.
- induction 1; simpl; auto; red; intros.
-- constructor.
-- eapply match_cont_call with (hf := hf); eauto.
+ induction 1; simpl; auto. inversion H; subst; auto.
Qed.
Remark match_is_call_cont:
- forall cunit hf k k', match_cont cunit hf k k' -> Cminor.is_call_cont k -> match_call_cont k k'.
+ forall cunit hf ki env k k',
+ match_cont cunit ki env hf k k' -> Cminor.is_call_cont k ->
+ match_call_cont k k' /\ is_call_cont k'.
Proof.
- destruct 1; intros; try contradiction; red; intros.
-- constructor.
-- eapply match_cont_call with (hf := hf); eauto.
+ destruct 1; intros; try contradiction. split; auto. inv H; auto.
Qed.
+(*
Remark match_call_cont_cont:
- forall k k', match_call_cont k k' -> exists cunit hf, match_cont cunit hf k k'.
+ forall k k', match_call_cont k k' -> exists cunit hf ki env, match_cont cunit hf ki env k k'.
Proof.
intros. simple refine (let cunit : Cminor.program := _ in _).
econstructor. apply nil. apply nil. apply xH.
@@ -843,14 +1122,66 @@ Proof.
econstructor; apply xH.
exists cunit, hf; auto.
Qed.
+*)
+
+Definition nolabel (s: Cminor.stmt) : Prop :=
+ forall lbl k, Cminor.find_label lbl s k = None.
+Definition nolabel' (s: stmt) : Prop :=
+ forall lbl k, find_label lbl s k = None.
+
+Lemma classify_stmt_nolabel:
+ forall s, classify_stmt s <> SCother -> nolabel s.
+Proof.
+ intros s. functional induction (classify_stmt s); intros.
+- red; auto.
+- red; auto.
+- apply IHs0 in H. red; intros; simpl. apply H.
+- apply IHs0 in H. red; intros; simpl. rewrite H; auto.
+- congruence.
+Qed.
+
+Lemma if_conversion_base_nolabel: forall (hf: helper_functions) ki env a id a1 a2 s,
+ if_conversion_base ki env a id a1 a2 = Some s ->
+ nolabel' s.
+Proof.
+ unfold if_conversion_base; intros.
+ destruct (is_known ki id && safe_expr ki a1 && safe_expr ki a2 &&
+ if_conversion_heuristic a a1 a2 (env id)); try discriminate.
+ destruct (sel_select_opt (env id) a a1 a2); inv H.
+ red; auto.
+Qed.
+
+Lemma if_conversion_nolabel: forall (hf: helper_functions) ki env a s1 s2 s,
+ if_conversion ki env a s1 s2 = Some s ->
+ nolabel s1 /\ nolabel s2 /\ nolabel' s.
+Proof.
+ unfold if_conversion; intros.
+ Ltac conclude :=
+ split; [apply classify_stmt_nolabel;congruence
+ |split; [apply classify_stmt_nolabel;congruence
+ |eapply if_conversion_base_nolabel; eauto]].
+ destruct (classify_stmt s1) eqn:C1; try discriminate;
+ destruct (classify_stmt s2) eqn:C2; try discriminate.
+ conclude.
+ conclude.
+ destruct (ident_eq id id0). conclude. discriminate.
+Qed.
+
+Remark sel_builtin_nolabel:
+ forall (hf: helper_functions) optid ef args, nolabel' (sel_builtin optid ef args).
+Proof.
+ unfold sel_builtin; intros; red; intros.
+ destruct optid; auto. destruct ef; auto. destruct lookup_builtin_function; auto.
+ destruct sel_known_builtin; auto.
+Qed.
Remark find_label_commut:
- forall cunit hf lbl s k s' k',
- match_cont cunit hf k k' ->
- sel_stmt (prog_defmap cunit) s = OK s' ->
+ forall cunit hf ki env lbl s k s' k',
+ match_cont cunit hf ki env k k' ->
+ sel_stmt (prog_defmap cunit) ki env s = OK s' ->
match Cminor.find_label lbl s k, find_label lbl s' k' with
| None, None => True
- | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) s1 = OK s1' /\ match_cont cunit hf k1 k1'
+ | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) ki env s1 = OK s1' /\ match_cont cunit hf ki env k1 k1'
| _, _ => False
end.
Proof.
@@ -859,15 +1190,22 @@ Proof.
- unfold store. destruct (addressing m (sel_expr e)); simpl; auto.
(* call *)
- destruct (classify_call (prog_defmap cunit) e); simpl; auto.
+ rewrite sel_builtin_nolabel; auto.
(* tailcall *)
- destruct (classify_call (prog_defmap cunit) e); simpl; auto.
+(* builtin *)
+- rewrite sel_builtin_nolabel; auto.
(* seq *)
- exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. eauto.
destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ];
destruct (find_label lbl x (Kseq x0 k')) as [[sy ky] | ];
intuition. apply IHs2; auto.
(* ifthenelse *)
-- exploit (IHs1 k); eauto.
+- destruct (if_conversion ki env e s1 s2) as [s|] eqn:IFC.
+ inv SE. exploit if_conversion_nolabel; eauto. intros (A & B & C).
+ rewrite A, B, C. auto.
+ monadInv SE; simpl.
+ exploit (IHs1 k); eauto.
destruct (Cminor.find_label lbl s1 k) as [[sx kx] | ];
destruct (find_label lbl x k') as [[sy ky] | ];
intuition. apply IHs2; auto.
@@ -896,20 +1234,22 @@ Definition measure (s: Cminor.state) : nat :=
Lemma sel_step_correct:
forall S1 t S2, Cminor.step ge S1 t S2 ->
- forall T1, match_states S1 T1 ->
+ forall T1, match_states S1 T1 -> wt_state S1 ->
(exists T2, step tge T1 t T2 /\ match_states S2 T2)
- \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat.
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 T1)%nat
+ \/ (exists S3 T2, star Cminor.step ge S2 E0 S3 /\ step tge T1 t T2 /\ match_states S3 T2).
Proof.
- induction 1; intros T1 ME; inv ME; try (monadInv TS).
+ induction 1; intros T1 ME WTS; inv ME; try (monadInv TS).
- (* skip seq *)
inv MC. left; econstructor; split. econstructor. econstructor; eauto.
+ inv H.
- (* skip block *)
inv MC. left; econstructor; split. econstructor. econstructor; eauto.
+ inv H.
- (* skip call *)
exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
left; econstructor; split.
- econstructor. inv MC; simpl in H; simpl; auto.
- eauto.
+ econstructor. eapply match_is_call_cont; eauto.
erewrite stackspace_function_translated; eauto.
econstructor; eauto. eapply match_is_call_cont; eauto.
- (* assign *)
@@ -918,8 +1258,8 @@ Proof.
econstructor; eauto.
econstructor; eauto. apply set_var_lessdef; auto.
- (* store *)
- exploit sel_expr_correct. eauto. eauto. eexact H. eauto. eauto. intros [vaddr' [A B]].
- exploit sel_expr_correct. eauto. eauto. eexact H0. eauto. eauto. intros [v' [C D]].
+ exploit sel_expr_correct. try apply LINK. try apply HF. eexact H. eauto. eauto. intros [vaddr' [A B]].
+ exploit sel_expr_correct. try apply LINK. try apply HF. eexact H0. eauto. eauto. intros [v' [C D]].
exploit Mem.storev_extends; eauto. intros [m2' [P Q]].
left; econstructor; split.
eapply eval_store; eauto.
@@ -935,7 +1275,7 @@ Proof.
econstructor; eauto. econstructor; eauto.
eapply sig_function_translated; eauto.
eapply match_callstate with (cunit := cunit'); eauto.
- red; intros. eapply match_cont_call with (cunit := cunit) (hf := hf); eauto.
+ eapply match_cont_call with (cunit := cunit) (hf := hf); eauto.
+ (* direct *)
intros [b [U V]].
exploit sel_exprlist_correct; eauto. intros [vargs' [C D]].
@@ -945,12 +1285,10 @@ Proof.
subst vf. econstructor; eauto. rewrite symbols_preserved; eauto.
eapply sig_function_translated; eauto.
eapply match_callstate with (cunit := cunit'); eauto.
- red; intros; eapply match_cont_call with (cunit := cunit) (hf := hf); eauto.
+ eapply match_cont_call with (cunit := cunit) (hf := hf); eauto.
+ (* turned into Sbuiltin *)
intros EQ. subst fd.
- exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]].
- right; split. simpl. omega. split. auto.
- econstructor; eauto.
+ right; left; split. simpl; omega. split; auto. econstructor; eauto.
- (* Stailcall *)
exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]].
erewrite <- stackspace_function_translated in P by eauto.
@@ -967,18 +1305,20 @@ Proof.
eapply match_callstate with (cunit := cunit'); eauto.
eapply call_cont_commut; eauto.
- (* Sbuiltin *)
- exploit sel_builtin_args_correct; eauto. intros [vargs' [P Q]].
- exploit external_call_mem_extends; eauto.
- intros [vres' [m2 [A [B [C D]]]]].
- left; econstructor; split.
- econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- econstructor; eauto. apply sel_builtin_res_correct; auto.
+ exploit sel_builtin_correct; eauto. intros (e2' & m2' & P & Q & R).
+ left; econstructor; split. eexact P. econstructor; eauto.
- (* Seq *)
left; econstructor; split.
constructor.
econstructor; eauto. constructor; auto.
- (* Sifthenelse *)
- exploit sel_expr_correct; eauto. intros [v' [A B]].
+ simpl in TS. destruct (if_conversion (known_id f) env a s1 s2) as [s|] eqn:IFC; monadInv TS.
++ inv WTS. inv WT_FN. assert (env0 = env) by congruence. subst env0. inv WT_STMT.
+ exploit if_conversion_correct; eauto.
+ set (s0 := if b then s1 else s2). intros (e1 & e1' & A & B & C).
+ right; right. econstructor; econstructor.
+ split. eexact B. split. eexact A. econstructor; eauto.
++ exploit sel_expr_correct; eauto. intros [v' [A B]].
assert (Val.bool_of_val v' b). inv B. auto. inv H0.
left; exists (State f' (if b then x else x0) k' sp e' m'); split.
econstructor; eauto. eapply eval_condexpr_of_expr; eauto.
@@ -990,10 +1330,13 @@ Proof.
left; econstructor; split. constructor. econstructor; eauto. constructor; auto.
- (* Sexit seq *)
inv MC. left; econstructor; split. constructor. econstructor; eauto.
+ inv H.
- (* Sexit0 block *)
inv MC. left; econstructor; split. constructor. econstructor; eauto.
+ inv H.
- (* SexitS block *)
inv MC. left; econstructor; split. constructor. econstructor; eauto.
+ inv H.
- (* Sswitch *)
inv H0; simpl in TS.
+ set (ct := compile_switch Int.modulus default cases) in *.
@@ -1024,10 +1367,10 @@ Proof.
- (* Slabel *)
left; econstructor; split. constructor. econstructor; eauto.
- (* Sgoto *)
- assert (sel_stmt (prog_defmap cunit) (Cminor.fn_body f) = OK (fn_body f')).
- { monadInv TF; simpl; auto. }
- exploit (find_label_commut cunit hf lbl (Cminor.fn_body f) (Cminor.call_cont k)).
- eapply call_cont_commut; eauto. eauto.
+ assert (sel_stmt (prog_defmap cunit) (known_id f) env (Cminor.fn_body f) = OK (fn_body f')).
+ { monadInv TF; simpl. congruence. }
+ exploit (find_label_commut cunit hf (known_id f) env lbl (Cminor.fn_body f) (Cminor.call_cont k)).
+ apply match_cont_other. eapply call_cont_commut; eauto. eauto.
rewrite H.
destruct (find_label lbl (fn_body f') (call_cont k'0))
as [[s'' k'']|] eqn:?; intros; try contradiction.
@@ -1036,13 +1379,15 @@ Proof.
econstructor; eauto.
econstructor; eauto.
- (* internal function *)
- destruct TF as (hf & HF & TF). specialize (MC cunit hf).
+ destruct TF as (hf & HF & TF).
monadInv TF. generalize EQ; intros TF; monadInv TF.
exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
intros [m2' [A B]].
left; econstructor; split.
econstructor; simpl; eauto.
- econstructor; simpl; eauto. apply set_locals_lessdef. apply set_params_lessdef; auto.
+ econstructor; simpl; eauto.
+ apply match_cont_other; auto.
+ apply set_locals_lessdef. apply set_params_lessdef; auto.
- (* external call *)
destruct TF as (hf & HF & TF).
monadInv TF.
@@ -1052,20 +1397,15 @@ Proof.
econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved.
econstructor; eauto.
- (* external call turned into a Sbuiltin *)
- exploit external_call_mem_extends; eauto.
- intros [vres' [m2 [A [B [C D]]]]].
- left; econstructor; split.
- econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- econstructor; eauto.
+ exploit sel_builtin_correct; eauto. intros (e2' & m2' & P & Q & R).
+ left; econstructor; split. eexact P. econstructor; eauto.
- (* return *)
- apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC).
inv MC.
left; econstructor; split.
econstructor.
econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto.
- (* return of an external call turned into a Sbuiltin *)
- right; split. simpl; omega. split. auto. econstructor; eauto.
- apply sel_builtin_res_correct; auto.
+ right; left; split. simpl; omega. split. auto. econstructor; eauto.
Qed.
Lemma sel_initial_states:
@@ -1080,26 +1420,35 @@ Proof.
rewrite (match_program_main TRANSF). fold tge. rewrite symbols_preserved. eauto.
eexact A.
rewrite <- H2. eapply sig_function_translated; eauto.
- econstructor; eauto. red; intros; constructor. apply Mem.extends_refl.
+ econstructor; eauto. constructor. apply Mem.extends_refl.
Qed.
Lemma sel_final_states:
forall S R r,
match_states S R -> Cminor.final_state S r -> final_state R r.
Proof.
- intros. inv H0. inv H.
- apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC).
- inv MC. inv LD. constructor.
+ intros. inv H0. inv H. inv MC. inv LD. constructor.
Qed.
Theorem transf_program_correct:
forward_simulation (Cminor.semantics prog) (CminorSel.semantics tprog).
Proof.
- apply forward_simulation_opt with (match_states := match_states) (measure := measure).
- apply senv_preserved.
- apply sel_initial_states; auto.
- apply sel_final_states; auto.
- apply sel_step_correct; auto.
+ set (MS := fun S T => match_states S T /\ wt_state S).
+ apply forward_simulation_determ_star with (match_states := MS) (measure := measure).
+- apply Cminor.semantics_determinate.
+- apply senv_preserved.
+- intros. exploit sel_initial_states; eauto. intros (T & P & Q).
+ exists T; split; auto; split; auto. eapply wt_initial_state. eexact wt_prog. auto.
+- intros. destruct H. eapply sel_final_states; eauto.
+- intros S1 t S2 A T1 [B C].
+ assert (wt_state S2) by (eapply subject_reduction; eauto using wt_prog).
+ unfold MS.
+ exploit sel_step_correct; eauto.
+ intros [(T2 & D & E) | [(D & E & F) | (S3 & T2 & D & E & F)]].
++ exists S2, T2. intuition auto using star_refl, plus_one.
++ subst t. exists S2, T1. intuition auto using star_refl.
++ assert (wt_state S3) by (eapply subject_reduction_star; eauto using wt_prog).
+ exists S3, T2. intuition auto using plus_one.
Qed.
End PRESERVATION.
diff --git a/backend/SplitLongproof.v b/backend/SplitLongproof.v
index 6718ba5b..c8e3b94c 100644
--- a/backend/SplitLongproof.v
+++ b/backend/SplitLongproof.v
@@ -15,13 +15,16 @@
Require Import String.
Require Import Coqlib Maps.
Require Import AST Errors Integers Floats.
-Require Import Values Memory Globalenvs Events Cminor Op CminorSel.
+Require Import Values Memory Globalenvs Builtins Events Cminor Op CminorSel.
Require Import OpHelpers OpHelpersproof.
+Require Import Values Memory Globalenvs Builtins Events Cminor Op CminorSel.
Require Import SelectOp SelectOpproof SplitLong.
Local Open Scope cminorsel_scope.
Local Open Scope string_scope.
+(** * Properties of the helper functions *)
+
(** * Correctness of the instruction selection functions for 64-bit operators *)
Section CMCONSTR.
@@ -38,56 +41,64 @@ Ltac UseHelper := decompose [Logic.and] arith_helpers_correct; eauto.
Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto.
Lemma eval_helper:
- forall le id name sg args vargs vres,
+ forall bf le id name sg args vargs vres,
eval_exprlist ge sp e m le args vargs ->
helper_declared prog id name sg ->
- external_implements name sg vargs vres ->
+ lookup_builtin_function name sg = Some bf ->
+ builtin_function_sem bf vargs = Some vres ->
eval_expr ge sp e m le (Eexternal id sg args) vres.
Proof.
intros.
red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q).
rewrite <- Genv.find_funct_ptr_iff in Q.
- econstructor; eauto.
+ econstructor; eauto.
+ simpl. red. rewrite H1. constructor; auto.
Qed.
Corollary eval_helper_1:
- forall le id name sg arg1 varg1 vres,
+ forall bf le id name sg arg1 varg1 vres,
eval_expr ge sp e m le arg1 varg1 ->
helper_declared prog id name sg ->
- external_implements name sg (varg1::nil) vres ->
+ lookup_builtin_function name sg = Some bf ->
+ builtin_function_sem bf (varg1 :: nil) = Some vres ->
eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres.
Proof.
intros. eapply eval_helper; eauto. constructor; auto. constructor.
Qed.
Corollary eval_helper_2:
- forall le id name sg arg1 arg2 varg1 varg2 vres,
+ forall bf le id name sg arg1 arg2 varg1 varg2 vres,
eval_expr ge sp e m le arg1 varg1 ->
eval_expr ge sp e m le arg2 varg2 ->
helper_declared prog id name sg ->
- external_implements name sg (varg1::varg2::nil) vres ->
+ lookup_builtin_function name sg = Some bf ->
+ builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres ->
eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres.
Proof.
intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor.
Qed.
Remark eval_builtin_1:
- forall le id sg arg1 varg1 vres,
+ forall bf le id sg arg1 varg1 vres,
eval_expr ge sp e m le arg1 varg1 ->
- builtin_implements id sg (varg1::nil) vres ->
+ lookup_builtin_function id sg = Some bf ->
+ builtin_function_sem bf (varg1 :: nil) = Some vres ->
eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: Enil)) vres.
Proof.
- intros. econstructor. econstructor. eauto. constructor. apply H0.
+ intros. econstructor. econstructor. eauto. constructor.
+ simpl. red. rewrite H0. constructor. auto.
Qed.
Remark eval_builtin_2:
- forall le id sg arg1 arg2 varg1 varg2 vres,
+ forall bf le id sg arg1 arg2 varg1 varg2 vres,
eval_expr ge sp e m le arg1 varg1 ->
eval_expr ge sp e m le arg2 varg2 ->
- builtin_implements id sg (varg1::varg2::nil) vres ->
+ lookup_builtin_function id sg = Some bf ->
+ builtin_function_sem bf (varg1 :: varg2 :: nil) = Some vres ->
eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: arg2 ::: Enil)) vres.
Proof.
- intros. econstructor. constructor; eauto. constructor; eauto. constructor. apply H1.
+ intros. econstructor. constructor; eauto. constructor; eauto. constructor.
+ simpl. red. rewrite H1. constructor. auto.
Qed.
Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
@@ -336,9 +347,10 @@ Qed.
Theorem eval_negl: unary_constructor_sound negl Val.negl.
Proof.
unfold negl; red; intros. destruct (is_longconst a) eqn:E.
- econstructor; split. apply eval_longconst.
+- econstructor; split. apply eval_longconst.
exploit is_longconst_sound; eauto. intros EQ; subst x. simpl. auto.
- econstructor; split. eapply eval_builtin_1; eauto. UseHelper. auto.
+- exists (Val.negl x); split; auto.
+ eapply (eval_builtin_1 (BI_standard BI_negl)); eauto.
Qed.
Theorem eval_notl: unary_constructor_sound notl Val.notl.
@@ -360,7 +372,7 @@ Theorem eval_longoffloat:
exists v, eval_expr ge sp e m le (longoffloat a) v /\ Val.lessdef y v.
Proof.
intros; unfold longoffloat. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_dtos)); eauto. DeclHelper. auto. auto.
Qed.
Theorem eval_longuoffloat:
@@ -370,7 +382,7 @@ Theorem eval_longuoffloat:
exists v, eval_expr ge sp e m le (longuoffloat a) v /\ Val.lessdef y v.
Proof.
intros; unfold longuoffloat. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_dtou)); eauto. DeclHelper. auto. auto.
Qed.
Theorem eval_floatoflong:
@@ -379,8 +391,9 @@ Theorem eval_floatoflong:
Val.floatoflong x = Some y ->
exists v, eval_expr ge sp e m le (floatoflong a) v /\ Val.lessdef y v.
Proof.
- intros; unfold floatoflong. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ intros; unfold floatoflong. exists y; split; auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_stod)); eauto. DeclHelper. auto.
+ simpl. destruct x; simpl in H0; inv H0; auto.
Qed.
Theorem eval_floatoflongu:
@@ -389,8 +402,9 @@ Theorem eval_floatoflongu:
Val.floatoflongu x = Some y ->
exists v, eval_expr ge sp e m le (floatoflongu a) v /\ Val.lessdef y v.
Proof.
- intros; unfold floatoflongu. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ intros; unfold floatoflongu. exists y; split; auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_utod)); eauto. DeclHelper. auto.
+ simpl. destruct x; simpl in H0; inv H0; auto.
Qed.
Theorem eval_longofsingle:
@@ -427,8 +441,9 @@ Theorem eval_singleoflong:
Val.singleoflong x = Some y ->
exists v, eval_expr ge sp e m le (singleoflong a) v /\ Val.lessdef y v.
Proof.
- intros; unfold singleoflong. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ intros; unfold singleoflong. exists y; split; auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_stof)); eauto. DeclHelper. auto.
+ simpl. destruct x; simpl in H0; inv H0; auto.
Qed.
Theorem eval_singleoflongu:
@@ -437,8 +452,9 @@ Theorem eval_singleoflongu:
Val.singleoflongu x = Some y ->
exists v, eval_expr ge sp e m le (singleoflongu a) v /\ Val.lessdef y v.
Proof.
- intros; unfold singleoflongu. econstructor; split.
- eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
+ intros; unfold singleoflongu. exists y; split; auto.
+ eapply (eval_helper_1 (BI_standard BI_i64_utof)); eauto. DeclHelper. auto.
+ simpl. destruct x; simpl in H0; inv H0; auto.
Qed.
Theorem eval_andl: binary_constructor_sound andl Val.andl.
@@ -565,7 +581,9 @@ Proof.
simpl. erewrite <- Int64.decompose_shl_2. instantiate (1 := Int64.hiword i).
rewrite Int64.ofwords_recompose. auto. auto.
+ (* n >= 64 *)
- econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
+ econstructor; split.
+ eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity.
+ auto.
Qed.
Theorem eval_shll: binary_constructor_sound shll Val.shll.
@@ -576,7 +594,7 @@ Proof.
exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
eapply eval_shllimm; eauto.
- (* General case *)
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto.
Qed.
Lemma eval_shrluimm:
@@ -610,7 +628,9 @@ Proof.
simpl. erewrite <- Int64.decompose_shru_2. instantiate (1 := Int64.loword i).
rewrite Int64.ofwords_recompose. auto. auto.
+ (* n >= 64 *)
- econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
+ econstructor; split.
+ eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity.
+ auto.
Qed.
Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
@@ -621,7 +641,7 @@ Proof.
exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
eapply eval_shrluimm; eauto.
- (* General case *)
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto.
Qed.
Lemma eval_shrlimm:
@@ -659,7 +679,9 @@ Proof.
erewrite <- Int64.decompose_shr_2. instantiate (1 := Int64.loword i).
rewrite Int64.ofwords_recompose. auto. auto.
+ (* n >= 64 *)
- econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
+ econstructor; split.
+ eapply eval_helper_2; eauto. EvalOp. DeclHelper. reflexivity. reflexivity.
+ auto.
Qed.
Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
@@ -670,7 +692,7 @@ Proof.
exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
eapply eval_shrlimm; eauto.
- (* General case *)
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. reflexivity. auto.
Qed.
Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound addl Val.addl.
@@ -680,7 +702,7 @@ Proof.
assert (DEFAULT:
exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.addl x y) v).
{
- econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto.
+ econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto.
}
destruct (is_longconst a) as [p|] eqn:LC1;
destruct (is_longconst b) as [q|] eqn:LC2.
@@ -703,7 +725,7 @@ Proof.
assert (DEFAULT:
exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.subl x y) v).
{
- econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto.
+ econstructor; split. eapply eval_builtin_2; eauto. reflexivity. reflexivity. auto.
}
destruct (is_longconst a) as [p|] eqn:LC1;
destruct (is_longconst b) as [q|] eqn:LC2.
@@ -734,7 +756,7 @@ Proof.
exploit eval_add. eexact E2. eexact E3. intros [v5 [E5 L5]].
exploit eval_add. eexact E5. eexact E4. intros [v6 [E6 L6]].
exists (Val.longofwords v6 (Val.loword p)); split.
- EvalOp. eapply eval_builtin_2; eauto. UseHelper.
+ EvalOp. eapply eval_builtin_2; eauto. reflexivity. reflexivity.
intros. unfold le1, p in *; subst; simpl in *.
inv L3. inv L4. inv L5. simpl in L6. inv L6.
simpl. f_equal. symmetry. apply Int64.decompose_mul.
@@ -782,14 +804,14 @@ Theorem eval_mullhu:
forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
Proof.
unfold mullhu; intros; red; intros. econstructor; split; eauto.
- eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper.
+ eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity.
Qed.
Theorem eval_mullhs:
forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
Proof.
unfold mullhs; intros; red; intros. econstructor; split; eauto.
- eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper.
+ eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper. reflexivity. reflexivity.
Qed.
Theorem eval_shrxlimm:
@@ -831,7 +853,7 @@ Theorem eval_divlu_base:
exists v, eval_expr ge sp e m le (divlu_base a b) v /\ Val.lessdef z v.
Proof.
intros; unfold divlu_base.
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto.
Qed.
Theorem eval_modlu_base:
@@ -842,7 +864,7 @@ Theorem eval_modlu_base:
exists v, eval_expr ge sp e m le (modlu_base a b) v /\ Val.lessdef z v.
Proof.
intros; unfold modlu_base.
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto.
Qed.
Theorem eval_divls_base:
@@ -853,7 +875,7 @@ Theorem eval_divls_base:
exists v, eval_expr ge sp e m le (divls_base a b) v /\ Val.lessdef z v.
Proof.
intros; unfold divls_base.
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto.
Qed.
Theorem eval_modls_base:
@@ -864,7 +886,7 @@ Theorem eval_modls_base:
exists v, eval_expr ge sp e m le (modls_base a b) v /\ Val.lessdef z v.
Proof.
intros; unfold modls_base.
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. reflexivity. eassumption. auto.
Qed.
Remark decompose_cmpl_eq_zero:
diff --git a/backend/Splitting.ml b/backend/Splitting.ml
index 40f09c3d..3ca45c3b 100644
--- a/backend/Splitting.ml
+++ b/backend/Splitting.ml
@@ -151,8 +151,8 @@ let ren_instr f maps pc i =
| Inop s -> Inop s
| Iop(op, args, res, s) ->
Iop(op, ren_regs before args, ren_reg after res, s)
- | Iload(chunk, addr, args, dst, s) ->
- Iload(chunk, addr, ren_regs before args, ren_reg after dst, s)
+ | Iload(trap, chunk, addr, args, dst, s) ->
+ Iload(trap, chunk, addr, ren_regs before args, ren_reg after dst, s)
| Istore(chunk, addr, args, src, s) ->
Istore(chunk, addr, ren_regs before args, ren_reg before src, s)
| Icall(sg, ros, args, res, s) ->
@@ -162,8 +162,8 @@ let ren_instr f maps pc i =
| Ibuiltin(ef, args, res, s) ->
Ibuiltin(ef, List.map (AST.map_builtin_arg (ren_reg before)) args,
AST.map_builtin_res (ren_reg after) res, s)
- | Icond(cond, args, s1, s2) ->
- Icond(cond, ren_regs before args, s1, s2)
+ | Icond(cond, args, s1, s2, i) ->
+ Icond(cond, ren_regs before args, s1, s2, i)
| Ijumptable(arg, tbl) ->
Ijumptable(ren_reg before arg, tbl)
| Ireturn optarg ->
diff --git a/backend/Stacking.v b/backend/Stacking.v
index 7b382d05..0e3f2832 100644
--- a/backend/Stacking.v
+++ b/backend/Stacking.v
@@ -133,8 +133,8 @@ Definition transl_instr
end
| Lop op args res =>
Mop (transl_op fe op) args res :: k
- | Lload chunk addr args dst =>
- Mload chunk (transl_addr fe addr) args dst :: k
+ | Lload trap chunk addr args dst =>
+ Mload trap chunk (transl_addr fe addr) args dst :: k
| Lstore chunk addr args src =>
Mstore chunk (transl_addr fe addr) args src :: k
| Lcall sig ros =>
diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v
index 326fab61..d3fcdb91 100644
--- a/backend/Stackingproof.v
+++ b/backend/Stackingproof.v
@@ -1918,6 +1918,46 @@ Proof.
apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto.
apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto.
+- (* Lload notrap1*)
+ assert (eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = None) as Haddress.
+ eapply eval_addressing_inject_none; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ eapply agree_reglist; eauto.
+ econstructor; split.
+ apply plus_one. apply exec_Mload_notrap1.
+ rewrite <- Haddress. apply eval_addressing_preserved. exact symbols_preserved.
+ eauto. econstructor; eauto with coqlib.
+ apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto.
+ apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto.
+
+- (* Lload notrap2 *)
+ assert (exists a',
+ eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a'
+ /\ Val.inject j a a').
+ eapply eval_addressing_inject; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ eapply agree_reglist; eauto.
+ destruct H1 as [a' [A B]].
+
+ destruct ( Mem.loadv chunk m' a') as [v'|] eqn:Hloadv.
+ {
+ econstructor; split.
+ apply plus_one. apply exec_Mload with (a:=a') (v:=v'); eauto.
+ try (rewrite <- A; apply eval_addressing_preserved; auto; exact symbols_preserved).
+ econstructor; eauto with coqlib.
+ apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto.
+ apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto.
+ }
+ {
+ econstructor; split.
+ apply plus_one. apply exec_Mload_notrap2 with (a:=a'); eauto.
+ try (rewrite <- A; apply eval_addressing_preserved; auto; exact symbols_preserved).
+
+ econstructor; eauto with coqlib.
+ apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto.
+ apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto.
+ }
+
- (* Lstore *)
assert (exists a',
eval_addressing ge (Vptr sp' Ptrofs.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a'
diff --git a/backend/Tailcall.v b/backend/Tailcall.v
index 939abeea..b7a62d74 100644
--- a/backend/Tailcall.v
+++ b/backend/Tailcall.v
@@ -82,7 +82,7 @@ Definition transf_instr (f: function) (pc: node) (instr: instruction) :=
| Icall sig ros args res s =>
if is_return niter f s res
&& tailcall_is_possible sig
- && opt_typ_eq sig.(sig_res) f.(fn_sig).(sig_res)
+ && rettype_eq sig.(sig_res) f.(fn_sig).(sig_res)
then Itailcall sig ros args
else instr
| _ => instr
diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v
index 06e314f3..79a5c1cf 100644
--- a/backend/Tailcallproof.v
+++ b/backend/Tailcallproof.v
@@ -157,12 +157,10 @@ Lemma transf_instr_charact:
transf_instr_spec f instr (transf_instr f pc instr).
Proof.
intros. unfold transf_instr. destruct instr; try constructor.
- caseEq (is_return niter f n r && tailcall_is_possible s &&
- opt_typ_eq (sig_res s) (sig_res (fn_sig f))); intros.
- destruct (andb_prop _ _ H0). destruct (andb_prop _ _ H1).
- eapply transf_instr_tailcall; eauto.
- eapply is_return_charact; eauto.
- constructor.
+ destruct (is_return niter f n r && tailcall_is_possible s &&
+ rettype_eq (sig_res s) (sig_res (fn_sig f))) eqn:B.
+- InvBooleans. eapply transf_instr_tailcall; eauto. eapply is_return_charact; eauto.
+- constructor.
Qed.
Lemma transf_instr_lookup:
@@ -438,6 +436,43 @@ Proof.
apply eval_addressing_preserved. exact symbols_preserved. eauto.
econstructor; eauto. apply set_reg_lessdef; auto.
+- (* load notrap1 *)
+ TransfInstr.
+ assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
+ left.
+ exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- (default_notrap_load_value chunk)) m'); split.
+ eapply exec_Iload_notrap1.
+ eassumption.
+ eapply eval_addressing_lessdef_none. eassumption.
+ erewrite eval_addressing_preserved.
+ eassumption. exact symbols_preserved.
+
+ econstructor; eauto. apply set_reg_lessdef; auto.
+
+- (* load notrap2 *)
+ TransfInstr.
+ assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
+ left.
+
+ exploit eval_addressing_lessdef; eauto.
+ intros [a' [ADDR' ALD]].
+
+ destruct (Mem.loadv chunk m' a') eqn:Echunk2.
+ + exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- v) m'); split.
+ eapply exec_Iload with (a:=a'). eassumption.
+ erewrite eval_addressing_preserved.
+ eassumption.
+ exact symbols_preserved.
+ assumption.
+ econstructor; eauto. apply set_reg_lessdef; auto.
+ + exists (State s' (transf_function f) (Vptr sp0 Ptrofs.zero) pc' (rs'#dst <- (default_notrap_load_value chunk)) m'); split.
+ eapply exec_Iload_notrap2. eassumption.
+ erewrite eval_addressing_preserved.
+ eassumption.
+ exact symbols_preserved.
+ assumption.
+ econstructor; eauto. apply set_reg_lessdef; auto.
+
- (* store *)
TransfInstr.
assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto.
diff --git a/backend/Tunneling.v b/backend/Tunneling.v
index da1ce45a..a4c4a195 100644
--- a/backend/Tunneling.v
+++ b/backend/Tunneling.v
@@ -78,11 +78,11 @@ Definition record_gotos (f: LTL.function) : U.t :=
Definition tunnel_instr (uf: U.t) (i: instruction) : instruction :=
match i with
| Lbranch s => Lbranch (U.repr uf s)
- | Lcond cond args s1 s2 =>
+ | Lcond cond args s1 s2 info =>
let s1' := U.repr uf s1 in let s2' := U.repr uf s2 in
if peq s1' s2'
then Lbranch s1'
- else Lcond cond args s1' s2'
+ else Lcond cond args s1' s2' info
| Ljumptable arg tbl => Ljumptable arg (List.map (U.repr uf) tbl)
| _ => i
end.
diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v
index 4f95ac9b..d3b8a9f0 100644
--- a/backend/Tunnelingproof.v
+++ b/backend/Tunnelingproof.v
@@ -441,6 +441,31 @@ Proof.
rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved.
eauto. eauto.
econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef.
+- (* Lload notrap1 *)
+ exploit eval_addressing_lessdef_none. apply reglist_lessdef; eauto. eassumption.
+ left; simpl; econstructor; split.
+ eapply exec_Lload_notrap1.
+ rewrite <- H0.
+ apply eval_addressing_preserved. exact symbols_preserved. eauto.
+ econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef.
+- (* Lload notrap2 *)
+ exploit eval_addressing_lessdef. apply reglist_lessdef; eauto. eauto.
+ intros (ta & EV & LD).
+ destruct (Mem.loadv chunk tm ta) eqn:Htload.
+ {
+ left; simpl; econstructor; split.
+ eapply exec_Lload.
+ rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved.
+ exact Htload. eauto.
+ econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef.
+ }
+ {
+ left; simpl; econstructor; split.
+ eapply exec_Lload_notrap2.
+ rewrite <- EV. apply eval_addressing_preserved. exact symbols_preserved.
+ exact Htload. eauto.
+ econstructor; eauto using locmap_set_lessdef, locmap_undef_regs_lessdef.
+ }
- (* Lgetstack *)
left; simpl; econstructor; split.
econstructor; eauto.
diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v
index 916e111b..93ca7af4 100644
--- a/backend/Unusedglob.v
+++ b/backend/Unusedglob.v
@@ -46,14 +46,14 @@ Definition ref_instruction (i: instruction) : list ident :=
match i with
| Inop _ => nil
| Iop op _ _ _ => globals_operation op
- | Iload _ addr _ _ _ => globals_addressing addr
+ | Iload _ _ addr _ _ _ => globals_addressing addr
| Istore _ addr _ _ _ => globals_addressing addr
| Icall _ (inl r) _ _ _ => nil
| Icall _ (inr id) _ _ _ => id :: nil
| Itailcall _ (inl r) _ => nil
| Itailcall _ (inr id) _ => id :: nil
| Ibuiltin _ args _ _ => globals_of_builtin_args args
- | Icond cond _ _ _ => nil
+ | Icond cond _ _ _ _ => nil
| Ijumptable _ _ => nil
| Ireturn _ => nil
end.
@@ -107,7 +107,7 @@ Definition used_globals (p: program) (pm: prog_map) : option IS.t :=
(** * Elimination of unreferenced global definitions *)
-(** We also eliminate multiple definitions of the same global name, keeping ony
+(** We also eliminate multiple definitions of the same global name, keeping only
the last definition (in program definition order). *)
Fixpoint filter_globdefs (used: IS.t) (accu defs: list (ident * globdef fundef unit)) :=
diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v
index 7899a04c..fa120b6d 100644
--- a/backend/Unusedglobproof.v
+++ b/backend/Unusedglobproof.v
@@ -915,7 +915,7 @@ Proof.
/\ Val.inject j a ta).
{ apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args).
intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto.
- apply KEPT. red. exists pc, (Iload chunk addr args dst pc'); auto.
+ apply KEPT. red. exists pc, (Iload trap chunk addr args dst pc'); auto.
econstructor; eauto.
apply regs_inject; auto.
assumption. }
@@ -924,6 +924,36 @@ Proof.
econstructor; split. eapply exec_Iload; eauto.
econstructor; eauto. apply set_reg_inject; auto.
+- (* load notrap1 *)
+ assert (eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = None).
+ { eapply eval_addressing_inj_none.
+ intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto.
+ apply KEPT. red. exists pc, (Iload NOTRAP chunk addr args dst pc'); auto.
+ econstructor; eauto.
+ rewrite Ptrofs.add_zero; reflexivity.
+ apply regs_inject; auto.
+ eassumption.
+ assumption. }
+
+ econstructor; split. eapply exec_Iload_notrap1; eauto.
+ econstructor; eauto. apply set_reg_inject; auto.
+
+- (* load notrap2 *)
+ assert (A: exists ta,
+ eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta
+ /\ Val.inject j a ta).
+ { apply eval_addressing_inj with (ge1 := ge) (sp1 := Vptr sp0 Ptrofs.zero) (vl1 := rs##args).
+ intros. apply symbol_address_inject. eapply match_stacks_preserves_globals; eauto.
+ apply KEPT. red. exists pc, (Iload NOTRAP chunk addr args dst pc'); auto.
+ econstructor; eauto.
+ apply regs_inject; auto.
+ assumption. }
+ destruct A as (ta & B & C).
+ destruct (Mem.loadv chunk tm ta) eqn:Echunk2.
+ + econstructor; split. eapply exec_Iload; eauto.
+ econstructor; eauto. apply set_reg_inject; auto.
+ + econstructor; split. eapply exec_Iload_notrap2; eauto.
+ econstructor; eauto. apply set_reg_inject; auto.
- (* store *)
assert (A: exists ta,
eval_addressing tge (Vptr tsp Ptrofs.zero) addr trs##args = Some ta
@@ -1160,10 +1190,10 @@ Local Transparent Mem.loadbytes.
generalize (S1 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E1; inv E1.
generalize (S2 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E2; inv E2.
rewrite Z.add_0_r.
- apply Mem_getN_forall2 with (p := 0) (n := nat_of_Z (init_data_list_size (gvar_init v))).
+ apply Mem_getN_forall2 with (p := 0) (n := Z.to_nat (init_data_list_size (gvar_init v))).
rewrite H3, H4. apply bytes_of_init_inject. auto.
omega.
- rewrite nat_of_Z_eq by (apply init_data_list_size_pos). omega.
+ rewrite Z2Nat.id by (apply Z.ge_le; apply init_data_list_size_pos). omega.
Qed.
Lemma init_mem_inj_2:
@@ -1373,9 +1403,9 @@ Proof.
* apply Y with id; auto.
* exists gd1; auto.
* exists gd2; auto.
- * eapply used_not_defined_2 in GD1; eauto. eapply used_not_defined_2 in GD2; eauto.
+ * eapply used_not_defined_2 in GD1; [ | eauto | congruence ].
+ eapply used_not_defined_2 in GD2; [ | eauto | congruence ].
tauto.
- congruence.
}
destruct E as [g LD].
left. unfold prog_defs_names; simpl.
diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v
index 1f80c293..2e79d1a9 100644
--- a/backend/ValueAnalysis.v
+++ b/backend/ValueAnalysis.v
@@ -13,7 +13,7 @@
Require Import FunInd.
Require Import Coqlib Maps Integers Floats Lattice Kildall.
Require Import Compopts AST Linking.
-Require Import Values Memory Globalenvs Events.
+Require Import Values Memory Globalenvs Builtins Events.
Require Import Registers Op RTL.
Require Import ValueDomain ValueAOp Liveness.
@@ -78,6 +78,15 @@ Definition transfer_builtin_default
let (av, am') := analyze_call am (map (abuiltin_arg ae am rm) args) in
VA.State (set_builtin_res res av ae) am'.
+Definition eval_static_builtin_function
+ (ae: aenv) (am: amem) (rm: romem)
+ (bf: builtin_function) (args: list (builtin_arg reg)) :=
+ match builtin_function_sem bf
+ (map val_of_aval (map (abuiltin_arg ae am rm) args)) with
+ | Some v => aval_of_val v
+ | None => None
+ end.
+
Definition transfer_builtin
(ae: aenv) (am: amem) (rm: romem) (ef: external_function)
(args: list (builtin_arg reg)) (res: builtin_res reg) :=
@@ -105,6 +114,15 @@ Definition transfer_builtin
| EF_annot_val _ _ _, v :: nil =>
let av := abuiltin_arg ae am rm v in
VA.State (set_builtin_res res av ae) am
+ | EF_builtin name sg, _ =>
+ match lookup_builtin_function name sg with
+ | Some bf =>
+ match eval_static_builtin_function ae am rm bf args with
+ | Some av => VA.State (set_builtin_res res av ae) am
+ | None => transfer_builtin_default ae am rm args res
+ end
+ | None => transfer_builtin_default ae am rm args res
+ end
| _, _ =>
transfer_builtin_default ae am rm args res
end.
@@ -121,9 +139,14 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) :
| Some(Iop op args res s) =>
let a := eval_static_operation op (aregs ae args) in
VA.State (AE.set res a ae) am
- | Some(Iload chunk addr args dst s) =>
+ | Some(Iload TRAP chunk addr args dst s) =>
let a := loadv chunk rm am (eval_static_addressing addr (aregs ae args)) in
VA.State (AE.set dst a ae) am
+
+ (* TODO: maybe a case analysis on the results of loadv? *)
+
+ | Some(Iload NOTRAP chunk addr args dst s) =>
+ VA.State (AE.set dst Vtop ae) am
| Some(Istore chunk addr args src s) =>
let am' := storev chunk am (eval_static_addressing addr (aregs ae args)) (areg ae src) in
VA.State ae am'
@@ -133,7 +156,7 @@ Definition transfer (f: function) (rm: romem) (pc: node) (ae: aenv) (am: amem) :
VA.Bot
| Some(Ibuiltin ef args res s) =>
transfer_builtin ae am rm ef args res
- | Some(Icond cond args s1 s2) =>
+ | Some(Icond cond args s1 s2 _) =>
VA.State ae am
| Some(Ijumptable arg tbl) =>
VA.State ae am
@@ -372,6 +395,31 @@ Proof.
intros. destruct res; simpl; auto. apply ematch_update; auto.
Qed.
+Lemma eval_static_builtin_function_sound:
+ forall bc ge rs sp m ae rm am (bf: builtin_function) al vl v va,
+ ematch bc rs ae ->
+ romatch bc m rm ->
+ mmatch bc m am ->
+ genv_match bc ge ->
+ bc sp = BCstack ->
+ eval_builtin_args ge (fun r => rs#r) (Vptr sp Ptrofs.zero) m al vl ->
+ eval_static_builtin_function ae am rm bf al = Some va ->
+ builtin_function_sem bf vl = Some v ->
+ vmatch bc v va.
+Proof.
+ unfold eval_static_builtin_function; intros.
+ exploit abuiltin_args_sound; eauto.
+ set (vla := map (abuiltin_arg ae am rm) al) in *. intros VMA.
+ destruct (builtin_function_sem bf (map val_of_aval vla)) as [v0|] eqn:A; try discriminate.
+ assert (LD: Val.lessdef v0 v).
+ { apply val_inject_lessdef.
+ exploit (bs_inject _ (builtin_function_sem bf)).
+ apply val_inject_list_lessdef. eapply list_val_of_aval_sound; eauto.
+ rewrite A, H6; simpl. auto.
+ }
+ inv LD. apply aval_of_val_sound; auto. discriminate.
+Qed.
+
(** ** Constructing block classifications *)
Definition bc_nostack (bc: block_classification) : Prop :=
@@ -996,9 +1044,8 @@ Proof.
red; simpl; intros. destruct (plt b (Mem.nextblock m)).
exploit RO; eauto. intros (R & P & Q).
split; auto.
- split. apply bmatch_incr with bc; auto. apply bmatch_inv with m; auto.
- intros. eapply Mem.loadbytes_unchanged_on_1. eapply external_call_readonly; eauto.
- auto. intros; red. apply Q.
+ split. apply bmatch_incr with bc; auto. apply bmatch_ext with m; auto.
+ intros. eapply external_call_readonly with (m2 := m'); eauto.
intros; red; intros; elim (Q ofs).
eapply external_call_max_perm with (m2 := m'); eauto.
destruct (j' b); congruence.
@@ -1105,10 +1152,10 @@ Proof.
- constructor.
- assert (Plt sp bound') by eauto with va.
eapply sound_stack_public_call; eauto. apply IHsound_stack; intros.
- apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
+ apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto.
- assert (Plt sp bound') by eauto with va.
eapply sound_stack_private_call; eauto. apply IHsound_stack; intros.
- apply INV. xomega. rewrite SAME; auto. xomega. auto. auto.
+ apply INV. xomega. rewrite SAME; auto with ordered_type. xomega. auto. auto.
apply bmatch_ext with m; auto. intros. apply INV. xomega. auto. auto. auto.
Qed.
@@ -1225,11 +1272,29 @@ Proof.
apply ematch_update; auto. eapply eval_static_operation_sound; eauto with va.
- (* load *)
+ destruct trap.
+ + eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ apply ematch_update; auto. eapply loadv_sound; eauto with va.
+ eapply eval_static_addressing_sound; eauto with va.
+ + eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ apply ematch_update; auto.
+ eapply vmatch_top.
+ eapply loadv_sound; try eassumption.
+ eapply eval_static_addressing_sound; eauto with va.
+- (* load notrap1 *)
eapply sound_succ_state; eauto. simpl; auto.
unfold transfer; rewrite H. eauto.
- apply ematch_update; auto. eapply loadv_sound; eauto with va.
- eapply eval_static_addressing_sound; eauto with va.
-
+ apply ematch_update; auto.
+ unfold default_notrap_load_value.
+ constructor.
+- (* load notrap2 *)
+ eapply sound_succ_state; eauto. simpl; auto.
+ unfold transfer; rewrite H. eauto.
+ apply ematch_update; auto.
+ unfold default_notrap_load_value.
+ constructor.
- (* store *)
exploit eval_static_addressing_sound; eauto with va. intros VMADDR.
eapply sound_succ_state; eauto. simpl; auto.
@@ -1319,7 +1384,7 @@ Proof.
apply sound_stack_exten with bc.
apply sound_stack_inv with m. auto.
intros. apply Q. red. eapply Plt_trans; eauto.
- rewrite C; auto.
+ rewrite C; auto with ordered_type.
exact AA.
* (* public builtin call *)
exploit anonymize_stack; eauto.
@@ -1338,11 +1403,18 @@ Proof.
apply sound_stack_exten with bc.
apply sound_stack_inv with m. auto.
intros. apply Q. red. eapply Plt_trans; eauto.
- rewrite C; auto.
+ rewrite C; auto with ordered_type.
exact AA.
}
unfold transfer_builtin in TR.
destruct ef; auto.
++ (* builtin function *)
+ destruct (lookup_builtin_function name sg) as [bf|] eqn:LK; auto.
+ destruct (eval_static_builtin_function ae am rm bf args) as [av|] eqn:ES; auto.
+ simpl in H1. red in H1. rewrite LK in H1. inv H1.
+ eapply sound_succ_state; eauto. simpl; auto.
+ apply set_builtin_res_sound; auto.
+ eapply eval_static_builtin_function_sound; eauto.
+ (* volatile load *)
inv H0; auto. inv H3; auto. inv H1.
exploit abuiltin_arg_sound; eauto. intros VM1.
diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v
index e7e44e29..779e7bb9 100644
--- a/backend/ValueDomain.v
+++ b/backend/ValueDomain.v
@@ -11,9 +11,9 @@
(* *********************************************************************)
Require Import FunInd.
-Require Import Zwf Coqlib Maps Integers Floats Lattice.
+Require Import Zwf Coqlib Maps Zbits Integers Floats Lattice.
Require Import Compopts AST.
-Require Import Values Memory Globalenvs Events.
+Require Import Values Memory Globalenvs Builtins Events.
Require Import Registers RTL.
(** The abstract domains for value analysis *)
@@ -1492,12 +1492,12 @@ Proof.
inv H; auto with va.
- apply vmatch_uns. red; intros. rewrite Int.bits_rol by auto.
generalize (Int.unsigned_range n); intros.
- rewrite Zmod_small by omega.
+ rewrite Z.mod_small by omega.
apply H1. omega. omega.
- destruct (zlt n0 Int.zwordsize); auto with va.
apply vmatch_sgn. red; intros. rewrite ! Int.bits_rol by omega.
generalize (Int.unsigned_range n); intros.
- rewrite ! Zmod_small by omega.
+ rewrite ! Z.mod_small by omega.
rewrite H1 by omega. symmetry. rewrite H1 by omega. auto.
- destruct (zlt n0 Int.zwordsize); auto with va.
Qed.
@@ -1670,7 +1670,7 @@ Proof.
assert (UNS: forall i j, j <> Int.zero -> is_uns (usize j) (Int.modu i j)).
{
intros. apply is_uns_mon with (usize (Int.modu i j)); auto with va.
- unfold usize, Int.size. apply Int.Zsize_monotone.
+ unfold usize, Int.size. apply Zsize_monotone.
generalize (Int.unsigned_range_2 j); intros RANGE.
assert (Int.unsigned j <> 0).
{ red; intros; elim H. rewrite <- (Int.repr_unsigned j). rewrite H0. auto. }
@@ -2093,6 +2093,7 @@ Proof.
Qed.
Definition sign_ext (nbits: Z) (v: aval) :=
+ if zle nbits 0 then Uns (provenance v) 0 else
match v with
| I i => I (Int.sign_ext nbits i)
| Uns p n => if zlt n nbits then Uns p n else sgn p nbits
@@ -2101,20 +2102,39 @@ Definition sign_ext (nbits: Z) (v: aval) :=
end.
Lemma sign_ext_sound:
- forall nbits v x, 0 < nbits -> vmatch v x -> vmatch (Val.sign_ext nbits v) (sign_ext nbits x).
+ forall nbits v x, vmatch v x -> vmatch (Val.sign_ext nbits v) (sign_ext nbits x).
Proof.
assert (DFL: forall p nbits i, 0 < nbits -> vmatch (Vint (Int.sign_ext nbits i)) (sgn p nbits)).
{
intros. apply vmatch_sgn. apply is_sign_ext_sgn; auto with va.
}
- intros. inv H0; simpl; auto with va.
-- destruct (zlt n nbits); eauto with va.
+ intros. unfold sign_ext. destruct (zle nbits 0).
+- destruct v; simpl; auto with va. constructor. omega.
+ rewrite Int.sign_ext_below by auto. red; intros; apply Int.bits_zero.
+- inv H; simpl; auto with va.
++ destruct (zlt n nbits); eauto with va.
constructor; auto. eapply is_sign_ext_uns; eauto with va.
-- destruct (zlt n nbits); auto with va.
-- apply vmatch_sgn. apply is_sign_ext_sgn; auto with va.
++ destruct (zlt n nbits); auto with va.
++ apply vmatch_sgn. apply is_sign_ext_sgn; auto with va.
apply Z.min_case; auto with va.
Qed.
+Definition zero_ext_l (s: Z) := unop_long (Int64.zero_ext s).
+
+Lemma zero_ext_l_sound:
+ forall s v x, vmatch v x -> vmatch (Val.zero_ext_l s v) (zero_ext_l s x).
+Proof.
+ intros s. exact (unop_long_sound (Int64.zero_ext s)).
+Qed.
+
+Definition sign_ext_l (s: Z) := unop_long (Int64.sign_ext s).
+
+Lemma sign_ext_l_sound:
+ forall s v x, vmatch v x -> vmatch (Val.sign_ext_l s v) (sign_ext_l s x).
+Proof.
+ intros s. exact (unop_long_sound (Int64.sign_ext s)).
+Qed.
+
Definition longofint (v: aval) :=
match v with
| I i => L (Int64.repr (Int.signed i))
@@ -2824,6 +2844,64 @@ Proof.
intros. inv H; simpl in H0; congruence.
Qed.
+(** Select either returns one of its arguments, or Vundef. *)
+
+Definition add_undef (x: aval) :=
+ match x with
+ | Vbot => ntop
+ | I i =>
+ if Int.lt i Int.zero
+ then sgn Pbot (ssize i)
+ else uns Pbot (usize i)
+ | L _ | F _ | FS _ => ntop
+ | _ => x
+ end.
+
+Lemma add_undef_sound:
+ forall v x, vmatch v x -> vmatch v (add_undef x).
+Proof.
+ destruct 1; simpl; auto with va.
+ destruct (Int.lt i Int.zero).
+ apply vmatch_sgn; apply is_sgn_ssize.
+ apply vmatch_uns; apply is_uns_usize.
+Qed.
+
+Lemma add_undef_undef:
+ forall x, vmatch Vundef (add_undef x).
+Proof.
+ destruct x; simpl; auto with va.
+ destruct (Int.lt n Int.zero); auto with va.
+Qed.
+
+Lemma add_undef_normalize:
+ forall v x ty, vmatch v x -> vmatch (Val.normalize v ty) (add_undef x).
+Proof.
+ intros. destruct (Val.lessdef_normalize v ty);
+ auto using add_undef_sound, add_undef_undef.
+Qed.
+
+Definition select (ab: abool) (x y: aval) :=
+ match ab with
+ | Bnone => ntop
+ | Just b | Maybe b => add_undef (if b then x else y)
+ | Btop => add_undef (vlub x y)
+ end.
+
+Lemma select_sound:
+ forall ob v w ab x y ty,
+ cmatch ob ab -> vmatch v x -> vmatch w y ->
+ vmatch (Val.select ob v w ty) (select ab x y).
+Proof.
+ unfold Val.select, select; intros. inv H.
+- auto with va.
+- apply add_undef_normalize; destruct b; auto.
+- apply add_undef_undef.
+- apply add_undef_normalize; destruct b; auto.
+- destruct ob as [b|].
++ apply add_undef_normalize. destruct b; [apply vmatch_lub_l|apply vmatch_lub_r]; auto.
++ apply add_undef_undef.
+Qed.
+
(** Normalization at load time *)
Definition vnormalize (chunk: memory_chunk) (v: aval) :=
@@ -2980,7 +3058,47 @@ Proof with (auto using provenance_monotone with va).
- destruct (zlt n 16)...
Qed.
-(** Abstracting memory blocks *)
+(** Analysis of known builtin functions. All we have is a dynamic semantics
+ as a function [list val -> option val], but we can still perform
+ some constant propagation. *)
+
+Definition val_of_aval (a: aval) : val :=
+ match a with
+ | I n => Vint n
+ | L n => Vlong n
+ | F f => Vfloat f
+ | FS f => Vsingle f
+ | _ => Vundef
+ end.
+
+Definition aval_of_val (v: val) : option aval :=
+ match v with
+ | Vint n => Some (I n)
+ | Vlong n => Some (L n)
+ | Vfloat f => Some (F f)
+ | Vsingle f => Some (FS f)
+ | _ => None
+ end.
+
+Lemma val_of_aval_sound:
+ forall v a, vmatch v a -> Val.lessdef (val_of_aval a) v.
+Proof.
+ destruct 1; simpl; auto.
+Qed.
+
+Corollary list_val_of_aval_sound:
+ forall vl al, list_forall2 vmatch vl al -> Val.lessdef_list (map val_of_aval al) vl.
+Proof.
+ induction 1; simpl; constructor; auto using val_of_aval_sound.
+Qed.
+
+Lemma aval_of_val_sound:
+ forall v a, aval_of_val v = Some a -> vmatch v a.
+Proof.
+ intros v a E; destruct v; simpl in E; inv E; constructor.
+Qed.
+
+(** * Abstracting memory blocks *)
Inductive acontent : Type :=
| ACval (chunk: memory_chunk) (av: aval).
@@ -3134,7 +3252,7 @@ Proof.
omega.
intros (bytes1 & bytes2 & LOAD1 & LOAD2 & CONCAT).
subst bytes.
- exploit Mem.loadbytes_length. eexact LOAD1. change (nat_of_Z 1) with 1%nat. intros LENGTH1.
+ exploit Mem.loadbytes_length. eexact LOAD1. change (Z.to_nat 1) with 1%nat. intros LENGTH1.
rewrite in_app_iff in IN. destruct IN.
* destruct bytes1; try discriminate. destruct bytes1; try discriminate.
simpl in H. destruct H; try contradiction. subst m0.
@@ -3384,11 +3502,6 @@ Proof.
- omegaContradiction.
Qed.
-Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8.
-Proof.
- destruct chunk; simpl; omega.
-Qed.
-
Remark inval_before_contents:
forall i c chunk' av' j,
(inval_before i (i - 7) c)##j = Some (ACval chunk' av') ->
@@ -3492,7 +3605,7 @@ Qed.
Lemma ablock_storebytes_sound:
forall m b ofs bytes m' p ab sz,
Mem.storebytes m b ofs bytes = Some m' ->
- length bytes = nat_of_Z sz ->
+ length bytes = Z.to_nat sz ->
(forall b' ofs' q i, In (Fragment (Vptr b' ofs') q i) bytes -> pmatch b' ofs' p) ->
bmatch m b ab ->
bmatch m' b (ablock_storebytes ab p ofs sz).
@@ -3509,7 +3622,7 @@ Proof.
exploit ablock_storebytes_contents; eauto. intros [A B].
assert (Mem.load chunk' m b ofs' = Some v').
{ rewrite <- LOAD'; symmetry. eapply Mem.load_storebytes_other; eauto.
- rewrite U. rewrite LENGTH. rewrite nat_of_Z_max. right; omega. }
+ rewrite U. rewrite LENGTH. rewrite Z_to_nat_max. right; omega. }
exploit BM2; eauto. unfold ablock_load. rewrite A. rewrite COMPAT. auto.
Qed.
@@ -3992,7 +4105,7 @@ Theorem storebytes_sound:
Mem.storebytes m b (Ptrofs.unsigned ofs) bytes = Some m' ->
mmatch m am ->
pmatch b ofs p ->
- length bytes = nat_of_Z sz ->
+ length bytes = Z.to_nat sz ->
(forall b' ofs' qt i, In (Fragment (Vptr b' ofs') qt i) bytes -> pmatch b' ofs' q) ->
mmatch m' (storebytes am p sz q).
Proof.
@@ -4614,6 +4727,7 @@ Hint Resolve cnot_sound symbol_address_sound
negfs_sound absfs_sound
addfs_sound subfs_sound mulfs_sound divfs_sound
zero_ext_sound sign_ext_sound longofint_sound longofintu_sound
+ zero_ext_l_sound sign_ext_l_sound
singleoffloat_sound floatofsingle_sound
intoffloat_sound intuoffloat_sound floatofint_sound floatofintu_sound
intofsingle_sound intuofsingle_sound singleofint_sound singleofintu_sound
diff --git a/backend/XTL.ml b/backend/XTL.ml
index f10efeed..1d8e89c0 100644
--- a/backend/XTL.ml
+++ b/backend/XTL.ml
@@ -30,13 +30,13 @@ type instruction =
| Xspill of var * var
| Xparmove of var list * var list * var * var
| Xop of operation * var list * var
- | Xload of memory_chunk * addressing * var list * var
+ | Xload of trapping_mode * memory_chunk * addressing * var list * var
| Xstore of memory_chunk * addressing * var list * var
| Xcall of signature * (var, ident) sum * var list * var list
| Xtailcall of signature * (var, ident) sum * var list
| Xbuiltin of external_function * var builtin_arg list * var builtin_res
| Xbranch of node
- | Xcond of condition * var list * node * node
+ | Xcond of condition * var list * node * node * bool option
| Xjumptable of var * node list
| Xreturn of var list
@@ -105,7 +105,7 @@ let twin_reg r =
let rec successors_block = function
| Xbranch s :: _ -> [s]
| Xtailcall(sg, vos, args) :: _ -> []
- | Xcond(cond, args, s1, s2) :: _ -> [s1; s2]
+ | Xcond(cond, args, s1, s2, _) :: _ -> [s1; s2]
| Xjumptable(arg, tbl) :: _ -> tbl
| Xreturn _:: _ -> []
| instr :: blk -> successors_block blk
@@ -159,7 +159,7 @@ let type_instr = function
let (targs, tres) = type_of_operation op in
set_vars_type args targs;
set_var_type res tres
- | Xload(chunk, addr, args, dst) ->
+ | Xload(trap, chunk, addr, args, dst) ->
set_vars_type args (type_of_addressing addr);
set_var_type dst (type_of_chunk chunk)
| Xstore(chunk, addr, args, src) ->
@@ -179,7 +179,7 @@ let type_instr = function
type_builtin_res res (proj_sig_res sg)
| Xbranch s ->
()
- | Xcond(cond, args, s1, s2) ->
+ | Xcond(cond, args, s1, s2, _) ->
set_vars_type args (type_of_condition cond)
| Xjumptable(arg, tbl) ->
set_var_type arg Tint
diff --git a/backend/XTL.mli b/backend/XTL.mli
index 54988d4b..7b7f7186 100644
--- a/backend/XTL.mli
+++ b/backend/XTL.mli
@@ -31,13 +31,13 @@ type instruction =
| Xspill of var * var
| Xparmove of var list * var list * var * var
| Xop of operation * var list * var
- | Xload of memory_chunk * addressing * var list * var
+ | Xload of trapping_mode * memory_chunk * addressing * var list * var
| Xstore of memory_chunk * addressing * var list * var
| Xcall of signature * (var, ident) sum * var list * var list
| Xtailcall of signature * (var, ident) sum * var list
| Xbuiltin of external_function * var builtin_arg list * var builtin_res
| Xbranch of node
- | Xcond of condition * var list * node * node
+ | Xcond of condition * var list * node * node * bool option
| Xjumptable of var * node list
| Xreturn of var list
diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml
index 0f2e3674..bc5173ca 100644
--- a/cfrontend/C2C.ml
+++ b/cfrontend/C2C.ml
@@ -33,6 +33,7 @@ type inline_status =
type atom_info =
{ a_storage: C.storage; (* storage class *)
+ a_size: int64 option; (* size in bytes *)
a_alignment: int option; (* alignment *)
a_sections: Sections.section_name list; (* in which section to put it *)
(* 1 section for data, 3 sections (code/lit/jumptbl) for functions *)
@@ -61,15 +62,25 @@ let atom_alignof a =
with Not_found ->
None
+let atom_is_aligned a sz =
+ match atom_alignof a with
+ | None -> false
+ | Some align -> align mod (Z.to_int sz) = 0
+
let atom_sections a =
try
(Hashtbl.find decl_atom a).a_sections
with Not_found ->
[]
-let atom_is_small_data a ofs =
+let atom_is_small_data a ofs =
try
- (Hashtbl.find decl_atom a).a_access = Sections.Access_near
+ let info = Hashtbl.find decl_atom a in
+ info.a_access = Sections.Access_near
+ && (match info.a_size with
+ | None -> false
+ | Some sz ->
+ let ofs = camlint64_of_ptrofs ofs in 0L <= ofs && ofs < sz)
with Not_found ->
false
@@ -109,7 +120,7 @@ let atom_location a =
let comp_env : composite_env ref = ref Maps.PTree.empty
-(** Hooks -- overriden in machine-dependent CPragmas module *)
+(** Hooks -- overridden in machine-dependent CPragmas module *)
let process_pragma_hook = ref (fun (_: string) -> false)
@@ -153,19 +164,17 @@ let ais_annot_functions =
true);]
else
[]
-
-let builtin_ternary suffix typ =
- ("__builtin_ternary_" ^ suffix),
- (typ, [TInt(IInt, []); typ; typ], false);;
let builtins_generic = {
- Builtins.typedefs = [];
- Builtins.functions =
+ builtin_typedefs = [];
+ builtin_functions =
ais_annot_functions
@
[
(* Integer arithmetic *)
- "__builtin_bswap",
+ "__builtin_bswap64",
+ (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
+ "__builtin_bswap",
(TInt(IUInt, []), [TInt(IUInt, [])], false);
"__builtin_bswap32",
(TInt(IUInt, []), [TInt(IUInt, [])], false);
@@ -184,15 +193,12 @@ let builtins_generic = {
TPtr(TVoid [AConst], []);
TInt(IULong, []);
TInt(IULong, [])],
- false);
- (* Ternary operator *)
- builtin_ternary "uint" (TInt(IUInt, []));
- builtin_ternary "ulong" (TInt(IULong, []));
- builtin_ternary "int" (TInt(IInt, []));
- builtin_ternary "long" (TInt(ILong, []));
- builtin_ternary "double" (TFloat(FDouble, []));
- builtin_ternary "float" (TFloat(FFloat, []));
-
+ false);
+ (* Selection *)
+ "__builtin_sel",
+ (TVoid [],
+ [TInt(C.IBool, [])],
+ true);
(* Annotations *)
"__builtin_annot",
(TVoid [],
@@ -336,9 +342,12 @@ let builtins_generic = {
(* Add processor-dependent builtins *)
-let builtins =
- Builtins.({ typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs;
- functions = builtins_generic.Builtins.functions @ CBuiltins.builtins.functions })
+let builtins = {
+ builtin_typedefs =
+ builtins_generic.builtin_typedefs @ CBuiltins.builtins.builtin_typedefs;
+ builtin_functions =
+ builtins_generic.builtin_functions @ CBuiltins.builtins.builtin_functions
+}
(** ** The known attributes *)
@@ -373,6 +382,7 @@ let name_for_string_literal s =
Hashtbl.add decl_atom id
{ a_storage = C.Storage_static;
a_alignment = Some 1;
+ a_size = Some (Int64.of_int (String.length s + 1));
a_sections = [Sections.for_stringlit()];
a_access = Sections.Access_default;
a_inline = No_specifier;
@@ -400,9 +410,12 @@ let name_for_wide_string_literal s =
incr stringNum;
let name = Printf.sprintf "__stringlit_%d" !stringNum in
let id = intern_string name in
+ let wchar_size = Machine.((!config).sizeof_wchar) in
Hashtbl.add decl_atom id
{ a_storage = C.Storage_static;
- a_alignment = Some Machine.((!config).sizeof_wchar);
+ a_alignment = Some wchar_size;
+ a_size = Some (Int64.(mul (of_int (List.length s + 1))
+ (of_int wchar_size)));
a_sections = [Sections.for_stringlit()];
a_access = Sections.Access_default;
a_inline = No_specifier;
@@ -632,6 +645,12 @@ and convertParams env = function
| [] -> Tnil
| (id, ty) :: rem -> Tcons(convertTyp env ty, convertParams env rem)
+(* Convert types for the arguments to a function call. The types for
+ fixed arguments are taken from the function prototype. The types
+ for other arguments (variable-argument function or unprototyped K&R
+ functions) are taken from the types of the function arguments,
+ after default argument conversion. *)
+
let rec convertTypArgs env tl el =
match tl, el with
| _, [] -> Tnil
@@ -641,6 +660,20 @@ let rec convertTypArgs env tl el =
| (id, t1) :: tl, e1 :: el ->
Tcons(convertTyp env t1, convertTypArgs env tl el)
+(* Convert types for the arguments to inline asm statements and to
+ the special built-in functions __builtin_annot, __builtin_ais_annot_
+ and __builtin_debug. The types are taken from the types of the
+ arguments, after performing the usual unary conversions.
+ Hence char becomes int but float remains float and is not promoted
+ to double. The goal is to preserve the representation of the arguments
+ and avoid inserting compiled code to convert the arguments. *)
+
+let rec convertTypAnnotArgs env = function
+ | [] -> Tnil
+ | e1 :: el ->
+ Tcons(convertTyp env (Cutil.unary_conversion env e1.etyp),
+ convertTypAnnotArgs env el)
+
let convertField env f =
if f.fld_bitfield <> None then
unsupported "bit field in struct or union (consider adding option [-fbitfields])";
@@ -703,12 +736,12 @@ let z_of_str hex str fst =
let checkFloatOverflow f typ =
match f with
- | Fappli_IEEE.B754_finite _ -> ()
- | Fappli_IEEE.B754_zero _ ->
+ | Binary.B754_finite _ -> ()
+ | Binary.B754_zero _ ->
warning Diagnostics.Literal_range "magnitude of floating-point constant too small for type '%s'" typ
- | Fappli_IEEE.B754_infinity _ ->
+ | Binary.B754_infinity _ ->
warning Diagnostics.Literal_range "magnitude of floating-point constant too large for type '%s'" typ
- | Fappli_IEEE.B754_nan _ ->
+ | Binary.B754_nan _ ->
warning Diagnostics.Literal_range "floating-point converts converts to 'NaN'"
let convertFloat f kind =
@@ -881,7 +914,7 @@ let rec convertExpr env e =
| {edesc = C.EVar id} :: args2 -> (id.name, args2)
| _::args2 -> error "argument 2 of '__builtin_debug' must be either a string literal or a variable"; ("", args2)
| [] -> assert false (* catched earlier *) in
- let targs2 = convertTypArgs env [] args2 in
+ let targs2 = convertTypAnnotArgs env args2 in
Ebuiltin(
AST.EF_debug(P.of_int64 kind, intern_string text,
typlist_of_typelist targs2),
@@ -890,7 +923,7 @@ let rec convertExpr env e =
| C.ECall({edesc = C.EVar {name = "__builtin_annot"}}, args) ->
begin match args with
| {edesc = C.EConst(CStr txt)} :: args1 ->
- let targs1 = convertTypArgs env [] args1 in
+ let targs1 = convertTypAnnotArgs env args1 in
Ebuiltin(
AST.EF_annot(P.of_int 1,coqstring_of_camlstring txt, typlist_of_typelist targs1),
targs1, convertExprList env args1, convertTyp env e.etyp)
@@ -918,7 +951,7 @@ let rec convertExpr env e =
let file,line = !currentLocation in
let fun_name = !currentFunction in
let loc_string = Printf.sprintf "# file:%s line:%d function:%s\n" file line fun_name in
- let targs1 = convertTypArgs env [] args1 in
+ let targs1 = convertTypAnnotArgs env args1 in
AisAnnot.validate_ais_annot env !currentLocation txt args1;
Ebuiltin(
AST.EF_annot(P.of_int 2,coqstring_of_camlstring (loc_string ^ txt), typlist_of_typelist targs1),
@@ -954,6 +987,10 @@ let rec convertExpr env e =
Econs(va_list_ptr dst, Econs(va_list_ptr src, Enil)),
Tvoid)
+ | C.ECall({edesc = C.EVar {name = "__builtin_sel"}}, [arg1; arg2; arg3]) ->
+ ewrap (Ctyping.eselection (convertExpr env arg1)
+ (convertExpr env arg2) (convertExpr env arg3))
+
| C.ECall({edesc = C.EVar {name = "printf"}}, args)
when !Clflags.option_interp ->
let targs = convertTypArgs env [] args
@@ -1019,14 +1056,14 @@ let convertAsm loc env txt outputs inputs clobber =
match output' with None -> TVoid [] | Some e -> e.etyp in
(* Build the Ebuiltin expression *)
let e =
- let tinputs = convertTypArgs env [] inputs' in
+ let tinputs = convertTypAnnotArgs env inputs' in
let toutput = convertTyp env ty_res in
Ebuiltin( AST.EF_inline_asm(coqstring_of_camlstring txt',
signature_of_type tinputs toutput AST.cc_default,
clobber'),
tinputs,
convertExprList env inputs',
- convertTyp env ty_res) in
+ toutput) in
(* Add an assignment to the output, if any *)
match output' with
| None -> e
@@ -1220,7 +1257,8 @@ let convertFundef loc env fd =
Hashtbl.add decl_atom id'
{ a_storage = fd.fd_storage;
a_alignment = None;
- a_sections = Sections.for_function env id' fd.fd_attrib;
+ a_size = None;
+ a_sections = Sections.for_function env loc id' fd.fd_attrib;
a_access = Sections.Access_default;
a_inline = inline;
a_loc = loc };
@@ -1257,7 +1295,7 @@ let convertFundecl env (sto, id, ty, optinit) =
then AST.EF_runtime(id'', sg)
else
if Str.string_match re_builtin id.name 0
- && List.mem_assoc id.name builtins.Builtins.functions
+ && List.mem_assoc id.name builtins.builtin_functions
then AST.EF_builtin(id'', sg)
else AST.EF_external(id'', sg) in
(id', AST.Gfun(Ctypes.External(ef, args, res, cconv)))
@@ -1305,7 +1343,7 @@ let convertGlobvar loc env (sto, id, ty, optinit) =
| Some i ->
convertInitializer env ty i in
let (section, access) =
- Sections.for_variable env id' ty (optinit <> None) in
+ Sections.for_variable env loc id' ty (optinit <> None) in
if Z.gt sz (Z.of_uint64 0xFFFF_FFFFL) then
error "'%s' is too big (%s bytes)"
id.name (Z.to_string sz);
@@ -1314,6 +1352,7 @@ let convertGlobvar loc env (sto, id, ty, optinit) =
Hashtbl.add decl_atom id'
{ a_storage = sto;
a_alignment = Some (Z.to_int al);
+ a_size = Some (Z.to_int64 sz);
a_sections = [section];
a_access = access;
a_inline = No_specifier;
@@ -1456,7 +1495,7 @@ let convertProgram p =
Hashtbl.clear decl_atom;
Hashtbl.clear stringTable;
Hashtbl.clear wstringTable;
- let p = cleanupGlobals (Builtins.declarations() @ p) in
+ let p = cleanupGlobals (Env.initial_declarations() @ p) in
try
let env = translEnv Env.empty p in
let typs = convertCompositedefs env [] p in
diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v
index 823d2542..b08c3ad7 100644
--- a/cfrontend/Cexec.v
+++ b/cfrontend/Cexec.v
@@ -16,7 +16,7 @@ Require Import FunInd.
Require Import Axioms Classical.
Require Import String Coqlib Decidableplus.
Require Import Errors Maps Integers Floats.
-Require Import AST Values Memory Events Globalenvs Determinism.
+Require Import AST Values Memory Events Globalenvs Builtins Determinism.
Require Import Ctypes Cop Csyntax Csem.
Require Cstrategy.
@@ -292,7 +292,6 @@ Remark check_assign_copy:
{ assign_copy_ok ty b ofs b' ofs' } + {~ assign_copy_ok ty b ofs b' ofs' }.
Proof with try (right; intuition omega).
intros. unfold assign_copy_ok.
- assert (alignof_blockcopy ge ty > 0) by apply alignof_blockcopy_pos.
destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs')); auto...
destruct (Zdivide_dec (alignof_blockcopy ge ty) (Ptrofs.unsigned ofs)); auto...
assert (Y: {b' <> b \/
@@ -461,6 +460,14 @@ Definition do_ef_free
check (zlt 0 (Ptrofs.unsigned sz));
do m' <- Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz);
Some(w, E0, Vundef, m')
+ | Vint n :: nil =>
+ if Int.eq_dec n Int.zero && negb Archi.ptr64
+ then Some(w, E0, Vundef, m)
+ else None
+ | Vlong n :: nil =>
+ if Int64.eq_dec n Int64.zero && Archi.ptr64
+ then Some(w, E0, Vundef, m)
+ else None
| _ => None
end.
@@ -502,12 +509,19 @@ Definition do_ef_debug (kind: positive) (text: ident) (targs: list typ)
(w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
Some(w, E0, Vundef, m).
+Definition do_builtin_or_external (name: string) (sg: signature)
+ (w: world) (vargs: list val) (m: mem) : option (world * trace * val * mem) :=
+ match lookup_builtin_function name sg with
+ | Some bf => match builtin_function_sem bf vargs with Some v => Some(w, E0, v, m) | None => None end
+ | None => do_external_function name sg ge w vargs m
+ end.
+
Definition do_external (ef: external_function):
world -> list val -> mem -> option (world * trace * val * mem) :=
match ef with
| EF_external name sg => do_external_function name sg ge
- | EF_builtin name sg => do_external_function name sg ge
- | EF_runtime name sg => do_external_function name sg ge
+ | EF_builtin name sg => do_builtin_or_external name sg
+ | EF_runtime name sg => do_builtin_or_external name sg
| EF_vload chunk => do_ef_volatile_load chunk
| EF_vstore chunk => do_ef_volatile_store chunk
| EF_malloc => do_ef_malloc
@@ -524,50 +538,65 @@ Lemma do_ef_external_sound:
do_external ef w vargs m = Some(w', t, vres, m') ->
external_call ef ge vargs m t vres m' /\ possible_trace w t w'.
Proof with try congruence.
+ intros until m'.
assert (SIZE: forall v sz, do_alloc_size v = Some sz -> v = Vptrofs sz).
{ intros until sz; unfold Vptrofs; destruct v; simpl; destruct Archi.ptr64 eqn:SF;
intros EQ; inv EQ; f_equal; symmetry; eauto with ptrofs. }
- intros until m'.
+ assert (BF_EX: forall name sg,
+ do_builtin_or_external name sg w vargs m = Some (w', t, vres, m') ->
+ builtin_or_external_sem name sg ge vargs m t vres m' /\ possible_trace w t w').
+ { unfold do_builtin_or_external, builtin_or_external_sem; intros.
+ destruct (lookup_builtin_function name sg ) as [bf|].
+ - destruct (builtin_function_sem bf vargs) as [vres1|] eqn:BF; inv H.
+ split. constructor; auto. constructor.
+ - eapply do_external_function_sound; eauto.
+ }
destruct ef; simpl.
-(* EF_external *)
- eapply do_external_function_sound; eauto.
-(* EF_builtin *)
+- (* EF_external *)
eapply do_external_function_sound; eauto.
-(* EF_runtime *)
- eapply do_external_function_sound; eauto.
-(* EF_vload *)
+- (* EF_builtin *)
+ eapply BF_EX; eauto.
+- (* EF_runtime *)
+ eapply BF_EX; eauto.
+- (* EF_vload *)
unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs...
mydestr. destruct p as [[w'' t''] v]; mydestr.
exploit do_volatile_load_sound; eauto. intuition. econstructor; eauto.
- auto.
-(* EF_vstore *)
+- (* EF_vstore *)
unfold do_ef_volatile_store. destruct vargs... destruct v... destruct vargs... destruct vargs...
mydestr. destruct p as [[w'' t''] m'']. mydestr.
exploit do_volatile_store_sound; eauto. intuition. econstructor; eauto.
- auto.
-(* EF_malloc *)
+- (* EF_malloc *)
unfold do_ef_malloc. destruct vargs... destruct vargs... mydestr.
destruct (Mem.alloc m (- size_chunk Mptr) (Ptrofs.unsigned i)) as [m1 b] eqn:?. mydestr.
split. apply SIZE in Heqo. subst v. econstructor; eauto. constructor.
-(* EF_free *)
- unfold do_ef_free. destruct vargs... destruct v... destruct vargs...
- mydestr. split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega. constructor.
-(* EF_memcpy *)
+- (* EF_free *)
+ unfold do_ef_free. destruct vargs... destruct v...
++ destruct vargs... mydestr; InvBooleans; subst i.
+ replace (Vint Int.zero) with Vnullptr. split; constructor.
+ apply negb_true_iff in H0. unfold Vnullptr; rewrite H0; auto.
++ destruct vargs... mydestr; InvBooleans; subst i.
+ replace (Vlong Int64.zero) with Vnullptr. split; constructor.
+ unfold Vnullptr; rewrite H0; auto.
++ destruct vargs... mydestr.
+ split. apply SIZE in Heqo0. econstructor; eauto. congruence. omega.
+ constructor.
+- (* EF_memcpy *)
unfold do_ef_memcpy. destruct vargs... destruct v... destruct vargs...
destruct v... destruct vargs... mydestr.
apply Decidable_sound in Heqb1. red in Heqb1.
split. econstructor; eauto; tauto. constructor.
-(* EF_annot *)
+- (* EF_annot *)
unfold do_ef_annot. mydestr.
split. constructor. apply list_eventval_of_val_sound; auto.
econstructor. constructor; eauto. constructor.
-(* EF_annot_val *)
+- (* EF_annot_val *)
unfold do_ef_annot_val. destruct vargs... destruct vargs... mydestr.
split. constructor. apply eventval_of_val_sound; auto.
econstructor. constructor; eauto. constructor.
-(* EF_inline_asm *)
+- (* EF_inline_asm *)
eapply do_inline_assembly_sound; eauto.
-(* EF_debug *)
+- (* EF_debug *)
unfold do_ef_debug. mydestr. split; constructor.
Qed.
@@ -576,42 +605,52 @@ Lemma do_ef_external_complete:
external_call ef ge vargs m t vres m' -> possible_trace w t w' ->
do_external ef w vargs m = Some(w', t, vres, m').
Proof.
+ intros.
assert (SIZE: forall n, do_alloc_size (Vptrofs n) = Some n).
{ unfold Vptrofs, do_alloc_size; intros; destruct Archi.ptr64 eqn:SF.
rewrite Ptrofs.of_int64_to_int64; auto.
rewrite Ptrofs.of_int_to_int; auto. }
- intros. destruct ef; simpl in *.
-(* EF_external *)
- eapply do_external_function_complete; eauto.
-(* EF_builtin *)
- eapply do_external_function_complete; eauto.
-(* EF_runtime *)
+ assert (BF_EX: forall name sg,
+ builtin_or_external_sem name sg ge vargs m t vres m' ->
+ do_builtin_or_external name sg w vargs m = Some (w', t, vres, m')).
+ { unfold do_builtin_or_external, builtin_or_external_sem; intros.
+ destruct (lookup_builtin_function name sg) as [bf|].
+ - inv H1. inv H0. rewrite H2. auto.
+ - eapply do_external_function_complete; eauto.
+ }
+ destruct ef; simpl in *.
+- (* EF_external *)
eapply do_external_function_complete; eauto.
-(* EF_vload *)
+- (* EF_builtin *)
+ eapply BF_EX; eauto.
+- (* EF_runtime *)
+ eapply BF_EX; eauto.
+- (* EF_vload *)
inv H; unfold do_ef_volatile_load.
exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto.
-(* EF_vstore *)
+- (* EF_vstore *)
inv H; unfold do_ef_volatile_store.
exploit do_volatile_store_complete; eauto. intros EQ; rewrite EQ; auto.
-(* EF_malloc *)
+- (* EF_malloc *)
inv H; unfold do_ef_malloc.
inv H0. erewrite SIZE by eauto. rewrite H1, H2. auto.
-(* EF_free *)
+- (* EF_free *)
inv H; unfold do_ef_free.
- inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega.
-(* EF_memcpy *)
++ inv H0. rewrite H1. erewrite SIZE by eauto. rewrite zlt_true. rewrite H3. auto. omega.
++ inv H0. unfold Vnullptr; destruct Archi.ptr64; auto.
+- (* EF_memcpy *)
inv H; unfold do_ef_memcpy.
inv H0. rewrite Decidable_complete. rewrite H7; rewrite H8; auto.
red. tauto.
-(* EF_annot *)
+- (* EF_annot *)
inv H; unfold do_ef_annot. inv H0. inv H6. inv H4.
rewrite (list_eventval_of_val_complete _ _ _ H1). auto.
-(* EF_annot_val *)
+- (* EF_annot_val *)
inv H; unfold do_ef_annot_val. inv H0. inv H6. inv H4.
rewrite (eventval_of_val_complete _ _ _ H1). auto.
-(* EF_inline_asm *)
+- (* EF_inline_asm *)
eapply do_inline_assembly_complete; eauto.
-(* EF_debug *)
+- (* EF_debug *)
inv H. inv H0. reflexivity.
Qed.
@@ -1100,8 +1139,8 @@ Proof.
induction 1; intros; constructor; eauto.
Qed.
-Hint Constructors context contextlist.
-Hint Resolve context_compose contextlist_compose.
+Local Hint Constructors context contextlist : core.
+Local Hint Resolve context_compose contextlist_compose : core.
Definition reduction_ok (k: kind) (a: expr) (m: mem) (rd: reduction) : Prop :=
match k, rd with
@@ -1667,8 +1706,9 @@ Proof.
change (In (f (C0, rd)) (map f res2)). apply in_map; auto.
Qed.
-Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval
- reducts_incl_incontext reducts_incl_incontext2_left reducts_incl_incontext2_right.
+Local Hint Resolve reducts_incl_val reducts_incl_loc reducts_incl_listval
+ reducts_incl_incontext reducts_incl_incontext2_left
+ reducts_incl_incontext2_right : core.
Lemma step_expr_context:
forall from to C, context from to C ->
@@ -2053,7 +2093,7 @@ Ltac myinv :=
| _ => idtac
end.
-Hint Extern 3 => exact I.
+Local Hint Extern 3 => exact I : core.
Theorem do_step_sound:
forall w S rule t S',
diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v
index 7a4c49a2..8ab29fe9 100644
--- a/cfrontend/Clight.v
+++ b/cfrontend/Clight.v
@@ -84,7 +84,7 @@ Definition typeof (e: expr) : type :=
(** ** Statements *)
(** Clight statements are similar to those of Compcert C, with the addition
- of assigment (of a rvalue to a lvalue), assignment to a temporary,
+ of assignment (of a rvalue to a lvalue), assignment to a temporary,
and function call (with assignment of the result to a temporary).
The three C loops are replaced by a single infinite loop [Sloop s1
s2] that executes [s1] then [s2] repeatedly. A [continue] in [s1]
diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v
index ffafc5d2..5acb996d 100644
--- a/cfrontend/Cminorgenproof.v
+++ b/cfrontend/Cminorgenproof.v
@@ -923,7 +923,7 @@ Remark inj_offset_aligned_block:
Mem.inj_offset_aligned (align stacksize (block_alignment sz)) sz.
Proof.
intros; red; intros.
- apply Zdivides_trans with (block_alignment sz).
+ apply Z.divide_trans with (block_alignment sz).
unfold align_chunk. unfold block_alignment.
generalize Z.divide_1_l; intro.
generalize Z.divide_refl; intro.
diff --git a/cfrontend/Cop.v b/cfrontend/Cop.v
index c395a2cb..143e87a3 100644
--- a/cfrontend/Cop.v
+++ b/cfrontend/Cop.v
@@ -140,8 +140,8 @@ Definition classify_cast (tfrom tto: type) : classify_cast_cases :=
| Tfloat F64 _, Tfloat F32 _ => cast_case_s2f
| Tfloat F32 _, Tfloat F64 _ => cast_case_f2s
(* To pointer types *)
- | Tpointer _ _, Tint _ _ _ =>
- if Archi.ptr64 then cast_case_i2l Unsigned else cast_case_pointer
+ | Tpointer _ _, Tint _ si _ =>
+ if Archi.ptr64 then cast_case_i2l si else cast_case_pointer
| Tpointer _ _, Tlong _ _ =>
if Archi.ptr64 then cast_case_pointer else cast_case_l2i I32 Unsigned
| Tpointer _ _, (Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _) => cast_case_pointer
@@ -1131,7 +1131,7 @@ Qed.
Remark val_inject_vptrofs: forall n, Val.inject f (Vptrofs n) (Vptrofs n).
Proof. intros. unfold Vptrofs. destruct Archi.ptr64; auto. Qed.
-Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool val_inject_vptrofs.
+Local Hint Resolve val_inject_vtrue val_inject_vfalse val_inject_of_bool val_inject_vptrofs : core.
Ltac TrivialInject :=
match goal with
@@ -1517,7 +1517,7 @@ Inductive val_casted: val -> type -> Prop :=
| val_casted_void: forall v,
val_casted v Tvoid.
-Hint Constructors val_casted.
+Local Hint Constructors val_casted : core.
Remark cast_int_int_idem:
forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i.
@@ -1580,6 +1580,27 @@ Proof.
intros. apply cast_val_casted. eapply cast_val_is_casted; eauto.
Qed.
+(** Moreover, casted values belong to the machine type corresponding to the
+ C type. *)
+
+Lemma val_casted_has_type:
+ forall v ty, val_casted v ty -> ty <> Tvoid -> Val.has_type v (typ_of_type ty).
+Proof.
+ intros. inv H; simpl typ_of_type.
+- exact I.
+- exact I.
+- exact I.
+- exact I.
+- apply Val.Vptr_has_type.
+- red; unfold Tptr; rewrite H1; auto.
+- red; unfold Tptr; rewrite H1; auto.
+- red; unfold Tptr; rewrite H1; auto.
+- red; unfold Tptr; rewrite H1; auto.
+- apply Val.Vptr_has_type.
+- apply Val.Vptr_has_type.
+- congruence.
+Qed.
+
(** Relation with the arithmetic conversions of ISO C99, section 6.3.1 *)
Module ArithConv.
diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v
index 0c3e00de..6d2b470f 100644
--- a/cfrontend/Csem.v
+++ b/cfrontend/Csem.v
@@ -15,19 +15,9 @@
(** Dynamic semantics for the Compcert C language *)
-Require Import Coqlib.
-Require Import Errors.
-Require Import Maps.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import AST.
-Require Import Memory.
-Require Import Events.
-Require Import Globalenvs.
-Require Import Ctypes.
-Require Import Cop.
-Require Import Csyntax.
+Require Import Coqlib Errors Maps.
+Require Import Integers Floats Values AST Memory Builtins Events Globalenvs.
+Require Import Ctypes Cop Csyntax.
Require Import Smallstep.
(** * Operational semantics *)
@@ -437,6 +427,59 @@ Definition not_stuck (e: expr) (m: mem) : Prop :=
forall k C e' ,
context k RV C -> e = C e' -> imm_safe k e' m.
+(** ** Derived forms. *)
+
+(** The following are admissible reduction rules for some derived forms
+ of the CompCert C language. They help showing that the derived forms
+ make sense. *)
+
+Lemma red_selection:
+ forall v1 ty1 v2 ty2 v3 ty3 ty m b v2' v3',
+ ty <> Tvoid ->
+ bool_val v1 ty1 m = Some b ->
+ sem_cast v2 ty2 ty m = Some v2' ->
+ sem_cast v3 ty3 ty m = Some v3' ->
+ rred (Eselection (Eval v1 ty1) (Eval v2 ty2) (Eval v3 ty3) ty) m
+ E0 (Eval (if b then v2' else v3') ty) m.
+Proof.
+ intros. unfold Eselection.
+ set (t := typ_of_type ty).
+ set (sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default).
+ assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select t))).
+ { unfold sg, t; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ];
+ simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. }
+ set (v' := if b then v2' else v3').
+ assert (C: val_casted v' ty).
+ { unfold v'; destruct b; eapply cast_val_is_casted; eauto. }
+ assert (EQ: Val.normalize v' t = v').
+ { apply Val.normalize_idem. apply val_casted_has_type; auto. }
+ econstructor.
+- constructor. rewrite cast_bool_bool_val, H0. eauto.
+ constructor. eauto.
+ constructor. eauto.
+ constructor.
+- red. red. rewrite LK. constructor. simpl. rewrite <- EQ.
+ destruct b; auto.
+Qed.
+
+Lemma ctx_selection_1:
+ forall k C r2 r3 ty, context k RV C -> context k RV (fun x => Eselection (C x) r2 r3 ty).
+Proof.
+ intros. apply ctx_builtin. constructor; auto.
+Qed.
+
+Lemma ctx_selection_2:
+ forall k r1 C r3 ty, context k RV C -> context k RV (fun x => Eselection r1 (C x) r3 ty).
+Proof.
+ intros. apply ctx_builtin. constructor; constructor; auto.
+Qed.
+
+Lemma ctx_selection_3:
+ forall k r1 r2 C ty, context k RV C -> context k RV (fun x => Eselection r1 r2 (C x) ty).
+Proof.
+ intros. apply ctx_builtin. constructor; constructor; constructor; auto.
+Qed.
+
End EXPR.
(** ** Transition semantics. *)
diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v
index 792a73f9..5bd12d00 100644
--- a/cfrontend/Cshmgen.v
+++ b/cfrontend/Cshmgen.v
@@ -23,6 +23,7 @@
Require Import Coqlib Maps Errors Integers Floats.
Require Import AST Linking.
Require Import Ctypes Cop Clight Cminor Csharpminor.
+Require Import Conventions1.
Local Open Scope string_scope.
Local Open Scope error_monad_scope.
@@ -558,6 +559,34 @@ Fixpoint typlist_of_arglist (al: list Clight.expr) (tyl: typelist)
typ_of_type (default_argument_conversion (typeof a1)) :: typlist_of_arglist a2 Tnil
end.
+(** Translate a function call.
+ Depending on the ABI, it may be necessary to normalize the value
+ returned by casting it to the return type of the function.
+ For example, in the x86 ABI, a return value of type "char" is
+ returned in register AL, leaving the top 24 bits of EAX
+ unspecified. Hence, a cast to type "char" is needed to sign- or
+ zero-extend the returned integer before using it. *)
+
+Definition make_normalization (t: type) (a: expr) :=
+ match t with
+ | Tint IBool _ _ => Eunop Ocast8unsigned a
+ | Tint I8 Signed _ => Eunop Ocast8signed a
+ | Tint I8 Unsigned _ => Eunop Ocast8unsigned a
+ | Tint I16 Signed _ => Eunop Ocast16signed a
+ | Tint I16 Unsigned _ => Eunop Ocast16unsigned a
+ | _ => a
+ end.
+
+Definition make_funcall (x: option ident) (tres: type) (sg: signature)
+ (fn: expr) (args: list expr): stmt :=
+ match x, return_value_needs_normalization sg.(sig_res) with
+ | Some id, true =>
+ Sseq (Scall x sg fn args)
+ (Sset id (make_normalization tres (Evar id)))
+ | _, _ =>
+ Scall x sg fn args
+ end.
+
(** * Translation of statements *)
(** [transl_statement nbrk ncnt s] returns a Csharpminor statement
@@ -601,10 +630,10 @@ Fixpoint transl_statement (ce: composite_env) (tyret: type) (nbrk ncnt: nat)
| fun_case_f args res cconv =>
do tb <- transl_expr ce b;
do tcl <- transl_arglist ce cl args;
- OK(Scall x {| sig_args := typlist_of_arglist cl args;
- sig_res := opttyp_of_type res;
- sig_cc := cconv |}
- tb tcl)
+ let sg := {| sig_args := typlist_of_arglist cl args;
+ sig_res := rettype_of_type res;
+ sig_cc := cconv |} in
+ OK (make_funcall x res sg tb tcl)
| _ => Error(msg "Cshmgen.transl_stmt(call)")
end
| Clight.Sbuiltin x ef tyargs bl =>
@@ -667,7 +696,7 @@ Definition transl_var (ce: composite_env) (v: ident * type) :=
Definition signature_of_function (f: Clight.function) :=
{| sig_args := map typ_of_type (map snd (Clight.fn_params f));
- sig_res := opttyp_of_type (Clight.fn_return f);
+ sig_res := rettype_of_type (Clight.fn_return f);
sig_cc := Clight.fn_callconv f |}.
Definition transl_function (ce: composite_env) (f: Clight.function) : res function :=
diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v
index 09e31cb2..1ceb8e4d 100644
--- a/cfrontend/Cshmgenproof.v
+++ b/cfrontend/Cshmgenproof.v
@@ -15,7 +15,7 @@
Require Import Coqlib Errors Maps Integers Floats.
Require Import AST Linking.
Require Import Values Events Memory Globalenvs Smallstep.
-Require Import Ctypes Cop Clight Cminor Csharpminor.
+Require Import Ctypes Ctyping Cop Clight Cminor Csharpminor.
Require Import Cshmgen.
(** * Relational specification of the transformation *)
@@ -996,6 +996,26 @@ Proof.
eapply make_memcpy_correct with (b := b) (v := Vptr b' ofs'); eauto.
Qed.
+Lemma make_normalization_correct:
+ forall e le m a v t,
+ eval_expr ge e le m a v ->
+ wt_val v t ->
+ eval_expr ge e le m (make_normalization t a) v.
+Proof.
+ intros. destruct t; simpl; auto. inv H0.
+- destruct i; simpl in H3.
+ + destruct s; econstructor; eauto; simpl; congruence.
+ + destruct s; econstructor; eauto; simpl; congruence.
+ + auto.
+ + econstructor; eauto; simpl; congruence.
+- auto.
+- destruct i.
+ + destruct s; econstructor; eauto.
+ + destruct s; econstructor; eauto.
+ + auto.
+ + econstructor; eauto.
+Qed.
+
End CONSTRUCTORS.
(** * Basic preservation invariants *)
@@ -1360,7 +1380,16 @@ Inductive match_cont: composite_env -> type -> nat -> nat -> Clight.cont -> Csha
match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk' ncnt' k tk ->
match_cont ce tyret nbrk ncnt
(Clight.Kcall id f e le k)
- (Kcall id tf te le tk).
+ (Kcall id tf te le tk)
+ | match_Kcall_normalize: forall ce tyret nbrk ncnt nbrk' ncnt' f e k id a tf te le tk cu,
+ linkorder cu prog ->
+ transl_function cu.(prog_comp_env) f = OK tf ->
+ match_env e te ->
+ match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk' ncnt' k tk ->
+ (forall v e le m, wt_val v tyret -> le!id = Some v -> eval_expr tge e le m a v) ->
+ match_cont ce tyret nbrk ncnt
+ (Clight.Kcall (Some id) f e le k)
+ (Kcall (Some id) tf te le (Kseq (Sset id a) tk)).
Inductive match_states: Clight.state -> Csharpminor.state -> Prop :=
| match_state:
@@ -1377,14 +1406,15 @@ Inductive match_states: Clight.state -> Csharpminor.state -> Prop :=
forall fd args k m tfd tk targs tres cconv cu ce
(LINK: linkorder cu prog)
(TR: match_fundef cu fd tfd)
- (MK: match_cont ce Tvoid 0%nat 0%nat k tk)
+ (MK: match_cont ce tres 0%nat 0%nat k tk)
(ISCC: Clight.is_call_cont k)
(TY: type_of_fundef fd = Tfunction targs tres cconv),
match_states (Clight.Callstate fd args k m)
(Callstate tfd args tk m)
| match_returnstate:
- forall res k m tk ce
- (MK: match_cont ce Tvoid 0%nat 0%nat k tk),
+ forall res tres k m tk ce
+ (MK: match_cont ce tres 0%nat 0%nat k tk)
+ (WT: wt_val res tres),
match_states (Clight.Returnstate res k m)
(Returnstate res tk m).
@@ -1442,7 +1472,9 @@ Proof.
- (* set *)
auto.
- (* call *)
- simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto.
+ simpl in TR. destruct (classify_fun (typeof e)); monadInv TR.
+ unfold make_funcall.
+ destruct o; auto; destruct Conventions1.return_value_needs_normalization; auto.
- (* builtin *)
auto.
- (* seq *)
@@ -1500,24 +1532,26 @@ End FIND_LABEL.
(** Properties of call continuations *)
Lemma match_cont_call_cont:
- forall ce' tyret' nbrk' ncnt' ce tyret nbrk ncnt k tk,
+ forall ce' nbrk' ncnt' ce tyret nbrk ncnt k tk,
match_cont ce tyret nbrk ncnt k tk ->
- match_cont ce' tyret' nbrk' ncnt' (Clight.call_cont k) (call_cont tk).
+ match_cont ce' tyret nbrk' ncnt' (Clight.call_cont k) (call_cont tk).
Proof.
induction 1; simpl; auto.
- constructor.
- econstructor; eauto.
+- apply match_Kstop.
+- eapply match_Kcall; eauto.
+- eapply match_Kcall_normalize; eauto.
Qed.
Lemma match_cont_is_call_cont:
- forall ce tyret nbrk ncnt k tk ce' tyret' nbrk' ncnt',
+ forall ce tyret nbrk ncnt k tk ce' nbrk' ncnt',
match_cont ce tyret nbrk ncnt k tk ->
Clight.is_call_cont k ->
- match_cont ce' tyret' nbrk' ncnt' k tk /\ is_call_cont tk.
+ match_cont ce' tyret nbrk' ncnt' k tk /\ is_call_cont tk.
Proof.
intros. inv H; simpl in H0; try contradiction; simpl.
- split; auto; constructor.
- split; auto; econstructor; eauto.
+ split; auto; apply match_Kstop.
+ split; auto; eapply match_Kcall; eauto.
+ split; auto; eapply match_Kcall_normalize; eauto.
Qed.
(** The simulation proof *)
@@ -1549,19 +1583,44 @@ Proof.
- (* call *)
revert TR. simpl. case_eq (classify_fun (typeof a)); try congruence.
- intros targs tres cc CF TR. monadInv TR. inv MTR.
+ intros targs tres cc CF TR. monadInv TR.
exploit functions_translated; eauto. intros (cu' & tfd & FIND & TFD & LINK').
rewrite H in CF. simpl in CF. inv CF.
- econstructor; split.
- apply plus_one. econstructor; eauto.
- eapply transl_expr_correct with (cunit := cu); eauto.
- eapply transl_arglist_correct with (cunit := cu); eauto.
- erewrite typlist_of_arglist_eq by eauto.
- eapply transl_fundef_sig1; eauto.
- rewrite H3. auto.
- econstructor; eauto.
- eapply match_Kcall with (ce := prog_comp_env cu') (cu := cu); eauto.
- simpl. auto.
+ set (sg := {| sig_args := typlist_of_arglist al targs;
+ sig_res := rettype_of_type tres;
+ sig_cc := cc |}) in *.
+ assert (SIG: funsig tfd = sg).
+ { unfold sg; erewrite typlist_of_arglist_eq by eauto.
+ eapply transl_fundef_sig1; eauto. rewrite H3; auto. }
+ assert (EITHER: tk' = tk /\ ts' = Scall optid sg x x0
+ \/ exists id, optid = Some id /\
+ tk' = tk /\ ts' = Sseq (Scall optid sg x x0)
+ (Sset id (make_normalization tres (Evar id)))).
+ { unfold make_funcall in MTR.
+ destruct optid. destruct Conventions1.return_value_needs_normalization.
+ inv MTR. right; exists i; auto.
+ inv MTR; auto.
+ inv MTR; auto. }
+ destruct EITHER as [(EK & ES) | (id & EI & EK & ES)]; rewrite EK, ES.
+ + (* without normalization of return value *)
+ econstructor; split.
+ apply plus_one. eapply step_call; eauto.
+ eapply transl_expr_correct with (cunit := cu); eauto.
+ eapply transl_arglist_correct with (cunit := cu); eauto.
+ econstructor; eauto.
+ eapply match_Kcall with (ce := prog_comp_env cu') (cu := cu); eauto.
+ exact I.
+ + (* with normalization of return value *)
+ subst optid.
+ econstructor; split.
+ eapply plus_two. apply step_seq. eapply step_call; eauto.
+ eapply transl_expr_correct with (cunit := cu); eauto.
+ eapply transl_arglist_correct with (cunit := cu); eauto.
+ traceEq.
+ econstructor; eauto.
+ eapply match_Kcall_normalize with (ce := prog_comp_env cu') (cu := cu); eauto.
+ intros. eapply make_normalization_correct; eauto. constructor; eauto.
+ exact I.
- (* builtin *)
monadInv TR. inv MTR.
@@ -1658,6 +1717,7 @@ Proof.
eapply match_env_free_blocks; eauto.
eapply match_returnstate with (ce := prog_comp_env cu); eauto.
eapply match_cont_call_cont. eauto.
+ constructor.
- (* return some *)
monadInv TR. inv MTR.
@@ -1667,6 +1727,7 @@ Proof.
eapply match_env_free_blocks; eauto.
eapply match_returnstate with (ce := prog_comp_env cu); eauto.
eapply match_cont_call_cont. eauto.
+ apply wt_val_casted. eapply cast_val_is_casted; eauto.
- (* skip call *)
monadInv TR. inv MTR.
@@ -1675,6 +1736,7 @@ Proof.
apply plus_one. apply step_skip_call. auto.
eapply match_env_free_blocks; eauto.
eapply match_returnstate with (ce := prog_comp_env cu); eauto.
+ constructor.
- (* switch *)
monadInv TR.
@@ -1738,20 +1800,33 @@ Proof.
simpl. econstructor; eauto.
unfold transl_function. rewrite EQ; simpl. rewrite EQ1; simpl. auto.
constructor.
+ replace (fn_return f) with tres. eassumption.
+ simpl in TY. unfold type_of_function in TY. congruence.
- (* external function *)
inv TR.
exploit match_cont_is_call_cont; eauto. intros [A B].
econstructor; split.
- apply plus_one. constructor. eauto.
+ apply plus_one. constructor.
eapply external_call_symbols_preserved; eauto. apply senv_preserved.
eapply match_returnstate with (ce := ce); eauto.
+ apply has_rettype_wt_val.
+ replace (rettype_of_type tres0) with (sig_res (ef_sig ef)).
+ eapply external_call_well_typed_gen; eauto.
+ rewrite H5. simpl. simpl in TY. congruence.
- (* returnstate *)
inv MK.
- econstructor; split.
- apply plus_one. constructor.
- econstructor; eauto. simpl; reflexivity. constructor.
+ + (* without normalization *)
+ econstructor; split.
+ apply plus_one. constructor.
+ econstructor; eauto. simpl; reflexivity. constructor.
+ + (* with normalization *)
+ econstructor; split.
+ eapply plus_three. econstructor. econstructor. constructor.
+ simpl. apply H13. eauto. apply PTree.gss.
+ traceEq.
+ simpl. rewrite PTree.set2. econstructor; eauto. simpl; reflexivity. constructor.
Qed.
Lemma transl_initial_states:
diff --git a/cfrontend/Cstrategy.v b/cfrontend/Cstrategy.v
index 28c8eeb8..c235031f 100644
--- a/cfrontend/Cstrategy.v
+++ b/cfrontend/Cstrategy.v
@@ -222,7 +222,7 @@ Proof.
induction 1; constructor; auto.
Qed.
-Hint Resolve leftcontext_context.
+Local Hint Resolve leftcontext_context : core.
(** Strategy for reducing expressions. We reduce the leftmost innermost
non-simple subexpression, evaluating its arguments (which are necessarily
@@ -398,8 +398,8 @@ Proof.
induction 1; intros; constructor; eauto.
Qed.
-Hint Constructors context contextlist.
-Hint Resolve context_compose contextlist_compose.
+Local Hint Constructors context contextlist : core.
+Local Hint Resolve context_compose contextlist_compose : core.
(** * Safe executions. *)
@@ -975,7 +975,7 @@ Proof.
apply extensionality; intros. f_equal. f_equal. apply exprlist_app_assoc.
Qed.
-Hint Resolve contextlist'_head contextlist'_tail.
+Local Hint Resolve contextlist'_head contextlist'_tail : core.
Lemma eval_simple_list_steps:
forall rl vl, eval_simple_list' rl vl ->
@@ -1049,7 +1049,7 @@ Scheme expr_ind2 := Induction for expr Sort Prop
with exprlist_ind2 := Induction for exprlist Sort Prop.
Combined Scheme expr_expr_list_ind from expr_ind2, exprlist_ind2.
-Hint Constructors leftcontext leftcontextlist.
+Local Hint Constructors leftcontext leftcontextlist : core.
Lemma decompose_expr:
(forall a from C,
diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v
index 914328be..e3e2c1e9 100644
--- a/cfrontend/Csyntax.v
+++ b/cfrontend/Csyntax.v
@@ -41,7 +41,7 @@ Inductive expr : Type :=
(**r binary arithmetic operation *)
| Ecast (r: expr) (ty: type) (**r type cast [(ty)r] *)
| Eseqand (r1 r2: expr) (ty: type) (**r sequential "and" [r1 && r2] *)
- | Eseqor (r1 r2: expr) (ty: type) (**r sequential "or" [r1 && r2] *)
+ | Eseqor (r1 r2: expr) (ty: type) (**r sequential "or" [r1 || r2] *)
| Econdition (r1 r2 r3: expr) (ty: type) (**r conditional [r1 ? r2 : r3] *)
| Esizeof (ty': type) (ty: type) (**r size of a type *)
| Ealignof (ty': type) (ty: type) (**r natural alignment of a type *)
@@ -100,6 +100,18 @@ Definition Epreincr (id: incr_or_decr) (l: expr) (ty: type) :=
Eassignop (match id with Incr => Oadd | Decr => Osub end)
l (Eval (Vint Int.one) type_int32s) (typeconv ty) ty.
+(** Selection is a conditional expression that always evaluates both arms
+ and can be implemented by "conditional move" instructions.
+ It is expressed as an invocation of a builtin function. *)
+
+Definition Eselection (r1 r2 r3: expr) (ty: type) :=
+ let t := typ_of_type ty in
+ let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in
+ Ebuiltin (EF_builtin "__builtin_sel"%string sg)
+ (Tcons type_bool (Tcons ty (Tcons ty Tnil)))
+ (Econs r1 (Econs r2 (Econs r3 Enil)))
+ ty.
+
(** Extract the type part of a type-annotated expression. *)
Definition typeof (a: expr) : type :=
diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v
index bfc5daa9..664a60c5 100644
--- a/cfrontend/Ctypes.v
+++ b/cfrontend/Ctypes.v
@@ -732,8 +732,21 @@ Definition typ_of_type (t: type) : AST.typ :=
| Tpointer _ _ | Tarray _ _ _ | Tfunction _ _ _ | Tstruct _ _ | Tunion _ _ => AST.Tptr
end.
-Definition opttyp_of_type (t: type) : option AST.typ :=
- if type_eq t Tvoid then None else Some (typ_of_type t).
+Definition rettype_of_type (t: type) : AST.rettype :=
+ match t with
+ | Tvoid => AST.Tvoid
+ | Tint I32 _ _ => AST.Tint
+ | Tint I8 Signed _ => AST.Tint8signed
+ | Tint I8 Unsigned _ => AST.Tint8unsigned
+ | Tint I16 Signed _ => AST.Tint16signed
+ | Tint I16 Unsigned _ => AST.Tint16unsigned
+ | Tint IBool _ _ => AST.Tint8unsigned
+ | Tlong _ _ => AST.Tlong
+ | Tfloat F32 _ => AST.Tsingle
+ | Tfloat F64 _ => AST.Tfloat
+ | Tpointer _ _ => AST.Tptr
+ | Tarray _ _ _ | Tfunction _ _ _ | Tstruct _ _ | Tunion _ _ => AST.Tvoid
+ end.
Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ :=
match tl with
@@ -742,7 +755,7 @@ Fixpoint typlist_of_typelist (tl: typelist) : list AST.typ :=
end.
Definition signature_of_type (args: typelist) (res: type) (cc: calling_convention): signature :=
- mksignature (typlist_of_typelist args) (opttyp_of_type res) cc.
+ mksignature (typlist_of_typelist args) (rettype_of_type res) cc.
(** * Construction of the composite environment *)
diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v
index ba1d34fb..00fcf8ab 100644
--- a/cfrontend/Ctyping.v
+++ b/cfrontend/Ctyping.v
@@ -18,7 +18,7 @@
Require Import String.
Require Import Coqlib Maps Integers Floats Errors.
Require Import AST Linking.
-Require Import Values Memory Globalenvs Events.
+Require Import Values Memory Globalenvs Builtins Events.
Require Import Ctypes Cop Csyntax Csem.
Local Open Scope error_monad_scope.
@@ -392,13 +392,17 @@ Inductive wt_rvalue : expr -> Prop :=
classify_fun (typeof r1) = fun_case_f tyargs tyres cconv ->
wt_arguments rargs tyargs ->
wt_rvalue (Ecall r1 rargs tyres)
- | wt_Ebuiltin: forall ef tyargs rargs,
+ | wt_Ebuiltin: forall ef tyargs rargs ty,
wt_exprlist rargs ->
wt_arguments rargs tyargs ->
- (* This is specialized to builtins returning void, the only
- case generated by C2C. *)
- sig_res (ef_sig ef) = None ->
- wt_rvalue (Ebuiltin ef tyargs rargs Tvoid)
+ (* This typing rule is specialized to the builtin invocations generated
+ by C2C, which are either __builtin_sel or builtins returning void. *)
+ (ty = Tvoid /\ sig_res (ef_sig ef) = AST.Tvoid)
+ \/ (tyargs = Tcons type_bool (Tcons ty (Tcons ty Tnil))
+ /\ let t := typ_of_type ty in
+ let sg := mksignature (AST.Tint :: t :: t :: nil) t cc_default in
+ ef = EF_builtin "__builtin_sel"%string sg) ->
+ wt_rvalue (Ebuiltin ef tyargs rargs ty)
| wt_Eparen: forall r tycast ty,
wt_rvalue r ->
wt_cast (typeof r) tycast -> subtype tycast ty ->
@@ -517,11 +521,20 @@ Fixpoint bind_globdef (e: typenv) (l: list (ident * globdef fundef type)) : type
| (id, Gvar v) :: l => bind_globdef (PTree.set id v.(gvar_info) e) l
end.
+Inductive wt_fundef (ce: composite_env) (e: typenv) : fundef -> Prop :=
+ | wt_fundef_internal: forall f,
+ wt_function ce e f ->
+ wt_fundef ce e (Internal f)
+ | wt_fundef_external: forall ef targs tres cc,
+ (ef_sig ef).(sig_res) = rettype_of_type tres ->
+ wt_fundef ce e (External ef targs tres cc).
+
Inductive wt_program : program -> Prop :=
| wt_program_intro: forall p,
let e := bind_globdef (PTree.empty _) p.(prog_defs) in
- (forall id f, In (id, Gfun (Internal f)) p.(prog_defs) ->
- wt_function p.(prog_comp_env) e f) ->
+ (forall id fd,
+ In (id, Gfun fd) p.(prog_defs) ->
+ wt_fundef p.(prog_comp_env) e fd) ->
wt_program p.
Hint Constructors wt_val wt_rvalue wt_lvalue wt_stmt wt_lblstmts: ty.
@@ -741,10 +754,16 @@ Definition ebuiltin (ef: external_function) (tyargs: typelist) (args: exprlist)
do x1 <- check_rvals args;
do x2 <- check_arguments args tyargs;
if type_eq tyres Tvoid
- && opt_typ_eq (sig_res (ef_sig ef)) None
+ && AST.rettype_eq (sig_res (ef_sig ef)) AST.Tvoid
then OK (Ebuiltin ef tyargs args tyres)
else Error (msg "builtin: wrong type decoration").
+Definition eselection (r1 r2 r3: expr) : res expr :=
+ do x1 <- check_rval r1; do x2 <- check_rval r2; do x3 <- check_rval r3;
+ do y1 <- check_bool (typeof r1);
+ do ty <- type_conditional (typeof r2) (typeof r3);
+ OK (Eselection r1 r2 r3 ty).
+
Definition sdo (a: expr) : res statement :=
do x <- check_rval a; OK (Sdo a).
@@ -905,7 +924,8 @@ Definition retype_function (ce: composite_env) (e: typenv) (f: function) : res f
Definition retype_fundef (ce: composite_env) (e: typenv) (fd: fundef) : res fundef :=
match fd with
| Internal f => do f' <- retype_function ce e f; OK (Internal f')
- | External id args res cc => OK fd
+ | External ef args res cc =>
+ assertion (rettype_eq (ef_sig ef).(sig_res) (rettype_of_type res)); OK fd
end.
Definition typecheck_program (p: program) : res program :=
@@ -977,10 +997,20 @@ Proof.
classify_cast (Tint i s a) t2 <> cast_case_default).
{
unfold classify_cast. destruct t2; try congruence. destruct f; congruence.
+ destruct Archi.ptr64; congruence.
}
destruct i; auto.
Qed.
+Lemma wt_bool_cast:
+ forall ty, wt_bool ty -> wt_cast ty type_bool.
+Proof.
+ unfold wt_bool, wt_cast; unfold classify_bool; intros.
+ destruct ty; simpl in *; try congruence;
+ try (destruct Archi.ptr64; congruence).
+ destruct f; congruence.
+Qed.
+
Lemma wt_cast_int:
forall i1 s1 a1 i2 s2 a2, wt_cast (Tint i1 s1 a1) (Tint i2 s2 a2).
Proof.
@@ -1221,10 +1251,21 @@ Lemma ebuiltin_sound:
Proof.
intros. monadInv H.
destruct (type_eq tyres Tvoid); simpl in EQ2; try discriminate.
- destruct (opt_typ_eq (sig_res (ef_sig ef)) None); inv EQ2.
+ destruct (rettype_eq (sig_res (ef_sig ef)) AST.Tvoid); inv EQ2.
econstructor; eauto. eapply check_arguments_sound; eauto.
Qed.
+Lemma eselection_sound:
+ forall r1 r2 r3 a, eselection r1 r2 r3 = OK a ->
+ wt_expr ce e r1 -> wt_expr ce e r2 -> wt_expr ce e r3 -> wt_expr ce e a.
+Proof.
+ intros. monadInv H. apply type_conditional_cast in EQ3. destruct EQ3.
+ eapply wt_Ebuiltin.
+ repeat (constructor; eauto with ty).
+ repeat (constructor; eauto with ty). apply wt_bool_cast; eauto with ty.
+ right; auto.
+Qed.
+
Lemma sdo_sound:
forall a s, sdo a = OK s -> wt_expr ce e a -> wt_stmt ce e rt s.
Proof.
@@ -1342,6 +1383,14 @@ Proof.
intros. monadInv H. constructor; simpl. eapply retype_stmt_sound; eauto.
Qed.
+Lemma retype_fundef_sound:
+ forall ce e fd fd', retype_fundef ce e fd = OK fd' -> wt_fundef ce e fd'.
+Proof.
+ intros. destruct fd; monadInv H.
+- constructor; eapply retype_function_sound; eauto.
+- constructor; auto.
+Qed.
+
Theorem typecheck_program_sound:
forall p p', typecheck_program p = OK p' -> wt_program p'.
Proof.
@@ -1364,11 +1413,11 @@ Proof.
inv H1. simpl. auto.
}
rewrite ENVS.
- intros id f. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp).
+ intros id fd. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp).
induction 1; simpl; intros.
contradiction.
destruct H0; auto. subst b1; inv H. simpl in H1. inv H1.
- destruct f1; monadInv H4. eapply retype_function_sound; eauto.
+ eapply retype_fundef_sound; eauto.
Qed.
(** * Subject reduction *)
@@ -1632,15 +1681,6 @@ Proof.
destruct f; discriminate.
Qed.
-Lemma wt_bool_cast:
- forall ty, wt_bool ty -> wt_cast ty type_bool.
-Proof.
- unfold wt_bool, wt_cast; unfold classify_bool; intros.
- destruct ty; simpl in *; try congruence;
- try (destruct Archi.ptr64; congruence).
- destruct f; congruence.
-Qed.
-
Lemma wt_cast_self:
forall t1 t2, wt_cast t1 t2 -> wt_cast t2 t2.
Proof.
@@ -1689,6 +1729,26 @@ Proof.
inv H; auto.
Qed.
+Lemma has_rettype_wt_val:
+ forall v ty,
+ Val.has_rettype v (rettype_of_type ty) -> wt_val v ty.
+Proof.
+ unfold rettype_of_type, Val.has_rettype, Val.has_type; destruct ty; intros.
+- destruct v; contradiction || constructor.
+- destruct i.
+ + destruct s; destruct v; try contradiction; constructor; red; auto.
+ + destruct s; destruct v; try contradiction; constructor; red; auto.
+ + destruct v; try contradiction; constructor; auto.
+ + destruct v; try contradiction; constructor; red; auto.
+- destruct v; try contradiction; constructor; auto.
+- destruct f; destruct v; try contradiction; constructor.
+- unfold Tptr in *; destruct v; destruct Archi.ptr64 eqn:P64; try contradiction; constructor; auto.
+- destruct v; contradiction || constructor.
+- destruct v; contradiction || constructor.
+- destruct v; contradiction || constructor.
+- destruct v; contradiction || constructor.
+Qed.
+
Lemma wt_rred:
forall ge tenv a m t a' m',
rred ge a m t a' m' -> wt_rvalue ge tenv a -> wt_rvalue ge tenv a'.
@@ -1725,7 +1785,27 @@ Proof.
constructor; auto.
- (* comma *) auto.
- (* paren *) inv H3. constructor. apply H5. eapply pres_sem_cast; eauto.
-- (* builtin *) subst. auto with ty.
+- (* builtin *) subst. destruct H7 as [(A & B) | (A & B)].
++ subst ty. auto with ty.
++ simpl in B. set (T := typ_of_type ty) in *.
+ set (sg := mksignature (AST.Tint :: T :: T :: nil) T cc_default) in *.
+ assert (LK: lookup_builtin_function "__builtin_sel"%string sg = Some (BI_standard (BI_select T))).
+ { unfold sg, T; destruct ty as [ | ? ? ? | ? | [] ? | ? ? | ? ? ? | ? ? ? | ? ? | ? ? ];
+ simpl; unfold Tptr; destruct Archi.ptr64; reflexivity. }
+ subst ef. red in H0. red in H0. rewrite LK in H0. inv H0.
+ inv H. inv H8. inv H9. inv H10. simpl in H1.
+ assert (A: val_casted v1 type_bool) by (eapply cast_val_is_casted; eauto).
+ inv A.
+ set (v' := if Int.eq n Int.zero then v4 else v2) in *.
+ constructor.
+ destruct (type_eq ty Tvoid).
+ subst. constructor.
+ inv H1.
+ assert (C: val_casted v' ty).
+ { unfold v'; destruct (Int.eq n Int.zero); eapply cast_val_is_casted; eauto. }
+ assert (EQ: Val.normalize v' T = v').
+ { apply Val.normalize_idem. apply val_casted_has_type; auto. }
+ rewrite EQ. apply wt_val_casted; auto.
Qed.
Lemma wt_lred:
@@ -1767,8 +1847,8 @@ with wt_subexprlist:
wt_exprlist cenv tenv (C a) ->
wt_expr_kind cenv tenv from a.
Proof.
- destruct 1; intros WT; auto; inv WT; eauto.
- destruct 1; intros WT; inv WT; eauto.
+- destruct 1; intros WT; auto; inv WT; eauto.
+- destruct 1; intros WT; inv WT; eauto.
Qed.
Lemma typeof_context:
@@ -1854,12 +1934,6 @@ Hypothesis WTPROG: wt_program prog.
Let ge := globalenv prog.
Let gtenv := bind_globdef (PTree.empty _) prog.(prog_defs).
-Hypothesis WT_EXTERNAL:
- forall id ef args res cc vargs m t vres m',
- In (id, Gfun (External ef args res cc)) prog.(prog_defs) ->
- external_call ef ge vargs m t vres m' ->
- wt_val vres res.
-
Inductive wt_expr_cont: typenv -> function -> cont -> Prop :=
| wt_Kdo: forall te f k,
wt_stmt_cont te f k ->
@@ -1958,12 +2032,6 @@ Proof.
induction 1; simpl; auto; econstructor; eauto.
Qed.
-Definition wt_fundef (fd: fundef) :=
- match fd with
- | Internal f => wt_function ge gtenv f
- | External ef targs tres cc => True
- end.
-
Definition fundef_return (fd: fundef) : type :=
match fd with
| Internal f => f.(fn_return)
@@ -1971,10 +2039,10 @@ Definition fundef_return (fd: fundef) : type :=
end.
Lemma wt_find_funct:
- forall v fd, Genv.find_funct ge v = Some fd -> wt_fundef fd.
+ forall v fd, Genv.find_funct ge v = Some fd -> wt_fundef ge gtenv fd.
Proof.
intros. apply Genv.find_funct_prop with (p := prog) (v := v); auto.
- intros. inv WTPROG. destruct f; simpl; auto. apply H1 with id; auto.
+ intros. inv WTPROG. apply H1 with id; auto.
Qed.
Inductive wt_state: state -> Prop :=
@@ -1990,7 +2058,7 @@ Inductive wt_state: state -> Prop :=
wt_state (ExprState f r k e m)
| wt_call_state: forall b fd vargs k m
(WTK: wt_call_cont k (fundef_return fd))
- (WTFD: wt_fundef fd)
+ (WTFD: wt_fundef ge gtenv fd)
(FIND: Genv.find_funct ge b = Some fd),
wt_state (Callstate fd vargs k m)
| wt_return_state: forall v k m ty
@@ -2047,7 +2115,6 @@ Qed.
End WT_FIND_LABEL.
-
Lemma preservation_estep:
forall S t S', estep ge S t S' -> wt_state S -> wt_state S'.
Proof.
@@ -2122,9 +2189,10 @@ Proof.
- inv WTS; eauto with ty.
- exploit wt_find_label. eexact WTB. eauto. eapply call_cont_wt'; eauto.
intros [A B]. eauto with ty.
-- simpl in WTFD; inv WTFD. econstructor; eauto. apply wt_call_cont_stmt_cont; auto.
-- exploit (Genv.find_funct_inversion prog); eauto. intros (id & A).
- econstructor; eauto.
+- inv WTFD. inv H3. econstructor; eauto. apply wt_call_cont_stmt_cont; auto.
+- inv WTFD. econstructor; eauto.
+ apply has_rettype_wt_val. simpl; rewrite <- H1.
+ eapply external_call_well_typed_gen; eauto.
- inv WTK. eauto with ty.
Qed.
@@ -2139,7 +2207,7 @@ Theorem wt_initial_state:
Proof.
intros. inv H. econstructor. constructor.
apply Genv.find_funct_ptr_prop with (p := prog) (b := b); auto.
- intros. inv WTPROG. destruct f0; simpl; auto. apply H4 with id; auto.
+ intros. inv WTPROG. apply H4 with id; auto.
instantiate (1 := (Vptr b Ptrofs.zero)). rewrite Genv.find_funct_find_funct_ptr. auto.
Qed.
diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml
index ca378c11..0e735d2d 100644
--- a/cfrontend/PrintClight.ml
+++ b/cfrontend/PrintClight.ml
@@ -23,9 +23,18 @@ open Cop
open PrintCsyntax
open Clight
-(* Naming temporaries *)
+(* Naming temporaries.
+ Some temporaries are obtained by lifting variables in SimplLocals.
+ For these we use a meaningful name "$var", as found in the table of
+ atoms. Other temporaries are generated during SimplExpr, and are
+ not in the table of atoms. We print them as "$NNN" (a unique
+ integer). *)
-let temp_name (id: AST.ident) = "$" ^ Z.to_string (Z.Zpos id)
+let temp_name (id: AST.ident) =
+ try
+ "$" ^ Hashtbl.find string_of_atom id
+ with Not_found ->
+ Printf.sprintf "$%d" (P.to_int id)
(* Declarator (identifier + type) -- reuse from PrintCsyntax *)
@@ -236,10 +245,20 @@ and print_stmt_for p s =
| _ ->
fprintf p "({ %a })" print_stmt s
-let print_function p id f =
+(* There are two versions of Clight, Clight1 and Clight2, that differ
+ only in the meaning of function parameters:
+ - in Clight1, function parameters are variables
+ - in Clight2, function parameters are temporaries.
+*)
+
+type clight_version = Clight1 | Clight2
+
+let name_param = function Clight1 -> extern_atom | Clight2 -> temp_name
+
+let print_function ver p id f =
fprintf p "%s@ "
- (name_cdecl (name_function_parameters (extern_atom id)
- f.fn_params f.fn_callconv)
+ (name_cdecl (name_function_parameters (name_param ver)
+ (extern_atom id) f.fn_params f.fn_callconv)
f.fn_return);
fprintf p "@[<v 2>{@ ";
List.iter
@@ -253,12 +272,12 @@ let print_function p id f =
print_stmt p f.fn_body;
fprintf p "@;<0 -2>}@]@ @ "
-let print_fundef p id fd =
+let print_fundef ver p id fd =
match fd with
| Ctypes.External(_, _, _, _) ->
()
| Internal f ->
- print_function p id f
+ print_function ver p id f
let print_fundecl p id fd =
match fd with
@@ -271,9 +290,9 @@ let print_fundecl p id fd =
fprintf p "%s;@ "
(name_cdecl (extern_atom id) (Clight.type_of_function f))
-let print_globdef p (id, gd) =
+let print_globdef var p (id, gd) =
match gd with
- | AST.Gfun f -> print_fundef p id f
+ | AST.Gfun f -> print_fundef var p id f
| AST.Gvar v -> print_globvar p id v (* from PrintCsyntax *)
let print_globdecl p (id, gd) =
@@ -281,20 +300,29 @@ let print_globdecl p (id, gd) =
| AST.Gfun f -> print_fundecl p id f
| AST.Gvar v -> ()
-let print_program p prog =
+let print_program ver p prog =
fprintf p "@[<v 0>";
List.iter (declare_composite p) prog.prog_types;
List.iter (define_composite p) prog.prog_types;
List.iter (print_globdecl p) prog.prog_defs;
- List.iter (print_globdef p) prog.prog_defs;
+ List.iter (print_globdef ver p) prog.prog_defs;
fprintf p "@]@."
let destination : string option ref = ref None
-let print_if prog =
+let print_if_gen ver prog =
match !destination with
| None -> ()
| Some f ->
let oc = open_out f in
- print_program (formatter_of_out_channel oc) prog;
+ print_program ver (formatter_of_out_channel oc) prog;
close_out oc
+
+(* print_if is called from driver/Compiler.v between the SimplExpr
+ and SimplLocals passes. It receives Clight1 syntax. *)
+let print_if prog = print_if_gen Clight1 prog
+
+(* print_if_2 is called from clightgen/Clightgen.ml, after the
+ SimplLocals pass. It receives Clight2 syntax. *)
+let print_if_2 prog = print_if_gen Clight2 prog
+
diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml
index 3a44796c..03dc5837 100644
--- a/cfrontend/PrintCsyntax.ml
+++ b/cfrontend/PrintCsyntax.ml
@@ -19,7 +19,7 @@ open Format
open Camlcoq
open Values
open AST
-open Ctypes
+open! Ctypes
open Cop
open Csyntax
@@ -85,7 +85,7 @@ let name_optid id =
let rec name_cdecl id ty =
match ty with
- | Tvoid ->
+ | Ctypes.Tvoid ->
"void" ^ name_optid id
| Ctypes.Tint(sz, sg, a) ->
name_inttype sz sg ^ attributes a ^ name_optid id
@@ -391,7 +391,7 @@ and print_stmt_for p s =
| _ ->
fprintf p "({ %a })" print_stmt s
-let name_function_parameters fun_name params cconv =
+let name_function_parameters name_param fun_name params cconv =
let b = Buffer.create 20 in
Buffer.add_string b fun_name;
Buffer.add_char b '(';
@@ -404,7 +404,7 @@ let name_function_parameters fun_name params cconv =
if cconv.cc_vararg then Buffer.add_string b ",..."
| (id, ty) :: rem ->
if not first then Buffer.add_string b ", ";
- Buffer.add_string b (name_cdecl (extern_atom id) ty);
+ Buffer.add_string b (name_cdecl (name_param id) ty);
add_params false rem in
add_params true params
end;
@@ -413,8 +413,8 @@ let name_function_parameters fun_name params cconv =
let print_function p id f =
fprintf p "%s@ "
- (name_cdecl (name_function_parameters (extern_atom id)
- f.fn_params f.fn_callconv)
+ (name_cdecl (name_function_parameters extern_atom
+ (extern_atom id) f.fn_params f.fn_callconv)
f.fn_return);
fprintf p "@[<v 2>{@ ";
List.iter
diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v
index 37e2cd96..e7d57a1c 100644
--- a/cfrontend/SimplExprspec.v
+++ b/cfrontend/SimplExprspec.v
@@ -687,7 +687,7 @@ Hint Resolve gensym_within within_widen contained_widen
in_eq in_cons
Ple_trans Ple_refl: gensym.
-Hint Resolve dest_for_val_below dest_for_effect_below.
+Local Hint Resolve dest_for_val_below dest_for_effect_below : core.
(** ** Correctness of the translation functions *)
diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v
index 26d3d347..2dd34389 100644
--- a/cfrontend/SimplLocalsproof.v
+++ b/cfrontend/SimplLocalsproof.v
@@ -1055,7 +1055,7 @@ Proof.
assert (RPDST: Mem.range_perm m bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sizeof tge ty) Cur Nonempty).
replace (sizeof tge ty) with (Z.of_nat (List.length bytes)).
eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem.
- rewrite LEN. apply nat_of_Z_eq. omega.
+ rewrite LEN. apply Z2Nat.id. omega.
assert (PSRC: Mem.perm m bsrc (Ptrofs.unsigned osrc) Cur Nonempty).
apply RPSRC. omega.
assert (PDST: Mem.perm m bdst (Ptrofs.unsigned odst) Cur Nonempty).
diff --git a/common/AST.v b/common/AST.v
index 145f4919..eb34d675 100644
--- a/common/AST.v
+++ b/common/AST.v
@@ -17,7 +17,7 @@
the abstract syntax trees of many of the intermediate languages. *)
Require Import String.
-Require Import Coqlib Maps Errors Integers Floats.
+Require Import Coqlib Maps Errors Integers Floats BinPos.
Require Archi.
Set Implicit Arguments.
@@ -45,9 +45,6 @@ Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}.
Proof. decide equality. Defined.
Global Opaque typ_eq.
-Definition opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2}
- := option_eq typ_eq.
-
Definition list_typ_eq: forall (l1 l2: list typ), {l1=l2} + {l1<>l2}
:= list_eq_dec typ_eq.
@@ -91,10 +88,34 @@ Fixpoint subtype_list (tyl1 tyl2: list typ) : bool :=
| _, _ => false
end.
+(** To describe the values returned by functions, we use the more precise
+ types below. *)
+
+Inductive rettype : Type :=
+ | Tret (t: typ) (**r like type [t] *)
+ | Tint8signed (**r 8-bit signed integer *)
+ | Tint8unsigned (**r 8-bit unsigned integer *)
+ | Tint16signed (**r 16-bit signed integer *)
+ | Tint16unsigned (**r 16-bit unsigned integer *)
+ | Tvoid. (**r no value returned *)
+
+Coercion Tret: typ >-> rettype.
+
+Lemma rettype_eq: forall (t1 t2: rettype), {t1=t2} + {t1<>t2}.
+Proof. generalize typ_eq; decide equality. Defined.
+Global Opaque rettype_eq.
+
+Fixpoint proj_rettype (r: rettype) : typ :=
+ match r with
+ | Tret t => t
+ | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => Tint
+ | Tvoid => Tint
+ end.
+
(** Additionally, function definitions and function calls are annotated
by function signatures indicating:
- the number and types of arguments;
-- the type of the returned value, if any;
+- the type of the returned value;
- additional information on which calling convention to use.
These signatures are used in particular to determine appropriate
@@ -117,24 +138,20 @@ Global Opaque calling_convention_eq.
Record signature : Type := mksignature {
sig_args: list typ;
- sig_res: option typ;
+ sig_res: rettype;
sig_cc: calling_convention
}.
-Definition proj_sig_res (s: signature) : typ :=
- match s.(sig_res) with
- | None => Tint
- | Some t => t
- end.
+Definition proj_sig_res (s: signature) : typ := proj_rettype s.(sig_res).
Definition signature_eq: forall (s1 s2: signature), {s1=s2} + {s1<>s2}.
Proof.
- generalize opt_typ_eq, list_typ_eq, calling_convention_eq; decide equality.
+ generalize rettype_eq, list_typ_eq, calling_convention_eq; decide equality.
Defined.
Global Opaque signature_eq.
Definition signature_main :=
- {| sig_args := nil; sig_res := Some Tint; sig_cc := cc_default |}.
+ {| sig_args := nil; sig_res := Tint; sig_cc := cc_default |}.
(** Memory accesses (load and store instructions) are annotated by
a ``memory chunk'' indicating the type, size and signedness of the
@@ -177,6 +194,28 @@ Definition type_of_chunk (c: memory_chunk) : typ :=
Lemma type_of_Mptr: type_of_chunk Mptr = Tptr.
Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed.
+(** Same, as a return type. *)
+
+Definition rettype_of_chunk (c: memory_chunk) : rettype :=
+ match c with
+ | Mint8signed => Tint8signed
+ | Mint8unsigned => Tint8unsigned
+ | Mint16signed => Tint16signed
+ | Mint16unsigned => Tint16unsigned
+ | Mint32 => Tint
+ | Mint64 => Tlong
+ | Mfloat32 => Tsingle
+ | Mfloat64 => Tfloat
+ | Many32 => Tany32
+ | Many64 => Tany64
+ end.
+
+Lemma proj_rettype_of_chunk:
+ forall chunk, proj_rettype (rettype_of_chunk chunk) = type_of_chunk chunk.
+Proof.
+ destruct chunk; auto.
+Qed.
+
(** The chunk that is appropriate to store and reload a value of
the given type, without losing information. *)
@@ -193,6 +232,16 @@ Definition chunk_of_type (ty: typ) :=
Lemma chunk_of_Tptr: chunk_of_type Tptr = Mptr.
Proof. unfold Mptr, Tptr; destruct Archi.ptr64; auto. Qed.
+(** Trapping mode: does undefined behavior result in a trap or an undefined value (e.g. for loads) *)
+Inductive trapping_mode : Type := TRAP | NOTRAP.
+
+Definition trapping_mode_eq : forall x y : trapping_mode,
+ { x=y } + { x <> y}.
+Proof.
+ decide equality.
+Defined.
+
+
(** Initialization data for global variables. *)
Inductive init_data: Type :=
@@ -432,12 +481,12 @@ Inductive external_function : Type :=
(** A function from the run-time library. Behaves like an
external, but must not be redefined. *)
| EF_vload (chunk: memory_chunk)
- (** A volatile read operation. If the adress given as first argument
+ (** A volatile read operation. If the address given as first argument
points within a volatile global variable, generate an
event and return the value found in this event. Otherwise,
produce no event and behave like a regular memory load. *)
| EF_vstore (chunk: memory_chunk)
- (** A volatile store operation. If the adress given as first argument
+ (** A volatile store operation. If the address given as first argument
points within a volatile global variable, generate an event.
Otherwise, produce no event and behave like a regular memory store. *)
| EF_malloc
@@ -477,15 +526,15 @@ Definition ef_sig (ef: external_function): signature :=
| EF_external name sg => sg
| EF_builtin name sg => sg
| EF_runtime name sg => sg
- | EF_vload chunk => mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default
- | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default
- | EF_malloc => mksignature (Tptr :: nil) (Some Tptr) cc_default
- | EF_free => mksignature (Tptr :: nil) None cc_default
- | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) None cc_default
- | EF_annot kind text targs => mksignature targs None cc_default
- | EF_annot_val kind text targ => mksignature (targ :: nil) (Some targ) cc_default
+ | EF_vload chunk => mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default
+ | EF_vstore chunk => mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default
+ | EF_malloc => mksignature (Tptr :: nil) Tptr cc_default
+ | EF_free => mksignature (Tptr :: nil) Tvoid cc_default
+ | EF_memcpy sz al => mksignature (Tptr :: Tptr :: nil) Tvoid cc_default
+ | EF_annot kind text targs => mksignature targs Tvoid cc_default
+ | EF_annot_val kind text targ => mksignature (targ :: nil) targ cc_default
| EF_inline_asm text sg clob => sg
- | EF_debug kind text targs => mksignature targs None cc_default
+ | EF_debug kind text targs => mksignature targs Tvoid cc_default
end.
(** Whether an external function should be inlined by the compiler. *)
@@ -630,11 +679,28 @@ Inductive builtin_arg (A: Type) : Type :=
| BA_splitlong (hi lo: builtin_arg A)
| BA_addptr (a1 a2: builtin_arg A).
+Definition builtin_arg_eq {A: Type}:
+ (forall x y : A, {x = y} + {x <> y}) ->
+ forall (ba1 ba2: (builtin_arg A)), {ba1=ba2} + {ba1<>ba2}.
+Proof.
+ intro. generalize Integers.int_eq int64_eq float_eq float32_eq chunk_eq ptrofs_eq ident_eq.
+ decide equality.
+Defined.
+Global Opaque builtin_arg_eq.
+
Inductive builtin_res (A: Type) : Type :=
| BR (x: A)
| BR_none
| BR_splitlong (hi lo: builtin_res A).
+Definition builtin_res_eq {A: Type}:
+ (forall x y : A, {x = y} + {x <> y}) ->
+ forall (a b: builtin_res A), {a=b} + {a<>b}.
+Proof.
+ intro. decide equality.
+Defined.
+Global Opaque builtin_res_eq.
+
Fixpoint globals_of_builtin_arg (A: Type) (a: builtin_arg A) : list ident :=
match a with
| BA_loadglobal chunk id ofs => id :: nil
diff --git a/common/Builtins.v b/common/Builtins.v
new file mode 100644
index 00000000..476b541e
--- /dev/null
+++ b/common/Builtins.v
@@ -0,0 +1,58 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Known built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Export Builtins0 Builtins1.
+
+Inductive builtin_function : Type :=
+ | BI_standard (b: standard_builtin)
+ | BI_platform (b: platform_builtin).
+
+Definition builtin_function_sig (b: builtin_function) : signature :=
+ match b with
+ | BI_standard b => standard_builtin_sig b
+ | BI_platform b => platform_builtin_sig b
+ end.
+
+Definition builtin_function_sem (b: builtin_function) : builtin_sem (sig_res (builtin_function_sig b)) :=
+ match b with
+ | BI_standard b => standard_builtin_sem b
+ | BI_platform b => platform_builtin_sem b
+ end.
+
+Definition lookup_builtin_function (name: string) (sg: signature) : option builtin_function :=
+ match lookup_builtin standard_builtin_sig name sg standard_builtin_table with
+ | Some b => Some (BI_standard b)
+ | None =>
+ match lookup_builtin platform_builtin_sig name sg platform_builtin_table with
+ | Some b => Some (BI_platform b)
+ | None => None
+ end end.
+
+Lemma lookup_builtin_function_sig:
+ forall name sg b, lookup_builtin_function name sg = Some b -> builtin_function_sig b = sg.
+Proof.
+ unfold lookup_builtin_function; intros.
+ destruct (lookup_builtin standard_builtin_sig name sg standard_builtin_table) as [bs|] eqn:E.
+ inv H. simpl. eapply lookup_builtin_sig; eauto.
+ destruct (lookup_builtin platform_builtin_sig name sg platform_builtin_table) as [bp|] eqn:E'.
+ inv H. simpl. eapply lookup_builtin_sig; eauto.
+ discriminate.
+Qed.
+
+
diff --git a/common/Builtins0.v b/common/Builtins0.v
new file mode 100644
index 00000000..8da98314
--- /dev/null
+++ b/common/Builtins0.v
@@ -0,0 +1,531 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Associating semantics to built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values Memdata.
+
+(** This module provides definitions and mechanisms to associate semantics
+ with names of built-in functions.
+
+ This module is independent of the target architecture. Each target
+ provides a [Builtins1] module that lists the built-ins semantics
+ appropriate for the target.
+*)
+
+Definition val_opt_has_rettype (ov: option val) (t: rettype) : Prop :=
+ match ov with Some v => Val.has_rettype v t | None => True end.
+
+Definition val_opt_inject (j: meminj) (ov ov': option val) : Prop :=
+ match ov, ov' with
+ | None, _ => True
+ | Some v, Some v' => Val.inject j v v'
+ | _, None => False
+ end.
+
+(** The semantics of a built-in function is a partial function
+ from list of values to values.
+ It must agree with the return type stated in the signature,
+ and be compatible with value injections.
+*)
+
+Record builtin_sem (tret: rettype) : Type := mkbuiltin {
+ bs_sem :> list val -> option val;
+ bs_well_typed: forall vl,
+ val_opt_has_rettype (bs_sem vl) tret;
+ bs_inject: forall j vl vl',
+ Val.inject_list j vl vl' -> val_opt_inject j (bs_sem vl) (bs_sem vl')
+}.
+
+(** Builtin functions can be created from functions over values, such as those
+ from the [Values.Val] module. Proofs of well-typedness and compatibility with
+ injections must be provided. The constructor functions have names
+- [mkbuiltin_vNt] for a [t]otal function of [N] arguments that are [v]alues, or
+- [mkbuiltin_vNp] for a [p]artial function of [N] arguments that are [v]alues.
+*)
+
+Local Unset Program Cases.
+
+Program Definition mkbuiltin_v1t
+ (tret: rettype) (f: val -> val)
+ (WT: forall v1, Val.has_rettype (f v1) tret)
+ (INJ: forall j v1 v1', Val.inject j v1 v1' -> Val.inject j (f v1) (f v1')) :=
+ mkbuiltin tret (fun vl => match vl with v1 :: nil => Some (f v1) | _ => None end) _ _.
+Next Obligation.
+ red; destruct vl; auto. destruct vl; auto.
+Qed.
+Next Obligation.
+ red; inv H; auto. inv H1; auto.
+Qed.
+
+Program Definition mkbuiltin_v2t
+ (tret: rettype) (f: val -> val -> val)
+ (WT: forall v1 v2, Val.has_rettype (f v1 v2) tret)
+ (INJ: forall j v1 v1' v2 v2',
+ Val.inject j v1 v1' -> Val.inject j v2 v2' ->
+ Val.inject j (f v1 v2) (f v1' v2')) :=
+ mkbuiltin tret (fun vl => match vl with v1 :: v2 :: nil => Some (f v1 v2) | _ => None end) _ _.
+Next Obligation.
+ red; destruct vl; auto. destruct vl; auto. destruct vl; auto.
+Qed.
+Next Obligation.
+ red; inv H; auto. inv H1; auto. inv H2; auto.
+Qed.
+
+Program Definition mkbuiltin_v3t
+ (tret: rettype) (f: val -> val -> val -> val)
+ (WT: forall v1 v2 v3, Val.has_rettype (f v1 v2 v3) tret)
+ (INJ: forall j v1 v1' v2 v2' v3 v3',
+ Val.inject j v1 v1' -> Val.inject j v2 v2' -> Val.inject j v3 v3' ->
+ Val.inject j (f v1 v2 v3) (f v1' v2' v3')) :=
+ mkbuiltin tret (fun vl => match vl with v1 :: v2 :: v3 :: nil => Some (f v1 v2 v3) | _ => None end) _ _.
+Next Obligation.
+ red; destruct vl; auto. destruct vl; auto. destruct vl; auto. destruct vl; auto.
+Qed.
+Next Obligation.
+ red; inv H; auto. inv H1; auto. inv H2; auto. inv H3; auto.
+Qed.
+
+Program Definition mkbuiltin_v1p
+ (tret: rettype) (f: val -> option val)
+ (WT: forall v1, val_opt_has_rettype (f v1) tret)
+ (INJ: forall j v1 v1',
+ Val.inject j v1 v1' -> val_opt_inject j (f v1) (f v1')) :=
+ mkbuiltin tret (fun vl => match vl with v1 :: nil => f v1 | _ => None end) _ _.
+Next Obligation.
+ red; destruct vl; auto. destruct vl; auto. apply WT.
+Qed.
+Next Obligation.
+ red; inv H; auto. inv H1; auto. apply INJ; auto.
+Qed.
+
+Program Definition mkbuiltin_v2p
+ (tret: rettype) (f: val -> val -> option val)
+ (WT: forall v1 v2, val_opt_has_rettype (f v1 v2) tret)
+ (INJ: forall j v1 v1' v2 v2',
+ Val.inject j v1 v1' -> Val.inject j v2 v2' ->
+ val_opt_inject j (f v1 v2) (f v1' v2')) :=
+ mkbuiltin tret (fun vl => match vl with v1 :: v2 :: nil => f v1 v2 | _ => None end) _ _.
+Next Obligation.
+ red; destruct vl; auto. destruct vl; auto. destruct vl; auto. apply WT.
+Qed.
+Next Obligation.
+ red; inv H; auto. inv H1; auto. inv H2; auto. apply INJ; auto.
+Qed.
+
+(** For numerical functions, involving only integers and floating-point numbers
+ but no pointer values, we can automate the proofs of well-typedness and
+ of compatibility with injections. *)
+
+(** First we define a mapping from syntactic Cminor types ([Tint], [Tfloat], etc) to semantic Coq types. *)
+
+Definition valty (t: typ) : Type :=
+ match t with
+ | Tint => int
+ | Tlong => int64
+ | Tfloat => float
+ | Tsingle => float32
+ | Tany32 | Tany64 => Empty_set (**r no clear semantic meaning *)
+ end.
+
+(** We can inject and project between the numerical type [valty t] and the type [val]. *)
+
+Definition inj_num (t: typ) : valty t -> val :=
+ match t with
+ | Tint => Vint
+ | Tlong => Vlong
+ | Tfloat => Vfloat
+ | Tsingle => Vsingle
+ | Tany32 | Tany64 => fun _ => Vundef
+ end.
+
+Definition proj_num {A: Type} (t: typ) (k0: A) (v: val): (valty t -> A) -> A :=
+ match t with
+ | Tint => fun k1 => match v with Vint n => k1 n | _ => k0 end
+ | Tlong => fun k1 => match v with Vlong n => k1 n | _ => k0 end
+ | Tfloat => fun k1 => match v with Vfloat n => k1 n | _ => k0 end
+ | Tsingle => fun k1 => match v with Vsingle n => k1 n | _ => k0 end
+ | Tany32 | Tany64 => fun k1 => k0
+ end.
+
+Lemma inj_num_wt: forall t x, Val.has_type (inj_num t x) t.
+Proof.
+ destruct t; intros; exact I.
+Qed.
+
+Lemma inj_num_inject: forall j t x, Val.inject j (inj_num t x) (inj_num t x).
+Proof.
+ destruct t; intros; constructor.
+Qed.
+
+Lemma inj_num_opt_wt: forall t x, val_opt_has_rettype (option_map (inj_num t) x) t.
+Proof.
+ intros. destruct x; simpl. apply inj_num_wt. auto.
+Qed.
+
+Lemma inj_num_opt_inject: forall j t x,
+ val_opt_inject j (option_map (inj_num t) x) (option_map (inj_num t) x).
+Proof.
+ destruct x; simpl. apply inj_num_inject. auto.
+Qed.
+
+Lemma proj_num_wt:
+ forall tres t k1 v,
+ (forall x, Val.has_type (k1 x) tres) ->
+ Val.has_type (proj_num t Vundef v k1) tres.
+Proof.
+ intros. destruct t; simpl; destruct v; auto; exact I.
+Qed.
+
+Lemma proj_num_inject:
+ forall j t k1 v k1' v',
+ (forall x, Val.inject j (k1 x) (k1' x)) ->
+ Val.inject j v v' ->
+ Val.inject j (proj_num t Vundef v k1) (proj_num t Vundef v' k1').
+Proof.
+ intros. destruct t; simpl; inv H0; auto.
+Qed.
+
+Lemma proj_num_opt_wt:
+ forall (tres: typ) t k0 k1 v,
+ k0 = None \/ k0 = Some Vundef ->
+ (forall x, val_opt_has_rettype (k1 x) tres) ->
+ val_opt_has_rettype (proj_num t k0 v k1) tres.
+Proof.
+ intros.
+ assert (val_opt_has_rettype k0 tres). { destruct H; subst k0; exact I. }
+ destruct t; simpl; destruct v; auto.
+Qed.
+
+Lemma proj_num_opt_inject:
+ forall j k0 t k1 v k1' v',
+ (forall ov, val_opt_inject j k0 ov) ->
+ (forall x, val_opt_inject j (k1 x) (k1' x)) ->
+ Val.inject j v v' ->
+ val_opt_inject j (proj_num t k0 v k1) (proj_num t k0 v' k1').
+Proof.
+ intros. destruct t; simpl; inv H1; auto.
+Qed.
+
+(** Wrapping numerical functions as built-ins. The constructor functions
+ have names
+- [mkbuiltin_nNt] for a [t]otal function of [N] numbers, or
+- [mkbuiltin_vNp] for a [p]artial function of [N] numbers.
+ *)
+
+Program Definition mkbuiltin_n1t
+ (targ1: typ) (tres: typ)
+ (f: valty targ1 -> valty tres) :=
+ mkbuiltin_v1t tres
+ (fun v1 => proj_num targ1 Vundef v1 (fun x => inj_num tres (f x)))
+ _ _.
+Next Obligation.
+ auto using proj_num_wt, inj_num_wt.
+Qed.
+Next Obligation.
+ auto using proj_num_inject, inj_num_inject.
+Qed.
+
+Program Definition mkbuiltin_n2t
+ (targ1 targ2: typ) (tres: typ)
+ (f: valty targ1 -> valty targ2 -> valty tres) :=
+ mkbuiltin_v2t tres
+ (fun v1 v2 =>
+ proj_num targ1 Vundef v1 (fun x1 =>
+ proj_num targ2 Vundef v2 (fun x2 => inj_num tres (f x1 x2))))
+ _ _.
+Next Obligation.
+ auto using proj_num_wt, inj_num_wt.
+Qed.
+Next Obligation.
+ auto using proj_num_inject, inj_num_inject.
+Qed.
+
+Program Definition mkbuiltin_n3t
+ (targ1 targ2 targ3: typ) (tres: typ)
+ (f: valty targ1 -> valty targ2 -> valty targ3 -> valty tres) :=
+ mkbuiltin_v3t tres
+ (fun v1 v2 v3 =>
+ proj_num targ1 Vundef v1 (fun x1 =>
+ proj_num targ2 Vundef v2 (fun x2 =>
+ proj_num targ3 Vundef v3 (fun x3 => inj_num tres (f x1 x2 x3)))))
+ _ _.
+Next Obligation.
+ auto using proj_num_wt, inj_num_wt.
+Qed.
+Next Obligation.
+ auto using proj_num_inject, inj_num_inject.
+Qed.
+
+Program Definition mkbuiltin_n1p
+ (targ1: typ) (tres: typ)
+ (f: valty targ1 -> option (valty tres)) :=
+ mkbuiltin_v1p tres
+ (fun v1 => proj_num targ1 None v1 (fun x => option_map (inj_num tres) (f x)))
+ _ _.
+Next Obligation.
+ auto using proj_num_opt_wt, inj_num_opt_wt.
+Qed.
+Next Obligation.
+ apply proj_num_opt_inject; auto. intros; red; auto. intros; apply inj_num_opt_inject.
+Qed.
+
+Program Definition mkbuiltin_n2p
+ (targ1 targ2: typ) (tres: typ)
+ (f: valty targ1 -> valty targ2 -> option (valty tres)) :=
+ mkbuiltin_v2p tres
+ (fun v1 v2 =>
+ proj_num targ1 None v1 (fun x1 =>
+ proj_num targ2 None v2 (fun x2 => option_map (inj_num tres) (f x1 x2))))
+ _ _.
+Next Obligation.
+ auto using proj_num_opt_wt, inj_num_opt_wt.
+Qed.
+Next Obligation.
+ apply proj_num_opt_inject; auto. intros; red; auto. intros.
+ apply proj_num_opt_inject; auto. intros; red; auto. intros.
+ apply inj_num_opt_inject.
+Qed.
+
+(** Looking up builtins by name and signature *)
+
+Section LOOKUP.
+
+Context {A: Type} (sig_of: A -> signature).
+
+Fixpoint lookup_builtin (name: string) (sg: signature) (l: list (string * A)) : option A :=
+ match l with
+ | nil => None
+ | (n, b) :: l =>
+ if string_dec name n && signature_eq sg (sig_of b)
+ then Some b
+ else lookup_builtin name sg l
+ end.
+
+Lemma lookup_builtin_sig: forall name sg b l,
+ lookup_builtin name sg l = Some b -> sig_of b = sg.
+Proof.
+ induction l as [ | [n b'] l ]; simpl; intros.
+- discriminate.
+- destruct (string_dec name n && signature_eq sg (sig_of b')) eqn:E.
++ InvBooleans. congruence.
++ auto.
+Qed.
+
+End LOOKUP.
+
+(** The standard, platform-independent built-ins *)
+
+Inductive standard_builtin : Type :=
+ | BI_select (t: typ)
+ | BI_fabs
+ | BI_fsqrt
+ | BI_negl
+ | BI_addl
+ | BI_subl
+ | BI_mull
+ | BI_i16_bswap
+ | BI_i32_bswap
+ | BI_i64_bswap
+ | BI_i64_umulh
+ | BI_i64_smulh
+ | BI_i64_sdiv
+ | BI_i64_udiv
+ | BI_i64_smod
+ | BI_i64_umod
+ | BI_i64_shl
+ | BI_i64_shr
+ | BI_i64_sar
+ | BI_i64_dtos
+ | BI_i64_dtou
+ | BI_i64_stod
+ | BI_i64_utod
+ | BI_i64_stof
+ | BI_i64_utof.
+
+Local Open Scope string_scope.
+
+Definition standard_builtin_table : list (string * standard_builtin) :=
+ ("__builtin_sel", BI_select Tint)
+ :: ("__builtin_sel", BI_select Tlong)
+ :: ("__builtin_sel", BI_select Tfloat)
+ :: ("__builtin_sel", BI_select Tsingle)
+ :: ("__builtin_fabs", BI_fabs)
+ :: ("__builtin_fsqrt", BI_fsqrt)
+ :: ("__builtin_negl", BI_negl)
+ :: ("__builtin_addl", BI_addl)
+ :: ("__builtin_subl", BI_subl)
+ :: ("__builtin_mull", BI_mull)
+ :: ("__builtin_bswap16", BI_i16_bswap)
+ :: ("__builtin_bswap", BI_i32_bswap)
+ :: ("__builtin_bswap32", BI_i32_bswap)
+ :: ("__builtin_bswap64", BI_i64_bswap)
+ :: ("__compcert_i64_umulh", BI_i64_umulh)
+ :: ("__compcert_i64_smulh", BI_i64_smulh)
+ :: ("__compcert_i64_sdiv", BI_i64_sdiv)
+ :: ("__compcert_i64_udiv", BI_i64_udiv)
+ :: ("__compcert_i64_smod", BI_i64_smod)
+ :: ("__compcert_i64_umod", BI_i64_umod)
+ :: ("__compcert_i64_shl", BI_i64_shl)
+ :: ("__compcert_i64_shr", BI_i64_shr)
+ :: ("__compcert_i64_sar", BI_i64_sar)
+ :: ("__compcert_i64_dtos", BI_i64_dtos)
+ :: ("__compcert_i64_dtou", BI_i64_dtou)
+ :: ("__compcert_i64_stod", BI_i64_stod)
+ :: ("__compcert_i64_utod", BI_i64_utod)
+ :: ("__compcert_i64_stof", BI_i64_stof)
+ :: ("__compcert_i64_utof", BI_i64_utof)
+ :: nil.
+
+Definition standard_builtin_sig (b: standard_builtin) : signature :=
+ match b with
+ | BI_select t =>
+ mksignature (Tint :: t :: t :: nil) t cc_default
+ | BI_fabs | BI_fsqrt =>
+ mksignature (Tfloat :: nil) Tfloat cc_default
+ | BI_negl =>
+ mksignature (Tlong :: nil) Tlong cc_default
+ | BI_addl | BI_subl | BI_i64_umulh| BI_i64_smulh
+ | BI_i64_sdiv | BI_i64_udiv | BI_i64_smod | BI_i64_umod =>
+ mksignature (Tlong :: Tlong :: nil) Tlong cc_default
+ | BI_mull =>
+ mksignature (Tint :: Tint :: nil) Tlong cc_default
+ | BI_i32_bswap =>
+ mksignature (Tint :: nil) Tint cc_default
+ | BI_i64_bswap =>
+ mksignature (Tlong :: nil) Tlong cc_default
+ | BI_i16_bswap =>
+ mksignature (Tint :: nil) Tint cc_default
+ | BI_i64_shl | BI_i64_shr | BI_i64_sar =>
+ mksignature (Tlong :: Tint :: nil) Tlong cc_default
+ | BI_i64_dtos | BI_i64_dtou =>
+ mksignature (Tfloat :: nil) Tlong cc_default
+ | BI_i64_stod | BI_i64_utod =>
+ mksignature (Tlong :: nil) Tfloat cc_default
+ | BI_i64_stof | BI_i64_utof =>
+ mksignature (Tlong :: nil) Tsingle cc_default
+ end.
+
+Program Definition standard_builtin_sem (b: standard_builtin) : builtin_sem (sig_res (standard_builtin_sig b)) :=
+ match b with
+ | BI_select t =>
+ mkbuiltin t
+ (fun vargs => match vargs with
+ | Vint n :: v1 :: v2 :: nil => Some (Val.normalize (if Int.eq n Int.zero then v2 else v1) t)
+ | _ => None
+ end) _ _
+ | BI_fabs => mkbuiltin_n1t Tfloat Tfloat Float.abs
+ | BI_fsqrt => mkbuiltin_n1t Tfloat Tfloat Float.sqrt
+ | BI_negl => mkbuiltin_n1t Tlong Tlong Int64.neg
+ | BI_addl => mkbuiltin_v2t Tlong Val.addl _ _
+ | BI_subl => mkbuiltin_v2t Tlong Val.subl _ _
+ | BI_mull => mkbuiltin_v2t Tlong Val.mull' _ _
+ | BI_i16_bswap =>
+ mkbuiltin_n1t Tint Tint
+ (fun n => Int.repr (decode_int (List.rev (encode_int 2%nat (Int.unsigned n)))))
+ | BI_i32_bswap =>
+ mkbuiltin_n1t Tint Tint
+ (fun n => Int.repr (decode_int (List.rev (encode_int 4%nat (Int.unsigned n)))))
+ | BI_i64_bswap =>
+ mkbuiltin_n1t Tlong Tlong
+ (fun n => Int64.repr (decode_int (List.rev (encode_int 8%nat (Int64.unsigned n)))))
+ | BI_i64_umulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhu
+ | BI_i64_smulh => mkbuiltin_n2t Tlong Tlong Tlong Int64.mulhs
+ | BI_i64_sdiv => mkbuiltin_v2p Tlong Val.divls _ _
+ | BI_i64_udiv => mkbuiltin_v2p Tlong Val.divlu _ _
+ | BI_i64_smod => mkbuiltin_v2p Tlong Val.modls _ _
+ | BI_i64_umod => mkbuiltin_v2p Tlong Val.modlu _ _
+ | BI_i64_shl => mkbuiltin_v2t Tlong Val.shll _ _
+ | BI_i64_shr => mkbuiltin_v2t Tlong Val.shrlu _ _
+ | BI_i64_sar => mkbuiltin_v2t Tlong Val.shrl _ _
+ | BI_i64_dtos => mkbuiltin_n1p Tfloat Tlong Float.to_long
+ | BI_i64_dtou => mkbuiltin_n1p Tfloat Tlong Float.to_longu
+ | BI_i64_stod => mkbuiltin_n1t Tlong Tfloat Float.of_long
+ | BI_i64_utod => mkbuiltin_n1t Tlong Tfloat Float.of_longu
+ | BI_i64_stof => mkbuiltin_n1t Tlong Tsingle Float32.of_long
+ | BI_i64_utof => mkbuiltin_n1t Tlong Tsingle Float32.of_longu
+ end.
+Next Obligation.
+ red. destruct vl; auto. destruct v; auto.
+ destruct vl; auto. destruct vl; auto. destruct vl; auto.
+ apply Val.normalize_type.
+Qed.
+Next Obligation.
+ red. inv H; auto. inv H0; auto. inv H1; auto. inv H0; auto. inv H2; auto.
+ apply Val.normalize_inject. destruct (Int.eq i Int.zero); auto.
+Qed.
+Next Obligation.
+ unfold Val.addl, Val.has_type; destruct v1; auto; destruct v2; auto; destruct Archi.ptr64; auto.
+Qed.
+Next Obligation.
+ apply Val.addl_inject; auto.
+Qed.
+Next Obligation.
+ unfold Val.subl, Val.has_type, negb; destruct v1; auto; destruct v2; auto;
+ destruct Archi.ptr64; auto; destruct (eq_block b0 b1); auto.
+Qed.
+Next Obligation.
+ apply Val.subl_inject; auto.
+Qed.
+Next Obligation.
+ unfold Val.mull', Val.has_type; destruct v1; simpl; auto; destruct v2; auto.
+Qed.
+Next Obligation.
+ inv H; simpl; auto. inv H0; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct orb; exact I.
+Qed.
+Next Obligation.
+ red. inv H; simpl; auto. inv H0; auto. destruct orb; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct Int64.eq; exact I.
+Qed.
+Next Obligation.
+ red. inv H; simpl; auto. inv H0; auto. destruct Int64.eq; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct orb; exact I.
+Qed.
+Next Obligation.
+ red. inv H; simpl; auto. inv H0; auto. destruct orb; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct Int64.eq; exact I.
+Qed.
+Next Obligation.
+ red. inv H; simpl; auto. inv H0; auto. destruct Int64.eq; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto.
+Qed.
+Next Obligation.
+ inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto.
+Qed.
+Next Obligation.
+ inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto.
+Qed.
+Next Obligation.
+ red. destruct v1; simpl; auto. destruct v2; auto. destruct Int.ltu; auto.
+Qed.
+Next Obligation.
+ inv H; simpl; auto. inv H0; auto. destruct Int.ltu; auto.
+Qed.
+
diff --git a/common/Errors.v b/common/Errors.v
index 28933313..6807735a 100644
--- a/common/Errors.v
+++ b/common/Errors.v
@@ -164,7 +164,7 @@ Ltac monadInv1 H :=
| (match ?X with left _ => _ | right _ => assertion_failed end = OK _) =>
destruct X; [try (monadInv1 H) | discriminate]
| (match (negb ?X) with true => _ | false => assertion_failed end = OK _) =>
- destruct X as [] eqn:?; [discriminate | try (monadInv1 H)]
+ destruct X as [] eqn:?; simpl negb in H; [discriminate | try (monadInv1 H)]
| (match ?X with true => _ | false => assertion_failed end = OK _) =>
destruct X as [] eqn:?; [try (monadInv1 H) | discriminate]
| (mmap ?F ?L = OK ?M) =>
diff --git a/common/Events.v b/common/Events.v
index b2335b96..28bb992a 100644
--- a/common/Events.v
+++ b/common/Events.v
@@ -24,6 +24,7 @@ Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
+Require Import Builtins.
(** * Events and traces *)
@@ -622,7 +623,7 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop :=
ec_well_typed:
forall ge vargs m1 t vres m2,
sem ge vargs m1 t vres m2 ->
- Val.has_type vres (proj_sig_res sg);
+ Val.has_rettype vres sg.(sig_res);
(** The semantics is invariant under change of global environment that preserves symbols. *)
ec_symbols_preserved:
@@ -648,9 +649,12 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop :=
(** External call cannot modify memory unless they have [Max, Writable]
permissions. *)
ec_readonly:
- forall ge vargs m1 t vres m2,
+ forall ge vargs m1 t vres m2 b ofs n bytes,
sem ge vargs m1 t vres m2 ->
- Mem.unchanged_on (loc_not_writable m1) m1 m2;
+ Mem.valid_block m1 b ->
+ Mem.loadbytes m2 b ofs n = Some bytes ->
+ (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) ->
+ Mem.loadbytes m1 b ofs n = Some bytes;
(** External calls must commute with memory extensions, in the
following sense. *)
@@ -770,12 +774,12 @@ Qed.
Lemma volatile_load_ok:
forall chunk,
extcall_properties (volatile_load_sem chunk)
- (mksignature (Tptr :: nil) (Some (type_of_chunk chunk)) cc_default).
+ (mksignature (Tptr :: nil) (rettype_of_chunk chunk) cc_default).
Proof.
intros; constructor; intros.
(* well typed *)
-- unfold proj_sig_res; simpl. inv H. inv H0. apply Val.load_result_type.
- eapply Mem.load_type; eauto.
+- inv H. inv H0. apply Val.load_result_rettype.
+ eapply Mem.load_rettype; eauto.
(* symbols *)
- inv H0. constructor. eapply volatile_load_preserved; eauto.
(* valid blocks *)
@@ -783,7 +787,7 @@ Proof.
(* max perms *)
- inv H; auto.
(* readonly *)
-- inv H. apply Mem.unchanged_on_refl.
+- inv H; auto.
(* mem extends *)
- inv H. inv H1. inv H6. inv H4.
exploit volatile_load_extends; eauto. intros [v' [A B]].
@@ -832,14 +836,27 @@ Proof.
rewrite C; auto.
Qed.
+Lemma unchanged_on_readonly:
+ forall m1 m2 b ofs n bytes,
+ Mem.unchanged_on (loc_not_writable m1) m1 m2 ->
+ Mem.valid_block m1 b ->
+ Mem.loadbytes m2 b ofs n = Some bytes ->
+ (forall i, ofs <= i < ofs + n -> ~Mem.perm m1 b i Max Writable) ->
+ Mem.loadbytes m1 b ofs n = Some bytes.
+Proof.
+ intros.
+ rewrite <- H1. symmetry.
+ apply Mem.loadbytes_unchanged_on_1 with (P := loc_not_writable m1); auto.
+Qed.
+
Lemma volatile_store_readonly:
forall ge chunk1 m1 b1 ofs1 v t m2,
volatile_store ge chunk1 m1 b1 ofs1 v t m2 ->
Mem.unchanged_on (loc_not_writable m1) m1 m2.
Proof.
intros. inv H.
- apply Mem.unchanged_on_refl.
- eapply Mem.store_unchanged_on; eauto.
+- apply Mem.unchanged_on_refl.
+- eapply Mem.store_unchanged_on; eauto.
exploit Mem.store_valid_access_3; eauto. intros [P Q].
intros. unfold loc_not_writable. red; intros. elim H2.
apply Mem.perm_cur_max. apply P. auto.
@@ -921,7 +938,7 @@ Qed.
Lemma volatile_store_ok:
forall chunk,
extcall_properties (volatile_store_sem chunk)
- (mksignature (Tptr :: type_of_chunk chunk :: nil) None cc_default).
+ (mksignature (Tptr :: type_of_chunk chunk :: nil) Tvoid cc_default).
Proof.
intros; constructor; intros.
(* well typed *)
@@ -933,7 +950,7 @@ Proof.
(* perms *)
- inv H. inv H2. auto. eauto with mem.
(* readonly *)
-- inv H. eapply volatile_store_readonly; eauto.
+- inv H. eapply unchanged_on_readonly; eauto. eapply volatile_store_readonly; eauto.
(* mem extends*)
- inv H. inv H1. inv H6. inv H7. inv H4.
exploit volatile_store_extends; eauto. intros [m2' [A [B C]]].
@@ -966,7 +983,7 @@ Inductive extcall_malloc_sem (ge: Senv.t):
Lemma extcall_malloc_ok:
extcall_properties extcall_malloc_sem
- (mksignature (Tptr :: nil) (Some Tptr) cc_default).
+ (mksignature (Tptr :: nil) Tptr cc_default).
Proof.
assert (UNCHANGED:
forall (P: block -> Z -> Prop) m lo hi v m' b m'',
@@ -983,7 +1000,7 @@ Proof.
}
constructor; intros.
(* well typed *)
-- inv H. unfold proj_sig_res, Tptr; simpl. destruct Archi.ptr64; auto.
+- inv H. simpl. unfold Tptr; destruct Archi.ptr64; auto.
(* symbols preserved *)
- inv H0; econstructor; eauto.
(* valid block *)
@@ -993,7 +1010,7 @@ Proof.
rewrite dec_eq_false. auto.
apply Mem.valid_not_valid_diff with m1; eauto with mem.
(* readonly *)
-- inv H. eapply UNCHANGED; eauto.
+- inv H. eapply unchanged_on_readonly; eauto.
(* mem extends *)
- inv H. inv H1. inv H7.
assert (SZ: v2 = Vptrofs sz).
@@ -1044,38 +1061,43 @@ Qed.
Inductive extcall_free_sem (ge: Senv.t):
list val -> mem -> trace -> val -> mem -> Prop :=
- | extcall_free_sem_intro: forall b lo sz m m',
+ | extcall_free_sem_ptr: forall b lo sz m m',
Mem.load Mptr m b (Ptrofs.unsigned lo - size_chunk Mptr) = Some (Vptrofs sz) ->
Ptrofs.unsigned sz > 0 ->
Mem.free m b (Ptrofs.unsigned lo - size_chunk Mptr) (Ptrofs.unsigned lo + Ptrofs.unsigned sz) = Some m' ->
- extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'.
+ extcall_free_sem ge (Vptr b lo :: nil) m E0 Vundef m'
+ | extcall_free_sem_null: forall m,
+ extcall_free_sem ge (Vnullptr :: nil) m E0 Vundef m.
Lemma extcall_free_ok:
extcall_properties extcall_free_sem
- (mksignature (Tptr :: nil) None cc_default).
+ (mksignature (Tptr :: nil) Tvoid cc_default).
Proof.
constructor; intros.
(* well typed *)
-- inv H. unfold proj_sig_res. simpl. auto.
+- inv H; simpl; auto.
(* symbols preserved *)
- inv H0; econstructor; eauto.
(* valid block *)
-- inv H. eauto with mem.
+- inv H; eauto with mem.
(* perms *)
-- inv H. eapply Mem.perm_free_3; eauto.
+- inv H; eauto using Mem.perm_free_3.
(* readonly *)
-- inv H. eapply Mem.free_unchanged_on; eauto.
- intros. red; intros. elim H3.
+- eapply unchanged_on_readonly; eauto. inv H.
++ eapply Mem.free_unchanged_on; eauto.
+ intros. red; intros. elim H6.
apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
eapply Mem.free_range_perm; eauto.
++ apply Mem.unchanged_on_refl.
(* mem extends *)
-- inv H. inv H1. inv H8. inv H6.
+- inv H.
++ inv H1. inv H8. inv H6.
exploit Mem.load_extends; eauto. intros [v' [A B]].
assert (v' = Vptrofs sz).
{ unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. }
subst v'.
exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]].
- exists Vundef; exists m2'; intuition.
+ exists Vundef; exists m2'; intuition auto.
econstructor; eauto.
eapply Mem.free_unchanged_on; eauto.
unfold loc_out_of_bounds; intros.
@@ -1083,8 +1105,14 @@ Proof.
{ apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
eapply Mem.free_range_perm. eexact H4. eauto. }
tauto.
++ inv H1. inv H5. replace v2 with Vnullptr.
+ exists Vundef; exists m1'; intuition auto.
+ constructor.
+ apply Mem.unchanged_on_refl.
+ unfold Vnullptr in *; destruct Archi.ptr64; inv H3; auto.
(* mem inject *)
-- inv H0. inv H2. inv H7. inv H9.
+- inv H0.
++ inv H2. inv H7. inv H9.
exploit Mem.load_inject; eauto. intros [v' [A B]].
assert (v' = Vptrofs sz).
{ unfold Vptrofs in *; destruct Archi.ptr64; inv B; auto. }
@@ -1098,7 +1126,7 @@ Proof.
intro EQ.
exploit Mem.free_parallel_inject; eauto. intros (m2' & C & D).
exists f, Vundef, m2'; split.
- apply extcall_free_sem_intro with (sz := sz) (m' := m2').
+ apply extcall_free_sem_ptr with (sz := sz) (m' := m2').
rewrite EQ. rewrite <- A. f_equal. omega.
auto. auto.
rewrite ! EQ. rewrite <- C. f_equal; omega.
@@ -1111,14 +1139,19 @@ Proof.
apply P. omega.
split. auto.
red; intros. congruence.
++ inv H2. inv H6. replace v' with Vnullptr.
+ exists f, Vundef, m1'; intuition auto using Mem.unchanged_on_refl.
+ constructor.
+ red; intros; congruence.
+ unfold Vnullptr in *; destruct Archi.ptr64; inv H4; auto.
(* trace length *)
- inv H; simpl; omega.
(* receptive *)
-- assert (t1 = t2). inv H; inv H0; auto. subst t2.
+- assert (t1 = t2) by (inv H; inv H0; auto). subst t2.
exists vres1; exists m1; auto.
(* determ *)
-- inv H; inv H0.
- assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence.
+- inv H; inv H0; try (unfold Vnullptr in *; destruct Archi.ptr64; discriminate).
++ assert (EQ1: Vptrofs sz0 = Vptrofs sz) by congruence.
assert (EQ2: sz0 = sz).
{ unfold Vptrofs in EQ1; destruct Archi.ptr64 eqn:SF.
rewrite <- (Ptrofs.of_int64_to_int64 SF sz0), <- (Ptrofs.of_int64_to_int64 SF sz). congruence.
@@ -1126,6 +1159,7 @@ Proof.
}
subst sz0.
split. constructor. intuition congruence.
++ split. constructor. intuition auto.
Qed.
(** ** Semantics of [memcpy] operations. *)
@@ -1146,11 +1180,11 @@ Inductive extcall_memcpy_sem (sz al: Z) (ge: Senv.t):
Lemma extcall_memcpy_ok:
forall sz al,
extcall_properties (extcall_memcpy_sem sz al)
- (mksignature (Tptr :: Tptr :: nil) None cc_default).
+ (mksignature (Tptr :: Tptr :: nil) Tvoid cc_default).
Proof.
intros. constructor.
- (* return type *)
- intros. inv H. constructor.
+ intros. inv H. exact I.
- (* change of globalenv *)
intros. inv H0. econstructor; eauto.
- (* valid blocks *)
@@ -1158,8 +1192,9 @@ Proof.
- (* perms *)
intros. inv H. eapply Mem.perm_storebytes_2; eauto.
- (* readonly *)
- intros. inv H. eapply Mem.storebytes_unchanged_on; eauto.
- intros; red; intros. elim H8.
+ intros. inv H. eapply unchanged_on_readonly; eauto.
+ eapply Mem.storebytes_unchanged_on; eauto.
+ intros; red; intros. elim H11.
apply Mem.perm_cur_max. eapply Mem.storebytes_range_perm; eauto.
- (* extensions *)
intros. inv H.
@@ -1208,7 +1243,7 @@ Proof.
assert (RPDST: Mem.range_perm m1 bdst (Ptrofs.unsigned odst) (Ptrofs.unsigned odst + sz) Cur Nonempty).
replace sz with (Z.of_nat (length bytes)).
eapply Mem.range_perm_implies. eapply Mem.storebytes_range_perm; eauto. auto with mem.
- rewrite LEN. apply nat_of_Z_eq. omega.
+ rewrite LEN. apply Z2Nat.id. omega.
assert (PSRC: Mem.perm m1 bsrc (Ptrofs.unsigned osrc) Cur Nonempty).
apply RPSRC. omega.
assert (PDST: Mem.perm m1 bdst (Ptrofs.unsigned odst) Cur Nonempty).
@@ -1257,7 +1292,7 @@ Inductive extcall_annot_sem (text: string) (targs: list typ) (ge: Senv.t):
Lemma extcall_annot_ok:
forall text targs,
extcall_properties (extcall_annot_sem text targs)
- (mksignature targs None cc_default).
+ (mksignature targs Tvoid cc_default).
Proof.
intros; constructor; intros.
(* well typed *)
@@ -1270,7 +1305,7 @@ Proof.
(* perms *)
- inv H; auto.
(* readonly *)
-- inv H. apply Mem.unchanged_on_refl.
+- inv H; auto.
(* mem extends *)
- inv H.
exists Vundef; exists m1'; intuition.
@@ -1302,11 +1337,11 @@ Inductive extcall_annot_val_sem (text: string) (targ: typ) (ge: Senv.t):
Lemma extcall_annot_val_ok:
forall text targ,
extcall_properties (extcall_annot_val_sem text targ)
- (mksignature (targ :: nil) (Some targ) cc_default).
+ (mksignature (targ :: nil) targ cc_default).
Proof.
intros; constructor; intros.
(* well typed *)
-- inv H. unfold proj_sig_res; simpl. eapply eventval_match_type; eauto.
+- inv H. eapply eventval_match_type; eauto.
(* symbols *)
- destruct H as (A & B & C). inv H0. econstructor; eauto.
eapply eventval_match_preserved; eauto.
@@ -1315,7 +1350,7 @@ Proof.
(* perms *)
- inv H; auto.
(* readonly *)
-- inv H. apply Mem.unchanged_on_refl.
+- inv H; auto.
(* mem extends *)
- inv H. inv H1. inv H6.
exists v2; exists m1'; intuition.
@@ -1346,7 +1381,7 @@ Inductive extcall_debug_sem (ge: Senv.t):
Lemma extcall_debug_ok:
forall targs,
extcall_properties extcall_debug_sem
- (mksignature targs None cc_default).
+ (mksignature targs Tvoid cc_default).
Proof.
intros; constructor; intros.
(* well typed *)
@@ -1358,7 +1393,7 @@ Proof.
(* perms *)
- inv H; auto.
(* readonly *)
-- inv H. apply Mem.unchanged_on_refl.
+- inv H; auto.
(* mem extends *)
- inv H.
exists Vundef; exists m1'; intuition.
@@ -1377,12 +1412,68 @@ Proof.
split. constructor. auto.
Qed.
+(** ** Semantics of known built-in functions. *)
+
+(** Some built-in functions and runtime support functions have known semantics
+ as defined in the [Builtin] modules.
+ These built-in functions have no observable effects and do not access memory. *)
+
+Inductive known_builtin_sem (bf: builtin_function) (ge: Senv.t):
+ list val -> mem -> trace -> val -> mem -> Prop :=
+ | known_builtin_sem_intro: forall vargs vres m,
+ builtin_function_sem bf vargs = Some vres ->
+ known_builtin_sem bf ge vargs m E0 vres m.
+
+Lemma known_builtin_ok: forall bf,
+ extcall_properties (known_builtin_sem bf) (builtin_function_sig bf).
+Proof.
+ intros. set (bsem := builtin_function_sem bf). constructor; intros.
+(* well typed *)
+- inv H.
+ specialize (bs_well_typed _ bsem vargs).
+ unfold val_opt_has_rettype, bsem; rewrite H0.
+ auto.
+(* symbols *)
+- inv H0. econstructor; eauto.
+(* valid blocks *)
+- inv H; auto.
+(* perms *)
+- inv H; auto.
+(* readonly *)
+- inv H; auto.
+(* mem extends *)
+- inv H. fold bsem in H2. apply val_inject_list_lessdef in H1.
+ specialize (bs_inject _ bsem _ _ _ H1).
+ unfold val_opt_inject; rewrite H2; intros.
+ destruct (bsem vargs') as [vres'|] eqn:?; try contradiction.
+ exists vres', m1'; intuition auto using Mem.extends_refl, Mem.unchanged_on_refl.
+ constructor; auto.
+ apply val_inject_lessdef; auto.
+(* mem injects *)
+- inv H0. fold bsem in H3.
+ specialize (bs_inject _ bsem _ _ _ H2).
+ unfold val_opt_inject; rewrite H3; intros.
+ destruct (bsem vargs') as [vres'|] eqn:?; try contradiction.
+ exists f, vres', m1'; intuition auto using Mem.extends_refl, Mem.unchanged_on_refl.
+ constructor; auto.
+ red; intros; congruence.
+(* trace length *)
+- inv H; simpl; omega.
+(* receptive *)
+- inv H; inv H0. exists vres1, m1; constructor; auto.
+(* determ *)
+- inv H; inv H0.
+ split. constructor. intuition congruence.
+Qed.
+
(** ** Semantics of external functions. *)
-(** For functions defined outside the program ([EF_external],
- [EF_builtin] and [EF_runtime]), we do not define their
- semantics, but only assume that it satisfies
- [extcall_properties]. *)
+(** For functions defined outside the program ([EF_external]),
+ we do not define their semantics, but only assume that it satisfies
+ [extcall_properties].
+ We do the same for built-in functions and runtime support functions that
+ are not described in [Builtins].
+*)
Parameter external_functions_sem: String.string -> signature -> extcall_sem.
@@ -1398,6 +1489,22 @@ Axiom inline_assembly_properties:
(** ** Combined semantics of external calls *)
+Definition builtin_or_external_sem name sg :=
+ match lookup_builtin_function name sg with
+ | Some bf => known_builtin_sem bf
+ | None => external_functions_sem name sg
+ end.
+
+Lemma builtin_or_external_sem_ok: forall name sg,
+ extcall_properties (builtin_or_external_sem name sg) sg.
+Proof.
+ unfold builtin_or_external_sem; intros.
+ destruct (lookup_builtin_function name sg) as [bf|] eqn:L.
+- exploit lookup_builtin_function_sig; eauto. intros EQ; subst sg.
+ apply known_builtin_ok.
+- apply external_functions_properties.
+Qed.
+
(** Combining the semantics given above for the various kinds of external calls,
we define the predicate [external_call] that relates:
- the external function being invoked
@@ -1412,8 +1519,8 @@ This predicate is used in the semantics of all CompCert languages. *)
Definition external_call (ef: external_function): extcall_sem :=
match ef with
| EF_external name sg => external_functions_sem name sg
- | EF_builtin name sg => external_functions_sem name sg
- | EF_runtime name sg => external_functions_sem name sg
+ | EF_builtin name sg => builtin_or_external_sem name sg
+ | EF_runtime name sg => builtin_or_external_sem name sg
| EF_vload chunk => volatile_load_sem chunk
| EF_vstore chunk => volatile_store_sem chunk
| EF_malloc => extcall_malloc_sem
@@ -1431,8 +1538,8 @@ Theorem external_call_spec:
Proof.
intros. unfold external_call, ef_sig; destruct ef.
apply external_functions_properties.
- apply external_functions_properties.
- apply external_functions_properties.
+ apply builtin_or_external_sem_ok.
+ apply builtin_or_external_sem_ok.
apply volatile_load_ok.
apply volatile_store_ok.
apply extcall_malloc_ok.
@@ -1444,7 +1551,7 @@ Proof.
apply extcall_debug_ok.
Qed.
-Definition external_call_well_typed ef := ec_well_typed (external_call_spec ef).
+Definition external_call_well_typed_gen ef := ec_well_typed (external_call_spec ef).
Definition external_call_symbols_preserved ef := ec_symbols_preserved (external_call_spec ef).
Definition external_call_valid_block ef := ec_valid_block (external_call_spec ef).
Definition external_call_max_perm ef := ec_max_perm (external_call_spec ef).
@@ -1455,6 +1562,16 @@ Definition external_call_trace_length ef := ec_trace_length (external_call_spec
Definition external_call_receptive ef := ec_receptive (external_call_spec ef).
Definition external_call_determ ef := ec_determ (external_call_spec ef).
+(** Corollary of [external_call_well_typed_gen]. *)
+
+Lemma external_call_well_typed:
+ forall ef ge vargs m1 t vres m2,
+ external_call ef ge vargs m1 t vres m2 ->
+ Val.has_type vres (proj_sig_res (ef_sig ef)).
+Proof.
+ intros. apply Val.has_proj_rettype. eapply external_call_well_typed_gen; eauto.
+Qed.
+
(** Corollary of [external_call_valid_block]. *)
Lemma external_call_nextblock:
diff --git a/common/Memdata.v b/common/Memdata.v
index a9ed48b4..a09b90f5 100644
--- a/common/Memdata.v
+++ b/common/Memdata.v
@@ -17,6 +17,7 @@
(** In-memory representation of values. *)
Require Import Coqlib.
+Require Import Zbits.
Require Archi.
Require Import AST.
Require Import Integers.
@@ -43,6 +44,13 @@ Definition size_chunk (chunk: memory_chunk) : Z :=
| Many64 => 8
end.
+Definition largest_size_chunk := 8.
+
+Lemma max_size_chunk: forall chunk, size_chunk chunk <= 8.
+Proof.
+ destruct chunk; simpl; omega.
+Qed.
+
Lemma size_chunk_pos:
forall chunk, size_chunk chunk > 0.
Proof.
@@ -50,7 +58,7 @@ Proof.
Qed.
Definition size_chunk_nat (chunk: memory_chunk) : nat :=
- nat_of_Z(size_chunk chunk).
+ Z.to_nat(size_chunk chunk).
Lemma size_chunk_conv:
forall chunk, size_chunk chunk = Z.of_nat (size_chunk_nat chunk).
@@ -258,21 +266,21 @@ Lemma decode_encode_int_4:
forall x, Int.repr (decode_int (encode_int 4 (Int.unsigned x))) = x.
Proof.
intros. rewrite decode_encode_int. transitivity (Int.repr (Int.unsigned x)).
- decEq. apply Zmod_small. apply Int.unsigned_range. apply Int.repr_unsigned.
+ decEq. apply Z.mod_small. apply Int.unsigned_range. apply Int.repr_unsigned.
Qed.
Lemma decode_encode_int_8:
forall x, Int64.repr (decode_int (encode_int 8 (Int64.unsigned x))) = x.
Proof.
intros. rewrite decode_encode_int. transitivity (Int64.repr (Int64.unsigned x)).
- decEq. apply Zmod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned.
+ decEq. apply Z.mod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned.
Qed.
(** A length-[n] encoding depends only on the low [8*n] bits of the integer. *)
Lemma bytes_of_int_mod:
forall n x y,
- Int.eqmod (two_p (Z.of_nat n * 8)) x y ->
+ eqmod (two_p (Z.of_nat n * 8)) x y ->
bytes_of_int n x = bytes_of_int n y.
Proof.
induction n.
@@ -284,7 +292,7 @@ Proof.
intro EQM.
simpl; decEq.
apply Byte.eqm_samerepr. red.
- eapply Int.eqmod_divides; eauto. apply Z.divide_factor_r.
+ eapply eqmod_divides; eauto. apply Z.divide_factor_r.
apply IHn.
destruct EQM as [k EQ]. exists k. rewrite EQ.
rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega.
@@ -292,7 +300,7 @@ Qed.
Lemma encode_int_8_mod:
forall x y,
- Int.eqmod (two_p 8) x y ->
+ eqmod (two_p 8) x y ->
encode_int 1%nat x = encode_int 1%nat y.
Proof.
intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
@@ -300,7 +308,7 @@ Qed.
Lemma encode_int_16_mod:
forall x y,
- Int.eqmod (two_p 16) x y ->
+ eqmod (two_p 16) x y ->
encode_int 2%nat x = encode_int 2%nat y.
Proof.
intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
@@ -546,18 +554,26 @@ Proof.
destruct v1; auto.
Qed.
-Lemma decode_val_type:
+Lemma decode_val_rettype:
forall chunk cl,
- Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
+ Val.has_rettype (decode_val chunk cl) (rettype_of_chunk chunk).
Proof.
intros. unfold decode_val.
destruct (proj_bytes cl).
- destruct chunk; simpl; auto.
-Local Opaque Val.load_result.
+- destruct chunk; simpl; rewrite ? Int.sign_ext_idem, ? Int.zero_ext_idem by omega; auto.
+- Local Opaque Val.load_result.
destruct chunk; simpl;
(exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)).
Qed.
+Lemma decode_val_type:
+ forall chunk cl,
+ Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
+Proof.
+ intros. rewrite <- proj_rettype_of_chunk.
+ apply Val.has_proj_rettype. apply decode_val_rettype.
+Qed.
+
Lemma encode_val_int8_signed_unsigned:
forall v, encode_val Mint8signed v = encode_val Mint8unsigned v.
Proof.
@@ -606,11 +622,9 @@ Lemma decode_val_cast:
| _ => True
end.
Proof.
- unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto.
- unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
- unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
- unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
- unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
+ intros.
+ assert (A: Val.has_rettype v (rettype_of_chunk chunk)) by apply decode_val_rettype.
+ destruct chunk; auto; simpl in A; destruct v; try contradiction; simpl; congruence.
Qed.
(** Pointers cannot be forged. *)
diff --git a/common/Memory.v b/common/Memory.v
index 2cf1c3ab..cd8a2001 100644
--- a/common/Memory.v
+++ b/common/Memory.v
@@ -38,6 +38,10 @@ Require Import Floats.
Require Import Values.
Require Export Memdata.
Require Export Memtype.
+Require Import Lia.
+
+Definition default_notrap_load_value (chunk : memory_chunk) := Vundef.
+
(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
@@ -284,7 +288,7 @@ Lemma valid_access_dec:
Proof.
intros.
destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Cur p).
- destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)).
+ destruct (Zdivide_dec (align_chunk chunk) ofs).
left; constructor; auto.
right; red; intro V; inv V; contradiction.
right; red; intro V; inv V; contradiction.
@@ -460,7 +464,7 @@ Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val :=
Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list memval) :=
if range_perm_dec m b ofs (ofs + n) Cur Readable
- then Some (getN (nat_of_Z n) ofs (m.(mem_contents)#b))
+ then Some (getN (Z.to_nat n) ofs (m.(mem_contents)#b))
else None.
(** Memory stores. *)
@@ -538,6 +542,48 @@ Proof.
induction vl; simpl; intros. auto. rewrite IHvl. auto.
Qed.
+Remark set_setN_swap_disjoint:
+ forall vl: list memval,
+ forall v: memval,
+ forall m : ZMap.t memval,
+ forall p pl: Z,
+ ~ (Intv.In p (pl, pl + Z.of_nat (length vl))) ->
+ (setN vl pl (ZMap.set p v m)) = (ZMap.set p v (setN vl pl m)).
+Proof.
+ induction vl; simpl; trivial.
+ intros.
+ unfold Intv.In in *; simpl in *.
+ rewrite ZMap.set_disjoint by lia.
+ apply IHvl.
+ lia.
+Qed.
+
+Lemma setN_swap_disjoint:
+ forall vl1 vl2: list memval,
+ forall m : ZMap.t memval,
+ forall p1 p2: Z,
+ Intv.disjoint (p1, p1 + Z.of_nat (length vl1))
+ (p2, p2 + Z.of_nat (length vl2)) ->
+ (setN vl1 p1 (setN vl2 p2 m)) = (setN vl2 p2 (setN vl1 p1 m)).
+Proof.
+ induction vl1; simpl; trivial.
+ intros until p2. intro DISJOINT.
+ rewrite <- set_setN_swap_disjoint.
+ { rewrite IHvl1.
+ reflexivity.
+ unfold Intv.disjoint, Intv.In in *.
+ simpl in *.
+ intro.
+ intro BOUNDS.
+ apply DISJOINT.
+ lia.
+ }
+ unfold Intv.disjoint, Intv.In in *.
+ simpl in *.
+ apply DISJOINT.
+ lia.
+Qed.
+
(** [store chunk m b ofs v] perform a write in memory state [m].
Value [v] is stored at address [b] and offset [ofs].
Return the updated memory store, or [None] if the accessed bytes
@@ -682,6 +728,15 @@ Proof.
apply decode_val_type.
Qed.
+Theorem load_rettype:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ Val.has_rettype v (rettype_of_chunk chunk).
+Proof.
+ intros. exploit load_result; eauto; intros. rewrite H0.
+ apply decode_val_rettype.
+Qed.
+
Theorem load_cast:
forall m chunk b ofs v,
load chunk m b ofs = Some v ->
@@ -780,7 +835,7 @@ Qed.
Theorem loadbytes_length:
forall m b ofs n bytes,
loadbytes m b ofs n = Some bytes ->
- length bytes = nat_of_Z n.
+ length bytes = Z.to_nat n.
Proof.
unfold loadbytes; intros.
destruct (range_perm_dec m b ofs (ofs + n) Cur Readable); try congruence.
@@ -791,7 +846,7 @@ Theorem loadbytes_empty:
forall m b ofs n,
n <= 0 -> loadbytes m b ofs n = Some nil.
Proof.
- intros. unfold loadbytes. rewrite pred_dec_true. rewrite nat_of_Z_neg; auto.
+ intros. unfold loadbytes. rewrite pred_dec_true. rewrite Z_to_nat_neg; auto.
red; intros. omegaContradiction.
Qed.
@@ -816,8 +871,8 @@ Proof.
unfold loadbytes; intros.
destruct (range_perm_dec m b ofs (ofs + n1) Cur Readable); try congruence.
destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Cur Readable); try congruence.
- rewrite pred_dec_true. rewrite nat_of_Z_plus; auto.
- rewrite getN_concat. rewrite nat_of_Z_eq; auto.
+ rewrite pred_dec_true. rewrite Z2Nat.inj_add by omega.
+ rewrite getN_concat. rewrite Z2Nat.id by omega.
congruence.
red; intros.
assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by omega.
@@ -836,8 +891,8 @@ Proof.
unfold loadbytes; intros.
destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Cur Readable);
try congruence.
- rewrite nat_of_Z_plus in H; auto. rewrite getN_concat in H.
- rewrite nat_of_Z_eq in H; auto.
+ rewrite Z2Nat.inj_add in H by omega. rewrite getN_concat in H.
+ rewrite Z2Nat.id in H by omega.
repeat rewrite pred_dec_true.
econstructor; econstructor.
split. reflexivity. split. reflexivity. congruence.
@@ -887,11 +942,11 @@ Proof.
intros (bytes1 & bytes2 & LB1 & LB2 & APP).
change 4 with (size_chunk Mint32) in LB1.
exploit loadbytes_load. eexact LB1.
- simpl. apply Zdivides_trans with 8; auto. exists 2; auto.
+ simpl. apply Z.divide_trans with 8; auto. exists 2; auto.
intros L1.
change 4 with (size_chunk Mint32) in LB2.
exploit loadbytes_load. eexact LB2.
- simpl. apply Z.divide_add_r. apply Zdivides_trans with 8; auto. exists 2; auto. exists 1; auto.
+ simpl. apply Z.divide_add_r. apply Z.divide_trans with 8; auto. exists 2; auto. exists 1; auto.
intros L2.
exists (decode_val Mint32 (if Archi.big_endian then bytes1 else bytes2));
exists (decode_val Mint32 (if Archi.big_endian then bytes2 else bytes1)).
@@ -1106,7 +1161,7 @@ Proof.
assert (valid_access m2 chunk b ofs Readable) by eauto with mem.
unfold loadbytes. rewrite pred_dec_true. rewrite store_mem_contents; simpl.
rewrite PMap.gss.
- replace (nat_of_Z (size_chunk chunk)) with (length (encode_val chunk v)).
+ replace (Z.to_nat (size_chunk chunk)) with (length (encode_val chunk v)).
rewrite getN_setN_same. auto.
rewrite encode_val_length. auto.
apply H.
@@ -1127,10 +1182,10 @@ Proof.
rewrite PMap.gsspec. destruct (peq b' b). subst b'.
destruct H. congruence.
destruct (zle n 0) as [z | n0].
- rewrite (nat_of_Z_neg _ z). auto.
+ rewrite (Z_to_nat_neg _ z). auto.
destruct H. omegaContradiction.
apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv.
- rewrite nat_of_Z_eq. auto. omega.
+ rewrite Z2Nat.id. auto. omega.
auto.
red; intros. eauto with mem.
rewrite pred_dec_false. auto.
@@ -1169,6 +1224,106 @@ Local Hint Resolve store_valid_block_1 store_valid_block_2: mem.
Local Hint Resolve store_valid_access_1 store_valid_access_2
store_valid_access_3: mem.
+Remark mem_same_proof_irr :
+ forall m1 m2 : mem,
+ (mem_contents m1) = (mem_contents m2) ->
+ (mem_access m1) = (mem_access m2) ->
+ (nextblock m1) = (nextblock m2) ->
+ m1 = m2.
+Proof.
+ destruct m1 as [contents1 access1 nextblock1 access_max1 nextblock_noaccess1 default1].
+ destruct m2 as [contents2 access2 nextblock2 access_max2 nextblock_noaccess2 default2].
+ simpl.
+ intros.
+ subst contents2.
+ subst access2.
+ subst nextblock2.
+ f_equal; apply proof_irr.
+Qed.
+
+Theorem store_store_other:
+ forall chunk b ofs v chunk' b' ofs' v' m0 m1 m1',
+ b' <> b
+ \/ ofs' + size_chunk chunk' <= ofs
+ \/ ofs + size_chunk chunk <= ofs' ->
+ store chunk m0 b ofs v = Some m1 ->
+ store chunk' m0 b' ofs' v' = Some m1' ->
+ store chunk' m1 b' ofs' v' =
+ store chunk m1' b ofs v.
+Proof.
+ intros until m1'.
+ intro DISJOINT.
+ intros W0 W0'.
+ assert (valid_access m1' chunk b ofs Writable) as WRITEABLE1' by eauto with mem.
+ (* {
+ eapply store_valid_access_1.
+ apply W0'.
+ eapply store_valid_access_3.
+ apply W0.
+ } *)
+ assert (valid_access m1 chunk' b' ofs' Writable) as WRITABLE1 by eauto with mem.
+ (* {
+ eapply store_valid_access_1.
+ apply W0.
+ eapply store_valid_access_3.
+ apply W0'.
+ } *)
+ unfold store in *.
+ destruct (valid_access_dec m0 chunk b ofs Writable).
+ 2: congruence.
+ destruct (valid_access_dec m1 chunk' b' ofs' Writable).
+ 2: contradiction.
+ destruct (valid_access_dec m0 chunk' b' ofs' Writable).
+ 2: congruence.
+ destruct (valid_access_dec m1' chunk b ofs Writable).
+ 2: contradiction.
+ f_equal.
+ inv W0; simpl in *.
+ inv W0'; simpl in *.
+ apply mem_same_proof_irr; simpl; trivial.
+ destruct (eq_block b b').
+ { subst b'.
+ rewrite PMap.gss.
+ rewrite PMap.gss.
+ rewrite PMap.set2.
+ rewrite PMap.set2.
+ f_equal.
+ apply setN_swap_disjoint.
+ unfold Intv.disjoint.
+ rewrite encode_val_length.
+ rewrite <- size_chunk_conv.
+ rewrite encode_val_length.
+ rewrite <- size_chunk_conv.
+ unfold Intv.In; simpl.
+ intros.
+ destruct DISJOINT. contradiction.
+ lia.
+ }
+ {
+ rewrite PMap.set_disjoint by congruence.
+ rewrite PMap.gso by congruence.
+ rewrite PMap.gso by congruence.
+ reflexivity.
+ }
+Qed.
+
+Section STOREV.
+Variable chunk: memory_chunk.
+Variable m1: mem.
+Variables addr v: val.
+Variable m2: mem.
+Hypothesis STORE: storev chunk m1 addr v = Some m2.
+
+
+Theorem loadv_storev_same:
+ loadv chunk m2 addr = Some (Val.load_result chunk v).
+Proof.
+ destruct addr; simpl in *; try discriminate.
+ eapply load_store_same.
+ eassumption.
+Qed.
+End STOREV.
+
Lemma load_store_overlap:
forall chunk m1 b ofs v m2 chunk' ofs' v',
store chunk m1 b ofs v = Some m2 ->
@@ -1523,7 +1678,7 @@ Proof.
destruct (range_perm_dec m1 b ofs (ofs + Z.of_nat (length bytes)) Cur Writable);
try discriminate.
rewrite pred_dec_true.
- decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite nat_of_Z_of_nat.
+ decEq. inv STORE2; simpl. rewrite PMap.gss. rewrite Nat2Z.id.
apply getN_setN_same.
red; eauto with mem.
Qed.
@@ -1539,7 +1694,7 @@ Proof.
rewrite pred_dec_true.
rewrite storebytes_mem_contents. decEq.
rewrite PMap.gsspec. destruct (peq b' b). subst b'.
- apply getN_setN_disjoint. rewrite nat_of_Z_eq; auto. intuition congruence.
+ apply getN_setN_disjoint. rewrite Z2Nat.id by omega. intuition congruence.
auto.
red; auto with mem.
apply pred_dec_false.
@@ -1644,9 +1799,9 @@ Proof.
rewrite encode_val_length in SB2. simpl in SB2.
exists m1; split.
apply storebytes_store. exact SB1.
- simpl. apply Zdivides_trans with 8; auto. exists 2; auto.
+ simpl. apply Z.divide_trans with 8; auto. exists 2; auto.
apply storebytes_store. exact SB2.
- simpl. apply Z.divide_add_r. apply Zdivides_trans with 8; auto. exists 2; auto. exists 1; auto.
+ simpl. apply Z.divide_add_r. apply Z.divide_trans with 8; auto. exists 2; auto. exists 1; auto.
Qed.
Theorem storev_int64_split:
@@ -1867,7 +2022,7 @@ Proof.
unfold loadbytes; intros. destruct (range_perm_dec m2 b ofs (ofs + n) Cur Readable); inv H.
revert H0.
injection ALLOC; intros A B. rewrite <- A; rewrite <- B; simpl. rewrite PMap.gss.
- generalize (nat_of_Z n) ofs. induction n0; simpl; intros.
+ generalize (Z.to_nat n) ofs. induction n0; simpl; intros.
contradiction.
rewrite ZMap.gi in H0. destruct H0; eauto.
Qed.
@@ -2342,13 +2497,13 @@ Lemma loadbytes_inj:
Proof.
intros. unfold loadbytes in *.
destruct (range_perm_dec m1 b1 ofs (ofs + len) Cur Readable); inv H0.
- exists (getN (nat_of_Z len) (ofs + delta) (m2.(mem_contents)#b2)).
+ exists (getN (Z.to_nat len) (ofs + delta) (m2.(mem_contents)#b2)).
split. apply pred_dec_true.
replace (ofs + delta + len) with ((ofs + len) + delta) by omega.
eapply range_perm_inj; eauto with mem.
apply getN_inj; auto.
- destruct (zle 0 len). rewrite nat_of_Z_eq; auto. omega.
- rewrite nat_of_Z_neg. simpl. red; intros; omegaContradiction. omega.
+ destruct (zle 0 len). rewrite Z2Nat.id by omega. auto.
+ rewrite Z_to_nat_neg by omega. simpl. red; intros; omegaContradiction.
Qed.
(** Preservation of stores. *)
@@ -4340,7 +4495,7 @@ Proof.
+ unfold loadbytes. destruct H.
destruct (range_perm_dec m b ofs (ofs + n) Cur Readable).
rewrite pred_dec_true. f_equal.
- apply getN_exten. intros. rewrite nat_of_Z_eq in H by omega.
+ apply getN_exten. intros. rewrite Z2Nat.id in H by omega.
apply unchanged_on_contents0; auto.
red; intros. apply unchanged_on_perm0; auto.
rewrite pred_dec_false. auto.
diff --git a/common/Memtype.v b/common/Memtype.v
index ae4fa5fd..ca9c6f1f 100644
--- a/common/Memtype.v
+++ b/common/Memtype.v
@@ -104,7 +104,7 @@ Parameter alloc: forall (m: mem) (lo hi: Z), mem * block.
(** [free m b lo hi] frees (deallocates) the range of offsets from [lo]
included to [hi] excluded in block [b]. Returns the updated memory
- state, or [None] if the freed addresses are not writable. *)
+ state, or [None] if the freed addresses are not freeable. *)
Parameter free: forall (m: mem) (b: block) (lo hi: Z), option mem.
(** [load chunk m b ofs] reads a memory quantity [chunk] from
@@ -300,6 +300,11 @@ Axiom load_type:
load chunk m b ofs = Some v ->
Val.has_type v (type_of_chunk chunk).
+Axiom load_rettype:
+ forall m chunk b ofs v,
+ load chunk m b ofs = Some v ->
+ Val.has_rettype v (rettype_of_chunk chunk).
+
(** For a small integer or float type, the value returned by [load]
is invariant under the corresponding cast. *)
Axiom load_cast:
@@ -358,7 +363,7 @@ Axiom load_loadbytes:
Axiom loadbytes_length:
forall m b ofs n bytes,
loadbytes m b ofs n = Some bytes ->
- length bytes = nat_of_Z n.
+ length bytes = Z.to_nat n.
Axiom loadbytes_empty:
forall m b ofs n,
diff --git a/common/PrintAST.ml b/common/PrintAST.ml
index e477957a..3f718428 100644
--- a/common/PrintAST.ml
+++ b/common/PrintAST.ml
@@ -27,6 +27,14 @@ let name_of_type = function
| Tany32 -> "any32"
| Tany64 -> "any64"
+let name_of_rettype = function
+ | Tret t -> name_of_type t
+ | Tvoid -> "void"
+ | Tint8signed -> "int8s"
+ | Tint8unsigned -> "int8u"
+ | Tint16signed -> "int16s"
+ | Tint16unsigned -> "int16u"
+
let name_of_chunk = function
| Mint8signed -> "int8s"
| Mint8unsigned -> "int8u"
@@ -90,3 +98,7 @@ let rec print_builtin_res px oc = function
fprintf oc "splitlong(%a, %a)"
(print_builtin_res px) hi (print_builtin_res px) lo
+let print_trapping_mode oc = function
+ | TRAP -> ()
+ | NOTRAP -> output_string oc " [notrap]"
+
diff --git a/common/Sections.ml b/common/Sections.ml
index 30be9e69..839128a5 100644
--- a/common/Sections.ml
+++ b/common/Sections.ml
@@ -160,9 +160,22 @@ let gcc_section name readonly exec =
sec_writable = not readonly; sec_executable = exec;
sec_access = Access_default }
+(* Check and extract whether a section was given as attribute *)
+
+let get_attr_section loc attr =
+ match Cutil.find_custom_attributes ["section"; "__section__"] attr with
+ | [] -> None
+ | [[C.AString name]] -> Some name
+ | [[_]] ->
+ Diagnostics.error loc "'section' attribute requires a string";
+ None
+ | _ ->
+ Diagnostics.error loc "ambiguous 'section' attribute";
+ None
+
(* Determine section for a variable definition *)
-let for_variable env id ty init =
+let for_variable env loc id ty init =
let attr = Cutil.attributes_of_type env ty in
let readonly = List.mem C.AConst attr && not(List.mem C.AVolatile attr) in
let si =
@@ -170,11 +183,11 @@ let for_variable env id ty init =
(* 1- Section explicitly associated with #use_section *)
Hashtbl.find use_section_table id
with Not_found ->
- match Cutil.find_custom_attributes ["section"; "__section__"] attr with
- | [[C.AString name]] ->
+ match get_attr_section loc attr with
+ | Some name ->
(* 2- Section given as an attribute, gcc-style *)
gcc_section name readonly false
- | _ ->
+ | None ->
(* 3- Default section appropriate for size and const-ness *)
let size =
match Cutil.sizeof env ty with Some sz -> sz | None -> max_int in
@@ -190,17 +203,17 @@ let for_variable env id ty init =
(* Determine sections for a function definition *)
-let for_function env id attr =
+let for_function env loc id attr =
let si_code =
try
(* 1- Section explicitly associated with #use_section *)
Hashtbl.find use_section_table id
with Not_found ->
- match Cutil.find_custom_attributes ["section"; "__section__"] attr with
- | [[C.AString name]] ->
+ match get_attr_section loc attr with
+ | Some name ->
(* 2- Section given as an attribute, gcc-style *)
gcc_section name true true
- | _ ->
+ | None ->
(* 3- Default section *)
try
Hashtbl.find current_section_table "CODE"
diff --git a/common/Sections.mli b/common/Sections.mli
index bc97814d..d9fd9239 100644
--- a/common/Sections.mli
+++ b/common/Sections.mli
@@ -46,7 +46,7 @@ val define_section:
-> ?writable:bool -> ?executable:bool -> ?access:access_mode -> unit -> unit
val use_section_for: AST.ident -> string -> bool
-val for_variable: Env.t -> AST.ident -> C.typ -> bool ->
+val for_variable: Env.t -> C.location -> AST.ident -> C.typ -> bool ->
section_name * access_mode
-val for_function: Env.t -> AST.ident -> C.attributes -> section_name list
+val for_function: Env.t -> C.location -> AST.ident -> C.attributes -> section_name list
val for_stringlit: unit -> section_name
diff --git a/common/Separation.v b/common/Separation.v
index a9642d72..27065d1f 100644
--- a/common/Separation.v
+++ b/common/Separation.v
@@ -113,7 +113,7 @@ Proof.
intros P Q [[A B] [C D]]. split; auto.
Qed.
-Hint Resolve massert_imp_refl massert_eqv_refl.
+Hint Resolve massert_imp_refl massert_eqv_refl : core.
(** * Separating conjunction *)
@@ -702,7 +702,7 @@ Proof.
- intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). omega.
- intros. apply Mem.perm_implies with Freeable; auto with mem.
eapply Mem.perm_alloc_2; eauto. xomega.
-- red; intros. apply Zdivides_trans with 8; auto.
+- red; intros. apply Z.divide_trans with 8; auto.
exists (8 / align_chunk chunk). destruct chunk; reflexivity.
- intros. elim FRESH2. eapply Mem.valid_block_inject_2; eauto.
- intros (j' & INJ' & J1 & J2 & J3).
diff --git a/common/Smallstep.v b/common/Smallstep.v
index c269013b..27ad0a2d 100644
--- a/common/Smallstep.v
+++ b/common/Smallstep.v
@@ -872,6 +872,14 @@ Proof.
intros. eapply sd_determ; eauto.
Qed.
+Lemma sd_determ_3:
+ forall s t s1 s2,
+ Step L s t s1 -> Step L s E0 s2 -> t = E0 /\ s1 = s2.
+Proof.
+ intros. exploit (sd_determ DET). eexact H. eexact H0.
+ intros [A B]. inv A. auto.
+Qed.
+
Lemma star_determinacy:
forall s t s', Star L s t s' ->
forall s'', Star L s t s'' -> Star L s' E0 s'' \/ Star L s'' E0 s'.
@@ -895,6 +903,171 @@ Qed.
End DETERMINACY.
+(** Extra simulation diagrams for determinate languages. *)
+
+Section FORWARD_SIMU_DETERM.
+
+Variable L1: semantics.
+Variable L2: semantics.
+
+Hypothesis L1det: determinate L1.
+
+Variable index: Type.
+Variable order: index -> index -> Prop.
+Hypothesis wf_order: well_founded order.
+
+Variable match_states: index -> state L1 -> state L2 -> Prop.
+
+Hypothesis match_initial_states:
+ forall s1, initial_state L1 s1 ->
+ exists i s2, initial_state L2 s2 /\ match_states i s1 s2.
+
+Hypothesis match_final_states:
+ forall i s1 s2 r,
+ match_states i s1 s2 ->
+ final_state L1 s1 r ->
+ final_state L2 s2 r.
+
+Hypothesis simulation:
+ forall s1 t s1', Step L1 s1 t s1' ->
+ forall i s2, match_states i s1 s2 ->
+ exists s1'' i' s2',
+ Star L1 s1' E0 s1''
+ /\ (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order i' i))
+ /\ match_states i' s1'' s2'.
+
+Hypothesis public_preserved:
+ forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.
+
+Inductive match_states_later: index * nat -> state L1 -> state L2 -> Prop :=
+| msl_now: forall i s1 s2,
+ match_states i s1 s2 -> match_states_later (i, O) s1 s2
+| msl_later: forall i n s1 s1' s2,
+ Step L1 s1 E0 s1' -> match_states_later (i, n) s1' s2 -> match_states_later (i, S n) s1 s2.
+
+Lemma star_match_states_later:
+ forall s1 s1', Star L1 s1 E0 s1' ->
+ forall i s2, match_states i s1' s2 ->
+ exists n, match_states_later (i, n) s1 s2.
+Proof.
+ intros s10 s10' STAR0. pattern s10, s10'; eapply star_E0_ind; eauto.
+ - intros s1 i s2 M. exists O; constructor; auto.
+ - intros s1 s1' s1'' STEP IH i s2 M.
+ destruct (IH i s2 M) as (n & MS).
+ exists (S n); econstructor; eauto.
+Qed.
+
+Lemma forward_simulation_determ: forward_simulation L1 L2.
+Proof.
+ apply Forward_simulation with (order0 := lex_ord order lt) (match_states0 := match_states_later);
+ constructor.
+- apply wf_lex_ord. apply wf_order. apply lt_wf.
+- intros. exploit match_initial_states; eauto. intros (i & s2 & A & B).
+ exists (i, O), s2; auto using msl_now.
+- intros. inv H.
+ + eapply match_final_states; eauto.
+ + eelim (sd_final_nostep L1det); eauto.
+- intros s1 t s1' A; destruct 1.
+ + exploit simulation; eauto. intros (s1'' & i' & s2' & B & C & D).
+ exploit star_match_states_later; eauto. intros (n & E).
+ exists (i', n), s2'; split; auto.
+ destruct C as [P | [P Q]]; auto using lex_ord_left.
+ + exploit sd_determ_3. eauto. eexact A. eauto. intros [P Q]; subst t s1'0.
+ exists (i, n), s2; split; auto.
+ right; split. apply star_refl. apply lex_ord_right. omega.
+- exact public_preserved.
+Qed.
+
+End FORWARD_SIMU_DETERM.
+
+(** A few useful special cases. *)
+
+Section FORWARD_SIMU_DETERM_DIAGRAMS.
+
+Variable L1: semantics.
+Variable L2: semantics.
+
+Hypothesis L1det: determinate L1.
+
+Variable match_states: state L1 -> state L2 -> Prop.
+
+Hypothesis public_preserved:
+ forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id.
+
+Hypothesis match_initial_states:
+ forall s1, initial_state L1 s1 ->
+ exists s2, initial_state L2 s2 /\ match_states s1 s2.
+
+Hypothesis match_final_states:
+ forall s1 s2 r,
+ match_states s1 s2 ->
+ final_state L1 s1 r ->
+ final_state L2 s2 r.
+
+Section SIMU_DETERM_STAR.
+
+Variable measure: state L1 -> nat.
+
+Hypothesis simulation:
+ forall s1 t s1', Step L1 s1 t s1' ->
+ forall s2, match_states s1 s2 ->
+ exists s1'' s2',
+ Star L1 s1' E0 s1''
+ /\ (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ measure s1'' < measure s1))%nat
+ /\ match_states s1'' s2'.
+
+Lemma forward_simulation_determ_star: forward_simulation L1 L2.
+Proof.
+ apply forward_simulation_determ with
+ (match_states := fun i s1 s2 => i = s1 /\ match_states s1 s2)
+ (order := ltof _ measure).
+- assumption.
+- apply well_founded_ltof.
+- intros. exploit match_initial_states; eauto. intros (s2 & A & B).
+ exists s1, s2; auto.
+- intros. destruct H. eapply match_final_states; eauto.
+- intros. destruct H0; subst i.
+ exploit simulation; eauto. intros (s1'' & s2' & A & B & C).
+ exists s1'', s1'', s2'. auto.
+- assumption.
+Qed.
+
+End SIMU_DETERM_STAR.
+
+Section SIMU_DETERM_PLUS.
+
+Hypothesis simulation:
+ forall s1 t s1', Step L1 s1 t s1' ->
+ forall s2, match_states s1 s2 ->
+ exists s1'' s2', Star L1 s1' E0 s1'' /\ Plus L2 s2 t s2' /\ match_states s1'' s2'.
+
+Lemma forward_simulation_determ_plus: forward_simulation L1 L2.
+Proof.
+ apply forward_simulation_determ_star with (measure := fun _ => O).
+ intros. exploit simulation; eauto. intros (s1'' & s2' & A & B & C).
+ exists s1'', s2'; auto.
+Qed.
+
+End SIMU_DETERM_PLUS.
+
+Section SIMU_DETERM_ONE.
+
+Hypothesis simulation:
+ forall s1 t s1', Step L1 s1 t s1' ->
+ forall s2, match_states s1 s2 ->
+ exists s1'' s2', Star L1 s1' E0 s1'' /\ Step L2 s2 t s2' /\ match_states s1'' s2'.
+
+Lemma forward_simulation_determ_one: forward_simulation L1 L2.
+Proof.
+ apply forward_simulation_determ_plus.
+ intros. exploit simulation; eauto. intros (s1'' & s2' & A & B & C).
+ exists s1'', s2'; auto using plus_one.
+Qed.
+
+End SIMU_DETERM_ONE.
+
+End FORWARD_SIMU_DETERM_DIAGRAMS.
+
(** * Backward simulations between two transition semantics. *)
Definition safe (L: semantics) (s: state L) : Prop :=
diff --git a/common/Switch.v b/common/Switch.v
index 0ef91d60..5a6d4c63 100644
--- a/common/Switch.v
+++ b/common/Switch.v
@@ -288,10 +288,10 @@ Lemma validate_jumptable_correct:
Proof.
intros.
rewrite (validate_jumptable_correct_rec cases tbl ofs); auto.
-- f_equal. f_equal. rewrite Zmod_small. omega.
+- f_equal. f_equal. rewrite Z.mod_small. omega.
destruct (zle ofs v). omega.
assert (M: ((v - ofs) + 1 * modulus) mod modulus = (v - ofs) + modulus).
- { rewrite Zmod_small. omega. omega. }
+ { rewrite Z.mod_small. omega. omega. }
rewrite Z_mod_plus in M by auto. rewrite M in H0. omega.
- generalize (Z_mod_lt (v - ofs) modulus modulus_pos). omega.
Qed.
@@ -331,7 +331,7 @@ Proof.
rewrite (split_between_prop v _ _ _ _ _ _ EQ).
assert (0 <= (v - ofs) mod modulus < modulus) by (apply Z_mod_lt; omega).
destruct (zlt ((v - ofs) mod modulus) sz).
- rewrite Zmod_small by omega. eapply validate_jumptable_correct; eauto.
+ rewrite Z.mod_small by omega. eapply validate_jumptable_correct; eauto.
eapply IHt; eauto.
Qed.
diff --git a/common/Values.v b/common/Values.v
index 127d1085..6401ba52 100644
--- a/common/Values.v
+++ b/common/Values.v
@@ -132,6 +132,40 @@ Proof.
simpl in *. InvBooleans. destruct H0. split; auto. eapply has_subtype; eauto.
Qed.
+Definition has_type_dec (v: val) (t: typ) : { has_type v t } + { ~ has_type v t }.
+Proof.
+ unfold has_type; destruct v.
+- auto.
+- destruct t; auto.
+- destruct t; auto.
+- destruct t; auto.
+- destruct t; auto.
+- destruct t.
+ apply bool_dec.
+ auto.
+ apply bool_dec.
+ auto.
+ apply bool_dec.
+ auto.
+Defined.
+
+Definition has_rettype (v: val) (r: rettype) : Prop :=
+ match r, v with
+ | Tret t, _ => has_type v t
+ | Tint8signed, Vint n => n = Int.sign_ext 8 n
+ | Tint8unsigned, Vint n => n = Int.zero_ext 8 n
+ | Tint16signed, Vint n => n = Int.sign_ext 16 n
+ | Tint16unsigned, Vint n => n = Int.zero_ext 16 n
+ | _, Vundef => True
+ | _, _ => False
+ end.
+
+Lemma has_proj_rettype: forall v r,
+ has_rettype v r -> has_type v (proj_rettype r).
+Proof.
+ destruct r; simpl; intros; auto; destruct v; try contradiction; exact I.
+Qed.
+
(** Truth values. Non-zero integers are treated as [True].
The integer 0 (also used to represent the null pointer) is [False].
Other values are neither true nor false. *)
@@ -766,6 +800,17 @@ Definition rolml (v: val) (amount: int) (mask: int64): val :=
| _ => Vundef
end.
+Definition zero_ext_l (nbits: Z) (v: val) : val :=
+ match v with
+ | Vlong n => Vlong(Int64.zero_ext nbits n)
+ | _ => Vundef
+ end.
+
+Definition sign_ext_l (nbits: Z) (v: val) : val :=
+ match v with
+ | Vlong n => Vlong(Int64.sign_ext nbits n)
+ | _ => Vundef
+ end.
(** Comparisons *)
@@ -899,6 +944,55 @@ Definition offset_ptr (v: val) (delta: ptrofs) : val :=
| _ => Vundef
end.
+(** Normalize a value to the given type, turning it into Vundef if it does not
+ match the type. *)
+
+Definition normalize (v: val) (ty: typ) : val :=
+ match v, ty with
+ | Vundef, _ => Vundef
+ | Vint _, Tint => v
+ | Vlong _, Tlong => v
+ | Vfloat _, Tfloat => v
+ | Vsingle _, Tsingle => v
+ | Vptr _ _, (Tint | Tany32) => if Archi.ptr64 then Vundef else v
+ | Vptr _ _, Tlong => if Archi.ptr64 then v else Vundef
+ | (Vint _ | Vsingle _), Tany32 => v
+ | _, Tany64 => v
+ | _, _ => Vundef
+ end.
+
+Lemma normalize_type:
+ forall v ty, has_type (normalize v ty) ty.
+Proof.
+ intros; destruct v; simpl.
+- auto.
+- destruct ty; exact I.
+- destruct ty; exact I.
+- destruct ty; exact I.
+- destruct ty; exact I.
+- unfold has_type; destruct ty, Archi.ptr64; auto.
+Qed.
+
+Lemma normalize_idem:
+ forall v ty, has_type v ty -> normalize v ty = v.
+Proof.
+ unfold has_type, normalize; intros. destruct v.
+- auto.
+- destruct ty; intuition auto.
+- destruct ty; intuition auto.
+- destruct ty; intuition auto.
+- destruct ty; intuition auto.
+- destruct ty, Archi.ptr64; intuition congruence.
+Qed.
+
+(** Select between two values based on the result of a comparison. *)
+
+Definition select (cmp: option bool) (v1 v2: val) (ty: typ) :=
+ match cmp with
+ | Some b => normalize (if b then v1 else v2) ty
+ | None => Vundef
+ end.
+
(** [load_result] reflects the effect of storing a value with a given
memory chunk, then reading it back with the same chunk. Depending
on the chunk and the type of the value, some normalization occurs.
@@ -926,10 +1020,24 @@ Definition load_result (chunk: memory_chunk) (v: val) :=
| _, _ => Vundef
end.
+Lemma load_result_rettype:
+ forall chunk v, has_rettype (load_result chunk v) (rettype_of_chunk chunk).
+Proof.
+ intros. unfold has_rettype; destruct chunk; destruct v; simpl; auto.
+- rewrite Int.sign_ext_idem by omega; auto.
+- rewrite Int.zero_ext_idem by omega; auto.
+- rewrite Int.sign_ext_idem by omega; auto.
+- rewrite Int.zero_ext_idem by omega; auto.
+- destruct Archi.ptr64 eqn:SF; simpl; auto.
+- destruct Archi.ptr64 eqn:SF; simpl; auto.
+- destruct Archi.ptr64 eqn:SF; simpl; auto.
+Qed.
+
Lemma load_result_type:
forall chunk v, has_type (load_result chunk v) (type_of_chunk chunk).
Proof.
- intros. unfold has_type; destruct chunk; destruct v; simpl; auto; destruct Archi.ptr64 eqn:SF; simpl; auto.
+ intros. rewrite <- proj_rettype_of_chunk. apply has_proj_rettype.
+ apply load_result_rettype.
Qed.
Lemma load_result_same:
@@ -1362,6 +1470,60 @@ Proof.
assert (32 < Int.max_unsigned) by reflexivity. omega.
Qed.
+Theorem shrx1_shr:
+ forall x z,
+ shrx x (Vint (Int.repr 1)) = Some z ->
+ z = shr (add x (shru x (Vint (Int.repr 31)))) (Vint (Int.repr 1)).
+Proof.
+ intros. destruct x; simpl in H; try discriminate.
+ change (Int.ltu (Int.repr 1) (Int.repr 31)) with true in H; simpl in H.
+ inversion_clear H.
+ simpl.
+ change (Int.ltu (Int.repr 31) Int.iwordsize) with true; simpl.
+ change (Int.ltu (Int.repr 1) Int.iwordsize) with true; simpl.
+ f_equal.
+ rewrite Int.shrx1_shr by reflexivity.
+ reflexivity.
+Qed.
+
+Theorem shrx_shr_3:
+ forall n x z,
+ shrx x (Vint n) = Some z ->
+ z = (if Int.eq n Int.zero then x else
+ if Int.eq n Int.one
+ then shr (add x (shru x (Vint (Int.repr 31)))) (Vint Int.one)
+ else shr (add x (shru (shr x (Vint (Int.repr 31)))
+ (Vint (Int.sub (Int.repr 32) n))))
+ (Vint n)).
+Proof.
+ intros. destruct x; simpl in H; try discriminate.
+ destruct (Int.ltu n (Int.repr 31)) eqn:LT; inv H.
+ exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 31)) with 31; intros LT'.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. unfold Int.shrx. rewrite Int.shl_zero. unfold Int.divs. change (Int.signed Int.one) with 1.
+ rewrite Z.quot_1_r. rewrite Int.repr_signed; auto.
+- predSpec Int.eq Int.eq_spec n Int.one.
+ * subst n. simpl.
+ change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl.
+ change (Int.ltu Int.one Int.iwordsize) with true. simpl.
+ f_equal.
+ apply Int.shrx1_shr.
+ reflexivity.
+ * clear H0.
+ simpl. change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl.
+ replace (Int.ltu (Int.sub (Int.repr 32) n) Int.iwordsize) with true. simpl.
+ replace (Int.ltu n Int.iwordsize) with true.
+ f_equal; apply Int.shrx_shr_2; assumption.
+ symmetry; apply zlt_true. change (Int.unsigned n < 32); omega.
+ symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 32)) with 32.
+ assert (Int.unsigned n <> 0).
+ { red; intros; elim H.
+ rewrite <- (Int.repr_unsigned n), H0. auto. }
+ rewrite Int.unsigned_repr.
+ change (Int.unsigned Int.iwordsize) with 32; omega.
+ assert (32 < Int.max_unsigned) by reflexivity. omega.
+Qed.
+
Theorem or_rolm:
forall x n m1 m2,
or (rolm x n m1) (rolm x n m2) = rolm x n (Int.or m1 m2).
@@ -1621,6 +1783,58 @@ Proof.
assert (64 < Int.max_unsigned) by reflexivity. omega.
Qed.
+Theorem shrxl1_shrl:
+ forall x z,
+ shrxl x (Vint (Int.repr 1)) = Some z ->
+ z = shrl (addl x (shrlu x (Vint (Int.repr 63)))) (Vint (Int.repr 1)).
+Proof.
+ intros. destruct x; simpl in H; try discriminate.
+ change (Int.ltu (Int.repr 1) (Int.repr 63)) with true in H; simpl in H.
+ inversion_clear H.
+ simpl.
+ change (Int.ltu (Int.repr 63) Int64.iwordsize') with true; simpl.
+ change (Int.ltu (Int.repr 1) Int64.iwordsize') with true; simpl.
+ f_equal.
+ rewrite Int64.shrx'1_shr' by reflexivity.
+ reflexivity.
+Qed.
+
+Theorem shrxl_shrl_3:
+ forall n x z,
+ shrxl x (Vint n) = Some z ->
+ z = (if Int.eq n Int.zero then x else
+ if Int.eq n Int.one
+ then shrl (addl x (shrlu x (Vint (Int.repr 63)))) (Vint Int.one)
+ else shrl (addl x (shrlu (shrl x (Vint (Int.repr 63)))
+ (Vint (Int.sub (Int.repr 64) n))))
+ (Vint n)).
+Proof.
+ intros. destruct x; simpl in H; try discriminate.
+ destruct (Int.ltu n (Int.repr 63)) eqn:LT; inv H.
+ exploit Int.ltu_inv; eauto. change (Int.unsigned (Int.repr 63)) with 63; intros LT'.
+ predSpec Int.eq Int.eq_spec n Int.zero.
+- subst n. unfold Int64.shrx'. rewrite Int64.shl'_zero. unfold Int64.divs. change (Int64.signed Int64.one) with 1.
+ rewrite Z.quot_1_r. rewrite Int64.repr_signed; auto.
+- predSpec Int.eq Int.eq_spec n Int.one.
+ * subst n. simpl.
+ change (Int.ltu (Int.repr 63) Int64.iwordsize') with true. simpl.
+ change (Int.ltu Int.one Int64.iwordsize') with true. simpl.
+ f_equal.
+ apply Int64.shrx'1_shr'.
+ reflexivity.
+ * clear H0.
+simpl. change (Int.ltu (Int.repr 63) Int64.iwordsize') with true. simpl.
+ replace (Int.ltu (Int.sub (Int.repr 64) n) Int64.iwordsize') with true. simpl.
+ replace (Int.ltu n Int64.iwordsize') with true.
+ f_equal; apply Int64.shrx'_shr_2; assumption.
+ symmetry; apply zlt_true. change (Int.unsigned n < 64); omega.
+ symmetry; apply zlt_true. unfold Int.sub. change (Int.unsigned (Int.repr 64)) with 64.
+ assert (Int.unsigned n <> 0). { red; intros; elim H. rewrite <- (Int.repr_unsigned n), H0. auto. }
+ rewrite Int.unsigned_repr.
+ change (Int.unsigned Int64.iwordsize') with 64; omega.
+ assert (64 < Int.max_unsigned) by reflexivity. omega.
+Qed.
+
Theorem negate_cmp_bool:
forall c x y, cmp_bool (negate_comparison c) x y = option_map negb (cmp_bool c x y).
Proof.
@@ -1833,10 +2047,18 @@ Qed.
Lemma zero_ext_and:
forall n v,
- 0 < n < Int.zwordsize ->
+ 0 <= n ->
Val.zero_ext n v = Val.and v (Vint (Int.repr (two_p n - 1))).
Proof.
- intros. destruct v; simpl; auto. decEq. apply Int.zero_ext_and; auto. omega.
+ intros. destruct v; simpl; auto. decEq. apply Int.zero_ext_and; auto.
+Qed.
+
+Lemma zero_ext_andl:
+ forall n v,
+ 0 <= n ->
+ Val.zero_ext_l n v = Val.andl v (Vlong (Int64.repr (two_p n - 1))).
+Proof.
+ intros. destruct v; simpl; auto. decEq. apply Int64.zero_ext_and; auto.
Qed.
Lemma rolm_lt_zero:
@@ -1884,7 +2106,7 @@ Inductive lessdef_list: list val -> list val -> Prop :=
lessdef v1 v2 -> lessdef_list vl1 vl2 ->
lessdef_list (v1 :: vl1) (v2 :: vl2).
-Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons.
+Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons : core.
Lemma lessdef_list_inv:
forall vl1 vl2, lessdef_list vl1 vl2 -> vl1 = vl2 \/ In Vundef vl1.
@@ -2045,6 +2267,36 @@ Proof.
intros. destruct v; simpl; auto. f_equal. apply Ptrofs.add_assoc.
Qed.
+Lemma lessdef_normalize:
+ forall v ty, lessdef (normalize v ty) v.
+Proof.
+ intros. destruct v; simpl.
+ - auto.
+ - destruct ty; auto.
+ - destruct ty; auto.
+ - destruct ty; auto.
+ - destruct ty; auto.
+ - destruct ty, Archi.ptr64; auto.
+Qed.
+
+Lemma normalize_lessdef:
+ forall v v' ty, lessdef v v' -> lessdef (normalize v ty) (normalize v' ty).
+Proof.
+ intros. inv H; auto.
+Qed.
+
+Lemma select_lessdef:
+ forall ob ob' v1 v1' v2 v2' ty,
+ ob = None \/ ob = ob' ->
+ lessdef v1 v1' -> lessdef v2 v2' ->
+ lessdef (select ob v1 v2 ty) (select ob' v1' v2' ty).
+Proof.
+ intros; unfold select. destruct H.
+- subst ob; auto.
+- subst ob'; destruct ob as [b|]; auto.
+ apply normalize_lessdef. destruct b; auto.
+Qed.
+
(** * Values and memory injections *)
(** A memory injection [f] is a function from addresses to either [None]
@@ -2079,7 +2331,7 @@ Inductive inject (mi: meminj): val -> val -> Prop :=
| val_inject_undef: forall v,
inject mi Vundef v.
-Hint Constructors inject.
+Hint Constructors inject : core.
Inductive inject_list (mi: meminj): list val -> list val-> Prop:=
| inject_list_nil :
@@ -2088,7 +2340,7 @@ Inductive inject_list (mi: meminj): list val -> list val-> Prop:=
inject mi v v' -> inject_list mi vl vl'->
inject_list mi (v :: vl) (v' :: vl').
-Hint Resolve inject_list_nil inject_list_cons.
+Hint Resolve inject_list_nil inject_list_cons : core.
Lemma inject_ptrofs:
forall mi i, inject mi (Vptrofs i) (Vptrofs i).
@@ -2096,7 +2348,7 @@ Proof.
unfold Vptrofs; intros. destruct Archi.ptr64; auto.
Qed.
-Hint Resolve inject_ptrofs.
+Hint Resolve inject_ptrofs : core.
Section VAL_INJ_OPS.
@@ -2329,6 +2581,36 @@ Proof.
intros. unfold Val.hiword; inv H; auto.
Qed.
+Lemma normalize_inject:
+ forall v v' ty, inject f v v' -> inject f (normalize v ty) (normalize v' ty).
+Proof.
+ intros. inv H.
+- destruct ty; constructor.
+- destruct ty; constructor.
+- destruct ty; constructor.
+- destruct ty; constructor.
+- simpl. destruct ty.
++ destruct Archi.ptr64; econstructor; eauto.
++ auto.
++ destruct Archi.ptr64; econstructor; eauto.
++ auto.
++ destruct Archi.ptr64; econstructor; eauto.
++ econstructor; eauto.
+- constructor.
+Qed.
+
+Lemma select_inject:
+ forall ob ob' v1 v1' v2 v2' ty,
+ ob = None \/ ob = ob' ->
+ inject f v1 v1' -> inject f v2 v2' ->
+ inject f (select ob v1 v2 ty) (select ob' v1' v2' ty).
+Proof.
+ intros; unfold select. destruct H.
+- subst ob; auto.
+- subst ob'; destruct ob as [b|]; auto.
+ apply normalize_inject. destruct b; auto.
+Qed.
+
End VAL_INJ_OPS.
End Val.
@@ -2369,7 +2651,7 @@ Proof.
constructor. eapply val_inject_incr; eauto. auto.
Qed.
-Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr.
+Hint Resolve inject_incr_refl val_inject_incr val_inject_list_incr : core.
Lemma val_inject_lessdef:
forall v1 v2, Val.lessdef v1 v2 <-> Val.inject (fun b => Some(b, 0)) v1 v2.
diff --git a/config_aarch64.sh b/config_aarch64.sh
new file mode 100755
index 00000000..ded267bf
--- /dev/null
+++ b/config_aarch64.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh aarch64-linux --toolprefix aarch64-linux-gnu- "$@"
diff --git a/config_arm.sh b/config_arm.sh
new file mode 100755
index 00000000..1861e029
--- /dev/null
+++ b/config_arm.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh arm-linux --toolprefix arm-linux-gnueabi- "$@"
diff --git a/config_armhf.sh b/config_armhf.sh
new file mode 100755
index 00000000..8a1302bd
--- /dev/null
+++ b/config_armhf.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh arm-eabihf --toolprefix arm-linux-gnueabihf- "$@"
diff --git a/config_ia32.sh b/config_ia32.sh
new file mode 100755
index 00000000..b40f2b39
--- /dev/null
+++ b/config_ia32.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh ia32-linux "$@"
diff --git a/config_k1c.sh b/config_k1c.sh
new file mode 100755
index 00000000..20408397
--- /dev/null
+++ b/config_k1c.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh k1c-cos "$@"
diff --git a/config_ppc.sh b/config_ppc.sh
new file mode 100755
index 00000000..d597cda5
--- /dev/null
+++ b/config_ppc.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh ppc-linux --toolprefix powerpc-linux-gnu- "$@"
diff --git a/config_ppc64.sh b/config_ppc64.sh
new file mode 100755
index 00000000..df31c18f
--- /dev/null
+++ b/config_ppc64.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh ppc64-linux --toolprefix powerpc64-linux-gnu- "$@"
diff --git a/config_rv32.sh b/config_rv32.sh
new file mode 100755
index 00000000..a5a5cf1c
--- /dev/null
+++ b/config_rv32.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh rv32-linux --toolprefix riscv64-linux-gnu- "$@"
diff --git a/config_rv64.sh b/config_rv64.sh
new file mode 100755
index 00000000..0698c2ff
--- /dev/null
+++ b/config_rv64.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh rv64-linux --toolprefix riscv64-linux-gnu- "$@"
diff --git a/config_simple.sh b/config_simple.sh
new file mode 100755
index 00000000..e2d3844c
--- /dev/null
+++ b/config_simple.sh
@@ -0,0 +1,11 @@
+arch=$1
+shift
+version=`git rev-parse --short HEAD`
+branch=`git rev-parse --abbrev-ref HEAD`
+date=`date -I`
+
+if test "x$CCOMP_INSTALL_PREFIX" = "x" ;
+then CCOMP_INSTALL_PREFIX=/opt/CompCert ;
+fi
+
+./configure --prefix ${CCOMP_INSTALL_PREFIX}/${branch}/${date}_${version}/$arch "$@" $arch
diff --git a/config_x86_64.sh b/config_x86_64.sh
new file mode 100755
index 00000000..b18ec95b
--- /dev/null
+++ b/config_x86_64.sh
@@ -0,0 +1 @@
+exec ./config_simple.sh x86_64-linux "$@"
diff --git a/configure b/configure
index 52fffa63..366ab847 100755
--- a/configure
+++ b/configure
@@ -57,10 +57,12 @@ Supported targets:
rv64-linux (RISC-V 64 bits, Linux)
k1c-mbr (Kalray K1c, bare runtime)
k1c-cos (Kalray K1c, ClusterOS)
+ aarch64-linux (AArch64, i.e. ARMv8 in 64-bit mode, Linux)
manual (edit configuration file by hand)
For x86 targets, the "x86_32-" prefix can also be written "ia32-" or "i386-".
For x86 targets, the "x86_64-" prefix can also be written "amd64-".
+For AArch64 targets, the "aarch64-" prefix can also be written "arm64-".
For PowerPC targets, the "ppc-" prefix can be refined into:
ppc64- PowerPC 64 bits
@@ -179,6 +181,8 @@ case "$target" in
arch="riscV"; model="64"; endianness="little"; bitsize=64;;
k1c-*)
arch="mppa_k1c"; model="64"; endianness="little"; bitsize=64;;
+ aarch64-*|arm64-*)
+ arch="aarch64"; model="default"; endianness="little"; bitsize=64;;
manual)
;;
"")
@@ -453,8 +457,8 @@ if test "$arch" = "mppa_k1c"; then
fi
osupper=`echo $os|tr a-z A-Z`
k1base="k1-$os"
- casm="$k1base-gcc"
- casm_options="$model_options -c"
+ casm="k1-elf-as"
+ casm_options="$model_options"
cc="$k1base-gcc $model_options"
clinker="$k1base-gcc"
bindir="$HOME/.usr/bin"
@@ -466,6 +470,29 @@ if test "$arch" = "mppa_k1c"; then
system="linux"
fi
+#
+# AArch64 (ARMv8 64 bits) Target Configuration
+#
+if test "$arch" = "aarch64"; then
+ case "$target" in
+ linux)
+ abi="standard"
+ casm="${toolprefix}gcc"
+ casm_options="-c"
+ cc="${toolprefix}gcc"
+ clinker="${toolprefix}gcc"
+ clinker_options=""
+ cprepro="${toolprefix}gcc"
+ cprepro_options="-std=c99 -U__GNUC__ -E"
+ libmath="-lm"
+ system="linux";;
+ *)
+ echo "Error: invalid eabi/system '$target' for architecture AArch64." 1>&2
+ echo "$usage" 1>&2
+ exit 2;;
+ esac
+fi
+
#
# Finalize Target Configuration
@@ -541,43 +568,38 @@ missingtools=false
echo "Testing Coq... " | tr -d '\n'
coq_ver=$(${COQBIN}coqc -v 2>/dev/null | sed -n -e 's/The Coq Proof Assistant, version \([^ ]*\).*$/\1/p')
case "$coq_ver" in
- 8.6.1|8.7.0|8.7.1|8.7.2|8.8.0|8.8.1|8.8.2|8.9.0)
+ 8.9.0|8.9.1|8.10.0|8.10.1|8.10.2|8.11.0|8.11.1)
echo "version $coq_ver -- good!";;
?*)
echo "version $coq_ver -- UNSUPPORTED"
if $ignore_coq_version; then
echo "Warning: this version of Coq is unsupported, proceed at your own risks."
else
- echo "Error: CompCert requires one of the following Coq versions: 8.9.0, 8.8.2, 8.8.1, 8.8.0, 8.7.2, 8.7.1, 8.7.0, 8.6.1"
+ echo "Error: CompCert requires one of the following Coq versions: 8.11.1, 8.11.0, 8.10.2, 8.10.1, 8.10.0, 8.9.1, 8.9.0"
missingtools=true
fi;;
"")
echo "NOT FOUND"
- echo "Error: make sure Coq version 8.9.0 is installed."
+ echo "Error: make sure Coq version 8.9.1 is installed."
missingtools=true;;
esac
echo "Testing OCaml... " | tr -d '\n'
ocaml_ver=`ocamlopt -version 2>/dev/null`
case "$ocaml_ver" in
- 4.00.*|4.01.*)
+ 4.00.*|4.01.*| 4.02.*|4.03.*|4.04.*)
echo "version $ocaml_ver -- UNSUPPORTED"
- echo "Error: CompCert requires OCaml version 4.02 or later."
+ echo "Error: CompCert requires OCaml version 4.05 or later."
missingtools=true;;
- 4.02.*|4.03.*|4.04.*)
- echo "version $ocaml_ver -- good!"
- echo "WARNING: some Intel processors of the Skylake and Kaby Lake generations"
- echo "have a hardware bug that can be triggered by this version of OCaml."
- echo "To avoid this risk, it is recommended to use OCaml 4.05 or later.";;
- 4.0*)
+ 4.*)
echo "version $ocaml_ver -- good!";;
?.*)
echo "version $ocaml_ver -- UNSUPPORTED"
- echo "Error: CompCert requires OCaml version 4.02 or later."
+ echo "Error: CompCert requires OCaml version 4.05 or later."
missingtools=true;;
*)
echo "NOT FOUND"
- echo "Error: make sure OCaml version 4.02 or later is installed."
+ echo "Error: make sure OCaml version 4.05 or later is installed."
missingtools=true;;
esac
@@ -591,23 +613,23 @@ else
ocaml_opt_comp=false
fi
-MENHIR_REQUIRED=20161201
-MENHIR_NEW_API=20180530
-MENHIR_MAX=20181113
-menhir_flags=''
+MENHIR_REQUIRED=20190626
echo "Testing Menhir... " | tr -d '\n'
menhir_ver=`menhir --version 2>/dev/null | sed -n -e 's/^.*version \([0-9]*\).*$/\1/p'`
case "$menhir_ver" in
20[0-9][0-9][0-9][0-9][0-9][0-9])
- if test "$menhir_ver" -ge $MENHIR_REQUIRED -a "$menhir_ver" -le $MENHIR_MAX; then
+ if test "$menhir_ver" -ge $MENHIR_REQUIRED; then
echo "version $menhir_ver -- good!"
- menhir_includes="-I `menhir --suggest-menhirLib`"
- if test "$menhir_ver" -ge $MENHIR_NEW_API; then
- menhir_flags="--coq-lib-path compcert.cparser.MenhirLib"
+ menhir_dir=$(menhir --suggest-menhirLib | tr -d '\r' | tr '\\' '/')
+ if test -z "$menhir_dir"; then
+ echo "Error: cannot determine the location of the Menhir API library."
+ echo "This can be due to an incorrect Menhir package."
+ echo "Consider using the OPAM package for Menhir."
+ missingtools=true
fi
else
echo "version $menhir_ver -- UNSUPPORTED"
- echo "Error: CompCert requires a version of Menhir between $MENHIR_REQUIRED and $MENHIR_MAX, included."
+ echo "Error: CompCert requires a version greater or equal to $MENHIR_REQUIRED."
missingtools=true
fi;;
*)
@@ -671,7 +693,8 @@ echo "-R lib compcert.lib \
-R driver compcert.driver \
-R flocq compcert.flocq \
-R exportclight compcert.exportclight \
--R cparser compcert.cparser" > _CoqProject
+-R cparser compcert.cparser \
+-R MenhirLib compcert.MenhirLib" > _CoqProject
case $arch in
x86)
echo "-R x86_${bitsize} compcert.x86_${bitsize}" >> _CoqProject
@@ -692,8 +715,7 @@ MANDIR=$sharedir/man
SHAREDIR=$sharedir
COQDEVDIR=$coqdevdir
OCAML_OPT_COMP=$ocaml_opt_comp
-MENHIR_INCLUDES=$menhir_includes
-MENHIR_FLAGS=$menhir_flags
+MENHIR_DIR=$menhir_dir
COMPFLAGS=-bin-annot
EOF
@@ -728,6 +750,8 @@ cat >> Makefile.config <<'EOF'
# ARCH=powerpc
# ARCH=arm
# ARCH=x86
+# ARCH=riscV
+# ARCH=aarch6
ARCH=
# Hardware variant
@@ -741,23 +765,24 @@ ARCH=
# MODEL=armv7m # for ARM
# MODEL=32sse2 # for x86 in 32-bit mode
# MODEL=64 # for x86 in 64-bit mode
+# MODEL=default # for others
MODEL=
# Target ABI
# ABI=eabi # for PowerPC / Linux and other SVR4 or EABI platforms
# ABI=eabi # for ARM
# ABI=hardfloat # for ARM
-# ABI=standard # for x86
+# ABI=standard # for others
ABI=
# Target bit width
-# BITSIZE=64 # for x86 in 64-bit mode
+# BITSIZE=64 # for x86 in 64-bit mode, RiscV in 64-bit mode, AArch64
# BITSIZE=32 # otherwise
BITSIZE=
# Target endianness
# ENDIANNESS=big # for ARM or PowerPC
-# ENDIANNESS=little # for ARM or x86
+# ENDIANNESS=little # for ARM or x86 or RiscV or AArch64
ENDIANNESS=
# Target operating system and development environment
@@ -766,7 +791,7 @@ ENDIANNESS=
# SYSTEM=linux
# SYSTEM=diab
#
-# Possible choices for ARM:
+# Possible choices for ARM, AArch64, RiscV:
# SYSTEM=linux
#
# Possible choices for x86:
@@ -816,11 +841,14 @@ fi
if [ "$arch" = "mppa_k1c" ]; then
cat >> Makefile.config <<EOF
ARCHDIRS=$arch $arch/lib $arch/abstractbb $arch/abstractbb/Impure
+EXECUTE=k1-cluster --syscall=libstd_scalls.so --
+CFLAGS= -D __K1C_COS__
+SIMU=k1-cluster --
BACKENDLIB=Machblock.v Machblockgen.v Machblockgenproof.v\\
- Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asmvliw.v\\
+ Asmblock.v Asmblockgen.v Asmblockgenproof0.v Asmblockgenproof1.v Asmblockgenproof.v Asmvliw.v Asmblockprops.v\\
ForwardSimulationBlock.v PostpassScheduling.v PostpassSchedulingproof.v\\
- Asmblockdeps.v DecBoolOps.v Chunks.v Peephole.v ExtValues.v\\
- AbstractBasicBlocksDef.v DepTreeTheory.v ImpDep.v Parallelizability.v\\
+ Asmblockdeps.v DecBoolOps.v Chunks.v Peephole.v ExtValues.v ExtFloats.v\\
+ AbstractBasicBlocksDef.v SeqSimuTheory.v ImpSimuTest.v Parallelizability.v\\
ImpConfig.v ImpCore.v ImpExtern.v ImpHCons.v ImpIO.v ImpLoops.v ImpMonads.v ImpPrelude.v
EOF
fi
@@ -878,6 +906,4 @@ cat <<EOF
Coq development will not be installed
EOF
fi
-
fi
-
diff --git a/coq b/coq
index 0b04a8c7..fcf744fd 100755
--- a/coq
+++ b/coq
@@ -12,4 +12,4 @@ make -q ${1}o || {
done)
}
-"${COQBIN}coqide" $INCLUDES $1 && make ${1}o
+"${COQBIN}coqide" -async-proofs off $INCLUDES $1 && make ${1}o
diff --git a/cparser/Builtins.ml b/cparser/Builtins.ml
deleted file mode 100644
index 8eb1abfd..00000000
--- a/cparser/Builtins.ml
+++ /dev/null
@@ -1,54 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(* Compiler built-ins *)
-
-open C
-open Cutil
-
-let env = ref Env.empty
-let idents = ref []
-let decls = ref []
-
-let environment () = !env
-let identifiers () = !idents
-let declarations () = List.rev !decls
-
-let add_typedef (s, ty) =
- let (id, env') = Env.enter_typedef !env s ty in
- env := env';
- idents := id :: !idents;
- decls := {gdesc = Gtypedef(id, ty); gloc = no_loc} :: !decls
-
-let add_function (s, (res, args, va)) =
- let ty =
- TFun(res,
- Some (List.map (fun ty -> (Env.fresh_ident "", ty)) args),
- va, []) in
- let (id, env') = Env.enter_ident !env s Storage_extern ty in
- env := env';
- idents := id :: !idents;
- decls := {gdesc = Gdecl(Storage_extern, id, ty, None); gloc = no_loc} :: !decls
-
-type t = {
- typedefs: (string * C.typ) list;
- functions: (string * (C.typ * C.typ list * bool)) list
-}
-
-let set blt =
- env := Env.empty;
- idents := [];
- List.iter add_typedef blt.typedefs;
- List.iter add_function blt.functions
diff --git a/cparser/C.mli b/cparser/C.mli
index cc8d4065..15717565 100644
--- a/cparser/C.mli
+++ b/cparser/C.mli
@@ -264,3 +264,10 @@ and globdecl_desc =
| Gpragma of string (* #pragma directive *)
type program = globdecl list
+
+(** Builtin types and functions *)
+
+type builtins = {
+ builtin_typedefs: (string * typ) list;
+ builtin_functions: (string * (typ * typ list * bool)) list
+}
diff --git a/cparser/Cabs.v b/cparser/Cabs.v
index 5865ab69..5f12e8a1 100644
--- a/cparser/Cabs.v
+++ b/cparser/Cabs.v
@@ -20,7 +20,7 @@ Parameter string : Type.
(* OCaml's int64 type, used to represent individual characters in literals. *)
Parameter char_code : Type.
(* Context information. *)
-Parameter cabsloc : Type.
+Parameter loc : Type.
Record floatInfo := {
isHex_FI:bool;
@@ -51,7 +51,7 @@ Inductive typeSpecifier := (* Merge all specifiers into one type *)
* They also have a list of __attribute__s that appeared between the
* keyword and the type name (definitions only) *)
| Tstruct_union : structOrUnion -> option string -> option (list field_group) -> list attribute -> typeSpecifier
- | Tenum : option string -> option (list (string * option expression * cabsloc)) -> list attribute -> typeSpecifier
+ | Tenum : option string -> option (list (string * option expression * loc)) -> list attribute -> typeSpecifier
with storage :=
AUTO | STATIC | EXTERN | REGISTER | TYPEDEF
@@ -87,18 +87,18 @@ with decl_type :=
| PROTO_OLD : decl_type -> list string -> decl_type
with parameter :=
- | PARAM : list spec_elem -> option string -> decl_type -> list attribute -> cabsloc -> parameter
+ | PARAM : list spec_elem -> option string -> decl_type -> list attribute -> loc -> parameter
(* The optional expression is the bitfield *)
with field_group :=
- | Field_group : list spec_elem -> list (option name * option expression) -> cabsloc -> field_group
+ | Field_group : list spec_elem -> list (option name * option expression) -> loc -> field_group
(* The decl_type is in the order in which they are printed. Only the name of
* the declared identifier is pulled out. *)
(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *)
(* the string, and decl_type will be PTR([], JUSTBASE) *)
with name :=
- | Name : string -> decl_type -> list attribute -> cabsloc -> name
+ | Name : string -> decl_type -> list attribute -> loc -> name
(* A variable declarator ("name") with an initializer *)
with init_name :=
@@ -161,9 +161,9 @@ with initwhat :=
| ATINDEX_INIT : expression -> initwhat
with attribute :=
- | GCC_ATTR : list gcc_attribute -> cabsloc -> attribute
- | PACKED_ATTR : list expression -> cabsloc -> attribute
- | ALIGNAS_ATTR : list expression -> cabsloc -> attribute
+ | GCC_ATTR : list gcc_attribute -> loc -> attribute
+ | PACKED_ATTR : list expression -> loc -> attribute
+ | ALIGNAS_ATTR : list expression -> loc -> attribute
with gcc_attribute :=
| GCC_ATTR_EMPTY
@@ -194,31 +194,31 @@ Definition asm_flag := (bool * list char_code)%type.
** Declaration definition (at toplevel)
*)
Inductive definition :=
- | FUNDEF : list spec_elem -> name -> list definition -> statement -> cabsloc -> definition
- | DECDEF : init_name_group -> cabsloc -> definition (* global variable(s), or function prototype *)
- | PRAGMA : string -> cabsloc -> definition
+ | FUNDEF : list spec_elem -> name -> list definition -> statement -> loc -> definition
+ | DECDEF : init_name_group -> loc -> definition (* global variable(s), or function prototype *)
+ | PRAGMA : string -> loc -> definition
(*
** statements
*)
with statement :=
- | NOP : cabsloc -> statement
- | COMPUTATION : expression -> cabsloc -> statement
- | BLOCK : list statement -> cabsloc -> statement
- | If : expression -> statement -> option statement -> cabsloc -> statement
- | WHILE : expression -> statement -> cabsloc -> statement
- | DOWHILE : expression -> statement -> cabsloc -> statement
- | FOR : option for_clause -> option expression -> option expression -> statement -> cabsloc -> statement
- | BREAK : cabsloc -> statement
- | CONTINUE : cabsloc -> statement
- | RETURN : option expression -> cabsloc -> statement
- | SWITCH : expression -> statement -> cabsloc -> statement
- | CASE : expression -> statement -> cabsloc -> statement
- | DEFAULT : statement -> cabsloc -> statement
- | LABEL : string -> statement -> cabsloc -> statement
- | GOTO : string -> cabsloc -> statement
- | ASM : list cvspec -> bool -> list char_code -> list asm_operand -> list asm_operand -> list asm_flag -> cabsloc -> statement
+ | NOP : loc -> statement
+ | COMPUTATION : expression -> loc -> statement
+ | BLOCK : list statement -> loc -> statement
+ | If : expression -> statement -> option statement -> loc -> statement
+ | WHILE : expression -> statement -> loc -> statement
+ | DOWHILE : expression -> statement -> loc -> statement
+ | FOR : option for_clause -> option expression -> option expression -> statement -> loc -> statement
+ | BREAK : loc -> statement
+ | CONTINUE : loc -> statement
+ | RETURN : option expression -> loc -> statement
+ | SWITCH : expression -> statement -> loc -> statement
+ | CASE : expression -> statement -> loc -> statement
+ | DEFAULT : statement -> loc -> statement
+ | LABEL : string -> statement -> loc -> statement
+ | GOTO : string -> loc -> statement
+ | ASM : list cvspec -> bool -> list char_code -> list asm_operand -> list asm_operand -> list asm_flag -> loc -> statement
| DEFINITION : definition -> statement (*definition or declaration of a variable or type*)
with for_clause :=
diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml
index 958f242c..22f3b3c7 100644
--- a/cparser/Cabshelper.ml
+++ b/cparser/Cabshelper.ml
@@ -16,11 +16,6 @@
open Cabs
-let cabslu = {lineno = -10;
- filename = "cabs loc unknown";
- byteno = -10;
- ident = 0}
-
(*********** HELPER FUNCTIONS **********)
let rec isStatic = function
@@ -44,13 +39,13 @@ let rec isTypedef = function
| _ :: rest -> isTypedef rest
-let get_definitionloc (d : definition) : cabsloc =
+let get_definitionloc (d : definition) : loc =
match d with
| FUNDEF(_, _, _, _, l) -> l
| DECDEF(_, l) -> l
| PRAGMA(_, l) -> l
-let get_statementloc (s : statement) : cabsloc =
+let get_statementloc (s : statement) : loc =
begin
match s with
| NOP(loc) -> loc
@@ -72,8 +67,8 @@ begin
| ASM(_,_,_,_,_,_,loc) -> loc
end
-let string_of_cabsloc l =
+let string_of_loc l =
Printf.sprintf "%s:%d" l.filename l.lineno
-let format_cabsloc pp l =
+let format_loc pp l =
Format.fprintf pp "%s:%d" l.filename l.lineno
diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml
index 58dea5f4..ecf83779 100644
--- a/cparser/Ceval.ml
+++ b/cparser/Ceval.ml
@@ -271,7 +271,7 @@ let constant_expr env ty e =
try
match unroll env ty, cast env ty (expr env e) with
| TInt(ik, _), I n -> Some(CInt(n, ik, ""))
- | TPtr(_, _), I n -> Some(CInt(n, IInt, ""))
+ | TPtr(_, _), I n -> Some(CInt(n, ptr_t_ikind (), ""))
| (TArray(_, _, _) | TPtr(_, _)), S s -> Some(CStr s)
| (TArray(_, _, _) | TPtr(_, _)), WS s -> Some(CWStr s)
| TEnum(_, _), I n -> Some(CInt(n, enum_ikind, ""))
diff --git a/cparser/Checks.ml b/cparser/Checks.ml
index a30cde7d..17caf19a 100644
--- a/cparser/Checks.ml
+++ b/cparser/Checks.ml
@@ -18,44 +18,68 @@ open Diagnostics
open Cutil
open Env
-let unknown_attrs loc attrs =
- let unknown attr =
- let attr_class = class_of_attribute attr in
- if attr_class = Attr_unknown then
- warning loc Unknown_attribute
- "unknown attribute '%s' ignored" (name_of_attribute attr) in
- List.iter unknown attrs
+(* AST traversal functions *)
-let unknown_attrs_typ env loc ty =
- let attr = attributes_of_type env ty in
- unknown_attrs loc attr
+let fold_over_stmt_loc ~(expr: 'a -> location -> exp -> 'a)
+ ~(decl: 'a -> location -> decl -> 'a)
+ (a: 'a) (s: stmt) : 'a =
+ let rec fold a s =
+ match s.sdesc with
+ | Sskip -> a
+ | Sbreak -> a
+ | Scontinue -> a
+ | Slabeled(_, s1) -> fold a s1
+ | Sgoto _ -> a
+ | Sreturn None -> a
+ | Sreturn (Some e) -> expr a s.sloc e
+ | Sasm(_, _, outs, ins, _) -> asm_operands (asm_operands a s.sloc outs) s.sloc ins
+ | Sdo e -> expr a s.sloc e
+ | Sif (e, s1, s2) -> fold (fold (expr a s.sloc e) s1) s2
+ | Sseq (s1, s2) -> fold (fold a s1) s2
+ | Sfor (s1, e, s2, s3) -> fold (fold (expr (fold a s1) s.sloc e) s2) s3
+ | Swhile(e, s1) -> fold (expr a s.sloc e) s1
+ | Sdowhile (s1, e) -> expr (fold a s1) s.sloc e
+ | Sswitch (e, s1) -> fold (expr a s.sloc e) s1
+ | Sblock sl -> List.fold_left fold a sl
+ | Sdecl d -> decl a s.sloc d
+ and asm_operands a loc l =
+ List.fold_left (fun a (_, _, e) -> expr a loc e) a l
+ in fold a s
-let unknown_attrs_decl env loc (sto, id, ty, init) =
- unknown_attrs_typ env loc ty
+let iter_over_stmt_loc
+ ?(expr = fun loc e -> ())
+ ?(decl = fun loc decl -> ())
+ (s: stmt) : unit =
+ fold_over_stmt_loc ~expr: (fun () loc e -> expr loc e)
+ ~decl: (fun () loc d -> decl loc d)
+ () s
+
+let fold_over_stmt ~(expr: 'a -> exp -> 'a)
+ ~(decl: 'a -> location -> decl -> 'a)
+ (a: 'a) (s: stmt) : 'a =
+ fold_over_stmt_loc ~expr:(fun a _ e -> expr a e) ~decl:decl a s
+
+let iter_over_stmt ?(expr = fun e -> ())
+ ?(decl = fun loc decl -> ())
+ (s:stmt) : unit =
+ fold_over_stmt_loc ~expr:(fun () _ e -> expr e)
+ ~decl:(fun () loc d -> decl loc d) () s
+
+let fold_over_init ~(expr: 'a -> exp -> 'a) (a: 'a) (i: init) : 'a =
+ let rec fold a = function
+ | Init_single e -> expr a e
+ | Init_array il -> List.fold_left fold a il
+ | Init_struct (_, sl) -> List.fold_left (fun a (_,i) -> fold a i) a sl
+ | Init_union (_, _, ui) -> fold a ui
+ in fold a i
-let rec unknown_attrs_stmt env s =
- match s.sdesc with
- | Sskip
- | Sbreak
- | Scontinue
- | Slabeled _
- | Sgoto _
- | Sreturn _
- | Sasm _
- | Sdo _ -> ()
- | Sif (_,s1,s2)
- | Sseq (s1,s2) ->
- unknown_attrs_stmt env s1;
- unknown_attrs_stmt env s2
- | Sfor (s1,e,s2,s3) ->
- unknown_attrs_stmt env s1;
- unknown_attrs_stmt env s2;
- unknown_attrs_stmt env s3
- | Swhile(_,s)
- | Sdowhile (s,_)
- | Sswitch (_,s) -> unknown_attrs_stmt env s
- | Sblock sl -> List.iter (unknown_attrs_stmt env) sl
- | Sdecl d -> unknown_attrs_decl env s.sloc d
+let iter_over_init ~(expr: exp -> unit) (i:init) : unit =
+ fold_over_init ~expr:(fun () e -> expr e) () i
+
+let fold_over_decl ~(expr: 'a -> exp -> 'a) (a: 'a) loc (sto, id, ty, init) : 'a=
+ match init with
+ | Some i -> fold_over_init ~expr a i
+ | None -> a
let traverse_program
?(decl = fun env loc d -> ())
@@ -93,7 +117,27 @@ let traverse_program
pragma env g.gloc s;
env in
traverse env gl in
- traverse (Builtins.environment ()) p
+ traverse (Env.initial ()) p
+
+(* Unknown attributes warning *)
+
+let unknown_attrs loc attrs =
+ let unknown attr =
+ let attr_class = class_of_attribute attr in
+ if attr_class = Attr_unknown then
+ warning loc Unknown_attribute
+ "unknown attribute '%s' ignored" (name_of_attribute attr) in
+ List.iter unknown attrs
+
+let unknown_attrs_typ env loc ty =
+ let attr = attributes_of_type env ty in
+ unknown_attrs loc attr
+
+let unknown_attrs_decl env loc (sto, id, ty, init) =
+ unknown_attrs_typ env loc ty
+
+let unknown_attrs_stmt env s =
+ iter_over_stmt ~decl:(unknown_attrs_decl env) s
let unknown_attrs_program p =
let decl env loc d =
@@ -122,6 +166,7 @@ let unknown_attrs_program p =
~enum:enum
p
+(* Unused variables and parameters warning *)
let rec vars_used_expr env e =
match e.edesc with
@@ -143,83 +188,21 @@ let rec vars_used_expr env e =
let env = vars_used_expr env e in
List.fold_left vars_used_expr env p
-and vars_used_init env = function
- | Init_single e -> vars_used_expr env e
- | Init_array al -> List.fold_left vars_used_init env al
- | Init_struct (_,sl) -> List.fold_left (fun env (_,i) -> vars_used_init env i) env sl
- | Init_union (_,_,ui) -> vars_used_init env ui
-
-let rec vars_used_stmt env s =
- match s.sdesc with
- | Sbreak
- | Scontinue
- | Sgoto _
- | Sreturn None
- | Sskip -> env
- | Sreturn (Some e)
- | Sdo e -> (vars_used_expr env e)
- | Sseq (s1,s2) ->
- let env = vars_used_stmt env s1 in
- vars_used_stmt env s2
- | Sif (e,s1,s2) ->
- let env = vars_used_expr env e in
- let env = vars_used_stmt env s1 in
- vars_used_stmt env s2
- | Sfor (s1,e,s2,s3) ->
- let env = vars_used_expr env e in
- let env = vars_used_stmt env s1 in
- let env = vars_used_stmt env s2 in
- vars_used_stmt env s3
- | Sswitch (e,s)
- | Swhile (e,s)
- | Sdowhile (s,e) ->
- let env = vars_used_expr env e in
- vars_used_stmt env s
- | Sblock sl -> List.fold_left vars_used_stmt env sl
- | Sdecl (sto,id,ty,init) ->
- let env = match init with
- | Some init ->vars_used_init env init
- | None -> env in
- env
- | Slabeled (lbl,s) -> vars_used_stmt env s
- | Sasm (attr,str,op,op2,constr) ->
- let vars_asm_op env (_,_,e) =
- vars_used_expr env e in
- let env = List.fold_left vars_asm_op env op in
- let env = List.fold_left vars_asm_op env op2 in
- env
-
-let unused_variable env used loc (id,ty) =
+and vars_used_init env init =
+ fold_over_init ~expr:vars_used_expr env init
+
+let vars_used_stmt env s =
+ fold_over_stmt ~expr: vars_used_expr
+ ~decl: (fold_over_decl ~expr: vars_used_expr) env s
+
+let unused_variable env used loc (id, ty) =
let attr = attributes_of_type env ty in
let unused_attr = find_custom_attributes ["unused";"__unused__"] attr <> [] in
if not ((IdentSet.mem id used) || unused_attr) then
warning loc Unused_variable "unused variable '%s'" id.name
-let rec unused_variables_stmt env used s =
- match s.sdesc with
- | Sbreak
- | Scontinue
- | Sgoto _
- | Sreturn _
- | Sskip
- | Sasm _
- | Sdo _ -> ()
- | Sseq (s1,s2)
- | Sif (_,s1,s2) ->
- unused_variables_stmt env used s1;
- unused_variables_stmt env used s2
- | Sfor (s1,e,s2,s3) ->
- unused_variables_stmt env used s1;
- unused_variables_stmt env used s2;
- unused_variables_stmt env used s3
- | Slabeled (_,s)
- | Sswitch (_,s)
- | Swhile (_,s)
- | Sdowhile (s,_) ->
- unused_variables_stmt env used s
- | Sblock sl -> List.iter (unused_variables_stmt env used) sl
- | Sdecl (sto,id,ty,init) ->
- unused_variable env used s.sloc (id,ty)
+let unused_variables_stmt env used s =
+ iter_over_stmt ~decl:(fun loc (sto, id, ty, init) -> unused_variable env used loc (id,ty)) s
let unused_variables p =
let fundef env loc fd =
@@ -229,3 +212,166 @@ let unused_variables p =
traverse_program
~fundef:fundef
p
+
+(* Warning for conditionals that cannot be transformed into linear code *)
+
+(* Compute the set of local variables that do not have their address taken *)
+
+let rec non_stack_locals_expr vars e =
+ match e.edesc with
+ | ECast (_,e) -> non_stack_locals_expr vars e
+ | EUnop (Oaddrof,e) ->
+ begin match e.edesc with
+ | EVar id ->
+ IdentSet.remove id vars
+ | _ -> vars
+ end
+ | EUnop (Oderef, e) ->
+ (* Special optimization *(& ...) is removed in SimplExpr *)
+ begin match e.edesc with
+ | EUnop (Oaddrof,e) -> non_stack_locals_expr vars e
+ | _ -> non_stack_locals_expr vars e
+ end
+ | EUnop (_, e) ->
+ non_stack_locals_expr vars e
+ | EBinop (_,e1,e2,_) ->
+ let vars = non_stack_locals_expr vars e1 in
+ non_stack_locals_expr vars e2
+ | EConditional (e1,e2,e3) ->
+ let vars = non_stack_locals_expr vars e1 in
+ let vars = non_stack_locals_expr vars e2 in
+ non_stack_locals_expr vars e3
+ | ECompound (_,init) -> non_stack_locals_init vars init
+ | ECall (e,p) ->
+ let vars = non_stack_locals_expr vars e in
+ List.fold_left non_stack_locals_expr vars p
+ | _ -> vars
+
+and non_stack_locals_init vars init =
+ fold_over_init ~expr:non_stack_locals_expr vars init
+
+let add_vars env vars (id,ty) =
+ let volatile = List.mem AVolatile (attributes_of_type env ty) in
+ if not volatile then
+ IdentSet.add id vars
+ else
+ vars
+
+let non_stack_locals_stmt env vars s =
+ let decl vars loc (sto, id, ty, init) =
+ let vars = match init with
+ | Some init -> non_stack_locals_init vars init
+ | None -> vars in
+ add_vars env vars (id,ty) in
+ fold_over_stmt ~expr:non_stack_locals_expr ~decl:decl
+ vars s
+
+(* Check whether an expression is safe and can be always evaluated *)
+
+let safe_cast env tfrom tto =
+ match unroll env tfrom, unroll env tto with
+ | (TInt _ | TPtr _ | TArray _ | TFun _ | TEnum _),
+ (TInt _ | TPtr _ | TEnum _) -> true
+ | TFloat _, TFloat _ -> true
+ | _, _ -> equal_types env tfrom tto
+
+let safe_expr vars env e =
+ let rec expr e =
+ match e.edesc with
+ | EConst _ | ESizeof _ | EAlignof _ | ECompound _ -> true
+ | EVar id -> (IdentSet.mem id vars) || not (is_scalar_type env e.etyp)
+ | ECast (ty, e) ->
+ safe_cast env e.etyp ty && expr e
+ | EUnop (op, e) ->
+ unop op e
+ | EBinop (op, e1, e2, ty) ->
+ binop op e1 e2
+ | EConditional _ -> false
+ | ECall _ -> false
+ and binop op e1 e2 =
+ let is_long_long_type ty =
+ match unroll env ty with
+ | TInt (ILongLong, _)
+ | TInt (IULongLong, _) -> true
+ | _ -> false in
+ match op with
+ | Oadd | Osub | Omul | Oand | Oor | Oxor | Oshl | Oshr ->
+ expr e1 && expr e2
+ | Oeq | One | Olt | Ogt | Ole | Oge ->
+ let not_long_long = not (is_long_long_type e1.etyp) && not (is_long_long_type e2.etyp) in
+ not_long_long && expr e1 && expr e2
+ | _ -> false
+ (* x.f if f has array or struct or union type *)
+ and unop op e =
+ match op with
+ | Ominus | Onot | Olognot | Oplus -> expr e
+ | Oaddrof ->
+ begin match e.edesc with
+ (* skip &*e *)
+ | EUnop (Oderef, e) -> expr e
+ (* skip &(e.f) *)
+ | EUnop (Odot f, e) -> expr e
+ | _ -> expr e
+ end
+ (* skip *&e *)
+ | Oderef ->
+ begin match e.edesc with
+ | EUnop (Oaddrof,e) -> expr e
+ | _ -> false
+ end
+ (* e.f is okay if f has array or composite type *)
+ | Odot m ->
+ let fld = field_of_dot_access env e.etyp m in
+ (is_array_type env fld.fld_typ || is_composite_type env fld.fld_typ) && expr e
+ | _ -> false in
+ expr e
+
+(* Check expressions if they contain conditionals that cannot be transformed in
+ linear code. The inner_cond parameter is used to mimic the translation of short
+ circuit logical or and logical and as well as conditional to if statements in
+ SimplExpr. *)
+
+let rec non_linear_cond_expr inner_cond vars env loc e =
+ match e.edesc with
+ | EConst _ | ESizeof _ | EAlignof _ | EVar _ -> ()
+ | ECast (_ , e) | EUnop (_, e)-> non_linear_cond_expr false vars env loc e
+ | EBinop (op, e1, e2, ty) ->
+ let inner_cond = match op with
+ | Ocomma -> inner_cond
+ | Ologand | Ologor -> true
+ | _ -> false
+ in
+ non_linear_cond_expr false vars env loc e1;
+ non_linear_cond_expr inner_cond vars env loc e2
+ | EConditional (c, e1, e2) ->
+ let can_cast = safe_cast env e1.etyp e.etyp && safe_cast env e2.etyp e.etyp in
+ if not can_cast || inner_cond || not (safe_expr vars env e1) || not (safe_expr vars env e2) then
+ warning loc Non_linear_cond_expr "conditional expression may not be linearized";
+ non_linear_cond_expr true vars env loc e1;
+ non_linear_cond_expr true vars env loc e2;
+ | ECompound (ty, init) -> non_linear_cond_init vars env loc init
+ | ECall (e, params) ->
+ non_linear_cond_expr false vars env loc e;
+ List.iter (non_linear_cond_expr false vars env loc) params
+
+and non_linear_cond_init vars env loc init =
+ iter_over_init ~expr:(non_linear_cond_expr false vars env loc) init
+
+let non_linear_cond_stmt vars env s =
+ let decl loc (sto, id, ty, init) =
+ match init with
+ | None -> ()
+ | Some init -> non_linear_cond_init vars env loc init in
+ iter_over_stmt_loc ~expr:(non_linear_cond_expr false vars env) ~decl:decl s
+
+let non_linear_conditional p =
+ if active_warning Non_linear_cond_expr && !Clflags.option_Obranchless then begin
+ let fundef env loc fd =
+ let vars = List.fold_left (add_vars env) IdentSet.empty fd.fd_params in
+ let vars = non_stack_locals_stmt env vars fd.fd_body in
+ non_linear_cond_stmt vars env fd.fd_body;
+ in
+ traverse_program
+ ~fundef:fundef
+ p
+ end
diff --git a/cparser/Checks.mli b/cparser/Checks.mli
index 4d61a5b8..cfd7b04d 100644
--- a/cparser/Checks.mli
+++ b/cparser/Checks.mli
@@ -16,3 +16,5 @@
val unknown_attrs_program: C.program -> unit
val unused_variables: C.program -> unit
+
+val non_linear_conditional : C.program -> unit
diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml
index cf67015a..3467c092 100644
--- a/cparser/Cutil.ml
+++ b/cparser/Cutil.ml
@@ -29,7 +29,7 @@ let no_loc = ("", -1)
module Ident = struct
type t = ident
- let compare id1 id2 = Pervasives.compare id1.stamp id2.stamp
+ let compare id1 id2 = compare id1.stamp id2.stamp
end
module IdentSet = Set.Make(Ident)
@@ -821,6 +821,11 @@ let is_composite_type env t =
| TStruct _ | TUnion _ -> true
| _ -> false
+let is_array_type env t =
+ match unroll env t with
+ | TArray _ -> true
+ | _ -> false
+
let is_function_type env t =
match unroll env t with
| TFun _ -> true
@@ -831,6 +836,12 @@ let is_anonymous_composite = function
| TUnion (id,_) -> id.C.name = ""
| _ -> false
+let is_anonymous_type = function
+ | TEnum (id,_)
+ | TStruct (id,_)
+ | TUnion (id,_) -> id.C.name = ""
+ | _ -> false
+
let is_function_pointer_type env t =
match unroll env t with
| TPtr (ty, _) -> is_function_type env ty
@@ -947,7 +958,7 @@ let binary_conversion env t1 t2 =
end
| _, _ -> assert false
-(* Conversion on function arguments (with protoypes) *)
+(* Conversion on function arguments (with prototypes) *)
let argument_conversion env t =
(* Arrays and functions degrade automatically to pointers *)
diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli
index 5a1e9af3..2ddee78c 100644
--- a/cparser/Cutil.mli
+++ b/cparser/Cutil.mli
@@ -166,12 +166,16 @@ val is_scalar_type : Env.t -> typ -> bool
(* Is type integer, float or pointer? *)
val is_composite_type : Env.t -> typ -> bool
(* Is type a struct or union? *)
+val is_array_type : Env.t -> typ -> bool
+ (* Is type an array type? *)
val is_function_type : Env.t -> typ -> bool
(* Is type a function type? (not pointer to function) *)
val is_function_pointer_type : Env.t -> typ -> bool
(* Is type a pointer to function type? *)
val is_anonymous_composite : typ -> bool
(* Is type an anonymous composite? *)
+val is_anonymous_type : typ -> bool
+ (* Is the type an anonymous composite or enum *)
val is_qualified_array : typ -> bool
(* Does the type contain a qualified array type (e.g. int[const 5])? *)
val pointer_arithmetic_ok : Env.t -> typ -> bool
diff --git a/cparser/Diagnostics.ml b/cparser/Diagnostics.ml
index 172affab..7957375c 100644
--- a/cparser/Diagnostics.ml
+++ b/cparser/Diagnostics.ml
@@ -18,6 +18,10 @@
open Format
open Commandline
+(* Ensure that the error formatter is flushed at exit *)
+let _ =
+ at_exit (pp_print_flush err_formatter)
+
(* Should errors be treated as fatal *)
let error_fatal = ref false
@@ -28,7 +32,7 @@ let max_error = ref 0
let diagnostics_show_option = ref true
(* Test if color diagnostics are available by testing if stderr is a tty
- and if the environment varibale TERM is set
+ and if the environment variable TERM is set
*)
let color_diagnostics =
let term = try Sys.getenv "TERM" with Not_found -> "" in
@@ -98,31 +102,48 @@ type warning_type =
| Flexible_array_extensions
| Tentative_incomplete_static
| Reduced_alignment
+ | Non_linear_cond_expr
+
+(* List of all warnings with default status.
+ "true" means the warning is active by default.
+ "false" means the warning is off by default. *)
+let all_warnings =
+ [ (Unnamed, true);
+ (Unknown_attribute, true);
+ (Zero_length_array, false);
+ (Celeven_extension, false);
+ (Gnu_empty_struct, true);
+ (Missing_declarations, true);
+ (Constant_conversion, true);
+ (Int_conversion, true);
+ (Varargs, true);
+ (Implicit_function_declaration, true);
+ (Pointer_type_mismatch, true);
+ (Compare_distinct_pointer_types, true);
+ (Implicit_int, true);
+ (Main_return_type, true);
+ (Invalid_noreturn, true);
+ (Return_type, true);
+ (Literal_range, true);
+ (Unknown_pragmas, false);
+ (CompCert_conformance, false);
+ (Inline_asm_sdump, true);
+ (Unused_variable, false);
+ (Unused_parameter, false);
+ (Wrong_ais_parameter, true);
+ (Unused_ais_parameter, true);
+ (Ignored_attributes, true);
+ (Extern_after_definition, true);
+ (Static_in_inline, true);
+ (Flexible_array_extensions, false);
+ (Tentative_incomplete_static, false);
+ (Reduced_alignment, false);
+ (Non_linear_cond_expr, false);
+ ]
(* List of active warnings *)
-let active_warnings: warning_type list ref = ref [
- Unnamed;
- Unknown_attribute;
- Gnu_empty_struct;
- Missing_declarations;
- Constant_conversion;
- Int_conversion;
- Varargs;
- Implicit_function_declaration;
- Pointer_type_mismatch;
- Compare_distinct_pointer_types;
- Implicit_int;
- Main_return_type;
- Invalid_noreturn;
- Return_type;
- Literal_range;
- Inline_asm_sdump;
- Wrong_ais_parameter;
- Unused_ais_parameter;
- Ignored_attributes;
- Extern_after_definition;
- Static_in_inline;
-]
+let active_warnings: warning_type list ref =
+ ref (List.map fst (List.filter snd all_warnings))
(* List of errors treated as warning *)
let error_warnings: warning_type list ref = ref []
@@ -159,6 +180,7 @@ let string_of_warning = function
| Flexible_array_extensions -> "flexible-array-extensions"
| Tentative_incomplete_static -> "tentative-incomplete-static"
| Reduced_alignment -> "reduced-alignment"
+ | Non_linear_cond_expr -> "non-linear-cond-expr"
(* Activate the given warning *)
let activate_warning w () =
@@ -182,74 +204,14 @@ let warning_not_as_error w () =
(* Activate all warnings *)
let wall () =
- active_warnings:=[
- Unnamed;
- Unknown_attribute;
- Zero_length_array;
- Celeven_extension;
- Gnu_empty_struct;
- Missing_declarations;
- Constant_conversion;
- Int_conversion;
- Varargs;
- Implicit_function_declaration;
- Pointer_type_mismatch;
- Compare_distinct_pointer_types;
- Implicit_int;
- Main_return_type;
- Invalid_noreturn;
- Return_type;
- Literal_range;
- Unknown_pragmas;
- CompCert_conformance;
- Inline_asm_sdump;
- Unused_variable;
- Unused_parameter;
- Wrong_ais_parameter;
- Ignored_attributes;
- Extern_after_definition;
- Static_in_inline;
- Flexible_array_extensions;
- Tentative_incomplete_static;
- Reduced_alignment;
- ]
+ active_warnings:= List.map fst all_warnings
let wnothing () =
active_warnings :=[]
(* Make all warnings an error *)
let werror () =
- error_warnings:=[
- Unnamed;
- Unknown_attribute;
- Zero_length_array;
- Celeven_extension;
- Gnu_empty_struct;
- Missing_declarations;
- Constant_conversion;
- Int_conversion;
- Varargs;
- Implicit_function_declaration;
- Pointer_type_mismatch;
- Compare_distinct_pointer_types;
- Implicit_int;
- Main_return_type;
- Invalid_noreturn;
- Return_type;
- Literal_range;
- Unknown_pragmas;
- CompCert_conformance;
- Inline_asm_sdump;
- Unused_variable;
- Wrong_ais_parameter;
- Unused_ais_parameter;
- Ignored_attributes;
- Extern_after_definition;
- Static_in_inline;
- Flexible_array_extensions;
- Tentative_incomplete_static;
- Reduced_alignment;
- ]
+ error_warnings:= List.map fst all_warnings
(* Generate the warning key for the message *)
let key_of_warning w =
@@ -403,36 +365,7 @@ let error_option w =
Exact ("-Wno-error="^key), Unit ( warning_not_as_error w)]
let warning_options =
- error_option Unnamed @
- error_option Unknown_attribute @
- error_option Zero_length_array @
- error_option Celeven_extension @
- error_option Gnu_empty_struct @
- error_option Missing_declarations @
- error_option Constant_conversion @
- error_option Int_conversion @
- error_option Varargs @
- error_option Implicit_function_declaration @
- error_option Pointer_type_mismatch @
- error_option Compare_distinct_pointer_types @
- error_option Implicit_int @
- error_option Main_return_type @
- error_option Invalid_noreturn @
- error_option Return_type @
- error_option Literal_range @
- error_option Unknown_pragmas @
- error_option CompCert_conformance @
- error_option Inline_asm_sdump @
- error_option Unused_variable @
- error_option Unused_parameter @
- error_option Wrong_ais_parameter @
- error_option Unused_ais_parameter @
- error_option Ignored_attributes @
- error_option Extern_after_definition @
- error_option Static_in_inline @
- error_option Flexible_array_extensions @
- error_option Tentative_incomplete_static @
- error_option Reduced_alignment @
+ List.concat (List.map (fun (w, active) -> error_option w) all_warnings) @
[Exact ("-Wfatal-errors"), Set error_fatal;
Exact ("-fdiagnostics-color"), Ignore; (* Either output supports it or no color *)
Exact ("-fno-diagnostics-color"), Unset color_diagnostics;
@@ -469,7 +402,7 @@ let raise_on_errors () =
let crash exn =
if Version.buildnr <> "" && Version.tag <> "" then begin
let backtrace = Printexc.get_backtrace () in
- eprintf "%tThis is CompCert, %s, Build:%s, Tag:%s%t\n"
+ eprintf "%tThis is CompCert, Release %s, Build:%s, Tag:%s%t\n"
bc Version.version Version.buildnr Version.tag rsc;
eprintf "Backtrace (please include this in your support request):\n%s"
backtrace;
@@ -488,3 +421,6 @@ let crash exn =
let no_loc = ("", -1)
let file_loc file = (file,-10)
+
+let active_warning ty =
+ fst (classify_warning ty) <> SuppressedMsg
diff --git a/cparser/Diagnostics.mli b/cparser/Diagnostics.mli
index ded8019f..0f0a0ea5 100644
--- a/cparser/Diagnostics.mli
+++ b/cparser/Diagnostics.mli
@@ -22,22 +22,22 @@ exception Abort
(** Exception raised upon fatal errors *)
val check_errors : unit -> unit
- (** Check whether errors occured and raise abort if an error occured *)
+ (** Check whether errors occurred and raise abort if an error occurred *)
type warning_type =
| Unnamed (** warnings which cannot be turned off *)
| Unknown_attribute (** usage of unsupported/unknown attributes *)
- | Zero_length_array (** gnu extension for zero lenght arrays *)
+ | Zero_length_array (** gnu extension for zero length arrays *)
| Celeven_extension (** C11 features *)
| Gnu_empty_struct (** gnu extension for empty struct *)
- | Missing_declarations (** declation which do not declare anything *)
+ | Missing_declarations (** declaration which do not declare anything *)
| Constant_conversion (** dangerous constant conversions *)
| Int_conversion (** pointer <-> int conversions *)
| Varargs (** promotable vararg argument *)
| Implicit_function_declaration (** deprecated implicit function declaration *)
| Pointer_type_mismatch (** pointer type mismatch in ?: operator *)
| Compare_distinct_pointer_types (** comparison between different pointer types *)
- | Implicit_int (** implict int parameter or return type *)
+ | Implicit_int (** implicit int parameter or return type *)
| Main_return_type (** wrong return type for main *)
| Invalid_noreturn (** noreturn function containing return *)
| Return_type (** void return in non-void function *)
@@ -55,6 +55,7 @@ type warning_type =
| Flexible_array_extensions (** usange of structs with flexible arrays in structs and arrays *)
| Tentative_incomplete_static (** static tentative definition with incomplete type *)
| Reduced_alignment (** alignment reduction *)
+ | Non_linear_cond_expr (** condition that cannot be linearized *)
val warning : (string * int) -> warning_type -> ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
(** [warning (f,c) w fmt arg1 ... argN] formats the arguments [arg1] to [argN] as warining according to
@@ -95,3 +96,6 @@ val file_loc : string -> string * int
val error_summary : unit -> unit
(** Print a summary containing the numbers of errors encountered *)
+
+val active_warning : warning_type -> bool
+(** Test whether a warning is active to avoid costly checks *)
diff --git a/cparser/Elab.ml b/cparser/Elab.ml
index 7a0b05de..9e17cb7e 100644
--- a/cparser/Elab.ml
+++ b/cparser/Elab.ml
@@ -21,7 +21,7 @@ open Machine
open Cabs
open C
open Diagnostics
-open !Cutil
+open! Cutil
(** * Utility functions *)
@@ -39,7 +39,16 @@ let warning loc =
let print_typ env fmt ty =
match ty with
| TNamed _ ->
- Format.fprintf fmt "'%a' (aka '%a')" Cprint.typ_raw ty Cprint.typ_raw (unroll env ty)
+ Format.fprintf fmt "'%a'" Cprint.typ_raw ty;
+ let ty' = unroll env ty in
+ if not (is_anonymous_type ty')
+ then Format.fprintf fmt " (aka '%a')" Cprint.typ_raw ty'
+ | TStruct (id,_) when id.C.name = "" ->
+ Format.fprintf fmt "'struct <anonymous>'"
+ | TUnion (id,_) when id.C.name = "" ->
+ Format.fprintf fmt "'union <anonymous>'"
+ | TEnum (id,_) when id.C.name = "" ->
+ Format.fprintf fmt "'enum <anonymous>'"
| _ -> Format.fprintf fmt "'%a'" Cprint.typ_raw ty
let pp_field fmt id =
@@ -172,7 +181,7 @@ let combine_toplevel_definitions loc env s old_sto old_ty sto ty =
error loc "static declaration of '%s' follows non-static declaration" s;
sto
| Storage_static,_ -> Storage_static (* Static stays static *)
- | Storage_extern,_ -> sto
+ | Storage_extern,_ -> if is_function_type env new_ty then Storage_extern else sto
| Storage_default,Storage_extern ->
if is_global_defined s && is_function_type env ty then
warning loc Extern_after_definition "this extern declaration follows a non-extern definition and is ignored";
@@ -258,7 +267,7 @@ let enter_or_refine_function loc env id sto ty =
(* Forward declarations *)
-let elab_expr_f : (cabsloc -> Env.t -> Cabs.expression -> C.exp * Env.t) ref
+let elab_expr_f : (Cabs.loc -> Env.t -> Cabs.expression -> C.exp * Env.t) ref
= ref (fun _ _ _ -> assert false)
let elab_funbody_f : (C.typ -> bool -> bool -> Env.t -> statement -> C.stmt) ref
@@ -295,14 +304,16 @@ let parse_int base s =
| _ -> assert false in
let v = ref 0L in
for i = 0 to String.length s - 1 do
- if !v < 0L || !v > max_val then raise Overflow;
- v := Int64.mul !v (Int64.of_int base);
let c = s.[i] in
let digit =
if c >= '0' && c <= '9' then Char.code c - 48
else if c >= 'A' && c <= 'F' then Char.code c - 55
else raise Bad_digit in
if digit >= base then raise Bad_digit;
+ if !v < 0L || !v > max_val then raise Overflow;
+ (* because (2^64 - 1) % 10 = 5, not 9 *)
+ if base = 10 && !v = max_val && digit > 5 then raise Overflow;
+ v := Int64.mul !v (Int64.of_int base);
v := Int64.add !v (Int64.of_int digit)
done;
!v
@@ -441,7 +452,8 @@ let elab_constant loc = function
let (v, fk) = elab_float_constant f in
CFloat(v, fk)
| CONST_CHAR(wide, s) ->
- CInt(elab_char_constant loc wide s, IInt, "")
+ let ikind = if wide then wchar_ikind () else IInt in
+ CInt(elab_char_constant loc wide s, ikind, "")
| CONST_STRING(wide, s) ->
elab_string_literal loc wide s
@@ -834,7 +846,7 @@ and elab_type_declarator ?(fundef = false) loc env ty = function
| Cabs.PROTO(d, (params, vararg)) ->
elab_return_type loc env ty;
let (ty, a) = get_nontype_attrs env ty in
- let (params', env') = elab_parameters env params in
+ let (params', env') = elab_parameters loc env params in
(* For a function declaration (fundef = false), the scope introduced
to treat parameters ends here, so we discard the extended
environment env' returned by elab_parameters.
@@ -860,13 +872,15 @@ and elab_type_declarator ?(fundef = false) loc env ty = function
(* Elaboration of parameters in a prototype *)
-and elab_parameters env params =
+and elab_parameters loc env params =
(* Prototype introduces a new scope *)
let (vars, env) = mmap elab_parameter (Env.new_scope env) params in
(* Catch special case f(t) where t is void or a typedef to void *)
match vars with
| [ ( {C.name=""}, t) ] when is_void_type env t -> [],env
- | _ -> vars,env
+ | _ -> if List.exists (fun (id, t) -> id.C.name = "" && is_void_type env t) vars then
+ error loc "'void' must be the only parameter";
+ (vars, env)
(* Elaboration of a function parameter *)
@@ -939,31 +953,7 @@ and elab_name_group loc env (spec, namelist) =
((id, add_attributes_type a ty), env1) in
(mmap elab_one_name env' namelist, sto)
-(* Elaboration of an init-name group *)
-and elab_init_name_group loc env (spec, namelist) =
- let (sto, inl, noret, tydef, bty, env') =
- elab_specifier ~only:(namelist=[]) loc env spec in
- if noret && tydef then
- error loc "'_Noreturn' can only appear on functions";
- let elab_one_name env (Init_name (Name (id, decl, attr, loc), init)) =
- let ((ty, _), env1) =
- elab_type_declarator loc env bty decl in
- let a = elab_attributes env attr in
- let has_fun_typ = is_function_type env ty in
- if inl && not has_fun_typ then
- error loc "'inline' can only appear on functions";
- let a' =
- if noret then begin
- warning loc Celeven_extension "_Noreturn functions are a C11 extension";
- if not has_fun_typ then
- error loc "'_Noreturn' can only appear on functions";
- add_attributes [Attr("noreturn",[])] a
- end else a in
- if has_std_alignas env ty && has_fun_typ then
- error loc "alignment specified for function '%s'" id;
- ((id, add_attributes_type a' ty, init), env1) in
- (mmap elab_one_name env' namelist, sto, tydef)
(* Elaboration of a field group *)
@@ -1076,7 +1066,7 @@ and elab_struct_or_union_info kind loc env members attrs =
| fld :: rem ->
if wrap incomplete_type loc env' fld.fld_typ then
(* Must be fatal otherwise we get problems constructing the init *)
- fatal_error loc "member '%a' has incomplete type" pp_field fld.fld_name;
+ fatal_error loc "member '%a' has incomplete type %a" pp_field fld.fld_name (print_typ env) fld.fld_typ;
if wrap contains_flex_array_mem loc env' fld.fld_typ && kind = Struct then
warning loc Flexible_array_extensions "%a may not be used as a struct member due to flexible array member" (print_typ env) fld.fld_typ;
check_reduced_alignment loc env' fld.fld_typ;
@@ -1631,7 +1621,7 @@ end;
try
elab_item (I.top env root ty_root) ie []
with No_default_init ->
- error loc "variable has incomplete type %a" Cprint.typ ty_root;
+ error loc "variable has incomplete type %a" (print_typ env) ty_root;
raise Exit
(* Elaboration of a top-level initializer *)
@@ -1706,7 +1696,7 @@ let elab_expr ctx loc env a =
error "arithmetic on a pointer to an incomplete type %a in binary '%c'" (print_typ env) ty s
in
- let check_static_var id sto ty =
+ let check_static_var env id sto ty =
if ctx.ctx_nonstatic_inline
&& sto = Storage_static
&& List.mem AConst (attributes_of_type env ty)
@@ -1720,7 +1710,7 @@ let elab_expr ctx loc env a =
| VARIABLE s ->
begin match wrap Env.lookup_ident loc env s with
| (id, Env.II_ident(sto, ty)) ->
- check_static_var id sto ty;
+ check_static_var env id sto ty;
{ edesc = EVar id; etyp = ty },env
| (id, Env.II_enum v) ->
{ edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) },env
@@ -1822,13 +1812,54 @@ let elab_expr ctx loc env a =
(print_typ env) ty (print_typ env) ty' (print_typ env) ty' (print_typ env) ty;
{ edesc = ECall(ident, [b2; b3]); etyp = ty },env
+ | CALL((VARIABLE "__builtin_sel" as a0), al) ->
+ begin match al with
+ | [a1; a2; a3] ->
+ let b0,env = elab env a0 in
+ let b1,env = elab env a1 in
+ let b2,env = elab env a2 in
+ let b3,env = elab env a3 in
+ if not (is_scalar_type env b1.etyp) then
+ error "first argument of '__builtin_sel' is not a scalar type (invalid %a)"
+ (print_typ env) b1.etyp;
+ let tyres =
+ match pointer_decay env b2.etyp, pointer_decay env b3.etyp with
+ | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) ->
+ binary_conversion env b2.etyp b3.etyp
+ | (TPtr(ty1, a1) as pty1), (TPtr(ty2, a2) as pty2) ->
+ if is_void_type env ty1 || is_void_type env ty2 then
+ TPtr(TVoid (add_attributes a1 a2), [])
+ else begin
+ match combine_types AttrIgnoreAll env pty1 pty2 with
+ | None ->
+ warning Pointer_type_mismatch "the second and third arguments of '__builtin_sel' have incompatible pointer types (%a and %a)"
+ (print_typ env) pty1 (print_typ env) pty2;
+ (* tolerance *)
+ TPtr(TVoid (add_attributes a1 a2), [])
+ | Some ty -> ty
+ end
+ | _, _ ->
+ fatal_error "wrong types (%a and %a) for the second and third arguments of '__builtin_sel'"
+ (print_typ env) b2.etyp (print_typ env) b3.etyp
+
+ in
+ { edesc = ECall(b0, [b1; b2; b3]); etyp = tyres }, env
+ | _ ->
+ fatal_error "'__builtin_sel' expect 3 arguments"
+ end
+
| CALL(a1, al) ->
let b1,env =
(* Catch the old-style usage of calling a function without
having declared it *)
match a1 with
| VARIABLE n when not (Env.ident_is_bound env n) ->
- warning Implicit_function_declaration "implicit declaration of function '%s' is invalid in C99" n;
+ let is_builtin = String.length n > 10
+ && String.sub n 0 10 = "__builtin_" in
+ if is_builtin then
+ error "use of unknown builtin '%s'" n
+ else
+ warning Implicit_function_declaration "implicit declaration of function '%s' is invalid in C99" n;
let ty = TFun(TInt(IInt, []), None, false, []) in
(* Check against other definitions and enter in env *)
let (id, sto, env, ty, linkage) =
@@ -1837,7 +1868,7 @@ let elab_expr ctx loc env a =
emit_elab ~linkage env loc (Gdecl(sto, id, ty, None));
{ edesc = EVar id; etyp = ty },env
| _ -> elab env a1 in
- let bl = mmap elab env al in
+ let (bl, env) = mmap elab env al in
(* Extract type information *)
let (res, args, vararg) =
match unroll env b1.etyp with
@@ -1852,14 +1883,19 @@ let elab_expr ctx loc env a =
(* Type-check the arguments against the prototype *)
let bl',env =
match args with
- | None -> bl
- | Some proto -> elab_arguments 1 bl proto vararg in
+ | None ->
+ List.iter (fun arg ->
+ let arg_typ = argument_conversion env arg.etyp in
+ if incomplete_type env arg_typ then
+ error "argument type %a is incomplete" (print_typ env) arg.etyp;
+ ) bl; (bl,env)
+ | Some proto -> elab_arguments 1 (bl, env) proto vararg in
{ edesc = ECall(b1, bl'); etyp = res },env
| UNARY(POSINCR, a1) ->
- elab_pre_post_incr_decr Opostincr "increment" a1
+ elab_pre_post_incr_decr env Opostincr "increment" a1
| UNARY(POSDECR, a1) ->
- elab_pre_post_incr_decr Opostdecr "decrement" a1
+ elab_pre_post_incr_decr env Opostdecr "decrement" a1
(* 6.5.4 Cast operators *)
@@ -1888,6 +1924,8 @@ let elab_expr ctx loc env a =
| CAST ((spec, dcl), ie) ->
let (ty, env) = elab_type loc env spec dcl in
+ if not (is_array_type env ty) && incomplete_type env ty then
+ fatal_error "ill-formed compound literal with incomplete type %a" (print_typ env) ty;
begin match elab_initializer loc env "<compound literal>" ty ie with
| (ty', Some i) -> { edesc = ECompound(ty', i); etyp = ty' },env
| (ty', None) -> fatal_error "ill-formed compound literal"
@@ -2018,20 +2056,20 @@ let elab_expr ctx loc env a =
end
| UNARY(PREINCR, a1) ->
- elab_pre_post_incr_decr Opreincr "increment" a1
+ elab_pre_post_incr_decr env Opreincr "increment" a1
| UNARY(PREDECR, a1) ->
- elab_pre_post_incr_decr Opredecr "decrement" a1
+ elab_pre_post_incr_decr env Opredecr "decrement" a1
(* 6.5.5 to 6.5.12 Binary operator expressions *)
| BINARY(MUL, a1, a2) ->
- elab_binary_arithmetic "*" Omul a1 a2
+ elab_binary_arithmetic env "*" Omul a1 a2
| BINARY(DIV, a1, a2) ->
- elab_binary_arithmetic "/" Odiv a1 a2
+ elab_binary_arithmetic env "/" Odiv a1 a2
| BINARY(MOD, a1, a2) ->
- elab_binary_integer "%" Omod a1 a2
+ elab_binary_integer env "%" Omod a1 a2
| BINARY(ADD, a1, a2) ->
let b1,env = elab env a1 in
@@ -2081,37 +2119,37 @@ let elab_expr ctx loc env a =
{ edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres },env
| BINARY(SHL, a1, a2) ->
- elab_shift "<<" Oshl a1 a2
+ elab_shift env "<<" Oshl a1 a2
| BINARY(SHR, a1, a2) ->
- elab_shift ">>" Oshr a1 a2
+ elab_shift env ">>" Oshr a1 a2
| BINARY(EQ, a1, a2) ->
- elab_comparison Oeq a1 a2
+ elab_comparison env Oeq a1 a2
| BINARY(NE, a1, a2) ->
- elab_comparison One a1 a2
+ elab_comparison env One a1 a2
| BINARY(LT, a1, a2) ->
- elab_comparison Olt a1 a2
+ elab_comparison env Olt a1 a2
| BINARY(GT, a1, a2) ->
- elab_comparison Ogt a1 a2
+ elab_comparison env Ogt a1 a2
| BINARY(LE, a1, a2) ->
- elab_comparison Ole a1 a2
+ elab_comparison env Ole a1 a2
| BINARY(GE, a1, a2) ->
- elab_comparison Oge a1 a2
+ elab_comparison env Oge a1 a2
| BINARY(BAND, a1, a2) ->
- elab_binary_integer "&" Oand a1 a2
+ elab_binary_integer env "&" Oand a1 a2
| BINARY(BOR, a1, a2) ->
- elab_binary_integer "|" Oor a1 a2
+ elab_binary_integer env "|" Oor a1 a2
| BINARY(XOR, a1, a2) ->
- elab_binary_integer "^" Oxor a1 a2
+ elab_binary_integer env "^" Oxor a1 a2
(* 6.5.13 and 6.5.14 Logical operator expressions *)
| BINARY(AND, a1, a2) ->
- elab_logical_operator "&&" Ologand a1 a2
+ elab_logical_operator env "&&" Ologand a1 a2
| BINARY(OR, a1, a2) ->
- elab_logical_operator "||" Ologor a1 a2
+ elab_logical_operator env "||" Ologor a1 a2
(* 6.5.15 Conditional expressions *)
| QUESTION(a1, a2, a3) ->
@@ -2227,7 +2265,7 @@ let elab_expr ctx loc env a =
{ edesc = EBinop (Ocomma, b1, b2, ty2); etyp = ty2 },env
(* Elaboration of pre- or post- increment/decrement *)
- and elab_pre_post_incr_decr op msg a1 =
+ and elab_pre_post_incr_decr env op msg a1 =
let b1,env = elab env a1 in
if not (is_modifiable_lvalue env b1) then
error "expression is not assignable";
@@ -2236,7 +2274,7 @@ let elab_expr ctx loc env a =
{ edesc = EUnop(op, b1); etyp = b1.etyp },env
(* Elaboration of binary operators over integers *)
- and elab_binary_integer msg op a1 a2 =
+ and elab_binary_integer env msg op a1 a2 =
let b1,env = elab env a1 in
let b2,env = elab env a2 in
if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then
@@ -2246,7 +2284,7 @@ let elab_expr ctx loc env a =
{ edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env
(* Elaboration of binary operators over arithmetic types *)
- and elab_binary_arithmetic msg op a1 a2 =
+ and elab_binary_arithmetic env msg op a1 a2 =
let b1,env = elab env a1 in
let b2,env = elab env a2 in
if not ((is_arith_type env b1.etyp) && (is_arith_type env b2.etyp)) then
@@ -2256,7 +2294,7 @@ let elab_expr ctx loc env a =
{ edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env
(* Elaboration of shift operators *)
- and elab_shift msg op a1 a2 =
+ and elab_shift env msg op a1 a2 =
let b1,env = elab env a1 in
let b2,env = elab env a2 in
if not ((is_integer_type env b1.etyp) && (is_integer_type env b2.etyp)) then
@@ -2266,7 +2304,7 @@ let elab_expr ctx loc env a =
{ edesc = EBinop(op, b1, b2, tyres); etyp = tyres },env
(* Elaboration of comparisons *)
- and elab_comparison op a1 a2 =
+ and elab_comparison env op a1 a2 =
let b1,env = elab env a1 in
let b2,env = elab env a2 in
let resdesc =
@@ -2303,7 +2341,7 @@ let elab_expr ctx loc env a =
{ edesc = resdesc; etyp = TInt(IInt, []) },env
(* Elaboration of && and || *)
- and elab_logical_operator msg op a1 a2 =
+ and elab_logical_operator env msg op a1 a2 =
let b1,env = elab env a1 in
let b2,env = elab env a2 in
if not ((is_scalar_type env b1.etyp) && (is_scalar_type env b2.etyp)) then
@@ -2371,113 +2409,106 @@ let __func__type_and_init s =
(* Elaboration of top-level and local definitions *)
-let enter_typedefs loc env sto dl =
- if sto <> Storage_default then
- error loc "non-default storage class on 'typedef' definition";
- if dl = [] then
- warning loc Missing_declarations "typedef requires a name";
- List.fold_left (fun env (s, ty, init) ->
- if init <> NO_INIT then
- error loc "initializer in typedef";
- if has_std_alignas env ty then
- error loc "alignment specified for typedef '%s'" s;
- List.iter
- (fun a -> match class_of_attribute a with
- | Attr_object | Attr_struct ->
- error loc "attribute '%s' not allowed in 'typedef'"
- (name_of_attribute a)
- | _ -> ())
- (attributes_of_type_no_expand ty);
- match previous_def Env.lookup_typedef env s with
- | Some (s',ty') when Env.in_current_scope env s' ->
- if equal_types env ty ty' then begin
- warning loc Celeven_extension "redefinition of typedef '%s' is a C11 extension" s;
- env
- end else begin
- error loc "typedef redefinition with different types (%a vs %a)"
- (print_typ env) ty (print_typ env) ty';
- env
- end
- | _ ->
- if redef Env.lookup_ident env s then
- error loc "redefinition of '%s' as different kind of symbol" s;
- let (id, env') = Env.enter_typedef env s ty in
- check_reduced_alignment loc env' ty;
- emit_elab env loc (Gtypedef(id, ty));
- env') env dl
-
-let enter_decdefs local nonstatic_inline loc env sto dl =
- (* Sanity checks on storage class *)
- if (sto = Storage_auto || sto = Storage_register) && not local then
- fatal_error loc "illegal storage class %s on file-scoped variable"
- (name_of_storage_class sto);
- if sto <> Storage_default && dl = [] then
- warning loc Missing_declarations "declaration does not declare anything";
- let enter_decdef (decls, env) (s, ty, init) =
- let isfun = is_function_type env ty in
- if sto = Storage_register && has_std_alignas env ty then
- error loc "alignment specified for 'register' object '%s'" s;
- if sto = Storage_extern && init <> NO_INIT then
- error loc "'extern' declaration variable has an initializer";
- if local && isfun then begin
- match sto with
- | Storage_static ->
- error loc "function declared in block scope cannot have 'static' storage class"
- | Storage_auto | Storage_register ->
- error loc "illegal storage class %s on function"
- (name_of_storage_class sto)
- | _ -> ()
- end;
- if is_qualified_array ty then
- error loc "type qualifier used in array declarator outside of function prototype";
- (* Local variable declarations with default storage are treated as 'auto'.
- Local function declarations with default storage remain with
- default storage. *)
- let sto1 =
- if local && sto = Storage_default && not isfun
- then Storage_auto
- else sto in
- (* enter ident in environment with declared type, because
- initializer can refer to the ident *)
- let (id, sto', env1, ty, linkage) =
- enter_or_refine_ident local loc env s sto1 ty in
- if init <> NO_INIT && not local then
- add_global_define loc s;
- if not isfun && is_void_type env ty then
- fatal_error loc "'%s' has incomplete type" s;
- (* process the initializer *)
- let (ty', init') = elab_initializer loc env1 s ty init in
- (* update environment with refined type *)
- let env2 = Env.add_ident env1 id sto' ty' in
- (* check for incomplete type *)
- if not isfun && wrap incomplete_type loc env ty' then
- if not local && sto' = Storage_static then begin
- warning loc Tentative_incomplete_static "tentative static definition with incomplete type";
- end else if local && sto' <> Storage_extern then
- error loc "variable has incomplete type %a" (print_typ env) ty';
- (* check if alignment is reduced *)
- check_reduced_alignment loc env ty';
- (* check for static variables in nonstatic inline functions *)
- if local && nonstatic_inline
- && sto' = Storage_static
- && not (List.mem AConst (attributes_of_type env ty')) then
- warning loc Static_in_inline "non-constant static local variable '%s' in inline function may be different in different files" s;
- if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then
- (* Local definition *)
- ((sto', id, ty', init') :: decls, env2)
+let enter_typedef loc env sto (s, ty, init) =
+ if init <> NO_INIT then
+ error loc "initializer in typedef";
+ if has_std_alignas env ty then
+ error loc "alignment specified for typedef '%s'" s;
+ List.iter
+ (fun a -> match class_of_attribute a with
+ | Attr_object | Attr_struct ->
+ error loc "attribute '%s' not allowed in 'typedef'"
+ (name_of_attribute a)
+ | _ -> ())
+ (attributes_of_type_no_expand ty);
+ match previous_def Env.lookup_typedef env s with
+ | Some (s',ty') when Env.in_current_scope env s' ->
+ if equal_types env ty ty' then begin
+ warning loc Celeven_extension "redefinition of typedef '%s' is a C11 extension" s;
+ env
+ end
else begin
- (* Global definition *)
- emit_elab ~linkage env2 loc (Gdecl(sto', id, ty', init'));
- (* Make sure the initializer is constant. *)
- begin match init' with
+ error loc "redefinition of typedef '%s' with different type (%a vs %a)"
+ s (print_typ env) ty (print_typ env) ty';
+ env
+ end
+ | _ ->
+ if redef Env.lookup_ident env s then
+ error loc "redefinition of '%s' as different kind of symbol" s;
+ let (id, env') = Env.enter_typedef env s ty in
+ check_reduced_alignment loc env' ty;
+ emit_elab env loc (Gtypedef(id, ty));
+ env'
+
+let enter_decdef local nonstatic_inline loc sto (decls, env) (s, ty, init) =
+ let isfun = is_function_type env ty in
+ let has_init = init <> NO_INIT in
+ if sto = Storage_register && has_std_alignas env ty then
+ error loc "alignment specified for 'register' object '%s'" s;
+ if sto = Storage_extern && has_init then
+ error loc "'extern' declaration variable has an initializer";
+ if local && isfun then begin
+ match sto with
+ | Storage_static ->
+ error loc "function declared in block scope cannot have 'static' storage class"
+ | Storage_auto | Storage_register ->
+ error loc "illegal storage class %s on function"
+ (name_of_storage_class sto)
+ | _ -> ()
+ end;
+ if is_qualified_array ty then
+ error loc "type qualifier used in array declarator outside of function prototype";
+ (* Local variable declarations with default storage are treated as 'auto'.
+ Local function declarations with default storage remain with
+ default storage. *)
+ let sto1 =
+ if local && sto = Storage_default && not isfun
+ then Storage_auto
+ else sto in
+ (* enter ident in environment with declared type, because
+ initializer can refer to the ident *)
+ let (id, sto', env1, ty, linkage) =
+ enter_or_refine_ident local loc env s sto1 ty in
+ if has_init && not local then
+ add_global_define loc s;
+ (* check if the type is void or incomplete and the declaration is initialized *)
+ if not isfun then begin
+ let incomplete_init = not (is_array_type env1 ty) && wrap incomplete_type loc env1 ty && has_init in
+ if is_void_type env1 ty || incomplete_init then
+ fatal_error loc "variable '%s' has incomplete type %a" s (print_typ env) ty;
+ end;
+ (* process the initializer *)
+ let (ty', init') = elab_initializer loc env1 s ty init in
+ (* update environment with refined type *)
+ let env2 = Env.add_ident env1 id sto' ty' in
+ (* check for incomplete type *)
+ if not isfun && wrap incomplete_type loc env ty' then
+ if not local && sto' = Storage_static then begin
+ warning loc Tentative_incomplete_static "tentative static definition with incomplete type";
+ end
+ else if local && sto' <> Storage_extern then
+ error loc "variable '%s' has incomplete type %a" s (print_typ env) ty';
+ (* check if alignment is reduced *)
+ check_reduced_alignment loc env ty';
+ (* check for static variables in nonstatic inline functions *)
+ if local && nonstatic_inline
+ && sto' = Storage_static
+ && not (List.mem AConst (attributes_of_type env ty')) then
+ warning loc Static_in_inline "non-constant static local variable '%s' in inline function may be different in different files" s;
+ if local && not isfun && sto' <> Storage_extern && sto' <> Storage_static then
+ (* Local definition *)
+ ((sto', id, ty', init') :: decls, env2)
+ else begin
+ (* Global definition *)
+ emit_elab ~linkage env2 loc (Gdecl(sto', id, ty', init'));
+ (* Make sure the initializer is constant. *)
+ begin match init' with
| Some i when not (Ceval.is_constant_init env2 i) ->
- error loc "initializer is not a compile-time constant"
+ error loc "initializer is not a compile-time constant"
| _ -> ()
- end;
- (decls, env2)
- end in
- let (decls, env') = List.fold_left enter_decdef ([], env) dl in
- (List.rev decls, env')
+ end;
+ (decls, env2)
+ end
(* Processing of K&R-style function definitions. Synopsis:
T f(X1, ..., Xn)
@@ -2650,10 +2681,10 @@ let elab_fundef genv spec name defs body loc =
and additionally they should have an identifier. In both cases a fatal
error is raised in order to avoid problems at later places. *)
let add_param env (id, ty) =
- if wrap incomplete_type loc env ty then
- fatal_error loc "parameter has incomplete type";
if id.C.name = "" then
fatal_error loc "parameter name omitted";
+ if wrap incomplete_type loc env ty then
+ fatal_error loc "parameter '%s' has incomplete type %a" id.C.name (print_typ env) ty;
Env.add_ident env id Storage_default ty
in
(* Enter parameters and extra declarations in the local environment.
@@ -2661,7 +2692,7 @@ let elab_fundef genv spec name defs body loc =
For prototyped functions this has been done by [elab_fundef_name]
already, but some parameter may have been shadowed by the
function name, while it should be the other way around, e.g.
- [int f(int f) { return f+1; }], with [f] refering to the
+ [int f(int f) { return f+1; }], with [f] referring to the
parameter [f] and not to the function [f] within the body of the
function. *)
let lenv =
@@ -2733,6 +2764,51 @@ let elab_fundef genv spec name defs body loc =
genv
(* Definitions *)
+let elab_decdef (for_loop: bool) (local: bool) (nonstatic_inline: bool)
+ (env: Env.t) ((spec, namelist): Cabs.init_name_group)
+ (loc: Cabs.loc) : decl list * Env.t =
+ let (sto, inl, noret, tydef, bty, env') =
+ elab_specifier ~only:(namelist=[]) loc env spec in
+ (* Sanity checks on storage class *)
+ if tydef then begin
+ if sto <> Storage_default then
+ error loc "non-default storage class on 'typedef' definition";
+ if namelist = [] then
+ warning loc Missing_declarations "typedef requires a name";
+ end else begin
+ if (sto = Storage_auto || sto = Storage_register) && not local then
+ fatal_error loc "illegal storage class %s on file-scoped variable"
+ (name_of_storage_class sto);
+ if sto <> Storage_default && namelist = [] then
+ warning loc Missing_declarations "declaration does not declare anything";
+ end;
+ let elab_one_name (decls, env) (Init_name (Name (id, decl, attr, loc), init)) =
+ let ((ty, _), env1) =
+ elab_type_declarator loc env bty decl in
+ let a = elab_attributes env attr in
+ let has_fun_typ = is_function_type env ty in
+ if for_loop && (has_fun_typ || sto = Storage_extern || sto = Storage_static || tydef) then
+ error loc "declaration of non-local variable in 'for' loop" ;
+ if has_fun_typ then begin
+ if noret then
+ warning loc Celeven_extension "_Noreturn functions are a C11 extension";
+ end else begin
+ if inl then
+ error loc "'inline' can only appear on functions";
+ if noret then
+ error loc "'_Noreturn' can only appear on functions";
+ end;
+ let a' = if noret then add_attributes [Attr ("noreturn", [])] a else a in
+ if has_std_alignas env ty && has_fun_typ then
+ error loc "alignment specified for function '%s'" id;
+ let decl = (id, add_attributes_type a' ty, init) in
+ if tydef then
+ (decls, enter_typedef loc env1 sto decl)
+ else
+ enter_decdef local nonstatic_inline loc sto (decls, env1) decl
+ in
+ let (decls, env') = List.fold_left elab_one_name ([],env') namelist in
+ (List.rev decls, env')
let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool)
(env: Env.t) (def: Cabs.definition)
@@ -2747,18 +2823,7 @@ let elab_definition (for_loop: bool) (local: bool) (nonstatic_inline: bool)
(* "int x = 12, y[10], *z" *)
| DECDEF(init_name_group, loc) ->
- let ((dl, env1), sto, tydef) =
- elab_init_name_group loc env init_name_group in
- if for_loop then begin
- let fun_declaration = List.exists (fun (_, ty, _) -> is_function_type env ty) dl in
- if fun_declaration || sto = Storage_extern || sto = Storage_static || tydef then
- error loc "declaration of non-local variable in 'for' loop" ;
- end;
- if tydef then
- let env2 = enter_typedefs loc env1 sto dl
- in ([], env2)
- else
- enter_decdefs local nonstatic_inline loc env1 sto dl
+ elab_decdef for_loop local nonstatic_inline env init_name_group loc
(* pragma *)
| PRAGMA(s, loc) ->
@@ -2885,48 +2950,49 @@ let rec elab_stmt env ctx s =
(* 6.8.4 Conditional statements *)
| If(a, s1, s2, loc) ->
- let a',env = elab_expr ctx loc env a in
- if not (is_scalar_type env a'.etyp) then
+ let a',env' = elab_expr ctx loc (Env.new_scope env) a in
+ if not (is_scalar_type env' a'.etyp) then
error loc "controlling expression of 'if' does not have scalar type (%a invalid)"
- (print_typ env) a'.etyp;
- let s1',env = elab_stmt env ctx s1 in
- let s2',env =
+ (print_typ env') a'.etyp;
+ let s1' = elab_stmt_new_scope env' ctx s1 in
+ let s2' =
match s2 with
- | None -> sskip,env
- | Some s2 -> elab_stmt env ctx s2
+ | None -> sskip
+ | Some s2 -> elab_stmt_new_scope env' ctx s2
in
{ sdesc = Sif(a', s1', s2'); sloc = elab_loc loc },env
(* 6.8.5 Iterative statements *)
| WHILE(a, s1, loc) ->
- let a',env = elab_expr ctx loc env a in
- if not (is_scalar_type env a'.etyp) then
+ let a',env' = elab_expr ctx loc (Env.new_scope env) a in
+ if not (is_scalar_type env' a'.etyp) then
error loc "controlling expression of 'while' does not have scalar type (%a invalid)"
- (print_typ env) a'.etyp;
- let s1',env = elab_stmt env (ctx_loop ctx) s1 in
+ (print_typ env') a'.etyp;
+ let s1' = elab_stmt_new_scope env' (ctx_loop ctx) s1 in
{ sdesc = Swhile(a', s1'); sloc = elab_loc loc },env
| DOWHILE(a, s1, loc) ->
- let s1',env = elab_stmt env (ctx_loop ctx) s1 in
- let a',env = elab_expr ctx loc env a in
- if not (is_scalar_type env a'.etyp) then
+ let s1' = elab_stmt_new_scope env (ctx_loop ctx) s1 in
+ let a',env' = elab_expr ctx loc (Env.new_scope env) a in
+ if not (is_scalar_type env' a'.etyp) then
error loc "controlling expression of 'while' does not have scalar type (%a invalid)"
- (print_typ env) a'.etyp;
+ (print_typ env') a'.etyp;
{ sdesc = Sdowhile(s1', a'); sloc = elab_loc loc },env
| FOR(fc, a2, a3, s1, loc) ->
+ let env' = Env.new_scope env in
let (a1', env_decls, decls') =
match fc with
| Some (FC_EXP a1) ->
- let a1,env = elab_for_expr ctx loc env (Some a1) in
+ let a1,env = elab_for_expr ctx loc env' (Some a1) in
(a1, env, None)
| None ->
- let a1,env = elab_for_expr ctx loc env None in
+ let a1,env = elab_for_expr ctx loc env' None in
(a1, env, None)
| Some (FC_DECL def) ->
let (dcl, env') = elab_definition true true ctx.ctx_nonstatic_inline
- (Env.new_scope env) def in
+ env' def in
let loc = elab_loc (Cabshelper.get_definitionloc def) in
(sskip, env',
Some(List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl)) in
@@ -2938,7 +3004,7 @@ let rec elab_stmt env ctx s =
if not (is_scalar_type env_test a2'.etyp) then
error loc "controlling expression of 'for' does not have scalar type (%a invalid)" (print_typ env) a2'.etyp;
let a3',env_for = elab_for_expr ctx loc env_test a3 in
- let s1',env_body = elab_stmt env_for (ctx_loop ctx) s1 in
+ let s1' = elab_stmt_new_scope env_for (ctx_loop ctx) s1 in
let sfor = { sdesc = Sfor(a1', a2', a3', s1'); sloc = elab_loc loc } in
begin match decls' with
| None -> sfor,env
@@ -2947,11 +3013,11 @@ let rec elab_stmt env ctx s =
(* 6.8.4 Switch statement *)
| SWITCH(a, s1, loc) ->
- let a',env = elab_expr ctx loc env a in
- if not (is_integer_type env a'.etyp) then
+ let a',env' = elab_expr ctx loc (Env.new_scope env) a in
+ if not (is_integer_type env' a'.etyp) then
error loc "controlling expression of 'switch' does not have integer type (%a invalid)"
- (print_typ env) a'.etyp;
- let s1',env = elab_stmt env (ctx_switch ctx) s1 in
+ (print_typ env') a'.etyp;
+ let s1' = elab_stmt_new_scope env' (ctx_switch ctx) s1 in
check_switch_cases s1';
{ sdesc = Sswitch(a', s1'); sloc = elab_loc loc },env
@@ -3025,6 +3091,10 @@ let rec elab_stmt env ctx s =
| DEFINITION def ->
error (Cabshelper.get_definitionloc def) "ill-placed definition";
sskip,env
+(* Elaborate a statement as a block whose scope is a strict subset of the scope
+ of its enclosing block. *)
+and elab_stmt_new_scope env ctx s =
+ fst (elab_stmt (Env.new_scope env) ctx s)
and elab_block loc env ctx b =
let b',_ = elab_block_body (Env.new_scope env) ctx b in
@@ -3077,10 +3147,11 @@ let _ = elab_funbody_f := elab_funbody
let elab_file prog =
reset();
- let env = Builtins.environment () in
+ let env = Env.initial () in
let elab_def env d = snd (elab_definition false false false env d) in
ignore (List.fold_left elab_def env prog);
let p = elaborated_program () in
Checks.unused_variables p;
Checks.unknown_attrs_program p;
+ Checks.non_linear_conditional p;
p
diff --git a/cparser/Elab.mli b/cparser/Elab.mli
index f701e8c5..59c5efc1 100644
--- a/cparser/Elab.mli
+++ b/cparser/Elab.mli
@@ -18,8 +18,8 @@ val elab_file : Cabs.definition list -> C.program
definitions as produced by the parser into a program in C abstract
syntax. *)
-val elab_int_constant : Cabs.cabsloc -> string -> int64 * C.ikind
+val elab_int_constant : Cabs.loc -> string -> int64 * C.ikind
val elab_float_constant : Cabs.floatInfo -> C.float_cst * C.fkind
-val elab_char_constant : Cabs.cabsloc -> bool -> int64 list -> int64
+val elab_char_constant : Cabs.loc -> bool -> int64 list -> int64
(* These auxiliary functions are exported so that they can be reused
in other projects that deal with C-style source languages. *)
diff --git a/cparser/Env.ml b/cparser/Env.ml
index 5fa4571a..4723a725 100644
--- a/cparser/Env.ml
+++ b/cparser/Env.ml
@@ -276,6 +276,46 @@ let add_enum env id info =
let add_types env_old env_new =
{ env_new with env_ident = env_old.env_ident;env_scope = env_old.env_scope;}
+(* Initial environment describing the built-in types and functions *)
+
+module Init = struct
+
+let env = ref empty
+let idents = ref []
+let decls = ref []
+
+let no_loc = ("", -1)
+
+let add_typedef (s, ty) =
+ let (id, env') = enter_typedef !env s ty in
+ env := env';
+ idents := id :: !idents;
+ decls := {gdesc = Gtypedef(id, ty); gloc = no_loc} :: !decls
+
+let add_function (s, (res, args, va)) =
+ let ty =
+ TFun(res,
+ Some (List.map (fun ty -> (fresh_ident "", ty)) args),
+ va, []) in
+ let (id, env') = enter_ident !env s Storage_extern ty in
+ env := env';
+ idents := id :: !idents;
+ decls :=
+ {gdesc = Gdecl(Storage_extern, id, ty, None); gloc = no_loc} :: !decls
+
+end
+
+let initial () = !Init.env
+let initial_identifiers () = !Init.idents
+let initial_declarations () = List.rev !Init.decls
+
+let set_builtins blt =
+ Init.env := empty;
+ Init.idents := [];
+ Init.decls := [];
+ List.iter Init.add_typedef blt.builtin_typedefs;
+ List.iter Init.add_function blt.builtin_functions
+
(* Error reporting *)
open Printf
diff --git a/cparser/Env.mli b/cparser/Env.mli
index 7ea2c514..1baab68f 100644
--- a/cparser/Env.mli
+++ b/cparser/Env.mli
@@ -77,3 +77,10 @@ val add_typedef : t -> C.ident -> typedef_info -> t
val add_enum : t -> C.ident -> enum_info -> t
val add_types : t -> t -> t
+
+(* Initial environment describing the builtin types and functions *)
+
+val initial: unit -> t
+val initial_identifiers: unit -> C.ident list
+val initial_declarations: unit -> C.globdecl list
+val set_builtins: C.builtins -> unit
diff --git a/cparser/GCC.ml b/cparser/GCC.ml
index 010d12f3..458e51d3 100644
--- a/cparser/GCC.ml
+++ b/cparser/GCC.ml
@@ -38,10 +38,10 @@ let intPtrType = TPtr(TInt(IInt, []), [])
let sizeType() = TInt(size_t_ikind(), [])
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list", voidPtrType
];
- Builtins.functions = [
+ builtin_functions = [
"__builtin___fprintf_chk", (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
"__builtin___memcpy_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType(); sizeType() ], false);
"__builtin___memmove_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType(); sizeType() ], false);
diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll
index b2a668f0..e44a330f 100644
--- a/cparser/Lexer.mll
+++ b/cparser/Lexer.mll
@@ -20,14 +20,21 @@ open Pre_parser_aux
module SSet = Set.Make(String)
-let lexicon : (string, Cabs.cabsloc -> token) Hashtbl.t = Hashtbl.create 17
+let lexicon : (string, Cabs.loc -> token) Hashtbl.t = Hashtbl.create 17
let ignored_keywords : SSet.t ref = ref SSet.empty
+let reserved_keyword loc id =
+ Diagnostics.fatal_error (loc.Cabs.filename, loc.Cabs.lineno)
+ "illegal use of reserved keyword `%s'" id
+
let () =
List.iter (fun (key, builder) -> Hashtbl.add lexicon key builder)
- [ ("_Alignas", fun loc -> ALIGNAS loc);
+ [
+ ("_Alignas", fun loc -> ALIGNAS loc);
("_Alignof", fun loc -> ALIGNOF loc);
("_Bool", fun loc -> UNDERSCORE_BOOL loc);
+ ("_Complex", fun loc -> reserved_keyword loc "_Complex");
+ ("_Imaginary", fun loc -> reserved_keyword loc "_Imaginary");
("__alignof", fun loc -> ALIGNOF loc);
("__alignof__", fun loc -> ALIGNOF loc);
("__asm", fun loc -> ASM loc);
@@ -170,7 +177,7 @@ let identifier_nondigit =
let identifier = identifier_nondigit (identifier_nondigit|digit)*
(* Whitespaces *)
-let whitespace_char_no_newline = [' ' '\t' '\012' '\r']
+let whitespace_char_no_newline = [' ' '\t' '\011' '\012' '\r']
(* Integer constants *)
let nonzero_digit = ['1'-'9']
@@ -427,10 +434,7 @@ and singleline_comment = parse
| _ { singleline_comment lexbuf }
{
- open Streams
- open Specif
- open Parser
- open !Aut.GramDefs
+ open Parser.MenhirLibParser.Inter
(* This is the main entry point to the lexer. *)
@@ -456,8 +460,8 @@ and singleline_comment = parse
curr_id := None;
let loc = currentLoc lexbuf in
let token =
- if SSet.mem id !types_context then TYPEDEF_NAME (id, ref TypedefId, loc)
- else VAR_NAME (id, ref VarId, loc)
+ if SSet.mem id !types_context then Pre_parser.TYPEDEF_NAME (id, ref TypedefId, loc)
+ else Pre_parser.VAR_NAME (id, ref VarId, loc)
in
Queue.push token tokens;
token
@@ -490,133 +494,129 @@ and singleline_comment = parse
(* [tokens_stream filename text] runs the pre_parser and produces a stream
of (appropriately classified) tokens. *)
- let tokens_stream filename text : token coq_Stream =
+ let tokens_stream filename text : buffer =
let tokens = Queue.create () in
let buffer = ref ErrorReports.Zero in
invoke_pre_parser filename text (lexer tokens buffer) buffer;
- let rec compute_token_stream () =
- let loop t v =
- Cons (Coq_existT (t, Obj.magic v), Lazy.from_fun compute_token_stream)
- in
+ let rec compute_buffer () =
+ let loop t = Buf_cons (t, Lazy.from_fun compute_buffer) in
match Queue.pop tokens with
- | ADD_ASSIGN loc -> loop ADD_ASSIGN't loc
- | AND loc -> loop AND't loc
- | ANDAND loc -> loop ANDAND't loc
- | AND_ASSIGN loc -> loop AND_ASSIGN't loc
- | AUTO loc -> loop AUTO't loc
- | BANG loc -> loop BANG't loc
- | BAR loc -> loop BAR't loc
- | BARBAR loc -> loop BARBAR't loc
- | UNDERSCORE_BOOL loc -> loop UNDERSCORE_BOOL't loc
- | BREAK loc -> loop BREAK't loc
- | BUILTIN_VA_ARG loc -> loop BUILTIN_VA_ARG't loc
- | BUILTIN_OFFSETOF loc -> loop BUILTIN_OFFSETOF't loc
- | CASE loc -> loop CASE't loc
- | CHAR loc -> loop CHAR't loc
- | COLON loc -> loop COLON't loc
- | COMMA loc -> loop COMMA't loc
- | CONST loc -> loop CONST't loc
- | CONSTANT (cst, loc) -> loop CONSTANT't (cst, loc)
- | CONTINUE loc -> loop CONTINUE't loc
- | DEC loc -> loop DEC't loc
- | DEFAULT loc -> loop DEFAULT't loc
- | DIV_ASSIGN loc -> loop DIV_ASSIGN't loc
- | DO loc -> loop DO't loc
- | DOT loc -> loop DOT't loc
- | DOUBLE loc -> loop DOUBLE't loc
- | ELLIPSIS loc -> loop ELLIPSIS't loc
- | ELSE loc -> loop ELSE't loc
- | ENUM loc -> loop ENUM't loc
- | EOF -> loop EOF't ()
- | EQ loc -> loop EQ't loc
- | EQEQ loc -> loop EQEQ't loc
- | EXTERN loc -> loop EXTERN't loc
- | FLOAT loc -> loop FLOAT't loc
- | FOR loc -> loop FOR't loc
- | GEQ loc -> loop GEQ't loc
- | GOTO loc -> loop GOTO't loc
- | GT loc -> loop GT't loc
- | HAT loc -> loop HAT't loc
- | IF loc -> loop IF't loc
- | INC loc -> loop INC't loc
- | INLINE loc -> loop INLINE't loc
- | INT loc -> loop INT't loc
- | LBRACE loc -> loop LBRACE't loc
- | LBRACK loc -> loop LBRACK't loc
- | LEFT loc -> loop LEFT't loc
- | LEFT_ASSIGN loc -> loop LEFT_ASSIGN't loc
- | LEQ loc -> loop LEQ't loc
- | LONG loc -> loop LONG't loc
- | LPAREN loc -> loop LPAREN't loc
- | LT loc -> loop LT't loc
- | MINUS loc -> loop MINUS't loc
- | MOD_ASSIGN loc -> loop MOD_ASSIGN't loc
- | MUL_ASSIGN loc -> loop MUL_ASSIGN't loc
- | NEQ loc -> loop NEQ't loc
- | NORETURN loc -> loop NORETURN't loc
- | OR_ASSIGN loc -> loop OR_ASSIGN't loc
- | PACKED loc -> loop PACKED't loc
- | PERCENT loc -> loop PERCENT't loc
- | PLUS loc -> loop PLUS't loc
- | PTR loc -> loop PTR't loc
- | QUESTION loc -> loop QUESTION't loc
- | RBRACE loc -> loop RBRACE't loc
- | RBRACK loc -> loop RBRACK't loc
- | REGISTER loc -> loop REGISTER't loc
- | RESTRICT loc -> loop RESTRICT't loc
- | RETURN loc -> loop RETURN't loc
- | RIGHT loc -> loop RIGHT't loc
- | RIGHT_ASSIGN loc -> loop RIGHT_ASSIGN't loc
- | RPAREN loc -> loop RPAREN't loc
- | SEMICOLON loc -> loop SEMICOLON't loc
- | SHORT loc -> loop SHORT't loc
- | SIGNED loc -> loop SIGNED't loc
- | SIZEOF loc -> loop SIZEOF't loc
- | SLASH loc -> loop SLASH't loc
- | STAR loc -> loop STAR't loc
- | STATIC loc -> loop STATIC't loc
- | STRING_LITERAL (wide, str, loc) ->
+ | Pre_parser.ADD_ASSIGN loc -> loop (Parser.ADD_ASSIGN loc)
+ | Pre_parser.AND loc -> loop (Parser.AND loc)
+ | Pre_parser.ANDAND loc -> loop (Parser.ANDAND loc)
+ | Pre_parser.AND_ASSIGN loc -> loop (Parser.AND_ASSIGN loc)
+ | Pre_parser.AUTO loc -> loop (Parser.AUTO loc)
+ | Pre_parser.BANG loc -> loop (Parser.BANG loc)
+ | Pre_parser.BAR loc -> loop (Parser.BAR loc)
+ | Pre_parser.BARBAR loc -> loop (Parser.BARBAR loc)
+ | Pre_parser.UNDERSCORE_BOOL loc -> loop (Parser.UNDERSCORE_BOOL loc)
+ | Pre_parser.BREAK loc -> loop (Parser.BREAK loc)
+ | Pre_parser.BUILTIN_VA_ARG loc -> loop (Parser.BUILTIN_VA_ARG loc)
+ | Pre_parser.BUILTIN_OFFSETOF loc -> loop (Parser.BUILTIN_OFFSETOF loc)
+ | Pre_parser.CASE loc -> loop (Parser.CASE loc)
+ | Pre_parser.CHAR loc -> loop (Parser.CHAR loc)
+ | Pre_parser.COLON loc -> loop (Parser.COLON loc)
+ | Pre_parser.COMMA loc -> loop (Parser.COMMA loc)
+ | Pre_parser.CONST loc -> loop (Parser.CONST loc)
+ | Pre_parser.CONSTANT (cst, loc) -> loop (Parser.CONSTANT (cst, loc))
+ | Pre_parser.CONTINUE loc -> loop (Parser.CONTINUE loc)
+ | Pre_parser.DEC loc -> loop (Parser.DEC loc)
+ | Pre_parser.DEFAULT loc -> loop (Parser.DEFAULT loc)
+ | Pre_parser.DIV_ASSIGN loc -> loop (Parser.DIV_ASSIGN loc)
+ | Pre_parser.DO loc -> loop (Parser.DO loc)
+ | Pre_parser.DOT loc -> loop (Parser.DOT loc)
+ | Pre_parser.DOUBLE loc -> loop (Parser.DOUBLE loc)
+ | Pre_parser.ELLIPSIS loc -> loop (Parser.ELLIPSIS loc)
+ | Pre_parser.ELSE loc -> loop (Parser.ELSE loc)
+ | Pre_parser.ENUM loc -> loop (Parser.ENUM loc)
+ | Pre_parser.EOF -> loop (Parser.EOF ())
+ | Pre_parser.EQ loc -> loop (Parser.EQ loc)
+ | Pre_parser.EQEQ loc -> loop (Parser.EQEQ loc)
+ | Pre_parser.EXTERN loc -> loop (Parser.EXTERN loc)
+ | Pre_parser.FLOAT loc -> loop (Parser.FLOAT loc)
+ | Pre_parser.FOR loc -> loop (Parser.FOR loc)
+ | Pre_parser.GEQ loc -> loop (Parser.GEQ loc)
+ | Pre_parser.GOTO loc -> loop (Parser.GOTO loc)
+ | Pre_parser.GT loc -> loop (Parser.GT loc)
+ | Pre_parser.HAT loc -> loop (Parser.HAT loc)
+ | Pre_parser.IF loc -> loop (Parser.IF_ loc)
+ | Pre_parser.INC loc -> loop (Parser.INC loc)
+ | Pre_parser.INLINE loc -> loop (Parser.INLINE loc)
+ | Pre_parser.INT loc -> loop (Parser.INT loc)
+ | Pre_parser.LBRACE loc -> loop (Parser.LBRACE loc)
+ | Pre_parser.LBRACK loc -> loop (Parser.LBRACK loc)
+ | Pre_parser.LEFT loc -> loop (Parser.LEFT loc)
+ | Pre_parser.LEFT_ASSIGN loc -> loop (Parser.LEFT_ASSIGN loc)
+ | Pre_parser.LEQ loc -> loop (Parser.LEQ loc)
+ | Pre_parser.LONG loc -> loop (Parser.LONG loc)
+ | Pre_parser.LPAREN loc -> loop (Parser.LPAREN loc)
+ | Pre_parser.LT loc -> loop (Parser.LT loc)
+ | Pre_parser.MINUS loc -> loop (Parser.MINUS loc)
+ | Pre_parser.MOD_ASSIGN loc -> loop (Parser.MOD_ASSIGN loc)
+ | Pre_parser.MUL_ASSIGN loc -> loop (Parser.MUL_ASSIGN loc)
+ | Pre_parser.NEQ loc -> loop (Parser.NEQ loc)
+ | Pre_parser.NORETURN loc -> loop (Parser.NORETURN loc)
+ | Pre_parser.OR_ASSIGN loc -> loop (Parser.OR_ASSIGN loc)
+ | Pre_parser.PACKED loc -> loop (Parser.PACKED loc)
+ | Pre_parser.PERCENT loc -> loop (Parser.PERCENT loc)
+ | Pre_parser.PLUS loc -> loop (Parser.PLUS loc)
+ | Pre_parser.PTR loc -> loop (Parser.PTR loc)
+ | Pre_parser.QUESTION loc -> loop (Parser.QUESTION loc)
+ | Pre_parser.RBRACE loc -> loop (Parser.RBRACE loc)
+ | Pre_parser.RBRACK loc -> loop (Parser.RBRACK loc)
+ | Pre_parser.REGISTER loc -> loop (Parser.REGISTER loc)
+ | Pre_parser.RESTRICT loc -> loop (Parser.RESTRICT loc)
+ | Pre_parser.RETURN loc -> loop (Parser.RETURN loc)
+ | Pre_parser.RIGHT loc -> loop (Parser.RIGHT loc)
+ | Pre_parser.RIGHT_ASSIGN loc -> loop (Parser.RIGHT_ASSIGN loc)
+ | Pre_parser.RPAREN loc -> loop (Parser.RPAREN loc)
+ | Pre_parser.SEMICOLON loc -> loop (Parser.SEMICOLON loc)
+ | Pre_parser.SHORT loc -> loop (Parser.SHORT loc)
+ | Pre_parser.SIGNED loc -> loop (Parser.SIGNED loc)
+ | Pre_parser.SIZEOF loc -> loop (Parser.SIZEOF loc)
+ | Pre_parser.SLASH loc -> loop (Parser.SLASH loc)
+ | Pre_parser.STAR loc -> loop (Parser.STAR loc)
+ | Pre_parser.STATIC loc -> loop (Parser.STATIC loc)
+ | Pre_parser.STRING_LITERAL (wide, str, loc) ->
(* Merge consecutive string literals *)
let rec doConcat wide str =
- try
- match Queue.peek tokens with
- | STRING_LITERAL (wide', str', loc) ->
- ignore (Queue.pop tokens);
- let (wide'', str'') = doConcat wide' str' in
- if str'' <> []
- then (wide || wide'', str @ str'')
- else (wide, str)
- | _ ->
- (wide, str)
- with Queue.Empty -> (wide, str) in
- let (wide', str') = doConcat wide str in
- loop STRING_LITERAL't ((wide', str'), loc)
- | STRUCT loc -> loop STRUCT't loc
- | SUB_ASSIGN loc -> loop SUB_ASSIGN't loc
- | SWITCH loc -> loop SWITCH't loc
- | TILDE loc -> loop TILDE't loc
- | TYPEDEF loc -> loop TYPEDEF't loc
- | TYPEDEF_NAME (id, typ, loc)
- | VAR_NAME (id, typ, loc) ->
- let terminal = match !typ with
- | VarId -> VAR_NAME't
- | TypedefId -> TYPEDEF_NAME't
- | OtherId -> OTHER_NAME't
+ match Queue.peek tokens with
+ | Pre_parser.STRING_LITERAL (wide', str', loc) ->
+ ignore (Queue.pop tokens);
+ let (wide'', str'') = doConcat wide' str' in
+ if str'' <> []
+ then (wide || wide'', str @ str'')
+ else (wide, str)
+ | _ -> (wide, str)
+ | exception Queue.Empty -> (wide, str)
in
- loop terminal (id, loc)
- | UNION loc -> loop UNION't loc
- | UNSIGNED loc -> loop UNSIGNED't loc
- | VOID loc -> loop VOID't loc
- | VOLATILE loc -> loop VOLATILE't loc
- | WHILE loc -> loop WHILE't loc
- | XOR_ASSIGN loc -> loop XOR_ASSIGN't loc
- | ALIGNAS loc -> loop ALIGNAS't loc
- | ALIGNOF loc -> loop ALIGNOF't loc
- | ATTRIBUTE loc -> loop ATTRIBUTE't loc
- | ASM loc -> loop ASM't loc
- | PRAGMA (s, loc) -> loop PRAGMA't (s, loc)
- | PRE_NAME _ -> assert false
+ let (wide', str') = doConcat wide str in
+ loop (Parser.STRING_LITERAL ((wide', str'), loc))
+ | Pre_parser.STRUCT loc -> loop (Parser.STRUCT loc)
+ | Pre_parser.SUB_ASSIGN loc -> loop (Parser.SUB_ASSIGN loc)
+ | Pre_parser.SWITCH loc -> loop (Parser.SWITCH loc)
+ | Pre_parser.TILDE loc -> loop (Parser.TILDE loc)
+ | Pre_parser.TYPEDEF loc -> loop (Parser.TYPEDEF loc)
+ | Pre_parser.TYPEDEF_NAME (id, typ, loc)
+ | Pre_parser.VAR_NAME (id, typ, loc) ->
+ begin match !typ with
+ | VarId -> loop (Parser.VAR_NAME (id, loc))
+ | TypedefId -> loop (Parser.TYPEDEF_NAME (id, loc))
+ | OtherId -> loop (Parser.OTHER_NAME (id, loc))
+ end
+ | Pre_parser.UNION loc -> loop (Parser.UNION loc)
+ | Pre_parser.UNSIGNED loc -> loop (Parser.UNSIGNED loc)
+ | Pre_parser.VOID loc -> loop (Parser.VOID loc)
+ | Pre_parser.VOLATILE loc -> loop (Parser.VOLATILE loc)
+ | Pre_parser.WHILE loc -> loop (Parser.WHILE loc)
+ | Pre_parser.XOR_ASSIGN loc -> loop (Parser.XOR_ASSIGN loc)
+ | Pre_parser.ALIGNAS loc -> loop (Parser.ALIGNAS loc)
+ | Pre_parser.ALIGNOF loc -> loop (Parser.ALIGNOF loc)
+ | Pre_parser.ATTRIBUTE loc -> loop (Parser.ATTRIBUTE loc)
+ | Pre_parser.ASM loc -> loop (Parser.ASM loc)
+ | Pre_parser.PRAGMA (s, loc) -> loop (Parser.PRAGMA (s, loc))
+ | Pre_parser.PRE_NAME _ -> assert false
in
- Lazy.from_fun compute_token_stream
+ Lazy.from_fun compute_buffer
}
diff --git a/cparser/Machine.ml b/cparser/Machine.ml
index 087e0308..193d83c4 100644
--- a/cparser/Machine.ml
+++ b/cparser/Machine.ml
@@ -18,6 +18,7 @@
type struct_passing_style =
| SP_ref_callee (* by reference, callee takes copy *)
| SP_ref_caller (* by reference, caller takes copy *)
+ | SP_value32_ref_callee (* by value if <= 32 bits, by ref_callee otherwise *)
| SP_split_args (* by value, as a sequence of ints *)
type struct_return_style =
@@ -238,11 +239,43 @@ let rv64 =
struct_return_style = SR_ref } (* to check *)
let mppa_k1c =
- { ilp32ll64 with sizeof_ptr = 8;
- sizeof_long = 8;
- name = "k1c";
- char_signed = true;
- supports_unaligned_accesses = true }
+ { name = "k1c";
+ char_signed = true;
+ wchar_signed = true;
+ sizeof_ptr = 8;
+ sizeof_short = 2;
+ sizeof_int = 4;
+ sizeof_long = 8;
+ sizeof_longlong = 8;
+ sizeof_float = 4;
+ sizeof_double = 8;
+ sizeof_longdouble = 8;
+ sizeof_void = None; (* What is this for ? *)
+ sizeof_fun = None; (* What is this for ? *)
+ sizeof_wchar = 4;
+ sizeof_size_t = 8;
+ sizeof_ptrdiff_t = 8;
+ sizeof_intreg = 8; (* What is this for ? *)
+ alignof_ptr = 8;
+ alignof_short = 2;
+ alignof_int = 4;
+ alignof_long = 8;
+ alignof_longlong = 8;
+ alignof_float = 4;
+ alignof_double = 8;
+ alignof_longdouble = 8;
+ alignof_void = None; (* what is this for ? *)
+ alignof_fun = None; (* what is this for ? *)
+ bigendian = false;
+ bitfields_msb_first = false; (* TO CHECK *)
+ supports_unaligned_accesses = true;
+ struct_passing_style = SP_value32_ref_callee;
+ struct_return_style = SR_int1to4 }
+
+let aarch64 =
+ { i32lpll64 with name = "aarch64";
+ struct_passing_style = SP_ref_callee; (* Wrong *)
+ struct_return_style = SR_ref } (* Wrong *)
(* Add GCC extensions re: sizeof and alignof *)
diff --git a/cparser/Machine.mli b/cparser/Machine.mli
index 56d8d0b9..ea25c4f6 100644
--- a/cparser/Machine.mli
+++ b/cparser/Machine.mli
@@ -17,6 +17,7 @@
type struct_passing_style =
| SP_ref_callee (* by reference, callee takes copy *)
| SP_ref_caller (* by reference, caller takes copy *)
+ | SP_value32_ref_callee (* by value if <= 32 bits, by ref_callee otherwise *)
| SP_split_args (* by value, as a sequence of ints *)
type struct_return_style =
@@ -87,6 +88,7 @@ val arm_bigendian : t
val rv32 : t
val rv64 : t
val mppa_k1c : t
+val aarch64 : t
val gcc_extensions : t -> t
val compcert_interpreter : t -> t
diff --git a/cparser/MenhirLib/Alphabet.v b/cparser/MenhirLib/Alphabet.v
deleted file mode 100644
index a13f69b0..00000000
--- a/cparser/MenhirLib/Alphabet.v
+++ /dev/null
@@ -1,320 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import Int31.
-Require Import Cyclic31.
-Require Import Omega.
-Require Import List.
-Require Import Syntax.
-Require Import Relations.
-Require Import RelationClasses.
-
-Local Obligation Tactic := intros.
-
-(** A comparable type is equiped with a [compare] function, that define an order
- relation. **)
-Class Comparable (A:Type) := {
- compare : A -> A -> comparison;
- compare_antisym : forall x y, CompOpp (compare x y) = compare y x;
- compare_trans : forall x y z c,
- (compare x y) = c -> (compare y z) = c -> (compare x z) = c
-}.
-
-Theorem compare_refl {A:Type} (C: Comparable A) :
- forall x, compare x x = Eq.
-Proof.
-intros.
-pose proof (compare_antisym x x).
-destruct (compare x x); intuition; try discriminate.
-Qed.
-
-(** The corresponding order is a strict order. **)
-Definition comparableLt {A:Type} (C: Comparable A) : relation A :=
- fun x y => compare x y = Lt.
-
-Instance ComparableLtStrictOrder {A:Type} (C: Comparable A) :
- StrictOrder (comparableLt C).
-Proof.
-apply Build_StrictOrder.
-unfold Irreflexive, Reflexive, complement, comparableLt.
-intros.
-pose proof H.
-rewrite <- compare_antisym in H.
-rewrite H0 in H.
-discriminate H.
-unfold Transitive, comparableLt.
-intros x y z.
-apply compare_trans.
-Qed.
-
-(** nat is comparable. **)
-Program Instance natComparable : Comparable nat :=
- { compare := Nat.compare }.
-Next Obligation.
-symmetry.
-destruct (Nat.compare x y) as [] eqn:?.
-rewrite Nat.compare_eq_iff in Heqc.
-destruct Heqc.
-rewrite Nat.compare_eq_iff.
-trivial.
-rewrite <- nat_compare_lt in *.
-rewrite <- nat_compare_gt in *.
-trivial.
-rewrite <- nat_compare_lt in *.
-rewrite <- nat_compare_gt in *.
-trivial.
-Qed.
-Next Obligation.
-destruct c.
-rewrite Nat.compare_eq_iff in *; destruct H; assumption.
-rewrite <- nat_compare_lt in *.
-apply (Nat.lt_trans _ _ _ H H0).
-rewrite <- nat_compare_gt in *.
-apply (gt_trans _ _ _ H H0).
-Qed.
-
-(** A pair of comparable is comparable. **)
-Program Instance PairComparable {A:Type} (CA:Comparable A) {B:Type} (CB:Comparable B) :
- Comparable (A*B) :=
- { compare := fun x y =>
- let (xa, xb) := x in let (ya, yb) := y in
- match compare xa ya return comparison with
- | Eq => compare xb yb
- | x => x
- end }.
-Next Obligation.
-destruct x, y.
-rewrite <- (compare_antisym a a0).
-rewrite <- (compare_antisym b b0).
-destruct (compare a a0); intuition.
-Qed.
-Next Obligation.
-destruct x, y, z.
-destruct (compare a a0) as [] eqn:?, (compare a0 a1) as [] eqn:?;
-try (rewrite <- H0 in H; discriminate);
-try (destruct (compare a a1) as [] eqn:?;
- try (rewrite <- compare_antisym in Heqc0;
- rewrite CompOpp_iff in Heqc0;
- rewrite (compare_trans _ _ _ _ Heqc0 Heqc2) in Heqc1;
- discriminate);
- try (rewrite <- compare_antisym in Heqc1;
- rewrite CompOpp_iff in Heqc1;
- rewrite (compare_trans _ _ _ _ Heqc2 Heqc1) in Heqc0;
- discriminate);
- assumption);
-rewrite (compare_trans _ _ _ _ Heqc0 Heqc1);
-try assumption.
-apply (compare_trans _ _ _ _ H H0).
-Qed.
-
-(** Special case of comparable, where equality is usual equality. **)
-Class ComparableUsualEq {A:Type} (C: Comparable A) :=
- compare_eq : forall x y, compare x y = Eq -> x = y.
-
-(** Boolean equality for a [Comparable]. **)
-Definition compare_eqb {A:Type} {C:Comparable A} (x y:A) :=
- match compare x y with
- | Eq => true
- | _ => false
- end.
-
-Theorem compare_eqb_iff {A:Type} {C:Comparable A} {U:ComparableUsualEq C} :
- forall x y, compare_eqb x y = true <-> x = y.
-Proof.
-unfold compare_eqb.
-intuition.
-apply compare_eq.
-destruct (compare x y); intuition; discriminate.
-destruct H.
-rewrite compare_refl; intuition.
-Qed.
-
-(** [Comparable] provides a decidable equality. **)
-Definition compare_eqdec {A:Type} {C:Comparable A} {U:ComparableUsualEq C} (x y:A):
- {x = y} + {x <> y}.
-Proof.
-destruct (compare x y) as [] eqn:?; [left; apply compare_eq; intuition | ..];
- right; intro; destruct H; rewrite compare_refl in Heqc; discriminate.
-Defined.
-
-Instance NComparableUsualEq : ComparableUsualEq natComparable := Nat.compare_eq.
-
-(** A pair of ComparableUsualEq is ComparableUsualEq **)
-Instance PairComparableUsualEq
- {A:Type} {CA:Comparable A} (UA:ComparableUsualEq CA)
- {B:Type} {CB:Comparable B} (UB:ComparableUsualEq CB) :
- ComparableUsualEq (PairComparable CA CB).
-Proof.
-intros x y; destruct x, y; simpl.
-pose proof (compare_eq a a0); pose proof (compare_eq b b0).
-destruct (compare a a0); try discriminate.
-intuition.
-destruct H2, H0.
-reflexivity.
-Qed.
-
-(** An [Finite] type is a type with the list of all elements. **)
-Class Finite (A:Type) := {
- all_list : list A;
- all_list_forall : forall x:A, In x all_list
-}.
-
-(** An alphabet is both [ComparableUsualEq] and [Finite]. **)
-Class Alphabet (A:Type) := {
- AlphabetComparable :> Comparable A;
- AlphabetComparableUsualEq :> ComparableUsualEq AlphabetComparable;
- AlphabetFinite :> Finite A
-}.
-
-(** The [Numbered] class provides a conveniant way to build [Alphabet] instances,
- with a good computationnal complexity. It is mainly a injection from it to
- [Int31] **)
-Class Numbered (A:Type) := {
- inj : A -> int31;
- surj : int31 -> A;
- surj_inj_compat : forall x, surj (inj x) = x;
- inj_bound : int31;
- inj_bound_spec : forall x, (phi (inj x) < phi inj_bound)%Z
-}.
-
-Program Instance NumberedAlphabet {A:Type} (N:Numbered A) : Alphabet A :=
- { AlphabetComparable :=
- {| compare := fun x y => compare31 (inj x) (inj y) |};
- AlphabetFinite :=
- {| all_list := fst (iter_int31 inj_bound _
- (fun p => (cons (surj (snd p)) (fst p), incr (snd p))) ([], 0%int31)) |} }.
-Next Obligation. apply Zcompare_antisym. Qed.
-Next Obligation.
-destruct c. unfold compare31 in *.
-rewrite Z.compare_eq_iff in *. congruence.
-eapply Zcompare_Lt_trans. apply H. apply H0.
-eapply Zcompare_Gt_trans. apply H. apply H0.
-Qed.
-Next Obligation.
-intros x y H. unfold compare, compare31 in H.
-rewrite Z.compare_eq_iff in *.
-rewrite <- surj_inj_compat, <- phi_inv_phi with (inj y), <- H.
-rewrite phi_inv_phi, surj_inj_compat; reflexivity.
-Qed.
-Next Obligation.
-rewrite iter_int31_iter_nat.
-pose proof (inj_bound_spec x).
-match goal with |- In x (fst ?p) => destruct p as [] eqn:? end.
-replace inj_bound with i in H.
-revert l i Heqp x H.
-induction (Z.abs_nat (phi inj_bound)); intros.
-inversion Heqp; clear Heqp; subst.
-rewrite spec_0 in H. pose proof (phi_bounded (inj x)). omega.
-simpl in Heqp.
-destruct nat_rect; specialize (IHn _ _ (eq_refl _) x); simpl in *.
-inversion Heqp. subst. clear Heqp.
-rewrite phi_incr in H.
-pose proof (phi_bounded i0).
-pose proof (phi_bounded (inj x)).
-destruct (Z_lt_le_dec (Z.succ (phi i0)) (2 ^ Z.of_nat size)%Z).
-rewrite Zmod_small in H by omega.
-apply Zlt_succ_le, Zle_lt_or_eq in H.
-destruct H; simpl; auto. left.
-rewrite <- surj_inj_compat, <- phi_inv_phi with (inj x), H, phi_inv_phi; reflexivity.
-replace (Z.succ (phi i0)) with (2 ^ Z.of_nat size)%Z in H by omega.
-rewrite Z_mod_same_full in H.
-exfalso; omega.
-rewrite <- phi_inv_phi with i, <- phi_inv_phi with inj_bound; f_equal.
-pose proof (phi_bounded inj_bound); pose proof (phi_bounded i).
-rewrite <- Z.abs_eq with (phi i), <- Z.abs_eq with (phi inj_bound) by omega.
-clear H H0 H1.
-do 2 rewrite <- Zabs2Nat.id_abs.
-f_equal.
-revert l i Heqp.
-assert (Z.abs_nat (phi inj_bound) < Z.abs_nat (2^31)).
-apply Zabs_nat_lt, phi_bounded.
-induction (Z.abs_nat (phi inj_bound)); intros.
-inversion Heqp; reflexivity.
-inversion Heqp; clear H1 H2 Heqp.
-match goal with |- _ (_ (_ (snd ?p))) = _ => destruct p end.
-pose proof (phi_bounded i0).
-erewrite <- IHn, <- Zabs2Nat.inj_succ in H |- *; eauto; try omega.
-rewrite phi_incr, Zmod_small; intuition; try omega.
-apply inj_lt in H.
-pose proof Z.le_le_succ_r.
-do 2 rewrite Zabs2Nat.id_abs, Z.abs_eq in H; now eauto.
-Qed.
-
-(** Previous class instances for [option A] **)
-Program Instance OptionComparable {A:Type} (C:Comparable A) : Comparable (option A) :=
- { compare := fun x y =>
- match x, y return comparison with
- | None, None => Eq
- | None, Some _ => Lt
- | Some _, None => Gt
- | Some x, Some y => compare x y
- end }.
-Next Obligation.
-destruct x, y; intuition.
-apply compare_antisym.
-Qed.
-Next Obligation.
-destruct x, y, z; try now intuition;
-try (rewrite <- H in H0; discriminate).
-apply (compare_trans _ _ _ _ H H0).
-Qed.
-
-Instance OptionComparableUsualEq {A:Type} {C:Comparable A} (U:ComparableUsualEq C) :
- ComparableUsualEq (OptionComparable C).
-Proof.
-intros x y.
-destruct x, y; intuition; try discriminate.
-rewrite (compare_eq a a0); intuition.
-Qed.
-
-Program Instance OptionFinite {A:Type} (E:Finite A) : Finite (option A) :=
- { all_list := None :: map Some all_list }.
-Next Obligation.
-destruct x; intuition.
-right.
-apply in_map.
-apply all_list_forall.
-Defined.
-
-(** Definitions of [FSet]/[FMap] from [Comparable] **)
-Require Import OrderedTypeAlt.
-Require FSetAVL.
-Require FMapAVL.
-Import OrderedType.
-
-Module Type ComparableM.
- Parameter t : Type.
- Declare Instance tComparable : Comparable t.
-End ComparableM.
-
-Module OrderedTypeAlt_from_ComparableM (C:ComparableM) <: OrderedTypeAlt.
- Definition t := C.t.
- Definition compare : t -> t -> comparison := compare.
-
- Infix "?=" := compare (at level 70, no associativity).
-
- Lemma compare_sym x y : (y?=x) = CompOpp (x?=y).
- Proof. exact (Logic.eq_sym (compare_antisym x y)). Qed.
- Lemma compare_trans c x y z :
- (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
- Proof.
- apply compare_trans.
- Qed.
-End OrderedTypeAlt_from_ComparableM.
-
-Module OrderedType_from_ComparableM (C:ComparableM) <: OrderedType.
- Module Alt := OrderedTypeAlt_from_ComparableM C.
- Include (OrderedType_from_Alt Alt).
-End OrderedType_from_ComparableM.
diff --git a/cparser/MenhirLib/Grammar.v b/cparser/MenhirLib/Grammar.v
deleted file mode 100644
index 8e427cd9..00000000
--- a/cparser/MenhirLib/Grammar.v
+++ /dev/null
@@ -1,166 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import List.
-Require Import Syntax.
-Require Import Alphabet.
-Require Import Orders.
-Require Tuples.
-
-(** The terminal non-terminal alphabets of the grammar. **)
-Module Type Alphs.
- Parameters terminal nonterminal : Type.
- Declare Instance TerminalAlph: Alphabet terminal.
- Declare Instance NonTerminalAlph: Alphabet nonterminal.
-End Alphs.
-
-(** Definition of the alphabet of symbols, given the alphabet of terminals
- and the alphabet of non terminals **)
-Module Symbol(Import A:Alphs).
-
- Inductive symbol :=
- | T: terminal -> symbol
- | NT: nonterminal -> symbol.
-
- Program Instance SymbolAlph : Alphabet symbol :=
- { AlphabetComparable := {| compare := fun x y =>
- match x, y return comparison with
- | T _, NT _ => Gt
- | NT _, T _ => Lt
- | T x, T y => compare x y
- | NT x, NT y => compare x y
- end |};
- AlphabetFinite := {| all_list :=
- map T all_list++map NT all_list |} }.
- Next Obligation.
- destruct x; destruct y; intuition; apply compare_antisym.
- Qed.
- Next Obligation.
- destruct x; destruct y; destruct z; intuition; try discriminate.
- apply (compare_trans _ t0); intuition.
- apply (compare_trans _ n0); intuition.
- Qed.
- Next Obligation.
- intros x y.
- destruct x; destruct y; try discriminate; intros.
- rewrite (compare_eq t t0); intuition.
- rewrite (compare_eq n n0); intuition.
- Qed.
- Next Obligation.
- rewrite in_app_iff.
- destruct x; [left | right]; apply in_map; apply all_list_forall.
- Qed.
-
-End Symbol.
-
-Module Type T.
- Export Tuples.
-
- Include Alphs <+ Symbol.
-
- (** [symbol_semantic_type] maps a symbols to the type of its semantic
- values. **)
- Parameter symbol_semantic_type: symbol -> Type.
-
- (** The type of productions identifiers **)
- Parameter production : Type.
- Declare Instance ProductionAlph : Alphabet production.
-
- (** Accessors for productions: left hand side, right hand side,
- and semantic action. The semantic actions are given in the form
- of curryfied functions, that take arguments in the reverse order. **)
- Parameter prod_lhs: production -> nonterminal.
- Parameter prod_rhs_rev: production -> list symbol.
- Parameter prod_action:
- forall p:production,
- arrows_left
- (map symbol_semantic_type (rev (prod_rhs_rev p)))
- (symbol_semantic_type (NT (prod_lhs p))).
-
-End T.
-
-Module Defs(Import G:T).
-
- (** A token is a terminal and a semantic value for this terminal. **)
- Definition token := {t:terminal & symbol_semantic_type (T t)}.
-
- (** A grammar creates a relation between word of tokens and semantic values.
- This relation is parametrized by the head symbol. It defines the
- "semantics" of the grammar. This relation is defined by a notion of
- parse tree. **)
- Inductive parse_tree:
- forall (head_symbol:symbol) (word:list token)
- (semantic_value:symbol_semantic_type head_symbol), Type :=
-
- (** A single token has its semantic value as semantic value, for the
- corresponding terminal as head symbol. **)
- | Terminal_pt:
- forall (t:terminal) (sem:symbol_semantic_type (T t)),
- parse_tree (T t)
- [existT (fun t => symbol_semantic_type (T t)) t sem] sem
-
- (** Given a production, if a word has a list of semantic values for the
- right hand side as head symbols, then this word has the semantic value
- given by the semantic action of the production for the left hand side
- as head symbol.**)
- | Non_terminal_pt:
- forall {p:production} {word:list token}
- {semantic_values:tuple (map symbol_semantic_type (rev (prod_rhs_rev p)))},
- parse_tree_list (rev (prod_rhs_rev p)) word semantic_values ->
- parse_tree (NT (prod_lhs p)) word (uncurry (prod_action p) semantic_values)
-
- (** Basically the same relation as before, but for list of head symbols (ie.
- We are building a forest of syntax trees. It is mutually recursive with the
- previous relation **)
- with parse_tree_list:
- forall (head_symbols:list symbol) (word:list token)
- (semantic_values:tuple (map symbol_semantic_type head_symbols)),
- Type :=
-
- (** The empty word has [()] as semantic for [[]] as head symbols list **)
- | Nil_ptl: parse_tree_list [] [] ()
-
- (** The cons of the semantic value for one head symbol and for a list of head
- symbols **)
- | Cons_ptl:
- (** The semantic for the head **)
- forall {head_symbolt:symbol} {wordt:list token}
- {semantic_valuet:symbol_semantic_type head_symbolt},
- parse_tree head_symbolt wordt semantic_valuet ->
-
- (** and the semantic for the tail **)
- forall {head_symbolsq:list symbol} {wordq:list token}
- {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)},
- parse_tree_list head_symbolsq wordq semantic_valuesq ->
-
- (** give the semantic of the cons **)
- parse_tree_list
- (head_symbolt::head_symbolsq)
- (wordt++wordq)
- (semantic_valuet, semantic_valuesq).
-
-
- Fixpoint pt_size {head_symbol word sem} (tree:parse_tree head_symbol word sem) :=
- match tree with
- | Terminal_pt _ _ => 1
- | Non_terminal_pt l => S (ptl_size l)
- end
- with ptl_size {head_symbols word sems} (tree:parse_tree_list head_symbols word sems) :=
- match tree with
- | Nil_ptl => 0
- | Cons_ptl t q =>
- pt_size t + ptl_size q
- end.
-End Defs.
diff --git a/cparser/MenhirLib/Interpreter.v b/cparser/MenhirLib/Interpreter.v
deleted file mode 100644
index 4ac02693..00000000
--- a/cparser/MenhirLib/Interpreter.v
+++ /dev/null
@@ -1,228 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import Streams.
-Require Import List.
-Require Import Syntax.
-Require Automaton.
-Require Import Alphabet.
-
-Module Make(Import A:Automaton.T).
-
-(** The error monad **)
-Inductive result (A:Type) :=
- | Err: result A
- | OK: A -> result A.
-
-Arguments Err [A].
-Arguments OK [A].
-
-Definition bind {A B: Type} (f: result A) (g: A -> result B): result B :=
- match f with
- | OK x => g x
- | Err => Err
- end.
-
-Definition bind2 {A B C: Type} (f: result (A * B)) (g: A -> B -> result C):
- result C :=
- match f with
- | OK (x, y) => g x y
- | Err => Err
- end.
-
-Notation "'do' X <- A ; B" := (bind A (fun X => B))
- (at level 200, X ident, A at level 100, B at level 200).
-
-Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B))
- (at level 200, X ident, Y ident, A at level 100, B at level 200).
-
-(** Some operations on streams **)
-
-(** Concatenation of a list and a stream **)
-Fixpoint app_str {A:Type} (l:list A) (s:Stream A) :=
- match l with
- | nil => s
- | cons t q => Cons t (app_str q s)
- end.
-
-Infix "++" := app_str (right associativity, at level 60).
-
-Lemma app_str_app_assoc {A:Type} (l1 l2:list A) (s:Stream A) :
- l1 ++ (l2 ++ s) = (l1 ++ l2) ++ s.
-Proof.
-induction l1.
-reflexivity.
-simpl.
-rewrite IHl1.
-reflexivity.
-Qed.
-
-(** The type of a non initial state: the type of semantic values associated
- with the last symbol of this state. *)
-Definition noninitstate_type state :=
- symbol_semantic_type (last_symb_of_non_init_state state).
-
-(** The stack of the automaton : it can be either nil or contains a non
- initial state, a semantic value for the symbol associted with this state,
- and a nested stack. **)
-Definition stack := list (sigT noninitstate_type). (* eg. list {state & state_type state} *)
-
-Section Init.
-
-Variable init : initstate.
-
-(** The top state of a stack **)
-Definition state_of_stack (stack:stack): state :=
- match stack with
- | [] => init
- | existT _ s _::_ => s
- end.
-
-(** [pop] pops some symbols from the stack. It returns the popped semantic
- values using [sem_popped] as an accumulator and discards the popped
- states.**)
-Fixpoint pop (symbols_to_pop:list symbol) (stack_cur:stack):
- forall {A:Type} (action:arrows_right A (map symbol_semantic_type symbols_to_pop)),
- result (stack * A) :=
- match symbols_to_pop return forall {A:Type} (action:arrows_right A (map _ symbols_to_pop)), result (stack * A) with
- | [] => fun A action => OK (stack_cur, action)
- | t::q => fun A action =>
- match stack_cur with
- | existT _ state_cur sem::stack_rec =>
- match compare_eqdec (last_symb_of_non_init_state state_cur) t with
- | left e =>
- let sem_conv := eq_rect _ symbol_semantic_type sem _ e in
- pop q stack_rec (action sem_conv)
- | right _ => Err
- end
- | [] => Err
- end
- end.
-
-(** [step_result] represents the result of one step of the automaton : it can
- fail, accept or progress. [Fail_sr] means that the input is incorrect.
- [Accept_sr] means that this is the last step of the automaton, and it
- returns the semantic value of the input word. [Progress_sr] means that
- some progress has been made, but new steps are needed in order to accept
- a word.
-
- For [Accept_sr] and [Progress_sr], the result contains the new input buffer.
-
- [Fail_sr] means that the input word is rejected by the automaton. It is
- different to [Err] (from the error monad), which mean that the automaton is
- bogus and has perfomed a forbidden action. **)
-Inductive step_result :=
- | Fail_sr: step_result
- | Accept_sr: symbol_semantic_type (NT (start_nt init)) -> Stream token -> step_result
- | Progress_sr: stack -> Stream token -> step_result.
-
-Program Definition prod_action':
- forall p,
- arrows_right (symbol_semantic_type (NT (prod_lhs p)))
- (map symbol_semantic_type (prod_rhs_rev p)):=
- fun p =>
- eq_rect _ (fun x => x) (prod_action p) _ _.
-Next Obligation.
-unfold arrows_left, arrows_right; simpl.
-rewrite <- fold_left_rev_right, <- map_rev, rev_involutive.
-reflexivity.
-Qed.
-
-(** [reduce_step] does a reduce action :
- - pops some elements from the stack
- - execute the action of the production
- - follows the goto for the produced non terminal symbol **)
-Definition reduce_step stack_cur production buffer: result step_result :=
- do (stack_new, sem) <-
- pop (prod_rhs_rev production) stack_cur (prod_action' production);
- match goto_table (state_of_stack stack_new) (prod_lhs production) with
- | Some (exist _ state_new e) =>
- let sem := eq_rect _ _ sem _ e in
- OK (Progress_sr (existT noninitstate_type state_new sem::stack_new) buffer)
- | None =>
- match stack_new with
- | [] =>
- match compare_eqdec (prod_lhs production) (start_nt init) with
- | left e =>
- let sem := eq_rect _ (fun nt => symbol_semantic_type (NT nt)) sem _ e in
- OK (Accept_sr sem buffer)
- | right _ => Err
- end
- | _::_ => Err
- end
- end.
-
-(** One step of parsing. **)
-Definition step stack_cur buffer: result step_result :=
- match action_table (state_of_stack stack_cur) with
- | Default_reduce_act production =>
- reduce_step stack_cur production buffer
- | Lookahead_act awt =>
- match Streams.hd buffer with
- | existT _ term sem =>
- match awt term with
- | Shift_act state_new e =>
- let sem_conv := eq_rect _ symbol_semantic_type sem _ e in
- OK (Progress_sr (existT noninitstate_type state_new sem_conv::stack_cur)
- (Streams.tl buffer))
- | Reduce_act production =>
- reduce_step stack_cur production buffer
- | Fail_action =>
- OK Fail_sr
- end
- end
- end.
-
-(** The parsing use a [nat] parameter [n_steps], so that we do not have to prove
- terminaison, which is difficult. So the result of a parsing is either
- a failure (the automaton has rejected the input word), either a timeout
- (the automaton has spent all the given [n_steps]), either a parsed semantic
- value with a rest of the input buffer.
-**)
-Inductive parse_result :=
- | Fail_pr: parse_result
- | Timeout_pr: parse_result
- | Parsed_pr: symbol_semantic_type (NT (start_nt init)) -> Stream token -> parse_result.
-
-Fixpoint parse_fix stack_cur buffer n_steps: result parse_result:=
- match n_steps with
- | O => OK Timeout_pr
- | S it =>
- do r <- step stack_cur buffer;
- match r with
- | Fail_sr => OK Fail_pr
- | Accept_sr t buffer_new => OK (Parsed_pr t buffer_new)
- | Progress_sr s buffer_new => parse_fix s buffer_new it
- end
- end.
-
-Definition parse buffer n_steps: result parse_result :=
- parse_fix [] buffer n_steps.
-
-End Init.
-
-Arguments Fail_sr [init].
-Arguments Accept_sr [init] _ _.
-Arguments Progress_sr [init] _ _.
-
-Arguments Fail_pr [init].
-Arguments Timeout_pr [init].
-Arguments Parsed_pr [init] _ _.
-
-End Make.
-
-Module Type T(A:Automaton.T).
- Include (Make A).
-End T.
diff --git a/cparser/MenhirLib/Interpreter_complete.v b/cparser/MenhirLib/Interpreter_complete.v
deleted file mode 100644
index 2e64b8da..00000000
--- a/cparser/MenhirLib/Interpreter_complete.v
+++ /dev/null
@@ -1,686 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import Streams.
-Require Import ProofIrrelevance.
-Require Import Equality.
-Require Import List.
-Require Import Syntax.
-Require Import Alphabet.
-Require Import Arith.
-Require Grammar.
-Require Automaton.
-Require Interpreter.
-Require Validator_complete.
-
-Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
-Module Import Valid := Validator_complete.Make A.
-
-(** * Completeness Proof **)
-
-Section Completeness_Proof.
-
-Hypothesis complete: complete.
-
-Proposition nullable_stable: nullable_stable.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition first_stable: first_stable.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition start_future: start_future.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition terminal_shift: terminal_shift.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition end_reduce: end_reduce.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition start_goto: start_goto.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition non_terminal_goto: non_terminal_goto.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-Proposition non_terminal_closed: non_terminal_closed.
-Proof. pose proof complete; unfold Valid.complete in H; intuition. Qed.
-
-(** If the nullable predicate has been validated, then it is correct. **)
-Lemma nullable_correct:
- forall head sem word, word = [] ->
- parse_tree head word sem -> nullable_symb head = true
-with nullable_correct_list:
- forall heads sems word, word = [] ->
- parse_tree_list heads word sems -> nullable_word heads = true.
-Proof with eauto.
-intros.
-destruct X.
-congruence.
-apply nullable_stable...
-intros.
-destruct X; simpl...
-apply andb_true_intro.
-apply app_eq_nil in H; destruct H; split...
-Qed.
-
-(** If the first predicate has been validated, then it is correct. **)
-Lemma first_correct:
- forall head sem word t q, word = t::q ->
- parse_tree head word sem ->
- TerminalSet.In (projT1 t) (first_symb_set head)
-with first_correct_list:
- forall heads sems word t q, word = t::q ->
- parse_tree_list heads word sems ->
- TerminalSet.In (projT1 t) (first_word_set heads).
-Proof with eauto.
-intros.
-destruct X.
-inversion H; subst.
-apply TerminalSet.singleton_2, compare_refl...
-apply first_stable...
-intros.
-destruct X.
-congruence.
-simpl.
-case_eq wordt; intros.
-erewrite nullable_correct...
-apply TerminalSet.union_3.
-subst...
-rewrite H0 in *; inversion H; destruct H2.
-destruct (nullable_symb head_symbolt)...
-apply TerminalSet.union_2...
-Qed.
-
-Variable init: initstate.
-Variable full_word: list token.
-Variable buffer_end: Stream token.
-Variable full_sem: symbol_semantic_type (NT (start_nt init)).
-
-Inductive pt_zipper:
- forall (hole_symb:symbol) (hole_word:list token)
- (hole_sem:symbol_semantic_type hole_symb), Type :=
-| Top_ptz:
- pt_zipper (NT (start_nt init)) (full_word) (full_sem)
-| Cons_ptl_ptz:
- forall {head_symbolt:symbol}
- {wordt:list token}
- {semantic_valuet:symbol_semantic_type head_symbolt},
-
- forall {head_symbolsq:list symbol}
- {wordq:list token}
- {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)},
- parse_tree_list head_symbolsq wordq semantic_valuesq ->
-
- ptl_zipper (head_symbolt::head_symbolsq) (wordt++wordq)
- (semantic_valuet,semantic_valuesq) ->
-
- pt_zipper head_symbolt wordt semantic_valuet
-with ptl_zipper:
- forall (hole_symbs:list symbol) (hole_word:list token)
- (hole_sems:tuple (map symbol_semantic_type hole_symbs)), Type :=
-| Non_terminal_pt_ptlz:
- forall {p:production} {word:list token}
- {semantic_values:tuple (map symbol_semantic_type (rev (prod_rhs_rev p)))},
- pt_zipper (NT (prod_lhs p)) word (uncurry (prod_action p) semantic_values) ->
- ptl_zipper (rev (prod_rhs_rev p)) word semantic_values
-
-| Cons_ptl_ptlz:
- forall {head_symbolt:symbol}
- {wordt:list token}
- {semantic_valuet:symbol_semantic_type head_symbolt},
- parse_tree head_symbolt wordt semantic_valuet ->
-
- forall {head_symbolsq:list symbol}
- {wordq:list token}
- {semantic_valuesq:tuple (map symbol_semantic_type head_symbolsq)},
-
- ptl_zipper (head_symbolt::head_symbolsq) (wordt++wordq)
- (semantic_valuet,semantic_valuesq) ->
-
- ptl_zipper head_symbolsq wordq semantic_valuesq.
-
-Fixpoint ptlz_cost {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems) :=
- match ptlz with
- | Non_terminal_pt_ptlz ptz =>
- ptz_cost ptz
- | Cons_ptl_ptlz pt ptlz' =>
- ptlz_cost ptlz'
- end
-with ptz_cost {hole_symb hole_word hole_sem}
- (ptz:pt_zipper hole_symb hole_word hole_sem) :=
- match ptz with
- | Top_ptz => 0
- | Cons_ptl_ptz ptl ptlz' =>
- 1 + ptl_size ptl + ptlz_cost ptlz'
- end.
-
-Inductive pt_dot: Type :=
-| Reduce_ptd: ptl_zipper [] [] () -> pt_dot
-| Shift_ptd:
- forall (term:terminal) (sem: symbol_semantic_type (T term))
- {symbolsq wordq semsq},
- parse_tree_list symbolsq wordq semsq ->
- ptl_zipper (T term::symbolsq) (existT (fun t => symbol_semantic_type (T t)) term sem::wordq) (sem, semsq) ->
- pt_dot.
-
-Definition ptd_cost (ptd:pt_dot) :=
- match ptd with
- | Reduce_ptd ptlz => ptlz_cost ptlz
- | Shift_ptd _ _ ptl ptlz => 1 + ptl_size ptl + ptlz_cost ptlz
- end.
-
-Fixpoint ptlz_buffer {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems): Stream token :=
- match ptlz with
- | Non_terminal_pt_ptlz ptz =>
- ptz_buffer ptz
- | Cons_ptl_ptlz _ ptlz' =>
- ptlz_buffer ptlz'
- end
-with ptz_buffer {hole_symb hole_word hole_sem}
- (ptz:pt_zipper hole_symb hole_word hole_sem): Stream token :=
- match ptz with
- | Top_ptz => buffer_end
- | @Cons_ptl_ptz _ _ _ _ wordq _ ptl ptlz' =>
- wordq++ptlz_buffer ptlz'
- end.
-
-Definition ptd_buffer (ptd:pt_dot) :=
- match ptd with
- | Reduce_ptd ptlz => ptlz_buffer ptlz
- | @Shift_ptd term sem _ wordq _ _ ptlz =>
- Cons (existT (fun t => symbol_semantic_type (T t)) term sem)
- (wordq ++ ptlz_buffer ptlz)
- end.
-
-Fixpoint ptlz_prod {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems): production :=
- match ptlz with
- | @Non_terminal_pt_ptlz prod _ _ _ => prod
- | Cons_ptl_ptlz _ ptlz' =>
- ptlz_prod ptlz'
- end.
-
-Fixpoint ptlz_past {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems): list symbol :=
- match ptlz with
- | Non_terminal_pt_ptlz _ => []
- | @Cons_ptl_ptlz s _ _ _ _ _ _ ptlz' => s::ptlz_past ptlz'
- end.
-
-Lemma ptlz_past_ptlz_prod:
- forall hole_symbs hole_word hole_sems
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- rev_append hole_symbs (ptlz_past ptlz) = prod_rhs_rev (ptlz_prod ptlz).
-Proof.
-fix ptlz_past_ptlz_prod 4.
-destruct ptlz; simpl.
-rewrite <- rev_alt, rev_involutive; reflexivity.
-apply (ptlz_past_ptlz_prod _ _ _ ptlz).
-Qed.
-
-Definition ptlz_state_compat {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- (state:state): Prop :=
- state_has_future state (ptlz_prod ptlz) hole_symbs
- (projT1 (Streams.hd (ptlz_buffer ptlz))).
-
-Fixpoint ptlz_stack_compat {hole_symbs hole_word hole_sems}
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- (stack:stack): Prop :=
- ptlz_state_compat ptlz (state_of_stack init stack) /\
- match ptlz with
- | Non_terminal_pt_ptlz ptz =>
- ptz_stack_compat ptz stack
- | @Cons_ptl_ptlz _ _ sem _ _ _ _ ptlz' =>
- match stack with
- | [] => False
- | existT _ _ sem'::stackq =>
- ptlz_stack_compat ptlz' stackq /\
- sem ~= sem'
- end
- end
-with ptz_stack_compat {hole_symb hole_word hole_sem}
- (ptz:pt_zipper hole_symb hole_word hole_sem)
- (stack:stack): Prop :=
- match ptz with
- | Top_ptz => stack = []
- | Cons_ptl_ptz _ ptlz' =>
- ptlz_stack_compat ptlz' stack
- end.
-
-Lemma ptlz_stack_compat_ptlz_state_compat:
- forall hole_symbs hole_word hole_sems
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- (stack:stack),
- ptlz_stack_compat ptlz stack -> ptlz_state_compat ptlz (state_of_stack init stack).
-Proof.
-destruct ptlz; simpl; intuition.
-Qed.
-
-Definition ptd_stack_compat (ptd:pt_dot) (stack:stack): Prop :=
- match ptd with
- | Reduce_ptd ptlz => ptlz_stack_compat ptlz stack
- | Shift_ptd _ _ _ ptlz => ptlz_stack_compat ptlz stack
- end.
-
-Fixpoint build_pt_dot {hole_symbs hole_word hole_sems}
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- :pt_dot :=
- match ptl in parse_tree_list hole_symbs hole_word hole_sems
- return ptl_zipper hole_symbs hole_word hole_sems -> _
- with
- | Nil_ptl => fun ptlz =>
- Reduce_ptd ptlz
- | Cons_ptl pt ptl' =>
- match pt in parse_tree hole_symb hole_word hole_sem
- return ptl_zipper (hole_symb::_) (hole_word++_) (hole_sem,_) -> _
- with
- | Terminal_pt term sem => fun ptlz =>
- Shift_ptd term sem ptl' ptlz
- | Non_terminal_pt ptl'' => fun ptlz =>
- build_pt_dot ptl''
- (Non_terminal_pt_ptlz (Cons_ptl_ptz ptl' ptlz))
- end
- end ptlz.
-
-Lemma build_pt_dot_cost:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- ptd_cost (build_pt_dot ptl ptlz) = ptl_size ptl + ptlz_cost ptlz.
-Proof.
-fix build_pt_dot_cost 4.
-destruct ptl; intros.
-reflexivity.
-destruct p.
-reflexivity.
-simpl; rewrite build_pt_dot_cost.
-simpl; rewrite <- plus_n_Sm, Nat.add_assoc; reflexivity.
-Qed.
-
-Lemma build_pt_dot_buffer:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- ptd_buffer (build_pt_dot ptl ptlz) = hole_word ++ ptlz_buffer ptlz.
-Proof.
-fix build_pt_dot_buffer 4.
-destruct ptl; intros.
-reflexivity.
-destruct p.
-reflexivity.
-simpl; rewrite build_pt_dot_buffer.
-apply app_str_app_assoc.
-Qed.
-
-Lemma ptd_stack_compat_build_pt_dot:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- (stack:stack),
- ptlz_stack_compat ptlz stack ->
- ptd_stack_compat (build_pt_dot ptl ptlz) stack.
-Proof.
-fix ptd_stack_compat_build_pt_dot 4.
-destruct ptl; intros.
-eauto.
-destruct p.
-eauto.
-simpl.
-apply ptd_stack_compat_build_pt_dot.
-split.
-apply ptlz_stack_compat_ptlz_state_compat, non_terminal_closed in H.
-apply H; clear H; eauto.
-destruct wordq.
-right; split.
-eauto.
-eapply nullable_correct_list; eauto.
-left.
-eapply first_correct_list; eauto.
-eauto.
-Qed.
-
-Program Fixpoint pop_ptlz {hole_symbs hole_word hole_sems}
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems):
- { word:_ & { sem:_ &
- (pt_zipper (NT (prod_lhs (ptlz_prod ptlz))) word sem *
- parse_tree (NT (prod_lhs (ptlz_prod ptlz))) word sem)%type } } :=
- match ptlz in ptl_zipper hole_symbs hole_word hole_sems
- return parse_tree_list hole_symbs hole_word hole_sems ->
- { word:_ & { sem:_ &
- (pt_zipper (NT (prod_lhs (ptlz_prod ptlz))) word sem *
- parse_tree (NT (prod_lhs (ptlz_prod ptlz))) word sem)%type } }
- with
- | @Non_terminal_pt_ptlz prod word sem ptz => fun ptl =>
- let sem := uncurry (prod_action prod) sem in
- existT _ word (existT _ sem (ptz, Non_terminal_pt ptl))
- | Cons_ptl_ptlz pt ptlz' => fun ptl =>
- pop_ptlz (Cons_ptl pt ptl) ptlz'
- end ptl.
-
-Lemma pop_ptlz_cost:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in
- ptlz_cost ptlz = ptz_cost ptz.
-Proof.
-fix pop_ptlz_cost 5.
-destruct ptlz.
-reflexivity.
-simpl; apply pop_ptlz_cost.
-Qed.
-
-Lemma pop_ptlz_buffer:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in
- ptlz_buffer ptlz = ptz_buffer ptz.
-Proof.
-fix pop_ptlz_buffer 5.
-destruct ptlz.
-reflexivity.
-simpl; apply pop_ptlz_buffer.
-Qed.
-
-Lemma pop_ptlz_pop_stack_compat_converter:
- forall A hole_symbs hole_word hole_sems (ptlz:ptl_zipper hole_symbs hole_word hole_sems),
- arrows_left (map symbol_semantic_type (rev (prod_rhs_rev (ptlz_prod ptlz)))) A =
- arrows_left (map symbol_semantic_type hole_symbs)
- (arrows_right A (map symbol_semantic_type (ptlz_past ptlz))).
-Proof.
-intros.
-rewrite <- ptlz_past_ptlz_prod.
-unfold arrows_right, arrows_left.
-rewrite rev_append_rev, map_rev, map_app, map_rev, <- fold_left_rev_right, rev_involutive, fold_right_app.
-rewrite fold_left_rev_right.
-reflexivity.
-Qed.
-
-Lemma pop_ptlz_pop_stack_compat:
- forall hole_symbs hole_word hole_sems
- (ptl:parse_tree_list hole_symbs hole_word hole_sems)
- (ptlz:ptl_zipper hole_symbs hole_word hole_sems)
- (stack:stack),
-
- ptlz_stack_compat ptlz stack ->
-
- let action' :=
- eq_rect _ (fun x=>x) (prod_action (ptlz_prod ptlz)) _
- (pop_ptlz_pop_stack_compat_converter _ _ _ _ _)
- in
- let 'existT _ word (existT _ sem (ptz, pt)) := pop_ptlz ptl ptlz in
- match pop (ptlz_past ptlz) stack (uncurry action' hole_sems) with
- | OK (stack', sem') =>
- ptz_stack_compat ptz stack' /\ sem = sem'
- | Err => True
- end.
-Proof.
-Opaque AlphabetComparable AlphabetComparableUsualEq.
-fix pop_ptlz_pop_stack_compat 5.
-destruct ptlz. intros; simpl.
-split.
-apply H.
-eapply (f_equal (fun X => uncurry X semantic_values)).
-apply JMeq_eq, JMeq_sym, JMeq_eqrect with (P:=fun x => x).
-simpl; intros; destruct stack0.
-destruct (proj2 H).
-simpl in H; destruct H.
-destruct s as (state, sem').
-destruct H0.
-specialize (pop_ptlz_pop_stack_compat _ _ _ (Cons_ptl p ptl) ptlz _ H0).
-destruct (pop_ptlz (Cons_ptl p ptl) ptlz) as [word [sem []]].
-destruct (compare_eqdec (last_symb_of_non_init_state state) head_symbolt); intuition.
-eapply JMeq_sym, JMeq_trans, JMeq_sym, JMeq_eq in H1; [|apply JMeq_eqrect with (e:=e)].
-rewrite <- H1.
-simpl in pop_ptlz_pop_stack_compat.
-erewrite proof_irrelevance with (p1:=pop_ptlz_pop_stack_compat_converter _ _ _ _ _).
-apply pop_ptlz_pop_stack_compat.
-Transparent AlphabetComparable AlphabetComparableUsualEq.
-Qed.
-
-Definition next_ptd (ptd:pt_dot): option pt_dot :=
- match ptd with
- | Shift_ptd term sem ptl ptlz =>
- Some (build_pt_dot ptl (Cons_ptl_ptlz (Terminal_pt term sem) ptlz))
- | Reduce_ptd ptlz =>
- let 'existT _ _ (existT _ _ (ptz, pt)) := pop_ptlz Nil_ptl ptlz in
- match ptz in pt_zipper sym _ _ return parse_tree sym _ _ -> _ with
- | Top_ptz => fun pt => None
- | Cons_ptl_ptz ptl ptlz' =>
- fun pt => Some (build_pt_dot ptl (Cons_ptl_ptlz pt ptlz'))
- end pt
- end.
-
-Lemma next_ptd_cost:
- forall ptd,
- match next_ptd ptd with
- | None => ptd_cost ptd = 0
- | Some ptd' => ptd_cost ptd = S (ptd_cost ptd')
- end.
-Proof.
-destruct ptd. unfold next_ptd.
-pose proof (pop_ptlz_cost _ _ _ Nil_ptl p).
-destruct (pop_ptlz Nil_ptl p) as [word[sem[[]]]].
-assumption.
-rewrite build_pt_dot_cost.
-assumption.
-simpl; rewrite build_pt_dot_cost; reflexivity.
-Qed.
-
-Lemma reduce_step_next_ptd:
- forall (ptlz:ptl_zipper [] [] ()) (stack:stack),
- ptlz_stack_compat ptlz stack ->
- match reduce_step init stack (ptlz_prod ptlz) (ptlz_buffer ptlz) with
- | OK Fail_sr =>
- False
- | OK (Accept_sr sem buffer) =>
- sem = full_sem /\ buffer = buffer_end /\ next_ptd (Reduce_ptd ptlz) = None
- | OK (Progress_sr stack buffer) =>
- match next_ptd (Reduce_ptd ptlz) with
- | None => False
- | Some ptd =>
- ptd_stack_compat ptd stack /\ buffer = ptd_buffer ptd
- end
- | Err =>
- True
- end.
-Proof.
-intros.
-unfold reduce_step, next_ptd.
-apply pop_ptlz_pop_stack_compat with (ptl:=Nil_ptl) in H.
-pose proof (pop_ptlz_buffer _ _ _ Nil_ptl ptlz).
-destruct (pop_ptlz Nil_ptl ptlz) as [word [sem [ptz pt]]].
-rewrite H0; clear H0.
-revert H.
-match goal with
- |- match ?p1 with Err => _ | OK _ => _ end -> match bind2 ?p2 _ with Err => _ | OK _ => _ end =>
- replace p1 with p2; [destruct p2 as [|[]]; intros|]
-end.
-assumption.
-simpl.
-destruct H; subst.
-generalize dependent s0.
-generalize (prod_lhs (ptlz_prod ptlz)); clear ptlz stack0.
-dependent destruction ptz; intros.
-simpl in H; subst; simpl.
-pose proof start_goto; unfold Valid.start_goto in H; rewrite H.
-destruct (compare_eqdec (start_nt init) (start_nt init)); intuition.
-apply JMeq_eq, JMeq_eqrect with (P:=fun nt => symbol_semantic_type (NT nt)).
-pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H).
-apply non_terminal_goto in H0.
-destruct (goto_table (state_of_stack init s) n) as [[]|]; intuition.
-apply ptd_stack_compat_build_pt_dot; simpl; intuition.
-symmetry; apply JMeq_eqrect with (P:=symbol_semantic_type).
-symmetry; apply build_pt_dot_buffer.
-destruct s; intuition.
-simpl in H; apply ptlz_stack_compat_ptlz_state_compat in H.
-destruct (H0 _ _ _ H eq_refl).
-generalize (pop_ptlz_pop_stack_compat_converter (symbol_semantic_type (NT (prod_lhs (ptlz_prod ptlz)))) _ _ _ ptlz).
-pose proof (ptlz_past_ptlz_prod _ _ _ ptlz); simpl in H.
-rewrite H; clear H.
-intro; f_equal; simpl.
-apply JMeq_eq.
-etransitivity.
-apply JMeq_eqrect with (P:=fun x => x).
-symmetry.
-apply JMeq_eqrect with (P:=fun x => x).
-Qed.
-
-Lemma step_next_ptd:
- forall (ptd:pt_dot) (stack:stack),
- ptd_stack_compat ptd stack ->
- match step init stack (ptd_buffer ptd) with
- | OK Fail_sr =>
- False
- | OK (Accept_sr sem buffer) =>
- sem = full_sem /\ buffer = buffer_end /\ next_ptd ptd = None
- | OK (Progress_sr stack buffer) =>
- match next_ptd ptd with
- | None => False
- | Some ptd =>
- ptd_stack_compat ptd stack /\ buffer = ptd_buffer ptd
- end
- | Err =>
- True
- end.
-Proof.
-intros.
-destruct ptd.
-pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H).
-apply end_reduce in H0.
-unfold step.
-destruct (action_table (state_of_stack init stack0)).
-rewrite H0 by reflexivity.
-apply reduce_step_next_ptd; assumption.
-simpl; destruct (Streams.hd (ptlz_buffer p)); simpl in H0.
-destruct (l x); intuition; rewrite H1.
-apply reduce_step_next_ptd; assumption.
-pose proof (ptlz_stack_compat_ptlz_state_compat _ _ _ _ _ H).
-apply terminal_shift in H0.
-unfold step.
-destruct (action_table (state_of_stack init stack0)); intuition.
-simpl; destruct (Streams.hd (ptlz_buffer p0)) as [] eqn:?.
-destruct (l term); intuition.
-apply ptd_stack_compat_build_pt_dot; simpl; intuition.
-unfold ptlz_state_compat; simpl; destruct Heqt; assumption.
-symmetry; apply JMeq_eqrect with (P:=symbol_semantic_type).
-rewrite build_pt_dot_buffer; reflexivity.
-Qed.
-
-Lemma parse_fix_complete:
- forall (ptd:pt_dot) (stack:stack) (n_steps:nat),
- ptd_stack_compat ptd stack ->
- match parse_fix init stack (ptd_buffer ptd) n_steps with
- | OK (Parsed_pr sem_res buffer_end_res) =>
- sem_res = full_sem /\ buffer_end_res = buffer_end /\
- S (ptd_cost ptd) <= n_steps
- | OK Fail_pr => False
- | OK Timeout_pr => n_steps < S (ptd_cost ptd)
- | Err => True
- end.
-Proof.
-fix parse_fix_complete 3.
-destruct n_steps; intros; simpl.
-apply Nat.lt_0_succ.
-apply step_next_ptd in H.
-pose proof (next_ptd_cost ptd).
-destruct (step init stack0 (ptd_buffer ptd)) as [|[]]; simpl; intuition.
-rewrite H3 in H0; rewrite H0.
-apply le_n_S, Nat.le_0_l.
-destruct (next_ptd ptd); intuition; subst.
-eapply parse_fix_complete with (n_steps:=n_steps) in H1.
-rewrite H0.
-destruct (parse_fix init s (ptd_buffer p) n_steps) as [|[]]; try assumption.
-apply lt_n_S; assumption.
-destruct H1 as [H1 []]; split; [|split]; try assumption.
-apply le_n_S; assumption.
-Qed.
-
-Variable full_pt: parse_tree (NT (start_nt init)) full_word full_sem.
-
-Definition init_ptd :=
- match full_pt in parse_tree head full_word full_sem return
- pt_zipper head full_word full_sem ->
- match head return Type with | T _ => unit | NT _ => pt_dot end
- with
- | Terminal_pt _ _ => fun _ => ()
- | Non_terminal_pt ptl =>
- fun top => build_pt_dot ptl (Non_terminal_pt_ptlz top)
- end Top_ptz.
-
-Lemma init_ptd_compat:
- ptd_stack_compat init_ptd [].
-Proof.
-unfold init_ptd.
-assert (ptz_stack_compat Top_ptz []) by reflexivity.
-pose proof (start_future init); revert H0.
-generalize dependent Top_ptz.
-generalize dependent full_word.
-generalize full_sem.
-generalize (start_nt init).
-dependent destruction full_pt0.
-intros.
-apply ptd_stack_compat_build_pt_dot; simpl; intuition.
-apply H0; reflexivity.
-Qed.
-
-Lemma init_ptd_cost:
- S (ptd_cost init_ptd) = pt_size full_pt.
-Proof.
-unfold init_ptd.
-assert (ptz_cost Top_ptz = 0) by reflexivity.
-generalize dependent Top_ptz.
-generalize dependent full_word.
-generalize full_sem.
-generalize (start_nt init).
-dependent destruction full_pt0.
-intros.
-rewrite build_pt_dot_cost; simpl.
-rewrite H, Nat.add_0_r; reflexivity.
-Qed.
-
-Lemma init_ptd_buffer:
- ptd_buffer init_ptd = full_word ++ buffer_end.
-Proof.
-unfold init_ptd.
-assert (ptz_buffer Top_ptz = buffer_end) by reflexivity.
-generalize dependent Top_ptz.
-generalize dependent full_word.
-generalize full_sem.
-generalize (start_nt init).
-dependent destruction full_pt0.
-intros.
-rewrite build_pt_dot_buffer; simpl.
-rewrite H; reflexivity.
-Qed.
-
-Theorem parse_complete n_steps:
- match parse init (full_word ++ buffer_end) n_steps with
- | OK (Parsed_pr sem_res buffer_end_res) =>
- sem_res = full_sem /\ buffer_end_res = buffer_end /\
- pt_size full_pt <= n_steps
- | OK Fail_pr => False
- | OK Timeout_pr => n_steps < pt_size full_pt
- | Err => True
- end.
-Proof.
-pose proof (parse_fix_complete init_ptd [] n_steps init_ptd_compat).
-rewrite init_ptd_buffer, init_ptd_cost in H.
-apply H.
-Qed.
-
-End Completeness_Proof.
-
-End Make.
diff --git a/cparser/MenhirLib/Interpreter_correct.v b/cparser/MenhirLib/Interpreter_correct.v
deleted file mode 100644
index 1263d4e3..00000000
--- a/cparser/MenhirLib/Interpreter_correct.v
+++ /dev/null
@@ -1,228 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import Streams.
-Require Import List.
-Require Import Syntax.
-Require Import Equality.
-Require Import Alphabet.
-Require Grammar.
-Require Automaton.
-Require Interpreter.
-
-Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
-
-(** * Correctness of the interpreter **)
-
-(** We prove that, in any case, if the interpreter accepts returning a
- semantic value, then this is a semantic value of the input **)
-
-Section Init.
-
-Variable init:initstate.
-
-(** [word_has_stack_semantics] relates a word with a state, stating that the
- word is a concatenation of words that have the semantic values stored in
- the stack. **)
-Inductive word_has_stack_semantics:
- forall (word:list token) (stack:stack), Prop :=
- | Nil_stack_whss: word_has_stack_semantics [] []
- | Cons_stack_whss:
- forall (wordq:list token) (stackq:stack),
- word_has_stack_semantics wordq stackq ->
-
- forall (wordt:list token) (s:noninitstate)
- (semantic_valuet:_),
- inhabited (parse_tree (last_symb_of_non_init_state s) wordt semantic_valuet) ->
-
- word_has_stack_semantics
- (wordq++wordt) (existT noninitstate_type s semantic_valuet::stackq).
-
-Lemma pop_invariant_converter:
- forall A symbols_to_pop symbols_popped,
- arrows_left (map symbol_semantic_type (rev_append symbols_to_pop symbols_popped)) A =
- arrows_left (map symbol_semantic_type symbols_popped)
- (arrows_right A (map symbol_semantic_type symbols_to_pop)).
-Proof.
-intros.
-unfold arrows_right, arrows_left.
-rewrite rev_append_rev, map_app, map_rev, fold_left_app.
-apply f_equal.
-rewrite <- fold_left_rev_right, rev_involutive.
-reflexivity.
-Qed.
-
-(** [pop] preserves the invariant **)
-Lemma pop_invariant:
- forall (symbols_to_pop symbols_popped:list symbol)
- (stack_cur:stack)
- (A:Type)
- (action:arrows_left (map symbol_semantic_type (rev_append symbols_to_pop symbols_popped)) A),
- forall word_stack word_popped,
- forall sem_popped,
- word_has_stack_semantics word_stack stack_cur ->
- inhabited (parse_tree_list symbols_popped word_popped sem_popped) ->
- let action' := eq_rect _ (fun x=>x) action _ (pop_invariant_converter _ _ _) in
- match pop symbols_to_pop stack_cur (uncurry action' sem_popped) with
- | OK (stack_new, sem) =>
- exists word1res word2res sem_full,
- (word_stack = word1res ++ word2res)%list /\
- word_has_stack_semantics word1res stack_new /\
- sem = uncurry action sem_full /\
- inhabited (
- parse_tree_list (rev_append symbols_to_pop symbols_popped) (word2res++word_popped) sem_full)
- | Err => True
- end.
-Proof.
-induction symbols_to_pop; intros; unfold pop; fold pop.
-exists word_stack, ([]:list token), sem_popped; intuition.
-f_equal.
-apply JMeq_eq, JMeq_eqrect with (P:=(fun x => x)).
-destruct stack_cur as [|[]]; eauto.
-destruct (compare_eqdec (last_symb_of_non_init_state x) a); eauto.
-destruct e; simpl.
-dependent destruction H.
-destruct H0, H1. apply (Cons_ptl X), inhabits in X0.
-specialize (IHsymbols_to_pop _ _ _ action0 _ _ _ H X0).
-match goal with
- IHsymbols_to_pop:match ?p1 with Err => _ | OK _ => _ end |- match ?p2 with Err => _ | OK _ => _ end =>
- replace p2 with p1; [destruct p1 as [|[]]|]; intuition
-end.
-destruct IHsymbols_to_pop as [word1res [word2res [sem_full []]]]; intuition; subst.
-exists word1res.
-eexists.
-exists sem_full.
-intuition.
-rewrite <- app_assoc; assumption.
-simpl; f_equal; f_equal.
-apply JMeq_eq.
-etransitivity.
-apply JMeq_eqrect with (P:=(fun x => x)).
-symmetry.
-apply JMeq_eqrect with (P:=(fun x => x)).
-Qed.
-
-(** [reduce_step] preserves the invariant **)
-Lemma reduce_step_invariant (stack:stack) (prod:production):
- forall word buffer, word_has_stack_semantics word stack ->
- match reduce_step init stack prod buffer with
- | OK (Accept_sr sem buffer_new) =>
- buffer = buffer_new /\
- inhabited (parse_tree (NT (start_nt init)) word sem)
- | OK (Progress_sr stack_new buffer_new) =>
- buffer = buffer_new /\
- word_has_stack_semantics word stack_new
- | Err | OK Fail_sr => True
- end.
-Proof with eauto.
-intros.
-unfold reduce_step.
-pose proof (pop_invariant (prod_rhs_rev prod) [] stack (symbol_semantic_type (NT (prod_lhs prod)))).
-revert H0.
-generalize (pop_invariant_converter (symbol_semantic_type (NT (prod_lhs prod))) (prod_rhs_rev prod) []).
-rewrite <- rev_alt.
-intros.
-specialize (H0 (prod_action prod) _ [] () H (inhabits Nil_ptl)).
-match goal with H0:let action' := ?a in _ |- _ => replace a with (prod_action' prod) in H0 end.
-simpl in H0.
-destruct (pop (prod_rhs_rev prod) stack (prod_action' prod)) as [|[]]; intuition.
-destruct H0 as [word1res [word2res [sem_full]]]; intuition.
-destruct H4; apply Non_terminal_pt, inhabits in X.
-match goal with X:inhabited (parse_tree _ _ ?u) |- _ => replace u with s0 in X end.
-clear sem_full H2.
-simpl; destruct (goto_table (state_of_stack init s) (prod_lhs prod)) as [[]|]; intuition; subst.
-rewrite app_nil_r in X; revert s0 X; rewrite e0; intro; simpl.
-constructor...
-destruct s; intuition.
-destruct (compare_eqdec (prod_lhs prod) (start_nt init)); intuition.
-rewrite app_nil_r in X.
-rewrite <- e0.
-inversion H0.
-destruct X; constructor...
-apply JMeq_eq.
-etransitivity.
-apply JMeq_eqrect with (P:=(fun x => x)).
-symmetry.
-apply JMeq_eqrect with (P:=(fun x => x)).
-Qed.
-
-(** [step] preserves the invariant **)
-Lemma step_invariant (stack:stack) (buffer:Stream token):
- forall buffer_tmp,
- (exists word_old,
- buffer = word_old ++ buffer_tmp /\
- word_has_stack_semantics word_old stack) ->
- match step init stack buffer_tmp with
- | OK (Accept_sr sem buffer_new) =>
- exists word_new,
- buffer = word_new ++ buffer_new /\
- inhabited (parse_tree (NT (start_nt init)) word_new sem)
- | OK (Progress_sr stack_new buffer_new) =>
- exists word_new,
- buffer = word_new ++ buffer_new /\
- word_has_stack_semantics word_new stack_new
- | Err | OK Fail_sr => True
- end.
-Proof with eauto.
-intros.
-destruct H, H.
-unfold step.
-destruct (action_table (state_of_stack init stack)).
-pose proof (reduce_step_invariant stack p x buffer_tmp).
-destruct (reduce_step init stack p buffer_tmp) as [|[]]; intuition; subst...
-destruct buffer_tmp.
-unfold Streams.hd.
-destruct t.
-destruct (l x0); intuition.
-exists (x ++ [existT (fun t => symbol_semantic_type (T t)) x0 s])%list.
-split.
-now rewrite <- app_str_app_assoc; intuition.
-apply Cons_stack_whss; intuition.
-destruct e; simpl.
-now exact (inhabits (Terminal_pt _ _)).
-match goal with |- (match reduce_step init stack p ?buff with Err => _ | OK _ => _ end) =>
- pose proof (reduce_step_invariant stack p x buff);
- destruct (reduce_step init stack p buff) as [|[]]; intuition; subst
-end...
-Qed.
-
-(** The interpreter is correct : if it returns a semantic value, then the input
- word has this semantic value.
-**)
-Theorem parse_correct buffer n_steps:
- match parse init buffer n_steps with
- | OK (Parsed_pr sem buffer_new) =>
- exists word_new,
- buffer = word_new ++ buffer_new /\
- inhabited (parse_tree (NT (start_nt init)) word_new sem)
- | _ => True
- end.
-Proof.
-unfold parse.
-assert (exists w, buffer = w ++ buffer /\ word_has_stack_semantics w []).
-exists ([]:list token); intuition.
-now apply Nil_stack_whss.
-revert H.
-generalize ([]:stack), buffer at 2 3.
-induction n_steps; simpl; intuition.
-pose proof (step_invariant _ _ _ H).
-destruct (step init s buffer0); simpl; intuition.
-destruct s0; intuition.
-apply IHn_steps; intuition.
-Qed.
-
-End Init.
-
-End Make.
diff --git a/cparser/MenhirLib/Interpreter_safe.v b/cparser/MenhirLib/Interpreter_safe.v
deleted file mode 100644
index a1aa35b8..00000000
--- a/cparser/MenhirLib/Interpreter_safe.v
+++ /dev/null
@@ -1,275 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import Streams.
-Require Import Equality.
-Require Import List.
-Require Import Syntax.
-Require Import Alphabet.
-Require Grammar.
-Require Automaton.
-Require Validator_safe.
-Require Interpreter.
-
-Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).
-Module Import Valid := Validator_safe.Make A.
-
-(** * A correct automaton does not crash **)
-
-Section Safety_proof.
-
-Hypothesis safe: safe.
-
-Proposition shift_head_symbs: shift_head_symbs.
-Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed.
-Proposition goto_head_symbs: goto_head_symbs.
-Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed.
-Proposition shift_past_state: shift_past_state.
-Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed.
-Proposition goto_past_state: goto_past_state.
-Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed.
-Proposition reduce_ok: reduce_ok.
-Proof. pose proof safe; unfold Valid.safe in H; intuition. Qed.
-
-(** We prove that a correct automaton won't crash : the interpreter will
- not return [Err] **)
-
-Variable init : initstate.
-
-(** The stack of states of an automaton stack **)
-Definition state_stack_of_stack (stack:stack) :=
- (List.map
- (fun cell:sigT noninitstate_type => singleton_state_pred (projT1 cell))
- stack ++ [singleton_state_pred init])%list.
-
-(** The stack of symbols of an automaton stack **)
-Definition symb_stack_of_stack (stack:stack) :=
- List.map
- (fun cell:sigT noninitstate_type => last_symb_of_non_init_state (projT1 cell))
- stack.
-
-(** The stack invariant : it basically states that the assumptions on the
- states are true. **)
-Inductive stack_invariant: stack -> Prop :=
- | stack_invariant_constr:
- forall stack,
- prefix (head_symbs_of_state (state_of_stack init stack))
- (symb_stack_of_stack stack) ->
- prefix_pred (head_states_of_state (state_of_stack init stack))
- (state_stack_of_stack stack) ->
- stack_invariant_next stack ->
- stack_invariant stack
-with stack_invariant_next: stack -> Prop :=
- | stack_invariant_next_nil:
- stack_invariant_next []
- | stack_invariant_next_cons:
- forall state_cur st stack_rec,
- stack_invariant stack_rec ->
- stack_invariant_next (existT _ state_cur st::stack_rec).
-
-(** [pop] conserves the stack invariant and does not crash
- under the assumption that we can pop at this place.
- Moreover, after a pop, the top state of the stack is allowed. **)
-Lemma pop_stack_invariant_conserved
- (symbols_to_pop:list symbol) (stack_cur:stack) A action:
- stack_invariant stack_cur ->
- prefix symbols_to_pop (head_symbs_of_state (state_of_stack init stack_cur)) ->
- match pop symbols_to_pop stack_cur (A:=A) action with
- | OK (stack_new, _) =>
- stack_invariant stack_new /\
- state_valid_after_pop
- (state_of_stack init stack_new) symbols_to_pop
- (head_states_of_state (state_of_stack init stack_cur))
- | Err => False
- end.
-Proof with eauto.
- intros.
- pose proof H.
- destruct H.
- revert H H0 H1 H2 H3.
- generalize (head_symbs_of_state (state_of_stack init stack0)).
- generalize (head_states_of_state (state_of_stack init stack0)).
- revert stack0 A action.
- induction symbols_to_pop; intros.
- - split...
- destruct l; constructor.
- inversion H2; subst.
- specialize (H7 (state_of_stack init stack0)).
- destruct (f2 (state_of_stack init stack0)) as [] eqn:? ...
- destruct stack0 as [|[]]; simpl in *.
- + inversion H6; subst.
- unfold singleton_state_pred in Heqb0.
- now rewrite compare_refl in Heqb0; discriminate.
- + inversion H6; subst.
- unfold singleton_state_pred in Heqb0.
- now rewrite compare_refl in Heqb0; discriminate.
- - destruct stack0 as [|[]]; unfold pop.
- + inversion H0; subst.
- now inversion H.
- + fold pop.
- destruct (compare_eqdec (last_symb_of_non_init_state x) a).
- * inversion H0; subst. clear H0.
- inversion H; subst. clear H.
- dependent destruction H3; simpl.
- assert (prefix_pred (List.tl l) (state_stack_of_stack stack0)).
- unfold tl; destruct l; [constructor | inversion H2]...
- pose proof H. destruct H3.
- specialize (IHsymbols_to_pop stack0 A (action0 n) _ _ H4 H7 H H0 H6).
- revert IHsymbols_to_pop.
- fold (noninitstate_type x); generalize (pop symbols_to_pop stack0 (action0 n)).
- destruct r as [|[]]; intuition...
- destruct l; constructor...
- * apply n0.
- inversion H0; subst.
- inversion H; subst...
-Qed.
-
-(** [prefix] is associative **)
-Lemma prefix_ass:
- forall (l1 l2 l3:list symbol), prefix l1 l2 -> prefix l2 l3 -> prefix l1 l3.
-Proof.
-induction l1; intros.
-constructor.
-inversion H; subst.
-inversion H0; subst.
-constructor; eauto.
-Qed.
-
-(** [prefix_pred] is associative **)
-Lemma prefix_pred_ass:
- forall (l1 l2 l3:list (state->bool)),
- prefix_pred l1 l2 -> prefix_pred l2 l3 -> prefix_pred l1 l3.
-Proof.
-induction l1; intros.
-constructor.
-inversion H; subst.
-inversion H0; subst.
-constructor; eauto.
-intro.
-specialize (H3 x).
-specialize (H4 x).
-destruct (f0 x); simpl in *; intuition.
-rewrite H4 in H3; intuition.
-Qed.
-
-(** If we have the right to reduce at this state, then the stack invariant
- is conserved by [reduce_step] and [reduce_step] does not crash. **)
-Lemma reduce_step_stack_invariant_conserved stack prod buff:
- stack_invariant stack ->
- valid_for_reduce (state_of_stack init stack) prod ->
- match reduce_step init stack prod buff with
- | OK (Fail_sr | Accept_sr _ _) => True
- | OK (Progress_sr stack_new _) => stack_invariant stack_new
- | Err => False
- end.
-Proof with eauto.
-unfold valid_for_reduce.
-intuition.
-unfold reduce_step.
-pose proof (pop_stack_invariant_conserved (prod_rhs_rev prod) stack _ (prod_action' prod)).
-destruct (pop (prod_rhs_rev prod) stack (prod_action' prod)) as [|[]].
-apply H0...
-destruct H0...
-pose proof (goto_head_symbs (state_of_stack init s) (prod_lhs prod)).
-pose proof (goto_past_state (state_of_stack init s) (prod_lhs prod)).
-unfold bind2.
-destruct H0.
-specialize (H2 _ H3)...
-destruct (goto_table (state_of_stack init stack0) (prod_lhs prod)) as [[]|].
-constructor.
-simpl.
-constructor.
-eapply prefix_ass...
-unfold state_stack_of_stack; simpl; constructor.
-intro; destruct (singleton_state_pred x x0); reflexivity.
-eapply prefix_pred_ass...
-constructor...
-constructor...
-destruct stack0 as [|[]]...
-destruct (compare_eqdec (prod_lhs prod) (start_nt init))...
-apply n, H2, eq_refl.
-apply H2, eq_refl.
-Qed.
-
-(** If the automaton is safe, then the stack invariant is conserved by
- [step] and [step] does not crash. **)
-Lemma step_stack_invariant_conserved (stack:stack) buffer:
- stack_invariant stack ->
- match step init stack buffer with
- | OK (Fail_sr | Accept_sr _ _) => True
- | OK (Progress_sr stack_new _) => stack_invariant stack_new
- | Err => False
- end.
-Proof with eauto.
-intro.
-unfold step.
-pose proof (shift_head_symbs (state_of_stack init stack)).
-pose proof (shift_past_state (state_of_stack init stack)).
-pose proof (reduce_ok (state_of_stack init stack)).
-destruct (action_table (state_of_stack init stack)).
-apply reduce_step_stack_invariant_conserved...
-destruct buffer as [[]]; simpl.
-specialize (H0 x); specialize (H1 x); specialize (H2 x).
-destruct (l x)...
-destruct H.
-constructor.
-unfold state_of_stack.
-constructor.
-eapply prefix_ass...
-unfold state_stack_of_stack; simpl; constructor.
-intro; destruct (singleton_state_pred s0 x0)...
-eapply prefix_pred_ass...
-constructor...
-constructor...
-apply reduce_step_stack_invariant_conserved...
-Qed.
-
-(** If the automaton is safe, then it does not crash **)
-Theorem parse_no_err buffer n_steps:
- parse init buffer n_steps <> Err.
-Proof with eauto.
-unfold parse.
-assert (stack_invariant []).
-constructor.
-constructor.
-unfold state_stack_of_stack; simpl; constructor.
-intro; destruct (singleton_state_pred init x)...
-constructor.
-constructor.
-revert H.
-generalize buffer ([]:stack).
-induction n_steps; simpl.
-now discriminate.
-intros.
-pose proof (step_stack_invariant_conserved s buffer0 H).
-destruct (step init s buffer0) as [|[]]; simpl...
-discriminate.
-discriminate.
-Qed.
-
-(** A version of [parse] that uses safeness in order to return a
- [parse_result], and not a [result parse_result] : we have proven that
- parsing does not return [Err]. **)
-Definition parse_with_safe (buffer:Stream token) (n_steps:nat):
- parse_result init.
-Proof with eauto.
-pose proof (parse_no_err buffer n_steps).
-destruct (parse init buffer n_steps)...
-congruence.
-Defined.
-
-End Safety_proof.
-
-End Make.
diff --git a/cparser/MenhirLib/Main.v b/cparser/MenhirLib/Main.v
deleted file mode 100644
index 1a17e988..00000000
--- a/cparser/MenhirLib/Main.v
+++ /dev/null
@@ -1,92 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Grammar.
-Require Automaton.
-Require Interpreter_safe.
-Require Interpreter_correct.
-Require Interpreter_complete.
-Require Import Syntax.
-
-Module Make(Export Aut:Automaton.T).
-Export Aut.Gram.
-Export Aut.GramDefs.
-
-Module Import Inter := Interpreter.Make Aut.
-Module Safe := Interpreter_safe.Make Aut Inter.
-Module Correct := Interpreter_correct.Make Aut Inter.
-Module Complete := Interpreter_complete.Make Aut Inter.
-
-Definition complete_validator:unit->bool := Complete.Valid.is_complete.
-Definition safe_validator:unit->bool := Safe.Valid.is_safe.
-Definition parse (safe:safe_validator ()=true) init n_steps buffer : parse_result init:=
- Safe.parse_with_safe (Safe.Valid.is_safe_correct safe) init buffer n_steps.
-
-(** Correction theorem. **)
-Theorem parse_correct
- (safe:safe_validator ()= true) init n_steps buffer:
- match parse safe init n_steps buffer with
- | Parsed_pr sem buffer_new =>
- exists word,
- buffer = word ++ buffer_new /\ inhabited (parse_tree (NT (start_nt init)) word sem)
- | _ => True
- end.
-Proof.
-unfold parse, Safe.parse_with_safe.
-pose proof (Correct.parse_correct init buffer n_steps).
-generalize (Safe.parse_no_err (Safe.Valid.is_safe_correct safe) init buffer n_steps).
-destruct (Inter.parse init buffer n_steps); intros.
-now destruct (n (eq_refl _)).
-now destruct p; trivial.
-Qed.
-
-(** Completeness theorem. **)
-Theorem parse_complete
- (safe:safe_validator () = true) init n_steps word buffer_end sem:
- complete_validator () = true ->
- forall tree:parse_tree (NT (start_nt init)) word sem,
- match parse safe init n_steps (word ++ buffer_end) with
- | Fail_pr => False
- | Parsed_pr sem_res buffer_end_res =>
- sem_res = sem /\ buffer_end_res = buffer_end /\ pt_size tree <= n_steps
- | Timeout_pr => n_steps < pt_size tree
- end.
-Proof.
-intros.
-unfold parse, Safe.parse_with_safe.
-pose proof (Complete.parse_complete (Complete.Valid.is_complete_correct H) init _ buffer_end _ tree n_steps).
-generalize (Safe.parse_no_err (Safe.Valid.is_safe_correct safe) init (word ++ buffer_end) n_steps).
-destruct (Inter.parse init (word ++ buffer_end) n_steps); intros.
-now destruct (n eq_refl).
-now exact H0.
-Qed.
-
-(** Unambiguity theorem. **)
-Theorem unambiguity:
- safe_validator () = true -> complete_validator () = true -> inhabited token ->
- forall init word,
- forall sem1 (tree1:parse_tree (NT (start_nt init)) word sem1),
- forall sem2 (tree2:parse_tree (NT (start_nt init)) word sem2),
- sem1 = sem2.
-Proof.
-intros.
-destruct H1.
-pose proof (parse_complete H init (pt_size tree1) word (Streams.const X) sem1) H0 tree1.
-pose proof (parse_complete H init (pt_size tree1) word (Streams.const X) sem2) H0 tree2.
-destruct (parse H init (pt_size tree1) (word ++ Streams.const X)); intuition.
-rewrite <- H3, H1; reflexivity.
-Qed.
-
-End Make.
diff --git a/cparser/MenhirLib/Tuples.v b/cparser/MenhirLib/Tuples.v
deleted file mode 100644
index 3fd2ec03..00000000
--- a/cparser/MenhirLib/Tuples.v
+++ /dev/null
@@ -1,49 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Import List.
-Require Import Coq.Program.Syntax.
-Require Import Equality.
-
-(** A curryfied function with multiple parameters **)
-Definition arrows_left: list Type -> Type -> Type :=
- fold_left (fun A B => B -> A).
-
-(** A curryfied function with multiple parameters **)
-Definition arrows_right: Type -> list Type -> Type :=
- fold_right (fun A B => A -> B).
-
-(** A tuple is a heterogeneous list. For convenience, we use pairs. **)
-Fixpoint tuple (types : list Type) : Type :=
- match types with
- | nil => unit
- | t::q => prod t (tuple q)
- end.
-
-Fixpoint uncurry {args:list Type} {res:Type}:
- arrows_left args res -> tuple args -> res :=
- match args return forall res, arrows_left args res -> tuple args -> res with
- | [] => fun _ f _ => f
- | t::q => fun res f p => let (d, t) := p in
- (@uncurry q _ f t) d
- end res.
-
-Lemma JMeq_eqrect:
- forall (U:Type) (a b:U) (P:U -> Type) (x:P a) (e:a=b),
- eq_rect a P x b e ~= x.
-Proof.
-destruct e.
-reflexivity.
-Qed.
diff --git a/cparser/MenhirLib/Validator_complete.v b/cparser/MenhirLib/Validator_complete.v
deleted file mode 100644
index a9823278..00000000
--- a/cparser/MenhirLib/Validator_complete.v
+++ /dev/null
@@ -1,542 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Automaton.
-Require Import Alphabet.
-Require Import List.
-Require Import Syntax.
-
-Module Make(Import A:Automaton.T).
-
-(** We instantiate some sets/map. **)
-Module TerminalComparableM <: ComparableM.
- Definition t := terminal.
- Instance tComparable : Comparable t := _.
-End TerminalComparableM.
-Module TerminalOrderedType := OrderedType_from_ComparableM TerminalComparableM.
-Module StateProdPosComparableM <: ComparableM.
- Definition t := (state*production*nat)%type.
- Instance tComparable : Comparable t := _.
-End StateProdPosComparableM.
-Module StateProdPosOrderedType :=
- OrderedType_from_ComparableM StateProdPosComparableM.
-
-Module TerminalSet := FSetAVL.Make TerminalOrderedType.
-Module StateProdPosMap := FMapAVL.Make StateProdPosOrderedType.
-
-(** Nullable predicate for symbols and list of symbols. **)
-Definition nullable_symb (symbol:symbol) :=
- match symbol with
- | NT nt => nullable_nterm nt
- | _ => false
- end.
-
-Definition nullable_word (word:list symbol) :=
- forallb nullable_symb word.
-
-(** First predicate for non terminal, symbols and list of symbols, given as FSets. **)
-Definition first_nterm_set (nterm:nonterminal) :=
- fold_left (fun acc t => TerminalSet.add t acc)
- (first_nterm nterm) TerminalSet.empty.
-
-Definition first_symb_set (symbol:symbol) :=
- match symbol with
- | NT nt => first_nterm_set nt
- | T t => TerminalSet.singleton t
- end.
-
-Fixpoint first_word_set (word:list symbol) :=
- match word with
- | [] => TerminalSet.empty
- | t::q =>
- if nullable_symb t then
- TerminalSet.union (first_symb_set t) (first_word_set q)
- else
- first_symb_set t
- end.
-
-(** Small helper for finding the part of an item that is after the dot. **)
-Definition future_of_prod prod dot_pos : list symbol :=
- (fix loop n lst :=
- match n with
- | O => lst
- | S x => match loop x lst with [] => [] | _::q => q end
- end)
- dot_pos (rev' (prod_rhs_rev prod)).
-
-(** We build a fast map to store all the items of all the states. **)
-Definition items_map (_:unit): StateProdPosMap.t TerminalSet.t :=
- fold_left (fun acc state =>
- fold_left (fun acc item =>
- let key := (state, prod_item item, dot_pos_item item) in
- let data := fold_left (fun acc t => TerminalSet.add t acc)
- (lookaheads_item item) TerminalSet.empty
- in
- let old :=
- match StateProdPosMap.find key acc with
- | Some x => x | None => TerminalSet.empty
- end
- in
- StateProdPosMap.add key (TerminalSet.union data old) acc
- ) (items_of_state state) acc
- ) all_list (StateProdPosMap.empty TerminalSet.t).
-
-(** Accessor. **)
-Definition find_items_map items_map state prod dot_pos : TerminalSet.t :=
- match StateProdPosMap.find (state, prod, dot_pos) items_map with
- | None => TerminalSet.empty
- | Some x => x
- end.
-
-Definition state_has_future state prod (fut:list symbol) (lookahead:terminal) :=
- exists dot_pos:nat,
- fut = future_of_prod prod dot_pos /\
- TerminalSet.In lookahead (find_items_map (items_map ()) state prod dot_pos).
-
-(** Iterator over items. **)
-Definition forallb_items items_map (P:state -> production -> nat -> TerminalSet.t -> bool): bool:=
- StateProdPosMap.fold (fun key set acc =>
- match key with (st, p, pos) => (acc && P st p pos set)%bool end
- ) items_map true.
-
-Lemma forallb_items_spec :
- forall p, forallb_items (items_map ()) p = true ->
- forall st prod fut lookahead, state_has_future st prod fut lookahead ->
- forall P:state -> production -> list symbol -> terminal -> Prop,
- (forall st prod pos set lookahead,
- TerminalSet.In lookahead set -> p st prod pos set = true ->
- P st prod (future_of_prod prod pos) lookahead) ->
- P st prod fut lookahead.
-Proof.
-intros.
-unfold forallb_items in H.
-rewrite StateProdPosMap.fold_1 in H.
-destruct H0; destruct H0.
-specialize (H1 st prod x _ _ H2).
-destruct H0.
-apply H1.
-unfold find_items_map in *.
-pose proof (@StateProdPosMap.find_2 _ (items_map ()) (st, prod, x)).
-destruct (StateProdPosMap.find (st, prod, x) (items_map ())); [ |destruct (TerminalSet.empty_1 H2)].
-specialize (H0 _ (eq_refl _)).
-pose proof (StateProdPosMap.elements_1 H0).
-revert H.
-generalize true at 1.
-induction H3.
-destruct H.
-destruct y.
-simpl in H3; destruct H3.
-pose proof (compare_eq (st, prod, x) k H).
-destruct H3.
-simpl.
-generalize (p st prod x t).
-induction l; simpl; intros.
-rewrite Bool.andb_true_iff in H3.
-intuition.
-destruct a; destruct k; destruct p0.
-simpl in H3.
-replace (b0 && b && p s p0 n t0)%bool with (b0 && p s p0 n t0 && b)%bool in H3.
-apply (IHl _ _ H3).
-destruct b, b0, (p s p0 n t0); reflexivity.
-intro.
-apply IHInA.
-Qed.
-
-(** * Validation for completeness **)
-
-(** The nullable predicate is a fixpoint : it is correct. **)
-Definition nullable_stable:=
- forall p:production,
- nullable_word (rev (prod_rhs_rev p)) = true ->
- nullable_nterm (prod_lhs p) = true.
-
-Definition is_nullable_stable (_:unit) :=
- forallb (fun p:production =>
- implb (nullable_word (rev' (prod_rhs_rev p))) (nullable_nterm (prod_lhs p)))
- all_list.
-
-Property is_nullable_stable_correct :
- is_nullable_stable () = true -> nullable_stable.
-Proof.
-unfold is_nullable_stable, nullable_stable.
-intros.
-rewrite forallb_forall in H.
-specialize (H p (all_list_forall p)).
-unfold rev' in H; rewrite <- rev_alt in H.
-rewrite H0 in H; intuition.
-Qed.
-
-(** The first predicate is a fixpoint : it is correct. **)
-Definition first_stable:=
- forall (p:production),
- TerminalSet.Subset (first_word_set (rev (prod_rhs_rev p)))
- (first_nterm_set (prod_lhs p)).
-
-Definition is_first_stable (_:unit) :=
- forallb (fun p:production =>
- TerminalSet.subset (first_word_set (rev' (prod_rhs_rev p)))
- (first_nterm_set (prod_lhs p)))
- all_list.
-
-Property is_first_stable_correct :
- is_first_stable () = true -> first_stable.
-Proof.
-unfold is_first_stable, first_stable.
-intros.
-rewrite forallb_forall in H.
-specialize (H p (all_list_forall p)).
-unfold rev' in H; rewrite <- rev_alt in H.
-apply TerminalSet.subset_2; intuition.
-Qed.
-
-(** The initial state has all the S=>.u items, where S is the start non-terminal **)
-Definition start_future :=
- forall (init:initstate) (t:terminal) (p:production),
- prod_lhs p = start_nt init ->
- state_has_future init p (rev (prod_rhs_rev p)) t.
-
-Definition is_start_future items_map :=
- forallb (fun init =>
- forallb (fun prod =>
- if compare_eqb (prod_lhs prod) (start_nt init) then
- let lookaheads := find_items_map items_map init prod 0 in
- forallb (fun t => TerminalSet.mem t lookaheads) all_list
- else
- true) all_list) all_list.
-
-Property is_start_future_correct :
- is_start_future (items_map ()) = true -> start_future.
-Proof.
-unfold is_start_future, start_future.
-intros.
-rewrite forallb_forall in H.
-specialize (H init (all_list_forall _)).
-rewrite forallb_forall in H.
-specialize (H p (all_list_forall _)).
-rewrite <- compare_eqb_iff in H0.
-rewrite H0 in H.
-rewrite forallb_forall in H.
-specialize (H t (all_list_forall _)).
-exists 0.
-split.
-apply rev_alt.
-apply TerminalSet.mem_2; eauto.
-Qed.
-
-(** If a state contains an item of the form A->_.av[[b]], where a is a
- terminal, then reading an a does a [Shift_act], to a state containing
- an item of the form A->_.v[[b]]. **)
-Definition terminal_shift :=
- forall (s1:state) prod fut lookahead,
- state_has_future s1 prod fut lookahead ->
- match fut with
- | T t::q =>
- match action_table s1 with
- | Lookahead_act awp =>
- match awp t with
- | Shift_act s2 _ =>
- state_has_future s2 prod q lookahead
- | _ => False
- end
- | _ => False
- end
- | _ => True
- end.
-
-Definition is_terminal_shift items_map :=
- forallb_items items_map (fun s1 prod pos lset =>
- match future_of_prod prod pos with
- | T t::_ =>
- match action_table s1 with
- | Lookahead_act awp =>
- match awp t with
- | Shift_act s2 _ =>
- TerminalSet.subset lset (find_items_map items_map s2 prod (S pos))
- | _ => false
- end
- | _ => false
- end
- | _ => true
- end).
-
-Property is_terminal_shift_correct :
- is_terminal_shift (items_map ()) = true -> terminal_shift.
-Proof.
-unfold is_terminal_shift, terminal_shift.
-intros.
-apply (forallb_items_spec _ H _ _ _ _ H0 (fun _ _ fut look => _)).
-intros.
-destruct (future_of_prod prod0 pos) as [|[]] eqn:?; intuition.
-destruct (action_table st); intuition.
-destruct (l0 t); intuition.
-exists (S pos).
-split.
-unfold future_of_prod in *.
-rewrite Heql; reflexivity.
-apply (TerminalSet.subset_2 H2); intuition.
-Qed.
-
-(** If a state contains an item of the form A->_.[[a]], then either we do a
- [Default_reduce_act] of the corresponding production, either a is a
- terminal (ie. there is a lookahead terminal), and reading a does a
- [Reduce_act] of the corresponding production. **)
-Definition end_reduce :=
- forall (s:state) prod fut lookahead,
- state_has_future s prod fut lookahead ->
- fut = [] ->
- match action_table s with
- | Default_reduce_act p => p = prod
- | Lookahead_act awt =>
- match awt lookahead with
- | Reduce_act p => p = prod
- | _ => False
- end
- end.
-
-Definition is_end_reduce items_map :=
- forallb_items items_map (fun s prod pos lset =>
- match future_of_prod prod pos with
- | [] =>
- match action_table s with
- | Default_reduce_act p => compare_eqb p prod
- | Lookahead_act awt =>
- TerminalSet.fold (fun lookahead acc =>
- match awt lookahead with
- | Reduce_act p => (acc && compare_eqb p prod)%bool
- | _ => false
- end) lset true
- end
- | _ => true
- end).
-
-Property is_end_reduce_correct :
- is_end_reduce (items_map ()) = true -> end_reduce.
-Proof.
-unfold is_end_reduce, end_reduce.
-intros.
-revert H1.
-apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look => _ ->
- match action_table st with
- | Default_reduce_act p => p = prod
- | _ => _
- end)).
-intros.
-rewrite H3 in H2.
-destruct (action_table st); intuition.
-apply compare_eqb_iff; intuition.
-rewrite TerminalSet.fold_1 in H2.
-revert H2.
-generalize true at 1.
-pose proof (TerminalSet.elements_1 H1).
-induction H2.
-pose proof (compare_eq _ _ H2).
-destruct H4.
-simpl.
-assert (fold_left
- (fun (a : bool) (e : TerminalSet.elt) =>
- match l e with
- | Shift_act _ _ => false
- | Reduce_act p => (a && compare_eqb p prod0)%bool
- | Fail_act => false
- end) l0 false = true -> False).
-induction l0; intuition.
-apply IHl0.
-simpl in H4.
-destruct (l a); intuition.
-destruct (l lookahead0); intuition.
-apply compare_eqb_iff.
-destruct (compare_eqb p prod0); intuition.
-destruct b; intuition.
-simpl; intros.
-eapply IHInA; eauto.
-Qed.
-
-(** If a state contains an item of the form A->_.Bv[[b]], where B is a
- non terminal, then the goto table says we have to go to a state containing
- an item of the form A->_.v[[b]]. **)
-Definition non_terminal_goto :=
- forall (s1:state) prod fut lookahead,
- state_has_future s1 prod fut lookahead ->
- match fut with
- | NT nt::q =>
- match goto_table s1 nt with
- | Some (exist _ s2 _) =>
- state_has_future s2 prod q lookahead
- | None =>
- forall prod fut lookahead,
- state_has_future s1 prod fut lookahead ->
- match fut with
- | NT nt'::_ => nt <> nt'
- | _ => True
- end
- end
- | _ => True
- end.
-
-Definition is_non_terminal_goto items_map :=
- forallb_items items_map (fun s1 prod pos lset =>
- match future_of_prod prod pos with
- | NT nt::_ =>
- match goto_table s1 nt with
- | Some (exist _ s2 _) =>
- TerminalSet.subset lset (find_items_map items_map s2 prod (S pos))
- | None => forallb_items items_map (fun s1' prod' pos' _ =>
- (implb (compare_eqb s1 s1')
- match future_of_prod prod' pos' with
- | NT nt' :: _ => negb (compare_eqb nt nt')
- | _ => true
- end)%bool)
- end
- | _ => true
- end).
-
-Property is_non_terminal_goto_correct :
- is_non_terminal_goto (items_map ()) = true -> non_terminal_goto.
-Proof.
-unfold is_non_terminal_goto, non_terminal_goto.
-intros.
-apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look =>
- match fut with
- | NT nt :: q =>
- match goto_table st nt with
- | Some _ => _
- | None =>
- forall p f l, state_has_future st p f l -> (_:Prop)
- end
- | _ => _
- end)).
-intros.
-destruct (future_of_prod prod0 pos) as [|[]] eqn:?; intuition.
-destruct (goto_table st n) as [[]|].
-exists (S pos).
-split.
-unfold future_of_prod in *.
-rewrite Heql; reflexivity.
-apply (TerminalSet.subset_2 H2); intuition.
-intros.
-remember st in H2; revert Heqs.
-apply (forallb_items_spec _ H2 _ _ _ _ H3 (fun st' prod fut look => s = st' -> match fut return Prop with [] => _ | _ => _ end)); intros.
-rewrite <- compare_eqb_iff in H6; rewrite H6 in H5.
-destruct (future_of_prod prod1 pos0) as [|[]]; intuition.
-rewrite <- compare_eqb_iff in H7; rewrite H7 in H5.
-discriminate.
-Qed.
-
-Definition start_goto :=
- forall (init:initstate), goto_table init (start_nt init) = None.
-
-Definition is_start_goto (_:unit) :=
- forallb (fun (init:initstate) =>
- match goto_table init (start_nt init) with
- | Some _ => false
- | None => true
- end) all_list.
-
-Definition is_start_goto_correct:
- is_start_goto () = true -> start_goto.
-Proof.
-unfold is_start_goto, start_goto.
-rewrite forallb_forall.
-intros.
-specialize (H init (all_list_forall _)).
-destruct (goto_table init (start_nt init)); congruence.
-Qed.
-
-(** Closure property of item sets : if a state contains an item of the form
- A->_.Bv[[b]], then for each production B->u and each terminal a of
- first(vb), the state contains an item of the form B->_.u[[a]] **)
-Definition non_terminal_closed :=
- forall (s1:state) prod fut lookahead,
- state_has_future s1 prod fut lookahead ->
- match fut with
- | NT nt::q =>
- forall (p:production) (lookahead2:terminal),
- prod_lhs p = nt ->
- TerminalSet.In lookahead2 (first_word_set q) \/
- lookahead2 = lookahead /\ nullable_word q = true ->
- state_has_future s1 p (rev (prod_rhs_rev p)) lookahead2
- | _ => True
- end.
-
-Definition is_non_terminal_closed items_map :=
- forallb_items items_map (fun s1 prod pos lset =>
- match future_of_prod prod pos with
- | NT nt::q =>
- forallb (fun p =>
- if compare_eqb (prod_lhs p) nt then
- let lookaheads := find_items_map items_map s1 p 0 in
- (implb (nullable_word q) (TerminalSet.subset lset lookaheads)) &&
- TerminalSet.subset (first_word_set q) lookaheads
- else true
- )%bool all_list
- | _ => true
- end).
-
-Property is_non_terminal_closed_correct:
- is_non_terminal_closed (items_map ()) = true -> non_terminal_closed.
-Proof.
-unfold is_non_terminal_closed, non_terminal_closed.
-intros.
-apply (forallb_items_spec _ H _ _ _ _ H0 (fun st prod fut look =>
- match fut with
- | NT nt :: q => forall p l, _ -> _ -> state_has_future st _ _ _
- | _ => _
- end)).
-intros.
-destruct (future_of_prod prod0 pos); intuition.
-destruct s; eauto; intros.
-rewrite forallb_forall in H2.
-specialize (H2 p (all_list_forall p)).
-rewrite <- compare_eqb_iff in H3.
-rewrite H3 in H2.
-rewrite Bool.andb_true_iff in H2.
-destruct H2.
-exists 0.
-split.
-apply rev_alt.
-destruct H4 as [|[]]; subst.
-apply (TerminalSet.subset_2 H5); intuition.
-rewrite H6 in H2.
-apply (TerminalSet.subset_2 H2); intuition.
-Qed.
-
-(** The automaton is complete **)
-Definition complete :=
- nullable_stable /\ first_stable /\ start_future /\ terminal_shift
- /\ end_reduce /\ non_terminal_goto /\ start_goto /\ non_terminal_closed.
-
-Definition is_complete (_:unit) :=
- let items_map := items_map () in
- (is_nullable_stable () && is_first_stable () && is_start_future items_map &&
- is_terminal_shift items_map && is_end_reduce items_map && is_start_goto () &&
- is_non_terminal_goto items_map && is_non_terminal_closed items_map)%bool.
-
-Property is_complete_correct:
- is_complete () = true -> complete.
-Proof.
-unfold is_complete, complete.
-repeat rewrite Bool.andb_true_iff.
-intuition.
-apply is_nullable_stable_correct; assumption.
-apply is_first_stable_correct; assumption.
-apply is_start_future_correct; assumption.
-apply is_terminal_shift_correct; assumption.
-apply is_end_reduce_correct; assumption.
-apply is_non_terminal_goto_correct; assumption.
-apply is_start_goto_correct; assumption.
-apply is_non_terminal_closed_correct; assumption.
-Qed.
-
-End Make.
diff --git a/cparser/MenhirLib/Validator_safe.v b/cparser/MenhirLib/Validator_safe.v
deleted file mode 100644
index 183d661b..00000000
--- a/cparser/MenhirLib/Validator_safe.v
+++ /dev/null
@@ -1,414 +0,0 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Jacques-Henri Jourdan, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the GNU General Public License as published by *)
-(* the Free Software Foundation, either version 2 of the License, or *)
-(* (at your option) any later version. This file is also distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-Require Automaton.
-Require Import Alphabet.
-Require Import List.
-Require Import Syntax.
-
-Module Make(Import A:Automaton.T).
-
-(** The singleton predicate for states **)
-Definition singleton_state_pred (state:state) :=
- (fun state' => match compare state state' with Eq => true |_ => false end).
-
-(** [past_state_of_non_init_state], extended for all states. **)
-Definition past_state_of_state (state:state) :=
- match state with
- | Init _ => []
- | Ninit nis => past_state_of_non_init_state nis
- end.
-
-(** Concatenations of last and past **)
-Definition head_symbs_of_state (state:state) :=
- match state with
- | Init _ => []
- | Ninit s =>
- last_symb_of_non_init_state s::past_symb_of_non_init_state s
- end.
-Definition head_states_of_state (state:state) :=
- singleton_state_pred state::past_state_of_state state.
-
-(** * Validation for correctness **)
-
-(** Prefix predicate between two lists of symbols. **)
-Inductive prefix: list symbol -> list symbol -> Prop :=
- | prefix_nil: forall l, prefix [] l
- | prefix_cons: forall l1 l2 x, prefix l1 l2 -> prefix (x::l1) (x::l2).
-
-Fixpoint is_prefix (l1 l2:list symbol):=
- match l1, l2 with
- | [], _ => true
- | t1::q1, t2::q2 => (compare_eqb t1 t2 && is_prefix q1 q2)%bool
- | _::_, [] => false
- end.
-
-Property is_prefix_correct (l1 l2:list symbol):
- is_prefix l1 l2 = true -> prefix l1 l2.
-Proof.
-revert l2.
-induction l1; intros.
-apply prefix_nil.
-unfold is_prefix in H.
-destruct l2; intuition; try discriminate.
-rewrite Bool.andb_true_iff in H.
-destruct H.
-rewrite compare_eqb_iff in H.
-destruct H.
-apply prefix_cons.
-apply IHl1; intuition.
-Qed.
-
-(** If we shift, then the known top symbols of the destination state is
- a prefix of the known top symbols of the source state, with the new
- symbol added. **)
-Definition shift_head_symbs :=
- forall s,
- match action_table s with
- | Lookahead_act awp =>
- forall t, match awp t with
- | Shift_act s2 _ =>
- prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
- | _ => True
- end
- | _ => True
- end.
-
-Definition is_shift_head_symbs (_:unit) :=
- forallb (fun s:state =>
- match action_table s with
- | Lookahead_act awp =>
- forallb (fun t =>
- match awp t with
- | Shift_act s2 _ =>
- is_prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
- | _ => true
- end)
- all_list
- | _ => true
- end)
- all_list.
-
-Property is_shift_head_symbs_correct:
- is_shift_head_symbs () = true -> shift_head_symbs.
-Proof.
-unfold is_shift_head_symbs, shift_head_symbs.
-intros.
-rewrite forallb_forall in H.
-specialize (H s (all_list_forall s)).
-destruct (action_table s); intuition.
-rewrite forallb_forall in H.
-specialize (H t (all_list_forall t)).
-destruct (l t); intuition.
-apply is_prefix_correct; intuition.
-Qed.
-
-(** When a goto happens, then the known top symbols of the destination state
- is a prefix of the known top symbols of the source state, with the new
- symbol added. **)
-Definition goto_head_symbs :=
- forall s nt,
- match goto_table s nt with
- | Some (exist _ s2 _) =>
- prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
- | None => True
- end.
-
-Definition is_goto_head_symbs (_:unit) :=
- forallb (fun s:state =>
- forallb (fun nt =>
- match goto_table s nt with
- | Some (exist _ s2 _) =>
- is_prefix (past_symb_of_non_init_state s2) (head_symbs_of_state s)
- | None => true
- end)
- all_list)
- all_list.
-
-Property is_goto_head_symbs_correct:
- is_goto_head_symbs () = true -> goto_head_symbs.
-Proof.
-unfold is_goto_head_symbs, goto_head_symbs.
-intros.
-rewrite forallb_forall in H.
-specialize (H s (all_list_forall s)).
-rewrite forallb_forall in H.
-specialize (H nt (all_list_forall nt)).
-destruct (goto_table s nt); intuition.
-destruct s0.
-apply is_prefix_correct; intuition.
-Qed.
-
-(** We have to say the same kind of checks for the assumptions about the
- states stack. However, theses assumptions are predicates. So we define
- a notion of "prefix" over predicates lists, that means, basically, that
- an assumption entails another **)
-Inductive prefix_pred: list (state->bool) -> list (state->bool) -> Prop :=
- | prefix_pred_nil: forall l, prefix_pred [] l
- | prefix_pred_cons: forall l1 l2 f1 f2,
- (forall x, implb (f2 x) (f1 x) = true) ->
- prefix_pred l1 l2 -> prefix_pred (f1::l1) (f2::l2).
-
-Fixpoint is_prefix_pred (l1 l2:list (state->bool)) :=
- match l1, l2 with
- | [], _ => true
- | f1::q1, f2::q2 =>
- (forallb (fun x => implb (f2 x) (f1 x)) all_list
- && is_prefix_pred q1 q2)%bool
- | _::_, [] => false
- end.
-
-Property is_prefix_pred_correct (l1 l2:list (state->bool)) :
- is_prefix_pred l1 l2 = true -> prefix_pred l1 l2.
-Proof.
-revert l2.
-induction l1.
-intros.
-apply prefix_pred_nil.
-intros.
-destruct l2; intuition; try discriminate.
-unfold is_prefix_pred in H.
-rewrite Bool.andb_true_iff in H.
-rewrite forallb_forall in H.
-apply prefix_pred_cons; intuition.
-apply H0.
-apply all_list_forall.
-Qed.
-
-(** The assumptions about state stack is conserved when we shift **)
-Definition shift_past_state :=
- forall s,
- match action_table s with
- | Lookahead_act awp =>
- forall t, match awp t with
- | Shift_act s2 _ =>
- prefix_pred (past_state_of_non_init_state s2)
- (head_states_of_state s)
- | _ => True
- end
- | _ => True
- end.
-
-Definition is_shift_past_state (_:unit) :=
- forallb (fun s:state =>
- match action_table s with
- | Lookahead_act awp =>
- forallb (fun t =>
- match awp t with
- | Shift_act s2 _ =>
- is_prefix_pred
- (past_state_of_non_init_state s2) (head_states_of_state s)
- | _ => true
- end)
- all_list
- | _ => true
- end)
- all_list.
-
-Property is_shift_past_state_correct:
- is_shift_past_state () = true -> shift_past_state.
-Proof.
-unfold is_shift_past_state, shift_past_state.
-intros.
-rewrite forallb_forall in H.
-specialize (H s (all_list_forall s)).
-destruct (action_table s); intuition.
-rewrite forallb_forall in H.
-specialize (H t (all_list_forall t)).
-destruct (l t); intuition.
-apply is_prefix_pred_correct; intuition.
-Qed.
-
-(** The assumptions about state stack is conserved when we do a goto **)
-Definition goto_past_state :=
- forall s nt,
- match goto_table s nt with
- | Some (exist _ s2 _) =>
- prefix_pred (past_state_of_non_init_state s2)
- (head_states_of_state s)
- | None => True
- end.
-
-Definition is_goto_past_state (_:unit) :=
- forallb (fun s:state =>
- forallb (fun nt =>
- match goto_table s nt with
- | Some (exist _ s2 _) =>
- is_prefix_pred
- (past_state_of_non_init_state s2) (head_states_of_state s)
- | None => true
- end)
- all_list)
- all_list.
-
-Property is_goto_past_state_correct :
- is_goto_past_state () = true -> goto_past_state.
-Proof.
-unfold is_goto_past_state, goto_past_state.
-intros.
-rewrite forallb_forall in H.
-specialize (H s (all_list_forall s)).
-rewrite forallb_forall in H.
-specialize (H nt (all_list_forall nt)).
-destruct (goto_table s nt); intuition.
-destruct s0.
-apply is_prefix_pred_correct; intuition.
-Qed.
-
-(** What states are possible after having popped these symbols from the
- stack, given the annotation of the current state ? **)
-Inductive state_valid_after_pop (s:state):
- list symbol -> list (state -> bool) -> Prop :=
- | state_valid_after_pop_nil1:
- forall p pl, p s = true -> state_valid_after_pop s [] (p::pl)
- | state_valid_after_pop_nil2:
- forall sl, state_valid_after_pop s sl []
- | state_valid_after_pop_cons:
- forall st sq p pl, state_valid_after_pop s sq pl ->
- state_valid_after_pop s (st::sq) (p::pl).
-
-Fixpoint is_state_valid_after_pop
- (state:state) (to_pop:list symbol) annot :=
- match annot, to_pop with
- | [], _ => true
- | p::_, [] => p state
- | p::pl, s::sl => is_state_valid_after_pop state sl pl
- end.
-
-Property is_state_valid_after_pop_complete state sl pl :
- state_valid_after_pop state sl pl -> is_state_valid_after_pop state sl pl = true.
-Proof.
-intro.
-induction H; intuition.
-destruct sl; intuition.
-Qed.
-
-(** A state is valid for reducing a production when :
- - The assumptions on the state are such that we will find the right hand
- side of the production on the stack.
- - We will be able to do a goto after having popped the right hand side.
-**)
-Definition valid_for_reduce (state:state) prod :=
- prefix (prod_rhs_rev prod) (head_symbs_of_state state) /\
- forall state_new,
- state_valid_after_pop state_new
- (prod_rhs_rev prod) (head_states_of_state state) ->
- goto_table state_new (prod_lhs prod) = None ->
- match state_new with
- | Init i => prod_lhs prod = start_nt i
- | Ninit _ => False
- end.
-
-Definition is_valid_for_reduce (state:state) prod:=
- (is_prefix (prod_rhs_rev prod) (head_symbs_of_state state) &&
- forallb (fun state_new =>
- if is_state_valid_after_pop state_new (prod_rhs_rev prod)
- (head_states_of_state state) then
- match goto_table state_new (prod_lhs prod) with
- | Some _ => true
- | None =>
- match state_new with
- | Init i => compare_eqb (prod_lhs prod) (start_nt i)
- | Ninit _ => false
- end
- end
- else
- true)
- all_list)%bool.
-
-Property is_valid_for_reduce_correct (state:state) prod:
- is_valid_for_reduce state prod = true -> valid_for_reduce state prod.
-Proof.
-unfold is_valid_for_reduce, valid_for_reduce.
-intros.
-rewrite Bool.andb_true_iff in H.
-split.
-apply is_prefix_correct.
-intuition.
-intros.
-rewrite forallb_forall in H.
-destruct H.
-specialize (H2 state_new (all_list_forall state_new)).
-rewrite is_state_valid_after_pop_complete, H1 in H2.
-destruct state_new; intuition.
-rewrite compare_eqb_iff in H2; intuition.
-intuition.
-Qed.
-
-(** All the states that does a reduce are valid for reduction **)
-Definition reduce_ok :=
- forall s,
- match action_table s with
- | Lookahead_act awp =>
- forall t, match awp t with
- | Reduce_act p => valid_for_reduce s p
- | _ => True
- end
- | Default_reduce_act p => valid_for_reduce s p
- end.
-
-Definition is_reduce_ok (_:unit) :=
- forallb (fun s =>
- match action_table s with
- | Lookahead_act awp =>
- forallb (fun t =>
- match awp t with
- | Reduce_act p => is_valid_for_reduce s p
- | _ => true
- end)
- all_list
- | Default_reduce_act p => is_valid_for_reduce s p
- end)
- all_list.
-
-Property is_reduce_ok_correct :
- is_reduce_ok () = true -> reduce_ok.
-Proof.
-unfold is_reduce_ok, reduce_ok.
-intros.
-rewrite forallb_forall in H.
-specialize (H s (all_list_forall s)).
-destruct (action_table s).
-apply is_valid_for_reduce_correct; intuition.
-intro.
-rewrite forallb_forall in H.
-specialize (H t (all_list_forall t)).
-destruct (l t); intuition.
-apply is_valid_for_reduce_correct; intuition.
-Qed.
-
-(** The automaton is safe **)
-Definition safe :=
- shift_head_symbs /\ goto_head_symbs /\ shift_past_state /\
- goto_past_state /\ reduce_ok.
-
-Definition is_safe (_:unit) :=
- (is_shift_head_symbs () && is_goto_head_symbs () && is_shift_past_state () &&
- is_goto_past_state () && is_reduce_ok ())%bool.
-
-Property is_safe_correct:
- is_safe () = true -> safe.
-Proof.
-unfold safe, is_safe.
-repeat rewrite Bool.andb_true_iff.
-intuition.
-apply is_shift_head_symbs_correct; assumption.
-apply is_goto_head_symbs_correct; assumption.
-apply is_shift_past_state_correct; assumption.
-apply is_goto_past_state_correct; assumption.
-apply is_reduce_ok_correct; assumption.
-Qed.
-
-End Make.
diff --git a/cparser/PackedStructs.ml b/cparser/PackedStructs.ml
index 3c27f3a9..4c70c7ae 100644
--- a/cparser/PackedStructs.ml
+++ b/cparser/PackedStructs.ml
@@ -418,4 +418,4 @@ let program p =
| _ -> false
end;
Hashtbl.clear byteswapped_fields;
- transf_globdecls (Builtins.environment()) [] p
+ transf_globdecls (Env.initial()) [] p
diff --git a/cparser/Parse.ml b/cparser/Parse.ml
index 154e3dcf..29245083 100644
--- a/cparser/Parse.ml
+++ b/cparser/Parse.ml
@@ -56,22 +56,21 @@ let preprocessed_file transfs name sourcefile =
let text = read_file sourcefile in
let p =
let t = parse_transformations transfs in
- let rec inf = Datatypes.S inf in
+ let log_fuel = Camlcoq.Nat.of_int 50 in
let ast : Cabs.definition list =
- Obj.magic
(match Timing.time "Parsing"
(* The call to Lexer.tokens_stream results in the pre
parsing of the entire file. This is non-negligeabe,
so we cannot use Timing.time2 *)
(fun () ->
- Parser.translation_unit_file inf (Lexer.tokens_stream name text)) ()
+ Parser.translation_unit_file log_fuel (Lexer.tokens_stream name text)) ()
with
- | Parser.Parser.Inter.Fail_pr ->
+ | Parser.MenhirLibParser.Inter.Fail_pr ->
(* Theoretically impossible : implies inconsistencies
between grammars. *)
- Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing"
- | Parser.Parser.Inter.Timeout_pr -> assert false
- | Parser.Parser.Inter.Parsed_pr (ast, _ ) -> ast) in
+ Diagnostics.fatal_error Diagnostics.no_loc "internal error while parsing"
+ | Parser.MenhirLibParser.Inter.Timeout_pr -> assert false
+ | Parser.MenhirLibParser.Inter.Parsed_pr (ast, _ ) -> ast) in
let p1 = Timing.time "Elaboration" Elab.elab_file ast in
Diagnostics.check_errors ();
Timing.time2 "Emulations" transform_program t p1 name in
diff --git a/cparser/Parser.vy b/cparser/Parser.vy
index 79e3793d..03bfa590 100644
--- a/cparser/Parser.vy
+++ b/cparser/Parser.vy
@@ -15,96 +15,99 @@
%{
-Require Import Cabs.
Require Import List.
+Require Cabs.
%}
-%token<string * cabsloc> VAR_NAME TYPEDEF_NAME OTHER_NAME
-%token<string * cabsloc> PRAGMA
-%token<bool * list char_code * cabsloc> STRING_LITERAL
-%token<constant * cabsloc> CONSTANT
-%token<cabsloc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT
+%token<Cabs.string * Cabs.loc> VAR_NAME TYPEDEF_NAME OTHER_NAME
+%token<Cabs.string * Cabs.loc> PRAGMA
+%token<bool * list Cabs.char_code * Cabs.loc> STRING_LITERAL
+%token<Cabs.constant * Cabs.loc> CONSTANT
+%token<Cabs.loc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT
ANDAND BARBAR PLUS MINUS STAR TILDE BANG SLASH PERCENT HAT BAR QUESTION
COLON AND ALIGNOF
-%token<cabsloc> MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN
+%token<Cabs.loc> MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN
LEFT_ASSIGN RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN
-%token<cabsloc> LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA
- SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE NORETURN
- CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID
+%token<Cabs.loc> LPAREN RPAREN LBRACK RBRACK LBRACE RBRACE DOT COMMA
+ SEMICOLON ELLIPSIS TYPEDEF EXTERN STATIC RESTRICT AUTO REGISTER INLINE
+ NORETURN CHAR SHORT INT LONG SIGNED UNSIGNED FLOAT DOUBLE CONST VOLATILE VOID
STRUCT UNION ENUM UNDERSCORE_BOOL PACKED ALIGNAS ATTRIBUTE ASM
-%token<cabsloc> CASE DEFAULT IF ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK
+%token<Cabs.loc> CASE DEFAULT IF_ ELSE SWITCH WHILE DO FOR GOTO CONTINUE BREAK
RETURN BUILTIN_VA_ARG BUILTIN_OFFSETOF
%token EOF
-%type<expression * cabsloc> primary_expression postfix_expression
+%type<Cabs.expression * Cabs.loc> primary_expression postfix_expression
unary_expression cast_expression multiplicative_expression additive_expression
shift_expression relational_expression equality_expression AND_expression
exclusive_OR_expression inclusive_OR_expression logical_AND_expression
logical_OR_expression conditional_expression assignment_expression
constant_expression expression
-%type<unary_operator * cabsloc> unary_operator
-%type<binary_operator> assignment_operator
-%type<list expression (* Reverse order *)> argument_expression_list
-%type<definition> declaration
-%type<list spec_elem * cabsloc> declaration_specifiers
-%type<list spec_elem> declaration_specifiers_typespec_opt
-%type<list init_name (* Reverse order *)> init_declarator_list
-%type<init_name> init_declarator
-%type<storage * cabsloc> storage_class_specifier
-%type<typeSpecifier * cabsloc> type_specifier struct_or_union_specifier enum_specifier
-%type<structOrUnion * cabsloc> struct_or_union
-%type<list field_group (* Reverse order *)> struct_declaration_list
-%type<field_group> struct_declaration
-%type<list spec_elem * cabsloc> specifier_qualifier_list
-%type<list (option name * option expression) (* Reverse order *)> struct_declarator_list
-%type<option name * option expression> struct_declarator
-%type<list (string * option expression * cabsloc) (* Reverse order *)> enumerator_list
-%type<string * option expression * cabsloc> enumerator
-%type<string * cabsloc> enumeration_constant
-%type<cvspec * cabsloc> type_qualifier type_qualifier_noattr
-%type<funspec * cabsloc> function_specifier
-%type<name> declarator declarator_noattrend direct_declarator
-%type<(decl_type -> decl_type) * cabsloc> pointer
-%type<list cvspec (* Reverse order *)> type_qualifier_list
-%type<list parameter * bool> parameter_type_list
-%type<list parameter (* Reverse order *)> parameter_list
-%type<parameter> parameter_declaration
-%type<list spec_elem * decl_type> type_name
-%type<decl_type> abstract_declarator direct_abstract_declarator
-%type<init_expression> c_initializer
-%type<list (list initwhat * init_expression) (* Reverse order *)> initializer_list
-%type<list initwhat> designation
-%type<list initwhat (* Reverse order *)> designator_list
-%type<initwhat> designator
-%type<statement> statement_dangerous statement_safe
+%type<Cabs.unary_operator * Cabs.loc> unary_operator
+%type<Cabs.binary_operator> assignment_operator
+%type<list Cabs.expression (* Reverse order *)> argument_expression_list
+%type<Cabs.definition> declaration
+%type<list Cabs.spec_elem * Cabs.loc> declaration_specifiers
+%type<list Cabs.spec_elem> declaration_specifiers_typespec_opt
+%type<list Cabs.init_name (* Reverse order *)> init_declarator_list
+%type<Cabs.init_name> init_declarator
+%type<Cabs.storage * Cabs.loc> storage_class_specifier
+%type<Cabs.typeSpecifier * Cabs.loc> type_specifier struct_or_union_specifier enum_specifier
+%type<Cabs.structOrUnion * Cabs.loc> struct_or_union
+%type<list Cabs.field_group (* Reverse order *)> struct_declaration_list
+%type<Cabs.field_group> struct_declaration
+%type<list Cabs.spec_elem * Cabs.loc> specifier_qualifier_list
+%type<list (option Cabs.name * option Cabs.expression) (* Reverse order *)>
+ struct_declarator_list
+%type<option Cabs.name * option Cabs.expression> struct_declarator
+%type<list (Cabs.string * option Cabs.expression * Cabs.loc) (* Reverse order *)>
+ enumerator_list
+%type<Cabs.string * option Cabs.expression * Cabs.loc> enumerator
+%type<Cabs.string * Cabs.loc> enumeration_constant
+%type<Cabs.cvspec * Cabs.loc> type_qualifier type_qualifier_noattr
+%type<Cabs.funspec * Cabs.loc> function_specifier
+%type<Cabs.name> declarator declarator_noattrend direct_declarator
+%type<(Cabs.decl_type -> Cabs.decl_type) * Cabs.loc> pointer
+%type<list Cabs.cvspec (* Reverse order *)> type_qualifier_list
+%type<list Cabs.parameter * bool> parameter_type_list
+%type<list Cabs.parameter (* Reverse order *)> parameter_list
+%type<Cabs.parameter> parameter_declaration
+%type<list Cabs.spec_elem * Cabs.decl_type> type_name
+%type<Cabs.decl_type> abstract_declarator direct_abstract_declarator
+%type<Cabs.init_expression> c_initializer
+%type<list (list Cabs.initwhat * Cabs.init_expression) (* Reverse order *)>
+ initializer_list
+%type<list Cabs.initwhat> designation
+%type<list Cabs.initwhat (* Reverse order *)> designator_list
+%type<Cabs.initwhat> designator
+%type<Cabs.statement> statement_dangerous statement_safe
labeled_statement(statement_safe) labeled_statement(statement_dangerous)
iteration_statement(statement_safe) iteration_statement(statement_dangerous)
compound_statement
-%type<list statement (* Reverse order *)> block_item_list
-%type<statement> block_item expression_statement selection_statement_dangerous
+%type<list Cabs.statement (* Reverse order *)> block_item_list
+%type<Cabs.statement> block_item expression_statement selection_statement_dangerous
selection_statement_safe jump_statement asm_statement
-%type<list definition (* Reverse order *)> translation_unit
-%type<definition> external_declaration function_definition
-%type<list definition> declaration_list
-%type<attribute * cabsloc> attribute_specifier
-%type<list attribute> attribute_specifier_list
-%type<gcc_attribute> gcc_attribute
-%type<list gcc_attribute> gcc_attribute_list
-%type<gcc_attribute_word> gcc_attribute_word
-%type<list string (* Reverse order *)> identifier_list
-%type<list asm_flag> asm_flags
-%type<option string> asm_op_name
-%type<asm_operand> asm_operand
-%type<list asm_operand> asm_operands asm_operands_ne
-%type<list asm_operand * list asm_operand * list asm_flag> asm_arguments
-%type<list cvspec> asm_attributes
-
-%start<list definition> translation_unit_file
+%type<list Cabs.definition (* Reverse order *)> translation_unit
+%type<Cabs.definition> external_declaration function_definition
+%type<list Cabs.definition> declaration_list
+%type<Cabs.attribute * Cabs.loc> attribute_specifier
+%type<list Cabs.attribute> attribute_specifier_list
+%type<Cabs.gcc_attribute> gcc_attribute
+%type<list Cabs.gcc_attribute> gcc_attribute_list
+%type<Cabs.gcc_attribute_word> gcc_attribute_word
+%type<list Cabs.string (* Reverse order *)> identifier_list
+%type<list Cabs.asm_flag> asm_flags
+%type<option Cabs.string> asm_op_name
+%type<Cabs.asm_operand> asm_operand
+%type<list Cabs.asm_operand> asm_operands asm_operands_ne
+%type<list Cabs.asm_operand * list Cabs.asm_operand * list Cabs.asm_flag> asm_arguments
+%type<list Cabs.cvspec> asm_attributes
+
+%start<list Cabs.definition> translation_unit_file
%%
(* Actual grammar *)
@@ -112,12 +115,12 @@ Require Import List.
(* 6.5.1 *)
primary_expression:
| var = VAR_NAME
- { (VARIABLE (fst var), snd var) }
+ { (Cabs.VARIABLE (fst var), snd var) }
| cst = CONSTANT
- { (CONSTANT (fst cst), snd cst) }
+ { (Cabs.CONSTANT (fst cst), snd cst) }
| str = STRING_LITERAL
{ let '((wide, chars), loc) := str in
- (CONSTANT (CONST_STRING wide chars), loc) }
+ (Cabs.CONSTANT (Cabs.CONST_STRING wide chars), loc) }
| loc = LPAREN expr = expression RPAREN
{ (fst expr, loc)}
@@ -126,29 +129,30 @@ postfix_expression:
| expr = primary_expression
{ expr }
| expr = postfix_expression LBRACK index = expression RBRACK
- { (INDEX (fst expr) (fst index), snd expr) }
+ { (Cabs.INDEX (fst expr) (fst index), snd expr) }
| expr = postfix_expression LPAREN args = argument_expression_list RPAREN
- { (CALL (fst expr) (rev' args), snd expr) }
+ { (Cabs.CALL (fst expr) (rev' args), snd expr) }
| expr = postfix_expression LPAREN RPAREN
- { (CALL (fst expr) [], snd expr) }
+ { (Cabs.CALL (fst expr) [], snd expr) }
| loc = BUILTIN_VA_ARG LPAREN expr = assignment_expression COMMA ty = type_name RPAREN
- { (BUILTIN_VA_ARG (fst expr) ty, loc) }
+ { (Cabs.BUILTIN_VA_ARG (fst expr) ty, loc) }
| expr = postfix_expression DOT mem = OTHER_NAME
- { (MEMBEROF (fst expr) (fst mem), snd expr) }
+ { (Cabs.MEMBEROF (fst expr) (fst mem), snd expr) }
| expr = postfix_expression PTR mem = OTHER_NAME
- { (MEMBEROFPTR (fst expr) (fst mem), snd expr) }
+ { (Cabs.MEMBEROFPTR (fst expr) (fst mem), snd expr) }
| expr = postfix_expression INC
- { (UNARY POSINCR (fst expr), snd expr) }
+ { (Cabs.UNARY Cabs.POSINCR (fst expr), snd expr) }
| expr = postfix_expression DEC
- { (UNARY POSDECR (fst expr), snd expr) }
+ { (Cabs.UNARY Cabs.POSDECR (fst expr), snd expr) }
| loc = LPAREN typ = type_name RPAREN LBRACE init = initializer_list RBRACE
- { (CAST typ (COMPOUND_INIT (rev' init)), loc) }
+ { (Cabs.CAST typ (Cabs.COMPOUND_INIT (rev' init)), loc) }
| loc = LPAREN typ = type_name RPAREN LBRACE init = initializer_list COMMA RBRACE
- { (CAST typ (COMPOUND_INIT (rev' init)), loc) }
-| loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA id = OTHER_NAME mems = designator_list RPAREN
- { (BUILTIN_OFFSETOF typ ((INFIELD_INIT (fst id))::(rev mems)), loc) }
+ { (Cabs.CAST typ (Cabs.COMPOUND_INIT (rev' init)), loc) }
+| loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA id = OTHER_NAME
+ mems = designator_list RPAREN
+ { (Cabs.BUILTIN_OFFSETOF typ ((Cabs.INFIELD_INIT (fst id))::(rev mems)), loc) }
| loc = BUILTIN_OFFSETOF LPAREN typ = type_name COMMA mem = OTHER_NAME RPAREN
- { (BUILTIN_OFFSETOF typ [INFIELD_INIT (fst mem)], loc) }
+ { (Cabs.BUILTIN_OFFSETOF typ [Cabs.INFIELD_INIT (fst mem)], loc) }
(* Semantic value is in reverse order. *)
argument_expression_list:
@@ -162,170 +166,171 @@ unary_expression:
| expr = postfix_expression
{ expr }
| loc = INC expr = unary_expression
- { (UNARY PREINCR (fst expr), loc) }
+ { (Cabs.UNARY Cabs.PREINCR (fst expr), loc) }
| loc = DEC expr = unary_expression
- { (UNARY PREDECR (fst expr), loc) }
+ { (Cabs.UNARY Cabs.PREDECR (fst expr), loc) }
| op = unary_operator expr = cast_expression
- { (UNARY (fst op) (fst expr), snd op) }
+ { (Cabs.UNARY (fst op) (fst expr), snd op) }
| loc = SIZEOF expr = unary_expression
- { (EXPR_SIZEOF (fst expr), loc) }
+ { (Cabs.EXPR_SIZEOF (fst expr), loc) }
| loc = SIZEOF LPAREN typ = type_name RPAREN
- { (TYPE_SIZEOF typ, loc) }
+ { (Cabs.TYPE_SIZEOF typ, loc) }
(* Non-standard *)
| loc = ALIGNOF LPAREN typ = type_name RPAREN
- { (ALIGNOF typ, loc) }
+ { (Cabs.ALIGNOF typ, loc) }
unary_operator:
| loc = AND
- { (ADDROF, loc) }
+ { (Cabs.ADDROF, loc) }
| loc = STAR
- { (MEMOF, loc) }
+ { (Cabs.MEMOF, loc) }
| loc = PLUS
- { (PLUS, loc) }
+ { (Cabs.PLUS, loc) }
| loc = MINUS
- { (MINUS, loc) }
+ { (Cabs.MINUS, loc) }
| loc = TILDE
- { (BNOT, loc) }
+ { (Cabs.BNOT, loc) }
| loc = BANG
- { (NOT, loc) }
+ { (Cabs.NOT, loc) }
(* 6.5.4 *)
cast_expression:
| expr = unary_expression
{ expr }
| loc = LPAREN typ = type_name RPAREN expr = cast_expression
- { (CAST typ (SINGLE_INIT (fst expr)), loc) }
+ { (Cabs.CAST typ (Cabs.SINGLE_INIT (fst expr)), loc) }
(* 6.5.5 *)
multiplicative_expression:
| expr = cast_expression
{ expr }
| expr1 = multiplicative_expression STAR expr2 = cast_expression
- { (BINARY MUL (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.MUL (fst expr1) (fst expr2), snd expr1) }
| expr1 = multiplicative_expression SLASH expr2 = cast_expression
- { (BINARY DIV (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.DIV (fst expr1) (fst expr2), snd expr1) }
| expr1 = multiplicative_expression PERCENT expr2 = cast_expression
- { (BINARY MOD (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.MOD (fst expr1) (fst expr2), snd expr1) }
(* 6.5.6 *)
additive_expression:
| expr = multiplicative_expression
{ expr }
| expr1 = additive_expression PLUS expr2 = multiplicative_expression
- { (BINARY ADD (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.ADD (fst expr1) (fst expr2), snd expr1) }
| expr1 = additive_expression MINUS expr2 = multiplicative_expression
- { (BINARY SUB (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.SUB (fst expr1) (fst expr2), snd expr1) }
(* 6.5.7 *)
shift_expression:
| expr = additive_expression
{ expr }
| expr1 = shift_expression LEFT expr2 = additive_expression
- { (BINARY SHL (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.SHL (fst expr1) (fst expr2), snd expr1) }
| expr1 = shift_expression RIGHT expr2 = additive_expression
- { (BINARY SHR (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.SHR (fst expr1) (fst expr2), snd expr1) }
(* 6.5.8 *)
relational_expression:
| expr = shift_expression
{ expr }
| expr1 = relational_expression LT expr2 = shift_expression
- { (BINARY LT (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.LT (fst expr1) (fst expr2), snd expr1) }
| expr1 = relational_expression GT expr2 = shift_expression
- { (BINARY GT (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.GT (fst expr1) (fst expr2), snd expr1) }
| expr1 = relational_expression LEQ expr2 = shift_expression
- { (BINARY LE (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.LE (fst expr1) (fst expr2), snd expr1) }
| expr1 = relational_expression GEQ expr2 = shift_expression
- { (BINARY GE (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.GE (fst expr1) (fst expr2), snd expr1) }
(* 6.5.9 *)
equality_expression:
| expr = relational_expression
{ expr }
| expr1 = equality_expression EQEQ expr2 = relational_expression
- { (BINARY EQ (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.EQ (fst expr1) (fst expr2), snd expr1) }
| expr1 = equality_expression NEQ expr2 = relational_expression
- { (BINARY NE (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.NE (fst expr1) (fst expr2), snd expr1) }
(* 6.5.10 *)
AND_expression:
| expr = equality_expression
{ expr }
| expr1 = AND_expression AND expr2 = equality_expression
- { (BINARY BAND (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.BAND (fst expr1) (fst expr2), snd expr1) }
(* 6.5.11 *)
exclusive_OR_expression:
| expr = AND_expression
{ expr }
| expr1 = exclusive_OR_expression HAT expr2 = AND_expression
- { (BINARY XOR (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.XOR (fst expr1) (fst expr2), snd expr1) }
(* 6.5.12 *)
inclusive_OR_expression:
| expr = exclusive_OR_expression
{ expr }
| expr1 = inclusive_OR_expression BAR expr2 = exclusive_OR_expression
- { (BINARY BOR (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.BOR (fst expr1) (fst expr2), snd expr1) }
(* 6.5.13 *)
logical_AND_expression:
| expr = inclusive_OR_expression
{ expr }
| expr1 = logical_AND_expression ANDAND expr2 = inclusive_OR_expression
- { (BINARY AND (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.AND (fst expr1) (fst expr2), snd expr1) }
(* 6.5.14 *)
logical_OR_expression:
| expr = logical_AND_expression
{ expr }
| expr1 = logical_OR_expression BARBAR expr2 = logical_AND_expression
- { (BINARY OR (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.OR (fst expr1) (fst expr2), snd expr1) }
(* 6.5.15 *)
conditional_expression:
| expr = logical_OR_expression
{ expr }
-| expr1 = logical_OR_expression QUESTION expr2 = expression COLON expr3 = conditional_expression
- { (QUESTION (fst expr1) (fst expr2) (fst expr3), snd expr1) }
+| expr1 = logical_OR_expression QUESTION expr2 = expression COLON
+ expr3 = conditional_expression
+ { (Cabs.QUESTION (fst expr1) (fst expr2) (fst expr3), snd expr1) }
(* 6.5.16 *)
assignment_expression:
| expr = conditional_expression
{ expr }
| expr1 = unary_expression op = assignment_operator expr2 = assignment_expression
- { (BINARY op (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY op (fst expr1) (fst expr2), snd expr1) }
assignment_operator:
| EQ
- { ASSIGN }
+ { Cabs.ASSIGN }
| MUL_ASSIGN
- { MUL_ASSIGN }
+ { Cabs.MUL_ASSIGN }
| DIV_ASSIGN
- { DIV_ASSIGN }
+ { Cabs.DIV_ASSIGN }
| MOD_ASSIGN
- { MOD_ASSIGN }
+ { Cabs.MOD_ASSIGN }
| ADD_ASSIGN
- { ADD_ASSIGN }
+ { Cabs.ADD_ASSIGN }
| SUB_ASSIGN
- { SUB_ASSIGN }
+ { Cabs.SUB_ASSIGN }
| LEFT_ASSIGN
- { SHL_ASSIGN }
+ { Cabs.SHL_ASSIGN }
| RIGHT_ASSIGN
- { SHR_ASSIGN }
+ { Cabs.SHR_ASSIGN }
| XOR_ASSIGN
- { XOR_ASSIGN }
+ { Cabs.XOR_ASSIGN }
| OR_ASSIGN
- { BOR_ASSIGN }
+ { Cabs.BOR_ASSIGN }
| AND_ASSIGN
- { BAND_ASSIGN }
+ { Cabs.BAND_ASSIGN }
(* 6.5.17 *)
expression:
| expr = assignment_expression
{ expr }
| expr1 = expression COMMA expr2 = assignment_expression
- { (BINARY COMMA (fst expr1) (fst expr2), snd expr1) }
+ { (Cabs.BINARY Cabs.COMMA (fst expr1) (fst expr2), snd expr1) }
(* 6.6 *)
constant_expression:
@@ -335,19 +340,19 @@ constant_expression:
(* 6.7 *)
declaration:
| decspec = declaration_specifiers decls = init_declarator_list SEMICOLON
- { DECDEF (fst decspec, rev' decls) (snd decspec) }
+ { Cabs.DECDEF (fst decspec, rev' decls) (snd decspec) }
| decspec = declaration_specifiers SEMICOLON
- { DECDEF (fst decspec, []) (snd decspec) }
+ { Cabs.DECDEF (fst decspec, []) (snd decspec) }
declaration_specifiers_typespec_opt:
| storage = storage_class_specifier rest = declaration_specifiers_typespec_opt
- { SpecStorage (fst storage)::rest }
+ { Cabs.SpecStorage (fst storage)::rest }
| typ = type_specifier rest = declaration_specifiers_typespec_opt
- { SpecType (fst typ)::rest }
+ { Cabs.SpecType (fst typ)::rest }
| qual = type_qualifier rest = declaration_specifiers_typespec_opt
- { SpecCV (fst qual)::rest }
+ { Cabs.SpecCV (fst qual)::rest }
| func = function_specifier rest = declaration_specifiers_typespec_opt
- { SpecFunction (fst func)::rest }
+ { Cabs.SpecFunction (fst func)::rest }
| /* empty */
{ [] }
@@ -357,16 +362,16 @@ declaration_specifiers_typespec_opt:
specifier. *)
declaration_specifiers:
| storage = storage_class_specifier rest = declaration_specifiers
- { (SpecStorage (fst storage)::fst rest, snd storage) }
+ { (Cabs.SpecStorage (fst storage)::fst rest, snd storage) }
| typ = type_specifier rest = declaration_specifiers_typespec_opt
- { (SpecType (fst typ)::rest, snd typ) }
+ { (Cabs.SpecType (fst typ)::rest, snd typ) }
(* We have to inline type_qualifier in order to avoid a conflict. *)
| qual = type_qualifier_noattr rest = declaration_specifiers
- { (SpecCV (fst qual)::fst rest, snd qual) }
+ { (Cabs.SpecCV (fst qual)::fst rest, snd qual) }
| attr = attribute_specifier rest = declaration_specifiers
- { (SpecCV (CV_ATTR (fst attr))::fst rest, snd attr) }
+ { (Cabs.SpecCV (Cabs.CV_ATTR (fst attr))::fst rest, snd attr) }
| func = function_specifier rest = declaration_specifiers
- { (SpecFunction (fst func)::fst rest, snd func) }
+ { (Cabs.SpecFunction (fst func)::fst rest, snd func) }
init_declarator_list:
| init = init_declarator
@@ -376,71 +381,71 @@ init_declarator_list:
init_declarator:
| name = declarator
- { Init_name name NO_INIT }
+ { Cabs.Init_name name Cabs.NO_INIT }
| name = declarator EQ init = c_initializer
- { Init_name name init }
+ { Cabs.Init_name name init }
(* 6.7.1 *)
storage_class_specifier:
| loc = TYPEDEF
- { (TYPEDEF, loc) }
+ { (Cabs.TYPEDEF, loc) }
| loc = EXTERN
- { (EXTERN, loc) }
+ { (Cabs.EXTERN, loc) }
| loc = STATIC
- { (STATIC, loc) }
+ { (Cabs.STATIC, loc) }
| loc = AUTO
- { (AUTO, loc) }
+ { (Cabs.AUTO, loc) }
| loc = REGISTER
- { (REGISTER, loc) }
+ { (Cabs.REGISTER, loc) }
(* 6.7.2 *)
type_specifier:
| loc = VOID
- { (Tvoid, loc) }
+ { (Cabs.Tvoid, loc) }
| loc = CHAR
- { (Tchar, loc) }
+ { (Cabs.Tchar, loc) }
| loc = SHORT
- { (Tshort, loc) }
+ { (Cabs.Tshort, loc) }
| loc = INT
- { (Tint, loc) }
+ { (Cabs.Tint, loc) }
| loc = LONG
- { (Tlong, loc) }
+ { (Cabs.Tlong, loc) }
| loc = FLOAT
- { (Tfloat, loc) }
+ { (Cabs.Tfloat, loc) }
| loc = DOUBLE
- { (Tdouble, loc) }
+ { (Cabs.Tdouble, loc) }
| loc = SIGNED
- { (Tsigned, loc) }
+ { (Cabs.Tsigned, loc) }
| loc = UNSIGNED
- { (Tunsigned, loc) }
+ { (Cabs.Tunsigned, loc) }
| loc = UNDERSCORE_BOOL
- { (T_Bool, loc) }
+ { (Cabs.T_Bool, loc) }
| spec = struct_or_union_specifier
{ spec }
| spec = enum_specifier
{ spec }
| id = TYPEDEF_NAME
- { (Tnamed (fst id), snd id) }
+ { (Cabs.Tnamed (fst id), snd id) }
(* 6.7.2.1 *)
struct_or_union_specifier:
| str_uni = struct_or_union attrs = attribute_specifier_list id = OTHER_NAME
LBRACE decls = struct_declaration_list RBRACE
- { (Tstruct_union (fst str_uni) (Some (fst id)) (Some (rev' decls)) attrs,
+ { (Cabs.Tstruct_union (fst str_uni) (Some (fst id)) (Some (rev' decls)) attrs,
snd str_uni) }
| str_uni = struct_or_union attrs = attribute_specifier_list
LBRACE decls = struct_declaration_list RBRACE
- { (Tstruct_union (fst str_uni) None (Some (rev' decls)) attrs,
+ { (Cabs.Tstruct_union (fst str_uni) None (Some (rev' decls)) attrs,
snd str_uni) }
| str_uni = struct_or_union attrs = attribute_specifier_list id = OTHER_NAME
- { (Tstruct_union (fst str_uni) (Some (fst id)) None attrs,
+ { (Cabs.Tstruct_union (fst str_uni) (Some (fst id)) None attrs,
snd str_uni) }
struct_or_union:
| loc = STRUCT
- { (STRUCT, loc) }
+ { (Cabs.STRUCT, loc) }
| loc = UNION
- { (UNION, loc) }
+ { (Cabs.UNION, loc) }
struct_declaration_list:
| (* empty *)
@@ -450,20 +455,20 @@ struct_declaration_list:
struct_declaration:
| decspec = specifier_qualifier_list decls = struct_declarator_list SEMICOLON
- { Field_group (fst decspec) (rev' decls) (snd decspec) }
+ { Cabs.Field_group (fst decspec) (rev' decls) (snd decspec) }
(* Extension to C99 grammar needed to parse some GNU header files. *)
| decspec = specifier_qualifier_list SEMICOLON
- { Field_group (fst decspec) [(None,None)] (snd decspec) }
+ { Cabs.Field_group (fst decspec) [(None,None)] (snd decspec) }
specifier_qualifier_list:
| typ = type_specifier rest = specifier_qualifier_list
- { (SpecType (fst typ)::fst rest, snd typ) }
+ { (Cabs.SpecType (fst typ)::fst rest, snd typ) }
| typ = type_specifier
- { ([SpecType (fst typ)], snd typ) }
+ { ([Cabs.SpecType (fst typ)], snd typ) }
| qual = type_qualifier rest = specifier_qualifier_list
- { (SpecCV (fst qual)::fst rest, snd qual) }
+ { (Cabs.SpecCV (fst qual)::fst rest, snd qual) }
| qual = type_qualifier
- { ([SpecCV (fst qual)], snd qual) }
+ { ([Cabs.SpecCV (fst qual)], snd qual) }
struct_declarator_list:
| decl = struct_declarator
@@ -483,18 +488,18 @@ struct_declarator:
enum_specifier:
| loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME
LBRACE enum_list = enumerator_list RBRACE
- { (Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) }
+ { (Cabs.Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) }
| loc = ENUM attrs = attribute_specifier_list
LBRACE enum_list = enumerator_list RBRACE
- { (Tenum None (Some (rev' enum_list)) attrs, loc) }
+ { (Cabs.Tenum None (Some (rev' enum_list)) attrs, loc) }
| loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME
LBRACE enum_list = enumerator_list COMMA RBRACE
- { (Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) }
+ { (Cabs.Tenum (Some (fst name)) (Some (rev' enum_list)) attrs, loc) }
| loc = ENUM attrs = attribute_specifier_list
LBRACE enum_list = enumerator_list COMMA RBRACE
- { (Tenum None (Some (rev' enum_list)) attrs, loc) }
+ { (Cabs.Tenum None (Some (rev' enum_list)) attrs, loc) }
| loc = ENUM attrs = attribute_specifier_list name = OTHER_NAME
- { (Tenum (Some (fst name)) None attrs, loc) }
+ { (Cabs.Tenum (Some (fst name)) None attrs, loc) }
enumerator_list:
| enum = enumerator
@@ -515,18 +520,18 @@ enumeration_constant:
(* 6.7.3 *)
type_qualifier_noattr:
| loc = CONST
- { (CV_CONST, loc) }
+ { (Cabs.CV_CONST, loc) }
| loc = RESTRICT
- { (CV_RESTRICT, loc) }
+ { (Cabs.CV_RESTRICT, loc) }
| loc = VOLATILE
- { (CV_VOLATILE, loc) }
+ { (Cabs.CV_VOLATILE, loc) }
type_qualifier:
| qual = type_qualifier_noattr
{ qual }
(* Non-standard *)
| attr = attribute_specifier
- { (CV_ATTR (fst attr), snd attr) }
+ { (Cabs.CV_ATTR (fst attr), snd attr) }
(* Non-standard *)
@@ -538,13 +543,13 @@ attribute_specifier_list:
attribute_specifier:
| loc = ATTRIBUTE LPAREN LPAREN attr = gcc_attribute_list RPAREN RPAREN
- { (GCC_ATTR (rev' attr) loc, loc) }
+ { (Cabs.GCC_ATTR (rev' attr) loc, loc) }
| loc = PACKED LPAREN args = argument_expression_list RPAREN
- { (PACKED_ATTR (rev' args) loc, loc) }
+ { (Cabs.PACKED_ATTR (rev' args) loc, loc) }
| loc = ALIGNAS LPAREN args = argument_expression_list RPAREN
- { (ALIGNAS_ATTR (rev' args) loc, loc) }
+ { (Cabs.ALIGNAS_ATTR (rev' args) loc, loc) }
| loc = ALIGNAS LPAREN typ = type_name RPAREN
- { (ALIGNAS_ATTR [ALIGNOF typ] loc, loc) }
+ { (Cabs.ALIGNAS_ATTR [Cabs.ALIGNOF typ] loc, loc) }
gcc_attribute_list:
| a = gcc_attribute
@@ -554,80 +559,81 @@ gcc_attribute_list:
gcc_attribute:
| /* empty */
- { GCC_ATTR_EMPTY }
+ { Cabs.GCC_ATTR_EMPTY }
| w = gcc_attribute_word
- { GCC_ATTR_NOARGS w }
+ { Cabs.GCC_ATTR_NOARGS w }
| w = gcc_attribute_word LPAREN RPAREN
- { GCC_ATTR_ARGS w [] }
+ { Cabs.GCC_ATTR_ARGS w [] }
| w = gcc_attribute_word LPAREN args = argument_expression_list RPAREN
- { GCC_ATTR_ARGS w (rev' args) }
+ { Cabs.GCC_ATTR_ARGS w (rev' args) }
gcc_attribute_word:
| i = OTHER_NAME
- { GCC_ATTR_IDENT (fst i) }
+ { Cabs.GCC_ATTR_IDENT (fst i) }
| CONST
- { GCC_ATTR_CONST }
+ { Cabs.GCC_ATTR_CONST }
| PACKED
- { GCC_ATTR_PACKED }
+ { Cabs.GCC_ATTR_PACKED }
(* 6.7.4 *)
function_specifier:
| loc = INLINE
- { (INLINE, loc) }
+ { (Cabs.INLINE, loc) }
| loc = NORETURN
- { (NORETURN, loc)}
+ { (Cabs.NORETURN, loc)}
(* 6.7.5 *)
declarator:
| decl = declarator_noattrend attrs = attribute_specifier_list
- { match decl with Name name typ attr loc =>
- Name name typ (List.app attr attrs) loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name typ (List.app attr attrs) loc }
declarator_noattrend:
| decl = direct_declarator
{ decl }
| pt = pointer decl = direct_declarator
- { match decl with Name name typ attr _ =>
- Name name ((fst pt) typ) attr (snd pt) end }
+ { let 'Cabs.Name name typ attr _ := decl in
+ Cabs.Name name ((fst pt) typ) attr (snd pt) }
direct_declarator:
| id = VAR_NAME
- { Name (fst id) JUSTBASE [] (snd id) }
+ { Cabs.Name (fst id) Cabs.JUSTBASE [] (snd id) }
| LPAREN decl = declarator RPAREN
{ decl }
-| decl = direct_declarator LBRACK quallst = type_qualifier_list expr = assignment_expression RBRACK
- { match decl with Name name typ attr loc =>
- Name name (ARRAY typ (rev' quallst) (Some (fst expr))) attr loc end }
+| decl = direct_declarator LBRACK quallst = type_qualifier_list
+ expr = assignment_expression RBRACK
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.ARRAY typ (rev' quallst) (Some (fst expr))) attr loc }
| decl = direct_declarator LBRACK expr = assignment_expression RBRACK
- { match decl with Name name typ attr loc =>
- Name name (ARRAY typ [] (Some (fst expr))) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.ARRAY typ [] (Some (fst expr))) attr loc }
| decl = direct_declarator LBRACK quallst = type_qualifier_list RBRACK
- { match decl with Name name typ attr loc =>
- Name name (ARRAY typ (rev' quallst) None) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.ARRAY typ (rev' quallst) None) attr loc }
| decl = direct_declarator LBRACK RBRACK
- { match decl with Name name typ attr loc =>
- Name name (ARRAY typ [] None) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.ARRAY typ [] None) attr loc }
(*| direct_declarator LBRACK ... STATIC ... RBRACK
| direct_declarator LBRACK STAR RBRACK*)
| decl = direct_declarator LPAREN params = parameter_type_list RPAREN
- { match decl with Name name typ attr loc =>
- Name name (PROTO typ params) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.PROTO typ params) attr loc }
| decl = direct_declarator LPAREN RPAREN
- { match decl with Name name typ attr loc =>
- Name name (PROTO_OLD typ []) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.PROTO_OLD typ []) attr loc }
| decl = direct_declarator LPAREN params = identifier_list RPAREN
- { match decl with Name name typ attr loc =>
- Name name (PROTO_OLD typ (rev' params)) attr loc end }
+ { let 'Cabs.Name name typ attr loc := decl in
+ Cabs.Name name (Cabs.PROTO_OLD typ (rev' params)) attr loc }
pointer:
| loc = STAR
- { (fun typ => PTR [] typ, loc) }
+ { (fun typ => Cabs.PTR [] typ, loc) }
| loc = STAR quallst = type_qualifier_list
- { (fun typ => PTR (rev' quallst) typ, loc) }
+ { (fun typ => Cabs.PTR (rev' quallst) typ, loc) }
| loc = STAR pt = pointer
- { (fun typ => PTR [] ((fst pt) typ), loc) }
+ { (fun typ => Cabs.PTR [] ((fst pt) typ), loc) }
| loc = STAR quallst = type_qualifier_list pt = pointer
- { (fun typ => PTR (rev' quallst) ((fst pt) typ), loc) }
+ { (fun typ => Cabs.PTR (rev' quallst) ((fst pt) typ), loc) }
type_qualifier_list:
| qual = type_qualifier
@@ -649,12 +655,12 @@ parameter_list:
parameter_declaration:
| specs = declaration_specifiers decl = declarator
- { match decl with Name name typ attr _ =>
- PARAM (fst specs) (Some name) typ attr (snd specs) end }
+ { match decl with Cabs.Name name typ attr _ =>
+ Cabs.PARAM (fst specs) (Some name) typ attr (snd specs) end }
| specs = declaration_specifiers decl = abstract_declarator
- { PARAM (fst specs) None decl [] (snd specs) }
+ { Cabs.PARAM (fst specs) None decl [] (snd specs) }
| specs = declaration_specifiers
- { PARAM (fst specs) None JUSTBASE [] (snd specs) }
+ { Cabs.PARAM (fst specs) None Cabs.JUSTBASE [] (snd specs) }
identifier_list:
| id = VAR_NAME
@@ -665,13 +671,13 @@ identifier_list:
(* 6.7.6 *)
type_name:
| specqual = specifier_qualifier_list
- { (fst specqual, JUSTBASE) }
+ { (fst specqual, Cabs.JUSTBASE) }
| specqual = specifier_qualifier_list typ = abstract_declarator
{ (fst specqual, typ) }
abstract_declarator:
| pt = pointer
- { (fst pt) JUSTBASE }
+ { (fst pt) Cabs.JUSTBASE }
| pt = pointer typ = direct_abstract_declarator
{ (fst pt) typ }
| typ = direct_abstract_declarator
@@ -680,41 +686,42 @@ abstract_declarator:
direct_abstract_declarator:
| LPAREN typ = abstract_declarator RPAREN
{ typ }
-| typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list expr = assignment_expression RBRACK
- { ARRAY typ cvspec (Some (fst expr)) }
+| typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list
+ expr = assignment_expression RBRACK
+ { Cabs.ARRAY typ cvspec (Some (fst expr)) }
| LBRACK cvspec = type_qualifier_list expr = assignment_expression RBRACK
- { ARRAY JUSTBASE cvspec (Some (fst expr)) }
+ { Cabs.ARRAY Cabs.JUSTBASE cvspec (Some (fst expr)) }
| typ = direct_abstract_declarator LBRACK expr = assignment_expression RBRACK
- { ARRAY typ [] (Some (fst expr)) }
+ { Cabs.ARRAY typ [] (Some (fst expr)) }
| LBRACK expr = assignment_expression RBRACK
- { ARRAY JUSTBASE [] (Some (fst expr)) }
+ { Cabs.ARRAY Cabs.JUSTBASE [] (Some (fst expr)) }
| typ = direct_abstract_declarator LBRACK cvspec = type_qualifier_list RBRACK
- { ARRAY typ cvspec None }
+ { Cabs.ARRAY typ cvspec None }
| LBRACK cvspec = type_qualifier_list RBRACK
- { ARRAY JUSTBASE cvspec None }
+ { Cabs.ARRAY Cabs.JUSTBASE cvspec None }
| typ = direct_abstract_declarator LBRACK RBRACK
- { ARRAY typ [] None }
+ { Cabs.ARRAY typ [] None }
| LBRACK RBRACK
- { ARRAY JUSTBASE [] None }
+ { Cabs.ARRAY Cabs.JUSTBASE [] None }
(*| direct_abstract_declarator? LBRACK STAR RBRACK*)
(*| direct_abstract_declarator? LBRACK ... STATIC ... RBRACK*)
| typ = direct_abstract_declarator LPAREN params = parameter_type_list RPAREN
- { PROTO typ params }
+ { Cabs.PROTO typ params }
| LPAREN params = parameter_type_list RPAREN
- { PROTO JUSTBASE params }
+ { Cabs.PROTO Cabs.JUSTBASE params }
| typ = direct_abstract_declarator LPAREN RPAREN
- { PROTO typ ([], false) }
+ { Cabs.PROTO typ ([], false) }
| LPAREN RPAREN
- { PROTO JUSTBASE ([], false) }
+ { Cabs.PROTO Cabs.JUSTBASE ([], false) }
(* 6.7.8 *)
c_initializer:
| expr = assignment_expression
- { SINGLE_INIT (fst expr) }
+ { Cabs.SINGLE_INIT (fst expr) }
| LBRACE init = initializer_list RBRACE
- { COMPOUND_INIT (rev' init) }
+ { Cabs.COMPOUND_INIT (rev' init) }
| LBRACE init = initializer_list COMMA RBRACE
- { COMPOUND_INIT (rev' init) }
+ { Cabs.COMPOUND_INIT (rev' init) }
initializer_list:
| design = designation init = c_initializer
@@ -738,9 +745,9 @@ designator_list:
designator:
| LBRACK expr = constant_expression RBRACK
- { ATINDEX_INIT (fst expr) }
+ { Cabs.ATINDEX_INIT (fst expr) }
| DOT id = OTHER_NAME
- { INFIELD_INIT (fst id) }
+ { Cabs.INFIELD_INIT (fst id) }
(* 6.8 *)
statement_dangerous:
@@ -768,18 +775,18 @@ statement_safe:
(* 6.8.1 *)
labeled_statement(last_statement):
| lbl = OTHER_NAME COLON stmt = last_statement
- { LABEL (fst lbl) stmt (snd lbl) }
+ { Cabs.LABEL (fst lbl) stmt (snd lbl) }
| loc = CASE expr = constant_expression COLON stmt = last_statement
- { CASE (fst expr) stmt loc }
+ { Cabs.CASE (fst expr) stmt loc }
| loc = DEFAULT COLON stmt = last_statement
- { DEFAULT stmt loc }
+ { Cabs.DEFAULT stmt loc }
(* 6.8.2 *)
compound_statement:
| loc = LBRACE lst = block_item_list RBRACE
- { BLOCK (rev' lst) loc }
+ { Cabs.BLOCK (rev' lst) loc }
| loc = LBRACE RBRACE
- { BLOCK [] loc }
+ { Cabs.BLOCK [] loc }
block_item_list:
| stmt = block_item
@@ -789,93 +796,103 @@ block_item_list:
block_item:
| decl = declaration
- { DEFINITION decl }
+ { Cabs.DEFINITION decl }
| stmt = statement_dangerous
{ stmt }
(* Non-standard *)
| p = PRAGMA
- { DEFINITION (PRAGMA (fst p) (snd p)) }
+ { Cabs.DEFINITION (Cabs.PRAGMA (fst p) (snd p)) }
(* 6.8.3 *)
expression_statement:
| expr = expression SEMICOLON
- { COMPUTATION (fst expr) (snd expr) }
+ { Cabs.COMPUTATION (fst expr) (snd expr) }
| loc = SEMICOLON
- { NOP loc }
+ { Cabs.NOP loc }
(* 6.8.4 *)
selection_statement_dangerous:
-| loc = IF LPAREN expr = expression RPAREN stmt = statement_dangerous
- { If (fst expr) stmt None loc }
-| loc = IF LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE stmt2 = statement_dangerous
- { If (fst expr) stmt1 (Some stmt2) loc }
+| loc = IF_ LPAREN expr = expression RPAREN stmt = statement_dangerous
+ { Cabs.If (fst expr) stmt None loc }
+| loc = IF_ LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE
+ stmt2 = statement_dangerous
+ { Cabs.If (fst expr) stmt1 (Some stmt2) loc }
| loc = SWITCH LPAREN expr = expression RPAREN stmt = statement_dangerous
- { SWITCH (fst expr) stmt loc }
+ { Cabs.SWITCH (fst expr) stmt loc }
selection_statement_safe:
-| loc = IF LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE stmt2 = statement_safe
- { If (fst expr) stmt1 (Some stmt2) loc }
+| loc = IF_ LPAREN expr = expression RPAREN stmt1 = statement_safe ELSE
+ stmt2 = statement_safe
+ { Cabs.If (fst expr) stmt1 (Some stmt2) loc }
| loc = SWITCH LPAREN expr = expression RPAREN stmt = statement_safe
- { SWITCH (fst expr) stmt loc }
+ { Cabs.SWITCH (fst expr) stmt loc }
(* 6.8.5 *)
iteration_statement(last_statement):
| loc = WHILE LPAREN expr = expression RPAREN stmt = last_statement
- { WHILE (fst expr) stmt loc }
+ { Cabs.WHILE (fst expr) stmt loc }
| loc = DO stmt = statement_dangerous WHILE LPAREN expr = expression RPAREN SEMICOLON
- { DOWHILE (fst expr) stmt loc }
-| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR (Some (FC_EXP (fst expr1))) (Some (fst expr2)) (Some (fst expr3)) stmt loc }
-| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR (Some (FC_DECL decl1)) (Some (fst expr2)) (Some (fst expr3)) stmt loc }
-| loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR None (Some (fst expr2)) (Some (fst expr3)) stmt loc }
-| loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR (Some (FC_EXP (fst expr1))) None (Some (fst expr3)) stmt loc }
-| loc = FOR LPAREN decl1 = declaration SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR (Some (FC_DECL decl1)) None (Some (fst expr3)) stmt loc }
+ { Cabs.DOWHILE (fst expr) stmt loc }
+| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON
+ expr3 = expression RPAREN stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) (Some (fst expr2)) (Some (fst expr3)) stmt loc }
+| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON
+ expr3 = expression RPAREN stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_DECL decl1)) (Some (fst expr2)) (Some (fst expr3)) stmt loc }
+| loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON expr3 = expression RPAREN
+ stmt = last_statement
+ { Cabs.FOR None (Some (fst expr2)) (Some (fst expr3)) stmt loc }
+| loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON expr3 = expression RPAREN
+ stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) None (Some (fst expr3)) stmt loc }
+| loc = FOR LPAREN decl1 = declaration SEMICOLON expr3 = expression RPAREN
+ stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_DECL decl1)) None (Some (fst expr3)) stmt loc }
| loc = FOR LPAREN SEMICOLON SEMICOLON expr3 = expression RPAREN stmt = last_statement
- { FOR None None (Some (fst expr3)) stmt loc }
-| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON RPAREN stmt = last_statement
- { FOR (Some (FC_EXP (fst expr1))) (Some (fst expr2)) None stmt loc }
-| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON RPAREN stmt = last_statement
- { FOR (Some (FC_DECL decl1)) (Some (fst expr2)) None stmt loc }
+ { Cabs.FOR None None (Some (fst expr3)) stmt loc }
+| loc = FOR LPAREN expr1 = expression SEMICOLON expr2 = expression SEMICOLON RPAREN
+ stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) (Some (fst expr2)) None stmt loc }
+| loc = FOR LPAREN decl1 = declaration expr2 = expression SEMICOLON RPAREN
+ stmt = last_statement
+ { Cabs.FOR (Some (Cabs.FC_DECL decl1)) (Some (fst expr2)) None stmt loc }
| loc = FOR LPAREN SEMICOLON expr2 = expression SEMICOLON RPAREN stmt = last_statement
- { FOR None (Some (fst expr2)) None stmt loc }
+ { Cabs.FOR None (Some (fst expr2)) None stmt loc }
| loc = FOR LPAREN expr1 = expression SEMICOLON SEMICOLON RPAREN stmt = last_statement
- { FOR (Some (FC_EXP (fst expr1))) None None stmt loc }
+ { Cabs.FOR (Some (Cabs.FC_EXP (fst expr1))) None None stmt loc }
| loc = FOR LPAREN decl1 = declaration SEMICOLON RPAREN stmt = last_statement
- { FOR (Some (FC_DECL decl1)) None None stmt loc }
+ { Cabs.FOR (Some (Cabs.FC_DECL decl1)) None None stmt loc }
| loc = FOR LPAREN SEMICOLON SEMICOLON RPAREN stmt = last_statement
- { FOR None None None stmt loc }
+ { Cabs.FOR None None None stmt loc }
(* 6.8.6 *)
jump_statement:
| loc = GOTO id = OTHER_NAME SEMICOLON
- { GOTO (fst id) loc }
+ { Cabs.GOTO (fst id) loc }
| loc = CONTINUE SEMICOLON
- { CONTINUE loc }
+ { Cabs.CONTINUE loc }
| loc = BREAK SEMICOLON
- { BREAK loc }
+ { Cabs.BREAK loc }
| loc = RETURN expr = expression SEMICOLON
- { RETURN (Some (fst expr)) loc }
+ { Cabs.RETURN (Some (fst expr)) loc }
| loc = RETURN SEMICOLON
- { RETURN None loc }
+ { Cabs.RETURN None loc }
(* Non-standard *)
asm_statement:
-| loc = ASM attr = asm_attributes LPAREN template = STRING_LITERAL args = asm_arguments RPAREN SEMICOLON
+| loc = ASM attr = asm_attributes LPAREN template = STRING_LITERAL args = asm_arguments
+ RPAREN SEMICOLON
{ let '(wide, chars, _) := template in
let '(outputs, inputs, flags) := args in
- ASM attr wide chars outputs inputs flags loc }
+ Cabs.ASM attr wide chars outputs inputs flags loc }
asm_attributes:
| /* empty */
{ [] }
| CONST attr = asm_attributes
- { CV_CONST :: attr }
+ { Cabs.CV_CONST :: attr }
| VOLATILE attr = asm_attributes
- { CV_VOLATILE :: attr }
+ { Cabs.CV_VOLATILE :: attr }
asm_arguments:
| /* empty */
@@ -897,7 +914,7 @@ asm_operands_ne:
asm_operand:
| n = asm_op_name cstr = STRING_LITERAL LPAREN e = expression RPAREN
- { let '(wide, s, loc) := cstr in ASMOPERAND n wide s (fst e) }
+ { let '(wide, s, loc) := cstr in Cabs.ASMOPERAND n wide s (fst e) }
asm_op_name:
| /* empty */ { None }
@@ -934,7 +951,7 @@ external_declaration:
{ def }
(* Non-standard *)
| p = PRAGMA
- { PRAGMA (fst p) (snd p) }
+ { Cabs.PRAGMA (fst p) (snd p) }
(* 6.9.1 *)
@@ -943,11 +960,11 @@ function_definition:
decl = declarator_noattrend
dlist = declaration_list
stmt = compound_statement
- { FUNDEF (fst specs) decl (List.rev' dlist) stmt (snd specs) }
+ { Cabs.FUNDEF (fst specs) decl (List.rev' dlist) stmt (snd specs) }
| specs = declaration_specifiers
decl = declarator
stmt = compound_statement
- { FUNDEF (fst specs) decl [] stmt (snd specs) }
+ { Cabs.FUNDEF (fst specs) decl [] stmt (snd specs) }
declaration_list:
| d = declaration
diff --git a/cparser/Rename.ml b/cparser/Rename.ml
index eb31eaf0..64412194 100644
--- a/cparser/Rename.ml
+++ b/cparser/Rename.ml
@@ -246,7 +246,7 @@ let rec globdecls env accu = function
(* Reserve names of builtins *)
let reserve_builtins () =
- List.fold_left enter_public empty_env (Builtins.identifiers())
+ List.fold_left enter_public empty_env (Env.initial_identifiers())
(* Reserve global declarations with public visibility *)
diff --git a/cparser/StructPassing.ml b/cparser/StructPassing.ml
index 5c6454f0..3aff090e 100644
--- a/cparser/StructPassing.ml
+++ b/cparser/StructPassing.ml
@@ -68,7 +68,16 @@ let classify_param env ty =
match !struct_passing_style with
| SP_ref_callee -> Param_unchanged
| SP_ref_caller -> Param_ref_caller
- | _ ->
+ | SP_value32_ref_callee ->
+ (match sizeof env ty, alignof env ty with
+ | Some sz, Some al ->
+ if (sz <= 4) then
+ Param_flattened ((sz+3)/4, sz, al) (* FIXME - why (sz+3)/4 ? *)
+ else
+ Param_unchanged
+ | _, _ -> Param_unchanged (* when parsing prototype with incomplete structure definition *)
+ )
+ | SP_split_args ->
match sizeof env ty, alignof env ty with
| Some sz, Some al ->
Param_flattened ((sz + 3) / 4, sz, al)
diff --git a/cparser/Transform.ml b/cparser/Transform.ml
index 0a2ce3bb..349a3155 100644
--- a/cparser/Transform.ml
+++ b/cparser/Transform.ml
@@ -227,4 +227,4 @@ let program
in
transf_globdecls env' ({g with gdesc = desc'} :: accu) gl
- in transf_globdecls (Builtins.environment()) [] p
+ in transf_globdecls (Env.initial()) [] p
diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml
index da8049a5..d25f70c6 100644
--- a/cparser/Unblock.ml
+++ b/cparser/Unblock.ml
@@ -340,7 +340,6 @@ and unblock_block env ctx ploc = function
let unblock_fundef env f =
local_variables := [];
- next_scope_id := 0;
curr_fun_id:= f.fd_name.stamp;
(* TODO: register the parameters as being declared in function scope *)
let body = unblock_stmt env [] no_loc f.fd_body in
@@ -398,5 +397,6 @@ let rec unblock_glob env accu = function
(* Entry point *)
let program p =
+ next_scope_id := 0;
{gloc = no_loc; gdesc = Gdecl(Storage_extern, debug_id, debug_ty, None)} ::
- unblock_glob (Builtins.environment()) [] p
+ unblock_glob (Env.initial()) [] p
diff --git a/cparser/handcrafted.messages b/cparser/handcrafted.messages
index 95077739..6d972439 100644
--- a/cparser/handcrafted.messages
+++ b/cparser/handcrafted.messages
@@ -4477,7 +4477,7 @@ translation_unit_file: VOID PRE_NAME TYPEDEF_NAME PACKED LPAREN CONSTANT RPAREN
##
# We have just parsed a list of attribute specifiers, but we cannot
-# print it because it is not available. We do not know wether it is
+# print it because it is not available. We do not know whether it is
# part of the declaration or whether it is part of the first K&R parameter
# declaration.
@@ -4599,7 +4599,7 @@ translation_unit_file: PACKED LPAREN BUILTIN_OFFSETOF XOR_ASSIGN
##
Ill-formed __builtin_offsetof.
-At this point, an opening paranthesis '(' is expected.
+At this point, an opening parenthesis '(' is expected.
#------------------------------------------------------------------------------
diff --git a/cparser/pre_parser.mly b/cparser/pre_parser.mly
index 71eaf419..669ecf5e 100644
--- a/cparser/pre_parser.mly
+++ b/cparser/pre_parser.mly
@@ -43,13 +43,13 @@
%}
%token<string> PRE_NAME
-%token<string * Pre_parser_aux.identifier_type ref * Cabs.cabsloc>
+%token<string * Pre_parser_aux.identifier_type ref * Cabs.loc>
VAR_NAME TYPEDEF_NAME
-%token<Cabs.constant * Cabs.cabsloc> CONSTANT
-%token<bool * int64 list * Cabs.cabsloc> STRING_LITERAL
-%token<string * Cabs.cabsloc> PRAGMA
+%token<Cabs.constant * Cabs.loc> CONSTANT
+%token<bool * int64 list * Cabs.loc> STRING_LITERAL
+%token<string * Cabs.loc> PRAGMA
-%token<Cabs.cabsloc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT
+%token<Cabs.loc> SIZEOF PTR INC DEC LEFT RIGHT LEQ GEQ EQEQ EQ NEQ LT GT
ANDAND BARBAR PLUS MINUS STAR TILDE BANG SLASH PERCENT HAT BAR QUESTION
COLON AND MUL_ASSIGN DIV_ASSIGN MOD_ASSIGN ADD_ASSIGN SUB_ASSIGN LEFT_ASSIGN
RIGHT_ASSIGN AND_ASSIGN XOR_ASSIGN OR_ASSIGN LPAREN RPAREN LBRACK RBRACK
diff --git a/debug/Debug.ml b/debug/Debug.ml
index 168df5a0..812f57cc 100644
--- a/debug/Debug.ml
+++ b/debug/Debug.ml
@@ -47,7 +47,7 @@ type implem =
exists_section: section_name -> bool;
remove_unused: ident -> unit;
remove_unused_function: ident -> unit;
- variable_printed: string -> unit;
+ symbol_printed: string -> unit;
add_diab_info: section_name -> int -> int -> int -> unit;
}
@@ -79,7 +79,7 @@ let default_implem =
exists_section = (fun _ -> true);
remove_unused = (fun _ -> ());
remove_unused_function = (fun _ -> ());
- variable_printed = (fun _ -> ());
+ symbol_printed = (fun _ -> ());
add_diab_info = (fun _ _ _ _ -> ());
}
@@ -111,5 +111,5 @@ let compute_diab_file_enum end_l entry_l line_e = !implem.compute_diab_file_enum
let compute_gnu_file_enum f = !implem.compute_gnu_file_enum f
let remove_unused ident = !implem.remove_unused ident
let remove_unused_function ident = !implem.remove_unused_function ident
-let variable_printed ident = !implem.variable_printed ident
+let symbol_printed ident = !implem.symbol_printed ident
let add_diab_info sec line_start debug_info low_pc = !implem.add_diab_info sec line_start debug_info low_pc
diff --git a/debug/Debug.mli b/debug/Debug.mli
index 3869a056..60e2f9bc 100644
--- a/debug/Debug.mli
+++ b/debug/Debug.mli
@@ -46,7 +46,7 @@ type implem =
exists_section: section_name -> bool;
remove_unused: ident -> unit;
remove_unused_function: ident -> unit;
- variable_printed: string -> unit;
+ symbol_printed: string -> unit;
add_diab_info: section_name -> int -> int -> int -> unit;
}
@@ -80,5 +80,5 @@ val compute_gnu_file_enum: (string -> unit) -> unit
val exists_section: section_name -> bool
val remove_unused: ident -> unit
val remove_unused_function: ident -> unit
-val variable_printed: string -> unit
+val symbol_printed: string -> unit
val add_diab_info: section_name -> int -> int -> int -> unit
diff --git a/debug/DebugInformation.ml b/debug/DebugInformation.ml
index e3f5d98e..f9684355 100644
--- a/debug/DebugInformation.ml
+++ b/debug/DebugInformation.ml
@@ -123,7 +123,7 @@ let insert_type ty =
| TNamed (id,_) ->
let typ = try
let _,t =
- List.find (fun a -> fst a = id.name) CBuiltins.builtins.Builtins.typedefs in
+ List.find (fun a -> fst a = id.name) CBuiltins.builtins.builtin_typedefs in
Some (attr_aux t)
with Not_found -> None in
let t = {
@@ -223,7 +223,7 @@ let name_to_definition: (string,int) Hashtbl.t = Hashtbl.create 7
(* Mapping from atom to debug id *)
let atom_to_definition: (atom, int) Hashtbl.t = Hashtbl.create 7
-(* Various lookup functions for defintions *)
+(* Various lookup functions for definitions *)
let find_gvar_stamp id =
let id = (Hashtbl.find stamp_to_definition id) in
let var = Hashtbl.find definitions id in
@@ -342,7 +342,7 @@ let insert_global_declaration env dec =
replace_var id ({var with gvar_declaration = false;})
end
end else begin
- (* Implict declarations need special handling *)
+ (* Implicit declarations need special handling *)
let id' = try Hashtbl.find name_to_definition id.name with Not_found ->
let id' = next_id () in
Hashtbl.add name_to_definition id.name id';id' in
@@ -553,7 +553,10 @@ let close_scope atom s_id lbl =
| a::rest -> a,rest
| _ -> assert false (* We must have an opening scope *)
end in
- let new_r = ({last_r with end_addr = Some lbl;})::rest in
+ let new_r = if last_r.start_addr = Some lbl then
+ rest
+ else
+ ({last_r with end_addr = Some lbl;})::rest in
Hashtbl.replace scope_ranges s_id new_r
with Not_found -> ()
@@ -632,12 +635,12 @@ let compute_gnu_file_enum f =
let all_files_iter f = StringSet.iter f !all_files
-let printed_vars: StringSet.t ref = ref StringSet.empty
+let printed_symbols: StringSet.t ref = ref StringSet.empty
-let is_variable_printed id = StringSet.mem id !printed_vars
+let is_symbol_printed id = StringSet.mem id !printed_symbols
-let variable_printed id =
- printed_vars := StringSet.add id !printed_vars
+let symbol_printed id =
+ printed_symbols := StringSet.add id !printed_symbols
let init name =
id := 0;
@@ -660,7 +663,7 @@ let init name =
Hashtbl.reset scope_ranges;
Hashtbl.reset label_translation;
all_files := StringSet.singleton name;
- printed_vars := StringSet.empty
+ printed_symbols := StringSet.empty
let default_debug =
{
@@ -690,6 +693,6 @@ let default_debug =
exists_section = exists_section;
remove_unused = remove_unused;
remove_unused_function = remove_unused_function;
- variable_printed = variable_printed;
+ symbol_printed = symbol_printed;
add_diab_info = (fun _ _ _ _ -> ());
}
diff --git a/debug/DebugInformation.mli b/debug/DebugInformation.mli
index 8905d8bf..0cf34756 100644
--- a/debug/DebugInformation.mli
+++ b/debug/DebugInformation.mli
@@ -23,7 +23,7 @@ val get_type: int -> debug_types
val fold_types: (int -> debug_types -> 'a -> 'a) -> 'a -> 'a
-val is_variable_printed: string -> bool
+val is_symbol_printed: string -> bool
val variable_location: atom -> atom -> var_location
diff --git a/debug/DwarfPrinter.ml b/debug/DwarfPrinter.ml
index a45fff0c..2cb8c7d9 100644
--- a/debug/DwarfPrinter.ml
+++ b/debug/DwarfPrinter.ml
@@ -241,9 +241,12 @@ module DwarfPrinter(Target: DWARF_TARGET):
let abbrev = !curr_abbrev in
incr curr_abbrev;abbrev
- (* Mapping from abbreviation string to abbreviaton id *)
+ (* Mapping from abbreviation string to abbreviation id *)
let abbrev_mapping: (string,int) Hashtbl.t = Hashtbl.create 7
+ (* Mapping from abbreviation range id to label *)
+ let range_labels : (int, int) Hashtbl.t = Hashtbl.create 7
+
(* Look up the id of the abbreviation and add it if it is missing *)
let get_abbrev entity has_sibling =
let abbrev_string = abbrev_string_of_entity entity has_sibling in
@@ -265,7 +268,7 @@ module DwarfPrinter(Target: DWARF_TARGET):
(* Print the debug_abbrev section using the previous computed abbreviations*)
let print_abbrev oc =
let abbrevs = Hashtbl.fold (fun s i acc -> (s,i)::acc) abbrev_mapping [] in
- let abbrevs = List.sort (fun (_,a) (_,b) -> Pervasives.compare a b) abbrevs in
+ let abbrevs = List.sort (fun (_,a) (_,b) -> compare a b) abbrevs in
section oc Section_debug_abbrev;
print_label oc !abbrev_start_addr;
List.iter (fun (s,id) ->
@@ -439,8 +442,11 @@ module DwarfPrinter(Target: DWARF_TARGET):
| Pc_pair (l,h) ->
print_addr oc "DW_AT_low_pc" l;
print_addr oc "DW_AT_high_pc" h
- | Offset i -> fprintf oc " .4byte %a+0x%d%a\n"
- label !debug_ranges_addr i print_comment "DW_AT_ranges"
+ | Offset i ->
+ let lbl = new_label () in
+ Hashtbl.add range_labels i lbl;
+ fprintf oc " .4byte %a%a\n"
+ label lbl print_comment "DW_AT_ranges"
| _ -> ()
let print_compilation_unit oc tag =
@@ -596,8 +602,13 @@ module DwarfPrinter(Target: DWARF_TARGET):
print_sleb128 oc "" 0;
print_label oc debug_end (* End of the debug section *)
- let print_location_entry oc c_low l =
+ let print_location_entry oc needs_base c_low l =
print_label oc (loc_to_label l.loc_id);
+ (* If we have multiple ranges per compilation unit we need to specify a base address for the location *)
+ if needs_base then begin
+ fprintf oc " %s -1\n" address;
+ fprintf oc " %s %a\n" address label c_low;
+ end;
List.iter (fun (b,e,loc) ->
fprintf oc " %s %a-%a\n" address label b label c_low;
fprintf oc " %s %a-%a\n" address label e label c_low;
@@ -615,11 +626,11 @@ module DwarfPrinter(Target: DWARF_TARGET):
fprintf oc " %s 0\n" address
- let print_location_list oc (c_low,l) =
- let f = match c_low with
- | Some s -> print_location_entry oc s
- | None -> print_location_entry_abs oc in
- List.iter f l
+ let print_location_list oc needs_base l =
+ let f l = match l.loc_sec_begin with
+ | Some s -> print_location_entry oc needs_base s l
+ | None -> print_location_entry_abs oc l in
+ List.iter f l
let list_opt l f =
match l with
@@ -629,29 +640,38 @@ module DwarfPrinter(Target: DWARF_TARGET):
let print_diab_entries oc entries =
let abbrev_start = new_label () in
abbrev_start_addr := abbrev_start;
- List.iter (fun e -> compute_abbrev e.entry) entries;
+ List.iter (fun e -> compute_abbrev e.diab_entry) entries;
print_abbrev oc;
List.iter (fun e ->
let name = if e.section_name <> ".text" then Some e.section_name else None in
section oc (Section_debug_info name);
- print_debug_info oc e.start_label e.line_label e.entry) entries;
- if List.exists (fun e -> match e.dlocs with _,[] -> false | _,_ -> true) entries then begin
+ print_debug_info oc e.start_label e.line_label e.diab_entry) entries;
+ if List.exists (fun e -> match e.diab_locs with [] -> false | _ -> true) entries then begin
section oc Section_debug_loc;
- List.iter (fun e -> print_location_list oc e.dlocs) entries
+ List.iter (fun e -> print_location_list oc false e.diab_locs) entries
end
let print_ranges oc r =
+ let print_range_entry = function
+ | AddressRange l ->
+ List.iter (fun (b,e) ->
+ fprintf oc " %s %a\n" address label b;
+ fprintf oc " %s %a\n" address label e) l;
+ | OffsetRange (start, l) ->
+ List.iter (fun (b,e) ->
+ fprintf oc " %s %a-%a\n" address label b label start;
+ fprintf oc " %s %a-%a\n" address label e label start) l
+ in
section oc Section_debug_ranges;
print_label oc !debug_ranges_addr;
- List.iter (fun l ->
- List.iter (fun (b,e) ->
- fprintf oc " %s %a\n" address label b;
- fprintf oc " %s %a\n" address label e) l;
- fprintf oc " %s 0\n" address;
- fprintf oc " %s 0\n" address) r
-
- let print_gnu_entries oc cp (lpc,loc) s r =
- compute_abbrev cp;
+ List.iter (fun (lbl,l) ->
+ print_label oc (Hashtbl.find range_labels lbl);
+ print_range_entry l;
+ fprintf oc " %s 0\n" address;
+ fprintf oc " %s 0\n" address) r
+
+ let print_gnu_entries oc entries =
+ compute_abbrev entries.gnu_entry;
let line_start = new_label ()
and start = new_label ()
and abbrev_start = new_label ()
@@ -659,18 +679,18 @@ module DwarfPrinter(Target: DWARF_TARGET):
debug_ranges_addr := range_label;
abbrev_start_addr := abbrev_start;
section oc (Section_debug_info None);
- print_debug_info oc start line_start cp;
+ print_debug_info oc start line_start entries.gnu_entry;
print_abbrev oc;
- list_opt loc (fun () ->
+ list_opt entries.gnu_locs (fun () ->
section oc Section_debug_loc;
- print_location_list oc (lpc,loc));
- list_opt r (fun () ->
- print_ranges oc r);
+ print_location_list oc entries.several_secs entries.gnu_locs);
+ list_opt entries.range_table (fun () ->
+ print_ranges oc entries.range_table);
section oc (Section_debug_line None);
print_label oc line_start;
- list_opt s (fun () ->
+ list_opt entries.string_table (fun () ->
section oc Section_debug_str;
- let s = List.sort (fun (a,_) (b,_) -> Pervasives.compare a b) s in
+ let s = List.sort (fun (a,_) (b,_) -> compare a b) entries.string_table in
List.iter (fun (id,s) ->
print_label oc (loc_to_label id);
fprintf oc " .asciz %S\n" s) s)
@@ -679,9 +699,10 @@ module DwarfPrinter(Target: DWARF_TARGET):
(* Print the debug info and abbrev section *)
let print_debug oc debug =
Hashtbl.clear abbrev_mapping;
+ Hashtbl.clear range_labels;
Hashtbl.clear loc_labels;
match debug with
| Diab entries -> print_diab_entries oc entries
- | Gnu (cp,loc,s,r) -> print_gnu_entries oc cp loc s r
+ | Gnu entries -> print_gnu_entries oc entries
end
diff --git a/debug/DwarfPrinter.mli b/debug/DwarfPrinter.mli
index e1e10601..78dc05fb 100644
--- a/debug/DwarfPrinter.mli
+++ b/debug/DwarfPrinter.mli
@@ -12,7 +12,7 @@
open DwarfTypes
-module DwarfPrinter: functor (Target: DWARF_TARGET) ->
+module DwarfPrinter: DWARF_TARGET ->
sig
val print_debug: out_channel -> debug_entries -> unit
end
diff --git a/debug/DwarfTypes.mli b/debug/DwarfTypes.mli
index 23aba448..567c65cd 100644
--- a/debug/DwarfTypes.mli
+++ b/debug/DwarfTypes.mli
@@ -266,15 +266,19 @@ type dw_entry =
(* The type for the location list. *)
type location_entry =
- {
- loc: (address * address * location_value) list;
- loc_id: reference;
- }
-type dw_locations = constant option * location_entry list
+ {
+ loc: (address * address * location_value) list;
+ loc_id: reference;
+ loc_sec_begin : address option;
+ }
+
+type dw_locations = location_entry list
-type range_entry = (address * address) list
+type range_entry =
+ | AddressRange of (address * address) list
+ | OffsetRange of reference * (address * address) list
-type dw_ranges = range_entry list
+type dw_ranges = (int * range_entry) list
type dw_string = (int * string) list
@@ -283,13 +287,20 @@ type diab_entry =
section_name: string;
start_label: int;
line_label: int;
- entry: dw_entry;
- dlocs: dw_locations;
+ diab_entry: dw_entry;
+ diab_locs: dw_locations;
}
type diab_entries = diab_entry list
-type gnu_entries = dw_entry * dw_locations * dw_string * dw_ranges
+type gnu_entries =
+ {
+ string_table: dw_string;
+ range_table: dw_ranges;
+ gnu_locs: dw_locations;
+ gnu_entry: dw_entry;
+ several_secs: bool;
+ }
type debug_entries =
| Diab of diab_entries
diff --git a/debug/Dwarfgen.ml b/debug/Dwarfgen.ml
index ee568042..6c1d0846 100644
--- a/debug/Dwarfgen.ml
+++ b/debug/Dwarfgen.ml
@@ -72,7 +72,9 @@ let up_locs acc loc =
{acc with locs = loc@acc.locs;}
let up_ranges acc r =
- {acc with ranges = r;}
+ let off, old_r = acc.ranges in
+ let new_r = (off +1 ), (off, r):: old_r in
+ (Offset off), {acc with ranges = new_r;}
let empty_accu =
{
@@ -90,6 +92,8 @@ module Dwarfgenaux (Target: TARGET) =
let subrange_type : int option ref = ref None
+ let current_section_start : int option ref = ref None
+
let encoding_of_ikind = function
| IBool -> DW_ATE_boolean
| IChar ->
@@ -340,7 +344,7 @@ module Dwarfgenaux (Target: TARGET) =
let global_variable_to_entry acc id v =
let loc = match v.gvar_atom with
- | Some a when is_variable_printed (extern_atom a) ->
+ | Some a when is_symbol_printed (extern_atom a) ->
Some (LocSymbol a)
| _ -> None in
let var = {
@@ -404,7 +408,7 @@ module Dwarfgenaux (Target: TARGET) =
and lo = translate_label f_id lo in
hi,lo,range_entry_loc i.var_loc) l in
let id = next_id () in
- Some (LocRef id),[{loc = l;loc_id = id;}]
+ Some (LocRef id),[{loc_sec_begin = !current_section_start; loc = l;loc_id = id;}]
end
with Not_found -> None,[]
else
@@ -424,7 +428,7 @@ module Dwarfgenaux (Target: TARGET) =
let acc = up_locs (up_typs acc p.formal_parameter_type) loc_list in
new_entry (next_id ()) (DW_TAG_formal_parameter p),acc
- let scope_range f_id id (o,dwr) =
+ let scope_range f_id id acc =
try
let r = get_scope_ranges id in
let lbl l h = match l,h with
@@ -435,19 +439,22 @@ module Dwarfgenaux (Target: TARGET) =
| _ -> raise Not_found in
begin
match r with
- | [] -> Empty,(o,dwr)
+ | [] -> Empty,acc
| [a] ->
let l,h = lbl a.start_addr a.end_addr in
- Pc_pair (l,h),(o,dwr)
+ Pc_pair (l,h), acc
| a::rest ->
if !Clflags.option_gdwarf > 2 then
let r = List.map (fun e -> lbl e.start_addr e.end_addr) r in
- (Offset o), (o + 2 + 4 * (List.length r),r::dwr)
- else
+ let r = match !current_section_start with
+ | None -> AddressRange r
+ | Some s -> OffsetRange (s, r) in
+ up_ranges acc r
+ else
let l,h = lbl (List.hd (List.rev rest)).start_addr a.end_addr in
- Pc_pair (l,h),(o,dwr)
+ Pc_pair (l,h), acc
end
- with Not_found -> Empty,(o,dwr)
+ with Not_found -> Empty, acc
let rec local_variable_to_entry f_id acc v id =
match v.lvar_atom with
@@ -466,11 +473,10 @@ module Dwarfgenaux (Target: TARGET) =
Some (new_entry id (DW_TAG_variable var)),acc
and scope_to_entry f_id acc sc id =
- let r,dwr = scope_range f_id id acc.ranges in
+ let r, acc = scope_range f_id id acc in
let scope = {
lexical_block_range = r;
} in
- let acc = up_ranges acc dwr in
let vars,acc = mmap_opt (local_to_entry f_id) acc sc.scope_variables in
let entry = new_entry id (DW_TAG_lexical_block scope) in
add_children entry vars,acc
@@ -490,7 +496,7 @@ module Dwarfgenaux (Target: TARGET) =
| Scope sc -> mmap_opt (local_to_entry f_id) acc sc.scope_variables
| _ -> assert false)
- let function_to_entry acc id f =
+ let function_to_entry sec_name acc id f =
let r = match f.fun_low_pc, f.fun_high_pc with
| Some l,Some h -> Pc_pair (l,h)
| _ -> Empty in
@@ -503,8 +509,13 @@ module Dwarfgenaux (Target: TARGET) =
subprogram_range = r;
} in
let f_id = get_opt_val f.fun_atom in
+ let start_sec =
+ try
+ Some (section_start (sec_name f_id))
+ with Not_found -> None in
+ current_section_start := start_sec;
let acc = match f.fun_return_type with Some s -> up_typs acc s | None -> acc in
- let f_entry = new_entry id (DW_TAG_subprogram f_tag) in
+ let f_entry = new_entry id (DW_TAG_subprogram f_tag) in
let children,acc =
if !Clflags.option_gdepth > 1 then
let params,acc = mmap (function_parameter_to_entry f_id) acc f.fun_parameter in
@@ -514,10 +525,14 @@ module Dwarfgenaux (Target: TARGET) =
[],acc in
add_children f_entry (children),acc
- let definition_to_entry acc id t =
+ let definition_to_entry sec_name acc id t =
match t with
- | GlobalVariable g -> global_variable_to_entry acc id g
- | Function f -> function_to_entry acc id f
+ | GlobalVariable g -> Some (global_variable_to_entry acc id g)
+ | Function f ->
+ if is_symbol_printed f.fun_name then
+ Some (function_to_entry sec_name acc id f)
+ else
+ None
end
@@ -529,20 +544,21 @@ let diab_file_loc sec (f,l) =
let prod_name =
let version_string =
if Version.buildnr <> "" && Version.tag <> "" then
- Printf.sprintf "%s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
+ Printf.sprintf "Release: %s, Build: %s, Tag: %s" Version.version Version.buildnr Version.tag
else
Version.version in
Printf.sprintf "AbsInt Angewandte Informatik GmbH:CompCert Version %s:(%s,%s,%s,%s)"
version_string Configuration.arch Configuration.system Configuration.abi Configuration.model
-let diab_gen_compilation_section s defs acc =
+let diab_gen_compilation_section sec_name s defs acc =
let module Gen = Dwarfgenaux(struct
let file_loc = diab_file_loc s
let string_entry s = Simple_string s
end) in
let defs,accu = List.fold_left (fun (acc,bcc) (id,t) ->
- let t,bcc = Gen.definition_to_entry bcc id t in
- t::acc,bcc) ([],empty_accu) defs in
+ match Gen.definition_to_entry sec_name bcc id t with
+ | Some (t,bcc) -> t::acc,bcc
+ | None -> acc,bcc) ([],empty_accu) defs in
let low_pc = section_start s
and line_start,debug_start = diab_additional_section s
and high_pc = section_end s in
@@ -558,8 +574,8 @@ let diab_gen_compilation_section s defs acc =
section_name = s;
start_label = debug_start;
line_label = line_start;
- entry = cp;
- dlocs = Some low_pc,accu.locs;
+ diab_entry = cp;
+ diab_locs = accu.locs;
}::acc
let gen_diab_debug_info sec_name var_section : debug_entries =
@@ -569,7 +585,7 @@ let gen_diab_debug_info sec_name var_section : debug_entries =
| Function f -> sec_name (get_opt_val f.fun_atom) in
let old = try StringMap.find s acc with Not_found -> [] in
StringMap.add s ((id,t)::old) acc) StringMap.empty in
- let entries = StringMap.fold diab_gen_compilation_section defs [] in
+ let entries = StringMap.fold (diab_gen_compilation_section sec_name) defs [] in
Diab entries
let gnu_file_loc (f,l) =
@@ -579,7 +595,7 @@ let string_table: (string,int) Hashtbl.t = Hashtbl.create 7
let gnu_string_entry s =
if (String.length s < 4 && Configuration.system <> "macosx") (* macosx needs debug_str *)
- || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str seciton*)
+ || Configuration.system = "cygwin" then (*Cygwin does not use the debug_str section*)
Simple_string s
else
try
@@ -592,30 +608,32 @@ let gnu_string_entry s =
let gen_gnu_debug_info sec_name var_section : debug_entries =
Hashtbl.clear string_table;
- let r,dwr,low_pc =
- try if !Clflags.option_gdwarf > 3 then
+ let r,accu,low_pc =
+ try if !Clflags.option_gdwarf > 2 then
let pcs = fold_section_start (fun s low acc ->
(low,section_end s)::acc) [] in
match pcs with
- | [] -> Empty,(0,[]),None
- | [(l,h)] -> Pc_pair (l,h),(0,[]),Some l
- | _ -> Offset 0,(2 + 4 * (List.length pcs),[pcs]),None
+ | [] -> Empty, empty_accu, None
+ | [(l,h)] -> Pc_pair (l,h), empty_accu, Some l
+ | _ ->
+ let off, acc = up_ranges empty_accu (AddressRange pcs) in
+ off, acc, None
else
let l = section_start ".text"
and h = section_end ".text" in
- Pc_pair(l,h),(0,[]),Some l
- with Not_found -> Empty,(0,[]),None in
- let accu = up_ranges empty_accu dwr in
+ Pc_pair(l,h), empty_accu,Some l
+ with Not_found -> Empty ,empty_accu, None in
let module Gen = Dwarfgenaux (struct
let file_loc = gnu_file_loc
let string_entry = gnu_string_entry
end) in
- let defs,accu,sec = fold_definitions (fun id t (acc,bcc,sec) ->
+ let defs,accu,sec = fold_definitions (fun id t (acc,bcc,sec) ->
let s = match t with
| GlobalVariable _ -> var_section
| Function f -> sec_name (get_opt_val f.fun_atom) in
- let t,bcc = Gen.definition_to_entry bcc id t in
- t::acc,bcc,StringSet.add s sec) ([],accu,StringSet.empty) in
+ match Gen.definition_to_entry sec_name bcc id t with
+ | Some (t,bcc) -> t::acc,bcc,StringSet.add s sec
+ | None -> acc, bcc, sec) ([],accu,StringSet.empty) in
let types = Gen.gen_types accu.typs in
let cp = {
compile_unit_name = gnu_string_entry !file_name;
@@ -625,6 +643,12 @@ let gen_gnu_debug_info sec_name var_section : debug_entries =
} in
let cp = new_entry (next_id ()) (DW_TAG_compile_unit cp) in
let cp = add_children cp (types@defs) in
- let loc_pc = if StringSet.cardinal sec > 1 then None else low_pc in
let string_table = Hashtbl.fold (fun s i acc -> (i,s)::acc) string_table [] in
- Gnu (cp,(loc_pc,accu.locs),string_table,snd accu.ranges)
+ let cp = {
+ string_table = string_table;
+ range_table = snd accu.ranges;
+ gnu_locs = accu.locs;
+ gnu_entry = cp;
+ several_secs = StringSet.cardinal sec > 1}
+ in
+ Gnu cp
diff --git a/doc/ccomp.1 b/doc/ccomp.1
index 374bd2e7..89e8c823 100644
--- a/doc/ccomp.1
+++ b/doc/ccomp.1
@@ -125,7 +125,8 @@ Enabled by default.
.TP
.B \-O0
Turn off most optimizations.
-Synonymous to \fB\-fno\-const\-prop\fP \fB\-fno\-cse\fP \fB\-fno\-redundancy\fP \fB\-fno\-tailcalls\fP.
+Synonymous to \fB\-fno\-const\-prop\fP \fB\-fno\-cse\fP \fB\-fno\-if\-conversion\fP
+\fB\-fno\-inline\fP \fB\-fno\-redundancy\fP \fB\-fno\-tailcalls\fP.
.
.TP
.BR \-O1 ", " \-O2 ", " \-O3
@@ -136,6 +137,13 @@ Synonymous for \fB\-O\fP.
Optimize for code size in preference to code speed.
.
.TP
+.B \-Obranchless
+Optimize to generate fewer conditional branches and use branch-free
+instruction sequences instead. When \fB-fif\-conversion\fP is
+enabled, the conversion is peformed aggressively even if the resulting
+code is less performant.
+.
+.TP
.BR \-fconst\-prop ", " \-fno\-const\-prop
Turn on/off global constant propagation.
Enabled by default.
@@ -146,6 +154,11 @@ Turn on/off common subexpression elimination.
Enabled by default.
.
.TP
+.BR \-fif\-conversion ", " \-fno\-if\-conversion
+Turn on/off generation of conditional moves.
+Enabled by default.
+.
+.TP
.BR \-finline ", " \-fno\-inline
Turn on/off inlining of functions.
Enabled by default.
@@ -180,6 +193,12 @@ Set alignment of function entry points to <n> bytes.
The default alignment is 16 bytes for x86 targets and 4 bytes for ARM and PowerPC.
.
.TP
+.BR \-fcommon ", " \-fno\-common
+Turn on/off placement of global variables defined without an initializer (tentative definitions) in the common section.
+Disabling the use of the common section inhibits merging of tentative definitions by the linker and may lead to multiple-definition errors.
+Enabled by default.
+.
+.TP
.BR \-ffpu ", " \-fno\-fpu
Turn on/off use of FP registers for some integer operations.
Enabled by default.
@@ -191,12 +210,12 @@ Code Generation Options (PowerPC)
.TP
.B \-falign\-branch\-targets <n>
Set alignment of branch targets to <n> bytes.
-The default alignment is 0 bytes, which deactivates alignment of branch targets.
+By default alignment of branch targets is deactivated.
.
.TP
.B \-falign\-cond\-branches <n>
-Set alignment of conditional branches to <n> bytes.
-The default alignment is 0 bytes, which deactivates alignment of conditional branch targets.
+Set alignment of conditional branch instructions to <n> bytes.
+By default alignment of conditional branches is deactivated.
.
.SS
Code Generation Options (PowerPC with Diab Backend)
@@ -424,9 +443,14 @@ Wrong return type for main.
Enabled by default.
.sp
\fImissing\-declarations\fP:
-Declations which do not declare anything.
+Declarations which do not declare anything.
Enabled by default.
.sp
+\fInon\-linear\-cond\-expr\fP:
+Conditional expression that may not be optimized to branchless code.
+Only issued in \fB-Obranchless\fP mode.
+Disabled by default.
+.sp
\fIpointer\-type\-mismatch\fP:
Use of incompatible pointer types in conditional expressions.
Enabled by default.
@@ -461,7 +485,7 @@ Disabled by default.
.sp
\fIunused\-variable\fP:
Unused local variables.
-Enabled by default.
+Disabled by default.
.sp
\fIvarargs\fP:
Promotable vararg arguments.
diff --git a/doc/index-mppa_k1c.html b/doc/index-mppa_k1c.html
new file mode 100644
index 00000000..41a44a0d
--- /dev/null
+++ b/doc/index-mppa_k1c.html
@@ -0,0 +1,380 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<HTML>
+<HEAD>
+<TITLE>The CompCert verified compiler</TITLE>
+<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=iso-8859-1">
+
+<style type="text/css">
+body {
+ color: black; background: white;
+ margin-left: 5%; margin-right: 5%;
+}
+h2 { margin-left: -5%;}
+h3 { margin-left: -3%; }
+h1,h2,h3 { font-family: sans-serif; }
+hr { margin-left: -5%; margin-right:-5%; }
+a:visited {color : #416DFF; text-decoration : none; font-weight : bold}
+a:link {color : #416DFF; text-decoration : none; font-weight : bold}
+a:hover {color : Red; text-decoration : underline; }
+a:active {color : Red; text-decoration : underline; }
+</style>
+
+</HEAD>
+<BODY>
+
+<H1 align="center">The CompCert verified compiler</H1>
+<H2 align="center">Commented Coq development</H2>
+<H3 align="center">Version 3.5, 2019-02-27</H3>
+<H3 align="center">PATCHED FOR MPPA-K1C</H3>
+
+<H2>Introduction</H2>
+
+<P>CompCert is a compiler that generates PowerPC, ARM, RISC-V and x86 assembly
+code from CompCert C, a large subset of the C programming language.
+The particularity of this compiler is that it is written mostly within
+the specification language of the Coq proof assistant, and its
+correctness --- the fact that the generated assembly code is
+semantically equivalent to its source program --- was entirely proved
+within the Coq proof assistant.</P>
+
+<P>High-level descriptions of the CompCert compiler and its proof of
+correctness can be found in the following papers (in increasing order of technical details):</P>
+<UL>
+<LI>Xavier Leroy, <A HREF="https://xavierleroy.org/publi/compcert-CACM.pdf">Formal verification of a realistic compiler</A>. Communications of the ACM 52(7), July 2009.
+<LI>Xavier Leroy, <A HREF="https://xavierleroy.org/publi/compcert-backend.pdf">A formally verified compiler back-end</A>.
+Journal of Automated Reasoning 43(4):363-446, 2009.
+</UL>
+
+<P>This Web site gives a commented listing of the underlying Coq
+specifications and proofs. Proof scripts are folded by default, but
+can be viewed by clicking on "Proof". Some modules (written in <I>italics</I> below) differ between the four target architectures. The
+PowerPC versions of these modules are shown below; the ARM, x86 and RISC-V
+versions can be found in the source distribution.
+</P>
+
+<P> This development is a work in progress; some parts have
+substantially changed since the overview papers above were
+written.</P>
+
+<P>The complete sources for CompCert can be downloaded from
+<A HREF="http://compcert.inria.fr/">the CompCert Web site</A>.</P>
+
+<P>This document and the CompCert sources are copyright Institut
+National de Recherche en Informatique et en Automatique (INRIA) and
+AbsInt Angewandte Informatik GmbH, and are distributed under the terms of the
+following <A HREF="LICENSE">license</A>.
+</P>
+
+<H2>Table of contents</H2>
+
+<H3>General-purpose libraries, data structures and algorithms</H3>
+
+<UL>
+<LI> <A HREF="html/compcert.lib.Coqlib.html">Coqlib</A>: addendum to the Coq standard library.
+<LI> <A HREF="html/compcert.lib.Maps.html">Maps</A>: finite maps.
+<LI> <A HREF="html/compcert.lib.Integers.html">Integers</A>: machine integers.
+<LI> <A HREF="html/compcert.lib.Floats.html">Floats</A>: machine floating-point numbers.
+<LI> <A HREF="html/compcert.lib.Iteration.html">Iteration</A>: various forms of "while" loops.
+<LI> <A HREF="html/compcert.lib.Ordered.html">Ordered</A>: construction of
+ordered types.
+<LI> <A HREF="html/compcert.lib.Lattice.html">Lattice</A>: construction of
+semi-lattices.
+<LI> <A HREF="html/compcert.backend.Kildall.html">Kildall</A>: resolution of dataflow
+inequations by fixpoint iteration.
+<LI> <A HREF="html/compcert.lib.UnionFind.html">UnionFind</A>: a persistent union-find data structure.
+<LI> <A HREF="html/compcert.lib.Postorder.html">Postorder</A>: postorder numbering of a directed graph.
+</UL>
+
+<H3>Definitions and theorems used in many parts of the development</H3>
+
+<UL>
+<LI> <A HREF="html/compcert.common.Errors.html">Errors</A>: the Error monad.
+<LI> <A HREF="html/compcert.common.AST.html">AST</A>: identifiers, whole programs and other
+common elements of abstract syntaxes.
+<LI> <A HREF="html/compcert.common.Linking.html">Linking</A>: generic framework to define syntactic linking over the CompCert languages.
+<LI> <A HREF="html/compcert.common.Values.html">Values</A>: run-time values.
+<LI> <A HREF="html/compcert.common.Events.html">Events</A>: observable events and traces.
+<LI> <A HREF="html/compcert.common.Memory.html">Memory</A>: memory model. <BR>
+See also: <A HREF="html/compcert.common.Memdata.html">Memdata</A> (in-memory representation of data).
+<LI> <A HREF="html/compcert.common.Globalenvs.html">Globalenvs</A>: global execution environments.
+<LI> <A HREF="html/compcert.common.Smallstep.html">Smallstep</A>: tools for small-step semantics.
+<LI> <A HREF="html/compcert.common.Behaviors.html">Behaviors</A>: from small-step semantics to observable behaviors of programs.
+<LI> <A HREF="html/compcert.common.Determinism.html">Determinism</A>: determinism properties of small-step semantics.
+<LI> <A HREF="html/compcert.mppa_k1c.Op.html"><I>Op</I></A>: operators, addressing modes and their
+semantics.
+<LI> <A HREF="html/compcert.common.Unityping.html">Unityping</A>: a solver for atomic unification constraints.
+</UL>
+
+<H3>Source, intermediate and target languages: syntax and semantics</H3>
+
+<UL>
+<LI> The CompCert C source language:
+<A HREF="html/compcert.cfrontend.Csyntax.html">syntax</A> and
+<A HREF="html/compcert.cfrontend.Csem.html">semantics</A> and
+<A HREF="html/compcert.cfrontend.Cstrategy.html">determinized semantics</A> and
+<A HREF="html/compcert.cfrontend.Ctyping.html">type system</A>.<BR>
+See also: <A HREF="html/compcert.cfrontend.Ctypes.html">type expressions</A> and
+<A HREF="html/compcert.cfrontend.Cop.html">operators (syntax and semantics)</A>.<BR>
+See also: <A HREF="html/compcert.cfrontend.Cexec.html">reference interpreter</A>.
+<LI> <A HREF="html/compcert.cfrontend.Clight.html">Clight</A>: a simpler version of CompCert C where expressions contain no side-effects.
+<LI> <A HREF="html/compcert.cfrontend.Csharpminor.html">Csharpminor</A>: low-level
+ structured language.
+<LI> <A HREF="html/compcert.backend.Cminor.html">Cminor</A>: low-level structured
+language, with explicit stack allocation of certain local variables.
+<LI> <A HREF="html/compcert.backend.CminorSel.html">CminorSel</A>: like Cminor,
+with machine-specific operators and addressing modes.
+<LI> <A HREF="html/compcert.backend.RTL.html">RTL</A>: register transfer language (3-address
+code, control-flow graph, infinitely many pseudo-registers). <BR>
+See also: <A HREF="html/compcert.backend.Registers.html">Registers</A> (representation of
+pseudo-registers).
+<LI> <A HREF="html/compcert.backend.LTL.html">LTL</A>: location transfer language (3-address
+code, control-flow graph of basic blocks, finitely many physical registers, infinitely
+many stack slots). <BR>
+See also: <A HREF="html/compcert.backend.Locations.html">Locations</A> (representation of
+locations) and <A HREF="html/compcert.mppa_k1c.Machregs.html"><I>Machregs</I></A> (description of processor registers).
+<LI> <A HREF="html/compcert.backend.Linear.html">Linear</A>: like LTL, but the CFG is
+replaced by a linear list of instructions with explicit branches and labels.
+<LI> <A HREF="html/compcert.backend.Mach.html">Mach</A>: like Linear, with a more concrete
+view of the activation record.
+<LI> <A HREF="html/compcert.mppa_k1c.lib.Machblock.html">Machblock</A>: a variant of Mach, with a syntax for basic-blocks, and a block-step semantics (execute one basic-block in one step).
+This IR is generic over the processor, even if currently, only used for MPPA_K1C.
+<LI> <A HREF="html/compcert.mppa_k1c.Asmvliw.html"><I>Asmvliw</I></A>: abstract syntax and semantics for Mppa_K1c VLIW assembly: atomic instructions are grouped by "bundles". These bundles are executed sequentially, but execution is parallel within bundles.
+<LI> <A HREF="html/compcert.mppa_k1c.Asmblock.html"><I>Asmblock</I></A>: a variant of Asmvliw, with a sequential semantics within bundles, which make them corresponds here to usual basic-blocks.
+ This IR is an intermediate step between Machblock and Asmvliw.
+<LI> <A HREF="html/compcert.mppa_k1c.Asm.html"><I>Asm</I></A>: a variant of Asmvliw with a flat syntax for bundles, instead of a structured one (bundle termination is encoded as a pseudo-instruction). This IR is mainly a wrapper of <I>Asmvliw</I> for a smooth integration in CompCert (and an easier pretty-printing of the abstract syntax).
+</UL>
+
+<H3>Compiler passes</H3>
+
+<TABLE cellpadding="5%">
+<TR valign="top">
+ <TH>Pass</TH>
+ <TH>Source &amp; target</TH>
+ <TH>Compiler&nbsp;code</TH>
+ <TH>Correctness&nbsp;proof</TH>
+</TR>
+
+<TR valign="top">
+ <TD>Pulling side-effects out of expressions;<br>
+ fixing an evaluation order</TD>
+ <TD>CompCert C to Clight</TD>
+ <TD><A HREF="html/compcert.cfrontend.SimplExpr.html">SimplExpr</A></TD>
+ <TD><A HREF="html/compcert.cfrontend.SimplExprspec.html">SimplExprspec</A><br>
+ <A HREF="html/compcert.cfrontend.SimplExprproof.html">SimplExprproof</A></TD>
+</TR>
+<TR valign="top">
+ <TD>Pulling non-adressable scalar local variables out of memory</TD>
+ <TD>Clight to Clight</TD>
+ <TD><A HREF="html/compcert.cfrontend.SimplLocals.html">SimplLocals</A></TD>
+ <TD><A HREF="html/compcert.cfrontend.SimplLocalsproof.html">SimplLocalsproof</A></TD>
+</TR>
+<TR valign="top">
+ <TD>Simplification of control structures; <br>
+ explication of type-dependent computations</TD>
+ <TD>Clight to Csharpminor</TD>
+ <TD><A HREF="html/compcert.cfrontend.Cshmgen.html">Cshmgen</A></TD>
+ <TD><A HREF="html/compcert.cfrontend.Cshmgenproof.html">Cshmgenproof</A></TD>
+</TR>
+<TR valign="top">
+ <TD>Stack allocation of local variables<br>
+ whose address is taken;<br>
+ simplification of switch statements</TD>
+ <TD>Csharpminor to Cminor</TD>
+ <TD><A HREF="html/compcert.cfrontend.Cminorgen.html">Cminorgen</A></TD>
+ <TD><A HREF="html/compcert.cfrontend.Cminorgenproof.html">Cminorgenproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Recognition of operators<br>and addressing modes</TD>
+ <TD>Cminor to CminorSel</TD>
+ <TD><A HREF="html/compcert.backend.Selection.html">Selection</A><br>
+ <A HREF="html/compcert.mppa_k1c.SelectOp.html"><I>SelectOp</I></A><br>
+ <A HREF="html/compcert.mppa_k1c.SelectLong.html"><I>SelectLong</I></A><br>
+ <A HREF="html/compcert.backend.SelectDiv.html">SelectDiv</A><br>
+ <A HREF="html/compcert.backend.SplitLong.html">SplitLong</A></TD>
+ <TD><A HREF="html/compcert.backend.Selectionproof.html">Selectionproof</A><br>
+ <A HREF="html/compcert.mppa_k1c.SelectOpproof.html"><I>SelectOpproof</I></A><br>
+ <A HREF="html/compcert.mppa_k1c.SelectLongproof.html"><I>SelectLongproof</I></A><br>
+ <A HREF="html/compcert.backend.SelectDivproof.html">SelectDivproof</A><br>
+ <A HREF="html/compcert.backend.SplitLongproof.html">SplitLongproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Construction of the CFG, <br>3-address code generation</TD>
+ <TD>CminorSel to RTL</TD>
+ <TD><A HREF="html/compcert.backend.RTLgen.html">RTLgen</A></TD>
+ <TD><A HREF="html/compcert.backend.RTLgenspec.html">RTLgenspec</A><BR>
+ <A HREF="html/compcert.backend.RTLgenproof.html">RTLgenproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Recognition of tail calls</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Tailcall.html">Tailcall</A></TD>
+ <TD><A HREF="html/compcert.backend.Tailcallproof.html">Tailcallproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Function inlining</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Inlining.html">Inlining</A></TD>
+ <TD><A HREF="html/compcert.backend.Inliningspec.html">Inliningspec</A><BR>
+ <A HREF="html/compcert.backend.Inliningproof.html">Inliningproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Postorder renumbering of the CFG</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Renumber.html">Renumber</A></TD>
+ <TD><A HREF="html/compcert.backend.Renumberproof.html">Renumberproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Constant propagation</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Constprop.html">Constprop</A><br>
+ <A HREF="html/compcert.mppa_k1c.ConstpropOp.html"><I>ConstpropOp</I></A></TD>
+ <TD><A HREF="html/compcert.backend.Constpropproof.html">Constpropproof</A><br>
+ <A HREF="html/compcert.mppa_k1c.ConstpropOpproof.html"><I>ConstproppOproof</I></A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Common subexpression elimination</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.CSE.html">CSE</A><BR>
+ <A HREF="html/compcert.mppa_k1c.CombineOp.html"><I>CombineOp</I></A></TD>
+ <TD><A HREF="html/compcert.backend.CSEproof.html">CSEproof</A><BR>
+ <A HREF="html/compcert.mppa_k1c.CombineOpproof.html"><I>CombineOpproof</I></A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Redundancy elimination</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Deadcode.html">Deadcode</A></TD>
+ <TD><A HREF="html/compcert.backend.Deadcodeproof.html">Deadcodeproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Removal of unused static globals</TD>
+ <TD>RTL to RTL</TD>
+ <TD><A HREF="html/compcert.backend.Unusedglob.html">Unusedglob</A></TD>
+ <TD><A HREF="html/compcert.backend.Unusedglobproof.html">Unusedglobproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Register allocation (validation a posteriori)</TD>
+ <TD>RTL to LTL</TD>
+ <TD><A HREF="html/compcert.backend.Allocation.html">Allocation</A></TD>
+ <TD><A HREF="html/compcert.backend.Allocproof.html">Allocproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Branch tunneling</TD>
+ <TD>LTL to LTL</TD>
+ <TD><A HREF="html/compcert.backend.Tunneling.html">Tunneling</A></TD>
+ <TD><A HREF="html/compcert.backend.Tunnelingproof.html">Tunnelingproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Linearization of the CFG</TD>
+ <TD>LTL to Linear</TD>
+ <TD><A HREF="html/compcert.backend.Linearize.html">Linearize</A></TD>
+ <TD><A HREF="html/compcert.backend.Linearizeproof.html">Linearizeproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Removal of unreferenced labels</TD>
+ <TD>Linear to Linear</TD>
+ <TD><A HREF="html/compcert.backend.CleanupLabels.html">CleanupLabels</A></TD>
+ <TD><A HREF="html/compcert.backend.CleanupLabelsproof.html">CleanupLabelsproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Synthesis of debugging information</TD>
+ <TD>Linear to Linear</TD>
+ <TD><A HREF="html/compcert.backend.Debugvar.html">Debugvar</A></TD>
+ <TD><A HREF="html/compcert.backend.Debugvarproof.html">Debugvarproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Laying out the activation records</TD>
+ <TD>Linear to Mach</TD>
+ <TD><A HREF="html/compcert.backend.Stacking.html">Stacking</A><BR>
+ <A HREF="html/compcert.backend.Bounds.html">Bounds</A><BR>
+ <A HREF="html/compcert.mppa_k1c.Stacklayout.html"><I>Stacklayout</I></A></TD>
+ <TD><A HREF="html/compcert.backend.Stackingproof.html">Stackingproof</A><br>
+ <A HREF="html/compcert.common.Separation.html">Separation</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Reconstruction of basic-blocks at Mach level</TD>
+ <TD>Mach to Machblock</TD>
+ <TD><A HREF="html/compcert.mppa_k1c.lib.Machblockgen.html">Machblockgen</A></TD>
+ <TD><A HREF="html/compcert.mppa_k1c.lib.ForwardSimulationBlock.html">ForwardSimulationBlock</A><BR>
+ <A HREF="html/compcert.mppa_k1c.lib.Machblockgenproof.html">Machblockgenproof</A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Emission of purely sequential assembly code</TD>
+ <TD>Machblock to Asmblock</TD>
+ <TD><A HREF="html/compcert.mppa_k1c.Asmblockgen.html"><I>Asmblockgen</I></A></TD>
+ <TD><A HREF="html/compcert.mppa_k1c.Asmblockgenproof0.html"><I>Asmblockgenproof0</I></A><BR>
+ <A HREF="html/compcert.mppa_k1c.Asmblockgenproof1.html"><I>Asmblockgenproof1</I></A><BR>
+ <A HREF="html/compcert.mppa_k1c.Asmblockgenproof.html"><I>Asmblockgenproof</I></A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Bundling (and basic-block scheduling)</TD>
+ <TD>Asmblock to Asmvliw</TD>
+ <TD><A HREF="html/compcert.mppa_k1c.PostpassScheduling.html"><I>PostpassScheduling</I></A> using<BR>
+ <A HREF="html/compcert.mppa_k1c.Asmblockdeps.html"><I>Asmblockdeps</I></A> and the <tt>abstractbb</tt> library</TD>
+ <TD><A HREF="html/compcert.mppa_k1c.PostpassSchedulingproof.html"><I>PostpassSchedulingproof</I></A></TD>
+</TR>
+
+<TR valign="top">
+ <TD>Flattening bundles (only a bureaucratic operation)</TD>
+ <TD>Asmvliw to Asm</TD>
+ <TD><A HREF="html/compcert.mppa_k1c.Asmgen.html"><I>Asmgen</I></A></TD>
+ <TD><A HREF="html/compcert.mppa_k1c.Asmgenproof.html"><I>Asmgenproof</I></A></TD>
+</TR>
+</TABLE>
+
+<H3>All together</H3>
+
+<UL>
+<LI> <A HREF="html/compcert.driver.Compiler.html">Compiler</A>: composing the passes together;
+whole-compiler semantic preservation theorems.
+<LI> <A HREF="html/compcert.driver.Complements.html">Complements</A>: interesting consequences of the semantic preservation theorems.
+</UL>
+
+<H3>Static analyses</H3>
+
+The following static analyses are performed over the RTL intermediate
+representation to support optimizations such as constant propagation,
+CSE, and dead code elimination.
+<UL>
+<LI> <A HREF="html/compcert.backend.Liveness.html">Liveness</A>: liveness analysis</A>.
+<LI> <A HREF="html/compcert.backend.ValueAnalysis.html">ValueAnalysis</A>: value and alias analysis</A> <BR>
+See also: <A HREF="html/compcert.backend.ValueDomain.html">ValueDomain</A>: the abstract domain for value analysis.<BR>
+See also: <A HREF="html/compcert.mppa_k1c.ValueAOp.html"><I>ValueAOp</I></A>: processor-dependent parts of value analysis.
+<LI> <A HREF="html/compcert.backend.Deadcode.html">Deadcode</A>: neededness analysis</A> <BR>
+See also: <A HREF="html/compcert.backend.NeedDomain.html">NeedDomain</A>: the abstract domain for neededness analysis.<BR>
+See also: <A HREF="html/compcert.mppa_k1c.NeedOp.html"><I>NeedOp</I></A>: processor-dependent parts of neededness analysis.
+</UL>
+
+<H3>Type systems</H3>
+
+The <A HREF="html/compcert.cfrontend.Ctyping.html">type system of CompCert C</A> is fully formalized. For some intermediate languages of the back-end, simpler type systems are used to statically capture well-formedness conditions.
+<UL>
+<LI> <A HREF="html/compcert.cfrontend.Ctyping.html">Ctyping</A>: typing for CompCert C + type-checking functions.
+<LI> <A HREF="html/compcert.backend.RTLtyping.html">RTLtyping</A>: typing for RTL + type
+reconstruction.
+<LI> <A HREF="html/compcert.backend.Lineartyping.html">Lineartyping</A>: typing for Linear.
+</UL>
+
+<HR>
+<ADDRESS>Xavier.Leroy@inria.fr</ADDRESS>
+<HR>
+
+</BODY>
+</HTML>
diff --git a/doc/index.html b/doc/index.html
index edb3accd..631c5d99 100644
--- a/doc/index.html
+++ b/doc/index.html
@@ -24,7 +24,7 @@ a:active {color : Red; text-decoration : underline; }
<H1 align="center">The CompCert verified compiler</H1>
<H2 align="center">Commented Coq development</H2>
-<H3 align="center">Version 3.5, 2019-02-27</H3>
+<H3 align="center">Version 3.7, 2020-03-31</H3>
<H2>Introduction</H2>
@@ -101,6 +101,8 @@ See also: <A HREF="html/compcert.common.Memdata.html">Memdata</A> (in-memory rep
<LI> <A HREF="html/compcert.common.Determinism.html">Determinism</A>: determinism properties of small-step semantics.
<LI> <A HREF="html/compcert.powerpc.Op.html"><I>Op</I></A>: operators, addressing modes and their
semantics.
+<LI> <A HREF="html/compcert.common.Builtins.html">Builtins</A>: semantics of built-in functions. <BR>
+See also: <A HREF="html/compcert.common.Builtins0.html">Builtins0</A> (target-independent part), <A HREF="html/compcert.powerpc.Builtins1.html"><I>Builtins1</I></A> (target-dependent part).
<LI> <A HREF="html/compcert.common.Unityping.html">Unityping</A>: a solver for atomic unification constraints.
</UL>
@@ -180,7 +182,8 @@ code.
</TR>
<TR valign="top">
- <TD>Recognition of operators<br>and addressing modes</TD>
+ <TD>Recognition of operators<br>and addressing modes;<br>
+ if-conversion</TD>
<TD>Cminor to CminorSel</TD>
<TD><A HREF="html/compcert.backend.Selection.html">Selection</A><br>
<A HREF="html/compcert.powerpc.SelectOp.html"><I>SelectOp</I></A><br>
diff --git a/driver/Clflags.ml b/driver/Clflags.ml
index fd5f0e68..c20758b3 100644
--- a/driver/Clflags.ml
+++ b/driver/Clflags.ml
@@ -26,13 +26,20 @@ let option_ffloatconstprop = ref 2
let option_ftailcalls = ref true
let option_fconstprop = ref true
let option_fcse = ref true
+let option_fcse2 = ref true
let option_fredundancy = ref true
+let option_fduplicate = ref (-1)
+let option_finvertcond = ref true
+let option_ftracelinearize = ref false
let option_fpostpass = ref true
let option_fpostpass_sched = ref "list"
+let option_fifconversion = ref true
+let option_Obranchless = ref false
let option_falignfunctions = ref (None: int option)
let option_falignbranchtargets = ref 0
let option_faligncondbranchs = ref 0
let option_finline_asm = ref false
+let option_fcommon = ref true
let option_mthumb = ref (Configuration.model = "armv7m")
let option_Osize = ref false
let option_finline = ref true
@@ -70,7 +77,10 @@ let use_standard_headers = ref Configuration.has_standard_headers
let option_fglobaladdrtmp = ref false
let option_fglobaladdroffset = ref false
let option_fxsaddr = ref true
-let option_coalesce_mem = ref true
-
let option_div_i32 = ref "stsud"
let option_div_i64 = ref "stsud"
+let option_faddx = ref false
+let option_fcoalesce_mem = ref true
+let option_fforward_moves = ref true
+let option_all_loads_nontrap = ref false
+let option_inline_auto_threshold = ref 0
diff --git a/driver/Commandline.ml b/driver/Commandline.ml
index 75ca1683..672ed834 100644
--- a/driver/Commandline.ml
+++ b/driver/Commandline.ml
@@ -16,7 +16,6 @@
(* Parsing of command-line flags and arguments *)
open Printf
-open Responsefile
type pattern =
| Exact of string
@@ -114,14 +113,15 @@ let parse_array spec argv first last =
end
in parse first
-let argv : string array ref = ref [||]
+let argv =
+ try
+ Responsefile.expandargv Sys.argv
+ with Responsefile.Error msg | Sys_error msg ->
+ eprintf "Error while processing the command line: %s\n" msg;
+ exit 2
let parse_cmdline spec =
- try
- argv := expandargv Sys.argv;
- parse_array spec !argv 1 (Array.length !argv - 1)
- with Responsefile.Error s ->
- raise (CmdError s)
+ parse_array spec argv 1 (Array.length argv - 1)
let long_int_action key s =
let ls = String.length s
diff --git a/driver/Commandline.mli b/driver/Commandline.mli
index e1b917f2..8bb6f18f 100644
--- a/driver/Commandline.mli
+++ b/driver/Commandline.mli
@@ -39,11 +39,11 @@ type action =
patterns are tried in the order in which they appear in the list. *)
exception CmdError of string
-(** Raise by [parse_cmdline] when an error occured *)
+(** Raise by [parse_cmdline] when an error occurred *)
val parse_cmdline: (pattern * action) list -> unit
-(** [parse_cmdline actions] parses the commandline and performs all [actions].
- Raises [CmdError] if an error occurred.
+(** [parse_cmdline actions] parses the command line (after @-file expansion)
+ and performs all [actions]. Raises [CmdError] if an error occurred.
*)
val longopt_int: string -> (int -> unit) -> pattern * action
@@ -51,5 +51,5 @@ val longopt_int: string -> (int -> unit) -> pattern * action
options of the form [key=<n>] and calls [fn] with the integer argument
*)
-val argv: string array ref
+val argv: string array
(** [argv] contains the complete command line after @-file expandsion *)
diff --git a/driver/CommonOptions.ml b/driver/CommonOptions.ml
index 58dd4007..c151ecf2 100644
--- a/driver/CommonOptions.ml
+++ b/driver/CommonOptions.ml
@@ -14,9 +14,9 @@ open Clflags
open Commandline
(* The version string for [tool_name] *)
-let version_string tool_name=
+let version_string tool_name =
if Version.buildnr <> "" && Version.tag <> "" then
- Printf.sprintf "The CompCert %s, %s, Build: %s, Tag: %s\n" tool_name Version.version Version.buildnr Version.tag
+ Printf.sprintf "The CompCert %s, Release: %s, Build: %s, Tag: %s\n" tool_name Version.version Version.buildnr Version.tag
else
Printf.sprintf "The CompCert %s, version %s\n" tool_name Version.version
diff --git a/driver/Compiler.v b/driver/Compiler.v
index 6d398327..499feff2 100644
--- a/driver/Compiler.v
+++ b/driver/Compiler.v
@@ -38,10 +38,14 @@ Require RTLgen.
Require Tailcall.
Require Inlining.
Require Renumber.
+Require Duplicate.
Require Constprop.
Require CSE.
+Require ForwardMoves.
+Require CSE2.
Require Deadcode.
Require Unusedglob.
+Require Allnontrap.
Require Allocation.
Require Tunneling.
Require Linearize.
@@ -59,10 +63,14 @@ Require RTLgenproof.
Require Tailcallproof.
Require Inliningproof.
Require Renumberproof.
+Require Duplicateproof.
Require Constpropproof.
Require CSEproof.
+Require ForwardMovesproof.
+Require CSE2proof.
Require Deadcodeproof.
Require Unusedglobproof.
+Require Allnontrapproof.
Require Allocproof.
Require Tunnelingproof.
Require Linearizeproof.
@@ -126,16 +134,24 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program :=
@@ print (print_RTL 2)
@@ time "Renumbering" Renumber.transf_program
@@ print (print_RTL 3)
- @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program)
+ @@@ partial_if Compopts.optim_duplicate (time "Tail-duplicating" Duplicate.transf_program)
@@ print (print_RTL 4)
- @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program)
+ @@ total_if Compopts.optim_constprop (time "Constant propagation" Constprop.transf_program)
@@ print (print_RTL 5)
- @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program)
+ @@ total_if Compopts.optim_constprop (time "Renumbering" Renumber.transf_program)
@@ print (print_RTL 6)
- @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program)
+ @@@ partial_if Compopts.optim_CSE (time "CSE" CSE.transf_program)
@@ print (print_RTL 7)
- @@@ time "Unused globals" Unusedglob.transform_program
+ @@ total_if Compopts.optim_CSE2 (time "CSE2" CSE2.transf_program)
@@ print (print_RTL 8)
+ @@ total_if Compopts.optim_forward_moves ForwardMoves.transf_program
+ @@ print (print_RTL 9)
+ @@@ partial_if Compopts.optim_redundancy (time "Redundancy elimination" Deadcode.transf_program)
+ @@ print (print_RTL 10)
+ @@ total_if Compopts.all_loads_nontrap Allnontrap.transf_program
+ @@ print (print_RTL 11)
+ @@@ time "Unused globals" Unusedglob.transform_program
+ @@ print (print_RTL 12)
@@@ time "Register allocation" Allocation.transf_program
@@ print print_LTL
@@ time "Branch tunneling" Tunneling.tunnel_program
@@ -144,7 +160,7 @@ Definition transf_rtl_program (f: RTL.program) : res Asm.program :=
@@@ partial_if Compopts.debug (time "Debugging info for local variables" Debugvar.transf_program)
@@@ time "Mach generation" Stacking.transf_program
@@ print print_Mach
- @@@ time "Asm generation" Asmgen.transf_program.
+ @@@ time "Total Mach->Asm generation" Asmgen.transf_program.
Definition transf_cminor_program (p: Cminor.program) : res Asm.program :=
OK p
@@ -238,10 +254,14 @@ Definition CompCert's_passes :=
::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog)
::: mkpass Inliningproof.match_prog
::: mkpass Renumberproof.match_prog
+ ::: mkpass (match_if Compopts.optim_duplicate Duplicateproof.match_prog)
::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog)
::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog)
::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog)
+ ::: mkpass (match_if Compopts.optim_CSE2 CSE2proof.match_prog)
+ ::: mkpass (match_if Compopts.optim_forward_moves ForwardMovesproof.match_prog)
::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog)
+ ::: mkpass (match_if Compopts.all_loads_nontrap Allnontrapproof.match_prog)
::: mkpass Unusedglobproof.match_prog
::: mkpass Allocproof.match_prog
::: mkpass Tunnelingproof.match_prog
@@ -281,17 +301,21 @@ Proof.
set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *.
destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate.
set (p9 := Renumber.transf_program p8) in *.
- set (p10 := total_if optim_constprop Constprop.transf_program p9) in *.
- set (p11 := total_if optim_constprop Renumber.transf_program p10) in *.
- destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate.
- destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate.
- destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate.
- destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate.
- set (p16 := Tunneling.tunnel_program p15) in *.
- destruct (Linearize.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate.
- set (p18 := CleanupLabels.transf_program p17) in *.
- destruct (partial_if debug Debugvar.transf_program p18) as [p19|e] eqn:P19; simpl in T; try discriminate.
- destruct (Stacking.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate.
+ destruct (partial_if optim_duplicate Duplicate.transf_program p9) as [p10|e] eqn:P10; simpl in T; try discriminate.
+ set (p11 := total_if optim_constprop Constprop.transf_program p10) in *.
+ set (p12 := total_if optim_constprop Renumber.transf_program p11) in *.
+ destruct (partial_if optim_CSE CSE.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate.
+ set (p13bis := total_if optim_CSE2 CSE2.transf_program p13) in *.
+ set (p13ter := total_if optim_forward_moves ForwardMoves.transf_program p13bis) in *.
+ destruct (partial_if optim_redundancy Deadcode.transf_program p13ter) as [p14|e] eqn:P14; simpl in T; try discriminate.
+ set (p14bis := total_if all_loads_nontrap Allnontrap.transf_program p14) in *.
+ destruct (Unusedglob.transform_program p14bis) as [p15|e] eqn:P15; simpl in T; try discriminate.
+ destruct (Allocation.transf_program p15) as [p16|e] eqn:P16; simpl in T; try discriminate.
+ set (p17 := Tunneling.tunnel_program p16) in *.
+ destruct (Linearize.transf_program p17) as [p18|e] eqn:P18; simpl in T; try discriminate.
+ set (p19 := CleanupLabels.transf_program p18) in *.
+ destruct (partial_if debug Debugvar.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate.
+ destruct (Stacking.transf_program p20) as [p21|e] eqn:P21; simpl in T; try discriminate.
unfold match_prog; simpl.
exists p1; split. apply SimplExprproof.transf_program_match; auto.
exists p2; split. apply SimplLocalsproof.match_transf_program; auto.
@@ -302,17 +326,21 @@ Proof.
exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match.
exists p8; split. apply Inliningproof.transf_program_match; auto.
exists p9; split. apply Renumberproof.transf_program_match; auto.
- exists p10; split. apply total_if_match. apply Constpropproof.transf_program_match.
- exists p11; split. apply total_if_match. apply Renumberproof.transf_program_match.
- exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match.
- exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match.
- exists p14; split. apply Unusedglobproof.transf_program_match; auto.
- exists p15; split. apply Allocproof.transf_program_match; auto.
- exists p16; split. apply Tunnelingproof.transf_program_match.
- exists p17; split. apply Linearizeproof.transf_program_match; auto.
- exists p18; split. apply CleanupLabelsproof.transf_program_match; auto.
- exists p19; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match.
- exists p20; split. apply Stackingproof.transf_program_match; auto.
+ exists p10; split. eapply partial_if_match; eauto. apply Duplicateproof.transf_program_match; auto.
+ exists p11; split. apply total_if_match. apply Constpropproof.transf_program_match.
+ exists p12; split. apply total_if_match. apply Renumberproof.transf_program_match.
+ exists p13; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match.
+ exists p13bis; split. apply total_if_match. apply CSE2proof.transf_program_match.
+ exists p13ter; split. eapply total_if_match; eauto. apply ForwardMovesproof.transf_program_match.
+ exists p14; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match.
+ exists p14bis; split. eapply total_if_match; eauto. apply Allnontrapproof.transf_program_match.
+ exists p15; split. apply Unusedglobproof.transf_program_match; auto.
+ exists p16; split. apply Allocproof.transf_program_match; auto.
+ exists p17; split. apply Tunnelingproof.transf_program_match.
+ exists p18; split. apply Linearizeproof.transf_program_match; auto.
+ exists p19; split. apply CleanupLabelsproof.transf_program_match; auto.
+ exists p20; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match.
+ exists p21; split. apply Stackingproof.transf_program_match; auto.
exists tp; split. apply Asmgenproof.transf_program_match; auto.
reflexivity.
Qed.
@@ -364,7 +392,7 @@ Ltac DestructM :=
destruct H as (p & M & MM); clear H
end.
repeat DestructM. subst tp.
- assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p21)).
+ assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p25)).
{
eapply compose_forward_simulations.
eapply SimplExprproof.transl_program_correct; eassumption.
@@ -384,14 +412,22 @@ Ltac DestructM :=
eapply Inliningproof.transf_program_correct; eassumption.
eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption.
eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact Duplicateproof.transf_program_correct.
+ eapply compose_forward_simulations.
eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct.
eapply compose_forward_simulations.
eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct.
eapply compose_forward_simulations.
eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct.
eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact CSE2proof.transf_program_correct.
+ eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact ForwardMovesproof.transf_program_correct; eassumption.
+ eapply compose_forward_simulations.
eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption.
eapply compose_forward_simulations.
+ eapply match_if_simulation. eassumption. exact Allnontrapproof.transf_program_correct.
+ eapply compose_forward_simulations.
eapply Unusedglobproof.transf_program_correct; eassumption.
eapply compose_forward_simulations.
eapply Allocproof.transf_program_correct; eassumption.
diff --git a/driver/Compopts.v b/driver/Compopts.v
index f7de596c..848657e5 100644
--- a/driver/Compopts.v
+++ b/driver/Compopts.v
@@ -27,6 +27,9 @@ Parameter generate_float_constants: unit -> bool.
(** For value analysis. Currently always false. *)
Parameter va_strict: unit -> bool.
+(** Flag -fduplicate. Branch prediction annotation + tail duplication *)
+Parameter optim_duplicate: unit -> bool.
+
(** Flag -ftailcalls. For tail call optimization. *)
Parameter optim_tailcalls: unit -> bool.
@@ -36,6 +39,9 @@ Parameter optim_constprop: unit -> bool.
(** Flag -fcse. For common subexpression elimination. *)
Parameter optim_CSE: unit -> bool.
+(** Flag -fcse2. For DMonniaux's common subexpression elimination. *)
+Parameter optim_CSE2: unit -> bool.
+
(** Flag -fredundancy. For dead code elimination. *)
Parameter optim_redundancy: unit -> bool.
@@ -43,19 +49,32 @@ Parameter optim_redundancy: unit -> bool.
Parameter optim_postpass: unit -> bool.
(** FIXME TEMPORARY Flag -fglobaladdrtmp. Use a temporary register for loading the address of global variables (default false) *)
-Parameter optim_fglobaladdrtmp: unit -> bool.
+Parameter optim_globaladdrtmp: unit -> bool.
(** FIXME TEMPORARY Flag -fglobaladdroffset. Fold offsets into global addresses (default false) *)
-Parameter optim_fglobaladdroffset: unit -> bool.
+Parameter optim_globaladdroffset: unit -> bool.
(** FIXME TEMPORARY Flag -fxsaddr. Use .xs addressing mode (default true) *)
-Parameter optim_fxsaddr: unit -> bool.
+Parameter optim_xsaddr: unit -> bool.
(** FIXME TEMPORARY Flag -fcoaelesce-mem. Fuse (default true) *)
Parameter optim_coalesce_mem: unit -> bool.
+(** FIXME TEMPORARY Flag -faddx. Fuse (default false) *)
+Parameter optim_addx: unit -> bool.
+
(** Flag -fthumb. For the ARM back-end. *)
Parameter thumb: unit -> bool.
(** Flag -g. For insertion of debugging information. *)
Parameter debug: unit -> bool.
+
+(** Flag -fall-loads-nontrap. Turn user loads into non trapping. *)
+Parameter all_loads_nontrap: unit -> bool.
+
+(** Flag -fforward-moves. Forward moves after CSE. *)
+Parameter optim_forward_moves: unit -> bool.
+
+(* TODO is there a more appropriate place? *)
+Require Import Coqlib.
+Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f.
diff --git a/driver/Configuration.ml b/driver/Configuration.ml
index eae3aaab..08084720 100644
--- a/driver/Configuration.ml
+++ b/driver/Configuration.ml
@@ -13,11 +13,11 @@
open Printf
let search_argv key =
- let len = Array.length Sys.argv in
+ let len = Array.length Commandline.argv in
let res: string option ref = ref None in
for i = 1 to len - 2 do
- if Sys.argv.(i) = key then
- res := Some Sys.argv.(i + 1);
+ if Commandline.argv.(i) = key then
+ res := Some Commandline.argv.(i + 1);
done;
!res
@@ -123,7 +123,7 @@ let get_bool_config key =
let arch =
match get_config_string "arch" with
- | "powerpc"|"arm"|"x86"|"riscV"|"mppa_k1c" as a -> a
+ | "powerpc"|"arm"|"x86"|"riscV"|"mppa_k1c"|"aarch64" as a -> a
| v -> bad_config "arch" [v]
let model = get_config_string "model"
let abi = get_config_string "abi"
diff --git a/driver/Driver.ml b/driver/Driver.ml
index 314cf31c..ba48f29a 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -185,20 +185,36 @@ Processing options:
{|Optimization options: (use -fno-<opt> to turn off -f<opt>)
-O Optimize the compiled code [on by default]
-O0 Do not optimize the compiled code
- -O1 -O2 -O3 Synonymous for -O
+ -O1 Perform all optimization passes except scheduling
+ -O2 -O3 Synonymous for -O
-Os Optimize for code size in preference to code speed
+ -Obranchless Optimize to generate fewer conditional branches; try to produce
+ branch-free instruction sequences as much as possible
+ -finline-auto-threshold n Inline functions under size n
-ftailcalls Optimize function calls in tail position [on]
-fconst-prop Perform global constant propagation [on]
-ffloat-const-prop <n> Control constant propagation of floats
(<n>=0: none, <n>=1: limited, <n>=2: full; default is full)
-fcse Perform common subexpression elimination [on]
+ -fcse2 Perform inter-loop common subexpression elimination [on]
-fredundancy Perform redundancy elimination [on]
-fpostpass Perform postpass scheduling (only for K1 architecture) [on]
-fpostpass= <optim> Perform postpass scheduling with the specified optimization [list]
(<optim>=list: list scheduling, <optim>=ilp: ILP, <optim>=greedy: just packing bundles)
+ -fduplicate <nb_nodes> Perform tail duplication to form superblocks on predicted traces
+ nb_nodes control the heuristic deciding to duplicate or not
+ A value of -1 desactivates the entire pass (including branch prediction)
+ A value of 0 desactivates the duplication (but activates the branch prediction)
+ FIXME : this is desactivated by default for now
+ -finvertcond Invert conditions based on predicted paths (to prefer fallthrough).
+ Requires -fduplicate to be also activated [on]
+ -ftracelinearize Linearizes based on the traces identified by duplicate phase
+ It is heavily recommended to activate -finvertcond with this pass [off]
+ -fforward-moves Forward moves after CSE
-finline Perform inlining of functions [on]
-finline-functions-called-once Integrate functions only required by their
single caller [on]
+ -fif-conversion Perform if-conversion (generation of conditional moves) [on]
Code generation options: (use -fno-<opt> to turn off -f<opt>)
-ffpu Use FP registers for some integer operations [on]
-fsmall-data <n> Set maximal size <n> for allocation in small data area
@@ -206,6 +222,7 @@ Code generation options: (use -fno-<opt> to turn off -f<opt>)
-falign-functions <n> Set alignment (in bytes) of function entry points
-falign-branch-targets <n> Set alignment (in bytes) of branch targets
-falign-cond-branches <n> Set alignment (in bytes) of conditional branches
+ -fcommon Put uninitialized globals in the common section [on].
|} ^
target_help ^
toolchain_help ^
@@ -252,7 +269,10 @@ let dump_mnemonics destfile =
exit 0
let optimization_options = [
- option_ftailcalls; option_fconstprop; option_fcse; option_fredundancy; option_fpostpass; option_finline_functions_called_once;
+ option_ftailcalls; option_fifconversion; option_fconstprop;
+ option_fcse; option_fcse2;
+ option_fpostpass;
+ option_fredundancy; option_finline; option_finline_functions_called_once;
]
let set_all opts () = List.iter (fun r -> r := true) opts
@@ -265,14 +285,18 @@ let num_input_files = ref 0
let cmdline_actions =
let f_opt name ref =
[Exact("-f" ^ name), Set ref; Exact("-fno-" ^ name), Unset ref] in
- let f_opt_str name ref strref default =
+ let f_opt_str name ref strref =
[Exact("-f" ^ name ^ "="), String
- (fun s -> (strref := (if s == "" then default else s)); ref := true)
+ (fun s -> (strref := (if s == "" then "list" else s)); ref := true)
] in
let f_str name strref default =
[Exact("-f" ^ name ^ "="), String
(fun s -> (strref := (if s == "" then default else s)))
] in
+ let check_align n =
+ if n <= 0 || ((n land (n - 1)) <> 0) then
+ error no_loc "requested alignment %d is not a power of 2" n
+ in
[
(* Getting help *)
Exact "-help", Unit print_usage_and_exit;
@@ -303,14 +327,18 @@ let cmdline_actions =
[
Exact "-O0", Unit (unset_all optimization_options);
Exact "-O", Unit (set_all optimization_options);
+ _Regexp "-O1", Self (fun _ -> set_all optimization_options (); option_fpostpass := false);
_Regexp "-O[123]$", Unit (set_all optimization_options);
Exact "-Os", Set option_Osize;
+ Exact "-Obranchless", Set option_Obranchless;
+ Exact "-finline-auto-threshold", Integer (fun n -> option_inline_auto_threshold := n);
Exact "-fsmall-data", Integer(fun n -> option_small_data := n);
Exact "-fsmall-const", Integer(fun n -> option_small_const := n);
- Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n);
- Exact "-falign-functions", Integer(fun n -> option_falignfunctions := Some n);
- Exact "-falign-branch-targets", Integer(fun n -> option_falignbranchtargets := n);
- Exact "-falign-cond-branches", Integer(fun n -> option_faligncondbranchs := n);] @
+ Exact "-ffloat-const-prop", Integer(fun n -> option_ffloatconstprop := n);
+ Exact "-falign-functions", Integer(fun n -> check_align n; option_falignfunctions := Some n);
+ Exact "-falign-branch-targets", Integer(fun n -> check_align n; option_falignbranchtargets := n);
+ Exact "-falign-cond-branches", Integer(fun n -> check_align n; option_faligncondbranchs := n);] @
+ f_opt "common" option_fcommon @
(* Target processor options *)
(if Configuration.arch = "arm" then
if Configuration.model = "armv6" then
@@ -369,19 +397,27 @@ let cmdline_actions =
(* Optimization options *)
(* -f options: come in -f and -fno- variants *)
@ f_opt "tailcalls" option_ftailcalls
+ @ f_opt "if-conversion" option_fifconversion
@ f_opt "const-prop" option_fconstprop
@ f_opt "cse" option_fcse
+ @ f_opt "cse2" option_fcse2
@ f_opt "redundancy" option_fredundancy
@ f_opt "postpass" option_fpostpass
- @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched "list"
+ @ [ Exact "-fduplicate", Integer (fun n -> option_fduplicate := n) ]
+ @ f_opt "invertcond" option_finvertcond
+ @ f_opt "tracelinearize" option_ftracelinearize
+ @ f_opt_str "postpass" option_fpostpass option_fpostpass_sched
@ f_opt "inline" option_finline
@ f_opt "inline-functions-called-once" option_finline_functions_called_once
@ f_opt "globaladdrtmp" option_fglobaladdrtmp
@ f_opt "globaladdroffset" option_fglobaladdroffset
@ f_opt "xsaddr" option_fxsaddr
- @ f_opt "coalesce-mem" option_coalesce_mem
@ f_str "div-i32" option_div_i32 "stsud"
@ f_str "div-i64" option_div_i64 "stsud"
+ @ f_opt "addx" option_faddx
+ @ f_opt "coalesce-mem" option_fcoalesce_mem
+ @ f_opt "all-loads-nontrap" option_all_loads_nontrap
+ @ f_opt "forward-moves" option_fforward_moves
(* Code generation options *)
@ f_opt "fpu" option_ffpu
@ f_opt "sse" option_ffpu (* backward compatibility *)
diff --git a/driver/Frontend.ml b/driver/Frontend.ml
index b29bb7f3..b9db0d23 100644
--- a/driver/Frontend.ml
+++ b/driver/Frontend.ml
@@ -11,21 +11,43 @@
(* *)
(* *********************************************************************)
+open Printf
open Clflags
open Commandline
open Driveraux
(* Common frontend functions between clightgen and ccomp *)
+(* Split the version number into major.minor *)
+
+let re_version = Str.regexp {|\([0-9]+\)\.\([0-9]+\)|}
+
+let (v_major, v_minor) =
+ let get n = int_of_string (Str.matched_group n Version.version) in
+ assert (Str.string_match re_version Version.version 0);
+ (get 1, get 2)
+
+let v_number =
+ assert (v_minor < 100);
+ 100 * v_major + v_minor
+
+(* Predefined macros: version numbers, C11 features *)
+
let predefined_macros =
- [
+ let macros = [
"-D__COMPCERT__";
+ sprintf "-D__COMPCERT_MAJOR__=%d" v_major;
+ sprintf "-D__COMPCERT_MINOR__=%d" v_minor;
+ sprintf "-D__COMPCERT_VERSION__=%d" v_number;
"-U__STDC_IEC_559_COMPLEX__";
"-D__STDC_NO_ATOMICS__";
"-D__STDC_NO_COMPLEX__";
"-D__STDC_NO_THREADS__";
"-D__STDC_NO_VLA__"
- ]
+ ] in
+ if Version.buildnr = ""
+ then macros
+ else sprintf "-D__COMPCERT_BUILDNR__=%s" Version.buildnr :: macros
(* From C to preprocessed C *)
@@ -95,9 +117,10 @@ let init () =
then Machine.rv64
else Machine.rv32
| "mppa_k1c" -> Machine.mppa_k1c
+ | "aarch64" -> Machine.aarch64
| _ -> assert false
end;
- Builtins.set C2C.builtins;
+ Env.set_builtins C2C.builtins;
Cutil.declare_attributes C2C.attributes;
CPragmas.initialize()
@@ -110,7 +133,7 @@ let gnu_prepro_opt_key key s =
let gnu_prepro_opt s =
prepro_options := s::!prepro_options
-(* Add gnu preprocessor option s and the implict -E *)
+(* Add gnu preprocessor option s and the implicit -E *)
let gnu_prepro_opt_e s =
prepro_options := s :: !prepro_options;
option_E := true
@@ -150,7 +173,7 @@ let prepro_actions = [
@ (if Configuration.gnu_toolchain then gnu_prepro_actions else [])
let gnu_prepro_help =
-{| -M Ouput a rule suitable for make describing the
+{| -M Output a rule suitable for make describing the
dependencies of the main source file
-MM Like -M but do not mention system header files
-MF <file> Specifies file <file> as output file for -M or -MM
diff --git a/driver/Interp.ml b/driver/Interp.ml
index 6760e76c..d4286779 100644
--- a/driver/Interp.ml
+++ b/driver/Interp.ml
@@ -15,12 +15,12 @@
open Format
open Camlcoq
open AST
-open Integers
+open! Integers
open Values
open Memory
open Globalenvs
open Events
-open Ctypes
+open! Ctypes
open Csyntax
open Csem
@@ -145,7 +145,7 @@ let print_state p (prog, ge, s) =
let compare_mem m1 m2 =
(* assumes nextblocks were already compared equal *)
(* should permissions be taken into account? *)
- Pervasives.compare m1.Mem.mem_contents m2.Mem.mem_contents
+ compare m1.Mem.mem_contents m2.Mem.mem_contents
(* Comparing continuations *)
diff --git a/exportclight/Clightgen.ml b/exportclight/Clightgen.ml
index 1eb4fe03..f7279a5e 100644
--- a/exportclight/Clightgen.ml
+++ b/exportclight/Clightgen.ml
@@ -45,12 +45,7 @@ let compile_c_ast sourcename csyntax ofile =
| Errors.Error msg ->
fatal_error loc "%a" print_error msg in
(* Dump Clight in C syntax if requested *)
- if !option_dclight then begin
- let ofile = Filename.chop_suffix sourcename ".c" ^ ".light.c" in
- let oc = open_out ofile in
- PrintClight.print_program (Format.formatter_of_out_channel oc) clight;
- close_out oc
- end;
+ PrintClight.print_if_2 clight;
(* Print Clight in Coq syntax *)
let oc = open_out ofile in
ExportClight.print_program (Format.formatter_of_out_channel oc)
@@ -60,6 +55,12 @@ let compile_c_ast sourcename csyntax ofile =
(* From C source to Clight *)
let compile_c_file sourcename ifile ofile =
+ let set_dest dst opt ext =
+ dst := if !opt then Some (output_filename sourcename ".c" ext)
+ else None in
+ set_dest Cprint.destination option_dparse ".parsed.c";
+ set_dest PrintCsyntax.destination option_dcmedium ".compcert.c";
+ set_dest PrintClight.destination option_dclight ".light.c";
compile_c_ast sourcename (parse_c_file sourcename ifile) ofile
let output_filename sourcename suff =
@@ -74,7 +75,10 @@ let process_c_file sourcename =
if !option_E then begin
preprocess sourcename "-"
end else begin
- let preproname = Driveraux.tmp_file ".i" in
+ let preproname = if !option_dprepro then
+ Driveraux.output_filename sourcename ".c" ".i"
+ else
+ Driveraux.tmp_file ".i" in
preprocess sourcename preproname;
compile_c_file sourcename preproname ofile
end
@@ -100,9 +104,11 @@ Processing options:
prepro_help ^
language_support_help ^
{|Tracing options:
+ -dprepro Save C file after preprocessing in <file>.i
-dparse Save C file after parsing and elaboration in <file>.parsed.c
-dc Save generated Compcert C in <file>.compcert.c
-dclight Save generated Clight in <file>.light.c
+ -dall Save all generated intermediate files in <file>.<ext>
|} ^
general_help ^
warning_help
@@ -142,9 +148,16 @@ let cmdline_actions =
(* Preprocessing options *)
@ prepro_actions @
(* Tracing options *)
- [ Exact "-dparse", Set option_dparse;
- Exact "-dc", Set option_dcmedium;
- Exact "-dclight", Set option_dclight;]
+ [ Exact "-dprepro", Set option_dprepro;
+ Exact "-dparse", Set option_dparse;
+ Exact "-dc", Set option_dcmedium;
+ Exact "-dclight", Set option_dclight;
+ Exact "-dall", Self (fun _ ->
+ option_dprepro := true;
+ option_dparse := true;
+ option_dcmedium := true;
+ option_dclight := true;);
+ ]
@ general_options
(* Diagnostic options *)
@ warning_options
diff --git a/exportclight/Clightnorm.ml b/exportclight/Clightnorm.ml
index 4b01d777..a0001250 100644
--- a/exportclight/Clightnorm.ml
+++ b/exportclight/Clightnorm.ml
@@ -133,7 +133,7 @@ let rec norm_stmt s =
add_sequence sl (Sreturn(Some e'))
| Sswitch(e, ls) ->
let (sl, e') = norm_expr e in
- add_sequence sl (Sswitch(e, norm_lbl_stmt ls))
+ add_sequence sl (Sswitch(e', norm_lbl_stmt ls))
| Slabel(lbl, s1) ->
Slabel(lbl, norm_stmt s1)
| Sgoto lbl -> s
diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml
index b124586a..c9d6fced 100644
--- a/exportclight/ExportClight.ml
+++ b/exportclight/ExportClight.ml
@@ -18,7 +18,7 @@
open Format
open Camlcoq
open AST
-open Ctypes
+open! Ctypes
open Cop
open Clight
@@ -221,6 +221,14 @@ let asttype p t =
| AST.Tany32 -> "AST.Tany32"
| AST.Tany64 -> "AST.Tany64")
+let astrettype p = function
+ | AST.Tret t -> asttype p t
+ | AST.Tvoid -> fprintf p "AST.Tvoid"
+ | AST.Tint8signed -> fprintf p "AST.Tint8signed"
+ | AST.Tint8unsigned -> fprintf p "AST.Tint8unsigned"
+ | AST.Tint16signed -> fprintf p "AST.Tint16signed"
+ | AST.Tint16unsigned -> fprintf p "AST.Tint16unsigned"
+
let name_of_chunk = function
| Mint8signed -> "Mint8signed"
| Mint8unsigned -> "Mint8unsigned"
@@ -236,7 +244,7 @@ let name_of_chunk = function
let signatur p sg =
fprintf p "@[<hov 2>(mksignature@ %a@ %a@ %a)@]"
(print_list asttype) sg.sig_args
- (print_option asttype) sg.sig_res
+ astrettype sg.sig_res
callconv sg.sig_cc
let assertions = ref ([]: (string * typ list) list)
@@ -381,7 +389,7 @@ and lblstmts p = function
(print_option coqZ) lbl stmt s lblstmts ls
let print_function p (id, f) =
- fprintf p "Definition f_%s := {|@ " (extern_atom id);
+ fprintf p "Definition f_%s := {|@ " (sanitize (extern_atom id));
fprintf p " fn_return := %a;@ " typ f.fn_return;
fprintf p " fn_callconv := %a;@ " callconv f.fn_callconv;
fprintf p " fn_params := %a;@ " (print_list (print_pair ident typ)) f.fn_params;
@@ -402,7 +410,7 @@ let init_data p = function
| Init_addrof(id,ofs) -> fprintf p "Init_addrof %a %a" ident id coqptrofs ofs
let print_variable p (id, v) =
- fprintf p "Definition v_%s := {|@ " (extern_atom id);
+ fprintf p "Definition v_%s := {|@ " (sanitize (extern_atom id));
fprintf p " gvar_info := %a;@ " typ v.gvar_info;
fprintf p " gvar_init := %a;@ " (print_list init_data) v.gvar_init;
fprintf p " gvar_readonly := %B;@ " v.gvar_readonly;
@@ -417,12 +425,12 @@ let print_globdef p (id, gd) =
let print_ident_globdef p = function
| (id, Gfun(Ctypes.Internal f)) ->
- fprintf p "(%a, Gfun(Internal f_%s))" ident id (extern_atom id)
+ fprintf p "(%a, Gfun(Internal f_%s))" ident id (sanitize (extern_atom id))
| (id, Gfun(Ctypes.External(ef, targs, tres, cc))) ->
fprintf p "@[<hov 2>(%a,@ @[<hov 2>Gfun(External %a@ %a@ %a@ %a))@]@]"
ident id external_function ef typlist targs typ tres callconv cc
| (id, Gvar v) ->
- fprintf p "(%a, Gvar v_%s)" ident id (extern_atom id)
+ fprintf p "(%a, Gvar v_%s)" ident id (sanitize (extern_atom id))
(* Composite definitions *)
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 979e1d49..9b568951 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -34,7 +34,6 @@ Require Clight.
Require Compiler.
Require Parser.
Require Initializers.
-Require Int31.
Require Asmaux.
(* Standard lib *)
@@ -73,6 +72,7 @@ Extract Constant Iteration.GenIter.iterate =>
(* Selection *)
Extract Constant Selection.compile_switch => "Switchaux.compile_switch".
+Extract Constant Selection.if_conversion_heuristic => "Selectionaux.if_conversion_heuristic".
(* RTLgen *)
Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely".
@@ -105,10 +105,14 @@ Extract Constant Compopts.generate_float_constants =>
"fun _ -> !Clflags.option_ffloatconstprop >= 2".
Extract Constant Compopts.optim_tailcalls =>
"fun _ -> !Clflags.option_ftailcalls".
+Extract Constant Compopts.optim_duplicate =>
+ "fun _ -> (if !Clflags.option_fduplicate = -1 then false else true)".
Extract Constant Compopts.optim_constprop =>
"fun _ -> !Clflags.option_fconstprop".
Extract Constant Compopts.optim_CSE =>
"fun _ -> !Clflags.option_fcse".
+Extract Constant Compopts.optim_CSE2 =>
+ "fun _ -> !Clflags.option_fcse2".
Extract Constant Compopts.optim_redundancy =>
"fun _ -> !Clflags.option_fredundancy".
Extract Constant Compopts.optim_postpass =>
@@ -117,14 +121,22 @@ Extract Constant Compopts.thumb =>
"fun _ -> !Clflags.option_mthumb".
Extract Constant Compopts.debug =>
"fun _ -> !Clflags.option_g".
-Extract Constant Compopts.optim_fglobaladdrtmp =>
+Extract Constant Compopts.optim_globaladdrtmp =>
"fun _ -> !Clflags.option_fglobaladdrtmp".
-Extract Constant Compopts.optim_fglobaladdroffset =>
+Extract Constant Compopts.optim_globaladdroffset =>
"fun _ -> !Clflags.option_fglobaladdroffset".
-Extract Constant Compopts.optim_fxsaddr =>
+Extract Constant Compopts.optim_xsaddr =>
"fun _ -> !Clflags.option_fxsaddr".
+Extract Constant Compopts.optim_addx =>
+ "fun _ -> !Clflags.option_faddx".
Extract Constant Compopts.optim_coalesce_mem =>
- "fun _ -> !Clflags.option_coalesce_mem".
+ "fun _ -> !Clflags.option_fcoalesce_mem".
+Extract Constant Compopts.optim_forward_moves =>
+ "fun _ -> !Clflags.option_fforward_moves".
+Extract Constant Compopts.va_strict =>
+ "fun _ -> false".
+Extract Constant Compopts.all_loads_nontrap =>
+ "fun _ -> !Clflags.option_all_loads_nontrap".
(* Compiler *)
Extract Constant Compiler.print_Clight => "PrintClight.print_if".
@@ -134,11 +146,12 @@ Extract Constant Compiler.print_LTL => "PrintLTL.print_if".
Extract Constant Compiler.print_Mach => "PrintMach.print_if".
Extract Constant Compiler.print => "fun (f: 'a -> unit) (x: 'a) -> f x; x".
Extract Constant Compiler.time => "Timing.time_coq".
+Extract Constant Compopts.time => "Timing.time_coq".
(*Extraction Inline Compiler.apply_total Compiler.apply_partial.*)
(* Cabs *)
-Extract Constant Cabs.cabsloc =>
+Extract Constant Cabs.loc =>
"{ lineno : int;
filename: string;
byteno: int;
@@ -147,15 +160,6 @@ Extract Constant Cabs.cabsloc =>
Extract Inlined Constant Cabs.string => "String.t".
Extract Constant Cabs.char_code => "int64".
-(* Int31 *)
-Extract Inductive Int31.digits => "bool" [ "false" "true" ].
-Extract Inductive Int31.int31 => "int" [ "Camlcoq.Int31.constr" ] "Camlcoq.Int31.destr".
-Extract Constant Int31.twice => "Camlcoq.Int31.twice".
-Extract Constant Int31.twice_plus_one => "Camlcoq.Int31.twice_plus_one".
-Extract Constant Int31.compare31 => "Camlcoq.Int31.compare".
-Extract Constant Int31.On => "0".
-Extract Constant Int31.In => "1".
-
(* Processor-specific extraction directives *)
Load extractionMachdep.
@@ -164,11 +168,11 @@ Load extractionMachdep.
Extraction Blacklist List String Int.
(* Cutting the dependency to R. *)
-Extract Inlined Constant Fcore_defs.F2R => "fun _ -> assert false".
-Extract Inlined Constant Fappli_IEEE.FF2R => "fun _ -> assert false".
-Extract Inlined Constant Fappli_IEEE.B2R => "fun _ -> assert false".
-Extract Inlined Constant Fappli_IEEE.round_mode => "fun _ -> assert false".
-Extract Inlined Constant Fcalc_bracket.inbetween_loc => "fun _ -> assert false".
+Extract Inlined Constant Defs.F2R => "fun _ -> assert false".
+Extract Inlined Constant Binary.FF2R => "fun _ -> assert false".
+Extract Inlined Constant Binary.B2R => "fun _ -> assert false".
+Extract Inlined Constant Binary.round_mode => "fun _ -> assert false".
+Extract Inlined Constant Bracket.inbetween_loc => "fun _ -> assert false".
(* Needed in Coq 8.4 to avoid problems with Function definitions. *)
Set Extraction AccessOpaque.
@@ -182,9 +186,10 @@ Separate Extraction
Cexec.do_initial_state Cexec.do_step Cexec.at_final_state
Ctypes.merge_attributes Ctypes.remove_attributes Ctypes.build_composite_env
Initializers.transl_init Initializers.constval
- Csyntax.Eindex Csyntax.Epreincr
+ Csyntax.Eindex Csyntax.Epreincr Csyntax.Eselection
Ctyping.typecheck_program
Ctyping.epostincr Ctyping.epostdecr Ctyping.epreincr Ctyping.epredecr
+ Ctyping.eselection
Ctypes.make_program
Clight.type_of_function
Conventions1.callee_save_type Conventions1.is_float_reg
diff --git a/flocq/Appli/Fappli_IEEE.v b/flocq/Appli/Fappli_IEEE.v
deleted file mode 100644
index 7503dc1d..00000000
--- a/flocq/Appli/Fappli_IEEE.v
+++ /dev/null
@@ -1,1920 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * IEEE-754 arithmetic *)
-Require Import Fcore.
-Require Import Fcore_digits.
-Require Import Fcalc_digits.
-Require Import Fcalc_round.
-Require Import Fcalc_bracket.
-Require Import Fcalc_ops.
-Require Import Fcalc_div.
-Require Import Fcalc_sqrt.
-Require Import Fprop_relative.
-
-Section AnyRadix.
-
-Inductive full_float :=
- | F754_zero : bool -> full_float
- | F754_infinity : bool -> full_float
- | F754_nan : bool -> positive -> full_float
- | F754_finite : bool -> positive -> Z -> full_float.
-
-Definition FF2R beta x :=
- match x with
- | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e)
- | _ => 0%R
- end.
-
-End AnyRadix.
-
-Section Binary.
-
-Arguments exist {A P} x _.
-
-(** [prec] is the number of bits of the mantissa including the implicit one;
- [emax] is the exponent of the infinities.
- For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
-Variable prec emax : Z.
-Context (prec_gt_0_ : Prec_gt_0 prec).
-Hypothesis Hmax : (prec < emax)%Z.
-
-Let emin := (3 - emax - prec)%Z.
-Let fexp := FLT_exp emin prec.
-Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
-Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
-
-Definition canonic_mantissa m e :=
- Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
-
-Definition bounded m e :=
- andb (canonic_mantissa m e) (Zle_bool e (emax - prec)).
-
-Definition valid_binary x :=
- match x with
- | F754_finite _ m e => bounded m e
- | F754_nan _ pl => (Zpos (digits2_pos pl) <? prec)%Z
- | _ => true
- end.
-
-(** Basic type used for representing binary FP numbers.
- Note that there is exactly one such object per FP datum. *)
-
-Definition nan_pl := {pl | (Zpos (digits2_pos pl) <? prec)%Z = true}.
-
-Inductive binary_float :=
- | B754_zero : bool -> binary_float
- | B754_infinity : bool -> binary_float
- | B754_nan : bool -> nan_pl -> binary_float
- | B754_finite : bool ->
- forall (m : positive) (e : Z), bounded m e = true -> binary_float.
-
-Definition FF2B x :=
- match x as x return valid_binary x = true -> binary_float with
- | F754_finite s m e => B754_finite s m e
- | F754_infinity s => fun _ => B754_infinity s
- | F754_zero s => fun _ => B754_zero s
- | F754_nan b pl => fun H => B754_nan b (exist pl H)
- end.
-
-Definition B2FF x :=
- match x with
- | B754_finite s m e _ => F754_finite s m e
- | B754_infinity s => F754_infinity s
- | B754_zero s => F754_zero s
- | B754_nan b (exist pl _) => F754_nan b pl
- end.
-
-Definition B2R f :=
- match f with
- | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
- | _ => 0%R
- end.
-
-Theorem FF2R_B2FF :
- forall x,
- FF2R radix2 (B2FF x) = B2R x.
-Proof.
-now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx].
-Qed.
-
-Theorem B2FF_FF2B :
- forall x Hx,
- B2FF (FF2B x Hx) = x.
-Proof.
-now intros [sx|sx|sx plx|sx mx ex] Hx.
-Qed.
-
-Theorem valid_binary_B2FF :
- forall x,
- valid_binary (B2FF x) = true.
-Proof.
-now intros [sx|sx|sx [plx Hplx]|sx mx ex Hx].
-Qed.
-
-Theorem FF2B_B2FF :
- forall x H,
- FF2B (B2FF x) H = x.
-Proof.
-intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] H ; try easy.
-simpl. apply f_equal, f_equal, eqbool_irrelevance.
-apply f_equal, eqbool_irrelevance.
-Qed.
-
-Theorem FF2B_B2FF_valid :
- forall x,
- FF2B (B2FF x) (valid_binary_B2FF x) = x.
-Proof.
-intros x.
-apply FF2B_B2FF.
-Qed.
-
-Theorem B2R_FF2B :
- forall x Hx,
- B2R (FF2B x Hx) = FF2R radix2 x.
-Proof.
-now intros [sx|sx|sx plx|sx mx ex] Hx.
-Qed.
-
-Theorem match_FF2B :
- forall {T} fz fi fn ff x Hx,
- match FF2B x Hx return T with
- | B754_zero sx => fz sx
- | B754_infinity sx => fi sx
- | B754_nan b (exist p _) => fn b p
- | B754_finite sx mx ex _ => ff sx mx ex
- end =
- match x with
- | F754_zero sx => fz sx
- | F754_infinity sx => fi sx
- | F754_nan b p => fn b p
- | F754_finite sx mx ex => ff sx mx ex
- end.
-Proof.
-now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx.
-Qed.
-
-Theorem canonic_canonic_mantissa :
- forall (sx : bool) mx ex,
- canonic_mantissa mx ex = true ->
- canonic radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex).
-Proof.
-intros sx mx ex H.
-assert (Hx := Zeq_bool_eq _ _ H). clear H.
-apply sym_eq.
-simpl.
-pattern ex at 2 ; rewrite <- Hx.
-apply (f_equal fexp).
-rewrite ln_beta_F2R_Zdigits.
-rewrite <- Zdigits_abs.
-rewrite Zpos_digits2_pos.
-now case sx.
-now case sx.
-Qed.
-
-Theorem generic_format_B2R :
- forall x,
- generic_format radix2 fexp (B2R x).
-Proof.
-intros [sx|sx|sx plx|sx mx ex Hx] ; try apply generic_format_0.
-simpl.
-apply generic_format_canonic.
-apply canonic_canonic_mantissa.
-now destruct (andb_prop _ _ Hx) as (H, _).
-Qed.
-
-Theorem FLT_format_B2R :
- forall x,
- FLT_format radix2 emin prec (B2R x).
-Proof with auto with typeclass_instances.
-intros x.
-apply FLT_format_generic...
-apply generic_format_B2R.
-Qed.
-
-Theorem B2FF_inj :
- forall x y : binary_float,
- B2FF x = B2FF y ->
- x = y.
-Proof.
-intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] [sy|sy|sy [ply Hply]|sy my ey Hy] ; try easy.
-(* *)
-intros H.
-now inversion H.
-(* *)
-intros H.
-now inversion H.
-(* *)
-intros H.
-inversion H.
-clear H.
-revert Hplx.
-rewrite H2.
-intros Hx.
-apply f_equal, f_equal, eqbool_irrelevance.
-(* *)
-intros H.
-inversion H.
-clear H.
-revert Hx.
-rewrite H2, H3.
-intros Hx.
-apply f_equal, eqbool_irrelevance.
-Qed.
-
-Definition is_finite_strict f :=
- match f with
- | B754_finite _ _ _ _ => true
- | _ => false
- end.
-
-Theorem B2R_inj:
- forall x y : binary_float,
- is_finite_strict x = true ->
- is_finite_strict y = true ->
- B2R x = B2R y ->
- x = y.
-Proof.
-intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy.
-simpl.
-intros _ _ Heq.
-assert (Hs: sx = sy).
-(* *)
-revert Heq. clear.
-case sx ; case sy ; try easy ;
- intros Heq ; apply False_ind ; revert Heq.
-apply Rlt_not_eq.
-apply Rlt_trans with R0.
-now apply F2R_lt_0_compat.
-now apply F2R_gt_0_compat.
-apply Rgt_not_eq.
-apply Rgt_trans with R0.
-now apply F2R_gt_0_compat.
-now apply F2R_lt_0_compat.
-assert (mx = my /\ ex = ey).
-(* *)
-refine (_ (canonic_unicity _ fexp _ _ _ _ Heq)).
-rewrite Hs.
-now case sy ; intro H ; injection H ; split.
-apply canonic_canonic_mantissa.
-exact (proj1 (andb_prop _ _ Hx)).
-apply canonic_canonic_mantissa.
-exact (proj1 (andb_prop _ _ Hy)).
-(* *)
-revert Hx.
-rewrite Hs, (proj1 H), (proj2 H).
-intros Hx.
-apply f_equal.
-apply eqbool_irrelevance.
-Qed.
-
-Definition Bsign x :=
- match x with
- | B754_nan s _ => s
- | B754_zero s => s
- | B754_infinity s => s
- | B754_finite s _ _ _ => s
- end.
-
-Definition sign_FF x :=
- match x with
- | F754_nan s _ => s
- | F754_zero s => s
- | F754_infinity s => s
- | F754_finite s _ _ => s
- end.
-
-Theorem Bsign_FF2B :
- forall x H,
- Bsign (FF2B x H) = sign_FF x.
-Proof.
-now intros [sx|sx|sx plx|sx mx ex] H.
-Qed.
-
-Definition is_finite f :=
- match f with
- | B754_finite _ _ _ _ => true
- | B754_zero _ => true
- | _ => false
- end.
-
-Definition is_finite_FF f :=
- match f with
- | F754_finite _ _ _ => true
- | F754_zero _ => true
- | _ => false
- end.
-
-Theorem is_finite_FF2B :
- forall x Hx,
- is_finite (FF2B x Hx) = is_finite_FF x.
-Proof.
-now intros [| | |].
-Qed.
-
-Theorem is_finite_FF_B2FF :
- forall x,
- is_finite_FF (B2FF x) = is_finite x.
-Proof.
-now intros [| |? []|].
-Qed.
-
-Theorem B2R_Bsign_inj:
- forall x y : binary_float,
- is_finite x = true ->
- is_finite y = true ->
- B2R x = B2R y ->
- Bsign x = Bsign y ->
- x = y.
-Proof.
-intros. destruct x, y; try (apply B2R_inj; now eauto).
-- simpl in H2. congruence.
-- symmetry in H1. apply Rmult_integral in H1.
- destruct H1. apply (eq_Z2R _ 0) in H1. destruct b0; discriminate H1.
- simpl in H1. pose proof (bpow_gt_0 radix2 e).
- rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
-- apply Rmult_integral in H1.
- destruct H1. apply (eq_Z2R _ 0) in H1. destruct b; discriminate H1.
- simpl in H1. pose proof (bpow_gt_0 radix2 e).
- rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
-Qed.
-
-Definition is_nan f :=
- match f with
- | B754_nan _ _ => true
- | _ => false
- end.
-
-Definition is_nan_FF f :=
- match f with
- | F754_nan _ _ => true
- | _ => false
- end.
-
-Theorem is_nan_FF2B :
- forall x Hx,
- is_nan (FF2B x Hx) = is_nan_FF x.
-Proof.
-now intros [| | |].
-Qed.
-
-Theorem is_nan_FF_B2FF :
- forall x,
- is_nan_FF (B2FF x) = is_nan x.
-Proof.
-now intros [| |? []|].
-Qed.
-
-(** Opposite *)
-
-Definition Bopp opp_nan x :=
- match x with
- | B754_nan sx plx =>
- let '(sres, plres) := opp_nan sx plx in B754_nan sres plres
- | B754_infinity sx => B754_infinity (negb sx)
- | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
- | B754_zero sx => B754_zero (negb sx)
- end.
-
-Theorem Bopp_involutive :
- forall opp_nan x,
- is_nan x = false ->
- Bopp opp_nan (Bopp opp_nan x) = x.
-Proof.
-now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive.
-Qed.
-
-Theorem B2R_Bopp :
- forall opp_nan x,
- B2R (Bopp opp_nan x) = (- B2R x)%R.
-Proof.
-intros opp_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0.
-simpl. destruct opp_nan. apply Ropp_0.
-simpl.
-rewrite <- F2R_opp.
-now case sx.
-Qed.
-
-Theorem is_finite_Bopp :
- forall opp_nan x,
- is_finite (Bopp opp_nan x) = is_finite x.
-Proof.
-intros opp_nan [| |s pl|] ; try easy.
-simpl.
-now case opp_nan.
-Qed.
-
-(** Absolute value *)
-
-Definition Babs abs_nan (x : binary_float) : binary_float :=
- match x with
- | B754_nan sx plx =>
- let '(sres, plres) := abs_nan sx plx in B754_nan sres plres
- | B754_infinity sx => B754_infinity false
- | B754_finite sx mx ex Hx => B754_finite false mx ex Hx
- | B754_zero sx => B754_zero false
- end.
-
-Theorem B2R_Babs :
- forall abs_nan x,
- B2R (Babs abs_nan x) = Rabs (B2R x).
-Proof.
- intros abs_nan [sx|sx|sx plx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0.
- simpl. destruct abs_nan. simpl. apply Rabs_R0.
- simpl. rewrite <- F2R_abs. now destruct sx.
-Qed.
-
-Theorem is_finite_Babs :
- forall abs_nan x,
- is_finite (Babs abs_nan x) = is_finite x.
-Proof.
- intros abs_nan [| |s pl|] ; try easy.
- simpl.
- now case abs_nan.
-Qed.
-
-Theorem Bsign_Babs :
- forall abs_nan x,
- is_nan x = false ->
- Bsign (Babs abs_nan x) = false.
-Proof.
- now intros abs_nan [| | |].
-Qed.
-
-Theorem Babs_idempotent :
- forall abs_nan (x: binary_float),
- is_nan x = false ->
- Babs abs_nan (Babs abs_nan x) = Babs abs_nan x.
-Proof.
- now intros abs_nan [sx|sx|sx plx|sx mx ex Hx].
-Qed.
-
-Theorem Babs_Bopp :
- forall abs_nan opp_nan x,
- is_nan x = false ->
- Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x.
-Proof.
- now intros abs_nan opp_nan [| | |].
-Qed.
-
-(** Comparison
-
-[Some c] means ordered as per [c]; [None] means unordered. *)
-
-Definition Bcompare (f1 f2 : binary_float) : option comparison :=
- match f1, f2 with
- | B754_nan _ _,_ | _,B754_nan _ _ => None
- | B754_infinity true, B754_infinity true
- | B754_infinity false, B754_infinity false => Some Eq
- | B754_infinity true, _ => Some Lt
- | B754_infinity false, _ => Some Gt
- | _, B754_infinity true => Some Gt
- | _, B754_infinity false => Some Lt
- | B754_finite true _ _ _, B754_zero _ => Some Lt
- | B754_finite false _ _ _, B754_zero _ => Some Gt
- | B754_zero _, B754_finite true _ _ _ => Some Gt
- | B754_zero _, B754_finite false _ _ _ => Some Lt
- | B754_zero _, B754_zero _ => Some Eq
- | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
- match s1, s2 with
- | true, false => Some Lt
- | false, true => Some Gt
- | false, false =>
- match Zcompare e1 e2 with
- | Lt => Some Lt
- | Gt => Some Gt
- | Eq => Some (Pcompare m1 m2 Eq)
- end
- | true, true =>
- match Zcompare e1 e2 with
- | Lt => Some Gt
- | Gt => Some Lt
- | Eq => Some (CompOpp (Pcompare m1 m2 Eq))
- end
- end
- end.
-
-Theorem Bcompare_correct :
- forall f1 f2,
- is_finite f1 = true -> is_finite f2 = true ->
- Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)).
-Proof.
- Ltac apply_Rcompare :=
- match goal with
- | [ |- Some Lt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Lt
- | [ |- Some Eq = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Eq
- | [ |- Some Gt = Some (Rcompare _ _) ] => f_equal; symmetry; apply Rcompare_Gt
- end.
- unfold Bcompare; intros.
- destruct f1, f2 ; try easy.
- now rewrite Rcompare_Eq.
- destruct b0 ; apply_Rcompare.
- now apply F2R_lt_0_compat.
- now apply F2R_gt_0_compat.
- destruct b ; apply_Rcompare.
- now apply F2R_lt_0_compat.
- now apply F2R_gt_0_compat.
- simpl.
- clear H H0.
- apply andb_prop in e0; destruct e0; apply (canonic_canonic_mantissa false) in H.
- apply andb_prop in e2; destruct e2; apply (canonic_canonic_mantissa false) in H1.
- pose proof (Zcompare_spec e e1); unfold canonic, Fexp in H1, H.
- assert (forall m1 m2 e1 e2,
- let x := (Z2R (Zpos m1) * bpow radix2 e1)%R in
- let y := (Z2R (Zpos m2) * bpow radix2 e2)%R in
- (canonic_exp radix2 fexp x < canonic_exp radix2 fexp y)%Z -> (x < y)%R).
- {
- intros; apply Rnot_le_lt; intro; apply (ln_beta_le radix2) in H5.
- apply Zlt_not_le with (1 := H4).
- now apply fexp_monotone.
- now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)).
- }
- assert (forall m1 m2 e1 e2, (Z2R (- Zpos m1) * bpow radix2 e1 < Z2R (Zpos m2) * bpow radix2 e2)%R).
- {
- intros; apply (Rlt_trans _ 0%R).
- now apply (F2R_lt_0_compat _ (Float radix2 (Zneg m1) e0)).
- now apply (F2R_gt_0_compat _ (Float radix2 (Zpos m2) e2)).
- }
- unfold F2R, Fnum, Fexp.
- destruct b, b0; try (now apply_Rcompare; apply H5); inversion H3;
- try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption);
- try (apply_Rcompare; do 2 rewrite Z2R_opp, Ropp_mult_distr_l_reverse;
- apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption);
- rewrite H7, Rcompare_mult_r, Rcompare_Z2R by (apply bpow_gt_0); reflexivity.
-Qed.
-
-Theorem Bcompare_swap :
- forall x y,
- Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end.
-Proof.
- intros.
- destruct x as [ ? | [] | ? ? | [] mx ex Bx ];
- destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy.
-- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
- now rewrite (Pcompare_antisym mx my).
-- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
- now rewrite Pcompare_antisym.
-Qed.
-
-Theorem bounded_lt_emax :
- forall mx ex,
- bounded mx ex = true ->
- (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R.
-Proof.
-intros mx ex Hx.
-destruct (andb_prop _ _ Hx) as (H1,H2).
-generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
-generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
-generalize (ln_beta_F2R_Zdigits radix2 (Zpos mx) ex).
-destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
-unfold ln_beta_val.
-intros H.
-apply Rlt_le_trans with (bpow radix2 e').
-change (Zpos mx) with (Zabs (Zpos mx)).
-rewrite F2R_Zabs.
-apply Ex.
-apply Rgt_not_eq.
-now apply F2R_gt_0_compat.
-apply bpow_le.
-rewrite H. 2: discriminate.
-revert H1. clear -H2.
-rewrite Zpos_digits2_pos.
-unfold fexp, FLT_exp.
-generalize (Zdigits radix2 (Zpos mx)).
-clearbody emin.
-intros ; zify ; omega.
-Qed.
-
-Theorem abs_B2R_lt_emax :
- forall x,
- (Rabs (B2R x) < bpow radix2 emax)%R.
-Proof.
-intros [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ).
-rewrite <- F2R_Zabs, abs_cond_Zopp.
-now apply bounded_lt_emax.
-Qed.
-
-Theorem bounded_canonic_lt_emax :
- forall mx ex,
- canonic radix2 fexp (Float radix2 (Zpos mx) ex) ->
- (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R ->
- bounded mx ex = true.
-Proof.
-intros mx ex Cx Bx.
-apply andb_true_intro.
-split.
-unfold canonic_mantissa.
-unfold canonic, Fexp in Cx.
-rewrite Cx at 2.
-rewrite Zpos_digits2_pos.
-unfold canonic_exp.
-rewrite ln_beta_F2R_Zdigits. 2: discriminate.
-now apply -> Zeq_is_eq_bool.
-apply Zle_bool_true.
-unfold canonic, Fexp in Cx.
-rewrite Cx.
-unfold canonic_exp, fexp, FLT_exp.
-destruct (ln_beta radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl.
-apply Zmax_lub.
-cut (e' - 1 < emax)%Z. clear ; omega.
-apply lt_bpow with radix2.
-apply Rle_lt_trans with (2 := Bx).
-change (Zpos mx) with (Zabs (Zpos mx)).
-rewrite F2R_Zabs.
-apply Ex.
-apply Rgt_not_eq.
-now apply F2R_gt_0_compat.
-unfold emin.
-generalize (prec_gt_0 prec).
-clear -Hmax ; omega.
-Qed.
-
-(** Truncation *)
-
-Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
-
-Definition shr_1 mrs :=
- let '(Build_shr_record m r s) := mrs in
- let s := orb r s in
- match m with
- | Z0 => Build_shr_record Z0 false s
- | Zpos xH => Build_shr_record Z0 true s
- | Zpos (xO p) => Build_shr_record (Zpos p) false s
- | Zpos (xI p) => Build_shr_record (Zpos p) true s
- | Zneg xH => Build_shr_record Z0 true s
- | Zneg (xO p) => Build_shr_record (Zneg p) false s
- | Zneg (xI p) => Build_shr_record (Zneg p) true s
- end.
-
-Definition loc_of_shr_record mrs :=
- match mrs with
- | Build_shr_record _ false false => loc_Exact
- | Build_shr_record _ false true => loc_Inexact Lt
- | Build_shr_record _ true false => loc_Inexact Eq
- | Build_shr_record _ true true => loc_Inexact Gt
- end.
-
-Definition shr_record_of_loc m l :=
- match l with
- | loc_Exact => Build_shr_record m false false
- | loc_Inexact Lt => Build_shr_record m false true
- | loc_Inexact Eq => Build_shr_record m true false
- | loc_Inexact Gt => Build_shr_record m true true
- end.
-
-Theorem shr_m_shr_record_of_loc :
- forall m l,
- shr_m (shr_record_of_loc m l) = m.
-Proof.
-now intros m [|[| |]].
-Qed.
-
-Theorem loc_of_shr_record_of_loc :
- forall m l,
- loc_of_shr_record (shr_record_of_loc m l) = l.
-Proof.
-now intros m [|[| |]].
-Qed.
-
-Definition shr mrs e n :=
- match n with
- | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
- | _ => (mrs, e)
- end.
-
-Lemma inbetween_shr_1 :
- forall x mrs e,
- (0 <= shr_m mrs)%Z ->
- inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) ->
- inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)).
-Proof.
-intros x mrs e Hm Hl.
-refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy.
-2: apply bpow_gt_0.
-2: now case (shr_r (shr_1 mrs)) ; split.
-change (Z2R 2) with (bpow radix2 1).
-rewrite <- bpow_plus.
-rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)).
-unfold inbetween_float, F2R. simpl.
-rewrite Z2R_plus, Rmult_plus_distr_r.
-replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)).
-easy.
-clear -Hm.
-destruct mrs as (m, r, s).
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-rewrite (F2R_change_exp radix2 e).
-2: apply Zle_succ.
-unfold F2R. simpl.
-rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus.
-rewrite Zplus_assoc.
-replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs).
-exact Hl.
-ring_simplify (e + 1 - e)%Z.
-change (2^1)%Z with 2%Z.
-rewrite Zmult_comm.
-clear -Hm.
-destruct mrs as (m, r, s).
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-Qed.
-
-Theorem inbetween_shr :
- forall x m e l n,
- (0 <= m)%Z ->
- inbetween_float radix2 m e x l ->
- let '(mrs, e') := shr (shr_record_of_loc m l) e n in
- inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs).
-Proof.
-intros x m e l n Hm Hl.
-destruct n as [|n|n].
-now destruct l as [|[| |]].
-2: now destruct l as [|[| |]].
-unfold shr.
-rewrite iter_pos_nat.
-rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
-induction (nat_of_P n).
-simpl.
-rewrite Zplus_0_r.
-now destruct l as [|[| |]].
-rewrite iter_nat_S.
-rewrite inj_S.
-unfold Zsucc.
-rewrite Zplus_assoc.
-revert IHn0.
-apply inbetween_shr_1.
-clear -Hm.
-induction n0.
-now destruct l as [|[| |]].
-rewrite iter_nat_S.
-revert IHn0.
-generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)).
-clear.
-intros (m, r, s) Hm.
-now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
-Qed.
-
-Definition shr_fexp m e l :=
- shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).
-
-Theorem shr_truncate :
- forall m e l,
- (0 <= m)%Z ->
- shr_fexp m e l =
- let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').
-Proof.
-intros m e l Hm.
-case_eq (truncate radix2 fexp (m, e, l)).
-intros (m', e') l'.
-unfold shr_fexp.
-rewrite Zdigits2_Zdigits.
-case_eq (fexp (Zdigits radix2 m + e) - e)%Z.
-(* *)
-intros He.
-unfold truncate.
-rewrite He.
-simpl.
-intros H.
-now inversion H.
-(* *)
-intros p Hp.
-assert (He: (e <= fexp (Zdigits radix2 m + e))%Z).
-clear -Hp ; zify ; omega.
-destruct (inbetween_float_ex radix2 m e l) as (x, Hx).
-generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx).
-assert (Hx0 : (0 <= x)%R).
-apply Rle_trans with (F2R (Float radix2 m e)).
-now apply F2R_ge_0_compat.
-exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)).
-case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)).
-intros mrs e'' H3 H4 H1.
-generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)).
-rewrite H1.
-intros (H2,_).
-rewrite <- Hp, H3.
-assert (e'' = e').
-change (snd (mrs, e'') = snd (fst (m',e',l'))).
-rewrite <- H1, <- H3.
-unfold truncate.
-now rewrite Hp.
-rewrite H in H4 |- *.
-apply (f_equal (fun v => (v, _))).
-destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6).
-rewrite H5, H6.
-case mrs.
-now intros m0 [|] [|].
-(* *)
-intros p Hp.
-unfold truncate.
-rewrite Hp.
-simpl.
-intros H.
-now inversion H.
-Qed.
-
-(** Rounding modes *)
-
-Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
-
-Definition round_mode m :=
- match m with
- | mode_NE => ZnearestE
- | mode_ZR => Ztrunc
- | mode_DN => Zfloor
- | mode_UP => Zceil
- | mode_NA => ZnearestA
- end.
-
-Definition choice_mode m sx mx lx :=
- match m with
- | mode_NE => cond_incr (round_N (negb (Zeven mx)) lx) mx
- | mode_ZR => mx
- | mode_DN => cond_incr (round_sign_DN sx lx) mx
- | mode_UP => cond_incr (round_sign_UP sx lx) mx
- | mode_NA => cond_incr (round_N true lx) mx
- end.
-
-Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m).
-Proof.
-destruct m ; unfold round_mode ; auto with typeclass_instances.
-Qed.
-
-Definition overflow_to_inf m s :=
- match m with
- | mode_NE => true
- | mode_NA => true
- | mode_ZR => false
- | mode_UP => negb s
- | mode_DN => s
- end.
-
-Definition binary_overflow m s :=
- if overflow_to_inf m s then F754_infinity s
- else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec).
-
-Definition binary_round_aux mode sx mx ex lx :=
- let '(mrs', e') := shr_fexp (Zpos mx) ex lx in
- let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
- match shr_m mrs'' with
- | Z0 => F754_zero sx
- | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx
- | _ => F754_nan false xH (* dummy *)
- end.
-
-Theorem binary_round_aux_correct :
- forall mode x mx ex lx,
- inbetween_float radix2 (Zpos mx) ex (Rabs x) lx ->
- (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z ->
- let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in
- valid_binary z = true /\
- if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
- FF2R radix2 z = round radix2 fexp (round_mode mode) x /\
- is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
- else
- z = binary_overflow mode (Rlt_bool x 0).
-Proof with auto with typeclass_instances.
-intros m x mx ex lx Bx Ex z.
-unfold binary_round_aux in z.
-revert z.
-rewrite shr_truncate. 2: easy.
-refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))).
-refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)).
-destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1).
-rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
-set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
-intros (H1a,H1b) H1c.
-rewrite H1c.
-assert (Hm: (m1 <= m1')%Z).
-(* . *)
-unfold m1', choice_mode, cond_incr.
-case m ;
- try apply Zle_refl ;
- match goal with |- (m1 <= if ?b then _ else _)%Z =>
- case b ; [ apply Zle_succ | apply Zle_refl ] end.
-assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
-(* . *)
-rewrite <- (Zabs_eq m1').
-replace (Zabs m1') with (Zabs (cond_Zopp (Rlt_bool x 0) m1')).
-rewrite F2R_Zabs.
-now apply f_equal.
-apply abs_cond_Zopp.
-apply Zle_trans with (2 := Hm).
-apply Zlt_succ_le.
-apply F2R_gt_0_reg with radix2 e1.
-apply Rle_lt_trans with (1 := Rabs_pos x).
-exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
-(* . *)
-assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
-now apply inbetween_Exact.
-destruct m1' as [|m1'|m1'].
-(* . m1' = 0 *)
-rewrite shr_truncate. 2: apply Zle_refl.
-generalize (truncate_0 radix2 fexp e1 loc_Exact).
-destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros Hm2.
-rewrite Hm2.
-repeat split.
-rewrite Rlt_bool_true.
-repeat split.
-apply sym_eq.
-case Rlt_bool ; apply F2R_0.
-rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
-apply bpow_gt_0.
-(* . 0 < m1' *)
-assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
-rewrite <- ln_beta_F2R_Zdigits, <- Hr, ln_beta_abs.
-2: discriminate.
-rewrite H1b.
-rewrite canonic_exp_abs.
-fold (canonic_exp radix2 fexp (round radix2 fexp (round_mode m) x)).
-apply canonic_exp_round_ge...
-rewrite H1c.
-case (Rlt_bool x 0).
-apply Rlt_not_eq.
-now apply F2R_lt_0_compat.
-apply Rgt_not_eq.
-now apply F2R_gt_0_compat.
-refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
-2: now rewrite Hr ; apply F2R_gt_0_compat.
-refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
-2: discriminate.
-rewrite shr_truncate. 2: easy.
-destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
-rewrite shr_m_shr_record_of_loc.
-intros (H3,H4) (H2,_).
-destruct m2 as [|m2|m2].
-elim Rgt_not_eq with (2 := H3).
-rewrite F2R_0.
-now apply F2R_gt_0_compat.
-rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
-simpl Zabs.
-case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
-assert (bounded m2 e2 = true).
-apply andb_true_intro.
-split.
-unfold canonic_mantissa.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-rewrite <- ln_beta_F2R_Zdigits.
-apply sym_eq.
-now rewrite H3 in H4.
-discriminate.
-exact He2.
-apply (conj H).
-rewrite Rlt_bool_true.
-repeat split.
-apply F2R_cond_Zopp.
-now apply bounded_lt_emax.
-rewrite (Rlt_bool_false _ (bpow radix2 emax)).
-refine (conj _ (refl_equal _)).
-unfold binary_overflow.
-case overflow_to_inf.
-apply refl_equal.
-unfold valid_binary, bounded.
-rewrite Zle_bool_refl.
-rewrite Bool.andb_true_r.
-apply Zeq_bool_true.
-rewrite Zpos_digits2_pos.
-replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
-unfold fexp, FLT_exp, emin.
-generalize (prec_gt_0 prec).
-clear -Hmax ; zify ; omega.
-change 2%Z with (radix_val radix2).
-case_eq (Zpower radix2 prec - 1)%Z.
-simpl Zdigits.
-generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
-clear ; omega.
-intros p Hp.
-apply Zle_antisym.
-cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega.
-apply Zdigits_gt_Zpower.
-simpl Zabs. rewrite <- Hp.
-cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
-apply lt_Z2R.
-rewrite 2!Z2R_Zpower. 2: now apply Zlt_le_weak.
-apply bpow_lt.
-apply Zlt_pred.
-now apply Zlt_0_le_0_pred.
-apply Zdigits_le_Zpower.
-simpl Zabs. rewrite <- Hp.
-apply Zlt_pred.
-intros p Hp.
-generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
-clear -Hp ; zify ; omega.
-apply Rnot_lt_le.
-intros Hx.
-generalize (refl_equal (bounded m2 e2)).
-unfold bounded at 2.
-rewrite He2.
-rewrite Bool.andb_false_r.
-rewrite bounded_canonic_lt_emax with (2 := Hx).
-discriminate.
-unfold canonic.
-now rewrite <- H3.
-elim Rgt_not_eq with (2 := H3).
-apply Rlt_trans with R0.
-now apply F2R_lt_0_compat.
-now apply F2R_gt_0_compat.
-rewrite <- Hr.
-apply generic_format_abs...
-apply generic_format_round...
-(* . not m1' < 0 *)
-elim Rgt_not_eq with (2 := Hr).
-apply Rlt_le_trans with R0.
-now apply F2R_lt_0_compat.
-apply Rabs_pos.
-(* *)
-apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)).
-now apply F2R_gt_0_compat.
-(* all the modes are valid *)
-clear. case m.
-exact inbetween_int_NE_sign.
-exact inbetween_int_ZR_sign.
-exact inbetween_int_DN_sign.
-exact inbetween_int_UP_sign.
-exact inbetween_int_NA_sign.
-Qed.
-
-(** Multiplication *)
-
-Lemma Bmult_correct_aux :
- forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true),
- let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
- let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
- let z := binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact in
- valid_binary z = true /\
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then
- FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\
- is_finite_FF z = true /\ sign_FF z = xorb sx sy
- else
- z = binary_overflow m (xorb sx sy).
-Proof.
-intros m sx mx ex Hx sy my ey Hy x y.
-unfold x, y.
-rewrite <- F2R_mult.
-simpl.
-replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0).
-apply binary_round_aux_correct.
-constructor.
-rewrite <- F2R_abs.
-apply F2R_eq_compat.
-rewrite Zabs_Zmult.
-now rewrite 2!abs_cond_Zopp.
-(* *)
-change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z.
-assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z.
-clear. intros m e Hb.
-destruct (andb_prop _ _ Hb) as (H,_).
-apply Zeq_bool_eq.
-now rewrite <- Zpos_digits2_pos.
-generalize (H _ _ Hx) (H _ _ Hy).
-clear x y sx sy Hx Hy H.
-unfold fexp, FLT_exp.
-refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate.
-refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate.
-generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)).
-clear -Hmax.
-unfold emin.
-intros dx dy dxy Hx Hy Hxy.
-zify ; intros ; subst.
-omega.
-(* *)
-case sx ; case sy.
-apply Rlt_bool_false.
-now apply F2R_ge_0_compat.
-apply Rlt_bool_true.
-now apply F2R_lt_0_compat.
-apply Rlt_bool_true.
-now apply F2R_lt_0_compat.
-apply Rlt_bool_false.
-now apply F2R_ge_0_compat.
-Qed.
-
-Definition Bmult mult_nan m x y :=
- let f pl := B754_nan (fst pl) (snd pl) in
- match x, y with
- | B754_nan _ _, _ | _, B754_nan _ _ => f (mult_nan x y)
- | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy)
- | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
- | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy)
- | B754_infinity _, B754_zero _ => f (mult_nan x y)
- | B754_zero _, B754_infinity _ => f (mult_nan x y)
- | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy)
- | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
- | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy)
- | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
- FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy))
- end.
-
-Theorem Bmult_correct :
- forall mult_nan m x y,
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then
- B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\
- is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\
- (is_nan (Bmult mult_nan m x y) = false ->
- Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y))
- else
- B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
-Proof.
-intros mult_nan m [sx|sx|sx plx|sx mx ex Hx] [sy|sy|sy ply|sy my ey Hy] ;
- try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | now auto with typeclass_instances ] ).
-simpl.
-case Bmult_correct_aux.
-intros H1.
-case Rlt_bool.
-intros (H2, (H3, H4)).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B. auto.
-intros H2.
-now rewrite B2FF_FF2B.
-Qed.
-
-Definition Bmult_FF mult_nan m x y :=
- let f pl := F754_nan (fst pl) (snd pl) in
- match x, y with
- | F754_nan _ _, _ | _, F754_nan _ _ => f (mult_nan x y)
- | F754_infinity sx, F754_infinity sy => F754_infinity (xorb sx sy)
- | F754_infinity sx, F754_finite sy _ _ => F754_infinity (xorb sx sy)
- | F754_finite sx _ _, F754_infinity sy => F754_infinity (xorb sx sy)
- | F754_infinity _, F754_zero _ => f (mult_nan x y)
- | F754_zero _, F754_infinity _ => f (mult_nan x y)
- | F754_finite sx _ _, F754_zero sy => F754_zero (xorb sx sy)
- | F754_zero sx, F754_finite sy _ _ => F754_zero (xorb sx sy)
- | F754_zero sx, F754_zero sy => F754_zero (xorb sx sy)
- | F754_finite sx mx ex, F754_finite sy my ey =>
- binary_round_aux m (xorb sx sy) (mx * my) (ex + ey) loc_Exact
- end.
-
-Theorem B2FF_Bmult :
- forall mult_nan mult_nan_ff,
- forall m x y,
- mult_nan_ff (B2FF x) (B2FF y) = (let '(sr, exist plr _) := mult_nan x y in (sr, plr)) ->
- B2FF (Bmult mult_nan m x y) = Bmult_FF mult_nan_ff m (B2FF x) (B2FF y).
-Proof.
-intros mult_nan mult_nan_ff m x y Hmult_nan.
-unfold Bmult_FF. rewrite Hmult_nan.
-destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Hx], y as [sy|sy|sy [ply Hply]|sy my ey Hy] ;
- simpl; try match goal with |- context [mult_nan ?x ?y] =>
- destruct (mult_nan x y) as [? []] end;
- try easy.
-apply B2FF_FF2B.
-Qed.
-
-(** Normalization and rounding *)
-
-Definition shl_align mx ex ex' :=
- match (ex' - ex)%Z with
- | Zneg d => (shift_pos d mx, ex')
- | _ => (mx, ex)
- end.
-
-Theorem shl_align_correct :
- forall mx ex ex',
- let (mx', ex'') := shl_align mx ex ex' in
- F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\
- (ex'' <= ex')%Z.
-Proof.
-intros mx ex ex'.
-unfold shl_align.
-case_eq (ex' - ex)%Z.
-(* d = 0 *)
-intros H.
-repeat split.
-rewrite Zminus_eq with (1 := H).
-apply Zle_refl.
-(* d > 0 *)
-intros d Hd.
-repeat split.
-replace ex' with (ex' - ex + ex)%Z by ring.
-rewrite Hd.
-pattern ex at 1 ; rewrite <- Zplus_0_l.
-now apply Zplus_le_compat_r.
-(* d < 0 *)
-intros d Hd.
-rewrite shift_pos_correct, Zmult_comm.
-change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)).
-change (Zpos d) with (Zopp (Zneg d)).
-rewrite <- Hd.
-split.
-replace (- (ex' - ex))%Z with (ex - ex')%Z by ring.
-apply F2R_change_exp.
-apply Zle_0_minus_le.
-replace (ex - ex')%Z with (- (ex' - ex))%Z by ring.
-now rewrite Hd.
-apply Zle_refl.
-Qed.
-
-Theorem snd_shl_align :
- forall mx ex ex',
- (ex' <= ex)%Z ->
- snd (shl_align mx ex ex') = ex'.
-Proof.
-intros mx ex ex' He.
-unfold shl_align.
-case_eq (ex' - ex)%Z ; simpl.
-intros H.
-now rewrite Zminus_eq with (1 := H).
-intros p.
-clear -He ; zify ; omega.
-intros.
-apply refl_equal.
-Qed.
-
-Definition shl_align_fexp mx ex :=
- shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).
-
-Theorem shl_align_fexp_correct :
- forall mx ex,
- let (mx', ex') := shl_align_fexp mx ex in
- F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\
- (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z.
-Proof.
-intros mx ex.
-unfold shl_align_fexp.
-generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))).
-rewrite Zpos_digits2_pos.
-case shl_align.
-intros mx' ex' (H1, H2).
-split.
-exact H1.
-rewrite <- ln_beta_F2R_Zdigits. 2: easy.
-rewrite <- H1.
-now rewrite ln_beta_F2R_Zdigits.
-Qed.
-
-Definition binary_round m sx mx ex :=
- let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx mz ez loc_Exact.
-
-Theorem binary_round_correct :
- forall m sx mx ex,
- let z := binary_round m sx mx ex in
- valid_binary z = true /\
- let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
- FF2R radix2 z = round radix2 fexp (round_mode m) x /\
- is_finite_FF z = true /\
- sign_FF z = sx
- else
- z = binary_overflow m sx.
-Proof.
-intros m sx mx ex.
-unfold binary_round.
-generalize (shl_align_fexp_correct mx ex).
-destruct (shl_align_fexp mx ex) as (mz, ez).
-intros (H1, H2).
-set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)).
-replace sx with (Rlt_bool x 0).
-apply binary_round_aux_correct.
-constructor.
-unfold x.
-now rewrite <- F2R_Zabs, abs_cond_Zopp.
-exact H2.
-unfold x.
-case sx.
-apply Rlt_bool_true.
-now apply F2R_lt_0_compat.
-apply Rlt_bool_false.
-now apply F2R_ge_0_compat.
-Qed.
-
-Definition binary_normalize mode m e szero :=
- match m with
- | Z0 => B754_zero szero
- | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e))
- | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e))
- end.
-
-Theorem binary_normalize_correct :
- forall m mx ex szero,
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then
- B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\
- is_finite (binary_normalize m mx ex szero) = true /\
- Bsign (binary_normalize m mx ex szero) =
- match Rcompare (F2R (Float radix2 mx ex)) 0 with
- | Eq => szero
- | Lt => true
- | Gt => false
- end
- else
- B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0).
-Proof with auto with typeclass_instances.
-intros m mx ez szero.
-destruct mx as [|mz|mz] ; simpl.
-rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true...
-split... split...
-rewrite Rcompare_Eq...
-apply bpow_gt_0.
-(* . mz > 0 *)
-generalize (binary_round_correct m false mz ez).
-simpl.
-case Rlt_bool_spec.
-intros _ (Vz, (Rz, (Rz', Rz''))).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B, Rz''.
-rewrite Rcompare_Gt...
-apply F2R_gt_0_compat.
-simpl. zify; omega.
-intros Hz' (Vz, Rz).
-rewrite B2FF_FF2B, Rz.
-apply f_equal.
-apply sym_eq.
-apply Rlt_bool_false.
-now apply F2R_ge_0_compat.
-(* . mz < 0 *)
-generalize (binary_round_correct m true mz ez).
-simpl.
-case Rlt_bool_spec.
-intros _ (Vz, (Rz, (Rz', Rz''))).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B, Rz''.
-rewrite Rcompare_Lt...
-apply F2R_lt_0_compat.
-simpl. zify; omega.
-intros Hz' (Vz, Rz).
-rewrite B2FF_FF2B, Rz.
-apply f_equal.
-apply sym_eq.
-apply Rlt_bool_true.
-now apply F2R_lt_0_compat.
-Qed.
-
-(** Addition *)
-
-Definition Bplus plus_nan m x y :=
- let f pl := B754_nan (fst pl) (snd pl) in
- match x, y with
- | B754_nan _ _, _ | _, B754_nan _ _ => f (plus_nan x y)
- | B754_infinity sx, B754_infinity sy =>
- if Bool.eqb sx sy then x else f (plus_nan x y)
- | B754_infinity _, _ => x
- | _, B754_infinity _ => y
- | B754_zero sx, B754_zero sy =>
- if Bool.eqb sx sy then x else
- match m with mode_DN => B754_zero true | _ => B754_zero false end
- | B754_zero _, _ => y
- | _, B754_zero _ => x
- | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
- let ez := Zmin ex ey in
- binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
- ez (match m with mode_DN => true | _ => false end)
- end.
-
-Theorem Bplus_correct :
- forall plus_nan m x y,
- is_finite x = true ->
- is_finite y = true ->
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then
- B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\
- is_finite (Bplus plus_nan m x y) = true /\
- Bsign (Bplus plus_nan m x y) =
- match Rcompare (B2R x + B2R y) 0 with
- | Eq => match m with mode_DN => orb (Bsign x) (Bsign y)
- | _ => andb (Bsign x) (Bsign y) end
- | Lt => true
- | Gt => false
- end
- else
- (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
-Proof with auto with typeclass_instances.
-intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
-(* *)
-rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true...
-simpl.
-rewrite Rcompare_Eq by auto.
-destruct sx, sy; try easy; now case m.
-apply bpow_gt_0.
-(* *)
-rewrite Rplus_0_l, round_generic, Rlt_bool_true...
-split... split...
-simpl. unfold F2R.
-erewrite <- Rmult_0_l, Rcompare_mult_r.
-rewrite Rcompare_Z2R with (y:=0%Z).
-destruct sy...
-apply bpow_gt_0.
-apply abs_B2R_lt_emax.
-apply generic_format_B2R.
-(* *)
-rewrite Rplus_0_r, round_generic, Rlt_bool_true...
-split... split...
-simpl. unfold F2R.
-erewrite <- Rmult_0_l, Rcompare_mult_r.
-rewrite Rcompare_Z2R with (y:=0%Z).
-destruct sx...
-apply bpow_gt_0.
-apply abs_B2R_lt_emax.
-apply generic_format_B2R.
-(* *)
-clear Fx Fy.
-simpl.
-set (szero := match m with mode_DN => true | _ => false end).
-set (ez := Zmin ex ey).
-set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z).
-assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) +
- F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)).
-rewrite 2!F2R_cond_Zopp.
-generalize (shl_align_correct mx ex ez).
-generalize (shl_align_correct my ey ez).
-generalize (snd_shl_align mx ex ez (Zle_min_l ex ey)).
-generalize (snd_shl_align my ey ez (Zle_min_r ex ey)).
-destruct (shl_align mx ex ez) as (mx', ex').
-destruct (shl_align my ey ez) as (my', ey').
-simpl.
-intros H1 H2.
-rewrite H1, H2.
-clear H1 H2.
-intros (H1, _) (H2, _).
-rewrite H1, H2.
-clear H1 H2.
-rewrite <- 2!F2R_cond_Zopp.
-unfold F2R. simpl.
-now rewrite <- Rmult_plus_distr_r, <- Z2R_plus.
-rewrite Hp.
-assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy).
-(* . *)
-rewrite <- Hp.
-intros Bz.
-destruct (Bool.bool_dec sx sy) as [Hs|Hs].
-(* .. *)
-refine (conj _ Hs).
-rewrite Hs.
-apply sym_eq.
-case sy.
-apply Rlt_bool_true.
-rewrite <- (Rplus_0_r 0).
-apply Rplus_lt_compat.
-now apply F2R_lt_0_compat.
-now apply F2R_lt_0_compat.
-apply Rlt_bool_false.
-rewrite <- (Rplus_0_r 0).
-apply Rplus_le_compat.
-now apply F2R_ge_0_compat.
-now apply F2R_ge_0_compat.
-(* .. *)
-elim Rle_not_lt with (1 := Bz).
-generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy).
-intros Bx By (Hx',_) (Hy',_).
-generalize (canonic_canonic_mantissa sx _ _ Hx') (canonic_canonic_mantissa sy _ _ Hy').
-clear -Bx By Hs prec_gt_0_.
-intros Cx Cy.
-destruct sx.
-(* ... *)
-destruct sy.
-now elim Hs.
-clear Hs.
-apply Rabs_lt.
-split.
-apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)).
-rewrite F2R_Zopp.
-now apply Ropp_lt_contravar.
-apply round_ge_generic...
-now apply generic_format_canonic.
-pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r.
-apply Rplus_le_compat_l.
-now apply F2R_ge_0_compat.
-apply Rle_lt_trans with (2 := By).
-apply round_le_generic...
-now apply generic_format_canonic.
-rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))).
-apply Rplus_le_compat_r.
-now apply F2R_le_0_compat.
-(* ... *)
-destruct sy.
-2: now elim Hs.
-clear Hs.
-apply Rabs_lt.
-split.
-apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)).
-rewrite F2R_Zopp.
-now apply Ropp_lt_contravar.
-apply round_ge_generic...
-now apply generic_format_canonic.
-pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l.
-apply Rplus_le_compat_r.
-now apply F2R_ge_0_compat.
-apply Rle_lt_trans with (2 := Bx).
-apply round_le_generic...
-now apply generic_format_canonic.
-rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))).
-apply Rplus_le_compat_l.
-now apply F2R_le_0_compat.
-(* . *)
-generalize (binary_normalize_correct m mz ez szero).
-case Rlt_bool_spec.
-split; try easy. split; try easy.
-destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy.
-rewrite H1 in Hp.
-apply Rplus_opp_r_uniq in Hp.
-rewrite <- F2R_Zopp in Hp.
-eapply canonic_unicity in Hp.
-inversion Hp. destruct sy, sx, m; try discriminate H3; easy.
-apply canonic_canonic_mantissa.
-apply Bool.andb_true_iff in Hy. easy.
-replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx))
- by (destruct sx; auto).
-apply canonic_canonic_mantissa.
-apply Bool.andb_true_iff in Hx. easy.
-intros Hz' Vz.
-specialize (Sz Hz').
-split.
-rewrite Vz.
-now apply f_equal.
-apply Sz.
-Qed.
-
-(** Subtraction *)
-
-Definition Bminus minus_nan m x y := Bplus minus_nan m x (Bopp pair y).
-
-Theorem Bminus_correct :
- forall minus_nan m x y,
- is_finite x = true ->
- is_finite y = true ->
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then
- B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\
- is_finite (Bminus minus_nan m x y) = true /\
- Bsign (Bminus minus_nan m x y) =
- match Rcompare (B2R x - B2R y) 0 with
- | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y))
- | _ => andb (Bsign x) (negb (Bsign y)) end
- | Lt => true
- | Gt => false
- end
- else
- (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)).
-Proof with auto with typeclass_instances.
-intros m minus_nan x y Fx Fy.
-replace (negb (Bsign y)) with (Bsign (Bopp pair y)).
-unfold Rminus.
-erewrite <- B2R_Bopp.
-apply Bplus_correct.
-exact Fx.
-rewrite is_finite_Bopp. auto. now destruct y as [ | | | ].
-Qed.
-
-(** Division *)
-
-Definition Fdiv_core_binary m1 e1 m2 e2 :=
- let d1 := Zdigits2 m1 in
- let d2 := Zdigits2 m2 in
- let e := (e1 - e2)%Z in
- let (m, e') :=
- match (d2 + prec - d1)%Z with
- | Zpos p => (Z.shiftl m1 (Zpos p), e + Zneg p)%Z
- | _ => (m1, e)
- end in
- let '(q, r) := Zfast_div_eucl m m2 in
- (q, e', new_location m2 r loc_Exact).
-
-Lemma Bdiv_correct_aux :
- forall m sx mx ex sy my ey,
- let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
- let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
- let z :=
- let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in
- match mz with
- | Zpos mz => binary_round_aux m (xorb sx sy) mz ez lz
- | _ => F754_nan false xH (* dummy *)
- end in
- valid_binary z = true /\
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then
- FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\
- is_finite_FF z = true /\ sign_FF z = xorb sx sy
- else
- z = binary_overflow m (xorb sx sy).
-Proof.
-intros m sx mx ex sy my ey.
-replace (Fdiv_core_binary (Zpos mx) ex (Zpos my) ey) with (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey).
-refine (_ (Fdiv_core_correct radix2 prec (Zpos mx) ex (Zpos my) ey _ _ _)) ; try easy.
-destruct (Fdiv_core radix2 prec (Zpos mx) ex (Zpos my) ey) as ((mz, ez), lz).
-intros (Pz, Bz).
-simpl.
-replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) *
- / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0).
-unfold Rdiv.
-destruct mz as [|mz|mz].
-(* . mz = 0 *)
-elim (Zlt_irrefl prec).
-now apply Zle_lt_trans with Z0.
-(* . mz > 0 *)
-apply binary_round_aux_correct.
-rewrite Rabs_mult, Rabs_Rinv.
-now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp.
-case sy.
-apply Rlt_not_eq.
-now apply F2R_lt_0_compat.
-apply Rgt_not_eq.
-now apply F2R_gt_0_compat.
-revert Pz.
-generalize (Zdigits radix2 (Zpos mz)).
-unfold fexp, FLT_exp.
-clear.
-intros ; zify ; subst.
-omega.
-(* . mz < 0 *)
-elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)).
-apply Rle_trans with R0.
-apply F2R_le_0_compat.
-now case mz.
-apply Rmult_le_pos.
-now apply F2R_ge_0_compat.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0_compat.
-(* *)
-case sy ; simpl.
-change (Zneg my) with (Zopp (Zpos my)).
-rewrite F2R_Zopp.
-rewrite <- Ropp_inv_permute.
-rewrite Ropp_mult_distr_r_reverse.
-case sx ; simpl.
-apply Rlt_bool_false.
-rewrite <- Ropp_mult_distr_l_reverse.
-apply Rmult_le_pos.
-rewrite <- F2R_opp.
-now apply F2R_ge_0_compat.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0_compat.
-apply Rlt_bool_true.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
-apply Rmult_lt_0_compat.
-now apply F2R_gt_0_compat.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0_compat.
-apply Rgt_not_eq.
-now apply F2R_gt_0_compat.
-case sx.
-apply Rlt_bool_true.
-rewrite F2R_Zopp.
-rewrite Ropp_mult_distr_l_reverse.
-rewrite <- Ropp_0.
-apply Ropp_lt_contravar.
-apply Rmult_lt_0_compat.
-now apply F2R_gt_0_compat.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0_compat.
-apply Rlt_bool_false.
-apply Rmult_le_pos.
-now apply F2R_ge_0_compat.
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply F2R_gt_0_compat.
-(* *)
-unfold Fdiv_core_binary, Fdiv_core.
-rewrite 2!Zdigits2_Zdigits.
-change 2%Z with (radix_val radix2).
-destruct (Zdigits radix2 (Z.pos my) + prec - Zdigits radix2 (Z.pos mx))%Z as [|p|p].
-now rewrite Zfast_div_eucl_correct.
-rewrite Z.shiftl_mul_pow2 by easy.
-now rewrite Zfast_div_eucl_correct.
-now rewrite Zfast_div_eucl_correct.
-Qed.
-
-Definition Bdiv div_nan m x y :=
- let f pl := B754_nan (fst pl) (snd pl) in
- match x, y with
- | B754_nan _ _, _ | _, B754_nan _ _ => f (div_nan x y)
- | B754_infinity sx, B754_infinity sy => f (div_nan x y)
- | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
- | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy)
- | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy)
- | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy)
- | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy)
- | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
- | B754_zero sx, B754_zero sy => f (div_nan x y)
- | B754_finite sx mx ex _, B754_finite sy my ey _ =>
- FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey))
- end.
-
-Theorem Bdiv_correct :
- forall div_nan m x y,
- B2R y <> 0%R ->
- if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then
- B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\
- is_finite (Bdiv div_nan m x y) = is_finite x /\
- (is_nan (Bdiv div_nan m x y) = false ->
- Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y))
- else
- B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
-Proof.
-intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy.
-revert x.
-unfold Rdiv.
-intros [sx|sx|sx plx|sx mx ex Hx] ;
- try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ now repeat constructor | apply bpow_gt_0 | auto with typeclass_instances ] ).
-simpl.
-case Bdiv_correct_aux.
-intros H1.
-unfold Rdiv.
-case Rlt_bool.
-intros (H2, (H3, H4)).
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-rewrite Bsign_FF2B. congruence.
-intros H2.
-now rewrite B2FF_FF2B.
-Qed.
-
-(** Square root *)
-
-Definition Fsqrt_core_binary m e :=
- let d := Zdigits2 m in
- let s := Zmax (2 * prec - d) 0 in
- let e' := (e - s)%Z in
- let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in
- let m' :=
- match s' with
- | Zpos p => Z.shiftl m (Zpos p)
- | _ => m
- end in
- let (q, r) := Z.sqrtrem m' in
- let l :=
- if Zeq_bool r 0 then loc_Exact
- else loc_Inexact (if Zle_bool r q then Lt else Gt) in
- (q, Zdiv2 e'', l).
-
-Lemma Bsqrt_correct_aux :
- forall m mx ex (Hx : bounded mx ex = true),
- let x := F2R (Float radix2 (Zpos mx) ex) in
- let z :=
- let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in
- match mz with
- | Zpos mz => binary_round_aux m false mz ez lz
- | _ => F754_nan false xH (* dummy *)
- end in
- valid_binary z = true /\
- FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\
- is_finite_FF z = true /\ sign_FF z = false.
-Proof with auto with typeclass_instances.
-intros m mx ex Hx.
-replace (Fsqrt_core_binary (Zpos mx) ex) with (Fsqrt_core radix2 prec (Zpos mx) ex).
-simpl.
-refine (_ (Fsqrt_core_correct radix2 prec (Zpos mx) ex _)) ; try easy.
-destruct (Fsqrt_core radix2 prec (Zpos mx) ex) as ((mz, ez), lz).
-intros (Pz, Bz).
-destruct mz as [|mz|mz].
-(* . mz = 0 *)
-elim (Zlt_irrefl prec).
-now apply Zle_lt_trans with Z0.
-(* . mz > 0 *)
-refine (_ (binary_round_aux_correct m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz ez lz _ _)).
-rewrite Rlt_bool_false. 2: apply sqrt_ge_0.
-rewrite Rlt_bool_true.
-easy.
-(* .. *)
-rewrite Rabs_pos_eq.
-refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)).
-fold fexp.
-intros (eps, (Heps, Hr)).
-rewrite Hr.
-assert (Heps': (Rabs eps < 1)%R).
-apply Rlt_le_trans with (1 := Heps).
-fold (bpow radix2 0).
-apply bpow_le.
-generalize (prec_gt_0 prec).
-clear ; omega.
-apply Rsqr_incrst_0.
-3: apply bpow_ge_0.
-rewrite Rsqr_mult.
-rewrite Rsqr_sqrt.
-2: now apply F2R_ge_0_compat.
-unfold Rsqr.
-apply Rmult_ge_0_gt_0_lt_compat.
-apply Rle_ge.
-apply Rle_0_sqr.
-apply bpow_gt_0.
-now apply bounded_lt_emax.
-apply Rlt_le_trans with 4%R.
-apply Rsqr_incrst_1.
-apply Rplus_lt_compat_l.
-apply (Rabs_lt_inv _ _ Heps').
-rewrite <- (Rplus_opp_r 1).
-apply Rplus_le_compat_l.
-apply Rlt_le.
-apply (Rabs_lt_inv _ _ Heps').
-now apply (Z2R_le 0 2).
-change 4%R with (bpow radix2 2).
-apply bpow_le.
-generalize (prec_gt_0 prec).
-clear -Hmax ; omega.
-apply Rmult_le_pos.
-apply sqrt_ge_0.
-rewrite <- (Rplus_opp_r 1).
-apply Rplus_le_compat_l.
-apply Rlt_le.
-apply (Rabs_lt_inv _ _ Heps').
-rewrite Rabs_pos_eq.
-2: apply sqrt_ge_0.
-apply Rsqr_incr_0.
-2: apply bpow_ge_0.
-2: apply sqrt_ge_0.
-rewrite Rsqr_sqrt.
-2: now apply F2R_ge_0_compat.
-apply Rle_trans with (bpow radix2 emin).
-unfold Rsqr.
-rewrite <- bpow_plus.
-apply bpow_le.
-unfold emin.
-clear -Hmax ; omega.
-apply generic_format_ge_bpow with fexp.
-intros.
-apply Zle_max_r.
-now apply F2R_gt_0_compat.
-apply generic_format_canonic.
-apply (canonic_canonic_mantissa false).
-apply (andb_prop _ _ Hx).
-(* .. *)
-apply round_ge_generic...
-apply generic_format_0.
-apply sqrt_ge_0.
-rewrite Rabs_pos_eq.
-exact Bz.
-apply sqrt_ge_0.
-revert Pz.
-generalize (Zdigits radix2 (Zpos mz)).
-unfold fexp, FLT_exp.
-clear.
-intros ; zify ; subst.
-omega.
-(* . mz < 0 *)
-elim Rlt_not_le with (1 := proj2 (inbetween_float_bounds _ _ _ _ _ Bz)).
-apply Rle_trans with R0.
-apply F2R_le_0_compat.
-now case mz.
-apply sqrt_ge_0.
-(* *)
-unfold Fsqrt_core, Fsqrt_core_binary.
-rewrite Zdigits2_Zdigits.
-destruct (if Zeven _ then _ else _) as [[|s'|s'] e''] ; try easy.
-now rewrite Z.shiftl_mul_pow2.
-Qed.
-
-Definition Bsqrt sqrt_nan m x :=
- let f pl := B754_nan (fst pl) (snd pl) in
- match x with
- | B754_nan sx plx => f (sqrt_nan x)
- | B754_infinity false => x
- | B754_infinity true => f (sqrt_nan x)
- | B754_finite true _ _ _ => f (sqrt_nan x)
- | B754_zero _ => x
- | B754_finite sx mx ex Hx =>
- FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx))
- end.
-
-Theorem Bsqrt_correct :
- forall sqrt_nan m x,
- B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\
- is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\
- (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x).
-Proof.
-intros sqrt_nan m [sx|[|]| |sx mx ex Hx] ; try ( now simpl ; rewrite sqrt_0, round_0 ; intuition auto with typeclass_instances ).
-simpl.
-case Bsqrt_correct_aux.
-intros H1 (H2, (H3, H4)).
-case sx.
-refine (conj _ (conj (refl_equal false) _)).
-apply sym_eq.
-unfold sqrt.
-case Rcase_abs.
-intros _.
-apply round_0.
-auto with typeclass_instances.
-intros H.
-elim Rge_not_lt with (1 := H).
-now apply F2R_lt_0_compat.
-easy.
-split.
-now rewrite B2R_FF2B.
-split.
-now rewrite is_finite_FF2B.
-intro. rewrite Bsign_FF2B. auto.
-Qed.
-
-End Binary.
diff --git a/flocq/Calc/Fcalc_bracket.v b/flocq/Calc/Bracket.v
index 03ef7bd3..83714e87 100644
--- a/flocq/Calc/Fcalc_bracket.v
+++ b/flocq/Calc/Bracket.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -19,9 +19,7 @@ COPYING file for more details.
(** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_float_prop.
+Require Import Raux Defs Float_prop.
Section Fcalc_bracket.
@@ -146,23 +144,17 @@ assert (0 < v < 1)%R.
split.
unfold v, Rdiv.
apply Rmult_lt_0_compat.
-case l.
-now apply (Z2R_lt 0 2).
-now apply (Z2R_lt 0 1).
-now apply (Z2R_lt 0 3).
+case l ; now apply IZR_lt.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 4).
+now apply IZR_lt.
unfold v, Rdiv.
apply Rmult_lt_reg_r with 4%R.
-now apply (Z2R_lt 0 4).
+now apply IZR_lt.
rewrite Rmult_assoc, Rinv_l.
rewrite Rmult_1_r, Rmult_1_l.
-case l.
-now apply (Z2R_lt 2 4).
-now apply (Z2R_lt 1 4).
-now apply (Z2R_lt 3 4).
+case l ; now apply IZR_lt.
apply Rgt_not_eq.
-now apply (Z2R_lt 0 4).
+now apply IZR_lt.
split.
apply Rplus_lt_reg_r with (d * (v - 1))%R.
ring_simplify.
@@ -179,7 +171,7 @@ exact Hdu.
set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end)%R).
rewrite <- (Rcompare_plus_r (- (d + u) / 2)).
rewrite <- (Rcompare_mult_r 4).
-2: now apply (Z2R_lt 0 4).
+2: now apply IZR_lt.
replace (((d + u) / 2 + - (d + u) / 2) * 4)%R with ((u - d) * 0)%R by field.
replace ((d + v / 4 * (u - d) + - (d + u) / 2) * 4)%R with ((u - d) * (v - 2))%R by field.
rewrite Rcompare_mult_l.
@@ -187,10 +179,7 @@ rewrite Rcompare_mult_l.
rewrite <- (Rcompare_plus_r 2).
ring_simplify (v - 2 + 2)%R (0 + 2)%R.
unfold v.
-case l.
-exact (Rcompare_Z2R 2 2).
-exact (Rcompare_Z2R 1 2).
-exact (Rcompare_Z2R 3 2).
+case l ; apply Rcompare_IZR.
Qed.
Section Fcalc_bracket_step.
@@ -201,19 +190,19 @@ Variable Hstep : (0 < step)%R.
Lemma ordered_steps :
forall k,
- (start + Z2R k * step < start + Z2R (k + 1) * step)%R.
+ (start + IZR k * step < start + IZR (k + 1) * step)%R.
Proof.
intros k.
apply Rplus_lt_compat_l.
apply Rmult_lt_compat_r.
exact Hstep.
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
Qed.
Lemma middle_range :
forall k,
- ((start + (start + Z2R k * step)) / 2 = start + (Z2R k / 2 * step))%R.
+ ((start + (start + IZR k * step)) / 2 = start + (IZR k / 2 * step))%R.
Proof.
intros k.
field.
@@ -223,10 +212,10 @@ Hypothesis (Hnb_steps : (1 < nb_steps)%Z).
Lemma inbetween_step_not_Eq :
forall x k l l',
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
(0 < k < nb_steps)%Z ->
- Rcompare x (start + (Z2R nb_steps / 2 * step))%R = l' ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l').
+ Rcompare x (start + (IZR nb_steps / 2 * step))%R = l' ->
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact l').
Proof.
intros x k l l' Hx Hk Hl'.
constructor.
@@ -237,13 +226,13 @@ apply Rlt_le_trans with (2 := proj1 Hx').
rewrite <- (Rplus_0_r start) at 1.
apply Rplus_lt_compat_l.
apply Rmult_lt_0_compat.
-now apply (Z2R_lt 0).
+now apply IZR_lt.
exact Hstep.
apply Rlt_le_trans with (1 := proj2 Hx').
apply Rplus_le_compat_l.
apply Rmult_le_compat_r.
now apply Rlt_le.
-apply Z2R_le.
+apply IZR_le.
omega.
(* . *)
now rewrite middle_range.
@@ -251,9 +240,9 @@ Qed.
Theorem inbetween_step_Lo :
forall x k l,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
(0 < k)%Z -> (2 * k + 1 < nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
@@ -264,18 +253,17 @@ apply Rlt_le_trans with (1 := proj2 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_not_Lt.
-change 2%R with (Z2R 2).
-rewrite <- Z2R_mult.
-apply Z2R_le.
+rewrite <- mult_IZR.
+apply IZR_le.
omega.
exact Hstep.
Qed.
Theorem inbetween_step_Hi :
forall x k l,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
(nb_steps < 2 * k)%Z -> (k < nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
@@ -286,9 +274,8 @@ apply Rlt_le_trans with (2 := proj1 Hx').
apply Rcompare_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_Lt.
-change 2%R with (Z2R 2).
-rewrite <- Z2R_mult.
-apply Z2R_lt.
+rewrite <- mult_IZR.
+apply IZR_lt.
omega.
exact Hstep.
Qed.
@@ -297,7 +284,7 @@ Theorem inbetween_step_Lo_not_Eq :
forall x l,
inbetween start (start + step) x l ->
l <> loc_Exact ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x l Hx Hl.
assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
@@ -310,7 +297,7 @@ apply Rplus_lt_compat_l.
rewrite <- (Rmult_1_l step) at 1.
apply Rmult_lt_compat_r.
exact Hstep.
-now apply (Z2R_lt 1).
+now apply IZR_lt.
(* . *)
apply Rcompare_Lt.
apply Rlt_le_trans with (1 := proj2 Hx').
@@ -320,7 +307,7 @@ rewrite <- (Rmult_1_l step) at 2.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
rewrite Rmult_1_r.
apply Rcompare_not_Lt.
-apply (Z2R_le 2).
+apply IZR_le.
now apply (Zlt_le_succ 1).
exact Hstep.
Qed.
@@ -328,19 +315,19 @@ Qed.
Lemma middle_odd :
forall k,
(2 * k + 1 = nb_steps)%Z ->
- (((start + Z2R k * step) + (start + Z2R (k + 1) * step))/2 = start + Z2R nb_steps /2 * step)%R.
+ (((start + IZR k * step) + (start + IZR (k + 1) * step))/2 = start + IZR nb_steps /2 * step)%R.
Proof.
intros k Hk.
rewrite <- Hk.
-rewrite 2!Z2R_plus, Z2R_mult.
+rewrite 2!plus_IZR, mult_IZR.
simpl. field.
Qed.
Theorem inbetween_step_any_Mi_odd :
forall x k l,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x (loc_Inexact l) ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x (loc_Inexact l) ->
(2 * k + 1 = nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact l).
Proof.
intros x k l Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
@@ -351,9 +338,9 @@ Qed.
Theorem inbetween_step_Lo_Mi_Eq_odd :
forall x k,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact ->
(2 * k + 1 = nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
@@ -362,9 +349,8 @@ inversion_clear Hx as [Hl|].
rewrite Hl.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
apply Rcompare_Lt.
-change 2%R with (Z2R 2).
-rewrite <- Z2R_mult.
-apply Z2R_lt.
+rewrite <- mult_IZR.
+apply IZR_lt.
rewrite <- Hk.
apply Zlt_succ.
exact Hstep.
@@ -372,10 +358,10 @@ Qed.
Theorem inbetween_step_Hi_Mi_even :
forall x k l,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
l <> loc_Exact ->
(2 * k = nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hl Hk.
apply inbetween_step_not_Eq with (1 := Hx).
@@ -385,28 +371,26 @@ assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
apply Rle_lt_trans with (2 := proj1 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
-change 2%R with (Z2R 2).
-rewrite <- Z2R_mult.
+rewrite <- mult_IZR.
apply Rcompare_not_Lt.
-apply Z2R_le.
+apply IZR_le.
rewrite Hk.
-apply Zle_refl.
+apply Z.le_refl.
exact Hstep.
Qed.
Theorem inbetween_step_Mi_Mi_even :
forall x k,
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact ->
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x loc_Exact ->
(2 * k = nb_steps)%Z ->
- inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Eq).
+ inbetween start (start + IZR nb_steps * step) x (loc_Inexact Eq).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Eq.
inversion_clear Hx as [Hx'|].
-rewrite Hx', <- Hk, Z2R_mult.
-simpl (Z2R 2).
+rewrite Hx', <- Hk, mult_IZR.
field.
Qed.
@@ -419,17 +403,17 @@ Definition new_location_even k l :=
match l with loc_Exact => l | _ => loc_Inexact Lt end
else
loc_Inexact
- match Zcompare (2 * k) nb_steps with
+ match Z.compare (2 * k) nb_steps with
| Lt => Lt
| Eq => match l with loc_Exact => Eq | _ => Gt end
| Gt => Gt
end.
Theorem new_location_even_correct :
- Zeven nb_steps = true ->
+ Z.even nb_steps = true ->
forall x k l, (0 <= k < nb_steps)%Z ->
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
- inbetween start (start + Z2R nb_steps * step) x (new_location_even k l).
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
+ inbetween start (start + IZR nb_steps * step) x (new_location_even k l).
Proof.
intros He x k l Hk Hx.
unfold new_location_even.
@@ -476,17 +460,17 @@ Definition new_location_odd k l :=
match l with loc_Exact => l | _ => loc_Inexact Lt end
else
loc_Inexact
- match Zcompare (2 * k + 1) nb_steps with
+ match Z.compare (2 * k + 1) nb_steps with
| Lt => Lt
| Eq => match l with loc_Inexact l => l | loc_Exact => Lt end
| Gt => Gt
end.
Theorem new_location_odd_correct :
- Zeven nb_steps = false ->
+ Z.even nb_steps = false ->
forall x k l, (0 <= k < nb_steps)%Z ->
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
- inbetween start (start + Z2R nb_steps * step) x (new_location_odd k l).
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
+ inbetween start (start + IZR nb_steps * step) x (new_location_odd k l).
Proof.
intros Ho x k l Hk Hx.
unfold new_location_odd.
@@ -520,16 +504,16 @@ apply Hk.
Qed.
Definition new_location :=
- if Zeven nb_steps then new_location_even else new_location_odd.
+ if Z.even nb_steps then new_location_even else new_location_odd.
Theorem new_location_correct :
forall x k l, (0 <= k < nb_steps)%Z ->
- inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
- inbetween start (start + Z2R nb_steps * step) x (new_location k l).
+ inbetween (start + IZR k * step) (start + IZR (k + 1) * step) x l ->
+ inbetween start (start + IZR nb_steps * step) x (new_location k l).
Proof.
intros x k l Hk Hx.
unfold new_location.
-generalize (refl_equal nb_steps) (Zle_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)).
+generalize (refl_equal nb_steps) (Z.le_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)).
pattern nb_steps at 2 3 5 ; case nb_steps.
now intros _.
(* . *)
@@ -603,7 +587,7 @@ intros x m e l [Hx|l' Hx Hl].
rewrite Hx.
split.
apply Rle_refl.
-apply F2R_lt_compat.
+apply F2R_lt.
apply Zlt_succ.
split.
now apply Rlt_le.
@@ -613,13 +597,13 @@ Qed.
(** Specialization of inbetween for two consecutive integers. *)
Definition inbetween_int m x l :=
- inbetween (Z2R m) (Z2R (m + 1)) x l.
+ inbetween (IZR m) (IZR (m + 1)) x l.
Theorem inbetween_float_new_location :
forall x m e l k,
(0 < k)%Z ->
inbetween_float m e x l ->
- inbetween_float (Zdiv m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l).
+ inbetween_float (Z.div m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l).
Proof.
intros x m e l k Hk Hx.
unfold inbetween_float in *.
@@ -630,19 +614,19 @@ apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))).
ring.
omega.
assert (Hp: (Zpower beta k > 0)%Z).
-apply Zlt_gt.
+apply Z.lt_gt.
apply Zpower_gt_0.
now apply Zlt_le_weak.
(* . *)
rewrite 2!Hr.
rewrite Zmult_plus_distr_l, Zmult_1_l.
unfold F2R at 2. simpl.
-rewrite Z2R_plus, Rmult_plus_distr_r.
+rewrite plus_IZR, Rmult_plus_distr_r.
apply new_location_correct.
apply bpow_gt_0.
now apply Zpower_gt_1.
now apply Z_mod_lt.
-rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus.
+rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR.
rewrite Zmult_comm, Zplus_assoc.
now rewrite <- Z_div_mod_eq.
Qed.
@@ -650,7 +634,7 @@ Qed.
Theorem inbetween_float_new_location_single :
forall x m e l,
inbetween_float m e x l ->
- inbetween_float (Zdiv m beta) (e + 1) x (new_location beta (Zmod m beta) l).
+ inbetween_float (Z.div m beta) (e + 1) x (new_location beta (Zmod m beta) l).
Proof.
intros x m e l Hx.
replace (radix_val beta) with (Zpower beta 1).
@@ -665,7 +649,7 @@ Theorem inbetween_float_ex :
Proof.
intros m e l.
apply inbetween_ex.
-apply F2R_lt_compat.
+apply F2R_lt.
apply Zlt_succ.
Qed.
@@ -682,7 +666,7 @@ apply inbetween_unique with (1 := H) (2 := H').
destruct (inbetween_float_bounds x m e l H) as (H1,H2).
destruct (inbetween_float_bounds x m' e l' H') as (H3,H4).
cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega.
-now split ; apply F2R_lt_reg with beta e ; apply Rle_lt_trans with x.
+now split ; apply lt_F2R with beta e ; apply Rle_lt_trans with x.
Qed.
End Fcalc_bracket_generic.
diff --git a/flocq/Calc/Div.v b/flocq/Calc/Div.v
new file mode 100644
index 00000000..65195562
--- /dev/null
+++ b/flocq/Calc/Div.v
@@ -0,0 +1,159 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)
+
+Require Import Raux Defs Generic_fmt Float_prop Digits Bracket.
+
+Set Implicit Arguments.
+Set Strongly Strict Implicit.
+
+Section Fcalc_div.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable fexp : Z -> Z.
+
+(** Computes a mantissa of precision p, the corresponding exponent,
+ and the position with respect to the real quotient of the
+ input floating-point numbers.
+
+The algorithm performs the following steps:
+- Shift dividend mantissa so that it has at least p2 + p digits.
+- Perform the Euclidean division.
+- Compute the position according to the division remainder.
+
+Complexity is fine as long as p1 <= 2p and p2 <= p.
+*)
+
+Lemma mag_div_F2R :
+ forall m1 e1 m2 e2,
+ (0 < m1)%Z -> (0 < m2)%Z ->
+ let e := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
+ (e <= mag beta (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) <= e + 1)%Z.
+Proof.
+intros m1 e1 m2 e2 Hm1 Hm2.
+rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
+rewrite <- (mag_F2R_Zdigits beta m2 e2) by now apply Zgt_not_eq.
+apply mag_div.
+now apply F2R_neq_0, Zgt_not_eq.
+now apply F2R_neq_0, Zgt_not_eq.
+Qed.
+
+Definition Fdiv_core m1 e1 m2 e2 e :=
+ let (m1', m2') :=
+ if Zle_bool e (e1 - e2)%Z
+ then (m1 * Zpower beta (e1 - e2 - e), m2)%Z
+ else (m1, m2 * Zpower beta (e - (e1 - e2)))%Z in
+ let '(q, r) := Z.div_eucl m1' m2' in
+ (q, new_location m2' r loc_Exact).
+
+Theorem Fdiv_core_correct :
+ forall m1 e1 m2 e2 e,
+ (0 < m1)%Z -> (0 < m2)%Z ->
+ let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
+ inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l.
+Proof.
+intros m1 e1 m2 e2 e Hm1 Hm2.
+unfold Fdiv_core.
+match goal with |- context [if ?b then ?b1 else ?b2] => set (m12 := if b then b1 else b2) end.
+case_eq m12 ; intros m1' m2' Hm.
+assert ((F2R (Float beta m1 e1) / F2R (Float beta m2 e2) = IZR m1' / IZR m2' * bpow e)%R /\ (0 < m2')%Z) as [Hf Hm2'].
+{ unfold F2R, Zminus ; simpl.
+ destruct (Zle_bool e (e1 - e2)) eqn:He' ; injection Hm ; intros ; subst.
+ - split ; try easy.
+ apply Zle_bool_imp_le in He'.
+ rewrite mult_IZR, IZR_Zpower by omega.
+ unfold Zminus ; rewrite 2!bpow_plus, 2!bpow_opp.
+ field.
+ repeat split ; try apply Rgt_not_eq, bpow_gt_0.
+ now apply IZR_neq, Zgt_not_eq.
+ - apply Z.leb_gt in He'.
+ split ; cycle 1.
+ { apply Z.mul_pos_pos with (1 := Hm2).
+ apply Zpower_gt_0 ; omega. }
+ rewrite mult_IZR, IZR_Zpower by omega.
+ unfold Zminus ; rewrite bpow_plus, bpow_opp, bpow_plus, bpow_opp.
+ field.
+ repeat split ; try apply Rgt_not_eq, bpow_gt_0.
+ now apply IZR_neq, Zgt_not_eq. }
+clearbody m12 ; clear Hm Hm1 Hm2.
+generalize (Z_div_mod m1' m2' (Z.lt_gt _ _ Hm2')).
+destruct (Z.div_eucl m1' m2') as (q, r).
+intros (Hq, Hr).
+rewrite Hf.
+unfold inbetween_float, F2R. simpl.
+rewrite Hq, 2!plus_IZR, mult_IZR.
+apply inbetween_mult_compat.
+ apply bpow_gt_0.
+destruct (Z_lt_le_dec 1 m2') as [Hm2''|Hm2''].
+- replace 1%R with (IZR m2' * /IZR m2')%R.
+ apply new_location_correct ; try easy.
+ apply Rinv_0_lt_compat.
+ now apply IZR_lt.
+ constructor.
+ field.
+ now apply IZR_neq, Zgt_not_eq.
+ field.
+ now apply IZR_neq, Zgt_not_eq.
+- assert (r = 0 /\ m2' = 1)%Z as [-> ->] by (clear -Hr Hm2'' ; omega).
+ unfold Rdiv.
+ rewrite Rmult_1_l, Rplus_0_r, Rinv_1, Rmult_1_r.
+ now constructor.
+Qed.
+
+Definition Fdiv (x y : float beta) :=
+ let (m1, e1) := x in
+ let (m2, e2) := y in
+ let e' := ((Zdigits beta m1 + e1) - (Zdigits beta m2 + e2))%Z in
+ let e := Z.min (Z.min (fexp e') (fexp (e' + 1))) (e1 - e2) in
+ let '(m, l) := Fdiv_core m1 e1 m2 e2 e in
+ (m, e, l).
+
+Theorem Fdiv_correct :
+ forall x y,
+ (0 < F2R x)%R -> (0 < F2R y)%R ->
+ let '(m, e, l) := Fdiv x y in
+ (e <= cexp beta fexp (F2R x / F2R y))%Z /\
+ inbetween_float beta m e (F2R x / F2R y) l.
+Proof.
+intros [m1 e1] [m2 e2] Hm1 Hm2.
+apply gt_0_F2R in Hm1.
+apply gt_0_F2R in Hm2.
+unfold Fdiv.
+generalize (mag_div_F2R m1 e1 m2 e2 Hm1 Hm2).
+set (e := Zminus _ _).
+set (e' := Z.min (Z.min (fexp e) (fexp (e + 1))) (e1 - e2)).
+intros [H1 H2].
+generalize (Fdiv_core_correct m1 e1 m2 e2 e' Hm1 Hm2).
+destruct Fdiv_core as [m' l].
+apply conj.
+apply Z.le_trans with (1 := Z.le_min_l _ _).
+unfold cexp.
+destruct (Zle_lt_or_eq _ _ H1) as [H|H].
+- replace (fexp (mag _ _)) with (fexp (e + 1)).
+ apply Z.le_min_r.
+ clear -H1 H2 H ; apply f_equal ; omega.
+- replace (fexp (mag _ _)) with (fexp e).
+ apply Z.le_min_l.
+ clear -H1 H2 H ; apply f_equal ; omega.
+Qed.
+
+End Fcalc_div.
diff --git a/flocq/Calc/Fcalc_digits.v b/flocq/Calc/Fcalc_digits.v
deleted file mode 100644
index 45133e81..00000000
--- a/flocq/Calc/Fcalc_digits.v
+++ /dev/null
@@ -1,63 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * Functions for computing the number of digits of integers and related theorems. *)
-
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_float_prop.
-Require Import Fcore_digits.
-
-Section Fcalc_digits.
-
-Variable beta : radix.
-Notation bpow e := (bpow beta e).
-
-Theorem Zdigits_ln_beta :
- forall n,
- n <> Z0 ->
- Zdigits beta n = ln_beta beta (Z2R n).
-Proof.
-intros n Hn.
-destruct (ln_beta beta (Z2R n)) as (e, He) ; simpl.
-specialize (He (Z2R_neq _ _ Hn)).
-rewrite <- Z2R_abs in He.
-assert (Hd := Zdigits_correct beta n).
-assert (Hd' := Zdigits_gt_0 beta n).
-apply Zle_antisym ; apply (bpow_lt_bpow beta).
-apply Rle_lt_trans with (2 := proj2 He).
-rewrite <- Z2R_Zpower by omega.
-now apply Z2R_le.
-apply Rle_lt_trans with (1 := proj1 He).
-rewrite <- Z2R_Zpower by omega.
-now apply Z2R_lt.
-Qed.
-
-Theorem ln_beta_F2R_Zdigits :
- forall m e, m <> Z0 ->
- (ln_beta beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z.
-Proof.
-intros m e Hm.
-rewrite ln_beta_F2R with (1 := Hm).
-apply (f_equal (fun v => Zplus v e)).
-apply sym_eq.
-now apply Zdigits_ln_beta.
-Qed.
-
-End Fcalc_digits.
diff --git a/flocq/Calc/Fcalc_div.v b/flocq/Calc/Fcalc_div.v
deleted file mode 100644
index c8f1f9fc..00000000
--- a/flocq/Calc/Fcalc_div.v
+++ /dev/null
@@ -1,165 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * Helper function and theorem for computing the rounded quotient of two floating-point numbers. *)
-
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_float_prop.
-Require Import Fcore_digits.
-Require Import Fcalc_bracket.
-Require Import Fcalc_digits.
-
-Section Fcalc_div.
-
-Variable beta : radix.
-Notation bpow e := (bpow beta e).
-
-(** Computes a mantissa of precision p, the corresponding exponent,
- and the position with respect to the real quotient of the
- input floating-point numbers.
-
-The algorithm performs the following steps:
-- Shift dividend mantissa so that it has at least p2 + p digits.
-- Perform the Euclidean division.
-- Compute the position according to the division remainder.
-
-Complexity is fine as long as p1 <= 2p and p2 <= p.
-*)
-
-Definition Fdiv_core prec m1 e1 m2 e2 :=
- let d1 := Zdigits beta m1 in
- let d2 := Zdigits beta m2 in
- let e := (e1 - e2)%Z in
- let (m, e') :=
- match (d2 + prec - d1)%Z with
- | Zpos p => (m1 * Zpower_pos beta p, e + Zneg p)%Z
- | _ => (m1, e)
- end in
- let '(q, r) := Zdiv_eucl m m2 in
- (q, e', new_location m2 r loc_Exact).
-
-Theorem Fdiv_core_correct :
- forall prec m1 e1 m2 e2,
- (0 < prec)%Z ->
- (0 < m1)%Z -> (0 < m2)%Z ->
- let '(m, e, l) := Fdiv_core prec m1 e1 m2 e2 in
- (prec <= Zdigits beta m)%Z /\
- inbetween_float beta m e (F2R (Float beta m1 e1) / F2R (Float beta m2 e2)) l.
-Proof.
-intros prec m1 e1 m2 e2 Hprec Hm1 Hm2.
-unfold Fdiv_core.
-set (d1 := Zdigits beta m1).
-set (d2 := Zdigits beta m2).
-case_eq
- (match (d2 + prec - d1)%Z with
- | Zpos p => ((m1 * Zpower_pos beta p)%Z, (e1 - e2 + Zneg p)%Z)
- | _ => (m1, (e1 - e2)%Z)
- end).
-intros m' e' Hme.
-(* . the shifted mantissa m' has enough digits *)
-assert (Hs: F2R (Float beta m' (e' + e2)) = F2R (Float beta m1 e1) /\ (0 < m')%Z /\ (d2 + prec <= Zdigits beta m')%Z).
-replace (d2 + prec)%Z with (d2 + prec - d1 + d1)%Z by ring.
-destruct (d2 + prec - d1)%Z as [|p|p] ;
- unfold d1 ;
- inversion Hme.
-ring_simplify (e1 - e2 + e2)%Z.
-repeat split.
-now rewrite <- H0.
-apply Zle_refl.
-replace (e1 - e2 + Zneg p + e2)%Z with (e1 - Zpos p)%Z by (unfold Zminus ; simpl ; ring).
-fold (Zpower beta (Zpos p)).
-split.
-pattern (Zpos p) at 1 ; replace (Zpos p) with (e1 - (e1 - Zpos p))%Z by ring.
-apply sym_eq.
-apply F2R_change_exp.
-assert (0 < Zpos p)%Z by easy.
-omega.
-split.
-apply Zmult_lt_0_compat.
-exact Hm1.
-now apply Zpower_gt_0.
-rewrite Zdigits_mult_Zpower.
-rewrite Zplus_comm.
-apply Zle_refl.
-apply sym_not_eq.
-now apply Zlt_not_eq.
-easy.
-split.
-now ring_simplify (e1 - e2 + e2)%Z.
-assert (Zneg p < 0)%Z by easy.
-omega.
-(* . *)
-destruct Hs as (Hs1, (Hs2, Hs3)).
-rewrite <- Hs1.
-generalize (Z_div_mod m' m2 (Zlt_gt _ _ Hm2)).
-destruct (Zdiv_eucl m' m2) as (q, r).
-intros (Hq, Hr).
-split.
-(* . the result mantissa q has enough digits *)
-cut (Zdigits beta m' <= d2 + Zdigits beta q)%Z. omega.
-unfold d2.
-rewrite Hq.
-assert (Hq': (0 < q)%Z).
-apply Zmult_lt_reg_r with (1 := Hm2).
-assert (m2 < m')%Z.
-apply lt_Zdigits with beta.
-now apply Zlt_le_weak.
-unfold d2 in Hs3.
-clear -Hprec Hs3 ; omega.
-cut (q * m2 = m' - r)%Z. clear -Hr H ; omega.
-rewrite Hq.
-ring.
-apply Zle_trans with (Zdigits beta (m2 + q + m2 * q)).
-apply Zdigits_le.
-rewrite <- Hq.
-now apply Zlt_le_weak.
-clear -Hr Hq'. omega.
-apply Zdigits_mult_strong ; apply Zlt_le_weak.
-now apply Zle_lt_trans with r.
-exact Hq'.
-(* . the location is correctly computed *)
-unfold inbetween_float, F2R. simpl.
-rewrite bpow_plus, Z2R_plus.
-rewrite Hq, Z2R_plus, Z2R_mult.
-replace ((Z2R m2 * Z2R q + Z2R r) * (bpow e' * bpow e2) / (Z2R m2 * bpow e2))%R
- with ((Z2R q + Z2R r / Z2R m2) * bpow e')%R.
-apply inbetween_mult_compat.
-apply bpow_gt_0.
-destruct (Z_lt_le_dec 1 m2) as [Hm2''|Hm2''].
-replace (Z2R 1) with (Z2R m2 * /Z2R m2)%R.
-apply new_location_correct ; try easy.
-apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0).
-now constructor.
-apply Rinv_r.
-apply Rgt_not_eq.
-now apply (Z2R_lt 0).
-assert (r = 0 /\ m2 = 1)%Z by (clear -Hr Hm2'' ; omega).
-rewrite (proj1 H), (proj2 H).
-unfold Rdiv.
-rewrite Rmult_0_l, Rplus_0_r.
-now constructor.
-field.
-split ; apply Rgt_not_eq.
-apply bpow_gt_0.
-now apply (Z2R_lt 0).
-Qed.
-
-End Fcalc_div.
diff --git a/flocq/Calc/Fcalc_sqrt.v b/flocq/Calc/Fcalc_sqrt.v
deleted file mode 100644
index 5f541d83..00000000
--- a/flocq/Calc/Fcalc_sqrt.v
+++ /dev/null
@@ -1,244 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)
-
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_digits.
-Require Import Fcore_float_prop.
-Require Import Fcalc_bracket.
-Require Import Fcalc_digits.
-
-Section Fcalc_sqrt.
-
-Variable beta : radix.
-Notation bpow e := (bpow beta e).
-
-(** Computes a mantissa of precision p, the corresponding exponent,
- and the position with respect to the real square root of the
- input floating-point number.
-
-The algorithm performs the following steps:
-- Shift the mantissa so that it has at least 2p-1 digits;
- shift it one digit more if the new exponent is not even.
-- Compute the square root s (at least p digits) of the new
- mantissa, and its remainder r.
-- Compute the position according to the remainder:
- -- r == 0 => Eq,
- -- r <= s => Lo,
- -- r >= s => Up.
-
-Complexity is fine as long as p1 <= 2p-1.
-*)
-
-Definition Fsqrt_core prec m e :=
- let d := Zdigits beta m in
- let s := Zmax (2 * prec - d) 0 in
- let e' := (e - s)%Z in
- let (s', e'') := if Zeven e' then (s, e') else (s + 1, e' - 1)%Z in
- let m' :=
- match s' with
- | Zpos p => (m * Zpower_pos beta p)%Z
- | _ => m
- end in
- let (q, r) := Z.sqrtrem m' in
- let l :=
- if Zeq_bool r 0 then loc_Exact
- else loc_Inexact (if Zle_bool r q then Lt else Gt) in
- (q, Zdiv2 e'', l).
-
-Theorem Fsqrt_core_correct :
- forall prec m e,
- (0 < m)%Z ->
- let '(m', e', l) := Fsqrt_core prec m e in
- (prec <= Zdigits beta m')%Z /\
- inbetween_float beta m' e' (sqrt (F2R (Float beta m e))) l.
-Proof.
-intros prec m e Hm.
-unfold Fsqrt_core.
-set (d := Zdigits beta m).
-set (s := Zmax (2 * prec - d) 0).
-(* . exponent *)
-case_eq (if Zeven (e - s) then (s, (e - s)%Z) else ((s + 1)%Z, (e - s - 1)%Z)).
-intros s' e' Hse.
-assert (He: (Zeven e' = true /\ 0 <= s' /\ 2 * prec - d <= s' /\ s' + e' = e)%Z).
-revert Hse.
-case_eq (Zeven (e - s)) ; intros He Hse ; inversion Hse.
-repeat split.
-exact He.
-unfold s.
-apply Zle_max_r.
-apply Zle_max_l.
-ring.
-assert (H: (Zmax (2 * prec - d) 0 <= s + 1)%Z).
-fold s.
-apply Zle_succ.
-repeat split.
-unfold Zminus at 1.
-now rewrite Zeven_plus, He.
-apply Zle_trans with (2 := H).
-apply Zle_max_r.
-apply Zle_trans with (2 := H).
-apply Zle_max_l.
-ring.
-clear -Hm He.
-destruct He as (He1, (He2, (He3, He4))).
-(* . shift *)
-set (m' := match s' with
- | Z0 => m
- | Zpos p => (m * Zpower_pos beta p)%Z
- | Zneg _ => m
- end).
-assert (Hs: F2R (Float beta m' e') = F2R (Float beta m e) /\ (2 * prec <= Zdigits beta m')%Z /\ (0 < m')%Z).
-rewrite <- He4.
-unfold m'.
-destruct s' as [|p|p].
-repeat split ; try easy.
-fold d.
-omega.
-fold (Zpower beta (Zpos p)).
-split.
-replace (Zpos p) with (Zpos p + e' - e')%Z by ring.
-rewrite <- F2R_change_exp.
-apply (f_equal (fun v => F2R (Float beta m v))).
-ring.
-assert (0 < Zpos p)%Z by easy.
-omega.
-split.
-rewrite Zdigits_mult_Zpower.
-fold d.
-omega.
-apply sym_not_eq.
-now apply Zlt_not_eq.
-easy.
-apply Zmult_lt_0_compat.
-exact Hm.
-now apply Zpower_gt_0.
-now elim He2.
-clearbody m'.
-destruct Hs as (Hs1, (Hs2, Hs3)).
-generalize (Z.sqrtrem_spec m' (Zlt_le_weak _ _ Hs3)).
-destruct (Z.sqrtrem m') as (q, r).
-intros (Hq, Hr).
-rewrite <- Hs1. clear Hs1.
-split.
-(* . mantissa width *)
-apply Zmult_le_reg_r with 2%Z.
-easy.
-rewrite Zmult_comm.
-apply Zle_trans with (1 := Hs2).
-rewrite Hq.
-apply Zle_trans with (Zdigits beta (q + q + q * q)).
-apply Zdigits_le.
-rewrite <- Hq.
-now apply Zlt_le_weak.
-omega.
-replace (Zdigits beta q * 2)%Z with (Zdigits beta q + Zdigits beta q)%Z by ring.
-apply Zdigits_mult_strong.
-omega.
-omega.
-(* . round *)
-unfold inbetween_float, F2R. simpl.
-rewrite sqrt_mult.
-2: now apply (Z2R_le 0) ; apply Zlt_le_weak.
-2: apply Rlt_le ; apply bpow_gt_0.
-destruct (Zeven_ex e') as (e2, Hev).
-rewrite He1, Zplus_0_r in Hev. clear He1.
-rewrite Hev.
-replace (Zdiv2 (2 * e2)) with e2 by now case e2.
-replace (2 * e2)%Z with (e2 + e2)%Z by ring.
-rewrite bpow_plus.
-fold (Rsqr (bpow e2)).
-rewrite sqrt_Rsqr.
-2: apply Rlt_le ; apply bpow_gt_0.
-apply inbetween_mult_compat.
-apply bpow_gt_0.
-rewrite Hq.
-case Zeq_bool_spec ; intros Hr'.
-(* .. r = 0 *)
-rewrite Hr', Zplus_0_r, Z2R_mult.
-fold (Rsqr (Z2R q)).
-rewrite sqrt_Rsqr.
-now constructor.
-apply (Z2R_le 0).
-omega.
-(* .. r <> 0 *)
-constructor.
-split.
-(* ... bounds *)
-apply Rle_lt_trans with (sqrt (Z2R (q * q))).
-rewrite Z2R_mult.
-fold (Rsqr (Z2R q)).
-rewrite sqrt_Rsqr.
-apply Rle_refl.
-apply (Z2R_le 0).
-omega.
-apply sqrt_lt_1.
-rewrite Z2R_mult.
-apply Rle_0_sqr.
-rewrite <- Hq.
-apply (Z2R_le 0).
-now apply Zlt_le_weak.
-apply Z2R_lt.
-omega.
-apply Rlt_le_trans with (sqrt (Z2R ((q + 1) * (q + 1)))).
-apply sqrt_lt_1.
-rewrite <- Hq.
-apply (Z2R_le 0).
-now apply Zlt_le_weak.
-rewrite Z2R_mult.
-apply Rle_0_sqr.
-apply Z2R_lt.
-ring_simplify.
-omega.
-rewrite Z2R_mult.
-fold (Rsqr (Z2R (q + 1))).
-rewrite sqrt_Rsqr.
-apply Rle_refl.
-apply (Z2R_le 0).
-omega.
-(* ... location *)
-rewrite Rcompare_half_r.
-rewrite <- Rcompare_sqr.
-replace ((2 * sqrt (Z2R (q * q + r))) * (2 * sqrt (Z2R (q * q + r))))%R
- with (4 * Rsqr (sqrt (Z2R (q * q + r))))%R by (unfold Rsqr ; ring).
-rewrite Rsqr_sqrt.
-change 4%R with (Z2R 4).
-rewrite <- Z2R_plus, <- 2!Z2R_mult.
-rewrite Rcompare_Z2R.
-replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
-generalize (Zle_cases r q).
-case (Zle_bool r q) ; intros Hr''.
-change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
-omega.
-change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
-omega.
-rewrite <- Hq.
-apply (Z2R_le 0).
-now apply Zlt_le_weak.
-apply Rmult_le_pos.
-now apply (Z2R_le 0 2).
-apply sqrt_ge_0.
-rewrite <- Z2R_plus.
-apply (Z2R_le 0).
-omega.
-Qed.
-
-End Fcalc_sqrt.
diff --git a/flocq/Calc/Fcalc_ops.v b/flocq/Calc/Operations.v
index e834c044..3416cb4e 100644
--- a/flocq/Calc/Fcalc_ops.v
+++ b/flocq/Calc/Operations.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,9 +18,10 @@ COPYING file for more details.
*)
(** Basic operations on floats: alignment, addition, multiplication *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_float_prop.
+Require Import Raux Defs Float_prop.
+
+Set Implicit Arguments.
+Set Strongly Strict Implicit.
Section Float_ops.
@@ -28,7 +29,7 @@ Variable beta : radix.
Notation bpow e := (bpow beta e).
-Arguments Float {beta} Fnum Fexp.
+Arguments Float {beta}.
Definition Falign (f1 f2 : float beta) :=
let '(Float m1 e1) := f1 in
@@ -54,7 +55,7 @@ Qed.
Theorem Falign_spec_exp:
forall f1 f2 : float beta,
- snd (Falign f1 f2) = Zmin (Fexp f1) (Fexp f2).
+ snd (Falign f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof.
intros (m1,e1) (m2,e2).
unfold Falign; simpl.
@@ -76,7 +77,7 @@ Qed.
Definition Fabs (f1 : float beta) : float beta :=
let '(Float m1 e1) := f1 in
- Float (Zabs m1)%Z e1.
+ Float (Z.abs m1)%Z e1.
Theorem F2R_abs :
forall f1 : float beta,
@@ -100,7 +101,7 @@ destruct (Falign f1 f2) as ((m1, m2), e).
intros (H1, H2).
rewrite H1, H2.
unfold F2R. simpl.
-rewrite Z2R_plus.
+rewrite plus_IZR.
apply Rmult_plus_distr_r.
Qed.
@@ -116,7 +117,7 @@ Qed.
Theorem Fexp_Fplus :
forall f1 f2 : float beta,
- Fexp (Fplus f1 f2) = Zmin (Fexp f1) (Fexp f2).
+ Fexp (Fplus f1 f2) = Z.min (Fexp f1) (Fexp f2).
Proof.
intros f1 f2.
unfold Fplus.
@@ -156,7 +157,7 @@ Theorem F2R_mult :
Proof.
intros (m1, e1) (m2, e2).
unfold Fmult, F2R. simpl.
-rewrite Z2R_mult, bpow_plus.
+rewrite mult_IZR, bpow_plus.
ring.
Qed.
diff --git a/flocq/Calc/Fcalc_round.v b/flocq/Calc/Round.v
index 86422247..5bde6af4 100644
--- a/flocq/Calc/Fcalc_round.v
+++ b/flocq/Calc/Round.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -19,10 +19,7 @@ COPYING file for more details.
(** * Helper function for computing the rounded value of a real number. *)
-Require Import Fcore.
-Require Import Fcore_digits.
-Require Import Fcalc_bracket.
-Require Import Fcalc_digits.
+Require Import Core Digits Float_prop Bracket.
Section Fcalc_round.
@@ -35,19 +32,78 @@ Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Notation format := (generic_format beta fexp).
+Theorem cexp_inbetween_float :
+ forall x m e l,
+ (0 < x)%R ->
+ inbetween_float beta m e x l ->
+ (e <= cexp beta fexp x \/ e <= fexp (Zdigits beta m + e))%Z ->
+ cexp beta fexp x = fexp (Zdigits beta m + e).
+Proof.
+intros x m e l Px Bx He.
+unfold cexp.
+apply inbetween_float_bounds in Bx.
+assert (0 <= m)%Z as Hm.
+{ apply Zlt_succ_le.
+ eapply gt_0_F2R.
+ apply Rlt_trans with (1 := Px).
+ apply Bx. }
+destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|<-].
+ now erewrite <- mag_F2R_bounds_Zdigits with (1 := Hm').
+clear Hm.
+assert (mag beta x <= e)%Z as Hx.
+{ apply mag_le_bpow.
+ now apply Rgt_not_eq.
+ rewrite Rabs_pos_eq.
+ now rewrite <- F2R_bpow.
+ now apply Rlt_le. }
+simpl in He |- *.
+clear Bx.
+destruct He as [He|He].
+- apply eq_sym, valid_exp with (2 := He).
+ now apply Z.le_trans with e.
+- apply valid_exp with (1 := He).
+ now apply Z.le_trans with e.
+Qed.
+
+Theorem cexp_inbetween_float_loc_Exact :
+ forall x m e l,
+ (0 <= x)%R ->
+ inbetween_float beta m e x l ->
+ (e <= cexp beta fexp x \/ l = loc_Exact <->
+ e <= fexp (Zdigits beta m + e) \/ l = loc_Exact)%Z.
+Proof.
+intros x m e l Px Bx.
+destruct Px as [Px|Px].
+- split ; (intros [H|H] ; [left|now right]).
+ rewrite <- cexp_inbetween_float with (1 := Px) (2 := Bx).
+ exact H.
+ now left.
+ rewrite cexp_inbetween_float with (1 := Px) (2 := Bx).
+ exact H.
+ now right.
+- assert (H := Bx).
+ destruct Bx as [|c Bx _].
+ now split ; right.
+ rewrite <- Px in Bx.
+ destruct Bx as [Bx1 Bx2].
+ apply lt_0_F2R in Bx1.
+ apply gt_0_F2R in Bx2.
+ omega.
+Qed.
+
(** Relates location and rounding. *)
Theorem inbetween_float_round :
forall rnd choice,
( forall x m l, inbetween_int m x l -> rnd x = choice m l ) ->
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof.
intros rnd choice Hc x m l e Hl.
unfold round, F2R. simpl.
-apply (f_equal (fun m => (Z2R m * bpow e)%R)).
+apply (f_equal (fun m => (IZR m * bpow e)%R)).
apply Hc.
apply inbetween_mult_reg with (bpow e).
apply bpow_gt_0.
@@ -61,12 +117,12 @@ Theorem inbetween_float_round_sign :
( forall x m l, inbetween_int m (Rabs x) l ->
rnd x = cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l) ) ->
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof.
intros rnd choice Hc x m l e Hx.
-apply (f_equal (fun m => (Z2R m * bpow e)%R)).
+apply (f_equal (fun m => (IZR m * bpow e)%R)).
simpl.
replace (Rlt_bool x 0) with (Rlt_bool (scaled_mantissa beta fexp x) 0).
(* *)
@@ -99,13 +155,13 @@ Proof.
intros x m l Hl.
refine (Zfloor_imp m _ _).
apply inbetween_bounds with (2 := Hl).
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
Qed.
Theorem inbetween_float_DN :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Zfloor x = F2R (Float beta m e).
Proof.
@@ -131,23 +187,23 @@ destruct (Rcase_abs x) as [Zx|Zx] .
rewrite Rlt_bool_true with (1 := Zx).
inversion_clear Hl ; simpl.
rewrite <- (Ropp_involutive x).
-rewrite H, <- Z2R_opp.
-apply Zfloor_Z2R.
+rewrite H, <- opp_IZR.
+apply Zfloor_IZR.
apply Zfloor_imp.
split.
apply Rlt_le.
-rewrite Z2R_opp.
+rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
ring_simplify (- (m + 1) + 1)%Z.
-rewrite Z2R_opp.
+rewrite opp_IZR.
apply Ropp_lt_cancel.
now rewrite Ropp_involutive.
(* *)
rewrite Rlt_bool_false.
inversion_clear Hl ; simpl.
rewrite H.
-apply Zfloor_Z2R.
+apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
@@ -157,7 +213,7 @@ Qed.
Theorem inbetween_float_DN_sign :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Zfloor x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_DN (Rlt_bool x 0) l) m)) e).
Proof.
@@ -186,7 +242,7 @@ destruct Hl' as [Hl'|(Hl1, Hl2)].
rewrite Hl'.
destruct Hl ; try easy.
rewrite H.
-exact (Zceil_Z2R _).
+exact (Zceil_IZR _).
(* not Exact *)
rewrite Hl2.
simpl.
@@ -198,7 +254,7 @@ Qed.
Theorem inbetween_float_UP :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Zceil x = F2R (Float beta (cond_incr (round_UP l) m) e).
Proof.
@@ -227,7 +283,7 @@ unfold Zceil.
apply f_equal.
inversion_clear Hl ; simpl.
rewrite H.
-apply Zfloor_Z2R.
+apply Zfloor_IZR.
apply Zfloor_imp.
split.
now apply Rlt_le.
@@ -237,10 +293,10 @@ rewrite Rlt_bool_false.
simpl.
inversion_clear Hl ; simpl.
rewrite H.
-apply Zceil_Z2R.
+apply Zceil_IZR.
apply Zceil_imp.
split.
-change (m + 1 - 1)%Z with (Zpred (Zsucc m)).
+change (m + 1 - 1)%Z with (Z.pred (Z.succ m)).
now rewrite <- Zpred_succ.
now apply Rlt_le.
now apply Rge_le.
@@ -248,7 +304,7 @@ Qed.
Theorem inbetween_float_UP_sign :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Zceil x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_sign_UP (Rlt_bool x 0) l) m)) e).
Proof.
@@ -273,7 +329,7 @@ intros x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].
(* Exact *)
rewrite Hx.
-rewrite Zrnd_Z2R...
+rewrite Zrnd_IZR...
(* not Exact *)
unfold Ztrunc.
assert (Hm: Zfloor x = m).
@@ -288,10 +344,10 @@ case Rlt_bool_spec ; intros Hx' ;
elim Rlt_not_le with (1 := Hx').
apply Rlt_le.
apply Rle_lt_trans with (2 := proj1 Hx).
-now apply (Z2R_le 0).
+now apply IZR_le.
elim Rle_not_lt with (1 := Hx').
apply Rlt_le_trans with (1 := proj2 Hx).
-apply (Z2R_le _ 0).
+apply IZR_le.
now apply Zlt_le_succ.
rewrite Hm.
now apply Rlt_not_eq.
@@ -299,7 +355,7 @@ Qed.
Theorem inbetween_float_ZR :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp Ztrunc x = F2R (Float beta (cond_incr (round_ZR (Zlt_bool m 0) l) m) e).
Proof.
@@ -324,7 +380,7 @@ apply f_equal.
apply Zfloor_imp.
rewrite <- Rabs_left with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
(* *)
rewrite Rlt_bool_false with (1 := Zx).
@@ -332,13 +388,13 @@ simpl.
apply Zfloor_imp.
rewrite <- Rabs_pos_eq with (1 := Zx).
apply inbetween_bounds with (2 := Hl).
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
Qed.
Theorem inbetween_float_ZR_sign :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
round beta fexp Ztrunc x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) m) e).
Proof.
@@ -365,7 +421,7 @@ intros choice x m l Hl.
inversion_clear Hl as [Hx|l' Hx Hl'].
(* Exact *)
rewrite Hx.
-rewrite Zrnd_Z2R...
+rewrite Zrnd_IZR...
(* not Exact *)
unfold Znearest.
assert (Hm: Zfloor x = m).
@@ -373,13 +429,12 @@ apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
rewrite Zceil_floor_neq.
rewrite Hm.
-replace (Rcompare (x - Z2R m) (/2)) with l'.
+replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
-rewrite Z2R_plus.
-rewrite <- (Rcompare_plus_r (- Z2R m) x).
+rewrite plus_IZR.
+rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
-simpl (Z2R 1).
field.
rewrite Hm.
now apply Rlt_not_eq.
@@ -402,20 +457,19 @@ rewrite Znearest_opp.
apply f_equal.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
-apply Zrnd_Z2R...
+apply Zrnd_IZR...
assert (Hm: Zfloor (-x) = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
-replace (Rcompare (- x - Z2R m) (/2)) with l'.
+replace (Rcompare (- x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
-rewrite Z2R_plus.
-rewrite <- (Rcompare_plus_r (- Z2R m) (-x)).
+rewrite plus_IZR.
+rewrite <- (Rcompare_plus_r (- IZR m) (-x)).
apply f_equal.
-simpl (Z2R 1).
field.
rewrite Hm.
now apply Rlt_not_eq.
@@ -426,20 +480,19 @@ rewrite Rlt_bool_false with (1 := Zx).
simpl.
inversion_clear Hl as [Hx|l' Hx Hl'].
rewrite Hx.
-apply Zrnd_Z2R...
+apply Zrnd_IZR...
assert (Hm: Zfloor x = m).
apply Zfloor_imp.
exact (conj (Rlt_le _ _ (proj1 Hx)) (proj2 Hx)).
unfold Znearest.
rewrite Zceil_floor_neq.
rewrite Hm.
-replace (Rcompare (x - Z2R m) (/2)) with l'.
+replace (Rcompare (x - IZR m) (/2)) with l'.
now case l'.
rewrite <- Hl'.
-rewrite Z2R_plus.
-rewrite <- (Rcompare_plus_r (- Z2R m) x).
+rewrite plus_IZR.
+rewrite <- (Rcompare_plus_r (- IZR m) x).
apply f_equal.
-simpl (Z2R 1).
field.
rewrite Hm.
now apply Rlt_not_eq.
@@ -450,44 +503,44 @@ Qed.
Theorem inbetween_int_NE :
forall x m l,
inbetween_int m x l ->
- ZnearestE x = cond_incr (round_N (negb (Zeven m)) l) m.
+ ZnearestE x = cond_incr (round_N (negb (Z.even m)) l) m.
Proof.
intros x m l Hl.
-now apply inbetween_int_N with (choice := fun x => negb (Zeven x)).
+now apply inbetween_int_N with (choice := fun x => negb (Z.even x)).
Qed.
Theorem inbetween_float_NE :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
- round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Zeven m)) l) m) e).
+ round beta fexp ZnearestE x = F2R (Float beta (cond_incr (round_N (negb (Z.even m)) l) m) e).
Proof.
-apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Zeven m)) l) m).
+apply inbetween_float_round with (choice := fun m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE.
Qed.
Theorem inbetween_int_NE_sign :
forall x m l,
inbetween_int m (Rabs x) l ->
- ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m).
+ ZnearestE x = cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m).
Proof.
intros x m l Hl.
-erewrite inbetween_int_N_sign with (choice := fun x => negb (Zeven x)).
+erewrite inbetween_int_N_sign with (choice := fun x => negb (Z.even x)).
2: eexact Hl.
apply f_equal.
case Rlt_bool.
-rewrite Zeven_opp, Zeven_plus.
-now case (Zeven m).
+rewrite Z.even_opp, Z.even_add.
+now case (Z.even m).
apply refl_equal.
Qed.
Theorem inbetween_float_NE_sign :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e (Rabs x) l ->
- round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Zeven m)) l) m)) e).
+ round beta fexp ZnearestE x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (cond_incr (round_N (negb (Z.even m)) l) m)) e).
Proof.
-apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Zeven m)) l) m).
+apply inbetween_float_round_sign with (choice := fun s m l => cond_incr (round_N (negb (Z.even m)) l) m).
exact inbetween_int_NE_sign.
Qed.
@@ -504,7 +557,7 @@ Qed.
Theorem inbetween_float_NA :
forall x m l,
- let e := canonic_exp beta fexp x in
+ let e := cexp beta fexp x in
inbetween_float beta m e x l ->
round beta fexp ZnearestA x = F2R (Float beta (cond_incr (round_N (Zle_bool 0 m) l) m) e).
Proof.
@@ -523,11 +576,11 @@ erewrite inbetween_int_N_sign with (choice := Zle_bool 0).
apply f_equal.
assert (Hm: (0 <= m)%Z).
apply Zlt_succ_le.
-apply lt_Z2R.
+apply lt_IZR.
apply Rle_lt_trans with (Rabs x).
apply Rabs_pos.
refine (proj2 (inbetween_bounds _ _ _ _ _ Hl)).
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
rewrite Zle_bool_true with (1 := Hm).
rewrite Zle_bool_false.
@@ -538,7 +591,7 @@ Qed.
Definition truncate_aux t k :=
let '(m, e, l) := t in
let p := Zpower beta k in
- (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l).
+ (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l).
Theorem truncate_aux_comp :
forall t k1 k2,
@@ -597,28 +650,28 @@ case Zlt_bool_spec ; intros Hk.
unfold truncate_aux.
apply generic_format_F2R.
intros Hd.
-unfold canonic_exp.
-rewrite ln_beta_F2R_Zdigits with (1 := Hd).
+unfold cexp.
+rewrite mag_F2R_Zdigits with (1 := Hd).
rewrite Zdigits_div_Zpower with (1 := Hm).
replace (Zdigits beta m - k + (e + k))%Z with (Zdigits beta m + e)%Z by ring.
unfold k.
ring_simplify.
-apply Zle_refl.
+apply Z.le_refl.
split.
now apply Zlt_le_weak.
apply Znot_gt_le.
contradict Hd.
apply Zdiv_small.
apply conj with (1 := Hm).
-rewrite <- Zabs_eq with (1 := Hm).
+rewrite <- Z.abs_eq with (1 := Hm).
apply Zpower_gt_Zdigits.
apply Zlt_le_weak.
-now apply Zgt_lt.
+now apply Z.gt_lt.
(* *)
destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm'].
apply generic_format_F2R.
-unfold canonic_exp.
-rewrite ln_beta_F2R_Zdigits.
+unfold cexp.
+rewrite mag_F2R_Zdigits.
2: now apply Zgt_not_eq.
unfold k in Hk. clear -Hk.
omega.
@@ -633,26 +686,26 @@ Theorem truncate_correct_format :
generic_format beta fexp x ->
(e <= fexp (Zdigits beta m + e))%Z ->
let '(m', e', l') := truncate (m, e, loc_Exact) in
- x = F2R (Float beta m' e') /\ e' = canonic_exp beta fexp x.
+ x = F2R (Float beta m' e') /\ e' = cexp beta fexp x.
Proof.
intros m e Hm x Fx He.
-assert (Hc: canonic_exp beta fexp x = fexp (Zdigits beta m + e)).
-unfold canonic_exp, x.
-now rewrite ln_beta_F2R_Zdigits.
+assert (Hc: cexp beta fexp x = fexp (Zdigits beta m + e)).
+unfold cexp, x.
+now rewrite mag_F2R_Zdigits.
unfold truncate.
rewrite <- Hc.
-set (k := (canonic_exp beta fexp x - e)%Z).
+set (k := (cexp beta fexp x - e)%Z).
case Zlt_bool_spec ; intros Hk.
(* *)
unfold truncate_aux.
rewrite Fx at 1.
-assert (H: (e + k)%Z = canonic_exp beta fexp x).
+assert (H: (e + k)%Z = cexp beta fexp x).
unfold k. ring.
refine (conj _ H).
rewrite <- H.
-apply F2R_eq_compat.
-replace (scaled_mantissa beta fexp x) with (Z2R (Zfloor (scaled_mantissa beta fexp x))).
-rewrite Ztrunc_Z2R.
+apply F2R_eq.
+replace (scaled_mantissa beta fexp x) with (IZR (Zfloor (scaled_mantissa beta fexp x))).
+rewrite Ztrunc_IZR.
unfold scaled_mantissa.
rewrite <- H.
unfold x, F2R. simpl.
@@ -666,7 +719,7 @@ intros H.
generalize (Zpower_pos_gt_0 beta k) (Zle_bool_imp_le _ _ (radix_prop beta)).
omega.
rewrite scaled_mantissa_generic with (1 := Fx).
-now rewrite Zfloor_Z2R.
+now rewrite Zfloor_IZR.
(* *)
split.
apply refl_equal.
@@ -674,73 +727,111 @@ unfold k in Hk.
omega.
Qed.
+Theorem truncate_correct_partial' :
+ forall x m e l,
+ (0 < x)%R ->
+ inbetween_float beta m e x l ->
+ (e <= cexp beta fexp x)%Z ->
+ let '(m', e', l') := truncate (m, e, l) in
+ inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
+Proof.
+intros x m e l Hx H1 H2.
+unfold truncate.
+rewrite <- cexp_inbetween_float with (1 := Hx) (2 := H1) by now left.
+generalize (Zlt_cases 0 (cexp beta fexp x - e)).
+destruct Zlt_bool ; intros Hk.
+- split.
+ now apply inbetween_float_new_location.
+ ring.
+- apply (conj H1).
+ omega.
+Qed.
+
Theorem truncate_correct_partial :
forall x m e l,
(0 < x)%R ->
inbetween_float beta m e x l ->
(e <= fexp (Zdigits beta m + e))%Z ->
let '(m', e', l') := truncate (m, e, l) in
- inbetween_float beta m' e' x l' /\ e' = canonic_exp beta fexp x.
+ inbetween_float beta m' e' x l' /\ e' = cexp beta fexp x.
Proof.
intros x m e l Hx H1 H2.
-unfold truncate.
-set (k := (fexp (Zdigits beta m + e) - e)%Z).
-set (p := Zpower beta k).
-(* *)
-assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R).
-apply inbetween_float_bounds with (1 := H1).
-(* *)
-assert (Hm: (0 <= m)%Z).
-cut (0 < m + 1)%Z. omega.
-apply F2R_lt_reg with beta e.
-rewrite F2R_0.
-apply Rlt_trans with (1 := Hx).
-apply Hx'.
-assert (He: (e + k = canonic_exp beta fexp x)%Z).
-(* . *)
-unfold canonic_exp.
-destruct (Zle_lt_or_eq _ _ Hm) as [Hm'|Hm'].
-(* .. 0 < m *)
-rewrite ln_beta_F2R_bounds with (1 := Hm') (2 := Hx').
-assert (H: m <> Z0).
-apply sym_not_eq.
-now apply Zlt_not_eq.
-rewrite ln_beta_F2R with (1 := H).
-rewrite <- Zdigits_ln_beta with (1 := H).
-unfold k.
-ring.
-(* .. m = 0 *)
-rewrite <- Hm' in H2.
-destruct (ln_beta beta x) as (ex, Hex).
-simpl.
-specialize (Hex (Rgt_not_eq _ _ Hx)).
-unfold k.
-ring_simplify.
-rewrite <- Hm'.
-simpl.
-apply sym_eq.
-apply valid_exp.
-exact H2.
-apply Zle_trans with e.
-eapply bpow_lt_bpow.
-apply Rle_lt_trans with (1 := proj1 Hex).
-rewrite Rabs_pos_eq.
-rewrite <- F2R_bpow.
-rewrite <- Hm' in Hx'.
-apply Hx'.
-now apply Rlt_le.
+apply truncate_correct_partial' with (1 := Hx) (2 := H1).
+rewrite cexp_inbetween_float with (1 := Hx) (2 := H1).
exact H2.
-(* . *)
-generalize (Zlt_cases 0 k).
-case (Zlt_bool 0 k) ; intros Hk ; unfold k in Hk.
-split.
-now apply inbetween_float_new_location.
-exact He.
-split.
-exact H1.
-rewrite <- He.
-unfold k.
-omega.
+now right.
+Qed.
+
+Theorem truncate_correct' :
+ forall x m e l,
+ (0 <= x)%R ->
+ inbetween_float beta m e x l ->
+ (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
+ let '(m', e', l') := truncate (m, e, l) in
+ inbetween_float beta m' e' x l' /\
+ (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
+Proof.
+intros x m e l [Hx|Hx] H1 H2.
+- destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3].
+ + generalize (truncate_correct_partial x m e l Hx H1 H3).
+ destruct (truncate (m, e, l)) as [[m' e'] l'].
+ intros [H4 H5].
+ apply (conj H4).
+ now left.
+ + destruct H2 as [H2|H2].
+ generalize (truncate_correct_partial' x m e l Hx H1 H2).
+ destruct (truncate (m, e, l)) as [[m' e'] l'].
+ intros [H4 H5].
+ apply (conj H4).
+ now left.
+ rewrite H2 in H1 |- *.
+ simpl.
+ generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)).
+ destruct Zlt_bool.
+ intros H.
+ apply False_ind.
+ omega.
+ intros _.
+ apply (conj H1).
+ right.
+ repeat split.
+ inversion_clear H1.
+ rewrite H.
+ apply generic_format_F2R.
+ intros Zm.
+ unfold cexp.
+ rewrite mag_F2R_Zdigits with (1 := Zm).
+ now apply Zlt_le_weak.
+- assert (Hm: m = 0%Z).
+ cut (m <= 0 < m + 1)%Z. omega.
+ assert (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R as Hx'.
+ apply inbetween_float_bounds with (1 := H1).
+ rewrite <- Hx in Hx'.
+ split.
+ apply le_0_F2R with (1 := proj1 Hx').
+ apply gt_0_F2R with (1 := proj2 Hx').
+ rewrite Hm, <- Hx in H1 |- *.
+ clear -H1.
+ destruct H1 as [_ | l' [H _] _].
+ + assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)).
+ unfold truncate, truncate_aux.
+ case Zlt_bool.
+ rewrite Zdiv_0_l, Zmod_0_l.
+ eexists.
+ apply f_equal.
+ unfold new_location.
+ now case Z.even.
+ now eexists.
+ destruct H as [e' H].
+ rewrite H.
+ split.
+ constructor.
+ apply eq_sym, F2R_0.
+ right.
+ repeat split.
+ apply generic_format_0.
+ + rewrite F2R_0 in H.
+ elim Rlt_irrefl with (1 := H).
Qed.
Theorem truncate_correct :
@@ -750,78 +841,11 @@ Theorem truncate_correct :
(e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate (m, e, l) in
inbetween_float beta m' e' x l' /\
- (e' = canonic_exp beta fexp x \/ (l' = loc_Exact /\ format x)).
+ (e' = cexp beta fexp x \/ (l' = loc_Exact /\ format x)).
Proof.
-intros x m e l [Hx|Hx] H1 H2.
-(* 0 < x *)
-destruct (Zle_or_lt e (fexp (Zdigits beta m + e))) as [H3|H3].
-(* . enough digits *)
-generalize (truncate_correct_partial x m e l Hx H1 H3).
-destruct (truncate (m, e, l)) as ((m', e'), l').
-intros (H4, H5).
-split.
-exact H4.
-now left.
-(* . not enough digits but loc_Exact *)
-destruct H2 as [H2|H2].
-elim (Zlt_irrefl e).
-now apply Zle_lt_trans with (1 := H2).
-rewrite H2 in H1 |- *.
-unfold truncate.
-generalize (Zlt_cases 0 (fexp (Zdigits beta m + e) - e)).
-case Zlt_bool.
-intros H.
-apply False_ind.
-omega.
-intros _.
-split.
-exact H1.
-right.
-split.
-apply refl_equal.
-inversion_clear H1.
-rewrite H.
-apply generic_format_F2R.
-intros Zm.
-unfold canonic_exp.
-rewrite ln_beta_F2R_Zdigits with (1 := Zm).
-now apply Zlt_le_weak.
-(* x = 0 *)
-assert (Hm: m = Z0).
-cut (m <= 0 < m + 1)%Z. omega.
-assert (Hx': (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R).
-apply inbetween_float_bounds with (1 := H1).
-rewrite <- Hx in Hx'.
-split.
-apply F2R_le_0_reg with (1 := proj1 Hx').
-apply F2R_gt_0_reg with (1 := proj2 Hx').
-rewrite Hm, <- Hx in H1 |- *.
-clear -H1.
-case H1.
-(* . *)
-intros _.
-assert (exists e', truncate (Z0, e, loc_Exact) = (Z0, e', loc_Exact)).
-unfold truncate, truncate_aux.
-case Zlt_bool.
-rewrite Zdiv_0_l, Zmod_0_l.
-eexists.
-apply f_equal.
-unfold new_location.
-now case Zeven.
-now eexists.
-destruct H as (e', H).
-rewrite H.
-split.
-constructor.
-apply sym_eq.
-apply F2R_0.
-right.
-repeat split.
-apply generic_format_0.
-(* . *)
-intros l' (H, _) _.
-rewrite F2R_0 in H.
-elim Rlt_irrefl with (1 := H).
+intros x m e l Hx H1 H2.
+apply truncate_correct' with (1 := Hx) (2 := H1).
+now apply cexp_inbetween_float_loc_Exact with (2 := H1).
Qed.
Section round_dir.
@@ -838,7 +862,7 @@ Hypothesis inbetween_int_valid :
Theorem round_any_correct :
forall x m e l,
inbetween_float beta m e x l ->
- (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) ->
+ (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
round beta fexp rnd x = F2R (Float beta (choice m l) e).
Proof with auto with typeclass_instances.
intros x m e l Hin [He|(Hl,Hf)].
@@ -851,7 +875,7 @@ rewrite Hl.
replace (choice m loc_Exact) with m.
rewrite <- H.
apply round_generic...
-rewrite <- (Zrnd_Z2R rnd m) at 1.
+rewrite <- (Zrnd_IZR rnd m) at 1.
apply inbetween_int_valid.
now constructor.
Qed.
@@ -872,6 +896,20 @@ intros (H1, H2).
now apply round_any_correct.
Qed.
+Theorem round_trunc_any_correct' :
+ forall x m e l,
+ (0 <= x)%R ->
+ inbetween_float beta m e x l ->
+ (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
+ round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (choice m' l') e').
+Proof.
+intros x m e l Hx Hl He.
+generalize (truncate_correct' x m e l Hx Hl He).
+destruct (truncate (m, e, l)) as [[m' e'] l'].
+intros [H1 H2].
+now apply round_any_correct.
+Qed.
+
End round_dir.
Section round_dir_sign.
@@ -888,7 +926,7 @@ Hypothesis inbetween_int_valid :
Theorem round_sign_any_correct :
forall x m e l,
inbetween_float beta m e (Rabs x) l ->
- (e = canonic_exp beta fexp x \/ (l = loc_Exact /\ format x)) ->
+ (e = cexp beta fexp x \/ (l = loc_Exact /\ format x)) ->
round beta fexp rnd x = F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m l)) e).
Proof with auto with typeclass_instances.
intros x m e l Hin [He|(Hl,Hf)].
@@ -915,14 +953,14 @@ now apply Rge_le.
(* *)
destruct (Rlt_bool_spec x 0) as [Zx|Zx].
(* . *)
-apply Zopp_inj.
+apply Z.opp_inj.
change (- m = cond_Zopp true (choice true m loc_Exact))%Z.
-rewrite <- (Zrnd_Z2R rnd (-m)) at 1.
-assert (Z2R (-m) < 0)%R.
-rewrite Z2R_opp.
+rewrite <- (Zrnd_IZR rnd (-m)) at 1.
+assert (IZR (-m) < 0)%R.
+rewrite opp_IZR.
apply Ropp_lt_gt_0_contravar.
-apply (Z2R_lt 0).
-apply F2R_gt_0_reg with beta e.
+apply IZR_lt.
+apply gt_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos_lt.
now apply Rlt_not_eq.
@@ -930,14 +968,14 @@ rewrite <- Rlt_bool_true with (1 := H0).
apply inbetween_int_valid.
constructor.
rewrite Rabs_left with (1 := H0).
-rewrite Z2R_opp.
+rewrite opp_IZR.
apply Ropp_involutive.
(* . *)
change (m = cond_Zopp false (choice false m loc_Exact))%Z.
-rewrite <- (Zrnd_Z2R rnd m) at 1.
-assert (0 <= Z2R m)%R.
-apply (Z2R_le 0).
-apply F2R_ge_0_reg with beta e.
+rewrite <- (Zrnd_IZR rnd m) at 1.
+assert (0 <= IZR m)%R.
+apply IZR_le.
+apply ge_0_F2R with beta e.
rewrite <- H.
apply Rabs_pos.
rewrite <- Rlt_bool_false with (1 := H0).
@@ -948,29 +986,38 @@ Qed.
(** Truncating a triple is sufficient to round a real number. *)
-Theorem round_trunc_sign_any_correct :
+Theorem round_trunc_sign_any_correct' :
forall x m e l,
inbetween_float beta m e (Rabs x) l ->
- (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
+ (e <= cexp beta fexp x)%Z \/ l = loc_Exact ->
round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
Proof.
intros x m e l Hl He.
-generalize (truncate_correct (Rabs x) m e l (Rabs_pos _) Hl He).
-destruct (truncate (m, e, l)) as ((m', e'), l').
-intros (H1, H2).
+rewrite <- cexp_abs in He.
+generalize (truncate_correct' (Rabs x) m e l (Rabs_pos _) Hl He).
+destruct (truncate (m, e, l)) as [[m' e'] l'].
+intros [H1 H2].
apply round_sign_any_correct.
exact H1.
-destruct H2 as [H2|(H2,H3)].
+destruct H2 as [H2|[H2 H3]].
left.
-now rewrite <- canonic_exp_abs.
+now rewrite <- cexp_abs.
right.
-split.
-exact H2.
-unfold Rabs in H3.
-destruct (Rcase_abs x) in H3.
-rewrite <- Ropp_involutive.
-now apply generic_format_opp.
-exact H3.
+apply (conj H2).
+now apply generic_format_abs_inv.
+Qed.
+
+Theorem round_trunc_sign_any_correct :
+ forall x m e l,
+ inbetween_float beta m e (Rabs x) l ->
+ (e <= fexp (Zdigits beta m + e))%Z \/ l = loc_Exact ->
+ round beta fexp rnd x = let '(m', e', l') := truncate (m, e, l) in F2R (Float beta (cond_Zopp (Rlt_bool x 0) (choice (Rlt_bool x 0) m' l')) e').
+Proof.
+intros x m e l Hl He.
+apply round_trunc_sign_any_correct' with (1 := Hl).
+rewrite <- cexp_abs.
+apply cexp_inbetween_float_loc_Exact with (2 := Hl) (3 := He).
+apply Rabs_pos.
Qed.
End round_dir_sign.
@@ -983,47 +1030,71 @@ Definition round_DN_correct :=
Definition round_trunc_DN_correct :=
round_trunc_any_correct _ (fun m _ => m) inbetween_int_DN.
+Definition round_trunc_DN_correct' :=
+ round_trunc_any_correct' _ (fun m _ => m) inbetween_int_DN.
+
Definition round_sign_DN_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.
Definition round_trunc_sign_DN_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.
+Definition round_trunc_sign_DN_correct' :=
+ round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_DN s l) m) inbetween_int_DN_sign.
+
Definition round_UP_correct :=
round_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.
Definition round_trunc_UP_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.
+Definition round_trunc_UP_correct' :=
+ round_trunc_any_correct' _ (fun m l => cond_incr (round_UP l) m) inbetween_int_UP.
+
Definition round_sign_UP_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.
Definition round_trunc_sign_UP_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.
+Definition round_trunc_sign_UP_correct' :=
+ round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_sign_UP s l) m) inbetween_int_UP_sign.
+
Definition round_ZR_correct :=
round_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.
Definition round_trunc_ZR_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.
+Definition round_trunc_ZR_correct' :=
+ round_trunc_any_correct' _ (fun m l => cond_incr (round_ZR (Zlt_bool m 0) l) m) inbetween_int_ZR.
+
Definition round_sign_ZR_correct :=
round_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.
Definition round_trunc_sign_ZR_correct :=
round_trunc_sign_any_correct _ (fun s m l => m) inbetween_int_ZR_sign.
+Definition round_trunc_sign_ZR_correct' :=
+ round_trunc_sign_any_correct' _ (fun s m l => m) inbetween_int_ZR_sign.
+
Definition round_NE_correct :=
- round_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE.
+ round_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.
Definition round_trunc_NE_correct :=
- round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE.
+ round_trunc_any_correct _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.
+
+Definition round_trunc_NE_correct' :=
+ round_trunc_any_correct' _ (fun m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE.
Definition round_sign_NE_correct :=
- round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign.
+ round_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.
Definition round_trunc_sign_NE_correct :=
- round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Zeven m)) l) m) inbetween_int_NE_sign.
+ round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.
+
+Definition round_trunc_sign_NE_correct' :=
+ round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N (negb (Z.even m)) l) m) inbetween_int_NE_sign.
Definition round_NA_correct :=
round_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.
@@ -1031,12 +1102,18 @@ Definition round_NA_correct :=
Definition round_trunc_NA_correct :=
round_trunc_any_correct _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.
+Definition round_trunc_NA_correct' :=
+ round_trunc_any_correct' _ (fun m l => cond_incr (round_N (Zle_bool 0 m) l) m) inbetween_int_NA.
+
Definition round_sign_NA_correct :=
round_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.
Definition round_trunc_sign_NA_correct :=
round_trunc_sign_any_correct _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.
+Definition round_trunc_sign_NA_correct' :=
+ round_trunc_sign_any_correct' _ (fun s m l => cond_incr (round_N true l) m) inbetween_int_NA_sign.
+
End Fcalc_round_fexp.
(** Specialization of truncate for FIX formats. *)
@@ -1048,7 +1125,7 @@ Definition truncate_FIX t :=
let k := (emin - e)%Z in
if Zlt_bool 0 k then
let p := Zpower beta k in
- (Zdiv m p, (e + k)%Z, new_location p (Zmod m p) l)
+ (Z.div m p, (e + k)%Z, new_location p (Zmod m p) l)
else t.
Theorem truncate_FIX_correct :
@@ -1057,13 +1134,13 @@ Theorem truncate_FIX_correct :
(e <= emin)%Z \/ l = loc_Exact ->
let '(m', e', l') := truncate_FIX (m, e, l) in
inbetween_float beta m' e' x l' /\
- (e' = canonic_exp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)).
+ (e' = cexp beta (FIX_exp emin) x \/ (l' = loc_Exact /\ generic_format beta (FIX_exp emin) x)).
Proof.
intros x m e l H1 H2.
unfold truncate_FIX.
set (k := (emin - e)%Z).
set (p := Zpower beta k).
-unfold canonic_exp, FIX_exp.
+unfold cexp, FIX_exp.
generalize (Zlt_cases 0 k).
case (Zlt_bool 0 k) ; intros Hk.
(* shift *)
@@ -1087,7 +1164,7 @@ rewrite H2 in H1.
inversion_clear H1.
rewrite H.
apply generic_format_F2R.
-unfold canonic_exp.
+unfold cexp.
omega.
Qed.
diff --git a/flocq/Calc/Sqrt.v b/flocq/Calc/Sqrt.v
new file mode 100644
index 00000000..8843d21e
--- /dev/null
+++ b/flocq/Calc/Sqrt.v
@@ -0,0 +1,201 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * Helper functions and theorems for computing the rounded square root of a floating-point number. *)
+
+Require Import Raux Defs Digits Generic_fmt Float_prop Bracket.
+
+Set Implicit Arguments.
+Set Strongly Strict Implicit.
+
+Section Fcalc_sqrt.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable fexp : Z -> Z.
+
+(** Computes a mantissa of precision p, the corresponding exponent,
+ and the position with respect to the real square root of the
+ input floating-point number.
+
+The algorithm performs the following steps:
+- Shift the mantissa so that it has at least 2p-1 digits;
+ shift it one digit more if the new exponent is not even.
+- Compute the square root s (at least p digits) of the new
+ mantissa, and its remainder r.
+- Compute the position according to the remainder:
+ -- r == 0 => Eq,
+ -- r <= s => Lo,
+ -- r >= s => Up.
+
+Complexity is fine as long as p1 <= 2p-1.
+*)
+
+Lemma mag_sqrt_F2R :
+ forall m1 e1,
+ (0 < m1)%Z ->
+ mag beta (sqrt (F2R (Float beta m1 e1))) = Z.div2 (Zdigits beta m1 + e1 + 1) :> Z.
+Proof.
+intros m1 e1 Hm1.
+rewrite <- (mag_F2R_Zdigits beta m1 e1) by now apply Zgt_not_eq.
+apply mag_sqrt.
+now apply F2R_gt_0.
+Qed.
+
+Definition Fsqrt_core m1 e1 e :=
+ let d1 := Zdigits beta m1 in
+ let m1' := (m1 * Zpower beta (e1 - 2 * e))%Z in
+ let (q, r) := Z.sqrtrem m1' in
+ let l :=
+ if Zeq_bool r 0 then loc_Exact
+ else loc_Inexact (if Zle_bool r q then Lt else Gt) in
+ (q, l).
+
+Theorem Fsqrt_core_correct :
+ forall m1 e1 e,
+ (0 < m1)%Z ->
+ (2 * e <= e1)%Z ->
+ let '(m, l) := Fsqrt_core m1 e1 e in
+ inbetween_float beta m e (sqrt (F2R (Float beta m1 e1))) l.
+Proof.
+intros m1 e1 e Hm1 He.
+unfold Fsqrt_core.
+set (m' := Zmult _ _).
+assert (0 <= m')%Z as Hm'.
+{ apply Z.mul_nonneg_nonneg.
+ now apply Zlt_le_weak.
+ apply Zpower_ge_0. }
+assert (sqrt (F2R (Float beta m1 e1)) = sqrt (IZR m') * bpow e)%R as Hf.
+{ rewrite <- (sqrt_Rsqr (bpow e)) by apply bpow_ge_0.
+ rewrite <- sqrt_mult.
+ unfold Rsqr, m'.
+ rewrite mult_IZR, IZR_Zpower by omega.
+ rewrite Rmult_assoc, <- 2!bpow_plus.
+ now replace (_ + _)%Z with e1 by ring.
+ now apply IZR_le.
+ apply Rle_0_sqr. }
+generalize (Z.sqrtrem_spec m' Hm').
+destruct Z.sqrtrem as [q r].
+intros [Hq Hr].
+rewrite Hf.
+unfold inbetween_float, F2R. simpl Fnum.
+apply inbetween_mult_compat.
+apply bpow_gt_0.
+rewrite Hq.
+case Zeq_bool_spec ; intros Hr'.
+(* .. r = 0 *)
+rewrite Hr', Zplus_0_r, mult_IZR.
+fold (Rsqr (IZR q)).
+rewrite sqrt_Rsqr.
+now constructor.
+apply IZR_le.
+clear -Hr ; omega.
+(* .. r <> 0 *)
+constructor.
+split.
+(* ... bounds *)
+apply Rle_lt_trans with (sqrt (IZR (q * q))).
+rewrite mult_IZR.
+fold (Rsqr (IZR q)).
+rewrite sqrt_Rsqr.
+apply Rle_refl.
+apply IZR_le.
+clear -Hr ; omega.
+apply sqrt_lt_1.
+rewrite mult_IZR.
+apply Rle_0_sqr.
+rewrite <- Hq.
+now apply IZR_le.
+apply IZR_lt.
+omega.
+apply Rlt_le_trans with (sqrt (IZR ((q + 1) * (q + 1)))).
+apply sqrt_lt_1.
+rewrite <- Hq.
+now apply IZR_le.
+rewrite mult_IZR.
+apply Rle_0_sqr.
+apply IZR_lt.
+ring_simplify.
+omega.
+rewrite mult_IZR.
+fold (Rsqr (IZR (q + 1))).
+rewrite sqrt_Rsqr.
+apply Rle_refl.
+apply IZR_le.
+clear -Hr ; omega.
+(* ... location *)
+rewrite Rcompare_half_r.
+generalize (Rcompare_sqr (2 * sqrt (IZR (q * q + r))) (IZR q + IZR (q + 1))).
+rewrite 2!Rabs_pos_eq.
+intros <-.
+replace ((2 * sqrt (IZR (q * q + r))) * (2 * sqrt (IZR (q * q + r))))%R
+ with (4 * Rsqr (sqrt (IZR (q * q + r))))%R by (unfold Rsqr ; ring).
+rewrite Rsqr_sqrt.
+rewrite <- plus_IZR, <- 2!mult_IZR.
+rewrite Rcompare_IZR.
+replace ((q + (q + 1)) * (q + (q + 1)))%Z with (4 * (q * q) + 4 * q + 1)%Z by ring.
+generalize (Zle_cases r q).
+case (Zle_bool r q) ; intros Hr''.
+change (4 * (q * q + r) < 4 * (q * q) + 4 * q + 1)%Z.
+omega.
+change (4 * (q * q + r) > 4 * (q * q) + 4 * q + 1)%Z.
+omega.
+rewrite <- Hq.
+now apply IZR_le.
+rewrite <- plus_IZR.
+apply IZR_le.
+clear -Hr ; omega.
+apply Rmult_le_pos.
+now apply IZR_le.
+apply sqrt_ge_0.
+Qed.
+
+Definition Fsqrt (x : float beta) :=
+ let (m1, e1) := x in
+ let e' := (Zdigits beta m1 + e1 + 1)%Z in
+ let e := Z.min (fexp (Z.div2 e')) (Z.div2 e1) in
+ let '(m, l) := Fsqrt_core m1 e1 e in
+ (m, e, l).
+
+Theorem Fsqrt_correct :
+ forall x,
+ (0 < F2R x)%R ->
+ let '(m, e, l) := Fsqrt x in
+ (e <= cexp beta fexp (sqrt (F2R x)))%Z /\
+ inbetween_float beta m e (sqrt (F2R x)) l.
+Proof.
+intros [m1 e1] Hm1.
+apply gt_0_F2R in Hm1.
+unfold Fsqrt.
+set (e := Z.min _ _).
+assert (2 * e <= e1)%Z as He.
+{ assert (e <= Z.div2 e1)%Z by apply Z.le_min_r.
+ rewrite (Zdiv2_odd_eqn e1).
+ destruct Z.odd ; omega. }
+generalize (Fsqrt_core_correct m1 e1 e Hm1 He).
+destruct Fsqrt_core as [m l].
+apply conj.
+apply Z.le_trans with (1 := Z.le_min_l _ _).
+unfold cexp.
+rewrite (mag_sqrt_F2R m1 e1 Hm1).
+apply Z.le_refl.
+Qed.
+
+End Fcalc_sqrt.
diff --git a/flocq/Core/Fcore.v b/flocq/Core/Core.v
index 2a5a5f02..78a140e1 100644
--- a/flocq/Core/Fcore.v
+++ b/flocq/Core/Core.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,13 +18,5 @@ COPYING file for more details.
*)
(** To ease the import *)
-Require Export Fcore_Raux.
-Require Export Fcore_defs.
-Require Export Fcore_float_prop.
-Require Export Fcore_rnd.
-Require Export Fcore_generic_fmt.
-Require Export Fcore_rnd_ne.
-Require Export Fcore_FIX.
-Require Export Fcore_FLX.
-Require Export Fcore_FLT.
-Require Export Fcore_ulp.
+Require Export Raux Defs Float_prop Round_pred Generic_fmt Round_NE.
+Require Export FIX FLX FLT Ulp.
diff --git a/flocq/Core/Fcore_defs.v b/flocq/Core/Defs.v
index 01b868ab..f5c6f33b 100644
--- a/flocq/Core/Fcore_defs.v
+++ b/flocq/Core/Defs.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,20 +18,20 @@ COPYING file for more details.
*)
(** * Basic definitions: float and rounding property *)
-Require Import Fcore_Raux.
+Require Import Raux.
Section Def.
(** Definition of a floating-point number *)
Record float (beta : radix) := Float { Fnum : Z ; Fexp : Z }.
-Arguments Fnum {beta} f.
-Arguments Fexp {beta} f.
+Arguments Fnum {beta}.
+Arguments Fexp {beta}.
Variable beta : radix.
Definition F2R (f : float beta) :=
- (Z2R (Fnum f) * bpow beta (Fexp f))%R.
+ (IZR (Fnum f) * bpow beta (Fexp f))%R.
(** Requirements on a rounding mode *)
Definition round_pred_total (P : R -> R -> Prop) :=
@@ -46,9 +46,9 @@ Definition round_pred (P : R -> R -> Prop) :=
End Def.
-Arguments Fnum {beta} f.
-Arguments Fexp {beta} f.
-Arguments F2R {beta} f.
+Arguments Fnum {beta}.
+Arguments Fexp {beta}.
+Arguments F2R {beta}.
Section RND.
@@ -57,45 +57,27 @@ Definition Rnd_DN_pt (F : R -> Prop) (x f : R) :=
F f /\ (f <= x)%R /\
forall g : R, F g -> (g <= x)%R -> (g <= f)%R.
-Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_DN_pt F x (rnd x).
-
(** property of being a round toward +inf *)
Definition Rnd_UP_pt (F : R -> Prop) (x f : R) :=
F f /\ (x <= f)%R /\
forall g : R, F g -> (x <= g)%R -> (f <= g)%R.
-Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_UP_pt F x (rnd x).
-
(** property of being a round toward zero *)
Definition Rnd_ZR_pt (F : R -> Prop) (x f : R) :=
( (0 <= x)%R -> Rnd_DN_pt F x f ) /\
( (x <= 0)%R -> Rnd_UP_pt F x f ).
-Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_ZR_pt F x (rnd x).
-
(** property of being a round to nearest *)
Definition Rnd_N_pt (F : R -> Prop) (x f : R) :=
F f /\
forall g : R, F g -> (Rabs (f - x) <= Rabs (g - x))%R.
-Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_N_pt F x (rnd x).
-
Definition Rnd_NG_pt (F : R -> Prop) (P : R -> R -> Prop) (x f : R) :=
Rnd_N_pt F x f /\
( P x f \/ forall f2 : R, Rnd_N_pt F x f2 -> f2 = f ).
-Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_NG_pt F P x (rnd x).
-
Definition Rnd_NA_pt (F : R -> Prop) (x f : R) :=
Rnd_N_pt F x f /\
forall f2 : R, Rnd_N_pt F x f2 -> (Rabs f2 <= Rabs f)%R.
-Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
- forall x : R, Rnd_NA_pt F x (rnd x).
-
End RND.
diff --git a/flocq/Core/Fcore_digits.v b/flocq/Core/Digits.v
index 53743035..bed2e20a 100644
--- a/flocq/Core/Fcore_digits.v
+++ b/flocq/Core/Digits.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2011-2013 Sylvie Boldo
+Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2011-2013 Guillaume Melquiond
+Copyright (C) 2011-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -17,9 +17,8 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)
-Require Import ZArith.
-Require Import Zquot.
-Require Import Fcore_Zaux.
+Require Import ZArith Zquot.
+Require Import Zaux.
(** Number of bits (radix 2) of a positive integer.
@@ -74,7 +73,7 @@ Qed.
Theorem Zdigit_opp :
forall n k,
- Zdigit (-n) k = Zopp (Zdigit n k).
+ Zdigit (-n) k = Z.opp (Zdigit n k).
Proof.
intros n k.
unfold Zdigit.
@@ -89,11 +88,11 @@ Theorem Zdigit_ge_Zpower_pos :
Proof.
intros e n Hn k Hk.
unfold Zdigit.
-rewrite Zquot_small.
+rewrite Z.quot_small.
apply Zrem_0_l.
split.
apply Hn.
-apply Zlt_le_trans with (1 := proj2 Hn).
+apply Z.lt_le_trans with (1 := proj2 Hn).
replace k with (e + (k - e))%Z by ring.
rewrite Zpower_plus.
rewrite <- (Zmult_1_r (beta ^ e)) at 1.
@@ -102,8 +101,8 @@ apply (Zlt_le_succ 0).
apply Zpower_gt_0.
now apply Zle_minus_le_0.
apply Zlt_le_weak.
-now apply Zle_lt_trans with n.
-generalize (Zle_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
+now apply Z.le_lt_trans with n.
+generalize (Z.le_lt_trans _ _ _ (proj1 Hn) (proj2 Hn)).
clear.
now destruct e as [|e|e].
now apply Zle_minus_le_0.
@@ -111,7 +110,7 @@ Qed.
Theorem Zdigit_ge_Zpower :
forall e n,
- (Zabs n < Zpower beta e)%Z ->
+ (Z.abs n < Zpower beta e)%Z ->
forall k, (e <= k)%Z -> Zdigit n k = Z0.
Proof.
intros e [|n|n] Hn k.
@@ -119,10 +118,10 @@ easy.
apply Zdigit_ge_Zpower_pos.
now split.
intros He.
-change (Zneg n) with (Zopp (Zpos n)).
+change (Zneg n) with (Z.opp (Zpos n)).
rewrite Zdigit_opp.
rewrite Zdigit_ge_Zpower_pos with (2 := He).
-apply Zopp_0.
+apply Z.opp_0.
now split.
Qed.
@@ -134,17 +133,17 @@ Proof.
intros e n He (Hn1,Hn2).
unfold Zdigit.
rewrite <- ZOdiv_mod_mult.
-rewrite Zrem_small.
+rewrite Z.rem_small.
intros H.
apply Zle_not_lt with (1 := Hn1).
rewrite (Z.quot_rem' n (beta ^ e)).
rewrite H, Zmult_0_r, Zplus_0_l.
apply Zrem_lt_pos_pos.
-apply Zle_trans with (2 := Hn1).
+apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
now apply Zpower_gt_0.
split.
-apply Zle_trans with (2 := Hn1).
+apply Z.le_trans with (2 := Hn1).
apply Zpower_ge_0.
replace (beta ^ e * beta)%Z with (beta ^ (e + 1))%Z.
exact Hn2.
@@ -154,12 +153,12 @@ Qed.
Theorem Zdigit_not_0 :
forall e n, (0 <= e)%Z ->
- (Zpower beta e <= Zabs n < Zpower beta (e + 1))%Z ->
+ (Zpower beta e <= Z.abs n < Zpower beta (e + 1))%Z ->
Zdigit n e <> Z0.
Proof.
intros e n He Hn.
destruct (Zle_or_lt 0 n) as [Hn'|Hn'].
-rewrite (Zabs_eq _ Hn') in Hn.
+rewrite (Z.abs_eq _ Hn') in Hn.
now apply Zdigit_not_0_pos.
intros H.
rewrite (Zabs_non_eq n) in Hn by now apply Zlt_le_weak.
@@ -245,8 +244,8 @@ intros n k k' Hk.
unfold Zdigit.
rewrite ZOdiv_small_abs.
apply Zrem_0_l.
-apply Zlt_le_trans with (Zpower beta k').
-rewrite <- (Zabs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
+apply Z.lt_le_trans with (Zpower beta k').
+rewrite <- (Z.abs_eq (beta ^ k')) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
@@ -266,7 +265,7 @@ Proof.
intros n.
induction k.
apply sym_eq.
-apply Zrem_1_r.
+apply Z.rem_1_r.
simpl Zsum_digit.
rewrite IHk.
unfold Zdigit.
@@ -284,65 +283,35 @@ apply Zle_0_nat.
easy.
Qed.
-Theorem Zpower_gt_id :
- forall n, (n < Zpower beta n)%Z.
-Proof.
-intros [|n|n] ; try easy.
-simpl.
-rewrite Zpower_pos_nat.
-rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
-induction (nat_of_P n).
-easy.
-rewrite inj_S.
-change (Zpower_nat beta (S n0)) with (beta * Zpower_nat beta n0)%Z.
-unfold Zsucc.
-apply Zlt_le_trans with (beta * (Z_of_nat n0 + 1))%Z.
-clear.
-apply Zlt_0_minus_lt.
-replace (beta * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((beta - 1) * (Z_of_nat n0 + 1))%Z by ring.
-apply Zmult_lt_0_compat.
-cut (2 <= beta)%Z. omega.
-apply Zle_bool_imp_le.
-apply beta.
-apply (Zle_lt_succ 0).
-apply Zle_0_nat.
-apply Zmult_le_compat_l.
-now apply Zlt_le_succ.
-apply Zle_trans with 2%Z.
-easy.
-apply Zle_bool_imp_le.
-apply beta.
-Qed.
-
Theorem Zdigit_ext :
forall n1 n2,
(forall k, (0 <= k)%Z -> Zdigit n1 k = Zdigit n2 k) ->
n1 = n2.
Proof.
intros n1 n2 H.
-rewrite <- (ZOmod_small_abs n1 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))).
-rewrite <- (ZOmod_small_abs n2 (Zpower beta (Zmax (Zabs n1) (Zabs n2)))) at 2.
-replace (Zmax (Zabs n1) (Zabs n2)) with (Z_of_nat (Zabs_nat (Zmax (Zabs n1) (Zabs n2)))).
+rewrite <- (ZOmod_small_abs n1 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))).
+rewrite <- (ZOmod_small_abs n2 (Zpower beta (Z.max (Z.abs n1) (Z.abs n2)))) at 2.
+replace (Z.max (Z.abs n1) (Z.abs n2)) with (Z_of_nat (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2)))).
rewrite <- 2!Zsum_digit_digit.
-induction (Zabs_nat (Zmax (Zabs n1) (Zabs n2))).
+induction (Z.abs_nat (Z.max (Z.abs n1) (Z.abs n2))).
easy.
simpl.
rewrite H, IHn.
apply refl_equal.
apply Zle_0_nat.
rewrite inj_Zabs_nat.
-apply Zabs_eq.
-apply Zle_trans with (Zabs n1).
+apply Z.abs_eq.
+apply Z.le_trans with (Z.abs n1).
apply Zabs_pos.
-apply Zle_max_l.
-apply Zlt_le_trans with (Zpower beta (Zabs n2)).
+apply Z.le_max_l.
+apply Z.lt_le_trans with (Zpower beta (Z.abs n2)).
apply Zpower_gt_id.
apply Zpower_le.
-apply Zle_max_r.
-apply Zlt_le_trans with (Zpower beta (Zabs n1)).
+apply Z.le_max_r.
+apply Z.lt_le_trans with (Zpower beta (Z.abs n1)).
apply Zpower_gt_id.
apply Zpower_le.
-apply Zle_max_l.
+apply Z.le_max_l.
Qed.
Theorem ZOmod_plus_pow_digit :
@@ -354,11 +323,11 @@ intros u v n Huv Hd.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
rewrite Zplus_rem with (1 := Huv).
apply ZOmod_small_abs.
-generalize (Zle_refl n).
-pattern n at -2 ; rewrite <- Zabs_eq with (1 := Hn).
+generalize (Z.le_refl n).
+pattern n at -2 ; rewrite <- Z.abs_eq with (1 := Hn).
rewrite <- (inj_Zabs_nat n).
-induction (Zabs_nat n) as [|p IHp].
-now rewrite 2!Zrem_1_r.
+induction (Z.abs_nat n) as [|p IHp].
+now rewrite 2!Z.rem_1_r.
rewrite <- 2!Zsum_digit_digit.
simpl Zsum_digit.
rewrite inj_S.
@@ -367,39 +336,39 @@ replace (Zsum_digit (Zdigit u) p + Zdigit u (Z_of_nat p) * beta ^ Z_of_nat p +
(Zsum_digit (Zdigit v) p + Zdigit v (Z_of_nat p) * beta ^ Z_of_nat p))%Z with
(Zsum_digit (Zdigit u) p + Zsum_digit (Zdigit v) p +
(Zdigit u (Z_of_nat p) + Zdigit v (Z_of_nat p)) * beta ^ Z_of_nat p)%Z by ring.
-apply (Zle_lt_trans _ _ _ (Zabs_triangle _ _)).
-replace (beta ^ Zsucc (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
+apply (Z.le_lt_trans _ _ _ (Z.abs_triangle _ _)).
+replace (beta ^ Z.succ (Z_of_nat p))%Z with (beta ^ Z_of_nat p + (beta - 1) * beta ^ Z_of_nat p)%Z.
apply Zplus_lt_le_compat.
rewrite 2!Zsum_digit_digit.
apply IHp.
now apply Zle_succ_le.
rewrite Zabs_Zmult.
-rewrite (Zabs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
+rewrite (Z.abs_eq (beta ^ Z_of_nat p)) by apply Zpower_ge_0.
apply Zmult_le_compat_r. 2: apply Zpower_ge_0.
apply Zlt_succ_le.
-assert (forall u v, Zabs (Zdigit u v) < Zsucc (beta - 1))%Z.
+assert (forall u v, Z.abs (Zdigit u v) < Z.succ (beta - 1))%Z.
clear ; intros n k.
assert (0 < beta)%Z.
-apply Zlt_le_trans with 2%Z.
+apply Z.lt_le_trans with 2%Z.
apply refl_equal.
apply Zle_bool_imp_le.
apply beta.
-replace (Zsucc (beta - 1)) with (Zabs beta).
+replace (Z.succ (beta - 1)) with (Z.abs beta).
apply Zrem_lt.
now apply Zgt_not_eq.
-rewrite Zabs_eq.
+rewrite Z.abs_eq.
apply Zsucc_pred.
now apply Zlt_le_weak.
assert (0 <= Z_of_nat p < n)%Z.
split.
apply Zle_0_nat.
-apply Zgt_lt.
+apply Z.gt_lt.
now apply Zle_succ_gt.
destruct (Hd (Z_of_nat p) H0) as [K|K] ; rewrite K.
apply H.
rewrite Zplus_0_r.
apply H.
-unfold Zsucc.
+unfold Z.succ.
ring_simplify.
rewrite Zpower_plus.
change (beta ^1)%Z with (beta * 1)%Z.
@@ -422,7 +391,7 @@ rewrite <- ZOmod_plus_pow_digit by assumption.
apply f_equal.
destruct (Zle_or_lt 0 n) as [Hn|Hn].
apply ZOdiv_small_abs.
-rewrite <- Zabs_eq.
+rewrite <- Z.abs_eq.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
@@ -562,7 +531,7 @@ rewrite Zle_bool_true.
rewrite Zdigit_mod_pow by apply Hk.
rewrite Zdigit_scale by apply Hk.
unfold Zminus.
-now rewrite Zopp_involutive, Zplus_comm.
+now rewrite Z.opp_involutive, Zplus_comm.
omega.
Qed.
@@ -608,13 +577,13 @@ Qed.
Theorem Zslice_slice :
forall n k1 k2 k1' k2', (0 <= k1' <= k2)%Z ->
- Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Zmin (k2 - k1') k2').
+ Zslice (Zslice n k1 k2) k1' k2' = Zslice n (k1 + k1') (Z.min (k2 - k1') k2').
Proof.
intros n k1 k2 k1' k2' Hk1'.
destruct (Zle_or_lt 0 k2') as [Hk2'|Hk2'].
apply Zdigit_ext.
intros k Hk.
-destruct (Zle_or_lt (Zmin (k2 - k1') k2') k) as [Hk'|Hk'].
+destruct (Zle_or_lt (Z.min (k2 - k1') k2') k) as [Hk'|Hk'].
rewrite (Zdigit_slice_out n (k1 + k1')) with (1 := Hk').
destruct (Zle_or_lt k2' k) as [Hk''|Hk''].
now apply Zdigit_slice_out.
@@ -627,7 +596,7 @@ rewrite Zdigit_slice.
now rewrite Zplus_assoc.
zify ; omega.
unfold Zslice.
-rewrite Zmin_r.
+rewrite Z.min_r.
now rewrite Zle_bool_false.
omega.
Qed.
@@ -659,11 +628,11 @@ replace k1 with Z0 by omega.
case Zle_bool_spec ; intros Hk'.
replace k with Z0 by omega.
simpl.
-now rewrite Zquot_1_r.
-rewrite Zopp_involutive.
+now rewrite Z.quot_1_r.
+rewrite Z.opp_involutive.
apply Zmult_1_r.
rewrite Zle_bool_false by omega.
-rewrite 2!Zopp_involutive, Zplus_comm.
+rewrite 2!Z.opp_involutive, Zplus_comm.
rewrite Zpower_plus by assumption.
apply Zquot_Zquot.
Qed.
@@ -689,7 +658,7 @@ apply Zdigit_ext.
intros k' Hk'.
rewrite Zdigit_scale with (1 := Hk').
unfold Zminus.
-rewrite (Zplus_comm k'), Zopp_involutive.
+rewrite (Zplus_comm k'), Z.opp_involutive.
destruct (Zle_or_lt k2 k') as [Hk2|Hk2].
rewrite Zdigit_slice_out with (1 := Hk2).
apply sym_eq.
@@ -770,7 +739,7 @@ Definition Zdigits n :=
Theorem Zdigits_correct :
forall n,
- (Zpower beta (Zdigits n - 1) <= Zabs n < Zpower beta (Zdigits n))%Z.
+ (Zpower beta (Zdigits n - 1) <= Z.abs n < Zpower beta (Zdigits n))%Z.
Proof.
cut (forall p, Zpower beta (Zdigits (Zpos p) - 1) <= Zpos p < Zpower beta (Zdigits (Zpos p)))%Z.
intros H [|n|n] ; try exact (H n).
@@ -779,7 +748,7 @@ intros n.
simpl.
(* *)
assert (U: (Zpos n < Zpower beta (Z_of_nat (S (digits2_Pnat n))))%Z).
-apply Zlt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
+apply Z.lt_le_trans with (1 := proj2 (digits2_Pnat_correct n)).
rewrite Zpower_Zpower_nat.
rewrite Zabs_nat_Z_of_nat.
induction (S (digits2_Pnat n)).
@@ -797,7 +766,7 @@ apply Zle_0_nat.
(* *)
revert U.
rewrite inj_S.
-unfold Zsucc.
+unfold Z.succ.
generalize (digits2_Pnat n).
intros u U.
pattern (radix_val beta) at 2 4 ; replace (radix_val beta) with (Zpower beta 1) by apply Zmult_1_r.
@@ -805,12 +774,12 @@ assert (V: (Zpower beta (1 - 1) <= Zpos n)%Z).
now apply (Zlt_le_succ 0).
generalize (conj V U).
clear.
-generalize (Zle_refl 1).
+generalize (Z.le_refl 1).
generalize 1%Z at 2 3 5 6 7 9 10.
(* *)
induction u.
easy.
-rewrite inj_S; unfold Zsucc.
+rewrite inj_S; unfold Z.succ.
simpl Zdigits_aux.
intros v Hv U.
case Zlt_bool_spec ; intros K.
@@ -829,20 +798,20 @@ Qed.
Theorem Zdigits_unique :
forall n d,
- (Zpower beta (d - 1) <= Zabs n < Zpower beta d)%Z ->
+ (Zpower beta (d - 1) <= Z.abs n < Zpower beta d)%Z ->
Zdigits n = d.
Proof.
intros n d Hd.
assert (Hd' := Zdigits_correct n).
apply Zle_antisym.
apply (Zpower_lt_Zpower beta).
-now apply Zle_lt_trans with (Zabs n).
+now apply Z.le_lt_trans with (Z.abs n).
apply (Zpower_lt_Zpower beta).
-now apply Zle_lt_trans with (Zabs n).
+now apply Z.le_lt_trans with (Z.abs n).
Qed.
Theorem Zdigits_abs :
- forall n, Zdigits (Zabs n) = Zdigits n.
+ forall n, Zdigits (Z.abs n) = Zdigits n.
Proof.
now intros [|n|n].
Qed.
@@ -852,10 +821,10 @@ Theorem Zdigits_gt_0 :
Proof.
intros n Zn.
rewrite <- (Zdigits_abs n).
-assert (Hn: (0 < Zabs n)%Z).
+assert (Hn: (0 < Z.abs n)%Z).
destruct n ; [|easy|easy].
now elim Zn.
-destruct (Zabs n) as [|p|p] ; try easy ; clear.
+destruct (Z.abs n) as [|p|p] ; try easy ; clear.
simpl.
generalize 1%Z (radix_val beta) (refl_equal Lt : (0 < 1)%Z).
induction (digits2_Pnat p).
@@ -872,7 +841,7 @@ Theorem Zdigits_ge_0 :
forall n, (0 <= Zdigits n)%Z.
Proof.
intros n.
-destruct (Z_eq_dec n 0) as [H|H].
+destruct (Z.eq_dec n 0) as [H|H].
now rewrite H.
apply Zlt_le_weak.
now apply Zdigits_gt_0.
@@ -908,8 +877,8 @@ unfold Zslice.
rewrite Zle_bool_true with (1 := Hl).
destruct (Zdigits_correct (Z.rem (Zscale n (- k)) (Zpower beta l))) as (H1,H2).
apply Zpower_lt_Zpower with beta.
-apply Zle_lt_trans with (1 := H1).
-rewrite <- (Zabs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
+apply Z.le_lt_trans with (1 := H1).
+rewrite <- (Z.abs_eq (beta ^ l)) at 2 by apply Zpower_ge_0.
apply Zrem_lt.
apply Zgt_not_eq.
now apply Zpower_gt_0.
@@ -923,7 +892,7 @@ Proof.
intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
-rewrite Z.abs_mul, Z.abs_pow, (Zabs_eq beta).
+rewrite Z.abs_mul, Z.abs_pow, (Z.abs_eq beta).
2: now apply Zlt_le_weak, radix_gt_0.
split.
replace (Zdigits m + e - 1)%Z with (Zdigits m - 1 + e)%Z by ring.
@@ -976,18 +945,18 @@ Qed.
Theorem Zpower_le_Zdigits :
forall e x,
(e < Zdigits x)%Z ->
- (Zpower beta e <= Zabs x)%Z.
+ (Zpower beta e <= Z.abs x)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
-apply Zle_trans with (2 := H1).
+apply Z.le_trans with (2 := H1).
apply Zpower_le.
clear -Hex ; omega.
Qed.
Theorem Zdigits_le_Zpower :
forall e x,
- (Zabs x < Zpower beta e)%Z ->
+ (Z.abs x < Zpower beta e)%Z ->
(Zdigits x <= e)%Z.
Proof.
intros e x.
@@ -998,17 +967,17 @@ Qed.
Theorem Zpower_gt_Zdigits :
forall e x,
(Zdigits x <= e)%Z ->
- (Zabs x < Zpower beta e)%Z.
+ (Z.abs x < Zpower beta e)%Z.
Proof.
intros e x Hex.
destruct (Zdigits_correct x) as [H1 H2].
-apply Zlt_le_trans with (1 := H2).
+apply Z.lt_le_trans with (1 := H2).
now apply Zpower_le.
Qed.
Theorem Zdigits_gt_Zpower :
forall e x,
- (Zpower beta e <= Zabs x)%Z ->
+ (Zpower beta e <= Z.abs x)%Z ->
(e < Zdigits x)%Z.
Proof.
intros e x Hex.
@@ -1029,17 +998,17 @@ Theorem Zdigits_mult_strong :
Proof.
intros x y Hx Hy.
apply Zdigits_le_Zpower.
-rewrite Zabs_eq.
-apply Zlt_le_trans with ((x + 1) * (y + 1))%Z.
+rewrite Z.abs_eq.
+apply Z.lt_le_trans with ((x + 1) * (y + 1))%Z.
ring_simplify.
-apply Zle_lt_succ, Zle_refl.
+apply Zle_lt_succ, Z.le_refl.
rewrite Zpower_plus by apply Zdigits_ge_0.
apply Zmult_le_compat.
apply Zlt_le_succ.
-rewrite <- (Zabs_eq x) at 1 by easy.
+rewrite <- (Z.abs_eq x) at 1 by easy.
apply Zdigits_correct.
apply Zlt_le_succ.
-rewrite <- (Zabs_eq y) at 1 by easy.
+rewrite <- (Z.abs_eq y) at 1 by easy.
apply Zdigits_correct.
clear -Hx ; omega.
clear -Hy ; omega.
@@ -1057,7 +1026,7 @@ intros x y.
rewrite <- Zdigits_abs.
rewrite <- (Zdigits_abs x).
rewrite <- (Zdigits_abs y).
-apply Zle_trans with (Zdigits (Zabs x + Zabs y + Zabs x * Zabs y)).
+apply Z.le_trans with (Zdigits (Z.abs x + Z.abs y + Z.abs x * Z.abs y)).
apply Zdigits_le.
apply Zabs_pos.
rewrite Zabs_Zmult.
@@ -1097,28 +1066,28 @@ intros m e Hm He.
assert (H := Zdigits_correct m).
apply Zdigits_unique.
destruct (Zle_lt_or_eq _ _ (proj2 He)) as [He'|He'].
- rewrite Zabs_eq in H by easy.
+ rewrite Z.abs_eq in H by easy.
destruct H as [H1 H2].
- rewrite Zabs_eq.
+ rewrite Z.abs_eq.
split.
replace (Zdigits m - e - 1)%Z with (Zdigits m - 1 - e)%Z by ring.
rewrite Z.pow_sub_r.
2: apply Zgt_not_eq, radix_gt_0.
2: clear -He He' ; omega.
apply Z_div_le with (2 := H1).
- now apply Zlt_gt, Zpower_gt_0.
+ now apply Z.lt_gt, Zpower_gt_0.
apply Zmult_lt_reg_r with (Zpower beta e).
now apply Zpower_gt_0.
- apply Zle_lt_trans with m.
+ apply Z.le_lt_trans with m.
rewrite Zmult_comm.
apply Z_mult_div_ge.
- now apply Zlt_gt, Zpower_gt_0.
+ now apply Z.lt_gt, Zpower_gt_0.
rewrite <- Zpower_plus.
now replace (Zdigits m - e + e)%Z with (Zdigits m) by ring.
now apply Zle_minus_le_0.
apply He.
apply Z_div_pos with (2 := Hm).
- now apply Zlt_gt, Zpower_gt_0.
+ now apply Z.lt_gt, Zpower_gt_0.
rewrite He'.
rewrite (Zeq_minus _ (Zdigits m)) by reflexivity.
simpl.
@@ -1126,7 +1095,7 @@ rewrite Zdiv_small.
easy.
split.
exact Hm.
-now rewrite <- (Zabs_eq m) at 1.
+now rewrite <- (Z.abs_eq m) at 1.
Qed.
End Fcore_digits.
@@ -1143,7 +1112,7 @@ intros m.
apply eq_sym, Zdigits_unique.
rewrite <- Zpower_nat_Z.
rewrite Nat2Z.inj_succ.
-change (_ - 1)%Z with (Zpred (Zsucc (Z.of_nat (digits2_Pnat m)))).
+change (_ - 1)%Z with (Z.pred (Z.succ (Z.of_nat (digits2_Pnat m)))).
rewrite <- Zpred_succ.
rewrite <- Zpower_nat_Z.
apply digits2_Pnat_correct.
@@ -1152,8 +1121,8 @@ Qed.
Fixpoint digits2_pos (n : positive) : positive :=
match n with
| xH => xH
- | xO p => Psucc (digits2_pos p)
- | xI p => Psucc (digits2_pos p)
+ | xO p => Pos.succ (digits2_pos p)
+ | xI p => Pos.succ (digits2_pos p)
end.
Theorem Zpos_digits2_pos :
diff --git a/flocq/Core/Fcore_FIX.v b/flocq/Core/FIX.v
index e224a64a..4e0a25e6 100644
--- a/flocq/Core/Fcore_FIX.v
+++ b/flocq/Core/FIX.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,12 +18,7 @@ COPYING file for more details.
*)
(** * Fixed-point format *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_ulp.
-Require Import Fcore_rnd_ne.
+Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE.
Section RND_FIX.
@@ -33,10 +28,9 @@ Notation bpow := (bpow beta).
Variable emin : Z.
-(* fixed-point format with exponent emin *)
-Definition FIX_format (x : R) :=
- exists f : float beta,
- x = F2R f /\ (Fexp f = emin)%Z.
+Inductive FIX_format (x : R) : Prop :=
+ FIX_spec (f : float beta) :
+ x = F2R f -> (Fexp f = emin)%Z -> FIX_format x.
Definition FIX_exp (e : Z) := emin.
@@ -49,16 +43,16 @@ unfold FIX_exp.
split ; intros H.
now apply Zlt_le_weak.
split.
-apply Zle_refl.
+apply Z.le_refl.
now intros _ _.
Qed.
Theorem generic_format_FIX :
forall x, FIX_format x -> generic_format beta FIX_exp x.
Proof.
-intros x ((xm, xe), (Hx1, Hx2)).
+intros x [[xm xe] Hx1 Hx2].
rewrite Hx1.
-now apply generic_format_canonic.
+now apply generic_format_canonical.
Qed.
Theorem FIX_format_generic :
@@ -82,10 +76,11 @@ Qed.
Global Instance FIX_exp_monotone : Monotone_exp FIX_exp.
Proof.
intros ex ey H.
-apply Zle_refl.
+apply Z.le_refl.
Qed.
-Theorem ulp_FIX: forall x, ulp beta FIX_exp x = bpow emin.
+Theorem ulp_FIX :
+ forall x, ulp beta FIX_exp x = bpow emin.
Proof.
intros x; unfold ulp.
case Req_bool_spec; intros Zx.
@@ -96,5 +91,4 @@ intros n _; reflexivity.
reflexivity.
Qed.
-
End RND_FIX.
diff --git a/flocq/Core/Fcore_FLT.v b/flocq/Core/FLT.v
index 2258b1d9..bd48d4b7 100644
--- a/flocq/Core/Fcore_FLT.v
+++ b/flocq/Core/FLT.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,15 +18,9 @@ COPYING file for more details.
*)
(** * Floating-point format with gradual underflow *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_float_prop.
-Require Import Fcore_FLX.
-Require Import Fcore_FIX.
-Require Import Fcore_ulp.
-Require Import Fcore_rnd_ne.
+Require Import Raux Defs Round_pred Generic_fmt Float_prop.
+Require Import FLX FIX Ulp Round_NE.
+Require Import Psatz.
Section RND_FLT.
@@ -38,12 +32,12 @@ Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
-(* floating-point format with gradual underflow *)
-Definition FLT_format (x : R) :=
- exists f : float beta,
- x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z /\ (emin <= Fexp f)%Z.
+Inductive FLT_format (x : R) : Prop :=
+ FLT_spec (f : float beta) :
+ x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z ->
+ (emin <= Fexp f)%Z -> FLT_format x.
-Definition FLT_exp e := Zmax (e - prec) emin.
+Definition FLT_exp e := Z.max (e - prec) emin.
(** Properties of the FLT format *)
Global Instance FLT_exp_valid : Valid_exp FLT_exp.
@@ -59,17 +53,17 @@ Theorem generic_format_FLT :
forall x, FLT_format x -> generic_format beta FLT_exp x.
Proof.
clear prec_gt_0_.
-intros x ((mx, ex), (H1, (H2, H3))).
+intros x [[mx ex] H1 H2 H3].
simpl in H2, H3.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
-unfold canonic_exp, FLT_exp.
-rewrite ln_beta_F2R with (1 := Zmx).
-apply Zmax_lub with (2 := H3).
+unfold cexp, FLT_exp.
+rewrite mag_F2R with (1 := Zmx).
+apply Z.max_lub with (2 := H3).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
-now apply ln_beta_le_Zpower.
+now apply mag_le_Zpower.
Qed.
Theorem FLT_format_generic :
@@ -77,32 +71,32 @@ Theorem FLT_format_generic :
Proof.
intros x.
unfold generic_format.
-set (ex := canonic_exp beta FLT_exp x).
+set (ex := cexp beta FLT_exp x).
set (mx := Ztrunc (scaled_mantissa beta FLT_exp x)).
intros Hx.
rewrite Hx.
eexists ; repeat split ; simpl.
-apply lt_Z2R.
-rewrite Z2R_Zpower. 2: now apply Zlt_le_weak.
+apply lt_IZR.
+rewrite IZR_Zpower. 2: now apply Zlt_le_weak.
apply Rmult_lt_reg_r with (bpow ex).
apply bpow_gt_0.
rewrite <- bpow_plus.
-change (F2R (Float beta (Zabs mx) ex) < bpow (prec + ex))%R.
+change (F2R (Float beta (Z.abs mx) ex) < bpow (prec + ex))%R.
rewrite F2R_Zabs.
rewrite <- Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0, Rabs_R0.
apply bpow_gt_0.
-unfold canonic_exp in ex.
-destruct (ln_beta beta x) as (ex', He).
+unfold cexp in ex.
+destruct (mag beta x) as (ex', He).
simpl in ex.
specialize (He Hx0).
apply Rlt_le_trans with (1 := proj2 He).
apply bpow_le.
cut (ex' - prec <= ex)%Z. omega.
unfold ex, FLT_exp.
-apply Zle_max_l.
-apply Zle_max_r.
+apply Z.le_max_l.
+apply Z.le_max_r.
Qed.
@@ -128,18 +122,18 @@ apply FLT_format_generic.
apply generic_format_FLT.
Qed.
-Theorem canonic_exp_FLT_FLX :
+Theorem cexp_FLT_FLX :
forall x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
- canonic_exp beta FLT_exp x = canonic_exp beta (FLX_exp prec) x.
+ cexp beta FLT_exp x = cexp beta (FLX_exp prec) x.
Proof.
intros x Hx.
assert (Hx0: x <> 0%R).
intros H1; rewrite H1, Rabs_R0 in Hx.
contradict Hx; apply Rlt_not_le, bpow_gt_0.
-unfold canonic_exp.
+unfold cexp.
apply Zmax_left.
-destruct (ln_beta beta x) as (ex, He).
+destruct (mag beta x) as (ex, He).
unfold FLX_exp. simpl.
specialize (He Hx0).
cut (emin + prec - 1 < ex)%Z. omega.
@@ -160,7 +154,7 @@ destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
-now rewrite canonic_exp_FLT_FLX.
+now rewrite cexp_FLT_FLX.
Qed.
Theorem generic_format_FLX_FLT :
@@ -173,29 +167,30 @@ unfold generic_format in Hx; rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
-unfold canonic_exp, FLX_exp, FLT_exp.
-apply Zle_max_l.
+unfold cexp, FLX_exp, FLT_exp.
+apply Z.le_max_l.
Qed.
Theorem round_FLT_FLX : forall rnd x,
(bpow (emin + prec - 1) <= Rabs x)%R ->
round beta FLT_exp rnd x = round beta (FLX_exp prec) rnd x.
+Proof.
intros rnd x Hx.
unfold round, scaled_mantissa.
-rewrite canonic_exp_FLT_FLX ; trivial.
+rewrite cexp_FLT_FLX ; trivial.
Qed.
(** Links between FLT and FIX (underflow) *)
-Theorem canonic_exp_FLT_FIX :
+Theorem cexp_FLT_FIX :
forall x, x <> 0%R ->
(Rabs x < bpow (emin + prec))%R ->
- canonic_exp beta FLT_exp x = canonic_exp beta (FIX_exp emin) x.
+ cexp beta FLT_exp x = cexp beta (FIX_exp emin) x.
Proof.
intros x Hx0 Hx.
-unfold canonic_exp.
+unfold cexp.
apply Zmax_right.
unfold FIX_exp.
-destruct (ln_beta beta x) as (ex, Hex).
+destruct (mag beta x) as (ex, Hex).
simpl.
cut (ex - 1 < emin + prec)%Z. omega.
apply (lt_bpow beta).
@@ -214,7 +209,7 @@ rewrite Hx.
apply generic_format_F2R.
intros _.
rewrite <- Hx.
-apply Zle_max_r.
+apply Z.le_max_r.
Qed.
Theorem generic_format_FLT_FIX :
@@ -226,9 +221,37 @@ Proof with auto with typeclass_instances.
apply generic_inclusion_le...
intros e He.
unfold FIX_exp.
-apply Zmax_lub.
+apply Z.max_lub.
omega.
-apply Zle_refl.
+apply Z.le_refl.
+Qed.
+
+Lemma negligible_exp_FLT :
+ exists n, negligible_exp FLT_exp = Some n /\ (n <= emin)%Z.
+Proof.
+case (negligible_exp_spec FLT_exp).
+{ intro H; exfalso; specialize (H emin); revert H.
+ apply Zle_not_lt, Z.le_max_r. }
+intros n Hn; exists n; split; [now simpl|].
+destruct (Z.max_spec (n - prec) emin) as [(Hm, Hm')|(Hm, Hm')].
+{ now revert Hn; unfold FLT_exp; rewrite Hm'. }
+revert Hn prec_gt_0_; unfold FLT_exp, Prec_gt_0; rewrite Hm'; lia.
+Qed.
+
+Theorem generic_format_FLT_1 (Hemin : (emin <= 0)%Z) :
+ generic_format beta FLT_exp 1.
+Proof.
+unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
+rewrite Rmult_1_l, (mag_unique beta 1 1).
+{ unfold FLT_exp.
+ destruct (Z.max_spec_le (1 - prec) emin) as [(H,Hm)|(H,Hm)]; rewrite Hm;
+ (rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega]);
+ (rewrite Ztrunc_IZR, IZR_Zpower, <-bpow_plus;
+ [|unfold Prec_gt_0 in prec_gt_0_; omega]);
+ now replace (_ + _)%Z with Z0 by ring. }
+rewrite Rabs_R1; simpl; split; [now right|].
+rewrite IZR_Zpower_pos; simpl; rewrite Rmult_1_r; apply IZR_lt.
+apply (Z.lt_le_trans _ 2); [omega|]; apply Zle_bool_imp_le, beta.
Qed.
Theorem ulp_FLT_small: forall x, (Rabs x < bpow (emin+prec))%R ->
@@ -240,7 +263,7 @@ unfold ulp; case Req_bool_spec; intros Hx2.
case (negligible_exp_spec FLT_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
apply Zle_not_lt; unfold FLT_exp.
-apply Zle_trans with (2:=Z.le_max_r _ _); omega.
+apply Z.le_trans with (2:=Z.le_max_r _ _); omega.
assert (V:FLT_exp emin = emin).
unfold FLT_exp; apply Z.max_r.
unfold Prec_gt_0 in prec_gt_0_; omega.
@@ -248,10 +271,10 @@ intros n H2; rewrite <-V.
apply f_equal, fexp_negligible_exp_eq...
omega.
(* x <> 0 *)
-apply f_equal; unfold canonic_exp, FLT_exp.
+apply f_equal; unfold cexp, FLT_exp.
apply Z.max_r.
-assert (ln_beta beta x-1 < emin+prec)%Z;[idtac|omega].
-destruct (ln_beta beta x) as (e,He); simpl.
+assert (mag beta x-1 < emin+prec)%Z;[idtac|omega].
+destruct (mag beta x) as (e,He); simpl.
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=Hx).
now apply He.
@@ -266,8 +289,8 @@ assert (Zx : (x <> 0)%R).
intros Z; contradict Hx; apply Rgt_not_le, Rlt_gt.
rewrite Z, Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0 with (1 := Zx).
-unfold canonic_exp, FLT_exp.
-destruct (ln_beta beta x) as (e,He).
+unfold cexp, FLT_exp.
+destruct (mag beta x) as (e,He).
apply Rle_trans with (bpow (e-1)*bpow (1-prec))%R.
rewrite <- bpow_plus.
right; apply f_equal.
@@ -289,17 +312,68 @@ intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLT_small, Rabs_R0, Rmult_0_l; try apply bpow_gt_0.
rewrite Rabs_R0; apply bpow_gt_0.
rewrite ulp_neq_0; try exact Hx.
-unfold canonic_exp, FLT_exp.
-apply Rlt_le_trans with (bpow (ln_beta beta x)*bpow (-prec))%R.
+unfold cexp, FLT_exp.
+apply Rlt_le_trans with (bpow (mag beta x)*bpow (-prec))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
-now apply bpow_ln_beta_gt.
+now apply bpow_mag_gt.
rewrite <- bpow_plus.
apply bpow_le.
apply Z.le_max_l.
Qed.
+Lemma ulp_FLT_exact_shift :
+ forall x e,
+ (x <> 0)%R ->
+ (emin + prec <= mag beta x)%Z ->
+ (emin + prec - mag beta x <= e)%Z ->
+ (ulp beta FLT_exp (x * bpow e) = ulp beta FLT_exp x * bpow e)%R.
+Proof.
+intros x e Nzx Hmx He.
+unfold ulp; rewrite Req_bool_false;
+ [|now intro H; apply Nzx, (Rmult_eq_reg_r (bpow e));
+ [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
+rewrite (Req_bool_false _ _ Nzx), <- bpow_plus; f_equal; unfold cexp, FLT_exp.
+rewrite (mag_mult_bpow _ _ _ Nzx), !Z.max_l; omega.
+Qed.
+
+Lemma succ_FLT_exact_shift_pos :
+ forall x e,
+ (0 < x)%R ->
+ (emin + prec <= mag beta x)%Z ->
+ (emin + prec - mag beta x <= e)%Z ->
+ (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
+Proof.
+intros x e Px Hmx He.
+rewrite succ_eq_pos; [|now apply Rlt_le, Rmult_lt_0_compat, bpow_gt_0].
+rewrite (succ_eq_pos _ _ _ (Rlt_le _ _ Px)).
+now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLT_exact_shift; [lra| |].
+Qed.
+Lemma succ_FLT_exact_shift :
+ forall x e,
+ (x <> 0)%R ->
+ (emin + prec + 1 <= mag beta x)%Z ->
+ (emin + prec - mag beta x + 1 <= e)%Z ->
+ (succ beta FLT_exp (x * bpow e) = succ beta FLT_exp x * bpow e)%R.
+Proof.
+intros x e Nzx Hmx He.
+destruct (Rle_or_lt 0 x) as [Px|Nx].
+{ now apply succ_FLT_exact_shift_pos; [lra|lia|lia]. }
+unfold succ.
+rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
+rewrite Rle_bool_false; [|now simpl].
+rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
+unfold pred_pos.
+rewrite mag_mult_bpow; [|lra].
+replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
+unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
+fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
+{ rewrite mag_opp; unfold FLT_exp; do 2 (rewrite Z.max_l; [|lia]).
+ replace (_ - _)%Z with (mag beta x - 1 - prec + e)%Z; [|ring].
+ rewrite bpow_plus; ring. }
+rewrite ulp_FLT_exact_shift; [ring|lra| |]; rewrite mag_opp; lia.
+Qed.
(** FLT is a nice format: it has a monotone exponent... *)
Global Instance FLT_exp_monotone : Monotone_exp FLT_exp.
@@ -310,7 +384,7 @@ zify ; omega.
Qed.
(** and it allows a rounding to nearest, ties to even. *)
-Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z.
+Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.
Global Instance exists_NE_FLT : Exists_NE beta FLT_exp.
Proof.
diff --git a/flocq/Core/FLX.v b/flocq/Core/FLX.v
new file mode 100644
index 00000000..803d96ef
--- /dev/null
+++ b/flocq/Core/FLX.v
@@ -0,0 +1,362 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2009-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2009-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * Floating-point format without underflow *)
+Require Import Raux Defs Round_pred Generic_fmt Float_prop.
+Require Import FIX Ulp Round_NE.
+Require Import Psatz.
+
+Section RND_FLX.
+
+Variable beta : radix.
+
+Notation bpow e := (bpow beta e).
+
+Variable prec : Z.
+
+Class Prec_gt_0 :=
+ prec_gt_0 : (0 < prec)%Z.
+
+Context { prec_gt_0_ : Prec_gt_0 }.
+
+Inductive FLX_format (x : R) : Prop :=
+ FLX_spec (f : float beta) :
+ x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> FLX_format x.
+
+Definition FLX_exp (e : Z) := (e - prec)%Z.
+
+(** Properties of the FLX format *)
+
+Global Instance FLX_exp_valid : Valid_exp FLX_exp.
+Proof.
+intros k.
+unfold FLX_exp.
+generalize prec_gt_0.
+repeat split ; intros ; omega.
+Qed.
+
+Theorem FIX_format_FLX :
+ forall x e,
+ (bpow (e - 1) <= Rabs x <= bpow e)%R ->
+ FLX_format x ->
+ FIX_format beta (e - prec) x.
+Proof.
+clear prec_gt_0_.
+intros x e Hx [[xm xe] H1 H2].
+rewrite H1, (F2R_prec_normalize beta xm xe e prec).
+now eexists.
+exact H2.
+now rewrite <- H1.
+Qed.
+
+Theorem FLX_format_generic :
+ forall x, generic_format beta FLX_exp x -> FLX_format x.
+Proof.
+intros x H.
+rewrite H.
+eexists ; repeat split.
+simpl.
+apply lt_IZR.
+rewrite abs_IZR.
+rewrite <- scaled_mantissa_generic with (1 := H).
+rewrite <- scaled_mantissa_abs.
+apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))).
+apply bpow_gt_0.
+rewrite scaled_mantissa_mult_bpow.
+rewrite IZR_Zpower, <- bpow_plus.
+2: now apply Zlt_le_weak.
+unfold cexp, FLX_exp.
+ring_simplify (prec + (mag beta (Rabs x) - prec))%Z.
+rewrite mag_abs.
+destruct (Req_dec x 0) as [Hx|Hx].
+rewrite Hx, Rabs_R0.
+apply bpow_gt_0.
+destruct (mag beta x) as (ex, Ex).
+now apply Ex.
+Qed.
+
+Theorem generic_format_FLX :
+ forall x, FLX_format x -> generic_format beta FLX_exp x.
+Proof.
+clear prec_gt_0_.
+intros x [[mx ex] H1 H2].
+simpl in H2.
+rewrite H1.
+apply generic_format_F2R.
+intros Zmx.
+unfold cexp, FLX_exp.
+rewrite mag_F2R with (1 := Zmx).
+apply Zplus_le_reg_r with (prec - ex)%Z.
+ring_simplify.
+now apply mag_le_Zpower.
+Qed.
+
+Theorem FLX_format_satisfies_any :
+ satisfies_any FLX_format.
+Proof.
+refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
+intros x.
+split.
+apply FLX_format_generic.
+apply generic_format_FLX.
+Qed.
+
+Theorem FLX_format_FIX :
+ forall x e,
+ (bpow (e - 1) <= Rabs x <= bpow e)%R ->
+ FIX_format beta (e - prec) x ->
+ FLX_format x.
+Proof with auto with typeclass_instances.
+intros x e Hx Fx.
+apply FLX_format_generic.
+apply generic_format_FIX in Fx.
+revert Fx.
+apply generic_inclusion with (e := e)...
+apply Z.le_refl.
+Qed.
+
+(** unbounded floating-point format with normal mantissas *)
+Inductive FLXN_format (x : R) : Prop :=
+ FLXN_spec (f : float beta) :
+ x = F2R f ->
+ (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
+ FLXN_format x.
+
+Theorem generic_format_FLXN :
+ forall x, FLXN_format x -> generic_format beta FLX_exp x.
+Proof.
+intros x [[xm ex] H1 H2].
+destruct (Req_dec x 0) as [Zx|Zx].
+rewrite Zx.
+apply generic_format_0.
+specialize (H2 Zx).
+apply generic_format_FLX.
+rewrite H1.
+eexists ; repeat split.
+apply H2.
+Qed.
+
+Theorem FLXN_format_generic :
+ forall x, generic_format beta FLX_exp x -> FLXN_format x.
+Proof.
+intros x Hx.
+rewrite Hx.
+simpl.
+eexists. easy.
+rewrite <- Hx.
+intros Zx.
+simpl.
+split.
+(* *)
+apply le_IZR.
+rewrite IZR_Zpower.
+2: now apply Zlt_0_le_0_pred.
+rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
+apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)).
+apply bpow_gt_0.
+rewrite <- bpow_plus.
+rewrite <- scaled_mantissa_abs.
+rewrite <- cexp_abs.
+rewrite scaled_mantissa_mult_bpow.
+unfold cexp, FLX_exp.
+rewrite mag_abs.
+ring_simplify (prec - 1 + (mag beta x - prec))%Z.
+destruct (mag beta x) as (ex,Ex).
+now apply Ex.
+(* *)
+apply lt_IZR.
+rewrite IZR_Zpower.
+2: now apply Zlt_le_weak.
+rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
+apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)).
+apply bpow_gt_0.
+rewrite <- bpow_plus.
+rewrite <- scaled_mantissa_abs.
+rewrite <- cexp_abs.
+rewrite scaled_mantissa_mult_bpow.
+unfold cexp, FLX_exp.
+rewrite mag_abs.
+ring_simplify (prec + (mag beta x - prec))%Z.
+destruct (mag beta x) as (ex,Ex).
+now apply Ex.
+Qed.
+
+Theorem FLXN_format_satisfies_any :
+ satisfies_any FLXN_format.
+Proof.
+refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
+split ; intros H.
+now apply FLXN_format_generic.
+now apply generic_format_FLXN.
+Qed.
+
+Lemma negligible_exp_FLX :
+ negligible_exp FLX_exp = None.
+Proof.
+case (negligible_exp_spec FLX_exp).
+intros _; reflexivity.
+intros n H2; contradict H2.
+unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega.
+Qed.
+
+Theorem generic_format_FLX_1 :
+ generic_format beta FLX_exp 1.
+Proof.
+unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
+rewrite Rmult_1_l, (mag_unique beta 1 1).
+{ unfold FLX_exp.
+ rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega].
+ rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; omega].
+ rewrite <- bpow_plus.
+ now replace (_ + _)%Z with Z0 by ring. }
+rewrite Rabs_R1; simpl; split; [now right|].
+unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt.
+assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); omega.
+Qed.
+
+Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
+Proof.
+unfold ulp; rewrite Req_bool_true; trivial.
+rewrite negligible_exp_FLX; easy.
+Qed.
+
+Lemma ulp_FLX_1 : ulp beta FLX_exp 1 = bpow (-prec + 1).
+Proof.
+unfold ulp, FLX_exp, cexp; rewrite Req_bool_false; [|apply R1_neq_R0].
+rewrite mag_1; f_equal; ring.
+Qed.
+
+Lemma succ_FLX_1 : (succ beta FLX_exp 1 = 1 + bpow (-prec + 1))%R.
+Proof.
+now unfold succ; rewrite Rle_bool_true; [|apply Rle_0_1]; rewrite ulp_FLX_1.
+Qed.
+
+Theorem eq_0_round_0_FLX :
+ forall rnd {Vr: Valid_rnd rnd} x,
+ round beta FLX_exp rnd x = 0%R -> x = 0%R.
+Proof.
+intros rnd Hr x.
+apply eq_0_round_0_negligible_exp; try assumption.
+apply FLX_exp_valid.
+apply negligible_exp_FLX.
+Qed.
+
+Theorem gt_0_round_gt_0_FLX :
+ forall rnd {Vr: Valid_rnd rnd} x,
+ (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R.
+Proof with auto with typeclass_instances.
+intros rnd Hr x Hx.
+assert (K: (0 <= round beta FLX_exp rnd x)%R).
+rewrite <- (round_0 beta FLX_exp rnd).
+apply round_le... now apply Rlt_le.
+destruct K; try easy.
+absurd (x = 0)%R.
+now apply Rgt_not_eq.
+apply eq_0_round_0_FLX with rnd...
+Qed.
+
+
+Theorem ulp_FLX_le :
+ forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
+Proof.
+intros x; case (Req_dec x 0); intros Hx.
+rewrite Hx, ulp_FLX_0, Rabs_R0.
+right; ring.
+rewrite ulp_neq_0; try exact Hx.
+unfold cexp, FLX_exp.
+replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring.
+rewrite bpow_plus.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+now apply bpow_mag_le.
+Qed.
+
+Theorem ulp_FLX_ge :
+ forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
+Proof.
+intros x; case (Req_dec x 0); intros Hx.
+rewrite Hx, ulp_FLX_0, Rabs_R0.
+right; ring.
+rewrite ulp_neq_0; try exact Hx.
+unfold cexp, FLX_exp.
+unfold Zminus; rewrite bpow_plus.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+left; now apply bpow_mag_gt.
+Qed.
+
+Lemma ulp_FLX_exact_shift :
+ forall x e,
+ (ulp beta FLX_exp (x * bpow e) = ulp beta FLX_exp x * bpow e)%R.
+Proof.
+intros x e.
+destruct (Req_dec x 0) as [Hx|Hx].
+{ unfold ulp.
+ now rewrite !Req_bool_true, negligible_exp_FLX; rewrite ?Hx, ?Rmult_0_l. }
+unfold ulp; rewrite Req_bool_false;
+ [|now intro H; apply Hx, (Rmult_eq_reg_r (bpow e));
+ [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
+rewrite (Req_bool_false _ _ Hx), <- bpow_plus; f_equal; unfold cexp, FLX_exp.
+now rewrite mag_mult_bpow; [ring|].
+Qed.
+
+Lemma succ_FLX_exact_shift :
+ forall x e,
+ (succ beta FLX_exp (x * bpow e) = succ beta FLX_exp x * bpow e)%R.
+Proof.
+intros x e.
+destruct (Rle_or_lt 0 x) as [Px|Nx].
+{ rewrite succ_eq_pos; [|now apply Rmult_le_pos, bpow_ge_0].
+ rewrite (succ_eq_pos _ _ _ Px).
+ now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLX_exact_shift. }
+unfold succ.
+rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
+rewrite Rle_bool_false; [|now simpl].
+rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
+unfold pred_pos.
+rewrite mag_mult_bpow; [|lra].
+replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
+unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
+fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
+{ unfold FLX_exp.
+ replace (_ - _)%Z with (mag beta (- x) - 1 - prec + e)%Z; [|ring].
+ rewrite bpow_plus; ring. }
+rewrite ulp_FLX_exact_shift; ring.
+Qed.
+
+(** FLX is a nice format: it has a monotone exponent... *)
+Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
+Proof.
+intros ex ey Hxy.
+now apply Zplus_le_compat_r.
+Qed.
+
+(** and it allows a rounding to nearest, ties to even. *)
+Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.
+
+Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
+Proof.
+destruct NE_prop as [H|H].
+now left.
+right.
+unfold FLX_exp.
+split ; omega.
+Qed.
+
+End RND_FLX.
diff --git a/flocq/Core/Fcore_FTZ.v b/flocq/Core/FTZ.v
index a2fab00b..1a93bcd9 100644
--- a/flocq/Core/Fcore_FTZ.v
+++ b/flocq/Core/FTZ.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,13 +18,8 @@ COPYING file for more details.
*)
(** * Floating-point format with abrupt underflow *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_float_prop.
-Require Import Fcore_ulp.
-Require Import Fcore_FLX.
+Require Import Raux Defs Round_pred Generic_fmt.
+Require Import Float_prop Ulp FLX.
Section RND_FTZ.
@@ -36,11 +31,12 @@ Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
-(* floating-point format with abrupt underflow *)
-Definition FTZ_format (x : R) :=
- exists f : float beta,
- x = F2R f /\ (x <> R0 -> Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z /\
- (emin <= Fexp f)%Z.
+Inductive FTZ_format (x : R) : Prop :=
+ FTZ_spec (f : float beta) :
+ x = F2R f ->
+ (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
+ (emin <= Fexp f)%Z ->
+ FTZ_format x.
Definition FTZ_exp e := if Zlt_bool (e - prec) emin then (emin + prec - 1)%Z else (e - prec)%Z.
@@ -73,9 +69,10 @@ Qed.
Theorem FLXN_format_FTZ :
forall x, FTZ_format x -> FLXN_format beta prec x.
Proof.
-intros x ((xm, xe), (Hx1, (Hx2, Hx3))).
+intros x [[xm xe] Hx1 Hx2 Hx3].
eexists.
-apply (conj Hx1 Hx2).
+exact Hx1.
+exact Hx2.
Qed.
Theorem generic_format_FTZ :
@@ -83,9 +80,9 @@ Theorem generic_format_FTZ :
Proof.
intros x Hx.
cut (generic_format beta (FLX_exp prec) x).
-apply generic_inclusion_ln_beta.
+apply generic_inclusion_mag.
intros Zx.
-destruct Hx as ((xm, xe), (Hx1, (Hx2, Hx3))).
+destruct Hx as [[xm xe] Hx1 Hx2 Hx3].
simpl in Hx2, Hx3.
specialize (Hx2 Zx).
assert (Zxm: xm <> Z0).
@@ -94,11 +91,11 @@ rewrite Hx1, Zx.
apply F2R_0.
unfold FTZ_exp, FLX_exp.
rewrite Zlt_bool_false.
-apply Zle_refl.
-rewrite Hx1, ln_beta_F2R with (1 := Zxm).
-cut (prec - 1 < ln_beta beta (Z2R xm))%Z.
+apply Z.le_refl.
+rewrite Hx1, mag_F2R with (1 := Zxm).
+cut (prec - 1 < mag beta (IZR xm))%Z.
clear -Hx3 ; omega.
-apply ln_beta_gt_Zpower with (1 := Zxm).
+apply mag_gt_Zpower with (1 := Zxm).
apply Hx2.
apply generic_format_FLXN.
now apply FLXN_format_FTZ.
@@ -108,17 +105,14 @@ Theorem FTZ_format_generic :
forall x, generic_format beta FTZ_exp x -> FTZ_format x.
Proof.
intros x Hx.
-destruct (Req_dec x 0) as [Hx3|Hx3].
+destruct (Req_dec x 0) as [->|Hx3].
exists (Float beta 0 emin).
-split.
-unfold F2R. simpl.
-now rewrite Rmult_0_l.
-split.
+apply sym_eq, F2R_0.
intros H.
now elim H.
-apply Zle_refl.
-unfold generic_format, scaled_mantissa, canonic_exp, FTZ_exp in Hx.
-destruct (ln_beta beta x) as (ex, Hx4).
+apply Z.le_refl.
+unfold generic_format, scaled_mantissa, cexp, FTZ_exp in Hx.
+destruct (mag beta x) as (ex, Hx4).
simpl in Hx.
specialize (Hx4 Hx3).
generalize (Zlt_cases (ex - prec) emin) Hx. clear Hx.
@@ -129,43 +123,43 @@ rewrite Hx2, <- F2R_Zabs.
rewrite <- (Rmult_1_l (bpow ex)).
unfold F2R. simpl.
apply Rmult_le_compat.
-now apply (Z2R_le 0 1).
+now apply IZR_le.
apply bpow_ge_0.
-apply (Z2R_le 1).
+apply IZR_le.
apply (Zlt_le_succ 0).
-apply lt_Z2R.
+apply lt_IZR.
apply Rmult_lt_reg_r with (bpow (emin + prec - 1)).
apply bpow_gt_0.
rewrite Rmult_0_l.
-change (0 < F2R (Float beta (Zabs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
+change (0 < F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (emin + prec - 1))))) (emin + prec - 1)))%R.
rewrite F2R_Zabs, <- Hx2.
now apply Rabs_pos_lt.
apply bpow_le.
omega.
rewrite Hx2.
eexists ; repeat split ; simpl.
-apply le_Z2R.
-rewrite Z2R_Zpower.
+apply le_IZR.
+rewrite IZR_Zpower.
apply Rmult_le_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec - 1 + (ex - prec))%Z with (ex - 1)%Z by ring.
-change (bpow (ex - 1) <= F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
+change (bpow (ex - 1) <= F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)))%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
apply Zle_minus_le_0.
now apply (Zlt_le_succ 0).
-apply lt_Z2R.
-rewrite Z2R_Zpower.
+apply lt_IZR.
+rewrite IZR_Zpower.
apply Rmult_lt_reg_r with (bpow (ex - prec)).
apply bpow_gt_0.
rewrite <- bpow_plus.
replace (prec + (ex - prec))%Z with ex by ring.
-change (F2R (Float beta (Zabs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
+change (F2R (Float beta (Z.abs (Ztrunc (x * bpow (- (ex - prec))))) (ex - prec)) < bpow ex)%R.
rewrite F2R_Zabs, <- Hx2.
apply Hx4.
now apply Zlt_le_weak.
-now apply Zge_le.
+now apply Z.ge_le.
Qed.
Theorem FTZ_format_satisfies_any :
@@ -191,11 +185,12 @@ apply generic_inclusion_ge.
intros e He.
unfold FTZ_exp.
rewrite Zlt_bool_false.
-apply Zle_refl.
+apply Z.le_refl.
omega.
Qed.
-Theorem ulp_FTZ_0: ulp beta FTZ_exp 0 = bpow (emin+prec-1).
+Theorem ulp_FTZ_0 :
+ ulp beta FTZ_exp 0 = bpow (emin+prec-1).
Proof with auto with typeclass_instances.
unfold ulp; rewrite Req_bool_true; trivial.
case (negligible_exp_spec FTZ_exp).
@@ -230,9 +225,9 @@ case Rle_bool_spec ; intros Hx ;
4: easy.
(* 1 <= |x| *)
now apply Zrnd_le.
-rewrite <- (Zrnd_Z2R rnd 0).
+rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
-apply Rle_trans with (Z2R (-1)). 2: now apply Z2R_le.
+apply Rle_trans with (-1)%R. 2: now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hx) as [Hx1|Hx1].
exact Hx1.
elim Rle_not_lt with (1 := Hx1).
@@ -240,10 +235,10 @@ apply Rle_lt_trans with (2 := Hy).
apply Rle_trans with (1 := Hxy).
apply RRle_abs.
(* |x| < 1 *)
-rewrite <- (Zrnd_Z2R rnd 0).
+rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
-apply Rle_trans with (Z2R 1).
-now apply Z2R_le.
+apply Rle_trans with 1%R.
+now apply IZR_le.
destruct (Rabs_ge_inv _ _ Hy) as [Hy1|Hy1].
elim Rle_not_lt with (1 := Hy1).
apply Rlt_le_trans with (2 := Hxy).
@@ -252,12 +247,12 @@ exact Hy1.
(* *)
intros n.
unfold Zrnd_FTZ.
-rewrite Zrnd_Z2R...
+rewrite Zrnd_IZR...
case Rle_bool_spec.
easy.
-rewrite <- Z2R_abs.
+rewrite <- abs_IZR.
intros H.
-generalize (lt_Z2R _ 1 H).
+generalize (lt_IZR _ 1 H).
clear.
now case n ; trivial ; simpl ; intros [p|p|].
Qed.
@@ -268,8 +263,8 @@ Theorem round_FTZ_FLX :
round beta FTZ_exp Zrnd_FTZ x = round beta (FLX_exp prec) rnd x.
Proof.
intros x Hx.
-unfold round, scaled_mantissa, canonic_exp.
-destruct (ln_beta beta x) as (ex, He). simpl.
+unfold round, scaled_mantissa, cexp.
+destruct (mag beta x) as (ex, He). simpl.
assert (Hx0: x <> 0%R).
intros Hx0.
apply Rle_not_lt with (1 := Hx).
@@ -306,14 +301,14 @@ Qed.
Theorem round_FTZ_small :
forall x : R,
(Rabs x < bpow (emin + prec - 1))%R ->
- round beta FTZ_exp Zrnd_FTZ x = R0.
+ round beta FTZ_exp Zrnd_FTZ x = 0%R.
Proof with auto with typeclass_instances.
intros x Hx.
destruct (Req_dec x 0) as [Hx0|Hx0].
rewrite Hx0.
apply round_0...
-unfold round, scaled_mantissa, canonic_exp.
-destruct (ln_beta beta x) as (ex, He). simpl.
+unfold round, scaled_mantissa, cexp.
+destruct (mag beta x) as (ex, He). simpl.
specialize (He Hx0).
unfold Zrnd_FTZ.
rewrite Rle_bool_false.
@@ -331,7 +326,7 @@ unfold FTZ_exp.
generalize (Zlt_cases (ex - prec) emin).
case Zlt_bool.
intros _.
-apply Zle_refl.
+apply Z.le_refl.
intros He'.
elim Rlt_not_le with (1 := Hx).
apply Rle_trans with (2 := proj1 He).
diff --git a/flocq/Core/Fcore_FLX.v b/flocq/Core/Fcore_FLX.v
deleted file mode 100644
index 55f6db61..00000000
--- a/flocq/Core/Fcore_FLX.v
+++ /dev/null
@@ -1,271 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * Floating-point format without underflow *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_float_prop.
-Require Import Fcore_FIX.
-Require Import Fcore_ulp.
-Require Import Fcore_rnd_ne.
-
-Section RND_FLX.
-
-Variable beta : radix.
-
-Notation bpow e := (bpow beta e).
-
-Variable prec : Z.
-
-Class Prec_gt_0 :=
- prec_gt_0 : (0 < prec)%Z.
-
-Context { prec_gt_0_ : Prec_gt_0 }.
-
-(* unbounded floating-point format *)
-Definition FLX_format (x : R) :=
- exists f : float beta,
- x = F2R f /\ (Zabs (Fnum f) < Zpower beta prec)%Z.
-
-Definition FLX_exp (e : Z) := (e - prec)%Z.
-
-(** Properties of the FLX format *)
-
-Global Instance FLX_exp_valid : Valid_exp FLX_exp.
-Proof.
-intros k.
-unfold FLX_exp.
-generalize prec_gt_0.
-repeat split ; intros ; omega.
-Qed.
-
-Theorem FIX_format_FLX :
- forall x e,
- (bpow (e - 1) <= Rabs x <= bpow e)%R ->
- FLX_format x ->
- FIX_format beta (e - prec) x.
-Proof.
-clear prec_gt_0_.
-intros x e Hx ((xm, xe), (H1, H2)).
-rewrite H1, (F2R_prec_normalize beta xm xe e prec).
-now eexists.
-exact H2.
-now rewrite <- H1.
-Qed.
-
-Theorem FLX_format_generic :
- forall x, generic_format beta FLX_exp x -> FLX_format x.
-Proof.
-intros x H.
-rewrite H.
-unfold FLX_format.
-eexists ; repeat split.
-simpl.
-apply lt_Z2R.
-rewrite Z2R_abs.
-rewrite <- scaled_mantissa_generic with (1 := H).
-rewrite <- scaled_mantissa_abs.
-apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp (Rabs x))).
-apply bpow_gt_0.
-rewrite scaled_mantissa_mult_bpow.
-rewrite Z2R_Zpower, <- bpow_plus.
-2: now apply Zlt_le_weak.
-unfold canonic_exp, FLX_exp.
-ring_simplify (prec + (ln_beta beta (Rabs x) - prec))%Z.
-rewrite ln_beta_abs.
-destruct (Req_dec x 0) as [Hx|Hx].
-rewrite Hx, Rabs_R0.
-apply bpow_gt_0.
-destruct (ln_beta beta x) as (ex, Ex).
-now apply Ex.
-Qed.
-
-Theorem generic_format_FLX :
- forall x, FLX_format x -> generic_format beta FLX_exp x.
-Proof.
-clear prec_gt_0_.
-intros x ((mx,ex),(H1,H2)).
-simpl in H2.
-rewrite H1.
-apply generic_format_F2R.
-intros Zmx.
-unfold canonic_exp, FLX_exp.
-rewrite ln_beta_F2R with (1 := Zmx).
-apply Zplus_le_reg_r with (prec - ex)%Z.
-ring_simplify.
-now apply ln_beta_le_Zpower.
-Qed.
-
-Theorem FLX_format_satisfies_any :
- satisfies_any FLX_format.
-Proof.
-refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
-intros x.
-split.
-apply FLX_format_generic.
-apply generic_format_FLX.
-Qed.
-
-Theorem FLX_format_FIX :
- forall x e,
- (bpow (e - 1) <= Rabs x <= bpow e)%R ->
- FIX_format beta (e - prec) x ->
- FLX_format x.
-Proof with auto with typeclass_instances.
-intros x e Hx Fx.
-apply FLX_format_generic.
-apply generic_format_FIX in Fx.
-revert Fx.
-apply generic_inclusion with (e := e)...
-apply Zle_refl.
-Qed.
-
-(** unbounded floating-point format with normal mantissas *)
-Definition FLXN_format (x : R) :=
- exists f : float beta,
- x = F2R f /\ (x <> R0 ->
- Zpower beta (prec - 1) <= Zabs (Fnum f) < Zpower beta prec)%Z.
-
-Theorem generic_format_FLXN :
- forall x, FLXN_format x -> generic_format beta FLX_exp x.
-Proof.
-intros x ((xm,ex),(H1,H2)).
-destruct (Req_dec x 0) as [Zx|Zx].
-rewrite Zx.
-apply generic_format_0.
-specialize (H2 Zx).
-apply generic_format_FLX.
-rewrite H1.
-eexists ; repeat split.
-apply H2.
-Qed.
-
-Theorem FLXN_format_generic :
- forall x, generic_format beta FLX_exp x -> FLXN_format x.
-Proof.
-intros x Hx.
-rewrite Hx.
-simpl.
-eexists ; split. split.
-simpl.
-rewrite <- Hx.
-intros Zx.
-split.
-(* *)
-apply le_Z2R.
-rewrite Z2R_Zpower.
-2: now apply Zlt_0_le_0_pred.
-rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
-apply Rmult_le_reg_r with (bpow (canonic_exp beta FLX_exp x)).
-apply bpow_gt_0.
-rewrite <- bpow_plus.
-rewrite <- scaled_mantissa_abs.
-rewrite <- canonic_exp_abs.
-rewrite scaled_mantissa_mult_bpow.
-unfold canonic_exp, FLX_exp.
-rewrite ln_beta_abs.
-ring_simplify (prec - 1 + (ln_beta beta x - prec))%Z.
-destruct (ln_beta beta x) as (ex,Ex).
-now apply Ex.
-(* *)
-apply lt_Z2R.
-rewrite Z2R_Zpower.
-2: now apply Zlt_le_weak.
-rewrite Z2R_abs, <- scaled_mantissa_generic with (1 := Hx).
-apply Rmult_lt_reg_r with (bpow (canonic_exp beta FLX_exp x)).
-apply bpow_gt_0.
-rewrite <- bpow_plus.
-rewrite <- scaled_mantissa_abs.
-rewrite <- canonic_exp_abs.
-rewrite scaled_mantissa_mult_bpow.
-unfold canonic_exp, FLX_exp.
-rewrite ln_beta_abs.
-ring_simplify (prec + (ln_beta beta x - prec))%Z.
-destruct (ln_beta beta x) as (ex,Ex).
-now apply Ex.
-Qed.
-
-Theorem FLXN_format_satisfies_any :
- satisfies_any FLXN_format.
-Proof.
-refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
-split ; intros H.
-now apply FLXN_format_generic.
-now apply generic_format_FLXN.
-Qed.
-
-Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
-Proof.
-unfold ulp; rewrite Req_bool_true; trivial.
-case (negligible_exp_spec FLX_exp).
-intros _; reflexivity.
-intros n H2; contradict H2.
-unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; omega.
-Qed.
-
-Theorem ulp_FLX_le: forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
-Proof.
-intros x; case (Req_dec x 0); intros Hx.
-rewrite Hx, ulp_FLX_0, Rabs_R0.
-right; ring.
-rewrite ulp_neq_0; try exact Hx.
-unfold canonic_exp, FLX_exp.
-replace (ln_beta beta x - prec)%Z with ((ln_beta beta x - 1) + (1-prec))%Z by ring.
-rewrite bpow_plus.
-apply Rmult_le_compat_r.
-apply bpow_ge_0.
-now apply bpow_ln_beta_le.
-Qed.
-
-
-Theorem ulp_FLX_ge: forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
-Proof.
-intros x; case (Req_dec x 0); intros Hx.
-rewrite Hx, ulp_FLX_0, Rabs_R0.
-right; ring.
-rewrite ulp_neq_0; try exact Hx.
-unfold canonic_exp, FLX_exp.
-unfold Zminus; rewrite bpow_plus.
-apply Rmult_le_compat_r.
-apply bpow_ge_0.
-left; now apply bpow_ln_beta_gt.
-Qed.
-
-(** FLX is a nice format: it has a monotone exponent... *)
-Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
-Proof.
-intros ex ey Hxy.
-now apply Zplus_le_compat_r.
-Qed.
-
-(** and it allows a rounding to nearest, ties to even. *)
-Hypothesis NE_prop : Zeven beta = false \/ (1 < prec)%Z.
-
-Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
-Proof.
-destruct NE_prop as [H|H].
-now left.
-right.
-unfold FLX_exp.
-split ; omega.
-Qed.
-
-End RND_FLX.
diff --git a/flocq/Core/Fcore_float_prop.v b/flocq/Core/Float_prop.v
index a183bf0a..804dd397 100644
--- a/flocq/Core/Fcore_float_prop.v
+++ b/flocq/Core/Float_prop.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,40 +18,38 @@ COPYING file for more details.
*)
(** * Basic properties of floating-point formats: lemmas about mantissa, exponent... *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
+Require Import Raux Defs Digits.
Section Float_prop.
Variable beta : radix.
-
Notation bpow e := (bpow beta e).
Theorem Rcompare_F2R :
forall e m1 m2 : Z,
- Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Zcompare m1 m2.
+ Rcompare (F2R (Float beta m1 e)) (F2R (Float beta m2 e)) = Z.compare m1 m2.
Proof.
intros e m1 m2.
unfold F2R. simpl.
rewrite Rcompare_mult_r.
-apply Rcompare_Z2R.
+apply Rcompare_IZR.
apply bpow_gt_0.
Qed.
(** Basic facts *)
-Theorem F2R_le_reg :
+Theorem le_F2R :
forall e m1 m2 : Z,
(F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R ->
(m1 <= m2)%Z.
Proof.
intros e m1 m2 H.
-apply le_Z2R.
+apply le_IZR.
apply Rmult_le_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.
-Theorem F2R_le_compat :
+Theorem F2R_le :
forall m1 m2 e : Z,
(m1 <= m2)%Z ->
(F2R (Float beta m1 e) <= F2R (Float beta m2 e))%R.
@@ -60,22 +58,22 @@ intros m1 m2 e H.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-now apply Z2R_le.
+now apply IZR_le.
Qed.
-Theorem F2R_lt_reg :
+Theorem lt_F2R :
forall e m1 m2 : Z,
(F2R (Float beta m1 e) < F2R (Float beta m2 e))%R ->
(m1 < m2)%Z.
Proof.
intros e m1 m2 H.
-apply lt_Z2R.
+apply lt_IZR.
apply Rmult_lt_reg_r with (bpow e).
apply bpow_gt_0.
exact H.
Qed.
-Theorem F2R_lt_compat :
+Theorem F2R_lt :
forall e m1 m2 : Z,
(m1 < m2)%Z ->
(F2R (Float beta m1 e) < F2R (Float beta m2 e))%R.
@@ -84,10 +82,10 @@ intros e m1 m2 H.
unfold F2R. simpl.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
-now apply Z2R_lt.
+now apply IZR_lt.
Qed.
-Theorem F2R_eq_compat :
+Theorem F2R_eq :
forall e m1 m2 : Z,
(m1 = m2)%Z ->
(F2R (Float beta m1 e) = F2R (Float beta m2 e))%R.
@@ -96,26 +94,26 @@ intros e m1 m2 H.
now apply (f_equal (fun m => F2R (Float beta m e))).
Qed.
-Theorem F2R_eq_reg :
+Theorem eq_F2R :
forall e m1 m2 : Z,
F2R (Float beta m1 e) = F2R (Float beta m2 e) ->
m1 = m2.
Proof.
intros e m1 m2 H.
apply Zle_antisym ;
- apply F2R_le_reg with e ;
+ apply le_F2R with e ;
rewrite H ;
apply Rle_refl.
Qed.
Theorem F2R_Zabs:
forall m e : Z,
- F2R (Float beta (Zabs m) e) = Rabs (F2R (Float beta m e)).
+ F2R (Float beta (Z.abs m) e) = Rabs (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R.
rewrite Rabs_mult.
-rewrite <- Z2R_abs.
+rewrite <- abs_IZR.
simpl.
apply f_equal.
apply sym_eq; apply Rabs_right.
@@ -125,12 +123,21 @@ Qed.
Theorem F2R_Zopp :
forall m e : Z,
- F2R (Float beta (Zopp m) e) = Ropp (F2R (Float beta m e)).
+ F2R (Float beta (Z.opp m) e) = Ropp (F2R (Float beta m e)).
Proof.
intros m e.
unfold F2R. simpl.
rewrite <- Ropp_mult_distr_l_reverse.
-now rewrite Z2R_opp.
+now rewrite opp_IZR.
+Qed.
+
+Theorem F2R_cond_Zopp :
+ forall b m e,
+ F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)).
+Proof.
+intros [|] m e ; unfold F2R ; simpl.
+now rewrite opp_IZR, Ropp_mult_distr_l_reverse.
+apply refl_equal.
Qed.
(** Sign facts *)
@@ -143,125 +150,125 @@ unfold F2R. simpl.
apply Rmult_0_l.
Qed.
-Theorem F2R_eq_0_reg :
+Theorem eq_0_F2R :
forall m e : Z,
F2R (Float beta m e) = 0%R ->
m = Z0.
Proof.
intros m e H.
-apply F2R_eq_reg with e.
+apply eq_F2R with e.
now rewrite F2R_0.
Qed.
-Theorem F2R_ge_0_reg :
+Theorem ge_0_F2R :
forall m e : Z,
(0 <= F2R (Float beta m e))%R ->
(0 <= m)%Z.
Proof.
intros m e H.
-apply F2R_le_reg with e.
+apply le_F2R with e.
now rewrite F2R_0.
Qed.
-Theorem F2R_le_0_reg :
+Theorem le_0_F2R :
forall m e : Z,
(F2R (Float beta m e) <= 0)%R ->
(m <= 0)%Z.
Proof.
intros m e H.
-apply F2R_le_reg with e.
+apply le_F2R with e.
now rewrite F2R_0.
Qed.
-Theorem F2R_gt_0_reg :
+Theorem gt_0_F2R :
forall m e : Z,
(0 < F2R (Float beta m e))%R ->
(0 < m)%Z.
Proof.
intros m e H.
-apply F2R_lt_reg with e.
+apply lt_F2R with e.
now rewrite F2R_0.
Qed.
-Theorem F2R_lt_0_reg :
+Theorem lt_0_F2R :
forall m e : Z,
(F2R (Float beta m e) < 0)%R ->
(m < 0)%Z.
Proof.
intros m e H.
-apply F2R_lt_reg with e.
+apply lt_F2R with e.
now rewrite F2R_0.
Qed.
-Theorem F2R_ge_0_compat :
+Theorem F2R_ge_0 :
forall f : float beta,
(0 <= Fnum f)%Z ->
(0 <= F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
-now apply F2R_le_compat.
+now apply F2R_le.
Qed.
-Theorem F2R_le_0_compat :
+Theorem F2R_le_0 :
forall f : float beta,
(Fnum f <= 0)%Z ->
(F2R f <= 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
-now apply F2R_le_compat.
+now apply F2R_le.
Qed.
-Theorem F2R_gt_0_compat :
+Theorem F2R_gt_0 :
forall f : float beta,
(0 < Fnum f)%Z ->
(0 < F2R f)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
-now apply F2R_lt_compat.
+now apply F2R_lt.
Qed.
-Theorem F2R_lt_0_compat :
+Theorem F2R_lt_0 :
forall f : float beta,
(Fnum f < 0)%Z ->
(F2R f < 0)%R.
Proof.
intros f H.
rewrite <- F2R_0 with (Fexp f).
-now apply F2R_lt_compat.
+now apply F2R_lt.
Qed.
-Theorem F2R_neq_0_compat :
+Theorem F2R_neq_0 :
forall f : float beta,
(Fnum f <> 0)%Z ->
(F2R f <> 0)%R.
Proof.
intros f H H1.
apply H.
-now apply F2R_eq_0_reg with (Fexp f).
+now apply eq_0_F2R with (Fexp f).
Qed.
-Lemma Fnum_ge_0_compat: forall (f : float beta),
+Lemma Fnum_ge_0: forall (f : float beta),
(0 <= F2R f)%R -> (0 <= Fnum f)%Z.
Proof.
intros f H.
case (Zle_or_lt 0 (Fnum f)); trivial.
intros H1; contradict H.
apply Rlt_not_le.
-now apply F2R_lt_0_compat.
+now apply F2R_lt_0.
Qed.
-Lemma Fnum_le_0_compat: forall (f : float beta),
+Lemma Fnum_le_0: forall (f : float beta),
(F2R f <= 0)%R -> (Fnum f <= 0)%Z.
Proof.
intros f H.
case (Zle_or_lt (Fnum f) 0); trivial.
intros H1; contradict H.
apply Rlt_not_le.
-now apply F2R_gt_0_compat.
+now apply F2R_gt_0.
Qed.
(** Floats and bpow *)
@@ -281,7 +288,7 @@ Theorem bpow_le_F2R :
Proof.
intros m e H.
rewrite <- F2R_bpow.
-apply F2R_le_compat.
+apply F2R_le.
now apply (Zlt_le_succ 0).
Qed.
@@ -301,7 +308,7 @@ unfold F2R. simpl.
rewrite <- (Rmult_1_l (bpow e1)) at 1.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-apply (Z2R_le 1).
+apply IZR_le.
now apply (Zlt_le_succ 0).
now apply Rlt_le.
(* . *)
@@ -309,14 +316,14 @@ revert H.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
-rewrite <- (Z2R_Zpower beta (e2 - e1)).
+rewrite <- (IZR_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
-apply Z2R_le.
+apply IZR_le.
apply Zlt_le_succ.
-now apply lt_Z2R.
+now apply lt_IZR.
apply bpow_gt_0.
now apply Zle_minus_le_0.
Qed.
@@ -332,16 +339,16 @@ case (Zle_or_lt e1 e2); intros He.
replace e2 with (e2 - e1 + e1)%Z by ring.
rewrite bpow_plus.
unfold F2R. simpl.
-rewrite <- (Z2R_Zpower beta (e2 - e1)).
+rewrite <- (IZR_Zpower beta (e2 - e1)).
intros H.
apply Rmult_le_compat_r.
apply bpow_ge_0.
apply Rmult_lt_reg_r in H.
-apply Z2R_le.
+apply IZR_le.
rewrite (Zpred_succ (Zpower _ _)).
apply Zplus_le_compat_r.
apply Zlt_le_succ.
-now apply lt_Z2R.
+now apply lt_IZR.
apply bpow_gt_0.
now apply Zle_minus_le_0.
intros H.
@@ -352,14 +359,13 @@ now apply Zlt_le_weak.
unfold F2R. simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-replace 1%R with (Z2R 1) by reflexivity.
-apply Z2R_le.
+apply IZR_le.
omega.
Qed.
Theorem F2R_lt_bpow :
forall f : float beta, forall e',
- (Zabs (Fnum f) < Zpower beta (e' - Fexp f))%Z ->
+ (Z.abs (Fnum f) < Zpower beta (e' - Fexp f))%Z ->
(Rabs (F2R f) < bpow e')%R.
Proof.
intros (m, e) e' Hm.
@@ -369,8 +375,8 @@ unfold F2R. simpl.
apply Rmult_lt_reg_r with (bpow (-e)).
apply bpow_gt_0.
rewrite Rmult_assoc, <- 2!bpow_plus, Zplus_opp_r, Rmult_1_r.
-rewrite <-Z2R_Zpower. 2: now apply Zle_left.
-now apply Z2R_lt.
+rewrite <-IZR_Zpower. 2: now apply Zle_left.
+now apply IZR_lt.
elim Zlt_not_le with (1 := Hm).
simpl.
cut (e' - e < 0)%Z. 2: omega.
@@ -387,7 +393,7 @@ Theorem F2R_change_exp :
Proof.
intros e' m e He.
unfold F2R. simpl.
-rewrite Z2R_mult, Z2R_Zpower, Rmult_assoc.
+rewrite mult_IZR, IZR_Zpower, Rmult_assoc.
apply f_equal.
pattern e at 1 ; replace e with (e - e' + e')%Z by ring.
apply bpow_plus.
@@ -396,7 +402,7 @@ Qed.
Theorem F2R_prec_normalize :
forall m e e' p : Z,
- (Zabs m < Zpower beta p)%Z ->
+ (Z.abs m < Zpower beta p)%Z ->
(bpow (e' - 1)%Z <= Rabs (F2R (Float beta m e)))%R ->
F2R (Float beta m e) = F2R (Float beta (m * Zpower beta (e - e' + p)) (e' - p)).
Proof.
@@ -413,23 +419,23 @@ apply Rle_lt_trans with (1 := Hf).
rewrite <- F2R_Zabs, Zplus_comm, bpow_plus.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
-rewrite <- Z2R_Zpower.
-now apply Z2R_lt.
+rewrite <- IZR_Zpower.
+now apply IZR_lt.
exact Hp.
Qed.
-(** Floats and ln_beta *)
-Theorem ln_beta_F2R_bounds :
+(** Floats and mag *)
+Theorem mag_F2R_bounds :
forall x m e, (0 < m)%Z ->
(F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R ->
- ln_beta beta x = ln_beta beta (F2R (Float beta m e)) :> Z.
+ mag beta x = mag beta (F2R (Float beta m e)) :> Z.
Proof.
intros x m e Hp (Hx,Hx2).
-destruct (ln_beta beta (F2R (Float beta m e))) as (ex, He).
+destruct (mag beta (F2R (Float beta m e))) as (ex, He).
simpl.
-apply ln_beta_unique.
+apply mag_unique.
assert (Hp1: (0 < F2R (Float beta m e))%R).
-now apply F2R_gt_0_compat.
+now apply F2R_gt_0.
specialize (He (Rgt_not_eq _ _ Hp1)).
rewrite Rabs_pos_eq in He. 2: now apply Rlt_le.
destruct He as (He1, He2).
@@ -442,22 +448,65 @@ apply Rlt_le_trans with (1 := Hx2).
now apply F2R_p1_le_bpow.
Qed.
-Theorem ln_beta_F2R :
+Theorem mag_F2R :
forall m e : Z,
m <> Z0 ->
- (ln_beta beta (F2R (Float beta m e)) = ln_beta beta (Z2R m) + e :> Z)%Z.
+ (mag beta (F2R (Float beta m e)) = mag beta (IZR m) + e :> Z)%Z.
Proof.
intros m e H.
unfold F2R ; simpl.
-apply ln_beta_mult_bpow.
-exact (Z2R_neq m 0 H).
+apply mag_mult_bpow.
+now apply IZR_neq.
+Qed.
+
+Theorem Zdigits_mag :
+ forall n,
+ n <> Z0 ->
+ Zdigits beta n = mag beta (IZR n).
+Proof.
+intros n Hn.
+destruct (mag beta (IZR n)) as (e, He) ; simpl.
+specialize (He (IZR_neq _ _ Hn)).
+rewrite <- abs_IZR in He.
+assert (Hd := Zdigits_correct beta n).
+assert (Hd' := Zdigits_gt_0 beta n).
+apply Zle_antisym ; apply (bpow_lt_bpow beta).
+apply Rle_lt_trans with (2 := proj2 He).
+rewrite <- IZR_Zpower by omega.
+now apply IZR_le.
+apply Rle_lt_trans with (1 := proj1 He).
+rewrite <- IZR_Zpower by omega.
+now apply IZR_lt.
+Qed.
+
+Theorem mag_F2R_Zdigits :
+ forall m e, m <> Z0 ->
+ (mag beta (F2R (Float beta m e)) = Zdigits beta m + e :> Z)%Z.
+Proof.
+intros m e Hm.
+rewrite mag_F2R with (1 := Hm).
+apply (f_equal (fun v => Zplus v e)).
+apply sym_eq.
+now apply Zdigits_mag.
+Qed.
+
+Theorem mag_F2R_bounds_Zdigits :
+ forall x m e, (0 < m)%Z ->
+ (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R ->
+ mag beta x = (Zdigits beta m + e)%Z :> Z.
+Proof.
+intros x m e Hm Bx.
+apply mag_F2R_bounds with (1 := Hm) in Bx.
+rewrite Bx.
+apply mag_F2R_Zdigits.
+now apply Zgt_not_eq.
Qed.
Theorem float_distribution_pos :
forall m1 e1 m2 e2 : Z,
(0 < m1)%Z ->
(F2R (Float beta m1 e1) < F2R (Float beta m2 e2) < F2R (Float beta (m1 + 1) e1))%R ->
- (e2 < e1)%Z /\ (e1 + ln_beta beta (Z2R m1) = e2 + ln_beta beta (Z2R m2))%Z.
+ (e2 < e1)%Z /\ (e1 + mag beta (IZR m1) = e2 + mag beta (IZR m2))%Z.
Proof.
intros m1 e1 m2 e2 Hp1 (H12, H21).
assert (He: (e2 < e1)%Z).
@@ -465,35 +514,35 @@ assert (He: (e2 < e1)%Z).
apply Znot_ge_lt.
intros H0.
elim Rlt_not_le with (1 := H21).
-apply Zge_le in H0.
+apply Z.ge_le in H0.
apply (F2R_change_exp e1 m2 e2) in H0.
rewrite H0.
-apply F2R_le_compat.
+apply F2R_le.
apply Zlt_le_succ.
-apply (F2R_lt_reg e1).
+apply (lt_F2R e1).
now rewrite <- H0.
(* . *)
split.
exact He.
rewrite (Zplus_comm e1), (Zplus_comm e2).
assert (Hp2: (0 < m2)%Z).
-apply (F2R_gt_0_reg m2 e2).
+apply (gt_0_F2R m2 e2).
apply Rlt_trans with (2 := H12).
-now apply F2R_gt_0_compat.
-rewrite <- 2!ln_beta_F2R.
-destruct (ln_beta beta (F2R (Float beta m1 e1))) as (e1', H1).
+now apply F2R_gt_0.
+rewrite <- 2!mag_F2R.
+destruct (mag beta (F2R (Float beta m1 e1))) as (e1', H1).
simpl.
apply sym_eq.
-apply ln_beta_unique.
+apply mag_unique.
assert (H2 : (bpow (e1' - 1) <= F2R (Float beta m1 e1) < bpow e1')%R).
-rewrite <- (Zabs_eq m1), F2R_Zabs.
+rewrite <- (Z.abs_eq m1), F2R_Zabs.
apply H1.
apply Rgt_not_eq.
apply Rlt_gt.
-now apply F2R_gt_0_compat.
+now apply F2R_gt_0.
now apply Zlt_le_weak.
clear H1.
-rewrite <- F2R_Zabs, Zabs_eq.
+rewrite <- F2R_Zabs, Z.abs_eq.
split.
apply Rlt_le.
apply Rle_lt_trans with (2 := H12).
@@ -507,13 +556,4 @@ apply sym_not_eq.
now apply Zlt_not_eq.
Qed.
-Theorem F2R_cond_Zopp :
- forall b m e,
- F2R (Float beta (cond_Zopp b m) e) = cond_Ropp b (F2R (Float beta m e)).
-Proof.
-intros [|] m e ; unfold F2R ; simpl.
-now rewrite Z2R_opp, Ropp_mult_distr_l_reverse.
-apply refl_equal.
-Qed.
-
End Float_prop.
diff --git a/flocq/Core/Fcore_generic_fmt.v b/flocq/Core/Generic_fmt.v
index 668b4da2..cb37bd91 100644
--- a/flocq/Core/Fcore_generic_fmt.v
+++ b/flocq/Core/Generic_fmt.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,10 +18,7 @@ COPYING file for more details.
*)
(** * What is a real number belonging to a format, and many properties. *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_float_prop.
+Require Import Raux Defs Round_pred Float_prop.
Section Generic.
@@ -53,7 +50,7 @@ Proof.
intros k l Hk H.
apply Znot_ge_lt.
intros Hl.
-apply Zge_le in Hl.
+apply Z.ge_le in Hl.
assert (H' := proj2 (proj2 (valid_exp l) Hl) k).
omega.
Qed.
@@ -66,24 +63,24 @@ Proof.
intros k l Hk H.
apply Znot_ge_lt.
intros H'.
-apply Zge_le in H'.
-assert (Hl := Zle_trans _ _ _ H H').
+apply Z.ge_le in H'.
+assert (Hl := Z.le_trans _ _ _ H H').
apply valid_exp in Hl.
assert (H1 := proj2 Hl k H').
omega.
Qed.
-Definition canonic_exp x :=
- fexp (ln_beta beta x).
+Definition cexp x :=
+ fexp (mag beta x).
-Definition canonic (f : float beta) :=
- Fexp f = canonic_exp (F2R f).
+Definition canonical (f : float beta) :=
+ Fexp f = cexp (F2R f).
Definition scaled_mantissa x :=
- (x * bpow (- canonic_exp x))%R.
+ (x * bpow (- cexp x))%R.
Definition generic_format (x : R) :=
- x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (canonic_exp x)).
+ x = F2R (Float beta (Ztrunc (scaled_mantissa x)) (cexp x)).
(** Basic facts *)
Theorem generic_format_0 :
@@ -91,26 +88,39 @@ Theorem generic_format_0 :
Proof.
unfold generic_format, scaled_mantissa.
rewrite Rmult_0_l.
-change (Ztrunc 0) with (Ztrunc (Z2R 0)).
-now rewrite Ztrunc_Z2R, F2R_0.
+now rewrite Ztrunc_IZR, F2R_0.
Qed.
-Theorem canonic_exp_opp :
+Theorem cexp_opp :
forall x,
- canonic_exp (-x) = canonic_exp x.
+ cexp (-x) = cexp x.
Proof.
intros x.
-unfold canonic_exp.
-now rewrite ln_beta_opp.
+unfold cexp.
+now rewrite mag_opp.
Qed.
-Theorem canonic_exp_abs :
+Theorem cexp_abs :
forall x,
- canonic_exp (Rabs x) = canonic_exp x.
+ cexp (Rabs x) = cexp x.
Proof.
intros x.
-unfold canonic_exp.
-now rewrite ln_beta_abs.
+unfold cexp.
+now rewrite mag_abs.
+Qed.
+
+Theorem canonical_generic_format :
+ forall x,
+ generic_format x ->
+ exists f : float beta,
+ x = F2R f /\ canonical f.
+Proof.
+intros x Hx.
+rewrite Hx.
+eexists.
+apply (conj eq_refl).
+unfold canonical.
+now rewrite <- Hx.
Qed.
Theorem generic_format_bpow :
@@ -118,11 +128,11 @@ Theorem generic_format_bpow :
generic_format (bpow e).
Proof.
intros e H.
-unfold generic_format, scaled_mantissa, canonic_exp.
-rewrite ln_beta_bpow.
+unfold generic_format, scaled_mantissa, cexp.
+rewrite mag_bpow.
rewrite <- bpow_plus.
-rewrite <- (Z2R_Zpower beta (e + - fexp (e + 1))).
-rewrite Ztrunc_Z2R.
+rewrite <- (IZR_Zpower beta (e + - fexp (e + 1))).
+rewrite Ztrunc_IZR.
rewrite <- F2R_bpow.
rewrite F2R_change_exp with (1 := H).
now rewrite Zmult_1_l.
@@ -140,110 +150,107 @@ now apply valid_exp_.
rewrite <- H.
apply valid_exp.
rewrite H.
-apply Zle_refl.
+apply Z.le_refl.
Qed.
Theorem generic_format_F2R :
forall m e,
- ( m <> 0 -> canonic_exp (F2R (Float beta m e)) <= e )%Z ->
+ ( m <> 0 -> cexp (F2R (Float beta m e)) <= e )%Z ->
generic_format (F2R (Float beta m e)).
Proof.
intros m e.
-destruct (Z_eq_dec m 0) as [Zm|Zm].
+destruct (Z.eq_dec m 0) as [Zm|Zm].
intros _.
rewrite Zm, F2R_0.
apply generic_format_0.
unfold generic_format, scaled_mantissa.
-set (e' := canonic_exp (F2R (Float beta m e))).
+set (e' := cexp (F2R (Float beta m e))).
intros He.
specialize (He Zm).
unfold F2R at 3. simpl.
rewrite F2R_change_exp with (1 := He).
-apply F2R_eq_compat.
-rewrite Rmult_assoc, <- bpow_plus, <- Z2R_Zpower, <- Z2R_mult.
-now rewrite Ztrunc_Z2R.
+apply F2R_eq.
+rewrite Rmult_assoc, <- bpow_plus, <- IZR_Zpower, <- mult_IZR.
+now rewrite Ztrunc_IZR.
now apply Zle_left.
Qed.
-Lemma generic_format_F2R': forall (x:R) (f:float beta),
- F2R f = x -> ((x <> 0)%R ->
- (canonic_exp x <= Fexp f)%Z) ->
- generic_format x.
+Lemma generic_format_F2R' :
+ forall (x : R) (f : float beta),
+ F2R f = x ->
+ (x <> 0%R -> (cexp x <= Fexp f)%Z) ->
+ generic_format x.
Proof.
intros x f H1 H2.
rewrite <- H1; destruct f as (m,e).
-apply generic_format_F2R.
+apply generic_format_F2R.
simpl in *; intros H3.
rewrite H1; apply H2.
intros Y; apply H3.
-apply F2R_eq_0_reg with beta e.
+apply eq_0_F2R with beta e.
now rewrite H1.
Qed.
-
-Theorem canonic_opp :
+Theorem canonical_opp :
forall m e,
- canonic (Float beta m e) ->
- canonic (Float beta (-m) e).
+ canonical (Float beta m e) ->
+ canonical (Float beta (-m) e).
Proof.
intros m e H.
-unfold canonic.
-now rewrite F2R_Zopp, canonic_exp_opp.
+unfold canonical.
+now rewrite F2R_Zopp, cexp_opp.
Qed.
-Theorem canonic_abs :
+Theorem canonical_abs :
forall m e,
- canonic (Float beta m e) ->
- canonic (Float beta (Zabs m) e).
+ canonical (Float beta m e) ->
+ canonical (Float beta (Z.abs m) e).
Proof.
intros m e H.
-unfold canonic.
-now rewrite F2R_Zabs, canonic_exp_abs.
+unfold canonical.
+now rewrite F2R_Zabs, cexp_abs.
Qed.
-Theorem canonic_0: canonic (Float beta 0 (fexp (ln_beta beta 0%R))).
+Theorem canonical_0 :
+ canonical (Float beta 0 (fexp (mag beta 0%R))).
Proof.
-unfold canonic; simpl; unfold canonic_exp.
-replace (F2R {| Fnum := 0; Fexp := fexp (ln_beta beta 0) |}) with 0%R.
-reflexivity.
-unfold F2R; simpl; ring.
+unfold canonical; simpl ; unfold cexp.
+now rewrite F2R_0.
Qed.
-
-
-Theorem canonic_unicity :
+Theorem canonical_unique :
forall f1 f2,
- canonic f1 ->
- canonic f2 ->
+ canonical f1 ->
+ canonical f2 ->
F2R f1 = F2R f2 ->
f1 = f2.
Proof.
intros (m1, e1) (m2, e2).
-unfold canonic. simpl.
+unfold canonical. simpl.
intros H1 H2 H.
rewrite H in H1.
rewrite <- H2 in H1. clear H2.
rewrite H1 in H |- *.
apply (f_equal (fun m => Float beta m e2)).
-apply F2R_eq_reg with (1 := H).
+apply eq_F2R with (1 := H).
Qed.
Theorem scaled_mantissa_generic :
forall x,
generic_format x ->
- scaled_mantissa x = Z2R (Ztrunc (scaled_mantissa x)).
+ scaled_mantissa x = IZR (Ztrunc (scaled_mantissa x)).
Proof.
intros x Hx.
unfold scaled_mantissa.
pattern x at 1 3 ; rewrite Hx.
unfold F2R. simpl.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-now rewrite Ztrunc_Z2R.
+now rewrite Ztrunc_IZR.
Qed.
Theorem scaled_mantissa_mult_bpow :
forall x,
- (scaled_mantissa x * bpow (canonic_exp x))%R = x.
+ (scaled_mantissa x * bpow (cexp x))%R = x.
Proof.
intros x.
unfold scaled_mantissa.
@@ -263,7 +270,7 @@ Theorem scaled_mantissa_opp :
Proof.
intros x.
unfold scaled_mantissa.
-rewrite canonic_exp_opp.
+rewrite cexp_opp.
now rewrite Ropp_mult_distr_l_reverse.
Qed.
@@ -273,7 +280,7 @@ Theorem scaled_mantissa_abs :
Proof.
intros x.
unfold scaled_mantissa.
-rewrite canonic_exp_abs, Rabs_mult.
+rewrite cexp_abs, Rabs_mult.
apply f_equal.
apply sym_eq.
apply Rabs_pos_eq.
@@ -285,7 +292,7 @@ Theorem generic_format_opp :
Proof.
intros x Hx.
unfold generic_format.
-rewrite scaled_mantissa_opp, canonic_exp_opp.
+rewrite scaled_mantissa_opp, cexp_opp.
rewrite Ztrunc_opp.
rewrite F2R_Zopp.
now apply f_equal.
@@ -296,7 +303,7 @@ Theorem generic_format_abs :
Proof.
intros x Hx.
unfold generic_format.
-rewrite scaled_mantissa_abs, canonic_exp_abs.
+rewrite scaled_mantissa_abs, cexp_abs.
rewrite Ztrunc_abs.
rewrite F2R_Zabs.
now apply f_equal.
@@ -308,7 +315,7 @@ Proof.
intros x.
unfold generic_format, Rabs.
case Rcase_abs ; intros _.
-rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp.
+rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp.
intros H.
rewrite <- (Ropp_involutive x) at 1.
rewrite H, F2R_Zopp.
@@ -316,23 +323,23 @@ apply Ropp_involutive.
easy.
Qed.
-Theorem canonic_exp_fexp :
+Theorem cexp_fexp :
forall x ex,
(bpow (ex - 1) <= Rabs x < bpow ex)%R ->
- canonic_exp x = fexp ex.
+ cexp x = fexp ex.
Proof.
intros x ex Hx.
-unfold canonic_exp.
-now rewrite ln_beta_unique with (1 := Hx).
+unfold cexp.
+now rewrite mag_unique with (1 := Hx).
Qed.
-Theorem canonic_exp_fexp_pos :
+Theorem cexp_fexp_pos :
forall x ex,
(bpow (ex - 1) <= x < bpow ex)%R ->
- canonic_exp x = fexp ex.
+ cexp x = fexp ex.
Proof.
intros x ex Hx.
-apply canonic_exp_fexp.
+apply cexp_fexp.
rewrite Rabs_pos_eq.
exact Hx.
apply Rle_trans with (2 := proj1 Hx).
@@ -360,7 +367,7 @@ apply Rlt_le_trans with (1 := proj2 Hx).
now apply bpow_le.
Qed.
-Theorem scaled_mantissa_small :
+Theorem scaled_mantissa_lt_1 :
forall x ex,
(Rabs x < bpow ex)%R ->
(ex <= fexp ex)%Z ->
@@ -369,62 +376,62 @@ Proof.
intros x ex Ex He.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, scaled_mantissa_0, Rabs_R0.
-now apply (Z2R_lt 0 1).
+now apply IZR_lt.
rewrite <- scaled_mantissa_abs.
unfold scaled_mantissa.
-rewrite canonic_exp_abs.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex', Ex').
+rewrite cexp_abs.
+unfold cexp.
+destruct (mag beta x) as (ex', Ex').
simpl.
specialize (Ex' Zx).
apply (mantissa_small_pos _ _ Ex').
assert (ex' <= fexp ex)%Z.
-apply Zle_trans with (2 := He).
+apply Z.le_trans with (2 := He).
apply bpow_lt_bpow with beta.
now apply Rle_lt_trans with (2 := Ex).
now rewrite (proj2 (proj2 (valid_exp _) He)).
Qed.
-Theorem abs_scaled_mantissa_lt_bpow :
+Theorem scaled_mantissa_lt_bpow :
forall x,
- (Rabs (scaled_mantissa x) < bpow (ln_beta beta x - canonic_exp x))%R.
+ (Rabs (scaled_mantissa x) < bpow (mag beta x - cexp x))%R.
Proof.
intros x.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, scaled_mantissa_0, Rabs_R0.
apply bpow_gt_0.
-apply Rlt_le_trans with (1 := bpow_ln_beta_gt beta _).
+apply Rlt_le_trans with (1 := bpow_mag_gt beta _).
apply bpow_le.
unfold scaled_mantissa.
-rewrite ln_beta_mult_bpow with (1 := Zx).
-apply Zle_refl.
+rewrite mag_mult_bpow with (1 := Zx).
+apply Z.le_refl.
Qed.
-Theorem ln_beta_generic_gt :
+Theorem mag_generic_gt :
forall x, (x <> 0)%R ->
generic_format x ->
- (canonic_exp x < ln_beta beta x)%Z.
+ (cexp x < mag beta x)%Z.
Proof.
intros x Zx Gx.
apply Znot_ge_lt.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
+unfold cexp.
+destruct (mag beta x) as (ex,Ex) ; simpl.
specialize (Ex Zx).
intros H.
-apply Zge_le in H.
-generalize (scaled_mantissa_small x ex (proj2 Ex) H).
+apply Z.ge_le in H.
+generalize (scaled_mantissa_lt_1 x ex (proj2 Ex) H).
contradict Zx.
rewrite Gx.
replace (Ztrunc (scaled_mantissa x)) with Z0.
apply F2R_0.
-cut (Zabs (Ztrunc (scaled_mantissa x)) < 1)%Z.
+cut (Z.abs (Ztrunc (scaled_mantissa x)) < 1)%Z.
clear ; zify ; omega.
-apply lt_Z2R.
-rewrite Z2R_abs.
+apply lt_IZR.
+rewrite abs_IZR.
now rewrite <- scaled_mantissa_generic.
Qed.
-Theorem mantissa_DN_small_pos :
+Lemma mantissa_DN_small_pos :
forall x ex,
(bpow (ex - 1) <= x < bpow ex)%R ->
(ex <= fexp ex)%Z ->
@@ -436,7 +443,7 @@ assert (H := mantissa_small_pos x ex Hx He).
split ; try apply Rlt_le ; apply H.
Qed.
-Theorem mantissa_UP_small_pos :
+Lemma mantissa_UP_small_pos :
forall x ex,
(bpow (ex - 1) <= x < bpow ex)%R ->
(ex <= fexp ex)%Z ->
@@ -451,7 +458,7 @@ Qed.
(** Generic facts about any format *)
Theorem generic_format_discrete :
forall x m,
- let e := canonic_exp x in
+ let e := cexp x in
(F2R (Float beta m e) < x < F2R (Float beta (m + 1) e))%R ->
~ generic_format x.
Proof.
@@ -459,27 +466,27 @@ intros x m e (Hx,Hx2) Hf.
apply Rlt_not_le with (1 := Hx2). clear Hx2.
rewrite Hf.
fold e.
-apply F2R_le_compat.
+apply F2R_le.
apply Zlt_le_succ.
-apply lt_Z2R.
+apply lt_IZR.
rewrite <- scaled_mantissa_generic with (1 := Hf).
apply Rmult_lt_reg_r with (bpow e).
apply bpow_gt_0.
now rewrite scaled_mantissa_mult_bpow.
Qed.
-Theorem generic_format_canonic :
- forall f, canonic f ->
+Theorem generic_format_canonical :
+ forall f, canonical f ->
generic_format (F2R f).
Proof.
intros (m, e) Hf.
-unfold canonic in Hf. simpl in Hf.
+unfold canonical in Hf. simpl in Hf.
unfold generic_format, scaled_mantissa.
rewrite <- Hf.
-apply F2R_eq_compat.
+apply F2R_eq.
unfold F2R. simpl.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-now rewrite Ztrunc_Z2R.
+now rewrite Ztrunc_IZR.
Qed.
Theorem generic_format_ge_bpow :
@@ -492,10 +499,10 @@ Theorem generic_format_ge_bpow :
Proof.
intros emin Emin x Hx Fx.
rewrite Fx.
-apply Rle_trans with (bpow (fexp (ln_beta beta x))).
+apply Rle_trans with (bpow (fexp (mag beta x))).
now apply bpow_le.
apply bpow_le_F2R.
-apply F2R_gt_0_reg with beta (canonic_exp x).
+apply gt_0_F2R with beta (cexp x).
now rewrite <- Fx.
Qed.
@@ -504,13 +511,13 @@ Theorem abs_lt_bpow_prec:
(forall e, (e - prec <= fexp e)%Z) ->
(* OK with FLX, FLT and FTZ *)
forall x,
- (Rabs x < bpow (prec + canonic_exp x))%R.
+ (Rabs x < bpow (prec + cexp x))%R.
intros prec Hp x.
case (Req_dec x 0); intros Hxz.
rewrite Hxz, Rabs_R0.
apply bpow_gt_0.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
+unfold cexp.
+destruct (mag beta x) as (ex,Ex) ; simpl.
specialize (Ex Hxz).
apply Rlt_le_trans with (1 := proj2 Ex).
apply bpow_le.
@@ -526,8 +533,8 @@ Proof.
intros e He.
apply Znot_gt_le.
contradict He.
-unfold generic_format, scaled_mantissa, canonic_exp, F2R. simpl.
-rewrite ln_beta_bpow, <- bpow_plus.
+unfold generic_format, scaled_mantissa, cexp, F2R. simpl.
+rewrite mag_bpow, <- bpow_plus.
apply Rgt_not_eq.
rewrite Ztrunc_floor.
2: apply bpow_ge_0.
@@ -559,7 +566,7 @@ Variable rnd : R -> Z.
Class Valid_rnd := {
Zrnd_le : forall x y, (x <= y)%R -> (rnd x <= rnd y)%Z ;
- Zrnd_Z2R : forall n, rnd (Z2R n) = n
+ Zrnd_IZR : forall n, rnd (IZR n) = n
}.
Context { valid_rnd : Valid_rnd }.
@@ -571,20 +578,20 @@ intros x.
destruct (Zle_or_lt (rnd x) (Zfloor x)) as [Hx|Hx].
left.
apply Zle_antisym with (1 := Hx).
-rewrite <- (Zrnd_Z2R (Zfloor x)).
+rewrite <- (Zrnd_IZR (Zfloor x)).
apply Zrnd_le.
apply Zfloor_lb.
right.
apply Zle_antisym.
-rewrite <- (Zrnd_Z2R (Zceil x)).
+rewrite <- (Zrnd_IZR (Zceil x)).
apply Zrnd_le.
apply Zceil_ub.
rewrite Zceil_floor_neq.
omega.
intros H.
rewrite <- H in Hx.
-rewrite Zfloor_Z2R, Zrnd_Z2R in Hx.
-apply Zlt_irrefl with (1 := Hx).
+rewrite Zfloor_IZR, Zrnd_IZR in Hx.
+apply Z.lt_irrefl with (1 := Hx).
Qed.
Theorem Zrnd_ZR_or_AW :
@@ -602,7 +609,7 @@ Qed.
(** the most useful one: R -> F *)
Definition round x :=
- F2R (Float beta (rnd (scaled_mantissa x)) (canonic_exp x)).
+ F2R (Float beta (rnd (scaled_mantissa x)) (cexp x)).
Theorem round_bounded_large_pos :
forall x ex,
@@ -612,7 +619,7 @@ Theorem round_bounded_large_pos :
Proof.
intros x ex He Hx.
unfold round, scaled_mantissa.
-rewrite (canonic_exp_fexp_pos _ _ Hx).
+rewrite (cexp_fexp_pos _ _ Hx).
unfold F2R. simpl.
destruct (Zrnd_DN_or_UP (x * bpow (- fexp ex))) as [Hr|Hr] ; rewrite Hr.
(* DN *)
@@ -621,11 +628,11 @@ replace (ex - 1)%Z with (ex - 1 + - fexp ex + fexp ex)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-assert (Hf: Z2R (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)).
-apply Z2R_Zpower.
+assert (Hf: IZR (Zpower beta (ex - 1 - fexp ex)) = bpow (ex - 1 + - fexp ex)).
+apply IZR_Zpower.
omega.
rewrite <- Hf.
-apply Z2R_le.
+apply IZR_le.
apply Zfloor_lub.
rewrite Hf.
rewrite bpow_plus.
@@ -648,11 +655,11 @@ pattern ex at 3 ; replace ex with (ex - fexp ex + fexp ex)%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-assert (Hf: Z2R (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)).
-apply Z2R_Zpower.
+assert (Hf: IZR (Zpower beta (ex - fexp ex)) = bpow (ex - fexp ex)).
+apply IZR_Zpower.
omega.
rewrite <- Hf.
-apply Z2R_le.
+apply IZR_le.
apply Zceil_glb.
rewrite Hf.
unfold Zminus.
@@ -671,13 +678,13 @@ Theorem round_bounded_small_pos :
Proof.
intros x ex He Hx.
unfold round, scaled_mantissa.
-rewrite (canonic_exp_fexp_pos _ _ Hx).
+rewrite (cexp_fexp_pos _ _ Hx).
unfold F2R. simpl.
destruct (Zrnd_DN_or_UP (x * bpow (-fexp ex))) as [Hr|Hr] ; rewrite Hr.
(* DN *)
left.
apply Rmult_eq_0_compat_r.
-apply (@f_equal _ _ Z2R _ Z0).
+apply IZR_eq.
apply Zfloor_imp.
refine (let H := _ in conj (Rlt_le _ _ (proj1 H)) (proj2 H)).
now apply mantissa_small_pos.
@@ -685,18 +692,18 @@ now apply mantissa_small_pos.
right.
pattern (bpow (fexp ex)) at 2 ; rewrite <- Rmult_1_l.
apply (f_equal (fun m => (m * bpow (fexp ex))%R)).
-apply (@f_equal _ _ Z2R _ 1%Z).
+apply IZR_eq.
apply Zceil_imp.
refine (let H := _ in conj (proj1 H) (Rlt_le _ _ (proj2 H))).
now apply mantissa_small_pos.
Qed.
-Theorem round_le_pos :
+Lemma round_le_pos :
forall x y, (0 < x)%R -> (x <= y)%R -> (round x <= round y)%R.
Proof.
intros x y Hx Hxy.
-destruct (ln_beta beta x) as [ex Hex].
-destruct (ln_beta beta y) as [ey Hey].
+destruct (mag beta x) as [ex Hex].
+destruct (mag beta y) as [ey Hey].
specialize (Hex (Rgt_not_eq _ _ Hx)).
specialize (Hey (Rgt_not_eq _ _ (Rlt_le_trans _ _ _ Hx Hxy))).
rewrite Rabs_pos_eq in Hex.
@@ -709,18 +716,18 @@ assert (He: (ex <= ey)%Z).
now apply Rle_lt_trans with y.
assert (Heq: fexp ex = fexp ey -> (round x <= round y)%R).
intros H.
- unfold round, scaled_mantissa, canonic_exp.
- rewrite ln_beta_unique_pos with (1 := Hex).
- rewrite ln_beta_unique_pos with (1 := Hey).
+ unfold round, scaled_mantissa, cexp.
+ rewrite mag_unique_pos with (1 := Hex).
+ rewrite mag_unique_pos with (1 := Hey).
rewrite H.
- apply F2R_le_compat.
+ apply F2R_le.
apply Zrnd_le.
apply Rmult_le_compat_r with (2 := Hxy).
apply bpow_ge_0.
destruct (Zle_or_lt ey (fexp ey)) as [Hy1|Hy1].
apply Heq.
apply valid_exp with (1 := Hy1).
- now apply Zle_trans with ey.
+ now apply Z.le_trans with ey.
destruct (Zle_lt_or_eq _ _ He) as [He'|He'].
2: now apply Heq, f_equal.
apply Rle_trans with (bpow (ey - 1)).
@@ -746,7 +753,7 @@ Proof.
intros x Hx.
unfold round.
rewrite scaled_mantissa_generic with (1 := Hx).
-rewrite Zrnd_Z2R.
+rewrite Zrnd_IZR.
now apply sym_eq.
Qed.
@@ -755,8 +762,7 @@ Theorem round_0 :
Proof.
unfold round, scaled_mantissa.
rewrite Rmult_0_l.
-change 0%R with (Z2R 0).
-rewrite Zrnd_Z2R.
+rewrite Zrnd_IZR.
apply F2R_0.
Qed.
@@ -774,13 +780,13 @@ apply bpow_gt_0.
apply (round_bounded_large_pos); assumption.
Qed.
-Theorem generic_format_round_pos :
+Lemma generic_format_round_pos :
forall x,
(0 < x)%R ->
generic_format (round x).
Proof.
intros x Hx0.
-destruct (ln_beta beta x) as (ex, Hex).
+destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx0)).
rewrite Rabs_pos_eq in Hex. 2: now apply Rlt_le.
destruct (Zle_or_lt ex (fexp ex)) as [He|He].
@@ -798,8 +804,8 @@ apply generic_format_bpow.
now apply valid_exp.
apply generic_format_F2R.
intros _.
-rewrite (canonic_exp_fexp_pos (F2R _) _ (conj Hr1 Hr)).
-rewrite (canonic_exp_fexp_pos _ _ Hex).
+rewrite (cexp_fexp_pos (F2R _) _ (conj Hr1 Hr)).
+rewrite (cexp_fexp_pos _ _ Hex).
now apply Zeq_le.
Qed.
@@ -821,7 +827,7 @@ Section Zround_opp.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Definition Zrnd_opp x := Zopp (rnd (-x)).
+Definition Zrnd_opp x := Z.opp (rnd (-x)).
Global Instance valid_rnd_opp : Valid_rnd Zrnd_opp.
Proof with auto with typeclass_instances.
@@ -830,14 +836,14 @@ split.
intros x y Hxy.
unfold Zrnd_opp.
apply Zopp_le_cancel.
-rewrite 2!Zopp_involutive.
+rewrite 2!Z.opp_involutive.
apply Zrnd_le...
now apply Ropp_le_contravar.
(* *)
intros n.
unfold Zrnd_opp.
-rewrite <- Z2R_opp, Zrnd_Z2R...
-apply Zopp_involutive.
+rewrite <- opp_IZR, Zrnd_IZR...
+apply Z.opp_involutive.
Qed.
Theorem round_opp :
@@ -846,10 +852,10 @@ Theorem round_opp :
Proof.
intros x.
unfold round.
-rewrite <- F2R_Zopp, canonic_exp_opp, scaled_mantissa_opp.
-apply F2R_eq_compat.
+rewrite <- F2R_Zopp, cexp_opp, scaled_mantissa_opp.
+apply F2R_eq.
apply sym_eq.
-exact (Zopp_involutive _).
+exact (Z.opp_involutive _).
Qed.
End Zround_opp.
@@ -860,28 +866,28 @@ Global Instance valid_rnd_DN : Valid_rnd Zfloor.
Proof.
split.
apply Zfloor_le.
-apply Zfloor_Z2R.
+apply Zfloor_IZR.
Qed.
Global Instance valid_rnd_UP : Valid_rnd Zceil.
Proof.
split.
apply Zceil_le.
-apply Zceil_Z2R.
+apply Zceil_IZR.
Qed.
Global Instance valid_rnd_ZR : Valid_rnd Ztrunc.
Proof.
split.
apply Ztrunc_le.
-apply Ztrunc_Z2R.
+apply Ztrunc_IZR.
Qed.
Global Instance valid_rnd_AW : Valid_rnd Zaway.
Proof.
split.
apply Zaway_le.
-apply Zaway_Z2R.
+apply Zaway_IZR.
Qed.
Section monotone.
@@ -923,7 +929,7 @@ destruct (Rlt_or_le y 0) as [Hy|Hy].
(* . y < 0 *)
rewrite <- (Ropp_involutive x), <- (Ropp_involutive y).
rewrite (scaled_mantissa_opp (-x)), (scaled_mantissa_opp (-y)).
-rewrite (canonic_exp_opp (-x)), (canonic_exp_opp (-y)).
+rewrite (cexp_opp (-x)), (cexp_opp (-y)).
apply Ropp_le_cancel.
rewrite <- 2!F2R_Zopp.
apply (round_le_pos (Zrnd_opp rnd) (-y) (-x)).
@@ -932,16 +938,16 @@ now apply Ropp_lt_contravar.
now apply Ropp_le_contravar.
(* . 0 <= y *)
apply Rle_trans with 0%R.
-apply F2R_le_0_compat. simpl.
-rewrite <- (Zrnd_Z2R rnd 0).
+apply F2R_le_0. simpl.
+rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
simpl.
-rewrite <- (Rmult_0_l (bpow (- fexp (ln_beta beta x)))).
+rewrite <- (Rmult_0_l (bpow (- fexp (mag beta x)))).
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply Rlt_le.
-apply F2R_ge_0_compat. simpl.
-rewrite <- (Zrnd_Z2R rnd 0).
+apply F2R_ge_0. simpl.
+rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rmult_le_pos.
exact Hy.
@@ -949,9 +955,9 @@ apply bpow_ge_0.
(* x = 0 *)
rewrite Hx.
rewrite round_0...
-apply F2R_ge_0_compat.
+apply F2R_ge_0.
simpl.
-rewrite <- (Zrnd_Z2R rnd 0).
+rewrite <- (Zrnd_IZR rnd 0).
apply Zrnd_le...
apply Rmult_le_pos.
now rewrite <- Hx.
@@ -1071,8 +1077,8 @@ unfold round.
rewrite scaled_mantissa_opp.
rewrite <- F2R_Zopp.
unfold Zceil.
-rewrite Zopp_involutive.
-now rewrite canonic_exp_opp.
+rewrite Z.opp_involutive.
+now rewrite cexp_opp.
Qed.
Theorem round_UP_opp :
@@ -1085,7 +1091,7 @@ rewrite scaled_mantissa_opp.
rewrite <- F2R_Zopp.
unfold Zceil.
rewrite Ropp_involutive.
-now rewrite canonic_exp_opp.
+now rewrite cexp_opp.
Qed.
Theorem round_ZR_opp :
@@ -1094,7 +1100,7 @@ Theorem round_ZR_opp :
Proof.
intros x.
unfold round.
-rewrite scaled_mantissa_opp, canonic_exp_opp, Ztrunc_opp.
+rewrite scaled_mantissa_opp, cexp_opp, Ztrunc_opp.
apply F2R_Zopp.
Qed.
@@ -1123,7 +1129,7 @@ Theorem round_AW_opp :
Proof.
intros x.
unfold round.
-rewrite scaled_mantissa_opp, canonic_exp_opp, Zaway_opp.
+rewrite scaled_mantissa_opp, cexp_opp, Zaway_opp.
apply F2R_Zopp.
Qed.
@@ -1146,7 +1152,7 @@ apply round_le...
now apply Rge_le.
Qed.
-Theorem round_ZR_pos :
+Theorem round_ZR_DN :
forall x,
(0 <= x)%R ->
round Ztrunc x = round Zfloor x.
@@ -1156,13 +1162,13 @@ unfold round, Ztrunc.
case Rlt_bool_spec.
intros H.
elim Rlt_not_le with (1 := H).
-rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
+rewrite <- (Rmult_0_l (bpow (- cexp x))).
apply Rmult_le_compat_r with (2 := Hx).
apply bpow_ge_0.
easy.
Qed.
-Theorem round_ZR_neg :
+Theorem round_ZR_UP :
forall x,
(x <= 0)%R ->
round Ztrunc x = round Zceil x.
@@ -1173,15 +1179,14 @@ case Rlt_bool_spec.
easy.
intros [H|H].
elim Rlt_not_le with (1 := H).
-rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
+rewrite <- (Rmult_0_l (bpow (- cexp x))).
apply Rmult_le_compat_r with (2 := Hx).
apply bpow_ge_0.
rewrite <- H.
-change 0%R with (Z2R 0).
-now rewrite Zfloor_Z2R, Zceil_Z2R.
+now rewrite Zfloor_IZR, Zceil_IZR.
Qed.
-Theorem round_AW_pos :
+Theorem round_AW_UP :
forall x,
(0 <= x)%R ->
round Zaway x = round Zceil x.
@@ -1191,13 +1196,13 @@ unfold round, Zaway.
case Rlt_bool_spec.
intros H.
elim Rlt_not_le with (1 := H).
-rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
+rewrite <- (Rmult_0_l (bpow (- cexp x))).
apply Rmult_le_compat_r with (2 := Hx).
apply bpow_ge_0.
easy.
Qed.
-Theorem round_AW_neg :
+Theorem round_AW_DN :
forall x,
(x <= 0)%R ->
round Zaway x = round Zfloor x.
@@ -1208,12 +1213,11 @@ case Rlt_bool_spec.
easy.
intros [H|H].
elim Rlt_not_le with (1 := H).
-rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
+rewrite <- (Rmult_0_l (bpow (- cexp x))).
apply Rmult_le_compat_r with (2 := Hx).
apply bpow_ge_0.
rewrite <- H.
-change 0%R with (Z2R 0).
-now rewrite Zfloor_Z2R, Zceil_Z2R.
+now rewrite Zfloor_IZR, Zceil_IZR.
Qed.
Theorem generic_format_round :
@@ -1275,7 +1279,7 @@ Proof.
intros x.
rewrite <- (Ropp_involutive x).
rewrite round_UP_opp.
-apply Rnd_DN_UP_pt_sym.
+apply Rnd_UP_pt_opp.
apply generic_format_opp.
apply round_DN_pt.
Qed.
@@ -1286,22 +1290,22 @@ Theorem round_ZR_pt :
Proof.
intros x.
split ; intros Hx.
-rewrite round_ZR_pos with (1 := Hx).
+rewrite round_ZR_DN with (1 := Hx).
apply round_DN_pt.
-rewrite round_ZR_neg with (1 := Hx).
+rewrite round_ZR_UP with (1 := Hx).
apply round_UP_pt.
Qed.
-Theorem round_DN_small_pos :
+Lemma round_DN_small_pos :
forall x ex,
(bpow (ex - 1) <= x < bpow ex)%R ->
(ex <= fexp ex)%Z ->
round Zfloor x = 0%R.
Proof.
intros x ex Hx He.
-rewrite <- (F2R_0 beta (canonic_exp x)).
+rewrite <- (F2R_0 beta (cexp x)).
rewrite <- mantissa_DN_small_pos with (1 := Hx) (2 := He).
-now rewrite <- canonic_exp_fexp_pos with (1 := Hx).
+now rewrite <- cexp_fexp_pos with (1 := Hx).
Qed.
@@ -1329,7 +1333,7 @@ contradict Fx.
apply generic_format_round...
Qed.
-Theorem round_UP_small_pos :
+Lemma round_UP_small_pos :
forall x ex,
(bpow (ex - 1) <= x < bpow ex)%R ->
(ex <= fexp ex)%Z ->
@@ -1338,7 +1342,7 @@ Proof.
intros x ex Hx He.
rewrite <- F2R_bpow.
rewrite <- mantissa_UP_small_pos with (1 := Hx) (2 := He).
-now rewrite <- canonic_exp_fexp_pos with (1 := Hx).
+now rewrite <- cexp_fexp_pos with (1 := Hx).
Qed.
Theorem generic_format_EM :
@@ -1361,14 +1365,14 @@ Section round_large.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Theorem round_large_pos_ge_pow :
+Lemma round_large_pos_ge_bpow :
forall x e,
(0 < round rnd x)%R ->
(bpow e <= x)%R ->
(bpow e <= round rnd x)%R.
Proof.
intros x e Hd Hex.
-destruct (ln_beta beta x) as (ex, He).
+destruct (mag beta x) as (ex, He).
assert (Hx: (0 < x)%R).
apply Rlt_le_trans with (2 := Hex).
apply bpow_gt_0.
@@ -1391,95 +1395,95 @@ Qed.
End round_large.
-Theorem ln_beta_round_ZR :
+Theorem mag_round_ZR :
forall x,
(round Ztrunc x <> 0)%R ->
- (ln_beta beta (round Ztrunc x) = ln_beta beta x :> Z).
+ (mag beta (round Ztrunc x) = mag beta x :> Z).
Proof with auto with typeclass_instances.
intros x Zr.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, round_0...
-apply ln_beta_unique.
-destruct (ln_beta beta x) as (ex, Ex) ; simpl.
+apply mag_unique.
+destruct (mag beta x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
rewrite <- round_ZR_abs.
split.
-apply round_large_pos_ge_pow...
+apply round_large_pos_ge_bpow...
rewrite round_ZR_abs.
now apply Rabs_pos_lt.
apply Ex.
apply Rle_lt_trans with (2 := proj2 Ex).
-rewrite round_ZR_pos.
+rewrite round_ZR_DN.
apply round_DN_pt.
apply Rabs_pos.
Qed.
-Theorem ln_beta_round :
+Theorem mag_round :
forall rnd {Hrnd : Valid_rnd rnd} x,
(round rnd x <> 0)%R ->
- (ln_beta beta (round rnd x) = ln_beta beta x :> Z) \/
- Rabs (round rnd x) = bpow (Zmax (ln_beta beta x) (fexp (ln_beta beta x))).
+ (mag beta (round rnd x) = mag beta x :> Z) \/
+ Rabs (round rnd x) = bpow (Z.max (mag beta x) (fexp (mag beta x))).
Proof with auto with typeclass_instances.
intros rnd Hrnd x.
destruct (round_ZR_or_AW rnd x) as [Hr|Hr] ; rewrite Hr ; clear Hr rnd Hrnd.
left.
-now apply ln_beta_round_ZR.
+now apply mag_round_ZR.
intros Zr.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, round_0...
-destruct (ln_beta beta x) as (ex, Ex) ; simpl.
+destruct (mag beta x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
-rewrite <- ln_beta_abs.
+rewrite <- mag_abs.
rewrite <- round_AW_abs.
destruct (Zle_or_lt ex (fexp ex)) as [He|He].
right.
-rewrite Zmax_r with (1 := He).
-rewrite round_AW_pos with (1 := Rabs_pos _).
+rewrite Z.max_r with (1 := He).
+rewrite round_AW_UP with (1 := Rabs_pos _).
now apply round_UP_small_pos.
destruct (round_bounded_large_pos Zaway _ ex He Ex) as (H1,[H2|H2]).
left.
-apply ln_beta_unique.
+apply mag_unique.
rewrite <- round_AW_abs, Rabs_Rabsolu.
now split.
right.
-now rewrite Zmax_l with (1 := Zlt_le_weak _ _ He).
+now rewrite Z.max_l with (1 := Zlt_le_weak _ _ He).
Qed.
-Theorem ln_beta_DN :
+Theorem mag_DN :
forall x,
(0 < round Zfloor x)%R ->
- (ln_beta beta (round Zfloor x) = ln_beta beta x :> Z).
+ (mag beta (round Zfloor x) = mag beta x :> Z).
Proof.
intros x Hd.
assert (0 < x)%R.
apply Rlt_le_trans with (1 := Hd).
apply round_DN_pt.
revert Hd.
-rewrite <- round_ZR_pos.
+rewrite <- round_ZR_DN.
intros Hd.
-apply ln_beta_round_ZR.
+apply mag_round_ZR.
now apply Rgt_not_eq.
now apply Rlt_le.
Qed.
-Theorem canonic_exp_DN :
+Theorem cexp_DN :
forall x,
(0 < round Zfloor x)%R ->
- canonic_exp (round Zfloor x) = canonic_exp x.
+ cexp (round Zfloor x) = cexp x.
Proof.
intros x Hd.
apply (f_equal fexp).
-now apply ln_beta_DN.
+now apply mag_DN.
Qed.
Theorem scaled_mantissa_DN :
forall x,
(0 < round Zfloor x)%R ->
- scaled_mantissa (round Zfloor x) = Z2R (Zfloor (scaled_mantissa x)).
+ scaled_mantissa (round Zfloor x) = IZR (Zfloor (scaled_mantissa x)).
Proof.
intros x Hd.
unfold scaled_mantissa.
-rewrite canonic_exp_DN with (1 := Hd).
+rewrite cexp_DN with (1 := Hd).
unfold round, F2R. simpl.
now rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
Qed.
@@ -1492,10 +1496,10 @@ Proof.
intros x f Hxf.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf).
left.
-apply Rnd_DN_pt_unicity with (1 := H).
+apply Rnd_DN_pt_unique with (1 := H).
apply round_DN_pt.
right.
-apply Rnd_UP_pt_unicity with (1 := H).
+apply Rnd_UP_pt_unique with (1 := H).
apply round_UP_pt.
Qed.
@@ -1516,20 +1520,20 @@ intros e x He Hx.
pattern x at 2 ; rewrite Hx.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
-assert (H: Z2R (Zpower beta (canonic_exp x + - fexp e)) = bpow (canonic_exp x + - fexp e)).
-apply Z2R_Zpower.
-unfold canonic_exp.
-set (ex := ln_beta beta x).
+assert (H: IZR (Zpower beta (cexp x + - fexp e)) = bpow (cexp x + - fexp e)).
+apply IZR_Zpower.
+unfold cexp.
+set (ex := mag beta x).
generalize (exp_not_FTZ ex).
generalize (proj2 (proj2 (valid_exp _) He) (fexp ex + 1)%Z).
omega.
rewrite <- H.
-rewrite <- Z2R_mult, Ztrunc_Z2R.
+rewrite <- mult_IZR, Ztrunc_IZR.
unfold F2R. simpl.
-rewrite Z2R_mult.
+rewrite mult_IZR.
rewrite H.
rewrite Rmult_assoc, <- bpow_plus.
-now ring_simplify (canonic_exp x + - fexp e + fexp e)%Z.
+now ring_simplify (cexp x + - fexp e + fexp e)%Z.
Qed.
End not_FTZ.
@@ -1550,60 +1554,60 @@ now apply Zlt_le_succ.
now apply valid_exp.
Qed.
-Lemma canonic_exp_le_bpow :
+Lemma cexp_le_bpow :
forall (x : R) (e : Z),
x <> 0%R ->
(Rabs x < bpow e)%R ->
- (canonic_exp x <= fexp e)%Z.
+ (cexp x <= fexp e)%Z.
Proof.
intros x e Zx Hx.
apply monotone_exp.
-now apply ln_beta_le_bpow.
+now apply mag_le_bpow.
Qed.
-Lemma canonic_exp_ge_bpow :
+Lemma cexp_ge_bpow :
forall (x : R) (e : Z),
(bpow (e - 1) <= Rabs x)%R ->
- (fexp e <= canonic_exp x)%Z.
+ (fexp e <= cexp x)%Z.
Proof.
intros x e Hx.
apply monotone_exp.
rewrite (Zsucc_pred e).
apply Zlt_le_succ.
-now apply ln_beta_gt_bpow.
+now apply mag_gt_bpow.
Qed.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Theorem ln_beta_round_ge :
+Theorem mag_round_ge :
forall x,
round rnd x <> 0%R ->
- (ln_beta beta x <= ln_beta beta (round rnd x))%Z.
+ (mag beta x <= mag beta (round rnd x))%Z.
Proof with auto with typeclass_instances.
intros x.
destruct (round_ZR_or_AW rnd x) as [H|H] ; rewrite H ; clear H ; intros Zr.
-rewrite ln_beta_round_ZR with (1 := Zr).
-apply Zle_refl.
-apply ln_beta_le_abs.
+rewrite mag_round_ZR with (1 := Zr).
+apply Z.le_refl.
+apply mag_le_abs.
contradict Zr.
rewrite Zr.
apply round_0...
rewrite <- round_AW_abs.
-rewrite round_AW_pos.
+rewrite round_AW_UP.
apply round_UP_pt.
apply Rabs_pos.
Qed.
-Theorem canonic_exp_round_ge :
+Theorem cexp_round_ge :
forall x,
round rnd x <> 0%R ->
- (canonic_exp x <= canonic_exp (round rnd x))%Z.
+ (cexp x <= cexp (round rnd x))%Z.
Proof with auto with typeclass_instances.
intros x Zr.
-unfold canonic_exp.
+unfold cexp.
apply monotone_exp.
-now apply ln_beta_round_ge.
+now apply mag_round_ge.
Qed.
End monotone_exp.
@@ -1614,7 +1618,7 @@ Section Znearest.
Variable choice : Z -> bool.
Definition Znearest x :=
- match Rcompare (x - Z2R (Zfloor x)) (/2) with
+ match Rcompare (x - IZR (Zfloor x)) (/2) with
| Lt => Zfloor x
| Eq => if choice (Zfloor x) then Zceil x else Zfloor x
| Gt => Zceil x
@@ -1640,8 +1644,8 @@ Theorem Znearest_ge_floor :
Proof.
intros x.
destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx.
-apply Zle_refl.
-apply le_Z2R.
+apply Z.le_refl.
+apply le_IZR.
apply Rle_trans with x.
apply Zfloor_lb.
apply Zceil_ub.
@@ -1653,11 +1657,11 @@ Theorem Znearest_le_ceil :
Proof.
intros x.
destruct (Znearest_DN_or_UP x) as [Hx|Hx] ; rewrite Hx.
-apply le_Z2R.
+apply le_IZR.
apply Rle_trans with x.
apply Zfloor_lb.
apply Zceil_ub.
-apply Zle_refl.
+apply Z.le_refl.
Qed.
Global Instance valid_rnd_N : Valid_rnd Znearest.
@@ -1665,22 +1669,22 @@ Proof.
split.
(* *)
intros x y Hxy.
-destruct (Rle_or_lt (Z2R (Zceil x)) y) as [H|H].
-apply Zle_trans with (1 := Znearest_le_ceil x).
-apply Zle_trans with (2 := Znearest_ge_floor y).
+destruct (Rle_or_lt (IZR (Zceil x)) y) as [H|H].
+apply Z.le_trans with (1 := Znearest_le_ceil x).
+apply Z.le_trans with (2 := Znearest_ge_floor y).
now apply Zfloor_lub.
(* . *)
assert (Hf: Zfloor y = Zfloor x).
apply Zfloor_imp.
split.
apply Rle_trans with (2 := Zfloor_lb y).
-apply Z2R_le.
+apply IZR_le.
now apply Zfloor_le.
apply Rlt_le_trans with (1 := H).
-apply Z2R_le.
+apply IZR_le.
apply Zceil_glb.
apply Rlt_le.
-rewrite Z2R_plus.
+rewrite plus_IZR.
apply Zfloor_ub.
(* . *)
unfold Znearest at 1.
@@ -1696,15 +1700,15 @@ elim Rlt_not_le with (1 := Hy).
rewrite <- Hx.
now apply Rplus_le_compat_r.
replace y with x.
-apply Zle_refl.
-apply Rplus_eq_reg_l with (- Z2R (Zfloor x))%R.
-rewrite 2!(Rplus_comm (- (Z2R (Zfloor x)))).
-change (x - Z2R (Zfloor x) = y - Z2R (Zfloor x))%R.
+apply Z.le_refl.
+apply Rplus_eq_reg_l with (- IZR (Zfloor x))%R.
+rewrite 2!(Rplus_comm (- (IZR (Zfloor x)))).
+change (x - IZR (Zfloor x) = y - IZR (Zfloor x))%R.
now rewrite Hy.
-apply Zle_trans with (Zceil x).
+apply Z.le_trans with (Zceil x).
case choice.
-apply Zle_refl.
-apply le_Z2R.
+apply Z.le_refl.
+apply le_IZR.
apply Rle_trans with x.
apply Zfloor_lb.
apply Zceil_ub.
@@ -1719,79 +1723,19 @@ now apply Rplus_le_compat_r.
(* *)
intros n.
unfold Znearest.
-rewrite Zfloor_Z2R.
+rewrite Zfloor_IZR.
rewrite Rcompare_Lt.
easy.
unfold Rminus.
rewrite Rplus_opp_r.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
-Qed.
-
-Theorem Rcompare_floor_ceil_mid :
- forall x,
- Z2R (Zfloor x) <> x ->
- Rcompare (x - Z2R (Zfloor x)) (/ 2) = Rcompare (x - Z2R (Zfloor x)) (Z2R (Zceil x) - x).
-Proof.
-intros x Hx.
-rewrite Zceil_floor_neq with (1 := Hx).
-rewrite Z2R_plus. simpl.
-destruct (Rcompare_spec (x - Z2R (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
-(* . *)
-apply Rcompare_Lt.
-apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R.
-replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring.
-replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
-apply Rmult_lt_compat_r with (2 := H1).
-now apply (Z2R_lt 0 2).
-(* . *)
-apply Rcompare_Eq.
-replace (Z2R (Zfloor x) + 1 - x)%R with (1 - (x - Z2R (Zfloor x)))%R by ring.
-rewrite H1.
-field.
-(* . *)
-apply Rcompare_Gt.
-apply Rplus_lt_reg_l with (x - Z2R (Zfloor x))%R.
-replace (x - Z2R (Zfloor x) + (x - Z2R (Zfloor x)))%R with ((x - Z2R (Zfloor x)) * 2)%R by ring.
-replace (x - Z2R (Zfloor x) + (Z2R (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
-apply Rmult_lt_compat_r with (2 := H1).
-now apply (Z2R_lt 0 2).
-Qed.
-
-Theorem Rcompare_ceil_floor_mid :
- forall x,
- Z2R (Zfloor x) <> x ->
- Rcompare (Z2R (Zceil x) - x) (/ 2) = Rcompare (Z2R (Zceil x) - x) (x - Z2R (Zfloor x)).
-Proof.
-intros x Hx.
-rewrite Zceil_floor_neq with (1 := Hx).
-rewrite Z2R_plus. simpl.
-destruct (Rcompare_spec (Z2R (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
-(* . *)
-apply Rcompare_Lt.
-apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R.
-replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring.
-replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field.
-apply Rmult_lt_compat_r with (2 := H1).
-now apply (Z2R_lt 0 2).
-(* . *)
-apply Rcompare_Eq.
-replace (x - Z2R (Zfloor x))%R with (1 - (Z2R (Zfloor x) + 1 - x))%R by ring.
-rewrite H1.
-field.
-(* . *)
-apply Rcompare_Gt.
-apply Rplus_lt_reg_l with (Z2R (Zfloor x) + 1 - x)%R.
-replace (Z2R (Zfloor x) + 1 - x + (Z2R (Zfloor x) + 1 - x))%R with ((Z2R (Zfloor x) + 1 - x) * 2)%R by ring.
-replace (Z2R (Zfloor x) + 1 - x + (x - Z2R (Zfloor x)))%R with (/2 * 2)%R by field.
-apply Rmult_lt_compat_r with (2 := H1).
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
Qed.
Theorem Znearest_N_strict :
forall x,
- (x - Z2R (Zfloor x) <> /2)%R ->
- (Rabs (x - Z2R (Znearest x)) < /2)%R.
+ (x - IZR (Zfloor x) <> /2)%R ->
+ (Rabs (x - IZR (Znearest x)) < /2)%R.
Proof.
intros x Hx.
unfold Znearest.
@@ -1804,72 +1748,70 @@ now elim Hx.
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
rewrite Zceil_floor_neq.
-rewrite Z2R_plus.
-simpl.
+rewrite plus_IZR.
apply Ropp_lt_cancel.
apply Rplus_lt_reg_l with 1%R.
replace (1 + -/2)%R with (/2)%R by field.
-now replace (1 + - (Z2R (Zfloor x) + 1 - x))%R with (x - Z2R (Zfloor x))%R by ring.
+now replace (1 + - (IZR (Zfloor x) + 1 - x))%R with (x - IZR (Zfloor x))%R by ring.
apply Rlt_not_eq.
-apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R.
+apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R.
apply Rlt_trans with (/2)%R.
rewrite Rplus_opp_l.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
now rewrite <- (Rplus_comm x).
apply Rle_minus.
apply Zceil_ub.
Qed.
-Theorem Znearest_N :
+Theorem Znearest_half :
forall x,
- (Rabs (x - Z2R (Znearest x)) <= /2)%R.
+ (Rabs (x - IZR (Znearest x)) <= /2)%R.
Proof.
intros x.
-destruct (Req_dec (x - Z2R (Zfloor x)) (/2)) as [Hx|Hx].
+destruct (Req_dec (x - IZR (Zfloor x)) (/2)) as [Hx|Hx].
assert (K: (Rabs (/2) <= /2)%R).
apply Req_le.
apply Rabs_pos_eq.
apply Rlt_le.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
destruct (Znearest_DN_or_UP x) as [H|H] ; rewrite H ; clear H.
now rewrite Hx.
rewrite Zceil_floor_neq.
-rewrite Z2R_plus.
-simpl.
-replace (x - (Z2R (Zfloor x) + 1))%R with (x - Z2R (Zfloor x) - 1)%R by ring.
+rewrite plus_IZR.
+replace (x - (IZR (Zfloor x) + 1))%R with (x - IZR (Zfloor x) - 1)%R by ring.
rewrite Hx.
rewrite Rabs_minus_sym.
now replace (1 - /2)%R with (/2)%R by field.
apply Rlt_not_eq.
-apply Rplus_lt_reg_l with (- Z2R (Zfloor x))%R.
+apply Rplus_lt_reg_l with (- IZR (Zfloor x))%R.
rewrite Rplus_opp_l, Rplus_comm.
-fold (x - Z2R (Zfloor x))%R.
+fold (x - IZR (Zfloor x))%R.
rewrite Hx.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply Rlt_le.
now apply Znearest_N_strict.
Qed.
Theorem Znearest_imp :
forall x n,
- (Rabs (x - Z2R n) < /2)%R ->
+ (Rabs (x - IZR n) < /2)%R ->
Znearest x = n.
Proof.
intros x n Hd.
-cut (Zabs (Znearest x - n) < 1)%Z.
+cut (Z.abs (Znearest x - n) < 1)%Z.
clear ; zify ; omega.
-apply lt_Z2R.
-rewrite Z2R_abs, Z2R_minus.
-replace (Z2R (Znearest x) - Z2R n)%R with (- (x - Z2R (Znearest x)) + (x - Z2R n))%R by ring.
+apply lt_IZR.
+rewrite abs_IZR, minus_IZR.
+replace (IZR (Znearest x) - IZR n)%R with (- (x - IZR (Znearest x)) + (x - IZR n))%R by ring.
apply Rle_lt_trans with (1 := Rabs_triang _ _).
simpl.
replace 1%R with (/2 + /2)%R by field.
apply Rplus_le_lt_compat with (2 := Hd).
rewrite Rabs_Ropp.
-apply Znearest_N.
+apply Znearest_half.
Qed.
Theorem round_N_pt :
@@ -1880,7 +1822,7 @@ intros x.
set (d := round Zfloor x).
set (u := round Zceil x).
set (mx := scaled_mantissa x).
-set (bx := bpow (canonic_exp x)).
+set (bx := bpow (cexp x)).
(* . *)
assert (H: (Rabs (round Znearest x - x) <= Rmin (x - d) (u - x))%R).
pattern x at -1 ; rewrite <- scaled_mantissa_mult_bpow.
@@ -1892,7 +1834,7 @@ rewrite <- Rmult_min_distr_r. 2: apply bpow_ge_0.
apply Rmult_le_compat_r.
apply bpow_ge_0.
unfold Znearest.
-destruct (Req_dec (Z2R (Zfloor mx)) mx) as [Hm|Hm].
+destruct (Req_dec (IZR (Zfloor mx)) mx) as [Hm|Hm].
(* .. *)
rewrite Hm.
unfold Rminus at 2.
@@ -1903,16 +1845,16 @@ unfold Rminus at -3.
rewrite Rplus_opp_r.
rewrite Rabs_R0.
unfold Rmin.
-destruct (Rle_dec 0 (Z2R (Zceil mx) - mx)) as [H|H].
+destruct (Rle_dec 0 (IZR (Zceil mx) - mx)) as [H|H].
apply Rle_refl.
apply Rle_0_minus.
apply Zceil_ub.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
(* .. *)
-rewrite Rcompare_floor_ceil_mid with (1 := Hm).
+rewrite Rcompare_floor_ceil_middle with (1 := Hm).
rewrite Rmin_compare.
-assert (H: (Rabs (mx - Z2R (Zfloor mx)) <= mx - Z2R (Zfloor mx))%R).
+assert (H: (Rabs (mx - IZR (Zfloor mx)) <= mx - IZR (Zfloor mx))%R).
rewrite Rabs_pos_eq.
apply Rle_refl.
apply Rle_0_minus.
@@ -1928,7 +1870,7 @@ apply Rle_refl.
apply Rle_0_minus.
apply Zceil_ub.
(* . *)
-apply Rnd_DN_UP_pt_N with d u.
+apply Rnd_N_pt_DN_UP with d u.
apply generic_format_round.
auto with typeclass_instances.
now apply round_DN_pt.
@@ -1947,63 +1889,63 @@ Proof.
intros x.
pattern x at 1 4 ; rewrite <- scaled_mantissa_mult_bpow.
unfold round, Znearest, F2R. simpl.
-destruct (Req_dec (Z2R (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx].
+destruct (Req_dec (IZR (Zfloor (scaled_mantissa x))) (scaled_mantissa x)) as [Fx|Fx].
(* *)
intros _.
rewrite <- Fx.
-rewrite Zceil_Z2R, Zfloor_Z2R.
+rewrite Zceil_IZR, Zfloor_IZR.
set (m := Zfloor (scaled_mantissa x)).
-now case (Rcompare (Z2R m - Z2R m) (/ 2)) ; case (choice m).
+now case (Rcompare (IZR m - IZR m) (/ 2)) ; case (choice m).
(* *)
intros H.
-rewrite Rcompare_floor_ceil_mid with (1 := Fx).
+rewrite Rcompare_floor_ceil_middle with (1 := Fx).
rewrite Rcompare_Eq.
now case choice.
-apply Rmult_eq_reg_r with (bpow (canonic_exp x)).
+apply Rmult_eq_reg_r with (bpow (cexp x)).
now rewrite 2!Rmult_minus_distr_r.
apply Rgt_not_eq.
apply bpow_gt_0.
Qed.
-Lemma round_N_really_small_pos :
+Lemma round_N_small_pos :
forall x,
forall ex,
- (Fcore_Raux.bpow beta (ex - 1) <= x < Fcore_Raux.bpow beta ex)%R ->
+ (Raux.bpow beta (ex - 1) <= x < Raux.bpow beta ex)%R ->
(ex < fexp ex)%Z ->
(round Znearest x = 0)%R.
Proof.
intros x ex Hex Hf.
-unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
-apply (Rmult_eq_reg_r (bpow (- fexp (ln_beta beta x))));
+unfold round, F2R, scaled_mantissa, cexp; simpl.
+apply (Rmult_eq_reg_r (bpow (- fexp (mag beta x))));
[|now apply Rgt_not_eq; apply bpow_gt_0].
rewrite Rmult_0_l, Rmult_assoc, <- bpow_plus.
replace (_ + - _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r.
-change 0%R with (Z2R 0); apply f_equal.
+apply IZR_eq.
apply Znearest_imp.
-simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
+unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
assert (H : (x >= 0)%R).
{ apply Rle_ge; apply Rle_trans with (bpow (ex - 1)); [|exact (proj1 Hex)].
now apply bpow_ge_0. }
-assert (H' : (x * bpow (- fexp (ln_beta beta x)) >= 0)%R).
+assert (H' : (x * bpow (- fexp (mag beta x)) >= 0)%R).
{ apply Rle_ge; apply Rmult_le_pos.
- now apply Rge_le.
- now apply bpow_ge_0. }
rewrite Rabs_right; [|exact H'].
-apply (Rmult_lt_reg_r (bpow (fexp (ln_beta beta x)))); [now apply bpow_gt_0|].
+apply (Rmult_lt_reg_r (bpow (fexp (mag beta x)))); [now apply bpow_gt_0|].
rewrite Rmult_assoc, <- bpow_plus.
replace (- _ + _)%Z with 0%Z by ring; simpl; rewrite Rmult_1_r.
apply (Rlt_le_trans _ _ _ (proj2 Hex)).
-apply Rle_trans with (bpow (fexp (ln_beta beta x) - 1)).
+apply Rle_trans with (bpow (fexp (mag beta x) - 1)).
- apply bpow_le.
- rewrite (ln_beta_unique beta x ex); [omega|].
+ rewrite (mag_unique beta x ex); [omega|].
now rewrite Rabs_right.
- unfold Zminus; rewrite bpow_plus.
rewrite Rmult_comm.
apply Rmult_le_compat_r; [now apply bpow_ge_0|].
- unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r.
apply Rinv_le; [exact Rlt_0_2|].
- change 2%R with (Z2R 2); apply Z2R_le.
+ apply IZR_le.
destruct beta as (beta_val,beta_prop).
now apply Zle_bool_imp_le.
Qed.
@@ -2024,7 +1966,7 @@ set (f := round (Znearest (Zle_bool 0)) x).
intros Rxf.
destruct (Req_dec (x - round Zfloor x) (round Zceil x - x)) as [Hm|Hm].
(* *)
-apply Rnd_NA_N_pt.
+apply Rnd_NA_pt_N.
exact generic_format_0.
exact Rxf.
destruct (Rle_or_lt 0 x) as [Hx|Hx].
@@ -2038,7 +1980,7 @@ apply (round_UP_pt x).
apply Zfloor_lub.
apply Rmult_le_pos with (1 := Hx).
apply bpow_ge_0.
-apply Rnd_N_pt_pos with (2 := Hx) (3 := Rxf).
+apply Rnd_N_pt_ge_0 with (2 := Hx) (3 := Rxf).
exact generic_format_0.
(* . *)
rewrite Rabs_left with (1 := Hx).
@@ -2048,21 +1990,21 @@ unfold f.
rewrite round_N_middle with (1 := Hm).
rewrite Zle_bool_false.
apply (round_DN_pt x).
-apply lt_Z2R.
+apply lt_IZR.
apply Rle_lt_trans with (scaled_mantissa x).
apply Zfloor_lb.
simpl.
-rewrite <- (Rmult_0_l (bpow (- canonic_exp x))).
+rewrite <- (Rmult_0_l (bpow (- cexp x))).
apply Rmult_lt_compat_r with (2 := Hx).
apply bpow_gt_0.
-apply Rnd_N_pt_neg with (3 := Rxf).
+apply Rnd_N_pt_le_0 with (3 := Rxf).
exact generic_format_0.
now apply Rlt_le.
(* *)
split.
apply Rxf.
intros g Rxg.
-rewrite Rnd_N_pt_unicity with (3 := Hm) (4 := Rxf) (5 := Rxg).
+rewrite Rnd_N_pt_unique with (3 := Hm) (4 := Rxf) (5 := Rxg).
apply Rle_refl.
apply round_DN_pt.
apply round_UP_pt.
@@ -2077,25 +2019,25 @@ Theorem Znearest_opp :
Znearest choice (- x) = (- Znearest (fun t => negb (choice (- (t + 1))%Z)) x)%Z.
Proof with auto with typeclass_instances.
intros choice x.
-destruct (Req_dec (Z2R (Zfloor x)) x) as [Hx|Hx].
+destruct (Req_dec (IZR (Zfloor x)) x) as [Hx|Hx].
rewrite <- Hx.
-rewrite <- Z2R_opp.
-rewrite 2!Zrnd_Z2R...
+rewrite <- opp_IZR.
+rewrite 2!Zrnd_IZR...
unfold Znearest.
-replace (- x - Z2R (Zfloor (-x)))%R with (Z2R (Zceil x) - x)%R.
-rewrite Rcompare_ceil_floor_mid with (1 := Hx).
-rewrite Rcompare_floor_ceil_mid with (1 := Hx).
+replace (- x - IZR (Zfloor (-x)))%R with (IZR (Zceil x) - x)%R.
+rewrite Rcompare_ceil_floor_middle with (1 := Hx).
+rewrite Rcompare_floor_ceil_middle with (1 := Hx).
rewrite Rcompare_sym.
rewrite <- Zceil_floor_neq with (1 := Hx).
unfold Zceil.
rewrite Ropp_involutive.
case Rcompare ; simpl ; trivial.
-rewrite Zopp_involutive.
+rewrite Z.opp_involutive.
case (choice (Zfloor (- x))) ; simpl ; trivial.
-now rewrite Zopp_involutive.
-now rewrite Zopp_involutive.
+now rewrite Z.opp_involutive.
+now rewrite Z.opp_involutive.
unfold Zceil.
-rewrite Z2R_opp.
+rewrite opp_IZR.
apply Rplus_comm.
Qed.
@@ -2106,15 +2048,30 @@ Theorem round_N_opp :
Proof.
intros choice x.
unfold round, F2R. simpl.
-rewrite canonic_exp_opp.
+rewrite cexp_opp.
rewrite scaled_mantissa_opp.
rewrite Znearest_opp.
-rewrite Z2R_opp.
+rewrite opp_IZR.
now rewrite Ropp_mult_distr_l_reverse.
Qed.
End rndN_opp.
+Lemma round_N_small :
+ forall choice,
+ forall x,
+ forall ex,
+ (Raux.bpow beta (ex - 1) <= Rabs x < Raux.bpow beta ex)%R ->
+ (ex < fexp ex)%Z ->
+ (round (Znearest choice) x = 0)%R.
+Proof.
+intros choice x ex Hx Hex.
+destruct (Rle_or_lt 0 x) as [Px|Nx].
+{ now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_pos_eq. }
+rewrite <-(Ropp_involutive x), round_N_opp, <-Ropp_0; f_equal.
+now revert Hex; apply round_N_small_pos; revert Hx; rewrite Rabs_left.
+Qed.
+
End Format.
(** Inclusion of a format into an extended format *)
@@ -2125,9 +2082,9 @@ Variables fexp1 fexp2 : Z -> Z.
Context { valid_exp1 : Valid_exp fexp1 }.
Context { valid_exp2 : Valid_exp fexp2 }.
-Theorem generic_inclusion_ln_beta :
+Theorem generic_inclusion_mag :
forall x,
- ( x <> R0 -> (fexp2 (ln_beta beta x) <= fexp1 (ln_beta beta x))%Z ) ->
+ ( x <> 0%R -> (fexp2 (mag beta x) <= fexp1 (mag beta x))%Z ) ->
generic_format fexp1 x ->
generic_format fexp2 x.
Proof.
@@ -2139,7 +2096,7 @@ rewrite <- Fx.
apply He.
contradict Zx.
rewrite Zx, scaled_mantissa_0.
-apply (Ztrunc_Z2R 0).
+apply Ztrunc_IZR.
Qed.
Theorem generic_inclusion_lt_ge :
@@ -2151,12 +2108,12 @@ Theorem generic_inclusion_lt_ge :
generic_format fexp2 x.
Proof.
intros e1 e2 He x (Hx1,Hx2).
-apply generic_inclusion_ln_beta.
+apply generic_inclusion_mag.
intros Zx.
apply He.
split.
-now apply ln_beta_gt_bpow.
-now apply ln_beta_le_bpow.
+now apply mag_gt_bpow.
+now apply mag_le_bpow.
Qed.
Theorem generic_inclusion :
@@ -2168,13 +2125,13 @@ Theorem generic_inclusion :
generic_format fexp2 x.
Proof with auto with typeclass_instances.
intros e He x (Hx1,[Hx2|Hx2]).
-apply generic_inclusion_ln_beta.
-now rewrite ln_beta_unique with (1 := conj Hx1 Hx2).
+apply generic_inclusion_mag.
+now rewrite mag_unique with (1 := conj Hx1 Hx2).
intros Fx.
apply generic_format_abs_inv.
rewrite Hx2.
apply generic_format_bpow'...
-apply Zle_trans with (1 := He).
+apply Z.le_trans with (1 := He).
apply generic_format_bpow_inv...
rewrite <- Hx2.
now apply generic_format_abs.
@@ -2191,18 +2148,18 @@ Theorem generic_inclusion_le_ge :
Proof.
intros e1 e2 He' He x (Hx1,[Hx2|Hx2]).
(* *)
-apply generic_inclusion_ln_beta.
+apply generic_inclusion_mag.
intros Zx.
apply He.
split.
-now apply ln_beta_gt_bpow.
-now apply ln_beta_le_bpow.
+now apply mag_gt_bpow.
+now apply mag_le_bpow.
(* *)
apply generic_inclusion with (e := e2).
apply He.
split.
apply He'.
-apply Zle_refl.
+apply Z.le_refl.
rewrite Hx2.
split.
apply bpow_le.
@@ -2219,13 +2176,13 @@ Theorem generic_inclusion_le :
generic_format fexp2 x.
Proof.
intros e2 He x [Hx|Hx].
-apply generic_inclusion_ln_beta.
+apply generic_inclusion_mag.
intros Zx.
apply He.
-now apply ln_beta_le_bpow.
+now apply mag_le_bpow.
apply generic_inclusion with (e := e2).
apply He.
-apply Zle_refl.
+apply Z.le_refl.
rewrite Hx.
split.
apply bpow_le.
@@ -2242,10 +2199,10 @@ Theorem generic_inclusion_ge :
generic_format fexp2 x.
Proof.
intros e1 He x Hx.
-apply generic_inclusion_ln_beta.
+apply generic_inclusion_mag.
intros Zx.
apply He.
-now apply ln_beta_gt_bpow.
+now apply mag_gt_bpow.
Qed.
Variable rnd : R -> Z.
@@ -2263,9 +2220,9 @@ revert rnd valid_rnd x Gx.
refine (round_abs_abs _ (fun x y => generic_format fexp1 x -> generic_format fexp1 y) _).
intros rnd valid_rnd x [Hx|Hx] Gx.
(* x > 0 *)
-generalize (ln_beta_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx).
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
+generalize (mag_generic_gt _ x (Rgt_not_eq _ _ Hx) Gx).
+unfold cexp.
+destruct (mag beta x) as (ex,Ex) ; simpl.
specialize (Ex (Rgt_not_eq _ _ Hx)).
intros He'.
rewrite Rabs_pos_eq in Ex by now apply Rlt_le.
@@ -2279,25 +2236,25 @@ apply generic_format_bpow'...
apply Zlt_le_weak.
apply valid_exp_large with ex...
(* - x large for fexp2 *)
-destruct (Zle_or_lt (canonic_exp fexp2 x) (canonic_exp fexp1 x)) as [He''|He''].
+destruct (Zle_or_lt (cexp fexp2 x) (cexp fexp1 x)) as [He''|He''].
(* - - round fexp2 x is representable for fexp1 *)
rewrite round_generic...
rewrite Gx.
apply generic_format_F2R.
fold (round fexp1 Ztrunc x).
intros Zx.
-unfold canonic_exp at 1.
-rewrite ln_beta_round_ZR...
+unfold cexp at 1.
+rewrite mag_round_ZR...
contradict Zx.
-apply F2R_eq_0_reg with (1 := Zx).
+apply eq_0_F2R with (1 := Zx).
(* - - round fexp2 x has too many digits for fexp1 *)
destruct (round_bounded_large_pos fexp2 rnd x ex He Ex) as (Hr1,[Hr2|Hr2]).
apply generic_format_F2R.
intros Zx.
fold (round fexp2 rnd x).
-unfold canonic_exp at 1.
-rewrite ln_beta_unique_pos with (1 := conj Hr1 Hr2).
-rewrite <- ln_beta_unique_pos with (1 := Ex).
+unfold cexp at 1.
+rewrite mag_unique_pos with (1 := conj Hr1 Hr2).
+rewrite <- mag_unique_pos with (1 := Ex).
now apply Zlt_le_weak.
rewrite Hr2.
apply generic_format_bpow'...
@@ -2327,7 +2284,7 @@ apply Ropp_eq_compat.
apply round_ext.
clear x; intro x.
unfold Znearest.
-case_eq (Rcompare (x - Z2R (Zfloor x)) (/ 2)); intro C;
+case_eq (Rcompare (x - IZR (Zfloor x)) (/ 2)); intro C;
[|reflexivity|reflexivity].
apply Rcompare_Eq_inv in C.
assert (H : negb (0 <=? - (Zfloor x + 1))%Z = (0 <=? Zfloor x)%Z);
diff --git a/flocq/Core/Fcore_Raux.v b/flocq/Core/Raux.v
index 77235e63..8273a55b 100644
--- a/flocq/Core/Fcore_Raux.v
+++ b/flocq/Core/Raux.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,9 +18,9 @@ COPYING file for more details.
*)
(** * Missing definitions/lemmas *)
-Require Export Reals.
-Require Export ZArith.
-Require Export Fcore_Zaux.
+Require Import Psatz.
+Require Export Reals ZArith.
+Require Export Zaux.
Section Rmissing.
@@ -58,12 +58,13 @@ Theorem Rabs_minus_le:
(Rabs (x-y) <= x)%R.
Proof.
intros x y Hx Hy.
-unfold Rabs; case (Rcase_abs (x - y)); intros H.
-apply Rplus_le_reg_l with x; ring_simplify; assumption.
-apply Rplus_le_reg_l with (-x)%R; ring_simplify.
-auto with real.
+apply Rabs_le.
+lra.
Qed.
+Theorem Rabs_eq_R0 x : (Rabs x = 0 -> x = 0)%R.
+Proof. split_Rabs; lra. Qed.
+
Theorem Rplus_eq_reg_r :
forall r r1 r2 : R,
(r1 + r = r2 + r)%R -> (r1 = r2)%R.
@@ -73,53 +74,6 @@ apply Rplus_eq_reg_l with r.
now rewrite 2!(Rplus_comm r).
Qed.
-Theorem Rplus_lt_reg_l :
- forall r r1 r2 : R,
- (r + r1 < r + r2)%R -> (r1 < r2)%R.
-Proof.
-intros.
-solve [ apply Rplus_lt_reg_l with (1 := H) |
- apply Rplus_lt_reg_r with (1 := H) ].
-Qed.
-
-Theorem Rplus_lt_reg_r :
- forall r r1 r2 : R,
- (r1 + r < r2 + r)%R -> (r1 < r2)%R.
-Proof.
-intros.
-apply Rplus_lt_reg_l with r.
-now rewrite 2!(Rplus_comm r).
-Qed.
-
-Theorem Rplus_le_reg_r :
- forall r r1 r2 : R,
- (r1 + r <= r2 + r)%R -> (r1 <= r2)%R.
-Proof.
-intros.
-apply Rplus_le_reg_l with r.
-now rewrite 2!(Rplus_comm r).
-Qed.
-
-Theorem Rmult_lt_reg_r :
- forall r r1 r2 : R, (0 < r)%R ->
- (r1 * r < r2 * r)%R -> (r1 < r2)%R.
-Proof.
-intros.
-apply Rmult_lt_reg_l with r.
-exact H.
-now rewrite 2!(Rmult_comm r).
-Qed.
-
-Theorem Rmult_le_reg_r :
- forall r r1 r2 : R, (0 < r)%R ->
- (r1 * r <= r2 * r)%R -> (r1 <= r2)%R.
-Proof.
-intros.
-apply Rmult_le_reg_l with r.
-exact H.
-now rewrite 2!(Rmult_comm r).
-Qed.
-
Theorem Rmult_lt_compat :
forall r1 r2 r3 r4,
(0 <= r1)%R -> (0 <= r3)%R -> (r1 < r2)%R -> (r3 < r4)%R ->
@@ -135,16 +89,6 @@ apply Rle_lt_trans with (r1 * r4)%R.
+ exact H12.
Qed.
-Theorem Rmult_eq_reg_r :
- forall r r1 r2 : R, (r1 * r)%R = (r2 * r)%R ->
- r <> 0%R -> r1 = r2.
-Proof.
-intros r r1 r2 H1 H2.
-apply Rmult_eq_reg_l with r.
-now rewrite 2!(Rmult_comm r).
-exact H2.
-Qed.
-
Theorem Rmult_minus_distr_r :
forall r r1 r2 : R,
((r1 - r2) * r = r1 * r - r2 * r)%R.
@@ -154,13 +98,18 @@ rewrite <- 3!(Rmult_comm r).
apply Rmult_minus_distr_l.
Qed.
-Lemma Rmult_neq_reg_r: forall r1 r2 r3:R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3.
+Lemma Rmult_neq_reg_r :
+ forall r1 r2 r3 : R, (r2 * r1 <> r3 * r1)%R -> r2 <> r3.
+Proof.
intros r1 r2 r3 H1 H2.
apply H1; rewrite H2; ring.
Qed.
-Lemma Rmult_neq_compat_r: forall r1 r2 r3:R, (r1 <> 0)%R -> (r2 <> r3)%R
- -> (r2 *r1 <> r3*r1)%R.
+Lemma Rmult_neq_compat_r :
+ forall r1 r2 r3 : R,
+ (r1 <> 0)%R -> (r2 <> r3)%R ->
+ (r2 * r1 <> r3 * r1)%R.
+Proof.
intros r1 r2 r3 H H1 H2.
now apply H1, Rmult_eq_reg_r with r1.
Qed.
@@ -227,7 +176,6 @@ rewrite Rmax_right; trivial.
now apply Ropp_le_contravar.
Qed.
-
Theorem exp_le :
forall x y : R,
(x <= y)%R -> (exp x <= exp y)%R.
@@ -288,6 +236,14 @@ destruct (Req_dec x 0) as [Zx|Nzx].
now apply Nzx, Rle_antisym; [|apply Rge_le].
Qed.
+Lemma Rsqr_le_abs_0_alt :
+ forall x y,
+ (x² <= y² -> x <= Rabs y)%R.
+Proof.
+intros x y H.
+apply (Rle_trans _ (Rabs x)); [apply Rle_abs|apply (Rsqr_le_abs_0 _ _ H)].
+Qed.
+
Theorem Rabs_le :
forall x y,
(-y <= x <= y)%R -> (Rabs x <= y)%R.
@@ -387,187 +343,35 @@ Qed.
End Rmissing.
-Section Z2R.
+Section IZR.
-(** Z2R function (Z -> R) *)
-Fixpoint P2R (p : positive) :=
- match p with
- | xH => 1%R
- | xO xH => 2%R
- | xO t => (2 * P2R t)%R
- | xI xH => 3%R
- | xI t => (1 + 2 * P2R t)%R
- end.
-
-Definition Z2R n :=
- match n with
- | Zpos p => P2R p
- | Zneg p => Ropp (P2R p)
- | Z0 => 0%R
- end.
-
-Theorem P2R_INR :
- forall n, P2R n = INR (nat_of_P n).
-Proof.
-induction n ; simpl ; try (
- rewrite IHn ;
- rewrite <- (mult_INR 2) ;
- rewrite <- (nat_of_P_mult_morphism 2) ;
- change (2 * n)%positive with (xO n)).
-(* xI *)
-rewrite (Rplus_comm 1).
-change (nat_of_P (xO n)) with (Pmult_nat n 2).
-case n ; intros ; simpl ; try apply refl_equal.
-case (Pmult_nat p 4) ; intros ; try apply refl_equal.
-rewrite Rplus_0_l.
-apply refl_equal.
-apply Rplus_comm.
-(* xO *)
-case n ; intros ; apply refl_equal.
-(* xH *)
-apply refl_equal.
-Qed.
-
-Theorem Z2R_IZR :
- forall n, Z2R n = IZR n.
-Proof.
-intro.
-case n ; intros ; unfold Z2R.
-apply refl_equal.
-rewrite <- positive_nat_Z, <- INR_IZR_INZ.
-apply P2R_INR.
-change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))).
-apply Ropp_eq_compat.
-rewrite <- positive_nat_Z, <- INR_IZR_INZ.
-apply P2R_INR.
-Qed.
-
-Theorem Z2R_opp :
- forall n, Z2R (-n) = (- Z2R n)%R.
-Proof.
-intros.
-repeat rewrite Z2R_IZR.
-apply Ropp_Ropp_IZR.
-Qed.
-
-Theorem Z2R_plus :
- forall m n, (Z2R (m + n) = Z2R m + Z2R n)%R.
-Proof.
-intros.
-repeat rewrite Z2R_IZR.
-apply plus_IZR.
-Qed.
-
-Theorem minus_IZR :
- forall n m : Z,
- IZR (n - m) = (IZR n - IZR m)%R.
-Proof.
-intros.
-unfold Zminus.
-rewrite plus_IZR.
-rewrite Ropp_Ropp_IZR.
-apply refl_equal.
-Qed.
-
-Theorem Z2R_minus :
- forall m n, (Z2R (m - n) = Z2R m - Z2R n)%R.
-Proof.
-intros.
-repeat rewrite Z2R_IZR.
-apply minus_IZR.
-Qed.
-
-Theorem Z2R_mult :
- forall m n, (Z2R (m * n) = Z2R m * Z2R n)%R.
-Proof.
-intros.
-repeat rewrite Z2R_IZR.
-apply mult_IZR.
-Qed.
-
-Theorem le_Z2R :
- forall m n, (Z2R m <= Z2R n)%R -> (m <= n)%Z.
-Proof.
-intros m n.
-repeat rewrite Z2R_IZR.
-apply le_IZR.
-Qed.
-
-Theorem Z2R_le :
- forall m n, (m <= n)%Z -> (Z2R m <= Z2R n)%R.
-Proof.
-intros m n.
-repeat rewrite Z2R_IZR.
-apply IZR_le.
-Qed.
-
-Theorem lt_Z2R :
- forall m n, (Z2R m < Z2R n)%R -> (m < n)%Z.
-Proof.
-intros m n.
-repeat rewrite Z2R_IZR.
-apply lt_IZR.
-Qed.
-
-Theorem Z2R_lt :
- forall m n, (m < n)%Z -> (Z2R m < Z2R n)%R.
-Proof.
-intros m n.
-repeat rewrite Z2R_IZR.
-apply IZR_lt.
-Qed.
-
-Theorem Z2R_le_lt :
- forall m n p, (m <= n < p)%Z -> (Z2R m <= Z2R n < Z2R p)%R.
+Theorem IZR_le_lt :
+ forall m n p, (m <= n < p)%Z -> (IZR m <= IZR n < IZR p)%R.
Proof.
intros m n p (H1, H2).
split.
-now apply Z2R_le.
-now apply Z2R_lt.
+now apply IZR_le.
+now apply IZR_lt.
Qed.
-Theorem le_lt_Z2R :
- forall m n p, (Z2R m <= Z2R n < Z2R p)%R -> (m <= n < p)%Z.
+Theorem le_lt_IZR :
+ forall m n p, (IZR m <= IZR n < IZR p)%R -> (m <= n < p)%Z.
Proof.
intros m n p (H1, H2).
split.
-now apply le_Z2R.
-now apply lt_Z2R.
-Qed.
-
-Theorem eq_Z2R :
- forall m n, (Z2R m = Z2R n)%R -> (m = n)%Z.
-Proof.
-intros m n H.
-apply eq_IZR.
-now rewrite <- 2!Z2R_IZR.
+now apply le_IZR.
+now apply lt_IZR.
Qed.
-Theorem neq_Z2R :
- forall m n, (Z2R m <> Z2R n)%R -> (m <> n)%Z.
+Theorem neq_IZR :
+ forall m n, (IZR m <> IZR n)%R -> (m <> n)%Z.
Proof.
intros m n H H'.
apply H.
now apply f_equal.
Qed.
-Theorem Z2R_neq :
- forall m n, (m <> n)%Z -> (Z2R m <> Z2R n)%R.
-Proof.
-intros m n.
-repeat rewrite Z2R_IZR.
-apply IZR_neq.
-Qed.
-
-Theorem Z2R_abs :
- forall z, Z2R (Zabs z) = Rabs (Z2R z).
-Proof.
-intros.
-repeat rewrite Z2R_IZR.
-now rewrite Rabs_Zabs.
-Qed.
-
-End Z2R.
+End IZR.
(** Decidable comparison on reals *)
Section Rcompare.
@@ -691,17 +495,17 @@ contradict H.
now apply Rcompare_Gt.
Qed.
-Theorem Rcompare_Z2R :
- forall x y, Rcompare (Z2R x) (Z2R y) = Zcompare x y.
+Theorem Rcompare_IZR :
+ forall x y, Rcompare (IZR x) (IZR y) = Z.compare x y.
Proof.
intros x y.
case Rcompare_spec ; intros H ; apply sym_eq.
apply Zcompare_Lt.
-now apply lt_Z2R.
+now apply lt_IZR.
apply Zcompare_Eq.
-now apply eq_Z2R.
+now apply eq_IZR.
apply Zcompare_Gt.
-now apply lt_Z2R.
+now apply lt_IZR.
Qed.
Theorem Rcompare_sym :
@@ -715,6 +519,16 @@ now apply Rcompare_Eq.
now apply Rcompare_Lt.
Qed.
+Lemma Rcompare_opp :
+ forall x y,
+ Rcompare (- x) (- y) = Rcompare y x.
+Proof.
+intros x y.
+destruct (Rcompare_spec y x);
+ destruct (Rcompare_spec (- x) (- y));
+ try reflexivity; exfalso; lra.
+Qed.
+
Theorem Rcompare_plus_r :
forall z x y,
Rcompare (x + z) (y + z) = Rcompare x y.
@@ -773,7 +587,7 @@ rewrite <- (Rcompare_mult_r (/2) (x - d)).
field_simplify (x + (- x / 2 - d / 2))%R.
now field_simplify ((d + u) / 2 + (- x / 2 - d / 2))%R.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
Qed.
Theorem Rcompare_half_l :
@@ -784,8 +598,8 @@ rewrite <- (Rcompare_mult_r 2%R).
unfold Rdiv.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
now rewrite Rmult_comm.
-now apply (Z2R_neq 2 0).
-now apply (Z2R_lt 0 2).
+now apply IZR_neq.
+now apply IZR_lt.
Qed.
Theorem Rcompare_half_r :
@@ -796,23 +610,23 @@ rewrite <- (Rcompare_mult_r 2%R).
unfold Rdiv.
rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
now rewrite Rmult_comm.
-now apply (Z2R_neq 2 0).
-now apply (Z2R_lt 0 2).
+now apply IZR_neq.
+now apply IZR_lt.
Qed.
Theorem Rcompare_sqr :
forall x y,
- (0 <= x)%R -> (0 <= y)%R ->
- Rcompare (x * x) (y * y) = Rcompare x y.
+ Rcompare (x * x) (y * y) = Rcompare (Rabs x) (Rabs y).
Proof.
-intros x y Hx Hy.
-destruct (Rcompare_spec x y) as [H|H|H].
+intros x y.
+destruct (Rcompare_spec (Rabs x) (Rabs y)) as [H|H|H].
apply Rcompare_Lt.
-now apply Rsqr_incrst_1.
-rewrite H.
+now apply Rsqr_lt_abs_1.
+change (Rcompare (Rsqr x) (Rsqr y) = Eq).
+rewrite Rsqr_abs, H, (Rsqr_abs y).
now apply Rcompare_Eq.
apply Rcompare_Gt.
-now apply Rsqr_incrst_1.
+now apply Rsqr_lt_abs_1.
Qed.
Theorem Rmin_compare :
@@ -941,6 +755,14 @@ rewrite <- negb_Rlt_bool.
now rewrite Rle_bool_true.
Qed.
+Lemma Rlt_bool_opp :
+ forall x y,
+ Rlt_bool (- x) (- y) = Rlt_bool y x.
+Proof.
+intros x y.
+now unfold Rlt_bool; rewrite Rcompare_opp.
+Qed.
+
End Rlt_bool.
Section Req_bool.
@@ -997,13 +819,12 @@ Definition Zfloor (x : R) := (up x - 1)%Z.
Theorem Zfloor_lb :
forall x : R,
- (Z2R (Zfloor x) <= x)%R.
+ (IZR (Zfloor x) <= x)%R.
Proof.
intros x.
unfold Zfloor.
-rewrite Z2R_minus.
+rewrite minus_IZR.
simpl.
-rewrite Z2R_IZR.
apply Rplus_le_reg_r with (1 - x)%R.
ring_simplify.
exact (proj2 (archimed x)).
@@ -1011,55 +832,54 @@ Qed.
Theorem Zfloor_ub :
forall x : R,
- (x < Z2R (Zfloor x) + 1)%R.
+ (x < IZR (Zfloor x) + 1)%R.
Proof.
intros x.
unfold Zfloor.
-rewrite Z2R_minus.
+rewrite minus_IZR.
unfold Rminus.
rewrite Rplus_assoc.
rewrite Rplus_opp_l, Rplus_0_r.
-rewrite Z2R_IZR.
exact (proj1 (archimed x)).
Qed.
Theorem Zfloor_lub :
forall n x,
- (Z2R n <= x)%R ->
+ (IZR n <= x)%R ->
(n <= Zfloor x)%Z.
Proof.
intros n x Hnx.
apply Zlt_succ_le.
-apply lt_Z2R.
+apply lt_IZR.
apply Rle_lt_trans with (1 := Hnx).
-unfold Zsucc.
-rewrite Z2R_plus.
+unfold Z.succ.
+rewrite plus_IZR.
apply Zfloor_ub.
Qed.
Theorem Zfloor_imp :
forall n x,
- (Z2R n <= x < Z2R (n + 1))%R ->
+ (IZR n <= x < IZR (n + 1))%R ->
Zfloor x = n.
Proof.
intros n x Hnx.
apply Zle_antisym.
apply Zlt_succ_le.
-apply lt_Z2R.
+apply lt_IZR.
apply Rle_lt_trans with (2 := proj2 Hnx).
apply Zfloor_lb.
now apply Zfloor_lub.
Qed.
-Theorem Zfloor_Z2R :
+Theorem Zfloor_IZR :
forall n,
- Zfloor (Z2R n) = n.
+ Zfloor (IZR n) = n.
Proof.
intros n.
apply Zfloor_imp.
split.
apply Rle_refl.
-apply Z2R_lt.
+apply IZR_lt.
apply Zlt_succ.
Qed.
@@ -1077,11 +897,11 @@ Definition Zceil (x : R) := (- Zfloor (- x))%Z.
Theorem Zceil_ub :
forall x : R,
- (x <= Z2R (Zceil x))%R.
+ (x <= IZR (Zceil x))%R.
Proof.
intros x.
unfold Zceil.
-rewrite Z2R_opp.
+rewrite opp_IZR.
apply Ropp_le_cancel.
rewrite Ropp_involutive.
apply Zfloor_lb.
@@ -1089,45 +909,45 @@ Qed.
Theorem Zceil_glb :
forall n x,
- (x <= Z2R n)%R ->
+ (x <= IZR n)%R ->
(Zceil x <= n)%Z.
Proof.
intros n x Hnx.
unfold Zceil.
apply Zopp_le_cancel.
-rewrite Zopp_involutive.
+rewrite Z.opp_involutive.
apply Zfloor_lub.
-rewrite Z2R_opp.
+rewrite opp_IZR.
now apply Ropp_le_contravar.
Qed.
Theorem Zceil_imp :
forall n x,
- (Z2R (n - 1) < x <= Z2R n)%R ->
+ (IZR (n - 1) < x <= IZR n)%R ->
Zceil x = n.
Proof.
intros n x Hnx.
unfold Zceil.
-rewrite <- (Zopp_involutive n).
+rewrite <- (Z.opp_involutive n).
apply f_equal.
apply Zfloor_imp.
split.
-rewrite Z2R_opp.
+rewrite opp_IZR.
now apply Ropp_le_contravar.
-rewrite <- (Zopp_involutive 1).
+rewrite <- (Z.opp_involutive 1).
rewrite <- Zopp_plus_distr.
-rewrite Z2R_opp.
+rewrite opp_IZR.
now apply Ropp_lt_contravar.
Qed.
-Theorem Zceil_Z2R :
+Theorem Zceil_IZR :
forall n,
- Zceil (Z2R n) = n.
+ Zceil (IZR n) = n.
Proof.
intros n.
unfold Zceil.
-rewrite <- Z2R_opp, Zfloor_Z2R.
-apply Zopp_involutive.
+rewrite <- opp_IZR, Zfloor_IZR.
+apply Z.opp_involutive.
Qed.
Theorem Zceil_le :
@@ -1142,7 +962,7 @@ Qed.
Theorem Zceil_floor_neq :
forall x : R,
- (Z2R (Zfloor x) <> x)%R ->
+ (IZR (Zfloor x) <> x)%R ->
(Zceil x = Zfloor x + 1)%Z.
Proof.
intros x Hx.
@@ -1156,21 +976,21 @@ apply Rle_antisym.
apply Zfloor_lb.
exact H.
apply Rlt_le.
-rewrite Z2R_plus.
+rewrite plus_IZR.
apply Zfloor_ub.
Qed.
Definition Ztrunc x := if Rlt_bool x 0 then Zceil x else Zfloor x.
-Theorem Ztrunc_Z2R :
+Theorem Ztrunc_IZR :
forall n,
- Ztrunc (Z2R n) = n.
+ Ztrunc (IZR n) = n.
Proof.
intros n.
unfold Ztrunc.
case Rlt_bool_spec ; intro H.
-apply Zceil_Z2R.
-apply Zfloor_Z2R.
+apply Zceil_IZR.
+apply Zfloor_IZR.
Qed.
Theorem Ztrunc_floor :
@@ -1196,9 +1016,8 @@ unfold Ztrunc.
case Rlt_bool_spec ; intro H.
apply refl_equal.
rewrite (Rle_antisym _ _ Hx H).
-change 0%R with (Z2R 0).
-rewrite Zceil_Z2R.
-apply Zfloor_Z2R.
+rewrite Zceil_IZR.
+apply Zfloor_IZR.
Qed.
Theorem Ztrunc_le :
@@ -1211,7 +1030,7 @@ case Rlt_bool_spec ; intro Hx.
unfold Ztrunc.
case Rlt_bool_spec ; intro Hy.
now apply Zceil_le.
-apply Zle_trans with 0%Z.
+apply Z.le_trans with 0%Z.
apply Zceil_glb.
now apply Rlt_le.
now apply Zfloor_lub.
@@ -1222,14 +1041,14 @@ Qed.
Theorem Ztrunc_opp :
forall x,
- Ztrunc (- x) = Zopp (Ztrunc x).
+ Ztrunc (- x) = Z.opp (Ztrunc x).
Proof.
intros x.
unfold Ztrunc at 2.
case Rlt_bool_spec ; intros Hx.
rewrite Ztrunc_floor.
apply sym_eq.
-apply Zopp_involutive.
+apply Z.opp_involutive.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
now apply Rlt_le.
@@ -1242,7 +1061,7 @@ Qed.
Theorem Ztrunc_abs :
forall x,
- Ztrunc (Rabs x) = Zabs (Ztrunc x).
+ Ztrunc (Rabs x) = Z.abs (Ztrunc x).
Proof.
intros x.
rewrite Ztrunc_floor. 2: apply Rabs_pos.
@@ -1251,19 +1070,19 @@ case Rlt_bool_spec ; intro H.
rewrite Rabs_left with (1 := H).
rewrite Zabs_non_eq.
apply sym_eq.
-apply Zopp_involutive.
+apply Z.opp_involutive.
apply Zceil_glb.
now apply Rlt_le.
rewrite Rabs_pos_eq with (1 := H).
apply sym_eq.
-apply Zabs_eq.
+apply Z.abs_eq.
now apply Zfloor_lub.
Qed.
Theorem Ztrunc_lub :
forall n x,
- (Z2R n <= Rabs x)%R ->
- (n <= Zabs (Ztrunc x))%Z.
+ (IZR n <= Rabs x)%R ->
+ (n <= Z.abs (Ztrunc x))%Z.
Proof.
intros n x H.
rewrite <- Ztrunc_abs.
@@ -1273,15 +1092,15 @@ Qed.
Definition Zaway x := if Rlt_bool x 0 then Zfloor x else Zceil x.
-Theorem Zaway_Z2R :
+Theorem Zaway_IZR :
forall n,
- Zaway (Z2R n) = n.
+ Zaway (IZR n) = n.
Proof.
intros n.
unfold Zaway.
case Rlt_bool_spec ; intro H.
-apply Zfloor_Z2R.
-apply Zceil_Z2R.
+apply Zfloor_IZR.
+apply Zceil_IZR.
Qed.
Theorem Zaway_ceil :
@@ -1307,9 +1126,8 @@ unfold Zaway.
case Rlt_bool_spec ; intro H.
apply refl_equal.
rewrite (Rle_antisym _ _ Hx H).
-change 0%R with (Z2R 0).
-rewrite Zfloor_Z2R.
-apply Zceil_Z2R.
+rewrite Zfloor_IZR.
+apply Zceil_IZR.
Qed.
Theorem Zaway_le :
@@ -1322,7 +1140,7 @@ case Rlt_bool_spec ; intro Hx.
unfold Zaway.
case Rlt_bool_spec ; intro Hy.
now apply Zfloor_le.
-apply le_Z2R.
+apply le_IZR.
apply Rle_trans with 0%R.
apply Rlt_le.
apply Rle_lt_trans with (2 := Hx).
@@ -1336,7 +1154,7 @@ Qed.
Theorem Zaway_opp :
forall x,
- Zaway (- x) = Zopp (Zaway x).
+ Zaway (- x) = Z.opp (Zaway x).
Proof.
intros x.
unfold Zaway at 2.
@@ -1348,14 +1166,14 @@ apply Rlt_le.
now apply Ropp_0_gt_lt_contravar.
rewrite Zaway_floor.
apply sym_eq.
-apply Zopp_involutive.
+apply Z.opp_involutive.
rewrite <- Ropp_0.
now apply Ropp_le_contravar.
Qed.
Theorem Zaway_abs :
forall x,
- Zaway (Rabs x) = Zabs (Zaway x).
+ Zaway (Rabs x) = Z.abs (Zaway x).
Proof.
intros x.
rewrite Zaway_ceil. 2: apply Rabs_pos.
@@ -1365,66 +1183,126 @@ rewrite Rabs_left with (1 := H).
rewrite Zabs_non_eq.
apply (f_equal (fun v => - Zfloor v)%Z).
apply Ropp_involutive.
-apply le_Z2R.
+apply le_IZR.
apply Rlt_le.
apply Rle_lt_trans with (2 := H).
apply Zfloor_lb.
rewrite Rabs_pos_eq with (1 := H).
apply sym_eq.
-apply Zabs_eq.
-apply le_Z2R.
+apply Z.abs_eq.
+apply le_IZR.
apply Rle_trans with (1 := H).
apply Zceil_ub.
Qed.
End Floor_Ceil.
+Theorem Rcompare_floor_ceil_middle :
+ forall x,
+ IZR (Zfloor x) <> x ->
+ Rcompare (x - IZR (Zfloor x)) (/ 2) = Rcompare (x - IZR (Zfloor x)) (IZR (Zceil x) - x).
+Proof.
+intros x Hx.
+rewrite Zceil_floor_neq with (1 := Hx).
+rewrite plus_IZR.
+destruct (Rcompare_spec (x - IZR (Zfloor x)) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
+(* . *)
+apply Rcompare_Lt.
+apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R.
+replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring.
+replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
+apply Rmult_lt_compat_r with (2 := H1).
+now apply IZR_lt.
+(* . *)
+apply Rcompare_Eq.
+replace (IZR (Zfloor x) + 1 - x)%R with (1 - (x - IZR (Zfloor x)))%R by ring.
+rewrite H1.
+field.
+(* . *)
+apply Rcompare_Gt.
+apply Rplus_lt_reg_l with (x - IZR (Zfloor x))%R.
+replace (x - IZR (Zfloor x) + (x - IZR (Zfloor x)))%R with ((x - IZR (Zfloor x)) * 2)%R by ring.
+replace (x - IZR (Zfloor x) + (IZR (Zfloor x) + 1 - x))%R with (/2 * 2)%R by field.
+apply Rmult_lt_compat_r with (2 := H1).
+now apply IZR_lt.
+Qed.
+
+Theorem Rcompare_ceil_floor_middle :
+ forall x,
+ IZR (Zfloor x) <> x ->
+ Rcompare (IZR (Zceil x) - x) (/ 2) = Rcompare (IZR (Zceil x) - x) (x - IZR (Zfloor x)).
+Proof.
+intros x Hx.
+rewrite Zceil_floor_neq with (1 := Hx).
+rewrite plus_IZR.
+destruct (Rcompare_spec (IZR (Zfloor x) + 1 - x) (/ 2)) as [H1|H1|H1] ; apply sym_eq.
+(* . *)
+apply Rcompare_Lt.
+apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R.
+replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring.
+replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field.
+apply Rmult_lt_compat_r with (2 := H1).
+now apply IZR_lt.
+(* . *)
+apply Rcompare_Eq.
+replace (x - IZR (Zfloor x))%R with (1 - (IZR (Zfloor x) + 1 - x))%R by ring.
+rewrite H1.
+field.
+(* . *)
+apply Rcompare_Gt.
+apply Rplus_lt_reg_l with (IZR (Zfloor x) + 1 - x)%R.
+replace (IZR (Zfloor x) + 1 - x + (IZR (Zfloor x) + 1 - x))%R with ((IZR (Zfloor x) + 1 - x) * 2)%R by ring.
+replace (IZR (Zfloor x) + 1 - x + (x - IZR (Zfloor x)))%R with (/2 * 2)%R by field.
+apply Rmult_lt_compat_r with (2 := H1).
+now apply IZR_lt.
+Qed.
+
Section Zdiv_Rdiv.
Theorem Zfloor_div :
forall x y,
y <> Z0 ->
- Zfloor (Z2R x / Z2R y) = (x / y)%Z.
+ Zfloor (IZR x / IZR y) = (x / y)%Z.
Proof.
intros x y Zy.
generalize (Z_div_mod_eq_full x y Zy).
intros Hx.
rewrite Hx at 1.
-assert (Zy': Z2R y <> R0).
+assert (Zy': IZR y <> 0%R).
contradict Zy.
-now apply eq_Z2R.
+now apply eq_IZR.
unfold Rdiv.
-rewrite Z2R_plus, Rmult_plus_distr_r, Z2R_mult.
-replace (Z2R y * Z2R (x / y) * / Z2R y)%R with (Z2R (x / y)) by now field.
+rewrite plus_IZR, Rmult_plus_distr_r, mult_IZR.
+replace (IZR y * IZR (x / y) * / IZR y)%R with (IZR (x / y)) by now field.
apply Zfloor_imp.
-rewrite Z2R_plus.
-assert (0 <= Z2R (x mod y) * / Z2R y < 1)%R.
+rewrite plus_IZR.
+assert (0 <= IZR (x mod y) * / IZR y < 1)%R.
(* *)
-assert (forall x' y', (0 < y')%Z -> 0 <= Z2R (x' mod y') * / Z2R y' < 1)%R.
+assert (forall x' y', (0 < y')%Z -> 0 <= IZR (x' mod y') * / IZR y' < 1)%R.
(* . *)
clear.
intros x y Hy.
split.
apply Rmult_le_pos.
-apply (Z2R_le 0).
+apply IZR_le.
refine (proj1 (Z_mod_lt _ _ _)).
-now apply Zlt_gt.
+now apply Z.lt_gt.
apply Rlt_le.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0).
-apply Rmult_lt_reg_r with (Z2R y).
-now apply (Z2R_lt 0).
+now apply IZR_lt.
+apply Rmult_lt_reg_r with (IZR y).
+now apply IZR_lt.
rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r.
-apply Z2R_lt.
+apply IZR_lt.
eapply Z_mod_lt.
-now apply Zlt_gt.
+now apply Z.lt_gt.
apply Rgt_not_eq.
-now apply (Z2R_lt 0).
+now apply IZR_lt.
(* . *)
destruct (Z_lt_le_dec y 0) as [Hy|Hy].
rewrite <- Rmult_opp_opp.
rewrite Ropp_inv_permute with (1 := Zy').
-rewrite <- 2!Z2R_opp.
+rewrite <- 2!opp_IZR.
rewrite <- Zmod_opp_opp.
apply H.
clear -Hy. omega.
@@ -1432,7 +1310,7 @@ apply H.
clear -Zy Hy. omega.
(* *)
split.
-pattern (Z2R (x / y)) at 1 ; rewrite <- Rplus_0_r.
+pattern (IZR (x / y)) at 1 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
apply H.
apply Rplus_lt_compat_l.
@@ -1445,11 +1323,11 @@ Section pow.
Variable r : radix.
-Theorem radix_pos : (0 < Z2R r)%R.
+Theorem radix_pos : (0 < IZR r)%R.
Proof.
destruct r as (v, Hr). simpl.
-apply (Z2R_lt 0).
-apply Zlt_le_trans with 2%Z.
+apply IZR_lt.
+apply Z.lt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.
@@ -1457,14 +1335,14 @@ Qed.
(** Well-used function called bpow for computing the power function #&beta;#^e *)
Definition bpow e :=
match e with
- | Zpos p => Z2R (Zpower_pos r p)
- | Zneg p => Rinv (Z2R (Zpower_pos r p))
+ | Zpos p => IZR (Zpower_pos r p)
+ | Zneg p => Rinv (IZR (Zpower_pos r p))
| Z0 => 1%R
end.
-Theorem Z2R_Zpower_pos :
+Theorem IZR_Zpower_pos :
forall n m,
- Z2R (Zpower_pos n m) = powerRZ (Z2R n) (Zpos m).
+ IZR (Zpower_pos n m) = powerRZ (IZR n) (Zpos m).
Proof.
intros.
rewrite Zpower_pos_nat.
@@ -1473,19 +1351,19 @@ induction (nat_of_P m).
apply refl_equal.
unfold Zpower_nat.
simpl.
-rewrite Z2R_mult.
+rewrite mult_IZR.
apply Rmult_eq_compat_l.
exact IHn0.
Qed.
Theorem bpow_powerRZ :
forall e,
- bpow e = powerRZ (Z2R r) e.
+ bpow e = powerRZ (IZR r) e.
Proof.
destruct e ; unfold bpow.
reflexivity.
-now rewrite Z2R_Zpower_pos.
-now rewrite Z2R_Zpower_pos.
+now rewrite IZR_Zpower_pos.
+now rewrite IZR_Zpower_pos.
Qed.
Theorem bpow_ge_0 :
@@ -1517,14 +1395,14 @@ apply radix_pos.
Qed.
Theorem bpow_1 :
- bpow 1 = Z2R r.
+ bpow 1 = IZR r.
Proof.
unfold bpow, Zpower_pos. simpl.
now rewrite Zmult_1_r.
Qed.
-Theorem bpow_plus1 :
- forall e : Z, (bpow (e + 1) = Z2R r * bpow e)%R.
+Theorem bpow_plus_1 :
+ forall e : Z, (bpow (e + 1) = IZR r * bpow e)%R.
Proof.
intros.
rewrite <- bpow_1.
@@ -1544,9 +1422,9 @@ apply Rgt_not_eq.
apply (bpow_gt_0 (Zpos p)).
Qed.
-Theorem Z2R_Zpower_nat :
+Theorem IZR_Zpower_nat :
forall e : nat,
- Z2R (Zpower_nat r e) = bpow (Z_of_nat e).
+ IZR (Zpower_nat r e) = bpow (Z_of_nat e).
Proof.
intros [|e].
split.
@@ -1555,10 +1433,10 @@ rewrite <- Zpower_pos_nat.
now rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P.
Qed.
-Theorem Z2R_Zpower :
+Theorem IZR_Zpower :
forall e : Z,
(0 <= e)%Z ->
- Z2R (Zpower r e) = bpow e.
+ IZR (Zpower r e) = bpow e.
Proof.
intros [|e|e] H.
split.
@@ -1579,8 +1457,8 @@ apply bpow_gt_0.
assert (0 < e2 - e1)%Z by omega.
destruct (e2 - e1)%Z ; try discriminate H0.
clear.
-rewrite <- Z2R_Zpower by easy.
-apply (Z2R_lt 1).
+rewrite <- IZR_Zpower by easy.
+apply IZR_lt.
now apply Zpower_gt_1.
Qed.
@@ -1589,7 +1467,7 @@ Theorem lt_bpow :
(bpow e1 < bpow e2)%R -> (e1 < e2)%Z.
Proof.
intros e1 e2 H.
-apply Zgt_lt.
+apply Z.gt_lt.
apply Znot_le_gt.
intros H'.
apply Rlt_not_le with (1 := H).
@@ -1608,7 +1486,7 @@ intros e1 e2 H.
apply Rnot_lt_le.
intros H'.
apply Zle_not_gt with (1 := H).
-apply Zlt_gt.
+apply Z.lt_gt.
now apply lt_bpow.
Qed.
@@ -1621,7 +1499,7 @@ apply Znot_gt_le.
intros H'.
apply Rle_not_lt with (1 := H).
apply bpow_lt.
-now apply Zgt_lt.
+now apply Z.gt_lt.
Qed.
Theorem bpow_inj :
@@ -1638,15 +1516,15 @@ Qed.
Theorem bpow_exp :
forall e : Z,
- bpow e = exp (Z2R e * ln (Z2R r)).
+ bpow e = exp (IZR e * ln (IZR r)).
Proof.
(* positive case *)
-assert (forall e, bpow (Zpos e) = exp (Z2R (Zpos e) * ln (Z2R r))).
+assert (forall e, bpow (Zpos e) = exp (IZR (Zpos e) * ln (IZR r))).
intros e.
unfold bpow.
rewrite Zpower_pos_nat.
-unfold Z2R at 2.
-rewrite P2R_INR.
+rewrite <- positive_nat_Z.
+rewrite <- INR_IZR_INZ.
induction (nat_of_P e).
rewrite Rmult_0_l.
now rewrite exp_0.
@@ -1657,7 +1535,7 @@ rewrite exp_plus.
rewrite Rmult_1_l.
rewrite exp_ln.
rewrite <- IHn.
-rewrite <- Z2R_mult.
+rewrite <- mult_IZR.
now rewrite Zmult_comm.
apply radix_pos.
(* general case *)
@@ -1666,31 +1544,50 @@ rewrite Rmult_0_l.
now rewrite exp_0.
apply H.
unfold bpow.
-change (Z2R (Zpower_pos r e)) with (bpow (Zpos e)).
+change (IZR (Zpower_pos r e)) with (bpow (Zpos e)).
rewrite H.
rewrite <- exp_Ropp.
rewrite <- Ropp_mult_distr_l_reverse.
-now rewrite <- Z2R_opp.
+now rewrite <- opp_IZR.
+Qed.
+
+Lemma sqrt_bpow :
+ forall e,
+ sqrt (bpow (2 * e)) = bpow e.
+Proof.
+intro e.
+change 2%Z with (1 + 1)%Z; rewrite Z.mul_add_distr_r, Z.mul_1_l, bpow_plus.
+apply sqrt_square, bpow_ge_0.
Qed.
-(** Another well-used function for having the logarithm of a real number x to the base #&beta;# *)
-Record ln_beta_prop x := {
- ln_beta_val :> Z ;
- _ : (x <> 0)%R -> (bpow (ln_beta_val - 1)%Z <= Rabs x < bpow ln_beta_val)%R
+Lemma sqrt_bpow_ge :
+ forall e,
+ (bpow (e / 2) <= sqrt (bpow e))%R.
+Proof.
+intro e.
+rewrite <- (sqrt_square (bpow _)); [|now apply bpow_ge_0].
+apply sqrt_le_1_alt; rewrite <- bpow_plus; apply bpow_le.
+now replace (_ + _)%Z with (2 * (e / 2))%Z by ring; apply Z_mult_div_ge.
+Qed.
+
+(** Another well-used function for having the magnitude of a real number x to the base #&beta;# *)
+Record mag_prop x := {
+ mag_val :> Z ;
+ _ : (x <> 0)%R -> (bpow (mag_val - 1)%Z <= Rabs x < bpow mag_val)%R
}.
-Definition ln_beta :
- forall x : R, ln_beta_prop x.
+Definition mag :
+ forall x : R, mag_prop x.
Proof.
intros x.
-set (fact := ln (Z2R r)).
+set (fact := ln (IZR r)).
(* . *)
assert (0 < fact)%R.
apply exp_lt_inv.
rewrite exp_0.
unfold fact.
rewrite exp_ln.
-apply (Z2R_lt 1).
+apply IZR_lt.
apply radix_gt_1.
apply radix_pos.
(* . *)
@@ -1703,19 +1600,19 @@ rewrite 2!bpow_exp.
fold fact.
pattern x at 2 3 ; replace x with (exp (ln x * / fact * fact)).
split.
-rewrite Z2R_minus.
+rewrite minus_IZR.
apply exp_le.
apply Rmult_le_compat_r.
now apply Rlt_le.
unfold Rminus.
-rewrite Z2R_plus.
+rewrite plus_IZR.
rewrite Rplus_assoc.
rewrite Rplus_opp_r, Rplus_0_r.
apply Zfloor_lb.
apply exp_increasing.
apply Rmult_lt_compat_r.
exact H.
-rewrite Z2R_plus.
+rewrite plus_IZR.
apply Zfloor_ub.
rewrite Rmult_assoc.
rewrite Rinv_l.
@@ -1748,55 +1645,55 @@ apply Zle_antisym ;
assumption.
Qed.
-Theorem ln_beta_unique :
+Theorem mag_unique :
forall (x : R) (e : Z),
(bpow (e - 1) <= Rabs x < bpow e)%R ->
- ln_beta x = e :> Z.
+ mag x = e :> Z.
Proof.
intros x e1 He.
destruct (Req_dec x 0) as [Hx|Hx].
elim Rle_not_lt with (1 := proj1 He).
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
-destruct (ln_beta x) as (e2, Hx2).
+destruct (mag x) as (e2, Hx2).
simpl.
apply bpow_unique with (2 := He).
now apply Hx2.
Qed.
-Theorem ln_beta_opp :
+Theorem mag_opp :
forall x,
- ln_beta (-x) = ln_beta x :> Z.
+ mag (-x) = mag x :> Z.
Proof.
intros x.
destruct (Req_dec x 0) as [Hx|Hx].
now rewrite Hx, Ropp_0.
-destruct (ln_beta x) as (e, He).
+destruct (mag x) as (e, He).
simpl.
specialize (He Hx).
-apply ln_beta_unique.
+apply mag_unique.
now rewrite Rabs_Ropp.
Qed.
-Theorem ln_beta_abs :
+Theorem mag_abs :
forall x,
- ln_beta (Rabs x) = ln_beta x :> Z.
+ mag (Rabs x) = mag x :> Z.
Proof.
intros x.
unfold Rabs.
case Rcase_abs ; intros _.
-apply ln_beta_opp.
+apply mag_opp.
apply refl_equal.
Qed.
-Theorem ln_beta_unique_pos :
+Theorem mag_unique_pos :
forall (x : R) (e : Z),
(bpow (e - 1) <= x < bpow e)%R ->
- ln_beta x = e :> Z.
+ mag x = e :> Z.
Proof.
intros x e1 He1.
-rewrite <- ln_beta_abs.
-apply ln_beta_unique.
+rewrite <- mag_abs.
+apply mag_unique.
rewrite 2!Rabs_pos_eq.
exact He1.
apply Rle_trans with (2 := proj1 He1).
@@ -1804,14 +1701,14 @@ apply bpow_ge_0.
apply Rabs_pos.
Qed.
-Theorem ln_beta_le_abs :
+Theorem mag_le_abs :
forall x y,
(x <> 0)%R -> (Rabs x <= Rabs y)%R ->
- (ln_beta x <= ln_beta y)%Z.
+ (mag x <= mag y)%Z.
Proof.
intros x y H0x Hxy.
-destruct (ln_beta x) as (ex, Hx).
-destruct (ln_beta y) as (ey, Hy).
+destruct (mag x) as (ex, Hx).
+destruct (mag y) as (ey, Hy).
simpl.
apply bpow_lt_bpow.
specialize (Hx H0x).
@@ -1825,13 +1722,13 @@ rewrite Hy', Rabs_R0.
apply Rle_refl.
Qed.
-Theorem ln_beta_le :
+Theorem mag_le :
forall x y,
(0 < x)%R -> (x <= y)%R ->
- (ln_beta x <= ln_beta y)%Z.
+ (mag x <= mag y)%Z.
Proof.
intros x y H0x Hxy.
-apply ln_beta_le_abs.
+apply mag_le_abs.
now apply Rgt_not_eq.
rewrite 2!Rabs_pos_eq.
exact Hxy.
@@ -1840,17 +1737,17 @@ now apply Rlt_le.
now apply Rlt_le.
Qed.
-Lemma ln_beta_lt_pos :
+Lemma lt_mag :
forall x y,
(0 < y)%R ->
- (ln_beta x < ln_beta y)%Z -> (x < y)%R.
+ (mag x < mag y)%Z -> (x < y)%R.
Proof.
intros x y Py.
case (Rle_or_lt x 0); intros Px.
intros H.
now apply Rle_lt_trans with 0%R.
-destruct (ln_beta x) as (ex, Hex).
-destruct (ln_beta y) as (ey, Hey).
+destruct (mag x) as (ex, Hex).
+destruct (mag y) as (ey, Hey).
simpl.
intro H.
destruct Hex as (_,Hex); [now apply Rgt_not_eq|].
@@ -1862,11 +1759,11 @@ apply Rle_trans with (bpow (ey - 1)); [|exact Hey].
now apply bpow_le; omega.
Qed.
-Theorem ln_beta_bpow :
- forall e, (ln_beta (bpow e) = e + 1 :> Z)%Z.
+Theorem mag_bpow :
+ forall e, (mag (bpow e) = e + 1 :> Z)%Z.
Proof.
intros e.
-apply ln_beta_unique.
+apply mag_unique.
rewrite Rabs_right.
replace (e + 1 - 1)%Z with e by ring.
split.
@@ -1877,14 +1774,14 @@ apply Rle_ge.
apply bpow_ge_0.
Qed.
-Theorem ln_beta_mult_bpow :
+Theorem mag_mult_bpow :
forall x e, x <> 0%R ->
- (ln_beta (x * bpow e) = ln_beta x + e :>Z)%Z.
+ (mag (x * bpow e) = mag x + e :>Z)%Z.
Proof.
intros x e Zx.
-destruct (ln_beta x) as (ex, Ex) ; simpl.
+destruct (mag x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
-apply ln_beta_unique.
+apply mag_unique.
rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow e)) by apply bpow_ge_0.
split.
@@ -1899,26 +1796,26 @@ apply bpow_gt_0.
apply Ex.
Qed.
-Theorem ln_beta_le_bpow :
+Theorem mag_le_bpow :
forall x e,
x <> 0%R ->
(Rabs x < bpow e)%R ->
- (ln_beta x <= e)%Z.
+ (mag x <= e)%Z.
Proof.
intros x e Zx Hx.
-destruct (ln_beta x) as (ex, Ex) ; simpl.
+destruct (mag x) as (ex, Ex) ; simpl.
specialize (Ex Zx).
apply bpow_lt_bpow.
now apply Rle_lt_trans with (Rabs x).
Qed.
-Theorem ln_beta_gt_bpow :
+Theorem mag_gt_bpow :
forall x e,
(bpow e <= Rabs x)%R ->
- (e < ln_beta x)%Z.
+ (e < mag x)%Z.
Proof.
intros x e Hx.
-destruct (ln_beta x) as (ex, Ex) ; simpl.
+destruct (mag x) as (ex, Ex) ; simpl.
apply lt_bpow.
apply Rle_lt_trans with (1 := Hx).
apply Ex.
@@ -1928,92 +1825,92 @@ rewrite Zx, Rabs_R0.
apply bpow_gt_0.
Qed.
-Theorem ln_beta_ge_bpow :
+Theorem mag_ge_bpow :
forall x e,
(bpow (e - 1) <= Rabs x)%R ->
- (e <= ln_beta x)%Z.
+ (e <= mag x)%Z.
Proof.
intros x e H.
destruct (Rlt_or_le (Rabs x) (bpow e)) as [Hxe|Hxe].
- (* Rabs x w bpow e *)
- assert (ln_beta x = e :> Z) as Hln.
- now apply ln_beta_unique; split.
+ assert (mag x = e :> Z) as Hln.
+ now apply mag_unique; split.
rewrite Hln.
now apply Z.le_refl.
- (* bpow e <= Rabs x *)
apply Zlt_le_weak.
- now apply ln_beta_gt_bpow.
+ now apply mag_gt_bpow.
Qed.
-Theorem bpow_ln_beta_gt :
+Theorem bpow_mag_gt :
forall x,
- (Rabs x < bpow (ln_beta x))%R.
+ (Rabs x < bpow (mag x))%R.
Proof.
intros x.
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx, Rabs_R0.
apply bpow_gt_0.
-destruct (ln_beta x) as (ex, Ex) ; simpl.
+destruct (mag x) as (ex, Ex) ; simpl.
now apply Ex.
Qed.
-Theorem bpow_ln_beta_le :
+Theorem bpow_mag_le :
forall x, (x <> 0)%R ->
- (bpow (ln_beta x-1) <= Rabs x)%R.
+ (bpow (mag x-1) <= Rabs x)%R.
Proof.
intros x Hx.
-destruct (ln_beta x) as (ex, Ex) ; simpl.
+destruct (mag x) as (ex, Ex) ; simpl.
now apply Ex.
Qed.
-Theorem ln_beta_le_Zpower :
+Theorem mag_le_Zpower :
forall m e,
m <> Z0 ->
- (Zabs m < Zpower r e)%Z->
- (ln_beta (Z2R m) <= e)%Z.
+ (Z.abs m < Zpower r e)%Z->
+ (mag (IZR m) <= e)%Z.
Proof.
intros m e Zm Hm.
-apply ln_beta_le_bpow.
-exact (Z2R_neq m 0 Zm).
+apply mag_le_bpow.
+now apply IZR_neq.
destruct (Zle_or_lt 0 e).
-rewrite <- Z2R_abs, <- Z2R_Zpower with (1 := H).
-now apply Z2R_lt.
+rewrite <- abs_IZR, <- IZR_Zpower with (1 := H).
+now apply IZR_lt.
elim Zm.
-cut (Zabs m < 0)%Z.
+cut (Z.abs m < 0)%Z.
now case m.
clear -Hm H.
now destruct e.
Qed.
-Theorem ln_beta_gt_Zpower :
+Theorem mag_gt_Zpower :
forall m e,
m <> Z0 ->
- (Zpower r e <= Zabs m)%Z ->
- (e < ln_beta (Z2R m))%Z.
+ (Zpower r e <= Z.abs m)%Z ->
+ (e < mag (IZR m))%Z.
Proof.
intros m e Zm Hm.
-apply ln_beta_gt_bpow.
-rewrite <- Z2R_abs.
+apply mag_gt_bpow.
+rewrite <- abs_IZR.
destruct (Zle_or_lt 0 e).
-rewrite <- Z2R_Zpower with (1 := H).
-now apply Z2R_le.
+rewrite <- IZR_Zpower with (1 := H).
+now apply IZR_le.
apply Rle_trans with (bpow 0).
apply bpow_le.
now apply Zlt_le_weak.
-apply (Z2R_le 1).
+apply IZR_le.
clear -Zm.
zify ; omega.
Qed.
-Lemma ln_beta_mult :
+Lemma mag_mult :
forall x y,
(x <> 0)%R -> (y <> 0)%R ->
- (ln_beta x + ln_beta y - 1 <= ln_beta (x * y) <= ln_beta x + ln_beta y)%Z.
+ (mag x + mag y - 1 <= mag (x * y) <= mag x + mag y)%Z.
Proof.
intros x y Hx Hy.
-destruct (ln_beta x) as (ex, Hx2).
-destruct (ln_beta y) as (ey, Hy2).
+destruct (mag x) as (ex, Hx2).
+destruct (mag y) as (ey, Hy2).
simpl.
destruct (Hx2 Hx) as (Hx21,Hx22); clear Hx2.
destruct (Hy2 Hy) as (Hy21,Hy22); clear Hy2.
@@ -2029,26 +1926,26 @@ assert (Hxy2 : (Rabs (x * y) < bpow (ex + ey))%R).
now apply Rle_trans with (bpow (ex - 1)); try apply bpow_ge_0.
now apply Rle_trans with (bpow (ey - 1)); try apply bpow_ge_0. }
split.
-- now apply ln_beta_ge_bpow.
-- apply ln_beta_le_bpow.
+- now apply mag_ge_bpow.
+- apply mag_le_bpow.
+ now apply Rmult_integral_contrapositive_currified.
+ assumption.
Qed.
-Lemma ln_beta_plus :
+Lemma mag_plus :
forall x y,
(0 < y)%R -> (y <= x)%R ->
- (ln_beta x <= ln_beta (x + y) <= ln_beta x + 1)%Z.
+ (mag x <= mag (x + y) <= mag x + 1)%Z.
Proof.
assert (Hr : (2 <= r)%Z).
{ destruct r as (beta_val,beta_prop).
now apply Zle_bool_imp_le. }
intros x y Hy Hxy.
assert (Hx : (0 < x)%R) by apply (Rlt_le_trans _ _ _ Hy Hxy).
-destruct (ln_beta x) as (ex,Hex); simpl.
+destruct (mag x) as (ex,Hex); simpl.
destruct Hex as (Hex0,Hex1); [now apply Rgt_not_eq|].
assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R).
-{ rewrite bpow_plus1.
+{ rewrite bpow_plus_1.
apply Rlt_le_trans with (2 * bpow ex)%R.
- rewrite Rabs_pos_eq.
apply Rle_lt_trans with (2 * Rabs x)%R.
@@ -2062,7 +1959,7 @@ assert (Haxy : (Rabs (x + y) < bpow (ex + 1))%R).
now apply Rlt_le, Rplus_lt_compat.
- apply Rmult_le_compat_r.
now apply bpow_ge_0.
- now apply (Z2R_le 2). }
+ now apply IZR_le. }
assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R).
{ apply (Rle_trans _ _ _ Hex0).
rewrite Rabs_right; [|now apply Rgt_ge].
@@ -2071,20 +1968,20 @@ assert (Haxy2 : (bpow (ex - 1) <= Rabs (x + y))%R).
apply Rplus_le_compat_l.
now apply Rlt_le. }
split.
-- now apply ln_beta_ge_bpow.
-- apply ln_beta_le_bpow.
+- now apply mag_ge_bpow.
+- apply mag_le_bpow.
+ now apply tech_Rplus; [apply Rlt_le|].
+ exact Haxy.
Qed.
-Lemma ln_beta_minus :
+Lemma mag_minus :
forall x y,
(0 < y)%R -> (y < x)%R ->
- (ln_beta (x - y) <= ln_beta x)%Z.
+ (mag (x - y) <= mag x)%Z.
Proof.
intros x y Py Hxy.
assert (Px : (0 < x)%R) by apply (Rlt_trans _ _ _ Py Hxy).
-apply ln_beta_le.
+apply mag_le.
- now apply Rlt_Rminus.
- rewrite <- (Rplus_0_r x) at 2.
apply Rplus_le_compat_l.
@@ -2092,19 +1989,19 @@ apply ln_beta_le.
now apply Ropp_le_contravar; apply Rlt_le.
Qed.
-Lemma ln_beta_minus_lb :
+Lemma mag_minus_lb :
forall x y,
(0 < x)%R -> (0 < y)%R ->
- (ln_beta y <= ln_beta x - 2)%Z ->
- (ln_beta x - 1 <= ln_beta (x - y))%Z.
+ (mag y <= mag x - 2)%Z ->
+ (mag x - 1 <= mag (x - y))%Z.
Proof.
assert (Hbeta : (2 <= r)%Z).
{ destruct r as (beta_val,beta_prop).
now apply Zle_bool_imp_le. }
intros x y Px Py Hln.
-assert (Oxy : (y < x)%R); [apply ln_beta_lt_pos;[assumption|omega]|].
-destruct (ln_beta x) as (ex,Hex).
-destruct (ln_beta y) as (ey,Hey).
+assert (Oxy : (y < x)%R); [apply lt_mag;[assumption|omega]|].
+destruct (mag x) as (ex,Hex).
+destruct (mag y) as (ey,Hey).
simpl in Hln |- *.
destruct Hex as (Hex,_); [now apply Rgt_not_eq|].
destruct Hey as (_,Hey); [now apply Rgt_not_eq|].
@@ -2112,9 +2009,9 @@ assert (Hbx : (bpow (ex - 2) + bpow (ex - 2) <= x)%R).
{ ring_simplify.
apply Rle_trans with (bpow (ex - 1)).
- replace (ex - 1)%Z with (ex - 2 + 1)%Z by ring.
- rewrite bpow_plus1.
+ rewrite bpow_plus_1.
apply Rmult_le_compat_r; [now apply bpow_ge_0|].
- now change 2%R with (Z2R 2); apply Z2R_le.
+ now apply IZR_le.
- now rewrite Rabs_right in Hex; [|apply Rle_ge; apply Rlt_le]. }
assert (Hby : (y < bpow (ex - 2))%R).
{ apply Rlt_le_trans with (bpow ey).
@@ -2126,98 +2023,95 @@ assert (Hbxy : (bpow (ex - 2) <= x - y)%R).
replace (bpow (ex - 2))%R with (bpow (ex - 2) + bpow (ex - 2)
- bpow (ex - 2))%R by ring.
now apply Rplus_le_compat. }
-apply ln_beta_ge_bpow.
+apply mag_ge_bpow.
replace (ex - 1 - 1)%Z with (ex - 2)%Z by ring.
now apply Rabs_ge; right.
Qed.
-Lemma ln_beta_div :
+Lemma mag_div :
forall x y : R,
- (0 < x)%R -> (0 < y)%R ->
- (ln_beta x - ln_beta y <= ln_beta (x / y) <= ln_beta x - ln_beta y + 1)%Z.
+ x <> 0%R -> y <> 0%R ->
+ (mag x - mag y <= mag (x / y) <= mag x - mag y + 1)%Z.
Proof.
intros x y Px Py.
-destruct (ln_beta x) as (ex,Hex).
-destruct (ln_beta y) as (ey,Hey).
+destruct (mag x) as (ex,Hex).
+destruct (mag y) as (ey,Hey).
simpl.
unfold Rdiv.
-rewrite Rabs_right in Hex; [|now apply Rle_ge; apply Rlt_le].
-rewrite Rabs_right in Hey; [|now apply Rle_ge; apply Rlt_le].
-assert (Heiy : (bpow (- ey) < / y <= bpow (- ey + 1))%R).
-{ split.
+assert (Heiy : (bpow (- ey) < Rabs (/ y) <= bpow (- ey + 1))%R).
+{ rewrite Rabs_Rinv by easy.
+ split.
- rewrite bpow_opp.
apply Rinv_lt_contravar.
- + apply Rmult_lt_0_compat; [exact Py|].
+ + apply Rmult_lt_0_compat.
+ now apply Rabs_pos_lt.
now apply bpow_gt_0.
- + apply Hey.
- now apply Rgt_not_eq.
+ + now apply Hey.
- replace (_ + _)%Z with (- (ey - 1))%Z by ring.
rewrite bpow_opp.
apply Rinv_le; [now apply bpow_gt_0|].
- apply Hey.
- now apply Rgt_not_eq. }
+ now apply Hey. }
split.
-- apply ln_beta_ge_bpow.
- apply Rabs_ge; right.
+- apply mag_ge_bpow.
replace (_ - _)%Z with (ex - 1 - ey)%Z by ring.
unfold Zminus at 1; rewrite bpow_plus.
+ rewrite Rabs_mult.
apply Rmult_le_compat.
+ now apply bpow_ge_0.
+ now apply bpow_ge_0.
- + apply Hex.
- now apply Rgt_not_eq.
- + apply Rlt_le; apply Heiy.
-- assert (Pxy : (0 < x * / y)%R).
- { apply Rmult_lt_0_compat; [exact Px|].
- now apply Rinv_0_lt_compat. }
- apply ln_beta_le_bpow.
- + now apply Rgt_not_eq.
- + rewrite Rabs_right; [|now apply Rle_ge; apply Rlt_le].
- replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring.
+ + now apply Hex.
+ + now apply Rlt_le; apply Heiy.
+- apply mag_le_bpow.
+ + apply Rmult_integral_contrapositive_currified.
+ exact Px.
+ now apply Rinv_neq_0_compat.
+ + replace (_ + 1)%Z with (ex + (- ey + 1))%Z by ring.
rewrite bpow_plus.
- apply Rlt_le_trans with (bpow ex * / y)%R.
- * apply Rmult_lt_compat_r; [now apply Rinv_0_lt_compat|].
- apply Hex.
- now apply Rgt_not_eq.
+ apply Rlt_le_trans with (bpow ex * Rabs (/ y))%R.
+ * rewrite Rabs_mult.
+ apply Rmult_lt_compat_r.
+ apply Rabs_pos_lt.
+ now apply Rinv_neq_0_compat.
+ now apply Hex.
* apply Rmult_le_compat_l; [now apply bpow_ge_0|].
apply Heiy.
Qed.
-Lemma ln_beta_sqrt :
+Lemma mag_sqrt :
forall x,
(0 < x)%R ->
- (2 * ln_beta (sqrt x) - 1 <= ln_beta x <= 2 * ln_beta (sqrt x))%Z.
+ mag (sqrt x) = Z.div2 (mag x + 1) :> Z.
Proof.
intros x Px.
-assert (H : (bpow (2 * ln_beta (sqrt x) - 1 - 1) <= Rabs x
- < bpow (2 * ln_beta (sqrt x)))%R).
-{ split.
- - apply Rge_le; rewrite <- (sqrt_def x) at 1;
- [|now apply Rlt_le]; apply Rle_ge.
- rewrite Rabs_mult.
- replace (_ - _)%Z with (ln_beta (sqrt x) - 1
- + (ln_beta (sqrt x) - 1))%Z by ring.
- rewrite bpow_plus.
- assert (H : (bpow (ln_beta (sqrt x) - 1) <= Rabs (sqrt x))%R).
- { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl.
- apply Hesx.
- apply Rgt_not_eq; apply Rlt_gt.
- now apply sqrt_lt_R0. }
- now apply Rmult_le_compat; [now apply bpow_ge_0|now apply bpow_ge_0| |].
- - rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le].
- rewrite Rabs_mult.
- change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l;
- rewrite Zmult_1_l.
- rewrite bpow_plus.
- assert (H : (Rabs (sqrt x) < bpow (ln_beta (sqrt x)))%R).
- { destruct (ln_beta (sqrt x)) as (esx,Hesx); simpl.
- apply Hesx.
- apply Rgt_not_eq; apply Rlt_gt.
- now apply sqrt_lt_R0. }
- now apply Rmult_lt_compat; [now apply Rabs_pos|now apply Rabs_pos| |]. }
+apply mag_unique.
+destruct mag as [e He].
+simpl.
+specialize (He (Rgt_not_eq _ _ Px)).
+rewrite Rabs_pos_eq in He by now apply Rlt_le.
split.
-- now apply ln_beta_ge_bpow.
-- now apply ln_beta_le_bpow; [now apply Rgt_not_eq|].
+- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
+ apply Rsqr_le_abs_0.
+ rewrite Rsqr_sqrt by now apply Rlt_le.
+ apply Rle_trans with (2 := proj1 He).
+ unfold Rsqr ; rewrite <- bpow_plus.
+ apply bpow_le.
+ generalize (Zdiv2_odd_eqn (e + 1)).
+ destruct Z.odd ; intros ; omega.
+- rewrite <- (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
+ apply Rsqr_lt_abs_0.
+ rewrite Rsqr_sqrt by now apply Rlt_le.
+ apply Rlt_le_trans with (1 := proj2 He).
+ unfold Rsqr ; rewrite <- bpow_plus.
+ apply bpow_le.
+ generalize (Zdiv2_odd_eqn (e + 1)).
+ destruct Z.odd ; intros ; omega.
+Qed.
+
+Lemma mag_1 : mag 1 = 1%Z :> Z.
+Proof.
+apply mag_unique_pos; rewrite bpow_1; simpl; split; [now right|apply IZR_lt].
+assert (H := Zle_bool_imp_le _ _ (radix_prop r)); revert H.
+now apply Z.lt_le_trans.
Qed.
End pow.
@@ -2248,12 +2142,12 @@ Section cond_Ropp.
Definition cond_Ropp (b : bool) m := if b then Ropp m else m.
-Theorem Z2R_cond_Zopp :
+Theorem IZR_cond_Zopp :
forall b m,
- Z2R (cond_Zopp b m) = cond_Ropp b (Z2R m).
+ IZR (cond_Zopp b m) = cond_Ropp b (IZR m).
Proof.
intros [|] m.
-apply Z2R_opp.
+apply opp_IZR.
apply refl_equal.
Qed.
@@ -2286,22 +2180,6 @@ apply Ropp_involutive.
apply refl_equal.
Qed.
-Theorem cond_Ropp_even_function :
- forall {A : Type} (f : R -> A),
- (forall x, f (Ropp x) = f x) ->
- forall b x, f (cond_Ropp b x) = f x.
-Proof.
-now intros A f Hf [|] x ; simpl.
-Qed.
-
-Theorem cond_Ropp_odd_function :
- forall (f : R -> R),
- (forall x, f (Ropp x) = Ropp (f x)) ->
- forall b x, f (cond_Ropp b x) = cond_Ropp b (f x).
-Proof.
-now intros f Hf [|] x ; simpl.
-Qed.
-
Theorem cond_Ropp_inj :
forall b x y,
cond_Ropp b x = cond_Ropp b y -> x = y.
@@ -2391,7 +2269,7 @@ destruct (Rle_lt_dec l 0) as [Hl|Hl].
apply ub.
now apply HE.
left.
-set (N := Zabs_nat (up (/l) - 2)).
+set (N := Z.abs_nat (up (/l) - 2)).
exists N.
assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R).
unfold N.
@@ -2399,7 +2277,7 @@ assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R).
rewrite inj_Zabs_nat.
replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R.
apply (f_equal (fun v => IZR v + 1)%R).
- apply Zabs_eq.
+ apply Z.abs_eq.
apply Zle_minus_le_0.
apply (Zlt_le_succ 1).
apply lt_IZR.
@@ -2484,10 +2362,10 @@ intros n; apply H.
destruct K as (n, Hn).
left; now exists (-Z.of_nat n)%Z.
right; intros n; case (Zle_or_lt 0 n); intros M.
-rewrite <- (Zabs_eq n); trivial.
+rewrite <- (Z.abs_eq n); trivial.
rewrite <- Zabs2Nat.id_abs.
apply J.
-rewrite <- (Zopp_involutive n).
+rewrite <- (Z.opp_involutive n).
rewrite <- (Z.abs_neq n).
rewrite <- Zabs2Nat.id_abs.
apply K.
diff --git a/flocq/Core/Fcore_rnd_ne.v b/flocq/Core/Round_NE.v
index 2d67e709..20b60ef5 100644
--- a/flocq/Core/Fcore_rnd_ne.v
+++ b/flocq/Core/Round_NE.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,14 +18,9 @@ COPYING file for more details.
*)
(** * Rounding to nearest, ties to even: existence, unicity... *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_float_prop.
-Require Import Fcore_ulp.
+Require Import Raux Defs Round_pred Generic_fmt Float_prop Ulp.
-Notation ZnearestE := (Znearest (fun x => negb (Zeven x))).
+Notation ZnearestE := (Znearest (fun x => negb (Z.even x))).
Section Fcore_rnd_NE.
@@ -38,10 +33,10 @@ Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Notation format := (generic_format beta fexp).
-Notation canonic := (canonic beta fexp).
+Notation canonical := (canonical beta fexp).
Definition NE_prop (_ : R) f :=
- exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = true.
+ exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = true.
Definition Rnd_NE_pt :=
Rnd_NG_pt format NE_prop.
@@ -50,20 +45,20 @@ Definition DN_UP_parity_pos_prop :=
forall x xd xu,
(0 < x)%R ->
~ format x ->
- canonic xd ->
- canonic xu ->
+ canonical xd ->
+ canonical xu ->
F2R xd = round beta fexp Zfloor x ->
F2R xu = round beta fexp Zceil x ->
- Zeven (Fnum xu) = negb (Zeven (Fnum xd)).
+ Z.even (Fnum xu) = negb (Z.even (Fnum xd)).
Definition DN_UP_parity_prop :=
forall x xd xu,
~ format x ->
- canonic xd ->
- canonic xu ->
+ canonical xd ->
+ canonical xu ->
F2R xd = round beta fexp Zfloor x ->
F2R xu = round beta fexp Zceil x ->
- Zeven (Fnum xu) = negb (Zeven (Fnum xd)).
+ Z.even (Fnum xu) = negb (Z.even (Fnum xd)).
Lemma DN_UP_parity_aux :
DN_UP_parity_pos_prop ->
@@ -83,18 +78,18 @@ now rewrite Ropp_involutive, Ropp_0.
destruct xd as (md, ed).
destruct xu as (mu, eu).
simpl.
-rewrite <- (Bool.negb_involutive (Zeven mu)).
+rewrite <- (Bool.negb_involutive (Z.even mu)).
apply f_equal.
apply sym_eq.
-rewrite <- (Zeven_opp mu), <- (Zeven_opp md).
-change (Zeven (Fnum (Float beta (-md) ed)) = negb (Zeven (Fnum (Float beta (-mu) eu)))).
+rewrite <- (Z.even_opp mu), <- (Z.even_opp md).
+change (Z.even (Fnum (Float beta (-md) ed)) = negb (Z.even (Fnum (Float beta (-mu) eu)))).
apply (Hpos (-x)%R _ _ Hx').
intros H.
apply Hfx.
rewrite <- Ropp_involutive.
now apply generic_format_opp.
-now apply canonic_opp.
-now apply canonic_opp.
+now apply canonical_opp.
+now apply canonical_opp.
rewrite round_DN_opp, F2R_Zopp.
now apply f_equal.
rewrite round_UP_opp, F2R_Zopp.
@@ -102,7 +97,7 @@ now apply f_equal.
Qed.
Class Exists_NE :=
- exists_NE : Zeven beta = false \/ forall e,
+ exists_NE : Z.even beta = false \/ forall e,
((fexp e < e)%Z -> (fexp (e + 1) < e)%Z) /\ ((e <= fexp e)%Z -> fexp (fexp e + 1) = fexp e).
Context { exists_NE_ : Exists_NE }.
@@ -111,22 +106,22 @@ Theorem DN_UP_parity_generic_pos :
DN_UP_parity_pos_prop.
Proof with auto with typeclass_instances.
intros x xd xu H0x Hfx Hd Hu Hxd Hxu.
-destruct (ln_beta beta x) as (ex, Hexa).
+destruct (mag beta x) as (ex, Hexa).
specialize (Hexa (Rgt_not_eq _ _ H0x)).
generalize Hexa. intros Hex.
rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0x)) in Hex.
destruct (Zle_or_lt ex (fexp ex)) as [Hxe|Hxe].
(* small x *)
assert (Hd3 : Fnum xd = Z0).
-apply F2R_eq_0_reg with beta (Fexp xd).
+apply eq_0_F2R with beta (Fexp xd).
change (F2R xd = R0).
rewrite Hxd.
apply round_DN_small_pos with (1 := Hex) (2 := Hxe).
assert (Hu3 : xu = Float beta (1 * Zpower beta (fexp ex - fexp (fexp ex + 1))) (fexp (fexp ex + 1))).
-apply canonic_unicity with (1 := Hu).
+apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
-now rewrite F2R_bpow, ln_beta_bpow.
+now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- F2R_change_exp.
rewrite F2R_bpow.
@@ -172,10 +167,10 @@ rewrite Hxu.
apply round_bounded_large_pos...
(* - xu = bpow ex *)
assert (Hu3: xu = Float beta (1 * Zpower beta (ex - fexp (ex + 1))) (fexp (ex + 1))).
-apply canonic_unicity with (1 := Hu).
+apply canonical_unique with (1 := Hu).
apply (f_equal fexp).
rewrite <- F2R_change_exp.
-now rewrite F2R_bpow, ln_beta_bpow.
+now rewrite F2R_bpow, mag_bpow.
now apply valid_exp.
rewrite <- Hu2.
apply sym_eq.
@@ -185,15 +180,15 @@ exact Hxe2.
assert (Hd3: xd = Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex)).
assert (H: F2R xd = F2R (Float beta (Zpower beta (ex - fexp ex) - 1) (fexp ex))).
unfold F2R. simpl.
-rewrite Z2R_minus.
+rewrite minus_IZR.
unfold Rminus.
rewrite Rmult_plus_distr_r.
-rewrite Z2R_Zpower, <- bpow_plus.
+rewrite IZR_Zpower, <- bpow_plus.
ring_simplify (ex - fexp ex + fexp ex)%Z.
rewrite Hu2, Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
-unfold canonic_exp.
-rewrite ln_beta_unique with beta x ex.
+unfold cexp.
+rewrite mag_unique with beta x ex.
unfold F2R.
simpl. ring.
rewrite Rabs_pos_eq.
@@ -201,25 +196,25 @@ exact Hex.
now apply Rlt_le.
apply Zle_minus_le_0.
now apply Zlt_le_weak.
-apply canonic_unicity with (1 := Hd) (3 := H).
+apply canonical_unique with (1 := Hd) (3 := H).
apply (f_equal fexp).
rewrite <- H.
apply sym_eq.
-now apply ln_beta_unique.
+now apply mag_unique.
rewrite Hd3, Hu3.
unfold Fnum.
-rewrite Zeven_mult. simpl.
+rewrite Z.even_mul. simpl.
unfold Zminus at 2.
-rewrite Zeven_plus.
+rewrite Z.even_add.
rewrite eqb_sym. simpl.
-fold (negb (Zeven (beta ^ (ex - fexp ex)))).
+fold (negb (Z.even (beta ^ (ex - fexp ex)))).
rewrite Bool.negb_involutive.
-rewrite (Zeven_Zpower beta (ex - fexp ex)). 2: omega.
+rewrite (Z.even_pow beta (ex - fexp ex)). 2: omega.
destruct exists_NE_.
rewrite H.
apply Zeven_Zpower_odd with (2 := H).
now apply Zle_minus_le_0.
-apply Zeven_Zpower.
+apply Z.even_pow.
specialize (H ex).
omega.
(* - xu < bpow ex *)
@@ -227,17 +222,17 @@ revert Hud.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
unfold F2R.
rewrite Hd, Hu.
-unfold canonic_exp.
-rewrite ln_beta_unique with beta (F2R xu) ex.
-rewrite ln_beta_unique with (1 := Hd4).
-rewrite ln_beta_unique with (1 := Hexa).
+unfold cexp.
+rewrite mag_unique with beta (F2R xu) ex.
+rewrite mag_unique with (1 := Hd4).
+rewrite mag_unique with (1 := Hexa).
intros H.
replace (Fnum xu) with (Fnum xd + 1)%Z.
-rewrite Zeven_plus.
+rewrite Z.even_add.
now apply eqb_sym.
apply sym_eq.
-apply eq_Z2R.
-rewrite Z2R_plus.
+apply eq_IZR.
+rewrite plus_IZR.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
rewrite H.
simpl. ring.
@@ -270,38 +265,38 @@ now apply generic_format_satisfies_any.
intros x d u Hf Hd Hu.
generalize (proj1 Hd).
unfold generic_format.
-set (ed := canonic_exp beta fexp d).
+set (ed := cexp beta fexp d).
set (md := Ztrunc (scaled_mantissa beta fexp d)).
intros Hd1.
-case_eq (Zeven md) ; [ intros He | intros Ho ].
+case_eq (Z.even md) ; [ intros He | intros Ho ].
right.
exists (Float beta md ed).
-unfold Fcore_generic_fmt.canonic.
+unfold Generic_fmt.canonical.
rewrite <- Hd1.
now repeat split.
left.
generalize (proj1 Hu).
unfold generic_format.
-set (eu := canonic_exp beta fexp u).
+set (eu := cexp beta fexp u).
set (mu := Ztrunc (scaled_mantissa beta fexp u)).
intros Hu1.
rewrite Hu1.
eexists ; repeat split.
-unfold Fcore_generic_fmt.canonic.
+unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite (DN_UP_parity_generic x (Float beta md ed) (Float beta mu eu)).
simpl.
now rewrite Ho.
exact Hf.
-unfold Fcore_generic_fmt.canonic.
+unfold Generic_fmt.canonical.
now rewrite <- Hd1.
-unfold Fcore_generic_fmt.canonic.
+unfold Generic_fmt.canonical.
now rewrite <- Hu1.
rewrite <- Hd1.
-apply Rnd_DN_pt_unicity with (1 := Hd).
+apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
-apply Rnd_UP_pt_unicity with (1 := Hu).
+apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.
@@ -323,15 +318,16 @@ apply Hx.
apply sym_eq.
now apply Rnd_DN_pt_idempotent with (1 := Hd).
rewrite <- Hd1.
-apply Rnd_DN_pt_unicity with (1 := Hd).
+apply Rnd_DN_pt_unique with (1 := Hd).
now apply round_DN_pt.
rewrite <- Hu1.
-apply Rnd_UP_pt_unicity with (1 := Hu).
+apply Rnd_UP_pt_unique with (1 := Hu).
now apply round_UP_pt.
Qed.
Theorem Rnd_NE_pt_round :
round_pred Rnd_NE_pt.
+Proof.
split.
apply Rnd_NE_pt_total.
apply Rnd_NE_pt_monotone.
@@ -348,14 +344,14 @@ now apply round_N_pt.
unfold NE_prop.
set (mx := scaled_mantissa beta fexp x).
set (xr := round beta fexp ZnearestE x).
-destruct (Req_dec (mx - Z2R (Zfloor mx)) (/2)) as [Hm|Hm].
+destruct (Req_dec (mx - IZR (Zfloor mx)) (/2)) as [Hm|Hm].
(* midpoint *)
left.
-exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (canonic_exp beta fexp xr)).
+exists (Float beta (Ztrunc (scaled_mantissa beta fexp xr)) (cexp beta fexp xr)).
split.
apply round_N_pt...
split.
-unfold Fcore_generic_fmt.canonic. simpl.
+unfold Generic_fmt.canonical. simpl.
apply f_equal.
apply round_N_pt...
simpl.
@@ -363,23 +359,22 @@ unfold xr, round, Znearest.
fold mx.
rewrite Hm.
rewrite Rcompare_Eq. 2: apply refl_equal.
-case_eq (Zeven (Zfloor mx)) ; intros Hmx.
+case_eq (Z.even (Zfloor mx)) ; intros Hmx.
(* . even floor *)
-change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
+change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zfloor x))) = true).
destruct (Rle_or_lt (round beta fexp Zfloor x) 0) as [Hr|Hr].
rewrite (Rle_antisym _ _ Hr).
unfold scaled_mantissa.
rewrite Rmult_0_l.
-change 0%R with (Z2R 0).
-now rewrite (Ztrunc_Z2R 0).
+now rewrite Ztrunc_IZR.
rewrite <- (round_0 beta fexp Zfloor).
apply round_le...
now apply Rlt_le.
rewrite scaled_mantissa_DN...
-now rewrite Ztrunc_Z2R.
+now rewrite Ztrunc_IZR.
(* . odd floor *)
-change (Zeven (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
-destruct (ln_beta beta x) as (ex, Hex).
+change (Z.even (Ztrunc (scaled_mantissa beta fexp (round beta fexp Zceil x))) = true).
+destruct (mag beta x) as (ex, Hex).
specialize (Hex (Rgt_not_eq _ _ Hx)).
rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hx)) in Hex.
destruct (Z_lt_le_dec (fexp ex) ex) as [He|He].
@@ -394,56 +389,56 @@ rewrite Rplus_opp_r in Hm.
elim (Rlt_irrefl 0).
rewrite Hm at 2.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
destruct (proj2 Hu) as [Hu'|Hu'].
(* ... u <> bpow *)
unfold scaled_mantissa.
-rewrite canonic_exp_fexp_pos with (1 := conj (proj1 Hu) Hu').
+rewrite cexp_fexp_pos with (1 := conj (proj1 Hu) Hu').
unfold round, F2R. simpl.
-rewrite canonic_exp_fexp_pos with (1 := Hex).
+rewrite cexp_fexp_pos with (1 := Hex).
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-rewrite Ztrunc_Z2R.
+rewrite Ztrunc_IZR.
fold mx.
rewrite Hfc.
-now rewrite Zeven_plus, Hmx.
+now rewrite Z.even_add, Hmx.
(* ... u = bpow *)
rewrite Hu'.
-unfold scaled_mantissa, canonic_exp.
-rewrite ln_beta_bpow.
-rewrite <- bpow_plus, <- Z2R_Zpower.
-rewrite Ztrunc_Z2R.
-case_eq (Zeven beta) ; intros Hr.
+unfold scaled_mantissa, cexp.
+rewrite mag_bpow.
+rewrite <- bpow_plus, <- IZR_Zpower.
+rewrite Ztrunc_IZR.
+case_eq (Z.even beta) ; intros Hr.
destruct exists_NE_ as [Hs|Hs].
now rewrite Hs in Hr.
destruct (Hs ex) as (H,_).
-rewrite Zeven_Zpower.
+rewrite Z.even_pow.
exact Hr.
omega.
-assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx.
+assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
replace (Zfloor mx) with (Zceil mx + -1)%Z by omega.
-rewrite Zeven_plus.
+rewrite Z.even_add.
apply eqb_true.
unfold mx.
replace (Zceil (scaled_mantissa beta fexp x)) with (Zpower beta (ex - fexp ex)).
rewrite Zeven_Zpower_odd with (2 := Hr).
easy.
omega.
-apply eq_Z2R.
-rewrite Z2R_Zpower. 2: omega.
+apply eq_IZR.
+rewrite IZR_Zpower. 2: omega.
apply Rmult_eq_reg_r with (bpow (fexp ex)).
unfold Zminus.
rewrite bpow_plus.
rewrite Rmult_assoc, <- bpow_plus, Zplus_opp_l, Rmult_1_r.
-pattern (fexp ex) ; rewrite <- canonic_exp_fexp_pos with (1 := Hex).
+pattern (fexp ex) ; rewrite <- cexp_fexp_pos with (1 := Hex).
now apply sym_eq.
apply Rgt_not_eq.
apply bpow_gt_0.
generalize (proj1 (valid_exp ex) He).
omega.
(* .. small pos *)
-assert (Zeven (Zfloor mx) = true). 2: now rewrite H in Hmx.
+assert (Z.even (Zfloor mx) = true). 2: now rewrite H in Hmx.
unfold mx, scaled_mantissa.
-rewrite canonic_exp_fexp_pos with (1 := Hex).
+rewrite cexp_fexp_pos with (1 := Hex).
now rewrite mantissa_DN_small_pos.
(* not midpoint *)
right.
@@ -456,7 +451,7 @@ rewrite Hxg.
apply Hg.
set (d := round beta fexp Zfloor x).
set (u := round beta fexp Zceil x).
-apply Rnd_N_pt_unicity with (d := d) (u := u) (4 := Hg).
+apply Rnd_N_pt_unique with (d := d) (u := u) (4 := Hg).
now apply round_DN_pt.
now apply round_UP_pt.
2: now apply round_N_pt.
@@ -467,7 +462,7 @@ intros H.
apply Rmult_eq_reg_r in H.
apply Hm.
apply Rcompare_Eq_inv.
-rewrite Rcompare_floor_ceil_mid.
+rewrite Rcompare_floor_ceil_middle.
now apply Rcompare_Eq.
contradict Hxg.
apply sym_eq.
@@ -475,7 +470,7 @@ apply Rnd_N_pt_idempotent with (1 := Hg).
rewrite <- (scaled_mantissa_mult_bpow beta fexp x).
fold mx.
rewrite <- Hxg.
-change (Z2R (Zfloor mx) * bpow (canonic_exp beta fexp x))%R with d.
+change (IZR (Zfloor mx) * bpow (cexp beta fexp x))%R with d.
now eapply round_DN_pt.
apply Rgt_not_eq.
apply bpow_gt_0.
@@ -487,7 +482,7 @@ Theorem round_NE_opp :
Proof.
intros x.
unfold round. simpl.
-rewrite scaled_mantissa_opp, canonic_exp_opp.
+rewrite scaled_mantissa_opp, cexp_opp.
rewrite Znearest_opp.
rewrite <- F2R_Zopp.
apply (f_equal (fun v => F2R (Float beta (-v) _))).
@@ -496,8 +491,8 @@ unfold Znearest.
case Rcompare ; trivial.
apply (f_equal (fun (b : bool) => if b then Zceil m else Zfloor m)).
rewrite Bool.negb_involutive.
-rewrite Zeven_opp.
-rewrite Zeven_plus.
+rewrite Z.even_opp.
+rewrite Z.even_add.
now rewrite eqb_sym.
Qed.
@@ -526,7 +521,7 @@ Theorem round_NE_pt :
Proof with auto with typeclass_instances.
intros x.
destruct (total_order_T x 0) as [[Hx|Hx]|Hx].
-apply Rnd_NG_pt_sym.
+apply Rnd_NG_pt_opp_inv.
apply generic_format_opp.
unfold NE_prop.
intros _ f ((mg,eg),(H1,(H2,H3))).
@@ -534,9 +529,9 @@ exists (Float beta (- mg) eg).
repeat split.
rewrite H1.
now rewrite F2R_Zopp.
-now apply canonic_opp.
+now apply canonical_opp.
simpl.
-now rewrite Zeven_opp.
+now rewrite Z.even_opp.
rewrite <- round_NE_opp.
apply round_NE_pt_pos.
now apply Ropp_0_gt_lt_contravar.
diff --git a/flocq/Core/Fcore_rnd.v b/flocq/Core/Round_pred.v
index e5091684..428a4bac 100644
--- a/flocq/Core/Fcore_rnd.v
+++ b/flocq/Core/Round_pred.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,13 +18,30 @@ COPYING file for more details.
*)
(** * Roundings: properties and/or functions *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
+Require Import Raux Defs.
Section RND_prop.
Open Scope R_scope.
+Definition Rnd_DN (F : R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_DN_pt F x (rnd x).
+
+Definition Rnd_UP (F : R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_UP_pt F x (rnd x).
+
+Definition Rnd_ZR (F : R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_ZR_pt F x (rnd x).
+
+Definition Rnd_N (F : R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_N_pt F x (rnd x).
+
+Definition Rnd_NG (F : R -> Prop) (P : R -> R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_NG_pt F P x (rnd x).
+
+Definition Rnd_NA (F : R -> Prop) (rnd : R -> R) :=
+ forall x : R, Rnd_NA_pt F x (rnd x).
+
Theorem round_val_of_pred :
forall rnd : R -> R -> Prop,
round_pred rnd ->
@@ -63,7 +80,7 @@ intros x.
now destruct round_val_of_pred as (f, H1).
Qed.
-Theorem round_unicity :
+Theorem round_unique :
forall rnd : R -> R -> Prop,
round_pred_monotone rnd ->
forall x f1 f2,
@@ -87,25 +104,25 @@ apply Hx1.
now apply Rle_trans with (2 := Hxy).
Qed.
-Theorem Rnd_DN_pt_unicity :
+Theorem Rnd_DN_pt_unique :
forall F : R -> Prop,
forall x f1 f2 : R,
Rnd_DN_pt F x f1 -> Rnd_DN_pt F x f2 ->
f1 = f2.
Proof.
intros F.
-apply round_unicity.
+apply round_unique.
apply Rnd_DN_pt_monotone.
Qed.
-Theorem Rnd_DN_unicity :
+Theorem Rnd_DN_unique :
forall F : R -> Prop,
forall rnd1 rnd2 : R -> R,
Rnd_DN F rnd1 -> Rnd_DN F rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof.
intros F rnd1 rnd2 H1 H2 x.
-now eapply Rnd_DN_pt_unicity.
+now eapply Rnd_DN_pt_unique.
Qed.
Theorem Rnd_UP_pt_monotone :
@@ -118,28 +135,28 @@ apply Hy1.
now apply Rle_trans with (1 := Hxy).
Qed.
-Theorem Rnd_UP_pt_unicity :
+Theorem Rnd_UP_pt_unique :
forall F : R -> Prop,
forall x f1 f2 : R,
Rnd_UP_pt F x f1 -> Rnd_UP_pt F x f2 ->
f1 = f2.
Proof.
intros F.
-apply round_unicity.
+apply round_unique.
apply Rnd_UP_pt_monotone.
Qed.
-Theorem Rnd_UP_unicity :
+Theorem Rnd_UP_unique :
forall F : R -> Prop,
forall rnd1 rnd2 : R -> R,
Rnd_UP F rnd1 -> Rnd_UP F rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof.
intros F rnd1 rnd2 H1 H2 x.
-now eapply Rnd_UP_pt_unicity.
+now eapply Rnd_UP_pt_unique.
Qed.
-Theorem Rnd_DN_UP_pt_sym :
+Theorem Rnd_UP_pt_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
@@ -160,7 +177,7 @@ now apply HF.
now apply Ropp_le_cancel.
Qed.
-Theorem Rnd_UP_DN_pt_sym :
+Theorem Rnd_DN_pt_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
@@ -181,7 +198,7 @@ now apply HF.
now apply Ropp_le_cancel.
Qed.
-Theorem Rnd_DN_UP_sym :
+Theorem Rnd_DN_opp :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall rnd1 rnd2 : R -> R,
@@ -191,10 +208,10 @@ Proof.
intros F HF rnd1 rnd2 H1 H2 x.
rewrite <- (Ropp_involutive (rnd1 (-x))).
apply f_equal.
-apply (Rnd_UP_unicity F (fun x => - rnd1 (-x))) ; trivial.
+apply (Rnd_UP_unique F (fun x => - rnd1 (-x))) ; trivial.
intros y.
pattern y at 1 ; rewrite <- Ropp_involutive.
-apply Rnd_DN_UP_pt_sym.
+apply Rnd_UP_pt_opp.
apply HF.
apply H1.
Qed.
@@ -303,18 +320,17 @@ apply Rle_refl.
(* . *)
destruct (Rle_or_lt 0 x).
(* positive *)
-rewrite Rabs_right.
-rewrite Rabs_right; auto with real.
+rewrite Rabs_pos_eq with (1 := H1).
+rewrite Rabs_pos_eq.
now apply (proj1 (H x)).
-apply Rle_ge.
now apply (proj1 (H x)).
(* negative *)
+apply Rlt_le in H1.
+rewrite Rabs_left1 with (1 := H1).
rewrite Rabs_left1.
-rewrite Rabs_left1 ; auto with real.
apply Ropp_le_contravar.
-apply (proj2 (H x)).
-auto with real.
-apply (proj2 (H x)) ; auto with real.
+now apply (proj2 (H x)).
+now apply (proj2 (H x)).
Qed.
Theorem Rnd_ZR_pt_monotone :
@@ -385,12 +401,12 @@ Proof.
intros F x fd fu f Hd Hu Hf.
destruct (Rnd_N_pt_DN_or_UP F x f Hf) as [H|H].
left.
-apply Rnd_DN_pt_unicity with (1 := H) (2 := Hd).
+apply Rnd_DN_pt_unique with (1 := H) (2 := Hd).
right.
-apply Rnd_UP_pt_unicity with (1 := H) (2 := Hu).
+apply Rnd_UP_pt_unique with (1 := H) (2 := Hu).
Qed.
-Theorem Rnd_N_pt_sym :
+Theorem Rnd_N_pt_opp_inv :
forall F : R -> Prop,
( forall x, F x -> F (- x) ) ->
forall x f : R,
@@ -449,7 +465,7 @@ apply Rminus_lt.
ring_simplify.
apply Rlt_minus.
apply Rmult_lt_compat_l.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
exact Hxy.
now apply Rlt_minus.
apply Rle_0_minus.
@@ -460,7 +476,7 @@ now apply Rlt_le.
now apply Rlt_minus.
Qed.
-Theorem Rnd_N_pt_unicity :
+Theorem Rnd_N_pt_unique :
forall F : R -> Prop,
forall x d u f1 f2 : R,
Rnd_DN_pt F x d ->
@@ -476,10 +492,10 @@ clear f1 f2. intros f1 f2 Hf1 Hf2 H12.
destruct (Rnd_N_pt_DN_or_UP F x f1 Hf1) as [Hd1|Hu1] ;
destruct (Rnd_N_pt_DN_or_UP F x f2 Hf2) as [Hd2|Hu2].
apply Rlt_not_eq with (1 := H12).
-now apply Rnd_DN_pt_unicity with (1 := Hd1).
+now apply Rnd_DN_pt_unique with (1 := Hd1).
apply Hdu.
-rewrite Rnd_DN_pt_unicity with (1 := Hd) (2 := Hd1).
-rewrite Rnd_UP_pt_unicity with (1 := Hu) (2 := Hu2).
+rewrite Rnd_DN_pt_unique with (1 := Hd) (2 := Hd1).
+rewrite Rnd_UP_pt_unique with (1 := Hu) (2 := Hu2).
rewrite <- (Rabs_pos_eq (x - f1)).
rewrite <- (Rabs_pos_eq (f2 - x)).
rewrite Rabs_minus_sym.
@@ -495,7 +511,7 @@ apply Rle_trans with x.
apply Hd2.
apply Hu1.
apply Rgt_not_eq with (1 := H12).
-now apply Rnd_UP_pt_unicity with (1 := Hu2).
+now apply Rnd_UP_pt_unique with (1 := Hu2).
intros Hf1 Hf2.
now apply Rle_antisym ; apply Rnot_lt_le ; refine (H _ _ _ _).
Qed.
@@ -547,7 +563,7 @@ rewrite 2!Rminus_0_r, Rabs_R0.
apply Rabs_pos.
Qed.
-Theorem Rnd_N_pt_pos :
+Theorem Rnd_N_pt_ge_0 :
forall F : R -> Prop, F 0 ->
forall x f, 0 <= x ->
Rnd_N_pt F x f ->
@@ -563,7 +579,7 @@ now rewrite Hx.
exact HF.
Qed.
-Theorem Rnd_N_pt_neg :
+Theorem Rnd_N_pt_le_0 :
forall F : R -> Prop, F 0 ->
forall x f, x <= 0 ->
Rnd_N_pt F x f ->
@@ -589,20 +605,20 @@ intros F HF0 HF x f Hxf.
unfold Rabs at 1.
destruct (Rcase_abs x) as [Hx|Hx].
rewrite Rabs_left1.
-apply Rnd_N_pt_sym.
+apply Rnd_N_pt_opp_inv.
exact HF.
now rewrite 2!Ropp_involutive.
-apply Rnd_N_pt_neg with (3 := Hxf).
+apply Rnd_N_pt_le_0 with (3 := Hxf).
exact HF0.
now apply Rlt_le.
rewrite Rabs_pos_eq.
exact Hxf.
-apply Rnd_N_pt_pos with (3 := Hxf).
+apply Rnd_N_pt_ge_0 with (3 := Hxf).
exact HF0.
now apply Rge_le.
Qed.
-Theorem Rnd_DN_UP_pt_N :
+Theorem Rnd_N_pt_DN_UP :
forall F : R -> Prop,
forall x d u f : R,
F f ->
@@ -635,7 +651,7 @@ apply Rle_trans with (2 := Hgu).
apply Hxu.
Qed.
-Theorem Rnd_DN_pt_N :
+Theorem Rnd_N_pt_DN :
forall F : R -> Prop,
forall x d u : R,
Rnd_DN_pt F x d ->
@@ -649,14 +665,14 @@ rewrite Rabs_minus_sym.
apply Rabs_pos_eq.
apply Rle_0_minus.
apply Hd.
-apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu).
+apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu).
apply Hd.
rewrite Hdx.
apply Rle_refl.
now rewrite Hdx.
Qed.
-Theorem Rnd_UP_pt_N :
+Theorem Rnd_N_pt_UP :
forall F : R -> Prop,
forall x d u : R,
Rnd_DN_pt F x d ->
@@ -669,22 +685,22 @@ assert (Hux: (Rabs (u - x) = u - x)%R).
apply Rabs_pos_eq.
apply Rle_0_minus.
apply Hu.
-apply Rnd_DN_UP_pt_N with (2 := Hd) (3 := Hu).
+apply Rnd_N_pt_DN_UP with (2 := Hd) (3 := Hu).
apply Hu.
now rewrite Hux.
rewrite Hux.
apply Rle_refl.
Qed.
-Definition Rnd_NG_pt_unicity_prop F P :=
+Definition Rnd_NG_pt_unique_prop F P :=
forall x d u,
Rnd_DN_pt F x d -> Rnd_N_pt F x d ->
Rnd_UP_pt F x u -> Rnd_N_pt F x u ->
P x d -> P x u -> d = u.
-Theorem Rnd_NG_pt_unicity :
+Theorem Rnd_NG_pt_unique :
forall (F : R -> Prop) (P : R -> R -> Prop),
- Rnd_NG_pt_unicity_prop F P ->
+ Rnd_NG_pt_unique_prop F P ->
forall x f1 f2 : R,
Rnd_NG_pt F P x f1 -> Rnd_NG_pt F P x f2 ->
f1 = f2.
@@ -694,11 +710,11 @@ destruct H1b as [H1b|H1b].
destruct H2b as [H2b|H2b].
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1a) as [H1c|H1c] ;
destruct (Rnd_N_pt_DN_or_UP _ _ _ H2a) as [H2c|H2c].
-eapply Rnd_DN_pt_unicity ; eassumption.
+eapply Rnd_DN_pt_unique ; eassumption.
now apply (HP x f1 f2).
apply sym_eq.
now apply (HP x f2 f1 H2c H2a H1c H1a).
-eapply Rnd_UP_pt_unicity ; eassumption.
+eapply Rnd_UP_pt_unique ; eassumption.
now apply H2b.
apply sym_eq.
now apply H1b.
@@ -706,14 +722,14 @@ Qed.
Theorem Rnd_NG_pt_monotone :
forall (F : R -> Prop) (P : R -> R -> Prop),
- Rnd_NG_pt_unicity_prop F P ->
+ Rnd_NG_pt_unique_prop F P ->
round_pred_monotone (Rnd_NG_pt F P).
Proof.
intros F P HP x y f g (Hf,Hx) (Hg,Hy) [Hxy|Hxy].
now apply Rnd_N_pt_monotone with F x y.
apply Req_le.
rewrite <- Hxy in Hg, Hy.
-eapply Rnd_NG_pt_unicity ; try split ; eassumption.
+eapply Rnd_NG_pt_unique ; try split ; eassumption.
Qed.
Theorem Rnd_NG_pt_refl :
@@ -728,7 +744,7 @@ intros f2 Hf2.
now apply Rnd_N_pt_idempotent with F.
Qed.
-Theorem Rnd_NG_pt_sym :
+Theorem Rnd_NG_pt_opp_inv :
forall (F : R -> Prop) (P : R -> R -> Prop),
( forall x, F x -> F (-x) ) ->
( forall x f, P x f -> P (-x) (-f) ) ->
@@ -737,7 +753,7 @@ Theorem Rnd_NG_pt_sym :
Proof.
intros F P HF HP x f (H1,H2).
split.
-now apply Rnd_N_pt_sym.
+now apply Rnd_N_pt_opp_inv.
destruct H2 as [H2|H2].
left.
rewrite <- (Ropp_involutive x), <- (Ropp_involutive f).
@@ -748,20 +764,20 @@ rewrite <- (Ropp_involutive f).
rewrite <- H2 with (-f2).
apply sym_eq.
apply Ropp_involutive.
-apply Rnd_N_pt_sym.
+apply Rnd_N_pt_opp_inv.
exact HF.
now rewrite 2!Ropp_involutive.
Qed.
-Theorem Rnd_NG_unicity :
+Theorem Rnd_NG_unique :
forall (F : R -> Prop) (P : R -> R -> Prop),
- Rnd_NG_pt_unicity_prop F P ->
+ Rnd_NG_pt_unique_prop F P ->
forall rnd1 rnd2 : R -> R,
Rnd_NG F P rnd1 -> Rnd_NG F P rnd2 ->
forall x, rnd1 x = rnd2 x.
Proof.
intros F P HP rnd1 rnd2 H1 H2 x.
-now apply Rnd_NG_pt_unicity with F P x.
+now apply Rnd_NG_pt_unique with F P x.
Qed.
Theorem Rnd_NA_NG_pt :
@@ -775,7 +791,7 @@ destruct (Rle_or_lt 0 x) as [Hx|Hx].
(* *)
split ; intros (H1, H2).
(* . *)
-assert (Hf := Rnd_N_pt_pos F HF x f Hx H1).
+assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].
@@ -784,12 +800,12 @@ right.
intros f2 Hxf2.
specialize (H2 _ Hxf2).
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H4|H4].
-eapply Rnd_DN_pt_unicity ; eassumption.
+eapply Rnd_DN_pt_unique ; eassumption.
apply Rle_antisym.
rewrite Rabs_pos_eq with (1 := Hf) in H2.
rewrite Rabs_pos_eq in H2.
exact H2.
-now apply Rnd_N_pt_pos with F x.
+now apply Rnd_N_pt_ge_0 with F x.
apply Rle_trans with x.
apply H3.
apply H4.
@@ -803,8 +819,8 @@ split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
-assert (Hf := Rnd_N_pt_pos F HF x f Hx H1).
-assert (Hf2 := Rnd_N_pt_pos F HF x f2 Hx Hxf2).
+assert (Hf := Rnd_N_pt_ge_0 F HF x f Hx H1).
+assert (Hf2 := Rnd_N_pt_ge_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_pos_eq ; trivial.
rewrite 2!Rabs_pos_eq in H2 ; trivial.
destruct (Rnd_N_pt_DN_or_UP _ _ _ Hxf2) as [H3|H3].
@@ -820,7 +836,7 @@ assert (Hx' := Rlt_le _ _ Hx).
clear Hx. rename Hx' into Hx.
split ; intros (H1, H2).
(* . *)
-assert (Hf := Rnd_N_pt_neg F HF x f Hx H1).
+assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
split.
exact H1.
destruct (Rnd_N_pt_DN_or_UP _ _ _ H1) as [H3|H3].
@@ -842,15 +858,15 @@ apply H3.
rewrite Rabs_left1 with (1 := Hf) in H2.
rewrite Rabs_left1 in H2.
now apply Ropp_le_cancel.
-now apply Rnd_N_pt_neg with F x.
-eapply Rnd_UP_pt_unicity ; eassumption.
+now apply Rnd_N_pt_le_0 with F x.
+eapply Rnd_UP_pt_unique ; eassumption.
(* . *)
split.
exact H1.
intros f2 Hxf2.
destruct H2 as [H2|H2].
-assert (Hf := Rnd_N_pt_neg F HF x f Hx H1).
-assert (Hf2 := Rnd_N_pt_neg F HF x f2 Hx Hxf2).
+assert (Hf := Rnd_N_pt_le_0 F HF x f Hx H1).
+assert (Hf2 := Rnd_N_pt_le_0 F HF x f2 Hx Hxf2).
rewrite 2!Rabs_left1 ; trivial.
rewrite 2!Rabs_left1 in H2 ; trivial.
apply Ropp_le_contravar.
@@ -865,10 +881,10 @@ rewrite (H2 _ Hxf2).
apply Rle_refl.
Qed.
-Theorem Rnd_NA_pt_unicity_prop :
+Lemma Rnd_NA_pt_unique_prop :
forall F : R -> Prop,
F 0 ->
- Rnd_NG_pt_unicity_prop F (fun a b => (Rabs a <= Rabs b)%R).
+ Rnd_NG_pt_unique_prop F (fun a b => (Rabs a <= Rabs b)%R).
Proof.
intros F HF x d u Hxd1 Hxd2 Hxu1 Hxu2 Hd Hu.
apply Rle_antisym.
@@ -892,7 +908,7 @@ apply HF.
now apply Rlt_le.
Qed.
-Theorem Rnd_NA_pt_unicity :
+Theorem Rnd_NA_pt_unique :
forall F : R -> Prop,
F 0 ->
forall x f1 f2 : R,
@@ -900,12 +916,12 @@ Theorem Rnd_NA_pt_unicity :
f1 = f2.
Proof.
intros F HF x f1 f2 H1 H2.
-apply (Rnd_NG_pt_unicity F _ (Rnd_NA_pt_unicity_prop F HF) x).
+apply (Rnd_NG_pt_unique F _ (Rnd_NA_pt_unique_prop F HF) x).
now apply -> Rnd_NA_NG_pt.
now apply -> Rnd_NA_NG_pt.
Qed.
-Theorem Rnd_NA_N_pt :
+Theorem Rnd_NA_pt_N :
forall F : R -> Prop,
F 0 ->
forall x f : R,
@@ -936,29 +952,29 @@ destruct (Rle_lt_dec 0 x) as [Hx|Hx].
(* . *)
revert Hxf.
rewrite Rabs_pos_eq with (1 := Hx).
-rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_pos F HF x) ; assumption ).
+rewrite 2!Rabs_pos_eq ; try ( apply (Rnd_N_pt_ge_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l with (2 := Hxf).
-now apply (Z2R_le 0 2).
+now apply IZR_le.
(* . *)
revert Hxf.
apply Rlt_le in Hx.
rewrite Rabs_left1 with (1 := Hx).
-rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_neg F HF x) ; assumption ).
+rewrite 2!Rabs_left1 ; try ( apply (Rnd_N_pt_le_0 F HF x) ; assumption ).
intros Hxf.
rewrite H0.
apply Ropp_le_contravar.
apply Rplus_le_reg_r with f.
ring_simplify.
apply Rmult_le_compat_l.
-now apply (Z2R_le 0 2).
+now apply IZR_le.
now apply Ropp_le_cancel.
Qed.
-Theorem Rnd_NA_unicity :
+Theorem Rnd_NA_unique :
forall (F : R -> Prop),
F 0 ->
forall rnd1 rnd2 : R -> R,
@@ -966,7 +982,7 @@ Theorem Rnd_NA_unicity :
forall x, rnd1 x = rnd2 x.
Proof.
intros F HF rnd1 rnd2 H1 H2 x.
-now apply Rnd_NA_pt_unicity with F x.
+now apply Rnd_NA_pt_unique with F x.
Qed.
Theorem Rnd_NA_pt_monotone :
@@ -975,7 +991,7 @@ Theorem Rnd_NA_pt_monotone :
round_pred_monotone (Rnd_NA_pt F).
Proof.
intros F HF x y f g Hxf Hyg Hxy.
-apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unicity_prop F HF) x y).
+apply (Rnd_NG_pt_monotone F _ (Rnd_NA_pt_unique_prop F HF) x y).
now apply -> Rnd_NA_NG_pt.
now apply -> Rnd_NA_NG_pt.
exact Hxy.
@@ -1165,7 +1181,7 @@ intros x.
destruct (proj1 (satisfies_any_imp_DN F Hany) (-x)) as (f, Hf).
exists (-f).
rewrite <- (Ropp_involutive x).
-apply Rnd_DN_UP_pt_sym.
+apply Rnd_UP_pt_opp.
apply Hany.
exact Hf.
apply Rnd_UP_pt_monotone.
diff --git a/flocq/Core/Fcore_ulp.v b/flocq/Core/Ulp.v
index 4fdd319e..4f4a5674 100644
--- a/flocq/Core/Fcore_ulp.v
+++ b/flocq/Core/Ulp.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2009-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -19,11 +19,7 @@ COPYING file for more details.
(** * Unit in the Last Place: our definition using fexp and its properties, successor and predecessor *)
Require Import Reals Psatz.
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_rnd.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_float_prop.
+Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Section Fcore_ulp.
@@ -97,10 +93,12 @@ Definition ulp x := match Req_bool x 0 with
| Some n => bpow (fexp n)
| None => 0%R
end
- | false => bpow (canonic_exp beta fexp x)
+ | false => bpow (cexp beta fexp x)
end.
-Lemma ulp_neq_0 : forall x:R, (x <> 0)%R -> ulp x = bpow (canonic_exp beta fexp x).
+Lemma ulp_neq_0 :
+ forall x, x <> 0%R ->
+ ulp x = bpow (cexp beta fexp x).
Proof.
intros x Hx.
unfold ulp; case (Req_bool_spec x); trivial.
@@ -118,7 +116,7 @@ case Req_bool_spec; intros H1.
rewrite Req_bool_true; trivial.
rewrite <- (Ropp_involutive x), H1; ring.
rewrite Req_bool_false.
-now rewrite canonic_exp_opp.
+now rewrite cexp_opp.
intros H2; apply H1; rewrite H2; ring.
Qed.
@@ -130,7 +128,7 @@ unfold ulp; case (Req_bool_spec x 0); intros H1.
rewrite Req_bool_true; trivial.
now rewrite H1, Rabs_R0.
rewrite Req_bool_false.
-now rewrite canonic_exp_abs.
+now rewrite cexp_abs.
now apply Rabs_no_R0.
Qed.
@@ -159,9 +157,8 @@ rewrite ulp_neq_0.
unfold F2R; simpl.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-apply (Z2R_le (Zsucc 0)).
-apply Zlt_le_succ.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply IZR_le, (Zlt_le_succ 0).
+apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
Qed.
@@ -178,8 +175,6 @@ now apply Rabs_pos_lt.
now apply generic_format_abs.
Qed.
-
-(* was ulp_DN_UP *)
Theorem round_UP_DN_ulp :
forall x, ~ F x ->
round beta fexp Zceil x = (round beta fexp Zfloor x + ulp x)%R.
@@ -189,13 +184,13 @@ rewrite ulp_neq_0.
unfold round. simpl.
unfold F2R. simpl.
rewrite Zceil_floor_neq.
-rewrite Z2R_plus. simpl.
+rewrite plus_IZR. simpl.
ring.
intros H.
apply Fx.
unfold generic_format, F2R. simpl.
rewrite <- H.
-rewrite Ztrunc_Z2R.
+rewrite Ztrunc_IZR.
rewrite H.
now rewrite scaled_mantissa_mult_bpow.
intros V; apply Fx.
@@ -210,7 +205,7 @@ Proof.
intros e.
rewrite ulp_neq_0.
apply f_equal.
-apply canonic_exp_fexp.
+apply cexp_fexp.
rewrite Rabs_pos_eq.
split.
ring_simplify (e + 1 - 1)%Z.
@@ -222,7 +217,7 @@ apply Rgt_not_eq, Rlt_gt, bpow_gt_0.
Qed.
-Lemma generic_format_ulp_0:
+Lemma generic_format_ulp_0 :
F (ulp 0).
Proof.
unfold ulp.
@@ -234,8 +229,9 @@ apply generic_format_bpow.
now apply valid_exp.
Qed.
-Lemma generic_format_bpow_ge_ulp_0: forall e,
- (ulp 0 <= bpow e)%R -> F (bpow e).
+Lemma generic_format_bpow_ge_ulp_0 :
+ forall e, (ulp 0 <= bpow e)%R ->
+ F (bpow e).
Proof.
intros e; unfold ulp.
rewrite Req_bool_true; trivial.
@@ -248,7 +244,7 @@ apply generic_format_bpow.
case (Zle_or_lt (e+1) (fexp (e+1))); intros H4.
absurd (e+1 <= e)%Z.
omega.
-apply Zle_trans with (1:=H4).
+apply Z.le_trans with (1:=H4).
replace (fexp (e+1)) with (fexp n).
now apply le_bpow with beta.
now apply fexp_negligible_exp_eq.
@@ -258,33 +254,36 @@ Qed.
(** The three following properties are equivalent:
[Exp_not_FTZ] ; forall x, F (ulp x) ; forall x, ulp 0 <= ulp x *)
-Lemma generic_format_ulp: Exp_not_FTZ fexp ->
- forall x, F (ulp x).
+Lemma generic_format_ulp :
+ Exp_not_FTZ fexp ->
+ forall x, F (ulp x).
Proof.
unfold Exp_not_FTZ; intros H x.
case (Req_dec x 0); intros Hx.
rewrite Hx; apply generic_format_ulp_0.
rewrite (ulp_neq_0 _ Hx).
-apply generic_format_bpow; unfold canonic_exp.
+apply generic_format_bpow.
apply H.
Qed.
-Lemma not_FTZ_generic_format_ulp:
- (forall x, F (ulp x)) -> Exp_not_FTZ fexp.
+Lemma not_FTZ_generic_format_ulp :
+ (forall x, F (ulp x)) ->
+ Exp_not_FTZ fexp.
Proof.
intros H e.
specialize (H (bpow (e-1))).
rewrite ulp_neq_0 in H.
2: apply Rgt_not_eq, bpow_gt_0.
-unfold canonic_exp in H.
-rewrite ln_beta_bpow in H.
-apply generic_format_bpow_inv' in H...
+unfold cexp in H.
+rewrite mag_bpow in H.
+apply generic_format_bpow_inv' in H.
now replace (e-1+1)%Z with e in H by ring.
Qed.
-Lemma ulp_ge_ulp_0: Exp_not_FTZ fexp ->
- forall x, (ulp 0 <= ulp x)%R.
+Lemma ulp_ge_ulp_0 :
+ Exp_not_FTZ fexp ->
+ forall x, (ulp 0 <= ulp x)%R.
Proof.
unfold Exp_not_FTZ; intros H x.
case (Req_dec x 0); intros Hx.
@@ -295,20 +294,21 @@ case negligible_exp_spec'.
intros (H1,H2); rewrite H1; apply ulp_ge_0.
intros (n,(H1,H2)); rewrite H1.
rewrite ulp_neq_0; trivial.
-apply bpow_le; unfold canonic_exp.
-generalize (ln_beta beta x); intros l.
+apply bpow_le; unfold cexp.
+generalize (mag beta x); intros l.
case (Zle_or_lt l (fexp l)); intros Hl.
-rewrite (fexp_negligible_exp_eq n l); trivial; apply Zle_refl.
+rewrite (fexp_negligible_exp_eq n l); trivial; apply Z.le_refl.
case (Zle_or_lt (fexp n) (fexp l)); trivial; intros K.
absurd (fexp n <= fexp l)%Z.
omega.
-apply Zle_trans with (2:= H _).
+apply Z.le_trans with (2:= H _).
apply Zeq_le, sym_eq, valid_exp; trivial.
omega.
Qed.
Lemma not_FTZ_ulp_ge_ulp_0:
- (forall x, (ulp 0 <= ulp x)%R) -> Exp_not_FTZ fexp.
+ (forall x, (ulp 0 <= ulp x)%R) ->
+ Exp_not_FTZ fexp.
Proof.
intros H e.
apply generic_format_bpow_inv' with beta.
@@ -318,9 +318,7 @@ rewrite <- ulp_bpow.
apply H.
Qed.
-
-
-Theorem ulp_le_pos :
+Lemma ulp_le_pos :
forall { Hm : Monotone_exp fexp },
forall x y: R,
(0 <= x)%R -> (x <= y)%R ->
@@ -332,7 +330,7 @@ rewrite ulp_neq_0.
rewrite ulp_neq_0.
apply bpow_le.
apply Hm.
-now apply ln_beta_le.
+now apply mag_le.
apply Rgt_not_eq, Rlt_gt.
now apply Rlt_le_trans with (1:=Hx).
now apply Rgt_not_eq.
@@ -341,7 +339,6 @@ apply ulp_ge_ulp_0.
apply monotone_exp_not_FTZ...
Qed.
-
Theorem ulp_le :
forall { Hm : Monotone_exp fexp },
forall x y: R,
@@ -355,26 +352,49 @@ apply ulp_le_pos; trivial.
apply Rabs_pos.
Qed.
+(** Properties when there is no minimal exponent *)
+Theorem eq_0_round_0_negligible_exp :
+ negligible_exp = None -> forall rnd {Vr: Valid_rnd rnd} x,
+ round beta fexp rnd x = 0%R -> x = 0%R.
+Proof.
+intros H rnd Vr x Hx.
+case (Req_dec x 0); try easy; intros Hx2.
+absurd (Rabs (round beta fexp rnd x) = 0%R).
+2: rewrite Hx, Rabs_R0; easy.
+apply Rgt_not_eq.
+apply Rlt_le_trans with (bpow (mag beta x - 1)).
+apply bpow_gt_0.
+apply abs_round_ge_generic; try assumption.
+apply generic_format_bpow.
+case negligible_exp_spec'; [intros (K1,K2)|idtac].
+ring_simplify (mag beta x-1+1)%Z.
+specialize (K2 (mag beta x)); now auto with zarith.
+intros (n,(Hn1,Hn2)).
+rewrite Hn1 in H; discriminate.
+now apply bpow_mag_le.
+Qed.
+
(** Definition and properties of pred and succ *)
Definition pred_pos x :=
- if Req_bool x (bpow (ln_beta beta x - 1)) then
- (x - bpow (fexp (ln_beta beta x - 1)))%R
+ if Req_bool x (bpow (mag beta x - 1)) then
+ (x - bpow (fexp (mag beta x - 1)))%R
else
(x - ulp x)%R.
Definition succ x :=
- if (Rle_bool 0 x) then
- (x+ulp x)%R
- else
- (- pred_pos (-x))%R.
+ if (Rle_bool 0 x) then
+ (x+ulp x)%R
+ else
+ (- pred_pos (-x))%R.
Definition pred x := (- succ (-x))%R.
-Theorem pred_eq_pos:
- forall x, (0 <= x)%R -> (pred x = pred_pos x)%R.
+Theorem pred_eq_pos :
+ forall x, (0 <= x)%R ->
+ pred x = pred_pos x.
Proof.
intros x Hx; unfold pred, succ.
case Rle_bool_spec; intros Hx'.
@@ -389,39 +409,29 @@ rewrite Ropp_0; ring.
now rewrite 2!Ropp_involutive.
Qed.
-Theorem succ_eq_pos:
- forall x, (0 <= x)%R -> (succ x = x + ulp x)%R.
+Theorem succ_eq_pos :
+ forall x, (0 <= x)%R ->
+ succ x = (x + ulp x)%R.
Proof.
intros x Hx; unfold succ.
now rewrite Rle_bool_true.
Qed.
-Lemma pred_eq_opp_succ_opp: forall x, pred x = (- succ (-x))%R.
+Theorem succ_opp :
+ forall x, succ (-x) = (- pred x)%R.
Proof.
-reflexivity.
-Qed.
-
-Lemma succ_eq_opp_pred_opp: forall x, succ x = (- pred (-x))%R.
-Proof.
-intros x; unfold pred.
-now rewrite 2!Ropp_involutive.
-Qed.
-
-Lemma succ_opp: forall x, (succ (-x) = - pred x)%R.
-Proof.
-intros x; rewrite succ_eq_opp_pred_opp.
-now rewrite Ropp_involutive.
+intros x.
+now apply sym_eq, Ropp_involutive.
Qed.
-Lemma pred_opp: forall x, (pred (-x) = - succ x)%R.
+Theorem pred_opp :
+ forall x, pred (-x) = (- succ x)%R.
Proof.
-intros x; rewrite pred_eq_opp_succ_opp.
+intros x.
+unfold pred.
now rewrite Ropp_involutive.
Qed.
-
-
-
(** pred and succ are in the format *)
(* cannont be x <> ulp 0, due to the counter-example 1-bit FP format fexp: e -> e-1 *)
@@ -436,7 +446,7 @@ intros x e Fx Hx' Hx.
(* *)
assert (1 <= Ztrunc (scaled_mantissa beta fexp x))%Z.
assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply gt_0_F2R with beta (cexp beta fexp x).
rewrite <- Fx.
apply Rle_lt_trans with (2:=Hx).
apply bpow_ge_0.
@@ -446,12 +456,11 @@ case (Zle_lt_or_eq _ _ H); intros Hm.
pattern x at 1 ; rewrite Fx.
rewrite ulp_neq_0.
unfold F2R. simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
+pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_minus_distr_r.
-change 1%R with (Z2R 1).
-rewrite <- Z2R_minus.
-change (bpow e <= F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) - 1) (canonic_exp beta fexp x)))%R.
-apply bpow_le_F2R_m1; trivial.
+rewrite <- minus_IZR.
+apply bpow_le_F2R_m1.
+easy.
now rewrite <- Fx.
apply Rgt_not_eq, Rlt_gt.
apply Rlt_trans with (2:=Hx), bpow_gt_0.
@@ -476,27 +485,23 @@ intros x e Zx Fx Hx.
pattern x at 1 ; rewrite Fx.
rewrite ulp_neq_0.
unfold F2R. simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
+pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_plus_distr_r.
-change 1%R with (Z2R 1).
-rewrite <- Z2R_plus.
-change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow e)%R.
+rewrite <- plus_IZR.
apply F2R_p1_le_bpow.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
now rewrite <- Fx.
now apply Rgt_not_eq.
Qed.
-
-
Lemma generic_format_pred_aux1:
forall x, (0 < x)%R -> F x ->
- x <> bpow (ln_beta beta x - 1) ->
+ x <> bpow (mag beta x - 1) ->
F (x - ulp x).
Proof.
intros x Zx Fx Hx.
-destruct (ln_beta beta x) as (ex, Ex).
+destruct (mag beta x) as (ex, Ex).
simpl in Hx.
specialize (Ex (Rgt_not_eq _ _ Zx)).
assert (Ex' : (bpow (ex - 1) < x < bpow ex)%R).
@@ -504,20 +509,20 @@ rewrite Rabs_pos_eq in Ex.
destruct Ex as (H,H'); destruct H; split; trivial.
contradict Hx; easy.
now apply Rlt_le.
-unfold generic_format, scaled_mantissa, canonic_exp.
-rewrite ln_beta_unique with beta (x - ulp x)%R ex.
+unfold generic_format, scaled_mantissa, cexp.
+rewrite mag_unique with beta (x - ulp x)%R ex.
pattern x at 1 3 ; rewrite Fx.
rewrite ulp_neq_0.
unfold scaled_mantissa.
-rewrite canonic_exp_fexp with (1 := Ex).
+rewrite cexp_fexp with (1 := Ex).
unfold F2R. simpl.
rewrite Rmult_minus_distr_r.
rewrite Rmult_assoc.
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-change (bpow 0) with (Z2R 1).
-rewrite <- Z2R_minus.
-rewrite Ztrunc_Z2R.
-rewrite Z2R_minus.
+change (bpow 0) with 1%R.
+rewrite <- minus_IZR.
+rewrite Ztrunc_IZR.
+rewrite minus_IZR.
rewrite Rmult_minus_distr_r.
now rewrite Rmult_1_l.
now apply Rgt_not_eq.
@@ -526,7 +531,7 @@ split.
apply id_m_ulp_ge_bpow; trivial.
rewrite ulp_neq_0.
intro H.
-assert (ex-1 < canonic_exp beta fexp x < ex)%Z.
+assert (ex-1 < cexp beta fexp x < ex)%Z.
split ; apply (lt_bpow beta) ; rewrite <- H ; easy.
clear -H0. omega.
now apply Rgt_not_eq.
@@ -541,13 +546,12 @@ apply Rle_0_minus.
pattern x at 2; rewrite Fx.
rewrite ulp_neq_0.
unfold F2R; simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 1; rewrite <- Rmult_1_l.
+pattern (bpow (cexp beta fexp x)) at 1; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-replace 1%R with (Z2R 1) by reflexivity.
-apply Z2R_le.
+apply IZR_le.
assert (0 < Ztrunc (scaled_mantissa beta fexp x))%Z.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply gt_0_F2R with beta (cexp beta fexp x).
rewrite <- Fx.
apply Rle_lt_trans with (2:=proj1 Ex').
apply bpow_ge_0.
@@ -557,8 +561,8 @@ Qed.
Lemma generic_format_pred_aux2 :
forall x, (0 < x)%R -> F x ->
- let e := ln_beta_val beta x (ln_beta beta x) in
- x = bpow (e - 1) ->
+ let e := mag_val beta x (mag beta x) in
+ x = bpow (e - 1) ->
F (x - bpow (fexp (e - 1))).
Proof.
intros x Zx Fx e Hx.
@@ -571,7 +575,7 @@ case (Zle_lt_or_eq _ _ He); clear He; intros He.
assert (f = F2R (Float beta (Zpower beta (e-1-(fexp (e-1))) -1) (fexp (e-1))))%R.
unfold f; rewrite Hx.
unfold F2R; simpl.
-rewrite Z2R_minus, Z2R_Zpower.
+rewrite minus_IZR, IZR_Zpower.
rewrite Rmult_minus_distr_r, Rmult_1_l.
rewrite <- bpow_plus.
now replace (e - 1 - fexp (e - 1) + fexp (e - 1))%Z with (e-1)%Z by ring.
@@ -580,7 +584,7 @@ rewrite H.
apply generic_format_F2R.
intros _.
apply Zeq_le.
-apply canonic_exp_fexp.
+apply cexp_fexp.
rewrite <- H.
unfold f; rewrite Hx.
rewrite Rabs_right.
@@ -593,9 +597,8 @@ apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-replace 2%R with (Z2R 2) by reflexivity.
-replace (bpow 1) with (Z2R beta).
-apply Z2R_le.
+replace (bpow 1) with (IZR beta).
+apply IZR_le.
apply <- Zle_is_le_bool.
now destruct beta.
simpl.
@@ -619,31 +622,30 @@ rewrite Hx, He.
ring.
Qed.
-
-Theorem generic_format_succ_aux1 :
+Lemma generic_format_succ_aux1 :
forall x, (0 < x)%R -> F x ->
F (x + ulp x).
Proof.
intros x Zx Fx.
-destruct (ln_beta beta x) as (ex, Ex).
+destruct (mag beta x) as (ex, Ex).
specialize (Ex (Rgt_not_eq _ _ Zx)).
assert (Ex' := Ex).
rewrite Rabs_pos_eq in Ex'.
destruct (id_p_ulp_le_bpow x ex) ; try easy.
-unfold generic_format, scaled_mantissa, canonic_exp.
-rewrite ln_beta_unique with beta (x + ulp x)%R ex.
+unfold generic_format, scaled_mantissa, cexp.
+rewrite mag_unique with beta (x + ulp x)%R ex.
pattern x at 1 3 ; rewrite Fx.
rewrite ulp_neq_0.
unfold scaled_mantissa.
-rewrite canonic_exp_fexp with (1 := Ex).
+rewrite cexp_fexp with (1 := Ex).
unfold F2R. simpl.
rewrite Rmult_plus_distr_r.
rewrite Rmult_assoc.
rewrite <- bpow_plus, Zplus_opp_r, Rmult_1_r.
-change (bpow 0) with (Z2R 1).
-rewrite <- Z2R_plus.
-rewrite Ztrunc_Z2R.
-rewrite Z2R_plus.
+change (bpow 0) with 1%R.
+rewrite <- plus_IZR.
+rewrite Ztrunc_IZR.
+rewrite plus_IZR.
rewrite Rmult_plus_distr_r.
now rewrite Rmult_1_l.
now apply Rgt_not_eq.
@@ -667,7 +669,7 @@ replace (Ztrunc (scaled_mantissa beta fexp x)) with Z0.
rewrite F2R_0.
apply Rle_refl.
unfold scaled_mantissa.
-rewrite canonic_exp_fexp with (1 := Ex).
+rewrite cexp_fexp with (1 := Ex).
destruct (mantissa_small_pos beta fexp x ex) ; trivial.
rewrite Ztrunc_floor.
apply sym_eq.
@@ -679,7 +681,7 @@ now apply Rlt_le.
now apply Rlt_le.
Qed.
-Theorem generic_format_pred_pos :
+Lemma generic_format_pred_pos :
forall x, F x -> (0 < x)%R ->
F (pred_pos x).
Proof.
@@ -689,7 +691,6 @@ now apply generic_format_pred_aux2.
now apply generic_format_pred_aux1.
Qed.
-
Theorem generic_format_succ :
forall x, F x ->
F (succ x).
@@ -717,9 +718,7 @@ apply generic_format_succ.
now apply generic_format_opp.
Qed.
-
-
-Theorem pred_pos_lt_id :
+Lemma pred_pos_lt_id :
forall x, (x <> 0)%R ->
(pred_pos x < x)%R.
Proof.
@@ -754,7 +753,7 @@ apply bpow_gt_0.
pattern x at 1; rewrite <- (Ropp_involutive x).
apply Ropp_lt_contravar.
apply pred_pos_lt_id.
-now auto with real.
+auto with real.
Qed.
@@ -766,7 +765,7 @@ intros x Zx; unfold pred.
pattern x at 2; rewrite <- (Ropp_involutive x).
apply Ropp_lt_contravar.
apply succ_gt_id.
-now auto with real.
+auto with real.
Qed.
Theorem succ_ge_id :
@@ -781,7 +780,7 @@ Qed.
Theorem pred_le_id :
- forall x, (pred x <= x)%R.
+ forall x, (pred x <= x)%R.
Proof.
intros x; unfold pred.
pattern x at 2; rewrite <- (Ropp_involutive x).
@@ -790,7 +789,7 @@ apply succ_ge_id.
Qed.
-Theorem pred_pos_ge_0 :
+Lemma pred_pos_ge_0 :
forall x,
(0 < x)%R -> F x -> (0 <= pred_pos x)%R.
Proof.
@@ -801,8 +800,8 @@ case Req_bool_spec; intros H.
apply Rle_0_minus.
rewrite H.
apply bpow_le.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
-rewrite ln_beta_bpow.
+destruct (mag beta x) as (ex,Ex) ; simpl.
+rewrite mag_bpow.
ring_simplify (ex - 1 + 1 - 1)%Z.
apply generic_format_bpow_inv with beta; trivial.
simpl in H.
@@ -824,36 +823,35 @@ Qed.
Lemma pred_pos_plus_ulp_aux1 :
forall x, (0 < x)%R -> F x ->
- x <> bpow (ln_beta beta x - 1) ->
+ x <> bpow (mag beta x - 1) ->
((x - ulp x) + ulp (x-ulp x) = x)%R.
Proof.
intros x Zx Fx Hx.
replace (ulp (x - ulp x)) with (ulp x).
ring.
-assert (H:(x <> 0)%R) by auto with real.
-assert (H':(x <> bpow (canonic_exp beta fexp x))%R).
-unfold canonic_exp; intros M.
-case_eq (ln_beta beta x); intros ex Hex T.
-assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
+assert (H : x <> 0%R) by now apply Rgt_not_eq.
+assert (H' : x <> bpow (cexp beta fexp x)).
+unfold cexp ; intros M.
+case_eq (mag beta x); intros ex Hex T.
+assert (Lex:(mag_val beta x (mag beta x) = ex)%Z).
rewrite T; reflexivity.
rewrite Lex in *.
clear T; simpl in *; specialize (Hex H).
-rewrite Rabs_right in Hex.
-2: apply Rle_ge; apply Rlt_le; easy.
-assert (ex-1 < fexp ex < ex)%Z.
-split ; apply (lt_bpow beta); rewrite <- M;[idtac|easy].
-destruct (proj1 Hex);[trivial|idtac].
-contradict Hx; auto with real.
+rewrite Rabs_pos_eq in Hex by now apply Rlt_le.
+assert (ex - 1 < fexp ex < ex)%Z.
+ split ; apply (lt_bpow beta) ; rewrite <- M by easy.
+ lra.
+ apply Hex.
omega.
-rewrite 2!ulp_neq_0; try auto with real.
+rewrite 2!ulp_neq_0 by lra.
apply f_equal.
-unfold canonic_exp; apply f_equal.
-case_eq (ln_beta beta x); intros ex Hex T.
-assert (Lex:(ln_beta_val beta x (ln_beta beta x) = ex)%Z).
+unfold cexp ; apply f_equal.
+case_eq (mag beta x); intros ex Hex T.
+assert (Lex:(mag_val beta x (mag beta x) = ex)%Z).
rewrite T; reflexivity.
rewrite Lex in *; simpl in *; clear T.
specialize (Hex H).
-apply sym_eq, ln_beta_unique.
+apply sym_eq, mag_unique.
rewrite Rabs_right.
rewrite Rabs_right in Hex.
2: apply Rle_ge; apply Rlt_le; easy.
@@ -863,8 +861,8 @@ apply Rle_trans with (x-ulp x)%R.
apply id_m_ulp_ge_bpow; trivial.
rewrite ulp_neq_0; trivial.
rewrite ulp_neq_0; trivial.
-right; unfold canonic_exp; now rewrite Lex.
-contradict Hx; auto with real.
+right; unfold cexp; now rewrite Lex.
+lra.
apply Rle_lt_trans with (2:=proj2 Hex).
rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
@@ -874,22 +872,19 @@ apply bpow_ge_0.
apply Rle_ge.
apply Rle_0_minus.
rewrite Fx.
-unfold F2R, canonic_exp; simpl.
+unfold F2R, cexp; simpl.
rewrite Lex.
pattern (bpow (fexp ex)) at 1; rewrite <- Rmult_1_l.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-replace 1%R with (Z2R (Zsucc 0)) by reflexivity.
-apply Z2R_le.
-apply Zlt_le_succ.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply IZR_le, (Zlt_le_succ 0).
+apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
Qed.
-
Lemma pred_pos_plus_ulp_aux2 :
forall x, (0 < x)%R -> F x ->
- let e := ln_beta_val beta x (ln_beta beta x) in
+ let e := mag_val beta x (mag beta x) in
x = bpow (e - 1) ->
(x - bpow (fexp (e-1)) <> 0)%R ->
((x - bpow (fexp (e-1))) + ulp (x - bpow (fexp (e-1))) = x)%R.
@@ -904,9 +899,9 @@ case (Zle_lt_or_eq _ _ He); clear He; intros He.
(* *)
rewrite ulp_neq_0; trivial.
apply f_equal.
-unfold canonic_exp; apply f_equal.
+unfold cexp ; apply f_equal.
apply sym_eq.
-apply ln_beta_unique.
+apply mag_unique.
rewrite Rabs_right.
split.
apply Rplus_le_reg_l with (bpow (fexp (e-1))).
@@ -917,9 +912,8 @@ apply Rle_trans with (2*bpow (e - 2))%R;[right; ring|idtac].
apply Rle_trans with (bpow 1*bpow (e - 2))%R.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-replace 2%R with (Z2R 2) by reflexivity.
-replace (bpow 1) with (Z2R beta).
-apply Z2R_le.
+replace (bpow 1) with (IZR beta).
+apply IZR_le.
apply <- Zle_is_le_bool.
now destruct beta.
simpl.
@@ -944,7 +938,7 @@ Qed.
Lemma pred_pos_plus_ulp_aux3 :
forall x, (0 < x)%R -> F x ->
- let e := ln_beta_val beta x (ln_beta beta x) in
+ let e := mag_val beta x (mag beta x) in
x = bpow (e - 1) ->
(x - bpow (fexp (e-1)) = 0)%R ->
(ulp 0 = x)%R.
@@ -967,40 +961,44 @@ apply valid_exp; omega.
apply sym_eq, valid_exp; omega.
Qed.
-
-
-
(** The following one is false for x = 0 in FTZ *)
-Theorem pred_pos_plus_ulp :
+Lemma pred_pos_plus_ulp :
forall x, (0 < x)%R -> F x ->
(pred_pos x + ulp (pred_pos x) = x)%R.
Proof.
intros x Zx Fx.
unfold pred_pos.
case Req_bool_spec; intros H.
-case (Req_EM_T (x - bpow (fexp (ln_beta_val beta x (ln_beta beta x) -1))) 0); intros H1.
+case (Req_EM_T (x - bpow (fexp (mag_val beta x (mag beta x) -1))) 0); intros H1.
rewrite H1, Rplus_0_l.
now apply pred_pos_plus_ulp_aux3.
now apply pred_pos_plus_ulp_aux2.
now apply pred_pos_plus_ulp_aux1.
Qed.
-
-
+Theorem pred_plus_ulp :
+ forall x, (0 < x)%R -> F x ->
+ (pred x + ulp (pred x))%R = x.
+Proof.
+intros x Hx Fx.
+rewrite pred_eq_pos.
+now apply pred_pos_plus_ulp.
+now apply Rlt_le.
+Qed.
(** Rounding x + small epsilon *)
-Theorem ln_beta_plus_eps:
+Theorem mag_plus_eps :
forall x, (0 < x)%R -> F x ->
forall eps, (0 <= eps < ulp x)%R ->
- ln_beta beta (x + eps) = ln_beta beta x :> Z.
+ mag beta (x + eps) = mag beta x :> Z.
Proof.
intros x Zx Fx eps Heps.
-destruct (ln_beta beta x) as (ex, He).
+destruct (mag beta x) as (ex, He).
simpl.
specialize (He (Rgt_not_eq _ _ Zx)).
-apply ln_beta_unique.
+apply mag_unique.
rewrite Rabs_pos_eq.
rewrite Rabs_pos_eq in He.
split.
@@ -1012,13 +1010,11 @@ now apply Rplus_lt_compat_l.
pattern x at 1 ; rewrite Fx.
rewrite ulp_neq_0.
unfold F2R. simpl.
-pattern (bpow (canonic_exp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
+pattern (bpow (cexp beta fexp x)) at 2 ; rewrite <- Rmult_1_l.
rewrite <- Rmult_plus_distr_r.
-change 1%R with (Z2R 1).
-rewrite <- Z2R_plus.
-change (F2R (Float beta (Ztrunc (scaled_mantissa beta fexp x) + 1) (canonic_exp beta fexp x)) <= bpow ex)%R.
+rewrite <- plus_IZR.
apply F2R_p1_le_bpow.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
now rewrite <- Fx.
now apply Rgt_not_eq.
@@ -1028,7 +1024,7 @@ now apply Rlt_le.
apply Heps.
Qed.
-Theorem round_DN_plus_eps_pos:
+Theorem round_DN_plus_eps_pos :
forall x, (0 <= x)%R -> F x ->
forall eps, (0 <= eps < ulp x)%R ->
round beta fexp Zfloor (x + eps) = x.
@@ -1039,8 +1035,8 @@ destruct Zx as [Zx|Zx].
pattern x at 2 ; rewrite Fx.
unfold round.
unfold scaled_mantissa. simpl.
-unfold canonic_exp at 1 2.
-rewrite ln_beta_plus_eps ; trivial.
+unfold cexp at 1 2.
+rewrite mag_plus_eps ; trivial.
apply (f_equal (fun m => F2R (Float beta m _))).
rewrite Ztrunc_floor.
apply Zfloor_imp.
@@ -1050,12 +1046,12 @@ apply Rmult_le_compat_r.
apply bpow_ge_0.
pattern x at 1 ; rewrite <- Rplus_0_r.
now apply Rplus_le_compat_l.
-apply Rlt_le_trans with ((x + ulp x) * bpow (- canonic_exp beta fexp x))%R.
+apply Rlt_le_trans with ((x + ulp x) * bpow (- cexp beta fexp x))%R.
apply Rmult_lt_compat_r.
apply bpow_gt_0.
now apply Rplus_lt_compat_l.
rewrite Rmult_plus_distr_r.
-rewrite Z2R_plus.
+rewrite plus_IZR.
apply Rplus_le_compat.
pattern x at 1 3 ; rewrite Fx.
unfold F2R. simpl.
@@ -1063,7 +1059,7 @@ rewrite Rmult_assoc.
rewrite <- bpow_plus.
rewrite Zplus_opp_r.
rewrite Rmult_1_r.
-rewrite Zfloor_Z2R.
+rewrite Zfloor_IZR.
apply Rle_refl.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
@@ -1076,24 +1072,23 @@ apply bpow_ge_0.
(* . x=0 *)
rewrite <- Zx, Rplus_0_l; rewrite <- Zx in Heps.
case (proj1 Heps); intros P.
-unfold round, scaled_mantissa, canonic_exp.
+unfold round, scaled_mantissa, cexp.
revert Heps; unfold ulp.
rewrite Req_bool_true; trivial.
case negligible_exp_spec.
intros _ (H1,H2).
-absurd (0 < 0)%R; auto with real.
-now apply Rle_lt_trans with (1:=H1).
+exfalso ; lra.
intros n Hn H.
-assert (fexp (ln_beta beta eps) = fexp n).
+assert (fexp (mag beta eps) = fexp n).
apply valid_exp; try assumption.
-assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
+assert(mag beta eps-1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=proj2 H).
-destruct (ln_beta beta eps) as (e,He).
+destruct (mag beta eps) as (e,He).
simpl; rewrite Rabs_pos_eq in He.
now apply He, Rgt_not_eq.
now left.
-replace (Zfloor (eps * bpow (- fexp (ln_beta beta eps)))) with 0%Z.
+replace (Zfloor (eps * bpow (- fexp (mag beta eps)))) with 0%Z.
unfold F2R; simpl; ring.
apply sym_eq, Zfloor_imp.
split.
@@ -1128,8 +1123,8 @@ assert (Hd := round_DN_plus_eps_pos x Zx Fx eps Heps).
rewrite round_UP_DN_ulp.
rewrite Hd.
rewrite 2!ulp_neq_0.
-unfold canonic_exp.
-now rewrite ln_beta_plus_eps.
+unfold cexp.
+now rewrite mag_plus_eps.
now apply Rgt_not_eq.
now apply Rgt_not_eq, Rplus_lt_0_compat.
intros Fs.
@@ -1144,24 +1139,22 @@ now apply generic_format_succ_aux1.
rewrite <- Zx1, 2!Rplus_0_l.
intros Heps.
case (proj2 Heps).
-unfold round, scaled_mantissa, canonic_exp.
+unfold round, scaled_mantissa, cexp.
unfold ulp.
rewrite Req_bool_true; trivial.
case negligible_exp_spec.
-intros H2.
-intros J; absurd (0 < 0)%R; auto with real.
-apply Rlt_trans with eps; try assumption; apply Heps.
+lra.
intros n Hn H.
-assert (fexp (ln_beta beta eps) = fexp n).
+assert (fexp (mag beta eps) = fexp n).
apply valid_exp; try assumption.
-assert(ln_beta beta eps-1 < fexp n)%Z;[idtac|omega].
+assert(mag beta eps-1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
apply Rle_lt_trans with (2:=H).
-destruct (ln_beta beta eps) as (e,He).
+destruct (mag beta eps) as (e,He).
simpl; rewrite Rabs_pos_eq in He.
now apply He, Rgt_not_eq.
now left.
-replace (Zceil (eps * bpow (- fexp (ln_beta beta eps)))) with 1%Z.
+replace (Zceil (eps * bpow (- fexp (mag beta eps)))) with 1%Z.
unfold F2R; simpl; rewrite H0; ring.
apply sym_eq, Zceil_imp.
split.
@@ -1316,7 +1309,7 @@ destruct Zp; trivial.
generalize H0.
rewrite pred_eq_pos;[idtac|now left].
unfold pred_pos.
-destruct (ln_beta beta y) as (ey,Hey); simpl.
+destruct (mag beta y) as (ey,Hey); simpl.
case Req_bool_spec; intros Hy2.
(* . *)
intros Hy3.
@@ -1326,7 +1319,7 @@ rewrite <- Hy2, <- Rplus_0_l, Hy3.
ring.
assert (Zx: (x <> 0)%R).
now apply Rgt_not_eq.
-destruct (ln_beta beta x) as (ex,Hex).
+destruct (mag beta x) as (ex,Hex).
specialize (Hex Zx).
assert (ex <= ey)%Z.
apply bpow_lt_bpow with beta.
@@ -1347,16 +1340,16 @@ omega.
absurd (0 < Ztrunc (scaled_mantissa beta fexp x) < 1)%Z.
omega.
split.
-apply F2R_gt_0_reg with beta (canonic_exp beta fexp x).
+apply gt_0_F2R with beta (cexp beta fexp x).
now rewrite <- Fx.
-apply lt_Z2R.
-apply Rmult_lt_reg_r with (bpow (canonic_exp beta fexp x)).
+apply lt_IZR.
+apply Rmult_lt_reg_r with (bpow (cexp beta fexp x)).
apply bpow_gt_0.
-replace (Z2R (Ztrunc (scaled_mantissa beta fexp x)) *
- bpow (canonic_exp beta fexp x))%R with x.
+replace (IZR (Ztrunc (scaled_mantissa beta fexp x)) *
+ bpow (cexp beta fexp x))%R with x.
rewrite Rmult_1_l.
-unfold canonic_exp.
-rewrite ln_beta_unique with beta x ex.
+unfold cexp.
+rewrite mag_unique with beta x ex.
rewrite H3,<-H1, <- Hy2.
apply H.
exact Hex.
@@ -1373,8 +1366,8 @@ assert (y = bpow (fexp ey))%R.
apply Rminus_diag_uniq.
rewrite Hy3.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
-unfold canonic_exp.
-rewrite (ln_beta_unique beta y ey); trivial.
+unfold cexp.
+rewrite (mag_unique beta y ey); trivial.
apply Hey.
now apply Rgt_not_eq.
contradict Hy2.
@@ -1382,8 +1375,8 @@ rewrite H1.
apply f_equal.
apply Zplus_reg_l with 1%Z.
ring_simplify.
-apply trans_eq with (ln_beta beta y).
-apply sym_eq; apply ln_beta_unique.
+apply trans_eq with (mag beta y).
+apply sym_eq; apply mag_unique.
rewrite H1, Rabs_right.
split.
apply bpow_le.
@@ -1391,7 +1384,7 @@ omega.
apply bpow_lt.
omega.
apply Rle_ge; apply bpow_ge_0.
-apply ln_beta_unique.
+apply mag_unique.
apply Hey.
now apply Rgt_not_eq.
(* *)
@@ -1418,7 +1411,7 @@ rewrite <- V; apply pred_pos_ge_0; trivial.
apply Rle_lt_trans with (1:=proj1 H); apply H.
Qed.
-Theorem succ_le_lt_aux:
+Lemma succ_le_lt_aux:
forall x y,
F x -> F y ->
(0 <= x)%R -> (x < y)%R ->
@@ -1468,7 +1461,7 @@ now apply generic_format_opp.
rewrite Ropp_0; now left.
Qed.
-Theorem le_pred_lt :
+Theorem pred_ge_gt :
forall x y,
F x -> F y ->
(x < y)%R ->
@@ -1483,7 +1476,7 @@ now apply generic_format_opp.
now apply Ropp_lt_contravar.
Qed.
-Theorem lt_succ_le :
+Theorem succ_gt_ge :
forall x y,
(y <> 0)%R ->
(x <= y)%R ->
@@ -1505,12 +1498,12 @@ apply Rlt_le_trans with (2 := Hxy).
now apply pred_lt_id.
Qed.
-Theorem succ_pred_aux : forall x, F x -> (0 < x)%R -> succ (pred x)=x.
+Lemma succ_pred_pos :
+ forall x, F x -> (0 < x)%R -> succ (pred x) = x.
Proof.
intros x Fx Hx.
-rewrite pred_eq_pos;[idtac|now left].
-rewrite succ_eq_pos.
-2: now apply pred_pos_ge_0.
+rewrite pred_eq_pos by now left.
+rewrite succ_eq_pos by now apply pred_pos_ge_0.
now apply pred_pos_plus_ulp.
Qed.
@@ -1530,7 +1523,7 @@ rewrite H1; ring.
(* *)
intros (n,(H1,H2)); rewrite H1.
unfold pred_pos.
-rewrite ln_beta_bpow.
+rewrite mag_bpow.
replace (fexp n + 1 - 1)%Z with (fexp n) by ring.
rewrite Req_bool_true; trivial.
apply Rminus_diag_eq, f_equal.
@@ -1554,7 +1547,7 @@ rewrite <- Ropp_0 at 1.
apply pred_opp.
Qed.
-Theorem pred_succ_aux :
+Lemma pred_succ_pos :
forall x, F x -> (0 < x)%R ->
pred (succ x) = x.
Proof.
@@ -1570,7 +1563,7 @@ apply Rle_antisym.
apply Rlt_le_trans with (1 := Hx).
apply succ_ge_id.
now apply generic_format_pred, generic_format_succ.
-- apply le_pred_lt with (1 := Fx).
+- apply pred_ge_gt with (1 := Fx).
now apply generic_format_succ.
apply succ_gt_id.
now apply Rgt_not_eq.
@@ -1582,12 +1575,12 @@ Theorem succ_pred :
Proof.
intros x Fx.
destruct (Rle_or_lt 0 x) as [[Hx|Hx]|Hx].
-now apply succ_pred_aux.
+now apply succ_pred_pos.
rewrite <- Hx.
rewrite pred_0, succ_opp, pred_ulp_0.
apply Ropp_0.
-rewrite pred_eq_opp_succ_opp, succ_opp.
-rewrite pred_succ_aux.
+unfold pred.
+rewrite succ_opp, pred_succ_pos.
apply Ropp_involutive.
now apply generic_format_opp.
now apply Ropp_0_gt_lt_contravar.
@@ -1606,8 +1599,8 @@ Qed.
Theorem round_UP_pred_plus_eps :
forall x, F x ->
- forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
- else (ulp (pred x)))%R ->
+ forall eps, (0 < eps <= if Rle_bool x 0 then ulp x
+ else ulp (pred x))%R ->
round beta fexp Zceil (pred x + eps) = x.
Proof.
intros x Fx eps Heps.
@@ -1636,7 +1629,6 @@ now apply pred_ge_0.
now apply generic_format_opp.
Qed.
-
Theorem round_DN_minus_eps:
forall x, F x ->
forall eps, (0 < eps <= if (Rle_bool x 0) then (ulp x)
@@ -1676,7 +1668,7 @@ Qed.
(* was ulp_error *)
Theorem error_lt_ulp :
forall rnd { Zrnd : Valid_rnd rnd } x,
- (x <> 0)%R ->
+ (x <> 0)%R ->
(Rabs (round beta fexp rnd x - x) < ulp x)%R.
Proof with auto with typeclass_instances.
intros rnd Zrnd x Zx.
@@ -1734,7 +1726,6 @@ intros Zx; left.
now apply error_lt_ulp.
Qed.
-(* was ulp_half_error *)
Theorem error_le_half_ulp :
forall choice x,
(Rabs (round beta fexp (Znearest choice) x - x) <= /2 * ulp x)%R.
@@ -1748,7 +1739,7 @@ rewrite Rplus_opp_r, Rabs_R0.
apply Rmult_le_pos.
apply Rlt_le.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply ulp_ge_0.
(* x <> rnd x *)
set (d := round beta fexp Zfloor x).
@@ -1761,7 +1752,7 @@ apply (round_DN_pt beta fexp x).
rewrite Rabs_left1.
rewrite Ropp_minus_distr.
apply Rmult_le_reg_r with 2%R.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply Rplus_le_reg_r with (d - x)%R.
ring_simplify.
apply Rle_trans with (1 := H).
@@ -1778,7 +1769,7 @@ rewrite Hu.
apply (round_UP_pt beta fexp x).
rewrite Rabs_pos_eq.
apply Rmult_le_reg_r with 2%R.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply Rplus_le_reg_r with (- (d + ulp x - x))%R.
ring_simplify.
apply Rlt_le.
@@ -1789,28 +1780,40 @@ rewrite Hu.
apply (round_UP_pt beta fexp x).
Qed.
-
Theorem ulp_DN :
- forall x,
- (0 < round beta fexp Zfloor x)%R ->
+ forall x, (0 <= x)%R ->
ulp (round beta fexp Zfloor x) = ulp x.
Proof with auto with typeclass_instances.
-intros x Hd.
-rewrite 2!ulp_neq_0.
-now rewrite canonic_exp_DN with (2 := Hd).
-intros T; contradict Hd; rewrite T, round_0...
-apply Rlt_irrefl.
-now apply Rgt_not_eq.
-Qed.
-
-Theorem round_neq_0_negligible_exp:
- negligible_exp=None -> forall rnd { Zrnd : Valid_rnd rnd } x,
- (x <> 0)%R -> (round beta fexp rnd x <> 0)%R.
+intros x [Hx|Hx].
+- rewrite (ulp_neq_0 x) by now apply Rgt_not_eq.
+ destruct (round_ge_generic beta fexp Zfloor 0 x) as [Hd|Hd].
+ apply generic_format_0.
+ now apply Rlt_le.
+ + rewrite ulp_neq_0 by now apply Rgt_not_eq.
+ now rewrite cexp_DN with (2 := Hd).
+ + rewrite <- Hd.
+ unfold cexp.
+ destruct (mag beta x) as [e He].
+ simpl.
+ specialize (He (Rgt_not_eq _ _ Hx)).
+ apply sym_eq in Hd.
+ assert (H := exp_small_round_0 _ _ _ _ _ He Hd).
+ unfold ulp.
+ rewrite Req_bool_true by easy.
+ destruct negligible_exp_spec as [H0|k Hk].
+ now elim Zlt_not_le with (1 := H0 e).
+ now apply f_equal, fexp_negligible_exp_eq.
+- rewrite <- Hx, round_0...
+Qed.
+
+Theorem round_neq_0_negligible_exp :
+ negligible_exp = None -> forall rnd { Zrnd : Valid_rnd rnd } x,
+ (x <> 0)%R -> (round beta fexp rnd x <> 0)%R.
Proof with auto with typeclass_instances.
intros H rndn Hrnd x Hx K.
case negligible_exp_spec'.
intros (_,Hn).
-destruct (ln_beta beta x) as (e,He).
+destruct (mag beta x) as (e,He).
absurd (fexp e < e)%Z.
apply Zle_not_lt.
apply exp_small_round_0 with beta rndn x...
@@ -1819,12 +1822,10 @@ intros (n,(H1,_)).
rewrite H in H1; discriminate.
Qed.
-
(** allows rnd x to be 0 *)
-(* was ulp_error_f *)
Theorem error_lt_ulp_round :
forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
- ( x <> 0)%R ->
+ (x <> 0)%R ->
(Rabs (round beta fexp rnd x - x) < ulp (round beta fexp rnd x))%R.
Proof with auto with typeclass_instances.
intros Hm.
@@ -1847,72 +1848,34 @@ now apply valid_rnd_opp.
now apply Ropp_0_gt_lt_contravar.
(* 0 < x *)
intros rnd Hrnd x Hx.
-case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
-apply round_ge_generic...
-apply generic_format_0.
-now left.
-(* . 0 < round Zfloor x *)
-intros Hx2.
apply Rlt_le_trans with (ulp x).
apply error_lt_ulp...
now apply Rgt_not_eq.
rewrite <- ulp_DN; trivial.
apply ulp_le_pos.
-now left.
+apply round_ge_generic...
+apply generic_format_0.
+now apply Rlt_le.
case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V.
apply Rle_refl.
apply Rle_trans with x.
apply round_DN_pt...
apply round_UP_pt...
-(* . 0 = round Zfloor x *)
-intros Hx2.
-case (round_DN_or_UP beta fexp rnd x); intros V; rewrite V; clear V.
-(* .. round down -- difficult case *)
-rewrite <- Hx2.
-unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp.
-unfold ulp; rewrite Req_bool_true; trivial.
-case negligible_exp_spec.
-(* without minimal exponent *)
-intros K; contradict Hx2.
-apply Rlt_not_eq.
-apply F2R_gt_0_compat; simpl.
-apply Zlt_le_trans with 1%Z.
-apply Pos2Z.is_pos.
-apply Zfloor_lub.
-simpl; unfold scaled_mantissa, canonic_exp.
-destruct (ln_beta beta x) as (e,He); simpl.
-apply Rle_trans with (bpow (e-1) * bpow (- fexp e))%R.
-rewrite <- bpow_plus.
-replace 1%R with (bpow 0) by reflexivity.
-apply bpow_le.
-specialize (K e); omega.
-apply Rmult_le_compat_r.
-apply bpow_ge_0.
-rewrite <- (Rabs_pos_eq x).
-now apply He, Rgt_not_eq.
-now left.
-(* with a minimal exponent *)
-intros n Hn.
-rewrite Rabs_pos_eq;[idtac|now left].
-case (Rle_or_lt (bpow (fexp n)) x); trivial.
-intros K; contradict Hx2.
-apply Rlt_not_eq.
-apply Rlt_le_trans with (bpow (fexp n)).
-apply bpow_gt_0.
-apply round_ge_generic...
-apply generic_format_bpow.
-now apply valid_exp.
-(* .. round up *)
-apply Rlt_le_trans with (ulp x).
-apply error_lt_ulp...
-now apply Rgt_not_eq.
-apply ulp_le_pos.
-now left.
-apply round_UP_pt...
+now apply Rlt_le.
+Qed.
+
+Lemma error_le_ulp_round :
+ forall { Hm : Monotone_exp fexp } rnd { Zrnd : Valid_rnd rnd } x,
+ (Rabs (round beta fexp rnd x - x) <= ulp (round beta fexp rnd x))%R.
+Proof.
+intros Mexp rnd Vrnd x.
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ rewrite Zx, round_0; [|exact Vrnd].
+ unfold Rminus; rewrite Ropp_0, Rplus_0_l, Rabs_R0; apply ulp_ge_0. }
+now apply Rlt_le, error_lt_ulp_round.
Qed.
(** allows both x and rnd x to be 0 *)
-(* was ulp_half_error_f *)
Theorem error_le_half_ulp_round :
forall { Hm : Monotone_exp fexp },
forall choice x,
@@ -1939,11 +1902,11 @@ apply Rle_trans with (1:=N).
right; apply f_equal.
rewrite ulp_neq_0; trivial.
apply f_equal.
-unfold canonic_exp.
+unfold cexp.
apply valid_exp; trivial.
-assert (ln_beta beta x -1 < fexp n)%Z;[idtac|omega].
+assert (mag beta x -1 < fexp n)%Z;[idtac|omega].
apply lt_bpow with beta.
-destruct (ln_beta beta x) as (e,He).
+destruct (mag beta x) as (e,He).
simpl.
apply Rle_lt_trans with (Rabs x).
now apply He.
@@ -1958,42 +1921,29 @@ now right.
(* *)
case (round_DN_or_UP beta fexp (Znearest choice) x); intros Hx.
(* . *)
-case (Rle_or_lt 0 (round beta fexp Zfloor x)).
-intros H; destruct H.
+destruct (Rle_or_lt 0 x) as [H|H].
rewrite Hx at 2.
-rewrite ulp_DN; trivial.
+rewrite ulp_DN by easy.
apply error_le_half_ulp.
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
apply Rle_trans with (1:=error_le_half_ulp _ _).
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
apply ulp_le.
-rewrite Hx; rewrite (Rabs_left1 x), Rabs_left; try assumption.
+rewrite Rabs_left1 by now apply Rlt_le.
+rewrite Hx.
+rewrite Rabs_left1.
apply Ropp_le_contravar.
-apply (round_DN_pt beta fexp x).
-case (Rle_or_lt x 0); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_ge_generic...
+apply round_DN_pt...
+apply round_le_generic...
apply generic_format_0.
-now left.
+now apply Rlt_le.
(* . *)
-case (Rle_or_lt 0 (round beta fexp Zceil x)).
-intros H; destruct H.
+destruct (Rle_or_lt 0 x) as [H|H].
apply Rle_trans with (1:=error_le_half_ulp _ _).
apply Rmult_le_compat_l.
apply Rlt_le, pos_half_prf.
apply ulp_le_pos; trivial.
-case (Rle_or_lt 0 x); trivial.
-intros H1; contradict H.
-apply Rle_not_lt.
-apply round_le_generic...
-apply generic_format_0.
-now left.
rewrite Hx; apply (round_UP_pt beta fexp x).
-rewrite Hx in Hfx; contradict Hfx; auto with real.
-intros H.
rewrite Hx at 2; rewrite <- (ulp_opp (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite ulp_DN; trivial.
@@ -2002,7 +1952,9 @@ rewrite round_N_opp.
unfold Rminus.
rewrite <- Ropp_plus_distr, Rabs_Ropp.
apply error_le_half_ulp.
-rewrite round_DN_opp; apply Ropp_0_gt_lt_contravar; apply Rlt_gt; assumption.
+rewrite <- Ropp_0.
+apply Ropp_le_contravar.
+now apply Rlt_le.
Qed.
Theorem pred_le :
@@ -2011,18 +1963,22 @@ Theorem pred_le :
Proof.
intros x y Fx Fy [Hxy| ->].
2: apply Rle_refl.
-apply le_pred_lt with (2 := Fy).
+apply pred_ge_gt with (2 := Fy).
now apply generic_format_pred.
apply Rle_lt_trans with (2 := Hxy).
apply pred_le_id.
Qed.
-Theorem succ_le: forall x y,
- F x -> F y -> (x <= y)%R -> (succ x <= succ y)%R.
+Theorem succ_le :
+ forall x y, F x -> F y -> (x <= y)%R ->
+ (succ x <= succ y)%R.
Proof.
intros x y Fx Fy Hxy.
-rewrite 2!succ_eq_opp_pred_opp.
-apply Ropp_le_contravar, pred_le; try apply generic_format_opp; try assumption.
+apply Ropp_le_cancel.
+rewrite <- 2!pred_opp.
+apply pred_le.
+now apply generic_format_opp.
+now apply generic_format_opp.
now apply Ropp_le_contravar.
Qed.
@@ -2064,8 +2020,95 @@ apply Rgt_not_le with (1 := Hxy).
now apply succ_le_inv.
Qed.
-(* was lt_UP_le_DN *)
-Theorem le_round_DN_lt_UP :
+(** Adding [ulp] is a, somewhat reasonable, overapproximation of [succ]. *)
+Lemma succ_le_plus_ulp :
+ forall { Hm : Monotone_exp fexp } x,
+ (succ x <= x + ulp x)%R.
+Proof.
+intros Mexp x.
+destruct (Rle_or_lt 0 x) as [Px|Nx]; [now right; apply succ_eq_pos|].
+replace (_ + _)%R with (- (-x - ulp x))%R by ring.
+unfold succ; rewrite (Rle_bool_false _ _ Nx), <-ulp_opp.
+apply Ropp_le_contravar; unfold pred_pos.
+destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx].
+{ rewrite (Req_bool_true _ _ Hx).
+ apply (Rplus_le_reg_r x); ring_simplify; apply Ropp_le_contravar.
+ unfold ulp; rewrite Req_bool_false; [|lra].
+ apply bpow_le, Mexp; lia. }
+ now rewrite (Req_bool_false _ _ Hx); right.
+Qed.
+
+(** And it also lies in the format. *)
+Lemma generic_format_plus_ulp :
+ forall { Hm : Monotone_exp fexp } x,
+ generic_format beta fexp x ->
+ generic_format beta fexp (x + ulp x).
+Proof.
+intros Mexp x Fx.
+destruct (Rle_or_lt 0 x) as [Px|Nx].
+{ now rewrite <-(succ_eq_pos _ Px); apply generic_format_succ. }
+apply generic_format_opp in Fx.
+replace (_ + _)%R with (- (-x - ulp x))%R by ring.
+apply generic_format_opp; rewrite <-ulp_opp.
+destruct (Req_dec (-x) (bpow (mag beta (-x) - 1))) as [Hx|Hx].
+{ unfold ulp; rewrite Req_bool_false; [|lra].
+ rewrite Hx at 1.
+ unfold cexp.
+ set (e := mag _ _).
+ assert (Hfe : (fexp e < e)%Z).
+ { now apply mag_generic_gt; [|lra|]. }
+ replace (e - 1)%Z with (e - 1 - fexp e + fexp e)%Z by ring.
+ rewrite bpow_plus.
+ set (m := bpow (_ - _)).
+ replace (_ - _)%R with ((m - 1) * bpow (fexp e))%R; [|unfold m; ring].
+ case_eq (e - 1 - fexp e)%Z.
+ { intro He; unfold m; rewrite He; simpl; ring_simplify (1 - 1)%R.
+ rewrite Rmult_0_l; apply generic_format_0. }
+ { intros p Hp; unfold m; rewrite Hp; simpl.
+ pose (f := {| Defs.Fnum := (Z.pow_pos beta p - 1)%Z;
+ Defs.Fexp := fexp e |} : Defs.float beta).
+ apply (generic_format_F2R' _ _ _ f); [|intro Hm'; unfold f; simpl].
+ { now unfold Defs.F2R; simpl; rewrite minus_IZR. }
+ unfold cexp.
+ replace (IZR _) with (bpow (Z.pos p)); [|now simpl].
+ rewrite <-Hp.
+ assert (He : (1 <= e - 1 - fexp e)%Z); [lia|].
+ set (e' := mag _ (_ * _)).
+ assert (H : (e' = e - 1 :> Z)%Z); [|rewrite H; apply Mexp; lia].
+ unfold e'; apply mag_unique.
+ rewrite Rabs_mult, (Rabs_pos_eq (bpow _)); [|apply bpow_ge_0].
+ rewrite Rabs_pos_eq;
+ [|apply (Rplus_le_reg_r 1); ring_simplify;
+ change 1%R with (bpow 0); apply bpow_le; lia].
+ assert (beta_pos : (0 < IZR beta)%R).
+ { apply (Rlt_le_trans _ 2); [lra|].
+ apply IZR_le, Z.leb_le, radix_prop. }
+ split.
+ { replace (e - 1 - 1)%Z with (e - 1 - fexp e + -1 + fexp e)%Z by ring.
+ rewrite bpow_plus.
+ apply Rmult_le_compat_r; [apply bpow_ge_0|].
+ rewrite bpow_plus; simpl; unfold Z.pow_pos; simpl.
+ rewrite Zmult_1_r.
+ apply (Rmult_le_reg_r _ _ _ beta_pos).
+ rewrite Rmult_assoc, Rinv_l; [|lra]; rewrite Rmult_1_r.
+ apply (Rplus_le_reg_r (IZR beta)); ring_simplify.
+ apply (Rle_trans _ (2 * bpow (e - 1 - fexp e))).
+ { change 2%R with (1 + 1)%R; rewrite Rmult_plus_distr_r, Rmult_1_l.
+ apply Rplus_le_compat_l.
+ rewrite <-bpow_1; apply bpow_le; lia. }
+ rewrite Rmult_comm; apply Rmult_le_compat_l; [apply bpow_ge_0|].
+ apply IZR_le, Z.leb_le, radix_prop. }
+ apply (Rmult_lt_reg_r (bpow (- fexp e))); [apply bpow_gt_0|].
+ rewrite Rmult_assoc, <-!bpow_plus.
+ replace (fexp e + - fexp e)%Z with 0%Z by ring; simpl.
+ rewrite Rmult_1_r; unfold Zminus; lra. }
+ intros p Hp; exfalso; lia. }
+replace (_ - _)%R with (pred_pos (-x)).
+{ now apply generic_format_pred_pos; [|lra]. }
+now unfold pred_pos; rewrite Req_bool_false.
+Qed.
+
+Theorem round_DN_ge_UP_gt :
forall x y, F y ->
(y < round beta fexp Zceil x -> y <= round beta fexp Zfloor x)%R.
Proof with auto with typeclass_instances.
@@ -2078,10 +2121,9 @@ apply round_UP_pt...
now apply Rlt_le.
Qed.
-(* was lt_DN_le_UP *)
-Theorem round_UP_le_gt_DN :
+Theorem round_UP_le_DN_lt :
forall x y, F y ->
- (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R.
+ (round beta fexp Zfloor x < y -> round beta fexp Zceil x <= y)%R.
Proof with auto with typeclass_instances.
intros x y Fy Hlt.
apply round_UP_pt...
@@ -2092,8 +2134,6 @@ apply round_DN_pt...
now apply Rlt_le.
Qed.
-
-
Theorem pred_UP_le_DN :
forall x, (pred (round beta fexp Zceil x) <= round beta fexp Zfloor x)%R.
Proof with auto with typeclass_instances.
@@ -2115,16 +2155,26 @@ absurd (round beta fexp Zceil x <= - bpow (fexp n))%R.
apply Rlt_not_le.
rewrite Zx, <- Ropp_0.
apply Ropp_lt_contravar, bpow_gt_0.
-apply round_UP_le_gt_DN; try assumption.
+apply round_UP_le_DN_lt; try assumption.
apply generic_format_opp, generic_format_bpow.
now apply valid_exp.
assert (let u := round beta fexp Zceil x in pred u < u)%R as Hup.
now apply pred_lt_id.
-apply le_round_DN_lt_UP...
+apply round_DN_ge_UP_gt...
apply generic_format_pred...
now apply round_UP_pt.
Qed.
+Theorem UP_le_succ_DN :
+ forall x, (round beta fexp Zceil x <= succ (round beta fexp Zfloor x))%R.
+Proof.
+intros x.
+rewrite <- (Ropp_involutive x).
+rewrite round_DN_opp, round_UP_opp, succ_opp.
+apply Ropp_le_contravar.
+apply pred_UP_le_DN.
+Qed.
+
Theorem pred_UP_eq_DN :
forall x, ~ F x ->
(pred (round beta fexp Zceil x) = round beta fexp Zfloor x)%R.
@@ -2132,7 +2182,7 @@ Proof with auto with typeclass_instances.
intros x Fx.
apply Rle_antisym.
now apply pred_UP_le_DN.
-apply le_pred_lt; try apply generic_format_round...
+apply pred_ge_gt; try apply generic_format_round...
pose proof round_DN_UP_lt _ _ _ Fx as HE.
now apply Rlt_trans with (1 := proj1 HE) (2 := proj2 HE).
Qed.
@@ -2147,11 +2197,9 @@ rewrite succ_pred; trivial.
apply generic_format_round...
Qed.
-
-(* was betw_eq_DN *)
-Theorem round_DN_eq_betw: forall x d, F d
- -> (d <= x < succ d)%R
- -> round beta fexp Zfloor x = d.
+Theorem round_DN_eq :
+ forall x d, F d -> (d <= x < succ d)%R ->
+ round beta fexp Zfloor x = d.
Proof with auto with typeclass_instances.
intros x d Fd (Hxd1,Hxd2).
generalize (round_DN_pt beta fexp x); intros (T1,(T2,T3)).
@@ -2169,25 +2217,161 @@ apply generic_format_succ...
now left.
Qed.
-(* was betw_eq_UP *)
-Theorem round_UP_eq_betw: forall x u, F u
- -> (pred u < x <= u)%R
- -> round beta fexp Zceil x = u.
+Theorem round_UP_eq :
+ forall x u, F u -> (pred u < x <= u)%R ->
+ round beta fexp Zceil x = u.
Proof with auto with typeclass_instances.
intros x u Fu Hux.
rewrite <- (Ropp_involutive (round beta fexp Zceil x)).
rewrite <- round_DN_opp.
rewrite <- (Ropp_involutive u).
apply f_equal.
-apply round_DN_eq_betw; try assumption.
+apply round_DN_eq; try assumption.
now apply generic_format_opp.
split;[now apply Ropp_le_contravar|idtac].
rewrite succ_opp.
now apply Ropp_lt_contravar.
Qed.
+Lemma ulp_ulp_0 : forall {H : Exp_not_FTZ fexp},
+ ulp (ulp 0) = ulp 0.
+Proof.
+intros H; case (negligible_exp_spec').
+intros (K1,K2).
+replace (ulp 0) with 0%R at 1; try easy.
+apply sym_eq; unfold ulp; rewrite Req_bool_true; try easy.
+now rewrite K1.
+intros (n,(Hn1,Hn2)).
+apply Rle_antisym.
+replace (ulp 0) with (bpow (fexp n)).
+rewrite ulp_bpow.
+apply bpow_le.
+now apply valid_exp.
+unfold ulp; rewrite Req_bool_true; try easy.
+rewrite Hn1; easy.
+now apply ulp_ge_ulp_0.
+Qed.
+Lemma ulp_succ_pos : forall x, F x -> (0 < x)%R ->
+ ulp (succ x) = ulp x \/ succ x = bpow (mag beta x).
+Proof with auto with typeclass_instances.
+intros x Fx Hx.
+generalize (Rlt_le _ _ Hx); intros Hx'.
+rewrite succ_eq_pos;[idtac|now left].
+destruct (mag beta x) as (e,He); simpl.
+rewrite Rabs_pos_eq in He; try easy.
+specialize (He (Rgt_not_eq _ _ Hx)).
+assert (H:(x+ulp x <= bpow e)%R).
+apply id_p_ulp_le_bpow; try assumption.
+apply He.
+destruct H;[left|now right].
+rewrite ulp_neq_0 at 1.
+2: apply Rgt_not_eq, Rgt_lt, Rlt_le_trans with x...
+2: rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l.
+2: apply ulp_ge_0.
+rewrite ulp_neq_0 at 2.
+2: now apply Rgt_not_eq.
+f_equal; unfold cexp; f_equal.
+apply trans_eq with e.
+apply mag_unique_pos; split; try assumption.
+apply Rle_trans with (1:=proj1 He).
+rewrite <- (Rplus_0_r x) at 1; apply Rplus_le_compat_l.
+apply ulp_ge_0.
+now apply sym_eq, mag_unique_pos.
+Qed.
+
+
+Lemma ulp_round_pos :
+ forall { Not_FTZ_ : Exp_not_FTZ fexp},
+ forall rnd { Zrnd : Valid_rnd rnd } x,
+ (0 < x)%R -> ulp (round beta fexp rnd x) = ulp x
+ \/ round beta fexp rnd x = bpow (mag beta x).
+Proof with auto with typeclass_instances.
+intros Not_FTZ_ rnd Zrnd x Hx.
+case (generic_format_EM beta fexp x); intros Fx.
+rewrite round_generic...
+case (round_DN_or_UP beta fexp rnd x); intros Hr; rewrite Hr.
+left.
+apply ulp_DN; now left...
+assert (M:(0 <= round beta fexp Zfloor x)%R).
+apply round_ge_generic...
+apply generic_format_0...
+apply Rlt_le...
+destruct M as [M|M].
+rewrite <- (succ_DN_eq_UP x)...
+case (ulp_succ_pos (round beta fexp Zfloor x)); try intros Y.
+apply generic_format_round...
+assumption.
+rewrite ulp_DN in Y...
+now apply Rlt_le.
+right; rewrite Y.
+apply f_equal, mag_DN...
+left; rewrite <- (succ_DN_eq_UP x)...
+rewrite <- M, succ_0.
+rewrite ulp_ulp_0...
+case (negligible_exp_spec').
+intros (K1,K2).
+absurd (x = 0)%R.
+now apply Rgt_not_eq.
+apply eq_0_round_0_negligible_exp with Zfloor...
+intros (n,(Hn1,Hn2)).
+replace (ulp 0) with (bpow (fexp n)).
+2: unfold ulp; rewrite Req_bool_true; try easy.
+2: now rewrite Hn1.
+rewrite ulp_neq_0.
+2: apply Rgt_not_eq...
+unfold cexp; f_equal.
+destruct (mag beta x) as (e,He); simpl.
+apply sym_eq, valid_exp...
+assert (e <= fexp e)%Z.
+apply exp_small_round_0_pos with beta Zfloor x...
+rewrite <- (Rabs_pos_eq x).
+apply He, Rgt_not_eq...
+apply Rlt_le...
+replace (fexp n) with (fexp e); try assumption.
+now apply fexp_negligible_exp_eq.
+Qed.
+
+
+Theorem ulp_round : forall { Not_FTZ_ : Exp_not_FTZ fexp},
+ forall rnd { Zrnd : Valid_rnd rnd } x,
+ ulp (round beta fexp rnd x) = ulp x
+ \/ Rabs (round beta fexp rnd x) = bpow (mag beta x).
+Proof with auto with typeclass_instances.
+intros Not_FTZ_ rnd Zrnd x.
+case (Rtotal_order x 0); intros Zx.
+case (ulp_round_pos (Zrnd_opp rnd) (-x)).
+now apply Ropp_0_gt_lt_contravar.
+rewrite ulp_opp, <- ulp_opp.
+rewrite <- round_opp, Ropp_involutive.
+intros Y;now left.
+rewrite mag_opp.
+intros Y; right.
+rewrite <- (Ropp_involutive x) at 1.
+rewrite round_opp, Y.
+rewrite Rabs_Ropp, Rabs_right...
+apply Rle_ge, bpow_ge_0.
+destruct Zx as [Zx|Zx].
+left; rewrite Zx; rewrite round_0...
+rewrite Rabs_right.
+apply ulp_round_pos...
+apply Rle_ge, round_ge_generic...
+apply generic_format_0...
+now apply Rlt_le.
+Qed.
+
+Lemma succ_round_ge_id :
+ forall rnd { Zrnd : Valid_rnd rnd } x,
+ (x <= succ (round beta fexp rnd x))%R.
+Proof.
+intros rnd Vrnd x.
+apply (Rle_trans _ (round beta fexp Raux.Zceil x)).
+{ now apply round_UP_pt. }
+destruct (round_DN_or_UP beta fexp rnd x) as [Hr|Hr]; rewrite Hr.
+{ now apply UP_le_succ_DN. }
+apply succ_ge_id.
+Qed.
(** Properties of rounding to nearest and ulp *)
@@ -2215,14 +2399,14 @@ assert (T: (u < (u + succ u) / 2 < succ u)%R) by lra.
destruct T as (T1,T2).
apply Rnd_N_pt_monotone with F v ((u + succ u) / 2)%R...
apply round_N_pt...
-apply Rnd_DN_pt_N with (succ u)%R.
+apply Rnd_N_pt_DN with (succ u)%R.
pattern u at 3; replace u with (round beta fexp Zfloor ((u + succ u) / 2)).
apply round_DN_pt...
-apply round_DN_eq_betw; trivial.
+apply round_DN_eq; trivial.
split; try left; assumption.
pattern (succ u) at 2; replace (succ u) with (round beta fexp Zceil ((u + succ u) / 2)).
apply round_UP_pt...
-apply round_UP_eq_betw; trivial.
+apply round_UP_eq; trivial.
apply generic_format_succ...
rewrite pred_succ; trivial.
split; try left; assumption.
@@ -2275,12 +2459,12 @@ Lemma round_N_eq_DN_pt: forall choice x d u,
Proof with auto with typeclass_instances.
intros choice x d u Hd Hu H.
assert (H0:(d = round beta fexp Zfloor x)%R).
-apply Rnd_DN_pt_unicity with (1:=Hd).
+apply Rnd_DN_pt_unique with (1:=Hd).
apply round_DN_pt...
rewrite H0.
apply round_N_eq_DN.
rewrite <- H0.
-rewrite Rnd_UP_pt_unicity with F x (round beta fexp Zceil x) u; try assumption.
+rewrite Rnd_UP_pt_unique with F x (round beta fexp Zceil x) u; try assumption.
apply round_UP_pt...
Qed.
@@ -2310,13 +2494,28 @@ Lemma round_N_eq_UP_pt: forall choice x d u,
Proof with auto with typeclass_instances.
intros choice x d u Hd Hu H.
assert (H0:(u = round beta fexp Zceil x)%R).
-apply Rnd_UP_pt_unicity with (1:=Hu).
+apply Rnd_UP_pt_unique with (1:=Hu).
apply round_UP_pt...
rewrite H0.
apply round_N_eq_UP.
rewrite <- H0.
-rewrite Rnd_DN_pt_unicity with F x (round beta fexp Zfloor x) d; try assumption.
+rewrite Rnd_DN_pt_unique with F x (round beta fexp Zfloor x) d; try assumption.
apply round_DN_pt...
Qed.
+Lemma round_N_plus_ulp_ge :
+ forall { Hm : Monotone_exp fexp } choice1 choice2 x,
+ let rx := round beta fexp (Znearest choice2) x in
+ (x <= round beta fexp (Znearest choice1) (rx + ulp rx))%R.
+Proof.
+intros Hm choice1 choice2 x.
+simpl.
+set (rx := round _ _ _ x).
+assert (Vrnd1 : Valid_rnd (Znearest choice1)) by now apply valid_rnd_N.
+assert (Vrnd2 : Valid_rnd (Znearest choice2)) by now apply valid_rnd_N.
+apply (Rle_trans _ (succ rx)); [now apply succ_round_ge_id|].
+rewrite round_generic; [now apply succ_le_plus_ulp|now simpl|].
+now apply generic_format_plus_ulp, generic_format_round.
+Qed.
+
End Fcore_ulp.
diff --git a/flocq/Core/Fcore_Zaux.v b/flocq/Core/Zaux.v
index f6731b4c..e21d93a4 100644
--- a/flocq/Core/Fcore_Zaux.v
+++ b/flocq/Core/Zaux.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2011-2013 Sylvie Boldo
+Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2011-2013 Guillaume Melquiond
+Copyright (C) 2011-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -17,7 +17,7 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)
-Require Import ZArith.
+Require Import ZArith Omega.
Require Import Zquot.
Section Zmissing.
@@ -25,7 +25,7 @@ Section Zmissing.
(** About Z *)
Theorem Zopp_le_cancel :
forall x y : Z,
- (-y <= -x)%Z -> Zle x y.
+ (-y <= -x)%Z -> Z.le x y.
Proof.
intros x y Hxy.
apply Zplus_le_reg_r with (-x - y)%Z.
@@ -37,7 +37,7 @@ Theorem Zgt_not_eq :
(y < x)%Z -> (x <> y)%Z.
Proof.
intros x y H Hn.
-apply Zlt_irrefl with x.
+apply Z.lt_irrefl with x.
now rewrite Hn at 1.
Qed.
@@ -69,29 +69,8 @@ End Proof_Irrelevance.
Section Even_Odd.
-(** Zeven, used for rounding to nearest, ties to even *)
-Definition Zeven (n : Z) :=
- match n with
- | Zpos (xO _) => true
- | Zneg (xO _) => true
- | Z0 => true
- | _ => false
- end.
-
-Theorem Zeven_mult :
- forall x y, Zeven (x * y) = orb (Zeven x) (Zeven y).
-Proof.
-now intros [|[xp|xp|]|[xp|xp|]] [|[yp|yp|]|[yp|yp|]].
-Qed.
-
-Theorem Zeven_opp :
- forall x, Zeven (- x) = Zeven x.
-Proof.
-now intros [|[n|n|]|[n|n|]].
-Qed.
-
Theorem Zeven_ex :
- forall x, exists p, x = (2 * p + if Zeven x then 0 else 1)%Z.
+ forall x, exists p, x = (2 * p + if Z.even x then 0 else 1)%Z.
Proof.
intros [|[n|n|]|[n|n|]].
now exists Z0.
@@ -105,37 +84,6 @@ now exists (Zneg n).
now exists (-1)%Z.
Qed.
-Theorem Zeven_2xp1 :
- forall n, Zeven (2 * n + 1) = false.
-Proof.
-intros n.
-destruct (Zeven_ex (2 * n + 1)) as (p, Hp).
-revert Hp.
-case (Zeven (2 * n + 1)) ; try easy.
-intros H.
-apply False_ind.
-omega.
-Qed.
-
-Theorem Zeven_plus :
- forall x y, Zeven (x + y) = Bool.eqb (Zeven x) (Zeven y).
-Proof.
-intros x y.
-destruct (Zeven_ex x) as (px, Hx).
-rewrite Hx at 1.
-destruct (Zeven_ex y) as (py, Hy).
-rewrite Hy at 1.
-replace (2 * px + (if Zeven x then 0 else 1) + (2 * py + (if Zeven y then 0 else 1)))%Z
- with (2 * (px + py) + ((if Zeven x then 0 else 1) + (if Zeven y then 0 else 1)))%Z by ring.
-case (Zeven x) ; case (Zeven y).
-rewrite Zplus_0_r.
-now rewrite Zeven_mult.
-apply Zeven_2xp1.
-apply Zeven_2xp1.
-replace (2 * (px + py) + (1 + 1))%Z with (2 * (px + py + 1))%Z by ring.
-now rewrite Zeven_mult.
-Qed.
-
End Even_Odd.
Section Zpower.
@@ -145,12 +93,12 @@ Theorem Zpower_plus :
Zpower n (k1 + k2) = (Zpower n k1 * Zpower n k2)%Z.
Proof.
intros n k1 k2 H1 H2.
-now apply Zpower_exp ; apply Zle_ge.
+now apply Zpower_exp ; apply Z.le_ge.
Qed.
Theorem Zpower_Zpower_nat :
forall b e, (0 <= e)%Z ->
- Zpower b e = Zpower_nat b (Zabs_nat e).
+ Zpower b e = Zpower_nat b (Z.abs_nat e).
Proof.
intros b [|e|e] He.
apply refl_equal.
@@ -181,40 +129,14 @@ rewrite Zpower_nat_S.
now apply Zmult_lt_0_compat.
Qed.
-Theorem Zeven_Zpower :
- forall b e, (0 < e)%Z ->
- Zeven (Zpower b e) = Zeven b.
-Proof.
-intros b e He.
-case_eq (Zeven b) ; intros Hb.
-(* b even *)
-replace e with (e - 1 + 1)%Z by ring.
-rewrite Zpower_exp.
-rewrite Zeven_mult.
-replace (Zeven (b ^ 1)) with true.
-apply Bool.orb_true_r.
-unfold Zpower, Zpower_pos. simpl.
-now rewrite Zmult_1_r.
-omega.
-discriminate.
-(* b odd *)
-rewrite Zpower_Zpower_nat.
-induction (Zabs_nat e).
-easy.
-unfold Zpower_nat. simpl.
-rewrite Zeven_mult.
-now rewrite Hb.
-now apply Zlt_le_weak.
-Qed.
-
Theorem Zeven_Zpower_odd :
- forall b e, (0 <= e)%Z -> Zeven b = false ->
- Zeven (Zpower b e) = false.
+ forall b e, (0 <= e)%Z -> Z.even b = false ->
+ Z.even (Zpower b e) = false.
Proof.
intros b e He Hb.
destruct (Z_le_lt_eq_dec _ _ He) as [He'|He'].
rewrite <- Hb.
-now apply Zeven_Zpower.
+now apply Z.even_pow.
now rewrite <- He'.
Qed.
@@ -239,7 +161,7 @@ Variable r : radix.
Theorem radix_gt_0 : (0 < r)%Z.
Proof.
-apply Zlt_le_trans with 2%Z.
+apply Z.lt_le_trans with 2%Z.
easy.
apply Zle_bool_imp_le.
apply r.
@@ -248,7 +170,7 @@ Qed.
Theorem radix_gt_1 : (1 < r)%Z.
Proof.
destruct r as (v, Hr). simpl.
-apply Zlt_le_trans with 2%Z.
+apply Z.lt_le_trans with 2%Z.
easy.
now apply Zle_bool_imp_le.
Qed.
@@ -273,7 +195,7 @@ easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
apply radix_gt_0.
-apply Zle_lt_trans with (1 * Zpower_nat r n)%Z.
+apply Z.le_lt_trans with (1 * Zpower_nat r n)%Z.
rewrite Zmult_1_l.
now apply (Zlt_le_succ 0).
apply Zmult_lt_compat_r with (1 := H).
@@ -287,7 +209,7 @@ Theorem Zpower_gt_0 :
Proof.
intros p Hp.
rewrite Zpower_Zpower_nat with (1 := Hp).
-induction (Zabs_nat p).
+induction (Z.abs_nat p).
easy.
rewrite Zpower_nat_S.
apply Zmult_lt_0_compat with (2 := IHn).
@@ -336,7 +258,7 @@ rewrite <- (Zmult_1_r (r ^ e1)) at 1.
apply Zmult_lt_compat2.
split.
now apply Zpower_gt_0.
-apply Zle_refl.
+apply Z.le_refl.
split.
easy.
apply Zpower_gt_1.
@@ -363,6 +285,36 @@ apply Zpower_le.
clear -H ; omega.
Qed.
+Theorem Zpower_gt_id :
+ forall n, (n < Zpower r n)%Z.
+Proof.
+intros [|n|n] ; try easy.
+simpl.
+rewrite Zpower_pos_nat.
+rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
+induction (nat_of_P n).
+easy.
+rewrite inj_S.
+change (Zpower_nat r (S n0)) with (r * Zpower_nat r n0)%Z.
+unfold Z.succ.
+apply Z.lt_le_trans with (r * (Z_of_nat n0 + 1))%Z.
+clear.
+apply Zlt_0_minus_lt.
+replace (r * (Z_of_nat n0 + 1) - (Z_of_nat n0 + 1))%Z with ((r - 1) * (Z_of_nat n0 + 1))%Z by ring.
+apply Zmult_lt_0_compat.
+cut (2 <= r)%Z. omega.
+apply Zle_bool_imp_le.
+apply r.
+apply (Zle_lt_succ 0).
+apply Zle_0_nat.
+apply Zmult_le_compat_l.
+now apply Zlt_le_succ.
+apply Z.le_trans with 2%Z.
+easy.
+apply Zle_bool_imp_le.
+apply r.
+Qed.
+
End Zpower.
Section Div_Mod.
@@ -380,7 +332,7 @@ rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
-now apply Zlt_gt.
+now apply Z.lt_gt.
easy.
now elim Hb.
Qed.
@@ -411,7 +363,7 @@ Qed.
Theorem Zdiv_mod_mult :
forall n a b, (0 <= a)%Z -> (0 <= b)%Z ->
- (Zdiv (Zmod n (a * b)) a) = Zmod (Zdiv n a) b.
+ (Z.div (Zmod n (a * b)) a) = Zmod (Z.div n a) b.
Proof.
intros n a b Ha Hb.
destruct (Zle_lt_or_eq _ _ Ha) as [Ha'|Ha'].
@@ -421,12 +373,12 @@ rewrite (Zmult_comm a b) at 2.
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
-rewrite Z_div_plus by now apply Zlt_gt.
+rewrite Z_div_plus by now apply Z.lt_gt.
rewrite <- Zdiv_Zdiv by easy.
apply sym_eq.
apply Zmod_eq.
-now apply Zlt_gt.
-now apply Zmult_gt_0_compat ; apply Zlt_gt.
+now apply Z.lt_gt.
+now apply Zmult_gt_0_compat ; apply Z.lt_gt.
rewrite <- Hb'.
rewrite Zmult_0_r, 2!Zmod_0_r.
apply Zdiv_0_l.
@@ -439,7 +391,7 @@ Theorem ZOdiv_mod_mult :
(Z.quot (Z.rem n (a * b)) a) = Z.rem (Z.quot n a) b.
Proof.
intros n a b.
-destruct (Z_eq_dec a 0) as [Za|Za].
+destruct (Z.eq_dec a 0) as [Za|Za].
rewrite Za.
now rewrite 2!Zquot_0_r, Zrem_0_l.
assert (Z.rem n (a * b) = n + - (Z.quot (Z.quot n a) b * b) * a)%Z.
@@ -456,34 +408,34 @@ Qed.
Theorem ZOdiv_small_abs :
forall a b,
- (Zabs a < b)%Z -> Z.quot a b = Z0.
+ (Z.abs a < b)%Z -> Z.quot a b = Z0.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
-apply Zquot_small.
+apply Z.quot_small.
split.
exact H.
-now rewrite Zabs_eq in Ha.
-apply Zopp_inj.
-rewrite <- Zquot_opp_l, Zopp_0.
-apply Zquot_small.
+now rewrite Z.abs_eq in Ha.
+apply Z.opp_inj.
+rewrite <- Zquot_opp_l, Z.opp_0.
+apply Z.quot_small.
generalize (Zabs_non_eq a).
omega.
Qed.
Theorem ZOmod_small_abs :
forall a b,
- (Zabs a < b)%Z -> Z.rem a b = a.
+ (Z.abs a < b)%Z -> Z.rem a b = a.
Proof.
intros a b Ha.
destruct (Zle_or_lt 0 a) as [H|H].
-apply Zrem_small.
+apply Z.rem_small.
split.
exact H.
-now rewrite Zabs_eq in Ha.
-apply Zopp_inj.
+now rewrite Z.abs_eq in Ha.
+apply Z.opp_inj.
rewrite <- Zrem_opp_l.
-apply Zrem_small.
+apply Z.rem_small.
generalize (Zabs_non_eq a).
omega.
Qed.
@@ -493,7 +445,7 @@ Theorem ZOdiv_plus :
(Z.quot (a + b) c = Z.quot a c + Z.quot b c + Z.quot (Z.rem a c + Z.rem b c) c)%Z.
Proof.
intros a b c Hab.
-destruct (Z_eq_dec c 0) as [Zc|Zc].
+destruct (Z.eq_dec c 0) as [Zc|Zc].
now rewrite Zc, 4!Zquot_0_r.
apply Zmult_reg_r with (1 := Zc).
rewrite 2!Zmult_plus_distr_l.
@@ -632,8 +584,8 @@ Proof.
intros x y Hxy.
generalize (Zle_cases x y).
case Zle_bool ; intros H.
-elim (Zlt_irrefl x).
-now apply Zle_lt_trans with y.
+elim (Z.lt_irrefl x).
+now apply Z.le_lt_trans with y.
apply refl_equal.
Qed.
@@ -672,8 +624,8 @@ Proof.
intros x y Hxy.
generalize (Zlt_cases x y).
case Zlt_bool ; intros H.
-elim (Zlt_irrefl x).
-now apply Zlt_le_trans with y.
+elim (Z.lt_irrefl x).
+now apply Z.lt_le_trans with y.
apply refl_equal.
Qed.
@@ -707,32 +659,32 @@ Inductive Zcompare_prop (x y : Z) : comparison -> Prop :=
| Zcompare_Gt_ : (y < x)%Z -> Zcompare_prop x y Gt.
Theorem Zcompare_spec :
- forall x y, Zcompare_prop x y (Zcompare x y).
+ forall x y, Zcompare_prop x y (Z.compare x y).
Proof.
intros x y.
destruct (Z_dec x y) as [[H|H]|H].
generalize (Zlt_compare _ _ H).
-case (Zcompare x y) ; try easy.
+case (Z.compare x y) ; try easy.
now constructor.
generalize (Zgt_compare _ _ H).
-case (Zcompare x y) ; try easy.
+case (Z.compare x y) ; try easy.
constructor.
-now apply Zgt_lt.
+now apply Z.gt_lt.
generalize (proj2 (Zcompare_Eq_iff_eq _ _) H).
-case (Zcompare x y) ; try easy.
+case (Z.compare x y) ; try easy.
now constructor.
Qed.
Theorem Zcompare_Lt :
forall x y,
- (x < y)%Z -> Zcompare x y = Lt.
+ (x < y)%Z -> Z.compare x y = Lt.
Proof.
easy.
Qed.
Theorem Zcompare_Eq :
forall x y,
- (x = y)%Z -> Zcompare x y = Eq.
+ (x = y)%Z -> Z.compare x y = Eq.
Proof.
intros x y.
apply <- Zcompare_Eq_iff_eq.
@@ -740,21 +692,29 @@ Qed.
Theorem Zcompare_Gt :
forall x y,
- (y < x)%Z -> Zcompare x y = Gt.
+ (y < x)%Z -> Z.compare x y = Gt.
Proof.
intros x y.
-apply Zlt_gt.
+apply Z.lt_gt.
Qed.
End Zcompare.
Section cond_Zopp.
-Definition cond_Zopp (b : bool) m := if b then Zopp m else m.
+Definition cond_Zopp (b : bool) m := if b then Z.opp m else m.
+
+Theorem cond_Zopp_negb :
+ forall x y, cond_Zopp (negb x) y = Z.opp (cond_Zopp x y).
+Proof.
+intros [|] y.
+apply sym_eq, Z.opp_involutive.
+easy.
+Qed.
Theorem abs_cond_Zopp :
forall b m,
- Zabs (cond_Zopp b m) = Zabs m.
+ Z.abs (cond_Zopp b m) = Z.abs m.
Proof.
intros [|] m.
apply Zabs_Zopp.
@@ -763,14 +723,14 @@ Qed.
Theorem cond_Zopp_Zlt_bool :
forall m,
- cond_Zopp (Zlt_bool m 0) m = Zabs m.
+ cond_Zopp (Zlt_bool m 0) m = Z.abs m.
Proof.
intros m.
apply sym_eq.
case Zlt_bool_spec ; intros Hm.
apply Zabs_non_eq.
now apply Zlt_le_weak.
-now apply Zabs_eq.
+now apply Z.abs_eq.
Qed.
End cond_Zopp.
@@ -808,11 +768,11 @@ Section faster_div.
Lemma Zdiv_eucl_unique :
forall a b,
- Zdiv_eucl a b = (Zdiv a b, Zmod a b).
+ Z.div_eucl a b = (Z.div a b, Zmod a b).
Proof.
intros a b.
-unfold Zdiv, Zmod.
-now case Zdiv_eucl.
+unfold Z.div, Zmod.
+now case Z.div_eucl.
Qed.
Fixpoint Zpos_div_eucl_aux1 (a b : positive) {struct b} :=
@@ -835,7 +795,7 @@ intros a b.
revert a.
induction b ; intros a.
- easy.
-- change (Z.pos_div_eucl a (Zpos b~0)) with (Zdiv_eucl (Zpos a) (Zpos b~0)).
+- change (Z.pos_div_eucl a (Zpos b~0)) with (Z.div_eucl (Zpos a) (Zpos b~0)).
rewrite Zdiv_eucl_unique.
change (Zpos b~0) with (2 * Zpos b)%Z.
rewrite Z.rem_mul_r by easy.
@@ -843,7 +803,7 @@ induction b ; intros a.
destruct a as [a|a|].
+ change (Zpos_div_eucl_aux1 a~1 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r + 1)%Z).
rewrite IHb. clear IHb.
- change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
+ change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
change (Zpos a~1) with (1 + 2 * Zpos a)%Z.
rewrite (Zmult_comm 2 (Zpos a)).
@@ -853,7 +813,7 @@ induction b ; intros a.
apply Zplus_comm.
+ change (Zpos_div_eucl_aux1 a~0 b~0) with (let (q, r) := Zpos_div_eucl_aux1 a b in (q, 2 * r)%Z).
rewrite IHb. clear IHb.
- change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
+ change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
change (Zpos a~0) with (2 * Zpos a)%Z.
rewrite (Zmult_comm 2 (Zpos a)).
@@ -861,7 +821,7 @@ induction b ; intros a.
apply f_equal.
now rewrite Z_mod_mult.
+ easy.
-- change (Z.pos_div_eucl a 1) with (Zdiv_eucl (Zpos a) 1).
+- change (Z.pos_div_eucl a 1) with (Z.div_eucl (Zpos a) 1).
rewrite Zdiv_eucl_unique.
now rewrite Zdiv_1_r, Zmod_1_r.
Qed.
@@ -879,13 +839,13 @@ Lemma Zpos_div_eucl_aux_correct :
Proof.
intros a b.
unfold Zpos_div_eucl_aux.
-change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
+change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
rewrite Zdiv_eucl_unique.
case Pos.compare_spec ; intros H.
now rewrite H, Z_div_same, Z_mod_same.
now rewrite Zdiv_small, Zmod_small by (split ; easy).
rewrite Zpos_div_eucl_aux1_correct.
-change (Z.pos_div_eucl a (Zpos b)) with (Zdiv_eucl (Zpos a) (Zpos b)).
+change (Z.pos_div_eucl a (Zpos b)) with (Z.div_eucl (Zpos a) (Zpos b)).
apply Zdiv_eucl_unique.
Qed.
@@ -920,7 +880,7 @@ Definition Zfast_div_eucl (a b : Z) :=
Theorem Zfast_div_eucl_correct :
forall a b : Z,
- Zfast_div_eucl a b = Zdiv_eucl a b.
+ Zfast_div_eucl a b = Z.div_eucl a b.
Proof.
unfold Zfast_div_eucl.
intros [|a|a] [|b|b] ; try rewrite Zpos_div_eucl_aux_correct ; easy.
diff --git a/flocq/IEEE754/Binary.v b/flocq/IEEE754/Binary.v
new file mode 100644
index 00000000..ac38c761
--- /dev/null
+++ b/flocq/IEEE754/Binary.v
@@ -0,0 +1,2935 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * IEEE-754 arithmetic *)
+Require Import Core Digits Round Bracket Operations Div Sqrt Relative.
+Require Import Psatz.
+
+Section AnyRadix.
+
+Inductive full_float :=
+ | F754_zero (s : bool)
+ | F754_infinity (s : bool)
+ | F754_nan (s : bool) (m : positive)
+ | F754_finite (s : bool) (m : positive) (e : Z).
+
+Definition FF2R beta x :=
+ match x with
+ | F754_finite s m e => F2R (Float beta (cond_Zopp s (Zpos m)) e)
+ | _ => 0%R
+ end.
+
+End AnyRadix.
+
+Section Binary.
+
+Arguments exist {A} {P}.
+
+(** [prec] is the number of bits of the mantissa including the implicit one;
+ [emax] is the exponent of the infinities.
+ For instance, binary32 is defined by [prec = 24] and [emax = 128]. *)
+Variable prec emax : Z.
+Context (prec_gt_0_ : Prec_gt_0 prec).
+Hypothesis Hmax : (prec < emax)%Z.
+
+Let emin := (3 - emax - prec)%Z.
+Let fexp := FLT_exp emin prec.
+Instance fexp_correct : Valid_exp fexp := FLT_exp_valid emin prec.
+Instance fexp_monotone : Monotone_exp fexp := FLT_exp_monotone emin prec.
+
+Definition canonical_mantissa m e :=
+ Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e.
+
+Definition bounded m e :=
+ andb (canonical_mantissa m e) (Zle_bool e (emax - prec)).
+
+Definition nan_pl pl :=
+ Zlt_bool (Zpos (digits2_pos pl)) prec.
+
+Definition valid_binary x :=
+ match x with
+ | F754_finite _ m e => bounded m e
+ | F754_nan _ pl => nan_pl pl
+ | _ => true
+ end.
+
+(** Basic type used for representing binary FP numbers.
+ Note that there is exactly one such object per FP datum. *)
+
+Inductive binary_float :=
+ | B754_zero (s : bool)
+ | B754_infinity (s : bool)
+ | B754_nan (s : bool) (pl : positive) :
+ nan_pl pl = true -> binary_float
+ | B754_finite (s : bool) (m : positive) (e : Z) :
+ bounded m e = true -> binary_float.
+
+Definition FF2B x :=
+ match x as x return valid_binary x = true -> binary_float with
+ | F754_finite s m e => B754_finite s m e
+ | F754_infinity s => fun _ => B754_infinity s
+ | F754_zero s => fun _ => B754_zero s
+ | F754_nan b pl => fun H => B754_nan b pl H
+ end.
+
+Definition B2FF x :=
+ match x with
+ | B754_finite s m e _ => F754_finite s m e
+ | B754_infinity s => F754_infinity s
+ | B754_zero s => F754_zero s
+ | B754_nan b pl _ => F754_nan b pl
+ end.
+
+Definition B2R f :=
+ match f with
+ | B754_finite s m e _ => F2R (Float radix2 (cond_Zopp s (Zpos m)) e)
+ | _ => 0%R
+ end.
+
+Theorem FF2R_B2FF :
+ forall x,
+ FF2R radix2 (B2FF x) = B2R x.
+Proof.
+now intros [sx|sx|sx plx Hplx|sx mx ex Hx].
+Qed.
+
+Theorem B2FF_FF2B :
+ forall x Hx,
+ B2FF (FF2B x Hx) = x.
+Proof.
+now intros [sx|sx|sx plx|sx mx ex] Hx.
+Qed.
+
+Theorem valid_binary_B2FF :
+ forall x,
+ valid_binary (B2FF x) = true.
+Proof.
+now intros [sx|sx|sx plx Hplx|sx mx ex Hx].
+Qed.
+
+Theorem FF2B_B2FF :
+ forall x H,
+ FF2B (B2FF x) H = x.
+Proof.
+intros [sx|sx|sx plx Hplx|sx mx ex Hx] H ; try easy.
+apply f_equal, eqbool_irrelevance.
+apply f_equal, eqbool_irrelevance.
+Qed.
+
+Theorem FF2B_B2FF_valid :
+ forall x,
+ FF2B (B2FF x) (valid_binary_B2FF x) = x.
+Proof.
+intros x.
+apply FF2B_B2FF.
+Qed.
+
+Theorem B2R_FF2B :
+ forall x Hx,
+ B2R (FF2B x Hx) = FF2R radix2 x.
+Proof.
+now intros [sx|sx|sx plx|sx mx ex] Hx.
+Qed.
+
+Theorem match_FF2B :
+ forall {T} fz fi fn ff x Hx,
+ match FF2B x Hx return T with
+ | B754_zero sx => fz sx
+ | B754_infinity sx => fi sx
+ | B754_nan b p _ => fn b p
+ | B754_finite sx mx ex _ => ff sx mx ex
+ end =
+ match x with
+ | F754_zero sx => fz sx
+ | F754_infinity sx => fi sx
+ | F754_nan b p => fn b p
+ | F754_finite sx mx ex => ff sx mx ex
+ end.
+Proof.
+now intros T fz fi fn ff [sx|sx|sx plx|sx mx ex] Hx.
+Qed.
+
+Theorem canonical_canonical_mantissa :
+ forall (sx : bool) mx ex,
+ canonical_mantissa mx ex = true ->
+ canonical radix2 fexp (Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+Proof.
+intros sx mx ex H.
+assert (Hx := Zeq_bool_eq _ _ H). clear H.
+apply sym_eq.
+simpl.
+pattern ex at 2 ; rewrite <- Hx.
+apply (f_equal fexp).
+rewrite mag_F2R_Zdigits.
+rewrite <- Zdigits_abs.
+rewrite Zpos_digits2_pos.
+now case sx.
+now case sx.
+Qed.
+
+Theorem generic_format_B2R :
+ forall x,
+ generic_format radix2 fexp (B2R x).
+Proof.
+intros [sx|sx|sx plx Hx |sx mx ex Hx] ; try apply generic_format_0.
+simpl.
+apply generic_format_canonical.
+apply canonical_canonical_mantissa.
+now destruct (andb_prop _ _ Hx) as (H, _).
+Qed.
+
+Theorem FLT_format_B2R :
+ forall x,
+ FLT_format radix2 emin prec (B2R x).
+Proof with auto with typeclass_instances.
+intros x.
+apply FLT_format_generic...
+apply generic_format_B2R.
+Qed.
+
+Theorem B2FF_inj :
+ forall x y : binary_float,
+ B2FF x = B2FF y ->
+ x = y.
+Proof.
+intros [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ; try easy.
+(* *)
+intros H.
+now inversion H.
+(* *)
+intros H.
+now inversion H.
+(* *)
+intros H.
+inversion H.
+clear H.
+revert Hplx.
+rewrite H2.
+intros Hx.
+apply f_equal, eqbool_irrelevance.
+(* *)
+intros H.
+inversion H.
+clear H.
+revert Hx.
+rewrite H2, H3.
+intros Hx.
+apply f_equal, eqbool_irrelevance.
+Qed.
+
+Definition is_finite_strict f :=
+ match f with
+ | B754_finite _ _ _ _ => true
+ | _ => false
+ end.
+
+Theorem B2R_inj:
+ forall x y : binary_float,
+ is_finite_strict x = true ->
+ is_finite_strict y = true ->
+ B2R x = B2R y ->
+ x = y.
+Proof.
+intros [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] ; try easy.
+simpl.
+intros _ _ Heq.
+assert (Hs: sx = sy).
+(* *)
+revert Heq. clear.
+case sx ; case sy ; try easy ;
+ intros Heq ; apply False_ind ; revert Heq.
+apply Rlt_not_eq.
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+apply Rgt_not_eq.
+apply Rgt_trans with R0.
+now apply F2R_gt_0.
+now apply F2R_lt_0.
+assert (mx = my /\ ex = ey).
+(* *)
+refine (_ (canonical_unique _ fexp _ _ _ _ Heq)).
+rewrite Hs.
+now case sy ; intro H ; injection H ; split.
+apply canonical_canonical_mantissa.
+exact (proj1 (andb_prop _ _ Hx)).
+apply canonical_canonical_mantissa.
+exact (proj1 (andb_prop _ _ Hy)).
+(* *)
+revert Hx.
+rewrite Hs, (proj1 H), (proj2 H).
+intros Hx.
+apply f_equal.
+apply eqbool_irrelevance.
+Qed.
+
+Definition Bsign x :=
+ match x with
+ | B754_nan s _ _ => s
+ | B754_zero s => s
+ | B754_infinity s => s
+ | B754_finite s _ _ _ => s
+ end.
+
+Definition sign_FF x :=
+ match x with
+ | F754_nan s _ => s
+ | F754_zero s => s
+ | F754_infinity s => s
+ | F754_finite s _ _ => s
+ end.
+
+Theorem Bsign_FF2B :
+ forall x H,
+ Bsign (FF2B x H) = sign_FF x.
+Proof.
+now intros [sx|sx|sx plx|sx mx ex] H.
+Qed.
+
+Definition is_finite f :=
+ match f with
+ | B754_finite _ _ _ _ => true
+ | B754_zero _ => true
+ | _ => false
+ end.
+
+Definition is_finite_FF f :=
+ match f with
+ | F754_finite _ _ _ => true
+ | F754_zero _ => true
+ | _ => false
+ end.
+
+Theorem is_finite_FF2B :
+ forall x Hx,
+ is_finite (FF2B x Hx) = is_finite_FF x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_finite_FF_B2FF :
+ forall x,
+ is_finite_FF (B2FF x) = is_finite x.
+Proof.
+now intros [| |? []|].
+Qed.
+
+Theorem B2R_Bsign_inj:
+ forall x y : binary_float,
+ is_finite x = true ->
+ is_finite y = true ->
+ B2R x = B2R y ->
+ Bsign x = Bsign y ->
+ x = y.
+Proof.
+intros. destruct x, y; try (apply B2R_inj; now eauto).
+- simpl in H2. congruence.
+- symmetry in H1. apply Rmult_integral in H1.
+ destruct H1. apply (eq_IZR _ 0) in H1. destruct s0; discriminate H1.
+ simpl in H1. pose proof (bpow_gt_0 radix2 e).
+ rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
+- apply Rmult_integral in H1.
+ destruct H1. apply (eq_IZR _ 0) in H1. destruct s; discriminate H1.
+ simpl in H1. pose proof (bpow_gt_0 radix2 e).
+ rewrite H1 in H3. apply Rlt_irrefl in H3. destruct H3.
+Qed.
+
+Definition is_nan f :=
+ match f with
+ | B754_nan _ _ _ => true
+ | _ => false
+ end.
+
+Definition is_nan_FF f :=
+ match f with
+ | F754_nan _ _ => true
+ | _ => false
+ end.
+
+Theorem is_nan_FF2B :
+ forall x Hx,
+ is_nan (FF2B x Hx) = is_nan_FF x.
+Proof.
+now intros [| | |].
+Qed.
+
+Theorem is_nan_FF_B2FF :
+ forall x,
+ is_nan_FF (B2FF x) = is_nan x.
+Proof.
+now intros [| |? []|].
+Qed.
+
+Definition get_nan_pl (x : binary_float) : positive :=
+ match x with B754_nan _ pl _ => pl | _ => xH end.
+
+Definition build_nan (x : { x | is_nan x = true }) : binary_float.
+Proof.
+apply (B754_nan (Bsign (proj1_sig x)) (get_nan_pl (proj1_sig x))).
+destruct x as [x H].
+simpl.
+revert H.
+assert (H: false = true -> nan_pl 1 = true) by now destruct (nan_pl 1).
+destruct x; try apply H.
+intros _.
+apply e.
+Defined.
+
+Theorem build_nan_correct :
+ forall x : { x | is_nan x = true },
+ build_nan x = proj1_sig x.
+Proof.
+intros [x H].
+now destruct x.
+Qed.
+
+Theorem B2R_build_nan :
+ forall x, B2R (build_nan x) = 0%R.
+Proof.
+easy.
+Qed.
+
+Theorem is_finite_build_nan :
+ forall x, is_finite (build_nan x) = false.
+Proof.
+easy.
+Qed.
+
+Theorem is_nan_build_nan :
+ forall x, is_nan (build_nan x) = true.
+Proof.
+easy.
+Qed.
+
+Definition erase (x : binary_float) : binary_float.
+Proof.
+destruct x as [s|s|s pl H|s m e H].
+- exact (B754_zero s).
+- exact (B754_infinity s).
+- apply (B754_nan s pl).
+ destruct nan_pl.
+ apply eq_refl.
+ exact H.
+- apply (B754_finite s m e).
+ destruct bounded.
+ apply eq_refl.
+ exact H.
+Defined.
+
+Theorem erase_correct :
+ forall x, erase x = x.
+Proof.
+destruct x as [s|s|s pl H|s m e H] ; try easy ; simpl.
+- apply f_equal, eqbool_irrelevance.
+- apply f_equal, eqbool_irrelevance.
+Qed.
+
+(** Opposite *)
+
+Definition Bopp opp_nan x :=
+ match x with
+ | B754_nan _ _ _ => build_nan (opp_nan x)
+ | B754_infinity sx => B754_infinity (negb sx)
+ | B754_finite sx mx ex Hx => B754_finite (negb sx) mx ex Hx
+ | B754_zero sx => B754_zero (negb sx)
+ end.
+
+Theorem Bopp_involutive :
+ forall opp_nan x,
+ is_nan x = false ->
+ Bopp opp_nan (Bopp opp_nan x) = x.
+Proof.
+now intros opp_nan [sx|sx|sx plx|sx mx ex Hx] ; simpl ; try rewrite Bool.negb_involutive.
+Qed.
+
+Theorem B2R_Bopp :
+ forall opp_nan x,
+ B2R (Bopp opp_nan x) = (- B2R x)%R.
+Proof.
+intros opp_nan [sx|sx|sx plx Hplx|sx mx ex Hx]; apply sym_eq ; try apply Ropp_0.
+simpl.
+rewrite <- F2R_opp.
+now case sx.
+Qed.
+
+Theorem is_finite_Bopp :
+ forall opp_nan x,
+ is_finite (Bopp opp_nan x) = is_finite x.
+Proof.
+now intros opp_nan [| | |].
+Qed.
+
+Lemma Bsign_Bopp :
+ forall opp_nan x, is_nan x = false -> Bsign (Bopp opp_nan x) = negb (Bsign x).
+Proof. now intros opp_nan [s|s|s pl H|s m e H]. Qed.
+
+(** Absolute value *)
+
+Definition Babs abs_nan (x : binary_float) : binary_float :=
+ match x with
+ | B754_nan _ _ _ => build_nan (abs_nan x)
+ | B754_infinity sx => B754_infinity false
+ | B754_finite sx mx ex Hx => B754_finite false mx ex Hx
+ | B754_zero sx => B754_zero false
+ end.
+
+Theorem B2R_Babs :
+ forall abs_nan x,
+ B2R (Babs abs_nan x) = Rabs (B2R x).
+Proof.
+ intros abs_nan [sx|sx|sx plx Hx|sx mx ex Hx]; apply sym_eq ; try apply Rabs_R0.
+ simpl. rewrite <- F2R_abs. now destruct sx.
+Qed.
+
+Theorem is_finite_Babs :
+ forall abs_nan x,
+ is_finite (Babs abs_nan x) = is_finite x.
+Proof.
+ now intros abs_nan [| | |].
+Qed.
+
+Theorem Bsign_Babs :
+ forall abs_nan x,
+ is_nan x = false ->
+ Bsign (Babs abs_nan x) = false.
+Proof.
+ now intros abs_nan [| | |].
+Qed.
+
+Theorem Babs_idempotent :
+ forall abs_nan (x: binary_float),
+ is_nan x = false ->
+ Babs abs_nan (Babs abs_nan x) = Babs abs_nan x.
+Proof.
+ now intros abs_nan [sx|sx|sx plx|sx mx ex Hx].
+Qed.
+
+Theorem Babs_Bopp :
+ forall abs_nan opp_nan x,
+ is_nan x = false ->
+ Babs abs_nan (Bopp opp_nan x) = Babs abs_nan x.
+Proof.
+ now intros abs_nan opp_nan [| | |].
+Qed.
+
+(** Comparison
+
+[Some c] means ordered as per [c]; [None] means unordered. *)
+
+Definition Bcompare (f1 f2 : binary_float) : option comparison :=
+ match f1, f2 with
+ | B754_nan _ _ _,_ | _,B754_nan _ _ _ => None
+ | B754_infinity s1, B754_infinity s2 =>
+ Some match s1, s2 with
+ | true, true => Eq
+ | false, false => Eq
+ | true, false => Lt
+ | false, true => Gt
+ end
+ | B754_infinity s, _ => Some (if s then Lt else Gt)
+ | _, B754_infinity s => Some (if s then Gt else Lt)
+ | B754_finite s _ _ _, B754_zero _ => Some (if s then Lt else Gt)
+ | B754_zero _, B754_finite s _ _ _ => Some (if s then Gt else Lt)
+ | B754_zero _, B754_zero _ => Some Eq
+ | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
+ Some match s1, s2 with
+ | true, false => Lt
+ | false, true => Gt
+ | false, false =>
+ match Z.compare e1 e2 with
+ | Lt => Lt
+ | Gt => Gt
+ | Eq => Pcompare m1 m2 Eq
+ end
+ | true, true =>
+ match Z.compare e1 e2 with
+ | Lt => Gt
+ | Gt => Lt
+ | Eq => CompOpp (Pcompare m1 m2 Eq)
+ end
+ end
+ end.
+
+Theorem Bcompare_correct :
+ forall f1 f2,
+ is_finite f1 = true -> is_finite f2 = true ->
+ Bcompare f1 f2 = Some (Rcompare (B2R f1) (B2R f2)).
+Proof.
+ Ltac apply_Rcompare :=
+ match goal with
+ | [ |- Lt = Rcompare _ _ ] => symmetry; apply Rcompare_Lt
+ | [ |- Eq = Rcompare _ _ ] => symmetry; apply Rcompare_Eq
+ | [ |- Gt = Rcompare _ _ ] => symmetry; apply Rcompare_Gt
+ end.
+ unfold Bcompare; intros f1 f2 H1 H2.
+ destruct f1, f2; try easy; apply f_equal; clear H1 H2.
+ now rewrite Rcompare_Eq.
+ destruct s0 ; apply_Rcompare.
+ now apply F2R_lt_0.
+ now apply F2R_gt_0.
+ destruct s ; apply_Rcompare.
+ now apply F2R_lt_0.
+ now apply F2R_gt_0.
+ simpl.
+ apply andb_prop in e0; destruct e0; apply (canonical_canonical_mantissa false) in H.
+ apply andb_prop in e2; destruct e2; apply (canonical_canonical_mantissa false) in H1.
+ pose proof (Zcompare_spec e e1); unfold canonical, Fexp in H1, H.
+ assert (forall m1 m2 e1 e2,
+ let x := (IZR (Zpos m1) * bpow radix2 e1)%R in
+ let y := (IZR (Zpos m2) * bpow radix2 e2)%R in
+ (cexp radix2 fexp x < cexp radix2 fexp y)%Z -> (x < y)%R).
+ {
+ intros; apply Rnot_le_lt; intro; apply (mag_le radix2) in H5.
+ apply Zlt_not_le with (1 := H4).
+ now apply fexp_monotone.
+ now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
+ }
+ assert (forall m1 m2 e1 e2, (IZR (- Zpos m1) * bpow radix2 e1 < IZR (Zpos m2) * bpow radix2 e2)%R).
+ {
+ intros; apply (Rlt_trans _ 0%R).
+ now apply (F2R_lt_0 _ (Float radix2 (Zneg m1) e0)).
+ now apply (F2R_gt_0 _ (Float radix2 (Zpos m2) e2)).
+ }
+ unfold F2R, Fnum, Fexp.
+ destruct s, s0; try (now apply_Rcompare; apply H5); inversion H3;
+ try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption);
+ try (apply_Rcompare; do 2 rewrite opp_IZR, Ropp_mult_distr_l_reverse;
+ apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption);
+ rewrite H7, Rcompare_mult_r, Rcompare_IZR by (apply bpow_gt_0); reflexivity.
+Qed.
+
+Theorem Bcompare_swap :
+ forall x y,
+ Bcompare y x = match Bcompare x y with Some c => Some (CompOpp c) | None => None end.
+Proof.
+ intros.
+ destruct x as [ ? | [] | ? ? | [] mx ex Bx ];
+ destruct y as [ ? | [] | ? ? | [] my ey By ]; simpl; try easy.
+- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
+ now rewrite (Pcompare_antisym mx my).
+- rewrite <- (Zcompare_antisym ex ey). destruct (ex ?= ey)%Z; try easy.
+ now rewrite Pcompare_antisym.
+Qed.
+
+Theorem bounded_lt_emax :
+ forall mx ex,
+ bounded mx ex = true ->
+ (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R.
+Proof.
+intros mx ex Hx.
+destruct (andb_prop _ _ Hx) as (H1,H2).
+generalize (Zeq_bool_eq _ _ H1). clear H1. intro H1.
+generalize (Zle_bool_imp_le _ _ H2). clear H2. intro H2.
+generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex).
+unfold mag_val.
+intros H.
+apply Rlt_le_trans with (bpow radix2 e').
+change (Zpos mx) with (Z.abs (Zpos mx)).
+rewrite F2R_Zabs.
+apply Ex.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+apply bpow_le.
+rewrite H. 2: discriminate.
+revert H1. clear -H2.
+rewrite Zpos_digits2_pos.
+unfold fexp, FLT_exp.
+intros ; zify ; omega.
+Qed.
+
+Theorem bounded_ge_emin :
+ forall mx ex,
+ bounded mx ex = true ->
+ (bpow radix2 emin <= F2R (Float radix2 (Zpos mx) ex))%R.
+Proof.
+intros mx ex Hx.
+destruct (andb_prop _ _ Hx) as [H1 _].
+apply Zeq_bool_eq in H1.
+generalize (mag_F2R_Zdigits radix2 (Zpos mx) ex).
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as [e' Ex].
+unfold mag_val.
+intros H.
+assert (H0 : Zpos mx <> 0%Z) by easy.
+rewrite Rabs_pos_eq in Ex by now apply F2R_ge_0.
+refine (Rle_trans _ _ _ _ (proj1 (Ex _))).
+2: now apply F2R_neq_0.
+apply bpow_le.
+rewrite H by easy.
+revert H1.
+rewrite Zpos_digits2_pos.
+generalize (Zdigits radix2 (Zpos mx)) (Zdigits_gt_0 radix2 (Zpos mx) H0).
+unfold fexp, FLT_exp.
+clear -prec_gt_0_.
+unfold Prec_gt_0 in prec_gt_0_.
+clearbody emin.
+intros ; zify ; omega.
+Qed.
+
+Theorem abs_B2R_lt_emax :
+ forall x,
+ (Rabs (B2R x) < bpow radix2 emax)%R.
+Proof.
+intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try ( rewrite Rabs_R0 ; apply bpow_gt_0 ).
+rewrite <- F2R_Zabs, abs_cond_Zopp.
+now apply bounded_lt_emax.
+Qed.
+
+Theorem abs_B2R_ge_emin :
+ forall x,
+ is_finite_strict x = true ->
+ (bpow radix2 emin <= Rabs (B2R x))%R.
+Proof.
+intros [sx|sx|sx plx Hx|sx mx ex Hx] ; simpl ; try discriminate.
+intros; case sx; simpl.
+- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
+ rewrite Rabs_pos_eq; [|apply bpow_ge_0].
+ now apply bounded_ge_emin.
+- unfold F2R; simpl; rewrite Rabs_mult, <-abs_IZR; simpl.
+ rewrite Rabs_pos_eq; [|apply bpow_ge_0].
+ now apply bounded_ge_emin.
+Qed.
+
+Theorem bounded_canonical_lt_emax :
+ forall mx ex,
+ canonical radix2 fexp (Float radix2 (Zpos mx) ex) ->
+ (F2R (Float radix2 (Zpos mx) ex) < bpow radix2 emax)%R ->
+ bounded mx ex = true.
+Proof.
+intros mx ex Cx Bx.
+apply andb_true_intro.
+split.
+unfold canonical_mantissa.
+unfold canonical, Fexp in Cx.
+rewrite Cx at 2.
+rewrite Zpos_digits2_pos.
+unfold cexp.
+rewrite mag_F2R_Zdigits. 2: discriminate.
+now apply -> Zeq_is_eq_bool.
+apply Zle_bool_true.
+unfold canonical, Fexp in Cx.
+rewrite Cx.
+unfold cexp, fexp, FLT_exp.
+destruct (mag radix2 (F2R (Float radix2 (Zpos mx) ex))) as (e',Ex). simpl.
+apply Z.max_lub.
+cut (e' - 1 < emax)%Z. clear ; omega.
+apply lt_bpow with radix2.
+apply Rle_lt_trans with (2 := Bx).
+change (Zpos mx) with (Z.abs (Zpos mx)).
+rewrite F2R_Zabs.
+apply Ex.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+unfold emin.
+generalize (prec_gt_0 prec).
+clear -Hmax ; omega.
+Qed.
+
+(** Truncation *)
+
+Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }.
+
+Definition shr_1 mrs :=
+ let '(Build_shr_record m r s) := mrs in
+ let s := orb r s in
+ match m with
+ | Z0 => Build_shr_record Z0 false s
+ | Zpos xH => Build_shr_record Z0 true s
+ | Zpos (xO p) => Build_shr_record (Zpos p) false s
+ | Zpos (xI p) => Build_shr_record (Zpos p) true s
+ | Zneg xH => Build_shr_record Z0 true s
+ | Zneg (xO p) => Build_shr_record (Zneg p) false s
+ | Zneg (xI p) => Build_shr_record (Zneg p) true s
+ end.
+
+Definition loc_of_shr_record mrs :=
+ match mrs with
+ | Build_shr_record _ false false => loc_Exact
+ | Build_shr_record _ false true => loc_Inexact Lt
+ | Build_shr_record _ true false => loc_Inexact Eq
+ | Build_shr_record _ true true => loc_Inexact Gt
+ end.
+
+Definition shr_record_of_loc m l :=
+ match l with
+ | loc_Exact => Build_shr_record m false false
+ | loc_Inexact Lt => Build_shr_record m false true
+ | loc_Inexact Eq => Build_shr_record m true false
+ | loc_Inexact Gt => Build_shr_record m true true
+ end.
+
+Theorem shr_m_shr_record_of_loc :
+ forall m l,
+ shr_m (shr_record_of_loc m l) = m.
+Proof.
+now intros m [|[| |]].
+Qed.
+
+Theorem loc_of_shr_record_of_loc :
+ forall m l,
+ loc_of_shr_record (shr_record_of_loc m l) = l.
+Proof.
+now intros m [|[| |]].
+Qed.
+
+Definition shr mrs e n :=
+ match n with
+ | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z)
+ | _ => (mrs, e)
+ end.
+
+Lemma inbetween_shr_1 :
+ forall x mrs e,
+ (0 <= shr_m mrs)%Z ->
+ inbetween_float radix2 (shr_m mrs) e x (loc_of_shr_record mrs) ->
+ inbetween_float radix2 (shr_m (shr_1 mrs)) (e + 1) x (loc_of_shr_record (shr_1 mrs)).
+Proof.
+intros x mrs e Hm Hl.
+refine (_ (new_location_even_correct (F2R (Float radix2 (shr_m (shr_1 mrs)) (e + 1))) (bpow radix2 e) 2 _ _ _ x (if shr_r (shr_1 mrs) then 1 else 0) (loc_of_shr_record mrs) _ _)) ; try easy.
+2: apply bpow_gt_0.
+2: now case (shr_r (shr_1 mrs)) ; split.
+change 2%R with (bpow radix2 1).
+rewrite <- bpow_plus.
+rewrite (Zplus_comm 1), <- (F2R_bpow radix2 (e + 1)).
+unfold inbetween_float, F2R. simpl.
+rewrite plus_IZR, Rmult_plus_distr_r.
+replace (new_location_even 2 (if shr_r (shr_1 mrs) then 1%Z else 0%Z) (loc_of_shr_record mrs)) with (loc_of_shr_record (shr_1 mrs)).
+easy.
+clear -Hm.
+destruct mrs as (m, r, s).
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+rewrite (F2R_change_exp radix2 e).
+2: apply Zle_succ.
+unfold F2R. simpl.
+rewrite <- 2!Rmult_plus_distr_r, <- 2!plus_IZR.
+rewrite Zplus_assoc.
+replace (shr_m (shr_1 mrs) * 2 ^ (e + 1 - e) + (if shr_r (shr_1 mrs) then 1%Z else 0%Z))%Z with (shr_m mrs).
+exact Hl.
+ring_simplify (e + 1 - e)%Z.
+change (2^1)%Z with 2%Z.
+rewrite Zmult_comm.
+clear -Hm.
+destruct mrs as (m, r, s).
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+Qed.
+
+Theorem inbetween_shr :
+ forall x m e l n,
+ (0 <= m)%Z ->
+ inbetween_float radix2 m e x l ->
+ let '(mrs, e') := shr (shr_record_of_loc m l) e n in
+ inbetween_float radix2 (shr_m mrs) e' x (loc_of_shr_record mrs).
+Proof.
+intros x m e l n Hm Hl.
+destruct n as [|n|n].
+now destruct l as [|[| |]].
+2: now destruct l as [|[| |]].
+unfold shr.
+rewrite iter_pos_nat.
+rewrite Zpos_eq_Z_of_nat_o_nat_of_P.
+induction (nat_of_P n).
+simpl.
+rewrite Zplus_0_r.
+now destruct l as [|[| |]].
+rewrite iter_nat_S.
+rewrite inj_S.
+unfold Z.succ.
+rewrite Zplus_assoc.
+revert IHn0.
+apply inbetween_shr_1.
+clear -Hm.
+induction n0.
+now destruct l as [|[| |]].
+rewrite iter_nat_S.
+revert IHn0.
+generalize (iter_nat shr_1 n0 (shr_record_of_loc m l)).
+clear.
+intros (m, r, s) Hm.
+now destruct m as [|[m|m|]|m] ; try (now elim Hm) ; destruct r as [|] ; destruct s as [|].
+Qed.
+
+Definition shr_fexp m e l :=
+ shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e).
+
+Theorem shr_truncate :
+ forall m e l,
+ (0 <= m)%Z ->
+ shr_fexp m e l =
+ let '(m', e', l') := truncate radix2 fexp (m, e, l) in (shr_record_of_loc m' l', e').
+Proof.
+intros m e l Hm.
+case_eq (truncate radix2 fexp (m, e, l)).
+intros (m', e') l'.
+unfold shr_fexp.
+rewrite Zdigits2_Zdigits.
+case_eq (fexp (Zdigits radix2 m + e) - e)%Z.
+(* *)
+intros He.
+unfold truncate.
+rewrite He.
+simpl.
+intros H.
+now inversion H.
+(* *)
+intros p Hp.
+assert (He: (e <= fexp (Zdigits radix2 m + e))%Z).
+clear -Hp ; zify ; omega.
+destruct (inbetween_float_ex radix2 m e l) as (x, Hx).
+generalize (inbetween_shr x m e l (fexp (Zdigits radix2 m + e) - e) Hm Hx).
+assert (Hx0 : (0 <= x)%R).
+apply Rle_trans with (F2R (Float radix2 m e)).
+now apply F2R_ge_0.
+exact (proj1 (inbetween_float_bounds _ _ _ _ _ Hx)).
+case_eq (shr (shr_record_of_loc m l) e (fexp (Zdigits radix2 m + e) - e)).
+intros mrs e'' H3 H4 H1.
+generalize (truncate_correct radix2 _ x m e l Hx0 Hx (or_introl _ He)).
+rewrite H1.
+intros (H2,_).
+rewrite <- Hp, H3.
+assert (e'' = e').
+change (snd (mrs, e'') = snd (fst (m',e',l'))).
+rewrite <- H1, <- H3.
+unfold truncate.
+now rewrite Hp.
+rewrite H in H4 |- *.
+apply (f_equal (fun v => (v, _))).
+destruct (inbetween_float_unique _ _ _ _ _ _ _ H2 H4) as (H5, H6).
+rewrite H5, H6.
+case mrs.
+now intros m0 [|] [|].
+(* *)
+intros p Hp.
+unfold truncate.
+rewrite Hp.
+simpl.
+intros H.
+now inversion H.
+Qed.
+
+(** Rounding modes *)
+
+Inductive mode := mode_NE | mode_ZR | mode_DN | mode_UP | mode_NA.
+
+Definition round_mode m :=
+ match m with
+ | mode_NE => ZnearestE
+ | mode_ZR => Ztrunc
+ | mode_DN => Zfloor
+ | mode_UP => Zceil
+ | mode_NA => ZnearestA
+ end.
+
+Definition choice_mode m sx mx lx :=
+ match m with
+ | mode_NE => cond_incr (round_N (negb (Z.even mx)) lx) mx
+ | mode_ZR => mx
+ | mode_DN => cond_incr (round_sign_DN sx lx) mx
+ | mode_UP => cond_incr (round_sign_UP sx lx) mx
+ | mode_NA => cond_incr (round_N true lx) mx
+ end.
+
+Global Instance valid_rnd_round_mode : forall m, Valid_rnd (round_mode m).
+Proof.
+destruct m ; unfold round_mode ; auto with typeclass_instances.
+Qed.
+
+Definition overflow_to_inf m s :=
+ match m with
+ | mode_NE => true
+ | mode_NA => true
+ | mode_ZR => false
+ | mode_UP => negb s
+ | mode_DN => s
+ end.
+
+Definition binary_overflow m s :=
+ if overflow_to_inf m s then F754_infinity s
+ else F754_finite s (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end) (emax - prec).
+
+Definition binary_round_aux mode sx mx ex lx :=
+ let '(mrs', e') := shr_fexp mx ex lx in
+ let '(mrs'', e'') := shr_fexp (choice_mode mode sx (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in
+ match shr_m mrs'' with
+ | Z0 => F754_zero sx
+ | Zpos m => if Zle_bool e'' (emax - prec) then F754_finite sx m e'' else binary_overflow mode sx
+ | _ => F754_nan false xH (* dummy *)
+ end.
+
+Theorem binary_round_aux_correct' :
+ forall mode x mx ex lx,
+ (x <> 0)%R ->
+ inbetween_float radix2 mx ex (Rabs x) lx ->
+ (ex <= cexp radix2 fexp x)%Z ->
+ let z := binary_round_aux mode (Rlt_bool x 0) mx ex lx in
+ valid_binary z = true /\
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
+ FF2R radix2 z = round radix2 fexp (round_mode mode) x /\
+ is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
+ else
+ z = binary_overflow mode (Rlt_bool x 0).
+Proof with auto with typeclass_instances.
+intros m x mx ex lx Px Bx Ex z.
+unfold binary_round_aux in z.
+revert z.
+rewrite shr_truncate.
+refine (_ (round_trunc_sign_any_correct' _ _ (round_mode m) (choice_mode m) _ x mx ex lx Bx (or_introl _ Ex))).
+rewrite <- cexp_abs in Ex.
+refine (_ (truncate_correct_partial' _ fexp _ _ _ _ _ Bx Ex)).
+destruct (truncate radix2 fexp (mx, ex, lx)) as ((m1, e1), l1).
+rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
+set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
+intros (H1a,H1b) H1c.
+rewrite H1c.
+assert (Hm: (m1 <= m1')%Z).
+(* . *)
+unfold m1', choice_mode, cond_incr.
+case m ;
+ try apply Z.le_refl ;
+ match goal with |- (m1 <= if ?b then _ else _)%Z =>
+ case b ; [ apply Zle_succ | apply Z.le_refl ] end.
+assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
+(* . *)
+rewrite <- (Z.abs_eq m1').
+replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
+rewrite F2R_Zabs.
+now apply f_equal.
+apply abs_cond_Zopp.
+apply Z.le_trans with (2 := Hm).
+apply Zlt_succ_le.
+apply gt_0_F2R with radix2 e1.
+apply Rle_lt_trans with (1 := Rabs_pos x).
+exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
+(* . *)
+assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
+now apply inbetween_Exact.
+destruct m1' as [|m1'|m1'].
+(* . m1' = 0 *)
+rewrite shr_truncate. 2: apply Z.le_refl.
+generalize (truncate_0 radix2 fexp e1 loc_Exact).
+destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros Hm2.
+rewrite Hm2.
+repeat split.
+rewrite Rlt_bool_true.
+repeat split.
+apply sym_eq.
+case Rlt_bool ; apply F2R_0.
+rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
+apply bpow_gt_0.
+(* . 0 < m1' *)
+assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
+rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
+2: discriminate.
+rewrite H1b.
+rewrite cexp_abs.
+fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
+apply cexp_round_ge...
+rewrite H1c.
+case (Rlt_bool x 0).
+apply Rlt_not_eq.
+now apply F2R_lt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
+2: now rewrite Hr ; apply F2R_gt_0.
+refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
+2: discriminate.
+rewrite shr_truncate. 2: easy.
+destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros (H3,H4) (H2,_).
+destruct m2 as [|m2|m2].
+elim Rgt_not_eq with (2 := H3).
+rewrite F2R_0.
+now apply F2R_gt_0.
+rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
+simpl Z.abs.
+case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
+assert (bounded m2 e2 = true).
+apply andb_true_intro.
+split.
+unfold canonical_mantissa.
+apply Zeq_bool_true.
+rewrite Zpos_digits2_pos.
+rewrite <- mag_F2R_Zdigits.
+apply sym_eq.
+now rewrite H3 in H4.
+discriminate.
+exact He2.
+apply (conj H).
+rewrite Rlt_bool_true.
+repeat split.
+apply F2R_cond_Zopp.
+now apply bounded_lt_emax.
+rewrite (Rlt_bool_false _ (bpow radix2 emax)).
+refine (conj _ (refl_equal _)).
+unfold binary_overflow.
+case overflow_to_inf.
+apply refl_equal.
+unfold valid_binary, bounded.
+rewrite Zle_bool_refl.
+rewrite Bool.andb_true_r.
+apply Zeq_bool_true.
+rewrite Zpos_digits2_pos.
+replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
+unfold fexp, FLT_exp, emin.
+generalize (prec_gt_0 prec).
+clear -Hmax ; zify ; omega.
+change 2%Z with (radix_val radix2).
+case_eq (Zpower radix2 prec - 1)%Z.
+simpl Zdigits.
+generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
+clear ; omega.
+intros p Hp.
+apply Zle_antisym.
+cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega.
+apply Zdigits_gt_Zpower.
+simpl Z.abs. rewrite <- Hp.
+cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
+apply lt_IZR.
+rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
+apply bpow_lt.
+apply Zlt_pred.
+now apply Zlt_0_le_0_pred.
+apply Zdigits_le_Zpower.
+simpl Z.abs. rewrite <- Hp.
+apply Zlt_pred.
+intros p Hp.
+generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
+clear -Hp ; zify ; omega.
+apply Rnot_lt_le.
+intros Hx.
+generalize (refl_equal (bounded m2 e2)).
+unfold bounded at 2.
+rewrite He2.
+rewrite Bool.andb_false_r.
+rewrite bounded_canonical_lt_emax with (2 := Hx).
+discriminate.
+unfold canonical.
+now rewrite <- H3.
+elim Rgt_not_eq with (2 := H3).
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+rewrite <- Hr.
+apply generic_format_abs...
+apply generic_format_round...
+(* . not m1' < 0 *)
+elim Rgt_not_eq with (2 := Hr).
+apply Rlt_le_trans with R0.
+now apply F2R_lt_0.
+apply Rabs_pos.
+(* *)
+now apply Rabs_pos_lt.
+(* all the modes are valid *)
+clear. case m.
+exact inbetween_int_NE_sign.
+exact inbetween_int_ZR_sign.
+exact inbetween_int_DN_sign.
+exact inbetween_int_UP_sign.
+exact inbetween_int_NA_sign.
+(* *)
+apply inbetween_float_bounds in Bx.
+apply Zlt_succ_le.
+eapply gt_0_F2R.
+apply Rle_lt_trans with (2 := proj2 Bx).
+apply Rabs_pos.
+Qed.
+
+Theorem binary_round_aux_correct :
+ forall mode x mx ex lx,
+ inbetween_float radix2 (Zpos mx) ex (Rabs x) lx ->
+ (ex <= fexp (Zdigits radix2 (Zpos mx) + ex))%Z ->
+ let z := binary_round_aux mode (Rlt_bool x 0) (Zpos mx) ex lx in
+ valid_binary z = true /\
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode mode) x)) (bpow radix2 emax) then
+ FF2R radix2 z = round radix2 fexp (round_mode mode) x /\
+ is_finite_FF z = true /\ sign_FF z = Rlt_bool x 0
+ else
+ z = binary_overflow mode (Rlt_bool x 0).
+Proof with auto with typeclass_instances.
+intros m x mx ex lx Bx Ex z.
+unfold binary_round_aux in z.
+revert z.
+rewrite shr_truncate. 2: easy.
+refine (_ (round_trunc_sign_any_correct _ _ (round_mode m) (choice_mode m) _ x (Zpos mx) ex lx Bx (or_introl _ Ex))).
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Bx Ex)).
+destruct (truncate radix2 fexp (Zpos mx, ex, lx)) as ((m1, e1), l1).
+rewrite loc_of_shr_record_of_loc, shr_m_shr_record_of_loc.
+set (m1' := choice_mode m (Rlt_bool x 0) m1 l1).
+intros (H1a,H1b) H1c.
+rewrite H1c.
+assert (Hm: (m1 <= m1')%Z).
+(* . *)
+unfold m1', choice_mode, cond_incr.
+case m ;
+ try apply Z.le_refl ;
+ match goal with |- (m1 <= if ?b then _ else _)%Z =>
+ case b ; [ apply Zle_succ | apply Z.le_refl ] end.
+assert (Hr: Rabs (round radix2 fexp (round_mode m) x) = F2R (Float radix2 m1' e1)).
+(* . *)
+rewrite <- (Z.abs_eq m1').
+replace (Z.abs m1') with (Z.abs (cond_Zopp (Rlt_bool x 0) m1')).
+rewrite F2R_Zabs.
+now apply f_equal.
+apply abs_cond_Zopp.
+apply Z.le_trans with (2 := Hm).
+apply Zlt_succ_le.
+apply gt_0_F2R with radix2 e1.
+apply Rle_lt_trans with (1 := Rabs_pos x).
+exact (proj2 (inbetween_float_bounds _ _ _ _ _ H1a)).
+(* . *)
+assert (Br: inbetween_float radix2 m1' e1 (Rabs (round radix2 fexp (round_mode m) x)) loc_Exact).
+now apply inbetween_Exact.
+destruct m1' as [|m1'|m1'].
+(* . m1' = 0 *)
+rewrite shr_truncate. 2: apply Z.le_refl.
+generalize (truncate_0 radix2 fexp e1 loc_Exact).
+destruct (truncate radix2 fexp (Z0, e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros Hm2.
+rewrite Hm2.
+repeat split.
+rewrite Rlt_bool_true.
+repeat split.
+apply sym_eq.
+case Rlt_bool ; apply F2R_0.
+rewrite <- F2R_Zabs, abs_cond_Zopp, F2R_0.
+apply bpow_gt_0.
+(* . 0 < m1' *)
+assert (He: (e1 <= fexp (Zdigits radix2 (Zpos m1') + e1))%Z).
+rewrite <- mag_F2R_Zdigits, <- Hr, mag_abs.
+2: discriminate.
+rewrite H1b.
+rewrite cexp_abs.
+fold (cexp radix2 fexp (round radix2 fexp (round_mode m) x)).
+apply cexp_round_ge...
+rewrite H1c.
+case (Rlt_bool x 0).
+apply Rlt_not_eq.
+now apply F2R_lt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+refine (_ (truncate_correct_partial _ _ _ _ _ _ _ Br He)).
+2: now rewrite Hr ; apply F2R_gt_0.
+refine (_ (truncate_correct_format radix2 fexp (Zpos m1') e1 _ _ He)).
+2: discriminate.
+rewrite shr_truncate. 2: easy.
+destruct (truncate radix2 fexp (Zpos m1', e1, loc_Exact)) as ((m2, e2), l2).
+rewrite shr_m_shr_record_of_loc.
+intros (H3,H4) (H2,_).
+destruct m2 as [|m2|m2].
+elim Rgt_not_eq with (2 := H3).
+rewrite F2R_0.
+now apply F2R_gt_0.
+rewrite F2R_cond_Zopp, H3, abs_cond_Ropp, <- F2R_abs.
+simpl Z.abs.
+case_eq (Zle_bool e2 (emax - prec)) ; intros He2.
+assert (bounded m2 e2 = true).
+apply andb_true_intro.
+split.
+unfold canonical_mantissa.
+apply Zeq_bool_true.
+rewrite Zpos_digits2_pos.
+rewrite <- mag_F2R_Zdigits.
+apply sym_eq.
+now rewrite H3 in H4.
+discriminate.
+exact He2.
+apply (conj H).
+rewrite Rlt_bool_true.
+repeat split.
+apply F2R_cond_Zopp.
+now apply bounded_lt_emax.
+rewrite (Rlt_bool_false _ (bpow radix2 emax)).
+refine (conj _ (refl_equal _)).
+unfold binary_overflow.
+case overflow_to_inf.
+apply refl_equal.
+unfold valid_binary, bounded.
+rewrite Zle_bool_refl.
+rewrite Bool.andb_true_r.
+apply Zeq_bool_true.
+rewrite Zpos_digits2_pos.
+replace (Zdigits radix2 (Zpos (match (Zpower 2 prec - 1)%Z with Zpos p => p | _ => xH end))) with prec.
+unfold fexp, FLT_exp, emin.
+generalize (prec_gt_0 prec).
+clear -Hmax ; zify ; omega.
+change 2%Z with (radix_val radix2).
+case_eq (Zpower radix2 prec - 1)%Z.
+simpl Zdigits.
+generalize (Zpower_gt_1 radix2 prec (prec_gt_0 prec)).
+clear ; omega.
+intros p Hp.
+apply Zle_antisym.
+cut (prec - 1 < Zdigits radix2 (Zpos p))%Z. clear ; omega.
+apply Zdigits_gt_Zpower.
+simpl Z.abs. rewrite <- Hp.
+cut (Zpower radix2 (prec - 1) < Zpower radix2 prec)%Z. clear ; omega.
+apply lt_IZR.
+rewrite 2!IZR_Zpower. 2: now apply Zlt_le_weak.
+apply bpow_lt.
+apply Zlt_pred.
+now apply Zlt_0_le_0_pred.
+apply Zdigits_le_Zpower.
+simpl Z.abs. rewrite <- Hp.
+apply Zlt_pred.
+intros p Hp.
+generalize (Zpower_gt_1 radix2 _ (prec_gt_0 prec)).
+clear -Hp ; zify ; omega.
+apply Rnot_lt_le.
+intros Hx.
+generalize (refl_equal (bounded m2 e2)).
+unfold bounded at 2.
+rewrite He2.
+rewrite Bool.andb_false_r.
+rewrite bounded_canonical_lt_emax with (2 := Hx).
+discriminate.
+unfold canonical.
+now rewrite <- H3.
+elim Rgt_not_eq with (2 := H3).
+apply Rlt_trans with R0.
+now apply F2R_lt_0.
+now apply F2R_gt_0.
+rewrite <- Hr.
+apply generic_format_abs...
+apply generic_format_round...
+(* . not m1' < 0 *)
+elim Rgt_not_eq with (2 := Hr).
+apply Rlt_le_trans with R0.
+now apply F2R_lt_0.
+apply Rabs_pos.
+(* *)
+apply Rlt_le_trans with (2 := proj1 (inbetween_float_bounds _ _ _ _ _ Bx)).
+now apply F2R_gt_0.
+(* all the modes are valid *)
+clear. case m.
+exact inbetween_int_NE_sign.
+exact inbetween_int_ZR_sign.
+exact inbetween_int_DN_sign.
+exact inbetween_int_UP_sign.
+exact inbetween_int_NA_sign.
+Qed.
+
+(** Multiplication *)
+
+Lemma Bmult_correct_aux :
+ forall m sx mx ex (Hx : bounded mx ex = true) sy my ey (Hy : bounded my ey = true),
+ let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+ let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
+ let z := binary_round_aux m (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact in
+ valid_binary z = true /\
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x * y))) (bpow radix2 emax) then
+ FF2R radix2 z = round radix2 fexp (round_mode m) (x * y) /\
+ is_finite_FF z = true /\ sign_FF z = xorb sx sy
+ else
+ z = binary_overflow m (xorb sx sy).
+Proof.
+intros m sx mx ex Hx sy my ey Hy x y.
+unfold x, y.
+rewrite <- F2R_mult.
+simpl.
+replace (xorb sx sy) with (Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx) * cond_Zopp sy (Zpos my)) (ex + ey))) 0).
+apply binary_round_aux_correct.
+constructor.
+rewrite <- F2R_abs.
+apply F2R_eq.
+rewrite Zabs_Zmult.
+now rewrite 2!abs_cond_Zopp.
+(* *)
+change (Zpos (mx * my)) with (Zpos mx * Zpos my)%Z.
+assert (forall m e, bounded m e = true -> fexp (Zdigits radix2 (Zpos m) + e) = e)%Z.
+clear. intros m e Hb.
+destruct (andb_prop _ _ Hb) as (H,_).
+apply Zeq_bool_eq.
+now rewrite <- Zpos_digits2_pos.
+generalize (H _ _ Hx) (H _ _ Hy).
+clear x y sx sy Hx Hy H.
+unfold fexp, FLT_exp.
+refine (_ (Zdigits_mult_ge radix2 (Zpos mx) (Zpos my) _ _)) ; try discriminate.
+refine (_ (Zdigits_gt_0 radix2 (Zpos mx) _) (Zdigits_gt_0 radix2 (Zpos my) _)) ; try discriminate.
+generalize (Zdigits radix2 (Zpos mx)) (Zdigits radix2 (Zpos my)) (Zdigits radix2 (Zpos mx * Zpos my)).
+clear -Hmax.
+unfold emin.
+intros dx dy dxy Hx Hy Hxy.
+zify ; intros ; subst.
+omega.
+(* *)
+case sx ; case sy.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+Qed.
+
+Definition Bmult mult_nan m x y :=
+ match x, y with
+ | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (mult_nan x y)
+ | B754_infinity sx, B754_infinity sy => B754_infinity (xorb sx sy)
+ | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
+ | B754_finite sx _ _ _, B754_infinity sy => B754_infinity (xorb sx sy)
+ | B754_infinity _, B754_zero _ => build_nan (mult_nan x y)
+ | B754_zero _, B754_infinity _ => build_nan (mult_nan x y)
+ | B754_finite sx _ _ _, B754_zero sy => B754_zero (xorb sx sy)
+ | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
+ | B754_zero sx, B754_zero sy => B754_zero (xorb sx sy)
+ | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+ FF2B _ (proj1 (Bmult_correct_aux m sx mx ex Hx sy my ey Hy))
+ end.
+
+Theorem Bmult_correct :
+ forall mult_nan m x y,
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x * B2R y))) (bpow radix2 emax) then
+ B2R (Bmult mult_nan m x y) = round radix2 fexp (round_mode m) (B2R x * B2R y) /\
+ is_finite (Bmult mult_nan m x y) = andb (is_finite x) (is_finite y) /\
+ (is_nan (Bmult mult_nan m x y) = false ->
+ Bsign (Bmult mult_nan m x y) = xorb (Bsign x) (Bsign y))
+ else
+ B2FF (Bmult mult_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
+Proof.
+intros mult_nan m [sx|sx|sx plx Hplx|sx mx ex Hx] [sy|sy|sy ply Hply|sy my ey Hy] ;
+ try ( rewrite ?Rmult_0_r, ?Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | now auto with typeclass_instances ] ).
+simpl.
+case Bmult_correct_aux.
+intros H1.
+case Rlt_bool.
+intros (H2, (H3, H4)).
+split.
+now rewrite B2R_FF2B.
+split.
+now rewrite is_finite_FF2B.
+rewrite Bsign_FF2B. auto.
+intros H2.
+now rewrite B2FF_FF2B.
+Qed.
+
+(** Normalization and rounding *)
+
+Definition shl_align mx ex ex' :=
+ match (ex' - ex)%Z with
+ | Zneg d => (shift_pos d mx, ex')
+ | _ => (mx, ex)
+ end.
+
+Theorem shl_align_correct :
+ forall mx ex ex',
+ let (mx', ex'') := shl_align mx ex ex' in
+ F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex'') /\
+ (ex'' <= ex')%Z.
+Proof.
+intros mx ex ex'.
+unfold shl_align.
+case_eq (ex' - ex)%Z.
+(* d = 0 *)
+intros H.
+repeat split.
+rewrite Zminus_eq with (1 := H).
+apply Z.le_refl.
+(* d > 0 *)
+intros d Hd.
+repeat split.
+replace ex' with (ex' - ex + ex)%Z by ring.
+rewrite Hd.
+pattern ex at 1 ; rewrite <- Zplus_0_l.
+now apply Zplus_le_compat_r.
+(* d < 0 *)
+intros d Hd.
+rewrite shift_pos_correct, Zmult_comm.
+change (Zpower_pos 2 d) with (Zpower radix2 (Zpos d)).
+change (Zpos d) with (Z.opp (Zneg d)).
+rewrite <- Hd.
+split.
+replace (- (ex' - ex))%Z with (ex - ex')%Z by ring.
+apply F2R_change_exp.
+apply Zle_0_minus_le.
+replace (ex - ex')%Z with (- (ex' - ex))%Z by ring.
+now rewrite Hd.
+apply Z.le_refl.
+Qed.
+
+Theorem snd_shl_align :
+ forall mx ex ex',
+ (ex' <= ex)%Z ->
+ snd (shl_align mx ex ex') = ex'.
+Proof.
+intros mx ex ex' He.
+unfold shl_align.
+case_eq (ex' - ex)%Z ; simpl.
+intros H.
+now rewrite Zminus_eq with (1 := H).
+intros p.
+clear -He ; zify ; omega.
+intros.
+apply refl_equal.
+Qed.
+
+Definition shl_align_fexp mx ex :=
+ shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex)).
+
+Theorem shl_align_fexp_correct :
+ forall mx ex,
+ let (mx', ex') := shl_align_fexp mx ex in
+ F2R (Float radix2 (Zpos mx) ex) = F2R (Float radix2 (Zpos mx') ex') /\
+ (ex' <= fexp (Zdigits radix2 (Zpos mx') + ex'))%Z.
+Proof.
+intros mx ex.
+unfold shl_align_fexp.
+generalize (shl_align_correct mx ex (fexp (Zpos (digits2_pos mx) + ex))).
+rewrite Zpos_digits2_pos.
+case shl_align.
+intros mx' ex' (H1, H2).
+split.
+exact H1.
+rewrite <- mag_F2R_Zdigits. 2: easy.
+rewrite <- H1.
+now rewrite mag_F2R_Zdigits.
+Qed.
+
+Definition binary_round m sx mx ex :=
+ let '(mz, ez) := shl_align_fexp mx ex in binary_round_aux m sx (Zpos mz) ez loc_Exact.
+
+Theorem binary_round_correct :
+ forall m sx mx ex,
+ let z := binary_round m sx mx ex in
+ valid_binary z = true /\
+ let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) x)) (bpow radix2 emax) then
+ FF2R radix2 z = round radix2 fexp (round_mode m) x /\
+ is_finite_FF z = true /\
+ sign_FF z = sx
+ else
+ z = binary_overflow m sx.
+Proof.
+intros m sx mx ex.
+unfold binary_round.
+generalize (shl_align_fexp_correct mx ex).
+destruct (shl_align_fexp mx ex) as (mz, ez).
+intros (H1, H2).
+set (x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex)).
+replace sx with (Rlt_bool x 0).
+apply binary_round_aux_correct.
+constructor.
+unfold x.
+now rewrite <- F2R_Zabs, abs_cond_Zopp.
+exact H2.
+unfold x.
+case sx.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+Qed.
+
+Definition binary_normalize mode m e szero :=
+ match m with
+ | Z0 => B754_zero szero
+ | Zpos m => FF2B _ (proj1 (binary_round_correct mode false m e))
+ | Zneg m => FF2B _ (proj1 (binary_round_correct mode true m e))
+ end.
+
+Theorem binary_normalize_correct :
+ forall m mx ex szero,
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)))) (bpow radix2 emax) then
+ B2R (binary_normalize m mx ex szero) = round radix2 fexp (round_mode m) (F2R (Float radix2 mx ex)) /\
+ is_finite (binary_normalize m mx ex szero) = true /\
+ Bsign (binary_normalize m mx ex szero) =
+ match Rcompare (F2R (Float radix2 mx ex)) 0 with
+ | Eq => szero
+ | Lt => true
+ | Gt => false
+ end
+ else
+ B2FF (binary_normalize m mx ex szero) = binary_overflow m (Rlt_bool (F2R (Float radix2 mx ex)) 0).
+Proof with auto with typeclass_instances.
+intros m mx ez szero.
+destruct mx as [|mz|mz] ; simpl.
+rewrite F2R_0, round_0, Rabs_R0, Rlt_bool_true...
+split... split...
+rewrite Rcompare_Eq...
+apply bpow_gt_0.
+(* . mz > 0 *)
+generalize (binary_round_correct m false mz ez).
+simpl.
+case Rlt_bool_spec.
+intros _ (Vz, (Rz, (Rz', Rz''))).
+split.
+now rewrite B2R_FF2B.
+split.
+now rewrite is_finite_FF2B.
+rewrite Bsign_FF2B, Rz''.
+rewrite Rcompare_Gt...
+apply F2R_gt_0.
+simpl. zify; omega.
+intros Hz' (Vz, Rz).
+rewrite B2FF_FF2B, Rz.
+apply f_equal.
+apply sym_eq.
+apply Rlt_bool_false.
+now apply F2R_ge_0.
+(* . mz < 0 *)
+generalize (binary_round_correct m true mz ez).
+simpl.
+case Rlt_bool_spec.
+intros _ (Vz, (Rz, (Rz', Rz''))).
+split.
+now rewrite B2R_FF2B.
+split.
+now rewrite is_finite_FF2B.
+rewrite Bsign_FF2B, Rz''.
+rewrite Rcompare_Lt...
+apply F2R_lt_0.
+simpl. zify; omega.
+intros Hz' (Vz, Rz).
+rewrite B2FF_FF2B, Rz.
+apply f_equal.
+apply sym_eq.
+apply Rlt_bool_true.
+now apply F2R_lt_0.
+Qed.
+
+(** Addition *)
+
+Definition Bplus plus_nan m x y :=
+ match x, y with
+ | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (plus_nan x y)
+ | B754_infinity sx, B754_infinity sy =>
+ if Bool.eqb sx sy then x else build_nan (plus_nan x y)
+ | B754_infinity _, _ => x
+ | _, B754_infinity _ => y
+ | B754_zero sx, B754_zero sy =>
+ if Bool.eqb sx sy then x else
+ match m with mode_DN => B754_zero true | _ => B754_zero false end
+ | B754_zero _, _ => y
+ | _, B754_zero _ => x
+ | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+ let ez := Z.min ex ey in
+ binary_normalize m (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
+ ez (match m with mode_DN => true | _ => false end)
+ end.
+
+Theorem Bplus_correct :
+ forall plus_nan m x y,
+ is_finite x = true ->
+ is_finite y = true ->
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x + B2R y))) (bpow radix2 emax) then
+ B2R (Bplus plus_nan m x y) = round radix2 fexp (round_mode m) (B2R x + B2R y) /\
+ is_finite (Bplus plus_nan m x y) = true /\
+ Bsign (Bplus plus_nan m x y) =
+ match Rcompare (B2R x + B2R y) 0 with
+ | Eq => match m with mode_DN => orb (Bsign x) (Bsign y)
+ | _ => andb (Bsign x) (Bsign y) end
+ | Lt => true
+ | Gt => false
+ end
+ else
+ (B2FF (Bplus plus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = Bsign y).
+Proof with auto with typeclass_instances.
+intros plus_nan m [sx|sx| |sx mx ex Hx] [sy|sy| |sy my ey Hy] Fx Fy ; try easy.
+(* *)
+rewrite Rplus_0_r, round_0, Rabs_R0, Rlt_bool_true...
+simpl.
+rewrite Rcompare_Eq by auto.
+destruct sx, sy; try easy; now case m.
+apply bpow_gt_0.
+(* *)
+rewrite Rplus_0_l, round_generic, Rlt_bool_true...
+split... split...
+simpl. unfold F2R.
+erewrite <- Rmult_0_l, Rcompare_mult_r.
+rewrite Rcompare_IZR with (y:=0%Z).
+destruct sy...
+apply bpow_gt_0.
+apply abs_B2R_lt_emax.
+apply generic_format_B2R.
+(* *)
+rewrite Rplus_0_r, round_generic, Rlt_bool_true...
+split... split...
+simpl. unfold F2R.
+erewrite <- Rmult_0_l, Rcompare_mult_r.
+rewrite Rcompare_IZR with (y:=0%Z).
+destruct sx...
+apply bpow_gt_0.
+apply abs_B2R_lt_emax.
+apply generic_format_B2R.
+(* *)
+clear Fx Fy.
+simpl.
+set (szero := match m with mode_DN => true | _ => false end).
+set (ez := Z.min ex ey).
+set (mz := (cond_Zopp sx (Zpos (fst (shl_align mx ex ez))) + cond_Zopp sy (Zpos (fst (shl_align my ey ez))))%Z).
+assert (Hp: (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) +
+ F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey))%R = F2R (Float radix2 mz ez)).
+rewrite 2!F2R_cond_Zopp.
+generalize (shl_align_correct mx ex ez).
+generalize (shl_align_correct my ey ez).
+generalize (snd_shl_align mx ex ez (Z.le_min_l ex ey)).
+generalize (snd_shl_align my ey ez (Z.le_min_r ex ey)).
+destruct (shl_align mx ex ez) as (mx', ex').
+destruct (shl_align my ey ez) as (my', ey').
+simpl.
+intros H1 H2.
+rewrite H1, H2.
+clear H1 H2.
+intros (H1, _) (H2, _).
+rewrite H1, H2.
+clear H1 H2.
+rewrite <- 2!F2R_cond_Zopp.
+unfold F2R. simpl.
+now rewrite <- Rmult_plus_distr_r, <- plus_IZR.
+rewrite Hp.
+assert (Sz: (bpow radix2 emax <= Rabs (round radix2 fexp (round_mode m) (F2R (Float radix2 mz ez))))%R -> sx = Rlt_bool (F2R (Float radix2 mz ez)) 0 /\ sx = sy).
+(* . *)
+rewrite <- Hp.
+intros Bz.
+destruct (Bool.bool_dec sx sy) as [Hs|Hs].
+(* .. *)
+refine (conj _ Hs).
+rewrite Hs.
+apply sym_eq.
+case sy.
+apply Rlt_bool_true.
+rewrite <- (Rplus_0_r 0).
+apply Rplus_lt_compat.
+now apply F2R_lt_0.
+now apply F2R_lt_0.
+apply Rlt_bool_false.
+rewrite <- (Rplus_0_r 0).
+apply Rplus_le_compat.
+now apply F2R_ge_0.
+now apply F2R_ge_0.
+(* .. *)
+elim Rle_not_lt with (1 := Bz).
+generalize (bounded_lt_emax _ _ Hx) (bounded_lt_emax _ _ Hy) (andb_prop _ _ Hx) (andb_prop _ _ Hy).
+intros Bx By (Hx',_) (Hy',_).
+generalize (canonical_canonical_mantissa sx _ _ Hx') (canonical_canonical_mantissa sy _ _ Hy').
+clear -Bx By Hs prec_gt_0_.
+intros Cx Cy.
+destruct sx.
+(* ... *)
+destruct sy.
+now elim Hs.
+clear Hs.
+apply Rabs_lt.
+split.
+apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)).
+rewrite F2R_Zopp.
+now apply Ropp_lt_contravar.
+apply round_ge_generic...
+now apply generic_format_canonical.
+pattern (F2R (Float radix2 (cond_Zopp true (Zpos mx)) ex)) at 1 ; rewrite <- Rplus_0_r.
+apply Rplus_le_compat_l.
+now apply F2R_ge_0.
+apply Rle_lt_trans with (2 := By).
+apply round_le_generic...
+now apply generic_format_canonical.
+rewrite <- (Rplus_0_l (F2R (Float radix2 (Zpos my) ey))).
+apply Rplus_le_compat_r.
+now apply F2R_le_0.
+(* ... *)
+destruct sy.
+2: now elim Hs.
+clear Hs.
+apply Rabs_lt.
+split.
+apply Rlt_le_trans with (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)).
+rewrite F2R_Zopp.
+now apply Ropp_lt_contravar.
+apply round_ge_generic...
+now apply generic_format_canonical.
+pattern (F2R (Float radix2 (cond_Zopp true (Zpos my)) ey)) at 1 ; rewrite <- Rplus_0_l.
+apply Rplus_le_compat_r.
+now apply F2R_ge_0.
+apply Rle_lt_trans with (2 := Bx).
+apply round_le_generic...
+now apply generic_format_canonical.
+rewrite <- (Rplus_0_r (F2R (Float radix2 (Zpos mx) ex))).
+apply Rplus_le_compat_l.
+now apply F2R_le_0.
+(* . *)
+generalize (binary_normalize_correct m mz ez szero).
+case Rlt_bool_spec.
+split; try easy. split; try easy.
+destruct (Rcompare_spec (F2R (beta:=radix2) {| Fnum := mz; Fexp := ez |}) 0); try easy.
+rewrite H1 in Hp.
+apply Rplus_opp_r_uniq in Hp.
+rewrite <- F2R_Zopp in Hp.
+eapply canonical_unique in Hp.
+inversion Hp. destruct sy, sx, m; try discriminate H3; easy.
+apply canonical_canonical_mantissa.
+apply Bool.andb_true_iff in Hy. easy.
+replace (-cond_Zopp sx (Z.pos mx))%Z with (cond_Zopp (negb sx) (Z.pos mx))
+ by (destruct sx; auto).
+apply canonical_canonical_mantissa.
+apply Bool.andb_true_iff in Hx. easy.
+intros Hz' Vz.
+specialize (Sz Hz').
+split.
+rewrite Vz.
+now apply f_equal.
+apply Sz.
+Qed.
+
+(** Subtraction *)
+
+Definition Bminus minus_nan m x y :=
+ match x, y with
+ | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (minus_nan x y)
+ | B754_infinity sx, B754_infinity sy =>
+ if Bool.eqb sx (negb sy) then x else build_nan (minus_nan x y)
+ | B754_infinity _, _ => x
+ | _, B754_infinity sy => B754_infinity (negb sy)
+ | B754_zero sx, B754_zero sy =>
+ if Bool.eqb sx (negb sy) then x else
+ match m with mode_DN => B754_zero true | _ => B754_zero false end
+ | B754_zero _, B754_finite sy my ey Hy => B754_finite (negb sy) my ey Hy
+ | _, B754_zero _ => x
+ | B754_finite sx mx ex Hx, B754_finite sy my ey Hy =>
+ let ez := Z.min ex ey in
+ binary_normalize m (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez)))))
+ ez (match m with mode_DN => true | _ => false end)
+ end.
+
+Theorem Bminus_correct :
+ forall minus_nan m x y,
+ is_finite x = true ->
+ is_finite y = true ->
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x - B2R y))) (bpow radix2 emax) then
+ B2R (Bminus minus_nan m x y) = round radix2 fexp (round_mode m) (B2R x - B2R y) /\
+ is_finite (Bminus minus_nan m x y) = true /\
+ Bsign (Bminus minus_nan m x y) =
+ match Rcompare (B2R x - B2R y) 0 with
+ | Eq => match m with mode_DN => orb (Bsign x) (negb (Bsign y))
+ | _ => andb (Bsign x) (negb (Bsign y)) end
+ | Lt => true
+ | Gt => false
+ end
+ else
+ (B2FF (Bminus minus_nan m x y) = binary_overflow m (Bsign x) /\ Bsign x = negb (Bsign y)).
+Proof with auto with typeclass_instances.
+intros minus_nan m x y Fx Fy.
+generalize (Bplus_correct minus_nan m x (Bopp (fun n => minus_nan n (B754_zero false)) y) Fx).
+rewrite is_finite_Bopp, B2R_Bopp.
+intros H.
+specialize (H Fy).
+replace (negb (Bsign y)) with (Bsign (Bopp (fun n => minus_nan n (B754_zero false)) y)).
+destruct x as [| | |sx mx ex Hx], y as [| | |sy my ey Hy] ; try easy.
+unfold Bminus, Zminus.
+now rewrite <- cond_Zopp_negb.
+now destruct y as [ | | | ].
+Qed.
+
+(** Fused Multiply-Add *)
+
+Definition Bfma_szero m (x y z: binary_float) : bool :=
+ let s_xy := xorb (Bsign x) (Bsign y) in (* sign of product x*y *)
+ if Bool.eqb s_xy (Bsign z) then s_xy
+ else match m with mode_DN => true | _ => false end.
+
+Definition Bfma fma_nan m (x y z: binary_float) :=
+ match x, y with
+ | B754_nan _ _ _, _ | _, B754_nan _ _ _
+ | B754_infinity _, B754_zero _
+ | B754_zero _, B754_infinity _ =>
+ (* Multiplication produces NaN *)
+ build_nan (fma_nan x y z)
+ | B754_infinity sx, B754_infinity sy
+ | B754_infinity sx, B754_finite sy _ _ _
+ | B754_finite sx _ _ _, B754_infinity sy =>
+ let s := xorb sx sy in
+ (* Multiplication produces infinity with sign [s] *)
+ match z with
+ | B754_nan _ _ _ => build_nan (fma_nan x y z)
+ | B754_infinity sz =>
+ if Bool.eqb s sz then z else build_nan (fma_nan x y z)
+ | _ => B754_infinity s
+ end
+ | B754_finite sx _ _ _, B754_zero sy
+ | B754_zero sx, B754_finite sy _ _ _
+ | B754_zero sx, B754_zero sy =>
+ (* Multiplication produces zero *)
+ match z with
+ | B754_nan _ _ _ => build_nan (fma_nan x y z)
+ | B754_zero _ => B754_zero (Bfma_szero m x y z)
+ | _ => z
+ end
+ | B754_finite sx mx ex _, B754_finite sy my ey _ =>
+ (* Multiplication produces a finite, non-zero result *)
+ match z with
+ | B754_nan _ _ _ => build_nan (fma_nan x y z)
+ | B754_infinity sz => z
+ | B754_zero _ =>
+ let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
+ let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
+ let '(Float _ mr er) := Fmult X Y in
+ binary_normalize m mr er (Bfma_szero m x y z)
+ | B754_finite sz mz ez _ =>
+ let X := Float radix2 (cond_Zopp sx (Zpos mx)) ex in
+ let Y := Float radix2 (cond_Zopp sy (Zpos my)) ey in
+ let Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez in
+ let '(Float _ mr er) := Fplus (Fmult X Y) Z in
+ binary_normalize m mr er (Bfma_szero m x y z)
+ end
+ end.
+
+Theorem Bfma_correct:
+ forall fma_nan m x y z,
+ let res := (B2R x * B2R y + B2R z)%R in
+ is_finite x = true ->
+ is_finite y = true ->
+ is_finite z = true ->
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) res)) (bpow radix2 emax) then
+ B2R (Bfma fma_nan m x y z) = round radix2 fexp (round_mode m) res /\
+ is_finite (Bfma fma_nan m x y z) = true /\
+ Bsign (Bfma fma_nan m x y z) =
+ match Rcompare res 0 with
+ | Eq => Bfma_szero m x y z
+ | Lt => true
+ | Gt => false
+ end
+ else
+ B2FF (Bfma fma_nan m x y z) = binary_overflow m (Rlt_bool res 0).
+Proof.
+ intros. pattern (Bfma fma_nan m x y z).
+ match goal with |- ?p ?x => set (PROP := p) end.
+ set (szero := Bfma_szero m x y z).
+ assert (BINORM: forall mr er, F2R (Float radix2 mr er) = res ->
+ PROP (binary_normalize m mr er szero)).
+ { intros mr er E.
+ specialize (binary_normalize_correct m mr er szero).
+ change (FLT_exp (3 - emax - prec) prec) with fexp. rewrite E. tauto.
+ }
+ set (add_zero :=
+ match z with
+ | B754_nan _ _ _ => build_nan (fma_nan x y z)
+ | B754_zero sz => B754_zero szero
+ | _ => z
+ end).
+ assert (ADDZERO: B2R x = 0%R \/ B2R y = 0%R -> PROP add_zero).
+ {
+ intros Z.
+ assert (RES: res = B2R z).
+ { unfold res. destruct Z as [E|E]; rewrite E, ?Rmult_0_l, ?Rmult_0_r, Rplus_0_l; auto. }
+ unfold PROP, add_zero; destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate.
+ - simpl in RES; rewrite RES; rewrite round_0 by apply valid_rnd_round_mode.
+ rewrite Rlt_bool_true. split. reflexivity. split. reflexivity.
+ rewrite Rcompare_Eq by auto. reflexivity.
+ rewrite Rabs_R0; apply bpow_gt_0.
+ - rewrite RES, round_generic, Rlt_bool_true.
+ split. reflexivity. split. reflexivity.
+ unfold B2R. destruct sz.
+ rewrite Rcompare_Lt. auto. apply F2R_lt_0. reflexivity.
+ rewrite Rcompare_Gt. auto. apply F2R_gt_0. reflexivity.
+ apply abs_B2R_lt_emax. apply valid_rnd_round_mode. apply generic_format_B2R.
+ }
+ destruct x as [ sx | sx | sx plx | sx mx ex Bx];
+ destruct y as [ sy | sy | sy ply | sy my ey By];
+ try discriminate.
+- apply ADDZERO; auto.
+- apply ADDZERO; auto.
+- apply ADDZERO; auto.
+- destruct z as [ sz | sz | sz plz | sz mz ez Bz]; try discriminate; unfold Bfma.
++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+ set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
+ destruct (Fmult X Y) as [mr er] eqn:FRES.
+ apply BINORM. unfold res. rewrite <- FRES, F2R_mult, Rplus_0_r. auto.
++ set (X := Float radix2 (cond_Zopp sx (Zpos mx)) ex).
+ set (Y := Float radix2 (cond_Zopp sy (Zpos my)) ey).
+ set (Z := Float radix2 (cond_Zopp sz (Zpos mz)) ez).
+ destruct (Fplus (Fmult X Y) Z) as [mr er] eqn:FRES.
+ apply BINORM. unfold res. rewrite <- FRES, F2R_plus, F2R_mult. auto.
+Qed.
+
+(** Division *)
+
+Definition Fdiv_core_binary m1 e1 m2 e2 :=
+ let d1 := Zdigits2 m1 in
+ let d2 := Zdigits2 m2 in
+ let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in
+ let s := (e1 - e2 - e')%Z in
+ let m' :=
+ match s with
+ | Zpos _ => Z.shiftl m1 s
+ | Z0 => m1
+ | Zneg _ => Z0
+ end in
+ let '(q, r) := Zfast_div_eucl m' m2 in
+ (q, e', new_location m2 r loc_Exact).
+
+Lemma Bdiv_correct_aux :
+ forall m sx mx ex sy my ey,
+ let x := F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) in
+ let y := F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey) in
+ let z :=
+ let '(mz, ez, lz) := Fdiv_core_binary (Zpos mx) ex (Zpos my) ey in
+ binary_round_aux m (xorb sx sy) mz ez lz in
+ valid_binary z = true /\
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (x / y))) (bpow radix2 emax) then
+ FF2R radix2 z = round radix2 fexp (round_mode m) (x / y) /\
+ is_finite_FF z = true /\ sign_FF z = xorb sx sy
+ else
+ z = binary_overflow m (xorb sx sy).
+Proof.
+intros m sx mx ex sy my ey.
+unfold Fdiv_core_binary.
+rewrite 2!Zdigits2_Zdigits.
+set (e' := Z.min _ _).
+generalize (Fdiv_core_correct radix2 (Zpos mx) ex (Zpos my) ey e' eq_refl eq_refl).
+unfold Fdiv_core.
+rewrite Zle_bool_true by apply Z.le_min_r.
+match goal with |- context [Zfast_div_eucl ?m _] => set (mx' := m) end.
+assert (mx' = Zpos mx * Zpower radix2 (ex - ey - e'))%Z as <-.
+{ unfold mx'.
+ destruct (ex - ey - e')%Z as [|p|p].
+ now rewrite Zmult_1_r.
+ now rewrite Z.shiftl_mul_pow2.
+ easy. }
+clearbody mx'.
+rewrite Zfast_div_eucl_correct.
+destruct Z.div_eucl as [q r].
+intros Bz.
+assert (xorb sx sy = Rlt_bool (F2R (Float radix2 (cond_Zopp sx (Zpos mx)) ex) *
+ / F2R (Float radix2 (cond_Zopp sy (Zpos my)) ey)) 0) as ->.
+{ apply eq_sym.
+case sy ; simpl.
+change (Zneg my) with (Z.opp (Zpos my)).
+rewrite F2R_Zopp.
+rewrite <- Ropp_inv_permute.
+rewrite Ropp_mult_distr_r_reverse.
+case sx ; simpl.
+apply Rlt_bool_false.
+rewrite <- Ropp_mult_distr_l_reverse.
+apply Rmult_le_pos.
+rewrite <- F2R_opp.
+now apply F2R_ge_0.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rlt_bool_true.
+rewrite <- Ropp_0.
+apply Ropp_lt_contravar.
+apply Rmult_lt_0_compat.
+now apply F2R_gt_0.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rgt_not_eq.
+now apply F2R_gt_0.
+case sx.
+apply Rlt_bool_true.
+rewrite F2R_Zopp.
+rewrite Ropp_mult_distr_l_reverse.
+rewrite <- Ropp_0.
+apply Ropp_lt_contravar.
+apply Rmult_lt_0_compat.
+now apply F2R_gt_0.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0.
+apply Rlt_bool_false.
+apply Rmult_le_pos.
+now apply F2R_ge_0.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply F2R_gt_0. }
+unfold Rdiv.
+apply binary_round_aux_correct'.
+- apply Rmult_integral_contrapositive_currified.
+ now apply F2R_neq_0 ; case sx.
+ apply Rinv_neq_0_compat.
+ now apply F2R_neq_0 ; case sy.
+- rewrite Rabs_mult, Rabs_Rinv.
+ now rewrite <- 2!F2R_Zabs, 2!abs_cond_Zopp.
+ now apply F2R_neq_0 ; case sy.
+- rewrite <- cexp_abs, Rabs_mult, Rabs_Rinv.
+ rewrite 2!F2R_cond_Zopp, 2!abs_cond_Ropp, <- Rabs_Rinv.
+ rewrite <- Rabs_mult, cexp_abs.
+ apply Z.le_trans with (1 := Z.le_min_l _ _).
+ apply FLT_exp_monotone.
+ now apply mag_div_F2R.
+ now apply F2R_neq_0.
+ now apply F2R_neq_0 ; case sy.
+Qed.
+
+Definition Bdiv div_nan m x y :=
+ match x, y with
+ | B754_nan _ _ _, _ | _, B754_nan _ _ _ => build_nan (div_nan x y)
+ | B754_infinity sx, B754_infinity sy => build_nan (div_nan x y)
+ | B754_infinity sx, B754_finite sy _ _ _ => B754_infinity (xorb sx sy)
+ | B754_finite sx _ _ _, B754_infinity sy => B754_zero (xorb sx sy)
+ | B754_infinity sx, B754_zero sy => B754_infinity (xorb sx sy)
+ | B754_zero sx, B754_infinity sy => B754_zero (xorb sx sy)
+ | B754_finite sx _ _ _, B754_zero sy => B754_infinity (xorb sx sy)
+ | B754_zero sx, B754_finite sy _ _ _ => B754_zero (xorb sx sy)
+ | B754_zero sx, B754_zero sy => build_nan (div_nan x y)
+ | B754_finite sx mx ex _, B754_finite sy my ey _ =>
+ FF2B _ (proj1 (Bdiv_correct_aux m sx mx ex sy my ey))
+ end.
+
+Theorem Bdiv_correct :
+ forall div_nan m x y,
+ B2R y <> 0%R ->
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode m) (B2R x / B2R y))) (bpow radix2 emax) then
+ B2R (Bdiv div_nan m x y) = round radix2 fexp (round_mode m) (B2R x / B2R y) /\
+ is_finite (Bdiv div_nan m x y) = is_finite x /\
+ (is_nan (Bdiv div_nan m x y) = false ->
+ Bsign (Bdiv div_nan m x y) = xorb (Bsign x) (Bsign y))
+ else
+ B2FF (Bdiv div_nan m x y) = binary_overflow m (xorb (Bsign x) (Bsign y)).
+Proof.
+intros div_nan m x [sy|sy|sy ply|sy my ey Hy] Zy ; try now elim Zy.
+revert x.
+unfold Rdiv.
+intros [sx|sx|sx plx Hx|sx mx ex Hx] ;
+ try ( rewrite Rmult_0_l, round_0, Rabs_R0, Rlt_bool_true ; [ simpl ; try easy ; now rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan | apply bpow_gt_0 | auto with typeclass_instances ] ).
+simpl.
+case Bdiv_correct_aux.
+intros H1.
+unfold Rdiv.
+case Rlt_bool.
+intros (H2, (H3, H4)).
+split.
+now rewrite B2R_FF2B.
+split.
+now rewrite is_finite_FF2B.
+rewrite Bsign_FF2B. congruence.
+intros H2.
+now rewrite B2FF_FF2B.
+Qed.
+
+(** Square root *)
+
+Definition Fsqrt_core_binary m e :=
+ let d := Zdigits2 m in
+ let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in
+ let s := (e - 2 * e')%Z in
+ let m' :=
+ match s with
+ | Zpos p => Z.shiftl m s
+ | Z0 => m
+ | Zneg _ => Z0
+ end in
+ let (q, r) := Z.sqrtrem m' in
+ let l :=
+ if Zeq_bool r 0 then loc_Exact
+ else loc_Inexact (if Zle_bool r q then Lt else Gt) in
+ (q, e', l).
+
+Lemma Bsqrt_correct_aux :
+ forall m mx ex (Hx : bounded mx ex = true),
+ let x := F2R (Float radix2 (Zpos mx) ex) in
+ let z :=
+ let '(mz, ez, lz) := Fsqrt_core_binary (Zpos mx) ex in
+ binary_round_aux m false mz ez lz in
+ valid_binary z = true /\
+ FF2R radix2 z = round radix2 fexp (round_mode m) (sqrt x) /\
+ is_finite_FF z = true /\ sign_FF z = false.
+Proof with auto with typeclass_instances.
+intros m mx ex Hx.
+unfold Fsqrt_core_binary.
+rewrite Zdigits2_Zdigits.
+set (e' := Z.min _ _).
+assert (2 * e' <= ex)%Z as He.
+{ assert (e' <= Z.div2 ex)%Z by apply Z.le_min_r.
+ rewrite (Zdiv2_odd_eqn ex).
+ destruct Z.odd ; omega. }
+generalize (Fsqrt_core_correct radix2 (Zpos mx) ex e' eq_refl He).
+unfold Fsqrt_core.
+set (mx' := match (ex - 2 * e')%Z with Z0 => _ | _ => _ end).
+assert (mx' = Zpos mx * Zpower radix2 (ex - 2 * e'))%Z as <-.
+{ unfold mx'.
+ destruct (ex - 2 * e')%Z as [|p|p].
+ now rewrite Zmult_1_r.
+ now rewrite Z.shiftl_mul_pow2.
+ easy. }
+clearbody mx'.
+destruct Z.sqrtrem as [mz r].
+set (lz := if Zeq_bool r 0 then _ else _).
+clearbody lz.
+intros Bz.
+refine (_ (binary_round_aux_correct' m (sqrt (F2R (Float radix2 (Zpos mx) ex))) mz e' lz _ _ _)) ; cycle 1.
+ now apply Rgt_not_eq, sqrt_lt_R0, F2R_gt_0.
+ rewrite Rabs_pos_eq.
+ exact Bz.
+ apply sqrt_ge_0.
+ apply Z.le_trans with (1 := Z.le_min_l _ _).
+ apply FLT_exp_monotone.
+ rewrite mag_sqrt_F2R by easy.
+ apply Z.le_refl.
+rewrite Rlt_bool_false by apply sqrt_ge_0.
+rewrite Rlt_bool_true.
+easy.
+rewrite Rabs_pos_eq.
+refine (_ (relative_error_FLT_ex radix2 emin prec (prec_gt_0 prec) (round_mode m) (sqrt (F2R (Float radix2 (Zpos mx) ex))) _)).
+fold fexp.
+intros (eps, (Heps, Hr)).
+rewrite Hr.
+assert (Heps': (Rabs eps < 1)%R).
+apply Rlt_le_trans with (1 := Heps).
+fold (bpow radix2 0).
+apply bpow_le.
+generalize (prec_gt_0 prec).
+clear ; omega.
+apply Rsqr_incrst_0.
+3: apply bpow_ge_0.
+rewrite Rsqr_mult.
+rewrite Rsqr_sqrt.
+2: now apply F2R_ge_0.
+unfold Rsqr.
+apply Rmult_ge_0_gt_0_lt_compat.
+apply Rle_ge.
+apply Rle_0_sqr.
+apply bpow_gt_0.
+now apply bounded_lt_emax.
+apply Rlt_le_trans with 4%R.
+apply (Rsqr_incrst_1 _ 2).
+apply Rplus_lt_compat_l.
+apply (Rabs_lt_inv _ _ Heps').
+rewrite <- (Rplus_opp_r 1).
+apply Rplus_le_compat_l.
+apply Rlt_le.
+apply (Rabs_lt_inv _ _ Heps').
+now apply IZR_le.
+change 4%R with (bpow radix2 2).
+apply bpow_le.
+generalize (prec_gt_0 prec).
+clear -Hmax ; omega.
+apply Rmult_le_pos.
+apply sqrt_ge_0.
+rewrite <- (Rplus_opp_r 1).
+apply Rplus_le_compat_l.
+apply Rlt_le.
+apply (Rabs_lt_inv _ _ Heps').
+rewrite Rabs_pos_eq.
+2: apply sqrt_ge_0.
+apply Rsqr_incr_0.
+2: apply bpow_ge_0.
+2: apply sqrt_ge_0.
+rewrite Rsqr_sqrt.
+2: now apply F2R_ge_0.
+apply Rle_trans with (bpow radix2 emin).
+unfold Rsqr.
+rewrite <- bpow_plus.
+apply bpow_le.
+unfold emin.
+clear -Hmax ; omega.
+apply generic_format_ge_bpow with fexp.
+intros.
+apply Z.le_max_r.
+now apply F2R_gt_0.
+apply generic_format_canonical.
+apply (canonical_canonical_mantissa false).
+apply (andb_prop _ _ Hx).
+apply round_ge_generic...
+apply generic_format_0.
+apply sqrt_ge_0.
+Qed.
+
+Definition Bsqrt sqrt_nan m x :=
+ match x with
+ | B754_nan sx plx _ => build_nan (sqrt_nan x)
+ | B754_infinity false => x
+ | B754_infinity true => build_nan (sqrt_nan x)
+ | B754_finite true _ _ _ => build_nan (sqrt_nan x)
+ | B754_zero _ => x
+ | B754_finite sx mx ex Hx =>
+ FF2B _ (proj1 (Bsqrt_correct_aux m mx ex Hx))
+ end.
+
+Theorem Bsqrt_correct :
+ forall sqrt_nan m x,
+ B2R (Bsqrt sqrt_nan m x) = round radix2 fexp (round_mode m) (sqrt (B2R x)) /\
+ is_finite (Bsqrt sqrt_nan m x) = match x with B754_zero _ => true | B754_finite false _ _ _ => true | _ => false end /\
+ (is_nan (Bsqrt sqrt_nan m x) = false -> Bsign (Bsqrt sqrt_nan m x) = Bsign x).
+Proof.
+intros sqrt_nan m [sx|[|]|sx plx Hplx|sx mx ex Hx] ;
+ try ( simpl ; rewrite sqrt_0, round_0, ?B2R_build_nan, ?is_finite_build_nan, ?is_nan_build_nan ; intuition auto with typeclass_instances ; easy).
+simpl.
+case Bsqrt_correct_aux.
+intros H1 (H2, (H3, H4)).
+case sx.
+rewrite B2R_build_nan, is_finite_build_nan, is_nan_build_nan.
+refine (conj _ (conj (refl_equal false) _)).
+apply sym_eq.
+unfold sqrt.
+case Rcase_abs.
+intros _.
+apply round_0.
+auto with typeclass_instances.
+intros H.
+elim Rge_not_lt with (1 := H).
+now apply F2R_lt_0.
+easy.
+split.
+now rewrite B2R_FF2B.
+split.
+now rewrite is_finite_FF2B.
+intros _.
+now rewrite Bsign_FF2B.
+Qed.
+
+(** A few values *)
+
+Definition Bone := FF2B _ (proj1 (binary_round_correct mode_NE false 1 0)).
+
+Theorem Bone_correct : B2R Bone = 1%R.
+Proof.
+unfold Bone; simpl.
+set (Hr := binary_round_correct _ _ _ _).
+unfold Hr; rewrite B2R_FF2B.
+destruct Hr as (Vz, Hr).
+revert Hr.
+fold emin; simpl.
+rewrite round_generic; [|now apply valid_rnd_N|].
+- unfold F2R; simpl; rewrite Rmult_1_r.
+ rewrite Rlt_bool_true.
+ + now intros (Hr, Hr'); rewrite Hr.
+ + rewrite Rabs_pos_eq; [|lra].
+ change 1%R with (bpow radix2 0); apply bpow_lt.
+ unfold Prec_gt_0 in prec_gt_0_; lia.
+- apply generic_format_F2R; intros _.
+ unfold cexp, fexp, FLT_exp, F2R; simpl; rewrite Rmult_1_r, mag_1.
+ unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+Qed.
+
+Lemma is_finite_Bone : is_finite Bone = true.
+Proof.
+generalize Bone_correct; case Bone; simpl;
+ try (intros; reflexivity); intros; exfalso; lra.
+Qed.
+
+Lemma Bsign_Bone : Bsign Bone = false.
+Proof.
+generalize Bone_correct; case Bone; simpl;
+ try (intros; exfalso; lra); intros s' m e _.
+case s'; [|now intro]; unfold F2R; simpl.
+intro H; exfalso; revert H; apply Rlt_not_eq, (Rle_lt_trans _ 0); [|lra].
+rewrite <-Ropp_0, <-(Ropp_involutive (_ * _)); apply Ropp_le_contravar.
+rewrite Ropp_mult_distr_l; apply Rmult_le_pos; [|now apply bpow_ge_0].
+unfold IZR; rewrite <-INR_IPR; generalize (INR_pos m); lra.
+Qed.
+
+Lemma Bmax_float_proof :
+ valid_binary
+ (F754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec))
+ = true.
+Proof.
+unfold valid_binary, bounded; apply andb_true_intro; split.
+- unfold canonical_mantissa; apply Zeq_bool_true.
+ set (p := Z.pos (digits2_pos _)).
+ assert (H : p = prec).
+ { unfold p; rewrite Zpos_digits2_pos, Pos2Z.inj_sub.
+ - rewrite shift_pos_correct, Z.mul_1_r.
+ assert (P2pm1 : (0 <= 2 ^ prec - 1)%Z).
+ { apply (Zplus_le_reg_r _ _ 1); ring_simplify.
+ change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+ apply Zpower_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
+ apply Zdigits_unique;
+ rewrite Z.pow_pos_fold, Z2Pos.id; [|exact prec_gt_0_]; simpl; split.
+ + rewrite (Z.abs_eq _ P2pm1).
+ replace prec with (prec - 1 + 1)%Z at 2 by ring.
+ rewrite Zpower_plus; [| unfold Prec_gt_0 in prec_gt_0_; lia|lia].
+ simpl; unfold Z.pow_pos; simpl.
+ assert (1 <= 2 ^ (prec - 1))%Z; [|lia].
+ change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+ apply Zpower_le; simpl; unfold Prec_gt_0 in prec_gt_0_; lia.
+ + now rewrite Z.abs_eq; [lia|].
+ - change (_ < _)%positive
+ with (Z.pos 1 < Z.pos (shift_pos (Z.to_pos prec) 1))%Z.
+ rewrite shift_pos_correct, Z.mul_1_r, Z.pow_pos_fold.
+ rewrite Z2Pos.id; [|exact prec_gt_0_].
+ change 1%Z with (2 ^ 0)%Z; change 2%Z with (radix2 : Z).
+ apply Zpower_lt; unfold Prec_gt_0 in prec_gt_0_; lia. }
+ unfold fexp, FLT_exp; rewrite H, Z.max_l; [ring|].
+ unfold Prec_gt_0 in prec_gt_0_; unfold emin; lia.
+- apply Zle_bool_true; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+Qed.
+
+Definition Bmax_float := FF2B _ Bmax_float_proof.
+
+(** Extraction/modification of mantissa/exponent *)
+
+Definition Bnormfr_mantissa x :=
+ match x with
+ | B754_finite _ mx ex _ =>
+ if Z.eqb ex (-prec)%Z then Npos mx else 0%N
+ | _ => 0%N
+ end.
+
+Definition Bldexp mode f e :=
+ match f with
+ | B754_finite sx mx ex _ =>
+ FF2B _ (proj1 (binary_round_correct mode sx mx (ex+e)))
+ | _ => f
+ end.
+
+Theorem Bldexp_correct :
+ forall m (f : binary_float) e,
+ if Rlt_bool
+ (Rabs (round radix2 fexp (round_mode m) (B2R f * bpow radix2 e)))
+ (bpow radix2 emax) then
+ (B2R (Bldexp m f e)
+ = round radix2 fexp (round_mode m) (B2R f * bpow radix2 e))%R /\
+ is_finite (Bldexp m f e) = is_finite f /\
+ Bsign (Bldexp m f e) = Bsign f
+ else
+ B2FF (Bldexp m f e) = binary_overflow m (Bsign f).
+Proof.
+intros m f e.
+case f.
+- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+ now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+ now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- intro s; simpl; rewrite Rmult_0_l, round_0; [|apply valid_rnd_round_mode].
+ now rewrite Rabs_R0, Rlt_bool_true; [|now apply bpow_gt_0].
+- intros s mf ef Hmef.
+ case (Rlt_bool_spec _ _); intro Hover.
+ + unfold Bldexp; rewrite B2R_FF2B, is_finite_FF2B, Bsign_FF2B.
+ simpl; unfold F2R; simpl; rewrite Rmult_assoc, <-bpow_plus.
+ destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
+ fold emin in Hr; simpl in Hr; rewrite Rlt_bool_true in Hr.
+ * now destruct Hr as (Hr, (Hfr, Hsr)); rewrite Hr, Hfr, Hsr.
+ * now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
+ + unfold Bldexp; rewrite B2FF_FF2B; simpl.
+ destruct (binary_round_correct m s mf (ef + e)) as (Hf, Hr).
+ fold emin in Hr; simpl in Hr; rewrite Rlt_bool_false in Hr; [exact Hr|].
+ now revert Hover; unfold B2R, F2R; simpl; rewrite Rmult_assoc, bpow_plus.
+Qed.
+
+(** This hypothesis is needed to implement Bfrexp
+ (otherwise, we have emin > - prec
+ and Bfrexp cannot fit the mantissa in interval [0.5, 1)) *)
+Hypothesis Hemax : (3 <= emax)%Z.
+
+Definition Ffrexp_core_binary s m e :=
+ if (Z.to_pos prec <=? digits2_pos m)%positive then
+ (F754_finite s m (-prec), (e + prec)%Z)
+ else
+ let d := (prec - Z.pos (digits2_pos m))%Z in
+ (F754_finite s (shift_pos (Z.to_pos d) m) (-prec), (e + prec - d)%Z).
+
+Lemma Bfrexp_correct_aux :
+ forall sx mx ex (Hx : bounded mx ex = true),
+ let x := F2R (Float radix2 (cond_Zopp sx (Z.pos mx)) ex) in
+ let z := fst (Ffrexp_core_binary sx mx ex) in
+ let e := snd (Ffrexp_core_binary sx mx ex) in
+ valid_binary z = true /\
+ (/2 <= Rabs (FF2R radix2 z) < 1)%R /\
+ (x = FF2R radix2 z * bpow radix2 e)%R.
+Proof.
+intros sx mx ex Bx.
+set (x := F2R _).
+set (z := fst _).
+set (e := snd _); simpl.
+assert (Dmx_le_prec : (Z.pos (digits2_pos mx) <= prec)%Z).
+{ revert Bx; unfold bounded; rewrite Bool.andb_true_iff.
+ unfold canonical_mantissa; rewrite <-Zeq_is_eq_bool; unfold fexp, FLT_exp.
+ case (Z.max_spec (Z.pos (digits2_pos mx) + ex - prec) emin); lia. }
+assert (Dmx_le_prec' : (digits2_pos mx <= Z.to_pos prec)%positive).
+{ change (_ <= _)%positive
+ with (Z.pos (digits2_pos mx) <= Z.pos (Z.to_pos prec))%Z.
+ now rewrite Z2Pos.id; [|now apply prec_gt_0_]. }
+unfold z, e, Ffrexp_core_binary.
+case (Pos.leb_spec _ _); simpl; intro Dmx.
+- unfold bounded, F2R; simpl.
+ assert (Dmx' : digits2_pos mx = Z.to_pos prec).
+ { now apply Pos.le_antisym. }
+ assert (Dmx'' : Z.pos (digits2_pos mx) = prec).
+ { now rewrite Dmx', Z2Pos.id; [|apply prec_gt_0_]. }
+ split; [|split].
+ + apply andb_true_intro.
+ split; [|apply Zle_bool_true; lia].
+ apply Zeq_bool_true; unfold fexp, FLT_exp.
+ rewrite Dmx', Z2Pos.id; [|now apply prec_gt_0_].
+ rewrite Z.max_l; [ring|unfold emin; lia].
+ + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0].
+ rewrite <-abs_IZR, abs_cond_Zopp; simpl; split.
+ * apply (Rmult_le_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
+ rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
+ rewrite Rmult_1_r.
+ change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
+ rewrite <-Dmx'', Z.add_comm, Zpos_digits2_pos, Zdigits_mag; [|lia].
+ set (b := bpow _ _).
+ rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+ apply bpow_mag_le; apply IZR_neq; lia.
+ * apply (Rmult_lt_reg_r (bpow radix2 prec)); [now apply bpow_gt_0|].
+ rewrite Rmult_assoc, <-bpow_plus, Z.add_opp_diag_l; simpl.
+ rewrite Rmult_1_l, Rmult_1_r.
+ rewrite <-Dmx'', Zpos_digits2_pos, Zdigits_mag; [|lia].
+ set (b := bpow _ _).
+ rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+ apply bpow_mag_gt; apply IZR_neq; lia.
+ + unfold x, F2R; simpl; rewrite Rmult_assoc, <-bpow_plus.
+ now replace (_ + _)%Z with ex by ring.
+- unfold bounded, F2R; simpl.
+ assert (Dmx' : (Z.pos (digits2_pos mx) < prec)%Z).
+ { now rewrite <-(Z2Pos.id prec); [|now apply prec_gt_0_]. }
+ split; [|split].
+ + unfold bounded; apply andb_true_intro.
+ split; [|apply Zle_bool_true; lia].
+ apply Zeq_bool_true; unfold fexp, FLT_exp.
+ rewrite Zpos_digits2_pos, shift_pos_correct, Z.pow_pos_fold.
+ rewrite Z2Pos.id; [|lia].
+ rewrite Z.mul_comm; change 2%Z with (radix2 : Z).
+ rewrite Zdigits_mult_Zpower; [|lia|lia].
+ rewrite Zpos_digits2_pos; replace (_ - _)%Z with (- prec)%Z by ring.
+ now rewrite Z.max_l; [|unfold emin; lia].
+ + rewrite Rabs_mult, (Rabs_pos_eq (bpow _ _)); [|now apply bpow_ge_0].
+ rewrite <-abs_IZR, abs_cond_Zopp; simpl.
+ rewrite shift_pos_correct, mult_IZR.
+ change (IZR (Z.pow_pos _ _))
+ with (bpow radix2 (Z.pos (Z.to_pos ((prec - Z.pos (digits2_pos mx)))))).
+ rewrite Z2Pos.id; [|lia].
+ rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
+ set (d := Z.pos (digits2_pos mx)).
+ replace (_ + _)%Z with (- d)%Z by ring; split.
+ * apply (Rmult_le_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
+ rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
+ rewrite Rmult_1_l.
+ change (/ 2)%R with (bpow radix2 (- 1)); rewrite <-bpow_plus.
+ rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+ unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
+ apply bpow_mag_le; apply IZR_neq; lia.
+ * apply (Rmult_lt_reg_l (bpow radix2 d)); [now apply bpow_gt_0|].
+ rewrite <-Rmult_assoc, <-bpow_plus, Z.add_opp_diag_r.
+ rewrite Rmult_1_l, Rmult_1_r.
+ rewrite <-(Rabs_pos_eq (IZR _)); [|apply IZR_le; lia].
+ unfold d; rewrite Zpos_digits2_pos, Zdigits_mag; [|lia].
+ apply bpow_mag_gt; apply IZR_neq; lia.
+ + rewrite Rmult_assoc, <-bpow_plus, shift_pos_correct.
+ rewrite IZR_cond_Zopp, mult_IZR, cond_Ropp_mult_r, <-IZR_cond_Zopp.
+ change (IZR (Z.pow_pos _ _))
+ with (bpow radix2 (Z.pos (Z.to_pos (prec - Z.pos (digits2_pos mx))))).
+ rewrite Z2Pos.id; [|lia].
+ rewrite Rmult_comm, <-Rmult_assoc, <-bpow_plus.
+ now replace (_ + _)%Z with ex by ring; rewrite Rmult_comm.
+Qed.
+
+Definition Bfrexp f :=
+ match f with
+ | B754_finite s m e H =>
+ let e' := snd (Ffrexp_core_binary s m e) in
+ (FF2B _ (proj1 (Bfrexp_correct_aux s m e H)), e')
+ | _ => (f, (-2*emax-prec)%Z)
+ end.
+
+Theorem Bfrexp_correct :
+ forall f,
+ is_finite_strict f = true ->
+ let x := B2R f in
+ let z := fst (Bfrexp f) in
+ let e := snd (Bfrexp f) in
+ (/2 <= Rabs (B2R z) < 1)%R /\
+ (x = B2R z * bpow radix2 e)%R /\
+ e = mag radix2 x.
+Proof.
+intro f; case f; intro s; try discriminate; intros m e Hf _.
+generalize (Bfrexp_correct_aux s m e Hf).
+intros (_, (Hb, Heq)); simpl; rewrite B2R_FF2B.
+split; [now simpl|]; split; [now simpl|].
+rewrite Heq, mag_mult_bpow.
+- apply (Z.add_reg_l (- (snd (Ffrexp_core_binary s m e)))).
+ now ring_simplify; symmetry; apply mag_unique.
+- intro H; destruct Hb as (Hb, _); revert Hb; rewrite H, Rabs_R0; lra.
+Qed.
+
+(** Ulp *)
+
+Definition Bulp x := Bldexp mode_NE Bone (fexp (snd (Bfrexp x))).
+
+Theorem Bulp_correct :
+ forall x,
+ is_finite x = true ->
+ B2R (Bulp x) = ulp radix2 fexp (B2R x) /\
+ is_finite (Bulp x) = true /\
+ Bsign (Bulp x) = false.
+Proof.
+intro x; case x.
+- intros s _; unfold Bulp.
+ replace (fexp _) with emin.
+ + generalize (Bldexp_correct mode_NE Bone emin).
+ rewrite Bone_correct, Rmult_1_l, round_generic;
+ [|now apply valid_rnd_N|apply generic_format_bpow; unfold fexp, FLT_exp;
+ rewrite Z.max_r; unfold Prec_gt_0 in prec_gt_0_; lia].
+ rewrite Rlt_bool_true.
+ * intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
+ split; [|now split; [apply is_finite_Bone|apply Bsign_Bone]].
+ simpl; unfold ulp; rewrite Req_bool_true; [|reflexivity].
+ destruct (negligible_exp_FLT emin prec) as (n, (Hn, Hn')).
+ change fexp with (FLT_exp emin prec); rewrite Hn.
+ now unfold FLT_exp; rewrite Z.max_r;
+ [|unfold Prec_gt_0 in prec_gt_0_; lia].
+ * rewrite Rabs_pos_eq; [|now apply bpow_ge_0]; apply bpow_lt.
+ unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+ + simpl; change (fexp _) with (fexp (-2 * emax - prec)).
+ unfold fexp, FLT_exp; rewrite Z.max_r; [reflexivity|].
+ unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+- intro; discriminate.
+- intros s pl Hpl; discriminate.
+- intros s m e Hme _; unfold Bulp, ulp, cexp.
+ set (f := B754_finite _ _ _ _).
+ rewrite Req_bool_false.
+ + destruct (Bfrexp_correct f (eq_refl _)) as (Hfr1, (Hfr2, Hfr3)).
+ rewrite Hfr3.
+ set (e' := fexp _).
+ generalize (Bldexp_correct mode_NE Bone e').
+ rewrite Bone_correct, Rmult_1_l, round_generic; [|now apply valid_rnd_N|].
+ { rewrite Rlt_bool_true.
+ - intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
+ now split; [|split; [apply is_finite_Bone|apply Bsign_Bone]].
+ - rewrite Rabs_pos_eq; [|now apply bpow_ge_0].
+ unfold e', fexp, FLT_exp.
+ case (Z.max_spec (mag radix2 (B2R f) - prec) emin)
+ as [(_, Hm)|(_, Hm)]; rewrite Hm; apply bpow_lt;
+ [now unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia|].
+ apply (Zplus_lt_reg_r _ _ prec); ring_simplify.
+ assert (mag radix2 (B2R f) <= emax)%Z;
+ [|now unfold Prec_gt_0 in prec_gt_0_; lia].
+ apply mag_le_bpow; [|now apply abs_B2R_lt_emax].
+ now unfold f, B2R; apply F2R_neq_0; case s. }
+ apply generic_format_bpow, Z.max_lub.
+ * unfold Prec_gt_0 in prec_gt_0_; lia.
+ * apply Z.le_max_r.
+ + now unfold f, B2R; apply F2R_neq_0; case s.
+Qed.
+
+(** Successor (and predecessor) *)
+
+Definition Bpred_pos pred_pos_nan x :=
+ match x with
+ | B754_finite _ mx _ _ =>
+ let d :=
+ if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then
+ Bldexp mode_NE Bone (fexp (snd (Bfrexp x) - 1))
+ else
+ Bulp x in
+ Bminus (fun _ => pred_pos_nan) mode_NE x d
+ | _ => x
+ end.
+
+Theorem Bpred_pos_correct :
+ forall pred_pos_nan x,
+ (0 < B2R x)%R ->
+ B2R (Bpred_pos pred_pos_nan x) = pred_pos radix2 fexp (B2R x) /\
+ is_finite (Bpred_pos pred_pos_nan x) = true /\
+ Bsign (Bpred_pos pred_pos_nan x) = false.
+Proof.
+intros pred_pos_nan x.
+generalize (Bfrexp_correct x).
+case x.
+- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
+- simpl; intros s _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
+- simpl; intros s pl Hpl _ Bx; exfalso; apply (Rlt_irrefl _ Bx).
+- intros sx mx ex Hmex Hfrexpx Px.
+ assert (Hsx : sx = false).
+ { revert Px; case sx; unfold B2R, F2R; simpl; [|now intro].
+ intro Px; exfalso; revert Px; apply Rle_not_lt.
+ rewrite <-(Rmult_0_l (bpow radix2 ex)).
+ apply Rmult_le_compat_r; [apply bpow_ge_0|apply IZR_le; lia]. }
+ clear Px; rewrite Hsx in Hfrexpx |- *; clear Hsx sx.
+ specialize (Hfrexpx (eq_refl _)).
+ simpl in Hfrexpx; rewrite B2R_FF2B in Hfrexpx.
+ destruct Hfrexpx as (Hfrexpx_bounds, (Hfrexpx_eq, Hfrexpx_exp)).
+ unfold Bpred_pos, Bfrexp.
+ simpl (snd (_, snd _)).
+ rewrite Hfrexpx_exp.
+ set (x' := B754_finite _ _ _ _).
+ set (xr := F2R _).
+ assert (Nzxr : xr <> 0%R).
+ { unfold xr, F2R; simpl.
+ rewrite <-(Rmult_0_l (bpow radix2 ex)); intro H.
+ apply Rmult_eq_reg_r in H; [|apply Rgt_not_eq, bpow_gt_0].
+ apply eq_IZR in H; lia. }
+ assert (Hulp := Bulp_correct x').
+ specialize (Hulp (eq_refl _)).
+ assert (Hldexp := Bldexp_correct mode_NE Bone (fexp (mag radix2 xr - 1))).
+ rewrite Bone_correct, Rmult_1_l in Hldexp.
+ assert (Fbpowxr : generic_format radix2 fexp
+ (bpow radix2 (fexp (mag radix2 xr - 1)))).
+ { apply generic_format_bpow, Z.max_lub.
+ - unfold Prec_gt_0 in prec_gt_0_; lia.
+ - apply Z.le_max_r. }
+ assert (H : Rlt_bool (Rabs
+ (round radix2 fexp (round_mode mode_NE)
+ (bpow radix2 (fexp (mag radix2 xr - 1)))))
+ (bpow radix2 emax) = true); [|rewrite H in Hldexp; clear H].
+ { apply Rlt_bool_true; rewrite round_generic;
+ [|apply valid_rnd_round_mode|apply Fbpowxr].
+ rewrite Rabs_pos_eq; [|apply bpow_ge_0]; apply bpow_lt.
+ apply Z.max_lub_lt; [|unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia].
+ apply (Zplus_lt_reg_r _ _ (prec + 1)); ring_simplify.
+ rewrite Z.add_1_r; apply Zle_lt_succ, mag_le_bpow.
+ - exact Nzxr.
+ - apply (Rlt_le_trans _ (bpow radix2 emax)).
+ + change xr with (B2R x'); apply abs_B2R_lt_emax.
+ + apply bpow_le; unfold Prec_gt_0 in prec_gt_0_; lia. }
+ set (d := if (mx~0 =? _)%positive then _ else _).
+ set (minus_nan := fun _ => _).
+ assert (Hminus := Bminus_correct minus_nan mode_NE x' d (eq_refl _)).
+ assert (Fd : is_finite d = true).
+ { unfold d; case (_ =? _)%positive.
+ - now rewrite (proj1 (proj2 Hldexp)), is_finite_Bone.
+ - now rewrite (proj1 (proj2 Hulp)). }
+ specialize (Hminus Fd).
+ assert (Px : (0 <= B2R x')%R).
+ { unfold B2R, x', F2R; simpl.
+ now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
+ assert (Pd : (0 <= B2R d)%R).
+ { unfold d; case (_ =? _)%positive.
+ - rewrite (proj1 Hldexp).
+ now rewrite round_generic; [apply bpow_ge_0|apply valid_rnd_N|].
+ - rewrite (proj1 Hulp); apply ulp_ge_0. }
+ assert (Hdlex : (B2R d <= B2R x')%R).
+ { unfold d; case (_ =? _)%positive.
+ - rewrite (proj1 Hldexp).
+ rewrite round_generic; [|now apply valid_rnd_N|now simpl].
+ apply (Rle_trans _ (bpow radix2 (mag radix2 xr - 1))).
+ + apply bpow_le, Z.max_lub.
+ * unfold Prec_gt_0 in prec_gt_0_; lia.
+ * apply (Zplus_le_reg_r _ _ 1); ring_simplify.
+ apply mag_ge_bpow.
+ replace (_ - 1)%Z with emin by ring.
+ now change xr with (B2R x'); apply abs_B2R_ge_emin.
+ + rewrite <-(Rabs_pos_eq _ Px).
+ now change xr with (B2R x'); apply bpow_mag_le.
+ - rewrite (proj1 Hulp); apply ulp_le_id.
+ + assert (B2R x' <> 0%R); [exact Nzxr|lra].
+ + apply generic_format_B2R. }
+ assert (H : Rlt_bool
+ (Rabs
+ (round radix2 fexp
+ (round_mode mode_NE) (B2R x' - B2R d)))
+ (bpow radix2 emax) = true); [|rewrite H in Hminus; clear H].
+ { apply Rlt_bool_true.
+ rewrite <-round_NE_abs; [|now apply FLT_exp_valid].
+ rewrite Rabs_pos_eq; [|lra].
+ apply (Rle_lt_trans _ (B2R x')).
+ - apply round_le_generic;
+ [now apply FLT_exp_valid|now apply valid_rnd_N| |lra].
+ apply generic_format_B2R.
+ - apply (Rle_lt_trans _ _ _ (Rle_abs _)), abs_B2R_lt_emax. }
+ rewrite (proj1 Hminus).
+ rewrite (proj1 (proj2 Hminus)).
+ rewrite (proj2 (proj2 Hminus)).
+ split; [|split; [reflexivity|now case (Rcompare_spec _ _); [lra| |]]].
+ unfold pred_pos, d.
+ case (Pos.eqb_spec _ _); intro Hd; case (Req_bool_spec _ _); intro Hpred.
+ + rewrite (proj1 Hldexp).
+ rewrite (round_generic _ _ _ _ Fbpowxr).
+ change xr with (B2R x').
+ replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+ * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
+ apply generic_format_pred_pos;
+ [now apply FLT_exp_valid|apply generic_format_B2R|].
+ change xr with (B2R x') in Nzxr; lra.
+ * now unfold pred_pos; rewrite Req_bool_true.
+ + exfalso; apply Hpred.
+ assert (Hmx : IZR (Z.pos mx) = bpow radix2 (prec - 1)).
+ { apply (Rmult_eq_reg_l 2); [|lra]; rewrite <-mult_IZR.
+ change (2 * Z.pos mx)%Z with (Z.pos mx~0); rewrite Hd.
+ rewrite shift_pos_correct, Z.mul_1_r.
+ change (IZR (Z.pow_pos _ _)) with (bpow radix2 (Z.pos (Z.to_pos prec))).
+ rewrite Z2Pos.id; [|exact prec_gt_0_].
+ change 2%R with (bpow radix2 1); rewrite <-bpow_plus.
+ f_equal; ring. }
+ unfold x' at 1; unfold B2R at 1; unfold F2R; simpl.
+ rewrite Hmx, <-bpow_plus; f_equal.
+ apply (Z.add_reg_l 1); ring_simplify; symmetry; apply mag_unique_pos.
+ unfold F2R; simpl; rewrite Hmx, <-bpow_plus; split.
+ * right; f_equal; ring.
+ * apply bpow_lt; lia.
+ + rewrite (proj1 Hulp).
+ assert (H : ulp radix2 fexp (B2R x')
+ = bpow radix2 (fexp (mag radix2 (B2R x') - 1)));
+ [|rewrite H; clear H].
+ { unfold ulp; rewrite Req_bool_false; [|now simpl].
+ unfold cexp; f_equal.
+ assert (H : (mag radix2 (B2R x') <= emin + prec)%Z).
+ { assert (Hcm : canonical_mantissa mx ex = true).
+ { now generalize Hmex; unfold bounded; rewrite Bool.andb_true_iff. }
+ apply (canonical_canonical_mantissa false) in Hcm.
+ revert Hcm; fold emin; unfold canonical, cexp; simpl.
+ change (F2R _) with (B2R x'); intro Hex.
+ apply Z.nlt_ge; intro H'; apply Hd.
+ apply Pos2Z.inj_pos; rewrite shift_pos_correct, Z.mul_1_r.
+ apply eq_IZR; change (IZR (Z.pow_pos _ _))
+ with (bpow radix2 (Z.pos (Z.to_pos prec))).
+ rewrite Z2Pos.id; [|exact prec_gt_0_].
+ change (Z.pos mx~0) with (2 * Z.pos mx)%Z.
+ rewrite Z.mul_comm, mult_IZR.
+ apply (Rmult_eq_reg_r (bpow radix2 (ex - 1)));
+ [|apply Rgt_not_eq, bpow_gt_0].
+ change 2%R with (bpow radix2 1); rewrite Rmult_assoc, <-!bpow_plus.
+ replace (1 + _)%Z with ex by ring.
+ unfold B2R at 1, F2R in Hpred; simpl in Hpred; rewrite Hpred.
+ change (F2R _) with (B2R x'); rewrite Hex.
+ unfold fexp, FLT_exp; rewrite Z.max_l; [f_equal; ring|lia]. }
+ now unfold fexp, FLT_exp; do 2 (rewrite Z.max_r; [|lia]). }
+ replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+ * rewrite round_generic; [reflexivity|apply valid_rnd_N|].
+ apply generic_format_pred_pos;
+ [now apply FLT_exp_valid| |change xr with (B2R x') in Nzxr; lra].
+ apply generic_format_B2R.
+ * now unfold pred_pos; rewrite Req_bool_true.
+ + rewrite (proj1 Hulp).
+ replace (_ - _)%R with (pred_pos radix2 fexp (B2R x')).
+ * rewrite round_generic; [reflexivity|now apply valid_rnd_N|].
+ apply generic_format_pred_pos;
+ [now apply FLT_exp_valid|apply generic_format_B2R|].
+ change xr with (B2R x') in Nzxr; lra.
+ * now unfold pred_pos; rewrite Req_bool_false.
+Qed.
+
+Definition Bsucc succ_nan x :=
+ match x with
+ | B754_zero _ => Bldexp mode_NE Bone emin
+ | B754_infinity false => x
+ | B754_infinity true => Bopp succ_nan Bmax_float
+ | B754_nan _ _ _ => build_nan (succ_nan x)
+ | B754_finite false _ _ _ =>
+ Bplus (fun _ => succ_nan) mode_NE x (Bulp x)
+ | B754_finite true _ _ _ =>
+ Bopp succ_nan (Bpred_pos succ_nan (Bopp succ_nan x))
+ end.
+
+Lemma Bsucc_correct :
+ forall succ_nan x,
+ is_finite x = true ->
+ if Rlt_bool (succ radix2 fexp (B2R x)) (bpow radix2 emax) then
+ B2R (Bsucc succ_nan x) = succ radix2 fexp (B2R x) /\
+ is_finite (Bsucc succ_nan x) = true /\
+ (Bsign (Bsucc succ_nan x) = Bsign x && is_finite_strict x)%bool
+ else
+ B2FF (Bsucc succ_nan x) = F754_infinity false.
+Proof.
+assert (Hsucc : succ radix2 fexp 0 = bpow radix2 emin).
+{ unfold succ; rewrite Rle_bool_true; [|now right]; rewrite Rplus_0_l.
+ unfold ulp; rewrite Req_bool_true; [|now simpl].
+ destruct (negligible_exp_FLT emin prec) as (n, (Hne, Hn)).
+ now unfold fexp; rewrite Hne; unfold FLT_exp; rewrite Z.max_r;
+ [|unfold Prec_gt_0 in prec_gt_0_; lia]. }
+intros succ_nan [s|s|s pl Hpl|sx mx ex Hmex]; try discriminate; intros _.
+- generalize (Bldexp_correct mode_NE Bone emin); unfold Bsucc; simpl.
+ assert (Hbemin : round radix2 fexp ZnearestE (bpow radix2 emin)
+ = bpow radix2 emin).
+ { rewrite round_generic; [reflexivity|apply valid_rnd_N|].
+ apply generic_format_bpow.
+ unfold fexp, FLT_exp; rewrite Z.max_r; [now simpl|].
+ unfold Prec_gt_0 in prec_gt_0_; lia. }
+ rewrite Hsucc, Rlt_bool_true.
+ + intros (Hr, (Hf, Hs)); rewrite Hr, Hf, Hs.
+ rewrite Bone_correct, Rmult_1_l, is_finite_Bone, Bsign_Bone.
+ case Rlt_bool_spec; intro Hover.
+ * now rewrite Bool.andb_false_r.
+ * exfalso; revert Hover; apply Rlt_not_le, bpow_lt.
+ unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+ + rewrite Bone_correct, Rmult_1_l, Hbemin, Rabs_pos_eq; [|apply bpow_ge_0].
+ apply bpow_lt; unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+- unfold Bsucc; case sx.
+ + case Rlt_bool_spec; intro Hover.
+ * rewrite B2R_Bopp; simpl (Bopp _ (B754_finite _ _ _ _)).
+ rewrite is_finite_Bopp.
+ set (ox := B754_finite false mx ex Hmex).
+ assert (Hpred := Bpred_pos_correct succ_nan ox).
+ assert (Hox : (0 < B2R ox)%R); [|specialize (Hpred Hox); clear Hox].
+ { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. }
+ rewrite (proj1 Hpred), (proj1 (proj2 Hpred)).
+ unfold succ; rewrite Rle_bool_false; [split; [|split]|].
+ { now unfold B2R, F2R, ox; simpl; rewrite Ropp_mult_distr_l, <-opp_IZR. }
+ { now simpl. }
+ { simpl (Bsign (B754_finite _ _ _ _)); simpl (true && _)%bool.
+ rewrite Bsign_Bopp, (proj2 (proj2 Hpred)); [now simpl|].
+ now destruct Hpred as (_, (H, _)); revert H; case (Bpred_pos _ _). }
+ unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z.
+ rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_lt_contravar.
+ now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0].
+ * exfalso; revert Hover; apply Rlt_not_le.
+ apply (Rle_lt_trans _ (succ radix2 fexp 0)).
+ { apply succ_le; [now apply FLT_exp_valid|apply generic_format_B2R|
+ apply generic_format_0|].
+ unfold B2R, F2R; simpl; change (Z.neg mx) with (- Z.pos mx)%Z.
+ rewrite opp_IZR, <-Ropp_mult_distr_l, <-Ropp_0; apply Ropp_le_contravar.
+ now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
+ rewrite Hsucc; apply bpow_lt.
+ unfold emin; unfold Prec_gt_0 in prec_gt_0_; lia.
+ + set (x := B754_finite _ _ _ _).
+ set (plus_nan := fun _ => succ_nan).
+ assert (Hulp := Bulp_correct x (eq_refl _)).
+ assert (Hplus := Bplus_correct plus_nan mode_NE x (Bulp x) (eq_refl _)).
+ rewrite (proj1 (proj2 Hulp)) in Hplus; specialize (Hplus (eq_refl _)).
+ assert (Px : (0 <= B2R x)%R).
+ { now apply Rmult_le_pos; [apply IZR_le|apply bpow_ge_0]. }
+ assert (Hsucc' : (succ radix2 fexp (B2R x)
+ = B2R x + ulp radix2 fexp (B2R x))%R).
+ { now unfold succ; rewrite (Rle_bool_true _ _ Px). }
+ rewrite (proj1 Hulp), <- Hsucc' in Hplus.
+ rewrite round_generic in Hplus;
+ [|apply valid_rnd_N| now apply generic_format_succ;
+ [apply FLT_exp_valid|apply generic_format_B2R]].
+ rewrite Rabs_pos_eq in Hplus; [|apply (Rle_trans _ _ _ Px), succ_ge_id].
+ revert Hplus; case Rlt_bool_spec; intros Hover Hplus.
+ * split; [now simpl|split; [now simpl|]].
+ rewrite (proj2 (proj2 Hplus)); case Rcompare_spec.
+ { intro H; exfalso; revert H.
+ apply Rle_not_lt, (Rle_trans _ _ _ Px), succ_ge_id. }
+ { intro H; exfalso; revert H; apply Rgt_not_eq, Rlt_gt.
+ apply (Rlt_le_trans _ (B2R x)); [|apply succ_ge_id].
+ now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. }
+ now simpl.
+ * now rewrite (proj1 Hplus).
+Qed.
+
+Definition Bpred pred_nan x :=
+ Bopp pred_nan (Bsucc pred_nan (Bopp pred_nan x)).
+
+Lemma Bpred_correct :
+ forall pred_nan x,
+ is_finite x = true ->
+ if Rlt_bool (- bpow radix2 emax) (pred radix2 fexp (B2R x)) then
+ B2R (Bpred pred_nan x) = pred radix2 fexp (B2R x) /\
+ is_finite (Bpred pred_nan x) = true /\
+ (Bsign (Bpred pred_nan x) = Bsign x || negb (is_finite_strict x))%bool
+ else
+ B2FF (Bpred pred_nan x) = F754_infinity true.
+Proof.
+intros pred_nan x Fx.
+assert (Fox : is_finite (Bopp pred_nan x) = true).
+{ now rewrite is_finite_Bopp. }
+rewrite <-(Ropp_involutive (B2R x)), <-(B2R_Bopp pred_nan).
+rewrite pred_opp, Rlt_bool_opp.
+generalize (Bsucc_correct pred_nan _ Fox).
+case (Rlt_bool _ _).
+- intros (HR, (HF, HS)); unfold Bpred.
+ rewrite B2R_Bopp, HR, is_finite_Bopp.
+ rewrite <-(Bool.negb_involutive (Bsign x)), <-Bool.negb_andb.
+ split; [reflexivity|split; [exact HF|]].
+ replace (is_finite_strict x) with (is_finite_strict (Bopp pred_nan x));
+ [|now case x; try easy; intros s pl Hpl; simpl;
+ rewrite is_finite_strict_build_nan].
+ rewrite Bsign_Bopp, <-(Bsign_Bopp pred_nan x), HS.
+ + now simpl.
+ + now revert Fx; case x.
+ + now revert HF; case (Bsucc _ _).
+- now unfold Bpred; case (Bsucc _ _); intro s; case s.
+Qed.
+
+End Binary.
diff --git a/flocq/Appli/Fappli_IEEE_bits.v b/flocq/IEEE754/Bits.v
index e6a012cf..3a84edfe 100644
--- a/flocq/Appli/Fappli_IEEE_bits.v
+++ b/flocq/IEEE754/Bits.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2011-2013 Sylvie Boldo
+Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2011-2013 Guillaume Melquiond
+Copyright (C) 2011-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,46 +18,18 @@ COPYING file for more details.
*)
(** * IEEE-754 encoding of binary floating-point data *)
-Require Import Fcore.
-Require Import Fcore_digits.
-Require Import Fcalc_digits.
-Require Import Fappli_IEEE.
+Require Import Core Digits Binary.
Section Binary_Bits.
-Arguments exist {A P} x _.
-Arguments B754_zero {prec emax} _.
-Arguments B754_infinity {prec emax} _.
-Arguments B754_nan {prec emax} _ _.
-Arguments B754_finite {prec emax} _ m e _.
+Arguments exist {A} {P}.
+Arguments B754_zero {prec} {emax}.
+Arguments B754_infinity {prec} {emax}.
+Arguments B754_nan {prec} {emax}.
+Arguments B754_finite {prec} {emax}.
(** Number of bits for the fraction and exponent *)
Variable mw ew : Z.
-Hypothesis Hmw : (0 < mw)%Z.
-Hypothesis Hew : (0 < ew)%Z.
-
-Let emax := Zpower 2 (ew - 1).
-Let prec := (mw + 1)%Z.
-Let emin := (3 - emax - prec)%Z.
-Let binary_float := binary_float prec emax.
-
-Let Hprec : (0 < prec)%Z.
-unfold prec.
-apply Zle_lt_succ.
-now apply Zlt_le_weak.
-Qed.
-
-Let Hm_gt_0 : (0 < 2^mw)%Z.
-apply (Zpower_gt_0 radix2).
-now apply Zlt_le_weak.
-Qed.
-
-Let He_gt_0 : (0 < 2^ew)%Z.
-apply (Zpower_gt_0 radix2).
-now apply Zlt_le_weak.
-Qed.
-
-Hypothesis Hmax : (prec < emax)%Z.
Definition join_bits (s : bool) m e :=
(Z.shiftl ((if s then Zpower 2 ew else 0) + e) mw + m)%Z.
@@ -69,8 +41,14 @@ Lemma join_bits_range :
(0 <= join_bits s m e < 2 ^ (mw + ew + 1))%Z.
Proof.
intros s m e Hm He.
+assert (0 <= mw)%Z as Hmw.
+ destruct mw as [|mw'|mw'] ; try easy.
+ clear -Hm ; simpl in Hm ; omega.
+assert (0 <= ew)%Z as Hew.
+ destruct ew as [|ew'|ew'] ; try easy.
+ clear -He ; simpl in He ; omega.
unfold join_bits.
-rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
+rewrite Z.shiftl_mul_pow2 by easy.
split.
- apply (Zplus_le_compat 0 _ 0) with (2 := proj1 Hm).
rewrite <- (Zmult_0_l (2^mw)).
@@ -79,26 +57,24 @@ split.
clear -He ; omega.
now rewrite Zmult_0_l.
clear -Hm ; omega.
-- apply Zlt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z.
+- apply Z.lt_le_trans with (((if s then 2 ^ ew else 0) + e + 1) * 2 ^ mw)%Z.
rewrite (Zmult_plus_distr_l _ 1).
apply Zplus_lt_compat_l.
now rewrite Zmult_1_l.
rewrite <- (Zplus_assoc mw), (Zplus_comm mw), Zpower_plus.
apply Zmult_le_compat_r.
- rewrite Zpower_plus.
+ rewrite Zpower_plus by easy.
change (2^1)%Z with 2%Z.
case s ; clear -He ; omega.
- now apply Zlt_le_weak.
- easy.
clear -Hm ; omega.
clear -Hew ; omega.
- now apply Zlt_le_weak.
+ easy.
Qed.
Definition split_bits x :=
let mm := Zpower 2 mw in
let em := Zpower 2 ew in
- (Zle_bool (mm * em) x, Zmod x mm, Zmod (Zdiv x mm) em)%Z.
+ (Zle_bool (mm * em) x, Zmod x mm, Zmod (Z.div x mm) em)%Z.
Theorem split_join_bits :
forall s m e,
@@ -107,45 +83,75 @@ Theorem split_join_bits :
split_bits (join_bits s m e) = (s, m, e).
Proof.
intros s m e Hm He.
+assert (0 <= mw)%Z as Hmw.
+ destruct mw as [|mw'|mw'] ; try easy.
+ clear -Hm ; simpl in Hm ; omega.
+assert (0 <= ew)%Z as Hew.
+ destruct ew as [|ew'|ew'] ; try easy.
+ clear -He ; simpl in He ; omega.
unfold split_bits, join_bits.
-rewrite Z.shiftl_mul_pow2 by now apply Zlt_le_weak.
-apply f_equal2.
-apply f_equal2.
-(* *)
-case s.
-apply Zle_bool_true.
-apply Zle_0_minus_le.
-ring_simplify.
-apply Zplus_le_0_compat.
-apply Zmult_le_0_compat.
-apply He.
+rewrite Z.shiftl_mul_pow2 by easy.
+apply f_equal2 ; [apply f_equal2|].
+- case s.
+ + apply Zle_bool_true.
+ apply Zle_0_minus_le.
+ ring_simplify.
+ apply Zplus_le_0_compat.
+ apply Zmult_le_0_compat.
+ apply He.
+ clear -Hm ; omega.
+ apply Hm.
+ + apply Zle_bool_false.
+ apply Zplus_lt_reg_l with (2^mw * (-e))%Z.
+ replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring.
+ rewrite <- Zmult_plus_distr_r.
+ apply Z.lt_le_trans with (2^mw * 1)%Z.
+ now apply Zmult_lt_compat_r.
+ apply Zmult_le_compat_l.
+ clear -He ; omega.
+ clear -Hm ; omega.
+- rewrite Zplus_comm.
+ rewrite Z_mod_plus_full.
+ now apply Zmod_small.
+- rewrite Z_div_plus_full_l by (clear -Hm ; omega).
+ rewrite Zdiv_small with (1 := Hm).
+ rewrite Zplus_0_r.
+ case s.
+ + replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring.
+ rewrite Z_mod_plus_full.
+ now apply Zmod_small.
+ + now apply Zmod_small.
+Qed.
+
+Hypothesis Hmw : (0 < mw)%Z.
+Hypothesis Hew : (0 < ew)%Z.
+
+Let emax := Zpower 2 (ew - 1).
+Let prec := (mw + 1)%Z.
+Let emin := (3 - emax - prec)%Z.
+Let binary_float := binary_float prec emax.
+
+Let Hprec : (0 < prec)%Z.
+Proof.
+unfold prec.
+apply Zle_lt_succ.
now apply Zlt_le_weak.
-apply Hm.
-apply Zle_bool_false.
-apply Zplus_lt_reg_l with (2^mw * (-e))%Z.
-replace (2 ^ mw * - e + ((0 + e) * 2 ^ mw + m))%Z with (m * 1)%Z by ring.
-rewrite <- Zmult_plus_distr_r.
-apply Zlt_le_trans with (2^mw * 1)%Z.
-now apply Zmult_lt_compat_r.
-apply Zmult_le_compat_l.
-clear -He. omega.
+Qed.
+
+Let Hm_gt_0 : (0 < 2^mw)%Z.
+Proof.
+apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
-(* *)
-rewrite Zplus_comm.
-rewrite Z_mod_plus_full.
-now apply Zmod_small.
-(* *)
-rewrite Z_div_plus_full_l.
-rewrite Zdiv_small with (1 := Hm).
-rewrite Zplus_0_r.
-case s.
-replace (2^ew + e)%Z with (e + 1 * 2^ew)%Z by ring.
-rewrite Z_mod_plus_full.
-now apply Zmod_small.
-now apply Zmod_small.
-now apply Zgt_not_eq.
Qed.
+Let He_gt_0 : (0 < 2^ew)%Z.
+Proof.
+apply (Zpower_gt_0 radix2).
+now apply Zlt_le_weak.
+Qed.
+
+Hypothesis Hmax : (prec < emax)%Z.
+
Theorem join_split_bits :
forall x,
(0 <= x < Zpower 2 (mw + ew + 1))%Z ->
@@ -171,17 +177,15 @@ case Zle_bool_spec ; intros Hs.
apply Zle_antisym.
cut (x / (2^mw * 2^ew) < 2)%Z. clear ; omega.
apply Zdiv_lt_upper_bound.
-try apply Hx. (* 8.2/8.3 compatibility *)
now apply Zmult_lt_0_compat.
-rewrite <- Zpower_exp ; try ( apply Zle_ge ; apply Zlt_le_weak ; assumption ).
+rewrite <- Zpower_exp ; try ( apply Z.le_ge ; apply Zlt_le_weak ; assumption ).
change 2%Z at 1 with (Zpower 2 1).
rewrite <- Zpower_exp.
now rewrite Zplus_comm.
discriminate.
-apply Zle_ge.
+apply Z.le_ge.
now apply Zplus_le_0_compat ; apply Zlt_le_weak.
apply Zdiv_le_lower_bound.
-try apply Hx. (* 8.2/8.3 compatibility *)
now apply Zmult_lt_0_compat.
now rewrite Zmult_1_l.
apply Zdiv_small.
@@ -213,7 +217,7 @@ Definition bits_of_binary_float (x : binary_float) :=
match x with
| B754_zero sx => join_bits sx 0 0
| B754_infinity sx => join_bits sx 0 (Zpower 2 ew - 1)
- | B754_nan sx (exist plx _) => join_bits sx (Zpos plx) (Zpower 2 ew - 1)
+ | B754_nan sx plx _ => join_bits sx (Zpos plx) (Zpower 2 ew - 1)
| B754_finite sx mx ex _ =>
let m := (Zpos mx - Zpower 2 mw)%Z in
if Zle_bool 0 m then
@@ -226,7 +230,7 @@ Definition split_bits_of_binary_float (x : binary_float) :=
match x with
| B754_zero sx => (sx, 0, 0)%Z
| B754_infinity sx => (sx, 0, Zpower 2 ew - 1)%Z
- | B754_nan sx (exist plx _) => (sx, Zpos plx, Zpower 2 ew - 1)%Z
+ | B754_nan sx plx _ => (sx, Zpos plx, Zpower 2 ew - 1)%Z
| B754_finite sx mx ex _ =>
let m := (Zpos mx - Zpower 2 mw)%Z in
if Zle_bool 0 m then
@@ -239,13 +243,14 @@ Theorem split_bits_of_binary_float_correct :
forall x,
split_bits (bits_of_binary_float x) = split_bits_of_binary_float x.
Proof.
-intros [sx|sx|sx [plx Hplx]|sx mx ex Hx] ;
- try ( simpl ; apply split_join_bits ; split ; try apply Zle_refl ; try apply Zlt_pred ; trivial ; omega ).
+intros [sx|sx|sx plx Hplx|sx mx ex Hx] ;
+ try ( simpl ; apply split_join_bits ; split ; try apply Z.le_refl ; try apply Zlt_pred ; trivial ; omega ).
simpl. apply split_join_bits; split; try (zify; omega).
destruct (digits2_Pnat_correct plx).
+unfold nan_pl in Hplx.
rewrite Zpos_digits2_pos, <- Z_of_nat_S_digits2_Pnat in Hplx.
rewrite Zpower_nat_Z in H0.
-eapply Zlt_le_trans. apply H0.
+eapply Z.lt_le_trans. apply H0.
change 2%Z with (radix_val radix2). apply Zpower_le.
rewrite Z.ltb_lt in Hplx.
unfold prec in *. zify; omega.
@@ -253,7 +258,7 @@ unfold prec in *. zify; omega.
unfold bits_of_binary_float, split_bits_of_binary_float.
assert (Hf: (emin <= ex /\ Zdigits radix2 (Zpos mx) <= prec)%Z).
destruct (andb_prop _ _ Hx) as (Hx', _).
-unfold canonic_mantissa in Hx'.
+unfold canonical_mantissa in Hx'.
rewrite Zpos_digits2_pos in Hx'.
generalize (Zeq_bool_eq _ _ Hx').
unfold FLT_exp.
@@ -271,7 +276,7 @@ apply (Zpower_gt_Zdigits radix2 _ (Zpos mx)).
apply Hf.
unfold prec.
rewrite Zplus_comm.
-apply Zpower_exp ; apply Zle_ge.
+apply Zpower_exp ; apply Z.le_ge.
discriminate.
now apply Zlt_le_weak.
(* *)
@@ -285,9 +290,9 @@ generalize (Zle_bool_imp_le _ _ Hx').
clear ; omega.
apply sym_eq.
rewrite (Zsucc_pred ew).
-unfold Zsucc.
+unfold Z.succ.
rewrite Zplus_comm.
-apply Zpower_exp ; apply Zle_ge.
+apply Zpower_exp ; apply Z.le_ge.
discriminate.
now apply Zlt_0_le_0_pred.
Qed.
@@ -296,7 +301,7 @@ Theorem bits_of_binary_float_range:
forall x, (0 <= bits_of_binary_float x < 2^(mw+ew+1))%Z.
Proof.
unfold bits_of_binary_float.
-intros [sx|sx|sx [pl pl_range]|sx mx ex H].
+intros [sx|sx|sx pl pl_range|sx mx ex H].
- apply join_bits_range ; now split.
- apply join_bits_range.
now split.
@@ -312,7 +317,7 @@ intros [sx|sx|sx [pl pl_range]|sx mx ex H].
- unfold bounded in H.
apply Bool.andb_true_iff in H ; destruct H as [A B].
apply Z.leb_le in B.
- unfold canonic_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
+ unfold canonical_mantissa, FLT_exp in A. apply Zeq_bool_eq in A.
case Zle_bool_spec ; intros H.
+ apply join_bits_range.
* split.
@@ -362,6 +367,10 @@ Lemma binary_float_of_bits_aux_correct :
Proof.
intros x.
unfold binary_float_of_bits_aux, split_bits.
+assert (Hnan: nan_pl prec 1 = true).
+ apply Z.ltb_lt.
+ simpl. unfold prec.
+ clear -Hmw ; omega.
case Zeq_bool_spec ; intros He1.
case_eq (x mod 2^mw)%Z ; try easy.
(* subnormal *)
@@ -371,11 +380,11 @@ apply Zdigits_le_Zpower.
simpl.
rewrite <- Hm.
eapply Z_mod_lt.
-now apply Zlt_gt.
-apply bounded_canonic_lt_emax ; try assumption.
-unfold canonic, canonic_exp.
+now apply Z.lt_gt.
+apply bounded_canonical_lt_emax ; try assumption.
+unfold canonical, cexp.
fold emin.
-rewrite ln_beta_F2R_Zdigits. 2: discriminate.
+rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
apply sym_eq.
apply Zmax_right.
@@ -383,16 +392,15 @@ clear -H Hprec.
unfold prec ; omega.
apply Rnot_le_lt.
intros H0.
-refine (_ (ln_beta_le radix2 _ _ _ H0)).
-rewrite ln_beta_bpow.
-rewrite ln_beta_F2R_Zdigits. 2: discriminate.
+refine (_ (mag_le radix2 _ _ _ H0)).
+rewrite mag_bpow.
+rewrite mag_F2R_Zdigits. 2: discriminate.
unfold emin, prec.
apply Zlt_not_le.
cut (0 < emax)%Z. clear -H Hew ; omega.
apply (Zpower_gt_0 radix2).
clear -Hew ; omega.
apply bpow_gt_0.
-simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
case Zeq_bool_spec ; intros He2.
case_eq (x mod 2 ^ mw)%Z; try easy.
(* nan *)
@@ -403,39 +411,37 @@ apply Zdigits_le_Zpower. simpl.
rewrite <- Eqplx. edestruct Z_mod_lt; eauto.
change 2%Z with (radix_val radix2).
apply Z.lt_gt, Zpower_gt_0. omega.
-simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
case_eq (x mod 2^mw + 2^mw)%Z ; try easy.
-simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
(* normal *)
intros px Hm.
assert (prec = Zdigits radix2 (Zpos px)).
(* . *)
-rewrite Zdigits_ln_beta. 2: discriminate.
+rewrite Zdigits_mag. 2: discriminate.
apply sym_eq.
-apply ln_beta_unique.
-rewrite <- Z2R_abs.
-unfold Zabs.
+apply mag_unique.
+rewrite <- abs_IZR.
+unfold Z.abs.
replace (prec - 1)%Z with mw by ( unfold prec ; ring ).
-rewrite <- Z2R_Zpower with (1 := Zlt_le_weak _ _ Hmw).
-rewrite <- Z2R_Zpower. 2: now apply Zlt_le_weak.
+rewrite <- IZR_Zpower with (1 := Zlt_le_weak _ _ Hmw).
+rewrite <- IZR_Zpower. 2: now apply Zlt_le_weak.
rewrite <- Hm.
split.
-apply Z2R_le.
+apply IZR_le.
change (radix2^mw)%Z with (0 + 2^mw)%Z.
apply Zplus_le_compat_r.
eapply Z_mod_lt.
-now apply Zlt_gt.
-apply Z2R_lt.
+now apply Z.lt_gt.
+apply IZR_lt.
unfold prec.
-rewrite Zpower_exp. 2: now apply Zle_ge ; apply Zlt_le_weak. 2: discriminate.
+rewrite Zpower_exp. 2: now apply Z.le_ge ; apply Zlt_le_weak. 2: discriminate.
rewrite <- Zplus_diag_eq_mult_2.
apply Zplus_lt_compat_r.
eapply Z_mod_lt.
-now apply Zlt_gt.
+now apply Z.lt_gt.
(* . *)
-apply bounded_canonic_lt_emax ; try assumption.
-unfold canonic, canonic_exp.
-rewrite ln_beta_F2R_Zdigits. 2: discriminate.
+apply bounded_canonical_lt_emax ; try assumption.
+unfold canonical, cexp.
+rewrite mag_F2R_Zdigits. 2: discriminate.
unfold Fexp, FLT_exp.
rewrite <- H.
set (ex := ((x / 2^mw) mod 2^ew)%Z).
@@ -448,14 +454,14 @@ cut (0 <= ex)%Z.
unfold emin.
clear ; intros H1 H2 ; omega.
eapply Z_mod_lt.
-apply Zlt_gt.
+apply Z.lt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply Rnot_le_lt.
intros H0.
-refine (_ (ln_beta_le radix2 _ _ _ H0)).
-rewrite ln_beta_bpow.
-rewrite ln_beta_F2R_Zdigits. 2: discriminate.
+refine (_ (mag_le radix2 _ _ _ H0)).
+rewrite mag_bpow.
+rewrite mag_F2R_Zdigits. 2: discriminate.
rewrite <- H.
apply Zlt_not_le.
unfold emin.
@@ -472,11 +478,10 @@ apply refl_equal.
discriminate.
clear -Hew ; omega.
eapply Z_mod_lt.
-apply Zlt_gt.
+apply Z.lt_gt.
apply (Zpower_gt_0 radix2).
now apply Zlt_le_weak.
apply bpow_gt_0.
-simpl. intros. rewrite Z.ltb_lt. unfold prec. zify; omega.
Qed.
Definition binary_float_of_bits x :=
@@ -492,7 +497,7 @@ unfold binary_float_of_bits.
rewrite B2FF_FF2B.
unfold binary_float_of_bits_aux.
rewrite split_bits_of_binary_float_correct.
-destruct x as [sx|sx|sx [plx Hplx]|sx mx ex Bx].
+destruct x as [sx|sx|sx plx Hplx|sx mx ex Bx].
apply refl_equal.
(* *)
simpl.
@@ -563,7 +568,7 @@ intros (sx, mx) ex Sx.
assert (Bm: (0 <= mx < 2^mw)%Z).
inversion_clear Sx.
apply Z_mod_lt.
-now apply Zlt_gt.
+now apply Z.lt_gt.
case Zeq_bool_spec ; intros He1.
(* subnormal *)
case_eq mx.
@@ -604,41 +609,47 @@ End Binary_Bits.
(** Specialization for IEEE single precision operations *)
Section B32_Bits.
-Arguments B754_nan {prec emax} _ _.
+Arguments B754_nan {prec} {emax}.
Definition binary32 := binary_float 24 128.
Let Hprec : (0 < 24)%Z.
+Proof.
apply refl_equal.
Qed.
Let Hprec_emax : (24 < 128)%Z.
+Proof.
apply refl_equal.
Qed.
-Definition default_nan_pl32 : bool * nan_pl 24 :=
- (false, exist _ (iter_nat xO 22 xH) (refl_equal true)).
+Definition default_nan_pl32 : { nan : binary32 | is_nan 24 128 nan = true } :=
+ exist _ (@B754_nan 24 128 false (iter_nat xO 22 xH) (refl_equal true)) (refl_equal true).
-Definition unop_nan_pl32 (f : binary32) : bool * nan_pl 24 :=
- match f with
- | B754_nan s pl => (s, pl)
+Definition unop_nan_pl32 (f : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
+ match f as f with
+ | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
| _ => default_nan_pl32
end.
-Definition binop_nan_pl32 (f1 f2 : binary32) : bool * nan_pl 24 :=
+Definition binop_nan_pl32 (f1 f2 : binary32) : { nan : binary32 | is_nan 24 128 nan = true } :=
match f1, f2 with
- | B754_nan s1 pl1, _ => (s1, pl1)
- | _, B754_nan s2 pl2 => (s2, pl2)
+ | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
+ | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
| _, _ => default_nan_pl32
end.
-Definition b32_opp := Bopp 24 128 pair.
-Definition b32_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl32.
-Definition b32_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl32.
-Definition b32_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl32.
-Definition b32_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32.
-Definition b32_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32.
+Definition b32_erase : binary32 -> binary32 := erase 24 128.
+Definition b32_opp : binary32 -> binary32 := Bopp 24 128 unop_nan_pl32.
+Definition b32_abs : binary32 -> binary32 := Babs 24 128 unop_nan_pl32.
+Definition b32_sqrt : mode -> binary32 -> binary32 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl32.
+
+Definition b32_plus : mode -> binary32 -> binary32 -> binary32 := Bplus _ _ Hprec Hprec_emax binop_nan_pl32.
+Definition b32_minus : mode -> binary32 -> binary32 -> binary32 := Bminus _ _ Hprec Hprec_emax binop_nan_pl32.
+Definition b32_mult : mode -> binary32 -> binary32 -> binary32 := Bmult _ _ Hprec Hprec_emax binop_nan_pl32.
+Definition b32_div : mode -> binary32 -> binary32 -> binary32 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl32.
+Definition b32_compare : binary32 -> binary32 -> option comparison := Bcompare 24 128.
Definition b32_of_bits : Z -> binary32 := binary_float_of_bits 23 8 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b32 : binary32 -> Z := bits_of_binary_float 23 8.
@@ -647,41 +658,47 @@ End B32_Bits.
(** Specialization for IEEE double precision operations *)
Section B64_Bits.
-Arguments B754_nan {prec emax} _ _.
+Arguments B754_nan {prec} {emax}.
Definition binary64 := binary_float 53 1024.
Let Hprec : (0 < 53)%Z.
+Proof.
apply refl_equal.
Qed.
Let Hprec_emax : (53 < 1024)%Z.
+Proof.
apply refl_equal.
Qed.
-Definition default_nan_pl64 : bool * nan_pl 53 :=
- (false, exist _ (iter_nat xO 51 xH) (refl_equal true)).
+Definition default_nan_pl64 : { nan : binary64 | is_nan 53 1024 nan = true } :=
+ exist _ (@B754_nan 53 1024 false (iter_nat xO 51 xH) (refl_equal true)) (refl_equal true).
-Definition unop_nan_pl64 (f : binary64) : bool * nan_pl 53 :=
- match f with
- | B754_nan s pl => (s, pl)
+Definition unop_nan_pl64 (f : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
+ match f as f with
+ | B754_nan s pl Hpl => exist _ (B754_nan s pl Hpl) (refl_equal true)
| _ => default_nan_pl64
end.
-Definition binop_nan_pl64 (pl1 pl2 : binary64) : bool * nan_pl 53 :=
- match pl1, pl2 with
- | B754_nan s1 pl1, _ => (s1, pl1)
- | _, B754_nan s2 pl2 => (s2, pl2)
+Definition binop_nan_pl64 (f1 f2 : binary64) : { nan : binary64 | is_nan 53 1024 nan = true } :=
+ match f1, f2 with
+ | B754_nan s1 pl1 Hpl1, _ => exist _ (B754_nan s1 pl1 Hpl1) (refl_equal true)
+ | _, B754_nan s2 pl2 Hpl2 => exist _ (B754_nan s2 pl2 Hpl2) (refl_equal true)
| _, _ => default_nan_pl64
end.
-Definition b64_opp := Bopp 53 1024 pair.
-Definition b64_plus := Bplus _ _ Hprec Hprec_emax binop_nan_pl64.
-Definition b64_minus := Bminus _ _ Hprec Hprec_emax binop_nan_pl64.
-Definition b64_mult := Bmult _ _ Hprec Hprec_emax binop_nan_pl64.
-Definition b64_div := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64.
-Definition b64_sqrt := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.
+Definition b64_erase : binary64 -> binary64 := erase 53 1024.
+Definition b64_opp : binary64 -> binary64 := Bopp 53 1024 unop_nan_pl64.
+Definition b64_abs : binary64 -> binary64 := Babs 53 1024 unop_nan_pl64.
+Definition b64_sqrt : mode -> binary64 -> binary64 := Bsqrt _ _ Hprec Hprec_emax unop_nan_pl64.
+
+Definition b64_plus : mode -> binary64 -> binary64 -> binary64 := Bplus _ _ Hprec Hprec_emax binop_nan_pl64.
+Definition b64_minus : mode -> binary64 -> binary64 -> binary64 := Bminus _ _ Hprec Hprec_emax binop_nan_pl64.
+Definition b64_mult : mode -> binary64 -> binary64 -> binary64 := Bmult _ _ Hprec Hprec_emax binop_nan_pl64.
+Definition b64_div : mode -> binary64 -> binary64 -> binary64 := Bdiv _ _ Hprec Hprec_emax binop_nan_pl64.
+Definition b64_compare : binary64 -> binary64 -> option comparison := Bcompare 53 1024.
Definition b64_of_bits : Z -> binary64 := binary_float_of_bits 52 11 (refl_equal _) (refl_equal _) (refl_equal _).
Definition bits_of_b64 : binary64 -> Z := bits_of_binary_float 52 11.
diff --git a/flocq/Prop/Div_sqrt_error.v b/flocq/Prop/Div_sqrt_error.v
new file mode 100644
index 00000000..79220438
--- /dev/null
+++ b/flocq/Prop/Div_sqrt_error.v
@@ -0,0 +1,872 @@
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2010-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2010-2018 Guillaume Melquiond
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
+
+(** * Remainder of the division and square root are in the FLX format *)
+
+Require Import Psatz.
+Require Import Core Operations Relative Sterbenz Mult_error.
+
+Section Fprop_divsqrt_error.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable prec : Z.
+
+Lemma generic_format_plus_prec :
+ forall fexp, (forall e, (fexp e <= e - prec)%Z) ->
+ forall x y (fx fy: float beta),
+ (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R ->
+ (Rabs (x+y) < bpow (prec+Fexp fy))%R ->
+ generic_format beta fexp (x+y)%R.
+Proof.
+intros fexp Hfexp x y fx fy Hx Hy H1 H2.
+case (Req_dec (x+y) 0); intros H.
+rewrite H; apply generic_format_0.
+rewrite Hx, Hy, <- F2R_plus.
+apply generic_format_F2R.
+intros _.
+case_eq (Fplus fx fy).
+intros mz ez Hz.
+rewrite <- Hz.
+apply Z.le_trans with (Z.min (Fexp fx) (Fexp fy)).
+rewrite F2R_plus, <- Hx, <- Hy.
+unfold cexp.
+apply Z.le_trans with (1:=Hfexp _).
+apply Zplus_le_reg_l with prec; ring_simplify.
+apply mag_le_bpow with (1 := H).
+now apply Z.min_case.
+rewrite <- Fexp_Fplus, Hz.
+apply Z.le_refl.
+Qed.
+
+Context { prec_gt_0_ : Prec_gt_0 prec }.
+
+Notation format := (generic_format beta (FLX_exp prec)).
+Notation cexp := (cexp beta (FLX_exp prec)).
+
+Variable choice : Z -> bool.
+
+
+(** Remainder of the division in FLX *)
+Theorem div_error_FLX :
+ forall rnd { Zrnd : Valid_rnd rnd } x y,
+ format x -> format y ->
+ format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R.
+Proof with auto with typeclass_instances.
+intros rnd Zrnd x y Hx Hy.
+destruct (Req_dec y 0) as [Zy|Zy].
+now rewrite Zy, Rmult_0_r, Rminus_0_r.
+destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr].
+rewrite Hr; ring_simplify (x-0*y)%R; assumption.
+assert (Zx: x <> R0).
+contradict Hr.
+rewrite Hr.
+unfold Rdiv.
+now rewrite Rmult_0_l, round_0.
+destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)).
+destruct (canonical_generic_format _ _ y Hy) as (fy,(Hy1,Hy2)).
+destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)).
+apply generic_format_round...
+unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fy)); trivial.
+intros e; apply Z.le_refl.
+now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1.
+(* *)
+destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)).
+rewrite Heps2.
+rewrite <- Rabs_Ropp.
+replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field.
+rewrite Rabs_mult.
+apply Rlt_le_trans with (Rabs x * 1)%R.
+apply Rmult_lt_compat_l.
+now apply Rabs_pos_lt.
+apply Rlt_le_trans with (1 := Heps1).
+change 1%R with (bpow 0).
+apply bpow_le.
+generalize (prec_gt_0 prec).
+clear ; omega.
+rewrite Rmult_1_r.
+rewrite Hx2, <- Hx1.
+unfold cexp.
+destruct (mag beta x) as (ex, Hex).
+simpl.
+specialize (Hex Zx).
+apply Rlt_le.
+apply Rlt_le_trans with (1 := proj2 Hex).
+apply bpow_le.
+unfold FLX_exp.
+ring_simplify.
+apply Z.le_refl.
+(* *)
+replace (Fexp (Fopp (Fmult fr fy))) with (Fexp fr + Fexp fy)%Z.
+2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl.
+replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with
+ (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R.
+2: field; assumption.
+rewrite Rabs_mult.
+apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R.
+apply Rmult_lt_compat_l.
+now apply Rabs_pos_lt.
+rewrite Rabs_Ropp.
+replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)).
+rewrite <- Hr1.
+apply error_lt_ulp_round...
+apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption.
+rewrite ulp_neq_0.
+2: now rewrite <- Hr1.
+apply f_equal.
+now rewrite Hr2, <- Hr1.
+replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring.
+rewrite bpow_plus.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+rewrite Hy2, <- Hy1 ; unfold cexp, FLX_exp.
+ring_simplify (prec + (mag beta y - prec))%Z.
+destruct (mag beta y); simpl.
+left; now apply a.
+Qed.
+
+(** Remainder of the square in FLX (with p>1) and rounding to nearest *)
+Variable Hp1 : Z.lt 1 prec.
+
+Theorem sqrt_error_FLX_N :
+ forall x, format x ->
+ format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R.
+Proof with auto with typeclass_instances.
+intros x Hx.
+destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz].
+unfold sqrt.
+destruct (Rcase_abs x).
+rewrite round_0...
+unfold Rsqr.
+now rewrite Rmult_0_l, Rminus_0_r.
+elim (Rlt_irrefl 0).
+now apply Rgt_ge_trans with x.
+rewrite Hxz, sqrt_0, round_0...
+unfold Rsqr.
+rewrite Rmult_0_l, Rminus_0_r.
+apply generic_format_0.
+case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr.
+rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption.
+destruct (canonical_generic_format _ _ x Hx) as (fx,(Hx1,Hx2)).
+destruct (canonical_generic_format beta (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)).
+apply generic_format_round...
+unfold Rminus; apply generic_format_plus_prec with fx (Fopp (Fmult fr fr)); trivial.
+intros e; apply Z.le_refl.
+unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1.
+(* *)
+apply Rle_lt_trans with x.
+apply Rabs_minus_le.
+apply Rle_0_sqr.
+destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)).
+rewrite Heps2.
+rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le.
+apply Rmult_le_compat_r.
+now apply Rlt_le.
+apply Rle_trans with (5²/4²)%R.
+rewrite <- Rsqr_div.
+apply Rsqr_le_abs_1.
+apply Rle_trans with (1 := Rabs_triang _ _).
+rewrite Rabs_R1.
+apply Rplus_le_reg_l with (-1)%R.
+replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring.
+apply Rle_trans with (1 := Heps1).
+rewrite Rabs_pos_eq.
+apply Rmult_le_reg_l with 2%R.
+now apply IZR_lt.
+rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
+apply Rle_trans with (bpow (-1)).
+apply bpow_le.
+omega.
+replace (2 * (-1 + 5 / 4))%R with (/2)%R by field.
+apply Rinv_le.
+now apply IZR_lt.
+apply IZR_le.
+unfold Zpower_pos. simpl.
+rewrite Zmult_1_r.
+apply Zle_bool_imp_le.
+apply beta.
+now apply IZR_neq.
+unfold Rdiv.
+apply Rmult_le_pos.
+now apply IZR_le.
+apply Rlt_le.
+apply Rinv_0_lt_compat.
+now apply IZR_lt.
+now apply IZR_neq.
+unfold Rsqr.
+replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field.
+apply Rmult_le_reg_r with 16%R.
+now apply IZR_lt.
+rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
+now apply (IZR_le _ 32).
+now apply IZR_neq.
+rewrite Hx2, <- Hx1; unfold cexp, FLX_exp.
+ring_simplify (prec + (mag beta x - prec))%Z.
+destruct (mag beta x); simpl.
+rewrite <- (Rabs_right x).
+apply a.
+now apply Rgt_not_eq.
+now apply Rgt_ge.
+(* *)
+replace (Fexp (Fopp (Fmult fr fr))) with (Fexp fr + Fexp fr)%Z.
+2: unfold Fopp, Fmult; destruct fr; now simpl.
+rewrite Hr1.
+replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R.
+2: rewrite <- (sqrt_sqrt x) at 3; auto.
+2: unfold Rsqr; ring.
+rewrite Rabs_Ropp, Rabs_mult.
+apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R.
+apply Rmult_le_compat_r.
+apply Rabs_pos.
+apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R.
+rewrite <- Hr1.
+apply error_le_half_ulp_round...
+right; rewrite ulp_neq_0.
+2: now rewrite <- Hr1.
+apply f_equal.
+rewrite Hr2, <- Hr1; trivial.
+rewrite Rmult_assoc, Rmult_comm.
+replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring.
+rewrite bpow_plus, Rmult_assoc.
+apply Rmult_lt_compat_l.
+apply bpow_gt_0.
+apply Rmult_lt_reg_l with (1 := Rlt_0_2).
+apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)).
+right; field.
+apply Rle_lt_trans with (1:=Rabs_triang _ _).
+(* . *)
+assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R.
+rewrite Hr2.
+unfold cexp, FLX_exp.
+ring_simplify (prec + (mag beta (F2R fr) - prec))%Z.
+destruct (mag beta (F2R fr)); simpl.
+apply a.
+rewrite <- Hr1; auto.
+(* . *)
+apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R.
+now apply Rplus_lt_compat_r.
+(* . *)
+replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring.
+apply Rplus_le_compat_l.
+assert (sqrt x <> 0)%R.
+apply Rgt_not_eq.
+now apply sqrt_lt_R0.
+destruct (mag beta (sqrt x)) as (es,Es).
+specialize (Es H0).
+apply Rle_trans with (bpow es).
+now apply Rlt_le.
+apply bpow_le.
+case (Zle_or_lt es (prec + Fexp fr)) ; trivial.
+intros H1.
+absurd (Rabs (F2R fr) < bpow (es - 1))%R.
+apply Rle_not_lt.
+rewrite <- Hr1.
+apply abs_round_ge_generic...
+apply generic_format_bpow.
+unfold FLX_exp; omega.
+apply Es.
+apply Rlt_le_trans with (1:=H).
+apply bpow_le.
+omega.
+now apply Rlt_le.
+Qed.
+
+Lemma sqrt_error_N_FLX_aux1 x (Fx : format x) (Px : (0 < x)%R) :
+ exists (mu : R) (e : Z), (format mu /\ x = mu * bpow (2 * e) :> R
+ /\ 1 <= mu < bpow 2)%R.
+Proof.
+set (e := ((mag beta x - 1) / 2)%Z).
+set (mu := (x * bpow (-2 * e)%Z)%R).
+assert (Hbe : (bpow (-2 * e) * bpow (2 * e) = 1)%R).
+{ now rewrite <- bpow_plus; case e; simpl; [reflexivity| |]; intro p;
+ rewrite Z.pos_sub_diag. }
+assert (Fmu : format mu); [now apply mult_bpow_exact_FLX|].
+exists mu, e; split; [exact Fmu|split; [|split]].
+{ set (e2 := (2 * e)%Z); simpl; unfold mu; rewrite Rmult_assoc.
+ now unfold e2; rewrite Hbe, Rmult_1_r. }
+{ apply (Rmult_le_reg_r (bpow (2 * e))).
+ { apply bpow_gt_0. }
+ rewrite Rmult_1_l; set (e2 := (2 * e)%Z); simpl; unfold mu.
+ unfold e2; rewrite Rmult_assoc, Hbe, Rmult_1_r.
+ apply (Rle_trans _ (bpow (mag beta x - 1))).
+ { now apply bpow_le; unfold e; apply Z_mult_div_ge. }
+ set (l := mag _ _); rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)).
+ unfold l; apply bpow_mag_le.
+ intro Hx; revert Px; rewrite Hx; apply Rlt_irrefl. }
+simpl; unfold mu; change (IZR _) with (bpow 2).
+apply (Rmult_lt_reg_r (bpow (2 * e))); [now apply bpow_gt_0|].
+rewrite Rmult_assoc, Hbe, Rmult_1_r.
+apply (Rlt_le_trans _ (bpow (mag beta x))).
+{ rewrite <- (Rabs_pos_eq _ (Rlt_le _ _ Px)) at 1; apply bpow_mag_gt. }
+rewrite <- bpow_plus; apply bpow_le; unfold e; set (mxm1 := (_ - 1)%Z).
+replace (_ * _)%Z with (2 * (mxm1 / 2) + mxm1 mod 2 - mxm1 mod 2)%Z by ring.
+rewrite <- Z.div_mod; [|now simpl].
+apply (Zplus_le_reg_r _ _ (mxm1 mod 2 - mag beta x)%Z).
+unfold mxm1; destruct (Z.mod_bound_or (mag beta x - 1) 2); omega.
+Qed.
+
+Notation u_ro := (u_ro beta prec).
+
+Lemma sqrt_error_N_FLX_aux2 x (Fx : format x) :
+ (1 <= x)%R ->
+ (x = 1 :> R \/ x = 1 + 2 * u_ro :> R \/ 1 + 4 * u_ro <= x)%R.
+Proof.
+intro HxGe1.
+assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|].
+destruct (Rle_or_lt x 1) as [HxLe1|HxGt1]; [now left; apply Rle_antisym|right].
+assert (F1 : format 1); [now apply generic_format_FLX_1|].
+assert (H2eps : (2 * u_ro = bpow (-prec + 1))%R).
+{ unfold u_ro; rewrite bpow_plus; field. }
+assert (HmuGe1p2eps : (1 + 2 * u_ro <= x)%R).
+{ rewrite H2eps, <- succ_FLX_1.
+ now apply succ_le_lt; [now apply FLX_exp_valid| | |]. }
+destruct (Rle_or_lt x (1 + 2 * u_ro)) as [HxLe1p2eps|HxGt1p2eps];
+ [now left; apply Rle_antisym|right].
+assert (Hulp1p2eps : (ulp beta (FLX_exp prec) (1 + 2 * u_ro) = 2 * u_ro)%R).
+{ destruct (ulp_succ_pos _ _ _ F1 Rlt_0_1) as [Hsucc|Hsucc].
+ { now rewrite H2eps, <- succ_FLX_1, <- ulp_FLX_1. }
+ exfalso; revert Hsucc; apply Rlt_not_eq.
+ rewrite succ_FLX_1, mag_1, bpow_1, <- H2eps; simpl.
+ apply (Rlt_le_trans _ 2); [apply Rplus_lt_compat_l|].
+ { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l; [|lra].
+ change R1 with (bpow 0); apply bpow_lt; omega. }
+ apply IZR_le, Zle_bool_imp_le, radix_prop. }
+assert (Hsucc1p2eps :
+ (succ beta (FLX_exp prec) (1 + 2 * u_ro) = 1 + 4 * u_ro)%R).
+{ unfold succ; rewrite Rle_bool_true; [rewrite Hulp1p2eps; ring|].
+ apply Rplus_le_le_0_compat; lra. }
+rewrite <- Hsucc1p2eps.
+apply succ_le_lt; [now apply FLX_exp_valid| |exact Fx|now simpl].
+rewrite H2eps, <- succ_FLX_1.
+now apply generic_format_succ; [apply FLX_exp_valid|].
+Qed.
+
+Lemma sqrt_error_N_FLX_aux3 :
+ (u_ro / sqrt (1 + 4 * u_ro) <= 1 - 1 / sqrt (1 + 2 * u_ro))%R.
+Proof.
+assert (Pu_ro : (0 <= u_ro)%R); [apply Rmult_le_pos; [lra|apply bpow_ge_0]|].
+unfold Rdiv; apply (Rplus_le_reg_r (/ sqrt (1 + 2 * u_ro))); ring_simplify.
+apply (Rmult_le_reg_r (sqrt (1 + 4 * u_ro) * sqrt (1 + 2 * u_ro))).
+{ apply Rmult_lt_0_compat; apply sqrt_lt_R0; lra. }
+field_simplify; [|split; apply Rgt_not_eq, Rlt_gt, sqrt_lt_R0; lra].
+try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r.
+apply Rsqr_incr_0_var; [|now apply Rmult_le_pos; apply sqrt_pos].
+rewrite <-sqrt_mult; [|lra|lra].
+rewrite Rsqr_sqrt; [|apply Rmult_le_pos; lra].
+unfold Rsqr; ring_simplify; unfold pow; rewrite !Rmult_1_r.
+rewrite !sqrt_def; [|lra|lra].
+apply (Rplus_le_reg_r (-u_ro * u_ro - 1 -4 * u_ro - 2 * u_ro ^ 3)).
+ring_simplify; apply Rsqr_incr_0_var.
+{ unfold Rsqr; ring_simplify.
+ unfold pow; rewrite !Rmult_1_r, !sqrt_def; [|lra|lra].
+ apply (Rplus_le_reg_r (-32 * u_ro ^ 4 - 24 * u_ro ^ 3 - 4 * u_ro ^ 2)).
+ ring_simplify.
+ replace (_ + _)%R
+ with (((4 * u_ro ^ 2 - 28 * u_ro + 9) * u_ro + 4) * u_ro ^ 3)%R by ring.
+ apply Rmult_le_pos; [|now apply pow_le].
+ assert (Heps_le_half : (u_ro <= 1 / 2)%R).
+ { unfold u_ro, Rdiv; rewrite Rmult_comm; apply Rmult_le_compat_r; [lra|].
+ change 1%R with (bpow 0); apply bpow_le; omega. }
+ apply (Rle_trans _ (-8 * u_ro + 4)); [lra|].
+ apply Rplus_le_compat_r, Rmult_le_compat_r; [apply Pu_ro|].
+ now assert (H : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra]. }
+assert (H : (u_ro ^ 3 <= u_ro ^ 2)%R).
+{ unfold pow; rewrite <-!Rmult_assoc, Rmult_1_r.
+ apply Rmult_le_compat_l; [now apply Rmult_le_pos; apply Pu_ro|].
+ now apply Rlt_le, u_ro_lt_1. }
+now assert (H' : (0 <= u_ro ^ 2)%R); [apply pow2_ge_0|lra].
+Qed.
+
+Lemma om1ds1p2u_ro_pos : (0 <= 1 - 1 / sqrt (1 + 2 * u_ro))%R.
+Proof.
+unfold Rdiv; rewrite Rmult_1_l, <-Rinv_1 at 1.
+apply Rle_0_minus, Rinv_le; [lra|].
+rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt.
+assert (H := u_ro_pos beta prec); lra.
+Qed.
+
+Lemma om1ds1p2u_ro_le_u_rod1pu_ro :
+ (1 - 1 / sqrt (1 + 2 * u_ro) <= u_ro / (1 + u_ro))%R.
+Proof.
+assert (Pu_ro := u_ro_pos beta prec).
+apply (Rmult_le_reg_r (sqrt (1 + 2 * u_ro) * (1 + u_ro))).
+{ apply Rmult_lt_0_compat; [apply sqrt_lt_R0|]; lra. }
+field_simplify; [|lra|intro H; apply sqrt_eq_0 in H; lra].
+try unfold Rdiv; unfold Rminus; rewrite ?Rinv_1, ?Rmult_1_r, !Rplus_assoc.
+rewrite <-(Rplus_0_r (sqrt _ * _)) at 2; apply Rplus_le_compat_l.
+apply (Rplus_le_reg_r (1 + u_ro)); ring_simplify.
+rewrite <-(sqrt_square (_ + 1)); [|lra]; apply sqrt_le_1_alt.
+assert (H : (0 <= u_ro * u_ro)%R); [apply Rmult_le_pos|]; lra.
+Qed.
+
+Lemma s1p2u_rom1_pos : (0 <= sqrt (1 + 2 * u_ro) - 1)%R.
+apply (Rplus_le_reg_r 1); ring_simplify.
+rewrite <-sqrt_1 at 1; apply sqrt_le_1_alt.
+assert (H := u_ro_pos beta prec); lra.
+Qed.
+
+Theorem sqrt_error_N_FLX x (Fx : format x) :
+ (Rabs (round beta (FLX_exp prec) (Znearest choice) (sqrt x) - sqrt x)
+ <= (1 - 1 / sqrt (1 + 2 * u_ro)) * Rabs (sqrt x))%R.
+Proof.
+assert (Peps := u_ro_pos beta prec).
+assert (Peps' : (0 < u_ro)%R).
+{ unfold u_ro; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. }
+assert (Pb := om1ds1p2u_ro_pos).
+assert (Pb' := s1p2u_rom1_pos).
+destruct (Rle_or_lt x 0) as [Nx|Px].
+{ rewrite (sqrt_neg _ Nx), round_0, Rabs_R0, Rmult_0_r; [|apply valid_rnd_N].
+ now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
+destruct (sqrt_error_N_FLX_aux1 _ Fx Px)
+ as (mu, (e, (Fmu, (Hmu, (HmuGe1, HmuLtsqradix))))).
+pose (t := sqrt x).
+set (rt := round _ _ _ _).
+assert (Ht : (t = sqrt mu * bpow e)%R).
+{ unfold t; rewrite Hmu, sqrt_mult_alt; [|now apply (Rle_trans _ _ _ Rle_0_1)].
+ now rewrite sqrt_bpow. }
+destruct (sqrt_error_N_FLX_aux2 _ Fmu HmuGe1) as [Hmu'|[Hmu'|Hmu']].
+{ unfold rt; fold t; rewrite Ht, Hmu', sqrt_1, Rmult_1_l.
+ rewrite round_generic; [|now apply valid_rnd_N|].
+ { rewrite Rminus_diag_eq, Rabs_R0; [|now simpl].
+ now apply Rmult_le_pos; [|apply Rabs_pos]. }
+ apply generic_format_bpow'; [now apply FLX_exp_valid|].
+ unfold FLX_exp; omega. }
+{ assert (Hsqrtmu : (1 <= sqrt mu < 1 + u_ro)%R); [rewrite Hmu'; split|].
+ { rewrite <- sqrt_1 at 1; apply sqrt_le_1_alt; lra. }
+ { rewrite <- sqrt_square; [|lra]; apply sqrt_lt_1_alt; split; [lra|].
+ ring_simplify; assert (0 < u_ro ^ 2)%R; [apply pow_lt|]; lra. }
+ assert (Fbpowe : generic_format beta (FLX_exp prec) (bpow e)).
+ { apply generic_format_bpow; unfold FLX_exp; omega. }
+ assert (Hrt : rt = bpow e :> R).
+ { unfold rt; fold t; rewrite Ht; simpl; apply Rle_antisym.
+ { apply round_N_le_midp; [now apply FLX_exp_valid|exact Fbpowe|].
+ apply (Rlt_le_trans _ ((1 + u_ro) * bpow e)).
+ { now apply Rmult_lt_compat_r; [apply bpow_gt_0|]. }
+ unfold succ; rewrite Rle_bool_true; [|now apply bpow_ge_0].
+ rewrite ulp_bpow; unfold FLX_exp.
+ unfold Z.sub, u_ro; rewrite !bpow_plus; right; field. }
+ apply round_ge_generic;
+ [now apply FLX_exp_valid|now apply valid_rnd_N|exact Fbpowe|].
+ rewrite <- (Rmult_1_l (bpow _)) at 1.
+ now apply Rmult_le_compat_r; [apply bpow_ge_0|]. }
+ fold t; rewrite Hrt, Ht, Hmu', <-(Rabs_pos_eq _ Pb), <-Rabs_mult.
+ rewrite Rabs_minus_sym; right; f_equal; field; lra. }
+assert (Hsqrtmu : (1 + u_ro < sqrt mu)%R).
+{ apply (Rlt_le_trans _ (sqrt (1 + 4 * u_ro))); [|now apply sqrt_le_1_alt].
+ assert (P1peps : (0 <= 1 + u_ro)%R)
+ by now apply Rplus_le_le_0_compat; [lra|apply Peps].
+ rewrite <- (sqrt_square (1 + u_ro)); [|lra].
+ apply sqrt_lt_1_alt; split; [now apply Rmult_le_pos|].
+ apply (Rplus_lt_reg_r (-1 - 2 * u_ro)); ring_simplify; simpl.
+ rewrite Rmult_1_r; apply Rmult_lt_compat_r; [apply Peps'|].
+ now apply (Rlt_le_trans _ 1); [apply u_ro_lt_1|lra]. }
+assert (Hulpt : (ulp beta (FLX_exp prec) t = 2 * u_ro * bpow e)%R).
+{ unfold ulp; rewrite Req_bool_false; [|apply Rgt_not_eq, Rlt_gt].
+ { unfold u_ro; rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, <-bpow_plus; [|lra].
+ f_equal; unfold cexp, FLX_exp.
+ assert (Hmagt : (mag beta t = 1 + e :> Z)%Z).
+ { apply mag_unique.
+ unfold t; rewrite (Rabs_pos_eq _ (Rlt_le _ _ (sqrt_lt_R0 _ Px))).
+ fold t; split.
+ { rewrite Ht; replace (_ - _)%Z with e by ring.
+ rewrite <- (Rmult_1_l (bpow _)) at 1; apply Rmult_le_compat_r.
+ { apply bpow_ge_0. }
+ now rewrite <- sqrt_1; apply sqrt_le_1_alt. }
+ rewrite bpow_plus, bpow_1, Ht; simpl.
+ apply Rmult_lt_compat_r; [now apply bpow_gt_0|].
+ rewrite <- sqrt_square.
+ { apply sqrt_lt_1_alt; split; [lra|].
+ apply (Rlt_le_trans _ _ _ HmuLtsqradix); right.
+ now unfold bpow, Z.pow_pos; simpl; rewrite Zmult_1_r, mult_IZR. }
+ apply IZR_le, (Z.le_trans _ 2), Zle_bool_imp_le, radix_prop; omega. }
+ rewrite Hmagt; ring. }
+ rewrite Ht; apply Rmult_lt_0_compat; [|now apply bpow_gt_0].
+ now apply (Rlt_le_trans _ 1); [lra|rewrite <- sqrt_1; apply sqrt_le_1_alt]. }
+assert (Pt : (0 < t)%R).
+{ rewrite Ht; apply Rmult_lt_0_compat; [lra|apply bpow_gt_0]. }
+assert (H : (Rabs ((rt - sqrt x) / sqrt x)
+ <= 1 - 1 / sqrt (1 + 2 * u_ro))%R).
+{ unfold Rdiv; rewrite Rabs_mult, (Rabs_pos_eq (/ _));
+ [|now left; apply Rinv_0_lt_compat].
+ apply (Rle_trans _ ((u_ro * bpow e) / t)).
+ { unfold Rdiv; apply Rmult_le_compat_r; [now left; apply Rinv_0_lt_compat|].
+ apply (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _)).
+ fold t; rewrite Hulpt; right; field. }
+ apply (Rle_trans _ (u_ro / sqrt (1 + 4 * u_ro))).
+ { apply (Rle_trans _ (u_ro * bpow e / (sqrt (1 + 4 * u_ro) * bpow e))).
+ { unfold Rdiv; apply Rmult_le_compat_l;
+ [now apply Rmult_le_pos; [apply Peps|apply bpow_ge_0]|].
+ apply Rinv_le.
+ { apply Rmult_lt_0_compat; [apply sqrt_lt_R0; lra|apply bpow_gt_0]. }
+ now rewrite Ht; apply Rmult_le_compat_r;
+ [apply bpow_ge_0|apply sqrt_le_1_alt]. }
+ right; field; split; apply Rgt_not_eq, Rlt_gt;
+ [apply sqrt_lt_R0; lra|apply bpow_gt_0]. }
+ apply sqrt_error_N_FLX_aux3. }
+revert H; unfold Rdiv; rewrite Rabs_mult, Rabs_Rinv; [|fold t; lra]; intro H.
+apply (Rmult_le_reg_r (/ Rabs (sqrt x)));
+ [apply Rinv_0_lt_compat, Rabs_pos_lt; fold t; lra|].
+apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0;fold t|]; lra.
+Qed.
+
+Theorem sqrt_error_N_FLX_ex x (Fx : format x) :
+ exists eps,
+ (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\
+ round beta (FLX_exp prec) (Znearest choice) (sqrt x)
+ = (sqrt x * (1 + eps))%R.
+Proof.
+now apply relative_error_le_conversion;
+ [apply valid_rnd_N|apply om1ds1p2u_ro_pos|apply sqrt_error_N_FLX].
+Qed.
+
+Lemma sqrt_error_N_round_ex_derive :
+ forall x rx,
+ (exists eps,
+ (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\ rx = (x * (1 + eps))%R) ->
+ exists eps,
+ (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\ x = (rx * (1 + eps))%R.
+Proof.
+intros x rx (d, (Bd, Hd)).
+assert (H := Rabs_le_inv _ _ Bd).
+assert (H' := om1ds1p2u_ro_le_u_rod1pu_ro).
+assert (H'' := u_rod1pu_ro_le_u_ro beta prec).
+assert (H''' := u_ro_lt_1 beta prec prec_gt_0_).
+assert (Hpos := s1p2u_rom1_pos).
+destruct (Req_dec rx 0) as [Zfx|Nzfx].
+{ exists 0%R; split; [now rewrite Rabs_R0|].
+ rewrite Rplus_0_r, Rmult_1_r, Zfx; rewrite Zfx in Hd.
+ destruct (Rmult_integral _ _ (sym_eq Hd)); lra. }
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ now exfalso; revert Hd; rewrite Zx; rewrite Rmult_0_l. }
+set (d' := ((x - rx) / rx)%R).
+assert (Hd' : (Rabs d' <= sqrt (1 + 2 * u_ro) - 1)%R).
+{ unfold d'; rewrite Hd.
+ replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
+ unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
+ rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
+ apply (Rmult_le_reg_r (1 + d)); [lra|].
+ rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
+ apply (Rle_trans _ _ _ Bd).
+ apply (Rle_trans _ ((sqrt (1 + 2 * u_ro) - 1) * (1/sqrt (1 + 2 * u_ro))));
+ [right; field|apply Rmult_le_compat_l]; lra. }
+now exists d'; split; [exact Hd'|]; unfold d'; field.
+Qed.
+
+(** sqrt(1 + 2 u_ro) - 1 <= u_ro *)
+Theorem sqrt_error_N_FLX_round_ex :
+ forall x,
+ format x ->
+ exists eps,
+ (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\
+ sqrt x = (round beta (FLX_exp prec) (Znearest choice) (sqrt x) * (1 + eps))%R.
+Proof.
+now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLX_ex.
+Qed.
+
+Variable emin : Z.
+Hypothesis Hemin : (emin <= 2 * (1 - prec))%Z.
+
+Theorem sqrt_error_N_FLT_ex :
+ forall x,
+ generic_format beta (FLT_exp emin prec) x ->
+ exists eps,
+ (Rabs eps <= 1 - 1 / sqrt (1 + 2 * u_ro))%R /\
+ round beta (FLT_exp emin prec) (Znearest choice) (sqrt x)
+ = (sqrt x * (1 + eps))%R.
+Proof.
+intros x Fx.
+assert (Heps := u_ro_pos).
+assert (Pb := om1ds1p2u_ro_pos).
+destruct (Rle_or_lt x 0) as [Nx|Px].
+{ exists 0%R; split; [now rewrite Rabs_R0|].
+ now rewrite (sqrt_neg x Nx), round_0, Rmult_0_l; [|apply valid_rnd_N]. }
+assert (Fx' := generic_format_FLX_FLT _ _ _ _ Fx).
+destruct (sqrt_error_N_FLX_ex _ Fx') as (d, (Bd, Hd)).
+exists d; split; [exact Bd|]; rewrite <-Hd; apply round_FLT_FLX.
+apply (Rle_trans _ (bpow (emin / 2)%Z)).
+{ apply bpow_le, Z.div_le_lower_bound; lia. }
+apply (Rle_trans _ _ _ (sqrt_bpow_ge _ _)).
+rewrite Rabs_pos_eq; [|now apply sqrt_pos]; apply sqrt_le_1_alt.
+revert Fx; apply generic_format_ge_bpow; [|exact Px].
+intro e; unfold FLT_exp; apply Z.le_max_r.
+Qed.
+
+(** sqrt(1 + 2 u_ro) - 1 <= u_ro *)
+Theorem sqrt_error_N_FLT_round_ex :
+ forall x,
+ generic_format beta (FLT_exp emin prec) x ->
+ exists eps,
+ (Rabs eps <= sqrt (1 + 2 * u_ro) - 1)%R /\
+ sqrt x
+ = (round beta (FLT_exp emin prec) (Znearest choice) (sqrt x) * (1 + eps))%R.
+Proof.
+now intros x Fx; apply sqrt_error_N_round_ex_derive, sqrt_error_N_FLT_ex.
+Qed.
+
+End Fprop_divsqrt_error.
+
+Section format_REM_aux.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable fexp : Z -> Z.
+Context { valid_exp : Valid_exp fexp }.
+Context { monotone_exp : Monotone_exp fexp }.
+
+Variable rnd : R -> Z.
+Context { valid_rnd : Valid_rnd rnd }.
+
+Notation format := (generic_format beta fexp).
+
+Lemma format_REM_aux:
+ forall x y : R,
+ format x -> format y -> (0 <= x)%R -> (0 < y)%R ->
+ ((0 < x/y < /2)%R -> rnd (x/y) = 0%Z) ->
+ format (x - IZR (rnd (x/y))*y).
+Proof with auto with typeclass_instances.
+intros x y Fx Fy Hx Hy rnd_small.
+pose (n:=rnd (x / y)).
+assert (Hn:(IZR n = round beta (FIX_exp 0) rnd (x/y))%R).
+unfold round, FIX_exp, cexp, scaled_mantissa, F2R; simpl.
+now rewrite 2!Rmult_1_r.
+assert (H:(0 <= n)%Z).
+apply le_IZR; rewrite Hn; simpl.
+apply Rle_trans with (round beta (FIX_exp 0) rnd 0).
+right; apply sym_eq, round_0...
+apply round_le...
+apply Fourier_util.Rle_mult_inv_pos; assumption.
+case (Zle_lt_or_eq 0 n); try exact H.
+clear H; intros H.
+case (Zle_lt_or_eq 1 n).
+omega.
+clear H; intros H.
+set (ex := cexp beta fexp x).
+set (ey := cexp beta fexp y).
+set (mx := Ztrunc (scaled_mantissa beta fexp x)).
+set (my := Ztrunc (scaled_mantissa beta fexp y)).
+case (Zle_or_lt ey ex); intros Hexy.
+(* ey <= ex *)
+assert (H0:(x-IZR n *y = F2R (Float beta (mx*beta^(ex-ey) - n*my) ey))%R).
+unfold Rminus; rewrite Rplus_comm.
+replace (IZR n) with (F2R (Float beta n 0)).
+rewrite Fx, Fy.
+fold mx my ex ey.
+rewrite <- F2R_mult.
+rewrite <- F2R_opp.
+rewrite <- F2R_plus.
+unfold Fplus. simpl.
+rewrite Zle_imp_le_bool with (1 := Hexy).
+f_equal; f_equal; ring.
+unfold F2R; simpl; ring.
+fold n; rewrite H0.
+apply generic_format_F2R.
+rewrite <- H0; intros H3.
+apply monotone_exp.
+apply mag_le_abs.
+rewrite H0; apply F2R_neq_0; easy.
+apply Rmult_le_reg_l with (/Rabs y)%R.
+apply Rinv_0_lt_compat.
+apply Rabs_pos_lt.
+now apply Rgt_not_eq.
+rewrite Rinv_l.
+2: apply Rgt_not_eq, Rabs_pos_lt.
+2: now apply Rgt_not_eq.
+rewrite <- Rabs_Rinv.
+2: now apply Rgt_not_eq.
+rewrite <- Rabs_mult.
+replace (/y * (x - IZR n *y))%R with (-(IZR n - x/y))%R.
+rewrite Rabs_Ropp.
+rewrite Hn.
+apply Rle_trans with (1:= error_le_ulp beta (FIX_exp 0) _ _).
+rewrite ulp_FIX.
+simpl; apply Rle_refl.
+field.
+now apply Rgt_not_eq.
+(* ex < ey: impossible as 1 < n *)
+absurd (1 < n)%Z; try easy.
+apply Zle_not_lt.
+apply le_IZR; simpl; rewrite Hn.
+apply round_le_generic...
+apply generic_format_FIX.
+exists (Float beta 1 0); try easy.
+unfold F2R; simpl; ring.
+apply Rmult_le_reg_r with y; try easy.
+unfold Rdiv; rewrite Rmult_assoc.
+rewrite Rinv_l, Rmult_1_r, Rmult_1_l.
+2: now apply Rgt_not_eq.
+assert (mag beta x < mag beta y)%Z.
+case (Zle_or_lt (mag beta y) (mag beta x)); try easy.
+intros J; apply monotone_exp in J; clear -J Hexy.
+unfold ex, ey, cexp in Hexy; omega.
+left; apply lt_mag with beta; easy.
+(* n = 1 -> Sterbenz + rnd_small *)
+intros Hn'; fold n; rewrite <- Hn'.
+rewrite Rmult_1_l.
+case Hx; intros Hx'.
+assert (J:(0 < x/y)%R).
+apply Fourier_util.Rlt_mult_inv_pos; assumption.
+apply sterbenz...
+assert (H0:(Rabs (1 - x/y) < 1)%R).
+rewrite Hn', Hn.
+apply Rlt_le_trans with (ulp beta (FIX_exp 0) (round beta (FIX_exp 0) rnd (x / y)))%R.
+apply error_lt_ulp_round...
+now apply Rgt_not_eq.
+rewrite ulp_FIX.
+rewrite <- Hn, <- Hn'.
+apply Rle_refl.
+apply Rabs_lt_inv in H0.
+split; apply Rmult_le_reg_l with (/y)%R; try now apply Rinv_0_lt_compat.
+unfold Rdiv; rewrite <- Rmult_assoc.
+rewrite Rinv_l.
+2: now apply Rgt_not_eq.
+rewrite Rmult_1_l, Rmult_comm; fold (x/y)%R.
+case (Rle_or_lt (/2) (x/y)); try easy.
+intros K.
+elim Zlt_not_le with (1 := H).
+apply Zeq_le.
+apply rnd_small.
+now split.
+apply Ropp_le_cancel; apply Rplus_le_reg_l with 1%R.
+apply Rle_trans with (1-x/y)%R.
+2: right; unfold Rdiv; ring.
+left; apply Rle_lt_trans with (2:=proj1 H0).
+right; field.
+now apply Rgt_not_eq.
+rewrite <- Hx', Rminus_0_l.
+now apply generic_format_opp.
+(* n = 0 *)
+clear H; intros H; fold n; rewrite <- H.
+now rewrite Rmult_0_l, Rminus_0_r.
+Qed.
+
+End format_REM_aux.
+
+Section format_REM.
+
+Variable beta : radix.
+Notation bpow e := (bpow beta e).
+
+Variable fexp : Z -> Z.
+Context { valid_exp : Valid_exp fexp }.
+Context { monotone_exp : Monotone_exp fexp }.
+
+Notation format := (generic_format beta fexp).
+
+Theorem format_REM :
+ forall rnd : R -> Z, Valid_rnd rnd ->
+ forall x y : R,
+ ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) ->
+ format x -> format y ->
+ format (x - IZR (rnd (x/y)%R) * y).
+Proof with auto with typeclass_instances.
+(* assume 0 < y *)
+assert (H: forall rnd : R -> Z, Valid_rnd rnd ->
+ forall x y : R,
+ ((Rabs (x/y) < /2)%R -> rnd (x/y)%R = 0%Z) ->
+ format x -> format y -> (0 < y)%R ->
+ format (x - IZR (rnd (x/y)%R) * y)).
+intros rnd valid_rnd x y Hrnd Fx Fy Hy.
+case (Rle_or_lt 0 x); intros Hx.
+apply format_REM_aux; try easy.
+intros K.
+apply Hrnd.
+rewrite Rabs_pos_eq.
+apply K.
+apply Rlt_le, K.
+replace (x - IZR (rnd (x/y)) * y)%R with
+ (- (-x - IZR (Zrnd_opp rnd (-x/y)) * y))%R.
+apply generic_format_opp.
+apply format_REM_aux; try easy...
+now apply generic_format_opp.
+apply Ropp_le_cancel; rewrite Ropp_0, Ropp_involutive; now left.
+replace (- x / y)%R with (- (x/y))%R by (unfold Rdiv; ring).
+intros K.
+unfold Zrnd_opp.
+rewrite Ropp_involutive, Hrnd.
+easy.
+rewrite Rabs_left.
+apply K.
+apply Ropp_lt_cancel.
+now rewrite Ropp_0.
+unfold Zrnd_opp.
+replace (- (- x / y))%R with (x / y)%R by (unfold Rdiv; ring).
+rewrite opp_IZR.
+ring.
+(* *)
+intros rnd valid_rnd x y Hrnd Fx Fy.
+case (Rle_or_lt 0 y); intros Hy.
+destruct Hy as [Hy|Hy].
+now apply H.
+now rewrite <- Hy, Rmult_0_r, Rminus_0_r.
+replace (IZR (rnd (x/y)) * y)%R with
+ (IZR ((Zrnd_opp rnd) ((x / -y))) * -y)%R.
+apply H; try easy...
+replace (x / - y)%R with (- (x/y))%R.
+intros K.
+unfold Zrnd_opp.
+rewrite Ropp_involutive, Hrnd.
+easy.
+now rewrite <- Rabs_Ropp.
+field; now apply Rlt_not_eq.
+now apply generic_format_opp.
+apply Ropp_lt_cancel; now rewrite Ropp_0, Ropp_involutive.
+unfold Zrnd_opp.
+replace (- (x / - y))%R with (x/y)%R.
+rewrite opp_IZR.
+ring.
+field; now apply Rlt_not_eq.
+Qed.
+
+Theorem format_REM_ZR:
+ forall x y : R,
+ format x -> format y ->
+ format (x - IZR (Ztrunc (x/y)) * y).
+Proof with auto with typeclass_instances.
+intros x y Fx Fy.
+apply format_REM; try easy...
+intros K.
+apply Z.abs_0_iff.
+rewrite <- Ztrunc_abs.
+rewrite Ztrunc_floor by apply Rabs_pos.
+apply Zle_antisym.
+replace 0%Z with (Zfloor (/2)).
+apply Zfloor_le.
+now apply Rlt_le.
+apply Zfloor_imp.
+simpl ; lra.
+apply Zfloor_lub.
+apply Rabs_pos.
+Qed.
+
+Theorem format_REM_N :
+ forall choice,
+ forall x y : R,
+ format x -> format y ->
+ format (x - IZR (Znearest choice (x/y)) * y).
+Proof with auto with typeclass_instances.
+intros choice x y Fx Fy.
+apply format_REM; try easy...
+intros K.
+apply Znearest_imp.
+now rewrite Rminus_0_r.
+Qed.
+
+End format_REM.
diff --git a/flocq/Appli/Fappli_double_round.v b/flocq/Prop/Double_rounding.v
index 82f61da3..055409bb 100644
--- a/flocq/Appli/Fappli_double_round.v
+++ b/flocq/Prop/Double_rounding.v
@@ -1,13 +1,28 @@
-(** * Conditions for innocuous double rounding. *)
+(**
+This file is part of the Flocq formalization of floating-point
+arithmetic in Coq: http://flocq.gforge.inria.fr/
+
+Copyright (C) 2014-2018 Sylvie Boldo
+#<br />#
+Copyright (C) 2014-2018 Guillaume Melquiond
+#<br />#
+Copyright (C) 2014-2018 Pierre Roux
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 3 of the License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+COPYING file for more details.
+*)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_generic_fmt.
-Require Import Fcalc_ops.
-Require Import Fcore_ulp.
-Require Fcore_FLX Fcore_FLT Fcore_FTZ.
+(** * Conditions for innocuous double rounding. *)
Require Import Psatz.
+Require Import Raux Defs Generic_fmt Operations Ulp FLX FLT FTZ.
Open Scope R_scope.
@@ -15,9 +30,9 @@ Section Double_round.
Variable beta : radix.
Notation bpow e := (bpow beta e).
-Notation ln_beta x := (ln_beta beta x).
+Notation mag x := (mag beta x).
-Definition double_round_eq fexp1 fexp2 choice1 choice2 x :=
+Definition round_round_eq fexp1 fexp2 choice1 choice2 x :=
round beta fexp1 (Znearest choice1) (round beta fexp2 (Znearest choice2) x)
= round beta fexp1 (Znearest choice1) x.
@@ -26,22 +41,22 @@ Ltac bpow_simplify :=
(* bpow ex * bpow ey ~~> bpow (ex + ey) *)
repeat
match goal with
- | |- context [(Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] =>
+ | |- context [(Raux.bpow _ _ * Raux.bpow _ _)] =>
rewrite <- bpow_plus
- | |- context [(?X1 * Fcore_Raux.bpow _ _ * Fcore_Raux.bpow _ _)] =>
+ | |- context [(?X1 * Raux.bpow _ _ * Raux.bpow _ _)] =>
rewrite (Rmult_assoc X1); rewrite <- bpow_plus
- | |- context [(?X1 * (?X2 * Fcore_Raux.bpow _ _) * Fcore_Raux.bpow _ _)] =>
+ | |- context [(?X1 * (?X2 * Raux.bpow _ _) * Raux.bpow _ _)] =>
rewrite <- (Rmult_assoc X1 X2); rewrite (Rmult_assoc (X1 * X2));
rewrite <- bpow_plus
end;
(* ring_simplify arguments of bpow *)
repeat
match goal with
- | |- context [(Fcore_Raux.bpow _ ?X)] =>
+ | |- context [(Raux.bpow _ ?X)] =>
progress ring_simplify X
end;
(* bpow 0 ~~> 1 *)
- change (Fcore_Raux.bpow _ 0) with 1;
+ change (Raux.bpow _ 0) with 1;
repeat
match goal with
| |- context [(_ * 1)] =>
@@ -54,26 +69,26 @@ Definition midp (fexp : Z -> Z) (x : R) :=
Definition midp' (fexp : Z -> Z) (x : R) :=
round beta fexp Zceil x - / 2 * ulp beta fexp x.
-Lemma double_round_lt_mid_further_place' :
+Lemma round_round_lt_mid_further_place' :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ x < bpow (mag x) - / 2 * ulp beta fexp2 x ->
x < midp fexp1 x - / 2 * ulp beta fexp2 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hx1.
-unfold double_round_eq.
+unfold round_round_eq.
set (x' := round beta fexp1 Zfloor x).
intro Hx2'.
assert (Hx2 : x - round beta fexp1 Zfloor x
< / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)).
{ now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. }
set (x'' := round beta fexp2 (Znearest choice2) x).
-assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))).
+assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))).
apply Rle_trans with (/ 2 * ulp beta fexp2 x).
now unfold x''; apply error_le_half_ulp...
rewrite ulp_neq_0;[now right|now apply Rgt_not_eq].
@@ -82,12 +97,12 @@ assert (Pxx' : 0 <= x - x').
apply round_DN_pt.
exact Vfexp1. }
rewrite 2!ulp_neq_0 in Hx2; try (apply Rgt_not_eq; assumption).
-assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))).
+assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))).
{ replace (x'' - x') with (x'' - x + (x - x')) by ring.
apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
- replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x))
- + (/ 2 * (bpow (fexp1 (ln_beta x))
- - bpow (fexp2 (ln_beta x))))) by ring.
+ replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x))
+ + (/ 2 * (bpow (fexp1 (mag x))
+ - bpow (fexp2 (mag x))))) by ring.
apply Rplus_le_lt_compat.
- exact Hr1.
- now rewrite Rabs_right; [|now apply Rle_ge]; apply Hx2. }
@@ -95,9 +110,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
- (* x'' = 0 *)
rewrite Zx'' in Hr1 |- *.
rewrite round_0; [|now apply valid_rnd_N].
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r.
@@ -109,25 +124,25 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
apply bpow_lt.
omega.
- (* x'' <> 0 *)
- assert (Lx'' : ln_beta x'' = ln_beta x :> Z).
+ assert (Lx'' : mag x'' = mag x :> Z).
{ apply Zle_antisym.
- - apply ln_beta_le_bpow; [exact Nzx''|].
+ - apply mag_le_bpow; [exact Nzx''|].
replace x'' with (x'' - x + x) by ring.
apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
- replace (bpow _) with (/ 2 * bpow (fexp2 (ln_beta x))
- + (bpow (ln_beta x)
- - / 2 * bpow (fexp2 (ln_beta x)))) by ring.
+ replace (bpow _) with (/ 2 * bpow (fexp2 (mag x))
+ + (bpow (mag x)
+ - / 2 * bpow (fexp2 (mag x)))) by ring.
apply Rplus_le_lt_compat; [exact Hr1|].
rewrite ulp_neq_0 in Hx1;[idtac| now apply Rgt_not_eq].
now rewrite Rabs_right; [|apply Rle_ge; apply Rlt_le].
- unfold x'' in Nzx'' |- *.
- now apply ln_beta_round_ge; [|apply valid_rnd_N|]. }
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ now apply mag_round_ge; [|apply valid_rnd_N|]. }
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite Lx''.
rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))).
+ rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x)));
[reflexivity|].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -137,9 +152,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
rewrite Rabs_right; [|now apply Rle_ge].
apply (Rlt_le_trans _ _ _ Hx2).
apply Rmult_le_compat_l; [lra|].
- generalize (bpow_ge_0 beta (fexp2 (ln_beta x))).
- unfold ulp, canonic_exp; lra.
- + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ generalize (bpow_ge_0 beta (fexp2 (mag x))).
+ unfold ulp, cexp; lra.
+ + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -148,16 +163,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
now bpow_simplify.
Qed.
-Lemma double_round_lt_mid_further_place :
+Lemma round_round_lt_mid_further_place :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
x < midp fexp1 x - / 2 * ulp beta fexp2 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1.
intro Hx2'.
@@ -165,15 +180,15 @@ assert (Hx2 : x - round beta fexp1 Zfloor x
< / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)).
{ now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. }
revert Hx2.
-unfold double_round_eq.
+unfold round_round_eq.
set (x' := round beta fexp1 Zfloor x).
intro Hx2.
assert (Pxx' : 0 <= x - x').
{ apply Rle_0_minus.
apply round_DN_pt.
exact Vfexp1. }
-assert (x < bpow (ln_beta x) - / 2 * bpow (fexp2 (ln_beta x)));
- [|apply double_round_lt_mid_further_place'; try assumption]...
+assert (x < bpow (mag x) - / 2 * bpow (fexp2 (mag x)));
+ [|apply round_round_lt_mid_further_place'; try assumption]...
2: rewrite ulp_neq_0;[assumption|now apply Rgt_not_eq].
destruct (Req_dec x' 0) as [Zx'|Nzx'].
- (* x' = 0 *)
@@ -182,10 +197,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
rewrite Rmult_minus_distr_l.
rewrite 2!ulp_neq_0;[idtac|now apply Rgt_not_eq|now apply Rgt_not_eq].
apply Rplus_le_compat_r.
- apply (Rmult_le_reg_r (bpow (- ln_beta x))); [now apply bpow_gt_0|].
- unfold ulp, canonic_exp; bpow_simplify.
+ apply (Rmult_le_reg_r (bpow (- mag x))); [now apply bpow_gt_0|].
+ unfold ulp, cexp; bpow_simplify.
apply Rmult_le_reg_l with (1 := Rlt_0_2).
- replace (2 * (/ 2 * _)) with (bpow (fexp1 (ln_beta x) - ln_beta x)) by field.
+ replace (2 * (/ 2 * _)) with (bpow (fexp1 (mag x) - mag x)) by field.
apply Rle_trans with 1; [|lra].
change 1 with (bpow 0); apply bpow_le.
omega.
@@ -193,16 +208,16 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
assert (Px' : 0 < x').
{ assert (0 <= x'); [|lra].
unfold x'.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_0_l.
- unfold round, F2R, canonic_exp; simpl; bpow_simplify.
- change 0 with (Z2R 0); apply Z2R_le.
+ unfold round, F2R, cexp; simpl; bpow_simplify.
+ apply IZR_le.
apply Zfloor_lub.
rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le].
rewrite scaled_mantissa_abs.
apply Rabs_pos. }
- assert (Hx' : x' <= bpow (ln_beta x) - ulp beta fexp1 x).
+ assert (Hx' : x' <= bpow (mag x) - ulp beta fexp1 x).
{ apply (Rplus_le_reg_r (ulp beta fexp1 x)); ring_simplify.
rewrite <- ulp_DN.
- change (round _ _ _ _) with x'.
@@ -213,10 +228,10 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
+ apply Rle_lt_trans with x.
* now apply round_DN_pt.
* rewrite <- (Rabs_right x) at 1; [|now apply Rle_ge; apply Rlt_le].
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
- exact Vfexp1.
- - exact Px'. }
- fold (canonic_exp beta fexp2 x); fold (ulp beta fexp2 x).
+ - now apply Rlt_le. }
+ fold (cexp beta fexp2 x); fold (ulp beta fexp2 x).
assert (/ 2 * ulp beta fexp1 x <= ulp beta fexp1 x).
rewrite <- (Rmult_1_l (ulp _ _ _)) at 2.
apply Rmult_le_compat_r; [|lra].
@@ -227,39 +242,39 @@ destruct (Req_dec x' 0) as [Zx'|Nzx'].
lra.
Qed.
-Lemma double_round_lt_mid_same_place :
+Lemma round_round_lt_mid_same_place :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z ->
+ (fexp2 (mag x) = fexp1 (mag x))%Z ->
x < midp fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1.
intro Hx'.
assert (Hx : x - round beta fexp1 Zfloor x < / 2 * ulp beta fexp1 x).
{ now apply (Rplus_lt_reg_r (round beta fexp1 Zfloor x)); ring_simplify. }
revert Hx.
-unfold double_round_eq.
+unfold round_round_eq.
set (x' := round beta fexp1 Zfloor x).
intro Hx.
assert (Pxx' : 0 <= x - x').
{ apply Rle_0_minus.
apply round_DN_pt.
exact Vfexp1. }
-assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) -
- Z2R (Zfloor (x * bpow (- fexp1 (ln_beta x))))) < / 2).
-{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
- unfold scaled_mantissa, canonic_exp in Hx.
+assert (H : Rabs (x * bpow (- fexp1 (mag x)) -
+ IZR (Zfloor (x * bpow (- fexp1 (mag x))))) < / 2).
+{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
+ unfold scaled_mantissa, cexp in Hx.
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
rewrite Rmult_minus_distr_r.
bpow_simplify.
apply Rabs_lt.
- change (Z2R _ * _) with x'.
+ change (IZR _ * _) with x'.
split.
- apply Rlt_le_trans with 0; [|exact Pxx'].
rewrite <- Ropp_0.
@@ -269,55 +284,54 @@ assert (H : Rabs (x * bpow (- fexp1 (ln_beta x)) -
apply bpow_gt_0.
- rewrite ulp_neq_0 in Hx;try apply Rgt_not_eq; assumption. }
unfold round at 2.
-unfold F2R, scaled_mantissa, canonic_exp; simpl.
+unfold F2R, scaled_mantissa, cexp; simpl.
rewrite Hf2f1.
-rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x))).
-- rewrite round_generic.
- + unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
- now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (ln_beta x))))).
+rewrite (Znearest_imp _ _ (Zfloor (scaled_mantissa beta fexp1 x)) H).
+rewrite round_generic.
+ + unfold round, F2R, scaled_mantissa, cexp; simpl.
+ now rewrite (Znearest_imp _ _ (Zfloor (x * bpow (- fexp1 (mag x))))).
+ now apply valid_rnd_N.
- + fold (canonic_exp beta fexp1 x).
- change (Z2R _ * bpow _) with (round beta fexp1 Zfloor x).
+ + fold (cexp beta fexp1 x).
+ change (IZR _ * bpow _) with (round beta fexp1 Zfloor x).
apply generic_format_round.
exact Vfexp1.
now apply valid_rnd_DN.
-- now unfold scaled_mantissa, canonic_exp.
Qed.
-Lemma double_round_lt_mid :
+Lemma round_round_lt_mid :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x))%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
x < midp fexp1 x ->
- ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
+ ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
x < midp fexp1 x - / 2 * ulp beta fexp2 x) ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'.
-destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2'].
-- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *)
- assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|].
- now apply double_round_lt_mid_same_place.
-- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *)
- assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|].
+destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2'].
+- (* fexp1 (mag x) <= fexp2 (mag x) *)
+ assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|].
+ now apply round_round_lt_mid_same_place.
+- (* fexp2 (mag x) < fexp1 (mag x) *)
+ assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|].
generalize (Hx' Hf2''); intro Hx''.
- now apply double_round_lt_mid_further_place.
+ now apply round_round_lt_mid_further_place.
Qed.
-Lemma double_round_gt_mid_further_place' :
+Lemma round_round_gt_mid_further_place' :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- round beta fexp2 (Znearest choice2) x < bpow (ln_beta x) ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ round beta fexp2 (Znearest choice2) x < bpow (mag x) ->
midp' fexp1 x + / 2 * ulp beta fexp2 x < x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1.
intros Hx1 Hx2'.
@@ -327,11 +341,11 @@ assert (Hx2 : round beta fexp1 Zceil x - x
+ / 2 * ulp beta fexp2 x)); ring_simplify.
now unfold midp' in Hx2'. }
revert Hx1 Hx2.
-unfold double_round_eq.
+unfold round_round_eq.
set (x' := round beta fexp1 Zceil x).
set (x'' := round beta fexp2 (Znearest choice2) x).
intros Hx1 Hx2.
-assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (ln_beta x))).
+assert (Hr1 : Rabs (x'' - x) <= / 2 * bpow (fexp2 (mag x))).
apply Rle_trans with (/2* ulp beta fexp2 x).
now unfold x''; apply error_le_half_ulp...
rewrite ulp_neq_0;[now right|now apply Rgt_not_eq].
@@ -339,12 +353,12 @@ assert (Px'x : 0 <= x' - x).
{ apply Rle_0_minus.
apply round_UP_pt.
exact Vfexp1. }
-assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (ln_beta x))).
+assert (Hr2 : Rabs (x'' - x') < / 2 * bpow (fexp1 (mag x))).
{ replace (x'' - x') with (x'' - x + (x - x')) by ring.
apply (Rle_lt_trans _ _ _ (Rabs_triang _ _)).
- replace (/ 2 * _) with (/ 2 * bpow (fexp2 (ln_beta x))
- + (/ 2 * (bpow (fexp1 (ln_beta x))
- - bpow (fexp2 (ln_beta x))))) by ring.
+ replace (/ 2 * _) with (/ 2 * bpow (fexp2 (mag x))
+ + (/ 2 * (bpow (fexp1 (mag x))
+ - bpow (fexp2 (mag x))))) by ring.
apply Rplus_le_lt_compat.
- exact Hr1.
- rewrite Rabs_minus_sym.
@@ -354,9 +368,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
- (* x'' = 0 *)
rewrite Zx'' in Hr1 |- *.
rewrite round_0; [|now apply valid_rnd_N].
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite (Znearest_imp _ _ 0); [now simpl; rewrite Rmult_0_l|].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult; rewrite Rmult_minus_distr_r.
@@ -368,9 +382,9 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
apply bpow_lt.
omega.
- (* x'' <> 0 *)
- assert (Lx'' : ln_beta x'' = ln_beta x :> Z).
+ assert (Lx'' : mag x'' = mag x :> Z).
{ apply Zle_antisym.
- - apply ln_beta_le_bpow; [exact Nzx''|].
+ - apply mag_le_bpow; [exact Nzx''|].
rewrite Rabs_right; [exact Hx1|apply Rle_ge].
apply round_ge_generic.
+ exact Vfexp2.
@@ -378,13 +392,13 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
+ apply generic_format_0.
+ now apply Rlt_le.
- unfold x'' in Nzx'' |- *.
- now apply ln_beta_round_ge; [|apply valid_rnd_N|]. }
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ now apply mag_round_ge; [|apply valid_rnd_N|]. }
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite Lx''.
rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))).
+ rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x)));
[reflexivity|].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -395,10 +409,10 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
rewrite Rabs_right; [|now apply Rle_ge].
apply (Rlt_le_trans _ _ _ Hx2).
apply Rmult_le_compat_l; [lra|].
- generalize (bpow_ge_0 beta (fexp2 (ln_beta x))).
+ generalize (bpow_ge_0 beta (fexp2 (mag x))).
rewrite 2!ulp_neq_0; try (apply Rgt_not_eq; assumption).
- unfold canonic_exp; lra.
- + apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ unfold cexp; lra.
+ + apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -407,16 +421,16 @@ destruct (Req_dec x'' 0) as [Zx''|Nzx''].
now bpow_simplify.
Qed.
-Lemma double_round_gt_mid_further_place :
+Lemma round_round_gt_mid_further_place :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
midp' fexp1 x + / 2 * ulp beta fexp2 x < x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx2'.
assert (Hx2 : round beta fexp1 Zceil x - x
@@ -425,15 +439,15 @@ assert (Hx2 : round beta fexp1 Zceil x - x
+ / 2 * ulp beta fexp2 x)); ring_simplify.
now unfold midp' in Hx2'. }
revert Hx2.
-unfold double_round_eq.
+unfold round_round_eq.
set (x' := round beta fexp1 Zfloor x).
intro Hx2.
set (x'' := round beta fexp2 (Znearest choice2) x).
-destruct (Rlt_or_le x'' (bpow (ln_beta x))) as [Hx''|Hx''];
- [now apply double_round_gt_mid_further_place'|].
-(* bpow (ln_beta x) <= x'' *)
-assert (Hx''pow : x'' = bpow (ln_beta x)).
-{ assert (H'x'' : x'' < bpow (ln_beta x) + / 2 * ulp beta fexp2 x).
+destruct (Rlt_or_le x'' (bpow (mag x))) as [Hx''|Hx''];
+ [now apply round_round_gt_mid_further_place'|].
+(* bpow (mag x) <= x'' *)
+assert (Hx''pow : x'' = bpow (mag x)).
+{ assert (H'x'' : x'' < bpow (mag x) + / 2 * ulp beta fexp2 x).
{ apply Rle_lt_trans with (x + / 2 * ulp beta fexp2 x).
- apply (Rplus_le_reg_r (- x)); ring_simplify.
apply Rabs_le_inv.
@@ -441,22 +455,22 @@ assert (Hx''pow : x'' = bpow (ln_beta x)).
exact Vfexp2.
- apply Rplus_lt_compat_r.
rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le].
- apply bpow_ln_beta_gt. }
+ apply bpow_mag_gt. }
apply Rle_antisym; [|exact Hx''].
- unfold x'', round, F2R, scaled_mantissa, canonic_exp; simpl.
- apply (Rmult_le_reg_r (bpow (- fexp2 (ln_beta x)))); [now apply bpow_gt_0|].
+ unfold x'', round, F2R, scaled_mantissa, cexp; simpl.
+ apply (Rmult_le_reg_r (bpow (- fexp2 (mag x)))); [now apply bpow_gt_0|].
bpow_simplify.
- rewrite <- (Z2R_Zpower _ (_ - _)); [|omega].
- apply Z2R_le.
+ rewrite <- (IZR_Zpower _ (_ - _)); [|omega].
+ apply IZR_le.
apply Zlt_succ_le; unfold Z.succ.
- apply lt_Z2R.
- rewrite Z2R_plus; rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (fexp2 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply lt_IZR.
+ rewrite plus_IZR; rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (fexp2 (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_plus_distr_r; rewrite Rmult_1_l.
bpow_simplify.
apply (Rlt_le_trans _ _ _ H'x'').
apply Rplus_le_compat_l.
- rewrite <- (Rmult_1_l (Fcore_Raux.bpow _ _)).
+ rewrite <- (Rmult_1_l (Raux.bpow _ _)).
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
apply Rmult_le_compat_r; [now apply bpow_ge_0|].
lra. }
@@ -467,26 +481,26 @@ assert (Hr : Rabs (x - x'') < / 2 * ulp beta fexp1 x).
exact Vfexp2.
- apply Rmult_lt_compat_l; [lra|].
rewrite 2!ulp_neq_0; try now apply Rgt_not_eq.
- unfold canonic_exp; apply bpow_lt.
+ unfold cexp; apply bpow_lt.
omega. }
-unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
-assert (Hf : (0 <= ln_beta x - fexp1 (ln_beta x''))%Z).
+unfold round, F2R, scaled_mantissa, cexp; simpl.
+assert (Hf : (0 <= mag x - fexp1 (mag x''))%Z).
{ rewrite Hx''pow.
- rewrite ln_beta_bpow.
- assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z; [|omega].
- destruct (Zle_or_lt (ln_beta x) (fexp1 (ln_beta x))) as [Hle|Hlt];
+ rewrite mag_bpow.
+ assert (fexp1 (mag x + 1) <= mag x)%Z; [|omega].
+ destruct (Zle_or_lt (mag x) (fexp1 (mag x))) as [Hle|Hlt];
[|now apply Vfexp1].
- assert (H : (ln_beta x = fexp1 (ln_beta x) :> Z)%Z);
+ assert (H : (mag x = fexp1 (mag x) :> Z)%Z);
[now apply Zle_antisym|].
rewrite H.
now apply Vfexp1. }
-rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z).
-- rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x)))%Z).
- + rewrite Z2R_Zpower; [|exact Hf].
- rewrite Z2R_Zpower; [|omega].
+rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x'')))%Z).
+- rewrite (Znearest_imp _ _ (beta ^ (mag x - fexp1 (mag x)))%Z).
+ + rewrite IZR_Zpower; [|exact Hf].
+ rewrite IZR_Zpower; [|omega].
now bpow_simplify.
- + rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ + rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -494,8 +508,8 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z).
bpow_simplify.
rewrite ulp_neq_0 in Hr;[idtac|now apply Rgt_not_eq].
rewrite <- Hx''pow; exact Hr.
-- rewrite Z2R_Zpower; [|exact Hf].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x'')))); [now apply bpow_gt_0|].
+- rewrite IZR_Zpower; [|exact Hf].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x'')))); [now apply bpow_gt_0|].
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -507,24 +521,24 @@ rewrite (Znearest_imp _ _ (beta ^ (ln_beta x - fexp1 (ln_beta x'')))%Z).
apply Rmult_lt_compat_l; [lra|apply bpow_gt_0].
Qed.
-Lemma double_round_gt_mid_same_place :
+Lemma round_round_gt_mid_same_place :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) = fexp1 (ln_beta x))%Z ->
+ (fexp2 (mag x) = fexp1 (mag x))%Z ->
midp' fexp1 x < x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 choice1 choice2 x Px Hf2f1 Hx'.
assert (Hx : round beta fexp1 Zceil x - x < / 2 * ulp beta fexp1 x).
{ apply (Rplus_lt_reg_r (- / 2 * ulp beta fexp1 x + x)); ring_simplify.
now unfold midp' in Hx'. }
-assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x))))
- - x * bpow (- fexp1 (ln_beta x))) < / 2).
-{ apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
- unfold scaled_mantissa, canonic_exp in Hx.
+assert (H : Rabs (IZR (Zceil (x * bpow (- fexp1 (mag x))))
+ - x * bpow (- fexp1 (mag x))) < / 2).
+{ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
+ unfold scaled_mantissa, cexp in Hx.
rewrite <- (Rabs_right (bpow (fexp1 _))) at 1;
[|now apply Rle_ge; apply bpow_ge_0].
rewrite <- Rabs_mult.
@@ -541,67 +555,67 @@ assert (H : Rabs (Z2R (Zceil (x * bpow (- fexp1 (ln_beta x))))
apply round_UP_pt.
exact Vfexp1.
- rewrite ulp_neq_0 in Hx;[exact Hx|now apply Rgt_not_eq]. }
-unfold double_round_eq, round at 2.
-unfold F2R, scaled_mantissa, canonic_exp; simpl.
+unfold round_round_eq, round at 2.
+unfold F2R, scaled_mantissa, cexp; simpl.
rewrite Hf2f1.
rewrite (Znearest_imp _ _ (Zceil (scaled_mantissa beta fexp1 x))).
- rewrite round_generic.
- + unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
- now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (ln_beta x)))));
+ + unfold round, F2R, scaled_mantissa, cexp; simpl.
+ now rewrite (Znearest_imp _ _ (Zceil (x * bpow (- fexp1 (mag x)))));
[|rewrite Rabs_minus_sym].
+ now apply valid_rnd_N.
- + fold (canonic_exp beta fexp1 x).
- change (Z2R _ * bpow _) with (round beta fexp1 Zceil x).
+ + fold (cexp beta fexp1 x).
+ change (IZR _ * bpow _) with (round beta fexp1 Zceil x).
apply generic_format_round.
exact Vfexp1.
now apply valid_rnd_UP.
- now rewrite Rabs_minus_sym.
Qed.
-Lemma double_round_gt_mid :
+Lemma round_round_gt_mid :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x))%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
midp' fexp1 x < x ->
- ((fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
+ ((fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
midp' fexp1 x + / 2 * ulp beta fexp2 x < x) ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1 Hx Hx'.
-destruct (Zle_or_lt (fexp1 (ln_beta x)) (fexp2 (ln_beta x))) as [Hf2'|Hf2'].
-- (* fexp1 (ln_beta x) <= fexp2 (ln_beta x) *)
- assert (Hf2'' : (fexp2 (ln_beta x) = fexp1 (ln_beta x) :> Z)%Z); [omega|].
- now apply double_round_gt_mid_same_place.
-- (* fexp2 (ln_beta x) < fexp1 (ln_beta x) *)
- assert (Hf2'' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|].
+destruct (Zle_or_lt (fexp1 (mag x)) (fexp2 (mag x))) as [Hf2'|Hf2'].
+- (* fexp1 (mag x) <= fexp2 (mag x) *)
+ assert (Hf2'' : (fexp2 (mag x) = fexp1 (mag x) :> Z)%Z); [omega|].
+ now apply round_round_gt_mid_same_place.
+- (* fexp2 (mag x) < fexp1 (mag x) *)
+ assert (Hf2'' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|].
generalize (Hx' Hf2''); intro Hx''.
- now apply double_round_gt_mid_further_place.
+ now apply round_round_gt_mid_further_place.
Qed.
Section Double_round_mult.
-Lemma ln_beta_mult_disj :
+Lemma mag_mult_disj :
forall x y,
x <> 0 -> y <> 0 ->
- ((ln_beta (x * y) = (ln_beta x + ln_beta y - 1)%Z :> Z)
- \/ (ln_beta (x * y) = (ln_beta x + ln_beta y)%Z :> Z)).
+ ((mag (x * y) = (mag x + mag y - 1)%Z :> Z)
+ \/ (mag (x * y) = (mag x + mag y)%Z :> Z)).
Proof.
intros x y Zx Zy.
-destruct (ln_beta_mult beta x y Zx Zy).
+destruct (mag_mult beta x y Zx Zy).
omega.
Qed.
-Definition double_round_mult_hyp fexp1 fexp2 :=
+Definition round_round_mult_hyp fexp1 fexp2 :=
(forall ex ey, (fexp2 (ex + ey) <= fexp1 ex + fexp1 ey)%Z)
/\ (forall ex ey, (fexp2 (ex + ey - 1) <= fexp1 ex + fexp1 ey)%Z).
-Lemma double_round_mult_aux :
+Lemma round_round_mult_aux :
forall (fexp1 fexp2 : Z -> Z),
- double_round_mult_hyp fexp1 fexp2 ->
+ round_round_mult_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x * y).
@@ -621,31 +635,31 @@ destruct (Req_dec x 0) as [Zx|Zx].
+ (* y <> 0 *)
revert Fx Fy.
unfold generic_format.
- unfold canonic_exp.
+ unfold cexp.
set (mx := Ztrunc (scaled_mantissa beta fexp1 x)).
set (my := Ztrunc (scaled_mantissa beta fexp1 y)).
unfold F2R; simpl.
intros Fx Fy.
- set (fxy := Float beta (mx * my) (fexp1 (ln_beta x) + fexp1 (ln_beta y))).
+ set (fxy := Float beta (mx * my) (fexp1 (mag x) + fexp1 (mag y))).
assert (Hxy : x * y = F2R fxy).
{ unfold fxy, F2R; simpl.
rewrite bpow_plus.
- rewrite Z2R_mult.
+ rewrite mult_IZR.
rewrite Fx, Fy at 1.
ring. }
apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|].
intros _.
- unfold canonic_exp, fxy; simpl.
+ unfold cexp, fxy; simpl.
destruct Hfexp as (Hfexp1, Hfexp2).
- now destruct (ln_beta_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy.
+ now destruct (mag_mult_disj x y Zx Zy) as [Lxy|Lxy]; rewrite Lxy.
Qed.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Theorem double_round_mult :
+Theorem round_round_mult :
forall (fexp1 fexp2 : Z -> Z),
- double_round_mult_hyp fexp1 fexp2 ->
+ round_round_mult_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
round beta fexp1 rnd (round beta fexp2 rnd (x * y))
@@ -654,21 +668,19 @@ Proof.
intros fexp1 fexp2 Hfexp x y Fx Fy.
assert (Hxy : round beta fexp2 rnd (x * y) = x * y).
{ apply round_generic; [assumption|].
- now apply (double_round_mult_aux fexp1 fexp2). }
+ now apply (round_round_mult_aux fexp1 fexp2). }
now rewrite Hxy at 1.
Qed.
Section Double_round_mult_FLX.
-Import Fcore_FLX.
-
Variable prec : Z.
Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Theorem double_round_mult_FLX :
+Theorem round_round_mult_FLX :
(2 * prec <= prec')%Z ->
forall x y,
FLX_format beta prec x -> FLX_format beta prec y ->
@@ -676,9 +688,9 @@ Theorem double_round_mult_FLX :
= round beta (FLX_exp prec) rnd (x * y).
Proof.
intros Hprec x y Fx Fy.
-apply double_round_mult;
+apply round_round_mult;
[|now apply generic_format_FLX|now apply generic_format_FLX].
-unfold double_round_mult_hyp; split; intros ex ey; unfold FLX_exp;
+unfold round_round_mult_hyp; split; intros ex ey; unfold FLX_exp;
omega.
Qed.
@@ -686,16 +698,13 @@ End Double_round_mult_FLX.
Section Double_round_mult_FLT.
-Import Fcore_FLX.
-Import Fcore_FLT.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Theorem double_round_mult_FLT :
+Theorem round_round_mult_FLT :
(emin' <= 2 * emin)%Z -> (2 * prec <= prec')%Z ->
forall x y,
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
@@ -704,9 +713,9 @@ Theorem double_round_mult_FLT :
= round beta (FLT_exp emin prec) rnd (x * y).
Proof.
intros Hemin Hprec x y Fx Fy.
-apply double_round_mult;
+apply round_round_mult;
[|now apply generic_format_FLT|now apply generic_format_FLT].
-unfold double_round_mult_hyp; split; intros ex ey;
+unfold round_round_mult_hyp; split; intros ex ey;
unfold FLT_exp;
generalize (Zmax_spec (ex + ey - prec') emin');
generalize (Zmax_spec (ex + ey - 1 - prec') emin');
@@ -719,16 +728,13 @@ End Double_round_mult_FLT.
Section Double_round_mult_FTZ.
-Import Fcore_FLX.
-Import Fcore_FTZ.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Theorem double_round_mult_FTZ :
+Theorem round_round_mult_FTZ :
(emin' + prec' <= 2 * emin + prec)%Z ->
(2 * prec <= prec')%Z ->
forall x y,
@@ -738,9 +744,9 @@ Theorem double_round_mult_FTZ :
= round beta (FTZ_exp emin prec) rnd (x * y).
Proof.
intros Hemin Hprec x y Fx Fy.
-apply double_round_mult;
+apply round_round_mult;
[|now apply generic_format_FTZ|now apply generic_format_FTZ].
-unfold double_round_mult_hyp; split; intros ex ey;
+unfold round_round_mult_hyp; split; intros ex ey;
unfold FTZ_exp;
unfold Prec_gt_0 in *;
destruct (Z.ltb_spec (ex + ey - prec') emin');
@@ -756,83 +762,77 @@ End Double_round_mult.
Section Double_round_plus.
-Lemma ln_beta_plus_disj :
+Lemma mag_plus_disj :
forall x y,
0 < y -> y <= x ->
- ((ln_beta (x + y) = ln_beta x :> Z)
- \/ (ln_beta (x + y) = (ln_beta x + 1)%Z :> Z)).
+ ((mag (x + y) = mag x :> Z)
+ \/ (mag (x + y) = (mag x + 1)%Z :> Z)).
Proof.
intros x y Py Hxy.
-destruct (ln_beta_plus beta x y Py Hxy).
+destruct (mag_plus beta x y Py Hxy).
omega.
Qed.
-Lemma ln_beta_plus_separated :
+Lemma mag_plus_separated :
forall fexp : Z -> Z,
forall x y,
0 < x -> 0 <= y ->
generic_format beta fexp x ->
- (ln_beta y <= fexp (ln_beta x))%Z ->
- (ln_beta (x + y) = ln_beta x :> Z).
+ (mag y <= fexp (mag x))%Z ->
+ (mag (x + y) = mag x :> Z).
Proof.
intros fexp x y Px Nny Fx Hsep.
-destruct (Req_dec y 0) as [Zy|Nzy].
-- (* y = 0 *)
- now rewrite Zy; rewrite Rplus_0_r.
-- (* y <> 0 *)
- apply (ln_beta_plus_eps beta fexp); [assumption|assumption|].
- split; [assumption|].
- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq].
- unfold canonic_exp.
- destruct (ln_beta y) as (ey, Hey); simpl in *.
- apply Rlt_le_trans with (bpow ey).
- + now rewrite <- (Rabs_right y); [apply Hey|apply Rle_ge].
- + now apply bpow_le.
+apply mag_plus_eps with (1 := Px) (2 := Fx).
+apply (conj Nny).
+rewrite <- Rabs_pos_eq with (1 := Nny).
+apply Rlt_le_trans with (1 := bpow_mag_gt beta _).
+rewrite ulp_neq_0 by now apply Rgt_not_eq.
+now apply bpow_le.
Qed.
-Lemma ln_beta_minus_disj :
+Lemma mag_minus_disj :
forall x y,
0 < x -> 0 < y ->
- (ln_beta y <= ln_beta x - 2)%Z ->
- ((ln_beta (x - y) = ln_beta x :> Z)
- \/ (ln_beta (x - y) = (ln_beta x - 1)%Z :> Z)).
+ (mag y <= mag x - 2)%Z ->
+ ((mag (x - y) = mag x :> Z)
+ \/ (mag (x - y) = (mag x - 1)%Z :> Z)).
Proof.
intros x y Px Py Hln.
-assert (Hxy : y < x); [now apply (ln_beta_lt_pos beta); [ |omega]|].
-generalize (ln_beta_minus beta x y Py Hxy); intro Hln2.
-generalize (ln_beta_minus_lb beta x y Px Py Hln); intro Hln3.
+assert (Hxy : y < x); [now apply (lt_mag beta); [ |omega]|].
+generalize (mag_minus beta x y Py Hxy); intro Hln2.
+generalize (mag_minus_lb beta x y Px Py Hln); intro Hln3.
omega.
Qed.
-Lemma ln_beta_minus_separated :
+Lemma mag_minus_separated :
forall fexp : Z -> Z, Valid_exp fexp ->
forall x y,
0 < x -> 0 < y -> y < x ->
- bpow (ln_beta x - 1) < x ->
- generic_format beta fexp x -> (ln_beta y <= fexp (ln_beta x))%Z ->
- (ln_beta (x - y) = ln_beta x :> Z).
+ bpow (mag x - 1) < x ->
+ generic_format beta fexp x -> (mag y <= fexp (mag x))%Z ->
+ (mag (x - y) = mag x :> Z).
Proof.
intros fexp Vfexp x y Px Py Yltx Xgtpow Fx Ly.
-apply ln_beta_unique.
+apply mag_unique.
split.
- apply Rabs_ge; right.
- assert (Hy : y < ulp beta fexp (bpow (ln_beta x - 1))).
+ assert (Hy : y < ulp beta fexp (bpow (mag x - 1))).
{ rewrite ulp_bpow.
- replace (_ + _)%Z with (ln_beta x : Z) by ring.
+ replace (_ + _)%Z with (mag x : Z) by ring.
rewrite <- (Rabs_right y); [|now apply Rle_ge; apply Rlt_le].
- apply Rlt_le_trans with (bpow (ln_beta y)).
- - apply bpow_ln_beta_gt.
+ apply Rlt_le_trans with (bpow (mag y)).
+ - apply bpow_mag_gt.
- now apply bpow_le. }
apply (Rplus_le_reg_r y); ring_simplify.
- apply Rle_trans with (bpow (ln_beta x - 1)
- + ulp beta fexp (bpow (ln_beta x - 1))).
+ apply Rle_trans with (bpow (mag x - 1)
+ + ulp beta fexp (bpow (mag x - 1))).
+ now apply Rplus_le_compat_l; apply Rlt_le.
+ rewrite <- succ_eq_pos;[idtac|apply bpow_ge_0].
apply succ_le_lt; [apply Vfexp|idtac|exact Fx|assumption].
- apply (generic_format_bpow beta fexp (ln_beta x - 1)).
- replace (_ + _)%Z with (ln_beta x : Z) by ring.
- assert (fexp (ln_beta x) < ln_beta x)%Z; [|omega].
- now apply ln_beta_generic_gt; [|now apply Rgt_not_eq|].
+ apply (generic_format_bpow beta fexp (mag x - 1)).
+ replace (_ + _)%Z with (mag x : Z) by ring.
+ assert (fexp (mag x) < mag x)%Z; [|omega].
+ now apply mag_generic_gt; [|now apply Rgt_not_eq|].
- rewrite Rabs_right.
+ apply Rlt_trans with x.
* rewrite <- (Rplus_0_r x) at 2.
@@ -840,22 +840,22 @@ split.
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
* apply Rabs_lt_inv.
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
+ lra.
Qed.
-Definition double_round_plus_hyp fexp1 fexp2 :=
+Definition round_round_plus_hyp fexp1 fexp2 :=
(forall ex ey, (fexp1 (ex + 1) - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (fexp1 ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z).
-Lemma double_round_plus_aux0_aux_aux :
+Lemma round_round_plus_aux0_aux_aux :
forall (fexp1 fexp2 : Z -> Z),
forall x y,
- (fexp1 (ln_beta x) <= fexp1 (ln_beta y))%Z ->
- (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z ->
- (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z ->
+ (fexp1 (mag x) <= fexp1 (mag y))%Z ->
+ (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z ->
+ (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x + y).
Proof.
@@ -863,224 +863,224 @@ intros fexp1 fexp2 x y Oxy Hlnx Hlny Fx Fy.
destruct (Req_dec x 0) as [Zx|Nzx].
- (* x = 0 *)
rewrite Zx, Rplus_0_l in Hlny |- *.
- now apply (generic_inclusion_ln_beta beta fexp1).
+ now apply (generic_inclusion_mag beta fexp1).
- (* x <> 0 *)
destruct (Req_dec y 0) as [Zy|Nzy].
+ (* y = 0 *)
rewrite Zy, Rplus_0_r in Hlnx |- *.
- now apply (generic_inclusion_ln_beta beta fexp1).
+ now apply (generic_inclusion_mag beta fexp1).
+ (* y <> 0 *)
revert Fx Fy.
- unfold generic_format at -3, canonic_exp, F2R; simpl.
+ unfold generic_format at -3, cexp, F2R; simpl.
set (mx := Ztrunc (scaled_mantissa beta fexp1 x)).
set (my := Ztrunc (scaled_mantissa beta fexp1 y)).
intros Fx Fy.
- set (fxy := Float beta (mx + my * (beta ^ (fexp1 (ln_beta y)
- - fexp1 (ln_beta x))))
- (fexp1 (ln_beta x))).
+ set (fxy := Float beta (mx + my * (beta ^ (fexp1 (mag y)
+ - fexp1 (mag x))))
+ (fexp1 (mag x))).
assert (Hxy : x + y = F2R fxy).
{ unfold fxy, F2R; simpl.
- rewrite Z2R_plus.
+ rewrite plus_IZR.
rewrite Rmult_plus_distr_r.
rewrite <- Fx.
- rewrite Z2R_mult.
- rewrite Z2R_Zpower; [|omega].
+ rewrite mult_IZR.
+ rewrite IZR_Zpower; [|omega].
bpow_simplify.
now rewrite <- Fy. }
apply generic_format_F2R' with (f := fxy); [now rewrite Hxy|].
intros _.
- now unfold canonic_exp, fxy; simpl.
+ now unfold cexp, fxy; simpl.
Qed.
-Lemma double_round_plus_aux0_aux :
+Lemma round_round_plus_aux0_aux :
forall (fexp1 fexp2 : Z -> Z),
forall x y,
- (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta x))%Z ->
- (fexp2 (ln_beta (x + y))%Z <= fexp1 (ln_beta y))%Z ->
+ (fexp2 (mag (x + y))%Z <= fexp1 (mag x))%Z ->
+ (fexp2 (mag (x + y))%Z <= fexp1 (mag y))%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x + y).
Proof.
intros fexp1 fexp2 x y Hlnx Hlny Fx Fy.
-destruct (Z.le_gt_cases (fexp1 (ln_beta x)) (fexp1 (ln_beta y))) as [Hle|Hgt].
-- now apply (double_round_plus_aux0_aux_aux fexp1).
+destruct (Z.le_gt_cases (fexp1 (mag x)) (fexp1 (mag y))) as [Hle|Hgt].
+- now apply (round_round_plus_aux0_aux_aux fexp1).
- rewrite Rplus_comm in Hlnx, Hlny |- *.
- now apply (double_round_plus_aux0_aux_aux fexp1); [omega| | | |].
+ now apply (round_round_plus_aux0_aux_aux fexp1); [omega| | | |].
Qed.
-(* fexp1 (ln_beta x) - 1 <= ln_beta y :
+(* fexp1 (mag x) - 1 <= mag y :
* addition is exact in the largest precision (fexp2). *)
-Lemma double_round_plus_aux0 :
+Lemma round_round_plus_aux0 :
forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 ->
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
(0 < x)%R -> (0 < y)%R -> (y <= x)%R ->
- (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z ->
+ (fexp1 (mag x) - 1 <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x + y).
Proof.
intros fexp1 fexp2 Vfexp1 Hexp x y Px Py Hyx Hln Fx Fy.
assert (Nny : (0 <= y)%R); [now apply Rlt_le|].
destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))).
-destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt].
-- (* ln_beta y <= fexp1 (ln_beta x) *)
- assert (Lxy : ln_beta (x + y) = ln_beta x :> Z);
- [now apply (ln_beta_plus_separated fexp1)|].
- apply (double_round_plus_aux0_aux fexp1);
+destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt].
+- (* mag y <= fexp1 (mag x) *)
+ assert (Lxy : mag (x + y) = mag x :> Z);
+ [now apply (mag_plus_separated fexp1)|].
+ apply (round_round_plus_aux0_aux fexp1);
[| |assumption|assumption]; rewrite Lxy.
+ now apply Hexp4; omega.
+ now apply Hexp3; omega.
-- (* fexp1 (ln_beta x) < ln_beta y *)
- apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption].
- destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+- (* fexp1 (mag x) < mag y *)
+ apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption].
+ destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+ now apply Hexp4; omega.
- + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx.
- replace (_ - _)%Z with (ln_beta x : Z) by ring.
+ + apply Hexp2; apply (mag_le beta y x Py) in Hyx.
+ replace (_ - _)%Z with (mag x : Z) by ring.
omega.
- + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+ + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
* now apply Hexp3; omega.
* apply Hexp2.
- replace (_ - _)%Z with (ln_beta x : Z) by ring.
+ replace (_ - _)%Z with (mag x : Z) by ring.
omega.
Qed.
-Lemma double_round_plus_aux1_aux :
+Lemma round_round_plus_aux1_aux :
forall k, (0 < k)%Z ->
forall (fexp : Z -> Z),
forall x y,
0 < x -> 0 < y ->
- (ln_beta y <= fexp (ln_beta x) - k)%Z ->
- (ln_beta (x + y) = ln_beta x :> Z) ->
+ (mag y <= fexp (mag x) - k)%Z ->
+ (mag (x + y) = mag x :> Z) ->
generic_format beta fexp x ->
- 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (ln_beta x) - k).
+ 0 < (x + y) - round beta fexp Zfloor (x + y) < bpow (fexp (mag x) - k).
Proof.
assert (Hbeta : (2 <= beta)%Z).
{ destruct beta as (beta_val,beta_prop).
now apply Zle_bool_imp_le. }
intros k Hk fexp x y Px Py Hln Hlxy Fx.
revert Fx.
-unfold round, generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
+unfold round, generic_format, F2R, scaled_mantissa, cexp; simpl.
rewrite Hlxy.
-set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))).
+set (mx := Ztrunc (x * bpow (- fexp (mag x)))).
intros Fx.
-assert (R : (x + y) * bpow (- fexp (ln_beta x))
- = Z2R mx + y * bpow (- fexp (ln_beta x))).
+assert (R : (x + y) * bpow (- fexp (mag x))
+ = IZR mx + y * bpow (- fexp (mag x))).
{ rewrite Fx at 1.
rewrite Rmult_plus_distr_r.
now bpow_simplify. }
rewrite R.
-assert (LB : 0 < y * bpow (- fexp (ln_beta x))).
+assert (LB : 0 < y * bpow (- fexp (mag x))).
{ rewrite <- (Rmult_0_r y).
now apply Rmult_lt_compat_l; [|apply bpow_gt_0]. }
-assert (UB : y * bpow (- fexp (ln_beta x)) < / Z2R (beta ^ k)).
-{ apply Rlt_le_trans with (bpow (ln_beta y) * bpow (- fexp (ln_beta x))).
+assert (UB : y * bpow (- fexp (mag x)) < / IZR (beta ^ k)).
+{ apply Rlt_le_trans with (bpow (mag y) * bpow (- fexp (mag x))).
- apply Rmult_lt_compat_r; [now apply bpow_gt_0|].
rewrite <- (Rabs_right y) at 1; [|now apply Rle_ge; apply Rlt_le].
- apply bpow_ln_beta_gt.
- - apply Rle_trans with (bpow (fexp (ln_beta x) - k)
- * bpow (- fexp (ln_beta x)))%R.
+ apply bpow_mag_gt.
+ - apply Rle_trans with (bpow (fexp (mag x) - k)
+ * bpow (- fexp (mag x)))%R.
+ apply Rmult_le_compat_r; [now apply bpow_ge_0|].
now apply bpow_le.
+ bpow_simplify.
rewrite bpow_opp.
destruct k.
* omega.
- * simpl; unfold Fcore_Raux.bpow, Z.pow_pos.
+ * simpl; unfold Raux.bpow, Z.pow_pos.
now apply Rle_refl.
- * casetype False; apply (Zlt_irrefl 0).
- apply (Zlt_trans _ _ _ Hk).
+ * casetype False; apply (Z.lt_irrefl 0).
+ apply (Z.lt_trans _ _ _ Hk).
apply Zlt_neg_0. }
rewrite (Zfloor_imp mx).
{ split; ring_simplify.
- - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|].
+ - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r, Rmult_0_l.
bpow_simplify.
rewrite R; ring_simplify.
now apply Rmult_lt_0_compat; [|apply bpow_gt_0].
- - apply (Rmult_lt_reg_r (bpow (- fexp (ln_beta x)))); [now apply bpow_gt_0|].
+ - apply (Rmult_lt_reg_r (bpow (- fexp (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r.
bpow_simplify.
rewrite R; ring_simplify.
apply (Rlt_le_trans _ _ _ UB).
rewrite bpow_opp.
apply Rinv_le; [now apply bpow_gt_0|].
- now rewrite Z2R_Zpower; [right|omega]. }
+ now rewrite IZR_Zpower; [right|omega]. }
split.
- rewrite <- Rplus_0_r at 1; apply Rplus_le_compat_l.
now apply Rlt_le.
-- rewrite Z2R_plus; apply Rplus_lt_compat_l.
- apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x)))); [now apply bpow_gt_0|].
+- rewrite plus_IZR; apply Rplus_lt_compat_l.
+ apply (Rmult_lt_reg_r (bpow (fexp (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_1_l.
bpow_simplify.
- apply Rlt_trans with (bpow (ln_beta y)).
+ apply Rlt_trans with (bpow (mag y)).
+ rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le].
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
+ apply bpow_lt; omega.
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 2 : double_round_lt_mid applies. *)
-Lemma double_round_plus_aux1 :
+(* mag y <= fexp1 (mag x) - 2 : round_round_lt_mid applies. *)
+Lemma round_round_plus_aux1 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
- (ln_beta y <= fexp1 (ln_beta x) - 2)%Z ->
+ (mag y <= fexp1 (mag x) - 2)%Z ->
generic_format beta fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
assert (Hbeta : (2 <= beta)%Z).
{ destruct beta as (beta_val,beta_prop).
now apply Zle_bool_imp_le. }
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx.
-assert (Lxy : ln_beta (x + y) = ln_beta x :> Z);
- [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|].
+assert (Lxy : mag (x + y) = mag x :> Z);
+ [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|].
destruct Hexp as (_,(_,(_,Hexp4))).
-assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z);
+assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z);
[now apply Hexp4; omega|].
assert (Bpow2 : bpow (- 2) <= / 2 * / 2).
{ replace (/2 * /2) with (/4) by field.
rewrite (bpow_opp _ 2).
apply Rinv_le; [lra|].
- apply (Z2R_le (2 * 2) (beta * (beta * 1))).
+ apply (IZR_le (2 * 2) (beta * (beta * 1))).
rewrite Zmult_1_r.
now apply Zmult_le_compat; omega. }
assert (P2 : (0 < 2)%Z) by omega.
-unfold double_round_eq.
-apply double_round_lt_mid.
+unfold round_round_eq.
+apply round_round_lt_mid.
- exact Vfexp1.
- exact Vfexp2.
- lra.
- now rewrite Lxy.
- rewrite Lxy.
- assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+ assert (fexp1 (mag x) < mag x)%Z; [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- unfold midp.
apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))).
- apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px
+ apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px
Py Hly Lxy Fx))).
ring_simplify.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold canonic_exp; rewrite Lxy.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ unfold cexp; rewrite Lxy.
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|].
bpow_simplify.
apply (Rle_trans _ _ _ Bpow2).
rewrite <- (Rmult_1_r (/ 2)) at 3.
apply Rmult_le_compat_l; lra.
- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
+ unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy.
intro Hf2'.
- apply (Rmult_lt_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_lt_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
bpow_simplify.
apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))).
unfold midp; ring_simplify.
- apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 2 P2 fexp1 x y Px
+ apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 2 P2 fexp1 x y Px
Py Hly Lxy Fx))).
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold canonic_exp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify.
+ unfold cexp; rewrite Lxy, Rmult_minus_distr_r; bpow_simplify.
apply (Rle_trans _ _ _ Bpow2).
rewrite <- (Rmult_1_r (/ 2)) at 3; rewrite <- Rmult_minus_distr_l.
apply Rmult_le_compat_l; [lra|].
@@ -1089,49 +1089,49 @@ apply double_round_lt_mid.
apply Ropp_le_contravar.
{ apply Rle_trans with (bpow (- 1)).
- apply bpow_le; omega.
- - unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ - unfold Raux.bpow, Z.pow_pos; simpl.
apply Rinv_le; [lra|].
- change 2 with (Z2R 2); apply Z2R_le; omega. }
+ apply IZR_le; omega. }
Qed.
-(* double_round_plus_aux{0,1} together *)
-Lemma double_round_plus_aux2 :
+(* round_round_plus_aux{0,1} together *)
+Lemma round_round_plus_aux2 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y -> y <= x ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hyx Fx Fy.
-unfold double_round_eq.
-destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly].
-- (* ln_beta y <= fexp1 (ln_beta x) - 2 *)
- now apply double_round_plus_aux1.
-- (* fexp1 (ln_beta x) - 2 < ln_beta y *)
+unfold round_round_eq.
+destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly].
+- (* mag y <= fexp1 (mag x) - 2 *)
+ now apply round_round_plus_aux1.
+- (* fexp1 (mag x) - 2 < mag y *)
rewrite (round_generic beta fexp2).
+ reflexivity.
+ now apply valid_rnd_N.
- + assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|].
- now apply (double_round_plus_aux0 fexp1).
+ + assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|].
+ now apply (round_round_plus_aux0 fexp1).
Qed.
-Lemma double_round_plus_aux :
+Lemma round_round_plus_aux :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 <= x -> 0 <= y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec x 0) as [Zx|Nzx].
- (* x = 0 *)
destruct Hexp as (_,(_,(_,Hexp4))).
@@ -1139,7 +1139,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
+ reflexivity.
+ now apply valid_rnd_N.
- + apply (generic_inclusion_ln_beta beta fexp1).
+ + apply (generic_inclusion_mag beta fexp1).
now intros _; apply Hexp4; omega.
exact Fy.
- (* x <> 0 *)
@@ -1150,7 +1150,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
now intros _; apply Hexp4; omega.
exact Fx.
+ (* y <> 0 *)
@@ -1160,118 +1160,118 @@ destruct (Req_dec x 0) as [Zx|Nzx].
* (* x < y *)
apply Rlt_le in H.
rewrite Rplus_comm.
- now apply double_round_plus_aux2.
- * now apply double_round_plus_aux2.
+ now apply round_round_plus_aux2.
+ * now apply round_round_plus_aux2.
Qed.
-Lemma double_round_minus_aux0_aux :
+Lemma round_round_minus_aux0_aux :
forall (fexp1 fexp2 : Z -> Z),
forall x y,
- (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta x))%Z ->
- (fexp2 (ln_beta (x - y))%Z <= fexp1 (ln_beta y))%Z ->
+ (fexp2 (mag (x - y))%Z <= fexp1 (mag x))%Z ->
+ (fexp2 (mag (x - y))%Z <= fexp1 (mag y))%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x - y).
Proof.
intros fexp1 fexp2 x y.
replace (x - y)%R with (x + (- y))%R; [|ring].
intros Hlnx Hlny Fx Fy.
-rewrite <- (ln_beta_opp beta y) in Hlny.
+rewrite <- (mag_opp beta y) in Hlny.
apply generic_format_opp in Fy.
-now apply (double_round_plus_aux0_aux fexp1).
+now apply (round_round_plus_aux0_aux fexp1).
Qed.
-(* fexp1 (ln_beta x) - 1 <= ln_beta y :
+(* fexp1 (mag x) - 1 <= mag y :
* substraction is exact in the largest precision (fexp2). *)
-Lemma double_round_minus_aux0 :
+Lemma round_round_minus_aux0 :
forall (fexp1 fexp2 : Z -> Z),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z ->
+ (fexp1 (mag x) - 1 <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x - y).
Proof.
intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hyx).
destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))).
-assert (Lyx : (ln_beta y <= ln_beta x)%Z);
- [now apply ln_beta_le; [|apply Rlt_le]|].
-destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge].
-- (* ln_beta x - 2 < ln_beta y *)
- assert (Hor : (ln_beta y = ln_beta x :> Z)
- \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|].
+assert (Lyx : (mag y <= mag x)%Z);
+ [now apply mag_le; [|apply Rlt_le]|].
+destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge].
+- (* mag x - 2 < mag y *)
+ assert (Hor : (mag y = mag x :> Z)
+ \/ (mag y = mag x - 1 :> Z)%Z); [omega|].
destruct Hor as [Heq|Heqm1].
- + (* ln_beta y = ln_beta x *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ + (* mag y = mag x *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
* rewrite Heq.
apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
- + (* ln_beta y = ln_beta x - 1 *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
+ + (* mag y = mag x - 1 *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
* rewrite Heqm1.
apply Hexp4.
apply Zplus_le_compat_r.
- now apply ln_beta_minus.
-- (* ln_beta y <= ln_beta x - 2 *)
- destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy].
- + (* ln_beta (x - y) = ln_beta x *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ now apply mag_minus.
+- (* mag y <= mag x - 2 *)
+ destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy].
+ + (* mag (x - y) = mag x *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
omega.
* now rewrite Lxmy; apply Hexp3.
- + (* ln_beta (x - y) = ln_beta x - 1 *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy];
+ + (* mag (x - y) = mag x - 1 *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy];
rewrite Lxmy.
* apply Hexp1.
- replace (_ + _)%Z with (ln_beta x : Z); [|ring].
- now apply Zle_trans with (ln_beta y).
+ replace (_ + _)%Z with (mag x : Z); [|ring].
+ now apply Z.le_trans with (mag y).
* apply Hexp1.
- now replace (_ + _)%Z with (ln_beta x : Z); [|ring].
+ now replace (_ + _)%Z with (mag x : Z); [|ring].
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 2,
- * fexp1 (ln_beta (x - y)) - 1 <= ln_beta y :
+(* mag y <= fexp1 (mag x) - 2,
+ * fexp1 (mag (x - y)) - 1 <= mag y :
* substraction is exact in the largest precision (fexp2). *)
-Lemma double_round_minus_aux1 :
+Lemma round_round_minus_aux1 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (ln_beta y <= fexp1 (ln_beta x) - 2)%Z ->
- (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z ->
+ (mag y <= fexp1 (mag x) - 2)%Z ->
+ (fexp1 (mag (x - y)) - 1 <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x - y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hyx).
destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))).
-assert (Lyx : (ln_beta y <= ln_beta x)%Z);
- [now apply ln_beta_le; [|apply Rlt_le]|].
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
-- apply Zle_trans with (fexp1 (ln_beta (x - y))).
+assert (Lyx : (mag y <= mag x)%Z);
+ [now apply mag_le; [|apply Rlt_le]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp1 (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+- apply Z.le_trans with (fexp1 (mag (x - y))).
+ apply Hexp4; omega.
+ omega.
- now apply Hexp3.
Qed.
-Lemma double_round_minus_aux2_aux :
+Lemma round_round_minus_aux2_aux :
forall (fexp : Z -> Z),
Valid_exp fexp ->
forall x y,
0 < y -> y < x ->
- (ln_beta y <= fexp (ln_beta x) - 1)%Z ->
+ (mag y <= fexp (mag x) - 1)%Z ->
generic_format beta fexp x ->
generic_format beta fexp y ->
round beta fexp Zceil (x - y) - (x - y) <= y.
@@ -1279,19 +1279,19 @@ Proof.
intros fexp Vfexp x y Py Hxy Hly Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hxy).
revert Fx.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp (ln_beta x)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp (mag x)))).
intro Fx.
-assert (Hfx : (fexp (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx].
-- (* bpow (ln_beta x - 1) < x *)
- assert (Lxy : ln_beta (x - y) = ln_beta x :> Z);
- [now apply (ln_beta_minus_separated fexp); [| | | | | |omega]|].
+assert (Hfx : (fexp (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+destruct (Rlt_or_le (bpow (mag x - 1)) x) as [Hx|Hx].
+- (* bpow (mag x - 1) < x *)
+ assert (Lxy : mag (x - y) = mag x :> Z);
+ [now apply (mag_minus_separated fexp); [| | | | | |omega]|].
assert (Rxy : round beta fexp Zceil (x - y) = x).
- { unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ { unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite Lxy.
apply eq_sym; rewrite Fx at 1; apply eq_sym.
apply Rmult_eq_compat_r.
@@ -1301,18 +1301,18 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx].
bpow_simplify.
apply Zceil_imp.
split.
- - unfold Zminus; rewrite Z2R_plus.
+ - unfold Zminus; rewrite plus_IZR.
apply Rplus_lt_compat_l.
apply Ropp_lt_contravar; simpl.
- apply (Rmult_lt_reg_r (bpow (fexp (ln_beta x))));
+ apply (Rmult_lt_reg_r (bpow (fexp (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_1_l; bpow_simplify.
- apply Rlt_le_trans with (bpow (ln_beta y)).
+ apply Rlt_le_trans with (bpow (mag y)).
+ rewrite <- Rabs_right at 1; [|now apply Rle_ge; apply Rlt_le].
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
+ apply bpow_le.
omega.
- - rewrite <- (Rplus_0_r (Z2R _)) at 2.
+ - rewrite <- (Rplus_0_r (IZR _)) at 2.
apply Rplus_le_compat_l.
rewrite <- Ropp_0; apply Ropp_le_contravar.
rewrite <- (Rmult_0_r y).
@@ -1320,34 +1320,34 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx].
now apply bpow_ge_0. }
rewrite Rxy; ring_simplify.
apply Rle_refl.
-- (* x <= bpow (ln_beta x - 1) *)
- assert (Xpow : x = bpow (ln_beta x - 1)).
+- (* x <= bpow (mag x - 1) *)
+ assert (Xpow : x = bpow (mag x - 1)).
{ apply Rle_antisym; [exact Hx|].
- destruct (ln_beta x) as (ex, Hex); simpl.
+ destruct (mag x) as (ex, Hex); simpl.
rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le].
apply Hex.
now apply Rgt_not_eq. }
- assert (Lxy : (ln_beta (x - y) = ln_beta x - 1 :> Z)%Z).
+ assert (Lxy : (mag (x - y) = mag x - 1 :> Z)%Z).
{ apply Zle_antisym.
- - apply ln_beta_le_bpow.
+ - apply mag_le_bpow.
+ apply Rminus_eq_contra.
now intro Hx'; rewrite Hx' in Hxy; apply (Rlt_irrefl y).
+ rewrite Rabs_right; lra.
- - apply (ln_beta_minus_lb beta x y Px Py).
+ - apply (mag_minus_lb beta x y Px Py).
omega. }
- assert (Hfx1 : (fexp (ln_beta x - 1) < ln_beta x - 1)%Z);
- [now apply (valid_exp_large fexp (ln_beta y)); [|omega]|].
+ assert (Hfx1 : (fexp (mag x - 1) < mag x - 1)%Z);
+ [now apply (valid_exp_large fexp (mag y)); [|omega]|].
assert (Rxy : round beta fexp Zceil (x - y) <= x).
{ rewrite Xpow at 2.
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
rewrite Lxy.
- apply (Rmult_le_reg_r (bpow (- fexp (ln_beta x - 1)%Z)));
+ apply (Rmult_le_reg_r (bpow (- fexp (mag x - 1)%Z)));
[now apply bpow_gt_0|].
bpow_simplify.
- rewrite <- (Z2R_Zpower beta (_ - _ - _)); [|omega].
- apply Z2R_le.
+ rewrite <- (IZR_Zpower beta (_ - _ - _)); [|omega].
+ apply IZR_le.
apply Zceil_glb.
- rewrite Z2R_Zpower; [|omega].
+ rewrite IZR_Zpower; [|omega].
rewrite Xpow at 1.
rewrite Rmult_minus_distr_r.
bpow_simplify.
@@ -1360,21 +1360,21 @@ destruct (Rlt_or_le (bpow (ln_beta x - 1)) x) as [Hx|Hx].
lra.
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 2 :
- * ln_beta y <= fexp1 (ln_beta (x - y)) - 2 :
- * double_round_gt_mid applies. *)
-Lemma double_round_minus_aux2 :
+(* mag y <= fexp1 (mag x) - 2 :
+ * mag y <= fexp1 (mag (x - y)) - 2 :
+ * round_round_gt_mid applies. *)
+Lemma round_round_minus_aux2 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (ln_beta y <= fexp1 (ln_beta x) - 2)%Z ->
- (ln_beta y <= fexp1 (ln_beta (x - y)) - 2)%Z ->
+ (mag y <= fexp1 (mag x) - 2)%Z ->
+ (mag y <= fexp1 (mag (x - y)) - 2)%Z ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
assert (Hbeta : (2 <= beta)%Z).
{ destruct beta as (beta_val,beta_prop).
@@ -1382,52 +1382,52 @@ assert (Hbeta : (2 <= beta)%Z).
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hxy).
destruct Hexp as (_,(_,(_,Hexp4))).
-assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z);
+assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z);
[now apply Hexp4; omega|].
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
assert (Bpow2 : bpow (- 2) <= / 2 * / 2).
{ replace (/2 * /2) with (/4) by field.
rewrite (bpow_opp _ 2).
apply Rinv_le; [lra|].
- apply (Z2R_le (2 * 2) (beta * (beta * 1))).
+ apply (IZR_le (2 * 2) (beta * (beta * 1))).
rewrite Zmult_1_r.
now apply Zmult_le_compat; omega. }
-assert (Ly : y < bpow (ln_beta y)).
+assert (Ly : y < bpow (mag y)).
{ apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
-unfold double_round_eq.
-apply double_round_gt_mid.
+ apply bpow_mag_gt. }
+unfold round_round_eq.
+apply round_round_gt_mid.
- exact Vfexp1.
- exact Vfexp2.
- lra.
- apply Hexp4; omega.
-- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega].
- apply (valid_exp_large fexp1 (ln_beta x - 1)).
- + apply (valid_exp_large fexp1 (ln_beta y)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
- + now apply ln_beta_minus_lb; [| |omega].
+- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega].
+ apply (valid_exp_large fexp1 (mag x - 1)).
+ + apply (valid_exp_large fexp1 (mag y)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
+ + now apply mag_minus_lb; [| |omega].
- unfold midp'.
apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))).
ring_simplify.
replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring.
- apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 2)).
+ apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 2)).
+ apply Rle_lt_trans with y;
- [now apply double_round_minus_aux2_aux; try assumption; omega|].
+ [now apply round_round_minus_aux2_aux; try assumption; omega|].
apply (Rlt_le_trans _ _ _ Ly).
now apply bpow_le.
+ rewrite ulp_neq_0;[idtac|now apply sym_not_eq, Rlt_not_eq, Rgt_minus].
- unfold canonic_exp.
- replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring.
+ unfold cexp.
+ replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring.
unfold Zminus at 1; rewrite bpow_plus.
rewrite Rmult_comm.
apply Rmult_le_compat.
* now apply bpow_ge_0.
* now apply bpow_ge_0.
- * unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ * unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le.
lra.
- now change 2 with (Z2R 2); apply Z2R_le.
+ now apply IZR_le.
* apply bpow_le; omega.
- intro Hf2'.
unfold midp'.
@@ -1436,53 +1436,53 @@ apply double_round_gt_mid.
ring_simplify.
replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring.
apply Rle_lt_trans with y;
- [now apply double_round_minus_aux2_aux; try assumption; omega|].
+ [now apply round_round_minus_aux2_aux; try assumption; omega|].
apply (Rlt_le_trans _ _ _ Ly).
- apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 2));
+ apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 2));
[now apply bpow_le|].
- replace (_ - 2)%Z with (fexp1 (ln_beta (x - y)) - 1 - 1)%Z by ring.
+ replace (_ - 2)%Z with (fexp1 (mag (x - y)) - 1 - 1)%Z by ring.
unfold Zminus at 1; rewrite bpow_plus.
rewrite <- Rmult_minus_distr_l.
rewrite Rmult_comm; apply Rmult_le_compat.
+ apply bpow_ge_0.
+ apply bpow_ge_0.
- + unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ + unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le; [lra|].
- now change 2 with (Z2R 2); apply Z2R_le.
+ now apply IZR_le.
+ rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus.
- unfold canonic_exp.
- apply (Rplus_le_reg_r (bpow (fexp2 (ln_beta (x - y))))); ring_simplify.
- apply Rle_trans with (2 * bpow (fexp1 (ln_beta (x - y)) - 1)).
- * replace (2 * bpow (fexp1 (ln_beta (x - y)) - 1)) with (bpow (fexp1 (ln_beta (x - y)) - 1) + bpow (fexp1 (ln_beta (x - y)) - 1)) by ring.
+ unfold cexp.
+ apply (Rplus_le_reg_r (bpow (fexp2 (mag (x - y))))); ring_simplify.
+ apply Rle_trans with (2 * bpow (fexp1 (mag (x - y)) - 1)).
+ * rewrite double.
apply Rplus_le_compat_l.
now apply bpow_le.
* unfold Zminus; rewrite bpow_plus.
rewrite Rmult_comm; rewrite Rmult_assoc.
rewrite <- Rmult_1_r.
apply Rmult_le_compat_l; [now apply bpow_ge_0|].
- unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r.
- apply Z2R_le, Rinv_le in Hbeta.
+ apply IZR_le, Rinv_le in Hbeta.
simpl in Hbeta.
lra.
apply Rlt_0_2.
Qed.
-(* double_round_minus_aux{0,1,2} together *)
-Lemma double_round_minus_aux3 :
+(* round_round_minus_aux{0,1,2} together *)
+Lemma round_round_minus_aux3 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y <= x ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy.
assert (Px := Rlt_le_trans 0 y x Py Hyx).
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec y x) as [Hy|Hy].
- (* y = x *)
rewrite Hy; replace (x - x) with 0 by ring.
@@ -1491,38 +1491,38 @@ destruct (Req_dec y x) as [Hy|Hy].
+ now apply valid_rnd_N.
- (* y < x *)
assert (Hyx' : y < x); [lra|].
- destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 2)) as [Hly|Hly].
- + (* ln_beta y <= fexp1 (ln_beta x) - 2 *)
- destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 2))
+ destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 2)) as [Hly|Hly].
+ + (* mag y <= fexp1 (mag x) - 2 *)
+ destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 2))
as [Hly'|Hly'].
- * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 2 *)
- now apply double_round_minus_aux2.
- * (* fexp1 (ln_beta (x - y)) - 2 < ln_beta y *)
+ * (* mag y <= fexp1 (mag (x - y)) - 2 *)
+ now apply round_round_minus_aux2.
+ * (* fexp1 (mag (x - y)) - 2 < mag y *)
{ rewrite (round_generic beta fexp2).
- reflexivity.
- now apply valid_rnd_N.
- - assert (Hf1 : (fexp1 (ln_beta (x - y)) - 1 <= ln_beta y)%Z); [omega|].
- now apply (double_round_minus_aux1 fexp1). }
+ - assert (Hf1 : (fexp1 (mag (x - y)) - 1 <= mag y)%Z); [omega|].
+ now apply (round_round_minus_aux1 fexp1). }
+ rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * assert (Hf1 : (fexp1 (ln_beta x) - 1 <= ln_beta y)%Z); [omega|].
- now apply (double_round_minus_aux0 fexp1).
+ * assert (Hf1 : (fexp1 (mag x) - 1 <= mag y)%Z); [omega|].
+ now apply (round_round_minus_aux0 fexp1).
Qed.
-Lemma double_round_minus_aux :
+Lemma round_round_minus_aux :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
0 <= x -> 0 <= y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec x 0) as [Zx|Nzx].
- (* x = 0 *)
rewrite Zx; unfold Rminus; rewrite Rplus_0_l.
@@ -1530,7 +1530,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
destruct Hexp as (_,(_,(_,Hexp4))).
now intros _; apply Hexp4; omega.
exact Fy.
@@ -1541,7 +1541,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
destruct Hexp as (_,(_,(_,Hexp4))).
now intros _; apply Hexp4; omega.
exact Fx.
@@ -1554,23 +1554,23 @@ destruct (Req_dec x 0) as [Zx|Nzx].
replace (x - y) with (- (y - x)) by ring.
do 3 rewrite round_N_opp.
apply Ropp_eq_compat.
- now apply double_round_minus_aux3.
+ now apply round_round_minus_aux3.
* (* y <= x *)
- now apply double_round_minus_aux3.
+ now apply round_round_minus_aux3.
Qed.
-Lemma double_round_plus :
+Lemma round_round_plus :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy].
- (* x < 0, y < 0 *)
replace (x + y) with (- (- x - y)); [|ring].
@@ -1580,87 +1580,85 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy].
assert (Py : 0 <= - y); [lra|].
apply generic_format_opp in Fx.
apply generic_format_opp in Fy.
- now apply double_round_plus_aux.
+ now apply round_round_plus_aux.
- (* x < 0, 0 <= y *)
replace (x + y) with (y - (- x)); [|ring].
assert (Px : 0 <= - x); [lra|].
apply generic_format_opp in Fx.
- now apply double_round_minus_aux.
+ now apply round_round_minus_aux.
- (* 0 <= x, y < 0 *)
replace (x + y) with (x - (- y)); [|ring].
assert (Py : 0 <= - y); [lra|].
apply generic_format_opp in Fy.
- now apply double_round_minus_aux.
+ now apply round_round_minus_aux.
- (* 0 <= x, 0 <= y *)
- now apply double_round_plus_aux.
+ now apply round_round_plus_aux.
Qed.
-Lemma double_round_minus :
+Lemma round_round_minus :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_hyp fexp1 fexp2 ->
+ round_round_plus_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy.
unfold Rminus.
apply generic_format_opp in Fy.
-now apply double_round_plus.
+now apply round_round_plus.
Qed.
Section Double_round_plus_FLX.
-Import Fcore_FLX.
-
Variable prec : Z.
Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLX_double_round_plus_hyp :
+Lemma FLX_round_round_plus_hyp :
(2 * prec + 1 <= prec')%Z ->
- double_round_plus_hyp (FLX_exp prec) (FLX_exp prec').
+ round_round_plus_hyp (FLX_exp prec) (FLX_exp prec').
Proof.
intros Hprec.
unfold FLX_exp.
-unfold double_round_plus_hyp; split; [|split; [|split]];
+unfold round_round_plus_hyp; split; [|split; [|split]];
intros ex ey; try omega.
unfold Prec_gt_0 in prec_gt_0_.
omega.
Qed.
-Theorem double_round_plus_FLX :
+Theorem round_round_plus_FLX :
forall choice1 choice2,
(2 * prec + 1 <= prec')%Z ->
forall x y,
FLX_format beta prec x -> FLX_format beta prec y ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y).
Proof.
intros choice1 choice2 Hprec x y Fx Fy.
-apply double_round_plus.
+apply round_round_plus.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_plus_hyp.
+- now apply FLX_round_round_plus_hyp.
- now apply generic_format_FLX.
- now apply generic_format_FLX.
Qed.
-Theorem double_round_minus_FLX :
+Theorem round_round_minus_FLX :
forall choice1 choice2,
(2 * prec + 1 <= prec')%Z ->
forall x y,
FLX_format beta prec x -> FLX_format beta prec y ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y).
Proof.
intros choice1 choice2 Hprec x y Fx Fy.
-apply double_round_minus.
+apply round_round_minus.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_plus_hyp.
+- now apply FLX_round_round_plus_hyp.
- now apply generic_format_FLX.
- now apply generic_format_FLX.
Qed.
@@ -1669,22 +1667,19 @@ End Double_round_plus_FLX.
Section Double_round_plus_FLT.
-Import Fcore_FLX.
-Import Fcore_FLT.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLT_double_round_plus_hyp :
+Lemma FLT_round_round_plus_hyp :
(emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z ->
- double_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
+ round_round_plus_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FLT_exp.
-unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
+unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
- generalize (Zmax_spec (ex + 1 - prec) emin).
generalize (Zmax_spec (ex - prec') emin').
generalize (Zmax_spec (ey - prec) emin).
@@ -1703,36 +1698,36 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
omega.
Qed.
-Theorem double_round_plus_FLT :
+Theorem round_round_plus_FLT :
forall choice1 choice2,
(emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z ->
forall x y,
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (x + y).
Proof.
intros choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_plus.
+apply round_round_plus.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_plus_hyp.
+- now apply FLT_round_round_plus_hyp.
- now apply generic_format_FLT.
- now apply generic_format_FLT.
Qed.
-Theorem double_round_minus_FLT :
+Theorem round_round_minus_FLT :
forall choice1 choice2,
(emin' <= emin)%Z -> (2 * prec + 1 <= prec')%Z ->
forall x y,
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (x - y).
Proof.
intros choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_minus.
+apply round_round_minus.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_plus_hyp.
+- now apply FLT_round_round_plus_hyp.
- now apply generic_format_FLT.
- now apply generic_format_FLT.
Qed.
@@ -1741,23 +1736,20 @@ End Double_round_plus_FLT.
Section Double_round_plus_FTZ.
-Import Fcore_FLX.
-Import Fcore_FTZ.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FTZ_double_round_plus_hyp :
+Lemma FTZ_round_round_plus_hyp :
(emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z ->
- double_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
+ round_round_plus_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FTZ_exp.
unfold Prec_gt_0 in *.
-unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
+unfold round_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
- destruct (Z.ltb_spec (ex + 1 - prec) emin);
destruct (Z.ltb_spec (ex - prec') emin');
destruct (Z.ltb_spec (ey - prec) emin);
@@ -1775,58 +1767,58 @@ unfold double_round_plus_hyp; split; [|split; [|split]]; intros ex ey.
omega.
Qed.
-Theorem double_round_plus_FTZ :
+Theorem round_round_plus_FTZ :
forall choice1 choice2,
(emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z ->
forall x y,
FTZ_format beta emin prec x -> FTZ_format beta emin prec y ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (x + y).
Proof.
intros choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_plus.
+apply round_round_plus.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_plus_hyp.
+- now apply FTZ_round_round_plus_hyp.
- now apply generic_format_FTZ.
- now apply generic_format_FTZ.
Qed.
-Theorem double_round_minus_FTZ :
+Theorem round_round_minus_FTZ :
forall choice1 choice2,
(emin' + prec' <= emin + 1)%Z -> (2 * prec + 1 <= prec')%Z ->
forall x y,
FTZ_format beta emin prec x -> FTZ_format beta emin prec y ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (x - y).
Proof.
intros choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_minus.
+apply round_round_minus.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_plus_hyp.
+- now apply FTZ_round_round_plus_hyp.
- now apply generic_format_FTZ.
- now apply generic_format_FTZ.
Qed.
End Double_round_plus_FTZ.
-Section Double_round_plus_beta_ge_3.
+Section Double_round_plus_radix_ge_3.
-Definition double_round_plus_beta_ge_3_hyp fexp1 fexp2 :=
+Definition round_round_plus_radix_ge_3_hyp fexp1 fexp2 :=
(forall ex ey, (fexp1 (ex + 1) <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (fexp1 (ex - 1) + 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (fexp1 ex <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z)
/\ (forall ex ey, (ex - 1 <= ey)%Z -> (fexp2 ex <= fexp1 ey)%Z).
-(* fexp1 (ln_beta x) <= ln_beta y :
+(* fexp1 (mag x) <= mag y :
* addition is exact in the largest precision (fexp2). *)
-Lemma double_round_plus_beta_ge_3_aux0 :
+Lemma round_round_plus_radix_ge_3_aux0 :
forall (fexp1 fexp2 : Z -> Z), Valid_exp fexp1 ->
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
(0 < y)%R -> (y <= x)%R ->
- (fexp1 (ln_beta x) <= ln_beta y)%Z ->
+ (fexp1 (mag x) <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x + y).
Proof.
@@ -1834,84 +1826,84 @@ intros fexp1 fexp2 Vfexp1 Hexp x y Py Hyx Hln Fx Fy.
assert (Px := Rlt_le_trans 0 y x Py Hyx).
assert (Nny : (0 <= y)%R); [now apply Rlt_le|].
destruct Hexp as (_,(Hexp2,(Hexp3,Hexp4))).
-destruct (Z.le_gt_cases (ln_beta y) (fexp1 (ln_beta x))) as [Hle|Hgt].
-- (* ln_beta y <= fexp1 (ln_beta x) *)
- assert (Lxy : ln_beta (x + y) = ln_beta x :> Z);
- [now apply (ln_beta_plus_separated fexp1)|].
- apply (double_round_plus_aux0_aux fexp1);
+destruct (Z.le_gt_cases (mag y) (fexp1 (mag x))) as [Hle|Hgt].
+- (* mag y <= fexp1 (mag x) *)
+ assert (Lxy : mag (x + y) = mag x :> Z);
+ [now apply (mag_plus_separated fexp1)|].
+ apply (round_round_plus_aux0_aux fexp1);
[| |assumption|assumption]; rewrite Lxy.
+ now apply Hexp4; omega.
+ now apply Hexp3; omega.
-- (* fexp1 (ln_beta x) < ln_beta y *)
- apply (double_round_plus_aux0_aux fexp1); [| |assumption|assumption].
- destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+- (* fexp1 (mag x) < mag y *)
+ apply (round_round_plus_aux0_aux fexp1); [| |assumption|assumption].
+ destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+ now apply Hexp4; omega.
- + apply Hexp2; apply (ln_beta_le beta y x Py) in Hyx.
- replace (_ - _)%Z with (ln_beta x : Z) by ring.
+ + apply Hexp2; apply (mag_le beta y x Py) in Hyx.
+ replace (_ - _)%Z with (mag x : Z) by ring.
omega.
- + destruct (ln_beta_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
+ + destruct (mag_plus_disj x y Py Hyx) as [Lxy|Lxy]; rewrite Lxy.
* now apply Hexp3; omega.
* apply Hexp2.
- replace (_ - _)%Z with (ln_beta x : Z) by ring.
+ replace (_ - _)%Z with (mag x : Z) by ring.
omega.
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 1 : double_round_lt_mid applies. *)
-Lemma double_round_plus_beta_ge_3_aux1 :
+(* mag y <= fexp1 (mag x) - 1 : round_round_lt_mid applies. *)
+Lemma round_round_plus_radix_ge_3_aux1 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
- (ln_beta y <= fexp1 (ln_beta x) - 1)%Z ->
+ (mag y <= fexp1 (mag x) - 1)%Z ->
generic_format beta fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Hly Fx.
-assert (Lxy : ln_beta (x + y) = ln_beta x :> Z);
- [now apply (ln_beta_plus_separated fexp1); [|apply Rlt_le| |omega]|].
+assert (Lxy : mag (x + y) = mag x :> Z);
+ [now apply (mag_plus_separated fexp1); [|apply Rlt_le| |omega]|].
destruct Hexp as (_,(_,(_,Hexp4))).
-assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z);
+assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z);
[now apply Hexp4; omega|].
assert (Bpow3 : bpow (- 1) <= / 3).
-{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+{ unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- now change 3 with (Z2R 3); apply Z2R_le. }
+ now apply IZR_le. }
assert (P1 : (0 < 1)%Z) by omega.
-unfold double_round_eq.
-apply double_round_lt_mid.
+unfold round_round_eq.
+apply round_round_lt_mid.
- exact Vfexp1.
- exact Vfexp2.
- lra.
- now rewrite Lxy.
- rewrite Lxy.
- assert (fexp1 (ln_beta x) < ln_beta x)%Z; [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+ assert (fexp1 (mag x) < mag x)%Z; [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- unfold midp.
apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))).
- apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px
+ apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px
Py Hly Lxy Fx))).
ring_simplify.
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold canonic_exp; rewrite Lxy.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ unfold cexp; rewrite Lxy.
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
bpow_simplify.
apply (Rle_trans _ _ _ Bpow3); lra.
- rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl; rewrite Lxy.
+ unfold round, F2R, scaled_mantissa, cexp; simpl; rewrite Lxy.
intro Hf2'.
unfold midp.
apply (Rplus_lt_reg_r (- round beta fexp1 Zfloor (x + y))); ring_simplify.
rewrite <- Rmult_minus_distr_l.
- apply (Rlt_le_trans _ _ _ (proj2 (double_round_plus_aux1_aux 1 P1 fexp1 x y Px
+ apply (Rlt_le_trans _ _ _ (proj2 (round_round_plus_aux1_aux 1 P1 fexp1 x y Px
Py Hly Lxy Fx))).
rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rplus_lt_0_compat].
- unfold canonic_exp; rewrite Lxy.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ unfold cexp; rewrite Lxy.
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite (Rmult_assoc (/ 2)).
rewrite Rmult_minus_distr_r.
@@ -1925,47 +1917,47 @@ apply double_round_lt_mid.
now apply Rle_trans with (bpow (- 1)); [apply bpow_le; omega|].
Qed.
-(* double_round_plus_beta_ge_3_aux{0,1} together *)
-Lemma double_round_plus_beta_ge_3_aux2 :
+(* round_round_plus_radix_ge_3_aux{0,1} together *)
+Lemma round_round_plus_radix_ge_3_aux2 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y <= x ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy.
assert (Px := Rlt_le_trans 0 y x Py Hyx).
-unfold double_round_eq.
-destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly].
-- (* ln_beta y <= fexp1 (ln_beta x) - 1 *)
- now apply double_round_plus_beta_ge_3_aux1.
-- (* fexp1 (ln_beta x) - 1 < ln_beta y *)
+unfold round_round_eq.
+destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly].
+- (* mag y <= fexp1 (mag x) - 1 *)
+ now apply round_round_plus_radix_ge_3_aux1.
+- (* fexp1 (mag x) - 1 < mag y *)
rewrite (round_generic beta fexp2).
+ reflexivity.
+ now apply valid_rnd_N.
- + assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|].
- now apply (double_round_plus_beta_ge_3_aux0 fexp1).
+ + assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|].
+ now apply (round_round_plus_radix_ge_3_aux0 fexp1).
Qed.
-Lemma double_round_plus_beta_ge_3_aux :
+Lemma round_round_plus_radix_ge_3_aux :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 <= x -> 0 <= y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec x 0) as [Zx|Nzx].
- (* x = 0 *)
destruct Hexp as (_,(_,(_,Hexp4))).
@@ -1973,7 +1965,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
+ reflexivity.
+ now apply valid_rnd_N.
- + apply (generic_inclusion_ln_beta beta fexp1).
+ + apply (generic_inclusion_mag beta fexp1).
now intros _; apply Hexp4; omega.
exact Fy.
- (* x <> 0 *)
@@ -1984,7 +1976,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
now intros _; apply Hexp4; omega.
exact Fx.
+ (* y <> 0 *)
@@ -1994,156 +1986,156 @@ destruct (Req_dec x 0) as [Zx|Nzx].
* (* x < y *)
apply Rlt_le in H.
rewrite Rplus_comm.
- now apply double_round_plus_beta_ge_3_aux2.
- * now apply double_round_plus_beta_ge_3_aux2.
+ now apply round_round_plus_radix_ge_3_aux2.
+ * now apply round_round_plus_radix_ge_3_aux2.
Qed.
-(* fexp1 (ln_beta x) <= ln_beta y :
+(* fexp1 (mag x) <= mag y :
* substraction is exact in the largest precision (fexp2). *)
-Lemma double_round_minus_beta_ge_3_aux0 :
+Lemma round_round_minus_radix_ge_3_aux0 :
forall (fexp1 fexp2 : Z -> Z),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (fexp1 (ln_beta x) <= ln_beta y)%Z ->
+ (fexp1 (mag x) <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x - y).
Proof.
intros fexp1 fexp2 Hexp x y Py Hyx Hln Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hyx).
destruct Hexp as (Hexp1,(_,(Hexp3,Hexp4))).
-assert (Lyx : (ln_beta y <= ln_beta x)%Z);
- [now apply ln_beta_le; [|apply Rlt_le]|].
-destruct (Z.lt_ge_cases (ln_beta x - 2) (ln_beta y)) as [Hlt|Hge].
-- (* ln_beta x - 2 < ln_beta y *)
- assert (Hor : (ln_beta y = ln_beta x :> Z)
- \/ (ln_beta y = ln_beta x - 1 :> Z)%Z); [omega|].
+assert (Lyx : (mag y <= mag x)%Z);
+ [now apply mag_le; [|apply Rlt_le]|].
+destruct (Z.lt_ge_cases (mag x - 2) (mag y)) as [Hlt|Hge].
+- (* mag x - 2 < mag y *)
+ assert (Hor : (mag y = mag x :> Z)
+ \/ (mag y = mag x - 1 :> Z)%Z); [omega|].
destruct Hor as [Heq|Heqm1].
- + (* ln_beta y = ln_beta x *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ + (* mag y = mag x *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
* rewrite Heq.
apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
- + (* ln_beta y = ln_beta x - 1 *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
+ + (* mag y = mag x - 1 *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
- apply Zle_trans with (ln_beta (x - y)); [omega|].
- now apply ln_beta_minus.
+ apply Z.le_trans with (mag (x - y)); [omega|].
+ now apply mag_minus.
* rewrite Heqm1.
apply Hexp4.
apply Zplus_le_compat_r.
- now apply ln_beta_minus.
-- (* ln_beta y <= ln_beta x - 2 *)
- destruct (ln_beta_minus_disj x y Px Py Hge) as [Lxmy|Lxmy].
- + (* ln_beta (x - y) = ln_beta x *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+ now apply mag_minus.
+- (* mag y <= mag x - 2 *)
+ destruct (mag_minus_disj x y Px Py Hge) as [Lxmy|Lxmy].
+ + (* mag (x - y) = mag x *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
* apply Hexp4.
omega.
* now rewrite Lxmy; apply Hexp3.
- + (* ln_beta (x - y) = ln_beta x - 1 *)
- apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy];
+ + (* mag (x - y) = mag x - 1 *)
+ apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy];
rewrite Lxmy.
* apply Hexp1.
- replace (_ + _)%Z with (ln_beta x : Z); [|ring].
- now apply Zle_trans with (ln_beta y).
+ replace (_ + _)%Z with (mag x : Z); [|ring].
+ now apply Z.le_trans with (mag y).
* apply Hexp1.
- now replace (_ + _)%Z with (ln_beta x : Z); [|ring].
+ now replace (_ + _)%Z with (mag x : Z); [|ring].
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 1,
- * fexp1 (ln_beta (x - y)) <= ln_beta y :
+(* mag y <= fexp1 (mag x) - 1,
+ * fexp1 (mag (x - y)) <= mag y :
* substraction is exact in the largest precision (fexp2). *)
-Lemma double_round_minus_beta_ge_3_aux1 :
+Lemma round_round_minus_radix_ge_3_aux1 :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (ln_beta y <= fexp1 (ln_beta x) - 1)%Z ->
- (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z ->
+ (mag y <= fexp1 (mag x) - 1)%Z ->
+ (fexp1 (mag (x - y)) <= mag y)%Z ->
generic_format beta fexp1 x -> generic_format beta fexp1 y ->
generic_format beta fexp2 (x - y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 Hexp x y Py Hyx Hln Hln' Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hyx).
destruct Hexp as (Hexp1,(Hexp2,(Hexp3,Hexp4))).
-assert (Lyx : (ln_beta y <= ln_beta x)%Z);
- [now apply ln_beta_le; [|apply Rlt_le]|].
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-apply (double_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
-- apply Zle_trans with (fexp1 (ln_beta (x - y))).
+assert (Lyx : (mag y <= mag x)%Z);
+ [now apply mag_le; [|apply Rlt_le]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp1 (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+apply (round_round_minus_aux0_aux fexp1); [| |exact Fx|exact Fy].
+- apply Z.le_trans with (fexp1 (mag (x - y))).
+ apply Hexp4; omega.
+ omega.
- now apply Hexp3.
Qed.
-(* ln_beta y <= fexp1 (ln_beta x) - 1 :
- * ln_beta y <= fexp1 (ln_beta (x - y)) - 1 :
- * double_round_gt_mid applies. *)
-Lemma double_round_minus_beta_ge_3_aux2 :
+(* mag y <= fexp1 (mag x) - 1 :
+ * mag y <= fexp1 (mag (x - y)) - 1 :
+ * round_round_gt_mid applies. *)
+Lemma round_round_minus_radix_ge_3_aux2 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y < x ->
- (ln_beta y <= fexp1 (ln_beta x) - 1)%Z ->
- (ln_beta y <= fexp1 (ln_beta (x - y)) - 1)%Z ->
+ (mag y <= fexp1 (mag x) - 1)%Z ->
+ (mag y <= fexp1 (mag (x - y)) - 1)%Z ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hxy Hly Hly' Fx Fy.
assert (Px := Rlt_trans 0 y x Py Hxy).
destruct Hexp as (_,(_,(_,Hexp4))).
-assert (Hf2 : (fexp2 (ln_beta x) <= fexp1 (ln_beta x))%Z);
+assert (Hf2 : (fexp2 (mag x) <= fexp1 (mag x))%Z);
[now apply Hexp4; omega|].
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
assert (Bpow3 : bpow (- 1) <= / 3).
-{ unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+{ unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- now change 3 with (Z2R 3); apply Z2R_le. }
-assert (Ly : y < bpow (ln_beta y)).
+ now apply IZR_le. }
+assert (Ly : y < bpow (mag y)).
{ apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
-unfold double_round_eq.
-apply double_round_gt_mid.
+ apply bpow_mag_gt. }
+unfold round_round_eq.
+apply round_round_gt_mid.
- exact Vfexp1.
- exact Vfexp2.
- lra.
- apply Hexp4; omega.
-- assert (fexp1 (ln_beta (x - y)) < ln_beta (x - y))%Z; [|omega].
- apply (valid_exp_large fexp1 (ln_beta x - 1)).
- + apply (valid_exp_large fexp1 (ln_beta y)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
- + now apply ln_beta_minus_lb; [| |omega].
+- assert (fexp1 (mag (x - y)) < mag (x - y))%Z; [|omega].
+ apply (valid_exp_large fexp1 (mag x - 1)).
+ + apply (valid_exp_large fexp1 (mag y)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
+ + now apply mag_minus_lb; [| |omega].
- unfold midp'.
apply (Rplus_lt_reg_r (/ 2 * ulp beta fexp1 (x - y) - (x - y))).
ring_simplify.
replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring.
- apply Rlt_le_trans with (bpow (fexp1 (ln_beta (x - y)) - 1)).
+ apply Rlt_le_trans with (bpow (fexp1 (mag (x - y)) - 1)).
+ apply Rle_lt_trans with y;
- [now apply double_round_minus_aux2_aux|].
+ [now apply round_round_minus_aux2_aux|].
apply (Rlt_le_trans _ _ _ Ly).
now apply bpow_le.
+ rewrite ulp_neq_0;[idtac|now apply Rgt_not_eq, Rgt_minus].
- unfold canonic_exp.
+ unfold cexp.
unfold Zminus at 1; rewrite bpow_plus.
rewrite Rmult_comm.
apply Rmult_le_compat_r; [now apply bpow_ge_0|].
- unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le; [lra|].
- now change 2 with (Z2R 2); apply Z2R_le; omega.
+ now apply IZR_le; omega.
- intro Hf2'.
unfold midp'.
apply (Rplus_lt_reg_r (/ 2 * (ulp beta fexp1 (x - y)
@@ -2151,21 +2143,21 @@ apply double_round_gt_mid.
ring_simplify; rewrite <- Rmult_minus_distr_l.
replace (_ + _) with (round beta fexp1 Zceil (x - y) - (x - y)) by ring.
apply Rle_lt_trans with y;
- [now apply double_round_minus_aux2_aux|].
+ [now apply round_round_minus_aux2_aux|].
apply (Rlt_le_trans _ _ _ Ly).
- apply Rle_trans with (bpow (fexp1 (ln_beta (x - y)) - 1));
+ apply Rle_trans with (bpow (fexp1 (mag (x - y)) - 1));
[now apply bpow_le|].
rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, Rgt_minus.
- unfold canonic_exp.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x - y)))));
+ unfold cexp.
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x - y)))));
[now apply bpow_gt_0|].
rewrite Rmult_assoc.
rewrite Rmult_minus_distr_r.
bpow_simplify.
apply Rle_trans with (/ 3).
- + unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ + unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le; [lra|].
- now change 3 with (Z2R 3); apply Z2R_le.
+ now apply IZR_le.
+ replace (/ 3) with (/ 2 * (2 / 3)) by field.
apply Rmult_le_compat_l; [lra|].
apply (Rplus_le_reg_r (- 1)); ring_simplify.
@@ -2173,27 +2165,27 @@ apply double_round_gt_mid.
apply Ropp_le_contravar.
apply Rle_trans with (bpow (- 1)).
* apply bpow_le; omega.
- * unfold Fcore_Raux.bpow, Z.pow_pos; simpl.
+ * unfold Raux.bpow, Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le; [lra|].
- now change 3 with (Z2R 3); apply Z2R_le.
+ now apply IZR_le.
Qed.
-(* double_round_minus_aux{0,1,2} together *)
-Lemma double_round_minus_beta_ge_3_aux3 :
+(* round_round_minus_aux{0,1,2} together *)
+Lemma round_round_minus_radix_ge_3_aux3 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 < y -> y <= x ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Py Hyx Fx Fy.
assert (Px := Rlt_le_trans 0 y x Py Hyx).
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec y x) as [Hy|Hy].
- (* y = x *)
rewrite Hy; replace (x - x) with 0 by ring.
@@ -2202,39 +2194,39 @@ destruct (Req_dec y x) as [Hy|Hy].
+ now apply valid_rnd_N.
- (* y < x *)
assert (Hyx' : y < x); [lra|].
- destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta x) - 1)) as [Hly|Hly].
- + (* ln_beta y <= fexp1 (ln_beta x) - 1 *)
- destruct (Zle_or_lt (ln_beta y) (fexp1 (ln_beta (x - y)) - 1))
+ destruct (Zle_or_lt (mag y) (fexp1 (mag x) - 1)) as [Hly|Hly].
+ + (* mag y <= fexp1 (mag x) - 1 *)
+ destruct (Zle_or_lt (mag y) (fexp1 (mag (x - y)) - 1))
as [Hly'|Hly'].
- * (* ln_beta y <= fexp1 (ln_beta (x - y)) - 1 *)
- now apply double_round_minus_beta_ge_3_aux2.
- * (* fexp1 (ln_beta (x - y)) - 1 < ln_beta y *)
+ * (* mag y <= fexp1 (mag (x - y)) - 1 *)
+ now apply round_round_minus_radix_ge_3_aux2.
+ * (* fexp1 (mag (x - y)) - 1 < mag y *)
{ rewrite (round_generic beta fexp2).
- reflexivity.
- now apply valid_rnd_N.
- - assert (Hf1 : (fexp1 (ln_beta (x - y)) <= ln_beta y)%Z); [omega|].
- now apply (double_round_minus_beta_ge_3_aux1 fexp1). }
+ - assert (Hf1 : (fexp1 (mag (x - y)) <= mag y)%Z); [omega|].
+ now apply (round_round_minus_radix_ge_3_aux1 fexp1). }
+ rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * assert (Hf1 : (fexp1 (ln_beta x) <= ln_beta y)%Z); [omega|].
- now apply (double_round_minus_beta_ge_3_aux0 fexp1).
+ * assert (Hf1 : (fexp1 (mag x) <= mag y)%Z); [omega|].
+ now apply (round_round_minus_radix_ge_3_aux0 fexp1).
Qed.
-Lemma double_round_minus_beta_ge_3_aux :
+Lemma round_round_minus_radix_ge_3_aux :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
0 <= x -> 0 <= y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Nnx Nny Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Req_dec x 0) as [Zx|Nzx].
- (* x = 0 *)
rewrite Zx; unfold Rminus; rewrite Rplus_0_l.
@@ -2242,7 +2234,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
destruct Hexp as (_,(_,(_,Hexp4))).
now intros _; apply Hexp4; omega.
exact Fy.
@@ -2253,7 +2245,7 @@ destruct (Req_dec x 0) as [Zx|Nzx].
rewrite (round_generic beta fexp2).
* reflexivity.
* now apply valid_rnd_N.
- * apply (generic_inclusion_ln_beta beta fexp1).
+ * apply (generic_inclusion_mag beta fexp1).
destruct Hexp as (_,(_,(_,Hexp4))).
now intros _; apply Hexp4; omega.
exact Fx.
@@ -2266,24 +2258,24 @@ destruct (Req_dec x 0) as [Zx|Nzx].
replace (x - y) with (- (y - x)) by ring.
do 3 rewrite round_N_opp.
apply Ropp_eq_compat.
- now apply double_round_minus_beta_ge_3_aux3.
+ now apply round_round_minus_radix_ge_3_aux3.
* (* y <= x *)
- now apply double_round_minus_beta_ge_3_aux3.
+ now apply round_round_minus_radix_ge_3_aux3.
Qed.
-Lemma double_round_plus_beta_ge_3 :
+Lemma round_round_plus_radix_ge_3 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x + y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x + y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy].
- (* x < 0, y < 0 *)
replace (x + y) with (- (- x - y)); [|ring].
@@ -2293,41 +2285,39 @@ destruct (Rlt_or_le x 0) as [Sx|Sx]; destruct (Rlt_or_le y 0) as [Sy|Sy].
assert (Py : 0 <= - y); [lra|].
apply generic_format_opp in Fx.
apply generic_format_opp in Fy.
- now apply double_round_plus_beta_ge_3_aux.
+ now apply round_round_plus_radix_ge_3_aux.
- (* x < 0, 0 <= y *)
replace (x + y) with (y - (- x)); [|ring].
assert (Px : 0 <= - x); [lra|].
apply generic_format_opp in Fx.
- now apply double_round_minus_beta_ge_3_aux.
+ now apply round_round_minus_radix_ge_3_aux.
- (* 0 <= x, y < 0 *)
replace (x + y) with (x - (- y)); [|ring].
assert (Py : 0 <= - y); [lra|].
apply generic_format_opp in Fy.
- now apply double_round_minus_beta_ge_3_aux.
+ now apply round_round_minus_radix_ge_3_aux.
- (* 0 <= x, 0 <= y *)
- now apply double_round_plus_beta_ge_3_aux.
+ now apply round_round_plus_radix_ge_3_aux.
Qed.
-Lemma double_round_minus_beta_ge_3 :
+Lemma round_round_minus_radix_ge_3 :
(3 <= beta)%Z ->
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_plus_beta_ge_3_hyp fexp1 fexp2 ->
+ round_round_plus_radix_ge_3_hyp fexp1 fexp2 ->
forall x y,
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x - y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x - y).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Fx Fy.
unfold Rminus.
apply generic_format_opp in Fy.
-now apply double_round_plus_beta_ge_3.
+now apply round_round_plus_radix_ge_3.
Qed.
-Section Double_round_plus_beta_ge_3_FLX.
-
-Import Fcore_FLX.
+Section Double_round_plus_radix_ge_3_FLX.
Variable prec : Z.
Variable prec' : Z.
@@ -2335,60 +2325,57 @@ Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLX_double_round_plus_beta_ge_3_hyp :
+Lemma FLX_round_round_plus_radix_ge_3_hyp :
(2 * prec <= prec')%Z ->
- double_round_plus_beta_ge_3_hyp (FLX_exp prec) (FLX_exp prec').
+ round_round_plus_radix_ge_3_hyp (FLX_exp prec) (FLX_exp prec').
Proof.
intros Hprec.
unfold FLX_exp.
-unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]];
+unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]];
intros ex ey; try omega.
unfold Prec_gt_0 in prec_gt_0_.
omega.
Qed.
-Theorem double_round_plus_beta_ge_3_FLX :
+Theorem round_round_plus_radix_ge_3_FLX :
(3 <= beta)%Z ->
forall choice1 choice2,
(2 * prec <= prec')%Z ->
forall x y,
FLX_format beta prec x -> FLX_format beta prec y ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x + y).
Proof.
intros Hbeta choice1 choice2 Hprec x y Fx Fy.
-apply double_round_plus_beta_ge_3.
+apply round_round_plus_radix_ge_3.
- exact Hbeta.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_plus_beta_ge_3_hyp.
+- now apply FLX_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FLX.
- now apply generic_format_FLX.
Qed.
-Theorem double_round_minus_beta_ge_3_FLX :
+Theorem round_round_minus_radix_ge_3_FLX :
(3 <= beta)%Z ->
forall choice1 choice2,
(2 * prec <= prec')%Z ->
forall x y,
FLX_format beta prec x -> FLX_format beta prec y ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x - y).
Proof.
intros Hbeta choice1 choice2 Hprec x y Fx Fy.
-apply double_round_minus_beta_ge_3.
+apply round_round_minus_radix_ge_3.
- exact Hbeta.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_plus_beta_ge_3_hyp.
+- now apply FLX_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FLX.
- now apply generic_format_FLX.
Qed.
-End Double_round_plus_beta_ge_3_FLX.
-
-Section Double_round_plus_beta_ge_3_FLT.
+End Double_round_plus_radix_ge_3_FLX.
-Import Fcore_FLX.
-Import Fcore_FLT.
+Section Double_round_plus_radix_ge_3_FLT.
Variable emin prec : Z.
Variable emin' prec' : Z.
@@ -2396,13 +2383,13 @@ Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLT_double_round_plus_beta_ge_3_hyp :
+Lemma FLT_round_round_plus_radix_ge_3_hyp :
(emin' <= emin)%Z -> (2 * prec <= prec')%Z ->
- double_round_plus_beta_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
+ round_round_plus_radix_ge_3_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FLT_exp.
-unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
+unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
- generalize (Zmax_spec (ex + 1 - prec) emin).
generalize (Zmax_spec (ex - prec') emin').
generalize (Zmax_spec (ey - prec) emin).
@@ -2421,50 +2408,47 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
omega.
Qed.
-Theorem double_round_plus_beta_ge_3_FLT :
+Theorem round_round_plus_radix_ge_3_FLT :
(3 <= beta)%Z ->
forall choice1 choice2,
(emin' <= emin)%Z -> (2 * prec <= prec')%Z ->
forall x y,
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (x + y).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_plus_beta_ge_3.
+apply round_round_plus_radix_ge_3.
- exact Hbeta.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_plus_beta_ge_3_hyp.
+- now apply FLT_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FLT.
- now apply generic_format_FLT.
Qed.
-Theorem double_round_minus_beta_ge_3_FLT :
+Theorem round_round_minus_radix_ge_3_FLT :
(3 <= beta)%Z ->
forall choice1 choice2,
(emin' <= emin)%Z -> (2 * prec <= prec')%Z ->
forall x y,
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (x - y).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_minus_beta_ge_3.
+apply round_round_minus_radix_ge_3.
- exact Hbeta.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_plus_beta_ge_3_hyp.
+- now apply FLT_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FLT.
- now apply generic_format_FLT.
Qed.
-End Double_round_plus_beta_ge_3_FLT.
+End Double_round_plus_radix_ge_3_FLT.
-Section Double_round_plus_beta_ge_3_FTZ.
-
-Import Fcore_FLX.
-Import Fcore_FTZ.
+Section Double_round_plus_radix_ge_3_FTZ.
Variable emin prec : Z.
Variable emin' prec' : Z.
@@ -2472,14 +2456,14 @@ Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FTZ_double_round_plus_beta_ge_3_hyp :
+Lemma FTZ_round_round_plus_radix_ge_3_hyp :
(emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z ->
- double_round_plus_beta_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
+ round_round_plus_radix_ge_3_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FTZ_exp.
unfold Prec_gt_0 in *.
-unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
+unfold round_round_plus_radix_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
- destruct (Z.ltb_spec (ex + 1 - prec) emin);
destruct (Z.ltb_spec (ex - prec') emin');
destruct (Z.ltb_spec (ey - prec) emin);
@@ -2497,64 +2481,64 @@ unfold double_round_plus_beta_ge_3_hyp; split; [|split; [|split]]; intros ex ey.
omega.
Qed.
-Theorem double_round_plus_beta_ge_3_FTZ :
+Theorem round_round_plus_radix_ge_3_FTZ :
(3 <= beta)%Z ->
forall choice1 choice2,
(emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z ->
forall x y,
FTZ_format beta emin prec x -> FTZ_format beta emin prec y ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (x + y).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_plus_beta_ge_3.
+apply round_round_plus_radix_ge_3.
- exact Hbeta.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_plus_beta_ge_3_hyp.
+- now apply FTZ_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FTZ.
- now apply generic_format_FTZ.
Qed.
-Theorem double_round_minus_beta_ge_3_FTZ :
+Theorem round_round_minus_radix_ge_3_FTZ :
(3 <= beta)%Z ->
forall choice1 choice2,
(emin' + prec' <= emin + 1)%Z -> (2 * prec <= prec')%Z ->
forall x y,
FTZ_format beta emin prec x -> FTZ_format beta emin prec y ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (x - y).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x y Fx Fy.
-apply double_round_minus_beta_ge_3.
+apply round_round_minus_radix_ge_3.
- exact Hbeta.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_plus_beta_ge_3_hyp.
+- now apply FTZ_round_round_plus_radix_ge_3_hyp.
- now apply generic_format_FTZ.
- now apply generic_format_FTZ.
Qed.
-End Double_round_plus_beta_ge_3_FTZ.
+End Double_round_plus_radix_ge_3_FTZ.
-End Double_round_plus_beta_ge_3.
+End Double_round_plus_radix_ge_3.
End Double_round_plus.
-Lemma double_round_mid_cases :
+Lemma round_round_mid_cases :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
(Rabs (x - midp fexp1 x) <= / 2 * (ulp beta fexp2 x) ->
- double_round_eq fexp1 fexp2 choice1 choice2 x) ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x) ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2f1 Hf1.
-unfold double_round_eq, midp.
+unfold round_round_eq, midp.
set (rd := round beta fexp1 Zfloor x).
set (u1 := ulp beta fexp1 x).
set (u2 := ulp beta fexp2 x).
@@ -2562,14 +2546,14 @@ intros Cmid.
destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx].
- (* generic_format beta fexp1 x *)
rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|].
- now apply (generic_inclusion_ln_beta beta fexp1); [omega|].
+ now apply (generic_inclusion_mag beta fexp1); [omega|].
- (* ~ generic_format beta fexp1 x *)
assert (Hceil : round beta fexp1 Zceil x = rd + u1);
[now apply round_UP_DN_ulp|].
- assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z); [omega|].
+ assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z); [omega|].
destruct (Rlt_or_le (x - rd) (/ 2 * (u1 - u2))).
+ (* x - rd < / 2 * (u1 - u2) *)
- apply double_round_lt_mid_further_place; try assumption.
+ apply round_round_lt_mid_further_place; try assumption.
unfold midp. fold rd; fold u1; fold u2.
apply (Rplus_lt_reg_r (- rd)); ring_simplify.
now rewrite <- Rmult_minus_distr_l.
@@ -2580,7 +2564,7 @@ destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx].
< / 2 * (ulp beta fexp1 x - ulp beta fexp2 x)).
{ rewrite Hceil; fold u1; fold u2.
lra. }
- apply double_round_gt_mid_further_place; try assumption.
+ apply round_round_gt_mid_further_place; try assumption.
unfold midp'; lra.
- (* x - rd <= / 2 * (u1 + u2) *)
apply Cmid, Rabs_le; split; lra. }
@@ -2588,31 +2572,31 @@ Qed.
Section Double_round_sqrt.
-Definition double_round_sqrt_hyp fexp1 fexp2 :=
+Definition round_round_sqrt_hyp fexp1 fexp2 :=
(forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z)
/\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z)
/\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z ->
(fexp2 ex + ex <= 2 * fexp1 ex - 2)%Z).
-Lemma ln_beta_sqrt_disj :
+Lemma mag_sqrt_disj :
forall x,
0 < x ->
- (ln_beta x = 2 * ln_beta (sqrt x) - 1 :> Z)%Z
- \/ (ln_beta x = 2 * ln_beta (sqrt x) :> Z)%Z.
+ (mag x = 2 * mag (sqrt x) - 1 :> Z)%Z
+ \/ (mag x = 2 * mag (sqrt x) :> Z)%Z.
Proof.
intros x Px.
-generalize (ln_beta_sqrt beta x Px).
-intro H.
-omega.
+rewrite (mag_sqrt beta x Px).
+generalize (Zdiv2_odd_eqn (mag x + 1)).
+destruct Z.odd ; intros ; omega.
Qed.
-Lemma double_round_sqrt_aux :
+Lemma round_round_sqrt_aux :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
- double_round_sqrt_hyp fexp1 fexp2 ->
+ round_round_sqrt_hyp fexp1 fexp2 ->
forall x,
0 < x ->
- (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z ->
+ (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z ->
generic_format beta fexp1 x ->
/ 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)).
Proof.
@@ -2621,8 +2605,8 @@ assert (Hbeta : (2 <= beta)%Z).
{ destruct beta as (beta_val,beta_prop).
now apply Zle_bool_imp_le. }
set (a := round beta fexp1 Zfloor (sqrt x)).
-set (u1 := bpow (fexp1 (ln_beta (sqrt x)))).
-set (u2 := bpow (fexp2 (ln_beta (sqrt x)))).
+set (u1 := bpow (fexp1 (mag (sqrt x)))).
+set (u2 := bpow (fexp2 (mag (sqrt x)))).
set (b := / 2 * (u1 - u2)).
set (b' := / 2 * (u1 + u2)).
unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0.
@@ -2633,9 +2617,9 @@ assert (Fa : generic_format beta fexp1 a).
- exact Vfexp1.
- now apply valid_rnd_DN. }
revert Fa; revert Fx.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
-set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))).
+set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))).
intros Fx Fa.
assert (Nna : 0 <= a).
{ rewrite <- (round_0 beta fexp1 Zfloor).
@@ -2666,14 +2650,14 @@ assert (Hl : a + b <= sqrt x).
replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring.
rewrite Ropp_mult_distr_l_reverse.
now apply Rabs_le_inv in H; destruct H. }
-assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z);
- [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|].
-assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z).
-{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx].
- - apply (valid_exp_large fexp1 (ln_beta x)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z);
+ [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|].
+assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z).
+{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx].
+ - apply (valid_exp_large fexp1 (mag x)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- rewrite <- Hlx.
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. }
+ now apply mag_generic_gt; [|apply Rgt_not_eq|]. }
assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x).
{ replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field].
rewrite <- sqrt_def; [|now apply Rlt_le].
@@ -2692,34 +2676,33 @@ destruct (Req_dec a 0) as [Za|Nza].
+ revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r.
now rewrite Ropp_0; do 3 rewrite Rplus_0_l.
+ rewrite Fx.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_0_l; bpow_simplify.
unfold mx.
rewrite Ztrunc_floor;
[|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]].
- apply Req_le.
- change 0 with (Z2R 0); apply f_equal.
+ apply Req_le, IZR_eq.
apply Zfloor_imp.
split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_1_l; bpow_simplify.
- apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x))));
+ apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x))));
[|now apply bpow_le].
change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l.
rewrite bpow_plus.
rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le].
- assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x))));
+ assert (sqrt x < bpow (fexp1 (mag (sqrt x))));
[|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]].
apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l.
unfold b'; change (bpow _) with u1.
apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra].
apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l.
- unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega.
+ unfold u2, u1, ulp, cexp; apply bpow_lt; omega.
- (* a <> 0 *)
assert (Pa : 0 < a); [lra|].
- assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)).
- { unfold a; apply ln_beta_DN.
+ assert (Hla : (mag a = mag (sqrt x) :> Z)).
+ { unfold a; apply mag_DN.
- exact Vfexp1.
- now fold a. }
assert (Hl' : 0 < - (u2 * a) + b * b).
@@ -2728,60 +2711,60 @@ destruct (Req_dec a 0) as [Za|Nza].
apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify.
replace (_ / 2) with (u2 * (a + / 2 * u1)) by field.
replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field.
- apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))).
+ apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))).
- apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|].
unfold u1; rewrite <- Hla.
- apply Rlt_le_trans with (a + bpow (fexp1 (ln_beta a))).
+ apply Rlt_le_trans with (a + bpow (fexp1 (mag a))).
+ apply Rplus_lt_compat_l.
rewrite <- (Rmult_1_l (bpow _)) at 2.
apply Rmult_lt_compat_r; [apply bpow_gt_0|lra].
+ apply Rle_trans with (a+ ulp beta fexp1 a).
right; now rewrite ulp_neq_0.
apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa).
- apply Rabs_lt_inv, bpow_ln_beta_gt.
+ apply Rabs_lt_inv, bpow_mag_gt.
- apply Rle_trans with (bpow (- 2) * u1 ^ 2).
+ unfold pow; rewrite Rmult_1_r.
- unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
+ unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le.
now apply Hexp.
+ apply Rmult_le_compat.
* apply bpow_ge_0.
* apply pow2_ge_0.
- * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
+ * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- change 4 with (Z2R (2 * 2)%Z); apply Z2R_le, Zmult_le_compat; omega.
+ change 4%Z with (2 * 2)%Z; apply IZR_le, Zmult_le_compat; omega.
* rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r.
apply pow2_ge_0. }
assert (Hr' : x <= a * a + u1 * a).
{ rewrite Hla in Fa.
rewrite <- Rmult_plus_distr_r.
- unfold u1, ulp, canonic_exp.
+ unfold u1, ulp, cexp.
rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r.
- rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)).
- rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify.
- apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x)))));
+ rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)).
+ rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify.
+ apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x)))));
[now apply bpow_gt_0|bpow_simplify].
rewrite Fx at 1; bpow_simplify.
- rewrite <- Z2R_Zpower; [|omega].
- change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult.
- apply Z2R_le, Zlt_succ_le, lt_Z2R.
- unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus.
- rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x)))));
+ rewrite <- IZR_Zpower; [|omega].
+ rewrite <- plus_IZR, <- 2!mult_IZR.
+ apply IZR_le, Zlt_succ_le, lt_IZR.
+ unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR.
+ rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x)))));
[now apply bpow_gt_0|bpow_simplify].
rewrite <- Fx.
change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l.
rewrite bpow_plus; simpl.
replace (_ * _) with (a * a + u1 * a + u1 * u1);
- [|unfold u1, ulp, canonic_exp; rewrite Fa; ring].
+ [|unfold u1, ulp, cexp; rewrite Fa; ring].
apply (Rle_lt_trans _ _ _ Hsr).
rewrite Rplus_assoc; apply Rplus_lt_compat_l.
apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify.
replace (_ + _) with ((a + / 2 * u1) * u2) by ring.
- apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2).
+ apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2).
- apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|].
apply Rlt_le_trans with (a + u1); [lra|].
- unfold u1; fold (canonic_exp beta fexp1 (sqrt x)).
- rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a.
+ unfold u1; fold (cexp beta fexp1 (sqrt x)).
+ rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a.
rewrite <- ulp_neq_0; trivial.
apply id_p_ulp_le_bpow.
+ exact Pa.
@@ -2789,27 +2772,27 @@ destruct (Req_dec a 0) as [Za|Nza].
+ apply Rle_lt_trans with (sqrt x).
* now apply round_DN_pt.
* apply Rabs_lt_inv.
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
- apply Rle_trans with (/ 2 * u1 ^ 2).
+ apply Rle_trans with (bpow (- 2) * u1 ^ 2).
* unfold pow; rewrite Rmult_1_r.
- unfold u2, u1, ulp, canonic_exp.
+ unfold u2, u1, ulp, cexp.
bpow_simplify.
apply bpow_le.
rewrite Zplus_comm.
now apply Hexp.
* apply Rmult_le_compat_r; [now apply pow2_ge_0|].
- unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl.
+ unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- change 2 with (Z2R 2); apply Z2R_le.
+ apply IZR_le.
rewrite <- (Zmult_1_l 2).
apply Zmult_le_compat; omega.
+ assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra].
unfold pow; do 2 rewrite Rmult_1_r.
assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|].
assert (u2 < u1); [|now apply Rmult_lt_compat].
- unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. }
+ unfold u1, u2, ulp, cexp; apply bpow_lt; omega. }
apply (Rlt_irrefl (a * a + u1 * a)).
apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b).
+ rewrite <- (Rplus_0_r (a * a + _)) at 1.
@@ -2819,29 +2802,29 @@ destruct (Req_dec a 0) as [Za|Nza].
Qed.
-Lemma double_round_sqrt :
+Lemma round_round_sqrt :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_sqrt_hyp fexp1 fexp2 ->
+ round_round_sqrt_hyp fexp1 fexp2 ->
forall x,
generic_format beta fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x).
+ round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Rle_or_lt x 0) as [Npx|Px].
- (* x <= 0 *)
rewrite (sqrt_neg _ Npx).
now rewrite round_0; [|apply valid_rnd_N].
- (* 0 < x *)
- assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; try assumption; lra|].
- assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z).
+ assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; try assumption; lra|].
+ assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z).
{ destruct (Rle_or_lt x 1) as [Hx|Hx].
- (* x <= 1 *)
- apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|].
- apply ln_beta_le; [exact Px|].
+ apply (valid_exp_large fexp1 (mag x)); [exact Hfx|].
+ apply mag_le; [exact Px|].
rewrite <- (sqrt_def x) at 1; [|lra].
rewrite <- Rmult_1_r.
apply Rmult_le_compat_l.
@@ -2854,64 +2837,62 @@ destruct (Rle_or_lt x 0) as [Npx|Px].
intro Hexp10.
assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10].
apply (valid_exp_large fexp1 1); [exact Hf0|].
- apply ln_beta_ge_bpow.
+ apply mag_ge_bpow.
rewrite Zeq_minus; [|reflexivity].
- unfold Fcore_Raux.bpow; simpl.
+ unfold Raux.bpow; simpl.
apply Rabs_ge; right.
rewrite <- sqrt_1.
apply sqrt_le_1_alt.
now apply Rlt_le. }
- assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z).
- { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z).
- { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx].
- - apply (valid_exp_large fexp1 (ln_beta x)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+ assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z).
+ { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z).
+ { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx].
+ - apply (valid_exp_large fexp1 (mag x)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- rewrite <- Hlx.
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. }
- generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H).
+ now apply mag_generic_gt; [|apply Rgt_not_eq|]. }
+ generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H).
omega. }
- apply double_round_mid_cases.
+ apply round_round_mid_cases.
+ exact Vfexp1.
+ exact Vfexp2.
+ now apply sqrt_lt_R0.
+ omega.
+ omega.
+ intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid).
- apply (double_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx).
+ apply (round_round_sqrt_aux fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx).
Qed.
Section Double_round_sqrt_FLX.
-Import Fcore_FLX.
-
Variable prec : Z.
Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLX_double_round_sqrt_hyp :
+Lemma FLX_round_round_sqrt_hyp :
(2 * prec + 2 <= prec')%Z ->
- double_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec').
+ round_round_sqrt_hyp (FLX_exp prec) (FLX_exp prec').
Proof.
intros Hprec.
unfold FLX_exp.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_sqrt_hyp; split; [|split]; intro ex; omega.
+unfold round_round_sqrt_hyp; split; [|split]; intro ex; omega.
Qed.
-Theorem double_round_sqrt_FLX :
+Theorem round_round_sqrt_FLX :
forall choice1 choice2,
(2 * prec + 2 <= prec')%Z ->
forall x,
FLX_format beta prec x ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x).
Proof.
intros choice1 choice2 Hprec x Fx.
-apply double_round_sqrt.
+apply round_round_sqrt.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_sqrt_hyp.
+- now apply FLX_round_round_sqrt_hyp.
- now apply generic_format_FLX.
Qed.
@@ -2919,26 +2900,23 @@ End Double_round_sqrt_FLX.
Section Double_round_sqrt_FLT.
-Import Fcore_FLX.
-Import Fcore_FLT.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLT_double_round_sqrt_hyp :
+Lemma FLT_round_round_sqrt_hyp :
(emin <= 0)%Z ->
((emin' <= emin - prec - 2)%Z
\/ (2 * emin' <= emin - 4 * prec - 2)%Z) ->
(2 * prec + 2 <= prec')%Z ->
- double_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
+ round_round_sqrt_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
Proof.
intros Hemin Heminprec Hprec.
unfold FLT_exp.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_sqrt_hyp; split; [|split]; intros ex.
+unfold round_round_sqrt_hyp; split; [|split]; intros ex.
- generalize (Zmax_spec (ex - prec) emin).
generalize (Zmax_spec (2 * ex - prec) emin).
omega.
@@ -2951,7 +2929,7 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex.
omega.
Qed.
-Theorem double_round_sqrt_FLT :
+Theorem round_round_sqrt_FLT :
forall choice1 choice2,
(emin <= 0)%Z ->
((emin' <= emin - prec - 2)%Z
@@ -2959,14 +2937,14 @@ Theorem double_round_sqrt_FLT :
(2 * prec + 2 <= prec')%Z ->
forall x,
FLT_format beta emin prec x ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (sqrt x).
Proof.
intros choice1 choice2 Hemin Heminprec Hprec x Fx.
-apply double_round_sqrt.
+apply round_round_sqrt.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_sqrt_hyp.
+- now apply FLT_round_round_sqrt_hyp.
- now apply generic_format_FLT.
Qed.
@@ -2974,24 +2952,21 @@ End Double_round_sqrt_FLT.
Section Double_round_sqrt_FTZ.
-Import Fcore_FLX.
-Import Fcore_FTZ.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FTZ_double_round_sqrt_hyp :
+Lemma FTZ_round_round_sqrt_hyp :
(2 * (emin' + prec') <= emin + prec <= 1)%Z ->
(2 * prec + 2 <= prec')%Z ->
- double_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
+ round_round_sqrt_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FTZ_exp.
unfold Prec_gt_0 in *.
-unfold double_round_sqrt_hyp; split; [|split]; intros ex.
+unfold round_round_sqrt_hyp; split; [|split]; intros ex.
- destruct (Z.ltb_spec (ex - prec) emin);
destruct (Z.ltb_spec (2 * ex - prec) emin);
omega.
@@ -3008,49 +2983,49 @@ unfold double_round_sqrt_hyp; split; [|split]; intros ex.
omega.
Qed.
-Theorem double_round_sqrt_FTZ :
+Theorem round_round_sqrt_FTZ :
(4 <= beta)%Z ->
forall choice1 choice2,
(2 * (emin' + prec') <= emin + prec <= 1)%Z ->
(2 * prec + 2 <= prec')%Z ->
forall x,
FTZ_format beta emin prec x ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (sqrt x).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x Fx.
-apply double_round_sqrt.
+apply round_round_sqrt.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_sqrt_hyp.
+- now apply FTZ_round_round_sqrt_hyp.
- now apply generic_format_FTZ.
Qed.
End Double_round_sqrt_FTZ.
-Section Double_round_sqrt_beta_ge_4.
+Section Double_round_sqrt_radix_ge_4.
-Definition double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 :=
+Definition round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 :=
(forall ex, (2 * fexp1 ex <= fexp1 (2 * ex))%Z)
/\ (forall ex, (2 * fexp1 ex <= fexp1 (2 * ex - 1))%Z)
/\ (forall ex, (fexp1 (2 * ex) < 2 * ex)%Z ->
(fexp2 ex + ex <= 2 * fexp1 ex - 1)%Z).
-Lemma double_round_sqrt_beta_ge_4_aux :
+Lemma round_round_sqrt_radix_ge_4_aux :
(4 <= beta)%Z ->
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
- double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 ->
+ round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 ->
forall x,
0 < x ->
- (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z ->
+ (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z ->
generic_format beta fexp1 x ->
/ 2 * ulp beta fexp2 (sqrt x) < Rabs (sqrt x - midp fexp1 (sqrt x)).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 Hexp x Px Hf2 Fx.
set (a := round beta fexp1 Zfloor (sqrt x)).
-set (u1 := bpow (fexp1 (ln_beta (sqrt x)))).
-set (u2 := bpow (fexp2 (ln_beta (sqrt x)))).
+set (u1 := bpow (fexp1 (mag (sqrt x)))).
+set (u2 := bpow (fexp2 (mag (sqrt x)))).
set (b := / 2 * (u1 - u2)).
set (b' := / 2 * (u1 + u2)).
unfold midp; rewrite 2!ulp_neq_0; try now apply Rgt_not_eq, sqrt_lt_R0.
@@ -3061,9 +3036,9 @@ assert (Fa : generic_format beta fexp1 a).
- exact Vfexp1.
- now apply valid_rnd_DN. }
revert Fa; revert Fx.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
-set (ma := Ztrunc (a * bpow (- fexp1 (ln_beta a)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))).
+set (ma := Ztrunc (a * bpow (- fexp1 (mag a)))).
intros Fx Fa.
assert (Nna : 0 <= a).
{ rewrite <- (round_0 beta fexp1 Zfloor).
@@ -3080,7 +3055,7 @@ assert (Pb : 0 < b).
rewrite <- (Rmult_0_r (/ 2)).
apply Rmult_lt_compat_l; [lra|].
apply Rlt_Rminus.
- unfold u2, u1, ulp, canonic_exp.
+ unfold u2, u1, ulp, cexp.
apply bpow_lt.
omega. }
assert (Pb' : 0 < b').
@@ -3094,14 +3069,14 @@ assert (Hl : a + b <= sqrt x).
replace (_ + sqrt _) with (sqrt x - (a + / 2 * u1)) by ring.
rewrite Ropp_mult_distr_l_reverse.
now apply Rabs_le_inv in H; destruct H. }
-assert (Hf1 : (2 * fexp1 (ln_beta (sqrt x)) <= fexp1 (ln_beta (x)))%Z);
- [destruct (ln_beta_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|].
-assert (Hlx : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z).
-{ destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx].
- - apply (valid_exp_large fexp1 (ln_beta x)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+assert (Hf1 : (2 * fexp1 (mag (sqrt x)) <= fexp1 (mag (x)))%Z);
+ [destruct (mag_sqrt_disj x Px) as [H'|H']; rewrite H'; apply Hexp|].
+assert (Hlx : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z).
+{ destruct (mag_sqrt_disj x Px) as [Hlx|Hlx].
+ - apply (valid_exp_large fexp1 (mag x)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- rewrite <- Hlx.
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. }
+ now apply mag_generic_gt; [|apply Rgt_not_eq|]. }
assert (Hsl : a * a + u1 * a - u2 * a + b * b <= x).
{ replace (_ + _) with ((a + b) * (a + b)); [|now unfold b; field].
rewrite <- sqrt_def; [|now apply Rlt_le].
@@ -3120,34 +3095,33 @@ destruct (Req_dec a 0) as [Za|Nza].
+ revert Hsl; unfold Rminus; rewrite Za; do 3 rewrite Rmult_0_r.
now rewrite Ropp_0; do 3 rewrite Rplus_0_l.
+ rewrite Fx.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_0_l; bpow_simplify.
unfold mx.
rewrite Ztrunc_floor;
[|now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]].
- apply Req_le.
- change 0 with (Z2R 0); apply f_equal.
+ apply Req_le, IZR_eq.
apply Zfloor_imp.
split; [now apply Rmult_le_pos; [apply Rlt_le|apply bpow_ge_0]|simpl].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x)))); [now apply bpow_gt_0|].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x)))); [now apply bpow_gt_0|].
rewrite Rmult_1_l; bpow_simplify.
- apply Rlt_le_trans with (bpow (2 * fexp1 (ln_beta (sqrt x))));
+ apply Rlt_le_trans with (bpow (2 * fexp1 (mag (sqrt x))));
[|now apply bpow_le].
change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l.
rewrite bpow_plus.
rewrite <- (sqrt_def x) at 1; [|now apply Rlt_le].
- assert (sqrt x < bpow (fexp1 (ln_beta (sqrt x))));
+ assert (sqrt x < bpow (fexp1 (mag (sqrt x))));
[|now apply Rmult_lt_compat; [apply sqrt_pos|apply sqrt_pos| |]].
apply (Rle_lt_trans _ _ _ Hr); rewrite Za; rewrite Rplus_0_l.
unfold b'; change (bpow _) with u1.
apply Rlt_le_trans with (/ 2 * (u1 + u1)); [|lra].
apply Rmult_lt_compat_l; [lra|]; apply Rplus_lt_compat_l.
- unfold u2, u1, ulp, canonic_exp; apply bpow_lt; omega.
+ unfold u2, u1, ulp, cexp; apply bpow_lt; omega.
- (* a <> 0 *)
assert (Pa : 0 < a); [lra|].
- assert (Hla : (ln_beta a = ln_beta (sqrt x) :> Z)).
- { unfold a; apply ln_beta_DN.
+ assert (Hla : (mag a = mag (sqrt x) :> Z)).
+ { unfold a; apply mag_DN.
- exact Vfexp1.
- now fold a. }
assert (Hl' : 0 < - (u2 * a) + b * b).
@@ -3156,7 +3130,7 @@ destruct (Req_dec a 0) as [Za|Nza].
apply (Rplus_lt_reg_r (/ 2 * u2 * u1)); field_simplify.
replace (_ / 2) with (u2 * (a + / 2 * u1)) by field.
replace (_ / 8) with (/ 4 * (u2 ^ 2 + u1 ^ 2)) by field.
- apply Rlt_le_trans with (u2 * bpow (ln_beta (sqrt x))).
+ apply Rlt_le_trans with (u2 * bpow (mag (sqrt x))).
- apply Rmult_lt_compat_l; [now unfold u2, ulp; apply bpow_gt_0|].
unfold u1; rewrite <- Hla.
apply Rlt_le_trans with (a + ulp beta fexp1 a).
@@ -3165,50 +3139,50 @@ destruct (Req_dec a 0) as [Za|Nza].
rewrite ulp_neq_0; trivial.
apply Rmult_lt_compat_r; [apply bpow_gt_0|lra].
+ apply (id_p_ulp_le_bpow _ _ _ _ Pa Fa).
- apply Rabs_lt_inv, bpow_ln_beta_gt.
+ apply Rabs_lt_inv, bpow_mag_gt.
- apply Rle_trans with (bpow (- 1) * u1 ^ 2).
+ unfold pow; rewrite Rmult_1_r.
- unfold u1, u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
+ unfold u1, u2, ulp, cexp; bpow_simplify; apply bpow_le.
now apply Hexp.
+ apply Rmult_le_compat.
* apply bpow_ge_0.
* apply pow2_ge_0.
- * unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
+ * unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- now change 4 with (Z2R 4); apply Z2R_le.
+ now apply IZR_le.
* rewrite <- (Rplus_0_l (u1 ^ 2)) at 1; apply Rplus_le_compat_r.
apply pow2_ge_0. }
assert (Hr' : x <= a * a + u1 * a).
{ rewrite Hla in Fa.
rewrite <- Rmult_plus_distr_r.
- unfold u1, ulp, canonic_exp.
+ unfold u1, ulp, cexp.
rewrite <- (Rmult_1_l (bpow _)); rewrite Fa; rewrite <- Rmult_plus_distr_r.
- rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (Z2R ma)).
- rewrite <- (Rmult_assoc (Z2R ma)); bpow_simplify.
- apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (ln_beta (sqrt x)))));
+ rewrite <- Rmult_assoc; rewrite (Rmult_comm _ (IZR ma)).
+ rewrite <- (Rmult_assoc (IZR ma)); bpow_simplify.
+ apply (Rmult_le_reg_r (bpow (- 2 * fexp1 (mag (sqrt x)))));
[now apply bpow_gt_0|bpow_simplify].
rewrite Fx at 1; bpow_simplify.
- rewrite <- Z2R_Zpower; [|omega].
- change 1 with (Z2R 1); rewrite <- Z2R_plus; do 2 rewrite <- Z2R_mult.
- apply Z2R_le, Zlt_succ_le, lt_Z2R.
- unfold Z.succ; rewrite Z2R_plus; do 2 rewrite Z2R_mult; rewrite Z2R_plus.
- rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (2 * fexp1 (ln_beta (sqrt x)))));
+ rewrite <- IZR_Zpower; [|omega].
+ rewrite <- plus_IZR, <- 2!mult_IZR.
+ apply IZR_le, Zlt_succ_le, lt_IZR.
+ unfold Z.succ; rewrite plus_IZR; do 2 rewrite mult_IZR; rewrite plus_IZR.
+ rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (2 * fexp1 (mag (sqrt x)))));
[now apply bpow_gt_0|bpow_simplify].
rewrite <- Fx.
change 2%Z with (1 + 1)%Z; rewrite Zmult_plus_distr_l; rewrite Zmult_1_l.
rewrite bpow_plus; simpl.
replace (_ * _) with (a * a + u1 * a + u1 * u1);
- [|unfold u1, ulp, canonic_exp; rewrite Fa; ring].
+ [|unfold u1, ulp, cexp; rewrite Fa; ring].
apply (Rle_lt_trans _ _ _ Hsr).
rewrite Rplus_assoc; apply Rplus_lt_compat_l.
apply (Rplus_lt_reg_r (- b' * b' + / 2 * u1 * u2)); ring_simplify.
replace (_ + _) with ((a + / 2 * u1) * u2) by ring.
- apply Rlt_le_trans with (bpow (ln_beta (sqrt x)) * u2).
+ apply Rlt_le_trans with (bpow (mag (sqrt x)) * u2).
- apply Rmult_lt_compat_r; [now unfold u2, ulp; apply bpow_gt_0|].
apply Rlt_le_trans with (a + u1); [lra|].
- unfold u1; fold (canonic_exp beta fexp1 (sqrt x)).
- rewrite <- canonic_exp_DN; [|exact Vfexp1|exact Pa]; fold a.
+ unfold u1; fold (cexp beta fexp1 (sqrt x)).
+ rewrite <- cexp_DN; [|exact Vfexp1|exact Pa]; fold a.
rewrite <- ulp_neq_0; trivial.
apply id_p_ulp_le_bpow.
+ exact Pa.
@@ -3216,25 +3190,25 @@ destruct (Req_dec a 0) as [Za|Nza].
+ apply Rle_lt_trans with (sqrt x).
* now apply round_DN_pt.
* apply Rabs_lt_inv.
- apply bpow_ln_beta_gt.
+ apply bpow_mag_gt.
- apply Rle_trans with (/ 2 * u1 ^ 2).
+ apply Rle_trans with (bpow (- 1) * u1 ^ 2).
* unfold pow; rewrite Rmult_1_r.
- unfold u2, u1, ulp, canonic_exp.
+ unfold u2, u1, ulp, cexp.
bpow_simplify.
apply bpow_le.
rewrite Zplus_comm.
now apply Hexp.
* apply Rmult_le_compat_r; [now apply pow2_ge_0|].
- unfold Fcore_Raux.bpow; simpl; unfold Z.pow_pos; simpl.
+ unfold Raux.bpow; simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r.
apply Rinv_le; [lra|].
- change 2 with (Z2R 2); apply Z2R_le; omega.
+ apply IZR_le; omega.
+ assert (u2 ^ 2 < u1 ^ 2); [|unfold b'; lra].
unfold pow; do 2 rewrite Rmult_1_r.
assert (H' : 0 <= u2); [unfold u2, ulp; apply bpow_ge_0|].
assert (u2 < u1); [|now apply Rmult_lt_compat].
- unfold u1, u2, ulp, canonic_exp; apply bpow_lt; omega. }
+ unfold u1, u2, ulp, cexp; apply bpow_lt; omega. }
apply (Rlt_irrefl (a * a + u1 * a)).
apply Rlt_le_trans with (a * a + u1 * a - u2 * a + b * b).
+ rewrite <- (Rplus_0_r (a * a + _)) at 1.
@@ -3243,18 +3217,18 @@ destruct (Req_dec a 0) as [Za|Nza].
+ now apply Rle_trans with x.
Qed.
-Lemma double_round_sqrt_beta_ge_4 :
+Lemma round_round_sqrt_radix_ge_4 :
(4 <= beta)%Z ->
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_sqrt_beta_ge_4_hyp fexp1 fexp2 ->
+ round_round_sqrt_radix_ge_4_hyp fexp1 fexp2 ->
forall x,
generic_format beta fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 (sqrt x).
+ round_round_eq fexp1 fexp2 choice1 choice2 (sqrt x).
Proof.
intros Hbeta fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x Fx.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Rle_or_lt x 0) as [Npx|Px].
- (* x <= 0 *)
assert (Hs : sqrt x = 0).
@@ -3272,13 +3246,13 @@ destruct (Rle_or_lt x 0) as [Npx|Px].
+ reflexivity.
+ now apply valid_rnd_N.
- (* 0 < x *)
- assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; try assumption; lra|].
- assert (Hfsx : (fexp1 (ln_beta (sqrt x)) < ln_beta (sqrt x))%Z).
+ assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; try assumption; lra|].
+ assert (Hfsx : (fexp1 (mag (sqrt x)) < mag (sqrt x))%Z).
{ destruct (Rle_or_lt x 1) as [Hx|Hx].
- (* x <= 1 *)
- apply (valid_exp_large fexp1 (ln_beta x)); [exact Hfx|].
- apply ln_beta_le; [exact Px|].
+ apply (valid_exp_large fexp1 (mag x)); [exact Hfx|].
+ apply mag_le; [exact Px|].
rewrite <- (sqrt_def x) at 1; [|lra].
rewrite <- Rmult_1_r.
apply Rmult_le_compat_l.
@@ -3291,36 +3265,34 @@ destruct (Rle_or_lt x 0) as [Npx|Px].
intro Hexp10.
assert (Hf0 : (fexp1 1 < 1)%Z); [omega|clear Hexp10].
apply (valid_exp_large fexp1 1); [exact Hf0|].
- apply ln_beta_ge_bpow.
+ apply mag_ge_bpow.
rewrite Zeq_minus; [|reflexivity].
- unfold Fcore_Raux.bpow; simpl.
+ unfold Raux.bpow; simpl.
apply Rabs_ge; right.
rewrite <- sqrt_1.
apply sqrt_le_1_alt.
now apply Rlt_le. }
- assert (Hf2 : (fexp2 (ln_beta (sqrt x)) <= fexp1 (ln_beta (sqrt x)) - 1)%Z).
- { assert (H : (fexp1 (2 * ln_beta (sqrt x)) < 2 * ln_beta (sqrt x))%Z).
- { destruct (ln_beta_sqrt_disj x Px) as [Hlx|Hlx].
- - apply (valid_exp_large fexp1 (ln_beta x)); [|omega].
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|].
+ assert (Hf2 : (fexp2 (mag (sqrt x)) <= fexp1 (mag (sqrt x)) - 1)%Z).
+ { assert (H : (fexp1 (2 * mag (sqrt x)) < 2 * mag (sqrt x))%Z).
+ { destruct (mag_sqrt_disj x Px) as [Hlx|Hlx].
+ - apply (valid_exp_large fexp1 (mag x)); [|omega].
+ now apply mag_generic_gt; [|apply Rgt_not_eq|].
- rewrite <- Hlx.
- now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]. }
- generalize ((proj2 (proj2 Hexp)) (ln_beta (sqrt x)) H).
+ now apply mag_generic_gt; [|apply Rgt_not_eq|]. }
+ generalize ((proj2 (proj2 Hexp)) (mag (sqrt x)) H).
omega. }
- apply double_round_mid_cases.
+ apply round_round_mid_cases.
+ exact Vfexp1.
+ exact Vfexp2.
+ now apply sqrt_lt_R0.
+ omega.
+ omega.
+ intros Hmid; casetype False; apply (Rle_not_lt _ _ Hmid).
- apply (double_round_sqrt_beta_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2
+ apply (round_round_sqrt_radix_ge_4_aux Hbeta fexp1 fexp2 Vfexp1 Vfexp2
Hexp x Px Hf2 Fx).
Qed.
-Section Double_round_sqrt_beta_ge_4_FLX.
-
-Import Fcore_FLX.
+Section Double_round_sqrt_radix_ge_4_FLX.
Variable prec : Z.
Variable prec' : Z.
@@ -3328,39 +3300,36 @@ Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLX_double_round_sqrt_beta_ge_4_hyp :
+Lemma FLX_round_round_sqrt_radix_ge_4_hyp :
(2 * prec + 1 <= prec')%Z ->
- double_round_sqrt_beta_ge_4_hyp (FLX_exp prec) (FLX_exp prec').
+ round_round_sqrt_radix_ge_4_hyp (FLX_exp prec) (FLX_exp prec').
Proof.
intros Hprec.
unfold FLX_exp.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intro ex; omega.
+unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intro ex; omega.
Qed.
-Theorem double_round_sqrt_beta_ge_4_FLX :
+Theorem round_round_sqrt_radix_ge_4_FLX :
(4 <= beta)%Z ->
forall choice1 choice2,
(2 * prec + 1 <= prec')%Z ->
forall x,
FLX_format beta prec x ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (sqrt x).
Proof.
intros Hbeta choice1 choice2 Hprec x Fx.
-apply double_round_sqrt_beta_ge_4.
+apply round_round_sqrt_radix_ge_4.
- exact Hbeta.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
-- now apply FLX_double_round_sqrt_beta_ge_4_hyp.
+- now apply FLX_round_round_sqrt_radix_ge_4_hyp.
- now apply generic_format_FLX.
Qed.
-End Double_round_sqrt_beta_ge_4_FLX.
+End Double_round_sqrt_radix_ge_4_FLX.
-Section Double_round_sqrt_beta_ge_4_FLT.
-
-Import Fcore_FLX.
-Import Fcore_FLT.
+Section Double_round_sqrt_radix_ge_4_FLT.
Variable emin prec : Z.
Variable emin' prec' : Z.
@@ -3368,17 +3337,17 @@ Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLT_double_round_sqrt_beta_ge_4_hyp :
+Lemma FLT_round_round_sqrt_radix_ge_4_hyp :
(emin <= 0)%Z ->
((emin' <= emin - prec - 1)%Z
\/ (2 * emin' <= emin - 4 * prec)%Z) ->
(2 * prec + 1 <= prec')%Z ->
- double_round_sqrt_beta_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
+ round_round_sqrt_radix_ge_4_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
Proof.
intros Hemin Heminprec Hprec.
unfold FLT_exp.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex.
+unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex.
- generalize (Zmax_spec (ex - prec) emin).
generalize (Zmax_spec (2 * ex - prec) emin).
omega.
@@ -3391,7 +3360,7 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex.
omega.
Qed.
-Theorem double_round_sqrt_beta_ge_4_FLT :
+Theorem round_round_sqrt_radix_ge_4_FLT :
(4 <= beta)%Z ->
forall choice1 choice2,
(emin <= 0)%Z ->
@@ -3400,24 +3369,21 @@ Theorem double_round_sqrt_beta_ge_4_FLT :
(2 * prec + 1 <= prec')%Z ->
forall x,
FLT_format beta emin prec x ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (sqrt x).
Proof.
intros Hbeta choice1 choice2 Hemin Heminprec Hprec x Fx.
-apply double_round_sqrt_beta_ge_4.
+apply round_round_sqrt_radix_ge_4.
- exact Hbeta.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
-- now apply FLT_double_round_sqrt_beta_ge_4_hyp.
+- now apply FLT_round_round_sqrt_radix_ge_4_hyp.
- now apply generic_format_FLT.
Qed.
-End Double_round_sqrt_beta_ge_4_FLT.
-
-Section Double_round_sqrt_beta_ge_4_FTZ.
+End Double_round_sqrt_radix_ge_4_FLT.
-Import Fcore_FLX.
-Import Fcore_FTZ.
+Section Double_round_sqrt_radix_ge_4_FTZ.
Variable emin prec : Z.
Variable emin' prec' : Z.
@@ -3425,15 +3391,15 @@ Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FTZ_double_round_sqrt_beta_ge_4_hyp :
+Lemma FTZ_round_round_sqrt_radix_ge_4_hyp :
(2 * (emin' + prec') <= emin + prec <= 1)%Z ->
(2 * prec + 1 <= prec')%Z ->
- double_round_sqrt_beta_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
+ round_round_sqrt_radix_ge_4_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FTZ_exp.
unfold Prec_gt_0 in *.
-unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex.
+unfold round_round_sqrt_radix_ge_4_hyp; split; [|split]; intros ex.
- destruct (Z.ltb_spec (ex - prec) emin);
destruct (Z.ltb_spec (2 * ex - prec) emin);
omega.
@@ -3450,47 +3416,47 @@ unfold double_round_sqrt_beta_ge_4_hyp; split; [|split]; intros ex.
omega.
Qed.
-Theorem double_round_sqrt_beta_ge_4_FTZ :
+Theorem round_round_sqrt_radix_ge_4_FTZ :
(4 <= beta)%Z ->
forall choice1 choice2,
(2 * (emin' + prec') <= emin + prec <= 1)%Z ->
(2 * prec + 1 <= prec')%Z ->
forall x,
FTZ_format beta emin prec x ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (sqrt x).
Proof.
intros Hbeta choice1 choice2 Hemin Hprec x Fx.
-apply double_round_sqrt_beta_ge_4.
+apply round_round_sqrt_radix_ge_4.
- exact Hbeta.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
-- now apply FTZ_double_round_sqrt_beta_ge_4_hyp.
+- now apply FTZ_round_round_sqrt_radix_ge_4_hyp.
- now apply generic_format_FTZ.
Qed.
-End Double_round_sqrt_beta_ge_4_FTZ.
+End Double_round_sqrt_radix_ge_4_FTZ.
-End Double_round_sqrt_beta_ge_4.
+End Double_round_sqrt_radix_ge_4.
End Double_round_sqrt.
Section Double_round_div.
-Lemma double_round_eq_mid_beta_even :
+Lemma round_round_eq_mid_beta_even :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
(exists n, (beta = 2 * n :> Z)%Z) ->
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- (fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ (fexp1 (mag x) <= mag x)%Z ->
x = midp fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta x Px Hf2 Hf1.
-unfold double_round_eq.
+unfold round_round_eq.
unfold midp.
set (rd := round beta fexp1 Zfloor x).
set (u := ulp beta fexp1 x).
@@ -3505,30 +3471,30 @@ assert (Hbeta : (2 <= beta)%Z).
apply (Rplus_eq_compat_l rd) in Xmid; ring_simplify in Xmid.
rewrite (round_generic beta fexp2); [reflexivity|now apply valid_rnd_N|].
set (f := Float beta (Zfloor (scaled_mantissa beta fexp2 rd)
- + n * beta ^ (fexp1 (ln_beta x) - 1
- - fexp2 (ln_beta x)))
- (canonic_exp beta fexp2 x)).
+ + n * beta ^ (fexp1 (mag x) - 1
+ - fexp2 (mag x)))
+ (cexp beta fexp2 x)).
assert (Hf : F2R f = x).
{ unfold f, F2R; simpl.
- rewrite Z2R_plus.
+ rewrite plus_IZR.
rewrite Rmult_plus_distr_r.
- rewrite Z2R_mult.
- rewrite Z2R_Zpower; [|omega].
- unfold canonic_exp at 2; bpow_simplify.
+ rewrite mult_IZR.
+ rewrite IZR_Zpower; [|omega].
+ unfold cexp at 2; bpow_simplify.
unfold Zminus; rewrite bpow_plus.
rewrite (Rmult_comm _ (bpow (- 1))).
- rewrite <- (Rmult_assoc (Z2R n)).
- change (bpow (- 1)) with (/ Z2R (beta * 1)).
+ rewrite <- (Rmult_assoc (IZR n)).
+ change (bpow (- 1)) with (/ IZR (beta * 1)).
rewrite Zmult_1_r.
rewrite Ebeta.
- rewrite (Z2R_mult 2).
+ rewrite (mult_IZR 2).
rewrite Rinv_mult_distr;
- [|simpl; lra|change 0 with (Z2R 0); apply Z2R_neq; omega].
- rewrite <- Rmult_assoc; rewrite (Rmult_comm (Z2R n));
- rewrite (Rmult_assoc _ (Z2R n)).
+ [|simpl; lra | apply IZR_neq; omega].
+ rewrite <- Rmult_assoc; rewrite (Rmult_comm (IZR n));
+ rewrite (Rmult_assoc _ (IZR n)).
rewrite Rinv_r;
- [rewrite Rmult_1_r|change 0 with (Z2R 0); apply Z2R_neq; omega].
- simpl; fold (canonic_exp beta fexp1 x).
+ [rewrite Rmult_1_r | apply IZR_neq; omega].
+ simpl; fold (cexp beta fexp1 x).
rewrite <- 2!ulp_neq_0; try now apply Rgt_not_eq.
fold u; rewrite Xmid at 2.
apply f_equal2; [|reflexivity].
@@ -3537,7 +3503,7 @@ assert (Hf : F2R f = x).
- (* rd = 0 *)
rewrite Zrd.
rewrite scaled_mantissa_0.
- change 0 with (Z2R 0) at 1; rewrite Zfloor_Z2R.
+ rewrite Zfloor_IZR.
now rewrite Rmult_0_l.
- (* rd <> 0 *)
assert (Nnrd : 0 <= rd).
@@ -3546,187 +3512,187 @@ assert (Hf : F2R f = x).
- apply generic_format_0.
- now apply Rlt_le. }
assert (Prd : 0 < rd); [lra|].
- assert (Lrd : (ln_beta rd = ln_beta x :> Z)).
+ assert (Lrd : (mag rd = mag x :> Z)).
{ apply Zle_antisym.
- - apply ln_beta_le; [exact Prd|].
+ - apply mag_le; [exact Prd|].
now apply round_DN_pt.
- - apply ln_beta_round_ge.
+ - apply mag_round_ge.
+ exact Vfexp1.
+ now apply valid_rnd_DN.
+ exact Nzrd. }
unfold scaled_mantissa.
unfold rd at 1.
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
bpow_simplify.
rewrite Lrd.
- rewrite <- (Z2R_Zpower _ (_ - _)); [|omega].
- rewrite <- Z2R_mult.
- rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (ln_beta x))) *
- beta ^ (fexp1 (ln_beta x) - fexp2 (ln_beta x)))).
- + rewrite Z2R_mult.
- rewrite Z2R_Zpower; [|omega].
+ rewrite <- (IZR_Zpower _ (_ - _)); [|omega].
+ rewrite <- mult_IZR.
+ rewrite (Zfloor_imp (Zfloor (x * bpow (- fexp1 (mag x))) *
+ beta ^ (fexp1 (mag x) - fexp2 (mag x)))).
+ + rewrite mult_IZR.
+ rewrite IZR_Zpower; [|omega].
bpow_simplify.
now unfold rd.
+ split; [now apply Rle_refl|].
- rewrite Z2R_plus.
+ rewrite plus_IZR.
simpl; lra. }
apply (generic_format_F2R' _ _ x f Hf).
intros _.
-apply Zle_refl.
+apply Z.le_refl.
Qed.
-Lemma double_round_really_zero :
+Lemma round_round_really_zero :
forall (fexp1 fexp2 : Z -> Z),
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (ln_beta x <= fexp1 (ln_beta x) - 2)%Z ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ (mag x <= fexp1 (mag x) - 2)%Z ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1.
-assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)).
-{ destruct (ln_beta x) as (ex,Hex); simpl.
+assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)).
+{ destruct (mag x) as (ex,Hex); simpl.
rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le].
apply Hex.
now apply Rgt_not_eq. }
-unfold double_round_eq.
-rewrite (round_N_really_small_pos beta fexp1 _ x (ln_beta x)); [|exact Hlx|omega].
+unfold round_round_eq.
+rewrite (round_N_small_pos beta fexp1 _ x (mag x)); [|exact Hlx|omega].
set (x'' := round beta fexp2 (Znearest choice2) x).
destruct (Req_dec x'' 0) as [Zx''|Nzx''];
[now rewrite Zx''; rewrite round_0; [|apply valid_rnd_N]|].
-destruct (Zle_or_lt (fexp2 (ln_beta x)) (ln_beta x)).
-- (* fexp2 (ln_beta x) <= ln_beta x *)
- destruct (Rlt_or_le x'' (bpow (ln_beta x))).
- + (* x'' < bpow (ln_beta x) *)
- rewrite (round_N_really_small_pos beta fexp1 _ _ (ln_beta x));
+destruct (Zle_or_lt (fexp2 (mag x)) (mag x)).
+- (* fexp2 (mag x) <= mag x *)
+ destruct (Rlt_or_le x'' (bpow (mag x))).
+ + (* x'' < bpow (mag x) *)
+ rewrite (round_N_small_pos beta fexp1 _ _ (mag x));
[reflexivity|split; [|exact H0]|omega].
- apply round_large_pos_ge_pow; [now apply valid_rnd_N| |now apply Hlx].
+ apply round_large_pos_ge_bpow; [now apply valid_rnd_N| |now apply Hlx].
fold x''; assert (0 <= x''); [|lra]; unfold x''.
rewrite <- (round_0 beta fexp2 (Znearest choice2)).
now apply round_le; [|apply valid_rnd_N|apply Rlt_le].
- + (* bpow (ln_beta x) <= x'' *)
- assert (Hx'' : x'' = bpow (ln_beta x)).
+ + (* bpow (mag x) <= x'' *)
+ assert (Hx'' : x'' = bpow (mag x)).
{ apply Rle_antisym; [|exact H0].
rewrite <- (round_generic beta fexp2 (Znearest choice2) (bpow _)).
- now apply round_le; [|apply valid_rnd_N|apply Rlt_le].
- now apply generic_format_bpow'. }
rewrite Hx''.
- unfold round, F2R, scaled_mantissa, canonic_exp; simpl.
- rewrite ln_beta_bpow.
- assert (Hf11 : (fexp1 (ln_beta x + 1) = fexp1 (ln_beta x) :> Z)%Z);
+ unfold round, F2R, scaled_mantissa, cexp; simpl.
+ rewrite mag_bpow.
+ assert (Hf11 : (fexp1 (mag x + 1) = fexp1 (mag x) :> Z)%Z);
[apply Vfexp1; omega|].
rewrite Hf11.
- apply (Rmult_eq_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_eq_reg_r (bpow (- fexp1 (mag x))));
[|now apply Rgt_not_eq; apply bpow_gt_0].
rewrite Rmult_0_l; bpow_simplify.
- change 0 with (Z2R 0); apply f_equal.
+ apply IZR_eq.
apply Znearest_imp.
simpl; unfold Rminus; rewrite Ropp_0; rewrite Rplus_0_r.
rewrite Rabs_right; [|now apply Rle_ge; apply bpow_ge_0].
apply Rle_lt_trans with (bpow (- 2)); [now apply bpow_le; omega|].
- unfold Fcore_Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
+ unfold Raux.bpow, Z.pow_pos; simpl; rewrite Zmult_1_r.
assert (Hbeta : (2 <= beta)%Z).
{ destruct beta as (beta_val,beta_prop); simpl.
now apply Zle_bool_imp_le. }
apply Rinv_lt_contravar.
* apply Rmult_lt_0_compat; [lra|].
- rewrite Z2R_mult; apply Rmult_lt_0_compat; change 0 with (Z2R 0);
- apply Z2R_lt; omega.
- * change 2 with (Z2R 2); apply Z2R_lt.
- apply (Zle_lt_trans _ _ _ Hbeta).
+ rewrite mult_IZR; apply Rmult_lt_0_compat;
+ apply IZR_lt; omega.
+ * apply IZR_lt.
+ apply (Z.le_lt_trans _ _ _ Hbeta).
rewrite <- (Zmult_1_r beta) at 1.
apply Zmult_lt_compat_l; omega.
-- (* ln_beta x < fexp2 (ln_beta x) *)
+- (* mag x < fexp2 (mag x) *)
casetype False; apply Nzx''.
- now apply (round_N_really_small_pos beta _ _ _ (ln_beta x)).
+ now apply (round_N_small_pos beta _ _ _ (mag x)).
Qed.
-Lemma double_round_zero :
+Lemma round_round_zero :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z ->
- x < bpow (ln_beta x) - / 2 * ulp beta fexp2 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ (fexp1 (mag x) = mag x + 1 :> Z)%Z ->
+ x < bpow (mag x) - / 2 * ulp beta fexp2 x ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf1.
-unfold double_round_eq.
+unfold round_round_eq.
set (x'' := round beta fexp2 (Znearest choice2) x).
set (u1 := ulp beta fexp1 x).
set (u2 := ulp beta fexp2 x).
intro Hx.
-assert (Hlx : bpow (ln_beta x - 1) <= x < bpow (ln_beta x)).
-{ destruct (ln_beta x) as (ex,Hex); simpl.
+assert (Hlx : bpow (mag x - 1) <= x < bpow (mag x)).
+{ destruct (mag x) as (ex,Hex); simpl.
rewrite <- (Rabs_right x); [|now apply Rle_ge; apply Rlt_le].
apply Hex.
now apply Rgt_not_eq. }
-rewrite (round_N_really_small_pos beta fexp1 choice1 x (ln_beta x));
+rewrite (round_N_small_pos beta fexp1 choice1 x (mag x));
[|exact Hlx|omega].
destruct (Req_dec x'' 0) as [Zx''|Nzx''];
[now rewrite Zx''; rewrite round_0; [reflexivity|apply valid_rnd_N]|].
-rewrite (round_N_really_small_pos beta _ _ x'' (ln_beta x));
+rewrite (round_N_small_pos beta _ _ x'' (mag x));
[reflexivity| |omega].
split.
-- apply round_large_pos_ge_pow.
+- apply round_large_pos_ge_bpow.
+ now apply valid_rnd_N.
+ assert (0 <= x''); [|now fold x''; lra].
rewrite <- (round_0 beta fexp2 (Znearest choice2)).
now apply round_le; [|apply valid_rnd_N|apply Rlt_le].
+ apply Rle_trans with (Rabs x);
[|now rewrite Rabs_right; [apply Rle_refl|apply Rle_ge; apply Rlt_le]].
- destruct (ln_beta x) as (ex,Hex); simpl; apply Hex.
+ destruct (mag x) as (ex,Hex); simpl; apply Hex.
now apply Rgt_not_eq.
- replace x'' with (x + (x'' - x)) by ring.
- replace (bpow _) with (bpow (ln_beta x) - / 2 * u2 + / 2 * u2) by ring.
+ replace (bpow _) with (bpow (mag x) - / 2 * u2 + / 2 * u2) by ring.
apply Rplus_lt_le_compat; [exact Hx|].
apply Rabs_le_inv.
now apply error_le_half_ulp.
Qed.
-Lemma double_round_all_mid_cases :
+Lemma round_round_all_mid_cases :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
forall x,
0 < x ->
- (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z ->
- ((fexp1 (ln_beta x) = ln_beta x + 1 :> Z)%Z ->
- bpow (ln_beta x) - / 2 * ulp beta fexp2 x <= x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x) ->
- ((fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z ->
+ ((fexp1 (mag x) = mag x + 1 :> Z)%Z ->
+ bpow (mag x) - / 2 * ulp beta fexp2 x <= x ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x) ->
+ ((fexp1 (mag x) <= mag x)%Z ->
midp fexp1 x - / 2 * ulp beta fexp2 x <= x < midp fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x) ->
- ((fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x) ->
+ ((fexp1 (mag x) <= mag x)%Z ->
x = midp fexp1 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x) ->
- ((fexp1 (ln_beta x) <= ln_beta x)%Z ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x) ->
+ ((fexp1 (mag x) <= mag x)%Z ->
midp fexp1 x < x <= midp fexp1 x + / 2 * ulp beta fexp2 x ->
- double_round_eq fexp1 fexp2 choice1 choice2 x) ->
- double_round_eq fexp1 fexp2 choice1 choice2 x.
+ round_round_eq fexp1 fexp2 choice1 choice2 x) ->
+ round_round_eq fexp1 fexp2 choice1 choice2 x.
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 x Px Hf2.
set (x' := round beta fexp1 Zfloor x).
set (u1 := ulp beta fexp1 x).
set (u2 := ulp beta fexp2 x).
intros Cz Clt Ceq Cgt.
-destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]].
-- (* ln_beta x < fexp1 (ln_beta x) - 1 *)
- assert (H : (ln_beta x <= fexp1 (ln_beta x) - 2)%Z) by omega.
- now apply double_round_really_zero.
-- (* ln_beta x = fexp1 (ln_beta x) - 1 *)
- assert (H : (fexp1 (ln_beta x) = (ln_beta x + 1))%Z) by omega.
- destruct (Rlt_or_le x (bpow (ln_beta x) - / 2 * u2)) as [Hlt'|Hge'].
- + now apply double_round_zero.
+destruct (Ztrichotomy (mag x) (fexp1 (mag x) - 1)) as [Hlt|[Heq|Hgt]].
+- (* mag x < fexp1 (mag x) - 1 *)
+ assert (H : (mag x <= fexp1 (mag x) - 2)%Z) by omega.
+ now apply round_round_really_zero.
+- (* mag x = fexp1 (mag x) - 1 *)
+ assert (H : (fexp1 (mag x) = (mag x + 1))%Z) by omega.
+ destruct (Rlt_or_le x (bpow (mag x) - / 2 * u2)) as [Hlt'|Hge'].
+ + now apply round_round_zero.
+ now apply Cz.
-- (* ln_beta x > fexp1 (ln_beta x) - 1 *)
- assert (H : (fexp1 (ln_beta x) <= ln_beta x)%Z) by omega.
+- (* mag x > fexp1 (mag x) - 1 *)
+ assert (H : (fexp1 (mag x) <= mag x)%Z) by omega.
destruct (Rtotal_order x (midp fexp1 x)) as [Hlt'|[Heq'|Hgt']].
+ (* x < midp fexp1 x *)
destruct (Rlt_or_le x (midp fexp1 x - / 2 * u2)) as [Hlt''|Hle''].
- * now apply double_round_lt_mid_further_place; [| | |omega| |].
+ * now apply round_round_lt_mid_further_place; [| | |omega| |].
* now apply Clt; [|split].
+ (* x = midp fexp1 x *)
now apply Ceq.
@@ -3735,33 +3701,33 @@ destruct (Ztrichotomy (ln_beta x) (fexp1 (ln_beta x) - 1)) as [Hlt|[Heq|Hgt]].
* now apply Cgt; [|split].
* { destruct (generic_format_EM beta fexp1 x) as [Fx|Nfx].
- (* generic_format beta fexp1 x *)
- unfold double_round_eq; rewrite (round_generic beta fexp2);
+ unfold round_round_eq; rewrite (round_generic beta fexp2);
[reflexivity|now apply valid_rnd_N|].
- now apply (generic_inclusion_ln_beta beta fexp1); [omega|].
+ now apply (generic_inclusion_mag beta fexp1); [omega|].
- (* ~ generic_format beta fexp1 x *)
assert (Hceil : round beta fexp1 Zceil x = x' + u1);
[now apply round_UP_DN_ulp|].
- assert (Hf2' : (fexp2 (ln_beta x) <= fexp1 (ln_beta x) - 1)%Z);
+ assert (Hf2' : (fexp2 (mag x) <= fexp1 (mag x) - 1)%Z);
[omega|].
assert (midp' fexp1 x + / 2 * ulp beta fexp2 x < x);
- [|now apply double_round_gt_mid_further_place].
+ [|now apply round_round_gt_mid_further_place].
revert Hle''; unfold midp, midp'; fold x'.
rewrite Hceil; fold u1; fold u2.
lra. }
Qed.
-Lemma ln_beta_div_disj :
+Lemma mag_div_disj :
forall x y : R,
0 < x -> 0 < y ->
- ((ln_beta (x / y) = ln_beta x - ln_beta y :> Z)%Z
- \/ (ln_beta (x / y) = ln_beta x - ln_beta y + 1 :> Z)%Z).
+ ((mag (x / y) = mag x - mag y :> Z)%Z
+ \/ (mag (x / y) = mag x - mag y + 1 :> Z)%Z).
Proof.
intros x y Px Py.
-generalize (ln_beta_div beta x y Px Py).
+generalize (mag_div beta x y (Rgt_not_eq _ _ Px) (Rgt_not_eq _ _ Py)).
omega.
Qed.
-Definition double_round_div_hyp fexp1 fexp2 :=
+Definition round_round_div_hyp fexp1 fexp2 :=
(forall ex, (fexp2 ex <= fexp1 ex - 1)%Z)
/\ (forall ex ey, (fexp1 ex < ex)%Z -> (fexp1 ey < ey)%Z ->
(fexp1 (ex - ey) <= ex - ey + 1)%Z ->
@@ -3777,63 +3743,63 @@ Definition double_round_div_hyp fexp1 fexp2 :=
(fexp1 (ex - ey) = ex - ey + 1)%Z ->
(fexp2 (ex - ey) <= ex - ey - ey + fexp1 ey)%Z).
-Lemma double_round_div_aux0 :
+Lemma round_round_div_aux0 :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_div_hyp fexp1 fexp2 ->
+ round_round_div_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- fexp1 (ln_beta (x / y)) = (ln_beta (x / y) + 1)%Z ->
- ~ (bpow (ln_beta (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y).
+ fexp1 (mag (x / y)) = (mag (x / y) + 1)%Z ->
+ ~ (bpow (mag (x / y)) - / 2 * ulp beta fexp2 (x / y) <= x / y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1.
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-set (p := bpow (ln_beta (x / y))).
-set (u2 := bpow (fexp2 (ln_beta (x / y)))).
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp1 (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+set (p := bpow (mag (x / y))).
+set (u2 := bpow (fexp2 (mag (x / y)))).
revert Fx Fy.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
-set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))).
+set (my := Ztrunc (y * bpow (- fexp1 (mag y)))).
intros Fx Fy.
rewrite ulp_neq_0.
2: apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
2: now apply Rinv_neq_0_compat, Rgt_not_eq.
intro Hl.
assert (Hr : x / y < p);
- [now apply Rabs_lt_inv; apply bpow_ln_beta_gt|].
+ [now apply Rabs_lt_inv; apply bpow_mag_gt|].
apply (Rlt_irrefl (p - / 2 * u2)).
apply (Rle_lt_trans _ _ _ Hl).
apply (Rmult_lt_reg_r y _ _ Py).
unfold Rdiv; rewrite Rmult_assoc.
rewrite Rinv_l; [|now apply Rgt_not_eq]; rewrite Rmult_1_r.
-destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y)
- - fexp1 (ln_beta y))%Z) as [He|He].
-- (* ln_beta (x / y) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *)
- apply Rle_lt_trans with (p * y - p * bpow (fexp1 (ln_beta y))).
+destruct (Zle_or_lt Z0 (fexp1 (mag x) - mag (x / y)
+ - fexp1 (mag y))%Z) as [He|He].
+- (* mag (x / y) + fexp1 (mag y) <= fexp1 (mag x) *)
+ apply Rle_lt_trans with (p * y - p * bpow (fexp1 (mag y))).
+ rewrite Fx; rewrite Fy at 1.
rewrite <- Rmult_assoc.
rewrite (Rmult_comm p).
unfold p; bpow_simplify.
- apply (Rmult_le_reg_r (bpow (- ln_beta (x / y) - fexp1 (ln_beta y))));
+ apply (Rmult_le_reg_r (bpow (- mag (x / y) - fexp1 (mag y))));
[now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r.
bpow_simplify.
- rewrite <- Z2R_Zpower; [|exact He].
- rewrite <- Z2R_mult.
- change 1 with (Z2R 1); rewrite <- Z2R_minus.
- apply Z2R_le.
+ rewrite <- IZR_Zpower; [|exact He].
+ rewrite <- mult_IZR.
+ rewrite <- minus_IZR.
+ apply IZR_le.
apply (Zplus_le_reg_r _ _ 1); ring_simplify.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_mult.
- rewrite Z2R_Zpower; [|exact He].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y) + ln_beta (x / y))));
+ apply lt_IZR.
+ rewrite mult_IZR.
+ rewrite IZR_Zpower; [|exact He].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag y) + mag (x / y))));
[now apply bpow_gt_0|].
bpow_simplify.
rewrite <- Fx.
@@ -3845,7 +3811,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y)
+ rewrite Rmult_minus_distr_r.
unfold Rminus; apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* rewrite <- (Rmult_1_l (u2 * _)).
rewrite Rmult_assoc.
{ apply Rmult_lt_compat.
@@ -3854,38 +3820,38 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y)
- lra.
- apply Rmult_lt_compat_l; [now apply bpow_gt_0|].
apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
- * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
- rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ apply bpow_mag_gt. }
+ * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
+ rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)).
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
[now apply Hexp; [| |rewrite <- Hxy]|].
- replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring.
+ replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring.
apply Hexp.
- { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z;
+ { now assert (fexp1 (mag x + 1) <= mag x)%Z;
[apply valid_exp|omega]. }
{ assumption. }
- replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring.
+ replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring.
now rewrite <- Hxy.
-- (* fexp1 (ln_beta x) < ln_beta (x / y) + fexp1 (ln_beta y) *)
- apply Rle_lt_trans with (p * y - bpow (fexp1 (ln_beta x))).
+- (* fexp1 (mag x) < mag (x / y) + fexp1 (mag y) *)
+ apply Rle_lt_trans with (p * y - bpow (fexp1 (mag x))).
+ rewrite Fx at 1; rewrite Fy at 1.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r.
bpow_simplify.
rewrite (Rmult_comm p).
unfold p; bpow_simplify.
- rewrite <- Z2R_Zpower; [|omega].
- rewrite <- Z2R_mult.
- change 1 with (Z2R 1); rewrite <- Z2R_minus.
- apply Z2R_le.
+ rewrite <- IZR_Zpower; [|omega].
+ rewrite <- mult_IZR.
+ rewrite <- minus_IZR.
+ apply IZR_le.
apply (Zplus_le_reg_r _ _ 1); ring_simplify.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_mult.
- rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x))));
+ apply lt_IZR.
+ rewrite mult_IZR.
+ rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
[now apply bpow_gt_0|bpow_simplify].
rewrite <- Fx.
rewrite Zplus_comm; rewrite bpow_plus.
@@ -3896,7 +3862,7 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y)
+ rewrite Rmult_minus_distr_r.
unfold Rminus; apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* rewrite <- (Rmult_1_l (u2 * _)).
rewrite Rmult_assoc.
{ apply Rmult_lt_compat.
@@ -3905,33 +3871,33 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - ln_beta (x / y)
- lra.
- apply Rmult_lt_compat_l; [now apply bpow_gt_0|].
apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
- * unfold u2, p, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
- rewrite (Zplus_comm (- _)); fold (Zminus (ln_beta (x / y)) (ln_beta y)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
- apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Zle_refl.
+ apply bpow_mag_gt. }
+ * unfold u2, p, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
+ rewrite (Zplus_comm (- _)); fold (Zminus (mag (x / y)) (mag y)).
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ apply Hexp; try assumption; rewrite <- Hxy; rewrite Hf1; apply Z.le_refl.
Qed.
-Lemma double_round_div_aux1 :
+Lemma round_round_div_aux1 :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_div_hyp fexp1 fexp2 ->
+ round_round_div_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z ->
+ (fexp1 (mag (x / y)) <= mag (x / y))%Z ->
~ (midp fexp1 (x / y) - / 2 * ulp beta fexp2 (x / y)
<= x / y
< midp fexp1 (x / y)).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1.
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp1 (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
assert (S : (x / y <> 0)%R).
apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
now apply Rinv_neq_0_compat, Rgt_not_eq.
@@ -3945,14 +3911,14 @@ cut (~ (/ 2 * (ulp beta fexp1 (x / y) - ulp beta fexp2 (x / y))
- apply (Rplus_lt_reg_l (round beta fexp1 Zfloor (x / y))).
ring_simplify.
apply H'. }
-set (u1 := bpow (fexp1 (ln_beta (x / y)))).
-set (u2 := bpow (fexp2 (ln_beta (x / y)))).
+set (u1 := bpow (fexp1 (mag (x / y)))).
+set (u2 := bpow (fexp2 (mag (x / y)))).
set (x' := round beta fexp1 Zfloor (x / y)).
rewrite 2!ulp_neq_0; trivial.
revert Fx Fy.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
-set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))).
+set (my := Ztrunc (y * bpow (- fexp1 (mag y)))).
intros Fx Fy.
intro Hlr.
apply (Rlt_irrefl (/ 2 * (u1 - u2))).
@@ -3966,48 +3932,47 @@ apply (Rmult_lt_reg_l 2); [lra|].
rewrite Rmult_minus_distr_l; rewrite Rmult_plus_distr_l.
do 5 rewrite <- Rmult_assoc.
rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l.
-destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
- - fexp1 (ln_beta y))%Z) as [He|He].
-- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y)) <= fexp1 (ln_beta x) *)
+destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
+ - fexp1 (mag y))%Z) as [He|He].
+- (* fexp1 (mag (x / y)) + fexp1 (mag y)) <= fexp1 (mag x) *)
apply Rle_lt_trans with (2 * x' * y + u1 * y
- - bpow (fexp1 (ln_beta (x / y))
- + fexp1 (ln_beta y))).
+ - bpow (fexp1 (mag (x / y))
+ + fexp1 (mag y))).
+ rewrite Fx at 1; rewrite Fy at 1 2.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y))
- - fexp1 (ln_beta y))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y))
+ - fexp1 (mag y))));
[now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)).
bpow_simplify.
replace (2 * x' * _ * _)
- with (2 * Z2R my * x' * bpow (- fexp1 (ln_beta (x / y)))) by ring.
+ with (2 * IZR my * x' * bpow (- fexp1 (mag (x / y)))) by ring.
rewrite (Rmult_comm u1).
- unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl.
+ unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl.
bpow_simplify.
- rewrite <- Z2R_Zpower; [|exact He].
- change 2 with (Z2R 2).
- do 4 rewrite <- Z2R_mult.
- rewrite <- Z2R_plus.
- change 1 with (Z2R 1); rewrite <- Z2R_minus.
- apply Z2R_le.
+ rewrite <- IZR_Zpower; [|exact He].
+ do 4 rewrite <- mult_IZR.
+ rewrite <- plus_IZR.
+ rewrite <- minus_IZR.
+ apply IZR_le.
apply (Zplus_le_reg_r _ _ 1); ring_simplify.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_plus.
- do 4 rewrite Z2R_mult; simpl.
- rewrite Z2R_Zpower; [|exact He].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y))
- + fexp1 (ln_beta y))));
+ apply lt_IZR.
+ rewrite plus_IZR.
+ do 4 rewrite mult_IZR; simpl.
+ rewrite IZR_Zpower; [|exact He].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y))
+ + fexp1 (mag y))));
[now apply bpow_gt_0|bpow_simplify].
rewrite Rmult_assoc.
rewrite <- Fx.
- rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)).
+ rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)).
rewrite Rmult_assoc.
rewrite bpow_plus.
- rewrite <- (Rmult_assoc (Z2R (Zfloor _))).
- change (Z2R (Zfloor _) * _) with x'.
- do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))).
+ rewrite <- (Rmult_assoc (IZR (Zfloor _))).
+ change (IZR (Zfloor _) * _) with x'.
+ do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))).
rewrite Rmult_assoc.
- do 2 rewrite <- (Rmult_assoc (Z2R my)).
+ do 2 rewrite <- (Rmult_assoc (IZR my)).
rewrite <- Fy.
change (bpow _) with u1.
apply (Rmult_lt_reg_l (/ 2)); [lra|].
@@ -4022,60 +3987,59 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
now rewrite Rmult_comm.
+ apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* { apply Rmult_lt_compat_l.
- apply bpow_gt_0.
- apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
- * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
+ apply bpow_mag_gt. }
+ * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
[now apply Hexp; [| |rewrite <- Hxy]|].
- replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring.
+ replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring.
apply Hexp.
- { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z;
+ { now assert (fexp1 (mag x + 1) <= mag x)%Z;
[apply valid_exp|omega]. }
{ assumption. }
- replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring.
+ replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring.
now rewrite <- Hxy.
-- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *)
- apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (ln_beta x))).
+- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *)
+ apply Rle_lt_trans with (2 * x' * y + u1 * y - bpow (fexp1 (mag x))).
+ rewrite Fx at 1; rewrite Fy at 1 2.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_minus_distr_r; rewrite (Rmult_plus_distr_r (_ * _ * _)).
bpow_simplify.
replace (2 * x' * _ * _)
- with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring.
+ with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring.
rewrite (Rmult_comm u1).
- unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl.
+ unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl.
bpow_simplify.
- rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega].
- change 2 with (Z2R 2).
- do 5 rewrite <- Z2R_mult.
- rewrite <- Z2R_plus.
- change 1 with (Z2R 1); rewrite <- Z2R_minus.
- apply Z2R_le.
+ rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega].
+ do 5 rewrite <- mult_IZR.
+ rewrite <- plus_IZR.
+ rewrite <- minus_IZR.
+ apply IZR_le.
apply (Zplus_le_reg_r _ _ 1); ring_simplify.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_plus.
- do 5 rewrite Z2R_mult; simpl.
- rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x))));
+ apply lt_IZR.
+ rewrite plus_IZR.
+ do 5 rewrite mult_IZR; simpl.
+ rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
[now apply bpow_gt_0|].
rewrite Rmult_assoc.
rewrite <- Fx.
- rewrite (Rmult_plus_distr_r _ _ (Fcore_Raux.bpow _ _)).
+ rewrite (Rmult_plus_distr_r _ _ (Raux.bpow _ _)).
bpow_simplify.
rewrite Rmult_assoc.
rewrite bpow_plus.
- rewrite <- (Rmult_assoc (Z2R (Zfloor _))).
- change (Z2R (Zfloor _) * _) with x'.
- do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))).
+ rewrite <- (Rmult_assoc (IZR (Zfloor _))).
+ change (IZR (Zfloor _) * _) with x'.
+ do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))).
rewrite Rmult_assoc.
- do 2 rewrite <- (Rmult_assoc (Z2R my)).
+ do 2 rewrite <- (Rmult_assoc (IZR my)).
rewrite <- Fy.
change (bpow _) with u1.
apply (Rmult_lt_reg_l (/ 2)); [lra|].
@@ -4090,37 +4054,37 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
now rewrite Rmult_comm.
+ apply Rplus_lt_compat_l.
apply Ropp_lt_contravar.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* { apply Rmult_lt_compat_l.
- apply bpow_gt_0.
- apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
- * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
+ apply bpow_mag_gt. }
+ * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
rewrite (Zplus_comm (- _)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
apply Hexp; try assumption; rewrite <- Hxy; omega.
Qed.
-Lemma double_round_div_aux2 :
+Lemma round_round_div_aux2 :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
- double_round_div_hyp fexp1 fexp2 ->
+ round_round_div_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- (fexp1 (ln_beta (x / y)) <= ln_beta (x / y))%Z ->
+ (fexp1 (mag (x / y)) <= mag (x / y))%Z ->
~ (midp fexp1 (x / y)
< x / y
<= midp fexp1 (x / y) + / 2 * ulp beta fexp2 (x / y)).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Hexp x y Px Py Fx Fy Hf1.
-assert (Hfx : (fexp1 (ln_beta x) < ln_beta x)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
-assert (Hfy : (fexp1 (ln_beta y) < ln_beta y)%Z);
- [now apply ln_beta_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfx : (fexp1 (mag x) < mag x)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
+assert (Hfy : (fexp1 (mag y) < mag y)%Z);
+ [now apply mag_generic_gt; [|apply Rgt_not_eq|]|].
cut (~ (/ 2 * ulp beta fexp1 (x / y)
< x / y - round beta fexp1 Zfloor (x / y)
<= / 2 * (ulp beta fexp1 (x / y) + ulp beta fexp2 (x / y)))).
@@ -4131,17 +4095,17 @@ cut (~ (/ 2 * ulp beta fexp1 (x / y)
- apply (Rplus_le_reg_l (round beta fexp1 Zfloor (x / y))).
ring_simplify.
apply H'. }
-set (u1 := bpow (fexp1 (ln_beta (x / y)))).
-set (u2 := bpow (fexp2 (ln_beta (x / y)))).
+set (u1 := bpow (fexp1 (mag (x / y)))).
+set (u2 := bpow (fexp2 (mag (x / y)))).
set (x' := round beta fexp1 Zfloor (x / y)).
assert (S : (x / y <> 0)%R).
apply Rmult_integral_contrapositive_currified; [now apply Rgt_not_eq|idtac].
now apply Rinv_neq_0_compat, Rgt_not_eq.
rewrite 2!ulp_neq_0; trivial.
revert Fx Fy.
-unfold generic_format, F2R, scaled_mantissa, canonic_exp; simpl.
-set (mx := Ztrunc (x * bpow (- fexp1 (ln_beta x)))).
-set (my := Ztrunc (y * bpow (- fexp1 (ln_beta y)))).
+unfold generic_format, F2R, scaled_mantissa, cexp; simpl.
+set (mx := Ztrunc (x * bpow (- fexp1 (mag x)))).
+set (my := Ztrunc (y * bpow (- fexp1 (mag y)))).
intros Fx Fy.
intro Hlr.
apply (Rlt_irrefl (/ 2 * (u1 + u2))).
@@ -4155,76 +4119,75 @@ apply (Rmult_lt_reg_l 2); [lra|].
do 2 rewrite Rmult_plus_distr_l.
do 5 rewrite <- Rmult_assoc.
rewrite Rinv_r; [|lra]; do 2 rewrite Rmult_1_l.
-destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
- - fexp1 (ln_beta y))%Z) as [He|He].
-- (* fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) <= fexp1 (ln_beta x) *)
- apply Rlt_le_trans with (u1 * y + bpow (fexp1 (ln_beta (x / y))
- + fexp1 (ln_beta y))
+destruct (Zle_or_lt Z0 (fexp1 (mag x) - fexp1 (mag (x / y))
+ - fexp1 (mag y))%Z) as [He|He].
+- (* fexp1 (mag (x / y)) + fexp1 (mag y) <= fexp1 (mag x) *)
+ apply Rlt_le_trans with (u1 * y + bpow (fexp1 (mag (x / y))
+ + fexp1 (mag y))
+ 2 * x' * y).
+ apply Rplus_lt_compat_r, Rplus_lt_compat_l.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* { apply Rmult_lt_compat_l.
- apply bpow_gt_0.
- apply Rabs_lt_inv.
- apply bpow_ln_beta_gt. }
- * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
+ apply bpow_mag_gt. }
+ * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
rewrite <- Zplus_assoc; rewrite (Zplus_comm (- _)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
[now apply Hexp; [| |rewrite <- Hxy]|].
- replace (_ - _ + 1)%Z with ((ln_beta x + 1) - ln_beta y)%Z by ring.
+ replace (_ - _ + 1)%Z with ((mag x + 1) - mag y)%Z by ring.
apply Hexp.
- { now assert (fexp1 (ln_beta x + 1) <= ln_beta x)%Z;
+ { now assert (fexp1 (mag x + 1) <= mag x)%Z;
[apply valid_exp|omega]. }
{ assumption. }
- replace (_ + 1 - _)%Z with (ln_beta x - ln_beta y + 1)%Z by ring.
+ replace (_ + 1 - _)%Z with (mag x - mag y + 1)%Z by ring.
now rewrite <- Hxy.
+ apply Rge_le; rewrite Fx at 1; apply Rle_ge.
- replace (u1 * y) with (u1 * (Z2R my * bpow (fexp1 (ln_beta y))));
+ replace (u1 * y) with (u1 * (IZR my * bpow (fexp1 (mag y))));
[|now apply eq_sym; rewrite Fy at 1].
- replace (2 * x' * y) with (2 * x' * (Z2R my * bpow (fexp1 (ln_beta y))));
+ replace (2 * x' * y) with (2 * x' * (IZR my * bpow (fexp1 (mag y))));
[|now apply eq_sym; rewrite Fy at 1].
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta (x / y))
- - fexp1 (ln_beta y))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag (x / y))
+ - fexp1 (mag y))));
[now apply bpow_gt_0|].
do 2 rewrite Rmult_plus_distr_r.
bpow_simplify.
rewrite (Rmult_comm u1).
- unfold u1, ulp, canonic_exp; bpow_simplify.
+ unfold u1, ulp, cexp; bpow_simplify.
rewrite (Rmult_assoc 2).
rewrite (Rmult_comm x').
rewrite (Rmult_assoc 2).
- unfold x', round, F2R, scaled_mantissa, canonic_exp; simpl.
+ unfold x', round, F2R, scaled_mantissa, cexp; simpl.
bpow_simplify.
- rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|exact He].
- change 2 with (Z2R 2).
- do 4 rewrite <- Z2R_mult.
- change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus.
- apply Z2R_le.
+ rewrite <- (IZR_Zpower _ (_ - _)%Z); [|exact He].
+ do 4 rewrite <- mult_IZR.
+ do 2 rewrite <- plus_IZR.
+ apply IZR_le.
rewrite Zplus_comm, Zplus_assoc.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_plus.
- do 4 rewrite Z2R_mult; simpl.
- rewrite Z2R_Zpower; [|exact He].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta y))));
+ apply lt_IZR.
+ rewrite plus_IZR.
+ do 4 rewrite mult_IZR; simpl.
+ rewrite IZR_Zpower; [|exact He].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag y))));
[now apply bpow_gt_0|].
rewrite Rmult_plus_distr_r.
- rewrite (Rmult_comm _ (Z2R _)).
+ rewrite (Rmult_comm _ (IZR _)).
do 2 rewrite Rmult_assoc.
rewrite <- Fy.
bpow_simplify.
unfold Zminus; rewrite bpow_plus.
- rewrite (Rmult_assoc _ (Z2R mx)).
- rewrite <- (Rmult_assoc (Z2R mx)).
+ rewrite (Rmult_assoc _ (IZR mx)).
+ rewrite <- (Rmult_assoc (IZR mx)).
rewrite <- Fx.
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta (x / y)))));
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag (x / y)))));
[now apply bpow_gt_0|].
rewrite Rmult_plus_distr_r.
bpow_simplify.
rewrite (Rmult_comm _ y).
do 2 rewrite Rmult_assoc.
- change (Z2R (Zfloor _) * _) with x'.
+ change (IZR (Zfloor _) * _) with x'.
change (bpow _) with u1.
apply (Rmult_lt_reg_l (/ 2)); [lra|].
rewrite Rmult_plus_distr_l.
@@ -4239,52 +4202,51 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
rewrite Rinv_l; [|now apply Rgt_not_eq]; do 2 rewrite Rmult_1_l.
rewrite (Rmult_comm (/ y)).
now rewrite (Rplus_comm (- x')).
-- (* fexp1 (ln_beta x) < fexp1 (ln_beta (x / y)) + fexp1 (ln_beta y) *)
- apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (ln_beta x))).
+- (* fexp1 (mag x) < fexp1 (mag (x / y)) + fexp1 (mag y) *)
+ apply Rlt_le_trans with (2 * x' * y + u1 * y + bpow (fexp1 (mag x))).
+ rewrite Rplus_comm, Rplus_assoc; do 2 apply Rplus_lt_compat_l.
- apply Rlt_le_trans with (u2 * bpow (ln_beta y)).
+ apply Rlt_le_trans with (u2 * bpow (mag y)).
* apply Rmult_lt_compat_l.
now apply bpow_gt_0.
- now apply Rabs_lt_inv; apply bpow_ln_beta_gt.
- * unfold u2, ulp, canonic_exp; bpow_simplify; apply bpow_le.
- apply (Zplus_le_reg_r _ _ (- ln_beta y)); ring_simplify.
+ now apply Rabs_lt_inv; apply bpow_mag_gt.
+ * unfold u2, ulp, cexp; bpow_simplify; apply bpow_le.
+ apply (Zplus_le_reg_r _ _ (- mag y)); ring_simplify.
rewrite (Zplus_comm (- _)).
- destruct (ln_beta_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
+ destruct (mag_div_disj x y Px Py) as [Hxy|Hxy]; rewrite Hxy;
apply Hexp; try assumption; rewrite <- Hxy; omega.
+ apply Rge_le; rewrite Fx at 1; apply Rle_ge.
rewrite Fy at 1 2.
- apply (Rmult_le_reg_r (bpow (- fexp1 (ln_beta x))));
+ apply (Rmult_le_reg_r (bpow (- fexp1 (mag x))));
[now apply bpow_gt_0|].
do 2 rewrite Rmult_plus_distr_r.
bpow_simplify.
replace (2 * x' * _ * _)
- with (2 * Z2R my * x' * bpow (fexp1 (ln_beta y) - fexp1 (ln_beta x))) by ring.
+ with (2 * IZR my * x' * bpow (fexp1 (mag y) - fexp1 (mag x))) by ring.
rewrite (Rmult_comm u1).
- unfold x', u1, round, F2R, ulp, scaled_mantissa, canonic_exp; simpl.
+ unfold x', u1, round, F2R, ulp, scaled_mantissa, cexp; simpl.
bpow_simplify.
- rewrite <- (Z2R_Zpower _ (_ - _)%Z); [|omega].
- change 2 with (Z2R 2).
- do 5 rewrite <- Z2R_mult.
- change 1 with (Z2R 1); do 2 rewrite <- Z2R_plus.
- apply Z2R_le.
+ rewrite <- (IZR_Zpower _ (_ - _)%Z); [|omega].
+ do 5 rewrite <- mult_IZR.
+ do 2 rewrite <- plus_IZR.
+ apply IZR_le.
apply Zlt_le_succ.
- apply lt_Z2R.
- rewrite Z2R_plus.
- do 5 rewrite Z2R_mult; simpl.
- rewrite Z2R_Zpower; [|omega].
- apply (Rmult_lt_reg_r (bpow (fexp1 (ln_beta x))));
+ apply lt_IZR.
+ rewrite plus_IZR.
+ do 5 rewrite mult_IZR; simpl.
+ rewrite IZR_Zpower; [|omega].
+ apply (Rmult_lt_reg_r (bpow (fexp1 (mag x))));
[now apply bpow_gt_0|].
- rewrite (Rmult_assoc _ (Z2R mx)).
+ rewrite (Rmult_assoc _ (IZR mx)).
rewrite <- Fx.
rewrite Rmult_plus_distr_r.
bpow_simplify.
rewrite bpow_plus.
rewrite Rmult_assoc.
- rewrite <- (Rmult_assoc (Z2R _)).
- change (Z2R _ * bpow _) with x'.
- do 2 rewrite (Rmult_comm _ (bpow (fexp1 (ln_beta y)))).
+ rewrite <- (Rmult_assoc (IZR _)).
+ change (IZR _ * bpow _) with x'.
+ do 2 rewrite (Rmult_comm _ (bpow (fexp1 (mag y)))).
rewrite Rmult_assoc.
- do 2 rewrite <- (Rmult_assoc (Z2R my)).
+ do 2 rewrite <- (Rmult_assoc (IZR my)).
rewrite <- Fy.
change (bpow _) with u1.
apply (Rmult_lt_reg_l (/ 2)); [lra|].
@@ -4302,55 +4264,55 @@ destruct (Zle_or_lt Z0 (fexp1 (ln_beta x) - fexp1 (ln_beta (x / y))
now rewrite (Rplus_comm (- x')).
Qed.
-Lemma double_round_div_aux :
+Lemma round_round_div_aux :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
(exists n, (beta = 2 * n :> Z)%Z) ->
- double_round_div_hyp fexp1 fexp2 ->
+ round_round_div_hyp fexp1 fexp2 ->
forall x y,
0 < x -> 0 < y ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x / y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x / y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Px Py Fx Fy.
assert (Pxy : 0 < x / y).
{ apply Rmult_lt_0_compat; [exact Px|].
now apply Rinv_0_lt_compat. }
-apply double_round_all_mid_cases.
+apply round_round_all_mid_cases.
- exact Vfexp1.
- exact Vfexp2.
- exact Pxy.
- apply Hexp.
- intros Hf1 Hlxy.
casetype False.
- now apply (double_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
+ now apply (round_round_div_aux0 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
- intros Hf1 Hlxy.
casetype False.
- now apply (double_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
+ now apply (round_round_div_aux1 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
- intro H.
- apply double_round_eq_mid_beta_even; try assumption.
+ apply round_round_eq_mid_beta_even; try assumption.
apply Hexp.
- intros Hf1 Hlxy.
casetype False.
- now apply (double_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
+ now apply (round_round_div_aux2 fexp1 fexp2 _ _ choice1 choice2 Hexp x y).
Qed.
-Lemma double_round_div :
+Lemma round_round_div :
forall fexp1 fexp2 : Z -> Z,
Valid_exp fexp1 -> Valid_exp fexp2 ->
forall (choice1 choice2 : Z -> bool),
(exists n, (beta = 2 * n :> Z)%Z) ->
- double_round_div_hyp fexp1 fexp2 ->
+ round_round_div_hyp fexp1 fexp2 ->
forall x y,
y <> 0 ->
generic_format beta fexp1 x ->
generic_format beta fexp1 y ->
- double_round_eq fexp1 fexp2 choice1 choice2 (x / y).
+ round_round_eq fexp1 fexp2 choice1 choice2 (x / y).
Proof.
intros fexp1 fexp2 Vfexp1 Vfexp2 choice1 choice2 Ebeta Hexp x y Nzy Fx Fy.
-unfold double_round_eq.
+unfold round_round_eq.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
- (* x < 0 *)
destruct (Rtotal_order y 0) as [Ny|[Zy|Py]].
@@ -4367,7 +4329,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
rewrite Ropp_0 in Nx, Ny.
apply generic_format_opp in Fx.
apply generic_format_opp in Fy.
- now apply double_round_div_aux.
+ now apply round_round_div_aux.
+ (* y = 0 *)
now casetype False; apply Nzy.
+ (* y > 0 *)
@@ -4378,7 +4340,7 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
apply Ropp_lt_contravar in Nx.
rewrite Ropp_0 in Nx.
apply generic_format_opp in Fx.
- now apply double_round_div_aux.
+ now apply round_round_div_aux.
- (* x = 0 *)
rewrite Zx.
unfold Rdiv; rewrite Rmult_0_l.
@@ -4394,50 +4356,48 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
apply Ropp_lt_contravar in Ny.
rewrite Ropp_0 in Ny.
apply generic_format_opp in Fy.
- now apply double_round_div_aux.
+ now apply round_round_div_aux.
+ (* y = 0 *)
now casetype False; apply Nzy.
+ (* y > 0 *)
- now apply double_round_div_aux.
+ now apply round_round_div_aux.
Qed.
Section Double_round_div_FLX.
-Import Fcore_FLX.
-
Variable prec : Z.
Variable prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLX_double_round_div_hyp :
+Lemma FLX_round_round_div_hyp :
(2 * prec <= prec')%Z ->
- double_round_div_hyp (FLX_exp prec) (FLX_exp prec').
+ round_round_div_hyp (FLX_exp prec) (FLX_exp prec').
Proof.
intros Hprec.
unfold Prec_gt_0 in prec_gt_0_.
unfold FLX_exp.
-unfold double_round_div_hyp.
+unfold round_round_div_hyp.
split; [now intro ex; omega|].
split; [|split; [|split]]; intros ex ey; omega.
Qed.
-Theorem double_round_div_FLX :
+Theorem round_round_div_FLX :
forall choice1 choice2,
(exists n, (beta = 2 * n :> Z)%Z) ->
(2 * prec <= prec')%Z ->
forall x y,
y <> 0 ->
FLX_format beta prec x -> FLX_format beta prec y ->
- double_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y).
+ round_round_eq (FLX_exp prec) (FLX_exp prec') choice1 choice2 (x / y).
Proof.
intros choice1 choice2 Ebeta Hprec x y Nzy Fx Fy.
-apply double_round_div.
+apply round_round_div.
- now apply FLX_exp_valid.
- now apply FLX_exp_valid.
- exact Ebeta.
-- now apply FLX_double_round_div_hyp.
+- now apply FLX_round_round_div_hyp.
- exact Nzy.
- now apply generic_format_FLX.
- now apply generic_format_FLX.
@@ -4447,24 +4407,21 @@ End Double_round_div_FLX.
Section Double_round_div_FLT.
-Import Fcore_FLX.
-Import Fcore_FLT.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FLT_double_round_div_hyp :
+Lemma FLT_round_round_div_hyp :
(emin' <= emin - prec - 2)%Z ->
(2 * prec <= prec')%Z ->
- double_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
+ round_round_div_hyp (FLT_exp emin prec) (FLT_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FLT_exp.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_div_hyp.
+unfold round_round_div_hyp.
split; [intro ex|split; [|split; [|split]]; intros ex ey].
- generalize (Zmax_spec (ex - prec') emin').
generalize (Zmax_spec (ex - prec) emin).
@@ -4491,7 +4448,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey].
omega.
Qed.
-Theorem double_round_div_FLT :
+Theorem round_round_div_FLT :
forall choice1 choice2,
(exists n, (beta = 2 * n :> Z)%Z) ->
(emin' <= emin - prec - 2)%Z ->
@@ -4499,15 +4456,15 @@ Theorem double_round_div_FLT :
forall x y,
y <> 0 ->
FLT_format beta emin prec x -> FLT_format beta emin prec y ->
- double_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
+ round_round_eq (FLT_exp emin prec) (FLT_exp emin' prec')
choice1 choice2 (x / y).
Proof.
intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy.
-apply double_round_div.
+apply round_round_div.
- now apply FLT_exp_valid.
- now apply FLT_exp_valid.
- exact Ebeta.
-- now apply FLT_double_round_div_hyp.
+- now apply FLT_round_round_div_hyp.
- exact Nzy.
- now apply generic_format_FLT.
- now apply generic_format_FLT.
@@ -4517,25 +4474,22 @@ End Double_round_div_FLT.
Section Double_round_div_FTZ.
-Import Fcore_FLX.
-Import Fcore_FTZ.
-
Variable emin prec : Z.
Variable emin' prec' : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Context { prec_gt_0_' : Prec_gt_0 prec' }.
-Lemma FTZ_double_round_div_hyp :
+Lemma FTZ_round_round_div_hyp :
(emin' + prec' <= emin - 1)%Z ->
(2 * prec <= prec')%Z ->
- double_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
+ round_round_div_hyp (FTZ_exp emin prec) (FTZ_exp emin' prec').
Proof.
intros Hemin Hprec.
unfold FTZ_exp.
unfold Prec_gt_0 in prec_gt_0_.
unfold Prec_gt_0 in prec_gt_0_.
-unfold double_round_div_hyp.
+unfold round_round_div_hyp.
split; [intro ex|split; [|split; [|split]]; intros ex ey].
- destruct (Z.ltb_spec (ex - prec') emin');
destruct (Z.ltb_spec (ex - prec) emin);
@@ -4562,7 +4516,7 @@ split; [intro ex|split; [|split; [|split]]; intros ex ey].
omega.
Qed.
-Theorem double_round_div_FTZ :
+Theorem round_round_div_FTZ :
forall choice1 choice2,
(exists n, (beta = 2 * n :> Z)%Z) ->
(emin' + prec' <= emin - 1)%Z ->
@@ -4570,15 +4524,15 @@ Theorem double_round_div_FTZ :
forall x y,
y <> 0 ->
FTZ_format beta emin prec x -> FTZ_format beta emin prec y ->
- double_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
+ round_round_eq (FTZ_exp emin prec) (FTZ_exp emin' prec')
choice1 choice2 (x / y).
Proof.
intros choice1 choice2 Ebeta Hemin Hprec x y Nzy Fx Fy.
-apply double_round_div.
+apply round_round_div.
- now apply FTZ_exp_valid.
- now apply FTZ_exp_valid.
- exact Ebeta.
-- now apply FTZ_double_round_div_hyp.
+- now apply FTZ_round_round_div_hyp.
- exact Nzy.
- now apply generic_format_FTZ.
- now apply generic_format_FTZ.
diff --git a/flocq/Prop/Fprop_div_sqrt_error.v b/flocq/Prop/Fprop_div_sqrt_error.v
deleted file mode 100644
index 422b6b64..00000000
--- a/flocq/Prop/Fprop_div_sqrt_error.v
+++ /dev/null
@@ -1,300 +0,0 @@
-(**
-This file is part of the Flocq formalization of floating-point
-arithmetic in Coq: http://flocq.gforge.inria.fr/
-
-Copyright (C) 2010-2013 Sylvie Boldo
-#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
-
-This library is free software; you can redistribute it and/or
-modify it under the terms of the GNU Lesser General Public
-License as published by the Free Software Foundation; either
-version 3 of the License, or (at your option) any later version.
-
-This library is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-COPYING file for more details.
-*)
-
-(** * Remainder of the division and square root are in the FLX format *)
-Require Import Fcore.
-Require Import Fcalc_ops.
-Require Import Fprop_relative.
-
-Section Fprop_divsqrt_error.
-
-Variable beta : radix.
-Notation bpow e := (bpow beta e).
-
-Variable prec : Z.
-
-Theorem generic_format_plus_prec:
- forall fexp, (forall e, (fexp e <= e - prec)%Z) ->
- forall x y (fx fy: float beta),
- (x = F2R fx)%R -> (y = F2R fy)%R -> (Rabs (x+y) < bpow (prec+Fexp fx))%R -> (Rabs (x+y) < bpow (prec+Fexp fy))%R
- -> generic_format beta fexp (x+y)%R.
-intros fexp Hfexp x y fx fy Hx Hy H1 H2.
-case (Req_dec (x+y) 0); intros H.
-rewrite H; apply generic_format_0.
-rewrite Hx, Hy, <- F2R_plus.
-apply generic_format_F2R.
-intros _.
-case_eq (Fplus beta fx fy).
-intros mz ez Hz.
-rewrite <- Hz.
-apply Zle_trans with (Zmin (Fexp fx) (Fexp fy)).
-rewrite F2R_plus, <- Hx, <- Hy.
-unfold canonic_exp.
-apply Zle_trans with (1:=Hfexp _).
-apply Zplus_le_reg_l with prec; ring_simplify.
-apply ln_beta_le_bpow with (1 := H).
-now apply Zmin_case.
-rewrite <- Fexp_Fplus, Hz.
-apply Zle_refl.
-Qed.
-
-Theorem ex_Fexp_canonic: forall fexp, forall x, generic_format beta fexp x
- -> exists fx:float beta, (x=F2R fx)%R /\ Fexp fx = canonic_exp beta fexp x.
-intros fexp x; unfold generic_format.
-exists (Float beta (Ztrunc (scaled_mantissa beta fexp x)) (canonic_exp beta fexp x)).
-split; auto.
-Qed.
-
-
-Context { prec_gt_0_ : Prec_gt_0 prec }.
-
-Notation format := (generic_format beta (FLX_exp prec)).
-Notation cexp := (canonic_exp beta (FLX_exp prec)).
-
-Variable choice : Z -> bool.
-
-
-(** Remainder of the division in FLX *)
-Theorem div_error_FLX :
- forall rnd { Zrnd : Valid_rnd rnd } x y,
- format x -> format y ->
- format (x - round beta (FLX_exp prec) rnd (x/y) * y)%R.
-Proof with auto with typeclass_instances.
-intros rnd Zrnd x y Hx Hy.
-destruct (Req_dec y 0) as [Zy|Zy].
-now rewrite Zy, Rmult_0_r, Rminus_0_r.
-destruct (Req_dec (round beta (FLX_exp prec) rnd (x/y)) 0) as [Hr|Hr].
-rewrite Hr; ring_simplify (x-0*y)%R; assumption.
-assert (Zx: x <> R0).
-contradict Hr.
-rewrite Hr.
-unfold Rdiv.
-now rewrite Rmult_0_l, round_0.
-destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)).
-destruct (ex_Fexp_canonic _ y Hy) as (fy,(Hy1,Hy2)).
-destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) rnd (x / y))) as (fr,(Hr1,Hr2)).
-apply generic_format_round...
-unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fy)); trivial.
-intros e; apply Zle_refl.
-now rewrite F2R_opp, F2R_mult, <- Hr1, <- Hy1.
-(* *)
-destruct (relative_error_FLX_ex beta prec (prec_gt_0 prec) rnd (x / y)%R) as (eps,(Heps1,Heps2)).
-rewrite Heps2.
-rewrite <- Rabs_Ropp.
-replace (-(x + - (x / y * (1 + eps) * y)))%R with (x * eps)%R by now field.
-rewrite Rabs_mult.
-apply Rlt_le_trans with (Rabs x * 1)%R.
-apply Rmult_lt_compat_l.
-now apply Rabs_pos_lt.
-apply Rlt_le_trans with (1 := Heps1).
-change 1%R with (bpow 0).
-apply bpow_le.
-generalize (prec_gt_0 prec).
-clear ; omega.
-rewrite Rmult_1_r.
-rewrite Hx2.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex, Hex).
-simpl.
-specialize (Hex Zx).
-apply Rlt_le.
-apply Rlt_le_trans with (1 := proj2 Hex).
-apply bpow_le.
-unfold FLX_exp.
-ring_simplify.
-apply Zle_refl.
-(* *)
-replace (Fexp (Fopp beta (Fmult beta fr fy))) with (Fexp fr + Fexp fy)%Z.
-2: unfold Fopp, Fmult; destruct fr; destruct fy; now simpl.
-replace (x + - (round beta (FLX_exp prec) rnd (x / y) * y))%R with
- (y * (-(round beta (FLX_exp prec) rnd (x / y) - x/y)))%R.
-2: field; assumption.
-rewrite Rabs_mult.
-apply Rlt_le_trans with (Rabs y * bpow (Fexp fr))%R.
-apply Rmult_lt_compat_l.
-now apply Rabs_pos_lt.
-rewrite Rabs_Ropp.
-replace (bpow (Fexp fr)) with (ulp beta (FLX_exp prec) (F2R fr)).
-rewrite <- Hr1.
-apply error_lt_ulp_round...
-apply Rmult_integral_contrapositive_currified; try apply Rinv_neq_0_compat; assumption.
-rewrite ulp_neq_0.
-2: now rewrite <- Hr1.
-apply f_equal.
-now rewrite Hr2, <- Hr1.
-replace (prec+(Fexp fr+Fexp fy))%Z with ((prec+Fexp fy)+Fexp fr)%Z by ring.
-rewrite bpow_plus.
-apply Rmult_le_compat_r.
-apply bpow_ge_0.
-rewrite Hy2; unfold canonic_exp, FLX_exp.
-ring_simplify (prec + (ln_beta beta y - prec))%Z.
-destruct (ln_beta beta y); simpl.
-left; now apply a.
-Qed.
-
-(** Remainder of the square in FLX (with p>1) and rounding to nearest *)
-Variable Hp1 : Zlt 1 prec.
-
-Theorem sqrt_error_FLX_N :
- forall x, format x ->
- format (x - Rsqr (round beta (FLX_exp prec) (Znearest choice) (sqrt x)))%R.
-Proof with auto with typeclass_instances.
-intros x Hx.
-destruct (total_order_T x 0) as [[Hxz|Hxz]|Hxz].
-unfold sqrt.
-destruct (Rcase_abs x).
-rewrite round_0...
-unfold Rsqr.
-now rewrite Rmult_0_l, Rminus_0_r.
-elim (Rlt_irrefl 0).
-now apply Rgt_ge_trans with x.
-rewrite Hxz, sqrt_0, round_0...
-unfold Rsqr.
-rewrite Rmult_0_l, Rminus_0_r.
-apply generic_format_0.
-case (Req_dec (round beta (FLX_exp prec) (Znearest choice) (sqrt x)) 0); intros Hr.
-rewrite Hr; unfold Rsqr; ring_simplify (x-0*0)%R; assumption.
-destruct (ex_Fexp_canonic _ x Hx) as (fx,(Hx1,Hx2)).
-destruct (ex_Fexp_canonic (FLX_exp prec) (round beta (FLX_exp prec) (Znearest choice) (sqrt x))) as (fr,(Hr1,Hr2)).
-apply generic_format_round...
-unfold Rminus; apply generic_format_plus_prec with fx (Fopp beta (Fmult beta fr fr)); trivial.
-intros e; apply Zle_refl.
-unfold Rsqr; now rewrite F2R_opp,F2R_mult, <- Hr1.
-(* *)
-apply Rle_lt_trans with x.
-apply Rabs_minus_le.
-apply Rle_0_sqr.
-destruct (relative_error_N_FLX_ex beta prec (prec_gt_0 prec) choice (sqrt x)) as (eps,(Heps1,Heps2)).
-rewrite Heps2.
-rewrite Rsqr_mult, Rsqr_sqrt, Rmult_comm. 2: now apply Rlt_le.
-apply Rmult_le_compat_r.
-now apply Rlt_le.
-apply Rle_trans with (5²/4²)%R.
-rewrite <- Rsqr_div.
-apply Rsqr_le_abs_1.
-apply Rle_trans with (1 := Rabs_triang _ _).
-rewrite Rabs_R1.
-apply Rplus_le_reg_l with (-1)%R.
-replace (-1 + (1 + Rabs eps))%R with (Rabs eps) by ring.
-apply Rle_trans with (1 := Heps1).
-rewrite Rabs_pos_eq.
-apply Rmult_le_reg_l with 2%R.
-now apply (Z2R_lt 0 2).
-rewrite <- Rmult_assoc, Rinv_r, Rmult_1_l.
-apply Rle_trans with (bpow (-1)).
-apply bpow_le.
-omega.
-replace (2 * (-1 + 5 / 4))%R with (/2)%R by field.
-apply Rinv_le.
-now apply (Z2R_lt 0 2).
-apply (Z2R_le 2).
-unfold Zpower_pos. simpl.
-rewrite Zmult_1_r.
-apply Zle_bool_imp_le.
-apply beta.
-apply Rgt_not_eq.
-now apply (Z2R_lt 0 2).
-unfold Rdiv.
-apply Rmult_le_pos.
-now apply (Z2R_le 0 5).
-apply Rlt_le.
-apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 4).
-apply Rgt_not_eq.
-now apply (Z2R_lt 0 4).
-unfold Rsqr.
-replace (5 * 5 / (4 * 4))%R with (25 * /16)%R by field.
-apply Rmult_le_reg_r with 16%R.
-now apply (Z2R_lt 0 16).
-rewrite Rmult_assoc, Rinv_l, Rmult_1_r.
-now apply (Z2R_le 25 32).
-apply Rgt_not_eq.
-now apply (Z2R_lt 0 16).
-rewrite Hx2; unfold canonic_exp, FLX_exp.
-ring_simplify (prec + (ln_beta beta x - prec))%Z.
-destruct (ln_beta beta x); simpl.
-rewrite <- (Rabs_right x).
-apply a.
-now apply Rgt_not_eq.
-now apply Rgt_ge.
-(* *)
-replace (Fexp (Fopp beta (Fmult beta fr fr))) with (Fexp fr + Fexp fr)%Z.
-2: unfold Fopp, Fmult; destruct fr; now simpl.
-rewrite Hr1.
-replace (x + - Rsqr (F2R fr))%R with (-((F2R fr - sqrt x)*(F2R fr + sqrt x)))%R.
-2: rewrite <- (sqrt_sqrt x) at 3; auto.
-2: unfold Rsqr; ring.
-rewrite Rabs_Ropp, Rabs_mult.
-apply Rle_lt_trans with ((/2*bpow (Fexp fr))* Rabs (F2R fr + sqrt x))%R.
-apply Rmult_le_compat_r.
-apply Rabs_pos.
-apply Rle_trans with (/2*ulp beta (FLX_exp prec) (F2R fr))%R.
-rewrite <- Hr1.
-apply error_le_half_ulp_round...
-right; rewrite ulp_neq_0.
-2: now rewrite <- Hr1.
-apply f_equal.
-rewrite Hr2, <- Hr1; trivial.
-rewrite Rmult_assoc, Rmult_comm.
-replace (prec+(Fexp fr+Fexp fr))%Z with (Fexp fr + (prec+Fexp fr))%Z by ring.
-rewrite bpow_plus, Rmult_assoc.
-apply Rmult_lt_compat_l.
-apply bpow_gt_0.
-apply Rmult_lt_reg_l with (1 := Rlt_0_2).
-apply Rle_lt_trans with (Rabs (F2R fr + sqrt x)).
-right; field.
-apply Rle_lt_trans with (1:=Rabs_triang _ _).
-(* . *)
-assert (Rabs (F2R fr) < bpow (prec + Fexp fr))%R.
-rewrite Hr2; unfold canonic_exp; rewrite Hr1.
-unfold FLX_exp.
-ring_simplify (prec + (ln_beta beta (F2R fr) - prec))%Z.
-destruct (ln_beta beta (F2R fr)); simpl.
-apply a.
-rewrite <- Hr1; auto.
-(* . *)
-apply Rlt_le_trans with (bpow (prec + Fexp fr)+ Rabs (sqrt x))%R.
-now apply Rplus_lt_compat_r.
-(* . *)
-replace (2 * bpow (prec + Fexp fr))%R with (bpow (prec + Fexp fr) + bpow (prec + Fexp fr))%R by ring.
-apply Rplus_le_compat_l.
-assert (sqrt x <> 0)%R.
-apply Rgt_not_eq.
-now apply sqrt_lt_R0.
-destruct (ln_beta beta (sqrt x)) as (es,Es).
-specialize (Es H0).
-apply Rle_trans with (bpow es).
-now apply Rlt_le.
-apply bpow_le.
-case (Zle_or_lt es (prec + Fexp fr)) ; trivial.
-intros H1.
-absurd (Rabs (F2R fr) < bpow (es - 1))%R.
-apply Rle_not_lt.
-rewrite <- Hr1.
-apply abs_round_ge_generic...
-apply generic_format_bpow.
-unfold FLX_exp; omega.
-apply Es.
-apply Rlt_le_trans with (1:=H).
-apply bpow_le.
-omega.
-now apply Rlt_le.
-Qed.
-
-End Fprop_divsqrt_error.
diff --git a/flocq/Prop/Fprop_mult_error.v b/flocq/Prop/Mult_error.v
index 44448cd6..57a3856f 100644
--- a/flocq/Prop/Fprop_mult_error.v
+++ b/flocq/Prop/Mult_error.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,8 +18,7 @@ COPYING file for more details.
*)
(** * Error of the multiplication is in the FLX/FLT format *)
-Require Import Fcore.
-Require Import Fcalc_ops.
+Require Import Core Operations Plus_error.
Section Fprop_mult_error.
@@ -30,7 +29,7 @@ Variable prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Notation format := (generic_format beta (FLX_exp prec)).
-Notation cexp := (canonic_exp beta (FLX_exp prec)).
+Notation cexp := (cexp beta (FLX_exp prec)).
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
@@ -41,9 +40,9 @@ Lemma mult_error_FLX_aux:
format x -> format y ->
(round beta (FLX_exp prec) rnd (x * y) - (x * y) <> 0)%R ->
exists f:float beta,
- (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R
- /\ (canonic_exp beta (FLX_exp prec) (F2R f) <= Fexp f)%Z
- /\ (Fexp f = cexp x + cexp y)%Z.
+ (F2R f = round beta (FLX_exp prec) rnd (x * y) - (x * y))%R
+ /\ (cexp (F2R f) <= Fexp f)%Z
+ /\ (Fexp f = cexp x + cexp y)%Z.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hz.
set (f := (round beta (FLX_exp prec) rnd (x * y))).
@@ -52,26 +51,26 @@ contradict Hz.
rewrite Hxy0.
rewrite round_0...
ring.
-destruct (ln_beta beta (x * y)) as (exy, Hexy).
+destruct (mag beta (x * y)) as (exy, Hexy).
specialize (Hexy Hxy0).
-destruct (ln_beta beta (f - x * y)) as (er, Her).
+destruct (mag beta (f - x * y)) as (er, Her).
specialize (Her Hz).
-destruct (ln_beta beta x) as (ex, Hex).
+destruct (mag beta x) as (ex, Hex).
assert (Hx0: (x <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_l.
specialize (Hex Hx0).
-destruct (ln_beta beta y) as (ey, Hey).
+destruct (mag beta y) as (ey, Hey).
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
specialize (Hey Hy0).
(* *)
assert (Hc1: (cexp (x * y)%R - prec <= cexp x + cexp y)%Z).
-unfold canonic_exp, FLX_exp.
-rewrite ln_beta_unique with (1 := Hex).
-rewrite ln_beta_unique with (1 := Hey).
-rewrite ln_beta_unique with (1 := Hexy).
+unfold cexp, FLX_exp.
+rewrite mag_unique with (1 := Hex).
+rewrite mag_unique with (1 := Hey).
+rewrite mag_unique with (1 := Hexy).
cut (exy - 1 < ex + ey)%Z. omega.
apply (lt_bpow beta).
apply Rle_lt_trans with (1 := proj1 Hexy).
@@ -84,10 +83,10 @@ apply Hex.
apply Hey.
(* *)
assert (Hc2: (cexp x + cexp y <= cexp (x * y)%R)%Z).
-unfold canonic_exp, FLX_exp.
-rewrite ln_beta_unique with (1 := Hex).
-rewrite ln_beta_unique with (1 := Hey).
-rewrite ln_beta_unique with (1 := Hexy).
+unfold cexp, FLX_exp.
+rewrite mag_unique with (1 := Hex).
+rewrite mag_unique with (1 := Hey).
+rewrite mag_unique with (1 := Hexy).
cut ((ex - 1) + (ey - 1) < exy)%Z.
generalize (prec_gt_0 prec).
clear ; omega.
@@ -120,16 +119,16 @@ split;[assumption|split].
rewrite Hr.
simpl.
clear Hr.
-apply Zle_trans with (cexp (x * y)%R - prec)%Z.
-unfold canonic_exp, FLX_exp.
+apply Z.le_trans with (cexp (x * y)%R - prec)%Z.
+unfold cexp, FLX_exp.
apply Zplus_le_compat_r.
-rewrite ln_beta_unique with (1 := Hexy).
-apply ln_beta_le_bpow with (1 := Hz).
+rewrite mag_unique with (1 := Hexy).
+apply mag_le_bpow with (1 := Hz).
replace (bpow (exy - prec)) with (ulp beta (FLX_exp prec) (x * y)).
apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
-unfold canonic_exp.
-now rewrite ln_beta_unique with (1 := Hexy).
+unfold cexp.
+now rewrite mag_unique with (1 := Hexy).
apply Hc1.
reflexivity.
Qed.
@@ -149,6 +148,24 @@ rewrite <- H1.
now apply generic_format_F2R.
Qed.
+Lemma mult_bpow_exact_FLX :
+ forall x e,
+ format x ->
+ format (x * bpow e)%R.
+Proof.
+intros x e Fx.
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ rewrite Zx, Rmult_0_l; apply generic_format_0. }
+rewrite Fx.
+set (mx := Ztrunc _); set (ex := cexp _).
+pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta).
+apply (generic_format_F2R' _ _ _ f).
+{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
+intro Nzmx; unfold mx, ex; rewrite <- Fx.
+unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
+unfold FLX_exp; omega.
+Qed.
+
End Fprop_mult_error.
Section Fprop_mult_error_FLT.
@@ -160,7 +177,7 @@ Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
Notation format := (generic_format beta (FLT_exp emin prec)).
-Notation cexp := (canonic_exp beta (FLT_exp emin prec)).
+Notation cexp := (cexp beta (FLT_exp emin prec)).
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
@@ -169,7 +186,7 @@ Context { valid_rnd : Valid_rnd rnd }.
Theorem mult_error_FLT :
forall x y,
format x -> format y ->
- (x*y = 0)%R \/ (bpow (emin + 2*prec - 1) <= Rabs (x * y))%R ->
+ (x * y <> 0 -> bpow (emin + 2*prec - 1) <= Rabs (x * y))%R ->
format (round beta (FLT_exp emin prec) rnd (x * y) - (x * y))%R.
Proof with auto with typeclass_instances.
intros x y Hx Hy Hxy.
@@ -177,12 +194,13 @@ set (f := (round beta (FLT_exp emin prec) rnd (x * y))).
destruct (Req_dec (f - x * y) 0) as [Hr0|Hr0].
rewrite Hr0.
apply generic_format_0.
-destruct Hxy as [Hxy|Hxy].
+destruct (Req_dec (x * y) 0) as [Hxy'|Hxy'].
unfold f.
-rewrite Hxy.
+rewrite Hxy'.
rewrite round_0...
ring_simplify (0 - 0)%R.
apply generic_format_0.
+specialize (Hxy Hxy').
destruct (mult_error_FLX_aux beta prec rnd x y) as ((m,e),(H1,(H2,H3))).
now apply generic_format_FLX_FLT with emin.
now apply generic_format_FLX_FLT with emin.
@@ -199,14 +217,14 @@ unfold f; rewrite <- H1.
apply generic_format_F2R.
intros _.
simpl in H2, H3.
-unfold canonic_exp, FLT_exp.
-case (Zmax_spec (ln_beta beta (F2R (Float beta m e)) - prec) emin);
+unfold cexp, FLT_exp.
+case (Zmax_spec (mag beta (F2R (Float beta m e)) - prec) emin);
intros (M1,M2); rewrite M2.
-apply Zle_trans with (2:=H2).
-unfold canonic_exp, FLX_exp.
-apply Zle_refl.
+apply Z.le_trans with (2:=H2).
+unfold cexp, FLX_exp.
+apply Z.le_refl.
rewrite H3.
-unfold canonic_exp, FLX_exp.
+unfold cexp, FLX_exp.
assert (Hxy0:(x*y <> 0)%R).
contradict Hr0.
unfold f.
@@ -219,9 +237,9 @@ now rewrite Hxy0, Rmult_0_l.
assert (Hy0: (y <> 0)%R).
contradict Hxy0.
now rewrite Hxy0, Rmult_0_r.
-destruct (ln_beta beta x) as (ex,Ex) ; simpl.
+destruct (mag beta x) as (ex,Ex) ; simpl.
specialize (Ex Hx0).
-destruct (ln_beta beta y) as (ey,Ey) ; simpl.
+destruct (mag beta y) as (ey,Ey) ; simpl.
specialize (Ey Hy0).
assert (emin + 2 * prec -1 < ex + ey)%Z.
2: omega.
@@ -233,4 +251,85 @@ apply Ex.
apply Ey.
Qed.
+Lemma F2R_ge: forall (y:float beta),
+ (F2R y <> 0)%R -> (bpow (Fexp y) <= Rabs (F2R y))%R.
+Proof.
+intros (ny,ey).
+rewrite <- F2R_Zabs; unfold F2R; simpl.
+case (Zle_lt_or_eq 0 (Z.abs ny)).
+apply Z.abs_nonneg.
+intros Hy _.
+rewrite <- (Rmult_1_l (bpow _)) at 1.
+apply Rmult_le_compat_r.
+apply bpow_ge_0.
+apply IZR_le; omega.
+intros H1 H2; contradict H2.
+replace ny with 0%Z.
+simpl; ring.
+now apply sym_eq, Z.abs_0_iff, sym_eq.
+Qed.
+
+Theorem mult_error_FLT_ge_bpow :
+ forall x y e,
+ format x -> format y ->
+ (bpow (e+2*prec-1) <= Rabs (x * y))%R ->
+ (round beta (FLT_exp emin prec) rnd (x * y) - (x * y) <> 0)%R ->
+ (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x * y) - (x * y)))%R.
+Proof with auto with typeclass_instances.
+intros x y e.
+set (f := (round beta (FLT_exp emin prec) rnd (x * y))).
+intros Fx Fy H1.
+unfold f; rewrite Fx, Fy, <- F2R_mult.
+simpl Fmult.
+destruct (round_repr_same_exp beta (FLT_exp emin prec)
+ rnd (Ztrunc (scaled_mantissa beta (FLT_exp emin prec) x) *
+ Ztrunc (scaled_mantissa beta (FLT_exp emin prec) y))
+ (cexp x + cexp y)) as (n,Hn).
+rewrite Hn; clear Hn.
+rewrite <- F2R_minus, Fminus_same_exp.
+intros K.
+eapply Rle_trans with (2:=F2R_ge _ K).
+simpl (Fexp _).
+apply bpow_le.
+unfold cexp, FLT_exp.
+destruct (mag beta x) as (ex,Hx).
+destruct (mag beta y) as (ey,Hy).
+simpl; apply Z.le_trans with ((ex-prec)+(ey-prec))%Z.
+2: apply Zplus_le_compat; apply Z.le_max_l.
+assert (e + 2*prec -1< ex+ey)%Z;[idtac|omega].
+apply lt_bpow with beta.
+apply Rle_lt_trans with (1:=H1).
+rewrite Rabs_mult, bpow_plus.
+apply Rmult_lt_compat.
+apply Rabs_pos.
+apply Rabs_pos.
+apply Hx.
+intros K'; contradict H1; apply Rlt_not_le.
+rewrite K', Rmult_0_l, Rabs_R0; apply bpow_gt_0.
+apply Hy.
+intros K'; contradict H1; apply Rlt_not_le.
+rewrite K', Rmult_0_r, Rabs_R0; apply bpow_gt_0.
+Qed.
+
+Lemma mult_bpow_exact_FLT :
+ forall x e,
+ format x ->
+ (emin + prec - mag beta x <= e)%Z ->
+ format (x * bpow e)%R.
+Proof.
+intros x e Fx He.
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ rewrite Zx, Rmult_0_l; apply generic_format_0. }
+rewrite Fx.
+set (mx := Ztrunc _); set (ex := cexp _).
+pose (f := {| Fnum := mx; Fexp := ex + e |} : float beta).
+apply (generic_format_F2R' _ _ _ f).
+{ now unfold F2R; simpl; rewrite bpow_plus, Rmult_assoc. }
+intro Nzmx; unfold mx, ex; rewrite <- Fx.
+unfold f, ex; simpl; unfold cexp; rewrite (mag_mult_bpow _ _ _ Nzx).
+unfold FLT_exp; rewrite Z.max_l; [|omega]; rewrite <- Z.add_max_distr_r.
+set (n := (_ - _ + _)%Z); apply (Z.le_trans _ n); [unfold n; omega|].
+apply Z.le_max_l.
+Qed.
+
End Fprop_mult_error_FLT.
diff --git a/flocq/Prop/Fprop_plus_error.v b/flocq/Prop/Plus_error.v
index 9bb5aee8..42f80093 100644
--- a/flocq/Prop/Fprop_plus_error.v
+++ b/flocq/Prop/Plus_error.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -20,15 +20,9 @@ COPYING file for more details.
(** * Error of the rounded-to-nearest addition is representable. *)
Require Import Psatz.
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_float_prop.
-Require Import Fcore_generic_fmt.
-Require Import Fcore_FIX.
-Require Import Fcore_FLX.
-Require Import Fcore_FLT.
-Require Import Fcore_ulp.
-Require Import Fcalc_ops.
+Require Import Raux Defs Float_prop Generic_fmt.
+Require Import FIX FLX FLT Ulp Operations.
+Require Import Relative.
Section Fprop_plus_error.
@@ -44,31 +38,31 @@ Section round_repr_same_exp.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Theorem round_repr_same_exp :
+Lemma round_repr_same_exp :
forall m e,
exists m',
round beta fexp rnd (F2R (Float beta m e)) = F2R (Float beta m' e).
Proof with auto with typeclass_instances.
intros m e.
-set (e' := canonic_exp beta fexp (F2R (Float beta m e))).
+set (e' := cexp beta fexp (F2R (Float beta m e))).
unfold round, scaled_mantissa. fold e'.
destruct (Zle_or_lt e' e) as [He|He].
exists m.
unfold F2R at 2. simpl.
rewrite Rmult_assoc, <- bpow_plus.
-rewrite <- Z2R_Zpower. 2: omega.
-rewrite <- Z2R_mult, Zrnd_Z2R...
+rewrite <- IZR_Zpower. 2: omega.
+rewrite <- mult_IZR, Zrnd_IZR...
unfold F2R. simpl.
-rewrite Z2R_mult.
+rewrite mult_IZR.
rewrite Rmult_assoc.
-rewrite Z2R_Zpower. 2: omega.
+rewrite IZR_Zpower. 2: omega.
rewrite <- bpow_plus.
-apply (f_equal (fun v => Z2R m * bpow v)%R).
+apply (f_equal (fun v => IZR m * bpow v)%R).
ring.
-exists ((rnd (Z2R m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
+exists ((rnd (IZR m * bpow (e - e'))) * Zpower beta (e' - e))%Z.
unfold F2R. simpl.
-rewrite Z2R_mult.
-rewrite Z2R_Zpower. 2: omega.
+rewrite mult_IZR.
+rewrite IZR_Zpower. 2: omega.
rewrite 2!Rmult_assoc.
rewrite <- 2!bpow_plus.
apply (f_equal (fun v => _ * bpow v)%R).
@@ -84,13 +78,13 @@ Variable choice : Z -> bool.
Lemma plus_error_aux :
forall x y,
- (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z ->
+ (cexp beta fexp x <= cexp beta fexp y)%Z ->
format x -> format y ->
format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y.
-set (ex := canonic_exp beta fexp x).
-set (ey := canonic_exp beta fexp y).
+set (ex := cexp beta fexp x).
+set (ey := cexp beta fexp y).
intros He Hx Hy.
destruct (Req_dec (round beta fexp (Znearest choice) (x + y) - (x + y)) R0) as [H0|H0].
rewrite H0.
@@ -116,7 +110,7 @@ apply generic_format_F2R.
intros _.
apply monotone_exp.
rewrite <- H, <- Hxy', <- Hxy.
-apply ln_beta_le_abs.
+apply mag_le_abs.
exact H0.
pattern x at 3 ; replace x with (-(y - (x + y)))%R by ring.
rewrite Rabs_Ropp.
@@ -130,7 +124,7 @@ Theorem plus_error :
format (round beta fexp (Znearest choice) (x + y) - (x + y))%R.
Proof.
intros x y Hx Hy.
-destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)).
+destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)).
now apply plus_error_aux.
rewrite Rplus_comm.
apply plus_error_aux ; try easy.
@@ -154,20 +148,17 @@ Section round_plus_eq_zero_aux.
Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
-Lemma round_plus_eq_zero_aux :
+Lemma round_plus_neq_0_aux :
forall x y,
- (canonic_exp beta fexp x <= canonic_exp beta fexp y)%Z ->
+ (cexp beta fexp x <= cexp beta fexp y)%Z ->
format x -> format y ->
- (0 <= x + y)%R ->
- round beta fexp rnd (x + y) = 0%R ->
- (x + y = 0)%R.
+ (0 < x + y)%R ->
+ round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
-intros x y He Hx Hy Hp Hxy.
-destruct (Req_dec (x + y) 0) as [H0|H0].
-exact H0.
-destruct (ln_beta beta (x + y)) as (exy, Hexy).
+intros x y He Hx Hy Hxy.
+destruct (mag beta (x + y)) as (exy, Hexy).
simpl.
-specialize (Hexy H0).
+specialize (Hexy (Rgt_not_eq _ _ Hxy)).
destruct (Zle_or_lt exy (fexp exy)) as [He'|He'].
(* . *)
assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
@@ -175,19 +166,21 @@ assert (H: (x + y)%R = F2R (Float beta (Ztrunc (x * bpow (- fexp exy)) +
rewrite (subnormal_exponent beta fexp exy x He' Hx) at 1.
rewrite (subnormal_exponent beta fexp exy y He' Hy) at 1.
now rewrite <- F2R_plus, Fplus_same_exp.
-rewrite H in Hxy.
-rewrite round_generic in Hxy...
-now rewrite <- H in Hxy.
+rewrite H.
+rewrite round_generic...
+rewrite <- H.
+now apply Rgt_not_eq.
apply generic_format_F2R.
intros _.
rewrite <- H.
-unfold canonic_exp.
-rewrite ln_beta_unique with (1 := Hexy).
-apply Zle_refl.
+unfold cexp.
+rewrite mag_unique with (1 := Hexy).
+apply Z.le_refl.
(* . *)
+intros H.
elim Rle_not_lt with (1 := round_le beta _ rnd _ _ (proj1 Hexy)).
-rewrite (Rabs_pos_eq _ Hp).
-rewrite Hxy.
+rewrite (Rabs_pos_eq _ (Rlt_le _ _ Hxy)).
+rewrite H.
rewrite round_generic...
apply bpow_gt_0.
apply generic_format_bpow.
@@ -201,40 +194,46 @@ Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
(** rnd(x+y)=0 -> x+y = 0 provided this is not a FTZ format *)
-Theorem round_plus_eq_zero :
+Theorem round_plus_neq_0 :
forall x y,
format x -> format y ->
- round beta fexp rnd (x + y) = 0%R ->
- (x + y = 0)%R.
+ (x + y <> 0)%R ->
+ round beta fexp rnd (x + y) <> 0%R.
Proof with auto with typeclass_instances.
-intros x y Hx Hy.
+intros x y Hx Hy Hxy.
destruct (Rle_or_lt 0 (x + y)) as [H1|H1].
(* . *)
-revert H1.
-destruct (Zle_or_lt (canonic_exp beta fexp x) (canonic_exp beta fexp y)) as [H2|H2].
-now apply round_plus_eq_zero_aux.
+destruct (Zle_or_lt (cexp beta fexp x) (cexp beta fexp y)) as [H2|H2].
+apply round_plus_neq_0_aux...
+lra.
rewrite Rplus_comm.
-apply round_plus_eq_zero_aux ; try easy.
+apply round_plus_neq_0_aux ; try easy.
now apply Zlt_le_weak.
+lra.
(* . *)
-revert H1.
-rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr, <- Ropp_0.
-intros H1.
+rewrite <- (Ropp_involutive (x + y)), Ropp_plus_distr.
rewrite round_opp.
-intros Hxy.
-apply f_equal.
-cut (round beta fexp (Zrnd_opp rnd) (- x + - y) = 0)%R.
-cut (0 <= -x + -y)%R.
-destruct (Zle_or_lt (canonic_exp beta fexp (-x)) (canonic_exp beta fexp (-y))) as [H2|H2].
-apply round_plus_eq_zero_aux ; try apply generic_format_opp...
+apply Ropp_neq_0_compat.
+destruct (Zle_or_lt (cexp beta fexp (-x)) (cexp beta fexp (-y))) as [H2|H2].
+apply round_plus_neq_0_aux; try apply generic_format_opp...
+lra.
rewrite Rplus_comm.
-apply round_plus_eq_zero_aux ; try apply generic_format_opp...
+apply round_plus_neq_0_aux; try apply generic_format_opp...
now apply Zlt_le_weak.
-apply Rlt_le.
-now apply Ropp_lt_cancel.
-rewrite <- (Ropp_involutive (round _ _ _ _)).
-rewrite Hxy.
-apply Ropp_involutive.
+lra.
+Qed.
+
+Theorem round_plus_eq_0 :
+ forall x y,
+ format x -> format y ->
+ round beta fexp rnd (x + y) = 0%R ->
+ (x + y = 0)%R.
+Proof with auto with typeclass_instances.
+intros x y Fx Fy H.
+destruct (Req_dec (x + y) 0) as [H'|H'].
+exact H'.
+contradict H.
+now apply round_plus_neq_0.
Qed.
End Fprop_plus_zero.
@@ -258,14 +257,48 @@ apply generic_format_FLT_FIX...
rewrite Zplus_comm; assumption.
apply generic_format_FIX_FLT, FIX_format_generic in Fx.
apply generic_format_FIX_FLT, FIX_format_generic in Fy.
-destruct Fx as (nx,(H1x,H2x)).
-destruct Fy as (ny,(H1y,H2y)).
+destruct Fx as [nx H1x H2x].
+destruct Fy as [ny H1y H2y].
apply generic_format_FIX.
exists (Float beta (Fnum nx+Fnum ny)%Z emin).
-split;[idtac|reflexivity].
rewrite H1x,H1y; unfold F2R; simpl.
rewrite H2x, H2y.
-rewrite Z2R_plus; ring.
+rewrite plus_IZR; ring.
+easy.
+Qed.
+
+Variable choice : Z -> bool.
+
+Lemma FLT_plus_error_N_ex : forall x y,
+ generic_format beta (FLT_exp emin prec) x ->
+ generic_format beta (FLT_exp emin prec) y ->
+ exists eps,
+ (Rabs eps <= u_ro beta prec / (1 + u_ro beta prec))%R /\
+ round beta (FLT_exp emin prec) (Znearest choice) (x + y)
+ = ((x + y) * (1 + eps))%R.
+Proof.
+intros x y Fx Fy.
+assert (Pb := u_rod1pu_ro_pos beta prec).
+destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs (x + y))) as [M|M].
+{ destruct (relative_error_N_FLX'_ex beta prec prec_gt_0_ choice (x + y))
+ as (d, (Bd, Hd)).
+ now exists d; split; [exact Bd|]; rewrite <- Hd; apply round_FLT_FLX. }
+exists 0%R; rewrite Rabs_R0; split; [exact Pb|]; rewrite Rplus_0_r, Rmult_1_r.
+apply round_generic; [apply valid_rnd_N|].
+apply FLT_format_plus_small; [exact Fx|exact Fy|].
+apply Rlt_le, (Rlt_le_trans _ _ _ M), bpow_le; lia.
+Qed.
+
+Lemma FLT_plus_error_N_round_ex : forall x y,
+ generic_format beta (FLT_exp emin prec) x ->
+ generic_format beta (FLT_exp emin prec) y ->
+ exists eps,
+ (Rabs eps <= u_ro beta prec)%R /\
+ (x + y
+ = round beta (FLT_exp emin prec) (Znearest choice) (x + y) * (1 + eps))%R.
+Proof.
+intros x y Fx Fy.
+now apply relative_error_N_round_ex_derive, FLT_plus_error_N_ex.
Qed.
End Fprop_plus_FLT.
@@ -282,62 +315,58 @@ Variable rnd : R -> Z.
Context { valid_rnd : Valid_rnd rnd }.
Notation format := (generic_format beta fexp).
-Notation cexp := (canonic_exp beta fexp).
+Notation cexp := (cexp beta fexp).
Lemma ex_shift :
forall x e, format x -> (e <= cexp x)%Z ->
- exists m, (x = Z2R m * bpow e)%R.
+ exists m, (x = IZR m * bpow e)%R.
Proof with auto with typeclass_instances.
intros x e Fx He.
exists (Ztrunc (scaled_mantissa beta fexp x)*Zpower beta (cexp x -e))%Z.
rewrite Fx at 1; unfold F2R; simpl.
-rewrite Z2R_mult, Rmult_assoc.
+rewrite mult_IZR, Rmult_assoc.
f_equal.
-rewrite Z2R_Zpower.
+rewrite IZR_Zpower.
2: omega.
rewrite <- bpow_plus; f_equal; ring.
Qed.
-Lemma ln_beta_minus1 :
+Lemma mag_minus1 :
forall z, z <> 0%R ->
- (ln_beta beta z - 1)%Z = ln_beta beta (z / Z2R beta).
+ (mag beta z - 1)%Z = mag beta (z / IZR beta).
Proof.
intros z Hz.
unfold Zminus.
-rewrite <- ln_beta_mult_bpow with (1 := Hz).
+rewrite <- mag_mult_bpow by easy.
now rewrite bpow_opp, bpow_1.
Qed.
-Theorem round_plus_mult_ulp :
+Theorem round_plus_F2R :
forall x y, format x -> format y -> (x <> 0)%R ->
- exists m, (round beta fexp rnd (x+y) = Z2R m * ulp beta fexp (x/Z2R beta))%R.
+ exists m,
+ round beta fexp rnd (x+y) = F2R (Float beta m (cexp (x / IZR beta))).
Proof with auto with typeclass_instances.
intros x y Fx Fy Zx.
-case (Zle_or_lt (ln_beta beta (x/Z2R beta)) (ln_beta beta y)); intros H1.
-pose (e:=cexp (x / Z2R beta)).
+case (Zle_or_lt (mag beta (x/IZR beta)) (mag beta y)); intros H1.
+pose (e:=cexp (x / IZR beta)).
destruct (ex_shift x e) as (nx, Hnx); try exact Fx.
apply monotone_exp.
-rewrite <- (ln_beta_minus1 x Zx); omega.
+rewrite <- (mag_minus1 x Zx); omega.
destruct (ex_shift y e) as (ny, Hny); try assumption.
apply monotone_exp...
destruct (round_repr_same_exp beta fexp rnd (nx+ny) e) as (n,Hn).
exists n.
-apply trans_eq with (F2R (Float beta n e)).
+fold e.
rewrite <- Hn; f_equal.
-rewrite Hnx, Hny; unfold F2R; simpl; rewrite Z2R_plus; ring.
+rewrite Hnx, Hny; unfold F2R; simpl; rewrite plus_IZR; ring.
unfold F2R; simpl.
-rewrite ulp_neq_0; try easy.
-apply Rmult_integral_contrapositive_currified; try assumption.
-apply Rinv_neq_0_compat.
-apply Rgt_not_eq.
-apply radix_pos.
(* *)
-destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/Z2R beta))) as (n,Hn).
+destruct (ex_shift (round beta fexp rnd (x + y)) (cexp (x/IZR beta))) as (n,Hn).
apply generic_format_round...
-apply Zle_trans with (cexp (x+y)).
+apply Z.le_trans with (cexp (x+y)).
apply monotone_exp.
-rewrite <- ln_beta_minus1 by easy.
-rewrite <- (ln_beta_abs beta (x+y)).
+rewrite <- mag_minus1 by easy.
+rewrite <- (mag_abs beta (x+y)).
(* . *)
assert (U: (Rabs (x+y) = Rabs x + Rabs y)%R \/ (y <> 0 /\ Rabs (x+y) = Rabs x - Rabs y)%R).
assert (V: forall x y, (Rabs y <= Rabs x)%R ->
@@ -374,94 +403,89 @@ rewrite Rabs_left1.
ring.
lra.
apply V; left.
-apply ln_beta_lt_pos with beta.
+apply lt_mag with beta.
now apply Rabs_pos_lt.
-rewrite <- ln_beta_minus1 in H1; try assumption.
-rewrite 2!ln_beta_abs; omega.
+rewrite <- mag_minus1 in H1; try assumption.
+rewrite 2!mag_abs; omega.
(* . *)
destruct U as [U|U].
-rewrite U; apply Zle_trans with (ln_beta beta x).
+rewrite U; apply Z.le_trans with (mag beta x).
omega.
-rewrite <- ln_beta_abs.
-apply ln_beta_le.
+rewrite <- mag_abs.
+apply mag_le.
now apply Rabs_pos_lt.
apply Rplus_le_reg_l with (-Rabs x)%R; ring_simplify.
apply Rabs_pos.
destruct U as (U',U); rewrite U.
-rewrite <- ln_beta_abs.
-apply ln_beta_minus_lb.
+rewrite <- mag_abs.
+apply mag_minus_lb.
now apply Rabs_pos_lt.
now apply Rabs_pos_lt.
-rewrite 2!ln_beta_abs.
-assert (ln_beta beta y < ln_beta beta x - 1)%Z.
-now rewrite (ln_beta_minus1 x Zx).
+rewrite 2!mag_abs.
+assert (mag beta y < mag beta x - 1)%Z.
+now rewrite (mag_minus1 x Zx).
omega.
-apply canonic_exp_round_ge...
-intros K.
-apply round_plus_eq_zero in K...
+apply cexp_round_ge...
+apply round_plus_neq_0...
contradict H1; apply Zle_not_lt.
-rewrite <- (ln_beta_minus1 x Zx).
+rewrite <- (mag_minus1 x Zx).
replace y with (-x)%R.
-rewrite ln_beta_opp; omega.
+rewrite mag_opp; omega.
lra.
-exists n.
-rewrite ulp_neq_0.
-assumption.
-apply Rmult_integral_contrapositive_currified; try assumption.
-apply Rinv_neq_0_compat.
-apply Rgt_not_eq.
-apply radix_pos.
+now exists n.
Qed.
Context {exp_not_FTZ : Exp_not_FTZ fexp}.
Theorem round_plus_ge_ulp :
forall x y, format x -> format y ->
- round beta fexp rnd (x+y) = 0%R \/
- (ulp beta fexp (x/Z2R beta) <= Rabs (round beta fexp rnd (x+y)))%R.
+ round beta fexp rnd (x+y) <> 0%R ->
+ (ulp beta fexp (x/IZR beta) <= Rabs (round beta fexp rnd (x+y)))%R.
Proof with auto with typeclass_instances.
-intros x y Fx Fy.
+intros x y Fx Fy KK.
case (Req_dec x 0); intros Zx.
(* *)
rewrite Zx, Rplus_0_l.
rewrite round_generic...
unfold Rdiv; rewrite Rmult_0_l.
-rewrite Fy at 2.
+rewrite Fy.
unfold F2R; simpl; rewrite Rabs_mult.
rewrite (Rabs_pos_eq (bpow _)) by apply bpow_ge_0.
case (Z.eq_dec (Ztrunc (scaled_mantissa beta fexp y)) 0); intros Hm.
-left.
-rewrite Fy, Hm; unfold F2R; simpl; ring.
-right.
+contradict KK.
+rewrite Zx, Fy, Hm; unfold F2R; simpl.
+rewrite Rplus_0_l, Rmult_0_l.
+apply round_0...
apply Rle_trans with (1*bpow (cexp y))%R.
rewrite Rmult_1_l.
rewrite <- ulp_neq_0.
apply ulp_ge_ulp_0...
intros K; apply Hm.
rewrite K, scaled_mantissa_0.
-apply (Ztrunc_Z2R 0).
+apply Ztrunc_IZR.
apply Rmult_le_compat_r.
apply bpow_ge_0.
-rewrite <- Z2R_abs.
-apply (Z2R_le 1).
+rewrite <- abs_IZR.
+apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
(* *)
-destruct (round_plus_mult_ulp x y Fx Fy Zx) as (m,Hm).
+destruct (round_plus_F2R x y Fx Fy Zx) as (m,Hm).
case (Z.eq_dec m 0); intros Zm.
-left.
-rewrite Hm, Zm; simpl; ring.
-right.
-rewrite Hm, Rabs_mult.
-rewrite (Rabs_pos_eq (ulp _ _ _)) by apply ulp_ge_0.
-apply Rle_trans with (1*ulp beta fexp (x/Z2R beta))%R.
-right; ring.
+contradict KK.
+rewrite Hm, Zm.
+apply F2R_0.
+rewrite Hm, <- F2R_Zabs.
+rewrite ulp_neq_0.
+rewrite <- (Rmult_1_l (bpow _)).
apply Rmult_le_compat_r.
-apply ulp_ge_0.
-rewrite <- Z2R_abs.
-apply (Z2R_le 1).
+apply bpow_ge_0.
+apply IZR_le.
apply (Zlt_le_succ 0).
now apply Z.abs_pos.
+apply Rmult_integral_contrapositive_currified with (1 := Zx).
+apply Rinv_neq_0_compat.
+apply Rgt_not_eq, radix_pos.
Qed.
End Fprop_plus_mult_ulp.
@@ -476,27 +500,27 @@ Context { valid_rnd : Valid_rnd rnd }.
Variable emin prec : Z.
Context { prec_gt_0_ : Prec_gt_0 prec }.
-Theorem round_plus_ge_ulp_FLT : forall x y e,
+Theorem round_FLT_plus_ge :
+ forall x y e,
generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
- (bpow e <= Rabs x)%R ->
- round beta (FLT_exp emin prec) rnd (x+y) = 0%R \/
- (bpow (e - prec) <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R.
+ (bpow (e + prec) <= Rabs x)%R ->
+ round beta (FLT_exp emin prec) rnd (x + y) <> 0%R ->
+ (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x + y)))%R.
Proof with auto with typeclass_instances.
-intros x y e Fx Fy He.
+intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
contradict He.
apply Rlt_not_le; rewrite He, Rabs_R0.
apply bpow_gt_0.
-case round_plus_ge_ulp with beta (FLT_exp emin prec) rnd x y...
-intros H; right.
-apply Rle_trans with (2:=H).
+apply Rle_trans with (ulp beta (FLT_exp emin prec) (x/IZR beta)).
+2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
-unfold canonic_exp.
-rewrite <- ln_beta_minus1 by easy.
+unfold cexp.
+rewrite <- mag_minus1; try assumption.
unfold FLT_exp; apply bpow_le.
-apply Zle_trans with (2:=Z.le_max_l _ _).
-destruct (ln_beta beta x) as (n,Hn); simpl.
-assert (e < n)%Z; try omega.
+apply Z.le_trans with (2:=Z.le_max_l _ _).
+destruct (mag beta x) as (n,Hn); simpl.
+assert (e + prec < n)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
@@ -506,26 +530,45 @@ apply Rgt_not_eq.
apply radix_pos.
Qed.
-Theorem round_plus_ge_ulp_FLX : forall x y e,
+Lemma round_FLT_plus_ge' :
+ forall x y e,
+ generic_format beta (FLT_exp emin prec) x -> generic_format beta (FLT_exp emin prec) y ->
+ (x <> 0%R -> (bpow (e+prec) <= Rabs x)%R) ->
+ (x = 0%R -> y <> 0%R -> (bpow e <= Rabs y)%R) ->
+ round beta (FLT_exp emin prec) rnd (x+y) <> 0%R ->
+ (bpow e <= Rabs (round beta (FLT_exp emin prec) rnd (x+y)))%R.
+Proof with auto with typeclass_instances.
+intros x y e Fx Fy H1 H2 H3.
+case (Req_dec x 0); intros H4.
+case (Req_dec y 0); intros H5.
+contradict H3.
+rewrite H4, H5, Rplus_0_l; apply round_0...
+rewrite H4, Rplus_0_l.
+rewrite round_generic...
+apply round_FLT_plus_ge; try easy.
+now apply H1.
+Qed.
+
+Theorem round_FLX_plus_ge :
+ forall x y e,
generic_format beta (FLX_exp prec) x -> generic_format beta (FLX_exp prec) y ->
- (bpow e <= Rabs x)%R ->
- round beta (FLX_exp prec) rnd (x+y) = 0%R \/
- (bpow (e - prec) <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R.
+ (bpow (e+prec) <= Rabs x)%R ->
+ (round beta (FLX_exp prec) rnd (x+y) <> 0)%R ->
+ (bpow e <= Rabs (round beta (FLX_exp prec) rnd (x+y)))%R.
Proof with auto with typeclass_instances.
-intros x y e Fx Fy He.
+intros x y e Fx Fy He KK.
assert (Zx: x <> 0%R).
contradict He.
apply Rlt_not_le; rewrite He, Rabs_R0.
apply bpow_gt_0.
-case round_plus_ge_ulp with beta (FLX_exp prec) rnd x y...
-intros H; right.
-apply Rle_trans with (2:=H).
+apply Rle_trans with (ulp beta (FLX_exp prec) (x/IZR beta)).
+2: apply round_plus_ge_ulp...
rewrite ulp_neq_0.
-unfold canonic_exp.
-rewrite <- ln_beta_minus1 by easy.
+unfold cexp.
+rewrite <- mag_minus1 by easy.
unfold FLX_exp; apply bpow_le.
-destruct (ln_beta beta x) as (n,Hn); simpl.
-assert (e < n)%Z; try omega.
+destruct (mag beta x) as (n,Hn); simpl.
+assert (e + prec < n)%Z; try omega.
apply lt_bpow with beta.
apply Rle_lt_trans with (1:=He).
now apply Hn.
@@ -536,3 +579,28 @@ apply radix_pos.
Qed.
End Fprop_plus_ge_ulp.
+
+Section Fprop_plus_le_ops.
+
+Variable beta : radix.
+Variable fexp : Z -> Z.
+Context { valid_exp : Valid_exp fexp }.
+Variable choice : Z -> bool.
+
+Lemma plus_error_le_l :
+ forall x y,
+ generic_format beta fexp x -> generic_format beta fexp y ->
+ (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs x)%R.
+Proof.
+intros x y Fx Fy.
+apply (Rle_trans _ (Rabs (y - (x + y)))); [now apply round_N_pt|].
+rewrite Rabs_minus_sym; right; f_equal; ring.
+Qed.
+
+Lemma plus_error_le_r :
+ forall x y,
+ generic_format beta fexp x -> generic_format beta fexp y ->
+ (Rabs (round beta fexp (Znearest choice) (x + y) - (x + y)) <= Rabs y)%R.
+Proof. now intros x y Fx Fy; rewrite Rplus_comm; apply plus_error_le_l. Qed.
+
+End Fprop_plus_le_ops.
diff --git a/flocq/Prop/Fprop_relative.v b/flocq/Prop/Relative.v
index 276ccd3b..5f87bd84 100644
--- a/flocq/Prop/Fprop_relative.v
+++ b/flocq/Prop/Relative.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -18,7 +18,8 @@ COPYING file for more details.
*)
(** * Relative error of the roundings *)
-Require Import Fcore.
+Require Import Core.
+Require Import Psatz. (* for lra *)
Section Fprop_relative.
@@ -88,6 +89,32 @@ rewrite Rinv_l with (1 := Hx0).
now rewrite Rabs_R1, Rmult_1_r.
Qed.
+Lemma relative_error_le_conversion_inv :
+ forall x b,
+ (exists eps,
+ (Rabs eps <= b)%R /\ round beta fexp rnd x = (x * (1 + eps))%R) ->
+ (Rabs (round beta fexp rnd x - x) <= b * Rabs x)%R.
+Proof with auto with typeclass_instances.
+intros x b (eps, (Beps, Heps)).
+assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
+rewrite Heps; replace (_ - _)%R with (eps * x)%R; [|ring].
+now rewrite Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
+Qed.
+
+Lemma relative_error_le_conversion_round_inv :
+ forall x b,
+ (exists eps,
+ (Rabs eps <= b)%R /\ x = (round beta fexp rnd x * (1 + eps))%R) ->
+ (Rabs (round beta fexp rnd x - x) <= b * Rabs (round beta fexp rnd x))%R.
+Proof with auto with typeclass_instances.
+intros x b.
+set (rx := round _ _ _ _).
+intros (eps, (Beps, Heps)).
+assert (Pb : (0 <= b)%R); [now revert Beps; apply Rle_trans, Rabs_pos|].
+rewrite Heps; replace (_ - _)%R with (- (eps * rx))%R; [|ring].
+now rewrite Rabs_Ropp, Rabs_mult; apply Rmult_le_compat_r; [apply Rabs_pos|].
+Qed.
+
End relative_error_conversion.
Variable emin p : Z.
@@ -108,8 +135,8 @@ apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp...
rewrite ulp_neq_0; trivial.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex, He).
+unfold cexp.
+destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
@@ -150,7 +177,7 @@ apply relative_error.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
-apply F2R_lt_reg with beta emin.
+apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.
@@ -179,8 +206,8 @@ apply Rlt_not_le, bpow_gt_0.
apply Rlt_le_trans with (ulp beta fexp x)%R.
now apply error_lt_ulp.
rewrite ulp_neq_0; trivial.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex, He).
+unfold cexp.
+destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
@@ -218,7 +245,7 @@ exact Hp.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
-apply F2R_lt_reg with beta emin.
+apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.
@@ -237,15 +264,15 @@ rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex, He).
+unfold cexp.
+destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
apply Rle_trans with (bpow (-p + 1) * bpow (ex - 1))%R.
@@ -274,7 +301,7 @@ apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N.
Qed.
@@ -296,7 +323,7 @@ apply relative_error_N.
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
-apply F2R_lt_reg with beta emin.
+apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.
@@ -311,7 +338,7 @@ apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_F2R_emin.
Qed.
@@ -329,15 +356,15 @@ rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
assert (Hx': (x <> 0)%R).
intros H.
apply Rlt_not_le with (2 := Hx).
rewrite H, Rabs_R0.
apply bpow_gt_0.
rewrite ulp_neq_0; trivial.
-unfold canonic_exp.
-destruct (ln_beta beta x) as (ex, He).
+unfold cexp.
+destruct (mag beta x) as (ex, He).
simpl.
specialize (He Hx').
assert (He': (emin < ex)%Z).
@@ -381,17 +408,250 @@ apply relative_error_N_round with (1 := Hp).
unfold x.
rewrite <- F2R_Zabs.
apply bpow_le_F2R.
-apply F2R_lt_reg with beta emin.
+apply lt_F2R with beta emin.
rewrite F2R_0, F2R_Zabs.
now apply Rabs_pos_lt.
Qed.
End Fprop_relative_generic.
+Section Fprop_relative_FLX.
+
+Variable prec : Z.
+Variable Hp : Z.lt 0 prec.
+
+Lemma relative_error_FLX_aux :
+ forall k, (prec <= k - FLX_exp prec k)%Z.
+Proof.
+intros k.
+unfold FLX_exp.
+omega.
+Qed.
+
+Variable rnd : R -> Z.
+Context { valid_rnd : Valid_rnd rnd }.
+
+Theorem relative_error_FLX :
+ forall x,
+ (x <> 0)%R ->
+ (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
+Proof with auto with typeclass_instances.
+intros x Hx.
+destruct (mag beta x) as (ex, He).
+specialize (He Hx).
+apply relative_error with (ex - 1)%Z...
+intros k _.
+apply relative_error_FLX_aux.
+apply He.
+Qed.
+
+(** 1+#&epsilon;# property in any rounding in FLX *)
+Theorem relative_error_FLX_ex :
+ forall x,
+ exists eps,
+ (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
+Proof with auto with typeclass_instances.
+intros x.
+apply relative_error_lt_conversion...
+apply bpow_gt_0.
+now apply relative_error_FLX.
+Qed.
+
+Theorem relative_error_FLX_round :
+ forall x,
+ (x <> 0)%R ->
+ (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
+Proof with auto with typeclass_instances.
+intros x Hx.
+destruct (mag beta x) as (ex, He).
+specialize (He Hx).
+apply relative_error_round with (ex - 1)%Z...
+intros k _.
+apply relative_error_FLX_aux.
+apply He.
+Qed.
+
+Variable choice : Z -> bool.
+
+Theorem relative_error_N_FLX :
+ forall x,
+ (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
+Proof with auto with typeclass_instances.
+intros x.
+destruct (Req_dec x 0) as [Hx|Hx].
+(* . *)
+rewrite Hx, round_0...
+unfold Rminus.
+rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
+rewrite Rmult_0_r.
+apply Rle_refl.
+(* . *)
+destruct (mag beta x) as (ex, He).
+specialize (He Hx).
+apply relative_error_N with (ex - 1)%Z...
+intros k _.
+apply relative_error_FLX_aux.
+apply He.
+Qed.
+
+(** unit roundoff *)
+Definition u_ro := (/2 * bpow (-prec + 1))%R.
+
+Lemma u_ro_pos : (0 <= u_ro)%R.
+Proof. apply Rmult_le_pos; [lra|apply bpow_ge_0]. Qed.
+
+Lemma u_ro_lt_1 : (u_ro < 1)%R.
+Proof.
+unfold u_ro; apply (Rmult_lt_reg_l 2); [lra|].
+rewrite <-Rmult_assoc, Rinv_r, Rmult_1_l, Rmult_1_r; [|lra].
+apply (Rle_lt_trans _ (bpow 0));
+ [apply bpow_le; omega|simpl; lra].
+Qed.
+
+Lemma u_rod1pu_ro_pos : (0 <= u_ro / (1 + u_ro))%R.
+Proof.
+apply Rmult_le_pos; [|apply Rlt_le, Rinv_0_lt_compat];
+assert (H := u_ro_pos); lra.
+Qed.
+
+Lemma u_rod1pu_ro_le_u_ro : (u_ro / (1 + u_ro) <= u_ro)%R.
+Proof.
+assert (Pu_ro := u_ro_pos).
+apply (Rmult_le_reg_r (1 + u_ro)); [lra|].
+unfold Rdiv; rewrite Rmult_assoc, Rinv_l; [|lra].
+assert (0 <= u_ro * u_ro)%R; [apply Rmult_le_pos|]; lra.
+Qed.
+
+Theorem relative_error_N_FLX' :
+ forall x,
+ (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x)
+ <= u_ro / (1 + u_ro) * Rabs x)%R.
+Proof with auto with typeclass_instances.
+intro x.
+assert (Pu_ro : (0 <= u_ro)%R).
+{ apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ rewrite Zx, Rabs_R0, Rmult_0_r, round_0...
+ now unfold Rminus; rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0; right. }
+set (ufpx := bpow (mag beta x - 1)%Z).
+set (rx := round _ _ _ _).
+assert (Pufpx : (0 <= ufpx)%R); [now apply bpow_ge_0|].
+assert (H_2_1 : (Rabs (rx - x) <= u_ro * ufpx)%R).
+{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
+ [now apply FLX_exp_valid|right].
+ unfold ulp, cexp, FLX_exp, u_ro, ufpx; rewrite (Req_bool_false _ _ Nzx).
+ rewrite Rmult_assoc, <-bpow_plus; do 2 f_equal; ring. }
+assert (H_2_3 : (ufpx + Rabs (rx - x) <= Rabs x)%R).
+{ apply (Rplus_le_reg_r (- ufpx)); ring_simplify.
+ destruct (Rle_or_lt 0 x) as [Sx|Sx].
+ { apply (Rle_trans _ (Rabs (ufpx - x))).
+ { apply round_N_pt; [now apply FLX_exp_valid|].
+ apply generic_format_bpow; unfold FLX_exp; lia. }
+ rewrite Rabs_minus_sym, Rabs_pos_eq.
+ { now rewrite Rabs_pos_eq; [right; ring|]. }
+ apply (Rplus_le_reg_r ufpx); ring_simplify.
+ now rewrite <-(Rabs_pos_eq _ Sx); apply bpow_mag_le. }
+ apply (Rle_trans _ (Rabs (- ufpx - x))).
+ { apply round_N_pt; [now apply FLX_exp_valid|].
+ apply generic_format_opp, generic_format_bpow; unfold FLX_exp; lia. }
+ rewrite Rabs_pos_eq; [now rewrite Rabs_left; [right|]|].
+ apply (Rplus_le_reg_r x); ring_simplify.
+ rewrite <-(Ropp_involutive x); apply Ropp_le_contravar; unfold ufpx.
+ rewrite <-mag_opp, <-Rabs_pos_eq; [apply bpow_mag_le|]; lra. }
+assert (H : (Rabs ((rx - x) / x) <= u_ro / (1 + u_ro))%R).
+{ assert (H : (0 < ufpx + Rabs (rx - x))%R).
+ { apply Rplus_lt_le_0_compat; [apply bpow_gt_0|apply Rabs_pos]. }
+ apply (Rle_trans _ (Rabs (rx - x) / (ufpx + Rabs (rx - x)))).
+ { unfold Rdiv; rewrite Rabs_mult; apply Rmult_le_compat_l; [apply Rabs_pos|].
+ now rewrite (Rabs_Rinv _ Nzx); apply Rinv_le. }
+ apply (Rmult_le_reg_r ((ufpx + Rabs (rx - x)) * (1 + u_ro))).
+ { apply Rmult_lt_0_compat; lra. }
+ field_simplify; [try unfold Rdiv; rewrite ?Rinv_1, ?Rmult_1_r| |]; lra. }
+revert H; unfold Rdiv; rewrite Rabs_mult, (Rabs_Rinv _ Nzx); intro H.
+apply (Rmult_le_reg_r (/ Rabs x)); [now apply Rinv_0_lt_compat, Rabs_pos_lt|].
+now apply (Rle_trans _ _ _ H); right; field; split; [apply Rabs_no_R0|lra].
+Qed.
+
+(** 1+#&epsilon;# property in rounding to nearest in FLX *)
+Theorem relative_error_N_FLX_ex :
+ forall x,
+ exists eps,
+ (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
+Proof with auto with typeclass_instances.
+intros x.
+apply relative_error_le_conversion...
+apply Rlt_le.
+apply Rmult_lt_0_compat.
+apply Rinv_0_lt_compat.
+now apply IZR_lt.
+apply bpow_gt_0.
+now apply relative_error_N_FLX.
+Qed.
+
+Theorem relative_error_N_FLX'_ex :
+ forall x,
+ exists eps,
+ (Rabs eps <= u_ro / (1 + u_ro))%R /\
+ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
+Proof with auto with typeclass_instances.
+intros x.
+apply relative_error_le_conversion...
+{ apply u_rod1pu_ro_pos. }
+now apply relative_error_N_FLX'.
+Qed.
+
+Lemma relative_error_N_round_ex_derive :
+ forall x rx,
+ (exists eps, (Rabs eps <= u_ro / (1 + u_ro))%R /\ rx = (x * (1 + eps))%R) ->
+ exists eps, (Rabs eps <= u_ro)%R /\ x = (rx * (1 + eps))%R.
+Proof.
+intros x rx (d, (Bd, Hd)).
+assert (Pu_ro := u_ro_pos).
+assert (H := Rabs_le_inv _ _ Bd).
+assert (H' := u_rod1pu_ro_le_u_ro); assert (H'' := u_ro_lt_1).
+destruct (Req_dec rx 0) as [Zfx|Nzfx].
+{ exists 0%R; split; [now rewrite Rabs_R0|].
+ rewrite Rplus_0_r, Rmult_1_r, Zfx.
+ now rewrite Zfx in Hd; destruct (Rmult_integral _ _ (sym_eq Hd)); [|lra]. }
+destruct (Req_dec x 0) as [Zx|Nzx].
+{ now exfalso; revert Hd; rewrite Zx, Rmult_0_l. }
+set (d' := ((x - rx) / rx)%R).
+assert (Hd' : (Rabs d' <= u_ro)%R).
+{ unfold d'; rewrite Hd.
+ replace (_ / _)%R with (- d / (1 + d))%R; [|now field; split; lra].
+ unfold Rdiv; rewrite Rabs_mult, Rabs_Ropp.
+ rewrite (Rabs_pos_eq (/ _)); [|apply Rlt_le, Rinv_0_lt_compat; lra].
+ apply (Rmult_le_reg_r (1 + d)); [lra|].
+ rewrite Rmult_assoc, Rinv_l, Rmult_1_r; [|lra].
+ apply (Rle_trans _ _ _ Bd).
+ unfold Rdiv; apply Rmult_le_compat_l; [now apply u_ro_pos|].
+ apply (Rle_trans _ (1 - u_ro / (1 + u_ro))); [right; field|]; lra. }
+now exists d'; split; [|unfold d'; field].
+Qed.
+
+Theorem relative_error_N_FLX_round_ex :
+ forall x,
+ exists eps,
+ (Rabs eps <= u_ro)%R /\
+ x = (round beta (FLX_exp prec) (Znearest choice) x * (1 + eps))%R.
+Proof.
+intro x; apply relative_error_N_round_ex_derive, relative_error_N_FLX'_ex.
+Qed.
+
+Theorem relative_error_N_FLX_round :
+ forall x,
+ (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs(round beta (FLX_exp prec) (Znearest choice) x))%R.
+Proof.
+intro x.
+apply relative_error_le_conversion_round_inv, relative_error_N_FLX_round_ex.
+Qed.
+
+End Fprop_relative_FLX.
+
Section Fprop_relative_FLT.
Variable emin prec : Z.
-Variable Hp : Zlt 0 prec.
+Variable Hp : Z.lt 0 prec.
Lemma relative_error_FLT_aux :
forall k, (emin + prec - 1 < k)%Z -> (prec <= k - FLT_exp emin prec k)%Z.
@@ -486,7 +746,7 @@ apply relative_error_le_conversion...
apply Rlt_le.
apply Rmult_lt_0_compat.
apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
+now apply IZR_lt.
apply bpow_gt_0.
now apply relative_error_N_FLT.
Qed.
@@ -607,23 +867,84 @@ apply Rlt_le, pos_half_prf.
rewrite ulp_neq_0.
2: now apply Rgt_not_eq.
apply bpow_le.
-unfold FLT_exp, canonic_exp.
+unfold FLT_exp, cexp.
rewrite Zmax_right.
omega.
-destruct (ln_beta beta x) as (e,He); simpl.
+destruct (mag beta x) as (e,He); simpl.
assert (e-1 < emin+prec)%Z.
apply (lt_bpow beta).
apply Rle_lt_trans with (2:=Hx).
-rewrite <- (Rabs_right x).
-apply He; auto with real.
-apply Rle_ge; now left.
+rewrite <- (Rabs_pos_eq x) by now apply Rlt_le.
+now apply He, Rgt_not_eq.
omega.
-split;ring.
+split ; ring.
+Qed.
+
+Theorem relative_error_N_FLT'_ex :
+ forall x,
+ exists eps eta : R,
+ (Rabs eps <= u_ro prec / (1 + u_ro prec))%R /\
+ (Rabs eta <= /2 * bpow emin)%R /\
+ (eps * eta = 0)%R /\
+ round beta (FLT_exp emin prec) (Znearest choice) x
+ = (x * (1 + eps) + eta)%R.
+Proof.
+intro x.
+set (rx := round _ _ _ x).
+assert (Pb := u_rod1pu_ro_pos prec).
+destruct (Rle_or_lt (bpow (emin + prec - 1)) (Rabs x)) as [MX|Mx].
+{ destruct (relative_error_N_FLX'_ex prec Hp choice x) as (d, (Bd, Hd)).
+ exists d, 0%R; split; [exact Bd|]; split.
+ { rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]. }
+ rewrite Rplus_0_r, Rmult_0_r; split; [reflexivity|].
+ now rewrite <- Hd; apply round_FLT_FLX. }
+assert (H : (Rabs (rx - x) <= /2 * bpow emin)%R).
+{ refine (Rle_trans _ _ _ (error_le_half_ulp _ _ _ _) _);
+ [now apply FLT_exp_valid|].
+ rewrite ulp_FLT_small; [now right|now simpl|].
+ apply (Rlt_le_trans _ _ _ Mx), bpow_le; lia. }
+exists 0%R, (rx - x)%R; split; [now rewrite Rabs_R0|]; split; [exact H|].
+now rewrite Rmult_0_l, Rplus_0_r, Rmult_1_r; split; [|ring].
+Qed.
+
+Theorem relative_error_N_FLT'_ex_separate :
+ forall x,
+ exists x' : R,
+ round beta (FLT_exp emin prec) (Znearest choice) x'
+ = round beta (FLT_exp emin prec) (Znearest choice) x /\
+ (exists eta, Rabs eta <= /2 * bpow emin /\ x' = x + eta)%R /\
+ (exists eps, Rabs eps <= u_ro prec / (1 + u_ro prec) /\
+ round beta (FLT_exp emin prec) (Znearest choice) x'
+ = x' * (1 + eps))%R.
+Proof.
+intro x.
+set (rx := round _ _ _ x).
+destruct (relative_error_N_FLT'_ex x) as (d, (e, (Bd, (Be, (Hde0, Hde))))).
+destruct (Rlt_or_le (Rabs (d * x)) (Rabs e)) as [HdxLte|HeLedx].
+{ exists rx; split; [|split].
+ { apply round_generic; [now apply valid_rnd_N|].
+ now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
+ { exists e; split; [exact Be|].
+ unfold rx; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
+ { now rewrite Zd, Rplus_0_r, Rmult_1_r. }
+ exfalso; revert HdxLte; rewrite Ze, Rabs_R0; apply Rle_not_lt, Rabs_pos. }
+ exists 0%R; split; [now rewrite Rabs_R0; apply u_rod1pu_ro_pos|].
+ rewrite Rplus_0_r, Rmult_1_r; apply round_generic; [now apply valid_rnd_N|].
+ now apply generic_format_round; [apply FLT_exp_valid|apply valid_rnd_N]. }
+exists x; split; [now simpl|split].
+{ exists 0%R; split;
+ [rewrite Rabs_R0; apply Rmult_le_pos; [lra|apply bpow_ge_0]|ring]. }
+exists d; rewrite Hde; destruct (Rmult_integral _ _ Hde0) as [Zd|Ze].
+{ split; [exact Bd|].
+ assert (Ze : e = 0%R); [|now rewrite Ze, Rplus_0_r].
+ apply Rabs_eq_R0, Rle_antisym; [|now apply Rabs_pos].
+ now revert HeLedx; rewrite Zd, Rmult_0_l, Rabs_R0. }
+now rewrite Ze, Rplus_0_r.
Qed.
End Fprop_relative_FLT.
-Lemma error_N_FLT :
+Theorem error_N_FLT :
forall (emin prec : Z), (0 < prec)%Z ->
forall (choice : Z -> bool),
forall (x : R),
@@ -638,9 +959,9 @@ intros emin prec Pprec choice x.
destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
{ assert (Pmx : (0 < - x)%R).
{ now rewrite <- Ropp_0; apply Ropp_lt_contravar. }
- destruct (error_N_FLT_aux emin prec Pprec
- (fun t : Z => negb (choice (- (t + 1))%Z))
- (- x)%R Pmx)
+ destruct (@error_N_FLT_aux emin prec Pprec
+ (fun t : Z => negb (choice (- (t + 1))%Z))
+ (- x)%R Pmx)
as (d,(e,(Hd,(He,(Hde,Hr))))).
exists d; exists (- e)%R; split; [exact Hd|split; [|split]].
{ now rewrite Rabs_Ropp. }
@@ -659,124 +980,4 @@ destruct (Rtotal_order x 0) as [Nx|[Zx|Px]].
now apply error_N_FLT_aux.
Qed.
-Section Fprop_relative_FLX.
-
-Variable prec : Z.
-Variable Hp : Zlt 0 prec.
-
-Lemma relative_error_FLX_aux :
- forall k, (prec <= k - FLX_exp prec k)%Z.
-Proof.
-intros k.
-unfold FLX_exp.
-omega.
-Qed.
-
-Variable rnd : R -> Z.
-Context { valid_rnd : Valid_rnd rnd }.
-
-Theorem relative_error_FLX :
- forall x,
- (x <> 0)%R ->
- (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs x)%R.
-Proof with auto with typeclass_instances.
-intros x Hx.
-destruct (ln_beta beta x) as (ex, He).
-specialize (He Hx).
-apply relative_error with (ex - 1)%Z...
-intros k _.
-apply relative_error_FLX_aux.
-apply He.
-Qed.
-
-(** 1+#&epsilon;# property in any rounding in FLX *)
-Theorem relative_error_FLX_ex :
- forall x,
- exists eps,
- (Rabs eps < bpow (-prec + 1))%R /\ round beta (FLX_exp prec) rnd x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros x.
-apply relative_error_lt_conversion...
-apply bpow_gt_0.
-now apply relative_error_FLX.
-Qed.
-
-Theorem relative_error_FLX_round :
- forall x,
- (x <> 0)%R ->
- (Rabs (round beta (FLX_exp prec) rnd x - x) < bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) rnd x))%R.
-Proof with auto with typeclass_instances.
-intros x Hx.
-destruct (ln_beta beta x) as (ex, He).
-specialize (He Hx).
-apply relative_error_round with (ex - 1)%Z...
-intros k _.
-apply relative_error_FLX_aux.
-apply He.
-Qed.
-
-Variable choice : Z -> bool.
-
-Theorem relative_error_N_FLX :
- forall x,
- (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs x)%R.
-Proof with auto with typeclass_instances.
-intros x.
-destruct (Req_dec x 0) as [Hx|Hx].
-(* . *)
-rewrite Hx, round_0...
-unfold Rminus.
-rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
-rewrite Rmult_0_r.
-apply Rle_refl.
-(* . *)
-destruct (ln_beta beta x) as (ex, He).
-specialize (He Hx).
-apply relative_error_N with (ex - 1)%Z...
-intros k _.
-apply relative_error_FLX_aux.
-apply He.
-Qed.
-
-(** 1+#&epsilon;# property in rounding to nearest in FLX *)
-Theorem relative_error_N_FLX_ex :
- forall x,
- exists eps,
- (Rabs eps <= /2 * bpow (-prec + 1))%R /\ round beta (FLX_exp prec) (Znearest choice) x = (x * (1 + eps))%R.
-Proof with auto with typeclass_instances.
-intros x.
-apply relative_error_le_conversion...
-apply Rlt_le.
-apply Rmult_lt_0_compat.
-apply Rinv_0_lt_compat.
-now apply (Z2R_lt 0 2).
-apply bpow_gt_0.
-now apply relative_error_N_FLX.
-Qed.
-
-Theorem relative_error_N_FLX_round :
- forall x,
- (Rabs (round beta (FLX_exp prec) (Znearest choice) x - x) <= /2 * bpow (-prec + 1) * Rabs (round beta (FLX_exp prec) (Znearest choice) x))%R.
-Proof with auto with typeclass_instances.
-intros x.
-destruct (Req_dec x 0) as [Hx|Hx].
-(* . *)
-rewrite Hx, round_0...
-unfold Rminus.
-rewrite Rplus_0_l, Rabs_Ropp, Rabs_R0.
-rewrite Rmult_0_r.
-apply Rle_refl.
-(* . *)
-destruct (ln_beta beta x) as (ex, He).
-specialize (He Hx).
-apply relative_error_N_round with (ex - 1)%Z.
-now apply FLX_exp_valid.
-intros k _.
-apply relative_error_FLX_aux.
-exact Hp.
-apply He.
-Qed.
-
-End Fprop_relative_FLX.
-
-End Fprop_relative. \ No newline at end of file
+End Fprop_relative.
diff --git a/flocq/Appli/Fappli_rnd_odd.v b/flocq/Prop/Round_odd.v
index 273c1000..df2952cc 100644
--- a/flocq/Appli/Fappli_rnd_odd.v
+++ b/flocq/Prop/Round_odd.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2013-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2013-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -21,12 +21,11 @@ COPYING file for more details.
between rnd_NE and double rounding with rnd_odd and then rnd_NE *)
Require Import Reals Psatz.
-Require Import Fcore.
-Require Import Fcalc_ops.
+Require Import Core Operations.
-Definition Zrnd_odd x := match Req_EM_T x (Z2R (Zfloor x)) with
+Definition Zrnd_odd x := match Req_EM_T x (IZR (Zfloor x)) with
| left _ => Zfloor x
- | right _ => match (Zeven (Zfloor x)) with
+ | right _ => match (Z.even (Zfloor x)) with
| true => Zceil x
| false => Zfloor x
end
@@ -41,64 +40,120 @@ split.
intros x y Hxy.
assert (Zfloor x <= Zrnd_odd y)%Z.
(* .. *)
-apply Zle_trans with (Zfloor y).
+apply Z.le_trans with (Zfloor y).
now apply Zfloor_le.
-unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))).
-now apply Zle_refl.
-case (Zeven (Zfloor y)).
-apply le_Z2R.
+unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))).
+now apply Z.le_refl.
+case (Z.even (Zfloor y)).
+apply le_IZR.
apply Rle_trans with y.
apply Zfloor_lb.
apply Zceil_ub.
-now apply Zle_refl.
+now apply Z.le_refl.
unfold Zrnd_odd at 1.
(* . *)
-destruct (Req_EM_T x (Z2R (Zfloor x))) as [Hx|Hx].
+destruct (Req_EM_T x (IZR (Zfloor x))) as [Hx|Hx].
(* .. *)
apply H.
(* .. *)
-case_eq (Zeven (Zfloor x)); intros Hx2.
+case_eq (Z.even (Zfloor x)); intros Hx2.
2: apply H.
-unfold Zrnd_odd; destruct (Req_EM_T y (Z2R (Zfloor y))) as [Hy|Hy].
+unfold Zrnd_odd; destruct (Req_EM_T y (IZR (Zfloor y))) as [Hy|Hy].
apply Zceil_glb.
now rewrite <- Hy.
-case_eq (Zeven (Zfloor y)); intros Hy2.
+case_eq (Z.even (Zfloor y)); intros Hy2.
now apply Zceil_le.
apply Zceil_glb.
assert (H0:(Zfloor x <= Zfloor y)%Z) by now apply Zfloor_le.
case (Zle_lt_or_eq _ _ H0); intros H1.
apply Rle_trans with (1:=Zceil_ub _).
rewrite Zceil_floor_neq.
-apply Z2R_le; omega.
+apply IZR_le; omega.
now apply sym_not_eq.
contradict Hy2.
rewrite <- H1, Hx2; discriminate.
(* . *)
intros n; unfold Zrnd_odd.
-rewrite Zfloor_Z2R, Zceil_Z2R.
-destruct (Req_EM_T (Z2R n) (Z2R n)); trivial.
-case (Zeven n); trivial.
+rewrite Zfloor_IZR, Zceil_IZR.
+destruct (Req_EM_T (IZR n) (IZR n)); trivial.
+case (Z.even n); trivial.
Qed.
-Lemma Zrnd_odd_Zodd: forall x, x <> (Z2R (Zfloor x)) ->
- (Zeven (Zrnd_odd x)) = false.
+Lemma Zrnd_odd_Zodd: forall x, x <> (IZR (Zfloor x)) ->
+ (Z.even (Zrnd_odd x)) = false.
Proof.
intros x Hx; unfold Zrnd_odd.
-destruct (Req_EM_T x (Z2R (Zfloor x))) as [H|H].
+destruct (Req_EM_T x (IZR (Zfloor x))) as [H|H].
now contradict H.
-case_eq (Zeven (Zfloor x)).
+case_eq (Z.even (Zfloor x)).
(* difficult case *)
intros H'.
rewrite Zceil_floor_neq.
-rewrite Zeven_plus, H'.
+rewrite Z.even_add, H'.
reflexivity.
now apply sym_not_eq.
trivial.
Qed.
+Lemma Zfloor_plus: forall (n:Z) y,
+ (Zfloor (IZR n+y) = n + Zfloor y)%Z.
+Proof.
+intros n y; unfold Zfloor.
+unfold Zminus; rewrite Zplus_assoc; f_equal.
+apply sym_eq, tech_up.
+rewrite plus_IZR.
+apply Rplus_lt_compat_l.
+apply archimed.
+rewrite plus_IZR, Rplus_assoc.
+apply Rplus_le_compat_l.
+apply Rplus_le_reg_r with (-y)%R.
+ring_simplify (y+1+-y)%R.
+apply archimed.
+Qed.
+
+Lemma Zceil_plus: forall (n:Z) y,
+ (Zceil (IZR n+y) = n + Zceil y)%Z.
+Proof.
+intros n y; unfold Zceil.
+rewrite Ropp_plus_distr, <- Ropp_Ropp_IZR.
+rewrite Zfloor_plus.
+ring.
+Qed.
+
+
+Lemma Zeven_abs: forall z, Z.even (Z.abs z) = Z.even z.
+Proof.
+intros z; case (Zle_or_lt z 0); intros H1.
+rewrite Z.abs_neq; try assumption.
+apply Z.even_opp.
+rewrite Z.abs_eq; auto with zarith.
+Qed.
+
+
+
+
+Lemma Zrnd_odd_plus: forall x y, (x = IZR (Zfloor x)) ->
+ Z.even (Zfloor x) = true ->
+ (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
+Proof.
+intros x y Hx H.
+unfold Zrnd_odd; rewrite Hx, Zfloor_plus.
+case (Req_EM_T y (IZR (Zfloor y))); intros Hy.
+rewrite Hy; repeat rewrite <- plus_IZR.
+repeat rewrite Zfloor_IZR.
+case (Req_EM_T _ _); intros K; easy.
+case (Req_EM_T _ _); intros K.
+contradict Hy.
+apply Rplus_eq_reg_l with (IZR (Zfloor x)).
+now rewrite K, plus_IZR.
+rewrite Z.even_add, H; simpl.
+case (Z.even (Zfloor y)).
+now rewrite Zceil_plus, plus_IZR.
+now rewrite plus_IZR.
+Qed.
Section Fcore_rnd_odd.
@@ -113,20 +168,19 @@ Context { valid_exp : Valid_exp fexp }.
Context { exists_NE_ : Exists_NE beta fexp }.
Notation format := (generic_format beta fexp).
-Notation canonic := (canonic beta fexp).
-Notation cexp := (canonic_exp beta fexp).
+Notation canonical := (canonical beta fexp).
+Notation cexp := (cexp beta fexp).
Definition Rnd_odd_pt (x f : R) :=
format f /\ ((f = x)%R \/
((Rnd_DN_pt format x f \/ Rnd_UP_pt format x f) /\
- exists g : float beta, f = F2R g /\ canonic g /\ Zeven (Fnum g) = false)).
+ exists g : float beta, f = F2R g /\ canonical g /\ Z.even (Fnum g) = false)).
Definition Rnd_odd (rnd : R -> R) :=
forall x : R, Rnd_odd_pt x (rnd x).
-
-Theorem Rnd_odd_pt_sym : forall x f : R,
+Theorem Rnd_odd_pt_opp_inv : forall x f : R,
Rnd_odd_pt (-x) (-f) -> Rnd_odd_pt x f.
Proof with auto with typeclass_instances.
intros x f (H1,H2).
@@ -144,12 +198,12 @@ destruct H2.
right.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
-apply Rnd_DN_UP_pt_sym...
+apply Rnd_UP_pt_opp...
apply generic_format_opp.
left.
replace f with (-(-f))%R by ring.
replace x with (-(-x))%R by ring.
-apply Rnd_UP_DN_pt_sym...
+apply Rnd_DN_pt_opp...
apply generic_format_opp.
exists (Float beta (-Fnum g) (Fexp g)).
split.
@@ -157,15 +211,15 @@ rewrite F2R_Zopp.
replace f with (-(-f))%R by ring.
rewrite Hg1; reflexivity.
split.
-now apply canonic_opp.
+now apply canonical_opp.
simpl.
-now rewrite Zeven_opp.
+now rewrite Z.even_opp.
Qed.
Theorem round_odd_opp :
forall x,
- (round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x))%R.
+ round beta fexp Zrnd_odd (-x) = (- round beta fexp Zrnd_odd x)%R.
Proof.
intros x; unfold round.
rewrite <- F2R_Zopp.
@@ -174,36 +228,36 @@ apply f_equal2; apply f_equal.
rewrite scaled_mantissa_opp.
generalize (scaled_mantissa beta fexp x); intros r.
unfold Zrnd_odd.
-case (Req_EM_T (- r) (Z2R (Zfloor (- r)))).
-case (Req_EM_T r (Z2R (Zfloor r))).
+case (Req_EM_T (- r) (IZR (Zfloor (- r)))).
+case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
-apply eq_Z2R.
-now rewrite Z2R_opp, <- Y1, <-Y2.
+apply eq_IZR.
+now rewrite opp_IZR, <- Y1, <-Y2.
intros Y1 Y2.
-absurd (r=Z2R (Zfloor r)); trivial.
+absurd (r=IZR (Zfloor r)); trivial.
pattern r at 2; replace r with (-(-r))%R by ring.
-rewrite Y2, <- Z2R_opp.
-rewrite Zfloor_Z2R.
-rewrite Z2R_opp, <- Y2.
+rewrite Y2, <- opp_IZR.
+rewrite Zfloor_IZR.
+rewrite opp_IZR, <- Y2.
ring.
-case (Req_EM_T r (Z2R (Zfloor r))).
+case (Req_EM_T r (IZR (Zfloor r))).
intros Y1 Y2.
-absurd (-r=Z2R (Zfloor (-r)))%R; trivial.
+absurd (-r=IZR (Zfloor (-r)))%R; trivial.
pattern r at 2; rewrite Y1.
-rewrite <- Z2R_opp, Zfloor_Z2R.
-now rewrite Z2R_opp, <- Y1.
+rewrite <- opp_IZR, Zfloor_IZR.
+now rewrite opp_IZR, <- Y1.
intros Y1 Y2.
unfold Zceil; rewrite Ropp_involutive.
-replace (Zeven (Zfloor (- r))) with (negb (Zeven (Zfloor r))).
-case (Zeven (Zfloor r)); simpl; ring.
-apply trans_eq with (Zeven (Zceil r)).
+replace (Z.even (Zfloor (- r))) with (negb (Z.even (Zfloor r))).
+case (Z.even (Zfloor r)); simpl; ring.
+apply trans_eq with (Z.even (Zceil r)).
rewrite Zceil_floor_neq.
-rewrite Zeven_plus.
-destruct (Zeven (Zfloor r)); reflexivity.
+rewrite Z.even_add.
+destruct (Z.even (Zfloor r)); reflexivity.
now apply sym_not_eq.
-rewrite <- (Zeven_opp (Zfloor (- r))).
+rewrite <- (Z.even_opp (Zfloor (- r))).
reflexivity.
-apply canonic_exp_opp.
+apply cexp_opp.
Qed.
@@ -221,7 +275,7 @@ rewrite round_0...
split.
apply generic_format_0.
now left.
-intros Hx; apply Rnd_odd_pt_sym.
+intros Hx; apply Rnd_odd_pt_opp_inv.
rewrite <- round_odd_opp.
apply H.
auto with real.
@@ -248,7 +302,7 @@ right; apply round_UP_pt...
(* *)
unfold o, Zrnd_odd, round.
case (Req_EM_T (scaled_mantissa beta fexp x)
- (Z2R (Zfloor (scaled_mantissa beta fexp x)))).
+ (IZR (Zfloor (scaled_mantissa beta fexp x)))).
intros T.
absurd (o=x); trivial.
apply round_generic...
@@ -260,20 +314,20 @@ apply Rmult_le_pos.
now left.
apply bpow_ge_0.
intros L.
-case_eq (Zeven (Zfloor (scaled_mantissa beta fexp x))).
+case_eq (Z.even (Zfloor (scaled_mantissa beta fexp x))).
(* . *)
generalize (generic_format_round beta fexp Zceil x).
unfold generic_format.
set (f:=round beta fexp Zceil x).
-set (ef := canonic_exp beta fexp f).
+set (ef := cexp f).
set (mf := Ztrunc (scaled_mantissa beta fexp f)).
exists (Float beta mf ef).
-unfold Fcore_generic_fmt.canonic.
+unfold canonical.
rewrite <- H0.
repeat split; try assumption.
-apply trans_eq with (negb (Zeven (Zfloor (scaled_mantissa beta fexp x)))).
+apply trans_eq with (negb (Z.even (Zfloor (scaled_mantissa beta fexp x)))).
2: rewrite H1; reflexivity.
-apply trans_eq with (negb (Zeven (Fnum
+apply trans_eq with (negb (Z.even (Fnum
(Float beta (Zfloor (scaled_mantissa beta fexp x)) (cexp x))))).
2: reflexivity.
case (Rle_lt_or_eq_dec 0 (round beta fexp Zfloor x)).
@@ -294,10 +348,10 @@ assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
-unfold Fcore_generic_fmt.canonic.
+unfold canonical.
simpl.
-apply sym_eq, canonic_exp_DN...
-unfold Fcore_generic_fmt.canonic.
+apply sym_eq, cexp_DN...
+unfold canonical.
rewrite <- H0; reflexivity.
reflexivity.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
@@ -305,7 +359,7 @@ reflexivity.
apply round_generic...
intros Y.
replace (Fnum {| Fnum := Zfloor (scaled_mantissa beta fexp x); Fexp := cexp x |})
- with (Fnum (Float beta 0 (fexp (ln_beta beta 0)))).
+ with (Fnum (Float beta 0 (fexp (mag beta 0)))).
generalize (DN_UP_parity_generic beta fexp)...
unfold DN_UP_parity_prop.
intros T; apply T with x; clear T.
@@ -319,15 +373,15 @@ assumption.
apply Rmult_le_pos.
now left.
apply bpow_ge_0.
-apply canonic_0.
-unfold Fcore_generic_fmt.canonic.
+apply canonical_0.
+unfold canonical.
rewrite <- H0; reflexivity.
rewrite <- Y; unfold F2R; simpl; ring.
apply trans_eq with (round beta fexp Ztrunc (round beta fexp Zceil x)).
reflexivity.
apply round_generic...
simpl.
-apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)).
+apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Y; simpl in Y; rewrite <- Y.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
@@ -338,27 +392,25 @@ rewrite <- round_0 with beta fexp Zfloor...
apply round_le...
now left.
intros Hrx.
-set (ef := canonic_exp beta fexp x).
+set (ef := cexp x).
set (mf := Zfloor (scaled_mantissa beta fexp x)).
exists (Float beta mf ef).
-unfold Fcore_generic_fmt.canonic.
+unfold canonical.
repeat split; try assumption.
simpl.
apply trans_eq with (cexp (round beta fexp Zfloor x )).
-apply sym_eq, canonic_exp_DN...
+apply sym_eq, cexp_DN...
reflexivity.
intros Hrx; contradict Y.
replace (Zfloor (scaled_mantissa beta fexp x)) with 0%Z.
simpl; discriminate.
-apply eq_Z2R, Rmult_eq_reg_r with (bpow (cexp x)).
+apply eq_IZR, Rmult_eq_reg_r with (bpow (cexp x)).
unfold round, F2R in Hrx; simpl in Hrx; rewrite <- Hrx.
simpl; ring.
apply Rgt_not_eq, bpow_gt_0.
Qed.
-
-
-Theorem Rnd_odd_pt_unicity :
+Theorem Rnd_odd_pt_unique :
forall x f1 f2 : R,
Rnd_odd_pt x f1 -> Rnd_odd_pt x f2 ->
f1 = f2.
@@ -381,61 +433,56 @@ contradict L; now rewrite <- H1.
destruct H2 as [H2|(H2,H2')].
contradict L; now rewrite <- H2.
destruct H1 as [H1|H1]; destruct H2 as [H2|H2].
-apply Rnd_DN_pt_unicity with format x; assumption.
+apply Rnd_DN_pt_unique with format x; assumption.
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- L3.
-apply trans_eq with (negb (Zeven (Fnum ff))).
+apply trans_eq with (negb (Z.even (Fnum ff))).
rewrite K3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
-rewrite <- K1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy...
+rewrite <- K1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
-rewrite <- L1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy...
+rewrite <- L1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
(* *)
destruct H1' as (ff,(K1,(K2,K3))).
destruct H2' as (gg,(L1,(L2,L3))).
absurd (true = false); try discriminate.
rewrite <- K3.
-apply trans_eq with (negb (Zeven (Fnum gg))).
+apply trans_eq with (negb (Z.even (Fnum gg))).
rewrite L3; easy.
apply sym_eq.
generalize (DN_UP_parity_generic beta fexp).
unfold DN_UP_parity_prop; intros T; apply (T x); clear T; try assumption...
-rewrite <- L1; apply Rnd_DN_pt_unicity with (generic_format beta fexp) x; try easy...
+rewrite <- L1; apply Rnd_DN_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_DN_pt...
-rewrite <- K1; apply Rnd_UP_pt_unicity with (generic_format beta fexp) x; try easy...
+rewrite <- K1; apply Rnd_UP_pt_unique with (generic_format beta fexp) x; try easy...
now apply round_UP_pt...
-apply Rnd_UP_pt_unicity with format x; assumption.
+apply Rnd_UP_pt_unique with format x; assumption.
Qed.
-
-
Theorem Rnd_odd_pt_monotone :
round_pred_monotone (Rnd_odd_pt).
Proof with auto with typeclass_instances.
intros x y f g H1 H2 Hxy.
apply Rle_trans with (round beta fexp Zrnd_odd x).
-right; apply Rnd_odd_pt_unicity with x; try assumption.
+right; apply Rnd_odd_pt_unique with x; try assumption.
apply round_odd_pt.
apply Rle_trans with (round beta fexp Zrnd_odd y).
apply round_le...
-right; apply Rnd_odd_pt_unicity with y; try assumption.
+right; apply Rnd_odd_pt_unique with y; try assumption.
apply round_odd_pt.
Qed.
-
-
-
End Fcore_rnd_odd.
Section Odd_prop_aux.
Variable beta : radix.
-Hypothesis Even_beta: Zeven (radix_val beta)=true.
+Hypothesis Even_beta: Z.even (radix_val beta)=true.
Notation bpow e := (bpow beta e).
@@ -454,26 +501,26 @@ Lemma generic_format_fexpe_fexp: forall x,
generic_format beta fexp x -> generic_format beta fexpe x.
Proof.
intros x Hx.
-apply generic_inclusion_ln_beta with fexp; trivial; intros Hx2.
-generalize (fexpe_fexp (ln_beta beta x)).
+apply generic_inclusion_mag with fexp; trivial; intros Hx2.
+generalize (fexpe_fexp (mag beta x)).
omega.
Qed.
Lemma exists_even_fexp_lt: forall (c:Z->Z), forall (x:R),
- (exists f:float beta, F2R f = x /\ (c (ln_beta beta x) < Fexp f)%Z) ->
- exists f:float beta, F2R f =x /\ canonic beta c f /\ Zeven (Fnum f) = true.
+ (exists f:float beta, F2R f = x /\ (c (mag beta x) < Fexp f)%Z) ->
+ exists f:float beta, F2R f =x /\ canonical beta c f /\ Z.even (Fnum f) = true.
Proof with auto with typeclass_instances.
intros c x (g,(Hg1,Hg2)).
exists (Float beta
- (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x)))
- (c (ln_beta beta x))).
+ (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
+ (c (mag beta x))).
assert (F2R (Float beta
- (Fnum g*Z.pow (radix_val beta) (Fexp g - c (ln_beta beta x)))
- (c (ln_beta beta x))) = x).
+ (Fnum g*Z.pow (radix_val beta) (Fexp g - c (mag beta x)))
+ (c (mag beta x))) = x).
unfold F2R; simpl.
-rewrite Z2R_mult, Z2R_Zpower.
+rewrite mult_IZR, IZR_Zpower.
rewrite Rmult_assoc, <- bpow_plus.
rewrite <- Hg1; unfold F2R.
apply f_equal, f_equal.
@@ -481,11 +528,11 @@ ring.
omega.
split; trivial.
split.
-unfold canonic, canonic_exp.
+unfold canonical, cexp.
now rewrite H.
simpl.
-rewrite Zeven_mult.
-rewrite Zeven_Zpower.
+rewrite Z.even_mul.
+rewrite Z.even_pow.
rewrite Even_beta.
apply Bool.orb_true_intro.
now right.
@@ -499,9 +546,9 @@ Variable x:R.
Variable d u: float beta.
Hypothesis Hd: Rnd_DN_pt (generic_format beta fexp) x (F2R d).
-Hypothesis Cd: canonic beta fexp d.
+Hypothesis Cd: canonical beta fexp d.
Hypothesis Hu: Rnd_UP_pt (generic_format beta fexp) x (F2R u).
-Hypothesis Cu: canonic beta fexp u.
+Hypothesis Cu: canonical beta fexp u.
Hypothesis xPos: (0 < x)%R.
@@ -511,14 +558,14 @@ Let m:= ((F2R d+F2R u)/2)%R.
Lemma d_eq: F2R d= round beta fexp Zfloor x.
Proof with auto with typeclass_instances.
-apply Rnd_DN_pt_unicity with (generic_format beta fexp) x...
+apply Rnd_DN_pt_unique with (generic_format beta fexp) x...
apply round_DN_pt...
Qed.
Lemma u_eq: F2R u= round beta fexp Zceil x.
Proof with auto with typeclass_instances.
-apply Rnd_UP_pt_unicity with (generic_format beta fexp) x...
+apply Rnd_UP_pt_unique with (generic_format beta fexp) x...
apply round_UP_pt...
Qed.
@@ -532,47 +579,47 @@ Qed.
-Lemma ln_beta_d: (0< F2R d)%R ->
- (ln_beta beta (F2R d) = ln_beta beta x :>Z).
+Lemma mag_d: (0< F2R d)%R ->
+ (mag beta (F2R d) = mag beta x :>Z).
Proof with auto with typeclass_instances.
intros Y.
-rewrite d_eq; apply ln_beta_DN...
+rewrite d_eq; apply mag_DN...
now rewrite <- d_eq.
Qed.
-Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (ln_beta beta x).
+Lemma Fexp_d: (0 < F2R d)%R -> Fexp d =fexp (mag beta x).
Proof with auto with typeclass_instances.
intros Y.
-now rewrite Cd, <- ln_beta_d.
+now rewrite Cd, <- mag_d.
Qed.
Lemma format_bpow_x: (0 < F2R d)%R
- -> generic_format beta fexp (bpow (ln_beta beta x)).
+ -> generic_format beta fexp (bpow (mag beta x)).
Proof with auto with typeclass_instances.
intros Y.
apply generic_format_bpow.
apply valid_exp.
rewrite <- Fexp_d; trivial.
-apply Zlt_le_trans with (ln_beta beta (F2R d))%Z.
-rewrite Cd; apply ln_beta_generic_gt...
+apply Z.lt_le_trans with (mag beta (F2R d))%Z.
+rewrite Cd; apply mag_generic_gt...
now apply Rgt_not_eq.
apply Hd.
-apply ln_beta_le; trivial.
+apply mag_le; trivial.
apply Hd.
Qed.
Lemma format_bpow_d: (0 < F2R d)%R ->
- generic_format beta fexp (bpow (ln_beta beta (F2R d))).
+ generic_format beta fexp (bpow (mag beta (F2R d))).
Proof with auto with typeclass_instances.
intros Y; apply generic_format_bpow.
apply valid_exp.
-apply ln_beta_generic_gt...
+apply mag_generic_gt...
now apply Rgt_not_eq.
-now apply generic_format_canonic.
+now apply generic_format_canonical.
Qed.
@@ -596,12 +643,12 @@ unfold m.
lra.
Qed.
-Lemma ln_beta_m: (0 < F2R d)%R -> (ln_beta beta m =ln_beta beta (F2R d) :>Z).
+Lemma mag_m: (0 < F2R d)%R -> (mag beta m =mag beta (F2R d) :>Z).
Proof with auto with typeclass_instances.
-intros dPos; apply ln_beta_unique_pos.
+intros dPos; apply mag_unique_pos.
split.
apply Rle_trans with (F2R d).
-destruct (ln_beta beta (F2R d)) as (e,He).
+destruct (mag beta (F2R d)) as (e,He).
simpl.
rewrite Rabs_right in He.
apply He.
@@ -614,13 +661,13 @@ rewrite u_eq.
apply round_le_generic...
apply generic_format_bpow.
apply valid_exp.
-apply ln_beta_generic_gt...
+apply mag_generic_gt...
now apply Rgt_not_eq.
-now apply generic_format_canonic.
-case (Rle_or_lt x (bpow (ln_beta beta (F2R d)))); trivial; intros Z.
-absurd ((bpow (ln_beta beta (F2R d)) <= (F2R d)))%R.
+now apply generic_format_canonical.
+case (Rle_or_lt x (bpow (mag beta (F2R d)))); trivial; intros Z.
+absurd ((bpow (mag beta (F2R d)) <= (F2R d)))%R.
apply Rlt_not_le.
-destruct (ln_beta beta (F2R d)) as (e,He).
+destruct (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
@@ -630,12 +677,12 @@ apply Rle_trans with (round beta fexp Zfloor x).
apply round_ge_generic...
apply generic_format_bpow.
apply valid_exp.
-apply ln_beta_generic_gt...
+apply mag_generic_gt...
now apply Rgt_not_eq.
-now apply generic_format_canonic.
+now apply generic_format_canonical.
now left.
replace m with (F2R d).
-destruct (ln_beta beta (F2R d)) as (e,He).
+destruct (mag beta (F2R d)) as (e,He).
simpl in *; rewrite Rabs_right in He.
apply He.
now apply Rgt_not_eq.
@@ -645,17 +692,17 @@ lra.
Qed.
-Lemma ln_beta_m_0: (0 = F2R d)%R
- -> (ln_beta beta m =ln_beta beta (F2R u)-1:>Z)%Z.
+Lemma mag_m_0: (0 = F2R d)%R
+ -> (mag beta m =mag beta (F2R u)-1:>Z)%Z.
Proof with auto with typeclass_instances.
intros Y.
-apply ln_beta_unique_pos.
+apply mag_unique_pos.
unfold m; rewrite <- Y, Rplus_0_l.
rewrite u_eq.
-destruct (ln_beta beta x) as (e,He).
+destruct (mag beta x) as (e,He).
rewrite Rabs_pos_eq in He by now apply Rlt_le.
rewrite round_UP_small_pos with (ex:=e).
-rewrite ln_beta_bpow.
+rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
split.
unfold Zminus; rewrite bpow_plus.
@@ -664,7 +711,7 @@ apply bpow_ge_0.
simpl; unfold Z.pow_pos; simpl.
rewrite Zmult_1_r; apply Rinv_le.
exact Rlt_0_2.
-apply (Z2R_le 2).
+apply IZR_le.
specialize (radix_gt_1 beta).
omega.
apply Rlt_le_trans with (bpow (fexp e)*1)%R.
@@ -691,29 +738,29 @@ simpl; now rewrite Fexp_d.
Qed.
-
-
-Lemma m_eq: (0 < F2R d)%R -> exists f:float beta,
- F2R f = m /\ (Fexp f = fexp (ln_beta beta x) -1)%Z.
+Lemma m_eq :
+ (0 < F2R d)%R ->
+ exists f:float beta,
+ F2R f = m /\ (Fexp f = fexp (mag beta x) - 1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
destruct u'_eq as (u', (Hu'1,Hu'2)); trivial.
-exists (Fmult beta (Float beta b (-1)) (Fplus beta d u'))%R.
+exists (Fmult (Float beta b (-1)) (Fplus d u'))%R.
split.
rewrite F2R_mult, F2R_plus, Hu'1.
unfold m; rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
-rewrite Zmult_1_r, Hb, Z2R_mult.
+rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
-rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb.
+rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
-apply trans_eq with (-1+Fexp (Fplus beta d u'))%Z.
+apply trans_eq with (-1+Fexp (Fplus d u'))%Z.
unfold Fmult.
-destruct (Fplus beta d u'); reflexivity.
+destruct (Fplus d u'); reflexivity.
rewrite Zplus_comm; unfold Zminus; apply f_equal2.
2: reflexivity.
rewrite Fexp_Fplus.
@@ -723,21 +770,21 @@ rewrite Hu'2; omega.
Qed.
Lemma m_eq_0: (0 = F2R d)%R -> exists f:float beta,
- F2R f = m /\ (Fexp f = fexp (ln_beta beta (F2R u)) -1)%Z.
+ F2R f = m /\ (Fexp f = fexp (mag beta (F2R u)) -1)%Z.
Proof with auto with typeclass_instances.
intros Y.
specialize (Zeven_ex (radix_val beta)); rewrite Even_beta.
intros (b, Hb); rewrite Zplus_0_r in Hb.
-exists (Fmult beta (Float beta b (-1)) u)%R.
+exists (Fmult (Float beta b (-1)) u)%R.
split.
rewrite F2R_mult; unfold m; rewrite <- Y, Rplus_0_l.
rewrite Rmult_comm.
unfold Rdiv; apply f_equal.
unfold F2R; simpl; unfold Z.pow_pos; simpl.
-rewrite Zmult_1_r, Hb, Z2R_mult.
+rewrite Zmult_1_r, Hb, mult_IZR.
simpl; field.
apply Rgt_not_eq, Rmult_lt_reg_l with (1 := Rlt_0_2).
-rewrite Rmult_0_r, <- (Z2R_mult 2), <-Hb.
+rewrite Rmult_0_r, <- (mult_IZR 2), <-Hb.
apply radix_pos.
apply trans_eq with (-1+Fexp u)%Z.
unfold Fmult.
@@ -746,12 +793,12 @@ rewrite Zplus_comm, Cu; unfold Zminus; now apply f_equal2.
Qed.
Lemma fexp_m_eq_0: (0 = F2R d)%R ->
- (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z.
+ (fexp (mag beta (F2R u)-1) < fexp (mag beta (F2R u))+1)%Z.
Proof with auto with typeclass_instances.
intros Y.
-assert ((fexp (ln_beta beta (F2R u) - 1) <= fexp (ln_beta beta (F2R u))))%Z.
+assert ((fexp (mag beta (F2R u) - 1) <= fexp (mag beta (F2R u))))%Z.
2: omega.
-destruct (ln_beta beta x) as (e,He).
+destruct (mag beta x) as (e,He).
rewrite Rabs_right in He.
2: now left.
assert (e <= fexp e)%Z.
@@ -760,7 +807,7 @@ now apply He, Rgt_not_eq.
now rewrite <- d_eq, Y.
rewrite u_eq, round_UP_small_pos with (ex:=e); trivial.
2: now apply He, Rgt_not_eq.
-rewrite ln_beta_bpow.
+rewrite mag_bpow.
ring_simplify (fexp e + 1 - 1)%Z.
replace (fexp (fexp e)) with (fexp e).
case exists_NE_; intros V.
@@ -770,33 +817,34 @@ apply sym_eq, valid_exp; omega.
Qed.
Lemma Fm: generic_format beta fexpe m.
+Proof.
case (d_ge_0); intros Y.
(* *)
destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
now apply sym_eq.
-intros H; unfold canonic_exp; rewrite Hg2.
-rewrite ln_beta_m; trivial.
+intros H; unfold cexp; rewrite Hg2.
+rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
-unfold canonic_exp.
-generalize (fexpe_fexp (ln_beta beta (F2R d))).
+unfold cexp.
+generalize (fexpe_fexp (mag beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply generic_format_F2R' with g.
assumption.
-intros H; unfold canonic_exp; rewrite Hg2.
-rewrite ln_beta_m_0; try assumption.
-apply Zle_trans with (1:=fexpe_fexp _).
-assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega].
-now apply fexp_m_eq_0.
+intros H; unfold cexp; rewrite Hg2.
+rewrite mag_m_0; try assumption.
+apply Z.le_trans with (1:=fexpe_fexp _).
+generalize (fexp_m_eq_0 Y).
+omega.
Qed.
Lemma Zm:
- exists g : float beta, F2R g = m /\ canonic beta fexpe g /\ Zeven (Fnum g) = true.
+ exists g : float beta, F2R g = m /\ canonical beta fexpe g /\ Z.even (Fnum g) = true.
Proof with auto with typeclass_instances.
case (d_ge_0); intros Y.
(* *)
@@ -804,26 +852,27 @@ destruct m_eq as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
-rewrite ln_beta_m; trivial.
+rewrite mag_m; trivial.
rewrite <- Fexp_d; trivial.
rewrite Cd.
-unfold canonic_exp.
-generalize (fexpe_fexp (ln_beta beta (F2R d))).
+unfold cexp.
+generalize (fexpe_fexp (mag beta (F2R d))).
omega.
(* *)
destruct m_eq_0 as (g,(Hg1,Hg2)); trivial.
apply exists_even_fexp_lt.
exists g; split; trivial.
rewrite Hg2.
-rewrite ln_beta_m_0; trivial.
-apply Zle_lt_trans with (1:=fexpe_fexp _).
-assert (fexp (ln_beta beta (F2R u)-1) < fexp (ln_beta beta (F2R u))+1)%Z;[idtac|omega].
-now apply fexp_m_eq_0.
+rewrite mag_m_0; trivial.
+apply Z.le_lt_trans with (1:=fexpe_fexp _).
+generalize (fexp_m_eq_0 Y).
+omega.
Qed.
-Lemma DN_odd_d_aux: forall z, (F2R d<= z< F2R u)%R ->
- Rnd_DN_pt (generic_format beta fexp) z (F2R d).
+Lemma DN_odd_d_aux :
+ forall z, (F2R d <= z < F2R u)%R ->
+ Rnd_DN_pt (generic_format beta fexp) z (F2R d).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R d) with (round beta fexp Zfloor z).
@@ -834,22 +883,21 @@ intros Y; apply Rle_antisym; trivial.
apply round_DN_pt...
apply Hd.
apply Hz1.
-intros Y; absurd (z < z)%R.
-auto with real.
+intros Y ; elim (Rlt_irrefl z).
apply Rlt_le_trans with (1:=proj2 Hz1), Rle_trans with (1:=Y).
apply round_DN_pt...
Qed.
-Lemma UP_odd_d_aux: forall z, (F2R d< z <= F2R u)%R ->
- Rnd_UP_pt (generic_format beta fexp) z (F2R u).
+Lemma UP_odd_d_aux :
+ forall z, (F2R d < z <= F2R u)%R ->
+ Rnd_UP_pt (generic_format beta fexp) z (F2R u).
Proof with auto with typeclass_instances.
intros z Hz1.
replace (F2R u) with (round beta fexp Zceil z).
apply round_UP_pt...
case (Rnd_DN_UP_pt_split _ _ _ _ Hd Hu (round beta fexp Zceil z)).
apply generic_format_round...
-intros Y; absurd (z < z)%R.
-auto with real.
+intros Y ; elim (Rlt_irrefl z).
apply Rle_lt_trans with (2:=proj1 Hz1), Rle_trans with (2:=Y).
apply round_UP_pt...
intros Y; apply Rle_antisym; trivial.
@@ -859,7 +907,7 @@ apply Hz1.
Qed.
-Theorem round_odd_prop_pos:
+Lemma round_N_odd_pos :
round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
@@ -889,7 +937,7 @@ absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
-apply canonic_unicity with fexpe...
+apply canonical_unique with fexpe...
now rewrite Hk'1, <- Y2.
assert (generic_format beta fexp o -> (forall P:Prop, P)).
intros Y.
@@ -902,14 +950,14 @@ destruct H as (_,(k,(Hk1,(Hk2,Hk3)))).
destruct (exists_even_fexp_lt fexpe o) as (k',(Hk'1,(Hk'2,Hk'3))).
eexists; split.
apply sym_eq, Y.
-simpl; unfold canonic_exp.
-apply Zle_lt_trans with (1:=fexpe_fexp _).
+simpl; unfold cexp.
+apply Z.le_lt_trans with (1:=fexpe_fexp _).
omega.
absurd (true=false).
discriminate.
rewrite <- Hk3, <- Hk'3.
apply f_equal, f_equal.
-apply canonic_unicity with fexpe...
+apply canonical_unique with fexpe...
now rewrite Hk'1, <- Hk1.
case K1; clear K1; intros K1.
2: apply H; rewrite <- K1; apply Hd.
@@ -957,7 +1005,7 @@ End Odd_prop_aux.
Section Odd_prop.
Variable beta : radix.
-Hypothesis Even_beta: Zeven (radix_val beta)=true.
+Hypothesis Even_beta: Z.even (radix_val beta)=true.
Variable fexp : Z -> Z.
Variable fexpe : Z -> Z.
@@ -970,25 +1018,8 @@ Context { exists_NE_e : Exists_NE beta fexpe }. (* for defining rounding to odd
Hypothesis fexpe_fexp: forall e, (fexpe e <= fexp e -2)%Z.
-
-Theorem canonizer: forall f, generic_format beta fexp f
- -> exists g : float beta, f = F2R g /\ canonic beta fexp g.
-Proof with auto with typeclass_instances.
-intros f Hf.
-exists (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)).
-assert (L:(f = F2R (Float beta (Ztrunc (scaled_mantissa beta fexp f)) (canonic_exp beta fexp f)))).
-apply trans_eq with (round beta fexp Ztrunc f).
-apply sym_eq, round_generic...
-reflexivity.
-split; trivial.
-unfold canonic; rewrite <- L.
-reflexivity.
-Qed.
-
-
-
-
-Theorem round_odd_prop: forall x,
+Theorem round_N_odd :
+ forall x,
round beta fexp (Znearest choice) (round beta fexpe Zrnd_odd x) =
round beta fexp (Znearest choice) x.
Proof with auto with typeclass_instances.
@@ -998,25 +1029,192 @@ rewrite <- (Ropp_involutive x).
rewrite round_odd_opp.
rewrite 2!round_N_opp.
apply f_equal.
-destruct (canonizer (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
+destruct (canonical_generic_format beta fexp (round beta fexp Zfloor (-x))) as (d,(Hd1,Hd2)).
apply generic_format_round...
-destruct (canonizer (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
+destruct (canonical_generic_format beta fexp (round beta fexp Zceil (-x))) as (u,(Hu1,Hu2)).
apply generic_format_round...
-apply round_odd_prop_pos with d u...
+apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
auto with real.
(* . *)
rewrite H; repeat rewrite round_0...
(* . *)
-destruct (canonizer (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
+destruct (canonical_generic_format beta fexp (round beta fexp Zfloor x)) as (d,(Hd1,Hd2)).
apply generic_format_round...
-destruct (canonizer (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
+destruct (canonical_generic_format beta fexp (round beta fexp Zceil x)) as (u,(Hu1,Hu2)).
apply generic_format_round...
-apply round_odd_prop_pos with d u...
+apply round_N_odd_pos with d u...
rewrite <- Hd1; apply round_DN_pt...
rewrite <- Hu1; apply round_UP_pt...
Qed.
-
End Odd_prop.
+
+
+Section Odd_propbis.
+
+Variable beta : radix.
+Hypothesis Even_beta: Z.even (radix_val beta)=true.
+
+Variable emin prec:Z.
+Variable choice:Z->bool.
+
+Hypothesis prec_gt_1: (1 < prec)%Z.
+
+
+Notation format := (generic_format beta (FLT_exp emin prec)).
+Notation round_flt :=(round beta (FLT_exp emin prec) (Znearest choice)).
+Notation cexp_flt := (cexp beta (FLT_exp emin prec)).
+Notation fexpe k := (FLT_exp (emin-k) (prec+k)).
+
+
+
+Lemma Zrnd_odd_plus': forall x y,
+ (exists n:Z, exists e:Z, (x = IZR n*bpow beta e)%R /\ (1 <= e)%Z) ->
+ (IZR (Zrnd_odd (x+y)) = x+IZR (Zrnd_odd y))%R.
+Proof.
+intros x y (n,(e,(H1,H2))).
+apply Zrnd_odd_plus.
+rewrite H1.
+rewrite <- IZR_Zpower.
+2: auto with zarith.
+now rewrite <- mult_IZR, Zfloor_IZR.
+rewrite H1, <- IZR_Zpower.
+2: auto with zarith.
+rewrite <- mult_IZR, Zfloor_IZR.
+rewrite Z.even_mul.
+rewrite Z.even_pow.
+2: auto with zarith.
+rewrite Even_beta.
+apply Bool.orb_true_iff; now right.
+Qed.
+
+
+
+Theorem mag_round_odd: forall (x:R),
+ (emin < mag beta x)%Z ->
+ (mag_val beta _ (mag beta (round beta (FLT_exp emin prec) Zrnd_odd x))
+ = mag_val beta x (mag beta x))%Z.
+Proof with auto with typeclass_instances.
+intros x.
+assert (T:Prec_gt_0 prec).
+unfold Prec_gt_0; auto with zarith.
+case (Req_dec x 0); intros Zx.
+intros _; rewrite Zx, round_0...
+destruct (mag beta x) as (e,He); simpl; intros H.
+apply mag_unique; split.
+apply abs_round_ge_generic...
+apply FLT_format_bpow...
+auto with zarith.
+now apply He.
+assert (V:
+ (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta e)%R).
+apply abs_round_le_generic...
+apply FLT_format_bpow...
+auto with zarith.
+left; now apply He.
+case V; try easy; intros K.
+assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x (round beta (FLT_exp emin prec) Zrnd_odd x)).
+apply round_odd_pt...
+destruct H0 as (_,HH); destruct HH as [H0|(H0,(g,(Hg1,(Hg2,Hg3))))].
+absurd (Rabs x < bpow beta e)%R.
+apply Rle_not_lt; right.
+now rewrite <- H0,K.
+now apply He.
+pose (gg:=Float beta (Zpower beta (e-FLT_exp emin prec (e+1))) (FLT_exp emin prec (e+1))).
+assert (Y1: F2R gg = bpow beta e).
+unfold F2R; simpl.
+rewrite IZR_Zpower.
+rewrite <- bpow_plus.
+f_equal; ring.
+assert (FLT_exp emin prec (e+1) <= e)%Z; [idtac|auto with zarith].
+unfold FLT_exp.
+apply Z.max_case_strong; auto with zarith.
+assert (Y2: canonical beta (FLT_exp emin prec) gg).
+unfold canonical; rewrite Y1; unfold gg; simpl.
+unfold cexp; now rewrite mag_bpow.
+assert (Y3: Fnum gg = Z.abs (Fnum g)).
+apply trans_eq with (Fnum (Fabs g)).
+2: destruct g; unfold Fabs; now simpl.
+f_equal.
+apply canonical_unique with (FLT_exp emin prec); try assumption.
+destruct g; unfold Fabs; apply canonical_abs; easy.
+now rewrite Y1, F2R_abs, <- Hg1,K.
+assert (Y4: Z.even (Fnum gg) = true).
+unfold gg; simpl.
+rewrite Z.even_pow; try assumption.
+assert (FLT_exp emin prec (e+1) < e)%Z; [idtac|auto with zarith].
+unfold FLT_exp.
+apply Z.max_case_strong; auto with zarith.
+absurd (true = false).
+discriminate.
+rewrite <- Hg3.
+rewrite <- Zeven_abs.
+now rewrite <- Y3.
+Qed.
+
+Theorem fexp_round_odd: forall (x:R),
+ (cexp_flt (round beta (FLT_exp emin prec) Zrnd_odd x)
+ = cexp_flt x)%Z.
+Proof with auto with typeclass_instances.
+intros x.
+assert (G0:Valid_exp (FLT_exp emin prec)).
+apply FLT_exp_valid; unfold Prec_gt_0; auto with zarith.
+case (Req_dec x 0); intros Zx.
+rewrite Zx, round_0...
+case (Zle_or_lt (mag beta x) emin).
+unfold cexp; destruct (mag beta x) as (e,He); simpl.
+intros H; unfold FLT_exp at 4.
+rewrite Z.max_r.
+2: auto with zarith.
+apply Z.max_r.
+assert (G: Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) = bpow beta emin).
+assert (G1: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <= bpow beta emin)%R).
+apply abs_round_le_generic...
+apply generic_format_bpow'...
+unfold FLT_exp; rewrite Z.max_r; auto with zarith.
+left; apply Rlt_le_trans with (bpow beta e).
+now apply He.
+now apply bpow_le.
+assert (G2: (0 <= Rabs (round beta (FLT_exp emin prec) Zrnd_odd x))%R).
+apply Rabs_pos.
+assert (G3: (Rabs (round beta (FLT_exp emin prec) Zrnd_odd x) <> 0)%R).
+assert (H0:Rnd_odd_pt beta (FLT_exp emin prec) x
+ (round beta (FLT_exp emin prec) Zrnd_odd x)).
+apply round_odd_pt...
+destruct H0 as (_,H0); destruct H0 as [H0|(_,(g,(Hg1,(Hg2,Hg3))))].
+apply Rgt_not_eq; rewrite H0.
+apply Rlt_le_trans with (bpow beta (e-1)).
+apply bpow_gt_0.
+now apply He.
+rewrite Hg1; intros K.
+contradict Hg3.
+replace (Fnum g) with 0%Z.
+easy.
+case (Z.eq_dec (Fnum g) Z0); intros W; try easy.
+contradict K.
+apply Rabs_no_R0.
+now apply F2R_neq_0.
+apply Rle_antisym; try assumption.
+apply Rle_trans with (succ beta (FLT_exp emin prec) 0).
+right; rewrite succ_0.
+rewrite ulp_FLT_small; try easy.
+unfold Prec_gt_0; auto with zarith.
+rewrite Rabs_R0; apply bpow_gt_0.
+apply succ_le_lt...
+apply generic_format_0.
+apply generic_format_abs; apply generic_format_round...
+case G2; [easy|intros; now contradict G3].
+rewrite <- mag_abs.
+rewrite G, mag_bpow; auto with zarith.
+intros H; unfold cexp.
+now rewrite mag_round_odd.
+Qed.
+
+
+
+
+End Odd_propbis.
+
+
diff --git a/flocq/Prop/Fprop_Sterbenz.v b/flocq/Prop/Sterbenz.v
index 4e74f889..746b7026 100644
--- a/flocq/Prop/Fprop_Sterbenz.v
+++ b/flocq/Prop/Sterbenz.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2010-2013 Sylvie Boldo
+Copyright (C) 2010-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2010-2013 Guillaume Melquiond
+Copyright (C) 2010-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -19,10 +19,7 @@ COPYING file for more details.
(** * Sterbenz conditions for exact subtraction *)
-Require Import Fcore_Raux.
-Require Import Fcore_defs.
-Require Import Fcore_generic_fmt.
-Require Import Fcalc_ops.
+Require Import Raux Defs Generic_fmt Operations.
Section Fprop_Sterbenz.
@@ -37,7 +34,7 @@ Notation format := (generic_format beta fexp).
Theorem generic_format_plus :
forall x y,
format x -> format y ->
- (Rabs (x + y) < bpow (Zmin (ln_beta beta x) (ln_beta beta y)))%R ->
+ (Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R ->
format (x + y)%R.
Proof.
intros x y Fx Fy Hxy.
@@ -48,44 +45,51 @@ destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
+destruct Hxy as [Hxy|Hxy].
revert Hxy.
-destruct (ln_beta beta x) as (ex, Ex). simpl.
+destruct (mag beta x) as (ex, Ex). simpl.
specialize (Ex Zx).
-destruct (ln_beta beta y) as (ey, Ey). simpl.
+destruct (mag beta y) as (ey, Ey). simpl.
specialize (Ey Zy).
intros Hxy.
set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)).
assert (Hx: x = F2R fx).
rewrite Fx at 1.
-unfold canonic_exp.
-now rewrite ln_beta_unique with (1 := Ex).
+unfold cexp.
+now rewrite mag_unique with (1 := Ex).
set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)).
assert (Hy: y = F2R fy).
rewrite Fy at 1.
-unfold canonic_exp.
-now rewrite ln_beta_unique with (1 := Ey).
+unfold cexp.
+now rewrite mag_unique with (1 := Ey).
rewrite Hx, Hy.
rewrite <- F2R_plus.
apply generic_format_F2R.
intros _.
-case_eq (Fplus beta fx fy).
+case_eq (Fplus fx fy).
intros mxy exy Pxy.
rewrite <- Pxy, F2R_plus, <- Hx, <- Hy.
-unfold canonic_exp.
-replace exy with (fexp (Zmin ex ey)).
+unfold cexp.
+replace exy with (fexp (Z.min ex ey)).
apply monotone_exp.
-now apply ln_beta_le_bpow.
-replace exy with (Fexp (Fplus beta fx fy)) by exact (f_equal Fexp Pxy).
+now apply mag_le_bpow.
+replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy).
rewrite Fexp_Fplus.
simpl. clear -monotone_exp.
apply sym_eq.
destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2.
-apply Zmin_l.
+apply Z.min_l.
now apply monotone_exp.
-apply Zmin_r.
+apply Z.min_r.
apply monotone_exp.
apply Zlt_le_weak.
-now apply Zgt_lt.
+now apply Z.gt_lt.
+apply generic_format_abs_inv.
+rewrite Hxy.
+apply generic_format_bpow.
+apply valid_exp.
+case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2);
+ rewrite H2; now apply mag_generic_gt.
Qed.
Theorem generic_format_plus_weak :
@@ -100,17 +104,17 @@ now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
apply generic_format_plus ; try assumption.
-apply Rle_lt_trans with (1 := Hxy).
+apply Rle_trans with (1 := Hxy).
unfold Rmin.
destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy'].
-rewrite Zmin_l.
-destruct (ln_beta beta x) as (ex, Hx).
-now apply Hx.
-now apply ln_beta_le_abs.
-rewrite Zmin_r.
-destruct (ln_beta beta y) as (ex, Hy).
-now apply Hy.
-apply ln_beta_le_abs.
+rewrite Z.min_l.
+destruct (mag beta x) as (ex, Hx).
+apply Rlt_le; now apply Hx.
+now apply mag_le_abs.
+rewrite Z.min_r.
+destruct (mag beta y) as (ex, Hy).
+apply Rlt_le; now apply Hy.
+apply mag_le_abs.
exact Zy.
apply Rlt_le.
now apply Rnot_le_lt.
diff --git a/flocq/Flocq_version.v b/flocq/Version.v
index 72d4fe20..d0e36a57 100644
--- a/flocq/Flocq_version.v
+++ b/flocq/Version.v
@@ -2,9 +2,9 @@
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/
-Copyright (C) 2011-2013 Sylvie Boldo
+Copyright (C) 2011-2018 Sylvie Boldo
#<br />#
-Copyright (C) 2011-2013 Guillaume Melquiond
+Copyright (C) 2011-2018 Guillaume Melquiond
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@@ -29,4 +29,4 @@ Definition Flocq_version := Eval vm_compute in
parse t major (minor * 10 + N_of_ascii h - N_of_ascii "0"%char)%N
| Empty_string => (major * 100 + minor)%N
end in
- parse "2.6.1"%string N0 N0.
+ parse "3.1.0"%string N0 N0.
diff --git a/lib/BoolEqual.v b/lib/BoolEqual.v
index c9e7bad5..e8c1d831 100644
--- a/lib/BoolEqual.v
+++ b/lib/BoolEqual.v
@@ -106,8 +106,8 @@ Ltac bool_eq_refl_case :=
end.
Ltac bool_eq_refl :=
- let H := fresh "Hrec" in let x := fresh "x" in
- fix H 1; intros x; destruct x; simpl; bool_eq_refl_case.
+ let Hrec := fresh "Hrec" in let x := fresh "x" in
+ fix Hrec 1; intros x; destruct x; simpl; bool_eq_refl_case.
Lemma false_not_true:
forall (P: Prop), false = true -> P.
@@ -124,7 +124,6 @@ Qed.
Ltac bool_eq_sound_case :=
match goal with
- | [ H: false = true |- _ ] => exact (false_not_true _ H)
| [ H: _ && _ = true |- _ ] => apply andb_prop in H; destruct H; bool_eq_sound_case
| [ H: proj_sumbool ?a = true |- _ ] => apply proj_sumbool_true in H; bool_eq_sound_case
| [ |- ?C ?x1 ?x2 ?x3 ?x4 = ?C ?y1 ?y2 ?y3 ?y4 ] => apply f_equal4; auto
@@ -137,7 +136,9 @@ Ltac bool_eq_sound_case :=
Ltac bool_eq_sound :=
let Hrec := fresh "Hrec" in let x := fresh "x" in let y := fresh "y" in
- fix Hrec 1; intros x y; destruct x, y; simpl; intro; bool_eq_sound_case.
+ let H := fresh "EQ" in
+ fix Hrec 1; intros x y; destruct x, y; intro H;
+ try (apply (false_not_true _ H)); simpl in H; bool_eq_sound_case.
Lemma dec_eq_from_bool_eq:
forall (A: Type) (f: A -> A -> bool)
diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml
index d94e3582..66322efb 100644
--- a/lib/Camlcoq.ml
+++ b/lib/Camlcoq.ml
@@ -335,54 +335,3 @@ let coqfloat32_of_camlfloat f =
Float32.of_bits(coqint_of_camlint(Int32.bits_of_float f))
let camlfloat_of_coqfloat32 f =
Int32.float_of_bits(camlint_of_coqint(Float32.to_bits f))
-
-(* Int31 *)
-
-module Int31 = struct
-
-(*
-let constr (b30,b29,b28,b27,b26,b25,b24,
- b23,b22,b21,b20,b19,b18,b17,b16,
- b15,b14,b13,b12,b11,b10,b9,b8,
- b7,b6,b5,b4,b3,b2,b1,b0) =
- let f i b accu = if b then accu + (1 lsl i) else accu in
- f 30 b30 (f 29 b29 (f 28 b28 (f 27 b27 (f 26 b26 (f 25 b25 (f 24 b24
- (f 23 b23 (f 22 b22 (f 21 b21 (f 20 b20 (f 19 b19 (f 18 b18 (f 17 b17 (f 16 b16
- (f 15 b15 (f 14 b14 (f 13 b13 (f 12 b12 (f 11 b11 (f 10 b10 (f 9 b9 (f 8 b8
- (f 7 b7 (f 6 b6 (f 5 b5 (f 4 b4 (f 3 b3 (f 2 b2 (f 1 b1 (f 0 b0 0))))))))))))))))))))))))))))))
-*)
-
-let constr (b30,b29,b28,b27,b26,b25,b24,
- b23,b22,b21,b20,b19,b18,b17,b16,
- b15,b14,b13,b12,b11,b10,b9,b8,
- b7,b6,b5,b4,b3,b2,b1,b0) =
- let f i b = if b then 1 lsl i else 0 in
- f 30 b30 + f 29 b29 + f 28 b28 + f 27 b27 + f 26 b26 + f 25 b25 + f 24 b24 +
- f 23 b23 + f 22 b22 + f 21 b21 + f 20 b20 + f 19 b19 + f 18 b18 + f 17 b17 + f 16 b16 +
- f 15 b15 + f 14 b14 + f 13 b13 + f 12 b12 + f 11 b11 + f 10 b10 + f 9 b9 + f 8 b8 +
- f 7 b7 + f 6 b6 + f 5 b5 + f 4 b4 + f 3 b3 + f 2 b2 + f 1 b1 + f 0 b0
-
-let destr f n =
- let b i = n land (1 lsl i) <> 0 in
- f (b 30) (b 29) (b 28) (b 27) (b 26) (b 25) (b 24)
- (b 23) (b 22) (b 21) (b 20) (b 19) (b 18) (b 17) (b 16)
- (b 15) (b 14) (b 13) (b 12) (b 11) (b 10) (b 9) (b 8)
- (b 7) (b 6) (b 5) (b 4) (b 3) (b 2) (b 1) (b 0)
-
-let twice n =
- (n lsl 1) land 0x7FFFFFFF
-
-let twice_plus_one n =
- ((n lsl 1) land 0x7FFFFFFF) lor 1
-
-let compare (x:int) (y:int) =
- if x = y then Datatypes.Eq
- else begin
- let sx = x < 0 and sy = y < 0 in
- if sx = sy then
- (if x < y then Datatypes.Lt else Datatypes.Gt)
- else
- (if sx then Datatypes.Gt else Datatypes.Lt)
- end
-
-end
diff --git a/lib/Coqlib.v b/lib/Coqlib.v
index 3b8e5b3b..02c5d07f 100644
--- a/lib/Coqlib.v
+++ b/lib/Coqlib.v
@@ -411,42 +411,12 @@ Qed.
(** Properties of Euclidean division and modulus. *)
-Lemma Zdiv_small:
- forall x y, 0 <= x < y -> x / y = 0.
-Proof.
- intros. assert (y > 0). omega.
- assert (forall a b,
- 0 <= a < y ->
- 0 <= y * b + a < y ->
- b = 0).
- intros.
- assert (b = 0 \/ b > 0 \/ (-b) > 0). omega.
- elim H3; intro.
- auto.
- elim H4; intro.
- assert (y * b >= y * 1). apply Zmult_ge_compat_l. omega. omega.
- omegaContradiction.
- assert (y * (-b) >= y * 1). apply Zmult_ge_compat_l. omega. omega.
- rewrite <- Zopp_mult_distr_r in H6. omegaContradiction.
- apply H1 with (x mod y).
- apply Z_mod_lt. auto.
- rewrite <- Z_div_mod_eq. auto. auto.
-Qed.
-
-Lemma Zmod_small:
- forall x y, 0 <= x < y -> x mod y = x.
-Proof.
- intros. assert (y > 0). omega.
- generalize (Z_div_mod_eq x y H0).
- rewrite (Zdiv_small x y H). omega.
-Qed.
-
Lemma Zmod_unique:
forall x y a b,
x = a * y + b -> 0 <= b < y -> x mod y = b.
Proof.
intros. subst x. rewrite Z.add_comm.
- rewrite Z_mod_plus. apply Zmod_small. auto. omega.
+ rewrite Z_mod_plus. apply Z.mod_small. auto. omega.
Qed.
Lemma Zdiv_unique:
@@ -461,30 +431,7 @@ Lemma Zdiv_Zdiv:
forall a b c,
b > 0 -> c > 0 -> (a / b) / c = a / (b * c).
Proof.
- intros.
- generalize (Z_div_mod_eq a b H). generalize (Z_mod_lt a b H). intros.
- generalize (Z_div_mod_eq (a/b) c H0). generalize (Z_mod_lt (a/b) c H0). intros.
- set (q1 := a / b) in *. set (r1 := a mod b) in *.
- set (q2 := q1 / c) in *. set (r2 := q1 mod c) in *.
- symmetry. apply Zdiv_unique with (r2 * b + r1).
- rewrite H2. rewrite H4. ring.
- split.
- assert (0 <= r2 * b). apply Z.mul_nonneg_nonneg. omega. omega. omega.
- assert ((r2 + 1) * b <= c * b).
- apply Zmult_le_compat_r. omega. omega.
- replace ((r2 + 1) * b) with (r2 * b + b) in H5 by ring.
- replace (c * b) with (b * c) in H5 by ring.
- omega.
-Qed.
-
-Lemma Zmult_le_compat_l_neg :
- forall n m p:Z, n >= m -> p <= 0 -> p * n <= p * m.
-Proof.
- intros.
- assert ((-p) * n >= (-p) * m). apply Zmult_ge_compat_l. auto. omega.
- replace (p * n) with (- ((-p) * n)) by ring.
- replace (p * m) with (- ((-p) * m)) by ring.
- omega.
+ intros. apply Z.div_div; omega.
Qed.
Lemma Zdiv_interval_1:
@@ -516,9 +463,9 @@ Proof.
intros.
assert (lo <= a / b < hi+1).
apply Zdiv_interval_1. omega. omega. auto.
- assert (lo * b <= lo * 1). apply Zmult_le_compat_l_neg. omega. omega.
+ assert (lo * b <= lo * 1) by (apply Z.mul_le_mono_nonpos_l; omega).
replace (lo * 1) with lo in H3 by ring.
- assert ((hi + 1) * 1 <= (hi + 1) * b). apply Zmult_le_compat_l. omega. omega.
+ assert ((hi + 1) * 1 <= (hi + 1) * b) by (apply Z.mul_le_mono_nonneg_l; omega).
replace ((hi + 1) * 1) with (hi + 1) in H4 by ring.
omega.
omega.
@@ -529,42 +476,11 @@ Lemma Zmod_recombine:
a > 0 -> b > 0 ->
x mod (a * b) = ((x/b) mod a) * b + (x mod b).
Proof.
- intros.
- set (xb := x/b).
- apply Zmod_unique with (xb/a).
- generalize (Z_div_mod_eq x b H0); fold xb; intro EQ1.
- generalize (Z_div_mod_eq xb a H); intro EQ2.
- rewrite EQ2 in EQ1.
- eapply eq_trans. eexact EQ1. ring.
- generalize (Z_mod_lt x b H0). intro.
- generalize (Z_mod_lt xb a H). intro.
- assert (0 <= xb mod a * b <= a * b - b).
- split. apply Z.mul_nonneg_nonneg; omega.
- replace (a * b - b) with ((a - 1) * b) by ring.
- apply Zmult_le_compat; omega.
- omega.
+ intros. rewrite (Z.mul_comm a b). rewrite Z.rem_mul_r by omega. ring.
Qed.
(** Properties of divisibility. *)
-Lemma Zdivides_trans:
- forall x y z, (x | y) -> (y | z) -> (x | z).
-Proof.
- intros x y z [a A] [b B]; subst. exists (a*b); ring.
-Qed.
-
-Definition Zdivide_dec:
- forall (p q: Z), p > 0 -> { (p|q) } + { ~(p|q) }.
-Proof.
- intros. destruct (zeq (Z.modulo q p) 0).
- left. exists (q / p).
- transitivity (p * (q / p) + (q mod p)). apply Z_div_mod_eq; auto.
- transitivity (p * (q / p)). omega. ring.
- right; red; intros. elim n. apply Z_div_exact_1; auto.
- inv H0. rewrite Z_div_mult; auto. ring.
-Defined.
-Global Opaque Zdivide_dec.
-
Lemma Zdivide_interval:
forall a b c,
0 < c -> 0 <= a < b -> (c | a) -> (c | b) -> 0 <= a <= b - c.
@@ -577,43 +493,20 @@ Qed.
(** Conversion from [Z] to [nat]. *)
-Definition nat_of_Z: Z -> nat := Z.to_nat.
-
-Lemma nat_of_Z_of_nat:
- forall n, nat_of_Z (Z.of_nat n) = n.
-Proof.
- exact Nat2Z.id.
-Qed.
-
-Lemma nat_of_Z_max:
- forall z, Z.of_nat (nat_of_Z z) = Z.max z 0.
-Proof.
- intros. unfold Z.max. destruct z; simpl; auto.
- change (Z.of_nat (Z.to_nat (Zpos p)) = Zpos p).
- apply Z2Nat.id. compute; intuition congruence.
-Qed.
-
-Lemma nat_of_Z_eq:
- forall z, z >= 0 -> Z.of_nat (nat_of_Z z) = z.
-Proof.
- unfold nat_of_Z; intros. apply Z2Nat.id. omega.
-Qed.
-
-Lemma nat_of_Z_neg:
- forall n, n <= 0 -> nat_of_Z n = O.
+Lemma Z_to_nat_neg:
+ forall n, n <= 0 -> Z.to_nat n = O.
Proof.
destruct n; unfold Z.le; simpl; auto. congruence.
Qed.
-Lemma nat_of_Z_plus:
- forall p q,
- p >= 0 -> q >= 0 ->
- nat_of_Z (p + q) = (nat_of_Z p + nat_of_Z q)%nat.
+Lemma Z_to_nat_max:
+ forall z, Z.of_nat (Z.to_nat z) = Z.max z 0.
Proof.
- unfold nat_of_Z; intros. apply Z2Nat.inj_add; omega.
+ intros. destruct (zle 0 z).
+- rewrite Z2Nat.id by auto. xomega.
+- rewrite Z_to_nat_neg by omega. xomega.
Qed.
-
(** Alignment: [align n amount] returns the smallest multiple of [amount]
greater than or equal to [n]. *)
diff --git a/lib/Floats.v b/lib/Floats.v
index ba225be1..272efa52 100644
--- a/lib/Floats.v
+++ b/lib/Floats.v
@@ -16,20 +16,80 @@
(** Formalization of floating-point numbers, using the Flocq library. *)
-Require Import Coqlib.
-Require Import Integers.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
-Require Import Fappli_IEEE_extra.
-Require Import Fcore.
+Require Import Coqlib Zbits Integers Axioms.
+(*From Flocq*)
+Require Import Binary Bits Core.
+Require Import IEEE754_extra.
Require Import Program.
Require Archi.
Close Scope R_scope.
+Open Scope Z_scope.
Definition float := binary64. (**r the type of IEE754 double-precision FP numbers *)
+
+Definition float_eq: forall (i1 i2: float), {i1=i2} + {i1<>i2}.
+Proof.
+ intros. destruct i1.
+(* B754_zero *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + apply eqb_prop in BEQ. subst. left. reflexivity.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_infinity *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + apply eqb_prop in BEQ. subst. left. reflexivity.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_nan *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + generalize (Pos.eq_dec pl pl0). intro. inv H.
+ ++ left. apply eqb_prop in BEQ. subst.
+ assert (e = e0) by (apply proof_irr). congruence.
+ ++ right. intro. inv H. contradiction.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_finite *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ; [apply eqb_prop in BEQ | apply eqb_false_iff in BEQ].
+ generalize (Pos.eq_dec m m0). intro. inv H.
+ generalize (Z.eq_dec e e1). intro. inv H.
+ 1: { left. assert (e0 = e2) by (apply proof_irr). congruence. }
+ all: right; intro; inv H; contradiction.
+Qed.
+
Definition float32 := binary32. (**r the type of IEE754 single-precision FP numbers *)
+Definition float32_eq: forall (i1 i2: float32), {i1=i2} + {i1<>i2}.
+Proof.
+ intros. destruct i1.
+(* B754_zero *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + apply eqb_prop in BEQ. subst. left. reflexivity.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_infinity *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + apply eqb_prop in BEQ. subst. left. reflexivity.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_nan *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ.
+ + generalize (Pos.eq_dec pl pl0). intro. inv H.
+ ++ left. apply eqb_prop in BEQ. subst.
+ assert (e = e0) by (apply proof_irr). congruence.
+ ++ right. intro. inv H. contradiction.
+ + apply eqb_false_iff in BEQ. right. intro. inv H. contradiction.
+(* B754_finite *)
+ - destruct i2; try (right; discriminate).
+ destruct (eqb s s0) eqn:BEQ; [apply eqb_prop in BEQ | apply eqb_false_iff in BEQ].
+ generalize (Pos.eq_dec m m0). intro. inv H.
+ generalize (Z.eq_dec e e1). intro. inv H.
+ 1: { left. assert (e0 = e2) by (apply proof_irr). congruence. }
+ all: right; intro; inv H; contradiction.
+Qed.
+
(** Boolean-valued comparisons *)
Definition cmp_of_comparison (c: comparison) (x: option Datatypes.comparison) : bool :=
@@ -95,10 +155,53 @@ Proof.
destruct x as [[]|]; simpl; intros; discriminate.
Qed.
+(** Normalization of NaN payloads *)
+
+Lemma normalized_nan: forall prec n p,
+ Z.of_nat n = prec - 1 -> 1 < prec ->
+ nan_pl prec (Z.to_pos (P_mod_two_p p n)) = true.
+Proof.
+ intros. unfold nan_pl. apply Z.ltb_lt. rewrite Digits.Zpos_digits2_pos.
+ set (p' := P_mod_two_p p n).
+ assert (A: 0 <= p' < 2 ^ Z.of_nat n).
+ { rewrite <- two_power_nat_equiv; apply P_mod_two_p_range. }
+ assert (B: Digits.Zdigits radix2 p' <= prec - 1).
+ { apply Digits.Zdigits_le_Zpower. rewrite <- H. rewrite Z.abs_eq; tauto. }
+ destruct (zeq p' 0).
+- rewrite e. simpl; auto.
+- rewrite Z2Pos.id by omega. omega.
+Qed.
+
+(** Transform a Nan payload to a quiet Nan payload. *)
+
+Definition quiet_nan_64_payload (p: positive) :=
+ Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 51 1%positive))) 52%nat).
+
+Lemma quiet_nan_64_proof: forall p, nan_pl 53 (quiet_nan_64_payload p) = true.
+Proof. intros; apply normalized_nan; auto; omega. Qed.
+
+Definition quiet_nan_64 (sp: bool * positive) : {x :float | is_nan _ _ x = true} :=
+ let (s, p) := sp in
+ exist _ (B754_nan 53 1024 s (quiet_nan_64_payload p) (quiet_nan_64_proof p)) (eq_refl true).
+
+Definition default_nan_64 := quiet_nan_64 Archi.default_nan_64.
+
+Definition quiet_nan_32_payload (p: positive) :=
+ Z.to_pos (P_mod_two_p (Pos.lor p ((iter_nat xO 22 1%positive))) 23%nat).
+
+Lemma quiet_nan_32_proof: forall p, nan_pl 24 (quiet_nan_32_payload p) = true.
+Proof. intros; apply normalized_nan; auto; omega. Qed.
+
+Definition quiet_nan_32 (sp: bool * positive) : {x :float32 | is_nan _ _ x = true} :=
+ let (s, p) := sp in
+ exist _ (B754_nan 24 128 s (quiet_nan_32_payload p) (quiet_nan_32_proof p)) (eq_refl true).
+
+Definition default_nan_32 := quiet_nan_32 Archi.default_nan_32.
+
Local Notation __ := (eq_refl Datatypes.Lt).
-Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt).
-Local Hint Extern 1 (_ < _) => exact (eq_refl Datatypes.Lt).
+Local Hint Extern 1 (Prec_gt_0 _) => exact (eq_refl Datatypes.Lt) : core.
+Local Hint Extern 1 (_ < _) => exact (eq_refl Datatypes.Lt) : core.
(** * Double-precision FP numbers *)
@@ -109,97 +212,107 @@ Module Float.
(** The following definitions are not part of the IEEE754 standard but
apply to all architectures supported by CompCert. *)
-(** Transform a Nan payload to a quiet Nan payload. *)
-
-Program Definition transform_quiet_pl (pl:nan_pl 53) : nan_pl 53 :=
- Pos.lor pl (iter_nat xO 51 xH).
-Next Obligation.
- destruct pl.
- simpl. rewrite Z.ltb_lt in *.
- assert (forall x, Fcore_digits.digits2_pos x = Pos.size x).
- { induction x0; simpl; auto; rewrite IHx0; zify; omega. }
- rewrite H, Psize_log_inf, <- Zlog2_log_inf in *. clear H.
- change (Z.pos (Pos.lor x 2251799813685248)) with (Z.lor (Z.pos x) 2251799813685248%Z).
- rewrite Z.log2_lor by (zify; omega).
- apply Z.max_case. auto. simpl. omega.
-Qed.
+(** Nan payload operations for single <-> double conversions. *)
-Lemma nan_payload_fequal:
- forall prec (p1 p2: nan_pl prec),
- proj1_sig p1 = proj1_sig p2 -> p1 = p2.
-Proof.
- intros. destruct p1, p2; simpl in H; subst. f_equal. apply Fcore_Zaux.eqbool_irrelevance.
-Qed.
+Definition expand_nan_payload (p: positive) := Pos.shiftl_nat p 29.
-Lemma lor_idempotent:
- forall x y, Pos.lor (Pos.lor x y) y = Pos.lor x y.
+Lemma expand_nan_proof (p : positive) :
+ nan_pl 24 p = true ->
+ nan_pl 53 (expand_nan_payload p) = true.
Proof.
- induction x; destruct y; simpl; f_equal; auto;
- induction y; simpl; f_equal; auto.
+ unfold nan_pl, expand_nan_payload. intros K.
+ rewrite Z.ltb_lt in *.
+ unfold Pos.shiftl_nat, nat_rect, Digits.digits2_pos.
+ fold (Digits.digits2_pos p).
+ zify; omega.
Qed.
-Lemma transform_quiet_pl_idempotent:
- forall pl, transform_quiet_pl (transform_quiet_pl pl) = transform_quiet_pl pl.
-Proof.
- intros. apply nan_payload_fequal; simpl. apply lor_idempotent.
-Qed.
+Definition expand_nan s p H : {x | is_nan _ _ x = true} :=
+ exist _ (B754_nan 53 1024 s (expand_nan_payload p) (expand_nan_proof p H)) (eq_refl true).
-(** Nan payload operations for single <-> double conversions. *)
+Definition of_single_nan (f : float32) : { x : float | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H =>
+ if Archi.float_of_single_preserves_sNaN
+ then expand_nan s p H
+ else quiet_nan_64 (s, expand_nan_payload p)
+ | _ => default_nan_64
+ end.
-Definition expand_pl (pl: nan_pl 24) : nan_pl 53.
-Proof.
- refine (exist _ (Pos.shiftl_nat (proj1_sig pl) 29) _).
- abstract (
- destruct pl; unfold proj1_sig, Pos.shiftl_nat, nat_rect, Fcore_digits.digits2_pos;
- fold (Fcore_digits.digits2_pos x);
- rewrite Z.ltb_lt in *;
- zify; omega).
-Defined.
-
-Definition of_single_pl (s:bool) (pl:nan_pl 24) : (bool * nan_pl 53) :=
- (s,
- if Archi.float_of_single_preserves_sNaN
- then expand_pl pl
- else transform_quiet_pl (expand_pl pl)).
-
-Definition reduce_pl (pl: nan_pl 53) : nan_pl 24.
-Proof.
- refine (exist _ (Pos.shiftr_nat (proj1_sig pl) 29) _).
- abstract (
- destruct pl; unfold proj1_sig, Pos.shiftr_nat, nat_rect;
- rewrite Z.ltb_lt in *;
- assert (forall x, Fcore_digits.digits2_pos (Pos.div2 x) =
- (Fcore_digits.digits2_pos x - 1)%positive)
- by (destruct x0; simpl; auto; rewrite Pplus_one_succ_r, Pos.add_sub; auto);
- rewrite !H, !Pos2Z.inj_sub_max;
- repeat (apply Z.max_lub_lt; [reflexivity |apply Z.lt_sub_lt_add_l]); auto).
-Defined.
-
-Definition to_single_pl (s:bool) (pl:nan_pl 53) : (bool * nan_pl 24) :=
- (s, reduce_pl (transform_quiet_pl pl)).
+Definition reduce_nan_payload (p: positive) :=
+ (* The [quiet_nan_64_payload p] before the right shift is redundant with
+ the [quiet_nan_32_payload p] performed after, in [to_single_nan].
+ However the former ensures that the result of the right shift is
+ not 0 and therefore representable as a positive. *)
+ Pos.shiftr_nat (quiet_nan_64_payload p) 29.
+
+Definition to_single_nan (f : float) : { x : float32 | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H => quiet_nan_32 (s, reduce_nan_payload p)
+ | _ => default_nan_32
+ end.
(** NaN payload operations for opposite and absolute value. *)
-Definition neg_pl (s:bool) (pl:nan_pl 53) := (negb s, pl).
-Definition abs_pl (s:bool) (pl:nan_pl 53) := (false, pl).
+Definition neg_nan (f : float) : { x : float | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H => exist _ (B754_nan 53 1024 (negb s) p H) (eq_refl true)
+ | _ => default_nan_64
+ end.
+
+Definition abs_nan (f : float) : { x : float | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H => exist _ (B754_nan 53 1024 false p H) (eq_refl true)
+ | _ => default_nan_64
+ end.
+
+(** When an arithmetic operation returns a NaN, the sign and payload
+ of this NaN are not fully specified by the IEEE standard, and vary
+ among the architectures supported by CompCert. However, the following
+ behavior applies to all the supported architectures: the payload is either
+- a default payload, independent of the arguments, or
+- the payload of one of the NaN arguments, if any.
+
+For each supported architecture, the functions [Archi.choose_nan_64]
+and [Archi.choose_nan_32] determine the payload of the result as a
+function of the payloads of the NaN arguments.
+
+Additionally, signaling NaNs are converted to quiet NaNs, as required by the standard.
+*)
-(** The NaN payload operations for two-argument arithmetic operations
- are not part of the IEEE754 standard, but all architectures of
- Compcert share a similar NaN behavior, parameterized by:
-- a "default" payload which occurs when an operation generates a NaN from
- non-NaN arguments;
-- a choice function determining which of the payload arguments to choose,
- when an operation is given two NaN arguments. *)
+Definition cons_pl (x: float) (l: list (bool * positive)) :=
+ match x with B754_nan s p _ => (s, p) :: l | _ => l end.
-Definition binop_pl (x y: binary64) : bool*nan_pl 53 :=
+Definition unop_nan (x: float) : {x : float | is_nan _ _ x = true} :=
+ quiet_nan_64 (Archi.choose_nan_64 (cons_pl x [])).
+
+Definition binop_nan (x y: float) : {x : float | is_nan _ _ x = true} :=
+ quiet_nan_64 (Archi.choose_nan_64 (cons_pl x (cons_pl y []))).
+
+(** For fused multiply-add, the order in which arguments are examined
+ to select a NaN payload varies across platforms. E.g. in [fma x y z],
+ x86 considers [x] first, then [y], then [z], while ARM considers [z] first,
+ then [x], then [y]. The corresponding permutation is defined
+ for each target, as function [Archi.fma_order]. *)
+
+Definition fma_nan_1 (x y z: float) : {x : float | is_nan _ _ x = true} :=
+ let '(a, b, c) := Archi.fma_order x y z in
+ quiet_nan_64 (Archi.choose_nan_64 (cons_pl a (cons_pl b (cons_pl c [])))).
+
+(** One last wrinkle for fused multiply-add: [fma zero infinity nan]
+ can return either the quiesced [nan], or the default NaN arising out
+ of the invalid operation [zero * infinity]. Of our target platforms,
+ only ARM honors the latter case. The choice between the default NaN
+ and [nan] is done as in the case of two-argument arithmetic operations. *)
+
+Definition fma_nan (x y z: float) : {x : float | is_nan _ _ x = true} :=
match x, y with
- | B754_nan s1 pl1, B754_nan s2 pl2 =>
- if Archi.choose_binop_pl_64 s1 pl1 s2 pl2
- then (s2, transform_quiet_pl pl2)
- else (s1, transform_quiet_pl pl1)
- | B754_nan s1 pl1, _ => (s1, transform_quiet_pl pl1)
- | _, B754_nan s2 pl2 => (s2, transform_quiet_pl pl2)
- | _, _ => Archi.default_pl_64
+ | B754_infinity _, B754_zero _ | B754_zero _, B754_infinity _ =>
+ if Archi.fma_invalid_mul_is_nan
+ then quiet_nan_64 (Archi.choose_nan_64 (Archi.default_nan_64 :: cons_pl z []))
+ else fma_nan_1 x y z
+ | _, _ =>
+ fma_nan_1 x y z
end.
(** ** Operations over double-precision floats *)
@@ -210,16 +323,20 @@ Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2} := Beq_dec _ _.
(** Arithmetic operations *)
-Definition neg: float -> float := Bopp _ _ neg_pl. (**r opposite (change sign) *)
-Definition abs: float -> float := Babs _ _ abs_pl. (**r absolute value (set sign to [+]) *)
+Definition neg: float -> float := Bopp _ _ neg_nan. (**r opposite (change sign) *)
+Definition abs: float -> float := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *)
+Definition sqrt: float -> float :=
+ Bsqrt 53 1024 __ __ unop_nan mode_NE. (**r square root *)
Definition add: float -> float -> float :=
- Bplus 53 1024 __ __ binop_pl mode_NE. (**r addition *)
+ Bplus 53 1024 __ __ binop_nan mode_NE. (**r addition *)
Definition sub: float -> float -> float :=
- Bminus 53 1024 __ __ binop_pl mode_NE. (**r subtraction *)
+ Bminus 53 1024 __ __ binop_nan mode_NE. (**r subtraction *)
Definition mul: float -> float -> float :=
- Bmult 53 1024 __ __ binop_pl mode_NE. (**r multiplication *)
+ Bmult 53 1024 __ __ binop_nan mode_NE. (**r multiplication *)
Definition div: float -> float -> float :=
- Bdiv 53 1024 __ __ binop_pl mode_NE. (**r division *)
+ Bdiv 53 1024 __ __ binop_nan mode_NE. (**r division *)
+Definition fma: float -> float -> float -> float :=
+ Bfma 53 1024 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *)
Definition compare (f1 f2: float) : option Datatypes.comparison := (**r general comparison *)
Bcompare 53 1024 f1 f2.
Definition cmp (c:comparison) (f1 f2: float) : bool := (**r Boolean comparison *)
@@ -229,8 +346,8 @@ Definition ordered (f1 f2: float) : bool :=
(** Conversions *)
-Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_pl mode_NE.
-Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_pl mode_NE.
+Definition of_single: float32 -> float := Bconv _ _ 53 1024 __ __ of_single_nan mode_NE.
+Definition to_single: float -> float32 := Bconv _ _ 24 128 __ __ to_single_nan mode_NE.
Definition to_int (f:float): option int := (**r conversion to signed 32-bit int *)
option_map Int.repr (ZofB_range _ _ f Int.min_signed Int.max_signed).
@@ -288,14 +405,14 @@ Theorem add_commut:
forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x.
Proof.
intros. apply Bplus_commut.
- destruct x, y; try reflexivity. simpl in H. intuition congruence.
+ destruct x, y; try reflexivity; now destruct H.
Qed.
Theorem mul_commut:
forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x.
Proof.
intros. apply Bmult_commut.
- destruct x, y; try reflexivity. simpl in H. intuition congruence.
+ destruct x, y; try reflexivity; now destruct H.
Qed.
(** Multiplication by 2 is diagonal addition. *)
@@ -304,10 +421,9 @@ Theorem mul2_add:
forall f, add f f = mul f (of_int (Int.repr 2%Z)).
Proof.
intros. apply Bmult2_Bplus.
- intros. destruct x; try discriminate. simpl.
- transitivity (b, transform_quiet_pl n).
- destruct Archi.choose_binop_pl_64; auto.
- destruct y; auto || discriminate.
+ intros x y Hx Hy. unfold binop_nan.
+ destruct x; try discriminate. simpl. rewrite Archi.choose_nan_64_idem.
+ destruct y; reflexivity || discriminate.
Qed.
(** Divisions that can be turned into multiplication by an inverse. *)
@@ -317,11 +433,10 @@ Definition exact_inverse : float -> option float := Bexact_inverse 53 1024 __ __
Theorem div_mul_inverse:
forall x y z, exact_inverse y = Some z -> div x y = mul x z.
Proof.
- intros. apply Bdiv_mult_inverse; auto.
- intros. destruct x0; try discriminate. simpl.
- transitivity (b, transform_quiet_pl n).
- destruct y0; reflexivity || discriminate.
- destruct z0; reflexivity || discriminate.
+ intros. apply Bdiv_mult_inverse. 2: easy.
+ intros x0 y0 z0 Hx Hy Hz. unfold binop_nan.
+ destruct x0; try discriminate.
+ destruct y0, z0; reflexivity || discriminate.
Qed.
(** Properties of comparisons. *)
@@ -395,6 +510,7 @@ Qed.
to emulate the former.) *)
Definition ox8000_0000 := Int.repr Int.half_modulus. (**r [0x8000_0000] *)
+Definition ox7FFF_FFFF := Int.repr Int.max_signed. (**r [0x7FFF_FFFF] *)
Theorem of_intu_of_int_1:
forall x,
@@ -425,6 +541,46 @@ Proof.
compute_this (Int.unsigned ox8000_0000); smart_omega.
Qed.
+Theorem of_intu_of_int_3:
+ forall x,
+ of_intu x = sub (of_int (Int.and x ox7FFF_FFFF)) (of_int (Int.and x ox8000_0000)).
+Proof.
+ intros.
+ set (hi := Int.and x ox8000_0000).
+ set (lo := Int.and x ox7FFF_FFFF).
+ assert (R: forall n, integer_representable 53 1024 (Int.signed n)).
+ { intros. pose proof (Int.signed_range n).
+ apply integer_representable_n; auto; smart_omega. }
+ unfold sub, of_int. rewrite BofZ_minus by auto. unfold of_intu. f_equal.
+ assert (E: Int.add hi lo = x).
+ { unfold hi, lo. rewrite Int.add_is_or.
+ - rewrite <- Int.and_or_distrib. apply Int.and_mone.
+ - rewrite Int.and_assoc. rewrite (Int.and_commut ox8000_0000). rewrite Int.and_assoc.
+ change (Int.and ox7FFF_FFFF ox8000_0000) with Int.zero. rewrite ! Int.and_zero; auto.
+ }
+ assert (RNG: 0 <= Int.unsigned lo < two_p 31).
+ { unfold lo. change ox7FFF_FFFF with (Int.repr (two_p 31 - 1)). rewrite <- Int.zero_ext_and by omega.
+ apply Int.zero_ext_range. compute_this Int.zwordsize. omega. }
+ assert (B: forall i, 0 <= i < Int.zwordsize -> Int.testbit ox8000_0000 i = if zeq i 31 then true else false).
+ { intros; unfold Int.testbit. change (Int.unsigned ox8000_0000) with (2^31).
+ destruct (zeq i 31). subst i; auto. apply Z.pow2_bits_false; auto. }
+ assert (EITHER: hi = Int.zero \/ hi = ox8000_0000).
+ { unfold hi; destruct (Int.testbit x 31) eqn:B31; [right|left];
+ Int.bit_solve; rewrite B by auto.
+ - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r.
+ - destruct (zeq i 31). subst i; rewrite B31; auto. apply andb_false_r.
+ }
+ assert (SU: - Int.signed hi = Int.unsigned hi).
+ { destruct EITHER as [EQ|EQ]; rewrite EQ; reflexivity. }
+ unfold Z.sub; rewrite SU, <- E.
+ unfold Int.add; rewrite Int.unsigned_repr, Int.signed_eq_unsigned. omega.
+ - assert (Int.max_signed = two_p 31 - 1) by reflexivity. omega.
+ - assert (Int.unsigned hi = 0 \/ Int.unsigned hi = two_p 31)
+ by (destruct EITHER as [EQ|EQ]; rewrite EQ; [left|right]; reflexivity).
+ assert (Int.max_unsigned = two_p 31 + two_p 31 - 1) by reflexivity.
+ omega.
+Qed.
+
Theorem to_intu_to_int_1:
forall x n,
cmp Clt x (of_intu ox8000_0000) = true ->
@@ -451,7 +607,7 @@ Proof.
rewrite Bcompare_correct in CMP by auto.
inv CMP. apply Rcompare_Lt_inv in H1. rewrite EQy in H1.
assert (p < Int.unsigned ox8000_0000).
- { apply lt_Z2R. eapply Rle_lt_trans; eauto. }
+ { apply lt_IZR. apply Rle_lt_trans with (1 := P) (2 := H1). }
change Int.max_signed with (Int.unsigned ox8000_0000 - 1). omega.
Qed.
@@ -471,7 +627,7 @@ Proof.
intros (EQy & FINy & SIGNy).
assert (FINx: is_finite _ _ x = true).
{ rewrite ZofB_correct in C. destruct (is_finite _ _ x) eqn:FINx; congruence. }
- assert (GE: (B2R _ _ x >= Z2R (Int.unsigned ox8000_0000))%R).
+ assert (GE: (B2R _ _ x >= IZR (Int.unsigned ox8000_0000))%R).
{ rewrite <- EQy. unfold cmp, cmp_of_comparison, compare in H.
rewrite Bcompare_correct in H by auto.
destruct (Rcompare (B2R 53 1024 x) (B2R 53 1024 y)) eqn:CMP.
@@ -502,7 +658,6 @@ Proof.
transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1075)).
- f_equal. rewrite Int64.ofwords_add'. reflexivity.
- apply split_join_bits.
- compute; auto.
generalize (Int.unsigned_range x).
compute_this Int.modulus; compute_this (2^52); omega.
compute_this (2^11); omega.
@@ -510,7 +665,7 @@ Qed.
Lemma from_words_value:
forall x,
- B2R _ _ (from_words ox4330_0000 x) = (bpow radix2 52 + Z2R (Int.unsigned x))%R
+ B2R _ _ (from_words ox4330_0000 x) = (bpow radix2 52 + IZR (Int.unsigned x))%R
/\ is_finite _ _ (from_words ox4330_0000 x) = true
/\ Bsign _ _ (from_words ox4330_0000 x) = false.
Proof.
@@ -520,7 +675,7 @@ Proof.
destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?.
exfalso; now smart_omega.
simpl; rewrite <- Heqz; unfold F2R; simpl. split; auto.
- rewrite <- (Z2R_plus 4503599627370496), Rmult_1_r. f_equal. rewrite Z.add_comm. auto.
+ rewrite Rmult_1_r, plus_IZR. apply Rplus_comm.
exfalso; now smart_omega.
Qed.
@@ -533,7 +688,7 @@ Proof.
destruct (BofZ_exact 53 1024 __ __ (2^52 + Int.unsigned x)) as (D & E & F).
smart_omega.
apply B2R_Bsign_inj; auto.
- rewrite A, D. rewrite Z2R_plus. auto.
+ rewrite A, D. rewrite plus_IZR. auto.
rewrite C, F. symmetry. apply Zlt_bool_false. smart_omega.
Qed.
@@ -585,7 +740,6 @@ Proof.
transitivity (split_bits 52 11 (join_bits 52 11 false (Int.unsigned x) 1107)).
- f_equal. rewrite Int64.ofwords_add'. reflexivity.
- apply split_join_bits.
- compute; auto.
generalize (Int.unsigned_range x).
compute_this Int.modulus; compute_this (2^52); omega.
compute_this (2^11); omega.
@@ -593,7 +747,7 @@ Qed.
Lemma from_words_value':
forall x,
- B2R _ _ (from_words ox4530_0000 x) = (bpow radix2 84 + Z2R (Int.unsigned x * two_p 32))%R
+ B2R _ _ (from_words ox4530_0000 x) = (bpow radix2 84 + IZR (Int.unsigned x * two_p 32))%R
/\ is_finite _ _ (from_words ox4530_0000 x) = true
/\ Bsign _ _ (from_words ox4530_0000 x) = false.
Proof.
@@ -603,8 +757,8 @@ Proof.
destruct (Int.unsigned x + Z.pow_pos 2 52) eqn:?.
exfalso; now smart_omega.
simpl; rewrite <- Heqz; unfold F2R; simpl. split; auto.
- rewrite <- (Z2R_plus 19342813113834066795298816), <- (Z2R_mult _ 4294967296).
- f_equal; compute_this (Z.pow_pos 2 52); compute_this (two_power_pos 32); ring.
+ rewrite plus_IZR, Rmult_plus_distr_r, <- 2!mult_IZR, Rplus_comm.
+ easy.
assert (Zneg p < 0) by reflexivity.
exfalso; now smart_omega.
Qed.
@@ -620,7 +774,7 @@ Proof.
with ((2^52 + Int.unsigned x) * 2^32) by ring.
apply integer_representable_n2p; auto. smart_omega. omega. omega.
apply B2R_Bsign_inj; auto.
- rewrite A, D. rewrite <- Z2R_Zpower by omega. rewrite <- Z2R_plus. auto.
+ rewrite A, D. rewrite <- IZR_Zpower by omega. rewrite <- plus_IZR. auto.
rewrite C, F. symmetry. apply Zlt_bool_false.
compute_this (2^84); compute_this (2^32); omega.
Qed.
@@ -902,40 +1056,39 @@ End Float.
Module Float32.
-(** ** NaN payload manipulations *)
+Definition neg_nan (f : float32) : { x : float32 | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H => exist _ (B754_nan 24 128 (negb s) p H) (eq_refl true)
+ | _ => default_nan_32
+ end.
-Program Definition transform_quiet_pl (pl:nan_pl 24) : nan_pl 24 :=
- Pos.lor pl (iter_nat xO 22 xH).
-Next Obligation.
- destruct pl.
- simpl. rewrite Z.ltb_lt in *.
- assert (forall x, Fcore_digits.digits2_pos x = Pos.size x).
- { induction x0; simpl; auto; rewrite IHx0; zify; omega. }
- rewrite H, Psize_log_inf, <- Zlog2_log_inf in *. clear H.
- change (Z.pos (Pos.lor x 4194304)) with (Z.lor (Z.pos x) 4194304%Z).
- rewrite Z.log2_lor by (zify; omega).
- apply Z.max_case. auto. simpl. omega.
-Qed.
+Definition abs_nan (f : float32) : { x : float32 | is_nan _ _ x = true } :=
+ match f with
+ | B754_nan s p H => exist _ (B754_nan 24 128 false p H) (eq_refl true)
+ | _ => default_nan_32
+ end.
-Lemma transform_quiet_pl_idempotent:
- forall pl, transform_quiet_pl (transform_quiet_pl pl) = transform_quiet_pl pl.
-Proof.
- intros []; simpl; intros. apply Float.nan_payload_fequal.
- simpl. apply Float.lor_idempotent.
-Qed.
+Definition cons_pl (x: float32) (l: list (bool * positive)) :=
+ match x with B754_nan s p _ => (s, p) :: l | _ => l end.
-Definition neg_pl (s:bool) (pl:nan_pl 24) := (negb s, pl).
-Definition abs_pl (s:bool) (pl:nan_pl 24) := (false, pl).
+Definition unop_nan (x: float32) : {x : float32 | is_nan _ _ x = true} :=
+ quiet_nan_32 (Archi.choose_nan_32 (cons_pl x [])).
-Definition binop_pl (x y: binary32) : bool*nan_pl 24 :=
+Definition binop_nan (x y: float32) : {x : float32 | is_nan _ _ x = true} :=
+ quiet_nan_32 (Archi.choose_nan_32 (cons_pl x (cons_pl y []))).
+
+Definition fma_nan_1 (x y z: float32) : {x : float32 | is_nan _ _ x = true} :=
+ let '(a, b, c) := Archi.fma_order x y z in
+ quiet_nan_32 (Archi.choose_nan_32 (cons_pl a (cons_pl b (cons_pl c [])))).
+
+Definition fma_nan (x y z: float32) : {x : float32 | is_nan _ _ x = true} :=
match x, y with
- | B754_nan s1 pl1, B754_nan s2 pl2 =>
- if Archi.choose_binop_pl_32 s1 pl1 s2 pl2
- then (s2, transform_quiet_pl pl2)
- else (s1, transform_quiet_pl pl1)
- | B754_nan s1 pl1, _ => (s1, transform_quiet_pl pl1)
- | _, B754_nan s2 pl2 => (s2, transform_quiet_pl pl2)
- | _, _ => Archi.default_pl_32
+ | B754_infinity _, B754_zero _ | B754_zero _, B754_infinity _ =>
+ if Archi.fma_invalid_mul_is_nan
+ then quiet_nan_32 (Archi.choose_nan_32 (Archi.default_nan_32 :: cons_pl z []))
+ else fma_nan_1 x y z
+ | _, _ =>
+ fma_nan_1 x y z
end.
(** ** Operations over single-precision floats *)
@@ -946,16 +1099,20 @@ Definition eq_dec: forall (f1 f2: float32), {f1 = f2} + {f1 <> f2} := Beq_dec _
(** Arithmetic operations *)
-Definition neg: float32 -> float32 := Bopp _ _ neg_pl. (**r opposite (change sign) *)
-Definition abs: float32 -> float32 := Babs _ _ abs_pl. (**r absolute value (set sign to [+]) *)
+Definition neg: float32 -> float32 := Bopp _ _ neg_nan. (**r opposite (change sign) *)
+Definition abs: float32 -> float32 := Babs _ _ abs_nan. (**r absolute value (set sign to [+]) *)
+Definition sqrt: float32 -> float32 :=
+ Bsqrt 24 128 __ __ unop_nan mode_NE. (**r square root *)
Definition add: float32 -> float32 -> float32 :=
- Bplus 24 128 __ __ binop_pl mode_NE. (**r addition *)
+ Bplus 24 128 __ __ binop_nan mode_NE. (**r addition *)
Definition sub: float32 -> float32 -> float32 :=
- Bminus 24 128 __ __ binop_pl mode_NE. (**r subtraction *)
+ Bminus 24 128 __ __ binop_nan mode_NE. (**r subtraction *)
Definition mul: float32 -> float32 -> float32 :=
- Bmult 24 128 __ __ binop_pl mode_NE. (**r multiplication *)
+ Bmult 24 128 __ __ binop_nan mode_NE. (**r multiplication *)
Definition div: float32 -> float32 -> float32 :=
- Bdiv 24 128 __ __ binop_pl mode_NE. (**r division *)
+ Bdiv 24 128 __ __ binop_nan mode_NE. (**r division *)
+Definition fma: float32 -> float32 -> float32 -> float32 :=
+ Bfma 24 128 __ __ fma_nan mode_NE. (**r fused multiply-add [x * y + z] *)
Definition compare (f1 f2: float32) : option Datatypes.comparison := (**r general comparison *)
Bcompare 24 128 f1 f2.
Definition cmp (c:comparison) (f1 f2: float32) : bool := (**r comparison *)
@@ -1003,15 +1160,15 @@ Definition of_bits (b: int): float32 := b32_of_bits (Int.unsigned b).
Theorem add_commut:
forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> add x y = add y x.
Proof.
- intros. apply Bplus_commut.
- destruct x, y; try reflexivity. simpl in H. intuition congruence.
+ intros. apply Bplus_commut.
+ destruct x, y; try reflexivity; now destruct H.
Qed.
Theorem mul_commut:
forall x y, is_nan _ _ x = false \/ is_nan _ _ y = false -> mul x y = mul y x.
Proof.
intros. apply Bmult_commut.
- destruct x, y; try reflexivity. simpl in H. intuition congruence.
+ destruct x, y; try reflexivity; now destruct H.
Qed.
(** Multiplication by 2 is diagonal addition. *)
@@ -1020,10 +1177,9 @@ Theorem mul2_add:
forall f, add f f = mul f (of_int (Int.repr 2%Z)).
Proof.
intros. apply Bmult2_Bplus.
- intros. destruct x; try discriminate. simpl.
- transitivity (b, transform_quiet_pl n).
- destruct Archi.choose_binop_pl_32; auto.
- destruct y; auto || discriminate.
+ intros x y Hx Hy. unfold binop_nan.
+ destruct x; try discriminate. simpl. rewrite Archi.choose_nan_32_idem.
+ destruct y; reflexivity || discriminate.
Qed.
(** Divisions that can be turned into multiplication by an inverse. *)
@@ -1033,11 +1189,10 @@ Definition exact_inverse : float32 -> option float32 := Bexact_inverse 24 128 __
Theorem div_mul_inverse:
forall x y z, exact_inverse y = Some z -> div x y = mul x z.
Proof.
- intros. apply Bdiv_mult_inverse; auto.
- intros. destruct x0; try discriminate. simpl.
- transitivity (b, transform_quiet_pl n).
- destruct y0; reflexivity || discriminate.
- destruct z0; reflexivity || discriminate.
+ intros. apply Bdiv_mult_inverse. 2: easy.
+ intros x0 y0 z0 Hx Hy Hz. unfold binop_nan.
+ destruct x0; try discriminate.
+ destruct y0, z0; reflexivity || discriminate.
Qed.
(** Properties of comparisons. *)
@@ -1193,15 +1348,15 @@ Proof.
set (m := n mod 2^p + (2^p-1)) in *.
assert (C: m / 2^p = if zeq (n mod 2^p) 0 then 0 else 1).
{ unfold m. destruct (zeq (n mod 2^p) 0).
- rewrite e. apply Zdiv_small. omega.
- eapply Zdiv_unique with (n mod 2^p - 1). ring. omega. }
+ rewrite e. apply Z.div_small. omega.
+ eapply Coqlib.Zdiv_unique with (n mod 2^p - 1). ring. omega. }
assert (D: Z.testbit m p = if zeq (n mod 2^p) 0 then false else true).
{ destruct (zeq (n mod 2^p) 0).
apply Z.testbit_false; auto. rewrite C; auto.
apply Z.testbit_true; auto. rewrite C; auto. }
assert (E: forall i, p < i -> Z.testbit m i = false).
{ intros. apply Z.testbit_false. omega.
- replace (m / 2^i) with 0. auto. symmetry. apply Zdiv_small.
+ replace (m / 2^i) with 0. auto. symmetry. apply Z.div_small.
unfold m. split. omega. apply Z.lt_le_trans with (2 * 2^p). omega.
change 2 with (2^1) at 1. rewrite <- (Zpower_plus radix2) by omega.
apply Zpower_le. omega. }
@@ -1264,7 +1419,7 @@ Proof.
intros.
pose proof (Int64.unsigned_range n).
unfold of_longu. erewrite of_long_round_odd.
- unfold of_double, Float.to_single. instantiate (1 := Float.to_single_pl).
+ unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan).
f_equal. unfold Float.of_longu. f_equal.
set (n' := Z.land (Z.lor (Int64.unsigned n) (Z.land (Int64.unsigned n) 2047 + 2047)) (-2048)).
assert (int_round_odd (Int64.unsigned n) 11 = n') by (apply int_round_odd_plus; omega).
@@ -1310,7 +1465,7 @@ Proof.
intros.
pose proof (Int64.signed_range n).
unfold of_long. erewrite of_long_round_odd.
- unfold of_double, Float.to_single. instantiate (1 := Float.to_single_pl).
+ unfold of_double, Float.to_single. instantiate (1 := Float.to_single_nan).
f_equal. unfold Float.of_long. f_equal.
set (n' := Z.land (Z.lor (Int64.signed n) (Z.land (Int64.signed n) 2047 + 2047)) (-2048)).
assert (int_round_odd (Int64.signed n) 11 = n') by (apply int_round_odd_plus; omega).
@@ -1331,9 +1486,9 @@ Proof.
rewrite Int64.testbit_repr by auto. f_equal. f_equal. unfold Int64.and.
change (Int64.unsigned (Int64.repr 2047)) with 2047.
change 2047 with (Z.ones 11). rewrite ! Z.land_ones by omega.
- rewrite Int64.unsigned_repr. apply Int64.eqmod_mod_eq.
+ rewrite Int64.unsigned_repr. apply eqmod_mod_eq.
apply Z.lt_gt. apply (Zpower_gt_0 radix2); omega.
- apply Int64.eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned.
+ apply eqmod_divides with (2^64). apply Int64.eqm_signed_unsigned.
exists (2^(64-11)); auto.
exploit (Z_mod_lt (Int64.unsigned n) (2^11)). compute; auto.
assert (2^11 < Int64.max_unsigned) by (compute; auto). omega.
diff --git a/lib/Heaps.v b/lib/Heaps.v
index 2a21f88c..85343998 100644
--- a/lib/Heaps.v
+++ b/lib/Heaps.v
@@ -256,14 +256,14 @@ Proof.
eapply gt_heap_trans with y; eauto. red; auto.
- intuition.
eapply lt_heap_trans; eauto. red; auto.
- eapply gt_heap_trans; eauto. red; auto.
+ eapply gt_heap_trans; eauto. red; auto with ordered_type.
- intuition. eapply gt_heap_trans; eauto. red; auto.
- rewrite e3 in *; simpl in *. intuition.
eapply lt_heap_trans with y; eauto. red; auto.
eapply gt_heap_trans; eauto. red; auto.
- intuition.
eapply lt_heap_trans with y; eauto. red; auto.
- eapply gt_heap_trans; eauto. red; auto.
+ eapply gt_heap_trans; eauto. red; auto with ordered_type.
eapply gt_heap_trans with x; eauto. red; auto.
- rewrite e3 in *; simpl in *; intuition.
eapply gt_heap_trans; eauto. red; auto.
@@ -308,7 +308,7 @@ Proof.
intros. unfold insert.
case_eq (partition x h). intros a b EQ; simpl.
assert (E.eq y x \/ ~E.eq y x).
- destruct (E.compare y x); auto.
+ destruct (E.compare y x); auto with ordered_type.
right; red; intros. elim (E.lt_not_eq l). apply E.eq_sym; auto.
destruct H0.
tauto.
@@ -432,7 +432,7 @@ Lemma lt_heap_In:
Proof.
induction h; simpl; intros.
contradiction.
- intuition. apply le_lt_trans with x0; auto. red. left. apply E.eq_sym; auto.
+ intuition. apply le_lt_trans with x0; auto. red. left. assumption.
Qed.
Lemma findMax_max:
diff --git a/lib/Fappli_IEEE_extra.v b/lib/IEEE754_extra.v
index 85fadc16..c23149be 100644
--- a/lib/Fappli_IEEE_extra.v
+++ b/lib/IEEE754_extra.v
@@ -20,15 +20,8 @@
Require Import Psatz.
Require Import Bool.
Require Import Eqdep_dec.
-Require Import Fcore.
-Require Import Fcore_digits.
-Require Import Fcalc_digits.
-Require Import Fcalc_ops.
-Require Import Fcalc_round.
-Require Import Fcalc_bracket.
-Require Import Fprop_Sterbenz.
-Require Import Fappli_IEEE.
-Require Import Fappli_rnd_odd.
+(*From Flocq *)
+Require Import Core Digits Operations Round Bracket Sterbenz Binary Round_odd.
Local Open Scope Z_scope.
@@ -65,7 +58,7 @@ Definition is_finite_pos0 (f: binary_float) : bool :=
match f with
| B754_zero _ _ s => negb s
| B754_infinity _ _ _ => false
- | B754_nan _ _ _ _ => false
+ | B754_nan _ _ _ _ _ => false
| B754_finite _ _ _ _ _ _ => true
end.
@@ -74,10 +67,10 @@ Lemma Bsign_pos0:
Proof.
intros. destruct x as [ [] | | | [] ex mx Bx ]; try discriminate; simpl.
- rewrite Rlt_bool_false; auto. lra.
-- rewrite Rlt_bool_true; auto. apply F2R_lt_0_compat. compute; auto.
+- rewrite Rlt_bool_true; auto. apply F2R_lt_0. compute; auto.
- rewrite Rlt_bool_false; auto.
assert ((F2R (Float radix2 (Z.pos ex) mx) > 0)%R) by
- ( apply F2R_gt_0_compat; compute; auto ).
+ ( apply F2R_gt_0; compute; auto ).
lra.
Qed.
@@ -101,18 +94,18 @@ Proof.
assert (UIP_bool: forall (b1 b2: bool) (e e': b1 = b2), e = e').
{ intros. apply UIP_dec. decide equality. }
Ltac try_not_eq := try solve [right; congruence].
- destruct f1 as [| |? []|], f2 as [| |? []|];
- try destruct b; try destruct b0;
+ destruct f1 as [s1|s1|s1 p1 H1|s1 m1 e1 H1], f2 as [s2|s2|s2 p2 H2|s2 m2 e2 H2];
+ try destruct s1; try destruct s2;
try solve [left; auto]; try_not_eq.
- destruct (Pos.eq_dec x x0); try_not_eq;
+ destruct (Pos.eq_dec p1 p2); try_not_eq;
subst; left; f_equal; f_equal; apply UIP_bool.
- destruct (Pos.eq_dec x x0); try_not_eq;
+ destruct (Pos.eq_dec p1 p2); try_not_eq;
subst; left; f_equal; f_equal; apply UIP_bool.
- destruct (Pos.eq_dec m m0); try_not_eq;
- destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence];
+ destruct (Pos.eq_dec m1 m2); try_not_eq;
+ destruct (Z.eq_dec e1 e2); try solve [right; intro H; inversion H; congruence];
subst; left; f_equal; apply UIP_bool.
- destruct (Pos.eq_dec m m0); try_not_eq;
- destruct (Z.eq_dec e e1); try solve [right; intro H; inversion H; congruence];
+ destruct (Pos.eq_dec m1 m2); try_not_eq;
+ destruct (Z.eq_dec e1 e2); try solve [right; intro H; inversion H; congruence];
subst; left; f_equal; apply UIP_bool.
Defined.
@@ -121,7 +114,7 @@ Defined.
(** Integers that can be represented exactly as FP numbers. *)
Definition integer_representable (n: Z): Prop :=
- Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (Z2R n).
+ Z.abs n <= 2^emax - 2^(emax - prec) /\ generic_format radix2 fexp (IZR n).
Let int_upper_bound_eq: 2^emax - 2^(emax - prec) = (2^prec - 1) * 2^(emax - prec).
Proof.
@@ -142,9 +135,9 @@ Proof.
rewrite Z.abs_mul. f_equal. rewrite Z.abs_eq. auto. apply (Zpower_ge_0 radix2).
- apply generic_format_FLT. exists (Float radix2 n p).
unfold F2R; simpl.
- split. rewrite <- Z2R_Zpower by auto. apply Z2R_mult.
- split. zify; omega.
- unfold emin; red in prec_gt_0_; omega.
+ rewrite <- IZR_Zpower by auto. apply mult_IZR.
+ simpl; zify; omega.
+ unfold emin, Fexp; red in prec_gt_0_; omega.
Qed.
Lemma integer_representable_2p:
@@ -166,16 +159,16 @@ Proof.
- red in prec_gt_0_.
apply generic_format_FLT. exists (Float radix2 1 p).
unfold F2R; simpl.
- split. rewrite Rmult_1_l. rewrite <- Z2R_Zpower. auto. omega.
- split. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto.
- unfold emin; omega.
+ rewrite Rmult_1_l. rewrite <- IZR_Zpower. auto. omega.
+ simpl Z.abs. change 1 with (2^0). apply (Zpower_lt radix2). omega. auto.
+ unfold emin, Fexp; omega.
Qed.
Lemma integer_representable_opp:
forall n, integer_representable n -> integer_representable (-n).
Proof.
intros n (A & B); split. rewrite Z.abs_opp. auto.
- rewrite Z2R_opp. apply generic_format_opp; auto.
+ rewrite opp_IZR. apply generic_format_opp; auto.
Qed.
Lemma integer_representable_n2p_wide:
@@ -204,19 +197,20 @@ Qed.
Lemma round_int_no_overflow:
forall n,
Z.abs n <= 2^emax - 2^(emax-prec) ->
- (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n)) < bpow radix2 emax)%R.
+ (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n)) < bpow radix2 emax)%R.
Proof.
intros. red in prec_gt_0_.
rewrite <- round_NE_abs.
- apply Rle_lt_trans with (Z2R (2^emax - 2^(emax-prec))).
+ apply Rle_lt_trans with (IZR (2^emax - 2^(emax-prec))).
apply round_le_generic. apply fexp_correct; auto. apply valid_rnd_N.
apply generic_format_FLT. exists (Float radix2 (2^prec-1) (emax-prec)).
rewrite int_upper_bound_eq. unfold F2R; simpl.
- split. rewrite <- Z2R_Zpower by omega. rewrite <- Z2R_mult. auto.
- split. assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega). zify; omega.
- unfold emin; omega.
- rewrite <- Z2R_abs. apply Z2R_le. auto.
- rewrite <- Z2R_Zpower by omega. apply Z2R_lt. simpl.
+ rewrite <- IZR_Zpower by omega. rewrite <- mult_IZR. auto.
+ assert (0 < 2^prec) by (apply (Zpower_gt_0 radix2); omega).
+ unfold Fnum; simpl; zify; omega.
+ unfold emin, Fexp; omega.
+ rewrite <- abs_IZR. apply IZR_le. auto.
+ rewrite <- IZR_Zpower by omega. apply IZR_lt. simpl.
assert (0 < 2^(emax-prec)) by (apply (Zpower_gt_0 radix2); omega).
omega.
apply fexp_correct. auto.
@@ -229,9 +223,9 @@ Definition BofZ (n: Z) : binary_float :=
Theorem BofZ_correct:
forall n,
- if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (Z2R n))) (bpow radix2 emax)
+ if Rlt_bool (Rabs (round radix2 fexp (round_mode mode_NE) (IZR n))) (bpow radix2 emax)
then
- B2R prec emax (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n) /\
+ B2R prec emax (BofZ n) = round radix2 fexp (round_mode mode_NE) (IZR n) /\
is_finite _ _ (BofZ n) = true /\
Bsign prec emax (BofZ n) = Z.ltb n 0
else
@@ -240,24 +234,24 @@ Proof.
intros.
generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
fold emin; fold fexp; fold (BofZ n).
- replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n).
+ replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n).
destruct Rlt_bool.
- intros (A & B & C). split; [|split].
+ auto.
+ auto.
- + rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
+ + rewrite C. rewrite Rcompare_IZR.
unfold Z.ltb. auto.
-- intros A; rewrite A. f_equal. change 0%R with (Z2R 0).
+- intros A; rewrite A. f_equal.
generalize (Z.ltb_spec n 0); intros SPEC; inversion SPEC.
- apply Rlt_bool_true; apply Z2R_lt; auto.
- apply Rlt_bool_false; apply Z2R_le; auto.
+ apply Rlt_bool_true; apply IZR_lt; auto.
+ apply Rlt_bool_false; apply IZR_le; auto.
- unfold F2R; simpl. ring.
Qed.
Theorem BofZ_finite:
forall n,
Z.abs n <= 2^emax - 2^(emax-prec) ->
- B2R _ _ (BofZ n) = round radix2 fexp (round_mode mode_NE) (Z2R n)
+ B2R _ _ (BofZ n) = round radix2 fexp (round_mode mode_NE) (IZR n)
/\ is_finite _ _ (BofZ n) = true
/\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z.
Proof.
@@ -269,7 +263,7 @@ Qed.
Theorem BofZ_representable:
forall n,
integer_representable n ->
- B2R _ _ (BofZ n) = Z2R n
+ B2R _ _ (BofZ n) = IZR n
/\ is_finite _ _ (BofZ n) = true
/\ Bsign _ _ (BofZ n) = (n <? 0).
Proof.
@@ -280,7 +274,7 @@ Qed.
Theorem BofZ_exact:
forall n,
-2^prec <= n <= 2^prec ->
- B2R _ _ (BofZ n) = Z2R n
+ B2R _ _ (BofZ n) = IZR n
/\ is_finite _ _ (BofZ n) = true
/\ Bsign _ _ (BofZ n) = Z.ltb n 0%Z.
Proof.
@@ -294,20 +288,19 @@ Proof.
intros.
generalize (binary_normalize_correct prec emax prec_gt_0_ Hmax mode_NE n 0 false).
fold emin; fold fexp; fold (BofZ n).
- replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n) by
+ replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n) by
(unfold F2R; simpl; ring).
rewrite Rlt_bool_true by (apply round_int_no_overflow; auto).
intros (A & B & C).
destruct (BofZ n); auto; try discriminate.
- simpl in *. rewrite C. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
+ simpl in *. rewrite C. rewrite Rcompare_IZR.
generalize (Zcompare_spec n 0); intros SPEC; inversion SPEC; auto.
- assert ((round radix2 fexp ZnearestE (Z2R n) <= -1)%R).
- { change (-1)%R with (Z2R (-1)).
- apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N.
+ assert ((round radix2 fexp ZnearestE (IZR n) <= -1)%R).
+ { apply round_le_generic. apply fexp_correct. auto. apply valid_rnd_N.
apply (integer_representable_opp 1).
apply (integer_representable_2p 0).
red in prec_gt_0_; omega.
- apply Z2R_le; omega.
+ apply IZR_le; omega.
}
lra.
Qed.
@@ -334,13 +327,13 @@ Proof.
destruct (BofZ_representable q) as (D & E & F); auto.
generalize (Bplus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
fold emin; fold fexp.
- rewrite A, D. rewrite <- Z2R_plus.
+ rewrite A, D. rewrite <- plus_IZR.
generalize (BofZ_correct (p + q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
apply B2R_Bsign_inj; auto.
rewrite P, U; auto.
rewrite R, W, C, F.
- change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3.
+ rewrite Rcompare_IZR. unfold Z.ltb at 3.
generalize (Zcompare_spec (p + q) 0); intros SPEC; inversion SPEC; auto.
assert (EITHER: 0 <= p \/ 0 <= q) by omega.
destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2];
@@ -364,13 +357,13 @@ Proof.
destruct (BofZ_representable q) as (D & E & F); auto.
generalize (Bminus_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q) B E).
fold emin; fold fexp.
- rewrite A, D. rewrite <- Z2R_minus.
+ rewrite A, D. rewrite <- minus_IZR.
generalize (BofZ_correct (p - q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
apply B2R_Bsign_inj; auto.
rewrite P, U; auto.
rewrite R, W, C, F.
- change 0%R with (Z2R 0). rewrite Rcompare_Z2R. unfold Z.ltb at 3.
+ rewrite Rcompare_IZR. unfold Z.ltb at 3.
generalize (Zcompare_spec (p - q) 0); intros SPEC; inversion SPEC; auto.
assert (EITHER: 0 <= p \/ q < 0) by omega.
destruct EITHER; [apply andb_false_intro1 | apply andb_false_intro2].
@@ -405,7 +398,7 @@ Proof.
destruct (BofZ_representable q) as (D & E & F); auto.
generalize (Bmult_correct _ _ _ Hmax nan mode_NE (BofZ p) (BofZ q)).
fold emin; fold fexp.
- rewrite A, B, C, D, E, F. rewrite <- Z2R_mult.
+ rewrite A, B, C, D, E, F. rewrite <- mult_IZR.
generalize (BofZ_correct (p * q)). destruct Rlt_bool.
- intros (P & Q & R) (U & V & W).
apply B2R_Bsign_inj; auto.
@@ -431,36 +424,36 @@ Proof.
apply integer_representable_2p. auto.
apply (Zpower_gt_0 radix2).
omega.
-- assert (Z2R x <> 0%R) by (apply (Z2R_neq _ _ n)).
+- assert (IZR x <> 0%R) by (apply (IZR_neq _ _ n)).
destruct (BofZ_finite x H) as (A & B & C).
destruct (BofZ_representable (2^p)) as (D & E & F).
apply integer_representable_2p. auto.
- assert (canonic_exp radix2 fexp (Z2R (x * 2^p)) =
- canonic_exp radix2 fexp (Z2R x) + p).
+ assert (cexp radix2 fexp (IZR (x * 2^p)) =
+ cexp radix2 fexp (IZR x) + p).
{
- unfold canonic_exp, fexp. rewrite Z2R_mult.
- change (2^p) with (radix2^p). rewrite Z2R_Zpower by omega.
- rewrite ln_beta_mult_bpow by auto.
- assert (prec + 1 <= ln_beta radix2 (Z2R x)).
- { rewrite <- (ln_beta_abs radix2 (Z2R x)).
- rewrite <- (ln_beta_bpow radix2 prec).
- apply ln_beta_le.
- apply bpow_gt_0. rewrite <- Z2R_Zpower by (red in prec_gt_0_;omega).
- rewrite <- Z2R_abs. apply Z2R_le; auto. }
+ unfold cexp, fexp. rewrite mult_IZR.
+ change (2^p) with (radix2^p). rewrite IZR_Zpower by omega.
+ rewrite mag_mult_bpow by auto.
+ assert (prec + 1 <= mag radix2 (IZR x)).
+ { rewrite <- (mag_abs radix2 (IZR x)).
+ rewrite <- (mag_bpow radix2 prec).
+ apply mag_le.
+ apply bpow_gt_0. rewrite <- IZR_Zpower by (red in prec_gt_0_;omega).
+ rewrite <- abs_IZR. apply IZR_le; auto. }
unfold FLT_exp.
unfold emin; red in prec_gt_0_; zify; omega.
}
- assert (forall m, round radix2 fexp m (Z2R x) * Z2R (2^p) =
- round radix2 fexp m (Z2R (x * 2^p)))%R.
+ assert (forall m, round radix2 fexp m (IZR x) * IZR (2^p) =
+ round radix2 fexp m (IZR (x * 2^p)))%R.
{
intros. unfold round, scaled_mantissa. rewrite H3.
- rewrite Z2R_mult. rewrite Z.opp_add_distr. rewrite bpow_plus.
- set (a := Z2R x); set (b := bpow radix2 (- canonic_exp radix2 fexp a)).
- replace (a * Z2R (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R.
+ rewrite mult_IZR. rewrite Z.opp_add_distr. rewrite bpow_plus.
+ set (a := IZR x); set (b := bpow radix2 (- cexp radix2 fexp a)).
+ replace (a * IZR (2^p) * (b * bpow radix2 (-p)))%R with (a * b)%R.
unfold F2R; simpl. rewrite Rmult_assoc. f_equal.
- rewrite bpow_plus. f_equal. apply (Z2R_Zpower radix2). omega.
- transitivity ((a * b) * (Z2R (2^p) * bpow radix2 (-p)))%R.
- rewrite (Z2R_Zpower radix2). rewrite <- bpow_plus.
+ rewrite bpow_plus. f_equal. apply (IZR_Zpower radix2). omega.
+ transitivity ((a * b) * (IZR (2^p) * bpow radix2 (-p)))%R.
+ rewrite (IZR_Zpower radix2). rewrite <- bpow_plus.
replace (p + -p) with 0 by omega. change (bpow radix2 0) with 1%R. ring.
omega.
ring.
@@ -502,7 +495,7 @@ Lemma round_odd_flt:
round radix2 fexp (Znearest choice) (round radix2 (FLT_exp emin' prec') Zrnd_odd x) =
round radix2 fexp (Znearest choice) x.
Proof.
- intros. apply round_odd_prop. auto. apply fexp_correct; auto.
+ intros. apply round_N_odd. auto. apply fexp_correct; auto.
apply exists_NE_FLT. right; omega.
apply FLT_exp_valid. red; omega.
apply exists_NE_FLT. right; omega.
@@ -519,17 +512,17 @@ Corollary round_odd_fix:
Proof.
intros. destruct (Req_EM_T x 0%R).
- subst x. rewrite round_0. auto. apply valid_rnd_odd.
-- set (prec' := ln_beta radix2 x - p).
+- set (prec' := mag radix2 x - p).
set (emin' := emin - 2).
- assert (PREC: ln_beta radix2 (bpow radix2 (prec + p + 1)) <= ln_beta radix2 x).
- { rewrite <- (ln_beta_abs radix2 x).
- apply ln_beta_le; auto. apply bpow_gt_0. }
- rewrite ln_beta_bpow in PREC.
- assert (CANON: canonic_exp radix2 (FLT_exp emin' prec') x =
- canonic_exp radix2 (FIX_exp p) x).
+ assert (PREC: mag radix2 (bpow radix2 (prec + p + 1)) <= mag radix2 x).
+ { rewrite <- (mag_abs radix2 x).
+ apply mag_le; auto. apply bpow_gt_0. }
+ rewrite mag_bpow in PREC.
+ assert (CANON: cexp radix2 (FLT_exp emin' prec') x =
+ cexp radix2 (FIX_exp p) x).
{
- unfold canonic_exp, FLT_exp, FIX_exp.
- replace (ln_beta radix2 x - prec') with p by (unfold prec'; omega).
+ unfold cexp, FLT_exp, FIX_exp.
+ replace (mag radix2 x - prec') with p by (unfold prec'; omega).
apply Z.max_l. unfold emin', emin. red in prec_gt_0_; omega.
}
assert (RND: round radix2 (FIX_exp p) Zrnd_odd x =
@@ -549,7 +542,7 @@ Definition int_round_odd (x: Z) (p: Z) :=
Lemma Zrnd_odd_int:
forall n p, 0 <= p ->
- Zrnd_odd (Z2R n * bpow radix2 (-p)) * 2^p =
+ Zrnd_odd (IZR n * bpow radix2 (-p)) * 2^p =
int_round_odd n p.
Proof.
intros.
@@ -561,29 +554,29 @@ Proof.
pose proof (bpow_gt_0 radix2 (-p)).
assert (bpow radix2 p * bpow radix2 (-p) = 1)%R.
{ rewrite <- bpow_plus. replace (p + -p) with 0 by omega. auto. }
- assert (Z2R n * bpow radix2 (-p) = Z2R q + Z2R r * bpow radix2 (-p))%R.
- { rewrite H1. rewrite Z2R_plus, Z2R_mult.
- change (Z2R (2^p)) with (Z2R (radix2^p)).
- rewrite Z2R_Zpower by omega. ring_simplify.
+ assert (IZR n * bpow radix2 (-p) = IZR q + IZR r * bpow radix2 (-p))%R.
+ { rewrite H1. rewrite plus_IZR, mult_IZR.
+ change (IZR (2^p)) with (IZR (radix2^p)).
+ rewrite IZR_Zpower by omega. ring_simplify.
rewrite Rmult_assoc. rewrite H4. ring. }
- assert (0 <= Z2R r < bpow radix2 p)%R.
- { split. change 0%R with (Z2R 0). apply Z2R_le; omega.
- rewrite <- Z2R_Zpower by omega. apply Z2R_lt; tauto. }
- assert (0 <= Z2R r * bpow radix2 (-p) < 1)%R.
+ assert (0 <= IZR r < bpow radix2 p)%R.
+ { split. apply IZR_le; omega.
+ rewrite <- IZR_Zpower by omega. apply IZR_lt; tauto. }
+ assert (0 <= IZR r * bpow radix2 (-p) < 1)%R.
{ generalize (bpow_gt_0 radix2 (-p)). intros.
split. apply Rmult_le_pos; lra.
rewrite <- H4. apply Rmult_lt_compat_r. auto. tauto. }
- assert (Zfloor (Z2R n * bpow radix2 (-p)) = q).
- { apply Zfloor_imp. rewrite H5. rewrite Z2R_plus. change (Z2R 1) with 1%R. lra. }
+ assert (Zfloor (IZR n * bpow radix2 (-p)) = q).
+ { apply Zfloor_imp. rewrite H5. rewrite plus_IZR. lra. }
unfold Zrnd_odd. destruct Req_EM_T.
-- assert (Z2R r * bpow radix2 (-p) = 0)%R.
+- assert (IZR r * bpow radix2 (-p) = 0)%R.
{ rewrite H8 in e. rewrite e in H5. lra. }
apply Rmult_integral in H9. destruct H9; [ | lra ].
- apply (eq_Z2R r 0) in H9. apply <- Z.eqb_eq in H9. rewrite H9. assumption.
-- assert (Z2R r * bpow radix2 (-p) <> 0)%R.
+ apply (eq_IZR r 0) in H9. apply <- Z.eqb_eq in H9. rewrite H9. assumption.
+- assert (IZR r * bpow radix2 (-p) <> 0)%R.
{ rewrite H8 in n0. lra. }
destruct (Z.eqb r 0) eqn:RZ.
- apply Z.eqb_eq in RZ. rewrite RZ in H9. change (Z2R 0) with 0%R in H9.
+ apply Z.eqb_eq in RZ. rewrite RZ in H9.
rewrite Rmult_0_l in H9. congruence.
rewrite Zceil_floor_neq by lra. rewrite H8.
change Zeven with Z.even. rewrite Zodd_even_bool. destruct (Z.even q); auto.
@@ -594,9 +587,9 @@ Lemma int_round_odd_le:
x <= y -> int_round_odd x p <= int_round_odd y p.
Proof.
intros.
- assert (Zrnd_odd (Z2R x * bpow radix2 (-p)) <= Zrnd_odd (Z2R y * bpow radix2 (-p))).
+ assert (Zrnd_odd (IZR x * bpow radix2 (-p)) <= Zrnd_odd (IZR y * bpow radix2 (-p))).
{ apply Zrnd_le. apply valid_rnd_odd. apply Rmult_le_compat_r. apply bpow_ge_0.
- apply Z2R_le; auto. }
+ apply IZR_le; auto. }
rewrite <- ! Zrnd_odd_int by auto.
apply Zmult_le_compat_r. auto. apply (Zpower_ge_0 radix2).
Qed.
@@ -635,14 +628,14 @@ Proof.
destruct (BofZ_finite (int_round_odd x p) YRANGE) as (Y1 & Y2 & Y3).
apply BofZ_finite_equal; auto.
rewrite X1, Y1.
- assert (Z2R (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (Z2R x)).
+ assert (IZR (int_round_odd x p) = round radix2 (FIX_exp p) Zrnd_odd (IZR x)).
{
- unfold round, scaled_mantissa, canonic_exp, FIX_exp.
+ unfold round, scaled_mantissa, cexp, FIX_exp.
rewrite <- Zrnd_odd_int by omega.
- unfold F2R; simpl. rewrite Z2R_mult. f_equal. apply (Z2R_Zpower radix2). omega.
+ unfold F2R; simpl. rewrite mult_IZR. f_equal. apply (IZR_Zpower radix2). omega.
}
rewrite H. symmetry. apply round_odd_fix. auto. omega.
- rewrite <- Z2R_Zpower. rewrite <- Z2R_abs. apply Z2R_le; auto.
+ rewrite <- IZR_Zpower. rewrite <- abs_IZR. apply IZR_le; auto.
red in prec_gt_0_; omega.
Qed.
@@ -704,37 +697,37 @@ Theorem ZofB_correct:
forall f,
ZofB f = if is_finite _ _ f then Some (Ztrunc (B2R _ _ f)) else None.
Proof.
- destruct f; simpl; auto.
-- f_equal. symmetry. apply (Ztrunc_Z2R 0).
+ destruct f as [s|s|s p H|s m e H]; simpl; auto.
+- f_equal. symmetry. apply (Ztrunc_IZR 0).
- destruct e; f_equal.
- + unfold F2R; simpl. rewrite Rmult_1_r. rewrite Ztrunc_Z2R. auto.
- + unfold F2R; simpl. rewrite <- Z2R_mult. rewrite Ztrunc_Z2R. auto.
- + unfold F2R; simpl. rewrite Z2R_cond_Zopp. rewrite <- cond_Ropp_mult_l.
- assert (EQ: forall x, Ztrunc (cond_Ropp b x) = cond_Zopp b (Ztrunc x)).
+ + unfold F2R; simpl. rewrite Rmult_1_r. rewrite Ztrunc_IZR. auto.
+ + unfold F2R; simpl. rewrite <- mult_IZR. rewrite Ztrunc_IZR. auto.
+ + unfold F2R; simpl. rewrite IZR_cond_Zopp. rewrite <- cond_Ropp_mult_l.
+ assert (EQ: forall x, Ztrunc (cond_Ropp s x) = cond_Zopp s (Ztrunc x)).
{
- intros. destruct b; simpl; auto. apply Ztrunc_opp.
+ intros. destruct s; simpl; auto. apply Ztrunc_opp.
}
rewrite EQ. f_equal.
generalize (Zpower_pos_gt_0 2 p (eq_refl _)); intros.
rewrite Ztrunc_floor. symmetry. apply Zfloor_div. omega.
- apply Rmult_le_pos. apply (Z2R_le 0). compute; congruence.
- apply Rlt_le. apply Rinv_0_lt_compat. apply (Z2R_lt 0). auto.
+ apply Rmult_le_pos. apply IZR_le. compute; congruence.
+ apply Rlt_le. apply Rinv_0_lt_compat. apply IZR_lt. auto.
Qed.
(** Interval properties. *)
Remark Ztrunc_range_pos:
- forall x, 0 < Ztrunc x -> (Z2R (Ztrunc x) <= x < Z2R (Ztrunc x + 1)%Z)%R.
+ forall x, 0 < Ztrunc x -> (IZR (Ztrunc x) <= x < IZR (Ztrunc x + 1)%Z)%R.
Proof.
intros.
- rewrite Ztrunc_floor. split. apply Zfloor_lb. rewrite Z2R_plus. apply Zfloor_ub.
+ rewrite Ztrunc_floor. split. apply Zfloor_lb. rewrite plus_IZR. apply Zfloor_ub.
generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE.
auto.
rewrite Ztrunc_ceil in H by lra. unfold Zceil in H.
assert (-x < 0)%R.
- { apply Rlt_le_trans with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
- change 0%R with (Z2R 0). change 1%R with (Z2R 1). rewrite <- Z2R_plus.
- apply Z2R_le. omega. }
+ { apply Rlt_le_trans with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
+ rewrite <- plus_IZR.
+ apply IZR_le. omega. }
lra.
Qed.
@@ -744,32 +737,32 @@ Proof.
intros; generalize (Rle_bool_spec 0%R x). intros RLE; inversion RLE; subst; clear RLE.
- rewrite Ztrunc_floor in H by auto. split.
+ apply Rlt_le_trans with 0%R; auto. rewrite <- Ropp_0. apply Ropp_lt_contravar. apply Rlt_0_1.
- + replace 1%R with (Z2R (Zfloor x) + 1)%R. apply Zfloor_ub. rewrite H. simpl. apply Rplus_0_l.
+ + replace 1%R with (IZR (Zfloor x) + 1)%R. apply Zfloor_ub. rewrite H. simpl. apply Rplus_0_l.
- rewrite Ztrunc_ceil in H by (apply Rlt_le; auto). split.
+ apply (Ropp_lt_cancel (-(1))). rewrite Ropp_involutive.
- replace 1%R with (Z2R (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
+ replace 1%R with (IZR (Zfloor (-x)) + 1)%R. apply Zfloor_ub.
unfold Zceil in H. replace (Zfloor (-x)) with 0 by omega. simpl. apply Rplus_0_l.
+ apply Rlt_le_trans with 0%R; auto. apply Rle_0_1.
Qed.
Theorem ZofB_range_pos:
- forall f n, ZofB f = Some n -> 0 < n -> (Z2R n <= B2R _ _ f < Z2R (n + 1)%Z)%R.
+ forall f n, ZofB f = Some n -> 0 < n -> (IZR n <= B2R _ _ f < IZR (n + 1)%Z)%R.
Proof.
intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H.
apply Ztrunc_range_pos. congruence.
Qed.
Theorem ZofB_range_neg:
- forall f n, ZofB f = Some n -> n < 0 -> (Z2R (n - 1)%Z < B2R _ _ f <= Z2R n)%R.
+ forall f n, ZofB f = Some n -> n < 0 -> (IZR (n - 1)%Z < B2R _ _ f <= IZR n)%R.
Proof.
intros. rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; inversion H.
set (x := B2R prec emax f) in *. set (y := (-x)%R).
- assert (A: (Z2R (Ztrunc y) <= y < Z2R (Ztrunc y + 1)%Z)%R).
+ assert (A: (IZR (Ztrunc y) <= y < IZR (Ztrunc y + 1)%Z)%R).
{ apply Ztrunc_range_pos. unfold y. rewrite Ztrunc_opp. omega. }
destruct A as [B C].
unfold y in B, C. rewrite Ztrunc_opp in B, C.
replace (- Ztrunc x + 1) with (- (Ztrunc x - 1)) in C by omega.
- rewrite Z2R_opp in B, C. lra.
+ rewrite opp_IZR in B, C. lra.
Qed.
Theorem ZofB_range_zero:
@@ -780,13 +773,13 @@ Proof.
Qed.
Theorem ZofB_range_nonneg:
- forall f n, ZofB f = Some n -> 0 <= n -> (-1 < B2R _ _ f < Z2R (n + 1)%Z)%R.
+ forall f n, ZofB f = Some n -> 0 <= n -> (-1 < B2R _ _ f < IZR (n + 1)%Z)%R.
Proof.
intros. destruct (Z.eq_dec n 0).
- subst n. apply ZofB_range_zero. auto.
- destruct (ZofB_range_pos f n) as (A & B). auto. omega.
- split; auto. apply Rlt_le_trans with (Z2R 0). simpl; lra.
- apply Rle_trans with (Z2R n); auto. apply Z2R_le; auto.
+ split; auto. apply Rlt_le_trans with 0%R. simpl; lra.
+ apply Rle_trans with (IZR n); auto. apply IZR_le; auto.
Qed.
(** For representable integers, [ZofB] is left inverse of [BofZ]. *)
@@ -795,35 +788,35 @@ Theorem ZofBofZ_exact:
forall n, integer_representable n -> ZofB (BofZ n) = Some n.
Proof.
intros. destruct (BofZ_representable n H) as (A & B & C).
- rewrite ZofB_correct. rewrite A, B. f_equal. apply Ztrunc_Z2R.
+ rewrite ZofB_correct. rewrite A, B. f_equal. apply Ztrunc_IZR.
Qed.
(** Compatibility with subtraction *)
Remark Zfloor_minus:
- forall x n, Zfloor (x - Z2R n) = Zfloor x - n.
+ forall x n, Zfloor (x - IZR n) = Zfloor x - n.
Proof.
intros. apply Zfloor_imp. replace (Zfloor x - n + 1) with ((Zfloor x + 1) - n) by omega.
- rewrite ! Z2R_minus. unfold Rminus. split.
+ rewrite ! minus_IZR. unfold Rminus. split.
apply Rplus_le_compat_r. apply Zfloor_lb.
- apply Rplus_lt_compat_r. rewrite Z2R_plus. apply Zfloor_ub.
+ apply Rplus_lt_compat_r. rewrite plus_IZR. apply Zfloor_ub.
Qed.
Theorem ZofB_minus:
forall minus_nan m f p q,
- ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R ->
+ ZofB f = Some p -> 0 <= p < 2*q -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R ->
ZofB (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) = Some (p - q).
Proof.
intros.
assert (Q: -2^prec <= q <= 2^prec).
{ split; auto. generalize (Zpower_ge_0 radix2 prec); simpl; omega. }
- assert (RANGE: (-1 < B2R _ _ f < Z2R (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega).
+ assert (RANGE: (-1 < B2R _ _ f < IZR (p + 1)%Z)%R) by (apply ZofB_range_nonneg; auto; omega).
rewrite ZofB_correct in H. destruct (is_finite prec emax f) eqn:FIN; try discriminate.
- assert (PQ2: (Z2R (p + 1) <= Z2R q * 2)%R).
- { change 2%R with (Z2R 2). rewrite <- Z2R_mult. apply Z2R_le. omega. }
- assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - Z2R q)%R = (B2R _ _ f - Z2R q)%R).
+ assert (PQ2: (IZR (p + 1) <= IZR q * 2)%R).
+ { rewrite <- mult_IZR. apply IZR_le. omega. }
+ assert (EXACT: round radix2 fexp (round_mode m) (B2R _ _ f - IZR q)%R = (B2R _ _ f - IZR q)%R).
{ apply round_generic. apply valid_rnd_round_mode.
- apply sterbenz_aux. apply FLT_exp_monotone. apply generic_format_B2R.
+ apply sterbenz_aux. now apply FLT_exp_valid. apply FLT_exp_monotone. apply generic_format_B2R.
apply integer_representable_n. auto. lra. }
destruct (BofZ_exact q Q) as (A & B & C).
generalize (Bminus_correct _ _ _ Hmax minus_nan m f (BofZ q) FIN B).
@@ -834,8 +827,8 @@ Proof.
lra. lra.
- rewrite A. fold emin; fold fexp. rewrite EXACT.
apply Rle_lt_trans with (bpow radix2 prec).
- apply Rle_trans with (Z2R q). apply Rabs_le. lra.
- rewrite <- Z2R_Zpower. apply Z2R_le; auto. red in prec_gt_0_; omega.
+ apply Rle_trans with (IZR q). apply Rabs_le. lra.
+ rewrite <- IZR_Zpower. apply IZR_le; auto. red in prec_gt_0_; omega.
apply bpow_lt. auto.
Qed.
@@ -875,7 +868,7 @@ Qed.
Theorem ZofB_range_minus:
forall minus_nan m f p q,
- ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (Z2R q <= B2R _ _ f)%R ->
+ ZofB_range f 0 (2 * q - 1) = Some p -> q <= 2^prec -> (IZR q <= B2R _ _ f)%R ->
ZofB_range (Bminus _ _ _ Hmax minus_nan m f (BofZ q)) (-q) (q - 1) = Some (p - q).
Proof.
intros. destruct (ZofB_range_inversion _ _ _ _ H) as (A & B & C).
@@ -897,11 +890,11 @@ Proof.
intros until y; intros NAN.
pose proof (Bplus_correct _ _ _ Hmax plus_nan mode x y).
pose proof (Bplus_correct _ _ _ Hmax plus_nan mode y x).
- unfold Bplus in *; destruct x; destruct y; auto.
-- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB; auto.
+ unfold Bplus in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto.
+- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB; auto.
f_equal; apply eqb_prop; auto.
- rewrite NAN; auto.
-- rewrite (eqb_sym b0 b). destruct (eqb b b0) eqn:EQB.
+- rewrite (eqb_sym sy sx). destruct (eqb sx sy) eqn:EQB.
f_equal; apply eqb_prop; auto.
rewrite NAN; auto.
- rewrite NAN; auto.
@@ -913,8 +906,8 @@ Proof.
- generalize (H (eq_refl _) (eq_refl _)); clear H.
generalize (H0 (eq_refl _) (eq_refl _)); clear H0.
fold emin. fold fexp.
- set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x).
- set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y).
+ set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x).
+ set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y).
rewrite (Rplus_comm ry rx). destruct Rlt_bool.
+ intros (A1 & A2 & A3) (B1 & B2 & B3).
apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
@@ -930,31 +923,31 @@ Proof.
intros until y; intros NAN.
pose proof (Bmult_correct _ _ _ Hmax mult_nan mode x y).
pose proof (Bmult_correct _ _ _ Hmax mult_nan mode y x).
- unfold Bmult in *; destruct x; destruct y; auto.
-- rewrite (xorb_comm b0 b); auto.
+ unfold Bmult in *; destruct x as [sx|sx|sx px Hx|sx mx ex Hx]; destruct y as [sy|sy|sy py Hy|sy my ey Hy]; auto.
+- rewrite (xorb_comm sx sy); auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
-- rewrite (xorb_comm b0 b); auto.
+- rewrite (xorb_comm sx sy); auto.
- rewrite NAN; auto.
-- rewrite (xorb_comm b0 b); auto.
+- rewrite (xorb_comm sx sy); auto.
- rewrite NAN; auto.
-- rewrite (xorb_comm b0 b); auto.
+- rewrite (xorb_comm sx sy); auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
- rewrite NAN; auto.
-- rewrite (xorb_comm b0 b); auto.
-- rewrite (xorb_comm b0 b); auto.
+- rewrite (xorb_comm sx sy); auto.
+- rewrite (xorb_comm sx sy); auto.
- rewrite NAN; auto.
- revert H H0. fold emin. fold fexp.
- set (x := B754_finite prec emax b0 m0 e1 e2). set (rx := B2R _ _ x).
- set (y := B754_finite prec emax b m e e0). set (ry := B2R _ _ y).
+ set (x := B754_finite prec emax sx mx ex Hx). set (rx := B2R _ _ x).
+ set (y := B754_finite prec emax sy my ey Hy). set (ry := B2R _ _ y).
rewrite (Rmult_comm ry rx).
destruct (Rlt_bool (Rabs (round radix2 fexp (round_mode mode) (rx * ry)))
(bpow radix2 emax)).
+ intros (A1 & A2 & A3) (B1 & B2 & B3).
apply B2R_Bsign_inj; auto. rewrite <- B1 in A1. auto.
- rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. apply Pos.mul_comm. apply Z.add_comm.
+ rewrite ! Bsign_FF2B. f_equal. f_equal. apply xorb_comm. now rewrite Pos.mul_comm. apply Z.add_comm.
+ intros A B. apply B2FF_inj. etransitivity. eapply A. rewrite xorb_comm. auto.
Qed.
@@ -973,26 +966,26 @@ Proof.
rewrite A, B, C in H. rewrite xorb_false_r in H.
destruct (is_finite _ _ f) eqn:FIN.
- pose proof (Bplus_correct _ _ _ Hmax plus_nan mode f f FIN FIN). fold emin in H0.
- assert (EQ: (B2R prec emax f * Z2R 2%Z = B2R prec emax f + B2R prec emax f)%R).
- { change (Z2R 2%Z) with 2%R. ring. }
+ assert (EQ: (B2R prec emax f * IZR 2%Z = B2R prec emax f + B2R prec emax f)%R).
+ { ring. }
rewrite <- EQ in H0. destruct Rlt_bool.
+ destruct H0 as (P & Q & R). destruct H as (S & T & U).
apply B2R_Bsign_inj; auto.
rewrite P, S. auto.
rewrite R, U.
- replace 0%R with (0 * Z2R 2%Z)%R by ring. rewrite Rcompare_mult_r.
- rewrite andb_diag, orb_diag. destruct f; try discriminate; simpl.
+ replace 0%R with (0 * 2)%R by ring. rewrite Rcompare_mult_r.
+ rewrite andb_diag, orb_diag. destruct f as [s|s|s p H|s m e H]; try discriminate; simpl.
rewrite Rcompare_Eq by auto. destruct mode; auto.
replace 0%R with (@F2R radix2 {| Fnum := 0%Z; Fexp := e |}).
- rewrite Rcompare_F2R. destruct b; auto.
+ rewrite Rcompare_F2R. destruct s; auto.
unfold F2R. simpl. ring.
- change 0%R with (Z2R 0%Z). apply Z2R_lt. omega.
+ apply IZR_lt. omega.
destruct (Bmult prec emax prec_gt_0_ Hmax mult_nan mode f (BofZ 2)); reflexivity || discriminate.
+ destruct H0 as (P & Q). apply B2FF_inj. rewrite P, H. auto.
-- destruct f; try discriminate.
- + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) eqn:B2; try discriminate; simpl in *.
- assert ((0 = 2)%Z) by (apply eq_Z2R; auto). discriminate.
- subst b0. rewrite xorb_false_r. auto.
+- destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate.
+ + simpl Bplus. rewrite eqb_true. destruct (BofZ 2) as [| | |s2 m2 e2 H2] eqn:B2; try discriminate; simpl in *.
+ assert ((0 = 2)%Z) by (apply eq_IZR; auto). discriminate.
+ subst s2. rewrite xorb_false_r. auto.
auto.
+ unfold Bplus, Bmult. rewrite <- NAN by auto. auto.
Qed.
@@ -1031,7 +1024,7 @@ Remark bounded_Bexact_inverse:
forall e,
emin <= e <= emax - prec <-> bounded prec emax Bexact_inverse_mantissa e = true.
Proof.
- intros. unfold bounded, canonic_mantissa. rewrite andb_true_iff.
+ intros. unfold bounded, canonical_mantissa. rewrite andb_true_iff.
rewrite <- Zeq_is_eq_bool. rewrite <- Zle_is_le_bool.
rewrite Bexact_inverse_mantissa_digits2_pos.
split.
@@ -1063,23 +1056,23 @@ Lemma Bexact_inverse_correct:
/\ B2R _ _ f <> 0%R
/\ Bsign _ _ f' = Bsign _ _ f.
Proof with (try discriminate).
- intros f f' EI. unfold Bexact_inverse in EI. destruct f...
+ intros f f' EI. unfold Bexact_inverse in EI. destruct f as [s|s|s p H|s m e H]...
destruct (Pos.eq_dec m Bexact_inverse_mantissa)...
set (e' := -e - (prec - 1) * 2) in *.
destruct (Z_le_dec emin e')...
destruct (Z_le_dec e' emax)...
inversion EI; clear EI; subst f' m.
split. auto. split. auto. split. unfold B2R. rewrite Bexact_inverse_mantissa_value.
- unfold F2R; simpl. rewrite Z2R_cond_Zopp.
+ unfold F2R; simpl. rewrite IZR_cond_Zopp.
rewrite <- ! cond_Ropp_mult_l.
red in prec_gt_0_.
- replace (Z2R (2 ^ (prec - 1))) with (bpow radix2 (prec - 1))
- by (symmetry; apply (Z2R_Zpower radix2); omega).
+ replace (IZR (2 ^ (prec - 1))) with (bpow radix2 (prec - 1))
+ by (symmetry; apply (IZR_Zpower radix2); omega).
rewrite <- ! bpow_plus.
replace (prec - 1 + e') with (- (prec - 1 + e)) by (unfold e'; omega).
- rewrite bpow_opp. unfold cond_Ropp; destruct b; auto.
+ rewrite bpow_opp. unfold cond_Ropp; destruct s; auto.
rewrite Ropp_inv_permute. auto. apply Rgt_not_eq. apply bpow_gt_0.
- split. simpl. red; intros. apply F2R_eq_0_reg in H. destruct b; simpl in H; discriminate.
+ split. simpl. apply F2R_neq_0. destruct s; simpl in H; discriminate.
auto.
Qed.
@@ -1180,7 +1173,7 @@ Lemma bpow_log_pos:
0 < n ->
(bpow radix2 (n * Z.log2 base)%Z <= bpow base n)%R.
Proof.
- intros. rewrite <- ! Z2R_Zpower. apply Z2R_le; apply Zpower_log; auto.
+ intros. rewrite <- ! IZR_Zpower. apply IZR_le; apply Zpower_log; auto.
omega.
rewrite Z.mul_comm; apply Zmult_gt_0_le_0_compat. omega. apply Z.log2_nonneg.
Qed.
@@ -1202,7 +1195,7 @@ Lemma round_integer_overflow:
forall (base: radix) e m,
0 < e ->
emax <= e * Z.log2 base ->
- (bpow radix2 emax <= round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e))%R.
+ (bpow radix2 emax <= round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e))%R.
Proof.
intros.
rewrite <- (round_generic radix2 fexp (round_mode mode_NE) (bpow radix2 emax)); auto.
@@ -1210,11 +1203,11 @@ Proof.
rewrite <- (Rmult_1_l (bpow radix2 emax)). apply Rmult_le_compat.
apply Rle_0_1.
apply bpow_ge_0.
- apply (Z2R_le 1). zify; omega.
+ apply IZR_le. zify; omega.
eapply Rle_trans. eapply bpow_le. eassumption. apply bpow_log_pos; auto.
apply generic_format_FLT. exists (Float radix2 1 emax).
- split. unfold F2R; simpl. ring.
- split. simpl. apply (Zpower_gt_1 radix2); auto.
+ unfold F2R; simpl. ring.
+ simpl. apply (Zpower_gt_1 radix2); auto.
simpl. unfold emin; red in prec_gt_0_; omega.
Qed.
@@ -1227,15 +1220,15 @@ Proof.
set (eps := bpow radix2 (emin - 1)) in *.
assert (A: round radix2 fexp (round_mode mode_NE) eps = 0%R).
{ unfold round. simpl.
- assert (E: canonic_exp radix2 fexp eps = emin).
- { unfold canonic_exp, eps. rewrite ln_beta_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. }
+ assert (E: cexp radix2 fexp eps = emin).
+ { unfold cexp, eps. rewrite mag_bpow. unfold fexp, FLT_exp. zify; red in prec_gt_0_; omega. }
unfold scaled_mantissa; rewrite E.
assert (P: (eps * bpow radix2 (-emin) = / 2)%R).
{ unfold eps. rewrite <- bpow_plus. replace (emin - 1 + -emin) with (-1) by omega. auto. }
rewrite P. unfold Znearest.
assert (F: Zfloor (/ 2)%R = 0).
{ apply Zfloor_imp. simpl. lra. }
- rewrite F. change (Z2R 0) with 0%R. rewrite Rminus_0_r. rewrite Rcompare_Eq by auto.
+ rewrite F. rewrite Rminus_0_r. rewrite Rcompare_Eq by auto.
simpl. unfold F2R; simpl. apply Rmult_0_l.
}
apply Rle_antisym.
@@ -1248,15 +1241,15 @@ Lemma round_integer_underflow:
forall (base: radix) e m,
e < 0 ->
e * Z.log2 base + Z.log2_up (Zpos m) < emin ->
- round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) = 0%R.
+ round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e) = 0%R.
Proof.
intros. apply round_NE_underflows. split.
-- apply Rmult_le_pos. apply (Z2R_le 0). zify; omega. apply bpow_ge_0.
+- apply Rmult_le_pos. apply IZR_le. zify; omega. apply bpow_ge_0.
- apply Rle_trans with (bpow radix2 (Z.log2_up (Z.pos m) + e * Z.log2 base)).
+ rewrite bpow_plus. apply Rmult_le_compat.
- apply (Z2R_le 0); zify; omega.
+ apply IZR_le; zify; omega.
apply bpow_ge_0.
- rewrite <- Z2R_Zpower. apply Z2R_le.
+ rewrite <- IZR_Zpower. apply IZR_le.
destruct (Z.eq_dec (Z.pos m) 1).
rewrite e0. simpl. omega.
apply Z.log2_up_spec. zify; omega.
@@ -1270,7 +1263,7 @@ Qed.
Theorem Bparse_correct:
forall b m e (BASE: 2 <= Zpos b),
let base := {| radix_val := Zpos b; radix_prop := Zle_imp_le_bool _ _ BASE |} in
- let r := round radix2 fexp (round_mode mode_NE) (Z2R (Zpos m) * bpow base e) in
+ let r := round radix2 fexp (round_mode mode_NE) (IZR (Zpos m) * bpow base e) in
if Rlt_bool (Rabs r) (bpow radix2 emax) then
B2R _ _ (Bparse b m e) = r
/\ is_finite _ _ (Bparse b m e) = true
@@ -1279,7 +1272,7 @@ Theorem Bparse_correct:
B2FF _ _ (Bparse b m e) = F754_infinity false.
Proof.
intros.
- assert (A: forall x, @F2R radix2 {| Fnum := x; Fexp := 0 |} = Z2R x).
+ assert (A: forall x, @F2R radix2 {| Fnum := x; Fexp := 0 |} = IZR x).
{ intros. unfold F2R, Fnum; simpl. ring. }
unfold Bparse, r. destruct e as [ | e | e].
- (* e = Z0 *)
@@ -1288,7 +1281,7 @@ Proof.
- (* e = Zpos e *)
destruct (Z.ltb_spec (Z.pos e * Z.log2 (Z.pos b)) emax).
+ (* no overflow *)
- rewrite pos_pow_spec. rewrite <- Z2R_Zpower by (zify; omega). rewrite <- Z2R_mult.
+ rewrite pos_pow_spec. rewrite <- IZR_Zpower by (zify; omega). rewrite <- mult_IZR.
replace false with (Z.pos m * Z.pos b ^ Z.pos e <? 0).
exact (BofZ_correct (Z.pos m * Z.pos b ^ Z.pos e)).
rewrite Z.ltb_ge. rewrite Z.mul_comm. apply Zmult_gt_0_le_0_compat. zify; omega. apply (Zpower_ge_0 base).
@@ -1300,25 +1293,21 @@ Proof.
+ (* undeflow *)
rewrite round_integer_underflow; auto.
rewrite Rlt_bool_true. auto.
- replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (Z2R_abs 0).
+ replace (Rabs 0)%R with 0%R. apply bpow_gt_0. apply (abs_IZR 0).
zify; omega.
+ (* no underflow *)
generalize (Bdiv_correct_aux prec emax prec_gt_0_ Hmax mode_NE false m 0 false (pos_pow b e) 0).
- set (f := match Fdiv_core_binary prec (Z.pos m) 0 (Z.pos (pos_pow b e)) 0 with
- | (0, _, _) => F754_nan false 1
- | (Z.pos mz0, ez, lz) =>
- binary_round_aux prec emax mode_NE (xorb false false) mz0 ez lz
- | (Z.neg _, _, _) => F754_nan false 1
- end).
+ set (f := let '(mz, ez, lz) := Fdiv_core_binary prec emax (Z.pos m) 0 (Z.pos (pos_pow b e)) 0
+ in binary_round_aux prec emax mode_NE (xorb false false) mz ez lz).
fold emin; fold fexp. rewrite ! A. unfold cond_Zopp. rewrite pos_pow_spec.
- assert (B: (Z2R (Z.pos m) / Z2R (Z.pos b ^ Z.pos e) =
- Z2R (Z.pos m) * bpow base (Z.neg e))%R).
+ assert (B: (IZR (Z.pos m) / IZR (Z.pos b ^ Z.pos e) =
+ IZR (Z.pos m) * bpow base (Z.neg e))%R).
{ change (Z.neg e) with (- (Z.pos e)). rewrite bpow_opp. auto. }
rewrite B. intros [P Q].
destruct (Rlt_bool
(Rabs
(round radix2 fexp (round_mode mode_NE)
- (Z2R (Z.pos m) * bpow base (Z.neg e))))
+ (IZR (Z.pos m) * bpow base (Z.neg e))))
(bpow radix2 emax)).
* destruct Q as (Q1 & Q2 & Q3).
split. rewrite B2R_FF2B, Q1. auto.
@@ -1344,9 +1333,9 @@ Hypothesis Hmax2 : (prec2 < emax2)%Z.
Let binary_float1 := binary_float prec1 emax1.
Let binary_float2 := binary_float prec2 emax2.
-Definition Bconv (conv_nan: bool -> nan_pl prec1 -> bool * nan_pl prec2) (md: mode) (f: binary_float1) : binary_float2 :=
+Definition Bconv (conv_nan: binary_float1 -> {x | is_nan prec2 emax2 x = true}) (md: mode) (f: binary_float1) : binary_float2 :=
match f with
- | B754_nan _ _ s pl => let '(s, pl) := conv_nan s pl in B754_nan _ _ s pl
+ | B754_nan _ _ _ _ _ => build_nan prec2 emax2 (conv_nan f)
| B754_infinity _ _ s => B754_infinity _ _ s
| B754_zero _ _ s => B754_zero _ _ s
| B754_finite _ _ s m e _ => binary_normalize _ _ _ Hmax2 md (cond_Zopp s (Zpos m)) e s
@@ -1363,18 +1352,18 @@ Theorem Bconv_correct:
else
B2FF _ _ (Bconv conv_nan m f) = binary_overflow prec2 emax2 m (Bsign _ _ f).
Proof.
- intros. destruct f; try discriminate.
+ intros. destruct f as [sf|sf|sf pf Hf|sf mf ef Hf]; try discriminate.
- simpl. rewrite round_0. rewrite Rabs_R0. rewrite Rlt_bool_true. auto.
apply bpow_gt_0. apply valid_rnd_round_mode.
-- generalize (binary_normalize_correct _ _ _ Hmax2 m (cond_Zopp b (Zpos m0)) e b).
+- generalize (binary_normalize_correct _ _ _ Hmax2 m (cond_Zopp sf (Zpos mf)) ef sf).
fold emin2; fold fexp2. simpl. destruct Rlt_bool.
+ intros (A & B & C). split. auto. split. auto. rewrite C.
- destruct b; simpl.
- rewrite Rcompare_Lt. auto. apply F2R_lt_0_compat. simpl. compute; auto.
- rewrite Rcompare_Gt. auto. apply F2R_gt_0_compat. simpl. compute; auto.
- + intros A. rewrite A. f_equal. destruct b.
- apply Rlt_bool_true. apply F2R_lt_0_compat. simpl. compute; auto.
- apply Rlt_bool_false. apply Rlt_le. apply Rgt_lt. apply F2R_gt_0_compat. simpl. compute; auto.
+ destruct sf; simpl.
+ rewrite Rcompare_Lt. auto. apply F2R_lt_0. simpl. compute; auto.
+ rewrite Rcompare_Gt. auto. apply F2R_gt_0. simpl. compute; auto.
+ + intros A. rewrite A. f_equal. destruct sf.
+ apply Rlt_bool_true. apply F2R_lt_0. simpl. compute; auto.
+ apply Rlt_bool_false. apply Rlt_le. apply Rgt_lt. apply F2R_gt_0. simpl. compute; auto.
Qed.
(** Converting a finite FP number to higher or equal precision preserves its value. *)
@@ -1421,15 +1410,15 @@ Proof.
unfold BofZ.
generalize (binary_normalize_correct _ _ _ Hmax2 mode_NE n 0 false).
fold emin2; fold fexp2. rewrite A.
- replace (F2R {| Fnum := n; Fexp := 0 |}) with (Z2R n).
+ replace (F2R {| Fnum := n; Fexp := 0 |}) with (IZR n).
destruct Rlt_bool.
- intros (P & Q & R) (D & E & F). apply B2R_Bsign_inj; auto.
- congruence. rewrite F, C, R. change 0%R with (Z2R 0). rewrite Rcompare_Z2R.
+ congruence. rewrite F, C, R. rewrite Rcompare_IZR.
unfold Z.ltb. auto.
-- intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal. change 0%R with (Z2R 0).
+- intros P Q. apply B2FF_inj. rewrite P, Q. rewrite C. f_equal.
generalize (Zlt_bool_spec n 0); intros LT; inversion LT.
- rewrite Rlt_bool_true; auto. apply Z2R_lt; auto.
- rewrite Rlt_bool_false; auto. apply Z2R_le; auto.
+ rewrite Rlt_bool_true; auto. apply IZR_lt; auto.
+ rewrite Rlt_bool_false; auto. apply IZR_le; auto.
- unfold F2R; simpl. rewrite Rmult_1_r. auto.
Qed.
@@ -1472,19 +1461,15 @@ Proof.
rewrite ! Bcompare_correct by auto. rewrite A, D. auto.
- generalize (Bconv_widen_exact H H0 conv_nan m x)
(Bconv_widen_exact H H0 conv_nan m y); intros P Q.
- destruct x, y; try discriminate; simpl in P, Q; simpl;
+ destruct x as [sx|sx|sx px Hx|sx mx ex Hx], y as [sy|sy|sy py Hy|sy my ey Hy]; try discriminate; simpl in P, Q; simpl;
repeat (match goal with |- context [conv_nan ?b ?pl] => destruct (conv_nan b pl) end);
auto.
destruct Q as (D & E & F); auto.
- destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b0 (Z.pos m0)) e b0);
- discriminate || reflexivity.
+ now destruct binary_normalize.
destruct P as (A & B & C); auto.
- destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b);
- try discriminate; simpl. destruct b; auto. destruct b, b1; auto.
+ now destruct binary_normalize.
destruct P as (A & B & C); auto.
- destruct (binary_normalize prec2 emax2 prec2_gt_0_ Hmax2 m (cond_Zopp b (Z.pos m0)) e b);
- try discriminate; simpl. destruct b; auto.
- destruct b, b2; auto.
+ now destruct binary_normalize.
Qed.
End Conversions.
diff --git a/lib/Integers.v b/lib/Integers.v
index 0e506208..246c708c 100644
--- a/lib/Integers.v
+++ b/lib/Integers.v
@@ -4,7 +4,7 @@
(* *)
(* Xavier Leroy, INRIA Paris-Rocquencourt *)
(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
+(* Copyright Institut National de Recherstestche en Informatique et en *)
(* Automatique. All rights reserved. This file is distributed *)
(* under the terms of the GNU General Public License as published by *)
(* the Free Software Foundation, either version 2 of the License, or *)
@@ -16,7 +16,7 @@
(** Formalizations of machine integers modulo $2^N$ #2<sup>N</sup>#. *)
Require Import Eqdep_dec Zquot Zwf.
-Require Import Coqlib.
+Require Import Coqlib Zbits Axioms.
Require Archi.
(** * Comparisons *)
@@ -29,6 +29,11 @@ Inductive comparison : Type :=
| Cgt : comparison (**r greater than *)
| Cge : comparison. (**r greater than or equal *)
+Definition comparison_eq: forall (x y: comparison), {x = y} + {x <> y}.
+Proof.
+ decide equality.
+Defined.
+
Definition negate_comparison (c: comparison): comparison :=
match c with
| Ceq => Cne
@@ -80,11 +85,19 @@ Proof.
unfold modulus. apply two_power_nat_two_p.
Qed.
+Remark modulus_gt_one: modulus > 1.
+Proof.
+ rewrite modulus_power. apply Z.lt_gt. apply (two_p_monotone_strict 0).
+ generalize wordsize_pos; omega.
+Qed.
+
Remark modulus_pos: modulus > 0.
Proof.
- rewrite modulus_power. apply two_p_gt_ZERO. generalize wordsize_pos; omega.
+ generalize modulus_gt_one; omega.
Qed.
+Hint Resolve modulus_pos: ints.
+
(** * Representation of machine integers *)
(** A machine integer (type [int]) is represented as a Coq arbitrary-precision
@@ -95,17 +108,6 @@ Record int: Type := mkint { intval: Z; intrange: -1 < intval < modulus }.
(** Fast normalization modulo [2^wordsize] *)
-Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z :=
- match n with
- | O => 0
- | S m =>
- match p with
- | xH => 1
- | xO q => Z.double (P_mod_two_p q m)
- | xI q => Z.succ_double (P_mod_two_p q m)
- end
- end.
-
Definition Z_mod_modulus (x: Z) : Z :=
match x with
| Z0 => 0
@@ -113,51 +115,9 @@ Definition Z_mod_modulus (x: Z) : Z :=
| Zneg p => let r := P_mod_two_p p wordsize in if zeq r 0 then 0 else modulus - r
end.
-Lemma P_mod_two_p_range:
- forall n p, 0 <= P_mod_two_p p n < two_power_nat n.
-Proof.
- induction n; simpl; intros.
- - rewrite two_power_nat_O. omega.
- - rewrite two_power_nat_S. destruct p.
- + generalize (IHn p). rewrite Z.succ_double_spec. omega.
- + generalize (IHn p). rewrite Z.double_spec. omega.
- + generalize (two_power_nat_pos n). omega.
-Qed.
-
-Lemma P_mod_two_p_eq:
- forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n).
-Proof.
- assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n).
- {
- induction n; simpl; intros.
- - rewrite two_power_nat_O. exists (Zpos p). ring.
- - rewrite two_power_nat_S. destruct p.
- + destruct (IHn p) as [y EQ]. exists y.
- change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ.
- rewrite Z.succ_double_spec. ring.
- + destruct (IHn p) as [y EQ]. exists y.
- change (Zpos p~0) with (2 * Zpos p). rewrite EQ.
- rewrite (Z.double_spec (P_mod_two_p p n)). ring.
- + exists 0; omega.
- }
- intros.
- destruct (H n p) as [y EQ].
- symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range.
-Qed.
-
Lemma Z_mod_modulus_range:
forall x, 0 <= Z_mod_modulus x < modulus.
-Proof.
- intros; unfold Z_mod_modulus.
- destruct x.
- - generalize modulus_pos; intuition.
- - apply P_mod_two_p_range.
- - set (r := P_mod_two_p p wordsize).
- assert (0 <= r < modulus) by apply P_mod_two_p_range.
- destruct (zeq r 0).
- + generalize modulus_pos; intuition.
- + Psatz.lia.
-Qed.
+Proof (Z_mod_two_p_range wordsize).
Lemma Z_mod_modulus_range':
forall x, -1 < Z_mod_modulus x < modulus.
@@ -167,22 +127,7 @@ Qed.
Lemma Z_mod_modulus_eq:
forall x, Z_mod_modulus x = x mod modulus.
-Proof.
- intros. unfold Z_mod_modulus. destruct x.
- - rewrite Zmod_0_l. auto.
- - apply P_mod_two_p_eq.
- - generalize (P_mod_two_p_range wordsize p) (P_mod_two_p_eq wordsize p).
- fold modulus. intros A B.
- exploit (Z_div_mod_eq (Zpos p) modulus). apply modulus_pos. intros C.
- set (q := Zpos p / modulus) in *.
- set (r := P_mod_two_p p wordsize) in *.
- rewrite <- B in C.
- change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0).
- + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia.
- intuition.
- + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia.
- intuition.
-Qed.
+Proof (Z_mod_two_p_eq wordsize).
(** The [unsigned] and [signed] functions return the Coq integer corresponding
to the given machine integer, interpreted as unsigned or signed
@@ -317,63 +262,20 @@ Definition shr_carry (x y: int) : int :=
(** Zero and sign extensions *)
-Definition Zshiftin (b: bool) (x: Z) : Z :=
- if b then Z.succ_double x else Z.double x.
-
-(** In pseudo-code:
-<<
- Fixpoint Zzero_ext (n: Z) (x: Z) : Z :=
- if zle n 0 then
- 0
- else
- Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
- Fixpoint Zsign_ext (n: Z) (x: Z) : Z :=
- if zle n 1 then
- if Z.odd x then -1 else 0
- else
- Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
->>
- We encode this [nat]-like recursion using the [Z.iter] iteration
- function, in order to make the [Zzero_ext] and [Zsign_ext]
- functions efficiently executable within Coq.
-*)
-
-Definition Zzero_ext (n: Z) (x: Z) : Z :=
- Z.iter n
- (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
- (fun x => 0)
- x.
-
-Definition Zsign_ext (n: Z) (x: Z) : Z :=
- Z.iter (Z.pred n)
- (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
- (fun x => if Z.odd x then -1 else 0)
- x.
-
Definition zero_ext (n: Z) (x: int) : int := repr (Zzero_ext n (unsigned x)).
-
Definition sign_ext (n: Z) (x: int) : int := repr (Zsign_ext n (unsigned x)).
(** Decomposition of a number as a sum of powers of two. *)
-Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z :=
- match n with
- | O => nil
- | S m =>
- if Z.odd x
- then i :: Z_one_bits m (Z.div2 x) (i+1)
- else Z_one_bits m (Z.div2 x) (i+1)
- end.
-
Definition one_bits (x: int) : list int :=
List.map repr (Z_one_bits wordsize (unsigned x) 0).
(** Recognition of powers of two. *)
Definition is_power2 (x: int) : option int :=
- match Z_one_bits wordsize (unsigned x) 0 with
- | i :: nil => Some (repr i)
- | _ => None
+ match Z_is_power2 (unsigned x) with
+ | Some i => Some (repr i)
+ | None => None
end.
(** Comparisons. *)
@@ -497,101 +399,7 @@ Qed.
(** ** Modulo arithmetic *)
-(** We define and state properties of equality and arithmetic modulo a
- positive integer. *)
-
-Section EQ_MODULO.
-
-Variable modul: Z.
-Hypothesis modul_pos: modul > 0.
-
-Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y.
-
-Lemma eqmod_refl: forall x, eqmod x x.
-Proof.
- intros; red. exists 0. omega.
-Qed.
-
-Lemma eqmod_refl2: forall x y, x = y -> eqmod x y.
-Proof.
- intros. subst y. apply eqmod_refl.
-Qed.
-
-Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x.
-Proof.
- intros x y [k EQ]; red. exists (-k). subst x. ring.
-Qed.
-
-Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z.
-Proof.
- intros x y z [k1 EQ1] [k2 EQ2]; red.
- exists (k1 + k2). subst x; subst y. ring.
-Qed.
-
-Lemma eqmod_small_eq:
- forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y.
-Proof.
- intros x y [k EQ] I1 I2.
- generalize (Zdiv_unique _ _ _ _ EQ I2). intro.
- rewrite (Zdiv_small x modul I1) in H. subst k. omega.
-Qed.
-
-Lemma eqmod_mod_eq:
- forall x y, eqmod x y -> x mod modul = y mod modul.
-Proof.
- intros x y [k EQ]. subst x.
- rewrite Z.add_comm. apply Z_mod_plus. auto.
-Qed.
-
-Lemma eqmod_mod:
- forall x, eqmod x (x mod modul).
-Proof.
- intros; red. exists (x / modul).
- rewrite Z.mul_comm. apply Z_div_mod_eq. auto.
-Qed.
-
-Lemma eqmod_add:
- forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d).
-Proof.
- intros a b c d [k1 EQ1] [k2 EQ2]; red.
- subst a; subst c. exists (k1 + k2). ring.
-Qed.
-
-Lemma eqmod_neg:
- forall x y, eqmod x y -> eqmod (-x) (-y).
-Proof.
- intros x y [k EQ]; red. exists (-k). rewrite EQ. ring.
-Qed.
-
-Lemma eqmod_sub:
- forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d).
-Proof.
- intros a b c d [k1 EQ1] [k2 EQ2]; red.
- subst a; subst c. exists (k1 - k2). ring.
-Qed.
-
-Lemma eqmod_mult:
- forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d).
-Proof.
- intros a b c d [k1 EQ1] [k2 EQ2]; red.
- subst a; subst b.
- exists (k1 * k2 * modul + c * k2 + k1 * d).
- ring.
-Qed.
-
-End EQ_MODULO.
-
-Lemma eqmod_divides:
- forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y.
-Proof.
- intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2].
- exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto.
-Qed.
-
-(** We then specialize these definitions to equality modulo
- $2^{wordsize}$ #2<sup>wordsize</sup>#. *)
-
-Hint Resolve modulus_pos: ints.
+(** [eqm] is equality modulo $2^{wordsize}$ #2<sup>wordsize</sup>#. *)
Definition eqm := eqmod modulus.
@@ -637,6 +445,19 @@ Lemma eqm_mult:
Proof (eqmod_mult modulus).
Hint Resolve eqm_mult: ints.
+Lemma eqm_same_bits:
+ forall x y,
+ (forall i, 0 <= i < zwordsize -> Z.testbit x i = Z.testbit y i) ->
+ eqm x y.
+Proof (eqmod_same_bits wordsize).
+
+Lemma same_bits_eqm:
+ forall x y i,
+ eqm x y ->
+ 0 <= i < zwordsize ->
+ Z.testbit x i = Z.testbit y i.
+Proof (same_bits_eqmod wordsize).
+
(** ** Properties of the coercions between [Z] and [int] *)
Lemma eqm_samerepr: forall x y, eqm x y -> repr x = repr y.
@@ -706,7 +527,7 @@ Theorem repr_unsigned:
forall i, repr (unsigned i) = i.
Proof.
destruct i; simpl. unfold repr. apply mkint_eq.
- rewrite Z_mod_modulus_eq. apply Zmod_small; omega.
+ rewrite Z_mod_modulus_eq. apply Z.mod_small; omega.
Qed.
Hint Resolve repr_unsigned: ints.
@@ -729,7 +550,7 @@ Theorem unsigned_repr:
forall z, 0 <= z <= max_unsigned -> unsigned (repr z) = z.
Proof.
intros. rewrite unsigned_repr_eq.
- apply Zmod_small. unfold max_unsigned in H. omega.
+ apply Z.mod_small. unfold max_unsigned in H. omega.
Qed.
Hint Resolve unsigned_repr: ints.
@@ -776,7 +597,7 @@ Qed.
Theorem unsigned_one: unsigned one = 1.
Proof.
- unfold one; rewrite unsigned_repr_eq. apply Zmod_small. split. omega.
+ unfold one; rewrite unsigned_repr_eq. apply Z.mod_small. split. omega.
unfold modulus. replace wordsize with (S(Init.Nat.pred wordsize)).
rewrite two_power_nat_S. generalize (two_power_nat_pos (Init.Nat.pred wordsize)).
omega.
@@ -787,7 +608,7 @@ Theorem unsigned_mone: unsigned mone = modulus - 1.
Proof.
unfold mone; rewrite unsigned_repr_eq.
replace (-1) with ((modulus - 1) + (-1) * modulus).
- rewrite Z_mod_plus_full. apply Zmod_small.
+ rewrite Z_mod_plus_full. apply Z.mod_small.
generalize modulus_pos. omega. omega.
Qed.
@@ -819,7 +640,7 @@ Qed.
Theorem unsigned_repr_wordsize:
unsigned iwordsize = zwordsize.
Proof.
- unfold iwordsize; rewrite unsigned_repr_eq. apply Zmod_small.
+ unfold iwordsize; rewrite unsigned_repr_eq. apply Z.mod_small.
generalize wordsize_pos wordsize_max_unsigned; unfold max_unsigned; omega.
Qed.
@@ -852,6 +673,11 @@ Proof.
intros. generalize (eq_spec x y); case (eq x y); intros; congruence.
Qed.
+Theorem same_if_eq: forall x y, eq x y = true -> x = y.
+Proof.
+ intros. generalize (eq_spec x y); rewrite H; auto.
+Qed.
+
Theorem eq_signed:
forall x y, eq x y = if zeq (signed x) (signed y) then true else false.
Proof.
@@ -1298,298 +1124,6 @@ Qed.
(** ** Bit-level properties *)
-(** ** Properties of bit-level operations over [Z] *)
-
-Remark Ztestbit_0: forall n, Z.testbit 0 n = false.
-Proof Z.testbit_0_l.
-
-Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0.
-Proof.
- intros. destruct n; simpl; auto.
-Qed.
-
-Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true.
-Proof.
- intros. destruct n; simpl; auto.
-Qed.
-
-Remark Zshiftin_spec:
- forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0).
-Proof.
- unfold Zshiftin; intros. destruct b.
- - rewrite Z.succ_double_spec. omega.
- - rewrite Z.double_spec. omega.
-Qed.
-
-Remark Zshiftin_inj:
- forall b1 x1 b2 x2,
- Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2.
-Proof.
- intros. rewrite !Zshiftin_spec in H.
- destruct b1; destruct b2.
- split; [auto|omega].
- omegaContradiction.
- omegaContradiction.
- split; [auto|omega].
-Qed.
-
-Remark Zdecomp:
- forall x, x = Zshiftin (Z.odd x) (Z.div2 x).
-Proof.
- intros. destruct x; simpl.
- - auto.
- - destruct p; auto.
- - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto.
-Qed.
-
-Remark Ztestbit_shiftin:
- forall b x n,
- 0 <= n ->
- Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n).
-Proof.
- intros. rewrite Zshiftin_spec. destruct (zeq n 0).
- - subst n. destruct b.
- + apply Z.testbit_odd_0.
- + rewrite Z.add_0_r. apply Z.testbit_even_0.
- - assert (0 <= Z.pred n) by omega.
- set (n' := Z.pred n) in *.
- replace n with (Z.succ n') by (unfold n'; omega).
- destruct b.
- + apply Z.testbit_odd_succ; auto.
- + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto.
-Qed.
-
-Remark Ztestbit_shiftin_base:
- forall b x, Z.testbit (Zshiftin b x) 0 = b.
-Proof.
- intros. rewrite Ztestbit_shiftin. apply zeq_true. omega.
-Qed.
-
-Remark Ztestbit_shiftin_succ:
- forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n.
-Proof.
- intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto.
- omega. omega.
-Qed.
-
-Remark Ztestbit_eq:
- forall n x, 0 <= n ->
- Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n).
-Proof.
- intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto.
-Qed.
-
-Remark Ztestbit_base:
- forall x, Z.testbit x 0 = Z.odd x.
-Proof.
- intros. rewrite Ztestbit_eq. apply zeq_true. omega.
-Qed.
-
-Remark Ztestbit_succ:
- forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n.
-Proof.
- intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto.
- omega. omega.
-Qed.
-
-Lemma eqmod_same_bits:
- forall n x y,
- (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) ->
- eqmod (two_power_nat n) x y.
-Proof.
- induction n; intros.
- - change (two_power_nat 0) with 1. exists (x-y); ring.
- - rewrite two_power_nat_S.
- assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)).
- apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega.
- omega. omega.
- destruct H0 as [k EQ].
- exists k. rewrite (Zdecomp x). rewrite (Zdecomp y).
- replace (Z.odd y) with (Z.odd x).
- rewrite EQ. rewrite !Zshiftin_spec. ring.
- exploit (H 0). rewrite Nat2Z.inj_succ; omega.
- rewrite !Ztestbit_base. auto.
-Qed.
-
-Lemma eqm_same_bits:
- forall x y,
- (forall i, 0 <= i < zwordsize -> Z.testbit x i = Z.testbit y i) ->
- eqm x y.
-Proof (eqmod_same_bits wordsize).
-
-Lemma same_bits_eqmod:
- forall n x y i,
- eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n ->
- Z.testbit x i = Z.testbit y i.
-Proof.
- induction n; intros.
- - simpl in H0. omegaContradiction.
- - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H.
- rewrite !(Ztestbit_eq i); intuition.
- destruct H as [k EQ].
- assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) =
- Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)).
- {
- rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ.
- rewrite EQ. rewrite !Zshiftin_spec. ring.
- }
- exploit Zshiftin_inj; eauto. intros [A B].
- destruct (zeq i 0).
- + auto.
- + apply IHn. exists k; auto. omega.
-Qed.
-
-Lemma same_bits_eqm:
- forall x y i,
- eqm x y ->
- 0 <= i < zwordsize ->
- Z.testbit x i = Z.testbit y i.
-Proof (same_bits_eqmod wordsize).
-
-Remark two_power_nat_infinity:
- forall x, 0 <= x -> exists n, x < two_power_nat n.
-Proof.
- intros x0 POS0; pattern x0; apply natlike_ind; auto.
- exists O. compute; auto.
- intros. destruct H0 as [n LT]. exists (S n). rewrite two_power_nat_S.
- generalize (two_power_nat_pos n). omega.
-Qed.
-
-Lemma equal_same_bits:
- forall x y,
- (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) ->
- x = y.
-Proof.
- intros.
- set (z := if zlt x y then y - x else x - y).
- assert (0 <= z).
- unfold z; destruct (zlt x y); omega.
- exploit (two_power_nat_infinity z); auto. intros [n LT].
- assert (eqmod (two_power_nat n) x y).
- apply eqmod_same_bits. intros. apply H. tauto.
- assert (eqmod (two_power_nat n) z 0).
- unfold z. destruct (zlt x y).
- replace 0 with (y - y) by omega. apply eqmod_sub. apply eqmod_refl. auto.
- replace 0 with (x - x) by omega. apply eqmod_sub. apply eqmod_refl. apply eqmod_sym; auto.
- assert (z = 0).
- apply eqmod_small_eq with (two_power_nat n). auto. omega. generalize (two_power_nat_pos n); omega.
- unfold z in H3. destruct (zlt x y); omega.
-Qed.
-
-Lemma Z_one_complement:
- forall i, 0 <= i ->
- forall x, Z.testbit (-x-1) i = negb (Z.testbit x i).
-Proof.
- intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
- intros i IND POS x.
- rewrite (Zdecomp x). set (y := Z.div2 x).
- replace (- Zshiftin (Z.odd x) y - 1)
- with (Zshiftin (negb (Z.odd x)) (- y - 1)).
- rewrite !Ztestbit_shiftin; auto.
- destruct (zeq i 0). auto. apply IND. omega.
- rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring.
-Qed.
-
-Lemma Ztestbit_above:
- forall n x i,
- 0 <= x < two_power_nat n ->
- i >= Z.of_nat n ->
- Z.testbit x i = false.
-Proof.
- induction n; intros.
- - change (two_power_nat 0) with 1 in H.
- replace x with 0 by omega.
- apply Z.testbit_0_l.
- - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false.
- apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H.
- rewrite Zshiftin_spec in H. destruct (Z.odd x); omega.
- omega. omega. omega.
-Qed.
-
-Lemma Ztestbit_above_neg:
- forall n x i,
- -two_power_nat n <= x < 0 ->
- i >= Z.of_nat n ->
- Z.testbit x i = true.
-Proof.
- intros. set (y := -x-1).
- assert (Z.testbit y i = false).
- apply Ztestbit_above with n.
- unfold y; omega. auto.
- unfold y in H1. rewrite Z_one_complement in H1.
- change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto.
- omega.
-Qed.
-
-Lemma Zsign_bit:
- forall n x,
- 0 <= x < two_power_nat (S n) ->
- Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true.
-Proof.
- induction n; intros.
- - change (two_power_nat 1) with 2 in H.
- assert (x = 0 \/ x = 1) by omega.
- destruct H0; subst x; reflexivity.
- - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ.
- rewrite IHn. rewrite two_power_nat_S.
- destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec.
- rewrite zlt_true. auto. destruct (Z.odd x); omega.
- rewrite zlt_false. auto. destruct (Z.odd x); omega.
- rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H.
- rewrite two_power_nat_S in H. destruct (Z.odd x); omega.
- omega. omega.
-Qed.
-
-Lemma Zshiftin_ind:
- forall (P: Z -> Prop),
- P 0 ->
- (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) ->
- forall x, 0 <= x -> P x.
-Proof.
- intros. destruct x.
- - auto.
- - induction p.
- + change (P (Zshiftin true (Z.pos p))). auto.
- + change (P (Zshiftin false (Z.pos p))). auto.
- + change (P (Zshiftin true 0)). apply H0. omega. auto.
- - compute in H1. intuition congruence.
-Qed.
-
-Lemma Zshiftin_pos_ind:
- forall (P: Z -> Prop),
- P 1 ->
- (forall b x, 0 < x -> P x -> P (Zshiftin b x)) ->
- forall x, 0 < x -> P x.
-Proof.
- intros. destruct x; simpl in H1; try discriminate.
- induction p.
- + change (P (Zshiftin true (Z.pos p))). auto.
- + change (P (Zshiftin false (Z.pos p))). auto.
- + auto.
-Qed.
-
-Lemma Ztestbit_le:
- forall x y,
- 0 <= y ->
- (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) ->
- x <= y.
-Proof.
- intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros.
- - replace x with 0. omega. apply equal_same_bits; intros.
- rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto.
- exploit H; eauto. rewrite Ztestbit_0. auto.
- - assert (Z.div2 x0 <= x).
- { apply H0. intros. exploit (H1 (Z.succ i)).
- omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto.
- }
- rewrite (Zdecomp x0). rewrite !Zshiftin_spec.
- destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega.
- exploit (H1 0). omega. rewrite Ztestbit_base; auto.
- rewrite Ztestbit_shiftin_base. congruence.
-Qed.
-
-(** ** Bit-level reasoning over type [int] *)
-
Definition testbit (x: int) (i: Z) : bool := Z.testbit (unsigned x) i.
Lemma testbit_repr:
@@ -1615,6 +1149,12 @@ Proof.
intros. apply Ztestbit_above with wordsize; auto. apply unsigned_range.
Qed.
+Lemma bits_below:
+ forall x i, i < 0 -> testbit x i = false.
+Proof.
+ intros. apply Z.testbit_neg_r; auto.
+Qed.
+
Lemma bits_zero:
forall i, testbit zero i = false.
Proof.
@@ -1654,6 +1194,34 @@ Proof.
rewrite <- half_modulus_modulus. apply unsigned_range.
Qed.
+Local Transparent repr.
+Lemma sign_bit_of_signed: forall x,
+ (testbit x (zwordsize - 1)) = lt x zero.
+Proof.
+ intro.
+ rewrite sign_bit_of_unsigned.
+ unfold lt.
+ unfold signed, unsigned.
+ simpl.
+ pose proof half_modulus_pos as HMOD.
+ destruct (zlt 0 half_modulus) as [HMOD' | HMOD'].
+ 2: omega.
+ clear HMOD'.
+ destruct (zlt (intval x) half_modulus) as [ LOW | HIGH].
+ {
+ destruct x as [ix RANGE].
+ simpl in *.
+ destruct (zlt ix 0). omega.
+ reflexivity.
+ }
+ destruct (zlt _ _) as [LOW' | HIGH']; trivial.
+ destruct x as [ix RANGE].
+ simpl in *.
+ rewrite half_modulus_modulus in *.
+ omega.
+Qed.
+Local Opaque repr.
+
Lemma bits_signed:
forall x i, 0 <= i ->
Z.testbit (signed x) i = testbit x (if zlt i zwordsize then i else zwordsize - 1).
@@ -1888,7 +1456,7 @@ Proof.
rewrite bits_or; auto. rewrite H0; auto.
Qed.
-(** Properties of bitwise complement.*)
+(** ** Properties of bitwise complement.*)
Theorem not_involutive:
forall (x: int), not (not x) = x.
@@ -2007,7 +1575,7 @@ Proof.
rewrite xor_idem. rewrite unsigned_one, unsigned_zero; auto.
Qed.
-(** Connections between [add] and bitwise logical operations. *)
+(** ** Connections between [add] and bitwise logical operations. *)
Lemma Z_add_is_or:
forall i, 0 <= i ->
@@ -2458,7 +2026,7 @@ Proof.
- rewrite andb_false_r; auto.
- generalize (unsigned_range n); intros.
rewrite bits_mone. rewrite andb_true_r. f_equal.
- symmetry. apply Zmod_small. omega.
+ symmetry. apply Z.mod_small. omega.
omega.
Qed.
@@ -2485,7 +2053,7 @@ Theorem rol_zero:
rol x zero = x.
Proof.
bit_solve. f_equal. rewrite unsigned_zero. rewrite Z.sub_0_r.
- apply Zmod_small; auto.
+ apply Z.mod_small; auto.
Qed.
Lemma bitwise_binop_rol:
@@ -2610,65 +2178,31 @@ Proof.
rewrite !testbit_repr; auto.
rewrite !Z.lor_spec. rewrite orb_comm. f_equal; apply same_bits_eqm; auto.
- apply eqm_unsigned_repr_r. apply eqm_refl2. f_equal.
- rewrite Zmod_small; auto.
+ rewrite Z.mod_small; auto.
assert (unsigned (add y z) = zwordsize).
rewrite H1. apply unsigned_repr_wordsize.
unfold add in H5. rewrite unsigned_repr in H5.
omega.
generalize two_wordsize_max_unsigned; omega.
- apply eqm_unsigned_repr_r. apply eqm_refl2. f_equal.
- apply Zmod_small; auto.
+ apply Z.mod_small; auto.
Qed.
-(** ** Properties of [Z_one_bits] and [is_power2]. *)
+(** ** Properties of [is_power2]. *)
-Fixpoint powerserie (l: list Z): Z :=
- match l with
- | nil => 0
- | x :: xs => two_p x + powerserie xs
- end.
-
-Lemma Z_one_bits_powerserie:
- forall x, 0 <= x < modulus -> x = powerserie (Z_one_bits wordsize x 0).
-Proof.
- assert (forall n x i,
- 0 <= i ->
- 0 <= x < two_power_nat n ->
- x * two_p i = powerserie (Z_one_bits n x i)).
- {
- induction n; intros.
- simpl. rewrite two_power_nat_O in H0.
- assert (x = 0) by omega. subst x. omega.
- rewrite two_power_nat_S in H0. simpl Z_one_bits.
- rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0.
- assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))).
- apply IHn. omega.
- destruct (Z.odd x); omega.
- rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ.
- rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec.
- destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring.
- omega. omega.
- }
- intros. rewrite <- H. change (two_p 0) with 1. omega.
- omega. exact H0.
-Qed.
-
-Lemma Z_one_bits_range:
- forall x i, In i (Z_one_bits wordsize x 0) -> 0 <= i < zwordsize.
+Remark is_power2_inv:
+ forall n logn,
+ is_power2 n = Some logn ->
+ Z_is_power2 (unsigned n) = Some (unsigned logn) /\ 0 <= unsigned logn < zwordsize.
Proof.
- assert (forall n x i j,
- In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n).
- {
- induction n; simpl In.
- tauto.
- intros x i j. rewrite Nat2Z.inj_succ.
- assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)).
- intros. exploit IHn; eauto. omega.
- destruct (Z.odd x); simpl.
- intros [A|B]. subst j. omega. auto.
- auto.
- }
- intros. generalize (H wordsize x 0 i H0). fold zwordsize; omega.
+ unfold is_power2; intros.
+ destruct (Z_is_power2 (unsigned n)) as [i|] eqn:E; inv H.
+ assert (0 <= i < zwordsize).
+ { apply Z_is_power2_range with (unsigned n).
+ generalize wordsize_pos; omega.
+ rewrite <- modulus_power. apply unsigned_range.
+ auto. }
+ rewrite unsigned_repr; auto. generalize wordsize_max_unsigned; omega.
Qed.
Lemma is_power2_rng:
@@ -2676,16 +2210,7 @@ Lemma is_power2_rng:
is_power2 n = Some logn ->
0 <= unsigned logn < zwordsize.
Proof.
- intros n logn. unfold is_power2.
- generalize (Z_one_bits_range (unsigned n)).
- destruct (Z_one_bits wordsize (unsigned n) 0).
- intros; discriminate.
- destruct l.
- intros. injection H0; intro; subst logn; clear H0.
- assert (0 <= z < zwordsize).
- apply H. auto with coqlib.
- rewrite unsigned_repr. auto. generalize wordsize_max_unsigned; omega.
- intros; discriminate.
+ intros. apply (is_power2_inv n logn); auto.
Qed.
Theorem is_power2_range:
@@ -2701,18 +2226,8 @@ Lemma is_power2_correct:
is_power2 n = Some logn ->
unsigned n = two_p (unsigned logn).
Proof.
- intros n logn. unfold is_power2.
- generalize (Z_one_bits_powerserie (unsigned n) (unsigned_range n)).
- generalize (Z_one_bits_range (unsigned n)).
- destruct (Z_one_bits wordsize (unsigned n) 0).
- intros; discriminate.
- destruct l.
- intros. simpl in H0. injection H1; intros; subst logn; clear H1.
- rewrite unsigned_repr. replace (two_p z) with (two_p z + 0).
- auto. omega. elim (H z); intros.
- generalize wordsize_max_unsigned; omega.
- auto with coqlib.
- intros; discriminate.
+ intros. apply is_power2_inv in H. destruct H as [P Q].
+ apply Z_is_power2_sound in P. tauto.
Qed.
Remark two_p_range:
@@ -2727,34 +2242,12 @@ Proof.
unfold max_unsigned, modulus. omega.
Qed.
-Remark Z_one_bits_zero:
- forall n i, Z_one_bits n 0 i = nil.
-Proof.
- induction n; intros; simpl; auto.
-Qed.
-
-Remark Z_one_bits_two_p:
- forall n x i,
- 0 <= x < Z.of_nat n ->
- Z_one_bits n (two_p x) i = (i + x) :: nil.
-Proof.
- induction n; intros; simpl. simpl in H. omegaContradiction.
- rewrite Nat2Z.inj_succ in H.
- assert (x = 0 \/ 0 < x) by omega. destruct H0.
- subst x; simpl. decEq. omega. apply Z_one_bits_zero.
- assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)).
- apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec.
- rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega.
- destruct H1 as [A B]; rewrite A; rewrite B.
- rewrite IHn. f_equal; omega. omega.
-Qed.
-
Lemma is_power2_two_p:
forall n, 0 <= n < zwordsize ->
is_power2 (repr (two_p n)) = Some (repr n).
Proof.
intros. unfold is_power2. rewrite unsigned_repr.
- rewrite Z_one_bits_two_p. auto. auto.
+ rewrite Z_is_power2_complete by omega; auto.
apply two_p_range. auto.
Qed.
@@ -2762,19 +2255,6 @@ Qed.
(** Left shifts and multiplications by powers of 2. *)
-Lemma Zshiftl_mul_two_p:
- forall x n, 0 <= n -> Z.shiftl x n = x * two_p n.
-Proof.
- intros. destruct n; simpl.
- - omega.
- - pattern p. apply Pos.peano_ind.
- + change (two_power_pos 1) with 2. simpl. ring.
- + intros. rewrite Pos.iter_succ. rewrite H0.
- rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
- change (two_power_pos 1) with 2. ring.
- - compute in H. congruence.
-Qed.
-
Lemma shl_mul_two_p:
forall x y,
shl x y = mul x (repr (two_p (unsigned y))).
@@ -2834,21 +2314,6 @@ Qed.
(** Unsigned right shifts and unsigned divisions by powers of 2. *)
-Lemma Zshiftr_div_two_p:
- forall x n, 0 <= n -> Z.shiftr x n = x / two_p n.
-Proof.
- intros. destruct n; unfold Z.shiftr; simpl.
- - rewrite Zdiv_1_r. auto.
- - pattern p. apply Pos.peano_ind.
- + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div.
- + intros. rewrite Pos.iter_succ. rewrite H0.
- rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
- change (two_power_pos 1) with 2.
- rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv.
- rewrite two_power_pos_nat. apply two_power_nat_pos. omega.
- - compute in H. congruence.
-Qed.
-
Lemma shru_div_two_p:
forall x y,
shru x y = repr (unsigned x / two_p (unsigned y)).
@@ -2891,43 +2356,6 @@ Qed.
(** Unsigned modulus over [2^n] is masking with [2^n-1]. *)
-Lemma Ztestbit_mod_two_p:
- forall n x i,
- 0 <= n -> 0 <= i ->
- Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false.
-Proof.
- intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto.
- - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l.
- rewrite zlt_false; auto. omega.
- - intros. rewrite two_p_S; auto.
- replace (x0 mod (2 * two_p x))
- with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)).
- rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0).
- + rewrite zlt_true; auto. omega.
- + rewrite H0. destruct (zlt (Z.pred i) x).
- * rewrite zlt_true; auto. omega.
- * rewrite zlt_false; auto. omega.
- * omega.
- + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry.
- apply Zmod_unique with (x1 / two_p x).
- rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal.
- transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)).
- f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto.
- ring.
- rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto.
- destruct (Z.odd x0); omega.
-Qed.
-
-Corollary Ztestbit_two_p_m1:
- forall n i, 0 <= n -> 0 <= i ->
- Z.testbit (two_p n - 1) i = if zlt i n then true else false.
-Proof.
- intros. replace (two_p n - 1) with ((-1) mod (two_p n)).
- rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto.
- apply Zmod_unique with (-1). ring.
- exploit (two_p_gt_ZERO n). auto. omega.
-Qed.
-
Theorem modu_and:
forall x n logn,
is_power2 n = Some logn ->
@@ -2949,21 +2377,6 @@ Qed.
(** ** Properties of [shrx] (signed division by a power of 2) *)
-Lemma Zquot_Zdiv:
- forall x y,
- y > 0 ->
- Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y.
-Proof.
- intros. destruct (zlt x 0).
- - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)).
- + red. right; split. omega.
- exploit (Z_mod_lt (x + y - 1) y); auto.
- rewrite Z.abs_eq. omega. omega.
- + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)).
- rewrite <- Z_div_mod_eq. ring. auto. ring.
- - apply Zquot_Zdiv_pos; omega.
-Qed.
-
Theorem shrx_zero:
forall x, zwordsize > 1 -> shrx x zero = x.
Proof.
@@ -3042,15 +2455,55 @@ Proof.
bit_solve. destruct (zlt (i + unsigned (sub iwordsize y)) zwordsize); auto.
Qed.
-Lemma Zdiv_shift:
- forall x y, y > 0 ->
- (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1.
+Theorem shrx1_shr:
+ forall x,
+ ltu one (repr (zwordsize - 1)) = true ->
+ shrx x (repr 1) = shr (add x (shru x (repr (zwordsize - 1)))) (repr 1).
Proof.
- intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H).
- set (q := x / y). set (r := x mod y). intros.
- destruct (zeq r 0).
- apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega.
- apply Zdiv_unique with (r - 1). rewrite H1. ring. omega.
+ intros.
+ rewrite shrx_shr by assumption.
+ rewrite shl_mul_two_p.
+ rewrite mul_commut. rewrite mul_one.
+ change (repr 1) with one.
+ rewrite unsigned_one.
+ change (two_p 1) with 2.
+ unfold sub.
+ rewrite unsigned_one.
+ assert (0 <= 2 <= max_unsigned).
+ {
+ unfold max_unsigned, modulus.
+ unfold zwordsize in *.
+ unfold ltu in *.
+ rewrite unsigned_one in H.
+ rewrite unsigned_repr in H.
+ {
+ destruct (zlt 1 (Z.of_nat wordsize - 1)) as [ LT | NONE].
+ 2: discriminate.
+ clear H.
+ rewrite two_power_nat_two_p.
+ split.
+ omega.
+ set (w := (Z.of_nat wordsize)) in *.
+ assert ((two_p 2) <= (two_p w)) as MONO.
+ {
+ apply two_p_monotone.
+ omega.
+ }
+ change (two_p 2) with 4 in MONO.
+ omega.
+ }
+ generalize wordsize_max_unsigned.
+ fold zwordsize.
+ generalize wordsize_pos.
+ omega.
+ }
+ rewrite unsigned_repr by assumption.
+ simpl.
+ rewrite shru_lt_zero.
+ destruct (lt x zero).
+ reflexivity.
+ rewrite add_zero.
+ reflexivity.
Qed.
Theorem shrx_carry:
@@ -3143,51 +2596,6 @@ Qed.
(** ** Properties of integer zero extension and sign extension. *)
-Lemma Ziter_base:
- forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x.
-Proof.
- intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto.
-Qed.
-
-Lemma Ziter_succ:
- forall (A: Type) n (f: A -> A) x,
- 0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x).
-Proof.
- intros. destruct n; simpl.
- - auto.
- - rewrite Pos.add_1_r. apply Pos.iter_succ.
- - compute in H. elim H; auto.
-Qed.
-
-Lemma Znatlike_ind:
- forall (P: Z -> Prop),
- (forall n, n <= 0 -> P n) ->
- (forall n, 0 <= n -> P n -> P (Z.succ n)) ->
- forall n, P n.
-Proof.
- intros. destruct (zle 0 n).
- apply natlike_ind; auto. apply H; omega.
- apply H. omega.
-Qed.
-
-Lemma Zzero_ext_spec:
- forall n x i, 0 <= i ->
- Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false.
-Proof.
- unfold Zzero_ext. induction n using Znatlike_ind.
- - intros. rewrite Ziter_base; auto.
- rewrite zlt_false. rewrite Ztestbit_0; auto. omega.
- - intros. rewrite Ziter_succ; auto.
- rewrite Ztestbit_shiftin; auto.
- rewrite (Ztestbit_eq i x); auto.
- destruct (zeq i 0).
- + subst i. rewrite zlt_true; auto. omega.
- + rewrite IHn. destruct (zlt (Z.pred i) n).
- rewrite zlt_true; auto. omega.
- rewrite zlt_false; auto. omega.
- omega.
-Qed.
-
Lemma bits_zero_ext:
forall n x i, 0 <= i ->
testbit (zero_ext n x) i = if zlt i n then testbit x i else false.
@@ -3197,42 +2605,12 @@ Proof.
rewrite !bits_above; auto. destruct (zlt i n); auto.
Qed.
-Lemma Zsign_ext_spec:
- forall n x i, 0 <= i -> 0 < n ->
- Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1).
-Proof.
- intros n0 x i I0 N0.
- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1).
- - unfold Zsign_ext. intros.
- destruct (zeq x 1).
- + subst x; simpl.
- replace (if zlt i 1 then i else 0) with 0.
- rewrite Ztestbit_base.
- destruct (Z.odd x0).
- apply Ztestbit_m1; auto.
- apply Ztestbit_0.
- destruct (zlt i 1); omega.
- + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)).
- rewrite Ziter_succ. rewrite Ztestbit_shiftin.
- destruct (zeq i 0).
- * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega.
- * rewrite H. unfold x1. destruct (zlt (Z.pred i) (Z.pred x)).
- rewrite zlt_true. rewrite (Ztestbit_eq i x0); auto. rewrite zeq_false; auto. omega.
- rewrite zlt_false. rewrite (Ztestbit_eq (x - 1) x0). rewrite zeq_false; auto.
- omega. omega. omega. unfold x1; omega. omega.
- * omega.
- * unfold x1; omega.
- * omega.
- - omega.
-Qed.
-
Lemma bits_sign_ext:
- forall n x i, 0 <= i < zwordsize -> 0 < n ->
+ forall n x i, 0 <= i < zwordsize ->
testbit (sign_ext n x) i = testbit x (if zlt i n then i else n - 1).
Proof.
intros. unfold sign_ext.
- rewrite testbit_repr; auto. rewrite Zsign_ext_spec. destruct (zlt i n); auto.
- omega. auto.
+ rewrite testbit_repr; auto. apply Zsign_ext_spec. omega.
Qed.
Hint Rewrite bits_zero_ext bits_sign_ext: ints.
@@ -3244,12 +2622,24 @@ Proof.
rewrite bits_zero_ext. apply zlt_true. omega. omega.
Qed.
+Theorem zero_ext_below:
+ forall n x, n <= 0 -> zero_ext n x = zero.
+Proof.
+ intros. bit_solve. destruct (zlt i n); auto. apply bits_below; omega. omega.
+Qed.
+
Theorem sign_ext_above:
forall n x, n >= zwordsize -> sign_ext n x = x.
Proof.
intros. apply same_bits_eq; intros.
unfold sign_ext; rewrite testbit_repr; auto.
- rewrite Zsign_ext_spec. rewrite zlt_true. auto. omega. omega. omega.
+ rewrite Zsign_ext_spec. rewrite zlt_true. auto. omega. omega.
+Qed.
+
+Theorem sign_ext_below:
+ forall n x, n <= 0 -> sign_ext n x = zero.
+Proof.
+ intros. bit_solve. apply bits_below. destruct (zlt i n); omega.
Qed.
Theorem zero_ext_and:
@@ -3286,7 +2676,7 @@ Proof.
Qed.
Theorem sign_ext_widen:
- forall x n n', 0 < n <= n' ->
+ forall x n n', 0 < n <= n' ->
sign_ext n' (sign_ext n x) = sign_ext n x.
Proof.
intros. destruct (zlt n' zwordsize).
@@ -3294,9 +2684,8 @@ Proof.
auto.
rewrite (zlt_false _ i n).
destruct (zlt (n' - 1) n); f_equal; omega.
- omega. omega.
+ omega.
destruct (zlt i n'); omega.
- omega. omega.
apply sign_ext_above; auto.
Qed.
@@ -3310,7 +2699,6 @@ Proof.
auto.
rewrite !zlt_false. auto. omega. omega. omega.
destruct (zlt i n'); omega.
- omega.
apply sign_ext_above; auto.
Qed.
@@ -3330,9 +2718,7 @@ Theorem sign_ext_narrow:
Proof.
intros. destruct (zlt n zwordsize).
bit_solve. destruct (zlt i n); f_equal; apply zlt_true; omega.
- omega.
destruct (zlt i n); omega.
- omega. omega.
rewrite (sign_ext_above n'). auto. omega.
Qed.
@@ -3344,7 +2730,7 @@ Proof.
bit_solve.
destruct (zlt i n); auto.
rewrite zlt_true; auto. omega.
- omega. omega. omega.
+ omega. omega.
rewrite sign_ext_above; auto.
Qed.
@@ -3359,7 +2745,7 @@ Theorem sign_ext_idem:
Proof.
intros. apply sign_ext_widen. omega.
Qed.
-
+
Theorem sign_ext_zero_ext:
forall n x, 0 < n -> sign_ext n (zero_ext n x) = sign_ext n x.
Proof.
@@ -3387,42 +2773,93 @@ Proof.
rewrite <- (sign_ext_zero_ext n y H). congruence.
Qed.
-Theorem zero_ext_shru_shl:
+Theorem shru_shl:
+ forall x y z, ltu y iwordsize = true -> ltu z iwordsize = true ->
+ shru (shl x y) z =
+ if ltu z y then shl (zero_ext (zwordsize - unsigned y) x) (sub y z)
+ else zero_ext (zwordsize - unsigned z) (shru x (sub z y)).
+Proof.
+ intros. apply ltu_iwordsize_inv in H; apply ltu_iwordsize_inv in H0.
+ unfold ltu. set (Y := unsigned y) in *; set (Z := unsigned z) in *.
+ apply same_bits_eq; intros. rewrite bits_shru by auto. fold Z.
+ destruct (zlt Z Y).
+- assert (A: unsigned (sub y z) = Y - Z).
+ { apply unsigned_repr. generalize wordsize_max_unsigned; omega. }
+ symmetry; rewrite bits_shl, A by omega.
+ destruct (zlt (i + Z) zwordsize).
++ rewrite bits_shl by omega. fold Y.
+ destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+ rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega.
++ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto.
+- assert (A: unsigned (sub z y) = Z - Y).
+ { apply unsigned_repr. generalize wordsize_max_unsigned; omega. }
+ rewrite bits_zero_ext, bits_shru, A by omega.
+ destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+ rewrite bits_shl by omega. fold Y.
+ destruct (zlt (i + Z) Y).
++ rewrite zlt_false by omega. auto.
++ rewrite zlt_true by omega. f_equal; omega.
+Qed.
+
+Corollary zero_ext_shru_shl:
forall n x,
0 < n < zwordsize ->
let y := repr (zwordsize - n) in
zero_ext n x = shru (shl x y) y.
Proof.
intros.
- assert (unsigned y = zwordsize - n).
- unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega.
- apply same_bits_eq; intros.
- rewrite bits_zero_ext.
- rewrite bits_shru; auto.
- destruct (zlt i n).
- rewrite zlt_true. rewrite bits_shl. rewrite zlt_false. f_equal. omega.
- omega. omega. omega.
- rewrite zlt_false. auto. omega.
- omega.
-Qed.
-
-Theorem sign_ext_shr_shl:
+ assert (A: unsigned y = zwordsize - n).
+ { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. }
+ assert (B: ltu y iwordsize = true).
+ { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. }
+ rewrite shru_shl by auto. unfold ltu; rewrite zlt_false by omega.
+ rewrite sub_idem, shru_zero. f_equal. rewrite A; omega.
+Qed.
+
+Theorem shr_shl:
+ forall x y z, ltu y iwordsize = true -> ltu z iwordsize = true ->
+ shr (shl x y) z =
+ if ltu z y then shl (sign_ext (zwordsize - unsigned y) x) (sub y z)
+ else sign_ext (zwordsize - unsigned z) (shr x (sub z y)).
+Proof.
+ intros. apply ltu_iwordsize_inv in H; apply ltu_iwordsize_inv in H0.
+ unfold ltu. set (Y := unsigned y) in *; set (Z := unsigned z) in *.
+ apply same_bits_eq; intros. rewrite bits_shr by auto. fold Z.
+ rewrite bits_shl by (destruct (zlt (i + Z) zwordsize); omega). fold Y.
+ destruct (zlt Z Y).
+- assert (A: unsigned (sub y z) = Y - Z).
+ { apply unsigned_repr. generalize wordsize_max_unsigned; omega. }
+ rewrite bits_shl, A by omega.
+ destruct (zlt i (Y - Z)).
++ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega.
++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega).
+ rewrite bits_sign_ext by omega. f_equal.
+ destruct (zlt (i + Z) zwordsize).
+ rewrite zlt_true by omega. omega.
+ rewrite zlt_false by omega. omega.
+- assert (A: unsigned (sub z y) = Z - Y).
+ { apply unsigned_repr. generalize wordsize_max_unsigned; omega. }
+ rewrite bits_sign_ext by omega.
+ rewrite bits_shr by (destruct (zlt i (zwordsize - Z)); omega).
+ rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega).
+ f_equal. destruct (zlt i (zwordsize - Z)).
++ rewrite ! zlt_true by omega. omega.
++ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega.
+Qed.
+
+Corollary sign_ext_shr_shl:
forall n x,
0 < n < zwordsize ->
let y := repr (zwordsize - n) in
sign_ext n x = shr (shl x y) y.
Proof.
intros.
- assert (unsigned y = zwordsize - n).
- unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega.
- apply same_bits_eq; intros.
- rewrite bits_sign_ext.
- rewrite bits_shr; auto.
- destruct (zlt i n).
- rewrite zlt_true. rewrite bits_shl. rewrite zlt_false. f_equal. omega.
- omega. omega. omega.
- rewrite zlt_false. rewrite bits_shl. rewrite zlt_false. f_equal. omega.
- omega. omega. omega. omega. omega.
+ assert (A: unsigned y = zwordsize - n).
+ { unfold y. apply unsigned_repr. generalize wordsize_max_unsigned. omega. }
+ assert (B: ltu y iwordsize = true).
+ { unfold ltu; rewrite A, unsigned_repr_wordsize. apply zlt_true; omega. }
+ rewrite shr_shl by auto. unfold ltu; rewrite zlt_false by omega.
+ rewrite sub_idem, shr_zero. f_equal. rewrite A; omega.
Qed.
(** [zero_ext n x] is the unique integer congruent to [x] modulo [2^n]
@@ -3482,7 +2919,7 @@ Proof.
apply eqmod_same_bits; intros.
rewrite H0 in H1. rewrite H0.
fold (testbit (sign_ext n x) i). rewrite bits_sign_ext.
- rewrite zlt_true. auto. omega. omega. omega.
+ rewrite zlt_true. auto. omega. omega.
Qed.
Lemma eqmod_sign_ext:
@@ -3497,6 +2934,132 @@ Proof.
apply eqmod_sign_ext'; auto.
Qed.
+(** Combinations of shifts and zero/sign extensions *)
+
+Lemma shl_zero_ext:
+ forall n m x, 0 <= n ->
+ shl (zero_ext n x) m = zero_ext (n + unsigned m) (shl x m).
+Proof.
+ intros. apply same_bits_eq; intros.
+ rewrite bits_zero_ext, ! bits_shl by omega.
+ destruct (zlt i (unsigned m)).
+- rewrite zlt_true by omega; auto.
+- rewrite bits_zero_ext by omega.
+ destruct (zlt (i - unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+Qed.
+
+Lemma shl_sign_ext:
+ forall n m x, 0 < n ->
+ shl (sign_ext n x) m = sign_ext (n + unsigned m) (shl x m).
+Proof.
+ intros. generalize (unsigned_range m); intros.
+ apply same_bits_eq; intros.
+ rewrite bits_sign_ext, ! bits_shl by omega.
+ destruct (zlt i (n + unsigned m)).
+- rewrite bits_shl by auto. destruct (zlt i (unsigned m)); auto.
+ rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega.
+- rewrite zlt_false by omega. rewrite bits_shl by omega. rewrite zlt_false by omega.
+ rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega.
+Qed.
+
+Lemma shru_zero_ext:
+ forall n m x, 0 <= n ->
+ shru (zero_ext (n + unsigned m) x) m = zero_ext n (shru x m).
+Proof.
+ intros. bit_solve.
+- destruct (zlt (i + unsigned m) zwordsize).
+* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+* destruct (zlt i n); auto.
+- generalize (unsigned_range m); omega.
+- omega.
+Qed.
+
+Lemma shru_zero_ext_0:
+ forall n m x, n <= unsigned m ->
+ shru (zero_ext n x) m = zero.
+Proof.
+ intros. bit_solve.
+- destruct (zlt (i + unsigned m) zwordsize); auto.
+ apply zlt_false. omega.
+- generalize (unsigned_range m); omega.
+Qed.
+
+Lemma shr_sign_ext:
+ forall n m x, 0 < n -> n + unsigned m < zwordsize ->
+ shr (sign_ext (n + unsigned m) x) m = sign_ext n (shr x m).
+Proof.
+ intros. generalize (unsigned_range m); intros.
+ apply same_bits_eq; intros.
+ rewrite bits_sign_ext, bits_shr by auto.
+ rewrite bits_sign_ext, bits_shr.
+- f_equal.
+ destruct (zlt i n), (zlt (i + unsigned m) zwordsize).
++ apply zlt_true; omega.
++ apply zlt_true; omega.
++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega.
++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega.
+- destruct (zlt i n); omega.
+- destruct (zlt (i + unsigned m) zwordsize); omega.
+Qed.
+
+Lemma zero_ext_shru_min:
+ forall s x n, ltu n iwordsize = true ->
+ zero_ext s (shru x n) = zero_ext (Z.min s (zwordsize - unsigned n)) (shru x n).
+Proof.
+ intros. apply ltu_iwordsize_inv in H.
+ apply Z.min_case_strong; intros; auto.
+ bit_solve; try omega.
+ destruct (zlt i (zwordsize - unsigned n)).
+ rewrite zlt_true by omega. auto.
+ destruct (zlt i s); auto. rewrite zlt_false by omega; auto.
+Qed.
+
+Lemma sign_ext_shr_min:
+ forall s x n, ltu n iwordsize = true ->
+ sign_ext s (shr x n) = sign_ext (Z.min s (zwordsize - unsigned n)) (shr x n).
+Proof.
+ intros. apply ltu_iwordsize_inv in H.
+ rewrite Z.min_comm.
+ destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto.
+ apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto.
+ destruct (zlt i (zwordsize - unsigned n)).
+ rewrite zlt_true by omega. auto.
+ assert (C: testbit (shr x n) (zwordsize - unsigned n - 1) = testbit x (zwordsize - 1)).
+ { rewrite bits_shr by omega. rewrite zlt_true by omega. f_equal; omega. }
+ rewrite C. destruct (zlt i s); rewrite bits_shr by omega.
+ rewrite zlt_false by omega. auto.
+ rewrite zlt_false by omega. auto.
+Qed.
+
+Lemma shl_zero_ext_min:
+ forall s x n, ltu n iwordsize = true ->
+ shl (zero_ext s x) n = shl (zero_ext (Z.min s (zwordsize - unsigned n)) x) n.
+Proof.
+ intros. apply ltu_iwordsize_inv in H.
+ apply Z.min_case_strong; intros; auto.
+ apply same_bits_eq; intros. rewrite ! bits_shl by auto.
+ destruct (zlt i (unsigned n)); auto.
+ rewrite ! bits_zero_ext by omega.
+ destruct (zlt (i - unsigned n) s).
+ rewrite zlt_true by omega; auto.
+ rewrite zlt_false by omega; auto.
+Qed.
+
+Lemma shl_sign_ext_min:
+ forall s x n, ltu n iwordsize = true ->
+ shl (sign_ext s x) n = shl (sign_ext (Z.min s (zwordsize - unsigned n)) x) n.
+Proof.
+ intros. apply ltu_iwordsize_inv in H.
+ rewrite Z.min_comm.
+ destruct (Z.min_spec (zwordsize - unsigned n) s) as [[A B] | [A B]]; rewrite B; auto.
+ apply same_bits_eq; intros. rewrite ! bits_shl by auto.
+ destruct (zlt i (unsigned n)); auto.
+ rewrite ! bits_sign_ext by omega. f_equal.
+ destruct (zlt (i - unsigned n) s).
+ rewrite zlt_true by omega; auto.
+ omegaContradiction.
+Qed.
+
(** ** Properties of [one_bits] (decomposition in sum of powers of two) *)
Theorem one_bits_range:
@@ -3527,7 +3090,7 @@ Proof.
auto with ints. decEq. apply Z_one_bits_powerserie.
auto with ints.
unfold one_bits.
- generalize (Z_one_bits_range (unsigned x)).
+ generalize (Z_one_bits_range wordsize (unsigned x)).
generalize (Z_one_bits wordsize (unsigned x) 0).
induction l.
intros; reflexivity.
@@ -3535,7 +3098,8 @@ Proof.
apply eqm_add. rewrite shl_mul_two_p. rewrite mul_commut.
rewrite mul_one. apply eqm_unsigned_repr_r.
rewrite unsigned_repr. auto with ints.
- generalize (H a (in_eq _ _)). generalize wordsize_max_unsigned. omega.
+ generalize (H a (in_eq _ _)). change (Z.of_nat wordsize) with zwordsize.
+ generalize wordsize_max_unsigned. omega.
auto with ints.
intros; apply H; auto with coqlib.
Qed.
@@ -3735,8 +3299,7 @@ Proof.
intros. rewrite <- negb_orb. rewrite <- not_ltu. rewrite negb_involutive. auto.
Qed.
-
-(** Non-overlapping test *)
+(** ** Non-overlapping test *)
Definition no_overlap (ofs1: int) (sz1: Z) (ofs2: int) (sz2: Z) : bool :=
let x1 := unsigned ofs1 in let x2 := unsigned ofs2 in
@@ -3762,94 +3325,10 @@ Proof.
intros [C|C] [D|D]; omega.
Qed.
-(** Size of integers, in bits. *)
-
-Definition Zsize (x: Z) : Z :=
- match x with
- | Zpos p => Zpos (Pos.size p)
- | _ => 0
- end.
+(** ** Size of integers, in bits. *)
Definition size (x: int) : Z := Zsize (unsigned x).
-Remark Zsize_pos: forall x, 0 <= Zsize x.
-Proof.
- destruct x; simpl. omega. compute; intuition congruence. omega.
-Qed.
-
-Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x.
-Proof.
- destruct x; simpl; intros; try discriminate. compute; auto.
-Qed.
-
-Lemma Zsize_shiftin:
- forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x).
-Proof.
- intros. destruct x; compute in H; try discriminate.
- destruct b.
- change (Zshiftin true (Zpos p)) with (Zpos (p~1)).
- simpl. f_equal. rewrite Pos.add_1_r; auto.
- change (Zshiftin false (Zpos p)) with (Zpos (p~0)).
- simpl. f_equal. rewrite Pos.add_1_r; auto.
-Qed.
-
-Lemma Ztestbit_size_1:
- forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true.
-Proof.
- intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto.
- intros. rewrite Zsize_shiftin; auto.
- replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega.
- rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega.
-Qed.
-
-Lemma Ztestbit_size_2:
- forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false.
-Proof.
- intros x0 POS0. destruct (zeq x0 0).
- - subst x0; intros. apply Ztestbit_0.
- - pattern x0; apply Zshiftin_pos_ind.
- + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin.
- rewrite zeq_false. apply Ztestbit_0. omega. omega.
- + intros. rewrite Zsize_shiftin in H1; auto.
- generalize (Zsize_pos' _ H); intros.
- rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega.
- omega. omega.
- + omega.
-Qed.
-
-Lemma Zsize_interval_1:
- forall x, 0 <= x -> 0 <= x < two_p (Zsize x).
-Proof.
- intros.
- assert (x = x mod (two_p (Zsize x))).
- apply equal_same_bits; intros.
- rewrite Ztestbit_mod_two_p; auto.
- destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto.
- apply Zsize_pos; auto.
- rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto.
-Qed.
-
-Lemma Zsize_interval_2:
- forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x.
-Proof.
- intros. set (N := Z.to_nat n).
- assert (Z.of_nat N = n) by (apply Z2Nat.id; auto).
- rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0.
- destruct (zeq x 0).
- subst x; simpl; omega.
- destruct (zlt n (Zsize x)); auto.
- exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega.
- rewrite Ztestbit_size_1. congruence. omega.
-Qed.
-
-Lemma Zsize_monotone:
- forall x y, 0 <= x <= y -> Zsize x <= Zsize y.
-Proof.
- intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos.
- exploit (Zsize_interval_1 y). omega.
- omega.
-Qed.
-
Theorem size_zero: size zero = 0.
Proof.
unfold size; rewrite unsigned_zero; auto.
@@ -3927,10 +3406,11 @@ Proof.
assert (0 <= Z.min (size a) (size b)).
generalize (size_range a) (size_range b). zify; omega.
apply bits_size_3. auto. intros.
- rewrite bits_and. zify. subst z z0. destruct H1.
- rewrite (bits_size_2 a). auto. omega.
- rewrite (bits_size_2 b). apply andb_false_r. omega.
- omega.
+ rewrite bits_and by omega.
+ rewrite andb_false_iff.
+ generalize (bits_size_2 a i).
+ generalize (bits_size_2 b i).
+ zify; intuition.
Qed.
Corollary and_interval:
@@ -4192,6 +3672,104 @@ Proof.
unfold ltu. apply zlt_true. change (unsigned z < 63). rewrite A; omega.
Qed.
+Lemma shr'63:
+ forall x, (shr' x (Int.repr 63)) = if lt x zero then mone else zero.
+Proof.
+ intro.
+ unfold shr', mone, zero.
+ rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; omega).
+ apply same_bits_eq.
+ intros i BIT.
+ rewrite testbit_repr by assumption.
+ rewrite Z.shiftr_spec by omega.
+ rewrite bits_signed by omega.
+ simpl.
+ change zwordsize with 64 in *.
+ destruct (zlt _ _) as [LT | GE].
+ {
+ replace i with 0 in * by omega.
+ change (0 + 63) with (zwordsize - 1).
+ rewrite sign_bit_of_signed.
+ destruct (lt x _).
+ all: rewrite testbit_repr by (change zwordsize with 64 in *; omega).
+ all: simpl; reflexivity.
+ }
+ change (64 - 1) with (zwordsize - 1).
+ rewrite sign_bit_of_signed.
+ destruct (lt x _).
+ all: rewrite testbit_repr by (change zwordsize with 64 in *; omega).
+ { symmetry.
+ apply Ztestbit_m1.
+ tauto.
+ }
+ symmetry.
+ apply Ztestbit_0.
+Qed.
+
+Lemma shru'63:
+ forall x, (shru' x (Int.repr 63)) = if lt x zero then one else zero.
+Proof.
+ intro.
+ unfold shru'.
+ rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; omega).
+ apply same_bits_eq.
+ intros i BIT.
+ rewrite testbit_repr by assumption.
+ rewrite Z.shiftr_spec by omega.
+ unfold lt.
+ rewrite signed_zero.
+ unfold one, zero.
+ destruct (zlt _ 0) as [LT | GE].
+ {
+ rewrite testbit_repr by assumption.
+ destruct (zeq i 0) as [IZERO | INONZERO].
+ { subst i.
+ change (Z.testbit (unsigned x) (0 + 63)) with (testbit x (zwordsize - 1)).
+ rewrite sign_bit_of_signed.
+ unfold lt.
+ rewrite signed_zero.
+ destruct (zlt _ _); try omega.
+ reflexivity.
+ }
+ change (Z.testbit (unsigned x) (i + 63)) with (testbit x (i+63)).
+ rewrite bits_above by (change zwordsize with 64; omega).
+ rewrite Ztestbit_1.
+ destruct (zeq i 0); trivial.
+ subst i.
+ omega.
+ }
+ destruct (zeq i 0) as [IZERO | INONZERO].
+ { subst i.
+ change (Z.testbit (unsigned x) (0 + 63)) with (testbit x (zwordsize - 1)).
+ rewrite sign_bit_of_signed.
+ unfold lt.
+ rewrite signed_zero.
+ rewrite bits_zero.
+ destruct (zlt _ _); try omega.
+ reflexivity.
+ }
+ change (Z.testbit (unsigned x) (i + 63)) with (testbit x (i + 63)).
+ rewrite bits_zero.
+ apply bits_above.
+ change zwordsize with 64.
+ omega.
+Qed.
+
+Theorem shrx'1_shr':
+ forall x,
+ Int.ltu Int.one (Int.repr (zwordsize - 1)) = true ->
+ shrx' x (Int.repr 1) = shr' (add x (shru' x (Int.repr (Int64.zwordsize - 1)))) (Int.repr 1).
+Proof.
+ intros.
+ rewrite shrx'_shr_2 by reflexivity.
+ change (Int.sub (Int.repr 64) (Int.repr 1)) with (Int.repr 63).
+ f_equal. f_equal.
+ rewrite shr'63.
+ rewrite shru'63.
+ rewrite shru'63.
+ destruct (lt x zero); reflexivity.
+Qed.
+
Remark int_ltu_2_inv:
forall y z,
Int.ltu y iwordsize' = true ->
@@ -4299,6 +3877,190 @@ Proof.
unfold shr, shr'; rewrite <- A; auto.
Qed.
+Theorem shru'_shl':
+ forall x y z, Int.ltu y iwordsize' = true -> Int.ltu z iwordsize' = true ->
+ shru' (shl' x y) z =
+ if Int.ltu z y then shl' (zero_ext (zwordsize - Int.unsigned y) x) (Int.sub y z)
+ else zero_ext (zwordsize - Int.unsigned z) (shru' x (Int.sub z y)).
+Proof.
+ intros. apply Int.ltu_inv in H; apply Int.ltu_inv in H0.
+ change (Int.unsigned iwordsize') with zwordsize in *.
+ unfold Int.ltu. set (Y := Int.unsigned y) in *; set (Z := Int.unsigned z) in *.
+ apply same_bits_eq; intros. rewrite bits_shru' by auto. fold Z.
+ destruct (zlt Z Y).
+- assert (A: Int.unsigned (Int.sub y z) = Y - Z).
+ { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. }
+ symmetry; rewrite bits_shl', A by omega.
+ destruct (zlt (i + Z) zwordsize).
++ rewrite bits_shl' by omega. fold Y.
+ destruct (zlt i (Y - Z)); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+ rewrite bits_zero_ext by omega. rewrite zlt_true by omega. f_equal; omega.
++ rewrite bits_zero_ext by omega. rewrite ! zlt_false by omega. auto.
+- assert (A: Int.unsigned (Int.sub z y) = Z - Y).
+ { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. }
+ rewrite bits_zero_ext, bits_shru', A by omega.
+ destruct (zlt (i + Z) zwordsize); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+ rewrite bits_shl' by omega. fold Y.
+ destruct (zlt (i + Z) Y).
++ rewrite zlt_false by omega. auto.
++ rewrite zlt_true by omega. f_equal; omega.
+Qed.
+
+Theorem shr'_shl':
+ forall x y z, Int.ltu y iwordsize' = true -> Int.ltu z iwordsize' = true ->
+ shr' (shl' x y) z =
+ if Int.ltu z y then shl' (sign_ext (zwordsize - Int.unsigned y) x) (Int.sub y z)
+ else sign_ext (zwordsize - Int.unsigned z) (shr' x (Int.sub z y)).
+Proof.
+ intros. apply Int.ltu_inv in H; apply Int.ltu_inv in H0.
+ change (Int.unsigned iwordsize') with zwordsize in *.
+ unfold Int.ltu. set (Y := Int.unsigned y) in *; set (Z := Int.unsigned z) in *.
+ apply same_bits_eq; intros. rewrite bits_shr' by auto. fold Z.
+ rewrite bits_shl' by (destruct (zlt (i + Z) zwordsize); omega). fold Y.
+ destruct (zlt Z Y).
+- assert (A: Int.unsigned (Int.sub y z) = Y - Z).
+ { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. }
+ rewrite bits_shl', A by omega.
+ destruct (zlt i (Y - Z)).
++ apply zlt_true. destruct (zlt (i + Z) zwordsize); omega.
++ rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega).
+ rewrite bits_sign_ext by omega. f_equal.
+ destruct (zlt (i + Z) zwordsize).
+ rewrite zlt_true by omega. omega.
+ rewrite zlt_false by omega. omega.
+- assert (A: Int.unsigned (Int.sub z y) = Z - Y).
+ { apply Int.unsigned_repr. assert (zwordsize < Int.max_unsigned) by reflexivity. omega. }
+ rewrite bits_sign_ext by omega.
+ rewrite bits_shr' by (destruct (zlt i (zwordsize - Z)); omega).
+ rewrite A. rewrite zlt_false by (destruct (zlt (i + Z) zwordsize); omega).
+ f_equal. destruct (zlt i (zwordsize - Z)).
++ rewrite ! zlt_true by omega. omega.
++ rewrite ! zlt_false by omega. rewrite zlt_true by omega. omega.
+Qed.
+
+Lemma shl'_zero_ext:
+ forall n m x, 0 <= n ->
+ shl' (zero_ext n x) m = zero_ext (n + Int.unsigned m) (shl' x m).
+Proof.
+ intros. apply same_bits_eq; intros.
+ rewrite bits_zero_ext, ! bits_shl' by omega.
+ destruct (zlt i (Int.unsigned m)).
+- rewrite zlt_true by omega; auto.
+- rewrite bits_zero_ext by omega.
+ destruct (zlt (i - Int.unsigned m) n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+Qed.
+
+Lemma shl'_sign_ext:
+ forall n m x, 0 < n ->
+ shl' (sign_ext n x) m = sign_ext (n + Int.unsigned m) (shl' x m).
+Proof.
+ intros. generalize (Int.unsigned_range m); intros.
+ apply same_bits_eq; intros.
+ rewrite bits_sign_ext, ! bits_shl' by omega.
+ destruct (zlt i (n + Int.unsigned m)).
+- rewrite bits_shl' by auto. destruct (zlt i (Int.unsigned m)); auto.
+ rewrite bits_sign_ext by omega. f_equal. apply zlt_true. omega.
+- rewrite zlt_false by omega. rewrite bits_shl' by omega. rewrite zlt_false by omega.
+ rewrite bits_sign_ext by omega. f_equal. rewrite zlt_false by omega. omega.
+Qed.
+
+Lemma shru'_zero_ext:
+ forall n m x, 0 <= n ->
+ shru' (zero_ext (n + Int.unsigned m) x) m = zero_ext n (shru' x m).
+Proof.
+ intros. generalize (Int.unsigned_range m); intros.
+ bit_solve; [|omega]. rewrite bits_shru', bits_zero_ext, bits_shru' by omega.
+ destruct (zlt (i + Int.unsigned m) zwordsize).
+* destruct (zlt i n); [rewrite zlt_true by omega|rewrite zlt_false by omega]; auto.
+* destruct (zlt i n); auto.
+Qed.
+
+Lemma shru'_zero_ext_0:
+ forall n m x, n <= Int.unsigned m ->
+ shru' (zero_ext n x) m = zero.
+Proof.
+ intros. generalize (Int.unsigned_range m); intros.
+ bit_solve. rewrite bits_shru', bits_zero_ext by omega.
+ destruct (zlt (i + Int.unsigned m) zwordsize); auto.
+ apply zlt_false. omega.
+Qed.
+
+Lemma shr'_sign_ext:
+ forall n m x, 0 < n -> n + Int.unsigned m < zwordsize ->
+ shr' (sign_ext (n + Int.unsigned m) x) m = sign_ext n (shr' x m).
+Proof.
+ intros. generalize (Int.unsigned_range m); intros.
+ apply same_bits_eq; intros.
+ rewrite bits_sign_ext, bits_shr' by auto.
+ rewrite bits_sign_ext, bits_shr'.
+- f_equal.
+ destruct (zlt i n), (zlt (i + Int.unsigned m) zwordsize).
++ apply zlt_true; omega.
++ apply zlt_true; omega.
++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega.
++ rewrite zlt_false by omega. rewrite zlt_true by omega. omega.
+- destruct (zlt i n); omega.
+- destruct (zlt (i + Int.unsigned m) zwordsize); omega.
+Qed.
+
+Lemma zero_ext_shru'_min:
+ forall s x n, Int.ltu n iwordsize' = true ->
+ zero_ext s (shru' x n) = zero_ext (Z.min s (zwordsize - Int.unsigned n)) (shru' x n).
+Proof.
+ intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H.
+ apply Z.min_case_strong; intros; auto.
+ bit_solve; try omega. rewrite ! bits_shru' by omega.
+ destruct (zlt i (zwordsize - Int.unsigned n)).
+ rewrite zlt_true by omega. auto.
+ destruct (zlt i s); auto. rewrite zlt_false by omega; auto.
+Qed.
+
+Lemma sign_ext_shr'_min:
+ forall s x n, Int.ltu n iwordsize' = true ->
+ sign_ext s (shr' x n) = sign_ext (Z.min s (zwordsize - Int.unsigned n)) (shr' x n).
+Proof.
+ intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H.
+ rewrite Z.min_comm.
+ destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto.
+ apply same_bits_eq; intros. rewrite ! bits_sign_ext by auto.
+ destruct (zlt i (zwordsize - Int.unsigned n)).
+ rewrite zlt_true by omega. auto.
+ assert (C: testbit (shr' x n) (zwordsize - Int.unsigned n - 1) = testbit x (zwordsize - 1)).
+ { rewrite bits_shr' by omega. rewrite zlt_true by omega. f_equal; omega. }
+ rewrite C. destruct (zlt i s); rewrite bits_shr' by omega.
+ rewrite zlt_false by omega. auto.
+ rewrite zlt_false by omega. auto.
+Qed.
+
+Lemma shl'_zero_ext_min:
+ forall s x n, Int.ltu n iwordsize' = true ->
+ shl' (zero_ext s x) n = shl' (zero_ext (Z.min s (zwordsize - Int.unsigned n)) x) n.
+Proof.
+ intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H.
+ apply Z.min_case_strong; intros; auto.
+ apply same_bits_eq; intros. rewrite ! bits_shl' by auto.
+ destruct (zlt i (Int.unsigned n)); auto.
+ rewrite ! bits_zero_ext by omega.
+ destruct (zlt (i - Int.unsigned n) s).
+ rewrite zlt_true by omega; auto.
+ rewrite zlt_false by omega; auto.
+Qed.
+
+Lemma shl'_sign_ext_min:
+ forall s x n, Int.ltu n iwordsize' = true ->
+ shl' (sign_ext s x) n = shl' (sign_ext (Z.min s (zwordsize - Int.unsigned n)) x) n.
+Proof.
+ intros. apply Int.ltu_inv in H. change (Int.unsigned iwordsize') with zwordsize in H.
+ rewrite Z.min_comm.
+ destruct (Z.min_spec (zwordsize - Int.unsigned n) s) as [[A B] | [A B]]; rewrite B; auto.
+ apply same_bits_eq; intros. rewrite ! bits_shl' by auto.
+ destruct (zlt i (Int.unsigned n)); auto.
+ rewrite ! bits_sign_ext by omega. f_equal.
+ destruct (zlt (i - Int.unsigned n) s).
+ rewrite zlt_true by omega; auto.
+ omegaContradiction.
+Qed.
+
(** Powers of two with exponents given as 32-bit ints *)
Definition one_bits' (x: int) : list Int.int :=
@@ -4315,7 +4077,7 @@ Theorem one_bits'_range:
Proof.
intros.
destruct (list_in_map_inv _ _ _ H) as [i0 [EQ IN]].
- exploit Z_one_bits_range; eauto. intros R.
+ exploit Z_one_bits_range; eauto. fold zwordsize. intros R.
unfold Int.ltu. rewrite EQ. rewrite Int.unsigned_repr.
change (Int.unsigned iwordsize') with zwordsize. apply zlt_true. omega.
assert (zwordsize < Int.max_unsigned) by reflexivity. omega.
@@ -4374,7 +4136,7 @@ Lemma is_power2'_correct:
Proof.
unfold is_power2'; intros.
destruct (Z_one_bits wordsize (unsigned n) 0) as [ | i [ | ? ?]] eqn:B; inv H.
- rewrite (Z_one_bits_powerserie (unsigned n)) by (apply unsigned_range).
+ rewrite (Z_one_bits_powerserie wordsize (unsigned n)) by (apply unsigned_range).
rewrite Int.unsigned_repr. rewrite B; simpl. omega.
assert (0 <= i < zwordsize).
{ apply Z_one_bits_range with (unsigned n). rewrite B; auto with coqlib. }
@@ -4956,8 +4718,26 @@ End Int64.
Strategy 0 [Wordsize_64.wordsize].
+Definition int_eq: forall (i1 i2: int), {i1=i2} + {i1<>i2}.
+Proof.
+ generalize Z.eq_dec. intros.
+ destruct i1. destruct i2. generalize (H intval intval0). intro.
+ inversion H0.
+ - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence.
+ - right. intro. inversion H2. contradiction.
+Qed.
+
Notation int64 := Int64.int.
+Definition int64_eq: forall (i1 i2: int64), {i1=i2} + {i1<>i2}.
+Proof.
+ generalize Z.eq_dec. intros.
+ destruct i1. destruct i2. generalize (H intval intval0). intro.
+ inversion H0.
+ - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence.
+ - right. intro. inversion H2. contradiction.
+Qed.
+
Global Opaque Int.repr Int64.repr Byte.repr.
(** * Specialization to offsets in pointer values *)
@@ -5234,6 +5014,15 @@ Strategy 0 [Wordsize_Ptrofs.wordsize].
Notation ptrofs := Ptrofs.int.
+Definition ptrofs_eq: forall (i1 i2: ptrofs), {i1=i2} + {i1<>i2}.
+Proof.
+ generalize Z.eq_dec. intros.
+ destruct i1. destruct i2. generalize (H intval intval0). intro.
+ inversion H0.
+ - subst. left. assert (intrange = intrange0) by (apply proof_irr). congruence.
+ - right. intro. inversion H2. contradiction.
+Qed.
+
Global Opaque Ptrofs.repr.
Hint Resolve Int.modulus_pos Int.eqm_refl Int.eqm_refl2 Int.eqm_sym Int.eqm_trans
diff --git a/lib/IntvSets.v b/lib/IntvSets.v
index 78c20cc5..b97d9882 100644
--- a/lib/IntvSets.v
+++ b/lib/IntvSets.v
@@ -102,7 +102,7 @@ Proof.
simpl. rewrite IHok. tauto.
destruct (zlt h0 l).
simpl. tauto.
- rewrite IHok. intuition.
+ rewrite IHok. intuition idtac.
assert (l0 <= x < h0 \/ l <= x < h) by xomega. tauto.
left; xomega.
left; xomega.
diff --git a/lib/Maps.v b/lib/Maps.v
index cfb866ba..8de3c892 100644
--- a/lib/Maps.v
+++ b/lib/Maps.v
@@ -116,6 +116,19 @@ Module Type TREE.
forall (m1: t A) (m2: t B) (i: elt),
get i (combine f m1 m2) = f (get i m1) (get i m2).
+ Parameter combine_null :
+ forall (A B C: Type) (f: A -> B -> option C),
+ t A -> t B -> t C.
+
+ Axiom gcombine_null:
+ forall (A B C: Type) (f: A -> B -> option C),
+ forall (m1: t A) (m2: t B) (i: elt),
+ get i (combine_null f m1 m2) =
+ match (get i m1), (get i m2) with
+ | (Some x1), (Some x2) => f x1 x2
+ | _, _ => None
+ end.
+
(** Enumerating the bindings of a tree. *)
Parameter elements:
forall (A: Type), t A -> list (elt * A).
@@ -151,6 +164,12 @@ Module Type TREE.
forall (A B: Type) (f: B -> A -> B) (v: B) (m: t A),
fold1 f m v =
List.fold_left (fun a p => f a (snd p)) (elements m) v.
+
+ Parameter bempty_canon :
+ forall (A : Type), t A -> bool.
+ Axiom bempty_canon_correct:
+ forall (A : Type) (tr : t A) (i : elt),
+ bempty_canon tr = true -> get i tr = None.
End TREE.
(** * The abstract signatures of maps *)
@@ -190,7 +209,7 @@ Module PTree <: TREE.
| Leaf : tree A
| Node : tree A -> option A -> tree A -> tree A.
- Arguments Leaf [A].
+ Arguments Leaf {A}.
Arguments Node [A].
Scheme tree_ind := Induction for tree Sort Prop.
@@ -261,6 +280,12 @@ Module PTree <: TREE.
induction i; simpl; auto.
Qed.
+ Definition bempty_canon (A : Type) (tr : t A) : bool :=
+ match tr with
+ | Leaf => true
+ | _ => false
+ end.
+
Theorem gss:
forall (A: Type) (i: positive) (x: A) (m: t A), get i (set i x m) = Some x.
Proof.
@@ -269,7 +294,16 @@ Module PTree <: TREE.
Lemma gleaf : forall (A : Type) (i : positive), get i (Leaf : t A) = None.
Proof. exact gempty. Qed.
-
+
+ Lemma bempty_canon_correct:
+ forall (A : Type) (tr : t A) (i : elt),
+ bempty_canon tr = true -> get i tr = None.
+ Proof.
+ destruct tr; intros.
+ - rewrite gleaf; trivial.
+ - discriminate.
+ Qed.
+
Theorem gso:
forall (A: Type) (i j: positive) (x: A) (m: t A),
i <> j -> get i (set j x m) = get i m.
@@ -625,7 +659,81 @@ Module PTree <: TREE.
auto.
Qed.
- Fixpoint xelements (A : Type) (m : t A) (i : positive)
+ Section COMBINE_NULL.
+
+ Variables A B C: Type.
+ Variable f: A -> B -> option C.
+
+
+ Fixpoint combine_null (m1: t A) (m2: t B) {struct m1} : t C :=
+ match m1, m2 with
+ | (Node l1 o1 r1), (Node l2 o2 r2) =>
+ Node' (combine_null l1 l2)
+ (match o1, o2 with
+ | (Some x1), (Some x2) => f x1 x2
+ | _, _ => None
+ end)
+ (combine_null r1 r2)
+ | _, _ => Leaf
+ end.
+
+ Theorem gcombine_null:
+ forall (m1: t A) (m2: t B) (i: positive),
+ get i (combine_null m1 m2) =
+ match (get i m1), (get i m2) with
+ | (Some x1), (Some x2) => f x1 x2
+ | _, _ => None
+ end.
+ Proof.
+ induction m1; intros; simpl.
+ - rewrite gleaf. rewrite gleaf.
+ reflexivity.
+ - destruct m2; simpl.
+ + rewrite gleaf. rewrite gleaf.
+ destruct get; reflexivity.
+ + rewrite gnode'.
+ destruct i; simpl; try rewrite IHm1_1; try rewrite IHm1; trivial.
+ Qed.
+
+ End COMBINE_NULL.
+
+ Section REMOVE_TREE.
+
+ Variables A B: Type.
+
+ Fixpoint remove_t (m1: t A) (m2: t B) {struct m1} : t A :=
+ match m1, m2 with
+ | Leaf, _ | _, Leaf => m1
+ | (Node l1 o1 r1), (Node l2 o2 r2) =>
+ Node' (remove_t l1 l2)
+ (match o2 with
+ | Some _ => None
+ | None => o1
+ end)
+ (remove_t r1 r2)
+ end.
+
+ Theorem gremove_t:
+ forall m1 : t A,
+ forall m2 : t B,
+ forall i : positive,
+ get i (remove_t m1 m2) = match get i m2 with
+ | None => get i m1
+ | Some _ => None
+ end.
+ Proof.
+ induction m1; intros; simpl.
+ - rewrite gleaf.
+ destruct get; reflexivity.
+ - destruct m2; simpl.
+ + rewrite gleaf.
+ reflexivity.
+ + rewrite gnode'.
+ destruct i; simpl; try rewrite IHm1_1; try rewrite IHm1; trivial.
+ Qed.
+ End REMOVE_TREE.
+
+ Fixpoint xelements (A : Type) (m : t A) (i : positive)
(k: list (positive * A)) {struct m}
: list (positive * A) :=
match m with
@@ -958,6 +1066,36 @@ Module PTree <: TREE.
intros. apply fold1_xelements with (l := @nil (positive * A)).
Qed.
+ Local Open Scope positive.
+ Lemma set_disjoint1:
+ forall (A: Type)(i d : elt) (m: t A) (x y: A),
+ set (i + d) y (set i x m) = set i x (set (i + d) y m).
+ Proof.
+ induction i; destruct d; destruct m; intro; simpl; trivial;
+ intro; congruence.
+ Qed.
+
+ Local Open Scope positive.
+ Lemma set_disjoint:
+ forall (A: Type)(i j : elt) (m: t A) (x y: A),
+ i <> j ->
+ set j y (set i x m) = set i x (set j y m).
+ Proof.
+ intros.
+ destruct (Pos.compare_spec i j) as [Heq | Hlt | Hlt].
+ { congruence. }
+ {
+ rewrite (Pos.lt_iff_add i j) in Hlt.
+ destruct Hlt as [d Hd].
+ subst j.
+ apply set_disjoint1.
+ }
+ rewrite (Pos.lt_iff_add j i) in Hlt.
+ destruct Hlt as [d Hd].
+ subst i.
+ symmetry.
+ apply set_disjoint1.
+ Qed.
End PTree.
(** * An implementation of maps over type [positive] *)
@@ -1035,6 +1173,15 @@ Module PMap <: MAP.
intros. unfold set. simpl. decEq. apply PTree.set2.
Qed.
+ Local Open Scope positive.
+ Lemma set_disjoint:
+ forall (A: Type) (i j : elt) (x y: A) (m: t A),
+ i <> j ->
+ set j y (set i x m) = set i x (set j y m).
+ Proof.
+ intros. unfold set. decEq. apply PTree.set_disjoint. assumption.
+ Qed.
+
End PMap.
(** * An implementation of maps over any type that injects into type [positive] *)
@@ -1102,6 +1249,16 @@ Module IMap(X: INDEXED_TYPE).
intros. unfold set. apply PMap.set2.
Qed.
+ Lemma set_disjoint:
+ forall (A: Type) (i j : elt) (x y: A) (m: t A),
+ i <> j ->
+ set j y (set i x m) = set i x (set j y m).
+ Proof.
+ intros. unfold set. apply PMap.set_disjoint.
+ intro INEQ.
+ assert (i = j) by (apply X.index_inj; auto).
+ auto.
+ Qed.
End IMap.
Module ZIndexed.
diff --git a/lib/Ordered.v b/lib/Ordered.v
index bcf24cbd..1adbd330 100644
--- a/lib/Ordered.v
+++ b/lib/Ordered.v
@@ -21,6 +21,8 @@ Require Import Coqlib.
Require Import Maps.
Require Import Integers.
+Create HintDb ordered_type.
+
(** The ordered type of positive numbers *)
Module OrderedPositive <: OrderedType.
@@ -173,17 +175,17 @@ Definition eq (x y: t) :=
Lemma eq_refl : forall x : t, eq x x.
Proof.
- intros; split; auto.
+ intros; split; auto with ordered_type.
Qed.
Lemma eq_sym : forall x y : t, eq x y -> eq y x.
Proof.
- unfold eq; intros. intuition auto.
+ unfold eq; intros. intuition auto with ordered_type.
Qed.
Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
Proof.
- unfold eq; intros. intuition eauto.
+ unfold eq; intros. intuition eauto with ordered_type.
Qed.
Definition lt (x y: t) :=
@@ -201,7 +203,7 @@ Proof.
case (A.compare (fst x) (fst z)); intro.
assumption.
generalize (A.lt_not_eq H2); intro. elim H5.
- apply A.eq_trans with (fst z). auto. auto.
+ apply A.eq_trans with (fst z). auto. auto with ordered_type.
generalize (@A.lt_not_eq (fst z) (fst y)); intro.
elim H5. apply A.lt_trans with (fst x); auto.
apply A.eq_sym; auto.
diff --git a/lib/Zbits.v b/lib/Zbits.v
new file mode 100644
index 00000000..27586aff
--- /dev/null
+++ b/lib/Zbits.v
@@ -0,0 +1,1101 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Additional operations and proofs about binary integers,
+ on top of the ZArith standard library. *)
+
+Require Import Psatz Zquot.
+Require Import Coqlib.
+
+(** ** Modulo arithmetic *)
+
+(** We define and state properties of equality and arithmetic modulo a
+ positive integer. *)
+
+Section EQ_MODULO.
+
+Variable modul: Z.
+Hypothesis modul_pos: modul > 0.
+
+Definition eqmod (x y: Z) : Prop := exists k, x = k * modul + y.
+
+Lemma eqmod_refl: forall x, eqmod x x.
+Proof.
+ intros; red. exists 0. omega.
+Qed.
+
+Lemma eqmod_refl2: forall x y, x = y -> eqmod x y.
+Proof.
+ intros. subst y. apply eqmod_refl.
+Qed.
+
+Lemma eqmod_sym: forall x y, eqmod x y -> eqmod y x.
+Proof.
+ intros x y [k EQ]; red. exists (-k). subst x. ring.
+Qed.
+
+Lemma eqmod_trans: forall x y z, eqmod x y -> eqmod y z -> eqmod x z.
+Proof.
+ intros x y z [k1 EQ1] [k2 EQ2]; red.
+ exists (k1 + k2). subst x; subst y. ring.
+Qed.
+
+Lemma eqmod_small_eq:
+ forall x y, eqmod x y -> 0 <= x < modul -> 0 <= y < modul -> x = y.
+Proof.
+ intros x y [k EQ] I1 I2.
+ generalize (Zdiv_unique _ _ _ _ EQ I2). intro.
+ rewrite (Z.div_small x modul I1) in H. subst k. omega.
+Qed.
+
+Lemma eqmod_mod_eq:
+ forall x y, eqmod x y -> x mod modul = y mod modul.
+Proof.
+ intros x y [k EQ]. subst x.
+ rewrite Z.add_comm. apply Z_mod_plus. auto.
+Qed.
+
+Lemma eqmod_mod:
+ forall x, eqmod x (x mod modul).
+Proof.
+ intros; red. exists (x / modul).
+ rewrite Z.mul_comm. apply Z_div_mod_eq. auto.
+Qed.
+
+Lemma eqmod_add:
+ forall a b c d, eqmod a b -> eqmod c d -> eqmod (a + c) (b + d).
+Proof.
+ intros a b c d [k1 EQ1] [k2 EQ2]; red.
+ subst a; subst c. exists (k1 + k2). ring.
+Qed.
+
+Lemma eqmod_neg:
+ forall x y, eqmod x y -> eqmod (-x) (-y).
+Proof.
+ intros x y [k EQ]; red. exists (-k). rewrite EQ. ring.
+Qed.
+
+Lemma eqmod_sub:
+ forall a b c d, eqmod a b -> eqmod c d -> eqmod (a - c) (b - d).
+Proof.
+ intros a b c d [k1 EQ1] [k2 EQ2]; red.
+ subst a; subst c. exists (k1 - k2). ring.
+Qed.
+
+Lemma eqmod_mult:
+ forall a b c d, eqmod a c -> eqmod b d -> eqmod (a * b) (c * d).
+Proof.
+ intros a b c d [k1 EQ1] [k2 EQ2]; red.
+ subst a; subst b.
+ exists (k1 * k2 * modul + c * k2 + k1 * d).
+ ring.
+Qed.
+
+End EQ_MODULO.
+
+Lemma eqmod_divides:
+ forall n m x y, eqmod n x y -> Z.divide m n -> eqmod m x y.
+Proof.
+ intros. destruct H as [k1 EQ1]. destruct H0 as [k2 EQ2].
+ exists (k1*k2). rewrite <- Z.mul_assoc. rewrite <- EQ2. auto.
+Qed.
+
+(** ** Fast normalization modulo [2^n] *)
+
+Fixpoint P_mod_two_p (p: positive) (n: nat) {struct n} : Z :=
+ match n with
+ | O => 0
+ | S m =>
+ match p with
+ | xH => 1
+ | xO q => Z.double (P_mod_two_p q m)
+ | xI q => Z.succ_double (P_mod_two_p q m)
+ end
+ end.
+
+Definition Z_mod_two_p (x: Z) (n: nat) : Z :=
+ match x with
+ | Z0 => 0
+ | Zpos p => P_mod_two_p p n
+ | Zneg p => let r := P_mod_two_p p n in if zeq r 0 then 0 else two_power_nat n - r
+ end.
+
+Lemma P_mod_two_p_range:
+ forall n p, 0 <= P_mod_two_p p n < two_power_nat n.
+Proof.
+ induction n; simpl; intros.
+ - rewrite two_power_nat_O. omega.
+ - rewrite two_power_nat_S. destruct p.
+ + generalize (IHn p). rewrite Z.succ_double_spec. omega.
+ + generalize (IHn p). rewrite Z.double_spec. omega.
+ + generalize (two_power_nat_pos n). omega.
+Qed.
+
+Lemma P_mod_two_p_eq:
+ forall n p, P_mod_two_p p n = (Zpos p) mod (two_power_nat n).
+Proof.
+ assert (forall n p, exists y, Zpos p = y * two_power_nat n + P_mod_two_p p n).
+ {
+ induction n; simpl; intros.
+ - rewrite two_power_nat_O. exists (Zpos p). ring.
+ - rewrite two_power_nat_S. destruct p.
+ + destruct (IHn p) as [y EQ]. exists y.
+ change (Zpos p~1) with (2 * Zpos p + 1). rewrite EQ.
+ rewrite Z.succ_double_spec. ring.
+ + destruct (IHn p) as [y EQ]. exists y.
+ change (Zpos p~0) with (2 * Zpos p). rewrite EQ.
+ rewrite (Z.double_spec (P_mod_two_p p n)). ring.
+ + exists 0; omega.
+ }
+ intros.
+ destruct (H n p) as [y EQ].
+ symmetry. apply Zmod_unique with y. auto. apply P_mod_two_p_range.
+Qed.
+
+Lemma Z_mod_two_p_range:
+ forall n x, 0 <= Z_mod_two_p x n < two_power_nat n.
+Proof.
+ intros; unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
+ destruct x.
+ - intuition.
+ - apply P_mod_two_p_range.
+ - set (r := P_mod_two_p p n).
+ assert (0 <= r < two_power_nat n) by apply P_mod_two_p_range.
+ destruct (zeq r 0).
+ + intuition.
+ + Psatz.lia.
+Qed.
+
+Lemma Z_mod_two_p_eq:
+ forall n x, Z_mod_two_p x n = x mod (two_power_nat n).
+Proof.
+ intros. unfold Z_mod_two_p. generalize (two_power_nat_pos n); intros.
+ destruct x.
+ - rewrite Zmod_0_l. auto.
+ - apply P_mod_two_p_eq.
+ - generalize (P_mod_two_p_range n p) (P_mod_two_p_eq n p). intros A B.
+ exploit (Z_div_mod_eq (Zpos p) (two_power_nat n)); auto. intros C.
+ set (q := Zpos p / two_power_nat n) in *.
+ set (r := P_mod_two_p p n) in *.
+ rewrite <- B in C.
+ change (Z.neg p) with (- (Z.pos p)). destruct (zeq r 0).
+ + symmetry. apply Zmod_unique with (-q). rewrite C; rewrite e. Psatz.lia.
+ intuition.
+ + symmetry. apply Zmod_unique with (-q - 1). rewrite C. Psatz.lia.
+ intuition.
+Qed.
+
+(** ** Bit-level operations and properties *)
+
+(** Shift [x] left by one and insert [b] as the low bit of the result. *)
+
+Definition Zshiftin (b: bool) (x: Z) : Z :=
+ if b then Z.succ_double x else Z.double x.
+
+Remark Ztestbit_0: forall n, Z.testbit 0 n = false.
+Proof Z.testbit_0_l.
+
+Remark Ztestbit_1: forall n, Z.testbit 1 n = zeq n 0.
+Proof.
+ intros. destruct n; simpl; auto.
+Qed.
+
+Remark Ztestbit_m1: forall n, 0 <= n -> Z.testbit (-1) n = true.
+Proof.
+ intros. destruct n; simpl; auto.
+Qed.
+
+Remark Zshiftin_spec:
+ forall b x, Zshiftin b x = 2 * x + (if b then 1 else 0).
+Proof.
+ unfold Zshiftin; intros. destruct b.
+ - rewrite Z.succ_double_spec. omega.
+ - rewrite Z.double_spec. omega.
+Qed.
+
+Remark Zshiftin_inj:
+ forall b1 x1 b2 x2,
+ Zshiftin b1 x1 = Zshiftin b2 x2 -> b1 = b2 /\ x1 = x2.
+Proof.
+ intros. rewrite !Zshiftin_spec in H.
+ destruct b1; destruct b2.
+ split; [auto|omega].
+ omegaContradiction.
+ omegaContradiction.
+ split; [auto|omega].
+Qed.
+
+Remark Zdecomp:
+ forall x, x = Zshiftin (Z.odd x) (Z.div2 x).
+Proof.
+ intros. destruct x; simpl.
+ - auto.
+ - destruct p; auto.
+ - destruct p; auto. simpl. rewrite Pos.pred_double_succ. auto.
+Qed.
+
+Remark Ztestbit_shiftin:
+ forall b x n,
+ 0 <= n ->
+ Z.testbit (Zshiftin b x) n = if zeq n 0 then b else Z.testbit x (Z.pred n).
+Proof.
+ intros. rewrite Zshiftin_spec. destruct (zeq n 0).
+ - subst n. destruct b.
+ + apply Z.testbit_odd_0.
+ + rewrite Z.add_0_r. apply Z.testbit_even_0.
+ - assert (0 <= Z.pred n) by omega.
+ set (n' := Z.pred n) in *.
+ replace n with (Z.succ n') by (unfold n'; omega).
+ destruct b.
+ + apply Z.testbit_odd_succ; auto.
+ + rewrite Z.add_0_r. apply Z.testbit_even_succ; auto.
+Qed.
+
+Remark Ztestbit_shiftin_base:
+ forall b x, Z.testbit (Zshiftin b x) 0 = b.
+Proof.
+ intros. rewrite Ztestbit_shiftin. apply zeq_true. omega.
+Qed.
+
+Remark Ztestbit_shiftin_succ:
+ forall b x n, 0 <= n -> Z.testbit (Zshiftin b x) (Z.succ n) = Z.testbit x n.
+Proof.
+ intros. rewrite Ztestbit_shiftin. rewrite zeq_false. rewrite Z.pred_succ. auto.
+ omega. omega.
+Qed.
+
+Lemma Zshiftin_ind:
+ forall (P: Z -> Prop),
+ P 0 ->
+ (forall b x, 0 <= x -> P x -> P (Zshiftin b x)) ->
+ forall x, 0 <= x -> P x.
+Proof.
+ intros. destruct x.
+ - auto.
+ - induction p.
+ + change (P (Zshiftin true (Z.pos p))). auto.
+ + change (P (Zshiftin false (Z.pos p))). auto.
+ + change (P (Zshiftin true 0)). apply H0. omega. auto.
+ - compute in H1. intuition congruence.
+Qed.
+
+Lemma Zshiftin_pos_ind:
+ forall (P: Z -> Prop),
+ P 1 ->
+ (forall b x, 0 < x -> P x -> P (Zshiftin b x)) ->
+ forall x, 0 < x -> P x.
+Proof.
+ intros. destruct x; simpl in H1; try discriminate.
+ induction p.
+ + change (P (Zshiftin true (Z.pos p))). auto.
+ + change (P (Zshiftin false (Z.pos p))). auto.
+ + auto.
+Qed.
+
+(** ** Bit-wise decomposition ([Z.testbit]) *)
+
+Remark Ztestbit_eq:
+ forall n x, 0 <= n ->
+ Z.testbit x n = if zeq n 0 then Z.odd x else Z.testbit (Z.div2 x) (Z.pred n).
+Proof.
+ intros. rewrite (Zdecomp x) at 1. apply Ztestbit_shiftin; auto.
+Qed.
+
+Remark Ztestbit_base:
+ forall x, Z.testbit x 0 = Z.odd x.
+Proof.
+ intros. rewrite Ztestbit_eq. apply zeq_true. omega.
+Qed.
+
+Remark Ztestbit_succ:
+ forall n x, 0 <= n -> Z.testbit x (Z.succ n) = Z.testbit (Z.div2 x) n.
+Proof.
+ intros. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ. auto.
+ omega. omega.
+Qed.
+
+Lemma eqmod_same_bits:
+ forall n x y,
+ (forall i, 0 <= i < Z.of_nat n -> Z.testbit x i = Z.testbit y i) ->
+ eqmod (two_power_nat n) x y.
+Proof.
+ induction n; intros.
+ - change (two_power_nat 0) with 1. exists (x-y); ring.
+ - rewrite two_power_nat_S.
+ assert (eqmod (two_power_nat n) (Z.div2 x) (Z.div2 y)).
+ apply IHn. intros. rewrite <- !Ztestbit_succ. apply H. rewrite Nat2Z.inj_succ; omega.
+ omega. omega.
+ destruct H0 as [k EQ].
+ exists k. rewrite (Zdecomp x). rewrite (Zdecomp y).
+ replace (Z.odd y) with (Z.odd x).
+ rewrite EQ. rewrite !Zshiftin_spec. ring.
+ exploit (H 0). rewrite Nat2Z.inj_succ; omega.
+ rewrite !Ztestbit_base. auto.
+Qed.
+
+Lemma same_bits_eqmod:
+ forall n x y i,
+ eqmod (two_power_nat n) x y -> 0 <= i < Z.of_nat n ->
+ Z.testbit x i = Z.testbit y i.
+Proof.
+ induction n; intros.
+ - simpl in H0. omegaContradiction.
+ - rewrite Nat2Z.inj_succ in H0. rewrite two_power_nat_S in H.
+ rewrite !(Ztestbit_eq i); intuition.
+ destruct H as [k EQ].
+ assert (EQ': Zshiftin (Z.odd x) (Z.div2 x) =
+ Zshiftin (Z.odd y) (k * two_power_nat n + Z.div2 y)).
+ {
+ rewrite (Zdecomp x) in EQ. rewrite (Zdecomp y) in EQ.
+ rewrite EQ. rewrite !Zshiftin_spec. ring.
+ }
+ exploit Zshiftin_inj; eauto. intros [A B].
+ destruct (zeq i 0).
+ + auto.
+ + apply IHn. exists k; auto. omega.
+Qed.
+
+Lemma equal_same_bits:
+ forall x y,
+ (forall i, 0 <= i -> Z.testbit x i = Z.testbit y i) ->
+ x = y.
+Proof Z.bits_inj'.
+
+Lemma Z_one_complement:
+ forall i, 0 <= i ->
+ forall x, Z.testbit (-x-1) i = negb (Z.testbit x i).
+Proof.
+ intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
+ intros i IND POS x.
+ rewrite (Zdecomp x). set (y := Z.div2 x).
+ replace (- Zshiftin (Z.odd x) y - 1)
+ with (Zshiftin (negb (Z.odd x)) (- y - 1)).
+ rewrite !Ztestbit_shiftin; auto.
+ destruct (zeq i 0). auto. apply IND. omega.
+ rewrite !Zshiftin_spec. destruct (Z.odd x); simpl negb; ring.
+Qed.
+
+Lemma Ztestbit_above:
+ forall n x i,
+ 0 <= x < two_power_nat n ->
+ i >= Z.of_nat n ->
+ Z.testbit x i = false.
+Proof.
+ induction n; intros.
+ - change (two_power_nat 0) with 1 in H.
+ replace x with 0 by omega.
+ apply Z.testbit_0_l.
+ - rewrite Nat2Z.inj_succ in H0. rewrite Ztestbit_eq. rewrite zeq_false.
+ apply IHn. rewrite two_power_nat_S in H. rewrite (Zdecomp x) in H.
+ rewrite Zshiftin_spec in H. destruct (Z.odd x); omega.
+ omega. omega. omega.
+Qed.
+
+Lemma Ztestbit_above_neg:
+ forall n x i,
+ -two_power_nat n <= x < 0 ->
+ i >= Z.of_nat n ->
+ Z.testbit x i = true.
+Proof.
+ intros. set (y := -x-1).
+ assert (Z.testbit y i = false).
+ apply Ztestbit_above with n.
+ unfold y; omega. auto.
+ unfold y in H1. rewrite Z_one_complement in H1.
+ change true with (negb false). rewrite <- H1. rewrite negb_involutive; auto.
+ omega.
+Qed.
+
+Lemma Zsign_bit:
+ forall n x,
+ 0 <= x < two_power_nat (S n) ->
+ Z.testbit x (Z.of_nat n) = if zlt x (two_power_nat n) then false else true.
+Proof.
+ induction n; intros.
+ - change (two_power_nat 1) with 2 in H.
+ assert (x = 0 \/ x = 1) by omega.
+ destruct H0; subst x; reflexivity.
+ - rewrite Nat2Z.inj_succ. rewrite Ztestbit_eq. rewrite zeq_false. rewrite Z.pred_succ.
+ rewrite IHn. rewrite two_power_nat_S.
+ destruct (zlt (Z.div2 x) (two_power_nat n)); rewrite (Zdecomp x); rewrite Zshiftin_spec.
+ rewrite zlt_true. auto. destruct (Z.odd x); omega.
+ rewrite zlt_false. auto. destruct (Z.odd x); omega.
+ rewrite (Zdecomp x) in H; rewrite Zshiftin_spec in H.
+ rewrite two_power_nat_S in H. destruct (Z.odd x); omega.
+ omega. omega.
+Qed.
+
+Lemma Ztestbit_le:
+ forall x y,
+ 0 <= y ->
+ (forall i, 0 <= i -> Z.testbit x i = true -> Z.testbit y i = true) ->
+ x <= y.
+Proof.
+ intros x y0 POS0; revert x; pattern y0; apply Zshiftin_ind; auto; intros.
+ - replace x with 0. omega. apply equal_same_bits; intros.
+ rewrite Ztestbit_0. destruct (Z.testbit x i) as [] eqn:E; auto.
+ exploit H; eauto. rewrite Ztestbit_0. auto.
+ - assert (Z.div2 x0 <= x).
+ { apply H0. intros. exploit (H1 (Z.succ i)).
+ omega. rewrite Ztestbit_succ; auto. rewrite Ztestbit_shiftin_succ; auto.
+ }
+ rewrite (Zdecomp x0). rewrite !Zshiftin_spec.
+ destruct (Z.odd x0) as [] eqn:E1; destruct b as [] eqn:E2; try omega.
+ exploit (H1 0). omega. rewrite Ztestbit_base; auto.
+ rewrite Ztestbit_shiftin_base. congruence.
+Qed.
+
+Lemma Ztestbit_mod_two_p:
+ forall n x i,
+ 0 <= n -> 0 <= i ->
+ Z.testbit (x mod (two_p n)) i = if zlt i n then Z.testbit x i else false.
+Proof.
+ intros n0 x i N0POS. revert x i; pattern n0; apply natlike_ind; auto.
+ - intros. change (two_p 0) with 1. rewrite Zmod_1_r. rewrite Z.testbit_0_l.
+ rewrite zlt_false; auto. omega.
+ - intros. rewrite two_p_S; auto.
+ replace (x0 mod (2 * two_p x))
+ with (Zshiftin (Z.odd x0) (Z.div2 x0 mod two_p x)).
+ rewrite Ztestbit_shiftin; auto. rewrite (Ztestbit_eq i x0); auto. destruct (zeq i 0).
+ + rewrite zlt_true; auto. omega.
+ + rewrite H0. destruct (zlt (Z.pred i) x).
+ * rewrite zlt_true; auto. omega.
+ * rewrite zlt_false; auto. omega.
+ * omega.
+ + rewrite (Zdecomp x0) at 3. set (x1 := Z.div2 x0). symmetry.
+ apply Zmod_unique with (x1 / two_p x).
+ rewrite !Zshiftin_spec. rewrite Z.add_assoc. f_equal.
+ transitivity (2 * (two_p x * (x1 / two_p x) + x1 mod two_p x)).
+ f_equal. apply Z_div_mod_eq. apply two_p_gt_ZERO; auto.
+ ring.
+ rewrite Zshiftin_spec. exploit (Z_mod_lt x1 (two_p x)). apply two_p_gt_ZERO; auto.
+ destruct (Z.odd x0); omega.
+Qed.
+
+Corollary Ztestbit_two_p_m1:
+ forall n i, 0 <= n -> 0 <= i ->
+ Z.testbit (two_p n - 1) i = if zlt i n then true else false.
+Proof.
+ intros. replace (two_p n - 1) with ((-1) mod (two_p n)).
+ rewrite Ztestbit_mod_two_p; auto. destruct (zlt i n); auto. apply Ztestbit_m1; auto.
+ apply Zmod_unique with (-1). ring.
+ exploit (two_p_gt_ZERO n). auto. omega.
+Qed.
+
+Corollary Ztestbit_neg_two_p:
+ forall n i, 0 <= n -> 0 <= i ->
+ Z.testbit (- (two_p n)) i = if zlt i n then false else true.
+Proof.
+ intros.
+ replace (- two_p n) with (- (two_p n - 1) - 1) by omega.
+ rewrite Z_one_complement by auto.
+ rewrite Ztestbit_two_p_m1 by auto.
+ destruct (zlt i n); auto.
+Qed.
+
+Lemma Z_add_is_or:
+ forall i, 0 <= i ->
+ forall x y,
+ (forall j, 0 <= j <= i -> Z.testbit x j && Z.testbit y j = false) ->
+ Z.testbit (x + y) i = Z.testbit x i || Z.testbit y i.
+Proof.
+ intros i0 POS0. pattern i0. apply Zlt_0_ind; auto.
+ intros i IND POS x y EXCL.
+ rewrite (Zdecomp x) in *. rewrite (Zdecomp y) in *.
+ transitivity (Z.testbit (Zshiftin (Z.odd x || Z.odd y) (Z.div2 x + Z.div2 y)) i).
+ - f_equal. rewrite !Zshiftin_spec.
+ exploit (EXCL 0). omega. rewrite !Ztestbit_shiftin_base. intros.
+Opaque Z.mul.
+ destruct (Z.odd x); destruct (Z.odd y); simpl in *; discriminate || ring.
+ - rewrite !Ztestbit_shiftin; auto.
+ destruct (zeq i 0).
+ + auto.
+ + apply IND. omega. intros.
+ exploit (EXCL (Z.succ j)). omega.
+ rewrite !Ztestbit_shiftin_succ. auto.
+ omega. omega.
+Qed.
+
+(** ** Zero and sign extensions *)
+
+(** In pseudo-code:
+<<
+ Fixpoint Zzero_ext (n: Z) (x: Z) : Z :=
+ if zle n 0 then
+ 0
+ else
+ Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
+ Fixpoint Zsign_ext (n: Z) (x: Z) : Z :=
+ if zle n 1 then
+ if Z.odd x then -1 else 0
+ else
+ Zshiftin (Z.odd x) (Zzero_ext (Z.pred n) (Z.div2 x)).
+>>
+ We encode this [nat]-like recursion using the [Z.iter] iteration
+ function, in order to make the [Zzero_ext] and [Zsign_ext]
+ functions efficiently executable within Coq.
+*)
+
+Definition Zzero_ext (n: Z) (x: Z) : Z :=
+ Z.iter n
+ (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
+ (fun x => 0)
+ x.
+
+Definition Zsign_ext (n: Z) (x: Z) : Z :=
+ Z.iter (Z.pred n)
+ (fun rec x => Zshiftin (Z.odd x) (rec (Z.div2 x)))
+ (fun x => if Z.odd x && zlt 0 n then -1 else 0)
+ x.
+
+Lemma Ziter_base:
+ forall (A: Type) n (f: A -> A) x, n <= 0 -> Z.iter n f x = x.
+Proof.
+ intros. unfold Z.iter. destruct n; auto. compute in H. elim H; auto.
+Qed.
+
+Lemma Ziter_succ:
+ forall (A: Type) n (f: A -> A) x,
+ 0 <= n -> Z.iter (Z.succ n) f x = f (Z.iter n f x).
+Proof.
+ intros. destruct n; simpl.
+ - auto.
+ - rewrite Pos.add_1_r. apply Pos.iter_succ.
+ - compute in H. elim H; auto.
+Qed.
+
+Lemma Znatlike_ind:
+ forall (P: Z -> Prop),
+ (forall n, n <= 0 -> P n) ->
+ (forall n, 0 <= n -> P n -> P (Z.succ n)) ->
+ forall n, P n.
+Proof.
+ intros. destruct (zle 0 n).
+ apply natlike_ind; auto. apply H; omega.
+ apply H. omega.
+Qed.
+
+Lemma Zzero_ext_spec:
+ forall n x i, 0 <= i ->
+ Z.testbit (Zzero_ext n x) i = if zlt i n then Z.testbit x i else false.
+Proof.
+ unfold Zzero_ext. induction n using Znatlike_ind.
+ - intros. rewrite Ziter_base; auto.
+ rewrite zlt_false. rewrite Ztestbit_0; auto. omega.
+ - intros. rewrite Ziter_succ; auto.
+ rewrite Ztestbit_shiftin; auto.
+ rewrite (Ztestbit_eq i x); auto.
+ destruct (zeq i 0).
+ + subst i. rewrite zlt_true; auto. omega.
+ + rewrite IHn. destruct (zlt (Z.pred i) n).
+ rewrite zlt_true; auto. omega.
+ rewrite zlt_false; auto. omega.
+ omega.
+Qed.
+
+Lemma Zsign_ext_spec:
+ forall n x i, 0 <= i ->
+ Z.testbit (Zsign_ext n x) i = Z.testbit x (if zlt i n then i else n - 1).
+Proof.
+ intros n0 x i I0. unfold Zsign_ext.
+ unfold proj_sumbool; destruct (zlt 0 n0) as [N0|N0]; simpl.
+- revert x i I0. pattern n0. apply Zlt_lower_bound_ind with (z := 1); [ | omega ].
+ unfold Zsign_ext. intros.
+ destruct (zeq x 1).
+ + subst x; simpl.
+ replace (if zlt i 1 then i else 0) with 0.
+ rewrite Ztestbit_base.
+ destruct (Z.odd x0); [ apply Ztestbit_m1; auto | apply Ztestbit_0 ].
+ destruct (zlt i 1); omega.
+ + set (x1 := Z.pred x). replace x1 with (Z.succ (Z.pred x1)) by omega.
+ rewrite Ziter_succ by (unfold x1; omega). rewrite Ztestbit_shiftin by auto.
+ destruct (zeq i 0).
+ * subst i. rewrite zlt_true. rewrite Ztestbit_base; auto. omega.
+ * rewrite H by (unfold x1; omega).
+ unfold x1; destruct (zlt (Z.pred i) (Z.pred x)).
+ ** rewrite zlt_true by omega.
+ rewrite (Ztestbit_eq i x0) by omega.
+ rewrite zeq_false by omega. auto.
+ ** rewrite zlt_false by omega.
+ rewrite (Ztestbit_eq (x - 1) x0) by omega.
+ rewrite zeq_false by omega. auto.
+- rewrite Ziter_base by omega. rewrite andb_false_r.
+ rewrite Z.testbit_0_l, Z.testbit_neg_r. auto.
+ destruct (zlt i n0); omega.
+Qed.
+
+(** [Zzero_ext n x] is [x modulo 2^n] *)
+
+Lemma Zzero_ext_mod:
+ forall n x, 0 <= n -> Zzero_ext n x = x mod (two_p n).
+Proof.
+ intros. apply equal_same_bits; intros.
+ rewrite Zzero_ext_spec, Ztestbit_mod_two_p by auto. auto.
+Qed.
+
+(** [Zzero_ext n x] is the unique integer congruent to [x] modulo [2^n] in the range [0...2^n-1]. *)
+
+Lemma Zzero_ext_range:
+ forall n x, 0 <= n -> 0 <= Zzero_ext n x < two_p n.
+Proof.
+ intros. rewrite Zzero_ext_mod; auto. apply Z_mod_lt. apply two_p_gt_ZERO. omega.
+Qed.
+
+Lemma eqmod_Zzero_ext:
+ forall n x, 0 <= n -> eqmod (two_p n) (Zzero_ext n x) x.
+Proof.
+ intros. rewrite Zzero_ext_mod; auto. apply eqmod_sym. apply eqmod_mod.
+ apply two_p_gt_ZERO. omega.
+Qed.
+
+(** Relation between [Zsign_ext n x] and (Zzero_ext n x] *)
+
+Lemma Zsign_ext_zero_ext:
+ forall n, 0 <= n -> forall x,
+ Zsign_ext n x = Zzero_ext n x - (if Z.testbit x (n - 1) then two_p n else 0).
+Proof.
+ intros. apply equal_same_bits; intros.
+ rewrite Zsign_ext_spec by auto.
+ destruct (Z.testbit x (n - 1)) eqn:SIGNBIT.
+- set (n' := - two_p n).
+ replace (Zzero_ext n x - two_p n) with (Zzero_ext n x + n') by (unfold n'; omega).
+ rewrite Z_add_is_or; auto.
+ rewrite Zzero_ext_spec by auto. unfold n'; rewrite Ztestbit_neg_two_p by omega.
+ destruct (zlt i n). rewrite orb_false_r; auto. auto.
+ intros. rewrite Zzero_ext_spec by omega. unfold n'; rewrite Ztestbit_neg_two_p by omega.
+ destruct (zlt j n); auto using andb_false_r.
+- replace (Zzero_ext n x - 0) with (Zzero_ext n x) by omega.
+ rewrite Zzero_ext_spec by auto.
+ destruct (zlt i n); auto.
+Qed.
+
+(** [Zsign_ext n x] is the unique integer congruent to [x] modulo [2^n]
+ in the range [-2^(n-1)...2^(n-1) - 1]. *)
+
+Lemma Zsign_ext_range:
+ forall n x, 0 < n -> -two_p (n-1) <= Zsign_ext n x < two_p (n-1).
+Proof.
+ intros.
+ assert (A: 0 <= Zzero_ext n x < two_p n) by (apply Zzero_ext_range; omega).
+ assert (B: Z.testbit (Zzero_ext n x) (n - 1) =
+ if zlt (Zzero_ext n x) (two_p (n - 1)) then false else true).
+ { set (N := Z.to_nat (n - 1)).
+ generalize (Zsign_bit N (Zzero_ext n x)).
+ rewrite ! two_power_nat_two_p.
+ rewrite inj_S. unfold N; rewrite Z2Nat.id by omega.
+ intros X; apply X. replace (Z.succ (n - 1)) with n by omega. exact A.
+ }
+ assert (C: two_p n = 2 * two_p (n - 1)).
+ { rewrite <- two_p_S by omega. f_equal; omega. }
+ rewrite Zzero_ext_spec, zlt_true in B by omega.
+ rewrite Zsign_ext_zero_ext by omega. rewrite B.
+ destruct (zlt (Zzero_ext n x) (two_p (n - 1))); omega.
+Qed.
+
+Lemma eqmod_Zsign_ext:
+ forall n x, 0 <= n ->
+ eqmod (two_p n) (Zsign_ext n x) x.
+Proof.
+ intros. rewrite Zsign_ext_zero_ext by auto.
+ apply eqmod_trans with (x - 0).
+ apply eqmod_sub.
+ apply eqmod_Zzero_ext; omega.
+ exists (if Z.testbit x (n - 1) then 1 else 0). destruct (Z.testbit x (n - 1)); ring.
+ apply eqmod_refl2; omega.
+Qed.
+
+(** ** Decomposition of a number as a sum of powers of two. *)
+
+Fixpoint Z_one_bits (n: nat) (x: Z) (i: Z) {struct n}: list Z :=
+ match n with
+ | O => nil
+ | S m =>
+ if Z.odd x
+ then i :: Z_one_bits m (Z.div2 x) (i+1)
+ else Z_one_bits m (Z.div2 x) (i+1)
+ end.
+
+Fixpoint powerserie (l: list Z): Z :=
+ match l with
+ | nil => 0
+ | x :: xs => two_p x + powerserie xs
+ end.
+
+Lemma Z_one_bits_powerserie:
+ forall n x, 0 <= x < two_power_nat n -> x = powerserie (Z_one_bits n x 0).
+Proof.
+ assert (forall n x i,
+ 0 <= i ->
+ 0 <= x < two_power_nat n ->
+ x * two_p i = powerserie (Z_one_bits n x i)).
+ {
+ induction n; intros.
+ simpl. rewrite two_power_nat_O in H0.
+ assert (x = 0) by omega. subst x. omega.
+ rewrite two_power_nat_S in H0. simpl Z_one_bits.
+ rewrite (Zdecomp x) in H0. rewrite Zshiftin_spec in H0.
+ assert (EQ: Z.div2 x * two_p (i + 1) = powerserie (Z_one_bits n (Z.div2 x) (i + 1))).
+ apply IHn. omega.
+ destruct (Z.odd x); omega.
+ rewrite two_p_is_exp in EQ. change (two_p 1) with 2 in EQ.
+ rewrite (Zdecomp x) at 1. rewrite Zshiftin_spec.
+ destruct (Z.odd x); simpl powerserie; rewrite <- EQ; ring.
+ omega. omega.
+ }
+ intros. rewrite <- H. change (two_p 0) with 1. omega.
+ omega. exact H0.
+Qed.
+
+Lemma Z_one_bits_range:
+ forall n x i, In i (Z_one_bits n x 0) -> 0 <= i < Z.of_nat n.
+Proof.
+ assert (forall n x i j,
+ In j (Z_one_bits n x i) -> i <= j < i + Z.of_nat n).
+ {
+ induction n; simpl In.
+ tauto.
+ intros x i j. rewrite Nat2Z.inj_succ.
+ assert (In j (Z_one_bits n (Z.div2 x) (i + 1)) -> i <= j < i + Z.succ (Z.of_nat n)).
+ intros. exploit IHn; eauto. omega.
+ destruct (Z.odd x); simpl.
+ intros [A|B]. subst j. omega. auto.
+ auto.
+ }
+ intros. generalize (H n x 0 i H0). omega.
+Qed.
+
+Remark Z_one_bits_zero:
+ forall n i, Z_one_bits n 0 i = nil.
+Proof.
+ induction n; intros; simpl; auto.
+Qed.
+
+Remark Z_one_bits_two_p:
+ forall n x i,
+ 0 <= x < Z.of_nat n ->
+ Z_one_bits n (two_p x) i = (i + x) :: nil.
+Proof.
+ induction n; intros; simpl. simpl in H. omegaContradiction.
+ rewrite Nat2Z.inj_succ in H.
+ assert (x = 0 \/ 0 < x) by omega. destruct H0.
+ subst x; simpl. decEq. omega. apply Z_one_bits_zero.
+ assert (Z.odd (two_p x) = false /\ Z.div2 (two_p x) = two_p (x-1)).
+ apply Zshiftin_inj. rewrite <- Zdecomp. rewrite !Zshiftin_spec.
+ rewrite <- two_p_S. rewrite Z.add_0_r. f_equal; omega. omega.
+ destruct H1 as [A B]; rewrite A; rewrite B.
+ rewrite IHn. f_equal; omega. omega.
+Qed.
+
+(** ** Recognition of powers of two *)
+
+Fixpoint P_is_power2 (p: positive) : bool :=
+ match p with
+ | xH => true
+ | xO q => P_is_power2 q
+ | xI q => false
+ end.
+
+Definition Z_is_power2 (x: Z) : option Z :=
+ match x with
+ | Z0 => None
+ | Zpos p => if P_is_power2 p then Some (Z.log2 x) else None
+ | Zneg _ => None
+ end.
+
+Remark P_is_power2_sound:
+ forall p, P_is_power2 p = true -> Z.pos p = two_p (Z.log2 (Z.pos p)).
+Proof.
+ induction p; simpl P_is_power2; intros.
+- discriminate.
+- change (Z.pos p~0) with (2 * Z.pos p). apply IHp in H.
+ rewrite Z.log2_double by xomega. rewrite two_p_S. congruence.
+ apply Z.log2_nonneg.
+- reflexivity.
+Qed.
+
+Lemma Z_is_power2_nonneg:
+ forall x i, Z_is_power2 x = Some i -> 0 <= i.
+Proof.
+ unfold Z_is_power2; intros. destruct x; try discriminate.
+ destruct (P_is_power2 p) eqn:P; try discriminate.
+ replace i with (Z.log2 (Z.pos p)) by congruence. apply Z.log2_nonneg.
+Qed.
+
+Lemma Z_is_power2_sound:
+ forall x i, Z_is_power2 x = Some i -> x = two_p i /\ i = Z.log2 x.
+Proof.
+ unfold Z_is_power2; intros. destruct x; try discriminate.
+ destruct (P_is_power2 p) eqn:P; try discriminate.
+ apply P_is_power2_sound in P. rewrite P; split; congruence.
+Qed.
+
+Corollary Z_is_power2_range:
+ forall n x i,
+ 0 <= n -> 0 <= x < two_p n -> Z_is_power2 x = Some i -> 0 <= i < n.
+Proof.
+ intros.
+ assert (x <> 0) by (red; intros; subst x; discriminate).
+ apply Z_is_power2_sound in H1. destruct H1 as [P Q]. subst i.
+ split. apply Z.log2_nonneg. apply Z.log2_lt_pow2. omega. rewrite <- two_p_equiv; tauto.
+Qed.
+
+Lemma Z_is_power2_complete:
+ forall i, 0 <= i -> Z_is_power2 (two_p i) = Some i.
+Proof.
+Opaque Z.log2.
+ assert (A: forall x i, Z_is_power2 x = Some i -> Z_is_power2 (2 * x) = Some (Z.succ i)).
+ { destruct x; simpl; intros; try discriminate.
+ change (2 * Z.pos p) with (Z.pos (xO p)); simpl.
+ destruct (P_is_power2 p); inv H. rewrite <- Z.log2_double by xomega. auto.
+ }
+ induction i using Znatlike_ind; intros.
+- replace i with 0 by omega. reflexivity.
+- rewrite two_p_S by omega. apply A. apply IHi; omega.
+Qed.
+
+Definition Z_is_power2m1 (x: Z) : option Z := Z_is_power2 (Z.succ x).
+
+Lemma Z_is_power2m1_nonneg:
+ forall x i, Z_is_power2m1 x = Some i -> 0 <= i.
+Proof.
+ unfold Z_is_power2m1; intros. eapply Z_is_power2_nonneg; eauto.
+Qed.
+
+Lemma Z_is_power2m1_sound:
+ forall x i, Z_is_power2m1 x = Some i -> x = two_p i - 1.
+Proof.
+ unfold Z_is_power2m1; intros. apply Z_is_power2_sound in H. omega.
+Qed.
+
+Lemma Z_is_power2m1_complete:
+ forall i, 0 <= i -> Z_is_power2m1 (two_p i - 1) = Some i.
+Proof.
+ intros. unfold Z_is_power2m1. replace (Z.succ (two_p i - 1)) with (two_p i) by omega.
+ apply Z_is_power2_complete; auto.
+Qed.
+
+Lemma Z_is_power2m1_range:
+ forall n x i,
+ 0 <= n -> 0 <= x < two_p n -> Z_is_power2m1 x = Some i -> 0 <= i <= n.
+Proof.
+ intros. destruct (zeq x (two_p n - 1)).
+- subst x. rewrite Z_is_power2m1_complete in H1 by auto. inv H1; omega.
+- unfold Z_is_power2m1 in H1. apply (Z_is_power2_range n (Z.succ x) i) in H1; omega.
+Qed.
+
+(** ** Relation between bitwise operations and multiplications / divisions by powers of 2 *)
+
+(** Left shifts and multiplications by powers of 2. *)
+
+Lemma Zshiftl_mul_two_p:
+ forall x n, 0 <= n -> Z.shiftl x n = x * two_p n.
+Proof.
+ intros. destruct n; simpl.
+ - omega.
+ - pattern p. apply Pos.peano_ind.
+ + change (two_power_pos 1) with 2. simpl. ring.
+ + intros. rewrite Pos.iter_succ. rewrite H0.
+ rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
+ change (two_power_pos 1) with 2. ring.
+ - compute in H. congruence.
+Qed.
+
+(** Right shifts and divisions by powers of 2. *)
+
+Lemma Zshiftr_div_two_p:
+ forall x n, 0 <= n -> Z.shiftr x n = x / two_p n.
+Proof.
+ intros. destruct n; unfold Z.shiftr; simpl.
+ - rewrite Zdiv_1_r. auto.
+ - pattern p. apply Pos.peano_ind.
+ + change (two_power_pos 1) with 2. simpl. apply Zdiv2_div.
+ + intros. rewrite Pos.iter_succ. rewrite H0.
+ rewrite Pplus_one_succ_l. rewrite two_power_pos_is_exp.
+ change (two_power_pos 1) with 2.
+ rewrite Zdiv2_div. rewrite Z.mul_comm. apply Zdiv_Zdiv.
+ rewrite two_power_pos_nat. apply two_power_nat_pos. omega.
+ - compute in H. congruence.
+Qed.
+
+(** ** Properties of [shrx] (signed division by a power of 2) *)
+
+Lemma Zquot_Zdiv:
+ forall x y,
+ y > 0 ->
+ Z.quot x y = if zlt x 0 then (x + y - 1) / y else x / y.
+Proof.
+ intros. destruct (zlt x 0).
+ - symmetry. apply Zquot_unique_full with ((x + y - 1) mod y - (y - 1)).
+ + red. right; split. omega.
+ exploit (Z_mod_lt (x + y - 1) y); auto.
+ rewrite Z.abs_eq. omega. omega.
+ + transitivity ((y * ((x + y - 1) / y) + (x + y - 1) mod y) - (y-1)).
+ rewrite <- Z_div_mod_eq. ring. auto. ring.
+ - apply Zquot_Zdiv_pos; omega.
+Qed.
+
+Lemma Zdiv_shift:
+ forall x y, y > 0 ->
+ (x + (y - 1)) / y = x / y + if zeq (Z.modulo x y) 0 then 0 else 1.
+Proof.
+ intros. generalize (Z_div_mod_eq x y H). generalize (Z_mod_lt x y H).
+ set (q := x / y). set (r := x mod y). intros.
+ destruct (zeq r 0).
+ apply Zdiv_unique with (y - 1). rewrite H1. rewrite e. ring. omega.
+ apply Zdiv_unique with (r - 1). rewrite H1. ring. omega.
+Qed.
+
+(** ** Size of integers, in bits. *)
+
+Definition Zsize (x: Z) : Z :=
+ match x with
+ | Zpos p => Zpos (Pos.size p)
+ | _ => 0
+ end.
+
+Remark Zsize_pos: forall x, 0 <= Zsize x.
+Proof.
+ destruct x; simpl. omega. compute; intuition congruence. omega.
+Qed.
+
+Remark Zsize_pos': forall x, 0 < x -> 0 < Zsize x.
+Proof.
+ destruct x; simpl; intros; try discriminate. compute; auto.
+Qed.
+
+Lemma Zsize_shiftin:
+ forall b x, 0 < x -> Zsize (Zshiftin b x) = Z.succ (Zsize x).
+Proof.
+ intros. destruct x; compute in H; try discriminate.
+ destruct b.
+ change (Zshiftin true (Zpos p)) with (Zpos (p~1)).
+ simpl. f_equal. rewrite Pos.add_1_r; auto.
+ change (Zshiftin false (Zpos p)) with (Zpos (p~0)).
+ simpl. f_equal. rewrite Pos.add_1_r; auto.
+Qed.
+
+Lemma Ztestbit_size_1:
+ forall x, 0 < x -> Z.testbit x (Z.pred (Zsize x)) = true.
+Proof.
+ intros x0 POS0; pattern x0; apply Zshiftin_pos_ind; auto.
+ intros. rewrite Zsize_shiftin; auto.
+ replace (Z.pred (Z.succ (Zsize x))) with (Z.succ (Z.pred (Zsize x))) by omega.
+ rewrite Ztestbit_shiftin_succ. auto. generalize (Zsize_pos' x H); omega.
+Qed.
+
+Lemma Ztestbit_size_2:
+ forall x, 0 <= x -> forall i, i >= Zsize x -> Z.testbit x i = false.
+Proof.
+ intros x0 POS0. destruct (zeq x0 0).
+ - subst x0; intros. apply Ztestbit_0.
+ - pattern x0; apply Zshiftin_pos_ind.
+ + simpl. intros. change 1 with (Zshiftin true 0). rewrite Ztestbit_shiftin.
+ rewrite zeq_false. apply Ztestbit_0. omega. omega.
+ + intros. rewrite Zsize_shiftin in H1; auto.
+ generalize (Zsize_pos' _ H); intros.
+ rewrite Ztestbit_shiftin. rewrite zeq_false. apply H0. omega.
+ omega. omega.
+ + omega.
+Qed.
+
+Lemma Zsize_interval_1:
+ forall x, 0 <= x -> 0 <= x < two_p (Zsize x).
+Proof.
+ intros.
+ assert (x = x mod (two_p (Zsize x))).
+ apply equal_same_bits; intros.
+ rewrite Ztestbit_mod_two_p; auto.
+ destruct (zlt i (Zsize x)). auto. apply Ztestbit_size_2; auto.
+ apply Zsize_pos; auto.
+ rewrite H0 at 1. rewrite H0 at 3. apply Z_mod_lt. apply two_p_gt_ZERO. apply Zsize_pos; auto.
+Qed.
+
+Lemma Zsize_interval_2:
+ forall x n, 0 <= n -> 0 <= x < two_p n -> n >= Zsize x.
+Proof.
+ intros. set (N := Z.to_nat n).
+ assert (Z.of_nat N = n) by (apply Z2Nat.id; auto).
+ rewrite <- H1 in H0. rewrite <- two_power_nat_two_p in H0.
+ destruct (zeq x 0).
+ subst x; simpl; omega.
+ destruct (zlt n (Zsize x)); auto.
+ exploit (Ztestbit_above N x (Z.pred (Zsize x))). auto. omega.
+ rewrite Ztestbit_size_1. congruence. omega.
+Qed.
+
+Lemma Zsize_monotone:
+ forall x y, 0 <= x <= y -> Zsize x <= Zsize y.
+Proof.
+ intros. apply Z.ge_le. apply Zsize_interval_2. apply Zsize_pos.
+ exploit (Zsize_interval_1 y). omega.
+ omega.
+Qed.
+
+(** ** Bit insertion, bit extraction *)
+
+(** Extract and optionally sign-extend bits [from...from+len-1] of [x] *)
+Definition Zextract_u (x: Z) (from: Z) (len: Z) : Z :=
+ Zzero_ext len (Z.shiftr x from).
+
+Definition Zextract_s (x: Z) (from: Z) (len: Z) : Z :=
+ Zsign_ext len (Z.shiftr x from).
+
+Lemma Zextract_u_spec:
+ forall x from len i,
+ 0 <= from -> 0 <= len -> 0 <= i ->
+ Z.testbit (Zextract_u x from len) i =
+ if zlt i len then Z.testbit x (from + i) else false.
+Proof.
+ unfold Zextract_u; intros. rewrite Zzero_ext_spec, Z.shiftr_spec by auto.
+ rewrite Z.add_comm. auto.
+Qed.
+
+Lemma Zextract_s_spec:
+ forall x from len i,
+ 0 <= from -> 0 < len -> 0 <= i ->
+ Z.testbit (Zextract_s x from len) i =
+ Z.testbit x (from + (if zlt i len then i else len - 1)).
+Proof.
+ unfold Zextract_s; intros. rewrite Zsign_ext_spec by auto. rewrite Z.shiftr_spec.
+ rewrite Z.add_comm. auto.
+ destruct (zlt i len); omega.
+Qed.
+
+(** Insert bits [0...len-1] of [y] into bits [to...to+len-1] of [x] *)
+
+Definition Zinsert (x y: Z) (to: Z) (len: Z) : Z :=
+ let mask := Z.shiftl (two_p len - 1) to in
+ Z.lor (Z.land (Z.shiftl y to) mask) (Z.ldiff x mask).
+
+Lemma Zinsert_spec:
+ forall x y to len i,
+ 0 <= to -> 0 <= len -> 0 <= i ->
+ Z.testbit (Zinsert x y to len) i =
+ if zle to i && zlt i (to + len)
+ then Z.testbit y (i - to)
+ else Z.testbit x i.
+Proof.
+ unfold Zinsert; intros. set (mask := two_p len - 1).
+ assert (M: forall j, 0 <= j -> Z.testbit mask j = if zlt j len then true else false).
+ { intros; apply Ztestbit_two_p_m1; auto. }
+ rewrite Z.lor_spec, Z.land_spec, Z.ldiff_spec by auto.
+ destruct (zle to i).
+- rewrite ! Z.shiftl_spec by auto. rewrite ! M by omega.
+ unfold proj_sumbool; destruct (zlt (i - to) len); simpl;
+ rewrite andb_true_r, andb_false_r.
++ rewrite zlt_true by omega. apply orb_false_r.
++ rewrite zlt_false by omega; auto.
+- rewrite ! Z.shiftl_spec_low by omega. simpl. apply andb_true_r.
+Qed.
diff --git a/mppa_k1c/Archi.v b/mppa_k1c/Archi.v
index bbe66c5b..69b32c7c 100644
--- a/mppa_k1c/Archi.v
+++ b/mppa_k1c/Archi.v
@@ -14,11 +14,10 @@
(* *)
(* *********************************************************************)
-(** Architecture-dependent parameters for RISC-V *)
+(** Architecture-dependent parameters for MPPA K1c. Mostly copied from the Risc-V backend *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+Require Import Binary Bits.
Definition ptr64 := true.
@@ -34,6 +33,8 @@ Proof.
unfold splitlong. destruct ptr64; simpl; congruence.
Qed.
+(** THIS IS NOT CHECKED ! NONE OF THIS ! *)
+
(** Section 7.3: "Except when otherwise stated, if the result of a
floating-point operation is NaN, it is the canonical NaN. The
canonical NaN has a positive sign and all significand bits clear
@@ -41,23 +42,36 @@ Qed.
We need to extend the [choose_binop_pl] functions to account for
this case. *)
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (false, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (false, iter_nat 22 _ xO xH).
+
+(* Always choose the first NaN argument, if any *)
+
+Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_64 | n :: _ => n end.
+
+Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_32 | n :: _ => n end.
+
+Definition fpu_returns_default_qNaN := false.
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- false. (**r always choose first NaN *)
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. auto. Qed.
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (false, iter_nat 22 _ xO xH).
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. auto. Qed.
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- false. (**r always choose first NaN *)
+Definition fma_order {A: Type} (x y z: A) := (x, z, y).
+Definition fma_invalid_mul_is_nan := false.
Definition float_of_single_preserves_sNaN := false.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
float_of_single_preserves_sNaN.
(** Whether to generate position-independent code or not *)
diff --git a/mppa_k1c/Asm.v b/mppa_k1c/Asm.v
index 1774b102..189e0c76 100644
--- a/mppa_k1c/Asm.v
+++ b/mppa_k1c/Asm.v
@@ -1,736 +1,753 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* Prashanth Mundkur, SRI International *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* The contributions by Prashanth Mundkur are reused and adapted *)
-(* under the terms of a Contributor License Agreement between *)
-(* SRI International and INRIA. *)
-(* *)
-(* *********************************************************************)
-
-(** Abstract syntax and semantics for K1c assembly language. *)
-
-Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import ExtValues.
-Require Import Memory.
-Require Import Events.
-Require Import Globalenvs.
-Require Import Smallstep.
-Require Import Locations.
-Require Stacklayout.
-Require Import Conventions.
-Require Import Asmvliw.
-Require Import Linking.
-Require Import Errors.
-
-(** Definitions for OCaml code *)
-Definition label := positive.
-Definition preg := preg.
-
-Inductive addressing : Type :=
- | AOff (ofs: offset)
- | AReg (ro: ireg)
- | ARegXS (ro: ireg)
-.
-
-(** Syntax *)
-Inductive instruction : Type :=
- (** pseudo instructions *)
- | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *)
- | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *)
- | Plabel (lbl: label) (**r define a code label *)
- | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)
- | Pbuiltin: external_function -> list (builtin_arg preg)
- -> builtin_res preg -> instruction (**r built-in function (pseudo) *)
- | Psemi (**r semi colon separating bundles *)
- | Pnop (**r instruction that does nothing *)
-
- (** builtins *)
- | Pclzll (rd rs: ireg)
- | Pstsud (rd rs1 rs2: ireg)
-
- (** Control flow instructions *)
- | Pget (rd: ireg) (rs: preg) (**r get system register *)
- | Pset (rd: preg) (rs: ireg) (**r set system register *)
- | Pret (**r return *)
- | Pcall (l: label) (**r function call *)
- | Picall (rs: ireg) (**r function call on register *)
- (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
- | Pgoto (l: label) (**r goto *)
- | Pigoto (rs: ireg) (**r goto from register *)
- | Pj_l (l: label) (**r jump to label *)
- | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *)
- | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *)
- | Pjumptable (r: ireg) (labels: list label)
-
- (* For builtins *)
- | Ploopdo (count: ireg) (loopend: label)
- | Pgetn (n: int) (dst: ireg)
- | Psetn (n: int) (src: ireg)
- | Pwfxl (n: int) (src: ireg)
- | Pwfxm (n: int) (src: ireg)
- | Pldu (dst: ireg) (addr: ireg)
- | Plbzu (dst: ireg) (addr: ireg)
- | Plhzu (dst: ireg) (addr: ireg)
- | Plwzu (dst: ireg) (addr: ireg)
- | Pawait
- | Psleep
- | Pstop
- | Pbarrier
- | Pfence
- | Pdinval
- | Pdinvall (addr: ireg)
- | Pdtouchl (addr: ireg)
- | Piinval
- | Piinvals (addr: ireg)
- | Pitouchl (addr: ireg)
- | Pdzerol (addr: ireg)
- | Pafaddd (addr: ireg) (incr_res: ireg)
- | Pafaddw (addr: ireg) (incr_res: ireg)
- | Palclrd (dst: ireg) (addr: ireg)
- | Palclrw (dst: ireg) (addr: ireg)
-
- (** Loads **)
- | Plb (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *)
- | Plbu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *)
- | Plh (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *)
- | Plhu (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *)
- | Plw (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *)
- | Plw_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *)
- | Pld (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *)
- | Pld_a (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *)
- | Pfls (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *)
- | Pfld (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *)
- | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *)
- | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *)
-
- (** Stores **)
- | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *)
- | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *)
- | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *)
- | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *)
- | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *)
- | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *)
- | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *)
- | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *)
-
- | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
- | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
-
- (** Arith RR *)
- | Pmv (rd rs: ireg) (**r register move *)
- | Pnegw (rd rs: ireg) (**r negate word *)
- | Pnegl (rd rs: ireg) (**r negate long *)
- | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *)
- | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *)
- | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *)
-
- | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
- | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
-
- | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
- | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
-
- | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
- | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
-
- | Pfabsd (rd rs: ireg) (**r float absolute double *)
- | Pfabsw (rd rs: ireg) (**r float absolute word *)
- | Pfnegd (rd rs: ireg) (**r float negate double *)
- | Pfnegw (rd rs: ireg) (**r float negate word *)
- | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *)
- | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *)
- | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *)
- | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *)
- | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *)
- | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *)
- | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *)
- | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *)
- | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *)
- | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *)
- | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *)
- | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *)
-
- (** Arith RI32 *)
- | Pmake (rd: ireg) (imm: int) (**r load immediate *)
-
- (** Arith RI64 *)
- | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *)
-
- (** Arith RF32 *)
- | Pmakefs (rd: ireg) (imm: float32)
-
- (** Arith RF64 *)
- | Pmakef (rd: ireg) (imm: float)
-
- (** Arith RRR *)
- | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *)
- | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *)
- | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *)
- | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *)
-
- | Paddw (rd rs1 rs2: ireg) (**r add word *)
- | Psubw (rd rs1 rs2: ireg) (**r sub word *)
- | Pmulw (rd rs1 rs2: ireg) (**r mul word *)
- | Pandw (rd rs1 rs2: ireg) (**r and word *)
- | Pnandw (rd rs1 rs2: ireg) (**r nand word *)
- | Porw (rd rs1 rs2: ireg) (**r or word *)
- | Pnorw (rd rs1 rs2: ireg) (**r nor word *)
- | Pxorw (rd rs1 rs2: ireg) (**r xor word *)
- | Pnxorw (rd rs1 rs2: ireg) (**r xor word *)
- | Pandnw (rd rs1 rs2: ireg) (**r andn word *)
- | Pornw (rd rs1 rs2: ireg) (**r orn word *)
- | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *)
- | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*)
- | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *)
- | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *)
- | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *)
-
- | Paddl (rd rs1 rs2: ireg) (**r add long *)
- | Psubl (rd rs1 rs2: ireg) (**r sub long *)
- | Pandl (rd rs1 rs2: ireg) (**r and long *)
- | Pnandl (rd rs1 rs2: ireg) (**r nand long *)
- | Porl (rd rs1 rs2: ireg) (**r or long *)
- | Pnorl (rd rs1 rs2: ireg) (**r nor long *)
- | Pxorl (rd rs1 rs2: ireg) (**r xor long *)
- | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *)
- | Pandnl (rd rs1 rs2: ireg) (**r andn long *)
- | Pornl (rd rs1 rs2: ireg) (**r orn long *)
- | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *)
- | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *)
- | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *)
- | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *)
- | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*)
- | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *)
-
- | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *)
- | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *)
- | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *)
- | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *)
- | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *)
- | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *)
-
- (** Arith RRI32 *)
- | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *)
-
- | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *)
- | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *)
- | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *)
- | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *)
- | Poriw (rd rs: ireg) (imm: int) (**r or imm word *)
- | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *)
- | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *)
- | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *)
- | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *)
- | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *)
- | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *)
- | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
- | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *)
- | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *)
- | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *)
- | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *)
- | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *)
- | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
- | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *)
- | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *)
-
- (** Arith RRI64 *)
- | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *)
- | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *)
- | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *)
- | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *)
- | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *)
- | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
- | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
- | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *)
- | Pornil (rd rs: ireg) (imm: int64) (**r orn long *)
- | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *)
- | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *)
- | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *)
-.
-
-(** Correspondance between Asmblock and Asm *)
-
-Definition control_to_instruction (c: control) :=
- match c with
- | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res
- | PCtlFlow Asmvliw.Pret => Pret
- | PCtlFlow (Asmvliw.Pcall l) => Pcall l
- | PCtlFlow (Asmvliw.Picall r) => Picall r
- | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l
- | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l
- | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l
- | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l
- | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l
- | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label
- end.
-
-Definition basic_to_instruction (b: basic) :=
- match b with
- (** Special basics *)
- | Asmvliw.Pget rd rs => Pget rd rs
- | Asmvliw.Pset rd rs => Pset rd rs
- | Asmvliw.Pnop => Pnop
- | Asmvliw.Pallocframe sz pos => Pallocframe sz pos
- | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos
-
- (** PArith basics *)
- (* R *)
- | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs
-
- (* RR *)
- | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs
- | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs
- | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs
- | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs
- | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs
- | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs
- | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start
- | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start
- | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start
- | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start
- | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs
- | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs
- | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs
- | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs
- | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs
- | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs
- | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs
- | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs
- | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs
- | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs
- | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs
- | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs
- | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs
- | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs
- | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs
- | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs
-
- (* RI32 *)
- | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm
-
- (* RI64 *)
- | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm
-
- (* RF32 *)
- | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm
-
- (* RF64 *)
- | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm
-
- (* RRR *)
- | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2
- | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2
- | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2
- | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2
- | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2
- | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2
- | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2
- | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2
- | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2
- | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2
- | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2
- | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2
- | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2
- | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2
- | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2
- | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2
- | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2
- | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2
- | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2
-
- | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2
- | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2
- | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2
- | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2
- | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2
- | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2
- | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2
- | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2
- | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2
- | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2
- | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2
- | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2
- | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2
- | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2
- | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2
-
- | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2
- | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2
- | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2
- | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2
- | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2
- | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2
-
- (* RRI32 *)
- | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm
- | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm
- | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm
- | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm
- | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm
- | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm
- | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm
- | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm
- | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm
- | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm
- | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm
- | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm
- | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm
- | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm
- | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm
- | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm
- | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm
- | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm
- | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm
- | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm
-
- (* RRI64 *)
- | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm
- | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm
- | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm
- | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm
- | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm
- | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm
- | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm
- | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm
- | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm
- | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm
- | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm
-
- (** ARRR *)
- | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2
- | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2
- | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2
- | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2
-
- (** ARR *)
- | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start
- | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start
-
- (** ARRI32 *)
- | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm
-
- (** ARRI64 *)
- | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm
-
- (** Load *)
- | PLoadRRO Asmvliw.Plb rd ra ofs => Plb rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plbu rd ra ofs => Plbu rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plh rd ra ofs => Plh rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plhu rd ra ofs => Plhu rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plw rd ra ofs => Plw rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Plw_a rd ra ofs => Plw_a rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pld rd ra ofs => Pld rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pld_a rd ra ofs => Pld_a rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pfls rd ra ofs => Pfls rd ra (AOff ofs)
- | PLoadRRO Asmvliw.Pfld rd ra ofs => Pfld rd ra (AOff ofs)
-
- | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs)
- | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs)
-
- | PLoadRRR Asmvliw.Plb rd ra ro => Plb rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plbu rd ra ro => Plbu rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plh rd ra ro => Plh rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plhu rd ra ro => Plhu rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plw rd ra ro => Plw rd ra (AReg ro)
- | PLoadRRR Asmvliw.Plw_a rd ra ro => Plw_a rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pld rd ra ro => Pld rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pld_a rd ra ro => Pld_a rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pfls rd ra ro => Pfls rd ra (AReg ro)
- | PLoadRRR Asmvliw.Pfld rd ra ro => Pfld rd ra (AReg ro)
-
- | PLoadRRRXS Asmvliw.Plb rd ra ro => Plb rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plbu rd ra ro => Plbu rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plh rd ra ro => Plh rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plhu rd ra ro => Plhu rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plw rd ra ro => Plw rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Plw_a rd ra ro => Plw_a rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pld rd ra ro => Pld rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pld_a rd ra ro => Pld_a rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pfls rd ra ro => Pfls rd ra (ARegXS ro)
- | PLoadRRRXS Asmvliw.Pfld rd ra ro => Pfld rd ra (ARegXS ro)
-
- (** Store *)
- | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs)
- | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs)
-
- | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro)
- | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro)
- | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro)
- | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro)
-
- | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro)
- | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro)
-
- | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs)
- | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs)
- end.
-
-Section RELSEM.
-
-Definition code := list instruction.
-
-Fixpoint unfold_label (ll: list label) :=
- match ll with
- | nil => nil
- | l :: ll => Plabel l :: unfold_label ll
- end.
-
-Fixpoint unfold_body (lb: list basic) :=
- match lb with
- | nil => nil
- | b :: lb => basic_to_instruction b :: unfold_body lb
- end.
-
-Definition unfold_exit (oc: option control) :=
- match oc with
- | None => nil
- | Some c => control_to_instruction c :: nil
- end.
-
-Definition unfold_bblock (b: bblock) := unfold_label (header b) ++
- (match (body b), (exit b) with
- | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None =>
- unfold_body bo
- | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil
- end).
-
-Fixpoint unfold (lb: bblocks) :=
- match lb with
- | nil => nil
- | b :: lb => (unfold_bblock b) ++ unfold lb
- end.
-
-Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code;
- correct: unfold fn_blocks = fn_code }.
-
-Definition fundef := AST.fundef function.
-Definition program := AST.program fundef unit.
-Definition genv := Genv.t fundef unit.
-
-Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f).
-
-(*
-Definition fundef_proj (fu: fundef) : Asmblock.fundef := transf_fundef function_proj fu.
-
-Definition program_proj (p: program) : Asmblock.program := transform_program fundef_proj p.
- *)
-
-Definition fundef_proj (fu: fundef) : Asmvliw.fundef :=
- match fu with
- | Internal f => Internal (function_proj f)
- | External ef => External ef
- end.
-
-Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit :=
- match gd with
- | Gfun f => Gfun (fundef_proj f)
- | Gvar gu => Gvar gu
- end.
-
-Program Definition genv_trans (ge: genv) : Asmvliw.genv :=
- {| Genv.genv_public := Genv.genv_public ge;
- Genv.genv_symb := Genv.genv_symb ge;
- Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge);
- Genv.genv_next := Genv.genv_next ge |}.
-Next Obligation.
- destruct ge. simpl in *. eauto.
-Qed. Next Obligation.
- destruct ge; simpl in *.
- rewrite PTree.gmap1 in H.
- destruct (genv_defs ! b) eqn:GEN.
- - eauto.
- - discriminate.
-Qed. Next Obligation.
- destruct ge; simpl in *.
- eauto.
-Qed.
-
-Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit))
- : list (ident * globdef Asmvliw.fundef unit) :=
- match l with
- | nil => nil
- | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l
- end.
-
-Definition program_proj (p: program) : Asmvliw.program :=
- {| prog_defs := prog_defs_proj (prog_defs p);
- prog_public := prog_public p;
- prog_main := prog_main p
- |}.
-
-End RELSEM.
-
-Definition semantics (p: program) := Asmvliw.semantics (program_proj p).
-
-(** Determinacy of the [Asm] semantics. *)
-
-Lemma semantics_determinate: forall p, determinate (semantics p).
-Proof.
- intros. apply semantics_determinate.
-Qed.
-
-(** transf_program *)
-
-Program Definition transf_function (f: Asmvliw.function) : function :=
- {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f;
- fn_code := unfold (Asmvliw.fn_blocks f) |}.
-
-Lemma transf_function_proj: forall f, function_proj (transf_function f) = f.
-Proof.
- intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto.
-Qed.
-
-Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function.
-
-Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f.
-Proof.
- intros f. destruct f as [f|e]; simpl; auto.
- rewrite transf_function_proj. auto.
-Qed.
-
-(* Definition transf_globdef (gd: globdef Asmblock.fundef unit) : globdef fundef unit :=
- match gd with
- | Gfun f => Gfun (transf_fundef f)
- | Gvar gu => Gvar gu
- end.
-
-Lemma transf_globdef_proj: forall gd, globdef_proj (transf_globdef gd) = gd.
-Proof.
- intros gd. destruct gd as [f|v]; simpl; auto.
- rewrite transf_fundef_proj; auto.
-Qed.
-
-Fixpoint transf_prog_defs (l: list (ident * globdef Asmblock.fundef unit))
- : list (ident * globdef fundef unit) :=
- match l with
- | nil => nil
- | (i, gd) :: l => (i, transf_globdef gd) :: transf_prog_defs l
- end.
-
-Lemma transf_prog_proj: forall p, prog_defs p = prog_defs_proj (transf_prog_defs (prog_defs p)).
-Proof.
- intros p. destruct p as [defs pub main]. simpl.
- induction defs; simpl; auto.
- destruct a as [i gd]. simpl.
- rewrite transf_globdef_proj.
- congruence.
-Qed.
- *)
-
-Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef.
-
-Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B),
- prog_defs p1 = prog_defs p2 ->
- prog_public p1 = prog_public p2 ->
- prog_main p1 = prog_main p2 ->
- p1 = p2.
-Proof.
- intros. destruct p1. destruct p2. simpl in *. subst. auto.
-Qed.
-
-Lemma transf_program_proj: forall p, program_proj (transf_program p) = p.
-Proof.
- intros p. destruct p as [defs pub main]. unfold program_proj. simpl.
- apply program_equals; simpl; auto.
- induction defs.
- - simpl; auto.
- - simpl. rewrite IHdefs.
- destruct a as [id gd]; simpl.
- destruct gd as [f|v]; simpl; auto.
- rewrite transf_fundef_proj. auto.
-Qed.
-
-Definition match_prog (p: Asmvliw.program) (tp: program) :=
- match_program (fun _ f tf => tf = transf_fundef f) eq p tp.
-
-Lemma transf_program_match:
- forall p tp, transf_program p = tp -> match_prog p tp.
-Proof.
- intros. rewrite <- H. eapply match_transform_program; eauto.
-Qed.
-
-Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l.
-Proof.
- intros. congruence.
-Qed.
-
-(* I think it is a special case of Asmblock -> Asm. Very handy to have *)
-Lemma match_program_transf:
- forall p tp, match_prog p tp -> transf_program p = tp.
-Proof.
- intros p tp H. inversion_clear H. inv H1.
- destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *.
- subst. unfold transf_program. unfold transform_program. simpl.
- apply program_equals; simpl; auto.
- induction H0; simpl; auto.
- rewrite IHlist_forall2. apply cons_extract.
- destruct a1 as [ida gda]. destruct b1 as [idb gdb].
- simpl in *.
- inv H. inv H2.
- - simpl in *. subst. auto.
- - simpl in *. subst. inv H. auto.
-Qed.
-
-Section PRESERVATION.
-
-Variable prog: Asmvliw.program.
-Variable tprog: program.
-Hypothesis TRANSF: match_prog prog tprog.
-Let ge := Genv.globalenv prog.
-Let tge := Genv.globalenv tprog.
-
-Definition match_states (s1 s2: state) := s1 = s2.
-
-Lemma symbols_preserved:
- forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_match TRANSF).
-
-Lemma senv_preserved:
- Senv.equiv ge tge.
-Proof (Genv.senv_match TRANSF).
-
-
-Theorem transf_program_correct:
- forward_simulation (Asmvliw.semantics prog) (semantics tprog).
-Proof.
- pose proof (match_program_transf prog tprog TRANSF) as TR.
- subst. unfold semantics. rewrite transf_program_proj.
-
- eapply forward_simulation_step with (match_states := match_states); simpl; auto.
- - intros. exists s1. split; auto. congruence.
- - intros. inv H. auto.
- - intros. exists s1'. inv H0. split; auto. congruence.
-Qed.
-
-End PRESERVATION.
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* Prashanth Mundkur, SRI International *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* The contributions by Prashanth Mundkur are reused and adapted *)
+(* under the terms of a Contributor License Agreement between *)
+(* SRI International and INRIA. *)
+(* *)
+(* *********************************************************************)
+
+(** * Abstract syntax for K1c textual assembly language.
+
+ Each emittable instruction is defined here. ';;' is also defined as an instruction.
+ The goal of this representation is to stay compatible with the rest of the generic backend of CompCert
+ We define [unfold : list bblock -> list instruction]
+ An Asm function is then defined as : [fn_sig], [fn_blocks], [fn_code], and a proof of [unfold fn_blocks = fn_code]
+ [fn_code] has no semantic. Instead, the semantic of Asm is given by using the AsmVLIW semantic on [fn_blocks] *)
+
+Require Import Coqlib.
+Require Import Maps.
+Require Import AST.
+Require Import Integers.
+Require Import Floats.
+Require Import Values.
+Require Import ExtValues.
+Require Import Memory.
+Require Import Events.
+Require Import Globalenvs.
+Require Import Smallstep.
+Require Import Locations.
+Require Stacklayout.
+Require Import Conventions.
+Require Import Asmvliw.
+Require Import Linking.
+Require Import Errors.
+
+(** Definitions for OCaml code *)
+Definition label := positive.
+Definition preg := preg.
+
+Inductive addressing : Type :=
+ | AOff (ofs: offset)
+ | AReg (ro: ireg)
+ | ARegXS (ro: ireg)
+.
+
+(** Syntax *)
+Inductive instruction : Type :=
+ (** pseudo instructions *)
+ | Pallocframe (sz: Z) (pos: ptrofs) (**r allocate new stack frame *)
+ | Pfreeframe (sz: Z) (pos: ptrofs) (**r deallocate stack frame and restore previous frame *)
+ | Plabel (lbl: label) (**r define a code label *)
+ | Ploadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (**r load the address of a symbol *)
+ | Pbuiltin: external_function -> list (builtin_arg preg)
+ -> builtin_res preg -> instruction (**r built-in function (pseudo) *)
+ | Psemi (**r semi colon separating bundles *)
+ | Pnop (**r instruction that does nothing *)
+
+ (** Control flow instructions *)
+ | Pget (rd: ireg) (rs: preg) (**r get system register *)
+ | Pset (rd: preg) (rs: ireg) (**r set system register *)
+ | Pret (**r return *)
+ | Pcall (l: label) (**r function call *)
+ | Picall (rs: ireg) (**r function call on register *)
+ (* Pgoto is for tailcalls, Pj_l is for jumping to a particular label *)
+ | Pgoto (l: label) (**r goto *)
+ | Pigoto (rs: ireg) (**r goto from register *)
+ | Pj_l (l: label) (**r jump to label *)
+ | Pcb (bt: btest) (r: ireg) (l: label) (**r branch based on btest *)
+ | Pcbu (bt: btest) (r: ireg) (l: label) (**r branch based on btest with unsigned semantics *)
+ | Pjumptable (r: ireg) (labels: list label)
+
+ (* For builtins *)
+ | Ploopdo (count: ireg) (loopend: label)
+ | Pgetn (n: int) (dst: ireg)
+ | Psetn (n: int) (src: ireg)
+ | Pwfxl (n: int) (src: ireg)
+ | Pwfxm (n: int) (src: ireg)
+ | Pldu (dst: ireg) (addr: ireg)
+ | Plbzu (dst: ireg) (addr: ireg)
+ | Plhzu (dst: ireg) (addr: ireg)
+ | Plwzu (dst: ireg) (addr: ireg)
+ | Pawait
+ | Psleep
+ | Pstop
+ | Pbarrier
+ | Pfence
+ | Pdinval
+ | Pdinvall (addr: ireg)
+ | Pdtouchl (addr: ireg)
+ | Piinval
+ | Piinvals (addr: ireg)
+ | Pitouchl (addr: ireg)
+ | Pdzerol (addr: ireg)
+(*| Pafaddd (addr: ireg) (incr_res: ireg)
+ | Pafaddw (addr: ireg) (incr_res: ireg) *) (* see #157 *)
+ | Palclrd (dst: ireg) (addr: ireg)
+ | Palclrw (dst: ireg) (addr: ireg)
+ | Pclzll (rd rs: ireg)
+ | Pstsud (rd rs1 rs2: ireg)
+
+ (** Loads **)
+ | Plb (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte *)
+ | Plbu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load byte unsigned *)
+ | Plh (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word *)
+ | Plhu (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load half word unsigned *)
+ | Plw (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int32 *)
+ | Plw_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any32 *)
+ | Pld (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load int64 *)
+ | Pld_a (trap: trapping_mode) (rd: ireg) (ra: ireg) (ofs: addressing) (**r load any64 *)
+ | Pfls (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load float *)
+ | Pfld (trap: trapping_mode) (rd: freg) (ra: ireg) (ofs: addressing) (**r load 64-bit float *)
+ | Plq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r load 2*64-bit *)
+ | Plo (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r load 4*64-bit *)
+
+ (** Stores **)
+ | Psb (rs: ireg) (ra: ireg) (ofs: addressing) (**r store byte *)
+ | Psh (rs: ireg) (ra: ireg) (ofs: addressing) (**r store half byte *)
+ | Psw (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int32 *)
+ | Psw_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any32 *)
+ | Psd (rs: ireg) (ra: ireg) (ofs: addressing) (**r store int64 *)
+ | Psd_a (rs: ireg) (ra: ireg) (ofs: addressing) (**r store any64 *)
+ | Pfss (rs: freg) (ra: ireg) (ofs: addressing) (**r store float *)
+ | Pfsd (rs: freg) (ra: ireg) (ofs: addressing) (**r store 64-bit float *)
+
+ | Psq (rs: gpreg_q) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
+ | Pso (rs: gpreg_o) (ra: ireg) (ofs: addressing) (**r store 2*64-bit *)
+
+ (** Arith RR *)
+ | Pmv (rd rs: ireg) (**r register move *)
+ | Pnegw (rd rs: ireg) (**r negate word *)
+ | Pnegl (rd rs: ireg) (**r negate long *)
+ | Pcvtl2w (rd rs: ireg) (**r Convert Long to Word *)
+ | Psxwd (rd rs: ireg) (**r Sign Extend Word to Double Word *)
+ | Pzxwd (rd rs: ireg) (**r Zero Extend Word to Double Word *)
+
+ | Pextfz (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
+ | Pextfs (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
+
+ | Pextfzl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields unsigned *)
+ | Pextfsl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r extract bitfields signed *)
+
+ | Pinsf (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
+ | Pinsfl (rd : ireg) (rs : ireg) (stop : Z) (start : Z) (**r insert bitfield *)
+
+ | Pfabsd (rd rs: ireg) (**r float absolute double *)
+ | Pfabsw (rd rs: ireg) (**r float absolute word *)
+ | Pfnegd (rd rs: ireg) (**r float negate double *)
+ | Pfnegw (rd rs: ireg) (**r float negate word *)
+ | Pfnarrowdw (rd rs: ireg) (**r float narrow 64 -> 32 bits *)
+ | Pfwidenlwd (rd rs: ireg) (**r float widen 32 -> 64 bits *)
+ | Pfloatwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (32 -> 32) *)
+ | Pfloatuwrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (u32 -> 32) *)
+ | Pfloatudrnsz (rd rs: ireg) (**r Floating Point Conversion from unsigned integer (64 bits) *)
+ | Pfloatdrnsz (rd rs: ireg) (**r Floating Point Conversion from integer (64 bits) *)
+ | Pfixedwrzz (rd rs: ireg) (**r Integer conversion from floating point *)
+ | Pfixeduwrzz (rd rs: ireg) (**r Integer conversion from floating point (f32 -> 32 bits unsigned *)
+ | Pfixeddrzz (rd rs: ireg) (**r Integer conversion from floating point (i64 -> 64 bits) *)
+ | Pfixeddrzz_i32 (rd rs: ireg) (**r Integer conversion from floating point (i32 -> f64) *)
+ | Pfixedudrzz (rd rs: ireg) (**r unsigned Integer conversion from floating point (u64 -> 64 bits) *)
+ | Pfixedudrzz_i32 (rd rs: ireg) (**r unsigned Integer conversion from floating point (u32 -> 64 bits) *)
+
+ (** Arith RI32 *)
+ | Pmake (rd: ireg) (imm: int) (**r load immediate *)
+
+ (** Arith RI64 *)
+ | Pmakel (rd: ireg) (imm: int64) (**r load immediate long *)
+
+ (** Arith RF32 *)
+ | Pmakefs (rd: ireg) (imm: float32)
+
+ (** Arith RF64 *)
+ | Pmakef (rd: ireg) (imm: float)
+
+ (** Arith RRR *)
+ | Pcompw (it: itest) (rd rs1 rs2: ireg) (**r comparison word *)
+ | Pcompl (it: itest) (rd rs1 rs2: ireg) (**r comparison long *)
+ | Pfcompw (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float *)
+ | Pfcompl (ft: ftest) (rd rs1 rs2: ireg) (**r comparison float64 *)
+
+ | Paddw (rd rs1 rs2: ireg) (**r add word *)
+ | Paddxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *)
+ | Psubw (rd rs1 rs2: ireg) (**r sub word *)
+ | Prevsubxw (shift : shift1_4) (rd rs1 rs2: ireg) (**r add word *)
+ | Pmulw (rd rs1 rs2: ireg) (**r mul word *)
+ | Pandw (rd rs1 rs2: ireg) (**r and word *)
+ | Pnandw (rd rs1 rs2: ireg) (**r nand word *)
+ | Porw (rd rs1 rs2: ireg) (**r or word *)
+ | Pnorw (rd rs1 rs2: ireg) (**r nor word *)
+ | Pxorw (rd rs1 rs2: ireg) (**r xor word *)
+ | Pnxorw (rd rs1 rs2: ireg) (**r xor word *)
+ | Pandnw (rd rs1 rs2: ireg) (**r andn word *)
+ | Pornw (rd rs1 rs2: ireg) (**r orn word *)
+ | Psraw (rd rs1 rs2: ireg) (**r shift right arithmetic word *)
+ | Psrxw (rd rs1 rs2: ireg) (**r shift right arithmetic word round to 0*)
+ | Psrlw (rd rs1 rs2: ireg) (**r shift right logical word *)
+ | Psllw (rd rs1 rs2: ireg) (**r shift left logical word *)
+ | Pmaddw (rd rs1 rs2: ireg) (**r multiply-add words *)
+ | Pmsubw (rd rs1 rs2: ireg) (**r multiply-add words *)
+ | Pfmaddfw (rd rs1 rs2: ireg) (**r float fused multiply-add words *)
+ | Pfmsubfw (rd rs1 rs2: ireg) (**r float fused multiply-subtract words *)
+ | Pfmaddfl (rd rs1 rs2: ireg) (**r float fused multiply-add longs *)
+ | Pfmsubfl (rd rs1 rs2: ireg) (**r float fused multiply-subtract longs *)
+
+ | Paddl (rd rs1 rs2: ireg) (**r add long *)
+ | Paddxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r add long shift *)
+ | Psubl (rd rs1 rs2: ireg) (**r sub long *)
+ | Prevsubxl (shift : shift1_4) (rd rs1 rs2: ireg) (**r sub long shift *)
+ | Pandl (rd rs1 rs2: ireg) (**r and long *)
+ | Pnandl (rd rs1 rs2: ireg) (**r nand long *)
+ | Porl (rd rs1 rs2: ireg) (**r or long *)
+ | Pnorl (rd rs1 rs2: ireg) (**r nor long *)
+ | Pxorl (rd rs1 rs2: ireg) (**r xor long *)
+ | Pnxorl (rd rs1 rs2: ireg) (**r nxor long *)
+ | Pandnl (rd rs1 rs2: ireg) (**r andn long *)
+ | Pornl (rd rs1 rs2: ireg) (**r orn long *)
+ | Pmull (rd rs1 rs2: ireg) (**r mul long (low part) *)
+ | Pslll (rd rs1 rs2: ireg) (**r shift left logical long *)
+ | Psrll (rd rs1 rs2: ireg) (**r shift right logical long *)
+ | Psral (rd rs1 rs2: ireg) (**r shift right arithmetic long *)
+ | Psrxl (rd rs1 rs2: ireg) (**r shift right arithmetic long round to 0*)
+ | Pmaddl (rd rs1 rs2: ireg) (**r multiply-add long *)
+ | Pmsubl (rd rs1 rs2: ireg) (**r multiply-add long *)
+
+ | Pfaddd (rd rs1 rs2: ireg) (**r Float addition double *)
+ | Pfaddw (rd rs1 rs2: ireg) (**r Float addition word *)
+ | Pfsbfd (rd rs1 rs2: ireg) (**r Float sub double *)
+ | Pfsbfw (rd rs1 rs2: ireg) (**r Float sub word *)
+ | Pfmuld (rd rs1 rs2: ireg) (**r Float mul double *)
+ | Pfmulw (rd rs1 rs2: ireg) (**r Float mul word *)
+ | Pfmind (rd rs1 rs2: ireg) (**r Float min double *)
+ | Pfminw (rd rs1 rs2: ireg) (**r Float min word *)
+ | Pfmaxd (rd rs1 rs2: ireg) (**r Float max double *)
+ | Pfmaxw (rd rs1 rs2: ireg) (**r Float max word *)
+ | Pfinvw (rd rs1: ireg) (**r Float invert word *)
+
+ (** Arith RRI32 *)
+ | Pcompiw (it: itest) (rd rs: ireg) (imm: int) (**r comparison imm word *)
+
+ | Paddiw (rd rs: ireg) (imm: int) (**r add imm word *)
+ | Paddxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r add imm word *)
+ | Prevsubiw (rd rs: ireg) (imm: int) (**r subtract imm word *)
+ | Prevsubxiw (shift : shift1_4) (rd rs: ireg) (imm: int) (**r subtract imm word *)
+ | Pmuliw (rd rs: ireg) (imm: int) (**r mul imm word *)
+ | Pandiw (rd rs: ireg) (imm: int) (**r and imm word *)
+ | Pnandiw (rd rs: ireg) (imm: int) (**r nand imm word *)
+ | Poriw (rd rs: ireg) (imm: int) (**r or imm word *)
+ | Pnoriw (rd rs: ireg) (imm: int) (**r nor imm word *)
+ | Pxoriw (rd rs: ireg) (imm: int) (**r xor imm word *)
+ | Pnxoriw (rd rs: ireg) (imm: int) (**r nxor imm word *)
+ | Pandniw (rd rs: ireg) (imm: int) (**r andn imm word *)
+ | Porniw (rd rs: ireg) (imm: int) (**r orn imm word *)
+ | Psraiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word *)
+ | Psrxiw (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
+ | Psrliw (rd rs: ireg) (imm: int) (**r shift right logical imm word *)
+ | Pslliw (rd rs: ireg) (imm: int) (**r shift left logical imm word *)
+ | Proriw (rd rs: ireg) (imm: int) (**r rotate right imm word *)
+ | Pmaddiw (rd rs: ireg) (imm: int) (**r multiply add imm word *)
+ | Psllil (rd rs: ireg) (imm: int) (**r shift left logical immediate long *)
+ | Psrxil (rd rs: ireg) (imm: int) (**r shift right arithmetic imm word round to 0*)
+ | Psrlil (rd rs: ireg) (imm: int) (**r shift right logical immediate long *)
+ | Psrail (rd rs: ireg) (imm: int) (**r shift right arithmetic immediate long *)
+
+ (** Arith RRI64 *)
+ | Pcompil (it: itest) (rd rs: ireg) (imm: int64) (**r comparison imm long *)
+ | Paddil (rd rs: ireg) (imm: int64) (**r add immediate long *)
+ | Paddxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r add immediate long *)
+ | Prevsubil (rd rs: ireg) (imm: int64) (**r subtract imm long *)
+ | Prevsubxil (shift : shift1_4) (rd rs: ireg) (imm: int64) (**r subtract imm long *)
+ | Pmulil (rd rs: ireg) (imm: int64) (**r add immediate long *)
+ | Pandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
+ | Pnandil (rd rs: ireg) (imm: int64) (**r and immediate long *)
+ | Poril (rd rs: ireg) (imm: int64) (**r or immediate long *)
+ | Pnoril (rd rs: ireg) (imm: int64) (**r and immediate long *)
+ | Pxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
+ | Pnxoril (rd rs: ireg) (imm: int64) (**r xor immediate long *)
+ | Pandnil (rd rs: ireg) (imm: int64) (**r andn long *)
+ | Pornil (rd rs: ireg) (imm: int64) (**r orn long *)
+ | Pmaddil (rd rs: ireg) (imm: int64) (**r multiply add imm long *)
+ | Pcmove (bt: btest) (rcond rd rs : ireg) (** conditional move *)
+ | Pcmoveu (bt: btest) (rcond rd rs : ireg) (** conditional move, unsigned semantics *)
+ | Pcmoveiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move *)
+ | Pcmoveuiw (bt: btest) (rcond rd : ireg) (imm: int) (** conditional move, unsigned semantics *)
+ | Pcmoveil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move *)
+ | Pcmoveuil (bt: btest) (rcond rd : ireg) (imm: int64) (** conditional move, unsigned semantics *)
+.
+
+(** Correspondance between Asmblock and Asm *)
+
+Definition control_to_instruction (c: control) :=
+ match c with
+ | PExpand (Asmvliw.Pbuiltin ef args res) => Pbuiltin ef args res
+ | PCtlFlow Asmvliw.Pret => Pret
+ | PCtlFlow (Asmvliw.Pcall l) => Pcall l
+ | PCtlFlow (Asmvliw.Picall r) => Picall r
+ | PCtlFlow (Asmvliw.Pgoto l) => Pgoto l
+ | PCtlFlow (Asmvliw.Pigoto l) => Pigoto l
+ | PCtlFlow (Asmvliw.Pj_l l) => Pj_l l
+ | PCtlFlow (Asmvliw.Pcb bt r l) => Pcb bt r l
+ | PCtlFlow (Asmvliw.Pcbu bt r l) => Pcbu bt r l
+ | PCtlFlow (Asmvliw.Pjumptable r label) => Pjumptable r label
+ end.
+
+Definition basic_to_instruction (b: basic) :=
+ match b with
+ (** Special basics *)
+ | Asmvliw.Pget rd rs => Pget rd rs
+ | Asmvliw.Pset rd rs => Pset rd rs
+ | Asmvliw.Pnop => Pnop
+ | Asmvliw.Pallocframe sz pos => Pallocframe sz pos
+ | Asmvliw.Pfreeframe sz pos => Pfreeframe sz pos
+
+ (** PArith basics *)
+ (* R *)
+ | PArithR (Asmvliw.Ploadsymbol id ofs) r => Ploadsymbol r id ofs
+
+ (* RR *)
+ | PArithRR Asmvliw.Pmv rd rs => Pmv rd rs
+ | PArithRR Asmvliw.Pnegw rd rs => Pnegw rd rs
+ | PArithRR Asmvliw.Pnegl rd rs => Pnegl rd rs
+ | PArithRR Asmvliw.Pcvtl2w rd rs => Pcvtl2w rd rs
+ | PArithRR Asmvliw.Psxwd rd rs => Psxwd rd rs
+ | PArithRR Asmvliw.Pzxwd rd rs => Pzxwd rd rs
+ | PArithRR (Asmvliw.Pextfz stop start) rd rs => Pextfz rd rs stop start
+ | PArithRR (Asmvliw.Pextfs stop start) rd rs => Pextfs rd rs stop start
+ | PArithRR (Asmvliw.Pextfzl stop start) rd rs => Pextfzl rd rs stop start
+ | PArithRR (Asmvliw.Pextfsl stop start) rd rs => Pextfsl rd rs stop start
+ | PArithRR Asmvliw.Pfabsd rd rs => Pfabsd rd rs
+ | PArithRR Asmvliw.Pfabsw rd rs => Pfabsw rd rs
+ | PArithRR Asmvliw.Pfnegd rd rs => Pfnegd rd rs
+ | PArithRR Asmvliw.Pfnegw rd rs => Pfnegw rd rs
+ | PArithRR Asmvliw.Pfinvw rd rs => Pfinvw rd rs
+ | PArithRR Asmvliw.Pfnarrowdw rd rs => Pfnarrowdw rd rs
+ | PArithRR Asmvliw.Pfwidenlwd rd rs => Pfwidenlwd rd rs
+ | PArithRR Asmvliw.Pfloatuwrnsz rd rs => Pfloatuwrnsz rd rs
+ | PArithRR Asmvliw.Pfloatwrnsz rd rs => Pfloatwrnsz rd rs
+ | PArithRR Asmvliw.Pfloatudrnsz rd rs => Pfloatudrnsz rd rs
+ | PArithRR Asmvliw.Pfloatdrnsz rd rs => Pfloatdrnsz rd rs
+ | PArithRR Asmvliw.Pfixedwrzz rd rs => Pfixedwrzz rd rs
+ | PArithRR Asmvliw.Pfixeduwrzz rd rs => Pfixeduwrzz rd rs
+ | PArithRR Asmvliw.Pfixeddrzz rd rs => Pfixeddrzz rd rs
+ | PArithRR Asmvliw.Pfixedudrzz rd rs => Pfixedudrzz rd rs
+ | PArithRR Asmvliw.Pfixeddrzz_i32 rd rs => Pfixeddrzz_i32 rd rs
+ | PArithRR Asmvliw.Pfixedudrzz_i32 rd rs => Pfixedudrzz_i32 rd rs
+
+ (* RI32 *)
+ | PArithRI32 Asmvliw.Pmake rd imm => Pmake rd imm
+
+ (* RI64 *)
+ | PArithRI64 Asmvliw.Pmakel rd imm => Pmakel rd imm
+
+ (* RF32 *)
+ | PArithRF32 Asmvliw.Pmakefs rd imm => Pmakefs rd imm
+
+ (* RF64 *)
+ | PArithRF64 Asmvliw.Pmakef rd imm => Pmakef rd imm
+
+ (* RRR *)
+ | PArithRRR (Asmvliw.Pcompw it) rd rs1 rs2 => Pcompw it rd rs1 rs2
+ | PArithRRR (Asmvliw.Pcompl it) rd rs1 rs2 => Pcompl it rd rs1 rs2
+ | PArithRRR (Asmvliw.Pfcompw ft) rd rs1 rs2 => Pfcompw ft rd rs1 rs2
+ | PArithRRR (Asmvliw.Pfcompl ft) rd rs1 rs2 => Pfcompl ft rd rs1 rs2
+ | PArithRRR Asmvliw.Paddw rd rs1 rs2 => Paddw rd rs1 rs2
+ | PArithRRR (Asmvliw.Paddxw shift) rd rs1 rs2 => Paddxw shift rd rs1 rs2
+ | PArithRRR Asmvliw.Psubw rd rs1 rs2 => Psubw rd rs1 rs2
+ | PArithRRR (Asmvliw.Prevsubxw shift) rd rs1 rs2 => Prevsubxw shift rd rs1 rs2
+ | PArithRRR Asmvliw.Pmulw rd rs1 rs2 => Pmulw rd rs1 rs2
+ | PArithRRR Asmvliw.Pandw rd rs1 rs2 => Pandw rd rs1 rs2
+ | PArithRRR Asmvliw.Pnandw rd rs1 rs2 => Pnandw rd rs1 rs2
+ | PArithRRR Asmvliw.Porw rd rs1 rs2 => Porw rd rs1 rs2
+ | PArithRRR Asmvliw.Pnorw rd rs1 rs2 => Pnorw rd rs1 rs2
+ | PArithRRR Asmvliw.Pxorw rd rs1 rs2 => Pxorw rd rs1 rs2
+ | PArithRRR Asmvliw.Pnxorw rd rs1 rs2 => Pnxorw rd rs1 rs2
+ | PArithRRR Asmvliw.Pandnw rd rs1 rs2 => Pandnw rd rs1 rs2
+ | PArithRRR Asmvliw.Pornw rd rs1 rs2 => Pornw rd rs1 rs2
+ | PArithRRR Asmvliw.Psraw rd rs1 rs2 => Psraw rd rs1 rs2
+ | PArithRRR Asmvliw.Psrxw rd rs1 rs2 => Psrxw rd rs1 rs2
+ | PArithRRR Asmvliw.Psrlw rd rs1 rs2 => Psrlw rd rs1 rs2
+ | PArithRRR Asmvliw.Psllw rd rs1 rs2 => Psllw rd rs1 rs2
+
+ | PArithRRR Asmvliw.Paddl rd rs1 rs2 => Paddl rd rs1 rs2
+ | PArithRRR (Asmvliw.Paddxl shift) rd rs1 rs2 => Paddxl shift rd rs1 rs2
+ | PArithRRR Asmvliw.Psubl rd rs1 rs2 => Psubl rd rs1 rs2
+ | PArithRRR (Asmvliw.Prevsubxl shift) rd rs1 rs2 => Prevsubxl shift rd rs1 rs2
+ | PArithRRR Asmvliw.Pandl rd rs1 rs2 => Pandl rd rs1 rs2
+ | PArithRRR Asmvliw.Pnandl rd rs1 rs2 => Pnandl rd rs1 rs2
+ | PArithRRR Asmvliw.Porl rd rs1 rs2 => Porl rd rs1 rs2
+ | PArithRRR Asmvliw.Pnorl rd rs1 rs2 => Pnorl rd rs1 rs2
+ | PArithRRR Asmvliw.Pxorl rd rs1 rs2 => Pxorl rd rs1 rs2
+ | PArithRRR Asmvliw.Pnxorl rd rs1 rs2 => Pnxorl rd rs1 rs2
+ | PArithRRR Asmvliw.Pandnl rd rs1 rs2 => Pandnl rd rs1 rs2
+ | PArithRRR Asmvliw.Pornl rd rs1 rs2 => Pornl rd rs1 rs2
+ | PArithRRR Asmvliw.Pmull rd rs1 rs2 => Pmull rd rs1 rs2
+ | PArithRRR Asmvliw.Pslll rd rs1 rs2 => Pslll rd rs1 rs2
+ | PArithRRR Asmvliw.Psrll rd rs1 rs2 => Psrll rd rs1 rs2
+ | PArithRRR Asmvliw.Psral rd rs1 rs2 => Psral rd rs1 rs2
+ | PArithRRR Asmvliw.Psrxl rd rs1 rs2 => Psrxl rd rs1 rs2
+
+ | PArithRRR Asmvliw.Pfaddd rd rs1 rs2 => Pfaddd rd rs1 rs2
+ | PArithRRR Asmvliw.Pfaddw rd rs1 rs2 => Pfaddw rd rs1 rs2
+ | PArithRRR Asmvliw.Pfsbfd rd rs1 rs2 => Pfsbfd rd rs1 rs2
+ | PArithRRR Asmvliw.Pfsbfw rd rs1 rs2 => Pfsbfw rd rs1 rs2
+ | PArithRRR Asmvliw.Pfmuld rd rs1 rs2 => Pfmuld rd rs1 rs2
+ | PArithRRR Asmvliw.Pfmulw rd rs1 rs2 => Pfmulw rd rs1 rs2
+ | PArithRRR Asmvliw.Pfmind rd rs1 rs2 => Pfmind rd rs1 rs2
+ | PArithRRR Asmvliw.Pfminw rd rs1 rs2 => Pfminw rd rs1 rs2
+ | PArithRRR Asmvliw.Pfmaxd rd rs1 rs2 => Pfmaxd rd rs1 rs2
+ | PArithRRR Asmvliw.Pfmaxw rd rs1 rs2 => Pfmaxw rd rs1 rs2
+
+ (* RRI32 *)
+ | PArithRRI32 (Asmvliw.Pcompiw it) rd rs imm => Pcompiw it rd rs imm
+ | PArithRRI32 Asmvliw.Paddiw rd rs imm => Paddiw rd rs imm
+ | PArithRRI32 (Asmvliw.Paddxiw shift) rd rs imm => Paddxiw shift rd rs imm
+ | PArithRRI32 Asmvliw.Prevsubiw rd rs imm => Prevsubiw rd rs imm
+ | PArithRRI32 (Asmvliw.Prevsubxiw shift) rd rs imm => Prevsubxiw shift rd rs imm
+ | PArithRRI32 Asmvliw.Pmuliw rd rs imm => Pmuliw rd rs imm
+ | PArithRRI32 Asmvliw.Pandiw rd rs imm => Pandiw rd rs imm
+ | PArithRRI32 Asmvliw.Pnandiw rd rs imm => Pnandiw rd rs imm
+ | PArithRRI32 Asmvliw.Poriw rd rs imm => Poriw rd rs imm
+ | PArithRRI32 Asmvliw.Pnoriw rd rs imm => Pnoriw rd rs imm
+ | PArithRRI32 Asmvliw.Pxoriw rd rs imm => Pxoriw rd rs imm
+ | PArithRRI32 Asmvliw.Pnxoriw rd rs imm => Pnxoriw rd rs imm
+ | PArithRRI32 Asmvliw.Pandniw rd rs imm => Pandniw rd rs imm
+ | PArithRRI32 Asmvliw.Porniw rd rs imm => Porniw rd rs imm
+ | PArithRRI32 Asmvliw.Psraiw rd rs imm => Psraiw rd rs imm
+ | PArithRRI32 Asmvliw.Psrxiw rd rs imm => Psrxiw rd rs imm
+ | PArithRRI32 Asmvliw.Psrliw rd rs imm => Psrliw rd rs imm
+ | PArithRRI32 Asmvliw.Pslliw rd rs imm => Pslliw rd rs imm
+ | PArithRRI32 Asmvliw.Proriw rd rs imm => Proriw rd rs imm
+ | PArithRRI32 Asmvliw.Psllil rd rs imm => Psllil rd rs imm
+ | PArithRRI32 Asmvliw.Psrlil rd rs imm => Psrlil rd rs imm
+ | PArithRRI32 Asmvliw.Psrxil rd rs imm => Psrxil rd rs imm
+ | PArithRRI32 Asmvliw.Psrail rd rs imm => Psrail rd rs imm
+
+ (* RRI64 *)
+ | PArithRRI64 (Asmvliw.Pcompil it) rd rs imm => Pcompil it rd rs imm
+ | PArithRRI64 Asmvliw.Paddil rd rs imm => Paddil rd rs imm
+ | PArithRRI64 (Asmvliw.Paddxil shift) rd rs imm => Paddxil shift rd rs imm
+ | PArithRRI64 Asmvliw.Prevsubil rd rs imm => Prevsubil rd rs imm
+ | PArithRRI64 (Asmvliw.Prevsubxil shift) rd rs imm => Prevsubxil shift rd rs imm
+ | PArithRRI64 Asmvliw.Pmulil rd rs imm => Pmulil rd rs imm
+ | PArithRRI64 Asmvliw.Pandil rd rs imm => Pandil rd rs imm
+ | PArithRRI64 Asmvliw.Pnandil rd rs imm => Pnandil rd rs imm
+ | PArithRRI64 Asmvliw.Poril rd rs imm => Poril rd rs imm
+ | PArithRRI64 Asmvliw.Pnoril rd rs imm => Pnoril rd rs imm
+ | PArithRRI64 Asmvliw.Pxoril rd rs imm => Pxoril rd rs imm
+ | PArithRRI64 Asmvliw.Pnxoril rd rs imm => Pnxoril rd rs imm
+ | PArithRRI64 Asmvliw.Pandnil rd rs imm => Pandnil rd rs imm
+ | PArithRRI64 Asmvliw.Pornil rd rs imm => Pornil rd rs imm
+
+ (** ARRR *)
+ | PArithARRR Asmvliw.Pmaddw rd rs1 rs2 => Pmaddw rd rs1 rs2
+ | PArithARRR Asmvliw.Pmaddl rd rs1 rs2 => Pmaddl rd rs1 rs2
+ | PArithARRR Asmvliw.Pmsubw rd rs1 rs2 => Pmsubw rd rs1 rs2
+ | PArithARRR Asmvliw.Pmsubl rd rs1 rs2 => Pmsubl rd rs1 rs2
+ | PArithARRR Asmvliw.Pfmaddfw rd rs1 rs2 => Pfmaddfw rd rs1 rs2
+ | PArithARRR Asmvliw.Pfmaddfl rd rs1 rs2 => Pfmaddfl rd rs1 rs2
+ | PArithARRR Asmvliw.Pfmsubfw rd rs1 rs2 => Pfmsubfw rd rs1 rs2
+ | PArithARRR Asmvliw.Pfmsubfl rd rs1 rs2 => Pfmsubfl rd rs1 rs2
+ | PArithARRR (Asmvliw.Pcmove cond) rd rs1 rs2=> Pcmove cond rd rs1 rs2
+ | PArithARRR (Asmvliw.Pcmoveu cond) rd rs1 rs2=> Pcmoveu cond rd rs1 rs2
+
+ (** ARR *)
+ | PArithARR (Asmvliw.Pinsf stop start) rd rs => Pinsf rd rs stop start
+ | PArithARR (Asmvliw.Pinsfl stop start) rd rs => Pinsfl rd rs stop start
+
+ (** ARRI32 *)
+ | PArithARRI32 Asmvliw.Pmaddiw rd rs1 imm => Pmaddiw rd rs1 imm
+ | PArithARRI32 (Asmvliw.Pcmoveiw cond) rd rs1 imm => Pcmoveiw cond rd rs1 imm
+ | PArithARRI32 (Asmvliw.Pcmoveuiw cond) rd rs1 imm => Pcmoveuiw cond rd rs1 imm
+
+ (** ARRI64 *)
+ | PArithARRI64 Asmvliw.Pmaddil rd rs1 imm => Pmaddil rd rs1 imm
+ | PArithARRI64 (Asmvliw.Pcmoveil cond) rd rs1 imm => Pcmoveil cond rd rs1 imm
+ | PArithARRI64 (Asmvliw.Pcmoveuil cond) rd rs1 imm => Pcmoveuil cond rd rs1 imm
+ (** Load *)
+ | PLoadRRO trap Asmvliw.Plb rd ra ofs => Plb trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Plbu rd ra ofs => Plbu trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Plh rd ra ofs => Plh trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Plhu rd ra ofs => Plhu trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Plw rd ra ofs => Plw trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Plw_a rd ra ofs => Plw_a trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Pld rd ra ofs => Pld trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Pld_a rd ra ofs => Pld_a trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Pfls rd ra ofs => Pfls trap rd ra (AOff ofs)
+ | PLoadRRO trap Asmvliw.Pfld rd ra ofs => Pfld trap rd ra (AOff ofs)
+
+ | PLoadQRRO qrs ra ofs => Plq qrs ra (AOff ofs)
+ | PLoadORRO qrs ra ofs => Plo qrs ra (AOff ofs)
+
+ | PLoadRRR trap Asmvliw.Plb rd ra ro => Plb trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Plh rd ra ro => Plh trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Plw rd ra ro => Plw trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Pld rd ra ro => Pld trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (AReg ro)
+ | PLoadRRR trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (AReg ro)
+
+ | PLoadRRRXS trap Asmvliw.Plb rd ra ro => Plb trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Plbu rd ra ro => Plbu trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Plh rd ra ro => Plh trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Plhu rd ra ro => Plhu trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Plw rd ra ro => Plw trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Plw_a rd ra ro => Plw_a trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Pld rd ra ro => Pld trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Pld_a rd ra ro => Pld_a trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Pfls rd ra ro => Pfls trap rd ra (ARegXS ro)
+ | PLoadRRRXS trap Asmvliw.Pfld rd ra ro => Pfld trap rd ra (ARegXS ro)
+
+ (** Store *)
+ | PStoreRRO Asmvliw.Psb rd ra ofs => Psb rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Psh rd ra ofs => Psh rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Psw rd ra ofs => Psw rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Psw_a rd ra ofs => Psw_a rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Psd rd ra ofs => Psd rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Psd_a rd ra ofs => Psd_a rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Pfss rd ra ofs => Pfss rd ra (AOff ofs)
+ | PStoreRRO Asmvliw.Pfsd rd ra ofs => Pfsd rd ra (AOff ofs)
+
+ | PStoreRRR Asmvliw.Psb rd ra ro => Psb rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Psh rd ra ro => Psh rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Psw rd ra ro => Psw rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Psw_a rd ra ro => Psw_a rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Psd rd ra ro => Psd rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Psd_a rd ra ro => Psd_a rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Pfss rd ra ro => Pfss rd ra (AReg ro)
+ | PStoreRRR Asmvliw.Pfsd rd ra ro => Pfsd rd ra (AReg ro)
+
+ | PStoreRRRXS Asmvliw.Psb rd ra ro => Psb rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Psh rd ra ro => Psh rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Psw rd ra ro => Psw rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Psw_a rd ra ro => Psw_a rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Psd rd ra ro => Psd rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Psd_a rd ra ro => Psd_a rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Pfss rd ra ro => Pfss rd ra (ARegXS ro)
+ | PStoreRRRXS Asmvliw.Pfsd rd ra ro => Pfsd rd ra (ARegXS ro)
+
+ | PStoreQRRO qrs ra ofs => Psq qrs ra (AOff ofs)
+ | PStoreORRO qrs ra ofs => Pso qrs ra (AOff ofs)
+ end.
+
+Section RELSEM.
+
+Definition code := list instruction.
+
+Fixpoint unfold_label (ll: list label) :=
+ match ll with
+ | nil => nil
+ | l :: ll => Plabel l :: unfold_label ll
+ end.
+
+Fixpoint unfold_body (lb: list basic) :=
+ match lb with
+ | nil => nil
+ | b :: lb => basic_to_instruction b :: unfold_body lb
+ end.
+
+Definition unfold_exit (oc: option control) :=
+ match oc with
+ | None => nil
+ | Some c => control_to_instruction c :: nil
+ end.
+
+Definition unfold_bblock (b: bblock) := unfold_label (header b) ++
+ (match (body b), (exit b) with
+ | (((Asmvliw.Pfreeframe _ _ | Asmvliw.Pallocframe _ _)::nil) as bo), None =>
+ unfold_body bo
+ | bo, ex => unfold_body bo ++ unfold_exit ex ++ Psemi :: nil
+ end).
+
+Fixpoint unfold (lb: bblocks) :=
+ match lb with
+ | nil => nil
+ | b :: lb => (unfold_bblock b) ++ unfold lb
+ end.
+
+Record function : Type := mkfunction { fn_sig: signature; fn_blocks: bblocks; fn_code: code;
+ correct: unfold fn_blocks = fn_code }.
+
+Definition fundef := AST.fundef function.
+Definition program := AST.program fundef unit.
+Definition genv := Genv.t fundef unit.
+
+Definition function_proj (f: function) := Asmvliw.mkfunction (fn_sig f) (fn_blocks f).
+
+Definition fundef_proj (fu: fundef) : Asmvliw.fundef :=
+ match fu with
+ | Internal f => Internal (function_proj f)
+ | External ef => External ef
+ end.
+
+Definition globdef_proj (gd: globdef fundef unit) : globdef Asmvliw.fundef unit :=
+ match gd with
+ | Gfun f => Gfun (fundef_proj f)
+ | Gvar gu => Gvar gu
+ end.
+
+Program Definition genv_trans (ge: genv) : Asmvliw.genv :=
+ {| Genv.genv_public := Genv.genv_public ge;
+ Genv.genv_symb := Genv.genv_symb ge;
+ Genv.genv_defs := PTree.map1 globdef_proj (Genv.genv_defs ge);
+ Genv.genv_next := Genv.genv_next ge |}.
+Next Obligation.
+ destruct ge. simpl in *. eauto.
+Qed. Next Obligation.
+ destruct ge; simpl in *.
+ rewrite PTree.gmap1 in H.
+ destruct (genv_defs ! b) eqn:GEN.
+ - eauto.
+ - discriminate.
+Qed. Next Obligation.
+ destruct ge; simpl in *.
+ eauto.
+Qed.
+
+Fixpoint prog_defs_proj (l: list (ident * globdef fundef unit))
+ : list (ident * globdef Asmvliw.fundef unit) :=
+ match l with
+ | nil => nil
+ | (i, gd) :: l => (i, globdef_proj gd) :: prog_defs_proj l
+ end.
+
+Definition program_proj (p: program) : Asmvliw.program :=
+ {| prog_defs := prog_defs_proj (prog_defs p);
+ prog_public := prog_public p;
+ prog_main := prog_main p
+ |}.
+
+End RELSEM.
+
+Definition semantics (p: program) := Asmvliw.semantics (program_proj p).
+
+(** Determinacy of the [Asm] semantics. *)
+
+Lemma semantics_determinate: forall p, determinate (semantics p).
+Proof.
+ intros. apply semantics_determinate.
+Qed.
+
+(** transf_program *)
+
+Program Definition transf_function (f: Asmvliw.function) : function :=
+ {| fn_sig := Asmvliw.fn_sig f; fn_blocks := Asmvliw.fn_blocks f;
+ fn_code := unfold (Asmvliw.fn_blocks f) |}.
+
+Lemma transf_function_proj: forall f, function_proj (transf_function f) = f.
+Proof.
+ intros f. destruct f as [sig blks]. unfold function_proj. simpl. auto.
+Qed.
+
+Definition transf_fundef : Asmvliw.fundef -> fundef := AST.transf_fundef transf_function.
+
+Lemma transf_fundef_proj: forall f, fundef_proj (transf_fundef f) = f.
+Proof.
+ intros f. destruct f as [f|e]; simpl; auto.
+ rewrite transf_function_proj. auto.
+Qed.
+
+Definition transf_program : Asmvliw.program -> program := transform_program transf_fundef.
+
+Lemma program_equals {A B: Type} : forall (p1 p2: AST.program A B),
+ prog_defs p1 = prog_defs p2 ->
+ prog_public p1 = prog_public p2 ->
+ prog_main p1 = prog_main p2 ->
+ p1 = p2.
+Proof.
+ intros. destruct p1. destruct p2. simpl in *. subst. auto.
+Qed.
+
+Lemma transf_program_proj: forall p, program_proj (transf_program p) = p.
+Proof.
+ intros p. destruct p as [defs pub main]. unfold program_proj. simpl.
+ apply program_equals; simpl; auto.
+ induction defs.
+ - simpl; auto.
+ - simpl. rewrite IHdefs.
+ destruct a as [id gd]; simpl.
+ destruct gd as [f|v]; simpl; auto.
+ rewrite transf_fundef_proj. auto.
+Qed.
+
+Definition match_prog (p: Asmvliw.program) (tp: program) :=
+ match_program (fun _ f tf => tf = transf_fundef f) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = tp -> match_prog p tp.
+Proof.
+ intros. rewrite <- H. eapply match_transform_program; eauto.
+Qed.
+
+Lemma cons_extract {A: Type} : forall (l: list A) a b, a = b -> a::l = b::l.
+Proof.
+ intros. congruence.
+Qed.
+
+Lemma match_program_transf:
+ forall p tp, match_prog p tp -> transf_program p = tp.
+Proof.
+ intros p tp H. inversion_clear H. inv H1.
+ destruct p as [defs pub main]. destruct tp as [tdefs tpub tmain]. simpl in *.
+ subst. unfold transf_program. unfold transform_program. simpl.
+ apply program_equals; simpl; auto.
+ induction H0; simpl; auto.
+ rewrite IHlist_forall2. apply cons_extract.
+ destruct a1 as [ida gda]. destruct b1 as [idb gdb].
+ simpl in *.
+ inv H. inv H2.
+ - simpl in *. subst. auto.
+ - simpl in *. subst. inv H. auto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Asmvliw.program.
+Variable tprog: program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Definition match_states (s1 s2: state) := s1 = s2.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+
+Theorem transf_program_correct:
+ forward_simulation (Asmvliw.semantics prog) (semantics tprog).
+Proof.
+ pose proof (match_program_transf prog tprog TRANSF) as TR.
+ subst. unfold semantics. rewrite transf_program_proj.
+
+ eapply forward_simulation_step with (match_states := match_states); simpl; auto.
+ - intros. exists s1. split; auto. congruence.
+ - intros. inv H. auto.
+ - intros. exists s1'. inv H0. split; auto. congruence.
+Qed.
+
+End PRESERVATION.
diff --git a/mppa_k1c/Asmaux.v b/mppa_k1c/Asmaux.v
index 85359658..891d1068 100644
--- a/mppa_k1c/Asmaux.v
+++ b/mppa_k1c/Asmaux.v
@@ -1,5 +1,5 @@
Require Import Asm.
Require Import AST.
-(* Constant only needed by Asmexpandaux.ml *)
-Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}.
+(** Constant only needed by Asmexpandaux.ml *)
+Program Definition dummy_function := {| fn_code := nil; fn_sig := signature_main; fn_blocks := nil |}.
diff --git a/mppa_k1c/Asmblock.v b/mppa_k1c/Asmblock.v
index ddb7ce7d..a05d4726 100644
--- a/mppa_k1c/Asmblock.v
+++ b/mppa_k1c/Asmblock.v
@@ -15,7 +15,7 @@
(* *)
(* *********************************************************************)
-(** Abstract syntax and semantics for K1c assembly language. *)
+(** Sequential block semantics for K1c assembly. The syntax is given in AsmVLIW *)
Require Import Coqlib.
Require Import Maps.
@@ -33,6 +33,19 @@ Require Import Conventions.
Require Import Errors.
Require Export Asmvliw.
+(* Notations necessary to hook Asmvliw definitions *)
+Notation undef_caller_save_regs := Asmvliw.undef_caller_save_regs.
+Notation regset := Asmvliw.regset.
+Notation extcall_arg := Asmvliw.extcall_arg.
+Notation extcall_arg_pair := Asmvliw.extcall_arg_pair.
+Notation extcall_arguments := Asmvliw.extcall_arguments.
+Notation set_res := Asmvliw.set_res.
+Notation function := Asmvliw.function.
+Notation bblocks := Asmvliw.bblocks.
+Notation header := Asmvliw.header.
+Notation body := Asmvliw.body.
+Notation exit := Asmvliw.exit.
+Notation correct := Asmvliw.correct.
(** * Auxiliary utilies on basic blocks *)
@@ -172,7 +185,6 @@ Proof.
Qed.
Ltac bblock_auto_correct := (apply non_empty_bblock_refl; try discriminate; try (left; discriminate); try (right; discriminate)).
-(* Local Obligation Tactic := bblock_auto_correct. *)
Lemma Istrue_proof_irrelevant (b: bool): forall (p1 p2:Is_true b), p1=p2.
Proof.
@@ -250,9 +262,6 @@ Proof.
intros. destruct bb as [hd bdy ex COR]. simpl. unfold no_header; unfold stick_header; simpl. reflexivity.
Qed.
-
-
-
(** * Sequential Semantics of basic blocks *)
Section RELSEM.
@@ -264,11 +273,11 @@ Definition exec_arith_instr (ai: ar_instruction) (rs: regset): regset := parexec
(** Auxiliaries for memory accesses *)
-Definition exec_load_offset (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset chunk rs rs m m d a ofs.
+Definition exec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a: ireg) (ofs: offset) := parexec_load_offset trap chunk rs rs m m d a ofs.
-Definition exec_load_reg (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg chunk rs rs m m d a ro.
+Definition exec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_reg trap chunk rs rs m m d a ro.
-Definition exec_load_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs chunk rs rs m m d a ro.
+Definition exec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rs: regset) (m: mem) (d a ro: ireg) := parexec_load_regxs trap chunk rs rs m m d a ro.
Definition exec_load_q_offset (rs: regset) (m: mem) (d : gpreg_q) (a: ireg) (ofs: offset) := parexec_load_q_offset rs rs m m d a ofs.
@@ -286,7 +295,7 @@ Definition exec_store_regxs (chunk: memory_chunk) (rs: regset) (m: mem) (s a ro:
(** * basic instructions *)
-Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := parexec_basic_instr ge bi rs rs m m.
+Definition exec_basic_instr (bi: basic) (rs: regset) (m: mem) : outcome := bstep ge bi rs rs m m.
Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome :=
match body with
@@ -298,32 +307,36 @@ Fixpoint exec_body (body: list basic) (rs: regset) (m: mem): outcome :=
end
end.
-(** Position corresponding to a label *)
-
-Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m.
-
-(** Evaluating a branch
-
-Warning: in m PC is assumed to be already pointing on the next instruction !
-*)
-Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res.
+Theorem builtin_body_nil:
+ forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil.
+Proof.
+ intros. destruct bb as [hd bdy ex WF]. simpl in *.
+ apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1.
+ eapply H1; eauto.
+Qed.
-(** Execution of a single control-flow instruction [i] in initial state [rs] and
- [m]. Return updated state.
+Theorem exec_body_app:
+ forall l l' rs m rs'' m'',
+ exec_body (l ++ l') rs m = Next rs'' m'' ->
+ exists rs' m',
+ exec_body l rs m = Next rs' m'
+ /\ exec_body l' rs' m' = Next rs'' m''.
+Proof.
+ induction l.
+ - intros. simpl in H. repeat eexists. auto.
+ - intros. rewrite <- app_comm_cons in H. simpl in H.
+ destruct (exec_basic_instr a rs m) eqn:EXEBI.
+ + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2).
+ repeat eexists. simpl. rewrite EXEBI. eauto. auto.
+ + discriminate.
+Qed.
- As above: PC is assumed to be incremented on the next block before the control-flow instruction
+(** Position corresponding to a label *)
- For instructions that correspond tobuiltin
- actual RISC-V instructions, the cases are straightforward
- transliterations of the informal descriptions given in the RISC-V
- user-mode specification. For pseudo-instructions, refer to the
- informal descriptions given above.
+Definition goto_label (f: function) (lbl: label) (rs: regset) (m: mem) : outcome := par_goto_label f lbl rs rs m.
- Note that we set to [Vundef] the registers used as temporaries by
- the expansions of the pseudo-instructions, so that the RISC-V code
- we generate cannot use those registers to hold values that must
- survive the execution of the pseudo-instruction. *)
+Definition eval_branch (f: function) (l: label) (rs: regset) (m: mem) (res: option bool) : outcome := par_eval_branch f l rs rs m res.
Definition exec_control (f: function) (oc: option control) (rs: regset) (m: mem) : outcome := parexec_control ge f oc rs rs m.
@@ -368,16 +381,11 @@ Inductive step: state -> trace -> state -> Prop :=
step (State rs m) t (State rs' m')
.
-
-
End RELSEM.
-
-
Definition semantics (p: program) :=
Semantics step (initial_state p) final_state (Genv.globalenv p).
-
Definition data_preg (r: preg) : bool :=
match r with
| RA => false
@@ -386,4 +394,3 @@ Definition data_preg (r: preg) : bool :=
| IR _ => true
| PC => false
end.
-
diff --git a/mppa_k1c/Asmblockdeps.v b/mppa_k1c/Asmblockdeps.v
index eb3900d5..01eda623 100644
--- a/mppa_k1c/Asmblockdeps.v
+++ b/mppa_k1c/Asmblockdeps.v
@@ -1,6 +1,13 @@
+(** * Translation from Asmblock to AbstractBB
+
+ We define a specific instance of AbstractBB, named L, translate bblocks from Asmblock into this instance
+ AbstractBB will then define two semantics for L : a sequential, and a semantic one
+ We prove a bisimulation between the parallel semantics of L and AsmVLIW
+ From this, we also deduce a bisimulation between the sequential semantics of L and Asmblock *)
+
Require Import AST.
Require Import Asmblock.
-Require Import Asmblockgenproof0.
+Require Import Asmblockgenproof0 Asmblockprops.
Require Import Values.
Require Import Globalenvs.
Require Import Memory.
@@ -9,14 +16,18 @@ Require Import Integers.
Require Import Floats.
Require Import ZArith.
Require Import Coqlib.
-Require Import ImpDep.
+Require Import ImpSimuTest.
Require Import Axioms.
Require Import Parallelizability.
Require Import Asmvliw Permutation.
Require Import Chunks.
+Require Import Lia.
+
Open Scope impure.
+(** Definition of L *)
+
Module P<: ImpParam.
Module R := Pos.
@@ -74,9 +85,9 @@ Coercion OArithRRI32: arith_name_rri32 >-> Funclass.
Coercion OArithRRI64: arith_name_rri64 >-> Funclass.
Inductive load_op :=
- | OLoadRRO (n: load_name) (ofs: offset)
- | OLoadRRR (n: load_name)
- | OLoadRRRXS (n: load_name)
+ | OLoadRRO (n: load_name) (trap: trapping_mode) (ofs: offset)
+ | OLoadRRR (n: load_name) (trap: trapping_mode)
+ | OLoadRRRXS (n: load_name) (trap: trapping_mode)
.
Coercion OLoadRRO: load_name >-> Funclass.
@@ -133,33 +144,39 @@ Definition arith_eval (ao: arith_op) (l: list value) :=
| _, _ => None
end.
-Definition exec_load_deps_offset (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) :=
+Definition exec_incorrect_load trap chunk :=
+ match trap with
+ | TRAP => None
+ | NOTRAP => Some (Val (concrete_default_notrap_load_value chunk))
+ end.
+
+Definition exec_load_deps_offset (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v: val) (ofs: offset) :=
let (ge, fn) := Ge in
match (eval_offset ofs) with
| OK ptr => match Mem.loadv chunk m (Val.offset_ptr v ptr) with
- | None => None
+ | None => exec_incorrect_load trap chunk
| Some vl => Some (Val vl)
end
| _ => None
end.
-Definition exec_load_deps_reg (chunk: memory_chunk) (m: mem) (v vo: val) :=
+Definition exec_load_deps_reg (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) :=
match Mem.loadv chunk m (Val.addl v vo) with
- | None => None
+ | None => exec_incorrect_load trap chunk
| Some vl => Some (Val vl)
end.
-Definition exec_load_deps_regxs (chunk: memory_chunk) (m: mem) (v vo: val) :=
+Definition exec_load_deps_regxs (trap: trapping_mode) (chunk: memory_chunk) (m: mem) (v vo: val) :=
match Mem.loadv chunk m (Val.addl v (Val.shll vo (scale_of_chunk chunk))) with
- | None => None
+ | None => exec_incorrect_load trap chunk
| Some vl => Some (Val vl)
end.
Definition load_eval (lo: load_op) (l: list value) :=
match lo, l with
- | OLoadRRO n ofs, [Val v; Memstate m] => exec_load_deps_offset (load_chunk n) m v ofs
- | OLoadRRR n, [Val v; Val vo; Memstate m] => exec_load_deps_reg (load_chunk n) m v vo
- | OLoadRRRXS n, [Val v; Val vo; Memstate m] => exec_load_deps_regxs (load_chunk n) m v vo
+ | OLoadRRO n trap ofs, [Val v; Memstate m] => exec_load_deps_offset trap (load_chunk n) m v ofs
+ | OLoadRRR n trap, [Val v; Val vo; Memstate m] => exec_load_deps_reg trap (load_chunk n) m v vo
+ | OLoadRRRXS n trap, [Val v; Val vo; Memstate m] => exec_load_deps_regxs trap (load_chunk n) m v vo
| _, _ => None
end.
@@ -193,6 +210,136 @@ Definition store_eval (so: store_op) (l: list value) :=
| _, _ => None
end.
+Local Open Scope Z.
+
+Remark size_chunk_positive: forall chunk,
+ (size_chunk chunk) > 0.
+Proof.
+ destruct chunk; simpl; lia.
+Qed.
+
+Remark size_chunk_small: forall chunk,
+ (size_chunk chunk) <= 8.
+Proof.
+ destruct chunk; simpl; lia.
+Qed.
+
+Definition disjoint_chunks
+ (ofs1 : offset) (chunk1 : memory_chunk)
+ (ofs2 : offset) (chunk2 : memory_chunk) :=
+ Intv.disjoint ((Ptrofs.unsigned ofs1),
+ ((Ptrofs.unsigned ofs1) + (size_chunk chunk1)))
+ ((Ptrofs.unsigned ofs2),
+ ((Ptrofs.unsigned ofs2) + (size_chunk chunk2))).
+
+Definition small_offset_threshold := 18446744073709551608.
+
+Lemma store_store_disjoint_offsets :
+ forall n1 n2 ofs1 ofs2 vs1 vs2 va m0 m1 m2 m1' m2',
+ (disjoint_chunks ofs1 (store_chunk n1) ofs2 (store_chunk n2)) ->
+ (Ptrofs.unsigned ofs1) < small_offset_threshold ->
+ (Ptrofs.unsigned ofs2) < small_offset_threshold ->
+ store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m0] = Some (Memstate m1) ->
+ store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m1] = Some (Memstate m2) ->
+ store_eval (OStoreRRO n2 ofs2) [vs2; va; Memstate m0] = Some (Memstate m1') ->
+ store_eval (OStoreRRO n1 ofs1) [vs1; va; Memstate m1'] = Some (Memstate m2') ->
+ m2 = m2'.
+Proof.
+ intros until m2'.
+ intros DISJOINT SMALL1 SMALL2 STORE0 STORE1 STORE0' STORE1'.
+ unfold disjoint_chunks in DISJOINT.
+ destruct vs1 as [v1 | ]; simpl in STORE0, STORE1'; try congruence.
+ destruct vs2 as [v2 | ]; simpl in STORE1, STORE0'; try congruence.
+ destruct va as [base | ]; try congruence.
+ unfold exec_store_deps_offset in *.
+ destruct Ge.
+ unfold eval_offset in *; simpl in *.
+ unfold Mem.storev in *.
+ unfold Val.offset_ptr in *.
+ destruct base as [ | | | | | wblock wpofs] in * ; try congruence.
+ destruct (Mem.store _ _ _ _ _) eqn:E0; try congruence.
+ inv STORE0.
+ destruct (Mem.store (store_chunk n2) _ _ _ _) eqn:E1; try congruence.
+ inv STORE1.
+ destruct (Mem.store (store_chunk n2) m0 _ _ _) eqn:E0'; try congruence.
+ inv STORE0'.
+ destruct (Mem.store _ m1' _ _ _) eqn:E1'; try congruence.
+ inv STORE1'.
+ assert (Some m2 = Some m2').
+ 2: congruence.
+ rewrite <- E1.
+ rewrite <- E1'.
+ eapply Mem.store_store_other.
+ 2, 3: eassumption.
+
+ right.
+ pose proof (size_chunk_positive (store_chunk n1)).
+ pose proof (size_chunk_positive (store_chunk n2)).
+ pose proof (size_chunk_small (store_chunk n1)).
+ pose proof (size_chunk_small (store_chunk n2)).
+ destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]];
+ unfold Intv.empty in DIS; simpl in DIS.
+ 1, 2: lia.
+ pose proof (Ptrofs.unsigned_range ofs1).
+ pose proof (Ptrofs.unsigned_range ofs2).
+ unfold small_offset_threshold in *.
+ destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1;
+ destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2;
+ change Ptrofs.modulus with 18446744073709551616 in *;
+ lia.
+Qed.
+
+Lemma load_store_disjoint_offsets :
+ forall n1 n2 tm ofs1 ofs2 vs va m0 m1,
+ (disjoint_chunks ofs1 (store_chunk n1) ofs2 (load_chunk n2)) ->
+ (Ptrofs.unsigned ofs1) < small_offset_threshold ->
+ (Ptrofs.unsigned ofs2) < small_offset_threshold ->
+ store_eval (OStoreRRO n1 ofs1) [vs; va; Memstate m0] = Some (Memstate m1) ->
+ load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m1] =
+ load_eval (OLoadRRO n2 tm ofs2) [va; Memstate m0].
+Proof.
+ intros until m1.
+ intros DISJOINT SMALL1 SMALL2 STORE0.
+ destruct vs as [v | ]; simpl in STORE0; try congruence.
+ destruct va as [base | ]; try congruence.
+ unfold exec_store_deps_offset in *.
+ unfold eval_offset in *; simpl in *.
+ unfold exec_load_deps_offset.
+ unfold Mem.storev, Mem.loadv in *.
+ destruct Ge in *.
+ unfold eval_offset in *.
+ unfold Val.offset_ptr in *.
+ destruct base as [ | | | | | wblock wpofs] in * ; try congruence.
+ destruct (Mem.store _ _ _ _) eqn:E0; try congruence.
+ inv STORE0.
+ assert (
+ (Mem.load (load_chunk n2) m1 wblock
+ (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) =
+ (Mem.load (load_chunk n2) m0 wblock
+ (Ptrofs.unsigned (Ptrofs.add wpofs ofs2))) ) as LOADS.
+ {
+ eapply Mem.load_store_other.
+ eassumption.
+ right.
+ pose proof (size_chunk_positive (store_chunk n1)).
+ pose proof (size_chunk_positive (load_chunk n2)).
+ pose proof (size_chunk_small (store_chunk n1)).
+ pose proof (size_chunk_small (load_chunk n2)).
+ destruct (Intv.range_disjoint _ _ DISJOINT) as [DIS | [DIS | DIS]];
+ unfold Intv.empty in DIS; simpl in DIS.
+ 1,2: lia.
+
+ pose proof (Ptrofs.unsigned_range ofs1).
+ pose proof (Ptrofs.unsigned_range ofs2).
+ unfold small_offset_threshold in *.
+ destruct (Ptrofs.unsigned_add_either wpofs ofs1) as [R1 | R1]; rewrite R1;
+ destruct (Ptrofs.unsigned_add_either wpofs ofs2) as [R2 | R2]; rewrite R2;
+ change Ptrofs.modulus with 18446744073709551616 in *;
+ lia.
+ }
+ destruct (Mem.load _ m1 _ _) in *; destruct (Mem.load _ m0 _ _) in *; congruence.
+Qed.
+
Definition goto_label_deps (f: function) (lbl: label) (vpc: val) :=
match label_pos lbl 0 (fn_blocks f) with
| None => None
@@ -302,30 +449,6 @@ Definition op_eval (o: op) (l: list value) :=
end.
- (** Function [is_constant] is used for a small optimization inside the scheduling verifier.
- It is good that it answers [true] as much as possible while satisfying [is_constant_correct] below.
-
- BE CAREFUL that, [is_constant] must not depend on [ge].
- Otherwise, we would have an easy implementation: [match op_eval o nil with Some _ => true | _ => false end]
-
- => REM: when [is_constant] is not complete w.r.t [is_constant_correct], this should have only a very little impact
- on the performance of the scheduling verifier...
- *)
-
-Definition is_constant (o: op): bool :=
- match o with
- | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true
- | _ => false
- end.
-
-Lemma is_constant_correct o: is_constant o = true -> op_eval o nil <> None.
-Proof.
- destruct o; simpl; try congruence.
- destruct ao; simpl; try congruence;
- destruct n; simpl; try congruence;
- unfold arith_eval; destruct Ge; simpl; try congruence.
-Qed.
-
Definition arith_op_eq (o1 o2: arith_op): ?? bool :=
match o1 with
| OArithR n1 =>
@@ -379,24 +502,47 @@ Proof.
Qed.
Hint Resolve offset_eq_correct: wlp.
+Definition trapping_mode_eq trap1 trap2 :=
+ RET (match trap1, trap2 with
+ | TRAP, TRAP | NOTRAP, NOTRAP => true
+ | TRAP, NOTRAP | NOTRAP, TRAP => false
+ end).
+Lemma trapping_mode_eq_correct t1 t2:
+ WHEN trapping_mode_eq t1 t2 ~> b THEN b = true -> t1 = t2.
+Proof.
+ wlp_simplify.
+ destruct t1; destruct t2; trivial; discriminate.
+Qed.
+Hint Resolve trapping_mode_eq_correct: wlp.
+
Definition load_op_eq (o1 o2: load_op): ?? bool :=
match o1 with
- | OLoadRRO n1 ofs1 =>
- match o2 with OLoadRRO n2 ofs2 => iandb (phys_eq n1 n2) (offset_eq ofs1 ofs2) | _ => RET false end
- | OLoadRRR n1 =>
- match o2 with OLoadRRR n2 => phys_eq n1 n2 | _ => RET false end
- | OLoadRRRXS n1 =>
- match o2 with OLoadRRRXS n2 => phys_eq n1 n2 | _ => RET false end
+ | OLoadRRO n1 trap ofs1 =>
+ match o2 with
+ | OLoadRRO n2 trap2 ofs2 => iandb (phys_eq n1 n2) (iandb (offset_eq ofs1 ofs2) (trapping_mode_eq trap trap2))
+ | _ => RET false
+ end
+ | OLoadRRR n1 trap =>
+ match o2 with
+ | OLoadRRR n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2)
+ | _ => RET false
+ end
+ | OLoadRRRXS n1 trap =>
+ match o2 with
+ | OLoadRRRXS n2 trap2 => iandb (phys_eq n1 n2) (trapping_mode_eq trap trap2)
+ | _ => RET false
+ end
end.
Lemma load_op_eq_correct o1 o2:
WHEN load_op_eq o1 o2 ~> b THEN b = true -> o1 = o2.
Proof.
destruct o1, o2; wlp_simplify; try discriminate.
- - f_equal. pose (Ptrofs.eq_spec ofs ofs0).
- rewrite H in *. trivial.
- - congruence.
- - congruence.
+ { f_equal.
+ destruct trap, trap0; simpl in *; trivial; discriminate.
+ pose (Ptrofs.eq_spec ofs ofs0).
+ rewrite H in *. trivial. }
+ all: destruct trap, trap0; simpl in *; trivial; discriminate.
Qed.
Hint Resolve load_op_eq_correct: wlp.
Opaque load_op_eq_correct.
@@ -483,18 +629,6 @@ Qed.
Hint Resolve op_eq_correct: wlp.
Global Opaque op_eq_correct.
-
-(* QUICK FIX WITH struct_eq *)
-
-(* Definition op_eq (o1 o2: op): ?? bool := struct_eq o1 o2.
-
-Theorem op_eq_correct o1 o2:
- WHEN op_eq o1 o2 ~> b THEN b=true -> o1 = o2.
-Proof.
- wlp_simplify.
-Qed.
-*)
-
End IMPPARAM.
End P.
@@ -507,7 +641,7 @@ Include MkSeqLanguage P.
End L.
-Module IDT := ImpDepTree L ImpPosDict.
+Module IST := ImpSimu L ImpPosDict.
Import L.
Import P.
@@ -574,7 +708,7 @@ Proof.
- unfold ppos. unfold pmem. discriminate.
Qed.
-(** Inversion functions, used for debugging *)
+(** Inversion functions, used for debug traces *)
Definition pos_to_ireg (p: R.t) : option gpreg :=
match p with
@@ -598,9 +732,6 @@ Definition inv_ppos (p: R.t) : option preg :=
end
end.
-
-(** Traduction Asmblock -> Asmblockdeps *)
-
Notation "a @ b" := (Econs a b) (at level 102, right associativity).
Definition trans_control (ctl: control) : inst :=
@@ -647,21 +778,21 @@ Definition trans_arith (ai: ar_instruction) : inst :=
Definition trans_basic (b: basic) : inst :=
match b with
| PArith ai => trans_arith ai
- | PLoadRRO n d a ofs => [(#d, Op (Load (OLoadRRO n ofs)) (PReg (#a) @ PReg pmem @ Enil))]
- | PLoadRRR n d a ro => [(#d, Op (Load (OLoadRRR n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
- | PLoadRRRXS n d a ro => [(#d, Op (Load (OLoadRRRXS n)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
+ | PLoadRRO trap n d a ofs => [(#d, Op (Load (OLoadRRO n trap ofs)) (PReg (#a) @ PReg pmem @ Enil))]
+ | PLoadRRR trap n d a ro => [(#d, Op (Load (OLoadRRR n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
+ | PLoadRRRXS trap n d a ro => [(#d, Op (Load (OLoadRRRXS n trap)) (PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
| PStoreRRO n s a ofs => [(pmem, Op (Store (OStoreRRO n ofs)) (PReg (#s) @ PReg (#a) @ PReg pmem @ Enil))]
| PLoadQRRO qd a ofs =>
let (d0, d1) := gpreg_q_expand qd in
- [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil));
- (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))]
+ [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil));
+ (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil))]
| PLoadORRO od a ofs =>
match gpreg_o_expand od with
| (d0, d1, d2, d3) =>
- [(#d0, Op (Load (OLoadRRO Pld_a ofs)) (PReg (#a) @ PReg pmem @ Enil));
- (#d1, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil));
- (#d2, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil));
- (#d3, Op (Load (OLoadRRO Pld_a (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))]
+ [(#d0, Op (Load (OLoadRRO Pld_a TRAP ofs)) (PReg (#a) @ PReg pmem @ Enil));
+ (#d1, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 8)))) (Old(PReg (#a)) @ PReg pmem @ Enil));
+ (#d2, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 16)))) (Old(PReg (#a)) @ PReg pmem @ Enil));
+ (#d3, Op (Load (OLoadRRO Pld_a TRAP (Ptrofs.add ofs (Ptrofs.repr 24)))) (Old(PReg (#a)) @ PReg pmem @ Enil))]
end
| PStoreRRR n s a ro => [(pmem, Op (Store (OStoreRRR n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
| PStoreRRRXS n s a ro => [(pmem, Op (Store (OStoreRRRXS n)) (PReg (#s) @ PReg (#a) @ PReg (#ro) @ PReg pmem @ Enil))]
@@ -744,7 +875,7 @@ Proof.
intros. congruence.
Qed.
-(** Parallelizability of a bblock (bundle) *)
+(** Parallelizability test of a bblock (bundle), and bisimulation of the Asmblock and L parallel semantics *)
Module PChk := ParallelChecks L PosPseudoRegSet.
@@ -866,15 +997,15 @@ Qed.
-Theorem forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw bi:
+Theorem bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw bi:
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
match_states (State rsw mw) sw ->
- match_outcome (parexec_basic_instr ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr).
+ match_outcome (bstep ge bi rsr rsw mr mw) (inst_prun Ge (trans_basic bi) sw sr sr).
Proof.
(* a little tactic to automate reasoning on preg_eq *)
-Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr.
+Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core.
Local Ltac preg_eq_discr r rd :=
destruct (preg_eq r rd); try (subst r; rewrite assign_eq, Pregmap.gss; auto);
rewrite (assign_diff _ (#rd) (#r) _); auto;
@@ -891,21 +1022,21 @@ Local Ltac preg_eq_discr r rd :=
unfold parexec_load_offset; simpl; unfold exec_load_deps_offset; erewrite GENV, H, H0;
unfold eval_offset;
simpl; auto;
- destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto;
+ destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto;
eexists; split; try split; Simpl;
intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl.
(* Load Reg *)
+ destruct i; simpl load_chunk. all:
unfold parexec_load_reg; simpl; unfold exec_load_deps_reg; rewrite H, H0; rewrite (H0 rofs);
- destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto;
+ destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto;
eexists; split; try split; Simpl;
intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl.
(* Load Reg XS *)
+ destruct i; simpl load_chunk. all:
unfold parexec_load_regxs; simpl; unfold exec_load_deps_regxs; rewrite H, H0; rewrite (H0 rofs);
- destruct (Mem.loadv _ _ _) eqn:MEML; simpl; auto;
+ destruct (Mem.loadv _ _ _) eqn:MEML; destruct trap; simpl; auto;
eexists; split; try split; Simpl;
intros rr; destruct rr; Simpl; destruct (ireg_eq g rd); subst; Simpl.
@@ -922,7 +1053,7 @@ Local Ltac preg_eq_discr r rd :=
preg_eq_discr r rd0. }
(* Load Octuple word *)
- + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr.
+ + Local Hint Resolve not_eq_sym ppos_pmem_discr ppos_discr: core.
unfold parexec_load_o_offset.
destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3]; destruct Ge; simpl.
rewrite H0, H.
@@ -1018,7 +1149,7 @@ Local Ltac preg_eq_discr r rd :=
Qed.
-Theorem forward_simu_par_body:
+Theorem bisimu_par_body:
forall bdy ge fn rsr mr sr rsw mw sw,
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
@@ -1027,19 +1158,19 @@ Theorem forward_simu_par_body:
Proof.
induction bdy as [|i bdy]; simpl; eauto.
intros.
- exploit (forward_simu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto.
- destruct (parexec_basic_instr _ _ _ _ _ _); simpl.
+ exploit (bisimu_par_wio_basic ge fn rsr rsw mr mw sr sw i); eauto.
+ destruct (bstep _ _ _ _ _ _); simpl.
- intros (s' & X1 & X2). rewrite X1; simpl; eauto.
- intros X; rewrite X; simpl; auto.
Qed.
-Theorem forward_simu_par_control ex sz aux ge fn rsr rsw mr mw sr sw:
+Theorem bisimu_par_control ex sz aux ge fn rsr rsw mr mw sr sw:
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
match_states (State rsw mw) sw ->
match_outcome (parexec_control ge fn ex (incrPC (Ptrofs.repr sz) rsr) (rsw#PC <- aux) mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr).
Proof.
- intros GENV MSR MSW; unfold parexec_exit.
+ intros GENV MSR MSW; unfold estep.
simpl in *. inv MSR. inv MSW.
destruct ex.
- destruct c; destruct i; try discriminate; simpl.
@@ -1091,54 +1222,52 @@ Proof.
intros rr; destruct rr; unfold incrPC; Simpl.
Qed.
-Theorem forward_simu_par_exit ex sz ge fn rsr rsw mr mw sr sw:
+Theorem bisimu_par_exit ex sz ge fn rsr rsw mr mw sr sw:
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
match_states (State rsw mw) sw ->
- match_outcome (parexec_exit ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr).
+ match_outcome (estep ge fn ex (Ptrofs.repr sz) rsr rsw mw) (inst_prun Ge (trans_pcincr sz (trans_exit ex)) sw sr sr).
Proof.
- intros; unfold parexec_exit.
- exploit (forward_simu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto.
+ intros; unfold estep.
+ exploit (bisimu_par_control ex sz rsw#PC ge fn rsr rsw mr mw sr sw); eauto.
cutrewrite (rsw # PC <- (rsw PC) = rsw); auto.
apply extensionality. intros; destruct x; simpl; auto.
Qed.
Definition trans_block_aux bdy sz ex := (trans_body bdy) ++ (trans_pcincr sz (trans_exit ex) :: nil).
-Theorem forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy ex sz:
+Theorem bisimu_par_wio ge fn rsr mr sr bdy ex sz:
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
- match_states (State rsw mw) sw ->
- match_outcome (parexec_wio_bblock_aux ge fn bdy ex (Ptrofs.repr sz) rsr rsw mr mw) (prun_iw Ge (trans_block_aux bdy sz ex) sw sr).
+ match_outcome (parexec_wio ge fn bdy ex (Ptrofs.repr sz) rsr mr) (prun_iw Ge (trans_block_aux bdy sz ex) sr sr).
Proof.
- intros GENV MSR MSW. unfold parexec_wio_bblock_aux, trans_block_aux.
- exploit (forward_simu_par_body bdy ge fn rsr mr sr rsw mw sw); eauto.
+ intros GENV MSR. unfold parexec_wio, trans_block_aux.
+ exploit (bisimu_par_body bdy ge fn rsr mr sr rsr mr sr); eauto.
destruct (parexec_wio_body _ _ _ _ _ _); simpl.
- intros (s' & X1 & X2).
erewrite prun_iw_app_Some; eauto.
- exploit (forward_simu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto.
+ exploit (bisimu_par_exit ex sz ge fn rsr rs mr m sr s'); eauto.
subst Ge; simpl. destruct MSR as (Y1 & Y2). erewrite Y2; simpl.
destruct (inst_prun _ _ _ _ _); simpl; auto.
- intros X; erewrite prun_iw_app_None; eauto.
Qed.
-Theorem forward_simu_par_wio_bblock ge fn rsr rsw mr sr sw mw bdy1 bdy2 ex sz:
+Theorem bisimu_par_wio_bblock ge fn rsr mr sr bdy1 bdy2 ex sz:
Ge = Genv ge fn ->
match_states (State rsr mr) sr ->
- match_states (State rsw mw) sw ->
match_outcome
- match parexec_wio_bblock_aux ge fn bdy1 ex (Ptrofs.repr sz) rsr rsw mr mw with
+ match parexec_wio ge fn bdy1 ex (Ptrofs.repr sz) rsr mr with
| Next rs' m' => parexec_wio_body ge bdy2 rsr rs' mr m'
| Stuck => Stuck
end
- (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sw sr).
+ (prun_iw Ge ((trans_block_aux bdy1 sz ex)++(trans_body bdy2)) sr sr).
Proof.
intros.
- exploit (forward_simu_par_wio_bblock_aux ge fn rsr mr sr rsw mw sw bdy1 ex sz); eauto.
- destruct (parexec_wio_bblock_aux _ _ _ _ _ _); simpl.
+ exploit (bisimu_par_wio ge fn rsr mr sr bdy1 ex sz); eauto.
+ destruct (parexec_wio _ _ _ _ _ _); simpl.
- intros (s' & X1 & X2).
erewrite prun_iw_app_Some; eauto.
- eapply forward_simu_par_body; eauto.
+ eapply bisimu_par_body; eauto.
- intros; erewrite prun_iw_app_None; eauto.
Qed.
@@ -1169,7 +1298,7 @@ Proof.
apply Permutation_app_comm.
Qed.
-Theorem forward_simu_par rs1 m1 s1' b ge fn o2:
+Theorem bisimu_par rs1 m1 s1' b ge fn o2:
Ge = Genv ge fn ->
match_states (State rs1 m1) s1' ->
parexec_bblock ge fn b rs1 m1 o2 ->
@@ -1181,24 +1310,24 @@ Proof.
inversion PAREXEC as (bdy1 & bdy2 & PERM & WIO).
exploit trans_block_perserves_permutation; eauto.
intros Perm.
- exploit (forward_simu_par_wio_bblock ge fn rs1 rs1 m1 s1' s1' m1 bdy1 bdy2 (exit b) (size b)); eauto.
+ exploit (bisimu_par_wio_bblock ge fn rs1 m1 s1' bdy1 bdy2 (exit b) (size b)); eauto.
rewrite <- WIO. clear WIO.
intros H; eexists; split. 2: eapply H.
unfold prun; eexists; split; eauto.
destruct (prun_iw _ _ _ _); simpl; eauto.
Qed.
-(* sequential execution *)
-Theorem forward_simu_basic ge fn bi rs m s:
+(** sequential execution *)
+Theorem bisimu_basic ge fn bi rs m s:
Ge = Genv ge fn ->
match_states (State rs m) s ->
match_outcome (exec_basic_instr ge bi rs m) (inst_run Ge (trans_basic bi) s s).
Proof.
intros; unfold exec_basic_instr. rewrite inst_run_prun.
- eapply forward_simu_par_wio_basic; eauto.
+ eapply bisimu_par_wio_basic; eauto.
Qed.
-Lemma forward_simu_body:
+Lemma bisimu_body:
forall bdy ge fn rs m s,
Ge = Genv ge fn ->
match_states (State rs m) s ->
@@ -1206,33 +1335,33 @@ Lemma forward_simu_body:
Proof.
induction bdy as [|i bdy]; simpl; eauto.
intros.
- exploit (forward_simu_basic ge fn i rs m s); eauto.
+ exploit (bisimu_basic ge fn i rs m s); eauto.
destruct (exec_basic_instr _ _ _ _); simpl.
- intros (s' & X1 & X2). rewrite X1; simpl; eauto.
- intros X; rewrite X; simpl; auto.
Qed.
-Theorem forward_simu_exit ge fn b rs m s:
+Theorem bisimu_exit ge fn b rs m s:
Ge = Genv ge fn ->
match_states (State rs m) s ->
match_outcome (exec_control ge fn (exit b) (nextblock b rs) m) (inst_run Ge (trans_pcincr (size b) (trans_exit (exit b))) s s).
Proof.
intros; unfold exec_control, nextblock. rewrite inst_run_prun.
- apply (forward_simu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto.
+ apply (bisimu_par_control (exit b) (size b) (Val.offset_ptr (rs PC) (Ptrofs.repr (size b))) ge fn rs rs m m s s); auto.
Qed.
-Theorem forward_simu rs m b ge fn s:
+Theorem bisimu rs m b ge fn s:
Ge = Genv ge fn ->
match_states (State rs m) s ->
match_outcome (exec_bblock ge fn b rs m) (exec Ge (trans_block b) s).
Proof.
intros GENV MS. unfold exec_bblock.
- exploit (forward_simu_body (body b) ge fn rs m s); eauto.
+ exploit (bisimu_body (body b) ge fn rs m s); eauto.
unfold exec, trans_block; simpl.
destruct (exec_body _ _ _ _); simpl.
- intros (s' & X1 & X2).
erewrite run_app_Some; eauto.
- exploit (forward_simu_exit ge fn b rs0 m0 s'); eauto.
+ exploit (bisimu_exit ge fn b rs0 m0 s'); eauto.
subst Ge; simpl. destruct X2 as (Y1 & Y2). erewrite Y2; simpl.
destruct (inst_run _ _ _); simpl; auto.
- intros X; erewrite run_app_None; eauto.
@@ -1269,10 +1398,10 @@ Lemma bblock_para_check_correct ge fn bb rs m rs' m':
det_parexec ge fn bb rs m rs' m'.
Proof.
intros H H0 H1 o H2. unfold bblock_para_check in H1.
- exploit (forward_simu rs m bb ge fn); eauto. eapply trans_state_match.
+ exploit (bisimu rs m bb ge fn); eauto. eapply trans_state_match.
rewrite H0; simpl.
intros (s2' & EXEC & MS).
- exploit forward_simu_par. 2: apply (trans_state_match (State rs m)). all: eauto.
+ exploit bisimu_par. 2: apply (trans_state_match (State rs m)). all: eauto.
intros (o2' & PRUN & MO).
exploit parallelizable_correct. apply is_para_correct_aux. eassumption.
intro. eapply H3 in PRUN. clear H3. destruct o2'.
@@ -1290,24 +1419,23 @@ Qed.
End SECT_PAR.
-
Section SECT_BBLOCK_EQUIV.
Variable Ge: genv.
-Local Hint Resolve trans_state_match.
+Local Hint Resolve trans_state_match: core.
Lemma bblock_simu_reduce:
forall p1 p2 ge fn,
Ge = Genv ge fn ->
L.bblock_simu Ge (trans_block p1) (trans_block p2) ->
- Asmblockgenproof0.bblock_simu ge fn p1 p2.
+ Asmblockprops.bblock_simu ge fn p1 p2.
Proof.
unfold bblock_simu, res_eq; intros p1 p2 ge fn H1 H2 rs m DONTSTUCK.
generalize (H2 (trans_state (State rs m))); clear H2.
intro H2.
- exploit (forward_simu Ge rs m p1 ge fn (trans_state (State rs m))); eauto.
- exploit (forward_simu Ge rs m p2 ge fn (trans_state (State rs m))); eauto.
+ exploit (bisimu Ge rs m p1 ge fn (trans_state (State rs m))); eauto.
+ exploit (bisimu Ge rs m p2 ge fn (trans_state (State rs m))); eauto.
destruct (exec_bblock ge fn p1 rs m); try congruence.
intros H3 (s2' & exp2 & MS'). unfold exec in exp2, H3. rewrite exp2 in H2.
destruct H2 as (m2' & H2 & H4). discriminate. rewrite H2 in H3.
@@ -1320,6 +1448,8 @@ Proof.
* discriminate.
Qed.
+(** Used for debug traces *)
+
Definition gpreg_name (gpr: gpreg) :=
match gpr with
| GPR0 => Str ("GPR0") | GPR1 => Str ("GPR1") | GPR2 => Str ("GPR2") | GPR3 => Str ("GPR3") | GPR4 => Str ("GPR4")
@@ -1369,6 +1499,7 @@ Definition string_of_name_rr (n: arith_name_rr): pstring :=
| Pfabsw => "Pfabsw"
| Pfnegd => "Pfnegd"
| Pfnegw => "Pfnegw"
+ | Pfinvw => "Pfinvw"
| Pfnarrowdw => "Pfnarrowdw"
| Pfwidenlwd => "Pfwidenlwd"
| Pfloatwrnsz => "Pfloatwrnsz"
@@ -1405,12 +1536,14 @@ Definition string_of_name_rf64 (n: arith_name_rf64): pstring :=
Definition string_of_name_rrr (n: arith_name_rrr): pstring :=
match n with
- Pcompw _ => "Pcompw"
+ | Pcompw _ => "Pcompw"
| Pcompl _ => "Pcompl"
| Pfcompw _ => "Pfcompw"
| Pfcompl _ => "Pfcompl"
| Paddw => "Paddw"
+ | Paddxw _ => "Paddxw"
| Psubw => "Psubw"
+ | Prevsubxw _ => "Prevsubxw"
| Pmulw => "Pmulw"
| Pandw => "Pandw"
| Pnandw => "Pnandw"
@@ -1425,7 +1558,9 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring :=
| Psrxw => "Psrxw"
| Psllw => "Psllw"
| Paddl => "Paddl"
+ | Paddxl _ => "Paddxl"
| Psubl => "Psubl"
+ | Prevsubxl _ => "Prevsubxl"
| Pandl => "Pandl"
| Pnandl => "Pnandl"
| Porl => "Porl"
@@ -1445,12 +1580,19 @@ Definition string_of_name_rrr (n: arith_name_rrr): pstring :=
| Pfsbfw => "Pfsbfw"
| Pfmuld => "Pfmuld"
| Pfmulw => "Pfmulw"
+ | Pfmind => "Pfmind"
+ | Pfminw => "Pfminw"
+ | Pfmaxd => "Pfmaxd"
+ | Pfmaxw => "Pfmaxw"
end.
Definition string_of_name_rri32 (n: arith_name_rri32): pstring :=
match n with
Pcompiw _ => "Pcompiw"
| Paddiw => "Paddiw"
+ | Paddxiw _ => "Paddxiw"
+ | Prevsubiw => "Prevsubiw"
+ | Prevsubxiw _ => "Prevsubxiw"
| Pmuliw => "Pmuliw"
| Pandiw => "Pandiw"
| Pnandiw => "Pnandiw"
@@ -1475,6 +1617,9 @@ Definition string_of_name_rri64 (n: arith_name_rri64): pstring :=
match n with
Pcompil _ => "Pcompil"
| Paddil => "Paddil"
+ | Prevsubil => "Prevsubil"
+ | Paddxil _ => "Paddxil"
+ | Prevsubxil _ => "Prevsubxil"
| Pmulil => "Pmulil"
| Pandil => "Pandil"
| Pnandil => "Pnandil"
@@ -1490,8 +1635,14 @@ Definition string_of_name_arrr (n: arith_name_arrr): pstring :=
match n with
| Pmaddw => "Pmaddw"
| Pmaddl => "Pmaddl"
+ | Pmsubw => "Pmsubw"
+ | Pmsubl => "Pmsubl"
| Pcmove _ => "Pcmove"
| Pcmoveu _ => "Pcmoveu"
+ | Pfmaddfw => "Pfmaddfw"
+ | Pfmaddfl => "Pfmaddfl"
+ | Pfmsubfw => "Pfmsubfw"
+ | Pfmsubfl => "Pfmsubfl"
end.
Definition string_of_name_arr (n: arith_name_arr): pstring :=
@@ -1503,11 +1654,15 @@ Definition string_of_name_arr (n: arith_name_arr): pstring :=
Definition string_of_name_arri32 (n: arith_name_arri32): pstring :=
match n with
| Pmaddiw => "Pmaddw"
+ | Pcmoveiw _ => "Pcmoveiw"
+ | Pcmoveuiw _ => "Pcmoveuiw"
end.
Definition string_of_name_arri64 (n: arith_name_arri64): pstring :=
match n with
| Pmaddil => "Pmaddl"
+ | Pcmoveil _ => "Pcmoveil"
+ | Pcmoveuil _ => "Pcmoveuil"
end.
Definition string_of_arith (op: arith_op): pstring :=
@@ -1543,9 +1698,9 @@ Definition string_of_load_name (n: load_name) : pstring :=
Definition string_of_load (op: load_op): pstring :=
match op with
- | OLoadRRO n _ => string_of_load_name n
- | OLoadRRR n => string_of_load_name n
- | OLoadRRRXS n => string_of_load_name n
+ | OLoadRRO n _ _ => string_of_load_name n
+ | OLoadRRR n _ => string_of_load_name n
+ | OLoadRRRXS n _ => string_of_load_name n
end.
Definition string_of_store_name (n: store_name) : pstring :=
@@ -1593,16 +1748,46 @@ Definition string_of_op (op: P.op): ?? pstring :=
| Fail => RET (Str "Fail")
end.
+End SECT_BBLOCK_EQUIV.
+
+(** REWRITE RULES *)
+
+Definition is_constant (o: op): bool :=
+ match o with
+ | Constant _ | OArithR _ | OArithRI32 _ _ | OArithRI64 _ _ | OArithRF32 _ _ | OArithRF64 _ _ => true
+ | _ => false
+ end.
+
+Lemma is_constant_correct ge o: is_constant o = true -> op_eval ge o [] <> None.
+Proof.
+ destruct o; simpl in * |- *; try congruence.
+ destruct ao; simpl in * |- *; try congruence;
+ destruct n; simpl in * |- *; try congruence;
+ unfold arith_eval; destruct ge; simpl in * |- *; try congruence.
+Qed.
+
+Definition main_reduce (t: Terms.term):= RET (Terms.nofail is_constant t).
+
+Local Hint Resolve is_constant_correct: wlp.
+
+Lemma main_reduce_correct t:
+ WHEN main_reduce t ~> pt THEN Terms.match_pt t pt.
+Proof.
+ wlp_simplify.
+Qed.
+
+Definition reduce := {| Terms.result := main_reduce; Terms.result_correct := main_reduce_correct |}.
+
Definition bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock) : ?? bool :=
if verb then
- IDT.verb_bblock_simu_test string_of_name string_of_op (trans_block p1) (trans_block p2)
+ IST.verb_bblock_simu_test reduce string_of_name string_of_op (trans_block p1) (trans_block p2)
else
- IDT.bblock_simu_test (trans_block p1) (trans_block p2).
+ IST.bblock_simu_test reduce (trans_block p1) (trans_block p2).
-Local Hint Resolve IDT.bblock_simu_test_correct bblock_simu_reduce IDT.verb_bblock_simu_test_correct: wlp.
+Local Hint Resolve IST.bblock_simu_test_correct bblock_simu_reduce IST.verb_bblock_simu_test_correct: wlp.
Theorem bblock_simu_test_correct verb p1 p2 :
- WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Ge = Genv ge fn -> Asmblockgenproof0.bblock_simu ge fn p1 p2.
+ WHEN bblock_simu_test verb p1 p2 ~> b THEN b=true -> forall ge fn, Asmblockprops.bblock_simu ge fn p1 p2.
Proof.
wlp_simplify.
Qed.
@@ -1612,19 +1797,23 @@ Hint Resolve bblock_simu_test_correct: wlp.
Import UnsafeImpure.
-Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool := unsafe_coerce (bblock_simu_test verb p1 p2).
+Definition pure_bblock_simu_test (verb: bool) (p1 p2: Asmvliw.bblock): bool :=
+ match unsafe_coerce (bblock_simu_test verb p1 p2) with
+ | Some b => b
+ | None => false
+ end.
-Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: Ge = Genv ge fn -> pure_bblock_simu_test verb p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2.
+Theorem pure_bblock_simu_test_correct verb p1 p2 ge fn: pure_bblock_simu_test verb p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2.
Proof.
- intros; unfold pure_bblock_simu_test. intros; eapply bblock_simu_test_correct; eauto.
+ unfold pure_bblock_simu_test.
+ destruct (unsafe_coerce (bblock_simu_test verb p1 p2)) eqn: UNSAFE; try discriminate.
+ intros; subst. eapply bblock_simu_test_correct; eauto.
apply unsafe_coerce_not_really_correct; eauto.
Qed.
Definition bblock_simub: Asmvliw.bblock -> Asmvliw.bblock -> bool := pure_bblock_simu_test true.
-Lemma bblock_simub_correct p1 p2 ge fn: Ge = Genv ge fn -> bblock_simub p1 p2 = true -> Asmblockgenproof0.bblock_simu ge fn p1 p2.
+Lemma bblock_simub_correct p1 p2 ge fn: bblock_simub p1 p2 = true -> Asmblockprops.bblock_simu ge fn p1 p2.
Proof.
eapply (pure_bblock_simu_test_correct true).
Qed.
-
-End SECT_BBLOCK_EQUIV.
diff --git a/mppa_k1c/Asmblockgen.v b/mppa_k1c/Asmblockgen.v
index a4364051..36269954 100644
--- a/mppa_k1c/Asmblockgen.v
+++ b/mppa_k1c/Asmblockgen.v
@@ -15,7 +15,8 @@
(* *)
(* *********************************************************************)
-(** Translation from Machblock to K1c assembly language (Asmblock) *)
+(** * Translation from Machblock to K1c assembly language (Asmblock)
+ Inspired from the Mach->Asm pass of other backends, but adapted to the block structure *)
Require Archi.
Require Import Coqlib Errors.
@@ -27,6 +28,8 @@ Require Import Chunks.
Local Open Scope string_scope.
Local Open Scope error_monad_scope.
+Import PArithCoercions.
+
(** The code generation functions take advantage of several
characteristics of the [Mach] code generated by earlier passes of the
compiler, mostly that argument and result registers are of the correct
@@ -41,23 +44,15 @@ Definition ireg_of (r: mreg) : res ireg :=
Definition freg_of (r: mreg) : res freg :=
match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgenblock.freg_of") end.
-(*
-(** Decomposition of 32-bit integer constants. They are split into either
- small signed immediates that fit in 12-bits, or, if they do not fit,
- into a (20-bit hi, 12-bit lo) pair where lo is sign-extended. *)
-
-*)
Inductive immed32 : Type :=
| Imm32_single (imm: int).
Definition make_immed32 (val: int) := Imm32_single val.
-(** Likewise, for 64-bit integer constants. *)
Inductive immed64 : Type :=
| Imm64_single (imm: int64)
.
-(* For now, let's suppose all instructions of K1c can handle 64-bits immediate *)
Definition make_immed64 (val: int64) := Imm64_single val.
Notation "a ::g b" := (cons (A:=instruction) a b) (at level 49, right associativity).
@@ -66,12 +61,6 @@ Notation "a ::b lb" := ((bblock_single_inst a) :: lb) (at level 49, right associ
Notation "a ++g b" := (app (A:=instruction) a b) (at level 49, right associativity).
Notation "a @@ b" := (app a b) (at level 49, right associativity).
-(** Smart constructors for arithmetic operations involving
- a 32-bit or 64-bit integer constant. Depending on whether the
- constant fits in 12 bits or not, one or several instructions
- are generated as required to perform the operation
- and prepended to the given instruction sequence [k]. *)
-
Definition loadimm32 (r: ireg) (n: int) :=
match make_immed32 n with
| Imm32_single imm => Pmake r imm
@@ -92,10 +81,6 @@ Definition orimm32 := opimm32 Porw Poriw.
Definition norimm32 := opimm32 Pnorw Pnoriw.
Definition xorimm32 := opimm32 Pxorw Pxoriw.
Definition nxorimm32 := opimm32 Pnxorw Pnxoriw.
-(*
-Definition sltimm32 := opimm32 Psltw Psltiw.
-Definition sltuimm32 := opimm32 Psltuw Psltiuw.
-*)
Definition loadimm64 (r: ireg) (n: int64) :=
match make_immed64 n with
@@ -118,11 +103,6 @@ Definition norimm64 := opimm64 Pnorl Pnoril.
Definition nandimm64 := opimm64 Pnandl Pnandil.
Definition nxorimm64 := opimm64 Pnxorl Pnxoril.
-(*
-Definition sltimm64 := opimm64 Psltl Psltil.
-Definition sltuimm64 := opimm64 Psltul Psltiul.
-*)
-
Definition addptrofs (rd rs: ireg) (n: ptrofs) :=
if Ptrofs.eq_dec n Ptrofs.zero then
Pmv rd rs
@@ -170,19 +150,6 @@ Definition transl_opt_compuimm
transl_compi c Unsigned r1 n lbl k
.
-(* Definition transl_opt_compuimm
- (n: int) (c: comparison) (r1: ireg) (lbl: label) (k: code) : list instruction :=
- loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k). *)
-
-(* match select_comp n c with
- | Some Ceq => Pcbu BTweqz r1 lbl ::g k
- | Some Cne => Pcbu BTwnez r1 lbl ::g k
- | Some _ => nil (* Never happens *)
- | None => loadimm32 RTMP n ::g (transl_comp c Unsigned r1 RTMP lbl k)
- end
- .
- *)
-
Definition select_compl (n: int64) (c: comparison) : option comparison :=
if Int64.eq n Int64.zero then
match c with
@@ -334,6 +301,75 @@ Definition transl_cond_notfloat64 (cmp: comparison) (rd r1 r2: ireg) (k: bcode)
| Reversed ft => Pfcompl ft rd r2 r1 ::i k
end.
+
+(* CoMPare Unsigned Words to Zero *)
+Definition btest_for_cmpuwz (c: comparison) :=
+ match c with
+ | Cne => OK BTwnez
+ | Ceq => OK BTweqz
+ | Clt => Error (msg "btest_for_compuwz: Clt")
+ | Cge => Error (msg "btest_for_compuwz: Cge")
+ | Cle => OK BTweqz
+ | Cgt => OK BTwnez
+ end.
+
+(* CoMPare Unsigned Words to Zero *)
+Definition btest_for_cmpudz (c: comparison) :=
+ match c with
+ | Cne => OK BTdnez
+ | Ceq => OK BTdeqz
+ | Clt => Error (msg "btest_for_compudz: Clt")
+ | Cge => Error (msg "btest_for_compudz: Cge")
+ | Cle => OK BTdeqz
+ | Cgt => OK BTdnez
+ end.
+
+Definition conditional_move (cond0 : condition0) (rc rd rs : ireg) :
+ res basic :=
+ if ireg_eq rd rs
+ then OK Pnop
+ else
+ (match cond0 with
+ | Ccomp0 cmp =>
+ OK (PArith (Pcmove (btest_for_cmpswz cmp) rd rc rs))
+ | Ccompu0 cmp =>
+ do bt <- btest_for_cmpuwz cmp;
+ OK (PArith (Pcmoveu bt rd rc rs))
+ | Ccompl0 cmp =>
+ OK (PArith (Pcmove (btest_for_cmpsdz cmp) rd rc rs))
+ | Ccomplu0 cmp =>
+ do bt <- btest_for_cmpudz cmp;
+ OK (PArith (Pcmoveu bt rd rc rs))
+ end).
+
+Definition conditional_move_imm32 (cond0 : condition0) (rc rd : ireg) (imm : int) : res basic :=
+ match cond0 with
+ | Ccomp0 cmp =>
+ OK (PArith (Pcmoveiw (btest_for_cmpswz cmp) rd rc imm))
+ | Ccompu0 cmp =>
+ do bt <- btest_for_cmpuwz cmp;
+ OK (PArith (Pcmoveuiw bt rd rc imm))
+ | Ccompl0 cmp =>
+ OK (PArith (Pcmoveiw (btest_for_cmpsdz cmp) rd rc imm))
+ | Ccomplu0 cmp =>
+ do bt <- btest_for_cmpudz cmp;
+ OK (PArith (Pcmoveuiw bt rd rc imm))
+ end.
+
+Definition conditional_move_imm64 (cond0 : condition0) (rc rd : ireg) (imm : int64) : res basic :=
+ match cond0 with
+ | Ccomp0 cmp =>
+ OK (PArith (Pcmoveil (btest_for_cmpswz cmp) rd rc imm))
+ | Ccompu0 cmp =>
+ do bt <- btest_for_cmpuwz cmp;
+ OK (PArith (Pcmoveuil bt rd rc imm))
+ | Ccompl0 cmp =>
+ OK (PArith (Pcmoveil (btest_for_cmpsdz cmp) rd rc imm))
+ | Ccomplu0 cmp =>
+ do bt <- btest_for_cmpudz cmp;
+ OK (PArith (Pcmoveuil bt rd rc imm))
+ end.
+
Definition transl_cond_op
(cond: condition) (rd: ireg) (args: list mreg) (k: bcode) :=
match cond, args with
@@ -377,28 +413,6 @@ Definition transl_cond_op
Error(msg "Asmblockgen.transl_cond_op")
end.
-(* CoMPare Unsigned Words to Zero *)
-Definition btest_for_cmpuwz (c: comparison) :=
- match c with
- | Cne => OK BTwnez
- | Ceq => OK BTweqz
- | Clt => Error (msg "btest_for_compuwz: Clt")
- | Cge => Error (msg "btest_for_compuwz: Cge")
- | Cle => Error (msg "btest_for_compuwz: Cle")
- | Cgt => Error (msg "btest_for_compuwz: Cgt")
- end.
-
-(* CoMPare Unsigned Words to Zero *)
-Definition btest_for_cmpudz (c: comparison) :=
- match c with
- | Cne => OK BTdnez
- | Ceq => OK BTdeqz
- | Clt => Error (msg "btest_for_compudz: Clt")
- | Cge => Error (msg "btest_for_compudz: Cge")
- | Cle => Error (msg "btest_for_compudz: Cle")
- | Cgt => Error (msg "btest_for_compudz: Cgt")
- end.
-
(** Translation of the arithmetic operation [r <- op(args)].
The corresponding instructions are prepended to [k]. *)
@@ -443,12 +457,33 @@ Definition transl_op
| Oaddimm n, a1 :: nil =>
do rd <- ireg_of res; do rs <- ireg_of a1;
OK (addimm32 rd rs n ::i k)
+ | Oaddx shift, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+ OK (Paddxw shift rd rs1 rs2 ::i k)
+ | Oaddximm shift n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Paddxiw shift rd rs n ::i k)
+ | Oaddxl shift, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+ OK (Paddxl shift rd rs1 rs2 ::i k)
+ | Oaddxlimm shift n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Paddxil shift rd rs n ::i k)
| Oneg, a1 :: nil =>
do rd <- ireg_of res; do rs <- ireg_of a1;
OK (Pnegw rd rs ::i k)
| Osub, a1 :: a2 :: nil =>
do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
OK (Psubw rd rs1 rs2 ::i k)
+ | Orevsubimm n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Prevsubiw rd rs n ::i k)
+ | Orevsubx shift, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+ OK (Prevsubxw shift rd rs1 rs2 ::i k)
+ | Orevsubximm shift n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Prevsubxiw shift rd rs n ::i k)
| Omul, a1 :: a2 :: nil =>
do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
OK (Pmulw rd rs1 rs2 ::i k)
@@ -543,6 +578,12 @@ Definition transl_op
do r1 <- ireg_of a1;
do r2 <- ireg_of a2;
OK (Pmaddiw r1 r2 n ::i k)
+ | Omsub, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r1 <- ireg_of a1;
+ do r2 <- ireg_of a2;
+ do r3 <- ireg_of a3;
+ OK (Pmsubw r1 r2 r3 ::i k)
(* [Omakelong], [Ohighlong] should not occur *)
| Olowlong, a1 :: nil =>
do rd <- ireg_of res; do rs <- ireg_of a1;
@@ -567,6 +608,15 @@ Definition transl_op
| Osubl, a1 :: a2 :: nil =>
do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
OK (Psubl rd rs1 rs2 ::i k)
+ | Orevsubxl shift, a1 :: a2 :: nil =>
+ do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
+ OK (Prevsubxl shift rd rs1 rs2 ::i k)
+ | Orevsublimm n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Prevsubil rd rs n ::i k)
+ | Orevsubxlimm shift n, a1 :: nil =>
+ do rd <- ireg_of res; do rs <- ireg_of a1;
+ OK (Prevsubxil shift rd rs n ::i k)
| Omull, a1 :: a2 :: nil =>
do rd <- ireg_of res; do rs1 <- ireg_of a1; do rs2 <- ireg_of a2;
OK (Pmull rd rs1 rs2 ::i k)
@@ -662,6 +712,12 @@ Definition transl_op
do r1 <- ireg_of a1;
do r2 <- ireg_of a2;
OK (Pmaddil r1 r2 n ::i k)
+ | Omsubl, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do r1 <- ireg_of a1;
+ do r2 <- ireg_of a2;
+ do r3 <- ireg_of a3;
+ OK (Pmsubl r1 r2 r3 ::i k)
| Oabsf, a1 :: nil =>
do rd <- freg_of res; do rs <- freg_of a1;
OK (Pfabsd rd rs ::i k)
@@ -686,12 +742,52 @@ Definition transl_op
| Omulfs, a1 :: a2 :: nil =>
do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
OK (Pfmulw rd rs1 rs2 ::i k)
+ | Ominf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfmind rd rs1 rs2 ::i k)
+ | Ominfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfminw rd rs1 rs2 ::i k)
+ | Omaxf, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfmaxd rd rs1 rs2 ::i k)
+ | Omaxfs, a1 :: a2 :: nil =>
+ do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
+ OK (Pfmaxw rd rs1 rs2 ::i k)
| Onegf, a1 :: nil =>
do rd <- freg_of res; do rs <- freg_of a1;
OK (Pfnegd rd rs ::i k)
| Onegfs, a1 :: nil =>
do rd <- freg_of res; do rs <- freg_of a1;
OK (Pfnegw rd rs ::i k)
+ | Oinvfs, a1 :: nil =>
+ do rd <- freg_of res; do rs <- freg_of a1;
+ OK (Pfinvw rd rs ::i k)
+
+ | Ofmaddf, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do rs1 <- freg_of a1;
+ do rs2 <- freg_of a2;
+ do rs3 <- freg_of a3;
+ OK (Pfmaddfl rs1 rs2 rs3 ::i k)
+ | Ofmaddfs, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do rs1 <- freg_of a1;
+ do rs2 <- freg_of a2;
+ do rs3 <- freg_of a3;
+ OK (Pfmaddfw rs1 rs2 rs3 ::i k)
+ | Ofmsubf, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do rs1 <- freg_of a1;
+ do rs2 <- freg_of a2;
+ do rs3 <- freg_of a3;
+ OK (Pfmsubfl rs1 rs2 rs3 ::i k)
+ | Ofmsubfs, a1 :: a2 :: a3 :: nil =>
+ assertion (mreg_eq a1 res);
+ do rs1 <- freg_of a1;
+ do rs2 <- freg_of a2;
+ do rs3 <- freg_of a3;
+ OK (Pfmsubfw rs1 rs2 rs3 ::i k)
| Osingleofint, a1 :: nil =>
do rd <- freg_of res; do rs <- ireg_of a1;
@@ -742,31 +838,10 @@ Definition transl_op
| Olonguofsingle , _ => Error (msg "Asmblockgen.transl_op: Olonguofsingle")
-
| Ocmp cmp, _ =>
do rd <- ireg_of res;
transl_cond_op cmp rd args k
- | Oselect cond, a0 :: a1 :: aS :: nil
- | Oselectl cond, a0 :: a1 :: aS :: nil
- | Oselectf cond, a0 :: a1 :: aS :: nil
- | Oselectfs cond, a0 :: a1 :: aS :: nil =>
- assertion (mreg_eq a0 res);
- do r0 <- ireg_of a0;
- do r1 <- ireg_of a1;
- do rS <- ireg_of aS;
- (match cond with
- | Ccomp0 cmp =>
- OK (Pcmove (btest_for_cmpswz cmp) r0 rS r1 ::i k)
- | Ccompu0 cmp =>
- do bt <- btest_for_cmpuwz cmp;
- OK (Pcmoveu bt r0 rS r1 ::i k)
- | Ccompl0 cmp =>
- OK (Pcmove (btest_for_cmpsdz cmp) r0 rS r1 ::i k)
- | Ccomplu0 cmp =>
- do bt <- btest_for_cmpudz cmp;
- OK (Pcmoveu bt r0 rS r1 ::i k)
- end)
| Oextfz stop start, a1 :: nil =>
assertion (ExtValues.is_bitfield stop start);
@@ -800,6 +875,29 @@ Definition transl_op
do rd <- ireg_of res; do rs <- ireg_of a1;
OK (Pinsfl stop start rd rs ::i k)
+ | Osel cond0 ty, aT :: aF :: aC :: nil =>
+ assertion (mreg_eq aT res);
+ do rT <- ireg_of aT;
+ do rF <- ireg_of aF;
+ do rC <- ireg_of aC;
+ do op <- conditional_move (negate_condition0 cond0) rC rT rF;
+ OK (op ::i k)
+
+ | Oselimm cond0 imm, aT :: aC :: nil =>
+ assertion (mreg_eq aT res);
+ do rT <- ireg_of aT;
+ do rC <- ireg_of aC;
+ do op <- conditional_move_imm32 (negate_condition0 cond0) rC rT imm;
+ OK (op ::i k)
+
+
+ | Osellimm cond0 imm, aT :: aC :: nil =>
+ assertion (mreg_eq aT res);
+ do rT <- ireg_of aT;
+ do rC <- ireg_of aC;
+ do op <- conditional_move_imm64 (negate_condition0 cond0) rC rT imm;
+ OK (op ::i k)
+
| _, _ =>
Error(msg "Asmgenblock.transl_op")
end.
@@ -816,12 +914,12 @@ end.
Definition loadind (base: ireg) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: bcode) :=
match ty, preg_of dst with
- | Tint, IR rd => OK (indexed_memory_access (PLoadRRO Plw rd) base ofs ::i k)
- | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO Pld rd) base ofs ::i k)
- | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO Pfls rd) base ofs ::i k)
- | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO Pfld rd) base ofs ::i k)
- | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO Plw_a rd) base ofs ::i k)
- | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO Pld_a rd) base ofs ::i k)
+ | Tint, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw rd) base ofs ::i k)
+ | Tlong, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld rd) base ofs ::i k)
+ | Tsingle, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfls rd) base ofs ::i k)
+ | Tfloat, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pfld rd) base ofs ::i k)
+ | Tany32, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Plw_a rd) base ofs ::i k)
+ | Tany64, IR rd => OK (indexed_memory_access (PLoadRRO TRAP Pld_a rd) base ofs ::i k)
| _, _ => Error (msg "Asmblockgen.loadind")
end.
@@ -837,7 +935,7 @@ Definition storeind (src: mreg) (base: ireg) (ofs: ptrofs) (ty: typ) (k: bcode)
end.
Definition loadind_ptr (base: ireg) (ofs: ptrofs) (dst: ireg) :=
- indexed_memory_access (PLoadRRO Pld dst) base ofs.
+ indexed_memory_access (PLoadRRO TRAP Pld dst) base ofs.
Definition storeind_ptr (src: ireg) (base: ireg) (ofs: ptrofs) :=
indexed_memory_access (PStoreRRO Psd src) base ofs.
@@ -897,27 +995,28 @@ Definition chunk2load (chunk: memory_chunk) :=
| Many64 => Pld_a
end.
-Definition transl_load_rro (chunk: memory_chunk) (addr: addressing)
+Definition transl_load_rro (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing)
(args: list mreg) (dst: mreg) (k: bcode) : res bcode :=
do r <- ireg_of dst;
- transl_memory_access (PLoadRRO (chunk2load chunk) r) addr args k.
+ transl_memory_access (PLoadRRO trap (chunk2load chunk) r) addr args k.
-Definition transl_load_rrr (chunk: memory_chunk) (addr: addressing)
+Definition transl_load_rrr (trap: trapping_mode) (chunk: memory_chunk) (addr: addressing)
(args: list mreg) (dst: mreg) (k: bcode) : res bcode :=
do r <- ireg_of dst;
- transl_memory_access2 (PLoadRRR (chunk2load chunk) r) addr args k.
+ transl_memory_access2 (PLoadRRR trap (chunk2load chunk) r) addr args k.
-Definition transl_load_rrrXS (chunk: memory_chunk) (scale : Z)
+Definition transl_load_rrrXS (trap: trapping_mode) (chunk: memory_chunk) (scale : Z)
(args: list mreg) (dst: mreg) (k: bcode) : res bcode :=
do r <- ireg_of dst;
- transl_memory_access2XS chunk (PLoadRRRXS (chunk2load chunk) r) scale args k.
+ transl_memory_access2XS chunk (PLoadRRRXS trap (chunk2load chunk) r) scale args k.
-Definition transl_load (chunk: memory_chunk) (addr: addressing)
+Definition transl_load (trap : trapping_mode)
+ (chunk: memory_chunk) (addr: addressing)
(args: list mreg) (dst: mreg) (k: bcode) : res bcode :=
match addr with
- | Aindexed2XS scale => transl_load_rrrXS chunk scale args dst k
- | Aindexed2 => transl_load_rrr chunk addr args dst k
- | _ => transl_load_rro chunk addr args dst k
+ | Aindexed2XS scale => transl_load_rrrXS trap chunk scale args dst k
+ | Aindexed2 => transl_load_rrr trap chunk addr args dst k
+ | _ => transl_load_rro trap chunk addr args dst k
end.
Definition chunk2store (chunk: memory_chunk) :=
@@ -961,7 +1060,7 @@ Definition make_epilogue (f: Machblock.function) (k: code) :=
(loadind_ptr SP f.(fn_retaddr_ofs) GPRA)
::g Pset RA GPRA ::g Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) ::g k.
-(** Translation of a Mach instruction. *)
+(** Translation of a Machblock instruction. *)
Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst)
(ep: bool) (k: bcode) :=
@@ -977,8 +1076,8 @@ Definition transl_instr_basic (f: Machblock.function) (i: Machblock.basic_inst)
else (loadind_ptr SP f.(fn_link_ofs) FP) ::i c)
| MBop op args res =>
transl_op op args res k
- | MBload chunk addr args dst =>
- transl_load chunk addr args dst k
+ | MBload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
| MBstore chunk addr args src =>
transl_store chunk addr args src k
end.
@@ -1005,32 +1104,25 @@ Definition transl_instr_control (f: Machblock.function) (oi: option Machblock.co
transl_cbranch cond args lbl nil
| MBreturn =>
OK (make_epilogue f (Pret ::g nil))
- (*OK (make_epilogue f (Pj_r RA f.(Mach.fn_sig) :: k))*)
| MBjumptable arg tbl =>
do r <- ireg_of arg;
OK (Pjumptable r tbl ::g nil)
end
end.
-(* TODO - dans l'idée, transl_instr_control renvoie une liste d'instructions sous la forme :
- * transl_instr_control _ _ _ = lb ++ (ctl :: nil), où lb est une liste de basics, ctl est un control_inst
-
- Il faut arriver à exprimer cet aspect là ; extraire le lb, le rajouter dans le body ; et extraire le ctl
- qu'on met dans le exit
-*)
-
(** Translation of a code sequence *)
Definition fp_is_parent (before: bool) (i: Machblock.basic_inst) : bool :=
match i with
+ | MBgetstack ofs ty dst => before && negb (mreg_eq dst MFP)
| MBsetstack src ofs ty => before
| MBgetparam ofs ty dst => negb (mreg_eq dst MFP)
| MBop op args res => before && negb (mreg_eq res MFP)
- | _ => false
+ | MBload trapping_mode chunk addr args dst => before && negb (mreg_eq dst MFP)
+ | MBstore chunk addr args res => before
end.
-(** This is the naive definition that we no longer use because it
- is not tail-recursive. It is kept as specification. *)
+(** This is the naive definition, which is not tail-recursive unlike the other backends *)
Fixpoint transl_basic_code (f: Machblock.function) (il: list Machblock.basic_inst) (it1p: bool) :=
match il with
@@ -1056,20 +1148,11 @@ Definition transl_basic_code' (f: Machblock.function) (il: list Machblock.basic_
transl_basic_rec f il it1p (fun c => OK c). *)
(** Translation of a whole function. Note that we must check
- that the generated code contains less than [2^32] instructions,
+ that the generated code contains less than [2^64] instructions,
otherwise the offset part of the [PC] code pointer could wrap
around, leading to incorrect executions. *)
-(* Local Obligation Tactic := bblock_auto_correct. *)
-
-(* Program Definition gen_bblock_noctl (hd: list label) (c: list basic) :=
- match c with
- | nil => {| header := hd; body := Pnop::nil; exit := None |}
- | i::c => {| header := hd; body := i::c; exit := None |}
- end.
- *)
-
-(** Can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *)
+(* gen_bblocks can generate two bblocks if the ctl is a PExpand (since the PExpand must be alone in its block) *)
Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instruction) :=
match (extract_ctl ctl) with
| None =>
@@ -1077,7 +1160,6 @@ Program Definition gen_bblocks (hd: list label) (c: list basic) (ctl: list instr
| nil => {| header := hd; body := Pnop::nil; exit := None |} :: nil
| i::c => {| header := hd; body := ((i::c) ++ extract_basic ctl); exit := None |} :: nil
end
-(* gen_bblock_noctl hd (c ++ (extract_basic ctl)) :: nil *)
| Some (PExpand (Pbuiltin ef args res)) =>
match c with
| nil => {| header := hd; body := nil; exit := Some (PExpand (Pbuiltin ef args res)) |} :: nil
diff --git a/mppa_k1c/Asmblockgenproof.v b/mppa_k1c/Asmblockgenproof.v
index c44ef3ff..1a427112 100644
--- a/mppa_k1c/Asmblockgenproof.v
+++ b/mppa_k1c/Asmblockgenproof.v
@@ -1,1797 +1,1804 @@
-(* *********************************************************************)
-(* *)
-(* The Compcert verified compiler *)
-(* *)
-(* Xavier Leroy, INRIA Paris-Rocquencourt *)
-(* *)
-(* Copyright Institut National de Recherche en Informatique et en *)
-(* Automatique. All rights reserved. This file is distributed *)
-(* under the terms of the INRIA Non-Commercial License Agreement. *)
-(* *)
-(* *********************************************************************)
-
-(** Correctness proof for RISC-V generation: main proof. *)
-
-Require Import Coqlib Errors.
-Require Import Integers Floats AST Linking.
-Require Import Values Memory Events Globalenvs Smallstep.
-Require Import Op Locations Machblock Conventions Asmblock.
-Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1.
-Require Import Axioms.
-
-Module MB := Machblock.
-Module AB := Asmvliw.
-
-Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) :=
- match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
-
-Lemma transf_program_match:
- forall p tp, transf_program p = OK tp -> match_prog p tp.
-Proof.
- intros. eapply match_transform_partial_program; eauto.
-Qed.
-
-Section PRESERVATION.
-
-Variable prog: Machblock.program.
-Variable tprog: Asmvliw.program.
-Hypothesis TRANSF: match_prog prog tprog.
-Let ge := Genv.globalenv prog.
-Let tge := Genv.globalenv tprog.
-
-Lemma symbols_preserved:
- forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
-Proof (Genv.find_symbol_match TRANSF).
-
-Lemma senv_preserved:
- Senv.equiv ge tge.
-Proof (Genv.senv_match TRANSF).
-
-
-Lemma functions_translated:
- forall b f,
- Genv.find_funct_ptr ge b = Some f ->
- exists tf,
- Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
-Proof (Genv.find_funct_ptr_transf_partial TRANSF).
-
-Lemma functions_transl:
- forall fb f tf,
- Genv.find_funct_ptr ge fb = Some (Internal f) ->
- transf_function f = OK tf ->
- Genv.find_funct_ptr tge fb = Some (Internal tf).
-Proof.
- intros. exploit functions_translated; eauto. intros [tf' [A B]].
- monadInv B. rewrite H0 in EQ; inv EQ; auto.
-Qed.
-
-(** * Properties of control flow *)
-
-Lemma transf_function_no_overflow:
- forall f tf,
- transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned.
-Proof.
- intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0.
- omega.
-Qed.
-
-(** The following lemmas show that the translation from Mach to Asm
- preserves labels, in the sense that the following diagram commutes:
-<<
- translation
- Mach code ------------------------ Asm instr sequence
- | |
- | Mach.find_label lbl find_label lbl |
- | |
- v v
- Mach code tail ------------------- Asm instr seq tail
- translation
->>
- The proof demands many boring lemmas showing that Asm constructor
- functions do not introduce new labels.
-*)
-
-Section TRANSL_LABEL.
-
-Lemma gen_bblocks_label:
- forall hd bdy ex tbb tc,
- gen_bblocks hd bdy ex = tbb::tc ->
- header tbb = hd.
-Proof.
- intros until tc. intros GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
- all: inv GENB; simpl; auto.
-Qed.
-
-Lemma gen_bblocks_label2:
- forall hd bdy ex tbb1 tbb2,
- gen_bblocks hd bdy ex = tbb1::tbb2::nil ->
- header tbb2 = nil.
-Proof.
- intros until tbb2. intros GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
- all: inv GENB; simpl; auto.
-Qed.
-
-Lemma in_dec_transl:
- forall lbl hd,
- (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false).
-Proof.
- intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto.
-Qed.
-
-Lemma transl_is_label:
- forall lbl bb tbb f ep tc,
- transl_block f bb ep = OK (tbb::tc) ->
- is_label lbl tbb = MB.is_label lbl bb.
-Proof.
- intros until tc. intros TLB.
- destruct tbb as [thd tbdy tex]; simpl in *.
- monadInv TLB.
- unfold is_label. simpl.
- apply gen_bblocks_label in H0. simpl in H0. subst.
- rewrite in_dec_transl. auto.
-Qed.
-
-Lemma transl_is_label_false2:
- forall lbl bb f ep tbb1 tbb2,
- transl_block f bb ep = OK (tbb1::tbb2::nil) ->
- is_label lbl tbb2 = false.
-Proof.
- intros until tbb2. intros TLB.
- destruct tbb2 as [thd tbdy tex]; simpl in *.
- monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst.
- apply is_label_correct_false. simpl. auto.
-Qed.
-
-Lemma transl_is_label2:
- forall f bb ep tbb1 tbb2 lbl,
- transl_block f bb ep = OK (tbb1::tbb2::nil) ->
- is_label lbl tbb1 = MB.is_label lbl bb
- /\ is_label lbl tbb2 = false.
-Proof.
- intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto.
-Qed.
-
-Lemma transl_block_nonil:
- forall f c ep tc,
- transl_block f c ep = OK tc ->
- tc <> nil.
-Proof.
- intros. monadInv H. unfold gen_bblocks.
- destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i.
- all: discriminate.
-Qed.
-
-Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc,
- ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc).
-Proof.
- intros. intro. monadInv H.
- unfold gen_bblocks in H0.
- destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i.
- all: discriminate.
-Qed.
-
-Lemma find_label_transl_false:
- forall x f lbl bb ep x',
- transl_block f bb ep = OK x ->
- MB.is_label lbl bb = false ->
- find_label lbl (x++x') = find_label lbl x'.
-Proof.
- intros until x'. intros TLB MBis; simpl; auto.
- destruct x as [|x0 x1]; simpl; auto.
- destruct x1 as [|x1 x2]; simpl; auto.
- - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto.
- - destruct x2 as [|x2 x3]; simpl; auto.
- + erewrite <- transl_is_label in MBis; eauto. rewrite MBis.
- erewrite transl_is_label_false2; eauto.
- + apply transl_block_limit in TLB. destruct TLB.
-Qed.
-
-Lemma transl_blocks_label:
- forall lbl f c tc ep,
- transl_blocks f c ep = OK tc ->
- match MB.find_label lbl c with
- | None => find_label lbl tc = None
- | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc'
- end.
-Proof.
- induction c; simpl; intros.
- inv H. auto.
- monadInv H.
- destruct (MB.is_label lbl a) eqn:MBis.
- - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. }
- simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis.
- rewrite ABis.
- eexists. eexists. split; eauto. simpl transl_blocks.
- assert (MB.header a <> nil).
- { apply MB.is_label_correct_true in MBis.
- destruct (MB.header a). contradiction. discriminate. }
- destruct (MB.header a); try contradiction.
- rewrite EQ. simpl. rewrite EQ1. simpl. auto.
- - apply IHc in EQ1. destruct (MB.find_label lbl c).
- + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto.
- erewrite find_label_transl_false; eauto.
- + erewrite find_label_transl_false; eauto.
-Qed.
-
-Lemma find_label_nil:
- forall bb lbl c,
- header bb = nil ->
- find_label lbl (bb::c) = find_label lbl c.
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *. subst.
- assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).
- { erewrite <- is_label_correct_false. simpl. auto. }
- rewrite H. auto.
-Qed.
-
-Lemma transl_find_label:
- forall lbl f tf,
- transf_function f = OK tf ->
- match MB.find_label lbl f.(MB.fn_code) with
- | None => find_label lbl tf.(fn_blocks) = None
- | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc
- end.
-Proof.
- intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g.
- monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto.
- eapply transl_blocks_label; eauto.
-Qed.
-
-End TRANSL_LABEL.
-
-(** A valid branch in a piece of Mach code translates to a valid ``go to''
- transition in the generated Asm code. *)
-
-Lemma find_label_goto_label:
- forall f tf lbl rs m c' b ofs,
- Genv.find_funct_ptr ge b = Some (Internal f) ->
- transf_function f = OK tf ->
- rs PC = Vptr b ofs ->
- MB.find_label lbl f.(MB.fn_code) = Some c' ->
- exists tc', exists rs',
- goto_label tf lbl rs m = Next rs' m
- /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
- /\ forall r, r <> PC -> rs'#r = rs#r.
-Proof.
- intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
- intros (tc & A & B).
- exploit label_pos_code_tail; eauto. instantiate (1 := 0).
- intros [pos' [P [Q R]]].
- exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
- split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto.
- split. rewrite Pregmap.gss. constructor; auto.
- rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
- auto. omega.
- generalize (transf_function_no_overflow _ _ H0). omega.
- intros. apply Pregmap.gso; auto.
-Qed.
-
-(** Existence of return addresses *)
-
-(* NB: the hypothesis in comment on [b] is not needed in the proof !
-*)
-Lemma return_address_exists:
- forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->
- exists ra, return_address_offset f c ra.
-Proof.
- intros. eapply Asmblockgenproof0.return_address_exists; eauto.
-
-- intros. monadInv H0.
- destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl.
-(* rewrite transl_code'_transl_code in EQ0. *)
- exists x; exists true; split; auto. (* unfold fn_code. *)
- repeat constructor.
- - exact transf_function_no_overflow.
-Qed.
-
-(** * Proof of semantic preservation *)
-
-(** Semantic preservation is proved using simulation diagrams
- of the following form.
-<<
- st1 --------------- st2
- | |
- t| *|t
- | |
- v v
- st1'--------------- st2'
->>
- The invariant is the [match_states] predicate below, which includes:
-- The Asm code pointed by the PC register is the translation of
- the current Mach code sequence.
-- Mach register values and Asm register values agree.
-*)
-
-(** We need to show that, in the simulation diagram, we cannot
- take infinitely many Mach transitions that correspond to zero
- transitions on the Asm side. Actually, all Mach transitions
- correspond to at least one Asm transition, except the
- transition from [Machsem.Returnstate] to [Machsem.State].
- So, the following integer measure will suffice to rule out
- the unwanted behaviour. *)
-
-
-Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r.
-Proof.
- intros. change (IR FP) with (preg_of MFP). red; intros.
- exploit preg_of_injective; eauto. intros; subst r; discriminate.
-Qed.
-
-Inductive match_states: Machblock.state -> Asmvliw.state -> Prop :=
- | match_states_intro:
- forall s fb sp c ep ms m m' rs f tf tc
- (STACKS: match_stack ge s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (MEXT: Mem.extends m m')
- (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
- (AG: agree ms sp rs)
- (DXP: ep = true -> rs#FP = parent_sp s),
- match_states (Machblock.State s fb sp c ms m)
- (Asmvliw.State rs m')
- | match_states_call:
- forall s fb ms m m' rs
- (STACKS: match_stack ge s)
- (MEXT: Mem.extends m m')
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = Vptr fb Ptrofs.zero)
- (ATLR: rs RA = parent_ra s),
- match_states (Machblock.Callstate s fb ms m)
- (Asmvliw.State rs m')
- | match_states_return:
- forall s ms m m' rs
- (STACKS: match_stack ge s)
- (MEXT: Mem.extends m m')
- (AG: agree ms (parent_sp s) rs)
- (ATPC: rs PC = parent_ra s),
- match_states (Machblock.Returnstate s ms m)
- (Asmvliw.State rs m').
-
-Record codestate :=
- Codestate { pstate: state;
- pheader: list label;
- pbody1: list basic;
- pbody2: list basic;
- pctl: option control;
- fpok: bool;
- rem: list AB.bblock;
- cur: option bblock }.
-
-(* | Codestate: state -> list AB.bblock -> option bblock -> codestate. *)
-
-Inductive match_codestate fb: Machblock.state -> codestate -> Prop :=
- | match_codestate_intro:
- forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi
- (STACKS: match_stack ge s)
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (MEXT: Mem.extends m m0)
- (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc)
- (TIC: transl_instr_control f (MB.exit bb) = OK tbi)
- (TBLS: transl_blocks f c false = OK tc)
-(* (TRANS: transl_blocks f (bb::c) ep = OK (tbb::tc)) *)
- (AG: agree ms sp rs0)
- (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s)
- ,
- match_codestate fb (Machblock.State s fb sp (bb::c) ms m)
- {| pstate := (Asmvliw.State rs0 m0);
- pheader := (MB.header bb);
- pbody1 := tbc;
- pbody2 := (extract_basic tbi);
- pctl := extract_ctl tbi;
- fpok := ep;
- rem := tc;
- cur := Some tbb
- |}
-.
-
-Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop :=
- | match_asmstate_some:
- forall rs f tf tc m tbb ofs ep tbdy tex lhd
- (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
- (TRANSF: transf_function f = OK tf)
- (PCeq: rs PC = Vptr fb ofs)
- (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc))
-(* (HDROK: header tbb = lhd) *)
- ,
- match_asmstate fb
- {| pstate := (Asmvliw.State rs m);
- pheader := lhd;
- pbody1 := tbdy;
- pbody2 := extract_basic tex;
- pctl := extract_ctl tex;
- fpok := ep;
- rem := tc;
- cur := Some tbb |}
- (Asmvliw.State rs m)
-.
-
-Ltac exploreInst :=
- repeat match goal with
- | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var
- | [ H : OK _ = OK _ |- _ ] => monadInv H
- | [ |- context[if ?b then _ else _] ] => destruct b
- | [ |- context[match ?m with | _ => _ end] ] => destruct m
- | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m
- | [ H : bind _ _ = OK _ |- _ ] => monadInv H
- | [ H : Error _ = OK _ |- _ ] => inversion H
- end.
-
-Lemma transl_blocks_nonil:
- forall f bb c tc ep,
- transl_blocks f (bb::c) ep = OK tc ->
- exists tbb tc', tc = tbb :: tc'.
-Proof.
- intros until ep. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks.
- destruct (extract_ctl x2).
- - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto.
- - destruct x1; simpl; eauto.
-Qed.
-
-Lemma no_builtin_preserved:
- forall f ex x2,
- (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
- transl_instr_control f ex = OK x2 ->
- (exists i, extract_ctl x2 = Some (PCtlFlow i))
- \/ extract_ctl x2 = None.
-Proof.
- intros until x2. intros Hbuiltin TIC.
- destruct ex.
- - destruct c.
- (* MBcall *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBtailcall *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBbuiltin *)
- + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)).
- apply Hbuiltin. contradict H; auto.
- (* MBgoto *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBcond *)
- + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto.
- * unfold transl_opt_compuimm. exploreInst; simpl; eauto.
- * unfold transl_opt_compluimm. exploreInst; simpl; eauto.
- * unfold transl_comp_float64. exploreInst; simpl; eauto.
- * unfold transl_comp_notfloat64. exploreInst; simpl; eauto.
- * unfold transl_comp_float32. exploreInst; simpl; eauto.
- * unfold transl_comp_notfloat32. exploreInst; simpl; eauto.
- (* MBjumptable *)
- + simpl in TIC. exploreInst; simpl; eauto.
- (* MBreturn *)
- + simpl in TIC. monadInv TIC. simpl. eauto.
- - monadInv TIC. simpl; auto.
-Qed.
-
-Lemma transl_blocks_distrib:
- forall c f bb tbb tc ep,
- transl_blocks f (bb::c) ep = OK (tbb::tc)
- -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res))
- -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil)
- /\ transl_blocks f c false = OK tc.
-Proof.
- intros until ep. intros TLBS Hbuiltin.
- destruct bb as [hd bdy ex].
- monadInv TLBS. monadInv EQ.
- exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl.
- - destruct H as [i Hectl].
- unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0.
- simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite Hectl. auto.
- - unfold gen_bblocks in H0. rewrite H in H0.
- destruct x1 as [|bi x1].
- + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite H. auto.
- + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
- unfold gen_bblocks. rewrite H. auto.
-Qed.
-
-Lemma gen_bblocks_nobuiltin:
- forall thd tbdy tex tbb,
- (tbdy <> nil \/ extract_ctl tex <> None) ->
- (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) ->
- gen_bblocks thd tbdy tex = tbb :: nil ->
- header tbb = thd
- /\ body tbb = tbdy ++ extract_basic tex
- /\ exit tbb = extract_ctl tex.
-Proof.
- intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB.
- destruct (extract_ctl tex) eqn:ECTL.
- - destruct c.
- + destruct i; try (inv GENB; simpl; auto; fail).
- assert False. eapply Hnobuiltin. eauto. destruct H.
- + inv GENB. simpl. auto.
- - inversion Hnonil.
- + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto.
- + contradict H; simpl; auto.
-Qed.
-
-Lemma transl_instr_basic_nonil:
- forall k f bi ep x,
- transl_instr_basic f bi ep k = OK x ->
- x <> nil.
-Proof.
- intros until x. intros TIB.
- destruct bi.
- - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate.
- - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate.
- - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate.
- - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate.
- unfold transl_cond_op in EQ0. exploreInst; try discriminate.
- unfold transl_cond_float64. exploreInst; try discriminate.
- unfold transl_cond_notfloat64. exploreInst; try discriminate.
- unfold transl_cond_float32. exploreInst; try discriminate.
- unfold transl_cond_notfloat32. exploreInst; try discriminate.
- - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate.
- all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
- - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate.
- all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
-Qed.
-
-Lemma transl_basic_code_nonil:
- forall bdy f x ep,
- bdy <> nil ->
- transl_basic_code f bdy ep = OK x ->
- x <> nil.
-Proof.
- induction bdy as [|bi bdy].
- intros. contradict H0; auto.
- destruct bdy as [|bi2 bdy].
- - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto.
- - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'.
- monadInv TBC.
- assert (x0 <> nil).
- eapply IHbdy; eauto. subst bdy'. discriminate.
- eapply transl_instr_basic_nonil; eauto.
-Qed.
-
-Lemma transl_instr_control_nonil:
- forall ex f x,
- ex <> None ->
- transl_instr_control f ex = OK x ->
- extract_ctl x <> None.
-Proof.
- intros ex f x Hnonil TIC.
- destruct ex as [ex|].
- - clear Hnonil. destruct ex.
- all: try (simpl in TIC; exploreInst; discriminate).
- + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate.
- * unfold transl_opt_compuimm. exploreInst; try discriminate.
- * unfold transl_opt_compluimm. exploreInst; try discriminate.
- * unfold transl_comp_float64. exploreInst; try discriminate.
- * unfold transl_comp_notfloat64. exploreInst; try discriminate.
- * unfold transl_comp_float32. exploreInst; try discriminate.
- * unfold transl_comp_notfloat32. exploreInst; try discriminate.
- - contradict Hnonil; auto.
-Qed.
-
-Lemma transl_instr_control_nobuiltin:
- forall f ex x,
- (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
- transl_instr_control f ex = OK x ->
- (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))).
-Proof.
- intros until x. intros Hnobuiltin TIC. intros until res.
- unfold transl_instr_control in TIC. exploreInst.
- all: try discriminate.
- - assert False. eapply Hnobuiltin; eauto. destruct H.
- - unfold transl_cbranch in TIC. exploreInst.
- all: try discriminate.
- * unfold transl_opt_compuimm. exploreInst. all: try discriminate.
- * unfold transl_opt_compluimm. exploreInst. all: try discriminate.
- * unfold transl_comp_float64. exploreInst; try discriminate.
- * unfold transl_comp_notfloat64. exploreInst; try discriminate.
- * unfold transl_comp_float32. exploreInst; try discriminate.
- * unfold transl_comp_notfloat32. exploreInst; try discriminate.
-Qed.
-
-Theorem match_state_codestate:
- forall mbs abs s fb sp bb c ms m,
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- (MB.body bb <> nil \/ MB.exit bb <> None) ->
- mbs = (Machblock.State s fb sp (bb::c) ms m) ->
- match_states mbs abs ->
- exists cs fb f tbb tc ep,
- match_codestate fb mbs cs /\ match_asmstate fb cs abs
- /\ Genv.find_funct_ptr ge fb = Some (Internal f)
- /\ transl_blocks f (bb::c) ep = OK (tbb::tc)
- /\ body tbb = pbody1 cs ++ pbody2 cs
- /\ exit tbb = pctl cs
- /\ cur cs = Some tbb /\ rem cs = tc
- /\ pstate cs = abs.
-Proof.
- intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS.
- inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst.
- exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2.
- monadInv TLB. exploit gen_bblocks_nobuiltin; eauto.
- { inversion Hnotempty.
- - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail).
- left. eapply transl_basic_code_nonil; eauto.
- - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail).
- right. eapply transl_instr_control_nonil; eauto. }
- eapply transl_instr_control_nobuiltin; eauto.
- intros (Hth & Htbdy & Htexit).
- exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0;
- pctl := extract_ctl x0; fpok := ep; rem := tc'; cur := Some tbb |}, fb, f, tbb, tc', ep.
- repeat split. 1-2: econstructor; eauto.
- { destruct (MB.header bb). eauto. discriminate. } eauto.
- unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl.
- rewrite TLBS. simpl. rewrite H2.
- all: simpl; auto.
-Qed.
-
-Definition mb_remove_body (bb: MB.bblock) :=
- {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}.
-
-Lemma exec_straight_pnil:
- forall c rs1 m1 rs2 m2,
- exec_straight tge c rs1 m1 (Pnop::gnil) rs2 m2 ->
- exec_straight tge c rs1 m1 nil rs2 m2.
-Proof.
- intros. eapply exec_straight_trans. eapply H. econstructor; eauto.
-Qed.
-
-Lemma transl_block_nobuiltin:
- forall f bb ep tbb,
- (MB.body bb <> nil \/ MB.exit bb <> None) ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- transl_block f bb ep = OK (tbb :: nil) ->
- exists c c',
- transl_basic_code f (MB.body bb) ep = OK c
- /\ transl_instr_control f (MB.exit bb) = OK c'
- /\ body tbb = c ++ extract_basic c'
- /\ exit tbb = extract_ctl c'.
-Proof.
- intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil.
- - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
- left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
- - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
- right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
-Qed.
-
-Lemma nextblock_preserves:
- forall rs rs' bb r,
- rs' = nextblock bb rs ->
- data_preg r = true ->
- rs r = rs' r.
-Proof.
- intros. destruct r; try discriminate.
- subst. Simpl.
-(* - subst. Simpl. *)
-Qed.
-
-Lemma cons3_app {A: Type}:
- forall a b c (l: list A),
- a :: b :: c :: l = (a :: b :: c :: nil) ++ l.
-Proof.
- intros. simpl. auto.
-Qed.
-
-Lemma exec_straight_opt_body2:
- forall c rs1 m1 c' rs2 m2,
- exec_straight_opt tge c rs1 m1 c' rs2 m2 ->
- exists body,
- exec_body tge body rs1 m1 = Next rs2 m2
- /\ (basics_to_code body) ++g c' = c.
-Proof.
- intros until m2. intros EXES.
- inv EXES.
- - exists nil. split; auto.
- - eapply exec_straight_body2. auto.
-Qed.
-
-Lemma extract_basics_to_code:
- forall lb c,
- extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c.
-Proof.
- induction lb; intros; simpl; congruence.
-Qed.
-
-Lemma extract_ctl_basics_to_code:
- forall lb c,
- extract_ctl (basics_to_code lb ++ c) = extract_ctl c.
-Proof.
- induction lb; intros; simpl; congruence.
-Qed.
-
-(* Lemma goto_label_inv:
- forall fn tbb l rs m b ofs,
- rs PC = Vptr b ofs ->
- goto_label fn l rs m = goto_label fn l (nextblock tbb rs) m.
-Proof.
- intros.
- unfold goto_label. rewrite nextblock_pc. unfold Val.offset_ptr. rewrite H.
- exploreInst; auto.
- unfold nextblock. rewrite Pregmap.gss.
-
-Qed.
-
-
-Lemma exec_control_goto_label_inv:
- exec_control tge fn (Some ctl) rs m = goto_label fn l rs m ->
- exec_control tge fn (Some ctl) (nextblock tbb rs) m = goto_label fn l (nextblock tbb rs) m.
-Proof.
-Qed. *)
-
-Theorem step_simu_control:
- forall bb' fb fn s sp c ms' m' rs2 m2 E0 S'' rs1 m1 tbb tbdy2 tex cs2,
- MB.body bb' = nil ->
- (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) ->
- Genv.find_funct_ptr tge fb = Some (Internal fn) ->
- pstate cs2 = (Asmvliw.State rs2 m2) ->
- pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex ->
- cur cs2 = Some tbb ->
- match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 ->
- match_asmstate fb cs2 (Asmvliw.State rs1 m1) ->
- exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') E0 S'' ->
- (exists rs3 m3 rs4 m4,
- exec_body tge tbdy2 rs2 m2 = Next rs3 m3
- /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4
- /\ match_states S'' (State rs4 m4)).
-Proof.
- intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP.
- inv ESTEP.
- - inv MCS. inv MAS. simpl in *.
- inv Hcur. inv Hpstate.
- destruct ctl.
- + (* MBcall *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- destruct s1 as [rf|fid]; simpl in H7.
- * (* Indirect call *)
- monadInv H1.
- assert (ms' rf = Vptr f' Ptrofs.zero).
- { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate.
- revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
- assert (rs2 x = Vptr f' Ptrofs.zero).
- { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
- remember (Ptrofs.add _ _) as ofs'.
- assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
- { econstructor; eauto. }
- assert (f1 = f) by congruence. subst f1.
- exploit return_address_offset_correct; eauto. intros; subst ra.
-
- repeat eexists.
- rewrite H6. econstructor; eauto.
- rewrite H7. econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
- simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto.
-
- * (* Direct call *)
- monadInv H1.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
- remember (Ptrofs.add _ _) as ofs'.
- assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
- econstructor; eauto.
- assert (f1 = f) by congruence. subst f1.
- exploit return_address_offset_correct; eauto. intros; subst ra.
- repeat eexists.
- rewrite H6. econstructor; eauto.
- rewrite H7. econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
- Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto.
- Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto.
- + (* MBtailcall *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]].
- destruct s1 as [rf|fid]; simpl in H13.
- * monadInv H1.
- assert (ms' rf = Vptr f' Ptrofs.zero).
- { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
- assert (rs2 x = Vptr f' Ptrofs.zero).
- { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
-
- assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- { simpl. eauto. }
- intros EXEB.
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- { apply agree_set_other.
- - econstructor; auto with asmgen.
- + apply V.
- + intro r. destruct r; apply V; auto.
- - eauto with asmgen. }
- assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16).
- { clear - EQ. destruct x; repeat split; try discriminate.
- all: unfold ireg_of in EQ; destruct rf; try discriminate. }
- Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate.
- * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- simpl. eauto.
- intros EXEB.
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- { apply agree_set_other.
- - econstructor; auto with asmgen.
- + apply V.
- + intro r. destruct r; apply V; auto.
- - eauto with asmgen. }
- { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. }
- + (* MBbuiltin (contradiction) *)
- assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin).
- rewrite <- H in H1. contradict H1; auto.
- + (* MBgoto *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11.
- remember (nextblock tbb rs2) as rs2'.
- (* inv AT. monadInv H4. *)
- exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
- exploit find_label_goto_label.
- eauto. eauto.
- instantiate (2 := rs2').
- { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. }
- eauto.
- intros (tc' & rs' & GOTO & AT2 & INV).
-
- eexists. eexists. repeat eexists. repeat split.
- rewrite H6. simpl extract_basic. simpl. eauto.
- rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto.
- econstructor; eauto.
- rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV.
- eapply agree_exten; eauto with asmgen.
- assert (forall r : preg, r <> PC -> rs' r = rs2 r).
- { intros. destruct r.
- - destruct g. all: rewrite INV; Simpl; auto.
-(* - destruct g. all: rewrite INV; Simpl; auto. *)
- - rewrite INV; Simpl; auto.
- - contradiction. }
- eauto with asmgen.
- congruence.
- + (* MBcond *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- * (* MBcond true *)
- assert (f0 = f) by congruence. subst f0.
- exploit eval_condition_lessdef.
- eapply preg_vals; eauto.
- all: eauto.
- intros EC.
- exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).
- exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
- assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
- rewrite PCeq' in PCeq.
- assert (f1 = f) by congruence. subst f1.
- exploit find_label_goto_label.
- 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc.
- unfold Val.offset_ptr. rewrite PCeq. eauto.
- intros (tc' & rs3 & GOTOL & TLPC & Hrs3).
- exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
-
- repeat eexists.
- rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
- rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
-
- econstructor; eauto.
- eapply agree_exten with rs2; eauto with asmgen.
- { intros. destruct r; try destruct g; try discriminate.
- all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. }
- intros. discriminate.
-
- * (* MBcond false *)
- assert (f0 = f) by congruence. subst f0.
- exploit eval_condition_lessdef.
- eapply preg_vals; eauto.
- all: eauto.
- intros EC.
-
- exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C).
- exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
- assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
- rewrite PCeq' in PCeq.
- exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
- assert (tf = fn) by congruence. subst tf.
-
- assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
-
- repeat eexists.
- rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
- rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
-
- econstructor; eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto.
- eapply agree_exten with rs2; eauto with asmgen.
- { intros. destruct r; try destruct g; try discriminate.
- all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. }
- intros. discriminate.
- + (* MBjumptable *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- monadInv H1.
- generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV.
- assert (f1 = f) by congruence. subst f1.
- exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef).
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity.
- exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn.
-
- intros [tc' [rs' [A [B C]]]].
- exploit ireg_val; eauto. rewrite H13. intros LD; inv LD.
-
- repeat eexists.
- rewrite H6. simpl extract_basic. simpl. eauto.
- rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A.
- econstructor; eauto.
- eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen.
- { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0.
- destruct (preg_eq r' GPR63). subst. contradiction.
- destruct (preg_eq r' GPR62). subst. contradiction.
- destruct r'; Simpl. }
- discriminate.
- + (* MBreturn *)
- destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
- inv TBC. inv TIC. inv H0.
-
- assert (f0 = f) by congruence. subst f0.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
- exploit exec_straight_body; eauto.
- simpl. eauto.
- intros EXEB.
- assert (f1 = f) by congruence. subst f1.
-
- repeat eexists.
- rewrite H6. simpl extract_basic. eauto.
- rewrite H7. simpl extract_ctl. simpl. reflexivity.
- econstructor; eauto.
- unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen.
-
- - inv MCS. inv MAS. simpl in *. subst. inv Hpstate. inv Hcur.
-(* exploit transl_blocks_distrib; eauto. (* rewrite <- H2. discriminate. *)
- intros (TLB & TLBS).
- *) destruct bb' as [hd' bdy' ex']; simpl in *. subst.
-(* unfold transl_block in TLB. simpl in TLB. unfold gen_bblocks in TLB; simpl in TLB. inv TLB. *)
- monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6.
- simpl. repeat eexists.
- econstructor. 4: instantiate (3 := false). all:eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- assert (f = f0) by congruence. subst f0. econstructor; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto.
- eapply agree_exten; eauto. intros. Simpl.
- discriminate.
-Qed.
-
-Definition mb_remove_first (bb: MB.bblock) :=
- {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}.
-
-Lemma exec_straight_body:
- forall c c' lc rs1 m1 rs2 m2,
- exec_straight tge c rs1 m1 c' rs2 m2 ->
- code_to_basics c = Some lc ->
- exists l ll,
- c = l ++ c'
- /\ code_to_basics l = Some ll
- /\ exec_body tge ll rs1 m1 = Next rs2 m2.
-Proof.
- induction c; try (intros; inv H; fail).
- intros until m2. intros EXES CTB. inv EXES.
- - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto.
- - inv CTB. destruct (code_to_basics c); try discriminate. inv H0.
- eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst.
- exists (i ::g l'),(i::ll). repeat (split; simpl; auto).
- rewrite CTB. auto.
- rewrite H1. auto.
-Qed.
-
-Lemma basics_to_code_app:
- forall c l x ll,
- basics_to_code c = l ++ basics_to_code x ->
- code_to_basics l = Some ll ->
- c = ll ++ x.
-Proof.
- intros. apply (f_equal code_to_basics) in H.
- erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id.
- rewrite code_to_basics_id in H. inv H. auto.
-Qed.
-
-Lemma basics_to_code_app2:
- forall i c l x ll,
- (PBasic i) :: basics_to_code c = l ++ basics_to_code x ->
- code_to_basics l = Some ll ->
- i :: c = ll ++ x.
-Proof.
- intros until ll. intros.
- exploit basics_to_code_app. instantiate (3 := (i::c)). simpl.
- all: eauto.
-Qed.
-
-Lemma step_simu_basic:
- forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy,
- MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} ->
- basic_step ge s fb sp ms m bi ms' m' ->
- pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists rs2 m2 l cs2 tbdy',
- cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := fp_is_parent (fpok cs1) bi; rem := rem cs1; cur := cur cs1 |}
- /\ tbdy = l ++ tbdy'
- /\ exec_body tge l rs1 m1 = Next rs2 m2
- /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2).
-Proof.
- intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS.
- simpl in *. inv Hpstate.
- rewrite Hbody in TBC. monadInv TBC.
- inv BSTEP.
- - (* MBgetstack *)
- simpl in EQ0.
- unfold Mach.load_stack in H.
- exploit Mem.loadv_extends; eauto. intros [v' [A B]].
- rewrite (sp_val _ _ _ AG) in A.
- exploit loadind_correct; eauto with asmgen.
- intros (rs2 & EXECS & Hrs'1 & Hrs'2).
- eapply exec_straight_body in EXECS.
- 2: eapply code_to_basics_id; eauto.
- destruct EXECS as (l & Hlbi & BTC & CTB & EXECB).
- exists rs2, m1, Hlbi.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
- rewrite <- Hheadereq. *) subst.
-
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. (* { destruct (MB.header bb); auto. } *)
- eapply agree_set_mreg; eauto with asmgen.
- intro Hep. simpl in Hep. inv Hep.
- - (* MBsetstack *)
- simpl in EQ0.
- unfold Mach.store_stack in H.
- assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. }
- exploit Mem.storev_extends; eauto. intros [m2' [A B]].
- exploit storeind_correct; eauto with asmgen.
- rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs', m2', ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
-
- eapply agree_undef_regs; eauto with asmgen.
- simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto.
- - (* MBgetparam *)
- simpl in EQ0.
-
- assert (f0 = f) by congruence; subst f0.
- unfold Mach.load_stack in *.
- exploit Mem.loadv_extends. eauto. eexact H0. auto.
- intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
- exploit Mem.loadv_extends. eauto. eexact H1. auto.
- intros [v' [C D]].
-
- (* Opaque loadind. *)
-(* left; eapply exec_straight_steps; eauto; intros. monadInv TR. *)
- monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP.
- destruct ep eqn:EPeq.
- (* RTMP contains parent *)
- + exploit loadind_correct. eexact EQ1.
- instantiate (2 := rs1). rewrite DXP; eauto.
- intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & BTC & CTB & EXECB).
- exists rs2, m1, ll. eexists.
- eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- { eapply basics_to_code_app; eauto. }
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
- (* rewrite <- Hheadereq. *)subst.
- eapply match_codestate_intro; eauto.
-
- eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
- simpl; intros. rewrite R; auto with asmgen.
- apply preg_of_not_FP; auto.
-
- (* GPR11 does not contain parent *)
- + rewrite chunk_of_Tptr in A.
- exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]].
- exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto.
- intros [rs3 [S [T U]]].
-
- exploit exec_straight_trans.
- eapply P.
- eapply S.
- intros EXES.
-
- eapply exec_straight_body in EXES.
- 2: simpl. 2: erewrite code_to_basics_id; eauto.
- destruct EXES as (l & ll & BTC & CTB & EXECB).
- exists rs3, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app2; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- subst.
- eapply match_codestate_intro; eauto.
- eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
- instantiate (1 := rs2#FP <- (rs3#FP)). intros.
- rewrite Pregmap.gso; auto with asmgen.
- congruence.
- intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.
- simpl; intros. rewrite U; auto with asmgen.
- apply preg_of_not_FP; auto.
- - (* MBop *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_operation tge sp op (map ms args) m' = Some v).
- rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
- exploit eval_operation_lessdef.
- eapply preg_vals; eauto.
- 2: eexact H0.
- all: eauto.
- intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
- apply agree_set_undef_mreg with rs1; auto.
- apply Val.lessdef_trans with v'; auto.
- simpl; intros. destruct (andb_prop _ _ H1); clear H1.
- rewrite R; auto. apply preg_of_not_FP; auto.
-Local Transparent destroyed_by_op.
- destruct op; simpl; auto; congruence.
- - (* MBload *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_addressing tge sp addr (map ms args) = Some a).
- rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
- intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- exploit Mem.loadv_extends; eauto. intros [v' [C D]].
- exploit transl_load_correct; eauto.
- intros [rs2 [P [Q R]]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m1, ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
-(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
- rewrite <- Hheadereq. *) subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ.
-
- eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.
- simpl; congruence.
-
- - (* MBstore *)
- simpl in EQ0. rewrite Hheader in DXP.
-
- assert (eval_addressing tge sp addr (map ms args) = Some a).
- rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
- exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
- intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
- assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto.
- exploit Mem.storev_extends; eauto. intros [m2' [C D]].
- exploit transl_store_correct; eauto. intros [rs2 [P Q]].
-
- eapply exec_straight_body in P.
- 2: eapply code_to_basics_id; eauto.
- destruct P as (l & ll & TBC & CTB & EXECB).
- exists rs2, m2', ll.
- eexists. eexists. split. instantiate (1 := x). eauto.
- repeat (split; auto).
- eapply basics_to_code_app; eauto.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
- subst.
- eapply match_codestate_intro; eauto. simpl. simpl in EQ.
-
- eapply agree_undef_regs; eauto with asmgen.
- simpl; congruence.
-Qed.
-
-Lemma exec_body_trans:
- forall l l' rs0 m0 rs1 m1 rs2 m2,
- exec_body tge l rs0 m0 = Next rs1 m1 ->
- exec_body tge l' rs1 m1 = Next rs2 m2 ->
- exec_body tge (l++l') rs0 m0 = Next rs2 m2.
-Proof.
- induction l.
- - simpl. congruence.
- - intros until m2. intros EXEB1 EXEB2.
- inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate.
- simpl. rewrite EBI. eapply IHl; eauto.
-Qed.
-
-Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}.
-
-Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}.
-Next Obligation.
- destruct tbb. simpl. auto.
-Qed.
-
-Inductive exec_header: codestate -> codestate -> Prop :=
- | exec_header_cons: forall cs1,
- exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := (if pheader cs1 then fpok cs1 else false); rem := rem cs1;
- (* cur := match cur cs1 with None => None | Some bcur => Some (remove_header bcur) end *)
- cur := cur cs1 |}.
-
-Lemma step_simu_header:
- forall bb s fb sp c ms m rs1 m1 cs1,
-(* (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) -> *)
- pstate cs1 = (State rs1 m1) ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists cs1',
- exec_header cs1 cs1'
- /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1').
-Proof.
- intros until cs1. intros Hpstate MCS.
- eexists. split; eauto.
- econstructor; eauto.
- inv MCS. simpl in *. inv Hpstate.
- econstructor; eauto.
-Qed.
-
-Lemma step_matchasm_header:
- forall fb cs1 cs1' s1,
- match_asmstate fb cs1 s1 ->
- exec_header cs1 cs1' ->
- match_asmstate fb cs1' s1.
-Proof.
- intros until s1. intros MAS EXH.
- inv MAS. inv EXH.
- simpl. econstructor; eauto.
-Qed.
-
-Lemma step_simu_body:
- forall bb s fb sp c ms m rs1 m1 ms' cs1 m',
- MB.header bb = nil ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- body_step ge s fb sp (MB.body bb) ms m ms' m' ->
- pstate cs1 = (State rs1 m1) ->
- match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
- (exists rs2 m2 cs2 ep,
- cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1;
- pctl := pctl cs1; fpok := ep; rem := rem cs1; cur := cur cs1 |}
- /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2
- /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2).
-Proof.
- intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy].
- - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS.
- inv BSTEP.
- exists rs1, m1, cs1, (fpok cs1).
- inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto).
- econstructor; eauto.
- - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP.
- rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'.
- exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto.
- intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS').
- simpl in *.
- exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto.
- intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS'').
- exists rs3, m3, cs3, ep.
- repeat (split; simpl; auto). subst. simpl in *. auto.
- rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto.
-Qed.
-
-(* Lemma exec_body_straight:
- forall l rs0 m0 rs1 m1,
- l <> nil ->
- exec_body tge l rs0 m0 = Next rs1 m1 ->
- exec_straight tge l rs0 m0 nil rs1 m1.
-Proof.
- induction l as [|i1 l].
- intros. contradict H; auto.
- destruct l as [|i2 l].
- - intros until m1. intros _ EXEB. simpl in EXEB.
- destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
- inv EXEB. econstructor; eauto.
- - intros until m1. intros _ EXEB. simpl in EXEB. simpl in IHl.
- destruct (exec_basic_instr tge i1 rs0 m0) eqn:EBI; try discriminate.
- econstructor; eauto. eapply IHl; eauto. discriminate.
-Qed. *)
-
-Lemma exec_body_pc:
- forall l rs1 m1 rs2 m2,
- exec_body tge l rs1 m1 = Next rs2 m2 ->
- rs2 PC = rs1 PC.
-Proof.
- induction l.
- - intros. inv H. auto.
- - intros until m2. intro EXEB.
- inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
- eapply IHl in H0. rewrite H0.
- erewrite exec_basic_instr_pc; eauto.
-Qed.
-
-Lemma exec_body_control:
- forall b rs1 m1 rs2 m2 rs3 m3 fn,
- exec_body tge (body b) rs1 m1 = Next rs2 m2 ->
- exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 ->
- exec_bblock_rel tge fn b rs1 m1 rs3 m3.
-Proof.
- intros until fn. intros EXEB EXECTL.
- econstructor; eauto. inv EXECTL.
- unfold exec_bblock. rewrite EXEB. auto.
-Qed.
-
-Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat.
-
-Lemma mbsize_eqz:
- forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None.
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H.
- remember (length _) as a. remember (length_opt _) as b.
- assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H.
- inv H0. inv H1. destruct bdy; destruct ex; auto.
- all: try discriminate.
-Qed.
-
-Lemma mbsize_neqz:
- forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None).
-Proof.
- intros. destruct bb as [hd bdy ex]; simpl in *.
- destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate).
- contradict H. unfold mbsize. simpl. auto.
-Qed.
-
-(* Alternative form of step_simulation_bblock, easier to prove *)
-Lemma step_simulation_bblock':
- forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1,
- bb' = mb_remove_header bb ->
- body_step ge sf f sp (Machblock.body bb') rs m rs' m' ->
- bb'' = mb_remove_body bb' ->
- (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) ->
- exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' ->
- match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
- exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2.
-Proof.
- intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS.
- destruct (mbsize bb) eqn:SIZE.
- - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit).
- destruct bb as [hd bdy ex]; simpl in *; subst.
- inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc.
- monadInv H2. simpl in *. inv ESTEP. inv BSTEP.
- eexists. split. eapply plus_one.
- exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'.
- assert (x = tf) by congruence. subst x.
- eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto.
- unfold exec_bblock. simpl. eauto.
- econstructor. eauto. eauto. eauto.
- unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H.
- assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
- eapply transf_function_no_overflow; eauto.
- econstructor; eauto.
- generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto.
- eapply agree_exten; eauto. intros. Simpl.
- intros. discriminate.
- - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. }
- intros Hnotempty.
-
- (* initial setting *)
- exploit match_state_codestate.
- 2: eapply Hnotempty.
- all: eauto.
- intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate).
-
- (* step_simu_header part *)
- assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. }
- destruct H as (rs1 & m1 & Hpstate2). subst.
- assert (f = fb). { inv MCS. auto. } subst fb.
- exploit step_simu_header.
- 2: eapply MCS.
- all: eauto.
- intros (cs1' & EXEH & MCS2).
-
- (* step_simu_body part *)
-(* assert (MB.body bb = MB.body (mb_remove_header bb)). { destruct bb; simpl; auto. }
- rewrite H in BSTEP. clear H. *)
- assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. }
- exploit step_simu_body.
- 3: eapply BSTEP.
- 4: eapply MCS2.
- all: eauto. rewrite Hpstate'. eauto.
- intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS').
-
- (* step_simu_control part *)
- assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)).
- { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. }
- destruct H as (tf & FIND').
- assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex).
- { inv MAS. simpl in *. eauto. }
- destruct H as (tex & Hpbody2 & Hpctl).
- inv EXEH. simpl in *.
- subst. exploit step_simu_control.
- 9: eapply MCS'. all: simpl.
- 10: eapply ESTEP.
- all: simpl; eauto.
- rewrite Hpbody2. rewrite Hpctl. rewrite Hcur.
- { inv MAS; simpl in *. inv Hcur. inv Hpstate2. eapply match_asmstate_some; eauto.
- erewrite exec_body_pc; eauto. }
- intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS').
-
- (* bringing the pieces together *)
- exploit exec_body_trans.
- eapply EXEB.
- eauto.
- intros EXEB2.
- exploit exec_body_control; eauto.
- rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto.
- rewrite Hexit. rewrite Hpctl. eauto.
- intros EXECB. inv EXECB.
- exists (State rs4 m4).
- split; auto. eapply plus_one. rewrite Hpstate2.
- assert (exists ofs, rs1 PC = Vptr f ofs).
- { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. }
- destruct H0 as (ofs & Hrs1pc).
- eapply exec_step_internal; eauto.
-
- (* proving the initial find_bblock *)
- rewrite Hpstate2 in MAS. inv MAS. simpl in *.
- assert (f1 = f0) by congruence. subst f0.
- rewrite PCeq in Hrs1pc. inv Hrs1pc.
- exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''.
- inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ. inv Hcur.
- eapply find_bblock_tail; eauto.
-Qed.
-
-Lemma step_simulation_bblock:
- forall sf f sp bb ms m ms' m' S2 c,
- body_step ge sf f sp (Machblock.body bb) ms m ms' m' ->
- (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
- exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 ->
- forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
- exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'.
-Proof.
- intros until c. intros BSTEP Hbuiltin ESTEP S1' MS.
- eapply step_simulation_bblock'; eauto.
- all: destruct bb as [hd bdy ex]; simpl in *; eauto.
- inv ESTEP.
- - econstructor. inv H; try (econstructor; eauto; fail).
- - econstructor.
-Qed.
-
-Definition measure (s: MB.state) : nat :=
- match s with
- | MB.State _ _ _ _ _ _ => 0%nat
- | MB.Callstate _ _ _ _ => 0%nat
- | MB.Returnstate _ _ _ => 1%nat
- end.
-
-Definition split (c: MB.code) :=
- match c with
- | nil => nil
- | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |}
- :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c
- end.
-
-Lemma cons_ok_eq3 {A: Type} :
- forall (x:A) y z x' y' z',
- x = x' -> y = y' -> z = z' ->
- OK (x::y::z) = OK (x'::y'::z').
-Proof.
- intros. subst. auto.
-Qed.
-
-Lemma transl_blocks_split_builtin:
- forall bb c ep f ef args res,
- MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil ->
- transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep.
-Proof.
- intros until res. intros Hexit Hbody. simpl split.
- unfold transl_blocks. fold transl_blocks. unfold transl_block.
- simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi.
- remember (transl_blocks _ _ _) as tlbs.
- destruct tbc; destruct tbi; destruct tlbs.
- all: try simpl; auto.
- - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl.
- unfold gen_bblocks. simpl. destruct l.
- + exploit transl_basic_code_nonil; eauto. intro. destruct H.
- + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto.
-Qed.
-
-Lemma transl_code_at_pc_split_builtin:
- forall rs f f0 bb c ep tf tc ef args res,
- MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc ->
- transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc.
-Proof.
- intros until res. intros Hbody Hexit AT. inv AT.
- econstructor; eauto. erewrite transl_blocks_split_builtin; eauto.
-Qed.
-
-Theorem match_states_split_builtin:
- forall sf f sp bb c rs m ef args res S1,
- MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
- match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1.
-Proof.
- intros until S1. intros Hbody Hexit MS.
- inv MS.
- econstructor; eauto.
- eapply transl_code_at_pc_split_builtin; eauto.
-Qed.
-
-Lemma step_simulation_builtin:
- forall ef args res bb sf f sp c ms m t S2,
- MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
- exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 ->
- forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
- exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'.
-Proof.
- intros until S2. intros Hbody Hexit ESTEP S1' MS.
- inv MS. inv AT. monadInv H2. monadInv EQ.
- rewrite Hbody in EQ0. monadInv EQ0.
- rewrite Hexit in EQ. monadInv EQ.
- rewrite Hexit in ESTEP. inv ESTEP. inv H4.
-
- exploit functions_transl; eauto. intro FN.
- generalize (transf_function_no_overflow _ _ H1); intro NOOV.
- exploit builtin_args_match; eauto. intros [vargs' [P Q]].
- exploit external_call_mem_extends; eauto.
- intros [vres' [m2' [A [B [C D]]]]].
- econstructor; split. apply plus_one.
- simpl in H3.
- eapply exec_step_builtin. eauto. eauto.
- eapply find_bblock_tail; eauto.
- simpl. eauto.
- erewrite <- sp_val by eauto.
- eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
- eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- eauto.
- econstructor; eauto.
- instantiate (2 := tf); instantiate (1 := x0).
- unfold nextblock, incrPC. rewrite Pregmap.gss.
- rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence.
- rewrite <- H. simpl. econstructor; eauto.
- eapply code_tail_next_int; eauto.
- rewrite preg_notin_charact. intros. auto with asmgen.
- auto with asmgen.
- apply agree_nextblock. eapply agree_set_res; auto.
- eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.
- apply Pregmap.gso; auto with asmgen.
- congruence.
-Qed.
-
-Lemma next_sep:
- forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'.
-Proof.
- congruence.
-Qed.
-
-Theorem step_simulation:
- forall S1 t S2, MB.step return_address_offset ge S1 t S2 ->
- forall S1' (MS: match_states S1 S1'),
- (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
- \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
-Proof.
- induction 1; intros.
-
-- (* bblock *)
- left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0.
- all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock;
- try (rewrite MBE; try discriminate); eauto).
- + (* MBbuiltin *)
- destruct (MB.body bb) eqn:MBB.
- * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto.
- * eapply match_states_split_builtin in MS; eauto.
- 2: rewrite MBB; discriminate.
- simpl split in MS.
- rewrite <- MBB in H.
- remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1.
- assert (MB.body bb = MB.body bb1). { subst. simpl. auto. }
- rewrite H1 in H. subst.
- exploit step_simulation_bblock. eapply H.
- discriminate.
- simpl. constructor.
- eauto.
- intros (S2' & PLUS1 & MS').
- rewrite MBE in MS'.
- assert (exit_step return_address_offset ge (Some (MBbuiltin e l b))
- (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c)
- rs' m') t s').
- { inv H0. inv H3. econstructor. econstructor; eauto. }
- exploit step_simulation_builtin.
- 4: eapply MS'.
- all: simpl; eauto.
- intros (S3' & PLUS'' & MS'').
- exists S3'. split; eauto.
- eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto.
- + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto.
-
-- (* internal function *)
- inv MS.
- exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
- generalize EQ; intros EQ'. monadInv EQ'.
- destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0.
- unfold Mach.store_stack in *.
- exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
- intros [m1' [C D]].
- exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
- intros [m2' [F G]].
- simpl chunk_of_type in F.
- exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
- intros [m3' [P Q]].
- (* Execution of function prologue *)
- monadInv EQ0. (* rewrite transl_code'_transl_code in EQ1. *)
- set (tfbody := make_prologue f x0) in *.
- set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *.
- set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef).
- exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto.
- intros (rs' & U' & V').
-(* exploit (exec_straight_through_singleinst); eauto.
- intro W'. remember (nextblock _ rs') as rs''. *)
- exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2').
- rewrite chunk_of_Tptr in P.
- assert (rs' GPRA = rs0 RA). { apply V'. }
- assert (rs' SP = rs2 SP). { apply V'; discriminate. }
- rewrite H4. rewrite H3.
- (* change (rs' GPRA) with (rs0 RA). *)
- rewrite ATLR.
- change (rs2 SP) with sp. eexact P.
- intros (rs3 & U & V).
-(* exploit (exec_straight_through_singleinst); eauto.
- intro W. *)
- assert (EXEC_PROLOGUE: exists rs3',
- exec_straight_blocks tge tf
- tf.(fn_blocks) rs0 m'
- x0 rs3' m3'
- /\ forall r, r <> PC -> rs3' r = rs3 r).
- { eexists. split.
- - change (fn_blocks tf) with tfbody; unfold tfbody.
- econstructor; eauto. unfold exec_bblock. simpl exec_body.
- rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F.
- Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset.
- rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P.
- simpl. apply next_sep; eauto. reflexivity.
- - intros. destruct V' as (V'' & V'). destruct r.
- + Simpl.
- destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
- Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. }
- + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl.
- + contradiction.
- } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3').
- exploit exec_straight_steps_2; eauto using functions_transl.
- simpl fn_blocks. simpl fn_blocks in g. omega. constructor.
- intros (ofs' & X & Y).
- left; exists (State rs3' m3'); split.
- eapply exec_straight_steps_1; eauto.
- simpl fn_blocks. simpl fn_blocks in g. omega.
- constructor.
- econstructor; eauto.
- rewrite X; econstructor; eauto.
- apply agree_exten with rs2; eauto with asmgen.
- unfold rs2.
- apply agree_set_other; auto with asmgen.
- apply agree_change_sp with (parent_sp s).
- apply agree_undef_regs with rs0. auto.
-Local Transparent destroyed_at_function_entry.
- simpl; intros; Simpl.
- unfold sp; congruence.
-
- intros.
- assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. }
- rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto.
- assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. }
- assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
- (* rewrite H8; auto. *)
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- contradict H3; rewrite H3; unfold data_preg; auto.
- intros. rewrite Heqrs3'. rewrite V by auto with asmgen.
- assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
- rewrite H4 by auto with asmgen. reflexivity. discriminate.
-- (* external function *)
- inv MS.
- exploit functions_translated; eauto.
- intros [tf [A B]]. simpl in B. inv B.
- exploit extcall_arguments_match; eauto.
- intros [args' [C D]].
- exploit external_call_mem_extends; eauto.
- intros [res' [m2' [P [Q [R S]]]]].
- left; econstructor; split.
- apply plus_one. eapply exec_step_external; eauto.
- eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- econstructor; eauto.
- unfold loc_external_result.
- apply agree_set_other; auto.
- apply agree_set_pair; auto.
- apply agree_undef_caller_save_regs; auto.
-
-- (* return *)
- inv MS.
- inv STACKS. simpl in *.
- right. split. omega. split. auto.
- rewrite <- ATPC in H5.
- econstructor; eauto. congruence.
-Qed.
-
-Lemma transf_initial_states:
- forall st1, MB.initial_state prog st1 ->
- exists st2, AB.initial_state tprog st2 /\ match_states st1 st2.
-Proof.
- intros. inversion H. unfold ge0 in *.
- econstructor; split.
- econstructor.
- eapply (Genv.init_mem_transf_partial TRANSF); eauto.
- replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
- with (Vptr fb Ptrofs.zero).
- econstructor; eauto.
- constructor.
- apply Mem.extends_refl.
- split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
- intros. rewrite Mach.Regmap.gi. auto.
- unfold Genv.symbol_address.
- rewrite (match_program_main TRANSF).
- rewrite symbols_preserved.
- unfold ge; rewrite H1. auto.
-Qed.
-
-Lemma transf_final_states:
- forall st1 st2 r,
- match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r.
-Proof.
- intros. inv H0. inv H. constructor. assumption.
- compute in H1. inv H1.
- generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
-Qed.
-
-Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop :=
- Asmblockgenproof0.return_address_offset.
-
-Theorem transf_program_correct:
- forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog).
-Proof.
- eapply forward_simulation_star with (measure := measure).
- - apply senv_preserved.
- - eexact transf_initial_states.
- - eexact transf_final_states.
- - exact step_simulation.
-Qed.
-
-End PRESERVATION.
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Correctness proof for RISC-V generation: main proof. *)
+
+Require Import Coqlib Errors.
+Require Import Integers Floats AST Linking.
+Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Op Locations Machblock Conventions Asmblock.
+Require Import Asmblockgen Asmblockgenproof0 Asmblockgenproof1 Asmblockprops.
+Require Import Axioms.
+
+Module MB := Machblock.
+Module AB := Asmvliw.
+
+Definition match_prog (p: Machblock.program) (tp: Asmvliw.program) :=
+ match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
+
+Lemma transf_program_match:
+ forall p tp, transf_program p = OK tp -> match_prog p tp.
+Proof.
+ intros. eapply match_transform_partial_program; eauto.
+Qed.
+
+Section PRESERVATION.
+
+Variable prog: Machblock.program.
+Variable tprog: Asmvliw.program.
+Hypothesis TRANSF: match_prog prog tprog.
+Let ge := Genv.globalenv prog.
+Let tge := Genv.globalenv tprog.
+
+Lemma symbols_preserved:
+ forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
+Proof (Genv.find_symbol_match TRANSF).
+
+Lemma senv_preserved:
+ Senv.equiv ge tge.
+Proof (Genv.senv_match TRANSF).
+
+Lemma functions_translated:
+ forall b f,
+ Genv.find_funct_ptr ge b = Some f ->
+ exists tf,
+ Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf.
+Proof (Genv.find_funct_ptr_transf_partial TRANSF).
+
+Lemma functions_transl:
+ forall fb f tf,
+ Genv.find_funct_ptr ge fb = Some (Internal f) ->
+ transf_function f = OK tf ->
+ Genv.find_funct_ptr tge fb = Some (Internal tf).
+Proof.
+ intros. exploit functions_translated; eauto. intros [tf' [A B]].
+ monadInv B. rewrite H0 in EQ; inv EQ; auto.
+Qed.
+
+Lemma transf_function_no_overflow:
+ forall f tf,
+ transf_function f = OK tf -> size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0.
+ omega.
+Qed.
+
+Section TRANSL_LABEL. (* Lemmas on translation of MB.is_label into AB.is_label *)
+
+Lemma gen_bblocks_label:
+ forall hd bdy ex tbb tc,
+ gen_bblocks hd bdy ex = tbb::tc ->
+ header tbb = hd.
+Proof.
+ intros until tc. intros GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
+ all: inv GENB; simpl; auto.
+Qed.
+
+Lemma gen_bblocks_label2:
+ forall hd bdy ex tbb1 tbb2,
+ gen_bblocks hd bdy ex = tbb1::tbb2::nil ->
+ header tbb2 = nil.
+Proof.
+ intros until tbb2. intros GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl ex); try destruct c; try destruct i; try destruct bdy.
+ all: inv GENB; simpl; auto.
+Qed.
+
+Remark in_dec_transl:
+ forall lbl hd,
+ (if in_dec lbl hd then true else false) = (if MB.in_dec lbl hd then true else false).
+Proof.
+ intros. destruct (in_dec lbl hd), (MB.in_dec lbl hd). all: tauto.
+Qed.
+
+Lemma transl_is_label:
+ forall lbl bb tbb f ep tc,
+ transl_block f bb ep = OK (tbb::tc) ->
+ is_label lbl tbb = MB.is_label lbl bb.
+Proof.
+ intros until tc. intros TLB.
+ destruct tbb as [thd tbdy tex]; simpl in *.
+ monadInv TLB.
+ unfold is_label. simpl.
+ apply gen_bblocks_label in H0. simpl in H0. subst.
+ rewrite in_dec_transl. auto.
+Qed.
+
+Lemma transl_is_label_false2:
+ forall lbl bb f ep tbb1 tbb2,
+ transl_block f bb ep = OK (tbb1::tbb2::nil) ->
+ is_label lbl tbb2 = false.
+Proof.
+ intros until tbb2. intros TLB.
+ destruct tbb2 as [thd tbdy tex]; simpl in *.
+ monadInv TLB. apply gen_bblocks_label2 in H0. simpl in H0. subst.
+ apply is_label_correct_false. simpl. auto.
+Qed.
+
+Lemma transl_is_label2:
+ forall f bb ep tbb1 tbb2 lbl,
+ transl_block f bb ep = OK (tbb1::tbb2::nil) ->
+ is_label lbl tbb1 = MB.is_label lbl bb
+ /\ is_label lbl tbb2 = false.
+Proof.
+ intros. split. eapply transl_is_label; eauto. eapply transl_is_label_false2; eauto.
+Qed.
+
+Lemma transl_block_nonil:
+ forall f c ep tc,
+ transl_block f c ep = OK tc ->
+ tc <> nil.
+Proof.
+ intros. monadInv H. unfold gen_bblocks.
+ destruct (extract_ctl x0); try destruct c0; try destruct x; try destruct i.
+ all: discriminate.
+Qed.
+
+Lemma transl_block_limit: forall f bb ep tbb1 tbb2 tbb3 tc,
+ ~transl_block f bb ep = OK (tbb1 :: tbb2 :: tbb3 :: tc).
+Proof.
+ intros. intro. monadInv H.
+ unfold gen_bblocks in H0.
+ destruct (extract_ctl x0); try destruct x; try destruct c; try destruct i.
+ all: discriminate.
+Qed.
+
+Lemma find_label_transl_false:
+ forall x f lbl bb ep x',
+ transl_block f bb ep = OK x ->
+ MB.is_label lbl bb = false ->
+ find_label lbl (x++x') = find_label lbl x'.
+Proof.
+ intros until x'. intros TLB MBis; simpl; auto.
+ destruct x as [|x0 x1]; simpl; auto.
+ destruct x1 as [|x1 x2]; simpl; auto.
+ - erewrite <- transl_is_label in MBis; eauto. rewrite MBis. auto.
+ - destruct x2 as [|x2 x3]; simpl; auto.
+ + erewrite <- transl_is_label in MBis; eauto. rewrite MBis.
+ erewrite transl_is_label_false2; eauto.
+ + apply transl_block_limit in TLB. destruct TLB.
+Qed.
+
+Lemma transl_blocks_label:
+ forall lbl f c tc ep,
+ transl_blocks f c ep = OK tc ->
+ match MB.find_label lbl c with
+ | None => find_label lbl tc = None
+ | Some c' => exists tc', find_label lbl tc = Some tc' /\ transl_blocks f c' false = OK tc'
+ end.
+Proof.
+ induction c; simpl; intros.
+ inv H. auto.
+ monadInv H.
+ destruct (MB.is_label lbl a) eqn:MBis.
+ - destruct x as [|tbb tc]. { apply transl_block_nonil in EQ. contradiction. }
+ simpl find_label. exploit transl_is_label; eauto. intros ABis. rewrite MBis in ABis.
+ rewrite ABis.
+ eexists. eexists. split; eauto. simpl transl_blocks.
+ assert (MB.header a <> nil).
+ { apply MB.is_label_correct_true in MBis.
+ destruct (MB.header a). contradiction. discriminate. }
+ destruct (MB.header a); try contradiction.
+ rewrite EQ. simpl. rewrite EQ1. simpl. auto.
+ - apply IHc in EQ1. destruct (MB.find_label lbl c).
+ + destruct EQ1 as (tc' & FIND & TLBS). exists tc'; eexists; auto.
+ erewrite find_label_transl_false; eauto.
+ + erewrite find_label_transl_false; eauto.
+Qed.
+
+Lemma find_label_nil:
+ forall bb lbl c,
+ header bb = nil ->
+ find_label lbl (bb::c) = find_label lbl c.
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *. subst.
+ assert (is_label lbl {| AB.header := nil; AB.body := bdy; AB.exit := ex; AB.correct := correct |} = false).
+ { erewrite <- is_label_correct_false. simpl. auto. }
+ rewrite H. auto.
+Qed.
+
+Theorem transl_find_label:
+ forall lbl f tf,
+ transf_function f = OK tf ->
+ match MB.find_label lbl f.(MB.fn_code) with
+ | None => find_label lbl tf.(fn_blocks) = None
+ | Some c => exists tc, find_label lbl tf.(fn_blocks) = Some tc /\ transl_blocks f c false = OK tc
+ end.
+Proof.
+ intros. monadInv H. destruct (zlt Ptrofs.max_unsigned (size_blocks (fn_blocks x))); inv EQ0. clear g.
+ monadInv EQ. unfold make_prologue. simpl fn_blocks. repeat (rewrite find_label_nil); simpl; auto.
+ eapply transl_blocks_label; eauto.
+Qed.
+
+End TRANSL_LABEL.
+
+(** A valid branch in a piece of Machblock code translates to a valid ``go to''
+ transition in the generated Asmblock code. *)
+
+Lemma find_label_goto_label:
+ forall f tf lbl rs m c' b ofs,
+ Genv.find_funct_ptr ge b = Some (Internal f) ->
+ transf_function f = OK tf ->
+ rs PC = Vptr b ofs ->
+ MB.find_label lbl f.(MB.fn_code) = Some c' ->
+ exists tc', exists rs',
+ goto_label tf lbl rs m = Next rs' m
+ /\ transl_code_at_pc ge (rs' PC) b f c' false tf tc'
+ /\ forall r, r <> PC -> rs'#r = rs#r.
+Proof.
+ intros. exploit (transl_find_label lbl f tf); eauto. rewrite H2.
+ intros (tc & A & B).
+ exploit label_pos_code_tail; eauto. instantiate (1 := 0).
+ intros [pos' [P [Q R]]].
+ exists tc; exists (rs#PC <- (Vptr b (Ptrofs.repr pos'))).
+ split. unfold goto_label. unfold par_goto_label. rewrite P. rewrite H1. auto.
+ split. rewrite Pregmap.gss. constructor; auto.
+ rewrite Ptrofs.unsigned_repr. replace (pos' - 0) with pos' in Q.
+ auto. omega.
+ generalize (transf_function_no_overflow _ _ H0). omega.
+ intros. apply Pregmap.gso; auto.
+Qed.
+
+(** Existence of return addresses *)
+
+Lemma return_address_exists:
+ forall b f c, is_tail (b :: c) f.(MB.fn_code) ->
+ exists ra, return_address_offset f c ra.
+Proof.
+ intros. eapply Asmblockgenproof0.return_address_exists; eauto.
+
+- intros. monadInv H0.
+ destruct (zlt Ptrofs.max_unsigned (size_blocks x.(fn_blocks))); inv EQ0. monadInv EQ. simpl.
+ exists x; exists true; split; auto.
+ repeat constructor.
+- exact transf_function_no_overflow.
+Qed.
+
+(** * Proof of semantic preservation *)
+
+(** Semantic preservation is proved using a complex simulation diagram
+ of the following form.
+<<
+ MB.step
+ ---------------------------------------->
+ header body exit
+ st1 -----> st2 -----> st3 ------------------> st4
+ | | | |
+ | (A) | (B) | (C) |
+ match_codestate | | | |
+ | header | body1 | body2 | match_states
+ cs1 -----> cs2 -----> cs3 ------> cs4 |
+ | / \ exit |
+ match_asmstate | --------------- --->--- |
+ | / match_asmstate \ |
+ st'1 ---------------------------------------> st'2
+ AB.step *
+>>
+ The invariant between each MB.step/AB.step is the [match_states] predicate below.
+ However, we also need to introduce an intermediary state [Codestate] which allows
+ us to reason on a finer grain, executing header, body and exit separately.
+
+ This [Codestate] consists in a state like [Asmblock.State], except that the
+ code is directly stored in the state, much like [Machblock.State]. It also features
+ additional useful elements to keep track of while executing a bblock.
+*)
+
+Remark preg_of_not_FP: forall r, negb (mreg_eq r MFP) = true -> IR FP <> preg_of r.
+Proof.
+ intros. change (IR FP) with (preg_of MFP). red; intros.
+ exploit preg_of_injective; eauto. intros; subst r; discriminate.
+Qed.
+
+Inductive match_states: Machblock.state -> Asmvliw.state -> Prop :=
+ | match_states_intro:
+ forall s fb sp c ep ms m m' rs f tf tc
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m')
+ (AT: transl_code_at_pc ge (rs PC) fb f c ep tf tc)
+ (AG: agree ms sp rs)
+ (DXP: ep = true -> rs#FP = parent_sp s),
+ match_states (Machblock.State s fb sp c ms m)
+ (Asmvliw.State rs m')
+ | match_states_call:
+ forall s fb ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = Vptr fb Ptrofs.zero)
+ (ATLR: rs RA = parent_ra s),
+ match_states (Machblock.Callstate s fb ms m)
+ (Asmvliw.State rs m')
+ | match_states_return:
+ forall s ms m m' rs
+ (STACKS: match_stack ge s)
+ (MEXT: Mem.extends m m')
+ (AG: agree ms (parent_sp s) rs)
+ (ATPC: rs PC = parent_ra s),
+ match_states (Machblock.Returnstate s ms m)
+ (Asmvliw.State rs m').
+
+Record codestate :=
+ Codestate { pstate: state; (**r projection to Asmblock.state *)
+ pheader: list label;
+ pbody1: list basic; (**r list of basic instructions coming from the translation of the Machblock body *)
+ pbody2: list basic; (**r list of basic instructions coming from the translation of the Machblock exit *)
+ pctl: option control; (**r exit instruction, coming from the translation of the Machblock exit *)
+ ep: bool; (**r reflects the [ep] variable used in the translation *)
+ rem: list AB.bblock; (**r remaining bblocks to execute *)
+ cur: bblock (**r current bblock to execute - to keep track of its size when incrementing PC *)
+ }.
+
+(* The part that deals with Machblock <-> Codestate agreement
+ * Note about DXP: the property of [ep] only matters if the current block doesn't have a header, hence the condition *)
+Inductive match_codestate fb: Machblock.state -> codestate -> Prop :=
+ | match_codestate_intro:
+ forall s sp ms m rs0 m0 f tc ep c bb tbb tbc tbi
+ (STACKS: match_stack ge s)
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (MEXT: Mem.extends m m0)
+ (TBC: transl_basic_code f (MB.body bb) (if MB.header bb then ep else false) = OK tbc)
+ (TIC: transl_instr_control f (MB.exit bb) = OK tbi)
+ (TBLS: transl_blocks f c false = OK tc)
+ (AG: agree ms sp rs0)
+ (DXP: (if MB.header bb then ep else false) = true -> rs0#FP = parent_sp s)
+ ,
+ match_codestate fb (Machblock.State s fb sp (bb::c) ms m)
+ {| pstate := (Asmvliw.State rs0 m0);
+ pheader := (MB.header bb);
+ pbody1 := tbc;
+ pbody2 := extract_basic tbi;
+ pctl := extract_ctl tbi;
+ ep := ep;
+ rem := tc;
+ cur := tbb
+ |}
+.
+
+(* The part ensuring that the code in Codestate actually resides at [rs PC] *)
+Inductive match_asmstate fb: codestate -> Asmvliw.state -> Prop :=
+ | match_asmstate_some:
+ forall rs f tf tc m tbb ofs ep tbdy tex lhd
+ (FIND: Genv.find_funct_ptr ge fb = Some (Internal f))
+ (TRANSF: transf_function f = OK tf)
+ (PCeq: rs PC = Vptr fb ofs)
+ (TAIL: code_tail (Ptrofs.unsigned ofs) (fn_blocks tf) (tbb::tc))
+ ,
+ match_asmstate fb
+ {| pstate := (Asmvliw.State rs m);
+ pheader := lhd;
+ pbody1 := tbdy;
+ pbody2 := extract_basic tex;
+ pctl := extract_ctl tex;
+ ep := ep;
+ rem := tc;
+ cur := tbb |}
+ (Asmvliw.State rs m)
+.
+
+(* Useful for dealing with the many cases in some proofs *)
+Ltac exploreInst :=
+ repeat match goal with
+ | [ H : match ?var with | _ => _ end = _ |- _ ] => destruct var
+ | [ H : OK _ = OK _ |- _ ] => monadInv H
+ | [ |- context[if ?b then _ else _] ] => destruct b
+ | [ |- context[match ?m with | _ => _ end] ] => destruct m
+ | [ |- context[match ?m as _ return _ with | _ => _ end]] => destruct m
+ | [ H : bind _ _ = OK _ |- _ ] => monadInv H
+ | [ H : Error _ = OK _ |- _ ] => inversion H
+ end.
+
+(** Some translation properties *)
+
+Lemma transl_blocks_nonil:
+ forall f bb c tc ep,
+ transl_blocks f (bb::c) ep = OK tc ->
+ exists tbb tc', tc = tbb :: tc'.
+Proof.
+ intros until ep0. intros TLBS. monadInv TLBS. monadInv EQ. unfold gen_bblocks.
+ destruct (extract_ctl x2).
+ - destruct c0; destruct i; simpl; eauto. destruct x1; simpl; eauto.
+ - destruct x1; simpl; eauto.
+Qed.
+
+Lemma no_builtin_preserved:
+ forall f ex x2,
+ (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
+ transl_instr_control f ex = OK x2 ->
+ (exists i, extract_ctl x2 = Some (PCtlFlow i))
+ \/ extract_ctl x2 = None.
+Proof.
+ intros until x2. intros Hbuiltin TIC.
+ destruct ex.
+ - destruct c.
+ (* MBcall *)
+ + simpl in TIC. exploreInst; simpl; eauto.
+ (* MBtailcall *)
+ + simpl in TIC. exploreInst; simpl; eauto.
+ (* MBbuiltin *)
+ + assert (H: Some (MBbuiltin e l b) <> Some (MBbuiltin e l b)).
+ apply Hbuiltin. contradict H; auto.
+ (* MBgoto *)
+ + simpl in TIC. exploreInst; simpl; eauto.
+ (* MBcond *)
+ + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; simpl; eauto.
+ * unfold transl_opt_compuimm. exploreInst; simpl; eauto.
+ * unfold transl_opt_compluimm. exploreInst; simpl; eauto.
+ * unfold transl_comp_float64. exploreInst; simpl; eauto.
+ * unfold transl_comp_notfloat64. exploreInst; simpl; eauto.
+ * unfold transl_comp_float32. exploreInst; simpl; eauto.
+ * unfold transl_comp_notfloat32. exploreInst; simpl; eauto.
+ (* MBjumptable *)
+ + simpl in TIC. exploreInst; simpl; eauto.
+ (* MBreturn *)
+ + simpl in TIC. monadInv TIC. simpl. eauto.
+ - monadInv TIC. simpl; auto.
+Qed.
+
+Lemma transl_blocks_distrib:
+ forall c f bb tbb tc ep,
+ transl_blocks f (bb::c) ep = OK (tbb::tc)
+ -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res))
+ -> transl_block f bb (if MB.header bb then ep else false) = OK (tbb :: nil)
+ /\ transl_blocks f c false = OK tc.
+Proof.
+ intros until ep0. intros TLBS Hbuiltin.
+ destruct bb as [hd bdy ex].
+ monadInv TLBS. monadInv EQ.
+ exploit no_builtin_preserved; eauto. intros Hectl. destruct Hectl.
+ - destruct H as [i Hectl].
+ unfold gen_bblocks in H0. rewrite Hectl in H0. inv H0.
+ simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite Hectl. auto.
+ - unfold gen_bblocks in H0. rewrite H in H0.
+ destruct x1 as [|bi x1].
+ + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite H. auto.
+ + simpl in H0. inv H0. simpl in *. unfold transl_block; simpl. rewrite EQ0. rewrite EQ. simpl.
+ unfold gen_bblocks. rewrite H. auto.
+Qed.
+
+Lemma gen_bblocks_nobuiltin:
+ forall thd tbdy tex tbb,
+ (tbdy <> nil \/ extract_ctl tex <> None) ->
+ (forall ef args res, extract_ctl tex <> Some (PExpand (Pbuiltin ef args res))) ->
+ gen_bblocks thd tbdy tex = tbb :: nil ->
+ header tbb = thd
+ /\ body tbb = tbdy ++ extract_basic tex
+ /\ exit tbb = extract_ctl tex.
+Proof.
+ intros until tbb. intros Hnonil Hnobuiltin GENB. unfold gen_bblocks in GENB.
+ destruct (extract_ctl tex) eqn:ECTL.
+ - destruct c.
+ + destruct i; try (inv GENB; simpl; auto; fail).
+ assert False. eapply Hnobuiltin. eauto. destruct H.
+ + inv GENB. simpl. auto.
+ - inversion Hnonil.
+ + destruct tbdy as [|bi tbdy]; try (contradict H; simpl; auto; fail). inv GENB. auto.
+ + contradict H; simpl; auto.
+Qed.
+
+Lemma transl_instr_basic_nonil:
+ forall k f bi ep x,
+ transl_instr_basic f bi ep k = OK x ->
+ x <> nil.
+Proof.
+ intros until x. intros TIB.
+ destruct bi.
+ - simpl in TIB. unfold loadind in TIB. exploreInst; try discriminate.
+ - simpl in TIB. unfold storeind in TIB. exploreInst; try discriminate.
+ - simpl in TIB. monadInv TIB. unfold loadind in EQ. exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_op in TIB. exploreInst; try discriminate.
+ unfold transl_cond_op in EQ0. exploreInst; try discriminate.
+ unfold transl_cond_float64. exploreInst; try discriminate.
+ unfold transl_cond_notfloat64. exploreInst; try discriminate.
+ unfold transl_cond_float32. exploreInst; try discriminate.
+ unfold transl_cond_notfloat32. exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_load in TIB. exploreInst; try discriminate.
+ all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
+ - simpl in TIB. unfold transl_store in TIB. exploreInst; try discriminate.
+ all: monadInv TIB; unfold transl_memory_access in EQ0; unfold transl_memory_access2 in EQ0; unfold transl_memory_access2XS in EQ0; exploreInst; try discriminate.
+Qed.
+
+Lemma transl_basic_code_nonil:
+ forall bdy f x ep,
+ bdy <> nil ->
+ transl_basic_code f bdy ep = OK x ->
+ x <> nil.
+Proof.
+ induction bdy as [|bi bdy].
+ intros. contradict H0; auto.
+ destruct bdy as [|bi2 bdy].
+ - clear IHbdy. intros f x b _ TBC. simpl in TBC. eapply transl_instr_basic_nonil; eauto.
+ - intros f x b Hnonil TBC. remember (bi2 :: bdy) as bdy'.
+ monadInv TBC.
+ assert (x0 <> nil).
+ eapply IHbdy; eauto. subst bdy'. discriminate.
+ eapply transl_instr_basic_nonil; eauto.
+Qed.
+
+Lemma transl_instr_control_nonil:
+ forall ex f x,
+ ex <> None ->
+ transl_instr_control f ex = OK x ->
+ extract_ctl x <> None.
+Proof.
+ intros ex f x Hnonil TIC.
+ destruct ex as [ex|].
+ - clear Hnonil. destruct ex.
+ all: try (simpl in TIC; exploreInst; discriminate).
+ + simpl in TIC. unfold transl_cbranch in TIC. exploreInst; try discriminate.
+ * unfold transl_opt_compuimm. exploreInst; try discriminate.
+ * unfold transl_opt_compluimm. exploreInst; try discriminate.
+ * unfold transl_comp_float64. exploreInst; try discriminate.
+ * unfold transl_comp_notfloat64. exploreInst; try discriminate.
+ * unfold transl_comp_float32. exploreInst; try discriminate.
+ * unfold transl_comp_notfloat32. exploreInst; try discriminate.
+ - contradict Hnonil; auto.
+Qed.
+
+Lemma transl_instr_control_nobuiltin:
+ forall f ex x,
+ (forall ef args res, ex <> Some (MBbuiltin ef args res)) ->
+ transl_instr_control f ex = OK x ->
+ (forall ef args res, extract_ctl x <> Some (PExpand (Pbuiltin ef args res))).
+Proof.
+ intros until x. intros Hnobuiltin TIC. intros until res.
+ unfold transl_instr_control in TIC. exploreInst.
+ all: try discriminate.
+ - assert False. eapply Hnobuiltin; eauto. destruct H.
+ - unfold transl_cbranch in TIC. exploreInst.
+ all: try discriminate.
+ * unfold transl_opt_compuimm. exploreInst. all: try discriminate.
+ * unfold transl_opt_compluimm. exploreInst. all: try discriminate.
+ * unfold transl_comp_float64. exploreInst; try discriminate.
+ * unfold transl_comp_notfloat64. exploreInst; try discriminate.
+ * unfold transl_comp_float32. exploreInst; try discriminate.
+ * unfold transl_comp_notfloat32. exploreInst; try discriminate.
+Qed.
+
+(* Proving that one can decompose a [match_state] relation into a [match_codestate]
+ and a [match_asmstate], along with some helpful properties tying both relations together *)
+
+Theorem match_state_codestate:
+ forall mbs abs s fb sp bb c ms m,
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ (MB.body bb <> nil \/ MB.exit bb <> None) ->
+ mbs = (Machblock.State s fb sp (bb::c) ms m) ->
+ match_states mbs abs ->
+ exists cs fb f tbb tc ep,
+ match_codestate fb mbs cs /\ match_asmstate fb cs abs
+ /\ Genv.find_funct_ptr ge fb = Some (Internal f)
+ /\ transl_blocks f (bb::c) ep = OK (tbb::tc)
+ /\ body tbb = pbody1 cs ++ pbody2 cs
+ /\ exit tbb = pctl cs
+ /\ cur cs = tbb /\ rem cs = tc
+ /\ pstate cs = abs.
+Proof.
+ intros until m. intros Hnobuiltin Hnotempty Hmbs MS. subst. inv MS.
+ inv AT. clear H0. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst.
+ exploit transl_blocks_distrib; eauto. intros (TLB & TLBS). clear H2.
+ monadInv TLB. exploit gen_bblocks_nobuiltin; eauto.
+ { inversion Hnotempty.
+ - destruct (MB.body bb) as [|bi bdy]; try (contradict H0; simpl; auto; fail).
+ left. eapply transl_basic_code_nonil; eauto.
+ - destruct (MB.exit bb) as [ei|]; try (contradict H0; simpl; auto; fail).
+ right. eapply transl_instr_control_nonil; eauto. }
+ eapply transl_instr_control_nobuiltin; eauto.
+ intros (Hth & Htbdy & Htexit).
+ exists {| pstate := (State rs m'); pheader := (Machblock.header bb); pbody1 := x; pbody2 := extract_basic x0;
+ pctl := extract_ctl x0; ep := ep0; rem := tc'; cur := tbb |}, fb, f, tbb, tc', ep0.
+ repeat split. 1-2: econstructor; eauto.
+ { destruct (MB.header bb). eauto. discriminate. } eauto.
+ unfold transl_blocks. fold transl_blocks. unfold transl_block. rewrite EQ. simpl. rewrite EQ1; simpl.
+ rewrite TLBS. simpl. rewrite H2.
+ all: simpl; auto.
+Qed.
+
+Definition mb_remove_body (bb: MB.bblock) :=
+ {| MB.header := MB.header bb; MB.body := nil; MB.exit := MB.exit bb |}.
+
+Lemma exec_straight_pnil:
+ forall c rs1 m1 rs2 m2,
+ exec_straight tge c rs1 m1 (Pnop ::g nil) rs2 m2 ->
+ exec_straight tge c rs1 m1 nil rs2 m2.
+Proof.
+ intros. eapply exec_straight_trans. eapply H. econstructor; eauto.
+Qed.
+
+Lemma transl_block_nobuiltin:
+ forall f bb ep tbb,
+ (MB.body bb <> nil \/ MB.exit bb <> None) ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ transl_block f bb ep = OK (tbb :: nil) ->
+ exists c c',
+ transl_basic_code f (MB.body bb) ep = OK c
+ /\ transl_instr_control f (MB.exit bb) = OK c'
+ /\ body tbb = c ++ extract_basic c'
+ /\ exit tbb = extract_ctl c'.
+Proof.
+ intros until tbb. intros Hnonil Hnobuiltin TLB. monadInv TLB. destruct Hnonil.
+ - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
+ left. eapply transl_basic_code_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
+ - eexists. eexists. split; eauto. split; eauto. eapply gen_bblocks_nobuiltin; eauto.
+ right. eapply transl_instr_control_nonil; eauto. eapply transl_instr_control_nobuiltin; eauto.
+Qed.
+
+Lemma nextblock_preserves:
+ forall rs rs' bb r,
+ rs' = nextblock bb rs ->
+ data_preg r = true ->
+ rs r = rs' r.
+Proof.
+ intros. destruct r; try discriminate.
+ subst. Simpl.
+Qed.
+
+Remark cons3_app {A: Type}:
+ forall a b c (l: list A),
+ a :: b :: c :: l = (a :: b :: c :: nil) ++ l.
+Proof.
+ intros. simpl. auto.
+Qed.
+
+Lemma exec_straight_opt_body2:
+ forall c rs1 m1 c' rs2 m2,
+ exec_straight_opt tge c rs1 m1 c' rs2 m2 ->
+ exists body,
+ exec_body tge body rs1 m1 = Next rs2 m2
+ /\ (basics_to_code body) ++g c' = c.
+Proof.
+ intros until m2. intros EXES.
+ inv EXES.
+ - exists nil. split; auto.
+ - eapply exec_straight_body2. auto.
+Qed.
+
+Lemma extract_basics_to_code:
+ forall lb c,
+ extract_basic (basics_to_code lb ++ c) = lb ++ extract_basic c.
+Proof.
+ induction lb; intros; simpl; congruence.
+Qed.
+
+Lemma extract_ctl_basics_to_code:
+ forall lb c,
+ extract_ctl (basics_to_code lb ++ c) = extract_ctl c.
+Proof.
+ induction lb; intros; simpl; congruence.
+Qed.
+
+(* See (C) in the diagram. The proofs are mostly adapted from the previous Mach->Asm proofs, but are
+ unfortunately quite cumbersome. To reproduce them, it's best to have a Coq IDE with you and see by
+ yourself the steps *)
+Theorem step_simu_control:
+ forall bb' fb fn s sp c ms' m' rs2 m2 t S'' rs1 m1 tbb tbdy2 tex cs2,
+ MB.body bb' = nil ->
+ (forall ef args res, MB.exit bb' <> Some (MBbuiltin ef args res)) ->
+ Genv.find_funct_ptr tge fb = Some (Internal fn) ->
+ pstate cs2 = (Asmvliw.State rs2 m2) ->
+ pbody1 cs2 = nil -> pbody2 cs2 = tbdy2 -> pctl cs2 = tex ->
+ cur cs2 = tbb ->
+ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2 ->
+ match_asmstate fb cs2 (Asmvliw.State rs1 m1) ->
+ exit_step return_address_offset ge (MB.exit bb') (MB.State s fb sp (bb'::c) ms' m') t S'' ->
+ (exists rs3 m3 rs4 m4,
+ exec_body tge tbdy2 rs2 m2 = Next rs3 m3
+ /\ exec_control_rel tge fn tex tbb rs3 m3 rs4 m4
+ /\ match_states S'' (State rs4 m4)).
+Proof.
+ intros until cs2. intros Hbody Hbuiltin FIND Hpstate Hpbody1 Hpbody2 Hpctl Hcur MCS MAS ESTEP.
+ inv ESTEP.
+ - inv MCS. inv MAS. simpl in *.
+ inv Hpstate.
+ destruct ctl.
+ + (* MBcall *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ destruct s1 as [rf|fid]; simpl in H7.
+ * (* Indirect call *)
+ monadInv H1.
+ assert (ms' rf = Vptr f' Ptrofs.zero).
+ { unfold find_function_ptr in H14. destruct (ms' rf); try discriminate.
+ revert H14; predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
+ assert (rs2 x = Vptr f' Ptrofs.zero).
+ { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
+ remember (Ptrofs.add _ _) as ofs'.
+ assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
+ { econstructor; eauto. }
+ assert (f1 = f) by congruence. subst f1.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+
+ repeat eexists.
+ rewrite H6. econstructor; eauto.
+ rewrite H7. econstructor; eauto.
+ econstructor; eauto.
+ econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
+ simpl. Simpl. rewrite PCeq. rewrite Heqofs'. simpl. auto.
+
+ * (* Direct call *)
+ monadInv H1.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
+ remember (Ptrofs.add _ _) as ofs'.
+ assert (TCA: transl_code_at_pc ge (Vptr fb ofs') fb f c false tf tc).
+ econstructor; eauto.
+ assert (f1 = f) by congruence. subst f1.
+ exploit return_address_offset_correct; eauto. intros; subst ra.
+ repeat eexists.
+ rewrite H6. econstructor; eauto.
+ rewrite H7. econstructor; eauto.
+ econstructor; eauto.
+ econstructor; eauto. eapply agree_sp_def; eauto. simpl. eapply agree_exten; eauto. intros. Simpl.
+ Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. simpl in H14. rewrite H14. auto.
+ Simpl. simpl. subst. Simpl. simpl. unfold Val.offset_ptr. rewrite PCeq. auto.
+ + (* MBtailcall *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ exploit Mem.loadv_extends. eauto. eexact H15. auto. simpl. intros [parent' [A B]].
+ destruct s1 as [rf|fid]; simpl in H13.
+ * monadInv H1.
+ assert (ms' rf = Vptr f' Ptrofs.zero).
+ { destruct (ms' rf); try discriminate. revert H13. predSpec Ptrofs.eq Ptrofs.eq_spec i Ptrofs.zero; intros; congruence. }
+ assert (rs2 x = Vptr f' Ptrofs.zero).
+ { exploit ireg_val; eauto. rewrite H; intros LD; inv LD; auto. }
+
+ assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_body; eauto.
+ { simpl. eauto. }
+ intros EXEB.
+ repeat eexists.
+ rewrite H6. simpl extract_basic. eauto.
+ rewrite H7. simpl extract_ctl. simpl. reflexivity.
+ econstructor; eauto.
+ { apply agree_set_other.
+ - econstructor; auto with asmgen.
+ + apply V.
+ + intro r. destruct r; apply V; auto.
+ - eauto with asmgen. }
+ assert (IR x <> IR GPR12 /\ IR x <> IR GPR32 /\ IR x <> IR GPR16).
+ { clear - EQ. destruct x; repeat split; try discriminate.
+ all: unfold ireg_of in EQ; destruct rf; try discriminate. }
+ Simpl. inv H1. inv H3. rewrite Z; auto; try discriminate.
+ * monadInv H1. assert (f = f1) by congruence. subst f1. clear FIND1. clear H14.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_body; eauto.
+ simpl. eauto.
+ intros EXEB.
+ repeat eexists.
+ rewrite H6. simpl extract_basic. eauto.
+ rewrite H7. simpl extract_ctl. simpl. reflexivity.
+ econstructor; eauto.
+ { apply agree_set_other.
+ - econstructor; auto with asmgen.
+ + apply V.
+ + intro r. destruct r; apply V; auto.
+ - eauto with asmgen. }
+ { Simpl. unfold Genv.symbol_address. rewrite symbols_preserved. rewrite H13. auto. }
+ + (* MBbuiltin (contradiction) *)
+ assert (MB.exit bb' <> Some (MBbuiltin e l b)) by (apply Hbuiltin).
+ rewrite <- H in H1. contradict H1; auto.
+ + (* MBgoto *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0. assert (f1 = f) by congruence. subst f1. clear H11.
+ remember (nextblock tbb rs2) as rs2'.
+ exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+ exploit find_label_goto_label.
+ eauto. eauto.
+ instantiate (2 := rs2').
+ { subst. unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. eauto. }
+ eauto.
+ intros (tc' & rs' & GOTO & AT2 & INV).
+
+ eexists. eexists. repeat eexists. repeat split.
+ rewrite H6. simpl extract_basic. simpl. eauto.
+ rewrite H7. simpl extract_ctl. simpl. rewrite <- Heqrs2'. eauto.
+ econstructor; eauto.
+ rewrite Heqrs2' in INV. unfold nextblock, incrPC in INV.
+ eapply agree_exten; eauto with asmgen.
+ assert (forall r : preg, r <> PC -> rs' r = rs2 r).
+ { intros. destruct r.
+ - destruct g. all: rewrite INV; Simpl; auto.
+ - rewrite INV; Simpl; auto.
+ - contradiction. }
+ eauto with asmgen.
+ congruence.
+ + (* MBcond *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ * (* MBcond true *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef.
+ eapply preg_vals; eauto.
+ all: eauto.
+ intros EC.
+ exploit transl_cbranch_correct_true; eauto. intros (rs' & jmp & A & B & C).
+ exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
+ assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
+ rewrite PCeq' in PCeq.
+ assert (f1 = f) by congruence. subst f1.
+ exploit find_label_goto_label.
+ 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs')). rewrite nextblock_pc.
+ unfold Val.offset_ptr. rewrite PCeq. eauto.
+ intros (tc' & rs3 & GOTOL & TLPC & Hrs3).
+ exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+
+ repeat eexists.
+ rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
+ rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
+
+ econstructor; eauto.
+ eapply agree_exten with rs2; eauto with asmgen.
+ { intros. destruct r; try destruct g; try discriminate.
+ all: rewrite Hrs3; try discriminate; unfold nextblock, incrPC; Simpl. }
+ intros. discriminate.
+
+ * (* MBcond false *)
+ assert (f0 = f) by congruence. subst f0.
+ exploit eval_condition_lessdef.
+ eapply preg_vals; eauto.
+ all: eauto.
+ intros EC.
+
+ exploit transl_cbranch_correct_false; eauto. intros (rs' & jmp & A & B & C).
+ exploit exec_straight_opt_body2. eauto. intros (bdy & EXEB & BTC).
+ assert (PCeq': rs2 PC = rs' PC). { inv A; auto. erewrite <- exec_straight_pc. 2: eapply H. eauto. }
+ rewrite PCeq' in PCeq.
+ exploit functions_transl. eapply FIND1. eapply TRANSF0. intros FIND'.
+ assert (tf = fn) by congruence. subst tf.
+
+ assert (NOOV: size_blocks fn.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1.
+
+ repeat eexists.
+ rewrite H6. rewrite <- BTC. rewrite extract_basics_to_code. simpl. rewrite app_nil_r. eauto.
+ rewrite H7. rewrite <- BTC. rewrite extract_ctl_basics_to_code. simpl extract_ctl. rewrite B. eauto.
+
+ econstructor; eauto.
+ unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. econstructor; eauto.
+ eapply agree_exten with rs2; eauto with asmgen.
+ { intros. destruct r; try destruct g; try discriminate.
+ all: rewrite <- C; try discriminate; unfold nextblock, incrPC; Simpl. }
+ intros. discriminate.
+ + (* MBjumptable *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ monadInv H1.
+ generalize (transf_function_no_overflow _ _ TRANSF0); intro NOOV.
+ assert (f1 = f) by congruence. subst f1.
+ exploit find_label_goto_label. 4: eapply H16. 1-2: eauto. instantiate (2 := (nextblock tbb rs2) # GPR62 <- Vundef # GPR63 <- Vundef).
+ unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq. reflexivity.
+ exploit functions_transl. eapply FIND0. eapply TRANSF0. intros FIND3. assert (fn = tf) by congruence. subst fn.
+
+ intros [tc' [rs' [A [B C]]]].
+ exploit ireg_val; eauto. rewrite H13. intros LD; inv LD.
+
+ repeat eexists.
+ rewrite H6. simpl extract_basic. simpl. eauto.
+ rewrite H7. simpl extract_ctl. simpl. Simpl. rewrite <- H1. unfold Mach.label in H14. unfold label. rewrite H14. eapply A.
+ econstructor; eauto.
+ eapply agree_undef_regs; eauto. intros. rewrite C; auto with asmgen.
+ { assert (destroyed_by_jumptable = R62 :: R63 :: nil) by auto. rewrite H2 in H0. simpl in H0. inv H0.
+ destruct (preg_eq r' GPR63). subst. contradiction.
+ destruct (preg_eq r' GPR62). subst. contradiction.
+ destruct r'; Simpl. }
+ discriminate.
+ + (* MBreturn *)
+ destruct bb' as [mhd' mbdy' mex']; simpl in *. subst.
+ inv TBC. inv TIC. inv H0.
+
+ assert (f0 = f) by congruence. subst f0.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ exploit make_epilogue_correct; eauto. intros (rs1 & m1 & U & V & W & X & Y & Z).
+ exploit exec_straight_body; eauto.
+ simpl. eauto.
+ intros EXEB.
+ assert (f1 = f) by congruence. subst f1.
+
+ repeat eexists.
+ rewrite H6. simpl extract_basic. eauto.
+ rewrite H7. simpl extract_ctl. simpl. reflexivity.
+ econstructor; eauto.
+ unfold nextblock, incrPC. repeat apply agree_set_other; auto with asmgen.
+
+ - inv MCS. inv MAS. simpl in *. subst. inv Hpstate.
+ destruct bb' as [hd' bdy' ex']; simpl in *. subst.
+ monadInv TBC. monadInv TIC. simpl in *. rewrite H5. rewrite H6.
+ simpl. repeat eexists.
+ econstructor. 4: instantiate (3 := false). all:eauto.
+ unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite PCeq.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ assert (f = f0) by congruence. subst f0. econstructor; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV TAIL). intro CT1. eauto.
+ eapply agree_exten; eauto. intros. Simpl.
+ discriminate.
+Qed.
+
+Definition mb_remove_first (bb: MB.bblock) :=
+ {| MB.header := MB.header bb; MB.body := tail (MB.body bb); MB.exit := MB.exit bb |}.
+
+Lemma exec_straight_body:
+ forall c c' lc rs1 m1 rs2 m2,
+ exec_straight tge c rs1 m1 c' rs2 m2 ->
+ code_to_basics c = Some lc ->
+ exists l ll,
+ c = l ++ c'
+ /\ code_to_basics l = Some ll
+ /\ exec_body tge ll rs1 m1 = Next rs2 m2.
+Proof.
+ induction c; try (intros; inv H; fail).
+ intros until m2. intros EXES CTB. inv EXES.
+ - exists (i1 ::g nil),(i1::nil). repeat (split; simpl; auto). rewrite H6. auto.
+ - inv CTB. destruct (code_to_basics c); try discriminate. inv H0.
+ eapply IHc in H7; eauto. destruct H7 as (l' & ll & Hc & CTB & EXECB). subst.
+ exists (i ::g l'),(i::ll). repeat (split; simpl; auto).
+ rewrite CTB. auto.
+ rewrite H1. auto.
+Qed.
+
+Lemma basics_to_code_app:
+ forall c l x ll,
+ basics_to_code c = l ++ basics_to_code x ->
+ code_to_basics l = Some ll ->
+ c = ll ++ x.
+Proof.
+ intros. apply (f_equal code_to_basics) in H.
+ erewrite code_to_basics_dist in H; eauto. 2: eapply code_to_basics_id.
+ rewrite code_to_basics_id in H. inv H. auto.
+Qed.
+
+Lemma basics_to_code_app2:
+ forall i c l x ll,
+ (PBasic i) :: basics_to_code c = l ++ basics_to_code x ->
+ code_to_basics l = Some ll ->
+ i :: c = ll ++ x.
+Proof.
+ intros until ll. intros.
+ exploit basics_to_code_app. instantiate (3 := (i::c)). simpl.
+ all: eauto.
+Qed.
+
+(* Handling the individual instructions of theorem (B) in the above diagram. A bit less cumbersome, but still tough *)
+Theorem step_simu_basic:
+ forall bb bb' s fb sp c ms m rs1 m1 ms' m' bi cs1 tbdy bdy,
+ MB.header bb = nil -> MB.body bb = bi::(bdy) -> (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ bb' = {| MB.header := nil; MB.body := bdy; MB.exit := MB.exit bb |} ->
+ basic_step ge s fb sp ms m bi ms' m' ->
+ pstate cs1 = (State rs1 m1) -> pbody1 cs1 = tbdy ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists rs2 m2 l cs2 tbdy',
+ cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := tbdy'; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; ep := fp_is_parent (ep cs1) bi; rem := rem cs1; cur := cur cs1 |}
+ /\ tbdy = l ++ tbdy'
+ /\ exec_body tge l rs1 m1 = Next rs2 m2
+ /\ match_codestate fb (MB.State s fb sp (bb'::c) ms' m') cs2).
+Proof.
+ intros until bdy. intros Hheader Hbody Hnobuiltin (* Hnotempty *) Hbb' BSTEP Hpstate Hpbody1 MCS. inv MCS.
+ simpl in *. inv Hpstate.
+ rewrite Hbody in TBC. monadInv TBC.
+ inv BSTEP.
+
+ - (* MBgetstack *)
+ simpl in EQ0.
+ unfold Mach.load_stack in H.
+ exploit Mem.loadv_extends; eauto. intros [v' [A B]].
+ rewrite (sp_val _ _ _ AG) in A.
+ exploit loadind_correct; eauto with asmgen.
+ intros (rs2 & EXECS & Hrs'1 & Hrs'2).
+ eapply exec_straight_body in EXECS.
+ 2: eapply code_to_basics_id; eauto.
+ destruct EXECS as (l & Hlbi & BTC & CTB & EXECB).
+ exists rs2, m1, Hlbi.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
+ subst. simpl in Hheadereq.
+
+ eapply match_codestate_intro; eauto.
+ { simpl. simpl in EQ. rewrite <- Hheadereq in EQ. assumption. }
+ eapply agree_set_mreg; eauto with asmgen.
+ intro Hep. simpl in Hep.
+ destruct (andb_prop _ _ Hep). clear Hep.
+ rewrite <- Hheadereq in DXP. subst. rewrite <- DXP. rewrite Hrs'2. reflexivity.
+ discriminate. apply preg_of_not_FP; assumption. reflexivity.
+
+ - (* MBsetstack *)
+ simpl in EQ0.
+ unfold Mach.store_stack in H.
+ assert (Val.lessdef (ms src) (rs1 (preg_of src))). { eapply preg_val; eauto. }
+ exploit Mem.storev_extends; eauto. intros [m2' [A B]].
+ exploit storeind_correct; eauto with asmgen.
+ rewrite (sp_val _ _ _ AG) in A. eauto. intros [rs' [P Q]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs', m2', ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
+
+ eapply agree_undef_regs; eauto with asmgen.
+ simpl; intros. rewrite Q; auto with asmgen. rewrite Hheader in DXP. auto.
+ - (* MBgetparam *)
+ simpl in EQ0.
+
+ assert (f0 = f) by congruence; subst f0.
+ unfold Mach.load_stack in *.
+ exploit Mem.loadv_extends. eauto. eexact H0. auto.
+ intros [parent' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit lessdef_parent_sp; eauto. clear B; intros B; subst parent'.
+ exploit Mem.loadv_extends. eauto. eexact H1. auto.
+ intros [v' [C D]].
+
+ monadInv EQ0. rewrite Hheader. rewrite Hheader in DXP.
+ destruct ep0 eqn:EPeq.
+
+ (* RTMP contains parent *)
+ + exploit loadind_correct. eexact EQ1.
+ instantiate (2 := rs1). rewrite DXP; eauto.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & BTC & CTB & EXECB).
+ exists rs2, m1, ll. eexists.
+ eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ { eapply basics_to_code_app; eauto. }
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. simpl. auto. }
+ subst.
+ eapply match_codestate_intro; eauto.
+
+ eapply agree_set_mreg. eapply agree_set_mreg; eauto. congruence. auto with asmgen.
+ simpl; intros. rewrite R; auto with asmgen.
+ apply preg_of_not_FP; auto.
+
+ (* RTMP does not contain parent *)
+ + rewrite chunk_of_Tptr in A.
+ exploit loadind_ptr_correct. eexact A. intros [rs2 [P [Q R]]].
+ exploit loadind_correct. eexact EQ1. instantiate (2 := rs2). rewrite Q. eauto.
+ intros [rs3 [S [T U]]].
+
+ exploit exec_straight_trans.
+ eapply P.
+ eapply S.
+ intros EXES.
+
+ eapply exec_straight_body in EXES.
+ 2: simpl. 2: erewrite code_to_basics_id; eauto.
+ destruct EXES as (l & ll & BTC & CTB & EXECB).
+ exists rs3, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app2; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ subst.
+ eapply match_codestate_intro; eauto.
+ eapply agree_set_mreg. eapply agree_set_mreg. eauto. eauto.
+ instantiate (1 := rs2#FP <- (rs3#FP)). intros.
+ rewrite Pregmap.gso; auto with asmgen.
+ congruence.
+ intros. unfold Pregmap.set. destruct (PregEq.eq r' FP). congruence. auto with asmgen.
+ simpl; intros. rewrite U; auto with asmgen.
+ apply preg_of_not_FP; auto.
+ - (* MBop *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_operation tge sp op (map ms args) m' = Some v).
+ rewrite <- H. apply eval_operation_preserved. exact symbols_preserved.
+ exploit eval_operation_lessdef.
+ eapply preg_vals; eauto.
+ 2: eexact H0.
+ all: eauto.
+ intros [v' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit transl_op_correct; eauto. intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ. rewrite Hheader in EQ. auto.
+ apply agree_set_undef_mreg with rs1; auto.
+ apply Val.lessdef_trans with v'; auto.
+ simpl; intros. destruct (andb_prop _ _ H1); clear H1.
+ rewrite R; auto. apply preg_of_not_FP; auto.
+Local Transparent destroyed_by_op.
+ destruct op; simpl; auto; congruence.
+ - (* MBload *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_addressing tge sp addr (map ms args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ exploit Mem.loadv_extends; eauto. intros [v' [C D]].
+ exploit transl_load_correct; eauto.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ.
+ rewrite <- Hheadereq in EQ. assumption.
+ eapply agree_set_mreg; eauto with asmgen.
+ intro Hep. simpl in Hep.
+ destruct (andb_prop _ _ Hep). clear Hep.
+ subst. rewrite <- DXP. rewrite R; try discriminate. reflexivity.
+ apply preg_of_not_FP; assumption. reflexivity.
+
+ - (* notrap1 cannot happen *)
+ simpl in EQ0. unfold transl_load in EQ0.
+ destruct addr; simpl in H.
+ all: unfold transl_load_rrrXS, transl_load_rrr, transl_load_rro in EQ0;
+ monadInv EQ0; unfold transl_memory_access2XS, transl_memory_access2, transl_memory_access in EQ2;
+ destruct args as [|h0 t0]; try discriminate;
+ destruct t0 as [|h1 t1]; try discriminate;
+ destruct t1 as [|h2 t2]; try discriminate.
+
+ - (* MBload notrap2 TODO *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_addressing tge sp addr (map ms args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+
+ destruct (Mem.loadv chunk m1 a') as [v' | ] eqn:Hload.
+ {
+ exploit transl_load_correct; eauto.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *.
+ simpl in EQ. assumption.
+
+ eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.
+
+ simpl. intro.
+ rewrite R; try congruence.
+ apply DXP.
+ destruct ep0; simpl in *; congruence.
+ apply preg_of_not_FP.
+ destruct ep0; simpl in *; congruence.
+ }
+ {
+ exploit transl_load_correct_notrap2; eauto.
+ intros [rs2 [P [Q R]]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m1, ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+(* assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ rewrite <- Hheadereq. *) subst.
+ eapply match_codestate_intro; eauto. simpl. rewrite Hheader in *. simpl in EQ. assumption.
+
+ eapply agree_set_undef_mreg; eauto. intros; auto with asmgen.
+ simpl. intro.
+ rewrite R; try congruence.
+ apply DXP.
+ destruct ep0; simpl in *; congruence.
+ apply preg_of_not_FP.
+ destruct ep0; simpl in *; congruence.
+ }
+ - (* MBstore *)
+ simpl in EQ0. rewrite Hheader in DXP.
+
+ assert (eval_addressing tge sp addr (map ms args) = Some a).
+ rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
+ exploit eval_addressing_lessdef. eapply preg_vals; eauto. eexact H1.
+ intros [a' [A B]]. rewrite (sp_val _ _ _ AG) in A.
+ assert (Val.lessdef (ms src) (rs1 (preg_of src))). eapply preg_val; eauto.
+ exploit Mem.storev_extends; eauto. intros [m2' [C D]].
+ exploit transl_store_correct; eauto. intros [rs2 [P Q]].
+
+ eapply exec_straight_body in P.
+ 2: eapply code_to_basics_id; eauto.
+ destruct P as (l & ll & TBC & CTB & EXECB).
+ exists rs2, m2', ll.
+ eexists. eexists. split. instantiate (1 := x). eauto.
+ repeat (split; auto).
+ eapply basics_to_code_app; eauto.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb'.
+ assert (Hheadereq: MB.header bb' = MB.header bb). { subst. auto. }
+ subst.
+ eapply match_codestate_intro; eauto. simpl. simpl in EQ.
+ rewrite <- Hheadereq in EQ. assumption.
+ eapply agree_undef_regs; eauto with asmgen.
+ intro Hep. simpl in Hep.
+ subst. rewrite <- DXP. rewrite Q; try discriminate. reflexivity. reflexivity.
+Qed.
+
+Lemma exec_body_trans:
+ forall l l' rs0 m0 rs1 m1 rs2 m2,
+ exec_body tge l rs0 m0 = Next rs1 m1 ->
+ exec_body tge l' rs1 m1 = Next rs2 m2 ->
+ exec_body tge (l++l') rs0 m0 = Next rs2 m2.
+Proof.
+ induction l.
+ - simpl. congruence.
+ - intros until m2. intros EXEB1 EXEB2.
+ inv EXEB1. destruct (exec_basic_instr _) eqn:EBI; try discriminate.
+ simpl. rewrite EBI. eapply IHl; eauto.
+Qed.
+
+Definition mb_remove_header bb := {| MB.header := nil; MB.body := MB.body bb; MB.exit := MB.exit bb |}.
+
+Program Definition remove_header tbb := {| header := nil; body := body tbb; exit := exit tbb |}.
+Next Obligation.
+ destruct tbb. simpl. auto.
+Qed.
+
+Inductive exec_header: codestate -> codestate -> Prop :=
+ | exec_header_cons: forall cs1,
+ exec_header cs1 {| pstate := pstate cs1; pheader := nil; pbody1 := pbody1 cs1; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; ep := (if pheader cs1 then ep cs1 else false); rem := rem cs1;
+ cur := cur cs1 |}.
+
+(* Theorem (A) in the diagram, the easiest of all *)
+Theorem step_simu_header:
+ forall bb s fb sp c ms m rs1 m1 cs1,
+ pstate cs1 = (State rs1 m1) ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists cs1',
+ exec_header cs1 cs1'
+ /\ match_codestate fb (MB.State s fb sp (mb_remove_header bb::c) ms m) cs1').
+Proof.
+ intros until cs1. intros Hpstate MCS.
+ eexists. split; eauto.
+ econstructor; eauto.
+ inv MCS. simpl in *. inv Hpstate.
+ econstructor; eauto.
+Qed.
+
+Lemma step_matchasm_header:
+ forall fb cs1 cs1' s1,
+ match_asmstate fb cs1 s1 ->
+ exec_header cs1 cs1' ->
+ match_asmstate fb cs1' s1.
+Proof.
+ intros until s1. intros MAS EXH.
+ inv MAS. inv EXH.
+ simpl. econstructor; eauto.
+Qed.
+
+(* Theorem (B) in the diagram, using step_simu_basic + induction on the Machblock body *)
+Theorem step_simu_body:
+ forall bb s fb sp c ms m rs1 m1 ms' cs1 m',
+ MB.header bb = nil ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ body_step ge s fb sp (MB.body bb) ms m ms' m' ->
+ pstate cs1 = (State rs1 m1) ->
+ match_codestate fb (MB.State s fb sp (bb::c) ms m) cs1 ->
+ (exists rs2 m2 cs2 ep,
+ cs2 = {| pstate := (State rs2 m2); pheader := nil; pbody1 := nil; pbody2 := pbody2 cs1;
+ pctl := pctl cs1; ep := ep; rem := rem cs1; cur := cur cs1 |}
+ /\ exec_body tge (pbody1 cs1) rs1 m1 = Next rs2 m2
+ /\ match_codestate fb (MB.State s fb sp ({| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |}::c) ms' m') cs2).
+Proof.
+ intros bb. destruct bb as [hd bdy ex]; simpl; auto. induction bdy as [|bi bdy].
+ - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS.
+ inv BSTEP.
+ exists rs1, m1, cs1, (ep cs1).
+ inv MCS. inv Hpstate. simpl in *. monadInv TBC. repeat (split; simpl; auto).
+ econstructor; eauto.
+ - intros until m'. intros Hheader Hnobuiltin BSTEP Hpstate MCS. inv BSTEP.
+ rename ms' into ms''. rename m' into m''. rename rs' into ms'. rename m'0 into m'.
+ exploit (step_simu_basic); eauto. simpl. eauto. simpl; auto. simpl; auto.
+ intros (rs2 & m2 & l & cs2 & tbdy' & Hcs2 & Happ & EXEB & MCS').
+ simpl in *.
+ exploit IHbdy. auto. 2: eapply H6. 3: eapply MCS'. all: eauto. subst; eauto. simpl; auto.
+ intros (rs3 & m3 & cs3 & ep & Hcs3 & EXEB' & MCS'').
+ exists rs3, m3, cs3, ep.
+ repeat (split; simpl; auto). subst. simpl in *. auto.
+ rewrite Happ. eapply exec_body_trans; eauto. rewrite Hcs2 in EXEB'; simpl in EXEB'. auto.
+Qed.
+
+Lemma exec_body_control:
+ forall b rs1 m1 rs2 m2 rs3 m3 fn,
+ exec_body tge (body b) rs1 m1 = Next rs2 m2 ->
+ exec_control_rel tge fn (exit b) b rs2 m2 rs3 m3 ->
+ exec_bblock_rel tge fn b rs1 m1 rs3 m3.
+Proof.
+ intros until fn. intros EXEB EXECTL.
+ econstructor; eauto. inv EXECTL.
+ unfold exec_bblock. rewrite EXEB. auto.
+Qed.
+
+Definition mbsize (bb: MB.bblock) := (length (MB.body bb) + length_opt (MB.exit bb))%nat.
+
+Lemma mbsize_eqz:
+ forall bb, mbsize bb = 0%nat -> MB.body bb = nil /\ MB.exit bb = None.
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *. unfold mbsize in H.
+ remember (length _) as a. remember (length_opt _) as b.
+ assert (a = 0%nat) by omega. assert (b = 0%nat) by omega. subst. clear H.
+ inv H0. inv H1. destruct bdy; destruct ex; auto.
+ all: try discriminate.
+Qed.
+
+Lemma mbsize_neqz:
+ forall bb, mbsize bb <> 0%nat -> (MB.body bb <> nil \/ MB.exit bb <> None).
+Proof.
+ intros. destruct bb as [hd bdy ex]; simpl in *.
+ destruct bdy; destruct ex; try (right; discriminate); try (left; discriminate).
+ contradict H. unfold mbsize. simpl. auto.
+Qed.
+
+(* Bringing theorems (A), (B) and (C) together, for the case of the absence of builtin instruction *)
+(* This more general form is easier to prove, but the actual theorem is step_simulation_bblock further below *)
+Lemma step_simulation_bblock':
+ forall sf f sp bb bb' bb'' rs m rs' m' s'' c S1,
+ bb' = mb_remove_header bb ->
+ body_step ge sf f sp (Machblock.body bb') rs m rs' m' ->
+ bb'' = mb_remove_body bb' ->
+ (forall ef args res, MB.exit bb'' <> Some (MBbuiltin ef args res)) ->
+ exit_step return_address_offset ge (Machblock.exit bb'') (Machblock.State sf f sp (bb'' :: c) rs' m') E0 s'' ->
+ match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
+ exists S2 : state, plus step tge S1 E0 S2 /\ match_states s'' S2.
+Proof.
+ intros until S1. intros Hbb' BSTEP Hbb'' Hbuiltin ESTEP MS.
+ destruct (mbsize bb) eqn:SIZE.
+ - apply mbsize_eqz in SIZE. destruct SIZE as (Hbody & Hexit).
+ destruct bb as [hd bdy ex]; simpl in *; subst.
+ inv MS. inv AT. exploit transl_blocks_nonil; eauto. intros (tbb & tc' & Htc). subst. rename tc' into tc.
+ monadInv H2. simpl in *. inv ESTEP. inv BSTEP.
+ eexists. split. eapply plus_one.
+ exploit functions_translated; eauto. intros (tf0 & FIND' & TRANSF'). monadInv TRANSF'.
+ assert (x = tf) by congruence. subst x.
+ eapply exec_step_internal; eauto. eapply find_bblock_tail; eauto.
+ unfold exec_bblock. simpl. eauto.
+ econstructor. eauto. eauto. eauto.
+ unfold nextblock, incrPC. Simpl. unfold Val.offset_ptr. rewrite <- H.
+ assert (NOOV: size_blocks tf.(fn_blocks) <= Ptrofs.max_unsigned).
+ eapply transf_function_no_overflow; eauto.
+ econstructor; eauto.
+ generalize (code_tail_next_int _ _ _ _ NOOV H3). intro CT1. eauto.
+ eapply agree_exten; eauto. intros. Simpl.
+ intros. discriminate.
+ - subst. exploit mbsize_neqz. { instantiate (1 := bb). rewrite SIZE. discriminate. }
+ intros Hnotempty.
+
+ (* initial setting *)
+ exploit match_state_codestate.
+ 2: eapply Hnotempty.
+ all: eauto.
+ intros (cs1 & fb & f0 & tbb & tc & ep & MCS & MAS & FIND & TLBS & Hbody & Hexit & Hcur & Hrem & Hpstate).
+
+ (* step_simu_header part *)
+ assert (exists rs1 m1, pstate cs1 = State rs1 m1). { inv MAS. simpl. eauto. }
+ destruct H as (rs1 & m1 & Hpstate2). subst.
+ assert (f = fb). { inv MCS. auto. } subst fb.
+ exploit step_simu_header.
+ 2: eapply MCS.
+ all: eauto.
+ intros (cs1' & EXEH & MCS2).
+
+ (* step_simu_body part *)
+ assert (Hpstate': pstate cs1' = pstate cs1). { inv EXEH; auto. }
+ exploit step_simu_body.
+ 3: eapply BSTEP.
+ 4: eapply MCS2.
+ all: eauto. rewrite Hpstate'. eauto.
+ intros (rs2 & m2 & cs2 & ep' & Hcs2 & EXEB & MCS').
+
+ (* step_simu_control part *)
+ assert (exists tf, Genv.find_funct_ptr tge f = Some (Internal tf)).
+ { exploit functions_translated; eauto. intros (tf & FIND' & TRANSF'). monadInv TRANSF'. eauto. }
+ destruct H as (tf & FIND').
+ assert (exists tex, pbody2 cs1 = extract_basic tex /\ pctl cs1 = extract_ctl tex).
+ { inv MAS. simpl in *. eauto. }
+ destruct H as (tex & Hpbody2 & Hpctl).
+ inv EXEH. simpl in *.
+ subst. exploit step_simu_control.
+ 9: eapply MCS'. all: simpl.
+ 10: eapply ESTEP.
+ all: simpl; eauto.
+ rewrite Hpbody2. rewrite Hpctl.
+ { inv MAS; simpl in *. inv Hpstate2. eapply match_asmstate_some; eauto.
+ erewrite exec_body_pc; eauto. }
+ intros (rs3 & m3 & rs4 & m4 & EXEB' & EXECTL' & MS').
+
+ (* bringing the pieces together *)
+ exploit exec_body_trans.
+ eapply EXEB.
+ eauto.
+ intros EXEB2.
+ exploit exec_body_control; eauto.
+ rewrite <- Hpbody2 in EXEB2. rewrite <- Hbody in EXEB2. eauto.
+ rewrite Hexit. rewrite Hpctl. eauto.
+ intros EXECB. inv EXECB.
+ exists (State rs4 m4).
+ split; auto. eapply plus_one. rewrite Hpstate2.
+ assert (exists ofs, rs1 PC = Vptr f ofs).
+ { rewrite Hpstate2 in MAS. inv MAS. simpl in *. eauto. }
+ destruct H0 as (ofs & Hrs1pc).
+ eapply exec_step_internal; eauto.
+
+ (* proving the initial find_bblock *)
+ rewrite Hpstate2 in MAS. inv MAS. simpl in *.
+ assert (f1 = f0) by congruence. subst f0.
+ rewrite PCeq in Hrs1pc. inv Hrs1pc.
+ exploit functions_translated; eauto. intros (tf1 & FIND'' & TRANS''). rewrite FIND' in FIND''.
+ inv FIND''. monadInv TRANS''. rewrite TRANSF0 in EQ. inv EQ.
+ eapply find_bblock_tail; eauto.
+Qed.
+
+Theorem step_simulation_bblock:
+ forall sf f sp bb ms m ms' m' S2 c,
+ body_step ge sf f sp (Machblock.body bb) ms m ms' m' ->
+ (forall ef args res, MB.exit bb <> Some (MBbuiltin ef args res)) ->
+ exit_step return_address_offset ge (Machblock.exit bb) (Machblock.State sf f sp (bb :: c) ms' m') E0 S2 ->
+ forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
+ exists S2' : state, plus step tge S1' E0 S2' /\ match_states S2 S2'.
+Proof.
+ intros until c. intros BSTEP Hbuiltin ESTEP S1' MS.
+ eapply step_simulation_bblock'; eauto.
+ all: destruct bb as [hd bdy ex]; simpl in *; eauto.
+ inv ESTEP.
+ - econstructor. inv H; try (econstructor; eauto; fail).
+ - econstructor.
+Qed.
+
+(** Dealing now with the builtin case *)
+
+Definition split (c: MB.code) :=
+ match c with
+ | nil => nil
+ | bb::c => {| MB.header := MB.header bb; MB.body := MB.body bb; MB.exit := None |}
+ :: {| MB.header := nil; MB.body := nil; MB.exit := MB.exit bb |} :: c
+ end.
+
+Lemma cons_ok_eq3 {A: Type} :
+ forall (x:A) y z x' y' z',
+ x = x' -> y = y' -> z = z' ->
+ OK (x::y::z) = OK (x'::y'::z').
+Proof.
+ intros. subst. auto.
+Qed.
+
+Lemma transl_blocks_split_builtin:
+ forall bb c ep f ef args res,
+ MB.exit bb = Some (MBbuiltin ef args res) -> MB.body bb <> nil ->
+ transl_blocks f (split (bb::c)) ep = transl_blocks f (bb::c) ep.
+Proof.
+ intros until res. intros Hexit Hbody. simpl split.
+ unfold transl_blocks. fold transl_blocks. unfold transl_block.
+ simpl. remember (transl_basic_code _ _ _) as tbc. remember (transl_instr_control _ _) as tbi.
+ remember (transl_blocks _ _ _) as tlbs.
+ destruct tbc; destruct tbi; destruct tlbs.
+ all: try simpl; auto.
+ - simpl. rewrite Hexit in Heqtbi. simpl in Heqtbi. monadInv Heqtbi. simpl.
+ unfold gen_bblocks. simpl. destruct l.
+ + exploit transl_basic_code_nonil; eauto. intro. destruct H.
+ + simpl. rewrite app_nil_r. apply cons_ok_eq3. all: try eapply bblock_equality. all: simpl; auto.
+Qed.
+
+Lemma transl_code_at_pc_split_builtin:
+ forall rs f f0 bb c ep tf tc ef args res,
+ MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ transl_code_at_pc ge (rs PC) f f0 (bb :: c) ep tf tc ->
+ transl_code_at_pc ge (rs PC) f f0 (split (bb :: c)) ep tf tc.
+Proof.
+ intros until res. intros Hbody Hexit AT. inv AT.
+ econstructor; eauto. erewrite transl_blocks_split_builtin; eauto.
+Qed.
+
+Theorem match_states_split_builtin:
+ forall sf f sp bb c rs m ef args res S1,
+ MB.body bb <> nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ match_states (Machblock.State sf f sp (bb :: c) rs m) S1 ->
+ match_states (Machblock.State sf f sp (split (bb::c)) rs m) S1.
+Proof.
+ intros until S1. intros Hbody Hexit MS.
+ inv MS.
+ econstructor; eauto.
+ eapply transl_code_at_pc_split_builtin; eauto.
+Qed.
+
+Theorem step_simulation_builtin:
+ forall ef args res bb sf f sp c ms m t S2,
+ MB.body bb = nil -> MB.exit bb = Some (MBbuiltin ef args res) ->
+ exit_step return_address_offset ge (MB.exit bb) (Machblock.State sf f sp (bb :: c) ms m) t S2 ->
+ forall S1', match_states (Machblock.State sf f sp (bb :: c) ms m) S1' ->
+ exists S2' : state, plus step tge S1' t S2' /\ match_states S2 S2'.
+Proof.
+ intros until S2. intros Hbody Hexit ESTEP S1' MS.
+ inv MS. inv AT. monadInv H2. monadInv EQ.
+ rewrite Hbody in EQ0. monadInv EQ0.
+ rewrite Hexit in EQ. monadInv EQ.
+ rewrite Hexit in ESTEP. inv ESTEP. inv H4.
+
+ exploit functions_transl; eauto. intro FN.
+ generalize (transf_function_no_overflow _ _ H1); intro NOOV.
+ exploit builtin_args_match; eauto. intros [vargs' [P Q]].
+ exploit external_call_mem_extends; eauto.
+ intros [vres' [m2' [A [B [C D]]]]].
+ econstructor; split. apply plus_one.
+ simpl in H3.
+ eapply exec_step_builtin. eauto. eauto.
+ eapply find_bblock_tail; eauto.
+ simpl. eauto.
+ erewrite <- sp_val by eauto.
+ eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ eauto.
+ econstructor; eauto.
+ instantiate (2 := tf); instantiate (1 := x0).
+ unfold nextblock, incrPC. rewrite Pregmap.gss.
+ rewrite set_res_other. rewrite undef_regs_other_2. rewrite Pregmap.gso by congruence.
+ rewrite <- H. simpl. econstructor; eauto.
+ eapply code_tail_next_int; eauto.
+ rewrite preg_notin_charact. intros. auto with asmgen.
+ auto with asmgen.
+ apply agree_nextblock. eapply agree_set_res; auto.
+ eapply agree_undef_regs; eauto. intros. rewrite undef_regs_other_2; auto.
+ apply Pregmap.gso; auto with asmgen.
+ congruence.
+Qed.
+
+Lemma next_sep:
+ forall rs m rs' m', rs = rs' -> m = m' -> Next rs m = Next rs' m'.
+Proof.
+ congruence.
+Qed.
+
+(* Measure to prove finite stuttering, see the other backends *)
+Definition measure (s: MB.state) : nat :=
+ match s with
+ | MB.State _ _ _ _ _ _ => 0%nat
+ | MB.Callstate _ _ _ _ => 0%nat
+ | MB.Returnstate _ _ _ => 1%nat
+ end.
+
+(* The actual MB.step/AB.step simulation, using the above theorems, plus extra proofs
+ for the internal and external function cases *)
+Theorem step_simulation:
+ forall S1 t S2, MB.step return_address_offset ge S1 t S2 ->
+ forall S1' (MS: match_states S1 S1'),
+ (exists S2', plus step tge S1' t S2' /\ match_states S2 S2')
+ \/ (measure S2 < measure S1 /\ t = E0 /\ match_states S2 S1')%nat.
+Proof.
+ induction 1; intros.
+
+- (* bblock *)
+ left. destruct (Machblock.exit bb) eqn:MBE; try destruct c0.
+ all: try(inversion H0; subst; inv H2; eapply step_simulation_bblock;
+ try (rewrite MBE; try discriminate); eauto).
+ + (* MBbuiltin *)
+ destruct (MB.body bb) eqn:MBB.
+ * inv H. eapply step_simulation_builtin; eauto. rewrite MBE. eauto.
+ * eapply match_states_split_builtin in MS; eauto.
+ 2: rewrite MBB; discriminate.
+ simpl split in MS.
+ rewrite <- MBB in H.
+ remember {| MB.header := _; MB.body := _; MB.exit := _ |} as bb1.
+ assert (MB.body bb = MB.body bb1). { subst. simpl. auto. }
+ rewrite H1 in H. subst.
+ exploit step_simulation_bblock. eapply H.
+ discriminate.
+ simpl. constructor.
+ eauto.
+ intros (S2' & PLUS1 & MS').
+ rewrite MBE in MS'.
+ assert (exit_step return_address_offset ge (Some (MBbuiltin e l b))
+ (MB.State sf f sp ({| MB.header := nil; MB.body := nil; MB.exit := Some (MBbuiltin e l b) |}::c)
+ rs' m') t s').
+ { inv H0. inv H3. econstructor. econstructor; eauto. }
+ exploit step_simulation_builtin.
+ 4: eapply MS'.
+ all: simpl; eauto.
+ intros (S3' & PLUS'' & MS'').
+ exists S3'. split; eauto.
+ eapply plus_trans. eapply PLUS1. eapply PLUS''. eauto.
+ + inversion H0. subst. eapply step_simulation_bblock; try (rewrite MBE; try discriminate); eauto.
+
+- (* internal function *)
+ inv MS.
+ exploit functions_translated; eauto. intros [tf [A B]]. monadInv B.
+ generalize EQ; intros EQ'. monadInv EQ'.
+ destruct (zlt Ptrofs.max_unsigned (size_blocks x0.(fn_blocks))); inversion EQ1. clear EQ1. subst x0.
+ unfold Mach.store_stack in *.
+ exploit Mem.alloc_extends. eauto. eauto. apply Z.le_refl. apply Z.le_refl.
+ intros [m1' [C D]].
+ exploit Mem.storev_extends. eexact D. eexact H1. eauto. eauto.
+ intros [m2' [F G]].
+ simpl chunk_of_type in F.
+ exploit Mem.storev_extends. eexact G. eexact H2. eauto. eauto.
+ intros [m3' [P Q]].
+ (* Execution of function prologue *)
+ monadInv EQ0.
+ set (tfbody := make_prologue f x0) in *.
+ set (tf := {| fn_sig := MB.fn_sig f; fn_blocks := tfbody |}) in *.
+ set (rs2 := rs0#FP <- (parent_sp s) #SP <- sp #RTMP <- Vundef).
+ exploit (Pget_correct tge GPRA RA nil rs2 m2'); auto.
+ intros (rs' & U' & V').
+ exploit (storeind_ptr_correct tge SP (fn_retaddr_ofs f) GPRA nil rs' m2').
+ { rewrite chunk_of_Tptr in P.
+ assert (rs' GPRA = rs0 RA). { apply V'. }
+ assert (rs' SP = rs2 SP). { apply V'; discriminate. }
+ rewrite H4. rewrite H3.
+ rewrite ATLR.
+ change (rs2 SP) with sp. eexact P. }
+ intros (rs3 & U & V).
+ assert (EXEC_PROLOGUE: exists rs3',
+ exec_straight_blocks tge tf
+ tf.(fn_blocks) rs0 m'
+ x0 rs3' m3'
+ /\ forall r, r <> PC -> rs3' r = rs3 r).
+ { eexists. split.
+ - change (fn_blocks tf) with tfbody; unfold tfbody.
+ econstructor; eauto. unfold exec_bblock. simpl exec_body.
+ rewrite C. fold sp. rewrite <- (sp_val _ _ _ AG). rewrite chunk_of_Tptr in F. simpl in F. rewrite F.
+ Simpl. unfold parexec_store_offset. rewrite Ptrofs.of_int64_to_int64. unfold eval_offset.
+ rewrite chunk_of_Tptr in P. Simpl. rewrite ATLR. unfold Mptr in P. assert (Archi.ptr64 = true) by auto. 2: auto. rewrite H3 in P. rewrite P.
+ simpl. apply next_sep; eauto. reflexivity.
+ - intros. destruct V' as (V'' & V'). destruct r.
+ + Simpl.
+ destruct (gpreg_eq g0 GPR16). { subst. Simpl. rewrite V; try discriminate. rewrite V''. subst rs2. Simpl. }
+ destruct (gpreg_eq g0 GPR32). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
+ destruct (gpreg_eq g0 GPR12). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
+ destruct (gpreg_eq g0 GPR17). { subst. Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. }
+ Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl. { destruct g0; try discriminate. contradiction. }
+ + Simpl. rewrite V; try discriminate. rewrite V'; try discriminate. subst rs2. Simpl.
+ + contradiction.
+ } destruct EXEC_PROLOGUE as (rs3' & EXEC_PROLOGUE & Heqrs3').
+ exploit exec_straight_steps_2; eauto using functions_transl.
+ simpl fn_blocks. simpl fn_blocks in g. omega. constructor.
+ intros (ofs' & X & Y).
+ left; exists (State rs3' m3'); split.
+ eapply exec_straight_steps_1; eauto.
+ simpl fn_blocks. simpl fn_blocks in g. omega.
+ constructor.
+ econstructor; eauto.
+ rewrite X; econstructor; eauto.
+ apply agree_exten with rs2; eauto with asmgen.
+ unfold rs2.
+ apply agree_set_other; auto with asmgen.
+ apply agree_change_sp with (parent_sp s).
+ apply agree_undef_regs with rs0. auto.
+Local Transparent destroyed_at_function_entry.
+ simpl; intros; Simpl.
+ unfold sp; congruence.
+
+ intros.
+ assert (r <> RTMP). { contradict H3; rewrite H3; unfold data_preg; auto. }
+ rewrite Heqrs3'. Simpl. rewrite V. inversion V'. rewrite H6. auto.
+ assert (r <> GPRA). { contradict H3; rewrite H3; unfold data_preg; auto. }
+ assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ contradict H3; rewrite H3; unfold data_preg; auto.
+ intros. rewrite Heqrs3'. rewrite V by auto with asmgen.
+ assert (forall r : preg, r <> PC -> r <> GPRA -> rs' r = rs2 r). { apply V'. }
+ rewrite H4 by auto with asmgen. reflexivity. discriminate.
+
+- (* external function *)
+ inv MS.
+ exploit functions_translated; eauto.
+ intros [tf [A B]]. simpl in B. inv B.
+ exploit extcall_arguments_match; eauto.
+ intros [args' [C D]].
+ exploit external_call_mem_extends; eauto.
+ intros [res' [m2' [P [Q [R S]]]]].
+ left; econstructor; split.
+ apply plus_one. eapply exec_step_external; eauto.
+ eapply external_call_symbols_preserved; eauto. apply senv_preserved.
+ econstructor; eauto.
+ unfold loc_external_result.
+ apply agree_set_other; auto.
+ apply agree_set_pair; auto.
+ apply agree_undef_caller_save_regs; auto.
+
+- (* return *)
+ inv MS.
+ inv STACKS. simpl in *.
+ right. split. omega. split. auto.
+ rewrite <- ATPC in H5.
+ econstructor; eauto. congruence.
+Qed.
+
+Lemma transf_initial_states:
+ forall st1, MB.initial_state prog st1 ->
+ exists st2, AB.initial_state tprog st2 /\ match_states st1 st2.
+Proof.
+ intros. inversion H. unfold ge0 in *.
+ econstructor; split.
+ econstructor.
+ eapply (Genv.init_mem_transf_partial TRANSF); eauto.
+ replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Ptrofs.zero)
+ with (Vptr fb Ptrofs.zero).
+ econstructor; eauto.
+ constructor.
+ apply Mem.extends_refl.
+ split. auto. simpl. unfold Vnullptr; destruct Archi.ptr64; congruence.
+ intros. rewrite Mach.Regmap.gi. auto.
+ unfold Genv.symbol_address.
+ rewrite (match_program_main TRANSF).
+ rewrite symbols_preserved.
+ unfold ge; rewrite H1. auto.
+Qed.
+
+Lemma transf_final_states:
+ forall st1 st2 r,
+ match_states st1 st2 -> MB.final_state st1 r -> AB.final_state st2 r.
+Proof.
+ intros. inv H0. inv H. constructor. assumption.
+ compute in H1. inv H1.
+ generalize (preg_val _ _ _ R0 AG). rewrite H2. intros LD; inv LD. auto.
+Qed.
+
+Definition return_address_offset : Machblock.function -> Machblock.code -> ptrofs -> Prop :=
+ Asmblockgenproof0.return_address_offset.
+
+Theorem transf_program_correct:
+ forward_simulation (MB.semantics return_address_offset prog) (Asmblock.semantics tprog).
+Proof.
+ eapply forward_simulation_star with (measure := measure).
+ - apply senv_preserved.
+ - eexact transf_initial_states.
+ - eexact transf_final_states.
+ - exact step_simulation.
+Qed.
+
+End PRESERVATION.
diff --git a/mppa_k1c/Asmblockgenproof1.v b/mppa_k1c/Asmblockgenproof1.v
index 3c1162bd..00df01e3 100644
--- a/mppa_k1c/Asmblockgenproof1.v
+++ b/mppa_k1c/Asmblockgenproof1.v
@@ -15,12 +15,16 @@
(* *)
(* *********************************************************************)
+(** * Proof of correctness for individual instructions *)
+
Require Import Coqlib Errors Maps.
Require Import AST Integers Floats Values Memory Globalenvs.
Require Import Op Locations Machblock Conventions.
-Require Import Asmblock Asmblockgen Asmblockgenproof0.
+Require Import Asmblock Asmblockgen Asmblockgenproof0 Asmblockprops.
Require Import Chunks.
+Import PArithCoercions.
+
(** Decomposition of integer constants. *)
Lemma make_immed32_sound:
@@ -86,31 +90,6 @@ Section CONSTRUCTORS.
Variable ge: genv.
Variable fn: function.
-(*
-(** 32-bit integer constants and arithmetic *)
-(*
-Lemma load_hilo32_correct:
- forall rd hi lo k rs m,
- exists rs',
- exec_straight ge fn (load_hilo32 rd hi lo k) rs m k rs' m
- /\ rs'#rd = Vint (Int.add (Int.shl hi (Int.repr 12)) lo)
- /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
-Proof.
- unfold load_hilo32; intros.
- predSpec Int.eq Int.eq_spec lo Int.zero.
-- subst lo. econstructor; split.
- apply exec_straight_one. simpl; eauto. auto.
- split. rewrite Int.add_zero. Simpl.
- intros; Simpl.
-- econstructor; split.
- eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
- split. Simpl.
- intros; Simpl.
-Qed.
-*)
-
-*)
-
Lemma loadimm32_correct:
forall rd n k rs m,
exists rs',
@@ -141,60 +120,6 @@ Proof.
intros; Simpl.
Qed.
-(*
-(*
-Lemma opimm32_correct:
- forall (op: ireg -> ireg0 -> ireg0 -> instruction)
- (opi: ireg -> ireg0 -> int -> instruction)
- (sem: val -> val -> val) m,
- (forall d s1 s2 rs,
- exec_instr ge fn (op d s1 s2) rs m = Next (nextinstr (rs#d <- (sem rs##s1 rs##s2))) m) ->
- (forall d s n rs,
- exec_instr ge fn (opi d s n) rs m = Next (nextinstr (rs#d <- (sem rs##s (Vint n)))) m) ->
- forall rd r1 n k rs,
- r1 <> RTMP ->
- exists rs',
- exec_straight ge fn (opimm32 op opi rd r1 n k) rs m k rs' m
- /\ rs'#rd = sem rs##r1 (Vint n)
- /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r.
-Proof.
- intros. unfold opimm32. generalize (make_immed32_sound n); intros E.
- destruct (make_immed32 n).
-- subst imm. econstructor; split.
- apply exec_straight_one. rewrite H0. simpl; eauto. auto.
- split. Simpl. intros; Simpl.
-- destruct (load_hilo32_correct RTMP hi lo (op rd r1 RTMP :: k) rs m)
- as (rs' & A & B & C).
- econstructor; split.
- eapply exec_straight_trans. eexact A. apply exec_straight_one.
- rewrite H; eauto. auto.
- split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence.
- intros; Simpl.
-Qed.
-
-(** 64-bit integer constants and arithmetic *)
-
-Lemma load_hilo64_correct:
- forall rd hi lo k rs m,
- exists rs',
- exec_straight ge fn (load_hilo64 rd hi lo k) rs m k rs' m
- /\ rs'#rd = Vlong (Int64.add (Int64.sign_ext 32 (Int64.shl hi (Int64.repr 12))) lo)
- /\ forall r, r <> PC -> r <> rd -> rs'#r = rs#r.
-Proof.
- unfold load_hilo64; intros.
- predSpec Int64.eq Int64.eq_spec lo Int64.zero.
-- subst lo. econstructor; split.
- apply exec_straight_one. simpl; eauto. auto.
- split. rewrite Int64.add_zero. Simpl.
- intros; Simpl.
-- econstructor; split.
- eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
- split. Simpl.
- intros; Simpl.
-Qed.
-*)
-*)
-
Lemma opimm64_correct:
forall (op: arith_name_rrr)
(opi: arith_name_rri64)
@@ -215,18 +140,6 @@ Proof.
- subst imm. econstructor; split.
apply exec_straight_one. rewrite H0. simpl; eauto. auto.
split. Simpl. intros; Simpl.
-(*
-- destruct (load_hilo64_correct RTMP hi lo (op rd r1 RTMP :: k) rs m)
- as (rs' & A & B & C).
- econstructor; split.
- eapply exec_straight_trans. eexact A. apply exec_straight_one.
- rewrite H; eauto. auto.
- split. Simpl. simpl. rewrite B, C, E. auto. congruence. congruence.
- intros; Simpl.
-- subst imm. econstructor; split.
- eapply exec_straight_two. simpl; eauto. rewrite H. simpl; eauto. auto. auto.
- split. Simpl. intros; Simpl.
-*)
Qed.
(** Add offset to pointer *)
@@ -252,35 +165,6 @@ Proof.
rewrite Ptrofs.of_int64_to_int64 by auto. auto.
Qed.
-(*
-(*
-Lemma addptrofs_correct_2:
- forall rd r1 n k (rs: regset) m b ofs,
- r1 <> RTMP -> rs#r1 = Vptr b of
-s ->
- exists rs',
- exec_straight ge fn (addptrofs rd r1 n k) rs m k rs' m
- /\ rs'#rd = Vptr b (Ptrofs.add ofs n)
- /\ forall r, r <> PC -> r <> rd -> r <> RTMP -> rs'#r = rs#r.
-Proof.
- intros. exploit (addptrofs_correct rd r1 n); eauto. intros (rs' & A & B & C).
- exists rs'; intuition eauto.
- rewrite H0 in B. inv B. auto.
-Qed.
-
-(** Translation of conditional branches *)
-
-Remark branch_on_RTMP:
- forall normal lbl (rs: regset) m b,
- rs#RTMP = Val.of_bool (eqb normal b) ->
- exec_instr ge fn (if normal then Pbnew RTMP X0 lbl else Pbeqw RTMP X0 lbl) rs m =
- eval_branch fn lbl rs m (Some b).
-Proof.
- intros. destruct normal; simpl; rewrite H; simpl; destruct b; reflexivity.
-Qed.
-*)
-*)
-
Ltac ArgsInv :=
repeat (match goal with
| [ H: Error _ = OK _ |- _ ] => discriminate
@@ -977,7 +861,7 @@ Proof.
destruct cmp; discriminate.
Qed.
-Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct.
+Local Hint Resolve Val_cmpu_bool_correct Val_cmplu_bool_correct: core.
Lemma transl_cbranch_correct_1:
forall cond args lbl k c m ms b sp rs m' tbb,
@@ -1281,7 +1165,7 @@ Proof.
split; intros; Simpl.
Qed.
-Local Hint Resolve Val_cmpu_correct Val_cmplu_correct.
+Local Hint Resolve Val_cmpu_correct Val_cmplu_correct: core.
Lemma transl_condimm_int32u_correct:
forall cmp rd r1 n k rs m,
@@ -1522,99 +1406,6 @@ Proof.
exploit transl_cond_nofloat32_correct; eauto. intros (rs' & A & B & C). exists rs'; eauto.
Qed.
-(*
-(*
-+ (* cmpf *)
- destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR.
- fold (Val.cmpf c0 (rs x) (rs x0)).
- set (v := Val.cmpf c0 (rs x) (rs x0)).
- destruct normal; inv EQ2.
-* econstructor; split.
- apply exec_straight_one. eapply transl_cond_float_correct with (v := v); eauto. auto.
- split; intros; Simpl.
-* econstructor; split.
- eapply exec_straight_two.
- eapply transl_cond_float_correct with (v := Val.notbool v); eauto.
- simpl; reflexivity.
- auto. auto.
- split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto.
-+ (* notcmpf *)
- destruct (transl_cond_float c0 rd x x0) as [insn normal] eqn:TR.
- rewrite Val.notbool_negb_3. fold (Val.cmpf c0 (rs x) (rs x0)).
- set (v := Val.cmpf c0 (rs x) (rs x0)).
- destruct normal; inv EQ2.
-* econstructor; split.
- eapply exec_straight_two.
- eapply transl_cond_float_correct with (v := v); eauto.
- simpl; reflexivity.
- auto. auto.
- split; intros; Simpl. unfold v, Val.cmpf. destruct (Val.cmpf_bool c0 (rs x) (rs x0)) as [[]|]; auto.
-* econstructor; split.
- apply exec_straight_one. eapply transl_cond_float_correct with (v := Val.notbool v); eauto. auto.
- split; intros; Simpl.
-+ (* cmpfs *)
- destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR.
- fold (Val.cmpfs c0 (rs x) (rs x0)).
- set (v := Val.cmpfs c0 (rs x) (rs x0)).
- destruct normal; inv EQ2.
-* econstructor; split.
- apply exec_straight_one. eapply transl_cond_single_correct with (v := v); eauto. auto.
- split; intros; Simpl.
-* econstructor; split.
- eapply exec_straight_two.
- eapply transl_cond_single_correct with (v := Val.notbool v); eauto.
- simpl; reflexivity.
- auto. auto.
- split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto.
-+ (* notcmpfs *)
- destruct (transl_cond_single c0 rd x x0) as [insn normal] eqn:TR.
- rewrite Val.notbool_negb_3. fold (Val.cmpfs c0 (rs x) (rs x0)).
- set (v := Val.cmpfs c0 (rs x) (rs x0)).
- destruct normal; inv EQ2.
-* econstructor; split.
- eapply exec_straight_two.
- eapply transl_cond_single_correct with (v := v); eauto.
- simpl; reflexivity.
- auto. auto.
- split; intros; Simpl. unfold v, Val.cmpfs. destruct (Val.cmpfs_bool c0 (rs x) (rs x0)) as [[]|]; auto.
-* econstructor; split.
- apply exec_straight_one. eapply transl_cond_single_correct with (v := Val.notbool v); eauto. auto.
- split; intros; Simpl.
-*)
-*)
-
-(** Some arithmetic properties. *)
-
-(* Remark cast32unsigned_from_cast32signed:
- forall i, Int64.repr (Int.unsigned i) = Int64.zero_ext 32 (Int64.repr (Int.signed i)).
-Proof.
- intros. apply Int64.same_bits_eq; intros.
- rewrite Int64.bits_zero_ext, !Int64.testbit_repr by tauto.
- rewrite Int.bits_signed by tauto. fold (Int.testbit i i0).
- change Int.zwordsize with 32.
- destruct (zlt i0 32). auto. apply Int.bits_above. auto.
-Qed.
-
-Lemma cast32signed_correct:
- forall (d s: ireg) (k: code) (rs: regset) (m: mem),
- exists rs': regset,
- exec_straight ge (cast32signed d s ::g k) rs m k rs' m
- /\ Val.lessdef (Val.longofint (rs s)) (rs' d)
- /\ (forall r: preg, r <> PC -> r <> d -> rs' r = rs r).
-Proof.
- intros. unfold cast32signed. destruct (ireg_eq d s).
-- econstructor; split.
- + apply exec_straight_one. simpl. eauto with asmgen.
- + split.
- * rewrite e. Simpl.
- * intros. destruct r; Simpl.
-- econstructor; split.
- + apply exec_straight_one. simpl. eauto with asmgen.
- + split.
- * Simpl.
- * intros. destruct r; Simpl.
-Qed. *)
-
(* Translation of arithmetic operations *)
Ltac SimplEval H :=
@@ -1649,6 +1440,51 @@ Proof.
destruct (Z.eq_dec _ _); destruct (Z.eq_dec _ _); congruence.
Qed.
+Lemma select_same_lessdef:
+ forall ty c v,
+ Val.lessdef (Val.select c v v ty) v.
+Proof.
+ intros.
+ unfold Val.select.
+ destruct c; try econstructor.
+ replace (if b then v else v) with v by (destruct b ; trivial).
+ destruct v; destruct ty; simpl; econstructor.
+Qed.
+
+Lemma if_neg : forall X,
+ forall a,
+ forall b c : X,
+ (if (negb a) then b else c) = (if a then c else b).
+Proof.
+ destruct a; reflexivity.
+Qed.
+
+Lemma int_ltu_to_neq:
+ forall x,
+ Int.ltu Int.zero x = negb (Int.eq x Int.zero).
+Proof.
+ intros.
+ unfold Int.ltu, Int.eq.
+ change (Int.unsigned Int.zero) with 0.
+ pose proof (Int.unsigned_range x) as RANGE.
+ unfold zlt, zeq.
+ destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega.
+Qed.
+
+Lemma int64_ltu_to_neq:
+ forall x,
+ Int64.ltu Int64.zero x = negb (Int64.eq x Int64.zero).
+Proof.
+ intros.
+ unfold Int64.ltu, Int64.eq.
+ change (Int64.unsigned Int64.zero) with 0.
+ pose proof (Int64.unsigned_range x) as RANGE.
+ unfold zlt, zeq.
+ destruct (Z_lt_dec _ _); destruct (Z.eq_dec _ _); trivial; omega.
+Qed.
+
+Ltac splitall := repeat match goal with |- _ /\ _ => split end.
+
Lemma transl_op_correct:
forall op args res k (rs: regset) m v c,
transl_op op args res k = OK c ->
@@ -1683,21 +1519,21 @@ Opaque Int.eq.
- (* Ocast8signed *)
econstructor; split.
eapply exec_straight_two. simpl;eauto. simpl;eauto.
- split; intros; simpl; Simpl.
+ repeat split; intros; simpl; Simpl.
assert (A: Int.ltu (Int.repr 24) Int.iwordsize = true) by auto.
destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A.
apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity.
- (* Ocast16signed *)
econstructor; split.
eapply exec_straight_two. simpl;eauto. simpl;eauto.
- split; intros; Simpl.
+ repeat split; intros; Simpl.
assert (A: Int.ltu (Int.repr 16) Int.iwordsize = true) by auto.
destruct (rs x0); auto; simpl. rewrite A; simpl. Simpl. unfold Val.shr. rewrite A.
apply Val.lessdef_same. f_equal. apply Int.sign_ext_shr_shl. split; reflexivity.
- (* Oshrximm *)
econstructor; split.
+ apply exec_straight_one. simpl. eauto.
- + split.
+ + repeat split.
* rewrite Pregmap.gss.
subst v.
destruct (rs x0); simpl; trivial.
@@ -1708,7 +1544,7 @@ Opaque Int.eq.
- (* Oshrxlimm *)
econstructor; split.
+ apply exec_straight_one. simpl. eauto.
- + split.
+ + repeat split.
* rewrite Pregmap.gss.
subst v.
destruct (rs x0); simpl; trivial.
@@ -1716,253 +1552,95 @@ Opaque Int.eq.
destruct (Int.ltu _ _); simpl; trivial.
* intros.
rewrite Pregmap.gso; trivial.
+
- (* Ocmp *)
exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C).
- exists rs'; split. eexact A. eauto with asmgen.
-- (* Oselect *)
- destruct cond in *; simpl in *; try congruence;
- try monadInv EQ3;
- try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew);
- econstructor; split;
- try ( eapply exec_straight_one; simpl; reflexivity ).
- (* Cmp *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmp_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
- (* Cmpu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmpl *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmpl_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmplu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
-- (* Oselectl *)
- destruct cond in *; simpl in *; try congruence;
- try monadInv EQ3;
- try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew);
- econstructor; split;
- try ( eapply exec_straight_one; simpl; reflexivity ).
- (* Cmp *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmp_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
- (* Cmpu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmpl *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmpl_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmplu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
-- (* Oselectf *)
- destruct cond in *; simpl in *; try congruence;
- try monadInv EQ3;
- try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew);
- econstructor; split;
- try ( eapply exec_straight_one; simpl; reflexivity ).
- (* Cmp *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmp_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
- (* Cmpu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmpl *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmpl_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmplu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
-
-- (* Oselectfs *)
- destruct cond in *; simpl in *; try congruence;
- try monadInv EQ3;
- try (injection EQ3; clear EQ3; intro Hrew; rewrite <- Hrew in * ; clear Hrew);
- econstructor; split;
- try ( eapply exec_straight_one; simpl; reflexivity ).
- (* Cmp *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmp_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
- (* Cmpu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Ceq (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpuabs := (Val_cmpu_bool_correct m Cne (rs x1) (Vint Int.zero))).
- destruct (Val.cmpu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpuabs true) | rewrite (Hcmpuabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmpl *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl;
- destruct (Val.cmpl_bool _ _); simpl; try constructor;
- destruct b; simpl; rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
-
- (* Cmplu *)
- + split.
- * unfold eval_select.
- destruct (rs x) eqn:eqX; try constructor.
- destruct (rs x0) eqn:eqX0; try constructor.
- destruct c0 in *; simpl in *; inv EQ2; simpl.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Ceq (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- ** assert (Hcmpluabs := (Val_cmplu_bool_correct m Cne (rs x1) (Vlong Int64.zero))).
- destruct (Val.cmplu_bool _ _); simpl; try constructor.
- destruct b in *; simpl in *; [ rewrite (Hcmpluabs true) | rewrite (Hcmpluabs false)]; trivial;
- rewrite Pregmap.gss; constructor.
- * intros.
- rewrite Pregmap.gso; congruence.
+ exists rs'; repeat split; eauto with asmgen.
+
+- (* Osel *)
+ unfold conditional_move in *.
+ destruct (ireg_eq _ _).
+ {
+ subst x. inv EQ2.
+ econstructor; split.
+ {
+ apply exec_straight_one.
+ simpl. reflexivity.
+ }
+ split.
+ { apply select_same_lessdef. }
+ intros; trivial.
+ }
+
+ destruct c0; simpl in *.
+
+ all: destruct c.
+ all: simpl in *.
+ all: inv EQ2.
+ all: econstructor; splitall.
+ all: try apply exec_straight_one.
+ all: intros; simpl; trivial.
+ all: unfold Val.select, cmove, cmoveu; simpl.
+ all: destruct (rs x1); simpl; trivial.
+ all: try rewrite int_ltu_to_neq.
+ all: try rewrite int64_ltu_to_neq.
+ all: try change (Int64.eq Int64.zero Int64.zero) with true.
+ all: try destruct Archi.ptr64.
+ all: try rewrite Pregmap.gss.
+ all: repeat rewrite if_neg.
+ all: simpl.
+ all: try destruct (_ || _).
+ all: try apply Val.lessdef_normalize.
+ all: trivial. (* no more lessdef *)
+ all: apply Pregmap.gso; congruence.
+
+- (* Oselimm *)
+ unfold conditional_move_imm32 in *.
+ destruct c0; simpl in *.
+
+ all: destruct c.
+ all: simpl in *.
+ all: inv EQ0.
+ all: econstructor; splitall.
+ all: try apply exec_straight_one.
+ all: intros; simpl; trivial.
+ all: unfold Val.select, cmove, cmoveu; simpl.
+ all: destruct (rs x0); simpl; trivial.
+ all: try rewrite int_ltu_to_neq.
+ all: try rewrite int64_ltu_to_neq.
+ all: try change (Int64.eq Int64.zero Int64.zero) with true.
+ all: try destruct Archi.ptr64.
+ all: try rewrite Pregmap.gss.
+ all: repeat rewrite if_neg.
+ all: simpl.
+ all: try destruct (_ || _).
+ all: try apply Val.lessdef_normalize.
+ all: trivial. (* no more lessdef *)
+ all: apply Pregmap.gso; congruence.
+
+- (* Osellimm *)
+ unfold conditional_move_imm64 in *.
+ destruct c0; simpl in *.
+
+ all: destruct c.
+ all: simpl in *.
+ all: inv EQ0.
+ all: econstructor; splitall.
+ all: try apply exec_straight_one.
+ all: intros; simpl; trivial.
+ all: unfold Val.select, cmove, cmoveu; simpl.
+ all: destruct (rs x0); simpl; trivial.
+ all: try rewrite int_ltu_to_neq.
+ all: try rewrite int64_ltu_to_neq.
+ all: try change (Int64.eq Int64.zero Int64.zero) with true.
+ all: try destruct Archi.ptr64.
+ all: try rewrite Pregmap.gss.
+ all: repeat rewrite if_neg.
+ all: simpl.
+ all: try destruct (_ || _).
+ all: try apply Val.lessdef_normalize.
+ all: trivial. (* no more lessdef *)
+ all: apply Pregmap.gso; congruence.
Qed.
(** Memory accesses *)
@@ -1984,40 +1662,13 @@ Proof.
+ econstructor; econstructor; econstructor; econstructor; split.
apply exec_straight_opt_refl.
split; auto. simpl. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto.
-(*
-+ econstructor; econstructor; econstructor; split.
- constructor. eapply exec_straight_two.
- simpl; eauto. simpl; eauto. auto. auto.
- split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl.
- rewrite Ptrofs.add_assoc. f_equal. f_equal.
- rewrite <- (Ptrofs.of_int64_to_int64 SF ofs). rewrite EQ.
- symmetry; auto with ptrofs.
-+ econstructor; econstructor; econstructor; split.
- constructor. eapply exec_straight_two.
- simpl; eauto. simpl; eauto. auto. auto.
- split; intros; Simpl. unfold eval_offset. destruct (rs base); auto; simpl. rewrite SF. simpl.
- rewrite Ptrofs.add_zero. subst imm. rewrite Ptrofs.of_int64_to_int64 by auto. auto.
-(* 32 bits part, irrelevant for us
-- generalize (make_immed32_sound (Ptrofs.to_int ofs)); intros EQ.
- destruct (make_immed32 (Ptrofs.to_int ofs)).
-+ econstructor; econstructor; econstructor; split.
- apply exec_straight_opt_refl.
- split; auto. simpl. subst imm. rewrite Ptrofs.of_int_to_int by auto. auto.
-+ econstructor; econstructor; econstructor; split.
- constructor. eapply exec_straight_two.
- simpl; eauto. simpl; eauto. auto. auto.
- split; intros; Simpl. destruct (rs base); auto; simpl. rewrite SF. simpl.
- rewrite Ptrofs.add_assoc. f_equal. f_equal.
- rewrite <- (Ptrofs.of_int_to_int SF ofs). rewrite EQ.
- symmetry; auto with ptrofs.
-*)*)
Qed.
Lemma indexed_load_access_correct:
- forall chunk (mk_instr: ireg -> offset -> basic) rd m,
+ forall trap chunk (mk_instr: ireg -> offset -> basic) rd m,
(forall base ofs rs,
- exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) ->
+ exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) ->
forall (base: ireg) ofs k (rs: regset) v,
Mem.loadv chunk m (Val.offset_ptr rs#base ofs) = Some v ->
exists rs',
@@ -2070,7 +1721,7 @@ Proof.
/\ c = indexed_memory_access mk_instr base ofs :: k
/\ forall base' ofs' rs',
exec_basic_instr ge (mk_instr base' ofs') rs' m =
- exec_load_offset (chunk_of_type ty) rs' m rd base' ofs').
+ exec_load_offset TRAP (chunk_of_type ty) rs' m rd base' ofs').
{ unfold loadind in TR.
destruct ty, (preg_of dst); inv TR; econstructor; esplit; eauto. }
destruct A as (mk_instr & rd & rdEq & B & C). subst c. rewrite rdEq.
@@ -2138,7 +1789,9 @@ Lemma loadind_ptr_correct:
/\ forall r, r <> PC -> r <> dst -> rs'#r = rs#r.
Proof.
intros. eapply indexed_load_access_correct; eauto with asmgen.
- intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0. auto.
+ intros. unfold Mptr. assert (Archi.ptr64 = true). auto. rewrite H0.
+ instantiate (1 := TRAP).
+ auto.
Qed.
Lemma storeind_ptr_correct:
@@ -2231,11 +1884,11 @@ Proof.
Qed.
Lemma transl_load_access2_correct:
- forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v',
+ forall trap chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro v',
args = mr1 :: mro :: nil ->
ireg_of mro = OK ro ->
(forall base rs,
- exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro) ->
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro) ->
transl_memory_access2 mk_instr addr args k = OK c ->
eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
Mem.loadv chunk m v = Some v' ->
@@ -2253,12 +1906,35 @@ Proof.
split; intros; Simpl. auto.
Qed.
+Lemma transl_load_access2_correct_notrap2:
+ forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c rd (rs: regset) m v mro mr1 ro,
+ args = mr1 :: mro :: nil ->
+ ireg_of mro = OK ro ->
+ (forall base rs,
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro) ->
+ transl_memory_access2 mk_instr addr args k = OK c ->
+ eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
+ Mem.loadv chunk m v = None ->
+ exists rs',
+ exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+ /\ rs'#rd = concrete_default_notrap_load_value chunk
+ /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r.
+Proof.
+ intros until ro; intros ARGS IREGE INSTR TR EV LOAD.
+ exploit transl_memory_access2_correct; eauto.
+ intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS.
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2.
+ rewrite INSTR. unfold exec_load_reg. unfold parexec_load_reg. rewrite B, LOAD. reflexivity. Simpl.
+ split; intros; Simpl. auto.
+Qed.
+
Lemma transl_load_access2XS_correct:
- forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v',
+ forall trap chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro v',
args = mr1 :: mro :: nil ->
ireg_of mro = OK ro ->
(forall base rs,
- exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro) ->
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro) ->
transl_memory_access2XS chunk mk_instr scale args k = OK c ->
eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v ->
Mem.loadv chunk m v = Some v' ->
@@ -2276,13 +1952,39 @@ Proof.
unfold scale_of_chunk.
subst scale.
rewrite B, LOAD. reflexivity. Simpl.
- split; intros; Simpl. auto.
+ split. trivial. intros. Simpl.
+Qed.
+
+Lemma transl_load_access2XS_correct_notrap2:
+ forall chunk (mk_instr: ireg -> ireg -> basic) (scale : Z) args k c rd (rs: regset) m v mro mr1 ro,
+ args = mr1 :: mro :: nil ->
+ ireg_of mro = OK ro ->
+ (forall base rs,
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro) ->
+ transl_memory_access2XS chunk mk_instr scale args k = OK c ->
+ eval_addressing ge rs#SP (Aindexed2XS scale) (map rs (map preg_of args)) = Some v ->
+ Mem.loadv chunk m v = None ->
+ exists rs',
+ exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+ /\ rs'#rd = concrete_default_notrap_load_value chunk
+ /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r.
+Proof.
+ intros until ro; intros ARGS IREGE INSTR TR EV LOAD.
+ exploit transl_memory_access2XS_correct; eauto.
+ intros (base & ro2 & mro2 & mr2 & rs' & ARGSS & IREGEQ & A & B & C & D). rewrite ARGSS in ARGS. inversion ARGS. subst mr2 mro2. clear ARGS.
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A. apply exec_straight_one. assert (ro = ro2) by congruence. subst ro2.
+ rewrite INSTR. unfold exec_load_regxs. unfold parexec_load_regxs.
+ unfold scale_of_chunk.
+ subst scale.
+ rewrite B, LOAD. reflexivity. Simpl.
+ split. trivial. intros. Simpl.
Qed.
Lemma transl_load_access_correct:
- forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v',
+ forall trap chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v v',
(forall base ofs rs,
- exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs) ->
+ exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs) ->
transl_memory_access mk_instr addr args k = OK c ->
eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
Mem.loadv chunk m v = Some v' ->
@@ -2300,54 +2002,119 @@ Proof.
split; intros; Simpl. auto.
Qed.
+Lemma transl_load_access_correct_notrap2:
+ forall chunk (mk_instr: ireg -> offset -> basic) addr args k c rd (rs: regset) m v,
+ (forall base ofs rs,
+ exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs) ->
+ transl_memory_access mk_instr addr args k = OK c ->
+ eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
+ Mem.loadv chunk m v = None ->
+ exists rs',
+ exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+ /\ rs'#rd = concrete_default_notrap_load_value chunk
+ /\ forall r, r <> PC -> r <> RTMP -> r <> rd -> rs'#r = rs#r.
+Proof.
+ intros until v; intros INSTR TR EV LOAD.
+ exploit transl_memory_access_correct; eauto.
+ intros (base & ofs & rs' & ptr & A & PtrEq & B & C).
+ econstructor; split.
+ eapply exec_straight_opt_right. eexact A. apply exec_straight_one.
+ rewrite INSTR. unfold exec_load_offset. unfold parexec_load_offset. rewrite PtrEq, B, LOAD. reflexivity. Simpl.
+ split. trivial. intros. Simpl.
+Qed.
+
Lemma transl_load_memory_access_ok:
- forall addr chunk args dst k c rs a v m,
+ forall addr trap chunk args dst k c rs a v m,
(match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) ->
- transl_load chunk addr args dst k = OK c ->
+ transl_load trap chunk addr args dst k = OK c ->
eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists mk_instr rd,
preg_of dst = IR rd
/\ transl_memory_access mk_instr addr args k = OK c
/\ forall base ofs rs,
- exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset chunk rs m rd base ofs.
+ exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset trap chunk rs m rd base ofs.
Proof.
intros until m. intros ADDR TR ? ?.
unfold transl_load in TR. destruct addr; try contradiction.
- monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto).
- monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split;
- [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity
+ [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity
| eauto ].
- monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split;
- [ instantiate (1 := (PLoadRRO _ x)); simpl; reflexivity
+ [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity
| eauto ].
Qed.
-Lemma transl_load_memory_access2_ok:
- forall addr chunk args dst k c rs a v m,
- addr = Aindexed2 ->
- transl_load chunk addr args dst k = OK c ->
+Lemma transl_load_memory_access_ok_notrap2:
+ forall addr chunk args dst k c rs a m,
+ (match addr with Aindexed2XS _ | Aindexed2 => False | _ => True end) ->
+ transl_load NOTRAP chunk addr args dst k = OK c ->
eval_addressing ge (rs (IR SP)) addr (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = None ->
+ exists mk_instr rd,
+ preg_of dst = IR rd
+ /\ transl_memory_access mk_instr addr args k = OK c
+ /\ forall base ofs rs,
+ exec_basic_instr ge (mk_instr base ofs) rs m = exec_load_offset NOTRAP chunk rs m rd base ofs.
+Proof.
+ intros until m. intros ADDR TR ? ?.
+ unfold transl_load in TR. destruct addr; try contradiction.
+ - monadInv TR. destruct chunk; ArgsInv; econstructor; (esplit; eauto).
+ - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split;
+ [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity
+ | eauto ].
+ - monadInv TR. destruct chunk. all: ArgsInv; destruct args; try discriminate; monadInv EQ0; eexists; eexists; split; try split;
+ [ instantiate (1 := (PLoadRRO _ _ x)); simpl; reflexivity
+ | eauto ].
+Qed.
+
+Lemma transl_load_memory_access2_ok:
+ forall trap chunk args dst k c rs a v m,
+ transl_load trap chunk Aindexed2 args dst k = OK c ->
+ eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists mk_instr mr0 mro rd ro,
args = mr0 :: mro :: nil
/\ preg_of dst = IR rd
/\ preg_of mro = IR ro
- /\ transl_memory_access2 mk_instr addr args k = OK c
+ /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c
/\ forall base rs,
- exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg chunk rs m rd base ro.
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg trap chunk rs m rd base ro.
Proof.
- intros until m. intros ? TR ? ?.
+ intros until m. intros TR ? ?.
+ unfold transl_load in TR. subst. monadInv TR. destruct chunk. all:
+ unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists;
+ [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity
+ | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity
+ | eauto].
+Qed.
+
+
+Lemma transl_load_memory_access2_ok_notrap2:
+ forall chunk args dst k c rs a m,
+ transl_load NOTRAP chunk Aindexed2 args dst k = OK c ->
+ eval_addressing ge (rs (IR SP)) Aindexed2 (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = None ->
+ exists mk_instr mr0 mro rd ro,
+ args = mr0 :: mro :: nil
+ /\ preg_of dst = IR rd
+ /\ preg_of mro = IR ro
+ /\ transl_memory_access2 mk_instr Aindexed2 args k = OK c
+ /\ forall base rs,
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_reg NOTRAP chunk rs m rd base ro.
+Proof.
+ intros until m. intros TR ? ?.
unfold transl_load in TR. subst. monadInv TR. destruct chunk. all:
unfold transl_memory_access2 in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists;
[ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity
- | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ x)); simpl; reflexivity
+ | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRR _ _ x)); simpl; reflexivity
| eauto].
Qed.
Lemma transl_load_memory_access2XS_ok:
- forall scale chunk args dst k c rs a v m,
- transl_load chunk (Aindexed2XS scale) args dst k = OK c ->
+ forall scale trap chunk args dst k c rs a v m,
+ transl_load trap chunk (Aindexed2XS scale) args dst k = OK c ->
eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists mk_instr mr0 mro rd ro,
@@ -2356,19 +2123,41 @@ Lemma transl_load_memory_access2XS_ok:
/\ preg_of mro = IR ro
/\ transl_memory_access2XS chunk mk_instr scale args k = OK c
/\ forall base rs,
- exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs chunk rs m rd base ro.
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs trap chunk rs m rd base ro.
Proof.
intros until m. intros TR ? ?.
unfold transl_load in TR. subst. monadInv TR. destruct chunk. all:
unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists;
[ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity
- | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ x)); simpl; rewrite Heqb; eauto
+ | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto
+ | eauto].
+Qed.
+
+
+Lemma transl_load_memory_access2XS_ok_notrap2:
+ forall scale chunk args dst k c rs a m,
+ transl_load NOTRAP chunk (Aindexed2XS scale) args dst k = OK c ->
+ eval_addressing ge (rs (IR SP)) (Aindexed2XS scale) (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = None ->
+ exists mk_instr mr0 mro rd ro,
+ args = mr0 :: mro :: nil
+ /\ preg_of dst = IR rd
+ /\ preg_of mro = IR ro
+ /\ transl_memory_access2XS chunk mk_instr scale args k = OK c
+ /\ forall base rs,
+ exec_basic_instr ge (mk_instr base ro) rs m = exec_load_regxs NOTRAP chunk rs m rd base ro.
+Proof.
+ intros until m. intros TR ? ?.
+ unfold transl_load in TR. subst. monadInv TR. destruct chunk. all:
+ unfold transl_memory_access2XS in EQ0; repeat (destruct args; try discriminate); monadInv EQ0; ArgsInv; repeat eexists;
+ [ unfold ireg_of in EQ0; destruct (preg_of m1); eauto; try discriminate; monadInv EQ0; reflexivity
+ | rewrite EQ1; rewrite EQ0; simpl; instantiate (1 := (PLoadRRRXS _ _ x)); simpl; rewrite Heqb; eauto
| eauto].
Qed.
Lemma transl_load_correct:
- forall chunk addr args dst k c (rs: regset) m a v,
- transl_load chunk addr args dst k = OK c ->
+ forall trap chunk addr args dst k c (rs: regset) m a v,
+ transl_load trap chunk addr args dst k = OK c ->
eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
@@ -2392,6 +2181,32 @@ Proof.
eapply transl_load_access_correct; eauto with asmgen.
Qed.
+Lemma transl_load_correct_notrap2:
+ forall chunk addr args dst k c (rs: regset) m a,
+ transl_load NOTRAP chunk addr args dst k = OK c ->
+ eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a ->
+ Mem.loadv chunk m a = None ->
+ exists rs',
+ exec_straight ge (basics_to_code c) rs m (basics_to_code k) rs' m
+ /\ rs'#(preg_of dst) = (concrete_default_notrap_load_value chunk)
+ /\ forall r, r <> PC -> r <> RTMP -> r <> preg_of dst -> rs'#r = rs#r.
+Proof.
+ intros until a; intros TR EV LOAD. destruct addr.
+ - exploit transl_load_memory_access2XS_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C).
+ rewrite rdEq. eapply transl_load_access2XS_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity.
+ - exploit transl_load_memory_access2_ok_notrap2; eauto. intros (mk_instr & mr0 & mro & rd & ro & argsEq & rdEq & roEq & B & C).
+ rewrite rdEq. eapply transl_load_access2_correct_notrap2; eauto with asmgen. unfold ireg_of. rewrite roEq. reflexivity.
+ - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity).
+ intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq;
+ eapply transl_load_access_correct_notrap2; eauto with asmgen.
+ - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity).
+ intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq;
+ eapply transl_load_access_correct_notrap2; eauto with asmgen.
+ - exploit transl_load_memory_access_ok_notrap2; eauto; try discriminate; try (simpl; reflexivity).
+ intros A; destruct A as (mk_instr & rd & rdEq & B & C); rewrite rdEq;
+ eapply transl_load_access_correct_notrap2; eauto with asmgen.
+Qed.
+
Lemma transl_store_access2_correct:
forall chunk (mk_instr: ireg -> ireg -> basic) addr args k c r1 (rs: regset) m v mr1 mro ro m',
args = mr1 :: mro :: nil ->
@@ -2671,8 +2486,8 @@ Proof.
{ eapply A2. }
{ apply exec_straight_one. simpl.
rewrite (C2 SP) by auto with asmgen. rewrite <- (sp_val _ _ rs1 AG1). simpl; rewrite LP'.
- rewrite FREE'. eauto. (* auto. *) } }
- * split. (* apply agree_nextinstr. *)apply agree_set_other; auto with asmgen.
+ rewrite FREE'. eauto. } }
+ * split. apply agree_set_other; auto with asmgen.
apply agree_change_sp with (Vptr stk soff).
apply agree_exten with rs; auto. intros; rewrite C2; auto with asmgen.
eapply parent_sp_def; eauto.
diff --git a/mppa_k1c/Asmblockprops.v b/mppa_k1c/Asmblockprops.v
new file mode 100644
index 00000000..3c6ba534
--- /dev/null
+++ b/mppa_k1c/Asmblockprops.v
@@ -0,0 +1,343 @@
+(** Common definition and proofs on Asmblock required by various modules *)
+
+Require Import Coqlib.
+Require Import Integers.
+Require Import Memory.
+Require Import Globalenvs.
+Require Import Values.
+Require Import Asmblock.
+Require Import Axioms.
+
+Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) :=
+ forall rs m,
+ exec_bblock ge f bb rs m <> Stuck ->
+ exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m.
+
+Hint Extern 2 (_ <> _) => congruence: asmgen.
+
+Lemma preg_of_data:
+ forall r, data_preg (preg_of r) = true.
+Proof.
+ intros. destruct r; reflexivity.
+Qed.
+Hint Resolve preg_of_data: asmgen.
+
+Lemma data_diff:
+ forall r r',
+ data_preg r = true -> data_preg r' = false -> r <> r'.
+Proof.
+ congruence.
+Qed.
+Hint Resolve data_diff: asmgen.
+
+Lemma preg_of_not_PC:
+ forall r, preg_of r <> PC.
+Proof.
+ intros. apply data_diff; auto with asmgen.
+Qed.
+
+Lemma preg_of_not_SP:
+ forall r, preg_of r <> SP.
+Proof.
+ intros. unfold preg_of; destruct r; simpl; congruence.
+Qed.
+
+Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen.
+
+
+Lemma nextblock_pc:
+ forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)).
+Proof.
+ intros. apply Pregmap.gss.
+Qed.
+
+Lemma nextblock_inv:
+ forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r.
+Proof.
+ intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto.
+Qed.
+
+Lemma nextblock_inv1:
+ forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r.
+Proof.
+ intros. apply nextblock_inv. red; intro; subst; discriminate.
+Qed.
+
+Ltac Simplif :=
+ ((rewrite nextblock_inv by eauto with asmgen)
+ || (rewrite nextblock_inv1 by eauto with asmgen)
+ || (rewrite Pregmap.gss)
+ || (rewrite nextblock_pc)
+ || (rewrite Pregmap.gso by eauto with asmgen)
+ ); auto with asmgen.
+
+Ltac Simpl := repeat Simplif.
+
+(* For Asmblockgenproof0 *)
+
+Theorem exec_basic_instr_pc:
+ forall ge b rs1 m1 rs2 m2,
+ exec_basic_instr ge b rs1 m1 = Next rs2 m2 ->
+ rs2 PC = rs1 PC.
+Proof.
+ intros. destruct b; try destruct i; try destruct i.
+ all: try (inv H; Simpl).
+ 1-10: unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail.
+
+ 1-20: unfold parexec_load_reg, parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); unfold parexec_incorrect_load in *; destruct trap; try discriminate; unfold concrete_default_notrap_load_value in *; inv H1; Simpl; fail.
+
+ { (* PLoadQRRO *)
+ unfold parexec_load_q_offset in H1.
+ destruct (gpreg_q_expand _) as [r0 r1] in H1.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ inv H1. Simpl. }
+ { (* PLoadORRO *)
+ unfold parexec_load_o_offset in H1.
+ destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ destruct (Mem.loadv _ _ _) in H1; try discriminate.
+ inv H1. Simpl. }
+ 1-8: unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]; fail.
+ 1-8: unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail.
+ 1-8: unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]; auto; fail.
+
+ { (* PStoreQRRO *)
+ unfold parexec_store_q_offset in H1.
+ destruct (gpreg_q_expand _) as [r0 r1] in H1.
+ unfold eval_offset in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ inv H1. Simpl. reflexivity. }
+ { (* PStoreORRO *)
+ unfold parexec_store_o_offset in H1.
+ destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1.
+ unfold eval_offset in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ destruct (Mem.storev _ _ _) in H1; try discriminate.
+ inv H1. Simpl. reflexivity. }
+ - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate.
+ - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate.
+ destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate.
+ - destruct rs; try discriminate. inv H1. Simpl.
+ - destruct rd; try discriminate. inv H1; Simpl.
+ - reflexivity.
+Qed.
+
+(* For PostpassSchedulingproof *)
+
+Lemma regset_double_set:
+ forall r1 r2 (rs: regset) v1 v2,
+ r1 <> r2 ->
+ (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1).
+Proof.
+ intros. apply functional_extensionality. intros r. destruct (preg_eq r r1).
+ - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto.
+ - destruct (preg_eq r r2).
+ + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto.
+ + repeat (rewrite Pregmap.gso; auto).
+Qed.
+
+Lemma next_eq:
+ forall (rs rs': regset) m m',
+ rs = rs' -> m = m' -> Next rs m = Next rs' m'.
+Proof.
+ intros; apply f_equal2; auto.
+Qed.
+
+Lemma exec_load_offset_pc_var:
+ forall trap t rs m rd ra ofs rs' m' v,
+ exec_load_offset trap t rs m rd ra ofs = Next rs' m' ->
+ exec_load_offset trap t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate.
+ destruct (Mem.loadv _ _ _).
+ - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+ - unfold parexec_incorrect_load in *.
+ destruct trap; try discriminate.
+ inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+Qed.
+
+Lemma exec_load_reg_pc_var:
+ forall trap t rs m rd ra ro rs' m' v,
+ exec_load_reg trap t rs m rd ra ro = Next rs' m' ->
+ exec_load_reg trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate.
+ destruct (Mem.loadv _ _ _).
+ - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+ - unfold parexec_incorrect_load in *.
+ destruct trap; try discriminate.
+ inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+Qed.
+
+Lemma exec_load_regxs_pc_var:
+ forall trap t rs m rd ra ro rs' m' v,
+ exec_load_regxs trap t rs m rd ra ro = Next rs' m' ->
+ exec_load_regxs trap t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate.
+ destruct (Mem.loadv _ _ _).
+ - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+ - unfold parexec_incorrect_load in *.
+ destruct trap; try discriminate.
+ inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
+Qed.
+
+Lemma exec_load_offset_q_pc_var:
+ forall rs m rd ra ofs rs' m' v,
+ exec_load_q_offset rs m rd ra ofs = Next rs' m' ->
+ exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *.
+ destruct (gpreg_q_expand rd) as [rd0 rd1].
+ (* destruct (ireg_eq rd0 ra); try discriminate. *)
+ rewrite Pregmap.gso; try discriminate.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ inv H.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ inv H1. f_equal.
+ rewrite (regset_double_set PC rd0) by discriminate.
+ rewrite (regset_double_set PC rd1) by discriminate.
+ reflexivity.
+Qed.
+
+Lemma exec_load_offset_o_pc_var:
+ forall rs m rd ra ofs rs' m' v,
+ exec_load_o_offset rs m rd ra ofs = Next rs' m' ->
+ exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *.
+ destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3].
+(*
+ destruct (ireg_eq rd0 ra); try discriminate.
+ destruct (ireg_eq rd1 ra); try discriminate.
+ destruct (ireg_eq rd2 ra); try discriminate.
+*)
+ rewrite Pregmap.gso; try discriminate.
+ simpl in *.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ destruct (Mem.loadv _ _ _); try discriminate.
+ rewrite (regset_double_set PC rd0) by discriminate.
+ rewrite (regset_double_set PC rd1) by discriminate.
+ rewrite (regset_double_set PC rd2) by discriminate.
+ rewrite (regset_double_set PC rd3) by discriminate.
+ inv H.
+ trivial.
+Qed.
+
+Lemma exec_store_offset_pc_var:
+ forall t rs m rd ra ofs rs' m' v,
+ exec_store_offset t rs m rd ra ofs = Next rs' m' ->
+ exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate.
+ destruct (eval_offset ofs); try discriminate.
+ destruct (Mem.storev _ _ _).
+ - inv H. apply next_eq; auto.
+ - discriminate.
+Qed.
+
+Lemma exec_store_q_offset_pc_var:
+ forall rs m rd ra ofs rs' m' v,
+ exec_store_q_offset rs m rd ra ofs = Next rs' m' ->
+ exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate.
+ simpl in *.
+ destruct (gpreg_q_expand _) as [s0 s1].
+ destruct (Mem.storev _ _ _); try discriminate.
+ destruct (Mem.storev _ _ _); try discriminate.
+ inv H. apply next_eq; auto.
+Qed.
+
+Lemma exec_store_o_offset_pc_var:
+ forall rs m rd ra ofs rs' m' v,
+ exec_store_o_offset rs m rd ra ofs = Next rs' m' ->
+ exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
+Proof.
+ intros.
+ unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *.
+ destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3].
+ destruct (Mem.storev _ _ _); try discriminate.
+ destruct (Mem.storev _ _ _); try discriminate.
+ destruct (Mem.storev _ _ _); try discriminate.
+ destruct (Mem.storev _ _ _); try discriminate.
+ inv H.
+ trivial.
+Qed.
+
+Lemma exec_store_reg_pc_var:
+ forall t rs m rd ra ro rs' m' v,
+ exec_store_reg t rs m rd ra ro = Next rs' m' ->
+ exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate.
+ destruct (Mem.storev _ _ _).
+ - inv H. apply next_eq; auto.
+ - discriminate.
+Qed.
+
+Lemma exec_store_regxs_pc_var:
+ forall t rs m rd ra ro rs' m' v,
+ exec_store_regxs t rs m rd ra ro = Next rs' m' ->
+ exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
+Proof.
+ intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate.
+ destruct (Mem.storev _ _ _).
+ - inv H. apply next_eq; auto.
+ - discriminate.
+Qed.
+
+Theorem exec_basic_instr_pc_var:
+ forall ge i rs m rs' m' v,
+ exec_basic_instr ge i rs m = Next rs' m' ->
+ exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'.
+Proof.
+ intros. unfold exec_basic_instr in *. unfold bstep in *. destruct i.
+ - unfold exec_arith_instr in *. destruct i; destruct i.
+ all: try (exploreInst; inv H; apply next_eq; auto;
+ apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate).
+(*
+ (* Some cases treated seperately because exploreInst destructs too much *)
+ all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *)
+ - destruct i.
+ + exploreInst; apply exec_load_offset_pc_var; auto.
+ + exploreInst; apply exec_load_reg_pc_var; auto.
+ + exploreInst; apply exec_load_regxs_pc_var; auto.
+ + apply exec_load_offset_q_pc_var; auto.
+ + apply exec_load_offset_o_pc_var; auto.
+ - destruct i.
+ + exploreInst; apply exec_store_offset_pc_var; auto.
+ + exploreInst; apply exec_store_reg_pc_var; auto.
+ + exploreInst; apply exec_store_regxs_pc_var; auto.
+ + apply exec_store_q_offset_pc_var; auto.
+ + apply exec_store_o_offset_pc_var; auto.
+ - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate).
+ destruct (Mem.storev _ _ _ _); try discriminate.
+ inv H. apply next_eq; auto. apply functional_extensionality. intros.
+ rewrite (regset_double_set GPR32 PC); try discriminate.
+ rewrite (regset_double_set GPR12 PC); try discriminate.
+ rewrite (regset_double_set FP PC); try discriminate. reflexivity.
+ - repeat (rewrite Pregmap.gso; try discriminate).
+ destruct (Mem.loadv _ _ _); try discriminate.
+ destruct (rs GPR12); try discriminate.
+ destruct (Mem.free _ _ _ _); try discriminate.
+ inv H. apply next_eq; auto.
+ rewrite (regset_double_set GPR32 PC).
+ rewrite (regset_double_set GPR12 PC). reflexivity.
+ all: discriminate.
+ - destruct rs0; try discriminate. inv H. apply next_eq; auto.
+ repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate.
+ - destruct rd; try discriminate. inv H. apply next_eq; auto.
+ repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate.
+ - inv H. apply next_eq; auto.
+Qed.
+
+
diff --git a/mppa_k1c/Asmexpand.ml b/mppa_k1c/Asmexpand.ml
index 65dee6c7..8ab10bc5 100644
--- a/mppa_k1c/Asmexpand.ml
+++ b/mppa_k1c/Asmexpand.ml
@@ -190,10 +190,10 @@ let expand_builtin_memcpy_big sz al src dst =
end);
cpy tmpbuf2 16L (fun x y z -> Plq(x, y, z)) (fun x y z -> Psq(x, y, z));
- cpy tmpbuf 8L (fun x y z -> Pld(x, y, z)) (fun x y z -> Psd(x, y, z));
- cpy tmpbuf 4L (fun x y z -> Plw(x, y, z)) (fun x y z -> Psw(x, y, z));
- cpy tmpbuf 2L (fun x y z -> Plh(x, y, z)) (fun x y z -> Psh(x, y, z));
- cpy tmpbuf 1L (fun x y z -> Plb(x, y, z)) (fun x y z -> Psb(x, y, z));
+ cpy tmpbuf 8L (fun x y z -> Pld(TRAP, x, y, z)) (fun x y z -> Psd(x, y, z));
+ cpy tmpbuf 4L (fun x y z -> Plw(TRAP, x, y, z)) (fun x y z -> Psw(x, y, z));
+ cpy tmpbuf 2L (fun x y z -> Plh(TRAP, x, y, z)) (fun x y z -> Psh(x, y, z));
+ cpy tmpbuf 1L (fun x y z -> Plb(TRAP, x, y, z)) (fun x y z -> Psb(x, y, z));
assert (!remaining = 0L)
end
else
@@ -203,7 +203,7 @@ let expand_builtin_memcpy_big sz al src dst =
let lbl = new_label() in
emit (Ploopdo (tmpbuf, lbl));
emit Psemi;
- emit (Plb (tmpbuf, srcptr, AOff Z.zero));
+ emit (Plb (TRAP, tmpbuf, srcptr, AOff Z.zero));
emit (Paddil (srcptr, srcptr, Z.one));
emit Psemi;
emit (Psb (tmpbuf, dstptr, AOff Z.zero));
@@ -223,30 +223,30 @@ let expand_builtin_memcpy sz al args =
let expand_builtin_vload_common chunk base ofs res =
match chunk, res with
| Mint8unsigned, BR(Asmvliw.IR res) ->
- emit (Plbu (res, base, AOff ofs))
+ emit (Plbu (TRAP, res, base, AOff ofs))
| Mint8signed, BR(Asmvliw.IR res) ->
- emit (Plb (res, base, AOff ofs))
+ emit (Plb (TRAP, res, base, AOff ofs))
| Mint16unsigned, BR(Asmvliw.IR res) ->
- emit (Plhu (res, base, AOff ofs))
+ emit (Plhu (TRAP, res, base, AOff ofs))
| Mint16signed, BR(Asmvliw.IR res) ->
- emit (Plh (res, base, AOff ofs))
+ emit (Plh (TRAP, res, base, AOff ofs))
| Mint32, BR(Asmvliw.IR res) ->
- emit (Plw (res, base, AOff ofs))
+ emit (Plw (TRAP, res, base, AOff ofs))
| Mint64, BR(Asmvliw.IR res) ->
- emit (Pld (res, base, AOff ofs))
+ emit (Pld (TRAP, res, base, AOff ofs))
| Mint64, BR_splitlong(BR(Asmvliw.IR res1), BR(Asmvliw.IR res2)) ->
let ofs' = Integers.Ptrofs.add ofs _4 in
if base <> res2 then begin
- emit (Plw (res2, base, AOff ofs));
- emit (Plw (res1, base, AOff ofs'))
+ emit (Plw (TRAP, res2, base, AOff ofs));
+ emit (Plw (TRAP, res1, base, AOff ofs'))
end else begin
- emit (Plw (res1, base, AOff ofs'));
- emit (Plw (res2, base, AOff ofs))
+ emit (Plw (TRAP, res1, base, AOff ofs'));
+ emit (Plw (TRAP, res2, base, AOff ofs))
end
| Mfloat32, BR(Asmvliw.IR res) ->
- emit (Pfls (res, base, AOff ofs))
+ emit (Pfls (TRAP, res, base, AOff ofs))
| Mfloat64, BR(Asmvliw.IR res) ->
- emit (Pfld (res, base, AOff ofs))
+ emit (Pfld (TRAP, res, base, AOff ofs))
| _ ->
assert false
@@ -345,34 +345,32 @@ let expand_int64_arith conflict rl fn = assert false
(* Byte swaps. There are no specific instructions, so we use standard,
not-very-efficient formulas. *)
-let expand_bswap16 d s = assert false
+let expand_bswap16 d s = let open Asmvliw in
(* d = (s & 0xFF) << 8 | (s >> 8) & 0xFF *)
-(*emit (Pandiw(X31, X s, coqint_of_camlint 0xFFl));
- emit (Pslliw(X31, X X31, _8));
- emit (Psrliw(d, X s, _8));
- emit (Pandiw(d, X d, coqint_of_camlint 0xFFl));
- emit (Porw(d, X X31, X d))
-*)
+ emit (Pandiw(GPR32, s, coqint_of_camlint 0xFFl)); emit Psemi;
+ emit (Pslliw(GPR32, GPR32, _8)); emit Psemi;
+ emit (Psrliw(d, s, _8)); emit Psemi;
+ emit (Pandiw(d, d, coqint_of_camlint 0xFFl));
+ emit (Porw(d, GPR32, d)); emit Psemi
-let expand_bswap32 d s = assert false
+let expand_bswap32 d s = let open Asmvliw in
(* d = (s << 24)
| (((s >> 8) & 0xFF) << 16)
| (((s >> 16) & 0xFF) << 8)
| (s >> 24) *)
-(*emit (Pslliw(X1, X s, coqint_of_camlint 24l));
- emit (Psrliw(X31, X s, _8));
- emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl));
- emit (Pslliw(X31, X X31, _16));
- emit (Porw(X1, X X1, X X31));
- emit (Psrliw(X31, X s, _16));
- emit (Pandiw(X31, X X31, coqint_of_camlint 0xFFl));
- emit (Pslliw(X31, X X31, _8));
- emit (Porw(X1, X X1, X X31));
- emit (Psrliw(X31, X s, coqint_of_camlint 24l));
- emit (Porw(d, X X1, X X31))
-*)
-
-let expand_bswap64 d s = assert false
+ emit (Pslliw(GPR16, s, coqint_of_camlint 24l)); emit Psemi;
+ emit (Psrliw(GPR32, s, _8)); emit Psemi;
+ emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi;
+ emit (Pslliw(GPR32, GPR32, _16)); emit Psemi;
+ emit (Porw(GPR16, GPR16, GPR31)); emit Psemi;
+ emit (Psrliw(GPR32, s, _16)); emit Psemi;
+ emit (Pandiw(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi;
+ emit (Pslliw(GPR32, GPR32, _8)); emit Psemi;
+ emit (Porw(GPR16, GPR16, GPR32)); emit Psemi;
+ emit (Psrliw(GPR32, s, coqint_of_camlint 24l)); emit Psemi;
+ emit (Porw(d, GPR16, GPR32)); emit Psemi
+
+let expand_bswap64 d s = let open Asmvliw in
(* d = s << 56
| (((s >> 8) & 0xFF) << 48)
| (((s >> 16) & 0xFF) << 40)
@@ -381,17 +379,16 @@ let expand_bswap64 d s = assert false
| (((s >> 40) & 0xFF) << 16)
| (((s >> 48) & 0xFF) << 8)
| s >> 56 *)
-(*emit (Psllil(X1, X s, coqint_of_camlint 56l));
+ emit (Psllil(GPR16, s, coqint_of_camlint 56l)); emit Psemi;
List.iter
(fun (n1, n2) ->
- emit (Psrlil(X31, X s, coqint_of_camlint n1));
- emit (Pandil(X31, X X31, coqint_of_camlint 0xFFl));
- emit (Psllil(X31, X X31, coqint_of_camlint n2));
- emit (Porl(X1, X X1, X X31)))
+ emit (Psrlil(GPR32, s, coqint_of_camlint n1)); emit Psemi;
+ emit (Pandil(GPR32, GPR32, coqint_of_camlint 0xFFl)); emit Psemi;
+ emit (Psllil(GPR32, GPR32, coqint_of_camlint n2)); emit Psemi;
+ emit (Porl(GPR16, GPR16, GPR32)); emit Psemi;)
[(8l,48l); (16l,40l); (24l,32l); (32l,24l); (40l,16l); (48l,8l)];
- emit (Psrlil(X31, X s, coqint_of_camlint 56l));
- emit (Porl(d, X X1, X X31))
-*)
+ emit (Psrlil(GPR32, s, coqint_of_camlint 56l)); emit Psemi;
+ emit (Porl(d, GPR16, GPR32)); emit Psemi
(* Handling of compiler-inlined builtins *)
let last_system_register = 511l
@@ -465,18 +462,24 @@ let expand_builtin_inline name args res = let open Asmvliw in
emit (Pitouchl addr)
| "__builtin_k1_dzerol", [BA(IR addr)], _ ->
emit (Pdzerol addr)
- | "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) ->
+(*| "__builtin_k1_afaddd", [BA(IR addr); BA (IR incr_res)], BR(IR res) ->
(if res <> incr_res
- then (emit (Pmv(res, incr_res)); emit Psemi));
+ then (emit (Asm.Pmv(res, incr_res)); emit Psemi));
emit (Pafaddd(addr, res))
| "__builtin_k1_afaddw", [BA(IR addr); BA (IR incr_res)], BR(IR res) ->
(if res <> incr_res
- then (emit (Pmv(res, incr_res)); emit Psemi));
- emit (Pafaddw(addr, res))
+ then (emit (Asm.Pmv(res, incr_res)); emit Psemi));
+ emit (Pafaddw(addr, res)) *) (* see #157 *)
| "__builtin_alclrd", [BA(IR addr)], BR(IR res) ->
emit (Palclrd(res, addr))
| "__builtin_alclrw", [BA(IR addr)], BR(IR res) ->
emit (Palclrw(res, addr))
+ | "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
+ expand_bswap16 res a1
+ | ("__builtin_bswap"| "__builtin_bswap32"), [BA(IR a1)], BR(IR res) ->
+ expand_bswap32 res a1
+ | "__builtin_bswap64", [BA(IR src)], BR(IR res) ->
+ expand_bswap64 res src
(* Byte swaps *)
(*| "__builtin_bswap16", [BA(IR a1)], BR(IR res) ->
@@ -504,15 +507,15 @@ let expand_instruction instr =
expand_storeind_ptr Asmvliw.GPR17 stack_pointer ofs;
emit Psemi;
let va_ofs =
- sz in
- (*Z.add full_sz (Z.of_sint ((n - _nbregargs_) * wordsize)) in *)
+ let extra_ofs = if n <= _nbregargs_ then 0 else ((n - _nbregargs_) * wordsize) in
+ Z.add sz (Z.of_sint extra_ofs) in
vararg_start_ofs := Some va_ofs;
save_arguments n va_ofs
end else begin
let below = Integers.Ptrofs.repr (Z.neg sz) in
expand_addptrofs stack_pointer stack_pointer below;
+ emit Psemi; (* Psemi required to fit in resource constraints *)
expand_storeind_ptr stack_pointer stack_pointer (Integers.Ptrofs.add ofs below);
- (* DM we don't need it emit Psemi; *)
vararg_start_ofs := None
end
| Pfreeframe (sz, ofs) ->
diff --git a/mppa_k1c/Asmgen.v b/mppa_k1c/Asmgen.v
index 58e80be1..8875a4ac 100644
--- a/mppa_k1c/Asmgen.v
+++ b/mppa_k1c/Asmgen.v
@@ -18,15 +18,18 @@
Require Import Integers.
Require Import Mach Asm Asmblock Asmblockgen Machblockgen.
Require Import PostpassScheduling.
-Require Import Errors.
+Require Import Errors String.
+Require Compopts.
Local Open Scope error_monad_scope.
+Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := Compopts.time name f.
+
Definition transf_program (p: Mach.program) : res Asm.program :=
- let mbp := Machblockgen.transf_program p in
- do abp <- Asmblockgen.transf_program mbp;
- do abp' <- PostpassScheduling.transf_program abp;
- OK (Asm.transf_program abp').
+ let mbp := (time "Machblock generation" Machblockgen.transf_program) p in
+ do abp <- (time "Asmblock generation" Asmblockgen.transf_program) mbp;
+ do abp' <- (time "PostpassScheduling total oracle+verification" PostpassScheduling.transf_program) abp;
+ OK ((time "Asm generation" Asm.transf_program) abp').
Definition transf_function (f: Mach.function) : res Asm.function :=
let mbf := Machblockgen.transf_function f in
diff --git a/mppa_k1c/Asmgenproof.v b/mppa_k1c/Asmgenproof.v
index e7e21a18..7388f6da 100644
--- a/mppa_k1c/Asmgenproof.v
+++ b/mppa_k1c/Asmgenproof.v
@@ -10,7 +10,7 @@
(* *)
(* *********************************************************************)
-(** Correctness proof for RISC-V generation: main proof. *)
+(** Correctness proof for Asmgen *)
Require Import Coqlib Errors.
Require Import Integers Floats AST Linking.
@@ -35,7 +35,7 @@ Proof.
intros p tp H.
unfold Asmgen.transf_program in H. apply bind_inversion in H. destruct H.
inversion_clear H. apply bind_inversion in H1. destruct H1.
- inversion_clear H. inversion H2. remember (Machblockgen.transf_program p) as mbp.
+ inversion_clear H. inversion H2. unfold time, Compopts.time in *. remember (Machblockgen.transf_program p) as mbp.
unfold match_prog; simpl.
exists mbp; split. apply Machblockgenproof.transf_program_match; auto.
exists x; split. apply Asmblockgenproof.transf_program_match; auto.
@@ -89,4 +89,4 @@ Module Asmgenproof0.
Definition return_address_offset := return_address_offset.
-End Asmgenproof0. \ No newline at end of file
+End Asmgenproof0.
diff --git a/mppa_k1c/Asmvliw.v b/mppa_k1c/Asmvliw.v
index 3bef1a5c..946007c1 100644
--- a/mppa_k1c/Asmvliw.v
+++ b/mppa_k1c/Asmvliw.v
@@ -17,8 +17,6 @@
(** Abstract syntax and semantics for VLIW semantics of K1c assembly language. *)
-(* FIXME: develop/fix the comments in this file *)
-
Require Import Coqlib.
Require Import Maps.
Require Import AST.
@@ -45,8 +43,7 @@ Require Import Chunks.
this view induces our sequential semantics of bundles defined in [Asmblock].
*)
-(** General Purpose registers.
-*)
+(** General Purpose registers. *)
Inductive gpreg: Type :=
| GPR0: gpreg | GPR1: gpreg | GPR2: gpreg | GPR3: gpreg | GPR4: gpreg
@@ -148,13 +145,10 @@ Definition gpreg_o_expand (x : gpreg_o) : gpreg * gpreg * gpreg * gpreg :=
| R56R57R58R59 => (GPR56, GPR57, GPR58, GPR59)
| R60R61R62R63 => (GPR60, GPR61, GPR62, GPR63)
end.
-
+
Lemma gpreg_o_eq : forall (x y : gpreg_o), {x=y} + {x<>y}.
Proof. decide equality. Defined.
-(** We model the following registers of the RISC-V architecture. *)
-
-(** basic register *)
Inductive preg: Type :=
| IR: gpreg -> preg (**r integer general purpose registers *)
| RA: preg
@@ -173,7 +167,7 @@ End PregEq.
Module Pregmap := EMap(PregEq).
-(** Conventional names for stack pointer ([SP]) and return address ([RA]). *)
+(** Conventional names for stack pointer ([SP]), return address ([RA]), frame pointer ([FP]) and other temporaries used *)
Notation "'SP'" := GPR12 (only parsing) : asm.
Notation "'FP'" := GPR17 (only parsing) : asm.
@@ -188,9 +182,7 @@ Inductive btest: Type :=
| BTdgez (**r Double Greater Than or Equal to Zero *)
| BTdlez (**r Double Less Than or Equal to Zero *)
| BTdgtz (**r Double Greater Than Zero *)
-(*| BTodd (**r Odd (LSB Set) *)
- | BTeven (**r Even (LSB Clear) *)
-*)| BTwnez (**r Word Not Equal to Zero *)
+ | BTwnez (**r Word Not Equal to Zero *)
| BTweqz (**r Word Equal to Zero *)
| BTwltz (**r Word Less Than Zero *)
| BTwgez (**r Word Greater Than or Equal to Zero *)
@@ -211,11 +203,6 @@ Inductive itest: Type :=
| ITgeu (**r Greater Than or Equal Unsigned *)
| ITleu (**r Less Than or Equal Unsigned *)
| ITgtu (**r Greater Than Unsigned *)
- (* Not used yet *)
- | ITall (**r All Bits Set in Mask *)
- | ITnall (**r Not All Bits Set in Mask *)
- | ITany (**r Any Bits Set in Mask *)
- | ITnone (**r Not Any Bits Set in Mask *)
.
Inductive ftest: Type :=
@@ -251,16 +238,7 @@ Definition offset : Type := ptrofs.
Definition label := positive.
-(* FIXME - rewrite the comment *)
-(** A note on immediates: there are various constraints on immediate
- operands to K1c instructions. We do not attempt to capture these
- restrictions in the abstract syntax nor in the semantics. The
- assembler will emit an error if immediate operands exceed the
- representable range. Of course, our K1c generator (file
- [Asmgen]) is careful to respect this range. *)
-
-(** Instructions to be expanded in control-flow
-*)
+(** Instructions to be expanded in control-flow *)
Inductive ex_instruction : Type :=
(* Pseudo-instructions *)
| Pbuiltin: external_function -> list (builtin_arg preg)
@@ -330,6 +308,16 @@ Inductive cf_instruction : Type :=
.
(** Loads **)
+Definition concrete_default_notrap_load_value (chunk : memory_chunk) :=
+ match chunk with
+ | Mint8signed | Mint8unsigned | Mint16signed | Mint16unsigned
+ | Mint32 => Vint Int.zero
+ | Mint64 => Vlong Int64.zero
+ | Many32 | Many64 => Vundef
+ | Mfloat32 => Vsingle Float32.zero
+ | Mfloat64 => Vfloat Float.zero
+ end.
+
Inductive load_name : Type :=
| Plb (**r load byte *)
| Plbu (**r load byte unsigned *)
@@ -344,9 +332,9 @@ Inductive load_name : Type :=
.
Inductive ld_instruction : Type :=
- | PLoadRRO (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset)
- | PLoadRRR (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg)
- | PLoadRRRXS (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg)
+ | PLoadRRO (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (ofs: offset)
+ | PLoadRRR (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg)
+ | PLoadRRRXS (trap: trapping_mode) (i: load_name) (rd: ireg) (ra: ireg) (rofs: ireg)
| PLoadQRRO (rd: gpreg_q) (ra: ireg) (ofs: offset)
| PLoadORRO (rd: gpreg_o) (ra: ireg) (ofs: offset)
.
@@ -392,6 +380,7 @@ Inductive arith_name_rr : Type :=
| Pfabsw (**r float absolute word *)
| Pfnegd (**r float negate double *)
| Pfnegw (**r float negate word *)
+ | Pfinvw (**r float invert word *)
| Pfnarrowdw (**r float narrow 64 -> 32 bits *)
| Pfwidenlwd (**r Floating Point widen from 32 bits to 64 bits *)
| Pfloatwrnsz (**r Floating Point conversion from integer (int -> SINGLE) *)
@@ -429,7 +418,9 @@ Inductive arith_name_rrr : Type :=
| Pfcompl (ft: ftest) (**r comparison float64 *)
| Paddw (**r add word *)
- | Psubw (**r sub word *)
+ | Paddxw (shift : shift1_4) (**r add shift *)
+ | Psubw (**r sub word word *)
+ | Prevsubxw (shift : shift1_4) (**r sub shift word *)
| Pmulw (**r mul word *)
| Pandw (**r and word *)
| Pnandw (**r nand word *)
@@ -445,7 +436,9 @@ Inductive arith_name_rrr : Type :=
| Psllw (**r shift left logical word *)
| Paddl (**r add long *)
+ | Paddxl (shift : shift1_4) (**r add shift long *)
| Psubl (**r sub long *)
+ | Prevsubxl (shift : shift1_4) (**r sub shift long *)
| Pandl (**r and long *)
| Pnandl (**r nand long *)
| Porl (**r or long *)
@@ -466,12 +459,19 @@ Inductive arith_name_rrr : Type :=
| Pfsbfw (**r float sub word *)
| Pfmuld (**r float multiply double *)
| Pfmulw (**r float multiply word *)
+ | Pfmind (**r float min double *)
+ | Pfminw (**r float min word *)
+ | Pfmaxd (**r float max double *)
+ | Pfmaxw (**r float max word *)
.
Inductive arith_name_rri32 : Type :=
| Pcompiw (it: itest) (**r comparison imm word *)
| Paddiw (**r add imm word *)
+ | Paddxiw (shift : shift1_4)
+ | Prevsubiw (**r add imm word *)
+ | Prevsubxiw (shift : shift1_4)
| Pmuliw (**r add imm word *)
| Pandiw (**r and imm word *)
| Pnandiw (**r nand imm word *)
@@ -495,6 +495,9 @@ Inductive arith_name_rri32 : Type :=
Inductive arith_name_rri64 : Type :=
| Pcompil (it: itest) (**r comparison imm long *)
| Paddil (**r add immediate long *)
+ | Paddxil (shift : shift1_4)
+ | Prevsubil
+ | Prevsubxil (shift : shift1_4)
| Pmulil (**r mul immediate long *)
| Pandil (**r and immediate long *)
| Pnandil (**r nand immediate long *)
@@ -509,16 +512,26 @@ Inductive arith_name_rri64 : Type :=
Inductive arith_name_arrr : Type :=
| Pmaddw (**r multiply add word *)
| Pmaddl (**r multiply add long *)
+ | Pmsubw (**r multiply subtract word *)
+ | Pmsubl (**r multiply subtract long *)
| Pcmove (bt: btest) (**r conditional move *)
| Pcmoveu (bt: btest) (**r conditional move, test on unsigned semantics *)
+ | Pfmaddfw (**r float fused multiply add word *)
+ | Pfmaddfl (**r float fused multiply add long *)
+ | Pfmsubfw (**r float fused multiply subtract word *)
+ | Pfmsubfl (**r float fused multiply subtract long *)
.
Inductive arith_name_arri32 : Type :=
| Pmaddiw (**r multiply add word *)
+ | Pcmoveiw (bt: btest)
+ | Pcmoveuiw (bt: btest)
.
Inductive arith_name_arri64 : Type :=
| Pmaddil (**r multiply add long *)
+ | Pcmoveil (bt: btest)
+ | Pcmoveuil (bt: btest)
.
Inductive arith_name_arr : Type :=
@@ -542,6 +555,8 @@ Inductive ar_instruction : Type :=
| PArithARRI64 (i: arith_name_arri64) (rd rs: ireg) (imm: int64)
.
+Module PArithCoercions.
+
Coercion PArithR: arith_name_r >-> Funclass.
Coercion PArithRR: arith_name_rr >-> Funclass.
Coercion PArithRI32: arith_name_ri32 >-> Funclass.
@@ -556,6 +571,8 @@ Coercion PArithARR: arith_name_arr >-> Funclass.
Coercion PArithARRI32: arith_name_arri32 >-> Funclass.
Coercion PArithARRI64: arith_name_arri64 >-> Funclass.
+End PArithCoercions.
+
Inductive basic : Type :=
| PArith (i: ar_instruction)
| PLoad (i: ld_instruction)
@@ -901,10 +918,6 @@ Definition compare_int (t: itest) (v1 v2: val): val :=
| ITgeu => Val_cmpu Cge v1 v2
| ITleu => Val_cmpu Cle v1 v2
| ITgtu => Val_cmpu Cgt v1 v2
- | ITall
- | ITnall
- | ITany
- | ITnone => Vundef
end.
Definition compare_long (t: itest) (v1 v2: val): val :=
@@ -921,10 +934,6 @@ Definition compare_long (t: itest) (v1 v2: val): val :=
| ITgeu => Some (Val_cmplu Cge v1 v2)
| ITleu => Some (Val_cmplu Cle v1 v2)
| ITgtu => Some (Val_cmplu Cgt v1 v2)
- | ITall
- | ITnall
- | ITany
- | ITnone => Some Vundef
end in
match res with
| Some v => v
@@ -976,6 +985,7 @@ Definition arith_eval_rr n v :=
| Pfnegw => Val.negfs v
| Pfabsd => Val.absf v
| Pfabsw => Val.absfs v
+ | Pfinvw => ExtValues.invfs v
| Pfnarrowdw => Val.singleoffloat v
| Pfwidenlwd => Val.floatofsingle v
| Pfloatwrnsz => match Val.singleofint v with Some f => f | _ => Vundef end
@@ -1055,12 +1065,24 @@ Definition arith_eval_rrr n v1 v2 :=
| Pfsbfw => Val.subfs v1 v2
| Pfmuld => Val.mulf v1 v2
| Pfmulw => Val.mulfs v1 v2
+
+ | Pfmind => ExtValues.minf v1 v2
+ | Pfminw => ExtValues.minfs v1 v2
+ | Pfmaxd => ExtValues.maxf v1 v2
+ | Pfmaxw => ExtValues.maxfs v1 v2
+
+ | Paddxw shift => ExtValues.addx (int_of_shift1_4 shift) v1 v2
+ | Paddxl shift => ExtValues.addxl (int_of_shift1_4 shift) v1 v2
+
+ | Prevsubxw shift => ExtValues.revsubx (int_of_shift1_4 shift) v1 v2
+ | Prevsubxl shift => ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2
end.
Definition arith_eval_rri32 n v i :=
match n with
| Pcompiw c => compare_int c v (Vint i)
| Paddiw => Val.add v (Vint i)
+ | Prevsubiw => Val.sub (Vint i) v
| Pmuliw => Val.mul v (Vint i)
| Pandiw => Val.and v (Vint i)
| Pnandiw => Val.notint (Val.and v (Vint i))
@@ -1079,12 +1101,15 @@ Definition arith_eval_rri32 n v i :=
| Psrxil => ExtValues.val_shrxl v (Vint i)
| Psrlil => Val.shrlu v (Vint i)
| Psrail => Val.shrl v (Vint i)
+ | Paddxiw shift => ExtValues.addx (int_of_shift1_4 shift) v (Vint i)
+ | Prevsubxiw shift => ExtValues.revsubx (int_of_shift1_4 shift) v (Vint i)
end.
Definition arith_eval_rri64 n v i :=
match n with
| Pcompil c => compare_long c v (Vlong i)
| Paddil => Val.addl v (Vlong i)
+ | Prevsubil => Val.subl (Vlong i) v
| Pmulil => Val.mull v (Vlong i)
| Pandil => Val.andl v (Vlong i)
| Pnandil => Val.notl (Val.andl v (Vlong i))
@@ -1094,44 +1119,56 @@ Definition arith_eval_rri64 n v i :=
| Pnxoril => Val.notl (Val.xorl v (Vlong i))
| Pandnil => Val.andl (Val.notl v) (Vlong i)
| Pornil => Val.orl (Val.notl v) (Vlong i)
+ | Paddxil shift => ExtValues.addxl (int_of_shift1_4 shift) v (Vlong i)
+ | Prevsubxil shift => ExtValues.revsubxl (int_of_shift1_4 shift) v (Vlong i)
+ end.
+
+Definition cmove bt v1 v2 v3 :=
+ match cmp_for_btest bt with
+ | (Some c, Int) =>
+ match Val.cmp_bool c v2 (Vint Int.zero) with
+ | None => Vundef
+ | Some true => v3
+ | Some false => v1
+ end
+ | (Some c, Long) =>
+ match Val.cmpl_bool c v2 (Vlong Int64.zero) with
+ | None => Vundef
+ | Some true => v3
+ | Some false => v1
+ end
+ | (None, _) => Vundef
+ end.
+
+Definition cmoveu bt v1 v2 v3 :=
+ match cmpu_for_btest bt with
+ | (Some c, Int) =>
+ match Val_cmpu_bool c v2 (Vint Int.zero) with
+ | None => Vundef
+ | Some true => v3
+ | Some false => v1
+ end
+ | (Some c, Long) =>
+ match Val_cmplu_bool c v2 (Vlong Int64.zero) with
+ | None => Vundef
+ | Some true => v3
+ | Some false => v1
+ end
+ | (None, _) => Vundef
end.
Definition arith_eval_arrr n v1 v2 v3 :=
match n with
| Pmaddw => Val.add v1 (Val.mul v2 v3)
| Pmaddl => Val.addl v1 (Val.mull v2 v3)
- | Pcmove bt =>
- match cmp_for_btest bt with
- | (Some c, Int) =>
- match Val.cmp_bool c v2 (Vint Int.zero) with
- | None => Vundef
- | Some true => v3
- | Some false => v1
- end
- | (Some c, Long) =>
- match Val.cmpl_bool c v2 (Vlong Int64.zero) with
- | None => Vundef
- | Some true => v3
- | Some false => v1
- end
- | (None, _) => Vundef
- end
- | Pcmoveu bt =>
- match cmpu_for_btest bt with
- | (Some c, Int) =>
- match Val_cmpu_bool c v2 (Vint Int.zero) with
- | None => Vundef
- | Some true => v3
- | Some false => v1
- end
- | (Some c, Long) =>
- match Val_cmplu_bool c v2 (Vlong Int64.zero) with
- | None => Vundef
- | Some true => v3
- | Some false => v1
- end
- | (None, _) => Vundef
- end
+ | Pmsubw => Val.sub v1 (Val.mul v2 v3)
+ | Pmsubl => Val.subl v1 (Val.mull v2 v3)
+ | Pcmove bt => cmove bt v1 v2 v3
+ | Pcmoveu bt => cmoveu bt v1 v2 v3
+ | Pfmaddfw => ExtValues.fmaddfs v1 v2 v3
+ | Pfmaddfl => ExtValues.fmaddf v1 v2 v3
+ | Pfmsubfw => ExtValues.fmsubfs v1 v2 v3
+ | Pfmsubfl => ExtValues.fmsubf v1 v2 v3
end.
Definition arith_eval_arr n v1 v2 :=
@@ -1143,11 +1180,15 @@ Definition arith_eval_arr n v1 v2 :=
Definition arith_eval_arri32 n v1 v2 v3 :=
match n with
| Pmaddiw => Val.add v1 (Val.mul v2 (Vint v3))
+ | Pcmoveiw bt => cmove bt v1 v2 (Vint v3)
+ | Pcmoveuiw bt => cmoveu bt v1 v2 (Vint v3)
end.
Definition arith_eval_arri64 n v1 v2 v3 :=
match n with
| Pmaddil => Val.addl v1 (Val.mull v2 (Vlong v3))
+ | Pcmoveil bt => cmove bt v1 v2 (Vlong v3)
+ | Pcmoveuil bt => cmoveu bt v1 v2 (Vlong v3)
end.
Definition parexec_arith_instr (ai: ar_instruction) (rsr rsw: regset): regset :=
@@ -1175,10 +1216,16 @@ Definition eval_offset (ofs: offset) : res ptrofs := OK ofs.
(** * load/store *)
-Definition parexec_load_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) :=
+Definition parexec_incorrect_load trap chunk d rsw mw :=
+ match trap with
+ | TRAP => Stuck
+ | NOTRAP => Next (rsw#d <- (concrete_default_notrap_load_value chunk)) mw
+ end.
+
+Definition parexec_load_offset (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a: ireg) (ofs: offset) :=
match (eval_offset ofs) with
| OK ptr => match Mem.loadv chunk mr (Val.offset_ptr (rsr a) ptr) with
- | None => Stuck
+ | None => parexec_incorrect_load trap chunk d rsw mw
| Some v => Next (rsw#d <- v) mw
end
| _ => Stuck
@@ -1223,15 +1270,15 @@ Definition parexec_load_o_offset (rsr rsw: regset) (mr mw: mem) (d : gpreg_o) (a
end
end.
-Definition parexec_load_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) :=
+Definition parexec_load_reg (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) :=
match Mem.loadv chunk mr (Val.addl (rsr a) (rsr ro)) with
- | None => Stuck
+ | None => parexec_incorrect_load trap chunk d rsw mw
| Some v => Next (rsw#d <- v) mw
end.
-Definition parexec_load_regxs (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) :=
+Definition parexec_load_regxs (trap: trapping_mode) (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (d a ro: ireg) :=
match Mem.loadv chunk mr (Val.addl (rsr a) (Val.shll (rsr ro) (scale_of_chunk chunk))) with
- | None => Stuck
+ | None => parexec_incorrect_load trap chunk d rsw mw
| Some v => Next (rsw#d <- v) mw
end.
@@ -1244,7 +1291,8 @@ Definition parexec_store_offset (chunk: memory_chunk) (rsr rsw: regset) (mr mw:
| _ => Stuck
end.
-Definition parexec_store_reg (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) :=
+Definition parexec_store_reg
+ (chunk: memory_chunk) (rsr rsw: regset) (mr mw: mem) (s a ro: ireg) :=
match Mem.storev chunk mr (Val.addl (rsr a) (rsr ro)) (rsr s) with
| None => Stuck
| Some m' => Next rsw m'
@@ -1302,7 +1350,7 @@ Definition load_chunk n :=
| Pfls => Mfloat32
| Pfld => Mfloat64
end.
-
+
Definition store_chunk n :=
match n with
| Psb => Mint8unsigned
@@ -1317,16 +1365,16 @@ Definition store_chunk n :=
(** * basic instructions *)
-Definition parexec_basic_instr (bi: basic) (rsr rsw: regset) (mr mw: mem) :=
+Definition bstep (bi: basic) (rsr rsw: regset) (mr mw: mem) :=
match bi with
| PArith ai => Next (parexec_arith_instr ai rsr rsw) mw
- | PLoadRRO n d a ofs => parexec_load_offset (load_chunk n) rsr rsw mr mw d a ofs
- | PLoadRRR n d a ro => parexec_load_reg (load_chunk n) rsr rsw mr mw d a ro
- | PLoadRRRXS n d a ro => parexec_load_regxs (load_chunk n) rsr rsw mr mw d a ro
- | PLoadQRRO d a ofs =>
+ | PLoad (PLoadRRO trap n d a ofs) => parexec_load_offset trap (load_chunk n) rsr rsw mr mw d a ofs
+ | PLoad (PLoadRRR trap n d a ro) => parexec_load_reg trap (load_chunk n) rsr rsw mr mw d a ro
+ | PLoad (PLoadRRRXS trap n d a ro) => parexec_load_regxs trap (load_chunk n) rsr rsw mr mw d a ro
+ | PLoad (PLoadQRRO d a ofs) =>
parexec_load_q_offset rsr rsw mr mw d a ofs
- | PLoadORRO d a ofs =>
+ | PLoad (PLoadORRO d a ofs) =>
parexec_load_o_offset rsr rsw mr mw d a ofs
| PStoreRRO n s a ofs => parexec_store_offset (store_chunk n) rsr rsw mr mw s a ofs
@@ -1376,7 +1424,7 @@ Fixpoint parexec_wio_body (body: list basic) (rsr rsw: regset) (mr mw: mem) :=
match body with
| nil => Next rsw mw
| bi::body' =>
- match parexec_basic_instr bi rsr rsw mr mw with
+ match bstep bi rsr rsw mr mw with
| Next rsw mw => parexec_wio_body body' rsr rsw mr mw
| Stuck => Stuck
end
@@ -1512,19 +1560,19 @@ Definition incrPC size_b (rs: regset) :=
rs#PC <- (Val.offset_ptr rs#PC size_b).
(** parallel execution of the exit instruction of a bundle *)
-Definition parexec_exit (f: function) ext size_b (rsr rsw: regset) (mw: mem)
+Definition estep (f: function) ext size_b (rsr rsw: regset) (mw: mem)
:= parexec_control f ext (incrPC size_b rsr) rsw mw.
-Definition parexec_wio_bblock_aux f bdy ext size_b (rsr rsw: regset) (mr mw: mem): outcome :=
- match parexec_wio_body bdy rsr rsw mr mw with
- | Next rsw mw => parexec_exit f ext size_b rsr rsw mw
+Definition parexec_wio f bdy ext size_b (rs: regset) (m: mem): outcome :=
+ match parexec_wio_body bdy rs rs m m with
+ | Next rsw mw => estep f ext size_b rs rsw mw
| Stuck => Stuck
end.
(** non-deterministic (out-of-order writes) parallel execution of bundles *)
Definition parexec_bblock (f: function) (bundle: bblock) (rs: regset) (m: mem) (o: outcome): Prop :=
exists bdy1 bdy2, Permutation (bdy1++bdy2) (body bundle) /\
- o=match parexec_wio_bblock_aux f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs rs m m with
+ o=match parexec_wio f bdy1 (exit bundle) (Ptrofs.repr (size bundle)) rs m with
| Next rsw mw => parexec_wio_body bdy2 rs rsw m mw
| Stuck => Stuck
end.
@@ -1651,7 +1699,7 @@ Inductive step: state -> trace -> state -> Prop :=
(** parallel in-order writes execution of bundles *)
Definition parexec_wio_bblock (f: function) (b: bblock) (rs: regset) (m: mem): outcome :=
- parexec_wio_bblock_aux f (body b) (exit b) (Ptrofs.repr (size b)) rs rs m m.
+ parexec_wio f (body b) (exit b) (Ptrofs.repr (size b)) rs m.
Lemma parexec_bblock_write_in_order f b rs m:
@@ -1661,11 +1709,11 @@ Proof.
constructor 1.
- rewrite app_nil_r; auto.
- unfold parexec_wio_bblock.
- destruct (parexec_wio_bblock_aux f _ _ _ _ _); simpl; auto.
+ destruct (parexec_wio f _ _ _); simpl; auto.
Qed.
-Local Hint Resolve parexec_bblock_write_in_order.
+Local Hint Resolve parexec_bblock_write_in_order: core.
Lemma det_parexec_write_in_order f b rs m rs' m':
det_parexec f b rs m rs' m' -> parexec_wio_bblock f b rs m = Next rs' m'.
@@ -1739,9 +1787,9 @@ Ltac Det_WIO X :=
- (* determ *) intros s t1 s1 t2 s2 H H0. inv H; Det_WIO X1;
inv H0; Det_WIO X2; Equalities.
+ split. constructor. auto.
- + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate.
+ + unfold parexec_wio_bblock, parexec_wio in X1. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate.
rewrite H8 in X1. discriminate.
- + unfold parexec_wio_bblock, parexec_wio_bblock_aux in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate.
+ + unfold parexec_wio_bblock, parexec_wio in X2. destruct (parexec_wio_body _ _ _ _ _ _); try discriminate.
rewrite H4 in X2. discriminate.
+ assert (vargs0 = vargs) by (eapply eval_builtin_args_determ; eauto). subst vargs0.
exploit external_call_determ. eexact H6. eexact H13. intros [A B].
diff --git a/mppa_k1c/Builtins1.v b/mppa_k1c/Builtins1.v
new file mode 100644
index 00000000..3b5cd419
--- /dev/null
+++ b/mppa_k1c/Builtins1.v
@@ -0,0 +1,66 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Platform-specific built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values ExtFloats.
+Require Import Builtins0.
+
+Inductive platform_builtin : Type :=
+| BI_fmin
+| BI_fmax
+| BI_fminf
+| BI_fmaxf
+| BI_fabsf
+| BI_fma
+| BI_fmaf.
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ ("__builtin_fmin", BI_fmin)
+ :: ("__builtin_fmax", BI_fmax)
+ :: ("__builtin_fminf", BI_fminf)
+ :: ("__builtin_fmaxf", BI_fmaxf)
+ :: ("__builtin_fabsf", BI_fabsf)
+ :: ("__builtin_fma", BI_fma)
+ :: ("__builtin_fmaf", BI_fmaf)
+ :: nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with
+ | BI_fmin | BI_fmax =>
+ mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default
+ | BI_fminf | BI_fmaxf =>
+ mksignature (Tsingle :: Tsingle :: nil) Tsingle cc_default
+ | BI_fabsf =>
+ mksignature (Tsingle :: nil) Tsingle cc_default
+ | BI_fma =>
+ mksignature (Tfloat :: Tfloat :: Tfloat :: nil) Tfloat cc_default
+ | BI_fmaf =>
+ mksignature (Tsingle :: Tsingle :: Tsingle :: nil) Tsingle cc_default
+ end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with
+ | BI_fmin => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.min
+ | BI_fmax => mkbuiltin_n2t Tfloat Tfloat Tfloat ExtFloat.max
+ | BI_fminf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.min
+ | BI_fmaxf => mkbuiltin_n2t Tsingle Tsingle Tsingle ExtFloat32.max
+ | BI_fabsf => mkbuiltin_n1t Tsingle Tsingle Float32.abs
+ | BI_fma => mkbuiltin_n3t Tfloat Tfloat Tfloat Tfloat Float.fma
+ | BI_fmaf => mkbuiltin_n3t Tsingle Tsingle Tsingle Tsingle Float32.fma
+ end.
diff --git a/mppa_k1c/CBuiltins.ml b/mppa_k1c/CBuiltins.ml
index 2f80c90f..a91119b1 100644
--- a/mppa_k1c/CBuiltins.ml
+++ b/mppa_k1c/CBuiltins.ml
@@ -18,11 +18,11 @@
open C
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list", TPtr(TVoid [], [])
];
(* The builtin list is inspired from the GCC file builtin_k1.h *)
- Builtins.functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *)
+ builtin_functions = [ (* Some builtins are commented out because their opcode is not present (yet?) *)
(* BCU Instructions *)
"__builtin_k1_await", (TVoid [], [], false); (* DONE *)
"__builtin_k1_barrier", (TVoid [], [], false); (* DONE *)
@@ -43,8 +43,8 @@ let builtins = {
(* LSU Instructions *)
(* acswapd and acswapw done using headers and assembly *)
- "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false);
- "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false);
+(* "__builtin_k1_afaddd", (TInt(IULongLong, []), [TPtr(TVoid [], []); TInt(ILongLong, [])], false);
+ "__builtin_k1_afaddw", (TInt(IUInt, []), [TPtr(TVoid [], []); TInt(IInt, [])], false); *) (* see #157 *)
"__builtin_k1_alclrd", (TInt(IULongLong, []), [TPtr(TVoid [], [])], false); (* DONE *)
"__builtin_k1_alclrw", (TInt(IUInt, []), [TPtr(TVoid [], [])], false); (* DONE *)
"__builtin_k1_dinval", (TVoid [], [], false); (* DONE *)
@@ -63,7 +63,6 @@ let builtins = {
"__builtin_k1_lwzu", (TInt(IUInt, []), [TPtr(TVoid [], [])], false);
(* ALU Instructions *)
- "__builtin_clzll", (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
(* "__builtin_k1_addhp", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *)
(* "__builtin_k1_adds", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false); *)
(* "__builtin_k1_bwlu", (TInt(IUInt, []),
@@ -74,8 +73,8 @@ let builtins = {
(* "__builtin_k1_cbs", (TInt(IInt, []), [TInt(IUInt, [])], false); *)
(* "__builtin_k1_cbsdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *)
(* "__builtin_k1_clz", (TInt(IInt, []), [TInt(IUInt, [])], false); *)
- "__builtin_k1_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false);
- "__builtin_k1_clzd", (TInt(ILongLong, []), [TInt(IULongLong, [])], false);
+ "__builtin_clzw", (TInt(IInt, []), [TInt(IUInt, [])], false);
+ "__builtin_clzll", (TInt(ILongLong, []), [TInt(IULongLong, [])], false);
(* "__builtin_k1_clzdl", (TInt(ILongLong, []), [TInt(IULongLong, [])], false); *)
(* "__builtin_k1_cmove", (TInt(IInt, []), [TInt(IInt, []); TInt(IInt, []); TInt(IInt, [])], false); *)
(* "__builtin_k1_ctz", (TInt(IInt, []), [TInt(IUInt, [])], false); *)
@@ -97,12 +96,8 @@ let builtins = {
(* Synchronization *)
(* "__builtin_fence",
- (TVoid [], [], false);
- (* Integer arithmetic *)
- "__builtin_bswap64",
- (TInt(IULongLong, []),
- [TInt(IULongLong, [])], false);
- (* Float arithmetic *)
+ (TVoid [], [], false); *)
+(* (* Float arithmetic *)
"__builtin_fmadd",
(TFloat(FDouble, []),
[TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false);
@@ -114,14 +109,29 @@ let builtins = {
[TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false);
"__builtin_fnmsub",
(TFloat(FDouble, []),
- [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false); *)
+ "__builtin_fabsf",
+ (TFloat(FFloat, []),
+ [TFloat(FFloat, [])], false);
"__builtin_fmax",
(TFloat(FDouble, []),
[TFloat(FDouble, []); TFloat(FDouble, [])], false);
"__builtin_fmin",
(TFloat(FDouble, []),
[TFloat(FDouble, []); TFloat(FDouble, [])], false);
-*)]
+ "__builtin_fmaxf",
+ (TFloat(FFloat, []),
+ [TFloat(FFloat, []); TFloat(FFloat, [])], false);
+ "__builtin_fminf",
+ (TFloat(FFloat, []),
+ [TFloat(FFloat, []); TFloat(FFloat, [])], false);
+ "__builtin_fma",
+ (TFloat(FDouble, []),
+ [TFloat(FDouble, []); TFloat(FDouble, []); TFloat(FDouble, [])], false);
+ "__builtin_fmaf",
+ (TFloat(FFloat, []),
+ [TFloat(FFloat, []); TFloat(FFloat, []); TFloat(FFloat, [])], false);
+]
}
let va_list_type = TPtr(TVoid [], []) (* to check! *)
diff --git a/mppa_k1c/CSE2deps.v b/mppa_k1c/CSE2deps.v
new file mode 100644
index 00000000..8ab9242a
--- /dev/null
+++ b/mppa_k1c/CSE2deps.v
@@ -0,0 +1,20 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk)
+ else true | _, _, _, _ => true
+ end.
diff --git a/mppa_k1c/CSE2depsproof.v b/mppa_k1c/CSE2depsproof.v
new file mode 100644
index 00000000..a3811e78
--- /dev/null
+++ b/mppa_k1c/CSE2depsproof.v
@@ -0,0 +1,127 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Lemma ptrofs_size :
+ Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat.
+Proof.
+ unfold Ptrofs.wordsize.
+ unfold Wordsize_Ptrofs.wordsize.
+ trivial.
+Qed.
+
+Lemma ptrofs_modulus :
+ Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296.
+Proof.
+ unfold Ptrofs.modulus.
+ rewrite ptrofs_size.
+ destruct Archi.ptr64; reflexivity.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : ptrofs.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr
+ \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in *.
+
+ rewrite ptrofs_modulus in *.
+ simpl in *.
+ inv ADDRR.
+ inv ADDRW.
+ destruct base; try discriminate.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW];
+ rewrite OFSW).
+ all: try rewrite ptrofs_modulus in *.
+ all: destruct Archi.ptr64.
+
+ all: intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/mppa_k1c/ConstpropOp.vp b/mppa_k1c/ConstpropOp.vp
index b5128357..7ee3dfe8 100644
--- a/mppa_k1c/ConstpropOp.vp
+++ b/mppa_k1c/ConstpropOp.vp
@@ -298,7 +298,7 @@ Nondetfunction addr_strength_reduction
(addr: addressing) (args: list reg) (vl: list aval) :=
match addr, args, vl with
| Aindexed n, r1 :: nil, Ptr(Gl symb n1) :: nil =>
- if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp tt)))
+ if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt)))
then (addr, args)
else (Aglobal symb (Ptrofs.add n1 n), nil)
| Aindexed n, r1 :: nil, Ptr(Stk n1) :: nil =>
diff --git a/mppa_k1c/Conventions1.v b/mppa_k1c/Conventions1.v
index d41f1095..48346a6d 100644
--- a/mppa_k1c/Conventions1.v
+++ b/mppa_k1c/Conventions1.v
@@ -90,12 +90,17 @@ Definition is_float_reg (r: mreg) := false.
returned value. We treat a function without result as a function
with one integer result. *)
+
Definition loc_result (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One R0
- | Some (Tint | Tany32) => One R0
- | Some (Tfloat | Tsingle | Tany64) => One R0
- | Some Tlong => if Archi.ptr64 then One R0 else One R0
+ match s.(sig_res) with
+ | Tvoid => One R0
+ | Tint8signed => One R0
+ | Tint8unsigned => One R0
+ | Tint16signed => One R0
+ | Tint16unsigned => One R0
+ | Tint | Tany32 => One R0
+ | Tfloat | Tsingle | Tany64 => One R0
+ | Tlong => if Archi.ptr64 then One R0 else One R0
end.
(** The result registers have types compatible with that given in the signature. *)
@@ -104,8 +109,8 @@ Lemma loc_result_type:
forall sig,
subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
Proof.
- intros. unfold proj_sig_res, loc_result, mreg_type;
- destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto.
+ intros. unfold proj_sig_res, loc_result, mreg_type.
+ destruct (sig_res sig); try destruct Archi.ptr64; simpl; trivial; destruct t; trivial.
Qed.
(** The result locations are caller-save registers *)
@@ -115,7 +120,7 @@ Lemma loc_result_caller_save:
forall_rpair (fun r => is_callee_save r = false) (loc_result s).
Proof.
intros. unfold loc_result, is_callee_save;
- destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto.
+ destruct (sig_res s); simpl; auto; try destruct Archi.ptr64; simpl; auto; try destruct t; simpl; auto.
Qed.
(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
@@ -125,14 +130,15 @@ Lemma loc_result_pair:
match loc_result sg with
| One _ => True
| Twolong r1 r2 =>
- r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ r1 <> r2 /\ proj_sig_res sg = Tlong
/\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
/\ Archi.ptr64 = false
end.
Proof.
intros.
- unfold loc_result; destruct (sig_res sg) as [[]|]; auto.
- unfold mreg_type; destruct Archi.ptr64; auto.
+ unfold loc_result; destruct (sig_res sg); auto;
+ unfold mreg_type; try destruct Archi.ptr64; auto;
+ destruct t; auto.
Qed.
(** The location of the result depends only on the result part of the signature *)
@@ -409,3 +415,6 @@ Lemma loc_arguments_main:
Proof.
reflexivity.
Qed.
+
+
+Definition return_value_needs_normalization (t: rettype) : bool := false.
diff --git a/mppa_k1c/DuplicateOpcodeHeuristic.ml b/mppa_k1c/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..2ec314c1
--- /dev/null
+++ b/mppa_k1c/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,27 @@
+(* open Camlcoq *)
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c | Ccompfs c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c | Cnotcompfs c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
diff --git a/mppa_k1c/ExtFloats.v b/mppa_k1c/ExtFloats.v
new file mode 100644
index 00000000..d9b9d3a6
--- /dev/null
+++ b/mppa_k1c/ExtFloats.v
@@ -0,0 +1,39 @@
+Require Import Floats Integers ZArith.
+
+Module ExtFloat.
+(** TODO check with the actual K1c;
+ this is what happens on x86 and may be inappropriate. *)
+
+Definition min (x : float) (y : float) : float :=
+ match Float.compare x y with
+ | Some Eq | Some Lt => x
+ | Some Gt | None => y
+ end.
+
+Definition max (x : float) (y : float) : float :=
+ match Float.compare x y with
+ | Some Eq | Some Gt => x
+ | Some Lt | None => y
+ end.
+End ExtFloat.
+
+Module ExtFloat32.
+(** TODO check with the actual K1c *)
+
+Definition min (x : float32) (y : float32) : float32 :=
+ match Float32.compare x y with
+ | Some Eq | Some Lt => x
+ | Some Gt | None => y
+ end.
+
+Definition max (x : float32) (y : float32) : float32 :=
+ match Float32.compare x y with
+ | Some Eq | Some Gt => x
+ | Some Lt | None => y
+ end.
+
+Definition one := Float32.of_int (Int.repr (1%Z)).
+Definition inv (x : float32) : float32 :=
+ Float32.div one x.
+
+End ExtFloat32.
diff --git a/mppa_k1c/ExtValues.v b/mppa_k1c/ExtValues.v
index 980e18f8..5a890f3c 100644
--- a/mppa_k1c/ExtValues.v
+++ b/mppa_k1c/ExtValues.v
@@ -1,6 +1,61 @@
Require Import Coqlib.
Require Import Integers.
Require Import Values.
+Require Import Floats ExtFloats.
+
+Open Scope Z_scope.
+
+Definition abs_diff (x y : Z) := Z.abs (x - y).
+Definition abs_diff2 (x y : Z) :=
+ if x <=? y then y - x else x - y.
+Lemma abs_diff2_correct :
+ forall x y : Z, (abs_diff x y) = (abs_diff2 x y).
+Proof.
+ intros.
+ unfold abs_diff, abs_diff2.
+ unfold Z.leb.
+ pose proof (Z.compare_spec x y) as Hspec.
+ inv Hspec.
+ - rewrite Z.abs_eq; omega.
+ - rewrite Z.abs_neq; omega.
+ - rewrite Z.abs_eq; omega.
+Qed.
+
+Inductive shift1_4 : Type :=
+| SHIFT1 | SHIFT2 | SHIFT3 | SHIFT4.
+
+Definition z_of_shift1_4 (x : shift1_4) :=
+ match x with
+ | SHIFT1 => 1
+ | SHIFT2 => 2
+ | SHIFT3 => 3
+ | SHIFT4 => 4
+ end.
+
+Definition shift1_4_of_z (x : Z) :=
+ if Z.eq_dec x 1 then Some SHIFT1
+ else if Z.eq_dec x 2 then Some SHIFT2
+ else if Z.eq_dec x 3 then Some SHIFT3
+ else if Z.eq_dec x 4 then Some SHIFT4
+ else None.
+
+Lemma shift1_4_of_z_correct :
+ forall z,
+ match shift1_4_of_z z with
+ | Some x => z_of_shift1_4 x = z
+ | None => True
+ end.
+Proof.
+ intro. unfold shift1_4_of_z.
+ destruct (Z.eq_dec _ _); simpl; try congruence.
+ destruct (Z.eq_dec _ _); simpl; try congruence.
+ destruct (Z.eq_dec _ _); simpl; try congruence.
+ destruct (Z.eq_dec _ _); simpl; try congruence.
+ trivial.
+Qed.
+
+Definition int_of_shift1_4 (x : shift1_4) :=
+ Int.repr (z_of_shift1_4 x).
Definition is_bitfield stop start :=
(Z.leb start stop)
@@ -251,10 +306,10 @@ Proof.
intros.
apply Int.eqm_samerepr.
unfold Int.eqm.
- unfold Int.eqmod.
+ unfold Zbits.eqmod.
pose proof (Int64.eqm_unsigned_repr x) as H64.
unfold Int64.eqm in H64.
- unfold Int64.eqmod in H64.
+ unfold Zbits.eqmod in H64.
destruct H64 as [k64 H64].
change Int64.modulus with 18446744073709551616 in *.
change Int.modulus with 4294967296.
@@ -331,7 +386,7 @@ Proof.
apply Int.eqm_samerepr.
unfold Int.eqm.
change (Int64.unsigned (Int64.repr (-2147483648))) with 18446744071562067968.
- unfold Int.eqmod.
+ unfold Zbits.eqmod.
change Int.modulus with 4294967296.
exists (-4294967296).
compute.
@@ -388,7 +443,7 @@ Qed.
(*
Lemma signed_0_eqb :
forall x, (Z.eqb (Int.signed x) 0) = Int.eq x Int.zero.
-Admitted.
+Qed.
*)
Lemma Z_quot_le: forall a b,
@@ -577,3 +632,109 @@ Proof.
}
}
Qed.
+
+Lemma sub_add_neg :
+ forall x y, Val.sub x y = Val.add x (Val.neg y).
+Proof.
+ destruct x; destruct y; simpl; trivial.
+ f_equal.
+ apply Int.sub_add_opp.
+Qed.
+
+Lemma neg_mul_distr_r :
+ forall x y, Val.neg (Val.mul x y) = Val.mul x (Val.neg y).
+Proof.
+ destruct x; destruct y; simpl; trivial.
+ f_equal.
+ apply Int.neg_mul_distr_r.
+Qed.
+
+(* pointer diff
+Lemma sub_addl_negl :
+ forall x y, Val.subl x y = Val.addl x (Val.negl y).
+Proof.
+ destruct x; destruct y; simpl; trivial.
+ + f_equal. apply Int64.sub_add_opp.
+ + destruct (Archi.ptr64) eqn:ARCHI64; trivial.
+ f_equal. rewrite Ptrofs.sub_add_opp.
+ pose (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 i0) i0) as Hagree.
+ unfold Ptrofs.agree64 in Hagree.
+ unfold Ptrofs.add.
+ f_equal. f_equal.
+ rewrite Hagree.
+ pose (Ptrofs.agree64_of_int ARCHI64 (Int64.neg i0)) as Hagree2.
+ rewrite Hagree2.
+ reflexivity.
+ exact (Ptrofs.agree64_of_int ARCHI64 i0).
+ + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial.
+ destruct (eq_block _ _); simpl; trivial.
+Qed.
+ *)
+
+Lemma negl_mull_distr_r :
+ forall x y, Val.negl (Val.mull x y) = Val.mull x (Val.negl y).
+Proof.
+ destruct x; destruct y; simpl; trivial.
+ f_equal.
+ apply Int64.neg_mul_distr_r.
+Qed.
+
+Definition addx sh v1 v2 :=
+ Val.add v2 (Val.shl v1 (Vint sh)).
+
+Definition addxl sh v1 v2 :=
+ Val.addl v2 (Val.shll v1 (Vint sh)).
+
+Definition revsubx sh v1 v2 :=
+ Val.sub v2 (Val.shl v1 (Vint sh)).
+
+Definition revsubxl sh v1 v2 :=
+ Val.subl v2 (Val.shll v1 (Vint sh)).
+
+Definition minf v1 v2 :=
+ match v1, v2 with
+ | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.min f1 f2)
+ | _, _ => Vundef
+ end.
+
+Definition maxf v1 v2 :=
+ match v1, v2 with
+ | (Vfloat f1), (Vfloat f2) => Vfloat (ExtFloat.max f1 f2)
+ | _, _ => Vundef
+ end.
+
+Definition minfs v1 v2 :=
+ match v1, v2 with
+ | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.min f1 f2)
+ | _, _ => Vundef
+ end.
+
+Definition maxfs v1 v2 :=
+ match v1, v2 with
+ | (Vsingle f1), (Vsingle f2) => Vsingle (ExtFloat32.max f1 f2)
+ | _, _ => Vundef
+ end.
+
+Definition invfs v1 :=
+ match v1 with
+ | (Vsingle f1) => Vsingle (ExtFloat32.inv f1)
+ | _ => Vundef
+ end.
+
+Definition triple_op_float f v1 v2 v3 :=
+ match v1, v2, v3 with
+ | (Vfloat f1), (Vfloat f2), (Vfloat f3) => Vfloat (f f1 f2 f3)
+ | _, _, _ => Vundef
+ end.
+
+Definition triple_op_single f v1 v2 v3 :=
+ match v1, v2, v3 with
+ | (Vsingle f1), (Vsingle f2), (Vsingle f3) => Vsingle (f f1 f2 f3)
+ | _, _, _ => Vundef
+ end.
+
+Definition fmaddf := triple_op_float (fun f1 f2 f3 => Float.fma f2 f3 f1).
+Definition fmaddfs := triple_op_single (fun f1 f2 f3 => Float32.fma f2 f3 f1).
+
+Definition fmsubf := triple_op_float (fun f1 f2 f3 => Float.fma (Float.neg f2) f3 f1).
+Definition fmsubfs := triple_op_single (fun f1 f2 f3 => Float32.fma (Float32.neg f2) f3 f1).
diff --git a/mppa_k1c/InstructionScheduler.ml b/mppa_k1c/InstructionScheduler.ml
index 1fa55c9b..9d3503e2 100644
--- a/mppa_k1c/InstructionScheduler.ml
+++ b/mppa_k1c/InstructionScheduler.ml
@@ -307,8 +307,8 @@ let priority_list_scheduler (order : list_scheduler_order)
let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;;
-(** FIXME - warning fix *)
-let _ = priority_list_scheduler INSTRUCTION_ORDER;;
+(* dummy code for placating ocaml's warnings *)
+let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;;
type bundle = int list;;
@@ -367,7 +367,7 @@ let bundles_to_schedule problem bundles : solution =
let greedy_scheduler (problem : problem) : solution option =
let bundles = make_bundles problem 0 in
Some (bundles_to_schedule problem bundles);;
-
+
(* alternate implementation
let swap_array_elements a i j =
let x = a.(i) in
@@ -389,32 +389,36 @@ let array_reverse a =
a';;
*)
+(* unneeded
let array_reverse a =
let n=Array.length a in
Array.init n (fun i -> a.(n-1-i));;
+ *)
let reverse_constraint nr_instructions ctr =
- if ctr.instr_to < nr_instructions
- then Some
- { instr_to = nr_instructions -1 -ctr.instr_from;
- instr_from = nr_instructions -1 - ctr.instr_to;
- latency = ctr.latency }
- else None;;
+ { instr_to = nr_instructions -ctr.instr_from;
+ instr_from = nr_instructions - ctr.instr_to;
+ latency = ctr.latency };;
+(* unneeded
let rec list_map_filter f = function
| [] -> []
| h::t ->
(match f h with
| None -> list_map_filter f t
| Some x -> x :: (list_map_filter f t));;
+ *)
let reverse_problem problem =
let nr_instructions = get_nr_instructions problem in
{
max_latency = problem.max_latency;
resource_bounds = problem.resource_bounds;
- instruction_usages = array_reverse problem.instruction_usages;
- latency_constraints = list_map_filter (reverse_constraint nr_instructions)
+ instruction_usages = Array.init (nr_instructions + 1)
+ (fun i ->
+ if i=0
+ then Array.map (fun _ -> 0) problem.resource_bounds else problem.instruction_usages.(nr_instructions - i));
+ latency_constraints = List.map (reverse_constraint nr_instructions)
problem.latency_constraints
};;
@@ -426,18 +430,28 @@ let max_scheduled_time solution =
done;
!time;;
+(*
+let recompute_makespan problem solution =
+ let n = (Array.length solution) - 1 and ms = ref 0 in
+ List.iter (fun cstr ->
+ if cstr.instr_to = n
+ then ms := max !ms (solution.(cstr.instr_from) + cstr.latency)
+ ) problem.latency_constraints;
+ !ms;;
+ *)
+
let schedule_reversed (scheduler : problem -> solution option)
(problem : problem) =
match scheduler (reverse_problem problem) with
| None -> None
| Some solution ->
- let nr_instructions = get_nr_instructions problem
- and maxi = max_scheduled_time solution in
- Some (Array.init (Array.length solution)
- (fun i ->
- if i < nr_instructions
- then maxi-solution.(nr_instructions-1-i)
- else solution.(i)));;
+ let nr_instructions = get_nr_instructions problem in
+ let makespan = max_scheduled_time solution in
+ let ret = Array.init (nr_instructions + 1)
+ (fun i -> makespan-solution.(nr_instructions-i)) in
+ ret.(nr_instructions) <- max ((max_scheduled_time ret) + 1)
+ (ret.(nr_instructions));
+ Some ret;;
(** Schedule the problem using a greedy list scheduling algorithm, from the end. *)
let reverse_list_scheduler = schedule_reversed list_scheduler;;
@@ -1143,9 +1157,10 @@ let ilp_read_solution mapper channel =
(if tnumber < 0 || tnumber >= (Array.length times)
then failwith (Printf.sprintf "bad ilp output: not a correct variable number: %d (%d)" tnumber (Array.length times)));
let value =
- try rounded_int_of_string (String.sub line (space+1) ((String.length line)-space-1))
+ let s = String.sub line (space+1) ((String.length line)-space-1) in
+ try rounded_int_of_string s
with Failure _ ->
- failwith "bad ilp output: not a time number"
+ failwith (Printf.sprintf "bad ilp output: not a time number (%s)" s)
in
(if value < 0
then failwith "bad ilp output: negative time");
@@ -1164,20 +1179,16 @@ let ilp_read_solution mapper channel =
let ilp_solver = ref "ilp_solver"
let problem_nr = ref 0
-
-let do_with_resource destroy x f =
- try
- let r = f x in
- destroy x; r
- with exn -> destroy x; raise exn;;
-
+
let ilp_scheduler pb_type problem =
try
let filename_in = Printf.sprintf "problem%05d.lp" !problem_nr
and filename_out = Printf.sprintf "problem%05d.sol" !problem_nr in
incr problem_nr;
- let mapper = do_with_resource close_out (open_out filename_in)
- (fun opb_problem -> ilp_print_problem opb_problem problem pb_type) in
+ let opb_problem = open_out filename_in in
+ let mapper = ilp_print_problem opb_problem problem pb_type in
+ close_out opb_problem;
+
begin
match Unix.system (!ilp_solver ^ " " ^ filename_in ^ " " ^ filename_out) with
| Unix.WEXITED 0 ->
@@ -1190,20 +1201,33 @@ let ilp_scheduler pb_type problem =
end
with
| Unschedulable -> None;;
-
+
+let current_utime_all () =
+ let t = Unix.times() in
+ t.Unix.tms_cutime +. t.Unix.tms_utime;;
+
+let utime_all_fn fn arg =
+ let utime_start = current_utime_all () in
+ let output = fn arg in
+ let utime_end = current_utime_all () in
+ (output, utime_end -. utime_start);;
+
let cascaded_scheduler (problem : problem) =
- match validated_scheduler list_scheduler problem with
+ let (some_initial_solution, list_scheduler_time) =
+ utime_all_fn (validated_scheduler list_scheduler) problem in
+ match some_initial_solution with
| None -> None
| Some initial_solution ->
- let solution = reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution problem in
+ let (solution, reoptimizing_time) = utime_all_fn (reoptimizing_scheduler (validated_scheduler (ilp_scheduler SATISFIABILITY)) initial_solution) problem in
begin
let latency2 = get_max_latency solution
and latency1 = get_max_latency initial_solution in
- if latency2 < latency1
- then Printf.printf "REOPTIMIZING SUCCEEDED %d < %d for %d instructions\n" latency2 latency1 (Array.length problem.instruction_usages)
- else if latency2 = latency1
- then Printf.printf "%d unchanged\n" latency1
- else failwith "optimizing not optimizing"
+ Printf.printf "postpass %s: %d, %d, %d, %g, %g\n"
+ (if latency2 < latency1 then "REOPTIMIZED" else "unchanged")
+ (get_nr_instructions problem)
+ latency1 latency2
+ list_scheduler_time reoptimizing_time;
+ flush stdout
end;
Some solution;;
diff --git a/mppa_k1c/Machregs.v b/mppa_k1c/Machregs.v
index cd8c6606..8098b5d1 100644
--- a/mppa_k1c/Machregs.v
+++ b/mppa_k1c/Machregs.v
@@ -213,8 +213,12 @@ Global Opaque
Definition two_address_op (op: operation) : bool :=
match op with
- | Omadd | Omaddimm _ | Omaddl | Omaddlimm _
- | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _
+ | Ofmaddf | Ofmaddfs
+ | Ofmsubf | Ofmsubfs
+ | Omadd | Omaddimm _
+ | Omaddl | Omaddlimm _
+ | Omsub | Omsubl
+ | Osel _ _ | Oselimm _ _ | Osellimm _ _
| Oinsf _ _ | Oinsfl _ _ => true
| _ => false
end.
diff --git a/mppa_k1c/NeedOp.v b/mppa_k1c/NeedOp.v
index c10f5c56..7111c48b 100644
--- a/mppa_k1c/NeedOp.v
+++ b/mppa_k1c/NeedOp.v
@@ -28,6 +28,7 @@ Definition op2 (nv: nval) := nv :: nv :: nil.
Definition op3 (nv: nval) := nv :: nv :: nv :: nil.
Definition needs_of_condition (cond: condition): list nval := nil.
+Definition needs_of_condition0 (cond0: condition0): list nval := nil.
Definition needs_of_operation (op: operation) (nv: nval): list nval :=
match op with
@@ -42,8 +43,13 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Ocast16signed => op1 (sign_ext 16 nv)
| Oadd => op2 (modarith nv)
| Oaddimm n => op1 (modarith nv)
+ | Oaddx _ => op2 (default nv)
+ | Oaddximm _ _ => op1 (default nv)
| Oneg => op1 (modarith nv)
| Osub => op2 (default nv)
+ | Orevsubimm _ => op1 (default nv)
+ | Orevsubx _ => op2 (default nv)
+ | Orevsubximm _ _ => op1 (default nv)
| Omul => op2 (modarith nv)
| Omulimm _ => op1 (modarith nv)
| Omulhs | Omulhu | Odiv | Odivu | Omod | Omodu => op2 (default nv)
@@ -72,12 +78,18 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Oshrximm n => op1 (default nv)
| Omadd => op3 (modarith nv)
| Omaddimm n => op2 (modarith nv)
+ | Omsub => op3 (modarith nv)
| Omakelong => op2 (default nv)
| Olowlong | Ohighlong => op1 (default nv)
| Ocast32signed => op1 (default nv)
| Ocast32unsigned => op1 (default nv)
| Oaddl => op2 (default nv)
| Oaddlimm n => op1 (default nv)
+ | Oaddxl _ => op2 (default nv)
+ | Oaddxlimm _ _ => op1 (default nv)
+ | Orevsublimm _ => op1 (default nv)
+ | Orevsubxl _ => op2 (default nv)
+ | Orevsubxlimm _ _ => op1 (default nv)
| Onegl => op1 (default nv)
| Osubl => op2 (default nv)
| Omull => op2 (default nv)
@@ -107,19 +119,25 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Oshrxlimm n => op1 (default nv)
| Omaddl => op3 (default nv)
| Omaddlimm n => op2 (default nv)
+ | Omsubl => op3 (default nv)
| Onegf | Oabsf => op1 (default nv)
- | Oaddf | Osubf | Omulf | Odivf => op2 (default nv)
+ | Oaddf | Osubf | Omulf | Odivf | Ominf | Omaxf => op2 (default nv)
+ | Ofmaddf | Ofmsubf => op3 (default nv)
| Onegfs | Oabsfs => op1 (default nv)
- | Oaddfs | Osubfs | Omulfs | Odivfs => op2 (default nv)
+ | Oaddfs | Osubfs | Omulfs | Odivfs | Ominfs | Omaxfs => op2 (default nv)
+ | Oinvfs => op1 (default nv)
+ | Ofmaddfs | Ofmsubfs => op3 (default nv)
| Ofloatofsingle | Osingleoffloat => op1 (default nv)
| Ointoffloat | Ointuoffloat => op1 (default nv)
| Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => op1 (default nv)
| Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => op1 (default nv)
| Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => op1 (default nv)
| Ocmp c => needs_of_condition c
- | Oselect _ | Oselectl _ | Oselectf _ | Oselectfs _ => op3 (default nv)
| Oextfz _ _ | Oextfs _ _ | Oextfzl _ _ | Oextfsl _ _ => op1 (default nv)
| Oinsf _ _ | Oinsfl _ _ => op2 (default nv)
+ | Osel c ty => nv :: nv :: needs_of_condition0 c
+ | Oselimm c imm
+ | Osellimm c imm => nv :: needs_of_condition0 c
end.
Definition operation_is_redundant (op: operation) (nv: nval): bool :=
@@ -229,6 +247,26 @@ Proof.
- apply Val.addl_lessdef; trivial.
Qed.
+Lemma subl_lessdef:
+ forall v1 v1' v2 v2',
+ Val.lessdef v1 v1' -> Val.lessdef v2 v2' -> Val.lessdef (Val.subl v1 v2) (Val.subl v1' v2').
+Proof.
+ intros. inv H. inv H0. auto. destruct v1'; simpl; auto. simpl; auto.
+Qed.
+
+Lemma subl_sound:
+ forall v1 w1 v2 w2 x,
+ vagree v1 w1 (default x) -> vagree v2 w2 (default x) ->
+ vagree (Val.subl v1 v2) (Val.subl w1 w2) x.
+Proof.
+ unfold default; intros.
+ destruct x; simpl in *; trivial.
+ - unfold Val.subl.
+ destruct v1; destruct v2; trivial; destruct Archi.ptr64; simpl; trivial.
+ destruct (eq_block _ _) ; simpl; trivial.
+ - apply subl_lessdef; trivial.
+Qed.
+
Lemma mull_sound:
forall v1 w1 v2 w2 x,
@@ -245,184 +283,57 @@ Proof.
trivial.
Qed.
-Lemma select_sound:
- forall cond v0 w0 v1 w1 v2 w2 x,
- vagree v0 w0 (default x) ->
- vagree v1 w1 (default x) ->
- vagree v2 w2 (default x) ->
- vagree (eval_select cond v0 v1 v2 m1) (eval_select cond w0 w1 w2 m2) x.
-Proof.
- intros.
- destruct x; simpl in *; trivial.
- - rewrite eval_select_to2.
- rewrite eval_select_to2.
- unfold eval_select2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- apply iagree_refl.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- apply iagree_refl.
- - rewrite eval_select_to2.
- rewrite eval_select_to2.
- unfold eval_select2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
-Qed.
-Lemma selectl_sound:
- forall cond v0 w0 v1 w1 v2 w2 x,
- vagree v0 w0 (default x) ->
- vagree v1 w1 (default x) ->
- vagree v2 w2 (default x) ->
- vagree (eval_selectl cond v0 v1 v2 m1) (eval_selectl cond w0 w1 w2 m2) x.
+Remark default_idem: forall nv, default (default nv) = default nv.
Proof.
- intros.
- destruct x; simpl in *; trivial.
- - rewrite eval_selectl_to2.
- rewrite eval_selectl_to2.
- unfold eval_selectl2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- - rewrite eval_selectl_to2.
- rewrite eval_selectl_to2.
- unfold eval_selectl2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
+ destruct nv; simpl; trivial.
Qed.
-Lemma selectf_sound:
- forall cond v0 w0 v1 w1 v2 w2 x,
- vagree v0 w0 (default x) ->
- vagree v1 w1 (default x) ->
- vagree v2 w2 (default x) ->
- vagree (eval_selectf cond v0 v1 v2 m1) (eval_selectf cond w0 w1 w2 m2) x.
+Lemma vagree_triple_op_float :
+ forall f a b c x y z nv,
+ (vagree a x (default nv)) ->
+ (vagree b y (default nv)) ->
+ (vagree c z (default nv)) ->
+ (vagree (ExtValues.triple_op_float f a b c)
+ (ExtValues.triple_op_float f x y z) nv).
Proof.
- intros.
- destruct x; simpl in *; trivial.
- - rewrite eval_selectf_to2.
- rewrite eval_selectf_to2.
- unfold eval_selectf2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- - rewrite eval_selectf_to2.
- rewrite eval_selectf_to2.
- unfold eval_selectf2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
+ induction nv;
+ intros Hax Hby Hcz.
+ - trivial.
+ - simpl in *. destruct a; simpl; trivial.
+ destruct b; simpl; trivial.
+ destruct c; simpl; trivial.
+ - simpl in *. destruct a; simpl; trivial.
+ destruct b; simpl; trivial.
+ destruct c; simpl; trivial.
+ inv Hax. inv Hby. inv Hcz.
+ simpl.
+ constructor.
Qed.
-Lemma selectfs_sound:
- forall cond v0 w0 v1 w1 v2 w2 x,
- vagree v0 w0 (default x) ->
- vagree v1 w1 (default x) ->
- vagree v2 w2 (default x) ->
- vagree (eval_selectfs cond v0 v1 v2 m1) (eval_selectfs cond w0 w1 w2 m2) x.
+Lemma vagree_triple_op_single :
+ forall f a b c x y z nv,
+ (vagree a x (default nv)) ->
+ (vagree b y (default nv)) ->
+ (vagree c z (default nv)) ->
+ (vagree (ExtValues.triple_op_single f a b c)
+ (ExtValues.triple_op_single f x y z) nv).
Proof.
- intros.
- destruct x; simpl in *; trivial.
- - rewrite eval_selectfs_to2.
- rewrite eval_selectfs_to2.
- unfold eval_selectfs2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- destruct w1; trivial.
- - rewrite eval_selectfs_to2.
- rewrite eval_selectfs_to2.
- unfold eval_selectfs2.
- assert (Hneedstrue := (needs_of_condition0_sound cond v2 true w2)).
- assert (Hneedsfalse := (needs_of_condition0_sound cond v2 false w2)).
- destruct (eval_condition0 cond v2 m1) in *; simpl in *; trivial.
- destruct b.
- + rewrite Hneedstrue; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
- + rewrite Hneedsfalse; trivial.
- inv H; trivial.
- destruct w0; trivial.
- inv H0; trivial.
+ induction nv;
+ intros Hax Hby Hcz.
+ - trivial.
+ - simpl in *. destruct a; simpl; trivial.
+ destruct b; simpl; trivial.
+ destruct c; simpl; trivial.
+ - simpl in *. destruct a; simpl; trivial.
+ destruct b; simpl; trivial.
+ destruct c; simpl; trivial.
+ inv Hax. inv Hby. inv Hcz.
+ simpl.
+ constructor.
Qed.
-Remark default_idem: forall nv, default (default nv) = default nv.
-Proof.
- destruct nv; simpl; trivial.
-Qed.
+Hint Resolve vagree_triple_op_float vagree_triple_op_single : na.
Lemma needs_of_operation_sound:
forall op args v nv args',
@@ -466,19 +377,26 @@ Proof.
(* madd *)
- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption.
- apply add_sound; try apply mul_sound; auto with na; rewrite modarith_idem; assumption.
- (* maddl *)
-- apply addl_sound; trivial.
- apply mull_sound; trivial.
- rewrite default_idem; trivial.
- rewrite default_idem; trivial.
- (* select *)
-- apply select_sound; trivial.
- (* selectl *)
-- apply selectl_sound; trivial.
- (* selectf *)
-- apply selectf_sound; trivial.
- (* selectfs *)
-- apply selectfs_sound; trivial.
+- repeat rewrite ExtValues.sub_add_neg.
+ apply add_sound; trivial.
+ apply neg_sound; trivial.
+ rewrite modarith_idem.
+ apply mul_sound;
+ rewrite modarith_idem; trivial.
+- destruct (eval_condition0 _ _ _) as [b|] eqn:EC.
+ erewrite needs_of_condition0_sound by eauto.
+ apply select_sound; auto.
+ simpl; auto with na.
+ (* select imm *)
+- destruct (eval_condition0 _ _ _) as [b|] eqn:EC.
+ { erewrite needs_of_condition0_sound by eauto.
+ apply select_sound; auto with na. }
+ simpl; auto with na.
+ (* select long imm *)
+- destruct (eval_condition0 _ _ _) as [b|] eqn:EC.
+ { erewrite needs_of_condition0_sound by eauto.
+ apply select_sound; auto with na. }
+ simpl; auto with na.
Qed.
Lemma operation_is_redundant_sound:
diff --git a/mppa_k1c/Op.v b/mppa_k1c/Op.v
index 5e80589b..92061d04 100644
--- a/mppa_k1c/Op.v
+++ b/mppa_k1c/Op.v
@@ -79,8 +79,13 @@ Inductive operation : Type :=
| Ocast16signed (**r [rd] is 16-bit sign extension of [r1] *)
| Oadd (**r [rd = r1 + r2] *)
| Oaddimm (n: int) (**r [rd = r1 + n] *)
+ | Oaddx (shift: shift1_4) (**r [rd = r1 << shift + r2] *)
+ | Oaddximm (shift: shift1_4) (n: int) (**r [rd = r1 << shift + n] *)
| Oneg (**r [rd = - r1] *)
| Osub (**r [rd = r1 - r2] *)
+ | Orevsubimm (n: int) (**r [rd = n - r1] *)
+ | Orevsubx (shift: shift1_4) (**r [rd = r2 -r1 << shift] *)
+ | Orevsubximm (shift: shift1_4) (n: int) (**r [rd = n -r1 << shift] *)
| Omul (**r [rd = r1 * r2] *)
| Omulimm (n: int) (**r [rd = r1 * n] *)
| Omulhs (**r [rd = high part of r1 * r2, signed] *)
@@ -95,27 +100,28 @@ Inductive operation : Type :=
| Onandimm (n: int) (**r [rd = ~(r1 & n)] *)
| Oor (**r [rd = r1 | r2] *)
| Oorimm (n: int) (**r [rd = r1 | n] *)
- | Onor (**r [rd = r1 | r2] *)
- | Onorimm (n: int) (**r [rd = r1 | n] *)
+ | Onor (**r [rd = ~(r1 | r2)] *)
+ | Onorimm (n: int) (**r [rd = ~(r1 | n)] *)
| Oxor (**r [rd = r1 ^ r2] *)
| Oxorimm (n: int) (**r [rd = r1 ^ n] *)
| Onxor (**r [rd = ~(r1 ^ r2)] *)
| Onxorimm (n: int) (**r [rd = ~(r1 ^ n)] *)
| Onot (**r [rd = ~r1] *)
- | Oandn (**r [rd = (~r1) ^ r2] *)
- | Oandnimm (n: int) (**r [rd = (~r1) ^ n] *)
+ | Oandn (**r [rd = (~r1) & r2] *)
+ | Oandnimm (n: int) (**r [rd = (~r1) & n] *)
| Oorn (**r [rd = (~r1) | r2] *)
| Oornimm (n: int) (**r [rd = (~r1) | n] *)
| Oshl (**r [rd = r1 << r2] *)
| Oshlimm (n: int) (**r [rd = r1 << n] *)
- | Oshr (**r [rd = r1 >> r2] (signed) *)
- | Oshrimm (n: int) (**r [rd = r1 >> n] (signed) *)
- | Oshru (**r [rd = r1 >> r2] (unsigned) *)
- | Oshruimm (n: int) (**r [rd = r1 >> n] (unsigned) *)
+ | Oshr (**r [rd = r1 >>s r2] (signed) *)
+ | Oshrimm (n: int) (**r [rd = r1 >>s n] (signed) *)
+ | Oshru (**r [rd = r1 >>u r2] (unsigned) *)
+ | Oshruimm (n: int) (**r [rd = r1 >>x n] (unsigned) *)
| Oshrximm (n: int) (**r [rd = r1 / 2^n] (signed) *)
| Ororimm (n: int) (**r rotate right immediate *)
| Omadd (**r [rd = rd + r1 * r2] *)
| Omaddimm (n: int) (**r [rd = rd + r1 * imm] *)
+ | Omsub (**r [rd = rd - r1 * r2] *)
(*c 64-bit integer arithmetic: *)
| Omakelong (**r [rd = r1 << 32 | r2] *)
| Olowlong (**r [rd = low-word(r1)] *)
@@ -124,6 +130,11 @@ Inductive operation : Type :=
| Ocast32unsigned (**r [rd] is 32-bit zero extension of [r1] *)
| Oaddl (**r [rd = r1 + r2] *)
| Oaddlimm (n: int64) (**r [rd = r1 + n] *)
+ | Oaddxl (shift: shift1_4) (**r [rd = r1 << shift + r2] *)
+ | Oaddxlimm (shift: shift1_4) (n: int64) (**r [rd = r1 << shift + n] *)
+ | Orevsublimm (n: int64) (**r [rd = n - r1] *)
+ | Orevsubxl (shift: shift1_4) (**r [rd = r2 -r1 << shift] *)
+ | Orevsubxlimm (shift: shift1_4) (n: int64) (**r [rd = n -r1 << shift] *)
| Onegl (**r [rd = - r1] *)
| Osubl (**r [rd = r1 - r2] *)
| Omull (**r [rd = r1 * r2] *)
@@ -147,8 +158,8 @@ Inductive operation : Type :=
| Onxorl (**r [rd = ~(r1 ^ r2)] *)
| Onxorlimm (n: int64) (**r [rd = ~(r1 ^ n)] *)
| Onotl (**r [rd = ~r1] *)
- | Oandnl (**r [rd = (~r1) ^ r2] *)
- | Oandnlimm (n: int64) (**r [rd = (~r1) ^ n] *)
+ | Oandnl (**r [rd = (~r1) & r2] *)
+ | Oandnlimm (n: int64) (**r [rd = (~r1) & n] *)
| Oornl (**r [rd = (~r1) | r2] *)
| Oornlimm (n: int64) (**r [rd = (~r1) | n] *)
| Oshll (**r [rd = r1 << r2] *)
@@ -160,6 +171,7 @@ Inductive operation : Type :=
| Oshrxlimm (n: int) (**r [rd = r1 / 2^n] (signed) *)
| Omaddl (**r [rd = rd + r1 * r2] *)
| Omaddlimm (n: int64) (**r [rd = rd + r1 * imm] *)
+ | Omsubl (**r [rd = rd - r1 * r2] *)
(*c Floating-point arithmetic: *)
| Onegf (**r [rd = - r1] *)
| Oabsf (**r [rd = abs(r1)] *)
@@ -167,12 +179,21 @@ Inductive operation : Type :=
| Osubf (**r [rd = r1 - r2] *)
| Omulf (**r [rd = r1 * r2] *)
| Odivf (**r [rd = r1 / r2] *)
+ | Ominf
+ | Omaxf
+ | Ofmaddf
+ | Ofmsubf
| Onegfs (**r [rd = - r1] *)
| Oabsfs (**r [rd = abs(r1)] *)
| Oaddfs (**r [rd = r1 + r2] *)
| Osubfs (**r [rd = r1 - r2] *)
| Omulfs (**r [rd = r1 * r2] *)
| Odivfs (**r [rd = r1 / r2] *)
+ | Ominfs
+ | Omaxfs
+ | Oinvfs
+ | Ofmaddfs
+ | Ofmsubfs
| Osingleoffloat (**r [rd] is [r1] truncated to single-precision float *)
| Ofloatofsingle (**r [rd] is [r1] extended to double-precision float *)
(*c Conversions between int and float: *)
@@ -192,16 +213,15 @@ Inductive operation : Type :=
| Osingleoflongu (**r [rd = float32_of_unsigned_int(r1)] *)
(*c Boolean tests: *)
| Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
- | Oselect (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *)
- | Oselectl (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *)
- | Oselectf (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *)
- | Oselectfs (cond: condition0) (**r [rd = if cond r3 then r2 else r1] *)
| Oextfz (stop : Z) (start : Z)
| Oextfs (stop : Z) (start : Z)
| Oextfzl (stop : Z) (start : Z)
| Oextfsl (stop : Z) (start : Z)
| Oinsf (stop : Z) (start : Z)
- | Oinsfl (stop : Z) (start : Z).
+ | Oinsfl (stop : Z) (start : Z)
+ | Osel (c0 : condition0) (ty : typ)
+ | Oselimm (c0 : condition0) (imm: int)
+ | Osellimm (c0 : condition0) (imm: int64).
(** Addressing modes. [r1], [r2], etc, are the arguments to the
addressing. *)
@@ -235,9 +255,14 @@ Proof.
decide equality.
Defined.
+Definition eq_shift1_4 (x y : shift1_4): {x=y} + {x<>y}.
+Proof.
+ decide equality.
+Defined.
+
Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}.
Proof.
- generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec; intros.
+ generalize typ_eq Int.eq_dec Int64.eq_dec Ptrofs.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_condition eq_condition0 Z.eq_dec eq_shift1_4; intros.
decide equality.
Defined.
@@ -287,90 +312,14 @@ Definition eval_condition0 (cond: condition0) (v1: val) (m: mem): option bool :=
| Ccomplu0 c => Val.cmplu_bool (Mem.valid_pointer m) c v1 (Vlong Int64.zero)
end.
-Definition eval_select (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match v0, v1, (eval_condition0 cond vselect m) with
- | Vint i0, Vint i1, Some bval => Vint (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Definition eval_select2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match (eval_condition0 cond vselect m), v0, v1 with
- | Some bval, Vint i0, Vint i1 => Vint (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Lemma eval_select_to2: forall cond v0 v1 vselect m,
- (eval_select cond v0 v1 vselect m) =
- (eval_select2 cond v0 v1 vselect m).
-Proof.
- intros.
- unfold eval_select2.
- destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity.
-Qed.
-
-Definition eval_selectl (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match v0, v1, (eval_condition0 cond vselect m) with
- | Vlong i0, Vlong i1, Some bval => Vlong (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Definition eval_selectl2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match (eval_condition0 cond vselect m), v0, v1 with
- | Some bval, Vlong i0, Vlong i1 => Vlong (if bval then i1 else i0)
- | _,_,_ => Vundef
+Definition negate_condition0 (cond0 : condition0) : condition0 :=
+ match cond0 with
+ | Ccomp0 c => Ccomp0 (negate_comparison c)
+ | Ccompu0 c => Ccompu0 (negate_comparison c)
+ | Ccompl0 c => Ccompl0 (negate_comparison c)
+ | Ccomplu0 c => Ccomplu0 (negate_comparison c)
end.
-Lemma eval_selectl_to2: forall cond v0 v1 vselect m,
- (eval_selectl cond v0 v1 vselect m) =
- (eval_selectl2 cond v0 v1 vselect m).
-Proof.
- intros.
- unfold eval_selectl2.
- destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity.
-Qed.
-
-Definition eval_selectf (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match v0, v1, (eval_condition0 cond vselect m) with
- | Vfloat i0, Vfloat i1, Some bval => Vfloat (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Definition eval_selectf2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match (eval_condition0 cond vselect m), v0, v1 with
- | Some bval, Vfloat i0, Vfloat i1 => Vfloat (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Lemma eval_selectf_to2: forall cond v0 v1 vselect m,
- (eval_selectf cond v0 v1 vselect m) =
- (eval_selectf2 cond v0 v1 vselect m).
-Proof.
- intros.
- unfold eval_selectf2.
- destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity.
-Qed.
-
-Definition eval_selectfs (cond: condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match v0, v1, (eval_condition0 cond vselect m) with
- | Vsingle i0, Vsingle i1, Some bval => Vsingle (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Definition eval_selectfs2 (cond : condition0) (v0 : val) (v1 : val) (vselect : val) (m: mem) : val :=
- match (eval_condition0 cond vselect m), v0, v1 with
- | Some bval, Vsingle i0, Vsingle i1 => Vsingle (if bval then i1 else i0)
- | _,_,_ => Vundef
- end.
-
-Lemma eval_selectfs_to2: forall cond v0 v1 vselect m,
- (eval_selectfs cond v0 v1 vselect m) =
- (eval_selectfs2 cond v0 v1 vselect m).
-Proof.
- intros.
- unfold eval_selectfs2.
- destruct v0; destruct v1; simpl; destruct (eval_condition0 cond vselect m); simpl; reflexivity.
-Qed.
-
Definition eval_operation
(F V: Type) (genv: Genv.t F V) (sp: val)
(op: operation) (vl: list val) (m: mem): option val :=
@@ -386,8 +335,13 @@ Definition eval_operation
| Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1)
| Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2)
| Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n))
+ | Oaddx s14, v1 :: v2 :: nil => Some (addx (int_of_shift1_4 s14) v1 v2)
+ | Oaddximm s14 n, v1 :: nil => Some (addx (int_of_shift1_4 s14) v1 (Vint n))
| Oneg, v1 :: nil => Some (Val.neg v1)
| Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2)
+ | Orevsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1)
+ | Orevsubx shift, v1 :: v2 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 v2)
+ | Orevsubximm shift n, v1 :: nil => Some (ExtValues.revsubx (int_of_shift1_4 shift) v1 (Vint n))
| Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2)
| Omulimm n, v1 :: nil => Some (Val.mul v1 (Vint n))
| Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2)
@@ -423,6 +377,7 @@ Definition eval_operation
| Oshrximm n, v1::nil => Val.shrx v1 (Vint n)
| Omadd, v1::v2::v3::nil => Some (Val.add v1 (Val.mul v2 v3))
| (Omaddimm n), v1::v2::nil => Some (Val.add v1 (Val.mul v2 (Vint n)))
+ | Omsub, v1::v2::v3::nil => Some (Val.sub v1 (Val.mul v2 v3))
| Omakelong, v1::v2::nil => Some (Val.longofwords v1 v2)
| Olowlong, v1::nil => Some (Val.loword v1)
@@ -431,8 +386,13 @@ Definition eval_operation
| Ocast32unsigned, v1 :: nil => Some (Val.longofintu v1)
| Oaddl, v1 :: v2 :: nil => Some (Val.addl v1 v2)
| Oaddlimm n, v1::nil => Some (Val.addl v1 (Vlong n))
+ | Oaddxl s14, v1 :: v2 :: nil => Some (addxl (int_of_shift1_4 s14) v1 v2)
+ | Oaddxlimm s14 n, v1 :: nil => Some (addxl (int_of_shift1_4 s14) v1 (Vlong n))
| Onegl, v1::nil => Some (Val.negl v1)
| Osubl, v1::v2::nil => Some (Val.subl v1 v2)
+ | Orevsublimm n, v1 :: nil => Some (Val.subl (Vlong n) v1)
+ | Orevsubxl shift, v1 :: v2 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 v2)
+ | Orevsubxlimm shift n, v1 :: nil => Some (ExtValues.revsubxl (int_of_shift1_4 shift) v1 (Vlong n))
| Omull, v1::v2::nil => Some (Val.mull v1 v2)
| Omullimm n, v1::nil => Some (Val.mull v1 (Vlong n))
| Omullhs, v1::v2::nil => Some (Val.mullhs v1 v2)
@@ -467,6 +427,7 @@ Definition eval_operation
| Oshrxlimm n, v1::nil => Val.shrxl v1 (Vint n)
| Omaddl, v1::v2::v3::nil => Some (Val.addl v1 (Val.mull v2 v3))
| (Omaddlimm n), v1::v2::nil => Some (Val.addl v1 (Val.mull v2 (Vlong n)))
+ | Omsubl, v1::v2::v3::nil => Some (Val.subl v1 (Val.mull v2 v3))
| Onegf, v1::nil => Some (Val.negf v1)
| Oabsf, v1::nil => Some (Val.absf v1)
@@ -474,12 +435,23 @@ Definition eval_operation
| Osubf, v1::v2::nil => Some (Val.subf v1 v2)
| Omulf, v1::v2::nil => Some (Val.mulf v1 v2)
| Odivf, v1::v2::nil => Some (Val.divf v1 v2)
+ | Ominf, v1::v2::nil => Some (ExtValues.minf v1 v2)
+ | Omaxf, v1::v2::nil => Some (ExtValues.maxf v1 v2)
+ | Ofmaddf, v1::v2::v3::nil => Some (ExtValues.fmaddf v1 v2 v3)
+ | Ofmsubf, v1::v2::v3::nil => Some (ExtValues.fmsubf v1 v2 v3)
+
| Onegfs, v1::nil => Some (Val.negfs v1)
| Oabsfs, v1::nil => Some (Val.absfs v1)
| Oaddfs, v1::v2::nil => Some (Val.addfs v1 v2)
| Osubfs, v1::v2::nil => Some (Val.subfs v1 v2)
| Omulfs, v1::v2::nil => Some (Val.mulfs v1 v2)
| Odivfs, v1::v2::nil => Some (Val.divfs v1 v2)
+ | Ominfs, v1::v2::nil => Some (ExtValues.minfs v1 v2)
+ | Omaxfs, v1::v2::nil => Some (ExtValues.maxfs v1 v2)
+ | Oinvfs, v1::nil => Some (ExtValues.invfs v1)
+ | Ofmaddfs, v1::v2::v3::nil => Some (ExtValues.fmaddfs v1 v2 v3)
+ | Ofmsubfs, v1::v2::v3::nil => Some (ExtValues.fmsubfs v1 v2 v3)
+
| Osingleoffloat, v1::nil => Some (Val.singleoffloat v1)
| Ofloatofsingle, v1::nil => Some (Val.floatofsingle v1)
| Ointoffloat, v1::nil => Val.intoffloat v1
@@ -497,16 +469,15 @@ Definition eval_operation
| Osingleoflong, v1::nil => Val.singleoflong v1
| Osingleoflongu, v1::nil => Val.singleoflongu v1
| Ocmp c, _ => Some (Val.of_optbool (eval_condition c vl m))
- | (Oselect cond), v0::v1::vselect::nil => Some (eval_select cond v0 v1 vselect m)
- | (Oselectl cond), v0::v1::vselect::nil => Some (eval_selectl cond v0 v1 vselect m)
- | (Oselectf cond), v0::v1::vselect::nil => Some (eval_selectf cond v0 v1 vselect m)
- | (Oselectfs cond), v0::v1::vselect::nil => Some (eval_selectfs cond v0 v1 vselect m)
| (Oextfz stop start), v0::nil => Some (extfz stop start v0)
| (Oextfs stop start), v0::nil => Some (extfs stop start v0)
| (Oextfzl stop start), v0::nil => Some (extfzl stop start v0)
| (Oextfsl stop start), v0::nil => Some (extfsl stop start v0)
| (Oinsf stop start), v0::v1::nil => Some (insf stop start v0 v1)
| (Oinsfl stop start), v0::v1::nil => Some (insfl stop start v0 v1)
+ | Osel c ty, v1::v2::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 v2 ty)
+ | Oselimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vint imm) Tint)
+ | Osellimm c imm, v1::vc::nil => Some(Val.select (eval_condition0 c vc m) v1 (Vlong imm) Tlong)
| _, _ => None
end.
@@ -583,8 +554,13 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Ocast16signed => (Tint :: nil, Tint)
| Oadd => (Tint :: Tint :: nil, Tint)
| Oaddimm _ => (Tint :: nil, Tint)
+ | Oaddx _ => (Tint :: Tint :: nil, Tint)
+ | Oaddximm _ _ => (Tint :: nil, Tint)
| Oneg => (Tint :: nil, Tint)
| Osub => (Tint :: Tint :: nil, Tint)
+ | Orevsubimm _ => (Tint :: nil, Tint)
+ | Orevsubx _ => (Tint :: Tint :: nil, Tint)
+ | Orevsubximm _ _ => (Tint :: nil, Tint)
| Omul => (Tint :: Tint :: nil, Tint)
| Omulimm _ => (Tint :: nil, Tint)
| Omulhs => (Tint :: Tint :: nil, Tint)
@@ -620,6 +596,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Ororimm _ => (Tint :: nil, Tint)
| Omadd => (Tint :: Tint :: Tint :: nil, Tint)
| Omaddimm _ => (Tint :: Tint :: nil, Tint)
+ | Omsub => (Tint :: Tint :: Tint :: nil, Tint)
| Omakelong => (Tint :: Tint :: nil, Tlong)
| Olowlong => (Tlong :: nil, Tint)
@@ -628,6 +605,11 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Ocast32unsigned => (Tint :: nil, Tlong)
| Oaddl => (Tlong :: Tlong :: nil, Tlong)
| Oaddlimm _ => (Tlong :: nil, Tlong)
+ | Oaddxl _ => (Tlong :: Tlong :: nil, Tlong)
+ | Oaddxlimm _ _ => (Tlong :: nil, Tlong)
+ | Orevsublimm _ => (Tlong :: nil, Tlong)
+ | Orevsubxl _ => (Tlong :: Tlong :: nil, Tlong)
+ | Orevsubxlimm _ _ => (Tlong :: nil, Tlong)
| Onegl => (Tlong :: nil, Tlong)
| Osubl => (Tlong :: Tlong :: nil, Tlong)
| Omull => (Tlong :: Tlong :: nil, Tlong)
@@ -664,19 +646,29 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Oshrxlimm _ => (Tlong :: nil, Tlong)
| Omaddl => (Tlong :: Tlong :: Tlong :: nil, Tlong)
| Omaddlimm _ => (Tlong :: Tlong :: nil, Tlong)
+ | Omsubl => (Tlong :: Tlong :: Tlong :: nil, Tlong)
| Onegf => (Tfloat :: nil, Tfloat)
| Oabsf => (Tfloat :: nil, Tfloat)
- | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat)
- | Osubf => (Tfloat :: Tfloat :: nil, Tfloat)
- | Omulf => (Tfloat :: Tfloat :: nil, Tfloat)
- | Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Oaddf
+ | Osubf
+ | Omulf
+ | Odivf
+ | Ominf
+ | Omaxf => (Tfloat :: Tfloat :: nil, Tfloat)
+ | Ofmaddf | Ofmsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
+
| Onegfs => (Tsingle :: nil, Tsingle)
| Oabsfs => (Tsingle :: nil, Tsingle)
- | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle)
- | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle)
- | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle)
- | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Oaddfs
+ | Osubfs
+ | Omulfs
+ | Odivfs
+ | Ominfs
+ | Omaxfs => (Tsingle :: Tsingle :: nil, Tsingle)
+ | Oinvfs => (Tsingle :: nil, Tsingle)
+ | Ofmaddfs | Ofmsubfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle)
+
| Osingleoffloat => (Tfloat :: nil, Tsingle)
| Ofloatofsingle => (Tsingle :: nil, Tfloat)
| Ointoffloat => (Tfloat :: nil, Tint)
@@ -693,16 +685,14 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Olonguofsingle => (Tsingle :: nil, Tlong)
| Osingleoflong => (Tlong :: nil, Tsingle)
| Osingleoflongu => (Tlong :: nil, Tsingle)
- | Ocmp c => (type_of_condition c, Tint)
-
- | Oselect cond => (Tint :: Tint :: (arg_type_of_condition0 cond) :: nil, Tint)
- | Oselectl cond => (Tlong :: Tlong :: (arg_type_of_condition0 cond) :: nil, Tlong)
- | Oselectf cond => (Tfloat :: Tfloat :: (arg_type_of_condition0 cond) :: nil, Tfloat)
- | Oselectfs cond => (Tsingle :: Tsingle :: (arg_type_of_condition0 cond) :: nil, Tsingle)
+ | Ocmp c => (type_of_condition c, Tint)
| Oextfz _ _ | Oextfs _ _ => (Tint :: nil, Tint)
| Oextfzl _ _ | Oextfsl _ _ => (Tlong :: nil, Tlong)
| Oinsf _ _ => (Tint :: Tint :: nil, Tint)
| Oinsfl _ _ => (Tlong :: Tlong :: nil, Tlong)
+ | Osel c ty => (ty :: ty :: arg_type_of_condition0 c :: nil, ty)
+ | Oselimm c ty => (Tint :: arg_type_of_condition0 c :: nil, Tint)
+ | Osellimm c ty => (Tlong :: arg_type_of_condition0 c :: nil, Tlong)
end.
(* FIXME: two Tptr ?! *)
@@ -736,6 +726,32 @@ Proof.
intros. unfold Val.has_type, Val.addl. destruct Archi.ptr64, v1, v2; auto.
Qed.
+Remark type_sub:
+ forall v1 v2, Val.has_type (Val.sub v1 v2) Tint.
+Proof.
+ intros. unfold Val.has_type, Val.sub. destruct Archi.ptr64, v1, v2; simpl; auto.
+ destruct (eq_block _ _); auto.
+Qed.
+
+Remark type_subl:
+ forall v1 v2, Val.has_type (Val.subl v1 v2) Tlong.
+Proof.
+ intros. unfold Val.has_type, Val.subl. destruct Archi.ptr64, v1, v2; simpl; auto.
+ destruct (eq_block _ _); auto.
+Qed.
+
+Remark type_shl:
+ forall v1 v2, Val.has_type (Val.shl v1 v2) Tint.
+Proof.
+ destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial.
+Qed.
+
+Remark type_shll:
+ forall v1 v2, Val.has_type (Val.shll v1 v2) Tlong.
+Proof.
+ destruct v1, v2; simpl; trivial; destruct (Int.ltu _ _); simpl; trivial.
+Qed.
+
Lemma type_of_operation_sound:
forall op vl sp v m,
op <> Omove ->
@@ -761,9 +777,18 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* add, addimm *)
- apply type_add.
- apply type_add.
+ (* addx, addximm *)
+ - apply type_add.
+ - destruct v0; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
(* neg, sub *)
- destruct v0...
- - unfold Val.sub. destruct v0; destruct v1...
+ - apply type_sub.
+ (* revsubimm, revsubx, revsubximm *)
+ - destruct v0...
+ - apply type_sub.
+ - destruct v0; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
(* mul, mulimm, mulhs, mulhu *)
- destruct v0; destruct v1...
- destruct v0...
@@ -819,8 +844,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* shrimm *)
- destruct v0; simpl...
(* madd *)
- - destruct v0; destruct v1; destruct v2...
- - destruct v0; destruct v1...
+ - apply type_add.
+ - apply type_add.
+ (* msub *)
+ - apply type_sub.
(* makelong, lowlong, highlong *)
- destruct v0; destruct v1...
- destruct v0...
@@ -831,11 +858,17 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* addl, addlimm *)
- apply type_addl.
- apply type_addl.
+ (* addxl addxlimm *)
+ - apply type_addl.
+ - destruct v0; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
(* negl, subl *)
- destruct v0...
- - unfold Val.subl. destruct v0; destruct v1...
- unfold Val.has_type; destruct Archi.ptr64...
- destruct (eq_block b b0)...
+ - apply type_subl.
+ - destruct v0; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
+ - destruct v0...
+ - apply type_subl.
(* mull, mullhs, mullhu *)
- destruct v0; destruct v1...
- destruct v0...
@@ -889,10 +922,10 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* shrxl *)
- destruct v0; simpl in H0; try discriminate. destruct (Int.ltu n (Int.repr 63)); inv H0...
(* maddl, maddlim *)
- - destruct v0; destruct v1; destruct v2; simpl; trivial.
- destruct Archi.ptr64; simpl; trivial.
- - destruct v0; destruct v1; simpl; trivial.
- destruct Archi.ptr64; simpl; trivial.
+ - apply type_addl.
+ - apply type_addl.
+ (* msubl *)
+ - apply type_subl.
(* negf, absf *)
- destruct v0...
- destruct v0...
@@ -902,6 +935,12 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* mulf, divf *)
- destruct v0; destruct v1...
- destruct v0; destruct v1...
+ (* minf, maxf *)
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ (* fmaddf, fmsubf *)
+ - destruct v0; destruct v1; destruct v2...
+ - destruct v0; destruct v1; destruct v2...
(* negfs, absfs *)
- destruct v0...
- destruct v0...
@@ -911,6 +950,14 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
(* mulfs, divfs *)
- destruct v0; destruct v1...
- destruct v0; destruct v1...
+ (* minfs, maxfs *)
+ - destruct v0; destruct v1...
+ - destruct v0; destruct v1...
+ (* invfs *)
+ - destruct v0...
+ (* fmaddfs, fmsubfs *)
+ - destruct v0; destruct v1; destruct v2...
+ - destruct v0; destruct v1; destruct v2...
(* singleoffloat, floatofsingle *)
- destruct v0...
- destruct v0...
@@ -937,43 +984,6 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
- destruct v0; simpl in H0; inv H0...
(* cmp *)
- destruct (eval_condition cond vl m)... destruct b...
- (* select *)
- - destruct v0; destruct v1; simpl in *; try discriminate; trivial.
- destruct cond; destruct v2; simpl in *; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- (* selectl *)
- - destruct v0; destruct v1; simpl in *; try discriminate; trivial.
- destruct cond; destruct v2; simpl in *; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
-
- (* selectf *)
- - destruct v0; destruct v1; simpl in *; try discriminate; trivial.
- destruct cond; destruct v2; simpl in *; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- (* selectfs *)
- - destruct v0; destruct v1; simpl in *; try discriminate; trivial.
- destruct cond; destruct v2; simpl in *; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
- + destruct Archi.ptr64; simpl; trivial.
- destruct (_ && _); simpl; trivial.
- destruct (Val.cmp_different_blocks _); simpl; trivial.
(* extfz *)
- unfold extfz.
destruct (is_bitfield _ _).
@@ -1006,8 +1016,48 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
+ destruct v0; destruct v1; simpl; trivial.
destruct (Int.ltu _ _); simpl; trivial.
+ constructor.
+ (* Osel *)
+ - unfold Val.select. destruct (eval_condition0 _ _ m).
+ + apply Val.normalize_type.
+ + constructor.
+ (* Oselimm *)
+ - unfold Val.select. destruct (eval_condition0 _ _ m).
+ + apply Val.normalize_type.
+ + constructor.
+ (* Osellimm *)
+ - unfold Val.select. destruct (eval_condition0 _ _ m).
+ + apply Val.normalize_type.
+ + constructor.
Qed.
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivl | Odivu | Odivlu
+ | Omod | Omodl | Omodu | Omodlu
+ | Oshrximm _ | Oshrxlimm _
+ | Ointoffloat | Ointuoffloat
+ | Ointofsingle | Ointuofsingle
+ | Olongoffloat | Olonguoffloat
+ | Olongofsingle | Olonguofsingle
+ | Osingleofint | Osingleofintu
+ | Osingleoflong | Osingleoflongu
+ | Ofloatoflong | Ofloatoflongu => true
+ | _ => false
+ end.
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
End SOUNDNESS.
(** * Manipulating and transforming operations *)
@@ -1166,19 +1216,10 @@ Definition op_depends_on_memory (op: operation) : bool :=
| Ocmp (Ccompuimm _ _) => negb Archi.ptr64
| Ocmp (Ccomplu _) => Archi.ptr64
| Ocmp (Ccompluimm _ _) => Archi.ptr64
+
+ | Osel (Ccompu0 _) _ | Oselimm (Ccompu0 _) _ | Osellimm (Ccompu0 _) _ => negb Archi.ptr64
+ | Osel (Ccomplu0 _) _ | Oselimm (Ccomplu0 _) _ | Osellimm (Ccomplu0 _) _ => Archi.ptr64
- | Oselect (Ccompu0 _) => negb Archi.ptr64
- | Oselect (Ccomplu0 _) => Archi.ptr64
-
- | Oselectl (Ccompu0 _) => negb Archi.ptr64
- | Oselectl (Ccomplu0 _) => Archi.ptr64
-
- | Oselectf (Ccompu0 _) => negb Archi.ptr64
- | Oselectf (Ccomplu0 _) => Archi.ptr64
-
- | Oselectfs (Ccompu0 _) => negb Archi.ptr64
- | Oselectfs (Ccomplu0 _) => Archi.ptr64
-
| _ => false
end.
@@ -1187,10 +1228,19 @@ Lemma op_depends_on_memory_correct:
op_depends_on_memory op = false ->
eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
- intros until m2. destruct op; simpl; try congruence;
-
- destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF;
- unfold eval_select, eval_selectl, eval_selectf, eval_selectfs, eval_condition0, Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+ intros until m2. destruct op; simpl; try congruence.
+ - destruct cond; simpl; try congruence;
+ intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+ - destruct c0; simpl; try congruence;
+ intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+ - destruct c0; simpl; try congruence;
+ intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+ - destruct c0; simpl; try congruence;
+ intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
Qed.
(** Global variables mentioned in an operation or addressing mode *)
@@ -1359,9 +1409,19 @@ Proof.
(* add, addimm *)
- apply Val.add_inject; auto.
- apply Val.add_inject; auto.
+ (* addx, addximm *)
+ - apply Val.add_inject; trivial.
+ inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto.
+ - inv H4; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
(* neg, sub *)
- inv H4; simpl; auto.
- apply Val.sub_inject; auto.
+ (* revsubimm, revsubx, revsubximm *)
+ - inv H4; simpl; trivial.
+ - apply Val.sub_inject; trivial.
+ inv H4; inv H2; simpl; try destruct (Int.ltu _ _); simpl; auto.
+ - inv H4; simpl; try destruct (Int.ltu _ _); simpl; auto.
(* mul, mulimm, mulhs, mulhu *)
- inv H4; inv H2; simpl; auto.
- inv H4; simpl; auto.
@@ -1424,6 +1484,9 @@ Proof.
(* madd, maddim *)
- inv H2; inv H3; inv H4; simpl; auto.
- inv H2; inv H4; simpl; auto.
+ (* msub *)
+ - apply Val.sub_inject; auto.
+ inv H3; inv H2; simpl; auto.
(* makelong, highlong, lowlong *)
- inv H4; inv H2; simpl; auto.
- inv H4; simpl; auto.
@@ -1434,9 +1497,21 @@ Proof.
(* addl, addlimm *)
- apply Val.addl_inject; auto.
- apply Val.addl_inject; auto.
+ (* addxl, addxlimm *)
+ - apply Val.addl_inject; auto.
+ inv H4; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
+ - inv H4; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
(* negl, subl *)
- inv H4; simpl; auto.
- apply Val.subl_inject; auto.
+ inv H4; inv H2; simpl; trivial;
+ destruct (Int.ltu _ _); simpl; trivial.
+ - inv H4; simpl; trivial;
+ destruct (Int.ltu _ _); simpl; trivial.
+ - inv H4; simpl; auto.
+ - apply Val.subl_inject; auto.
(* mull, mullhs, mullhu *)
- inv H4; inv H2; simpl; auto.
- inv H4; simpl; auto.
@@ -1500,6 +1575,9 @@ Proof.
inv H2; inv H3; inv H4; simpl; auto.
- apply Val.addl_inject; auto.
inv H4; inv H2; simpl; auto.
+ (* msubl, msublimm *)
+ - apply Val.subl_inject; auto.
+ inv H2; inv H3; inv H4; simpl; auto.
(* negf, absf *)
- inv H4; simpl; auto.
@@ -1510,6 +1588,12 @@ Proof.
(* mulf, divf *)
- inv H4; inv H2; simpl; auto.
- inv H4; inv H2; simpl; auto.
+ (* minf, maxf *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* fmaddf, fmsubf *)
+ - inv H4; inv H3; inv H2; simpl; auto.
+ - inv H4; inv H3; inv H2; simpl; auto.
(* negfs, absfs *)
- inv H4; simpl; auto.
- inv H4; simpl; auto.
@@ -1519,6 +1603,14 @@ Proof.
(* mulfs, divfs *)
- inv H4; inv H2; simpl; auto.
- inv H4; inv H2; simpl; auto.
+ (* minfs, maxfs *)
+ - inv H4; inv H2; simpl; auto.
+ - inv H4; inv H2; simpl; auto.
+ (* invfs *)
+ - inv H4; simpl; auto.
+ (* fmaddfs, fmsubfs *)
+ - inv H4; inv H3; inv H2; simpl; auto.
+ - inv H4; inv H3; inv H2; simpl; auto.
(* singleoffloat, floatofsingle *)
- inv H4; simpl; auto.
- inv H4; simpl; auto.
@@ -1556,62 +1648,6 @@ Proof.
exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
destruct b; simpl; constructor.
simpl; constructor.
- (* select *)
- - unfold eval_select.
- inv H4; trivial.
- inv H2; trivial.
- inv H3; trivial;
- try (destruct cond; simpl; trivial; fail).
- destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial.
- eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b).
- * eapply eval_condition0_inj.
- eapply Val.inject_ptr.
- eassumption.
- reflexivity.
- assumption.
- * rewrite Hcond'. constructor.
- (* selectl *)
- - unfold eval_selectl.
- inv H4; trivial.
- inv H2; trivial.
- inv H3; trivial;
- try (destruct cond; simpl; trivial; fail).
- destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial.
- eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b).
- * eapply eval_condition0_inj.
- eapply Val.inject_ptr.
- eassumption.
- reflexivity.
- assumption.
- * rewrite Hcond'. constructor.
- (* selectf *)
- - unfold eval_selectf.
- inv H4; trivial.
- inv H2; trivial.
- inv H3; trivial;
- try (destruct cond; simpl; trivial; fail).
- destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial.
- eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b).
- * eapply eval_condition0_inj.
- eapply Val.inject_ptr.
- eassumption.
- reflexivity.
- assumption.
- * rewrite Hcond'. constructor.
- (* selectfs *)
- - unfold eval_selectfs.
- inv H4; trivial.
- inv H2; trivial.
- inv H3; trivial;
- try (destruct cond; simpl; trivial; fail).
- destruct (eval_condition0 cond (Vptr _ _) m1) eqn:Hcond; trivial.
- eassert (Hcond' : ((eval_condition0 cond (Vptr b2 (Ptrofs.add ofs1 (Ptrofs.repr delta)))) m2) = Some b).
- * eapply eval_condition0_inj.
- eapply Val.inject_ptr.
- eassumption.
- reflexivity.
- assumption.
- * rewrite Hcond'. constructor.
(* extfz *)
- unfold extfz.
@@ -1652,6 +1688,30 @@ Proof.
simpl. destruct (Int.ltu _ _); trivial.
simpl. trivial.
+ trivial.
+
+ (* Osel *)
+ - apply Val.select_inject; trivial.
+ destruct (eval_condition0 c0 v2 m1) eqn:Hcond.
+ + right.
+ symmetry.
+ eapply eval_condition0_inj; eassumption.
+ + left. trivial.
+
+ (* Oselimm *)
+ - apply Val.select_inject; trivial.
+ destruct (eval_condition0 _ _ _) eqn:Hcond.
+ + right.
+ symmetry.
+ eapply eval_condition0_inj; eassumption.
+ + left. trivial.
+
+ (* Osellimm *)
+ - apply Val.select_inject; trivial.
+ destruct (eval_condition0 _ _ _) eqn:Hcond.
+ + right.
+ symmetry.
+ eapply eval_condition0_inj; eassumption.
+ + left. trivial.
Qed.
Lemma eval_addressing_inj:
@@ -1674,6 +1734,27 @@ Proof.
- apply Val.offset_ptr_inject; auto.
Qed.
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *.
+ 1,2: inv Hinjvl; trivial;
+ inv H0; trivial;
+ inv H2; trivial;
+ discriminate.
+ 2,3: inv Hinjvl; trivial; discriminate.
+ inv Hinjvl; trivial; inv H0; trivial;
+ inv H; trivial; discriminate.
+Qed.
+
End EVAL_COMPAT.
(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
@@ -1780,6 +1861,24 @@ Proof.
destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.
+
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros until vl2. intros Hlessdef Heval1.
+ destruct addr; simpl in *.
+ 1, 2, 4, 5: inv Hlessdef; trivial;
+ inv H0; trivial;
+ inv H2; trivial;
+ discriminate.
+ inv Hlessdef; trivial.
+ inv H0; trivial.
+ discriminate.
+Qed.
+
End EVAL_LESSDEF.
(** Compatibility of the evaluation functions with memory injections. *)
@@ -1832,6 +1931,19 @@ Proof.
econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
Lemma eval_operation_inject:
forall op vl1 vl2 v1 m1 m2,
Val.inject_list f vl1 vl2 ->
diff --git a/mppa_k1c/Peephole.v b/mppa_k1c/Peephole.v
index 7c8f65a8..0611fdda 100644
--- a/mppa_k1c/Peephole.v
+++ b/mppa_k1c/Peephole.v
@@ -2,6 +2,7 @@ Require Import Coqlib.
Require Import Asmvliw.
Require Import Values.
Require Import Integers.
+Require Import AST.
Require Compopts.
Definition gpreg_q_list : list gpreg_q :=
@@ -89,8 +90,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic :=
| None => h0 :: (coalesce_mem t0)
end
- | (PLoadRRO Pld_a rd0 ra0 ofs0),
- (PLoadRRO Pld_a rd1 ra1 ofs1) =>
+ | (PLoad (PLoadRRO TRAP Pld_a rd0 ra0 ofs0)),
+ (PLoad (PLoadRRO TRAP Pld_a rd1 ra1 ofs1)) =>
match gpreg_q_search rd0 rd1 with
| Some rd0rd1 =>
let zofs0 := Ptrofs.signed ofs0 in
@@ -100,8 +101,8 @@ Fixpoint coalesce_mem (insns : list basic) : list basic :=
if coalesce_octuples
then
match t1 with
- | (PLoadRRO Pld_a rd2 ra2 ofs2) ::
- (PLoadRRO Pld_a rd3 ra3 ofs3) :: t3 =>
+ | (PLoad (PLoadRRO TRAP Pld_a rd2 ra2 ofs2)) ::
+ (PLoad (PLoadRRO TRAP Pld_a rd3 ra3 ofs3)) :: t3 =>
match gpreg_o_search rd0 rd1 rd2 rd3 with
| Some octuple =>
let zofs2 := Ptrofs.signed ofs2 in
diff --git a/mppa_k1c/PostpassScheduling.v b/mppa_k1c/PostpassScheduling.v
index 15cb4c48..31180cea 100644
--- a/mppa_k1c/PostpassScheduling.v
+++ b/mppa_k1c/PostpassScheduling.v
@@ -12,14 +12,14 @@
Require Import Coqlib Errors AST Integers.
Require Import Asmblock Axioms Memory Globalenvs.
-Require Import Asmblockdeps Asmblockgenproof0.
+Require Import Asmblockdeps Asmblockgenproof0 Asmblockprops.
Require Peephole.
Local Open Scope error_monad_scope.
(** Oracle taking as input a basic block,
returns a schedule expressed as a list of bundles *)
-Axiom schedule: bblock -> list bblock.
+Axiom schedule: bblock -> (list (list basic)) * option control.
Extract Constant schedule => "PostpassSchedulingOracle.schedule".
@@ -208,7 +208,8 @@ Proof.
+ apply IHlbb in EQ. assumption.
Qed.
-
+Inductive is_concat : bblock -> list bblock -> Prop :=
+ | mk_is_concat: forall tbb lbb, concat_all lbb = OK tbb -> is_concat tbb lbb.
Definition verify_schedule (bb bb' : bblock) : res unit :=
match bblock_simub bb bb' with
@@ -333,10 +334,49 @@ Proof.
apply stick_header_concat_all. assumption.
Qed.
+Program Definition make_bblock_from_basics lb :=
+ match lb with
+ | nil => Error (msg "PostpassScheduling.make_bblock_from_basics")
+ | b :: lb => OK {| header := nil; body := b::lb; exit := None |}
+ end.
+
+Fixpoint schedule_to_bblocks_nocontrol llb :=
+ match llb with
+ | nil => OK nil
+ | lb :: llb => do bb <- make_bblock_from_basics lb;
+ do lbb <- schedule_to_bblocks_nocontrol llb;
+ OK (bb :: lbb)
+ end.
+
+Program Definition make_bblock_from_basics_and_control lb c :=
+ match c with
+ | PExpand (Pbuiltin _ _ _) => Error (msg "PostpassScheduling.make_bblock_from_basics_and_control")
+ | PCtlFlow cf => OK {| header := nil; body := lb; exit := Some (PCtlFlow cf) |}
+ end.
+Next Obligation.
+ apply wf_bblock_refl. constructor.
+ - right. discriminate.
+ - discriminate.
+Qed.
+
+Fixpoint schedule_to_bblocks_wcontrol llb c :=
+ match llb with
+ | nil => OK ((bblock_single_inst (PControl c)) :: nil)
+ | lb :: nil => do bb <- make_bblock_from_basics_and_control lb c; OK (bb :: nil)
+ | lb :: llb => do bb <- make_bblock_from_basics lb;
+ do lbb <- schedule_to_bblocks_wcontrol llb c;
+ OK (bb :: lbb)
+ end.
+Definition schedule_to_bblocks (llb: list (list basic)) (oc: option control) : res (list bblock) :=
+ match oc with
+ | None => schedule_to_bblocks_nocontrol llb
+ | Some c => schedule_to_bblocks_wcontrol llb c
+ end.
-Definition do_schedule (bb: bblock) : list bblock :=
- if (Z.eqb (size bb) 1) then bb::nil else schedule bb.
+Definition do_schedule (bb: bblock) : res (list bblock) :=
+ if (Z.eqb (size bb) 1) then OK (bb::nil)
+ else match (schedule bb) with (llb, oc) => schedule_to_bblocks llb oc end.
Definition verify_par_bblock (bb: bblock) : res unit :=
if (bblock_para_check bb) then OK tt else Error (msg "PostpassScheduling.verify_par_bblock").
@@ -350,7 +390,7 @@ Fixpoint verify_par (lbb: list bblock) :=
Definition verified_schedule_nob (bb : bblock) : res (list bblock) :=
let bb' := no_header bb in
let bb'' := Peephole.optimize_bblock bb' in
- let lbb := do_schedule bb'' in
+ do lbb <- do_schedule bb'';
do tbb <- concat_all lbb;
do sizecheck <- verify_size bb lbb;
do schedcheck <- verify_schedule bb' tbb;
@@ -363,7 +403,7 @@ Lemma verified_schedule_nob_size:
Proof.
intros. monadInv H. erewrite <- stick_header_code_size; eauto.
apply verify_size_size.
- destruct x0; try discriminate. assumption.
+ destruct x1; try discriminate. assumption.
Qed.
Lemma verified_schedule_nob_no_header_in_middle:
@@ -382,7 +422,7 @@ Lemma verified_schedule_nob_header:
/\ Forall (fun b => header b = nil) lbb.
Proof.
intros. split.
- - monadInv H. unfold stick_header_code in EQ2. destruct (hd_error _); try discriminate. inv EQ2.
+ - monadInv H. unfold stick_header_code in EQ3. destruct (hd_error _); try discriminate. inv EQ3.
simpl. reflexivity.
- apply verified_schedule_nob_no_header_in_middle in H. assumption.
Qed.
@@ -427,29 +467,29 @@ Qed.
Lemma verified_schedule_nob_correct:
forall ge f bb lbb,
verified_schedule_nob bb = OK lbb ->
- exists tbb,
- concat_all lbb = OK tbb
+ exists tbb,
+ is_concat tbb lbb
/\ bblock_simu ge f bb tbb.
Proof.
intros. monadInv H.
exploit stick_header_code_concat_all; eauto.
intros (tbb & CONC & STH).
- exists tbb. split; auto.
- rewrite verify_schedule_no_header in EQ0. erewrite stick_header_verify_schedule in EQ0; eauto.
- eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ0.
+ exists tbb. split; auto. constructor; auto.
+ rewrite verify_schedule_no_header in EQ2. erewrite stick_header_verify_schedule in EQ2; eauto.
+ eapply bblock_simub_correct; eauto. unfold verify_schedule in EQ2.
destruct (bblock_simub _ _); auto; try discriminate.
Qed.
Theorem verified_schedule_correct:
forall ge f bb lbb,
verified_schedule bb = OK lbb ->
- exists tbb,
- concat_all lbb = OK tbb
+ exists tbb,
+ is_concat tbb lbb
/\ bblock_simu ge f bb tbb.
Proof.
intros. unfold verified_schedule in H. destruct (exit bb). destruct c. destruct i.
all: try (eapply verified_schedule_nob_correct; eauto; fail).
- inv H. eexists. split; simpl; auto. constructor; auto.
+ inv H. eexists. split; simpl; auto. constructor; auto. simpl; auto. constructor; auto.
Qed.
Lemma verified_schedule_builtin_idem:
diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml
index 7015fd5f..686979a6 100644
--- a/mppa_k1c/PostpassSchedulingOracle.ml
+++ b/mppa_k1c/PostpassSchedulingOracle.ml
@@ -15,186 +15,270 @@ type immediate = I32 of Integers.Int.int | I64 of Integers.Int64.int | Off of of
type location = Reg of preg | Mem
+type real_instruction =
+ (* ALU *)
+ | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sbfxw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw
+ | Addd | Andd | Compd | Muld | Ord | Sbfd | Sbfxd | Srad | Srld | Slld | Srsd | Xord
+ | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd
+ | Maddw | Maddd | Msbfw | Msbfd | Cmoved
+ | Make | Nop | Extfz | Extfs | Insf
+ | Addxw | Addxd
+ (* LSU *)
+ | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo
+ | Sb | Sh | Sw | Sd | Sq | So
+ (* BCU *)
+ | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set
+ (* FPU *)
+ | Fabsd | Fabsw | Fnegw | Fnegd
+ | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw
+ | Fmind | Fminw | Fmaxd | Fmaxw | Finvw
+ | Ffmaw | Ffmad | Ffmsw | Ffmsd
+ | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz
+ | Fcompw | Fcompd
+
type ab_inst_rec = {
- inst: string; (* name of the pseudo instruction *)
+ inst: real_instruction;
write_locs : location list;
read_locs : location list;
+ read_at_id : location list; (* Must be contained in read_locs *)
+ read_at_e1 : location list; (* idem *)
imm : immediate option;
is_control : bool;
}
-(** Asmvliw constructor to string functions *)
+(** Asmvliw constructor to real instructions *)
exception OpaqueInstruction
-let arith_rr_str = function
- | Pcvtl2w -> "Pcvtl2w"
- | Pmv -> "Pmv"
- | Pnegw -> "Pnegw"
- | Pnegl -> "Pnegl"
- | Psxwd -> "Psxwd"
- | Pzxwd -> "Pzxwd"
- | Pextfz(_,_) -> "Pextfz"
- | Pextfs(_,_) -> "Pextfs"
- | Pextfzl(_,_) -> "Pextfzl"
- | Pextfsl(_,_) -> "Pextfsl"
- | Pfabsw -> "Pfabsw"
- | Pfabsd -> "Pfabsd"
- | Pfnegw -> "Pfnegw"
- | Pfnegd -> "Pfnegd"
- | Pfnarrowdw -> "Pfnarrowdw"
- | Pfwidenlwd -> "Pfwidenlwd"
- | Pfloatwrnsz -> "Pfloatwrnsz"
- | Pfloatuwrnsz -> "Pfloatuwrnsz"
- | Pfloatudrnsz -> "Pfloatudrnsz"
- | Pfloatdrnsz -> "Pfloatdrnsz"
- | Pfixedwrzz -> "Pfixedwrzz"
- | Pfixeduwrzz -> "Pfixeduwrzz"
- | Pfixeddrzz -> "Pfixeddrzz"
- | Pfixedudrzz -> "Pfixedudrzz"
- | Pfixeddrzz_i32 -> "Pfixeddrzz_i32"
- | Pfixedudrzz_i32 -> "Pfixedudrzz_i32"
-
-let arith_rrr_str = function
- | Pcompw it -> "Pcompw"
- | Pcompl it -> "Pcompl"
- | Pfcompw ft -> "Pfcompw"
- | Pfcompl ft -> "Pfcompl"
- | Paddw -> "Paddw"
- | Psubw -> "Psubw"
- | Pmulw -> "Pmulw"
- | Pandw -> "Pandw"
- | Pnandw -> "Pnandw"
- | Porw -> "Porw"
- | Pnorw -> "Pnorw"
- | Pxorw -> "Pxorw"
- | Pnxorw -> "Pnxorw"
- | Pandnw -> "Pandnw"
- | Pornw -> "Pornw"
- | Psraw -> "Psraw"
- | Psrlw -> "Psrlw"
- | Psrxw -> "Psrxw"
- | Psllw -> "Psllw"
- | Paddl -> "Paddl"
- | Psubl -> "Psubl"
- | Pandl -> "Pandl"
- | Pnandl -> "Pnandl"
- | Porl -> "Porl"
- | Pnorl -> "Pnorl"
- | Pxorl -> "Pxorl"
- | Pnxorl -> "Pnxorl"
- | Pandnl -> "Pandnl"
- | Pornl -> "Pornl"
- | Pmull -> "Pmull"
- | Pslll -> "Pslll"
- | Psrll -> "Psrll"
- | Psrxl -> "Psrxl"
- | Psral -> "Psral"
- | Pfaddd -> "Pfaddd"
- | Pfaddw -> "Pfaddw"
- | Pfsbfd -> "Pfsbfd"
- | Pfsbfw -> "Pfsbfw"
- | Pfmuld -> "Pfmuld"
- | Pfmulw -> "Pfmulw"
-
-let arith_rri32_str = function
- | Pcompiw it -> "Pcompiw"
- | Paddiw -> "Paddiw"
- | Pmuliw -> "Pmuliw"
- | Pandiw -> "Pandiw"
- | Pnandiw -> "Pnandiw"
- | Poriw -> "Poriw"
- | Pnoriw -> "Pnoriw"
- | Pxoriw -> "Pxoriw"
- | Pnxoriw -> "Pnxoriw"
- | Pandniw -> "Pandniw"
- | Porniw -> "Porniw"
- | Psraiw -> "Psraiw"
- | Psrxiw -> "Psrxiw"
- | Psrliw -> "Psrliw"
- | Pslliw -> "Pslliw"
- | Proriw -> "Proriw"
- | Psllil -> "Psllil"
- | Psrlil -> "Psrlil"
- | Psrail -> "Psrail"
- | Psrxil -> "Psrxil"
-
-let arith_rri64_str = function
- | Pcompil it -> "Pcompil"
- | Paddil -> "Paddil"
- | Pmulil -> "Pmulil"
- | Pandil -> "Pandil"
- | Pnandil -> "Pnandil"
- | Poril -> "Poril"
- | Pnoril -> "Pnoril"
- | Pxoril -> "Pxoril"
- | Pnxoril -> "Pnxoril"
- | Pandnil -> "Pandnil"
- | Pornil -> "Pornil"
-
-
-let arith_arr_str = function
- | Pinsf (_, _) -> "Pinsf"
- | Pinsfl (_, _) -> "Pinsfl"
-
-let arith_arrr_str = function
- | Pmaddw -> "Pmaddw"
- | Pmaddl -> "Pmaddl"
- | Pcmove _ -> "Pcmove"
- | Pcmoveu _ -> "Pcmoveu"
-
-let arith_ri32_str = "Pmake"
-
-let arith_ri64_str = "Pmakel"
-
-let arith_rf32_str = "Pmakefs"
-
-let arith_rf64_str = "Pmakef"
-
-let store_str = function
- | Psb -> "Psb"
- | Psh -> "Psh"
- | Psw -> "Psw"
- | Psw_a -> "Psw_a"
- | Psd -> "Psd"
- | Psd_a -> "Psd_a"
- | Pfss -> "Pfss"
- | Pfsd -> "Pfsd"
-
-let load_str = function
- | Plb -> "Plb"
- | Plbu -> "Plbu"
- | Plh -> "Plh"
- | Plhu -> "Plhu"
- | Plw -> "Plw"
- | Plw_a -> "Plw_a"
- | Pld -> "Pld"
- | Pld_a -> "Pld_a"
- | Pfls -> "Pfls"
- | Pfld -> "Pfld"
-
-let set_str = "Pset"
-let get_str = "Pget"
-
-let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false }
-
-let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false }
-
-let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_str i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false}
-
-let arith_arri32_rec i rd rs imm32 = { inst = "Pmaddiw"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false }
-
-let arith_arri64_rec i rd rs imm64 = { inst = "Pmaddil"; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false }
-
-let arith_arr_rec i rd rs = { inst = arith_arr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false}
-
-let arith_arrr_rec i rd rs1 rs2 = { inst = arith_arrr_str i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false}
-
-let arith_rr_rec i rd rs = { inst = arith_rr_str i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false}
+let arith_rr_real = function
+ | Pcvtl2w -> Addw
+ | Pmv -> Addd
+ | Pnegw -> Sbfw
+ | Pnegl -> Sbfd
+ | Psxwd -> Extfs
+ | Pzxwd -> Extfz
+ | Pextfz(_,_) -> Extfz
+ | Pextfs(_,_) -> Extfs
+ | Pextfzl(_,_) -> Extfz
+ | Pextfsl(_,_) -> Extfs
+ | Pfabsw -> Fabsw
+ | Pfabsd -> Fabsd
+ | Pfnegw -> Fnegw
+ | Pfnegd -> Fnegd
+ | Pfinvw -> Finvw
+ | Pfnarrowdw -> Fnarrowdw
+ | Pfwidenlwd -> Fwidenlwd
+ | Pfloatwrnsz -> Floatwz
+ | Pfloatuwrnsz -> Floatuwz
+ | Pfloatudrnsz -> Floatudz
+ | Pfloatdrnsz -> Floatdz
+ | Pfixedwrzz -> Fixedwz
+ | Pfixeduwrzz -> Fixeduwz
+ | Pfixeddrzz -> Fixeddz
+ | Pfixedudrzz -> Fixedudz
+ | Pfixeddrzz_i32 -> Fixeddz
+ | Pfixedudrzz_i32 -> Fixedudz
+
+let arith_rrr_real = function
+ | Pcompw it -> Compw
+ | Pcompl it -> Compd
+ | Pfcompw ft -> Fcompw
+ | Pfcompl ft -> Fcompd
+ | Paddw -> Addw
+ | Paddxw _ -> Addxw
+ | Psubw -> Sbfw
+ | Prevsubxw _ -> Sbfxw
+ | Pmulw -> Mulw
+ | Pandw -> Andw
+ | Pnandw -> Nandw
+ | Porw -> Orw
+ | Pnorw -> Norw
+ | Pxorw -> Xorw
+ | Pnxorw -> Nxorw
+ | Pandnw -> Andnw
+ | Pornw -> Ornw
+ | Psraw -> Sraw
+ | Psrlw -> Srlw
+ | Psrxw -> Srsw
+ | Psllw -> Sllw
+ | Paddl -> Addd
+ | Paddxl _ -> Addxd
+ | Psubl -> Sbfd
+ | Prevsubxl _ -> Sbfxd
+ | Pandl -> Andd
+ | Pnandl -> Nandd
+ | Porl -> Ord
+ | Pnorl -> Nord
+ | Pxorl -> Xord
+ | Pnxorl -> Nxord
+ | Pandnl -> Andnd
+ | Pornl -> Ornd
+ | Pmull -> Muld
+ | Pslll -> Slld
+ | Psrll -> Srld
+ | Psrxl -> Srsd
+ | Psral -> Srad
+ | Pfaddd -> Faddd
+ | Pfaddw -> Faddw
+ | Pfsbfd -> Fsbfd
+ | Pfsbfw -> Fsbfw
+ | Pfmuld -> Fmuld
+ | Pfmulw -> Fmulw
+ | Pfmind -> Fmind
+ | Pfminw -> Fminw
+ | Pfmaxd -> Fmaxd
+ | Pfmaxw -> Fmaxw
+
+let arith_rri32_real = function
+ | Pcompiw it -> Compw
+ | Paddiw -> Addw
+ | Paddxiw _ -> Addxw
+ | Prevsubiw -> Sbfw
+ | Prevsubxiw _ -> Sbfxw
+ | Pmuliw -> Mulw
+ | Pandiw -> Andw
+ | Pnandiw -> Nandw
+ | Poriw -> Orw
+ | Pnoriw -> Norw
+ | Pxoriw -> Xorw
+ | Pnxoriw -> Nxorw
+ | Pandniw -> Andnw
+ | Porniw -> Ornw
+ | Psraiw -> Sraw
+ | Psrxiw -> Srsw
+ | Psrliw -> Srlw
+ | Pslliw -> Sllw
+ | Proriw -> Rorw
+ | Psllil -> Slld
+ | Psrlil -> Srld
+ | Psrail -> Srad
+ | Psrxil -> Srsd
+
+let arith_rri64_real = function
+ | Pcompil it -> Compd
+ | Paddil -> Addd
+ | Prevsubil -> Sbfd
+ | Paddxil _ -> Addxd
+ | Prevsubxil _ -> Sbfxd
+ | Pmulil -> Muld
+ | Pandil -> Andd
+ | Pnandil -> Nandd
+ | Poril -> Ord
+ | Pnoril -> Nord
+ | Pxoril -> Xord
+ | Pnxoril -> Nxord
+ | Pandnil -> Andnd
+ | Pornil -> Ornd
+
+
+let arith_arr_real = function
+ | Pinsf (_, _) -> Insf
+ | Pinsfl (_, _) -> Insf
+
+let arith_arrr_real = function
+ | Pfmaddfw -> Ffmaw
+ | Pfmaddfl -> Ffmad
+ | Pfmsubfw -> Ffmsw
+ | Pfmsubfl -> Ffmsd
+ | Pmaddw -> Maddw
+ | Pmaddl -> Maddd
+ | Pmsubw -> Msbfw
+ | Pmsubl -> Msbfd
+ | Pcmove _ -> Cmoved
+ | Pcmoveu _ -> Cmoved
+
+let arith_arri32_real = function
+ | Pmaddiw -> Maddw
+ | Pcmoveiw _ -> Cmoved
+ | Pcmoveuiw _ -> Cmoved
+
+let arith_arri64_real = function
+ | Pmaddil -> Maddd
+ | Pcmoveil _ -> Cmoved
+ | Pcmoveuil _ -> Cmoved
+
+let arith_ri32_real = Make
+
+let arith_ri64_real = Make
+
+let arith_rf32_real = Make
+
+let arith_rf64_real = Make
+
+let store_real = function
+ | Psb -> Sb
+ | Psh -> Sh
+ | Psw -> Sw
+ | Psw_a -> Sw
+ | Psd -> Sd
+ | Psd_a -> Sd
+ | Pfss -> Sw
+ | Pfsd -> Sd
+
+let load_real = function
+ | Plb -> Lbs
+ | Plbu -> Lbz
+ | Plh -> Lhs
+ | Plhu -> Lhz
+ | Plw -> Lws
+ | Plw_a -> Lws
+ | Pld -> Ld
+ | Pld_a -> Ld
+ | Pfls -> Lws
+ | Pfld -> Ld
+
+let set_real = Set
+let get_real = Get
+let nop_real = Nop
+let loadsymbol_real = Make
+let loadqrro_real = Lq
+let loadorro_real = Lo
+let storeqrro_real = Sq
+let storeorro_real = So
+
+let ret_real = Ret
+let call_real = Call
+let icall_real = Icall
+let goto_real = Goto
+let igoto_real = Igoto
+let jl_real = Goto
+let cb_real = Cb
+let cbu_real = Cb
+
+let arith_rri32_rec i rd rs imm32 = { inst = arith_rri32_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm32; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+
+let arith_rri64_rec i rd rs imm64 = { inst = arith_rri64_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = imm64; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+
+let arith_rrr_rec i rd rs1 rs2 = { inst = arith_rrr_real i; write_locs = [Reg rd]; read_locs = [Reg rs1; Reg rs2]; imm = None; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+
+let arith_arri32_rec i rd rs imm32 =
+ let rae1 = match i with Pmaddiw -> [Reg rd] | _ -> []
+ in { inst = arith_arri32_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm32; is_control = false;
+ read_at_id = [] ; read_at_e1 = rae1 }
+
+let arith_arri64_rec i rd rs imm64 =
+ let rae1 = match i with Pmaddil -> [Reg rd] | _ -> []
+ in { inst = arith_arri64_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = imm64; is_control = false;
+ read_at_id = []; read_at_e1 = rae1 }
+
+let arith_arr_rec i rd rs = { inst = arith_arr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs]; imm = None; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+
+let arith_arrr_rec i rd rs1 rs2 =
+ let rae1 = match i with Pmaddl | Pmaddw | Pmsubl | Pmsubw -> [Reg rd] | _ -> []
+ in { inst = arith_arrr_real i; write_locs = [Reg rd]; read_locs = [Reg rd; Reg rs1; Reg rs2]; imm = None; is_control = false;
+ read_at_id = []; read_at_e1 = rae1 }
+
+let arith_rr_rec i rd rs = { inst = arith_rr_real i; write_locs = [Reg rd]; read_locs = [Reg rs]; imm = None; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
let arith_r_rec i rd = match i with
(* For Ploadsymbol, writing the highest integer since we do not know how many bits does a symbol have *)
- | Ploadsymbol (id, ofs) -> { inst = "Ploadsymbol"; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed); is_control = false}
+ | Ploadsymbol (id, ofs) -> { inst = loadsymbol_real; write_locs = [Reg rd]; read_locs = []; imm = Some (I64 Integers.Int64.max_signed);
+ is_control = false; read_at_id = []; read_at_e1 = [] }
let arith_rec i =
match i with
@@ -203,48 +287,57 @@ let arith_rec i =
| PArithRRR (i, rd, rs1, rs2) -> arith_rrr_rec i (IR rd) (IR rs1) (IR rs2)
| PArithARR (i, rd, rs) -> arith_arr_rec i (IR rd) (IR rs)
(* Seems like single constant constructor types are elided *)
- | PArithARRI32 ((* i,*) rd, rs, imm32) -> arith_arri32_rec () (IR rd) (IR rs) (Some (I32 imm32))
- | PArithARRI64 ((* i,*) rd, rs, imm64) -> arith_arri64_rec () (IR rd) (IR rs) (Some (I64 imm64))
+ | PArithARRI32 (i, rd, rs, imm32) -> arith_arri32_rec i (IR rd) (IR rs) (Some (I32 imm32))
+ | PArithARRI64 (i, rd, rs, imm64) -> arith_arri64_rec i (IR rd) (IR rs) (Some (I64 imm64))
| PArithARRR (i, rd, rs1, rs2) -> arith_arrr_rec i (IR rd) (IR rs1) (IR rs2)
- | PArithRI32 (rd, imm32) -> { inst = arith_ri32_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false}
- | PArithRI64 (rd, imm64) -> { inst = arith_ri64_str; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false}
- | PArithRF32 (rd, f) -> { inst = arith_rf32_str; write_locs = [Reg (IR rd)]; read_locs = [];
- imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false}
- | PArithRF64 (rd, f) -> { inst = arith_rf64_str; write_locs = [Reg (IR rd)]; read_locs = [];
- imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false}
+ | PArithRI32 (rd, imm32) -> { inst = arith_ri32_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I32 imm32)) ; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+ | PArithRI64 (rd, imm64) -> { inst = arith_ri64_real; write_locs = [Reg (IR rd)]; read_locs = []; imm = (Some (I64 imm64)) ; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
+ | PArithRF32 (rd, f) -> { inst = arith_rf32_real; write_locs = [Reg (IR rd)]; read_locs = [];
+ imm = (Some (I32 (Floats.Float32.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []}
+ | PArithRF64 (rd, f) -> { inst = arith_rf64_real; write_locs = [Reg (IR rd)]; read_locs = [];
+ imm = (Some (I64 (Floats.Float.to_bits f))); is_control = false; read_at_id = []; read_at_e1 = []}
| PArithRR (i, rd, rs) -> arith_rr_rec i (IR rd) (IR rs)
| PArithR (i, rd) -> arith_r_rec i (IR rd)
let load_rec i = match i with
- | PLoadRRO (i, rs1, rs2, imm) ->
- { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false}
+ | PLoadRRO (trap, i, rs1, rs2, imm) ->
+ { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2)]; imm = (Some (Off imm)) ; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
| PLoadQRRO(rs, ra, imm) ->
let (rs0, rs1) = gpreg_q_expand rs in
- { inst = "Plq"; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false}
+ { inst = loadqrro_real; write_locs = [Reg (IR rs0); Reg (IR rs1)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
| PLoadORRO(rs, ra, imm) ->
let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in
- { inst = "Plo"; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)]; imm = (Some (Off imm)) ; is_control = false}
- | PLoadRRR (i, rs1, rs2, rs3) | PLoadRRRXS (i, rs1, rs2, rs3) ->
- { inst = load_str i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false}
+ { inst = loadorro_real; write_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; read_locs = [Mem; Reg (IR ra)];
+ imm = (Some (Off imm)) ; is_control = false; read_at_id = []; read_at_e1 = []}
+ | PLoadRRR (trap, i, rs1, rs2, rs3) | PLoadRRRXS (trap, i, rs1, rs2, rs3) ->
+ { inst = load_real i; write_locs = [Reg (IR rs1)]; read_locs = [Mem; Reg (IR rs2); Reg (IR rs3)]; imm = None ; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
let store_rec i = match i with
- | PStoreRRO (i, rs1, rs2, imm) ->
- { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2)]; imm = (Some (Off imm))
- ; is_control = false}
+ | PStoreRRO (i, rs, ra, imm) ->
+ { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra)]; imm = (Some (Off imm));
+ read_at_id = []; read_at_e1 = [Reg (IR rs)] ; is_control = false}
| PStoreQRRO (rs, ra, imm) ->
let (rs0, rs1) = gpreg_q_expand rs in
- { inst = "Psq"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm))
- ; is_control = false}
+ { inst = storeqrro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR ra)]; imm = (Some (Off imm));
+ read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1)] ; is_control = false}
| PStoreORRO (rs, ra, imm) ->
let (((rs0, rs1), rs2), rs3) = gpreg_o_expand rs in
- { inst = "Pso"; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)]; imm = (Some (Off imm))
- ; is_control = false}
- | PStoreRRR (i, rs1, rs2, rs3) | PStoreRRRXS (i, rs1, rs2, rs3) -> { inst = store_str i; write_locs = [Mem]; read_locs = [Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; imm = None
- ; is_control = false}
+ { inst = storeorro_real; write_locs = [Mem]; read_locs = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3); Reg (IR ra)];
+ imm = (Some (Off imm)); read_at_id = []; read_at_e1 = [Reg (IR rs0); Reg (IR rs1); Reg (IR rs2); Reg (IR rs3)]; is_control = false}
+ | PStoreRRR (i, rs, ra1, ra2) | PStoreRRRXS (i, rs, ra1, ra2) ->
+ { inst = store_real i; write_locs = [Mem]; read_locs = [Reg (IR rs); Reg (IR ra1); Reg (IR ra2)]; imm = None;
+ read_at_id = []; read_at_e1 = [Reg (IR rs)]; is_control = false}
-let get_rec (rd:gpreg) rs = { inst = get_str; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false }
+let get_rec (rd:gpreg) rs = { inst = get_real; write_locs = [Reg (IR rd)]; read_locs = [Reg rs]; imm = None; is_control = false;
+ read_at_id = []; read_at_e1 = [] }
-let set_rec rd (rs:gpreg) = { inst = set_str; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false }
+let set_rec rd (rs:gpreg) = { inst = set_real; write_locs = [Reg rd]; read_locs = [Reg (IR rs)]; imm = None; is_control = false;
+ read_at_id = [Reg (IR rs)]; read_at_e1 = [] }
let basic_rec i =
match i with
@@ -255,21 +348,25 @@ let basic_rec i =
| Pfreeframe (_, _) -> raise OpaqueInstruction
| Pget (rd, rs) -> get_rec rd rs
| Pset (rd, rs) -> set_rec rd rs
- | Pnop -> { inst = "nop"; write_locs = []; read_locs = []; imm = None ; is_control = false}
+ | Pnop -> { inst = nop_real; write_locs = []; read_locs = []; imm = None ; is_control = false; read_at_id = []; read_at_e1 = []}
let expand_rec = function
| Pbuiltin _ -> raise OpaqueInstruction
let ctl_flow_rec = function
- | Pret -> { inst = "Pret"; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true}
- | Pcall lbl -> { inst = "Pcall"; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true}
- | Picall r -> { inst = "Picall"; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true}
- | Pgoto lbl -> { inst = "Pcall"; write_locs = []; read_locs = []; imm = None ; is_control = true}
- | Pigoto r -> { inst = "Pigoto"; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true}
- | Pj_l lbl -> { inst = "Pj_l"; write_locs = []; read_locs = []; imm = None ; is_control = true}
- | Pcb (bt, rs, lbl) -> { inst = "Pcb"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true}
- | Pcbu (bt, rs, lbl) -> { inst = "Pcbu"; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true}
- | Pjumptable (r, _) -> { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true}
+ | Pret -> { inst = ret_real; write_locs = []; read_locs = [Reg RA]; imm = None ; is_control = true; read_at_id = [Reg RA]; read_at_e1 = []}
+ | Pcall lbl -> { inst = call_real; write_locs = [Reg RA]; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}
+ | Picall r -> { inst = icall_real; write_locs = [Reg RA]; read_locs = [Reg (IR r)]; imm = None; is_control = true;
+ read_at_id = [Reg (IR r)]; read_at_e1 = [] }
+ | Pgoto lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}
+ | Pigoto r -> { inst = igoto_real; write_locs = []; read_locs = [Reg (IR r)]; imm = None ; is_control = true;
+ read_at_id = [Reg (IR r)]; read_at_e1 = [] }
+ | Pj_l lbl -> { inst = goto_real; write_locs = []; read_locs = []; imm = None ; is_control = true; read_at_id = []; read_at_e1 = []}
+ | Pcb (bt, rs, lbl) -> { inst = cb_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true;
+ read_at_id = [Reg (IR rs)]; read_at_e1 = [] }
+ | Pcbu (bt, rs, lbl) -> { inst = cbu_real; write_locs = []; read_locs = [Reg (IR rs)]; imm = None ; is_control = true;
+ read_at_id = [Reg (IR rs)]; read_at_e1 = [] }
+ | Pjumptable (r, _) -> raise OpaqueInstruction (* { inst = "Pjumptable"; write_locs = [Reg (IR GPR62); Reg (IR GPR63)]; read_locs = [Reg (IR r)]; imm = None ; is_control = true} *)
let control_rec i =
match i with
@@ -294,6 +391,8 @@ let instruction_recs bb = (basic_recs bb.body) @ (exit_rec bb.exit)
type inst_info = {
write_locs : location list;
read_locs : location list;
+ reads_at_id : bool;
+ reads_at_e1 : bool;
is_control : bool;
usage: int array; (* resources consumed by the instruction *)
latency: int;
@@ -343,7 +442,9 @@ let encode_imm (imm:int64) =
else failwith @@ sprintf "encode_imm: integer too big! (%Ld)" imm
(** Resources *)
-let resource_names = ["ISSUE"; "TINY"; "LITE"; "ALU"; "LSU"; "MAU"; "BCU"; "ACC"; "DATA"; "TCA"; "BRE"; "BRO"; "NOP"]
+type rname = Rissue | Rtiny | Rlite | Rfull | Rlsu | Rmau | Rbcu | Rtca | Rauxr | Rauxw | Rcrrp | Rcrwl | Rcrwh | Rnop
+
+let resource_names = [Rissue; Rtiny; Rlite; Rfull; Rlsu; Rmau; Rbcu; Rtca; Rauxr; Rauxw; Rcrrp; Rcrwl; Rcrwh; Rnop]
let rec find_index elt l =
match l with
@@ -355,231 +456,147 @@ let resource_id resource : int = find_index resource resource_names
let resource_bound resource : int =
match resource with
- | "ISSUE" -> 8
- | "TINY" -> 4
- | "LITE" -> 2
- | "ALU" -> 1
- | "LSU" -> 1
- | "MAU" -> 1
- | "BCU" -> 1
- | "ACC" -> 1
- | "DATA" -> 1
- | "TCA" -> 1
- | "BRE" -> 1
- | "BRO" -> 1
- | "NOP" -> 4
- | _ -> raise Not_found
+ | Rissue -> 8
+ | Rtiny -> 4
+ | Rlite -> 2
+ | Rfull -> 1
+ | Rlsu -> 1
+ | Rmau -> 1
+ | Rbcu -> 1
+ | Rtca -> 1
+ | Rauxr -> 1
+ | Rauxw -> 1
+ | Rcrrp -> 1
+ | Rcrwl -> 1
+ | Rcrwh -> 1
+ | Rnop -> 4
let resource_bounds : int array = Array.of_list (List.map resource_bound resource_names)
(** Reservation tables *)
-let alu_tiny : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | _ -> 0
- in Array.of_list (List.map resmap resource_names)
-
-let alu_tiny_x : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 2 | "TINY" -> 1 | _ -> 0
- in Array.of_list (List.map resmap resource_names)
-
-let alu_tiny_y : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 3 | "TINY" -> 1 | _ -> 0
+let alu_full : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | Rfull -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
let alu_lite : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0
+ | Rissue -> 1 | Rtiny -> 1 | Rlite -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
let alu_lite_x : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 2 | "TINY" -> 1 | "LITE" -> 1 | _ -> 0
+ | Rissue -> 2 | Rtiny -> 1 | Rlite -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let alu_full : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | "LITE" -> 1 | "ALU" -> 1 | _ -> 0
+let alu_lite_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | Rlite -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
let alu_nop : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "NOP" -> 1 | _ -> 0
+ | Rissue -> 1 | Rnop -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let mau : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0
+let alu_tiny : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let mau_x : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 2 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0
+let alu_tiny_x : int array = let resmap = fun r -> match r with
+ | Rissue -> 2 | Rtiny -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let mau_y : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 3 | "TINY" -> 1 | "MAU" -> 1 | _ -> 0
+let alu_tiny_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
let bcu : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "BCU" -> 1 | _ -> 0
+ | Rissue -> 1 | Rbcu -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
let bcu_tiny_tiny_mau_xnop : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 2 | "MAU" -> 1 | "BCU" -> 1 | "NOP" -> 4 | _ -> 0
+ | Rissue -> 1 | Rtiny -> 2 | Rmau -> 1 | Rbcu -> 1 | Rnop -> 4 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_acc : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0
+let lsu_auxr : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_acc_x : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0
+let lsu_auxr_x : int array = let resmap = fun r -> match r with
+ | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_acc_y : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "ACC" -> 1 | _ -> 0
+let lsu_auxr_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxr -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_data : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 1 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0
+let lsu_auxw : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_data_x : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 2 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0
+let lsu_auxw_x : int array = let resmap = fun r -> match r with
+ | Rissue -> 2 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-let lsu_data_y : int array = let resmap = fun r -> match r with
- | "ISSUE" -> 3 | "TINY" -> 1 | "LSU" -> 1 | "DATA" -> 1 | _ -> 0
+let lsu_auxw_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | Rlsu -> 1 | Rauxw -> 1 | _ -> 0
in Array.of_list (List.map resmap resource_names)
-(** Real instructions *)
+let mau : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
-type real_instruction =
- (* ALU *)
- | Addw | Andw | Compw | Mulw | Orw | Sbfw | Sraw | Srlw | Sllw | Srsw | Rorw | Xorw
- | Addd | Andd | Compd | Muld | Ord | Sbfd | Srad | Srld | Slld | Srsd | Xord
- | Nandw | Norw | Nxorw | Nandd | Nord | Nxord | Andnw | Ornw | Andnd | Ornd
- | Maddw | Maddd | Cmoved
- | Make | Nop | Extfz | Extfs | Insf
- (* LSU *)
- | Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo
- | Sb | Sh | Sw | Sd | Sq | So
- (* BCU *)
- | Icall | Call | Cb | Igoto | Goto | Ret | Get | Set
- (* FPU *)
- | Fabsd | Fabsw | Fnegw | Fnegd
- | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw
- | Fnarrowdw | Fwidenlwd | Floatwz | Floatuwz | Floatdz | Floatudz | Fixedwz | Fixeduwz | Fixeddz | Fixedudz
- | Fcompw | Fcompd
+let mau_x : int array = let resmap = fun r -> match r with
+ | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
+
+let mau_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
+
+let mau_auxr : int array = let resmap = fun r -> match r with
+ | Rissue -> 1 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
+
+let mau_auxr_x : int array = let resmap = fun r -> match r with
+ | Rissue -> 2 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
+
+let mau_auxr_y : int array = let resmap = fun r -> match r with
+ | Rissue -> 3 | Rtiny -> 1 | Rmau -> 1 | Rauxr -> 1 | _ -> 0
+ in Array.of_list (List.map resmap resource_names)
+
+(** Real instructions *)
-let ab_inst_to_real = function
- | "Paddw" | "Paddiw" | "Pcvtl2w" -> Addw
- | "Paddl" | "Paddil" | "Pmv" | "Pmvw2l" -> Addd
- | "Pandw" | "Pandiw" -> Andw
- | "Pnandw" | "Pnandiw" -> Nandw
- | "Pandl" | "Pandil" -> Andd
- | "Pnandl" | "Pnandil" -> Nandd
- | "Pcompw" | "Pcompiw" -> Compw
- | "Pcompl" | "Pcompil" -> Compd
- | "Pfcompw" -> Fcompw
- | "Pfcompl" -> Fcompd
- | "Pmulw" | "Pmuliw" -> Mulw
- | "Pmull" | "Pmulil" -> Muld
- | "Porw" | "Poriw" -> Orw
- | "Pnorw" | "Pnoriw" -> Norw
- | "Porl" | "Poril" -> Ord
- | "Pnorl" | "Pnoril" -> Nord
- | "Psubw" | "Pnegw" -> Sbfw
- | "Psubl" | "Pnegl" -> Sbfd
- | "Psraw" | "Psraiw" -> Sraw
- | "Psral" | "Psrail" -> Srad
- | "Psrxw" | "Psrxiw" -> Srsw
- | "Psrxl" | "Psrxil" -> Srsd
- | "Psrlw" | "Psrliw" -> Srlw
- | "Psrll" | "Psrlil" -> Srld
- | "Psllw" | "Pslliw" -> Sllw
- | "Proriw" -> Rorw
- | "Pmaddw" | "Pmaddiw" -> Maddw
- | "Pslll" | "Psllil" -> Slld
- | "Pxorw" | "Pxoriw" -> Xorw
- | "Pnxorw" | "Pnxoriw" -> Nxorw
- | "Pandnw" | "Pandniw" -> Andnw
- | "Pornw" | "Porniw" -> Ornw
- | "Pxorl" | "Pxoril" -> Xord
- | "Pnxorl" | "Pnxoril" -> Nxord
- | "Pandnl" | "Pandnil" -> Andnd
- | "Pornl" | "Pornil" -> Ornd
- | "Pmaddl" -> Maddd
- | "Pmake" | "Pmakel" | "Pmakefs" | "Pmakef" | "Ploadsymbol" -> Make
- | "Pnop" | "Pcvtw2l" -> Nop
- | "Pextfz" | "Pextfzl" | "Pzxwd" -> Extfz
- | "Pextfs" | "Pextfsl" | "Psxwd" -> Extfs
- | "Pinsf" | "Pinsfl" -> Insf
- | "Pfnarrowdw" -> Fnarrowdw
- | "Pfwidenlwd" -> Fwidenlwd
- | "Pfloatwrnsz" -> Floatwz
- | "Pfloatuwrnsz" -> Floatuwz
- | "Pfloatdrnsz" -> Floatdz
- | "Pfloatudrnsz" -> Floatudz
- | "Pfixedwrzz" -> Fixedwz
- | "Pfixeduwrzz" -> Fixeduwz
- | "Pfixeddrzz" -> Fixeddz
- | "Pfixedudrzz" -> Fixedudz
- | "Pfixeddrzz_i32" -> Fixeddz
- | "Pfixedudrzz_i32" -> Fixedudz
- | "Pcmove" | "Pcmoveu" -> Cmoved
-
- | "Plb" -> Lbs
- | "Plbu" -> Lbz
- | "Plh" -> Lhs
- | "Plhu" -> Lhz
- | "Plw" | "Plw_a" | "Pfls" -> Lws
- | "Pld" | "Pfld" | "Pld_a" -> Ld
- | "Plq" -> Lq
- | "Plo" -> Lo
-
- | "Psb" -> Sb
- | "Psh" -> Sh
- | "Psw" | "Psw_a" | "Pfss" -> Sw
- | "Psd" | "Psd_a" | "Pfsd" -> Sd
- | "Psq" -> Sq
- | "Pso" -> So
-
- | "Pcb" | "Pcbu" -> Cb
- | "Pcall" | "Pdiv" | "Pdivu" -> Call
- | "Picall" -> Icall
- | "Pgoto" | "Pj_l" -> Goto
- | "Pigoto" -> Igoto
- | "Pget" -> Get
- | "Pret" -> Ret
- | "Pset" -> Set
-
- | "Pfabsd" -> Fabsd
- | "Pfabsw" -> Fabsw
- | "Pfnegw" -> Fnegw
- | "Pfnegd" -> Fnegd
- | "Pfaddd" -> Faddd
- | "Pfaddw" -> Faddw
- | "Pfsbfd" -> Fsbfd
- | "Pfsbfw" -> Fsbfw
- | "Pfmuld" -> Fmuld
- | "Pfmulw" -> Fmulw
-
- | "nop" -> Nop
-
- | s -> failwith @@ sprintf "ab_inst_to_real: unrecognized instruction: %s" s
-
exception InvalidEncoding
let rec_to_usage r =
let encoding = match r.imm with None -> None | Some (I32 i) | Some (I64 i) -> Some (encode_imm @@ Z.to_int64 i)
| Some (Off ptr) -> Some (encode_imm @@ camlint64_of_ptrofs ptr)
- and real_inst = ab_inst_to_real r.inst
- in match real_inst with
+ in match r.inst with
| Addw | Andw | Nandw | Orw | Norw | Sbfw | Xorw
- | Nxorw | Andnw | Ornw ->
+ | Nxorw | Andnw | Ornw ->
(match encoding with None | Some U6 | Some S10 -> alu_tiny
| Some U27L5 | Some U27L10 -> alu_tiny_x
| _ -> raise InvalidEncoding)
+ | Sbfxw | Sbfxd ->
+ (match encoding with None -> alu_lite
+ | Some U6 | Some S10 | Some U27L5 -> alu_lite_x
+ | _ -> raise InvalidEncoding)
| Addd | Andd | Nandd | Ord | Nord | Sbfd | Xord
- | Nxord | Andnd | Ornd | Cmoved ->
+ | Nxord | Andnd | Ornd ->
(match encoding with None | Some U6 | Some S10 -> alu_tiny
| Some U27L5 | Some U27L10 -> alu_tiny_x
| Some E27U27L10 -> alu_tiny_y)
+ |Cmoved ->
+ (match encoding with None | Some U6 | Some S10 -> alu_lite
+ | Some U27L5 | Some U27L10 -> alu_lite_x
+ | Some E27U27L10 -> alu_lite_y)
+ | Addxw ->
+ (match encoding with None | Some U6 | Some S10 -> alu_lite
+ | Some U27L5 | Some U27L10 -> alu_lite_x
+ | _ -> raise InvalidEncoding)
+ | Addxd ->
+ (match encoding with None | Some U6 | Some S10 -> alu_lite
+ | Some U27L5 | Some U27L10 -> alu_lite_x
+ | Some E27U27L10 -> alu_lite_y)
| Compw -> (match encoding with None -> alu_tiny
| Some U6 | Some S10 | Some U27L5 -> alu_tiny_x
| _ -> raise InvalidEncoding)
@@ -596,10 +613,16 @@ let rec_to_usage r =
| Some U27L5 | Some U27L10 -> alu_tiny_x
| Some E27U27L10 -> alu_tiny_y
| _ -> raise InvalidEncoding)
- | Mulw| Maddw -> (match encoding with None -> mau
+ | Maddw -> (match encoding with None -> mau_auxr
+ | Some U6 | Some S10 | Some U27L5 -> mau_auxr_x
+ | _ -> raise InvalidEncoding)
+ | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau_auxr
+ | Some U27L5 | Some U27L10 -> mau_auxr_x
+ | Some E27U27L10 -> mau_auxr_y)
+ | Mulw| Msbfw -> (match encoding with None -> mau
| Some U6 | Some S10 | Some U27L5 -> mau_x
| _ -> raise InvalidEncoding)
- | Muld | Maddd -> (match encoding with None | Some U6 | Some S10 -> mau
+ | Muld | Msbfd -> (match encoding with None | Some U6 | Some S10 -> mau
| Some U27L5 | Some U27L10 -> mau_x
| Some E27U27L10 -> mau_y)
| Nop -> alu_nop
@@ -609,42 +632,64 @@ let rec_to_usage r =
| Extfz | Extfs | Insf -> (match encoding with None -> alu_lite | _ -> raise InvalidEncoding)
| Fixeduwz | Fixedwz | Floatwz | Floatuwz | Fixeddz | Fixedudz | Floatdz | Floatudz -> mau
| Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo ->
- (match encoding with None | Some U6 | Some S10 -> lsu_data
- | Some U27L5 | Some U27L10 -> lsu_data_x
- | Some E27U27L10 -> lsu_data_y)
+ (match encoding with None | Some U6 | Some S10 -> lsu_auxw
+ | Some U27L5 | Some U27L10 -> lsu_auxw_x
+ | Some E27U27L10 -> lsu_auxw_y)
| Sb | Sh | Sw | Sd | Sq | So ->
- (match encoding with None | Some U6 | Some S10 -> lsu_acc
- | Some U27L5 | Some U27L10 -> lsu_acc_x
- | Some E27U27L10 -> lsu_acc_y)
+ (match encoding with None | Some U6 | Some S10 -> lsu_auxr
+ | Some U27L5 | Some U27L10 -> lsu_auxr_x
+ | Some E27U27L10 -> lsu_auxr_y)
| Icall | Call | Cb | Igoto | Goto | Ret | Set -> bcu
| Get -> bcu_tiny_tiny_mau_xnop
- | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd -> alu_lite
+ | Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd
+ | Fmind | Fmaxd | Fminw | Fmaxw -> alu_lite
| Fnarrowdw -> alu_full
- | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> mau
+ | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw
+ | Ffmad | Ffmaw | Ffmsd | Ffmsw -> mau
+
+
+let inst_info_to_dlatency i =
+ begin
+ assert (not (i.reads_at_id && i.reads_at_e1));
+ match i.reads_at_id with
+ | true -> +1
+ | false -> (match i.reads_at_e1 with
+ | true -> -1
+ | false -> 0)
+ end
let real_inst_to_latency = function
| Nop -> 0 (* Only goes through ID *)
- | Addw | Andw | Compw | Orw | Sbfw | Sraw | Srsw | Srlw | Sllw | Xorw
+ | Addw | Andw | Compw | Orw | Sbfw | Sbfxw | Sraw | Srsw | Srlw | Sllw | Xorw
(* TODO check rorw *)
| Rorw | Nandw | Norw | Nxorw | Ornw | Andnw
| Nandd | Nord | Nxord | Ornd | Andnd
- | Addd | Andd | Compd | Ord | Sbfd | Srad | Srsd | Srld | Slld | Xord | Make
- | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved
+ | Addd | Andd | Compd | Ord | Sbfd | Sbfxd | Srad | Srsd | Srld | Slld | Xord | Make
+ | Extfs | Extfz | Insf | Fcompw | Fcompd | Cmoved | Addxw | Addxd
+ | Fmind | Fmaxd | Fminw | Fmaxw
-> 1
| Floatwz | Floatuwz | Fixeduwz | Fixedwz | Floatdz | Floatudz | Fixeddz | Fixedudz -> 4
- | Mulw | Muld | Maddw | Maddd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *)
+ | Mulw | Muld | Maddw | Maddd | Msbfw | Msbfd -> 2 (* FIXME - WORST CASE. If it's S10 then it's only 1 *)
| Lbs | Lbz | Lhs | Lhz | Lws | Ld | Lq | Lo -> 3
| Sb | Sh | Sw | Sd | Sq | So -> 1 (* See k1c-Optimization.pdf page 19 *)
| Get -> 1
| Set -> 4 (* According to the manual should be 3, but I measured 4 *)
| Icall | Call | Cb | Igoto | Goto | Ret -> 42 (* Should not matter since it's the final instruction of the basic block *)
| Fnegd | Fnegw | Fabsd | Fabsw | Fwidenlwd | Fnarrowdw -> 1
- | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw -> 4
+ | Faddd | Faddw | Fsbfd | Fsbfw | Fmuld | Fmulw | Finvw
+ | Ffmaw | Ffmad | Ffmsw | Ffmsd -> 4
+
+let rec empty_inter la = function
+ | [] -> true
+ | b::lb -> if (List.mem b la) then false else empty_inter la lb
let rec_to_info r : inst_info =
let usage = rec_to_usage r
- and latency = real_inst_to_latency @@ ab_inst_to_real r.inst
- in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control }
+ and latency = real_inst_to_latency r.inst
+ and reads_at_id = not (empty_inter r.read_locs r.read_at_id)
+ and reads_at_e1 = not (empty_inter r.read_locs r.read_at_e1)
+ in { write_locs = r.write_locs; read_locs = r.read_locs; usage=usage; latency=latency; is_control=r.is_control;
+ reads_at_id = reads_at_id; reads_at_e1 = reads_at_e1 }
let instruction_infos bb = List.map rec_to_info (instruction_recs bb)
@@ -656,38 +701,70 @@ let instruction_usages bb =
* Latency constraints building
*)
-type access = { inst: int; loc: location }
+(* type access = { inst: int; loc: location } *)
-let rec get_accesses llocs laccs =
- let accesses loc laccs = List.filter (fun acc -> acc.loc = loc) laccs
- in match llocs with
- | [] -> []
- | loc :: llocs -> (accesses loc laccs) @ (get_accesses llocs laccs)
+let preg2int pr = Camlcoq.P.to_int @@ Asmblockdeps.ppos pr
+
+let loc2int = function
+ | Mem -> 1
+ | Reg pr -> preg2int pr
+
+(* module HashedLoc = struct
+ type t = { loc: location; key: int }
+ let equal l1 l2 = (l1.key = l2.key)
+ let hash l = l.key
+ let create (l:location) : t = { loc=l; key = loc2int l }
+end *)
+
+(* module LocHash = Hashtbl.Make(HashedLoc) *)
+module LocHash = Hashtbl
+
+(* Hash table : location => list of instruction ids *)
let rec intlist n =
if n < 0 then failwith "intlist: n < 0"
else if n = 0 then []
else (n-1) :: (intlist (n-1))
-let latency_constraints bb = (* failwith "latency_constraints: not implemented" *)
- let written = ref []
- and read = ref []
+let find_in_hash hashloc loc =
+ match LocHash.find_opt hashloc loc with
+ | Some idl -> idl
+ | None -> []
+
+(* Returns a list of instruction ids *)
+let rec get_accesses hashloc (ll: location list) = match ll with
+ | [] -> []
+ | loc :: llocs -> (find_in_hash hashloc loc) @ (get_accesses hashloc llocs)
+
+let compute_latency (ifrom: inst_info) (ito: inst_info) =
+ let dlat = inst_info_to_dlatency ito
+ in let lat = ifrom.latency + dlat
+ in assert (lat >= 0); if (lat == 0) then 1 else lat
+
+let latency_constraints bb =
+ let written = LocHash.create 70
+ and read = LocHash.create 70
and count = ref 0
and constraints = ref []
and instr_infos = instruction_infos bb
- in let step (i: inst_info) =
- let write_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.write_locs
- and read_accesses = List.map (fun loc -> { inst= !count; loc=loc }) i.read_locs
- in let raw = get_accesses i.read_locs !written
- and waw = get_accesses i.write_locs !written
- and war = get_accesses i.write_locs !read
+ in let step (i: inst_info) =
+ let raw = get_accesses written i.read_locs
+ and waw = get_accesses written i.write_locs
+ and war = get_accesses read i.write_locs
in begin
- List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = (List.nth instr_infos acc.inst).latency} :: !constraints) (raw @ waw);
- List.iter (fun (acc: access) -> constraints := {instr_from = acc.inst; instr_to = !count; latency = 0} :: !constraints) war;
- (* If it's a control instruction, add an extra 0-lat dependency between this instruction and all the previous ones *)
+ List.iter (fun i -> constraints := {instr_from = i; instr_to = !count;
+ latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) raw;
+ List.iter (fun i -> constraints := {instr_from = i; instr_to = !count;
+ latency = compute_latency (List.nth instr_infos i) (List.nth instr_infos !count)} :: !constraints) waw;
+ List.iter (fun i -> constraints := {instr_from = i; instr_to = !count; latency = 0} :: !constraints) war;
if i.is_control then List.iter (fun n -> constraints := {instr_from = n; instr_to = !count; latency = 0} :: !constraints) (intlist !count);
- written := write_accesses @ !written;
- read := read_accesses @ !read;
+ (* Updating "read" and "written" hashmaps *)
+ List.iter (fun loc ->
+ begin
+ LocHash.replace written loc [!count];
+ LocHash.replace read loc []; (* Clearing all the entries of "read" hashmap when a register is written *)
+ end) i.write_locs;
+ List.iter (fun loc -> LocHash.replace read loc ((!count) :: (find_in_hash read loc))) i.read_locs;
count := !count + 1
end
in (List.iter step instr_infos; !constraints)
@@ -760,15 +837,52 @@ let find_all_indices m l =
else find m (off+1) l
in find m 0 l
+module TimeHash = Hashtbl
+
+(* Hash table : time => list of instruction ids *)
+
+let hashtbl2list h maxint =
+ let rec f i = match TimeHash.find_opt h i with
+ | None -> if (i > maxint) then [] else (f (i+1))
+ | Some bund -> bund :: (f (i+1))
+ in f 0
+
+let find_max l =
+ let rec f = function
+ | [] -> None
+ | e :: l -> match f l with
+ | None -> Some e
+ | Some m -> if (e > m) then Some e else Some m
+ in match (f l) with
+ | None -> raise Not_found
+ | Some m -> m
+
(* [0, 2, 3, 1, 1, 2, 4, 5] -> [[0], [3, 4], [1, 5], [2], [6], [7]] *)
-let minpack_list l =
+let minpack_list (l: int list) =
+ let timehash = TimeHash.create (List.length l)
+ in let rec f i = function
+ | [] -> ()
+ | t::l -> begin
+ (match TimeHash.find_opt timehash t with
+ | None -> TimeHash.add timehash t [i]
+ | Some bund -> TimeHash.replace timehash t (bund @ [i]));
+ f (i+1) l
+ end
+ in begin
+ f 0 l;
+ hashtbl2list timehash (find_max l)
+ end;;
+
+(* let minpack_list l =
let mins = find_mins l
in List.map (fun m -> find_all_indices m l) mins
+ *)
let bb_to_instrs bb = (List.map apply_pbasic bb.body) @ (match bb.exit with None -> [] | Some e -> [PControl e])
let bundlize_solution bb sol =
- let packs = minpack_list (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1))
+ let tmp = (Array.to_list @@ Array.sub sol 0 (Array.length sol - 1))
+ in let packs = minpack_list tmp
and instrs = bb_to_instrs bb
in let rec bund hd = function
| [] -> []
@@ -792,6 +906,8 @@ let do_schedule bb =
validated_scheduler cascaded_scheduler
else if !Clflags.option_fpostpass_sched = "list" then
validated_scheduler list_scheduler
+ else if !Clflags.option_fpostpass_sched = "revlist" then
+ validated_scheduler reverse_list_scheduler
else if !Clflags.option_fpostpass_sched = "greedy" then
greedy_scheduler else failwith ("Invalid scheduler:" ^ !Clflags.option_fpostpass_sched)) problem
in match solution with
@@ -881,17 +997,19 @@ let smart_schedule bb =
in bundles @ (f lbb)
in f lbb
-(** Called schedule function from Coq *)
-
-let schedule bb =
+let bblock_to_bundles bb =
if debug then (eprintf "###############################\n"; Printf.eprintf "SCHEDULING\n"; print_bb stderr bb);
(* print_problem (build_problem bb); *)
if Compopts.optim_postpass () then smart_schedule bb else dumb_schedule bb
-(** FIXME - Fix for PostpassScheduling WIP *)
+(** To deal with the Coq Axiom schedule : bblock -> (list (list basic)) * option control *)
-type bblock' = int
+let rec bundles_to_coq_schedule = function
+ | [] -> ([], None)
+ | bb :: [] -> ([bb.body], bb.exit)
+ | bb :: lbb -> let (llb, oc) = bundles_to_coq_schedule lbb in (bb.body :: llb, oc)
-let trans_block bb = 1
+(** Called schedule function from Coq *)
-let bblock_equivb' bb1 bb2 = true
+let schedule_notime bb = let toto = bundles_to_coq_schedule @@ bblock_to_bundles bb in toto
+let schedule bb = Timing.time_coq ('P'::('o'::('s'::('t'::('p'::('a'::('s'::('s'::('S'::('c'::('h'::('e'::('d'::('u'::('l'::('i'::('n'::('g'::(' '::('o'::('r'::('a'::('c'::('l'::('e'::([])))))))))))))))))))))))))) schedule_notime bb
diff --git a/mppa_k1c/PostpassSchedulingproof.v b/mppa_k1c/PostpassSchedulingproof.v
index 5d4fc881..8cc7f0ab 100644
--- a/mppa_k1c/PostpassSchedulingproof.v
+++ b/mppa_k1c/PostpassSchedulingproof.v
@@ -14,7 +14,7 @@ Require Import Coqlib Errors.
Require Import Integers Floats AST Linking.
Require Import Values Memory Events Globalenvs Smallstep.
Require Import Op Locations Machblock Conventions Asmblock.
-Require Import Asmblockgenproof0.
+Require Import Asmblockgenproof0 Asmblockprops.
Require Import PostpassScheduling.
Require Import Asmblockgenproof.
Require Import Axioms.
@@ -30,62 +30,6 @@ Proof.
intros. eapply match_transform_partial_program; eauto.
Qed.
-Remark builtin_body_nil:
- forall bb ef args res, exit bb = Some (PExpand (Pbuiltin ef args res)) -> body bb = nil.
-Proof.
- intros. destruct bb as [hd bdy ex WF]. simpl in *.
- apply wf_bblock_refl in WF. inv WF. unfold builtin_alone in H1.
- eapply H1; eauto.
-Qed.
-
-Lemma exec_body_app:
- forall l l' ge rs m rs'' m'',
- exec_body ge (l ++ l') rs m = Next rs'' m'' ->
- exists rs' m',
- exec_body ge l rs m = Next rs' m'
- /\ exec_body ge l' rs' m' = Next rs'' m''.
-Proof.
- induction l.
- - intros. simpl in H. repeat eexists. auto.
- - intros. rewrite <- app_comm_cons in H. simpl in H.
- destruct (exec_basic_instr ge a rs m) eqn:EXEBI.
- + apply IHl in H. destruct H as (rs1 & m1 & EXEB1 & EXEB2).
- repeat eexists. simpl. rewrite EXEBI. eauto. auto.
- + discriminate.
-Qed.
-
-Lemma exec_body_pc:
- forall l ge rs1 m1 rs2 m2,
- exec_body ge l rs1 m1 = Next rs2 m2 ->
- rs2 PC = rs1 PC.
-Proof.
- induction l.
- - intros. inv H. auto.
- - intros until m2. intro EXEB.
- inv EXEB. destruct (exec_basic_instr _ _ _) eqn:EBI; try discriminate.
- eapply IHl in H0. rewrite H0.
- erewrite exec_basic_instr_pc; eauto.
-Qed.
-
-Lemma next_eq:
- forall (rs rs': regset) m m',
- rs = rs' -> m = m' -> Next rs m = Next rs' m'.
-Proof.
- intros; apply f_equal2; auto.
-Qed.
-
-Lemma regset_double_set:
- forall r1 r2 (rs: regset) v1 v2,
- r1 <> r2 ->
- (rs # r1 <- v1 # r2 <- v2) = (rs # r2 <- v2 # r1 <- v1).
-Proof.
- intros. apply functional_extensionality. intros r. destruct (preg_eq r r1).
- - subst. rewrite Pregmap.gso; auto. repeat (rewrite Pregmap.gss). auto.
- - destruct (preg_eq r r2).
- + subst. rewrite Pregmap.gss. rewrite Pregmap.gso; auto. rewrite Pregmap.gss. auto.
- + repeat (rewrite Pregmap.gso; auto).
-Qed.
-
Lemma regset_double_set_id:
forall r (rs: regset) v1 v2,
(rs # r <- v1 # r <- v2) = (rs # r <- v2).
@@ -95,191 +39,6 @@ Proof.
- repeat (rewrite Pregmap.gso); auto.
Qed.
-Lemma exec_load_offset_pc_var:
- forall t rs m rd ra ofs rs' m' v,
- exec_load_offset t rs m rd ra ofs = Next rs' m' ->
- exec_load_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_load_offset in *. unfold parexec_load_offset in *. rewrite Pregmap.gso; try discriminate. destruct (eval_offset ofs); try discriminate.
- destruct (Mem.loadv _ _ _).
- - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
- - discriminate.
-Qed.
-
-Lemma exec_load_reg_pc_var:
- forall t rs m rd ra ro rs' m' v,
- exec_load_reg t rs m rd ra ro = Next rs' m' ->
- exec_load_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_load_reg in *. unfold parexec_load_reg in *. rewrite Pregmap.gso; try discriminate.
- destruct (Mem.loadv _ _ _).
- - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
- - discriminate.
-Qed.
-
-Lemma exec_load_regxs_pc_var:
- forall t rs m rd ra ro rs' m' v,
- exec_load_regxs t rs m rd ra ro = Next rs' m' ->
- exec_load_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_load_regxs in *. unfold parexec_load_regxs in *. rewrite Pregmap.gso; try discriminate.
- destruct (Mem.loadv _ _ _).
- - inv H. apply next_eq; auto. apply functional_extensionality. intros. rewrite regset_double_set; auto. discriminate.
- - discriminate.
-Qed.
-
-Lemma exec_load_offset_q_pc_var:
- forall rs m rd ra ofs rs' m' v,
- exec_load_q_offset rs m rd ra ofs = Next rs' m' ->
- exec_load_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_load_q_offset in *. unfold parexec_load_q_offset in *.
- destruct (gpreg_q_expand rd) as [rd0 rd1].
- (* destruct (ireg_eq rd0 ra); try discriminate. *)
- rewrite Pregmap.gso; try discriminate.
- destruct (Mem.loadv _ _ _); try discriminate.
- inv H.
- destruct (Mem.loadv _ _ _); try discriminate.
- inv H1. f_equal.
- rewrite (regset_double_set PC rd0) by discriminate.
- rewrite (regset_double_set PC rd1) by discriminate.
- reflexivity.
-Qed.
-
-Lemma exec_load_offset_o_pc_var:
- forall rs m rd ra ofs rs' m' v,
- exec_load_o_offset rs m rd ra ofs = Next rs' m' ->
- exec_load_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_load_o_offset in *. unfold parexec_load_o_offset in *.
- destruct (gpreg_o_expand rd) as [[[rd0 rd1] rd2] rd3].
-(*
- destruct (ireg_eq rd0 ra); try discriminate.
- destruct (ireg_eq rd1 ra); try discriminate.
- destruct (ireg_eq rd2 ra); try discriminate.
-*)
- rewrite Pregmap.gso; try discriminate.
- simpl in *.
- destruct (Mem.loadv _ _ _); try discriminate.
- destruct (Mem.loadv _ _ _); try discriminate.
- destruct (Mem.loadv _ _ _); try discriminate.
- destruct (Mem.loadv _ _ _); try discriminate.
- rewrite (regset_double_set PC rd0) by discriminate.
- rewrite (regset_double_set PC rd1) by discriminate.
- rewrite (regset_double_set PC rd2) by discriminate.
- rewrite (regset_double_set PC rd3) by discriminate.
- inv H.
- trivial.
-Qed.
-
-Lemma exec_store_offset_pc_var:
- forall t rs m rd ra ofs rs' m' v,
- exec_store_offset t rs m rd ra ofs = Next rs' m' ->
- exec_store_offset t rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_store_offset in *. unfold parexec_store_offset in *. rewrite Pregmap.gso; try discriminate.
- destruct (eval_offset ofs); try discriminate.
- destruct (Mem.storev _ _ _).
- - inv H. apply next_eq; auto.
- - discriminate.
-Qed.
-
-Lemma exec_store_q_offset_pc_var:
- forall rs m rd ra ofs rs' m' v,
- exec_store_q_offset rs m rd ra ofs = Next rs' m' ->
- exec_store_q_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_store_q_offset in *. unfold parexec_store_q_offset in *. rewrite Pregmap.gso; try discriminate.
- simpl in *.
- destruct (gpreg_q_expand _) as [s0 s1].
- destruct (Mem.storev _ _ _); try discriminate.
- destruct (Mem.storev _ _ _); try discriminate.
- inv H. apply next_eq; auto.
-Qed.
-
-Lemma exec_store_o_offset_pc_var:
- forall rs m rd ra ofs rs' m' v,
- exec_store_o_offset rs m rd ra ofs = Next rs' m' ->
- exec_store_o_offset rs # PC <- v m rd ra ofs = Next rs' # PC <- v m'.
-Proof.
- intros.
- unfold exec_store_o_offset in *. unfold parexec_store_o_offset in *.
- destruct (gpreg_o_expand _) as [[[s0 s1] s2] s3].
- destruct (Mem.storev _ _ _); try discriminate.
- destruct (Mem.storev _ _ _); try discriminate.
- destruct (Mem.storev _ _ _); try discriminate.
- destruct (Mem.storev _ _ _); try discriminate.
- inv H.
- trivial.
-Qed.
-
-Lemma exec_store_reg_pc_var:
- forall t rs m rd ra ro rs' m' v,
- exec_store_reg t rs m rd ra ro = Next rs' m' ->
- exec_store_reg t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_store_reg in *. unfold parexec_store_reg in *. rewrite Pregmap.gso; try discriminate.
- destruct (Mem.storev _ _ _).
- - inv H. apply next_eq; auto.
- - discriminate.
-Qed.
-
-Lemma exec_store_regxs_pc_var:
- forall t rs m rd ra ro rs' m' v,
- exec_store_regxs t rs m rd ra ro = Next rs' m' ->
- exec_store_regxs t rs # PC <- v m rd ra ro = Next rs' # PC <- v m'.
-Proof.
- intros. unfold exec_store_regxs in *. unfold parexec_store_regxs in *. rewrite Pregmap.gso; try discriminate.
- destruct (Mem.storev _ _ _).
- - inv H. apply next_eq; auto.
- - discriminate.
-Qed.
-
-Lemma exec_basic_instr_pc_var:
- forall ge i rs m rs' m' v,
- exec_basic_instr ge i rs m = Next rs' m' ->
- exec_basic_instr ge i (rs # PC <- v) m = Next (rs' # PC <- v) m'.
-Proof.
- intros. unfold exec_basic_instr in *. unfold parexec_basic_instr in *. destruct i.
- - unfold exec_arith_instr in *. destruct i; destruct i.
- all: try (exploreInst; inv H; apply next_eq; auto;
- apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate).
-(*
- (* Some cases treated seperately because exploreInst destructs too much *)
- all: try (inv H; apply next_eq; auto; apply functional_extensionality; intros; rewrite regset_double_set; auto; discriminate). *)
- - destruct i.
- + exploreInst; apply exec_load_offset_pc_var; auto.
- + exploreInst; apply exec_load_reg_pc_var; auto.
- + exploreInst; apply exec_load_regxs_pc_var; auto.
- + apply exec_load_offset_q_pc_var; auto.
- + apply exec_load_offset_o_pc_var; auto.
- - destruct i.
- + exploreInst; apply exec_store_offset_pc_var; auto.
- + exploreInst; apply exec_store_reg_pc_var; auto.
- + exploreInst; apply exec_store_regxs_pc_var; auto.
- + apply exec_store_q_offset_pc_var; auto.
- + apply exec_store_o_offset_pc_var; auto.
- - destruct (Mem.alloc _ _ _) as (m1 & stk). repeat (rewrite Pregmap.gso; try discriminate).
- destruct (Mem.storev _ _ _ _); try discriminate.
- inv H. apply next_eq; auto. apply functional_extensionality. intros.
- rewrite (regset_double_set GPR32 PC); try discriminate.
- rewrite (regset_double_set GPR12 PC); try discriminate.
- rewrite (regset_double_set FP PC); try discriminate. reflexivity.
- - repeat (rewrite Pregmap.gso; try discriminate).
- destruct (Mem.loadv _ _ _); try discriminate.
- destruct (rs GPR12); try discriminate.
- destruct (Mem.free _ _ _ _); try discriminate.
- inv H. apply next_eq; auto.
- rewrite (regset_double_set GPR32 PC).
- rewrite (regset_double_set GPR12 PC). reflexivity.
- all: discriminate.
- - destruct rs0; try discriminate. inv H. apply next_eq; auto.
- repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate.
- - destruct rd; try discriminate. inv H. apply next_eq; auto.
- repeat (rewrite Pregmap.gso; try discriminate). apply regset_double_set; discriminate.
- - inv H. apply next_eq; auto.
-Qed.
-
Lemma exec_body_pc_var:
forall l ge rs m rs' m' v,
exec_body ge l rs m = Next rs' m' ->
@@ -302,9 +61,9 @@ Proof.
- subst. repeat (rewrite Pregmap.gss); auto.
destruct v; simpl; auto.
rewrite Ptrofs.add_assoc.
- cutrewrite (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)); auto.
+ enough (Ptrofs.repr (x + y) = Ptrofs.add (Ptrofs.repr x) (Ptrofs.repr y)) as ->; auto.
unfold Ptrofs.add.
- cutrewrite (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)); auto.
+ enough (x + y = Ptrofs.unsigned (Ptrofs.repr x) + Ptrofs.unsigned (Ptrofs.repr y)) as ->; auto.
repeat (rewrite Ptrofs.unsigned_repr); auto.
- repeat (rewrite Pregmap.gso; auto).
Qed.
@@ -461,7 +220,8 @@ Proof.
destruct (zeq pos 0).
+ inv H. exists lbb. constructor; auto.
+ apply IHlbb in H. destruct H as (c & TAIL). exists c.
- cutrewrite (pos = pos - size a + size a). apply code_tail_S; auto.
+ enough (pos = pos - size a + size a) as ->.
+ apply code_tail_S; auto.
omega.
Qed.
@@ -681,7 +441,7 @@ Lemma transf_exec_basic_instr:
forall i rs m, exec_basic_instr ge i rs m = exec_basic_instr tge i rs m.
Proof.
intros. pose symbol_address_preserved.
- unfold exec_basic_instr. unfold parexec_basic_instr. exploreInst; simpl; auto; try congruence.
+ unfold exec_basic_instr. unfold bstep. exploreInst; simpl; auto; try congruence.
unfold parexec_arith_instr; unfold arith_eval_r; exploreInst; simpl; auto; try congruence.
Qed.
@@ -736,7 +496,7 @@ Proof.
induction 1; intros; inv MS.
- exploit function_ptr_translated; eauto. intros (tf & FFP & TRANSF). monadInv TRANSF.
exploit transf_find_bblock; eauto. intros (lbb & VES & c & TAIL).
- exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ).
+ exploit verified_schedule_correct; eauto. intros (tbb & CONC & BBEQ). inv CONC. rename H3 into CONC.
assert (NOOV: size_blocks x.(fn_blocks) <= Ptrofs.max_unsigned).
eapply transf_function_no_overflow; eauto.
@@ -776,12 +536,8 @@ Qed.
End PRESERVATION_ASMBLOCK.
-
-
-
Require Import Asmvliw.
-
Lemma verified_par_checks_alls_bundles lb x: forall bundle,
verify_par lb = OK x ->
List.In bundle lb -> verify_par_bblock bundle = OK tt.
@@ -792,13 +548,12 @@ Proof.
destruct x0; auto.
Qed.
-
Lemma verified_schedule_nob_checks_alls_bundles bb lb bundle:
verified_schedule_nob bb = OK lb ->
List.In bundle lb -> verify_par_bblock bundle = OK tt.
Proof.
unfold verified_schedule_nob. intros H;
- monadInv H. destruct x3.
+ monadInv H. destruct x4.
intros; eapply verified_par_checks_alls_bundles; eauto.
Qed.
@@ -813,7 +568,7 @@ Proof.
unfold builtin_alone in H0. erewrite H0; eauto.
Qed.
-Local Hint Resolve verified_schedule_nob_checks_alls_bundles.
+Local Hint Resolve verified_schedule_nob_checks_alls_bundles: core.
Lemma verified_schedule_checks_alls_bundles bb lb bundle:
verified_schedule bb = OK lb ->
@@ -914,9 +669,6 @@ Qed.
End PRESERVATION_ASMVLIW.
-
-
-
Section PRESERVATION.
Variables prog tprog: program.
diff --git a/mppa_k1c/PrintOp.ml b/mppa_k1c/PrintOp.ml
index 4b833014..67f87000 100644
--- a/mppa_k1c/PrintOp.ml
+++ b/mppa_k1c/PrintOp.ml
@@ -21,7 +21,8 @@ open Printf
open Camlcoq
open Integers
open Op
-
+open ExtValues
+
let comparison_name = function
| Ceq -> "=="
| Cne -> "!="
@@ -58,7 +59,20 @@ let print_condition reg pp = function
| _ ->
fprintf pp "<bad condition>"
-let print_operation reg pp = function
+let print_condition0 reg pp cond0 rc =
+ match cond0 with
+ | Ccomp0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c)
+ | Ccompu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c)
+ | Ccompl0 c -> fprintf pp "%a %ss 0" reg rc (comparison_name c)
+ | Ccomplu0 c -> fprintf pp "%a %su 0" reg rc (comparison_name c)
+
+let int_of_s14 = function
+ | SHIFT1 -> 1
+ | SHIFT2 -> 2
+ | SHIFT3 -> 3
+ | SHIFT4 -> 4
+
+let print_operation reg pp op = match op with
| Omove, [r1] -> reg pp r1
| Ointconst n, [] -> fprintf pp "%ld" (camlint_of_coqint n)
| Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n)
@@ -72,9 +86,15 @@ let print_operation reg pp = function
| Ocast16signed, [r1] -> fprintf pp "int16signed(%a)" reg r1
| Oadd, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2
| Oaddimm n, [r1] -> fprintf pp "%a + %ld" reg r1 (camlint_of_coqint n)
+ | Oaddx(s14), [r1; r2] -> fprintf pp "(%a << %d) + %a" reg r1 (int_of_s14 s14) reg r2
+ | Oaddximm(s14, imm), [r1] -> fprintf pp "(%a << %d) + %ld" reg r1 (int_of_s14 s14) (camlint_of_coqint imm)
| Oneg, [r1] -> fprintf pp "-(%a)" reg r1
| Osub, [r1;r2] -> fprintf pp "%a - %a" reg r1 reg r2
+ | Orevsubimm(imm), [r1] -> fprintf pp "%ld - %a" (camlint_of_coqint imm) reg r1
+ | Orevsubx(s14), [r1; r2] -> fprintf pp "%a - (%a << %d)" reg r2 reg r1 (int_of_s14 s14)
+ | Orevsubximm(s14, imm), [r1] -> fprintf pp "%ld - (%a << %d)" (camlint_of_coqint imm) reg r1 (int_of_s14 s14)
| Omul, [r1;r2] -> fprintf pp "%a * %a" reg r1 reg r2
+ | Omulimm(imm), [r1] -> fprintf pp "%a * %ld" reg r1 (camlint_of_coqint imm)
| Omulhs, [r1;r2] -> fprintf pp "%a *hs %a" reg r1 reg r2
| Omulhu, [r1;r2] -> fprintf pp "%a *hu %a" reg r1 reg r2
| Odiv, [r1;r2] -> fprintf pp "%a /s %a" reg r1 reg r2
@@ -87,6 +107,13 @@ let print_operation reg pp = function
| Oorimm n, [r1] -> fprintf pp "%a | %ld" reg r1 (camlint_of_coqint n)
| Oxor, [r1;r2] -> fprintf pp "%a ^ %a" reg r1 reg r2
| Oxorimm n, [r1] -> fprintf pp "%a ^ %ld" reg r1 (camlint_of_coqint n)
+ | Onxor, [r1;r2] -> fprintf pp "~(%a ^ %a)" reg r1 reg r2
+ | Onxorimm n, [r1] -> fprintf pp "~(%a ^ %ld)" reg r1 (camlint_of_coqint n)
+ | Onot, [r1] -> fprintf pp "~%a" reg r1
+ | Oandn, [r1; r2] -> fprintf pp "(~%a) & %a" reg r1 reg r2
+ | Oandnimm n, [r1] -> fprintf pp "(~%a) & %ld" reg r1 (camlint_of_coqint n)
+ | Oorn, [r1;r2] -> fprintf pp "(~%a) | %a" reg r1 reg r2
+ | Oornimm n, [r1] -> fprintf pp "(~%a) | %ld" reg r1 (camlint_of_coqint n)
| Oshl, [r1;r2] -> fprintf pp "%a << %a" reg r1 reg r2
| Oshlimm n, [r1] -> fprintf pp "%a << %ld" reg r1 (camlint_of_coqint n)
| Oshr, [r1;r2] -> fprintf pp "%a >>s %a" reg r1 reg r2
@@ -94,6 +121,10 @@ let print_operation reg pp = function
| Oshru, [r1;r2] -> fprintf pp "%a >>u %a" reg r1 reg r2
| Oshruimm n, [r1] -> fprintf pp "%a >>u %ld" reg r1 (camlint_of_coqint n)
| Oshrximm n, [r1] -> fprintf pp "%a >>x %ld" reg r1 (camlint_of_coqint n)
+ | Ororimm n, [r1] -> fprintf pp "(%a ror %ld)" reg r1 (camlint_of_coqint n)
+ | Omadd, [r1; r2; r3] -> fprintf pp "%a + %a * %a" reg r1 reg r2 reg r3
+ | Omaddimm imm, [r1; r2] -> fprintf pp "%a + %a * %ld" reg r1 reg r2 (camlint_of_coqint imm)
+ | Omsub, [r1; r2; r3] -> fprintf pp "%a - %a * %a" reg r1 reg r2 reg r3
| Omakelong, [r1;r2] -> fprintf pp "makelong(%a,%a)" reg r1 reg r2
| Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1
@@ -102,9 +133,15 @@ let print_operation reg pp = function
| Ocast32unsigned, [r1] -> fprintf pp "long32unsigned(%a)" reg r1
| Oaddl, [r1;r2] -> fprintf pp "%a +l %a" reg r1 reg r2
| Oaddlimm n, [r1] -> fprintf pp "%a +l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oaddxl(s14), [r1; r2] -> fprintf pp "(%a <<l %d) +l %a" reg r1 (int_of_s14 s14) reg r2
+ | Oaddxlimm(s14, imm), [r1] -> fprintf pp "(%a <<l %d) +l %Ld" reg r1 (int_of_s14 s14) (camlint64_of_coqint imm)
+ | Orevsublimm(imm), [r1] -> fprintf pp "%Ld -l %a" (camlint64_of_coqint imm) reg r1
+ | Orevsubxl(s14), [r1; r2] -> fprintf pp "%a -l (%a <<l %d)" reg r2 reg r1 (int_of_s14 s14)
+ | Orevsubxlimm(s14, imm), [r1] -> fprintf pp "%Ld -l (%a <<l %d)" (camlint64_of_coqint imm) reg r1 (int_of_s14 s14)
| Onegl, [r1] -> fprintf pp "-l (%a)" reg r1
| Osubl, [r1;r2] -> fprintf pp "%a -l %a" reg r1 reg r2
| Omull, [r1;r2] -> fprintf pp "%a *l %a" reg r1 reg r2
+ | Omullimm(imm), [r1] -> fprintf pp "%a *l %Ld" reg r1 (camlint64_of_coqint imm)
| Omullhs, [r1;r2] -> fprintf pp "%a *lhs %a" reg r1 reg r2
| Omullhu, [r1;r2] -> fprintf pp "%a *lhu %a" reg r1 reg r2
| Odivl, [r1;r2] -> fprintf pp "%a /ls %a" reg r1 reg r2
@@ -115,8 +152,17 @@ let print_operation reg pp = function
| Oandlimm n, [r1] -> fprintf pp "%a &l %Ld" reg r1 (camlint64_of_coqint n)
| Oorl, [r1;r2] -> fprintf pp "%a |l %a" reg r1 reg r2
| Oorlimm n, [r1] -> fprintf pp "%a |l %Ld" reg r1 (camlint64_of_coqint n)
+ | Onorl, [r1; r2] -> fprintf pp "~(%a |l %a)" reg r1 reg r2
+ | Onorlimm n, [r1] -> fprintf pp "~(%a |l %Ld)" reg r1 (camlint64_of_coqint n)
| Oxorl, [r1;r2] -> fprintf pp "%a ^l %a" reg r1 reg r2
| Oxorlimm n, [r1] -> fprintf pp "%a ^l %Ld" reg r1 (camlint64_of_coqint n)
+ | Onxorl, [r1;r2] -> fprintf pp "~(%a ^l %a)" reg r1 reg r2
+ | Onxorlimm n, [r1] -> fprintf pp "~(%a ^l %Ld)" reg r1 (camlint64_of_coqint n)
+ | Onotl, [r1] -> fprintf pp "~%a" reg r1
+ | Oandnl, [r1;r2] -> fprintf pp "(~%a) &l %a" reg r1 reg r2
+ | Oandnlimm n, [r1] -> fprintf pp "(~%a) &l %Ld" reg r1 (camlint64_of_coqint n)
+ | Oornl, [r1;r2] -> fprintf pp "(~%a) |l %a" reg r1 reg r2
+ | Oornlimm n, [r1;r2] -> fprintf pp "(~%a) |l %Ld" reg r1 (camlint64_of_coqint n)
| Oshll, [r1;r2] -> fprintf pp "%a <<l %a" reg r1 reg r2
| Oshllimm n, [r1] -> fprintf pp "%a <<l %Ld" reg r1 (camlint64_of_coqint n)
| Oshrl, [r1;r2] -> fprintf pp "%a >>ls %a" reg r1 reg r2
@@ -124,6 +170,9 @@ let print_operation reg pp = function
| Oshrlu, [r1;r2] -> fprintf pp "%a >>lu %a" reg r1 reg r2
| Oshrluimm n, [r1] -> fprintf pp "%a >>lu %ld" reg r1 (camlint_of_coqint n)
| Oshrxlimm n, [r1] -> fprintf pp "%a >>lx %ld" reg r1 (camlint_of_coqint n)
+ | Omaddl, [r1; r2; r3] -> fprintf pp "%a +l %a *l %a" reg r1 reg r2 reg r3
+ | Omaddlimm imm, [r1; r2] -> fprintf pp "%a +l %a *l %Ld" reg r1 reg r2 (camlint64_of_coqint imm)
+ | Omsubl, [r1; r2; r3] -> fprintf pp "%a -l %a *l %a" reg r1 reg r2 reg r3
| Onegf, [r1] -> fprintf pp "negf(%a)" reg r1
| Oabsf, [r1] -> fprintf pp "absf(%a)" reg r1
@@ -141,24 +190,41 @@ let print_operation reg pp = function
| Ofloatofsingle, [r1] -> fprintf pp "floatofsingle(%a)" reg r1
| Ointoffloat, [r1] -> fprintf pp "intoffloat(%a)" reg r1
| Ointuoffloat, [r1] -> fprintf pp "intuoffloat(%a)" reg r1
- | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1
- | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1
- | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1
- | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1
| Ointofsingle, [r1] -> fprintf pp "intofsingle(%a)" reg r1
| Ointuofsingle, [r1] -> fprintf pp "intuofsingle(%a)" reg r1
| Osingleofint, [r1] -> fprintf pp "singleofint(%a)" reg r1
| Osingleofintu, [r1] -> fprintf pp "singleofintu(%a)" reg r1
+ | Olongoffloat, [r1] -> fprintf pp "longoffloat(%a)" reg r1
+ | Olonguoffloat, [r1] -> fprintf pp "longuoffloat(%a)" reg r1
+ | Ofloatoflong, [r1] -> fprintf pp "floatoflong(%a)" reg r1
+ | Ofloatoflongu, [r1] -> fprintf pp "floatoflongu(%a)" reg r1
| Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1
| Olonguofsingle, [r1] -> fprintf pp "longuofsingle(%a)" reg r1
| Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1
| Osingleoflongu, [r1] -> fprintf pp "singleoflongu(%a)" reg r1
| Ocmp c, args -> print_condition reg pp (c, args)
- | _ -> fprintf pp "<bad operator>"
+
+ | Oextfz(stop, start), [r1] -> fprintf pp "extfz(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1
+ | Oextfs(stop, start), [r1] -> fprintf pp "extfs(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1
+ | Oextfzl(stop, start), [r1] -> fprintf pp "extfzl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1
+ | Oextfsl(stop, start), [r1] -> fprintf pp "extfsl(%ld, %ld, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1
+ | Oinsf(stop, start), [r1; r2] -> fprintf pp "insf(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2
+ | Oinsfl(stop, start), [r1; r2] -> fprintf pp "insfl(%ld, %ld, %a, %a)" (camlint_of_coqint stop) (camlint_of_coqint start) reg r1 reg r2
+ | Osel(cond0, ty), [r1; r2; rc] ->
+ print_condition0 reg pp cond0 rc;
+ fprintf pp " ? %a : %a" reg r1 reg r2
+ | Oselimm(cond0, imm), [r1; rc] ->
+ print_condition0 reg pp cond0 rc;
+ fprintf pp " ? %a : %ld" reg r1 (camlint_of_coqint imm)
+ | Osellimm(cond0, imm), [r1; rc] ->
+ print_condition0 reg pp cond0 rc;
+ fprintf pp " ? %a :l %Ld" reg r1 (camlint64_of_coqint imm)
+ | _, _ -> fprintf pp "<bad operator>"
let print_addressing reg pp = function
- | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n)
+ | Aindexed2XS scale, [r1;r2] -> fprintf pp "%a + (%a << %ld)" reg r1 reg r2 (camlint_of_coqint scale)
| Aindexed2, [r1;r2] -> fprintf pp "%a + %a" reg r1 reg r2
+ | Aindexed n, [r1] -> fprintf pp "%a + %Ld" reg r1 (camlint64_of_ptrofs n)
| Aglobal(id, ofs), [] ->
fprintf pp "\"%s\" + %Ld" (extern_atom id) (camlint64_of_ptrofs ofs)
| Ainstack ofs, [] -> fprintf pp "stack(%Ld)" (camlint64_of_ptrofs ofs)
diff --git a/mppa_k1c/SelectLong.vp b/mppa_k1c/SelectLong.vp
index 717b0120..981c796c 100644
--- a/mppa_k1c/SelectLong.vp
+++ b/mppa_k1c/SelectLong.vp
@@ -66,19 +66,39 @@ Definition longofintu (e: expr) :=
(** ** Integer addition and pointer addition *)
+Definition addlimm_shllimm sh k2 e1 :=
+ if Compopts.optim_addx tt
+ then
+ match shift1_4_of_z (Int.unsigned sh) with
+ | Some s14 => Eop (Oaddxlimm s14 k2) (e1:::Enil)
+ | None => Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil)
+ end
+ else Eop (Oaddlimm k2) ((Eop (Oshllimm sh) (e1:::Enil)):::Enil).
+
Nondetfunction addlimm (n: int64) (e: expr) :=
if Int64.eq n Int64.zero then e else
match e with
| Eop (Olongconst m) Enil => longconst (Int64.add n m)
| Eop (Oaddrsymbol s m) Enil =>
- (if Compopts.optim_fglobaladdroffset tt
+ (if Compopts.optim_globaladdroffset tt
then Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil
else Eop (Oaddlimm n) (e ::: Enil))
| Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int64 n) m)) Enil
| Eop (Oaddlimm m) (t ::: Enil) => Eop (Oaddlimm(Int64.add n m)) (t ::: Enil)
+ | Eop (Oaddxlimm sh m) (t ::: Enil) => Eop (Oaddxlimm sh (Int64.add n m)) (t ::: Enil)
+ | Eop (Oshllimm sh) (t1:::Enil) => addlimm_shllimm sh n t1
| _ => Eop (Oaddlimm n) (e ::: Enil)
end.
+Definition addl_shllimm n e1 e2 :=
+ if Compopts.optim_addx tt
+ then
+ match shift1_4_of_z (Int.unsigned n) with
+ | Some s14 => Eop (Oaddxl s14) (e1:::e2:::Enil)
+ | None => Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil)
+ end
+ else Eop Oaddl (e2:::(Eop (Oshllimm n) (e1:::Enil)):::Enil).
+
Nondetfunction addl (e1: expr) (e2: expr) :=
if Archi.splitlong then SplitLong.addl e1 e2 else
match e1, e2 with
@@ -102,6 +122,10 @@ Nondetfunction addl (e1: expr) (e2: expr) :=
Eop (Omaddlimm n) (t1:::t2:::Enil)
| (Eop (Omullimm n) (t2:::Enil)), t1 =>
Eop (Omaddlimm n) (t1:::t2:::Enil)
+ | (Eop (Oshllimm n) (t1:::Enil)), t2 =>
+ addl_shllimm n t1 t2
+ | t2, (Eop (Oshllimm n) (t1:::Enil)) =>
+ addl_shllimm n t1 t2
| _, _ => Eop Oaddl (e1:::e2:::Enil)
end.
@@ -118,6 +142,10 @@ Nondetfunction subl (e1: expr) (e2: expr) :=
addlimm n1 (Eop Osubl (t1:::t2:::Enil))
| t1, Eop (Oaddlimm n2) (t2:::Enil) =>
addlimm (Int64.neg n2) (Eop Osubl (t1:::t2:::Enil))
+ | t1, (Eop Omull (t2:::t3:::Enil)) =>
+ Eop Omsubl (t1:::t2:::t3:::Enil)
+ | t1, (Eop (Omullimm n) (t2:::Enil)) =>
+ Eop (Omaddlimm (Int64.neg n)) (t1:::t2:::Enil)
| _, _ => Eop Osubl (e1:::e2:::Enil)
end.
@@ -225,7 +253,7 @@ Definition mullimm_base (n1: int64) (e2: expr) :=
| i :: j :: nil =>
Elet e2 (addl (shllimm (Eletvar 0) i) (shllimm (Eletvar 0) j))
| _ =>
- Eop Omull (e2 ::: longconst n1 ::: Enil)
+ Eop (Omullimm n1) (e2 ::: Enil)
end.
Nondetfunction mullimm (n1: int64) (e2: expr) :=
@@ -278,14 +306,6 @@ Nondetfunction andl (e1: expr) (e2: expr) :=
| t1, (Eop Onotl (t2:::Enil)) => Eop Oandnl (t2:::t1:::Enil)
| _, _ => Eop Oandl (e1:::e2:::Enil)
end.
-(*
- | (Eop Ocast32signed
- ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1))
- (y1:::Enil)):::Enil)):::Enil)), v1 =>
- if Int64.eq zero1 Int64.zero
- then Eop Oselectl ((Eop (Olongconst Int64.zero) Enil):::v1:::y1:::Enil)
- else Eop Oandl (e1:::e2:::Enil)
-*)
Nondetfunction orlimm (n1: int64) (e2: expr) :=
if Int64.eq n1 Int64.zero then e2 else
@@ -304,17 +324,6 @@ Nondetfunction orl (e1: expr) (e2: expr) :=
| t1, Eop (Olongconst n2) Enil => orlimm n2 t1
| (Eop Onotl (t1:::Enil)), t2 => Eop Oornl (t1:::t2:::Enil)
| t1, (Eop Onotl (t2:::Enil)) => Eop Oornl (t2:::t1:::Enil)
- | (Eop Oandl ((Eop Ocast32signed
- ((Eop Oneg ((Eop (Ocmp (Ccomplimm Ceq zero0))
- (y0:::Enil)):::Enil)):::Enil)):::v0:::Enil)),
- (Eop Oandl ((Eop Ocast32signed
- ((Eop Oneg ((Eop (Ocmp (Ccomplimm Cne zero1))
- (y1:::Enil)):::Enil)):::Enil)):::v1:::Enil)) =>
- if same_expr_pure y0 y1
- && Int64.eq zero0 Int64.zero
- && Int64.eq zero1 Int64.zero
- then Eop (Oselectl (Ccompl0 Cne)) (v0:::v1:::y0:::Enil)
- else Eop Oorl (e1:::e2:::Enil)
| (Eop (Oandlimm nmask) (prev:::Enil)),
(Eop (Oandlimm mask)
((Eop (Oshllimm start) (fld:::Enil)):::Enil)) =>
diff --git a/mppa_k1c/SelectLongproof.v b/mppa_k1c/SelectLongproof.v
index 3b724c01..ada02585 100644
--- a/mppa_k1c/SelectLongproof.v
+++ b/mppa_k1c/SelectLongproof.v
@@ -119,6 +119,76 @@ Proof.
- TrivialExists.
Qed.
+
+Theorem eval_addlimm_shllimm:
+ forall sh k2, unary_constructor_sound (addlimm_shllimm sh k2) (fun x => ExtValues.addxl sh x (Vlong k2)).
+Proof.
+ red; unfold addlimm_shllimm; intros.
+ destruct (Compopts.optim_addx tt).
+ {
+ destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT.
+ - TrivialExists. simpl.
+ f_equal.
+ unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *.
+ destruct (Z.eq_dec _ _) as [e1|].
+ { replace s14 with SHIFT1 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e1.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e1.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e2|].
+ { replace s14 with SHIFT2 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e2.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e2.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e3|].
+ { replace s14 with SHIFT3 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e3.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e3.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e4|].
+ { replace s14 with SHIFT4 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e4.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e4.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ discriminate.
+ - unfold addxl. rewrite Val.addl_commut.
+ TrivialExists.
+ repeat (try eassumption; try econstructor).
+ simpl.
+ reflexivity.
+ }
+ { unfold addxl. rewrite Val.addl_commut.
+ TrivialExists.
+ repeat (try eassumption; try econstructor).
+ simpl.
+ reflexivity.
+ }
+Qed.
+
Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)).
Proof.
unfold addlimm; intros; red; intros.
@@ -127,7 +197,7 @@ Proof.
destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto.
destruct (addlimm_match a); InvEval.
- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto.
-- destruct (Compopts.optim_fglobaladdroffset _).
+- destruct (Compopts.optim_globaladdroffset _).
+ econstructor; split. EvalOp. simpl; eauto.
unfold Genv.symbol_address. destruct (Genv.find_symbol ge s); simpl; auto.
destruct Archi.ptr64; auto. rewrite Ptrofs.add_commut; auto.
@@ -136,9 +206,58 @@ Proof.
destruct sp; simpl; auto. destruct Archi.ptr64; auto.
rewrite Ptrofs.add_assoc, (Ptrofs.add_commut m0). auto.
- subst x. rewrite Val.addl_assoc. rewrite Int64.add_commut. TrivialExists.
+- TrivialExists; simpl. subst x.
+ destruct v1; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
+ rewrite Int64.add_assoc. rewrite Int64.add_commut.
+ reflexivity.
+- pose proof eval_addlimm_shllimm as ADDXL.
+ unfold unary_constructor_sound in ADDXL.
+ unfold addxl in ADDXL.
+ rewrite Val.addl_commut.
+ subst x.
+ apply ADDXL; assumption.
- TrivialExists.
Qed.
+Lemma eval_addxl: forall n, binary_constructor_sound (addl_shllimm n) (ExtValues.addxl n).
+Proof.
+ red.
+ intros.
+ unfold addl_shllimm.
+ destruct (Compopts.optim_addx tt).
+ {
+ destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT.
+ - TrivialExists.
+ simpl.
+ f_equal. f_equal.
+ unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *.
+ destruct (Z.eq_dec _ _) as [e1|].
+ { replace s14 with SHIFT1 by congruence.
+ rewrite <- e1.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e2|].
+ { replace s14 with SHIFT2 by congruence.
+ rewrite <- e2.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e3|].
+ { replace s14 with SHIFT3 by congruence.
+ rewrite <- e3.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e4|].
+ { replace s14 with SHIFT4 by congruence.
+ rewrite <- e4.
+ apply Int.repr_unsigned. }
+ discriminate.
+ (* Oaddxl *)
+ - TrivialExists;
+ repeat econstructor; eassumption.
+ }
+ { TrivialExists;
+ repeat econstructor; eassumption.
+ }
+Qed.
+
Theorem eval_addl: binary_constructor_sound addl Val.addl.
Proof.
unfold addl. destruct Archi.splitlong eqn:SL.
@@ -193,6 +312,14 @@ Proof.
- subst. rewrite Val.addl_commut. TrivialExists.
- subst. TrivialExists.
- subst. rewrite Val.addl_commut. TrivialExists.
+ - subst. pose proof eval_addxl as ADDXL.
+ unfold binary_constructor_sound in ADDXL.
+ rewrite Val.addl_commut.
+ apply ADDXL; assumption.
+ (* Oaddxl *)
+ - subst. pose proof eval_addxl as ADDXL.
+ unfold binary_constructor_sound in ADDXL.
+ apply ADDXL; assumption.
- TrivialExists.
Qed.
@@ -208,6 +335,23 @@ Proof.
- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp.
- subst. rewrite Val.subl_addl_r.
apply eval_addlimm; EvalOp.
+- TrivialExists. simpl. subst. reflexivity.
+- TrivialExists. simpl. subst.
+ destruct v1; destruct x; simpl; trivial.
+ + f_equal. f_equal.
+ rewrite <- Int64.neg_mul_distr_r.
+ rewrite Int64.sub_add_opp.
+ reflexivity.
+ + destruct (Archi.ptr64) eqn:ARCHI64; simpl; trivial.
+ f_equal. f_equal.
+ rewrite <- Int64.neg_mul_distr_r.
+ rewrite Ptrofs.sub_add_opp.
+ unfold Ptrofs.add.
+ f_equal. f_equal.
+ rewrite (Ptrofs.agree64_neg ARCHI64 (Ptrofs.of_int64 (Int64.mul i n)) (Int64.mul i n)).
+ rewrite (Ptrofs.agree64_of_int ARCHI64 (Int64.neg (Int64.mul i n))).
+ reflexivity.
+ apply (Ptrofs.agree64_of_int ARCHI64).
- TrivialExists.
Qed.
@@ -371,7 +515,7 @@ Proof.
auto. }
generalize (Int64.one_bits'_decomp n); intros D.
destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B.
-- apply DEFAULT.
+- TrivialExists.
- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)).
apply eval_shllimm; auto.
simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto.
@@ -389,7 +533,7 @@ Proof.
rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib).
inv B1; inv B2. simpl in B3; inv B3.
rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto.
-- apply DEFAULT.
+- TrivialExists.
Qed.
Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)).
@@ -516,81 +660,6 @@ Proof.
- InvEval. apply eval_orlimm; auto.
- (*orn*) InvEval. TrivialExists; simpl; congruence.
- (*orn reversed*) InvEval. rewrite Val.orl_commut. TrivialExists; simpl; congruence.
- - (* selectl *)
- destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try TrivialExists.
- predSpec Int64.eq Int64.eq_spec zero0 Int64.zero; simpl; try TrivialExists.
- predSpec Int64.eq Int64.eq_spec zero1 Int64.zero; simpl; [ | TrivialExists].
- inv H.
- inv H0.
- inv H6.
- inv H3.
- inv H2.
- inv H7.
- inv H4.
- inv H3.
- inv H6.
- inv H4.
- inv H3.
- inv H14.
- inv H13.
- inv H6.
- inv H4.
- inv H13.
- inv H14.
- inv H9.
- inv H11.
- inv H13.
- inv H3.
- inv H6.
- inv H7.
- inv H3.
- inv H14.
- inv H17.
- simpl in *.
- inv H8.
- inv H5.
- inv H10.
- inv H12.
- inv H15.
- inv H16.
- inv H11.
- inv H13.
- unfold same_expr_pure in PURE.
- destruct y0; try congruence.
- destruct y1; try congruence.
- destruct (ident_eq i i0); try congruence; clear PURE.
- rewrite <- e0 in *; clear e0.
- inv H6.
- inv H7.
- rename v10 into vtest.
- replace v11 with vtest in * by congruence.
- TrivialExists.
- simpl.
- f_equal.
- rewrite eval_selectl_to2.
- unfold eval_selectl2.
- destruct vtest; simpl; trivial.
- rewrite Val.andl_commut.
- destruct v4; simpl; trivial.
- rewrite Val.andl_commut.
- rewrite Val.orl_commut.
- destruct v9; simpl; trivial.
- rewrite int64_eq_commut.
- destruct (Int64.eq Int64.zero i1); simpl.
-
- + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve.
- replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve.
- rewrite Int64.and_mone.
- rewrite Int64.and_zero.
- rewrite Int64.or_commut.
- rewrite Int64.or_zero.
- reflexivity.
- + replace (Int64.repr (Int.signed (Int.neg Int.one))) with Int64.mone by Int64.bit_solve.
- replace (Int64.repr (Int.signed (Int.neg Int.zero))) with Int64.zero by Int64.bit_solve.
- rewrite Int64.and_mone.
- rewrite Int64.and_zero.
- rewrite Int64.or_zero.
- reflexivity.
- (*insfl first case*)
destruct (is_bitfieldl _ _) eqn:Risbitfield.
diff --git a/mppa_k1c/SelectOp.vp b/mppa_k1c/SelectOp.vp
index 6adcebe5..1cac2257 100644
--- a/mppa_k1c/SelectOp.vp
+++ b/mppa_k1c/SelectOp.vp
@@ -51,9 +51,10 @@ Require Import Floats.
Require Import Op.
Require Import CminorSel.
Require Import OpHelpers.
-Require Import ExtValues.
+Require Import ExtValues ExtFloats.
Require Import DecBoolOps.
Require Import Chunks.
+Require Import Builtins.
Require Compopts.
Local Open Scope cminorsel_scope.
@@ -65,34 +66,52 @@ Section SELECT.
Context {hf: helper_functions}.
+Nondetfunction cond_to_condition0 (cond : condition) (args : exprlist) :=
+ match cond, args with
+ | (Ccompimm c x), (e1 ::: Enil) =>
+ if Int.eq_dec x Int.zero
+ then Some ((Ccomp0 c), e1)
+ else None
+
+ | (Ccompuimm c x), (e1 ::: Enil) =>
+ if Int.eq_dec x Int.zero
+ then Some ((Ccompu0 c), e1)
+ else None
+
+ | (Ccomplimm c x), (e1 ::: Enil) =>
+ if Int64.eq_dec x Int64.zero
+ then Some ((Ccompl0 c), e1)
+ else None
+
+ | (Ccompluimm c x), (e1 ::: Enil) =>
+ if Int64.eq_dec x Int64.zero
+ then Some ((Ccomplu0 c), e1)
+ else None
+
+ | _, _ => None
+ end.
+
(** Ternary operator *)
-Definition select_base o0 o1 oselect :=
- Eop (Oselect (Ccomp0 Cne))
- (o0:::o1:::oselect:::Enil).
-
-Definition select o0 o1 oselect :=
- select_base o0 o1 oselect.
-
-Definition selectl_base o0 o1 oselect :=
- Eop (Oselectl (Ccomp0 Cne))
- (o0:::o1:::oselect:::Enil).
-
-Definition selectl o0 o1 oselect :=
- selectl_base o0 o1 oselect.
-
-Definition selectf_base o0 o1 oselect :=
- Eop (Oselectf (Ccomp0 Cne))
- (o0:::o1:::oselect:::Enil).
-
-Definition selectf o0 o1 oselect :=
- selectf_base o0 o1 oselect.
-
-Definition selectfs_base o0 o1 oselect :=
- Eop (Oselectfs (Ccomp0 Cne))
- (o0:::o1:::oselect:::Enil).
-
-Definition selectfs o0 o1 oselect :=
- selectfs_base o0 o1 oselect.
+Nondetfunction select0 (ty : typ) (cond0 : condition0) (e1 e2 e3: expr) :=
+ match ty, cond0, e1, e2, e3 with
+ | Tint, cond0, e1, (Eop (Ointconst imm) Enil), e3 =>
+ (Eop (Oselimm cond0 imm) (e1 ::: e3 ::: Enil))
+ | Tint, cond0, (Eop (Ointconst imm) Enil), e2, e3 =>
+ (Eop (Oselimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil))
+ | Tlong, cond0, e1, (Eop (Olongconst imm) Enil), e3 =>
+ (Eop (Osellimm cond0 imm) (e1 ::: e3 ::: Enil))
+ | Tlong, cond0, (Eop (Olongconst imm) Enil), e2, e3 =>
+ (Eop (Osellimm (negate_condition0 cond0) imm) (e2 ::: e3 ::: Enil))
+ | _, _, _ => (Eop (Osel cond0 ty) (e1 ::: e2 ::: e3 ::: Enil))
+ end.
+
+Definition select (ty : typ) (cond : condition) (args : exprlist) (e1 e2: expr) : option expr :=
+ Some(
+ match cond_to_condition0 cond args with
+ | None => select0 ty (Ccomp0 Cne) e1 e2 (Eop (Ocmp cond) args)
+ | Some(cond0, ec) => select0 ty cond0 e1 e2 ec
+ end).
+
(** ** Constants **)
@@ -104,6 +123,15 @@ Definition addrstack (ofs: ptrofs) :=
(** ** Integer addition and pointer addition *)
+Definition addimm_shlimm sh k2 e1 :=
+ if Compopts.optim_addx tt
+ then
+ match shift1_4_of_z (Int.unsigned sh) with
+ | Some s14 => Eop (Oaddximm s14 k2) (e1:::Enil)
+ | None => Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil)
+ end
+ else Eop (Oaddimm k2) ((Eop (Oshlimm sh) (e1:::Enil)):::Enil).
+
Nondetfunction addimm (n: int) (e: expr) :=
if Int.eq n Int.zero then e else
match e with
@@ -111,9 +139,20 @@ Nondetfunction addimm (n: int) (e: expr) :=
| Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Ptrofs.add (Ptrofs.of_int n) m)) Enil
| Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Ptrofs.add (Ptrofs.of_int n) m)) Enil
| Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil)
+ | Eop (Oaddximm sh m) (t ::: Enil) => Eop (Oaddximm sh (Int.add n m)) (t ::: Enil)
+ | Eop (Oshlimm sh) (t1:::Enil) => addimm_shlimm sh n t1
| _ => Eop (Oaddimm n) (e ::: Enil)
end.
+Definition add_shlimm n e1 e2 :=
+ if Compopts.optim_addx tt
+ then
+ match shift1_4_of_z (Int.unsigned n) with
+ | Some s14 => Eop (Oaddx s14) (e1:::e2:::Enil)
+ | None => Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil)
+ end
+ else Eop Oadd (e2:::(Eop (Oshlimm n) (e1:::Enil)):::Enil).
+
Nondetfunction add (e1: expr) (e2: expr) :=
match e1, e2 with
| Eop (Ointconst n1) Enil, t2 => addimm n1 t2
@@ -135,7 +174,11 @@ Nondetfunction add (e1: expr) (e2: expr) :=
| t1, (Eop (Omulimm n) (t2:::Enil)) =>
Eop (Omaddimm n) (t1:::t2:::Enil)
| (Eop (Omulimm n) (t2:::Enil)), t1 =>
- Eop (Omaddimm n) (t1:::t2:::Enil)
+ Eop (Omaddimm n) (t1:::t2:::Enil)
+ | (Eop (Oshlimm n) (t1:::Enil)), t2 =>
+ add_shlimm n t1 t2
+ | t2, (Eop (Oshlimm n) (t1:::Enil)) =>
+ add_shlimm n t1 t2
| _, _ => Eop Oadd (e1:::e2:::Enil)
end.
@@ -151,6 +194,10 @@ Nondetfunction sub (e1: expr) (e2: expr) :=
addimm n1 (Eop Osub (t1:::t2:::Enil))
| t1, Eop (Oaddimm n2) (t2:::Enil) =>
addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil))
+ | t1, (Eop Omul (t2:::t3:::Enil)) =>
+ Eop Omsub (t1:::t2:::t3:::Enil)
+ | t1, (Eop (Omulimm n) (t2:::Enil)) =>
+ Eop (Omaddimm (Int.neg n)) (t1:::t2:::Enil)
| _, _ => Eop Osub (e1:::e2:::Enil)
end.
@@ -321,24 +368,6 @@ Nondetfunction or (e1: expr) (e2: expr) :=
else Eop Oor (e1:::e2:::Enil)
| (Eop Onot (t1:::Enil)), t2 => Eop Oorn (t1:::t2:::Enil)
| t1, (Eop Onot (t2:::Enil)) => Eop Oorn (t2:::t1:::Enil)
- | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Ceq zero0))
- (y0:::Enil)):::Enil)):::v0:::Enil)),
- (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompimm Cne zero1))
- (y1:::Enil)):::Enil)):::v1:::Enil)) =>
- if same_expr_pure y0 y1
- && Int.eq zero0 Int.zero
- && Int.eq zero1 Int.zero
- then select_base v0 v1 y0
- else Eop Oor (e1:::e2:::Enil)
- | (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Ceq zero0))
- (y0:::Enil)):::Enil)):::v0:::Enil)),
- (Eop Oand ((Eop Oneg ((Eop (Ocmp (Ccompuimm Cne zero1))
- (y1:::Enil)):::Enil)):::v1:::Enil)) =>
- if same_expr_pure y0 y1
- && Int.eq zero0 Int.zero
- && Int.eq zero1 Int.zero
- then select_base v0 v1 y0
- else Eop Oor (e1:::e2:::Enil)
| (Eop (Oandimm nmask) (prev:::Enil)),
(Eop (Oandimm mask)
((Eop (Oshlimm start) (fld:::Enil)):::Enil)) =>
@@ -584,18 +613,26 @@ Nondetfunction addressing (chunk: memory_chunk) (e: expr) :=
match e with
| Eop (Oaddrstack n) Enil => (Ainstack n, Enil)
| Eop (Oaddrsymbol id ofs) Enil =>
- (if (orb (Archi.pic_code tt) (negb (Compopts.optim_fglobaladdrtmp tt)))
+ (if (orb (Archi.pic_code tt) (negb (Compopts.optim_globaladdrtmp tt)))
then (Aindexed Ptrofs.zero, e:::Enil)
else (Aglobal id ofs, Enil))
| Eop (Oaddimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int n), e1:::Enil)
| Eop (Oaddlimm n) (e1:::Enil) => (Aindexed (Ptrofs.of_int64 n), e1:::Enil)
| Eop Oaddl (e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil) =>
- (if Compopts.optim_fxsaddr tt
+ (if Compopts.optim_xsaddr tt
then let zscale := Int.unsigned scale in
if Z.eq_dec zscale (zscale_of_chunk chunk)
then (Aindexed2XS zscale, e1:::e2:::Enil)
else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil)
else (Aindexed2, e1:::(Eop (Oshllimm scale) (e2:::Enil)):::Enil))
+ | Eop (Oaddxl sh) (e1:::e2:::Enil) =>
+ let zscale := ExtValues.z_of_shift1_4 sh in
+ let scale := Int.repr zscale in
+ (if Compopts.optim_xsaddr tt
+ then if Z.eq_dec zscale (zscale_of_chunk chunk)
+ then (Aindexed2XS zscale, e2:::e1:::Enil)
+ else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil)
+ else (Aindexed2, e2:::(Eop (Oshllimm scale) (e1:::Enil)):::Enil))
| Eop Oaddl (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil)
| _ => (Aindexed Ptrofs.zero, e:::Enil)
end.
@@ -624,9 +661,45 @@ Definition divf_base (e1: expr) (e2: expr) :=
(* Eop Odivf (e1 ::: e2 ::: Enil). *)
Eexternal f64_div sig_ff_f (e1 ::: e2 ::: Enil).
-Definition divfs_base (e1: expr) (e2: expr) :=
+Definition divfs_base1 (e2 : expr) :=
+ Eop Oinvfs (e2 ::: Enil).
+Definition divfs_baseX (e1 : expr) (e2 : expr) :=
(* Eop Odivf (e1 ::: e2 ::: Enil). *)
Eexternal f32_div sig_ss_s (e1 ::: e2 ::: Enil).
+
+Nondetfunction divfs_base (e1: expr) :=
+ match e1 with
+ | Eop (Osingleconst f) Enil =>
+ (if Float32.eq_dec f ExtFloat32.one
+ then divfs_base1
+ else divfs_baseX e1)
+ | _ => divfs_baseX e1
+ end.
+
+Nondetfunction gen_fma args :=
+ match args with
+ | (Eop Onegf (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubf (e3:::e1:::e2:::Enil))
+ | e1:::e2:::e3:::Enil => Some (Eop Ofmaddf (e3:::e1:::e2:::Enil))
+ | _ => None
+ end.
+
+Nondetfunction gen_fmaf args :=
+ match args with
+ | (Eop Onegfs (e1:::Enil)):::e2:::e3:::Enil => Some (Eop Ofmsubfs (e3:::e1:::e2:::Enil))
+ | e1:::e2:::e3:::Enil => Some (Eop Ofmaddfs (e3:::e1:::e2:::Enil))
+ | _ => None
+ end.
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ match b with
+ | BI_fmin => Some (Eop Ominf args)
+ | BI_fmax => Some (Eop Omaxf args)
+ | BI_fminf => Some (Eop Ominfs args)
+ | BI_fmaxf => Some (Eop Omaxfs args)
+ | BI_fabsf => Some (Eop Oabsfs args)
+ | BI_fma => gen_fma args
+ | BI_fmaf => gen_fmaf args
+ end.
End SELECT.
(* Local Variables: *)
diff --git a/mppa_k1c/SelectOpproof.v b/mppa_k1c/SelectOpproof.v
index 22eecfad..6dd00ad5 100644
--- a/mppa_k1c/SelectOpproof.v
+++ b/mppa_k1c/SelectOpproof.v
@@ -17,6 +17,7 @@
(** Correctness of instruction selection for operators *)
+Require Import Builtins.
Require Import Coqlib.
Require Import Maps.
Require Import AST.
@@ -29,6 +30,7 @@ Require Import Globalenvs.
Require Import Cminor.
Require Import Op.
Require Import CminorSel.
+Require Import Builtins1.
Require Import SelectOp.
Require Import Events.
Require Import OpHelpers.
@@ -183,6 +185,75 @@ Proof.
auto.
Qed.
+Theorem eval_addimm_shlimm:
+ forall sh k2, unary_constructor_sound (addimm_shlimm sh k2) (fun x => ExtValues.addx sh x (Vint k2)).
+Proof.
+ red; unfold addimm_shlimm; intros.
+ destruct (Compopts.optim_addx tt).
+ {
+ destruct (shift1_4_of_z (Int.unsigned sh)) as [s14 |] eqn:SHIFT.
+ - TrivialExists. simpl.
+ f_equal.
+ unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *.
+ destruct (Z.eq_dec _ _) as [e1|].
+ { replace s14 with SHIFT1 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e1.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e1.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e2|].
+ { replace s14 with SHIFT2 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e2.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e2.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e3|].
+ { replace s14 with SHIFT3 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e3.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e3.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ destruct (Z.eq_dec _ _) as [e4|].
+ { replace s14 with SHIFT4 by congruence.
+ destruct x; simpl; trivial.
+ replace (Int.ltu _ _) with true by reflexivity.
+ unfold Int.ltu.
+ rewrite e4.
+ replace (if zlt _ _ then true else false) with true by reflexivity.
+ rewrite <- e4.
+ rewrite Int.repr_unsigned.
+ reflexivity.
+ }
+ discriminate.
+ - unfold addx. rewrite Val.add_commut.
+ TrivialExists.
+ repeat (try eassumption; try econstructor).
+ simpl.
+ reflexivity.
+ }
+ { unfold addx. rewrite Val.add_commut.
+ TrivialExists.
+ repeat (try eassumption; try econstructor).
+ simpl.
+ reflexivity.
+ }
+Qed.
+
Theorem eval_addimm:
forall n, unary_constructor_sound (addimm n) (fun x => Val.add x (Vint n)).
Proof.
@@ -198,9 +269,57 @@ Proof.
+ econstructor; split. EvalOp. simpl; eauto.
destruct sp; simpl; auto.
+ TrivialExists; simpl. subst x. rewrite Val.add_assoc. rewrite Int.add_commut. auto.
+ + TrivialExists; simpl. subst x.
+ destruct v1; simpl; trivial.
+ destruct (Int.ltu _ _); simpl; trivial.
+ rewrite Int.add_assoc. rewrite Int.add_commut.
+ reflexivity.
+ + pose proof eval_addimm_shlimm as ADDX.
+ unfold unary_constructor_sound in ADDX.
+ unfold addx in ADDX.
+ rewrite Val.add_commut.
+ subst x.
+ apply ADDX; assumption.
+ TrivialExists.
Qed.
+Lemma eval_addx: forall n, binary_constructor_sound (add_shlimm n) (ExtValues.addx n).
+Proof.
+ red.
+ intros.
+ unfold add_shlimm.
+ destruct (Compopts.optim_addx tt).
+ {
+ destruct (shift1_4_of_z (Int.unsigned n)) as [s14 |] eqn:SHIFT.
+ - TrivialExists.
+ simpl.
+ f_equal. f_equal.
+ unfold shift1_4_of_z, int_of_shift1_4, z_of_shift1_4 in *.
+ destruct (Z.eq_dec _ _) as [e1|].
+ { replace s14 with SHIFT1 by congruence.
+ rewrite <- e1.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e2|].
+ { replace s14 with SHIFT2 by congruence.
+ rewrite <- e2.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e3|].
+ { replace s14 with SHIFT3 by congruence.
+ rewrite <- e3.
+ apply Int.repr_unsigned. }
+ destruct (Z.eq_dec _ _) as [e4|].
+ { replace s14 with SHIFT4 by congruence.
+ rewrite <- e4.
+ apply Int.repr_unsigned. }
+ discriminate.
+ - TrivialExists;
+ repeat econstructor; eassumption.
+ }
+ { TrivialExists;
+ repeat econstructor; eassumption.
+ }
+Qed.
+
Theorem eval_add: binary_constructor_sound add Val.add.
Proof.
red; intros until y.
@@ -238,6 +357,15 @@ Proof.
subst. TrivialExists.
- (* Omaddimm rev *)
subst. rewrite Val.add_commut. TrivialExists.
+ (* Oaddx *)
+ - subst. pose proof eval_addx as ADDX.
+ unfold binary_constructor_sound in ADDX.
+ rewrite Val.add_commut.
+ apply ADDX; assumption.
+ (* Oaddx *)
+ - subst. pose proof eval_addx as ADDX.
+ unfold binary_constructor_sound in ADDX.
+ apply ADDX; assumption.
- TrivialExists.
Qed.
@@ -251,6 +379,12 @@ Proof.
apply eval_addimm; EvalOp.
- subst. rewrite Val.sub_add_l. apply eval_addimm; EvalOp.
- subst. rewrite Val.sub_add_r. apply eval_addimm; EvalOp.
+ - TrivialExists. simpl. subst. reflexivity.
+ - TrivialExists. simpl. subst.
+ rewrite sub_add_neg.
+ rewrite neg_mul_distr_r.
+ unfold Val.neg.
+ reflexivity.
- TrivialExists.
Qed.
@@ -477,7 +611,7 @@ Proof.
change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
apply Val.lessdef_same. f_equal.
transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)).
- unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity.
+ unfold Int.mulhs; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity.
apply Int.same_bits_eq; intros n N.
change Int.zwordsize with 32 in *.
assert (N1: 0 <= n < 64) by omega.
@@ -505,7 +639,7 @@ Proof.
change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
apply Val.lessdef_same. f_equal.
transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)).
- unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity.
+ unfold Int.mulhu; f_equal. rewrite Zbits.Zshiftr_div_two_p by omega. reflexivity.
apply Int.same_bits_eq; intros n N.
change Int.zwordsize with 32 in *.
assert (N1: 0 <= n < 64) by omega.
@@ -624,83 +758,6 @@ Proof.
exists (Val.ror v1 (Vint n2)); split. EvalOp. rewrite Val.or_commut. apply ROR; auto.
- (*orn*) TrivialExists; simpl; congruence.
- (*orn reversed*) rewrite Val.or_commut. TrivialExists; simpl; congruence.
- - (* select *)
- destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT.
- predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT.
- predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT.
- TrivialExists.
- simpl in *.
- unfold eval_select.
- f_equal.
- inv H6.
- inv H7.
- inv H9.
- inv H11.
- unfold same_expr_pure in PURE.
- destruct y0; try congruence.
- destruct y1; try congruence.
- destruct (ident_eq i i0); try congruence.
- rewrite <- e0 in *. clear e0. clear PURE.
- inv H2. inv H5.
- replace v8 with v4 in * by congruence.
- rename v4 into vselect.
- destruct vselect; simpl; trivial;
- destruct v5; simpl; trivial; destruct v9; simpl; trivial;
- destruct (Int.eq i1 Int.zero); simpl; trivial.
- + rewrite Int.neg_zero.
- rewrite Int.and_commut.
- rewrite Int.and_mone.
- rewrite Int.and_commut.
- rewrite Int.and_zero.
- rewrite Int.or_zero.
- reflexivity.
- + rewrite Int.neg_zero.
- rewrite Int.and_commut.
- rewrite Int.and_zero.
- rewrite Int.and_commut.
- rewrite Int.and_mone.
- rewrite Int.or_commut.
- rewrite Int.or_zero.
- reflexivity.
- - (* select unsigned *)
- destruct (same_expr_pure y0 y1) eqn:PURE; simpl; try exact DEFAULT.
- predSpec Int.eq Int.eq_spec zero0 Int.zero; simpl; try exact DEFAULT.
- predSpec Int.eq Int.eq_spec zero1 Int.zero; simpl; try exact DEFAULT.
- TrivialExists.
- simpl in *.
- unfold eval_select.
- f_equal.
- inv H6.
- inv H7.
- inv H9.
- inv H11.
- unfold same_expr_pure in PURE.
- destruct y0; try congruence.
- destruct y1; try congruence.
- destruct (ident_eq i i0); try congruence.
- rewrite <- e0 in *. clear e0. clear PURE.
- inv H2. inv H5.
- replace v8 with v4 in * by congruence.
- rename v4 into vselect.
- destruct vselect; simpl; trivial;
- destruct v5; simpl; trivial;
- destruct v9; simpl; trivial;
- destruct (Int.eq i1 Int.zero); simpl; trivial.
- + rewrite Int.neg_zero.
- rewrite Int.and_commut.
- rewrite Int.and_mone.
- rewrite Int.and_commut.
- rewrite Int.and_zero.
- rewrite Int.or_zero.
- reflexivity.
- + rewrite Int.neg_zero.
- rewrite Int.and_commut.
- rewrite Int.and_zero.
- rewrite Int.and_commut.
- rewrite Int.and_mone.
- rewrite Int.or_commut.
- rewrite Int.or_zero.
- reflexivity.
- set (zstop := (int_highest_bit mask)).
set (zstart := (Int.unsigned start)).
destruct (is_bitfield _ _) eqn:Risbitfield.
@@ -1161,7 +1218,8 @@ Qed.
Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+
+ rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate.
Qed.
Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
@@ -1174,7 +1232,7 @@ Qed.
Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm. compute; auto. discriminate.
Qed.
Theorem eval_intoffloat:
@@ -1311,7 +1369,7 @@ Proof.
- exists (v1 :: nil); split. eauto with evalexpr. simpl.
destruct v1; simpl in H; try discriminate. destruct Archi.ptr64 eqn:SF; inv H.
simpl. auto.
- - destruct (Compopts.optim_fxsaddr tt).
+ - destruct (Compopts.optim_xsaddr tt).
+ destruct (Z.eq_dec _ _).
* exists (v1 :: v2 :: nil); split.
repeat (constructor; auto). simpl. rewrite Int.repr_unsigned. destruct v2; simpl in *; congruence.
@@ -1323,6 +1381,25 @@ Proof.
repeat (constructor; auto). econstructor.
repeat (constructor; auto). eassumption. simpl. congruence.
simpl. congruence.
+ - unfold addxl in *.
+ destruct (Compopts.optim_xsaddr tt).
+ + unfold int_of_shift1_4 in *.
+ destruct (Z.eq_dec _ _).
+ * exists (v0 :: v1 :: nil); split.
+ repeat (constructor; auto). simpl.
+ congruence.
+ * eexists; split.
+ repeat (constructor; auto). eassumption.
+ econstructor.
+ repeat (constructor; auto). eassumption. simpl.
+ reflexivity.
+ simpl. congruence.
+ + eexists; split.
+ repeat (constructor; auto). eassumption.
+ econstructor.
+ repeat (constructor; auto). eassumption. simpl.
+ reflexivity.
+ simpl. unfold int_of_shift1_4 in *. congruence.
- exists (v1 :: v0 :: nil); split. repeat (constructor; auto). simpl. congruence.
- exists (v :: nil); split. eauto with evalexpr. subst. simpl. rewrite Ptrofs.add_zero; auto.
Qed.
@@ -1351,6 +1428,204 @@ Proof.
- constructor; auto.
Qed.
+(* ternary *)
+(* does not work due to possible nondeterminism
+Lemma cond_to_condition0_correct :
+ forall cond : condition,
+ forall al : exprlist,
+ match (cond_to_condition0 cond al) with
+ | None => True
+ | Some(cond0, e1) =>
+ forall le vl v1,
+ eval_expr ge sp e m le e1 v1 ->
+ eval_exprlist ge sp e m le al vl ->
+ (eval_condition0 cond0 v1 m) = (eval_condition cond vl m)
+ end.
+Proof.
+ intros.
+ unfold cond_to_condition0.
+ case (cond_to_condition0_match cond al); trivial.
+ {
+ intros.
+ destruct (Int.eq_dec _ _); trivial.
+ intros until v1.
+ intros He1 Hel.
+ InvEval.
+ simpl.
+ f_equal.
+ eapply eval_expr_determ. eassumption.
+ }
+Qed.
+*)
+
+Lemma eval_neg_condition0:
+ forall cond0: condition0,
+ forall v1: val,
+ forall m: mem,
+ (eval_condition0 (negate_condition0 cond0) v1 m) =
+ option_map negb (eval_condition0 cond0 v1 m).
+Proof.
+ intros.
+ destruct cond0; simpl;
+ try rewrite Val.negate_cmp_bool;
+ try rewrite Val.negate_cmpu_bool;
+ try rewrite Val.negate_cmpl_bool;
+ try rewrite Val.negate_cmplu_bool;
+ reflexivity.
+Qed.
+
+Lemma select_neg:
+ forall a b c,
+ Val.select (option_map negb a) b c =
+ Val.select a c b.
+Proof.
+ destruct a; simpl; trivial.
+ destruct b; simpl; trivial.
+Qed.
+
+Lemma eval_select0:
+ forall le ty cond0 ac vc a1 v1 a2 v2,
+ eval_expr ge sp e m le ac vc ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ exists v,
+ eval_expr ge sp e m le (select0 ty cond0 a1 a2 ac) v
+ /\ Val.lessdef (Val.select (eval_condition0 cond0 vc m) v1 v2 ty) v.
+Proof.
+ intros.
+ unfold select0.
+ destruct (select0_match ty cond0 a1 a2 ac).
+ all: InvEval; econstructor; split;
+ try repeat (try econstructor; try eassumption).
+ all: rewrite eval_neg_condition0; rewrite select_neg; constructor.
+Qed.
+
+Lemma bool_cond0_ne:
+ forall ob : option bool,
+ forall m,
+ (eval_condition0 (Ccomp0 Cne) (Val.of_optbool ob) m) = ob.
+Proof.
+ destruct ob; simpl; trivial.
+ intro.
+ destruct b; reflexivity.
+Qed.
+
+Lemma eval_condition_ccomp_swap :
+ forall c x y m,
+ eval_condition (Ccomp (swap_comparison c)) (x :: y :: nil) m=
+ eval_condition (Ccomp c) (y :: x :: nil) m.
+Proof.
+ intros; unfold eval_condition;
+ apply Val.swap_cmp_bool.
+Qed.
+
+Lemma eval_condition_ccompu_swap :
+ forall c x y m,
+ eval_condition (Ccompu (swap_comparison c)) (x :: y :: nil) m=
+ eval_condition (Ccompu c) (y :: x :: nil) m.
+Proof.
+ intros; unfold eval_condition;
+ apply Val.swap_cmpu_bool.
+Qed.
+
+Lemma eval_condition_ccompl_swap :
+ forall c x y m,
+ eval_condition (Ccompl (swap_comparison c)) (x :: y :: nil) m=
+ eval_condition (Ccompl c) (y :: x :: nil) m.
+Proof.
+ intros; unfold eval_condition;
+ apply Val.swap_cmpl_bool.
+Qed.
+
+Lemma eval_condition_ccomplu_swap :
+ forall c x y m,
+ eval_condition (Ccomplu (swap_comparison c)) (x :: y :: nil) m=
+ eval_condition (Ccomplu c) (y :: x :: nil) m.
+Proof.
+ intros; unfold eval_condition;
+ apply Val.swap_cmplu_bool.
+Qed.
+
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select.
+ intros until b.
+ intro Hop; injection Hop; clear Hop; intro; subst a.
+ intros HeL He1 He2 HeC.
+ unfold cond_to_condition0.
+ destruct (cond_to_condition0_match cond al).
+ {
+ InvEval.
+ rewrite <- HeC.
+ destruct (Int.eq_dec x Int.zero).
+ { subst x.
+ simpl.
+ change (Val.cmp_bool c v0 (Vint Int.zero))
+ with (eval_condition0 (Ccomp0 c) v0 m).
+ eapply eval_select0; eassumption.
+ }
+ simpl.
+ erewrite <- (bool_cond0_ne (Val.cmp_bool c v0 (Vint x))).
+ eapply eval_select0; repeat (try econstructor; try eassumption).
+ }
+ {
+ InvEval.
+ rewrite <- HeC.
+ destruct (Int.eq_dec x Int.zero).
+ { subst x.
+ simpl.
+ change (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint Int.zero))
+ with (eval_condition0 (Ccompu0 c) v0 m).
+ eapply eval_select0; eassumption.
+ }
+ simpl.
+ erewrite <- (bool_cond0_ne (Val.cmpu_bool (Mem.valid_pointer m) c v0 (Vint x))).
+ eapply eval_select0; repeat (try econstructor; try eassumption).
+ }
+ {
+ InvEval.
+ rewrite <- HeC.
+ destruct (Int64.eq_dec x Int64.zero).
+ { subst x.
+ simpl.
+ change (Val.cmpl_bool c v0 (Vlong Int64.zero))
+ with (eval_condition0 (Ccompl0 c) v0 m).
+ eapply eval_select0; eassumption.
+ }
+ simpl.
+ erewrite <- (bool_cond0_ne (Val.cmpl_bool c v0 (Vlong x))).
+ eapply eval_select0; repeat (try econstructor; try eassumption).
+ }
+ {
+ InvEval.
+ rewrite <- HeC.
+ destruct (Int64.eq_dec x Int64.zero).
+ { subst x.
+ simpl.
+ change (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong Int64.zero))
+ with (eval_condition0 (Ccomplu0 c) v0 m).
+ eapply eval_select0; eassumption.
+ }
+ simpl.
+ erewrite <- (bool_cond0_ne (Val.cmplu_bool (Mem.valid_pointer m) c v0 (Vlong x))).
+ eapply eval_select0; repeat (try econstructor; try eassumption).
+ }
+ erewrite <- (bool_cond0_ne (Some b)).
+ eapply eval_select0; repeat (try econstructor; try eassumption).
+ rewrite <- HeC.
+ simpl.
+ reflexivity.
+Qed.
+
(* floating-point division *)
Theorem eval_divf_base:
forall le a b x y,
@@ -1362,6 +1637,29 @@ Proof.
econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.
+
+Lemma eval_divfs_base1:
+ forall le a b x y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (divfs_base1 b) v /\ Val.lessdef (ExtValues.invfs y) v.
+Proof.
+ intros; unfold divfs_base1.
+ econstructor; split.
+ repeat (try econstructor; try eassumption).
+ trivial.
+Qed.
+
+Lemma eval_divfs_baseX:
+ forall le a b x y,
+ eval_expr ge sp e m le a x ->
+ eval_expr ge sp e m le b y ->
+ exists v, eval_expr ge sp e m le (divfs_baseX a b) v /\ Val.lessdef (Val.divfs x y) v.
+Proof.
+ intros; unfold divfs_base.
+ econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+Qed.
+
Theorem eval_divfs_base:
forall le a b x y,
eval_expr ge sp e m le a x ->
@@ -1369,6 +1667,82 @@ Theorem eval_divfs_base:
exists v, eval_expr ge sp e m le (divfs_base a b) v /\ Val.lessdef (Val.divfs x y) v.
Proof.
intros; unfold divfs_base.
- econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
+ destruct (divfs_base_match _).
+ - destruct (Float32.eq_dec _ _).
+ + exists (Val.divfs x y).
+ split; trivial. repeat (try econstructor; try eassumption).
+ simpl. InvEval. reflexivity.
+ + apply eval_divfs_baseX; assumption.
+ - apply eval_divfs_baseX; assumption.
+Qed.
+
+(** Platform-specific known builtins *)
+
+Lemma eval_fma:
+ forall al a vl v le,
+ gen_fma al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem BI_fma vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ unfold gen_fma.
+ intros until le.
+ intro Heval.
+ destruct (gen_fma_match _) in *; try discriminate.
+ all: inversion Heval; subst a; clear Heval; intro; InvEval.
+ - subst v1.
+ TrivialExists.
+ destruct v0; simpl; trivial;
+ destruct v2; simpl; trivial;
+ destruct v3; simpl; trivial.
+ - intro Heval.
+ simpl in Heval.
+ inv Heval.
+ TrivialExists.
+ destruct v0; simpl; trivial;
+ destruct v1; simpl; trivial;
+ destruct v2; simpl; trivial.
+Qed.
+
+Lemma eval_fmaf:
+ forall al a vl v le,
+ gen_fmaf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem BI_fmaf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ unfold gen_fmaf.
+ intros until le.
+ intro Heval.
+ destruct (gen_fmaf_match _) in *; try discriminate.
+ all: inversion Heval; subst a; clear Heval; intro; InvEval.
+ - subst v1.
+ TrivialExists.
+ destruct v0; simpl; trivial;
+ destruct v2; simpl; trivial;
+ destruct v3; simpl; trivial.
+ - intro Heval.
+ simpl in Heval.
+ inv Heval.
+ TrivialExists.
+ destruct v0; simpl; trivial;
+ destruct v1; simpl; trivial;
+ destruct v2; simpl; trivial.
+Qed.
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ destruct bf; intros until le; intro Heval.
+ all: try (inversion Heval; subst a; clear Heval;
+ exists v; split; trivial;
+ repeat (try econstructor; try eassumption)).
+ - apply eval_fma; assumption.
+ - apply eval_fmaf; assumption.
Qed.
+
End CMCONSTR.
diff --git a/mppa_k1c/TargetPrinter.ml b/mppa_k1c/TargetPrinter.ml
index 2bdd0978..63a0bd24 100644
--- a/mppa_k1c/TargetPrinter.ml
+++ b/mppa_k1c/TargetPrinter.ml
@@ -64,7 +64,7 @@ module Target (*: TARGET*) =
| "__compcert_i64_smod" ->
(match idiv_function_kind_64bit() with
| Idiv_system | Idiv_fp -> "__moddi3"
- | Idiv_stsud -> "__compcert_i64_stsud")
+ | Idiv_stsud -> "__compcert_i64_smod_stsud")
| "__compcert_i32_sdiv" as s ->
(match idiv_function_kind_32bit() with
| Idiv_system -> s
@@ -186,11 +186,19 @@ module Target (*: TARGET*) =
| RA -> output_string oc "$ra"
| _ -> assert false
+ let preg_asm oc ty = preg oc
+
let preg_annot = let open Asmvliw in function
| IR r -> int_reg_name r
| RA -> "$ra"
| _ -> assert false
+ let scale_of_shift1_4 = let open ExtValues in function
+ | SHIFT1 -> 2
+ | SHIFT2 -> 4
+ | SHIFT3 -> 8
+ | SHIFT4 -> 16;;
+
(* Names of sections *)
let name_of_section = function
@@ -289,6 +297,10 @@ module Target (*: TARGET*) =
| ARegXS _ -> fprintf oc ".xs"
| _ -> ()
+ let lsvariant oc = function
+ | TRAP -> ()
+ | NOTRAP -> output_string oc ".s"
+
let icond_name = let open Asmvliw in function
| ITne | ITneu -> "ne"
| ITeq | ITequ -> "eq"
@@ -300,10 +312,6 @@ module Target (*: TARGET*) =
| ITgeu -> "geu"
| ITleu -> "leu"
| ITgtu -> "gtu"
- | ITall -> "all"
- | ITnall -> "nall"
- | ITany -> "any"
- | ITnone -> "none"
let icond oc c = fprintf oc "%s" (icond_name c)
@@ -364,7 +372,7 @@ module Target (*: TARGET*) =
(P.to_int kind) (extern_atom txt) args
| EF_inline_asm(txt, sg, clob) ->
fprintf oc "%s begin inline assembly\n\t" comment;
- print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
fprintf oc "%s end inline assembly\n" comment
| _ ->
assert false
@@ -439,10 +447,10 @@ module Target (*: TARGET*) =
fprintf oc " itouchl 0[%a]\n" ireg addr
| Pdzerol addr ->
fprintf oc " dzerol 0[%a]\n" ireg addr
- | Pafaddd(addr, incr_res) ->
- fprintf oc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res
+(* | Pafaddd(addr, incr_res) ->
+ fprintfoc " afaddd 0[%a] = %a\n" ireg addr ireg incr_res
| Pafaddw(addr, incr_res) ->
- fprintf oc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res
+ fprintfoc " afaddw 0[%a] = %a\n" ireg addr ireg incr_res *) (* see #157 *)
| Palclrd(res, addr) ->
fprintf oc " alclrd %a = 0[%a]\n" ireg res ireg addr
| Palclrw(res, addr) ->
@@ -462,18 +470,18 @@ module Target (*: TARGET*) =
section oc Section_text
(* Load/Store instructions *)
- | Plb(rd, ra, adr) ->
- fprintf oc " lbs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
- | Plbu(rd, ra, adr) ->
- fprintf oc " lbz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
- | Plh(rd, ra, adr) ->
- fprintf oc " lhs%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
- | Plhu(rd, ra, adr) ->
- fprintf oc " lhz%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
- | Plw(rd, ra, adr) | Plw_a(rd, ra, adr) | Pfls(rd, ra, adr) ->
- fprintf oc " lws%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
- | Pld(rd, ra, adr) | Pfld(rd, ra, adr) | Pld_a(rd, ra, adr) -> assert Archi.ptr64;
- fprintf oc " ld%a %a = %a[%a]\n" xscale adr ireg rd addressing adr ireg ra
+ | Plb(trap, rd, ra, adr) ->
+ fprintf oc " lbs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
+ | Plbu(trap, rd, ra, adr) ->
+ fprintf oc " lbz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
+ | Plh(trap, rd, ra, adr) ->
+ fprintf oc " lhs%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
+ | Plhu(trap, rd, ra, adr) ->
+ fprintf oc " lhz%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
+ | Plw(trap, rd, ra, adr) | Plw_a(trap, rd, ra, adr) | Pfls(trap, rd, ra, adr) ->
+ fprintf oc " lws%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
+ | Pld(trap, rd, ra, adr) | Pfld(trap, rd, ra, adr) | Pld_a(trap, rd, ra, adr) -> assert Archi.ptr64;
+ fprintf oc " ld%a%a %a = %a[%a]\n" lsvariant trap xscale adr ireg rd addressing adr ireg ra
| Plq(rd, ra, adr) ->
fprintf oc " lq%a %a = %a[%a]\n" xscale adr gpreg_q rd addressing adr ireg ra
| Plo(rd, ra, adr) ->
@@ -574,8 +582,14 @@ module Target (*: TARGET*) =
| Paddw (rd, rs1, rs2) ->
fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Paddxw (s14, rd, rs1, rs2) ->
+ fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs1 ireg rs2
| Psubw (rd, rs1, rs2) ->
fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs2 ireg rs1
+ | Prevsubxw (s14, rd, rs1, rs2) ->
+ fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs1 ireg rs2
| Pmulw (rd, rs1, rs2) ->
fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pandw (rd, rs1, rs2) ->
@@ -604,22 +618,34 @@ module Target (*: TARGET*) =
fprintf oc " sllw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pmaddw (rd, rs1, rs2) ->
fprintf oc " maddw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
-
- | Paddl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Pmsubw (rd, rs1, rs2) ->
+ fprintf oc " msbfw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmaddfw (rd, rs1, rs2) ->
+ fprintf oc " ffmaw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmsubfw (rd, rs1, rs2) ->
+ fprintf oc " ffmsw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+
+ | Paddl (rd, rs1, rs2) ->
fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Paddxl (s14, rd, rs1, rs2) ->
+ fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs1 ireg rs2
| Psubl (rd, rs1, rs2) ->
fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs2 ireg rs1
- | Pandl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Prevsubxl (s14, rd, rs1, rs2) ->
+ fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs1 ireg rs2
+ | Pandl (rd, rs1, rs2) ->
fprintf oc " andd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
- | Pnandl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Pnandl (rd, rs1, rs2) ->
fprintf oc " nandd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
- | Porl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Porl (rd, rs1, rs2) ->
fprintf oc " ord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
- | Pnorl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Pnorl (rd, rs1, rs2) ->
fprintf oc " nord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
- | Pxorl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Pxorl (rd, rs1, rs2) ->
fprintf oc " xord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
- | Pnxorl (rd, rs1, rs2) -> assert Archi.ptr64;
+ | Pnxorl (rd, rs1, rs2) ->
fprintf oc " nxord %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pandnl (rd, rs1, rs2) ->
fprintf oc " andnd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
@@ -637,6 +663,12 @@ module Target (*: TARGET*) =
fprintf oc " srad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pmaddl (rd, rs1, rs2) ->
fprintf oc " maddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pmsubl (rd, rs1, rs2) ->
+ fprintf oc " msbfd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmaddfl (rd, rs1, rs2) ->
+ fprintf oc " ffmad %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmsubfl (rd, rs1, rs2) ->
+ fprintf oc " ffmsd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pfaddd (rd, rs1, rs2) ->
fprintf oc " faddd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
@@ -650,12 +682,30 @@ module Target (*: TARGET*) =
fprintf oc " fmuld %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
| Pfmulw (rd, rs1, rs2) ->
fprintf oc " fmulw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmind (rd, rs1, rs2) ->
+ fprintf oc " fmind %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfminw (rd, rs1, rs2) ->
+ fprintf oc " fminw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmaxd (rd, rs1, rs2) ->
+ fprintf oc " fmaxd %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfmaxw (rd, rs1, rs2) ->
+ fprintf oc " fmaxw %a = %a, %a\n" ireg rd ireg rs1 ireg rs2
+ | Pfinvw (rd, rs1) ->
+ fprintf oc " finvw %a = %a\n" ireg rd ireg rs1
(* Arith RRI32 instructions *)
| Pcompiw (it, rd, rs, imm) ->
fprintf oc " compw.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint imm
| Paddiw (rd, rs, imm) ->
fprintf oc " addw %a = %a, %a\n" ireg rd ireg rs coqint imm
+ | Paddxiw (s14, rd, rs, imm) ->
+ fprintf oc " addx%dw %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs coqint imm
+ | Prevsubiw (rd, rs, imm) ->
+ fprintf oc " sbfw %a = %a, %a\n" ireg rd ireg rs coqint imm
+ | Prevsubxiw (s14, rd, rs, imm) ->
+ fprintf oc " sbfx%dw %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs coqint imm
| Pmuliw (rd, rs, imm) ->
fprintf oc " mulw %a = %a, %a\n" ireg rd ireg rs coqint imm
| Pandiw (rd, rs, imm) ->
@@ -701,6 +751,14 @@ module Target (*: TARGET*) =
fprintf oc " compd.%a %a = %a, %a\n" icond it ireg rd ireg rs coqint64 imm
| Paddil (rd, rs, imm) -> assert Archi.ptr64;
fprintf oc " addd %a = %a, %a\n" ireg rd ireg rs coqint64 imm
+ | Paddxil (s14, rd, rs, imm) ->
+ fprintf oc " addx%dd %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs coqint imm
+ | Prevsubil (rd, rs, imm) ->
+ fprintf oc " sbfd %a = %a, %a\n" ireg rd ireg rs coqint64 imm
+ | Prevsubxil (s14, rd, rs, imm) ->
+ fprintf oc " sbfx%dd %a = %a, %a\n" (scale_of_shift1_4 s14)
+ ireg rd ireg rs coqint64 imm
| Pmulil (rd, rs, imm) -> assert Archi.ptr64;
fprintf oc " muld %a = %a, %a\n" ireg rd ireg rs coqint64 imm
| Pandil (rd, rs, imm) -> assert Archi.ptr64;
@@ -725,6 +783,12 @@ module Target (*: TARGET*) =
| Pcmove (bt, rd, rcond, rs) | Pcmoveu (bt, rd, rcond, rs) ->
fprintf oc " cmoved.%a %a? %a = %a\n"
bcond bt ireg rcond ireg rd ireg rs
+ | Pcmoveiw (bt, rd, rcond, imm) | Pcmoveuiw (bt, rd, rcond, imm) ->
+ fprintf oc " cmoved.%a %a? %a = %a\n"
+ bcond bt ireg rcond ireg rd coqint imm
+ | Pcmoveil (bt, rd, rcond, imm) | Pcmoveuil (bt, rd, rcond, imm) ->
+ fprintf oc " cmoved.%a %a? %a = %a\n"
+ bcond bt ireg rcond ireg rd coqint64 imm
let get_section_names name =
let (text, lit) =
diff --git a/mppa_k1c/ValueAOp.v b/mppa_k1c/ValueAOp.v
index 643cca0c..7d84447e 100644
--- a/mppa_k1c/ValueAOp.v
+++ b/mppa_k1c/ValueAOp.v
@@ -12,7 +12,37 @@
Require Import Coqlib Compopts.
Require Import AST Integers Floats Values Memory Globalenvs.
-Require Import Op ExtValues RTL ValueDomain.
+Require Import Op ExtValues ExtFloats RTL ValueDomain.
+
+Definition minf := binop_float ExtFloat.min.
+Definition maxf := binop_float ExtFloat.max.
+Definition minfs := binop_single ExtFloat32.min.
+Definition maxfs := binop_single ExtFloat32.max.
+
+Definition ntop3 (x y z: aval) : aval := Ifptr (plub (provenance x) (plub (provenance y) (provenance z))).
+
+Definition triple_op_float (sem: float -> float -> float -> float) (x y z: aval) :=
+ match x, y, z with
+ | F a, F b, F c => F (sem a b c)
+ | _, _, _ => ntop3 x y z
+ end.
+
+Definition triple_op_single (sem: float32 -> float32 -> float32 -> float32) (x y z: aval) :=
+ match x, y, z with
+ | FS a, FS b, FS c => FS (sem a b c)
+ | _, _, _ => ntop3 x y z
+ end.
+
+Definition fmaddf := triple_op_float (fun x y z => Float.fma y z x).
+Definition fmsubf := triple_op_float (fun x y z => Float.fma (Float.neg y) z x).
+Definition fmaddfs := triple_op_single (fun x y z => Float32.fma y z x).
+Definition fmsubfs := triple_op_single (fun x y z => Float32.fma (Float32.neg y) z x).
+
+Definition invfs (y : aval) :=
+ match y with
+ | FS f => FS (ExtFloat32.inv f)
+ | _ => ntop1 y
+ end.
(** Value analysis for RISC V operators *)
@@ -51,30 +81,6 @@ Definition eval_static_condition0 (cond : condition0) (v : aval) : abool :=
| Ccomplu0 c => cmplu_bool c v (L Int64.zero)
end.
-Definition eval_static_select (cond : condition0) (v0 v1 vselect : aval) : aval :=
- match eval_static_condition0 cond vselect with
- | Just b => binop_int (fun x0 x1 => if b then x1 else x0) v0 v1
- | _ => Vtop
- end.
-
-Definition eval_static_selectl (cond : condition0) (v0 v1 vselect : aval) : aval :=
- match eval_static_condition0 cond vselect with
- | Just b => binop_long (fun x0 x1 => if b then x1 else x0) v0 v1
- | _ => Vtop
- end.
-
-Definition eval_static_selectf (cond : condition0) (v0 v1 vselect : aval) : aval :=
- match eval_static_condition0 cond vselect with
- | Just b => binop_float (fun x0 x1 => if b then x1 else x0) v0 v1
- | _ => Vtop
- end.
-
-Definition eval_static_selectfs (cond : condition0) (v0 v1 vselect : aval) : aval :=
- match eval_static_condition0 cond vselect with
- | Just b => binop_single (fun x0 x1 => if b then x1 else x0) v0 v1
- | _ => Vtop
- end.
-
Definition eval_static_extfs (stop : Z) (start : Z) (v : aval) :=
if is_bitfield stop start
@@ -161,8 +167,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Ocast16signed, v1 :: nil => sign_ext 16 v1
| Oadd, v1::v2::nil => add v1 v2
| Oaddimm n, v1::nil => add v1 (I n)
+ | Oaddx shift, v1::v2::nil => add v2 (shl v1 (I (int_of_shift1_4 shift)))
+ | Oaddximm shift n, v1::nil => add (I n) (shl v1 (I (int_of_shift1_4 shift)))
| Oneg, v1::nil => neg v1
| Osub, v1::v2::nil => sub v1 v2
+ | Orevsubx shift, v1::v2::nil => sub v2 (shl v1 (I (int_of_shift1_4 shift)))
+ | Orevsubimm n, v1::nil => sub (I n) v1
+ | Orevsubximm shift n, v1::nil => sub (I n) (shl v1 (I (int_of_shift1_4 shift)))
| Omul, v1::v2::nil => mul v1 v2
| Omulimm n, v1::nil => mul v1 (I n)
| Omulhs, v1::v2::nil => mulhs v1 v2
@@ -198,6 +209,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Oshrximm n, v1::nil => shrx v1 (I n)
| Omadd, v1::v2::v3::nil => add v1 (mul v2 v3)
| Omaddimm n, v1::v2::nil => add v1 (mul v2 (I n))
+ | Omsub, v1::v2::v3::nil => sub v1 (mul v2 v3)
| Omakelong, v1::v2::nil => longofwords v1 v2
| Olowlong, v1::nil => loword v1
| Ohighlong, v1::nil => hiword v1
@@ -205,8 +217,13 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Ocast32unsigned, v1::nil => longofintu v1
| Oaddl, v1::v2::nil => addl v1 v2
| Oaddlimm n, v1::nil => addl v1 (L n)
+ | Oaddxl shift, v1::v2::nil => addl v2 (shll v1 (I (int_of_shift1_4 shift)))
+ | Oaddxlimm shift n, v1::nil => addl (L n) (shll v1 (I (int_of_shift1_4 shift)))
| Onegl, v1::nil => negl v1
| Osubl, v1::v2::nil => subl v1 v2
+ | Orevsubxl shift, v1::v2::nil => subl v2 (shll v1 (I (int_of_shift1_4 shift)))
+ | Orevsublimm n, v1::nil => subl (L n) v1
+ | Orevsubxlimm shift n, v1::nil => subl (L n) (shll v1 (I (int_of_shift1_4 shift)))
| Omull, v1::v2::nil => mull v1 v2
| Omullimm n, v1::nil => mull v1 (L n)
| Omullhs, v1::v2::nil => mullhs v1 v2
@@ -241,18 +258,28 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Oshrxlimm n, v1::nil => shrxl v1 (I n)
| Omaddl, v1::v2::v3::nil => addl v1 (mull v2 v3)
| Omaddlimm n, v1::v2::nil => addl v1 (mull v2 (L n))
+ | Omsubl, v1::v2::v3::nil => subl v1 (mull v2 v3)
| Onegf, v1::nil => negf v1
| Oabsf, v1::nil => absf v1
| Oaddf, v1::v2::nil => addf v1 v2
| Osubf, v1::v2::nil => subf v1 v2
| Omulf, v1::v2::nil => mulf v1 v2
| Odivf, v1::v2::nil => divf v1 v2
+ | Ominf, v1::v2::nil => minf v1 v2
+ | Omaxf, v1::v2::nil => maxf v1 v2
+ | Ofmaddf, v1::v2::v3::nil => fmaddf v1 v2 v3
+ | Ofmsubf, v1::v2::v3::nil => fmsubf v1 v2 v3
| Onegfs, v1::nil => negfs v1
| Oabsfs, v1::nil => absfs v1
| Oaddfs, v1::v2::nil => addfs v1 v2
| Osubfs, v1::v2::nil => subfs v1 v2
| Omulfs, v1::v2::nil => mulfs v1 v2
| Odivfs, v1::v2::nil => divfs v1 v2
+ | Ominfs, v1::v2::nil => minfs v1 v2
+ | Omaxfs, v1::v2::nil => maxfs v1 v2
+ | Oinvfs, v1::nil => invfs v1
+ | Ofmaddfs, v1::v2::v3::nil => fmaddfs v1 v2 v3
+ | Ofmsubfs, v1::v2::v3::nil => fmsubfs v1 v2 v3
| Osingleoffloat, v1::nil => singleoffloat v1
| Ofloatofsingle, v1::nil => floatofsingle v1
| Ointoffloat, v1::nil => intoffloat v1
@@ -270,16 +297,15 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Osingleoflong, v1::nil => singleoflong v1
| Osingleoflongu, v1::nil => singleoflongu v1
| Ocmp c, _ => of_optbool (eval_static_condition c vl)
- | (Oselect cond), v0::v1::vselect::nil => eval_static_select cond v0 v1 vselect
- | (Oselectl cond), v0::v1::vselect::nil => eval_static_selectl cond v0 v1 vselect
- | (Oselectf cond), v0::v1::vselect::nil => eval_static_selectf cond v0 v1 vselect
- | (Oselectfs cond), v0::v1::vselect::nil => eval_static_selectfs cond v0 v1 vselect
| (Oextfz stop start), v0::nil => eval_static_extfz stop start v0
| (Oextfs stop start), v0::nil => eval_static_extfs stop start v0
| (Oextfzl stop start), v0::nil => eval_static_extfzl stop start v0
| (Oextfsl stop start), v0::nil => eval_static_extfsl stop start v0
| (Oinsf stop start), v0::v1::nil => eval_static_insf stop start v0 v1
| (Oinsfl stop start), v0::v1::nil => eval_static_insfl stop start v0 v1
+ | Osel c ty, v1::v2::vc::nil => select (eval_static_condition0 c vc) v1 v2
+ | Oselimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (I imm)
+ | Osellimm c imm, v1::vc::nil => select (eval_static_condition0 c vc) v1 (L imm)
| _, _ => Vbot
end.
@@ -291,6 +317,99 @@ Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.
+Lemma minf_sound:
+ forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minf v w) (minf x y).
+Proof.
+ apply (binop_float_sound bc ExtFloat.min); assumption.
+Qed.
+
+Lemma maxf_sound:
+ forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxf v w) (maxf x y).
+Proof.
+ apply (binop_float_sound bc ExtFloat.max); assumption.
+Qed.
+
+Lemma minfs_sound:
+ forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.minfs v w) (minfs x y).
+Proof.
+ apply (binop_single_sound bc ExtFloat32.min); assumption.
+Qed.
+
+Lemma maxfs_sound:
+ forall v x w y, vmatch bc v x -> vmatch bc w y -> vmatch bc (ExtValues.maxfs v w) (maxfs x y).
+Proof.
+ apply (binop_single_sound bc ExtFloat32.max); assumption.
+Qed.
+
+Lemma invfs_sound:
+ forall v x, vmatch bc v x -> vmatch bc (ExtValues.invfs v) (invfs x).
+Proof.
+ intros v x;
+ intro MATCH;
+ inversion MATCH;
+ simpl;
+ constructor.
+Qed.
+
+Lemma triple_op_float_sound:
+ forall f a x b y c z,
+ vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.triple_op_float f a b c)
+ (triple_op_float f x y z).
+Proof.
+ intros until z.
+ intros Hax Hby Hcz.
+ inv Hax; simpl; try constructor;
+ inv Hby; simpl; try constructor;
+ inv Hcz; simpl; try constructor.
+Qed.
+
+Lemma triple_op_single_sound:
+ forall f a x b y c z,
+ vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.triple_op_single f a b c)
+ (triple_op_single f x y z).
+Proof.
+ intros until z.
+ intros Hax Hby Hcz.
+ inv Hax; simpl; try constructor;
+ inv Hby; simpl; try constructor;
+ inv Hcz; simpl; try constructor.
+Qed.
+
+Lemma fmaddf_sound :
+ forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.fmaddf a b c) (fmaddf x y z).
+Proof.
+ intros. unfold ExtValues.fmaddf, fmaddf.
+ apply triple_op_float_sound; assumption.
+Qed.
+
+Lemma fmaddfs_sound :
+ forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.fmaddfs a b c) (fmaddfs x y z).
+Proof.
+ intros. unfold ExtValues.fmaddfs, fmaddfs.
+ apply triple_op_single_sound; assumption.
+Qed.
+
+Lemma fmsubf_sound :
+ forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.fmsubf a b c) (fmsubf x y z).
+Proof.
+ intros. unfold ExtValues.fmsubf, fmsubf.
+ apply triple_op_float_sound; assumption.
+Qed.
+
+Lemma fmsubfs_sound :
+ forall a x b y c z, vmatch bc a x -> vmatch bc b y -> vmatch bc c z ->
+ vmatch bc (ExtValues.fmsubfs a b c) (fmsubfs x y z).
+Proof.
+ intros. unfold ExtValues.fmsubfs, fmsubfs.
+ apply triple_op_single_sound; assumption.
+Qed.
+Hint Resolve minf_sound maxf_sound minfs_sound maxfs_sound invfs_sound fmaddf_sound fmaddfs_sound fmsubf_sound fmsubfs_sound : va.
+
Theorem eval_static_condition_sound:
forall cond vargs m aargs,
list_forall2 (vmatch bc) vargs aargs ->
@@ -353,58 +472,70 @@ Proof.
rewrite Ptrofs.add_zero_l; eauto with va.
Qed.
+Theorem eval_static_addressing_sound_none:
+ forall addr vargs aargs,
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ (eval_static_addressing addr aargs) = Vbot.
+Proof.
+ unfold eval_addressing, eval_static_addressing.
+ intros until aargs. intros Heval_none Hlist.
+ inv Hlist.
+ destruct addr; trivial; discriminate.
+ inv H0.
+ destruct addr; trivial; discriminate.
+ inv H2.
+ destruct addr; trivial; discriminate.
+ inv H3;
+ destruct addr; trivial; discriminate.
+Qed.
+
Theorem eval_static_operation_sound:
forall op vargs m vres aargs,
eval_operation ge (Vptr sp Ptrofs.zero) op vargs m = Some vres ->
list_forall2 (vmatch bc) vargs aargs ->
vmatch bc vres (eval_static_operation op aargs).
Proof.
- unfold eval_operation, eval_static_operation, eval_static_select, eval_static_selectl, eval_static_selectf, eval_static_selectfs; intros;
+ unfold eval_operation, eval_static_operation, addx, revsubx, addxl, revsubxl; intros.
destruct op; InvHyps; eauto with va.
- destruct (propagate_float_constants tt); constructor.
- destruct (propagate_float_constants tt); constructor.
- rewrite Ptrofs.add_zero_l; eauto with va.
- apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
- (* select *)
- - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption).
- rewrite eval_select_to2.
- unfold eval_select2.
- inv Hcond; trivial; try constructor.
- + apply binop_int_sound; assumption.
- + destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- apply vmatch_ifptr_i.
- + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- apply vmatch_ifptr_i.
- (* selectl *)
- - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption).
- rewrite eval_selectl_to2.
- unfold eval_selectl2.
- inv Hcond; trivial; try constructor.
- + apply binop_long_sound; assumption.
- + destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- apply vmatch_ifptr_l.
- + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- apply vmatch_ifptr_l.
- (* selectf *)
- - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption).
- rewrite eval_selectf_to2.
- unfold eval_selectf2.
- inv Hcond; trivial; try constructor.
- + apply binop_float_sound; assumption.
- + destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- constructor.
- + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- constructor.
- (* selectfs *)
- - assert (Hcond : (cmatch (eval_condition0 cond a2 m) (eval_static_condition0 cond b2))) by (apply eval_static_condition0_sound; assumption).
- rewrite eval_selectfs_to2.
- unfold eval_selectfs2.
- inv Hcond; trivial; try constructor.
- + apply binop_single_sound; assumption.
- + destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- constructor.
- + destruct (eval_condition0 cond a2 m); destruct a1; destruct a0; try apply vmatch_ifptr_undef.
- constructor.
+ - destruct (propagate_float_constants tt); constructor.
+ - destruct (propagate_float_constants tt); constructor.
+ - rewrite Ptrofs.add_zero_l; eauto with va.
+ - replace(match Val.shl a1 (Vint (int_of_shift1_4 shift)) with
+ | Vint n2 => Vint (Int.add n n2)
+ | Vptr b2 ofs2 =>
+ if Archi.ptr64
+ then Vundef
+ else Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int n))
+ | _ => Vundef
+ end) with (Val.add (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))).
+ + eauto with va.
+ + destruct a1; destruct shift; reflexivity.
+ - (*revsubimm*) inv H1; constructor.
+ - replace (match Val.shl a1 (Vint (int_of_shift1_4 shift)) with
+ | Vint n2 => Vint (Int.sub n n2)
+ | _ => Vundef
+ end) with (Val.sub (Vint n) (Val.shl a1 (Vint (int_of_shift1_4 shift)))).
+ + eauto with va.
+ + destruct n; destruct shift; reflexivity.
+ - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with
+ | Vlong n2 => Vlong (Int64.add n n2)
+ | Vptr b2 ofs2 =>
+ if Archi.ptr64
+ then Vptr b2 (Ptrofs.add ofs2 (Ptrofs.of_int64 n))
+ else Vundef
+ | _ => Vundef
+ end) with (Val.addl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))).
+ + eauto with va.
+ + destruct a1; destruct shift; reflexivity.
+ - inv H1; constructor.
+ - replace (match Val.shll a1 (Vint (int_of_shift1_4 shift)) with
+ | Vlong n2 => Vlong (Int64.sub n n2)
+ | _ => Vundef
+ end) with (Val.subl (Vlong n) (Val.shll a1 (Vint (int_of_shift1_4 shift)))).
+ + eauto with va.
+ + destruct a1; destruct shift; reflexivity.
+ - apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
(* extfz *)
- unfold extfz, eval_static_extfz.
@@ -440,6 +571,12 @@ Proof.
destruct (is_bitfieldl _ _).
+ inv H1; inv H0; simpl; try constructor; destruct (Int.ltu _ _); simpl; constructor.
+ constructor.
+ (* select *)
+ - apply select_sound; auto. eapply eval_static_condition0_sound; eauto.
+ (* select imm *)
+ - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto.
+ (* select long imm *)
+ - apply select_sound; auto with va. eapply eval_static_condition0_sound; eauto.
Qed.
End SOUNDNESS.
diff --git a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v
index 618f3ebe..cf46072f 100644
--- a/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v
+++ b/mppa_k1c/abstractbb/AbstractBasicBlocksDef.v
@@ -1,6 +1,7 @@
(** Syntax and Sequential Semantics of Abstract Basic Blocks.
*)
-
+Require Import Setoid.
+Require Import ImpPrelude.
Module Type PseudoRegisters.
@@ -24,16 +25,8 @@ Parameter op: Type. (* type of operations *)
Parameter genv: Type. (* environment to be used for evaluating an op *)
-(* NB: possible generalization
- - relation after/before.
-*)
Parameter op_eval: genv -> op -> list value -> option value.
-Parameter is_constant: op -> bool.
-
-Parameter is_constant_correct:
- forall ge o, is_constant o = true -> op_eval ge o nil <> None.
-
End LangParam.
@@ -54,6 +47,9 @@ Definition mem := R.t -> value.
Definition assign (m: mem) (x:R.t) (v: value): mem
:= fun y => if R.eq_dec x y then v else m y.
+
+(** expressions *)
+
Inductive exp :=
| PReg (x:R.t)
| Op (o:op) (le: list_exp)
@@ -140,7 +136,7 @@ Proof.
Qed.
-(** A small theory of bblock equality *)
+(** A small theory of bblock simulation *)
(* equalities on bblock outputs *)
Definition res_eq (om1 om2: option mem): Prop :=
@@ -240,6 +236,195 @@ Qed.
End SEQLANG.
+Module Terms.
+
+(** terms in the symbolic evaluation
+NB: such a term represents the successive computations in one given pseudo-register
+*)
+
+Inductive term :=
+ | Input (x:R.t) (hid:hashcode)
+ | App (o: op) (l: list_term) (hid:hashcode)
+with list_term :=
+ | LTnil (hid:hashcode)
+ | LTcons (t:term) (l:list_term) (hid:hashcode)
+ .
+
+Scheme term_mut := Induction for term Sort Prop
+with list_term_mut := Induction for list_term Sort Prop.
+
+Bind Scope pattern_scope with term.
+Delimit Scope term_scope with term.
+Delimit Scope pattern_scope with pattern.
+
+Notation "[ ]" := (LTnil _) (format "[ ]"): pattern_scope.
+Notation "[ x ]" := (LTcons x [] _): pattern_scope.
+Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil _) _) .. _) _): pattern_scope.
+Notation "o @ l" := (App o l _) (at level 50, no associativity): pattern_scope.
+
+Import HConsingDefs.
+
+Notation "[ ]" := (LTnil unknown_hid) (format "[ ]"): term_scope.
+Notation "[ x ]" := (LTcons x [] unknown_hid): term_scope.
+Notation "[ x ; y ; .. ; z ]" := (LTcons x (LTcons y .. (LTcons z (LTnil unknown_hid) unknown_hid) .. unknown_hid) unknown_hid): term_scope.
+Notation "o @ l" := (App o l unknown_hid) (at level 50, no associativity): term_scope.
+
+Local Open Scope pattern_scope.
+
+Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value :=
+ match t with
+ | Input x _ => Some (m x)
+ | o @ l =>
+ match list_term_eval ge l m with
+ | Some v => op_eval ge o v
+ | _ => None
+ end
+ end
+with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) :=
+ match l with
+ | [] => Some nil
+ | LTcons t l' _ =>
+ match term_eval ge t m, list_term_eval ge l' m with
+ | Some v, Some lv => Some (v::lv)
+ | _, _ => None
+ end
+ end.
+
+
+Definition term_get_hid (t: term): hashcode :=
+ match t with
+ | Input _ hid => hid
+ | App _ _ hid => hid
+ end.
+
+Definition list_term_get_hid (l: list_term): hashcode :=
+ match l with
+ | LTnil hid => hid
+ | LTcons _ _ hid => hid
+ end.
+
+
+Fixpoint allvalid ge (l: list term) m : Prop :=
+ match l with
+ | nil => True
+ | t::nil => term_eval ge t m <> None
+ | t::l' => term_eval ge t m <> None /\ allvalid ge l' m
+ end.
+
+Lemma allvalid_extensionality ge (l: list term) m:
+ allvalid ge l m <-> (forall t, List.In t l -> term_eval ge t m <> None).
+Proof.
+ induction l as [|t l]; simpl; try (tauto).
+ destruct l.
+ - intuition (congruence || eauto).
+ - rewrite IHl; clear IHl. intuition (congruence || eauto).
+Qed.
+
+Record pseudo_term: Type := intro_fail {
+ mayfail: list term;
+ effect: term
+}.
+
+Lemma inf_option_equivalence (A:Type) (o1 o2: option A):
+ (o1 <> None -> o1 = o2) <-> (forall m1, o1 = Some m1 -> o2 = Some m1).
+Proof.
+ destruct o1; intuition (congruence || eauto).
+ symmetry; eauto.
+Qed.
+
+Definition match_pt (t: term) (pt: pseudo_term) :=
+ (forall ge m, term_eval ge t m <> None <-> allvalid ge pt.(mayfail) m)
+ /\ (forall ge m0 m1, term_eval ge t m0 = Some m1 -> term_eval ge pt.(effect) m0 = Some m1).
+
+Lemma intro_fail_correct (l: list term) (t: term) :
+ (forall ge m, term_eval ge t m <> None <-> allvalid ge l m) -> match_pt t (intro_fail l t).
+Proof.
+ unfold match_pt; simpl; intros; intuition congruence.
+Qed.
+Hint Resolve intro_fail_correct: wlp.
+
+Definition identity_fail (t: term):= intro_fail [t] t.
+
+Lemma identity_fail_correct (t: term): match_pt t (identity_fail t).
+Proof.
+ eapply intro_fail_correct; simpl; tauto.
+Qed.
+Global Opaque identity_fail.
+Hint Resolve identity_fail_correct: wlp.
+
+Definition nofail (is_constant: op -> bool) (t: term):=
+ match t with
+ | Input x _ => intro_fail ([])%list t
+ | o @ [] => if is_constant o then (intro_fail ([])%list t) else (identity_fail t)
+ | _ => identity_fail t
+ end.
+
+Lemma nofail_correct (is_constant: op -> bool) t:
+ (forall ge o, is_constant o = true -> op_eval ge o nil <> None) -> match_pt t (nofail is_constant t).
+Proof.
+ destruct t; simpl.
+ + intros; eapply intro_fail_correct; simpl; intuition congruence.
+ + intros; destruct l; simpl; auto with wlp.
+ destruct (is_constant o) eqn:Heqo; simpl; intuition eauto with wlp.
+ eapply intro_fail_correct; simpl; intuition eauto with wlp.
+Qed.
+Global Opaque nofail.
+Hint Resolve nofail_correct: wlp.
+
+Definition term_equiv t1 t2:= forall ge m, term_eval ge t1 m = term_eval ge t2 m.
+
+Global Instance term_equiv_Equivalence : Equivalence term_equiv.
+Proof.
+ split; intro x; unfold term_equiv; intros; eauto.
+ eapply eq_trans; eauto.
+Qed.
+
+Lemma match_pt_term_equiv t1 t2 pt: term_equiv t1 t2 -> match_pt t1 pt -> match_pt t2 pt.
+Proof.
+ unfold match_pt, term_equiv.
+ intros H. intuition; try (erewrite <- H1 in * |- *; congruence).
+ erewrite <- H2; eauto; congruence.
+Qed.
+Hint Resolve match_pt_term_equiv: wlp.
+
+Definition app_fail (l: list term) (pt: pseudo_term): pseudo_term :=
+ {| mayfail := List.rev_append l pt.(mayfail); effect := pt.(effect) |}.
+
+Lemma app_fail_allvalid_correct l pt t1 t2: forall
+ (V1: forall (ge : genv) (m : mem), term_eval ge t1 m <> None <-> allvalid ge (mayfail pt) m)
+ (V2: forall (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail {| mayfail := t1 :: l; effect := t1 |}) m)
+ (ge : genv) (m : mem), term_eval ge t2 m <> None <-> allvalid ge (mayfail (app_fail l pt)) m.
+Proof.
+ intros; generalize (V1 ge m) (V2 ge m); rewrite !allvalid_extensionality; simpl. clear V1 V2.
+ intuition subst.
+ + rewrite rev_append_rev, in_app_iff, <- in_rev in H3. destruct H3; eauto.
+ + eapply H3; eauto.
+ intros. intuition subst.
+ * eapply H2; eauto. intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff; auto.
+ * intros; eapply H0; eauto. rewrite rev_append_rev, in_app_iff, <- in_rev; auto.
+Qed.
+Local Hint Resolve app_fail_allvalid_correct: core.
+
+Lemma app_fail_correct l pt t1 t2:
+ match_pt t1 pt ->
+ match_pt t2 {| mayfail:=t1::l; effect:=t1 |} ->
+ match_pt t2 (app_fail l pt).
+Proof.
+ unfold match_pt in * |- *; intros (V1 & E1) (V2 & E2); split; intros ge m; try (eauto; fail).
+Qed.
+Extraction Inline app_fail.
+
+Import ImpCore.Notations.
+Local Open Scope impure_scope.
+
+Record reduction:= {
+ result:> term -> ?? pseudo_term;
+ result_correct: forall t, WHEN result t ~> pt THEN match_pt t pt;
+}.
+Hint Resolve result_correct: wlp.
+
+End Terms.
+
End MkSeqLanguage.
diff --git a/mppa_k1c/abstractbb/DepTreeTheory.v b/mppa_k1c/abstractbb/DepTreeTheory.v
deleted file mode 100644
index c7bed8bf..00000000
--- a/mppa_k1c/abstractbb/DepTreeTheory.v
+++ /dev/null
@@ -1,456 +0,0 @@
-(** Dependency Trees of Abstract Basic Blocks
-
-with a purely-functional-but-exponential test.
-
-*)
-
-
-Require Setoid. (* in order to rewrite <-> *)
-Require Export AbstractBasicBlocksDef.
-Require Import List.
-
-Module Type PseudoRegDictionary.
-
-Declare Module R: PseudoRegisters.
-
-Parameter t: Type -> Type.
-
-Parameter get: forall {A}, t A -> R.t -> option A.
-
-Parameter set: forall {A}, t A -> R.t -> A -> t A.
-
-Parameter set_spec_eq: forall A d x (v: A),
- get (set d x v) x = Some v.
-
-Parameter set_spec_diff: forall A d x y (v: A),
- x <> y -> get (set d x v) y = get d y.
-
-Parameter empty: forall {A}, t A.
-
-Parameter empty_spec: forall A x,
- get (empty (A:=A)) x = None.
-
-End PseudoRegDictionary.
-
-
-(** * Computations of "bblock" Dependencies and application to the equality test *)
-
-Module DepTree (L: SeqLanguage) (Dict: PseudoRegDictionary with Module R:=L.LP.R).
-
-Export L.
-Export LP.
-
-Section DEPTREE.
-
-(** Dependency Trees of these "bblocks"
-
-NB: each tree represents the successive computations in one given resource
-
-*)
-
-Inductive tree :=
- | Tname (x:R.t)
- | Top (o: op) (l: list_tree)
-with list_tree :=
- | Tnil: list_tree
- | Tcons (t:tree) (l:list_tree): list_tree
- .
-
-
-Fixpoint tree_eval (ge: genv) (t: tree) (m: mem): option value :=
- match t with
- | Tname x => Some (m x)
- | Top o l =>
- match list_tree_eval ge l m with
- | Some v => op_eval ge o v
- | _ => None
- end
- end
-with list_tree_eval ge (l: list_tree) (m: mem) {struct l}: option (list value) :=
- match l with
- | Tnil => Some nil
- | Tcons t l' =>
- match (tree_eval ge t m), (list_tree_eval ge l' m) with
- | Some v, Some lv => Some (v::lv)
- | _, _ => None
- end
- end.
-
-Definition deps_get (d:Dict.t tree) x :=
- match Dict.get d x with
- | None => Tname x
- | Some t => t
- end.
-
-Fixpoint exp_tree (e: exp) d old: tree :=
- match e with
- | PReg x => deps_get d x
- | Op o le => Top o (list_exp_tree le d old)
- | Old e => exp_tree e old old
- end
-with list_exp_tree (le: list_exp) d old: list_tree :=
- match le with
- | Enil => Tnil
- | Econs e le' => Tcons (exp_tree e d old) (list_exp_tree le' d old)
- | LOld le => list_exp_tree le old old
- end.
-
-Record deps:= {pre: genv -> mem -> Prop; post: Dict.t tree}.
-
-Coercion post: deps >-> Dict.t.
-
-Definition deps_eval ge (d: deps) x (m:mem) :=
- tree_eval ge (deps_get d x) m.
-
-Definition deps_set (d:deps) x (t:tree) :=
- {| pre:=(fun ge m => (deps_eval ge d x m) <> None /\ (d.(pre) ge m));
- post:=Dict.set d x t |}.
-
-Definition deps_empty := {| pre:=fun _ _ => True; post:=Dict.empty |}.
-
-Variable ge: genv.
-
-Lemma set_spec_eq d x t m:
- deps_eval ge (deps_set d x t) x m = tree_eval ge t m.
-Proof.
- unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_eq; simpl; auto.
-Qed.
-
-Lemma set_spec_diff d x y t m:
- x <> y -> deps_eval ge (deps_set d x t) y m = deps_eval ge d y m.
-Proof.
- intros; unfold deps_eval, deps_set, deps_get; simpl; rewrite Dict.set_spec_diff; simpl; auto.
-Qed.
-
-Lemma deps_eval_empty x m: deps_eval ge deps_empty x m = Some (m x).
-Proof.
- unfold deps_eval, deps_get; rewrite Dict.empty_spec; simpl; auto.
-Qed.
-
-Hint Rewrite set_spec_eq deps_eval_empty: dict_rw.
-
-Fixpoint inst_deps (i: inst) (d old: deps): deps :=
- match i with
- | nil => d
- | (x, e)::i' =>
- let t:=exp_tree e d old in
- inst_deps i' (deps_set d x t) old
- end.
-
-Fixpoint bblock_deps_rec (p: bblock) (d: deps): deps :=
- match p with
- | nil => d
- | i::p' =>
- let d':=inst_deps i d d in
- bblock_deps_rec p' d'
- end.
-
-Local Hint Resolve deps_eval_empty.
-
-Definition bblock_deps: bblock -> deps
- := fun p => bblock_deps_rec p deps_empty.
-
-Lemma inst_deps_pre_monotonic i old: forall d m,
- (pre (inst_deps i d old) ge m) -> (pre d ge m).
-Proof.
- induction i as [|[y e] i IHi]; simpl; auto.
- intros d a H; generalize (IHi _ _ H); clear H IHi.
- unfold deps_set; simpl; intuition.
-Qed.
-
-Lemma bblock_deps_pre_monotonic p: forall d m,
- (pre (bblock_deps_rec p d) ge m) -> (pre d ge m).
-Proof.
- induction p as [|i p' IHp']; simpl; eauto.
- intros d a H; eapply inst_deps_pre_monotonic; eauto.
-Qed.
-
-Local Hint Resolve inst_deps_pre_monotonic bblock_deps_pre_monotonic.
-
-Lemma tree_eval_exp e od m0 old:
- (forall x, deps_eval ge od x m0 = Some (old x)) ->
- forall d m1,
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- tree_eval ge (exp_tree e d od) m0 = exp_eval ge e m1 old.
-Proof.
- unfold deps_eval in * |- *; intro H.
- induction e using exp_mut with
- (P0:=fun l => forall (d:deps) m1, (forall x, tree_eval ge (deps_get d x) m0 = Some (m1 x)) -> list_tree_eval ge (list_exp_tree l d od) m0 = list_exp_eval ge l m1 old);
- simpl; auto.
- - intros; erewrite IHe; eauto.
- - intros. erewrite IHe, IHe0; eauto.
-Qed.
-
-Lemma inst_deps_abort i m0 x old: forall d,
- pre (inst_deps i d old) ge m0 ->
- deps_eval ge d x m0 = None ->
- deps_eval ge (inst_deps i d old) x m0 = None.
-Proof.
- induction i as [|[y e] i IHi]; simpl; auto.
- intros d VALID H; erewrite IHi; eauto. clear IHi.
- destruct (R.eq_dec x y).
- * subst; autorewrite with dict_rw.
- generalize (inst_deps_pre_monotonic _ _ _ _ VALID); clear VALID.
- unfold deps_set; simpl; intuition congruence.
- * rewrite set_spec_diff; auto.
-Qed.
-
-Lemma block_deps_rec_abort p m0 x: forall d,
- pre (bblock_deps_rec p d) ge m0 ->
- deps_eval ge d x m0 = None ->
- deps_eval ge (bblock_deps_rec p d) x m0 = None.
-Proof.
- induction p; simpl; auto.
- intros d VALID H; erewrite IHp; eauto. clear IHp.
- eapply inst_deps_abort; eauto.
-Qed.
-
-Lemma inst_deps_Some_correct1 i m0 old od:
- (forall x, deps_eval ge od x m0 = Some (old x)) ->
- forall (m1 m2: mem) (d: deps),
- inst_run ge i m1 old = Some m2 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x).
-Proof.
- intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H.
- - inversion_clear H; eauto.
- - intros H0 x0.
- destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence.
- refine (IHi _ _ _ _ _ _); eauto.
- clear x0; intros x0.
- unfold assign; destruct (R.eq_dec x x0).
- * subst; autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
- * rewrite set_spec_diff; auto.
-Qed.
-
-Lemma bblocks_deps_rec_Some_correct1 p m0: forall (m1 m2: mem) d,
- run ge p m1 = Some m2 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x).
-Proof.
- Local Hint Resolve inst_deps_Some_correct1.
- induction p as [ | i p]; simpl; intros m1 m2 d H.
- - inversion_clear H; eauto.
- - intros H0 x0.
- destruct (inst_run ge i m1 m1) eqn: Heqov.
- + refine (IHp _ _ _ _ _ _); eauto.
- + inversion H.
-Qed.
-
-Lemma bblock_deps_Some_correct1 p m0 m1:
- run ge p m0 = Some m1
- -> forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x).
-Proof.
- intros; eapply bblocks_deps_rec_Some_correct1; eauto.
-Qed.
-
-Lemma inst_deps_None_correct i m0 old od:
- (forall x, deps_eval ge od x m0 = Some (old x)) ->
- forall m1 d, pre (inst_deps i d od) ge m0 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- inst_run ge i m1 old = None -> exists x, deps_eval ge (inst_deps i d od) x m0 = None.
-Proof.
- intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d.
- - discriminate.
- - intros VALID H0.
- destruct (exp_eval ge e m1 old) eqn: Heqov.
- + refine (IHi _ _ _ _); eauto.
- intros x0; unfold assign; destruct (R.eq_dec x x0).
- * subst; autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
- * rewrite set_spec_diff; auto.
- + intuition.
- constructor 1 with (x:=x); simpl.
- apply inst_deps_abort; auto.
- autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
-Qed.
-
-Lemma inst_deps_Some_correct2 i m0 old od:
- (forall x, deps_eval ge od x m0 = Some (old x)) ->
- forall (m1 m2: mem) d,
- pre (inst_deps i d od) ge m0 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- (forall x, deps_eval ge (inst_deps i d od) x m0 = Some (m2 x)) ->
- res_eq (Some m2) (inst_run ge i m1 old).
-Proof.
- intro X.
- induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0.
- - intros H; eapply ex_intro; intuition eauto.
- generalize (H0 x); rewrite H.
- congruence.
- - intros H.
- destruct (exp_eval ge e m1 old) eqn: Heqov.
- + refine (IHi _ _ _ _ _ _); eauto.
- intros x0; unfold assign; destruct (R.eq_dec x x0).
- * subst. autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
- * rewrite set_spec_diff; auto.
- + generalize (H x).
- rewrite inst_deps_abort; discriminate || auto.
- autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
-Qed.
-
-Lemma bblocks_deps_rec_Some_correct2 p m0: forall (m1 m2: mem) d,
- pre (bblock_deps_rec p d) ge m0 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- (forall x, deps_eval ge (bblock_deps_rec p d) x m0 = Some (m2 x)) ->
- res_eq (Some m2) (run ge p m1).
-Proof.
- induction p as [|i p]; simpl; intros m1 m2 d VALID H0.
- - intros H; eapply ex_intro; intuition eauto.
- generalize (H0 x); rewrite H.
- congruence.
- - intros H.
- destruct (inst_run ge i m1 m1) eqn: Heqom.
- + refine (IHp _ _ _ _ _ _); eauto.
- + assert (X: exists x, tree_eval ge (deps_get (inst_deps i d d) x) m0 = None).
- { eapply inst_deps_None_correct; eauto. }
- destruct X as [x H1].
- generalize (H x).
- erewrite block_deps_rec_abort; eauto.
- congruence.
-Qed.
-
-
-Lemma bblock_deps_Some_correct2 p m0 m1:
- pre (bblock_deps p) ge m0 ->
- (forall x, deps_eval ge (bblock_deps p) x m0 = Some (m1 x))
- -> res_eq (Some m1) (run ge p m0).
-Proof.
- intros; eapply bblocks_deps_rec_Some_correct2; eauto.
-Qed.
-
-Lemma inst_valid i m0 old od:
- (forall x, deps_eval ge od x m0 = Some (old x)) ->
- forall (m1 m2: mem) (d: deps),
- pre d ge m0 ->
- inst_run ge i m1 old = Some m2 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- pre (inst_deps i d od) ge m0.
-Proof.
- induction i as [|[x e] i IHi]; simpl; auto.
- intros Hold m1 m2 d VALID0 H Hm1.
- destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence.
- eapply IHi; eauto.
- + unfold deps_set in * |- *; simpl.
- rewrite Hm1; intuition congruence.
- + intros x0. unfold assign; destruct (R.eq_dec x x0).
- * subst; autorewrite with dict_rw.
- erewrite tree_eval_exp; eauto.
- * rewrite set_spec_diff; auto.
-Qed.
-
-
-Lemma block_deps_rec_valid p m0: forall (m1 m2: mem) (d:deps),
- pre d ge m0 ->
- run ge p m1 = Some m2 ->
- (forall x, deps_eval ge d x m0 = Some (m1 x)) ->
- pre (bblock_deps_rec p d) ge m0.
-Proof.
- Local Hint Resolve inst_valid.
- induction p as [ | i p]; simpl; intros m1 d H; auto.
- intros H0 H1.
- destruct (inst_run ge i m1 m1) eqn: Heqov; eauto.
- congruence.
-Qed.
-
-Lemma bblock_deps_valid p m0 m1:
- run ge p m0 = Some m1 ->
- pre (bblock_deps p) ge m0.
-Proof.
- intros; eapply block_deps_rec_valid; eauto.
- unfold deps_empty; simpl. auto.
-Qed.
-
-Definition valid ge d m := pre d ge m /\ forall x, deps_eval ge d x m <> None.
-
-Theorem bblock_deps_simu p1 p2:
- (forall m, valid ge (bblock_deps p1) m -> valid ge (bblock_deps p2) m) ->
- (forall m0 x m1, valid ge (bblock_deps p1) m0 -> deps_eval ge (bblock_deps p1) x m0 = Some m1 ->
- deps_eval ge (bblock_deps p2) x m0 = Some m1) ->
- bblock_simu ge p1 p2.
-Proof.
- Local Hint Resolve bblock_deps_valid bblock_deps_Some_correct1.
- unfold valid; intros INCL EQUIV m DONTFAIL.
- destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence.
- assert (X: forall x, deps_eval ge (bblock_deps p1) x m = Some (m1 x)); eauto.
- eapply bblock_deps_Some_correct2; eauto.
- + destruct (INCL m); intuition eauto.
- congruence.
- + intro x; apply EQUIV; intuition eauto.
- congruence.
-Qed.
-
-Lemma valid_set_decompose_1 d t x m:
- valid ge (deps_set d x t) m -> valid ge d m.
-Proof.
- unfold valid; intros ((PRE1 & PRE2) & VALID); split.
- + intuition.
- + intros x0 H. case (R.eq_dec x x0).
- * intuition congruence.
- * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto.
-Qed.
-
-Lemma valid_set_decompose_2 d t x m:
- valid ge (deps_set d x t) m -> tree_eval ge t m <> None.
-Proof.
- unfold valid; intros ((PRE1 & PRE2) & VALID) H.
- generalize (VALID x); autorewrite with dict_rw.
- tauto.
-Qed.
-
-Lemma valid_set_proof d x t m:
- valid ge d m -> tree_eval ge t m <> None -> valid ge (deps_set d x t) m.
-Proof.
- unfold valid; intros (PRE & VALID) PREt. split.
- + split; auto.
- + intros x0; case (R.eq_dec x x0).
- - intros; subst; autorewrite with dict_rw. auto.
- - intros. rewrite set_spec_diff; auto.
-Qed.
-
-End DEPTREE.
-
-End DepTree.
-
-Require Import PArith.
-Require Import FMapPositive.
-
-Module PosDict <: PseudoRegDictionary with Module R:=Pos.
-
-Module R:=Pos.
-
-Definition t:=PositiveMap.t.
-
-Definition get {A} (d:t A) (x:R.t): option A
- := PositiveMap.find x d.
-
-Definition set {A} (d:t A) (x:R.t) (v:A): t A
- := PositiveMap.add x v d.
-
-Local Hint Unfold PositiveMap.E.eq.
-
-Lemma set_spec_eq A d x (v: A):
- get (set d x v) x = Some v.
-Proof.
- unfold get, set; apply PositiveMap.add_1; auto.
-Qed.
-
-Lemma set_spec_diff A d x y (v: A):
- x <> y -> get (set d x v) y = get d y.
-Proof.
- unfold get, set; intros; apply PositiveMap.gso; auto.
-Qed.
-
-Definition empty {A}: t A := PositiveMap.empty A.
-
-Lemma empty_spec A x:
- get (empty (A:=A)) x = None.
-Proof.
- unfold get, empty; apply PositiveMap.gempty; auto.
-Qed.
-
-End PosDict. \ No newline at end of file
diff --git a/mppa_k1c/abstractbb/ImpDep.v b/mppa_k1c/abstractbb/ImpDep.v
deleted file mode 100644
index eebf396d..00000000
--- a/mppa_k1c/abstractbb/ImpDep.v
+++ /dev/null
@@ -1,960 +0,0 @@
-(** Dependency Graph of Abstract Basic Blocks
-
-using imperative hash-consing technique in order to get a linear equivalence test.
-
-*)
-
-Require Export Impure.ImpHCons.
-Export Notations.
-
-Require Export DepTreeTheory.
-
-Require Import PArith.
-
-
-Local Open Scope impure.
-
-Import ListNotations.
-Local Open Scope list_scope.
-
-
-Module Type ImpParam.
-
-Include LangParam.
-
-Parameter op_eq: op -> op -> ?? bool.
-
-Parameter op_eq_correct: forall o1 o2,
- WHEN op_eq o1 o2 ~> b THEN
- b=true -> o1 = o2.
-
-End ImpParam.
-
-
-Module Type ISeqLanguage.
-
-Declare Module LP: ImpParam.
-
-Include MkSeqLanguage LP.
-
-End ISeqLanguage.
-
-
-Module Type ImpDict.
-
-Include PseudoRegDictionary.
-
-Parameter eq_test: forall {A}, t A -> t A -> ?? bool.
-
-Parameter eq_test_correct: forall A (d1 d2: t A),
- WHEN eq_test d1 d2 ~> b THEN
- b=true -> forall x, get d1 x = get d2 x.
-
-(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *)
-
-
-(* only for debugging *)
-Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t.
-
-End ImpDict.
-
-Module ImpDepTree (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R).
-
-Module DT := DepTree L Dict.
-
-Import DT.
-
-Section CanonBuilding.
-
-Variable hC_tree: pre_hashV tree -> ?? hashV tree.
-Hypothesis hC_tree_correct: forall t, WHEN hC_tree t ~> t' THEN pre_data t=data t'.
-
-Variable hC_list_tree: pre_hashV list_tree -> ?? hashV list_tree.
-Hypothesis hC_list_tree_correct: forall t, WHEN hC_list_tree t ~> t' THEN pre_data t=data t'.
-
-(* First, we wrap constructors for hashed values !*)
-
-Local Open Scope positive.
-Local Open Scope list_scope.
-
-Definition hTname (x:R.t) (debug: option pstring): ?? hashV tree :=
- DO hc <~ hash 1;;
- DO hv <~ hash x;;
- hC_tree {| pre_data:=Tname x; hcodes :=[hc;hv]; debug_info := debug |}.
-
-Lemma hTname_correct x dbg:
- WHEN hTname x dbg ~> t THEN (data t)=(Tname x).
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque hTname.
-Hint Resolve hTname_correct: wlp.
-
-Definition hTop (o:op) (l: hashV list_tree) (debug: option pstring) : ?? hashV tree :=
- DO hc <~ hash 2;;
- DO hv <~ hash o;;
- hC_tree {| pre_data:=Top o (data l);
- hcodes:=[hc;hv;hid l];
- debug_info := debug |}.
-
-Lemma hTop_correct o l dbg :
- WHEN hTop o l dbg ~> t THEN (data t)=(Top o (data l)).
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque hTop.
-Hint Resolve hTop_correct: wlp.
-
-Definition hTnil (_: unit): ?? hashV list_tree :=
- hC_list_tree {| pre_data:=Tnil; hcodes := nil; debug_info := None |} .
-
-Lemma hTnil_correct x:
- WHEN hTnil x ~> l THEN (data l)=Tnil.
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque hTnil.
-Hint Resolve hTnil_correct: wlp.
-
-
-Definition hTcons (t: hashV tree) (l: hashV list_tree): ?? hashV list_tree :=
- hC_list_tree {| pre_data:=Tcons (data t) (data l); hcodes := [hid t; hid l]; debug_info := None |}.
-
-Lemma hTcons_correct t l:
- WHEN hTcons t l ~> l' THEN (data l')=Tcons (data t) (data l).
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque hTcons.
-Hint Resolve hTcons_correct: wlp.
-
-(* Second, we use these hashed constructors ! *)
-
-
-Record hdeps:= {hpre: list (hashV tree); hpost: Dict.t (hashV tree)}.
-
-Coercion hpost: hdeps >-> Dict.t.
-
-(* pseudo deps_get *)
-Definition pdeps_get (d:Dict.t (hashV tree)) x : tree :=
- match Dict.get d x with
- | None => Tname x
- | Some t => (data t)
- end.
-
-Definition hdeps_get (d:hdeps) x dbg : ?? hashV tree :=
- match Dict.get d x with
- | None => hTname x dbg
- | Some t => RET t
- end.
-
-Lemma hdeps_get_correct (d:hdeps) x dbg:
- WHEN hdeps_get d x dbg ~> t THEN (data t) = pdeps_get d x.
-Proof.
- unfold hdeps_get, pdeps_get; destruct (Dict.get d x); wlp_simplify.
-Qed.
-Global Opaque hdeps_get.
-Hint Resolve hdeps_get_correct: wlp.
-
-Definition hdeps_valid ge (hd:hdeps) m := forall ht, List.In ht hd.(hpre) -> tree_eval ge (data ht) m <> None.
-
-
-Definition deps_model ge (d: deps) (hd:hdeps): Prop :=
- (forall m, hdeps_valid ge hd m <-> valid ge d m)
- /\ (forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m = (deps_eval ge d x m)).
-
-Lemma deps_model_valid_alt ge d hd: deps_model ge d hd ->
- forall m x, valid ge d m -> tree_eval ge (pdeps_get hd x) m <> None.
-Proof.
- intros (H1 & H2) m x H. rewrite H2; auto.
- unfold valid in H. intuition eauto.
-Qed.
-
-Lemma deps_model_hdeps_valid_alt ge d hd: deps_model ge d hd ->
- forall m x, hdeps_valid ge hd m -> tree_eval ge (pdeps_get hd x) m <> None.
-Proof.
- intros (H1 & H2) m x H. eapply deps_model_valid_alt.
- - split; eauto.
- - rewrite <- H1; auto.
-Qed.
-
-Fixpoint hexp_tree (e: exp) (d od: hdeps) (dbg: option pstring) : ?? hashV tree :=
- match e with
- | PReg x => hdeps_get d x dbg
- | Op o le =>
- DO lt <~ hlist_exp_tree le d od;;
- hTop o lt dbg
- | Old e => hexp_tree e od od dbg
- end
-with hlist_exp_tree (le: list_exp) (d od: hdeps): ?? hashV list_tree :=
- match le with
- | Enil => hTnil tt
- | Econs e le' =>
- DO t <~ hexp_tree e d od None;;
- DO lt <~ hlist_exp_tree le' d od;;
- hTcons t lt
- | LOld le => hlist_exp_tree le od od
- end.
-
-Lemma hexp_tree_correct_x ge e hod od:
- deps_model ge od hod ->
- forall hd d dbg,
- deps_model ge d hd ->
- WHEN hexp_tree e hd hod dbg ~> t THEN forall m, valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m.
-Proof.
- intro H.
- induction e using exp_mut with (P0:=fun le => forall d hd,
- deps_model ge d hd ->
- WHEN hlist_exp_tree le hd hod ~> lt THEN forall m, valid ge d m -> valid ge od m -> list_tree_eval ge (data lt) m = list_tree_eval ge (list_exp_tree le d od) m);
- unfold deps_model, deps_eval in * |- * ; simpl; wlp_simplify.
- - rewrite H1, H4; auto.
- - rewrite H4, <- H0; simpl; auto.
- - rewrite H1; simpl; auto.
- - rewrite H5, <- H0, <- H4; simpl; auto.
-Qed.
-Global Opaque hexp_tree.
-
-Lemma hexp_tree_correct e hd hod dbg:
- WHEN hexp_tree e hd hod dbg ~> t THEN forall ge od d m, deps_model ge od hod -> deps_model ge d hd -> valid ge d m -> valid ge od m -> tree_eval ge (data t) m = tree_eval ge (exp_tree e d od) m.
-Proof.
- unfold wlp; intros; eapply hexp_tree_correct_x; eauto.
-Qed.
-Hint Resolve hexp_tree_correct: wlp.
-
-Definition failsafe (t: tree): bool :=
- match t with
- | Tname x => true
- | Top o Tnil => is_constant o
- | _ => false
- end.
-
-Local Hint Resolve is_constant_correct.
-
-Lemma failsafe_correct ge (t: tree) m: failsafe t = true -> tree_eval ge t m <> None.
-Proof.
- destruct t; simpl; try congruence.
- destruct l; simpl; try congruence.
- eauto.
-Qed.
-Local Hint Resolve failsafe_correct.
-
-Definition naive_set (hd:hdeps) x (t:hashV tree) :=
- {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}.
-
-Lemma naive_set_correct hd x ht ge d t:
- deps_model ge d hd ->
- (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) ->
- deps_model ge (deps_set d x t) (naive_set hd x ht).
-Proof.
- unfold naive_set; intros (DM0 & DM1) EQT; split.
- - intros m.
- destruct (DM0 m) as (PRE & VALID0); clear DM0.
- assert (VALID1: hdeps_valid ge hd m -> pre d ge m). { unfold valid in PRE; tauto. }
- assert (VALID2: hdeps_valid ge hd m -> forall x : Dict.R.t, deps_eval ge d x m <> None). { unfold valid in PRE; tauto. }
- unfold hdeps_valid in * |- *; simpl.
- intuition (subst; eauto).
- + eapply valid_set_proof; eauto.
- erewrite <- EQT; eauto.
- + exploit valid_set_decompose_1; eauto.
- intros X1; exploit valid_set_decompose_2; eauto.
- rewrite <- EQT; eauto.
- + exploit valid_set_decompose_1; eauto.
- - clear DM0. unfold deps_eval, pdeps_get, deps_get in * |- *; simpl.
- Local Hint Resolve valid_set_decompose_1.
- intros; case (R.eq_dec x x0).
- + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto.
- + intros; rewrite !Dict.set_spec_diff; simpl; eauto.
-Qed.
-Local Hint Resolve naive_set_correct.
-
-Definition equiv_hdeps ge (hd1 hd2: hdeps) :=
- (forall m, hdeps_valid ge hd1 m <-> hdeps_valid ge hd2 m)
- /\ (forall m x, hdeps_valid ge hd1 m -> tree_eval ge (pdeps_get hd1 x) m = tree_eval ge (pdeps_get hd2 x) m).
-
-Lemma equiv_deps_symmetry ge hd1 hd2:
- equiv_hdeps ge hd1 hd2 -> equiv_hdeps ge hd2 hd1.
-Proof.
- intros (V1 & P1); split.
- - intros; symmetry; auto.
- - intros; symmetry; eapply P1. rewrite V1; auto.
-Qed.
-
-Lemma equiv_hdeps_models ge hd1 hd2 d:
- deps_model ge d hd1 -> equiv_hdeps ge hd1 hd2 -> deps_model ge d hd2.
-Proof.
- intros (VALID & EQUIV) (HEQUIV & PEQUIV); split.
- - intros m; rewrite <- VALID; auto. symmetry; auto.
- - intros m x H. rewrite <- EQUIV; auto.
- rewrite PEQUIV; auto.
- rewrite VALID; auto.
-Qed.
-
-Definition hdeps_set (hd:hdeps) x (t:hashV tree) :=
- DO ot <~ hdeps_get hd x None;;
- DO b <~ phys_eq ot t;;
- if b then
- RET hd
- else
- RET {| hpre:= if failsafe (data t) then hd.(hpre) else t::hd.(hpre);
- hpost:=Dict.set hd x t |}.
-
-Lemma hdeps_set_correct hd x ht:
- WHEN hdeps_set hd x ht ~> nhd THEN
- forall ge d t, deps_model ge d hd ->
- (forall m, valid ge d m -> tree_eval ge (data ht) m = tree_eval ge t m) ->
- deps_model ge (deps_set d x t) nhd.
-Proof.
- intros; wlp_simplify; eapply equiv_hdeps_models; eauto; unfold equiv_hdeps, hdeps_valid; simpl.
- + split; eauto.
- * intros m; split.
- - intros X1 ht0 X2; apply X1; auto.
- - intros X1 ht0 [Y1 | Y1]. subst.
- rewrite H; eapply deps_model_hdeps_valid_alt; eauto.
- eauto.
- * intros m x0 X1. case (R.eq_dec x x0).
- - intros; subst. unfold pdeps_get at 1. rewrite Dict.set_spec_eq. congruence.
- - intros; unfold pdeps_get; rewrite Dict.set_spec_diff; auto.
- + split; eauto. intros m.
- generalize (failsafe_correct ge (data ht) m); intros FAILSAFE.
- destruct (failsafe _); simpl; intuition (subst; eauto).
-Qed.
-Local Hint Resolve hdeps_set_correct: wlp.
-Global Opaque hdeps_set.
-
-Variable debug_assign: R.t -> ?? option pstring.
-
-Fixpoint hinst_deps (i: inst) (d od: hdeps): ?? hdeps :=
- match i with
- | nil => RET d
- | (x, e)::i' =>
- DO dbg <~ debug_assign x;;
- DO ht <~ hexp_tree e d od dbg;;
- DO nd <~ hdeps_set d x ht;;
- hinst_deps i' nd od
- end.
-
-
-Lemma hinst_deps_correct i: forall hd hod,
- WHEN hinst_deps i hd hod ~> hd' THEN
- forall ge od d, deps_model ge od hod -> deps_model ge d hd -> (forall m, valid ge d m -> valid ge od m) -> deps_model ge (inst_deps i d od) hd'.
-Proof.
- Local Hint Resolve valid_set_proof.
- induction i; simpl; wlp_simplify; eauto 20.
-Qed.
-Global Opaque hinst_deps.
-Local Hint Resolve hinst_deps_correct: wlp.
-
-(* logging info: we log the number of inst-instructions passed ! *)
-Variable log: unit -> ?? unit.
-
-Fixpoint hbblock_deps_rec (p: bblock) (d: hdeps): ?? hdeps :=
- match p with
- | nil => RET d
- | i::p' =>
- log tt;;
- DO d' <~ hinst_deps i d d;;
- hbblock_deps_rec p' d'
- end.
-
-Lemma hbblock_deps_rec_correct p: forall hd,
- WHEN hbblock_deps_rec p hd ~> hd' THEN forall ge d, deps_model ge d hd -> deps_model ge (bblock_deps_rec p d) hd'.
-Proof.
- induction p; simpl; wlp_simplify.
-Qed.
-Global Opaque hbblock_deps_rec.
-Local Hint Resolve hbblock_deps_rec_correct: wlp.
-
-
-Definition hbblock_deps: bblock -> ?? hdeps
- := fun p => hbblock_deps_rec p {| hpre:= nil ; hpost := Dict.empty |}.
-
-Lemma hbblock_deps_correct p:
- WHEN hbblock_deps p ~> hd THEN forall ge, deps_model ge (bblock_deps p) hd.
-Proof.
- unfold bblock_deps; wlp_simplify. eapply H. clear H.
- unfold deps_model, valid, pdeps_get, hdeps_valid, deps_eval, deps_get; simpl; intuition;
- rewrite !Dict.empty_spec in * |- *; simpl in * |- *; try congruence.
-Qed.
-Global Opaque hbblock_deps.
-
-End CanonBuilding.
-
-(* Now, we build the hash-Cons value from a "hash_eq".
-
-Informal specification:
- [hash_eq] must be consistent with the "hashed" constructors defined above.
-
-We expect that pre_hashV values in the code of these "hashed" constructors verify:
-
- (hash_eq (pre_data x) (pre_data y) ~> true) <-> (hcodes x)=(hcodes y)
-
-*)
-
-Definition tree_hash_eq (ta tb: tree): ?? bool :=
- match ta, tb with
- | Tname xa, Tname xb =>
- if R.eq_dec xa xb (* Inefficient in some cases ? *)
- then RET true
- else RET false
- | Top oa lta, Top ob ltb =>
- DO b <~ op_eq oa ob ;;
- if b then phys_eq lta ltb
- else RET false
- | _,_ => RET false
- end.
-
-Local Hint Resolve op_eq_correct: wlp.
-
-Lemma tree_hash_eq_correct: forall ta tb, WHEN tree_hash_eq ta tb ~> b THEN b=true -> ta=tb.
-Proof.
- destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)).
-Qed.
-Global Opaque tree_hash_eq.
-Hint Resolve tree_hash_eq_correct: wlp.
-
-Definition list_tree_hash_eq (lta ltb: list_tree): ?? bool :=
- match lta, ltb with
- | Tnil, Tnil => RET true
- | Tcons ta lta, Tcons tb ltb =>
- DO b <~ phys_eq ta tb ;;
- if b then phys_eq lta ltb
- else RET false
- | _,_ => RET false
- end.
-
-Lemma list_tree_hash_eq_correct: forall lta ltb, WHEN list_tree_hash_eq lta ltb ~> b THEN b=true -> lta=ltb.
-Proof.
- destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)).
-Qed.
-Global Opaque list_tree_hash_eq.
-Hint Resolve list_tree_hash_eq_correct: wlp.
-
-Lemma pdeps_get_intro (d1 d2: hdeps):
- (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall x, pdeps_get d1 x = pdeps_get d2 x).
-Proof.
- unfold pdeps_get; intros H x; rewrite H. destruct (Dict.get d2 x); auto.
-Qed.
-
-Local Hint Resolve hbblock_deps_correct Dict.eq_test_correct: wlp.
-
-(* TODO:
- A REVOIR pour que Dict.test_eq qui soit insensible aux infos de debug !
- (cf. definition ci-dessous).
- Il faut pour généraliser hash_params sur des Setoid (et les Dict aussi, avec ListSetoid, etc)...
- *)
-Program Definition mk_hash_params (log: hashV tree -> ?? unit): Dict.hash_params (hashV tree) :=
- {| (* Dict.test_eq := fun (ht1 ht2: hashV tree) => phys_eq (data ht1) (data ht2); *)
- Dict.test_eq := phys_eq;
- Dict.hashing := fun (ht: hashV tree) => RET (hid ht);
- Dict.log := log |}.
-Obligation 1.
- eauto with wlp.
-Qed.
-
-(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***)
-
-Section Prog_Eq_Gen.
-
-Variable dbg1: R.t -> ?? option pstring. (* debugging of p1 insts *)
-Variable dbg2: R.t -> ?? option pstring. (* log of p2 insts *)
-Variable log1: unit -> ?? unit. (* log of p1 insts *)
-Variable log2: unit -> ?? unit. (* log of p2 insts *)
-
-Variable hco_tree: hashConsing tree.
-Hypothesis hco_tree_correct: hCons_spec hco_tree.
-Variable hco_list: hashConsing list_tree.
-Hypothesis hco_list_correct: hCons_spec hco_list.
-
-Variable print_error_end: hdeps -> hdeps -> ?? unit.
-Variable print_error: pstring -> ?? unit.
-
-Variable check_failpreserv: bool.
-Variable dbg_failpreserv: hashV tree -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *)
-
-Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool :=
- DO failure_in_failpreserv <~ make_cref false;;
- DO r <~ (TRY
- DO d1 <~ hbblock_deps (hC hco_tree) (hC hco_list) dbg1 log1 p1 ;;
- DO d2 <~ hbblock_deps (hC_known hco_tree) (hC_known hco_list) dbg2 log2 p2 ;;
- DO b <~ Dict.eq_test d1 d2 ;;
- if b then (
- if check_failpreserv then (
- let hp := mk_hash_params dbg_failpreserv in
- failure_in_failpreserv.(set)(true);;
- Sets.assert_list_incl hp d2.(hpre) d1.(hpre);;
- RET true
- ) else RET false
- ) else (
- print_error_end d1 d2 ;;
- RET false
- )
- CATCH_FAIL s, _ =>
- DO b <~ failure_in_failpreserv.(get)();;
- if b then RET false
- else print_error s;; RET false
- ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));;
- RET (`r).
-Obligation 1.
- destruct hco_tree_correct as [TEQ1 TEQ2], hco_list_correct as [LEQ1 LEQ2].
- constructor 1; wlp_simplify; try congruence.
- destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0.
- apply bblock_deps_simu; auto.
- + intros m; rewrite <- EQPRE1, <- EQPRE2.
- unfold incl, hdeps_valid in * |- *; intuition eauto.
- + intros m0 x m1 VALID; rewrite <- EQPOST1, <- EQPOST2; auto.
- erewrite pdeps_get_intro; auto.
- auto.
- erewrite <- EQPRE2; auto.
- erewrite <- EQPRE1 in VALID.
- unfold incl, hdeps_valid in * |- *; intuition eauto.
-Qed.
-
-Theorem g_bblock_simu_test_correct p1 p2:
- WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
-Proof.
- wlp_simplify.
- destruct exta0; simpl in * |- *; auto.
-Qed.
-Global Opaque g_bblock_simu_test.
-
-End Prog_Eq_Gen.
-
-
-
-Definition skip (_:unit): ?? unit := RET tt.
-Definition no_dbg (_:R.t): ?? option pstring := RET None.
-
-
-Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ".
-Definition msg_error_on_end: pstring := "mismatch in final assignments !".
-Definition msg_unknow_tree: pstring := "unknown tree node".
-Definition msg_unknow_list_tree: pstring := "unknown list node".
-Definition msg_number: pstring := "on 2nd bblock -- on inst num ".
-Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock".
-
-Definition print_error_end (_ _: hdeps): ?? unit
- := println (msg_prefix +; msg_error_on_end).
-
-Definition print_error (log: logger unit) (s:pstring): ?? unit
- := DO n <~ log_info log ();;
- println (msg_prefix +; msg_number +; n +; " -- " +; s).
-
-Definition failpreserv_error (_: hashV tree): ?? unit
- := println (msg_prefix +; msg_notfailpreserv).
-
-Program Definition bblock_simu_test (p1 p2: bblock): ?? bool :=
- DO log <~ count_logger ();;
- DO hco_tree <~ mk_annot (hCons tree_hash_eq (fun _ => RET msg_unknow_tree));;
- DO hco_list <~ mk_annot (hCons list_tree_hash_eq (fun _ => RET msg_unknow_list_tree));;
- g_bblock_simu_test
- no_dbg
- no_dbg
- skip
- (log_insert log)
- hco_tree _
- hco_list _
- print_error_end
- (print_error log)
- true (* check_failpreserv *)
- failpreserv_error
- p1 p2.
-Obligation 1.
- generalize (hCons_correct _ _ _ _ H0); clear H0.
- constructor 1; wlp_simplify.
-Qed.
-Obligation 2.
- generalize (hCons_correct _ _ _ _ H); clear H.
- constructor 1; wlp_simplify.
-Qed.
-
-Local Hint Resolve g_bblock_simu_test_correct.
-
-Theorem bblock_simu_test_correct p1 p2:
- WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque bblock_simu_test.
-
-
-
-(** This is only to print info on each bblock_simu_test run **)
-Section Verbose_version.
-
-Variable string_of_name: R.t -> ?? pstring.
-Variable string_of_op: op -> ?? pstring.
-
-Definition tree_id (id: caml_string): pstring := "E" +; (CamlStr id).
-Definition list_id (id: caml_string): pstring := "L" +; (CamlStr id).
-
-Local Open Scope string_scope.
-
-Definition print_raw_htree (td: pre_hashV tree): ?? unit :=
- match pre_data td, hcodes td with
- | (Tname x), _ =>
- DO s <~ string_of_name x;;
- println( "init_access " +; s)
- | (Top o Tnil), _ =>
- DO so <~ string_of_op o;;
- println so
- | (Top o _), [ _; _; lid ] =>
- DO so <~ string_of_op o;;
- DO sl <~ string_of_hashcode lid;;
- println (so +; " " +; (list_id sl))
- | _, _ => FAILWITH "unexpected hcodes"
- end.
-
-Definition print_raw_hlist(ld: pre_hashV list_tree): ?? unit :=
- match pre_data ld, hcodes ld with
- | Tnil, _ => println ""
- | (Tcons _ _), [ t ; l ] =>
- DO st <~ string_of_hashcode t ;;
- DO sl <~ string_of_hashcode l ;;
- println((tree_id st) +; " " +; (list_id sl))
- | _, _ => FAILWITH "unexpected hcodes"
- end.
-
-Section PrettryPrint.
-
-Variable get_htree: hashcode -> ?? pre_hashV tree.
-Variable get_hlist: hashcode -> ?? pre_hashV list_tree.
-
-(* NB: requires [t = pre_data pt] *)
-Fixpoint string_of_tree (t: tree) (pt: pre_hashV tree) : ?? pstring :=
- match debug_info pt with
- | Some x => RET x
- | None =>
- match t, hcodes pt with
- | Tname x, _ => string_of_name x
- | Top o Tnil, _ => string_of_op o
- | Top o (_ as l), [ _; _; lid ] =>
- DO so <~ string_of_op o;;
- DO pl <~ get_hlist lid;;
- DO sl <~ string_of_list_tree l pl;;
- RET (so +; "(" +; sl +; ")")
- | _, _ => FAILWITH "unexpected hcodes"
- end
- end
-(* NB: requires [l = pre_data pl] *)
-with string_of_list_tree (l: list_tree) (lt: pre_hashV list_tree): ?? pstring :=
- match l, hcodes lt with
- | Tnil, _ => RET (Str "")
- | Tcons t Tnil, [ tid ; l ] =>
- DO pt <~ get_htree tid;;
- string_of_tree t pt
- | Tcons t l', [ tid ; lid' ] =>
- DO pt <~ get_htree tid;;
- DO st <~ string_of_tree t pt;;
- DO pl' <~ get_hlist lid';;
- DO sl <~ string_of_list_tree l' pl';;
- RET (st +; "," +; sl)
- | _, _ => FAILWITH "unexpected hcodes"
- end.
-
-
-End PrettryPrint.
-
-
-Definition pretty_tree ext exl pt :=
- DO r <~ string_of_tree (get_hashV ext) (get_hashV exl) (pre_data pt) pt;;
- println(r).
-
-Fixpoint print_head (head: list pstring): ?? unit :=
- match head with
- | i::head' => println ("--- inst " +; i);; print_head head'
- | _ => RET tt
- end.
-
-Definition print_htree ext exl (head: list pstring) (hid: hashcode) (td: pre_hashV tree): ?? unit :=
- print_head head;;
- DO s <~ string_of_hashcode hid ;;
- print ((tree_id s) +; ": ");;
- print_raw_htree td;;
- match debug_info td with
- | Some x =>
- print("// " +; x +; " <- ");;
- pretty_tree ext exl {| pre_data:=(pre_data td); hcodes:=(hcodes td); debug_info:=None |}
- | None => RET tt
- end.
-
-Definition print_hlist (head: list pstring) (hid: hashcode) (ld: pre_hashV list_tree): ?? unit :=
- print_head head;;
- DO s <~ string_of_hashcode hid ;;
- print ((list_id s) +; ": ");;
- print_raw_hlist ld.
-
-Definition print_tables ext exl: ?? unit :=
- println "-- tree table --" ;;
- iterall ext (print_htree ext exl);;
- println "-- list table --" ;;
- iterall exl print_hlist;;
- println "----------------".
-
-Definition print_final_debug ext exl (d1 d2: hdeps): ?? unit
- := DO b <~ Dict.not_eq_witness d1 d2 ;;
- match b with
- | Some x =>
- DO s <~ string_of_name x;;
- println("mismatch on: " +; s);;
- match Dict.get d1 x with
- | None => println("=> unassigned in 1st bblock")
- | Some ht1 =>
- print("=> node expected from 1st bblock: ");;
- DO pt1 <~ get_hashV ext (hid ht1);;
- pretty_tree ext exl pt1
- end;;
- match Dict.get d2 x with
- | None => println("=> unassigned in 2nd bblock")
- | Some ht2 =>
- print("=> node found from 2nd bblock: ");;
- DO pt2 <~ get_hashV ext (hid ht2);;
- pretty_tree ext exl pt2
- end
- | None => FAILWITH "bug in Dict.not_eq_witness ?"
- end.
-
-Inductive witness:=
- | Htree (pt: pre_hashV tree)
- | Hlist (pl: pre_hashV list_tree)
- | Nothing
- .
-
-Definition msg_tree (cr: cref witness) td :=
- set cr (Htree td);;
- RET msg_unknow_tree.
-
-Definition msg_list (cr: cref witness) tl :=
- set cr (Hlist tl);;
- RET msg_unknow_list_tree.
-
-Definition print_witness ext exl cr msg :=
- DO wit <~ get cr ();;
- match wit with
- | Htree pt =>
- println("=> unknown tree node: ");;
- pretty_tree ext exl {| pre_data:=(pre_data pt); hcodes:=(hcodes pt); debug_info:=None |};;
- println("=> encoded on " +; msg +; " graph as: ");;
- print_raw_htree pt
- | Hlist pl =>
- println("=> unknown list node: ");;
- DO r <~ string_of_list_tree (get_hashV ext) (get_hashV exl) (pre_data pl) pl;;
- println(r);;
- println("=> encoded on " +; msg +; " graph as: ");;
- print_raw_hlist pl
- | _ => println "Unexpected failure: no witness info (hint: hash-consing bug ?)"
- end.
-
-
-Definition print_error_end1 hct hcl (d1 d2:hdeps): ?? unit
- := println "- GRAPH of 1st bblock";;
- DO ext <~ export hct ();;
- DO exl <~ export hcl ();;
- print_tables ext exl;;
- print_error_end d1 d2;;
- print_final_debug ext exl d1 d2.
-
-Definition print_error1 hct hcl cr log s : ?? unit
- := println "- GRAPH of 1st bblock";;
- DO ext <~ export hct ();;
- DO exl <~ export hcl ();;
- print_tables ext exl;;
- print_error log s;;
- print_witness ext exl cr "1st".
-
-
-Definition xmsg_number: pstring := "on 1st bblock -- on inst num ".
-
-Definition print_error_end2 hct hcl (d1 d2:hdeps): ?? unit
- := println (msg_prefix +; msg_error_on_end);;
- println "- GRAPH of 2nd bblock";;
- DO ext <~ export hct ();;
- DO exl <~ export hcl ();;
- print_tables ext exl.
-
-Definition print_error2 hct hcl cr (log: logger unit) (s:pstring): ?? unit
- := DO n <~ log_info log ();;
- DO ext <~ export hct ();;
- DO exl <~ export hcl ();;
- println (msg_prefix +; xmsg_number +; n +; " -- " +; s);;
- print_witness ext exl cr "2nd";;
- println "- GRAPH of 2nd bblock";;
- print_tables ext exl.
-
-Definition simple_debug (x: R.t): ?? option pstring :=
- DO s <~ string_of_name x;;
- RET (Some s).
-
-Definition log_debug (log: logger unit) (x: R.t): ?? option pstring :=
- DO i <~ log_info log ();;
- DO sx <~ string_of_name x;;
- RET (Some (sx +; "@" +; i)).
-
-Definition hlog (log: logger unit) (hct: hashConsing tree) (hcl: hashConsing list_tree): unit -> ?? unit :=
- (fun _ =>
- log_insert log tt ;;
- DO s <~ log_info log tt;;
- next_log hct s;;
- next_log hcl s
- ).
-
-Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool :=
- DO log1 <~ count_logger ();;
- DO log2 <~ count_logger ();;
- DO cr <~ make_cref Nothing;;
- DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));;
- DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));;
- DO result1 <~ g_bblock_simu_test
- (log_debug log1)
- simple_debug
- (hlog log1 hco_tree hco_list)
- (log_insert log2)
- hco_tree _
- hco_list _
- (print_error_end1 hco_tree hco_list)
- (print_error1 hco_tree hco_list cr log2)
- true
- failpreserv_error (* TODO: debug info *)
- p1 p2;;
- if result1
- then RET true
- else
- DO log1 <~ count_logger ();;
- DO log2 <~ count_logger ();;
- DO cr <~ make_cref Nothing;;
- DO hco_tree <~ mk_annot (hCons tree_hash_eq (msg_tree cr));;
- DO hco_list <~ mk_annot (hCons list_tree_hash_eq (msg_list cr));;
- DO result2 <~ g_bblock_simu_test
- (log_debug log1)
- simple_debug
- (hlog log1 hco_tree hco_list)
- (log_insert log2)
- hco_tree _
- hco_list _
- (print_error_end2 hco_tree hco_list)
- (print_error2 hco_tree hco_list cr log2)
- false
- (fun _ => RET tt)
- p2 p1;;
- if result2
- then (
- println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");;
- RET false
- ) else RET false
- .
-Obligation 1.
- generalize (hCons_correct _ _ _ _ H0); clear H0.
- constructor 1; wlp_simplify.
-Qed.
-Obligation 2.
- generalize (hCons_correct _ _ _ _ H); clear H.
- constructor 1; wlp_simplify.
-Qed.
-Obligation 3.
- generalize (hCons_correct _ _ _ _ H0); clear H0.
- constructor 1; wlp_simplify.
-Qed.
-Obligation 4.
- generalize (hCons_correct _ _ _ _ H); clear H.
- constructor 1; wlp_simplify.
-Qed.
-
-Theorem verb_bblock_simu_test_correct p1 p2:
- WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
-Proof.
- wlp_simplify.
-Qed.
-Global Opaque verb_bblock_simu_test.
-
-End Verbose_version.
-
-
-End ImpDepTree.
-
-Require Import FMapPositive.
-
-Module ImpPosDict <: ImpDict with Module R:=Pos.
-
-Include PosDict.
-Import PositiveMap.
-
-Fixpoint eq_test {A} (d1 d2: t A): ?? bool :=
- match d1, d2 with
- | Leaf _, Leaf _ => RET true
- | Node l1 (Some x1) r1, Node l2 (Some x2) r2 =>
- DO b0 <~ phys_eq x1 x2 ;;
- if b0 then
- DO b1 <~ eq_test l1 l2 ;;
- if b1 then
- eq_test r1 r2
- else
- RET false
- else
- RET false
- | Node l1 None r1, Node l2 None r2 =>
- DO b1 <~ eq_test l1 l2 ;;
- if b1 then
- eq_test r1 r2
- else
- RET false
- | _, _ => RET false
- end.
-
-Lemma eq_test_correct A d1: forall (d2: t A),
- WHEN eq_test d1 d2 ~> b THEN
- b=true -> forall x, get d1 x = get d2 x.
-Proof.
- unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl;
- wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)).
-Qed.
-Global Opaque eq_test.
-
-(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *)
-Fixpoint pick {A} (d: t A): ?? R.t :=
- match d with
- | Leaf _ => FAILWITH "unexpected empty dictionary"
- | Node _ (Some _) _ => RET xH
- | Node (Leaf _) None r =>
- DO p <~ pick r;;
- RET (xI p)
- | Node l None _ =>
- DO p <~ pick l;;
- RET (xO p)
- end.
-
-(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *)
-Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t :=
- match d1, d2 with
- | Leaf _, Leaf _ => RET None
- | Node l1 (Some x1) r1, Node l2 (Some x2) r2 =>
- DO b0 <~ phys_eq x1 x2 ;;
- if b0 then
- DO b1 <~ not_eq_witness l1 l2;;
- match b1 with
- | None =>
- DO b2 <~ not_eq_witness r1 r2;;
- match b2 with
- | None => RET None
- | Some p => RET (Some (xI p))
- end
- | Some p => RET (Some (xO p))
- end
- else
- RET (Some xH)
- | Node l1 None r1, Node l2 None r2 =>
- DO b1 <~ not_eq_witness l1 l2;;
- match b1 with
- | None =>
- DO b2 <~ not_eq_witness r1 r2;;
- match b2 with
- | None => RET None
- | Some p => RET (Some (xI p))
- end
- | Some p => RET (Some (xO p))
- end
- | l, Leaf _ => DO p <~ pick l;; RET (Some p)
- | Leaf _, r => DO p <~ pick r;; RET (Some p)
- | _, _ => RET (Some xH)
- end.
-
-End ImpPosDict.
-
diff --git a/mppa_k1c/abstractbb/ImpSimuTest.v b/mppa_k1c/abstractbb/ImpSimuTest.v
new file mode 100644
index 00000000..7a77ec15
--- /dev/null
+++ b/mppa_k1c/abstractbb/ImpSimuTest.v
@@ -0,0 +1,1246 @@
+(** Implementation of a symbolic execution of sequential semantics of Abstract Basic Blocks
+
+with imperative hash-consing, and rewriting.
+
+*)
+
+Require Export Impure.ImpHCons.
+Export Notations.
+Import HConsing.
+
+
+Require Export SeqSimuTheory.
+
+Require Import PArith.
+
+
+Local Open Scope impure.
+
+Import ListNotations.
+Local Open Scope list_scope.
+
+
+Module Type ImpParam.
+
+Include LangParam.
+
+Parameter op_eq: op -> op -> ?? bool.
+
+Parameter op_eq_correct: forall o1 o2,
+ WHEN op_eq o1 o2 ~> b THEN
+ b=true -> o1 = o2.
+
+End ImpParam.
+
+
+Module Type ISeqLanguage.
+
+Declare Module LP: ImpParam.
+
+Include MkSeqLanguage LP.
+
+End ISeqLanguage.
+
+
+Module Type ImpDict.
+
+Declare Module R: PseudoRegisters.
+
+Parameter t: Type -> Type.
+
+Parameter get: forall {A}, t A -> R.t -> option A.
+
+Parameter set: forall {A}, t A -> R.t -> A -> t A.
+
+Parameter set_spec_eq: forall A d x (v: A),
+ get (set d x v) x = Some v.
+
+Parameter set_spec_diff: forall A d x y (v: A),
+ x <> y -> get (set d x v) y = get d y.
+
+Parameter rem: forall {A}, t A -> R.t -> t A.
+
+Parameter rem_spec_eq: forall A (d: t A) x,
+ get (rem d x) x = None.
+
+Parameter rem_spec_diff: forall A (d: t A) x y,
+ x <> y -> get (rem d x) y = get d y.
+
+Parameter empty: forall {A}, t A.
+
+Parameter empty_spec: forall A x,
+ get (empty (A:=A)) x = None.
+
+Parameter eq_test: forall {A}, t A -> t A -> ?? bool.
+
+Parameter eq_test_correct: forall A (d1 d2: t A),
+ WHEN eq_test d1 d2 ~> b THEN
+ b=true -> forall x, get d1 x = get d2 x.
+
+(* NB: we could also take an eq_test on R.t (but not really useful with "pure" dictionaries *)
+
+
+(* only for debugging *)
+Parameter not_eq_witness: forall {A}, t A -> t A -> ?? option R.t.
+
+End ImpDict.
+
+
+Module Type ImpSimuInterface.
+
+Declare Module CoreL: ISeqLanguage.
+Import CoreL.
+Import Terms.
+
+Parameter bblock_simu_test: reduction -> bblock -> bblock -> ?? bool.
+
+Parameter bblock_simu_test_correct: forall reduce (p1 p2 : bblock),
+ WHEN bblock_simu_test reduce p1 p2 ~> b
+ THEN b = true -> forall ge : genv, bblock_simu ge p1 p2.
+
+
+Parameter verb_bblock_simu_test
+ : reduction ->
+ (R.t -> ?? pstring) ->
+ (op -> ?? pstring) -> bblock -> bblock -> ?? bool.
+
+Parameter verb_bblock_simu_test_correct:
+ forall reduce
+ (string_of_name : R.t -> ?? pstring)
+ (string_of_op : op -> ?? pstring)
+ (p1 p2 : bblock),
+ WHEN verb_bblock_simu_test reduce string_of_name string_of_op p1 p2 ~> b
+ THEN b = true -> forall ge : genv, bblock_simu ge p1 p2.
+
+End ImpSimuInterface.
+
+
+
+Module ImpSimu (L: ISeqLanguage) (Dict: ImpDict with Module R:=L.LP.R): ImpSimuInterface with Module CoreL := L.
+
+Module CoreL:=L.
+
+Module ST := SimuTheory L.
+
+Import ST.
+Import Terms.
+
+Definition term_set_hid (t: term) (hid: hashcode): term :=
+ match t with
+ | Input x _ => Input x hid
+ | App op l _ => App op l hid
+ end.
+
+Definition list_term_set_hid (l: list_term) (hid: hashcode): list_term :=
+ match l with
+ | LTnil _ => LTnil hid
+ | LTcons t l' _ => LTcons t l' hid
+ end.
+
+Lemma term_eval_set_hid ge t hid m:
+ term_eval ge (term_set_hid t hid) m = term_eval ge t m.
+Proof.
+ destruct t; simpl; auto.
+Qed.
+
+Lemma list_term_eval_set_hid ge l hid m:
+ list_term_eval ge (list_term_set_hid l hid) m = list_term_eval ge l m.
+Proof.
+ destruct l; simpl; auto.
+Qed.
+
+(* Local nickname *)
+Module D:=ImpPrelude.Dict.
+
+Section SimuWithReduce.
+
+Variable reduce: reduction.
+
+Section CanonBuilding.
+
+Variable hC_term: hashinfo term -> ?? term.
+Hypothesis hC_term_correct: forall t, WHEN hC_term t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m.
+
+Variable hC_list_term: hashinfo list_term -> ?? list_term.
+Hypothesis hC_list_term_correct: forall t, WHEN hC_list_term t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m.
+
+(* First, we wrap constructors for hashed values !*)
+
+Local Open Scope positive.
+Local Open Scope list_scope.
+
+Definition hInput_hcodes (x:R.t) :=
+ DO hc <~ hash 1;;
+ DO hv <~ hash x;;
+ RET [hc;hv].
+Extraction Inline hInput_hcodes.
+
+Definition hInput (x:R.t): ?? term :=
+ DO hv <~ hInput_hcodes x;;
+ hC_term {| hdata:=Input x unknown_hid; hcodes :=hv; |}.
+
+Lemma hInput_correct x:
+ WHEN hInput x ~> t THEN forall ge m, term_eval ge t m = Some (m x).
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque hInput.
+Hint Resolve hInput_correct: wlp.
+
+Definition hApp_hcodes (o:op) (l: list_term) :=
+ DO hc <~ hash 2;;
+ DO hv <~ hash o;;
+ RET [hc;hv;list_term_get_hid l].
+Extraction Inline hApp_hcodes.
+
+Definition hApp (o:op) (l: list_term) : ?? term :=
+ DO hv <~ hApp_hcodes o l;;
+ hC_term {| hdata:=App o l unknown_hid; hcodes:=hv |}.
+
+Lemma hApp_correct o l:
+ WHEN hApp o l ~> t THEN forall ge m,
+ term_eval ge t m = match list_term_eval ge l m with
+ | Some v => op_eval ge o v
+ | None => None
+ end.
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque hApp.
+Hint Resolve hApp_correct: wlp.
+
+Definition hLTnil (_: unit): ?? list_term :=
+ hC_list_term {| hdata:=LTnil unknown_hid; hcodes := nil; |} .
+
+Lemma hLTnil_correct x:
+ WHEN hLTnil x ~> l THEN forall ge m, list_term_eval ge l m = Some nil.
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque hLTnil.
+Hint Resolve hLTnil_correct: wlp.
+
+
+Definition hLTcons (t: term) (l: list_term): ?? list_term :=
+ hC_list_term {| hdata:=LTcons t l unknown_hid; hcodes := [term_get_hid t; list_term_get_hid l]; |}.
+
+Lemma hLTcons_correct t l:
+ WHEN hLTcons t l ~> l' THEN forall ge m,
+ list_term_eval ge l' m = match term_eval ge t m, list_term_eval ge l m with
+ | Some v, Some lv => Some (v::lv)
+ | _, _ => None
+ end.
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque hLTcons.
+Hint Resolve hLTcons_correct: wlp.
+
+(* Second, we use these hashed constructors ! *)
+
+Record hsmem:= {hpre: list term; hpost:> Dict.t term}.
+
+(** evaluation of the post-condition *)
+Definition hsmem_post_eval ge (hd: Dict.t term) x (m:mem) :=
+ match Dict.get hd x with
+ | None => Some (m x)
+ | Some ht => term_eval ge ht m
+ end.
+
+Definition hsmem_get (d:hsmem) x: ?? term :=
+ match Dict.get d x with
+ | None => hInput x
+ | Some t => RET t
+ end.
+
+Lemma hsmem_get_correct (d:hsmem) x:
+ WHEN hsmem_get d x ~> t THEN forall ge m, term_eval ge t m = hsmem_post_eval ge d x m.
+Proof.
+ unfold hsmem_get, hsmem_post_eval; destruct (Dict.get d x); wlp_simplify.
+Qed.
+Global Opaque hsmem_get.
+Hint Resolve hsmem_get_correct: wlp.
+
+Local Opaque allvalid.
+
+Definition smem_model ge (d: smem) (hd:hsmem): Prop :=
+ (forall m, allvalid ge hd.(hpre) m <-> smem_valid ge d m)
+ /\ (forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m = (ST.term_eval ge (d x) m)).
+
+Lemma smem_model_smem_valid_alt ge d hd: smem_model ge d hd ->
+ forall m x, smem_valid ge d m -> hsmem_post_eval ge hd x m <> None.
+Proof.
+ intros (H1 & H2) m x H. rewrite H2; auto.
+ unfold smem_valid in H. intuition eauto.
+Qed.
+
+Lemma smem_model_allvalid_alt ge d hd: smem_model ge d hd ->
+ forall m x, allvalid ge hd.(hpre) m -> hsmem_post_eval ge hd x m <> None.
+Proof.
+ intros (H1 & H2) m x H. eapply smem_model_smem_valid_alt.
+ - split; eauto.
+ - rewrite <- H1; auto.
+Qed.
+
+Definition naive_set (hd:hsmem) x (t:term) :=
+ {| hpre:= t::hd.(hpre); hpost:=Dict.set hd x t |}.
+
+Lemma naive_set_correct hd x ht ge d t:
+ smem_model ge d hd ->
+ (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) ->
+ smem_model ge (smem_set d x t) (naive_set hd x ht).
+Proof.
+ unfold naive_set; intros (DM0 & DM1) EQT; split.
+ - intros m.
+ destruct (DM0 m) as (PRE & VALID0); clear DM0.
+ assert (VALID1: allvalid ge hd.(hpre) m -> pre d ge m). { unfold smem_valid in PRE; tauto. }
+ assert (VALID2: allvalid ge hd.(hpre) m -> forall x : Dict.R.t, ST.term_eval ge (d x) m <> None). { unfold smem_valid in PRE; tauto. }
+ rewrite !allvalid_extensionality in * |- *; simpl.
+ intuition (subst; eauto).
+ + eapply smem_valid_set_proof; eauto.
+ erewrite <- EQT; eauto.
+ + exploit smem_valid_set_decompose_1; eauto.
+ intros X1; exploit smem_valid_set_decompose_2; eauto.
+ rewrite <- EQT; eauto.
+ + exploit smem_valid_set_decompose_1; eauto.
+ - clear DM0. unfold hsmem_post_eval, hsmem_post_eval in * |- *; simpl.
+ Local Hint Resolve smem_valid_set_decompose_1: core.
+ intros; case (R.eq_dec x x0).
+ + intros; subst; rewrite !Dict.set_spec_eq; simpl; eauto.
+ + intros; rewrite !Dict.set_spec_diff; simpl; eauto.
+Qed.
+Local Hint Resolve naive_set_correct: core.
+
+Definition equiv_hsmem ge (hd1 hd2: hsmem) :=
+ (forall m, allvalid ge hd1.(hpre) m <-> allvalid ge hd2.(hpre) m)
+ /\ (forall m x, allvalid ge hd1.(hpre) m -> hsmem_post_eval ge hd1 x m = hsmem_post_eval ge hd2 x m).
+
+Lemma equiv_smem_symmetry ge hd1 hd2:
+ equiv_hsmem ge hd1 hd2 -> equiv_hsmem ge hd2 hd1.
+Proof.
+ intros (V1 & P1); split.
+ - intros; symmetry; auto.
+ - intros; symmetry; eapply P1. rewrite V1; auto.
+Qed.
+
+Lemma equiv_hsmem_models ge hd1 hd2 d:
+ smem_model ge d hd1 -> equiv_hsmem ge hd1 hd2 -> smem_model ge d hd2.
+Proof.
+ intros (VALID & EQUIV) (HEQUIV & PEQUIV); split.
+ - intros m; rewrite <- VALID; auto. symmetry; auto.
+ - intros m x H. rewrite <- EQUIV; auto.
+ rewrite PEQUIV; auto.
+ rewrite VALID; auto.
+Qed.
+
+Variable log_assign: R.t -> term -> ?? unit.
+
+Definition lift {A B} hid (x:A) (k: B -> ?? A) (y:B): ?? A :=
+ DO b <~ phys_eq hid unknown_hid;;
+ if b then k y else RET x.
+
+Fixpoint hterm_lift (t: term): ?? term :=
+ match t with
+ | Input x hid => lift hid t hInput x
+ | App o l hid =>
+ lift hid t
+ (fun l => DO lt <~ hlist_term_lift l;;
+ hApp o lt) l
+ end
+with hlist_term_lift (l: list_term) {struct l}: ?? list_term :=
+ match l with
+ | LTnil hid => lift hid l hLTnil ()
+ | LTcons t l' hid =>
+ lift hid l
+ (fun t => DO t <~ hterm_lift t;;
+ DO lt <~ hlist_term_lift l';;
+ hLTcons t lt) t
+ end.
+
+Lemma hterm_lift_correct t:
+ WHEN hterm_lift t ~> ht THEN forall ge m, term_eval ge ht m = term_eval ge t m.
+Proof.
+ induction t using term_mut with (P0:=fun lt =>
+ WHEN hlist_term_lift lt ~> hlt THEN forall ge m, list_term_eval ge hlt m = list_term_eval ge lt m);
+ wlp_simplify.
+ - rewrite H0, H; auto.
+ - rewrite H1, H0, H; auto.
+Qed.
+Local Hint Resolve hterm_lift_correct: wlp.
+Global Opaque hterm_lift.
+
+Variable log_new_hterm: term -> ?? unit.
+
+Fixpoint hterm_append (l: list term) (lh: list term): ?? list term :=
+ match l with
+ | nil => RET lh
+ | t::l' =>
+ DO ht <~ hterm_lift t;;
+ log_new_hterm ht;;
+ hterm_append l' (ht::lh)
+ end.
+
+Lemma hterm_append_correct l: forall lh,
+ WHEN hterm_append l lh ~> lh' THEN (forall ge m, allvalid ge lh' m <-> (allvalid ge l m /\ allvalid ge lh m)).
+Proof.
+ Local Hint Resolve eq_trans: localhint.
+ induction l as [|t l']; simpl; wlp_xsimplify ltac:(eauto with wlp).
+ - intros; rewrite! allvalid_extensionality; intuition eauto.
+ - intros REC ge m; rewrite REC; clear IHl' REC. rewrite !allvalid_extensionality.
+ simpl; intuition (subst; eauto with wlp localhint).
+Qed.
+(*Local Hint Resolve hterm_append_correct: wlp.*)
+Global Opaque hterm_append.
+
+Definition smart_set (hd:hsmem) x (ht:term) :=
+ match ht with
+ | Input y _ =>
+ if R.eq_dec x y then
+ RET (Dict.rem hd x)
+ else (
+ log_assign x ht;;
+ RET (Dict.set hd x ht)
+ )
+ | _ =>
+ log_assign x ht;;
+ RET (Dict.set hd x ht)
+ end.
+
+Lemma smart_set_correct hd x ht:
+ WHEN smart_set hd x ht ~> d THEN
+ forall ge m y, hsmem_post_eval ge d y m = hsmem_post_eval ge (Dict.set hd x ht) y m.
+Proof.
+ destruct ht; wlp_simplify.
+ unfold hsmem_post_eval; simpl. case (R.eq_dec x0 y).
+ - intros; subst. rewrite Dict.set_spec_eq, Dict.rem_spec_eq. simpl; congruence.
+ - intros; rewrite Dict.set_spec_diff, Dict.rem_spec_diff; auto.
+Qed.
+(*Local Hint Resolve smart_set_correct: wlp.*)
+Global Opaque smart_set.
+
+Definition hsmem_set (hd:hsmem) x (t:term) :=
+ DO pt <~ reduce t;;
+ DO lht <~ hterm_append pt.(mayfail) hd.(hpre);;
+ DO ht <~ hterm_lift pt.(effect);;
+ log_new_hterm ht;;
+ DO nd <~ smart_set hd x ht;;
+ RET {| hpre := lht; hpost := nd |}.
+
+Lemma hsmem_set_correct hd x ht:
+ WHEN hsmem_set hd x ht ~> nhd THEN
+ forall ge d t, smem_model ge d hd ->
+ (forall m, smem_valid ge d m -> term_eval ge ht m = ST.term_eval ge t m) ->
+ smem_model ge (smem_set d x t) nhd.
+Proof.
+ intros; wlp_simplify.
+ generalize (hterm_append_correct _ _ _ Hexta0); intro APPEND.
+ generalize (hterm_lift_correct _ _ Hexta1); intro LIFT.
+ generalize (smart_set_correct _ _ _ _ Hexta3); intro SMART.
+ eapply equiv_hsmem_models; eauto; unfold equiv_hsmem; simpl.
+ destruct H as (VALID & EFFECT); split.
+ - intros; rewrite APPEND, <- VALID.
+ rewrite !allvalid_extensionality in * |- *; simpl; intuition (subst; eauto).
+ - intros m x0 ALLVALID; rewrite SMART.
+ destruct (term_eval ge ht m) eqn: Hht.
+ * case (R.eq_dec x x0).
+ + intros; subst. unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_eq.
+ erewrite LIFT, EFFECT; eauto.
+ + intros; unfold hsmem_post_eval; simpl. rewrite !Dict.set_spec_diff; auto.
+ * rewrite allvalid_extensionality in ALLVALID; destruct (ALLVALID ht); simpl; auto.
+Qed.
+Local Hint Resolve hsmem_set_correct: wlp.
+Global Opaque hsmem_set.
+
+(* VARIANTE: we do not hash-cons the term from the expression
+Lemma exp_hterm_correct ge e hod od:
+ smem_model ge od hod ->
+ forall hd d,
+ smem_model ge d hd ->
+ forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge (exp_term e hd hod) m = term_eval ge (exp_term e d od) m.
+Proof.
+ intro H.
+ induction e using exp_mut with (P0:=fun le => forall d hd,
+ smem_model ge d hd -> forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge (list_exp_term le hd hod) m = list_term_eval ge (list_exp_term le d od) m);
+ unfold smem_model in * |- * ; simpl; intuition eauto.
+ - erewrite IHe; eauto.
+ - erewrite IHe0, IHe; eauto.
+Qed.
+Local Hint Resolve exp_hterm_correct: wlp.
+*)
+
+Fixpoint exp_hterm (e: exp) (hd hod: hsmem): ?? term :=
+ match e with
+ | PReg x => hsmem_get hd x
+ | Op o le =>
+ DO lt <~ list_exp_hterm le hd hod;;
+ hApp o lt
+ | Old e => exp_hterm e hod hod
+ end
+with list_exp_hterm (le: list_exp) (hd hod: hsmem): ?? list_term :=
+ match le with
+ | Enil => hLTnil tt
+ | Econs e le' =>
+ DO t <~ exp_hterm e hd hod;;
+ DO lt <~ list_exp_hterm le' hd hod;;
+ hLTcons t lt
+ | LOld le => list_exp_hterm le hod hod
+ end.
+
+Lemma exp_hterm_correct_x ge e hod od:
+ smem_model ge od hod ->
+ forall hd d,
+ smem_model ge d hd ->
+ WHEN exp_hterm e hd hod ~> t THEN forall m, smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m.
+ Proof.
+ intro H.
+ induction e using exp_mut with (P0:=fun le => forall d hd,
+ smem_model ge d hd ->
+ WHEN list_exp_hterm le hd hod ~> lt THEN forall m, smem_valid ge d m -> smem_valid ge od m -> list_term_eval ge lt m = ST.list_term_eval ge (list_exp_term le d od) m);
+ unfold smem_model, hsmem_post_eval in * |- * ; simpl; wlp_simplify.
+ - rewrite H1, <- H4; auto.
+ - rewrite H4, <- H0; simpl; auto.
+ - rewrite H5, <- H0, <- H4; simpl; auto.
+Qed.
+Global Opaque exp_hterm.
+
+Lemma exp_hterm_correct e hd hod:
+ WHEN exp_hterm e hd hod ~> t THEN forall ge od d m, smem_model ge od hod -> smem_model ge d hd -> smem_valid ge d m -> smem_valid ge od m -> term_eval ge t m = ST.term_eval ge (exp_term e d od) m.
+Proof.
+ unfold wlp; intros; eapply exp_hterm_correct_x; eauto.
+Qed.
+Hint Resolve exp_hterm_correct: wlp.
+
+Fixpoint hinst_smem (i: inst) (hd hod: hsmem): ?? hsmem :=
+ match i with
+ | nil => RET hd
+ | (x, e)::i' =>
+ DO ht <~ exp_hterm e hd hod;;
+ DO nd <~ hsmem_set hd x ht;;
+ hinst_smem i' nd hod
+ end.
+
+Lemma hinst_smem_correct i: forall hd hod,
+ WHEN hinst_smem i hd hod ~> hd' THEN
+ forall ge od d, smem_model ge od hod -> smem_model ge d hd -> (forall m, smem_valid ge d m -> smem_valid ge od m) -> smem_model ge (inst_smem i d od) hd'.
+Proof.
+ Local Hint Resolve smem_valid_set_proof: core.
+ induction i; simpl; wlp_simplify; eauto 15 with wlp.
+Qed.
+Global Opaque hinst_smem.
+Local Hint Resolve hinst_smem_correct: wlp.
+
+(* logging info: we log the number of inst-instructions passed ! *)
+Variable log_new_inst: unit -> ?? unit.
+
+Fixpoint bblock_hsmem_rec (p: bblock) (d: hsmem): ?? hsmem :=
+ match p with
+ | nil => RET d
+ | i::p' =>
+ log_new_inst tt;;
+ DO d' <~ hinst_smem i d d;;
+ bblock_hsmem_rec p' d'
+ end.
+
+Lemma bblock_hsmem_rec_correct p: forall hd,
+ WHEN bblock_hsmem_rec p hd ~> hd' THEN forall ge d, smem_model ge d hd -> smem_model ge (bblock_smem_rec p d) hd'.
+Proof.
+ induction p; simpl; wlp_simplify.
+Qed.
+Global Opaque bblock_hsmem_rec.
+Local Hint Resolve bblock_hsmem_rec_correct: wlp.
+
+Definition hsmem_empty: hsmem := {| hpre:= nil ; hpost := Dict.empty |}.
+
+Lemma hsmem_empty_correct ge: smem_model ge smem_empty hsmem_empty.
+Proof.
+ unfold smem_model, smem_valid, hsmem_post_eval; simpl; intuition try congruence.
+ rewrite !Dict.empty_spec; simpl; auto.
+Qed.
+
+Definition bblock_hsmem: bblock -> ?? hsmem
+ := fun p => bblock_hsmem_rec p hsmem_empty.
+
+Lemma bblock_hsmem_correct p:
+ WHEN bblock_hsmem p ~> hd THEN forall ge, smem_model ge (bblock_smem p) hd.
+Proof.
+ Local Hint Resolve hsmem_empty_correct: core.
+ wlp_simplify.
+Qed.
+Global Opaque bblock_hsmem.
+
+End CanonBuilding.
+
+(* Now, we build the hash-Cons value from a "hash_eq".
+
+Informal specification:
+ [hash_eq] must be consistent with the "hashed" constructors defined above.
+
+We expect that hashinfo values in the code of these "hashed" constructors verify:
+
+ (hash_eq (hdata x) (hdata y) ~> true) <-> (hcodes x)=(hcodes y)
+
+*)
+
+Definition term_hash_eq (ta tb: term): ?? bool :=
+ match ta, tb with
+ | Input xa _, Input xb _ =>
+ if R.eq_dec xa xb (* Inefficient in some cases ? *)
+ then RET true
+ else RET false
+ | App oa lta _, App ob ltb _ =>
+ DO b <~ op_eq oa ob ;;
+ if b then phys_eq lta ltb
+ else RET false
+ | _,_ => RET false
+ end.
+
+Lemma term_hash_eq_correct: forall ta tb, WHEN term_hash_eq ta tb ~> b THEN b=true -> term_set_hid ta unknown_hid=term_set_hid tb unknown_hid.
+Proof.
+ Local Hint Resolve op_eq_correct: wlp.
+ destruct ta, tb; wlp_simplify; (discriminate || (subst; auto)).
+Qed.
+Global Opaque term_hash_eq.
+Hint Resolve term_hash_eq_correct: wlp.
+
+Definition list_term_hash_eq (lta ltb: list_term): ?? bool :=
+ match lta, ltb with
+ | LTnil _, LTnil _ => RET true
+ | LTcons ta lta _, LTcons tb ltb _ =>
+ DO b <~ phys_eq ta tb ;;
+ if b then phys_eq lta ltb
+ else RET false
+ | _,_ => RET false
+ end.
+
+Lemma list_term_hash_eq_correct: forall lta ltb, WHEN list_term_hash_eq lta ltb ~> b THEN b=true -> list_term_set_hid lta unknown_hid=list_term_set_hid ltb unknown_hid.
+Proof.
+ destruct lta, ltb; wlp_simplify; (discriminate || (subst; auto)).
+Qed.
+Global Opaque list_term_hash_eq.
+Hint Resolve list_term_hash_eq_correct: wlp.
+
+Lemma hsmem_post_eval_intro (d1 d2: hsmem):
+ (forall x, Dict.get d1 x = Dict.get d2 x) -> (forall ge x m, hsmem_post_eval ge d1 x m = hsmem_post_eval ge d2 x m).
+Proof.
+ unfold hsmem_post_eval; intros H ge x m; rewrite H. destruct (Dict.get d2 x); auto.
+Qed.
+
+Local Hint Resolve bblock_hsmem_correct Dict.eq_test_correct: wlp.
+
+Program Definition mk_hash_params (log: term -> ?? unit): Dict.hash_params term :=
+ {|
+ Dict.test_eq := phys_eq;
+ Dict.hashing := fun (ht: term) => RET (term_get_hid ht);
+ Dict.log := log |}.
+Obligation 1.
+ eauto with wlp.
+Qed.
+
+(*** A GENERIC EQ_TEST: IN ORDER TO SUPPORT SEVERAL DEBUGGING MODE !!! ***)
+Definition no_log_assign (x:R.t) (t:term): ?? unit := RET tt.
+Definition no_log_new_term (t:term): ?? unit := RET tt.
+
+Section Prog_Eq_Gen.
+
+Variable log_assign: R.t -> term -> ?? unit.
+Variable log_new_term: hashConsing term -> hashConsing list_term -> ??(term -> ?? unit).
+Variable log_inst1: unit -> ?? unit. (* log of p1 insts *)
+Variable log_inst2: unit -> ?? unit. (* log of p2 insts *)
+
+Variable hco_term: hashConsing term.
+Hypothesis hco_term_correct: forall t, WHEN hco_term.(hC) t ~> t' THEN forall ge m, term_eval ge (hdata t) m = term_eval ge t' m.
+
+Variable hco_list: hashConsing list_term.
+Hypothesis hco_list_correct: forall t, WHEN hco_list.(hC) t ~> t' THEN forall ge m, list_term_eval ge (hdata t) m = list_term_eval ge t' m.
+
+Variable print_error_end: hsmem -> hsmem -> ?? unit.
+Variable print_error: pstring -> ?? unit.
+
+Variable check_failpreserv: bool.
+Variable dbg_failpreserv: term -> ?? unit. (* info of additional failure of the output bbloc p2 wrt the input bbloc p1 *)
+
+Program Definition g_bblock_simu_test (p1 p2: bblock): ?? bool :=
+ DO failure_in_failpreserv <~ make_cref false;;
+ DO r <~ (TRY
+ DO d1 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) log_assign no_log_new_term log_inst1 p1;;
+ DO log_new_term <~ log_new_term hco_term hco_list;;
+ DO d2 <~ bblock_hsmem hco_term.(hC) hco_list.(hC) no_log_assign log_new_term log_inst2 p2;;
+ DO b <~ Dict.eq_test d1 d2 ;;
+ if b then (
+ if check_failpreserv then (
+ let hp := mk_hash_params dbg_failpreserv in
+ failure_in_failpreserv.(set)(true);;
+ Sets.assert_list_incl hp d2.(hpre) d1.(hpre);;
+ RET true
+ ) else RET false
+ ) else (
+ print_error_end d1 d2 ;;
+ RET false
+ )
+ CATCH_FAIL s, _ =>
+ DO b <~ failure_in_failpreserv.(get)();;
+ if b then RET false
+ else print_error s;; RET false
+ ENSURE (fun b => b=true -> forall ge, bblock_simu ge p1 p2));;
+ RET (`r).
+Obligation 1.
+ constructor 1; wlp_simplify; try congruence.
+ destruct (H ge) as (EQPRE1&EQPOST1); destruct (H0 ge) as (EQPRE2&EQPOST2); clear H H0.
+ apply bblock_smem_simu; auto. split.
+ + intros m; rewrite <- EQPRE1, <- EQPRE2.
+ rewrite ! allvalid_extensionality.
+ unfold incl in * |- *; intuition eauto.
+ + intros m0 x VALID; rewrite <- EQPOST1, <- EQPOST2; auto.
+ erewrite hsmem_post_eval_intro; eauto.
+ erewrite <- EQPRE2; auto.
+ erewrite <- EQPRE1 in VALID.
+ rewrite ! allvalid_extensionality in * |- *.
+ unfold incl in * |- *; intuition eauto.
+Qed.
+
+Theorem g_bblock_simu_test_correct p1 p2:
+ WHEN g_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
+Proof.
+ wlp_simplify.
+ destruct exta0; simpl in * |- *; auto.
+Qed.
+Global Opaque g_bblock_simu_test.
+
+End Prog_Eq_Gen.
+
+
+
+Definition hpt: hashP term := {| hash_eq := term_hash_eq; get_hid:=term_get_hid; set_hid:=term_set_hid |}.
+Definition hplt: hashP list_term := {| hash_eq := list_term_hash_eq; get_hid:=list_term_get_hid; set_hid:=list_term_set_hid |}.
+
+Definition recover_hcodes (t:term): ??(hashinfo term) :=
+ match t with
+ | Input x _ =>
+ DO hv <~ hInput_hcodes x ;;
+ RET {| hdata := t; hcodes := hv |}
+ | App o l _ =>
+ DO hv <~ hApp_hcodes o l ;;
+ RET {| hdata := t; hcodes := hv |}
+ end.
+
+
+Definition msg_end_of_bblock: pstring :="--- unknown subterms in the graph".
+
+Definition log_new_term
+ (unknownHash_msg: term -> ?? pstring)
+ (hct:hashConsing term)
+ (hcl:hashConsing list_term)
+ : ?? (term -> ?? unit) :=
+ DO clock <~ hct.(next_hid)();;
+ hct.(next_log) msg_end_of_bblock;;
+ hcl.(next_log) msg_end_of_bblock;;
+ RET (fun t =>
+ DO ok <~ hash_older (term_get_hid t) clock;;
+ if ok
+ then
+ RET tt
+ else
+ DO ht <~ recover_hcodes t;;
+ hct.(remove) ht;;
+ DO msg <~ unknownHash_msg t;;
+ FAILWITH msg).
+
+Definition skip (_:unit): ?? unit := RET tt.
+
+Definition msg_prefix: pstring := "*** ERROR INFO from bblock_simu_test: ".
+Definition msg_error_on_end: pstring := "mismatch in final assignments !".
+Definition msg_unknow_term: pstring := "unknown term".
+Definition msg_number: pstring := "on 2nd bblock -- on inst num ".
+Definition msg_notfailpreserv: pstring := "a possible failure of 2nd bblock is absent in 1st bblock (INTERNAL ERROR: this error is expected to be detected before!!!)".
+
+Definition print_error_end (_ _: hsmem): ?? unit
+ := println (msg_prefix +; msg_error_on_end).
+
+Definition print_error (log: logger unit) (s:pstring): ?? unit
+ := DO n <~ log_info log ();;
+ println (msg_prefix +; msg_number +; n +; " -- " +; s).
+
+Definition failpreserv_error (_: term): ?? unit
+ := println (msg_prefix +; msg_notfailpreserv).
+
+Lemma term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m:
+ term_set_hid t1 hid1 = term_set_hid t2 hid2 -> term_eval ge t1 m = term_eval ge t2 m.
+Proof.
+ intro H; erewrite <- term_eval_set_hid; rewrite H. apply term_eval_set_hid.
+Qed.
+
+Lemma list_term_eval_set_hid_equiv ge t1 t2 hid1 hid2 m:
+ list_term_set_hid t1 hid1 = list_term_set_hid t2 hid2 -> list_term_eval ge t1 m = list_term_eval ge t2 m.
+Proof.
+ intro H; erewrite <- list_term_eval_set_hid; rewrite H. apply list_term_eval_set_hid.
+Qed.
+
+Local Hint Resolve term_eval_set_hid_equiv list_term_eval_set_hid_equiv: core.
+
+Program Definition bblock_simu_test (p1 p2: bblock): ?? bool :=
+ DO log <~ count_logger ();;
+ DO hco_term <~ mk_annot (hCons hpt);;
+ DO hco_list <~ mk_annot (hCons hplt);;
+ g_bblock_simu_test
+ no_log_assign
+ (log_new_term (fun _ => RET msg_unknow_term))
+ skip
+ (log_insert log)
+ hco_term _
+ hco_list _
+ print_error_end
+ (print_error log)
+ true (* check_failpreserv *)
+ failpreserv_error
+ p1 p2.
+Obligation 1.
+ generalize (hCons_correct _ _ _ H0); clear H0.
+ wlp_simplify.
+Qed.
+Obligation 2.
+ generalize (hCons_correct _ _ _ H); clear H.
+ wlp_simplify.
+Qed.
+
+Local Hint Resolve g_bblock_simu_test_correct: core.
+
+Theorem bblock_simu_test_correct p1 p2:
+ WHEN bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque bblock_simu_test.
+
+(** This is only to print info on each bblock_simu_test run **)
+Section Verbose_version.
+
+Variable string_of_name: R.t -> ?? pstring.
+Variable string_of_op: op -> ?? pstring.
+
+
+Local Open Scope string_scope.
+
+Definition string_term_hid (t: term): ?? pstring :=
+ DO id <~ string_of_hashcode (term_get_hid t);;
+ RET ("E" +; (CamlStr id)).
+
+Definition string_list_hid (lt: list_term): ?? pstring :=
+ DO id <~ string_of_hashcode (list_term_get_hid lt);;
+ RET ("L" +; (CamlStr id)).
+
+Definition print_raw_term (t: term): ?? unit :=
+ match t with
+ | Input x _ =>
+ DO s <~ string_of_name x;;
+ println( "init_access " +; s)
+ | App o (LTnil _) _ =>
+ DO so <~ string_of_op o;;
+ println so
+ | App o l _ =>
+ DO so <~ string_of_op o;;
+ DO sl <~ string_list_hid l;;
+ println (so +; " " +; sl)
+ end.
+
+(*
+Definition print_raw_list(lt: list_term): ?? unit :=
+ match lt with
+ | LTnil _=> println ""
+ | LTcons t l _ =>
+ DO st <~ string_term_hid t;;
+ DO sl <~ string_list_hid l;;
+ println(st +; " " +; sl)
+ end.
+*)
+
+Section PrettryPrint.
+
+Variable get_debug_info: term -> ?? option pstring.
+
+Fixpoint string_of_term (t: term): ?? pstring :=
+ match t with
+ | Input x _ => string_of_name x
+ | App o (LTnil _) _ => string_of_op o
+ | App o l _ =>
+ DO so <~ string_of_op o;;
+ DO sl <~ string_of_list_term l;;
+ RET (so +; "[" +; sl +; "]")
+ end
+with string_of_list_term (l: list_term): ?? pstring :=
+ match l with
+ | LTnil _ => RET (Str "")
+ | LTcons t (LTnil _) _ =>
+ DO dbg <~ get_debug_info t;;
+ match dbg with
+ | Some x => RET x
+ | None => string_of_term t
+ end
+ | LTcons t l' _ =>
+ DO st <~ (DO dbg <~ get_debug_info t;;
+ match dbg with
+ | Some x => RET x
+ | None => string_of_term t
+ end);;
+ DO sl <~ string_of_list_term l';;
+ RET (st +; ";" +; sl)
+ end.
+
+
+End PrettryPrint.
+
+
+Definition pretty_term gdi t :=
+ DO r <~ string_of_term gdi t;;
+ println(r).
+
+Fixpoint print_head (head: list pstring): ?? unit :=
+ match head with
+ | i::head' => println (i);; print_head head'
+ | _ => RET tt
+ end.
+
+Definition print_term gdi (head: list pstring) (t: term): ?? unit :=
+ print_head head;;
+ DO s <~ string_term_hid t;;
+ print (s +; ": ");;
+ print_raw_term t;;
+ DO dbg <~ gdi t;;
+ match dbg with
+ | Some x =>
+ print("// " +; x +; " <- ");;
+ pretty_term gdi t
+ | None => RET tt
+ end.
+
+Definition print_list gdi (head: list pstring) (lt: list_term): ?? unit :=
+ print_head head;;
+ DO s <~ string_list_hid lt ;;
+ print (s +; ": ");;
+ (* print_raw_list lt;; *)
+ DO ps <~ string_of_list_term gdi lt;;
+ println("[" +; ps +; "]").
+
+
+Definition print_tables gdi ext exl: ?? unit :=
+ println "-- term table --" ;;
+ iterall ext (fun head _ pt => print_term gdi head pt.(hdata));;
+ println "-- list table --" ;;
+ iterall exl (fun head _ pl => print_list gdi head pl.(hdata));;
+ println "----------------".
+
+Definition print_final_debug gdi (d1 d2: hsmem): ?? unit
+ := DO b <~ Dict.not_eq_witness d1 d2 ;;
+ match b with
+ | Some x =>
+ DO s <~ string_of_name x;;
+ println("mismatch on: " +; s);;
+ match Dict.get d1 x with
+ | None => println("=> unassigned in 1st bblock")
+ | Some t1 =>
+ print("=> node expected from 1st bblock: ");;
+ pretty_term gdi t1
+ end;;
+ match Dict.get d2 x with
+ | None => println("=> unassigned in 2nd bblock")
+ | Some t2 =>
+ print("=> node found from 2nd bblock: ");;
+ pretty_term gdi t2
+ end
+ | None => FAILWITH "bug in Dict.not_eq_witness ?"
+ end.
+
+Definition witness:= option term.
+
+Definition msg_term (cr: cref witness) t :=
+ set cr (Some t);;
+ RET msg_unknow_term.
+
+Definition print_witness gdi cr (*msg*) :=
+ DO wit <~ get cr ();;
+ match wit with
+ | Some t =>
+ println("=> unknown term node: ");;
+ pretty_term gdi t (*;;
+ println("=> encoded on " +; msg +; " graph as: ");;
+ print_raw_term t *)
+ | None => println "Unexpected failure: no witness info (hint: hash-consing bug ?)"
+ end.
+
+
+Definition print_error_end1 gdi hct hcl (d1 d2:hsmem): ?? unit
+ := println "- GRAPH of 1st bblock";;
+ DO ext <~ export hct ();;
+ DO exl <~ export hcl ();;
+ print_tables gdi ext exl;;
+ print_error_end d1 d2;;
+ print_final_debug gdi d1 d2.
+
+Definition print_error1 gdi hct hcl cr log s : ?? unit
+ := println "- GRAPH of 1st bblock";;
+ DO ext <~ export hct ();;
+ DO exl <~ export hcl ();;
+ print_tables gdi ext exl;;
+ print_error log s;;
+ print_witness gdi cr (*"1st"*).
+
+
+Definition xmsg_number: pstring := "on 1st bblock -- on inst num ".
+
+Definition print_error_end2 gdi hct hcl (d1 d2:hsmem): ?? unit
+ := println (msg_prefix +; msg_error_on_end);;
+ println "- GRAPH of 2nd bblock";;
+ DO ext <~ export hct ();;
+ DO exl <~ export hcl ();;
+ print_tables gdi ext exl.
+
+Definition print_error2 gdi hct hcl cr (log: logger unit) (s:pstring): ?? unit
+ := DO n <~ log_info log ();;
+ DO ext <~ export hct ();;
+ DO exl <~ export hcl ();;
+ println (msg_prefix +; xmsg_number +; n +; " -- " +; s);;
+ print_witness gdi cr (*"2nd"*);;
+ println "- GRAPH of 2nd bblock";;
+ print_tables gdi ext exl.
+
+(* USELESS
+Definition simple_log_assign (d: D.t term pstring) (x: R.t) (t: term): ?? unit :=
+ DO s <~ string_of_name x;;
+ d.(D.set) (t,s).
+*)
+
+Definition log_assign (d: D.t term pstring) (log: logger unit) (x: R.t) (t: term): ?? unit :=
+ DO i <~ log_info log ();;
+ DO sx <~ string_of_name x;;
+ d.(D.set) (t,(sx +; "@" +; i)).
+
+Definition msg_new_inst : pstring := "--- inst ".
+
+Definition hlog (log: logger unit) (hct: hashConsing term) (hcl: hashConsing list_term): unit -> ?? unit :=
+ (fun _ =>
+ log_insert log tt ;;
+ DO s <~ log_info log tt;;
+ let s:= msg_new_inst +; s in
+ next_log hct s;;
+ next_log hcl s
+ ).
+
+Program Definition verb_bblock_simu_test (p1 p2: bblock): ?? bool :=
+ DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));;
+ DO log1 <~ count_logger ();;
+ DO log2 <~ count_logger ();;
+ DO cr <~ make_cref None;;
+ DO hco_term <~ mk_annot (hCons hpt);;
+ DO hco_list <~ mk_annot (hCons hplt);;
+ DO result1 <~ g_bblock_simu_test
+ (log_assign dict_info log1)
+ (log_new_term (msg_term cr))
+ (hlog log1 hco_term hco_list)
+ (log_insert log2)
+ hco_term _
+ hco_list _
+ (print_error_end1 dict_info.(D.get) hco_term hco_list)
+ (print_error1 dict_info.(D.get) hco_term hco_list cr log2)
+ true
+ failpreserv_error
+ p1 p2;;
+ if result1
+ then RET true
+ else
+ DO dict_info <~ make_dict (mk_hash_params (fun _ => RET tt));;
+ DO log1 <~ count_logger ();;
+ DO log2 <~ count_logger ();;
+ DO cr <~ make_cref None;;
+ DO hco_term <~ mk_annot (hCons hpt);;
+ DO hco_list <~ mk_annot (hCons hplt);;
+ DO result2 <~ g_bblock_simu_test
+ (log_assign dict_info log1)
+ (*fun _ _ => RET no_log_new_term*) (* REM: too weak !! *)
+ (log_new_term (msg_term cr)) (* REM: too strong ?? *)
+ (hlog log1 hco_term hco_list)
+ (log_insert log2)
+ hco_term _
+ hco_list _
+ (print_error_end2 dict_info.(D.get) hco_term hco_list)
+ (print_error2 dict_info.(D.get) hco_term hco_list cr log2)
+ false
+ (fun _ => RET tt)
+ p2 p1;;
+ if result2
+ then (
+ println (msg_prefix +; " OOops - symmetry violation in bblock_simu_test => this is a bug of bblock_simu_test ??");;
+ RET false
+ ) else RET false
+ .
+Obligation 1.
+ generalize (hCons_correct _ _ _ H0); clear H0.
+ wlp_simplify.
+Qed.
+Obligation 2.
+ generalize (hCons_correct _ _ _ H); clear H.
+ wlp_simplify.
+Qed.
+Obligation 3.
+ generalize (hCons_correct _ _ _ H0); clear H0.
+ wlp_simplify.
+Qed.
+Obligation 4.
+ generalize (hCons_correct _ _ _ H); clear H.
+ wlp_simplify.
+Qed.
+
+Theorem verb_bblock_simu_test_correct p1 p2:
+ WHEN verb_bblock_simu_test p1 p2 ~> b THEN b=true -> forall ge, bblock_simu ge p1 p2.
+Proof.
+ wlp_simplify.
+Qed.
+Global Opaque verb_bblock_simu_test.
+
+End Verbose_version.
+
+End SimuWithReduce.
+
+(* TODO: why inlining fails here ? *)
+Transparent hterm_lift.
+Extraction Inline lift.
+
+End ImpSimu.
+
+Require Import FMapPositive.
+
+
+Require Import PArith.
+Require Import FMapPositive.
+
+Module ImpPosDict <: ImpDict with Module R:=Pos.
+
+Module R:=Pos.
+
+Definition t:=PositiveMap.t.
+
+Definition get {A} (d:t A) (x:R.t): option A
+ := PositiveMap.find x d.
+
+Definition set {A} (d:t A) (x:R.t) (v:A): t A
+ := PositiveMap.add x v d.
+
+Local Hint Unfold PositiveMap.E.eq: core.
+
+Lemma set_spec_eq A d x (v: A):
+ get (set d x v) x = Some v.
+Proof.
+ unfold get, set; apply PositiveMap.add_1; auto.
+Qed.
+
+Lemma set_spec_diff A d x y (v: A):
+ x <> y -> get (set d x v) y = get d y.
+Proof.
+ unfold get, set; intros; apply PositiveMap.gso; auto.
+Qed.
+
+Definition rem {A} (d:t A) (x:R.t): t A
+ := PositiveMap.remove x d.
+
+Lemma rem_spec_eq A (d: t A) x:
+ get (rem d x) x = None.
+Proof.
+ unfold get, rem; apply PositiveMap.grs; auto.
+Qed.
+
+Lemma rem_spec_diff A (d: t A) x y:
+ x <> y -> get (rem d x) y = get d y.
+Proof.
+ unfold get, rem; intros; apply PositiveMap.gro; auto.
+Qed.
+
+
+Definition empty {A}: t A := PositiveMap.empty A.
+
+Lemma empty_spec A x:
+ get (empty (A:=A)) x = None.
+Proof.
+ unfold get, empty; apply PositiveMap.gempty; auto.
+Qed.
+
+Import PositiveMap.
+
+Fixpoint eq_test {A} (d1 d2: t A): ?? bool :=
+ match d1, d2 with
+ | Leaf _, Leaf _ => RET true
+ | Node l1 (Some x1) r1, Node l2 (Some x2) r2 =>
+ DO b0 <~ phys_eq x1 x2 ;;
+ if b0 then
+ DO b1 <~ eq_test l1 l2 ;;
+ if b1 then
+ eq_test r1 r2
+ else
+ RET false
+ else
+ RET false
+ | Node l1 None r1, Node l2 None r2 =>
+ DO b1 <~ eq_test l1 l2 ;;
+ if b1 then
+ eq_test r1 r2
+ else
+ RET false
+ | _, _ => RET false
+ end.
+
+Lemma eq_test_correct A d1: forall (d2: t A),
+ WHEN eq_test d1 d2 ~> b THEN
+ b=true -> forall x, get d1 x = get d2 x.
+Proof.
+ unfold get; induction d1 as [|l1 Hl1 [x1|] r1 Hr1]; destruct d2 as [|l2 [x2|] r2]; simpl;
+ wlp_simplify; (discriminate || (subst; destruct x; simpl; auto)).
+Qed.
+Global Opaque eq_test.
+
+(* ONLY FOR DEBUGGING INFO: get some key of a non-empty d *)
+Fixpoint pick {A} (d: t A): ?? R.t :=
+ match d with
+ | Leaf _ => FAILWITH "unexpected empty dictionary"
+ | Node _ (Some _) _ => RET xH
+ | Node (Leaf _) None r =>
+ DO p <~ pick r;;
+ RET (xI p)
+ | Node l None _ =>
+ DO p <~ pick l;;
+ RET (xO p)
+ end.
+
+(* ONLY FOR DEBUGGING INFO: find one variable on which d1 and d2 differs *)
+Fixpoint not_eq_witness {A} (d1 d2: t A): ?? option R.t :=
+ match d1, d2 with
+ | Leaf _, Leaf _ => RET None
+ | Node l1 (Some x1) r1, Node l2 (Some x2) r2 =>
+ DO b0 <~ phys_eq x1 x2 ;;
+ if b0 then
+ DO b1 <~ not_eq_witness l1 l2;;
+ match b1 with
+ | None =>
+ DO b2 <~ not_eq_witness r1 r2;;
+ match b2 with
+ | None => RET None
+ | Some p => RET (Some (xI p))
+ end
+ | Some p => RET (Some (xO p))
+ end
+ else
+ RET (Some xH)
+ | Node l1 None r1, Node l2 None r2 =>
+ DO b1 <~ not_eq_witness l1 l2;;
+ match b1 with
+ | None =>
+ DO b2 <~ not_eq_witness r1 r2;;
+ match b2 with
+ | None => RET None
+ | Some p => RET (Some (xI p))
+ end
+ | Some p => RET (Some (xO p))
+ end
+ | l, Leaf _ => DO p <~ pick l;; RET (Some p)
+ | Leaf _, r => DO p <~ pick r;; RET (Some p)
+ | _, _ => RET (Some xH)
+ end.
+
+End ImpPosDict.
+
diff --git a/mppa_k1c/abstractbb/Impure/ImpConfig.v b/mppa_k1c/abstractbb/Impure/ImpConfig.v
index 1bd93d4c..e49a4611 100644
--- a/mppa_k1c/abstractbb/Impure/ImpConfig.v
+++ b/mppa_k1c/abstractbb/Impure/ImpConfig.v
@@ -22,9 +22,9 @@ Module Type ImpureView.
(* START COMMENT *)
Module UnsafeImpure.
- Parameter unsafe_coerce: forall {A}, t A -> A.
+ Parameter unsafe_coerce: forall {A}, t A -> option A.
- Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=x -> mayRet k x.
+ Parameter unsafe_coerce_not_really_correct: forall A (k: t A) (x:A), (unsafe_coerce k)=Some x -> mayRet k x.
Extraction Inline unsafe_coerce.
@@ -41,11 +41,11 @@ Module Impure: ImpureView.
Module UnsafeImpure.
- Definition unsafe_coerce {A} (x:t A) := x.
+ Definition unsafe_coerce {A} (x:t A) := Some x.
- Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=x -> mayRet k x.
+ Lemma unsafe_coerce_not_really_correct: forall A (k: t A) x, (unsafe_coerce k)=Some x -> mayRet k x.
Proof.
- unfold unsafe_coerce, mayRet; auto.
+ unfold unsafe_coerce, mayRet; congruence.
Qed.
End UnsafeImpure.
diff --git a/mppa_k1c/abstractbb/Impure/ImpCore.v b/mppa_k1c/abstractbb/Impure/ImpCore.v
index 7925f62d..f1abaf7a 100644
--- a/mppa_k1c/abstractbb/Impure/ImpCore.v
+++ b/mppa_k1c/abstractbb/Impure/ImpCore.v
@@ -193,4 +193,4 @@ Ltac wlp_xsimplify hint :=
Create HintDb wlp discriminated.
-Ltac wlp_simplify := wlp_xsimplify ltac:(intuition (eauto with wlp)). \ No newline at end of file
+Ltac wlp_simplify := wlp_xsimplify ltac:(intuition eauto with wlp). \ No newline at end of file
diff --git a/mppa_k1c/abstractbb/Impure/ImpHCons.v b/mppa_k1c/abstractbb/Impure/ImpHCons.v
index dd615628..637116cc 100644
--- a/mppa_k1c/abstractbb/Impure/ImpHCons.v
+++ b/mppa_k1c/abstractbb/Impure/ImpHCons.v
@@ -95,45 +95,105 @@ Proof.
wlp_simplify.
Qed.
Global Opaque assert_list_incl.
-Hint Resolve assert_list_incl_correct.
+Hint Resolve assert_list_incl_correct: wlp.
End Sets.
+
+
+
(********************************)
(* (Weak) HConsing *)
+Module HConsing.
-Axiom xhCons: forall {A}, ((A -> A -> ?? bool) * (pre_hashV A -> ?? hashV A)) -> ?? hashConsing A.
+Export HConsingDefs.
+
+(* NB: this axiom is NOT intended to be called directly, but only through [hCons...] functions below. *)
+Axiom xhCons: forall {A}, (hashP A) -> ?? hashConsing A.
Extract Constant xhCons => "ImpHConsOracles.xhCons".
-Definition hCons_eq_msg: pstring := "xhCons: hash_eq differs".
+Definition hCons_eq_msg: pstring := "xhCons: hash eq differs".
-Definition hCons {A} (hash_eq: A -> A -> ?? bool) (unknownHash_msg: pre_hashV A -> ?? pstring): ?? (hashConsing A) :=
- DO hco <~ xhCons (hash_eq, fun v => DO s <~ unknownHash_msg v ;; FAILWITH s) ;;
+Definition hCons {A} (hp: hashP A): ?? (hashConsing A) :=
+ DO hco <~ xhCons hp ;;
RET {|
- hC := fun x =>
- DO x' <~ hC hco x ;;
- DO b0 <~ hash_eq (pre_data x) (data x') ;;
- assert_b b0 hCons_eq_msg;;
- RET x';
- hC_known := fun x =>
- DO x' <~ hC_known hco x ;;
- DO b0 <~ hash_eq (pre_data x) (data x') ;;
- assert_b b0 hCons_eq_msg;;
- RET x';
- next_log := next_log hco;
- export := export hco;
+ hC := (fun x =>
+ DO x' <~ hC hco x ;;
+ DO b0 <~ hash_eq hp x.(hdata) x' ;;
+ assert_b b0 hCons_eq_msg;;
+ RET x');
+ next_hid := hco.(next_hid);
+ next_log := hco.(next_log);
+ export := hco.(export);
+ remove := hco.(remove)
|}.
-Lemma hCons_correct: forall A (hash_eq: A -> A -> ?? bool) msg,
- WHEN hCons hash_eq msg ~> hco THEN
- ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x'))
- /\ ((forall x y, WHEN hash_eq x y ~> b THEN b=true -> x=y) -> forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')).
+
+Lemma hCons_correct A (hp: hashP A):
+ WHEN hCons hp ~> hco THEN
+ (forall x y, WHEN hp.(hash_eq) x y ~> b THEN b=true -> (ignore_hid hp x)=(ignore_hid hp y)) ->
+ forall x, WHEN hco.(hC) x ~> x' THEN ignore_hid hp x.(hdata)=ignore_hid hp x'.
Proof.
wlp_simplify.
Qed.
Global Opaque hCons.
Hint Resolve hCons_correct: wlp.
-Definition hCons_spec {A} (hco: hashConsing A) :=
- (forall x, WHEN hC hco x ~> x' THEN (pre_data x)=(data x')) /\ (forall x, WHEN hC_known hco x ~> x' THEN (pre_data x)=(data x')).
+
+
+(* hashV: extending a given type with hash-consing *)
+Record hashV {A:Type}:= {
+ data: A;
+ hid: hashcode
+}.
+Arguments hashV: clear implicits.
+
+Definition hashV_C {A} (test_eq: A -> A -> ?? bool) : hashP (hashV A) := {|
+ hash_eq := fun v1 v2 => test_eq v1.(data) v2.(data);
+ get_hid := hid;
+ set_hid := fun v id => {| data := v.(data); hid := id |}
+|}.
+
+Definition liftHV (x:nat) := {| data := x; hid := unknown_hid |}.
+
+Definition hConsV {A} (hasheq: A -> A -> ?? bool): ?? (hashConsing (hashV A)) :=
+ hCons (hashV_C hasheq).
+
+Lemma hConsV_correct A (hasheq: A -> A -> ?? bool):
+ WHEN hConsV hasheq ~> hco THEN
+ (forall x y, WHEN hasheq x y ~> b THEN b=true -> x=y) ->
+ forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data).
+Proof.
+ Local Hint Resolve f_equal2: core.
+ wlp_simplify.
+ exploit H; eauto.
+ + wlp_simplify.
+ + intros; congruence.
+Qed.
+Global Opaque hConsV.
+Hint Resolve hConsV_correct: wlp.
+
+Definition hC_known {A} (hco:hashConsing (hashV A)) (unknownHash_msg: hashinfo (hashV A) -> ?? pstring) (x:hashinfo (hashV A)): ?? hashV A :=
+ DO clock <~ hco.(next_hid)();;
+ DO x' <~ hco.(hC) x;;
+ DO ok <~ hash_older x'.(hid) clock;;
+ if ok
+ then RET x'
+ else
+ hco.(remove) x;;
+ DO msg <~ unknownHash_msg x;;
+ FAILWITH msg.
+
+Lemma hC_known_correct A (hco:hashConsing (hashV A)) msg x:
+ WHEN hC_known hco msg x ~> x' THEN
+ (forall x, WHEN hco.(hC) x ~> x' THEN x.(hdata).(data)=x'.(data)) ->
+ x.(hdata).(data)=x'.(data).
+Proof.
+ wlp_simplify.
+ unfold wlp in * |- ; eauto.
+Qed.
+Global Opaque hC_known.
+Hint Resolve hC_known_correct: wlp.
+
+End HConsing.
diff --git a/mppa_k1c/abstractbb/Impure/ImpLoops.v b/mppa_k1c/abstractbb/Impure/ImpLoops.v
index dc8b2627..33376c19 100644
--- a/mppa_k1c/abstractbb/Impure/ImpLoops.v
+++ b/mppa_k1c/abstractbb/Impure/ImpLoops.v
@@ -17,7 +17,7 @@ Section While_Loop.
(** Local Definition of "while-loop-invariant" *)
Let wli {S} cond body (I: S -> Prop) := forall s, I s -> cond s = true -> WHEN (body s) ~> s' THEN I s'.
-Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | I s0 -> I s /\ cond s = false}
+Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {s | (I s0 -> I s) /\ cond s = false}
:= loop (A:={s | I s0 -> I s})
(s0,
fun s =>
@@ -26,7 +26,7 @@ Program Definition while {S} cond body (I: S -> Prop | wli cond body I) s0: ?? {
DO s' <~ mk_annot (body s) ;;
RET (inl (A:={s | I s0 -> I s }) s')
| false =>
- RET (inr (B:={s | I s0 -> I s /\ cond s = false}) s)
+ RET (inr (B:={s | (I s0 -> I s) /\ cond s = false}) s)
end).
Obligation 2.
unfold wli, wlp in * |-; eauto.
@@ -83,7 +83,7 @@ Definition wapply {A B} {R: A -> B -> Prop} (beq: A -> A -> ?? bool) (k: A -> ??
assert_b b msg;;
RET (output a).
-Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool)x (k: A -> ?? answ R):
+Lemma wapply_correct A B (R: A -> B -> Prop) (beq: A -> A -> ?? bool) (k: A -> ?? answ R) x:
beq_correct beq
-> WHEN wapply beq k x ~> y THEN R x y.
Proof.
@@ -107,7 +107,7 @@ Definition rec_preserv {A B} (recF: (A -> ?? B) -> A -> ?? B) (R: A -> B -> Prop
Program Definition rec {A B} beq recF (R: A -> B -> Prop) (H1: rec_preserv recF R) (H2: beq_correct beq): ?? (A -> ?? B) :=
DO f <~ xrec (B:=answ R) (fun f x =>
DO y <~ mk_annot (recF (wapply beq f) x) ;;
- RET {| input := x; output := proj1_sig y |});;
+ RET {| input := x; output := `y |});;
RET (wapply beq f).
Obligation 1.
eapply H1; eauto. clear H H1.
diff --git a/mppa_k1c/abstractbb/Impure/ImpPrelude.v b/mppa_k1c/abstractbb/Impure/ImpPrelude.v
index 1a84eb3b..de4c7973 100644
--- a/mppa_k1c/abstractbb/Impure/ImpPrelude.v
+++ b/mppa_k1c/abstractbb/Impure/ImpPrelude.v
@@ -91,11 +91,17 @@ Extract Inlined Constant struct_eq => "(=)".
Hint Resolve struct_eq_correct: wlp.
-(** Data-structure for generic hash-consing, hash-set *)
+(** Data-structure for generic hash-consing *)
Axiom hashcode: Type.
Extract Constant hashcode => "int".
+(* NB: hashConsing is assumed to generate hash-code in ascending order.
+ This gives a way to check that a hash-consed value is older than an other one.
+*)
+Axiom hash_older: hashcode -> hashcode -> ?? bool.
+Extract Inlined Constant hash_older => "(<)".
+
Module Dict.
Record hash_params {A:Type} := {
@@ -115,42 +121,45 @@ Arguments t: clear implicits.
End Dict.
+Module HConsingDefs.
-(* NB: hashConsing is assumed to generate hash-code in ascending order.
- This gives a way to check that a hash-consed value is older than an other one.
-*)
-Axiom hash_older: hashcode -> hashcode -> ?? bool.
-Extract Inlined Constant hash_older => "(<=)".
-
-Record pre_hashV {A: Type} := {
- pre_data: A;
+Record hashinfo {A: Type} := {
+ hdata: A;
hcodes: list hashcode;
- debug_info: option pstring;
}.
-Arguments pre_hashV: clear implicits.
+Arguments hashinfo: clear implicits.
-Record hashV {A:Type}:= {
- data: A;
- hid: hashcode
+(* for inductive types with intrinsic hash-consing *)
+Record hashP {A:Type}:= {
+ hash_eq: A -> A -> ?? bool;
+ get_hid: A -> hashcode;
+ set_hid: A -> hashcode -> A; (* WARNING: should only be used by hash-consing machinery *)
}.
-Arguments hashV: clear implicits.
+Arguments hashP: clear implicits.
+
+Axiom unknown_hid: hashcode.
+Extract Constant unknown_hid => "-1".
+
+Definition ignore_hid {A} (hp: hashP A) (hv:A) := set_hid hp hv unknown_hid.
Record hashExport {A:Type}:= {
- get_hashV: hashcode -> ?? pre_hashV A;
- iterall: ((list pstring) -> hashcode -> pre_hashV A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *)
+ get_info: hashcode -> ?? hashinfo A;
+ iterall: ((list pstring) -> hashcode -> hashinfo A -> ?? unit) -> ?? unit; (* iter on all elements in the hashtbl, by order of creation *)
}.
Arguments hashExport: clear implicits.
Record hashConsing {A:Type}:= {
- (* TODO next_hashcode: unit -> ?? hashcode *)
- hC: pre_hashV A -> ?? hashV A;
- hC_known: pre_hashV A -> ?? hashV A; (* fails on unknown inputs *)
- (**** below: debugging functions ****)
+ hC: hashinfo A -> ?? A;
+ (**** below: debugging or internal functions ****)
+ next_hid: unit -> ?? hashcode; (* should be strictly less old than ignore_hid *)
+ remove: hashinfo A -> ??unit; (* SHOULD NOT BE USED ! *)
next_log: pstring -> ?? unit; (* insert a log info (for the next introduced element) -- regiven by [iterall export] below *)
export: unit -> ?? hashExport A ;
}.
Arguments hashConsing: clear implicits.
+End HConsingDefs.
+
(** recMode: this is mainly for Tests ! *)
Inductive recMode:= StdRec | MemoRec | BareRec | BuggyRec.
diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml
index b7a80679..2b66899b 100644
--- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml
+++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.ml
@@ -1,6 +1,5 @@
open ImpPrelude
-
-exception Stop;;
+open HConsingDefs
let make_dict (type key) (p: key Dict.hash_params) =
let module MyHashedType = struct
@@ -16,10 +15,15 @@ let make_dict (type key) (p: key Dict.hash_params) =
}
-let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV)) =
+exception Stop;;
+
+let xhCons (type a) (hp:a hashP) =
+ (* We use a hash-table, but a hash-set would be sufficient ! *)
+ (* Thus, we could use a weak hash-set, but prefer avoid it for easier debugging *)
+ (* Ideally, a parameter would allow to select between the weak or full version *)
let module MyHashedType = struct
- type t = a pre_hashV
- let equal x y = hash_eq x.pre_data y.pre_data
+ type t = a hashinfo
+ let equal x y = hp.hash_eq x.hdata y.hdata
let hash x = Hashtbl.hash x.hcodes
end in
let module MyHashtbl = Hashtbl.Make(MyHashedType) in
@@ -34,21 +38,18 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV))
let t = MyHashtbl.create 1000 in
let logs = ref [] in
{
- hC = (fun (x:a pre_hashV) ->
- match MyHashtbl.find_opt t x with
- | Some x' -> x'
+ hC = (fun (k:a hashinfo) ->
+ match MyHashtbl.find_opt t k with
+ | Some d -> d
| None -> (*print_string "+";*)
- let x' = { data = x.pre_data ;
- hid = MyHashtbl.length t }
- in MyHashtbl.add t x x'; x');
- hC_known = (fun (x:a pre_hashV) ->
- match MyHashtbl.find_opt t x with
- | Some x' -> x'
- | None -> error x);
+ let d = hp.set_hid k.hdata (MyHashtbl.length t) in
+ MyHashtbl.add t {k with hdata = d } d; d);
next_log = (fun info -> logs := (MyHashtbl.length t, info)::(!logs));
+ next_hid = (fun () -> MyHashtbl.length t);
+ remove = (fun (x:a hashinfo) -> MyHashtbl.remove t x);
export = fun () ->
match pick t with
- | None -> { get_hashV = (fun _ -> raise Not_found); iterall = (fun _ -> ()) }
+ | None -> { get_info = (fun _ -> raise Not_found); iterall = (fun _ -> ()) }
| Some (k,_) ->
(* the state is fully copied at export ! *)
let logs = ref (List.rev_append (!logs) []) in
@@ -57,9 +58,9 @@ let xhCons (type a) (hash_eq, error: (a -> a -> bool)*(a pre_hashV -> a hashV))
| (j, info)::l' when i>=j -> logs:=l'; info::(step_log i)
| _ -> []
in let a = Array.make (MyHashtbl.length t) k in
- MyHashtbl.iter (fun k d -> a.(d.hid) <- k) t;
+ MyHashtbl.iter (fun k d -> a.(hp.get_hid d) <- k) t;
{
- get_hashV = (fun i -> a.(i));
+ get_info = (fun i -> a.(i));
iterall = (fun iter_node -> Array.iteri (fun i k -> iter_node (step_log i) i k) a)
}
}
diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli
index a74c721a..5075d176 100644
--- a/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli
+++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpHConsOracles.mli
@@ -1,4 +1,5 @@
open ImpPrelude
+open HConsingDefs
-val make_dict : 'a1 Dict.hash_params -> ('a1, 'a2) Dict.t
-val xhCons: (('a -> 'a -> bool) * ('a pre_hashV -> 'a hashV)) -> 'a hashConsing
+val make_dict : 'a Dict.hash_params -> ('a, 'b) Dict.t
+val xhCons: 'a hashP -> 'a hashConsing
diff --git a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml
index 33c3c842..9e63c12d 100644
--- a/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml
+++ b/mppa_k1c/abstractbb/Impure/ocaml/ImpIOOracles.ml
@@ -74,7 +74,7 @@ let println: pstring -> unit
= fun l -> print l; print_newline()
let read_line () =
- CamlStr (Pervasives.read_line());;
+ CamlStr (Stdlib.read_line());;
exception ImpureFail of pstring;;
diff --git a/mppa_k1c/abstractbb/Parallelizability.v b/mppa_k1c/abstractbb/Parallelizability.v
index d1971e57..30904b5d 100644
--- a/mppa_k1c/abstractbb/Parallelizability.v
+++ b/mppa_k1c/abstractbb/Parallelizability.v
@@ -1,4 +1,4 @@
-(** Parallel Semantics of Abstract Basic Blocks and parallelizability test.s
+(** Parallel Semantics of Abstract Basic Blocks and parallelizability test.
*)
Require Setoid. (* in order to rewrite <-> *)
@@ -32,7 +32,7 @@ Fixpoint inst_prun (i: inst) (m tmp old: mem): option mem :=
end
end.
-(* [inst_prun] is generalization of [inst_run] *)
+(* [inst_prun] is generalization of [inst_run] *)
Lemma inst_run_prun i: forall m old,
inst_run ge i m old = inst_prun i m m old.
Proof.
@@ -332,7 +332,7 @@ Fixpoint bblock_wframe(p:bblock): list R.t :=
| i::p' => (inst_wframe i)++(bblock_wframe p')
end.
-Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm.
+Local Hint Resolve Permutation_app_head Permutation_app_tail Permutation_app_comm: core.
Lemma bblock_wframe_Permutation p p':
Permutation p p' -> Permutation (bblock_wframe p) (bblock_wframe p').
@@ -620,7 +620,7 @@ Include ParallelizablityChecking L.
Section PARALLEL2.
Variable ge: genv.
-Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame.
+Local Hint Resolve S.empty_match_frame S.add_match_frame S.union_match_frame S.is_disjoint_match_frame: core.
(** Now, refinement of each operation toward parallelizable *)
@@ -659,14 +659,14 @@ Fixpoint inst_sframe (i: inst): S.t :=
| a::i' => S.add (fst a) (S.union (exp_sframe (snd a)) (inst_sframe i'))
end.
-Local Hint Resolve exp_sframe_correct.
+Local Hint Resolve exp_sframe_correct: core.
Lemma inst_sframe_correct i: S.match_frame (inst_sframe i) (inst_frame i).
Proof.
induction i as [|[y e] i']; simpl; auto.
Qed.
-Local Hint Resolve inst_wsframe_correct inst_sframe_correct.
+Local Hint Resolve inst_wsframe_correct inst_sframe_correct: core.
Fixpoint is_pararec (p: bblock) (wsframe: S.t): bool :=
match p with
diff --git a/mppa_k1c/abstractbb/SeqSimuTheory.v b/mppa_k1c/abstractbb/SeqSimuTheory.v
new file mode 100644
index 00000000..e234883f
--- /dev/null
+++ b/mppa_k1c/abstractbb/SeqSimuTheory.v
@@ -0,0 +1,384 @@
+(** A theory for checking/proving simulation by symbolic execution.
+
+*)
+
+
+Require Coq.Logic.FunctionalExtensionality. (* not really necessary -- see lemma at the end *)
+Require Setoid. (* in order to rewrite <-> *)
+Require Export AbstractBasicBlocksDef.
+Require Import List.
+Require Import ImpPrelude.
+Import HConsingDefs.
+
+
+Module SimuTheory (L: SeqLanguage).
+
+Export L.
+Export LP.
+
+Inductive term :=
+ | Input (x:R.t)
+ | App (o: op) (l: list_term)
+with list_term :=
+ | LTnil
+ | LTcons (t:term) (l:list_term)
+ .
+
+Fixpoint term_eval (ge: genv) (t: term) (m: mem): option value :=
+ match t with
+ | Input x => Some (m x)
+ | App o l =>
+ match list_term_eval ge l m with
+ | Some v => op_eval ge o v
+ | _ => None
+ end
+ end
+with list_term_eval ge (l: list_term) (m: mem) {struct l}: option (list value) :=
+ match l with
+ | LTnil => Some nil
+ | LTcons t l' =>
+ match term_eval ge t m, list_term_eval ge l' m with
+ | Some v, Some lv => Some (v::lv)
+ | _, _ => None
+ end
+ end.
+
+(* the symbolic memory:
+ - pre: pre-condition expressing that the computation has not yet abort on a None.
+ - post: the post-condition for each pseudo-register
+*)
+Record smem:= {pre: genv -> mem -> Prop; post:> R.t -> term}.
+
+(** initial symbolic memory *)
+Definition smem_empty := {| pre:=fun _ _ => True; post:=(fun x => Input x) |}.
+
+Fixpoint exp_term (e: exp) (d old: smem) : term :=
+ match e with
+ | PReg x => d x
+ | Op o le => App o (list_exp_term le d old)
+ | Old e => exp_term e old old
+ end
+with list_exp_term (le: list_exp) (d old: smem) : list_term :=
+ match le with
+ | Enil => LTnil
+ | Econs e le' => LTcons (exp_term e d old) (list_exp_term le' d old)
+ | LOld le => list_exp_term le old old
+ end.
+
+
+(** assignment of the symbolic memory *)
+Definition smem_set (d:smem) x (t:term) :=
+ {| pre:=(fun ge m => (term_eval ge (d x) m) <> None /\ (d.(pre) ge m));
+ post:=fun y => if R.eq_dec x y then t else d y |}.
+
+Section SIMU_THEORY.
+
+Variable ge: genv.
+
+Lemma set_spec_eq d x t m:
+ term_eval ge (smem_set d x t x) m = term_eval ge t m.
+Proof.
+ unfold smem_set; simpl; case (R.eq_dec x x); try congruence.
+Qed.
+
+Lemma set_spec_diff d x y t m:
+ x <> y -> term_eval ge (smem_set d x t y) m = term_eval ge (d y) m.
+Proof.
+ unfold smem_set; simpl; case (R.eq_dec x y); try congruence.
+Qed.
+
+Fixpoint inst_smem (i: inst) (d old: smem): smem :=
+ match i with
+ | nil => d
+ | (x, e)::i' =>
+ let t:=exp_term e d old in
+ inst_smem i' (smem_set d x t) old
+ end.
+
+Fixpoint bblock_smem_rec (p: bblock) (d: smem): smem :=
+ match p with
+ | nil => d
+ | i::p' =>
+ let d':=inst_smem i d d in
+ bblock_smem_rec p' d'
+ end.
+
+Definition bblock_smem: bblock -> smem
+ := fun p => bblock_smem_rec p smem_empty.
+
+Lemma inst_smem_pre_monotonic i old: forall d m,
+ (pre (inst_smem i d old) ge m) -> (pre d ge m).
+Proof.
+ induction i as [|[y e] i IHi]; simpl; auto.
+ intros d a H; generalize (IHi _ _ H); clear H IHi.
+ unfold smem_set; simpl; intuition.
+Qed.
+
+Lemma bblock_smem_pre_monotonic p: forall d m,
+ (pre (bblock_smem_rec p d) ge m) -> (pre d ge m).
+Proof.
+ induction p as [|i p' IHp']; simpl; eauto.
+ intros d a H; eapply inst_smem_pre_monotonic; eauto.
+Qed.
+
+Local Hint Resolve inst_smem_pre_monotonic bblock_smem_pre_monotonic: core.
+
+Lemma term_eval_exp e (od:smem) m0 old:
+ (forall x, term_eval ge (od x) m0 = Some (old x)) ->
+ forall (d:smem) m1,
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ term_eval ge (exp_term e d od) m0 = exp_eval ge e m1 old.
+Proof.
+ intro H.
+ induction e using exp_mut with
+ (P0:=fun l => forall (d:smem) m1, (forall x, term_eval ge (d x) m0 = Some (m1 x)) -> list_term_eval ge (list_exp_term l d od) m0 = list_exp_eval ge l m1 old);
+ simpl; auto.
+ - intros; erewrite IHe; eauto.
+ - intros. erewrite IHe, IHe0; eauto.
+Qed.
+
+Lemma inst_smem_abort i m0 x old: forall (d:smem),
+ pre (inst_smem i d old) ge m0 ->
+ term_eval ge (d x) m0 = None ->
+ term_eval ge (inst_smem i d old x) m0 = None.
+Proof.
+ induction i as [|[y e] i IHi]; simpl; auto.
+ intros d VALID H; erewrite IHi; eauto. clear IHi.
+ unfold smem_set; simpl; destruct (R.eq_dec y x); auto.
+ subst;
+ generalize (inst_smem_pre_monotonic _ _ _ _ VALID); clear VALID.
+ unfold smem_set; simpl. intuition congruence.
+Qed.
+
+Lemma block_smem_rec_abort p m0 x: forall d,
+ pre (bblock_smem_rec p d) ge m0 ->
+ term_eval ge (d x) m0 = None ->
+ term_eval ge (bblock_smem_rec p d x) m0 = None.
+Proof.
+ induction p; simpl; auto.
+ intros d VALID H; erewrite IHp; eauto. clear IHp.
+ eapply inst_smem_abort; eauto.
+Qed.
+
+Lemma inst_smem_Some_correct1 i m0 old (od:smem):
+ (forall x, term_eval ge (od x) m0 = Some (old x)) ->
+ forall (m1 m2: mem) (d: smem),
+ inst_run ge i m1 old = Some m2 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x).
+Proof.
+ intro X; induction i as [|[x e] i IHi]; simpl; intros m1 m2 d H.
+ - inversion_clear H; eauto.
+ - intros H0 x0.
+ destruct (exp_eval ge e m1 old) eqn:Heqov; try congruence.
+ refine (IHi _ _ _ _ _ _); eauto.
+ clear x0; intros x0.
+ unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto.
+ subst; erewrite term_eval_exp; eauto.
+Qed.
+
+Lemma bblocks_smem_rec_Some_correct1 p m0: forall (m1 m2: mem) (d: smem),
+ run ge p m1 = Some m2 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x).
+Proof.
+ Local Hint Resolve inst_smem_Some_correct1: core.
+ induction p as [ | i p]; simpl; intros m1 m2 d H.
+ - inversion_clear H; eauto.
+ - intros H0 x0.
+ destruct (inst_run ge i m1 m1) eqn: Heqov.
+ + refine (IHp _ _ _ _ _ _); eauto.
+ + inversion H.
+Qed.
+
+Lemma bblock_smem_Some_correct1 p m0 m1:
+ run ge p m0 = Some m1
+ -> forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x).
+Proof.
+ intros; eapply bblocks_smem_rec_Some_correct1; eauto.
+Qed.
+
+Lemma inst_smem_None_correct i m0 old (od: smem):
+ (forall x, term_eval ge (od x) m0 = Some (old x)) ->
+ forall m1 d, pre (inst_smem i d od) ge m0 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ inst_run ge i m1 old = None -> exists x, term_eval ge (inst_smem i d od x) m0 = None.
+Proof.
+ intro X; induction i as [|[x e] i IHi]; simpl; intros m1 d.
+ - discriminate.
+ - intros VALID H0.
+ destruct (exp_eval ge e m1 old) eqn: Heqov.
+ + refine (IHi _ _ _ _); eauto.
+ intros x0; unfold assign, smem_set; simpl. destruct (R.eq_dec x x0); auto.
+ subst; erewrite term_eval_exp; eauto.
+ + intuition.
+ constructor 1 with (x:=x); simpl.
+ apply inst_smem_abort; auto.
+ rewrite set_spec_eq.
+ erewrite term_eval_exp; eauto.
+Qed.
+
+Lemma inst_smem_Some_correct2 i m0 old (od: smem):
+ (forall x, term_eval ge (od x) m0 = Some (old x)) ->
+ forall (m1 m2: mem) d,
+ pre (inst_smem i d od) ge m0 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ (forall x, term_eval ge (inst_smem i d od x) m0 = Some (m2 x)) ->
+ res_eq (Some m2) (inst_run ge i m1 old).
+Proof.
+ intro X.
+ induction i as [|[x e] i IHi]; simpl; intros m1 m2 d VALID H0.
+ - intros H; eapply ex_intro; intuition eauto.
+ generalize (H0 x); rewrite H.
+ congruence.
+ - intros H.
+ destruct (exp_eval ge e m1 old) eqn: Heqov.
+ + refine (IHi _ _ _ _ _ _); eauto.
+ intros x0; unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto.
+ subst; erewrite term_eval_exp; eauto.
+ + generalize (H x).
+ rewrite inst_smem_abort; discriminate || auto.
+ rewrite set_spec_eq.
+ erewrite term_eval_exp; eauto.
+Qed.
+
+Lemma bblocks_smem_rec_Some_correct2 p m0: forall (m1 m2: mem) d,
+ pre (bblock_smem_rec p d) ge m0 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ (forall x, term_eval ge (bblock_smem_rec p d x) m0 = Some (m2 x)) ->
+ res_eq (Some m2) (run ge p m1).
+Proof.
+ induction p as [|i p]; simpl; intros m1 m2 d VALID H0.
+ - intros H; eapply ex_intro; intuition eauto.
+ generalize (H0 x); rewrite H.
+ congruence.
+ - intros H.
+ destruct (inst_run ge i m1 m1) eqn: Heqom.
+ + refine (IHp _ _ _ _ _ _); eauto.
+ + assert (X: exists x, term_eval ge (inst_smem i d d x) m0 = None).
+ { eapply inst_smem_None_correct; eauto. }
+ destruct X as [x H1].
+ generalize (H x).
+ erewrite block_smem_rec_abort; eauto.
+ congruence.
+Qed.
+
+Lemma bblock_smem_Some_correct2 p m0 m1:
+ pre (bblock_smem p) ge m0 ->
+ (forall x, term_eval ge (bblock_smem p x) m0 = Some (m1 x))
+ -> res_eq (Some m1) (run ge p m0).
+Proof.
+ intros; eapply bblocks_smem_rec_Some_correct2; eauto.
+Qed.
+
+Lemma inst_valid i m0 old (od:smem):
+ (forall x, term_eval ge (od x) m0 = Some (old x)) ->
+ forall (m1 m2: mem) (d: smem),
+ pre d ge m0 ->
+ inst_run ge i m1 old = Some m2 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ pre (inst_smem i d od) ge m0.
+Proof.
+ induction i as [|[x e] i IHi]; simpl; auto.
+ intros Hold m1 m2 d VALID0 H Hm1.
+ destruct (exp_eval ge e m1 old) eqn: Heq; simpl; try congruence.
+ eapply IHi; eauto.
+ + unfold smem_set in * |- *; simpl.
+ rewrite Hm1; intuition congruence.
+ + intros x0. unfold assign, smem_set; simpl; destruct (R.eq_dec x x0); auto.
+ subst; erewrite term_eval_exp; eauto.
+Qed.
+
+
+Lemma block_smem_rec_valid p m0: forall (m1 m2: mem) (d:smem),
+ pre d ge m0 ->
+ run ge p m1 = Some m2 ->
+ (forall x, term_eval ge (d x) m0 = Some (m1 x)) ->
+ pre (bblock_smem_rec p d) ge m0.
+Proof.
+ Local Hint Resolve inst_valid: core.
+ induction p as [ | i p]; simpl; intros m1 d H; auto.
+ intros H0 H1.
+ destruct (inst_run ge i m1 m1) eqn: Heqov; eauto.
+ congruence.
+Qed.
+
+Lemma bblock_smem_valid p m0 m1:
+ run ge p m0 = Some m1 ->
+ pre (bblock_smem p) ge m0.
+Proof.
+ intros; eapply block_smem_rec_valid; eauto.
+ unfold smem_empty; simpl. auto.
+Qed.
+
+Definition smem_valid ge d m := pre d ge m /\ forall x, term_eval ge (d x) m <> None.
+
+Definition smem_simu (d1 d2: smem): Prop :=
+ (forall m, smem_valid ge d1 m -> smem_valid ge d2 m)
+ /\ (forall m0 x, smem_valid ge d1 m0 ->
+ term_eval ge (d1 x) m0 = term_eval ge (d2 x) m0).
+
+
+Theorem bblock_smem_simu p1 p2:
+ smem_simu (bblock_smem p1) (bblock_smem p2) ->
+ bblock_simu ge p1 p2.
+Proof.
+ Local Hint Resolve bblock_smem_valid bblock_smem_Some_correct1: core.
+ intros (INCL & EQUIV) m DONTFAIL; unfold smem_valid in * |-.
+ destruct (run ge p1 m) as [m1|] eqn: RUN1; simpl; try congruence.
+ assert (X: forall x, term_eval ge (bblock_smem p1 x) m = Some (m1 x)); eauto.
+ eapply bblock_smem_Some_correct2; eauto.
+ + destruct (INCL m); intuition eauto.
+ congruence.
+ + intro x; erewrite <- EQUIV; intuition eauto.
+ congruence.
+Qed.
+
+Lemma smem_valid_set_decompose_1 d t x m:
+ smem_valid ge (smem_set d x t) m -> smem_valid ge d m.
+Proof.
+ unfold smem_valid; intros ((PRE1 & PRE2) & VALID); split.
+ + intuition.
+ + intros x0 H. case (R.eq_dec x x0).
+ * intuition congruence.
+ * intros DIFF; eapply VALID. erewrite set_spec_diff; eauto.
+Qed.
+
+Lemma smem_valid_set_decompose_2 d t x m:
+ smem_valid ge (smem_set d x t) m -> term_eval ge t m <> None.
+Proof.
+ unfold smem_valid; intros ((PRE1 & PRE2) & VALID) H.
+ generalize (VALID x); rewrite set_spec_eq.
+ tauto.
+Qed.
+
+Lemma smem_valid_set_proof d x t m:
+ smem_valid ge d m -> term_eval ge t m <> None -> smem_valid ge (smem_set d x t) m.
+Proof.
+ unfold smem_valid; intros (PRE & VALID) PREt. split.
+ + split; auto.
+ + intros x0; unfold smem_set; simpl; case (R.eq_dec x x0); intros; subst; auto.
+Qed.
+
+
+End SIMU_THEORY.
+
+(** REMARKS: more abstract formulation of the proof...
+ but relying on functional_extensionality.
+*)
+Definition smem_correct ge (d: smem) (m: mem) (om: option mem): Prop:=
+ forall m', om=Some m' <-> (d.(pre) ge m /\ forall x, term_eval ge (d x) m = Some (m' x)).
+
+Lemma bblock_smem_correct ge p m: smem_correct ge (bblock_smem p) m (run ge p m).
+Proof.
+ unfold smem_correct; simpl; intros m'; split.
+ + intros; split.
+ * eapply bblock_smem_valid; eauto.
+ * eapply bblock_smem_Some_correct1; eauto.
+ + intros (H1 & H2).
+ destruct (bblock_smem_Some_correct2 ge p m m') as (m2 & X & Y); eauto.
+ rewrite X. f_equal.
+ apply FunctionalExtensionality.functional_extensionality; auto.
+Qed.
+
+End SimuTheory.
diff --git a/mppa_k1c/Asmblockgenproof0.v b/mppa_k1c/lib/Asmblockgenproof0.v
index 89d41017..58455ada 100644
--- a/mppa_k1c/Asmblockgenproof0.v
+++ b/mppa_k1c/lib/Asmblockgenproof0.v
@@ -1,3 +1,9 @@
+(** * "block" version of Asmgenproof0
+
+ This module is largely adapted from Asmgenproof0.v of the other backends
+ It needs to stand apart because of the block structure, and the distinction control/basic that there isn't in the other backends
+ It has similar definitions than Asmgenproof0, but adapted to this new structure *)
+
Require Import Coqlib.
Require Intv.
Require Import AST.
@@ -16,34 +22,22 @@ Require Import Asmblockgen.
Require Import Conventions1.
Require Import Axioms.
Require Import Machblockgenproof. (* FIXME: only use to import [is_tail_app] and [is_tail_app_inv] *)
+Require Import Asmblockprops.
Module MB:=Machblock.
-Module AB:=Asmvliw.
-
-Hint Extern 2 (_ <> _) => congruence: asmgen.
-
-Definition bblock_simu (ge: Genv.t fundef unit) (f: function) (bb bb': bblock) :=
- forall rs m,
- exec_bblock ge f bb rs m <> Stuck ->
- exec_bblock ge f bb rs m = exec_bblock ge f bb' rs m.
+Module AB:=Asmblock.
Lemma ireg_of_eq:
forall r r', ireg_of r = OK r' -> preg_of r = IR r'.
Proof.
unfold ireg_of; intros. destruct (preg_of r); inv H; auto.
-(* destruct b. all: try discriminate.
- inv H1. auto.
- *)Qed.
+Qed.
-(* FIXME - Replaced FR by IR for MPPA *)
Lemma freg_of_eq:
forall r r', freg_of r = OK r' -> preg_of r = IR r'.
Proof.
unfold freg_of; intros. destruct (preg_of r); inv H; auto.
-(* destruct b. all: try discriminate.
- inv H1. auto.
- *)Qed.
-
+Qed.
Lemma preg_of_injective:
forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2.
@@ -51,53 +45,6 @@ Proof.
destruct r1; destruct r2; simpl; intros; reflexivity || discriminate.
Qed.
-Lemma preg_of_data:
- forall r, data_preg (preg_of r) = true.
-Proof.
- intros. destruct r; reflexivity.
-Qed.
-Hint Resolve preg_of_data: asmgen.
-
-Lemma data_diff:
- forall r r',
- data_preg r = true -> data_preg r' = false -> r <> r'.
-Proof.
- congruence.
-Qed.
-Hint Resolve data_diff: asmgen.
-
-Lemma preg_of_not_SP:
- forall r, preg_of r <> SP.
-Proof.
- intros. unfold preg_of; destruct r; simpl; congruence.
-Qed.
-
-Lemma preg_of_not_PC:
- forall r, preg_of r <> PC.
-Proof.
- intros. apply data_diff; auto with asmgen.
-Qed.
-
-Hint Resolve preg_of_not_SP preg_of_not_PC: asmgen.
-
-Lemma nextblock_pc:
- forall b rs, (nextblock b rs)#PC = Val.offset_ptr rs#PC (Ptrofs.repr (size b)).
-Proof.
- intros. apply Pregmap.gss.
-Qed.
-
-Lemma nextblock_inv:
- forall b r rs, r <> PC -> (nextblock b rs)#r = rs#r.
-Proof.
- intros. unfold nextblock. apply Pregmap.gso. red; intro; subst. auto.
-Qed.
-
-Lemma nextblock_inv1:
- forall b r rs, data_preg r = true -> (nextblock b rs)#r = rs#r.
-Proof.
- intros. apply nextblock_inv. red; intro; subst; discriminate.
-Qed.
-
Lemma undef_regs_other:
forall r rl rs,
(forall r', In r' rl -> r <> r') ->
@@ -277,24 +224,6 @@ Proof.
exploit preg_of_injective; eauto. congruence.
Qed.
-(* Lemma agree_undef_regs2:
- forall ms sp rl rs rs',
- agree (Mach.undef_regs rl ms) sp rs ->
- (forall r', data_preg r' = true -> preg_notin r' rl -> rs'#r' = rs#r') ->
- agree (Mach.undef_regs rl ms) sp rs'.
-Proof.
- intros. destruct H. split; auto.
- rewrite <- agree_sp0. apply H0; auto.
- rewrite preg_notin_charact. intros. apply not_eq_sym. apply preg_of_not_SP.
- intros. destruct (In_dec mreg_eq r rl).
- rewrite Mach.undef_regs_same; auto.
- rewrite H0; auto.
- apply preg_of_data.
- rewrite preg_notin_charact. intros; red; intros. elim n.
- exploit preg_of_injective; eauto. congruence.
-Qed.
- *)
-
Lemma agree_set_undef_mreg:
forall ms sp rs r v rl rs',
agree ms sp rs ->
@@ -312,9 +241,9 @@ Qed.
Lemma agree_undef_caller_save_regs:
forall ms sp rs,
agree ms sp rs ->
- agree (Mach.undef_caller_save_regs ms) sp (Asmvliw.undef_caller_save_regs rs).
+ agree (Mach.undef_caller_save_regs ms) sp (undef_caller_save_regs rs).
Proof.
- intros. destruct H. unfold Mach.undef_caller_save_regs, Asmvliw.undef_caller_save_regs; split.
+ intros. destruct H. unfold Mach.undef_caller_save_regs, undef_caller_save_regs; split.
- unfold proj_sumbool; rewrite dec_eq_true. auto.
- auto.
- intros. unfold proj_sumbool. rewrite dec_eq_false by (apply preg_of_not_SP).
@@ -485,7 +414,7 @@ Proof.
Qed.
-Local Hint Resolve code_tail_0 code_tail_S.
+Local Hint Resolve code_tail_0 code_tail_S: core.
Lemma code_tail_next:
forall fn ofs c0,
@@ -529,7 +458,7 @@ Proof.
omega.
Qed.
-Local Hint Resolve code_tail_next.
+Local Hint Resolve code_tail_next: core.
Lemma code_tail_next_int:
forall fn ofs bi c,
@@ -607,15 +536,13 @@ Hypothesis transf_function_len:
forall f tf, transf_function f = OK tf -> size_blocks (fn_blocks tf) <= Ptrofs.max_unsigned.
-(* NB: the hypothesis in comment on [b] is not needed in the proof ! *)
Lemma return_address_exists:
- forall b f (* sg ros *) c, (* b.(MB.exit) = Some (MBcall sg ros) -> *) is_tail (b :: c) f.(MB.fn_code) ->
+ forall b f c, is_tail (b :: c) f.(MB.fn_code) ->
exists ra, return_address_offset f c ra.
Proof.
intros. destruct (transf_function f) as [tf|] eqn:TF.
+ exploit transf_function_inv; eauto. intros (tc1 & ep1 & TR1 & TL1).
exploit transl_blocks_tail; eauto. intros (tc2 & ep2 & TR2 & TL2).
-(* unfold return_address_offset. *)
monadInv TR2.
assert (TL3: is_tail x0 (fn_blocks tf)).
{ apply is_tail_trans with tc1; auto.
@@ -632,7 +559,7 @@ Qed.
End RETADDR_EXISTS.
(** [transl_code_at_pc pc fb f c ep tf tc] holds if the code pointer [pc] points
- within the Asm code generated by translating Mach function [f],
+ within the Asmblock code generated by translating Machblock function [f],
and [tc] is the tail of the generated code at the position corresponding
to the code pointer [pc]. *)
@@ -772,6 +699,19 @@ Proof.
intros. destruct H. auto.
Qed.
+Lemma exec_body_pc:
+ forall ge l rs1 m1 rs2 m2,
+ exec_body ge l rs1 m1 = Next rs2 m2 ->
+ rs2 PC = rs1 PC.
+Proof.
+ induction l.
+ - intros. inv H. auto.
+ - intros until m2. intro EXEB.
+ inv EXEB. destruct (exec_basic_instr _ _ _ _) eqn:EBI; try discriminate.
+ eapply IHl in H0. rewrite H0.
+ erewrite exec_basic_instr_pc; eauto.
+Qed.
+
Section STRAIGHTLINE.
Variable ge: genv.
@@ -850,18 +790,6 @@ Proof.
apply exec_straight_step with rs2 m2; auto.
Qed.
-(* Theorem exec_straight_bblock:
- forall rs1 m1 rs2 m2 rs3 m3 b,
- exec_straight (body b) rs1 m1 nil rs2 m2 ->
- exec_control_rel (exit b) b rs2 m2 rs3 m3 ->
- exec_bblock_rel b rs1 m1 rs3 m3.
-Proof.
- intros.
- econstructor; eauto. unfold exec_bblock. erewrite exec_straight_body; eauto.
- inv H0. auto.
-Qed. *)
-
-
Lemma exec_straight_two:
forall i1 i2 c rs1 m1 rs2 m2 rs3 m3,
exec_basic_instr ge i1 rs1 m1 = Next rs2 m2 ->
@@ -912,79 +840,6 @@ Qed.
(** Linking exec_straight with exec_straight_blocks *)
-Ltac Simplif :=
- ((rewrite nextblock_inv by eauto with asmgen)
- || (rewrite nextblock_inv1 by eauto with asmgen)
- || (rewrite Pregmap.gss)
- || (rewrite nextblock_pc)
- || (rewrite Pregmap.gso by eauto with asmgen)
- ); auto with asmgen.
-
-Ltac Simpl := repeat Simplif.
-
-Lemma exec_basic_instr_pc:
- forall b rs1 m1 rs2 m2,
- exec_basic_instr ge b rs1 m1 = Next rs2 m2 ->
- rs2 PC = rs1 PC.
-Proof.
- intros. destruct b; try destruct i; try destruct i.
- all: try (inv H; Simpl).
- 1-10: try (unfold parexec_load_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]).
- 1-10: try (unfold parexec_load_reg in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]).
- 1-10: try (unfold parexec_load_regxs in H1; destruct (Mem.loadv _ _ _); [inv H1; Simpl | discriminate]).
- 1-10: try (unfold parexec_store_offset in H1; destruct (eval_offset ofs); try discriminate; destruct (Mem.storev _ _ _); [inv H1; auto | discriminate]).
- 1-10: try (unfold parexec_store_reg in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto.
- 1-10: try (unfold parexec_store_regxs in H1; destruct (Mem.storev _ _ _); [inv H1; Simpl | discriminate]); auto.
- - (* PLoadQRRO *)
- unfold parexec_load_q_offset in H1.
- destruct (gpreg_q_expand _) as [r0 r1] in H1.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- inv H1. Simpl.
- - (* PLoadORRO *)
- unfold parexec_load_o_offset in H1.
- destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- destruct (Mem.loadv _ _ _) in H1; try discriminate.
- inv H1. Simpl.
- - (* PStoreQRRO *)
- unfold parexec_store_q_offset in H1.
- destruct (gpreg_q_expand _) as [r0 r1] in H1.
- unfold eval_offset in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- inv H1. Simpl. reflexivity.
- - (* PStoreORRO *)
- unfold parexec_store_o_offset in H1.
- destruct (gpreg_o_expand _) as [[[r0 r1] r2] r3] in H1.
- unfold eval_offset in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- destruct (Mem.storev _ _ _) in H1; try discriminate.
- inv H1. Simpl. reflexivity.
- - destruct (Mem.alloc _ _ _). destruct (Mem.store _ _ _ _ _). inv H1. Simpl. discriminate.
- - destruct (Mem.loadv _ _ _); try discriminate. destruct (rs1 _); try discriminate.
- destruct (Mem.free _ _ _ _). inv H1. Simpl. discriminate.
- - destruct rs; try discriminate. inv H1. Simpl.
- - destruct rd; try discriminate. inv H1; Simpl.
- - reflexivity.
-Qed.
-
-(* Lemma exec_straight_pc':
- forall c rs1 m1 rs2 m2,
- exec_straight c rs1 m1 nil rs2 m2 ->
- rs2 PC = rs1 PC.
-Proof.
- induction c; intros; try (inv H; fail).
- inv H.
- - erewrite exec_basic_instr_pc; eauto.
- - rewrite (IHc rs3 m3 rs2 m2); auto.
- erewrite exec_basic_instr_pc; eauto.
-Qed. *)
-
Lemma exec_straight_pc:
forall c c' rs1 m1 rs2 m2,
exec_straight c rs1 m1 c' rs2 m2 ->
@@ -997,25 +852,6 @@ Proof.
erewrite exec_basic_instr_pc; eauto.
Qed.
-(* Lemma exec_straight_through:
- forall c i b lb rs1 m1 rs2 m2 rs2' m2',
- bblock_basic_ctl c i = b ->
- exec_straight c rs1 m1 nil rs2 m2 ->
- nextblock b rs2 = rs2' -> m2 = m2' ->
- exec_control ge fn i rs2' m2' = Next rs2' m2' -> (* if the control does not jump *)
- exec_straight_blocks (b::lb) rs1 m1 lb rs2' m2'.
-Proof.
- intros. subst. destruct i.
- - constructor 1.
- + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto.
- + rewrite <- (exec_straight_pc c nil rs1 m1 rs2 m2'); auto.
- - destruct c as [|i c]; try (inv H0; fail).
- constructor 1.
- + unfold exec_bblock. simpl body. erewrite exec_straight_body; eauto.
- + rewrite <- (exec_straight_pc (i ::i c) nil rs1 m1 rs2 m2'); auto.
-Qed.
- *)
-
Lemma regset_same_assign (rs: regset) r:
rs # r <- (rs r) = rs.
Proof.
@@ -1034,8 +870,6 @@ Proof.
simpl; auto. unfold nextblock, incrPC; simpl. Simpl. erewrite exec_straight_pc; eauto.
Qed.
-
-
(** The following lemmas show that straight-line executions
(predicate [exec_straight_blocks]) correspond to correct Asm executions. *)
@@ -1086,7 +920,6 @@ Qed.
End STRAIGHTLINE.
-
(** * Properties of the Machblock call stack *)
Section MATCH_STACK.
diff --git a/mppa_k1c/lib/ForwardSimulationBlock.v b/mppa_k1c/lib/ForwardSimulationBlock.v
index 39dd2234..224eda0a 100644
--- a/mppa_k1c/lib/ForwardSimulationBlock.v
+++ b/mppa_k1c/lib/ForwardSimulationBlock.v
@@ -21,7 +21,7 @@ Section starN_lemma.
Variable L: semantics.
-Local Hint Resolve starN_refl starN_step Eapp_assoc.
+Local Hint Resolve starN_refl starN_step Eapp_assoc: core.
Lemma starN_split n s t s':
starN (step L) (globalenv L) n s t s' ->
@@ -93,7 +93,7 @@ Hypothesis simu_end_block:
(** Introduction d'une sémantique par bloc sur L1 appelée "memoL1" *)
-Local Hint Resolve starN_refl starN_step.
+Local Hint Resolve starN_refl starN_step: core.
Definition follows_in_block (head current: state L1): Prop :=
dist_end_block head >= dist_end_block current
@@ -164,7 +164,7 @@ Inductive is_well_memorized (s s': memostate): Prop :=
memorized s' = None ->
is_well_memorized s s'.
-Local Hint Resolve StartBloc MidBloc ExitBloc.
+Local Hint Resolve StartBloc MidBloc ExitBloc: core.
Definition memoL1 := {|
state := memostate;
diff --git a/mppa_k1c/lib/Machblock.v b/mppa_k1c/lib/Machblock.v
index 30393fd5..5a7f1782 100644
--- a/mppa_k1c/lib/Machblock.v
+++ b/mppa_k1c/lib/Machblock.v
@@ -14,19 +14,19 @@ Require Stacklayout.
Require Import Mach.
Require Import Linking.
-(** instructions "basiques" (ie non control-flow) *)
+(** basic instructions (ie no control-flow) *)
Inductive basic_inst: Type :=
| MBgetstack: ptrofs -> typ -> mreg -> basic_inst
| MBsetstack: mreg -> ptrofs -> typ -> basic_inst
| MBgetparam: ptrofs -> typ -> mreg -> basic_inst
| MBop: operation -> list mreg -> mreg -> basic_inst
- | MBload: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst
+ | MBload: trapping_mode -> memory_chunk -> addressing -> list mreg -> mreg -> basic_inst
| MBstore: memory_chunk -> addressing -> list mreg -> mreg -> basic_inst
.
Definition bblock_body := list basic_inst.
-(** instructions de control flow *)
+(** control flow instructions *)
Inductive control_flow_inst: Type :=
| MBcall: signature -> mreg + ident -> control_flow_inst
| MBtailcall: signature -> mreg + ident -> control_flow_inst
@@ -207,11 +207,22 @@ Inductive basic_step (s: list stackframe) (fb: block) (sp: val) (rs: regset) (m:
rs' = ((undef_regs (destroyed_by_op op) rs)#res <- v) ->
basic_step s fb sp rs m (MBop op args res) rs' m
| exec_MBload:
- forall addr args a v rs' chunk dst,
+ forall addr args a v rs' trap chunk dst,
eval_addressing ge sp addr rs##args = Some a ->
Mem.loadv chunk m a = Some v ->
rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- v) ->
- basic_step s fb sp rs m (MBload chunk addr args dst) rs' m
+ basic_step s fb sp rs m (MBload trap chunk addr args dst) rs' m
+ | exec_MBload_notrap1:
+ forall addr args rs' chunk dst,
+ eval_addressing ge sp addr rs##args = None ->
+ rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) ->
+ basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m
+ | exec_MBload_notrap2:
+ forall addr args a rs' chunk dst,
+ eval_addressing ge sp addr rs##args = Some a ->
+ Mem.loadv chunk m a = None ->
+ rs' = ((undef_regs (destroyed_by_load chunk addr) rs)#dst <- (default_notrap_load_value chunk)) ->
+ basic_step s fb sp rs m (MBload NOTRAP chunk addr args dst) rs' m
| exec_MBstore:
forall chunk addr args src m' a rs',
eval_addressing ge sp addr rs##args = Some a ->
diff --git a/mppa_k1c/lib/Machblockgen.v b/mppa_k1c/lib/Machblockgen.v
index 4dfc309e..2ba42814 100644
--- a/mppa_k1c/lib/Machblockgen.v
+++ b/mppa_k1c/lib/Machblockgen.v
@@ -33,7 +33,7 @@ Definition trans_inst (i:Mach.instruction) : Machblock_inst :=
| Msetstack src ofs ty => MB_basic (MBsetstack src ofs ty)
| Mgetparam ofs ty dst => MB_basic (MBgetparam ofs ty dst)
| Mop op args res => MB_basic (MBop op args res)
- | Mload chunk addr args dst => MB_basic (MBload chunk addr args dst)
+ | Mload trap chunk addr args dst=> MB_basic (MBload trap chunk addr args dst)
| Mstore chunk addr args src => MB_basic (MBstore chunk addr args src)
| Mlabel l => MB_label l
end.
@@ -57,12 +57,9 @@ Definition add_to_new_bblock (i:Machblock_inst) : bblock :=
| MB_cfi i => cfi_bblock i
end.
-(* ajout d'une instruction en début d'une liste de blocks *)
-(* Soit /1\ ajout en tête de block, soit /2\ ajout dans un nouveau block*)
-(* bl est vide -> /2\ *)
-(* cfi -> /2\ (ajout dans exit)*)
-(* basic -> /1\ si header vide, /2\ si a un header *)
-(* label -> /1\ (dans header)*)
+(** Adding an instruction to the beginning of a bblock list
+ * Either adding the instruction to the head of the list,
+ * or create a new bblock with the instruction *)
Definition add_to_code (i:Machblock_inst) (bl:code) : code :=
match bl with
| bh::bl0 => match i with
@@ -86,8 +83,6 @@ Fixpoint trans_code_rev (c: Mach.code) (bl:code) : code :=
Function trans_code (c: Mach.code) : code :=
trans_code_rev (List.rev_append c nil) nil.
-
-(* à finir pour passer des Mach.function au function, etc. *)
Definition transf_function (f: Mach.function) : function :=
{| fn_sig:=Mach.fn_sig f;
fn_code:=trans_code (Mach.fn_code f);
@@ -103,14 +98,14 @@ Definition transf_program (src: Mach.program) : program :=
transform_program transf_fundef src.
-(** Abstraction de trans_code *)
+(** Abstracting trans_code *)
Inductive is_end_block: Machblock_inst -> code -> Prop :=
| End_empty mbi: is_end_block mbi nil
| End_basic bi bh bl: header bh <> nil -> is_end_block (MB_basic bi) (bh::bl)
| End_cfi cfi bl: bl <> nil -> is_end_block (MB_cfi cfi) bl.
-Local Hint Resolve End_empty End_basic End_cfi.
+Local Hint Resolve End_empty End_basic End_cfi: core.
Inductive is_trans_code: Mach.code -> code -> Prop :=
| Tr_nil: is_trans_code nil nil
@@ -128,7 +123,7 @@ Inductive is_trans_code: Mach.code -> code -> Prop :=
header bh = nil ->
is_trans_code (i::c) (add_basic bi bh::bl).
-Local Hint Resolve Tr_nil Tr_end_block.
+Local Hint Resolve Tr_nil Tr_end_block: core.
Lemma add_to_code_is_trans_code i c bl:
is_trans_code c bl ->
@@ -150,7 +145,7 @@ Proof.
rewrite <- Heqti. eapply End_cfi. congruence.
Qed.
-Local Hint Resolve add_to_code_is_trans_code.
+Local Hint Resolve add_to_code_is_trans_code: core.
Lemma trans_code_is_trans_code_rev c1: forall c2 mbi,
is_trans_code c2 mbi ->
@@ -190,7 +185,7 @@ Proof.
exists mbi1. split; congruence.
Qed.
-Local Hint Resolve trans_code_is_trans_code.
+Local Hint Resolve trans_code_is_trans_code: core.
Theorem is_trans_code_inv c bl: is_trans_code c bl <-> bl=(trans_code c).
Proof.
diff --git a/mppa_k1c/lib/Machblockgenproof.v b/mppa_k1c/lib/Machblockgenproof.v
index 9186e54a..0de2df52 100644
--- a/mppa_k1c/lib/Machblockgenproof.v
+++ b/mppa_k1c/lib/Machblockgenproof.v
@@ -72,7 +72,7 @@ Proof.
apply match_states_trans_state.
Qed.
-Local Hint Resolve match_states_trans_state.
+Local Hint Resolve match_states_trans_state: core.
Lemma symbols_preserved:
forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
@@ -284,7 +284,7 @@ Proof.
Qed.
Local Hint Resolve symbols_preserved senv_preserved init_mem_preserved prog_main_preserved functions_translated
- parent_sp_preserved.
+ parent_sp_preserved: core.
Definition dist_end_block_code (c: Mach.code) :=
@@ -299,8 +299,8 @@ Definition dist_end_block (s: Mach.state): nat :=
| _ => 0
end.
-Local Hint Resolve exec_nil_body exec_cons_body.
-Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore.
+Local Hint Resolve exec_nil_body exec_cons_body: core.
+Local Hint Resolve exec_MBgetstack exec_MBsetstack exec_MBgetparam exec_MBop exec_MBload exec_MBstore: core.
Lemma size_add_label l bh: size (add_label l bh) = size bh + 1.
Proof.
@@ -336,7 +336,7 @@ Proof.
omega.
Qed.
-Local Hint Resolve dist_end_block_code_simu_mid_block.
+Local Hint Resolve dist_end_block_code_simu_mid_block: core.
Lemma size_nonzero c b bl:
@@ -392,8 +392,8 @@ destruct i; congruence.
Qed.
-Local Hint Resolve Mlabel_is_not_cfi.
-Local Hint Resolve MBbasic_is_not_cfi.
+Local Hint Resolve Mlabel_is_not_cfi: core.
+Local Hint Resolve MBbasic_is_not_cfi: core.
Lemma add_to_new_block_is_label i:
header (add_to_new_bblock (trans_inst i)) <> nil -> exists l, i = Mlabel l.
@@ -408,7 +408,7 @@ Proof.
+ unfold cfi_bblock in H; simpl in H; congruence.
Qed.
-Local Hint Resolve Mlabel_is_not_basic.
+Local Hint Resolve Mlabel_is_not_basic: core.
Lemma trans_code_decompose c: forall b bl,
is_trans_code c (b::bl) ->
@@ -483,6 +483,10 @@ Proof.
unfold Genv.symbol_address; rewrite symbols_preserved; auto.
- eapply exec_MBload; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
unfold Genv.symbol_address; rewrite symbols_preserved; auto.
+ - eapply exec_MBload_notrap1; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
+ unfold Genv.symbol_address; rewrite symbols_preserved; auto.
+ - eapply exec_MBload_notrap2; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
+ unfold Genv.symbol_address; rewrite symbols_preserved; auto.
- eapply exec_MBstore; eauto; rewrite <- H; destruct a; simpl; auto; destruct (rs ## l); simpl; auto;
unfold Genv.symbol_address; rewrite symbols_preserved; auto.
Qed.
@@ -506,8 +510,8 @@ Proof.
rewrite Hs2, Hb2; eauto.
Qed.
-Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit.
-Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same.
+Local Hint Resolve exec_MBcall exec_MBtailcall exec_MBbuiltin exec_MBgoto exec_MBcond_true exec_MBcond_false exec_MBjumptable exec_MBreturn exec_Some_exit exec_None_exit: core.
+Local Hint Resolve eval_builtin_args_preserved external_call_symbols_preserved find_funct_ptr_same: core.
Lemma match_states_concat_trans_code st f sp c rs m h:
@@ -715,11 +719,11 @@ Proof.
intro H; destruct c as [|i' c]. { inversion H. }
remember (trans_inst i) as ti.
destruct ti as [lbl|bi|cfi].
- - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2:{ destruct i; simpl in * |- *; try congruence. }
+ - (*i=lbl *) cutrewrite (i = Mlabel lbl). 2: ( destruct i; simpl in * |- *; try congruence ).
exists nil; simpl; eexists. eapply Tr_add_label; eauto.
- (*i=basic*)
destruct i'.
- 10: {exists (add_to_new_bblock (MB_basic bi)::nil). exists b.
+ 10: { exists (add_to_new_bblock (MB_basic bi)::nil). exists b.
cutrewrite ((add_to_new_bblock (MB_basic bi) :: nil) ++ (b::l)=(add_to_new_bblock (MB_basic bi) :: (b::l)));eauto.
rewrite Heqti.
eapply Tr_end_block; eauto.
diff --git a/pg b/pg
index 28926baa..398d618f 100755
--- a/pg
+++ b/pg
@@ -1,10 +1,7 @@
#!/bin/sh
-# Start Proof General with the right -I options
+# Start Proof General with the right Coq version
# Use the Makefile to rebuild dependencies if needed
-# Recompile the modified file after coqide editing
-
-PWD=`pwd`
-INCLUDES=`make print-includes`
+# Recompile the modified file after editing
make -q ${1}o || {
make -n ${1}o | grep -v "\\b${1}\\b" | \
@@ -15,16 +12,5 @@ make -q ${1}o || {
COQPROGNAME="${COQBIN}coqtop"
-COQPROGARGS=""
-for arg in $INCLUDES; do
- case "$arg" in
- -I|-R|-as|compcert*)
- COQPROGARGS="$COQPROGARGS \"$arg\"";;
- *)
- COQPROGARGS="$COQPROGARGS \"$PWD/$arg\"";;
- esac
-done
-
-emacs --eval "(setq coq-prog-name \"$COQPROGNAME\")" \
- --eval "(setq coq-prog-args '($COQPROGARGS))" $1 \
+emacs --eval "(setq coq-prog-name \"$COQPROGNAME\")" $1 \
&& make ${1}o
diff --git a/powerpc/Archi.v b/powerpc/Archi.v
index 5d11aad1..10f38391 100644
--- a/powerpc/Archi.v
+++ b/powerpc/Archi.v
@@ -16,9 +16,9 @@
(** Architecture-dependent parameters for PowerPC *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
Definition ptr64 := false.
@@ -30,6 +30,10 @@ Definition align_float64 := 8%Z.
(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64 : bool.
+(** Should single-precision FP arguments passed on stack be passed
+ as singles or use double FP format. *)
+Parameter single_passed_as_single : bool.
+
Definition splitlong := negb ppc64.
Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
@@ -37,21 +41,33 @@ Proof.
reflexivity.
Qed.
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (false, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (false, iter_nat 22 _ xO xH).
+
+(* Always choose the first NaN argument, if any *)
+
+Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_64 | n :: _ => n end.
+
+Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_32 | n :: _ => n end.
+
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. auto. Qed.
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- false. (**r always choose first NaN *)
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. auto. Qed.
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (false, iter_nat 22 _ xO xH).
+Definition fma_order {A: Type} (x y z: A) := (x, z, y).
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- false. (**r always choose first NaN *)
+Definition fma_invalid_mul_is_nan := false.
Definition float_of_single_preserves_sNaN := true.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
- float_of_single_preserves_sNaN. \ No newline at end of file
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
+ float_of_single_preserves_sNaN.
diff --git a/powerpc/Asm.v b/powerpc/Asm.v
index ad24f563..4fb38ff8 100644
--- a/powerpc/Asm.v
+++ b/powerpc/Asm.v
@@ -231,6 +231,7 @@ Inductive instruction : Type :=
| Pfres: freg -> freg -> instruction (**r approximate inverse *)
| Pfsel: freg -> freg -> freg -> freg -> instruction (**r FP conditional move *)
| Pisel: ireg -> ireg -> ireg -> crbit -> instruction (**r integer select *)
+ | Pfsel_gen: freg -> freg -> freg -> crbit -> instruction (**r floating point select *)
| Pisync: instruction (**r ISYNC barrier *)
| Picbi: ireg -> ireg -> instruction (**r instruction cache invalidate *)
| Picbtls: int -> ireg -> ireg -> instruction (**r instruction cache block touch and lock set *)
@@ -860,6 +861,20 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out
Next (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m
| Pfsubs rd r1 r2 =>
Next (nextinstr (rs#rd <- (Val.subfs rs#r1 rs#r2))) m
+ | Pisel rd r1 r2 bit =>
+ let v :=
+ match rs#(reg_of_crbit bit) with
+ | Vint n => if Int.eq n Int.zero then rs#r2 else (gpr_or_zero rs r1)
+ | _ => Vundef
+ end in
+ Next (nextinstr (rs #rd <- v #GPR0 <- Vundef)) m
+ | Pfsel_gen rd r1 r2 bit =>
+ let v :=
+ match rs#(reg_of_crbit bit) with
+ | Vint n => if Int.eq n Int.zero then rs#r2 else rs#r1
+ | _ => Vundef
+ end in
+ Next (nextinstr (rs #rd <- v #GPR0 <- Vundef)) m
| Plbz rd cst r1 =>
load1 Mint8unsigned rd cst r1 rs m
| Plbzx rd r1 r2 =>
@@ -1073,7 +1088,6 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out
| Pfrsqrte _ _
| Pfres _ _
| Pfsel _ _ _ _
- | Pisel _ _ _ _
| Plwarx _ _ _
| Plwbrx _ _ _
| Picbi _ _
diff --git a/powerpc/AsmToJSON.ml b/powerpc/AsmToJSON.ml
index ee3eaca8..f4d4285a 100644
--- a/powerpc/AsmToJSON.ml
+++ b/powerpc/AsmToJSON.ml
@@ -17,12 +17,10 @@ open AST
open BinNums
open Camlcoq
open Json
-open Format
open JsonAST
let pp_reg pp t n =
- let s = sprintf "%s%s" t n in
- pp_jsingle_object pp "Register" pp_jstring s
+ pp_jsingle_object pp "Register" pp_jstring (t ^ n)
let pp_ireg pp reg =
pp_reg pp "r" (TargetPrinter.int_reg_name reg)
@@ -31,8 +29,8 @@ let pp_freg pp reg =
pp_reg pp "f" (TargetPrinter.float_reg_name reg)
let preg_annot = function
- | IR r -> sprintf "r%s" (TargetPrinter.int_reg_name r)
- | FR r -> sprintf "f%s" (TargetPrinter.float_reg_name r)
+ | IR r -> "r" ^ (TargetPrinter.int_reg_name r)
+ | FR r -> "f" ^ (TargetPrinter.float_reg_name r)
| _ -> assert false
let pp_constant pp c =
@@ -86,28 +84,31 @@ let pp_arg pp = function
| Atom a -> pp_atom_constant pp a
| String s -> pp_jsingle_object pp "String" pp_jstring s
-let mnemonic_names =["Padd"; "Paddc"; "Padde"; "Paddi"; "Paddic"; "Paddis"; "Paddze"; "Pand_";
- "Pandc"; "Pandi_"; "Pandis_"; "Pannot"; "Pb"; "Pbctr"; "Pbctrl"; "Pbdnz";
- "Pbf"; "Pbl"; "Pblr"; "Pbs"; "Pbt"; "Pbtbl"; "Pcmpb"; "Pcmpd"; "Pcmpdi";
- "Pcmpld"; "Pcmpldi"; "Pcmplw"; "Pcmplwi"; "Pcmpw"; "Pcmpwi"; "Pcntlzd";
- "Pcntlzw"; "Pcreqv"; "Pcror"; "Pcrxor"; "Pdcbf"; "Pdcbi"; "Pdcbt";
- "Pdcbtls"; "Pdcbtst"; "Pdcbz"; "Pdivd"; "Pdivdu"; "Pdivw"; "Pdivwu";
- "Peieio"; "Peqv"; "Pextsb"; "Pextsh"; "Pextsw"; "Pfabs"; "Pfadd"; "Pfadds";
- "Pfcfid"; "Pfcmpu"; "Pfctidz"; "Pfctiw"; "Pfctiwz"; "Pfdiv"; "Pfdivs";
- "Pfmadd"; "Pfmr"; "Pfmsub"; "Pfmul"; "Pfmuls"; "Pfneg"; "Pfnmadd";
- "Pfnmsub"; "Pfres"; "Pfrsp"; "Pfrsqrte"; "Pfsel"; "Pfsqrt"; "Pfsub";
- "Pfsubs"; "Picbi"; "Picbtls"; "Pinlineasm"; "Pisel"; "Pisync"; "Plabel";
- "Plbz"; "Plbzx"; "Pld"; "Pldbrx"; "Pldi"; "Pldx"; "Plfd"; "Plfdx"; "Plfi"; "Plfis";
- "Plfs"; "Plfsx"; "Plha"; "Plhax"; "Plhbrx"; "Plhz"; "Plhzx"; "Plwarx";
- "Plwbrx"; "Plwsync"; "Plwz"; "Plwzu"; "Plwzx"; "Pmbar"; "Pmfcr"; "Pmflr";
- "Pmfspr"; "Pmr"; "Pmtctr"; "Pmtlr"; "Pmtspr"; "Pmulhd"; "Pmulhdu"; "Pmulhw";
- "Pmulhwu"; "Pmulld"; "Pmulli"; "Pmullw"; "Pnand"; "Pnor"; "Por"; "Porc";
- "Pori"; "Poris"; "Prldicl"; "Prldimi"; "Prldinm"; "Prlwimi"; "Prlwinm";
- "Psld"; "Pslw"; "Psrad"; "Psradi"; "Psraw"; "Psrawi"; "Psrd"; "Psrw";
- "Pstb"; "Pstbx"; "Pstd"; "Pstdbrx"; "Pstdu"; "Pstdx"; "Pstfd"; "Pstfdu"; "Pstfdx";
- "Pstfs"; "Pstfsx"; "Psth"; "Psthbrx"; "Psthx"; "Pstw"; "Pstwbrx"; "Pstwcx_";
- "Pstwu"; "Pstwux"; "Pstwx"; "Psubfc"; "Psubfe"; "Psubfic"; "Psubfze";
- "Psync"; "Ptrap"; "Pxor"; "Pxori"; "Pxoris"]
+module StringSet = Set.Make(String)
+
+let mnemonic_names = StringSet.of_list
+ ["Padd"; "Paddc"; "Padde"; "Paddi"; "Paddic"; "Paddis"; "Paddze"; "Pand_";
+ "Pandc"; "Pandi_"; "Pandis_"; "Pannot"; "Pb"; "Pbctr"; "Pbctrl"; "Pbdnz";
+ "Pbf"; "Pbl"; "Pblr"; "Pbs"; "Pbt"; "Pbtbl"; "Pcmpb"; "Pcmpd"; "Pcmpdi";
+ "Pcmpld"; "Pcmpldi"; "Pcmplw"; "Pcmplwi"; "Pcmpw"; "Pcmpwi"; "Pcntlzd";
+ "Pcntlzw"; "Pcreqv"; "Pcror"; "Pcrxor"; "Pdcbf"; "Pdcbi"; "Pdcbt";
+ "Pdcbtls"; "Pdcbtst"; "Pdcbz"; "Pdivd"; "Pdivdu"; "Pdivw"; "Pdivwu";
+ "Peieio"; "Peqv"; "Pextsb"; "Pextsh"; "Pextsw"; "Pfabs"; "Pfadd"; "Pfadds";
+ "Pfcfid"; "Pfcmpu"; "Pfctidz"; "Pfctiw"; "Pfctiwz"; "Pfdiv"; "Pfdivs";
+ "Pfmadd"; "Pfmr"; "Pfmsub"; "Pfmul"; "Pfmuls"; "Pfneg"; "Pfnmadd";
+ "Pfnmsub"; "Pfres"; "Pfrsp"; "Pfrsqrte"; "Pfsel"; "Pfsqrt"; "Pfsub";
+ "Pfsubs"; "Picbi"; "Picbtls"; "Pinlineasm"; "Pisel"; "Pisync"; "Plabel";
+ "Plbz"; "Plbzx"; "Pld"; "Pldbrx"; "Pldi"; "Pldx"; "Plfd"; "Plfdx"; "Plfi";
+ "Plfis"; "Plfs"; "Plfsx"; "Plha"; "Plhax"; "Plhbrx"; "Plhz"; "Plhzx";
+ "Plwarx"; "Plwbrx"; "Plwsync"; "Plwz"; "Plwzu"; "Plwzx"; "Pmbar"; "Pmfcr";
+ "Pmflr"; "Pmfspr"; "Pmr"; "Pmtctr"; "Pmtlr"; "Pmtspr"; "Pmulhd"; "Pmulhdu";
+ "Pmulhw"; "Pmulhwu"; "Pmulld"; "Pmulli"; "Pmullw"; "Pnand"; "Pnor"; "Por";
+ "Porc"; "Pori"; "Poris"; "Prldicl"; "Prldimi"; "Prldinm"; "Prlwimi";
+ "Prlwinm"; "Psld"; "Pslw"; "Psrad"; "Psradi"; "Psraw"; "Psrawi"; "Psrd";
+ "Psrw"; "Pstb"; "Pstbx"; "Pstd"; "Pstdbrx"; "Pstdu"; "Pstdx"; "Pstfd";
+ "Pstfdu"; "Pstfdx"; "Pstfs"; "Pstfsx"; "Psth"; "Psthbrx"; "Psthx"; "Pstw";
+ "Pstwbrx"; "Pstwcx_"; "Pstwu"; "Pstwux"; "Pstwx"; "Psubfc"; "Psubfe";
+ "Psubfic"; "Psubfze"; "Psync"; "Ptrap"; "Pxor"; "Pxori"; "Pxoris"]
let pp_instructions pp ic =
let ic = List.filter (fun s -> match s with
@@ -126,7 +127,7 @@ let pp_instructions pp ic =
| Pcfi_rel_offset _ -> false
| _ -> true) ic in
let instruction pp n args =
- assert (List.mem n mnemonic_names);
+ assert (StringSet.mem n mnemonic_names);
pp_jobject_start pp;
pp_jmember ~first:true pp "Instruction Name" pp_jstring n;
pp_jmember pp "Args" (pp_jarray pp_arg) args;
@@ -228,6 +229,7 @@ let pp_instructions pp ic =
| Pfres (fr1,fr2) -> instruction pp "Pfres" [Freg fr1; Freg fr2]
| Pfsel (fr1,fr2,fr3,fr4) -> instruction pp "Pfsel" [Freg fr1; Freg fr2; Freg fr3; Freg fr4]
| Pisel (ir1,ir2,ir3,cr) -> instruction pp "Pisel" [Ireg ir1; Ireg ir2; Ireg ir3; Crbit cr]
+ | Pfsel_gen _ -> assert false (* Should not occur *)
| Picbi (ir1,ir2) -> instruction pp "Picbi" [Ireg ir1; Ireg ir2]
| Picbtls (n,ir1,ir2) -> instruction pp "Picbtls" [Constant (Cint n);Ireg ir1; Ireg ir2]
| Pisync -> instruction pp "Pisync" []
@@ -250,7 +252,7 @@ let pp_instructions pp ic =
| Plhbrx (ir1,ir2,ir3) -> instruction pp "Plhbrx" [Ireg ir1; Ireg ir2; Ireg ir3]
| Plhz (ir1,c,ir2) -> instruction pp "Plhz" [Ireg ir1; Constant c; Ireg ir2]
| Plhzx (ir1,ir2,ir3) -> instruction pp "Plhzx" [Ireg ir1; Ireg ir2; Ireg ir3]
- | Pldi (ir,c) -> instruction pp "Pldi" [Ireg ir; Long c] (* FIXME Cint is too small, we need Clong *)
+ | Pldi (ir,c) -> instruction pp "Pldi" [Ireg ir; Long c]
| Plmake _ (* Should not occur *)
| Pllo _ (* Should not occur *)
| Plhi _ -> assert false (* Should not occur *)
@@ -384,8 +386,8 @@ let print_if prog sourcename =
| Some f ->
let f = Filename.concat !sdump_folder f in
let oc = open_out_bin f in
- pp_ast (formatter_of_out_channel oc) pp_instructions prog sourcename;
+ pp_ast oc pp_instructions prog sourcename;
close_out oc
let pp_mnemonics pp =
- pp_mnemonics pp mnemonic_names
+ pp_mnemonics pp (StringSet.elements mnemonic_names)
diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml
index 49a0d237..ce88778c 100644
--- a/powerpc/Asmexpand.ml
+++ b/powerpc/Asmexpand.ml
@@ -14,7 +14,7 @@
of the PPC assembly code. *)
open Camlcoq
-open Integers
+open! Integers
open AST
open Asm
open Asmexpandaux
@@ -30,20 +30,22 @@ let eref =
(* Useful constants and helper functions *)
-let _0 = Integers.Int.zero
-let _1 = Integers.Int.one
+let _0 = Int.zero
+let _1 = Int.one
let _2 = coqint_of_camlint 2l
let _4 = coqint_of_camlint 4l
let _6 = coqint_of_camlint 6l
let _8 = coqint_of_camlint 8l
+let _16 = coqint_of_camlint 16l
let _31 = coqint_of_camlint 31l
let _32 = coqint_of_camlint 32l
let _64 = coqint_of_camlint 64l
let _m1 = coqint_of_camlint (-1l)
let _m4 = coqint_of_camlint (-4l)
let _m8 = coqint_of_camlint (-8l)
+let _m16 = coqint_of_camlint (-16l)
-let _0L = Integers.Int64.zero
+let _0L = Int64.zero
let _32L = coqint_of_camlint64 32L
let _64L = coqint_of_camlint64 64L
let _m1L = coqint_of_camlint64 (-1L)
@@ -56,6 +58,15 @@ let emit_loadimm r n =
let emit_addimm rd rs n =
List.iter emit (Asmgen.addimm rd rs n [])
+(* Numbering of bits in the CR register *)
+
+let num_crbit = function
+ | CRbit_0 -> 0
+ | CRbit_1 -> 1
+ | CRbit_2 -> 2
+ | CRbit_3 -> 3
+ | CRbit_6 -> 6
+
(* Handling of annotations *)
let expand_annot_val kind txt targ args res =
@@ -77,8 +88,6 @@ let expand_annot_val kind txt targ args res =
So, use 64-bit accesses only if alignment >= 4.
Note that lfd and stfd cannot trap on ill-formed floats. *)
-
-
let offset_in_range ofs =
Int.eq (Asmgen.high_s ofs) _0
@@ -410,10 +419,21 @@ let expand_builtin_va_start r =
let expand_int64_arith conflict rl fn =
if conflict then (fn GPR0; emit (Pmr(rl, GPR0))) else fn rl
-(* Expansion of integer conditional moves (__builtin_*sel) *)
+(* Expansion of integer conditional moves (__builtin_*sel and Pisel) *)
(* The generated code works equally well with 32-bit integer registers
and with 64-bit integer registers. *)
+let expand_integer_cond_move_1 a2 a3 res =
+ (* GPR0 is -1 (all ones) if condition is true, 0 if it is false *)
+ if res <> a3 then begin
+ emit (Pand_ (res, a2, GPR0));
+ emit (Pandc (GPR0, a3, GPR0))
+ end else begin
+ emit (Pandc (res, a3, GPR0));
+ emit (Pand_ (GPR0, a2, GPR0))
+ end;
+ emit (Por (res, res, GPR0))
+
let expand_integer_cond_move a1 a2 a3 res =
if a2 = a3 then
emit (Pmr (res, a2))
@@ -423,15 +443,37 @@ let expand_integer_cond_move a1 a2 a3 res =
end else begin
(* a1 has type _Bool, hence it is 0 or 1 *)
emit (Psubfic (GPR0, a1, Cint _0));
- (* r0 = -1 (all ones) if a1 is true, r0 = 0 if a1 is false *)
- if res <> a3 then begin
- emit (Pand_ (res, a2, GPR0));
- emit (Pandc (GPR0, a3, GPR0))
- end else begin
- emit (Pandc (res, a3, GPR0));
- emit (Pand_ (GPR0, a2, GPR0))
- end;
- emit (Por (res, res, GPR0))
+ expand_integer_cond_move_1 a2 a3 res
+ end
+
+
+(* Expansion of floating point conditional moves (Pfcmove) *)
+
+let expand_float_cond_move bit a2 a3 res =
+ emit (Pmfcr GPR0);
+ emit (Prlwinm(GPR0, GPR0, Z.of_uint (4 + num_crbit bit), _8));
+ emit (Pstfdu (a3, Cint (_m16), GPR1));
+ emit (Pcfi_adjust _16);
+ emit (Pstfd (a2, Cint (_8), GPR1));
+ emit (Plfdx (res, GPR1, GPR0));
+ emit (Paddi (GPR1, GPR1, (Cint _16)));
+ emit (Pcfi_adjust _m16)
+
+
+
+(* Symmetrically, we emulate the "isel" instruction on PPC processors
+ that do not have it. *)
+
+let expand_isel bit a2 a3 res =
+ if a2 = a3 then
+ emit (Pmr (res, a2))
+ else if eref then
+ emit (Pisel (res, a2, a3, bit))
+ else begin
+ emit (Pmfcr GPR0);
+ emit (Prlwinm(GPR0, GPR0, Z.of_uint (1 + num_crbit bit), _1));
+ emit (Psubfic (GPR0, GPR0, Cint _0));
+ expand_integer_cond_move_1 a2 a3 res
end
(* Convert integer constant into GPR with corresponding number *)
@@ -512,6 +554,26 @@ let expand_builtin_inline name args res =
emit (Plabel lbl2)
| "__builtin_cmpb", [BA(IR a1); BA(IR a2)], BR(IR res) ->
emit (Pcmpb (res,a1,a2))
+ | "__builtin_bswap64", [BA_splitlong(BA(IR ah), BA(IR al))],
+ BR_splitlong(BR(IR rh), BR(IR rl))->
+ assert (not Archi.ppc64);
+ emit (Pstwu(ah, Cint _m8, GPR1));
+ emit (Pcfi_adjust _8);
+ emit (Pstwu(al, Cint _m8, GPR1));
+ emit (Pcfi_adjust _8);
+ emit (Plwbrx(rh, GPR0, GPR1));
+ emit (Paddi(GPR1, GPR1, Cint _8));
+ emit (Pcfi_adjust _m8);
+ emit (Plwbrx(rl, GPR0, GPR1));
+ emit (Paddi(GPR1, GPR1, Cint _8));
+ emit (Pcfi_adjust _m8)
+ | "__builtin_bswap64", [BA(IR a1)], BR(IR res) ->
+ assert (Archi.ppc64);
+ emit (Pstdu(a1, Cint _m8, GPR1));
+ emit (Pcfi_adjust _8);
+ emit (Pldbrx(res, GPR0, GPR1));
+ emit (Paddi(GPR1, GPR1, Cint _8));
+ emit (Pcfi_adjust _m8)
| ("__builtin_bswap" | "__builtin_bswap32"), [BA(IR a1)], BR(IR res) ->
emit (Pstwu(a1, Cint _m8, GPR1));
emit (Pcfi_adjust _8);
@@ -772,13 +834,6 @@ let set_cr6 sg =
(* Expand instructions *)
-let num_crbit = function
- | CRbit_0 -> 0
- | CRbit_1 -> 1
- | CRbit_2 -> 2
- | CRbit_3 -> 3
- | CRbit_6 -> 6
-
let expand_instruction instr =
match instr with
| Pallocframe(sz, ofs,retofs) ->
@@ -797,7 +852,7 @@ let expand_instruction instr =
if variadic then begin
emit (Pmflr GPR0);
emit (Pbl(intern_string "__compcert_va_saveregs",
- {sig_args = []; sig_res = None; sig_cc = cc_default}));
+ {sig_args = []; sig_res = Tvoid; sig_cc = cc_default}));
emit (Pmtlr GPR0)
end;
current_function_stacksize := sz;
@@ -874,6 +929,10 @@ let expand_instruction instr =
emit (Pcfi_adjust _m8);
| Pfxdp(r1, r2) ->
if r1 <> r2 then emit(Pfmr(r1, r2))
+ | Pisel(rd, r1, r2, bit) ->
+ expand_isel bit r1 r2 rd
+ | Pfsel_gen (rd, r1, r2, bit) ->
+ expand_float_cond_move bit r1 r2 rd
| Plmake(r1, rhi, rlo) ->
if r1 = rlo then
emit (Prldimi(r1, rhi, _32L, upper32))
diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v
index 8c296f0a..29e2c028 100644
--- a/powerpc/Asmgen.v
+++ b/powerpc/Asmgen.v
@@ -125,17 +125,35 @@ Definition rolm (r1 r2: ireg) (amount mask: int) (k: code) :=
Definition low64_u (n: int64) := Int64.zero_ext 16 n.
Definition low64_s (n: int64) := Int64.sign_ext 16 n.
-Definition loadimm64 (r: ireg) (n: int64) (k: code) :=
+Definition loadimm64_32s (r: ireg) (n: int64) (k: code) :=
let lo_u := low64_u n in
let lo_s := low64_s n in
- let hi_s := Int64.sign_ext 16 (Int64.shr n (Int64.repr 16)) in
+ let hi_s := low64_s (Int64.shr n (Int64.repr 16)) in
if Int64.eq n lo_s then
Paddi64 r GPR0 n :: k
- else if Int64.eq n (Int64.or (Int64.shl hi_s (Int64.repr 16)) lo_u) then
- Paddis64 r GPR0 hi_s :: Pori64 r r lo_u :: k
+ else
+ Paddis64 r GPR0 hi_s :: Pori64 r r lo_u :: k.
+
+Definition loadimm64 (r: ireg) (n: int64) (k: code) :=
+ if Int64.eq n (Int64.sign_ext 32 n) then
+ loadimm64_32s r n k
else
Pldi r n :: k.
+(** [loadimm64_notemp] is a variant of [loadimm64] that uses no temporary
+ register. The code it produces is larger and slower than the code
+ produced by [loadimm64], but it is sometimes useful to preserve all registers
+ except the destination. *)
+
+Definition loadimm64_notemp (r: ireg) (n: int64) (k: code) :=
+ if Int64.eq n (Int64.sign_ext 32 n) then
+ loadimm64_32s r n k
+ else
+ loadimm64_32s r (Int64.shru n (Int64.repr 32))
+ (Prldinm r r (Int.repr 32) (Int64.shl Int64.mone (Int64.repr 32)) ::
+ Poris64 r r (low64_u (Int64.shru n (Int64.repr 16))) ::
+ Pori64 r r (low64_u n) :: k).
+
Definition opimm64 (insn2: ireg -> ireg -> ireg -> instruction)
(insn1: ireg -> ireg -> int64 -> instruction)
(r1 r2: ireg) (n: int64) (ok: bool) (k: code) :=
@@ -261,18 +279,14 @@ Definition transl_cond
do r1 <- ireg_of a1;
if Int64.eq n (low64_s n) then
OK (Pcmpdi r1 n :: k)
- else if ireg_eq r1 GPR12 then
- OK (Pmr GPR0 GPR12 :: loadimm64 GPR12 n (Pcmpd GPR0 GPR12 :: k))
else
- OK (loadimm64 GPR0 n (Pcmpd r1 GPR0 :: k))
+ OK (loadimm64_notemp GPR0 n (Pcmpd r1 GPR0 :: k))
| Ccompluimm c n, a1 :: nil =>
do r1 <- ireg_of a1;
if Int64.eq n (low64_u n) then
OK (Pcmpldi r1 n :: k)
- else if ireg_eq r1 GPR12 then
- OK (Pmr GPR0 GPR12 :: loadimm64 GPR12 n (Pcmpld GPR0 GPR12 :: k))
else
- OK (loadimm64 GPR0 n (Pcmpld r1 GPR0 :: k))
+ OK (loadimm64_notemp GPR0 n (Pcmpld r1 GPR0 :: k))
| _, _ =>
Error(msg "Asmgen.transl_cond")
end.
@@ -390,6 +404,28 @@ Definition transl_cond_op
else Pxori r' r' (Cint Int.one) :: k)
end.
+(** Translation of a select operation *)
+
+Definition transl_select_op
+ (cond: condition) (args: list mreg) (r1 r2 rd: ireg) (k: code) :=
+ if ireg_eq r1 r2 then
+ OK (Pmr rd r1 :: k)
+ else
+ (let p := crbit_for_cond cond in
+ let r1' := if snd p then r1 else r2 in
+ let r2' := if snd p then r2 else r1 in
+ transl_cond cond args (Pisel rd r1' r2' (fst p) :: k)).
+
+Definition transl_fselect_op
+ (cond: condition) (args: list mreg) (r1 r2 rd: freg) (k: code) :=
+ if freg_eq r1 r2 then
+ OK (Pfmr rd r1 :: k)
+ else
+ (let p := crbit_for_cond cond in
+ let r1' := if snd p then r1 else r2 in
+ let r2' := if snd p then r2 else r1 in
+ transl_cond cond args (Pfsel_gen rd r1' r2' (fst p) :: k)).
+
(** Translation of the arithmetic operation [r <- op(args)].
The corresponding instructions are prepended to [k]. *)
@@ -596,6 +632,17 @@ Definition transl_op
do r1 <- ireg_of a1; do r <- ireg_of res; OK (Plhi r r1 :: k)
| Ocmp cmp, _ =>
transl_cond_op cmp args res k
+ | Osel cmp ty, a1 :: a2 :: args =>
+ match preg_of res with
+ | IR r1 =>
+ do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r <- ireg_of res;
+ transl_select_op cmp args r1 r2 r k
+ | FR r =>
+ do r1 <- freg_of a1; do r2 <- freg_of a2; do r <- freg_of res;
+ transl_fselect_op cmp args r1 r2 r k
+ | _ =>
+ Error (msg "Asmgen.Osel")
+ end
(*c PPC64 operations *)
| Olongconst n, nil =>
do r <- ireg_of res; OK (loadimm64 r n k)
@@ -736,8 +783,13 @@ Definition transl_memory_access
Error(msg "Asmgen.transl_memory_access")
end.
-Definition transl_load (chunk: memory_chunk) (addr: addressing)
- (args: list mreg) (dst: mreg) (k: code) :=
+Definition transl_load
+ (trap : trapping_mode)
+ (chunk: memory_chunk) (addr: addressing)
+ (args: list mreg) (dst: mreg) (k: code) :=
+ match trap with
+ | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on PPC")
+ | TRAP =>
match chunk with
| Mint8signed =>
do r <- ireg_of dst;
@@ -765,6 +817,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing)
transl_memory_access (Plfd r) (Plfdx r) addr args GPR12 k
| _ =>
Error (msg "Asmgen.transl_load")
+ end
end.
Definition transl_store (chunk: memory_chunk) (addr: addressing)
@@ -822,8 +875,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction)
loadind GPR1 f.(fn_link_ofs) Tint R11 k1)
| Mop op args res =>
transl_op op args res k
- | Mload chunk addr args dst =>
- transl_load chunk addr args dst k
+ | Mload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
| Mstore chunk addr args src =>
transl_store chunk addr args src k
| Mcall sig (inl r) =>
diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v
index 8ad28aea..21d5ce48 100644
--- a/powerpc/Asmgenproof.v
+++ b/powerpc/Asmgenproof.v
@@ -179,14 +179,28 @@ Proof.
Qed.
Hint Resolve rolm_label: labels.
+Remark loadimm64_32s_label:
+ forall r n k, tail_nolabel k (loadimm64_32s r n k).
+Proof.
+ unfold loadimm64_32s; intros. destruct Int64.eq; TailNoLabel.
+Qed.
+Hint Resolve loadimm64_32s_label: labels.
+
Remark loadimm64_label:
forall r n k, tail_nolabel k (loadimm64 r n k).
Proof.
- unfold loadimm64; intros.
- destruct Int64.eq. TailNoLabel. destruct Int64.eq; TailNoLabel.
+ unfold loadimm64; intros. destruct Int64.eq; TailNoLabel.
Qed.
Hint Resolve loadimm64_label: labels.
+Remark loadimm64_notemp_label:
+ forall r n k, tail_nolabel k (loadimm64_notemp r n k).
+Proof.
+ unfold loadimm64_notemp; intros. destruct Int64.eq; TailNoLabel.
+ eapply tail_nolabel_trans; TailNoLabel.
+Qed.
+Hint Resolve loadimm64_notemp_label: labels.
+
Remark loadind_label:
forall base ofs ty dst k c,
loadind base ofs ty dst k = OK c -> tail_nolabel k c.
@@ -234,6 +248,24 @@ Proof.
destruct (snd (crbit_for_cond c0)); TailNoLabel.
Qed.
+Remark transl_select_op_label:
+ forall cond args r1 r2 rd k c,
+ transl_select_op cond args r1 r2 rd k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_select_op; intros. destruct (ireg_eq r1 r2).
+ TailNoLabel.
+ eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel.
+Qed.
+
+Remark transl_fselect_op_label:
+ forall cond args r1 r2 rd k c,
+ transl_fselect_op cond args r1 r2 rd k = OK c -> tail_nolabel k c.
+Proof.
+ unfold transl_fselect_op; intros. destruct (freg_eq r1 r2).
+ TailNoLabel.
+ eapply tail_nolabel_trans. eapply transl_cond_label; eauto. TailNoLabel.
+Qed.
+
Remark transl_op_label:
forall op args r k c,
transl_op op args r k = OK c -> tail_nolabel k c.
@@ -261,6 +293,7 @@ Opaque Int.eq.
destruct Int64.eq. TailNoLabel.
destruct ireg_eq; [apply tail_nolabel_cons; unfold nolabel;auto|]; eapply tail_nolabel_trans; TailNoLabel.
- eapply transl_cond_op_label; eauto.
+- destruct (preg_of r); monadInv H. eapply transl_select_op_label; eauto. eapply transl_fselect_op_label; eauto.
Qed.
Remark transl_memory_access_label:
@@ -295,6 +328,7 @@ Proof.
eapply loadind_label; eauto.
eapply tail_nolabel_trans; eapply loadind_label; eauto.
eapply transl_op_label; eauto.
+ destruct t; try discriminate.
destruct m; monadInv H; (eapply tail_nolabel_trans; [eapply transl_memory_access_label; TailNoLabel|TailNoLabel]).
destruct m; monadInv H; eapply transl_memory_access_label; TailNoLabel.
destruct s0; monadInv H; TailNoLabel.
@@ -624,6 +658,13 @@ Opaque loadind.
split. simpl; congruence.
apply R; auto with asmgen.
+
+- (* Mload notrap *) (* isn't there a nicer way? *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
- (* Mstore *)
assert (eval_addressing tge sp addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v
index c18757b2..1b797999 100644
--- a/powerpc/Asmgenproof1.v
+++ b/powerpc/Asmgenproof1.v
@@ -16,6 +16,7 @@ Require Import Coqlib.
Require Import Errors.
Require Import Maps.
Require Import AST.
+Require Import Zbits.
Require Import Integers.
Require Import Floats.
Require Import Values.
@@ -80,13 +81,13 @@ Proof.
unfold Int.modu, Int.zero. decEq.
change 0 with (0 mod 65536).
change (Int.unsigned (Int.repr 65536)) with 65536.
- apply Int.eqmod_mod_eq. omega.
- unfold x, low_s. eapply Int.eqmod_trans.
- apply Int.eqmod_divides with Int.modulus.
+ apply eqmod_mod_eq. omega.
+ unfold x, low_s. eapply eqmod_trans.
+ apply eqmod_divides with Int.modulus.
unfold Int.sub. apply Int.eqm_unsigned_repr_l. apply Int.eqm_refl.
exists 65536. compute; auto.
replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
- apply Int.eqmod_sub. apply Int.eqmod_refl. apply Int.eqmod_sign_ext'.
+ apply eqmod_sub. apply eqmod_refl. apply Int.eqmod_sign_ext'.
compute; auto.
rewrite H0 in H. rewrite Int.add_zero in H.
rewrite <- H. unfold x. rewrite Int.sub_add_opp. rewrite Int.add_assoc.
@@ -531,6 +532,40 @@ Qed.
(** Load int64 constant. *)
+Lemma loadimm64_32s_correct:
+ forall r n k rs m,
+ exists rs',
+ exec_straight ge fn (loadimm64_32s r n k) rs m k rs' m
+ /\ rs'#r = Vlong (Int64.sign_ext 32 n)
+ /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+ unfold loadimm64_32s; intros. predSpec Int64.eq Int64.eq_spec n (low64_s n).
+ - econstructor; split; [|split].
+ + apply exec_straight_one. simpl; eauto. auto.
+ + Simpl. rewrite Int64.add_zero_l. rewrite H. unfold low64_s.
+ rewrite Int64.sign_ext_widen by omega. auto.
+ + intros; Simpl.
+ - econstructor; split; [|split].
+ + eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
+ + Simpl. simpl. f_equal. rewrite Int64.add_zero_l.
+ apply Int64.same_bits_eq; intros. assert (Int64.zwordsize = 64) by auto.
+ rewrite Int64.bits_or, Int64.bits_shl by auto.
+ unfold low64_s, low64_u.
+ rewrite Int64.bits_zero_ext by omega.
+ change (Int64.unsigned (Int64.repr 16)) with 16.
+ destruct (zlt i 16).
+ * rewrite Int64.bits_sign_ext by omega. rewrite zlt_true by omega. auto.
+ * rewrite ! Int64.bits_sign_ext by omega. rewrite orb_false_r.
+ destruct (zlt i 32).
+ ** rewrite zlt_true by omega. rewrite Int64.bits_shr by omega.
+ change (Int64.unsigned (Int64.repr 16)) with 16.
+ rewrite zlt_true by omega. f_equal; omega.
+ ** rewrite zlt_false by omega. rewrite Int64.bits_shr by omega.
+ change (Int64.unsigned (Int64.repr 16)) with 16.
+ reflexivity.
+ + intros; Simpl.
+Qed.
+
Lemma loadimm64_correct:
forall r n k rs m,
exists rs',
@@ -539,20 +574,78 @@ Lemma loadimm64_correct:
/\ forall r': preg, r' <> r -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'.
Proof.
intros. unfold loadimm64.
- set (hi_s := Int64.sign_ext 16 (Int64.shr n (Int64.repr 16))).
- set (hi' := Int64.shl hi_s (Int64.repr 16)).
- destruct (Int64.eq n (low64_s n)).
- (* addi *)
- econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- rewrite Int64.add_zero_l. intuition Simpl.
- (* addis + ori *)
- predSpec Int64.eq Int64.eq_spec n (Int64.or hi' (low64_u n)).
- econstructor; split. eapply exec_straight_two. simpl; eauto. simpl; eauto. auto. auto.
- split. Simpl. rewrite Int64.add_zero_l. simpl; f_equal; auto.
- intros. Simpl.
- (* ldi *)
- econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- intuition Simpl.
+ predSpec Int64.eq Int64.eq_spec n (Int64.sign_ext 32 n).
+ - destruct (loadimm64_32s_correct r n k rs m) as (rs' & A & B & C).
+ exists rs'; intuition auto. congruence.
+ - econstructor; split. apply exec_straight_one. simpl; eauto. auto.
+ intuition Simpl.
+Qed.
+
+(** Alternate load int64 immediate *)
+
+Lemma loadimm64_notemp_correct:
+ forall r n k rs m,
+ exists rs',
+ exec_straight ge fn (loadimm64_notemp r n k) rs m k rs' m
+ /\ rs'#r = Vlong n
+ /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'.
+Proof.
+ intros. unfold loadimm64_notemp.
+ predSpec Int64.eq Int64.eq_spec n (Int64.sign_ext 32 n).
+- destruct (loadimm64_32s_correct r n k rs m) as (rs' & A & B & C).
+ exists rs'; intuition auto. congruence.
+- set (n2 := Int64.shru n (Int64.repr 32)).
+ set (n1 := Int64.zero_ext 16 (Int64.shru n (Int64.repr 16))).
+ set (n0 := Int64.zero_ext 16 n).
+ set (mi := Int64.shl n1 (Int64.repr 16)).
+ set (hi := Int64.shl (Int64.sign_ext 32 n2) (Int64.repr 32)).
+ assert (HI: forall i, 0 <= i < Int64.zwordsize ->
+ Int64.testbit hi i = if zlt i 32 then false else Int64.testbit n i).
+ { intros. unfold hi. assert (Int64.zwordsize = 64) by auto.
+ rewrite Int64.bits_shl by auto.
+ change (Int64.unsigned (Int64.repr 32)) with 32.
+ destruct (zlt i 32); auto.
+ rewrite Int64.bits_sign_ext by omega.
+ rewrite zlt_true by omega.
+ unfold n2. rewrite Int64.bits_shru by omega.
+ change (Int64.unsigned (Int64.repr 32)) with 32.
+ rewrite zlt_true by omega. f_equal; omega.
+ }
+ assert (MI: forall i, 0 <= i < Int64.zwordsize ->
+ Int64.testbit mi i =
+ if zlt i 16 then false
+ else if zlt i 32 then Int64.testbit n i else false).
+ { intros. unfold mi. assert (Int64.zwordsize = 64) by auto.
+ rewrite Int64.bits_shl by auto.
+ change (Int64.unsigned (Int64.repr 16)) with 16.
+ destruct (zlt i 16); auto.
+ unfold n1. rewrite Int64.bits_zero_ext by omega.
+ rewrite Int64.bits_shru by omega.
+ destruct (zlt i 32).
+ rewrite zlt_true by omega.
+ change (Int64.unsigned (Int64.repr 16)) with 16.
+ rewrite zlt_true by omega. f_equal; omega.
+ rewrite zlt_false by omega. auto.
+ }
+ assert (EQ: Int64.or (Int64.or hi mi) n0 = n).
+ { apply Int64.same_bits_eq; intros.
+ rewrite ! Int64.bits_or by auto.
+ unfold n0; rewrite Int64.bits_zero_ext by omega.
+ rewrite HI, MI by auto.
+ destruct (zlt i 16).
+ rewrite zlt_true by omega. auto.
+ destruct (zlt i 32); rewrite ! orb_false_r; auto.
+ }
+ edestruct (loadimm64_32s_correct r n2) as (rs' & A & B & C).
+ econstructor; split; [|split].
+ + eapply exec_straight_trans. eexact A.
+ eapply exec_straight_three.
+ simpl. rewrite B. simpl; auto.
+ simpl; auto.
+ simpl; auto.
+ reflexivity. reflexivity. reflexivity.
+ + Simpl. simpl. f_equal. rewrite <- Int64.shl_rolm by auto. exact EQ.
+ + intros; Simpl.
Qed.
(** Add int64 immediate. *)
@@ -889,7 +982,7 @@ Lemma transl_cond_correct_1:
(if snd (crbit_for_cond cond)
then Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)
else Val.notbool (Val.of_optbool (eval_condition cond (map rs (map preg_of args)) m)))
- /\ forall r, important_preg r = true -> preg_notin r (destroyed_by_cond cond) -> rs'#r = rs#r.
+ /\ forall r, important_preg r = true -> rs'#r = rs#r.
Proof.
intros.
Opaque Int.eq.
@@ -991,20 +1084,12 @@ Opaque Int.eq.
auto with asmgen.
- (* Ccomplimm *)
rewrite <- Val.notbool_negb_3. rewrite <- Val.negate_cmpl_bool.
- destruct (Int64.eq i (low64_s i)); [|destruct (ireg_eq x GPR12)]; inv EQ0.
+ destruct (Int64.eq i (low64_s i)); inv EQ0.
+ destruct (compare_slong_spec rs (rs x) (Vlong i)) as [A [B [C D]]].
econstructor; split.
apply exec_straight_one. simpl; reflexivity. reflexivity.
split. case c0; simpl; auto. auto with asmgen.
-+ destruct (loadimm64_correct GPR12 i (Pcmpd GPR0 GPR12 :: k) (nextinstr (rs#GPR0 <- (rs#GPR12))) m) as [rs1 [EX1 [RES1 OTH1]]].
- destruct (compare_slong_spec rs1 (rs GPR12) (Vlong i)) as [A [B [C D]]].
- assert (SAME: rs1 GPR0 = rs GPR12) by (apply OTH1; eauto with asmgen).
- econstructor; split.
- eapply exec_straight_step. simpl;reflexivity. reflexivity.
- eapply exec_straight_trans. eexact EX1. eapply exec_straight_one. simpl;reflexivity. reflexivity.
- split. rewrite RES1, SAME. destruct c0; simpl; auto.
- simpl; intros. rewrite RES1, SAME. rewrite D by eauto with asmgen. rewrite OTH1 by eauto with asmgen. Simpl.
-+ destruct (loadimm64_correct GPR0 i (Pcmpd x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
++ destruct (loadimm64_notemp_correct GPR0 i (Pcmpd x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
destruct (compare_slong_spec rs1 (rs x) (Vlong i)) as [A [B [C D]]].
assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
econstructor; split.
@@ -1013,20 +1098,12 @@ Opaque Int.eq.
simpl; intros. rewrite RES1, SAME. rewrite D; eauto with asmgen.
- (* Ccompluimm *)
rewrite <- Val.notbool_negb_3. rewrite <- Val.negate_cmplu_bool.
- destruct (Int64.eq i (low64_u i)); [|destruct (ireg_eq x GPR12)]; inv EQ0.
+ destruct (Int64.eq i (low64_u i)); inv EQ0.
+ destruct (compare_ulong_spec rs m (rs x) (Vlong i)) as [A [B [C D]]].
econstructor; split.
apply exec_straight_one. simpl; reflexivity. reflexivity.
split. case c0; simpl; auto. auto with asmgen.
-+ destruct (loadimm64_correct GPR12 i (Pcmpld GPR0 GPR12 :: k) (nextinstr (rs#GPR0 <- (rs#GPR12))) m) as [rs1 [EX1 [RES1 OTH1]]].
- destruct (compare_ulong_spec rs1 m (rs GPR12) (Vlong i)) as [A [B [C D]]].
- assert (SAME: rs1 GPR0 = rs GPR12) by (apply OTH1; eauto with asmgen).
- econstructor; split.
- eapply exec_straight_step. simpl;reflexivity. reflexivity.
- eapply exec_straight_trans. eexact EX1. eapply exec_straight_one. simpl;reflexivity. reflexivity.
- split. rewrite RES1, SAME. destruct c0; simpl; auto.
- simpl; intros. rewrite RES1, SAME. rewrite D by eauto with asmgen. rewrite OTH1 by eauto with asmgen. Simpl.
-+ destruct (loadimm64_correct GPR0 i (Pcmpld x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
++ destruct (loadimm64_notemp_correct GPR0 i (Pcmpld x GPR0 :: k) rs m) as [rs1 [EX1 [RES1 OTH1]]].
destruct (compare_ulong_spec rs1 m (rs x) (Vlong i)) as [A [B [C D]]].
assert (SAME: rs1 x = rs x) by (apply OTH1; eauto with asmgen).
econstructor; split.
@@ -1045,7 +1122,7 @@ Lemma transl_cond_correct_2:
(if snd (crbit_for_cond cond)
then Val.of_bool b
else Val.notbool (Val.of_bool b))
- /\ forall r, important_preg r = true -> preg_notin r (destroyed_by_cond cond) -> rs'#r = rs#r.
+ /\ forall r, important_preg r = true -> rs'#r = rs#r.
Proof.
intros.
replace (Val.of_bool b)
@@ -1072,7 +1149,8 @@ Proof.
exploit transl_cond_correct_2. eauto.
eapply eval_condition_lessdef. eapply preg_vals; eauto. eauto. eauto.
intros [rs' [A [B C]]].
- exists rs'; split. eauto. split. auto. apply agree_undef_regs with rs; auto. intros r D.
+ exists rs'; split. eauto. split. auto.
+ apply agree_undef_regs with rs; auto. intros r D E.
apply C. apply important_data_preg_1; auto.
Qed.
@@ -1180,6 +1258,66 @@ Proof.
intuition Simpl.
rewrite RES1. destruct (eval_condition c rs ## (preg_of ## rl) m). destruct b; auto. auto.
Qed.
+
+Lemma transl_select_op_correct:
+ forall cond args ty r1 r2 rd k rs m c,
+ transl_select_op cond args r1 r2 rd k = OK c ->
+ important_preg rd = true -> important_preg r1 = true -> important_preg r2 = true ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#r1 rs#r2 ty) rs'#rd
+ /\ forall r, important_preg r = true -> r <> rd -> rs'#r = rs#r.
+Proof.
+ intros until c. intros TR IMP1 IMP2 IMP3.
+ unfold transl_select_op in TR.
+ destruct (ireg_eq r1 r2).
+ - inv TR. econstructor; split; [|split].
+ + apply exec_straight_one. simpl; eauto. auto.
+ + Simpl. destruct (eval_condition cond rs ## (preg_of ## args) m) as [[]|]; simpl; auto using Val.lessdef_normalize.
+ + intros; Simpl.
+ - destruct (transl_cond_correct_1 cond args _ rs m _ TR) as (rs1 & A & B & C).
+ set (bit := fst (crbit_for_cond cond)) in *.
+ set (dir := snd (crbit_for_cond cond)) in *.
+ set (ob := eval_condition cond rs##(preg_of##args) m) in *.
+ econstructor; split; [|split].
+ + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto.
+ reflexivity.
+ + Simpl.
+ rewrite <- (C r1), <- (C r2) by auto.
+ rewrite B, gpr_or_zero_not_zero.
+ destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize.
+ destruct dir; intros e; subst; discriminate.
+ + intros. Simpl.
+Qed.
+
+Lemma transl_fselect_op_correct:
+ forall cond args ty r1 r2 rd k rs m c,
+ transl_fselect_op cond args r1 r2 rd k = OK c ->
+ important_preg rd = true -> important_preg r1 = true -> important_preg r2 = true ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#r1 rs#r2 ty) rs'#rd
+ /\ forall r, important_preg r = true -> r <> rd -> rs'#r = rs#r.
+Proof.
+ intros until c. intros TR IMP1 IMP2 IMP3.
+ unfold transl_fselect_op in TR.
+ destruct (freg_eq r1 r2).
+ - inv TR. econstructor; split; [|split].
+ + apply exec_straight_one. simpl; eauto. auto.
+ + Simpl. destruct (eval_condition cond rs ## (preg_of ## args) m) as [[]|]; simpl; auto using Val.lessdef_normalize.
+ + intros; Simpl.
+ - destruct (transl_cond_correct_1 cond args _ rs m _ TR) as (rs1 & A & B & C).
+ set (bit := fst (crbit_for_cond cond)) in *.
+ set (dir := snd (crbit_for_cond cond)) in *.
+ set (ob := eval_condition cond rs##(preg_of##args) m) in *.
+ econstructor; split; [|split].
+ + eapply exec_straight_trans. eexact A. apply exec_straight_one. simpl; eauto.
+ reflexivity.
+ + Simpl.
+ rewrite <- (C r1), <- (C r2) by auto.
+ rewrite B. destruct dir; destruct ob as [[]|]; simpl; auto using Val.lessdef_normalize.
+ + intros. Simpl.
+Qed.
(** Translation of arithmetic operations. *)
@@ -1377,6 +1515,18 @@ Opaque Val.add.
(* Ocmp *)
- destruct (transl_cond_op_correct c0 args res k rs m c) as [rs' [A [B C]]]; auto.
exists rs'; auto with asmgen.
+ (* Osel *)
+- assert (X: forall mr r, ireg_of mr = OK r -> important_preg r = true).
+ { intros. apply ireg_of_eq in H0. apply important_data_preg_1. rewrite <- H0.
+ auto with asmgen. }
+ assert (Y: forall mr r, freg_of mr = OK r -> important_preg r = true).
+ { intros. apply freg_of_eq in H0. apply important_data_preg_1. rewrite <- H0.
+ auto with asmgen. }
+ destruct (preg_of res) eqn:RES; monadInv H; rewrite <- RES.
+ + rewrite (ireg_of_eq _ _ EQ), (ireg_of_eq _ _ EQ0), (ireg_of_eq _ _ EQ1) in *.
+ destruct (transl_select_op_correct _ _ t _ _ _ _ rs m _ EQ3) as (rs' & A & B & C); eauto.
+ + rewrite (freg_of_eq _ _ EQ), (freg_of_eq _ _ EQ0), (freg_of_eq _ _ EQ1) in *.
+ destruct (transl_fselect_op_correct _ _ t _ _ _ _ rs m _ EQ3) as (rs' & A & B & C); eauto.
Qed.
Lemma transl_op_correct:
@@ -1529,8 +1679,8 @@ Qed.
(** Translation of loads *)
Lemma transl_load_correct:
- forall chunk addr args dst k c (rs: regset) m a v,
- transl_load chunk addr args dst k = OK c ->
+ forall trap chunk addr args dst k c (rs: regset) m a v,
+ transl_load trap chunk addr args dst k = OK c ->
eval_addressing ge (rs#GPR1) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
@@ -1539,6 +1689,7 @@ Lemma transl_load_correct:
/\ forall r, r <> PC -> r <> GPR12 -> r <> GPR0 -> r <> preg_of dst -> rs' r = rs r.
Proof.
intros.
+ destruct trap; try discriminate.
assert (LD: forall v, Val.lessdef a v -> v = a).
{ intros. inv H2; auto. discriminate H1. }
assert (BASE: forall mk1 mk2 k' chunk' v',
diff --git a/powerpc/Builtins1.v b/powerpc/Builtins1.v
new file mode 100644
index 00000000..53c83d7e
--- /dev/null
+++ b/powerpc/Builtins1.v
@@ -0,0 +1,33 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Platform-specific built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Import Builtins0.
+
+Inductive platform_builtin : Type := .
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with end.
diff --git a/powerpc/CBuiltins.ml b/powerpc/CBuiltins.ml
index 11b7aef9..e29a41f1 100644
--- a/powerpc/CBuiltins.ml
+++ b/powerpc/CBuiltins.ml
@@ -18,11 +18,11 @@
open C
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list",
TArray(TInt(IUInt, []), Some 3L, [])
];
- Builtins.functions = [
+ builtin_functions = [
(* Integer arithmetic *)
"__builtin_mulhw",
(TInt(IInt, []), [TInt(IInt, []); TInt(IInt, [])], false);
diff --git a/powerpc/CSE2deps.v b/powerpc/CSE2deps.v
new file mode 100644
index 00000000..9db51bbb
--- /dev/null
+++ b/powerpc/CSE2deps.v
@@ -0,0 +1,20 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs (Int.unsigned ofs') chunk' (Int.unsigned ofs) chunk)
+ else true | _, _, _, _ => true
+ end.
diff --git a/powerpc/CSE2depsproof.v b/powerpc/CSE2depsproof.v
new file mode 100644
index 00000000..fdded9b6
--- /dev/null
+++ b/powerpc/CSE2depsproof.v
@@ -0,0 +1,135 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Lemma ptrofs_size :
+ Ptrofs.wordsize = if Archi.ptr64 then 64%nat else 32%nat.
+Proof.
+ unfold Ptrofs.wordsize.
+ unfold Wordsize_Ptrofs.wordsize.
+ trivial.
+Qed.
+
+Lemma ptrofs_modulus :
+ Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296.
+Proof.
+ unfold Ptrofs.modulus.
+ rewrite ptrofs_size.
+ destruct Archi.ptr64; reflexivity.
+Qed.
+
+Lemma ptrofs_max_unsigned :
+ Ptrofs.max_unsigned = if Archi.ptr64 then 18446744073709551615 else 4294967295.
+Proof.
+ unfold Ptrofs.max_unsigned.
+ rewrite ptrofs_modulus.
+ destruct Archi.ptr64; reflexivity.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : int.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= Int.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= Int.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : Int.unsigned ofsw + size_chunk chunkw <= Int.unsigned ofsr
+ \/ Int.unsigned ofsr + size_chunk chunkr <= Int.unsigned ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in *.
+
+ rewrite ptrofs_modulus in *.
+ simpl in *.
+ inv ADDRR.
+ inv ADDRW.
+ destruct base; try discriminate.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsr)) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i (Ptrofs.of_int ofsw)) as [OFSW | OFSW];
+ rewrite OFSW).
+ all: unfold Ptrofs.of_int.
+
+ all: repeat rewrite Ptrofs.unsigned_repr by (unfold Ptrofs.max_unsigned; rewrite ptrofs_modulus; destruct Archi.ptr64; lia).
+ all: repeat rewrite ptrofs_modulus.
+ all: destruct Archi.ptr64; intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs (Int.unsigned ofsr) chunkr (Int.unsigned ofsw) chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs (Int.unsigned i0) chunk' (Int.unsigned i) chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/powerpc/ConstpropOp.vp b/powerpc/ConstpropOp.vp
index 2d492b66..8e90a849 100644
--- a/powerpc/ConstpropOp.vp
+++ b/powerpc/ConstpropOp.vp
@@ -16,13 +16,14 @@
Require Import Coqlib Compopts.
Require Import AST Integers Floats.
Require Import Op Registers.
-Require Import ValueDomain.
+Require Import ValueDomain ValueAOp.
(** * Converting known values to constants *)
Definition const_for_result (a: aval) : option operation :=
match a with
| I n => Some(Ointconst n)
+ | L n => if Archi.ppc64 then Some (Olongconst n) else None
| F n => if Compopts.generate_float_constants tt then Some(Ofloatconst n) else None
| FS n => if Compopts.generate_float_constants tt then Some(Osingleconst n) else None
| Ptr(Gl id ofs) => Some (Oaddrsymbol id ofs)
@@ -95,6 +96,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
make_cmp_base c args vl
end.
+Definition make_select (c: condition) (ty: typ)
+ (r1 r2: reg) (args: list reg) (vl: list aval) :=
+ match resolve_branch (eval_static_condition c vl) with
+ | Some b => (Omove, (if b then r1 else r2) :: nil)
+ | None =>
+ let (c', args') := cond_strength_reduction c args vl in
+ (Osel c' ty, r1 :: r2 :: args')
+ end.
+
Definition make_addimm (n: int) (r: reg) :=
if Int.eq n Int.zero
then (Omove, r :: nil)
@@ -303,6 +313,7 @@ Nondetfunction op_strength_reduction
| Oshrl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrlimm n2 r1 r2
| Oshrlu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrluimm n2 r1 r2
| Ocmp c, args, vl => make_cmp c args vl
+ | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl
| Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
| Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
| Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v
index fe061e5b..8687b056 100644
--- a/powerpc/ConstpropOpproof.v
+++ b/powerpc/ConstpropOpproof.v
@@ -14,7 +14,7 @@
Require Import Coqlib Compopts.
Require Import Integers Floats Values Memory Globalenvs Events.
-Require Import Op Registers RTL ValueDomain.
+Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.
Local Transparent Archi.ptr64.
@@ -101,6 +101,8 @@ Proof.
destruct a; inv H; SimplVM.
- (* integer *)
exists (Vint n); auto.
+- (* long *)
+ destruct (Archi.ppc64); inv H2. exists (Vlong n); auto.
- (* float *)
destruct (generate_float_constants tt); inv H2. exists (Vfloat f); auto.
- (* single *)
@@ -211,6 +213,28 @@ Proof.
- apply make_cmp_base_correct; auto.
Qed.
+Lemma make_select_correct:
+ forall c ty r1 r2 args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_select c ty r1 r2 args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' rs##args' m = Some v
+ /\ Val.lessdef (Val.select (eval_condition c rs##args m) rs#r1 rs#r2 ty) v.
+Proof.
+ unfold make_select; intros.
+ destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB.
+- exists (if b then rs#r1 else rs#r2); split.
++ simpl. destruct b; auto.
++ destruct (eval_condition c rs##args m) as [b'|] eqn:EC; simpl; auto.
+ assert (b = b').
+ { eapply resolve_branch_sound; eauto.
+ rewrite <- EC. apply eval_static_condition_sound with bc.
+ subst vl. exact (aregs_sound _ _ _ args MATCH). }
+ subst b'. apply Val.lessdef_normalize.
+- generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ; auto.
+Qed.
+
Lemma make_addimm_correct:
forall n r,
let (op, args) := make_addimm n r in
@@ -715,6 +739,8 @@ Proof.
InvApproxRegs; SimplVM; inv H0. apply make_shrluimm_correct; auto.
(* cmp *)
inv H0. apply make_cmp_correct; auto.
+(* select *)
+ inv H0. apply make_select_correct; congruence.
(* mulf *)
InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2).
diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v
index 1de55c1a..5c9cbd4f 100644
--- a/powerpc/Conventions1.v
+++ b/powerpc/Conventions1.v
@@ -117,18 +117,16 @@ Definition dummy_float_reg := F0. (**r Used in [Coloring]. *)
We treat a function without result as a function with one integer result. *)
Definition loc_result_32 (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One R3
- | Some (Tint | Tany32) => One R3
- | Some (Tfloat | Tsingle | Tany64) => One F1
- | Some Tlong => Twolong R3 R4
+ match proj_sig_res s with
+ | Tint | Tany32 => One R3
+ | Tfloat | Tsingle | Tany64 => One F1
+ | Tlong => Twolong R3 R4
end.
Definition loc_result_64 (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One R3
- | Some (Tint | Tlong | Tany32 | Tany64) => One R3
- | Some (Tfloat | Tsingle) => One F1
+ match proj_sig_res s with
+ | Tint | Tlong | Tany32 | Tany64 => One R3
+ | Tfloat | Tsingle => One F1
end.
Definition loc_result :=
@@ -140,8 +138,8 @@ Lemma loc_result_type:
forall sig,
subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
Proof.
- intros. unfold proj_sig_res, loc_result, loc_result_32, loc_result_64, mreg_type.
- destruct Archi.ptr64 eqn:?; destruct (sig_res sig) as [[]|]; destruct Archi.ppc64; simpl; auto.
+ intros. unfold loc_result, loc_result_32, loc_result_64, mreg_type.
+ destruct Archi.ptr64 eqn:?; destruct (proj_sig_res sig); destruct Archi.ppc64; simpl; auto.
Qed.
(** The result locations are caller-save registers *)
@@ -151,7 +149,7 @@ Lemma loc_result_caller_save:
forall_rpair (fun r => is_callee_save r = false) (loc_result s).
Proof.
intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save;
- destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto.
+ destruct Archi.ptr64; destruct (proj_sig_res s); simpl; auto.
Qed.
(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
@@ -161,13 +159,13 @@ Lemma loc_result_pair:
match loc_result sg with
| One _ => True
| Twolong r1 r2 =>
- r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ r1 <> r2 /\ proj_sig_res sg = Tlong
/\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
/\ Archi.ptr64 = false
end.
Proof.
intros; unfold loc_result, loc_result_32, loc_result_64, mreg_type;
- destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; destruct Archi.ppc64; simpl; auto.
+ destruct Archi.ptr64; destruct (proj_sig_res sg); destruct Archi.ppc64; simpl; auto.
split; auto. congruence.
split; auto. congruence.
Qed.
@@ -177,7 +175,7 @@ Qed.
Lemma loc_result_exten:
forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
Proof.
- intros. unfold loc_result, loc_result_32, loc_result_64.
+ intros. unfold loc_result, loc_result_32, loc_result_64, proj_sig_res.
destruct Archi.ptr64; rewrite H; auto.
Qed.
@@ -210,7 +208,16 @@ Fixpoint loc_arguments_rec
| Some ireg =>
One (R ireg) :: loc_arguments_rec tys (ir + 1) fr ofs
end
- | (Tfloat | Tsingle | Tany64) as ty :: tys =>
+ | Tsingle as ty :: tys =>
+ match list_nth_z float_param_regs fr with
+ | None =>
+ let ty := if Archi.single_passed_as_single then Tsingle else Tany64 in
+ let ofs := align ofs (typesize ty) in
+ One (S Outgoing ofs ty) :: loc_arguments_rec tys ir fr (ofs + (typesize ty))
+ | Some freg =>
+ One (R freg) :: loc_arguments_rec tys ir (fr + 1) ofs
+ end
+ | (Tfloat | Tany64) as ty :: tys =>
match list_nth_z float_param_regs fr with
| None =>
let ofs := align ofs 2 in
@@ -238,33 +245,6 @@ Fixpoint loc_arguments_rec
Definition loc_arguments (s: signature) : list (rpair loc) :=
loc_arguments_rec s.(sig_args) 0 0 0.
-(** [size_arguments s] returns the number of [Outgoing] slots used
- to call a function with signature [s]. *)
-
-Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
- match tyl with
- | nil => ofs
- | (Tint | Tany32) :: tys =>
- match list_nth_z int_param_regs ir with
- | None => size_arguments_rec tys ir fr (ofs + 1)
- | Some ireg => size_arguments_rec tys (ir + 1) fr ofs
- end
- | (Tfloat | Tsingle | Tany64) :: tys =>
- match list_nth_z float_param_regs fr with
- | None => size_arguments_rec tys ir fr (align ofs 2 + 2)
- | Some freg => size_arguments_rec tys ir (fr + 1) ofs
- end
- | Tlong :: tys =>
- let ir := align ir 2 in
- match list_nth_z int_param_regs ir, list_nth_z int_param_regs (ir + 1) with
- | Some r1, Some r2 => size_arguments_rec tys (ir + 2) fr ofs
- | _, _ => size_arguments_rec tys ir fr (align ofs 2 + 2)
- end
- end.
-
-Definition size_arguments (s: signature) : Z :=
- size_arguments_rec s.(sig_args) 0 0 0.
-
(** Argument locations are either caller-save registers or [Outgoing]
stack slots at nonnegative offsets. *)
@@ -324,12 +304,14 @@ Opaque list_nth_z.
apply align_divides; omega. apply Z.divide_1_l. apply Z.divide_1_l.
eapply Y; eauto. omega.
- (* single *)
+ assert (ofs <= align ofs 1) by (apply align_le; omega).
assert (ofs <= align ofs 2) by (apply align_le; omega).
destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
subst. right. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. omega. apply Z.divide_1_l.
- eapply Y; eauto. omega.
+ subst. split. destruct Archi.single_passed_as_single; simpl; omega.
+ destruct Archi.single_passed_as_single; simpl; apply Z.divide_1_l.
+ eapply Y; eauto. destruct Archi.single_passed_as_single; simpl; omega.
- (* any32 *)
destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H.
subst. left. eapply list_nth_z_in; eauto.
@@ -361,107 +343,14 @@ Qed.
Hint Resolve loc_arguments_acceptable: locs.
-(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
-
-Remark size_arguments_rec_above:
- forall tyl ir fr ofs0,
- ofs0 <= size_arguments_rec tyl ir fr ofs0.
-Proof.
- induction tyl; simpl; intros.
- omega.
- destruct a.
- destruct (list_nth_z int_param_regs ir); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega.
- destruct (list_nth_z float_param_regs fr); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- set (ir' := align ir 2).
- destruct (list_nth_z int_param_regs ir'); eauto.
- destruct (list_nth_z int_param_regs (ir' + 1)); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- destruct (list_nth_z float_param_regs fr); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
- destruct (list_nth_z int_param_regs ir); eauto. apply Z.le_trans with (ofs0 + 1); auto; omega.
- destruct (list_nth_z float_param_regs fr); eauto.
- apply Z.le_trans with (align ofs0 2). apply align_le; omega.
- apply Z.le_trans with (align ofs0 2 + 2); auto; omega.
-Qed.
-
-Lemma size_arguments_above:
- forall s, size_arguments s >= 0.
-Proof.
- intros; unfold size_arguments. apply Z.le_ge.
- apply size_arguments_rec_above.
-Qed.
-
-Lemma loc_arguments_bounded:
- forall (s: signature) (ofs: Z) (ty: typ),
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
- ofs + typesize ty <= size_arguments s.
-Proof.
- intros.
- assert (forall tyl ir fr ofs0,
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_rec tyl ir fr ofs0)) ->
- ofs + typesize ty <= size_arguments_rec tyl ir fr ofs0).
-{
- induction tyl; simpl; intros.
- elim H0.
- destruct a.
-- (* int *)
- destruct (list_nth_z int_param_regs ir); destruct H0.
- congruence.
- eauto.
- inv H0. apply size_arguments_rec_above.
- eauto.
-- (* float *)
- destruct (list_nth_z float_param_regs fr); destruct H0.
- congruence.
- eauto.
- inv H0. apply size_arguments_rec_above. eauto.
-- (* long *)
- set (ir' := align ir 2) in *.
- assert (DFL:
- In (S Outgoing ofs ty) (regs_of_rpairs
- ((if Archi.ptr64
- then One (S Outgoing (align ofs0 2) Tlong)
- else Twolong (S Outgoing (align ofs0 2) Tint)
- (S Outgoing (align ofs0 2 + 1) Tint))
- :: loc_arguments_rec tyl ir' fr (align ofs0 2 + 2))) ->
- ofs + typesize ty <= size_arguments_rec tyl ir' fr (align ofs0 2 + 2)).
- { destruct Archi.ptr64; intros IN.
- - destruct IN. inv H1. apply size_arguments_rec_above. auto.
- - destruct IN. inv H1. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above.
- destruct H1. inv H1. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above.
- auto. }
- destruct (list_nth_z int_param_regs ir'); auto.
- destruct (list_nth_z int_param_regs (ir' + 1)); auto.
- destruct H0. congruence. destruct H0. congruence. eauto.
-- (* single *)
- destruct (list_nth_z float_param_regs fr); destruct H0.
- congruence.
- eauto.
- inv H0. transitivity (align ofs0 2 + 2). simpl; omega. apply size_arguments_rec_above.
- eauto.
-- (* any32 *)
- destruct (list_nth_z int_param_regs ir); destruct H0.
- congruence.
- eauto.
- inv H0. apply size_arguments_rec_above.
- eauto.
-- (* any64 *)
- destruct (list_nth_z float_param_regs fr); destruct H0.
- congruence.
- eauto.
- inv H0. apply size_arguments_rec_above. eauto.
- }
- eauto.
-Qed.
-
Lemma loc_arguments_main:
loc_arguments signature_main = nil.
Proof.
reflexivity.
Qed.
+
+(** ** Normalization of function results *)
+
+(** No normalization needed. *)
+
+Definition return_value_needs_normalization (t: rettype) := false.
diff --git a/powerpc/DuplicateOpcodeHeuristic.ml b/powerpc/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..33be79e8
--- /dev/null
+++ b/powerpc/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,27 @@
+(* open Camlcoq *)
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v
index 53d99e2f..e7c8758b 100644
--- a/powerpc/Machregs.v
+++ b/powerpc/Machregs.v
@@ -159,11 +159,7 @@ Definition register_by_name (s: string) : option mreg :=
(** ** Destroyed registers, preferred registers *)
-Definition destroyed_by_cond (cond: condition): list mreg :=
- match cond with
- | Ccomplimm _ _ | Ccompluimm _ _ => R12 :: nil
- | _ => nil
- end.
+Definition destroyed_by_cond (cond: condition): list mreg := nil.
Definition destroyed_by_op (op: operation): list mreg :=
match op with
diff --git a/powerpc/NeedOp.v b/powerpc/NeedOp.v
index 9a579cc5..5ea09bd8 100644
--- a/powerpc/NeedOp.v
+++ b/powerpc/NeedOp.v
@@ -65,6 +65,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Ofloatofwords | Omakelong => op2 (default nv)
| Olowlong | Ohighlong => op1 (default nv)
| Ocmp c => needs_of_condition c
+ | Osel c ty => nv :: nv :: needs_of_condition c
end.
Definition operation_is_redundant (op: operation) (nv: nval): bool :=
@@ -147,6 +148,10 @@ Proof.
erewrite needs_of_condition_sound by eauto.
subst v; simpl. auto with na.
subst v; auto with na.
+- destruct (eval_condition c args m) as [b|] eqn:EC.
+ erewrite needs_of_condition_sound by eauto.
+ apply select_sound; auto.
+ simpl; auto with na.
Qed.
Lemma operation_is_redundant_sound:
diff --git a/powerpc/Op.v b/powerpc/Op.v
index e6f942c1..b73cb14b 100644
--- a/powerpc/Op.v
+++ b/powerpc/Op.v
@@ -150,8 +150,9 @@ Inductive operation : Type :=
| Olowlong: operation (**r [rd = low-word(r1)] *)
| Ohighlong: operation (**r [rd = high-word(r1)] *)
(*c Boolean tests: *)
- | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
-
+ | Ocmp: condition -> operation (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Osel: condition -> typ -> operation.
+ (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *)
(** Addressing modes. [r1], [r2], etc, are the arguments to the
addressing. *)
@@ -173,7 +174,7 @@ Proof.
Defined.
Definition beq_operation: forall (x y: operation), bool.
- generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec ident_eq Float.eq_dec Float32.eq_dec eq_condition; boolean_equality.
+ generalize Int.eq_dec Int64.eq_dec Ptrofs.eq_dec ident_eq Float.eq_dec Float32.eq_dec typ_eq eq_condition; boolean_equality.
Defined.
Definition eq_operation (x y: operation): {x=y} + {x<>y}.
@@ -306,6 +307,7 @@ Definition eval_operation
| Olowlong, v1::nil => Some(Val.loword v1)
| Ohighlong, v1::nil => Some(Val.hiword v1)
| Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m))
+ | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty)
| _, _ => None
end.
@@ -455,6 +457,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Olowlong => (Tlong :: nil, Tint)
| Ohighlong => (Tlong :: nil, Tint)
| Ocmp c => (type_of_condition c, Tint)
+ | Osel c ty => (ty :: ty :: type_of_condition c, ty)
end.
Definition type_of_addressing (addr: addressing) : list typ :=
@@ -575,8 +578,33 @@ Proof with (try exact I; try reflexivity).
destruct v0...
destruct v0...
destruct (eval_condition c vl m); simpl... destruct b...
+ unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I.
Qed.
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivl | Odivu | Odivlu
+ | Oshrximm _ | Oshrxlimm _
+ | Ointoffloat | Ointuoffloat
+ | Ofloatofint | Ofloatofintu
+ | Olongoffloat
+ | Ofloatoflong => true
+ | _ => false
+ end.
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
End SOUNDNESS.
(** * Manipulating and transforming operations *)
@@ -727,22 +755,40 @@ Definition is_trivial_op (op: operation) : bool :=
(** Operations that depend on the memory state. *)
+Definition condition_depends_on_memory (c: condition) : bool :=
+ match c with
+ | Ccompu _ => true
+ | Ccompuimm _ _ => true
+ | Ccomplu _ => Archi.ppc64
+ | Ccompluimm _ _ => Archi.ppc64
+ | _ => false
+ end.
+
Definition op_depends_on_memory (op: operation) : bool :=
match op with
- | Ocmp (Ccompu _) => true
- | Ocmp (Ccompuimm _ _) => true
- | Ocmp (Ccomplu _) => Archi.ppc64
- | Ocmp (Ccompluimm _ _) => Archi.ppc64
+ | Ocmp c => condition_depends_on_memory c
+ | Osel c ty => condition_depends_on_memory c
| _ => false
end.
+Lemma condition_depends_on_memory_correct:
+ forall c args m1 m2,
+ condition_depends_on_memory c = false ->
+ eval_condition c args m1 = eval_condition c args m2.
+Proof.
+ intros. destruct c; simpl; auto; discriminate.
+Qed.
+
Lemma op_depends_on_memory_correct:
forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
op_depends_on_memory op = false ->
eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
- intros until m2. destruct op; simpl; try congruence. unfold eval_condition.
- destruct c; simpl; auto; try discriminate.
+ intros until m2. destruct op; simpl; try congruence; intros C.
+- f_equal; f_equal; apply condition_depends_on_memory_correct; auto.
+- destruct args; auto. destruct args; auto.
+ rewrite (condition_depends_on_memory_correct c args m1 m2 C).
+ auto.
Qed.
(** Global variables mentioned in an operation or addressing mode *)
@@ -989,6 +1035,9 @@ Proof.
exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
destruct b; simpl; constructor.
simpl; constructor.
+ apply Val.select_inject; auto.
+ destruct (eval_condition c vl1 m1) eqn:?; auto.
+ right; symmetry; eapply eval_condition_inj; eauto.
Qed.
Lemma eval_addressing_inj:
@@ -1007,6 +1056,21 @@ Proof.
apply Val.add_inject; auto. apply H; simpl; auto.
Qed.
+
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *;
+ inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
+Qed.
End EVAL_COMPAT.
(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
@@ -1073,6 +1137,20 @@ Proof.
rewrite <- val_inject_list_lessdef. eauto. auto.
Qed.
+
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros until vl2. intros Hlessdef Heval1.
+ destruct addr; simpl in *;
+ inv Hlessdef; trivial; try discriminate;
+ inv H0; trivial; try discriminate;
+ inv H2; trivial; try discriminate.
+Qed.
+
Lemma eval_operation_lessdef:
forall sp op vl1 vl2 v1 m1 m2,
Val.lessdef_list vl1 vl2 ->
@@ -1164,6 +1242,19 @@ Proof.
econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
Lemma eval_operation_inject:
forall op vl1 vl2 v1 m1 m2,
Val.inject_list f vl1 vl2 ->
diff --git a/powerpc/PrintOp.ml b/powerpc/PrintOp.ml
index cffaafdb..8d7f17ab 100644
--- a/powerpc/PrintOp.ml
+++ b/powerpc/PrintOp.ml
@@ -110,6 +110,10 @@ let print_operation reg pp = function
| Olowlong, [r1] -> fprintf pp "lowlong(%a)" reg r1
| Ohighlong, [r1] -> fprintf pp "highlong(%a)" reg r1
| Ocmp c, args -> print_condition reg pp (c, args)
+ | Osel (c, ty), r1::r2::args ->
+ fprintf pp "%a ?%s %a : %a"
+ (print_condition reg) (c, args)
+ (PrintAST.name_of_type ty) reg r1 reg r2
| Olongconst n, [] -> fprintf pp "%LdL" (camlint64_of_coqint n)
| Ocast32signed, [r1] -> fprintf pp "int32signed(%a)" reg r1
| Ocast32unsigned, [r1] -> fprintf pp "int32unsigned(%a)" reg r1
diff --git a/powerpc/SelectLongproof.v b/powerpc/SelectLongproof.v
index b4e48596..eba071eb 100644
--- a/powerpc/SelectLongproof.v
+++ b/powerpc/SelectLongproof.v
@@ -12,7 +12,7 @@
(** Correctness of instruction selection for 64-bit integer operations *)
-Require Import String Coqlib Maps Integers Floats Errors.
+Require Import String Coqlib Maps Zbits Integers Floats Errors.
Require Archi.
Require Import AST Values Memory Globalenvs Events.
Require Import Cminor Op CminorSel.
@@ -222,11 +222,11 @@ Proof.
change (Int64.unsigned Int64.iwordsize) with 64.
f_equal.
rewrite Int.unsigned_repr.
- apply Int.eqmod_mod_eq. omega.
- apply Int.eqmod_trans with a.
- apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr.
+ apply eqmod_mod_eq. omega.
+ apply eqmod_trans with a.
+ apply eqmod_divides with Int.modulus. apply Int.eqm_sym. apply Int.eqm_unsigned_repr.
exists (two_p (32-6)); auto.
- apply Int.eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr.
+ apply eqmod_divides with Int64.modulus. apply Int64.eqm_unsigned_repr.
exists (two_p (64-6)); auto.
assert (0 <= Int.unsigned (Int.repr a) mod 64 < 64) by (apply Z_mod_lt; omega).
assert (64 < Int.max_unsigned) by (compute; auto).
diff --git a/powerpc/SelectOp.vp b/powerpc/SelectOp.vp
index 478ce251..50b1bdd6 100644
--- a/powerpc/SelectOp.vp
+++ b/powerpc/SelectOp.vp
@@ -38,12 +38,9 @@
Require Import Coqlib.
Require Import Compopts.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import CminorSel.
-Require Import OpHelpers.
+Require Import AST Integers Floats Builtins.
+Require Import Op OpHelpers CminorSel.
+Require Archi.
Local Open Scope cminorsel_scope.
@@ -517,6 +514,19 @@ Definition singleofintu (e: expr) :=
Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil).
+(** ** Selection *)
+
+Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) :=
+ if match ty with
+ | Tint => true
+ | Tfloat => true
+ | Tsingle => true
+ | Tlong => Archi.ppc64
+ | _ => false
+ end
+ then Some (Eop (Osel cond ty) (e1 ::: e2 ::: args))
+ else None.
+
(** ** Recognition of addressing modes for load and store operations *)
Definition can_use_Aindexed2 (chunk: memory_chunk): bool :=
@@ -560,3 +570,8 @@ Definition divf_base (e1: expr) (e2: expr) :=
Definition divfs_base (e1: expr) (e2: expr) :=
Eop Odivfs (e1 ::: e2 ::: Enil).
+
+(** Platform-specific known builtins *)
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ None.
diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v
index 00b91e70..8135bad6 100644
--- a/powerpc/SelectOpproof.v
+++ b/powerpc/SelectOpproof.v
@@ -13,17 +13,10 @@
(** Correctness of instruction selection for operators *)
Require Import Coqlib.
-Require Import Maps.
+Require Import AST Integers Floats.
+Require Import Values Memory Builtins Globalenvs.
+Require Import Cminor Op CminorSel.
Require Import Compopts.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import Memory.
-Require Import Globalenvs.
-Require Import Cminor.
-Require Import Op.
-Require Import CminorSel.
Require Import SelectOp.
Require Import OpHelpers.
Require Import OpHelpersproof.
@@ -816,7 +809,7 @@ Qed.
Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
Proof.
red; intros. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm; auto. omega.
Qed.
Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
@@ -829,7 +822,7 @@ Qed.
Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
Proof.
red; intros. unfold cast16unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm; auto. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm; auto. omega.
Qed.
Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat.
@@ -1004,6 +997,27 @@ Proof.
exists (Val.singleoffloat v); split. EvalOp. inv D; auto.
Qed.
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select; intros.
+ destruct (match ty with Tint => true | Tfloat => true | Tsingle => true | Tlong => Archi.ppc64 | _ => false end); inv H.
+ exists (Val.select (Some b) v1 v2 ty); split.
+ apply eval_Eop with (v1 :: v2 :: vl).
+ constructor; auto. constructor; auto.
+ simpl. rewrite H3; auto.
+ auto.
+Qed.
+
Theorem eval_addressing:
forall le chunk a v b ofs,
eval_expr ge sp e m le a v ->
@@ -1068,4 +1082,17 @@ Proof.
intros; unfold divfs_base.
TrivialExists.
Qed.
+
+(** Platform-specific known builtins *)
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros. discriminate.
+Qed.
+
End CMCONSTR.
diff --git a/powerpc/TargetPrinter.ml b/powerpc/TargetPrinter.ml
index c1aaa55d..0f608d25 100644
--- a/powerpc/TargetPrinter.ml
+++ b/powerpc/TargetPrinter.ml
@@ -118,13 +118,22 @@ module Linux_System : SYSTEM =
let name_of_section = function
| Section_text -> ".text"
| Section_data i ->
- if i then ".data" else "COMM"
+ if i then
+ ".data"
+ else
+ common_section ~sec:".section .bss" ()
| Section_small_data i ->
- if i then ".section .sdata,\"aw\",@progbits" else "COMM"
+ if i then
+ ".section .sdata,\"aw\",@progbits"
+ else
+ common_section ~sec:".section .sbss,\"aw\",@nobits" ()
| Section_const i ->
- if i then ".rodata" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".rodata" else "COMM"
| Section_small_const i ->
- if i then ".section .sdata2,\"a\",@progbits" else "COMM"
+ if i || (not !Clflags.option_fcommon) then
+ ".section .sdata2,\"a\",@progbits"
+ else
+ "COMM"
| Section_string -> ".rodata"
| Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8"
| Section_jumptable -> ".text"
@@ -209,7 +218,7 @@ module Diab_System : SYSTEM =
let name_of_section = function
| Section_text -> ".text"
- | Section_data i -> if i then ".data" else "COMM"
+ | Section_data i -> if i then ".data" else common_section ()
| Section_small_data i -> if i then ".sdata" else ".sbss"
| Section_const _ -> ".text"
| Section_small_const _ -> ".sdata2"
@@ -331,7 +340,7 @@ module Target (System : SYSTEM):TARGET =
let ireg_or_zero oc r =
if r = GPR0 then output_string oc "0" else ireg oc r
- let preg oc = function
+ let preg_asm oc ty = function
| IR r -> ireg oc r
| FR r -> freg oc r
| _ -> assert false
@@ -604,6 +613,7 @@ module Target (System : SYSTEM):TARGET =
fprintf oc " fsel %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4
| Pisel (r1,r2,r3,cr) ->
fprintf oc " isel %a, %a, %a, %a\n" ireg r1 ireg r2 ireg r3 crbit cr
+ | Pfsel_gen _ -> assert false
| Picbi (r1,r2) ->
fprintf oc " icbi %a, %a\n" ireg r1 ireg r2
| Picbtls (n,r1,r2) ->
@@ -853,7 +863,7 @@ module Target (System : SYSTEM):TARGET =
(P.to_int kind) (extern_atom txt) args
| EF_inline_asm(txt, sg, clob) ->
fprintf oc "%s begin inline assembly\n\t" comment;
- print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
fprintf oc "%s end inline assembly\n" comment
| _ ->
assert false
diff --git a/powerpc/ValueAOp.v b/powerpc/ValueAOp.v
index f7f65e9e..a270d857 100644
--- a/powerpc/ValueAOp.v
+++ b/powerpc/ValueAOp.v
@@ -141,6 +141,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Olowlong, v1::nil => loword v1
| Ohighlong, v1::nil => hiword v1
| Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2
| _, _ => Vbot
end.
@@ -211,6 +212,7 @@ Proof.
apply rolml_sound; auto.
apply floatofwords_sound; auto.
apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+ apply select_sound; auto. eapply eval_static_condition_sound; eauto.
Qed.
End SOUNDNESS.
diff --git a/powerpc/extractionMachdep.v b/powerpc/extractionMachdep.v
index 7482435f..a3e945bf 100644
--- a/powerpc/extractionMachdep.v
+++ b/powerpc/extractionMachdep.v
@@ -34,3 +34,6 @@ Extract Constant Archi.ppc64 =>
| ""e5500"" -> true
| _ -> false
end".
+
+(* Choice of passing of single *)
+Extract Constant Archi.single_passed_as_single => "Configuration.gnu_toolchain".
diff --git a/riscV/Archi.v b/riscV/Archi.v
index a1664262..61d129d0 100644
--- a/riscV/Archi.v
+++ b/riscV/Archi.v
@@ -16,9 +16,9 @@
(** Architecture-dependent parameters for RISC-V *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
Parameter ptr64 : bool.
@@ -38,26 +38,35 @@ Qed.
floating-point operation is NaN, it is the canonical NaN. The
canonical NaN has a positive sign and all significand bits clear
except the MSB, a.k.a. the quiet bit."
- We need to extend the [choose_binop_pl] functions to account for
- this case. *)
+ Exceptions are operations manipulating signs. *)
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (false, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (false, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (false, iter_nat 22 _ xO xH).
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- false. (**r always choose first NaN *)
+Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
+ default_nan_64.
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (false, iter_nat 22 _ xO xH).
+Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
+ default_nan_32.
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- false. (**r always choose first NaN *)
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. auto. Qed.
+
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. auto. Qed.
+
+Definition fma_order {A: Type} (x y z: A) := (x, y, z).
+
+Definition fma_invalid_mul_is_nan := false.
Definition float_of_single_preserves_sNaN := false.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
float_of_single_preserves_sNaN.
(** Whether to generate position-independent code or not *)
diff --git a/riscV/Asm.v b/riscV/Asm.v
index 1d8fda11..dc410a3b 100644
--- a/riscV/Asm.v
+++ b/riscV/Asm.v
@@ -369,7 +369,7 @@ lbl:
- [Ploadfi rd fval]: similar to [Ploadli] but loads a double FP constant fval
into a float register rd.
-- [Ploadsi rd fval]: similar to [Ploadli] but loads a singe FP constant fval
+- [Ploadsi rd fval]: similar to [Ploadli] but loads a single FP constant fval
into a float register rd.
- [Pallocframe sz pos]: in the formal semantics, this
diff --git a/riscV/Asmexpand.ml b/riscV/Asmexpand.ml
index 3e734747..7e36abf8 100644
--- a/riscV/Asmexpand.ml
+++ b/riscV/Asmexpand.ml
@@ -23,7 +23,7 @@ open Asm
open Asmexpandaux
open AST
open Camlcoq
-open !Integers
+open! Integers
exception Error of string
@@ -63,44 +63,44 @@ let expand_storeind_ptr src base ofs =
let int_param_regs = [| X10; X11; X12; X13; X14; X15; X16; X17 |]
let float_param_regs = [| F10; F11; F12; F13; F14; F15; F16; F17 |]
-let rec fixup_variadic_call pos tyl =
- if pos < 8 then
+let rec fixup_variadic_call ri rf tyl =
+ if ri < 8 then
match tyl with
| [] ->
()
| (Tint | Tany32) :: tyl ->
- fixup_variadic_call (pos + 1) tyl
+ fixup_variadic_call (ri + 1) rf tyl
| Tsingle :: tyl ->
- let rs =float_param_regs.(pos)
- and rd = int_param_regs.(pos) in
+ let rs = float_param_regs.(rf)
+ and rd = int_param_regs.(ri) in
emit (Pfmvxs(rd, rs));
- fixup_variadic_call (pos + 1) tyl
+ fixup_variadic_call (ri + 1) (rf + 1) tyl
| Tlong :: tyl ->
- let pos' = if Archi.ptr64 then pos + 1 else align pos 2 + 2 in
- fixup_variadic_call pos' tyl
+ let ri' = if Archi.ptr64 then ri + 1 else align ri 2 + 2 in
+ fixup_variadic_call ri' rf tyl
| (Tfloat | Tany64) :: tyl ->
if Archi.ptr64 then begin
- let rs = float_param_regs.(pos)
- and rd = int_param_regs.(pos) in
+ let rs = float_param_regs.(rf)
+ and rd = int_param_regs.(ri) in
emit (Pfmvxd(rd, rs));
- fixup_variadic_call (pos + 1) tyl
+ fixup_variadic_call (ri + 1) (rf + 1) tyl
end else begin
- let pos = align pos 2 in
- if pos < 8 then begin
- let rs = float_param_regs.(pos)
- and rd1 = int_param_regs.(pos)
- and rd2 = int_param_regs.(pos + 1) in
+ let ri = align ri 2 in
+ if ri < 8 then begin
+ let rs = float_param_regs.(rf)
+ and rd1 = int_param_regs.(ri)
+ and rd2 = int_param_regs.(ri + 1) in
emit (Paddiw(X2, X X2, Integers.Int.neg _16));
emit (Pfsd(rs, X2, Ofsimm _0));
emit (Plw(rd1, X2, Ofsimm _0));
emit (Plw(rd2, X2, Ofsimm _4));
emit (Paddiw(X2, X X2, _16));
- fixup_variadic_call (pos + 2) tyl
+ fixup_variadic_call (ri + 2) (rf + 1) tyl
end
end
let fixup_call sg =
- if sg.sig_cc.cc_vararg then fixup_variadic_call 0 sg.sig_args
+ if sg.sig_cc.cc_vararg then fixup_variadic_call 0 0 sg.sig_args
(* Handling of annotations *)
@@ -483,7 +483,7 @@ let expand_instruction instr =
emit (Pmv (X30, X2));
if sg.sig_cc.cc_vararg then begin
let n = arguments_size sg in
- let extra_sz = if n >= 8 then 0 else align 16 ((8 - n) * wordsize) in
+ let extra_sz = if n >= 8 then 0 else align ((8 - n) * wordsize) 16 in
let full_sz = Z.add sz (Z.of_uint extra_sz) in
expand_addptrofs X2 X2 (Ptrofs.repr (Z.neg full_sz));
expand_storeind_ptr X30 X2 ofs;
@@ -501,7 +501,7 @@ let expand_instruction instr =
let extra_sz =
if sg.sig_cc.cc_vararg then begin
let n = arguments_size sg in
- if n >= 8 then 0 else align 16 ((8 - n) * wordsize)
+ if n >= 8 then 0 else align ((8 - n) * wordsize) 16
end else 0 in
expand_addptrofs X2 X2 (Ptrofs.repr (Z.add sz (Z.of_uint extra_sz)))
diff --git a/riscV/Asmgen.v b/riscV/Asmgen.v
index a704ed74..b431d63d 100644
--- a/riscV/Asmgen.v
+++ b/riscV/Asmgen.v
@@ -25,6 +25,8 @@ Require Import Op Locations Mach Asm.
Local Open Scope string_scope.
Local Open Scope error_monad_scope.
+Definition time {A B: Type} (name: string) (f: A -> B) : A -> B := f.
+
(** The code generation functions take advantage of several
characteristics of the [Mach] code generated by earlier passes of the
compiler, mostly that argument and result registers are of the correct
@@ -503,11 +505,16 @@ Definition transl_op
OK (Psrliw rd rs n :: k)
| Oshrximm n, a1 :: nil =>
do rd <- ireg_of res; do rs <- ireg_of a1;
- OK (if Int.eq n Int.zero then Pmv rd rs :: k else
- Psraiw X31 rs (Int.repr 31) ::
- Psrliw X31 X31 (Int.sub Int.iwordsize n) ::
- Paddw X31 rs X31 ::
- Psraiw rd X31 n :: k)
+ OK (if Int.eq n Int.zero
+ then Pmv rd rs :: k
+ else if Int.eq n Int.one
+ then Psrliw X31 rs (Int.repr 31) ::
+ Paddw X31 rs X31 ::
+ Psraiw rd X31 Int.one :: k
+ else Psraiw X31 rs (Int.repr 31) ::
+ Psrliw X31 X31 (Int.sub Int.iwordsize n) ::
+ Paddw X31 rs X31 ::
+ Psraiw rd X31 n :: k)
(* [Omakelong], [Ohighlong] should not occur *)
| Olowlong, a1 :: nil =>
@@ -592,11 +599,16 @@ Definition transl_op
OK (Psrlil rd rs n :: k)
| Oshrxlimm n, a1 :: nil =>
do rd <- ireg_of res; do rs <- ireg_of a1;
- OK (if Int.eq n Int.zero then Pmv rd rs :: k else
- Psrail X31 rs (Int.repr 63) ::
- Psrlil X31 X31 (Int.sub Int64.iwordsize' n) ::
- Paddl X31 rs X31 ::
- Psrail rd X31 n :: k)
+ OK (if Int.eq n Int.zero
+ then Pmv rd rs :: k
+ else if Int.eq n Int.one
+ then Psrlil X31 rs (Int.repr 63) ::
+ Paddl X31 rs X31 ::
+ Psrail rd X31 Int.one :: k
+ else Psrail X31 rs (Int.repr 63) ::
+ Psrlil X31 X31 (Int.sub Int64.iwordsize' n) ::
+ Paddl X31 rs X31 ::
+ Psrail rd X31 n :: k)
| Onegf, a1 :: nil =>
do rd <- freg_of res; do rs <- freg_of a1;
@@ -770,9 +782,13 @@ Definition transl_memory_access
Error(msg "Asmgen.transl_memory_access")
end.
-Definition transl_load (chunk: memory_chunk) (addr: addressing)
+Definition transl_load (trap : trapping_mode)
+ (chunk: memory_chunk) (addr: addressing)
(args: list mreg) (dst: mreg) (k: code) :=
- match chunk with
+ match trap with
+ | NOTRAP => Error (msg "Asmgen.transl_load non-trapping loads unsupported on Arm")
+ | TRAP =>
+ match chunk with
| Mint8signed =>
do r <- ireg_of dst;
transl_memory_access (Plb r) addr args k
@@ -799,6 +815,7 @@ Definition transl_load (chunk: memory_chunk) (addr: addressing)
transl_memory_access (Pfld r) addr args k
| _ =>
Error (msg "Asmgen.transl_load")
+ end
end.
Definition transl_store (chunk: memory_chunk) (addr: addressing)
@@ -848,8 +865,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction)
else loadind_ptr SP f.(fn_link_ofs) X30 c)
| Mop op args res =>
transl_op op args res k
- | Mload chunk addr args dst =>
- transl_load chunk addr args dst k
+ | Mload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
| Mstore chunk addr args src =>
transl_store chunk addr args src k
| Mcall sig (inl r) =>
diff --git a/riscV/Asmgenproof.v b/riscV/Asmgenproof.v
index 5ec57886..8e9f022c 100644
--- a/riscV/Asmgenproof.v
+++ b/riscV/Asmgenproof.v
@@ -285,12 +285,12 @@ Opaque Int.eq.
- apply opimm32_label; intros; exact I.
- apply opimm32_label; intros; exact I.
- apply opimm32_label; intros; exact I.
-- destruct (Int.eq n Int.zero); TailNoLabel.
+- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel.
- apply opimm64_label; intros; exact I.
- apply opimm64_label; intros; exact I.
- apply opimm64_label; intros; exact I.
- apply opimm64_label; intros; exact I.
-- destruct (Int.eq n Int.zero); TailNoLabel.
+- destruct (Int.eq n Int.zero); try destruct (Int.eq n Int.one); TailNoLabel.
- eapply transl_cond_op_label; eauto.
Qed.
@@ -359,7 +359,7 @@ Proof.
- destruct ep. eapply loadind_label; eauto.
eapply tail_nolabel_trans. apply loadind_ptr_label. eapply loadind_label; eauto.
- eapply transl_op_label; eauto.
-- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
+- destruct t; (try discriminate); destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
- destruct m; monadInv H; eapply transl_memory_access_label; eauto; intros; exact I.
- destruct s0; monadInv H; TailNoLabel.
- destruct s0; monadInv H; (eapply tail_nolabel_trans; [eapply make_epilogue_label|TailNoLabel]).
@@ -725,6 +725,12 @@ Local Transparent destroyed_by_op.
intros; auto with asmgen.
simpl; congruence.
+- (* Mload notrap *) (* isn't there a nicer way? *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
- (* Mstore *)
assert (eval_addressing tge sp addr (map rs args) = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
diff --git a/riscV/Asmgenproof1.v b/riscV/Asmgenproof1.v
index 7f070c12..8678a5dc 100644
--- a/riscV/Asmgenproof1.v
+++ b/riscV/Asmgenproof1.v
@@ -16,7 +16,7 @@
(* *********************************************************************)
Require Import Coqlib Errors Maps.
-Require Import AST Integers Floats Values Memory Globalenvs.
+Require Import AST Zbits Integers Floats Values Memory Globalenvs.
Require Import Op Locations Mach Conventions.
Require Import Asm Asmgen Asmgenproof0.
@@ -33,16 +33,16 @@ Proof.
predSpec Int.eq Int.eq_spec n lo.
- auto.
- set (m := Int.sub n lo).
- assert (A: Int.eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto).
- assert (B: Int.eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0).
+ assert (A: eqmod (two_p 12) (Int.unsigned lo) (Int.unsigned n)) by (apply Int.eqmod_sign_ext'; compute; auto).
+ assert (B: eqmod (two_p 12) (Int.unsigned n - Int.unsigned lo) 0).
{ replace 0 with (Int.unsigned n - Int.unsigned n) by omega.
- auto using Int.eqmod_sub, Int.eqmod_refl. }
- assert (C: Int.eqmod (two_p 12) (Int.unsigned m) 0).
- { apply Int.eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto.
- apply Int.eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
+ auto using eqmod_sub, eqmod_refl. }
+ assert (C: eqmod (two_p 12) (Int.unsigned m) 0).
+ { apply eqmod_trans with (Int.unsigned n - Int.unsigned lo); auto.
+ apply eqmod_divides with Int.modulus. apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
exists (two_p (32-12)); auto. }
assert (D: Int.modu m (Int.repr 4096) = Int.zero).
- { apply Int.eqmod_mod_eq in C. unfold Int.modu.
+ { apply eqmod_mod_eq in C. unfold Int.modu.
change (Int.unsigned (Int.repr 4096)) with (two_p 12). rewrite C.
reflexivity.
apply two_p_gt_ZERO; omega. }
@@ -400,22 +400,6 @@ Ltac ArgsInv :=
| [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *
end).
-Inductive exec_straight_opt: code -> regset -> mem -> code -> regset -> mem -> Prop :=
- | exec_straight_opt_refl: forall c rs m,
- exec_straight_opt c rs m c rs m
- | exec_straight_opt_intro: forall c1 rs1 m1 c2 rs2 m2,
- exec_straight ge fn c1 rs1 m1 c2 rs2 m2 ->
- exec_straight_opt c1 rs1 m1 c2 rs2 m2.
-
-Remark exec_straight_opt_right:
- forall c3 rs3 m3 c1 rs1 m1 c2 rs2 m2,
- exec_straight_opt c1 rs1 m1 c2 rs2 m2 ->
- exec_straight ge fn c2 rs2 m2 c3 rs3 m3 ->
- exec_straight ge fn c1 rs1 m1 c3 rs3 m3.
-Proof.
- destruct 1; intros. auto. eapply exec_straight_trans; eauto.
-Qed.
-
Lemma transl_cbranch_correct_1:
forall cond args lbl k c m ms b sp rs m',
transl_cbranch cond args lbl k = OK c ->
@@ -423,7 +407,7 @@ Lemma transl_cbranch_correct_1:
agree ms sp rs ->
Mem.extends m m' ->
exists rs', exists insn,
- exec_straight_opt c rs m' (insn :: k) rs' m'
+ exec_straight_opt ge fn c rs m' (insn :: k) rs' m'
/\ exec_instr ge fn insn rs' m' = eval_branch fn lbl rs' m' (Some b)
/\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r.
Proof.
@@ -518,7 +502,7 @@ Lemma transl_cbranch_correct_true:
agree ms sp rs ->
Mem.extends m m' ->
exists rs', exists insn,
- exec_straight_opt c rs m' (insn :: k) rs' m'
+ exec_straight_opt ge fn c rs m' (insn :: k) rs' m'
/\ exec_instr ge fn insn rs' m' = goto_label fn lbl rs' m'
/\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r.
Proof.
@@ -1051,17 +1035,23 @@ Opaque Int.eq.
intros (rs' & A & B & C).
exists rs'; split; eauto. rewrite B; auto with asmgen.
- (* shrximm *)
- clear H. exploit Val.shrx_shr_2; eauto. intros E; subst v; clear EV.
+ clear H. exploit Val.shrx_shr_3; eauto. intros E; subst v; clear EV.
destruct (Int.eq n Int.zero).
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
split; intros; Simpl.
-+ change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n).
- econstructor; split.
- eapply exec_straight_step. simpl; reflexivity. auto.
- eapply exec_straight_step. simpl; reflexivity. auto.
- eapply exec_straight_step. simpl; reflexivity. auto.
- apply exec_straight_one. simpl; reflexivity. auto.
- split; intros; Simpl.
++ destruct (Int.eq n Int.one).
+ * econstructor; split.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ apply exec_straight_one. simpl; reflexivity. auto.
+ split; intros; Simpl.
+ * change (Int.repr 32) with Int.iwordsize. set (n' := Int.sub Int.iwordsize n).
+ econstructor; split.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ apply exec_straight_one. simpl; reflexivity. auto.
+ split; intros; Simpl.
- (* longofintu *)
econstructor; split.
eapply exec_straight_three. simpl; eauto. simpl; eauto. simpl; eauto. auto. auto. auto.
@@ -1086,17 +1076,24 @@ Opaque Int.eq.
intros (rs' & A & B & C).
exists rs'; split; eauto. rewrite B; auto with asmgen.
- (* shrxlimm *)
- clear H. exploit Val.shrxl_shrl_2; eauto. intros E; subst v; clear EV.
+ clear H. exploit Val.shrxl_shrl_3; eauto. intros E; subst v; clear EV.
destruct (Int.eq n Int.zero).
+ econstructor; split. apply exec_straight_one. simpl; eauto. auto.
split; intros; Simpl.
-+ change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n).
- econstructor; split.
- eapply exec_straight_step. simpl; reflexivity. auto.
- eapply exec_straight_step. simpl; reflexivity. auto.
- eapply exec_straight_step. simpl; reflexivity. auto.
- apply exec_straight_one. simpl; reflexivity. auto.
- split; intros; Simpl.
++ destruct (Int.eq n Int.one).
+ * econstructor; split.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ apply exec_straight_one. simpl; reflexivity. auto.
+ split; intros; Simpl.
+
+ * change (Int.repr 64) with Int64.iwordsize'. set (n' := Int.sub Int64.iwordsize' n).
+ econstructor; split.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ eapply exec_straight_step. simpl; reflexivity. auto.
+ apply exec_straight_one. simpl; reflexivity. auto.
+ split; intros; Simpl.
- (* cond *)
exploit transl_cond_op_correct; eauto. intros (rs' & A & B & C).
exists rs'; split. eexact A. eauto with asmgen.
@@ -1108,7 +1105,7 @@ Lemma indexed_memory_access_correct:
forall mk_instr base ofs k rs m,
base <> X31 ->
exists base' ofs' rs',
- exec_straight_opt (indexed_memory_access mk_instr base ofs k) rs m
+ exec_straight_opt ge fn (indexed_memory_access mk_instr base ofs k) rs m
(mk_instr base' ofs' :: k) rs' m
/\ Val.offset_ptr rs'#base' (eval_offset ge ofs') = Val.offset_ptr rs#base ofs
/\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r.
@@ -1258,7 +1255,7 @@ Lemma transl_memory_access_correct:
transl_memory_access mk_instr addr args k = OK c ->
eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some v ->
exists base ofs rs',
- exec_straight_opt c rs m (mk_instr base ofs :: k) rs' m
+ exec_straight_opt ge fn c rs m (mk_instr base ofs :: k) rs' m
/\ Val.offset_ptr rs'#base (eval_offset ge ofs) = v
/\ forall r, r <> PC -> r <> X31 -> rs'#r = rs#r.
Proof.
@@ -1318,8 +1315,8 @@ Proof.
Qed.
Lemma transl_load_correct:
- forall chunk addr args dst k c (rs: regset) m a v,
- transl_load chunk addr args dst k = OK c ->
+ forall trap chunk addr args dst k c (rs: regset) m a v,
+ transl_load trap chunk addr args dst k = OK c ->
eval_addressing ge rs#SP addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
@@ -1327,7 +1324,8 @@ Lemma transl_load_correct:
/\ rs'#(preg_of dst) = v
/\ forall r, r <> PC -> r <> X31 -> r <> preg_of dst -> rs'#r = rs#r.
Proof.
- intros until v; intros TR EV LOAD.
+ intros until v; intros TR EV LOAD.
+ destruct trap; try (simpl in *; discriminate).
assert (A: exists mk_instr,
transl_memory_access mk_instr addr args k = OK c
/\ forall base ofs rs,
diff --git a/riscV/Builtins1.v b/riscV/Builtins1.v
new file mode 100644
index 00000000..53c83d7e
--- /dev/null
+++ b/riscV/Builtins1.v
@@ -0,0 +1,33 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Platform-specific built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Import Builtins0.
+
+Inductive platform_builtin : Type := .
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with end.
diff --git a/riscV/CBuiltins.ml b/riscV/CBuiltins.ml
index 0c981d11..a2087cb7 100644
--- a/riscV/CBuiltins.ml
+++ b/riscV/CBuiltins.ml
@@ -18,16 +18,13 @@
open C
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list", TPtr(TVoid [], [])
];
- Builtins.functions = [
+ builtin_functions = [
(* Synchronization *)
"__builtin_fence",
(TVoid [], [], false);
- (* Integer arithmetic *)
- "__builtin_bswap64",
- (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
(* Float arithmetic *)
"__builtin_fmadd",
(TFloat(FDouble, []),
diff --git a/riscV/CSE2deps.v b/riscV/CSE2deps.v
new file mode 100644
index 00000000..8ab9242a
--- /dev/null
+++ b/riscV/CSE2deps.v
@@ -0,0 +1,20 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk)
+ else true | _, _, _, _ => true
+ end.
diff --git a/riscV/CSE2depsproof.v b/riscV/CSE2depsproof.v
new file mode 100644
index 00000000..a3811e78
--- /dev/null
+++ b/riscV/CSE2depsproof.v
@@ -0,0 +1,127 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Lemma ptrofs_size :
+ Ptrofs.wordsize = (if Archi.ptr64 then 64 else 32)%nat.
+Proof.
+ unfold Ptrofs.wordsize.
+ unfold Wordsize_Ptrofs.wordsize.
+ trivial.
+Qed.
+
+Lemma ptrofs_modulus :
+ Ptrofs.modulus = if Archi.ptr64 then 18446744073709551616 else 4294967296.
+Proof.
+ unfold Ptrofs.modulus.
+ rewrite ptrofs_size.
+ destruct Archi.ptr64; reflexivity.
+Qed.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : ptrofs.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= Ptrofs.unsigned ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= Ptrofs.unsigned ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : Ptrofs.unsigned ofsw + size_chunk chunkw <= Ptrofs.unsigned ofsr
+ \/ Ptrofs.unsigned ofsr + size_chunk chunkr <= Ptrofs.unsigned ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in *.
+
+ rewrite ptrofs_modulus in *.
+ simpl in *.
+ inv ADDRR.
+ inv ADDRW.
+ destruct base; try discriminate.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i ofsr) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i ofsw) as [OFSW | OFSW];
+ rewrite OFSW).
+ all: try rewrite ptrofs_modulus in *.
+ all: destruct Archi.ptr64.
+
+ all: intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs (Ptrofs.unsigned i0) chunk' (Ptrofs.unsigned i) chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away with (F:=F) (V:=V) (genv:=genv) (sp:=sp); eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/riscV/Conventions1.v b/riscV/Conventions1.v
index df7ddfd2..17326139 100644
--- a/riscV/Conventions1.v
+++ b/riscV/Conventions1.v
@@ -105,7 +105,9 @@ Definition is_float_reg (r: mreg) :=
of function arguments), but this leaves much liberty in choosing actual
locations. To ensure binary interoperability of code generated by our
compiler with libraries compiled by another compiler, we
- implement the standard RISC-V conventions. *)
+ implement the standard RISC-V conventions as found here:
+ https://github.com/riscv/riscv-elf-psabi-doc/blob/master/riscv-elf.md
+*)
(** ** Location of function result *)
@@ -115,11 +117,10 @@ Definition is_float_reg (r: mreg) :=
with one integer result. *)
Definition loc_result (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One R10
- | Some (Tint | Tany32) => One R10
- | Some (Tfloat | Tsingle | Tany64) => One F10
- | Some Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10
+ match proj_sig_res s with
+ | Tint | Tany32 => One R10
+ | Tfloat | Tsingle | Tany64 => One F10
+ | Tlong => if Archi.ptr64 then One R10 else Twolong R11 R10
end.
(** The result registers have types compatible with that given in the signature. *)
@@ -128,8 +129,8 @@ Lemma loc_result_type:
forall sig,
subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
Proof.
- intros. unfold proj_sig_res, loc_result, mreg_type;
- destruct (sig_res sig) as [[]|]; auto; destruct Archi.ptr64; auto.
+ intros. unfold loc_result, mreg_type;
+ destruct (proj_sig_res sig); auto; destruct Archi.ptr64; auto.
Qed.
(** The result locations are caller-save registers *)
@@ -139,7 +140,7 @@ Lemma loc_result_caller_save:
forall_rpair (fun r => is_callee_save r = false) (loc_result s).
Proof.
intros. unfold loc_result, is_callee_save;
- destruct (sig_res s) as [[]|]; simpl; auto; destruct Archi.ptr64; simpl; auto.
+ destruct (proj_sig_res s); simpl; auto; destruct Archi.ptr64; simpl; auto.
Qed.
(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
@@ -149,13 +150,13 @@ Lemma loc_result_pair:
match loc_result sg with
| One _ => True
| Twolong r1 r2 =>
- r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ r1 <> r2 /\ proj_sig_res sg = Tlong
/\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
/\ Archi.ptr64 = false
end.
Proof.
intros.
- unfold loc_result; destruct (sig_res sg) as [[]|]; auto.
+ unfold loc_result; destruct (proj_sig_res sg); auto.
unfold mreg_type; destruct Archi.ptr64; auto.
split; auto. congruence.
Qed.
@@ -165,43 +166,37 @@ Qed.
Lemma loc_result_exten:
forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
Proof.
- intros. unfold loc_result. rewrite H; auto.
+ intros. unfold loc_result, proj_sig_res. rewrite H; auto.
Qed.
(** ** Location of function arguments *)
-(** The RISC-V ABI states the following convention for passing arguments
+(** The RISC-V ABI states the following conventions for passing arguments
to a function:
-- Arguments are passed in registers when possible.
-
-- Up to eight integer registers (ai: int_param_regs) and up to eight
- floating-point registers (fai: float_param_regs) are used for this
- purpose.
-
-- If the arguments to a function are conceptualized as fields of a C
- struct, each with pointer alignment, the argument registers are a
- shadow of the first eight pointer-words of that struct. If argument
- i < 8 is a floating-point type, it is passed in floating-point
- register fa_i; otherwise, it is passed in integer register a_i.
-
-- When primitive arguments twice the size of a pointer-word are passed
- on the stack, they are naturally aligned. When they are passed in the
- integer registers, they reside in an aligned even-odd register pair,
- with the even register holding the least-significant bits.
-
-- Floating-point arguments to variadic functions (except those that
- are explicitly named in the parameter list) are passed in integer
- registers.
-
-- The portion of the conceptual struct that is not passed in argument
- registers is passed on the stack. The stack pointer sp points to the
- first argument not passed in a register.
-
-The bit about variadic functions doesn't quite fit CompCert's model.
-We do our best by passing the FP arguments in registers, as usual,
-and reserving the corresponding integer registers, so that fixup
-code can be introduced in the Asmexpand pass.
+- RV64, not variadic: pass the first 8 integer arguments in
+ integer registers (a1...a8: int_param_regs), the first 8 FP arguments
+ in FP registers (fa1...fa8: float_param_regs), and the remaining
+ arguments on the stack, in 8-byte slots.
+
+- RV32, not variadic: same, but arguments of 64-bit integer type
+ are passed in two consecutive integer registers (a(i), a(i+1))
+ or in a(8) and on a 32-bit word on the stack. Stack-allocated
+ arguments are aligned to their natural alignment.
+
+- RV64, variadic: pass the first 8 arguments in integer registers
+ (a1...a8), including FP arguments; pass the remaining arguments on
+ the stack, in 8-byte slots.
+
+- RV32, variadic: same, but arguments of 64-bit types (integers as well
+ as floats) are passed in two consecutive aligned integer registers
+ (a(2i), a(2i+1)).
+
+The passing of FP arguments to variadic functions in integer registers
+doesn't quite fit CompCert's model. We do our best by passing the FP
+arguments in registers, as usual, and reserving the corresponding
+integer registers, so that fixup code can be introduced in the
+Asmexpand pass.
*)
Definition int_param_regs :=
@@ -209,80 +204,84 @@ Definition int_param_regs :=
Definition float_param_regs :=
F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: F16 :: F17 :: nil.
-Definition one_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ)
- (rec: Z -> Z -> list (rpair loc)) :=
- match list_nth_z regs rn with
+Definition int_arg (ri rf ofs: Z) (ty: typ)
+ (rec: Z -> Z -> Z -> list (rpair loc)) :=
+ match list_nth_z int_param_regs ri with
| Some r =>
- One(R r) :: rec (rn + 1) ofs
+ One(R r) :: rec (ri + 1) rf ofs
| None =>
- let ofs := align ofs (typealign ty) in
- One(S Outgoing ofs ty) :: rec rn (ofs + (if Archi.ptr64 then 2 else typesize ty))
+ let ofs := align ofs (typesize ty) in
+ One(S Outgoing ofs ty)
+ :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty))
end.
-Definition two_args (regs: list mreg) (rn: Z) (ofs: Z)
- (rec: Z -> Z -> list (rpair loc)) :=
- let rn := align rn 2 in
- match list_nth_z regs rn, list_nth_z regs (rn + 1) with
- | Some r1, Some r2 =>
- Twolong (R r2) (R r1) :: rec (rn + 2) ofs
- | _, _ =>
- let ofs := align ofs 2 in
- Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) ::
- rec rn (ofs + 2)
+Definition float_arg (va: bool) (ri rf ofs: Z) (ty: typ)
+ (rec: Z -> Z -> Z -> list (rpair loc)) :=
+ match list_nth_z float_param_regs rf with
+ | Some r =>
+ if va then
+ (let ri' := (* reserve 1 or 2 aligned integer registers *)
+ if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2 in
+ if zle ri' 8 then
+ (* we have enough integer registers, put argument in FP reg
+ and fixup code will put it in one or two integer regs *)
+ One (R r) :: rec ri' (rf + 1) ofs
+ else
+ (* we are out of integer registers, pass argument on stack *)
+ let ofs := align ofs (typesize ty) in
+ One(S Outgoing ofs ty)
+ :: rec ri' rf (ofs + (if Archi.ptr64 then 2 else typesize ty)))
+ else
+ One (R r) :: rec ri (rf + 1) ofs
+ | None =>
+ let ofs := align ofs (typesize ty) in
+ One(S Outgoing ofs ty)
+ :: rec ri rf (ofs + (if Archi.ptr64 then 2 else typesize ty))
end.
-Definition hybrid_arg (regs: list mreg) (rn: Z) (ofs: Z) (ty: typ)
- (rec: Z -> Z -> list (rpair loc)) :=
- let rn := align rn 2 in
- match list_nth_z regs rn with
- | Some r =>
- One (R r) :: rec (rn + 2) ofs
- | None =>
+Definition split_long_arg (va: bool) (ri rf ofs: Z)
+ (rec: Z -> Z -> Z -> list (rpair loc)) :=
+ let ri := if va then align ri 2 else ri in
+ match list_nth_z int_param_regs ri, list_nth_z int_param_regs (ri + 1) with
+ | Some r1, Some r2 =>
+ Twolong (R r2) (R r1) :: rec (ri + 2) rf ofs
+ | Some r1, None =>
+ Twolong (S Outgoing ofs Tint) (R r1) :: rec (ri + 1) rf (ofs + 1)
+ | None, _ =>
let ofs := align ofs 2 in
- One (S Outgoing ofs ty) :: rec rn (ofs + 2)
+ Twolong (S Outgoing (ofs + 1) Tint) (S Outgoing ofs Tint) ::
+ rec ri rf (ofs + 2)
end.
Fixpoint loc_arguments_rec (va: bool)
- (tyl: list typ) (r ofs: Z) {struct tyl} : list (rpair loc) :=
+ (tyl: list typ) (ri rf ofs: Z) {struct tyl} : list (rpair loc) :=
match tyl with
| nil => nil
| (Tint | Tany32) as ty :: tys =>
- one_arg int_param_regs r ofs ty (loc_arguments_rec va tys)
+ (* pass in one integer register or on stack *)
+ int_arg ri rf ofs ty (loc_arguments_rec va tys)
| Tsingle as ty :: tys =>
- one_arg float_param_regs r ofs ty (loc_arguments_rec va tys)
+ (* pass in one FP register or on stack.
+ If vararg, reserve 1 integer register. *)
+ float_arg va ri rf ofs ty (loc_arguments_rec va tys)
| Tlong as ty :: tys =>
- if Archi.ptr64
- then one_arg int_param_regs r ofs ty (loc_arguments_rec va tys)
- else two_args int_param_regs r ofs (loc_arguments_rec va tys)
+ if Archi.ptr64 then
+ (* pass in one integer register or on stack *)
+ int_arg ri rf ofs ty (loc_arguments_rec va tys)
+ else
+ (* pass in register pair or on stack; align register pair if vararg *)
+ split_long_arg va ri rf ofs(loc_arguments_rec va tys)
| (Tfloat | Tany64) as ty :: tys =>
- if va && negb Archi.ptr64
- then hybrid_arg float_param_regs r ofs ty (loc_arguments_rec va tys)
- else one_arg float_param_regs r ofs ty (loc_arguments_rec va tys)
+ (* pass in one FP register or on stack.
+ If vararg, reserve 1 or 2 integer registers. *)
+ float_arg va ri rf ofs ty (loc_arguments_rec va tys)
end.
(** [loc_arguments s] returns the list of locations where to store arguments
when calling a function with signature [s]. *)
Definition loc_arguments (s: signature) : list (rpair loc) :=
- loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0.
-
-(** [size_arguments s] returns the number of [Outgoing] slots used
- to call a function with signature [s]. *)
-
-Definition max_outgoing_1 (accu: Z) (l: loc) : Z :=
- match l with
- | S Outgoing ofs ty => Z.max accu (ofs + typesize ty)
- | _ => accu
- end.
-
-Definition max_outgoing_2 (accu: Z) (rl: rpair loc) : Z :=
- match rl with
- | One l => max_outgoing_1 accu l
- | Twolong l1 l2 => max_outgoing_1 (max_outgoing_1 accu l1) l2
- end.
-
-Definition size_arguments (s: signature) : Z :=
- List.fold_left max_outgoing_2 (loc_arguments s) 0.
+ loc_arguments_rec s.(sig_cc).(cc_vararg) s.(sig_args) 0 0 0.
(** Argument locations are either non-temporary registers or [Outgoing]
stack slots at nonnegative offsets. *)
@@ -295,90 +294,87 @@ Definition loc_argument_acceptable (l: loc) : Prop :=
end.
Lemma loc_arguments_rec_charact:
- forall va tyl rn ofs p,
+ forall va tyl ri rf ofs p,
ofs >= 0 ->
- In p (loc_arguments_rec va tyl rn ofs) -> forall_rpair loc_argument_acceptable p.
+ In p (loc_arguments_rec va tyl ri rf ofs) -> forall_rpair loc_argument_acceptable p.
Proof.
set (OK := fun (l: list (rpair loc)) =>
forall p, In p l -> forall_rpair loc_argument_acceptable p).
- set (OKF := fun (f: Z -> Z -> list (rpair loc)) =>
- forall rn ofs, ofs >= 0 -> OK (f rn ofs)).
- set (OKREGS := fun (l: list mreg) => forall r, In r l -> is_callee_save r = false).
- assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typealign ty) >= 0).
+ set (OKF := fun (f: Z -> Z -> Z -> list (rpair loc)) =>
+ forall ri rf ofs, ofs >= 0 -> OK (f ri rf ofs)).
+ assert (CSI: forall r, In r int_param_regs -> is_callee_save r = false).
+ { decide_goal. }
+ assert (CSF: forall r, In r float_param_regs -> is_callee_save r = false).
+ { decide_goal. }
+ assert (AL: forall ofs ty, ofs >= 0 -> align ofs (typesize ty) >= 0).
{ intros.
- assert (ofs <= align ofs (typealign ty)) by (apply align_le; apply typealign_pos).
+ assert (ofs <= align ofs (typesize ty)) by (apply align_le; apply typesize_pos).
omega. }
+ assert (ALD: forall ofs ty, ofs >= 0 -> (typealign ty | align ofs (typesize ty))).
+ { intros. eapply Z.divide_trans. apply typealign_typesize.
+ apply align_divides. apply typesize_pos. }
assert (SK: (if Archi.ptr64 then 2 else 1) > 0).
{ destruct Archi.ptr64; omega. }
assert (SKK: forall ty, (if Archi.ptr64 then 2 else typesize ty) > 0).
{ intros. destruct Archi.ptr64. omega. apply typesize_pos. }
- assert (A: forall regs rn ofs ty f,
- OKREGS regs -> OKF f -> ofs >= 0 -> OK (one_arg regs rn ofs ty f)).
- { intros until f; intros OR OF OO; red; unfold one_arg; intros.
- destruct (list_nth_z regs rn) as [r|] eqn:NTH; destruct H.
- - subst p; simpl. apply OR. eapply list_nth_z_in; eauto.
+ assert (A: forall ri rf ofs ty f,
+ OKF f -> ofs >= 0 -> OK (int_arg ri rf ofs ty f)).
+ { intros until f; intros OF OO; red; unfold int_arg; intros.
+ destruct (list_nth_z int_param_regs ri) as [r|] eqn:NTH; destruct H.
+ - subst p; simpl. apply CSI. eapply list_nth_z_in; eauto.
- eapply OF; eauto.
- subst p; simpl. auto using align_divides, typealign_pos.
- eapply OF; [idtac|eauto].
generalize (AL ofs ty OO) (SKK ty); omega.
}
- assert (B: forall regs rn ofs f,
- OKREGS regs -> OKF f -> ofs >= 0 -> OK (two_args regs rn ofs f)).
- { intros until f; intros OR OF OO; unfold two_args.
- set (rn' := align rn 2).
+ assert (B: forall va ri rf ofs ty f,
+ OKF f -> ofs >= 0 -> OK (float_arg va ri rf ofs ty f)).
+ { intros until f; intros OF OO; red; unfold float_arg; intros.
+ destruct (list_nth_z float_param_regs rf) as [r|] eqn:NTH.
+ - set (ri' := if Archi.ptr64 || zeq (typesize ty) 1 then ri + 1 else align ri 2 + 2) in *.
+ destruct va; [destruct (zle ri' 8)|idtac]; destruct H.
+ + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto.
+ + eapply OF; eauto.
+ + subst p; repeat split; auto.
+ + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega.
+ + subst p; simpl. apply CSF. eapply list_nth_z_in; eauto.
+ + eapply OF; eauto.
+ - destruct H.
+ + subst p; repeat split; auto.
+ + eapply OF; [idtac|eauto]. generalize (AL ofs ty OO) (SKK ty); omega.
+ }
+ assert (C: forall va ri rf ofs f,
+ OKF f -> ofs >= 0 -> OK (split_long_arg va ri rf ofs f)).
+ { intros until f; intros OF OO; unfold split_long_arg.
+ set (ri' := if va then align ri 2 else ri).
set (ofs' := align ofs 2).
assert (OO': ofs' >= 0) by (apply (AL ofs Tlong); auto).
- assert (DFL: OK (Twolong (S Outgoing (ofs' + 1) Tint) (S Outgoing ofs' Tint)
- :: f rn' (ofs' + 2))).
- { red; simpl; intros. destruct H.
- - subst p; simpl.
- repeat split; auto using Z.divide_1_l. omega.
- - eapply OF; [idtac|eauto]. omega.
- }
- destruct (list_nth_z regs rn') as [r1|] eqn:NTH1;
- destruct (list_nth_z regs (rn' + 1)) as [r2|] eqn:NTH2;
- try apply DFL.
- red; simpl; intros; destruct H.
- - subst p; simpl. split; apply OR; eauto using list_nth_z_in.
- - eapply OF; [idtac|eauto]. auto.
+ destruct (list_nth_z int_param_regs ri') as [r1|] eqn:NTH1;
+ [destruct (list_nth_z int_param_regs (ri'+1)) as [r2|] eqn:NTH2 | idtac].
+ - red; simpl; intros; destruct H.
+ + subst p; split; apply CSI; eauto using list_nth_z_in.
+ + eapply OF; [idtac|eauto]. omega.
+ - red; simpl; intros; destruct H.
+ + subst p; split. split; auto using Z.divide_1_l. apply CSI; eauto using list_nth_z_in.
+ + eapply OF; [idtac|eauto]. omega.
+ - red; simpl; intros; destruct H.
+ + subst p; repeat split; auto using Z.divide_1_l. omega.
+ + eapply OF; [idtac|eauto]. omega.
}
- assert (C: forall regs rn ofs ty f,
- OKREGS regs -> OKF f -> ofs >= 0 -> typealign ty = 1 -> OK (hybrid_arg regs rn ofs ty f)).
- { intros until f; intros OR OF OO OTY; unfold hybrid_arg; red; intros.
- set (rn' := align rn 2) in *.
- destruct (list_nth_z regs rn') as [r|] eqn:NTH; destruct H.
- - subst p; simpl. apply OR. eapply list_nth_z_in; eauto.
- - eapply OF; eauto.
- - subst p; simpl. rewrite OTY. split. apply (AL ofs Tlong OO). apply Z.divide_1_l.
- - eapply OF; [idtac|eauto]. generalize (AL ofs Tlong OO); simpl; omega.
- }
- assert (D: OKREGS int_param_regs).
- { red. decide_goal. }
- assert (E: OKREGS float_param_regs).
- { red. decide_goal. }
-
- cut (forall va tyl rn ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl rn ofs)).
+ cut (forall va tyl ri rf ofs, ofs >= 0 -> OK (loc_arguments_rec va tyl ri rf ofs)).
unfold OK. eauto.
induction tyl as [ | ty1 tyl]; intros until ofs; intros OO; simpl.
- red; simpl; tauto.
- destruct ty1.
+ (* int *) apply A; auto.
-+ (* float *)
- destruct (va && negb Archi.ptr64).
- apply C; auto.
- apply A; auto.
++ (* float *) apply B; auto.
+ (* long *)
destruct Archi.ptr64.
apply A; auto.
- apply B; auto.
-+ (* single *)
- apply A; auto.
-+ (* any32 *)
- apply A; auto.
-+ (* any64 *)
- destruct (va && negb Archi.ptr64).
apply C; auto.
- apply A; auto.
++ (* single *) apply B; auto.
++ (* any32 *) apply A; auto.
++ (* any64 *) apply B; auto.
Qed.
Lemma loc_arguments_acceptable:
@@ -388,54 +384,14 @@ Proof.
unfold loc_arguments; intros. eapply loc_arguments_rec_charact; eauto. omega.
Qed.
-(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
-
-Remark fold_max_outgoing_above:
- forall l n, fold_left max_outgoing_2 l n >= n.
-Proof.
- assert (A: forall n l, max_outgoing_1 n l >= n).
- { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. }
- induction l; simpl; intros.
- - omega.
- - eapply Zge_trans. eauto.
- destruct a; simpl. apply A. eapply Zge_trans; eauto.
-Qed.
-
-Lemma size_arguments_above:
- forall s, size_arguments s >= 0.
-Proof.
- intros. apply fold_max_outgoing_above.
-Qed.
-
-Lemma loc_arguments_bounded:
- forall (s: signature) (ofs: Z) (ty: typ),
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
- ofs + typesize ty <= size_arguments s.
-Proof.
- intros until ty.
- assert (A: forall n l, n <= max_outgoing_1 n l).
- { intros; unfold max_outgoing_1. destruct l as [_ | []]; xomega. }
- assert (B: forall p n,
- In (S Outgoing ofs ty) (regs_of_rpair p) ->
- ofs + typesize ty <= max_outgoing_2 n p).
- { intros. destruct p; simpl in H; intuition; subst; simpl.
- - xomega.
- - eapply Z.le_trans. 2: apply A. xomega.
- - xomega. }
- assert (C: forall l n,
- In (S Outgoing ofs ty) (regs_of_rpairs l) ->
- ofs + typesize ty <= fold_left max_outgoing_2 l n).
- { induction l; simpl; intros.
- - contradiction.
- - rewrite in_app_iff in H. destruct H.
- + eapply Z.le_trans. eapply B; eauto. apply Z.ge_le. apply fold_max_outgoing_above.
- + apply IHl; auto.
- }
- apply C.
-Qed.
-
Lemma loc_arguments_main:
loc_arguments signature_main = nil.
Proof.
reflexivity.
Qed.
+
+(** ** Normalization of function results *)
+
+(** No normalization needed. *)
+
+Definition return_value_needs_normalization (t: rettype) := false.
diff --git a/riscV/DuplicateOpcodeHeuristic.ml b/riscV/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..2ec314c1
--- /dev/null
+++ b/riscV/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,27 @@
+(* open Camlcoq *)
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c | Ccompfs c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c | Cnotcompfs c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
diff --git a/riscV/Op.v b/riscV/Op.v
index bb04f786..a71696c7 100644
--- a/riscV/Op.v
+++ b/riscV/Op.v
@@ -666,6 +666,36 @@ Proof with (try exact I; try reflexivity; auto using Val.Vptr_has_type).
- destruct (eval_condition cond vl m)... destruct b...
Qed.
+
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivl | Odivu | Odivlu
+ | Omod | Omodl | Omodu | Omodlu
+ | Oshrximm _ | Oshrxlimm _
+ | Ointoffloat | Ointuoffloat
+ | Ointofsingle | Ointuofsingle
+ | Olongoffloat | Olonguoffloat
+ | Olongofsingle | Olonguofsingle
+ | Osingleofint | Osingleofintu
+ | Osingleoflong | Osingleoflongu
+ | Ofloatofint | Ofloatofintu
+ | Ofloatoflong | Ofloatoflongu => true
+ | _ => false
+ end.
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
End SOUNDNESS.
(** * Manipulating and transforming operations *)
@@ -1159,6 +1189,20 @@ Proof.
apply Val.offset_ptr_inject; auto.
Qed.
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *;
+ inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
+Qed.
End EVAL_COMPAT.
(** Compatibility of the evaluation functions with the ``is less defined'' relation over values. *)
@@ -1265,6 +1309,18 @@ Proof.
destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros until vl2. intros Hlessdef Heval1.
+ destruct addr; simpl in *;
+ inv Hlessdef; trivial; try discriminate;
+ inv H0; trivial; try discriminate;
+ inv H2; trivial; try discriminate.
+Qed.
End EVAL_LESSDEF.
(** Compatibility of the evaluation functions with memory injections. *)
@@ -1317,6 +1373,20 @@ Proof.
econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.
+
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
Lemma eval_operation_inject:
forall op vl1 vl2 v1 m1 m2,
Val.inject_list f vl1 vl2 ->
diff --git a/riscV/SelectOp.vp b/riscV/SelectOp.vp
index 181b9d05..e9920e46 100644
--- a/riscV/SelectOp.vp
+++ b/riscV/SelectOp.vp
@@ -44,11 +44,8 @@
Require Archi.
Require Import Coqlib.
Require Import Compopts.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Op.
-Require Import CminorSel.
+Require Import AST Integers Floats Builtins.
+Require Import Op CminorSel.
Local Open Scope cminorsel_scope.
@@ -420,6 +417,12 @@ Definition singleofintu (e: expr) := Eop Osingleofintu (e ::: Enil).
Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil).
+(** ** Selection *)
+
+Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr)
+ : option expr
+ := None.
+
(** ** Recognition of addressing modes for load and store operations *)
Nondetfunction addressing (chunk: memory_chunk) (e: expr) :=
@@ -455,3 +458,8 @@ Definition divf_base (e1: expr) (e2: expr) :=
Definition divfs_base (e1: expr) (e2: expr) :=
Eop Odivfs (e1 ::: e2 ::: Enil).
+
+(** Platform-specific known builtins *)
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ None.
diff --git a/riscV/SelectOpproof.v b/riscV/SelectOpproof.v
index 9966305c..7f2014dc 100644
--- a/riscV/SelectOpproof.v
+++ b/riscV/SelectOpproof.v
@@ -17,17 +17,10 @@
(** Correctness of instruction selection for operators *)
-Require Import Coqlib.
-Require Import Maps.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import Memory.
-Require Import Globalenvs.
-Require Import Cminor.
-Require Import Op.
-Require Import CminorSel.
+Require Import Coqlib Zbits.
+Require Import AST Integers Floats.
+Require Import Values Memory Builtins Globalenvs.
+Require Import Cminor Op CminorSel.
Require Import SelectOp.
Require Import OpHelpers.
Require Import OpHelpersproof.
@@ -376,7 +369,7 @@ Proof.
change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
apply Val.lessdef_same. f_equal.
transitivity (Int.repr (Z.shiftr (Int.signed i * Int.signed i0) 32)).
- unfold Int.mulhs; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity.
+ unfold Int.mulhs; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity.
apply Int.same_bits_eq; intros n N.
change Int.zwordsize with 32 in *.
assert (N1: 0 <= n < 64) by omega.
@@ -404,7 +397,7 @@ Proof.
change (Int.ltu (Int.repr 32) Int64.iwordsize') with true; simpl.
apply Val.lessdef_same. f_equal.
transitivity (Int.repr (Z.shiftr (Int.unsigned i * Int.unsigned i0) 32)).
- unfold Int.mulhu; f_equal. rewrite Int.Zshiftr_div_two_p by omega. reflexivity.
+ unfold Int.mulhu; f_equal. rewrite Zshiftr_div_two_p by omega. reflexivity.
apply Int.same_bits_eq; intros n N.
change Int.zwordsize with 32 in *.
assert (N1: 0 <= n < 64) by omega.
@@ -774,7 +767,7 @@ Qed.
Theorem eval_cast8unsigned: unary_constructor_sound cast8unsigned (Val.zero_ext 8).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm. omega.
Qed.
Theorem eval_cast16signed: unary_constructor_sound cast16signed (Val.sign_ext 16).
@@ -787,7 +780,7 @@ Qed.
Theorem eval_cast16unsigned: unary_constructor_sound cast16unsigned (Val.zero_ext 16).
Proof.
red; intros until x. unfold cast8unsigned.
- rewrite Val.zero_ext_and. apply eval_andimm. compute; auto.
+ rewrite Val.zero_ext_and. apply eval_andimm. omega.
Qed.
Theorem eval_intoffloat:
@@ -876,6 +869,20 @@ Proof.
red; intros. unfold floatofsingle. TrivialExists.
Qed.
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select; intros; discriminate.
+Qed.
+
Theorem eval_addressing:
forall le chunk a v b ofs,
eval_expr ge sp e m le a v ->
@@ -926,7 +933,6 @@ Proof.
- constructor; auto.
Qed.
-
(* floating-point division without HELPERS *)
Theorem eval_divf_base:
forall le a b x y,
@@ -947,4 +953,17 @@ Proof.
intros; unfold divfs_base.
TrivialExists.
Qed.
+
+(** Platform-specific known builtins *)
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros. discriminate.
+Qed.
+
End CMCONSTR.
diff --git a/riscV/TargetPrinter.ml b/riscV/TargetPrinter.ml
index 19704bad..64bcea4c 100644
--- a/riscV/TargetPrinter.ml
+++ b/riscV/TargetPrinter.ml
@@ -93,7 +93,7 @@ module Target : TARGET =
| X0 -> output_string oc "x0"
| X r -> ireg oc r
- let preg oc = function
+ let preg_asm oc ty = function
| IR r -> ireg oc r
| FR r -> freg oc r
| _ -> assert false
@@ -108,9 +108,9 @@ module Target : TARGET =
let name_of_section = function
| Section_text -> ".text"
| Section_data i | Section_small_data i ->
- if i then ".data" else "COMM"
+ if i then ".data" else common_section ()
| Section_const i | Section_small_const i ->
- if i then ".section .rodata" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM"
| Section_string -> ".section .rodata"
| Section_literal -> ".section .rodata"
| Section_jumptable -> ".section .rodata"
@@ -582,7 +582,7 @@ module Target : TARGET =
(P.to_int kind) (extern_atom txt) args
| EF_inline_asm(txt, sg, clob) ->
fprintf oc "%s begin inline assembly\n\t" comment;
- print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
fprintf oc "%s end inline assembly\n" comment
| _ ->
assert false
diff --git a/runtime/Makefile b/runtime/Makefile
index 6bc3e7ea..a689f3ea 100644
--- a/runtime/Makefile
+++ b/runtime/Makefile
@@ -28,6 +28,8 @@ OBJS=i64_umod.o i64_udiv.o i64_udivmod.o i64_sdiv.o i64_smod.o \
vararg.o
# Missing: i64_utod.o i64_utof.o i64_stod.o i64_stof.o
DOMAKE:=$(shell (cd mppa_k1c && make))
+else ifeq ($(ARCH),aarch64)
+OBJS=vararg.o
else
OBJS=i64_dtos.o i64_dtou.o i64_sar.o i64_sdiv.o i64_shl.o \
i64_shr.o i64_smod.o i64_stod.o i64_stof.o \
@@ -79,16 +81,16 @@ clean::
ifeq ($(strip $(HAS_RUNTIME_LIB)),true)
install::
- install -d $(LIBDIR)
- install -m 0644 $(LIB) $(LIBDIR)
+ install -d $(DESTDIR)$(LIBDIR)
+ install -m 0644 $(LIB) $(DESTDIR)$(LIBDIR)
else
install::
endif
ifeq ($(strip $(HAS_STANDARD_HEADERS)),true)
install::
- install -d $(LIBDIR)/include
- install -m 0644 $(INCLUDES) $(LIBDIR)/include
+ install -d $(DESTDIR)$(LIBDIR)/include
+ install -m 0644 $(INCLUDES) $(DESTDIR)$(LIBDIR)/include
else
install::
endif
diff --git a/runtime/aarch64/sysdeps.h b/runtime/aarch64/sysdeps.h
new file mode 100644
index 00000000..0cee9ae3
--- /dev/null
+++ b/runtime/aarch64/sysdeps.h
@@ -0,0 +1,45 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, Collège de France and INRIA Paris
+//
+// Copyright (c) Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// System dependencies
+
+#define FUNCTION(f) \
+ .text; \
+ .balign 16; \
+ .globl f; \
+f:
+
+#define ENDFUNCTION(f) \
+ .type f, @function; .size f, . - f
+
diff --git a/runtime/aarch64/vararg.S b/runtime/aarch64/vararg.S
new file mode 100644
index 00000000..b7347d65
--- /dev/null
+++ b/runtime/aarch64/vararg.S
@@ -0,0 +1,109 @@
+// *****************************************************************
+//
+// The Compcert verified compiler
+//
+// Xavier Leroy, Collège de France and INRIA Paris
+//
+// Copyright (c) Institut National de Recherche en Informatique et
+// en Automatique.
+//
+// Redistribution and use in source and binary forms, with or without
+// modification, are permitted provided that the following conditions are met:
+// * Redistributions of source code must retain the above copyright
+// notice, this list of conditions and the following disclaimer.
+// * Redistributions in binary form must reproduce the above copyright
+// notice, this list of conditions and the following disclaimer in the
+// documentation and/or other materials provided with the distribution.
+// * Neither the name of the <organization> nor the
+// names of its contributors may be used to endorse or promote products
+// derived from this software without specific prior written permission.
+//
+// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+// A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT
+// HOLDER> BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+// EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+// PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+// PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+// LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+// NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+// SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+//
+// *********************************************************************
+
+// Helper functions for variadic functions <stdarg.h>. AArch64 version.
+
+#include "sysdeps.h"
+
+// typedef struct __va_list {
+// void *__stack; // next stack parameter
+// void *__gr_top; // top of the save area for int regs
+// void *__vr_top; // top of the save area for float regs
+// int__gr_offs; // offset from gr_top to next int reg
+// int__vr_offs; // offset from gr_top to next FP reg
+// }
+// typedef struct __va_list va_list; // struct passed by reference
+// unsigned int __compcert_va_int32(va_list * ap);
+// unsigned long long __compcert_va_int64(va_list * ap);
+// double __compcert_va_float64(va_list * ap);
+
+FUNCTION(__compcert_va_int32)
+ ldr w1, [x0, #24] // w1 = gr_offs
+ cbz w1, 1f
+ // gr_offs is not zero: load from int save area and update gr_offs
+ ldr x2, [x0, #8] // x2 = gr_top
+ ldr w2, [x2, w1, sxtw] // w2 = the next integer
+ add w1, w1, #8
+ str w1, [x0, #24] // update gr_offs
+ mov w0, w2
+ ret
+ // gr_offs is zero: load from stack save area and update stack pointer
+1: ldr x1, [x0, #0] // x1 = stack
+ ldr w2, [x1, #0] // w2 = the next integer
+ add x1, x1, #8
+ str x1, [x0, #0] // update stack
+ mov w0, w2
+ ret
+ENDFUNCTION(__compcert_va_int32)
+
+FUNCTION(__compcert_va_int64)
+ ldr w1, [x0, #24] // w1 = gr_offs
+ cbz w1, 1f
+ // gr_offs is not zero: load from int save area and update gr_offs
+ ldr x2, [x0, #8] // x2 = gr_top
+ ldr x2, [x2, w1, sxtw] // w2 = the next long integer
+ add w1, w1, #8
+ str w1, [x0, #24] // update gr_offs
+ mov x0, x2
+ ret
+ // gr_offs is zero: load from stack save area and update stack pointer
+1: ldr x1, [x0, #0] // x1 = stack
+ ldr x2, [x1, #0] // w2 = the next long integer
+ add x1, x1, #8
+ str x1, [x0, #0] // update stack
+ mov x0, x2
+ ret
+ENDFUNCTION(__compcert_va_int64)
+
+FUNCTION(__compcert_va_float64)
+ ldr w1, [x0, #28] // w1 = vr_offs
+ cbz w1, 1f
+ // vr_offs is not zero: load from float save area and update vr_offs
+ ldr x2, [x0, #16] // x2 = vr_top
+ ldr d0, [x2, w1, sxtw] // d0 = the next float
+ add w1, w1, #16
+ str w1, [x0, #28] // update vr_offs
+ ret
+ // gr_offs is zero: load from stack save area and update stack pointer
+1: ldr x1, [x0, #0] // x1 = stack
+ ldr d0, [x1, #0] // d0 = the next float
+ add x1, x1, #8
+ str x1, [x0, #0] // update stack
+ ret
+ENDFUNCTION(__compcert_va_float64)
+
+// Right now we pass structs by reference. This is not ABI conformant.
+FUNCTION(__compcert_va_composite)
+ b __compcert_va_int64
+ENDFUNCTION(__compcert_va_composite)
diff --git a/runtime/arm/i64_stof.S b/runtime/arm/i64_stof.S
index bcfa471c..11e00a2a 100644
--- a/runtime/arm/i64_stof.S
+++ b/runtime/arm/i64_stof.S
@@ -39,12 +39,11 @@
@@@ Conversion from signed 64-bit integer to single float
FUNCTION(__compcert_i64_stof)
- @ Check whether -2^53 <= X < 2^53
- ASR r2, Reg0HI, #21
- ASR r3, Reg0HI, #31 @ (r2,r3) = X >> 53
+ @ Check whether -2^53 <= X < 2^53
+ ASR r2, Reg0HI, #21 @ r2 = high 32 bits of X >> 53
+ @ -2^53 <= X < 2^53 iff r2 is -1 or 0, that is, iff r2 + 1 is 0 or 1
adds r2, r2, #1
- adc r3, r3, #0 @ (r2,r3) = X >> 53 + 1
- cmp r3, #2
+ cmp r2, #2
blo 1f
@ X is large enough that double rounding can occur.
@ Avoid it by nudging X away from the points where double rounding
diff --git a/runtime/include/ccomp_k1c_fixes.h b/runtime/include/ccomp_k1c_fixes.h
index 5c543d8f..718ac3e5 100644
--- a/runtime/include/ccomp_k1c_fixes.h
+++ b/runtime/include/ccomp_k1c_fixes.h
@@ -17,6 +17,12 @@ extern __int128 __compcert_acswapd(void *address, unsigned long long new_value,
#define __builtin_k1_acswapw __compcert_acswapw
extern __int128 __compcert_acswapw(void *address, unsigned long long new_value, unsigned long long old_value);
+
+#define __builtin_k1_afaddd __compcert_afaddd
+extern long long __compcert_afaddd(void *address, unsigned long long incr);
+
+#define __builtin_k1_afaddw __compcert_afaddw
+extern int __compcert_afaddw(void *address, unsigned int incr);
#endif
#define __builtin_expect(x, y) (x)
diff --git a/runtime/include/math.h b/runtime/include/math.h
index 805cc8e7..01b8d8d8 100644
--- a/runtime/include/math.h
+++ b/runtime/include/math.h
@@ -1,7 +1,26 @@
#ifndef _COMPCERT_MATH_H
#define _COMPCERT_MATH_H
+#ifdef __K1C__
+
#define isfinite(__y) (fpclassify((__y)) >= FP_ZERO)
#include_next <math.h>
+
+#ifndef COMPCERT_NO_FP_MACROS
+#define fmin(x, y) __builtin_fmin((x),(y))
+#define fmax(x, y) __builtin_fmax((x),(y))
+#define fminf(x, y) __builtin_fminf((x),(y))
+#define fmaxf(x, y) __builtin_fmaxf((x),(y))
+#define fabs(x) __builtin_fabs((x))
+#define fabsf(x) __builtin_fabsf((x))
+#define fma(x, y, z) __builtin_fma((x),(y),(z))
+#define fmaf(x, y, z) __builtin_fmaf((x),(y),(z))
+#endif
+
+#else
+
+#include_next <math.h>
+
+#endif
#endif
diff --git a/runtime/mppa_k1c/i32_divmod.S b/runtime/mppa_k1c/i32_divmod.s
index d2b4e8d5..d2b4e8d5 100644
--- a/runtime/mppa_k1c/i32_divmod.S
+++ b/runtime/mppa_k1c/i32_divmod.s
diff --git a/runtime/mppa_k1c/i64_sdiv.c b/runtime/mppa_k1c/i64_sdiv.c
index df308736..b98d9316 100644
--- a/runtime/mppa_k1c/i64_sdiv.c
+++ b/runtime/mppa_k1c/i64_sdiv.c
@@ -5,31 +5,19 @@ int i32_sdiv (int a, int b)
return __divdi3 (a, b);
}
-/* #define COMPCERT_FE_EXCEPT */
-#ifdef COMPCERT_FE_EXCEPT
-#ifdef __K1C_COS__
-
-#include <hal/cos_registers.h>
-#define K1_SFR_CS_IO_MASK COS_SFR_CS_IO_MASK
-#define K1_SFR_CS_DZ_MASK COS_SFR_CS_DZ_MASK
-#define K1_SFR_CS_OV_MASK COS_SFR_CS_OV_MASK
-#define K1_SFR_CS_UN_MASK COS_SFR_CS_UN_MASK
-#define K1_SFR_CS_IN_MASK COS_SFR_CS_IN_MASK
-#define K1_SFR_CS COS_SFR_CS
-#else
-#include <mppa_bare_runtime/k1c/registers.h>
-#endif
+#ifdef OUR_OWN_FE_EXCEPT
+#include <../../k1-cos/include/hal/cos_registers.h>
/* DM FIXME this is for floating point */
int fetestexcept(int excepts) {
- int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts;
- unsigned long long cs = __builtin_k1_get(K1_SFR_CS);
+ int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts;
+ unsigned long long cs = __builtin_k1_get(COS_SFR_CS);
return cs & mask;
}
int feclearexcept(int excepts) {
- int mask = (K1_SFR_CS_IO_MASK | K1_SFR_CS_DZ_MASK | K1_SFR_CS_OV_MASK | K1_SFR_CS_UN_MASK | K1_SFR_CS_IN_MASK) & excepts;
- __builtin_k1_wfxl(K1_SFR_CS, mask);
+ int mask = (COS_SFR_CS_IO_MASK | COS_SFR_CS_DZ_MASK | COS_SFR_CS_OV_MASK | COS_SFR_CS_UN_MASK | COS_SFR_CS_IN_MASK) & excepts;
+ __builtin_k1_wfxl(COS_SFR_CS, mask);
return 0;
}
#endif
diff --git a/runtime/mppa_k1c/i64_udivmod_stsud.S b/runtime/mppa_k1c/i64_udivmod_stsud.s
index ac84ca47..b1d10326 100644
--- a/runtime/mppa_k1c/i64_udivmod_stsud.S
+++ b/runtime/mppa_k1c/i64_udivmod_stsud.s
@@ -116,9 +116,40 @@ __compcert_i32_udiv_stsud:
zxwd $r1 = $r1
goto __compcert_i64_divmod_stsud
;;
+
+ .globl __compcert_i64_umod_stsud
+__compcert_i64_umod_stsud:
+ make $r2 = 0
+ make $r3 = 1
+ goto __compcert_i64_divmod_stsud
+ ;;
+
+ .globl __compcert_i64_udiv_stsud
+__compcert_i64_udiv_stsud:
+ make $r2 = 0
+ make $r3 = 0
+ goto __compcert_i64_divmod_stsud
+ ;;
+
+ .globl __compcert_i64_sdiv_stsud
+__compcert_i64_sdiv_stsud:
+ compd.lt $r2 = $r0, 0
+ compd.lt $r3 = $r1, 0
+ ;;
+ xord $r2 = $r2, $r3
+ make $r3 = 0
+ goto __compcert_i64_divmod_stsud
+ ;;
+
+ .globl __compcert_i64_smod_stsud
+__compcert_i64_smod_stsud:
+ compd.lt $r2 = $r0, 0
+ make $r3 = 1
+ goto __compcert_i64_divmod_stsud
+ ;;
.globl __compcert_i64_divmod_stsud
- __compcert_i64_divmod_stsud:
+__compcert_i64_divmod_stsud:
make $r5 = 0
compd.ltu $r7 = $r0, $r1
;;
diff --git a/runtime/mppa_k1c/vararg.S b/runtime/mppa_k1c/vararg.s
index 9e23e0b3..65c1eab8 100644
--- a/runtime/mppa_k1c/vararg.S
+++ b/runtime/mppa_k1c/vararg.s
@@ -1,7 +1,7 @@
-// typedef void * va_list;
-// unsigned int __compcert_va_int32(va_list * ap);
-// unsigned long long __compcert_va_int64(va_list * ap);
+# typedef void * va_list;
+# unsigned int __compcert_va_int32(va_list * ap);
+# unsigned long long __compcert_va_int64(va_list * ap);
.text
.balign 2
diff --git a/runtime/powerpc/i64_stof.s b/runtime/powerpc/i64_stof.s
index 97fa6bb8..ea23a1c8 100644
--- a/runtime/powerpc/i64_stof.s
+++ b/runtime/powerpc/i64_stof.s
@@ -43,20 +43,19 @@
__compcert_i64_stof:
mflr r9
# Check whether -2^53 <= X < 2^53
- srawi r5, r3, 31
- srawi r6, r3, 21 # (r5,r6) = X >> 53
- addic r6, r6, 1
- addze r5, r5 # (r5,r6) = (X >> 53) + 1
+ srawi r5, r3, 21 # r5 = high 32 bits of X >> 53
+ # -2^53 <= X < 2^53 iff r5 is -1 or 0, that is, iff r5 + 1 is 0 or 1
+ addi r5, r5, 1
cmplwi r5, 2
blt 1f
# X is large enough that double rounding can occur.
# Avoid it by nudging X away from the points where double rounding
# occurs (the "round to odd" technique)
- rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X
- addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF
- # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise
- # bits 13-31 of r0 are 0
- or r4, r4, r0 # correct bit number 12 of X
+ rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X
+ addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF
+ # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise
+ # bits 13-31 of r5 are 0
+ or r4, r4, r5 # correct bit number 12 of X
rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X
# Convert to double, then round to single
1: bl __compcert_i64_stod
diff --git a/runtime/powerpc/i64_utof.s b/runtime/powerpc/i64_utof.s
index cdb2f867..4a2a172b 100644
--- a/runtime/powerpc/i64_utof.s
+++ b/runtime/powerpc/i64_utof.s
@@ -48,11 +48,11 @@ __compcert_i64_utof:
# X is large enough that double rounding can occur.
# Avoid it by nudging X away from the points where double rounding
# occurs (the "round to odd" technique)
- rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X
- addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF
- # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise
- # bits 13-31 of r0 are 0
- or r4, r4, r0 # correct bit number 12 of X
+ rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X
+ addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF
+ # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise
+ # bits 13-31 of r5 are 0
+ or r4, r4, r5 # correct bit number 12 of X
rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X
# Convert to double, then round to single
1: bl __compcert_i64_utod
diff --git a/runtime/powerpc64/i64_utof.s b/runtime/powerpc64/i64_utof.s
index cdb2f867..4a2a172b 100644
--- a/runtime/powerpc64/i64_utof.s
+++ b/runtime/powerpc64/i64_utof.s
@@ -48,11 +48,11 @@ __compcert_i64_utof:
# X is large enough that double rounding can occur.
# Avoid it by nudging X away from the points where double rounding
# occurs (the "round to odd" technique)
- rlwinm r0, r4, 0, 21, 31 # extract bits 0 to 11 of X
- addi r0, r0, 0x7FF # r0 = (X & 0x7FF) + 0x7FF
- # bit 12 of r0 is 0 if all low 12 bits of X are 0, 1 otherwise
- # bits 13-31 of r0 are 0
- or r4, r4, r0 # correct bit number 12 of X
+ rlwinm r5, r4, 0, 21, 31 # extract bits 0 to 11 of X
+ addi r5, r5, 0x7FF # r5 = (X & 0x7FF) + 0x7FF
+ # bit 12 of r5 is 0 if all low 12 bits of X are 0, 1 otherwise
+ # bits 13-31 of r5 are 0
+ or r4, r4, r5 # correct bit number 12 of X
rlwinm r4, r4, 0, 0, 20 # set to 0 bits 0 to 11 of X
# Convert to double, then round to single
1: bl __compcert_i64_utod
diff --git a/test/Makefile b/test/Makefile
index 504e4c53..e9c5d6a1 100644
--- a/test/Makefile
+++ b/test/Makefile
@@ -1,6 +1,14 @@
include ../Makefile.config
-DIRS=c compression raytracer spass regression
+#DIRS=c compression raytracer spass regression
+
+# Kalray note - removing compression, raytracer and spass that cannot be executed by the simulator in reasonable time
+ifeq ($(ARCH),mppa_k1c)
+ DIRS=c regression
+else
+ DIRS=c compression raytracer spass regression
+endif
+
ifeq ($(CLIGHTGEN),true)
DIRS+=clightgen
endif
diff --git a/test/c/Makefile b/test/c/Makefile
index 46670ec6..a2a80e06 100644
--- a/test/c/Makefile
+++ b/test/c/Makefile
@@ -3,18 +3,32 @@ include ../../Makefile.config
CCOMP=../../ccomp
CCOMPFLAGS=$(CCOMPOPTS) -stdlib ../../runtime -dc -dclight -dasm
-CFLAGS=-O1 -Wall
+CFLAGS+=-O2 -Wall
+EXECUTE:=timeout --signal=SIGTERM 20s $(EXECUTE)
LIBS=$(LIBMATH)
-TIME=xtime -o /dev/null -mintime 2.0 # Xavier's hack
-#TIME=time >/dev/null # Otherwise
-
-PROGS=fib qsort fftw sha1 sha3 aes \
- lists binarytrees fannkuch \
- nsieve nsievebits vmach \
- chomp perlin siphash24\
- integr fft fftsp almabench knucleotide mandelbrot nbody spectral bisect
+TIME=time >/dev/null
+# FIXME - maybe this is better? From v3.6
+# TIME=ocaml unix.cma ../../tools/xtime.ml -o /dev/null -mintime 2.0 -minruns 4
+
+PROGS?=fib integr qsort fft fftsp fftw sha1 sha3 aes almabench \
+ lists binarytrees fannkuch mandelbrot nbody \
+ nsieve nsievebits spectral vmach \
+ chomp perlin siphash24
+
+##
+# Kalray NOTE :
+# * removed knucleotide from PROGS, it is hard to edit the input
+# to modify its size without resulting in a seg fault, and the base input
+# takes a too long time to complete in the simulator.
+# * also removed bisect, who is exhibiting different float values on the Kalray
+# architecture than using x86 GCC (for both CompCert and GCC ports) (tested with n=10)
+##
+ifeq ($(ARCH),mppa_k1c)
+ PROGS:=$(filter-out knucleotide,$(PROGS))
+ PROGS:=$(filter-out bisect,$(PROGS))
+endif
all: $(PROGS:%=%.compcert)
@@ -31,32 +45,27 @@ all_gcc: $(PROGS:%=%.gcc)
%.gcc: %.c
$(CC) $(CFLAGS) -o $*.gcc $*.c $(LIBS)
-test:
+test: all
@for i in $(PROGS); do \
- if $(SIMU) ./$$i.compcert | cmp -s - Results/$$i; \
- then echo "$$i: passed"; \
- else echo "$$i: FAILED"; exit 2; \
- fi; \
+ SIMU='$(EXECUTE)' ./Runtest $$i ./$$i.compcert;\
done
-test_gcc:
+test_gcc: all_gcc
@for i in $(PROGS); do \
- if ./$$i.gcc | cmp -s - Results/$$i; \
- then echo "$$i: passed"; \
- else echo "$$i: FAILED"; \
- fi; \
+ SIMU='$(EXECUTE)' ./Runtest $$i ./$$i.gcc;\
done
-bench_gcc:
+bench_gcc: all_gcc
@for i in $(PROGS); do \
- echo -n "$$i: "; $(TIME) ./$$i.gcc; \
+ $(TIME) -name $$i -- ./$$i.gcc; \
done
-bench:
+bench: all
@for i in $(PROGS); do \
- echo -n "$$i: "; $(TIME) ./$$i.compcert; \
+ $(TIME) -name $$i -- ./$$i.compcert; \
done
clean:
rm -f *.compcert *.gcc
rm -f *.compcert.c *.light.c *.parsed.c *.s *.o *.sdump *~
+ rm -f *.out
diff --git a/test/c/Results/binarytrees-mppa_k1c b/test/c/Results/binarytrees-mppa_k1c
new file mode 100644
index 00000000..72654db9
--- /dev/null
+++ b/test/c/Results/binarytrees-mppa_k1c
@@ -0,0 +1,4 @@
+stretch tree of depth 7 check: -1
+128 trees of depth 4 check: -128
+32 trees of depth 6 check: -32
+long lived tree of depth 6 check: -1
diff --git a/test/c/Results/chomp-mppa_k1c b/test/c/Results/chomp-mppa_k1c
new file mode 100644
index 00000000..7898d32f
--- /dev/null
+++ b/test/c/Results/chomp-mppa_k1c
@@ -0,0 +1,9 @@
+player 0 plays at (1,1)
+player 1 plays at (3,0)
+player 0 plays at (0,3)
+player 1 plays at (2,0)
+player 0 plays at (0,2)
+player 1 plays at (1,0)
+player 0 plays at (0,1)
+player 1 plays at (0,0)
+player 1 loses
diff --git a/test/c/Results/fannkuch-mppa_k1c b/test/c/Results/fannkuch-mppa_k1c
new file mode 100644
index 00000000..09ecc715
--- /dev/null
+++ b/test/c/Results/fannkuch-mppa_k1c
@@ -0,0 +1,31 @@
+123456
+213456
+231456
+321456
+312456
+132456
+234156
+324156
+342156
+432156
+423156
+243156
+341256
+431256
+413256
+143256
+134256
+314256
+412356
+142356
+124356
+214356
+241356
+421356
+234516
+324516
+342516
+432516
+423516
+243516
+Pfannkuchen(6) = 10
diff --git a/test/c/Results/fft-mppa_k1c b/test/c/Results/fft-mppa_k1c
new file mode 100644
index 00000000..0fc1c969
--- /dev/null
+++ b/test/c/Results/fft-mppa_k1c
@@ -0,0 +1 @@
+1024 points, result OK
diff --git a/test/c/Results/fftsp-mppa_k1c b/test/c/Results/fftsp-mppa_k1c
new file mode 100644
index 00000000..2b5711a6
--- /dev/null
+++ b/test/c/Results/fftsp-mppa_k1c
@@ -0,0 +1 @@
+8 points, result OK
diff --git a/test/c/Results/fftw-mppa_k1c b/test/c/Results/fftw-mppa_k1c
new file mode 100644
index 00000000..a1b6130c
--- /dev/null
+++ b/test/c/Results/fftw-mppa_k1c
@@ -0,0 +1,16 @@
+o[0] = 2.918193e+01
+o[1] = -3.230611e+01
+o[2] = 1.271687e+01
+o[3] = -1.099040e+01
+o[4] = 5.728673e+00
+o[5] = -4.918940e+00
+o[6] = 1.880764e+00
+o[7] = -1.292782e+00
+o[8] = 1.104073e+02
+o[9] = -5.867858e+01
+o[10] = 2.768382e+01
+o[11] = -2.073843e+01
+o[12] = 1.229410e+01
+o[13] = -9.195029e+00
+o[14] = 4.307537e+00
+o[15] = -2.080713e+00
diff --git a/test/c/Results/fib-mppa_k1c b/test/c/Results/fib-mppa_k1c
new file mode 100644
index 00000000..0e0fa4d1
--- /dev/null
+++ b/test/c/Results/fib-mppa_k1c
@@ -0,0 +1 @@
+fib(15) = 987
diff --git a/test/c/Results/integr-mppa_k1c b/test/c/Results/integr-mppa_k1c
new file mode 100644
index 00000000..c61fdcc2
--- /dev/null
+++ b/test/c/Results/integr-mppa_k1c
@@ -0,0 +1 @@
+integr(square, 0.0, 1.0, 100000) = 0.333328
diff --git a/test/c/Results/knucleotide-mppa_k1c b/test/c/Results/knucleotide-mppa_k1c
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/test/c/Results/knucleotide-mppa_k1c
diff --git a/test/c/Results/lists-mppa_k1c b/test/c/Results/lists-mppa_k1c
new file mode 100644
index 00000000..2c94e483
--- /dev/null
+++ b/test/c/Results/lists-mppa_k1c
@@ -0,0 +1,2 @@
+OK
+OK
diff --git a/test/c/Results/mandelbrot-mppa_k1c b/test/c/Results/mandelbrot-mppa_k1c
new file mode 100644
index 00000000..f50961fe
--- /dev/null
+++ b/test/c/Results/mandelbrot-mppa_k1c
Binary files differ
diff --git a/test/c/Results/nbody-mppa_k1c b/test/c/Results/nbody-mppa_k1c
new file mode 100644
index 00000000..99ad4fd1
--- /dev/null
+++ b/test/c/Results/nbody-mppa_k1c
@@ -0,0 +1,2 @@
+-0.169075164
+-0.169050762
diff --git a/test/c/Results/nsieve-mppa_k1c b/test/c/Results/nsieve-mppa_k1c
new file mode 100644
index 00000000..95fea812
--- /dev/null
+++ b/test/c/Results/nsieve-mppa_k1c
@@ -0,0 +1,3 @@
+Primes up to 12800 1526
+Primes up to 6400 834
+Primes up to 3200 452
diff --git a/test/c/Results/nsievebits-mppa_k1c b/test/c/Results/nsievebits-mppa_k1c
new file mode 100644
index 00000000..2131804c
--- /dev/null
+++ b/test/c/Results/nsievebits-mppa_k1c
@@ -0,0 +1,3 @@
+Primes up to 40000 4203
+Primes up to 20000 2262
+Primes up to 10000 1229
diff --git a/test/c/Results/perlin-mppa_k1c b/test/c/Results/perlin-mppa_k1c
new file mode 100644
index 00000000..8438b53c
--- /dev/null
+++ b/test/c/Results/perlin-mppa_k1c
@@ -0,0 +1 @@
+6.0000e+00
diff --git a/test/c/Results/qsort-mppa_k1c b/test/c/Results/qsort-mppa_k1c
new file mode 100644
index 00000000..d86bac9d
--- /dev/null
+++ b/test/c/Results/qsort-mppa_k1c
@@ -0,0 +1 @@
+OK
diff --git a/test/c/Results/sha1-mppa_k1c b/test/c/Results/sha1-mppa_k1c
new file mode 100644
index 00000000..730d5406
--- /dev/null
+++ b/test/c/Results/sha1-mppa_k1c
@@ -0,0 +1,2 @@
+Test `abc': passed
+Test `abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq': passed
diff --git a/test/c/Results/spectral-mppa_k1c b/test/c/Results/spectral-mppa_k1c
new file mode 100644
index 00000000..b06cd560
--- /dev/null
+++ b/test/c/Results/spectral-mppa_k1c
@@ -0,0 +1 @@
+1.272359925
diff --git a/test/c/Results/vmach-mppa_k1c b/test/c/Results/vmach-mppa_k1c
new file mode 100644
index 00000000..a95237a6
--- /dev/null
+++ b/test/c/Results/vmach-mppa_k1c
@@ -0,0 +1,2 @@
+fib(15) = 987
+tak(12, 9, 6) = 9
diff --git a/test/c/Runtest b/test/c/Runtest
new file mode 100755
index 00000000..f693219a
--- /dev/null
+++ b/test/c/Runtest
@@ -0,0 +1,71 @@
+#!/bin/sh
+
+# The name of the test
+name="$1"
+shift
+
+# The temp file for output
+out="test$$.log"
+rm -f $out
+trap "rm -f $out" 0 INT QUIT
+
+# Is the test expected to fail?
+expect_fail=false
+
+# The architecture and the bitsize
+arch=`sed -n -e 's/^ARCH=//p' ../../Makefile.config`
+bits=`sed -n -e 's/^BITSIZE=//p' ../../Makefile.config`
+
+# The reference output
+if test -f "Results/$name-$arch-$bits"; then
+ ref="Results/$name-$arch-$bits"
+elif test -f "Results/$name-$arch"; then
+ ref="Results/$name-$arch"
+elif test -f "Results/$name-$bits"; then
+ ref="Results/$name-$bits"
+elif test -f "Results/$name"; then
+ ref="Results/$name"
+else
+ ref=""
+fi
+
+# Special conditions
+
+if test -f "$name.cond"; then
+ RUN=0 SKIP=1 EXPECT_FAIL=2 sh "$name.cond"
+ case "$?" in
+ 1) echo "$name: skipped"; exit 0;;
+ 2) expect_fail=true;;
+ esac
+fi
+
+# Administer the test
+if $SIMU $* > $out
+then
+ if $expect_fail; then
+ echo "$name: ERROR (should have failed but did not)"
+ exit 2
+ elif test -n "$ref"; then
+ if cmp -s "$out" "$ref"; then
+ echo "$name: passed"
+ exit 0
+ else
+ echo "$name: WRONG OUTPUT (diff follows)"
+ diff -u "$ref" "$out"
+ exit 2
+ fi
+ else
+ echo "$name: passed"
+ exit 0
+ fi
+else
+ retcode=$?
+ if $expect_fail; then
+ echo "$name: passed (failed as expected)"
+ exit 0
+ else
+ echo "$name: EXECUTION FAILED (status $retcode)"
+ exit 2
+ fi
+fi
+
diff --git a/test/c/aes.c b/test/c/aes.c
index 28d51a78..0a64fe60 100644
--- a/test/c/aes.c
+++ b/test/c/aes.c
@@ -27,6 +27,7 @@
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
+#include "../endian.h"
#define MAXKC (256/32)
#define MAXKB (256/8)
@@ -36,15 +37,6 @@ typedef unsigned char u8;
typedef unsigned short u16;
typedef unsigned int u32;
-#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__)
-#define ARCH_BIG_ENDIAN
-#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \
- || defined(__riscv) || defined(__K1C__)
-#undef ARCH_BIG_ENDIAN
-#else
-#error "unknown endianness"
-#endif
-
#ifdef ARCH_BIG_ENDIAN
#define GETU32(pt) (*(u32 *)(pt))
#define PUTU32(ct,st) (*(u32 *)(ct) = (st))
@@ -1449,6 +1441,10 @@ int main(int argc, char ** argv)
(u8 *)"\x00\x11\x22\x33\x44\x55\x66\x77\x88\x99\xAA\xBB\xCC\xDD\xEE\xFF",
(u8 *)"\x8E\xA2\xB7\xCA\x51\x67\x45\xBF\xEA\xFC\x49\x90\x4B\x49\x60\x89",
5, 6);
+#ifdef __K1C__
+ do_bench(2000);
+#else
do_bench(1000000);
+#endif
return 0;
}
diff --git a/test/c/almabench.c b/test/c/almabench.c
index 5487b062..4417200c 100644
--- a/test/c/almabench.c
+++ b/test/c/almabench.c
@@ -42,10 +42,15 @@
#define R2D (180.0 / PI)
#define GAUSSK 0.01720209895
#define TEST_LOOPS 20
-#define TEST_LENGTH 36525
#define sineps 0.3977771559319137
#define coseps 0.9174820620691818
+#ifdef __K1C__
+#define TEST_LENGTH 12
+#else
+#define TEST_LENGTH 36525
+#endif
+
const double amas [8] = { 6023600.0, 408523.5, 328900.5, 3098710.0, 1047.355, 3498.5, 22869.0, 19314.0 };
const double a [8][3] =
diff --git a/test/c/binarytrees.c b/test/c/binarytrees.c
index b4b10232..becae164 100644
--- a/test/c/binarytrees.c
+++ b/test/c/binarytrees.c
@@ -7,6 +7,7 @@
icc -O3 -ip -unroll -static binary-trees.c -lm
*/
+#include <assert.h>
#include <math.h>
#include <stdio.h>
#include <stdlib.h>
@@ -24,6 +25,7 @@ treeNode* NewTreeNode(treeNode* left, treeNode* right, long item)
treeNode* new;
new = (treeNode*)malloc(sizeof(treeNode));
+ assert(new != NULL && "NewTreeNode: new malloc failed");
new->left = left;
new->right = right;
@@ -73,7 +75,11 @@ int main(int argc, char* argv[])
unsigned N, depth, minDepth, maxDepth, stretchDepth;
treeNode *stretchTree, *longLivedTree, *tempTree;
+#ifdef __K1C__
+ N = argc < 2 ? 6 : atol(argv[1]);
+#else
N = argc < 2 ? 12 : atol(argv[1]);
+#endif
minDepth = 4;
diff --git a/test/c/chomp.c b/test/c/chomp.c
index c88cef5c..7e2f62c1 100644
--- a/test/c/chomp.c
+++ b/test/c/chomp.c
@@ -106,7 +106,7 @@ void dump_play(struct _play *play) /* and for the entire game tree */
int get_value(int *data) /* get the value (0 or 1) for a specific _data */
{
struct _play *search;
- search = game_tree; /* start at the begginig */
+ search = game_tree; /* start at the beginning */
while (! equal_data(search -> state,data)) /* until you find a match */
search = search -> next; /* take next element */
return search -> value; /* return its value */
@@ -138,7 +138,7 @@ void show_list(struct _list *list) /* show the entire list of moves */
}
}
-void show_play(struct _play *play) /* to diplay the whole tree */
+void show_play(struct _play *play) /* to display the whole tree */
{
while (play != NULL)
{
@@ -154,7 +154,7 @@ void show_play(struct _play *play) /* to diplay the whole tree */
int in_wanted(int *data) /* checks if the current _data is in the wanted list */
{
struct _list *current;
- current = wanted; /* start at the begginig */
+ current = wanted; /* start at the beginning */
while (current != NULL) /* unitl the last one */
{
if (equal_data(current -> data,data)) break; /* break if found */
@@ -338,8 +338,13 @@ int main(void)
struct _play *tree;
+#ifdef __K1C__
+ ncol = 4;
+ nrow = 4;
+#else
ncol = 7;
nrow = 7;
+#endif
tree = make_play(1); /* create entire tree structure, not just the */
player = 0; /* needed part for first move */
current = make_data(nrow,ncol); /* start play at full board */
diff --git a/test/c/fannkuch.c b/test/c/fannkuch.c
index 9cc7a693..befccd8d 100644
--- a/test/c/fannkuch.c
+++ b/test/c/fannkuch.c
@@ -8,6 +8,7 @@
* $Id: fannkuch-gcc.code,v 1.33 2006/02/25 16:38:58 igouy-guest Exp $
*/
+#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
@@ -31,8 +32,11 @@ fannkuch( int n )
if( n < 1 ) return 0;
perm = calloc(n, sizeof(*perm ));
+ assert(perm != NULL && "fannkuch: perm malloc failed");
perm1 = calloc(n, sizeof(*perm1));
+ assert(perm != NULL && "fannkuch: perm1 malloc failed");
count = calloc(n, sizeof(*count));
+ assert(perm != NULL && "fannkuch: count malloc failed");
for( i=0 ; i<n ; ++i ) perm1[i] = i; /* initial (trivial) permu */
@@ -98,7 +102,11 @@ fannkuch( int n )
int
main( int argc, char* argv[] )
{
+#ifdef __K1C__
+ int n = (argc>1) ? atoi(argv[1]) : 6;
+#else
int n = (argc>1) ? atoi(argv[1]) : 10;
+#endif
printf("Pfannkuchen(%d) = %ld\n", n, fannkuch(n));
return 0;
diff --git a/test/c/fft.c b/test/c/fft.c
index 2bd55a18..8ab59c9a 100644
--- a/test/c/fft.c
+++ b/test/c/fft.c
@@ -3,6 +3,7 @@
by: Dave Edelblute, edelblut@cod.nosc.mil, 05 Jan 1993
*/
+#include <assert.h>
#include <math.h>
#include <stdlib.h>
#include <stdio.h>
@@ -151,13 +152,19 @@ int main(int argc, char ** argv)
double enp, t, y, z, zr, zi, zm, a;
double * xr, * xi, * pxr, * pxi;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 10;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 18;
+#endif
np = 1 << n;
enp = np;
npm = np / 2 - 1;
t = PI / enp;
xr = calloc(np, sizeof(double));
+ assert(xr != NULL && "xr calloc failed");
xi = calloc(np, sizeof(double));
+ assert(xi != NULL && "xi calloc failed");
pxr = xr;
pxi = xi;
for (nruns = 0; nruns < NRUNS; nruns++) {
diff --git a/test/c/fftsp.c b/test/c/fftsp.c
index 26b18b62..d327a74c 100644
--- a/test/c/fftsp.c
+++ b/test/c/fftsp.c
@@ -153,7 +153,11 @@ int main(int argc, char ** argv)
float enp, t, y, z, zr, zi, zm, a;
float * xr, * xi, * pxr, * pxi;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 3;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 12;
+#endif
np = 1 << n;
enp = np;
npm = np / 2 - 1;
diff --git a/test/c/fftw.c b/test/c/fftw.c
index 913091d9..04d896ad 100644
--- a/test/c/fftw.c
+++ b/test/c/fftw.c
@@ -74,7 +74,11 @@ const E KP1_847759065 = ((E) +1.847759065022573512256366378793576573644833252);
/* Test harness */
+#ifdef __K1C__
+#define NRUNS (10 * 10)
+#else
#define NRUNS (100 * 1000)
+#endif
int main()
{
diff --git a/test/c/fib.c b/test/c/fib.c
index e4c7d095..168626bc 100644
--- a/test/c/fib.c
+++ b/test/c/fib.c
@@ -12,7 +12,11 @@ int fib(int n)
int main(int argc, char ** argv)
{
int n, r;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 15;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 35;
+#endif
r = fib(n);
printf("fib(%d) = %d\n", n, r);
return 0;
diff --git a/test/c/integr.c b/test/c/integr.c
index 882325c3..cd0521f5 100644
--- a/test/c/integr.c
+++ b/test/c/integr.c
@@ -25,7 +25,11 @@ double test(int n)
int main(int argc, char ** argv)
{
int n; double r;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 100000;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 10000000;
+#endif
r = test(n);
printf("integr(square, 0.0, 1.0, %d) = %g\n", n, r);
return 0;
diff --git a/test/c/knucleotide.c b/test/c/knucleotide.c
index 3ac469be..1982834e 100644
--- a/test/c/knucleotide.c
+++ b/test/c/knucleotide.c
@@ -8,6 +8,7 @@
http://cvs.alioth.debian.org/cgi-bin/cvsweb.cgi/shootout/bench/Include/?cvsroot=shootout
*/
+#include <assert.h>
#include <stdio.h>
#include <string.h>
#include <ctype.h>
@@ -76,9 +77,11 @@ struct ht_node *ht_node_create(char *key) {
struct ht_ht *ht_create(int size) {
int i = 0;
struct ht_ht *ht = (struct ht_ht *)malloc(sizeof(struct ht_ht));
+ assert (ht != NULL && "ht_create: ht malloc failed");
while (ht_prime_list[i] < size) { i++; }
ht->size = ht_prime_list[i];
ht->tbl = (struct ht_node **)calloc(ht->size, sizeof(struct ht_node *));
+ assert (ht->tbl != NULL && "ht_create: ht->tbl calloc failed");
ht->iter_index = 0;
ht->iter_next = 0;
ht->items = 0;
@@ -250,6 +253,7 @@ write_frequencies (int fl, char *buffer, long buflen)
size++;
}
s = calloc (size, sizeof (sorter));
+ assert(s != NULL && "write_frequencies: s alloc failed");
i = 0;
for (nd = ht_first (ht); nd != NULL; nd = ht_next (ht))
{
@@ -293,6 +297,7 @@ main ()
FILE * f;
line = malloc (256);
+ assert (line != NULL && "line alloc failed");
if (!line)
return 2;
seqlen = 0;
@@ -308,6 +313,7 @@ main ()
buflen = 10240;
buffer = malloc (buflen + 1);
+ assert (buffer != NULL && "buffer alloc failed");
if (!buffer)
return 2;
x = buffer;
diff --git a/test/c/lists.c b/test/c/lists.c
index ced384c0..8deb0f37 100644
--- a/test/c/lists.c
+++ b/test/c/lists.c
@@ -1,5 +1,6 @@
/* List manipulations */
+#include <assert.h>
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
@@ -11,6 +12,7 @@ struct list * buildlist(int n)
struct list * r;
if (n < 0) return NULL;
r = malloc(sizeof(struct list));
+ assert(r != NULL && "buildlist: r malloc failed");
r->hd = n;
r->tl = buildlist(n - 1);
return r;
@@ -21,6 +23,7 @@ struct list * reverselist (struct list * l)
struct list * r, * r2;
for (r = NULL; l != NULL; l = l->tl) {
r2 = malloc(sizeof(struct list));
+ assert(r2 != NULL && "reverselist: r2 malloc failed");
r2->hd = l->hd;
r2->tl = r;
r = r2;
@@ -58,8 +61,13 @@ int main(int argc, char ** argv)
int n, niter, i;
struct list * l;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 500;
+ if (argc >= 3) niter = atoi(argv[1]); else niter = 100;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 1000;
if (argc >= 3) niter = atoi(argv[1]); else niter = 20000;
+#endif
l = buildlist(n);
if (checklist(n, reverselist(l))) {
printf("OK\n");
diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c
index 032e7d75..548c3ffa 100644
--- a/test/c/mandelbrot.c
+++ b/test/c/mandelbrot.c
@@ -17,12 +17,20 @@ int main (int argc, char **argv)
{
int w, h, bit_num = 0;
char byte_acc = 0;
+#ifdef __K1C__
+ int i, iter = 30;
+#else
int i, iter = 50;
+#endif
double x, y, limit = 2.0;
double Zr, Zi, Cr, Ci, Tr, Ti;
if (argc < 2) {
+#ifdef __K1C__
+ w = h = 40;
+#else
w = h = 1000;
+#endif
} else {
w = h = atoi(argv[1]);
}
@@ -52,6 +60,9 @@ int main (int argc, char **argv)
if(bit_num == 8)
{
putc(byte_acc,stdout);
+#ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster
+ fflush(stdout);
+#endif
byte_acc = 0;
bit_num = 0;
}
@@ -59,6 +70,9 @@ int main (int argc, char **argv)
{
byte_acc <<= (8-w%8);
putc(byte_acc,stdout);
+#ifdef __K1C__ // stdout isn't flushed enough when --syscall=libstd_scalls.so is passed to the simulator k1-cluster
+ fflush(stdout);
+#endif
byte_acc = 0;
bit_num = 0;
}
diff --git a/test/c/nbody.c b/test/c/nbody.c
index 530c41fa..ab0ebabe 100644
--- a/test/c/nbody.c
+++ b/test/c/nbody.c
@@ -140,7 +140,11 @@ void setup_bodies(void)
int main(int argc, char ** argv)
{
+#ifdef __K1C__
+ int n = argc < 2 ? 100 : atoi(argv[1]);
+#else
int n = argc < 2 ? 1000000 : atoi(argv[1]);
+#endif
int i;
setup_bodies();
diff --git a/test/c/nsieve.c b/test/c/nsieve.c
index 819d47f1..3954bcbe 100644
--- a/test/c/nsieve.c
+++ b/test/c/nsieve.c
@@ -29,10 +29,18 @@ static unsigned int nsieve(int m) {
#define NITER 2
int main(int argc, char * argv[]) {
+#ifdef __K1C__
+ int m = argc < 2 ? 6 : atoi(argv[1]);
+#else
int m = argc < 2 ? 9 : atoi(argv[1]);
+#endif
int i, j;
for (i = 0; i < 3; i++) {
+#ifdef __K1C__
+ int n = 200 << (m-i);
+#else
int n = 10000 << (m-i);
+#endif
unsigned count;
for (j = 0; j < NITER; j++) { count = nsieve(n); }
printf("Primes up to %8d %8u\n", n, count);
diff --git a/test/c/nsievebits.c b/test/c/nsievebits.c
index 743a5ffd..e3b7fd43 100644
--- a/test/c/nsievebits.c
+++ b/test/c/nsievebits.c
@@ -30,7 +30,11 @@ nsieve(unsigned int m)
return (count);
}
+#ifdef __K1C__
+#define NITER 1
+#else
#define NITER 2
+#endif
static void
test(unsigned int n)
@@ -48,7 +52,11 @@ main(int ac, char **av)
{
unsigned int n;
+#ifdef __K1C__
+ n = ac < 2 ? 2 : atoi(av[1]);
+#else
n = ac < 2 ? 9 : atoi(av[1]);
+#endif
test(n);
if (n >= 1)
test(n - 1);
diff --git a/test/c/perlin.c b/test/c/perlin.c
index e7bbd22d..29ebf964 100644
--- a/test/c/perlin.c
+++ b/test/c/perlin.c
@@ -63,13 +63,22 @@ static void init(void) {
p[256+i] = p[i] = permutation[i];
}
+#ifdef __K1C__
+#define INCREMENT 0.5
+#define MIN -3.0
+#define MAX 3.0
+#else
+#define INCREMENT 0.1
+#define MIN -5.0
+#define MAX 5.0
+#endif
int main(int argc, char ** argv) {
init();
double x, y, z, sum = 0.0;
- for (x = -5.0; x < 5.0; x += 0.1)
- for (y = -5.0; y < 5.0; y += 0.1)
- for (z = -5.0; z < 5.0; z += 0.1)
+ for (x = MIN; x < MAX; x += INCREMENT)
+ for (y = MIN; y < MAX; y += INCREMENT)
+ for (z = MIN; z < MAX; z += INCREMENT)
sum += noise(x, y, z);
printf("%.4e\n", sum);
diff --git a/test/c/qsort.c b/test/c/qsort.c
index 66eef68d..1ebe1e11 100644
--- a/test/c/qsort.c
+++ b/test/c/qsort.c
@@ -34,7 +34,11 @@ int main(int argc, char ** argv)
int n, i, j;
int * a, * b;
+#ifdef __K1C__
+ if (argc >= 2) n = atoi(argv[1]); else n = 500;
+#else
if (argc >= 2) n = atoi(argv[1]); else n = 100000;
+#endif
a = malloc(n * sizeof(int));
b = malloc(n * sizeof(int));
for (j = 0; j < NITER; j++) {
diff --git a/test/c/sha1.c b/test/c/sha1.c
index 0a6ac8fe..624030cc 100644
--- a/test/c/sha1.c
+++ b/test/c/sha1.c
@@ -231,6 +231,10 @@ int main(int argc, char ** argv)
}
do_test(test_input_1, test_output_1);
do_test(test_input_2, test_output_2);
+#ifdef __K1C__
+ do_bench(500);
+#else
do_bench(200000);
+#endif
return 0;
}
diff --git a/test/c/sha3.c b/test/c/sha3.c
index a0905817..164e3086 100644
--- a/test/c/sha3.c
+++ b/test/c/sha3.c
@@ -190,8 +190,13 @@ test_triplet_t testvec[4] = {
}
};
+#ifdef __K1C__
+#define DATALEN 1000
+#define NITER 7
+#else
#define DATALEN 100000
#define NITER 25
+#endif
int main()
{
diff --git a/test/c/siphash24.c b/test/c/siphash24.c
index 4a42e013..ce0df78c 100644
--- a/test/c/siphash24.c
+++ b/test/c/siphash24.c
@@ -235,13 +235,19 @@ int test_vectors()
u8 testdata[100] = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 12, 34, 56, 78, 90 };
+#ifdef __K1C__
+#define NITER 1000
+#else
+#define NITER 1000000
+#endif
+
int speed_test(void)
{
u8 out[8], k[16];
int i;
for(i = 0; i < 16; ++i ) k[i] = i;
- for(i = 0; i < 1000000; i++) {
+ for(i = 0; i < NITER; i++) {
testdata[99] = (u8) i;
crypto_auth(out, testdata, 100, k);
}
diff --git a/test/c/spectral.c b/test/c/spectral.c
index f7dc90ee..dca78fe0 100644
--- a/test/c/spectral.c
+++ b/test/c/spectral.c
@@ -43,7 +43,11 @@ void eval_AtA_times_u(int N, const double u[], double AtAu[])
int main(int argc, char *argv[])
{
int i;
+#ifdef __K1C__
+ int N = ((argc == 2) ? atoi(argv[1]) : 11);
+#else
int N = ((argc == 2) ? atoi(argv[1]) : 1000);
+#endif
double * u, * v, vBv, vv;
u = malloc(N * sizeof(double));
v = malloc(N * sizeof(double));
diff --git a/test/c/vmach.c b/test/c/vmach.c
index 815cb710..5858d4d6 100644
--- a/test/c/vmach.c
+++ b/test/c/vmach.c
@@ -159,8 +159,14 @@ long wordcode_interp(unsigned int* code)
#define I(a,b,c,d) ((a) + ((b) << 8) + ((c) << 16) + ((d) << 24))
+#ifdef __K1C__
+#define FIBSIZE 15
+#else
+#define FIBSIZE 30
+#endif
+
unsigned int wordcode_fib[] = {
-/* 0 */ I(WCONST, 30, 0, 0),
+/* 0 */ I(WCONST, FIBSIZE, 0, 0),
/* 1 */ I(WCALL1_pop1, 0, 3-1-1, 0),
/* 2 */ I(WSTOP, 0, 1, 0),
/* 3 */ I(WCONST, 2, 0, 0),
@@ -175,10 +181,21 @@ unsigned int wordcode_fib[] = {
/* 12 */ I(WCONST, 1, 0, 0),
/* 13 */ I(WRETURN, 0, 2, 0)
};
+
+#ifdef __K1C__
+#define TAKSIZE1 6
+#define TAKSIZE2 9
+#define TAKSIZE3 12
+#else
+#define TAKSIZE1 6
+#define TAKSIZE2 12
+#define TAKSIZE3 18
+#endif
+
unsigned int wordcode_tak[] = {
-/* 0 */ I(WCONST, 6, 0, 0),
-/* 1 */ I(WCONST, 12, 0, 0),
-/* 2 */ I(WCONST, 18, 0, 0),
+/* 0 */ I(WCONST, TAKSIZE1, 0, 0),
+/* 1 */ I(WCONST, TAKSIZE2, 0, 0),
+/* 2 */ I(WCONST, TAKSIZE3, 0, 0),
/* 3 */ I(WCALL3, 3, 6-3-2, 0),
/* 4 */ I(0, 1, 2, 0),
/* 5 */ I(WSTOP, 0, 1, 0),
@@ -203,8 +220,8 @@ unsigned int wordcode_tak[] = {
int main(int argc, char ** argv)
{
- printf("fib(30) = %ld\n", wordcode_interp(wordcode_fib));
- printf("tak(18, 12, 6) = %ld\n", wordcode_interp(wordcode_tak));
+ printf("fib(%d) = %ld\n", FIBSIZE, wordcode_interp(wordcode_fib));
+ printf("tak(%d, %d, %d) = %ld\n", TAKSIZE3, TAKSIZE2, TAKSIZE1, wordcode_interp(wordcode_tak));
return 0;
}
diff --git a/test/clightgen/issue319.c b/test/clightgen/issue319.c
new file mode 100644
index 00000000..be9f3f7e
--- /dev/null
+++ b/test/clightgen/issue319.c
@@ -0,0 +1,12 @@
+/* Dollar signs in identifiers */
+
+int c$d = 42;
+
+int a$b(int x$$) {
+ return c$d + x$$;
+}
+
+int main(int argc, const char *argv[])
+{
+ return a$b(6);
+}
diff --git a/test/compression/Makefile b/test/compression/Makefile
index 2e14e646..ff7032d5 100644
--- a/test/compression/Makefile
+++ b/test/compression/Makefile
@@ -1,9 +1,11 @@
include ../../Makefile.config
+SIMU=timeout --signal=SIGKILL 20s $(EXECUTE)
+
CC=../../ccomp
CFLAGS=$(CCOMPOPTS) -U__GNUC__ -stdlib ../../runtime -dclight -dasm
LIBS=
-TIME=xtime -o /dev/null -mintime 1.0
+TIME=ocaml unix.cma ../../tools/xtime.ml -mintime 2.0 -minruns 2
EXE=arcode lzw lzss
@@ -30,15 +32,19 @@ TESTFILE:=$(firstword $(wildcard /usr/share/dict/words) ./lzss)
TESTCOMPR=/tmp/testcompr.$$$$
TESTEXPND=/tmp/testexpnd.$$$$
+LIGHTERFILEPRE:=/tmp/lighter
+LIGHTERFILE:=$(LIGHTERFILEPRE)aa
+
test:
- @rm -f $(TESTCOMPR) $(TESTEXPND); \
- echo "Test data: $(TESTFILE)"; \
+ @split -l15 $(TESTFILE) $(LIGHTERFILEPRE); \
+ rm -f $(TESTCOMPR) $(TESTEXPND); \
+ echo "Test data: $(LIGHTERFILE)"; \
for i in $(EXE); do \
echo "$$i: compression..."; \
- $(SIMU) ./$$i -c -i $(TESTFILE) -o $(TESTCOMPR); \
+ $(SIMU) ./$$i -c -i $(LIGHTERFILE) -o $(TESTCOMPR); \
echo "$$i: decompression..."; \
$(SIMU) ./$$i -d -i $(TESTCOMPR) -o $(TESTEXPND); \
- if cmp $(TESTFILE) $(TESTEXPND); \
+ if cmp $(LIGHTERFILE) $(TESTEXPND); \
then echo "$$i: passed"; \
else echo "$$i: FAILED"; exit 2; \
fi; \
@@ -48,8 +54,7 @@ test:
bench:
@rm -f $(TESTCOMPR)
@for i in $(EXE); do \
- echo -n "$$i: "; \
- $(TIME) sh -c "./$$i -c -i $(TESTFILE) -o $(TESTCOMPR) && ./$$i -d -i $(TESTCOMPR) -o /dev/null"; \
+ $(TIME) -name $$i -- sh -c "./$$i -c -i $(TESTFILE) -o $(TESTCOMPR) && ./$$i -d -i $(TESTCOMPR) -o /dev/null"; \
done
@rm -f $(TESTCOMPR)
diff --git a/test/cse2/globals.c b/test/cse2/globals.c
new file mode 100644
index 00000000..c6dd59cd
--- /dev/null
+++ b/test/cse2/globals.c
@@ -0,0 +1,8 @@
+int glob1, glob2;
+
+void toto() {
+ if (glob1 > 4) {
+ glob2 ++;
+ glob1 --;
+ }
+}
diff --git a/test/cse2/indexed_addr.c b/test/cse2/indexed_addr.c
new file mode 100644
index 00000000..30a7c571
--- /dev/null
+++ b/test/cse2/indexed_addr.c
@@ -0,0 +1,6 @@
+void foo(int *t) {
+ if (t[0] > 4) {
+ t[1] ++;
+ t[0] --;
+ }
+}
diff --git a/test/endian.h b/test/endian.h
new file mode 100644
index 00000000..d6e121f4
--- /dev/null
+++ b/test/endian.h
@@ -0,0 +1,8 @@
+#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__)
+#define ARCH_BIG_ENDIAN
+#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \
+ || defined(__riscv) || defined(__aarch64__) || defined(__K1C__)
+#undef ARCH_BIG_ENDIAN
+#else
+#error "unknown endianness"
+#endif
diff --git a/test/monniaux/.gitignore b/test/monniaux/.gitignore
new file mode 100644
index 00000000..c06c2984
--- /dev/null
+++ b/test/monniaux/.gitignore
@@ -0,0 +1,14 @@
+**.host
+**.k1c
+**measures.csv
+
+commands.txt
+oracle_times.txt
+verifier_times.txt
+compile_times.pdf
+measure_times.host.pdf
+measure_times.k1c.pdf
+
+/.mypy_cache/
+
+mbedtls/mbedtls/
diff --git a/test/monniaux/Asmblockdeps.patch b/test/monniaux/Asmblockdeps.patch
new file mode 100644
index 00000000..a2d8c7be
--- /dev/null
+++ b/test/monniaux/Asmblockdeps.patch
@@ -0,0 +1,20 @@
+--- extraction/Asmblockdeps.ml 2019-06-13 15:06:55.493592984 +0200
++++ Asmblockdeps.mod.ml 2019-06-13 15:04:55.900122958 +0200
+@@ -2243,5 +2243,15 @@
+
+ (** val bblock_simub : bblock -> bblock -> bool **)
+
+-let bblock_simub =
+- pure_bblock_simu_test true
++let bblock_simub bb tbb =
++ let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb
++ in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime)
++ in let simub = pure_bblock_simu_test true bb tbb
++ in let refer = ref false
++ in begin
++ for i = 1 to 1000-1 do
++ refer := (if i > 0 then pure_bblock_simu_test true bb tbb else false); (* dumb i > 0 test to lure warning 35 *)
++ done;
++ Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time);
++ simub
++ end
diff --git a/test/monniaux/BearSSL/conf/KalrayCompCert.mk b/test/monniaux/BearSSL/conf/KalrayCompCert.mk
index 9c0e951c..9b34eed2 100644
--- a/test/monniaux/BearSSL/conf/KalrayCompCert.mk
+++ b/test/monniaux/BearSSL/conf/KalrayCompCert.mk
@@ -37,7 +37,7 @@ RM = rm -f
MKDIR = mkdir -p
# C compiler and flags.
-CC = ../../../ccomp -fstruct-passing
+CC = ../../../ccomp -fstruct-passing -fpostpass= ilp -U__SIZEOF_INT128__ -U__SIZEOF_FLOAT128__
CFLAGS = -W -Wall -Wno-c11-extensions -O3 -D_POSIX_C_SOURCE=200909L
CCOUT = -c -o
diff --git a/test/monniaux/BearSSL/mk/mkT0.cmd b/test/monniaux/BearSSL/mk/mkT0.cmd
deleted file mode 100644
index 98955625..00000000
--- a/test/monniaux/BearSSL/mk/mkT0.cmd
+++ /dev/null
@@ -1,32 +0,0 @@
-@echo off
-
-rem =====================================================================
-rem This script uses the command-line C# compiler csc.exe, which is
-rem provided with the .NET framework. We need framework 3.5 or later
-rem (some of the code uses features not available in the language version
-rem implemented in the compiler provided with framework 2.0.50727).
-rem =====================================================================
-
-if exist "%SystemRoot%\Microsoft.NET\Framework\v3.5\csc.exe" (
- set CSC="%SystemRoot%\Microsoft.NET\Framework\v3.5\csc.exe"
- goto do_compile
-)
-if exist "%SystemRoot%\Microsoft.NET\Framework\v4.0.30319\csc.exe" (
- set CSC="%SystemRoot%\Microsoft.NET\Framework\v4.0.30319\csc.exe"
- goto do_compile
-)
-if exist "%SystemRoot%\Microsoft.NET\Framework64\v3.5\csc.exe" (
- set CSC="%SystemRoot%\Microsoft.NET\Framework64\v3.5\csc.exe"
- goto do_compile
-)
-if exist "%SystemRoot%\Microsoft.NET\Framework64\v4.0.30319\csc.exe" (
- set CSC="%SystemRoot%\Microsoft.NET\Framework64\v4.0.30319\csc.exe"
- goto do_compile
-)
-
-echo C# compiler not found
-exit 1
-
-:do_compile
-%CSC% /nologo /out:T0Comp.exe /main:T0Comp /res:T0\kern.t0,t0-kernel T0\*.cs
-if %errorlevel% neq 0 exit /b %errorlevel%
diff --git a/test/monniaux/Makefile b/test/monniaux/Makefile
new file mode 100644
index 00000000..d7437eea
--- /dev/null
+++ b/test/monniaux/Makefile
@@ -0,0 +1,39 @@
+# NOTE: do NOT run this makefile with the -j option
+
+CCOMP?=ccomp
+
+#all: verifier_times.txt oracle_times.txt measures.csv
+all: measures.csv
+
+verifier_times.txt: Asmblockdeps.patch
+ (cd ../../ && make -j20 && make install)
+ patch $(realpath ../../extraction/Asmblockdeps.ml) < $<
+ (cd ../../ && make -j20 && make install); patch -R $(realpath ../../extraction/Asmblockdeps.ml) < $<
+ bash clean_benches.sh
+ bash build_benches.sh $@
+
+oracle_times.txt: PostpassSchedulingOracle.patch
+ (cd ../../ && make -j20 && make install)
+ patch $(realpath ../../mppa_k1c/PostpassSchedulingOracle.ml) < $<
+ (cd ../../ && make -j20 && make install); patch -R $(realpath ../../mppa_k1c/PostpassSchedulingOracle.ml) < $<
+ bash clean_benches.sh
+ bash build_benches.sh $@
+
+measures.csv:
+ @echo "Building compcert.."
+ @(cd ../../ && make -s -j20 && make -s install)
+ @echo "Building benches..."
+ @bash build_benches.sh
+ @echo "Benches built. Running benches..."
+ @bash run_benches.sh $@
+
+#compile_times.pdf: gencompile.py verifier_times.txt oracle_times.txt
+# python3.5 $^ $@
+#
+#measure_times.k1c.pdf: gengraphs.py measures.csv
+# python3.5 $^ $(basename $(basename $@))
+
+.PHONY:
+clean:
+ @bash clean_benches.sh
+ rm -f verifier_times.txt oracle_times.txt compile_times.pdf measure_times.k1c.pdf measures.csv
diff --git a/test/monniaux/PostpassSchedulingOracle.patch b/test/monniaux/PostpassSchedulingOracle.patch
new file mode 100644
index 00000000..31afdbc8
--- /dev/null
+++ b/test/monniaux/PostpassSchedulingOracle.patch
@@ -0,0 +1,33 @@
+diff --git a/mppa_k1c/PostpassSchedulingOracle.ml b/mppa_k1c/PostpassSchedulingOracle.ml
+index 2fc561e..d3748e8 100644
+--- a/mppa_k1c/PostpassSchedulingOracle.ml
++++ b/mppa_k1c/PostpassSchedulingOracle.ml
+@@ -808,7 +808,7 @@ let print_bb oc bb =
+ let asm_instructions = Asm.unfold_bblock bb
+ in List.iter (print_inst oc) asm_instructions
+
+-let do_schedule bb =
++let real_do_schedule bb =
+ let problem = build_problem bb
+ in let solution = (if !Clflags.option_fpostpass_sched = "ilp" then
+ validated_scheduler cascaded_scheduler
+@@ -831,6 +831,19 @@ let do_schedule bb =
+ end;
+ bundles)
+
++let do_schedule bb =
++ let nb_instructions = Camlcoq.Z.to_int64 @@ Asmvliw.size bb
++ in let start_time = (Gc.major(); (Unix.times ()).Unix.tms_utime)
++ in let sched = real_do_schedule bb
++ in let refer = ref sched
++ in begin
++ for i = 1 to 1000-1 do
++ refer := (if i > 0 then real_do_schedule bb else real_do_schedule bb);
++ done;
++ Printf.printf "%Ld: %f\n" nb_instructions ((Unix.times ()).Unix.tms_utime -. start_time);
++ sched
++ end
++
+ (**
+ * Dumb schedule if the above doesn't work
+ *)
diff --git a/test/monniaux/README.md b/test/monniaux/README.md
index 1a4f8e9e..14b062da 100644
--- a/test/monniaux/README.md
+++ b/test/monniaux/README.md
@@ -1,64 +1,107 @@
-## Folders with just source code
-- acswap
-- bitfields
-- crypto-algorithms
-- des
-- fill_buffer
-- jumptable
-- k1_builtins
-- latency
-- longjmp
-- loop
-- madd
-- math
-- memcpy
-- multithreaded_volatile
-- nand
-- predicated
-- regalloc
-- rotate
-- send_through
-- sizeof
-- slow_globals
-- ternary_builtin
-- tiny-AES-c
-- uzlib
-- varargs
-- volatile
-- xor_and_mat
-
-## Special folders
-- csmith
-- jpeg-6b
-- mbedtls
-- quest
-- yarpgen
-
-## Just to be compiled
-- frame_pointer
-
-## Benches to fix
-- BearSSL : does not compile (to fix)
-- ncompress : error on comparing
-- ocaml : error during postpass scheduling
-- micro-bunzip : -O3 buggy with gcc ?
-- mod_int_mat : does not include rules.mk
-- pcre2test : Trap MEMORY ACCESS VIOLATION sur le binaire ccomp
-- picosat : compilation error : implicit declaration
-
-## Benches that work
-- binary_search
-- bitsliced-aes
-- bitsliced-tea
-- complex
-- float_mat
-- glibc_qsort
-- heapsort
-- idea
-- number_theoretic_transform
-- quicksort
-- sha-2
-- tacle-bench-lift
-- tacle-bench-powerwindow
-- ternary
-- too_slow
+# Benchmarking `CompCert` and GCC
+
+## Compiling `CompCert`
+
+The first step to benchmark `CompCert` is to compile it - the `INSTALL.md` instructions of the project root folder should guide you on installing it.
+
+For the benchmarks to work, the compiler `ccomp` should be on your `$PATH`, with the runtime libraries installed correctly (with a successful `make install` on the project root directory).
+
+## Using the harness
+
+`rules.mk` contains generic rules to compile with `gcc` and `ccomp`, with different optimizations, and producing different binaries. It also produces a `measures.csv` file containing the different timings given by the bench.
+
+Up to 5 different sets of optimizations per compiler can be used.
+
+To use this `rules.mk`, create a folder, put inside all the .c/.h source files, and write a Makefile resembling:
+```make
+TARGET=float_mat
+MEASURES="c1 c2 c3 c4 c5 c6 c7 c8"
+
+include ../rules.mk
+```
+
+This is all that is required to write, the `rules.mk` handles everything.
+
+There is the possibility to define some variables to fine tune what you want. For instance, `ALL_CFILES` describes the .c source files whose objects are to be linked.
+
+Here is an exhaustive list of the variables:
+- `TARGET`: name of the binary to produce
+- `MEASURES`: list of the different timings. This supposes that the program
+prints something of the form `c3 cycles: 44131`.
+- `ALL_CFILES`: list of .c files to compile. By default, `$(wildcard *.c)`
+- `CLOCK`: `basename` of the clock file to compile. Default `../clock`
+- `ALL_CFLAGS`: `cflags` that are to be included for all compilers
+- `ALL_GCCFLAGS`: same, but GCC specific
+- `ALL_CCOMPFLAGS`: same, but `ccomp` specific
+- `K1C_CC`: GCC compiler (default `k1-cos-gcc`)
+- `K1C_CCOMP`: `CompCert` compiler (default `ccomp`)
+- `EXECUTE_CYCLES`: running command (default is `k1-cluster --syscall=libstd_scalls.so --cycle-based --`)
+- `EXECUTE_ARGS`: execution arguments. You can use a macro `__BASE__` which expands to the name of the binary being executed.
+- `GCCiFLAGS` with `i` from 0 to 4: the wanted optimizations. If one of these flags is empty, nothing is done. Same for `CCOMPiFLAGS`. Look at `rules.mk` to see the default values. You might find something like this:
+
+ # You can define up to GCC4FLAGS and CCOMP4FLAGS
+ GCC0FLAGS?=
+ GCC1FLAGS?=$(ALL_GCCFLAGS) -O1
+ GCC2FLAGS?=$(ALL_GCCFLAGS) -O2
+ GCC3FLAGS?=$(ALL_GCCFLAGS) -O3
+ GCC4FLAGS?=
+ CCOMP0FLAGS?=
+ CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -fno-postpass
+ CCOMP2FLAGS?=$(ALL_CCOMPFLAGS)
+ CCOMP3FLAGS?=
+ CCOMP4FLAGS?=
+
+ # Prefix names
+ GCC0PREFIX?=
+ GCC1PREFIX?=.gcc.o1
+ GCC2PREFIX?=.gcc.o2
+ GCC3PREFIX?=.gcc.o3
+ GCC4PREFIX?=
+ CCOMP0PREFIX?=
+ CCOMP1PREFIX?=.ccomp.o1
+ CCOMP2PREFIX?=.ccomp.o2
+ CCOMP3PREFIX?=
+ CCOMP4PREFIX?=
+
+The `PREFIX` are the prefixes to add to the secondary produced files (assembly, object, executable, ..). You should be careful that if a `FLAGS` is set, then the according `PREFIX` should be set as well.
+
+Assembly files are generated in `asm/`, objects in `obj/`, binaries in `bin/` and outputs in `out/`.
+
+To compile and execute all the benches : `make` while in the `monniaux` directory (without any `-j` flag). Doing so will compile CompCert, install it, and then proceed to execute each bench.
+
+To compile and/or execute a single bench, `cd` to the bench directory, then:
+- `make` for compiling the bench
+- `make run` for running it
+
+You can use `-j` flag when in a single bench directory.
+
+## Individual scripts
+
+If you want to run the building and running scripts individually without having to use the `Makefile` from `test/monniaux`, you can run the `build_benches.sh` script which builds each bench using all the available cores on your machine.
+
+Once the benches are built, you can then run `run_benches.sh file.csv` where `file.csv` is where you want to store the timings of the benchmarks. `run_benches.sh` also uses all the available cores of your machine.
+
+## Adding timings to a benchmark
+
+If you just add a benchmark without any timing function, the resulting `measures.csv` file will be empty for lack of timing output.
+
+To add a timing, you must use the functions whose prototypes are in `clock.h`
+
+ #include "../clock.h"
+ /* ... */
+ clock_prepare();
+ /* ... */
+ clock_start();
+ /* .. computations .. */
+ clock_stop();
+ /* ... */
+ print_total_clock(); // print to stdout
+ printerr_total_clock(); // print to stderr
+
+If the benchmark doesn't use `stdout` in a binary way you can use `print_total_clock()`. However, some benchmarks like `jpeg-6b` print their binary content to `stdout`, which then messes up the `grep` command when attempting to use it to extract the cycles from `stdout`.
+
+The solution is then to use `printerr_total_clock()` which will print the cycles to `stderr`, and use `EXECUTE_ARGS` ressembling this:
+
+ EXECUTE_ARGS=-dct int -outfile __BASE__.jpg testimg.ppm 2> __BASE__.out
+
+`__BASE__` is a macro that gets expanded to the base name - that is, the `TARGET` concatenated with one of the `GCCiPREFIX` or `CCOMPiPREFIX`. For instance, in `jpeg-6b`, `__BASE__` could be `jpeg-6b.ccomp.o2`.
diff --git a/test/monniaux/benches.sh b/test/monniaux/benches.sh
index 9bca6b42..434e1b15 100644
--- a/test/monniaux/benches.sh
+++ b/test/monniaux/benches.sh
@@ -1 +1,3 @@
-benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow ternary too_slow"
+benches="binary_search bitsliced-aes bitsliced-tea complex float_mat glibc_qsort heapsort idea number_theoretic_transform quicksort sha-2 tacle-bench-lift tacle-bench-powerwindow too_slow heptagon_radio_transmitter lustrev4_lustrec_heater_control lustrev4_lv4_heater_control lustrev4_lv6-en-2cgc_heater_control lustrev6-convertible-en-2cgc xor_and_mat glpk-4.65 picosat-965 genann jpeg-6b zlib-1.2.11 ocaml tiff-4.0.10 ncompress"
+
+# Removed for now : ternary
diff --git a/test/monniaux/binary_search/Makefile b/test/monniaux/binary_search/Makefile
new file mode 100644
index 00000000..924f4217
--- /dev/null
+++ b/test/monniaux/binary_search/Makefile
@@ -0,0 +1,4 @@
+TARGET=binary_search
+MEASURES="randomfill search1 search2 search3 search4"
+
+include ../rules.mk
diff --git a/test/monniaux/binary_search/binary_search.c b/test/monniaux/binary_search/binary_search.c
index 24d1b122..f16d15b8 100644
--- a/test/monniaux/binary_search/binary_search.c
+++ b/test/monniaux/binary_search/binary_search.c
@@ -2,7 +2,6 @@
#include <stdlib.h>
#include <inttypes.h>
#include "../clock.h"
-#include "../ternary.h"
typedef int data;
typedef unsigned index;
@@ -31,8 +30,8 @@ int my_bsearch2 (data *a, index n, data x) {
index k = (i + j) / 2;
index kp1 = k+1, km1 = k-1;
data ak = a[k];
- i = TERNARY32(ak < x, kp1, i);
- j = TERNARY32(ak > x, km1, j);
+ i = ak < x ? kp1 : i;
+ j = ak > x ? km1 : j;
if (ak == x) {
return k;
}
@@ -47,8 +46,8 @@ int my_bsearch3 (data *a, index n, data x) {
index kp1 = k+1, km1 = k-1;
data ak = a[k];
_Bool lt = ak < x, gt = ak > x;
- i = TERNARY32(lt, kp1, i);
- j = TERNARY32(gt, km1, j);
+ i = lt ? kp1 : i;
+ j = gt ? km1 : j;
if (ak == x) {
return k;
}
@@ -63,8 +62,8 @@ int my_bsearch4 (data *a, index n, data x) {
index kp1 = k+1, km1 = k-1;
data ak = a[k];
_Bool lt = ak < x, gt = ak > x;
- i = TERNARY32(lt, kp1, i);
- j = TERNARY32(gt, km1, j);
+ i = lt ? kp1 : i;
+ j = gt ? km1 : j;
if (ak == x) {
goto end;
}
@@ -81,7 +80,7 @@ void random_ascending_fill(data *a, index n) {
for(index i=0; i<n; i++) {
a[i] = v;
v++;
- v = TERNARY32(r & 0x40000000, v+1, v);
+ v = (r & 0x40000000) ? (v+1) : v;
r = r * 97 + 5;
}
}
@@ -119,7 +118,7 @@ int main () {
"position2: %d\n"
"position3: %d\n"
"position4: %d\n"
- "random fill cycles: %" PRIu64 "\n"
+ "randomfill cycles: %" PRIu64 "\n"
"search1 cycles: %" PRIu64 "\n"
"search2 cycles: %" PRIu64 "\n"
"search3 cycles: %" PRIu64 "\n"
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized01 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized01
deleted file mode 100644
index 7d9df872..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized01
+++ /dev/null
@@ -1,204 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position: %d\012random fill cycles: %lu\012search cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L105:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L106
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L107
-;;
- addw $r8 = $r8, 1
-;;
-.L107:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L105
-;;
-.L106:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -64
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
- make $r22, 5000
- call malloc
-;;
- addd $r21 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r22, 0
- addd $r0 = $r21, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r19 = $r18, $r0
- call get_current_cycle
-;;
- addd $r20 = $r0, 0
- make $r2, 1502
- addd $r1 = $r22, 0
- addd $r0 = $r21, 0
- call my_bsearch
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r3 = $r20, $r0
- make $r0 = __stringlit_1
- addd $r2 = $r19, 0
- addd $r1 = $r18, 0
- call printf
-;;
- addd $r0 = $r21, 0
- call free
-;;
- make $r0, 0
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 64
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized02 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized02
deleted file mode 100644
index b148e33f..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized02
+++ /dev/null
@@ -1,203 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position: %d\012random fill cycles: %lu\012search cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
- compw.lt $r33 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- cb.wnez $r33? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L105:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L106
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L107
-;;
- addw $r8 = $r8, 1
-;;
-.L107:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L105
-;;
-.L106:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -64
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
- make $r22, 5000
- call malloc
-;;
- addd $r21 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r22, 0
- addd $r0 = $r21, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r19 = $r18, $r0
- call get_current_cycle
-;;
- addd $r20 = $r0, 0
- make $r2, 1502
- addd $r1 = $r22, 0
- addd $r0 = $r21, 0
- call my_bsearch
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r3 = $r20, $r0
- make $r0 = __stringlit_1
- addd $r2 = $r19, 0
- addd $r1 = $r18, 0
- call printf
-;;
- addd $r0 = $r21, 0
- call free
-;;
- make $r0, 0
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 64
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized03 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized03
deleted file mode 100644
index 8eabb5dd..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized03
+++ /dev/null
@@ -1,291 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position1: %d\012position2: %d\012random fill cycles: %lu\012search1 cycles: %lu\012search2 cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl my_bsearch2
-my_bsearch2:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
- addw $r4 = $r1, -1
-;;
-.L105:
- addw $r9 = $r5, $r4
-;;
- srlw $r1 = $r9, 1
-;;
- lws.xs $r7 = $r1[$r0]
-;;
- compw.ne $r32 = $r7, $r2
-;;
- cb.wnez $r32? .L106
-;;
- addd $r0 = $r1, 0
- goto .L107
-;;
-.L106:
- compw.lt $r3 = $r7, $r2
- addw $r6 = $r1, 1
- addw $r1 = $r1, -1
-;;
- cmoved.wnez $r3? $r5 = $r6
- compw.gt $r6 = $r7, $r2
-;;
- cmoved.wnez $r6? $r4 = $r1
-;;
- compw.leu $r32 = $r5, $r4
-;;
- cb.wnez $r32? .L105
-;;
- make $r0, -1
-;;
-.L107:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch2, @function
- .size my_bsearch2, . - my_bsearch2
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L108:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L109
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L110
-;;
- addw $r8 = $r8, 1
-;;
-.L110:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L108
-;;
-.L109:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -80
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
-;;
- sd 56[$r12] = $r23
- make $r23, 1502
-;;
- sd 64[$r12] = $r24
- make $r24, 5000
-;;
- sd 72[$r12] = $r25
- call malloc
-;;
- addd $r19 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r21 = $r18, $r0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- addd $r22 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r20 = $r18, $r0
- call get_current_cycle
-;;
- addd $r25 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch2
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r5 = $r25, $r0
- make $r0 = __stringlit_1
- addd $r4 = $r20, 0
- addd $r3 = $r21, 0
-;;
- addd $r2 = $r18, 0
- addd $r1 = $r22, 0
- call printf
-;;
- addd $r0 = $r19, 0
- call free
-;;
- make $r0, 0
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
- set $ra = $r16
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r24 = 64[$r12]
-;;
- ld $r25 = 72[$r12]
-;;
- addd $r12 = $r12, 80
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized04 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized04
deleted file mode 100644
index 2e4ff5c6..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized04
+++ /dev/null
@@ -1,288 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position1: %d\012position2: %d\012random fill cycles: %lu\012search1 cycles: %lu\012search2 cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl my_bsearch2
-my_bsearch2:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
- addw $r4 = $r1, -1
-;;
-.L105:
- addw $r9 = $r5, $r4
-;;
- srlw $r1 = $r9, 1
-;;
- lws.xs $r7 = $r1[$r0]
-;;
- compw.ne $r32 = $r7, $r2
-;;
- cb.weqz $r32? .L107
-;;
- compw.lt $r3 = $r7, $r2
- addw $r6 = $r1, 1
- addw $r1 = $r1, -1
-;;
- cmoved.wnez $r3? $r5 = $r6
- compw.gt $r6 = $r7, $r2
-;;
- cmoved.wnez $r6? $r4 = $r1
-;;
- compw.leu $r32 = $r5, $r4
-;;
- cb.wnez $r32? .L105
-;;
- make $r0, -1
-;;
-.L107:
- addd $r0 = $r1, 0
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch2, @function
- .size my_bsearch2, . - my_bsearch2
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L108:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L109
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L110
-;;
- addw $r8 = $r8, 1
-;;
-.L110:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L108
-;;
-.L109:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -80
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
-;;
- sd 56[$r12] = $r23
- make $r23, 1502
-;;
- sd 64[$r12] = $r24
- make $r24, 5000
-;;
- sd 72[$r12] = $r25
- call malloc
-;;
- addd $r19 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r21 = $r18, $r0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- addd $r22 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r20 = $r18, $r0
- call get_current_cycle
-;;
- addd $r25 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch2
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r5 = $r25, $r0
- make $r0 = __stringlit_1
- addd $r4 = $r20, 0
- addd $r3 = $r21, 0
-;;
- addd $r2 = $r18, 0
- addd $r1 = $r22, 0
- call printf
-;;
- addd $r0 = $r19, 0
- call free
-;;
- make $r0, 0
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
- set $ra = $r16
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r24 = 64[$r12]
-;;
- ld $r25 = 72[$r12]
-;;
- addd $r12 = $r12, 80
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized05 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized05
deleted file mode 100644
index 9f54a967..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized05
+++ /dev/null
@@ -1,287 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position1: %d\012position2: %d\012random fill cycles: %lu\012search1 cycles: %lu\012search2 cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl my_bsearch2
-my_bsearch2:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
- addw $r4 = $r1, -1
-;;
-.L105:
- addw $r9 = $r5, $r4
-;;
- srlw $r1 = $r9, 1
-;;
- lws.xs $r7 = $r1[$r0]
-;;
- compw.ne $r32 = $r7, $r2
-;;
- cb.weqz $r32? .L107
-;;
- compw.lt $r3 = $r7, $r2
- compw.gt $r8 = $r7, $r2
- addw $r6 = $r1, 1
- addw $r1 = $r1, -1
-;;
- cmoved.wnez $r3? $r5 = $r6
- cmoved.wnez $r8? $r4 = $r1
-;;
- compw.leu $r32 = $r5, $r4
-;;
- cb.wnez $r32? .L105
-;;
- make $r0, -1
-;;
-.L107:
- addd $r0 = $r1, 0
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch2, @function
- .size my_bsearch2, . - my_bsearch2
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L108:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L109
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L110
-;;
- addw $r8 = $r8, 1
-;;
-.L110:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L108
-;;
-.L109:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -80
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
-;;
- sd 56[$r12] = $r23
- make $r23, 1502
-;;
- sd 64[$r12] = $r24
- make $r24, 5000
-;;
- sd 72[$r12] = $r25
- call malloc
-;;
- addd $r19 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r21 = $r18, $r0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- addd $r22 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r20 = $r18, $r0
- call get_current_cycle
-;;
- addd $r25 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch2
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r5 = $r25, $r0
- make $r0 = __stringlit_1
- addd $r4 = $r20, 0
- addd $r3 = $r21, 0
-;;
- addd $r2 = $r18, 0
- addd $r1 = $r22, 0
- call printf
-;;
- addd $r0 = $r19, 0
- call free
-;;
- make $r0, 0
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
- set $ra = $r16
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r24 = 64[$r12]
-;;
- ld $r25 = 72[$r12]
-;;
- addd $r12 = $r12, 80
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized06 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized06
deleted file mode 100644
index 79005b9c..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized06
+++ /dev/null
@@ -1,287 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position1: %d\012position2: %d\012random fill cycles: %lu\012search1 cycles: %lu\012search2 cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl my_bsearch2
-my_bsearch2:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
- addw $r4 = $r1, -1
-;;
-.L105:
- addw $r9 = $r5, $r4
-;;
- srlw $r1 = $r9, 1
-;;
- lws.xs $r7 = $r1[$r0]
-;;
- compw.ne $r32 = $r7, $r2
-;;
-;;
- compw.lt $r3 = $r7, $r2
- compw.gt $r8 = $r7, $r2
- addw $r6 = $r1, 1
- addw $r1 = $r1, -1
- cb.weqz $r32? .L107
-;;
- cmoved.wnez $r3? $r5 = $r6
- cmoved.wnez $r8? $r4 = $r1
-;;
- compw.leu $r32 = $r5, $r4
-;;
- cb.wnez $r32? .L105
-;;
- make $r0, -1
-;;
-.L107:
- addd $r0 = $r1, 0
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch2, @function
- .size my_bsearch2, . - my_bsearch2
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L108:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L109
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L110
-;;
- addw $r8 = $r8, 1
-;;
-.L110:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L108
-;;
-.L109:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -80
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
-;;
- sd 56[$r12] = $r23
- make $r23, 1502
-;;
- sd 64[$r12] = $r24
- make $r24, 5000
-;;
- sd 72[$r12] = $r25
- call malloc
-;;
- addd $r19 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r21 = $r18, $r0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch
-;;
- addd $r22 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r20 = $r18, $r0
- call get_current_cycle
-;;
- addd $r25 = $r0, 0
- addd $r2 = $r23, 0
- addd $r1 = $r24, 0
- addd $r0 = $r19, 0
- call my_bsearch2
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r5 = $r25, $r0
- make $r0 = __stringlit_1
- addd $r4 = $r20, 0
- addd $r3 = $r21, 0
-;;
- addd $r2 = $r18, 0
- addd $r1 = $r22, 0
- call printf
-;;
- addd $r0 = $r19, 0
- call free
-;;
- make $r0, 0
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
- set $ra = $r16
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r24 = 64[$r12]
-;;
- ld $r25 = 72[$r12]
-;;
- addd $r12 = $r12, 80
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized07 b/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized07
deleted file mode 100644
index 3214c5bc..00000000
--- a/test/monniaux/binary_search/binary_search.ccomp.k1c.s.optimized07
+++ /dev/null
@@ -1,372 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S binary_search.c -o binary_search.ccomp.k1c.s
- .section .rodata
- .balign 1
-__stringlit_1:
- .ascii "position1: %d\012position2: %d\012position3: %d\012random fill cycles: %lu\012search1 cycles: %lu\012search2 cycles: %lu\012search3 cycles: %lu\012\000"
- .type __stringlit_1, @object
- .size __stringlit_1, . - __stringlit_1
- .text
- .balign 2
- .globl my_bsearch
-my_bsearch:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
- addw $r6 = $r1, -1
-;;
-.L100:
- addw $r5 = $r4, $r6
-;;
- srlw $r3 = $r5, 1
-;;
- zxwd $r5 = $r3
-;;
- slld $r8 = $r5, 2
-;;
- lws $r1 = $r8[$r0]
-;;
- compw.eq $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L101
-;;
- compw.lt $r32 = $r1, $r2
-;;
- cb.wnez $r32? .L102
-;;
- addw $r6 = $r3, -1
- goto .L103
-;;
-.L102:
- addw $r4 = $r3, 1
-;;
-.L103:
- compw.leu $r32 = $r4, $r6
-;;
- cb.wnez $r32? .L100
-;;
- make $r0, -1
- goto .L104
-;;
-.L101:
- addd $r0 = $r3, 0
-;;
-.L104:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch, @function
- .size my_bsearch, . - my_bsearch
- .text
- .balign 2
- .globl my_bsearch2
-my_bsearch2:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
- addw $r4 = $r1, -1
-;;
-.L105:
- addw $r9 = $r5, $r4
-;;
- srlw $r1 = $r9, 1
-;;
- zxwd $r10 = $r1
-;;
- slld $r8 = $r10, 2
-;;
- lws $r7 = $r8[$r0]
-;;
- compw.ne $r32 = $r7, $r2
-;;
- cb.wnez $r32? .L106
-;;
- addd $r0 = $r1, 0
- goto .L107
-;;
-.L106:
- compw.lt $r3 = $r7, $r2
- addw $r6 = $r1, 1
- addw $r1 = $r1, -1
-;;
- cmoved.wnez $r3? $r5 = $r6
- compw.gt $r6 = $r7, $r2
-;;
- cmoved.wnez $r6? $r4 = $r1
-;;
- compw.leu $r32 = $r5, $r4
-;;
- cb.wnez $r32? .L105
-;;
- make $r0, -1
-;;
-.L107:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch2, @function
- .size my_bsearch2, . - my_bsearch2
- .text
- .balign 2
- .globl my_bsearch3
-my_bsearch3:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 0
- addw $r3 = $r1, -1
-;;
-.L108:
- addw $r11 = $r7, $r3
-;;
- srlw $r6 = $r11, 1
-;;
- addw $r1 = $r6, 1
- lws.xs $r4 = $r6[$r0]
-;;
- compw.lt $r5 = $r4, $r2
- compw.gt $r8 = $r4, $r2
- compw.eq $r32 = $r4, $r2
-;;
- cmoved.wnez $r5? $r7 = $r1
- addw $r5 = $r6, -1
-;;
- cmoved.wnez $r8? $r3 = $r5
- cb.wnez $r32? .L109
-;;
- compw.leu $r32 = $r7, $r3
-;;
- cb.wnez $r32? .L108
-;;
- make $r6, -1
-;;
-.L109:
- addd $r0 = $r6, 0
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type my_bsearch3, @function
- .size my_bsearch3, . - my_bsearch3
- .text
- .balign 2
- .globl random_ascending_fill
-random_ascending_fill:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r7, 41
- make $r8, 0
- make $r6, 0
-;;
-.L110:
- compw.geu $r32 = $r6, $r1
-;;
- cb.wnez $r32? .L111
-;;
- zxwd $r2 = $r6
- andw $r3 = $r7, 1073741824
-;;
- slld $r4 = $r2, 2
-;;
- sw $r4[$r0] = $r8
- addw $r8 = $r8, 1
- cb.weqz $r3? .L112
-;;
- addw $r8 = $r8, 1
-;;
-.L112:
- mulw $r2 = $r7, 97
- addw $r6 = $r6, 1
-;;
- addw $r7 = $r2, 5
- goto .L110
-;;
-.L111:
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type random_ascending_fill, @function
- .size random_ascending_fill, . - random_ascending_fill
- .text
- .balign 2
- .globl main
-main:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -96
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- make $r0, 20000
-;;
- sd 24[$r12] = $r19
- make $r19, 1502
-;;
- sd 32[$r12] = $r20
- make $r20, 5000
-;;
- sd 40[$r12] = $r21
-;;
- sd 48[$r12] = $r22
-;;
- sd 56[$r12] = $r23
-;;
- sd 64[$r12] = $r24
-;;
- sd 72[$r12] = $r25
-;;
- sd 80[$r12] = $r26
-;;
- sd 88[$r12] = $r27
- call malloc
-;;
- addd $r21 = $r0, 0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r1 = $r20, 0
- addd $r0 = $r21, 0
- call random_ascending_fill
-;;
- call get_current_cycle
-;;
- sbfd $r24 = $r18, $r0
- addd $r2 = $r19, 0
- addd $r1 = $r20, 0
- addd $r0 = $r21, 0
- call my_bsearch
-;;
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r19, 0
- addd $r1 = $r20, 0
- addd $r0 = $r21, 0
- call my_bsearch
-;;
- addd $r26 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r23 = $r18, $r0
- call get_current_cycle
-;;
- addd $r18 = $r0, 0
- addd $r2 = $r19, 0
- addd $r1 = $r20, 0
- addd $r0 = $r21, 0
- call my_bsearch2
-;;
- addd $r25 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r22 = $r18, $r0
- call get_current_cycle
-;;
- addd $r27 = $r0, 0
- addd $r2 = $r19, 0
- addd $r1 = $r20, 0
- addd $r0 = $r21, 0
- call my_bsearch3
-;;
- addd $r18 = $r0, 0
- call get_current_cycle
-;;
- sbfd $r7 = $r27, $r0
- make $r0 = __stringlit_1
- addd $r6 = $r22, 0
- addd $r5 = $r23, 0
-;;
- addd $r4 = $r24, 0
- addd $r3 = $r18, 0
- addd $r2 = $r25, 0
- addd $r1 = $r26, 0
- call printf
-;;
- addd $r0 = $r21, 0
- call free
-;;
- make $r0, 0
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
- set $ra = $r16
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r24 = 64[$r12]
-;;
- ld $r25 = 72[$r12]
-;;
- ld $r26 = 80[$r12]
-;;
- ld $r27 = 88[$r12]
-;;
- addd $r12 = $r12, 96
-;;
- ret
-;;
- .type main, @function
- .size main, . - main
diff --git a/test/monniaux/binary_search/make.proto b/test/monniaux/binary_search/make.proto
deleted file mode 100644
index 337751bb..00000000
--- a/test/monniaux/binary_search/make.proto
+++ /dev/null
@@ -1,2 +0,0 @@
-target: binary_search
-measures: ["random fill", search1]
diff --git a/test/monniaux/bitsliced-aes/Makefile b/test/monniaux/bitsliced-aes/Makefile
new file mode 100644
index 00000000..0fef17be
--- /dev/null
+++ b/test/monniaux/bitsliced-aes/Makefile
@@ -0,0 +1,4 @@
+ALL_CFILES=$(wildcard *.c) tests/tests.c
+TARGET=bitsliced-aes
+
+include ../rules.mk
diff --git a/test/monniaux/bitsliced-aes/bs.c b/test/monniaux/bitsliced-aes/bs.c
index 083a8fc5..a172aca5 100644
--- a/test/monniaux/bitsliced-aes/bs.c
+++ b/test/monniaux/bitsliced-aes/bs.c
@@ -1,9 +1,9 @@
#include <string.h>
#include "bs.h"
-#include "../ternary.h"
-#define TERNARY(x, v0, v1) TERNARY64(x, v1, v0)
+/* TEMPORARY */
+#define TERNARY(x, v0, v1) ((x) ? (v1) : (v0))
#if (defined(__BYTE_ORDER__) && __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) ||\
defined(__amd64__) || defined(__amd32__)|| defined(__amd16__)
diff --git a/test/monniaux/bitsliced-aes/bs.ccomp.k1c.s.optimized b/test/monniaux/bitsliced-aes/bs.ccomp.k1c.s.optimized
deleted file mode 100644
index d939f856..00000000
--- a/test/monniaux/bitsliced-aes/bs.ccomp.k1c.s.optimized
+++ /dev/null
@@ -1,3268 +0,0 @@
-# File generated by CompCert 3.5
-# Command line: -O3 -Wall -Wno-c11-extensions -fno-unprototyped -S bs.c -o bs.ccomp.k1c.s
- .text
- .balign 2
- .globl bs_addroundkey
-bs_addroundkey:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r5, 0
-;;
-.L100:
- sxwd $r6 = $r5
- addw $r5 = $r5, 1
- make $r32, 128
-;;
- slld $r2 = $r6, 3
- compw.lt $r32 = $r5, $r32
-;;
- addd $r3 = $r0, $r2
- addd $r4 = $r1, $r2
-;;
- ld $r7 = 0[$r3]
-;;
- ld $r9 = 0[$r4]
-;;
- xord $r6 = $r7, $r9
-;;
- sd 0[$r3] = $r6
-;;
- cb.wnez $r32? .L100
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type bs_addroundkey, @function
- .size bs_addroundkey, . - bs_addroundkey
- .text
- .balign 2
- .globl bs_apply_sbox
-bs_apply_sbox:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -32
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
-;;
- sd 24[$r12] = $r19
- make $r19, 0
-;;
-.L101:
- sxwd $r1 = $r19
-;;
- slld $r0 = $r1, 3
-;;
- addd $r0 = $r18, $r0
- call bs_sbox
-;;
- addw $r19 = $r19, 8
- make $r32, 128
-;;
- compw.lt $r32 = $r19, $r32
-;;
- cb.wnez $r32? .L101
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 32
-;;
- ret
-;;
- .type bs_apply_sbox, @function
- .size bs_apply_sbox, . - bs_apply_sbox
- .text
- .balign 2
- .globl bs_apply_sbox_rev
-bs_apply_sbox_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -32
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
-;;
- sd 24[$r12] = $r19
- make $r19, 0
-;;
-.L102:
- sxwd $r1 = $r19
-;;
- slld $r0 = $r1, 3
-;;
- addd $r0 = $r18, $r0
- call bs_sbox_rev
-;;
- addw $r19 = $r19, 8
- make $r32, 128
-;;
- compw.lt $r32 = $r19, $r32
-;;
- cb.wnez $r32? .L102
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 32
-;;
- ret
-;;
- .type bs_apply_sbox_rev, @function
- .size bs_apply_sbox_rev, . - bs_apply_sbox_rev
- .text
- .balign 2
- .globl bs_sbox_rev
-bs_sbox_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -96
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
-;;
- sd 24[$r12] = $r19
-;;
- ld $r7 = 48[$r0]
-;;
- ld $r3 = 56[$r0]
-;;
- ld $r4 = 32[$r0]
- nxord $r40 = $r3, $r7
-;;
- xord $r10 = $r3, $r4
- nxord $r11 = $r7, $r4
- ld $r2 = 8[$r0]
-;;
- ld $r5 = 24[$r0]
- nxord $r45 = $r7, $r10
- xord $r59 = $r7, $r2
-;;
- xord $r41 = $r4, $r5
- ld $r1 = 0[$r0]
- xord $r60 = $r5, $r45
- andd $r33 = $r10, $r45
-;;
- nxord $r35 = $r5, $r1
- xord $r63 = $r2, $r1
- nxord $r39 = $r1, $r41
- ld $r6 = 40[$r0]
-;;
- xord $r46 = $r11, $r63
- xord $r54 = $r40, $r35
- ld $r7 = 16[$r0]
- nxord $r57 = $r6, $r5
-;;
- xord $r52 = $r40, $r63
- xord $r50 = $r41, $r63
- nxord $r47 = $r6, $r7
- nxord $r38 = $r7, $r2
-;;
- nxord $r58 = $r6, $r46
- xord $r19 = $r11, $r47
- xord $r63 = $r59, $r57
- xord $r7 = $r41, $r38
-;;
- xord $r44 = $r35, $r59
- xord $r18 = $r3, $r47
- xord $r3 = $r54, $r7
- xord $r55 = $r54, $r38
-;;
- nxord $r34 = $r6, $r41
- xord $r2 = $r50, $r63
- andd $r57 = $r52, $r19
- andd $r17 = $r50, $r63
-;;
- xord $r36 = $r55, $r57
- andd $r62 = $r46, $r18
- andd $r53 = $r11, $r39
- xord $r6 = $r2, $r17
-;;
- andd $r42 = $r44, $r58
- andd $r15 = $r41, $r3
- andd $r2 = $r60, $r7
- andd $r37 = $r40, $r54
-;;
- xord $r59 = $r62, $r57
- xord $r51 = $r42, $r17
- xord $r8 = $r2, $r15
- xord $r4 = $r37, $r15
-;;
- xord $r5 = $r36, $r33
- xord $r38 = $r59, $r35
- xord $r48 = $r6, $r53
- xord $r47 = $r51, $r4
-;;
- xord $r53 = $r5, $r8
- xord $r43 = $r38, $r4
- xord $r56 = $r48, $r8
- xord $r57 = $r47, $r34
-;;
- xord $r49 = $r56, $r57
- andd $r48 = $r56, $r53
- xord $r47 = $r53, $r43
- andd $r9 = $r53, $r57
-;;
- xord $r36 = $r43, $r48
- xord $r35 = $r57, $r48
- andd $r62 = $r47, $r9
- xord $r17 = $r47, $r48
-;;
- andd $r15 = $r35, $r47
- andd $r42 = $r36, $r49
- andd $r47 = $r43, $r56
- xord $r59 = $r49, $r48
-;;
- andd $r37 = $r49, $r47
- xord $r5 = $r43, $r15
- xord $r4 = $r62, $r17
- xord $r55 = $r57, $r42
-;;
- xord $r1 = $r37, $r59
- xord $r2 = $r5, $r55
- xord $r47 = $r5, $r4
- andd $r35 = $r4, $r39
-;;
- xord $r61 = $r4, $r1
- xord $r33 = $r55, $r1
- andd $r62 = $r1, $r45
- andd $r45 = $r55, $r18
-;;
- xord $r48 = $r2, $r61
- andd $r49 = $r2, $r3
- andd $r6 = $r1, $r10
- andd $r3 = $r47, $r50
-;;
- andd $r56 = $r47, $r63
- andd $r42 = $r5, $r58
- andd $r1 = $r4, $r11
- andd $r57 = $r2, $r41
-;;
- andd $r9 = $r61, $r54
- andd $r51 = $r33, $r52
- andd $r58 = $r55, $r46
- andd $r53 = $r5, $r44
-;;
- andd $r41 = $r48, $r60
- andd $r10 = $r61, $r40
- xord $r59 = $r49, $r57
- xord $r61 = $r3, $r1
-;;
- andd $r34 = $r33, $r19
- andd $r39 = $r48, $r7
- xord $r55 = $r9, $r41
- xord $r60 = $r45, $r6
-;;
- xord $r48 = $r62, $r35
- xord $r15 = $r56, $r53
- xord $r44 = $r59, $r61
- xord $r49 = $r51, $r10
-;;
- xord $r54 = $r34, $r42
- xord $r51 = $r58, $r60
- xord $r59 = $r59, $r48
- xord $r8 = $r56, $r42
-;;
- xord $r47 = $r9, $r1
- xord $r11 = $r60, $r15
- xord $r40 = $r55, $r44
- xord $r60 = $r15, $r51
-;;
- xord $r52 = $r56, $r41
- xord $r56 = $r10, $r54
- xord $r2 = $r49, $r59
- xord $r5 = $r59, $r60
-;;
- xord $r7 = $r3, $r55
- xord $r61 = $r51, $r56
- xord $r59 = $r47, $r11
- xord $r47 = $r8, $r40
-;;
- xord $r63 = $r35, $r39
- xord $r4 = $r34, $r45
- sd 88[$r12] = $r47
- xord $r51 = $r2, $r59
-;;
- xord $r10 = $r55, $r48
- xord $r50 = $r44, $r63
- sd 80[$r12] = $r51
- xord $r37 = $r7, $r5
-;;
- xord $r53 = $r54, $r44
- sd 72[$r12] = $r37
- xord $r37 = $r4, $r40
- xord $r40 = $r50, $r61
-;;
- xord $r1 = $r58, $r57
- sd 64[$r12] = $r37
- xord $r46 = $r10, $r53
- xord $r7 = $r52, $r50
-;;
- sd 56[$r12] = $r40
- xord $r49 = $r49, $r1
- addd $r1 = $r12, 32
- make $r2, 64
-;;
- sd 48[$r12] = $r46
-;;
- sd 40[$r12] = $r7
-;;
- sd 32[$r12] = $r49
- call memmove
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 96
-;;
- ret
-;;
- .type bs_sbox_rev, @function
- .size bs_sbox_rev, . - bs_sbox_rev
- .text
- .balign 2
- .globl bs_sbox
-bs_sbox:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -80
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- ld $r5 = 56[$r0]
-;;
- ld $r6 = 32[$r0]
-;;
- xord $r41 = $r5, $r6
- ld $r2 = 16[$r0]
-;;
- xord $r42 = $r5, $r2
- ld $r4 = 8[$r0]
- xord $r49 = $r6, $r2
-;;
- xord $r48 = $r5, $r4
- ld $r55 = 24[$r0]
-;;
- xord $r9 = $r55, $r4
- ld $r3 = 48[$r0]
-;;
- xord $r5 = $r41, $r9
- ld $r7 = 40[$r0]
- xord $r34 = $r3, $r2
-;;
- xord $r10 = $r3, $r7
- ld $r1 = 0[$r0]
- xord $r11 = $r7, $r2
- xord $r3 = $r48, $r49
-;;
- xord $r33 = $r9, $r34
- xord $r8 = $r9, $r11
- xord $r44 = $r6, $r1
- xord $r47 = $r4, $r1
-;;
- xord $r59 = $r1, $r10
- xord $r7 = $r5, $r34
- xord $r9 = $r10, $r44
- xord $r4 = $r10, $r47
-;;
- xord $r61 = $r1, $r5
- xord $r57 = $r5, $r10
- andd $r50 = $r3, $r5
- andd $r43 = $r9, $r1
-;;
- xord $r34 = $r59, $r8
- xord $r6 = $r41, $r9
- xord $r35 = $r42, $r4
- xord $r36 = $r48, $r8
-;;
- xord $r38 = $r41, $r11
- xord $r40 = $r7, $r50
- xord $r11 = $r43, $r50
- andd $r50 = $r48, $r8
-;;
- xord $r15 = $r42, $r57
- andd $r62 = $r35, $r61
- andd $r37 = $r4, $r59
- xord $r52 = $r36, $r50
-;;
- andd $r53 = $r6, $r34
- andd $r55 = $r41, $r33
- andd $r46 = $r49, $r38
- andd $r54 = $r42, $r57
-;;
- xord $r39 = $r53, $r50
- xord $r60 = $r46, $r55
- xord $r55 = $r54, $r55
- xord $r10 = $r40, $r62
-;;
- xord $r44 = $r6, $r34
- xord $r43 = $r11, $r15
- xord $r15 = $r52, $r37
- xord $r17 = $r39, $r55
-;;
- xord $r45 = $r10, $r60
- xord $r55 = $r43, $r55
- xord $r50 = $r15, $r60
- xord $r46 = $r17, $r44
-;;
- xord $r63 = $r50, $r46
- andd $r43 = $r50, $r45
- xord $r56 = $r45, $r55
- andd $r54 = $r45, $r46
-;;
- xord $r36 = $r55, $r43
- xord $r47 = $r46, $r43
- andd $r40 = $r56, $r54
- andd $r60 = $r55, $r50
-;;
- andd $r2 = $r47, $r56
- andd $r58 = $r36, $r63
- xord $r36 = $r56, $r43
- andd $r15 = $r63, $r60
-;;
- xord $r47 = $r63, $r43
- xord $r17 = $r55, $r2
- xord $r50 = $r40, $r36
- xord $r52 = $r46, $r58
-;;
- xord $r58 = $r15, $r47
- xord $r51 = $r17, $r52
- xord $r7 = $r17, $r50
- andd $r43 = $r52, $r1
-;;
- xord $r53 = $r50, $r58
- xord $r62 = $r52, $r58
- andd $r44 = $r7, $r8
- andd $r8 = $r50, $r59
-;;
- xord $r40 = $r51, $r53
- andd $r45 = $r58, $r61
- andd $r54 = $r51, $r33
- andd $r10 = $r58, $r35
-;;
- andd $r47 = $r40, $r38
- andd $r46 = $r62, $r3
- andd $r2 = $r51, $r41
- xord $r35 = $r8, $r10
-;;
- andd $r5 = $r62, $r5
- andd $r36 = $r17, $r34
- andd $r39 = $r53, $r57
- andd $r56 = $r7, $r48
-;;
- andd $r41 = $r40, $r49
- xord $r34 = $r45, $r46
- xord $r51 = $r44, $r2
- xord $r62 = $r54, $r47
-;;
- andd $r38 = $r52, $r9
- andd $r37 = $r50, $r4
- andd $r9 = $r17, $r6
- xord $r59 = $r46, $r35
-;;
- andd $r61 = $r53, $r42
- xord $r1 = $r2, $r41
- xord $r63 = $r5, $r43
- xord $r33 = $r39, $r56
-;;
- xord $r42 = $r41, $r51
- xord $r51 = $r5, $r34
- xord $r52 = $r36, $r37
- xord $r49 = $r59, $r62
-;;
- xord $r57 = $r47, $r33
- xord $r3 = $r9, $r63
- xord $r11 = $r54, $r2
- xord $r50 = $r10, $r1
-;;
- xord $r37 = $r43, $r36
- xord $r6 = $r56, $r52
- xord $r9 = $r51, $r62
- xord $r40 = $r42, $r49
-;;
- xord $r36 = $r61, $r33
- xord $r10 = $r42, $r57
- xord $r56 = $r52, $r57
- xord $r57 = $r3, $r11
-;;
- xord $r5 = $r35, $r51
- sd 72[$r12] = $r40
- nxord $r43 = $r50, $r9
- nxord $r17 = $r36, $r57
-;;
- xord $r39 = $r8, $r1
- xord $r53 = $r38, $r35
- xord $r8 = $r1, $r35
- sd 64[$r12] = $r43
-;;
- xord $r7 = $r34, $r37
- xord $r58 = $r3, $r53
- sd 56[$r12] = $r17
- xord $r38 = $r42, $r5
-;;
- xord $r48 = $r6, $r63
- sd 48[$r12] = $r38
- xord $r1 = $r8, $r7
- xord $r43 = $r10, $r58
-;;
- sd 40[$r12] = $r1
- nxord $r4 = $r39, $r56
- nxord $r34 = $r42, $r48
- addd $r1 = $r12, 16
-;;
- sd 32[$r12] = $r43
- make $r2, 64
-;;
- sd 24[$r12] = $r4
-;;
- sd 16[$r12] = $r34
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 80
-;;
- ret
-;;
- .type bs_sbox, @function
- .size bs_sbox, . - bs_sbox
- .text
- .balign 2
- .globl bs_transpose
-bs_transpose:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1056
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
- addd $r0 = $r12, 24
- make $r1, 0
-;;
- make $r2, 1024
- call memset
-;;
- addd $r0 = $r12, 24
- addd $r1 = $r18, 0
- call bs_transpose_dst
-;;
- addd $r1 = $r12, 24
- make $r2, 1024
- addd $r0 = $r18, 0
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1056
-;;
- ret
-;;
- .type bs_transpose, @function
- .size bs_transpose, . - bs_transpose
- .text
- .balign 2
- .globl bs_transpose_dst
-bs_transpose_dst:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -16
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- make $r4, 0
-;;
-.L103:
- make $r35, 1
- make $r17, 0
-;;
- slld $r41 = $r35, $r4
-;;
- addw $r9 = $r41, 0
-;;
-.L104:
- sllw $r10 = $r4, 1
- sllw $r42 = $r17, 6
- make $r6, 0
-;;
- addw $r36 = $r10, $r17
-;;
- sxwd $r15 = $r36
-;;
- slld $r2 = $r15, 3
-;;
- addd $r8 = $r1, $r2
-;;
- ld $r11 = 0[$r8]
-;;
-.L105:
- addw $r40 = $r42, $r6
- make $r2, 0
- make $r44, 1
- make $r32, 64
-;;
- sxwd $r34 = $r40
- sxwd $r39 = $r9
- slld $r37 = $r44, $r6
- addw $r6 = $r6, 1
-;;
- ld.xs $r7 = $r34[$r0]
- andd $r33 = $r11, $r37
- compw.lt $r32 = $r6, $r32
-;;
- cmoved.dnez $r33? $r2 = $r39
-;;
- ord $r38 = $r7, $r2
-;;
- sd.xs $r34[$r0] = $r38
- cb.wnez $r32? .L105
-;;
- addw $r17 = $r17, 1
- make $r32, 2
-;;
- compw.lt $r32 = $r17, $r32
-;;
- cb.wnez $r32? .L104
-;;
- addw $r4 = $r4, 1
- make $r32, 64
-;;
- compw.lt $r32 = $r4, $r32
-;;
- cb.wnez $r32? .L103
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 16
-;;
- ret
-;;
- .type bs_transpose_dst, @function
- .size bs_transpose_dst, . - bs_transpose_dst
- .text
- .balign 2
- .globl bs_transpose_rev
-bs_transpose_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1056
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
- addd $r0 = $r12, 24
- make $r1, 0
-;;
- make $r2, 1024
- call memset
-;;
- make $r3, 0
-;;
-.L106:
- sxwd $r8 = $r3
- sraw $r32 = $r3, 31
- make $r11, 0
-;;
- slld $r34 = $r8, 3
- srlw $r32 = $r32, 26
-;;
- addd $r6 = $r18, $r34
- addw $r32 = $r3, $r32
-;;
- sraw $r2 = $r32, 6
-;;
- sxwd $r5 = $r2
-;;
- ld $r36 = 0[$r6]
-;;
-.L107:
- make $r39, 1
-;;
- slld $r38 = $r39, $r11
-;;
- andd $r17 = $r36, $r38
-;;
- cb.deqz $r17? .L108
-;;
- make $r44, 1
- sraw $r32 = $r3, 31
-;;
- srlw $r32 = $r32, 26
-;;
- addw $r32 = $r3, $r32
-;;
- sraw $r40 = $r32, 6
-;;
- sllw $r9 = $r40, 6
-;;
- sbfw $r45 = $r9, $r3
-;;
- slld $r0 = $r44, $r45
- goto .L109
-;;
-.L108:
- make $r0, 0
-;;
-.L109:
- addd $r37 = $r12, 24
- sllw $r46 = $r11, 1
- addw $r11 = $r11, 1
- make $r32, 64
-;;
- sxwd $r7 = $r46
- compw.lt $r32 = $r11, $r32
-;;
- addd $r4 = $r7, $r5
-;;
- slld $r10 = $r4, 3
-;;
- addd $r1 = $r37, $r10
-;;
- ld $r41 = 0[$r1]
-;;
- ord $r35 = $r41, $r0
-;;
- sd 0[$r1] = $r35
-;;
- cb.wnez $r32? .L107
-;;
- addw $r3 = $r3, 1
- make $r32, 128
-;;
- compw.lt $r32 = $r3, $r32
-;;
- cb.wnez $r32? .L106
-;;
- addd $r1 = $r12, 24
- make $r2, 1024
- addd $r0 = $r18, 0
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1056
-;;
- ret
-;;
- .type bs_transpose_rev, @function
- .size bs_transpose_rev, . - bs_transpose_rev
- .text
- .balign 2
- .globl bs_shiftrows
-bs_shiftrows:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1040
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- addd $r50 = $r12, 16
- addd $r1 = $r0, 0
- addd $r43 = $r0, 256
- addd $r8 = $r0, 512
-;;
- addd $r60 = $r0, 768
- make $r15, 0
- make $r52, 32
- make $r3, 64
-;;
- make $r36, 96
- make $r7, 0
-;;
-.L110:
- ld $r5 = 0[$r1]
- addw $r59 = $r52, 40
- addw $r7 = $r7, 1
- make $r32, 4
-;;
- sd 0[$r50] = $r5
- andw $r52 = $r59, 127
- addw $r63 = $r36, 40
- compw.lt $r32 = $r7, $r32
-;;
- andw $r36 = $r63, 127
- sxwd $r62 = $r52
-;;
- slld $r53 = $r62, 3
-;;
- ld $r11 = 8[$r1]
-;;
- sd 8[$r50] = $r11
-;;
- ld $r61 = 16[$r1]
-;;
- sd 16[$r50] = $r61
-;;
- ld $r6 = 24[$r1]
-;;
- sd 24[$r50] = $r6
-;;
- ld $r56 = 32[$r1]
-;;
- sd 32[$r50] = $r56
-;;
- ld $r2 = 40[$r1]
-;;
- sd 40[$r50] = $r2
- addw $r2 = $r3, 40
-;;
- andw $r3 = $r2, 127
- sxwd $r2 = $r36
-;;
- sxwd $r5 = $r3
- slld $r39 = $r2, 3
-;;
- ld $r38 = 48[$r1]
- slld $r46 = $r5, 3
-;;
- sd 48[$r50] = $r38
-;;
- ld $r54 = 56[$r1]
-;;
- sd 56[$r50] = $r54
-;;
- ld $r4 = 0[$r43]
-;;
- sd 256[$r50] = $r4
-;;
- ld $r58 = 8[$r43]
-;;
- sd 264[$r50] = $r58
-;;
- ld $r10 = 16[$r43]
-;;
- sd 272[$r50] = $r10
-;;
- ld $r34 = 24[$r43]
-;;
- sd 280[$r50] = $r34
-;;
- ld $r51 = 32[$r43]
-;;
- sd 288[$r50] = $r51
-;;
- ld $r9 = 40[$r43]
-;;
- sd 296[$r50] = $r9
-;;
- ld $r1 = 48[$r43]
-;;
- sd 304[$r50] = $r1
-;;
- ld $r4 = 56[$r43]
- addd $r43 = $r0, $r53
-;;
- sd 312[$r50] = $r4
-;;
- ld $r41 = 0[$r8]
-;;
- sd 512[$r50] = $r41
-;;
- ld $r9 = 8[$r8]
-;;
- sd 520[$r50] = $r9
-;;
- ld $r6 = 16[$r8]
-;;
- sd 528[$r50] = $r6
-;;
- ld $r9 = 24[$r8]
-;;
- sd 536[$r50] = $r9
-;;
- ld $r42 = 32[$r8]
-;;
- sd 544[$r50] = $r42
-;;
- ld $r35 = 40[$r8]
-;;
- sd 552[$r50] = $r35
-;;
- ld $r10 = 48[$r8]
-;;
- sd 560[$r50] = $r10
-;;
- ld $r57 = 56[$r8]
-;;
- sd 568[$r50] = $r57
-;;
- ld $r17 = 0[$r60]
-;;
- sd 768[$r50] = $r17
-;;
- ld $r8 = 8[$r60]
-;;
- sd 776[$r50] = $r8
- addw $r8 = $r15, 40
-;;
- andw $r15 = $r8, 127
- addd $r8 = $r0, $r46
-;;
- sxwd $r37 = $r15
-;;
- ld $r48 = 16[$r60]
- slld $r40 = $r37, 3
-;;
- sd 784[$r50] = $r48
- addd $r1 = $r0, $r40
-;;
- ld $r33 = 24[$r60]
-;;
- sd 792[$r50] = $r33
-;;
- ld $r47 = 32[$r60]
-;;
- sd 800[$r50] = $r47
-;;
- ld $r4 = 40[$r60]
-;;
- sd 808[$r50] = $r4
-;;
- ld $r44 = 48[$r60]
-;;
- sd 816[$r50] = $r44
-;;
- ld $r49 = 56[$r60]
- addd $r60 = $r0, $r39
-;;
- sd 824[$r50] = $r49
- addd $r50 = $r50, 64
- cb.wnez $r32? .L110
-;;
- addd $r1 = $r12, 16
- make $r2, 1024
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1040
-;;
- ret
-;;
- .type bs_shiftrows, @function
- .size bs_shiftrows, . - bs_shiftrows
- .text
- .balign 2
- .globl bs_shiftrows_rev
-bs_shiftrows_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1040
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- addd $r56 = $r12, 16
- addd $r34 = $r12, 16
- addd $r45 = $r12, 272
- addd $r6 = $r12, 528
-;;
- addd $r62 = $r12, 784
- make $r4, 0
- make $r10, 32
- make $r55, 64
-;;
- make $r2, 96
- make $r59, 0
-;;
-.L111:
- ld $r43 = 0[$r0]
- addw $r9 = $r4, 40
- addw $r59 = $r59, 1
- make $r32, 4
-;;
- sd 0[$r34] = $r43
- andw $r4 = $r9, 127
- addw $r51 = $r10, 40
- compw.lt $r32 = $r59, $r32
-;;
- andw $r10 = $r51, 127
- sxwd $r39 = $r4
-;;
- slld $r60 = $r39, 3
-;;
- ld $r57 = 8[$r0]
-;;
- sd 8[$r34] = $r57
-;;
- ld $r63 = 16[$r0]
-;;
- sd 16[$r34] = $r63
-;;
- ld $r7 = 24[$r0]
-;;
- sd 24[$r34] = $r7
-;;
- ld $r44 = 32[$r0]
-;;
- sd 32[$r34] = $r44
-;;
- ld $r42 = 40[$r0]
-;;
- sd 40[$r34] = $r42
-;;
- ld $r40 = 48[$r0]
-;;
- sd 48[$r34] = $r40
-;;
- ld $r61 = 56[$r0]
-;;
- sd 56[$r34] = $r61
- addd $r34 = $r56, $r60
-;;
- ld $r35 = 256[$r0]
-;;
- sd 0[$r45] = $r35
-;;
- ld $r1 = 264[$r0]
-;;
- sd 8[$r45] = $r1
- addw $r1 = $r2, 40
-;;
- andw $r2 = $r1, 127
-;;
- ld $r49 = 272[$r0]
-;;
- sd 16[$r45] = $r49
-;;
- ld $r37 = 280[$r0]
-;;
- sd 24[$r45] = $r37
-;;
- ld $r54 = 288[$r0]
-;;
- sd 32[$r45] = $r54
-;;
- ld $r15 = 296[$r0]
-;;
- sd 40[$r45] = $r15
-;;
- ld $r3 = 304[$r0]
-;;
- sd 48[$r45] = $r3
-;;
- ld $r5 = 312[$r0]
-;;
- sd 56[$r45] = $r5
- sxwd $r5 = $r2
-;;
- slld $r38 = $r5, 3
-;;
- ld $r53 = 512[$r0]
-;;
- sd 0[$r6] = $r53
-;;
- ld $r33 = 520[$r0]
-;;
- sd 8[$r6] = $r33
-;;
- ld $r8 = 528[$r0]
-;;
- sd 16[$r6] = $r8
-;;
- ld $r11 = 536[$r0]
-;;
- sd 24[$r6] = $r11
-;;
- ld $r47 = 544[$r0]
-;;
- sd 32[$r6] = $r47
-;;
- ld $r3 = 552[$r0]
-;;
- sd 40[$r6] = $r3
-;;
- ld $r17 = 560[$r0]
-;;
- sd 48[$r6] = $r17
-;;
- ld $r52 = 568[$r0]
-;;
- sd 56[$r6] = $r52
- sxwd $r6 = $r10
-;;
- slld $r1 = $r6, 3
-;;
- addd $r45 = $r56, $r1
-;;
- ld $r8 = 768[$r0]
-;;
- sd 0[$r62] = $r8
-;;
- ld $r41 = 776[$r0]
-;;
- sd 8[$r62] = $r41
-;;
- ld $r3 = 784[$r0]
-;;
- sd 16[$r62] = $r3
- addw $r3 = $r55, 40
-;;
- andw $r55 = $r3, 127
-;;
- sxwd $r7 = $r55
-;;
- ld $r36 = 792[$r0]
- slld $r58 = $r7, 3
-;;
- sd 24[$r62] = $r36
- addd $r6 = $r56, $r58
-;;
- ld $r48 = 800[$r0]
-;;
- sd 32[$r62] = $r48
-;;
- ld $r11 = 808[$r0]
-;;
- sd 40[$r62] = $r11
-;;
- ld $r46 = 816[$r0]
-;;
- sd 48[$r62] = $r46
-;;
- ld $r50 = 824[$r0]
- addd $r0 = $r0, 64
-;;
- sd 56[$r62] = $r50
- addd $r62 = $r56, $r38
- cb.wnez $r32? .L111
-;;
- addd $r0 = $r0, -256
- addd $r1 = $r12, 16
- make $r2, 1024
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1040
-;;
- ret
-;;
- .type bs_shiftrows_rev, @function
- .size bs_shiftrows_rev, . - bs_shiftrows_rev
- .text
- .balign 2
- .globl bs_shiftmix
-bs_shiftmix:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1088
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r4 = $r0, 256
- addd $r1 = $r0, 512
- addd $r3 = $r0, 768
-;;
- sd 24[$r12] = $r19
- addd $r19 = $r12, 64
- make $r18, 0
- addd $r2 = $r0, 0
-;;
- sd 32[$r12] = $r20
- make $r20, 64
-;;
- sd 40[$r12] = $r21
- make $r21, 96
-;;
- sd 48[$r12] = $r22
- make $r22, 32
-;;
- sd 56[$r12] = $r23
- make $r23, 0
-;;
-.L112:
- ld $r46 = 64[$r4]
- addw $r23 = $r23, 1
- make $r32, 4
-;;
- ld $r8 = 128[$r1]
- compw.lt $r32 = $r23, $r32
-;;
- ld $r5 = 56[$r2]
- xord $r57 = $r46, $r8
-;;
- ld $r59 = 120[$r4]
-;;
- xord $r7 = $r5, $r59
- ld $r17 = 192[$r3]
-;;
- xord $r5 = $r57, $r17
-;;
- xord $r61 = $r5, $r7
-;;
- sd 0[$r19] = $r61
-;;
- ld $r48 = 0[$r2]
-;;
- ld $r62 = 64[$r4]
-;;
- xord $r42 = $r48, $r62
- ld $r60 = 72[$r4]
-;;
- xord $r5 = $r42, $r60
- ld $r61 = 136[$r1]
-;;
- xord $r45 = $r5, $r61
- ld $r40 = 200[$r3]
-;;
- xord $r45 = $r45, $r40
-;;
- xord $r5 = $r45, $r7
-;;
- sd 8[$r19] = $r5
-;;
- ld $r11 = 8[$r2]
-;;
- ld $r51 = 72[$r4]
-;;
- xord $r45 = $r11, $r51
- ld $r40 = 80[$r4]
-;;
- xord $r37 = $r45, $r40
- ld $r39 = 144[$r1]
-;;
- xord $r6 = $r37, $r39
- ld $r42 = 208[$r3]
-;;
- xord $r59 = $r6, $r42
-;;
- sd 16[$r19] = $r59
-;;
- ld $r6 = 16[$r2]
-;;
- ld $r44 = 80[$r4]
-;;
- xord $r43 = $r6, $r44
- ld $r9 = 88[$r4]
-;;
- xord $r52 = $r43, $r9
- ld $r46 = 152[$r1]
-;;
- xord $r42 = $r52, $r46
- ld $r48 = 216[$r3]
-;;
- xord $r5 = $r42, $r48
-;;
- xord $r55 = $r5, $r7
-;;
- sd 24[$r19] = $r55
-;;
- ld $r34 = 24[$r2]
-;;
- ld $r8 = 88[$r4]
-;;
- xord $r62 = $r34, $r8
- ld $r47 = 96[$r4]
-;;
- xord $r38 = $r62, $r47
- ld $r50 = 160[$r1]
-;;
- xord $r34 = $r38, $r50
- ld $r56 = 224[$r3]
-;;
- xord $r8 = $r34, $r56
-;;
- xord $r11 = $r8, $r7
-;;
- sd 32[$r19] = $r11
-;;
- ld $r5 = 96[$r4]
-;;
- ld $r53 = 32[$r2]
-;;
- xord $r44 = $r53, $r5
- ld $r54 = 168[$r1]
-;;
- ld $r5 = 104[$r4]
-;;
- xord $r40 = $r44, $r5
-;;
- xord $r10 = $r40, $r54
-;;
- ld $r5 = 232[$r3]
-;;
- xord $r39 = $r10, $r5
-;;
- sd 40[$r19] = $r39
-;;
- ld $r5 = 40[$r2]
-;;
- ld $r58 = 104[$r4]
-;;
- xord $r17 = $r5, $r58
- ld $r15 = 112[$r4]
-;;
- xord $r37 = $r17, $r15
- ld $r5 = 176[$r1]
-;;
- xord $r57 = $r37, $r5
- ld $r51 = 240[$r3]
-;;
- xord $r57 = $r57, $r51
-;;
- sd 48[$r19] = $r57
-;;
- ld $r40 = 48[$r2]
-;;
- ld $r52 = 112[$r4]
-;;
- xord $r35 = $r40, $r52
- ld $r5 = 120[$r4]
-;;
- xord $r5 = $r35, $r5
- ld $r49 = 184[$r1]
-;;
- xord $r15 = $r5, $r49
- ld $r34 = 248[$r3]
-;;
- xord $r46 = $r15, $r34
-;;
- sd 56[$r19] = $r46
-;;
- ld $r33 = 0[$r2]
-;;
- ld $r36 = 128[$r1]
-;;
- ld $r48 = 120[$r4]
- xord $r42 = $r33, $r36
-;;
- ld $r5 = 184[$r1]
-;;
- xord $r34 = $r48, $r5
- ld $r47 = 192[$r3]
-;;
- xord $r60 = $r42, $r47
-;;
- xord $r60 = $r60, $r34
-;;
- sd 64[$r19] = $r60
-;;
- ld $r43 = 8[$r2]
-;;
- ld $r47 = 64[$r4]
-;;
- xord $r63 = $r43, $r47
- ld $r52 = 128[$r1]
-;;
- xord $r5 = $r63, $r52
- ld $r7 = 136[$r1]
-;;
- xord $r60 = $r5, $r7
- ld $r15 = 200[$r3]
-;;
- xord $r55 = $r60, $r15
-;;
- xord $r48 = $r55, $r34
-;;
- sd 72[$r19] = $r48
-;;
- ld $r56 = 16[$r2]
-;;
- ld $r5 = 72[$r4]
-;;
- xord $r7 = $r56, $r5
- ld $r46 = 136[$r1]
-;;
- xord $r41 = $r7, $r46
- ld $r40 = 144[$r1]
-;;
- xord $r5 = $r41, $r40
- ld $r47 = 208[$r3]
-;;
- xord $r5 = $r5, $r47
-;;
- sd 80[$r19] = $r5
-;;
- ld $r52 = 24[$r2]
-;;
- ld $r54 = 80[$r4]
-;;
- xord $r35 = $r52, $r54
- ld $r63 = 144[$r1]
-;;
- xord $r7 = $r35, $r63
- ld $r8 = 152[$r1]
-;;
- xord $r33 = $r7, $r8
- ld $r37 = 216[$r3]
-;;
- xord $r56 = $r33, $r37
-;;
- xord $r54 = $r56, $r34
-;;
- sd 88[$r19] = $r54
-;;
- ld $r9 = 32[$r2]
-;;
- ld $r6 = 88[$r4]
-;;
- xord $r44 = $r9, $r6
- ld $r51 = 152[$r1]
-;;
- xord $r35 = $r44, $r51
- ld $r52 = 160[$r1]
-;;
- xord $r38 = $r35, $r52
- ld $r9 = 224[$r3]
-;;
- xord $r62 = $r38, $r9
-;;
- xord $r6 = $r62, $r34
-;;
- sd 96[$r19] = $r6
-;;
- ld $r15 = 40[$r2]
-;;
- ld $r17 = 96[$r4]
-;;
- xord $r36 = $r15, $r17
- ld $r5 = 160[$r1]
-;;
- xord $r50 = $r36, $r5
- ld $r51 = 168[$r1]
-;;
- xord $r37 = $r50, $r51
- ld $r42 = 232[$r3]
-;;
- xord $r58 = $r37, $r42
-;;
- sd 104[$r19] = $r58
-;;
- ld $r56 = 48[$r2]
-;;
- ld $r41 = 104[$r4]
-;;
- xord $r11 = $r56, $r41
- ld $r48 = 168[$r1]
-;;
- xord $r51 = $r11, $r48
- ld $r58 = 176[$r1]
-;;
- xord $r61 = $r51, $r58
- ld $r5 = 240[$r3]
-;;
- xord $r61 = $r61, $r5
-;;
- sd 112[$r19] = $r61
-;;
- ld $r34 = 56[$r2]
-;;
- ld $r56 = 112[$r4]
-;;
- xord $r46 = $r34, $r56
- ld $r9 = 176[$r1]
-;;
- xord $r62 = $r46, $r9
- ld $r33 = 184[$r1]
-;;
- xord $r46 = $r62, $r33
- ld $r61 = 248[$r3]
-;;
- xord $r40 = $r46, $r61
-;;
- sd 120[$r19] = $r40
-;;
- ld $r5 = 184[$r1]
-;;
- ld $r59 = 248[$r3]
-;;
- xord $r43 = $r5, $r59
- ld $r55 = 0[$r2]
-;;
- ld $r5 = 64[$r4]
-;;
- xord $r42 = $r55, $r5
- ld $r35 = 192[$r3]
-;;
- xord $r49 = $r42, $r35
-;;
- xord $r5 = $r49, $r43
-;;
- sd 128[$r19] = $r5
-;;
- ld $r57 = 8[$r2]
-;;
- ld $r5 = 72[$r4]
-;;
- xord $r44 = $r57, $r5
- ld $r45 = 128[$r1]
-;;
- xord $r17 = $r44, $r45
- ld $r33 = 192[$r3]
-;;
- xord $r52 = $r17, $r33
- ld $r39 = 200[$r3]
-;;
- xord $r35 = $r52, $r39
-;;
- xord $r62 = $r35, $r43
-;;
- sd 136[$r19] = $r62
-;;
- ld $r5 = 16[$r2]
-;;
- ld $r39 = 80[$r4]
-;;
- xord $r36 = $r5, $r39
- ld $r41 = 136[$r1]
-;;
- xord $r6 = $r36, $r41
- ld $r5 = 200[$r3]
-;;
- xord $r35 = $r6, $r5
- ld $r11 = 208[$r3]
-;;
- xord $r37 = $r35, $r11
-;;
- sd 144[$r19] = $r37
-;;
- ld $r5 = 24[$r2]
-;;
- ld $r63 = 88[$r4]
-;;
- xord $r33 = $r5, $r63
- ld $r45 = 144[$r1]
-;;
- xord $r49 = $r33, $r45
- ld $r36 = 208[$r3]
-;;
- xord $r55 = $r49, $r36
- ld $r8 = 216[$r3]
-;;
- xord $r41 = $r55, $r8
-;;
- xord $r58 = $r41, $r43
-;;
- sd 152[$r19] = $r58
-;;
- ld $r6 = 32[$r2]
-;;
- ld $r47 = 96[$r4]
-;;
- xord $r11 = $r6, $r47
- ld $r61 = 152[$r1]
-;;
- xord $r44 = $r11, $r61
- ld $r9 = 216[$r3]
-;;
- xord $r59 = $r44, $r9
- ld $r34 = 224[$r3]
-;;
- xord $r7 = $r59, $r34
-;;
- xord $r17 = $r7, $r43
-;;
- sd 160[$r19] = $r17
-;;
- ld $r54 = 40[$r2]
-;;
- ld $r53 = 104[$r4]
-;;
- xord $r7 = $r54, $r53
- ld $r59 = 160[$r1]
-;;
- xord $r37 = $r7, $r59
- ld $r41 = 224[$r3]
-;;
- xord $r10 = $r37, $r41
- ld $r46 = 232[$r3]
-;;
- xord $r10 = $r10, $r46
-;;
- sd 168[$r19] = $r10
-;;
- ld $r58 = 48[$r2]
-;;
- ld $r5 = 112[$r4]
-;;
- xord $r40 = $r58, $r5
- ld $r38 = 168[$r1]
-;;
- xord $r57 = $r40, $r38
- ld $r51 = 232[$r3]
-;;
- xord $r60 = $r57, $r51
- ld $r55 = 240[$r3]
-;;
- xord $r53 = $r60, $r55
-;;
- sd 176[$r19] = $r53
-;;
- ld $r45 = 56[$r2]
-;;
- ld $r41 = 120[$r4]
-;;
- xord $r5 = $r45, $r41
- ld $r53 = 176[$r1]
-;;
- xord $r38 = $r5, $r53
- ld $r8 = 240[$r3]
-;;
- xord $r43 = $r38, $r8
- ld $r63 = 248[$r3]
-;;
- xord $r6 = $r43, $r63
-;;
- sd 184[$r19] = $r6
-;;
- ld $r8 = 0[$r2]
-;;
- ld $r58 = 64[$r4]
-;;
- ld $r35 = 56[$r2]
- xord $r54 = $r8, $r58
-;;
- ld $r5 = 248[$r3]
-;;
- xord $r50 = $r35, $r5
- ld $r51 = 128[$r1]
-;;
- xord $r11 = $r54, $r51
-;;
- xord $r38 = $r11, $r50
-;;
- sd 192[$r19] = $r38
-;;
- ld $r63 = 8[$r2]
-;;
- ld $r54 = 0[$r2]
-;;
- xord $r54 = $r63, $r54
- ld $r36 = 72[$r4]
-;;
- xord $r5 = $r54, $r36
- ld $r41 = 136[$r1]
-;;
- xord $r39 = $r5, $r41
- ld $r58 = 192[$r3]
-;;
- xord $r44 = $r39, $r58
-;;
- xord $r33 = $r44, $r50
-;;
- sd 200[$r19] = $r33
-;;
- ld $r5 = 8[$r2]
-;;
- ld $r63 = 16[$r2]
-;;
- xord $r54 = $r63, $r5
- ld $r49 = 80[$r4]
- addw $r63 = $r18, 32
-;;
- xord $r51 = $r54, $r49
- ld $r5 = 144[$r1]
- andw $r18 = $r63, 127
-;;
- xord $r43 = $r51, $r5
- ld $r57 = 200[$r3]
-;;
- xord $r47 = $r43, $r57
-;;
- sd 208[$r19] = $r47
- addw $r47 = $r21, 32
-;;
- andw $r21 = $r47, 127
-;;
- ld $r7 = 24[$r2]
-;;
- ld $r15 = 16[$r2]
-;;
- xord $r56 = $r7, $r15
- ld $r48 = 88[$r4]
-;;
- xord $r10 = $r56, $r48
- ld $r51 = 152[$r1]
-;;
- xord $r39 = $r10, $r51
- addw $r10 = $r22, 32
-;;
- ld $r48 = 208[$r3]
- andw $r22 = $r10, 127
-;;
- xord $r53 = $r39, $r48
-;;
- xord $r37 = $r53, $r50
-;;
- sd 216[$r19] = $r37
-;;
- ld $r9 = 32[$r2]
-;;
- ld $r15 = 24[$r2]
-;;
- xord $r43 = $r9, $r15
- ld $r53 = 96[$r4]
- addw $r15 = $r20, 32
-;;
- xord $r42 = $r43, $r53
- ld $r17 = 160[$r1]
- andw $r20 = $r15, 127
-;;
- xord $r55 = $r42, $r17
- ld $r62 = 216[$r3]
- sxwd $r8 = $r20
-;;
- xord $r60 = $r55, $r62
- slld $r43 = $r8, 3
-;;
- xord $r5 = $r60, $r50
- sxwd $r50 = $r18
-;;
- sd 224[$r19] = $r5
- slld $r39 = $r50, 3
-;;
- ld $r5 = 40[$r2]
-;;
- ld $r51 = 32[$r2]
-;;
- xord $r62 = $r5, $r51
- ld $r45 = 168[$r1]
-;;
- ld $r5 = 104[$r4]
-;;
- xord $r9 = $r62, $r5
-;;
- xord $r17 = $r9, $r45
-;;
- ld $r5 = 224[$r3]
-;;
- xord $r49 = $r17, $r5
-;;
- sd 232[$r19] = $r49
-;;
- ld $r33 = 48[$r2]
-;;
- ld $r57 = 40[$r2]
-;;
- xord $r49 = $r33, $r57
- ld $r55 = 112[$r4]
-;;
- xord $r59 = $r49, $r55
- ld $r36 = 176[$r1]
-;;
- xord $r61 = $r59, $r36
- ld $r52 = 232[$r3]
-;;
- xord $r6 = $r61, $r52
-;;
- sd 240[$r19] = $r6
-;;
- ld $r49 = 56[$r2]
-;;
- ld $r45 = 48[$r2]
- addd $r2 = $r0, $r39
-;;
- xord $r56 = $r49, $r45
- ld $r59 = 120[$r4]
-;;
- xord $r11 = $r56, $r59
- ld $r38 = 184[$r1]
-;;
- xord $r4 = $r11, $r38
- ld $r34 = 240[$r3]
- sxwd $r38 = $r22
- sxwd $r3 = $r21
-;;
- xord $r1 = $r4, $r34
- slld $r10 = $r38, 3
- slld $r36 = $r3, 3
-;;
- sd 248[$r19] = $r1
- addd $r19 = $r19, 256
- addd $r4 = $r0, $r10
- addd $r1 = $r0, $r43
-;;
- addd $r3 = $r0, $r36
- cb.wnez $r32? .L112
-;;
- addd $r1 = $r12, 64
- make $r2, 1024
- call memmove
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- ld $r21 = 40[$r12]
-;;
- ld $r22 = 48[$r12]
-;;
- ld $r23 = 56[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1088
-;;
- ret
-;;
- .type bs_shiftmix, @function
- .size bs_shiftmix, . - bs_shiftmix
- .text
- .balign 2
- .globl bs_mixcolumns
-bs_mixcolumns:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1040
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- addd $r46 = $r12, 16
- make $r45, 0
-;;
-.L113:
- ld $r60 = 64[$r0]
- addw $r45 = $r45, 1
- make $r32, 4
-;;
- ld $r54 = 128[$r0]
- compw.lt $r32 = $r45, $r32
-;;
- ld $r44 = 56[$r0]
- xord $r49 = $r60, $r54
-;;
- ld $r7 = 120[$r0]
-;;
- xord $r57 = $r44, $r7
- ld $r5 = 192[$r0]
-;;
- xord $r1 = $r49, $r5
-;;
- xord $r40 = $r1, $r57
-;;
- sd 0[$r46] = $r40
-;;
- ld $r42 = 0[$r0]
-;;
- xord $r53 = $r42, $r60
- ld $r39 = 72[$r0]
-;;
- xord $r43 = $r53, $r39
- ld $r55 = 136[$r0]
-;;
- xord $r6 = $r43, $r55
- ld $r2 = 200[$r0]
-;;
- xord $r15 = $r6, $r2
-;;
- xord $r8 = $r15, $r57
-;;
- sd 8[$r46] = $r8
-;;
- ld $r35 = 8[$r0]
-;;
- xord $r59 = $r35, $r39
- ld $r37 = 80[$r0]
- xord $r60 = $r35, $r60
-;;
- xord $r56 = $r59, $r37
- ld $r6 = 144[$r0]
- xord $r59 = $r59, $r54
-;;
- xord $r43 = $r56, $r6
- ld $r51 = 208[$r0]
- xord $r59 = $r59, $r5
-;;
- xord $r11 = $r43, $r51
- xord $r59 = $r59, $r2
-;;
- sd 16[$r46] = $r11
-;;
- ld $r47 = 16[$r0]
-;;
- xord $r11 = $r47, $r37
- ld $r52 = 88[$r0]
-;;
- xord $r48 = $r11, $r52
- ld $r17 = 152[$r0]
-;;
- xord $r4 = $r48, $r17
- ld $r1 = 216[$r0]
-;;
- xord $r4 = $r4, $r1
-;;
- xord $r3 = $r4, $r57
-;;
- sd 24[$r46] = $r3
-;;
- ld $r8 = 24[$r0]
-;;
- xord $r58 = $r8, $r52
- ld $r36 = 96[$r0]
-;;
- xord $r9 = $r58, $r36
- ld $r50 = 160[$r0]
- xord $r58 = $r58, $r6
-;;
- xord $r40 = $r9, $r50
- ld $r4 = 224[$r0]
-;;
- xord $r61 = $r40, $r4
-;;
- xord $r48 = $r61, $r57
-;;
- sd 32[$r46] = $r48
-;;
- ld $r15 = 32[$r0]
-;;
- xord $r57 = $r15, $r36
- ld $r38 = 104[$r0]
-;;
- xord $r61 = $r57, $r38
- ld $r3 = 168[$r0]
-;;
- xord $r9 = $r61, $r3
- ld $r48 = 232[$r0]
-;;
- xord $r9 = $r9, $r48
-;;
- sd 40[$r46] = $r9
-;;
- ld $r43 = 40[$r0]
-;;
- xord $r34 = $r43, $r38
- ld $r33 = 112[$r0]
-;;
- xord $r40 = $r34, $r33
- ld $r10 = 176[$r0]
- xord $r63 = $r44, $r33
-;;
- xord $r49 = $r40, $r10
- ld $r41 = 240[$r0]
-;;
- xord $r62 = $r49, $r41
-;;
- sd 48[$r46] = $r62
- xord $r62 = $r42, $r54
-;;
- xord $r62 = $r62, $r5
-;;
- ld $r9 = 48[$r0]
-;;
- xord $r56 = $r9, $r33
- ld $r40 = 184[$r0]
-;;
- xord $r49 = $r56, $r7
- xord $r56 = $r56, $r3
-;;
- xord $r61 = $r49, $r40
-;;
- ld $r49 = 248[$r0]
- addd $r0 = $r0, 256
-;;
- xord $r61 = $r61, $r49
-;;
- sd 56[$r46] = $r61
- xord $r61 = $r7, $r40
-;;
- xord $r62 = $r62, $r61
-;;
- sd 64[$r46] = $r62
- xord $r62 = $r60, $r54
-;;
- xord $r60 = $r62, $r55
-;;
- xord $r60 = $r60, $r2
-;;
- xord $r60 = $r60, $r61
-;;
- sd 72[$r46] = $r60
- xord $r60 = $r47, $r39
-;;
- xord $r60 = $r60, $r55
-;;
- xord $r60 = $r60, $r6
-;;
- xord $r60 = $r60, $r51
-;;
- sd 80[$r46] = $r60
- xord $r60 = $r8, $r37
-;;
- xord $r60 = $r60, $r6
-;;
- xord $r60 = $r60, $r17
-;;
- xord $r60 = $r60, $r1
-;;
- xord $r60 = $r60, $r61
-;;
- sd 88[$r46] = $r60
- xord $r60 = $r15, $r52
-;;
- xord $r60 = $r60, $r17
-;;
- xord $r60 = $r60, $r50
-;;
- xord $r60 = $r60, $r4
-;;
- xord $r60 = $r60, $r61
- xord $r61 = $r53, $r5
-;;
- sd 96[$r46] = $r60
- xord $r60 = $r43, $r36
-;;
- xord $r60 = $r60, $r50
-;;
- xord $r60 = $r60, $r3
-;;
- xord $r60 = $r60, $r48
-;;
- sd 104[$r46] = $r60
- xord $r60 = $r9, $r38
-;;
- xord $r60 = $r60, $r3
-;;
- xord $r60 = $r60, $r10
-;;
- xord $r60 = $r60, $r41
-;;
- sd 112[$r46] = $r60
- xord $r60 = $r63, $r10
-;;
- xord $r60 = $r60, $r40
-;;
- xord $r60 = $r60, $r49
-;;
- sd 120[$r46] = $r60
- xord $r60 = $r40, $r49
-;;
- xord $r61 = $r61, $r60
- xord $r63 = $r59, $r60
- xord $r59 = $r11, $r55
-;;
- sd 128[$r46] = $r61
- xord $r59 = $r59, $r2
-;;
- sd 136[$r46] = $r63
- xord $r11 = $r59, $r51
- xord $r63 = $r58, $r51
-;;
- sd 144[$r46] = $r11
- xord $r58 = $r63, $r1
- xord $r11 = $r57, $r17
-;;
- xord $r61 = $r58, $r60
- xord $r57 = $r11, $r1
-;;
- sd 152[$r46] = $r61
- xord $r57 = $r57, $r4
-;;
- xord $r57 = $r57, $r60
-;;
- sd 160[$r46] = $r57
- xord $r57 = $r34, $r50
-;;
- xord $r57 = $r57, $r4
-;;
- xord $r11 = $r57, $r48
- xord $r57 = $r53, $r54
-;;
- sd 168[$r46] = $r11
- xord $r11 = $r56, $r48
-;;
- xord $r56 = $r11, $r41
- xord $r11 = $r44, $r7
-;;
- sd 176[$r46] = $r56
- xord $r34 = $r11, $r10
-;;
- xord $r11 = $r34, $r41
-;;
- xord $r56 = $r11, $r49
- xord $r49 = $r44, $r49
- xord $r11 = $r35, $r42
- xord $r42 = $r9, $r43
-;;
- sd 184[$r46] = $r56
- xord $r53 = $r57, $r49
- xord $r11 = $r11, $r39
- xord $r58 = $r42, $r33
-;;
- sd 192[$r46] = $r53
- xord $r61 = $r11, $r55
- xord $r53 = $r47, $r35
-;;
- xord $r39 = $r61, $r5
- xord $r62 = $r53, $r37
-;;
- xord $r34 = $r39, $r49
- xord $r37 = $r62, $r6
-;;
- sd 200[$r46] = $r34
- xord $r57 = $r37, $r2
- xord $r37 = $r8, $r47
- xord $r34 = $r15, $r8
-;;
- sd 208[$r46] = $r57
- xord $r35 = $r37, $r52
-;;
- xord $r47 = $r35, $r17
-;;
- xord $r47 = $r47, $r51
-;;
- xord $r54 = $r47, $r49
- xord $r47 = $r34, $r36
-;;
- sd 216[$r46] = $r54
- xord $r35 = $r47, $r50
-;;
- xord $r39 = $r35, $r1
-;;
- xord $r11 = $r39, $r49
- xord $r49 = $r43, $r15
-;;
- sd 224[$r46] = $r11
- xord $r53 = $r49, $r38
- xord $r11 = $r58, $r10
- xord $r38 = $r44, $r9
-;;
- xord $r6 = $r53, $r3
- xord $r56 = $r11, $r48
- xord $r52 = $r38, $r7
-;;
- xord $r15 = $r6, $r4
- xord $r34 = $r52, $r40
-;;
- sd 232[$r46] = $r15
- xord $r58 = $r34, $r41
-;;
- sd 240[$r46] = $r56
-;;
- sd 248[$r46] = $r58
- addd $r46 = $r46, 256
- cb.wnez $r32? .L113
-;;
- addd $r0 = $r0, -1024
- addd $r1 = $r46, -1024
- make $r2, 1024
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1040
-;;
- ret
-;;
- .type bs_mixcolumns, @function
- .size bs_mixcolumns, . - bs_mixcolumns
- .text
- .balign 2
- .globl bs_mixcolumns_rev
-bs_mixcolumns_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -1040
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- addd $r49 = $r12, 16
- make $r50, 0
-;;
-.L114:
- ld $r47 = 56[$r0]
- addw $r50 = $r50, 8
- make $r32, 32
-;;
- ld $r11 = 48[$r0]
- compw.lt $r32 = $r50, $r32
-;;
- xord $r56 = $r47, $r11
- ld $r6 = 40[$r0]
-;;
- xord $r2 = $r56, $r6
- ld $r15 = 120[$r0]
-;;
- ld $r33 = 104[$r0]
- xord $r1 = $r47, $r15
-;;
- xord $r60 = $r15, $r33
- ld $r7 = 176[$r0]
-;;
- xord $r57 = $r2, $r60
- ld $r48 = 168[$r0]
-;;
- xord $r63 = $r7, $r48
- ld $r44 = 64[$r0]
-;;
- xord $r62 = $r57, $r63
- ld $r34 = 128[$r0]
-;;
- ld $r3 = 232[$r0]
- xord $r38 = $r44, $r34
-;;
- xord $r9 = $r62, $r3
- ld $r17 = 192[$r0]
-;;
- ld $r51 = 112[$r0]
- xord $r36 = $r38, $r17
-;;
- xord $r8 = $r56, $r51
- ld $r10 = 184[$r0]
- xord $r40 = $r36, $r9
-;;
- xord $r57 = $r10, $r7
- ld $r5 = 240[$r0]
- xord $r4 = $r1, $r10
-;;
- xord $r54 = $r8, $r57
- ld $r39 = 248[$r0]
-;;
- xord $r35 = $r54, $r5
- xord $r58 = $r4, $r39
- sd 0[$r49] = $r40
-;;
- ld $r8 = 0[$r0]
-;;
- xord $r36 = $r8, $r44
- ld $r52 = 72[$r0]
-;;
- xord $r59 = $r36, $r52
- ld $r45 = 136[$r0]
-;;
- xord $r59 = $r59, $r45
- ld $r4 = 200[$r0]
-;;
- xord $r59 = $r59, $r4
-;;
- xord $r36 = $r59, $r9
-;;
- xord $r61 = $r36, $r35
-;;
- sd 8[$r49] = $r61
-;;
- ld $r43 = 8[$r0]
-;;
- xord $r53 = $r43, $r8
- ld $r46 = 80[$r0]
-;;
- xord $r53 = $r53, $r52
- ld $r2 = 144[$r0]
-;;
- xord $r36 = $r53, $r46
- ld $r42 = 208[$r0]
-;;
- xord $r59 = $r36, $r2
-;;
- xord $r53 = $r59, $r34
-;;
- xord $r53 = $r53, $r42
-;;
- xord $r37 = $r53, $r35
-;;
- xord $r53 = $r37, $r58
-;;
- sd 16[$r49] = $r53
-;;
- ld $r1 = 16[$r0]
-;;
- xord $r41 = $r1, $r43
- ld $r38 = 88[$r0]
-;;
- xord $r36 = $r41, $r8
-;;
- xord $r53 = $r36, $r44
-;;
- xord $r36 = $r53, $r46
- ld $r41 = 152[$r0]
-;;
- xord $r36 = $r36, $r38
-;;
- xord $r40 = $r36, $r41
-;;
- xord $r53 = $r40, $r45
-;;
- xord $r36 = $r53, $r34
-;;
- ld $r53 = 216[$r0]
-;;
- xord $r54 = $r36, $r53
-;;
- xord $r36 = $r54, $r17
-;;
- xord $r36 = $r36, $r9
-;;
- xord $r36 = $r36, $r58
-;;
- sd 24[$r49] = $r36
-;;
- ld $r36 = 24[$r0]
-;;
- xord $r54 = $r36, $r1
- ld $r40 = 96[$r0]
-;;
- xord $r61 = $r54, $r43
- ld $r37 = 160[$r0]
-;;
- xord $r54 = $r61, $r52
-;;
- xord $r59 = $r54, $r38
-;;
- xord $r59 = $r59, $r40
-;;
- xord $r54 = $r59, $r37
-;;
- xord $r54 = $r54, $r2
-;;
- xord $r55 = $r54, $r45
-;;
- ld $r54 = 224[$r0]
-;;
- xord $r55 = $r55, $r54
-;;
- xord $r55 = $r55, $r4
-;;
- xord $r55 = $r55, $r9
-;;
- xord $r9 = $r55, $r35
-;;
- sd 32[$r49] = $r9
-;;
- ld $r9 = 32[$r0]
- addd $r0 = $r0, 256
-;;
- xord $r55 = $r9, $r36
- xord $r61 = $r6, $r9
-;;
- xord $r55 = $r55, $r1
-;;
- xord $r55 = $r55, $r46
-;;
- xord $r55 = $r55, $r40
-;;
- xord $r55 = $r55, $r33
-;;
- xord $r55 = $r55, $r48
-;;
- xord $r55 = $r55, $r41
-;;
- xord $r55 = $r55, $r2
-;;
- xord $r55 = $r55, $r3
-;;
- xord $r55 = $r55, $r42
-;;
- xord $r35 = $r55, $r35
-;;
- xord $r60 = $r35, $r58
- xord $r35 = $r61, $r36
-;;
- sd 40[$r49] = $r60
- xord $r55 = $r35, $r38
-;;
- xord $r62 = $r55, $r33
-;;
- xord $r59 = $r62, $r51
- xord $r62 = $r8, $r34
-;;
- xord $r35 = $r59, $r7
- xord $r59 = $r11, $r6
- xord $r62 = $r62, $r17
-;;
- xord $r35 = $r35, $r37
-;;
- xord $r35 = $r35, $r41
-;;
- xord $r55 = $r35, $r5
- xord $r35 = $r59, $r9
-;;
- xord $r63 = $r55, $r53
- xord $r60 = $r35, $r40
-;;
- xord $r55 = $r63, $r58
- xord $r35 = $r60, $r51
-;;
- sd 48[$r49] = $r55
- xord $r63 = $r35, $r15
- xord $r55 = $r15, $r51
-;;
- xord $r35 = $r63, $r10
- xord $r63 = $r1, $r52
-;;
- xord $r35 = $r35, $r48
-;;
- xord $r35 = $r35, $r37
-;;
- xord $r60 = $r35, $r39
- xord $r35 = $r55, $r33
-;;
- xord $r60 = $r60, $r54
- xord $r35 = $r6, $r35
-;;
- sd 56[$r49] = $r60
- xord $r60 = $r10, $r48
-;;
- xord $r61 = $r35, $r60
- xord $r60 = $r5, $r3
- xord $r35 = $r39, $r5
-;;
- xord $r60 = $r61, $r60
- xord $r61 = $r11, $r55
-;;
- xord $r61 = $r61, $r7
- xord $r62 = $r62, $r60
-;;
- xord $r61 = $r61, $r35
- sd 64[$r49] = $r62
- xord $r62 = $r43, $r44
-;;
- xord $r62 = $r62, $r45
-;;
- xord $r62 = $r62, $r34
-;;
- xord $r62 = $r62, $r4
-;;
- xord $r62 = $r62, $r60
-;;
- xord $r62 = $r62, $r61
-;;
- sd 72[$r49] = $r62
- xord $r62 = $r63, $r44
-;;
- xord $r62 = $r62, $r2
-;;
- xord $r62 = $r62, $r45
-;;
- xord $r62 = $r62, $r42
-;;
- xord $r62 = $r62, $r17
-;;
- xord $r62 = $r62, $r61
-;;
- xord $r62 = $r62, $r58
-;;
- sd 80[$r49] = $r62
- xord $r62 = $r36, $r8
-;;
- xord $r62 = $r62, $r46
-;;
- xord $r62 = $r62, $r52
-;;
- xord $r62 = $r62, $r44
-;;
- xord $r62 = $r62, $r41
-;;
- xord $r62 = $r62, $r2
-;;
- xord $r62 = $r62, $r34
-;;
- xord $r62 = $r62, $r53
-;;
- xord $r62 = $r62, $r4
-;;
- xord $r62 = $r62, $r17
-;;
- xord $r62 = $r62, $r60
-;;
- xord $r62 = $r62, $r58
-;;
- sd 88[$r49] = $r62
- xord $r62 = $r9, $r43
-;;
- xord $r62 = $r62, $r38
-;;
- xord $r62 = $r62, $r46
-;;
- xord $r62 = $r62, $r52
-;;
- xord $r62 = $r62, $r37
-;;
- xord $r62 = $r62, $r41
-;;
- xord $r62 = $r62, $r45
-;;
- xord $r62 = $r62, $r54
-;;
- xord $r62 = $r62, $r42
-;;
- xord $r62 = $r62, $r4
-;;
- xord $r60 = $r62, $r60
-;;
- xord $r60 = $r60, $r61
-;;
- sd 96[$r49] = $r60
- xord $r60 = $r6, $r1
-;;
- xord $r60 = $r60, $r40
-;;
- xord $r60 = $r60, $r38
-;;
- xord $r60 = $r60, $r46
-;;
- xord $r60 = $r60, $r48
-;;
- xord $r60 = $r60, $r37
-;;
- xord $r60 = $r60, $r2
-;;
- xord $r60 = $r60, $r3
-;;
- xord $r60 = $r60, $r53
-;;
- xord $r60 = $r60, $r42
-;;
- xord $r60 = $r60, $r61
-;;
- xord $r60 = $r60, $r58
-;;
- sd 104[$r49] = $r60
- xord $r60 = $r11, $r36
-;;
- xord $r60 = $r60, $r33
-;;
- xord $r60 = $r60, $r40
-;;
- xord $r60 = $r60, $r38
-;;
- xord $r62 = $r60, $r7
-;;
- xord $r60 = $r62, $r48
-;;
- xord $r60 = $r60, $r41
-;;
- xord $r60 = $r60, $r5
-;;
- xord $r60 = $r60, $r54
-;;
- xord $r60 = $r60, $r53
-;;
- xord $r58 = $r60, $r58
-;;
- sd 112[$r49] = $r58
- xord $r58 = $r47, $r9
-;;
- xord $r58 = $r58, $r51
-;;
- xord $r58 = $r58, $r33
-;;
- xord $r58 = $r58, $r40
-;;
- xord $r58 = $r58, $r10
-;;
- xord $r58 = $r58, $r7
-;;
- xord $r58 = $r58, $r37
-;;
- xord $r58 = $r58, $r39
-;;
- xord $r63 = $r58, $r3
-;;
- xord $r58 = $r63, $r54
-;;
- sd 120[$r49] = $r58
- xord $r58 = $r57, $r48
- xord $r57 = $r51, $r57
-;;
- xord $r60 = $r33, $r58
- xord $r58 = $r39, $r3
- xord $r63 = $r57, $r5
-;;
- xord $r58 = $r60, $r58
- xord $r63 = $r63, $r56
- xord $r56 = $r15, $r10
-;;
- xord $r61 = $r58, $r59
- xord $r56 = $r56, $r39
-;;
- xord $r62 = $r56, $r47
- xord $r56 = $r44, $r17
-;;
- xord $r56 = $r56, $r8
-;;
- xord $r56 = $r56, $r61
-;;
- sd 128[$r49] = $r56
- xord $r56 = $r52, $r34
-;;
- xord $r56 = $r56, $r4
-;;
- xord $r56 = $r56, $r17
-;;
- xord $r56 = $r56, $r43
-;;
- xord $r56 = $r56, $r61
-;;
- xord $r56 = $r56, $r63
-;;
- sd 136[$r49] = $r56
- xord $r56 = $r46, $r45
-;;
- xord $r56 = $r56, $r34
-;;
- xord $r56 = $r56, $r42
-;;
- xord $r56 = $r56, $r4
-;;
- xord $r56 = $r56, $r1
-;;
- xord $r56 = $r56, $r8
-;;
- xord $r56 = $r56, $r63
-;;
- xord $r56 = $r56, $r62
-;;
- sd 144[$r49] = $r56
- xord $r56 = $r38, $r44
-;;
- xord $r56 = $r56, $r2
-;;
- xord $r56 = $r56, $r45
-;;
- xord $r56 = $r56, $r34
-;;
- xord $r56 = $r56, $r53
-;;
- xord $r56 = $r56, $r42
-;;
- xord $r56 = $r56, $r17
-;;
- xord $r56 = $r56, $r36
-;;
- xord $r59 = $r56, $r43
-;;
- xord $r56 = $r59, $r8
-;;
- xord $r59 = $r56, $r61
-;;
- xord $r56 = $r59, $r62
- xord $r59 = $r33, $r46
-;;
- sd 152[$r49] = $r56
- xord $r56 = $r40, $r52
-;;
- xord $r56 = $r56, $r41
-;;
- xord $r56 = $r56, $r2
-;;
- xord $r56 = $r56, $r45
-;;
- xord $r56 = $r56, $r54
-;;
- xord $r56 = $r56, $r53
-;;
- xord $r56 = $r56, $r4
-;;
- xord $r56 = $r56, $r9
-;;
- xord $r56 = $r56, $r1
-;;
- xord $r56 = $r56, $r43
-;;
- xord $r56 = $r56, $r61
-;;
- xord $r56 = $r56, $r63
-;;
- sd 160[$r49] = $r56
- xord $r56 = $r59, $r37
-;;
- xord $r56 = $r56, $r41
-;;
- xord $r56 = $r56, $r2
-;;
- xord $r56 = $r56, $r3
-;;
- xord $r56 = $r56, $r54
-;;
- xord $r57 = $r56, $r42
-;;
- xord $r56 = $r57, $r6
-;;
- xord $r56 = $r56, $r36
-;;
- xord $r56 = $r56, $r1
-;;
- xord $r56 = $r56, $r63
-;;
- xord $r56 = $r56, $r62
-;;
- sd 168[$r49] = $r56
- xord $r56 = $r51, $r38
-;;
- xord $r56 = $r56, $r48
-;;
- xord $r56 = $r56, $r37
-;;
- xord $r58 = $r56, $r41
-;;
- xord $r56 = $r58, $r5
-;;
- xord $r56 = $r56, $r3
-;;
- xord $r56 = $r56, $r53
-;;
- xord $r56 = $r56, $r11
-;;
- xord $r58 = $r56, $r9
-;;
- xord $r56 = $r58, $r36
-;;
- xord $r56 = $r56, $r62
-;;
- sd 176[$r49] = $r56
- xord $r56 = $r15, $r40
-;;
- xord $r56 = $r56, $r7
-;;
- xord $r56 = $r56, $r48
-;;
- xord $r56 = $r56, $r37
-;;
- xord $r60 = $r56, $r39
- xord $r39 = $r10, $r39
-;;
- xord $r56 = $r60, $r5
-;;
- xord $r56 = $r56, $r54
-;;
- xord $r56 = $r56, $r47
-;;
- xord $r56 = $r56, $r6
-;;
- xord $r56 = $r56, $r9
-;;
- sd 184[$r49] = $r56
- xord $r56 = $r35, $r3
-;;
- xord $r57 = $r48, $r56
- xord $r56 = $r47, $r6
-;;
- xord $r57 = $r57, $r56
- xord $r56 = $r51, $r33
-;;
- xord $r56 = $r57, $r56
- xord $r57 = $r7, $r35
-;;
- xord $r35 = $r57, $r11
- xord $r57 = $r39, $r47
-;;
- xord $r55 = $r35, $r55
- xord $r35 = $r57, $r15
- xord $r57 = $r34, $r8
- xord $r34 = $r41, $r34
-;;
- xord $r39 = $r57, $r44
- xord $r57 = $r45, $r17
- xord $r58 = $r34, $r42
-;;
- xord $r39 = $r39, $r56
- xord $r34 = $r58, $r4
-;;
- sd 192[$r49] = $r39
- xord $r39 = $r57, $r43
-;;
- xord $r39 = $r39, $r8
-;;
- xord $r39 = $r39, $r52
-;;
- xord $r57 = $r39, $r56
-;;
- xord $r39 = $r57, $r55
-;;
- sd 200[$r49] = $r39
- xord $r39 = $r2, $r4
-;;
- xord $r39 = $r39, $r17
- xord $r17 = $r34, $r17
-;;
- xord $r39 = $r39, $r1
-;;
- xord $r57 = $r39, $r43
-;;
- xord $r39 = $r57, $r46
-;;
- xord $r39 = $r39, $r44
-;;
- xord $r63 = $r39, $r55
-;;
- xord $r57 = $r63, $r35
-;;
- sd 208[$r49] = $r57
- xord $r57 = $r17, $r36
-;;
- xord $r57 = $r57, $r1
-;;
- xord $r57 = $r57, $r8
- xord $r8 = $r48, $r2
-;;
- xord $r17 = $r57, $r38
- xord $r57 = $r37, $r45
-;;
- xord $r59 = $r17, $r52
- xord $r62 = $r57, $r53
-;;
- xord $r34 = $r59, $r44
- xord $r39 = $r62, $r42
-;;
- xord $r44 = $r34, $r56
-;;
- xord $r44 = $r44, $r35
-;;
- sd 216[$r49] = $r44
- xord $r44 = $r39, $r4
-;;
- xord $r4 = $r44, $r9
-;;
- xord $r4 = $r4, $r36
-;;
- xord $r57 = $r4, $r43
- xord $r43 = $r8, $r54
-;;
- xord $r59 = $r57, $r40
- xord $r48 = $r43, $r53
-;;
- xord $r34 = $r59, $r46
-;;
- xord $r52 = $r34, $r52
-;;
- xord $r52 = $r52, $r56
- xord $r56 = $r10, $r37
-;;
- xord $r39 = $r52, $r55
- xord $r52 = $r48, $r42
-;;
- sd 224[$r49] = $r39
- xord $r42 = $r52, $r6
-;;
- xord $r17 = $r42, $r9
-;;
- xord $r39 = $r17, $r1
-;;
- xord $r48 = $r39, $r33
-;;
- xord $r42 = $r48, $r38
-;;
- xord $r17 = $r42, $r46
-;;
- xord $r52 = $r17, $r55
- xord $r55 = $r7, $r41
-;;
- xord $r17 = $r52, $r35
- xord $r34 = $r55, $r3
-;;
- sd 232[$r49] = $r17
- xord $r44 = $r34, $r54
-;;
- xord $r39 = $r44, $r53
-;;
- xord $r60 = $r39, $r11
-;;
- xord $r61 = $r60, $r6
-;;
- xord $r8 = $r61, $r36
-;;
- xord $r4 = $r8, $r51
-;;
- xord $r39 = $r4, $r40
-;;
- xord $r2 = $r39, $r38
-;;
- xord $r2 = $r2, $r35
- xord $r35 = $r56, $r5
-;;
- sd 240[$r49] = $r2
- xord $r62 = $r35, $r3
-;;
- xord $r38 = $r62, $r54
-;;
- xord $r48 = $r38, $r47
-;;
- xord $r38 = $r48, $r11
-;;
- xord $r11 = $r38, $r9
-;;
- xord $r1 = $r11, $r15
-;;
- xord $r55 = $r1, $r33
-;;
- xord $r5 = $r55, $r40
-;;
- sd 248[$r49] = $r5
- addd $r49 = $r49, 256
- cb.wnez $r32? .L114
-;;
- addd $r0 = $r0, -1024
- addd $r1 = $r49, -1024
- make $r2, 1024
- call memmove
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 1040
-;;
- ret
-;;
- .type bs_mixcolumns_rev, @function
- .size bs_mixcolumns_rev, . - bs_mixcolumns_rev
- .text
- .balign 2
- .globl bs_expand_key
-bs_expand_key:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -224
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
- addd $r0 = $r12, 40
- make $r2, 16
-;;
- sd 24[$r12] = $r19
-;;
- sd 32[$r12] = $r20
- call memmove
-;;
- addd $r0 = $r12, 40
- call expand_key
-;;
- make $r20, 0
- make $r19, 0
-;;
-.L115:
- sxwd $r1 = $r20
- addd $r11 = $r12, 40
- sxwd $r15 = $r19
- make $r2, 16
-;;
- slld $r34 = $r1, 10
- addd $r1 = $r11, $r15
-;;
- addd $r0 = $r18, $r34
- call memmove
-;;
- make $r1, 2
-;;
-.L116:
- make $r35, 0
-;;
-.L117:
- addw $r38 = $r1, $r35
- sxwd $r37 = $r35
- addw $r35 = $r35, 1
- make $r32, 2
-;;
- sxwd $r6 = $r20
- sxwd $r33 = $r38
- slld $r10 = $r37, 3
- compw.lt $r32 = $r35, $r32
-;;
- slld $r3 = $r6, 10
- slld $r9 = $r33, 3
-;;
- addd $r0 = $r18, $r3
-;;
- addd $r39 = $r0, $r9
- addd $r8 = $r0, $r10
-;;
- ld $r17 = 0[$r8]
-;;
- sd 0[$r39] = $r17
-;;
- cb.wnez $r32? .L117
-;;
- addw $r1 = $r1, 2
- make $r32, 128
-;;
- compw.lt $r32 = $r1, $r32
-;;
- cb.wnez $r32? .L116
-;;
- call bs_transpose
-;;
- addw $r20 = $r20, 1
- addw $r19 = $r19, 16
- make $r32, 176
-;;
- compw.lt $r32 = $r19, $r32
-;;
- cb.wnez $r32? .L115
-;;
- ld $r16 = 8[$r12]
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 224
-;;
- ret
-;;
- .type bs_expand_key, @function
- .size bs_expand_key, . - bs_expand_key
- .text
- .balign 2
- .globl bs_cipher
-bs_cipher:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -48
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
-;;
- sd 24[$r12] = $r19
- addd $r19 = $r1, 0
- addd $r0 = $r18, 0
-;;
- sd 32[$r12] = $r20
- call bs_transpose
-;;
- addd $r1 = $r19, 0
- addd $r0 = $r18, 0
- call bs_addroundkey
-;;
- make $r20, 1
-;;
-.L118:
- addd $r0 = $r18, 0
- call bs_apply_sbox
-;;
- addd $r0 = $r18, 0
- call bs_shiftmix
-;;
- sxwd $r6 = $r20
- addd $r0 = $r18, 0
-;;
- slld $r4 = $r6, 10
-;;
- addd $r1 = $r19, $r4
- call bs_addroundkey
-;;
- addw $r20 = $r20, 1
- make $r32, 10
-;;
- compw.lt $r32 = $r20, $r32
-;;
- cb.wnez $r32? .L118
-;;
- addd $r0 = $r18, 0
- call bs_apply_sbox
-;;
- addd $r0 = $r18, 0
- call bs_shiftrows
-;;
- addd $r1 = $r19, 10240
- addd $r0 = $r18, 0
- call bs_addroundkey
-;;
- addd $r0 = $r18, 0
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 48
-;;
- goto bs_transpose_rev
-;;
- .type bs_cipher, @function
- .size bs_cipher, . - bs_cipher
- .text
- .balign 2
- .globl bs_cipher_rev
-bs_cipher_rev:
- addd $r17 = $r12, 0
- addd $r12 = $r12, -48
-;;
- sd 0[$r12] = $r17
-;;
-;;
- get $r16 = $ra
-;;
- sd 8[$r12] = $r16
-;;
- sd 16[$r12] = $r18
- addd $r18 = $r0, 0
-;;
- sd 24[$r12] = $r19
- addd $r19 = $r1, 0
- addd $r0 = $r18, 0
-;;
- sd 32[$r12] = $r20
- call bs_transpose
-;;
- addd $r1 = $r19, 10240
- addd $r0 = $r18, 0
- call bs_addroundkey
-;;
- make $r20, 9
-;;
-.L119:
- addd $r0 = $r18, 0
- call bs_shiftrows_rev
-;;
- addd $r0 = $r18, 0
- call bs_apply_sbox_rev
-;;
- sxwd $r5 = $r20
- addd $r0 = $r18, 0
-;;
- slld $r8 = $r5, 10
-;;
- addd $r1 = $r19, $r8
- call bs_addroundkey
-;;
- addd $r0 = $r18, 0
- call bs_mixcolumns_rev
-;;
- addw $r20 = $r20, -1
-;;
- cb.wgtz $r20? .L119
-;;
- addd $r0 = $r18, 0
- call bs_shiftrows_rev
-;;
- addd $r0 = $r18, 0
- call bs_apply_sbox_rev
-;;
- addd $r1 = $r19, 0
- addd $r0 = $r18, 0
- call bs_addroundkey
-;;
- addd $r0 = $r18, 0
-;;
- ld $r18 = 16[$r12]
-;;
- ld $r19 = 24[$r12]
-;;
- ld $r20 = 32[$r12]
-;;
- ld $r16 = 8[$r12]
-;;
- set $ra = $r16
-;;
- addd $r12 = $r12, 48
-;;
- goto bs_transpose_rev
-;;
- .type bs_cipher_rev, @function
- .size bs_cipher_rev, . - bs_cipher_rev
diff --git a/test/monniaux/bitsliced-aes/make.proto b/test/monniaux/bitsliced-aes/make.proto
deleted file mode 100644
index 8a9a1bff..00000000
--- a/test/monniaux/bitsliced-aes/make.proto
+++ /dev/null
@@ -1,4 +0,0 @@
-sources: "$(wildcard *.c) tests/tests.c"
-target: test
-measures: [cycles]
-name: bitsliced-aes
diff --git a/test/monniaux/bitsliced-tea/Makefile b/test/monniaux/bitsliced-tea/Makefile
new file mode 100644
index 00000000..02b35381
--- /dev/null
+++ b/test/monniaux/bitsliced-tea/Makefile
@@ -0,0 +1,3 @@
+TARGET=bitsliced-tea
+
+include ../rules.mk
diff --git a/test/monniaux/bitsliced-tea/bstea.h b/test/monniaux/bitsliced-tea/bstea.h
index 9ca4f776..15607464 100644
--- a/test/monniaux/bitsliced-tea/bstea.h
+++ b/test/monniaux/bitsliced-tea/bstea.h
@@ -5,17 +5,8 @@
#include <limits.h>
#include "bstea_wordsize.h"
-#include "../ternary.h"
-/*
+
#define TERNARY(x, v1, v0) ((x) ? (v1) : (v0))
-*/
-#if __BSTEA_WORDSIZE==64
-#define TERNARY(x, v1, v0) TERNARY64(x, v1, v0)
-#elif __BSTEA_WORDSIZE==32
-#define TERNARY(x, v1, v0) TERNARY32(x, v1, v0)
-#else
-#error What is the bit size !?
-#endif
#define TEA_ROUNDS 32
diff --git a/test/monniaux/bitsliced-tea/make.proto b/test/monniaux/bitsliced-tea/make.proto
deleted file mode 100644
index 6cdc0814..00000000
--- a/test/monniaux/bitsliced-tea/make.proto
+++ /dev/null
@@ -1,4 +0,0 @@
-objdeps: [{name: bstea_run, compiler: gcc}]
-target: bstea
-name: bitsliced-tea
-measures: [cycles]
diff --git a/test/monniaux/build_benches.sh b/test/monniaux/build_benches.sh
index 02123665..01abf55d 100755
--- a/test/monniaux/build_benches.sh
+++ b/test/monniaux/build_benches.sh
@@ -1,9 +1,26 @@
+#!/usr/bin/env bash
+TMPFILE=/tmp/1513times.txt
+
+cores=$(grep -c ^processor /proc/cpuinfo)
source benches.sh
+default="\e[39m"
+magenta="\e[35m"
+red="\e[31m"
+
rm -f commands.txt
+rm -f $TMPFILE
for bench in $benches; do
- echo "(cd $bench && make -j5 $1)" >> commands.txt
+ echo -e "${magenta}Building $bench..${default}"
+ if [ "$1" == "" ]; then
+ (cd $bench && make -s -j$cores > /dev/null &> /dev/null) || { echo -e "${red}Build failed" && break; }
+ else
+ (cd $bench && make -j$cores) | grep -P "\d+: \d+\.\d+" >> $TMPFILE
+ fi
done
-cat commands.txt | xargs -n1 -I{} -P4 bash -c '{}'
+if [ "$1" != "" ]; then
+ cat $TMPFILE | sort -n -k 1 > $1
+fi
+
diff --git a/test/monniaux/builtins/fma.c b/test/monniaux/builtins/fma.c
new file mode 100644
index 00000000..4083e781
--- /dev/null
+++ b/test/monniaux/builtins/fma.c
@@ -0,0 +1,14 @@
+#define COMPCERT_NO_FP_MACROS
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+int main(int argc, char **argv) {
+ if (argc < 4) return 1;
+ double x = strtod(argv[1], NULL);
+ double y = strtod(argv[2], NULL);
+ double z = strtod(argv[3], NULL);
+ printf("%g %g %g\n", __builtin_fma(x, y, z), fma(x, y, z), x*y + z);
+ printf("%g %g %g\n", __builtin_fma(-x, y, z), fma(-x, y, z), (-x)*y + z);
+ return 0;
+}
diff --git a/test/monniaux/clean_benches.sh b/test/monniaux/clean_benches.sh
index c0a87ff9..dff15fd4 100755
--- a/test/monniaux/clean_benches.sh
+++ b/test/monniaux/clean_benches.sh
@@ -1,8 +1,12 @@
source benches.sh
+blue="\e[34m"
+default="\e[39m"
+
rm -f commands.txt
for bench in $benches; do
- (cd $bench && make clean)
+ echo -e "${blue}Cleaning $bench..${default}"
+ (cd $bench && make -s clean)
done
rm -f *.o
diff --git a/test/monniaux/clock.c b/test/monniaux/clock.c
index 7611a2ee..4ec679f6 100644
--- a/test/monniaux/clock.c
+++ b/test/monniaux/clock.c
@@ -24,9 +24,9 @@ cycle_t get_current_cycle(void) {
}
void print_total_clock(void) {
- printf("cycles: %lu\n", total_clock);
+ printf("time cycles: %" PRcycle "\n", total_clock);
}
void printerr_total_clock(void) {
- fprintf(stderr, "cycles: %lu\n", total_clock);
+ fprintf(stderr, "time cycles: %" PRcycle "\n", total_clock);
}
diff --git a/test/monniaux/complex/Makefile b/test/monniaux/complex/Makefile
new file mode 100644
index 00000000..38c10eab
--- /dev/null
+++ b/test/monniaux/complex/Makefile
@@ -0,0 +1,4 @@
+TARGET=complex_mat
+MEASURES="c1 c8 c9"
+
+include ../rules.mk
diff --git a/test/monniaux/complex/complex_mat.c b/test/monniaux/complex/complex_mat.c
index b7103f60..f39dccf0 100644
--- a/test/monniaux/complex/complex_mat.c
+++ b/test/monniaux/complex/complex_mat.c
@@ -227,9 +227,9 @@ int main() {
printf("c1==c8: %s\n"
"c1==c9: %s\n"
- "c1_time : %" PRIu64 "\n"
- "c8_time : %" PRIu64 "\n"
- "c9_time : %" PRIu64 "\n",
+ "c1 cycles: %" PRIu64 "\n"
+ "c8 cycles: %" PRIu64 "\n"
+ "c9 cycles: %" PRIu64 "\n",
COMPLEX_mat_equal(m, n, c1, p, c8, p)?"true":"false",
COMPLEX_mat_equal(m, n, c1, p, c9, p)?"true":"false",
diff --git a/test/monniaux/complex/make.proto b/test/monniaux/complex/make.proto
deleted file mode 100644
index 8870f311..00000000
--- a/test/monniaux/complex/make.proto
+++ /dev/null
@@ -1,2 +0,0 @@
-target: complex_mat
-measures: [[c1_time, c1]]
diff --git a/test/monniaux/cse2/loopaccess.c b/test/monniaux/cse2/loopaccess.c
new file mode 100644
index 00000000..5ddaeb66
--- /dev/null
+++ b/test/monniaux/cse2/loopaccess.c
@@ -0,0 +1,7 @@
+double toto(double x, int count) {
+ double r = 5*x + 3;
+ while (count > r) {
+ count --;
+ }
+ return 5*x + 3;
+}
diff --git a/test/monniaux/cse2/loopinvariant.c b/test/monniaux/cse2/loopinvariant.c
new file mode 100644
index 00000000..64caf80b
--- /dev/null
+++ b/test/monniaux/cse2/loopinvariant.c
@@ -0,0 +1,7 @@
+int toto(int *t, int n) {
+ int x = t[0];
+ for(int i=1; i<n; i++) {
+ if (t[i] > t[0]) return i;
+ }
+ return 0;
+}
diff --git a/test/monniaux/cse2/loopload.c b/test/monniaux/cse2/loopload.c
new file mode 100644
index 00000000..6e0925f7
--- /dev/null
+++ b/test/monniaux/cse2/loopload.c
@@ -0,0 +1,5 @@
+int find_index(int *t, int n) {
+ if (t[0] > 0) return 3;
+ while (n > 0) n--;
+ return t[0];
+}
diff --git a/test/monniaux/csmith/Makefile b/test/monniaux/csmith/Makefile
index e6961036..3c748c62 100644
--- a/test/monniaux/csmith/Makefile
+++ b/test/monniaux/csmith/Makefile
@@ -1,8 +1,8 @@
-CSMITH=csmith
+CSMITH?=/local/monniaux/packages/csmith-2.3.0/bin/csmith
MAX=1000
include ../rules.mk
-K1C_CCOMPFLAGS+=-I/usr/include/csmith -fstruct-passing -fbitfields
+K1C_CCOMPFLAGS+=-I/local/monniaux/packages/csmith-2.3.0/include/csmith-2.3.0 -fstruct-passing -fbitfields
TARGETS_S=$(shell seq --format src%06.f.ccomp.k1c.s 0 $(MAX))
TARGETS_C=$(shell seq --format src%06.f.c 0 $(MAX))
diff --git a/test/monniaux/cycles.h b/test/monniaux/cycles.h
index 45c900e3..c7dc582b 100644
--- a/test/monniaux/cycles.h
+++ b/test/monniaux/cycles.h
@@ -1,32 +1,93 @@
-typedef unsigned long cycle_t;
+#include <stdint.h>
+#include <inttypes.h>
+#include <stdio.h>
#ifdef __K1C__
-#ifdef __K1C_COS__
-#include <hal/cos_registers.h>
-#define K1_SFR_PMC COS_SFR_PMC
-#define K1_SFR_PM0 COS_SFR_PM0
-#else
-#include <mppa_bare_runtime/k1c/registers.h>
-#endif
+typedef uint64_t cycle_t;
+#define PRcycle PRId64
+
+#include <../../k1-cos/include/hal/cos_registers.h>
+
static inline void cycle_count_config(void)
{
/* config pmc for cycle count */
- cycle_t pmc_value = __builtin_k1_get(K1_SFR_PMC);
+ cycle_t pmc_value = __builtin_k1_get(COS_SFR_PMC);
pmc_value &= ~(0xfULL);
- __builtin_k1_set(K1_SFR_PMC, pmc_value);
+ __builtin_k1_set(COS_SFR_PMC, pmc_value);
}
static inline cycle_t get_cycle(void)
{
- return __builtin_k1_get(K1_SFR_PM0);
+ return __builtin_k1_get(COS_SFR_PM0);
}
-#else
+
+#else // not K1C
static inline void cycle_count_config(void) { }
-#ifdef __x86_64__
+
+#if defined(__i386__) || defined( __x86_64__)
+#define PRcycle PRId64
+typedef uint64_t cycle_t;
#include <x86intrin.h>
static inline cycle_t get_cycle(void) { return __rdtsc(); }
+
+#elif __riscv
+#ifdef __riscv32
+#define PRcycle PRId32
+typedef uint32_t cycle_t;
+#else
+#define PRcycle PRId64
+typedef uint64_t cycle_t;
+#endif
+static inline cycle_t get_cycle(void) {
+ cycle_t cycles;
+ asm volatile ("rdcycle %0" : "=r" (cycles));
+ return cycles;
+}
+
+#elif defined (__ARM_ARCH) && (__ARM_ARCH >= 6)
+#if (__ARM_ARCH < 8)
+typedef uint32_t cycle_t;
+#define PRcycle PRId32
+
+/* need this kernel module
+https://github.com/zertyz/MTL/tree/master/cpp/time/kernel/arm */
+static inline cycle_t get_cycle(void) {
+ cycle_t cycles;
+ __asm__ volatile ("mrc p15, 0, %0, c9, c13, 0":"=r" (cycles));
+ return cycles;
+}
#else
+#define PRcycle PRId64
+typedef uint64_t cycle_t;
+/* need this kernel module:
+https://github.com/jerinjacobk/armv8_pmu_cycle_counter_el0
+
+on 5+ kernels, remove first argument of access_ok macro */
+
+static inline cycle_t get_cycle(void)
+{
+ uint64_t val;
+ __asm__ volatile("mrs %0, pmccntr_el0" : "=r"(val));
+ return val;
+}
+#endif
+
+#else
+#define PRcycle PRId32
+typedef uint32_t cycle_t;
static inline cycle_t get_cycle(void) { return 0; }
#endif
#endif
+
+#ifdef MAX_MEASURES
+ #define TIMEINIT(i) {_last_stop[i] = get_cycle();}
+ #define TIMESTOP(i) {cycle_t cur = get_cycle(); _total_cycles[i] += cur - _last_stop[i]; _last_stop[i] = cur;}
+ #define TIMEPRINT(n) { for (int i = 0; i <= n; i++) printf("%d cycles: %" PRIu64 "\n", i, _total_cycles[i]); }
+#endif
+
+
+#ifdef MAX_MEASURES
+ static cycle_t _last_stop[MAX_MEASURES] = {0};
+ static cycle_t _total_cycles[MAX_MEASURES] = {0};
+#endif
diff --git a/test/monniaux/float_mat/Makefile b/test/monniaux/float_mat/Makefile
new file mode 100644
index 00000000..69621159
--- /dev/null
+++ b/test/monniaux/float_mat/Makefile
@@ -0,0 +1,4 @@
+TARGET=float_mat
+MEASURES="c1 c2 c3 c4 c5 c6 c7 c8"
+
+include ../rules.mk
diff --git a/test/monniaux/float_mat/float_mat_run.c b/test/monniaux/float_mat/float_mat_run.c
index 329648c2..2f590f98 100644
--- a/test/monniaux/float_mat/float_mat_run.c
+++ b/test/monniaux/float_mat/float_mat_run.c
@@ -93,14 +93,14 @@ int main() {
"c1==c6: %s\n"
"c1==c7: %s\n"
"c1==c8: %s\n"
- "c1_time : %" PRIu64 "\n"
- "c2_time : %" PRIu64 "\n"
- "c3_time : %" PRIu64 "\n"
- "c4_time : %" PRIu64 "\n"
- "c5_time : %" PRIu64 "\n"
- "c6_time : %" PRIu64 "\n"
- "c7_time : %" PRIu64 "\n"
- "c8_time : %" PRIu64 "\n",
+ "c1 cycles: %" PRIu64 "\n"
+ "c2 cycles: %" PRIu64 "\n"
+ "c3 cycles: %" PRIu64 "\n"
+ "c4 cycles: %" PRIu64 "\n"
+ "c5 cycles: %" PRIu64 "\n"
+ "c6 cycles: %" PRIu64 "\n"
+ "c7 cycles: %" PRIu64 "\n"
+ "c8 cycles: %" PRIu64 "\n",
REAL_mat_equal(m, n, c1, p, c2, p)?"true":"false",
REAL_mat_equal(m, n, c1, p, c3, p)?"true":"false",
diff --git a/test/monniaux/float_mat/make.proto b/test/monniaux/float_mat/make.proto
deleted file mode 100644
index ebdd8930..00000000
--- a/test/monniaux/float_mat/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-objdeps: [{name: float_mat_run, compiler: gcc}]
-target: float_mat
-measures: [[c2_time, c2]]
diff --git a/test/monniaux/genann/Makefile b/test/monniaux/genann/Makefile
new file mode 100644
index 00000000..2e76ec63
--- /dev/null
+++ b/test/monniaux/genann/Makefile
@@ -0,0 +1,4 @@
+ALL_CFILES= example4shorter.c genann.c
+TARGET=genann4
+
+include ../rules.mk
diff --git a/test/monniaux/genann/example/iris.data b/test/monniaux/genann/example/iris.data
new file mode 100644
index 00000000..a3490e0e
--- /dev/null
+++ b/test/monniaux/genann/example/iris.data
@@ -0,0 +1,150 @@
+5.1,3.5,1.4,0.2,Iris-setosa
+4.9,3.0,1.4,0.2,Iris-setosa
+4.7,3.2,1.3,0.2,Iris-setosa
+4.6,3.1,1.5,0.2,Iris-setosa
+5.0,3.6,1.4,0.2,Iris-setosa
+5.4,3.9,1.7,0.4,Iris-setosa
+4.6,3.4,1.4,0.3,Iris-setosa
+5.0,3.4,1.5,0.2,Iris-setosa
+4.4,2.9,1.4,0.2,Iris-setosa
+4.9,3.1,1.5,0.1,Iris-setosa
+5.4,3.7,1.5,0.2,Iris-setosa
+4.8,3.4,1.6,0.2,Iris-setosa
+4.8,3.0,1.4,0.1,Iris-setosa
+4.3,3.0,1.1,0.1,Iris-setosa
+5.8,4.0,1.2,0.2,Iris-setosa
+5.7,4.4,1.5,0.4,Iris-setosa
+5.4,3.9,1.3,0.4,Iris-setosa
+5.1,3.5,1.4,0.3,Iris-setosa
+5.7,3.8,1.7,0.3,Iris-setosa
+5.1,3.8,1.5,0.3,Iris-setosa
+5.4,3.4,1.7,0.2,Iris-setosa
+5.1,3.7,1.5,0.4,Iris-setosa
+4.6,3.6,1.0,0.2,Iris-setosa
+5.1,3.3,1.7,0.5,Iris-setosa
+4.8,3.4,1.9,0.2,Iris-setosa
+5.0,3.0,1.6,0.2,Iris-setosa
+5.0,3.4,1.6,0.4,Iris-setosa
+5.2,3.5,1.5,0.2,Iris-setosa
+5.2,3.4,1.4,0.2,Iris-setosa
+4.7,3.2,1.6,0.2,Iris-setosa
+4.8,3.1,1.6,0.2,Iris-setosa
+5.4,3.4,1.5,0.4,Iris-setosa
+5.2,4.1,1.5,0.1,Iris-setosa
+5.5,4.2,1.4,0.2,Iris-setosa
+4.9,3.1,1.5,0.1,Iris-setosa
+5.0,3.2,1.2,0.2,Iris-setosa
+5.5,3.5,1.3,0.2,Iris-setosa
+4.9,3.1,1.5,0.1,Iris-setosa
+4.4,3.0,1.3,0.2,Iris-setosa
+5.1,3.4,1.5,0.2,Iris-setosa
+5.0,3.5,1.3,0.3,Iris-setosa
+4.5,2.3,1.3,0.3,Iris-setosa
+4.4,3.2,1.3,0.2,Iris-setosa
+5.0,3.5,1.6,0.6,Iris-setosa
+5.1,3.8,1.9,0.4,Iris-setosa
+4.8,3.0,1.4,0.3,Iris-setosa
+5.1,3.8,1.6,0.2,Iris-setosa
+4.6,3.2,1.4,0.2,Iris-setosa
+5.3,3.7,1.5,0.2,Iris-setosa
+5.0,3.3,1.4,0.2,Iris-setosa
+7.0,3.2,4.7,1.4,Iris-versicolor
+6.4,3.2,4.5,1.5,Iris-versicolor
+6.9,3.1,4.9,1.5,Iris-versicolor
+5.5,2.3,4.0,1.3,Iris-versicolor
+6.5,2.8,4.6,1.5,Iris-versicolor
+5.7,2.8,4.5,1.3,Iris-versicolor
+6.3,3.3,4.7,1.6,Iris-versicolor
+4.9,2.4,3.3,1.0,Iris-versicolor
+6.6,2.9,4.6,1.3,Iris-versicolor
+5.2,2.7,3.9,1.4,Iris-versicolor
+5.0,2.0,3.5,1.0,Iris-versicolor
+5.9,3.0,4.2,1.5,Iris-versicolor
+6.0,2.2,4.0,1.0,Iris-versicolor
+6.1,2.9,4.7,1.4,Iris-versicolor
+5.6,2.9,3.6,1.3,Iris-versicolor
+6.7,3.1,4.4,1.4,Iris-versicolor
+5.6,3.0,4.5,1.5,Iris-versicolor
+5.8,2.7,4.1,1.0,Iris-versicolor
+6.2,2.2,4.5,1.5,Iris-versicolor
+5.6,2.5,3.9,1.1,Iris-versicolor
+5.9,3.2,4.8,1.8,Iris-versicolor
+6.1,2.8,4.0,1.3,Iris-versicolor
+6.3,2.5,4.9,1.5,Iris-versicolor
+6.1,2.8,4.7,1.2,Iris-versicolor
+6.4,2.9,4.3,1.3,Iris-versicolor
+6.6,3.0,4.4,1.4,Iris-versicolor
+6.8,2.8,4.8,1.4,Iris-versicolor
+6.7,3.0,5.0,1.7,Iris-versicolor
+6.0,2.9,4.5,1.5,Iris-versicolor
+5.7,2.6,3.5,1.0,Iris-versicolor
+5.5,2.4,3.8,1.1,Iris-versicolor
+5.5,2.4,3.7,1.0,Iris-versicolor
+5.8,2.7,3.9,1.2,Iris-versicolor
+6.0,2.7,5.1,1.6,Iris-versicolor
+5.4,3.0,4.5,1.5,Iris-versicolor
+6.0,3.4,4.5,1.6,Iris-versicolor
+6.7,3.1,4.7,1.5,Iris-versicolor
+6.3,2.3,4.4,1.3,Iris-versicolor
+5.6,3.0,4.1,1.3,Iris-versicolor
+5.5,2.5,4.0,1.3,Iris-versicolor
+5.5,2.6,4.4,1.2,Iris-versicolor
+6.1,3.0,4.6,1.4,Iris-versicolor
+5.8,2.6,4.0,1.2,Iris-versicolor
+5.0,2.3,3.3,1.0,Iris-versicolor
+5.6,2.7,4.2,1.3,Iris-versicolor
+5.7,3.0,4.2,1.2,Iris-versicolor
+5.7,2.9,4.2,1.3,Iris-versicolor
+6.2,2.9,4.3,1.3,Iris-versicolor
+5.1,2.5,3.0,1.1,Iris-versicolor
+5.7,2.8,4.1,1.3,Iris-versicolor
+6.3,3.3,6.0,2.5,Iris-virginica
+5.8,2.7,5.1,1.9,Iris-virginica
+7.1,3.0,5.9,2.1,Iris-virginica
+6.3,2.9,5.6,1.8,Iris-virginica
+6.5,3.0,5.8,2.2,Iris-virginica
+7.6,3.0,6.6,2.1,Iris-virginica
+4.9,2.5,4.5,1.7,Iris-virginica
+7.3,2.9,6.3,1.8,Iris-virginica
+6.7,2.5,5.8,1.8,Iris-virginica
+7.2,3.6,6.1,2.5,Iris-virginica
+6.5,3.2,5.1,2.0,Iris-virginica
+6.4,2.7,5.3,1.9,Iris-virginica
+6.8,3.0,5.5,2.1,Iris-virginica
+5.7,2.5,5.0,2.0,Iris-virginica
+5.8,2.8,5.1,2.4,Iris-virginica
+6.4,3.2,5.3,2.3,Iris-virginica
+6.5,3.0,5.5,1.8,Iris-virginica
+7.7,3.8,6.7,2.2,Iris-virginica
+7.7,2.6,6.9,2.3,Iris-virginica
+6.0,2.2,5.0,1.5,Iris-virginica
+6.9,3.2,5.7,2.3,Iris-virginica
+5.6,2.8,4.9,2.0,Iris-virginica
+7.7,2.8,6.7,2.0,Iris-virginica
+6.3,2.7,4.9,1.8,Iris-virginica
+6.7,3.3,5.7,2.1,Iris-virginica
+7.2,3.2,6.0,1.8,Iris-virginica
+6.2,2.8,4.8,1.8,Iris-virginica
+6.1,3.0,4.9,1.8,Iris-virginica
+6.4,2.8,5.6,2.1,Iris-virginica
+7.2,3.0,5.8,1.6,Iris-virginica
+7.4,2.8,6.1,1.9,Iris-virginica
+7.9,3.8,6.4,2.0,Iris-virginica
+6.4,2.8,5.6,2.2,Iris-virginica
+6.3,2.8,5.1,1.5,Iris-virginica
+6.1,2.6,5.6,1.4,Iris-virginica
+7.7,3.0,6.1,2.3,Iris-virginica
+6.3,3.4,5.6,2.4,Iris-virginica
+6.4,3.1,5.5,1.8,Iris-virginica
+6.0,3.0,4.8,1.8,Iris-virginica
+6.9,3.1,5.4,2.1,Iris-virginica
+6.7,3.1,5.6,2.4,Iris-virginica
+6.9,3.1,5.1,2.3,Iris-virginica
+5.8,2.7,5.1,1.9,Iris-virginica
+6.8,3.2,5.9,2.3,Iris-virginica
+6.7,3.3,5.7,2.5,Iris-virginica
+6.7,3.0,5.2,2.3,Iris-virginica
+6.3,2.5,5.0,1.9,Iris-virginica
+6.5,3.0,5.2,2.0,Iris-virginica
+6.2,3.4,5.4,2.3,Iris-virginica
+5.9,3.0,5.1,1.8,Iris-virginica
diff --git a/test/monniaux/genann/example4shorter.c b/test/monniaux/genann/example4shorter.c
new file mode 100644
index 00000000..ff4ce402
--- /dev/null
+++ b/test/monniaux/genann/example4shorter.c
@@ -0,0 +1,141 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+#include <string.h>
+#include <math.h>
+#include "genann.h"
+
+#define VERIMAG
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
+/* This example is to illustrate how to use GENANN.
+ * It is NOT an example of good machine learning techniques.
+ */
+
+const char *iris_data = "example/iris.data";
+
+double *input, *class;
+int samples;
+const char *class_names[] = {"Iris-setosa", "Iris-versicolor", "Iris-virginica"};
+
+void load_data() {
+ /* Load the iris data-set. */
+ FILE *in = fopen("example/iris.data", "r");
+ if (!in) {
+ printf("Could not open file: %s\n", iris_data);
+ exit(1);
+ }
+
+ /* Loop through the data to get a count. */
+ char line[1024];
+ while (!feof(in) && fgets(line, 1024, in)) {
+ ++samples;
+ }
+ fseek(in, 0, SEEK_SET);
+
+ printf("Loading %d data points from %s\n", samples, iris_data);
+
+ /* Allocate memory for input and output data. */
+ input = malloc(sizeof(double) * samples * 4);
+ class = malloc(sizeof(double) * samples * 3);
+
+ /* Read the file into our arrays. */
+ int i, j;
+ for (i = 0; i < samples; ++i) {
+ double *p = input + i * 4;
+ double *c = class + i * 3;
+ c[0] = c[1] = c[2] = 0.0;
+
+ if (fgets(line, 1024, in) == NULL) {
+ perror("fgets");
+ exit(1);
+ }
+
+ char *split = strtok(line, ",");
+ for (j = 0; j < 4; ++j) {
+ p[j] = atof(split);
+ split = strtok(0, ",");
+ }
+
+ split[strlen(split)-1] = 0;
+ if (strcmp(split, class_names[0]) == 0) {c[0] = 1.0;}
+ else if (strcmp(split, class_names[1]) == 0) {c[1] = 1.0;}
+ else if (strcmp(split, class_names[2]) == 0) {c[2] = 1.0;}
+ else {
+ printf("Unknown class %s.\n", split);
+ exit(1);
+ }
+
+ /* printf("Data point %d is %f %f %f %f -> %f %f %f\n", i, p[0], p[1], p[2], p[3], c[0], c[1], c[2]); */
+ }
+
+ fclose(in);
+}
+
+
+int main(int argc, char *argv[])
+{
+ printf("GENANN example 4.\n");
+ printf("Train an ANN on the IRIS dataset using backpropagation.\n");
+
+#ifdef VERIMAG
+ srand(42);
+#else
+ srand(time(0));
+#endif
+
+ /* Load the data from file. */
+ load_data();
+
+ /* 4 inputs.
+ * 1 hidden layer(s) of 4 neurons.
+ * 3 outputs (1 per class)
+ */
+ genann *ann = genann_init(4, 1, 4, 3);
+
+ int i, j;
+#ifdef VERIMAG
+ int loops = 500;
+#else
+ int loops = 5000;
+#endif
+
+ /* Train the network with backpropagation. */
+ printf("Training for %d loops over data.\n", loops);
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+ for (i = 0; i < loops; ++i) {
+ for (j = 0; j < samples; ++j) {
+ genann_train(ann, input + j*4, class + j*3, .01);
+ }
+ /* printf("%1.2f ", xor_score(ann)); */
+ }
+
+ int correct = 0;
+ for (j = 0; j < samples; ++j) {
+ const double *guess = genann_run(ann, input + j*4);
+ if (class[j*3+0] == 1.0) {if (guess[0] > guess[1] && guess[0] > guess[2]) ++correct;}
+ else if (class[j*3+1] == 1.0) {if (guess[1] > guess[0] && guess[1] > guess[2]) ++correct;}
+ else if (class[j*3+2] == 1.0) {if (guess[2] > guess[0] && guess[2] > guess[1]) ++correct;}
+ else {printf("Logic error.\n"); exit(1);}
+ }
+#ifdef VERIMAG
+ clock_stop();
+#endif
+
+ printf("%d/%d correct (%0.1f%%).\n", correct, samples, (double)correct / samples * 100.0);
+
+#ifdef VERIMAG
+ print_total_clock();
+#endif
+
+ genann_free(ann);
+ free(input);
+ free(class);
+
+ return 0;
+}
diff --git a/test/monniaux/genann/genann.c b/test/monniaux/genann/genann.c
new file mode 100644
index 00000000..98af736b
--- /dev/null
+++ b/test/monniaux/genann/genann.c
@@ -0,0 +1,415 @@
+/*
+ * GENANN - Minimal C Artificial Neural Network
+ *
+ * Copyright (c) 2015-2018 Lewis Van Winkle
+ *
+ * http://CodePlea.com
+ *
+ * This software is provided 'as-is', without any express or implied
+ * warranty. In no event will the authors be held liable for any damages
+ * arising from the use of this software.
+ *
+ * Permission is granted to anyone to use this software for any purpose,
+ * including commercial applications, and to alter it and redistribute it
+ * freely, subject to the following restrictions:
+ *
+ * 1. The origin of this software must not be misrepresented; you must not
+ * claim that you wrote the original software. If you use this software
+ * in a product, an acknowledgement in the product documentation would be
+ * appreciated but is not required.
+ * 2. Altered source versions must be plainly marked as such, and must not be
+ * misrepresented as being the original software.
+ * 3. This notice may not be removed or altered from any source distribution.
+ *
+ */
+
+#define VERIMAG
+
+#include "genann.h"
+
+#include <assert.h>
+#include <errno.h>
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#ifndef genann_act
+#define genann_act_hidden genann_act_hidden_indirect
+#define genann_act_output genann_act_output_indirect
+#else
+#define genann_act_hidden genann_act
+#define genann_act_output genann_act
+#endif
+
+#define LOOKUP_SIZE 4096
+
+double genann_act_hidden_indirect(const struct genann *ann, double a) {
+ return ann->activation_hidden(ann, a);
+}
+
+double genann_act_output_indirect(const struct genann *ann, double a) {
+ return ann->activation_output(ann, a);
+}
+
+const double sigmoid_dom_min = -15.0;
+const double sigmoid_dom_max = 15.0;
+double interval;
+double lookup[LOOKUP_SIZE];
+
+#ifdef __GNUC__
+#define likely(x) __builtin_expect(!!(x), 1)
+#define unlikely(x) __builtin_expect(!!(x), 0)
+#define unused __attribute__((unused))
+#else
+#define likely(x) x
+#define unlikely(x) x
+#define unused
+#pragma warning(disable : 4996) /* For fscanf */
+#endif
+
+
+double static inline genann_act_sigmoid(const genann *ann unused, double a) {
+ if (a < -45.0) return 0;
+ if (a > 45.0) return 1;
+ return 1.0 / (1 + exp(-a));
+}
+
+void genann_init_sigmoid_lookup(const genann *ann) {
+ const double f = (sigmoid_dom_max - sigmoid_dom_min)
+#ifdef VERIMAG
+ * 0x1.0p-12
+#else
+ / LOOKUP_SIZE
+#endif
+ ;
+ int i;
+
+ interval = LOOKUP_SIZE / (sigmoid_dom_max - sigmoid_dom_min);
+ for (i = 0; i < LOOKUP_SIZE; ++i) {
+ lookup[i] = genann_act_sigmoid(ann, sigmoid_dom_min + f * i);
+ }
+}
+
+double static inline genann_act_sigmoid_cached(const genann *ann unused, double a) {
+#ifndef VERIMAG
+ assert(!isnan(a));
+#endif
+
+ if (a < sigmoid_dom_min) return lookup[0];
+ if (a >= sigmoid_dom_max) return lookup[LOOKUP_SIZE - 1];
+
+ size_t j = (size_t)((a-sigmoid_dom_min)*interval+0.5);
+
+ /* Because floating point... */
+ if (unlikely(j >= LOOKUP_SIZE)) return lookup[LOOKUP_SIZE - 1];
+
+ return lookup[j];
+}
+
+double static inline genann_act_linear(const struct genann *ann unused, double a) {
+ return a;
+}
+
+double static inline genann_act_threshold(const struct genann *ann unused, double a) {
+ return a > 0;
+}
+
+genann *genann_init(int inputs, int hidden_layers, int hidden, int outputs) {
+ if (hidden_layers < 0) return 0;
+ if (inputs < 1) return 0;
+ if (outputs < 1) return 0;
+ if (hidden_layers > 0 && hidden < 1) return 0;
+
+
+ const int hidden_weights = hidden_layers ? (inputs+1) * hidden + (hidden_layers-1) * (hidden+1) * hidden : 0;
+ const int output_weights = (hidden_layers ? (hidden+1) : (inputs+1)) * outputs;
+ const int total_weights = (hidden_weights + output_weights);
+
+ const int total_neurons = (inputs + hidden * hidden_layers + outputs);
+
+ /* Allocate extra size for weights, outputs, and deltas. */
+ const int size = sizeof(genann) + sizeof(double) * (total_weights + total_neurons + (total_neurons - inputs));
+ genann *ret = malloc(size);
+ if (!ret) return 0;
+
+ ret->inputs = inputs;
+ ret->hidden_layers = hidden_layers;
+ ret->hidden = hidden;
+ ret->outputs = outputs;
+
+ ret->total_weights = total_weights;
+ ret->total_neurons = total_neurons;
+
+ /* Set pointers. */
+ ret->weight = (double*)((char*)ret + sizeof(genann));
+ ret->output = ret->weight + ret->total_weights;
+ ret->delta = ret->output + ret->total_neurons;
+
+ genann_randomize(ret);
+
+ ret->activation_hidden = genann_act_sigmoid_cached;
+ ret->activation_output = genann_act_sigmoid_cached;
+
+ genann_init_sigmoid_lookup(ret);
+
+ return ret;
+}
+
+
+genann *genann_read(FILE *in) {
+ int inputs, hidden_layers, hidden, outputs;
+ int rc;
+
+ errno = 0;
+ rc = fscanf(in, "%d %d %d %d", &inputs, &hidden_layers, &hidden, &outputs);
+ if (rc < 4 || errno != 0) {
+ perror("fscanf");
+ return NULL;
+ }
+
+ genann *ann = genann_init(inputs, hidden_layers, hidden, outputs);
+
+ int i;
+ for (i = 0; i < ann->total_weights; ++i) {
+ errno = 0;
+ rc = fscanf(in, " %le", ann->weight + i);
+ if (rc < 1 || errno != 0) {
+ perror("fscanf");
+ genann_free(ann);
+
+ return NULL;
+ }
+ }
+
+ return ann;
+}
+
+
+genann *genann_copy(genann const *ann) {
+ const int size = sizeof(genann) + sizeof(double) * (ann->total_weights + ann->total_neurons + (ann->total_neurons - ann->inputs));
+ genann *ret = malloc(size);
+ if (!ret) return 0;
+
+ memcpy(ret, ann, size);
+
+ /* Set pointers. */
+ ret->weight = (double*)((char*)ret + sizeof(genann));
+ ret->output = ret->weight + ret->total_weights;
+ ret->delta = ret->output + ret->total_neurons;
+
+ return ret;
+}
+
+
+void genann_randomize(genann *ann) {
+ int i;
+ for (i = 0; i < ann->total_weights; ++i) {
+ double r = GENANN_RANDOM();
+ /* Sets weights from -0.5 to 0.5. */
+ ann->weight[i] = r - 0.5;
+ }
+}
+
+
+void genann_free(genann *ann) {
+ /* The weight, output, and delta pointers go to the same buffer. */
+ free(ann);
+}
+
+
+double const *genann_run(genann const *ann, double const *inputs) {
+ double const *w = ann->weight;
+ double *o = ann->output + ann->inputs;
+ double const *i = ann->output;
+
+ /* Copy the inputs to the scratch area, where we also store each neuron's
+ * output, for consistency. This way the first layer isn't a special case. */
+ memcpy(ann->output, inputs, sizeof(double) * ann->inputs);
+
+ int h, j, k;
+
+ if (!ann->hidden_layers) {
+ double *ret = o;
+ for (j = 0; j < ann->outputs; ++j) {
+ double sum = *w++ * -1.0;
+ for (k = 0; k < ann->inputs; ++k) {
+ sum += *w++ * i[k];
+ }
+ *o++ = genann_act_output(ann, sum);
+ }
+
+ return ret;
+ }
+
+ /* Figure input layer */
+ for (j = 0; j < ann->hidden; ++j) {
+ double sum = *w++ * -1.0;
+ for (k = 0; k < ann->inputs; ++k) {
+ sum += *w++ * i[k];
+ }
+ *o++ = genann_act_hidden(ann, sum);
+ }
+
+ i += ann->inputs;
+
+ /* Figure hidden layers, if any. */
+ for (h = 1; h < ann->hidden_layers; ++h) {
+ for (j = 0; j < ann->hidden; ++j) {
+ double sum = *w++ * -1.0;
+ for (k = 0; k < ann->hidden; ++k) {
+ sum += *w++ * i[k];
+ }
+ *o++ = genann_act_hidden(ann, sum);
+ }
+
+ i += ann->hidden;
+ }
+
+ double const *ret = o;
+
+ /* Figure output layer. */
+ for (j = 0; j < ann->outputs; ++j) {
+ double sum = *w++ * -1.0;
+ for (k = 0; k < ann->hidden; ++k) {
+ sum += *w++ * i[k];
+ }
+ *o++ = genann_act_output(ann, sum);
+ }
+
+ /* Sanity check that we used all weights and wrote all outputs. */
+ assert(w - ann->weight == ann->total_weights);
+ assert(o - ann->output == ann->total_neurons);
+
+ return ret;
+}
+
+
+void genann_train(genann const *ann, double const *inputs, double const *desired_outputs, double learning_rate) {
+ /* To begin with, we must run the network forward. */
+ genann_run(ann, inputs);
+
+ int h, j, k;
+
+ /* First set the output layer deltas. */
+ {
+ double const *o = ann->output + ann->inputs + ann->hidden * ann->hidden_layers; /* First output. */
+ double *d = ann->delta + ann->hidden * ann->hidden_layers; /* First delta. */
+ double const *t = desired_outputs; /* First desired output. */
+
+
+ /* Set output layer deltas. */
+ if (genann_act_output == genann_act_linear ||
+ ann->activation_output == genann_act_linear) {
+ for (j = 0; j < ann->outputs; ++j) {
+ *d++ = *t++ - *o++;
+ }
+ } else {
+ for (j = 0; j < ann->outputs; ++j) {
+ *d++ = (*t - *o) * *o * (1.0 - *o);
+ ++o; ++t;
+ }
+ }
+ }
+
+
+ /* Set hidden layer deltas, start on last layer and work backwards. */
+ /* Note that loop is skipped in the case of hidden_layers == 0. */
+ for (h = ann->hidden_layers - 1; h >= 0; --h) {
+
+ /* Find first output and delta in this layer. */
+ double const *o = ann->output + ann->inputs + (h * ann->hidden);
+ double *d = ann->delta + (h * ann->hidden);
+
+ /* Find first delta in following layer (which may be hidden or output). */
+ double const * const dd = ann->delta + ((h+1) * ann->hidden);
+
+ /* Find first weight in following layer (which may be hidden or output). */
+ double const * const ww = ann->weight + ((ann->inputs+1) * ann->hidden) + ((ann->hidden+1) * ann->hidden * (h));
+
+ for (j = 0; j < ann->hidden; ++j) {
+
+ double delta = 0;
+
+ for (k = 0; k < (h == ann->hidden_layers-1 ? ann->outputs : ann->hidden); ++k) {
+ const double forward_delta = dd[k];
+ const int windex = k * (ann->hidden + 1) + (j + 1);
+ const double forward_weight = ww[windex];
+ delta += forward_delta * forward_weight;
+ }
+
+ *d = *o * (1.0-*o) * delta;
+ ++d; ++o;
+ }
+ }
+
+
+ /* Train the outputs. */
+ {
+ /* Find first output delta. */
+ double const *d = ann->delta + ann->hidden * ann->hidden_layers; /* First output delta. */
+
+ /* Find first weight to first output delta. */
+ double *w = ann->weight + (ann->hidden_layers
+ ? ((ann->inputs+1) * ann->hidden + (ann->hidden+1) * ann->hidden * (ann->hidden_layers-1))
+ : (0));
+
+ /* Find first output in previous layer. */
+ double const * const i = ann->output + (ann->hidden_layers
+ ? (ann->inputs + (ann->hidden) * (ann->hidden_layers-1))
+ : 0);
+
+ /* Set output layer weights. */
+ for (j = 0; j < ann->outputs; ++j) {
+ *w++ += *d * learning_rate * -1.0;
+ for (k = 1; k < (ann->hidden_layers ? ann->hidden : ann->inputs) + 1; ++k) {
+ *w++ += *d * learning_rate * i[k-1];
+ }
+
+ ++d;
+ }
+
+ assert(w - ann->weight == ann->total_weights);
+ }
+
+
+ /* Train the hidden layers. */
+ for (h = ann->hidden_layers - 1; h >= 0; --h) {
+
+ /* Find first delta in this layer. */
+ double const *d = ann->delta + (h * ann->hidden);
+
+ /* Find first input to this layer. */
+ double const *i = ann->output + (h
+ ? (ann->inputs + ann->hidden * (h-1))
+ : 0);
+
+ /* Find first weight to this layer. */
+ double *w = ann->weight + (h
+ ? ((ann->inputs+1) * ann->hidden + (ann->hidden+1) * (ann->hidden) * (h-1))
+ : 0);
+
+
+ for (j = 0; j < ann->hidden; ++j) {
+ *w++ += *d * learning_rate * -1.0;
+ for (k = 1; k < (h == 0 ? ann->inputs : ann->hidden) + 1; ++k) {
+ *w++ += *d * learning_rate * i[k-1];
+ }
+ ++d;
+ }
+
+ }
+
+}
+
+
+void genann_write(genann const *ann, FILE *out) {
+ fprintf(out, "%d %d %d %d", ann->inputs, ann->hidden_layers, ann->hidden, ann->outputs);
+
+ int i;
+ for (i = 0; i < ann->total_weights; ++i) {
+ fprintf(out, " %.20e", ann->weight[i]);
+ }
+}
+
+
diff --git a/test/monniaux/genann/genann.h b/test/monniaux/genann/genann.h
new file mode 100644
index 00000000..7eeb1cdc
--- /dev/null
+++ b/test/monniaux/genann/genann.h
@@ -0,0 +1,109 @@
+/*
+ * GENANN - Minimal C Artificial Neural Network
+ *
+ * Copyright (c) 2015-2018 Lewis Van Winkle
+ *
+ * http://CodePlea.com
+ *
+ * This software is provided 'as-is', without any express or implied
+ * warranty. In no event will the authors be held liable for any damages
+ * arising from the use of this software.
+ *
+ * Permission is granted to anyone to use this software for any purpose,
+ * including commercial applications, and to alter it and redistribute it
+ * freely, subject to the following restrictions:
+ *
+ * 1. The origin of this software must not be misrepresented; you must not
+ * claim that you wrote the original software. If you use this software
+ * in a product, an acknowledgement in the product documentation would be
+ * appreciated but is not required.
+ * 2. Altered source versions must be plainly marked as such, and must not be
+ * misrepresented as being the original software.
+ * 3. This notice may not be removed or altered from any source distribution.
+ *
+ */
+
+
+#ifndef GENANN_H
+#define GENANN_H
+
+#include <stdio.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef GENANN_RANDOM
+/* We use the following for uniform random numbers between 0 and 1.
+ * If you have a better function, redefine this macro. */
+#define GENANN_RANDOM() (((double)rand())/RAND_MAX)
+#endif
+
+struct genann;
+
+typedef double (*genann_actfun)(const struct genann *ann, double a);
+
+typedef struct genann {
+ /* How many inputs, outputs, and hidden neurons. */
+ int inputs, hidden_layers, hidden, outputs;
+
+ /* Which activation function to use for hidden neurons. Default: gennann_act_sigmoid_cached*/
+ genann_actfun activation_hidden;
+
+ /* Which activation function to use for output. Default: gennann_act_sigmoid_cached*/
+ genann_actfun activation_output;
+
+ /* Total number of weights, and size of weights buffer. */
+ int total_weights;
+
+ /* Total number of neurons + inputs and size of output buffer. */
+ int total_neurons;
+
+ /* All weights (total_weights long). */
+ double *weight;
+
+ /* Stores input array and output of each neuron (total_neurons long). */
+ double *output;
+
+ /* Stores delta of each hidden and output neuron (total_neurons - inputs long). */
+ double *delta;
+
+} genann;
+
+/* Creates and returns a new ann. */
+genann *genann_init(int inputs, int hidden_layers, int hidden, int outputs);
+
+/* Creates ANN from file saved with genann_write. */
+genann *genann_read(FILE *in);
+
+/* Sets weights randomly. Called by init. */
+void genann_randomize(genann *ann);
+
+/* Returns a new copy of ann. */
+genann *genann_copy(genann const *ann);
+
+/* Frees the memory used by an ann. */
+void genann_free(genann *ann);
+
+/* Runs the feedforward algorithm to calculate the ann's output. */
+double const *genann_run(genann const *ann, double const *inputs);
+
+/* Does a single backprop update. */
+void genann_train(genann const *ann, double const *inputs, double const *desired_outputs, double learning_rate);
+
+/* Saves the ann. */
+void genann_write(genann const *ann, FILE *out);
+
+void genann_init_sigmoid_lookup(const genann *ann);
+#ifndef VERIMAG
+double genann_act_sigmoid(const genann *ann, double a);
+double genann_act_sigmoid_cached(const genann *ann, double a);
+double genann_act_threshold(const genann *ann, double a);
+double genann_act_linear(const genann *ann, double a);
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /*GENANN_H*/
diff --git a/test/monniaux/generate_makefiles.sh b/test/monniaux/generate_makefiles.sh
deleted file mode 100755
index ecbbdf4d..00000000
--- a/test/monniaux/generate_makefiles.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/usr/bin/env bash
-
-source benches.sh
-
-for bench in $benches; do
- ./genmake.py $bench/make.proto > $bench/Makefile
-done
-
diff --git a/test/monniaux/gengraphs.py b/test/monniaux/gengraphs.py
deleted file mode 100755
index 3ffe6f3d..00000000
--- a/test/monniaux/gengraphs.py
+++ /dev/null
@@ -1,94 +0,0 @@
-#!/usr/bin/python3.6
-
-import numpy as np # type: ignore
-import matplotlib.pyplot as plt # type: ignore
-import pandas as pd # type: ignore
-import sys
-from typing import *
-
-##
-# Reading data
-##
-
-if len(sys.argv) != 2:
- raise Exception("Only 1 argument should be given to this script: the make.proto file")
-csv_file = sys.argv[1]
-
-with open(csv_file, "r") as f:
- df = pd.read_csv(csv_file)
-
-benches = df["benches"]
-
-host_measures_cols = [col for col in df if "host" in col]
-k1c_measures_cols = [col for col in df if "k1c" in col]
-
-colors = ["forestgreen", "darkorange", "cornflowerblue", "darkorchid", "darksalmon", "dodgerblue", "navy", "gray", "springgreen", "crimson"]
-
-##
-# Generating PDF
-##
-
-def extract_compiler(env: str) -> str:
- words = env.split()[:-1]
- return " ".join(words)
-
-def extract_compilers(envs: List[str]) -> List[str]:
- compilers: List[str] = []
- for env in envs:
- compiler = extract_compiler(env)
- if compiler not in compilers:
- compilers.append(compiler)
- return compilers
-
-def subdivide_interv(inf: Any, sup: float, n: int) -> List[float]:
- return [inf + k*(sup-inf)/n for k in range(n)]
-
-
-# df associates the environment string (e.g. "gcc host") to the cycles
-# envs is the list of environments to compare
-# The returned value will be a dictionnary associating the compiler (e.g. "gcc") to his relative comparison on the best result
-def make_relative_heights(data: Any, envs: List[str]) -> Dict[str, List[float]]:
- n_benches: int = len((data.values)) # type: ignore
- cols: Dict[str, List[int]] = {extract_compiler(env):data[env] for env in envs}
-
- ret: Dict[str, List[float]] = {}
- for compiler in cols:
- ret[compiler] = []
-
- for i in range(n_benches):
- max_time: int = max([cols[compiler][i] for compiler in cols])
- for compiler in cols:
- ret[compiler].append(cols[compiler][i] / float(max_time))
-
- return ret
-
-
-def generate_file(f: str, cols: List[str]) -> None:
- ind = np.arange(len(df[cols[0]]))
-
- width = 0.25 # the width of the bars
-
- compilers = extract_compilers(cols)
- start_inds = subdivide_interv(ind, ind+2*width, len(compilers))
- heights: Dict[str, List[float]] = make_relative_heights(df, cols)
-
- fig, ax = plt.subplots()
- rects = []
- for i, compiler in enumerate(compilers):
- rects.append(ax.bar(start_inds[i], heights[compiler], width, color=colors[i], label=compiler))
-
- # Add some text for labels, title and custom x-axis tick labels, etc.
- ax.set_ylabel('Cycles (%)')
- ax.set_yticklabels(['{:,.0%}'.format(x) for x in ax.get_yticks()])
- ax.set_title('TITLE')
- ax.set_xticks(ind)
- ax.set_xticklabels(benches)
- ax.legend()
-
- plt.setp(ax.get_xticklabels(), rotation=30, horizontalalignment='right')
- plt.xticks(size=5)
-
- plt.savefig(f)
-
-generate_file("measures-host.pdf", host_measures_cols)
-generate_file("measures-k1c.pdf", k1c_measures_cols)
diff --git a/test/monniaux/genmake.py b/test/monniaux/genmake.py
deleted file mode 100755
index 62b97836..00000000
--- a/test/monniaux/genmake.py
+++ /dev/null
@@ -1,136 +0,0 @@
-#!/usr/bin/env python3
-
-""" Custom Makefile generator
-
-Generates the Makefiles for the various benches, including extra rules for each different optimization options and/or compilers.
-
-See the source for more info.
-"""
-
-from collections import namedtuple
-from typing import *
-import sys
-import yaml
-
-Optim = namedtuple("Optim", ["short", "full"])
-Env = namedtuple("Env", ["compiler", "optimizations", "target"])
-Compiler = namedtuple("Compiler", ["short", "full"])
-
-##
-# Variables you can change.
-##
-
-# Defining the compilers and optimizations
-
-gcc_x86 = Env(compiler = Compiler("gcc", "$(CC)"), optimizations = [Optim("", "$(CFLAGS)")], target = "host")
-gcc_k1c = Env(compiler = Compiler("gcc", "$(K1C_CC)"), optimizations = [Optim("", "$(K1C_CFLAGS)"), Optim("o1", "$(K1C_CFLAGS_O1)")], target = "k1c")
-ccomp_x86 = Env(compiler = Compiler("ccomp", "$(CCOMP)"), optimizations = [Optim("", "$(CCOMPFLAGS)")], target = "host")
-ccomp_k1c = Env(compiler = Compiler("ccomp", "$(K1C_CCOMP)"), optimizations = [Optim("", "$(K1C_CCOMPFLAGS)")], target = "k1c")
-
-environments = [gcc_x86, ccomp_x86, gcc_k1c, ccomp_k1c]
-
-##
-# Argument parsing
-##
-if len(sys.argv) != 2:
- raise Exception("Only 1 argument should be given to this script: the make.proto file")
-yaml_file = sys.argv[1]
-
-with open(yaml_file, "r") as f:
- settings = yaml.load(f.read(), Loader=yaml.SafeLoader)
-
-basename = settings["target"]
-objdeps = settings["objdeps"] if "objdeps" in settings else []
-intro = settings["intro"] if "intro" in settings else ""
-sources = settings["sources"] if "sources" in settings else None
-measures = settings["measures"] if "measures" in settings else []
-name = settings["name"] if "name" in settings else None
-
-if sources:
- intro += "\nsrc=" + sources
-
-for objdep in objdeps:
- if objdep["compiler"] not in ("gcc", "ccomp", "both"):
- raise Exception('Invalid compiler specified in make.proto:objdeps, should be either "gcc" or "ccomp" or "both"')
-
-##
-# Printing the rules
-##
-
-def make_product(env: Env, optim: Optim) -> str:
- return basename + "." + env.compiler.short + (("." + optim.short) if optim.short != "" else "") + "." + env.target
-
-def make_obj(name: str, env: Env, compiler_short: str) -> str:
- return name + "." + compiler_short + "." + env.target + ".o"
-
-def make_clock(env: Env, optim: Optim) -> str:
- return "clock.gcc." + env.target
-
-def make_sources(env: Env, optim: Optim) -> str:
- if sources:
- return "$(src:.c=." + env.compiler.short + (("." + optim.short) if optim.short != "" else "") + "." + env.target + ".o)"
- else:
- return "{product}.o".format(product = make_product(env, optim))
-
-def print_rule(env: Env, optim: Optim) -> None:
- print("{product}: {sources} ../{clock}.o "
- .format(product = make_product(env, optim),
- sources = make_sources(env, optim), clock = make_clock(env, optim))
- + " ".join([make_obj(objdep["name"], env, (objdep["compiler"] if objdep["compiler"] != "both" else env.compiler.short)) for objdep in objdeps]))
- print(" {compiler} {flags} $+ -o $@"
- .format(compiler = env.compiler.full, flags = optim.full))
-
-def make_env_list(envs: List[Env]) -> str:
- return ",".join([(env.compiler.short + ((" " + optim.short) if optim.short != "" else "") + " " + env.target)
- for env in environments
- for optim in env.optimizations])
-
-def print_measure_rule(environments: List[Env], measures: List[Union[List[str], str]]) -> None:
- print("measures.csv: $(PRODUCTS_OUT)")
- print(' echo "benches, {}" > $@'.format(make_env_list(environments)))
- for measure in measures:
- display_measure_name = (len(measures) > 1)
- if isinstance(measure, list):
- measure_name, measure_short = measure
- display_measure_name = True
- else:
- measure_name = measure_short = measure
- print(' echo "{name} {measure}"'.format(name=basename if not name else name, measure=measure_short if display_measure_name else ""), end="")
- for env in environments:
- for optim in env.optimizations:
- print(", $$(grep '{measure}' {outfile} | cut -d':' -f2)".format(
- measure=measure_name, outfile=make_product(env, optim) + ".out"), end="")
- print('>> $@')
-
-products = []
-for env in environments:
- for optim in env.optimizations:
- products.append(make_product(env, optim))
-
-print("""
-include ../rules.mk
-
-{intro}
-
-PRODUCTS?={prod}
-PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS))
-
-all: $(PRODUCTS)
-
-.PHONY:
-run: measures.csv
-
-""".format(intro=intro, prod=" ".join(products)))
-
-for env in environments:
- for optim in env.optimizations:
- print_rule(env, optim)
-
-print_measure_rule(environments, measures)
-
-
-print("""
-.PHONY:
-clean:
- rm -f *.o *.s *.k1c *.csv
-""")
diff --git a/test/monniaux/glibc_qsort/Makefile b/test/monniaux/glibc_qsort/Makefile
new file mode 100644
index 00000000..ca029339
--- /dev/null
+++ b/test/monniaux/glibc_qsort/Makefile
@@ -0,0 +1,3 @@
+TARGET=glibc_qsort
+
+include ../rules.mk
diff --git a/test/monniaux/glibc_qsort/glibc_qsort_run.c b/test/monniaux/glibc_qsort/glibc_qsort_run.c
index 7fcb8130..fee5a2ff 100644
--- a/test/monniaux/glibc_qsort/glibc_qsort_run.c
+++ b/test/monniaux/glibc_qsort/glibc_qsort_run.c
@@ -41,7 +41,7 @@ int main (void) {
quicksort(vec, len, sizeof(data), data_compare, NULL);
quicksort_time = get_cycle() - quicksort_time;
printf("sorted=%s\n"
- "quicksort_time:%" PRIu64 "\n",
+ "time cycles:%" PRIu64 "\n",
data_vec_is_sorted(vec, len)?"true":"false",
quicksort_time);
free(vec);
diff --git a/test/monniaux/glibc_qsort/make.proto b/test/monniaux/glibc_qsort/make.proto
deleted file mode 100644
index 763e77f5..00000000
--- a/test/monniaux/glibc_qsort/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-objdeps: [{name: glibc_qsort_run, compiler: gcc}]
-target: glibc_qsort
-measures: [quicksort_time]
diff --git a/test/monniaux/glpk-4.65/Makefile b/test/monniaux/glpk-4.65/Makefile
new file mode 100644
index 00000000..eaa3f4b0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/Makefile
@@ -0,0 +1,6 @@
+ALL_CFLAGS += -I src/amd -I src/colamd -I src/mpl -I src/simplex -I src/api -I src/intopt -I src/minisat -I src/npp -I src/zlib -I src/bflib -I src/env -I src/misc -I src/draft -I src
+ALL_CFILES=examples/glpsol.c $(wildcard src/*/*.c)
+TARGET=glpk
+EXECUTE_ARGS=--math examples/prod.mod
+
+include ../rules.mk
diff --git a/test/monniaux/glpk-4.65/config.h b/test/monniaux/glpk-4.65/config.h
new file mode 100644
index 00000000..35a44f00
--- /dev/null
+++ b/test/monniaux/glpk-4.65/config.h
@@ -0,0 +1,31 @@
+/* config.h. Generated from config.h.in by configure. */
+/* config.h.in (GLPK configuration template file) */
+
+#define HAVE_SYS_TIME_H 1
+/* defined if the <sys/time.h> header can be used */
+
+#define HAVE_GETTIMEOFDAY 1
+/* defined if the gettimeofday function can be used */
+
+/* #undef HAVE_GMP */
+/* defined if the GNU MP bignum library is available */
+/* requires <gmp.h> and -lgmp */
+
+/* #undef HAVE_LTDL */
+/* defined if the GNU Libtool shared library support is enabled */
+/* requires <ltdl.h> and -lltdl */
+
+/* #undef HAVE_DLFCN */
+/* defined if the POSIX shared library support is enabled */
+/* requires <dlfcn.h> */
+
+/* #undef ODBC_DLNAME */
+/* ODBC shared library name if this feature is enabled */
+
+/* #undef MYSQL_DLNAME */
+/* MySQL shared library name if this feature is enabled */
+
+/* #undef TLS */
+/* thread local storage-class specifier for re-entrancy (if any) */
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/examples/glpsol.c b/test/monniaux/glpk-4.65/examples/glpsol.c
new file mode 100644
index 00000000..17df3380
--- /dev/null
+++ b/test/monniaux/glpk-4.65/examples/glpsol.c
@@ -0,0 +1,1598 @@
+/* glpsol.c (stand-alone GLPK LP/MIP solver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#define VERIMAG
+#ifdef VERIMAG
+#include "../../clock.h"
+#endif
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include <ctype.h>
+#include <float.h>
+#include <limits.h>
+#include <math.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <glpk.h>
+
+#define xassert glp_assert
+#define xerror glp_error
+#define xprintf glp_printf
+
+struct csa
+{ /* common storage area */
+ glp_prob *prob;
+ /* LP/MIP problem object */
+ glp_bfcp bfcp;
+ /* basis factorization control parameters */
+ glp_smcp smcp;
+ /* simplex method control parameters */
+ glp_iptcp iptcp;
+ /* interior-point method control parameters */
+ glp_iocp iocp;
+ /* integer optimizer control parameters */
+ glp_tran *tran;
+ /* model translator workspace */
+ glp_graph *graph;
+ /* network problem object */
+ int format;
+ /* problem file format: */
+#define FMT_MPS_DECK 1 /* fixed MPS */
+#define FMT_MPS_FILE 2 /* free MPS */
+#define FMT_LP 3 /* CPLEX LP */
+#define FMT_GLP 4 /* GLPK LP/MIP */
+#define FMT_MATHPROG 5 /* MathProg */
+#define FMT_MIN_COST 6 /* DIMACS min-cost flow */
+#define FMT_MAX_FLOW 7 /* DIMACS maximum flow */
+#if 1 /* 06/VIII-2011 */
+#define FMT_CNF 8 /* DIMACS CNF-SAT */
+#endif
+ const char *in_file;
+ /* name of input problem file */
+#define DATA_MAX 10
+ /* maximal number of input data files */
+ int ndf;
+ /* number of input data files specified */
+ const char *in_data[1+DATA_MAX];
+ /* name(s) of input data file(s) */
+ const char *out_dpy;
+ /* name of output file to send display output; NULL means the
+ display output is sent to the terminal */
+ int seed;
+ /* seed value to be passed to the MathProg translator; initially
+ set to 1; 0x80000000 means the value is omitted */
+ int solution;
+ /* solution type flag: */
+#define SOL_BASIC 1 /* basic */
+#define SOL_INTERIOR 2 /* interior-point */
+#define SOL_INTEGER 3 /* mixed integer */
+ const char *in_res;
+ /* name of input solution file in raw format */
+ int dir;
+ /* optimization direction flag:
+ 0 - not specified
+ GLP_MIN - minimization
+ GLP_MAX - maximization */
+ int scale;
+ /* automatic problem scaling flag */
+ const char *out_sol;
+ /* name of output solution file in printable format */
+ const char *out_res;
+ /* name of output solution file in raw format */
+ const char *out_ranges;
+ /* name of output file to write sensitivity analysis report */
+ int check;
+ /* input data checking flag; no solution is performed */
+ const char *new_name;
+ /* new name to be assigned to the problem */
+#if 1 /* 18/I-2018 */
+ int hide;
+ /* clear all symbolic names in the problem object */
+#endif
+ const char *out_mps;
+ /* name of output problem file in fixed MPS format */
+ const char *out_freemps;
+ /* name of output problem file in free MPS format */
+ const char *out_cpxlp;
+ /* name of output problem file in CPLEX LP format */
+ const char *out_glp;
+ /* name of output problem file in GLPK format */
+#if 0
+ const char *out_pb;
+ /* name of output problem file in OPB format */
+ const char *out_npb;
+ /* name of output problem file in normalized OPB format */
+#endif
+#if 1 /* 06/VIII-2011 */
+ const char *out_cnf;
+ /* name of output problem file in DIMACS CNF-SAT format */
+#endif
+ const char *log_file;
+ /* name of output file to hardcopy terminal output */
+ int crash;
+ /* initial basis option: */
+#define USE_STD_BASIS 1 /* use standard basis */
+#define USE_ADV_BASIS 2 /* use advanced basis */
+#define USE_CPX_BASIS 3 /* use Bixby's basis */
+#define USE_INI_BASIS 4 /* use initial basis from ini_file */
+ const char *ini_file;
+ /* name of input file containing initial basis */
+ int exact;
+ /* flag to use glp_exact rather than glp_simplex */
+ int xcheck;
+ /* flag to check final basis with glp_exact */
+ int nomip;
+ /* flag to consider MIP as pure LP */
+#if 1 /* 15/VIII-2011 */
+ int minisat;
+ /* option to solve feasibility problem with MiniSat solver */
+ int use_bnd;
+ /* option to bound objective function */
+ int obj_bnd;
+ /* upper (minization) or lower (maximization) objective bound */
+#endif
+#if 1 /* 11/VII-2013 */
+ const char *use_sol;
+ /* name of input mip solution file in GLPK format */
+#endif
+};
+
+static int str2int(const char *s, int *x)
+{ /* convert string to integer */
+ long t;
+ char *endptr;
+ t = strtol(s, &endptr, 10);
+ if (*endptr != '\0')
+ return 2;
+ if (!(INT_MIN <= t && t <= INT_MAX))
+ return 1;
+ *x = t;
+#if 0
+ xprintf("str2int: x = %d\n", *x);
+#endif
+ return 0;
+}
+
+static int str2num(const char *s, double *x)
+{ /* convert string to floating point */
+ double t;
+ char *endptr;
+ t = strtod(s, &endptr);
+ if (*endptr != '\0')
+ return 2;
+ if (!(-DBL_MAX <= t && t <= +DBL_MAX))
+ return 1;
+ *x = t;
+#if 0
+ xprintf("str2num: x = %g\n", *x);
+#endif
+ return 0;
+}
+
+static void print_help(const char *my_name)
+{ /* print help information */
+ xprintf("Usage: %s [options...] filename\n", my_name);
+ xprintf("\n");
+ xprintf("General options:\n");
+ xprintf(" --mps read LP/MIP problem in fixed MPS fo"
+ "rmat\n");
+ xprintf(" --freemps read LP/MIP problem in free MPS for"
+ "mat (default)\n");
+ xprintf(" --lp read LP/MIP problem in CPLEX LP for"
+ "mat\n");
+ xprintf(" --glp read LP/MIP problem in GLPK format "
+ "\n");
+ xprintf(" --math read LP/MIP model written in GNU Ma"
+ "thProg modeling\n");
+ xprintf(" language\n");
+ xprintf(" -m filename, --model filename\n");
+ xprintf(" read model section and optional dat"
+ "a section from\n");
+ xprintf(" filename (same as --math)\n");
+ xprintf(" -d filename, --data filename\n");
+ xprintf(" read data section from filename (fo"
+ "r --math only);\n");
+ xprintf(" if model file also has data section"
+ ", it is ignored\n");
+ xprintf(" -y filename, --display filename\n");
+ xprintf(" send display output to filename (fo"
+ "r --math only);\n");
+ xprintf(" by default the output is sent to te"
+ "rminal\n");
+ xprintf(" --seed value initialize pseudo-random number gen"
+ "erator used in\n");
+ xprintf(" MathProg model with specified seed "
+ "(any integer);\n");
+ xprintf(" if seed value is ?, some random see"
+ "d will be used\n");
+ xprintf(" --mincost read min-cost flow problem in DIMAC"
+ "S format\n");
+ xprintf(" --maxflow read maximum flow problem in DIMACS"
+ " format\n");
+#if 1 /* 06/VIII-2011 */
+ xprintf(" --cnf read CNF-SAT problem in DIMACS form"
+ "at\n");
+#endif
+ xprintf(" --simplex use simplex method (default)\n");
+ xprintf(" --interior use interior point method (LP only)"
+ "\n");
+ xprintf(" -r filename, --read filename\n");
+ xprintf(" read solution from filename rather "
+ "to find it with\n");
+ xprintf(" the solver\n");
+ xprintf(" --min minimization\n");
+ xprintf(" --max maximization\n");
+ xprintf(" --scale scale problem (default)\n");
+ xprintf(" --noscale do not scale problem\n");
+ xprintf(" -o filename, --output filename\n");
+ xprintf(" write solution to filename in print"
+ "able format\n");
+ xprintf(" -w filename, --write filename\n");
+ xprintf(" write solution to filename in plain"
+ " text format\n");
+ xprintf(" --ranges filename\n");
+ xprintf(" write sensitivity analysis report t"
+ "o filename in\n");
+ xprintf(" printable format (simplex only)\n");
+ xprintf(" --tmlim nnn limit solution time to nnn seconds "
+ "\n");
+ xprintf(" --memlim nnn limit available memory to nnn megab"
+ "ytes\n");
+ xprintf(" --check do not solve problem, check input d"
+ "ata only\n");
+ xprintf(" --name probname change problem name to probname\n");
+#if 1 /* 18/I-2018 */
+ xprintf(" --hide remove all symbolic names from prob"
+ "lem object\n");
+#endif
+ xprintf(" --wmps filename write problem to filename in fixed "
+ "MPS format\n");
+ xprintf(" --wfreemps filename\n");
+ xprintf(" write problem to filename in free M"
+ "PS format\n");
+ xprintf(" --wlp filename write problem to filename in CPLEX "
+ "LP format\n");
+ xprintf(" --wglp filename write problem to filename in GLPK f"
+ "ormat\n");
+#if 0
+ xprintf(" --wpb filename write problem to filename in OPB fo"
+ "rmat\n");
+ xprintf(" --wnpb filename write problem to filename in normal"
+ "ized OPB format\n");
+#endif
+#if 1 /* 06/VIII-2011 */
+ xprintf(" --wcnf filename write problem to filename in DIMACS"
+ " CNF-SAT format\n");
+#endif
+ xprintf(" --log filename write copy of terminal output to fi"
+ "lename\n");
+ xprintf(" -h, --help display this help information and e"
+ "xit\n");
+ xprintf(" -v, --version display program version and exit\n")
+ ;
+ xprintf("\n");
+ xprintf("LP basis factorization options:\n");
+#if 0 /* 08/III-2014 */
+ xprintf(" --luf LU + Forrest-Tomlin update\n");
+ xprintf(" (faster, less stable; default)\n");
+ xprintf(" --cbg LU + Schur complement + Bartels-Gol"
+ "ub update\n");
+ xprintf(" (slower, more stable)\n");
+ xprintf(" --cgr LU + Schur complement + Givens rota"
+ "tion update\n");
+ xprintf(" (slower, more stable)\n");
+#else
+ xprintf(" --luf plain LU-factorization (default)\n")
+ ;
+ xprintf(" --btf block triangular LU-factorization\n"
+ );
+ xprintf(" --ft Forrest-Tomlin update (requires --l"
+ "uf; default)\n");
+ xprintf(" --cbg Schur complement + Bartels-Golub up"
+ "date\n");
+ xprintf(" --cgr Schur complement + Givens rotation "
+ "update\n");
+#endif
+ xprintf("\n");
+ xprintf("Options specific to simplex solver:\n");
+ xprintf(" --primal use primal simplex (default)\n");
+ xprintf(" --dual use dual simplex\n");
+ xprintf(" --std use standard initial basis of all s"
+ "lacks\n");
+ xprintf(" --adv use advanced initial basis (default"
+ ")\n");
+ xprintf(" --bib use Bixby's initial basis\n");
+ xprintf(" --ini filename use as initial basis previously sav"
+ "ed with -w\n");
+ xprintf(" (disables LP presolver)\n");
+ xprintf(" --steep use steepest edge technique (defaul"
+ "t)\n");
+ xprintf(" --nosteep use standard \"textbook\" pricing\n"
+ );
+ xprintf(" --relax use Harris' two-pass ratio test (de"
+ "fault)\n");
+ xprintf(" --norelax use standard \"textbook\" ratio tes"
+ "t\n");
+#if 0 /* 23/VI-2017 */
+#if 1 /* 28/III-2016 */
+ xprintf(" --flip use flip-flop ratio test (assumes -"
+ "-dual)\n");
+#endif
+#else
+ /* now this option is implemented in both primal and dual */
+ xprintf(" --flip use long-step ratio test\n");
+#endif
+ xprintf(" --presol use presolver (default; assumes --s"
+ "cale and --adv)\n");
+ xprintf(" --nopresol do not use presolver\n");
+ xprintf(" --exact use simplex method based on exact a"
+ "rithmetic\n");
+ xprintf(" --xcheck check final basis using exact arith"
+ "metic\n");
+ xprintf("\n");
+ xprintf("Options specific to interior-point solver:\n");
+ xprintf(" --nord use natural (original) ordering\n");
+ xprintf(" --qmd use quotient minimum degree orderin"
+ "g\n");
+ xprintf(" --amd use approximate minimum degree orde"
+ "ring (default)\n");
+ xprintf(" --symamd use approximate minimum degree orde"
+ "ring\n");
+ xprintf("\n");
+ xprintf("Options specific to MIP solver:\n");
+ xprintf(" --nomip consider all integer variables as c"
+ "ontinuous\n");
+ xprintf(" (allows solving MIP as pure LP)\n");
+ xprintf(" --first branch on first integer variable\n")
+ ;
+ xprintf(" --last branch on last integer variable\n");
+ xprintf(" --mostf branch on most fractional variable "
+ "\n");
+ xprintf(" --drtom branch using heuristic by Driebeck "
+ "and Tomlin\n");
+ xprintf(" (default)\n");
+ xprintf(" --pcost branch using hybrid pseudocost heur"
+ "istic (may be\n");
+ xprintf(" useful for hard instances)\n");
+ xprintf(" --dfs backtrack using depth first search "
+ "\n");
+ xprintf(" --bfs backtrack using breadth first searc"
+ "h\n");
+ xprintf(" --bestp backtrack using the best projection"
+ " heuristic\n");
+ xprintf(" --bestb backtrack using node with best loca"
+ "l bound\n");
+ xprintf(" (default)\n");
+ xprintf(" --intopt use MIP presolver (default)\n");
+ xprintf(" --nointopt do not use MIP presolver\n");
+ xprintf(" --binarize replace general integer variables b"
+ "y binary ones\n");
+ xprintf(" (assumes --intopt)\n");
+ xprintf(" --fpump apply feasibility pump heuristic\n")
+ ;
+#if 1 /* 29/VI-2013 */
+ xprintf(" --proxy [nnn] apply proximity search heuristic (n"
+ "nn is time limit\n");
+ xprintf(" in seconds; default is 60)\n");
+#endif
+ xprintf(" --gomory generate Gomory's mixed integer cut"
+ "s\n");
+ xprintf(" --mir generate MIR (mixed integer roundin"
+ "g) cuts\n");
+ xprintf(" --cover generate mixed cover cuts\n");
+ xprintf(" --clique generate clique cuts\n");
+ xprintf(" --cuts generate all cuts above\n");
+ xprintf(" --mipgap tol set relative mip gap tolerance to t"
+ "ol\n");
+#if 1 /* 15/VIII-2011 */
+ xprintf(" --minisat translate integer feasibility probl"
+ "em to CNF-SAT\n");
+ xprintf(" and solve it with MiniSat solver\n")
+ ;
+ xprintf(" --objbnd bound add inequality obj <= bound (minimi"
+ "zation) or\n");
+ xprintf(" obj >= bound (maximization) to inte"
+ "ger feasibility\n");
+ xprintf(" problem (assumes --minisat)\n");
+#endif
+ xprintf("\n");
+ xprintf("For description of the MPS and CPLEX LP formats see Refe"
+ "rence Manual.\n");
+ xprintf("For description of the modeling language see \"GLPK: Mod"
+ "eling Language\n");
+ xprintf("GNU MathProg\". Both documents are included in the GLPK "
+ "distribution.\n");
+ xprintf("\n");
+ xprintf("See GLPK web page at <http://www.gnu.org/software/glpk/g"
+ "lpk.html>.\n");
+ xprintf("\n");
+ xprintf("Please report bugs to <bug-glpk@gnu.org>.\n");
+ return;
+}
+
+static void print_version(int briefly)
+{ /* print version information */
+ xprintf("GLPSOL: GLPK LP/MIP Solver, v%s\n", glp_version());
+ if (briefly) goto done;
+ xprintf("Copyright (C) 2000-2017 Andrew Makhorin, Department for "
+ "Applied\n");
+ xprintf("Informatics, Moscow Aviation Institute, Moscow, Russia. "
+ "All rights\n");
+ xprintf("reserved. E-mail: <mao@gnu.org>.\n");
+ xprintf("\n");
+ xprintf("This program has ABSOLUTELY NO WARRANTY.\n");
+ xprintf("\n");
+ xprintf("This program is free software; you may re-distribute it "
+ "under the terms\n");
+ xprintf("of the GNU General Public License version 3 or later.\n")
+ ;
+done: return;
+}
+
+static int parse_cmdline(struct csa *csa, int argc, char *argv[])
+{ /* parse command-line parameters */
+ int k;
+#define p(str) (strcmp(argv[k], str) == 0)
+ for (k = 1; k < argc; k++)
+ { if (p("--mps"))
+ csa->format = FMT_MPS_DECK;
+ else if (p("--freemps"))
+ csa->format = FMT_MPS_FILE;
+ else if (p("--lp") || p("--cpxlp"))
+ csa->format = FMT_LP;
+ else if (p("--glp"))
+ csa->format = FMT_GLP;
+ else if (p("--math") || p("-m") || p("--model"))
+ csa->format = FMT_MATHPROG;
+ else if (p("-d") || p("--data"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No input data file specified\n");
+ return 1;
+ }
+ if (csa->ndf == DATA_MAX)
+ { xprintf("Too many input data files\n");
+ return 1;
+ }
+ csa->in_data[++(csa->ndf)] = argv[k];
+ }
+ else if (p("-y") || p("--display"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No display output file specified\n");
+ return 1;
+ }
+ if (csa->out_dpy != NULL)
+ { xprintf("Only one display output file allowed\n");
+ return 1;
+ }
+ csa->out_dpy = argv[k];
+ }
+ else if (p("--seed"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' ||
+ argv[k][0] == '-' && !isdigit((unsigned char)argv[k][1]))
+ { xprintf("No seed value specified\n");
+ return 1;
+ }
+ if (strcmp(argv[k], "?") == 0)
+ csa->seed = 0x80000000;
+ else if (str2int(argv[k], &csa->seed))
+ { xprintf("Invalid seed value '%s'\n", argv[k]);
+ return 1;
+ }
+ }
+ else if (p("--mincost"))
+ csa->format = FMT_MIN_COST;
+ else if (p("--maxflow"))
+ csa->format = FMT_MAX_FLOW;
+#if 1 /* 06/VIII-2011 */
+ else if (p("--cnf"))
+ csa->format = FMT_CNF;
+#endif
+ else if (p("--simplex"))
+ csa->solution = SOL_BASIC;
+ else if (p("--interior"))
+ csa->solution = SOL_INTERIOR;
+#if 1 /* 28/V-2010 */
+ else if (p("--alien"))
+ csa->iocp.alien = GLP_ON;
+#endif
+ else if (p("-r") || p("--read"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No input solution file specified\n");
+ return 1;
+ }
+ if (csa->in_res != NULL)
+ { xprintf("Only one input solution file allowed\n");
+ return 1;
+ }
+ csa->in_res = argv[k];
+ }
+ else if (p("--min"))
+ csa->dir = GLP_MIN;
+ else if (p("--max"))
+ csa->dir = GLP_MAX;
+ else if (p("--scale"))
+ csa->scale = 1;
+ else if (p("--noscale"))
+ csa->scale = 0;
+ else if (p("-o") || p("--output"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No output solution file specified\n");
+ return 1;
+ }
+ if (csa->out_sol != NULL)
+ { xprintf("Only one output solution file allowed\n");
+ return 1;
+ }
+ csa->out_sol = argv[k];
+ }
+ else if (p("-w") || p("--write"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No output solution file specified\n");
+ return 1;
+ }
+ if (csa->out_res != NULL)
+ { xprintf("Only one output solution file allowed\n");
+ return 1;
+ }
+ csa->out_res = argv[k];
+ }
+ else if (p("--ranges") || p("--bounds"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No output file specified to write sensitivity a"
+ "nalysis report\n");
+ return 1;
+ }
+ if (csa->out_ranges != NULL)
+ { xprintf("Only one output file allowed to write sensitivi"
+ "ty analysis report\n");
+ return 1;
+ }
+ csa->out_ranges = argv[k];
+ }
+ else if (p("--tmlim"))
+ { int tm_lim;
+ k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No time limit specified\n");
+ return 1;
+ }
+ if (str2int(argv[k], &tm_lim) || tm_lim < 0)
+ { xprintf("Invalid time limit '%s'\n", argv[k]);
+ return 1;
+ }
+ if (tm_lim <= INT_MAX / 1000)
+ csa->smcp.tm_lim = csa->iocp.tm_lim = 1000 * tm_lim;
+ else
+ csa->smcp.tm_lim = csa->iocp.tm_lim = INT_MAX;
+ }
+ else if (p("--memlim"))
+ { int mem_lim;
+ k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No memory limit specified\n");
+ return 1;
+ }
+ if (str2int(argv[k], &mem_lim) || mem_lim < 1)
+ { xprintf("Invalid memory limit '%s'\n", argv[k]);
+ return 1;
+ }
+ glp_mem_limit(mem_lim);
+ }
+ else if (p("--check"))
+ csa->check = 1;
+ else if (p("--name"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No problem name specified\n");
+ return 1;
+ }
+ if (csa->new_name != NULL)
+ { xprintf("Only one problem name allowed\n");
+ return 1;
+ }
+ csa->new_name = argv[k];
+ }
+#if 1 /* 18/I-2018 */
+ else if (p("--hide"))
+ csa->hide = 1;
+#endif
+ else if (p("--wmps"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No fixed MPS output file specified\n");
+ return 1;
+ }
+ if (csa->out_mps != NULL)
+ { xprintf("Only one fixed MPS output file allowed\n");
+ return 1;
+ }
+ csa->out_mps = argv[k];
+ }
+ else if (p("--wfreemps"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No free MPS output file specified\n");
+ return 1;
+ }
+ if (csa->out_freemps != NULL)
+ { xprintf("Only one free MPS output file allowed\n");
+ return 1;
+ }
+ csa->out_freemps = argv[k];
+ }
+ else if (p("--wlp") || p("--wcpxlp") || p("--wlpt"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No CPLEX LP output file specified\n");
+ return 1;
+ }
+ if (csa->out_cpxlp != NULL)
+ { xprintf("Only one CPLEX LP output file allowed\n");
+ return 1;
+ }
+ csa->out_cpxlp = argv[k];
+ }
+ else if (p("--wglp"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No GLPK LP/MIP output file specified\n");
+ return 1;
+ }
+ if (csa->out_glp != NULL)
+ { xprintf("Only one GLPK LP/MIP output file allowed\n");
+ return 1;
+ }
+ csa->out_glp = argv[k];
+ }
+#if 0
+ else if (p("--wpb"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No problem output file specified\n");
+ return 1;
+ }
+ if (csa->out_pb != NULL)
+ { xprintf("Only one OPB output file allowed\n");
+ return 1;
+ }
+ csa->out_pb = argv[k];
+ }
+ else if (p("--wnpb"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No problem output file specified\n");
+ return 1;
+ }
+ if (csa->out_npb != NULL)
+ { xprintf("Only one normalized OPB output file allowed\n");
+ return 1;
+ }
+ csa->out_npb = argv[k];
+ }
+#endif
+#if 1 /* 06/VIII-2011 */
+ else if (p("--wcnf"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No problem output file specified\n");
+ return 1;
+ }
+ if (csa->out_cnf != NULL)
+ { xprintf("Only one output DIMACS CNF-SAT file allowed\n");
+ return 1;
+ }
+ csa->out_cnf = argv[k];
+ }
+#endif
+ else if (p("--log"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No log file specified\n");
+ return 1;
+ }
+ if (csa->log_file != NULL)
+ { xprintf("Only one log file allowed\n");
+ return 1;
+ }
+ csa->log_file = argv[k];
+ }
+ else if (p("-h") || p("--help"))
+ { print_help(argv[0]);
+ return -1;
+ }
+ else if (p("-v") || p("--version"))
+ { print_version(0);
+ return -1;
+ }
+#if 0 /* 08/III-2014 */
+ else if (p("--luf"))
+ csa->bfcp.type = GLP_BF_FT;
+ else if (p("--cbg"))
+ csa->bfcp.type = GLP_BF_BG;
+ else if (p("--cgr"))
+ csa->bfcp.type = GLP_BF_GR;
+#else
+ else if (p("--luf"))
+ { csa->bfcp.type &= 0x0F;
+ csa->bfcp.type |= GLP_BF_LUF;
+ }
+ else if (p("--btf"))
+ { csa->bfcp.type &= 0x0F;
+ csa->bfcp.type |= GLP_BF_BTF;
+ }
+ else if (p("--ft"))
+ { csa->bfcp.type &= 0xF0;
+ csa->bfcp.type |= GLP_BF_FT;
+ }
+ else if (p("--cbg"))
+ { csa->bfcp.type &= 0xF0;
+ csa->bfcp.type |= GLP_BF_BG;
+ }
+ else if (p("--cgr"))
+ { csa->bfcp.type &= 0xF0;
+ csa->bfcp.type |= GLP_BF_GR;
+ }
+#endif
+ else if (p("--primal"))
+ csa->smcp.meth = GLP_PRIMAL;
+ else if (p("--dual"))
+ csa->smcp.meth = GLP_DUAL;
+ else if (p("--std"))
+ csa->crash = USE_STD_BASIS;
+ else if (p("--adv"))
+ csa->crash = USE_ADV_BASIS;
+ else if (p("--bib"))
+ csa->crash = USE_CPX_BASIS;
+ else if (p("--ini"))
+ { csa->crash = USE_INI_BASIS;
+ csa->smcp.presolve = GLP_OFF;
+ k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No initial basis file specified\n");
+ return 1;
+ }
+ if (csa->ini_file != NULL)
+ { xprintf("Only one initial basis file allowed\n");
+ return 1;
+ }
+ csa->ini_file = argv[k];
+ }
+ else if (p("--steep"))
+ csa->smcp.pricing = GLP_PT_PSE;
+ else if (p("--nosteep"))
+ csa->smcp.pricing = GLP_PT_STD;
+ else if (p("--relax"))
+ csa->smcp.r_test = GLP_RT_HAR;
+ else if (p("--norelax"))
+ csa->smcp.r_test = GLP_RT_STD;
+#if 1 /* 28/III-2016 */
+ else if (p("--flip"))
+#if 0 /* 23/VI-2017 */
+ { csa->smcp.meth = GLP_DUAL;
+#else
+ /* now this option is implemented in both primal and dual */
+ {
+#endif
+ csa->smcp.r_test = GLP_RT_FLIP;
+ csa->iocp.flip = GLP_ON;
+ }
+#endif
+ else if (p("--presol"))
+ csa->smcp.presolve = GLP_ON;
+ else if (p("--nopresol"))
+ csa->smcp.presolve = GLP_OFF;
+ else if (p("--exact"))
+ csa->exact = 1;
+ else if (p("--xcheck"))
+ csa->xcheck = 1;
+ else if (p("--nord"))
+ csa->iptcp.ord_alg = GLP_ORD_NONE;
+ else if (p("--qmd"))
+ csa->iptcp.ord_alg = GLP_ORD_QMD;
+ else if (p("--amd"))
+ csa->iptcp.ord_alg = GLP_ORD_AMD;
+ else if (p("--symamd"))
+ csa->iptcp.ord_alg = GLP_ORD_SYMAMD;
+ else if (p("--nomip"))
+ csa->nomip = 1;
+ else if (p("--first"))
+ csa->iocp.br_tech = GLP_BR_FFV;
+ else if (p("--last"))
+ csa->iocp.br_tech = GLP_BR_LFV;
+ else if (p("--drtom"))
+ csa->iocp.br_tech = GLP_BR_DTH;
+ else if (p("--mostf"))
+ csa->iocp.br_tech = GLP_BR_MFV;
+ else if (p("--pcost"))
+ csa->iocp.br_tech = GLP_BR_PCH;
+ else if (p("--dfs"))
+ csa->iocp.bt_tech = GLP_BT_DFS;
+ else if (p("--bfs"))
+ csa->iocp.bt_tech = GLP_BT_BFS;
+ else if (p("--bestp"))
+ csa->iocp.bt_tech = GLP_BT_BPH;
+ else if (p("--bestb"))
+ csa->iocp.bt_tech = GLP_BT_BLB;
+ else if (p("--intopt"))
+ csa->iocp.presolve = GLP_ON;
+ else if (p("--nointopt"))
+ csa->iocp.presolve = GLP_OFF;
+ else if (p("--binarize"))
+ csa->iocp.presolve = csa->iocp.binarize = GLP_ON;
+ else if (p("--fpump"))
+ csa->iocp.fp_heur = GLP_ON;
+#if 1 /* 29/VI-2013 */
+ else if (p("--proxy"))
+ { csa->iocp.ps_heur = GLP_ON;
+ if (argv[k+1] && isdigit((unsigned char)argv[k+1][0]))
+ { int nnn;
+ k++;
+ if (str2int(argv[k], &nnn) || nnn < 1)
+ { xprintf("Invalid proxy time limit '%s'\n", argv[k]);
+ return 1;
+ }
+ csa->iocp.ps_tm_lim = 1000 * nnn;
+ }
+ }
+#endif
+ else if (p("--gomory"))
+ csa->iocp.gmi_cuts = GLP_ON;
+ else if (p("--mir"))
+ csa->iocp.mir_cuts = GLP_ON;
+ else if (p("--cover"))
+ csa->iocp.cov_cuts = GLP_ON;
+ else if (p("--clique"))
+ csa->iocp.clq_cuts = GLP_ON;
+ else if (p("--cuts"))
+ csa->iocp.gmi_cuts = csa->iocp.mir_cuts =
+ csa->iocp.cov_cuts = csa->iocp.clq_cuts = GLP_ON;
+ else if (p("--mipgap"))
+ { double mip_gap;
+ k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No relative gap tolerance specified\n");
+ return 1;
+ }
+ if (str2num(argv[k], &mip_gap) || mip_gap < 0.0)
+ { xprintf("Invalid relative mip gap tolerance '%s'\n",
+ argv[k]);
+ return 1;
+ }
+ csa->iocp.mip_gap = mip_gap;
+ }
+#if 1 /* 15/VIII-2011 */
+ else if (p("--minisat"))
+ csa->minisat = 1;
+ else if (p("--objbnd"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' ||
+ argv[k][0] == '-' && !isdigit((unsigned char)argv[k][1]))
+ { xprintf("No objective bound specified\n");
+ return 1;
+ }
+ csa->minisat = 1;
+ csa->use_bnd = 1;
+ if (str2int(argv[k], &csa->obj_bnd))
+ { xprintf("Invalid objective bound '%s' (should be integer"
+ " value)\n", argv[k]);
+ return 1;
+ }
+ }
+#endif
+#if 1 /* 11/VII-2013 */
+ else if (p("--use"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No input MIP solution file specified\n");
+ return 1;
+ }
+ if (csa->use_sol != NULL)
+ { xprintf("Only one input MIP solution file allowed\n");
+ return 1;
+ }
+ csa->use_sol = argv[k];
+ }
+ else if (p("--save"))
+ { k++;
+ if (k == argc || argv[k][0] == '\0' || argv[k][0] == '-')
+ { xprintf("No output MIP solution file specified\n");
+ return 1;
+ }
+ if (csa->iocp.save_sol != NULL)
+ { xprintf("Only one output MIP solution file allowed\n");
+ return 1;
+ }
+ csa->iocp.save_sol = argv[k];
+ }
+#endif
+ else if (argv[k][0] == '-' ||
+ (argv[k][0] == '-' && argv[k][1] == '-'))
+ { xprintf("Invalid option '%s'; try %s --help\n",
+ argv[k], argv[0]);
+ return 1;
+ }
+ else
+ { if (csa->in_file != NULL)
+ { xprintf("Only one input problem file allowed\n");
+ return 1;
+ }
+ csa->in_file = argv[k];
+ }
+ }
+#undef p
+ return 0;
+}
+
+typedef struct { double rhs, pi; } v_data;
+typedef struct { double low, cap, cost, x; } a_data;
+
+#ifndef __WOE__
+int main(int argc, char *argv[])
+#else
+int __cdecl main(int argc, char *argv[])
+#endif
+{ /* stand-alone LP/MIP solver */
+ struct csa _csa, *csa = &_csa;
+ int ret;
+#if 0 /* 10/VI-2013 */
+ glp_long start;
+#else
+ double start;
+#endif
+ /* perform initialization */
+ csa->prob = glp_create_prob();
+ glp_get_bfcp(csa->prob, &csa->bfcp);
+ glp_init_smcp(&csa->smcp);
+ csa->smcp.presolve = GLP_ON;
+ glp_init_iptcp(&csa->iptcp);
+ glp_init_iocp(&csa->iocp);
+ csa->iocp.presolve = GLP_ON;
+ csa->tran = NULL;
+ csa->graph = NULL;
+ csa->format = FMT_MPS_FILE;
+ csa->in_file = NULL;
+ csa->ndf = 0;
+ csa->out_dpy = NULL;
+ csa->seed = 1;
+ csa->solution = SOL_BASIC;
+ csa->in_res = NULL;
+ csa->dir = 0;
+ csa->scale = 1;
+ csa->out_sol = NULL;
+ csa->out_res = NULL;
+ csa->out_ranges = NULL;
+ csa->check = 0;
+ csa->new_name = NULL;
+#if 1 /* 18/I-2018 */
+ csa->hide = 0;
+#endif
+ csa->out_mps = NULL;
+ csa->out_freemps = NULL;
+ csa->out_cpxlp = NULL;
+ csa->out_glp = NULL;
+#if 0
+ csa->out_pb = NULL;
+ csa->out_npb = NULL;
+#endif
+#if 1 /* 06/VIII-2011 */
+ csa->out_cnf = NULL;
+#endif
+ csa->log_file = NULL;
+ csa->crash = USE_ADV_BASIS;
+ csa->ini_file = NULL;
+ csa->exact = 0;
+ csa->xcheck = 0;
+ csa->nomip = 0;
+#if 1 /* 15/VIII-2011 */
+ csa->minisat = 0;
+ csa->use_bnd = 0;
+ csa->obj_bnd = 0;
+#endif
+#if 1 /* 11/VII-2013 */
+ csa->use_sol = NULL;
+#endif
+ /* parse command-line parameters */
+ ret = parse_cmdline(csa, argc, argv);
+ if (ret < 0)
+ { ret = EXIT_SUCCESS;
+ goto done;
+ }
+ if (ret > 0)
+ { ret = EXIT_FAILURE;
+ goto done;
+ }
+ /*--------------------------------------------------------------*/
+ /* remove all output files specified in the command line */
+ if (csa->out_dpy != NULL) remove(csa->out_dpy);
+ if (csa->out_sol != NULL) remove(csa->out_sol);
+ if (csa->out_res != NULL) remove(csa->out_res);
+ if (csa->out_ranges != NULL) remove(csa->out_ranges);
+ if (csa->out_mps != NULL) remove(csa->out_mps);
+ if (csa->out_freemps != NULL) remove(csa->out_freemps);
+ if (csa->out_cpxlp != NULL) remove(csa->out_cpxlp);
+ if (csa->out_glp != NULL) remove(csa->out_glp);
+#if 0
+ if (csa->out_pb != NULL) remove(csa->out_pb);
+ if (csa->out_npb != NULL) remove(csa->out_npb);
+#endif
+#if 1 /* 06/VIII-2011 */
+ if (csa->out_cnf != NULL) remove(csa->out_cnf);
+#endif
+ if (csa->log_file != NULL) remove(csa->log_file);
+ /*--------------------------------------------------------------*/
+ /* open log file, if required */
+ if (csa->log_file != NULL)
+ { if (glp_open_tee(csa->log_file))
+ { xprintf("Unable to create log file\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* print version information */
+ print_version(1);
+ /*--------------------------------------------------------------*/
+ /* print parameters specified in the command line */
+ if (argc > 1)
+ { int k, len = INT_MAX;
+ xprintf("Parameter(s) specified in the command line:");
+ for (k = 1; k < argc; k++)
+ { if (len > 72)
+ xprintf("\n"), len = 0;
+ xprintf(" %s", argv[k]);
+ len += 1 + strlen(argv[k]);
+ }
+ xprintf("\n");
+ }
+ /*--------------------------------------------------------------*/
+ /* read problem data from the input file */
+ if (csa->in_file == NULL)
+ { xprintf("No input problem file specified; try %s --help\n",
+ argv[0]);
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ if (csa->format == FMT_MPS_DECK)
+ { ret = glp_read_mps(csa->prob, GLP_MPS_DECK, NULL,
+ csa->in_file);
+ if (ret != 0)
+err1: { xprintf("MPS file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ else if (csa->format == FMT_MPS_FILE)
+ { ret = glp_read_mps(csa->prob, GLP_MPS_FILE, NULL,
+ csa->in_file);
+ if (ret != 0) goto err1;
+ }
+ else if (csa->format == FMT_LP)
+ { ret = glp_read_lp(csa->prob, NULL, csa->in_file);
+ if (ret != 0)
+ { xprintf("CPLEX LP file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ else if (csa->format == FMT_GLP)
+ { ret = glp_read_prob(csa->prob, 0, csa->in_file);
+ if (ret != 0)
+ { xprintf("GLPK LP/MIP file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ else if (csa->format == FMT_MATHPROG)
+ { int k;
+ /* allocate the translator workspace */
+ csa->tran = glp_mpl_alloc_wksp();
+ /* set seed value */
+ if (csa->seed == 0x80000000)
+#if 0 /* 10/VI-2013 */
+ { csa->seed = glp_time().lo;
+#else
+ { csa->seed = (int)fmod(glp_time(), 1000000000.0);
+#endif
+ xprintf("Seed value %d will be used\n", csa->seed);
+ }
+ glp_mpl_init_rand(csa->tran, csa->seed);
+ /* read model section and optional data section */
+ if (glp_mpl_read_model(csa->tran, csa->in_file, csa->ndf > 0))
+err2: { xprintf("MathProg model processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ /* read optional data section(s), if necessary */
+ for (k = 1; k <= csa->ndf; k++)
+ { if (glp_mpl_read_data(csa->tran, csa->in_data[k]))
+ goto err2;
+ }
+ /* generate the model */
+ if (glp_mpl_generate(csa->tran, csa->out_dpy)) goto err2;
+ /* build the problem instance from the model */
+ glp_mpl_build_prob(csa->tran, csa->prob);
+ }
+ else if (csa->format == FMT_MIN_COST)
+ { csa->graph = glp_create_graph(sizeof(v_data), sizeof(a_data));
+ ret = glp_read_mincost(csa->graph, offsetof(v_data, rhs),
+ offsetof(a_data, low), offsetof(a_data, cap),
+ offsetof(a_data, cost), csa->in_file);
+ if (ret != 0)
+ { xprintf("DIMACS file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ glp_mincost_lp(csa->prob, csa->graph, GLP_ON,
+ offsetof(v_data, rhs), offsetof(a_data, low),
+ offsetof(a_data, cap), offsetof(a_data, cost));
+ glp_set_prob_name(csa->prob, csa->in_file);
+ }
+ else if (csa->format == FMT_MAX_FLOW)
+ { int s, t;
+ csa->graph = glp_create_graph(sizeof(v_data), sizeof(a_data));
+ ret = glp_read_maxflow(csa->graph, &s, &t,
+ offsetof(a_data, cap), csa->in_file);
+ if (ret != 0)
+ { xprintf("DIMACS file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ glp_maxflow_lp(csa->prob, csa->graph, GLP_ON, s, t,
+ offsetof(a_data, cap));
+ glp_set_prob_name(csa->prob, csa->in_file);
+ }
+#if 1 /* 06/VIII-2011 */
+ else if (csa->format == FMT_CNF)
+ { ret = glp_read_cnfsat(csa->prob, csa->in_file);
+ if (ret != 0)
+ { xprintf("DIMACS file processing error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ glp_set_prob_name(csa->prob, csa->in_file);
+ }
+#endif
+ else
+ xassert(csa != csa);
+ /*--------------------------------------------------------------*/
+ /* change problem name, if required */
+ if (csa->new_name != NULL)
+ glp_set_prob_name(csa->prob, csa->new_name);
+ /* change optimization direction, if required */
+ if (csa->dir != 0)
+ glp_set_obj_dir(csa->prob, csa->dir);
+ /* sort elements of the constraint matrix */
+ glp_sort_matrix(csa->prob);
+#if 1 /* 18/I-2018 */
+ /*--------------------------------------------------------------*/
+ /* remove all symbolic names from problem object, if required */
+ if (csa->hide)
+ { int i, j;
+ glp_set_obj_name(csa->prob, NULL);
+ glp_delete_index(csa->prob);
+ for (i = glp_get_num_rows(csa->prob); i >= 1; i--)
+ glp_set_row_name(csa->prob, i, NULL);
+ for (j = glp_get_num_cols(csa->prob); j >= 1; j--)
+ glp_set_col_name(csa->prob, j, NULL);
+ }
+#endif
+ /*--------------------------------------------------------------*/
+ /* write problem data in fixed MPS format, if required */
+ if (csa->out_mps != NULL)
+ { ret = glp_write_mps(csa->prob, GLP_MPS_DECK, NULL,
+ csa->out_mps);
+ if (ret != 0)
+ { xprintf("Unable to write problem in fixed MPS format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write problem data in free MPS format, if required */
+ if (csa->out_freemps != NULL)
+ { ret = glp_write_mps(csa->prob, GLP_MPS_FILE, NULL,
+ csa->out_freemps);
+ if (ret != 0)
+ { xprintf("Unable to write problem in free MPS format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write problem data in CPLEX LP format, if required */
+ if (csa->out_cpxlp != NULL)
+ { ret = glp_write_lp(csa->prob, NULL, csa->out_cpxlp);
+ if (ret != 0)
+ { xprintf("Unable to write problem in CPLEX LP format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write problem data in GLPK format, if required */
+ if (csa->out_glp != NULL)
+ { ret = glp_write_prob(csa->prob, 0, csa->out_glp);
+ if (ret != 0)
+ { xprintf("Unable to write problem in GLPK format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+#if 0
+ /* write problem data in OPB format, if required */
+ if (csa->out_pb != NULL)
+ { ret = lpx_write_pb(csa->prob, csa->out_pb, 0, 0);
+ if (ret != 0)
+ { xprintf("Unable to write problem in OPB format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write problem data in normalized OPB format, if required */
+ if (csa->out_npb != NULL)
+ { ret = lpx_write_pb(csa->prob, csa->out_npb, 1, 1);
+ if (ret != 0)
+ { xprintf(
+ "Unable to write problem in normalized OPB format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+#endif
+#if 1 /* 06/VIII-2011 */
+ /* write problem data in DIMACS CNF-SAT format, if required */
+ if (csa->out_cnf != NULL)
+ { ret = glp_write_cnfsat(csa->prob, csa->out_cnf);
+ if (ret != 0)
+ { xprintf(
+ "Unable to write problem in DIMACS CNF-SAT format\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+#endif
+ /*--------------------------------------------------------------*/
+ /* if only problem data check is required, skip computations */
+ if (csa->check)
+ {
+#if 1 /* 29/III-2016 */
+ /* report problem characteristics */
+ int j, cnt = 0;
+ xprintf("--- Problem Characteristics ---\n");
+ xprintf("Number of rows = %8d\n",
+ glp_get_num_rows(csa->prob));
+ xprintf("Number of columns = %8d\n",
+ glp_get_num_cols(csa->prob));
+ xprintf("Number of non-zeros (matrix) = %8d\n",
+ glp_get_num_nz(csa->prob));
+ for (j = glp_get_num_cols(csa->prob); j >= 1; j--)
+ { if (glp_get_obj_coef(csa->prob, j) != 0.0)
+ cnt++;
+ }
+ xprintf("Number of non-zeros (objrow) = %8d\n",
+ cnt);
+#endif
+ ret = EXIT_SUCCESS;
+ goto done;
+ }
+ /*--------------------------------------------------------------*/
+ /* determine the solution type */
+ if (!csa->nomip &&
+ glp_get_num_int(csa->prob) + glp_get_num_bin(csa->prob) > 0)
+ { if (csa->solution == SOL_INTERIOR)
+ { xprintf("Interior-point method is not able to solve MIP pro"
+ "blem; use --simplex\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ csa->solution = SOL_INTEGER;
+ }
+ /*--------------------------------------------------------------*/
+ /* if solution is provided, read it and skip computations */
+ if (csa->in_res != NULL)
+ { if (csa->solution == SOL_BASIC)
+ ret = glp_read_sol(csa->prob, csa->in_res);
+ else if (csa->solution == SOL_INTERIOR)
+ ret = glp_read_ipt(csa->prob, csa->in_res);
+ else if (csa->solution == SOL_INTEGER)
+ ret = glp_read_mip(csa->prob, csa->in_res);
+ else
+ xassert(csa != csa);
+ if (ret != 0)
+ { xprintf("Unable to read problem solution\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ goto skip;
+ }
+#if 1 /* 11/VII-2013 */
+ /*--------------------------------------------------------------*/
+ /* if initial MIP solution is provided, read it */
+ if (csa->solution == SOL_INTEGER && csa->use_sol != NULL)
+ { ret = glp_read_mip(csa->prob, csa->use_sol);
+ if (ret != 0)
+ { xprintf("Unable to read initial MIP solution\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ csa->iocp.use_sol = GLP_ON;
+ }
+#endif
+ /*--------------------------------------------------------------*/
+ /* scale the problem data, if required */
+ if (csa->scale)
+ { if (csa->solution == SOL_BASIC && !csa->smcp.presolve ||
+ csa->solution == SOL_INTERIOR ||
+ csa->solution == SOL_INTEGER && !csa->iocp.presolve)
+ glp_scale_prob(csa->prob, GLP_SF_AUTO);
+ }
+ /*--------------------------------------------------------------*/
+ /* construct starting LP basis */
+ if (csa->solution == SOL_BASIC && !csa->smcp.presolve ||
+ csa->solution == SOL_INTEGER && !csa->iocp.presolve)
+ { if (csa->crash == USE_STD_BASIS)
+ glp_std_basis(csa->prob);
+ else if (csa->crash == USE_ADV_BASIS)
+ glp_adv_basis(csa->prob, 0);
+ else if (csa->crash == USE_CPX_BASIS)
+ glp_cpx_basis(csa->prob);
+ else if (csa->crash == USE_INI_BASIS)
+ { ret = glp_read_sol(csa->prob, csa->ini_file);
+ if (ret != 0)
+ { xprintf("Unable to read initial basis\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ else
+ xassert(csa != csa);
+ }
+ /*--------------------------------------------------------------*/
+ /* solve the problem */
+
+ start = glp_time();
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+ if (csa->solution == SOL_BASIC)
+ { if (!csa->exact)
+ { glp_set_bfcp(csa->prob, &csa->bfcp);
+ glp_simplex(csa->prob, &csa->smcp);
+ if (csa->xcheck)
+ { if (csa->smcp.presolve &&
+ glp_get_status(csa->prob) != GLP_OPT)
+ xprintf("If you need to check final basis for non-opt"
+ "imal solution, use --nopresol\n");
+ else
+ glp_exact(csa->prob, &csa->smcp);
+ }
+ if (csa->out_sol != NULL || csa->out_res != NULL)
+ { if (csa->smcp.presolve &&
+ glp_get_status(csa->prob) != GLP_OPT)
+ xprintf("If you need actual output for non-optimal solut"
+ "ion, use --nopresol\n");
+ }
+ }
+ else
+ glp_exact(csa->prob, &csa->smcp);
+ }
+ else if (csa->solution == SOL_INTERIOR)
+ glp_interior(csa->prob, &csa->iptcp);
+#if 1 /* 15/VIII-2011 */
+ else if (csa->solution == SOL_INTEGER && csa->minisat)
+ { if (glp_check_cnfsat(csa->prob) == 0)
+ glp_minisat1(csa->prob);
+ else
+ glp_intfeas1(csa->prob, csa->use_bnd, csa->obj_bnd);
+ }
+#endif
+ else if (csa->solution == SOL_INTEGER)
+ { glp_set_bfcp(csa->prob, &csa->bfcp);
+ if (!csa->iocp.presolve)
+ glp_simplex(csa->prob, &csa->smcp);
+#if 0
+ csa->iocp.msg_lev = GLP_MSG_DBG;
+ csa->iocp.pp_tech = GLP_PP_NONE;
+#endif
+#ifdef GLP_CB_FUNC /* 05/IV-2016 */
+ { extern void GLP_CB_FUNC(glp_tree *, void *);
+ csa->iocp.cb_func = GLP_CB_FUNC;
+ csa->iocp.cb_info = NULL;
+ }
+#endif
+ glp_intopt(csa->prob, &csa->iocp);
+ }
+ else
+ xassert(csa != csa);
+ /*--------------------------------------------------------------*/
+ /* display statistics */
+#ifdef VERIMAG
+ clock_stop();
+ print_total_clock();
+#endif
+ xprintf("Time used: %.1f secs\n", glp_difftime(glp_time(),
+ start));
+#if 0 /* 16/II-2012 */
+ { glp_long tpeak;
+ char buf[50];
+ glp_mem_usage(NULL, NULL, NULL, &tpeak);
+ xprintf("Memory used: %.1f Mb (%s bytes)\n",
+ xltod(tpeak) / 1048576.0, xltoa(tpeak, buf));
+ }
+#else
+ { size_t tpeak;
+ glp_mem_usage(NULL, NULL, NULL, &tpeak);
+ xprintf("Memory used: %.1f Mb (%.0f bytes)\n",
+ (double)tpeak / 1048576.0, (double)tpeak);
+ }
+#endif
+ /*--------------------------------------------------------------*/
+skip: /* postsolve the model, if necessary */
+ if (csa->tran != NULL)
+ { if (csa->solution == SOL_BASIC)
+ { if (!(glp_get_status(csa->prob) == GLP_OPT ||
+ glp_get_status(csa->prob) == GLP_FEAS))
+ ret = -1;
+ else
+ ret = glp_mpl_postsolve(csa->tran, csa->prob, GLP_SOL);
+ }
+ else if (csa->solution == SOL_INTERIOR)
+ { if (!(glp_ipt_status(csa->prob) == GLP_OPT ||
+ glp_ipt_status(csa->prob) == GLP_FEAS))
+ ret = -1;
+ else
+ ret = glp_mpl_postsolve(csa->tran, csa->prob, GLP_IPT);
+ }
+ else if (csa->solution == SOL_INTEGER)
+ { if (!(glp_mip_status(csa->prob) == GLP_OPT ||
+ glp_mip_status(csa->prob) == GLP_FEAS))
+ ret = -1;
+ else
+ ret = glp_mpl_postsolve(csa->tran, csa->prob, GLP_MIP);
+ }
+ else
+ xassert(csa != csa);
+ if (ret > 0)
+ { xprintf("Model postsolving error\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* write problem solution in printable format, if required */
+ if (csa->out_sol != NULL)
+ { if (csa->solution == SOL_BASIC)
+ ret = glp_print_sol(csa->prob, csa->out_sol);
+ else if (csa->solution == SOL_INTERIOR)
+ ret = glp_print_ipt(csa->prob, csa->out_sol);
+ else if (csa->solution == SOL_INTEGER)
+ ret = glp_print_mip(csa->prob, csa->out_sol);
+ else
+ xassert(csa != csa);
+ if (ret != 0)
+ { xprintf("Unable to write problem solution\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write problem solution in printable format, if required */
+ if (csa->out_res != NULL)
+ { if (csa->solution == SOL_BASIC)
+ ret = glp_write_sol(csa->prob, csa->out_res);
+ else if (csa->solution == SOL_INTERIOR)
+ ret = glp_write_ipt(csa->prob, csa->out_res);
+ else if (csa->solution == SOL_INTEGER)
+ ret = glp_write_mip(csa->prob, csa->out_res);
+ else
+ xassert(csa != csa);
+ if (ret != 0)
+ { xprintf("Unable to write problem solution\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ /* write sensitivity analysis report, if required */
+ if (csa->out_ranges != NULL)
+ { if (csa->solution == SOL_BASIC)
+ { if (glp_get_status(csa->prob) == GLP_OPT)
+ { if (glp_bf_exists(csa->prob))
+ranges: { ret = glp_print_ranges(csa->prob, 0, NULL, 0,
+ csa->out_ranges);
+ if (ret != 0)
+ { xprintf("Unable to write sensitivity analysis repo"
+ "rt\n");
+ ret = EXIT_FAILURE;
+ goto done;
+ }
+ }
+ else
+ { ret = glp_factorize(csa->prob);
+ if (ret == 0) goto ranges;
+ xprintf("Cannot produce sensitivity analysis report d"
+ "ue to error in basis factorization (glp_factorize"
+ " returned %d); try --nopresol\n", ret);
+ }
+ }
+ else
+ xprintf("Cannot produce sensitivity analysis report for "
+ "non-optimal basic solution\n");
+ }
+ else
+ xprintf("Cannot produce sensitivity analysis report for int"
+ "erior-point or MIP solution\n");
+ }
+ /*--------------------------------------------------------------*/
+ /* all seems to be ok */
+ ret = EXIT_SUCCESS;
+ /*--------------------------------------------------------------*/
+done: /* delete the LP/MIP problem object */
+ if (csa->prob != NULL)
+ glp_delete_prob(csa->prob);
+ /* free the translator workspace, if necessary */
+ if (csa->tran != NULL)
+ glp_mpl_free_wksp(csa->tran);
+ /* delete the network problem object, if necessary */
+ if (csa->graph != NULL)
+ glp_delete_graph(csa->graph);
+#if 0 /* 23/XI-2015 */
+ xassert(gmp_pool_count() == 0);
+ gmp_free_mem();
+#endif
+ /* close log file, if necessary */
+ if (csa->log_file != NULL) glp_close_tee();
+ /* check that no memory blocks are still allocated */
+#if 0 /* 16/II-2012 */
+ { int count;
+ glp_long total;
+ glp_mem_usage(&count, NULL, &total, NULL);
+ if (count != 0)
+ xerror("Error: %d memory block(s) were lost\n", count);
+ xassert(count == 0);
+ xassert(total.lo == 0 && total.hi == 0);
+ }
+#else
+ { int count;
+ size_t total;
+ glp_mem_usage(&count, NULL, &total, NULL);
+ if (count != 0)
+ xerror("Error: %d memory block(s) were lost\n", count);
+ xassert(total == 0);
+ }
+#endif
+ /* free the GLPK environment */
+ glp_free_env();
+ /* return to the control program */
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/examples/prod.mod b/test/monniaux/glpk-4.65/examples/prod.mod
new file mode 100644
index 00000000..aa793f76
--- /dev/null
+++ b/test/monniaux/glpk-4.65/examples/prod.mod
@@ -0,0 +1,331 @@
+# PROD, a multiperiod production model
+#
+# References:
+# Robert Fourer, David M. Gay and Brian W. Kernighan, "A Modeling Language
+# for Mathematical Programming." Management Science 36 (1990) 519-554.
+
+### PRODUCTION SETS AND PARAMETERS ###
+
+set prd 'products'; # Members of the product group
+
+param pt 'production time' {prd} > 0;
+
+ # Crew-hours to produce 1000 units
+
+param pc 'production cost' {prd} > 0;
+
+ # Nominal production cost per 1000, used
+ # to compute inventory and shortage costs
+
+### TIME PERIOD SETS AND PARAMETERS ###
+
+param first > 0 integer;
+ # Index of first production period to be modeled
+
+param last > first integer;
+
+ # Index of last production period to be modeled
+
+set time 'planning horizon' := first..last;
+
+### EMPLOYMENT PARAMETERS ###
+
+param cs 'crew size' > 0 integer;
+
+ # Workers per crew
+
+param sl 'shift length' > 0;
+
+ # Regular-time hours per shift
+
+param rtr 'regular time rate' > 0;
+
+ # Wage per hour for regular-time labor
+
+param otr 'overtime rate' > rtr;
+
+ # Wage per hour for overtime labor
+
+param iw 'initial workforce' >= 0 integer;
+
+ # Crews employed at start of first period
+
+param dpp 'days per period' {time} > 0;
+
+ # Regular working days in a production period
+
+param ol 'overtime limit' {time} >= 0;
+
+ # Maximum crew-hours of overtime in a period
+
+param cmin 'crew minimum' {time} >= 0;
+
+ # Lower limit on average employment in a period
+
+param cmax 'crew maximum' {t in time} >= cmin[t];
+
+ # Upper limit on average employment in a period
+
+param hc 'hiring cost' {time} >= 0;
+
+ # Penalty cost of hiring a crew
+
+param lc 'layoff cost' {time} >= 0;
+
+ # Penalty cost of laying off a crew
+
+### DEMAND PARAMETERS ###
+
+param dem 'demand' {prd,first..last+1} >= 0;
+
+ # Requirements (in 1000s)
+ # to be met from current production and inventory
+
+param pro 'promoted' {prd,first..last+1} logical;
+
+ # true if product will be the subject
+ # of a special promotion in the period
+
+### INVENTORY AND SHORTAGE PARAMETERS ###
+
+param rir 'regular inventory ratio' >= 0;
+
+ # Proportion of non-promoted demand
+ # that must be in inventory the previous period
+
+param pir 'promotional inventory ratio' >= 0;
+
+ # Proportion of promoted demand
+ # that must be in inventory the previous period
+
+param life 'inventory lifetime' > 0 integer;
+
+ # Upper limit on number of periods that
+ # any product may sit in inventory
+
+param cri 'inventory cost ratio' {prd} > 0;
+
+ # Inventory cost per 1000 units is
+ # cri times nominal production cost
+
+param crs 'shortage cost ratio' {prd} > 0;
+
+ # Shortage cost per 1000 units is
+ # crs times nominal production cost
+
+param iinv 'initial inventory' {prd} >= 0;
+
+ # Inventory at start of first period; age unknown
+
+param iil 'initial inventory left' {p in prd, t in time}
+ := iinv[p] less sum {v in first..t} dem[p,v];
+
+ # Initial inventory still available for allocation
+ # at end of period t
+
+param minv 'minimum inventory' {p in prd, t in time}
+ := dem[p,t+1] * (if pro[p,t+1] then pir else rir);
+
+ # Lower limit on inventory at end of period t
+
+### VARIABLES ###
+
+var Crews{first-1..last} >= 0;
+
+ # Average number of crews employed in each period
+
+var Hire{time} >= 0; # Crews hired from previous to current period
+
+var Layoff{time} >= 0; # Crews laid off from previous to current period
+
+var Rprd 'regular production' {prd,time} >= 0;
+
+ # Production using regular-time labor, in 1000s
+
+var Oprd 'overtime production' {prd,time} >= 0;
+
+ # Production using overtime labor, in 1000s
+
+var Inv 'inventory' {prd,time,1..life} >= 0;
+
+ # Inv[p,t,a] is the amount of product p that is
+ # a periods old -- produced in period (t+1)-a --
+ # and still in storage at the end of period t
+
+var Short 'shortage' {prd,time} >= 0;
+
+ # Accumulated unsatisfied demand at the end of period t
+
+### OBJECTIVE ###
+
+minimize cost:
+
+ sum {t in time} rtr * sl * dpp[t] * cs * Crews[t] +
+ sum {t in time} hc[t] * Hire[t] +
+ sum {t in time} lc[t] * Layoff[t] +
+ sum {t in time, p in prd} otr * cs * pt[p] * Oprd[p,t] +
+ sum {t in time, p in prd, a in 1..life} cri[p] * pc[p] * Inv[p,t,a] +
+ sum {t in time, p in prd} crs[p] * pc[p] * Short[p,t];
+
+ # Full regular wages for all crews employed, plus
+ # penalties for hiring and layoffs, plus
+ # wages for any overtime worked, plus
+ # inventory and shortage costs
+
+ # (All other production costs are assumed
+ # to depend on initial inventory and on demands,
+ # and so are not included explicitly.)
+
+### CONSTRAINTS ###
+
+rlim 'regular-time limit' {t in time}:
+
+ sum {p in prd} pt[p] * Rprd[p,t] <= sl * dpp[t] * Crews[t];
+
+ # Hours needed to accomplish all regular-time
+ # production in a period must not exceed
+ # hours available on all shifts
+
+olim 'overtime limit' {t in time}:
+
+ sum {p in prd} pt[p] * Oprd[p,t] <= ol[t];
+
+ # Hours needed to accomplish all overtime
+ # production in a period must not exceed
+ # the specified overtime limit
+
+empl0 'initial crew level': Crews[first-1] = iw;
+
+ # Use given initial workforce
+
+empl 'crew levels' {t in time}: Crews[t] = Crews[t-1] + Hire[t] - Layoff[t];
+
+ # Workforce changes by hiring or layoffs
+
+emplbnd 'crew limits' {t in time}: cmin[t] <= Crews[t] <= cmax[t];
+
+ # Workforce must remain within specified bounds
+
+dreq1 'first demand requirement' {p in prd}:
+
+ Rprd[p,first] + Oprd[p,first] + Short[p,first]
+ - Inv[p,first,1] = dem[p,first] less iinv[p];
+
+dreq 'demand requirements' {p in prd, t in first+1..last}:
+
+ Rprd[p,t] + Oprd[p,t] + Short[p,t] - Short[p,t-1]
+ + sum {a in 1..life} (Inv[p,t-1,a] - Inv[p,t,a])
+ = dem[p,t] less iil[p,t-1];
+
+ # Production plus increase in shortage plus
+ # decrease in inventory must equal demand
+
+ireq 'inventory requirements' {p in prd, t in time}:
+
+ sum {a in 1..life} Inv[p,t,a] + iil[p,t] >= minv[p,t];
+
+ # Inventory in storage at end of period t
+ # must meet specified minimum
+
+izero 'impossible inventories' {p in prd, v in 1..life-1, a in v+1..life}:
+
+ Inv[p,first+v-1,a] = 0;
+
+ # In the vth period (starting from first)
+ # no inventory may be more than v periods old
+ # (initial inventories are handled separately)
+
+ilim1 'new-inventory limits' {p in prd, t in time}:
+
+ Inv[p,t,1] <= Rprd[p,t] + Oprd[p,t];
+
+ # New inventory cannot exceed
+ # production in the most recent period
+
+ilim 'inventory limits' {p in prd, t in first+1..last, a in 2..life}:
+
+ Inv[p,t,a] <= Inv[p,t-1,a-1];
+
+ # Inventory left from period (t+1)-p
+ # can only decrease as time goes on
+
+### DATA ###
+
+data;
+
+set prd := 18REG 24REG 24PRO ;
+
+param first := 1 ;
+param last := 13 ;
+param life := 2 ;
+
+param cs := 18 ;
+param sl := 8 ;
+param iw := 8 ;
+
+param rtr := 16.00 ;
+param otr := 43.85 ;
+param rir := 0.75 ;
+param pir := 0.80 ;
+
+param : pt pc cri crs iinv :=
+
+ 18REG 1.194 2304. 0.015 1.100 82.0
+ 24REG 1.509 2920. 0.015 1.100 792.2
+ 24PRO 1.509 2910. 0.015 1.100 0.0 ;
+
+param : dpp ol cmin cmax hc lc :=
+
+ 1 19.5 96.0 0.0 8.0 7500 7500
+ 2 19.0 96.0 0.0 8.0 7500 7500
+ 3 20.0 96.0 0.0 8.0 7500 7500
+ 4 19.0 96.0 0.0 8.0 7500 7500
+ 5 19.5 96.0 0.0 8.0 15000 15000
+ 6 19.0 96.0 0.0 8.0 15000 15000
+ 7 19.0 96.0 0.0 8.0 15000 15000
+ 8 20.0 96.0 0.0 8.0 15000 15000
+ 9 19.0 96.0 0.0 8.0 15000 15000
+ 10 20.0 96.0 0.0 8.0 15000 15000
+ 11 20.0 96.0 0.0 8.0 7500 7500
+ 12 18.0 96.0 0.0 8.0 7500 7500
+ 13 18.0 96.0 0.0 8.0 7500 7500 ;
+
+param dem (tr) :
+
+ 18REG 24REG 24PRO :=
+
+ 1 63.8 1212.0 0.0
+ 2 76.0 306.2 0.0
+ 3 88.4 319.0 0.0
+ 4 913.8 208.4 0.0
+ 5 115.0 298.0 0.0
+ 6 133.8 328.2 0.0
+ 7 79.6 959.6 0.0
+ 8 111.0 257.6 0.0
+ 9 121.6 335.6 0.0
+ 10 470.0 118.0 1102.0
+ 11 78.4 284.8 0.0
+ 12 99.4 970.0 0.0
+ 13 140.4 343.8 0.0
+ 14 63.8 1212.0 0.0 ;
+
+param pro (tr) :
+
+ 18REG 24REG 24PRO :=
+
+ 1 0 1 0
+ 2 0 0 0
+ 3 0 0 0
+ 4 1 0 0
+ 5 0 0 0
+ 6 0 0 0
+ 7 0 1 0
+ 8 0 0 0
+ 9 0 0 0
+ 10 1 0 1
+ 11 0 0 0
+ 12 0 0 0
+ 13 0 1 0
+ 14 0 1 0 ;
+
+end;
diff --git a/test/monniaux/glpk-4.65/src/amd/COPYING b/test/monniaux/glpk-4.65/src/amd/COPYING
new file mode 100644
index 00000000..84bba36d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/COPYING
@@ -0,0 +1,502 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it. You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+ When we speak of free software, we are referring to freedom of use,
+not price. Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+ To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights. These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ To protect each distributor, we want to make it very clear that
+there is no warranty for the free library. Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+
+ Finally, software patents pose a constant threat to the existence of
+any free program. We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder. Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+ Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License. This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License. We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+ When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library. The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom. The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+ We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License. It also provides other free software developers Less
+of an advantage over competing non-free programs. These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries. However, the Lesser license provides advantages in certain
+special circumstances.
+
+ For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard. To achieve this, non-free programs must be
+allowed to use the library. A more frequent case is that a free
+library does the same job as widely used non-free libraries. In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+ In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software. For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+ Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+
+ GNU LESSER GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+
+ 6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (1) uses at run time a
+ copy of the library already present on the user's computer system,
+ rather than copying library functions into the executable, and (2)
+ will operate properly with a modified version of the library, if
+ the user installs one, as long as the modified version is
+ interface-compatible with the version that the work was made with.
+
+ c) Accompany the work with a written offer, valid for at
+ least three years, to give the same user the materials
+ specified in Subsection 6a, above, for a charge no more
+ than the cost of performing this distribution.
+
+ d) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ e) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded. In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library. It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
diff --git a/test/monniaux/glpk-4.65/src/amd/README b/test/monniaux/glpk-4.65/src/amd/README
new file mode 100644
index 00000000..de950eb4
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/README
@@ -0,0 +1,58 @@
+NOTE: Files in this subdirectory are NOT part of the GLPK package, but
+ are used with GLPK.
+
+ The original code was modified according to GLPK requirements by
+ Andrew Makhorin <mao@gnu.org>.
+************************************************************************
+AMD Version 2.2, Copyright (C) 2007 by Timothy A. Davis,
+Patrick R. Amestoy, and Iain S. Duff. All Rights Reserved.
+
+Description:
+
+ AMD is a set of routines for pre-ordering sparse matrices prior to
+ Cholesky or LU factorization, using the approximate minimum degree
+ ordering algorithm. Written in ANSI/ISO C with a MATLAB interface,
+ and in Fortran 77.
+
+Authors:
+
+ Timothy A. Davis (davis at cise.ufl.edu), University of Florida.
+ Patrick R. Amestoy, ENSEEIHT, Toulouse, France.
+ Iain S. Duff, Rutherford Appleton Laboratory, UK.
+
+AMD License:
+
+ Your use or distribution of AMD or any modified version of AMD
+ implies that you agree to this License.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public License
+ as published by the Free Software Foundation; either version 2.1 of
+ the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
+ USA.
+
+ Permission is hereby granted to use or copy this program under the
+ terms of the GNU LGPL, provided that the Copyright, this License,
+ and the Availability of the original version is retained on all
+ copies. User documentation of any code that uses this code or any
+ modified version of this code must cite the Copyright, this License,
+ the Availability note, and "Used by permission." Permission to
+ modify the code and to distribute modified code is granted, provided
+ the Copyright, this License, and the Availability note are retained,
+ and a notice that the code was modified is included.
+
+ AMD is available under alternate licences; contact T. Davis for
+ details.
+
+Availability:
+
+ http://www.cise.ufl.edu/research/sparse/amd
diff --git a/test/monniaux/glpk-4.65/src/amd/amd.h b/test/monniaux/glpk-4.65/src/amd/amd.h
new file mode 100644
index 00000000..be662d95
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd.h
@@ -0,0 +1,67 @@
+/* amd.h */
+
+/* Written by Andrew Makhorin <mao@gnu.org>. */
+
+#ifndef GLPAMD_H
+#define GLPAMD_H
+
+#define AMD_DATE "May 31, 2007"
+#define AMD_VERSION_CODE(main, sub) ((main) * 1000 + (sub))
+#define AMD_MAIN_VERSION 2
+#define AMD_SUB_VERSION 2
+#define AMD_SUBSUB_VERSION 0
+#define AMD_VERSION AMD_VERSION_CODE(AMD_MAIN_VERSION, AMD_SUB_VERSION)
+
+#define AMD_CONTROL 5
+#define AMD_INFO 20
+
+#define AMD_DENSE 0
+#define AMD_AGGRESSIVE 1
+
+#define AMD_DEFAULT_DENSE 10.0
+#define AMD_DEFAULT_AGGRESSIVE 1
+
+#define AMD_STATUS 0
+#define AMD_N 1
+#define AMD_NZ 2
+#define AMD_SYMMETRY 3
+#define AMD_NZDIAG 4
+#define AMD_NZ_A_PLUS_AT 5
+#define AMD_NDENSE 6
+#define AMD_MEMORY 7
+#define AMD_NCMPA 8
+#define AMD_LNZ 9
+#define AMD_NDIV 10
+#define AMD_NMULTSUBS_LDL 11
+#define AMD_NMULTSUBS_LU 12
+#define AMD_DMAX 13
+
+#define AMD_OK 0
+#define AMD_OUT_OF_MEMORY (-1)
+#define AMD_INVALID (-2)
+#define AMD_OK_BUT_JUMBLED 1
+
+#define amd_order _glp_amd_order
+int amd_order(int n, const int Ap[], const int Ai[], int P[],
+ double Control[], double Info[]);
+
+#define amd_2 _glp_amd_2
+void amd_2(int n, int Pe[], int Iw[], int Len[], int iwlen, int pfree,
+ int Nv[], int Next[], int Last[], int Head[], int Elen[],
+ int Degree[], int W[], double Control[], double Info[]);
+
+#define amd_valid _glp_amd_valid
+int amd_valid(int n_row, int n_col, const int Ap[], const int Ai[]);
+
+#define amd_defaults _glp_amd_defaults
+void amd_defaults(double Control[]);
+
+#define amd_control _glp_amd_control
+void amd_control(double Control[]);
+
+#define amd_info _glp_amd_info
+void amd_info(double Info[]);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_1.c b/test/monniaux/glpk-4.65/src/amd/amd_1.c
new file mode 100644
index 00000000..4f9b07d7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_1.c
@@ -0,0 +1,181 @@
+/* ========================================================================= */
+/* === AMD_1 =============================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* AMD_1: Construct A+A' for a sparse matrix A and perform the AMD ordering.
+ *
+ * The n-by-n sparse matrix A can be unsymmetric. It is stored in MATLAB-style
+ * compressed-column form, with sorted row indices in each column, and no
+ * duplicate entries. Diagonal entries may be present, but they are ignored.
+ * Row indices of column j of A are stored in Ai [Ap [j] ... Ap [j+1]-1].
+ * Ap [0] must be zero, and nz = Ap [n] is the number of entries in A. The
+ * size of the matrix, n, must be greater than or equal to zero.
+ *
+ * This routine must be preceded by a call to AMD_aat, which computes the
+ * number of entries in each row/column in A+A', excluding the diagonal.
+ * Len [j], on input, is the number of entries in row/column j of A+A'. This
+ * routine constructs the matrix A+A' and then calls AMD_2. No error checking
+ * is performed (this was done in AMD_valid).
+ */
+
+#include "amd_internal.h"
+
+GLOBAL void AMD_1
+(
+ Int n, /* n > 0 */
+ const Int Ap [ ], /* input of size n+1, not modified */
+ const Int Ai [ ], /* input of size nz = Ap [n], not modified */
+ Int P [ ], /* size n output permutation */
+ Int Pinv [ ], /* size n output inverse permutation */
+ Int Len [ ], /* size n input, undefined on output */
+ Int slen, /* slen >= sum (Len [0..n-1]) + 7n,
+ * ideally slen = 1.2 * sum (Len) + 8n */
+ Int S [ ], /* size slen workspace */
+ double Control [ ], /* input array of size AMD_CONTROL */
+ double Info [ ] /* output array of size AMD_INFO */
+)
+{
+ Int i, j, k, p, pfree, iwlen, pj, p1, p2, pj2, *Iw, *Pe, *Nv, *Head,
+ *Elen, *Degree, *s, *W, *Sp, *Tp ;
+
+ /* --------------------------------------------------------------------- */
+ /* construct the matrix for AMD_2 */
+ /* --------------------------------------------------------------------- */
+
+ ASSERT (n > 0) ;
+
+ iwlen = slen - 6*n ;
+ s = S ;
+ Pe = s ; s += n ;
+ Nv = s ; s += n ;
+ Head = s ; s += n ;
+ Elen = s ; s += n ;
+ Degree = s ; s += n ;
+ W = s ; s += n ;
+ Iw = s ; s += iwlen ;
+
+ ASSERT (AMD_valid (n, n, Ap, Ai) == AMD_OK) ;
+
+ /* construct the pointers for A+A' */
+ Sp = Nv ; /* use Nv and W as workspace for Sp and Tp [ */
+ Tp = W ;
+ pfree = 0 ;
+ for (j = 0 ; j < n ; j++)
+ {
+ Pe [j] = pfree ;
+ Sp [j] = pfree ;
+ pfree += Len [j] ;
+ }
+
+ /* Note that this restriction on iwlen is slightly more restrictive than
+ * what is strictly required in AMD_2. AMD_2 can operate with no elbow
+ * room at all, but it will be very slow. For better performance, at
+ * least size-n elbow room is enforced. */
+ ASSERT (iwlen >= pfree + n) ;
+
+#ifndef NDEBUG
+ for (p = 0 ; p < iwlen ; p++) Iw [p] = EMPTY ;
+#endif
+
+ for (k = 0 ; k < n ; k++)
+ {
+ AMD_DEBUG1 (("Construct row/column k= "ID" of A+A'\n", k)) ;
+ p1 = Ap [k] ;
+ p2 = Ap [k+1] ;
+
+ /* construct A+A' */
+ for (p = p1 ; p < p2 ; )
+ {
+ /* scan the upper triangular part of A */
+ j = Ai [p] ;
+ ASSERT (j >= 0 && j < n) ;
+ if (j < k)
+ {
+ /* entry A (j,k) in the strictly upper triangular part */
+ ASSERT (Sp [j] < (j == n-1 ? pfree : Pe [j+1])) ;
+ ASSERT (Sp [k] < (k == n-1 ? pfree : Pe [k+1])) ;
+ Iw [Sp [j]++] = k ;
+ Iw [Sp [k]++] = j ;
+ p++ ;
+ }
+ else if (j == k)
+ {
+ /* skip the diagonal */
+ p++ ;
+ break ;
+ }
+ else /* j > k */
+ {
+ /* first entry below the diagonal */
+ break ;
+ }
+ /* scan lower triangular part of A, in column j until reaching
+ * row k. Start where last scan left off. */
+ ASSERT (Ap [j] <= Tp [j] && Tp [j] <= Ap [j+1]) ;
+ pj2 = Ap [j+1] ;
+ for (pj = Tp [j] ; pj < pj2 ; )
+ {
+ i = Ai [pj] ;
+ ASSERT (i >= 0 && i < n) ;
+ if (i < k)
+ {
+ /* A (i,j) is only in the lower part, not in upper */
+ ASSERT (Sp [i] < (i == n-1 ? pfree : Pe [i+1])) ;
+ ASSERT (Sp [j] < (j == n-1 ? pfree : Pe [j+1])) ;
+ Iw [Sp [i]++] = j ;
+ Iw [Sp [j]++] = i ;
+ pj++ ;
+ }
+ else if (i == k)
+ {
+ /* entry A (k,j) in lower part and A (j,k) in upper */
+ pj++ ;
+ break ;
+ }
+ else /* i > k */
+ {
+ /* consider this entry later, when k advances to i */
+ break ;
+ }
+ }
+ Tp [j] = pj ;
+ }
+ Tp [k] = p ;
+ }
+
+ /* clean up, for remaining mismatched entries */
+ for (j = 0 ; j < n ; j++)
+ {
+ for (pj = Tp [j] ; pj < Ap [j+1] ; pj++)
+ {
+ i = Ai [pj] ;
+ ASSERT (i >= 0 && i < n) ;
+ /* A (i,j) is only in the lower part, not in upper */
+ ASSERT (Sp [i] < (i == n-1 ? pfree : Pe [i+1])) ;
+ ASSERT (Sp [j] < (j == n-1 ? pfree : Pe [j+1])) ;
+ Iw [Sp [i]++] = j ;
+ Iw [Sp [j]++] = i ;
+ }
+ }
+
+#ifndef NDEBUG
+ for (j = 0 ; j < n-1 ; j++) ASSERT (Sp [j] == Pe [j+1]) ;
+ ASSERT (Sp [n-1] == pfree) ;
+#endif
+
+ /* Tp and Sp no longer needed ] */
+
+ /* --------------------------------------------------------------------- */
+ /* order the matrix */
+ /* --------------------------------------------------------------------- */
+
+ AMD_2 (n, Pe, Iw, Len, iwlen, pfree,
+ Nv, Pinv, P, Head, Elen, Degree, W, Control, Info) ;
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_2.c b/test/monniaux/glpk-4.65/src/amd/amd_2.c
new file mode 100644
index 00000000..36ae828a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_2.c
@@ -0,0 +1,1842 @@
+/* ========================================================================= */
+/* === AMD_2 =============================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* AMD_2: performs the AMD ordering on a symmetric sparse matrix A, followed
+ * by a postordering (via depth-first search) of the assembly tree using the
+ * AMD_postorder routine.
+ */
+
+#include "amd_internal.h"
+
+/* ========================================================================= */
+/* === clear_flag ========================================================== */
+/* ========================================================================= */
+
+static Int clear_flag (Int wflg, Int wbig, Int W [ ], Int n)
+{
+ Int x ;
+ if (wflg < 2 || wflg >= wbig)
+ {
+ for (x = 0 ; x < n ; x++)
+ {
+ if (W [x] != 0) W [x] = 1 ;
+ }
+ wflg = 2 ;
+ }
+ /* at this point, W [0..n-1] < wflg holds */
+ return (wflg) ;
+}
+
+
+/* ========================================================================= */
+/* === AMD_2 =============================================================== */
+/* ========================================================================= */
+
+GLOBAL void AMD_2
+(
+ Int n, /* A is n-by-n, where n > 0 */
+ Int Pe [ ], /* Pe [0..n-1]: index in Iw of row i on input */
+ Int Iw [ ], /* workspace of size iwlen. Iw [0..pfree-1]
+ * holds the matrix on input */
+ Int Len [ ], /* Len [0..n-1]: length for row/column i on input */
+ Int iwlen, /* length of Iw. iwlen >= pfree + n */
+ Int pfree, /* Iw [pfree ... iwlen-1] is empty on input */
+
+ /* 7 size-n workspaces, not defined on input: */
+ Int Nv [ ], /* the size of each supernode on output */
+ Int Next [ ], /* the output inverse permutation */
+ Int Last [ ], /* the output permutation */
+ Int Head [ ],
+ Int Elen [ ], /* the size columns of L for each supernode */
+ Int Degree [ ],
+ Int W [ ],
+
+ /* control parameters and output statistics */
+ double Control [ ], /* array of size AMD_CONTROL */
+ double Info [ ] /* array of size AMD_INFO */
+)
+{
+
+/*
+ * Given a representation of the nonzero pattern of a symmetric matrix, A,
+ * (excluding the diagonal) perform an approximate minimum (UMFPACK/MA38-style)
+ * degree ordering to compute a pivot order such that the introduction of
+ * nonzeros (fill-in) in the Cholesky factors A = LL' is kept low. At each
+ * step, the pivot selected is the one with the minimum UMFAPACK/MA38-style
+ * upper-bound on the external degree. This routine can optionally perform
+ * aggresive absorption (as done by MC47B in the Harwell Subroutine
+ * Library).
+ *
+ * The approximate degree algorithm implemented here is the symmetric analog of
+ * the degree update algorithm in MA38 and UMFPACK (the Unsymmetric-pattern
+ * MultiFrontal PACKage, both by Davis and Duff). The routine is based on the
+ * MA27 minimum degree ordering algorithm by Iain Duff and John Reid.
+ *
+ * This routine is a translation of the original AMDBAR and MC47B routines,
+ * in Fortran, with the following modifications:
+ *
+ * (1) dense rows/columns are removed prior to ordering the matrix, and placed
+ * last in the output order. The presence of a dense row/column can
+ * increase the ordering time by up to O(n^2), unless they are removed
+ * prior to ordering.
+ *
+ * (2) the minimum degree ordering is followed by a postordering (depth-first
+ * search) of the assembly tree. Note that mass elimination (discussed
+ * below) combined with the approximate degree update can lead to the mass
+ * elimination of nodes with lower exact degree than the current pivot
+ * element. No additional fill-in is caused in the representation of the
+ * Schur complement. The mass-eliminated nodes merge with the current
+ * pivot element. They are ordered prior to the current pivot element.
+ * Because they can have lower exact degree than the current element, the
+ * merger of two or more of these nodes in the current pivot element can
+ * lead to a single element that is not a "fundamental supernode". The
+ * diagonal block can have zeros in it. Thus, the assembly tree used here
+ * is not guaranteed to be the precise supernodal elemination tree (with
+ * "funadmental" supernodes), and the postordering performed by this
+ * routine is not guaranteed to be a precise postordering of the
+ * elimination tree.
+ *
+ * (3) input parameters are added, to control aggressive absorption and the
+ * detection of "dense" rows/columns of A.
+ *
+ * (4) additional statistical information is returned, such as the number of
+ * nonzeros in L, and the flop counts for subsequent LDL' and LU
+ * factorizations. These are slight upper bounds, because of the mass
+ * elimination issue discussed above.
+ *
+ * (5) additional routines are added to interface this routine to MATLAB
+ * to provide a simple C-callable user-interface, to check inputs for
+ * errors, compute the symmetry of the pattern of A and the number of
+ * nonzeros in each row/column of A+A', to compute the pattern of A+A',
+ * to perform the assembly tree postordering, and to provide debugging
+ * ouput. Many of these functions are also provided by the Fortran
+ * Harwell Subroutine Library routine MC47A.
+ *
+ * (6) both int and UF_long versions are provided. In the descriptions below
+ * and integer is and int or UF_long depending on which version is
+ * being used.
+
+ **********************************************************************
+ ***** CAUTION: ARGUMENTS ARE NOT CHECKED FOR ERRORS ON INPUT. ******
+ **********************************************************************
+ ** If you want error checking, a more versatile input format, and a **
+ ** simpler user interface, use amd_order or amd_l_order instead. **
+ ** This routine is not meant to be user-callable. **
+ **********************************************************************
+
+ * ----------------------------------------------------------------------------
+ * References:
+ * ----------------------------------------------------------------------------
+ *
+ * [1] Timothy A. Davis and Iain Duff, "An unsymmetric-pattern multifrontal
+ * method for sparse LU factorization", SIAM J. Matrix Analysis and
+ * Applications, vol. 18, no. 1, pp. 140-158. Discusses UMFPACK / MA38,
+ * which first introduced the approximate minimum degree used by this
+ * routine.
+ *
+ * [2] Patrick Amestoy, Timothy A. Davis, and Iain S. Duff, "An approximate
+ * minimum degree ordering algorithm," SIAM J. Matrix Analysis and
+ * Applications, vol. 17, no. 4, pp. 886-905, 1996. Discusses AMDBAR and
+ * MC47B, which are the Fortran versions of this routine.
+ *
+ * [3] Alan George and Joseph Liu, "The evolution of the minimum degree
+ * ordering algorithm," SIAM Review, vol. 31, no. 1, pp. 1-19, 1989.
+ * We list below the features mentioned in that paper that this code
+ * includes:
+ *
+ * mass elimination:
+ * Yes. MA27 relied on supervariable detection for mass elimination.
+ *
+ * indistinguishable nodes:
+ * Yes (we call these "supervariables"). This was also in the MA27
+ * code - although we modified the method of detecting them (the
+ * previous hash was the true degree, which we no longer keep track
+ * of). A supervariable is a set of rows with identical nonzero
+ * pattern. All variables in a supervariable are eliminated together.
+ * Each supervariable has as its numerical name that of one of its
+ * variables (its principal variable).
+ *
+ * quotient graph representation:
+ * Yes. We use the term "element" for the cliques formed during
+ * elimination. This was also in the MA27 code. The algorithm can
+ * operate in place, but it will work more efficiently if given some
+ * "elbow room."
+ *
+ * element absorption:
+ * Yes. This was also in the MA27 code.
+ *
+ * external degree:
+ * Yes. The MA27 code was based on the true degree.
+ *
+ * incomplete degree update and multiple elimination:
+ * No. This was not in MA27, either. Our method of degree update
+ * within MC47B is element-based, not variable-based. It is thus
+ * not well-suited for use with incomplete degree update or multiple
+ * elimination.
+ *
+ * Authors, and Copyright (C) 2004 by:
+ * Timothy A. Davis, Patrick Amestoy, Iain S. Duff, John K. Reid.
+ *
+ * Acknowledgements: This work (and the UMFPACK package) was supported by the
+ * National Science Foundation (ASC-9111263, DMS-9223088, and CCR-0203270).
+ * The UMFPACK/MA38 approximate degree update algorithm, the unsymmetric analog
+ * which forms the basis of AMD, was developed while Tim Davis was supported by
+ * CERFACS (Toulouse, France) in a post-doctoral position. This C version, and
+ * the etree postorder, were written while Tim Davis was on sabbatical at
+ * Stanford University and Lawrence Berkeley National Laboratory.
+
+ * ----------------------------------------------------------------------------
+ * INPUT ARGUMENTS (unaltered):
+ * ----------------------------------------------------------------------------
+
+ * n: The matrix order. Restriction: n >= 1.
+ *
+ * iwlen: The size of the Iw array. On input, the matrix is stored in
+ * Iw [0..pfree-1]. However, Iw [0..iwlen-1] should be slightly larger
+ * than what is required to hold the matrix, at least iwlen >= pfree + n.
+ * Otherwise, excessive compressions will take place. The recommended
+ * value of iwlen is 1.2 * pfree + n, which is the value used in the
+ * user-callable interface to this routine (amd_order.c). The algorithm
+ * will not run at all if iwlen < pfree. Restriction: iwlen >= pfree + n.
+ * Note that this is slightly more restrictive than the actual minimum
+ * (iwlen >= pfree), but AMD_2 will be very slow with no elbow room.
+ * Thus, this routine enforces a bare minimum elbow room of size n.
+ *
+ * pfree: On input the tail end of the array, Iw [pfree..iwlen-1], is empty,
+ * and the matrix is stored in Iw [0..pfree-1]. During execution,
+ * additional data is placed in Iw, and pfree is modified so that
+ * Iw [pfree..iwlen-1] is always the unused part of Iw.
+ *
+ * Control: A double array of size AMD_CONTROL containing input parameters
+ * that affect how the ordering is computed. If NULL, then default
+ * settings are used.
+ *
+ * Control [AMD_DENSE] is used to determine whether or not a given input
+ * row is "dense". A row is "dense" if the number of entries in the row
+ * exceeds Control [AMD_DENSE] times sqrt (n), except that rows with 16 or
+ * fewer entries are never considered "dense". To turn off the detection
+ * of dense rows, set Control [AMD_DENSE] to a negative number, or to a
+ * number larger than sqrt (n). The default value of Control [AMD_DENSE]
+ * is AMD_DEFAULT_DENSE, which is defined in amd.h as 10.
+ *
+ * Control [AMD_AGGRESSIVE] is used to determine whether or not aggressive
+ * absorption is to be performed. If nonzero, then aggressive absorption
+ * is performed (this is the default).
+
+ * ----------------------------------------------------------------------------
+ * INPUT/OUPUT ARGUMENTS:
+ * ----------------------------------------------------------------------------
+ *
+ * Pe: An integer array of size n. On input, Pe [i] is the index in Iw of
+ * the start of row i. Pe [i] is ignored if row i has no off-diagonal
+ * entries. Thus Pe [i] must be in the range 0 to pfree-1 for non-empty
+ * rows.
+ *
+ * During execution, it is used for both supervariables and elements:
+ *
+ * Principal supervariable i: index into Iw of the description of
+ * supervariable i. A supervariable represents one or more rows of
+ * the matrix with identical nonzero pattern. In this case,
+ * Pe [i] >= 0.
+ *
+ * Non-principal supervariable i: if i has been absorbed into another
+ * supervariable j, then Pe [i] = FLIP (j), where FLIP (j) is defined
+ * as (-(j)-2). Row j has the same pattern as row i. Note that j
+ * might later be absorbed into another supervariable j2, in which
+ * case Pe [i] is still FLIP (j), and Pe [j] = FLIP (j2) which is
+ * < EMPTY, where EMPTY is defined as (-1) in amd_internal.h.
+ *
+ * Unabsorbed element e: the index into Iw of the description of element
+ * e, if e has not yet been absorbed by a subsequent element. Element
+ * e is created when the supervariable of the same name is selected as
+ * the pivot. In this case, Pe [i] >= 0.
+ *
+ * Absorbed element e: if element e is absorbed into element e2, then
+ * Pe [e] = FLIP (e2). This occurs when the pattern of e (which we
+ * refer to as Le) is found to be a subset of the pattern of e2 (that
+ * is, Le2). In this case, Pe [i] < EMPTY. If element e is "null"
+ * (it has no nonzeros outside its pivot block), then Pe [e] = EMPTY,
+ * and e is the root of an assembly subtree (or the whole tree if
+ * there is just one such root).
+ *
+ * Dense variable i: if i is "dense", then Pe [i] = EMPTY.
+ *
+ * On output, Pe holds the assembly tree/forest, which implicitly
+ * represents a pivot order with identical fill-in as the actual order
+ * (via a depth-first search of the tree), as follows. If Nv [i] > 0,
+ * then i represents a node in the assembly tree, and the parent of i is
+ * Pe [i], or EMPTY if i is a root. If Nv [i] = 0, then (i, Pe [i])
+ * represents an edge in a subtree, the root of which is a node in the
+ * assembly tree. Note that i refers to a row/column in the original
+ * matrix, not the permuted matrix.
+ *
+ * Info: A double array of size AMD_INFO. If present, (that is, not NULL),
+ * then statistics about the ordering are returned in the Info array.
+ * See amd.h for a description.
+
+ * ----------------------------------------------------------------------------
+ * INPUT/MODIFIED (undefined on output):
+ * ----------------------------------------------------------------------------
+ *
+ * Len: An integer array of size n. On input, Len [i] holds the number of
+ * entries in row i of the matrix, excluding the diagonal. The contents
+ * of Len are undefined on output.
+ *
+ * Iw: An integer array of size iwlen. On input, Iw [0..pfree-1] holds the
+ * description of each row i in the matrix. The matrix must be symmetric,
+ * and both upper and lower triangular parts must be present. The
+ * diagonal must not be present. Row i is held as follows:
+ *
+ * Len [i]: the length of the row i data structure in the Iw array.
+ * Iw [Pe [i] ... Pe [i] + Len [i] - 1]:
+ * the list of column indices for nonzeros in row i (simple
+ * supervariables), excluding the diagonal. All supervariables
+ * start with one row/column each (supervariable i is just row i).
+ * If Len [i] is zero on input, then Pe [i] is ignored on input.
+ *
+ * Note that the rows need not be in any particular order, and there
+ * may be empty space between the rows.
+ *
+ * During execution, the supervariable i experiences fill-in. This is
+ * represented by placing in i a list of the elements that cause fill-in
+ * in supervariable i:
+ *
+ * Len [i]: the length of supervariable i in the Iw array.
+ * Iw [Pe [i] ... Pe [i] + Elen [i] - 1]:
+ * the list of elements that contain i. This list is kept short
+ * by removing absorbed elements.
+ * Iw [Pe [i] + Elen [i] ... Pe [i] + Len [i] - 1]:
+ * the list of supervariables in i. This list is kept short by
+ * removing nonprincipal variables, and any entry j that is also
+ * contained in at least one of the elements (j in Le) in the list
+ * for i (e in row i).
+ *
+ * When supervariable i is selected as pivot, we create an element e of
+ * the same name (e=i):
+ *
+ * Len [e]: the length of element e in the Iw array.
+ * Iw [Pe [e] ... Pe [e] + Len [e] - 1]:
+ * the list of supervariables in element e.
+ *
+ * An element represents the fill-in that occurs when supervariable i is
+ * selected as pivot (which represents the selection of row i and all
+ * non-principal variables whose principal variable is i). We use the
+ * term Le to denote the set of all supervariables in element e. Absorbed
+ * supervariables and elements are pruned from these lists when
+ * computationally convenient.
+ *
+ * CAUTION: THE INPUT MATRIX IS OVERWRITTEN DURING COMPUTATION.
+ * The contents of Iw are undefined on output.
+
+ * ----------------------------------------------------------------------------
+ * OUTPUT (need not be set on input):
+ * ----------------------------------------------------------------------------
+ *
+ * Nv: An integer array of size n. During execution, ABS (Nv [i]) is equal to
+ * the number of rows that are represented by the principal supervariable
+ * i. If i is a nonprincipal or dense variable, then Nv [i] = 0.
+ * Initially, Nv [i] = 1 for all i. Nv [i] < 0 signifies that i is a
+ * principal variable in the pattern Lme of the current pivot element me.
+ * After element me is constructed, Nv [i] is set back to a positive
+ * value.
+ *
+ * On output, Nv [i] holds the number of pivots represented by super
+ * row/column i of the original matrix, or Nv [i] = 0 for non-principal
+ * rows/columns. Note that i refers to a row/column in the original
+ * matrix, not the permuted matrix.
+ *
+ * Elen: An integer array of size n. See the description of Iw above. At the
+ * start of execution, Elen [i] is set to zero for all rows i. During
+ * execution, Elen [i] is the number of elements in the list for
+ * supervariable i. When e becomes an element, Elen [e] = FLIP (esize) is
+ * set, where esize is the size of the element (the number of pivots, plus
+ * the number of nonpivotal entries). Thus Elen [e] < EMPTY.
+ * Elen (i) = EMPTY set when variable i becomes nonprincipal.
+ *
+ * For variables, Elen (i) >= EMPTY holds until just before the
+ * postordering and permutation vectors are computed. For elements,
+ * Elen [e] < EMPTY holds.
+ *
+ * On output, Elen [i] is the degree of the row/column in the Cholesky
+ * factorization of the permuted matrix, corresponding to the original row
+ * i, if i is a super row/column. It is equal to EMPTY if i is
+ * non-principal. Note that i refers to a row/column in the original
+ * matrix, not the permuted matrix.
+ *
+ * Note that the contents of Elen on output differ from the Fortran
+ * version (Elen holds the inverse permutation in the Fortran version,
+ * which is instead returned in the Next array in this C version,
+ * described below).
+ *
+ * Last: In a degree list, Last [i] is the supervariable preceding i, or EMPTY
+ * if i is the head of the list. In a hash bucket, Last [i] is the hash
+ * key for i.
+ *
+ * Last [Head [hash]] is also used as the head of a hash bucket if
+ * Head [hash] contains a degree list (see the description of Head,
+ * below).
+ *
+ * On output, Last [0..n-1] holds the permutation. That is, if
+ * i = Last [k], then row i is the kth pivot row (where k ranges from 0 to
+ * n-1). Row Last [k] of A is the kth row in the permuted matrix, PAP'.
+ *
+ * Next: Next [i] is the supervariable following i in a link list, or EMPTY if
+ * i is the last in the list. Used for two kinds of lists: degree lists
+ * and hash buckets (a supervariable can be in only one kind of list at a
+ * time).
+ *
+ * On output Next [0..n-1] holds the inverse permutation. That is, if
+ * k = Next [i], then row i is the kth pivot row. Row i of A appears as
+ * the (Next[i])-th row in the permuted matrix, PAP'.
+ *
+ * Note that the contents of Next on output differ from the Fortran
+ * version (Next is undefined on output in the Fortran version).
+
+ * ----------------------------------------------------------------------------
+ * LOCAL WORKSPACE (not input or output - used only during execution):
+ * ----------------------------------------------------------------------------
+ *
+ * Degree: An integer array of size n. If i is a supervariable, then
+ * Degree [i] holds the current approximation of the external degree of
+ * row i (an upper bound). The external degree is the number of nonzeros
+ * in row i, minus ABS (Nv [i]), the diagonal part. The bound is equal to
+ * the exact external degree if Elen [i] is less than or equal to two.
+ *
+ * We also use the term "external degree" for elements e to refer to
+ * |Le \ Lme|. If e is an element, then Degree [e] is |Le|, which is the
+ * degree of the off-diagonal part of the element e (not including the
+ * diagonal part).
+ *
+ * Head: An integer array of size n. Head is used for degree lists.
+ * Head [deg] is the first supervariable in a degree list. All
+ * supervariables i in a degree list Head [deg] have the same approximate
+ * degree, namely, deg = Degree [i]. If the list Head [deg] is empty then
+ * Head [deg] = EMPTY.
+ *
+ * During supervariable detection Head [hash] also serves as a pointer to
+ * a hash bucket. If Head [hash] >= 0, there is a degree list of degree
+ * hash. The hash bucket head pointer is Last [Head [hash]]. If
+ * Head [hash] = EMPTY, then the degree list and hash bucket are both
+ * empty. If Head [hash] < EMPTY, then the degree list is empty, and
+ * FLIP (Head [hash]) is the head of the hash bucket. After supervariable
+ * detection is complete, all hash buckets are empty, and the
+ * (Last [Head [hash]] = EMPTY) condition is restored for the non-empty
+ * degree lists.
+ *
+ * W: An integer array of size n. The flag array W determines the status of
+ * elements and variables, and the external degree of elements.
+ *
+ * for elements:
+ * if W [e] = 0, then the element e is absorbed.
+ * if W [e] >= wflg, then W [e] - wflg is the size of the set
+ * |Le \ Lme|, in terms of nonzeros (the sum of ABS (Nv [i]) for
+ * each principal variable i that is both in the pattern of
+ * element e and NOT in the pattern of the current pivot element,
+ * me).
+ * if wflg > W [e] > 0, then e is not absorbed and has not yet been
+ * seen in the scan of the element lists in the computation of
+ * |Le\Lme| in Scan 1 below.
+ *
+ * for variables:
+ * during supervariable detection, if W [j] != wflg then j is
+ * not in the pattern of variable i.
+ *
+ * The W array is initialized by setting W [i] = 1 for all i, and by
+ * setting wflg = 2. It is reinitialized if wflg becomes too large (to
+ * ensure that wflg+n does not cause integer overflow).
+
+ * ----------------------------------------------------------------------------
+ * LOCAL INTEGERS:
+ * ----------------------------------------------------------------------------
+ */
+
+ Int deg, degme, dext, lemax, e, elenme, eln, i, ilast, inext, j,
+ jlast, jnext, k, knt1, knt2, knt3, lenj, ln, me, mindeg, nel, nleft,
+ nvi, nvj, nvpiv, slenme, wbig, we, wflg, wnvi, ok, ndense, ncmpa,
+ dense, aggressive ;
+
+ unsigned Int hash ; /* unsigned, so that hash % n is well defined.*/
+
+/*
+ * deg: the degree of a variable or element
+ * degme: size, |Lme|, of the current element, me (= Degree [me])
+ * dext: external degree, |Le \ Lme|, of some element e
+ * lemax: largest |Le| seen so far (called dmax in Fortran version)
+ * e: an element
+ * elenme: the length, Elen [me], of element list of pivotal variable
+ * eln: the length, Elen [...], of an element list
+ * hash: the computed value of the hash function
+ * i: a supervariable
+ * ilast: the entry in a link list preceding i
+ * inext: the entry in a link list following i
+ * j: a supervariable
+ * jlast: the entry in a link list preceding j
+ * jnext: the entry in a link list, or path, following j
+ * k: the pivot order of an element or variable
+ * knt1: loop counter used during element construction
+ * knt2: loop counter used during element construction
+ * knt3: loop counter used during compression
+ * lenj: Len [j]
+ * ln: length of a supervariable list
+ * me: current supervariable being eliminated, and the current
+ * element created by eliminating that supervariable
+ * mindeg: current minimum degree
+ * nel: number of pivots selected so far
+ * nleft: n - nel, the number of nonpivotal rows/columns remaining
+ * nvi: the number of variables in a supervariable i (= Nv [i])
+ * nvj: the number of variables in a supervariable j (= Nv [j])
+ * nvpiv: number of pivots in current element
+ * slenme: number of variables in variable list of pivotal variable
+ * wbig: = INT_MAX - n for the int version, UF_long_max - n for the
+ * UF_long version. wflg is not allowed to be >= wbig.
+ * we: W [e]
+ * wflg: used for flagging the W array. See description of Iw.
+ * wnvi: wflg - Nv [i]
+ * x: either a supervariable or an element
+ *
+ * ok: true if supervariable j can be absorbed into i
+ * ndense: number of "dense" rows/columns
+ * dense: rows/columns with initial degree > dense are considered "dense"
+ * aggressive: true if aggressive absorption is being performed
+ * ncmpa: number of garbage collections
+
+ * ----------------------------------------------------------------------------
+ * LOCAL DOUBLES, used for statistical output only (except for alpha):
+ * ----------------------------------------------------------------------------
+ */
+
+ double f, r, ndiv, s, nms_lu, nms_ldl, dmax, alpha, lnz, lnzme ;
+
+/*
+ * f: nvpiv
+ * r: degme + nvpiv
+ * ndiv: number of divisions for LU or LDL' factorizations
+ * s: number of multiply-subtract pairs for LU factorization, for the
+ * current element me
+ * nms_lu number of multiply-subtract pairs for LU factorization
+ * nms_ldl number of multiply-subtract pairs for LDL' factorization
+ * dmax: the largest number of entries in any column of L, including the
+ * diagonal
+ * alpha: "dense" degree ratio
+ * lnz: the number of nonzeros in L (excluding the diagonal)
+ * lnzme: the number of nonzeros in L (excl. the diagonal) for the
+ * current element me
+
+ * ----------------------------------------------------------------------------
+ * LOCAL "POINTERS" (indices into the Iw array)
+ * ----------------------------------------------------------------------------
+*/
+
+ Int p, p1, p2, p3, p4, pdst, pend, pj, pme, pme1, pme2, pn, psrc ;
+
+/*
+ * Any parameter (Pe [...] or pfree) or local variable starting with "p" (for
+ * Pointer) is an index into Iw, and all indices into Iw use variables starting
+ * with "p." The only exception to this rule is the iwlen input argument.
+ *
+ * p: pointer into lots of things
+ * p1: Pe [i] for some variable i (start of element list)
+ * p2: Pe [i] + Elen [i] - 1 for some variable i
+ * p3: index of first supervariable in clean list
+ * p4:
+ * pdst: destination pointer, for compression
+ * pend: end of memory to compress
+ * pj: pointer into an element or variable
+ * pme: pointer into the current element (pme1...pme2)
+ * pme1: the current element, me, is stored in Iw [pme1...pme2]
+ * pme2: the end of the current element
+ * pn: pointer into a "clean" variable, also used to compress
+ * psrc: source pointer, for compression
+*/
+
+/* ========================================================================= */
+/* INITIALIZATIONS */
+/* ========================================================================= */
+
+ /* Note that this restriction on iwlen is slightly more restrictive than
+ * what is actually required in AMD_2. AMD_2 can operate with no elbow
+ * room at all, but it will be slow. For better performance, at least
+ * size-n elbow room is enforced. */
+ ASSERT (iwlen >= pfree + n) ;
+ ASSERT (n > 0) ;
+
+ /* initialize output statistics */
+ lnz = 0 ;
+ ndiv = 0 ;
+ nms_lu = 0 ;
+ nms_ldl = 0 ;
+ dmax = 1 ;
+ me = EMPTY ;
+
+ mindeg = 0 ;
+ ncmpa = 0 ;
+ nel = 0 ;
+ lemax = 0 ;
+
+ /* get control parameters */
+ if (Control != (double *) NULL)
+ {
+ alpha = Control [AMD_DENSE] ;
+ aggressive = (Control [AMD_AGGRESSIVE] != 0) ;
+ }
+ else
+ {
+ alpha = AMD_DEFAULT_DENSE ;
+ aggressive = AMD_DEFAULT_AGGRESSIVE ;
+ }
+ /* Note: if alpha is NaN, this is undefined: */
+ if (alpha < 0)
+ {
+ /* only remove completely dense rows/columns */
+ dense = n-2 ;
+ }
+ else
+ {
+ dense = alpha * sqrt ((double) n) ;
+ }
+ dense = MAX (16, dense) ;
+ dense = MIN (n, dense) ;
+ AMD_DEBUG1 (("\n\nAMD (debug), alpha %g, aggr. "ID"\n",
+ alpha, aggressive)) ;
+
+ for (i = 0 ; i < n ; i++)
+ {
+ Last [i] = EMPTY ;
+ Head [i] = EMPTY ;
+ Next [i] = EMPTY ;
+ /* if separate Hhead array is used for hash buckets: *
+ Hhead [i] = EMPTY ;
+ */
+ Nv [i] = 1 ;
+ W [i] = 1 ;
+ Elen [i] = 0 ;
+ Degree [i] = Len [i] ;
+ }
+
+#ifndef NDEBUG
+ AMD_DEBUG1 (("\n======Nel "ID" initial\n", nel)) ;
+ AMD_dump (n, Pe, Iw, Len, iwlen, pfree, Nv, Next, Last,
+ Head, Elen, Degree, W, -1) ;
+#endif
+
+ /* initialize wflg */
+ wbig = Int_MAX - n ;
+ wflg = clear_flag (0, wbig, W, n) ;
+
+ /* --------------------------------------------------------------------- */
+ /* initialize degree lists and eliminate dense and empty rows */
+ /* --------------------------------------------------------------------- */
+
+ ndense = 0 ;
+
+ for (i = 0 ; i < n ; i++)
+ {
+ deg = Degree [i] ;
+ ASSERT (deg >= 0 && deg < n) ;
+ if (deg == 0)
+ {
+
+ /* -------------------------------------------------------------
+ * we have a variable that can be eliminated at once because
+ * there is no off-diagonal non-zero in its row. Note that
+ * Nv [i] = 1 for an empty variable i. It is treated just
+ * the same as an eliminated element i.
+ * ------------------------------------------------------------- */
+
+ Elen [i] = FLIP (1) ;
+ nel++ ;
+ Pe [i] = EMPTY ;
+ W [i] = 0 ;
+
+ }
+ else if (deg > dense)
+ {
+
+ /* -------------------------------------------------------------
+ * Dense variables are not treated as elements, but as unordered,
+ * non-principal variables that have no parent. They do not take
+ * part in the postorder, since Nv [i] = 0. Note that the Fortran
+ * version does not have this option.
+ * ------------------------------------------------------------- */
+
+ AMD_DEBUG1 (("Dense node "ID" degree "ID"\n", i, deg)) ;
+ ndense++ ;
+ Nv [i] = 0 ; /* do not postorder this node */
+ Elen [i] = EMPTY ;
+ nel++ ;
+ Pe [i] = EMPTY ;
+
+ }
+ else
+ {
+
+ /* -------------------------------------------------------------
+ * place i in the degree list corresponding to its degree
+ * ------------------------------------------------------------- */
+
+ inext = Head [deg] ;
+ ASSERT (inext >= EMPTY && inext < n) ;
+ if (inext != EMPTY) Last [inext] = i ;
+ Next [i] = inext ;
+ Head [deg] = i ;
+
+ }
+ }
+
+/* ========================================================================= */
+/* WHILE (selecting pivots) DO */
+/* ========================================================================= */
+
+ while (nel < n)
+ {
+
+#ifndef NDEBUG
+ AMD_DEBUG1 (("\n======Nel "ID"\n", nel)) ;
+ if (AMD_debug >= 2)
+ {
+ AMD_dump (n, Pe, Iw, Len, iwlen, pfree, Nv, Next,
+ Last, Head, Elen, Degree, W, nel) ;
+ }
+#endif
+
+/* ========================================================================= */
+/* GET PIVOT OF MINIMUM DEGREE */
+/* ========================================================================= */
+
+ /* ----------------------------------------------------------------- */
+ /* find next supervariable for elimination */
+ /* ----------------------------------------------------------------- */
+
+ ASSERT (mindeg >= 0 && mindeg < n) ;
+ for (deg = mindeg ; deg < n ; deg++)
+ {
+ me = Head [deg] ;
+ if (me != EMPTY) break ;
+ }
+ mindeg = deg ;
+ ASSERT (me >= 0 && me < n) ;
+ AMD_DEBUG1 (("=================me: "ID"\n", me)) ;
+
+ /* ----------------------------------------------------------------- */
+ /* remove chosen variable from link list */
+ /* ----------------------------------------------------------------- */
+
+ inext = Next [me] ;
+ ASSERT (inext >= EMPTY && inext < n) ;
+ if (inext != EMPTY) Last [inext] = EMPTY ;
+ Head [deg] = inext ;
+
+ /* ----------------------------------------------------------------- */
+ /* me represents the elimination of pivots nel to nel+Nv[me]-1. */
+ /* place me itself as the first in this set. */
+ /* ----------------------------------------------------------------- */
+
+ elenme = Elen [me] ;
+ nvpiv = Nv [me] ;
+ ASSERT (nvpiv > 0) ;
+ nel += nvpiv ;
+
+/* ========================================================================= */
+/* CONSTRUCT NEW ELEMENT */
+/* ========================================================================= */
+
+ /* -----------------------------------------------------------------
+ * At this point, me is the pivotal supervariable. It will be
+ * converted into the current element. Scan list of the pivotal
+ * supervariable, me, setting tree pointers and constructing new list
+ * of supervariables for the new element, me. p is a pointer to the
+ * current position in the old list.
+ * ----------------------------------------------------------------- */
+
+ /* flag the variable "me" as being in Lme by negating Nv [me] */
+ Nv [me] = -nvpiv ;
+ degme = 0 ;
+ ASSERT (Pe [me] >= 0 && Pe [me] < iwlen) ;
+
+ if (elenme == 0)
+ {
+
+ /* ------------------------------------------------------------- */
+ /* construct the new element in place */
+ /* ------------------------------------------------------------- */
+
+ pme1 = Pe [me] ;
+ pme2 = pme1 - 1 ;
+
+ for (p = pme1 ; p <= pme1 + Len [me] - 1 ; p++)
+ {
+ i = Iw [p] ;
+ ASSERT (i >= 0 && i < n && Nv [i] >= 0) ;
+ nvi = Nv [i] ;
+ if (nvi > 0)
+ {
+
+ /* ----------------------------------------------------- */
+ /* i is a principal variable not yet placed in Lme. */
+ /* store i in new list */
+ /* ----------------------------------------------------- */
+
+ /* flag i as being in Lme by negating Nv [i] */
+ degme += nvi ;
+ Nv [i] = -nvi ;
+ Iw [++pme2] = i ;
+
+ /* ----------------------------------------------------- */
+ /* remove variable i from degree list. */
+ /* ----------------------------------------------------- */
+
+ ilast = Last [i] ;
+ inext = Next [i] ;
+ ASSERT (ilast >= EMPTY && ilast < n) ;
+ ASSERT (inext >= EMPTY && inext < n) ;
+ if (inext != EMPTY) Last [inext] = ilast ;
+ if (ilast != EMPTY)
+ {
+ Next [ilast] = inext ;
+ }
+ else
+ {
+ /* i is at the head of the degree list */
+ ASSERT (Degree [i] >= 0 && Degree [i] < n) ;
+ Head [Degree [i]] = inext ;
+ }
+ }
+ }
+ }
+ else
+ {
+
+ /* ------------------------------------------------------------- */
+ /* construct the new element in empty space, Iw [pfree ...] */
+ /* ------------------------------------------------------------- */
+
+ p = Pe [me] ;
+ pme1 = pfree ;
+ slenme = Len [me] - elenme ;
+
+ for (knt1 = 1 ; knt1 <= elenme + 1 ; knt1++)
+ {
+
+ if (knt1 > elenme)
+ {
+ /* search the supervariables in me. */
+ e = me ;
+ pj = p ;
+ ln = slenme ;
+ AMD_DEBUG2 (("Search sv: "ID" "ID" "ID"\n", me,pj,ln)) ;
+ }
+ else
+ {
+ /* search the elements in me. */
+ e = Iw [p++] ;
+ ASSERT (e >= 0 && e < n) ;
+ pj = Pe [e] ;
+ ln = Len [e] ;
+ AMD_DEBUG2 (("Search element e "ID" in me "ID"\n", e,me)) ;
+ ASSERT (Elen [e] < EMPTY && W [e] > 0 && pj >= 0) ;
+ }
+ ASSERT (ln >= 0 && (ln == 0 || (pj >= 0 && pj < iwlen))) ;
+
+ /* ---------------------------------------------------------
+ * search for different supervariables and add them to the
+ * new list, compressing when necessary. this loop is
+ * executed once for each element in the list and once for
+ * all the supervariables in the list.
+ * --------------------------------------------------------- */
+
+ for (knt2 = 1 ; knt2 <= ln ; knt2++)
+ {
+ i = Iw [pj++] ;
+ ASSERT (i >= 0 && i < n && (i == me || Elen [i] >= EMPTY));
+ nvi = Nv [i] ;
+ AMD_DEBUG2 ((": "ID" "ID" "ID" "ID"\n",
+ i, Elen [i], Nv [i], wflg)) ;
+
+ if (nvi > 0)
+ {
+
+ /* ------------------------------------------------- */
+ /* compress Iw, if necessary */
+ /* ------------------------------------------------- */
+
+ if (pfree >= iwlen)
+ {
+
+ AMD_DEBUG1 (("GARBAGE COLLECTION\n")) ;
+
+ /* prepare for compressing Iw by adjusting pointers
+ * and lengths so that the lists being searched in
+ * the inner and outer loops contain only the
+ * remaining entries. */
+
+ Pe [me] = p ;
+ Len [me] -= knt1 ;
+ /* check if nothing left of supervariable me */
+ if (Len [me] == 0) Pe [me] = EMPTY ;
+ Pe [e] = pj ;
+ Len [e] = ln - knt2 ;
+ /* nothing left of element e */
+ if (Len [e] == 0) Pe [e] = EMPTY ;
+
+ ncmpa++ ; /* one more garbage collection */
+
+ /* store first entry of each object in Pe */
+ /* FLIP the first entry in each object */
+ for (j = 0 ; j < n ; j++)
+ {
+ pn = Pe [j] ;
+ if (pn >= 0)
+ {
+ ASSERT (pn >= 0 && pn < iwlen) ;
+ Pe [j] = Iw [pn] ;
+ Iw [pn] = FLIP (j) ;
+ }
+ }
+
+ /* psrc/pdst point to source/destination */
+ psrc = 0 ;
+ pdst = 0 ;
+ pend = pme1 - 1 ;
+
+ while (psrc <= pend)
+ {
+ /* search for next FLIP'd entry */
+ j = FLIP (Iw [psrc++]) ;
+ if (j >= 0)
+ {
+ AMD_DEBUG2 (("Got object j: "ID"\n", j)) ;
+ Iw [pdst] = Pe [j] ;
+ Pe [j] = pdst++ ;
+ lenj = Len [j] ;
+ /* copy from source to destination */
+ for (knt3 = 0 ; knt3 <= lenj - 2 ; knt3++)
+ {
+ Iw [pdst++] = Iw [psrc++] ;
+ }
+ }
+ }
+
+ /* move the new partially-constructed element */
+ p1 = pdst ;
+ for (psrc = pme1 ; psrc <= pfree-1 ; psrc++)
+ {
+ Iw [pdst++] = Iw [psrc] ;
+ }
+ pme1 = p1 ;
+ pfree = pdst ;
+ pj = Pe [e] ;
+ p = Pe [me] ;
+
+ }
+
+ /* ------------------------------------------------- */
+ /* i is a principal variable not yet placed in Lme */
+ /* store i in new list */
+ /* ------------------------------------------------- */
+
+ /* flag i as being in Lme by negating Nv [i] */
+ degme += nvi ;
+ Nv [i] = -nvi ;
+ Iw [pfree++] = i ;
+ AMD_DEBUG2 ((" s: "ID" nv "ID"\n", i, Nv [i]));
+
+ /* ------------------------------------------------- */
+ /* remove variable i from degree link list */
+ /* ------------------------------------------------- */
+
+ ilast = Last [i] ;
+ inext = Next [i] ;
+ ASSERT (ilast >= EMPTY && ilast < n) ;
+ ASSERT (inext >= EMPTY && inext < n) ;
+ if (inext != EMPTY) Last [inext] = ilast ;
+ if (ilast != EMPTY)
+ {
+ Next [ilast] = inext ;
+ }
+ else
+ {
+ /* i is at the head of the degree list */
+ ASSERT (Degree [i] >= 0 && Degree [i] < n) ;
+ Head [Degree [i]] = inext ;
+ }
+ }
+ }
+
+ if (e != me)
+ {
+ /* set tree pointer and flag to indicate element e is
+ * absorbed into new element me (the parent of e is me) */
+ AMD_DEBUG1 ((" Element "ID" => "ID"\n", e, me)) ;
+ Pe [e] = FLIP (me) ;
+ W [e] = 0 ;
+ }
+ }
+
+ pme2 = pfree - 1 ;
+ }
+
+ /* ----------------------------------------------------------------- */
+ /* me has now been converted into an element in Iw [pme1..pme2] */
+ /* ----------------------------------------------------------------- */
+
+ /* degme holds the external degree of new element */
+ Degree [me] = degme ;
+ Pe [me] = pme1 ;
+ Len [me] = pme2 - pme1 + 1 ;
+ ASSERT (Pe [me] >= 0 && Pe [me] < iwlen) ;
+
+ Elen [me] = FLIP (nvpiv + degme) ;
+ /* FLIP (Elen (me)) is now the degree of pivot (including
+ * diagonal part). */
+
+#ifndef NDEBUG
+ AMD_DEBUG2 (("New element structure: length= "ID"\n", pme2-pme1+1)) ;
+ for (pme = pme1 ; pme <= pme2 ; pme++) AMD_DEBUG3 ((" "ID"", Iw[pme]));
+ AMD_DEBUG3 (("\n")) ;
+#endif
+
+ /* ----------------------------------------------------------------- */
+ /* make sure that wflg is not too large. */
+ /* ----------------------------------------------------------------- */
+
+ /* With the current value of wflg, wflg+n must not cause integer
+ * overflow */
+
+ wflg = clear_flag (wflg, wbig, W, n) ;
+
+/* ========================================================================= */
+/* COMPUTE (W [e] - wflg) = |Le\Lme| FOR ALL ELEMENTS */
+/* ========================================================================= */
+
+ /* -----------------------------------------------------------------
+ * Scan 1: compute the external degrees of previous elements with
+ * respect to the current element. That is:
+ * (W [e] - wflg) = |Le \ Lme|
+ * for each element e that appears in any supervariable in Lme. The
+ * notation Le refers to the pattern (list of supervariables) of a
+ * previous element e, where e is not yet absorbed, stored in
+ * Iw [Pe [e] + 1 ... Pe [e] + Len [e]]. The notation Lme
+ * refers to the pattern of the current element (stored in
+ * Iw [pme1..pme2]). If aggressive absorption is enabled, and
+ * (W [e] - wflg) becomes zero, then the element e will be absorbed
+ * in Scan 2.
+ * ----------------------------------------------------------------- */
+
+ AMD_DEBUG2 (("me: ")) ;
+ for (pme = pme1 ; pme <= pme2 ; pme++)
+ {
+ i = Iw [pme] ;
+ ASSERT (i >= 0 && i < n) ;
+ eln = Elen [i] ;
+ AMD_DEBUG3 ((""ID" Elen "ID": \n", i, eln)) ;
+ if (eln > 0)
+ {
+ /* note that Nv [i] has been negated to denote i in Lme: */
+ nvi = -Nv [i] ;
+ ASSERT (nvi > 0 && Pe [i] >= 0 && Pe [i] < iwlen) ;
+ wnvi = wflg - nvi ;
+ for (p = Pe [i] ; p <= Pe [i] + eln - 1 ; p++)
+ {
+ e = Iw [p] ;
+ ASSERT (e >= 0 && e < n) ;
+ we = W [e] ;
+ AMD_DEBUG4 ((" e "ID" we "ID" ", e, we)) ;
+ if (we >= wflg)
+ {
+ /* unabsorbed element e has been seen in this loop */
+ AMD_DEBUG4 ((" unabsorbed, first time seen")) ;
+ we -= nvi ;
+ }
+ else if (we != 0)
+ {
+ /* e is an unabsorbed element */
+ /* this is the first we have seen e in all of Scan 1 */
+ AMD_DEBUG4 ((" unabsorbed")) ;
+ we = Degree [e] + wnvi ;
+ }
+ AMD_DEBUG4 (("\n")) ;
+ W [e] = we ;
+ }
+ }
+ }
+ AMD_DEBUG2 (("\n")) ;
+
+/* ========================================================================= */
+/* DEGREE UPDATE AND ELEMENT ABSORPTION */
+/* ========================================================================= */
+
+ /* -----------------------------------------------------------------
+ * Scan 2: for each i in Lme, sum up the degree of Lme (which is
+ * degme), plus the sum of the external degrees of each Le for the
+ * elements e appearing within i, plus the supervariables in i.
+ * Place i in hash list.
+ * ----------------------------------------------------------------- */
+
+ for (pme = pme1 ; pme <= pme2 ; pme++)
+ {
+ i = Iw [pme] ;
+ ASSERT (i >= 0 && i < n && Nv [i] < 0 && Elen [i] >= 0) ;
+ AMD_DEBUG2 (("Updating: i "ID" "ID" "ID"\n", i, Elen[i], Len [i]));
+ p1 = Pe [i] ;
+ p2 = p1 + Elen [i] - 1 ;
+ pn = p1 ;
+ hash = 0 ;
+ deg = 0 ;
+ ASSERT (p1 >= 0 && p1 < iwlen && p2 >= -1 && p2 < iwlen) ;
+
+ /* ------------------------------------------------------------- */
+ /* scan the element list associated with supervariable i */
+ /* ------------------------------------------------------------- */
+
+ /* UMFPACK/MA38-style approximate degree: */
+ if (aggressive)
+ {
+ for (p = p1 ; p <= p2 ; p++)
+ {
+ e = Iw [p] ;
+ ASSERT (e >= 0 && e < n) ;
+ we = W [e] ;
+ if (we != 0)
+ {
+ /* e is an unabsorbed element */
+ /* dext = | Le \ Lme | */
+ dext = we - wflg ;
+ if (dext > 0)
+ {
+ deg += dext ;
+ Iw [pn++] = e ;
+ hash += e ;
+ AMD_DEBUG4 ((" e: "ID" hash = "ID"\n",e,hash)) ;
+ }
+ else
+ {
+ /* external degree of e is zero, absorb e into me*/
+ AMD_DEBUG1 ((" Element "ID" =>"ID" (aggressive)\n",
+ e, me)) ;
+ ASSERT (dext == 0) ;
+ Pe [e] = FLIP (me) ;
+ W [e] = 0 ;
+ }
+ }
+ }
+ }
+ else
+ {
+ for (p = p1 ; p <= p2 ; p++)
+ {
+ e = Iw [p] ;
+ ASSERT (e >= 0 && e < n) ;
+ we = W [e] ;
+ if (we != 0)
+ {
+ /* e is an unabsorbed element */
+ dext = we - wflg ;
+ ASSERT (dext >= 0) ;
+ deg += dext ;
+ Iw [pn++] = e ;
+ hash += e ;
+ AMD_DEBUG4 ((" e: "ID" hash = "ID"\n",e,hash)) ;
+ }
+ }
+ }
+
+ /* count the number of elements in i (including me): */
+ Elen [i] = pn - p1 + 1 ;
+
+ /* ------------------------------------------------------------- */
+ /* scan the supervariables in the list associated with i */
+ /* ------------------------------------------------------------- */
+
+ /* The bulk of the AMD run time is typically spent in this loop,
+ * particularly if the matrix has many dense rows that are not
+ * removed prior to ordering. */
+ p3 = pn ;
+ p4 = p1 + Len [i] ;
+ for (p = p2 + 1 ; p < p4 ; p++)
+ {
+ j = Iw [p] ;
+ ASSERT (j >= 0 && j < n) ;
+ nvj = Nv [j] ;
+ if (nvj > 0)
+ {
+ /* j is unabsorbed, and not in Lme. */
+ /* add to degree and add to new list */
+ deg += nvj ;
+ Iw [pn++] = j ;
+ hash += j ;
+ AMD_DEBUG4 ((" s: "ID" hash "ID" Nv[j]= "ID"\n",
+ j, hash, nvj)) ;
+ }
+ }
+
+ /* ------------------------------------------------------------- */
+ /* update the degree and check for mass elimination */
+ /* ------------------------------------------------------------- */
+
+ /* with aggressive absorption, deg==0 is identical to the
+ * Elen [i] == 1 && p3 == pn test, below. */
+ ASSERT (IMPLIES (aggressive, (deg==0) == (Elen[i]==1 && p3==pn))) ;
+
+ if (Elen [i] == 1 && p3 == pn)
+ {
+
+ /* --------------------------------------------------------- */
+ /* mass elimination */
+ /* --------------------------------------------------------- */
+
+ /* There is nothing left of this node except for an edge to
+ * the current pivot element. Elen [i] is 1, and there are
+ * no variables adjacent to node i. Absorb i into the
+ * current pivot element, me. Note that if there are two or
+ * more mass eliminations, fillin due to mass elimination is
+ * possible within the nvpiv-by-nvpiv pivot block. It is this
+ * step that causes AMD's analysis to be an upper bound.
+ *
+ * The reason is that the selected pivot has a lower
+ * approximate degree than the true degree of the two mass
+ * eliminated nodes. There is no edge between the two mass
+ * eliminated nodes. They are merged with the current pivot
+ * anyway.
+ *
+ * No fillin occurs in the Schur complement, in any case,
+ * and this effect does not decrease the quality of the
+ * ordering itself, just the quality of the nonzero and
+ * flop count analysis. It also means that the post-ordering
+ * is not an exact elimination tree post-ordering. */
+
+ AMD_DEBUG1 ((" MASS i "ID" => parent e "ID"\n", i, me)) ;
+ Pe [i] = FLIP (me) ;
+ nvi = -Nv [i] ;
+ degme -= nvi ;
+ nvpiv += nvi ;
+ nel += nvi ;
+ Nv [i] = 0 ;
+ Elen [i] = EMPTY ;
+
+ }
+ else
+ {
+
+ /* --------------------------------------------------------- */
+ /* update the upper-bound degree of i */
+ /* --------------------------------------------------------- */
+
+ /* the following degree does not yet include the size
+ * of the current element, which is added later: */
+
+ Degree [i] = MIN (Degree [i], deg) ;
+
+ /* --------------------------------------------------------- */
+ /* add me to the list for i */
+ /* --------------------------------------------------------- */
+
+ /* move first supervariable to end of list */
+ Iw [pn] = Iw [p3] ;
+ /* move first element to end of element part of list */
+ Iw [p3] = Iw [p1] ;
+ /* add new element, me, to front of list. */
+ Iw [p1] = me ;
+ /* store the new length of the list in Len [i] */
+ Len [i] = pn - p1 + 1 ;
+
+ /* --------------------------------------------------------- */
+ /* place in hash bucket. Save hash key of i in Last [i]. */
+ /* --------------------------------------------------------- */
+
+ /* NOTE: this can fail if hash is negative, because the ANSI C
+ * standard does not define a % b when a and/or b are negative.
+ * That's why hash is defined as an unsigned Int, to avoid this
+ * problem. */
+ hash = hash % n ;
+ ASSERT (((Int) hash) >= 0 && ((Int) hash) < n) ;
+
+ /* if the Hhead array is not used: */
+ j = Head [hash] ;
+ if (j <= EMPTY)
+ {
+ /* degree list is empty, hash head is FLIP (j) */
+ Next [i] = FLIP (j) ;
+ Head [hash] = FLIP (i) ;
+ }
+ else
+ {
+ /* degree list is not empty, use Last [Head [hash]] as
+ * hash head. */
+ Next [i] = Last [j] ;
+ Last [j] = i ;
+ }
+
+ /* if a separate Hhead array is used: *
+ Next [i] = Hhead [hash] ;
+ Hhead [hash] = i ;
+ */
+
+ Last [i] = hash ;
+ }
+ }
+
+ Degree [me] = degme ;
+
+ /* ----------------------------------------------------------------- */
+ /* Clear the counter array, W [...], by incrementing wflg. */
+ /* ----------------------------------------------------------------- */
+
+ /* make sure that wflg+n does not cause integer overflow */
+ lemax = MAX (lemax, degme) ;
+ wflg += lemax ;
+ wflg = clear_flag (wflg, wbig, W, n) ;
+ /* at this point, W [0..n-1] < wflg holds */
+
+/* ========================================================================= */
+/* SUPERVARIABLE DETECTION */
+/* ========================================================================= */
+
+ AMD_DEBUG1 (("Detecting supervariables:\n")) ;
+ for (pme = pme1 ; pme <= pme2 ; pme++)
+ {
+ i = Iw [pme] ;
+ ASSERT (i >= 0 && i < n) ;
+ AMD_DEBUG2 (("Consider i "ID" nv "ID"\n", i, Nv [i])) ;
+ if (Nv [i] < 0)
+ {
+ /* i is a principal variable in Lme */
+
+ /* ---------------------------------------------------------
+ * examine all hash buckets with 2 or more variables. We do
+ * this by examing all unique hash keys for supervariables in
+ * the pattern Lme of the current element, me
+ * --------------------------------------------------------- */
+
+ /* let i = head of hash bucket, and empty the hash bucket */
+ ASSERT (Last [i] >= 0 && Last [i] < n) ;
+ hash = Last [i] ;
+
+ /* if Hhead array is not used: */
+ j = Head [hash] ;
+ if (j == EMPTY)
+ {
+ /* hash bucket and degree list are both empty */
+ i = EMPTY ;
+ }
+ else if (j < EMPTY)
+ {
+ /* degree list is empty */
+ i = FLIP (j) ;
+ Head [hash] = EMPTY ;
+ }
+ else
+ {
+ /* degree list is not empty, restore Last [j] of head j */
+ i = Last [j] ;
+ Last [j] = EMPTY ;
+ }
+
+ /* if separate Hhead array is used: *
+ i = Hhead [hash] ;
+ Hhead [hash] = EMPTY ;
+ */
+
+ ASSERT (i >= EMPTY && i < n) ;
+ AMD_DEBUG2 (("----i "ID" hash "ID"\n", i, hash)) ;
+
+ while (i != EMPTY && Next [i] != EMPTY)
+ {
+
+ /* -----------------------------------------------------
+ * this bucket has one or more variables following i.
+ * scan all of them to see if i can absorb any entries
+ * that follow i in hash bucket. Scatter i into w.
+ * ----------------------------------------------------- */
+
+ ln = Len [i] ;
+ eln = Elen [i] ;
+ ASSERT (ln >= 0 && eln >= 0) ;
+ ASSERT (Pe [i] >= 0 && Pe [i] < iwlen) ;
+ /* do not flag the first element in the list (me) */
+ for (p = Pe [i] + 1 ; p <= Pe [i] + ln - 1 ; p++)
+ {
+ ASSERT (Iw [p] >= 0 && Iw [p] < n) ;
+ W [Iw [p]] = wflg ;
+ }
+
+ /* ----------------------------------------------------- */
+ /* scan every other entry j following i in bucket */
+ /* ----------------------------------------------------- */
+
+ jlast = i ;
+ j = Next [i] ;
+ ASSERT (j >= EMPTY && j < n) ;
+
+ while (j != EMPTY)
+ {
+ /* ------------------------------------------------- */
+ /* check if j and i have identical nonzero pattern */
+ /* ------------------------------------------------- */
+
+ AMD_DEBUG3 (("compare i "ID" and j "ID"\n", i,j)) ;
+
+ /* check if i and j have the same Len and Elen */
+ ASSERT (Len [j] >= 0 && Elen [j] >= 0) ;
+ ASSERT (Pe [j] >= 0 && Pe [j] < iwlen) ;
+ ok = (Len [j] == ln) && (Elen [j] == eln) ;
+ /* skip the first element in the list (me) */
+ for (p = Pe [j] + 1 ; ok && p <= Pe [j] + ln - 1 ; p++)
+ {
+ ASSERT (Iw [p] >= 0 && Iw [p] < n) ;
+ if (W [Iw [p]] != wflg) ok = 0 ;
+ }
+ if (ok)
+ {
+ /* --------------------------------------------- */
+ /* found it! j can be absorbed into i */
+ /* --------------------------------------------- */
+
+ AMD_DEBUG1 (("found it! j "ID" => i "ID"\n", j,i));
+ Pe [j] = FLIP (i) ;
+ /* both Nv [i] and Nv [j] are negated since they */
+ /* are in Lme, and the absolute values of each */
+ /* are the number of variables in i and j: */
+ Nv [i] += Nv [j] ;
+ Nv [j] = 0 ;
+ Elen [j] = EMPTY ;
+ /* delete j from hash bucket */
+ ASSERT (j != Next [j]) ;
+ j = Next [j] ;
+ Next [jlast] = j ;
+
+ }
+ else
+ {
+ /* j cannot be absorbed into i */
+ jlast = j ;
+ ASSERT (j != Next [j]) ;
+ j = Next [j] ;
+ }
+ ASSERT (j >= EMPTY && j < n) ;
+ }
+
+ /* -----------------------------------------------------
+ * no more variables can be absorbed into i
+ * go to next i in bucket and clear flag array
+ * ----------------------------------------------------- */
+
+ wflg++ ;
+ i = Next [i] ;
+ ASSERT (i >= EMPTY && i < n) ;
+
+ }
+ }
+ }
+ AMD_DEBUG2 (("detect done\n")) ;
+
+/* ========================================================================= */
+/* RESTORE DEGREE LISTS AND REMOVE NONPRINCIPAL SUPERVARIABLES FROM ELEMENT */
+/* ========================================================================= */
+
+ p = pme1 ;
+ nleft = n - nel ;
+ for (pme = pme1 ; pme <= pme2 ; pme++)
+ {
+ i = Iw [pme] ;
+ ASSERT (i >= 0 && i < n) ;
+ nvi = -Nv [i] ;
+ AMD_DEBUG3 (("Restore i "ID" "ID"\n", i, nvi)) ;
+ if (nvi > 0)
+ {
+ /* i is a principal variable in Lme */
+ /* restore Nv [i] to signify that i is principal */
+ Nv [i] = nvi ;
+
+ /* --------------------------------------------------------- */
+ /* compute the external degree (add size of current element) */
+ /* --------------------------------------------------------- */
+
+ deg = Degree [i] + degme - nvi ;
+ deg = MIN (deg, nleft - nvi) ;
+ ASSERT (IMPLIES (aggressive, deg > 0) && deg >= 0 && deg < n) ;
+
+ /* --------------------------------------------------------- */
+ /* place the supervariable at the head of the degree list */
+ /* --------------------------------------------------------- */
+
+ inext = Head [deg] ;
+ ASSERT (inext >= EMPTY && inext < n) ;
+ if (inext != EMPTY) Last [inext] = i ;
+ Next [i] = inext ;
+ Last [i] = EMPTY ;
+ Head [deg] = i ;
+
+ /* --------------------------------------------------------- */
+ /* save the new degree, and find the minimum degree */
+ /* --------------------------------------------------------- */
+
+ mindeg = MIN (mindeg, deg) ;
+ Degree [i] = deg ;
+
+ /* --------------------------------------------------------- */
+ /* place the supervariable in the element pattern */
+ /* --------------------------------------------------------- */
+
+ Iw [p++] = i ;
+
+ }
+ }
+ AMD_DEBUG2 (("restore done\n")) ;
+
+/* ========================================================================= */
+/* FINALIZE THE NEW ELEMENT */
+/* ========================================================================= */
+
+ AMD_DEBUG2 (("ME = "ID" DONE\n", me)) ;
+ Nv [me] = nvpiv ;
+ /* save the length of the list for the new element me */
+ Len [me] = p - pme1 ;
+ if (Len [me] == 0)
+ {
+ /* there is nothing left of the current pivot element */
+ /* it is a root of the assembly tree */
+ Pe [me] = EMPTY ;
+ W [me] = 0 ;
+ }
+ if (elenme != 0)
+ {
+ /* element was not constructed in place: deallocate part of */
+ /* it since newly nonprincipal variables may have been removed */
+ pfree = p ;
+ }
+
+ /* The new element has nvpiv pivots and the size of the contribution
+ * block for a multifrontal method is degme-by-degme, not including
+ * the "dense" rows/columns. If the "dense" rows/columns are included,
+ * the frontal matrix is no larger than
+ * (degme+ndense)-by-(degme+ndense).
+ */
+
+ if (Info != (double *) NULL)
+ {
+ f = nvpiv ;
+ r = degme + ndense ;
+ dmax = MAX (dmax, f + r) ;
+
+ /* number of nonzeros in L (excluding the diagonal) */
+ lnzme = f*r + (f-1)*f/2 ;
+ lnz += lnzme ;
+
+ /* number of divide operations for LDL' and for LU */
+ ndiv += lnzme ;
+
+ /* number of multiply-subtract pairs for LU */
+ s = f*r*r + r*(f-1)*f + (f-1)*f*(2*f-1)/6 ;
+ nms_lu += s ;
+
+ /* number of multiply-subtract pairs for LDL' */
+ nms_ldl += (s + lnzme)/2 ;
+ }
+
+#ifndef NDEBUG
+ AMD_DEBUG2 (("finalize done nel "ID" n "ID"\n ::::\n", nel, n)) ;
+ for (pme = Pe [me] ; pme <= Pe [me] + Len [me] - 1 ; pme++)
+ {
+ AMD_DEBUG3 ((" "ID"", Iw [pme])) ;
+ }
+ AMD_DEBUG3 (("\n")) ;
+#endif
+
+ }
+
+/* ========================================================================= */
+/* DONE SELECTING PIVOTS */
+/* ========================================================================= */
+
+ if (Info != (double *) NULL)
+ {
+
+ /* count the work to factorize the ndense-by-ndense submatrix */
+ f = ndense ;
+ dmax = MAX (dmax, (double) ndense) ;
+
+ /* number of nonzeros in L (excluding the diagonal) */
+ lnzme = (f-1)*f/2 ;
+ lnz += lnzme ;
+
+ /* number of divide operations for LDL' and for LU */
+ ndiv += lnzme ;
+
+ /* number of multiply-subtract pairs for LU */
+ s = (f-1)*f*(2*f-1)/6 ;
+ nms_lu += s ;
+
+ /* number of multiply-subtract pairs for LDL' */
+ nms_ldl += (s + lnzme)/2 ;
+
+ /* number of nz's in L (excl. diagonal) */
+ Info [AMD_LNZ] = lnz ;
+
+ /* number of divide ops for LU and LDL' */
+ Info [AMD_NDIV] = ndiv ;
+
+ /* number of multiply-subtract pairs for LDL' */
+ Info [AMD_NMULTSUBS_LDL] = nms_ldl ;
+
+ /* number of multiply-subtract pairs for LU */
+ Info [AMD_NMULTSUBS_LU] = nms_lu ;
+
+ /* number of "dense" rows/columns */
+ Info [AMD_NDENSE] = ndense ;
+
+ /* largest front is dmax-by-dmax */
+ Info [AMD_DMAX] = dmax ;
+
+ /* number of garbage collections in AMD */
+ Info [AMD_NCMPA] = ncmpa ;
+
+ /* successful ordering */
+ Info [AMD_STATUS] = AMD_OK ;
+ }
+
+/* ========================================================================= */
+/* POST-ORDERING */
+/* ========================================================================= */
+
+/* -------------------------------------------------------------------------
+ * Variables at this point:
+ *
+ * Pe: holds the elimination tree. The parent of j is FLIP (Pe [j]),
+ * or EMPTY if j is a root. The tree holds both elements and
+ * non-principal (unordered) variables absorbed into them.
+ * Dense variables are non-principal and unordered.
+ *
+ * Elen: holds the size of each element, including the diagonal part.
+ * FLIP (Elen [e]) > 0 if e is an element. For unordered
+ * variables i, Elen [i] is EMPTY.
+ *
+ * Nv: Nv [e] > 0 is the number of pivots represented by the element e.
+ * For unordered variables i, Nv [i] is zero.
+ *
+ * Contents no longer needed:
+ * W, Iw, Len, Degree, Head, Next, Last.
+ *
+ * The matrix itself has been destroyed.
+ *
+ * n: the size of the matrix.
+ * No other scalars needed (pfree, iwlen, etc.)
+ * ------------------------------------------------------------------------- */
+
+ /* restore Pe */
+ for (i = 0 ; i < n ; i++)
+ {
+ Pe [i] = FLIP (Pe [i]) ;
+ }
+
+ /* restore Elen, for output information, and for postordering */
+ for (i = 0 ; i < n ; i++)
+ {
+ Elen [i] = FLIP (Elen [i]) ;
+ }
+
+/* Now the parent of j is Pe [j], or EMPTY if j is a root. Elen [e] > 0
+ * is the size of element e. Elen [i] is EMPTY for unordered variable i. */
+
+#ifndef NDEBUG
+ AMD_DEBUG2 (("\nTree:\n")) ;
+ for (i = 0 ; i < n ; i++)
+ {
+ AMD_DEBUG2 ((" "ID" parent: "ID" ", i, Pe [i])) ;
+ ASSERT (Pe [i] >= EMPTY && Pe [i] < n) ;
+ if (Nv [i] > 0)
+ {
+ /* this is an element */
+ e = i ;
+ AMD_DEBUG2 ((" element, size is "ID"\n", Elen [i])) ;
+ ASSERT (Elen [e] > 0) ;
+ }
+ AMD_DEBUG2 (("\n")) ;
+ }
+ AMD_DEBUG2 (("\nelements:\n")) ;
+ for (e = 0 ; e < n ; e++)
+ {
+ if (Nv [e] > 0)
+ {
+ AMD_DEBUG3 (("Element e= "ID" size "ID" nv "ID" \n", e,
+ Elen [e], Nv [e])) ;
+ }
+ }
+ AMD_DEBUG2 (("\nvariables:\n")) ;
+ for (i = 0 ; i < n ; i++)
+ {
+ Int cnt ;
+ if (Nv [i] == 0)
+ {
+ AMD_DEBUG3 (("i unordered: "ID"\n", i)) ;
+ j = Pe [i] ;
+ cnt = 0 ;
+ AMD_DEBUG3 ((" j: "ID"\n", j)) ;
+ if (j == EMPTY)
+ {
+ AMD_DEBUG3 ((" i is a dense variable\n")) ;
+ }
+ else
+ {
+ ASSERT (j >= 0 && j < n) ;
+ while (Nv [j] == 0)
+ {
+ AMD_DEBUG3 ((" j : "ID"\n", j)) ;
+ j = Pe [j] ;
+ AMD_DEBUG3 ((" j:: "ID"\n", j)) ;
+ cnt++ ;
+ if (cnt > n) break ;
+ }
+ e = j ;
+ AMD_DEBUG3 ((" got to e: "ID"\n", e)) ;
+ }
+ }
+ }
+#endif
+
+/* ========================================================================= */
+/* compress the paths of the variables */
+/* ========================================================================= */
+
+ for (i = 0 ; i < n ; i++)
+ {
+ if (Nv [i] == 0)
+ {
+
+ /* -------------------------------------------------------------
+ * i is an un-ordered row. Traverse the tree from i until
+ * reaching an element, e. The element, e, was the principal
+ * supervariable of i and all nodes in the path from i to when e
+ * was selected as pivot.
+ * ------------------------------------------------------------- */
+
+ AMD_DEBUG1 (("Path compression, i unordered: "ID"\n", i)) ;
+ j = Pe [i] ;
+ ASSERT (j >= EMPTY && j < n) ;
+ AMD_DEBUG3 ((" j: "ID"\n", j)) ;
+ if (j == EMPTY)
+ {
+ /* Skip a dense variable. It has no parent. */
+ AMD_DEBUG3 ((" i is a dense variable\n")) ;
+ continue ;
+ }
+
+ /* while (j is a variable) */
+ while (Nv [j] == 0)
+ {
+ AMD_DEBUG3 ((" j : "ID"\n", j)) ;
+ j = Pe [j] ;
+ AMD_DEBUG3 ((" j:: "ID"\n", j)) ;
+ ASSERT (j >= 0 && j < n) ;
+ }
+ /* got to an element e */
+ e = j ;
+ AMD_DEBUG3 (("got to e: "ID"\n", e)) ;
+
+ /* -------------------------------------------------------------
+ * traverse the path again from i to e, and compress the path
+ * (all nodes point to e). Path compression allows this code to
+ * compute in O(n) time.
+ * ------------------------------------------------------------- */
+
+ j = i ;
+ /* while (j is a variable) */
+ while (Nv [j] == 0)
+ {
+ jnext = Pe [j] ;
+ AMD_DEBUG3 (("j "ID" jnext "ID"\n", j, jnext)) ;
+ Pe [j] = e ;
+ j = jnext ;
+ ASSERT (j >= 0 && j < n) ;
+ }
+ }
+ }
+
+/* ========================================================================= */
+/* postorder the assembly tree */
+/* ========================================================================= */
+
+ AMD_postorder (n, Pe, Nv, Elen,
+ W, /* output order */
+ Head, Next, Last) ; /* workspace */
+
+/* ========================================================================= */
+/* compute output permutation and inverse permutation */
+/* ========================================================================= */
+
+ /* W [e] = k means that element e is the kth element in the new
+ * order. e is in the range 0 to n-1, and k is in the range 0 to
+ * the number of elements. Use Head for inverse order. */
+
+ for (k = 0 ; k < n ; k++)
+ {
+ Head [k] = EMPTY ;
+ Next [k] = EMPTY ;
+ }
+ for (e = 0 ; e < n ; e++)
+ {
+ k = W [e] ;
+ ASSERT ((k == EMPTY) == (Nv [e] == 0)) ;
+ if (k != EMPTY)
+ {
+ ASSERT (k >= 0 && k < n) ;
+ Head [k] = e ;
+ }
+ }
+
+ /* construct output inverse permutation in Next,
+ * and permutation in Last */
+ nel = 0 ;
+ for (k = 0 ; k < n ; k++)
+ {
+ e = Head [k] ;
+ if (e == EMPTY) break ;
+ ASSERT (e >= 0 && e < n && Nv [e] > 0) ;
+ Next [e] = nel ;
+ nel += Nv [e] ;
+ }
+ ASSERT (nel == n - ndense) ;
+
+ /* order non-principal variables (dense, & those merged into supervar's) */
+ for (i = 0 ; i < n ; i++)
+ {
+ if (Nv [i] == 0)
+ {
+ e = Pe [i] ;
+ ASSERT (e >= EMPTY && e < n) ;
+ if (e != EMPTY)
+ {
+ /* This is an unordered variable that was merged
+ * into element e via supernode detection or mass
+ * elimination of i when e became the pivot element.
+ * Place i in order just before e. */
+ ASSERT (Next [i] == EMPTY && Nv [e] > 0) ;
+ Next [i] = Next [e] ;
+ Next [e]++ ;
+ }
+ else
+ {
+ /* This is a dense unordered variable, with no parent.
+ * Place it last in the output order. */
+ Next [i] = nel++ ;
+ }
+ }
+ }
+ ASSERT (nel == n) ;
+
+ AMD_DEBUG2 (("\n\nPerm:\n")) ;
+ for (i = 0 ; i < n ; i++)
+ {
+ k = Next [i] ;
+ ASSERT (k >= 0 && k < n) ;
+ Last [k] = i ;
+ AMD_DEBUG2 ((" perm ["ID"] = "ID"\n", k, i)) ;
+ }
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_aat.c b/test/monniaux/glpk-4.65/src/amd/amd_aat.c
new file mode 100644
index 00000000..63bf55f5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_aat.c
@@ -0,0 +1,185 @@
+/* ========================================================================= */
+/* === AMD_aat ============================================================= */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* AMD_aat: compute the symmetry of the pattern of A, and count the number of
+ * nonzeros each column of A+A' (excluding the diagonal). Assumes the input
+ * matrix has no errors, with sorted columns and no duplicates
+ * (AMD_valid (n, n, Ap, Ai) must be AMD_OK, but this condition is not
+ * checked).
+ */
+
+#include "amd_internal.h"
+
+GLOBAL size_t AMD_aat /* returns nz in A+A' */
+(
+ Int n,
+ const Int Ap [ ],
+ const Int Ai [ ],
+ Int Len [ ], /* Len [j]: length of column j of A+A', excl diagonal*/
+ Int Tp [ ], /* workspace of size n */
+ double Info [ ]
+)
+{
+ Int p1, p2, p, i, j, pj, pj2, k, nzdiag, nzboth, nz ;
+ double sym ;
+ size_t nzaat ;
+
+#ifndef NDEBUG
+ AMD_debug_init ("AMD AAT") ;
+ for (k = 0 ; k < n ; k++) Tp [k] = EMPTY ;
+ ASSERT (AMD_valid (n, n, Ap, Ai) == AMD_OK) ;
+#endif
+
+ if (Info != (double *) NULL)
+ {
+ /* clear the Info array, if it exists */
+ for (i = 0 ; i < AMD_INFO ; i++)
+ {
+ Info [i] = EMPTY ;
+ }
+ Info [AMD_STATUS] = AMD_OK ;
+ }
+
+ for (k = 0 ; k < n ; k++)
+ {
+ Len [k] = 0 ;
+ }
+
+ nzdiag = 0 ;
+ nzboth = 0 ;
+ nz = Ap [n] ;
+
+ for (k = 0 ; k < n ; k++)
+ {
+ p1 = Ap [k] ;
+ p2 = Ap [k+1] ;
+ AMD_DEBUG2 (("\nAAT Column: "ID" p1: "ID" p2: "ID"\n", k, p1, p2)) ;
+
+ /* construct A+A' */
+ for (p = p1 ; p < p2 ; )
+ {
+ /* scan the upper triangular part of A */
+ j = Ai [p] ;
+ if (j < k)
+ {
+ /* entry A (j,k) is in the strictly upper triangular part,
+ * add both A (j,k) and A (k,j) to the matrix A+A' */
+ Len [j]++ ;
+ Len [k]++ ;
+ AMD_DEBUG3 ((" upper ("ID","ID") ("ID","ID")\n", j,k, k,j));
+ p++ ;
+ }
+ else if (j == k)
+ {
+ /* skip the diagonal */
+ p++ ;
+ nzdiag++ ;
+ break ;
+ }
+ else /* j > k */
+ {
+ /* first entry below the diagonal */
+ break ;
+ }
+ /* scan lower triangular part of A, in column j until reaching
+ * row k. Start where last scan left off. */
+ ASSERT (Tp [j] != EMPTY) ;
+ ASSERT (Ap [j] <= Tp [j] && Tp [j] <= Ap [j+1]) ;
+ pj2 = Ap [j+1] ;
+ for (pj = Tp [j] ; pj < pj2 ; )
+ {
+ i = Ai [pj] ;
+ if (i < k)
+ {
+ /* A (i,j) is only in the lower part, not in upper.
+ * add both A (i,j) and A (j,i) to the matrix A+A' */
+ Len [i]++ ;
+ Len [j]++ ;
+ AMD_DEBUG3 ((" lower ("ID","ID") ("ID","ID")\n",
+ i,j, j,i)) ;
+ pj++ ;
+ }
+ else if (i == k)
+ {
+ /* entry A (k,j) in lower part and A (j,k) in upper */
+ pj++ ;
+ nzboth++ ;
+ break ;
+ }
+ else /* i > k */
+ {
+ /* consider this entry later, when k advances to i */
+ break ;
+ }
+ }
+ Tp [j] = pj ;
+ }
+ /* Tp [k] points to the entry just below the diagonal in column k */
+ Tp [k] = p ;
+ }
+
+ /* clean up, for remaining mismatched entries */
+ for (j = 0 ; j < n ; j++)
+ {
+ for (pj = Tp [j] ; pj < Ap [j+1] ; pj++)
+ {
+ i = Ai [pj] ;
+ /* A (i,j) is only in the lower part, not in upper.
+ * add both A (i,j) and A (j,i) to the matrix A+A' */
+ Len [i]++ ;
+ Len [j]++ ;
+ AMD_DEBUG3 ((" lower cleanup ("ID","ID") ("ID","ID")\n",
+ i,j, j,i)) ;
+ }
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* compute the symmetry of the nonzero pattern of A */
+ /* --------------------------------------------------------------------- */
+
+ /* Given a matrix A, the symmetry of A is:
+ * B = tril (spones (A), -1) + triu (spones (A), 1) ;
+ * sym = nnz (B & B') / nnz (B) ;
+ * or 1 if nnz (B) is zero.
+ */
+
+ if (nz == nzdiag)
+ {
+ sym = 1 ;
+ }
+ else
+ {
+ sym = (2 * (double) nzboth) / ((double) (nz - nzdiag)) ;
+ }
+
+ nzaat = 0 ;
+ for (k = 0 ; k < n ; k++)
+ {
+ nzaat += Len [k] ;
+ }
+
+ AMD_DEBUG1 (("AMD nz in A+A', excluding diagonal (nzaat) = %g\n",
+ (double) nzaat)) ;
+ AMD_DEBUG1 ((" nzboth: "ID" nz: "ID" nzdiag: "ID" symmetry: %g\n",
+ nzboth, nz, nzdiag, sym)) ;
+
+ if (Info != (double *) NULL)
+ {
+ Info [AMD_STATUS] = AMD_OK ;
+ Info [AMD_N] = n ;
+ Info [AMD_NZ] = nz ;
+ Info [AMD_SYMMETRY] = sym ; /* symmetry of pattern of A */
+ Info [AMD_NZDIAG] = nzdiag ; /* nonzeros on diagonal of A */
+ Info [AMD_NZ_A_PLUS_AT] = nzaat ; /* nonzeros in A+A' */
+ }
+
+ return (nzaat) ;
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_control.c b/test/monniaux/glpk-4.65/src/amd/amd_control.c
new file mode 100644
index 00000000..f4d4f0df
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_control.c
@@ -0,0 +1,64 @@
+/* ========================================================================= */
+/* === AMD_control ========================================================= */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* User-callable. Prints the control parameters for AMD. See amd.h
+ * for details. If the Control array is not present, the defaults are
+ * printed instead.
+ */
+
+#include "amd_internal.h"
+
+GLOBAL void AMD_control
+(
+ double Control [ ]
+)
+{
+ double alpha ;
+ Int aggressive ;
+
+ if (Control != (double *) NULL)
+ {
+ alpha = Control [AMD_DENSE] ;
+ aggressive = Control [AMD_AGGRESSIVE] != 0 ;
+ }
+ else
+ {
+ alpha = AMD_DEFAULT_DENSE ;
+ aggressive = AMD_DEFAULT_AGGRESSIVE ;
+ }
+
+ PRINTF (("\nAMD version %d.%d.%d, %s: approximate minimum degree ordering\n"
+ " dense row parameter: %g\n", AMD_MAIN_VERSION, AMD_SUB_VERSION,
+ AMD_SUBSUB_VERSION, AMD_DATE, alpha)) ;
+
+ if (alpha < 0)
+ {
+ PRINTF ((" no rows treated as dense\n")) ;
+ }
+ else
+ {
+ PRINTF ((
+ " (rows with more than max (%g * sqrt (n), 16) entries are\n"
+ " considered \"dense\", and placed last in output permutation)\n",
+ alpha)) ;
+ }
+
+ if (aggressive)
+ {
+ PRINTF ((" aggressive absorption: yes\n")) ;
+ }
+ else
+ {
+ PRINTF ((" aggressive absorption: no\n")) ;
+ }
+
+ PRINTF ((" size of AMD integer: %d\n\n", sizeof (Int))) ;
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_defaults.c b/test/monniaux/glpk-4.65/src/amd/amd_defaults.c
new file mode 100644
index 00000000..820e8942
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_defaults.c
@@ -0,0 +1,38 @@
+/* ========================================================================= */
+/* === AMD_defaults ======================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* User-callable. Sets default control parameters for AMD. See amd.h
+ * for details.
+ */
+
+#include "amd_internal.h"
+
+/* ========================================================================= */
+/* === AMD defaults ======================================================== */
+/* ========================================================================= */
+
+GLOBAL void AMD_defaults
+(
+ double Control [ ]
+)
+{
+ Int i ;
+
+ if (Control != (double *) NULL)
+ {
+ for (i = 0 ; i < AMD_CONTROL ; i++)
+ {
+ Control [i] = 0 ;
+ }
+ Control [AMD_DENSE] = AMD_DEFAULT_DENSE ;
+ Control [AMD_AGGRESSIVE] = AMD_DEFAULT_AGGRESSIVE ;
+ }
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_dump.c b/test/monniaux/glpk-4.65/src/amd/amd_dump.c
new file mode 100644
index 00000000..39bbe1d8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_dump.c
@@ -0,0 +1,180 @@
+/* ========================================================================= */
+/* === AMD_dump ============================================================ */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* Debugging routines for AMD. Not used if NDEBUG is not defined at compile-
+ * time (the default). See comments in amd_internal.h on how to enable
+ * debugging. Not user-callable.
+ */
+
+#include "amd_internal.h"
+
+#ifndef NDEBUG
+
+/* This global variable is present only when debugging */
+GLOBAL Int AMD_debug = -999 ; /* default is no debug printing */
+
+/* ========================================================================= */
+/* === AMD_debug_init ====================================================== */
+/* ========================================================================= */
+
+/* Sets the debug print level, by reading the file debug.amd (if it exists) */
+
+GLOBAL void AMD_debug_init ( char *s )
+{
+ FILE *f ;
+ f = fopen ("debug.amd", "r") ;
+ if (f == (FILE *) NULL)
+ {
+ AMD_debug = -999 ;
+ }
+ else
+ {
+ fscanf (f, ID, &AMD_debug) ;
+ fclose (f) ;
+ }
+ if (AMD_debug >= 0)
+ {
+ printf ("%s: AMD_debug_init, D= "ID"\n", s, AMD_debug) ;
+ }
+}
+
+/* ========================================================================= */
+/* === AMD_dump ============================================================ */
+/* ========================================================================= */
+
+/* Dump AMD's data structure, except for the hash buckets. This routine
+ * cannot be called when the hash buckets are non-empty.
+ */
+
+GLOBAL void AMD_dump (
+ Int n, /* A is n-by-n */
+ Int Pe [ ], /* pe [0..n-1]: index in iw of start of row i */
+ Int Iw [ ], /* workspace of size iwlen, iwlen [0..pfree-1]
+ * holds the matrix on input */
+ Int Len [ ], /* len [0..n-1]: length for row i */
+ Int iwlen, /* length of iw */
+ Int pfree, /* iw [pfree ... iwlen-1] is empty on input */
+ Int Nv [ ], /* nv [0..n-1] */
+ Int Next [ ], /* next [0..n-1] */
+ Int Last [ ], /* last [0..n-1] */
+ Int Head [ ], /* head [0..n-1] */
+ Int Elen [ ], /* size n */
+ Int Degree [ ], /* size n */
+ Int W [ ], /* size n */
+ Int nel
+)
+{
+ Int i, pe, elen, nv, len, e, p, k, j, deg, w, cnt, ilast ;
+
+ if (AMD_debug < 0) return ;
+ ASSERT (pfree <= iwlen) ;
+ AMD_DEBUG3 (("\nAMD dump, pfree: "ID"\n", pfree)) ;
+ for (i = 0 ; i < n ; i++)
+ {
+ pe = Pe [i] ;
+ elen = Elen [i] ;
+ nv = Nv [i] ;
+ len = Len [i] ;
+ w = W [i] ;
+
+ if (elen >= EMPTY)
+ {
+ if (nv == 0)
+ {
+ AMD_DEBUG3 (("\nI "ID": nonprincipal: ", i)) ;
+ ASSERT (elen == EMPTY) ;
+ if (pe == EMPTY)
+ {
+ AMD_DEBUG3 ((" dense node\n")) ;
+ ASSERT (w == 1) ;
+ }
+ else
+ {
+ ASSERT (pe < EMPTY) ;
+ AMD_DEBUG3 ((" i "ID" -> parent "ID"\n", i, FLIP (Pe[i])));
+ }
+ }
+ else
+ {
+ AMD_DEBUG3 (("\nI "ID": active principal supervariable:\n",i));
+ AMD_DEBUG3 ((" nv(i): "ID" Flag: %d\n", nv, (nv < 0))) ;
+ ASSERT (elen >= 0) ;
+ ASSERT (nv > 0 && pe >= 0) ;
+ p = pe ;
+ AMD_DEBUG3 ((" e/s: ")) ;
+ if (elen == 0) AMD_DEBUG3 ((" : ")) ;
+ ASSERT (pe + len <= pfree) ;
+ for (k = 0 ; k < len ; k++)
+ {
+ j = Iw [p] ;
+ AMD_DEBUG3 ((" "ID"", j)) ;
+ ASSERT (j >= 0 && j < n) ;
+ if (k == elen-1) AMD_DEBUG3 ((" : ")) ;
+ p++ ;
+ }
+ AMD_DEBUG3 (("\n")) ;
+ }
+ }
+ else
+ {
+ e = i ;
+ if (w == 0)
+ {
+ AMD_DEBUG3 (("\nE "ID": absorbed element: w "ID"\n", e, w)) ;
+ ASSERT (nv > 0 && pe < 0) ;
+ AMD_DEBUG3 ((" e "ID" -> parent "ID"\n", e, FLIP (Pe [e]))) ;
+ }
+ else
+ {
+ AMD_DEBUG3 (("\nE "ID": unabsorbed element: w "ID"\n", e, w)) ;
+ ASSERT (nv > 0 && pe >= 0) ;
+ p = pe ;
+ AMD_DEBUG3 ((" : ")) ;
+ ASSERT (pe + len <= pfree) ;
+ for (k = 0 ; k < len ; k++)
+ {
+ j = Iw [p] ;
+ AMD_DEBUG3 ((" "ID"", j)) ;
+ ASSERT (j >= 0 && j < n) ;
+ p++ ;
+ }
+ AMD_DEBUG3 (("\n")) ;
+ }
+ }
+ }
+
+ /* this routine cannot be called when the hash buckets are non-empty */
+ AMD_DEBUG3 (("\nDegree lists:\n")) ;
+ if (nel >= 0)
+ {
+ cnt = 0 ;
+ for (deg = 0 ; deg < n ; deg++)
+ {
+ if (Head [deg] == EMPTY) continue ;
+ ilast = EMPTY ;
+ AMD_DEBUG3 ((ID": \n", deg)) ;
+ for (i = Head [deg] ; i != EMPTY ; i = Next [i])
+ {
+ AMD_DEBUG3 ((" "ID" : next "ID" last "ID" deg "ID"\n",
+ i, Next [i], Last [i], Degree [i])) ;
+ ASSERT (i >= 0 && i < n && ilast == Last [i] &&
+ deg == Degree [i]) ;
+ cnt += Nv [i] ;
+ ilast = i ;
+ }
+ AMD_DEBUG3 (("\n")) ;
+ }
+ ASSERT (cnt == n - nel) ;
+ }
+
+}
+
+#endif
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_info.c b/test/monniaux/glpk-4.65/src/amd/amd_info.c
new file mode 100644
index 00000000..e7b806a9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_info.c
@@ -0,0 +1,120 @@
+/* ========================================================================= */
+/* === AMD_info ============================================================ */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* User-callable. Prints the output statistics for AMD. See amd.h
+ * for details. If the Info array is not present, nothing is printed.
+ */
+
+#include "amd_internal.h"
+
+#define PRI(format,x) { if (x >= 0) { PRINTF ((format, x)) ; }}
+
+GLOBAL void AMD_info
+(
+ double Info [ ]
+)
+{
+ double n, ndiv, nmultsubs_ldl, nmultsubs_lu, lnz, lnzd ;
+
+ PRINTF (("\nAMD version %d.%d.%d, %s, results:\n",
+ AMD_MAIN_VERSION, AMD_SUB_VERSION, AMD_SUBSUB_VERSION, AMD_DATE)) ;
+
+ if (!Info)
+ {
+ return ;
+ }
+
+ n = Info [AMD_N] ;
+ ndiv = Info [AMD_NDIV] ;
+ nmultsubs_ldl = Info [AMD_NMULTSUBS_LDL] ;
+ nmultsubs_lu = Info [AMD_NMULTSUBS_LU] ;
+ lnz = Info [AMD_LNZ] ;
+ lnzd = (n >= 0 && lnz >= 0) ? (n + lnz) : (-1) ;
+
+ /* AMD return status */
+ PRINTF ((" status: ")) ;
+ if (Info [AMD_STATUS] == AMD_OK)
+ {
+ PRINTF (("OK\n")) ;
+ }
+ else if (Info [AMD_STATUS] == AMD_OUT_OF_MEMORY)
+ {
+ PRINTF (("out of memory\n")) ;
+ }
+ else if (Info [AMD_STATUS] == AMD_INVALID)
+ {
+ PRINTF (("invalid matrix\n")) ;
+ }
+ else if (Info [AMD_STATUS] == AMD_OK_BUT_JUMBLED)
+ {
+ PRINTF (("OK, but jumbled\n")) ;
+ }
+ else
+ {
+ PRINTF (("unknown\n")) ;
+ }
+
+ /* statistics about the input matrix */
+ PRI (" n, dimension of A: %.20g\n", n);
+ PRI (" nz, number of nonzeros in A: %.20g\n",
+ Info [AMD_NZ]) ;
+ PRI (" symmetry of A: %.4f\n",
+ Info [AMD_SYMMETRY]) ;
+ PRI (" number of nonzeros on diagonal: %.20g\n",
+ Info [AMD_NZDIAG]) ;
+ PRI (" nonzeros in pattern of A+A' (excl. diagonal): %.20g\n",
+ Info [AMD_NZ_A_PLUS_AT]) ;
+ PRI (" # dense rows/columns of A+A': %.20g\n",
+ Info [AMD_NDENSE]) ;
+
+ /* statistics about AMD's behavior */
+ PRI (" memory used, in bytes: %.20g\n",
+ Info [AMD_MEMORY]) ;
+ PRI (" # of memory compactions: %.20g\n",
+ Info [AMD_NCMPA]) ;
+
+ /* statistics about the ordering quality */
+ PRINTF (("\n"
+ " The following approximate statistics are for a subsequent\n"
+ " factorization of A(P,P) + A(P,P)'. They are slight upper\n"
+ " bounds if there are no dense rows/columns in A+A', and become\n"
+ " looser if dense rows/columns exist.\n\n")) ;
+
+ PRI (" nonzeros in L (excluding diagonal): %.20g\n",
+ lnz) ;
+ PRI (" nonzeros in L (including diagonal): %.20g\n",
+ lnzd) ;
+ PRI (" # divide operations for LDL' or LU: %.20g\n",
+ ndiv) ;
+ PRI (" # multiply-subtract operations for LDL': %.20g\n",
+ nmultsubs_ldl) ;
+ PRI (" # multiply-subtract operations for LU: %.20g\n",
+ nmultsubs_lu) ;
+ PRI (" max nz. in any column of L (incl. diagonal): %.20g\n",
+ Info [AMD_DMAX]) ;
+
+ /* total flop counts for various factorizations */
+
+ if (n >= 0 && ndiv >= 0 && nmultsubs_ldl >= 0 && nmultsubs_lu >= 0)
+ {
+ PRINTF (("\n"
+ " chol flop count for real A, sqrt counted as 1 flop: %.20g\n"
+ " LDL' flop count for real A: %.20g\n"
+ " LDL' flop count for complex A: %.20g\n"
+ " LU flop count for real A (with no pivoting): %.20g\n"
+ " LU flop count for complex A (with no pivoting): %.20g\n\n",
+ n + ndiv + 2*nmultsubs_ldl,
+ ndiv + 2*nmultsubs_ldl,
+ 9*ndiv + 8*nmultsubs_ldl,
+ ndiv + 2*nmultsubs_lu,
+ 9*ndiv + 8*nmultsubs_lu)) ;
+ }
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_internal.h b/test/monniaux/glpk-4.65/src/amd/amd_internal.h
new file mode 100644
index 00000000..b08f8436
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_internal.h
@@ -0,0 +1,117 @@
+/* amd_internal.h */
+
+/* Written by Andrew Makhorin <mao@gnu.org>. */
+
+#ifndef AMD_INTERNAL_H
+#define AMD_INTERNAL_H
+
+/* AMD will be exceedingly slow when running in debug mode. */
+#if 1
+#define NDEBUG
+#endif
+
+#include "amd.h"
+#define _GLPSTD_STDIO
+#include "env.h"
+
+#define Int int
+#define ID "%d"
+#define Int_MAX INT_MAX
+
+#if 0 /* 15/II-2012 */
+/* now this macro is defined in glpenv.h; besides, the definiton below
+ depends on implementation, because size_t is an unsigned type */
+#define SIZE_T_MAX ((size_t)(-1))
+#endif
+
+#define EMPTY (-1)
+#define FLIP(i) (-(i)-2)
+#define UNFLIP(i) ((i < EMPTY) ? FLIP (i) : (i))
+
+#define MAX(a,b) (((a) > (b)) ? (a) : (b))
+#define MIN(a,b) (((a) < (b)) ? (a) : (b))
+
+#define IMPLIES(p, q) (!(p) || (q))
+
+#define GLOBAL
+
+#define AMD_order amd_order
+#define AMD_defaults amd_defaults
+#define AMD_control amd_control
+#define AMD_info amd_info
+#define AMD_1 amd_1
+#define AMD_2 amd_2
+#define AMD_valid amd_valid
+#define AMD_aat amd_aat
+#define AMD_postorder amd_postorder
+#define AMD_post_tree amd_post_tree
+#define AMD_dump amd_dump
+#define AMD_debug amd_debug
+#define AMD_debug_init amd_debug_init
+#define AMD_preprocess amd_preprocess
+
+#define amd_malloc xmalloc
+#if 0 /* 24/V-2009 */
+#define amd_free xfree
+#else
+#define amd_free(ptr) { if ((ptr) != NULL) xfree(ptr); }
+#endif
+#define amd_printf xprintf
+
+#define PRINTF(params) { amd_printf params; }
+
+#ifndef NDEBUG
+#define ASSERT(expr) xassert(expr)
+#define AMD_DEBUG0(params) { PRINTF(params); }
+#define AMD_DEBUG1(params) { if (AMD_debug >= 1) PRINTF(params); }
+#define AMD_DEBUG2(params) { if (AMD_debug >= 2) PRINTF(params); }
+#define AMD_DEBUG3(params) { if (AMD_debug >= 3) PRINTF(params); }
+#define AMD_DEBUG4(params) { if (AMD_debug >= 4) PRINTF(params); }
+#else
+#define ASSERT(expression)
+#define AMD_DEBUG0(params)
+#define AMD_DEBUG1(params)
+#define AMD_DEBUG2(params)
+#define AMD_DEBUG3(params)
+#define AMD_DEBUG4(params)
+#endif
+
+#define amd_aat _glp_amd_aat
+size_t AMD_aat(Int n, const Int Ap[], const Int Ai[], Int Len[],
+ Int Tp[], double Info[]);
+
+#define amd_1 _glp_amd_1
+void AMD_1(Int n, const Int Ap[], const Int Ai[], Int P[], Int Pinv[],
+ Int Len[], Int slen, Int S[], double Control[], double Info[]);
+
+#define amd_postorder _glp_amd_postorder
+void AMD_postorder(Int nn, Int Parent[], Int Npiv[], Int Fsize[],
+ Int Order[], Int Child[], Int Sibling[], Int Stack[]);
+
+#define amd_post_tree _glp_amd_post_tree
+#ifndef NDEBUG
+Int AMD_post_tree(Int root, Int k, Int Child[], const Int Sibling[],
+ Int Order[], Int Stack[], Int nn);
+#else
+Int AMD_post_tree(Int root, Int k, Int Child[], const Int Sibling[],
+ Int Order[], Int Stack[]);
+#endif
+
+#define amd_preprocess _glp_amd_preprocess
+void AMD_preprocess(Int n, const Int Ap[], const Int Ai[], Int Rp[],
+ Int Ri[], Int W[], Int Flag[]);
+
+#define amd_debug _glp_amd_debug
+extern Int AMD_debug;
+
+#define amd_debug_init _glp_amd_debug_init
+void AMD_debug_init(char *s);
+
+#define amd_dump _glp_amd_dump
+void AMD_dump(Int n, Int Pe[], Int Iw[], Int Len[], Int iwlen,
+ Int pfree, Int Nv[], Int Next[], Int Last[], Int Head[],
+ Int Elen[], Int Degree[], Int W[], Int nel);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_order.c b/test/monniaux/glpk-4.65/src/amd/amd_order.c
new file mode 100644
index 00000000..332d5663
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_order.c
@@ -0,0 +1,200 @@
+/* ========================================================================= */
+/* === AMD_order =========================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* User-callable AMD minimum degree ordering routine. See amd.h for
+ * documentation.
+ */
+
+#include "amd_internal.h"
+
+/* ========================================================================= */
+/* === AMD_order =========================================================== */
+/* ========================================================================= */
+
+GLOBAL Int AMD_order
+(
+ Int n,
+ const Int Ap [ ],
+ const Int Ai [ ],
+ Int P [ ],
+ double Control [ ],
+ double Info [ ]
+)
+{
+ Int *Len, *S, nz, i, *Pinv, info, status, *Rp, *Ri, *Cp, *Ci, ok ;
+ size_t nzaat, slen ;
+ double mem = 0 ;
+
+#ifndef NDEBUG
+ AMD_debug_init ("amd") ;
+#endif
+
+ /* clear the Info array, if it exists */
+ info = Info != (double *) NULL ;
+ if (info)
+ {
+ for (i = 0 ; i < AMD_INFO ; i++)
+ {
+ Info [i] = EMPTY ;
+ }
+ Info [AMD_N] = n ;
+ Info [AMD_STATUS] = AMD_OK ;
+ }
+
+ /* make sure inputs exist and n is >= 0 */
+ if (Ai == (Int *) NULL || Ap == (Int *) NULL || P == (Int *) NULL || n < 0)
+ {
+ if (info) Info [AMD_STATUS] = AMD_INVALID ;
+ return (AMD_INVALID) ; /* arguments are invalid */
+ }
+
+ if (n == 0)
+ {
+ return (AMD_OK) ; /* n is 0 so there's nothing to do */
+ }
+
+ nz = Ap [n] ;
+ if (info)
+ {
+ Info [AMD_NZ] = nz ;
+ }
+ if (nz < 0)
+ {
+ if (info) Info [AMD_STATUS] = AMD_INVALID ;
+ return (AMD_INVALID) ;
+ }
+
+ /* check if n or nz will cause size_t overflow */
+ if (((size_t) n) >= SIZE_T_MAX / sizeof (Int)
+ || ((size_t) nz) >= SIZE_T_MAX / sizeof (Int))
+ {
+ if (info) Info [AMD_STATUS] = AMD_OUT_OF_MEMORY ;
+ return (AMD_OUT_OF_MEMORY) ; /* problem too large */
+ }
+
+ /* check the input matrix: AMD_OK, AMD_INVALID, or AMD_OK_BUT_JUMBLED */
+ status = AMD_valid (n, n, Ap, Ai) ;
+
+ if (status == AMD_INVALID)
+ {
+ if (info) Info [AMD_STATUS] = AMD_INVALID ;
+ return (AMD_INVALID) ; /* matrix is invalid */
+ }
+
+ /* allocate two size-n integer workspaces */
+ Len = amd_malloc (n * sizeof (Int)) ;
+ Pinv = amd_malloc (n * sizeof (Int)) ;
+ mem += n ;
+ mem += n ;
+ if (!Len || !Pinv)
+ {
+ /* :: out of memory :: */
+ amd_free (Len) ;
+ amd_free (Pinv) ;
+ if (info) Info [AMD_STATUS] = AMD_OUT_OF_MEMORY ;
+ return (AMD_OUT_OF_MEMORY) ;
+ }
+
+ if (status == AMD_OK_BUT_JUMBLED)
+ {
+ /* sort the input matrix and remove duplicate entries */
+ AMD_DEBUG1 (("Matrix is jumbled\n")) ;
+ Rp = amd_malloc ((n+1) * sizeof (Int)) ;
+ Ri = amd_malloc (MAX (nz,1) * sizeof (Int)) ;
+ mem += (n+1) ;
+ mem += MAX (nz,1) ;
+ if (!Rp || !Ri)
+ {
+ /* :: out of memory :: */
+ amd_free (Rp) ;
+ amd_free (Ri) ;
+ amd_free (Len) ;
+ amd_free (Pinv) ;
+ if (info) Info [AMD_STATUS] = AMD_OUT_OF_MEMORY ;
+ return (AMD_OUT_OF_MEMORY) ;
+ }
+ /* use Len and Pinv as workspace to create R = A' */
+ AMD_preprocess (n, Ap, Ai, Rp, Ri, Len, Pinv) ;
+ Cp = Rp ;
+ Ci = Ri ;
+ }
+ else
+ {
+ /* order the input matrix as-is. No need to compute R = A' first */
+ Rp = NULL ;
+ Ri = NULL ;
+ Cp = (Int *) Ap ;
+ Ci = (Int *) Ai ;
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* determine the symmetry and count off-diagonal nonzeros in A+A' */
+ /* --------------------------------------------------------------------- */
+
+ nzaat = AMD_aat (n, Cp, Ci, Len, P, Info) ;
+ AMD_DEBUG1 (("nzaat: %g\n", (double) nzaat)) ;
+ ASSERT ((MAX (nz-n, 0) <= nzaat) && (nzaat <= 2 * (size_t) nz)) ;
+
+ /* --------------------------------------------------------------------- */
+ /* allocate workspace for matrix, elbow room, and 6 size-n vectors */
+ /* --------------------------------------------------------------------- */
+
+ S = NULL ;
+ slen = nzaat ; /* space for matrix */
+ ok = ((slen + nzaat/5) >= slen) ; /* check for size_t overflow */
+ slen += nzaat/5 ; /* add elbow room */
+ for (i = 0 ; ok && i < 7 ; i++)
+ {
+ ok = ((slen + n) > slen) ; /* check for size_t overflow */
+ slen += n ; /* size-n elbow room, 6 size-n work */
+ }
+ mem += slen ;
+ ok = ok && (slen < SIZE_T_MAX / sizeof (Int)) ; /* check for overflow */
+ ok = ok && (slen < Int_MAX) ; /* S[i] for Int i must be OK */
+ if (ok)
+ {
+ S = amd_malloc (slen * sizeof (Int)) ;
+ }
+ AMD_DEBUG1 (("slen %g\n", (double) slen)) ;
+ if (!S)
+ {
+ /* :: out of memory :: (or problem too large) */
+ amd_free (Rp) ;
+ amd_free (Ri) ;
+ amd_free (Len) ;
+ amd_free (Pinv) ;
+ if (info) Info [AMD_STATUS] = AMD_OUT_OF_MEMORY ;
+ return (AMD_OUT_OF_MEMORY) ;
+ }
+ if (info)
+ {
+ /* memory usage, in bytes. */
+ Info [AMD_MEMORY] = mem * sizeof (Int) ;
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* order the matrix */
+ /* --------------------------------------------------------------------- */
+
+ AMD_1 (n, Cp, Ci, P, Pinv, Len, slen, S, Control, Info) ;
+
+ /* --------------------------------------------------------------------- */
+ /* free the workspace */
+ /* --------------------------------------------------------------------- */
+
+ amd_free (Rp) ;
+ amd_free (Ri) ;
+ amd_free (Len) ;
+ amd_free (Pinv) ;
+ amd_free (S) ;
+ if (info) Info [AMD_STATUS] = status ;
+ return (status) ; /* successful ordering */
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_post_tree.c b/test/monniaux/glpk-4.65/src/amd/amd_post_tree.c
new file mode 100644
index 00000000..bff0e263
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_post_tree.c
@@ -0,0 +1,121 @@
+/* ========================================================================= */
+/* === AMD_post_tree ======================================================= */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* Post-ordering of a supernodal elimination tree. */
+
+#include "amd_internal.h"
+
+GLOBAL Int AMD_post_tree
+(
+ Int root, /* root of the tree */
+ Int k, /* start numbering at k */
+ Int Child [ ], /* input argument of size nn, undefined on
+ * output. Child [i] is the head of a link
+ * list of all nodes that are children of node
+ * i in the tree. */
+ const Int Sibling [ ], /* input argument of size nn, not modified.
+ * If f is a node in the link list of the
+ * children of node i, then Sibling [f] is the
+ * next child of node i.
+ */
+ Int Order [ ], /* output order, of size nn. Order [i] = k
+ * if node i is the kth node of the reordered
+ * tree. */
+ Int Stack [ ] /* workspace of size nn */
+#ifndef NDEBUG
+ , Int nn /* nodes are in the range 0..nn-1. */
+#endif
+)
+{
+ Int f, head, h, i ;
+
+#if 0
+ /* --------------------------------------------------------------------- */
+ /* recursive version (Stack [ ] is not used): */
+ /* --------------------------------------------------------------------- */
+
+ /* this is simple, but can caouse stack overflow if nn is large */
+ i = root ;
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ k = AMD_post_tree (f, k, Child, Sibling, Order, Stack, nn) ;
+ }
+ Order [i] = k++ ;
+ return (k) ;
+#endif
+
+ /* --------------------------------------------------------------------- */
+ /* non-recursive version, using an explicit stack */
+ /* --------------------------------------------------------------------- */
+
+ /* push root on the stack */
+ head = 0 ;
+ Stack [0] = root ;
+
+ while (head >= 0)
+ {
+ /* get head of stack */
+ ASSERT (head < nn) ;
+ i = Stack [head] ;
+ AMD_DEBUG1 (("head of stack "ID" \n", i)) ;
+ ASSERT (i >= 0 && i < nn) ;
+
+ if (Child [i] != EMPTY)
+ {
+ /* the children of i are not yet ordered */
+ /* push each child onto the stack in reverse order */
+ /* so that small ones at the head of the list get popped first */
+ /* and the biggest one at the end of the list gets popped last */
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ head++ ;
+ ASSERT (head < nn) ;
+ ASSERT (f >= 0 && f < nn) ;
+ }
+ h = head ;
+ ASSERT (head < nn) ;
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ ASSERT (h > 0) ;
+ Stack [h--] = f ;
+ AMD_DEBUG1 (("push "ID" on stack\n", f)) ;
+ ASSERT (f >= 0 && f < nn) ;
+ }
+ ASSERT (Stack [h] == i) ;
+
+ /* delete child list so that i gets ordered next time we see it */
+ Child [i] = EMPTY ;
+ }
+ else
+ {
+ /* the children of i (if there were any) are already ordered */
+ /* remove i from the stack and order it. Front i is kth front */
+ head-- ;
+ AMD_DEBUG1 (("pop "ID" order "ID"\n", i, k)) ;
+ Order [i] = k++ ;
+ ASSERT (k <= nn) ;
+ }
+
+#ifndef NDEBUG
+ AMD_DEBUG1 (("\nStack:")) ;
+ for (h = head ; h >= 0 ; h--)
+ {
+ Int j = Stack [h] ;
+ AMD_DEBUG1 ((" "ID, j)) ;
+ ASSERT (j >= 0 && j < nn) ;
+ }
+ AMD_DEBUG1 (("\n\n")) ;
+ ASSERT (head < nn) ;
+#endif
+
+ }
+ return (k) ;
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_postorder.c b/test/monniaux/glpk-4.65/src/amd/amd_postorder.c
new file mode 100644
index 00000000..a3ece915
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_postorder.c
@@ -0,0 +1,207 @@
+/* ========================================================================= */
+/* === AMD_postorder ======================================================= */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* Perform a postordering (via depth-first search) of an assembly tree. */
+
+#include "amd_internal.h"
+
+GLOBAL void AMD_postorder
+(
+ /* inputs, not modified on output: */
+ Int nn, /* nodes are in the range 0..nn-1 */
+ Int Parent [ ], /* Parent [j] is the parent of j, or EMPTY if root */
+ Int Nv [ ], /* Nv [j] > 0 number of pivots represented by node j,
+ * or zero if j is not a node. */
+ Int Fsize [ ], /* Fsize [j]: size of node j */
+
+ /* output, not defined on input: */
+ Int Order [ ], /* output post-order */
+
+ /* workspaces of size nn: */
+ Int Child [ ],
+ Int Sibling [ ],
+ Int Stack [ ]
+)
+{
+ Int i, j, k, parent, frsize, f, fprev, maxfrsize, bigfprev, bigf, fnext ;
+
+ for (j = 0 ; j < nn ; j++)
+ {
+ Child [j] = EMPTY ;
+ Sibling [j] = EMPTY ;
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* place the children in link lists - bigger elements tend to be last */
+ /* --------------------------------------------------------------------- */
+
+ for (j = nn-1 ; j >= 0 ; j--)
+ {
+ if (Nv [j] > 0)
+ {
+ /* this is an element */
+ parent = Parent [j] ;
+ if (parent != EMPTY)
+ {
+ /* place the element in link list of the children its parent */
+ /* bigger elements will tend to be at the end of the list */
+ Sibling [j] = Child [parent] ;
+ Child [parent] = j ;
+ }
+ }
+ }
+
+#ifndef NDEBUG
+ {
+ Int nels, ff, nchild ;
+ AMD_DEBUG1 (("\n\n================================ AMD_postorder:\n"));
+ nels = 0 ;
+ for (j = 0 ; j < nn ; j++)
+ {
+ if (Nv [j] > 0)
+ {
+ AMD_DEBUG1 (( ""ID" : nels "ID" npiv "ID" size "ID
+ " parent "ID" maxfr "ID"\n", j, nels,
+ Nv [j], Fsize [j], Parent [j], Fsize [j])) ;
+ /* this is an element */
+ /* dump the link list of children */
+ nchild = 0 ;
+ AMD_DEBUG1 ((" Children: ")) ;
+ for (ff = Child [j] ; ff != EMPTY ; ff = Sibling [ff])
+ {
+ AMD_DEBUG1 ((ID" ", ff)) ;
+ ASSERT (Parent [ff] == j) ;
+ nchild++ ;
+ ASSERT (nchild < nn) ;
+ }
+ AMD_DEBUG1 (("\n")) ;
+ parent = Parent [j] ;
+ if (parent != EMPTY)
+ {
+ ASSERT (Nv [parent] > 0) ;
+ }
+ nels++ ;
+ }
+ }
+ }
+ AMD_DEBUG1 (("\n\nGo through the children of each node, and put\n"
+ "the biggest child last in each list:\n")) ;
+#endif
+
+ /* --------------------------------------------------------------------- */
+ /* place the largest child last in the list of children for each node */
+ /* --------------------------------------------------------------------- */
+
+ for (i = 0 ; i < nn ; i++)
+ {
+ if (Nv [i] > 0 && Child [i] != EMPTY)
+ {
+
+#ifndef NDEBUG
+ Int nchild ;
+ AMD_DEBUG1 (("Before partial sort, element "ID"\n", i)) ;
+ nchild = 0 ;
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ ASSERT (f >= 0 && f < nn) ;
+ AMD_DEBUG1 ((" f: "ID" size: "ID"\n", f, Fsize [f])) ;
+ nchild++ ;
+ ASSERT (nchild <= nn) ;
+ }
+#endif
+
+ /* find the biggest element in the child list */
+ fprev = EMPTY ;
+ maxfrsize = EMPTY ;
+ bigfprev = EMPTY ;
+ bigf = EMPTY ;
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ ASSERT (f >= 0 && f < nn) ;
+ frsize = Fsize [f] ;
+ if (frsize >= maxfrsize)
+ {
+ /* this is the biggest seen so far */
+ maxfrsize = frsize ;
+ bigfprev = fprev ;
+ bigf = f ;
+ }
+ fprev = f ;
+ }
+ ASSERT (bigf != EMPTY) ;
+
+ fnext = Sibling [bigf] ;
+
+ AMD_DEBUG1 (("bigf "ID" maxfrsize "ID" bigfprev "ID" fnext "ID
+ " fprev " ID"\n", bigf, maxfrsize, bigfprev, fnext, fprev)) ;
+
+ if (fnext != EMPTY)
+ {
+ /* if fnext is EMPTY then bigf is already at the end of list */
+
+ if (bigfprev == EMPTY)
+ {
+ /* delete bigf from the element of the list */
+ Child [i] = fnext ;
+ }
+ else
+ {
+ /* delete bigf from the middle of the list */
+ Sibling [bigfprev] = fnext ;
+ }
+
+ /* put bigf at the end of the list */
+ Sibling [bigf] = EMPTY ;
+ ASSERT (Child [i] != EMPTY) ;
+ ASSERT (fprev != bigf) ;
+ ASSERT (fprev != EMPTY) ;
+ Sibling [fprev] = bigf ;
+ }
+
+#ifndef NDEBUG
+ AMD_DEBUG1 (("After partial sort, element "ID"\n", i)) ;
+ for (f = Child [i] ; f != EMPTY ; f = Sibling [f])
+ {
+ ASSERT (f >= 0 && f < nn) ;
+ AMD_DEBUG1 ((" "ID" "ID"\n", f, Fsize [f])) ;
+ ASSERT (Nv [f] > 0) ;
+ nchild-- ;
+ }
+ ASSERT (nchild == 0) ;
+#endif
+
+ }
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* postorder the assembly tree */
+ /* --------------------------------------------------------------------- */
+
+ for (i = 0 ; i < nn ; i++)
+ {
+ Order [i] = EMPTY ;
+ }
+
+ k = 0 ;
+
+ for (i = 0 ; i < nn ; i++)
+ {
+ if (Parent [i] == EMPTY && Nv [i] > 0)
+ {
+ AMD_DEBUG1 (("Root of assembly tree "ID"\n", i)) ;
+ k = AMD_post_tree (i, k, Child, Sibling, Order, Stack
+#ifndef NDEBUG
+ , nn
+#endif
+ ) ;
+ }
+ }
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_preprocess.c b/test/monniaux/glpk-4.65/src/amd/amd_preprocess.c
new file mode 100644
index 00000000..fc223fb5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_preprocess.c
@@ -0,0 +1,119 @@
+/* ========================================================================= */
+/* === AMD_preprocess ====================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* Sorts, removes duplicate entries, and transposes from the nonzero pattern of
+ * a column-form matrix A, to obtain the matrix R. The input matrix can have
+ * duplicate entries and/or unsorted columns (AMD_valid (n,Ap,Ai) must not be
+ * AMD_INVALID).
+ *
+ * This input condition is NOT checked. This routine is not user-callable.
+ */
+
+#include "amd_internal.h"
+
+/* ========================================================================= */
+/* === AMD_preprocess ====================================================== */
+/* ========================================================================= */
+
+/* AMD_preprocess does not check its input for errors or allocate workspace.
+ * On input, the condition (AMD_valid (n,n,Ap,Ai) != AMD_INVALID) must hold.
+ */
+
+GLOBAL void AMD_preprocess
+(
+ Int n, /* input matrix: A is n-by-n */
+ const Int Ap [ ], /* size n+1 */
+ const Int Ai [ ], /* size nz = Ap [n] */
+
+ /* output matrix R: */
+ Int Rp [ ], /* size n+1 */
+ Int Ri [ ], /* size nz (or less, if duplicates present) */
+
+ Int W [ ], /* workspace of size n */
+ Int Flag [ ] /* workspace of size n */
+)
+{
+
+ /* --------------------------------------------------------------------- */
+ /* local variables */
+ /* --------------------------------------------------------------------- */
+
+ Int i, j, p, p2 ;
+
+ ASSERT (AMD_valid (n, n, Ap, Ai) != AMD_INVALID) ;
+
+ /* --------------------------------------------------------------------- */
+ /* count the entries in each row of A (excluding duplicates) */
+ /* --------------------------------------------------------------------- */
+
+ for (i = 0 ; i < n ; i++)
+ {
+ W [i] = 0 ; /* # of nonzeros in row i (excl duplicates) */
+ Flag [i] = EMPTY ; /* Flag [i] = j if i appears in column j */
+ }
+ for (j = 0 ; j < n ; j++)
+ {
+ p2 = Ap [j+1] ;
+ for (p = Ap [j] ; p < p2 ; p++)
+ {
+ i = Ai [p] ;
+ if (Flag [i] != j)
+ {
+ /* row index i has not yet appeared in column j */
+ W [i]++ ; /* one more entry in row i */
+ Flag [i] = j ; /* flag row index i as appearing in col j*/
+ }
+ }
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* compute the row pointers for R */
+ /* --------------------------------------------------------------------- */
+
+ Rp [0] = 0 ;
+ for (i = 0 ; i < n ; i++)
+ {
+ Rp [i+1] = Rp [i] + W [i] ;
+ }
+ for (i = 0 ; i < n ; i++)
+ {
+ W [i] = Rp [i] ;
+ Flag [i] = EMPTY ;
+ }
+
+ /* --------------------------------------------------------------------- */
+ /* construct the row form matrix R */
+ /* --------------------------------------------------------------------- */
+
+ /* R = row form of pattern of A */
+ for (j = 0 ; j < n ; j++)
+ {
+ p2 = Ap [j+1] ;
+ for (p = Ap [j] ; p < p2 ; p++)
+ {
+ i = Ai [p] ;
+ if (Flag [i] != j)
+ {
+ /* row index i has not yet appeared in column j */
+ Ri [W [i]++] = j ; /* put col j in row i */
+ Flag [i] = j ; /* flag row index i as appearing in col j*/
+ }
+ }
+ }
+
+#ifndef NDEBUG
+ ASSERT (AMD_valid (n, n, Rp, Ri) == AMD_OK) ;
+ for (j = 0 ; j < n ; j++)
+ {
+ ASSERT (W [j] == Rp [j+1]) ;
+ }
+#endif
+}
diff --git a/test/monniaux/glpk-4.65/src/amd/amd_valid.c b/test/monniaux/glpk-4.65/src/amd/amd_valid.c
new file mode 100644
index 00000000..e9e2e5ab
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/amd/amd_valid.c
@@ -0,0 +1,93 @@
+/* ========================================================================= */
+/* === AMD_valid =========================================================== */
+/* ========================================================================= */
+
+/* ------------------------------------------------------------------------- */
+/* AMD, Copyright (c) Timothy A. Davis, */
+/* Patrick R. Amestoy, and Iain S. Duff. See ../README.txt for License. */
+/* email: davis at cise.ufl.edu CISE Department, Univ. of Florida. */
+/* web: http://www.cise.ufl.edu/research/sparse/amd */
+/* ------------------------------------------------------------------------- */
+
+/* Check if a column-form matrix is valid or not. The matrix A is
+ * n_row-by-n_col. The row indices of entries in column j are in
+ * Ai [Ap [j] ... Ap [j+1]-1]. Required conditions are:
+ *
+ * n_row >= 0
+ * n_col >= 0
+ * nz = Ap [n_col] >= 0 number of entries in the matrix
+ * Ap [0] == 0
+ * Ap [j] <= Ap [j+1] for all j in the range 0 to n_col.
+ * Ai [0 ... nz-1] must be in the range 0 to n_row-1.
+ *
+ * If any of the above conditions hold, AMD_INVALID is returned. If the
+ * following condition holds, AMD_OK_BUT_JUMBLED is returned (a warning,
+ * not an error):
+ *
+ * row indices in Ai [Ap [j] ... Ap [j+1]-1] are not sorted in ascending
+ * order, and/or duplicate entries exist.
+ *
+ * Otherwise, AMD_OK is returned.
+ *
+ * In v1.2 and earlier, this function returned TRUE if the matrix was valid
+ * (now returns AMD_OK), or FALSE otherwise (now returns AMD_INVALID or
+ * AMD_OK_BUT_JUMBLED).
+ */
+
+#include "amd_internal.h"
+
+GLOBAL Int AMD_valid
+(
+ /* inputs, not modified on output: */
+ Int n_row, /* A is n_row-by-n_col */
+ Int n_col,
+ const Int Ap [ ], /* column pointers of A, of size n_col+1 */
+ const Int Ai [ ] /* row indices of A, of size nz = Ap [n_col] */
+)
+{
+ Int nz, j, p1, p2, ilast, i, p, result = AMD_OK ;
+
+ if (n_row < 0 || n_col < 0 || Ap == NULL || Ai == NULL)
+ {
+ return (AMD_INVALID) ;
+ }
+ nz = Ap [n_col] ;
+ if (Ap [0] != 0 || nz < 0)
+ {
+ /* column pointers must start at Ap [0] = 0, and Ap [n] must be >= 0 */
+ AMD_DEBUG0 (("column 0 pointer bad or nz < 0\n")) ;
+ return (AMD_INVALID) ;
+ }
+ for (j = 0 ; j < n_col ; j++)
+ {
+ p1 = Ap [j] ;
+ p2 = Ap [j+1] ;
+ AMD_DEBUG2 (("\nColumn: "ID" p1: "ID" p2: "ID"\n", j, p1, p2)) ;
+ if (p1 > p2)
+ {
+ /* column pointers must be ascending */
+ AMD_DEBUG0 (("column "ID" pointer bad\n", j)) ;
+ return (AMD_INVALID) ;
+ }
+ ilast = EMPTY ;
+ for (p = p1 ; p < p2 ; p++)
+ {
+ i = Ai [p] ;
+ AMD_DEBUG3 (("row: "ID"\n", i)) ;
+ if (i < 0 || i >= n_row)
+ {
+ /* row index out of range */
+ AMD_DEBUG0 (("index out of range, col "ID" row "ID"\n", j, i));
+ return (AMD_INVALID) ;
+ }
+ if (i <= ilast)
+ {
+ /* row index unsorted, or duplicate entry present */
+ AMD_DEBUG1 (("index unsorted/dupl col "ID" row "ID"\n", j, i));
+ result = AMD_OK_BUT_JUMBLED ;
+ }
+ ilast = i ;
+ }
+ }
+ return (result) ;
+}
diff --git a/test/monniaux/glpk-4.65/src/api/advbas.c b/test/monniaux/glpk-4.65/src/api/advbas.c
new file mode 100644
index 00000000..23067624
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/advbas.c
@@ -0,0 +1,155 @@
+/* advbas.c (construct advanced initial LP basis) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+#include "triang.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_adv_basis - construct advanced initial LP basis
+*
+* SYNOPSIS
+*
+* void glp_adv_basis(glp_prob *P, int flags);
+*
+* DESCRIPTION
+*
+* The routine glp_adv_basis constructs an advanced initial LP basis
+* for the specified problem object.
+*
+* The parameter flag is reserved for use in the future and should be
+* specified as zero.
+*
+* NOTE
+*
+* The routine glp_adv_basis should be called after the constraint
+* matrix has been scaled (if scaling is used). */
+
+static int mat(void *info, int k, int ind[], double val[])
+{ glp_prob *P = info;
+ int m = P->m;
+ int n = P->n;
+ GLPROW **row = P->row;
+ GLPCOL **col = P->col;
+ GLPAIJ *aij;
+ int i, j, len;
+ if (k > 0)
+ { /* retrieve scaled row of constraint matrix */
+ i = +k;
+ xassert(1 <= i && i <= m);
+ len = 0;
+ if (row[i]->type == GLP_FX)
+ { for (aij = row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { j = aij->col->j;
+ if (col[j]->type != GLP_FX)
+ { len++;
+ ind[len] = j;
+ val[len] = aij->row->rii * aij->val * aij->col->sjj;
+ }
+ }
+ }
+ }
+ else
+ { /* retrieve scaled column of constraint matrix */
+ j = -k;
+ xassert(1 <= j && j <= n);
+ len = 0;
+ if (col[j]->type != GLP_FX)
+ { for (aij = col[j]->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row->i;
+ if (row[i]->type == GLP_FX)
+ { len++;
+ ind[len] = i;
+ val[len] = aij->row->rii * aij->val * aij->col->sjj;
+ }
+ }
+ }
+ }
+ return len;
+}
+
+void glp_adv_basis(glp_prob *P, int flags)
+{ int i, j, k, m, n, min_mn, size, *rn, *cn;
+ char *flag;
+ if (flags != 0)
+ xerror("glp_adv_basis: flags = %d; invalid flags\n", flags);
+ m = P->m; /* number of rows */
+ n = P->n; /* number of columns */
+ if (m == 0 || n == 0)
+ { /* trivial case */
+ glp_std_basis(P);
+ goto done;
+ }
+ xprintf("Constructing initial basis...\n");
+ /* allocate working arrays */
+ min_mn = (m < n ? m : n);
+ rn = talloc(1+min_mn, int);
+ cn = talloc(1+min_mn, int);
+ flag = talloc(1+m, char);
+ /* make the basis empty */
+ for (i = 1; i <= m; i++)
+ { flag[i] = 0;
+ glp_set_row_stat(P, i, GLP_NS);
+ }
+ for (j = 1; j <= n; j++)
+ glp_set_col_stat(P, j, GLP_NS);
+ /* find maximal triangular part of the constraint matrix;
+ to prevent including non-fixed rows and fixed columns in the
+ triangular part, such rows and columns are temporarily made
+ empty by the routine mat */
+#if 1 /* FIXME: tolerance */
+ size = triang(m, n, mat, P, 0.001, rn, cn);
+#endif
+ xassert(0 <= size && size <= min_mn);
+ /* include in the basis non-fixed structural variables, whose
+ columns constitute the triangular part */
+ for (k = 1; k <= size; k++)
+ { i = rn[k];
+ xassert(1 <= i && i <= m);
+ flag[i] = 1;
+ j = cn[k];
+ xassert(1 <= j && j <= n);
+ glp_set_col_stat(P, j, GLP_BS);
+ }
+ /* include in the basis appropriate auxiliary variables, whose
+ unity columns preserve triangular form of the basis matrix */
+ for (i = 1; i <= m; i++)
+ { if (flag[i] == 0)
+ { glp_set_row_stat(P, i, GLP_BS);
+ if (P->row[i]->type != GLP_FX)
+ size++;
+ }
+ }
+ /* size of triangular part = (number of rows) - (number of basic
+ fixed auxiliary variables) */
+ xprintf("Size of triangular part is %d\n", size);
+ /* deallocate working arrays */
+ tfree(rn);
+ tfree(cn);
+ tfree(flag);
+done: return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/asnhall.c b/test/monniaux/glpk-4.65/src/api/asnhall.c
new file mode 100644
index 00000000..d7112a10
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/asnhall.c
@@ -0,0 +1,163 @@
+/* asnhall.c (find bipartite matching of maximum cardinality) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "mc21a.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_asnprob_hall - find bipartite matching of maximum cardinality
+*
+* SYNOPSIS
+*
+* int glp_asnprob_hall(glp_graph *G, int v_set, int a_x);
+*
+* DESCRIPTION
+*
+* The routine glp_asnprob_hall finds a matching of maximal cardinality
+* in the specified bipartite graph G. It uses a version of the Fortran
+* routine MC21A developed by I.S.Duff [1], which implements Hall's
+* algorithm [2].
+*
+* RETURNS
+*
+* The routine glp_asnprob_hall returns the cardinality of the matching
+* found. However, if the specified graph is incorrect (as detected by
+* the routine glp_check_asnprob), the routine returns negative value.
+*
+* REFERENCES
+*
+* 1. I.S.Duff, Algorithm 575: Permutations for zero-free diagonal, ACM
+* Trans. on Math. Softw. 7 (1981), 387-390.
+*
+* 2. M.Hall, "An Algorithm for distinct representatives," Amer. Math.
+* Monthly 63 (1956), 716-717. */
+
+int glp_asnprob_hall(glp_graph *G, int v_set, int a_x)
+{ glp_vertex *v;
+ glp_arc *a;
+ int card, i, k, loc, n, n1, n2, xij;
+ int *num, *icn, *ip, *lenr, *iperm, *pr, *arp, *cv, *out;
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_asnprob_hall: v_set = %d; invalid offset\n",
+ v_set);
+ if (a_x >= 0 && a_x > G->a_size - (int)sizeof(int))
+ xerror("glp_asnprob_hall: a_x = %d; invalid offset\n", a_x);
+ if (glp_check_asnprob(G, v_set))
+ return -1;
+ /* determine the number of vertices in sets R and S and renumber
+ vertices in S which correspond to columns of the matrix; skip
+ all isolated vertices */
+ num = xcalloc(1+G->nv, sizeof(int));
+ n1 = n2 = 0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (v->in == NULL && v->out != NULL)
+ n1++, num[i] = 0; /* vertex in R */
+ else if (v->in != NULL && v->out == NULL)
+ n2++, num[i] = n2; /* vertex in S */
+ else
+ { xassert(v->in == NULL && v->out == NULL);
+ num[i] = -1; /* isolated vertex */
+ }
+ }
+ /* the matrix must be square, thus, if it has more columns than
+ rows, extra rows will be just empty, and vice versa */
+ n = (n1 >= n2 ? n1 : n2);
+ /* allocate working arrays */
+ icn = xcalloc(1+G->na, sizeof(int));
+ ip = xcalloc(1+n, sizeof(int));
+ lenr = xcalloc(1+n, sizeof(int));
+ iperm = xcalloc(1+n, sizeof(int));
+ pr = xcalloc(1+n, sizeof(int));
+ arp = xcalloc(1+n, sizeof(int));
+ cv = xcalloc(1+n, sizeof(int));
+ out = xcalloc(1+n, sizeof(int));
+ /* build the adjacency matrix of the bipartite graph in row-wise
+ format (rows are vertices in R, columns are vertices in S) */
+ k = 0, loc = 1;
+ for (i = 1; i <= G->nv; i++)
+ { if (num[i] != 0) continue;
+ /* vertex i in R */
+ ip[++k] = loc;
+ v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { xassert(num[a->head->i] != 0);
+ icn[loc++] = num[a->head->i];
+ }
+ lenr[k] = loc - ip[k];
+ }
+ xassert(loc-1 == G->na);
+ /* make all extra rows empty (all extra columns are empty due to
+ the row-wise format used) */
+ for (k++; k <= n; k++)
+ ip[k] = loc, lenr[k] = 0;
+ /* find a row permutation that maximizes the number of non-zeros
+ on the main diagonal */
+ card = mc21a(n, icn, ip, lenr, iperm, pr, arp, cv, out);
+#if 1 /* 18/II-2010 */
+ /* FIXED: if card = n, arp remains clobbered on exit */
+ for (i = 1; i <= n; i++)
+ arp[i] = 0;
+ for (i = 1; i <= card; i++)
+ { k = iperm[i];
+ xassert(1 <= k && k <= n);
+ xassert(arp[k] == 0);
+ arp[k] = i;
+ }
+#endif
+ /* store solution, if necessary */
+ if (a_x < 0) goto skip;
+ k = 0;
+ for (i = 1; i <= G->nv; i++)
+ { if (num[i] != 0) continue;
+ /* vertex i in R */
+ k++;
+ v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { /* arp[k] is the number of matched column or zero */
+ if (arp[k] == num[a->head->i])
+ { xassert(arp[k] != 0);
+ xij = 1;
+ }
+ else
+ xij = 0;
+ memcpy((char *)a->data + a_x, &xij, sizeof(int));
+ }
+ }
+skip: /* free working arrays */
+ xfree(num);
+ xfree(icn);
+ xfree(ip);
+ xfree(lenr);
+ xfree(iperm);
+ xfree(pr);
+ xfree(arp);
+ xfree(cv);
+ xfree(out);
+ return card;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/asnlp.c b/test/monniaux/glpk-4.65/src/api/asnlp.c
new file mode 100644
index 00000000..cfa925d0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/asnlp.c
@@ -0,0 +1,104 @@
+/* asnlp.c (convert assignment problem to LP) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_asnprob_lp - convert assignment problem to LP
+*
+* SYNOPSIS
+*
+* int glp_asnprob_lp(glp_prob *P, int form, glp_graph *G, int names,
+* int v_set, int a_cost);
+*
+* DESCRIPTION
+*
+* The routine glp_asnprob_lp builds an LP problem, which corresponds
+* to the assignment problem on the specified graph G.
+*
+* RETURNS
+*
+* If the LP problem has been successfully built, the routine returns
+* zero, otherwise, non-zero. */
+
+int glp_asnprob_lp(glp_prob *P, int form, glp_graph *G, int names,
+ int v_set, int a_cost)
+{ glp_vertex *v;
+ glp_arc *a;
+ int i, j, ret, ind[1+2];
+ double cost, val[1+2];
+ if (!(form == GLP_ASN_MIN || form == GLP_ASN_MAX ||
+ form == GLP_ASN_MMP))
+ xerror("glp_asnprob_lp: form = %d; invalid parameter\n",
+ form);
+ if (!(names == GLP_ON || names == GLP_OFF))
+ xerror("glp_asnprob_lp: names = %d; invalid parameter\n",
+ names);
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_asnprob_lp: v_set = %d; invalid offset\n",
+ v_set);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_asnprob_lp: a_cost = %d; invalid offset\n",
+ a_cost);
+ ret = glp_check_asnprob(G, v_set);
+ if (ret != 0) goto done;
+ glp_erase_prob(P);
+ if (names) glp_set_prob_name(P, G->name);
+ glp_set_obj_dir(P, form == GLP_ASN_MIN ? GLP_MIN : GLP_MAX);
+ if (G->nv > 0) glp_add_rows(P, G->nv);
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (names) glp_set_row_name(P, i, v->name);
+ glp_set_row_bnds(P, i, form == GLP_ASN_MMP ? GLP_UP : GLP_FX,
+ 1.0, 1.0);
+ }
+ if (G->na > 0) glp_add_cols(P, G->na);
+ for (i = 1, j = 0; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { j++;
+ if (names)
+ { char name[50+1];
+ sprintf(name, "x[%d,%d]", a->tail->i, a->head->i);
+ xassert(strlen(name) < sizeof(name));
+ glp_set_col_name(P, j, name);
+ }
+ ind[1] = a->tail->i, val[1] = +1.0;
+ ind[2] = a->head->i, val[2] = +1.0;
+ glp_set_mat_col(P, j, 2, ind, val);
+ glp_set_col_bnds(P, j, GLP_DB, 0.0, 1.0);
+ if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 1.0;
+ glp_set_obj_coef(P, j, cost);
+ }
+ }
+ xassert(j == G->na);
+done: return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/asnokalg.c b/test/monniaux/glpk-4.65/src/api/asnokalg.c
new file mode 100644
index 00000000..d55dbac7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/asnokalg.c
@@ -0,0 +1,154 @@
+/* asnokalg.c (solve assignment problem with out-of-kilter alg.) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "okalg.h"
+
+int glp_asnprob_okalg(int form, glp_graph *G, int v_set, int a_cost,
+ double *sol, int a_x)
+{ /* solve assignment problem with out-of-kilter algorithm */
+ glp_vertex *v;
+ glp_arc *a;
+ int nv, na, i, k, *tail, *head, *low, *cap, *cost, *x, *pi, ret;
+ double temp;
+ if (!(form == GLP_ASN_MIN || form == GLP_ASN_MAX ||
+ form == GLP_ASN_MMP))
+ xerror("glp_asnprob_okalg: form = %d; invalid parameter\n",
+ form);
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_asnprob_okalg: v_set = %d; invalid offset\n",
+ v_set);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_asnprob_okalg: a_cost = %d; invalid offset\n",
+ a_cost);
+ if (a_x >= 0 && a_x > G->a_size - (int)sizeof(int))
+ xerror("glp_asnprob_okalg: a_x = %d; invalid offset\n", a_x);
+ if (glp_check_asnprob(G, v_set))
+ return GLP_EDATA;
+ /* nv is the total number of nodes in the resulting network */
+ nv = G->nv + 1;
+ /* na is the total number of arcs in the resulting network */
+ na = G->na + G->nv;
+ /* allocate working arrays */
+ tail = xcalloc(1+na, sizeof(int));
+ head = xcalloc(1+na, sizeof(int));
+ low = xcalloc(1+na, sizeof(int));
+ cap = xcalloc(1+na, sizeof(int));
+ cost = xcalloc(1+na, sizeof(int));
+ x = xcalloc(1+na, sizeof(int));
+ pi = xcalloc(1+nv, sizeof(int));
+ /* construct the resulting network */
+ k = 0;
+ /* (original arcs) */
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ tail[k] = a->tail->i;
+ head[k] = a->head->i;
+ low[k] = 0;
+ cap[k] = 1;
+ if (a_cost >= 0)
+ memcpy(&temp, (char *)a->data + a_cost, sizeof(double));
+ else
+ temp = 1.0;
+ if (!(fabs(temp) <= (double)INT_MAX && temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ cost[k] = (int)temp;
+ if (form != GLP_ASN_MIN) cost[k] = - cost[k];
+ }
+ }
+ /* (artificial arcs) */
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ k++;
+ if (v->out == NULL)
+ tail[k] = i, head[k] = nv;
+ else if (v->in == NULL)
+ tail[k] = nv, head[k] = i;
+ else
+ xassert(v != v);
+ low[k] = (form == GLP_ASN_MMP ? 0 : 1);
+ cap[k] = 1;
+ cost[k] = 0;
+ }
+ xassert(k == na);
+ /* find minimal-cost circulation in the resulting network */
+ ret = okalg(nv, na, tail, head, low, cap, cost, x, pi);
+ switch (ret)
+ { case 0:
+ /* optimal circulation found */
+ ret = 0;
+ break;
+ case 1:
+ /* no feasible circulation exists */
+ ret = GLP_ENOPFS;
+ break;
+ case 2:
+ /* integer overflow occured */
+ ret = GLP_ERANGE;
+ goto done;
+ case 3:
+ /* optimality test failed (logic error) */
+ ret = GLP_EFAIL;
+ goto done;
+ default:
+ xassert(ret != ret);
+ }
+ /* store solution components */
+ /* (objective function = the total cost) */
+ if (sol != NULL)
+ { temp = 0.0;
+ for (k = 1; k <= na; k++)
+ temp += (double)cost[k] * (double)x[k];
+ if (form != GLP_ASN_MIN) temp = - temp;
+ *sol = temp;
+ }
+ /* (arc flows) */
+ if (a_x >= 0)
+ { k = 0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ if (ret == 0)
+ xassert(x[k] == 0 || x[k] == 1);
+ memcpy((char *)a->data + a_x, &x[k], sizeof(int));
+ }
+ }
+ }
+done: /* free working arrays */
+ xfree(tail);
+ xfree(head);
+ xfree(low);
+ xfree(cap);
+ xfree(cost);
+ xfree(x);
+ xfree(pi);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/ckasn.c b/test/monniaux/glpk-4.65/src/api/ckasn.c
new file mode 100644
index 00000000..56221a8a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/ckasn.c
@@ -0,0 +1,78 @@
+/* ckasn.c (check correctness of assignment problem data) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_check_asnprob - check correctness of assignment problem data
+*
+* SYNOPSIS
+*
+* int glp_check_asnprob(glp_graph *G, int v_set);
+*
+* RETURNS
+*
+* If the specified assignment problem data are correct, the routine
+* glp_check_asnprob returns zero, otherwise, non-zero. */
+
+int glp_check_asnprob(glp_graph *G, int v_set)
+{ glp_vertex *v;
+ int i, k, ret = 0;
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_check_asnprob: v_set = %d; invalid offset\n",
+ v_set);
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (v_set >= 0)
+ { memcpy(&k, (char *)v->data + v_set, sizeof(int));
+ if (k == 0)
+ { if (v->in != NULL)
+ { ret = 1;
+ break;
+ }
+ }
+ else if (k == 1)
+ { if (v->out != NULL)
+ { ret = 2;
+ break;
+ }
+ }
+ else
+ { ret = 3;
+ break;
+ }
+ }
+ else
+ { if (v->in != NULL && v->out != NULL)
+ { ret = 4;
+ break;
+ }
+ }
+ }
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/ckcnf.c b/test/monniaux/glpk-4.65/src/api/ckcnf.c
new file mode 100644
index 00000000..0ee47ed9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/ckcnf.c
@@ -0,0 +1,82 @@
+/* ckcnf.c (check for CNF-SAT problem instance) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+int glp_check_cnfsat(glp_prob *P)
+{ /* check for CNF-SAT problem instance */
+ int m = P->m;
+ int n = P->n;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, j, neg;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_check_cnfsat: P = %p; invalid problem object\n",
+ P);
+#endif
+ /* check columns */
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ /* the variable should be binary */
+ if (!(col->kind == GLP_IV && col->type == GLP_DB &&
+ col->lb == 0.0 && col->ub == 1.0))
+ return 1;
+ }
+ /* objective function should be zero */
+ if (P->c0 != 0.0)
+ return 2;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ if (col->coef != 0.0)
+ return 3;
+ }
+ /* check rows */
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ /* the row should be of ">=" type */
+ if (row->type != GLP_LO)
+ return 4;
+ /* check constraint coefficients */
+ neg = 0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { /* the constraint coefficient should be +1 or -1 */
+ if (aij->val == +1.0)
+ ;
+ else if (aij->val == -1.0)
+ neg++;
+ else
+ return 5;
+ }
+ /* the right-hand side should be (1 - neg), where neg is the
+ number of negative constraint coefficients in the row */
+ if (row->lb != (double)(1 - neg))
+ return 6;
+ }
+ /* congratulations; this is CNF-SAT */
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/cplex.c b/test/monniaux/glpk-4.65/src/api/cplex.c
new file mode 100644
index 00000000..8403a646
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/cplex.c
@@ -0,0 +1,1283 @@
+/* cplex.c (CPLEX LP format routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_init_cpxcp - initialize CPLEX LP format control parameters
+*
+* SYNOPSIS
+*
+* void glp_init_cpxcp(glp_cpxcp *parm):
+*
+* The routine glp_init_cpxcp initializes control parameters used by
+* the CPLEX LP input/output routines glp_read_lp and glp_write_lp with
+* default values.
+*
+* Default values of the control parameters are stored in the glp_cpxcp
+* structure, which the parameter parm points to. */
+
+void glp_init_cpxcp(glp_cpxcp *parm)
+{ xassert(parm != NULL);
+ return;
+}
+
+static void check_parm(const char *func, const glp_cpxcp *parm)
+{ /* check control parameters */
+ xassert(func != NULL);
+ xassert(parm != NULL);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_read_lp - read problem data in CPLEX LP format
+*
+* SYNOPSIS
+*
+* int glp_read_lp(glp_prob *P, const glp_cpxcp *parm, const char
+* *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_lp reads problem data in CPLEX LP format from
+* a text file.
+*
+* The parameter parm is a pointer to the structure glp_cpxcp, which
+* specifies control parameters used by the routine. If parm is NULL,
+* the routine uses default settings.
+*
+* The character string fname specifies a name of the text file to be
+* read.
+*
+* Note that before reading data the current content of the problem
+* object is completely erased with the routine glp_erase_prob.
+*
+* RETURNS
+*
+* If the operation was successful, the routine glp_read_lp returns
+* zero. Otherwise, it prints an error message and returns non-zero. */
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* LP/MIP problem object */
+ const glp_cpxcp *parm;
+ /* pointer to control parameters */
+ const char *fname;
+ /* name of input CPLEX LP file */
+ glp_file *fp;
+ /* stream assigned to input CPLEX LP file */
+ jmp_buf jump;
+ /* label for go to in case of error */
+ int count;
+ /* line count */
+ int c;
+ /* current character or EOF */
+ int token;
+ /* current token: */
+#define T_EOF 0x00 /* end of file */
+#define T_MINIMIZE 0x01 /* keyword 'minimize' */
+#define T_MAXIMIZE 0x02 /* keyword 'maximize' */
+#define T_SUBJECT_TO 0x03 /* keyword 'subject to' */
+#define T_BOUNDS 0x04 /* keyword 'bounds' */
+#define T_GENERAL 0x05 /* keyword 'general' */
+#define T_INTEGER 0x06 /* keyword 'integer' */
+#define T_BINARY 0x07 /* keyword 'binary' */
+#define T_END 0x08 /* keyword 'end' */
+#define T_NAME 0x09 /* symbolic name */
+#define T_NUMBER 0x0A /* numeric constant */
+#define T_PLUS 0x0B /* delimiter '+' */
+#define T_MINUS 0x0C /* delimiter '-' */
+#define T_COLON 0x0D /* delimiter ':' */
+#define T_LE 0x0E /* delimiter '<=' */
+#define T_GE 0x0F /* delimiter '>=' */
+#define T_EQ 0x10 /* delimiter '=' */
+ char image[255+1];
+ /* image of current token */
+ int imlen;
+ /* length of token image */
+ double value;
+ /* value of numeric constant */
+ int n_max;
+ /* length of the following five arrays (enlarged automatically,
+ if necessary) */
+ int *ind; /* int ind[1+n_max]; */
+ double *val; /* double val[1+n_max]; */
+ char *flag; /* char flag[1+n_max]; */
+ /* working arrays used to construct linear forms */
+ double *lb; /* double lb[1+n_max]; */
+ double *ub; /* double ub[1+n_max]; */
+ /* lower and upper bounds of variables (columns) */
+#if 1 /* 27/VII-2013 */
+ int lb_warn, ub_warn;
+ /* warning 'lower/upper bound redefined' already issued */
+#endif
+};
+
+#define CHAR_SET "!\"#$%&()/,.;?@_`'{}|~"
+/* characters that may appear in symbolic names */
+
+static void error(struct csa *csa, const char *fmt, ...)
+{ /* print error message and terminate processing */
+ va_list arg;
+ xprintf("%s:%d: ", csa->fname, csa->count);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ longjmp(csa->jump, 1);
+ /* no return */
+}
+
+static void warning(struct csa *csa, const char *fmt, ...)
+{ /* print warning message and continue processing */
+ va_list arg;
+ xprintf("%s:%d: warning: ", csa->fname, csa->count);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ return;
+}
+
+static void read_char(struct csa *csa)
+{ /* read next character from input file */
+ int c;
+ xassert(csa->c != EOF);
+ if (csa->c == '\n') csa->count++;
+ c = glp_getc(csa->fp);
+ if (c < 0)
+ { if (glp_ioerr(csa->fp))
+ error(csa, "read error - %s\n", get_err_msg());
+ else if (csa->c == '\n')
+ { csa->count--;
+ c = EOF;
+ }
+ else
+ { warning(csa, "missing final end of line\n");
+ c = '\n';
+ }
+ }
+ else if (c == '\n')
+ ;
+ else if (isspace(c))
+ c = ' ';
+ else if (iscntrl(c))
+ error(csa, "invalid control character 0x%02X\n", c);
+ csa->c = c;
+ return;
+}
+
+static void add_char(struct csa *csa)
+{ /* append current character to current token */
+ if (csa->imlen == sizeof(csa->image)-1)
+ error(csa, "token '%.15s...' too long\n", csa->image);
+ csa->image[csa->imlen++] = (char)csa->c;
+ csa->image[csa->imlen] = '\0';
+ read_char(csa);
+ return;
+}
+
+static int the_same(char *s1, char *s2)
+{ /* compare two character strings ignoring case sensitivity */
+ for (; *s1 != '\0'; s1++, s2++)
+ { if (tolower((unsigned char)*s1) != tolower((unsigned char)*s2))
+ return 0;
+ }
+ return 1;
+}
+
+static void scan_token(struct csa *csa)
+{ /* scan next token */
+ int flag;
+ csa->token = -1;
+ csa->image[0] = '\0';
+ csa->imlen = 0;
+ csa->value = 0.0;
+loop: flag = 0;
+ /* skip non-significant characters */
+ while (csa->c == ' ') read_char(csa);
+ /* recognize and scan current token */
+ if (csa->c == EOF)
+ csa->token = T_EOF;
+ else if (csa->c == '\n')
+ { read_char(csa);
+ /* if the next character is letter, it may begin a keyword */
+ if (isalpha(csa->c))
+ { flag = 1;
+ goto name;
+ }
+ goto loop;
+ }
+ else if (csa->c == '\\')
+ { /* comment; ignore everything until end-of-line */
+ while (csa->c != '\n') read_char(csa);
+ goto loop;
+ }
+ else if (isalpha(csa->c) || csa->c != '.' && strchr(CHAR_SET,
+ csa->c) != NULL)
+name: { /* symbolic name */
+ csa->token = T_NAME;
+ while (isalnum(csa->c) || strchr(CHAR_SET, csa->c) != NULL)
+ add_char(csa);
+ if (flag)
+ { /* check for keyword */
+ if (the_same(csa->image, "minimize"))
+ csa->token = T_MINIMIZE;
+ else if (the_same(csa->image, "minimum"))
+ csa->token = T_MINIMIZE;
+ else if (the_same(csa->image, "min"))
+ csa->token = T_MINIMIZE;
+ else if (the_same(csa->image, "maximize"))
+ csa->token = T_MAXIMIZE;
+ else if (the_same(csa->image, "maximum"))
+ csa->token = T_MAXIMIZE;
+ else if (the_same(csa->image, "max"))
+ csa->token = T_MAXIMIZE;
+ else if (the_same(csa->image, "subject"))
+ { if (csa->c == ' ')
+ { read_char(csa);
+ if (tolower(csa->c) == 't')
+ { csa->token = T_SUBJECT_TO;
+ csa->image[csa->imlen++] = ' ';
+ csa->image[csa->imlen] = '\0';
+ add_char(csa);
+ if (tolower(csa->c) != 'o')
+ error(csa, "keyword 'subject to' incomplete\n");
+ add_char(csa);
+ if (isalpha(csa->c))
+ error(csa, "keyword '%s%c...' not recognized\n",
+ csa->image, csa->c);
+ }
+ }
+ }
+ else if (the_same(csa->image, "such"))
+ { if (csa->c == ' ')
+ { read_char(csa);
+ if (tolower(csa->c) == 't')
+ { csa->token = T_SUBJECT_TO;
+ csa->image[csa->imlen++] = ' ';
+ csa->image[csa->imlen] = '\0';
+ add_char(csa);
+ if (tolower(csa->c) != 'h')
+err: error(csa, "keyword 'such that' incomplete\n");
+ add_char(csa);
+ if (tolower(csa->c) != 'a') goto err;
+ add_char(csa);
+ if (tolower(csa->c) != 't') goto err;
+ add_char(csa);
+ if (isalpha(csa->c))
+ error(csa, "keyword '%s%c...' not recognized\n",
+ csa->image, csa->c);
+ }
+ }
+ }
+ else if (the_same(csa->image, "st"))
+ csa->token = T_SUBJECT_TO;
+ else if (the_same(csa->image, "s.t."))
+ csa->token = T_SUBJECT_TO;
+ else if (the_same(csa->image, "st."))
+ csa->token = T_SUBJECT_TO;
+ else if (the_same(csa->image, "bounds"))
+ csa->token = T_BOUNDS;
+ else if (the_same(csa->image, "bound"))
+ csa->token = T_BOUNDS;
+ else if (the_same(csa->image, "general"))
+ csa->token = T_GENERAL;
+ else if (the_same(csa->image, "generals"))
+ csa->token = T_GENERAL;
+ else if (the_same(csa->image, "gen"))
+ csa->token = T_GENERAL;
+ else if (the_same(csa->image, "integer"))
+ csa->token = T_INTEGER;
+ else if (the_same(csa->image, "integers"))
+ csa->token = T_INTEGER;
+ else if (the_same(csa->image, "int"))
+ csa->token = T_INTEGER;
+ else if (the_same(csa->image, "binary"))
+ csa->token = T_BINARY;
+ else if (the_same(csa->image, "binaries"))
+ csa->token = T_BINARY;
+ else if (the_same(csa->image, "bin"))
+ csa->token = T_BINARY;
+ else if (the_same(csa->image, "end"))
+ csa->token = T_END;
+ }
+ }
+ else if (isdigit(csa->c) || csa->c == '.')
+ { /* numeric constant */
+ csa->token = T_NUMBER;
+ /* scan integer part */
+ while (isdigit(csa->c)) add_char(csa);
+ /* scan optional fractional part (it is mandatory, if there is
+ no integer part) */
+ if (csa->c == '.')
+ { add_char(csa);
+ if (csa->imlen == 1 && !isdigit(csa->c))
+ error(csa, "invalid use of decimal point\n");
+ while (isdigit(csa->c)) add_char(csa);
+ }
+ /* scan optional decimal exponent */
+ if (csa->c == 'e' || csa->c == 'E')
+ { add_char(csa);
+ if (csa->c == '+' || csa->c == '-') add_char(csa);
+ if (!isdigit(csa->c))
+ error(csa, "numeric constant '%s' incomplete\n",
+ csa->image);
+ while (isdigit(csa->c)) add_char(csa);
+ }
+ /* convert the numeric constant to floating-point */
+ if (str2num(csa->image, &csa->value))
+ error(csa, "numeric constant '%s' out of range\n",
+ csa->image);
+ }
+ else if (csa->c == '+')
+ csa->token = T_PLUS, add_char(csa);
+ else if (csa->c == '-')
+ csa->token = T_MINUS, add_char(csa);
+ else if (csa->c == ':')
+ csa->token = T_COLON, add_char(csa);
+ else if (csa->c == '<')
+ { csa->token = T_LE, add_char(csa);
+ if (csa->c == '=') add_char(csa);
+ }
+ else if (csa->c == '>')
+ { csa->token = T_GE, add_char(csa);
+ if (csa->c == '=') add_char(csa);
+ }
+ else if (csa->c == '=')
+ { csa->token = T_EQ, add_char(csa);
+ if (csa->c == '<')
+ csa->token = T_LE, add_char(csa);
+ else if (csa->c == '>')
+ csa->token = T_GE, add_char(csa);
+ }
+ else
+ error(csa, "character '%c' not recognized\n", csa->c);
+ /* skip non-significant characters */
+ while (csa->c == ' ') read_char(csa);
+ return;
+}
+
+static int find_col(struct csa *csa, char *name)
+{ /* find column by its symbolic name */
+ int j;
+ j = glp_find_col(csa->P, name);
+ if (j == 0)
+ { /* not found; create new column */
+ j = glp_add_cols(csa->P, 1);
+ glp_set_col_name(csa->P, j, name);
+ /* enlarge working arrays, if necessary */
+ if (csa->n_max < j)
+ { int n_max = csa->n_max;
+ int *ind = csa->ind;
+ double *val = csa->val;
+ char *flag = csa->flag;
+ double *lb = csa->lb;
+ double *ub = csa->ub;
+ csa->n_max += csa->n_max;
+ csa->ind = xcalloc(1+csa->n_max, sizeof(int));
+ memcpy(&csa->ind[1], &ind[1], n_max * sizeof(int));
+ xfree(ind);
+ csa->val = xcalloc(1+csa->n_max, sizeof(double));
+ memcpy(&csa->val[1], &val[1], n_max * sizeof(double));
+ xfree(val);
+ csa->flag = xcalloc(1+csa->n_max, sizeof(char));
+ memset(&csa->flag[1], 0, csa->n_max * sizeof(char));
+ memcpy(&csa->flag[1], &flag[1], n_max * sizeof(char));
+ xfree(flag);
+ csa->lb = xcalloc(1+csa->n_max, sizeof(double));
+ memcpy(&csa->lb[1], &lb[1], n_max * sizeof(double));
+ xfree(lb);
+ csa->ub = xcalloc(1+csa->n_max, sizeof(double));
+ memcpy(&csa->ub[1], &ub[1], n_max * sizeof(double));
+ xfree(ub);
+ }
+ csa->lb[j] = +DBL_MAX, csa->ub[j] = -DBL_MAX;
+ }
+ return j;
+}
+
+/***********************************************************************
+* parse_linear_form - parse linear form
+*
+* This routine parses the linear form using the following syntax:
+*
+* <variable> ::= <symbolic name>
+* <coefficient> ::= <numeric constant>
+* <term> ::= <variable> | <numeric constant> <variable>
+* <linear form> ::= <term> | + <term> | - <term> |
+* <linear form> + <term> | <linear form> - <term>
+*
+* The routine returns the number of terms in the linear form. */
+
+static int parse_linear_form(struct csa *csa)
+{ int j, k, len = 0, newlen;
+ double s, coef;
+loop: /* parse an optional sign */
+ if (csa->token == T_PLUS)
+ s = +1.0, scan_token(csa);
+ else if (csa->token == T_MINUS)
+ s = -1.0, scan_token(csa);
+ else
+ s = +1.0;
+ /* parse an optional coefficient */
+ if (csa->token == T_NUMBER)
+ coef = csa->value, scan_token(csa);
+ else
+ coef = 1.0;
+ /* parse a variable name */
+ if (csa->token != T_NAME)
+ error(csa, "missing variable name\n");
+ /* find the corresponding column */
+ j = find_col(csa, csa->image);
+ /* check if the variable is already used in the linear form */
+ if (csa->flag[j])
+ error(csa, "multiple use of variable '%s' not allowed\n",
+ csa->image);
+ /* add new term to the linear form */
+ len++, csa->ind[len] = j, csa->val[len] = s * coef;
+ /* and mark that the variable is used in the linear form */
+ csa->flag[j] = 1;
+ scan_token(csa);
+ /* if the next token is a sign, there is another term */
+ if (csa->token == T_PLUS || csa->token == T_MINUS) goto loop;
+ /* clear marks of the variables used in the linear form */
+ for (k = 1; k <= len; k++) csa->flag[csa->ind[k]] = 0;
+ /* remove zero coefficients */
+ newlen = 0;
+ for (k = 1; k <= len; k++)
+ { if (csa->val[k] != 0.0)
+ { newlen++;
+ csa->ind[newlen] = csa->ind[k];
+ csa->val[newlen] = csa->val[k];
+ }
+ }
+ return newlen;
+}
+
+/***********************************************************************
+* parse_objective - parse objective function
+*
+* This routine parses definition of the objective function using the
+* following syntax:
+*
+* <obj sense> ::= minimize | minimum | min | maximize | maximum | max
+* <obj name> ::= <empty> | <symbolic name> :
+* <obj function> ::= <obj sense> <obj name> <linear form> */
+
+static void parse_objective(struct csa *csa)
+{ /* parse objective sense */
+ int k, len;
+ /* parse the keyword 'minimize' or 'maximize' */
+ if (csa->token == T_MINIMIZE)
+ glp_set_obj_dir(csa->P, GLP_MIN);
+ else if (csa->token == T_MAXIMIZE)
+ glp_set_obj_dir(csa->P, GLP_MAX);
+ else
+ xassert(csa != csa);
+ scan_token(csa);
+ /* parse objective name */
+ if (csa->token == T_NAME && csa->c == ':')
+ { /* objective name is followed by a colon */
+ glp_set_obj_name(csa->P, csa->image);
+ scan_token(csa);
+ xassert(csa->token == T_COLON);
+ scan_token(csa);
+ }
+ else
+ { /* objective name is not specified; use default */
+ glp_set_obj_name(csa->P, "obj");
+ }
+ /* parse linear form */
+ len = parse_linear_form(csa);
+ for (k = 1; k <= len; k++)
+ glp_set_obj_coef(csa->P, csa->ind[k], csa->val[k]);
+ return;
+}
+
+/***********************************************************************
+* parse_constraints - parse constraints section
+*
+* This routine parses the constraints section using the following
+* syntax:
+*
+* <row name> ::= <empty> | <symbolic name> :
+* <row sense> ::= < | <= | =< | > | >= | => | =
+* <right-hand side> ::= <numeric constant> | + <numeric constant> |
+* - <numeric constant>
+* <constraint> ::= <row name> <linear form> <row sense>
+* <right-hand side>
+* <subject to> ::= subject to | such that | st | s.t. | st.
+* <constraints section> ::= <subject to> <constraint> |
+* <constraints section> <constraint> */
+
+static void parse_constraints(struct csa *csa)
+{ int i, len, type;
+ double s;
+ /* parse the keyword 'subject to' */
+ xassert(csa->token == T_SUBJECT_TO);
+ scan_token(csa);
+loop: /* create new row (constraint) */
+ i = glp_add_rows(csa->P, 1);
+ /* parse row name */
+ if (csa->token == T_NAME && csa->c == ':')
+ { /* row name is followed by a colon */
+ if (glp_find_row(csa->P, csa->image) != 0)
+ error(csa, "constraint '%s' multiply defined\n",
+ csa->image);
+ glp_set_row_name(csa->P, i, csa->image);
+ scan_token(csa);
+ xassert(csa->token == T_COLON);
+ scan_token(csa);
+ }
+ else
+ { /* row name is not specified; use default */
+ char name[50];
+ sprintf(name, "r.%d", csa->count);
+ glp_set_row_name(csa->P, i, name);
+ }
+ /* parse linear form */
+ len = parse_linear_form(csa);
+ glp_set_mat_row(csa->P, i, len, csa->ind, csa->val);
+ /* parse constraint sense */
+ if (csa->token == T_LE)
+ type = GLP_UP, scan_token(csa);
+ else if (csa->token == T_GE)
+ type = GLP_LO, scan_token(csa);
+ else if (csa->token == T_EQ)
+ type = GLP_FX, scan_token(csa);
+ else
+ error(csa, "missing constraint sense\n");
+ /* parse right-hand side */
+ if (csa->token == T_PLUS)
+ s = +1.0, scan_token(csa);
+ else if (csa->token == T_MINUS)
+ s = -1.0, scan_token(csa);
+ else
+ s = +1.0;
+ if (csa->token != T_NUMBER)
+ error(csa, "missing right-hand side\n");
+ glp_set_row_bnds(csa->P, i, type, s * csa->value, s * csa->value);
+ /* the rest of the current line must be empty */
+ if (!(csa->c == '\n' || csa->c == EOF))
+ error(csa, "invalid symbol(s) beyond right-hand side\n");
+ scan_token(csa);
+ /* if the next token is a sign, numeric constant, or a symbolic
+ name, here is another constraint */
+ if (csa->token == T_PLUS || csa->token == T_MINUS ||
+ csa->token == T_NUMBER || csa->token == T_NAME) goto loop;
+ return;
+}
+
+static void set_lower_bound(struct csa *csa, int j, double lb)
+{ /* set lower bound of j-th variable */
+ if (csa->lb[j] != +DBL_MAX && !csa->lb_warn)
+ { warning(csa, "lower bound of variable '%s' redefined\n",
+ glp_get_col_name(csa->P, j));
+ csa->lb_warn = 1;
+ }
+ csa->lb[j] = lb;
+ return;
+}
+
+static void set_upper_bound(struct csa *csa, int j, double ub)
+{ /* set upper bound of j-th variable */
+ if (csa->ub[j] != -DBL_MAX && !csa->ub_warn)
+ { warning(csa, "upper bound of variable '%s' redefined\n",
+ glp_get_col_name(csa->P, j));
+ csa->ub_warn = 1;
+ }
+ csa->ub[j] = ub;
+ return;
+}
+
+/***********************************************************************
+* parse_bounds - parse bounds section
+*
+* This routine parses the bounds section using the following syntax:
+*
+* <variable> ::= <symbolic name>
+* <infinity> ::= infinity | inf
+* <bound> ::= <numeric constant> | + <numeric constant> |
+* - <numeric constant> | + <infinity> | - <infinity>
+* <lt> ::= < | <= | =<
+* <gt> ::= > | >= | =>
+* <bound definition> ::= <bound> <lt> <variable> <lt> <bound> |
+* <bound> <lt> <variable> | <variable> <lt> <bound> |
+* <variable> <gt> <bound> | <variable> = <bound> | <variable> free
+* <bounds> ::= bounds | bound
+* <bounds section> ::= <bounds> |
+* <bounds section> <bound definition> */
+
+static void parse_bounds(struct csa *csa)
+{ int j, lb_flag;
+ double lb, s;
+ /* parse the keyword 'bounds' */
+ xassert(csa->token == T_BOUNDS);
+ scan_token(csa);
+loop: /* bound definition can start with a sign, numeric constant, or
+ a symbolic name */
+ if (!(csa->token == T_PLUS || csa->token == T_MINUS ||
+ csa->token == T_NUMBER || csa->token == T_NAME)) goto done;
+ /* parse bound definition */
+ if (csa->token == T_PLUS || csa->token == T_MINUS)
+ { /* parse signed lower bound */
+ lb_flag = 1;
+ s = (csa->token == T_PLUS ? +1.0 : -1.0);
+ scan_token(csa);
+ if (csa->token == T_NUMBER)
+ lb = s * csa->value, scan_token(csa);
+ else if (the_same(csa->image, "infinity") ||
+ the_same(csa->image, "inf"))
+ { if (s > 0.0)
+ error(csa, "invalid use of '+inf' as lower bound\n");
+ lb = -DBL_MAX, scan_token(csa);
+ }
+ else
+ error(csa, "missing lower bound\n");
+ }
+ else if (csa->token == T_NUMBER)
+ { /* parse unsigned lower bound */
+ lb_flag = 1;
+ lb = csa->value, scan_token(csa);
+ }
+ else
+ { /* lower bound is not specified */
+ lb_flag = 0;
+ }
+ /* parse the token that should follow the lower bound */
+ if (lb_flag)
+ { if (csa->token != T_LE)
+ error(csa, "missing '<', '<=', or '=<' after lower bound\n")
+ ;
+ scan_token(csa);
+ }
+ /* parse variable name */
+ if (csa->token != T_NAME)
+ error(csa, "missing variable name\n");
+ j = find_col(csa, csa->image);
+ /* set lower bound */
+ if (lb_flag) set_lower_bound(csa, j, lb);
+ scan_token(csa);
+ /* parse the context that follows the variable name */
+ if (csa->token == T_LE)
+ { /* parse upper bound */
+ scan_token(csa);
+ if (csa->token == T_PLUS || csa->token == T_MINUS)
+ { /* parse signed upper bound */
+ s = (csa->token == T_PLUS ? +1.0 : -1.0);
+ scan_token(csa);
+ if (csa->token == T_NUMBER)
+ { set_upper_bound(csa, j, s * csa->value);
+ scan_token(csa);
+ }
+ else if (the_same(csa->image, "infinity") ||
+ the_same(csa->image, "inf"))
+ { if (s < 0.0)
+ error(csa, "invalid use of '-inf' as upper bound\n");
+ set_upper_bound(csa, j, +DBL_MAX);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing upper bound\n");
+ }
+ else if (csa->token == T_NUMBER)
+ { /* parse unsigned upper bound */
+ set_upper_bound(csa, j, csa->value);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing upper bound\n");
+ }
+ else if (csa->token == T_GE)
+ { /* parse lower bound */
+ if (lb_flag)
+ { /* the context '... <= x >= ...' is invalid */
+ error(csa, "invalid bound definition\n");
+ }
+ scan_token(csa);
+ if (csa->token == T_PLUS || csa->token == T_MINUS)
+ { /* parse signed lower bound */
+ s = (csa->token == T_PLUS ? +1.0 : -1.0);
+ scan_token(csa);
+ if (csa->token == T_NUMBER)
+ { set_lower_bound(csa, j, s * csa->value);
+ scan_token(csa);
+ }
+ else if (the_same(csa->image, "infinity") ||
+ the_same(csa->image, "inf") == 0)
+ { if (s > 0.0)
+ error(csa, "invalid use of '+inf' as lower bound\n");
+ set_lower_bound(csa, j, -DBL_MAX);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing lower bound\n");
+ }
+ else if (csa->token == T_NUMBER)
+ { /* parse unsigned lower bound */
+ set_lower_bound(csa, j, csa->value);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing lower bound\n");
+ }
+ else if (csa->token == T_EQ)
+ { /* parse fixed value */
+ if (lb_flag)
+ { /* the context '... <= x = ...' is invalid */
+ error(csa, "invalid bound definition\n");
+ }
+ scan_token(csa);
+ if (csa->token == T_PLUS || csa->token == T_MINUS)
+ { /* parse signed fixed value */
+ s = (csa->token == T_PLUS ? +1.0 : -1.0);
+ scan_token(csa);
+ if (csa->token == T_NUMBER)
+ { set_lower_bound(csa, j, s * csa->value);
+ set_upper_bound(csa, j, s * csa->value);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing fixed value\n");
+ }
+ else if (csa->token == T_NUMBER)
+ { /* parse unsigned fixed value */
+ set_lower_bound(csa, j, csa->value);
+ set_upper_bound(csa, j, csa->value);
+ scan_token(csa);
+ }
+ else
+ error(csa, "missing fixed value\n");
+ }
+ else if (the_same(csa->image, "free"))
+ { /* parse the keyword 'free' */
+ if (lb_flag)
+ { /* the context '... <= x free ...' is invalid */
+ error(csa, "invalid bound definition\n");
+ }
+ set_lower_bound(csa, j, -DBL_MAX);
+ set_upper_bound(csa, j, +DBL_MAX);
+ scan_token(csa);
+ }
+ else if (!lb_flag)
+ { /* neither lower nor upper bounds are specified */
+ error(csa, "invalid bound definition\n");
+ }
+ goto loop;
+done: return;
+}
+
+/***********************************************************************
+* parse_integer - parse general, integer, or binary section
+*
+* <variable> ::= <symbolic name>
+* <general> ::= general | generals | gen
+* <integer> ::= integer | integers | int
+* <binary> ::= binary | binaries | bin
+* <section head> ::= <general> <integer> <binary>
+* <additional section> ::= <section head> |
+* <additional section> <variable> */
+
+static void parse_integer(struct csa *csa)
+{ int j, binary;
+ /* parse the keyword 'general', 'integer', or 'binary' */
+ if (csa->token == T_GENERAL)
+ binary = 0, scan_token(csa);
+ else if (csa->token == T_INTEGER)
+ binary = 0, scan_token(csa);
+ else if (csa->token == T_BINARY)
+ binary = 1, scan_token(csa);
+ else
+ xassert(csa != csa);
+ /* parse list of variables (may be empty) */
+ while (csa->token == T_NAME)
+ { /* find the corresponding column */
+ j = find_col(csa, csa->image);
+ /* change kind of the variable */
+ glp_set_col_kind(csa->P, j, GLP_IV);
+ /* set bounds for the binary variable */
+ if (binary)
+#if 0 /* 07/VIII-2013 */
+ { set_lower_bound(csa, j, 0.0);
+ set_upper_bound(csa, j, 1.0);
+ }
+#else
+ { set_lower_bound(csa, j,
+ csa->lb[j] == +DBL_MAX ? 0.0 : csa->lb[j]);
+ set_upper_bound(csa, j,
+ csa->ub[j] == -DBL_MAX ? 1.0 : csa->ub[j]);
+ }
+#endif
+ scan_token(csa);
+ }
+ return;
+}
+
+int glp_read_lp(glp_prob *P, const glp_cpxcp *parm, const char *fname)
+{ /* read problem data in CPLEX LP format */
+ glp_cpxcp _parm;
+ struct csa _csa, *csa = &_csa;
+ int ret;
+ xprintf("Reading problem data from '%s'...\n", fname);
+ if (parm == NULL)
+ glp_init_cpxcp(&_parm), parm = &_parm;
+ /* check control parameters */
+ check_parm("glp_read_lp", parm);
+ /* initialize common storage area */
+ csa->P = P;
+ csa->parm = parm;
+ csa->fname = fname;
+ csa->fp = NULL;
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->count = 0;
+ csa->c = '\n';
+ csa->token = T_EOF;
+ csa->image[0] = '\0';
+ csa->imlen = 0;
+ csa->value = 0.0;
+ csa->n_max = 100;
+ csa->ind = xcalloc(1+csa->n_max, sizeof(int));
+ csa->val = xcalloc(1+csa->n_max, sizeof(double));
+ csa->flag = xcalloc(1+csa->n_max, sizeof(char));
+ memset(&csa->flag[1], 0, csa->n_max * sizeof(char));
+ csa->lb = xcalloc(1+csa->n_max, sizeof(double));
+ csa->ub = xcalloc(1+csa->n_max, sizeof(double));
+#if 1 /* 27/VII-2013 */
+ csa->lb_warn = csa->ub_warn = 0;
+#endif
+ /* erase problem object */
+ glp_erase_prob(P);
+ glp_create_index(P);
+ /* open input CPLEX LP file */
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* scan very first token */
+ scan_token(csa);
+ /* parse definition of the objective function */
+ if (!(csa->token == T_MINIMIZE || csa->token == T_MAXIMIZE))
+ error(csa, "'minimize' or 'maximize' keyword missing\n");
+ parse_objective(csa);
+ /* parse constraints section */
+ if (csa->token != T_SUBJECT_TO)
+ error(csa, "constraints section missing\n");
+ parse_constraints(csa);
+ /* parse optional bounds section */
+ if (csa->token == T_BOUNDS) parse_bounds(csa);
+ /* parse optional general, integer, and binary sections */
+ while (csa->token == T_GENERAL ||
+ csa->token == T_INTEGER ||
+ csa->token == T_BINARY) parse_integer(csa);
+ /* check for the keyword 'end' */
+ if (csa->token == T_END)
+ scan_token(csa);
+ else if (csa->token == T_EOF)
+ warning(csa, "keyword 'end' missing\n");
+ else
+ error(csa, "symbol '%s' in wrong position\n", csa->image);
+ /* nothing must follow the keyword 'end' (except comments) */
+ if (csa->token != T_EOF)
+ error(csa, "extra symbol(s) detected beyond 'end'\n");
+ /* set bounds of variables */
+ { int j, type;
+ double lb, ub;
+ for (j = 1; j <= P->n; j++)
+ { lb = csa->lb[j];
+ ub = csa->ub[j];
+ if (lb == +DBL_MAX) lb = 0.0; /* default lb */
+ if (ub == -DBL_MAX) ub = +DBL_MAX; /* default ub */
+ if (lb == -DBL_MAX && ub == +DBL_MAX)
+ type = GLP_FR;
+ else if (ub == +DBL_MAX)
+ type = GLP_LO;
+ else if (lb == -DBL_MAX)
+ type = GLP_UP;
+ else if (lb != ub)
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_col_bnds(csa->P, j, type, lb, ub);
+ }
+ }
+ /* print some statistics */
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" : "s",
+ P->nnz, P->nnz == 1 ? "" : "s");
+ if (glp_get_num_int(P) > 0)
+ { int ni = glp_get_num_int(P);
+ int nb = glp_get_num_bin(P);
+ if (ni == 1)
+ { if (nb == 0)
+ xprintf("One variable is integer\n");
+ else
+ xprintf("One variable is binary\n");
+ }
+ else
+ { xprintf("%d integer variables, ", ni);
+ if (nb == 0)
+ xprintf("none");
+ else if (nb == 1)
+ xprintf("one");
+ else if (nb == ni)
+ xprintf("all");
+ else
+ xprintf("%d", nb);
+ xprintf(" of which %s binary\n", nb == 1 ? "is" : "are");
+ }
+ }
+ xprintf("%d lines were read\n", csa->count);
+ /* problem data has been successfully read */
+ glp_delete_index(P);
+ glp_sort_matrix(P);
+ ret = 0;
+done: if (csa->fp != NULL) glp_close(csa->fp);
+ xfree(csa->ind);
+ xfree(csa->val);
+ xfree(csa->flag);
+ xfree(csa->lb);
+ xfree(csa->ub);
+ if (ret != 0) glp_erase_prob(P);
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_write_lp - write problem data in CPLEX LP format
+*
+* SYNOPSIS
+*
+* int glp_write_lp(glp_prob *P, const glp_cpxcp *parm, const char
+* *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_lp writes problem data in CPLEX LP format to
+* a text file.
+*
+* The parameter parm is a pointer to the structure glp_cpxcp, which
+* specifies control parameters used by the routine. If parm is NULL,
+* the routine uses default settings.
+*
+* The character string fname specifies a name of the text file to be
+* written.
+*
+* RETURNS
+*
+* If the operation was successful, the routine glp_write_lp returns
+* zero. Otherwise, it prints an error message and returns non-zero. */
+
+#define csa csa1
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* pointer to problem object */
+ const glp_cpxcp *parm;
+ /* pointer to control parameters */
+};
+
+static int check_name(char *name)
+{ /* check if specified name is valid for CPLEX LP format */
+ if (*name == '.') return 1;
+ if (isdigit((unsigned char)*name)) return 1;
+ for (; *name; name++)
+ { if (!isalnum((unsigned char)*name) &&
+ strchr(CHAR_SET, (unsigned char)*name) == NULL) return 1;
+ }
+ return 0; /* name is ok */
+}
+
+static void adjust_name(char *name)
+{ /* attempt to adjust specified name to make it valid for CPLEX LP
+ format */
+ for (; *name; name++)
+ { if (*name == ' ')
+ *name = '_';
+ else if (*name == '-')
+ *name = '~';
+ else if (*name == '[')
+ *name = '(';
+ else if (*name == ']')
+ *name = ')';
+ }
+ return;
+}
+
+static char *row_name(struct csa *csa, int i, char rname[255+1])
+{ /* construct symbolic name of i-th row (constraint) */
+ const char *name;
+ if (i == 0)
+ name = glp_get_obj_name(csa->P);
+ else
+ name = glp_get_row_name(csa->P, i);
+ if (name == NULL) goto fake;
+ strcpy(rname, name);
+ adjust_name(rname);
+ if (check_name(rname)) goto fake;
+ return rname;
+fake: if (i == 0)
+ strcpy(rname, "obj");
+ else
+ sprintf(rname, "r_%d", i);
+ return rname;
+}
+
+static char *col_name(struct csa *csa, int j, char cname[255+1])
+{ /* construct symbolic name of j-th column (variable) */
+ const char *name;
+ name = glp_get_col_name(csa->P, j);
+ if (name == NULL) goto fake;
+ strcpy(cname, name);
+ adjust_name(cname);
+ if (check_name(cname)) goto fake;
+ return cname;
+#if 0 /* 18/I-2018 */
+fake: sprintf(cname, "x_%d", j);
+#else
+fake: /* construct fake name depending on column's attributes */
+ { GLPCOL *col = csa->P->col[j];
+ if (col->type == GLP_FX)
+ { /* fixed column */
+ sprintf(cname, "s_%d", j);
+ }
+ else if (col->kind == GLP_CV)
+ { /* continuous variable */
+ sprintf(cname, "x_%d", j);
+ }
+ else if (!(col->lb == 0 && col->ub == 1))
+ { /* general (non-binary) integer variable */
+ sprintf(cname, "y_%d", j);
+ }
+ else
+ { /* binary variable */
+ sprintf(cname, "z_%d", j);
+ }
+ }
+#endif
+ return cname;
+}
+
+int glp_write_lp(glp_prob *P, const glp_cpxcp *parm, const char *fname)
+{ /* write problem data in CPLEX LP format */
+ glp_cpxcp _parm;
+ struct csa _csa, *csa = &_csa;
+ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, j, len, flag, count, ret;
+ char line[1000+1], term[500+1], name[255+1];
+ xprintf("Writing problem data to '%s'...\n", fname);
+ if (parm == NULL)
+ glp_init_cpxcp(&_parm), parm = &_parm;
+ /* check control parameters */
+ check_parm("glp_write_lp", parm);
+ /* initialize common storage area */
+ csa->P = P;
+ csa->parm = parm;
+ /* create output CPLEX LP file */
+ fp = glp_open(fname, "w"), count = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* write problem name */
+ xfprintf(fp, "\\* Problem: %s *\\\n",
+ P->name == NULL ? "Unknown" : P->name), count++;
+ xfprintf(fp, "\n"), count++;
+ /* the problem should contain at least one row and one column */
+ if (!(P->m > 0 && P->n > 0))
+ { xprintf("Warning: problem has no rows/columns\n");
+ xfprintf(fp, "\\* WARNING: PROBLEM HAS NO ROWS/COLUMNS *\\\n"),
+ count++;
+ xfprintf(fp, "\n"), count++;
+ goto skip;
+ }
+ /* write the objective function definition */
+ if (P->dir == GLP_MIN)
+ xfprintf(fp, "Minimize\n"), count++;
+ else if (P->dir == GLP_MAX)
+ xfprintf(fp, "Maximize\n"), count++;
+ else
+ xassert(P != P);
+ row_name(csa, 0, name);
+ sprintf(line, " %s:", name);
+ len = 0;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->coef != 0.0 || col->ptr == NULL)
+ { len++;
+ col_name(csa, j, name);
+ if (col->coef == 0.0)
+ sprintf(term, " + 0 %s", name); /* empty column */
+ else if (col->coef == +1.0)
+ sprintf(term, " + %s", name);
+ else if (col->coef == -1.0)
+ sprintf(term, " - %s", name);
+ else if (col->coef > 0.0)
+ sprintf(term, " + %.*g %s", DBL_DIG, +col->coef, name);
+ else
+ sprintf(term, " - %.*g %s", DBL_DIG, -col->coef, name);
+ if (strlen(line) + strlen(term) > 72)
+ xfprintf(fp, "%s\n", line), line[0] = '\0', count++;
+ strcat(line, term);
+ }
+ }
+ if (len == 0)
+ { /* empty objective */
+ sprintf(term, " 0 %s", col_name(csa, 1, name));
+ strcat(line, term);
+ }
+ xfprintf(fp, "%s\n", line), count++;
+ if (P->c0 != 0.0)
+ xfprintf(fp, "\\* constant term = %.*g *\\\n", DBL_DIG, P->c0),
+ count++;
+ xfprintf(fp, "\n"), count++;
+ /* write the constraints section */
+ xfprintf(fp, "Subject To\n"), count++;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->type == GLP_FR) continue; /* skip free row */
+ row_name(csa, i, name);
+ sprintf(line, " %s:", name);
+ /* linear form */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col_name(csa, aij->col->j, name);
+ if (aij->val == +1.0)
+ sprintf(term, " + %s", name);
+ else if (aij->val == -1.0)
+ sprintf(term, " - %s", name);
+ else if (aij->val > 0.0)
+ sprintf(term, " + %.*g %s", DBL_DIG, +aij->val, name);
+ else
+ sprintf(term, " - %.*g %s", DBL_DIG, -aij->val, name);
+ if (strlen(line) + strlen(term) > 72)
+ xfprintf(fp, "%s\n", line), line[0] = '\0', count++;
+ strcat(line, term);
+ }
+ if (row->type == GLP_DB)
+ { /* double-bounded (ranged) constraint */
+ sprintf(term, " - ~r_%d", i);
+ if (strlen(line) + strlen(term) > 72)
+ xfprintf(fp, "%s\n", line), line[0] = '\0', count++;
+ strcat(line, term);
+ }
+ else if (row->ptr == NULL)
+ { /* empty constraint */
+ sprintf(term, " 0 %s", col_name(csa, 1, name));
+ strcat(line, term);
+ }
+ /* right hand-side */
+ if (row->type == GLP_LO)
+ sprintf(term, " >= %.*g", DBL_DIG, row->lb);
+ else if (row->type == GLP_UP)
+ sprintf(term, " <= %.*g", DBL_DIG, row->ub);
+ else if (row->type == GLP_DB || row->type == GLP_FX)
+ sprintf(term, " = %.*g", DBL_DIG, row->lb);
+ else
+ xassert(row != row);
+ if (strlen(line) + strlen(term) > 72)
+ xfprintf(fp, "%s\n", line), line[0] = '\0', count++;
+ strcat(line, term);
+ xfprintf(fp, "%s\n", line), count++;
+ }
+ xfprintf(fp, "\n"), count++;
+ /* write the bounds section */
+ flag = 0;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->type != GLP_DB) continue;
+ if (!flag)
+ xfprintf(fp, "Bounds\n"), flag = 1, count++;
+ xfprintf(fp, " 0 <= ~r_%d <= %.*g\n",
+ i, DBL_DIG, row->ub - row->lb), count++;
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->type == GLP_LO && col->lb == 0.0) continue;
+ if (!flag)
+ xfprintf(fp, "Bounds\n"), flag = 1, count++;
+ col_name(csa, j, name);
+ if (col->type == GLP_FR)
+ xfprintf(fp, " %s free\n", name), count++;
+ else if (col->type == GLP_LO)
+ xfprintf(fp, " %s >= %.*g\n",
+ name, DBL_DIG, col->lb), count++;
+ else if (col->type == GLP_UP)
+ xfprintf(fp, " -Inf <= %s <= %.*g\n",
+ name, DBL_DIG, col->ub), count++;
+ else if (col->type == GLP_DB)
+ xfprintf(fp, " %.*g <= %s <= %.*g\n",
+ DBL_DIG, col->lb, name, DBL_DIG, col->ub), count++;
+ else if (col->type == GLP_FX)
+ xfprintf(fp, " %s = %.*g\n",
+ name, DBL_DIG, col->lb), count++;
+ else
+ xassert(col != col);
+ }
+ if (flag) xfprintf(fp, "\n"), count++;
+ /* write the integer section */
+ flag = 0;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->kind == GLP_CV) continue;
+ xassert(col->kind == GLP_IV);
+ if (!flag)
+ xfprintf(fp, "Generals\n"), flag = 1, count++;
+ xfprintf(fp, " %s\n", col_name(csa, j, name)), count++;
+ }
+ if (flag) xfprintf(fp, "\n"), count++;
+skip: /* write the end keyword */
+ xfprintf(fp, "End\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* problem data has been successfully written */
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/cpp.c b/test/monniaux/glpk-4.65/src/api/cpp.c
new file mode 100644
index 00000000..ac3d63ef
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/cpp.c
@@ -0,0 +1,185 @@
+/* cpp.c (solve critical path problem) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_cpp - solve critical path problem
+*
+* SYNOPSIS
+*
+* double glp_cpp(glp_graph *G, int v_t, int v_es, int v_ls);
+*
+* DESCRIPTION
+*
+* The routine glp_cpp solves the critical path problem represented in
+* the form of the project network.
+*
+* The parameter G is a pointer to the graph object, which specifies
+* the project network. This graph must be acyclic. Multiple arcs are
+* allowed being considered as single arcs.
+*
+* The parameter v_t specifies an offset of the field of type double
+* in the vertex data block, which contains time t[i] >= 0 needed to
+* perform corresponding job j. If v_t < 0, it is assumed that t[i] = 1
+* for all jobs.
+*
+* The parameter v_es specifies an offset of the field of type double
+* in the vertex data block, to which the routine stores earliest start
+* time for corresponding job. If v_es < 0, this time is not stored.
+*
+* The parameter v_ls specifies an offset of the field of type double
+* in the vertex data block, to which the routine stores latest start
+* time for corresponding job. If v_ls < 0, this time is not stored.
+*
+* RETURNS
+*
+* The routine glp_cpp returns the minimal project duration, that is,
+* minimal time needed to perform all jobs in the project. */
+
+static void sorting(glp_graph *G, int list[]);
+
+double glp_cpp(glp_graph *G, int v_t, int v_es, int v_ls)
+{ glp_vertex *v;
+ glp_arc *a;
+ int i, j, k, nv, *list;
+ double temp, total, *t, *es, *ls;
+ if (v_t >= 0 && v_t > G->v_size - (int)sizeof(double))
+ xerror("glp_cpp: v_t = %d; invalid offset\n", v_t);
+ if (v_es >= 0 && v_es > G->v_size - (int)sizeof(double))
+ xerror("glp_cpp: v_es = %d; invalid offset\n", v_es);
+ if (v_ls >= 0 && v_ls > G->v_size - (int)sizeof(double))
+ xerror("glp_cpp: v_ls = %d; invalid offset\n", v_ls);
+ nv = G->nv;
+ if (nv == 0)
+ { total = 0.0;
+ goto done;
+ }
+ /* allocate working arrays */
+ t = xcalloc(1+nv, sizeof(double));
+ es = xcalloc(1+nv, sizeof(double));
+ ls = xcalloc(1+nv, sizeof(double));
+ list = xcalloc(1+nv, sizeof(int));
+ /* retrieve job times */
+ for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ if (v_t >= 0)
+ { memcpy(&t[i], (char *)v->data + v_t, sizeof(double));
+ if (t[i] < 0.0)
+ xerror("glp_cpp: t[%d] = %g; invalid time\n", i, t[i]);
+ }
+ else
+ t[i] = 1.0;
+ }
+ /* perform topological sorting to determine the list of nodes
+ (jobs) such that if list[k] = i and list[kk] = j and there
+ exists arc (i->j), then k < kk */
+ sorting(G, list);
+ /* FORWARD PASS */
+ /* determine earliest start times */
+ for (k = 1; k <= nv; k++)
+ { j = list[k];
+ es[j] = 0.0;
+ for (a = G->v[j]->in; a != NULL; a = a->h_next)
+ { i = a->tail->i;
+ /* there exists arc (i->j) in the project network */
+ temp = es[i] + t[i];
+ if (es[j] < temp) es[j] = temp;
+ }
+ }
+ /* determine the minimal project duration */
+ total = 0.0;
+ for (i = 1; i <= nv; i++)
+ { temp = es[i] + t[i];
+ if (total < temp) total = temp;
+ }
+ /* BACKWARD PASS */
+ /* determine latest start times */
+ for (k = nv; k >= 1; k--)
+ { i = list[k];
+ ls[i] = total - t[i];
+ for (a = G->v[i]->out; a != NULL; a = a->t_next)
+ { j = a->head->i;
+ /* there exists arc (i->j) in the project network */
+ temp = ls[j] - t[i];
+ if (ls[i] > temp) ls[i] = temp;
+ }
+ /* avoid possible round-off errors */
+ if (ls[i] < es[i]) ls[i] = es[i];
+ }
+ /* store results, if necessary */
+ if (v_es >= 0)
+ { for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_es, &es[i], sizeof(double));
+ }
+ }
+ if (v_ls >= 0)
+ { for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_ls, &ls[i], sizeof(double));
+ }
+ }
+ /* free working arrays */
+ xfree(t);
+ xfree(es);
+ xfree(ls);
+ xfree(list);
+done: return total;
+}
+
+static void sorting(glp_graph *G, int list[])
+{ /* perform topological sorting to determine the list of nodes
+ (jobs) such that if list[k] = i and list[kk] = j and there
+ exists arc (i->j), then k < kk */
+ int i, k, nv, v_size, *num;
+ void **save;
+ nv = G->nv;
+ v_size = G->v_size;
+ save = xcalloc(1+nv, sizeof(void *));
+ num = xcalloc(1+nv, sizeof(int));
+ G->v_size = sizeof(int);
+ for (i = 1; i <= nv; i++)
+ { save[i] = G->v[i]->data;
+ G->v[i]->data = &num[i];
+ list[i] = 0;
+ }
+ if (glp_top_sort(G, 0) != 0)
+ xerror("glp_cpp: project network is not acyclic\n");
+ G->v_size = v_size;
+ for (i = 1; i <= nv; i++)
+ { G->v[i]->data = save[i];
+ k = num[i];
+ xassert(1 <= k && k <= nv);
+ xassert(list[k] == 0);
+ list[k] = i;
+ }
+ xfree(save);
+ xfree(num);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/cpxbas.c b/test/monniaux/glpk-4.65/src/api/cpxbas.c
new file mode 100644
index 00000000..e1c656a7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/cpxbas.c
@@ -0,0 +1,269 @@
+/* cpxbas.c (construct Bixby's initial LP basis) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+struct var
+{ /* structural variable */
+ int j;
+ /* ordinal number */
+ double q;
+ /* penalty value */
+};
+
+static int CDECL fcmp(const void *ptr1, const void *ptr2)
+{ /* this routine is passed to the qsort() function */
+ struct var *col1 = (void *)ptr1, *col2 = (void *)ptr2;
+ if (col1->q < col2->q) return -1;
+ if (col1->q > col2->q) return +1;
+ return 0;
+}
+
+static int get_column(glp_prob *lp, int j, int ind[], double val[])
+{ /* Bixby's algorithm assumes that the constraint matrix is scaled
+ such that the maximum absolute value in every non-zero row and
+ column is 1 */
+ int k, len;
+ double big;
+ len = glp_get_mat_col(lp, j, ind, val);
+ big = 0.0;
+ for (k = 1; k <= len; k++)
+ if (big < fabs(val[k])) big = fabs(val[k]);
+ if (big == 0.0) big = 1.0;
+ for (k = 1; k <= len; k++) val[k] /= big;
+ return len;
+}
+
+static void cpx_basis(glp_prob *lp)
+{ /* main routine */
+ struct var *C, *C2, *C3, *C4;
+ int m, n, i, j, jk, k, l, ll, t, n2, n3, n4, type, len, *I, *r,
+ *ind;
+ double alpha, gamma, cmax, temp, *v, *val;
+ xprintf("Constructing initial basis...\n");
+ /* determine the number of rows and columns */
+ m = glp_get_num_rows(lp);
+ n = glp_get_num_cols(lp);
+ /* allocate working arrays */
+ C = xcalloc(1+n, sizeof(struct var));
+ I = xcalloc(1+m, sizeof(int));
+ r = xcalloc(1+m, sizeof(int));
+ v = xcalloc(1+m, sizeof(double));
+ ind = xcalloc(1+m, sizeof(int));
+ val = xcalloc(1+m, sizeof(double));
+ /* make all auxiliary variables non-basic */
+ for (i = 1; i <= m; i++)
+ { if (glp_get_row_type(lp, i) != GLP_DB)
+ glp_set_row_stat(lp, i, GLP_NS);
+ else if (fabs(glp_get_row_lb(lp, i)) <=
+ fabs(glp_get_row_ub(lp, i)))
+ glp_set_row_stat(lp, i, GLP_NL);
+ else
+ glp_set_row_stat(lp, i, GLP_NU);
+ }
+ /* make all structural variables non-basic */
+ for (j = 1; j <= n; j++)
+ { if (glp_get_col_type(lp, j) != GLP_DB)
+ glp_set_col_stat(lp, j, GLP_NS);
+ else if (fabs(glp_get_col_lb(lp, j)) <=
+ fabs(glp_get_col_ub(lp, j)))
+ glp_set_col_stat(lp, j, GLP_NL);
+ else
+ glp_set_col_stat(lp, j, GLP_NU);
+ }
+ /* C2 is a set of free structural variables */
+ n2 = 0, C2 = C + 0;
+ for (j = 1; j <= n; j++)
+ { type = glp_get_col_type(lp, j);
+ if (type == GLP_FR)
+ { n2++;
+ C2[n2].j = j;
+ C2[n2].q = 0.0;
+ }
+ }
+ /* C3 is a set of structural variables having excatly one (lower
+ or upper) bound */
+ n3 = 0, C3 = C2 + n2;
+ for (j = 1; j <= n; j++)
+ { type = glp_get_col_type(lp, j);
+ if (type == GLP_LO)
+ { n3++;
+ C3[n3].j = j;
+ C3[n3].q = + glp_get_col_lb(lp, j);
+ }
+ else if (type == GLP_UP)
+ { n3++;
+ C3[n3].j = j;
+ C3[n3].q = - glp_get_col_ub(lp, j);
+ }
+ }
+ /* C4 is a set of structural variables having both (lower and
+ upper) bounds */
+ n4 = 0, C4 = C3 + n3;
+ for (j = 1; j <= n; j++)
+ { type = glp_get_col_type(lp, j);
+ if (type == GLP_DB)
+ { n4++;
+ C4[n4].j = j;
+ C4[n4].q = glp_get_col_lb(lp, j) - glp_get_col_ub(lp, j);
+ }
+ }
+ /* compute gamma = max{|c[j]|: 1 <= j <= n} */
+ gamma = 0.0;
+ for (j = 1; j <= n; j++)
+ { temp = fabs(glp_get_obj_coef(lp, j));
+ if (gamma < temp) gamma = temp;
+ }
+ /* compute cmax */
+ cmax = (gamma == 0.0 ? 1.0 : 1000.0 * gamma);
+ /* compute final penalty for all structural variables within sets
+ C2, C3, and C4 */
+ switch (glp_get_obj_dir(lp))
+ { case GLP_MIN: temp = +1.0; break;
+ case GLP_MAX: temp = -1.0; break;
+ default: xassert(lp != lp);
+ }
+ for (k = 1; k <= n2+n3+n4; k++)
+ { j = C[k].j;
+ C[k].q += (temp * glp_get_obj_coef(lp, j)) / cmax;
+ }
+ /* sort structural variables within C2, C3, and C4 in ascending
+ order of penalty value */
+ qsort(C2+1, n2, sizeof(struct var), fcmp);
+ for (k = 1; k < n2; k++) xassert(C2[k].q <= C2[k+1].q);
+ qsort(C3+1, n3, sizeof(struct var), fcmp);
+ for (k = 1; k < n3; k++) xassert(C3[k].q <= C3[k+1].q);
+ qsort(C4+1, n4, sizeof(struct var), fcmp);
+ for (k = 1; k < n4; k++) xassert(C4[k].q <= C4[k+1].q);
+ /*** STEP 1 ***/
+ for (i = 1; i <= m; i++)
+ { type = glp_get_row_type(lp, i);
+ if (type != GLP_FX)
+ { /* row i is either free or inequality constraint */
+ glp_set_row_stat(lp, i, GLP_BS);
+ I[i] = 1;
+ r[i] = 1;
+ }
+ else
+ { /* row i is equality constraint */
+ I[i] = 0;
+ r[i] = 0;
+ }
+ v[i] = +DBL_MAX;
+ }
+ /*** STEP 2 ***/
+ for (k = 1; k <= n2+n3+n4; k++)
+ { jk = C[k].j;
+ len = get_column(lp, jk, ind, val);
+ /* let alpha = max{|A[l,jk]|: r[l] = 0} and let l' be such
+ that alpha = |A[l',jk]| */
+ alpha = 0.0, ll = 0;
+ for (t = 1; t <= len; t++)
+ { l = ind[t];
+ if (r[l] == 0 && alpha < fabs(val[t]))
+ alpha = fabs(val[t]), ll = l;
+ }
+ if (alpha >= 0.99)
+ { /* B := B union {jk} */
+ glp_set_col_stat(lp, jk, GLP_BS);
+ I[ll] = 1;
+ v[ll] = alpha;
+ /* r[l] := r[l] + 1 for all l such that |A[l,jk]| != 0 */
+ for (t = 1; t <= len; t++)
+ { l = ind[t];
+ if (val[t] != 0.0) r[l]++;
+ }
+ /* continue to the next k */
+ continue;
+ }
+ /* if |A[l,jk]| > 0.01 * v[l] for some l, continue to the
+ next k */
+ for (t = 1; t <= len; t++)
+ { l = ind[t];
+ if (fabs(val[t]) > 0.01 * v[l]) break;
+ }
+ if (t <= len) continue;
+ /* otherwise, let alpha = max{|A[l,jk]|: I[l] = 0} and let l'
+ be such that alpha = |A[l',jk]| */
+ alpha = 0.0, ll = 0;
+ for (t = 1; t <= len; t++)
+ { l = ind[t];
+ if (I[l] == 0 && alpha < fabs(val[t]))
+ alpha = fabs(val[t]), ll = l;
+ }
+ /* if alpha = 0, continue to the next k */
+ if (alpha == 0.0) continue;
+ /* B := B union {jk} */
+ glp_set_col_stat(lp, jk, GLP_BS);
+ I[ll] = 1;
+ v[ll] = alpha;
+ /* r[l] := r[l] + 1 for all l such that |A[l,jk]| != 0 */
+ for (t = 1; t <= len; t++)
+ { l = ind[t];
+ if (val[t] != 0.0) r[l]++;
+ }
+ }
+ /*** STEP 3 ***/
+ /* add an artificial variable (auxiliary variable for equality
+ constraint) to cover each remaining uncovered row */
+ for (i = 1; i <= m; i++)
+ if (I[i] == 0) glp_set_row_stat(lp, i, GLP_BS);
+ /* free working arrays */
+ xfree(C);
+ xfree(I);
+ xfree(r);
+ xfree(v);
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_cpx_basis - construct Bixby's initial LP basis
+*
+* SYNOPSIS
+*
+* void glp_cpx_basis(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_cpx_basis constructs an advanced initial basis for
+* the specified problem object.
+*
+* The routine is based on Bixby's algorithm described in the paper:
+*
+* Robert E. Bixby. Implementing the Simplex Method: The Initial Basis.
+* ORSA Journal on Computing, Vol. 4, No. 3, 1992, pp. 267-84. */
+
+void glp_cpx_basis(glp_prob *lp)
+{ if (lp->m == 0 || lp->n == 0)
+ glp_std_basis(lp);
+ else
+ cpx_basis(lp);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/graph.c b/test/monniaux/glpk-4.65/src/api/graph.c
new file mode 100644
index 00000000..82994c84
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/graph.c
@@ -0,0 +1,504 @@
+/* graph.c (basic graph routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "avl.h"
+#include "dmp.h"
+#include "env.h"
+#include "glpk.h"
+
+/* CAUTION: DO NOT CHANGE THE LIMITS BELOW */
+
+#define NV_MAX 100000000 /* = 100*10^6 */
+/* maximal number of vertices in the graph */
+
+#define NA_MAX 500000000 /* = 500*10^6 */
+/* maximal number of arcs in the graph */
+
+/***********************************************************************
+* NAME
+*
+* glp_create_graph - create graph
+*
+* SYNOPSIS
+*
+* glp_graph *glp_create_graph(int v_size, int a_size);
+*
+* DESCRIPTION
+*
+* The routine creates a new graph, which initially is empty, i.e. has
+* no vertices and arcs.
+*
+* The parameter v_size specifies the size of data associated with each
+* vertex of the graph (0 to 256 bytes).
+*
+* The parameter a_size specifies the size of data associated with each
+* arc of the graph (0 to 256 bytes).
+*
+* RETURNS
+*
+* The routine returns a pointer to the graph created. */
+
+static void create_graph(glp_graph *G, int v_size, int a_size)
+{ G->pool = dmp_create_pool();
+ G->name = NULL;
+ G->nv_max = 50;
+ G->nv = G->na = 0;
+ G->v = xcalloc(1+G->nv_max, sizeof(glp_vertex *));
+ G->index = NULL;
+ G->v_size = v_size;
+ G->a_size = a_size;
+ return;
+}
+
+glp_graph *glp_create_graph(int v_size, int a_size)
+{ glp_graph *G;
+ if (!(0 <= v_size && v_size <= 256))
+ xerror("glp_create_graph: v_size = %d; invalid size of vertex "
+ "data\n", v_size);
+ if (!(0 <= a_size && a_size <= 256))
+ xerror("glp_create_graph: a_size = %d; invalid size of arc dat"
+ "a\n", a_size);
+ G = xmalloc(sizeof(glp_graph));
+ create_graph(G, v_size, a_size);
+ return G;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_graph_name - assign (change) graph name
+*
+* SYNOPSIS
+*
+* void glp_set_graph_name(glp_graph *G, const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_set_graph_name assigns a symbolic name specified by
+* the character string name (1 to 255 chars) to the graph.
+*
+* If the parameter name is NULL or an empty string, the routine erases
+* the existing symbolic name of the graph. */
+
+void glp_set_graph_name(glp_graph *G, const char *name)
+{ if (G->name != NULL)
+ { dmp_free_atom(G->pool, G->name, strlen(G->name)+1);
+ G->name = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int j;
+ for (j = 0; name[j] != '\0'; j++)
+ { if (j == 256)
+ xerror("glp_set_graph_name: graph name too long\n");
+ if (iscntrl((unsigned char)name[j]))
+ xerror("glp_set_graph_name: graph name contains invalid "
+ "character(s)\n");
+ }
+ G->name = dmp_get_atom(G->pool, strlen(name)+1);
+ strcpy(G->name, name);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_add_vertices - add new vertices to graph
+*
+* SYNOPSIS
+*
+* int glp_add_vertices(glp_graph *G, int nadd);
+*
+* DESCRIPTION
+*
+* The routine glp_add_vertices adds nadd vertices to the specified
+* graph. New vertices are always added to the end of the vertex list,
+* so ordinal numbers of existing vertices remain unchanged.
+*
+* Being added each new vertex is isolated (has no incident arcs).
+*
+* RETURNS
+*
+* The routine glp_add_vertices returns an ordinal number of the first
+* new vertex added to the graph. */
+
+int glp_add_vertices(glp_graph *G, int nadd)
+{ int i, nv_new;
+ if (nadd < 1)
+ xerror("glp_add_vertices: nadd = %d; invalid number of vertice"
+ "s\n", nadd);
+ if (nadd > NV_MAX - G->nv)
+ xerror("glp_add_vertices: nadd = %d; too many vertices\n",
+ nadd);
+ /* determine new number of vertices */
+ nv_new = G->nv + nadd;
+ /* increase the room, if necessary */
+ if (G->nv_max < nv_new)
+ { glp_vertex **save = G->v;
+ while (G->nv_max < nv_new)
+ { G->nv_max += G->nv_max;
+ xassert(G->nv_max > 0);
+ }
+ G->v = xcalloc(1+G->nv_max, sizeof(glp_vertex *));
+ memcpy(&G->v[1], &save[1], G->nv * sizeof(glp_vertex *));
+ xfree(save);
+ }
+ /* add new vertices to the end of the vertex list */
+ for (i = G->nv+1; i <= nv_new; i++)
+ { glp_vertex *v;
+ G->v[i] = v = dmp_get_atom(G->pool, sizeof(glp_vertex));
+ v->i = i;
+ v->name = NULL;
+ v->entry = NULL;
+ if (G->v_size == 0)
+ v->data = NULL;
+ else
+ { v->data = dmp_get_atom(G->pool, G->v_size);
+ memset(v->data, 0, G->v_size);
+ }
+ v->temp = NULL;
+ v->in = v->out = NULL;
+ }
+ /* set new number of vertices */
+ G->nv = nv_new;
+ /* return the ordinal number of the first vertex added */
+ return nv_new - nadd + 1;
+}
+
+/**********************************************************************/
+
+void glp_set_vertex_name(glp_graph *G, int i, const char *name)
+{ /* assign (change) vertex name */
+ glp_vertex *v;
+ if (!(1 <= i && i <= G->nv))
+ xerror("glp_set_vertex_name: i = %d; vertex number out of rang"
+ "e\n", i);
+ v = G->v[i];
+ if (v->name != NULL)
+ { if (v->entry != NULL)
+ { xassert(G->index != NULL);
+ avl_delete_node(G->index, v->entry);
+ v->entry = NULL;
+ }
+ dmp_free_atom(G->pool, v->name, strlen(v->name)+1);
+ v->name = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int k;
+ for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_set_vertex_name: i = %d; vertex name too lon"
+ "g\n", i);
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_set_vertex_name: i = %d; vertex name contain"
+ "s invalid character(s)\n", i);
+ }
+ v->name = dmp_get_atom(G->pool, strlen(name)+1);
+ strcpy(v->name, name);
+ if (G->index != NULL)
+ { xassert(v->entry == NULL);
+ v->entry = avl_insert_node(G->index, v->name);
+ avl_set_node_link(v->entry, v);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_add_arc - add new arc to graph
+*
+* SYNOPSIS
+*
+* glp_arc *glp_add_arc(glp_graph *G, int i, int j);
+*
+* DESCRIPTION
+*
+* The routine glp_add_arc adds a new arc to the specified graph.
+*
+* The parameters i and j specify the ordinal numbers of, resp., tail
+* and head vertices of the arc. Note that self-loops and multiple arcs
+* are allowed.
+*
+* RETURNS
+*
+* The routine glp_add_arc returns a pointer to the arc added. */
+
+glp_arc *glp_add_arc(glp_graph *G, int i, int j)
+{ glp_arc *a;
+ if (!(1 <= i && i <= G->nv))
+ xerror("glp_add_arc: i = %d; tail vertex number out of range\n"
+ , i);
+ if (!(1 <= j && j <= G->nv))
+ xerror("glp_add_arc: j = %d; head vertex number out of range\n"
+ , j);
+ if (G->na == NA_MAX)
+ xerror("glp_add_arc: too many arcs\n");
+ a = dmp_get_atom(G->pool, sizeof(glp_arc));
+ a->tail = G->v[i];
+ a->head = G->v[j];
+ if (G->a_size == 0)
+ a->data = NULL;
+ else
+ { a->data = dmp_get_atom(G->pool, G->a_size);
+ memset(a->data, 0, G->a_size);
+ }
+ a->temp = NULL;
+ a->t_prev = NULL;
+ a->t_next = G->v[i]->out;
+ if (a->t_next != NULL) a->t_next->t_prev = a;
+ a->h_prev = NULL;
+ a->h_next = G->v[j]->in;
+ if (a->h_next != NULL) a->h_next->h_prev = a;
+ G->v[i]->out = G->v[j]->in = a;
+ G->na++;
+ return a;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_del_vertices - delete vertices from graph
+*
+* SYNOPSIS
+*
+* void glp_del_vertices(glp_graph *G, int ndel, const int num[]);
+*
+* DESCRIPTION
+*
+* The routine glp_del_vertices deletes vertices along with all
+* incident arcs from the specified graph. Ordinal numbers of vertices
+* to be deleted should be placed in locations num[1], ..., num[ndel],
+* ndel > 0.
+*
+* Note that deleting vertices involves changing ordinal numbers of
+* other vertices remaining in the graph. New ordinal numbers of the
+* remaining vertices are assigned under the assumption that the
+* original order of vertices is not changed. */
+
+void glp_del_vertices(glp_graph *G, int ndel, const int num[])
+{ glp_vertex *v;
+ int i, k, nv_new;
+ /* scan the list of vertices to be deleted */
+ if (!(1 <= ndel && ndel <= G->nv))
+ xerror("glp_del_vertices: ndel = %d; invalid number of vertice"
+ "s\n", ndel);
+ for (k = 1; k <= ndel; k++)
+ { /* take the number of vertex to be deleted */
+ i = num[k];
+ /* obtain pointer to i-th vertex */
+ if (!(1 <= i && i <= G->nv))
+ xerror("glp_del_vertices: num[%d] = %d; vertex number out o"
+ "f range\n", k, i);
+ v = G->v[i];
+ /* check that the vertex is not marked yet */
+ if (v->i == 0)
+ xerror("glp_del_vertices: num[%d] = %d; duplicate vertex nu"
+ "mbers not allowed\n", k, i);
+ /* erase symbolic name assigned to the vertex */
+ glp_set_vertex_name(G, i, NULL);
+ xassert(v->name == NULL);
+ xassert(v->entry == NULL);
+ /* free vertex data, if allocated */
+ if (v->data != NULL)
+ dmp_free_atom(G->pool, v->data, G->v_size);
+ /* delete all incoming arcs */
+ while (v->in != NULL)
+ glp_del_arc(G, v->in);
+ /* delete all outgoing arcs */
+ while (v->out != NULL)
+ glp_del_arc(G, v->out);
+ /* mark the vertex to be deleted */
+ v->i = 0;
+ }
+ /* delete all marked vertices from the vertex list */
+ nv_new = 0;
+ for (i = 1; i <= G->nv; i++)
+ { /* obtain pointer to i-th vertex */
+ v = G->v[i];
+ /* check if the vertex is marked */
+ if (v->i == 0)
+ { /* it is marked, delete it */
+ dmp_free_atom(G->pool, v, sizeof(glp_vertex));
+ }
+ else
+ { /* it is not marked, keep it */
+ v->i = ++nv_new;
+ G->v[v->i] = v;
+ }
+ }
+ /* set new number of vertices in the graph */
+ G->nv = nv_new;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_del_arc - delete arc from graph
+*
+* SYNOPSIS
+*
+* void glp_del_arc(glp_graph *G, glp_arc *a);
+*
+* DESCRIPTION
+*
+* The routine glp_del_arc deletes an arc from the specified graph.
+* The arc to be deleted must exist. */
+
+void glp_del_arc(glp_graph *G, glp_arc *a)
+{ /* some sanity checks */
+ xassert(G->na > 0);
+ xassert(1 <= a->tail->i && a->tail->i <= G->nv);
+ xassert(a->tail == G->v[a->tail->i]);
+ xassert(1 <= a->head->i && a->head->i <= G->nv);
+ xassert(a->head == G->v[a->head->i]);
+ /* remove the arc from the list of incoming arcs */
+ if (a->h_prev == NULL)
+ a->head->in = a->h_next;
+ else
+ a->h_prev->h_next = a->h_next;
+ if (a->h_next == NULL)
+ ;
+ else
+ a->h_next->h_prev = a->h_prev;
+ /* remove the arc from the list of outgoing arcs */
+ if (a->t_prev == NULL)
+ a->tail->out = a->t_next;
+ else
+ a->t_prev->t_next = a->t_next;
+ if (a->t_next == NULL)
+ ;
+ else
+ a->t_next->t_prev = a->t_prev;
+ /* free arc data, if allocated */
+ if (a->data != NULL)
+ dmp_free_atom(G->pool, a->data, G->a_size);
+ /* delete the arc from the graph */
+ dmp_free_atom(G->pool, a, sizeof(glp_arc));
+ G->na--;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_erase_graph - erase graph content
+*
+* SYNOPSIS
+*
+* void glp_erase_graph(glp_graph *G, int v_size, int a_size);
+*
+* DESCRIPTION
+*
+* The routine glp_erase_graph erases the content of the specified
+* graph. The effect of this operation is the same as if the graph
+* would be deleted with the routine glp_delete_graph and then created
+* anew with the routine glp_create_graph, with exception that the
+* handle (pointer) to the graph remains valid. */
+
+static void delete_graph(glp_graph *G)
+{ dmp_delete_pool(G->pool);
+ xfree(G->v);
+ if (G->index != NULL) avl_delete_tree(G->index);
+ return;
+}
+
+void glp_erase_graph(glp_graph *G, int v_size, int a_size)
+{ if (!(0 <= v_size && v_size <= 256))
+ xerror("glp_erase_graph: v_size = %d; invalid size of vertex d"
+ "ata\n", v_size);
+ if (!(0 <= a_size && a_size <= 256))
+ xerror("glp_erase_graph: a_size = %d; invalid size of arc data"
+ "\n", a_size);
+ delete_graph(G);
+ create_graph(G, v_size, a_size);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_delete_graph - delete graph
+*
+* SYNOPSIS
+*
+* void glp_delete_graph(glp_graph *G);
+*
+* DESCRIPTION
+*
+* The routine glp_delete_graph deletes the specified graph and frees
+* all the memory allocated to this program object. */
+
+void glp_delete_graph(glp_graph *G)
+{ delete_graph(G);
+ xfree(G);
+ return;
+}
+
+/**********************************************************************/
+
+void glp_create_v_index(glp_graph *G)
+{ /* create vertex name index */
+ glp_vertex *v;
+ int i;
+ if (G->index == NULL)
+ { G->index = avl_create_tree(avl_strcmp, NULL);
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ xassert(v->entry == NULL);
+ if (v->name != NULL)
+ { v->entry = avl_insert_node(G->index, v->name);
+ avl_set_node_link(v->entry, v);
+ }
+ }
+ }
+ return;
+}
+
+int glp_find_vertex(glp_graph *G, const char *name)
+{ /* find vertex by its name */
+ AVLNODE *node;
+ int i = 0;
+ if (G->index == NULL)
+ xerror("glp_find_vertex: vertex name index does not exist\n");
+ if (!(name == NULL || name[0] == '\0' || strlen(name) > 255))
+ { node = avl_find_node(G->index, name);
+ if (node != NULL)
+ i = ((glp_vertex *)avl_get_node_link(node))->i;
+ }
+ return i;
+}
+
+void glp_delete_v_index(glp_graph *G)
+{ /* delete vertex name index */
+ int i;
+ if (G->index != NULL)
+ { avl_delete_tree(G->index), G->index = NULL;
+ for (i = 1; i <= G->nv; i++) G->v[i]->entry = NULL;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/gridgen.c b/test/monniaux/glpk-4.65/src/api/gridgen.c
new file mode 100644
index 00000000..8cd3517f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/gridgen.c
@@ -0,0 +1,769 @@
+/* gridgen.c (grid-like network problem generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is a modified version of the program GRIDGEN, a grid-like
+* network problem generator developed by Yusin Lee and Jim Orlin.
+* The original code is publically available on the DIMACS ftp site at:
+* <ftp://dimacs.rutgers.edu/pub/netflow/generators/network/gridgen>.
+*
+* All changes concern only the program interface, so this modified
+* version produces exactly the same instances as the original version.
+*
+* Changes were made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_gridgen - grid-like network problem generator
+*
+* SYNOPSIS
+*
+* int glp_gridgen(glp_graph *G, int v_rhs, int a_cap, int a_cost,
+* const int parm[1+14]);
+*
+* DESCRIPTION
+*
+* The routine glp_gridgen is a grid-like network problem generator
+* developed by Yusin Lee and Jim Orlin.
+*
+* The parameter G specifies the graph object, to which the generated
+* problem data have to be stored. Note that on entry the graph object
+* is erased with the routine glp_erase_graph.
+*
+* The parameter v_rhs specifies an offset of the field of type double
+* in the vertex data block, to which the routine stores the supply or
+* demand value. If v_rhs < 0, the value is not stored.
+*
+* The parameter a_cap specifies an offset of the field of type double
+* in the arc data block, to which the routine stores the arc capacity.
+* If a_cap < 0, the capacity is not stored.
+*
+* The parameter a_cost specifies an offset of the field of type double
+* in the arc data block, to which the routine stores the per-unit cost
+* if the arc flow. If a_cost < 0, the cost is not stored.
+*
+* The array parm contains description of the network to be generated:
+*
+* parm[0] not used
+* parm[1] two-ways arcs indicator:
+* 1 - if links in both direction should be generated
+* 0 - otherwise
+* parm[2] random number seed (a positive integer)
+* parm[3] number of nodes (the number of nodes generated might be
+* slightly different to make the network a grid)
+* parm[4] grid width
+* parm[5] number of sources
+* parm[6] number of sinks
+* parm[7] average degree
+* parm[8] total flow
+* parm[9] distribution of arc costs:
+* 1 - uniform
+* 2 - exponential
+* parm[10] lower bound for arc cost (uniform)
+* 100 * lambda (exponential)
+* parm[11] upper bound for arc cost (uniform)
+* not used (exponential)
+* parm[12] distribution of arc capacities:
+* 1 - uniform
+* 2 - exponential
+* parm[13] lower bound for arc capacity (uniform)
+* 100 * lambda (exponential)
+* parm[14] upper bound for arc capacity (uniform)
+* not used (exponential)
+*
+* RETURNS
+*
+* If the instance was successfully generated, the routine glp_gridgen
+* returns zero; otherwise, if specified parameters are inconsistent,
+* the routine returns a non-zero error code.
+*
+* COMMENTS
+*
+* This network generator generates a grid-like network plus a super
+* node. In additional to the arcs connecting the nodes in the grid,
+* there is an arc from each supply node to the super node and from the
+* super node to each demand node to guarantee feasiblity. These arcs
+* have very high costs and very big capacities.
+*
+* The idea of this network generator is as follows: First, a grid of
+* n1 * n2 is generated. For example, 5 * 3. The nodes are numbered as
+* 1 to 15, and the supernode is numbered as n1*n2+1. Then arcs between
+* adjacent nodes are generated. For these arcs, the user is allowed to
+* specify either to generate two-way arcs or one-way arcs. If two-way
+* arcs are to be generated, two arcs, one in each direction, will be
+* generated between each adjacent node pairs. Otherwise, only one arc
+* will be generated. If this is the case, the arcs will be generated
+* in alterntive directions as shown below.
+*
+* 1 ---> 2 ---> 3 ---> 4 ---> 5
+* | ^ | ^ |
+* | | | | |
+* V | V | V
+* 6 <--- 7 <--- 8 <--- 9 <--- 10
+* | ^ | ^ |
+* | | | | |
+* V | V | V
+* 11 --->12 --->13 --->14 ---> 15
+*
+* Then the arcs between the super node and the source/sink nodes are
+* added as mentioned before. If the number of arcs still doesn't reach
+* the requirement, additional arcs will be added by uniformly picking
+* random node pairs. There is no checking to prevent multiple arcs
+* between any pair of nodes. However, there will be no self-arcs (arcs
+* that poins back to its tail node) in the network.
+*
+* The source and sink nodes are selected uniformly in the network, and
+* the imbalances of each source/sink node are also assigned by uniform
+* distribution. */
+
+struct stat_para
+{ /* structure for statistical distributions */
+ int distribution;
+ /* the distribution: */
+#define UNIFORM 1 /* uniform distribution */
+#define EXPONENTIAL 2 /* exponential distribution */
+ double parameter[5];
+ /* the parameters of the distribution */
+};
+
+struct arcs
+{ int from;
+ /* the FROM node of that arc */
+ int to;
+ /* the TO node of that arc */
+ int cost;
+ /* original cost of that arc */
+ int u;
+ /* capacity of the arc */
+};
+
+struct imbalance
+{ int node;
+ /* Node ID */
+ int supply;
+ /* Supply of that node */
+};
+
+struct csa
+{ /* common storage area */
+ glp_graph *G;
+ int v_rhs, a_cap, a_cost;
+ int seed;
+ /* random number seed */
+ int seed_original;
+ /* the original seed from input */
+ int two_way;
+ /* 0: generate arcs in both direction for the basic grid, except
+ for the arcs to/from the super node. 1: o/w */
+ int n_node;
+ /* total number of nodes in the network, numbered 1 to n_node,
+ including the super node, which is the last one */
+ int n_arc;
+ /* total number of arcs in the network, counting EVERY arc. */
+ int n_grid_arc;
+ /* number of arcs in the basic grid, including the arcs to/from
+ the super node */
+ int n_source, n_sink;
+ /* number of source and sink nodes */
+ int avg_degree;
+ /* average degree, arcs to and from the super node are counted */
+ int t_supply;
+ /* total supply in the network */
+ int n1, n2;
+ /* the two edges of the network grid. n1 >= n2 */
+ struct imbalance *source_list, *sink_list;
+ /* head of the array of source/sink nodes */
+ struct stat_para arc_costs;
+ /* the distribution of arc costs */
+ struct stat_para capacities;
+ /* distribution of the capacities of the arcs */
+ struct arcs *arc_list;
+ /* head of the arc list array. Arcs in this array are in the
+ order of grid_arcs, arcs to/from super node, and other arcs */
+};
+
+#define G (csa->G)
+#define v_rhs (csa->v_rhs)
+#define a_cap (csa->a_cap)
+#define a_cost (csa->a_cost)
+#define seed (csa->seed)
+#define seed_original (csa->seed_original)
+#define two_way (csa->two_way)
+#define n_node (csa->n_node)
+#define n_arc (csa->n_arc)
+#define n_grid_arc (csa->n_grid_arc)
+#define n_source (csa->n_source)
+#define n_sink (csa->n_sink)
+#define avg_degree (csa->avg_degree)
+#define t_supply (csa->t_supply)
+#define n1 (csa->n1)
+#define n2 (csa->n2)
+#define source_list (csa->source_list)
+#define sink_list (csa->sink_list)
+#define arc_costs (csa->arc_costs)
+#define capacities (csa->capacities)
+#define arc_list (csa->arc_list)
+
+static void assign_capacities(struct csa *csa);
+static void assign_costs(struct csa *csa);
+static void assign_imbalance(struct csa *csa);
+static int exponential(struct csa *csa, double lambda[1]);
+static struct arcs *gen_additional_arcs(struct csa *csa, struct arcs
+ *arc_ptr);
+static struct arcs *gen_basic_grid(struct csa *csa, struct arcs
+ *arc_ptr);
+static void gen_more_arcs(struct csa *csa, struct arcs *arc_ptr);
+static void generate(struct csa *csa);
+static void output(struct csa *csa);
+static double randy(struct csa *csa);
+static void select_source_sinks(struct csa *csa);
+static int uniform(struct csa *csa, double a[2]);
+
+int glp_gridgen(glp_graph *G_, int _v_rhs, int _a_cap, int _a_cost,
+ const int parm[1+14])
+{ struct csa _csa, *csa = &_csa;
+ int n, ret;
+ G = G_;
+ v_rhs = _v_rhs;
+ a_cap = _a_cap;
+ a_cost = _a_cost;
+ if (G != NULL)
+ { if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_gridgen: v_rhs = %d; invalid offset\n", v_rhs);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_gridgen: a_cap = %d; invalid offset\n", a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_gridgen: a_cost = %d; invalid offset\n", a_cost)
+ ;
+ }
+ /* Check the parameters for consistency. */
+ if (!(parm[1] == 0 || parm[1] == 1))
+ { ret = 1;
+ goto done;
+ }
+ if (parm[2] < 1)
+ { ret = 2;
+ goto done;
+ }
+ if (!(10 <= parm[3] && parm[3] <= 40000))
+ { ret = 3;
+ goto done;
+ }
+ if (!(1 <= parm[4] && parm[4] <= 40000))
+ { ret = 4;
+ goto done;
+ }
+ if (!(parm[5] >= 0 && parm[6] >= 0 && parm[5] + parm[6] <=
+ parm[3]))
+ { ret = 5;
+ goto done;
+ }
+ if (!(1 <= parm[7] && parm[7] <= parm[3]))
+ { ret = 6;
+ goto done;
+ }
+ if (parm[8] < 0)
+ { ret = 7;
+ goto done;
+ }
+ if (!(parm[9] == 1 || parm[9] == 2))
+ { ret = 8;
+ goto done;
+ }
+ if (parm[9] == 1 && parm[10] > parm[11] ||
+ parm[9] == 2 && parm[10] < 1)
+ { ret = 9;
+ goto done;
+ }
+ if (!(parm[12] == 1 || parm[12] == 2))
+ { ret = 10;
+ goto done;
+ }
+ if (parm[12] == 1 && !(0 <= parm[13] && parm[13] <= parm[14]) ||
+ parm[12] == 2 && parm[13] < 1)
+ { ret = 11;
+ goto done;
+ }
+ /* Initialize the graph object. */
+ if (G != NULL)
+ { glp_erase_graph(G, G->v_size, G->a_size);
+ glp_set_graph_name(G, "GRIDGEN");
+ }
+ /* Copy the generator parameters. */
+ two_way = parm[1];
+ seed_original = seed = parm[2];
+ n_node = parm[3];
+ n = parm[4];
+ n_source = parm[5];
+ n_sink = parm[6];
+ avg_degree = parm[7];
+ t_supply = parm[8];
+ arc_costs.distribution = parm[9];
+ if (parm[9] == 1)
+ { arc_costs.parameter[0] = parm[10];
+ arc_costs.parameter[1] = parm[11];
+ }
+ else
+ { arc_costs.parameter[0] = (double)parm[10] / 100.0;
+ arc_costs.parameter[1] = 0.0;
+ }
+ capacities.distribution = parm[12];
+ if (parm[12] == 1)
+ { capacities.parameter[0] = parm[13];
+ capacities.parameter[1] = parm[14];
+ }
+ else
+ { capacities.parameter[0] = (double)parm[13] / 100.0;
+ capacities.parameter[1] = 0.0;
+ }
+ /* Calculate the edge lengths of the grid according to the
+ input. */
+ if (n * n >= n_node)
+ { n1 = n;
+ n2 = (int)((double)n_node / (double)n + 0.5);
+ }
+ else
+ { n2 = n;
+ n1 = (int)((double)n_node / (double)n + 0.5);
+ }
+ /* Recalculate the total number of nodes and plus 1 for the super
+ node. */
+ n_node = n1 * n2 + 1;
+ n_arc = n_node * avg_degree;
+ n_grid_arc = (two_way + 1) * ((n1 - 1) * n2 + (n2 - 1) * n1) +
+ n_source + n_sink;
+ if (n_grid_arc > n_arc) n_arc = n_grid_arc;
+ arc_list = xcalloc(n_arc, sizeof(struct arcs));
+ source_list = xcalloc(n_source, sizeof(struct imbalance));
+ sink_list = xcalloc(n_sink, sizeof(struct imbalance));
+ /* Generate a random network. */
+ generate(csa);
+ /* Output the network. */
+ output(csa);
+ /* Free all allocated memory. */
+ xfree(arc_list);
+ xfree(source_list);
+ xfree(sink_list);
+ /* The instance has been successfully generated. */
+ ret = 0;
+done: return ret;
+}
+
+#undef random
+
+static void assign_capacities(struct csa *csa)
+{ /* Assign a capacity to each arc. */
+ struct arcs *arc_ptr = arc_list;
+ int (*random)(struct csa *csa, double *);
+ int i;
+ /* Determine the random number generator to use. */
+ switch (arc_costs.distribution)
+ { case UNIFORM:
+ random = uniform;
+ break;
+ case EXPONENTIAL:
+ random = exponential;
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ /* Assign capacities to grid arcs. */
+ for (i = n_source + n_sink; i < n_grid_arc; i++, arc_ptr++)
+ arc_ptr->u = random(csa, capacities.parameter);
+ i = i - n_source - n_sink;
+ /* Assign capacities to arcs to/from supernode. */
+ for (; i < n_grid_arc; i++, arc_ptr++)
+ arc_ptr->u = t_supply;
+ /* Assign capacities to all other arcs. */
+ for (; i < n_arc; i++, arc_ptr++)
+ arc_ptr->u = random(csa, capacities.parameter);
+ return;
+}
+
+static void assign_costs(struct csa *csa)
+{ /* Assign a cost to each arc. */
+ struct arcs *arc_ptr = arc_list;
+ int (*random)(struct csa *csa, double *);
+ int i;
+ /* A high cost assigned to arcs to/from the supernode. */
+ int high_cost;
+ /* The maximum cost assigned to arcs in the base grid. */
+ int max_cost = 0;
+ /* Determine the random number generator to use. */
+ switch (arc_costs.distribution)
+ { case UNIFORM:
+ random = uniform;
+ break;
+ case EXPONENTIAL:
+ random = exponential;
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ /* Assign costs to arcs in the base grid. */
+ for (i = n_source + n_sink; i < n_grid_arc; i++, arc_ptr++)
+ { arc_ptr->cost = random(csa, arc_costs.parameter);
+ if (max_cost < arc_ptr->cost) max_cost = arc_ptr->cost;
+ }
+ i = i - n_source - n_sink;
+ /* Assign costs to arcs to/from the super node. */
+ high_cost = max_cost * 2;
+ for (; i < n_grid_arc; i++, arc_ptr++)
+ arc_ptr->cost = high_cost;
+ /* Assign costs to all other arcs. */
+ for (; i < n_arc; i++, arc_ptr++)
+ arc_ptr->cost = random(csa, arc_costs.parameter);
+ return;
+}
+
+static void assign_imbalance(struct csa *csa)
+{ /* Assign an imbalance to each node. */
+ int total, i;
+ double avg;
+ struct imbalance *ptr;
+ /* assign the supply nodes */
+ avg = 2.0 * t_supply / n_source;
+ do
+ { for (i = 1, total = t_supply, ptr = source_list + 1;
+ i < n_source; i++, ptr++)
+ { ptr->supply = (int)(randy(csa) * avg + 0.5);
+ total -= ptr->supply;
+ }
+ source_list->supply = total;
+ }
+ /* redo all if the assignment "overshooted" */
+ while (total <= 0);
+ /* assign the demand nodes */
+ avg = -2.0 * t_supply / n_sink;
+ do
+ { for (i = 1, total = t_supply, ptr = sink_list + 1;
+ i < n_sink; i++, ptr++)
+ { ptr->supply = (int)(randy(csa) * avg - 0.5);
+ total += ptr->supply;
+ }
+ sink_list->supply = - total;
+ }
+ while (total <= 0);
+ return;
+}
+
+static int exponential(struct csa *csa, double lambda[1])
+{ /* Returns an "exponentially distributed" integer with parameter
+ lambda. */
+ return ((int)(- lambda[0] * log((double)randy(csa)) + 0.5));
+}
+
+static struct arcs *gen_additional_arcs(struct csa *csa, struct arcs
+ *arc_ptr)
+{ /* Generate an arc from each source to the supernode and from
+ supernode to each sink. */
+ int i;
+ for (i = 0; i < n_source; i++, arc_ptr++)
+ { arc_ptr->from = source_list[i].node;
+ arc_ptr->to = n_node;
+ }
+ for (i = 0; i < n_sink; i++, arc_ptr++)
+ { arc_ptr->to = sink_list[i].node;
+ arc_ptr->from = n_node;
+ }
+ return arc_ptr;
+}
+
+static struct arcs *gen_basic_grid(struct csa *csa, struct arcs
+ *arc_ptr)
+{ /* Generate the basic grid. */
+ int direction = 1, i, j, k;
+ if (two_way)
+ { /* Generate an arc in each direction. */
+ for (i = 1; i < n_node; i += n1)
+ { for (j = i, k = j + n1 - 1; j < k; j++)
+ { arc_ptr->from = j;
+ arc_ptr->to = j + 1;
+ arc_ptr++;
+ arc_ptr->from = j + 1;
+ arc_ptr->to = j;
+ arc_ptr++;
+ }
+ }
+ for (i = 1; i <= n1; i++)
+ { for (j = i + n1; j < n_node; j += n1)
+ { arc_ptr->from = j;
+ arc_ptr->to = j - n1;
+ arc_ptr++;
+ arc_ptr->from = j - n1;
+ arc_ptr->to = j;
+ arc_ptr++;
+ }
+ }
+ }
+ else
+ { /* Generate one arc in each direction. */
+ for (i = 1; i < n_node; i += n1)
+ { if (direction == 1)
+ j = i;
+ else
+ j = i + 1;
+ for (k = j + n1 - 1; j < k; j++)
+ { arc_ptr->from = j;
+ arc_ptr->to = j + direction;
+ arc_ptr++;
+ }
+ direction = - direction;
+ }
+ for (i = 1; i <= n1; i++)
+ { j = i + n1;
+ if (direction == 1)
+ { for (; j < n_node; j += n1)
+ { arc_ptr->from = j - n1;
+ arc_ptr->to = j;
+ arc_ptr++;
+ }
+ }
+ else
+ { for (; j < n_node; j += n1)
+ { arc_ptr->from = j - n1;
+ arc_ptr->to = j;
+ arc_ptr++;
+ }
+ }
+ direction = - direction;
+ }
+ }
+ return arc_ptr;
+}
+
+static void gen_more_arcs(struct csa *csa, struct arcs *arc_ptr)
+{ /* Generate random arcs to meet the specified density. */
+ int i;
+ double ab[2];
+ ab[0] = 0.9;
+ ab[1] = n_node - 0.99; /* upper limit is n_node-1 because the
+ supernode cannot be selected */
+ for (i = n_grid_arc; i < n_arc; i++, arc_ptr++)
+ { arc_ptr->from = uniform(csa, ab);
+ arc_ptr->to = uniform(csa, ab);
+ if (arc_ptr->from == arc_ptr->to)
+ { arc_ptr--;
+ i--;
+ }
+ }
+ return;
+}
+
+static void generate(struct csa *csa)
+{ /* Generate a random network. */
+ struct arcs *arc_ptr = arc_list;
+ arc_ptr = gen_basic_grid(csa, arc_ptr);
+ select_source_sinks(csa);
+ arc_ptr = gen_additional_arcs(csa, arc_ptr);
+ gen_more_arcs(csa, arc_ptr);
+ assign_costs(csa);
+ assign_capacities(csa);
+ assign_imbalance(csa);
+ return;
+}
+
+static void output(struct csa *csa)
+{ /* Output the network in DIMACS format. */
+ struct arcs *arc_ptr;
+ struct imbalance *imb_ptr;
+ int i;
+ if (G != NULL) goto skip;
+ /* Output "c", "p" records. */
+ xprintf("c generated by GRIDGEN\n");
+ xprintf("c seed %d\n", seed_original);
+ xprintf("c nodes %d\n", n_node);
+ xprintf("c grid size %d X %d\n", n1, n2);
+ xprintf("c sources %d sinks %d\n", n_source, n_sink);
+ xprintf("c avg. degree %d\n", avg_degree);
+ xprintf("c supply %d\n", t_supply);
+ switch (arc_costs.distribution)
+ { case UNIFORM:
+ xprintf("c arc costs: UNIFORM distr. min %d max %d\n",
+ (int)arc_costs.parameter[0],
+ (int)arc_costs.parameter[1]);
+ break;
+ case EXPONENTIAL:
+ xprintf("c arc costs: EXPONENTIAL distr. lambda %d\n",
+ (int)arc_costs.parameter[0]);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ switch (capacities.distribution)
+ { case UNIFORM:
+ xprintf("c arc caps : UNIFORM distr. min %d max %d\n",
+ (int)capacities.parameter[0],
+ (int)capacities.parameter[1]);
+ break;
+ case EXPONENTIAL:
+ xprintf("c arc caps : EXPONENTIAL distr. %d lambda %d\n",
+ (int)capacities.parameter[0]);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+skip: if (G == NULL)
+ xprintf("p min %d %d\n", n_node, n_arc);
+ else
+ { glp_add_vertices(G, n_node);
+ if (v_rhs >= 0)
+ { double zero = 0.0;
+ for (i = 1; i <= n_node; i++)
+ { glp_vertex *v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &zero, sizeof(double));
+ }
+ }
+ }
+ /* Output "n node supply". */
+ for (i = 0, imb_ptr = source_list; i < n_source; i++, imb_ptr++)
+ { if (G == NULL)
+ xprintf("n %d %d\n", imb_ptr->node, imb_ptr->supply);
+ else
+ { if (v_rhs >= 0)
+ { double temp = (double)imb_ptr->supply;
+ glp_vertex *v = G->v[imb_ptr->node];
+ memcpy((char *)v->data + v_rhs, &temp, sizeof(double));
+ }
+ }
+ }
+ for (i = 0, imb_ptr = sink_list; i < n_sink; i++, imb_ptr++)
+ { if (G == NULL)
+ xprintf("n %d %d\n", imb_ptr->node, imb_ptr->supply);
+ else
+ { if (v_rhs >= 0)
+ { double temp = (double)imb_ptr->supply;
+ glp_vertex *v = G->v[imb_ptr->node];
+ memcpy((char *)v->data + v_rhs, &temp, sizeof(double));
+ }
+ }
+ }
+ /* Output "a from to lowcap=0 hicap cost". */
+ for (i = 0, arc_ptr = arc_list; i < n_arc; i++, arc_ptr++)
+ { if (G == NULL)
+ xprintf("a %d %d 0 %d %d\n", arc_ptr->from, arc_ptr->to,
+ arc_ptr->u, arc_ptr->cost);
+ else
+ { glp_arc *a = glp_add_arc(G, arc_ptr->from, arc_ptr->to);
+ if (a_cap >= 0)
+ { double temp = (double)arc_ptr->u;
+ memcpy((char *)a->data + a_cap, &temp, sizeof(double));
+ }
+ if (a_cost >= 0)
+ { double temp = (double)arc_ptr->cost;
+ memcpy((char *)a->data + a_cost, &temp, sizeof(double));
+ }
+ }
+ }
+ return;
+}
+
+static double randy(struct csa *csa)
+{ /* Returns a random number between 0.0 and 1.0.
+ See Ward Cheney & David Kincaid, "Numerical Mathematics and
+ Computing," 2Ed, pp. 335. */
+ seed = 16807 * seed % 2147483647;
+ if (seed < 0) seed = - seed;
+ return seed * 4.6566128752459e-10;
+}
+
+static void select_source_sinks(struct csa *csa)
+{ /* Randomly select the source nodes and sink nodes. */
+ int i, *int_ptr;
+ int *temp_list; /* a temporary list of nodes */
+ struct imbalance *ptr;
+ double ab[2]; /* parameter for random number generator */
+ ab[0] = 0.9;
+ ab[1] = n_node - 0.99; /* upper limit is n_node-1 because the
+ supernode cannot be selected */
+ temp_list = xcalloc(n_node, sizeof(int));
+ for (i = 0, int_ptr = temp_list; i < n_node; i++, int_ptr++)
+ *int_ptr = 0;
+ /* Select the source nodes. */
+ for (i = 0, ptr = source_list; i < n_source; i++, ptr++)
+ { ptr->node = uniform(csa, ab);
+ if (temp_list[ptr->node] == 1) /* check for duplicates */
+ { ptr--;
+ i--;
+ }
+ else
+ temp_list[ptr->node] = 1;
+ }
+ /* Select the sink nodes. */
+ for (i = 0, ptr = sink_list; i < n_sink; i++, ptr++)
+ { ptr->node = uniform(csa, ab);
+ if (temp_list[ptr->node] == 1)
+ { ptr--;
+ i--;
+ }
+ else
+ temp_list[ptr->node] = 1;
+ }
+ xfree(temp_list);
+ return;
+}
+
+int uniform(struct csa *csa, double a[2])
+{ /* Generates an integer uniformly selected from [a[0],a[1]]. */
+ return (int)((a[1] - a[0]) * randy(csa) + a[0] + 0.5);
+}
+
+/**********************************************************************/
+
+#if 0
+int main(void)
+{ int parm[1+14];
+ double temp;
+ scanf("%d", &parm[1]);
+ scanf("%d", &parm[2]);
+ scanf("%d", &parm[3]);
+ scanf("%d", &parm[4]);
+ scanf("%d", &parm[5]);
+ scanf("%d", &parm[6]);
+ scanf("%d", &parm[7]);
+ scanf("%d", &parm[8]);
+ scanf("%d", &parm[9]);
+ if (parm[9] == 1)
+ { scanf("%d", &parm[10]);
+ scanf("%d", &parm[11]);
+ }
+ else
+ { scanf("%le", &temp);
+ parm[10] = (int)(100.0 * temp + .5);
+ parm[11] = 0;
+ }
+ scanf("%d", &parm[12]);
+ if (parm[12] == 1)
+ { scanf("%d", &parm[13]);
+ scanf("%d", &parm[14]);
+ }
+ else
+ { scanf("%le", &temp);
+ parm[13] = (int)(100.0 * temp + .5);
+ parm[14] = 0;
+ }
+ glp_gridgen(NULL, 0, 0, 0, parm);
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/intfeas1.c b/test/monniaux/glpk-4.65/src/api/intfeas1.c
new file mode 100644
index 00000000..43064351
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/intfeas1.c
@@ -0,0 +1,267 @@
+/* intfeas1.c (solve integer feasibility problem) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2011-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+int glp_intfeas1(glp_prob *P, int use_bound, int obj_bound)
+{ /* solve integer feasibility problem */
+ NPP *npp = NULL;
+ glp_prob *mip = NULL;
+ int *obj_ind = NULL;
+ double *obj_val = NULL;
+ int obj_row = 0;
+ int i, j, k, obj_len, temp, ret;
+#if 0 /* 04/IV-2016 */
+ /* check the problem object */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_intfeas1: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (P->tree != NULL)
+ xerror("glp_intfeas1: operation not allowed\n");
+ /* integer solution is currently undefined */
+ P->mip_stat = GLP_UNDEF;
+ P->mip_obj = 0.0;
+ /* check columns (variables) */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+#if 0 /* binarization is not yet implemented */
+ if (!(col->kind == GLP_IV || col->type == GLP_FX))
+ { xprintf("glp_intfeas1: column %d: non-integer non-fixed var"
+ "iable not allowed\n", j);
+#else
+ if (!((col->kind == GLP_IV && col->lb == 0.0 && col->ub == 1.0)
+ || col->type == GLP_FX))
+ { xprintf("glp_intfeas1: column %d: non-binary non-fixed vari"
+ "able not allowed\n", j);
+#endif
+ ret = GLP_EDATA;
+ goto done;
+ }
+ temp = (int)col->lb;
+ if ((double)temp != col->lb)
+ { if (col->type == GLP_FX)
+ xprintf("glp_intfeas1: column %d: fixed value %g is non-"
+ "integer or out of range\n", j, col->lb);
+ else
+ xprintf("glp_intfeas1: column %d: lower bound %g is non-"
+ "integer or out of range\n", j, col->lb);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ temp = (int)col->ub;
+ if ((double)temp != col->ub)
+ { xprintf("glp_intfeas1: column %d: upper bound %g is non-int"
+ "eger or out of range\n", j, col->ub);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ if (col->type == GLP_DB && col->lb > col->ub)
+ { xprintf("glp_intfeas1: column %d: lower bound %g is greater"
+ " than upper bound %g\n", j, col->lb, col->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ /* check rows (constraints) */
+ for (i = 1; i <= P->m; i++)
+ { GLPROW *row = P->row[i];
+ GLPAIJ *aij;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { temp = (int)aij->val;
+ if ((double)temp != aij->val)
+ { xprintf("glp_intfeas1: row = %d, column %d: constraint c"
+ "oefficient %g is non-integer or out of range\n",
+ i, aij->col->j, aij->val);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ }
+ temp = (int)row->lb;
+ if ((double)temp != row->lb)
+ { if (row->type == GLP_FX)
+ xprintf("glp_intfeas1: row = %d: fixed value %g is non-i"
+ "nteger or out of range\n", i, row->lb);
+ else
+ xprintf("glp_intfeas1: row = %d: lower bound %g is non-i"
+ "nteger or out of range\n", i, row->lb);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ temp = (int)row->ub;
+ if ((double)temp != row->ub)
+ { xprintf("glp_intfeas1: row = %d: upper bound %g is non-inte"
+ "ger or out of range\n", i, row->ub);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ if (row->type == GLP_DB && row->lb > row->ub)
+ { xprintf("glp_intfeas1: row %d: lower bound %g is greater th"
+ "an upper bound %g\n", i, row->lb, row->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ /* check the objective function */
+#if 1 /* 08/I-2017 by cmatraki & mao */
+ if (!use_bound)
+ { /* skip check if no obj. bound is specified */
+ goto skip;
+ }
+#endif
+ temp = (int)P->c0;
+ if ((double)temp != P->c0)
+ { xprintf("glp_intfeas1: objective constant term %g is non-integ"
+ "er or out of range\n", P->c0);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ for (j = 1; j <= P->n; j++)
+ { temp = (int)P->col[j]->coef;
+ if ((double)temp != P->col[j]->coef)
+ { xprintf("glp_intfeas1: column %d: objective coefficient is "
+ "non-integer or out of range\n", j, P->col[j]->coef);
+ ret = GLP_EDATA;
+ goto done;
+ }
+ }
+#if 1 /* 08/I-2017 by cmatraki & mao */
+skip: ;
+#endif
+ /* save the objective function and set it to zero */
+ obj_ind = xcalloc(1+P->n, sizeof(int));
+ obj_val = xcalloc(1+P->n, sizeof(double));
+ obj_len = 0;
+ obj_ind[0] = 0;
+ obj_val[0] = P->c0;
+ P->c0 = 0.0;
+ for (j = 1; j <= P->n; j++)
+ { if (P->col[j]->coef != 0.0)
+ { obj_len++;
+ obj_ind[obj_len] = j;
+ obj_val[obj_len] = P->col[j]->coef;
+ P->col[j]->coef = 0.0;
+ }
+ }
+ /* add inequality to bound the objective function, if required */
+ if (!use_bound)
+ xprintf("Will search for ANY feasible solution\n");
+ else
+ { xprintf("Will search only for solution not worse than %d\n",
+ obj_bound);
+ obj_row = glp_add_rows(P, 1);
+ glp_set_mat_row(P, obj_row, obj_len, obj_ind, obj_val);
+ if (P->dir == GLP_MIN)
+ glp_set_row_bnds(P, obj_row,
+ GLP_UP, 0.0, (double)obj_bound - obj_val[0]);
+ else if (P->dir == GLP_MAX)
+ glp_set_row_bnds(P, obj_row,
+ GLP_LO, (double)obj_bound - obj_val[0], 0.0);
+ else
+ xassert(P != P);
+ }
+ /* create preprocessor workspace */
+ xprintf("Translating to CNF-SAT...\n");
+ xprintf("Original problem has %d row%s, %d column%s, and %d non-z"
+ "ero%s\n", P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" :
+ "s", P->nnz, P->nnz == 1 ? "" : "s");
+ npp = npp_create_wksp();
+ /* load the original problem into the preprocessor workspace */
+ npp_load_prob(npp, P, GLP_OFF, GLP_MIP, GLP_OFF);
+ /* perform translation to SAT-CNF problem instance */
+ ret = npp_sat_encode_prob(npp);
+ if (ret == 0)
+ ;
+ else if (ret == GLP_ENOPFS)
+ xprintf("PROBLEM HAS NO INTEGER FEASIBLE SOLUTION\n");
+ else if (ret == GLP_ERANGE)
+ xprintf("glp_intfeas1: translation to SAT-CNF failed because o"
+ "f integer overflow\n");
+ else
+ xassert(ret != ret);
+ if (ret != 0)
+ goto done;
+ /* build SAT-CNF problem instance and try to solve it */
+ mip = glp_create_prob();
+ npp_build_prob(npp, mip);
+ ret = glp_minisat1(mip);
+ /* only integer feasible solution can be postprocessed */
+ if (!(mip->mip_stat == GLP_OPT || mip->mip_stat == GLP_FEAS))
+ { P->mip_stat = mip->mip_stat;
+ goto done;
+ }
+ /* postprocess the solution found */
+ npp_postprocess(npp, mip);
+ /* the transformed problem is no longer needed */
+ glp_delete_prob(mip), mip = NULL;
+ /* store solution to the original problem object */
+ npp_unload_sol(npp, P);
+ /* change the solution status to 'integer feasible' */
+ P->mip_stat = GLP_FEAS;
+ /* check integer feasibility */
+ for (i = 1; i <= P->m; i++)
+ { GLPROW *row;
+ GLPAIJ *aij;
+ double sum;
+ row = P->row[i];
+ sum = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ sum += aij->val * aij->col->mipx;
+ xassert(sum == row->mipx);
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ xassert(sum >= row->lb);
+ if (row->type == GLP_UP || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ xassert(sum <= row->ub);
+ }
+ /* compute value of the original objective function */
+ P->mip_obj = obj_val[0];
+ for (k = 1; k <= obj_len; k++)
+ P->mip_obj += obj_val[k] * P->col[obj_ind[k]]->mipx;
+ xprintf("Objective value = %17.9e\n", P->mip_obj);
+done: /* delete the transformed problem, if it exists */
+ if (mip != NULL)
+ glp_delete_prob(mip);
+ /* delete the preprocessor workspace, if it exists */
+ if (npp != NULL)
+ npp_delete_wksp(npp);
+ /* remove inequality used to bound the objective function */
+ if (obj_row > 0)
+ { int ind[1+1];
+ ind[1] = obj_row;
+ glp_del_rows(P, 1, ind);
+ }
+ /* restore the original objective function */
+ if (obj_ind != NULL)
+ { P->c0 = obj_val[0];
+ for (k = 1; k <= obj_len; k++)
+ P->col[obj_ind[k]]->coef = obj_val[k];
+ xfree(obj_ind);
+ xfree(obj_val);
+ }
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/maxffalg.c b/test/monniaux/glpk-4.65/src/api/maxffalg.c
new file mode 100644
index 00000000..0f3f9b04
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/maxffalg.c
@@ -0,0 +1,130 @@
+/* maxffalg.c (find maximal flow with Ford-Fulkerson algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ffalg.h"
+#include "glpk.h"
+
+int glp_maxflow_ffalg(glp_graph *G, int s, int t, int a_cap,
+ double *sol, int a_x, int v_cut)
+{ /* find maximal flow with Ford-Fulkerson algorithm */
+ glp_vertex *v;
+ glp_arc *a;
+ int nv, na, i, k, flag, *tail, *head, *cap, *x, ret;
+ char *cut;
+ double temp;
+ if (!(1 <= s && s <= G->nv))
+ xerror("glp_maxflow_ffalg: s = %d; source node number out of r"
+ "ange\n", s);
+ if (!(1 <= t && t <= G->nv))
+ xerror("glp_maxflow_ffalg: t = %d: sink node number out of ran"
+ "ge\n", t);
+ if (s == t)
+ xerror("glp_maxflow_ffalg: s = t = %d; source and sink nodes m"
+ "ust be distinct\n", s);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_maxflow_ffalg: a_cap = %d; invalid offset\n",
+ a_cap);
+ if (v_cut >= 0 && v_cut > G->v_size - (int)sizeof(int))
+ xerror("glp_maxflow_ffalg: v_cut = %d; invalid offset\n",
+ v_cut);
+ /* allocate working arrays */
+ nv = G->nv;
+ na = G->na;
+ tail = xcalloc(1+na, sizeof(int));
+ head = xcalloc(1+na, sizeof(int));
+ cap = xcalloc(1+na, sizeof(int));
+ x = xcalloc(1+na, sizeof(int));
+ if (v_cut < 0)
+ cut = NULL;
+ else
+ cut = xcalloc(1+nv, sizeof(char));
+ /* copy the flow network */
+ k = 0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ tail[k] = a->tail->i;
+ head[k] = a->head->i;
+ if (tail[k] == head[k])
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ if (a_cap >= 0)
+ memcpy(&temp, (char *)a->data + a_cap, sizeof(double));
+ else
+ temp = 1.0;
+ if (!(0.0 <= temp && temp <= (double)INT_MAX &&
+ temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ cap[k] = (int)temp;
+ }
+ }
+ xassert(k == na);
+ /* find maximal flow in the flow network */
+ ffalg(nv, na, tail, head, s, t, cap, x, cut);
+ ret = 0;
+ /* store solution components */
+ /* (objective function = total flow through the network) */
+ if (sol != NULL)
+ { temp = 0.0;
+ for (k = 1; k <= na; k++)
+ { if (tail[k] == s)
+ temp += (double)x[k];
+ else if (head[k] == s)
+ temp -= (double)x[k];
+ }
+ *sol = temp;
+ }
+ /* (arc flows) */
+ if (a_x >= 0)
+ { k = 0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { temp = (double)x[++k];
+ memcpy((char *)a->data + a_x, &temp, sizeof(double));
+ }
+ }
+ }
+ /* (node flags) */
+ if (v_cut >= 0)
+ { for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ flag = cut[i];
+ memcpy((char *)v->data + v_cut, &flag, sizeof(int));
+ }
+ }
+done: /* free working arrays */
+ xfree(tail);
+ xfree(head);
+ xfree(cap);
+ xfree(x);
+ if (cut != NULL) xfree(cut);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/maxflp.c b/test/monniaux/glpk-4.65/src/api/maxflp.c
new file mode 100644
index 00000000..1135b78c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/maxflp.c
@@ -0,0 +1,114 @@
+/* maxflp.c (convert maximum flow problem to LP) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_maxflow_lp - convert maximum flow problem to LP
+*
+* SYNOPSIS
+*
+* void glp_maxflow_lp(glp_prob *lp, glp_graph *G, int names, int s,
+* int t, int a_cap);
+*
+* DESCRIPTION
+*
+* The routine glp_maxflow_lp builds an LP problem, which corresponds
+* to the maximum flow problem on the specified network G. */
+
+void glp_maxflow_lp(glp_prob *lp, glp_graph *G, int names, int s,
+ int t, int a_cap)
+{ glp_vertex *v;
+ glp_arc *a;
+ int i, j, type, ind[1+2];
+ double cap, val[1+2];
+ if (!(names == GLP_ON || names == GLP_OFF))
+ xerror("glp_maxflow_lp: names = %d; invalid parameter\n",
+ names);
+ if (!(1 <= s && s <= G->nv))
+ xerror("glp_maxflow_lp: s = %d; source node number out of rang"
+ "e\n", s);
+ if (!(1 <= t && t <= G->nv))
+ xerror("glp_maxflow_lp: t = %d: sink node number out of range "
+ "\n", t);
+ if (s == t)
+ xerror("glp_maxflow_lp: s = t = %d; source and sink nodes must"
+ " be distinct\n", s);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_maxflow_lp: a_cap = %d; invalid offset\n", a_cap);
+ glp_erase_prob(lp);
+ if (names) glp_set_prob_name(lp, G->name);
+ glp_set_obj_dir(lp, GLP_MAX);
+ glp_add_rows(lp, G->nv);
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (names) glp_set_row_name(lp, i, v->name);
+ if (i == s)
+ type = GLP_LO;
+ else if (i == t)
+ type = GLP_UP;
+ else
+ type = GLP_FX;
+ glp_set_row_bnds(lp, i, type, 0.0, 0.0);
+ }
+ if (G->na > 0) glp_add_cols(lp, G->na);
+ for (i = 1, j = 0; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { j++;
+ if (names)
+ { char name[50+1];
+ sprintf(name, "x[%d,%d]", a->tail->i, a->head->i);
+ xassert(strlen(name) < sizeof(name));
+ glp_set_col_name(lp, j, name);
+ }
+ if (a->tail->i != a->head->i)
+ { ind[1] = a->tail->i, val[1] = +1.0;
+ ind[2] = a->head->i, val[2] = -1.0;
+ glp_set_mat_col(lp, j, 2, ind, val);
+ }
+ if (a_cap >= 0)
+ memcpy(&cap, (char *)a->data + a_cap, sizeof(double));
+ else
+ cap = 1.0;
+ if (cap == DBL_MAX)
+ type = GLP_LO;
+ else if (cap != 0.0)
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_col_bnds(lp, j, type, 0.0, cap);
+ if (a->tail->i == s)
+ glp_set_obj_coef(lp, j, +1.0);
+ else if (a->head->i == s)
+ glp_set_obj_coef(lp, j, -1.0);
+ }
+ }
+ xassert(j == G->na);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/mcflp.c b/test/monniaux/glpk-4.65/src/api/mcflp.c
new file mode 100644
index 00000000..5cd24060
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/mcflp.c
@@ -0,0 +1,114 @@
+/* mcflp.c (convert minimum cost flow problem to LP) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_mincost_lp - convert minimum cost flow problem to LP
+*
+* SYNOPSIS
+*
+* void glp_mincost_lp(glp_prob *lp, glp_graph *G, int names,
+* int v_rhs, int a_low, int a_cap, int a_cost);
+*
+* DESCRIPTION
+*
+* The routine glp_mincost_lp builds an LP problem, which corresponds
+* to the minimum cost flow problem on the specified network G. */
+
+void glp_mincost_lp(glp_prob *lp, glp_graph *G, int names, int v_rhs,
+ int a_low, int a_cap, int a_cost)
+{ glp_vertex *v;
+ glp_arc *a;
+ int i, j, type, ind[1+2];
+ double rhs, low, cap, cost, val[1+2];
+ if (!(names == GLP_ON || names == GLP_OFF))
+ xerror("glp_mincost_lp: names = %d; invalid parameter\n",
+ names);
+ if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_mincost_lp: v_rhs = %d; invalid offset\n", v_rhs);
+ if (a_low >= 0 && a_low > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_lp: a_low = %d; invalid offset\n", a_low);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_lp: a_cap = %d; invalid offset\n", a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_lp: a_cost = %d; invalid offset\n", a_cost)
+ ;
+ glp_erase_prob(lp);
+ if (names) glp_set_prob_name(lp, G->name);
+ if (G->nv > 0) glp_add_rows(lp, G->nv);
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (names) glp_set_row_name(lp, i, v->name);
+ if (v_rhs >= 0)
+ memcpy(&rhs, (char *)v->data + v_rhs, sizeof(double));
+ else
+ rhs = 0.0;
+ glp_set_row_bnds(lp, i, GLP_FX, rhs, rhs);
+ }
+ if (G->na > 0) glp_add_cols(lp, G->na);
+ for (i = 1, j = 0; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { j++;
+ if (names)
+ { char name[50+1];
+ sprintf(name, "x[%d,%d]", a->tail->i, a->head->i);
+ xassert(strlen(name) < sizeof(name));
+ glp_set_col_name(lp, j, name);
+ }
+ if (a->tail->i != a->head->i)
+ { ind[1] = a->tail->i, val[1] = +1.0;
+ ind[2] = a->head->i, val[2] = -1.0;
+ glp_set_mat_col(lp, j, 2, ind, val);
+ }
+ if (a_low >= 0)
+ memcpy(&low, (char *)a->data + a_low, sizeof(double));
+ else
+ low = 0.0;
+ if (a_cap >= 0)
+ memcpy(&cap, (char *)a->data + a_cap, sizeof(double));
+ else
+ cap = 1.0;
+ if (cap == DBL_MAX)
+ type = GLP_LO;
+ else if (low != cap)
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_col_bnds(lp, j, type, low, cap);
+ if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 0.0;
+ glp_set_obj_coef(lp, j, cost);
+ }
+ }
+ xassert(j == G->na);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/mcfokalg.c b/test/monniaux/glpk-4.65/src/api/mcfokalg.c
new file mode 100644
index 00000000..786dc71b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/mcfokalg.c
@@ -0,0 +1,221 @@
+/* mcfokalg.c (find minimum-cost flow with out-of-kilter algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "okalg.h"
+
+int glp_mincost_okalg(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, double *sol, int a_x, int v_pi)
+{ /* find minimum-cost flow with out-of-kilter algorithm */
+ glp_vertex *v;
+ glp_arc *a;
+ int nv, na, i, k, s, t, *tail, *head, *low, *cap, *cost, *x, *pi,
+ ret;
+ double sum, temp;
+ if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: v_rhs = %d; invalid offset\n",
+ v_rhs);
+ if (a_low >= 0 && a_low > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: a_low = %d; invalid offset\n",
+ a_low);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: a_cap = %d; invalid offset\n",
+ a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: a_cost = %d; invalid offset\n",
+ a_cost);
+ if (a_x >= 0 && a_x > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: a_x = %d; invalid offset\n", a_x);
+ if (v_pi >= 0 && v_pi > G->v_size - (int)sizeof(double))
+ xerror("glp_mincost_okalg: v_pi = %d; invalid offset\n", v_pi);
+ /* s is artificial source node */
+ s = G->nv + 1;
+ /* t is artificial sink node */
+ t = s + 1;
+ /* nv is the total number of nodes in the resulting network */
+ nv = t;
+ /* na is the total number of arcs in the resulting network */
+ na = G->na + 1;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (v_rhs >= 0)
+ memcpy(&temp, (char *)v->data + v_rhs, sizeof(double));
+ else
+ temp = 0.0;
+ if (temp != 0.0) na++;
+ }
+ /* allocate working arrays */
+ tail = xcalloc(1+na, sizeof(int));
+ head = xcalloc(1+na, sizeof(int));
+ low = xcalloc(1+na, sizeof(int));
+ cap = xcalloc(1+na, sizeof(int));
+ cost = xcalloc(1+na, sizeof(int));
+ x = xcalloc(1+na, sizeof(int));
+ pi = xcalloc(1+nv, sizeof(int));
+ /* construct the resulting network */
+ k = 0;
+ /* (original arcs) */
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ tail[k] = a->tail->i;
+ head[k] = a->head->i;
+ if (tail[k] == head[k])
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ if (a_low >= 0)
+ memcpy(&temp, (char *)a->data + a_low, sizeof(double));
+ else
+ temp = 0.0;
+ if (!(0.0 <= temp && temp <= (double)INT_MAX &&
+ temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ low[k] = (int)temp;
+ if (a_cap >= 0)
+ memcpy(&temp, (char *)a->data + a_cap, sizeof(double));
+ else
+ temp = 1.0;
+ if (!((double)low[k] <= temp && temp <= (double)INT_MAX &&
+ temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ cap[k] = (int)temp;
+ if (a_cost >= 0)
+ memcpy(&temp, (char *)a->data + a_cost, sizeof(double));
+ else
+ temp = 0.0;
+ if (!(fabs(temp) <= (double)INT_MAX && temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ cost[k] = (int)temp;
+ }
+ }
+ /* (artificial arcs) */
+ sum = 0.0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (v_rhs >= 0)
+ memcpy(&temp, (char *)v->data + v_rhs, sizeof(double));
+ else
+ temp = 0.0;
+ if (!(fabs(temp) <= (double)INT_MAX && temp == floor(temp)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ if (temp > 0.0)
+ { /* artificial arc from s to original source i */
+ k++;
+ tail[k] = s;
+ head[k] = i;
+ low[k] = cap[k] = (int)(+temp); /* supply */
+ cost[k] = 0;
+ sum += (double)temp;
+ }
+ else if (temp < 0.0)
+ { /* artificial arc from original sink i to t */
+ k++;
+ tail[k] = i;
+ head[k] = t;
+ low[k] = cap[k] = (int)(-temp); /* demand */
+ cost[k] = 0;
+ }
+ }
+ /* (feedback arc from t to s) */
+ k++;
+ xassert(k == na);
+ tail[k] = t;
+ head[k] = s;
+ if (sum > (double)INT_MAX)
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ low[k] = cap[k] = (int)sum; /* total supply/demand */
+ cost[k] = 0;
+ /* find minimal-cost circulation in the resulting network */
+ ret = okalg(nv, na, tail, head, low, cap, cost, x, pi);
+ switch (ret)
+ { case 0:
+ /* optimal circulation found */
+ ret = 0;
+ break;
+ case 1:
+ /* no feasible circulation exists */
+ ret = GLP_ENOPFS;
+ break;
+ case 2:
+ /* integer overflow occured */
+ ret = GLP_ERANGE;
+ goto done;
+ case 3:
+ /* optimality test failed (logic error) */
+ ret = GLP_EFAIL;
+ goto done;
+ default:
+ xassert(ret != ret);
+ }
+ /* store solution components */
+ /* (objective function = the total cost) */
+ if (sol != NULL)
+ { temp = 0.0;
+ for (k = 1; k <= na; k++)
+ temp += (double)cost[k] * (double)x[k];
+ *sol = temp;
+ }
+ /* (arc flows) */
+ if (a_x >= 0)
+ { k = 0;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { temp = (double)x[++k];
+ memcpy((char *)a->data + a_x, &temp, sizeof(double));
+ }
+ }
+ }
+ /* (node potentials = Lagrange multipliers) */
+ if (v_pi >= 0)
+ { for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ temp = - (double)pi[i];
+ memcpy((char *)v->data + v_pi, &temp, sizeof(double));
+ }
+ }
+done: /* free working arrays */
+ xfree(tail);
+ xfree(head);
+ xfree(low);
+ xfree(cap);
+ xfree(cost);
+ xfree(x);
+ xfree(pi);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/mcfrelax.c b/test/monniaux/glpk-4.65/src/api/mcfrelax.c
new file mode 100644
index 00000000..9b34949a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/mcfrelax.c
@@ -0,0 +1,251 @@
+/* mcfrelax.c (find minimum-cost flow with RELAX-IV) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "relax4.h"
+
+static int overflow(int u, int v)
+{ /* check for integer overflow on computing u + v */
+ if (u > 0 && v > 0 && u + v < 0) return 1;
+ if (u < 0 && v < 0 && u + v > 0) return 1;
+ return 0;
+}
+
+int glp_mincost_relax4(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, int crash, double *sol, int a_x, int a_rc)
+{ /* find minimum-cost flow with Bertsekas-Tseng relaxation method
+ (RELAX-IV) */
+ glp_vertex *v;
+ glp_arc *a;
+ struct relax4_csa csa;
+ int i, k, large, n, na, ret;
+ double cap, cost, low, rc, rhs, sum, x;
+ if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: v_rhs = %d; invalid offset\n",
+ v_rhs);
+ if (a_low >= 0 && a_low > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: a_low = %d; invalid offset\n",
+ a_low);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: a_cap = %d; invalid offset\n",
+ a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: a_cost = %d; invalid offset\n",
+ a_cost);
+ if (a_x >= 0 && a_x > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: a_x = %d; invalid offset\n",
+ a_x);
+ if (a_rc >= 0 && a_rc > G->a_size - (int)sizeof(double))
+ xerror("glp_mincost_relax4: a_rc = %d; invalid offset\n",
+ a_rc);
+ csa.n = n = G->nv; /* number of nodes */
+ csa.na = na = G->na; /* number of arcs */
+ csa.large = large = INT_MAX / 4;
+ csa.repeat = 0;
+ csa.crash = crash;
+ /* allocate working arrays */
+ csa.startn = xcalloc(1+na, sizeof(int));
+ csa.endn = xcalloc(1+na, sizeof(int));
+ csa.fou = xcalloc(1+n, sizeof(int));
+ csa.nxtou = xcalloc(1+na, sizeof(int));
+ csa.fin = xcalloc(1+n, sizeof(int));
+ csa.nxtin = xcalloc(1+na, sizeof(int));
+ csa.rc = xcalloc(1+na, sizeof(int));
+ csa.u = xcalloc(1+na, sizeof(int));
+ csa.dfct = xcalloc(1+n, sizeof(int));
+ csa.x = xcalloc(1+na, sizeof(int));
+ csa.label = xcalloc(1+n, sizeof(int));
+ csa.prdcsr = xcalloc(1+n, sizeof(int));
+ csa.save = xcalloc(1+na, sizeof(int));
+ csa.tfstou = xcalloc(1+n, sizeof(int));
+ csa.tnxtou = xcalloc(1+na, sizeof(int));
+ csa.tfstin = xcalloc(1+n, sizeof(int));
+ csa.tnxtin = xcalloc(1+na, sizeof(int));
+ csa.nxtqueue = xcalloc(1+n, sizeof(int));
+ csa.scan = xcalloc(1+n, sizeof(char));
+ csa.mark = xcalloc(1+n, sizeof(char));
+ if (crash)
+ { csa.extend_arc = xcalloc(1+n, sizeof(int));
+ csa.sb_level = xcalloc(1+n, sizeof(int));
+ csa.sb_arc = xcalloc(1+n, sizeof(int));
+ }
+ else
+ { csa.extend_arc = NULL;
+ csa.sb_level = NULL;
+ csa.sb_arc = NULL;
+ }
+ /* scan nodes */
+ for (i = 1; i <= n; i++)
+ { v = G->v[i];
+ /* get supply at i-th node */
+ if (v_rhs >= 0)
+ memcpy(&rhs, (char *)v->data + v_rhs, sizeof(double));
+ else
+ rhs = 0.0;
+ if (!(fabs(rhs) <= (double)large && rhs == floor(rhs)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ /* set demand at i-th node */
+ csa.dfct[i] = -(int)rhs;
+ }
+ /* scan arcs */
+ k = 0;
+ for (i = 1; i <= n; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ /* set endpoints of k-th arc */
+ if (a->tail->i == a->head->i)
+ { /* self-loops not allowed */
+ ret = GLP_EDATA;
+ goto done;
+ }
+ csa.startn[k] = a->tail->i;
+ csa.endn[k] = a->head->i;
+ /* set per-unit cost for k-th arc flow */
+ if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 0.0;
+ if (!(fabs(cost) <= (double)large && cost == floor(cost)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ csa.rc[k] = (int)cost;
+ /* get lower bound for k-th arc flow */
+ if (a_low >= 0)
+ memcpy(&low, (char *)a->data + a_low, sizeof(double));
+ else
+ low = 0.0;
+ if (!(0.0 <= low && low <= (double)large &&
+ low == floor(low)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ /* get upper bound for k-th arc flow */
+ if (a_cap >= 0)
+ memcpy(&cap, (char *)a->data + a_cap, sizeof(double));
+ else
+ cap = 1.0;
+ if (!(low <= cap && cap <= (double)large &&
+ cap == floor(cap)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ /* substitute x = x' + low, where 0 <= x' <= cap - low */
+ csa.u[k] = (int)(cap - low);
+ /* correct demands at endpoints of k-th arc */
+ if (overflow(csa.dfct[a->tail->i], +low))
+ { ret = GLP_ERANGE;
+ goto done;
+ }
+#if 0 /* 29/IX-2017 */
+ csa.dfct[a->tail->i] += low;
+#else
+ csa.dfct[a->tail->i] += (int)low;
+#endif
+ if (overflow(csa.dfct[a->head->i], -low))
+ { ret = GLP_ERANGE;
+ goto done;
+ }
+#if 0 /* 29/IX-2017 */
+ csa.dfct[a->head->i] -= low;
+#else
+ csa.dfct[a->head->i] -= (int)low;
+#endif
+ }
+ }
+ /* construct linked list for network topology */
+ relax4_inidat(&csa);
+ /* find minimum-cost flow */
+ ret = relax4(&csa);
+ if (ret != 0)
+ { /* problem is found to be infeasible */
+ xassert(1 <= ret && ret <= 8);
+ ret = GLP_ENOPFS;
+ goto done;
+ }
+ /* store solution */
+ sum = 0.0;
+ k = 0;
+ for (i = 1; i <= n; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { k++;
+ /* get lower bound for k-th arc flow */
+ if (a_low >= 0)
+ memcpy(&low, (char *)a->data + a_low, sizeof(double));
+ else
+ low = 0.0;
+ /* store original flow x = x' + low thru k-th arc */
+ x = (double)csa.x[k] + low;
+ if (a_x >= 0)
+ memcpy((char *)a->data + a_x, &x, sizeof(double));
+ /* store reduced cost for k-th arc flow */
+ rc = (double)csa.rc[k];
+ if (a_rc >= 0)
+ memcpy((char *)a->data + a_rc, &rc, sizeof(double));
+ /* get per-unit cost for k-th arc flow */
+ if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 0.0;
+ /* compute the total cost */
+ sum += cost * x;
+ }
+ }
+ /* store the total cost */
+ if (sol != NULL)
+ *sol = sum;
+done: /* free working arrays */
+ xfree(csa.startn);
+ xfree(csa.endn);
+ xfree(csa.fou);
+ xfree(csa.nxtou);
+ xfree(csa.fin);
+ xfree(csa.nxtin);
+ xfree(csa.rc);
+ xfree(csa.u);
+ xfree(csa.dfct);
+ xfree(csa.x);
+ xfree(csa.label);
+ xfree(csa.prdcsr);
+ xfree(csa.save);
+ xfree(csa.tfstou);
+ xfree(csa.tnxtou);
+ xfree(csa.tfstin);
+ xfree(csa.tnxtin);
+ xfree(csa.nxtqueue);
+ xfree(csa.scan);
+ xfree(csa.mark);
+ if (crash)
+ { xfree(csa.extend_arc);
+ xfree(csa.sb_level);
+ xfree(csa.sb_arc);
+ }
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/minisat1.c b/test/monniaux/glpk-4.65/src/api/minisat1.c
new file mode 100644
index 00000000..a669c487
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/minisat1.c
@@ -0,0 +1,161 @@
+/* minisat1.c (driver to MiniSat solver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2011-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "minisat.h"
+#include "prob.h"
+
+int glp_minisat1(glp_prob *P)
+{ /* solve CNF-SAT problem with MiniSat solver */
+ solver *s;
+ GLPAIJ *aij;
+ int i, j, len, ret, *ind;
+ double sum;
+#if 0 /* 04/IV-2016 */
+ /* check problem object */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_minisat1: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (P->tree != NULL)
+ xerror("glp_minisat1: operation not allowed\n");
+ /* integer solution is currently undefined */
+ P->mip_stat = GLP_UNDEF;
+ P->mip_obj = 0.0;
+ /* check that problem object encodes CNF-SAT instance */
+ if (glp_check_cnfsat(P) != 0)
+ { xprintf("glp_minisat1: problem object does not encode CNF-SAT "
+ "instance\n");
+ ret = GLP_EDATA;
+ goto done;
+ }
+#if 0 /* 08/I-2017 by cmatraki */
+#if 1 /* 07/XI-2015 */
+ if (sizeof(void *) != sizeof(int))
+ { xprintf("glp_minisat1: sorry, MiniSat solver is not supported "
+ "on 64-bit platforms\n");
+ ret = GLP_EFAIL;
+ goto done;
+ }
+#endif
+#else
+ if (sizeof(void *) != sizeof(size_t))
+ { xprintf("glp_minisat1: sorry, MiniSat solver is not supported "
+ "on this platform\n");
+ ret = GLP_EFAIL;
+ goto done;
+ }
+#endif
+ /* solve CNF-SAT problem */
+ xprintf("Solving CNF-SAT problem...\n");
+ xprintf("Instance has %d variable%s, %d clause%s, and %d literal%"
+ "s\n", P->n, P->n == 1 ? "" : "s", P->m, P->m == 1 ? "" : "s",
+ P->nnz, P->nnz == 1 ? "" : "s");
+ /* if CNF-SAT has no clauses, it is satisfiable */
+ if (P->m == 0)
+ { P->mip_stat = GLP_OPT;
+ for (j = 1; j <= P->n; j++)
+ P->col[j]->mipx = 0.0;
+ goto fini;
+ }
+ /* if CNF-SAT has an empty clause, it is unsatisfiable */
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->ptr == NULL)
+ { P->mip_stat = GLP_NOFEAS;
+ goto fini;
+ }
+ }
+ /* prepare input data for the solver */
+ s = solver_new();
+ solver_setnvars(s, P->n);
+ ind = xcalloc(1+P->n, sizeof(int));
+ for (i = 1; i <= P->m; i++)
+ { len = 0;
+ for (aij = P->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { ind[++len] = toLit(aij->col->j-1);
+ if (aij->val < 0.0)
+ ind[len] = lit_neg(ind[len]);
+ }
+ xassert(len > 0);
+#if 0 /* 08/I-2017 by cmatraki */
+ xassert(solver_addclause(s, &ind[1], &ind[1+len]));
+#else
+ if (!solver_addclause(s, &ind[1], &ind[1+len]))
+ { /* found trivial conflict */
+ xfree(ind);
+ solver_delete(s);
+ P->mip_stat = GLP_NOFEAS;
+ goto fini;
+ }
+#endif
+ }
+ xfree(ind);
+ /* call the solver */
+ s->verbosity = 1;
+ if (solver_solve(s, 0, 0))
+ { /* instance is reported as satisfiable */
+ P->mip_stat = GLP_OPT;
+ /* copy solution to the problem object */
+ xassert(s->model.size == P->n);
+ for (j = 1; j <= P->n; j++)
+ { P->col[j]->mipx =
+ s->model.ptr[j-1] == l_True ? 1.0 : 0.0;
+ }
+ /* compute row values */
+ for (i = 1; i <= P->m; i++)
+ { sum = 0;
+ for (aij = P->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ sum += aij->val * aij->col->mipx;
+ P->row[i]->mipx = sum;
+ }
+ /* check integer feasibility */
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->mipx < P->row[i]->lb)
+ { /* solution is wrong */
+ P->mip_stat = GLP_UNDEF;
+ break;
+ }
+ }
+ }
+ else
+ { /* instance is reported as unsatisfiable */
+ P->mip_stat = GLP_NOFEAS;
+ }
+ solver_delete(s);
+fini: /* report the instance status */
+ if (P->mip_stat == GLP_OPT)
+ { xprintf("SATISFIABLE\n");
+ ret = 0;
+ }
+ else if (P->mip_stat == GLP_NOFEAS)
+ { xprintf("UNSATISFIABLE\n");
+ ret = 0;
+ }
+ else
+ { xprintf("glp_minisat1: solver failed\n");
+ ret = GLP_EFAIL;
+ }
+done: return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/mpl.c b/test/monniaux/glpk-4.65/src/api/mpl.c
new file mode 100644
index 00000000..cfa6f75b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/mpl.c
@@ -0,0 +1,269 @@
+/* mpl.c (processing model in GNU MathProg language) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+#include "prob.h"
+
+glp_tran *glp_mpl_alloc_wksp(void)
+{ /* allocate the MathProg translator workspace */
+ glp_tran *tran;
+ tran = mpl_initialize();
+ return tran;
+}
+
+void glp_mpl_init_rand(glp_tran *tran, int seed)
+{ /* initialize pseudo-random number generator */
+ if (tran->phase != 0)
+ xerror("glp_mpl_init_rand: invalid call sequence\n");
+ rng_init_rand(tran->rand, seed);
+ return;
+}
+
+int glp_mpl_read_model(glp_tran *tran, const char *fname, int skip)
+{ /* read and translate model section */
+ int ret;
+ if (tran->phase != 0)
+ xerror("glp_mpl_read_model: invalid call sequence\n");
+ ret = mpl_read_model(tran, (char *)fname, skip);
+ if (ret == 1 || ret == 2)
+ ret = 0;
+ else if (ret == 4)
+ ret = 1;
+ else
+ xassert(ret != ret);
+ return ret;
+}
+
+int glp_mpl_read_data(glp_tran *tran, const char *fname)
+{ /* read and translate data section */
+ int ret;
+ if (!(tran->phase == 1 || tran->phase == 2))
+ xerror("glp_mpl_read_data: invalid call sequence\n");
+ ret = mpl_read_data(tran, (char *)fname);
+ if (ret == 2)
+ ret = 0;
+ else if (ret == 4)
+ ret = 1;
+ else
+ xassert(ret != ret);
+ return ret;
+}
+
+int glp_mpl_generate(glp_tran *tran, const char *fname)
+{ /* generate the model */
+ int ret;
+ if (!(tran->phase == 1 || tran->phase == 2))
+ xerror("glp_mpl_generate: invalid call sequence\n");
+ ret = mpl_generate(tran, (char *)fname);
+ if (ret == 3)
+ ret = 0;
+ else if (ret == 4)
+ ret = 1;
+ return ret;
+}
+
+void glp_mpl_build_prob(glp_tran *tran, glp_prob *prob)
+{ /* build LP/MIP problem instance from the model */
+ int m, n, i, j, t, kind, type, len, *ind;
+ double lb, ub, *val;
+ if (tran->phase != 3)
+ xerror("glp_mpl_build_prob: invalid call sequence\n");
+ /* erase the problem object */
+ glp_erase_prob(prob);
+ /* set problem name */
+ glp_set_prob_name(prob, mpl_get_prob_name(tran));
+ /* build rows (constraints) */
+ m = mpl_get_num_rows(tran);
+ if (m > 0)
+ glp_add_rows(prob, m);
+ for (i = 1; i <= m; i++)
+ { /* set row name */
+ glp_set_row_name(prob, i, mpl_get_row_name(tran, i));
+ /* set row bounds */
+ type = mpl_get_row_bnds(tran, i, &lb, &ub);
+ switch (type)
+ { case MPL_FR: type = GLP_FR; break;
+ case MPL_LO: type = GLP_LO; break;
+ case MPL_UP: type = GLP_UP; break;
+ case MPL_DB: type = GLP_DB; break;
+ case MPL_FX: type = GLP_FX; break;
+ default: xassert(type != type);
+ }
+ if (type == GLP_DB && fabs(lb - ub) < 1e-9 * (1.0 + fabs(lb)))
+ { type = GLP_FX;
+ if (fabs(lb) <= fabs(ub)) ub = lb; else lb = ub;
+ }
+ glp_set_row_bnds(prob, i, type, lb, ub);
+ /* warn about non-zero constant term */
+ if (mpl_get_row_c0(tran, i) != 0.0)
+ xprintf("glp_mpl_build_prob: row %s; constant term %.12g ig"
+ "nored\n",
+ mpl_get_row_name(tran, i), mpl_get_row_c0(tran, i));
+ }
+ /* build columns (variables) */
+ n = mpl_get_num_cols(tran);
+ if (n > 0)
+ glp_add_cols(prob, n);
+ for (j = 1; j <= n; j++)
+ { /* set column name */
+ glp_set_col_name(prob, j, mpl_get_col_name(tran, j));
+ /* set column kind */
+ kind = mpl_get_col_kind(tran, j);
+ switch (kind)
+ { case MPL_NUM:
+ break;
+ case MPL_INT:
+ case MPL_BIN:
+ glp_set_col_kind(prob, j, GLP_IV);
+ break;
+ default:
+ xassert(kind != kind);
+ }
+ /* set column bounds */
+ type = mpl_get_col_bnds(tran, j, &lb, &ub);
+ switch (type)
+ { case MPL_FR: type = GLP_FR; break;
+ case MPL_LO: type = GLP_LO; break;
+ case MPL_UP: type = GLP_UP; break;
+ case MPL_DB: type = GLP_DB; break;
+ case MPL_FX: type = GLP_FX; break;
+ default: xassert(type != type);
+ }
+ if (kind == MPL_BIN)
+ { if (type == GLP_FR || type == GLP_UP || lb < 0.0) lb = 0.0;
+ if (type == GLP_FR || type == GLP_LO || ub > 1.0) ub = 1.0;
+ type = GLP_DB;
+ }
+ if (type == GLP_DB && fabs(lb - ub) < 1e-9 * (1.0 + fabs(lb)))
+ { type = GLP_FX;
+ if (fabs(lb) <= fabs(ub)) ub = lb; else lb = ub;
+ }
+ glp_set_col_bnds(prob, j, type, lb, ub);
+ }
+ /* load the constraint matrix */
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ for (i = 1; i <= m; i++)
+ { len = mpl_get_mat_row(tran, i, ind, val);
+ glp_set_mat_row(prob, i, len, ind, val);
+ }
+ /* build objective function (the first objective is used) */
+ for (i = 1; i <= m; i++)
+ { kind = mpl_get_row_kind(tran, i);
+ if (kind == MPL_MIN || kind == MPL_MAX)
+ { /* set objective name */
+ glp_set_obj_name(prob, mpl_get_row_name(tran, i));
+ /* set optimization direction */
+ glp_set_obj_dir(prob, kind == MPL_MIN ? GLP_MIN : GLP_MAX);
+ /* set constant term */
+ glp_set_obj_coef(prob, 0, mpl_get_row_c0(tran, i));
+ /* set objective coefficients */
+ len = mpl_get_mat_row(tran, i, ind, val);
+ for (t = 1; t <= len; t++)
+ glp_set_obj_coef(prob, ind[t], val[t]);
+ break;
+ }
+ }
+ /* free working arrays */
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+int glp_mpl_postsolve(glp_tran *tran, glp_prob *prob, int sol)
+{ /* postsolve the model */
+ int i, j, m, n, stat, ret;
+ double prim, dual;
+ if (!(tran->phase == 3 && !tran->flag_p))
+ xerror("glp_mpl_postsolve: invalid call sequence\n");
+ if (!(sol == GLP_SOL || sol == GLP_IPT || sol == GLP_MIP))
+ xerror("glp_mpl_postsolve: sol = %d; invalid parameter\n",
+ sol);
+ m = mpl_get_num_rows(tran);
+ n = mpl_get_num_cols(tran);
+ if (!(m == glp_get_num_rows(prob) &&
+ n == glp_get_num_cols(prob)))
+ xerror("glp_mpl_postsolve: wrong problem object\n");
+ if (!mpl_has_solve_stmt(tran))
+ { ret = 0;
+ goto done;
+ }
+ for (i = 1; i <= m; i++)
+ { if (sol == GLP_SOL)
+ { stat = glp_get_row_stat(prob, i);
+ prim = glp_get_row_prim(prob, i);
+ dual = glp_get_row_dual(prob, i);
+ }
+ else if (sol == GLP_IPT)
+ { stat = 0;
+ prim = glp_ipt_row_prim(prob, i);
+ dual = glp_ipt_row_dual(prob, i);
+ }
+ else if (sol == GLP_MIP)
+ { stat = 0;
+ prim = glp_mip_row_val(prob, i);
+ dual = 0.0;
+ }
+ else
+ xassert(sol != sol);
+ if (fabs(prim) < 1e-9) prim = 0.0;
+ if (fabs(dual) < 1e-9) dual = 0.0;
+ mpl_put_row_soln(tran, i, stat, prim, dual);
+ }
+ for (j = 1; j <= n; j++)
+ { if (sol == GLP_SOL)
+ { stat = glp_get_col_stat(prob, j);
+ prim = glp_get_col_prim(prob, j);
+ dual = glp_get_col_dual(prob, j);
+ }
+ else if (sol == GLP_IPT)
+ { stat = 0;
+ prim = glp_ipt_col_prim(prob, j);
+ dual = glp_ipt_col_dual(prob, j);
+ }
+ else if (sol == GLP_MIP)
+ { stat = 0;
+ prim = glp_mip_col_val(prob, j);
+ dual = 0.0;
+ }
+ else
+ xassert(sol != sol);
+ if (fabs(prim) < 1e-9) prim = 0.0;
+ if (fabs(dual) < 1e-9) dual = 0.0;
+ mpl_put_col_soln(tran, j, stat, prim, dual);
+ }
+ ret = mpl_postsolve(tran);
+ if (ret == 3)
+ ret = 0;
+ else if (ret == 4)
+ ret = 1;
+done: return ret;
+}
+
+void glp_mpl_free_wksp(glp_tran *tran)
+{ /* free the MathProg translator workspace */
+ mpl_terminate(tran);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/mps.c b/test/monniaux/glpk-4.65/src/api/mps.c
new file mode 100644
index 00000000..3bdc6db1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/mps.c
@@ -0,0 +1,1452 @@
+/* mps.c (MPS format routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_init_mpscp - initialize MPS format control parameters
+*
+* SYNOPSIS
+*
+* void glp_init_mpscp(glp_mpscp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_init_mpscp initializes control parameters, which are
+* used by the MPS input/output routines glp_read_mps and glp_write_mps,
+* with default values.
+*
+* Default values of the control parameters are stored in the glp_mpscp
+* structure, which the parameter parm points to. */
+
+void glp_init_mpscp(glp_mpscp *parm)
+{ parm->blank = '\0';
+ parm->obj_name = NULL;
+ parm->tol_mps = 1e-12;
+ return;
+}
+
+static void check_parm(const char *func, const glp_mpscp *parm)
+{ /* check control parameters */
+ if (!(0x00 <= parm->blank && parm->blank <= 0xFF) ||
+ !(parm->blank == '\0' || isprint(parm->blank)))
+ xerror("%s: blank = 0x%02X; invalid parameter\n",
+ func, parm->blank);
+ if (!(parm->obj_name == NULL || strlen(parm->obj_name) <= 255))
+ xerror("%s: obj_name = \"%.12s...\"; parameter too long\n",
+ func, parm->obj_name);
+ if (!(0.0 <= parm->tol_mps && parm->tol_mps < 1.0))
+ xerror("%s: tol_mps = %g; invalid parameter\n",
+ func, parm->tol_mps);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_read_mps - read problem data in MPS format
+*
+* SYNOPSIS
+*
+* int glp_read_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_mps reads problem data in MPS format from a
+* text file.
+*
+* The parameter fmt specifies the version of MPS format:
+*
+* GLP_MPS_DECK - fixed (ancient) MPS format;
+* GLP_MPS_FILE - free (modern) MPS format.
+*
+* The parameter parm is a pointer to the structure glp_mpscp, which
+* specifies control parameters used by the routine. If parm is NULL,
+* the routine uses default settings.
+*
+* The character string fname specifies a name of the text file to be
+* read.
+*
+* Note that before reading data the current content of the problem
+* object is completely erased with the routine glp_erase_prob.
+*
+* RETURNS
+*
+* If the operation was successful, the routine glp_read_mps returns
+* zero. Otherwise, it prints an error message and returns non-zero. */
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* pointer to problem object */
+ int deck;
+ /* MPS format (0 - free, 1 - fixed) */
+ const glp_mpscp *parm;
+ /* pointer to control parameters */
+ const char *fname;
+ /* name of input MPS file */
+ glp_file *fp;
+ /* stream assigned to input MPS file */
+ jmp_buf jump;
+ /* label for go to in case of error */
+ int recno;
+ /* current record (card) number */
+ int recpos;
+ /* current record (card) position */
+ int c;
+ /* current character */
+ int fldno;
+ /* current field number */
+ char field[255+1];
+ /* current field content */
+ int w80;
+ /* warning 'record must not be longer than 80 chars' issued */
+ int wef;
+ /* warning 'extra fields detected beyond field 6' issued */
+ int obj_row;
+ /* objective row number */
+ void *work1, *work2, *work3;
+ /* working arrays */
+};
+
+static void error(struct csa *csa, const char *fmt, ...)
+{ /* print error message and terminate processing */
+ va_list arg;
+ xprintf("%s:%d: ", csa->fname, csa->recno);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ longjmp(csa->jump, 1);
+ /* no return */
+}
+
+static void warning(struct csa *csa, const char *fmt, ...)
+{ /* print warning message and continue processing */
+ va_list arg;
+ xprintf("%s:%d: warning: ", csa->fname, csa->recno);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ return;
+}
+
+static void read_char(struct csa *csa)
+{ /* read next character */
+ int c;
+ if (csa->c == '\n')
+ csa->recno++, csa->recpos = 0;
+ csa->recpos++;
+read: c = glp_getc(csa->fp);
+ if (c < 0)
+ { if (glp_ioerr(csa->fp))
+ error(csa, "read error - %s\n", get_err_msg());
+ else if (csa->c == '\n')
+ error(csa, "unexpected end of file\n");
+ else
+ { warning(csa, "missing final end of line\n");
+ c = '\n';
+ }
+ }
+ else if (c == '\n')
+ ;
+ else if (csa->c == '\r')
+ { c = '\r';
+ goto badc;
+ }
+ else if (csa->deck && c == '\r')
+ { csa->c = '\r';
+ goto read;
+ }
+ else if (c == ' ')
+ ;
+ else if (isspace(c))
+ { if (csa->deck)
+badc: error(csa, "in fixed MPS format white-space character 0x%02"
+ "X is not allowed\n", c);
+ c = ' ';
+ }
+ else if (iscntrl(c))
+ error(csa, "invalid control character 0x%02X\n", c);
+ if (csa->deck && csa->recpos == 81 && c != '\n' && csa->w80 < 1)
+ { warning(csa, "in fixed MPS format record must not be longer th"
+ "an 80 characters\n");
+ csa->w80++;
+ }
+ csa->c = c;
+ return;
+}
+
+static int indicator(struct csa *csa, int name)
+{ /* skip comment records and read possible indicator record */
+ int ret;
+ /* reset current field number */
+ csa->fldno = 0;
+loop: /* read the very first character of the next record */
+ xassert(csa->c == '\n');
+ read_char(csa);
+ if (csa->c == ' ' || csa->c == '\n')
+ { /* data record */
+ ret = 0;
+ }
+ else if (csa->c == '*')
+ { /* comment record */
+ while (csa->c != '\n')
+ read_char(csa);
+ goto loop;
+ }
+ else
+ { /* indicator record */
+ int len = 0;
+ while (csa->c != ' ' && csa->c != '\n' && len < 12)
+ { csa->field[len++] = (char)csa->c;
+ read_char(csa);
+ }
+ csa->field[len] = '\0';
+ if (!(strcmp(csa->field, "NAME") == 0 ||
+ strcmp(csa->field, "ROWS") == 0 ||
+ strcmp(csa->field, "COLUMNS") == 0 ||
+ strcmp(csa->field, "RHS") == 0 ||
+ strcmp(csa->field, "RANGES") == 0 ||
+ strcmp(csa->field, "BOUNDS") == 0 ||
+ strcmp(csa->field, "ENDATA") == 0))
+ error(csa, "invalid indicator record\n");
+ if (!name)
+ { while (csa->c != '\n')
+ read_char(csa);
+ }
+ ret = 1;
+ }
+ return ret;
+}
+
+static void read_field(struct csa *csa)
+{ /* read next field of the current data record */
+ csa->fldno++;
+ if (csa->deck)
+ { /* fixed MPS format */
+ int beg, end, pos;
+ /* determine predefined field positions */
+ if (csa->fldno == 1)
+ beg = 2, end = 3;
+ else if (csa->fldno == 2)
+ beg = 5, end = 12;
+ else if (csa->fldno == 3)
+ beg = 15, end = 22;
+ else if (csa->fldno == 4)
+ beg = 25, end = 36;
+ else if (csa->fldno == 5)
+ beg = 40, end = 47;
+ else if (csa->fldno == 6)
+ beg = 50, end = 61;
+ else
+ xassert(csa != csa);
+ /* skip blanks preceding the current field */
+ if (csa->c != '\n')
+ { pos = csa->recpos;
+ while (csa->recpos < beg)
+ { if (csa->c == ' ')
+ ;
+ else if (csa->c == '\n')
+ break;
+ else
+ error(csa, "in fixed MPS format positions %d-%d must "
+ "be blank\n", pos, beg-1);
+ read_char(csa);
+ }
+ }
+ /* skip possible comment beginning in the field 3 or 5 */
+ if ((csa->fldno == 3 || csa->fldno == 5) && csa->c == '$')
+ { while (csa->c != '\n')
+ read_char(csa);
+ }
+ /* read the current field */
+ for (pos = beg; pos <= end; pos++)
+ { if (csa->c == '\n') break;
+ csa->field[pos-beg] = (char)csa->c;
+ read_char(csa);
+ }
+ csa->field[pos-beg] = '\0';
+ strtrim(csa->field);
+ /* skip blanks following the last field */
+ if (csa->fldno == 6 && csa->c != '\n')
+ { while (csa->recpos <= 72)
+ { if (csa->c == ' ')
+ ;
+ else if (csa->c == '\n')
+ break;
+ else
+ error(csa, "in fixed MPS format positions 62-72 must "
+ "be blank\n");
+ read_char(csa);
+ }
+ while (csa->c != '\n')
+ read_char(csa);
+ }
+ }
+ else
+ { /* free MPS format */
+ int len;
+ /* skip blanks preceding the current field */
+ while (csa->c == ' ')
+ read_char(csa);
+ /* skip possible comment */
+ if (csa->c == '$')
+ { while (csa->c != '\n')
+ read_char(csa);
+ }
+ /* read the current field */
+ len = 0;
+ while (!(csa->c == ' ' || csa->c == '\n'))
+ { if (len == 255)
+ error(csa, "length of field %d exceeds 255 characters\n",
+ csa->fldno++);
+ csa->field[len++] = (char)csa->c;
+ read_char(csa);
+ }
+ csa->field[len] = '\0';
+ /* skip anything following the last field (any extra fields
+ are considered to be comments) */
+ if (csa->fldno == 6)
+ { while (csa->c == ' ')
+ read_char(csa);
+ if (csa->c != '$' && csa->c != '\n' && csa->wef < 1)
+ { warning(csa, "some extra field(s) detected beyond field "
+ "6; field(s) ignored\n");
+ csa->wef++;
+ }
+ while (csa->c != '\n')
+ read_char(csa);
+ }
+ }
+ return;
+}
+
+static void patch_name(struct csa *csa, char *name)
+{ /* process embedded blanks in symbolic name */
+ int blank = csa->parm->blank;
+ if (blank == '\0')
+ { /* remove emedded blanks */
+ strspx(name);
+ }
+ else
+ { /* replace embedded blanks by specified character */
+ for (; *name != '\0'; name++)
+ if (*name == ' ') *name = (char)blank;
+ }
+ return;
+}
+
+static double read_number(struct csa *csa)
+{ /* read next field and convert it to floating-point number */
+ double x;
+ char *s;
+ /* read next field */
+ read_field(csa);
+ xassert(csa->fldno == 4 || csa->fldno == 6);
+ if (csa->field[0] == '\0')
+ error(csa, "missing numeric value in field %d\n", csa->fldno);
+ /* skip initial spaces of the field */
+ for (s = csa->field; *s == ' '; s++);
+ /* perform conversion */
+ if (str2num(s, &x) != 0)
+ error(csa, "cannot convert '%s' to floating-point number\n",
+ s);
+ return x;
+}
+
+static void skip_field(struct csa *csa)
+{ /* read and skip next field (assumed to be blank) */
+ read_field(csa);
+ if (csa->field[0] != '\0')
+ error(csa, "field %d must be blank\n", csa->fldno);
+ return;
+}
+
+static void read_name(struct csa *csa)
+{ /* read NAME indicator record */
+ if (!(indicator(csa, 1) && strcmp(csa->field, "NAME") == 0))
+ error(csa, "missing NAME indicator record\n");
+ /* this indicator record looks like a data record; simulate that
+ fields 1 and 2 were read */
+ csa->fldno = 2;
+ /* field 3: model name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ warning(csa, "missing model name in field 3\n");
+ else
+ glp_set_prob_name(csa->P, csa->field);
+ /* skip anything following field 3 */
+ while (csa->c != '\n')
+ read_char(csa);
+ return;
+}
+
+static void read_rows(struct csa *csa)
+{ /* read ROWS section */
+ int i, type;
+loop: if (indicator(csa, 0)) goto done;
+ /* field 1: row type */
+ read_field(csa), strspx(csa->field);
+ if (strcmp(csa->field, "N") == 0)
+ type = GLP_FR;
+ else if (strcmp(csa->field, "G") == 0)
+ type = GLP_LO;
+ else if (strcmp(csa->field, "L") == 0)
+ type = GLP_UP;
+ else if (strcmp(csa->field, "E") == 0)
+ type = GLP_FX;
+ else if (csa->field[0] == '\0')
+ error(csa, "missing row type in field 1\n");
+ else
+ error(csa, "invalid row type in field 1\n");
+ /* field 2: row name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ error(csa, "missing row name in field 2\n");
+ if (glp_find_row(csa->P, csa->field) != 0)
+ error(csa, "row '%s' multiply specified\n", csa->field);
+ i = glp_add_rows(csa->P, 1);
+ glp_set_row_name(csa->P, i, csa->field);
+ glp_set_row_bnds(csa->P, i, type, 0.0, 0.0);
+ /* fields 3, 4, 5, and 6 must be blank */
+ skip_field(csa);
+ skip_field(csa);
+ skip_field(csa);
+ skip_field(csa);
+ goto loop;
+done: return;
+}
+
+static void read_columns(struct csa *csa)
+{ /* read COLUMNS section */
+ int i, j, f, len, kind = GLP_CV, *ind;
+ double aij, *val;
+ char name[255+1], *flag;
+ /* allocate working arrays */
+ csa->work1 = ind = xcalloc(1+csa->P->m, sizeof(int));
+ csa->work2 = val = xcalloc(1+csa->P->m, sizeof(double));
+ csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
+ memset(&flag[1], 0, csa->P->m);
+ /* no current column exists */
+ j = 0, len = 0;
+loop: if (indicator(csa, 0)) goto done;
+ /* field 1 must be blank */
+ if (csa->deck)
+ { read_field(csa);
+ if (csa->field[0] != '\0')
+ error(csa, "field 1 must be blank\n");
+ }
+ else
+ csa->fldno++;
+ /* field 2: column or kind name */
+ read_field(csa), patch_name(csa, csa->field);
+ strcpy(name, csa->field);
+ /* field 3: row name or keyword 'MARKER' */
+ read_field(csa), patch_name(csa, csa->field);
+ if (strcmp(csa->field, "'MARKER'") == 0)
+ { /* process kind data record */
+ /* field 4 must be blank */
+ if (csa->deck)
+ { read_field(csa);
+ if (csa->field[0] != '\0')
+ error(csa, "field 4 must be blank\n");
+ }
+ else
+ csa->fldno++;
+ /* field 5: keyword 'INTORG' or 'INTEND' */
+ read_field(csa), patch_name(csa, csa->field);
+ if (strcmp(csa->field, "'INTORG'") == 0)
+ kind = GLP_IV;
+ else if (strcmp(csa->field, "'INTEND'") == 0)
+ kind = GLP_CV;
+ else if (csa->field[0] == '\0')
+ error(csa, "missing keyword in field 5\n");
+ else
+ error(csa, "invalid keyword in field 5\n");
+ /* field 6 must be blank */
+ skip_field(csa);
+ goto loop;
+ }
+ /* process column name specified in field 2 */
+ if (name[0] == '\0')
+ { /* the same column as in previous data record */
+ if (j == 0)
+ error(csa, "missing column name in field 2\n");
+ }
+ else if (j != 0 && strcmp(name, csa->P->col[j]->name) == 0)
+ { /* the same column as in previous data record */
+ xassert(j != 0);
+ }
+ else
+ { /* store the current column */
+ if (j != 0)
+ { glp_set_mat_col(csa->P, j, len, ind, val);
+ while (len > 0) flag[ind[len--]] = 0;
+ }
+ /* create new column */
+ if (glp_find_col(csa->P, name) != 0)
+ error(csa, "column '%s' multiply specified\n", name);
+ j = glp_add_cols(csa->P, 1);
+ glp_set_col_name(csa->P, j, name);
+ glp_set_col_kind(csa->P, j, kind);
+ if (kind == GLP_CV)
+ glp_set_col_bnds(csa->P, j, GLP_LO, 0.0, 0.0);
+ else if (kind == GLP_IV)
+ glp_set_col_bnds(csa->P, j, GLP_DB, 0.0, 1.0);
+ else
+ xassert(kind != kind);
+ }
+ /* process fields 3-4 and 5-6 */
+ for (f = 3; f <= 5; f += 2)
+ { /* field 3 or 5: row name */
+ if (f == 3)
+ { if (csa->field[0] == '\0')
+ error(csa, "missing row name in field 3\n");
+ }
+ else
+ { read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { /* if field 5 is blank, field 6 also must be blank */
+ skip_field(csa);
+ continue;
+ }
+ }
+ i = glp_find_row(csa->P, csa->field);
+ if (i == 0)
+ error(csa, "row '%s' not found\n", csa->field);
+ if (flag[i])
+ error(csa, "duplicate coefficient in row '%s'\n",
+ csa->field);
+ /* field 4 or 6: coefficient value */
+ aij = read_number(csa);
+ if (fabs(aij) < csa->parm->tol_mps) aij = 0.0;
+ len++, ind[len] = i, val[len] = aij, flag[i] = 1;
+ }
+ goto loop;
+done: /* store the last column */
+ if (j != 0)
+ glp_set_mat_col(csa->P, j, len, ind, val);
+ /* free working arrays */
+ xfree(ind);
+ xfree(val);
+ xfree(flag);
+ csa->work1 = csa->work2 = csa->work3 = NULL;
+ return;
+}
+
+static void read_rhs(struct csa *csa)
+{ /* read RHS section */
+ int i, f, v, type;
+ double rhs;
+ char name[255+1], *flag;
+ /* allocate working array */
+ csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
+ memset(&flag[1], 0, csa->P->m);
+ /* no current RHS vector exists */
+ v = 0;
+loop: if (indicator(csa, 0)) goto done;
+ /* field 1 must be blank */
+ if (csa->deck)
+ { read_field(csa);
+ if (csa->field[0] != '\0')
+ error(csa, "field 1 must be blank\n");
+ }
+ else
+ csa->fldno++;
+ /* field 2: RHS vector name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { /* the same RHS vector as in previous data record */
+ if (v == 0)
+ { warning(csa, "missing RHS vector name in field 2\n");
+ goto blnk;
+ }
+ }
+ else if (v != 0 && strcmp(csa->field, name) == 0)
+ { /* the same RHS vector as in previous data record */
+ xassert(v != 0);
+ }
+ else
+blnk: { /* new RHS vector */
+ if (v != 0)
+ error(csa, "multiple RHS vectors not supported\n");
+ v++;
+ strcpy(name, csa->field);
+ }
+ /* process fields 3-4 and 5-6 */
+ for (f = 3; f <= 5; f += 2)
+ { /* field 3 or 5: row name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { if (f == 3)
+ error(csa, "missing row name in field 3\n");
+ else
+ { /* if field 5 is blank, field 6 also must be blank */
+ skip_field(csa);
+ continue;
+ }
+ }
+ i = glp_find_row(csa->P, csa->field);
+ if (i == 0)
+ error(csa, "row '%s' not found\n", csa->field);
+ if (flag[i])
+ error(csa, "duplicate right-hand side for row '%s'\n",
+ csa->field);
+ /* field 4 or 6: right-hand side value */
+ rhs = read_number(csa);
+ if (fabs(rhs) < csa->parm->tol_mps) rhs = 0.0;
+ type = csa->P->row[i]->type;
+ if (type == GLP_FR)
+ { if (i == csa->obj_row)
+ glp_set_obj_coef(csa->P, 0, rhs);
+ else if (rhs != 0.0)
+ warning(csa, "non-zero right-hand side for free row '%s'"
+ " ignored\n", csa->P->row[i]->name);
+ }
+ else
+ glp_set_row_bnds(csa->P, i, type, rhs, rhs);
+ flag[i] = 1;
+ }
+ goto loop;
+done: /* free working array */
+ xfree(flag);
+ csa->work3 = NULL;
+ return;
+}
+
+static void read_ranges(struct csa *csa)
+{ /* read RANGES section */
+ int i, f, v, type;
+ double rhs, rng;
+ char name[255+1], *flag;
+ /* allocate working array */
+ csa->work3 = flag = xcalloc(1+csa->P->m, sizeof(char));
+ memset(&flag[1], 0, csa->P->m);
+ /* no current RANGES vector exists */
+ v = 0;
+loop: if (indicator(csa, 0)) goto done;
+ /* field 1 must be blank */
+ if (csa->deck)
+ { read_field(csa);
+ if (csa->field[0] != '\0')
+ error(csa, "field 1 must be blank\n");
+ }
+ else
+ csa->fldno++;
+ /* field 2: RANGES vector name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { /* the same RANGES vector as in previous data record */
+ if (v == 0)
+ { warning(csa, "missing RANGES vector name in field 2\n");
+ goto blnk;
+ }
+ }
+ else if (v != 0 && strcmp(csa->field, name) == 0)
+ { /* the same RANGES vector as in previous data record */
+ xassert(v != 0);
+ }
+ else
+blnk: { /* new RANGES vector */
+ if (v != 0)
+ error(csa, "multiple RANGES vectors not supported\n");
+ v++;
+ strcpy(name, csa->field);
+ }
+ /* process fields 3-4 and 5-6 */
+ for (f = 3; f <= 5; f += 2)
+ { /* field 3 or 5: row name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { if (f == 3)
+ error(csa, "missing row name in field 3\n");
+ else
+ { /* if field 5 is blank, field 6 also must be blank */
+ skip_field(csa);
+ continue;
+ }
+ }
+ i = glp_find_row(csa->P, csa->field);
+ if (i == 0)
+ error(csa, "row '%s' not found\n", csa->field);
+ if (flag[i])
+ error(csa, "duplicate range for row '%s'\n", csa->field);
+ /* field 4 or 6: range value */
+ rng = read_number(csa);
+ if (fabs(rng) < csa->parm->tol_mps) rng = 0.0;
+ type = csa->P->row[i]->type;
+ if (type == GLP_FR)
+ warning(csa, "range for free row '%s' ignored\n",
+ csa->P->row[i]->name);
+ else if (type == GLP_LO)
+ { rhs = csa->P->row[i]->lb;
+#if 0 /* 26/V-2017 by cmatraki */
+ glp_set_row_bnds(csa->P, i, rhs == 0.0 ? GLP_FX : GLP_DB,
+#else
+ glp_set_row_bnds(csa->P, i, rng == 0.0 ? GLP_FX : GLP_DB,
+#endif
+ rhs, rhs + fabs(rng));
+ }
+ else if (type == GLP_UP)
+ { rhs = csa->P->row[i]->ub;
+#if 0 /* 26/V-2017 by cmatraki */
+ glp_set_row_bnds(csa->P, i, rhs == 0.0 ? GLP_FX : GLP_DB,
+#else
+ glp_set_row_bnds(csa->P, i, rng == 0.0 ? GLP_FX : GLP_DB,
+#endif
+ rhs - fabs(rng), rhs);
+ }
+ else if (type == GLP_FX)
+ { rhs = csa->P->row[i]->lb;
+ if (rng > 0.0)
+ glp_set_row_bnds(csa->P, i, GLP_DB, rhs, rhs + rng);
+ else if (rng < 0.0)
+ glp_set_row_bnds(csa->P, i, GLP_DB, rhs + rng, rhs);
+ }
+ else
+ xassert(type != type);
+ flag[i] = 1;
+ }
+ goto loop;
+done: /* free working array */
+ xfree(flag);
+ csa->work3 = NULL;
+ return;
+}
+
+static void read_bounds(struct csa *csa)
+{ /* read BOUNDS section */
+ GLPCOL *col;
+ int j, v, mask, data;
+ double bnd, lb, ub;
+ char type[2+1], name[255+1], *flag;
+ /* allocate working array */
+ csa->work3 = flag = xcalloc(1+csa->P->n, sizeof(char));
+ memset(&flag[1], 0, csa->P->n);
+ /* no current BOUNDS vector exists */
+ v = 0;
+loop: if (indicator(csa, 0)) goto done;
+ /* field 1: bound type */
+ read_field(csa);
+ if (strcmp(csa->field, "LO") == 0)
+ mask = 0x01, data = 1;
+ else if (strcmp(csa->field, "UP") == 0)
+ mask = 0x10, data = 1;
+ else if (strcmp(csa->field, "FX") == 0)
+ mask = 0x11, data = 1;
+ else if (strcmp(csa->field, "FR") == 0)
+ mask = 0x11, data = 0;
+ else if (strcmp(csa->field, "MI") == 0)
+ mask = 0x01, data = 0;
+ else if (strcmp(csa->field, "PL") == 0)
+ mask = 0x10, data = 0;
+ else if (strcmp(csa->field, "LI") == 0)
+ mask = 0x01, data = 1;
+ else if (strcmp(csa->field, "UI") == 0)
+ mask = 0x10, data = 1;
+ else if (strcmp(csa->field, "BV") == 0)
+ mask = 0x11, data = 0;
+ else if (csa->field[0] == '\0')
+ error(csa, "missing bound type in field 1\n");
+ else
+ error(csa, "invalid bound type in field 1\n");
+ strcpy(type, csa->field);
+ /* field 2: BOUNDS vector name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ { /* the same BOUNDS vector as in previous data record */
+ if (v == 0)
+ { warning(csa, "missing BOUNDS vector name in field 2\n");
+ goto blnk;
+ }
+ }
+ else if (v != 0 && strcmp(csa->field, name) == 0)
+ { /* the same BOUNDS vector as in previous data record */
+ xassert(v != 0);
+ }
+ else
+blnk: { /* new BOUNDS vector */
+ if (v != 0)
+ error(csa, "multiple BOUNDS vectors not supported\n");
+ v++;
+ strcpy(name, csa->field);
+ }
+ /* field 3: column name */
+ read_field(csa), patch_name(csa, csa->field);
+ if (csa->field[0] == '\0')
+ error(csa, "missing column name in field 3\n");
+ j = glp_find_col(csa->P, csa->field);
+ if (j == 0)
+ error(csa, "column '%s' not found\n", csa->field);
+ if ((flag[j] & mask) == 0x01)
+ error(csa, "duplicate lower bound for column '%s'\n",
+ csa->field);
+ if ((flag[j] & mask) == 0x10)
+ error(csa, "duplicate upper bound for column '%s'\n",
+ csa->field);
+ xassert((flag[j] & mask) == 0x00);
+ /* field 4: bound value */
+ if (data)
+ { bnd = read_number(csa);
+ if (fabs(bnd) < csa->parm->tol_mps) bnd = 0.0;
+ }
+ else
+ read_field(csa), bnd = 0.0;
+ /* get current column bounds */
+ col = csa->P->col[j];
+ if (col->type == GLP_FR)
+ lb = -DBL_MAX, ub = +DBL_MAX;
+ else if (col->type == GLP_LO)
+ lb = col->lb, ub = +DBL_MAX;
+ else if (col->type == GLP_UP)
+ lb = -DBL_MAX, ub = col->ub;
+ else if (col->type == GLP_DB)
+ lb = col->lb, ub = col->ub;
+ else if (col->type == GLP_FX)
+ lb = ub = col->lb;
+ else
+ xassert(col != col);
+ /* change column bounds */
+ if (strcmp(type, "LO") == 0)
+ lb = bnd;
+ else if (strcmp(type, "UP") == 0)
+ ub = bnd;
+ else if (strcmp(type, "FX") == 0)
+ lb = ub = bnd;
+ else if (strcmp(type, "FR") == 0)
+ lb = -DBL_MAX, ub = +DBL_MAX;
+ else if (strcmp(type, "MI") == 0)
+ lb = -DBL_MAX;
+ else if (strcmp(type, "PL") == 0)
+ ub = +DBL_MAX;
+ else if (strcmp(type, "LI") == 0)
+ { glp_set_col_kind(csa->P, j, GLP_IV);
+ lb = ceil(bnd);
+#if 1 /* 16/VII-2013 */
+ /* if column upper bound has not been explicitly specified,
+ take it as +inf */
+ if (!(flag[j] & 0x10))
+ ub = +DBL_MAX;
+#endif
+ }
+ else if (strcmp(type, "UI") == 0)
+ { glp_set_col_kind(csa->P, j, GLP_IV);
+ ub = floor(bnd);
+ }
+ else if (strcmp(type, "BV") == 0)
+ { glp_set_col_kind(csa->P, j, GLP_IV);
+ lb = 0.0, ub = 1.0;
+ }
+ else
+ xassert(type != type);
+ /* set new column bounds */
+ if (lb == -DBL_MAX && ub == +DBL_MAX)
+ glp_set_col_bnds(csa->P, j, GLP_FR, lb, ub);
+ else if (ub == +DBL_MAX)
+ glp_set_col_bnds(csa->P, j, GLP_LO, lb, ub);
+ else if (lb == -DBL_MAX)
+ glp_set_col_bnds(csa->P, j, GLP_UP, lb, ub);
+ else if (lb != ub)
+ glp_set_col_bnds(csa->P, j, GLP_DB, lb, ub);
+ else
+ glp_set_col_bnds(csa->P, j, GLP_FX, lb, ub);
+ flag[j] |= (char)mask;
+ /* fields 5 and 6 must be blank */
+ skip_field(csa);
+ skip_field(csa);
+ goto loop;
+done: /* free working array */
+ xfree(flag);
+ csa->work3 = NULL;
+ return;
+}
+
+int glp_read_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+ const char *fname)
+{ /* read problem data in MPS format */
+ glp_mpscp _parm;
+ struct csa _csa, *csa = &_csa;
+ int ret;
+ xprintf("Reading problem data from '%s'...\n", fname);
+ if (!(fmt == GLP_MPS_DECK || fmt == GLP_MPS_FILE))
+ xerror("glp_read_mps: fmt = %d; invalid parameter\n", fmt);
+ if (parm == NULL)
+ glp_init_mpscp(&_parm), parm = &_parm;
+ /* check control parameters */
+ check_parm("glp_read_mps", parm);
+ /* initialize common storage area */
+ csa->P = P;
+ csa->deck = (fmt == GLP_MPS_DECK);
+ csa->parm = parm;
+ csa->fname = fname;
+ csa->fp = NULL;
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->recno = csa->recpos = 0;
+ csa->c = '\n';
+ csa->fldno = 0;
+ csa->field[0] = '\0';
+ csa->w80 = csa->wef = 0;
+ csa->obj_row = 0;
+ csa->work1 = csa->work2 = csa->work3 = NULL;
+ /* erase problem object */
+ glp_erase_prob(P);
+ glp_create_index(P);
+ /* open input MPS file */
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* read NAME indicator record */
+ read_name(csa);
+ if (P->name != NULL)
+ xprintf("Problem: %s\n", P->name);
+ /* read ROWS section */
+ if (!(indicator(csa, 0) && strcmp(csa->field, "ROWS") == 0))
+ error(csa, "missing ROWS indicator record\n");
+ read_rows(csa);
+ /* determine objective row */
+ if (parm->obj_name == NULL || parm->obj_name[0] == '\0')
+ { /* use the first row of N type */
+ int i;
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->type == GLP_FR)
+ { csa->obj_row = i;
+ break;
+ }
+ }
+ if (csa->obj_row == 0)
+ warning(csa, "unable to determine objective row\n");
+ }
+ else
+ { /* use a row with specified name */
+ int i;
+ for (i = 1; i <= P->m; i++)
+ { xassert(P->row[i]->name != NULL);
+ if (strcmp(parm->obj_name, P->row[i]->name) == 0)
+ { csa->obj_row = i;
+ break;
+ }
+ }
+ if (csa->obj_row == 0)
+ error(csa, "objective row '%s' not found\n",
+ parm->obj_name);
+ }
+ if (csa->obj_row != 0)
+ { glp_set_obj_name(P, P->row[csa->obj_row]->name);
+ xprintf("Objective: %s\n", P->obj);
+ }
+ /* read COLUMNS section */
+ if (strcmp(csa->field, "COLUMNS") != 0)
+ error(csa, "missing COLUMNS indicator record\n");
+ read_columns(csa);
+ /* set objective coefficients */
+ if (csa->obj_row != 0)
+ { GLPAIJ *aij;
+ for (aij = P->row[csa->obj_row]->ptr; aij != NULL; aij =
+ aij->r_next) glp_set_obj_coef(P, aij->col->j, aij->val);
+ }
+ /* read optional RHS section */
+ if (strcmp(csa->field, "RHS") == 0)
+ read_rhs(csa);
+ /* read optional RANGES section */
+ if (strcmp(csa->field, "RANGES") == 0)
+ read_ranges(csa);
+ /* read optional BOUNDS section */
+ if (strcmp(csa->field, "BOUNDS") == 0)
+ read_bounds(csa);
+ /* read ENDATA indicator record */
+ if (strcmp(csa->field, "ENDATA") != 0)
+ error(csa, "invalid use of %s indicator record\n",
+ csa->field);
+ /* print some statistics */
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" : "s",
+ P->nnz, P->nnz == 1 ? "" : "s");
+ if (glp_get_num_int(P) > 0)
+ { int ni = glp_get_num_int(P);
+ int nb = glp_get_num_bin(P);
+ if (ni == 1)
+ { if (nb == 0)
+ xprintf("One variable is integer\n");
+ else
+ xprintf("One variable is binary\n");
+ }
+ else
+ { xprintf("%d integer variables, ", ni);
+ if (nb == 0)
+ xprintf("none");
+ else if (nb == 1)
+ xprintf("one");
+ else if (nb == ni)
+ xprintf("all");
+ else
+ xprintf("%d", nb);
+ xprintf(" of which %s binary\n", nb == 1 ? "is" : "are");
+ }
+ }
+ xprintf("%d records were read\n", csa->recno);
+#if 1 /* 31/III-2016 */
+ /* free (unbounded) row(s) in MPS file are intended to specify
+ * objective function(s), so all such rows can be removed */
+#if 1 /* 08/VIII-2013 */
+ /* remove free rows */
+ { int i, nrs, *num;
+ num = talloc(1+P->m, int);
+ nrs = 0;
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->type == GLP_FR)
+ num[++nrs] = i;
+ }
+ if (nrs > 0)
+ { glp_del_rows(P, nrs, num);
+ if (nrs == 1)
+ xprintf("One free row was removed\n");
+ else
+ xprintf("%d free rows were removed\n", nrs);
+ }
+ tfree(num);
+ }
+#endif
+#else
+ /* if objective function row is free, remove it */
+ if (csa->obj_row != 0 && P->row[csa->obj_row]->type == GLP_FR)
+ { int num[1+1];
+ num[1] = csa->obj_row;
+ glp_del_rows(P, 1, num);
+ xprintf("Free objective row was removed\n");
+ }
+#endif
+ /* problem data has been successfully read */
+ glp_delete_index(P);
+ glp_sort_matrix(P);
+ ret = 0;
+done: if (csa->fp != NULL) glp_close(csa->fp);
+ if (csa->work1 != NULL) xfree(csa->work1);
+ if (csa->work2 != NULL) xfree(csa->work2);
+ if (csa->work3 != NULL) xfree(csa->work3);
+ if (ret != 0) glp_erase_prob(P);
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_write_mps - write problem data in MPS format
+*
+* SYNOPSIS
+*
+* int glp_write_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_mps writes problem data in MPS format to a
+* text file.
+*
+* The parameter fmt specifies the version of MPS format:
+*
+* GLP_MPS_DECK - fixed (ancient) MPS format;
+* GLP_MPS_FILE - free (modern) MPS format.
+*
+* The parameter parm is a pointer to the structure glp_mpscp, which
+* specifies control parameters used by the routine. If parm is NULL,
+* the routine uses default settings.
+*
+* The character string fname specifies a name of the text file to be
+* written.
+*
+* RETURNS
+*
+* If the operation was successful, the routine glp_read_mps returns
+* zero. Otherwise, it prints an error message and returns non-zero. */
+
+#define csa csa1
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* pointer to problem object */
+ int deck;
+ /* MPS format (0 - free, 1 - fixed) */
+ const glp_mpscp *parm;
+ /* pointer to control parameters */
+ char field[255+1];
+ /* field buffer */
+};
+
+static char *mps_name(struct csa *csa)
+{ /* make problem name */
+ char *f;
+ if (csa->P->name == NULL)
+ csa->field[0] = '\0';
+ else if (csa->deck)
+ { strncpy(csa->field, csa->P->name, 8);
+ csa->field[8] = '\0';
+ }
+ else
+ strcpy(csa->field, csa->P->name);
+ for (f = csa->field; *f != '\0'; f++)
+ if (*f == ' ') *f = '_';
+ return csa->field;
+}
+
+static char *row_name(struct csa *csa, int i)
+{ /* make i-th row name */
+ char *f;
+ xassert(0 <= i && i <= csa->P->m);
+ if (i == 0 || csa->P->row[i]->name == NULL ||
+ csa->deck && strlen(csa->P->row[i]->name) > 8)
+ sprintf(csa->field, "R%07d", i);
+ else
+ { strcpy(csa->field, csa->P->row[i]->name);
+ for (f = csa->field; *f != '\0'; f++)
+ if (*f == ' ') *f = '_';
+ }
+ return csa->field;
+}
+
+static char *col_name(struct csa *csa, int j)
+{ /* make j-th column name */
+ char *f;
+ xassert(1 <= j && j <= csa->P->n);
+ if (csa->P->col[j]->name == NULL ||
+ csa->deck && strlen(csa->P->col[j]->name) > 8)
+ sprintf(csa->field, "C%07d", j);
+ else
+ { strcpy(csa->field, csa->P->col[j]->name);
+ for (f = csa->field; *f != '\0'; f++)
+ if (*f == ' ') *f = '_';
+ }
+ return csa->field;
+}
+
+static char *mps_numb(struct csa *csa, double val)
+{ /* format floating-point number */
+ int dig;
+ char *exp;
+ for (dig = 12; dig >= 6; dig--)
+ { if (val != 0.0 && fabs(val) < 0.002)
+ sprintf(csa->field, "%.*E", dig-1, val);
+ else
+ sprintf(csa->field, "%.*G", dig, val);
+ exp = strchr(csa->field, 'E');
+ if (exp != NULL)
+ sprintf(exp+1, "%d", atoi(exp+1));
+ if (strlen(csa->field) <= 12) break;
+ }
+ xassert(strlen(csa->field) <= 12);
+ return csa->field;
+}
+
+int glp_write_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+ const char *fname)
+{ /* write problem data in MPS format */
+ glp_mpscp _parm;
+ struct csa _csa, *csa = &_csa;
+ glp_file *fp;
+ int out_obj, one_col = 0, empty = 0;
+ int i, j, recno, marker, count, gap, ret;
+ xprintf("Writing problem data to '%s'...\n", fname);
+ if (!(fmt == GLP_MPS_DECK || fmt == GLP_MPS_FILE))
+ xerror("glp_write_mps: fmt = %d; invalid parameter\n", fmt);
+ if (parm == NULL)
+ glp_init_mpscp(&_parm), parm = &_parm;
+ /* check control parameters */
+ check_parm("glp_write_mps", parm);
+ /* initialize common storage area */
+ csa->P = P;
+ csa->deck = (fmt == GLP_MPS_DECK);
+ csa->parm = parm;
+ /* create output MPS file */
+ fp = glp_open(fname, "w"), recno = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* write comment records */
+ xfprintf(fp, "* %-*s%s\n", P->name == NULL ? 1 : 12, "Problem:",
+ P->name == NULL ? "" : P->name), recno++;
+ xfprintf(fp, "* %-12s%s\n", "Class:", glp_get_num_int(P) == 0 ?
+ "LP" : "MIP"), recno++;
+ xfprintf(fp, "* %-12s%d\n", "Rows:", P->m), recno++;
+ if (glp_get_num_int(P) == 0)
+ xfprintf(fp, "* %-12s%d\n", "Columns:", P->n), recno++;
+ else
+ xfprintf(fp, "* %-12s%d (%d integer, %d binary)\n",
+ "Columns:", P->n, glp_get_num_int(P), glp_get_num_bin(P)),
+ recno++;
+ xfprintf(fp, "* %-12s%d\n", "Non-zeros:", P->nnz), recno++;
+ xfprintf(fp, "* %-12s%s\n", "Format:", csa->deck ? "Fixed MPS" :
+ "Free MPS"), recno++;
+ xfprintf(fp, "*\n", recno++);
+ /* write NAME indicator record */
+ xfprintf(fp, "NAME%*s%s\n",
+ P->name == NULL ? 0 : csa->deck ? 10 : 1, "", mps_name(csa)),
+ recno++;
+#if 1
+ /* determine whether to write the objective row */
+ out_obj = 1;
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->type == GLP_FR)
+ { out_obj = 0;
+ break;
+ }
+ }
+#endif
+ /* write ROWS section */
+ xfprintf(fp, "ROWS\n"), recno++;
+ for (i = (out_obj ? 0 : 1); i <= P->m; i++)
+ { int type;
+ type = (i == 0 ? GLP_FR : P->row[i]->type);
+ if (type == GLP_FR)
+ type = 'N';
+ else if (type == GLP_LO)
+ type = 'G';
+ else if (type == GLP_UP)
+ type = 'L';
+ else if (type == GLP_DB || type == GLP_FX)
+ type = 'E';
+ else
+ xassert(type != type);
+ xfprintf(fp, " %c%*s%s\n", type, csa->deck ? 2 : 1, "",
+ row_name(csa, i)), recno++;
+ }
+ /* write COLUMNS section */
+ xfprintf(fp, "COLUMNS\n"), recno++;
+ marker = 0;
+ for (j = 1; j <= P->n; j++)
+ { GLPAIJ cj, *aij;
+ int kind;
+ kind = P->col[j]->kind;
+ if (kind == GLP_CV)
+ { if (marker % 2 == 1)
+ { /* close current integer block */
+ marker++;
+ xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTEND'\n",
+ csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
+ csa->deck ? 17 : 1, ""), recno++;
+ }
+ }
+ else if (kind == GLP_IV)
+ { if (marker % 2 == 0)
+ { /* open new integer block */
+ marker++;
+ xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTORG'\n",
+ csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
+ csa->deck ? 17 : 1, ""), recno++;
+ }
+ }
+ else
+ xassert(kind != kind);
+ if (out_obj && P->col[j]->coef != 0.0)
+ { /* make fake objective coefficient */
+ aij = &cj;
+ aij->row = NULL;
+ aij->val = P->col[j]->coef;
+ aij->c_next = P->col[j]->ptr;
+ }
+ else
+ aij = P->col[j]->ptr;
+#if 1 /* FIXME */
+ if (aij == NULL)
+ { /* empty column */
+ empty++;
+ xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
+ csa->deck ? 8 : 1, col_name(csa, j));
+ /* we need a row */
+ xassert(P->m > 0);
+ xfprintf(fp, "%*s%-*s",
+ csa->deck ? 2 : 1, "", csa->deck ? 8 : 1,
+ row_name(csa, 1));
+ xfprintf(fp, "%*s0%*s$ empty column\n",
+ csa->deck ? 13 : 1, "", csa->deck ? 3 : 1, ""), recno++;
+ }
+#endif
+ count = 0;
+ for (aij = aij; aij != NULL; aij = aij->c_next)
+ { if (one_col || count % 2 == 0)
+ xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
+ csa->deck ? 8 : 1, col_name(csa, j));
+ gap = (one_col || count % 2 == 0 ? 2 : 3);
+ xfprintf(fp, "%*s%-*s",
+ csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
+ row_name(csa, aij->row == NULL ? 0 : aij->row->i));
+ xfprintf(fp, "%*s%*s",
+ csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
+ mps_numb(csa, aij->val)), count++;
+ if (one_col || count % 2 == 0)
+ xfprintf(fp, "\n"), recno++;
+ }
+ if (!(one_col || count % 2 == 0))
+ xfprintf(fp, "\n"), recno++;
+ }
+ if (marker % 2 == 1)
+ { /* close last integer block */
+ marker++;
+ xfprintf(fp, "%*sM%07d%*s'MARKER'%*s'INTEND'\n",
+ csa->deck ? 4 : 1, "", marker, csa->deck ? 2 : 1, "",
+ csa->deck ? 17 : 1, ""), recno++;
+ }
+#if 1
+ if (empty > 0)
+ xprintf("Warning: problem has %d empty column(s)\n", empty);
+#endif
+ /* write RHS section */
+ xfprintf(fp, "RHS\n"), recno++;
+ count = 0;
+ for (i = (out_obj ? 0 : 1); i <= P->m; i++)
+ { int type;
+ double rhs;
+ if (i == 0)
+ rhs = P->c0;
+ else
+ { type = P->row[i]->type;
+ if (type == GLP_FR)
+ rhs = 0.0;
+ else if (type == GLP_LO)
+ rhs = P->row[i]->lb;
+ else if (type == GLP_UP)
+ rhs = P->row[i]->ub;
+ else if (type == GLP_DB || type == GLP_FX)
+ rhs = P->row[i]->lb;
+ else
+ xassert(type != type);
+ }
+ if (rhs != 0.0)
+ { if (one_col || count % 2 == 0)
+ xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
+ csa->deck ? 8 : 1, "RHS1");
+ gap = (one_col || count % 2 == 0 ? 2 : 3);
+ xfprintf(fp, "%*s%-*s",
+ csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
+ row_name(csa, i));
+ xfprintf(fp, "%*s%*s",
+ csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
+ mps_numb(csa, rhs)), count++;
+ if (one_col || count % 2 == 0)
+ xfprintf(fp, "\n"), recno++;
+ }
+ }
+ if (!(one_col || count % 2 == 0))
+ xfprintf(fp, "\n"), recno++;
+ /* write RANGES section */
+ for (i = P->m; i >= 1; i--)
+ if (P->row[i]->type == GLP_DB) break;
+ if (i == 0) goto bnds;
+ xfprintf(fp, "RANGES\n"), recno++;
+ count = 0;
+ for (i = 1; i <= P->m; i++)
+ { if (P->row[i]->type == GLP_DB)
+ { if (one_col || count % 2 == 0)
+ xfprintf(fp, "%*s%-*s", csa->deck ? 4 : 1, "",
+ csa->deck ? 8 : 1, "RNG1");
+ gap = (one_col || count % 2 == 0 ? 2 : 3);
+ xfprintf(fp, "%*s%-*s",
+ csa->deck ? gap : 1, "", csa->deck ? 8 : 1,
+ row_name(csa, i));
+ xfprintf(fp, "%*s%*s",
+ csa->deck ? 2 : 1, "", csa->deck ? 12 : 1,
+ mps_numb(csa, P->row[i]->ub - P->row[i]->lb)), count++;
+ if (one_col || count % 2 == 0)
+ xfprintf(fp, "\n"), recno++;
+ }
+ }
+ if (!(one_col || count % 2 == 0))
+ xfprintf(fp, "\n"), recno++;
+bnds: /* write BOUNDS section */
+ for (j = P->n; j >= 1; j--)
+ if (!(P->col[j]->kind == GLP_CV &&
+ P->col[j]->type == GLP_LO && P->col[j]->lb == 0.0))
+ break;
+ if (j == 0) goto endt;
+ xfprintf(fp, "BOUNDS\n"), recno++;
+ for (j = 1; j <= P->n; j++)
+ { int type, data[2];
+ double bnd[2];
+ char *spec[2];
+ spec[0] = spec[1] = NULL;
+ type = P->col[j]->type;
+ if (type == GLP_FR)
+ spec[0] = "FR", data[0] = 0;
+ else if (type == GLP_LO)
+ { if (P->col[j]->lb != 0.0)
+ spec[0] = "LO", data[0] = 1, bnd[0] = P->col[j]->lb;
+ if (P->col[j]->kind == GLP_IV)
+ spec[1] = "PL", data[1] = 0;
+ }
+ else if (type == GLP_UP)
+ { spec[0] = "MI", data[0] = 0;
+ spec[1] = "UP", data[1] = 1, bnd[1] = P->col[j]->ub;
+ }
+ else if (type == GLP_DB)
+ { if (P->col[j]->lb != 0.0)
+ spec[0] = "LO", data[0] = 1, bnd[0] = P->col[j]->lb;
+ spec[1] = "UP", data[1] = 1, bnd[1] = P->col[j]->ub;
+ }
+ else if (type == GLP_FX)
+ spec[0] = "FX", data[0] = 1, bnd[0] = P->col[j]->lb;
+ else
+ xassert(type != type);
+ for (i = 0; i <= 1; i++)
+ { if (spec[i] != NULL)
+ { xfprintf(fp, " %s %-*s%*s%-*s", spec[i],
+ csa->deck ? 8 : 1, "BND1", csa->deck ? 2 : 1, "",
+ csa->deck ? 8 : 1, col_name(csa, j));
+ if (data[i])
+ xfprintf(fp, "%*s%*s", csa->deck ? 2 : 1, "",
+ csa->deck ? 12 : 1, mps_numb(csa, bnd[i]));
+ xfprintf(fp, "\n"), recno++;
+ }
+ }
+ }
+endt: /* write ENDATA indicator record */
+ xfprintf(fp, "ENDATA\n"), recno++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* problem data has been successfully written */
+ xprintf("%d records were written\n", recno);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/netgen.c b/test/monniaux/glpk-4.65/src/api/netgen.c
new file mode 100644
index 00000000..519fd609
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/netgen.c
@@ -0,0 +1,1020 @@
+/* netgen.c (Klingman's network problem generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is the result of translation of the Fortran program NETGEN
+* developed by Dr. Darwin Klingman, which is publically available from
+* NETLIB at <http://www.netlib.org/lp/generators>.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_netgen - Klingman's network problem generator
+*
+* SYNOPSIS
+*
+* int glp_netgen(glp_graph *G, int v_rhs, int a_cap, int a_cost,
+* const int parm[1+15]);
+*
+* DESCRIPTION
+*
+* The routine glp_netgen is a network problem generator developed by
+* Dr. Darwin Klingman. It can create capacitated and uncapacitated
+* minimum cost flow (or transshipment), transportation, and assignment
+* problems.
+*
+* The parameter G specifies the graph object, to which the generated
+* problem data have to be stored. Note that on entry the graph object
+* is erased with the routine glp_erase_graph.
+*
+* The parameter v_rhs specifies an offset of the field of type double
+* in the vertex data block, to which the routine stores the supply or
+* demand value. If v_rhs < 0, the value is not stored.
+*
+* The parameter a_cap specifies an offset of the field of type double
+* in the arc data block, to which the routine stores the arc capacity.
+* If a_cap < 0, the capacity is not stored.
+*
+* The parameter a_cost specifies an offset of the field of type double
+* in the arc data block, to which the routine stores the per-unit cost
+* if the arc flow. If a_cost < 0, the cost is not stored.
+*
+* The array parm contains description of the network to be generated:
+*
+* parm[0] not used
+* parm[1] (iseed) 8-digit positive random number seed
+* parm[2] (nprob) 8-digit problem id number
+* parm[3] (nodes) total number of nodes
+* parm[4] (nsorc) total number of source nodes (including
+* transshipment nodes)
+* parm[5] (nsink) total number of sink nodes (including
+* transshipment nodes)
+* parm[6] (iarcs) number of arcs
+* parm[7] (mincst) minimum cost for arcs
+* parm[8] (maxcst) maximum cost for arcs
+* parm[9] (itsup) total supply
+* parm[10] (ntsorc) number of transshipment source nodes
+* parm[11] (ntsink) number of transshipment sink nodes
+* parm[12] (iphic) percentage of skeleton arcs to be given
+* the maximum cost
+* parm[13] (ipcap) percentage of arcs to be capacitated
+* parm[14] (mincap) minimum upper bound for capacitated arcs
+* parm[15] (maxcap) maximum upper bound for capacitated arcs
+*
+* The routine generates a transportation problem if:
+*
+* nsorc + nsink = nodes, ntsorc = 0, and ntsink = 0.
+*
+* The routine generates an assignment problem if the requirements for
+* a transportation problem are met and:
+*
+* nsorc = nsink and itsup = nsorc.
+*
+* RETURNS
+*
+* If the instance was successfully generated, the routine glp_netgen
+* returns zero; otherwise, if specified parameters are inconsistent,
+* the routine returns a non-zero error code.
+*
+* REFERENCES
+*
+* D.Klingman, A.Napier, and J.Stutz. NETGEN: A program for generating
+* large scale capacitated assignment, transportation, and minimum cost
+* flow networks. Management Science 20 (1974), 814-20. */
+
+struct csa
+{ /* common storage area */
+ glp_graph *G;
+ int v_rhs, a_cap, a_cost;
+ int nodes, iarcs, mincst, maxcst, itsup, nsorc, nsink, nonsor,
+ nfsink, narcs, nsort, nftsor, ipcap, mincap, maxcap, ktl,
+ nodlft, *ipred, *ihead, *itail, *iflag, *isup, *lsinks, mult,
+ modul, i15, i16, jran;
+};
+
+#define G (csa->G)
+#define v_rhs (csa->v_rhs)
+#define a_cap (csa->a_cap)
+#define a_cost (csa->a_cost)
+#define nodes (csa->nodes)
+#define iarcs (csa->iarcs)
+#define mincst (csa->mincst)
+#define maxcst (csa->maxcst)
+#define itsup (csa->itsup)
+#define nsorc (csa->nsorc)
+#define nsink (csa->nsink)
+#define nonsor (csa->nonsor)
+#define nfsink (csa->nfsink)
+#define narcs (csa->narcs)
+#define nsort (csa->nsort)
+#define nftsor (csa->nftsor)
+#define ipcap (csa->ipcap)
+#define mincap (csa->mincap)
+#define maxcap (csa->maxcap)
+#define ktl (csa->ktl)
+#define nodlft (csa->nodlft)
+#if 0
+/* spent a day to find out this bug */
+#define ist (csa->ist)
+#else
+#define ist (ipred[0])
+#endif
+#define ipred (csa->ipred)
+#define ihead (csa->ihead)
+#define itail (csa->itail)
+#define iflag (csa->iflag)
+#define isup (csa->isup)
+#define lsinks (csa->lsinks)
+#define mult (csa->mult)
+#define modul (csa->modul)
+#define i15 (csa->i15)
+#define i16 (csa->i16)
+#define jran (csa->jran)
+
+static void cresup(struct csa *csa);
+static void chain(struct csa *csa, int lpick, int lsorc);
+static void chnarc(struct csa *csa, int lsorc);
+static void sort(struct csa *csa);
+static void pickj(struct csa *csa, int it);
+static void assign(struct csa *csa);
+static void setran(struct csa *csa, int iseed);
+static int iran(struct csa *csa, int ilow, int ihigh);
+
+int glp_netgen(glp_graph *G_, int _v_rhs, int _a_cap, int _a_cost,
+ const int parm[1+15])
+{ struct csa _csa, *csa = &_csa;
+ int iseed, nprob, ntsorc, ntsink, iphic, i, nskel, nltr, ltsink,
+ ntrans, npsink, nftr, npsorc, ntravl, ntrrem, lsorc, lpick,
+ nsksr, nsrchn, j, item, l, ks, k, ksp, li, n, ii, it, ih, icap,
+ jcap, icost, jcost, ret;
+ G = G_;
+ v_rhs = _v_rhs;
+ a_cap = _a_cap;
+ a_cost = _a_cost;
+ if (G != NULL)
+ { if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_netgen: v_rhs = %d; invalid offset\n", v_rhs);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_netgen: a_cap = %d; invalid offset\n", a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_netgen: a_cost = %d; invalid offset\n", a_cost);
+ }
+ /* Input the user's random number seed and fix it if
+ non-positive. */
+ iseed = parm[1];
+ nprob = parm[2];
+ if (iseed <= 0) iseed = 13502460;
+ setran(csa, iseed);
+ /* Input the user's problem characteristics. */
+ nodes = parm[3];
+ nsorc = parm[4];
+ nsink = parm[5];
+ iarcs = parm[6];
+ mincst = parm[7];
+ maxcst = parm[8];
+ itsup = parm[9];
+ ntsorc = parm[10];
+ ntsink = parm[11];
+ iphic = parm[12];
+ ipcap = parm[13];
+ mincap = parm[14];
+ maxcap = parm[15];
+ /* Check the size of the problem. */
+ if (!(10 <= nodes && nodes <= 100000))
+ { ret = 1;
+ goto done;
+ }
+ /* Check user supplied parameters for consistency. */
+ if (!(nsorc >= 0 && nsink >= 0 && nsorc + nsink <= nodes))
+ { ret = 2;
+ goto done;
+ }
+ if (iarcs < 0)
+ { ret = 3;
+ goto done;
+ }
+ if (mincst > maxcst)
+ { ret = 4;
+ goto done;
+ }
+ if (itsup < 0)
+ { ret = 5;
+ goto done;
+ }
+ if (!(0 <= ntsorc && ntsorc <= nsorc))
+ { ret = 6;
+ goto done;
+ }
+ if (!(0 <= ntsink && ntsink <= nsink))
+ { ret = 7;
+ goto done;
+ }
+ if (!(0 <= iphic && iphic <= 100))
+ { ret = 8;
+ goto done;
+ }
+ if (!(0 <= ipcap && ipcap <= 100))
+ { ret = 9;
+ goto done;
+ }
+ if (mincap > maxcap)
+ { ret = 10;
+ goto done;
+ }
+ /* Initailize the graph object. */
+ if (G != NULL)
+ { glp_erase_graph(G, G->v_size, G->a_size);
+ glp_add_vertices(G, nodes);
+ if (v_rhs >= 0)
+ { double zero = 0.0;
+ for (i = 1; i <= nodes; i++)
+ { glp_vertex *v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &zero, sizeof(double));
+ }
+ }
+ }
+ /* Allocate working arrays. */
+ ipred = xcalloc(1+nodes, sizeof(int));
+ ihead = xcalloc(1+nodes, sizeof(int));
+ itail = xcalloc(1+nodes, sizeof(int));
+ iflag = xcalloc(1+nodes, sizeof(int));
+ isup = xcalloc(1+nodes, sizeof(int));
+ lsinks = xcalloc(1+nodes, sizeof(int));
+ /* Print the problem documentation records. */
+ if (G == NULL)
+ { xprintf("BEGIN\n");
+ xprintf("NETGEN PROBLEM%8d%10s%10d NODES AND%10d ARCS\n",
+ nprob, "", nodes, iarcs);
+ xprintf("USER:%11d%11d%11d%11d%11d%11d\nDATA:%11d%11d%11d%11d%"
+ "11d%11d\n", iseed, nsorc, nsink, mincst,
+ maxcst, itsup, ntsorc, ntsink, iphic, ipcap,
+ mincap, maxcap);
+ }
+ else
+ glp_set_graph_name(G, "NETGEN");
+ /* Set various constants used in the program. */
+ narcs = 0;
+ nskel = 0;
+ nltr = nodes - nsink;
+ ltsink = nltr + ntsink;
+ ntrans = nltr - nsorc;
+ nfsink = nltr + 1;
+ nonsor = nodes - nsorc + ntsorc;
+ npsink = nsink - ntsink;
+ nodlft = nodes - nsink + ntsink;
+ nftr = nsorc + 1;
+ nftsor = nsorc - ntsorc + 1;
+ npsorc = nsorc - ntsorc;
+ /* Randomly distribute the supply among the source nodes. */
+ if (npsorc + npsink == nodes && npsorc == npsink &&
+ itsup == nsorc)
+ { assign(csa);
+ nskel = nsorc;
+ goto L390;
+ }
+ cresup(csa);
+ /* Print the supply records. */
+ if (G == NULL)
+ { xprintf("SUPPLY\n");
+ for (i = 1; i <= nsorc; i++)
+ xprintf("%6s%6d%18s%10d\n", "", i, "", isup[i]);
+ xprintf("ARCS\n");
+ }
+ else
+ { if (v_rhs >= 0)
+ { for (i = 1; i <= nsorc; i++)
+ { double temp = (double)isup[i];
+ glp_vertex *v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &temp, sizeof(double));
+ }
+ }
+ }
+ /* Make the sources point to themselves in ipred array. */
+ for (i = 1; i <= nsorc; i++)
+ ipred[i] = i;
+ if (ntrans == 0) goto L170;
+ /* Chain the transshipment nodes together in the ipred array. */
+ ist = nftr;
+ ipred[nltr] = 0;
+ for (i = nftr; i < nltr; i++)
+ ipred[i] = i+1;
+ /* Form even length chains for 60 percent of the transshipments.*/
+ ntravl = 6 * ntrans / 10;
+ ntrrem = ntrans - ntravl;
+L140: lsorc = 1;
+ while (ntravl != 0)
+ { lpick = iran(csa, 1, ntravl + ntrrem);
+ ntravl--;
+ chain(csa, lpick, lsorc);
+ if (lsorc == nsorc) goto L140;
+ lsorc++;
+ }
+ /* Add the remaining transshipments to the chains. */
+ while (ntrrem != 0)
+ {
+ lpick = iran(csa, 1, ntrrem);
+ ntrrem--;
+ lsorc = iran(csa, 1, nsorc);
+ chain(csa, lpick, lsorc);
+ }
+L170: /* Set all demands equal to zero. */
+ for (i = nfsink; i <= nodes; i++)
+ ipred[i] = 0;
+ /* The following loop takes one chain at a time (through the use
+ of logic contained in the loop and calls to other routines) and
+ creates the remaining network arcs. */
+ for (lsorc = 1; lsorc <= nsorc; lsorc++)
+ { chnarc(csa, lsorc);
+ for (i = nfsink; i <= nodes; i++)
+ iflag[i] = 0;
+ /* Choose the number of sinks to be hooked up to the current
+ chain. */
+ if (ntrans != 0)
+ nsksr = (nsort * 2 * nsink) / ntrans;
+ else
+ nsksr = nsink / nsorc + 1;
+ if (nsksr < 2) nsksr = 2;
+ if (nsksr > nsink) nsksr = nsink;
+ nsrchn = nsort;
+ /* Randomly pick nsksr sinks and put their names in lsinks. */
+ ktl = nsink;
+ for (j = 1; j <= nsksr; j++)
+ { item = iran(csa, 1, ktl);
+ ktl--;
+ for (l = nfsink; l <= nodes; l++)
+ { if (iflag[l] != 1)
+ { item--;
+ if (item == 0) goto L230;
+ }
+ }
+ break;
+L230: lsinks[j] = l;
+ iflag[l] = 1;
+ }
+ /* If last source chain, add all sinks with zero demand to
+ lsinks list. */
+ if (lsorc == nsorc)
+ { for (j = nfsink; j <= nodes; j++)
+ { if (ipred[j] == 0 && iflag[j] != 1)
+ { nsksr++;
+ lsinks[nsksr] = j;
+ iflag[j] = 1;
+ }
+ }
+ }
+ /* Create demands for group of sinks in lsinks. */
+ ks = isup[lsorc] / nsksr;
+ k = ipred[lsorc];
+ for (i = 1; i <= nsksr; i++)
+ { nsort++;
+ ksp = iran(csa, 1, ks);
+ j = iran(csa, 1, nsksr);
+ itail[nsort] = k;
+ li = lsinks[i];
+ ihead[nsort] = li;
+ ipred[li] += ksp;
+ li = lsinks[j];
+ ipred[li] += ks - ksp;
+ n = iran(csa, 1, nsrchn);
+ k = lsorc;
+ for (ii = 1; ii <= n; ii++)
+ k = ipred[k];
+ }
+ li = lsinks[1];
+ ipred[li] += isup[lsorc] - ks * nsksr;
+ nskel += nsort;
+ /* Sort the arcs in the chain from source lsorc using itail as
+ sort key. */
+ sort(csa);
+ /* Print this part of skeleton and create the arcs for these
+ nodes. */
+ i = 1;
+ itail[nsort+1] = 0;
+L300: for (j = nftsor; j <= nodes; j++)
+ iflag[j] = 0;
+ ktl = nonsor - 1;
+ it = itail[i];
+ iflag[it] = 1;
+L320: ih = ihead[i];
+ iflag[ih] = 1;
+ narcs++;
+ ktl--;
+ /* Determine if this skeleton arc should be capacitated. */
+ icap = itsup;
+ jcap = iran(csa, 1, 100);
+ if (jcap <= ipcap)
+ { icap = isup[lsorc];
+ if (mincap > icap) icap = mincap;
+ }
+ /* Determine if this skeleton arc should have the maximum
+ cost. */
+ icost = maxcst;
+ jcost = iran(csa, 1, 100);
+ if (jcost > iphic)
+ icost = iran(csa, mincst, maxcst);
+ if (G == NULL)
+ xprintf("%6s%6d%6d%2s%10d%10d\n", "", it, ih, "", icost,
+ icap);
+ else
+ { glp_arc *a = glp_add_arc(G, it, ih);
+ if (a_cap >= 0)
+ { double temp = (double)icap;
+ memcpy((char *)a->data + a_cap, &temp, sizeof(double));
+ }
+ if (a_cost >= 0)
+ { double temp = (double)icost;
+ memcpy((char *)a->data + a_cost, &temp, sizeof(double));
+ }
+ }
+ i++;
+ if (itail[i] == it) goto L320;
+ pickj(csa, it);
+ if (i <= nsort) goto L300;
+ }
+ /* Create arcs from the transshipment sinks. */
+ if (ntsink != 0)
+ { for (i = nfsink; i <= ltsink; i++)
+ { for (j = nftsor; j <= nodes; j++)
+ iflag[j] = 0;
+ ktl = nonsor - 1;
+ iflag[i] = 1;
+ pickj(csa, i);
+ }
+ }
+L390: /* Print the demand records and end record. */
+ if (G == NULL)
+ { xprintf("DEMAND\n");
+ for (i = nfsink; i <= nodes; i++)
+ xprintf("%6s%6d%18s%10d\n", "", i, "", ipred[i]);
+ xprintf("END\n");
+ }
+ else
+ { if (v_rhs >= 0)
+ { for (i = nfsink; i <= nodes; i++)
+ { double temp = - (double)ipred[i];
+ glp_vertex *v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &temp, sizeof(double));
+ }
+ }
+ }
+ /* Free working arrays. */
+ xfree(ipred);
+ xfree(ihead);
+ xfree(itail);
+ xfree(iflag);
+ xfree(isup);
+ xfree(lsinks);
+ /* The instance has been successfully generated. */
+ ret = 0;
+done: return ret;
+}
+
+/***********************************************************************
+* The routine cresup randomly distributes the total supply among the
+* source nodes. */
+
+static void cresup(struct csa *csa)
+{ int i, j, ks, ksp;
+ xassert(itsup > nsorc);
+ ks = itsup / nsorc;
+ for (i = 1; i <= nsorc; i++)
+ isup[i] = 0;
+ for (i = 1; i <= nsorc; i++)
+ { ksp = iran(csa, 1, ks);
+ j = iran(csa, 1, nsorc);
+ isup[i] += ksp;
+ isup[j] += ks - ksp;
+ }
+ j = iran(csa, 1, nsorc);
+ isup[j] += itsup - ks * nsorc;
+ return;
+}
+
+/***********************************************************************
+* The routine chain adds node lpick to the end of the chain with source
+* node lsorc. */
+
+static void chain(struct csa *csa, int lpick, int lsorc)
+{ int i, j, k, l, m;
+ k = 0;
+ m = ist;
+ for (i = 1; i <= lpick; i++)
+ { l = k;
+ k = m;
+ m = ipred[k];
+ }
+ ipred[l] = m;
+ j = ipred[lsorc];
+ ipred[k] = j;
+ ipred[lsorc] = k;
+ return;
+}
+
+/***********************************************************************
+* The routine chnarc puts the arcs in the chain from source lsorc into
+* the ihead and itail arrays for sorting. */
+
+static void chnarc(struct csa *csa, int lsorc)
+{ int ito, ifrom;
+ nsort = 0;
+ ito = ipred[lsorc];
+L10: if (ito == lsorc) return;
+ nsort++;
+ ifrom = ipred[ito];
+ ihead[nsort] = ito;
+ itail[nsort] = ifrom;
+ ito = ifrom;
+ goto L10;
+}
+
+/***********************************************************************
+* The routine sort sorts the nsort arcs in the ihead and itail arrays.
+* ihead is used as the sort key (i.e. forward star sort order). */
+
+static void sort(struct csa *csa)
+{ int i, j, k, l, m, n, it;
+ n = nsort;
+ m = n;
+L10: m /= 2;
+ if (m == 0) return;
+ k = n - m;
+ j = 1;
+L20: i = j;
+L30: l = i + m;
+ if (itail[i] <= itail[l]) goto L40;
+ it = itail[i];
+ itail[i] = itail[l];
+ itail[l] = it;
+ it = ihead[i];
+ ihead[i] = ihead[l];
+ ihead[l] = it;
+ i -= m;
+ if (i >= 1) goto L30;
+L40: j++;
+ if (j <= k) goto L20;
+ goto L10;
+}
+
+/***********************************************************************
+* The routine pickj creates a random number of arcs out of node 'it'.
+* Various parameters are dynamically adjusted in an attempt to ensure
+* that the generated network has the correct number of arcs. */
+
+static void pickj(struct csa *csa, int it)
+{ int j, k, l, nn, nupbnd, icap, jcap, icost;
+ if ((nodlft - 1) * 2 > iarcs - narcs - 1)
+ { nodlft--;
+ return;
+ }
+ if ((iarcs - narcs + nonsor - ktl - 1) / nodlft - nonsor + 1 >= 0)
+ k = nonsor;
+ else
+ { nupbnd = (iarcs - narcs - nodlft) / nodlft * 2;
+L40: k = iran(csa, 1, nupbnd);
+ if (nodlft == 1) k = iarcs - narcs;
+ if ((nodlft - 1) * (nonsor - 1) < iarcs - narcs - k) goto L40;
+ }
+ nodlft--;
+ for (j = 1; j <= k; j++)
+ { nn = iran(csa, 1, ktl);
+ ktl--;
+ for (l = nftsor; l <= nodes; l++)
+ { if (iflag[l] != 1)
+ { nn--;
+ if (nn == 0) goto L70;
+ }
+ }
+ return;
+L70: iflag[l] = 1;
+ icap = itsup;
+ jcap = iran(csa, 1, 100);
+ if (jcap <= ipcap)
+ icap = iran(csa, mincap, maxcap);
+ icost = iran(csa, mincst, maxcst);
+ if (G == NULL)
+ xprintf("%6s%6d%6d%2s%10d%10d\n", "", it, l, "", icost,
+ icap);
+ else
+ { glp_arc *a = glp_add_arc(G, it, l);
+ if (a_cap >= 0)
+ { double temp = (double)icap;
+ memcpy((char *)a->data + a_cap, &temp, sizeof(double));
+ }
+ if (a_cost >= 0)
+ { double temp = (double)icost;
+ memcpy((char *)a->data + a_cost, &temp, sizeof(double));
+ }
+ }
+ narcs++;
+ }
+ return;
+}
+
+/***********************************************************************
+* The routine assign generate assignment problems. It defines the unit
+* supplies, builds a skeleton, then calls pickj to create the arcs. */
+
+static void assign(struct csa *csa)
+{ int i, it, nn, l, ll, icost;
+ if (G == NULL)
+ xprintf("SUPPLY\n");
+ for (i = 1; i <= nsorc; i++)
+ { isup[i] = 1;
+ iflag[i] = 0;
+ if (G == NULL)
+ xprintf("%6s%6d%18s%10d\n", "", i, "", isup[i]);
+ else
+ { if (v_rhs >= 0)
+ { double temp = (double)isup[i];
+ glp_vertex *v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &temp, sizeof(double));
+ }
+ }
+ }
+ if (G == NULL)
+ xprintf("ARCS\n");
+ for (i = nfsink; i <= nodes; i++)
+ ipred[i] = 1;
+ for (it = 1; it <= nsorc; it++)
+ { for (i = nfsink; i <= nodes; i++)
+ iflag[i] = 0;
+ ktl = nsink - 1;
+ nn = iran(csa, 1, nsink - it + 1);
+ for (l = 1; l <= nsorc; l++)
+ { if (iflag[l] != 1)
+ { nn--;
+ if (nn == 0) break;
+ }
+ }
+ narcs++;
+ ll = nsorc + l;
+ icost = iran(csa, mincst, maxcst);
+ if (G == NULL)
+ xprintf("%6s%6d%6d%2s%10d%10d\n", "", it, ll, "", icost,
+ isup[1]);
+ else
+ { glp_arc *a = glp_add_arc(G, it, ll);
+ if (a_cap >= 0)
+ { double temp = (double)isup[1];
+ memcpy((char *)a->data + a_cap, &temp, sizeof(double));
+ }
+ if (a_cost >= 0)
+ { double temp = (double)icost;
+ memcpy((char *)a->data + a_cost, &temp, sizeof(double));
+ }
+ }
+ iflag[l] = 1;
+ iflag[ll] = 1;
+ pickj(csa, it);
+ }
+ return;
+}
+
+/***********************************************************************
+* Portable congruential (uniform) random number generator:
+*
+* next_value = ((7**5) * previous_value) modulo ((2**31)-1)
+*
+* This generator consists of three routines:
+*
+* (1) setran - initializes constants and seed
+* (2) iran - generates an integer random number
+* (3) rran - generates a real random number
+*
+* The generator requires a machine with at least 32 bits of precision.
+* The seed (iseed) must be in the range [1,(2**31)-1]. */
+
+static void setran(struct csa *csa, int iseed)
+{ xassert(iseed >= 1);
+ mult = 16807;
+ modul = 2147483647;
+ i15 = 1 << 15;
+ i16 = 1 << 16;
+ jran = iseed;
+ return;
+}
+
+/***********************************************************************
+* The routine iran generates an integer random number between ilow and
+* ihigh. If ilow > ihigh then iran returns ihigh. */
+
+static int iran(struct csa *csa, int ilow, int ihigh)
+{ int ixhi, ixlo, ixalo, leftlo, ixahi, ifulhi, irtlo, iover,
+ irthi, j;
+ ixhi = jran / i16;
+ ixlo = jran - ixhi * i16;
+ ixalo = ixlo * mult;
+ leftlo = ixalo / i16;
+ ixahi = ixhi * mult;
+ ifulhi = ixahi + leftlo;
+ irtlo = ixalo - leftlo * i16;
+ iover = ifulhi / i15;
+ irthi = ifulhi - iover * i15;
+ jran = ((irtlo - modul) + irthi * i16) + iover;
+ if (jran < 0) jran += modul;
+ j = ihigh - ilow + 1;
+ if (j > 0)
+ return jran % j + ilow;
+ else
+ return ihigh;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_netgen_prob - Klingman's standard network problem instance
+*
+* SYNOPSIS
+*
+* void glp_netgen_prob(int nprob, int parm[1+15]);
+*
+* DESCRIPTION
+*
+* The routine glp_netgen_prob provides the set of parameters for
+* Klingman's network problem generator (see the routine glp_netgen),
+* which describe a standard network problem instance.
+*
+* The parameter nprob (101 <= nprob <= 150) specifies the problem
+* instance number.
+*
+* The array parm contains description of the network, provided by the
+* routine. (For detailed description of these parameters see comments
+* to the routine glp_netgen.)
+*
+* PROBLEM CHARACTERISTICS
+*
+* The table below shows characteristics of Klingman's standard network
+* problem instances.
+*
+* Problem Nodes Arcs Optimum
+* ------- ----- ----- ----------
+* 101 5000 25336 6191726
+* 102 5000 25387 72337144
+* 103 5000 25355 218947553
+* 104 5000 25344 -19100371
+* 105 5000 25332 31192578
+* 106 5000 12870 4314276
+* 107 5000 37832 7393769
+* 108 5000 50309 8405738
+* 109 5000 75299 9190300
+* 110 5000 12825 8975048
+* 111 5000 37828 4747532
+* 112 5000 50325 4012671
+* 113 5000 75318 2979725
+* 114 5000 26514 5821181
+* 115 5000 25962 6353310
+* 116 5000 25304 5915426
+* 117 5000 12816 4420560
+* 118 5000 37797 7045842
+* 119 5000 50301 7724179
+* 120 5000 75330 8455200
+* 121 5000 25000 66366360
+* 122 5000 25000 30997529
+* 123 5000 25000 23388777
+* 124 5000 25000 17803443
+* 125 5000 25000 14119622
+* 126 5000 12500 18802218
+* 127 5000 37500 27674647
+* 128 5000 50000 30906194
+* 129 5000 75000 40905209
+* 130 5000 12500 38939608
+* 131 5000 37500 16752978
+* 132 5000 50000 13302951
+* 133 5000 75000 9830268
+* 134 1000 25000 3804874
+* 135 2500 25000 11729616
+* 136 7500 25000 33318101
+* 137 10000 25000 46426030
+* 138 5000 25000 60710879
+* 139 5000 25000 32729682
+* 140 5000 25000 27183831
+* 141 5000 25000 19963286
+* 142 5000 25000 20243457
+* 143 5000 25000 18586777
+* 144 5000 25000 2504591
+* 145 5000 25000 215956138
+* 146 5000 25000 2253113811
+* 147 5000 25000 -427908373
+* 148 5000 25000 -92965318
+* 149 5000 25000 86051224
+* 150 5000 25000 619314919 */
+
+static const int data[50][1+15] =
+{ { 0, 13502460, 101, 5000, 2500, 2500, 25000,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 4281922, 102, 5000, 2500, 2500, 25000,
+ 1, 100, 2500000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 44820113, 103, 5000, 2500, 2500, 25000,
+ 1, 100, 6250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 13450451, 104, 5000, 2500, 2500, 25000,
+ -100, -1, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 14719436, 105, 5000, 2500, 2500, 25000,
+ 101, 200, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 17365786, 106, 5000, 2500, 2500, 12500,
+ 1, 100, 125000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 19540113, 107, 5000, 2500, 2500, 37500,
+ 1, 100, 375000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 19560313, 108, 5000, 2500, 2500, 50000,
+ 1, 100, 500000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 2403509, 109, 5000, 2500, 2500, 75000,
+ 1, 100, 750000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 92480414, 110, 5000, 2500, 2500, 12500,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 4230140, 111, 5000, 2500, 2500, 37500,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 10032490, 112, 5000, 2500, 2500, 50000,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 17307474, 113, 5000, 2500, 2500, 75000,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 4925114, 114, 5000, 500, 4500, 25000,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 19842704, 115, 5000, 1500, 3500, 25000,
+ 1, 100, 250000, 0, 0, 0, 100, 1, 1000
+ },
+ { 0, 88392060, 116, 5000, 2500, 2500, 25000,
+ 1, 100, 250000, 0, 0, 0, 0, 1, 1000
+ },
+ { 0, 12904407, 117, 5000, 2500, 2500, 12500,
+ 1, 100, 125000, 0, 0, 0, 0, 1, 1000
+ },
+ { 0, 11811811, 118, 5000, 2500, 2500, 37500,
+ 1, 100, 375000, 0, 0, 0, 0, 1, 1000
+ },
+ { 0, 90023593, 119, 5000, 2500, 2500, 50000,
+ 1, 100, 500000, 0, 0, 0, 0, 1, 1000
+ },
+ { 0, 93028922, 120, 5000, 2500, 2500, 75000,
+ 1, 100, 750000, 0, 0, 0, 0, 1, 1000
+ },
+ { 0, 72707401, 121, 5000, 50, 50, 25000,
+ 1, 100, 250000, 50, 50, 0, 100, 1, 1000
+ },
+ { 0, 93040771, 122, 5000, 250, 250, 25000,
+ 1, 100, 250000, 250, 250, 0, 100, 1, 1000
+ },
+ { 0, 70220611, 123, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 52774811, 124, 5000, 1000, 1000, 25000,
+ 1, 100, 250000, 1000, 1000, 0, 100, 1, 1000
+ },
+ { 0, 22492311, 125, 5000, 1500, 1500, 25000,
+ 1, 100, 250000, 1500, 1500, 0, 100, 1, 1000
+ },
+ { 0, 35269337, 126, 5000, 500, 500, 12500,
+ 1, 100, 125000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 30140502, 127, 5000, 500, 500, 37500,
+ 1, 100, 375000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 49205455, 128, 5000, 500, 500, 50000,
+ 1, 100, 500000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 42958341, 129, 5000, 500, 500, 75000,
+ 1, 100, 750000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 25440925, 130, 5000, 500, 500, 12500,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 75294924, 131, 5000, 500, 500, 37500,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 4463965, 132, 5000, 500, 500, 50000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 13390427, 133, 5000, 500, 500, 75000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 95250971, 134, 1000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 54830522, 135, 2500, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 520593, 136, 7500, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 52900925, 137, 10000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 22603395, 138, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 50
+ },
+ { 0, 55253099, 139, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 250
+ },
+ { 0, 75357001, 140, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 500
+ },
+ { 0, 10072459, 141, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 2500
+ },
+ { 0, 55728492, 142, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 100, 1, 5000
+ },
+ { 0, 593043, 143, 5000, 500, 500, 25000,
+ 1, 100, 250000, 500, 500, 0, 0, 1, 1000
+ },
+ { 0, 94236572, 144, 5000, 500, 500, 25000,
+ 1, 10, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 94882955, 145, 5000, 500, 500, 25000,
+ 1, 1000, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 48489922, 146, 5000, 500, 500, 25000,
+ 1, 10000, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 75578374, 147, 5000, 500, 500, 25000,
+ -100, -1, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 44821152, 148, 5000, 500, 500, 25000,
+ -50, 49, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 45224103, 149, 5000, 500, 500, 25000,
+ 101, 200, 250000, 500, 500, 0, 100, 1, 1000
+ },
+ { 0, 63491741, 150, 5000, 500, 500, 25000,
+ 1001, 1100, 250000, 500, 500, 0, 100, 1, 1000
+ },
+};
+
+void glp_netgen_prob(int nprob, int parm[1+15])
+{ int k;
+ if (!(101 <= nprob && nprob <= 150))
+ xerror("glp_netgen_prob: nprob = %d; invalid problem instance "
+ "number\n", nprob);
+ for (k = 1; k <= 15; k++)
+ parm[k] = data[nprob-101][k];
+ return;
+}
+
+/**********************************************************************/
+
+#if 0
+static int scan(char card[80+1], int pos, int len)
+{ char buf[10+1];
+ memcpy(buf, &card[pos-1], len);
+ buf[len] = '\0';
+ return atoi(buf);
+}
+
+int main(void)
+{ int parm[1+15];
+ char card[80+1];
+ xassert(fgets(card, sizeof(card), stdin) == card);
+ parm[1] = scan(card, 1, 8);
+ parm[2] = scan(card, 9, 8);
+ xassert(fgets(card, sizeof(card), stdin) == card);
+ parm[3] = scan(card, 1, 5);
+ parm[4] = scan(card, 6, 5);
+ parm[5] = scan(card, 11, 5);
+ parm[6] = scan(card, 16, 5);
+ parm[7] = scan(card, 21, 5);
+ parm[8] = scan(card, 26, 5);
+ parm[9] = scan(card, 31, 10);
+ parm[10] = scan(card, 41, 5);
+ parm[11] = scan(card, 46, 5);
+ parm[12] = scan(card, 51, 5);
+ parm[13] = scan(card, 56, 5);
+ parm[14] = scan(card, 61, 10);
+ parm[15] = scan(card, 71, 10);
+ glp_netgen(NULL, 0, 0, 0, parm);
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/npp.c b/test/monniaux/glpk-4.65/src/api/npp.c
new file mode 100644
index 00000000..a7ae07c1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/npp.c
@@ -0,0 +1,143 @@
+/* npp.c (LP/MIP preprocessing) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+glp_prep *glp_npp_alloc_wksp(void)
+{ /* allocate the preprocessor workspace */
+ glp_prep *prep;
+ prep = npp_create_wksp();
+ return prep;
+}
+
+void glp_npp_load_prob(glp_prep *prep, glp_prob *P, int sol, int names)
+{ /* load original problem instance */
+ if (prep->sol != 0)
+ xerror("glp_npp_load_prob: invalid call sequence (original ins"
+ "tance already loaded)\n");
+ if (!(sol == GLP_SOL || sol == GLP_IPT || sol == GLP_MIP))
+ xerror("glp_npp_load_prob: sol = %d; invalid parameter\n",
+ sol);
+ if (!(names == GLP_ON || names == GLP_OFF))
+ xerror("glp_npp_load_prob: names = %d; invalid parameter\n",
+ names);
+ npp_load_prob(prep, P, names, sol, GLP_OFF);
+ return;
+}
+
+int glp_npp_preprocess1(glp_prep *prep, int hard)
+{ /* perform basic LP/MIP preprocessing */
+ if (prep->sol == 0)
+ xerror("glp_npp_preprocess1: invalid call sequence (original i"
+ "nstance not loaded yet)\n");
+ if (prep->pool == NULL)
+ xerror("glp_npp_preprocess1: invalid call sequence (preprocess"
+ "ing already finished)\n");
+ if (!(hard == GLP_ON || hard == GLP_OFF))
+ xerror("glp_npp_preprocess1: hard = %d; invalid parameter\n",
+ hard);
+ return npp_process_prob(prep, hard);
+}
+
+void glp_npp_build_prob(glp_prep *prep, glp_prob *Q)
+{ /* build resultant problem instance */
+ if (prep->sol == 0)
+ xerror("glp_npp_build_prob: invalid call sequence (original in"
+ "stance not loaded yet)\n");
+ if (prep->pool == NULL)
+ xerror("glp_npp_build_prob: invalid call sequence (resultant i"
+ "nstance already built)\n");
+ npp_build_prob(prep, Q);
+ return;
+}
+
+void glp_npp_postprocess(glp_prep *prep, glp_prob *Q)
+{ /* postprocess solution to resultant problem */
+ if (prep->pool != NULL)
+ xerror("glp_npp_postprocess: invalid call sequence (resultant "
+ "instance not built yet)\n");
+ if (!(prep->m == Q->m && prep->n == Q->n && prep->nnz == Q->nnz))
+ xerror("glp_npp_postprocess: resultant instance mismatch\n");
+ switch (prep->sol)
+ { case GLP_SOL:
+ if (glp_get_status(Q) != GLP_OPT)
+ xerror("glp_npp_postprocess: unable to recover non-optim"
+ "al basic solution\n");
+ break;
+ case GLP_IPT:
+ if (glp_ipt_status(Q) != GLP_OPT)
+ xerror("glp_npp_postprocess: unable to recover non-optim"
+ "al interior-point solution\n");
+ break;
+ case GLP_MIP:
+ if (!(glp_mip_status(Q) == GLP_OPT || glp_mip_status(Q) ==
+ GLP_FEAS))
+ xerror("glp_npp_postprocess: unable to recover integer n"
+ "on-feasible solution\n");
+ break;
+ default:
+ xassert(prep != prep);
+ }
+ npp_postprocess(prep, Q);
+ return;
+}
+
+void glp_npp_obtain_sol(glp_prep *prep, glp_prob *P)
+{ /* obtain solution to original problem */
+ if (prep->pool != NULL)
+ xerror("glp_npp_obtain_sol: invalid call sequence (resultant i"
+ "nstance not built yet)\n");
+ switch (prep->sol)
+ { case GLP_SOL:
+ if (prep->p_stat == 0 || prep->d_stat == 0)
+ xerror("glp_npp_obtain_sol: invalid call sequence (basic"
+ " solution not provided yet)\n");
+ break;
+ case GLP_IPT:
+ if (prep->t_stat == 0)
+ xerror("glp_npp_obtain_sol: invalid call sequence (inter"
+ "ior-point solution not provided yet)\n");
+ break;
+ case GLP_MIP:
+ if (prep->i_stat == 0)
+ xerror("glp_npp_obtain_sol: invalid call sequence (MIP s"
+ "olution not provided yet)\n");
+ break;
+ default:
+ xassert(prep != prep);
+ }
+ if (!(prep->orig_dir == P->dir && prep->orig_m == P->m &&
+ prep->orig_n == P->n && prep->orig_nnz == P->nnz))
+ xerror("glp_npp_obtain_sol: original instance mismatch\n");
+ npp_unload_sol(prep, P);
+ return;
+}
+
+void glp_npp_free_wksp(glp_prep *prep)
+{ /* free the preprocessor workspace */
+ npp_delete_wksp(prep);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/pript.c b/test/monniaux/glpk-4.65/src/api/pript.c
new file mode 100644
index 00000000..f123089d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/pript.c
@@ -0,0 +1,186 @@
+/* pript.c (write interior-point solution in printable format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+int glp_print_ipt(glp_prob *P, const char *fname)
+{ /* write interior-point solution in printable format */
+ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, t, ae_ind, re_ind, ret;
+ double ae_max, re_max;
+ xprintf("Writing interior-point solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "%-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name);
+ xfprintf(fp, "%-12s%d\n", "Rows:", P->m);
+ xfprintf(fp, "%-12s%d\n", "Columns:", P->n);
+ xfprintf(fp, "%-12s%d\n", "Non-zeros:", P->nnz);
+ t = glp_ipt_status(P);
+ xfprintf(fp, "%-12s%s\n", "Status:",
+ t == GLP_OPT ? "OPTIMAL" :
+ t == GLP_UNDEF ? "UNDEFINED" :
+ t == GLP_INFEAS ? "INFEASIBLE (INTERMEDIATE)" :
+ t == GLP_NOFEAS ? "INFEASIBLE (FINAL)" : "???");
+ xfprintf(fp, "%-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->ipt_obj,
+ P->dir == GLP_MIN ? "MINimum" :
+ P->dir == GLP_MAX ? "MAXimum" : "???");
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Row name Activity Lower bound "
+ " Upper bound Marginal\n");
+ xfprintf(fp, "------ ------------ ------------- ------------- "
+ "------------- -------------\n");
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ xfprintf(fp, "%6d ", i);
+ if (row->name == NULL || strlen(row->name) <= 12)
+ xfprintf(fp, "%-12s ", row->name == NULL ? "" : row->name);
+ else
+ xfprintf(fp, "%s\n%20s", row->name, "");
+ xfprintf(fp, "%3s", "");
+ xfprintf(fp, "%13.6g ",
+ fabs(row->pval) <= 1e-9 ? 0.0 : row->pval);
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", row->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (row->type == GLP_UP || row->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", row->ub);
+ else
+ xfprintf(fp, "%13s ", row->type == GLP_FX ? "=" : "");
+ if (fabs(row->dval) <= 1e-9)
+ xfprintf(fp, "%13s", "< eps");
+ else
+ xfprintf(fp, "%13.6g ", row->dval);
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Column name Activity Lower bound "
+ " Upper bound Marginal\n");
+ xfprintf(fp, "------ ------------ ------------- ------------- "
+ "------------- -------------\n");
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ xfprintf(fp, "%6d ", j);
+ if (col->name == NULL || strlen(col->name) <= 12)
+ xfprintf(fp, "%-12s ", col->name == NULL ? "" : col->name);
+ else
+ xfprintf(fp, "%s\n%20s", col->name, "");
+ xfprintf(fp, "%3s", "");
+ xfprintf(fp, "%13.6g ",
+ fabs(col->pval) <= 1e-9 ? 0.0 : col->pval);
+ if (col->type == GLP_LO || col->type == GLP_DB ||
+ col->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", col->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (col->type == GLP_UP || col->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", col->ub);
+ else
+ xfprintf(fp, "%13s ", col->type == GLP_FX ? "=" : "");
+ if (fabs(col->dval) <= 1e-9)
+ xfprintf(fp, "%13s", "< eps");
+ else
+ xfprintf(fp, "%13.6g ", col->dval);
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, "Karush-Kuhn-Tucker optimality conditions:\n");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_IPT, GLP_KKT_PE, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PE: max.abs.err = %.2e on row %d\n",
+ ae_max, ae_ind);
+ xfprintf(fp, " max.rel.err = %.2e on row %d\n",
+ re_max, re_ind);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "PRIMAL SOLUTION IS WRONG");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_IPT, GLP_KKT_PB, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PB: max.abs.err = %.2e on %s %d\n",
+ ae_max, ae_ind <= P->m ? "row" : "column",
+ ae_ind <= P->m ? ae_ind : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on %s %d\n",
+ re_max, re_ind <= P->m ? "row" : "column",
+ re_ind <= P->m ? re_ind : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "PRIMAL SOLUTION IS INFEASIBL"
+ "E");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_IPT, GLP_KKT_DE, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.DE: max.abs.err = %.2e on column %d\n",
+ ae_max, ae_ind == 0 ? 0 : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on column %d\n",
+ re_max, re_ind == 0 ? 0 : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "DUAL SOLUTION IS WRONG");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_IPT, GLP_KKT_DB, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.DB: max.abs.err = %.2e on %s %d\n",
+ ae_max, ae_ind <= P->m ? "row" : "column",
+ ae_ind <= P->m ? ae_ind : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on %s %d\n",
+ re_max, re_ind <= P->m ? "row" : "column",
+ re_ind <= P->m ? re_ind : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "DUAL SOLUTION IS INFEASIBLE")
+ ;
+ xfprintf(fp, "\n");
+ xfprintf(fp, "End of output\n");
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prmip.c b/test/monniaux/glpk-4.65/src/api/prmip.c
new file mode 100644
index 00000000..885ed82a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prmip.c
@@ -0,0 +1,155 @@
+/* prmip.c (write MIP solution in printable format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+int glp_print_mip(glp_prob *P, const char *fname)
+{ /* write MIP solution in printable format */
+ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, t, ae_ind, re_ind, ret;
+ double ae_max, re_max;
+ xprintf("Writing MIP solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "%-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name);
+ xfprintf(fp, "%-12s%d\n", "Rows:", P->m);
+ xfprintf(fp, "%-12s%d (%d integer, %d binary)\n", "Columns:",
+ P->n, glp_get_num_int(P), glp_get_num_bin(P));
+ xfprintf(fp, "%-12s%d\n", "Non-zeros:", P->nnz);
+ t = glp_mip_status(P);
+ xfprintf(fp, "%-12s%s\n", "Status:",
+ t == GLP_OPT ? "INTEGER OPTIMAL" :
+ t == GLP_FEAS ? "INTEGER NON-OPTIMAL" :
+ t == GLP_NOFEAS ? "INTEGER EMPTY" :
+ t == GLP_UNDEF ? "INTEGER UNDEFINED" : "???");
+ xfprintf(fp, "%-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->mip_obj,
+ P->dir == GLP_MIN ? "MINimum" :
+ P->dir == GLP_MAX ? "MAXimum" : "???");
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Row name Activity Lower bound "
+ " Upper bound\n");
+ xfprintf(fp, "------ ------------ ------------- ------------- "
+ "-------------\n");
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ xfprintf(fp, "%6d ", i);
+ if (row->name == NULL || strlen(row->name) <= 12)
+ xfprintf(fp, "%-12s ", row->name == NULL ? "" : row->name);
+ else
+ xfprintf(fp, "%s\n%20s", row->name, "");
+ xfprintf(fp, "%3s", "");
+ xfprintf(fp, "%13.6g ",
+ fabs(row->mipx) <= 1e-9 ? 0.0 : row->mipx);
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", row->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (row->type == GLP_UP || row->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", row->ub);
+ else
+ xfprintf(fp, "%13s ", row->type == GLP_FX ? "=" : "");
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Column name Activity Lower bound "
+ " Upper bound\n");
+ xfprintf(fp, "------ ------------ ------------- ------------- "
+ "-------------\n");
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ xfprintf(fp, "%6d ", j);
+ if (col->name == NULL || strlen(col->name) <= 12)
+ xfprintf(fp, "%-12s ", col->name == NULL ? "" : col->name);
+ else
+ xfprintf(fp, "%s\n%20s", col->name, "");
+ xfprintf(fp, "%s ",
+ col->kind == GLP_CV ? " " :
+ col->kind == GLP_IV ? "*" : "?");
+ xfprintf(fp, "%13.6g ",
+ fabs(col->mipx) <= 1e-9 ? 0.0 : col->mipx);
+ if (col->type == GLP_LO || col->type == GLP_DB ||
+ col->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", col->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (col->type == GLP_UP || col->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", col->ub);
+ else
+ xfprintf(fp, "%13s ", col->type == GLP_FX ? "=" : "");
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, "Integer feasibility conditions:\n");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_MIP, GLP_KKT_PE, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PE: max.abs.err = %.2e on row %d\n",
+ ae_max, ae_ind);
+ xfprintf(fp, " max.rel.err = %.2e on row %d\n",
+ re_max, re_ind);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "SOLUTION IS WRONG");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_MIP, GLP_KKT_PB, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PB: max.abs.err = %.2e on %s %d\n",
+ ae_max, ae_ind <= P->m ? "row" : "column",
+ ae_ind <= P->m ? ae_ind : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on %s %d\n",
+ re_max, re_ind <= P->m ? "row" : "column",
+ re_ind <= P->m ? re_ind : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "SOLUTION IS INFEASIBLE");
+ xfprintf(fp, "\n");
+ xfprintf(fp, "End of output\n");
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob.h b/test/monniaux/glpk-4.65/src/api/prob.h
new file mode 100644
index 00000000..cc9389b5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob.h
@@ -0,0 +1,286 @@
+/* prob.h (LP/MIP problem object) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef PROB_H
+#define PROB_H
+
+#include "avl.h"
+#include "bfd.h"
+#include "dmp.h"
+#if 1 /* 28/III-2016 */
+#define GLP_UNDOC 1
+#endif
+#include "glpk.h"
+
+typedef struct GLPROW GLPROW;
+typedef struct GLPCOL GLPCOL;
+typedef struct GLPAIJ GLPAIJ;
+
+#if 0 /* 04/IV-2016 */
+#define GLP_PROB_MAGIC 0xD7D9D6C2
+#endif
+
+struct glp_prob
+{ /* LP/MIP problem object */
+#if 0 /* 04/IV-2016 */
+ unsigned magic;
+ /* magic value used for debugging */
+#endif
+ DMP *pool;
+ /* memory pool to store problem object components */
+ glp_tree *tree;
+ /* pointer to the search tree; set by the MIP solver when this
+ object is used in the tree as a core MIP object */
+#if 0 /* 08/III-2014 */
+ void *parms;
+ /* reserved for backward compatibility */
+#endif
+ /*--------------------------------------------------------------*/
+ /* LP/MIP data */
+ char *name;
+ /* problem name (1 to 255 chars); NULL means no name is assigned
+ to the problem */
+ char *obj;
+ /* objective function name (1 to 255 chars); NULL means no name
+ is assigned to the objective function */
+ int dir;
+ /* optimization direction flag (objective "sense"):
+ GLP_MIN - minimization
+ GLP_MAX - maximization */
+ double c0;
+ /* constant term of the objective function ("shift") */
+ int m_max;
+ /* length of the array of rows (enlarged automatically) */
+ int n_max;
+ /* length of the array of columns (enlarged automatically) */
+ int m;
+ /* number of rows, 0 <= m <= m_max */
+ int n;
+ /* number of columns, 0 <= n <= n_max */
+ int nnz;
+ /* number of non-zero constraint coefficients, nnz >= 0 */
+ GLPROW **row; /* GLPROW *row[1+m_max]; */
+ /* row[i], 1 <= i <= m, is a pointer to i-th row */
+ GLPCOL **col; /* GLPCOL *col[1+n_max]; */
+ /* col[j], 1 <= j <= n, is a pointer to j-th column */
+ AVL *r_tree;
+ /* row index to find rows by their names; NULL means this index
+ does not exist */
+ AVL *c_tree;
+ /* column index to find columns by their names; NULL means this
+ index does not exist */
+ /*--------------------------------------------------------------*/
+ /* basis factorization (LP) */
+ int valid;
+ /* the factorization is valid only if this flag is set */
+ int *head; /* int head[1+m_max]; */
+ /* basis header (valid only if the factorization is valid);
+ head[i] = k is the ordinal number of auxiliary (1 <= k <= m)
+ or structural (m+1 <= k <= m+n) variable which corresponds to
+ i-th basic variable xB[i], 1 <= i <= m */
+#if 0 /* 08/III-2014 */
+ glp_bfcp *bfcp;
+ /* basis factorization control parameters; may be NULL */
+#endif
+ BFD *bfd; /* BFD bfd[1:m,1:m]; */
+ /* basis factorization driver; may be NULL */
+ /*--------------------------------------------------------------*/
+ /* basic solution (LP) */
+ int pbs_stat;
+ /* primal basic solution status:
+ GLP_UNDEF - primal solution is undefined
+ GLP_FEAS - primal solution is feasible
+ GLP_INFEAS - primal solution is infeasible
+ GLP_NOFEAS - no primal feasible solution exists */
+ int dbs_stat;
+ /* dual basic solution status:
+ GLP_UNDEF - dual solution is undefined
+ GLP_FEAS - dual solution is feasible
+ GLP_INFEAS - dual solution is infeasible
+ GLP_NOFEAS - no dual feasible solution exists */
+ double obj_val;
+ /* objective function value */
+ int it_cnt;
+ /* simplex method iteration count; increases by one on performing
+ one simplex iteration */
+ int some;
+ /* ordinal number of some auxiliary or structural variable having
+ certain property, 0 <= some <= m+n */
+ /*--------------------------------------------------------------*/
+ /* interior-point solution (LP) */
+ int ipt_stat;
+ /* interior-point solution status:
+ GLP_UNDEF - interior solution is undefined
+ GLP_OPT - interior solution is optimal
+ GLP_INFEAS - interior solution is infeasible
+ GLP_NOFEAS - no feasible solution exists */
+ double ipt_obj;
+ /* objective function value */
+ /*--------------------------------------------------------------*/
+ /* integer solution (MIP) */
+ int mip_stat;
+ /* integer solution status:
+ GLP_UNDEF - integer solution is undefined
+ GLP_OPT - integer solution is optimal
+ GLP_FEAS - integer solution is feasible
+ GLP_NOFEAS - no integer solution exists */
+ double mip_obj;
+ /* objective function value */
+};
+
+struct GLPROW
+{ /* LP/MIP row (auxiliary variable) */
+ int i;
+ /* ordinal number (1 to m) assigned to this row */
+ char *name;
+ /* row name (1 to 255 chars); NULL means no name is assigned to
+ this row */
+ AVLNODE *node;
+ /* pointer to corresponding node in the row index; NULL means
+ that either the row index does not exist or this row has no
+ name assigned */
+#if 1 /* 20/IX-2008 */
+ int level;
+ unsigned char origin;
+ unsigned char klass;
+#endif
+ int type;
+ /* type of the auxiliary variable:
+ GLP_FR - free variable
+ GLP_LO - variable with lower bound
+ GLP_UP - variable with upper bound
+ GLP_DB - double-bounded variable
+ GLP_FX - fixed variable */
+ double lb; /* non-scaled */
+ /* lower bound; if the row has no lower bound, lb is zero */
+ double ub; /* non-scaled */
+ /* upper bound; if the row has no upper bound, ub is zero */
+ /* if the row type is GLP_FX, ub is equal to lb */
+ GLPAIJ *ptr; /* non-scaled */
+ /* pointer to doubly linked list of constraint coefficients which
+ are placed in this row */
+ double rii;
+ /* diagonal element r[i,i] of scaling matrix R for this row;
+ if the scaling is not used, r[i,i] is 1 */
+ int stat;
+ /* status of the auxiliary variable:
+ GLP_BS - basic variable
+ GLP_NL - non-basic variable on lower bound
+ GLP_NU - non-basic variable on upper bound
+ GLP_NF - non-basic free variable
+ GLP_NS - non-basic fixed variable */
+ int bind;
+ /* if the auxiliary variable is basic, head[bind] refers to this
+ row, otherwise, bind is 0; this attribute is valid only if the
+ basis factorization is valid */
+ double prim; /* non-scaled */
+ /* primal value of the auxiliary variable in basic solution */
+ double dual; /* non-scaled */
+ /* dual value of the auxiliary variable in basic solution */
+ double pval; /* non-scaled */
+ /* primal value of the auxiliary variable in interior solution */
+ double dval; /* non-scaled */
+ /* dual value of the auxiliary variable in interior solution */
+ double mipx; /* non-scaled */
+ /* primal value of the auxiliary variable in integer solution */
+};
+
+struct GLPCOL
+{ /* LP/MIP column (structural variable) */
+ int j;
+ /* ordinal number (1 to n) assigned to this column */
+ char *name;
+ /* column name (1 to 255 chars); NULL means no name is assigned
+ to this column */
+ AVLNODE *node;
+ /* pointer to corresponding node in the column index; NULL means
+ that either the column index does not exist or the column has
+ no name assigned */
+ int kind;
+ /* kind of the structural variable:
+ GLP_CV - continuous variable
+ GLP_IV - integer or binary variable */
+ int type;
+ /* type of the structural variable:
+ GLP_FR - free variable
+ GLP_LO - variable with lower bound
+ GLP_UP - variable with upper bound
+ GLP_DB - double-bounded variable
+ GLP_FX - fixed variable */
+ double lb; /* non-scaled */
+ /* lower bound; if the column has no lower bound, lb is zero */
+ double ub; /* non-scaled */
+ /* upper bound; if the column has no upper bound, ub is zero */
+ /* if the column type is GLP_FX, ub is equal to lb */
+ double coef; /* non-scaled */
+ /* objective coefficient at the structural variable */
+ GLPAIJ *ptr; /* non-scaled */
+ /* pointer to doubly linked list of constraint coefficients which
+ are placed in this column */
+ double sjj;
+ /* diagonal element s[j,j] of scaling matrix S for this column;
+ if the scaling is not used, s[j,j] is 1 */
+ int stat;
+ /* status of the structural variable:
+ GLP_BS - basic variable
+ GLP_NL - non-basic variable on lower bound
+ GLP_NU - non-basic variable on upper bound
+ GLP_NF - non-basic free variable
+ GLP_NS - non-basic fixed variable */
+ int bind;
+ /* if the structural variable is basic, head[bind] refers to
+ this column; otherwise, bind is 0; this attribute is valid only
+ if the basis factorization is valid */
+ double prim; /* non-scaled */
+ /* primal value of the structural variable in basic solution */
+ double dual; /* non-scaled */
+ /* dual value of the structural variable in basic solution */
+ double pval; /* non-scaled */
+ /* primal value of the structural variable in interior solution */
+ double dval; /* non-scaled */
+ /* dual value of the structural variable in interior solution */
+ double mipx; /* non-scaled */
+ /* primal value of the structural variable in integer solution */
+};
+
+struct GLPAIJ
+{ /* constraint coefficient a[i,j] */
+ GLPROW *row;
+ /* pointer to row, where this coefficient is placed */
+ GLPCOL *col;
+ /* pointer to column, where this coefficient is placed */
+ double val;
+ /* numeric (non-zero) value of this coefficient */
+ GLPAIJ *r_prev;
+ /* pointer to previous coefficient in the same row */
+ GLPAIJ *r_next;
+ /* pointer to next coefficient in the same row */
+ GLPAIJ *c_prev;
+ /* pointer to previous coefficient in the same column */
+ GLPAIJ *c_next;
+ /* pointer to next coefficient in the same column */
+};
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob1.c b/test/monniaux/glpk-4.65/src/api/prob1.c
new file mode 100644
index 00000000..6afad442
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob1.c
@@ -0,0 +1,1588 @@
+/* prob1.c (problem creating and modifying routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/* CAUTION: DO NOT CHANGE THE LIMITS BELOW */
+
+#define M_MAX 100000000 /* = 100*10^6 */
+/* maximal number of rows in the problem object */
+
+#define N_MAX 100000000 /* = 100*10^6 */
+/* maximal number of columns in the problem object */
+
+#define NNZ_MAX 500000000 /* = 500*10^6 */
+/* maximal number of constraint coefficients in the problem object */
+
+/***********************************************************************
+* NAME
+*
+* glp_create_prob - create problem object
+*
+* SYNOPSIS
+*
+* glp_prob *glp_create_prob(void);
+*
+* DESCRIPTION
+*
+* The routine glp_create_prob creates a new problem object, which is
+* initially "empty", i.e. has no rows and columns.
+*
+* RETURNS
+*
+* The routine returns a pointer to the object created, which should be
+* used in any subsequent operations on this object. */
+
+static void create_prob(glp_prob *lp)
+#if 0 /* 04/IV-2016 */
+{ lp->magic = GLP_PROB_MAGIC;
+#else
+{
+#endif
+ lp->pool = dmp_create_pool();
+#if 0 /* 08/III-2014 */
+#if 0 /* 17/XI-2009 */
+ lp->cps = xmalloc(sizeof(struct LPXCPS));
+ lpx_reset_parms(lp);
+#else
+ lp->parms = NULL;
+#endif
+#endif
+ lp->tree = NULL;
+#if 0
+ lp->lwa = 0;
+ lp->cwa = NULL;
+#endif
+ /* LP/MIP data */
+ lp->name = NULL;
+ lp->obj = NULL;
+ lp->dir = GLP_MIN;
+ lp->c0 = 0.0;
+ lp->m_max = 100;
+ lp->n_max = 200;
+ lp->m = lp->n = 0;
+ lp->nnz = 0;
+ lp->row = xcalloc(1+lp->m_max, sizeof(GLPROW *));
+ lp->col = xcalloc(1+lp->n_max, sizeof(GLPCOL *));
+ lp->r_tree = lp->c_tree = NULL;
+ /* basis factorization */
+ lp->valid = 0;
+ lp->head = xcalloc(1+lp->m_max, sizeof(int));
+#if 0 /* 08/III-2014 */
+ lp->bfcp = NULL;
+#endif
+ lp->bfd = NULL;
+ /* basic solution (LP) */
+ lp->pbs_stat = lp->dbs_stat = GLP_UNDEF;
+ lp->obj_val = 0.0;
+ lp->it_cnt = 0;
+ lp->some = 0;
+ /* interior-point solution (LP) */
+ lp->ipt_stat = GLP_UNDEF;
+ lp->ipt_obj = 0.0;
+ /* integer solution (MIP) */
+ lp->mip_stat = GLP_UNDEF;
+ lp->mip_obj = 0.0;
+ return;
+}
+
+glp_prob *glp_create_prob(void)
+{ glp_prob *lp;
+ lp = xmalloc(sizeof(glp_prob));
+ create_prob(lp);
+ return lp;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_prob_name - assign (change) problem name
+*
+* SYNOPSIS
+*
+* void glp_set_prob_name(glp_prob *lp, const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_set_prob_name assigns a given symbolic name (1 up to
+* 255 characters) to the specified problem object.
+*
+* If the parameter name is NULL or empty string, the routine erases an
+* existing symbolic name of the problem object. */
+
+void glp_set_prob_name(glp_prob *lp, const char *name)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_prob_name: operation not allowed\n");
+ if (lp->name != NULL)
+ { dmp_free_atom(lp->pool, lp->name, strlen(lp->name)+1);
+ lp->name = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int k;
+ for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_set_prob_name: problem name too long\n");
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_set_prob_name: problem name contains invalid"
+ " character(s)\n");
+ }
+ lp->name = dmp_get_atom(lp->pool, strlen(name)+1);
+ strcpy(lp->name, name);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_obj_name - assign (change) objective function name
+*
+* SYNOPSIS
+*
+* void glp_set_obj_name(glp_prob *lp, const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_set_obj_name assigns a given symbolic name (1 up to
+* 255 characters) to the objective function of the specified problem
+* object.
+*
+* If the parameter name is NULL or empty string, the routine erases an
+* existing name of the objective function. */
+
+void glp_set_obj_name(glp_prob *lp, const char *name)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_obj_name: operation not allowed\n");
+ if (lp->obj != NULL)
+ { dmp_free_atom(lp->pool, lp->obj, strlen(lp->obj)+1);
+ lp->obj = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int k;
+ for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_set_obj_name: objective name too long\n");
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_set_obj_name: objective name contains invali"
+ "d character(s)\n");
+ }
+ lp->obj = dmp_get_atom(lp->pool, strlen(name)+1);
+ strcpy(lp->obj, name);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_obj_dir - set (change) optimization direction flag
+*
+* SYNOPSIS
+*
+* void glp_set_obj_dir(glp_prob *lp, int dir);
+*
+* DESCRIPTION
+*
+* The routine glp_set_obj_dir sets (changes) optimization direction
+* flag (i.e. "sense" of the objective function) as specified by the
+* parameter dir:
+*
+* GLP_MIN - minimization;
+* GLP_MAX - maximization. */
+
+void glp_set_obj_dir(glp_prob *lp, int dir)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_obj_dir: operation not allowed\n");
+ if (!(dir == GLP_MIN || dir == GLP_MAX))
+ xerror("glp_set_obj_dir: dir = %d; invalid direction flag\n",
+ dir);
+ lp->dir = dir;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_add_rows - add new rows to problem object
+*
+* SYNOPSIS
+*
+* int glp_add_rows(glp_prob *lp, int nrs);
+*
+* DESCRIPTION
+*
+* The routine glp_add_rows adds nrs rows (constraints) to the specified
+* problem object. New rows are always added to the end of the row list,
+* so the ordinal numbers of existing rows remain unchanged.
+*
+* Being added each new row is initially free (unbounded) and has empty
+* list of the constraint coefficients.
+*
+* RETURNS
+*
+* The routine glp_add_rows returns the ordinal number of the first new
+* row added to the problem object. */
+
+int glp_add_rows(glp_prob *lp, int nrs)
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ int m_new, i;
+ /* determine new number of rows */
+ if (nrs < 1)
+ xerror("glp_add_rows: nrs = %d; invalid number of rows\n",
+ nrs);
+ if (nrs > M_MAX - lp->m)
+ xerror("glp_add_rows: nrs = %d; too many rows\n", nrs);
+ m_new = lp->m + nrs;
+ /* increase the room, if necessary */
+ if (lp->m_max < m_new)
+ { GLPROW **save = lp->row;
+ while (lp->m_max < m_new)
+ { lp->m_max += lp->m_max;
+ xassert(lp->m_max > 0);
+ }
+ lp->row = xcalloc(1+lp->m_max, sizeof(GLPROW *));
+ memcpy(&lp->row[1], &save[1], lp->m * sizeof(GLPROW *));
+ xfree(save);
+ /* do not forget about the basis header */
+ xfree(lp->head);
+ lp->head = xcalloc(1+lp->m_max, sizeof(int));
+ }
+ /* add new rows to the end of the row list */
+ for (i = lp->m+1; i <= m_new; i++)
+ { /* create row descriptor */
+ lp->row[i] = row = dmp_get_atom(lp->pool, sizeof(GLPROW));
+ row->i = i;
+ row->name = NULL;
+ row->node = NULL;
+#if 1 /* 20/IX-2008 */
+ row->level = 0;
+ row->origin = 0;
+ row->klass = 0;
+ if (tree != NULL)
+ { switch (tree->reason)
+ { case 0:
+ break;
+ case GLP_IROWGEN:
+ xassert(tree->curr != NULL);
+ row->level = tree->curr->level;
+ row->origin = GLP_RF_LAZY;
+ break;
+ case GLP_ICUTGEN:
+ xassert(tree->curr != NULL);
+ row->level = tree->curr->level;
+ row->origin = GLP_RF_CUT;
+ break;
+ default:
+ xassert(tree != tree);
+ }
+ }
+#endif
+ row->type = GLP_FR;
+ row->lb = row->ub = 0.0;
+ row->ptr = NULL;
+ row->rii = 1.0;
+ row->stat = GLP_BS;
+#if 0
+ row->bind = -1;
+#else
+ row->bind = 0;
+#endif
+ row->prim = row->dual = 0.0;
+ row->pval = row->dval = 0.0;
+ row->mipx = 0.0;
+ }
+ /* set new number of rows */
+ lp->m = m_new;
+ /* invalidate the basis factorization */
+ lp->valid = 0;
+#if 1
+ if (tree != NULL && tree->reason != 0) tree->reopt = 1;
+#endif
+ /* return the ordinal number of the first row added */
+ return m_new - nrs + 1;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_add_cols - add new columns to problem object
+*
+* SYNOPSIS
+*
+* int glp_add_cols(glp_prob *lp, int ncs);
+*
+* DESCRIPTION
+*
+* The routine glp_add_cols adds ncs columns (structural variables) to
+* the specified problem object. New columns are always added to the end
+* of the column list, so the ordinal numbers of existing columns remain
+* unchanged.
+*
+* Being added each new column is initially fixed at zero and has empty
+* list of the constraint coefficients.
+*
+* RETURNS
+*
+* The routine glp_add_cols returns the ordinal number of the first new
+* column added to the problem object. */
+
+int glp_add_cols(glp_prob *lp, int ncs)
+{ glp_tree *tree = lp->tree;
+ GLPCOL *col;
+ int n_new, j;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_add_cols: operation not allowed\n");
+ /* determine new number of columns */
+ if (ncs < 1)
+ xerror("glp_add_cols: ncs = %d; invalid number of columns\n",
+ ncs);
+ if (ncs > N_MAX - lp->n)
+ xerror("glp_add_cols: ncs = %d; too many columns\n", ncs);
+ n_new = lp->n + ncs;
+ /* increase the room, if necessary */
+ if (lp->n_max < n_new)
+ { GLPCOL **save = lp->col;
+ while (lp->n_max < n_new)
+ { lp->n_max += lp->n_max;
+ xassert(lp->n_max > 0);
+ }
+ lp->col = xcalloc(1+lp->n_max, sizeof(GLPCOL *));
+ memcpy(&lp->col[1], &save[1], lp->n * sizeof(GLPCOL *));
+ xfree(save);
+ }
+ /* add new columns to the end of the column list */
+ for (j = lp->n+1; j <= n_new; j++)
+ { /* create column descriptor */
+ lp->col[j] = col = dmp_get_atom(lp->pool, sizeof(GLPCOL));
+ col->j = j;
+ col->name = NULL;
+ col->node = NULL;
+ col->kind = GLP_CV;
+ col->type = GLP_FX;
+ col->lb = col->ub = 0.0;
+ col->coef = 0.0;
+ col->ptr = NULL;
+ col->sjj = 1.0;
+ col->stat = GLP_NS;
+#if 0
+ col->bind = -1;
+#else
+ col->bind = 0; /* the basis may remain valid */
+#endif
+ col->prim = col->dual = 0.0;
+ col->pval = col->dval = 0.0;
+ col->mipx = 0.0;
+ }
+ /* set new number of columns */
+ lp->n = n_new;
+ /* return the ordinal number of the first column added */
+ return n_new - ncs + 1;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_row_name - assign (change) row name
+*
+* SYNOPSIS
+*
+* void glp_set_row_name(glp_prob *lp, int i, const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_set_row_name assigns a given symbolic name (1 up to
+* 255 characters) to i-th row (auxiliary variable) of the specified
+* problem object.
+*
+* If the parameter name is NULL or empty string, the routine erases an
+* existing name of i-th row. */
+
+void glp_set_row_name(glp_prob *lp, int i, const char *name)
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_row_name: i = %d; row number out of range\n",
+ i);
+ row = lp->row[i];
+ if (tree != NULL && tree->reason != 0)
+ { xassert(tree->curr != NULL);
+ xassert(row->level == tree->curr->level);
+ }
+ if (row->name != NULL)
+ { if (row->node != NULL)
+ { xassert(lp->r_tree != NULL);
+ avl_delete_node(lp->r_tree, row->node);
+ row->node = NULL;
+ }
+ dmp_free_atom(lp->pool, row->name, strlen(row->name)+1);
+ row->name = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int k;
+ for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_set_row_name: i = %d; row name too long\n",
+ i);
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_set_row_name: i = %d: row name contains inva"
+ "lid character(s)\n", i);
+ }
+ row->name = dmp_get_atom(lp->pool, strlen(name)+1);
+ strcpy(row->name, name);
+ if (lp->r_tree != NULL)
+ { xassert(row->node == NULL);
+ row->node = avl_insert_node(lp->r_tree, row->name);
+ avl_set_node_link(row->node, row);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_col_name - assign (change) column name
+*
+* SYNOPSIS
+*
+* void glp_set_col_name(glp_prob *lp, int j, const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_set_col_name assigns a given symbolic name (1 up to
+* 255 characters) to j-th column (structural variable) of the specified
+* problem object.
+*
+* If the parameter name is NULL or empty string, the routine erases an
+* existing name of j-th column. */
+
+void glp_set_col_name(glp_prob *lp, int j, const char *name)
+{ glp_tree *tree = lp->tree;
+ GLPCOL *col;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_col_name: operation not allowed\n");
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_col_name: j = %d; column number out of range\n"
+ , j);
+ col = lp->col[j];
+ if (col->name != NULL)
+ { if (col->node != NULL)
+ { xassert(lp->c_tree != NULL);
+ avl_delete_node(lp->c_tree, col->node);
+ col->node = NULL;
+ }
+ dmp_free_atom(lp->pool, col->name, strlen(col->name)+1);
+ col->name = NULL;
+ }
+ if (!(name == NULL || name[0] == '\0'))
+ { int k;
+ for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_set_col_name: j = %d; column name too long\n"
+ , j);
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_set_col_name: j = %d: column name contains i"
+ "nvalid character(s)\n", j);
+ }
+ col->name = dmp_get_atom(lp->pool, strlen(name)+1);
+ strcpy(col->name, name);
+ if (lp->c_tree != NULL && col->name != NULL)
+ { xassert(col->node == NULL);
+ col->node = avl_insert_node(lp->c_tree, col->name);
+ avl_set_node_link(col->node, col);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_row_bnds - set (change) row bounds
+*
+* SYNOPSIS
+*
+* void glp_set_row_bnds(glp_prob *lp, int i, int type, double lb,
+* double ub);
+*
+* DESCRIPTION
+*
+* The routine glp_set_row_bnds sets (changes) the type and bounds of
+* i-th row (auxiliary variable) of the specified problem object.
+*
+* Parameters type, lb, and ub specify the type, lower bound, and upper
+* bound, respectively, as follows:
+*
+* Type Bounds Comments
+* ------------------------------------------------------
+* GLP_FR -inf < x < +inf Free variable
+* GLP_LO lb <= x < +inf Variable with lower bound
+* GLP_UP -inf < x <= ub Variable with upper bound
+* GLP_DB lb <= x <= ub Double-bounded variable
+* GLP_FX x = lb Fixed variable
+*
+* where x is the auxiliary variable associated with i-th row.
+*
+* If the row has no lower bound, the parameter lb is ignored. If the
+* row has no upper bound, the parameter ub is ignored. If the row is
+* an equality constraint (i.e. the corresponding auxiliary variable is
+* of fixed type), only the parameter lb is used while the parameter ub
+* is ignored. */
+
+void glp_set_row_bnds(glp_prob *lp, int i, int type, double lb,
+ double ub)
+{ GLPROW *row;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_row_bnds: i = %d; row number out of range\n",
+ i);
+ row = lp->row[i];
+ row->type = type;
+ switch (type)
+ { case GLP_FR:
+ row->lb = row->ub = 0.0;
+ if (row->stat != GLP_BS) row->stat = GLP_NF;
+ break;
+ case GLP_LO:
+ row->lb = lb, row->ub = 0.0;
+ if (row->stat != GLP_BS) row->stat = GLP_NL;
+ break;
+ case GLP_UP:
+ row->lb = 0.0, row->ub = ub;
+ if (row->stat != GLP_BS) row->stat = GLP_NU;
+ break;
+ case GLP_DB:
+ row->lb = lb, row->ub = ub;
+ if (!(row->stat == GLP_BS ||
+ row->stat == GLP_NL || row->stat == GLP_NU))
+ row->stat = (fabs(lb) <= fabs(ub) ? GLP_NL : GLP_NU);
+ break;
+ case GLP_FX:
+ row->lb = row->ub = lb;
+ if (row->stat != GLP_BS) row->stat = GLP_NS;
+ break;
+ default:
+ xerror("glp_set_row_bnds: i = %d; type = %d; invalid row ty"
+ "pe\n", i, type);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_col_bnds - set (change) column bounds
+*
+* SYNOPSIS
+*
+* void glp_set_col_bnds(glp_prob *lp, int j, int type, double lb,
+* double ub);
+*
+* DESCRIPTION
+*
+* The routine glp_set_col_bnds sets (changes) the type and bounds of
+* j-th column (structural variable) of the specified problem object.
+*
+* Parameters type, lb, and ub specify the type, lower bound, and upper
+* bound, respectively, as follows:
+*
+* Type Bounds Comments
+* ------------------------------------------------------
+* GLP_FR -inf < x < +inf Free variable
+* GLP_LO lb <= x < +inf Variable with lower bound
+* GLP_UP -inf < x <= ub Variable with upper bound
+* GLP_DB lb <= x <= ub Double-bounded variable
+* GLP_FX x = lb Fixed variable
+*
+* where x is the structural variable associated with j-th column.
+*
+* If the column has no lower bound, the parameter lb is ignored. If the
+* column has no upper bound, the parameter ub is ignored. If the column
+* is of fixed type, only the parameter lb is used while the parameter
+* ub is ignored. */
+
+void glp_set_col_bnds(glp_prob *lp, int j, int type, double lb,
+ double ub)
+{ GLPCOL *col;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_col_bnds: j = %d; column number out of range\n"
+ , j);
+ col = lp->col[j];
+ col->type = type;
+ switch (type)
+ { case GLP_FR:
+ col->lb = col->ub = 0.0;
+ if (col->stat != GLP_BS) col->stat = GLP_NF;
+ break;
+ case GLP_LO:
+ col->lb = lb, col->ub = 0.0;
+ if (col->stat != GLP_BS) col->stat = GLP_NL;
+ break;
+ case GLP_UP:
+ col->lb = 0.0, col->ub = ub;
+ if (col->stat != GLP_BS) col->stat = GLP_NU;
+ break;
+ case GLP_DB:
+ col->lb = lb, col->ub = ub;
+ if (!(col->stat == GLP_BS ||
+ col->stat == GLP_NL || col->stat == GLP_NU))
+ col->stat = (fabs(lb) <= fabs(ub) ? GLP_NL : GLP_NU);
+ break;
+ case GLP_FX:
+ col->lb = col->ub = lb;
+ if (col->stat != GLP_BS) col->stat = GLP_NS;
+ break;
+ default:
+ xerror("glp_set_col_bnds: j = %d; type = %d; invalid column"
+ " type\n", j, type);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_obj_coef - set (change) obj. coefficient or constant term
+*
+* SYNOPSIS
+*
+* void glp_set_obj_coef(glp_prob *lp, int j, double coef);
+*
+* DESCRIPTION
+*
+* The routine glp_set_obj_coef sets (changes) objective coefficient at
+* j-th column (structural variable) of the specified problem object.
+*
+* If the parameter j is 0, the routine sets (changes) the constant term
+* ("shift") of the objective function. */
+
+void glp_set_obj_coef(glp_prob *lp, int j, double coef)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_obj_coef: operation not allowed\n");
+ if (!(0 <= j && j <= lp->n))
+ xerror("glp_set_obj_coef: j = %d; column number out of range\n"
+ , j);
+ if (j == 0)
+ lp->c0 = coef;
+ else
+ lp->col[j]->coef = coef;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_mat_row - set (replace) row of the constraint matrix
+*
+* SYNOPSIS
+*
+* void glp_set_mat_row(glp_prob *lp, int i, int len, const int ind[],
+* const double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_set_mat_row stores (replaces) the contents of i-th
+* row of the constraint matrix of the specified problem object.
+*
+* Column indices and numeric values of new row elements must be placed
+* in locations ind[1], ..., ind[len] and val[1], ..., val[len], where
+* 0 <= len <= n is the new length of i-th row, n is the current number
+* of columns in the problem object. Elements with identical column
+* indices are not allowed. Zero elements are allowed, but they are not
+* stored in the constraint matrix.
+*
+* If the parameter len is zero, the parameters ind and/or val can be
+* specified as NULL. */
+
+void glp_set_mat_row(glp_prob *lp, int i, int len, const int ind[],
+ const double val[])
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij, *next;
+ int j, k;
+ /* obtain pointer to i-th row */
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_mat_row: i = %d; row number out of range\n",
+ i);
+ row = lp->row[i];
+ if (tree != NULL && tree->reason != 0)
+ { xassert(tree->curr != NULL);
+ xassert(row->level == tree->curr->level);
+ }
+ /* remove all existing elements from i-th row */
+ while (row->ptr != NULL)
+ { /* take next element in the row */
+ aij = row->ptr;
+ /* remove the element from the row list */
+ row->ptr = aij->r_next;
+ /* obtain pointer to corresponding column */
+ col = aij->col;
+ /* remove the element from the column list */
+ if (aij->c_prev == NULL)
+ col->ptr = aij->c_next;
+ else
+ aij->c_prev->c_next = aij->c_next;
+ if (aij->c_next == NULL)
+ ;
+ else
+ aij->c_next->c_prev = aij->c_prev;
+ /* return the element to the memory pool */
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ /* if the corresponding column is basic, invalidate the basis
+ factorization */
+ if (col->stat == GLP_BS) lp->valid = 0;
+ }
+ /* store new contents of i-th row */
+ if (!(0 <= len && len <= lp->n))
+ xerror("glp_set_mat_row: i = %d; len = %d; invalid row length "
+ "\n", i, len);
+ if (len > NNZ_MAX - lp->nnz)
+ xerror("glp_set_mat_row: i = %d; len = %d; too many constraint"
+ " coefficients\n", i, len);
+ for (k = 1; k <= len; k++)
+ { /* take number j of corresponding column */
+ j = ind[k];
+ /* obtain pointer to j-th column */
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_mat_row: i = %d; ind[%d] = %d; column index"
+ " out of range\n", i, k, j);
+ col = lp->col[j];
+ /* if there is element with the same column index, it can only
+ be found in the beginning of j-th column list */
+ if (col->ptr != NULL && col->ptr->row->i == i)
+ xerror("glp_set_mat_row: i = %d; ind[%d] = %d; duplicate co"
+ "lumn indices not allowed\n", i, k, j);
+ /* create new element */
+ aij = dmp_get_atom(lp->pool, sizeof(GLPAIJ)), lp->nnz++;
+ aij->row = row;
+ aij->col = col;
+ aij->val = val[k];
+ /* add the new element to the beginning of i-th row and j-th
+ column lists */
+ aij->r_prev = NULL;
+ aij->r_next = row->ptr;
+ aij->c_prev = NULL;
+ aij->c_next = col->ptr;
+ if (aij->r_next != NULL) aij->r_next->r_prev = aij;
+ if (aij->c_next != NULL) aij->c_next->c_prev = aij;
+ row->ptr = col->ptr = aij;
+ /* if the corresponding column is basic, invalidate the basis
+ factorization */
+ if (col->stat == GLP_BS && aij->val != 0.0) lp->valid = 0;
+ }
+ /* remove zero elements from i-th row */
+ for (aij = row->ptr; aij != NULL; aij = next)
+ { next = aij->r_next;
+ if (aij->val == 0.0)
+ { /* remove the element from the row list */
+ if (aij->r_prev == NULL)
+ row->ptr = next;
+ else
+ aij->r_prev->r_next = next;
+ if (next == NULL)
+ ;
+ else
+ next->r_prev = aij->r_prev;
+ /* remove the element from the column list */
+ xassert(aij->c_prev == NULL);
+ aij->col->ptr = aij->c_next;
+ if (aij->c_next != NULL) aij->c_next->c_prev = NULL;
+ /* return the element to the memory pool */
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_mat_col - set (replace) column of the constraint matrix
+*
+* SYNOPSIS
+*
+* void glp_set_mat_col(glp_prob *lp, int j, int len, const int ind[],
+* const double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_set_mat_col stores (replaces) the contents of j-th
+* column of the constraint matrix of the specified problem object.
+*
+* Row indices and numeric values of new column elements must be placed
+* in locations ind[1], ..., ind[len] and val[1], ..., val[len], where
+* 0 <= len <= m is the new length of j-th column, m is the current
+* number of rows in the problem object. Elements with identical column
+* indices are not allowed. Zero elements are allowed, but they are not
+* stored in the constraint matrix.
+*
+* If the parameter len is zero, the parameters ind and/or val can be
+* specified as NULL. */
+
+void glp_set_mat_col(glp_prob *lp, int j, int len, const int ind[],
+ const double val[])
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij, *next;
+ int i, k;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_set_mat_col: operation not allowed\n");
+ /* obtain pointer to j-th column */
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_mat_col: j = %d; column number out of range\n",
+ j);
+ col = lp->col[j];
+ /* remove all existing elements from j-th column */
+ while (col->ptr != NULL)
+ { /* take next element in the column */
+ aij = col->ptr;
+ /* remove the element from the column list */
+ col->ptr = aij->c_next;
+ /* obtain pointer to corresponding row */
+ row = aij->row;
+ /* remove the element from the row list */
+ if (aij->r_prev == NULL)
+ row->ptr = aij->r_next;
+ else
+ aij->r_prev->r_next = aij->r_next;
+ if (aij->r_next == NULL)
+ ;
+ else
+ aij->r_next->r_prev = aij->r_prev;
+ /* return the element to the memory pool */
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ }
+ /* store new contents of j-th column */
+ if (!(0 <= len && len <= lp->m))
+ xerror("glp_set_mat_col: j = %d; len = %d; invalid column leng"
+ "th\n", j, len);
+ if (len > NNZ_MAX - lp->nnz)
+ xerror("glp_set_mat_col: j = %d; len = %d; too many constraint"
+ " coefficients\n", j, len);
+ for (k = 1; k <= len; k++)
+ { /* take number i of corresponding row */
+ i = ind[k];
+ /* obtain pointer to i-th row */
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_mat_col: j = %d; ind[%d] = %d; row index ou"
+ "t of range\n", j, k, i);
+ row = lp->row[i];
+ /* if there is element with the same row index, it can only be
+ found in the beginning of i-th row list */
+ if (row->ptr != NULL && row->ptr->col->j == j)
+ xerror("glp_set_mat_col: j = %d; ind[%d] = %d; duplicate ro"
+ "w indices not allowed\n", j, k, i);
+ /* create new element */
+ aij = dmp_get_atom(lp->pool, sizeof(GLPAIJ)), lp->nnz++;
+ aij->row = row;
+ aij->col = col;
+ aij->val = val[k];
+ /* add the new element to the beginning of i-th row and j-th
+ column lists */
+ aij->r_prev = NULL;
+ aij->r_next = row->ptr;
+ aij->c_prev = NULL;
+ aij->c_next = col->ptr;
+ if (aij->r_next != NULL) aij->r_next->r_prev = aij;
+ if (aij->c_next != NULL) aij->c_next->c_prev = aij;
+ row->ptr = col->ptr = aij;
+ }
+ /* remove zero elements from j-th column */
+ for (aij = col->ptr; aij != NULL; aij = next)
+ { next = aij->c_next;
+ if (aij->val == 0.0)
+ { /* remove the element from the row list */
+ xassert(aij->r_prev == NULL);
+ aij->row->ptr = aij->r_next;
+ if (aij->r_next != NULL) aij->r_next->r_prev = NULL;
+ /* remove the element from the column list */
+ if (aij->c_prev == NULL)
+ col->ptr = next;
+ else
+ aij->c_prev->c_next = next;
+ if (next == NULL)
+ ;
+ else
+ next->c_prev = aij->c_prev;
+ /* return the element to the memory pool */
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ }
+ }
+ /* if j-th column is basic, invalidate the basis factorization */
+ if (col->stat == GLP_BS) lp->valid = 0;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_load_matrix - load (replace) the whole constraint matrix
+*
+* SYNOPSIS
+*
+* void glp_load_matrix(glp_prob *lp, int ne, const int ia[],
+* const int ja[], const double ar[]);
+*
+* DESCRIPTION
+*
+* The routine glp_load_matrix loads the constraint matrix passed in
+* the arrays ia, ja, and ar into the specified problem object. Before
+* loading the current contents of the constraint matrix is destroyed.
+*
+* Constraint coefficients (elements of the constraint matrix) must be
+* specified as triplets (ia[k], ja[k], ar[k]) for k = 1, ..., ne,
+* where ia[k] is the row index, ja[k] is the column index, ar[k] is a
+* numeric value of corresponding constraint coefficient. The parameter
+* ne specifies the total number of (non-zero) elements in the matrix
+* to be loaded. Coefficients with identical indices are not allowed.
+* Zero coefficients are allowed, however, they are not stored in the
+* constraint matrix.
+*
+* If the parameter ne is zero, the parameters ia, ja, and ar can be
+* specified as NULL. */
+
+void glp_load_matrix(glp_prob *lp, int ne, const int ia[],
+ const int ja[], const double ar[])
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij, *next;
+ int i, j, k;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_load_matrix: operation not allowed\n");
+ /* clear the constraint matrix */
+ for (i = 1; i <= lp->m; i++)
+ { row = lp->row[i];
+ while (row->ptr != NULL)
+ { aij = row->ptr;
+ row->ptr = aij->r_next;
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ }
+ }
+ xassert(lp->nnz == 0);
+ for (j = 1; j <= lp->n; j++) lp->col[j]->ptr = NULL;
+ /* load the new contents of the constraint matrix and build its
+ row lists */
+ if (ne < 0)
+ xerror("glp_load_matrix: ne = %d; invalid number of constraint"
+ " coefficients\n", ne);
+ if (ne > NNZ_MAX)
+ xerror("glp_load_matrix: ne = %d; too many constraint coeffici"
+ "ents\n", ne);
+ for (k = 1; k <= ne; k++)
+ { /* take indices of new element */
+ i = ia[k], j = ja[k];
+ /* obtain pointer to i-th row */
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_load_matrix: ia[%d] = %d; row index out of rang"
+ "e\n", k, i);
+ row = lp->row[i];
+ /* obtain pointer to j-th column */
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_load_matrix: ja[%d] = %d; column index out of r"
+ "ange\n", k, j);
+ col = lp->col[j];
+ /* create new element */
+ aij = dmp_get_atom(lp->pool, sizeof(GLPAIJ)), lp->nnz++;
+ aij->row = row;
+ aij->col = col;
+ aij->val = ar[k];
+ /* add the new element to the beginning of i-th row list */
+ aij->r_prev = NULL;
+ aij->r_next = row->ptr;
+ if (aij->r_next != NULL) aij->r_next->r_prev = aij;
+ row->ptr = aij;
+ }
+ xassert(lp->nnz == ne);
+ /* build column lists of the constraint matrix and check elements
+ with identical indices */
+ for (i = 1; i <= lp->m; i++)
+ { for (aij = lp->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { /* obtain pointer to corresponding column */
+ col = aij->col;
+ /* if there is element with identical indices, it can only
+ be found in the beginning of j-th column list */
+ if (col->ptr != NULL && col->ptr->row->i == i)
+ { for (k = 1; k <= ne; k++)
+ if (ia[k] == i && ja[k] == col->j) break;
+ xerror("glp_load_mat: ia[%d] = %d; ja[%d] = %d; duplicat"
+ "e indices not allowed\n", k, i, k, col->j);
+ }
+ /* add the element to the beginning of j-th column list */
+ aij->c_prev = NULL;
+ aij->c_next = col->ptr;
+ if (aij->c_next != NULL) aij->c_next->c_prev = aij;
+ col->ptr = aij;
+ }
+ }
+ /* remove zero elements from the constraint matrix */
+ for (i = 1; i <= lp->m; i++)
+ { row = lp->row[i];
+ for (aij = row->ptr; aij != NULL; aij = next)
+ { next = aij->r_next;
+ if (aij->val == 0.0)
+ { /* remove the element from the row list */
+ if (aij->r_prev == NULL)
+ row->ptr = next;
+ else
+ aij->r_prev->r_next = next;
+ if (next == NULL)
+ ;
+ else
+ next->r_prev = aij->r_prev;
+ /* remove the element from the column list */
+ if (aij->c_prev == NULL)
+ aij->col->ptr = aij->c_next;
+ else
+ aij->c_prev->c_next = aij->c_next;
+ if (aij->c_next == NULL)
+ ;
+ else
+ aij->c_next->c_prev = aij->c_prev;
+ /* return the element to the memory pool */
+ dmp_free_atom(lp->pool, aij, sizeof(GLPAIJ)), lp->nnz--;
+ }
+ }
+ }
+ /* invalidate the basis factorization */
+ lp->valid = 0;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_check_dup - check for duplicate elements in sparse matrix
+*
+* SYNOPSIS
+*
+* int glp_check_dup(int m, int n, int ne, const int ia[],
+* const int ja[]);
+*
+* DESCRIPTION
+*
+* The routine glp_check_dup checks for duplicate elements (that is,
+* elements with identical indices) in a sparse matrix specified in the
+* coordinate format.
+*
+* The parameters m and n specifies, respectively, the number of rows
+* and columns in the matrix, m >= 0, n >= 0.
+*
+* The parameter ne specifies the number of (structurally) non-zero
+* elements in the matrix, ne >= 0.
+*
+* Elements of the matrix are specified as doublets (ia[k],ja[k]) for
+* k = 1,...,ne, where ia[k] is a row index, ja[k] is a column index.
+*
+* The routine glp_check_dup can be used prior to a call to the routine
+* glp_load_matrix to check that the constraint matrix to be loaded has
+* no duplicate elements.
+*
+* RETURNS
+*
+* The routine glp_check_dup returns one of the following values:
+*
+* 0 - the matrix has no duplicate elements;
+*
+* -k - indices ia[k] or/and ja[k] are out of range;
+*
+* +k - element (ia[k],ja[k]) is duplicate. */
+
+int glp_check_dup(int m, int n, int ne, const int ia[], const int ja[])
+{ int i, j, k, *ptr, *next, ret;
+ char *flag;
+ if (m < 0)
+ xerror("glp_check_dup: m = %d; invalid parameter\n");
+ if (n < 0)
+ xerror("glp_check_dup: n = %d; invalid parameter\n");
+ if (ne < 0)
+ xerror("glp_check_dup: ne = %d; invalid parameter\n");
+ if (ne > 0 && ia == NULL)
+ xerror("glp_check_dup: ia = %p; invalid parameter\n", ia);
+ if (ne > 0 && ja == NULL)
+ xerror("glp_check_dup: ja = %p; invalid parameter\n", ja);
+ for (k = 1; k <= ne; k++)
+ { i = ia[k], j = ja[k];
+ if (!(1 <= i && i <= m && 1 <= j && j <= n))
+ { ret = -k;
+ goto done;
+ }
+ }
+ if (m == 0 || n == 0)
+ { ret = 0;
+ goto done;
+ }
+ /* allocate working arrays */
+ ptr = xcalloc(1+m, sizeof(int));
+ next = xcalloc(1+ne, sizeof(int));
+ flag = xcalloc(1+n, sizeof(char));
+ /* build row lists */
+ for (i = 1; i <= m; i++)
+ ptr[i] = 0;
+ for (k = 1; k <= ne; k++)
+ { i = ia[k];
+ next[k] = ptr[i];
+ ptr[i] = k;
+ }
+ /* clear column flags */
+ for (j = 1; j <= n; j++)
+ flag[j] = 0;
+ /* check for duplicate elements */
+ for (i = 1; i <= m; i++)
+ { for (k = ptr[i]; k != 0; k = next[k])
+ { j = ja[k];
+ if (flag[j])
+ { /* find first element (i,j) */
+ for (k = 1; k <= ne; k++)
+ if (ia[k] == i && ja[k] == j) break;
+ xassert(k <= ne);
+ /* find next (duplicate) element (i,j) */
+ for (k++; k <= ne; k++)
+ if (ia[k] == i && ja[k] == j) break;
+ xassert(k <= ne);
+ ret = +k;
+ goto skip;
+ }
+ flag[j] = 1;
+ }
+ /* clear column flags */
+ for (k = ptr[i]; k != 0; k = next[k])
+ flag[ja[k]] = 0;
+ }
+ /* no duplicate element found */
+ ret = 0;
+skip: /* free working arrays */
+ xfree(ptr);
+ xfree(next);
+ xfree(flag);
+done: return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_sort_matrix - sort elements of the constraint matrix
+*
+* SYNOPSIS
+*
+* void glp_sort_matrix(glp_prob *P);
+*
+* DESCRIPTION
+*
+* The routine glp_sort_matrix sorts elements of the constraint matrix
+* rebuilding its row and column linked lists. On exit from the routine
+* the constraint matrix is not changed, however, elements in the row
+* linked lists become ordered by ascending column indices, and the
+* elements in the column linked lists become ordered by ascending row
+* indices. */
+
+void glp_sort_matrix(glp_prob *P)
+{ GLPAIJ *aij;
+ int i, j;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_sort_matrix: P = %p; invalid problem object\n",
+ P);
+#endif
+ /* rebuild row linked lists */
+ for (i = P->m; i >= 1; i--)
+ P->row[i]->ptr = NULL;
+ for (j = P->n; j >= 1; j--)
+ { for (aij = P->col[j]->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row->i;
+ aij->r_prev = NULL;
+ aij->r_next = P->row[i]->ptr;
+ if (aij->r_next != NULL) aij->r_next->r_prev = aij;
+ P->row[i]->ptr = aij;
+ }
+ }
+ /* rebuild column linked lists */
+ for (j = P->n; j >= 1; j--)
+ P->col[j]->ptr = NULL;
+ for (i = P->m; i >= 1; i--)
+ { for (aij = P->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { j = aij->col->j;
+ aij->c_prev = NULL;
+ aij->c_next = P->col[j]->ptr;
+ if (aij->c_next != NULL) aij->c_next->c_prev = aij;
+ P->col[j]->ptr = aij;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_del_rows - delete rows from problem object
+*
+* SYNOPSIS
+*
+* void glp_del_rows(glp_prob *lp, int nrs, const int num[]);
+*
+* DESCRIPTION
+*
+* The routine glp_del_rows deletes rows from the specified problem
+* object. Ordinal numbers of rows to be deleted should be placed in
+* locations num[1], ..., num[nrs], where nrs > 0.
+*
+* Note that deleting rows involves changing ordinal numbers of other
+* rows remaining in the problem object. New ordinal numbers of the
+* remaining rows are assigned under the assumption that the original
+* order of rows is not changed. */
+
+void glp_del_rows(glp_prob *lp, int nrs, const int num[])
+{ glp_tree *tree = lp->tree;
+ GLPROW *row;
+ int i, k, m_new;
+ /* mark rows to be deleted */
+ if (!(1 <= nrs && nrs <= lp->m))
+ xerror("glp_del_rows: nrs = %d; invalid number of rows\n",
+ nrs);
+ for (k = 1; k <= nrs; k++)
+ { /* take the number of row to be deleted */
+ i = num[k];
+ /* obtain pointer to i-th row */
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_del_rows: num[%d] = %d; row number out of range"
+ "\n", k, i);
+ row = lp->row[i];
+ if (tree != NULL && tree->reason != 0)
+ { if (!(tree->reason == GLP_IROWGEN ||
+ tree->reason == GLP_ICUTGEN))
+ xerror("glp_del_rows: operation not allowed\n");
+ xassert(tree->curr != NULL);
+ if (row->level != tree->curr->level)
+ xerror("glp_del_rows: num[%d] = %d; invalid attempt to d"
+ "elete row created not in current subproblem\n", k,i);
+ if (row->stat != GLP_BS)
+ xerror("glp_del_rows: num[%d] = %d; invalid attempt to d"
+ "elete active row (constraint)\n", k, i);
+ tree->reinv = 1;
+ }
+ /* check that the row is not marked yet */
+ if (row->i == 0)
+ xerror("glp_del_rows: num[%d] = %d; duplicate row numbers n"
+ "ot allowed\n", k, i);
+ /* erase symbolic name assigned to the row */
+ glp_set_row_name(lp, i, NULL);
+ xassert(row->node == NULL);
+ /* erase corresponding row of the constraint matrix */
+ glp_set_mat_row(lp, i, 0, NULL, NULL);
+ xassert(row->ptr == NULL);
+ /* mark the row to be deleted */
+ row->i = 0;
+ }
+ /* delete all marked rows from the row list */
+ m_new = 0;
+ for (i = 1; i <= lp->m; i++)
+ { /* obtain pointer to i-th row */
+ row = lp->row[i];
+ /* check if the row is marked */
+ if (row->i == 0)
+ { /* it is marked, delete it */
+ dmp_free_atom(lp->pool, row, sizeof(GLPROW));
+ }
+ else
+ { /* it is not marked; keep it */
+ row->i = ++m_new;
+ lp->row[row->i] = row;
+ }
+ }
+ /* set new number of rows */
+ lp->m = m_new;
+ /* invalidate the basis factorization */
+ lp->valid = 0;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_del_cols - delete columns from problem object
+*
+* SYNOPSIS
+*
+* void glp_del_cols(glp_prob *lp, int ncs, const int num[]);
+*
+* DESCRIPTION
+*
+* The routine glp_del_cols deletes columns from the specified problem
+* object. Ordinal numbers of columns to be deleted should be placed in
+* locations num[1], ..., num[ncs], where ncs > 0.
+*
+* Note that deleting columns involves changing ordinal numbers of
+* other columns remaining in the problem object. New ordinal numbers
+* of the remaining columns are assigned under the assumption that the
+* original order of columns is not changed. */
+
+void glp_del_cols(glp_prob *lp, int ncs, const int num[])
+{ glp_tree *tree = lp->tree;
+ GLPCOL *col;
+ int j, k, n_new;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_del_cols: operation not allowed\n");
+ /* mark columns to be deleted */
+ if (!(1 <= ncs && ncs <= lp->n))
+ xerror("glp_del_cols: ncs = %d; invalid number of columns\n",
+ ncs);
+ for (k = 1; k <= ncs; k++)
+ { /* take the number of column to be deleted */
+ j = num[k];
+ /* obtain pointer to j-th column */
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_del_cols: num[%d] = %d; column number out of ra"
+ "nge", k, j);
+ col = lp->col[j];
+ /* check that the column is not marked yet */
+ if (col->j == 0)
+ xerror("glp_del_cols: num[%d] = %d; duplicate column number"
+ "s not allowed\n", k, j);
+ /* erase symbolic name assigned to the column */
+ glp_set_col_name(lp, j, NULL);
+ xassert(col->node == NULL);
+ /* erase corresponding column of the constraint matrix */
+ glp_set_mat_col(lp, j, 0, NULL, NULL);
+ xassert(col->ptr == NULL);
+ /* mark the column to be deleted */
+ col->j = 0;
+ /* if it is basic, invalidate the basis factorization */
+ if (col->stat == GLP_BS) lp->valid = 0;
+ }
+ /* delete all marked columns from the column list */
+ n_new = 0;
+ for (j = 1; j <= lp->n; j++)
+ { /* obtain pointer to j-th column */
+ col = lp->col[j];
+ /* check if the column is marked */
+ if (col->j == 0)
+ { /* it is marked; delete it */
+ dmp_free_atom(lp->pool, col, sizeof(GLPCOL));
+ }
+ else
+ { /* it is not marked; keep it */
+ col->j = ++n_new;
+ lp->col[col->j] = col;
+ }
+ }
+ /* set new number of columns */
+ lp->n = n_new;
+ /* if the basis header is still valid, adjust it */
+ if (lp->valid)
+ { int m = lp->m;
+ int *head = lp->head;
+ for (j = 1; j <= n_new; j++)
+ { k = lp->col[j]->bind;
+ if (k != 0)
+ { xassert(1 <= k && k <= m);
+ head[k] = m + j;
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_copy_prob - copy problem object content
+*
+* SYNOPSIS
+*
+* void glp_copy_prob(glp_prob *dest, glp_prob *prob, int names);
+*
+* DESCRIPTION
+*
+* The routine glp_copy_prob copies the content of the problem object
+* prob to the problem object dest.
+*
+* The parameter names is a flag. If it is non-zero, the routine also
+* copies all symbolic names; otherwise, if it is zero, symbolic names
+* are not copied. */
+
+void glp_copy_prob(glp_prob *dest, glp_prob *prob, int names)
+{ glp_tree *tree = dest->tree;
+ glp_bfcp bfcp;
+ int i, j, len, *ind;
+ double *val;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_copy_prob: operation not allowed\n");
+ if (dest == prob)
+ xerror("glp_copy_prob: copying problem object to itself not al"
+ "lowed\n");
+ if (!(names == GLP_ON || names == GLP_OFF))
+ xerror("glp_copy_prob: names = %d; invalid parameter\n",
+ names);
+ glp_erase_prob(dest);
+ if (names && prob->name != NULL)
+ glp_set_prob_name(dest, prob->name);
+ if (names && prob->obj != NULL)
+ glp_set_obj_name(dest, prob->obj);
+ dest->dir = prob->dir;
+ dest->c0 = prob->c0;
+ if (prob->m > 0)
+ glp_add_rows(dest, prob->m);
+ if (prob->n > 0)
+ glp_add_cols(dest, prob->n);
+ glp_get_bfcp(prob, &bfcp);
+ glp_set_bfcp(dest, &bfcp);
+ dest->pbs_stat = prob->pbs_stat;
+ dest->dbs_stat = prob->dbs_stat;
+ dest->obj_val = prob->obj_val;
+ dest->some = prob->some;
+ dest->ipt_stat = prob->ipt_stat;
+ dest->ipt_obj = prob->ipt_obj;
+ dest->mip_stat = prob->mip_stat;
+ dest->mip_obj = prob->mip_obj;
+ for (i = 1; i <= prob->m; i++)
+ { GLPROW *to = dest->row[i];
+ GLPROW *from = prob->row[i];
+ if (names && from->name != NULL)
+ glp_set_row_name(dest, i, from->name);
+ to->type = from->type;
+ to->lb = from->lb;
+ to->ub = from->ub;
+ to->rii = from->rii;
+ to->stat = from->stat;
+ to->prim = from->prim;
+ to->dual = from->dual;
+ to->pval = from->pval;
+ to->dval = from->dval;
+ to->mipx = from->mipx;
+ }
+ ind = xcalloc(1+prob->m, sizeof(int));
+ val = xcalloc(1+prob->m, sizeof(double));
+ for (j = 1; j <= prob->n; j++)
+ { GLPCOL *to = dest->col[j];
+ GLPCOL *from = prob->col[j];
+ if (names && from->name != NULL)
+ glp_set_col_name(dest, j, from->name);
+ to->kind = from->kind;
+ to->type = from->type;
+ to->lb = from->lb;
+ to->ub = from->ub;
+ to->coef = from->coef;
+ len = glp_get_mat_col(prob, j, ind, val);
+ glp_set_mat_col(dest, j, len, ind, val);
+ to->sjj = from->sjj;
+ to->stat = from->stat;
+ to->prim = from->prim;
+ to->dual = from->dual;
+ to->pval = from->pval;
+ to->dval = from->dval;
+ to->mipx = from->mipx;
+ }
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_erase_prob - erase problem object content
+*
+* SYNOPSIS
+*
+* void glp_erase_prob(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_erase_prob erases the content of the specified
+* problem object. The effect of this operation is the same as if the
+* problem object would be deleted with the routine glp_delete_prob and
+* then created anew with the routine glp_create_prob, with exception
+* that the handle (pointer) to the problem object remains valid. */
+
+static void delete_prob(glp_prob *lp);
+
+void glp_erase_prob(glp_prob *lp)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_erase_prob: operation not allowed\n");
+ delete_prob(lp);
+ create_prob(lp);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_delete_prob - delete problem object
+*
+* SYNOPSIS
+*
+* void glp_delete_prob(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_delete_prob deletes the specified problem object and
+* frees all the memory allocated to it. */
+
+static void delete_prob(glp_prob *lp)
+#if 0 /* 04/IV-2016 */
+{ lp->magic = 0x3F3F3F3F;
+#else
+{
+#endif
+ dmp_delete_pool(lp->pool);
+#if 0 /* 08/III-2014 */
+#if 0 /* 17/XI-2009 */
+ xfree(lp->cps);
+#else
+ if (lp->parms != NULL) xfree(lp->parms);
+#endif
+#endif
+ xassert(lp->tree == NULL);
+#if 0
+ if (lp->cwa != NULL) xfree(lp->cwa);
+#endif
+ xfree(lp->row);
+ xfree(lp->col);
+ if (lp->r_tree != NULL) avl_delete_tree(lp->r_tree);
+ if (lp->c_tree != NULL) avl_delete_tree(lp->c_tree);
+ xfree(lp->head);
+#if 0 /* 08/III-2014 */
+ if (lp->bfcp != NULL) xfree(lp->bfcp);
+#endif
+ if (lp->bfd != NULL) bfd_delete_it(lp->bfd);
+ return;
+}
+
+void glp_delete_prob(glp_prob *lp)
+{ glp_tree *tree = lp->tree;
+ if (tree != NULL && tree->reason != 0)
+ xerror("glp_delete_prob: operation not allowed\n");
+ delete_prob(lp);
+ xfree(lp);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob2.c b/test/monniaux/glpk-4.65/src/api/prob2.c
new file mode 100644
index 00000000..d352db12
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob2.c
@@ -0,0 +1,491 @@
+/* prob2.c (problem retrieving routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_get_prob_name - retrieve problem name
+*
+* SYNOPSIS
+*
+* const char *glp_get_prob_name(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_prob_name returns a pointer to an internal
+* buffer, which contains symbolic name of the problem. However, if the
+* problem has no assigned name, the routine returns NULL. */
+
+const char *glp_get_prob_name(glp_prob *lp)
+{ char *name;
+ name = lp->name;
+ return name;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_obj_name - retrieve objective function name
+*
+* SYNOPSIS
+*
+* const char *glp_get_obj_name(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_obj_name returns a pointer to an internal
+* buffer, which contains a symbolic name of the objective function.
+* However, if the objective function has no assigned name, the routine
+* returns NULL. */
+
+const char *glp_get_obj_name(glp_prob *lp)
+{ char *name;
+ name = lp->obj;
+ return name;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_obj_dir - retrieve optimization direction flag
+*
+* SYNOPSIS
+*
+* int glp_get_obj_dir(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_obj_dir returns the optimization direction flag
+* (i.e. "sense" of the objective function):
+*
+* GLP_MIN - minimization;
+* GLP_MAX - maximization. */
+
+int glp_get_obj_dir(glp_prob *lp)
+{ int dir = lp->dir;
+ return dir;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_num_rows - retrieve number of rows
+*
+* SYNOPSIS
+*
+* int glp_get_num_rows(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_num_rows returns the current number of rows in
+* the specified problem object. */
+
+int glp_get_num_rows(glp_prob *lp)
+{ int m = lp->m;
+ return m;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_num_cols - retrieve number of columns
+*
+* SYNOPSIS
+*
+* int glp_get_num_cols(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_num_cols returns the current number of columns
+* in the specified problem object. */
+
+int glp_get_num_cols(glp_prob *lp)
+{ int n = lp->n;
+ return n;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_name - retrieve row name
+*
+* SYNOPSIS
+*
+* const char *glp_get_row_name(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_name returns a pointer to an internal
+* buffer, which contains symbolic name of i-th row. However, if i-th
+* row has no assigned name, the routine returns NULL. */
+
+const char *glp_get_row_name(glp_prob *lp, int i)
+{ char *name;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_name: i = %d; row number out of range\n",
+ i);
+ name = lp->row[i]->name;
+ return name;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_name - retrieve column name
+*
+* SYNOPSIS
+*
+* const char *glp_get_col_name(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_name returns a pointer to an internal
+* buffer, which contains symbolic name of j-th column. However, if j-th
+* column has no assigned name, the routine returns NULL. */
+
+const char *glp_get_col_name(glp_prob *lp, int j)
+{ char *name;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_name: j = %d; column number out of range\n"
+ , j);
+ name = lp->col[j]->name;
+ return name;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_type - retrieve row type
+*
+* SYNOPSIS
+*
+* int glp_get_row_type(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_type returns the type of i-th row, i.e. the
+* type of corresponding auxiliary variable, as follows:
+*
+* GLP_FR - free (unbounded) variable;
+* GLP_LO - variable with lower bound;
+* GLP_UP - variable with upper bound;
+* GLP_DB - double-bounded variable;
+* GLP_FX - fixed variable. */
+
+int glp_get_row_type(glp_prob *lp, int i)
+{ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_type: i = %d; row number out of range\n",
+ i);
+ return lp->row[i]->type;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_lb - retrieve row lower bound
+*
+* SYNOPSIS
+*
+* double glp_get_row_lb(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_lb returns the lower bound of i-th row, i.e.
+* the lower bound of corresponding auxiliary variable. However, if the
+* row has no lower bound, the routine returns -DBL_MAX. */
+
+double glp_get_row_lb(glp_prob *lp, int i)
+{ double lb;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_lb: i = %d; row number out of range\n", i);
+ switch (lp->row[i]->type)
+ { case GLP_FR:
+ case GLP_UP:
+ lb = -DBL_MAX; break;
+ case GLP_LO:
+ case GLP_DB:
+ case GLP_FX:
+ lb = lp->row[i]->lb; break;
+ default:
+ xassert(lp != lp);
+ }
+ return lb;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_ub - retrieve row upper bound
+*
+* SYNOPSIS
+*
+* double glp_get_row_ub(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_ub returns the upper bound of i-th row, i.e.
+* the upper bound of corresponding auxiliary variable. However, if the
+* row has no upper bound, the routine returns +DBL_MAX. */
+
+double glp_get_row_ub(glp_prob *lp, int i)
+{ double ub;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_ub: i = %d; row number out of range\n", i);
+ switch (lp->row[i]->type)
+ { case GLP_FR:
+ case GLP_LO:
+ ub = +DBL_MAX; break;
+ case GLP_UP:
+ case GLP_DB:
+ case GLP_FX:
+ ub = lp->row[i]->ub; break;
+ default:
+ xassert(lp != lp);
+ }
+ return ub;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_type - retrieve column type
+*
+* SYNOPSIS
+*
+* int glp_get_col_type(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_type returns the type of j-th column, i.e.
+* the type of corresponding structural variable, as follows:
+*
+* GLP_FR - free (unbounded) variable;
+* GLP_LO - variable with lower bound;
+* GLP_UP - variable with upper bound;
+* GLP_DB - double-bounded variable;
+* GLP_FX - fixed variable. */
+
+int glp_get_col_type(glp_prob *lp, int j)
+{ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_type: j = %d; column number out of range\n"
+ , j);
+ return lp->col[j]->type;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_lb - retrieve column lower bound
+*
+* SYNOPSIS
+*
+* double glp_get_col_lb(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_lb returns the lower bound of j-th column,
+* i.e. the lower bound of corresponding structural variable. However,
+* if the column has no lower bound, the routine returns -DBL_MAX. */
+
+double glp_get_col_lb(glp_prob *lp, int j)
+{ double lb;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_lb: j = %d; column number out of range\n",
+ j);
+ switch (lp->col[j]->type)
+ { case GLP_FR:
+ case GLP_UP:
+ lb = -DBL_MAX; break;
+ case GLP_LO:
+ case GLP_DB:
+ case GLP_FX:
+ lb = lp->col[j]->lb; break;
+ default:
+ xassert(lp != lp);
+ }
+ return lb;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_ub - retrieve column upper bound
+*
+* SYNOPSIS
+*
+* double glp_get_col_ub(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_ub returns the upper bound of j-th column,
+* i.e. the upper bound of corresponding structural variable. However,
+* if the column has no upper bound, the routine returns +DBL_MAX. */
+
+double glp_get_col_ub(glp_prob *lp, int j)
+{ double ub;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_ub: j = %d; column number out of range\n",
+ j);
+ switch (lp->col[j]->type)
+ { case GLP_FR:
+ case GLP_LO:
+ ub = +DBL_MAX; break;
+ case GLP_UP:
+ case GLP_DB:
+ case GLP_FX:
+ ub = lp->col[j]->ub; break;
+ default:
+ xassert(lp != lp);
+ }
+ return ub;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_obj_coef - retrieve obj. coefficient or constant term
+*
+* SYNOPSIS
+*
+* double glp_get_obj_coef(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_obj_coef returns the objective coefficient at
+* j-th structural variable (column) of the specified problem object.
+*
+* If the parameter j is zero, the routine returns the constant term
+* ("shift") of the objective function. */
+
+double glp_get_obj_coef(glp_prob *lp, int j)
+{ if (!(0 <= j && j <= lp->n))
+ xerror("glp_get_obj_coef: j = %d; column number out of range\n"
+ , j);
+ return j == 0 ? lp->c0 : lp->col[j]->coef;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_num_nz - retrieve number of constraint coefficients
+*
+* SYNOPSIS
+*
+* int glp_get_num_nz(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_num_nz returns the number of (non-zero) elements
+* in the constraint matrix of the specified problem object. */
+
+int glp_get_num_nz(glp_prob *lp)
+{ int nnz = lp->nnz;
+ return nnz;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_mat_row - retrieve row of the constraint matrix
+*
+* SYNOPSIS
+*
+* int glp_get_mat_row(glp_prob *lp, int i, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_get_mat_row scans (non-zero) elements of i-th row
+* of the constraint matrix of the specified problem object and stores
+* their column indices and numeric values to locations ind[1], ...,
+* ind[len] and val[1], ..., val[len], respectively, where 0 <= len <= n
+* is the number of elements in i-th row, n is the number of columns.
+*
+* The parameter ind and/or val can be specified as NULL, in which case
+* corresponding information is not stored.
+*
+* RETURNS
+*
+* The routine glp_get_mat_row returns the length len, i.e. the number
+* of (non-zero) elements in i-th row. */
+
+int glp_get_mat_row(glp_prob *lp, int i, int ind[], double val[])
+{ GLPAIJ *aij;
+ int len;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_mat_row: i = %d; row number out of range\n",
+ i);
+ len = 0;
+ for (aij = lp->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { len++;
+ if (ind != NULL) ind[len] = aij->col->j;
+ if (val != NULL) val[len] = aij->val;
+ }
+ xassert(len <= lp->n);
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_mat_col - retrieve column of the constraint matrix
+*
+* SYNOPSIS
+*
+* int glp_get_mat_col(glp_prob *lp, int j, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_get_mat_col scans (non-zero) elements of j-th column
+* of the constraint matrix of the specified problem object and stores
+* their row indices and numeric values to locations ind[1], ...,
+* ind[len] and val[1], ..., val[len], respectively, where 0 <= len <= m
+* is the number of elements in j-th column, m is the number of rows.
+*
+* The parameter ind or/and val can be specified as NULL, in which case
+* corresponding information is not stored.
+*
+* RETURNS
+*
+* The routine glp_get_mat_col returns the length len, i.e. the number
+* of (non-zero) elements in j-th column. */
+
+int glp_get_mat_col(glp_prob *lp, int j, int ind[], double val[])
+{ GLPAIJ *aij;
+ int len;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_mat_col: j = %d; column number out of range\n",
+ j);
+ len = 0;
+ for (aij = lp->col[j]->ptr; aij != NULL; aij = aij->c_next)
+ { len++;
+ if (ind != NULL) ind[len] = aij->row->i;
+ if (val != NULL) val[len] = aij->val;
+ }
+ xassert(len <= lp->m);
+ return len;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob3.c b/test/monniaux/glpk-4.65/src/api/prob3.c
new file mode 100644
index 00000000..d7edbd33
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob3.c
@@ -0,0 +1,166 @@
+/* prob3.c (problem row/column searching routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_create_index - create the name index
+*
+* SYNOPSIS
+*
+* void glp_create_index(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_create_index creates the name index for the
+* specified problem object. The name index is an auxiliary data
+* structure, which is intended to quickly (i.e. for logarithmic time)
+* find rows and columns by their names.
+*
+* This routine can be called at any time. If the name index already
+* exists, the routine does nothing. */
+
+void glp_create_index(glp_prob *lp)
+{ GLPROW *row;
+ GLPCOL *col;
+ int i, j;
+ /* create row name index */
+ if (lp->r_tree == NULL)
+ { lp->r_tree = avl_create_tree(avl_strcmp, NULL);
+ for (i = 1; i <= lp->m; i++)
+ { row = lp->row[i];
+ xassert(row->node == NULL);
+ if (row->name != NULL)
+ { row->node = avl_insert_node(lp->r_tree, row->name);
+ avl_set_node_link(row->node, row);
+ }
+ }
+ }
+ /* create column name index */
+ if (lp->c_tree == NULL)
+ { lp->c_tree = avl_create_tree(avl_strcmp, NULL);
+ for (j = 1; j <= lp->n; j++)
+ { col = lp->col[j];
+ xassert(col->node == NULL);
+ if (col->name != NULL)
+ { col->node = avl_insert_node(lp->c_tree, col->name);
+ avl_set_node_link(col->node, col);
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_find_row - find row by its name
+*
+* SYNOPSIS
+*
+* int glp_find_row(glp_prob *lp, const char *name);
+*
+* RETURNS
+*
+* The routine glp_find_row returns the ordinal number of a row,
+* which is assigned (by the routine glp_set_row_name) the specified
+* symbolic name. If no such row exists, the routine returns 0. */
+
+int glp_find_row(glp_prob *lp, const char *name)
+{ AVLNODE *node;
+ int i = 0;
+ if (lp->r_tree == NULL)
+ xerror("glp_find_row: row name index does not exist\n");
+ if (!(name == NULL || name[0] == '\0' || strlen(name) > 255))
+ { node = avl_find_node(lp->r_tree, name);
+ if (node != NULL)
+ i = ((GLPROW *)avl_get_node_link(node))->i;
+ }
+ return i;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_find_col - find column by its name
+*
+* SYNOPSIS
+*
+* int glp_find_col(glp_prob *lp, const char *name);
+*
+* RETURNS
+*
+* The routine glp_find_col returns the ordinal number of a column,
+* which is assigned (by the routine glp_set_col_name) the specified
+* symbolic name. If no such column exists, the routine returns 0. */
+
+int glp_find_col(glp_prob *lp, const char *name)
+{ AVLNODE *node;
+ int j = 0;
+ if (lp->c_tree == NULL)
+ xerror("glp_find_col: column name index does not exist\n");
+ if (!(name == NULL || name[0] == '\0' || strlen(name) > 255))
+ { node = avl_find_node(lp->c_tree, name);
+ if (node != NULL)
+ j = ((GLPCOL *)avl_get_node_link(node))->j;
+ }
+ return j;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_delete_index - delete the name index
+*
+* SYNOPSIS
+*
+* void glp_delete_index(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_delete_index deletes the name index previously
+* created by the routine glp_create_index and frees the memory
+* allocated to this auxiliary data structure.
+*
+* This routine can be called at any time. If the name index does not
+* exist, the routine does nothing. */
+
+void glp_delete_index(glp_prob *lp)
+{ int i, j;
+ /* delete row name index */
+ if (lp->r_tree != NULL)
+ { for (i = 1; i <= lp->m; i++) lp->row[i]->node = NULL;
+ avl_delete_tree(lp->r_tree), lp->r_tree = NULL;
+ }
+ /* delete column name index */
+ if (lp->c_tree != NULL)
+ { for (j = 1; j <= lp->n; j++) lp->col[j]->node = NULL;
+ avl_delete_tree(lp->c_tree), lp->c_tree = NULL;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob4.c b/test/monniaux/glpk-4.65/src/api/prob4.c
new file mode 100644
index 00000000..8c2b5ae5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob4.c
@@ -0,0 +1,156 @@
+/* prob4.c (problem scaling routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_set_rii - set (change) row scale factor
+*
+* SYNOPSIS
+*
+* void glp_set_rii(glp_prob *lp, int i, double rii);
+*
+* DESCRIPTION
+*
+* The routine glp_set_rii sets (changes) the scale factor r[i,i] for
+* i-th row of the specified problem object. */
+
+void glp_set_rii(glp_prob *lp, int i, double rii)
+{ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_rii: i = %d; row number out of range\n", i);
+ if (rii <= 0.0)
+ xerror("glp_set_rii: i = %d; rii = %g; invalid scale factor\n",
+ i, rii);
+ if (lp->valid && lp->row[i]->rii != rii)
+ { GLPAIJ *aij;
+ for (aij = lp->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->col->stat == GLP_BS)
+ { /* invalidate the basis factorization */
+ lp->valid = 0;
+ break;
+ }
+ }
+ }
+ lp->row[i]->rii = rii;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set sjj - set (change) column scale factor
+*
+* SYNOPSIS
+*
+* void glp_set_sjj(glp_prob *lp, int j, double sjj);
+*
+* DESCRIPTION
+*
+* The routine glp_set_sjj sets (changes) the scale factor s[j,j] for
+* j-th column of the specified problem object. */
+
+void glp_set_sjj(glp_prob *lp, int j, double sjj)
+{ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_sjj: j = %d; column number out of range\n", j);
+ if (sjj <= 0.0)
+ xerror("glp_set_sjj: j = %d; sjj = %g; invalid scale factor\n",
+ j, sjj);
+ if (lp->valid && lp->col[j]->sjj != sjj && lp->col[j]->stat ==
+ GLP_BS)
+ { /* invalidate the basis factorization */
+ lp->valid = 0;
+ }
+ lp->col[j]->sjj = sjj;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_rii - retrieve row scale factor
+*
+* SYNOPSIS
+*
+* double glp_get_rii(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_rii returns current scale factor r[i,i] for i-th
+* row of the specified problem object. */
+
+double glp_get_rii(glp_prob *lp, int i)
+{ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_rii: i = %d; row number out of range\n", i);
+ return lp->row[i]->rii;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_sjj - retrieve column scale factor
+*
+* SYNOPSIS
+*
+* double glp_get_sjj(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_sjj returns current scale factor s[j,j] for j-th
+* column of the specified problem object. */
+
+double glp_get_sjj(glp_prob *lp, int j)
+{ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_sjj: j = %d; column number out of range\n", j);
+ return lp->col[j]->sjj;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_unscale_prob - unscale problem data
+*
+* SYNOPSIS
+*
+* void glp_unscale_prob(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_unscale_prob performs unscaling of problem data for
+* the specified problem object.
+*
+* "Unscaling" means replacing the current scaling matrices R and S by
+* unity matrices that cancels the scaling effect. */
+
+void glp_unscale_prob(glp_prob *lp)
+{ int m = glp_get_num_rows(lp);
+ int n = glp_get_num_cols(lp);
+ int i, j;
+ for (i = 1; i <= m; i++) glp_set_rii(lp, i, 1.0);
+ for (j = 1; j <= n; j++) glp_set_sjj(lp, j, 1.0);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prob5.c b/test/monniaux/glpk-4.65/src/api/prob5.c
new file mode 100644
index 00000000..1c1d3160
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prob5.c
@@ -0,0 +1,168 @@
+/* prob5.c (LP problem basis constructing routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_set_row_stat - set (change) row status
+*
+* SYNOPSIS
+*
+* void glp_set_row_stat(glp_prob *lp, int i, int stat);
+*
+* DESCRIPTION
+*
+* The routine glp_set_row_stat sets (changes) status of the auxiliary
+* variable associated with i-th row.
+*
+* The new status of the auxiliary variable should be specified by the
+* parameter stat as follows:
+*
+* GLP_BS - basic variable;
+* GLP_NL - non-basic variable;
+* GLP_NU - non-basic variable on its upper bound; if the variable is
+* not double-bounded, this means the same as GLP_NL (only in
+* case of this routine);
+* GLP_NF - the same as GLP_NL (only in case of this routine);
+* GLP_NS - the same as GLP_NL (only in case of this routine). */
+
+void glp_set_row_stat(glp_prob *lp, int i, int stat)
+{ GLPROW *row;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_set_row_stat: i = %d; row number out of range\n",
+ i);
+ if (!(stat == GLP_BS || stat == GLP_NL || stat == GLP_NU ||
+ stat == GLP_NF || stat == GLP_NS))
+ xerror("glp_set_row_stat: i = %d; stat = %d; invalid status\n",
+ i, stat);
+ row = lp->row[i];
+ if (stat != GLP_BS)
+ { switch (row->type)
+ { case GLP_FR: stat = GLP_NF; break;
+ case GLP_LO: stat = GLP_NL; break;
+ case GLP_UP: stat = GLP_NU; break;
+ case GLP_DB: if (stat != GLP_NU) stat = GLP_NL; break;
+ case GLP_FX: stat = GLP_NS; break;
+ default: xassert(row != row);
+ }
+ }
+ if (row->stat == GLP_BS && stat != GLP_BS ||
+ row->stat != GLP_BS && stat == GLP_BS)
+ { /* invalidate the basis factorization */
+ lp->valid = 0;
+ }
+ row->stat = stat;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_set_col_stat - set (change) column status
+*
+* SYNOPSIS
+*
+* void glp_set_col_stat(glp_prob *lp, int j, int stat);
+*
+* DESCRIPTION
+*
+* The routine glp_set_col_stat sets (changes) status of the structural
+* variable associated with j-th column.
+*
+* The new status of the structural variable should be specified by the
+* parameter stat as follows:
+*
+* GLP_BS - basic variable;
+* GLP_NL - non-basic variable;
+* GLP_NU - non-basic variable on its upper bound; if the variable is
+* not double-bounded, this means the same as GLP_NL (only in
+* case of this routine);
+* GLP_NF - the same as GLP_NL (only in case of this routine);
+* GLP_NS - the same as GLP_NL (only in case of this routine). */
+
+void glp_set_col_stat(glp_prob *lp, int j, int stat)
+{ GLPCOL *col;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_set_col_stat: j = %d; column number out of range\n"
+ , j);
+ if (!(stat == GLP_BS || stat == GLP_NL || stat == GLP_NU ||
+ stat == GLP_NF || stat == GLP_NS))
+ xerror("glp_set_col_stat: j = %d; stat = %d; invalid status\n",
+ j, stat);
+ col = lp->col[j];
+ if (stat != GLP_BS)
+ { switch (col->type)
+ { case GLP_FR: stat = GLP_NF; break;
+ case GLP_LO: stat = GLP_NL; break;
+ case GLP_UP: stat = GLP_NU; break;
+ case GLP_DB: if (stat != GLP_NU) stat = GLP_NL; break;
+ case GLP_FX: stat = GLP_NS; break;
+ default: xassert(col != col);
+ }
+ }
+ if (col->stat == GLP_BS && stat != GLP_BS ||
+ col->stat != GLP_BS && stat == GLP_BS)
+ { /* invalidate the basis factorization */
+ lp->valid = 0;
+ }
+ col->stat = stat;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_std_basis - construct standard initial LP basis
+*
+* SYNOPSIS
+*
+* void glp_std_basis(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_std_basis builds the "standard" (trivial) initial
+* basis for the specified problem object.
+*
+* In the "standard" basis all auxiliary variables are basic, and all
+* structural variables are non-basic. */
+
+void glp_std_basis(glp_prob *lp)
+{ int i, j;
+ /* make all auxiliary variables basic */
+ for (i = 1; i <= lp->m; i++)
+ glp_set_row_stat(lp, i, GLP_BS);
+ /* make all structural variables non-basic */
+ for (j = 1; j <= lp->n; j++)
+ { GLPCOL *col = lp->col[j];
+ if (col->type == GLP_DB && fabs(col->lb) > fabs(col->ub))
+ glp_set_col_stat(lp, j, GLP_NU);
+ else
+ glp_set_col_stat(lp, j, GLP_NL);
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prrngs.c b/test/monniaux/glpk-4.65/src/api/prrngs.c
new file mode 100644
index 00000000..41a141ff
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prrngs.c
@@ -0,0 +1,302 @@
+/* prrngs.c (print sensitivity analysis report) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+static char *format(char buf[13+1], double x)
+{ /* format floating-point number in MPS/360-like style */
+ if (x == -DBL_MAX)
+ strcpy(buf, " -Inf");
+ else if (x == +DBL_MAX)
+ strcpy(buf, " +Inf");
+ else if (fabs(x) <= 999999.99998)
+ { sprintf(buf, "%13.5f", x);
+#if 1
+ if (strcmp(buf, " 0.00000") == 0 ||
+ strcmp(buf, " -0.00000") == 0)
+ strcpy(buf, " . ");
+ else if (memcmp(buf, " 0.", 8) == 0)
+ memcpy(buf, " .", 8);
+ else if (memcmp(buf, " -0.", 8) == 0)
+ memcpy(buf, " -.", 8);
+#endif
+ }
+ else
+ sprintf(buf, "%13.6g", x);
+ return buf;
+}
+
+int glp_print_ranges(glp_prob *P, int len, const int list[],
+ int flags, const char *fname)
+{ /* print sensitivity analysis report */
+ glp_file *fp = NULL;
+ GLPROW *row;
+ GLPCOL *col;
+ int m, n, pass, k, t, numb, type, stat, var1, var2, count, page,
+ ret;
+ double lb, ub, slack, coef, prim, dual, value1, value2, coef1,
+ coef2, obj1, obj2;
+ const char *name, *limit;
+ char buf[13+1];
+ /* sanity checks */
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_print_ranges: P = %p; invalid problem object\n",
+ P);
+#endif
+ m = P->m, n = P->n;
+ if (len < 0)
+ xerror("glp_print_ranges: len = %d; invalid list length\n",
+ len);
+ if (len > 0)
+ { if (list == NULL)
+ xerror("glp_print_ranges: list = %p: invalid parameter\n",
+ list);
+ for (t = 1; t <= len; t++)
+ { k = list[t];
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_print_ranges: list[%d] = %d; row/column numb"
+ "er out of range\n", t, k);
+ }
+ }
+ if (flags != 0)
+ xerror("glp_print_ranges: flags = %d; invalid parameter\n",
+ flags);
+ if (fname == NULL)
+ xerror("glp_print_ranges: fname = %p; invalid parameter\n",
+ fname);
+ if (glp_get_status(P) != GLP_OPT)
+ { xprintf("glp_print_ranges: optimal basic solution required\n");
+ ret = 1;
+ goto done;
+ }
+ if (!glp_bf_exists(P))
+ { xprintf("glp_print_ranges: basis factorization required\n");
+ ret = 2;
+ goto done;
+ }
+ /* start reporting */
+ xprintf("Write sensitivity analysis report to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 3;
+ goto done;
+ }
+ page = count = 0;
+ for (pass = 1; pass <= 2; pass++)
+ for (t = 1; t <= (len == 0 ? m+n : len); t++)
+ { if (t == 1) count = 0;
+ k = (len == 0 ? t : list[t]);
+ if (pass == 1 && k > m || pass == 2 && k <= m)
+ continue;
+ if (count == 0)
+ { xfprintf(fp, "GLPK %-4s - SENSITIVITY ANALYSIS REPORT%73sPa"
+ "ge%4d\n", glp_version(), "", ++page);
+ xfprintf(fp, "\n");
+ xfprintf(fp, "%-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name);
+ xfprintf(fp, "%-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->obj_val,
+ P->dir == GLP_MIN ? "MINimum" :
+ P->dir == GLP_MAX ? "MAXimum" : "???");
+ xfprintf(fp, "\n");
+ xfprintf(fp, "%6s %-12s %2s %13s %13s %13s %13s %13s %13s "
+ "%s\n", "No.", pass == 1 ? "Row name" : "Column name",
+ "St", "Activity", pass == 1 ? "Slack" : "Obj coef",
+ "Lower bound", "Activity", "Obj coef", "Obj value at",
+ "Limiting");
+ xfprintf(fp, "%6s %-12s %2s %13s %13s %13s %13s %13s %13s "
+ "%s\n", "", "", "", "", "Marginal", "Upper bound",
+ "range", "range", "break point", "variable");
+ xfprintf(fp, "------ ------------ -- ------------- --------"
+ "----- ------------- ------------- ------------- ------"
+ "------- ------------\n");
+ }
+ if (pass == 1)
+ { numb = k;
+ xassert(1 <= numb && numb <= m);
+ row = P->row[numb];
+ name = row->name;
+ type = row->type;
+ lb = glp_get_row_lb(P, numb);
+ ub = glp_get_row_ub(P, numb);
+ coef = 0.0;
+ stat = row->stat;
+ prim = row->prim;
+ if (type == GLP_FR)
+ slack = - prim;
+ else if (type == GLP_LO)
+ slack = lb - prim;
+ else if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ slack = ub - prim;
+ dual = row->dual;
+ }
+ else
+ { numb = k - m;
+ xassert(1 <= numb && numb <= n);
+ col = P->col[numb];
+ name = col->name;
+ lb = glp_get_col_lb(P, numb);
+ ub = glp_get_col_ub(P, numb);
+ coef = col->coef;
+ stat = col->stat;
+ prim = col->prim;
+ slack = 0.0;
+ dual = col->dual;
+ }
+ if (stat != GLP_BS)
+ { glp_analyze_bound(P, k, &value1, &var1, &value2, &var2);
+ if (stat == GLP_NF)
+ coef1 = coef2 = coef;
+ else if (stat == GLP_NS)
+ coef1 = -DBL_MAX, coef2 = +DBL_MAX;
+ else if (stat == GLP_NL && P->dir == GLP_MIN ||
+ stat == GLP_NU && P->dir == GLP_MAX)
+ coef1 = coef - dual, coef2 = +DBL_MAX;
+ else
+ coef1 = -DBL_MAX, coef2 = coef - dual;
+ if (value1 == -DBL_MAX)
+ { if (dual < -1e-9)
+ obj1 = +DBL_MAX;
+ else if (dual > +1e-9)
+ obj1 = -DBL_MAX;
+ else
+ obj1 = P->obj_val;
+ }
+ else
+ obj1 = P->obj_val + dual * (value1 - prim);
+ if (value2 == +DBL_MAX)
+ { if (dual < -1e-9)
+ obj2 = -DBL_MAX;
+ else if (dual > +1e-9)
+ obj2 = +DBL_MAX;
+ else
+ obj2 = P->obj_val;
+ }
+ else
+ obj2 = P->obj_val + dual * (value2 - prim);
+ }
+ else
+ { glp_analyze_coef(P, k, &coef1, &var1, &value1, &coef2,
+ &var2, &value2);
+ if (coef1 == -DBL_MAX)
+ { if (prim < -1e-9)
+ obj1 = +DBL_MAX;
+ else if (prim > +1e-9)
+ obj1 = -DBL_MAX;
+ else
+ obj1 = P->obj_val;
+ }
+ else
+ obj1 = P->obj_val + (coef1 - coef) * prim;
+ if (coef2 == +DBL_MAX)
+ { if (prim < -1e-9)
+ obj2 = -DBL_MAX;
+ else if (prim > +1e-9)
+ obj2 = +DBL_MAX;
+ else
+ obj2 = P->obj_val;
+ }
+ else
+ obj2 = P->obj_val + (coef2 - coef) * prim;
+ }
+ /*** first line ***/
+ /* row/column number */
+ xfprintf(fp, "%6d", numb);
+ /* row/column name */
+ xfprintf(fp, " %-12.12s", name == NULL ? "" : name);
+ if (name != NULL && strlen(name) > 12)
+ xfprintf(fp, "%s\n%6s %12s", name+12, "", "");
+ /* row/column status */
+ xfprintf(fp, " %2s",
+ stat == GLP_BS ? "BS" : stat == GLP_NL ? "NL" :
+ stat == GLP_NU ? "NU" : stat == GLP_NF ? "NF" :
+ stat == GLP_NS ? "NS" : "??");
+ /* row/column activity */
+ xfprintf(fp, " %s", format(buf, prim));
+ /* row slack, column objective coefficient */
+ xfprintf(fp, " %s", format(buf, k <= m ? slack : coef));
+ /* row/column lower bound */
+ xfprintf(fp, " %s", format(buf, lb));
+ /* row/column activity range */
+ xfprintf(fp, " %s", format(buf, value1));
+ /* row/column objective coefficient range */
+ xfprintf(fp, " %s", format(buf, coef1));
+ /* objective value at break point */
+ xfprintf(fp, " %s", format(buf, obj1));
+ /* limiting variable name */
+ if (var1 != 0)
+ { if (var1 <= m)
+ limit = glp_get_row_name(P, var1);
+ else
+ limit = glp_get_col_name(P, var1 - m);
+ if (limit != NULL)
+ xfprintf(fp, " %s", limit);
+ }
+ xfprintf(fp, "\n");
+ /*** second line ***/
+ xfprintf(fp, "%6s %-12s %2s %13s", "", "", "", "");
+ /* row/column reduced cost */
+ xfprintf(fp, " %s", format(buf, dual));
+ /* row/column upper bound */
+ xfprintf(fp, " %s", format(buf, ub));
+ /* row/column activity range */
+ xfprintf(fp, " %s", format(buf, value2));
+ /* row/column objective coefficient range */
+ xfprintf(fp, " %s", format(buf, coef2));
+ /* objective value at break point */
+ xfprintf(fp, " %s", format(buf, obj2));
+ /* limiting variable name */
+ if (var2 != 0)
+ { if (var2 <= m)
+ limit = glp_get_row_name(P, var2);
+ else
+ limit = glp_get_col_name(P, var2 - m);
+ if (limit != NULL)
+ xfprintf(fp, " %s", limit);
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, "\n");
+ /* print 10 items per page */
+ count = (count + 1) % 10;
+ }
+ xfprintf(fp, "End of report\n");
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 4;
+ goto done;
+ }
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/prsol.c b/test/monniaux/glpk-4.65/src/api/prsol.c
new file mode 100644
index 00000000..d785dc2e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/prsol.c
@@ -0,0 +1,202 @@
+/* prsol.c (write basic solution in printable format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+int glp_print_sol(glp_prob *P, const char *fname)
+{ /* write basic solution in printable format */
+ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, t, ae_ind, re_ind, ret;
+ double ae_max, re_max;
+ xprintf("Writing basic solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "%-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name);
+ xfprintf(fp, "%-12s%d\n", "Rows:", P->m);
+ xfprintf(fp, "%-12s%d\n", "Columns:", P->n);
+ xfprintf(fp, "%-12s%d\n", "Non-zeros:", P->nnz);
+ t = glp_get_status(P);
+ xfprintf(fp, "%-12s%s\n", "Status:",
+ t == GLP_OPT ? "OPTIMAL" :
+ t == GLP_FEAS ? "FEASIBLE" :
+ t == GLP_INFEAS ? "INFEASIBLE (INTERMEDIATE)" :
+ t == GLP_NOFEAS ? "INFEASIBLE (FINAL)" :
+ t == GLP_UNBND ? "UNBOUNDED" :
+ t == GLP_UNDEF ? "UNDEFINED" : "???");
+ xfprintf(fp, "%-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->obj_val,
+ P->dir == GLP_MIN ? "MINimum" :
+ P->dir == GLP_MAX ? "MAXimum" : "???");
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Row name St Activity Lower bound "
+ " Upper bound Marginal\n");
+ xfprintf(fp, "------ ------------ -- ------------- ------------- "
+ "------------- -------------\n");
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ xfprintf(fp, "%6d ", i);
+ if (row->name == NULL || strlen(row->name) <= 12)
+ xfprintf(fp, "%-12s ", row->name == NULL ? "" : row->name);
+ else
+ xfprintf(fp, "%s\n%20s", row->name, "");
+ xfprintf(fp, "%s ",
+ row->stat == GLP_BS ? "B " :
+ row->stat == GLP_NL ? "NL" :
+ row->stat == GLP_NU ? "NU" :
+ row->stat == GLP_NF ? "NF" :
+ row->stat == GLP_NS ? "NS" : "??");
+ xfprintf(fp, "%13.6g ",
+ fabs(row->prim) <= 1e-9 ? 0.0 : row->prim);
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", row->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (row->type == GLP_UP || row->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", row->ub);
+ else
+ xfprintf(fp, "%13s ", row->type == GLP_FX ? "=" : "");
+ if (row->stat != GLP_BS)
+ { if (fabs(row->dual) <= 1e-9)
+ xfprintf(fp, "%13s", "< eps");
+ else
+ xfprintf(fp, "%13.6g ", row->dual);
+ }
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, " No. Column name St Activity Lower bound "
+ " Upper bound Marginal\n");
+ xfprintf(fp, "------ ------------ -- ------------- ------------- "
+ "------------- -------------\n");
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ xfprintf(fp, "%6d ", j);
+ if (col->name == NULL || strlen(col->name) <= 12)
+ xfprintf(fp, "%-12s ", col->name == NULL ? "" : col->name);
+ else
+ xfprintf(fp, "%s\n%20s", col->name, "");
+ xfprintf(fp, "%s ",
+ col->stat == GLP_BS ? "B " :
+ col->stat == GLP_NL ? "NL" :
+ col->stat == GLP_NU ? "NU" :
+ col->stat == GLP_NF ? "NF" :
+ col->stat == GLP_NS ? "NS" : "??");
+ xfprintf(fp, "%13.6g ",
+ fabs(col->prim) <= 1e-9 ? 0.0 : col->prim);
+ if (col->type == GLP_LO || col->type == GLP_DB ||
+ col->type == GLP_FX)
+ xfprintf(fp, "%13.6g ", col->lb);
+ else
+ xfprintf(fp, "%13s ", "");
+ if (col->type == GLP_UP || col->type == GLP_DB)
+ xfprintf(fp, "%13.6g ", col->ub);
+ else
+ xfprintf(fp, "%13s ", col->type == GLP_FX ? "=" : "");
+ if (col->stat != GLP_BS)
+ { if (fabs(col->dual) <= 1e-9)
+ xfprintf(fp, "%13s", "< eps");
+ else
+ xfprintf(fp, "%13.6g ", col->dual);
+ }
+ xfprintf(fp, "\n");
+ }
+ xfprintf(fp, "\n");
+ xfprintf(fp, "Karush-Kuhn-Tucker optimality conditions:\n");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_SOL, GLP_KKT_PE, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PE: max.abs.err = %.2e on row %d\n",
+ ae_max, ae_ind);
+ xfprintf(fp, " max.rel.err = %.2e on row %d\n",
+ re_max, re_ind);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "PRIMAL SOLUTION IS WRONG");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_SOL, GLP_KKT_PB, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.PB: max.abs.err = %.2e on %s %d\n",
+ ae_max, ae_ind <= P->m ? "row" : "column",
+ ae_ind <= P->m ? ae_ind : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on %s %d\n",
+ re_max, re_ind <= P->m ? "row" : "column",
+ re_ind <= P->m ? re_ind : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "PRIMAL SOLUTION IS INFEASIBL"
+ "E");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_SOL, GLP_KKT_DE, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.DE: max.abs.err = %.2e on column %d\n",
+ ae_max, ae_ind == 0 ? 0 : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on column %d\n",
+ re_max, re_ind == 0 ? 0 : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "DUAL SOLUTION IS WRONG");
+ xfprintf(fp, "\n");
+ glp_check_kkt(P, GLP_SOL, GLP_KKT_DB, &ae_max, &ae_ind, &re_max,
+ &re_ind);
+ xfprintf(fp, "KKT.DB: max.abs.err = %.2e on %s %d\n",
+ ae_max, ae_ind <= P->m ? "row" : "column",
+ ae_ind <= P->m ? ae_ind : ae_ind - P->m);
+ xfprintf(fp, " max.rel.err = %.2e on %s %d\n",
+ re_max, re_ind <= P->m ? "row" : "column",
+ re_ind <= P->m ? re_ind : re_ind - P->m);
+ xfprintf(fp, "%8s%s\n", "",
+ re_max <= 1e-9 ? "High quality" :
+ re_max <= 1e-6 ? "Medium quality" :
+ re_max <= 1e-3 ? "Low quality" : "DUAL SOLUTION IS INFEASIBLE")
+ ;
+ xfprintf(fp, "\n");
+ xfprintf(fp, "End of output\n");
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdasn.c b/test/monniaux/glpk-4.65/src/api/rdasn.c
new file mode 100644
index 00000000..05dcb9fc
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdasn.c
@@ -0,0 +1,164 @@
+/* rdasn.c (read assignment problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "glpk.h"
+#include "misc.h"
+
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+/***********************************************************************
+* NAME
+*
+* glp_read_asnprob - read assignment problem data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_read_asnprob(glp_graph *G, int v_set, int a_cost,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_asnprob reads assignment problem data in DIMACS
+* format from a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_asnprob(glp_graph *G, int v_set, int a_cost, const char
+ *fname)
+{ DMX _csa, *csa = &_csa;
+ glp_vertex *v;
+ glp_arc *a;
+ int nv, na, n1, i, j, k, ret = 0;
+ double cost;
+ char *flag = NULL;
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_read_asnprob: v_set = %d; invalid offset\n",
+ v_set);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_read_asnprob: a_cost = %d; invalid offset\n",
+ a_cost);
+ glp_erase_graph(G, G->v_size, G->a_size);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading assignment problem data from '%s'...\n", fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "asn") != 0)
+ error(csa, "wrong problem designator; 'asn' expected");
+ read_field(csa);
+ if (!(str2int(csa->field, &nv) == 0 && nv >= 0))
+ error(csa, "number of nodes missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &na) == 0 && na >= 0))
+ error(csa, "number of arcs missing or invalid");
+ if (nv > 0) glp_add_vertices(G, nv);
+ end_of_line(csa);
+ /* read node descriptor lines */
+ flag = xcalloc(1+nv, sizeof(char));
+ memset(&flag[1], 0, nv * sizeof(char));
+ n1 = 0;
+ for (;;)
+ { read_designator(csa);
+ if (strcmp(csa->field, "n") != 0) break;
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "node number %d out of range", i);
+ if (flag[i])
+ error(csa, "duplicate descriptor of node %d", i);
+ flag[i] = 1, n1++;
+ end_of_line(csa);
+ }
+ xprintf(
+ "Assignment problem has %d + %d = %d node%s and %d arc%s\n",
+ n1, nv - n1, nv, nv == 1 ? "" : "s", na, na == 1 ? "" : "s");
+ if (v_set >= 0)
+ { for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ k = (flag[i] ? 0 : 1);
+ memcpy((char *)v->data + v_set, &k, sizeof(int));
+ }
+ }
+ /* read arc descriptor lines */
+ for (k = 1; k <= na; k++)
+ { if (k > 1) read_designator(csa);
+ if (strcmp(csa->field, "a") != 0)
+ error(csa, "wrong line designator; 'a' expected");
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "starting node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "starting node number %d out of range", i);
+ if (!flag[i])
+ error(csa, "node %d cannot be a starting node", i);
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "ending node number missing or invalid");
+ if (!(1 <= j && j <= nv))
+ error(csa, "ending node number %d out of range", j);
+ if (flag[j])
+ error(csa, "node %d cannot be an ending node", j);
+ read_field(csa);
+ if (str2num(csa->field, &cost) != 0)
+ error(csa, "arc cost missing or invalid");
+ check_int(csa, cost);
+ a = glp_add_arc(G, i, j);
+ if (a_cost >= 0)
+ memcpy((char *)a->data + a_cost, &cost, sizeof(double));
+ end_of_line(csa);
+ }
+ xprintf("%d lines were read\n", csa->count);
+done: if (ret) glp_erase_graph(G, G->v_size, G->a_size);
+ if (csa->fp != NULL) glp_close(csa->fp);
+ if (flag != NULL) xfree(flag);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdcc.c b/test/monniaux/glpk-4.65/src/api/rdcc.c
new file mode 100644
index 00000000..c63d60d8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdcc.c
@@ -0,0 +1,162 @@
+/* rdcc.c (read graph in DIMACS clique/coloring format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "glpk.h"
+#include "misc.h"
+
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+/***********************************************************************
+* NAME
+*
+* glp_read_ccdata - read graph in DIMACS clique/coloring format
+*
+* SYNOPSIS
+*
+* int glp_read_ccdata(glp_graph *G, int v_wgt, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_ccdata reads an (undirected) graph in DIMACS
+* clique/coloring format from a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_ccdata(glp_graph *G, int v_wgt, const char *fname)
+{ DMX _csa, *csa = &_csa;
+ glp_vertex *v;
+ int i, j, k, nv, ne, ret = 0;
+ double w;
+ char *flag = NULL;
+ if (v_wgt >= 0 && v_wgt > G->v_size - (int)sizeof(double))
+ xerror("glp_read_ccdata: v_wgt = %d; invalid offset\n",
+ v_wgt);
+ glp_erase_graph(G, G->v_size, G->a_size);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading graph from '%s'...\n", fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "edge") != 0)
+ error(csa, "wrong problem designator; 'edge' expected");
+ read_field(csa);
+ if (!(str2int(csa->field, &nv) == 0 && nv >= 0))
+ error(csa, "number of vertices missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &ne) == 0 && ne >= 0))
+ error(csa, "number of edges missing or invalid");
+ xprintf("Graph has %d vert%s and %d edge%s\n",
+ nv, nv == 1 ? "ex" : "ices", ne, ne == 1 ? "" : "s");
+ if (nv > 0) glp_add_vertices(G, nv);
+ end_of_line(csa);
+ /* read node descriptor lines */
+ flag = xcalloc(1+nv, sizeof(char));
+ memset(&flag[1], 0, nv * sizeof(char));
+ if (v_wgt >= 0)
+ { w = 1.0;
+ for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_wgt, &w, sizeof(double));
+ }
+ }
+ for (;;)
+ { read_designator(csa);
+ if (strcmp(csa->field, "n") != 0) break;
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "vertex number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "vertex number %d out of range", i);
+ if (flag[i])
+ error(csa, "duplicate descriptor of vertex %d", i);
+ read_field(csa);
+ if (str2num(csa->field, &w) != 0)
+ error(csa, "vertex weight missing or invalid");
+ check_int(csa, w);
+ if (v_wgt >= 0)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_wgt, &w, sizeof(double));
+ }
+ flag[i] = 1;
+ end_of_line(csa);
+ }
+ xfree(flag), flag = NULL;
+ /* read edge descriptor lines */
+ for (k = 1; k <= ne; k++)
+ { if (k > 1) read_designator(csa);
+ if (strcmp(csa->field, "e") != 0)
+ error(csa, "wrong line designator; 'e' expected");
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "first vertex number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "first vertex number %d out of range", i);
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "second vertex number missing or invalid");
+ if (!(1 <= j && j <= nv))
+ error(csa, "second vertex number %d out of range", j);
+ glp_add_arc(G, i, j);
+ end_of_line(csa);
+ }
+ xprintf("%d lines were read\n", csa->count);
+done: if (ret) glp_erase_graph(G, G->v_size, G->a_size);
+ if (csa->fp != NULL) glp_close(csa->fp);
+ if (flag != NULL) xfree(flag);
+ return ret;
+}
+
+/**********************************************************************/
+
+int glp_read_graph(glp_graph *G, const char *fname)
+{ return
+ glp_read_ccdata(G, -1, fname);
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdcnf.c b/test/monniaux/glpk-4.65/src/api/rdcnf.c
new file mode 100644
index 00000000..acab50fe
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdcnf.c
@@ -0,0 +1,136 @@
+/* rdcnf.c (read CNF-SAT problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "misc.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+int glp_read_cnfsat(glp_prob *P, const char *fname)
+{ /* read CNF-SAT problem data in DIMACS format */
+ DMX _csa, *csa = &_csa;
+ int m, n, i, j, len, neg, rhs, ret = 0, *ind = NULL;
+ double *val = NULL;
+ char *map = NULL;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_read_cnfsat: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (fname == NULL)
+ xerror("glp_read_cnfsat: fname = %p; invalid parameter\n",
+ fname);
+ glp_erase_prob(P);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading CNF-SAT problem data from '%s'...\n", fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "cnf") != 0)
+ error(csa, "wrong problem designator; 'cnf' expected\n");
+ read_field(csa);
+ if (!(str2int(csa->field, &n) == 0 && n >= 0))
+ error(csa, "number of variables missing or invalid\n");
+ read_field(csa);
+ if (!(str2int(csa->field, &m) == 0 && m >= 0))
+ error(csa, "number of clauses missing or invalid\n");
+ xprintf("Instance has %d variable%s and %d clause%s\n",
+ n, n == 1 ? "" : "s", m, m == 1 ? "" : "s");
+ end_of_line(csa);
+ if (m > 0)
+ glp_add_rows(P, m);
+ if (n > 0)
+ { glp_add_cols(P, n);
+ for (j = 1; j <= n; j++)
+ glp_set_col_kind(P, j, GLP_BV);
+ }
+ /* allocate working arrays */
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ map = xcalloc(1+n, sizeof(char));
+ for (j = 1; j <= n; j++) map[j] = 0;
+ /* read clauses */
+ for (i = 1; i <= m; i++)
+ { /* read i-th clause */
+ len = 0, rhs = 1;
+ for (;;)
+ { /* skip white-space characters */
+ while (csa->c == ' ' || csa->c == '\n')
+ read_char(csa);
+ /* read term */
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "variable number missing or invalid\n");
+ if (j > 0)
+ neg = 0;
+ else if (j < 0)
+ neg = 1, j = -j, rhs--;
+ else
+ break;
+ if (!(1 <= j && j <= n))
+ error(csa, "variable number out of range\n");
+ if (map[j])
+ error(csa, "duplicate variable number\n");
+ len++, ind[len] = j, val[len] = (neg ? -1.0 : +1.0);
+ map[j] = 1;
+ }
+ glp_set_row_bnds(P, i, GLP_LO, (double)rhs, 0.0);
+ glp_set_mat_row(P, i, len, ind, val);
+ while (len > 0) map[ind[len--]] = 0;
+ }
+ xprintf("%d lines were read\n", csa->count);
+ /* problem data has been successfully read */
+ glp_sort_matrix(P);
+done: if (csa->fp != NULL) glp_close(csa->fp);
+ if (ind != NULL) xfree(ind);
+ if (val != NULL) xfree(val);
+ if (map != NULL) xfree(map);
+ if (ret) glp_erase_prob(P);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdipt.c b/test/monniaux/glpk-4.65/src/api/rdipt.c
new file mode 100644
index 00000000..aaf8e9d4
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdipt.c
@@ -0,0 +1,185 @@
+/* rdipt.c (read interior-point solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_read_ipt - read interior-point solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_read_ipt(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_ipt reads interior-point solution from a text
+* file in GLPK format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_ipt(glp_prob *P, const char *fname)
+{ DMX dmx_, *dmx = &dmx_;
+ int i, j, k, m, n, sst, ret = 1;
+ char *stat = NULL;
+ double obj, *prim = NULL, *dual = NULL;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_read_ipt: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_read_ipt: fname = %d; invalid parameter\n", fname);
+ if (setjmp(dmx->jump))
+ goto done;
+ dmx->fname = fname;
+ dmx->fp = NULL;
+ dmx->count = 0;
+ dmx->c = '\n';
+ dmx->field[0] = '\0';
+ dmx->empty = dmx->nonint = 0;
+ xprintf("Reading interior-point solution from '%s'...\n", fname);
+ dmx->fp = glp_open(fname, "r");
+ if (dmx->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* read solution line */
+ dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "s") != 0)
+ dmx_error(dmx, "solution line missing or invalid");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "ipt") != 0)
+ dmx_error(dmx, "wrong solution designator; 'ipt' expected");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &m) == 0 && m >= 0))
+ dmx_error(dmx, "number of rows missing or invalid");
+ if (m != P->m)
+ dmx_error(dmx, "number of rows mismatch");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &n) == 0 && n >= 0))
+ dmx_error(dmx, "number of columns missing or invalid");
+ if (n != P->n)
+ dmx_error(dmx, "number of columns mismatch");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "o") == 0)
+ sst = GLP_OPT;
+ else if (strcmp(dmx->field, "i") == 0)
+ sst = GLP_INFEAS;
+ else if (strcmp(dmx->field, "n") == 0)
+ sst = GLP_NOFEAS;
+ else if (strcmp(dmx->field, "u") == 0)
+ sst = GLP_UNDEF;
+ else
+ dmx_error(dmx, "solution status missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &obj) != 0)
+ dmx_error(dmx, "objective value missing or invalid");
+ dmx_end_of_line(dmx);
+ /* allocate working arrays */
+ stat = xalloc(1+m+n, sizeof(stat[0]));
+ for (k = 1; k <= m+n; k++)
+ stat[k] = '?';
+ prim = xalloc(1+m+n, sizeof(prim[0]));
+ dual = xalloc(1+m+n, sizeof(dual[0]));
+ /* read solution descriptor lines */
+ for (;;)
+ { dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "i") == 0)
+ { /* row solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &i) != 0)
+ dmx_error(dmx, "row number missing or invalid");
+ if (!(1 <= i && i <= m))
+ dmx_error(dmx, "row number out of range");
+ if (stat[i] != '?')
+ dmx_error(dmx, "duplicate row solution descriptor");
+ stat[i] = GLP_BS;
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[i]) != 0)
+ dmx_error(dmx, "row primal value missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &dual[i]) != 0)
+ dmx_error(dmx, "row dual value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "j") == 0)
+ { /* column solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &j) != 0)
+ dmx_error(dmx, "column number missing or invalid");
+ if (!(1 <= j && j <= n))
+ dmx_error(dmx, "column number out of range");
+ if (stat[m+j] != '?')
+ dmx_error(dmx, "duplicate column solution descriptor");
+ stat[m+j] = GLP_BS;
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[m+j]) != 0)
+ dmx_error(dmx, "column primal value missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &dual[m+j]) != 0)
+ dmx_error(dmx, "column dual value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "e") == 0)
+ break;
+ else
+ dmx_error(dmx, "line designator missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ /* store solution components into problem object */
+ for (k = 1; k <= m+n; k++)
+ { if (stat[k] == '?')
+ dmx_error(dmx, "incomplete interior-point solution");
+ }
+ P->ipt_stat = sst;
+ P->ipt_obj = obj;
+ for (i = 1; i <= m; i++)
+ { P->row[i]->pval = prim[i];
+ P->row[i]->dval = dual[i];
+ }
+ for (j = 1; j <= n; j++)
+ { P->col[j]->pval = prim[m+j];
+ P->col[j]->dval = dual[m+j];
+ }
+ /* interior-point solution has been successfully read */
+ xprintf("%d lines were read\n", dmx->count);
+ ret = 0;
+done: if (dmx->fp != NULL)
+ glp_close(dmx->fp);
+ if (stat != NULL)
+ xfree(stat);
+ if (prim != NULL)
+ xfree(prim);
+ if (dual != NULL)
+ xfree(dual);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdmaxf.c b/test/monniaux/glpk-4.65/src/api/rdmaxf.c
new file mode 100644
index 00000000..a45405c9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdmaxf.c
@@ -0,0 +1,163 @@
+/* rdmaxf.c (read maximum flow problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "glpk.h"
+#include "misc.h"
+
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+/***********************************************************************
+* NAME
+*
+* glp_read_maxflow - read maximum flow problem data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_read_maxflow(glp_graph *G, int *s, int *t, int a_cap,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_maxflow reads maximum flow problem data in
+* DIMACS format from a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_maxflow(glp_graph *G, int *_s, int *_t, int a_cap,
+ const char *fname)
+{ DMX _csa, *csa = &_csa;
+ glp_arc *a;
+ int i, j, k, s, t, nv, na, ret = 0;
+ double cap;
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_read_maxflow: a_cap = %d; invalid offset\n",
+ a_cap);
+ glp_erase_graph(G, G->v_size, G->a_size);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading maximum flow problem data from '%s'...\n",
+ fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "max") != 0)
+ error(csa, "wrong problem designator; 'max' expected");
+ read_field(csa);
+ if (!(str2int(csa->field, &nv) == 0 && nv >= 2))
+ error(csa, "number of nodes missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &na) == 0 && na >= 0))
+ error(csa, "number of arcs missing or invalid");
+ xprintf("Flow network has %d node%s and %d arc%s\n",
+ nv, nv == 1 ? "" : "s", na, na == 1 ? "" : "s");
+ if (nv > 0) glp_add_vertices(G, nv);
+ end_of_line(csa);
+ /* read node descriptor lines */
+ s = t = 0;
+ for (;;)
+ { read_designator(csa);
+ if (strcmp(csa->field, "n") != 0) break;
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "node number %d out of range", i);
+ read_field(csa);
+ if (strcmp(csa->field, "s") == 0)
+ { if (s > 0)
+ error(csa, "only one source node allowed");
+ s = i;
+ }
+ else if (strcmp(csa->field, "t") == 0)
+ { if (t > 0)
+ error(csa, "only one sink node allowed");
+ t = i;
+ }
+ else
+ error(csa, "wrong node designator; 's' or 't' expected");
+ if (s > 0 && s == t)
+ error(csa, "source and sink nodes must be distinct");
+ end_of_line(csa);
+ }
+ if (s == 0)
+ error(csa, "source node descriptor missing\n");
+ if (t == 0)
+ error(csa, "sink node descriptor missing\n");
+ if (_s != NULL) *_s = s;
+ if (_t != NULL) *_t = t;
+ /* read arc descriptor lines */
+ for (k = 1; k <= na; k++)
+ { if (k > 1) read_designator(csa);
+ if (strcmp(csa->field, "a") != 0)
+ error(csa, "wrong line designator; 'a' expected");
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "starting node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "starting node number %d out of range", i);
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "ending node number missing or invalid");
+ if (!(1 <= j && j <= nv))
+ error(csa, "ending node number %d out of range", j);
+ read_field(csa);
+ if (!(str2num(csa->field, &cap) == 0 && cap >= 0.0))
+ error(csa, "arc capacity missing or invalid");
+ check_int(csa, cap);
+ a = glp_add_arc(G, i, j);
+ if (a_cap >= 0)
+ memcpy((char *)a->data + a_cap, &cap, sizeof(double));
+ end_of_line(csa);
+ }
+ xprintf("%d lines were read\n", csa->count);
+done: if (ret) glp_erase_graph(G, G->v_size, G->a_size);
+ if (csa->fp != NULL) glp_close(csa->fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdmcf.c b/test/monniaux/glpk-4.65/src/api/rdmcf.c
new file mode 100644
index 00000000..bab1ec79
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdmcf.c
@@ -0,0 +1,186 @@
+/* rdmcf.c (read min-cost flow problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "glpk.h"
+#include "misc.h"
+
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+/***********************************************************************
+* NAME
+*
+* glp_read_mincost - read min-cost flow problem data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_read_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+* int a_cost, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_mincost reads minimum cost flow problem data in
+* DIMACS format from a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, const char *fname)
+{ DMX _csa, *csa = &_csa;
+ glp_vertex *v;
+ glp_arc *a;
+ int i, j, k, nv, na, ret = 0;
+ double rhs, low, cap, cost;
+ char *flag = NULL;
+ if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_read_mincost: v_rhs = %d; invalid offset\n",
+ v_rhs);
+ if (a_low >= 0 && a_low > G->a_size - (int)sizeof(double))
+ xerror("glp_read_mincost: a_low = %d; invalid offset\n",
+ a_low);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_read_mincost: a_cap = %d; invalid offset\n",
+ a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_read_mincost: a_cost = %d; invalid offset\n",
+ a_cost);
+ glp_erase_graph(G, G->v_size, G->a_size);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading min-cost flow problem data from '%s'...\n",
+ fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "min") != 0)
+ error(csa, "wrong problem designator; 'min' expected");
+ read_field(csa);
+ if (!(str2int(csa->field, &nv) == 0 && nv >= 0))
+ error(csa, "number of nodes missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &na) == 0 && na >= 0))
+ error(csa, "number of arcs missing or invalid");
+ xprintf("Flow network has %d node%s and %d arc%s\n",
+ nv, nv == 1 ? "" : "s", na, na == 1 ? "" : "s");
+ if (nv > 0) glp_add_vertices(G, nv);
+ end_of_line(csa);
+ /* read node descriptor lines */
+ flag = xcalloc(1+nv, sizeof(char));
+ memset(&flag[1], 0, nv * sizeof(char));
+ if (v_rhs >= 0)
+ { rhs = 0.0;
+ for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &rhs, sizeof(double));
+ }
+ }
+ for (;;)
+ { read_designator(csa);
+ if (strcmp(csa->field, "n") != 0) break;
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "node number %d out of range", i);
+ if (flag[i])
+ error(csa, "duplicate descriptor of node %d", i);
+ read_field(csa);
+ if (str2num(csa->field, &rhs) != 0)
+ error(csa, "node supply/demand missing or invalid");
+ check_int(csa, rhs);
+ if (v_rhs >= 0)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_rhs, &rhs, sizeof(double));
+ }
+ flag[i] = 1;
+ end_of_line(csa);
+ }
+ xfree(flag), flag = NULL;
+ /* read arc descriptor lines */
+ for (k = 1; k <= na; k++)
+ { if (k > 1) read_designator(csa);
+ if (strcmp(csa->field, "a") != 0)
+ error(csa, "wrong line designator; 'a' expected");
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "starting node number missing or invalid");
+ if (!(1 <= i && i <= nv))
+ error(csa, "starting node number %d out of range", i);
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "ending node number missing or invalid");
+ if (!(1 <= j && j <= nv))
+ error(csa, "ending node number %d out of range", j);
+ read_field(csa);
+ if (!(str2num(csa->field, &low) == 0 && low >= 0.0))
+ error(csa, "lower bound of arc flow missing or invalid");
+ check_int(csa, low);
+ read_field(csa);
+ if (!(str2num(csa->field, &cap) == 0 && cap >= low))
+ error(csa, "upper bound of arc flow missing or invalid");
+ check_int(csa, cap);
+ read_field(csa);
+ if (str2num(csa->field, &cost) != 0)
+ error(csa, "per-unit cost of arc flow missing or invalid");
+ check_int(csa, cost);
+ a = glp_add_arc(G, i, j);
+ if (a_low >= 0)
+ memcpy((char *)a->data + a_low, &low, sizeof(double));
+ if (a_cap >= 0)
+ memcpy((char *)a->data + a_cap, &cap, sizeof(double));
+ if (a_cost >= 0)
+ memcpy((char *)a->data + a_cost, &cost, sizeof(double));
+ end_of_line(csa);
+ }
+ xprintf("%d lines were read\n", csa->count);
+done: if (ret) glp_erase_graph(G, G->v_size, G->a_size);
+ if (csa->fp != NULL) glp_close(csa->fp);
+ if (flag != NULL) xfree(flag);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdmip.c b/test/monniaux/glpk-4.65/src/api/rdmip.c
new file mode 100644
index 00000000..7aec26b3
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdmip.c
@@ -0,0 +1,172 @@
+/* rdmip.c (read MIP solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_read_mip - read MIP solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_read_mip(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_mip reads MIP solution from a text file in GLPK
+* format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_mip(glp_prob *P, const char *fname)
+{ DMX dmx_, *dmx = &dmx_;
+ int i, j, k, m, n, sst, ret = 1;
+ char *stat = NULL;
+ double obj, *prim = NULL;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_read_mip: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_read_mip: fname = %d; invalid parameter\n", fname);
+ if (setjmp(dmx->jump))
+ goto done;
+ dmx->fname = fname;
+ dmx->fp = NULL;
+ dmx->count = 0;
+ dmx->c = '\n';
+ dmx->field[0] = '\0';
+ dmx->empty = dmx->nonint = 0;
+ xprintf("Reading MIP solution from '%s'...\n", fname);
+ dmx->fp = glp_open(fname, "r");
+ if (dmx->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* read solution line */
+ dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "s") != 0)
+ dmx_error(dmx, "solution line missing or invalid");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "mip") != 0)
+ dmx_error(dmx, "wrong solution designator; 'mip' expected");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &m) == 0 && m >= 0))
+ dmx_error(dmx, "number of rows missing or invalid");
+ if (m != P->m)
+ dmx_error(dmx, "number of rows mismatch");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &n) == 0 && n >= 0))
+ dmx_error(dmx, "number of columns missing or invalid");
+ if (n != P->n)
+ dmx_error(dmx, "number of columns mismatch");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "o") == 0)
+ sst = GLP_OPT;
+ else if (strcmp(dmx->field, "f") == 0)
+ sst = GLP_FEAS;
+ else if (strcmp(dmx->field, "n") == 0)
+ sst = GLP_NOFEAS;
+ else if (strcmp(dmx->field, "u") == 0)
+ sst = GLP_UNDEF;
+ else
+ dmx_error(dmx, "solution status missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &obj) != 0)
+ dmx_error(dmx, "objective value missing or invalid");
+ dmx_end_of_line(dmx);
+ /* allocate working arrays */
+ stat = xalloc(1+m+n, sizeof(stat[0]));
+ for (k = 1; k <= m+n; k++)
+ stat[k] = '?';
+ prim = xalloc(1+m+n, sizeof(prim[0]));
+ /* read solution descriptor lines */
+ for (;;)
+ { dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "i") == 0)
+ { /* row solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &i) != 0)
+ dmx_error(dmx, "row number missing or invalid");
+ if (!(1 <= i && i <= m))
+ dmx_error(dmx, "row number out of range");
+ if (stat[i] != '?')
+ dmx_error(dmx, "duplicate row solution descriptor");
+ stat[i] = GLP_BS;
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[i]) != 0)
+ dmx_error(dmx, "row value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "j") == 0)
+ { /* column solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &j) != 0)
+ dmx_error(dmx, "column number missing or invalid");
+ if (!(1 <= j && j <= n))
+ dmx_error(dmx, "column number out of range");
+ if (stat[m+j] != '?')
+ dmx_error(dmx, "duplicate column solution descriptor");
+ stat[m+j] = GLP_BS;
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[m+j]) != 0)
+ dmx_error(dmx, "column value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "e") == 0)
+ break;
+ else
+ dmx_error(dmx, "line designator missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ /* store solution components into problem object */
+ for (k = 1; k <= m+n; k++)
+ { if (stat[k] == '?')
+ dmx_error(dmx, "incomplete MIP solution");
+ }
+ P->mip_stat = sst;
+ P->mip_obj = obj;
+ for (i = 1; i <= m; i++)
+ P->row[i]->mipx = prim[i];
+ for (j = 1; j <= n; j++)
+ P->col[j]->mipx = prim[m+j];
+ /* MIP solution has been successfully read */
+ xprintf("%d lines were read\n", dmx->count);
+ ret = 0;
+done: if (dmx->fp != NULL)
+ glp_close(dmx->fp);
+ if (stat != NULL)
+ xfree(stat);
+ if (prim != NULL)
+ xfree(prim);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdprob.c b/test/monniaux/glpk-4.65/src/api/rdprob.c
new file mode 100644
index 00000000..1ad544a5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdprob.c
@@ -0,0 +1,377 @@
+/* rdprob.c (read problem data in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "misc.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+#define error dmx_error
+#define warning dmx_warning
+#define read_char dmx_read_char
+#define read_designator dmx_read_designator
+#define read_field dmx_read_field
+#define end_of_line dmx_end_of_line
+#define check_int dmx_check_int
+
+/***********************************************************************
+* NAME
+*
+* glp_read_prob - read problem data in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_read_prob(glp_prob *P, int flags, const char *fname);
+*
+* The routine glp_read_prob reads problem data in GLPK LP/MIP format
+* from a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_prob(glp_prob *P, int flags, const char *fname)
+{ DMX _csa, *csa = &_csa;
+ int mip, m, n, nnz, ne, i, j, k, type, kind, ret, *ln = NULL,
+ *ia = NULL, *ja = NULL;
+ double lb, ub, temp, *ar = NULL;
+ char *rf = NULL, *cf = NULL;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_read_prob: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (flags != 0)
+ xerror("glp_read_prob: flags = %d; invalid parameter\n",
+ flags);
+ if (fname == NULL)
+ xerror("glp_read_prob: fname = %d; invalid parameter\n",
+ fname);
+ glp_erase_prob(P);
+ if (setjmp(csa->jump))
+ { ret = 1;
+ goto done;
+ }
+ csa->fname = fname;
+ csa->fp = NULL;
+ csa->count = 0;
+ csa->c = '\n';
+ csa->field[0] = '\0';
+ csa->empty = csa->nonint = 0;
+ xprintf("Reading problem data from '%s'...\n", fname);
+ csa->fp = glp_open(fname, "r");
+ if (csa->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ longjmp(csa->jump, 1);
+ }
+ /* read problem line */
+ read_designator(csa);
+ if (strcmp(csa->field, "p") != 0)
+ error(csa, "problem line missing or invalid");
+ read_field(csa);
+ if (strcmp(csa->field, "lp") == 0)
+ mip = 0;
+ else if (strcmp(csa->field, "mip") == 0)
+ mip = 1;
+ else
+ error(csa, "wrong problem designator; 'lp' or 'mip' expected");
+ read_field(csa);
+ if (strcmp(csa->field, "min") == 0)
+ glp_set_obj_dir(P, GLP_MIN);
+ else if (strcmp(csa->field, "max") == 0)
+ glp_set_obj_dir(P, GLP_MAX);
+ else
+ error(csa, "objective sense missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &m) == 0 && m >= 0))
+ error(csa, "number of rows missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &n) == 0 && n >= 0))
+ error(csa, "number of columns missing or invalid");
+ read_field(csa);
+ if (!(str2int(csa->field, &nnz) == 0 && nnz >= 0))
+ error(csa, "number of constraint coefficients missing or inval"
+ "id");
+ if (m > 0)
+ { glp_add_rows(P, m);
+ for (i = 1; i <= m; i++)
+ glp_set_row_bnds(P, i, GLP_FX, 0.0, 0.0);
+ }
+ if (n > 0)
+ { glp_add_cols(P, n);
+ for (j = 1; j <= n; j++)
+ { if (!mip)
+ glp_set_col_bnds(P, j, GLP_LO, 0.0, 0.0);
+ else
+ glp_set_col_kind(P, j, GLP_BV);
+ }
+ }
+ end_of_line(csa);
+ /* allocate working arrays */
+ rf = xcalloc(1+m, sizeof(char));
+ memset(rf, 0, 1+m);
+ cf = xcalloc(1+n, sizeof(char));
+ memset(cf, 0, 1+n);
+ ln = xcalloc(1+nnz, sizeof(int));
+ ia = xcalloc(1+nnz, sizeof(int));
+ ja = xcalloc(1+nnz, sizeof(int));
+ ar = xcalloc(1+nnz, sizeof(double));
+ /* read descriptor lines */
+ ne = 0;
+ for (;;)
+ { read_designator(csa);
+ if (strcmp(csa->field, "i") == 0)
+ { /* row descriptor */
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "row number missing or invalid");
+ if (!(1 <= i && i <= m))
+ error(csa, "row number out of range");
+ read_field(csa);
+ if (strcmp(csa->field, "f") == 0)
+ type = GLP_FR;
+ else if (strcmp(csa->field, "l") == 0)
+ type = GLP_LO;
+ else if (strcmp(csa->field, "u") == 0)
+ type = GLP_UP;
+ else if (strcmp(csa->field, "d") == 0)
+ type = GLP_DB;
+ else if (strcmp(csa->field, "s") == 0)
+ type = GLP_FX;
+ else
+ error(csa, "row type missing or invalid");
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { read_field(csa);
+ if (str2num(csa->field, &lb) != 0)
+ error(csa, "row lower bound/fixed value missing or in"
+ "valid");
+ }
+ else
+ lb = 0.0;
+ if (type == GLP_UP || type == GLP_DB)
+ { read_field(csa);
+ if (str2num(csa->field, &ub) != 0)
+ error(csa, "row upper bound missing or invalid");
+ }
+ else
+ ub = 0.0;
+ if (rf[i] & 0x01)
+ error(csa, "duplicate row descriptor");
+ glp_set_row_bnds(P, i, type, lb, ub), rf[i] |= 0x01;
+ }
+ else if (strcmp(csa->field, "j") == 0)
+ { /* column descriptor */
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "column number missing or invalid");
+ if (!(1 <= j && j <= n))
+ error(csa, "column number out of range");
+ if (!mip)
+ kind = GLP_CV;
+ else
+ { read_field(csa);
+ if (strcmp(csa->field, "c") == 0)
+ kind = GLP_CV;
+ else if (strcmp(csa->field, "i") == 0)
+ kind = GLP_IV;
+ else if (strcmp(csa->field, "b") == 0)
+ { kind = GLP_IV;
+ type = GLP_DB, lb = 0.0, ub = 1.0;
+ goto skip;
+ }
+ else
+ error(csa, "column kind missing or invalid");
+ }
+ read_field(csa);
+ if (strcmp(csa->field, "f") == 0)
+ type = GLP_FR;
+ else if (strcmp(csa->field, "l") == 0)
+ type = GLP_LO;
+ else if (strcmp(csa->field, "u") == 0)
+ type = GLP_UP;
+ else if (strcmp(csa->field, "d") == 0)
+ type = GLP_DB;
+ else if (strcmp(csa->field, "s") == 0)
+ type = GLP_FX;
+ else
+ error(csa, "column type missing or invalid");
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { read_field(csa);
+ if (str2num(csa->field, &lb) != 0)
+ error(csa, "column lower bound/fixed value missing or"
+ " invalid");
+ }
+ else
+ lb = 0.0;
+ if (type == GLP_UP || type == GLP_DB)
+ { read_field(csa);
+ if (str2num(csa->field, &ub) != 0)
+ error(csa, "column upper bound missing or invalid");
+ }
+ else
+ ub = 0.0;
+skip: if (cf[j] & 0x01)
+ error(csa, "duplicate column descriptor");
+ glp_set_col_kind(P, j, kind);
+ glp_set_col_bnds(P, j, type, lb, ub), cf[j] |= 0x01;
+ }
+ else if (strcmp(csa->field, "a") == 0)
+ { /* coefficient descriptor */
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "row number missing or invalid");
+ if (!(0 <= i && i <= m))
+ error(csa, "row number out of range");
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "column number missing or invalid");
+ if (!((i == 0 ? 0 : 1) <= j && j <= n))
+ error(csa, "column number out of range");
+ read_field(csa);
+ if (i == 0)
+ { if (str2num(csa->field, &temp) != 0)
+ error(csa, "objective %s missing or invalid",
+ j == 0 ? "constant term" : "coefficient");
+ if (cf[j] & 0x10)
+ error(csa, "duplicate objective %s",
+ j == 0 ? "constant term" : "coefficient");
+ glp_set_obj_coef(P, j, temp), cf[j] |= 0x10;
+ }
+ else
+ { if (str2num(csa->field, &temp) != 0)
+ error(csa, "constraint coefficient missing or invalid"
+ );
+ if (ne == nnz)
+ error(csa, "too many constraint coefficient descripto"
+ "rs");
+ ln[++ne] = csa->count;
+ ia[ne] = i, ja[ne] = j, ar[ne] = temp;
+ }
+ }
+ else if (strcmp(csa->field, "n") == 0)
+ { /* symbolic name descriptor */
+ read_field(csa);
+ if (strcmp(csa->field, "p") == 0)
+ { /* problem name */
+ read_field(csa);
+ if (P->name != NULL)
+ error(csa, "duplicate problem name");
+ glp_set_prob_name(P, csa->field);
+ }
+ else if (strcmp(csa->field, "z") == 0)
+ { /* objective name */
+ read_field(csa);
+ if (P->obj != NULL)
+ error(csa, "duplicate objective name");
+ glp_set_obj_name(P, csa->field);
+ }
+ else if (strcmp(csa->field, "i") == 0)
+ { /* row name */
+ read_field(csa);
+ if (str2int(csa->field, &i) != 0)
+ error(csa, "row number missing or invalid");
+ if (!(1 <= i && i <= m))
+ error(csa, "row number out of range");
+ read_field(csa);
+ if (P->row[i]->name != NULL)
+ error(csa, "duplicate row name");
+ glp_set_row_name(P, i, csa->field);
+ }
+ else if (strcmp(csa->field, "j") == 0)
+ { /* column name */
+ read_field(csa);
+ if (str2int(csa->field, &j) != 0)
+ error(csa, "column number missing or invalid");
+ if (!(1 <= j && j <= n))
+ error(csa, "column number out of range");
+ read_field(csa);
+ if (P->col[j]->name != NULL)
+ error(csa, "duplicate column name");
+ glp_set_col_name(P, j, csa->field);
+ }
+ else
+ error(csa, "object designator missing or invalid");
+ }
+ else if (strcmp(csa->field, "e") == 0)
+ break;
+ else
+ error(csa, "line designator missing or invalid");
+ end_of_line(csa);
+ }
+ if (ne < nnz)
+ error(csa, "too few constraint coefficient descriptors");
+ xassert(ne == nnz);
+ k = glp_check_dup(m, n, ne, ia, ja);
+ xassert(0 <= k && k <= nnz);
+ if (k > 0)
+ { csa->count = ln[k];
+ error(csa, "duplicate constraint coefficient");
+ }
+ glp_load_matrix(P, ne, ia, ja, ar);
+ /* print some statistics */
+ if (P->name != NULL)
+ xprintf("Problem: %s\n", P->name);
+ if (P->obj != NULL)
+ xprintf("Objective: %s\n", P->obj);
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ m, m == 1 ? "" : "s", n, n == 1 ? "" : "s", nnz, nnz == 1 ?
+ "" : "s");
+ if (glp_get_num_int(P) > 0)
+ { int ni = glp_get_num_int(P);
+ int nb = glp_get_num_bin(P);
+ if (ni == 1)
+ { if (nb == 0)
+ xprintf("One variable is integer\n");
+ else
+ xprintf("One variable is binary\n");
+ }
+ else
+ { xprintf("%d integer variables, ", ni);
+ if (nb == 0)
+ xprintf("none");
+ else if (nb == 1)
+ xprintf("one");
+ else if (nb == ni)
+ xprintf("all");
+ else
+ xprintf("%d", nb);
+ xprintf(" of which %s binary\n", nb == 1 ? "is" : "are");
+ }
+ }
+ xprintf("%d lines were read\n", csa->count);
+ /* problem data has been successfully read */
+ glp_sort_matrix(P);
+ ret = 0;
+done: if (csa->fp != NULL) glp_close(csa->fp);
+ if (rf != NULL) xfree(rf);
+ if (cf != NULL) xfree(cf);
+ if (ln != NULL) xfree(ln);
+ if (ia != NULL) xfree(ia);
+ if (ja != NULL) xfree(ja);
+ if (ar != NULL) xfree(ar);
+ if (ret) glp_erase_prob(P);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rdsol.c b/test/monniaux/glpk-4.65/src/api/rdsol.c
new file mode 100644
index 00000000..d85a2562
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rdsol.c
@@ -0,0 +1,225 @@
+/* rdsol.c (read basic solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_read_sol - read basic solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_read_sol(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_read_sol reads basic solution from a text file in
+* GLPK format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_read_sol(glp_prob *P, const char *fname)
+{ DMX dmx_, *dmx = &dmx_;
+ int i, j, k, m, n, pst, dst, ret = 1;
+ char *stat = NULL;
+ double obj, *prim = NULL, *dual = NULL;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_read_sol: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_read_sol: fname = %d; invalid parameter\n", fname);
+ if (setjmp(dmx->jump))
+ goto done;
+ dmx->fname = fname;
+ dmx->fp = NULL;
+ dmx->count = 0;
+ dmx->c = '\n';
+ dmx->field[0] = '\0';
+ dmx->empty = dmx->nonint = 0;
+ xprintf("Reading basic solution from '%s'...\n", fname);
+ dmx->fp = glp_open(fname, "r");
+ if (dmx->fp == NULL)
+ { xprintf("Unable to open '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* read solution line */
+ dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "s") != 0)
+ dmx_error(dmx, "solution line missing or invalid");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "bas") != 0)
+ dmx_error(dmx, "wrong solution designator; 'bas' expected");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &m) == 0 && m >= 0))
+ dmx_error(dmx, "number of rows missing or invalid");
+ if (m != P->m)
+ dmx_error(dmx, "number of rows mismatch");
+ dmx_read_field(dmx);
+ if (!(str2int(dmx->field, &n) == 0 && n >= 0))
+ dmx_error(dmx, "number of columns missing or invalid");
+ if (n != P->n)
+ dmx_error(dmx, "number of columns mismatch");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "u") == 0)
+ pst = GLP_UNDEF;
+ else if (strcmp(dmx->field, "f") == 0)
+ pst = GLP_FEAS;
+ else if (strcmp(dmx->field, "i") == 0)
+ pst = GLP_INFEAS;
+ else if (strcmp(dmx->field, "n") == 0)
+ pst = GLP_NOFEAS;
+ else
+ dmx_error(dmx, "primal solution status missing or invalid");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "u") == 0)
+ dst = GLP_UNDEF;
+ else if (strcmp(dmx->field, "f") == 0)
+ dst = GLP_FEAS;
+ else if (strcmp(dmx->field, "i") == 0)
+ dst = GLP_INFEAS;
+ else if (strcmp(dmx->field, "n") == 0)
+ dst = GLP_NOFEAS;
+ else
+ dmx_error(dmx, "dual solution status missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &obj) != 0)
+ dmx_error(dmx, "objective value missing or invalid");
+ dmx_end_of_line(dmx);
+ /* allocate working arrays */
+ stat = xalloc(1+m+n, sizeof(stat[0]));
+ for (k = 1; k <= m+n; k++)
+ stat[k] = '?';
+ prim = xalloc(1+m+n, sizeof(prim[0]));
+ dual = xalloc(1+m+n, sizeof(dual[0]));
+ /* read solution descriptor lines */
+ for (;;)
+ { dmx_read_designator(dmx);
+ if (strcmp(dmx->field, "i") == 0)
+ { /* row solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &i) != 0)
+ dmx_error(dmx, "row number missing or invalid");
+ if (!(1 <= i && i <= m))
+ dmx_error(dmx, "row number out of range");
+ if (stat[i] != '?')
+ dmx_error(dmx, "duplicate row solution descriptor");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "b") == 0)
+ stat[i] = GLP_BS;
+ else if (strcmp(dmx->field, "l") == 0)
+ stat[i] = GLP_NL;
+ else if (strcmp(dmx->field, "u") == 0)
+ stat[i] = GLP_NU;
+ else if (strcmp(dmx->field, "f") == 0)
+ stat[i] = GLP_NF;
+ else if (strcmp(dmx->field, "s") == 0)
+ stat[i] = GLP_NS;
+ else
+ dmx_error(dmx, "row status missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[i]) != 0)
+ dmx_error(dmx, "row primal value missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &dual[i]) != 0)
+ dmx_error(dmx, "row dual value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "j") == 0)
+ { /* column solution descriptor */
+ dmx_read_field(dmx);
+ if (str2int(dmx->field, &j) != 0)
+ dmx_error(dmx, "column number missing or invalid");
+ if (!(1 <= j && j <= n))
+ dmx_error(dmx, "column number out of range");
+ if (stat[m+j] != '?')
+ dmx_error(dmx, "duplicate column solution descriptor");
+ dmx_read_field(dmx);
+ if (strcmp(dmx->field, "b") == 0)
+ stat[m+j] = GLP_BS;
+ else if (strcmp(dmx->field, "l") == 0)
+ stat[m+j] = GLP_NL;
+ else if (strcmp(dmx->field, "u") == 0)
+ stat[m+j] = GLP_NU;
+ else if (strcmp(dmx->field, "f") == 0)
+ stat[m+j] = GLP_NF;
+ else if (strcmp(dmx->field, "s") == 0)
+ stat[m+j] = GLP_NS;
+ else
+ dmx_error(dmx, "column status missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &prim[m+j]) != 0)
+ dmx_error(dmx, "column primal value missing or invalid");
+ dmx_read_field(dmx);
+ if (str2num(dmx->field, &dual[m+j]) != 0)
+ dmx_error(dmx, "column dual value missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ else if (strcmp(dmx->field, "e") == 0)
+ break;
+ else
+ dmx_error(dmx, "line designator missing or invalid");
+ dmx_end_of_line(dmx);
+ }
+ /* store solution components into problem object */
+ for (k = 1; k <= m+n; k++)
+ { if (stat[k] == '?')
+ dmx_error(dmx, "incomplete basic solution");
+ }
+ P->pbs_stat = pst;
+ P->dbs_stat = dst;
+ P->obj_val = obj;
+ P->it_cnt = 0;
+ P->some = 0;
+ for (i = 1; i <= m; i++)
+ { glp_set_row_stat(P, i, stat[i]);
+ P->row[i]->prim = prim[i];
+ P->row[i]->dual = dual[i];
+ }
+ for (j = 1; j <= n; j++)
+ { glp_set_col_stat(P, j, stat[m+j]);
+ P->col[j]->prim = prim[m+j];
+ P->col[j]->dual = dual[m+j];
+ }
+ /* basic solution has been successfully read */
+ xprintf("%d lines were read\n", dmx->count);
+ ret = 0;
+done: if (dmx->fp != NULL)
+ glp_close(dmx->fp);
+ if (stat != NULL)
+ xfree(stat);
+ if (prim != NULL)
+ xfree(prim);
+ if (dual != NULL)
+ xfree(dual);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/rmfgen.c b/test/monniaux/glpk-4.65/src/api/rmfgen.c
new file mode 100644
index 00000000..a1ba27bb
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/rmfgen.c
@@ -0,0 +1,368 @@
+/* rmfgen.c (Goldfarb's maximum flow problem generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is a modified version of the program RMFGEN, a maxflow
+* problem generator developed by D.Goldfarb and M.Grigoriadis, and
+* originally implemented by Tamas Badics <badics@rutcor.rutgers.edu>.
+* The original code is publically available on the DIMACS ftp site at:
+* <ftp://dimacs.rutgers.edu/pub/netflow/generators/network/genrmf>.
+*
+* All changes concern only the program interface, so this modified
+* version produces exactly the same instances as the original version.
+*
+* Changes were made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "rng.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_rmfgen - Goldfarb's maximum flow problem generator
+*
+* SYNOPSIS
+*
+* int glp_rmfgen(glp_graph *G, int *s, int *t, int a_cap,
+* const int parm[1+5]);
+*
+* DESCRIPTION
+*
+* The routine glp_rmfgen is a maximum flow problem generator developed
+* by D.Goldfarb and M.Grigoriadis.
+*
+* The parameter G specifies the graph object, to which the generated
+* problem data have to be stored. Note that on entry the graph object
+* is erased with the routine glp_erase_graph.
+*
+* The pointer s specifies a location, to which the routine stores the
+* source node number. If s is NULL, the node number is not stored.
+*
+* The pointer t specifies a location, to which the routine stores the
+* sink node number. If t is NULL, the node number is not stored.
+*
+* The parameter a_cap specifies an offset of the field of type double
+* in the arc data block, to which the routine stores the arc capacity.
+* If a_cap < 0, the capacity is not stored.
+*
+* The array parm contains description of the network to be generated:
+*
+* parm[0] not used
+* parm[1] (seed) random number seed (a positive integer)
+* parm[2] (a) frame size
+* parm[3] (b) depth
+* parm[4] (c1) minimal arc capacity
+* parm[5] (c2) maximal arc capacity
+*
+* RETURNS
+*
+* If the instance was successfully generated, the routine glp_netgen
+* returns zero; otherwise, if specified parameters are inconsistent,
+* the routine returns a non-zero error code.
+*
+* COMMENTS
+*
+* The generated network is as follows. It has b pieces of frames of
+* size a * a. (So alltogether the number of vertices is a * a * b)
+*
+* In each frame all the vertices are connected with their neighbours
+* (forth and back). In addition the vertices of a frame are connected
+* one to one with the vertices of next frame using a random permutation
+* of those vertices.
+*
+* The source is the lower left vertex of the first frame, the sink is
+* the upper right vertex of the b'th frame.
+*
+* t
+* +-------+
+* | .|
+* | . |
+* / | / |
+* +-------+/ -+ b
+* | | |/.
+* a | -v- |/
+* | | |/
+* +-------+ 1
+* s a
+*
+* The capacities are randomly chosen integers from the range of [c1,c2]
+* in the case of interconnecting edges, and c2 * a * a for the in-frame
+* edges.
+*
+* REFERENCES
+*
+* D.Goldfarb and M.D.Grigoriadis, "A computational comparison of the
+* Dinic and network simplex methods for maximum flow." Annals of Op.
+* Res. 13 (1988), pp. 83-123.
+*
+* U.Derigs and W.Meier, "Implementing Goldberg's max-flow algorithm:
+* A computational investigation." Zeitschrift fuer Operations Research
+* 33 (1989), pp. 383-403. */
+
+typedef struct VERTEX
+{ struct EDGE **edgelist;
+ /* Pointer to the list of pointers to the adjacent edges.
+ (No matter that to or from edges) */
+ struct EDGE **current;
+ /* Pointer to the current edge */
+ int degree;
+ /* Number of adjacent edges (both direction) */
+ int index;
+} vertex;
+
+typedef struct EDGE
+{ int from;
+ int to;
+ int cap;
+ /* Capacity */
+} edge;
+
+typedef struct NETWORK
+{ struct NETWORK *next, *prev;
+ int vertnum;
+ int edgenum;
+ vertex *verts;
+ /* Vertex array[1..vertnum] */
+ edge *edges;
+ /* Edge array[1..edgenum] */
+ int source;
+ /* Pointer to the source */
+ int sink;
+ /* Pointer to the sink */
+} network;
+
+struct csa
+{ /* common storage area */
+ glp_graph *G;
+ int *s, *t, a_cap;
+ RNG *rand;
+ network *N;
+ int *Parr;
+ int A, AA, C2AA, Ec;
+};
+
+#define G (csa->G)
+#define s (csa->s)
+#define t (csa->t)
+#define a_cap (csa->a_cap)
+#define N (csa->N)
+#define Parr (csa->Parr)
+#define A (csa->A)
+#define AA (csa->AA)
+#define C2AA (csa->C2AA)
+#define Ec (csa->Ec)
+
+#undef random
+#define random(A) (int)(rng_unif_01(csa->rand) * (double)(A))
+#define RANDOM(A, B) (int)(random((B) - (A) + 1) + (A))
+#define sgn(A) (((A) > 0) ? 1 : ((A) == 0) ? 0 : -1)
+
+static void make_edge(struct csa *csa, int from, int to, int c1, int c2)
+{ Ec++;
+ N->edges[Ec].from = from;
+ N->edges[Ec].to = to;
+ N->edges[Ec].cap = RANDOM(c1, c2);
+ return;
+}
+
+static void permute(struct csa *csa)
+{ int i, j, tmp;
+ for (i = 1; i < AA; i++)
+ { j = RANDOM(i, AA);
+ tmp = Parr[i];
+ Parr[i] = Parr[j];
+ Parr[j] = tmp;
+ }
+ return;
+}
+
+static void connect(struct csa *csa, int offset, int cv, int x1, int y1)
+{ int cv1;
+ cv1 = offset + (x1 - 1) * A + y1;
+ Ec++;
+ N->edges[Ec].from = cv;
+ N->edges[Ec].to = cv1;
+ N->edges[Ec].cap = C2AA;
+ return;
+}
+
+static network *gen_rmf(struct csa *csa, int a, int b, int c1, int c2)
+{ /* generates a network with a*a*b nodes and 6a*a*b-4ab-2a*a edges
+ random_frame network:
+ Derigs & Meier, Methods & Models of OR (1989), 33:383-403 */
+ int x, y, z, offset, cv;
+ A = a;
+ AA = a * a;
+ C2AA = c2 * AA;
+ Ec = 0;
+ N = (network *)xmalloc(sizeof(network));
+ N->vertnum = AA * b;
+ N->edgenum = 5 * AA * b - 4 * A * b - AA;
+ N->edges = (edge *)xcalloc(N->edgenum + 1, sizeof(edge));
+ N->source = 1;
+ N->sink = N->vertnum;
+ Parr = (int *)xcalloc(AA + 1, sizeof(int));
+ for (x = 1; x <= AA; x++)
+ Parr[x] = x;
+ for (z = 1; z <= b; z++)
+ { offset = AA * (z - 1);
+ if (z != b)
+ permute(csa);
+ for (x = 1; x <= A; x++)
+ { for (y = 1; y <= A; y++)
+ { cv = offset + (x - 1) * A + y;
+ if (z != b)
+ make_edge(csa, cv, offset + AA + Parr[cv - offset],
+ c1, c2); /* the intermediate edges */
+ if (y < A)
+ connect(csa, offset, cv, x, y + 1);
+ if (y > 1)
+ connect(csa, offset, cv, x, y - 1);
+ if (x < A)
+ connect(csa, offset, cv, x + 1, y);
+ if (x > 1)
+ connect(csa, offset, cv, x - 1, y);
+ }
+ }
+ }
+ xfree(Parr);
+ return N;
+}
+
+static void print_max_format(struct csa *csa, network *n, char *comm[],
+ int dim)
+{ /* prints a network heading with dim lines of comments (no \n
+ needs at the ends) */
+ int i, vnum, e_num;
+ edge *e;
+ vnum = n->vertnum;
+ e_num = n->edgenum;
+ if (G == NULL)
+ { for (i = 0; i < dim; i++)
+ xprintf("c %s\n", comm[i]);
+ xprintf("p max %7d %10d\n", vnum, e_num);
+ xprintf("n %7d s\n", n->source);
+ xprintf("n %7d t\n", n->sink);
+ }
+ else
+ { glp_add_vertices(G, vnum);
+ if (s != NULL) *s = n->source;
+ if (t != NULL) *t = n->sink;
+ }
+ for (i = 1; i <= e_num; i++)
+ { e = &n->edges[i];
+ if (G == NULL)
+ xprintf("a %7d %7d %10d\n", e->from, e->to, (int)e->cap);
+ else
+ { glp_arc *a = glp_add_arc(G, e->from, e->to);
+ if (a_cap >= 0)
+ { double temp = (double)e->cap;
+ memcpy((char *)a->data + a_cap, &temp, sizeof(double));
+ }
+ }
+ }
+ return;
+}
+
+static void gen_free_net(network *n)
+{ xfree(n->edges);
+ xfree(n);
+ return;
+}
+
+int glp_rmfgen(glp_graph *G_, int *_s, int *_t, int _a_cap,
+ const int parm[1+5])
+{ struct csa _csa, *csa = &_csa;
+ network *n;
+ char comm[10][80], *com1[10];
+ int seed, a, b, c1, c2, ret;
+ G = G_;
+ s = _s;
+ t = _t;
+ a_cap = _a_cap;
+ if (G != NULL)
+ { if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_rmfgen: a_cap = %d; invalid offset\n", a_cap);
+ }
+ seed = parm[1];
+ a = parm[2];
+ b = parm[3];
+ c1 = parm[4];
+ c2 = parm[5];
+ if (!(seed > 0 && 1 <= a && a <= 1000 && 1 <= b && b <= 1000 &&
+ 0 <= c1 && c1 <= c2 && c2 <= 1000))
+ { ret = 1;
+ goto done;
+ }
+ if (G != NULL)
+ { glp_erase_graph(G, G->v_size, G->a_size);
+ glp_set_graph_name(G, "RMFGEN");
+ }
+ csa->rand = rng_create_rand();
+ rng_init_rand(csa->rand, seed);
+ n = gen_rmf(csa, a, b, c1, c2);
+ sprintf(comm[0], "This file was generated by genrmf.");
+ sprintf(comm[1], "The parameters are: a: %d b: %d c1: %d c2: %d",
+ a, b, c1, c2);
+ com1[0] = comm[0];
+ com1[1] = comm[1];
+ print_max_format(csa, n, com1, 2);
+ gen_free_net(n);
+ rng_delete_rand(csa->rand);
+ ret = 0;
+done: return ret;
+}
+
+/**********************************************************************/
+
+#if 0
+int main(int argc, char *argv[])
+{ int seed, a, b, c1, c2, i, parm[1+5];
+ seed = 123;
+ a = b = c1 = c2 = -1;
+ for (i = 1; i < argc; i++)
+ { if (strcmp(argv[i], "-seed") == 0)
+ seed = atoi(argv[++i]);
+ else if (strcmp(argv[i], "-a") == 0)
+ a = atoi(argv[++i]);
+ else if (strcmp(argv[i], "-b") == 0)
+ b = atoi(argv[++i]);
+ else if (strcmp(argv[i], "-c1") == 0)
+ c1 = atoi(argv[++i]);
+ else if (strcmp(argv[i], "-c2") == 0)
+ c2 = atoi(argv[++i]);
+ }
+ if (a < 0 || b < 0 || c1 < 0 || c2 < 0)
+ { xprintf("Usage:\n");
+ xprintf("genrmf [-seed seed] -a frame_size -b depth\n");
+ xprintf(" -c1 cap_range1 -c2 cap_range2\n");
+ }
+ else
+ { parm[1] = seed;
+ parm[2] = a;
+ parm[3] = b;
+ parm[4] = c1;
+ parm[5] = c2;
+ glp_rmfgen(NULL, NULL, NULL, 0, parm);
+ }
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/strong.c b/test/monniaux/glpk-4.65/src/api/strong.c
new file mode 100644
index 00000000..9ddcacfb
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/strong.c
@@ -0,0 +1,110 @@
+/* strong.c (find all strongly connected components of graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "mc13d.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_strong_comp - find all strongly connected components of graph
+*
+* SYNOPSIS
+*
+* int glp_strong_comp(glp_graph *G, int v_num);
+*
+* DESCRIPTION
+*
+* The routine glp_strong_comp finds all strongly connected components
+* of the specified graph.
+*
+* The parameter v_num specifies an offset of the field of type int
+* in the vertex data block, to which the routine stores the number of
+* a strongly connected component containing that vertex. If v_num < 0,
+* no component numbers are stored.
+*
+* The components are numbered in arbitrary order from 1 to nc, where
+* nc is the total number of components found, 0 <= nc <= |V|. However,
+* the component numbering has the property that for every arc (i->j)
+* in the graph the condition num(i) >= num(j) holds.
+*
+* RETURNS
+*
+* The routine returns nc, the total number of components found. */
+
+int glp_strong_comp(glp_graph *G, int v_num)
+{ glp_vertex *v;
+ glp_arc *a;
+ int i, k, last, n, na, nc, *icn, *ip, *lenr, *ior, *ib, *lowl,
+ *numb, *prev;
+ if (v_num >= 0 && v_num > G->v_size - (int)sizeof(int))
+ xerror("glp_strong_comp: v_num = %d; invalid offset\n",
+ v_num);
+ n = G->nv;
+ if (n == 0)
+ { nc = 0;
+ goto done;
+ }
+ na = G->na;
+ icn = xcalloc(1+na, sizeof(int));
+ ip = xcalloc(1+n, sizeof(int));
+ lenr = xcalloc(1+n, sizeof(int));
+ ior = xcalloc(1+n, sizeof(int));
+ ib = xcalloc(1+n, sizeof(int));
+ lowl = xcalloc(1+n, sizeof(int));
+ numb = xcalloc(1+n, sizeof(int));
+ prev = xcalloc(1+n, sizeof(int));
+ k = 1;
+ for (i = 1; i <= n; i++)
+ { v = G->v[i];
+ ip[i] = k;
+ for (a = v->out; a != NULL; a = a->t_next)
+ icn[k++] = a->head->i;
+ lenr[i] = k - ip[i];
+ }
+ xassert(na == k-1);
+ nc = mc13d(n, icn, ip, lenr, ior, ib, lowl, numb, prev);
+ if (v_num >= 0)
+ { xassert(ib[1] == 1);
+ for (k = 1; k <= nc; k++)
+ { last = (k < nc ? ib[k+1] : n+1);
+ xassert(ib[k] < last);
+ for (i = ib[k]; i < last; i++)
+ { v = G->v[ior[i]];
+ memcpy((char *)v->data + v_num, &k, sizeof(int));
+ }
+ }
+ }
+ xfree(icn);
+ xfree(ip);
+ xfree(lenr);
+ xfree(ior);
+ xfree(ib);
+ xfree(lowl);
+ xfree(numb);
+ xfree(prev);
+done: return nc;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/topsort.c b/test/monniaux/glpk-4.65/src/api/topsort.c
new file mode 100644
index 00000000..971937f2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/topsort.c
@@ -0,0 +1,123 @@
+/* topsort.c (topological sorting of acyclic digraph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_top_sort - topological sorting of acyclic digraph
+*
+* SYNOPSIS
+*
+* int glp_top_sort(glp_graph *G, int v_num);
+*
+* DESCRIPTION
+*
+* The routine glp_top_sort performs topological sorting of vertices of
+* the specified acyclic digraph.
+*
+* The parameter v_num specifies an offset of the field of type int in
+* the vertex data block, to which the routine stores the vertex number
+* assigned. If v_num < 0, vertex numbers are not stored.
+*
+* The vertices are numbered from 1 to n, where n is the total number
+* of vertices in the graph. The vertex numbering has the property that
+* for every arc (i->j) in the graph the condition num(i) < num(j)
+* holds. Special case num(i) = 0 means that vertex i is not assigned a
+* number, because the graph is *not* acyclic.
+*
+* RETURNS
+*
+* If the graph is acyclic and therefore all the vertices have been
+* assigned numbers, the routine glp_top_sort returns zero. Otherwise,
+* if the graph is not acyclic, the routine returns the number of
+* vertices which have not been numbered, i.e. for which num(i) = 0. */
+
+static int top_sort(glp_graph *G, int num[])
+{ glp_arc *a;
+ int i, j, cnt, top, *stack, *indeg;
+ /* allocate working arrays */
+ indeg = xcalloc(1+G->nv, sizeof(int));
+ stack = xcalloc(1+G->nv, sizeof(int));
+ /* determine initial indegree of each vertex; push into the stack
+ the vertices having zero indegree */
+ top = 0;
+ for (i = 1; i <= G->nv; i++)
+ { num[i] = indeg[i] = 0;
+ for (a = G->v[i]->in; a != NULL; a = a->h_next)
+ indeg[i]++;
+ if (indeg[i] == 0)
+ stack[++top] = i;
+ }
+ /* assign numbers to vertices in the sorted order */
+ cnt = 0;
+ while (top > 0)
+ { /* pull vertex i from the stack */
+ i = stack[top--];
+ /* it has zero indegree in the current graph */
+ xassert(indeg[i] == 0);
+ /* so assign it a next number */
+ xassert(num[i] == 0);
+ num[i] = ++cnt;
+ /* remove vertex i from the current graph, update indegree of
+ its adjacent vertices, and push into the stack new vertices
+ whose indegree becomes zero */
+ for (a = G->v[i]->out; a != NULL; a = a->t_next)
+ { j = a->head->i;
+ /* there exists arc (i->j) in the graph */
+ xassert(indeg[j] > 0);
+ indeg[j]--;
+ if (indeg[j] == 0)
+ stack[++top] = j;
+ }
+ }
+ /* free working arrays */
+ xfree(indeg);
+ xfree(stack);
+ return G->nv - cnt;
+}
+
+int glp_top_sort(glp_graph *G, int v_num)
+{ glp_vertex *v;
+ int i, cnt, *num;
+ if (v_num >= 0 && v_num > G->v_size - (int)sizeof(int))
+ xerror("glp_top_sort: v_num = %d; invalid offset\n", v_num);
+ if (G->nv == 0)
+ { cnt = 0;
+ goto done;
+ }
+ num = xcalloc(1+G->nv, sizeof(int));
+ cnt = top_sort(G, num);
+ if (v_num >= 0)
+ { for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_num, &num[i], sizeof(int));
+ }
+ }
+ xfree(num);
+done: return cnt;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wcliqex.c b/test/monniaux/glpk-4.65/src/api/wcliqex.c
new file mode 100644
index 00000000..53c2d521
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wcliqex.c
@@ -0,0 +1,122 @@
+/* wcliqex.c (find maximum weight clique with exact algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+#include "wclique.h"
+
+static void set_edge(int nv, unsigned char a[], int i, int j)
+{ int k;
+ xassert(1 <= j && j < i && i <= nv);
+ k = ((i - 1) * (i - 2)) / 2 + (j - 1);
+ a[k / CHAR_BIT] |=
+ (unsigned char)(1 << ((CHAR_BIT - 1) - k % CHAR_BIT));
+ return;
+}
+
+int glp_wclique_exact(glp_graph *G, int v_wgt, double *sol, int v_set)
+{ /* find maximum weight clique with exact algorithm */
+ glp_arc *e;
+ int i, j, k, len, x, *w, *ind, ret = 0;
+ unsigned char *a;
+ double s, t;
+ if (v_wgt >= 0 && v_wgt > G->v_size - (int)sizeof(double))
+ xerror("glp_wclique_exact: v_wgt = %d; invalid parameter\n",
+ v_wgt);
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_wclique_exact: v_set = %d; invalid parameter\n",
+ v_set);
+ if (G->nv == 0)
+ { /* empty graph has only empty clique */
+ if (sol != NULL) *sol = 0.0;
+ return 0;
+ }
+ /* allocate working arrays */
+ w = xcalloc(1+G->nv, sizeof(int));
+ ind = xcalloc(1+G->nv, sizeof(int));
+ len = G->nv; /* # vertices */
+ len = len * (len - 1) / 2; /* # entries in lower triangle */
+ len = (len + (CHAR_BIT - 1)) / CHAR_BIT; /* # bytes needed */
+ a = xcalloc(len, sizeof(char));
+ memset(a, 0, len * sizeof(char));
+ /* determine vertex weights */
+ s = 0.0;
+ for (i = 1; i <= G->nv; i++)
+ { if (v_wgt >= 0)
+ { memcpy(&t, (char *)G->v[i]->data + v_wgt, sizeof(double));
+ if (!(0.0 <= t && t <= (double)INT_MAX && t == floor(t)))
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ w[i] = (int)t;
+ }
+ else
+ w[i] = 1;
+ s += (double)w[i];
+ }
+ if (s > (double)INT_MAX)
+ { ret = GLP_EDATA;
+ goto done;
+ }
+ /* build the adjacency matrix */
+ for (i = 1; i <= G->nv; i++)
+ { for (e = G->v[i]->in; e != NULL; e = e->h_next)
+ { j = e->tail->i;
+ /* there exists edge (j,i) in the graph */
+ if (i > j) set_edge(G->nv, a, i, j);
+ }
+ for (e = G->v[i]->out; e != NULL; e = e->t_next)
+ { j = e->head->i;
+ /* there exists edge (i,j) in the graph */
+ if (i > j) set_edge(G->nv, a, i, j);
+ }
+ }
+ /* find maximum weight clique in the graph */
+ len = wclique(G->nv, w, a, ind);
+ /* compute the clique weight */
+ s = 0.0;
+ for (k = 1; k <= len; k++)
+ { i = ind[k];
+ xassert(1 <= i && i <= G->nv);
+ s += (double)w[i];
+ }
+ if (sol != NULL) *sol = s;
+ /* mark vertices included in the clique */
+ if (v_set >= 0)
+ { x = 0;
+ for (i = 1; i <= G->nv; i++)
+ memcpy((char *)G->v[i]->data + v_set, &x, sizeof(int));
+ x = 1;
+ for (k = 1; k <= len; k++)
+ { i = ind[k];
+ memcpy((char *)G->v[i]->data + v_set, &x, sizeof(int));
+ }
+ }
+done: /* free working arrays */
+ xfree(w);
+ xfree(ind);
+ xfree(a);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/weak.c b/test/monniaux/glpk-4.65/src/api/weak.c
new file mode 100644
index 00000000..027c09c1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/weak.c
@@ -0,0 +1,150 @@
+/* weak.c (find all weakly connected components of graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_weak_comp - find all weakly connected components of graph
+*
+* SYNOPSIS
+*
+* int glp_weak_comp(glp_graph *G, int v_num);
+*
+* DESCRIPTION
+*
+* The routine glp_weak_comp finds all weakly connected components of
+* the specified graph.
+*
+* The parameter v_num specifies an offset of the field of type int
+* in the vertex data block, to which the routine stores the number of
+* a (weakly) connected component containing that vertex. If v_num < 0,
+* no component numbers are stored.
+*
+* The components are numbered in arbitrary order from 1 to nc, where
+* nc is the total number of components found, 0 <= nc <= |V|.
+*
+* RETURNS
+*
+* The routine returns nc, the total number of components found. */
+
+int glp_weak_comp(glp_graph *G, int v_num)
+{ glp_vertex *v;
+ glp_arc *a;
+ int f, i, j, nc, nv, pos1, pos2, *prev, *next, *list;
+ if (v_num >= 0 && v_num > G->v_size - (int)sizeof(int))
+ xerror("glp_weak_comp: v_num = %d; invalid offset\n", v_num);
+ nv = G->nv;
+ if (nv == 0)
+ { nc = 0;
+ goto done;
+ }
+ /* allocate working arrays */
+ prev = xcalloc(1+nv, sizeof(int));
+ next = xcalloc(1+nv, sizeof(int));
+ list = xcalloc(1+nv, sizeof(int));
+ /* if vertex i is unlabelled, prev[i] is the index of previous
+ unlabelled vertex, and next[i] is the index of next unlabelled
+ vertex; if vertex i is labelled, then prev[i] < 0, and next[i]
+ is the connected component number */
+ /* initially all vertices are unlabelled */
+ f = 1;
+ for (i = 1; i <= nv; i++)
+ prev[i] = i - 1, next[i] = i + 1;
+ next[nv] = 0;
+ /* main loop (until all vertices have been labelled) */
+ nc = 0;
+ while (f != 0)
+ { /* take an unlabelled vertex */
+ i = f;
+ /* and remove it from the list of unlabelled vertices */
+ f = next[i];
+ if (f != 0) prev[f] = 0;
+ /* label the vertex; it begins a new component */
+ prev[i] = -1, next[i] = ++nc;
+ /* breadth first search */
+ list[1] = i, pos1 = pos2 = 1;
+ while (pos1 <= pos2)
+ { /* dequeue vertex i */
+ i = list[pos1++];
+ /* consider all arcs incoming to vertex i */
+ for (a = G->v[i]->in; a != NULL; a = a->h_next)
+ { /* vertex j is adjacent to vertex i */
+ j = a->tail->i;
+ if (prev[j] >= 0)
+ { /* vertex j is unlabelled */
+ /* remove it from the list of unlabelled vertices */
+ if (prev[j] == 0)
+ f = next[j];
+ else
+ next[prev[j]] = next[j];
+ if (next[j] == 0)
+ ;
+ else
+ prev[next[j]] = prev[j];
+ /* label the vertex */
+ prev[j] = -1, next[j] = nc;
+ /* and enqueue it for further consideration */
+ list[++pos2] = j;
+ }
+ }
+ /* consider all arcs outgoing from vertex i */
+ for (a = G->v[i]->out; a != NULL; a = a->t_next)
+ { /* vertex j is adjacent to vertex i */
+ j = a->head->i;
+ if (prev[j] >= 0)
+ { /* vertex j is unlabelled */
+ /* remove it from the list of unlabelled vertices */
+ if (prev[j] == 0)
+ f = next[j];
+ else
+ next[prev[j]] = next[j];
+ if (next[j] == 0)
+ ;
+ else
+ prev[next[j]] = prev[j];
+ /* label the vertex */
+ prev[j] = -1, next[j] = nc;
+ /* and enqueue it for further consideration */
+ list[++pos2] = j;
+ }
+ }
+ }
+ }
+ /* store component numbers */
+ if (v_num >= 0)
+ { for (i = 1; i <= nv; i++)
+ { v = G->v[i];
+ memcpy((char *)v->data + v_num, &next[i], sizeof(int));
+ }
+ }
+ /* free working arrays */
+ xfree(prev);
+ xfree(next);
+ xfree(list);
+done: return nc;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrasn.c b/test/monniaux/glpk-4.65/src/api/wrasn.c
new file mode 100644
index 00000000..81433da8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrasn.c
@@ -0,0 +1,107 @@
+/* wrasn.c (write assignment problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_write_asnprob - write assignment problem data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_write_asnprob(glp_graph *G, int v_set, int a_cost,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_asnprob writes assignment problem data in
+* DIMACS format to a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_asnprob(glp_graph *G, int v_set, int a_cost, const char
+ *fname)
+{ glp_file *fp;
+ glp_vertex *v;
+ glp_arc *a;
+ int i, k, count = 0, ret;
+ double cost;
+ if (v_set >= 0 && v_set > G->v_size - (int)sizeof(int))
+ xerror("glp_write_asnprob: v_set = %d; invalid offset\n",
+ v_set);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_write_asnprob: a_cost = %d; invalid offset\n",
+ a_cost);
+ xprintf("Writing assignment problem data to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "c %s\n",
+ G->name == NULL ? "unknown" : G->name), count++;
+ xfprintf(fp, "p asn %d %d\n", G->nv, G->na), count++;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ if (v_set >= 0)
+ memcpy(&k, (char *)v->data + v_set, sizeof(int));
+ else
+ k = (v->out != NULL ? 0 : 1);
+ if (k == 0)
+ xfprintf(fp, "n %d\n", i), count++;
+ }
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 1.0;
+ xfprintf(fp, "a %d %d %.*g\n",
+ a->tail->i, a->head->i, DBL_DIG, cost), count++;
+ }
+ }
+ xfprintf(fp, "c eof\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrcc.c b/test/monniaux/glpk-4.65/src/api/wrcc.c
new file mode 100644
index 00000000..2069c8ac
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrcc.c
@@ -0,0 +1,102 @@
+/* wrcc.c (write graph in DIMACS clique/coloring format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_write_ccdata - write graph in DIMACS clique/coloring format
+*
+* SYNOPSIS
+*
+* int glp_write_ccdata(glp_graph *G, int v_wgt, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_ccdata writes the specified graph in DIMACS
+* clique/coloring format to a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_ccdata(glp_graph *G, int v_wgt, const char *fname)
+{ glp_file *fp;
+ glp_vertex *v;
+ glp_arc *e;
+ int i, count = 0, ret;
+ double w;
+ if (v_wgt >= 0 && v_wgt > G->v_size - (int)sizeof(double))
+ xerror("glp_write_ccdata: v_wgt = %d; invalid offset\n",
+ v_wgt);
+ xprintf("Writing graph to '%s'\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "c %s\n",
+ G->name == NULL ? "unknown" : G->name), count++;
+ xfprintf(fp, "p edge %d %d\n", G->nv, G->na), count++;
+ if (v_wgt >= 0)
+ { for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ memcpy(&w, (char *)v->data + v_wgt, sizeof(double));
+ if (w != 1.0)
+ xfprintf(fp, "n %d %.*g\n", i, DBL_DIG, w), count++;
+ }
+ }
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (e = v->out; e != NULL; e = e->t_next)
+ xfprintf(fp, "e %d %d\n", e->tail->i, e->head->i), count++;
+ }
+ xfprintf(fp, "c eof\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/**********************************************************************/
+
+int glp_write_graph(glp_graph *G, const char *fname)
+{ return
+ glp_write_ccdata(G, -1, fname);
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrcnf.c b/test/monniaux/glpk-4.65/src/api/wrcnf.c
new file mode 100644
index 00000000..c7974386
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrcnf.c
@@ -0,0 +1,87 @@
+/* wrcnf.c (write CNF-SAT problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+int glp_write_cnfsat(glp_prob *P, const char *fname)
+{ /* write CNF-SAT problem data in DIMACS format */
+ glp_file *fp = NULL;
+ GLPAIJ *aij;
+ int i, j, len, count = 0, ret;
+ char s[50];
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_write_cnfsat: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (glp_check_cnfsat(P) != 0)
+ { xprintf("glp_write_cnfsat: problem object does not encode CNF-"
+ "SAT instance\n");
+ ret = 1;
+ goto done;
+ }
+ xprintf("Writing CNF-SAT problem data to '%s'...\n", fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "c %s\n",
+ P->name == NULL ? "unknown" : P->name), count++;
+ xfprintf(fp, "p cnf %d %d\n", P->n, P->m), count++;
+ for (i = 1; i <= P->m; i++)
+ { len = 0;
+ for (aij = P->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { j = aij->col->j;
+ if (aij->val < 0.0) j = -j;
+ sprintf(s, "%d", j);
+ if (len > 0 && len + 1 + strlen(s) > 72)
+ xfprintf(fp, "\n"), count++, len = 0;
+ xfprintf(fp, "%s%s", len == 0 ? "" : " ", s);
+ if (len > 0) len++;
+ len += strlen(s);
+ }
+ if (len > 0 && len + 1 + 1 > 72)
+ xfprintf(fp, "\n"), count++, len = 0;
+ xfprintf(fp, "%s0\n", len == 0 ? "" : " "), count++;
+ }
+ xfprintf(fp, "c eof\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wript.c b/test/monniaux/glpk-4.65/src/api/wript.c
new file mode 100644
index 00000000..f2ca802c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wript.c
@@ -0,0 +1,124 @@
+/* wript.c (write interior-point solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_write_ipt - write interior-point solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_write_ipt(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_ipt writes interior-point solution to a text
+* file in GLPK format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_ipt(glp_prob *P, const char *fname)
+{ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, count, ret = 1;
+ char *s;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_write_ipt: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_write_ipt: fname = %d; invalid parameter\n", fname)
+ ;
+ xprintf("Writing interior-point solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w"), count = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* write comment lines */
+ glp_format(fp, "c %-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name), count++;
+ glp_format(fp, "c %-12s%d\n", "Rows:", P->m), count++;
+ glp_format(fp, "c %-12s%d\n", "Columns:", P->n), count++;
+ glp_format(fp, "c %-12s%d\n", "Non-zeros:", P->nnz), count++;
+ switch (P->ipt_stat)
+ { case GLP_OPT: s = "OPTIMAL"; break;
+ case GLP_INFEAS: s = "INFEASIBLE (INTERMEDIATE)"; break;
+ case GLP_NOFEAS: s = "INFEASIBLE (FINAL)"; break;
+ case GLP_UNDEF: s = "UNDEFINED"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s\n", "Status:", s), count++;
+ switch (P->dir)
+ { case GLP_MIN: s = "MINimum"; break;
+ case GLP_MAX: s = "MAXimum"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->ipt_obj, s), count++;
+ glp_format(fp, "c\n"), count++;
+ /* write solution line */
+ glp_format(fp, "s ipt %d %d ", P->m, P->n), count++;
+ switch (P->ipt_stat)
+ { case GLP_OPT: glp_format(fp, "o"); break;
+ case GLP_INFEAS: glp_format(fp, "i"); break;
+ case GLP_NOFEAS: glp_format(fp, "n"); break;
+ case GLP_UNDEF: glp_format(fp, "u"); break;
+ default: glp_format(fp, "?"); break;
+ }
+ glp_format(fp, " %.*g\n", DBL_DIG, P->ipt_obj);
+ /* write row solution descriptor lines */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ glp_format(fp, "i %d %.*g %.*g\n", i, DBL_DIG, row->pval,
+ DBL_DIG, row->dval), count++;
+ }
+ /* write column solution descriptor lines */
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ glp_format(fp, "j %d %.*g %.*g\n", j, DBL_DIG, col->pval,
+ DBL_DIG, col->dval), count++;
+ }
+ /* write end line */
+ glp_format(fp, "e o f\n"), count++;
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* interior-point solution has been successfully written */
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL)
+ glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrmaxf.c b/test/monniaux/glpk-4.65/src/api/wrmaxf.c
new file mode 100644
index 00000000..d3101ca8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrmaxf.c
@@ -0,0 +1,104 @@
+/* wrmaxf.c (write maximum flow problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_write_maxflow - write maximum flow problem data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_write_maxflow(glp_graph *G, int s, int t, int a_cap,
+* const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_maxflow writes maximum flow problem data in
+* DIMACS format to a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_maxflow(glp_graph *G, int s, int t, int a_cap,
+ const char *fname)
+{ glp_file *fp;
+ glp_vertex *v;
+ glp_arc *a;
+ int i, count = 0, ret;
+ double cap;
+ if (!(1 <= s && s <= G->nv))
+ xerror("glp_write_maxflow: s = %d; source node number out of r"
+ "ange\n", s);
+ if (!(1 <= t && t <= G->nv))
+ xerror("glp_write_maxflow: t = %d: sink node number out of ran"
+ "ge\n", t);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_write_mincost: a_cap = %d; invalid offset\n",
+ a_cap);
+ xprintf("Writing maximum flow problem data to '%s'...\n",
+ fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "c %s\n",
+ G->name == NULL ? "unknown" : G->name), count++;
+ xfprintf(fp, "p max %d %d\n", G->nv, G->na), count++;
+ xfprintf(fp, "n %d s\n", s), count++;
+ xfprintf(fp, "n %d t\n", t), count++;
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { if (a_cap >= 0)
+ memcpy(&cap, (char *)a->data + a_cap, sizeof(double));
+ else
+ cap = 1.0;
+ xfprintf(fp, "a %d %d %.*g\n",
+ a->tail->i, a->head->i, DBL_DIG, cap), count++;
+ }
+ }
+ xfprintf(fp, "c eof\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrmcf.c b/test/monniaux/glpk-4.65/src/api/wrmcf.c
new file mode 100644
index 00000000..0da37f42
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrmcf.c
@@ -0,0 +1,122 @@
+/* wrmcf.c (write min-cost flow problem data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpk.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_write_mincost - write min-cost flow probl. data in DIMACS format
+*
+* SYNOPSIS
+*
+* int glp_write_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+* int a_cost, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_mincost writes minimum cost flow problem data
+* in DIMACS format to a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, const char *fname)
+{ glp_file *fp;
+ glp_vertex *v;
+ glp_arc *a;
+ int i, count = 0, ret;
+ double rhs, low, cap, cost;
+ if (v_rhs >= 0 && v_rhs > G->v_size - (int)sizeof(double))
+ xerror("glp_write_mincost: v_rhs = %d; invalid offset\n",
+ v_rhs);
+ if (a_low >= 0 && a_low > G->a_size - (int)sizeof(double))
+ xerror("glp_write_mincost: a_low = %d; invalid offset\n",
+ a_low);
+ if (a_cap >= 0 && a_cap > G->a_size - (int)sizeof(double))
+ xerror("glp_write_mincost: a_cap = %d; invalid offset\n",
+ a_cap);
+ if (a_cost >= 0 && a_cost > G->a_size - (int)sizeof(double))
+ xerror("glp_write_mincost: a_cost = %d; invalid offset\n",
+ a_cost);
+ xprintf("Writing min-cost flow problem data to '%s'...\n",
+ fname);
+ fp = glp_open(fname, "w");
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xfprintf(fp, "c %s\n",
+ G->name == NULL ? "unknown" : G->name), count++;
+ xfprintf(fp, "p min %d %d\n", G->nv, G->na), count++;
+ if (v_rhs >= 0)
+ { for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ memcpy(&rhs, (char *)v->data + v_rhs, sizeof(double));
+ if (rhs != 0.0)
+ xfprintf(fp, "n %d %.*g\n", i, DBL_DIG, rhs), count++;
+ }
+ }
+ for (i = 1; i <= G->nv; i++)
+ { v = G->v[i];
+ for (a = v->out; a != NULL; a = a->t_next)
+ { if (a_low >= 0)
+ memcpy(&low, (char *)a->data + a_low, sizeof(double));
+ else
+ low = 0.0;
+ if (a_cap >= 0)
+ memcpy(&cap, (char *)a->data + a_cap, sizeof(double));
+ else
+ cap = 1.0;
+ if (a_cost >= 0)
+ memcpy(&cost, (char *)a->data + a_cost, sizeof(double));
+ else
+ cost = 0.0;
+ xfprintf(fp, "a %d %d %.*g %.*g %.*g\n",
+ a->tail->i, a->head->i, DBL_DIG, low, DBL_DIG, cap,
+ DBL_DIG, cost), count++;
+ }
+ }
+ xfprintf(fp, "c eof\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrmip.c b/test/monniaux/glpk-4.65/src/api/wrmip.c
new file mode 100644
index 00000000..407a5fec
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrmip.c
@@ -0,0 +1,122 @@
+/* wrmip.c (write MIP solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_write_mip - write MIP solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_write_mip(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_mip writes MIP solution to a text file in GLPK
+* format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_mip(glp_prob *P, const char *fname)
+{ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, count, ret = 1;
+ char *s;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_write_mip: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_write_mip: fname = %d; invalid parameter\n", fname)
+ ;
+ xprintf("Writing MIP solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w"), count = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* write comment lines */
+ glp_format(fp, "c %-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name), count++;
+ glp_format(fp, "c %-12s%d\n", "Rows:", P->m), count++;
+ glp_format(fp, "c %-12s%d\n", "Columns:", P->n), count++;
+ glp_format(fp, "c %-12s%d\n", "Non-zeros:", P->nnz), count++;
+ switch (P->mip_stat)
+ { case GLP_OPT: s = "INTEGER OPTIMAL"; break;
+ case GLP_FEAS: s = "INTEGER NON-OPTIMAL"; break;
+ case GLP_NOFEAS: s = "INTEGER EMPTY"; break;
+ case GLP_UNDEF: s = "INTEGER UNDEFINED"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s\n", "Status:", s), count++;
+ switch (P->dir)
+ { case GLP_MIN: s = "MINimum"; break;
+ case GLP_MAX: s = "MAXimum"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->mip_obj, s), count++;
+ glp_format(fp, "c\n"), count++;
+ /* write solution line */
+ glp_format(fp, "s mip %d %d ", P->m, P->n), count++;
+ switch (P->mip_stat)
+ { case GLP_OPT: glp_format(fp, "o"); break;
+ case GLP_FEAS: glp_format(fp, "f"); break;
+ case GLP_NOFEAS: glp_format(fp, "n"); break;
+ case GLP_UNDEF: glp_format(fp, "u"); break;
+ default: glp_format(fp, "?"); break;
+ }
+ glp_format(fp, " %.*g\n", DBL_DIG, P->mip_obj);
+ /* write row solution descriptor lines */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ glp_format(fp, "i %d %.*g\n", i, DBL_DIG, row->mipx), count++;
+ }
+ /* write column solution descriptor lines */
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ glp_format(fp, "j %d %.*g\n", j, DBL_DIG, col->mipx), count++;
+ }
+ /* write end line */
+ glp_format(fp, "e o f\n"), count++;
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* MIP solution has been successfully written */
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL)
+ glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrprob.c b/test/monniaux/glpk-4.65/src/api/wrprob.c
new file mode 100644
index 00000000..99983d35
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrprob.c
@@ -0,0 +1,166 @@
+/* wrprob.c (write problem data in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+#define xfprintf glp_format
+
+/***********************************************************************
+* NAME
+*
+* glp_write_prob - write problem data in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_write_prob(glp_prob *P, int flags, const char *fname);
+*
+* The routine glp_write_prob writes problem data in GLPK LP/MIP format
+* to a text file.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_prob(glp_prob *P, int flags, const char *fname)
+{ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int mip, i, j, count, ret;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_write_prob: P = %p; invalid problem object\n",
+ P);
+#endif
+ if (flags != 0)
+ xerror("glp_write_prob: flags = %d; invalid parameter\n",
+ flags);
+ if (fname == NULL)
+ xerror("glp_write_prob: fname = %d; invalid parameter\n",
+ fname);
+ xprintf("Writing problem data to '%s'...\n", fname);
+ fp = glp_open(fname, "w"), count = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ /* write problem line */
+ mip = (glp_get_num_int(P) > 0);
+ xfprintf(fp, "p %s %s %d %d %d\n", !mip ? "lp" : "mip",
+ P->dir == GLP_MIN ? "min" : P->dir == GLP_MAX ? "max" : "???",
+ P->m, P->n, P->nnz), count++;
+ if (P->name != NULL)
+ xfprintf(fp, "n p %s\n", P->name), count++;
+ if (P->obj != NULL)
+ xfprintf(fp, "n z %s\n", P->obj), count++;
+ /* write row descriptors */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->type == GLP_FX && row->lb == 0.0)
+ goto skip1;
+ xfprintf(fp, "i %d ", i), count++;
+ if (row->type == GLP_FR)
+ xfprintf(fp, "f\n");
+ else if (row->type == GLP_LO)
+ xfprintf(fp, "l %.*g\n", DBL_DIG, row->lb);
+ else if (row->type == GLP_UP)
+ xfprintf(fp, "u %.*g\n", DBL_DIG, row->ub);
+ else if (row->type == GLP_DB)
+ xfprintf(fp, "d %.*g %.*g\n", DBL_DIG, row->lb, DBL_DIG,
+ row->ub);
+ else if (row->type == GLP_FX)
+ xfprintf(fp, "s %.*g\n", DBL_DIG, row->lb);
+ else
+ xassert(row != row);
+skip1: if (row->name != NULL)
+ xfprintf(fp, "n i %d %s\n", i, row->name), count++;
+ }
+ /* write column descriptors */
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (!mip && col->type == GLP_LO && col->lb == 0.0)
+ goto skip2;
+ if (mip && col->kind == GLP_IV && col->type == GLP_DB &&
+ col->lb == 0.0 && col->ub == 1.0)
+ goto skip2;
+ xfprintf(fp, "j %d ", j), count++;
+ if (mip)
+ { if (col->kind == GLP_CV)
+ xfprintf(fp, "c ");
+ else if (col->kind == GLP_IV)
+ xfprintf(fp, "i ");
+ else
+ xassert(col != col);
+ }
+ if (col->type == GLP_FR)
+ xfprintf(fp, "f\n");
+ else if (col->type == GLP_LO)
+ xfprintf(fp, "l %.*g\n", DBL_DIG, col->lb);
+ else if (col->type == GLP_UP)
+ xfprintf(fp, "u %.*g\n", DBL_DIG, col->ub);
+ else if (col->type == GLP_DB)
+ xfprintf(fp, "d %.*g %.*g\n", DBL_DIG, col->lb, DBL_DIG,
+ col->ub);
+ else if (col->type == GLP_FX)
+ xfprintf(fp, "s %.*g\n", DBL_DIG, col->lb);
+ else
+ xassert(col != col);
+skip2: if (col->name != NULL)
+ xfprintf(fp, "n j %d %s\n", j, col->name), count++;
+ }
+ /* write objective coefficient descriptors */
+ if (P->c0 != 0.0)
+ xfprintf(fp, "a 0 0 %.*g\n", DBL_DIG, P->c0), count++;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->coef != 0.0)
+ xfprintf(fp, "a 0 %d %.*g\n", j, DBL_DIG, col->coef),
+ count++;
+ }
+ /* write constraint coefficient descriptors */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ xfprintf(fp, "a %d %d %.*g\n", i, aij->col->j, DBL_DIG,
+ aij->val), count++;
+ }
+ /* write end line */
+ xfprintf(fp, "e o f\n"), count++;
+#if 0 /* FIXME */
+ xfflush(fp);
+#endif
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ ret = 1;
+ goto done;
+ }
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL) glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/api/wrsol.c b/test/monniaux/glpk-4.65/src/api/wrsol.c
new file mode 100644
index 00000000..66c69233
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/api/wrsol.c
@@ -0,0 +1,174 @@
+/* wrsol.c (write basic solution in GLPK format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2010-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_write_sol - write basic solution in GLPK format
+*
+* SYNOPSIS
+*
+* int glp_write_sol(glp_prob *P, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine glp_write_sol writes basic solution to a text file in
+* GLPK format.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero. Otherwise
+* it prints an error message and returns non-zero. */
+
+int glp_write_sol(glp_prob *P, const char *fname)
+{ glp_file *fp;
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j, count, ret = 1;
+ char *s;
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_write_sol: P = %p; invalid problem object\n", P);
+#endif
+ if (fname == NULL)
+ xerror("glp_write_sol: fname = %d; invalid parameter\n", fname)
+ ;
+ xprintf("Writing basic solution to '%s'...\n", fname);
+ fp = glp_open(fname, "w"), count = 0;
+ if (fp == NULL)
+ { xprintf("Unable to create '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* write comment lines */
+ glp_format(fp, "c %-12s%s\n", "Problem:",
+ P->name == NULL ? "" : P->name), count++;
+ glp_format(fp, "c %-12s%d\n", "Rows:", P->m), count++;
+ glp_format(fp, "c %-12s%d\n", "Columns:", P->n), count++;
+ glp_format(fp, "c %-12s%d\n", "Non-zeros:", P->nnz), count++;
+ switch (glp_get_status(P))
+ { case GLP_OPT: s = "OPTIMAL"; break;
+ case GLP_FEAS: s = "FEASIBLE"; break;
+ case GLP_INFEAS: s = "INFEASIBLE (INTERMEDIATE)"; break;
+ case GLP_NOFEAS: s = "INFEASIBLE (FINAL)"; break;
+ case GLP_UNBND: s = "UNBOUNDED"; break;
+ case GLP_UNDEF: s = "UNDEFINED"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s\n", "Status:", s), count++;
+ switch (P->dir)
+ { case GLP_MIN: s = "MINimum"; break;
+ case GLP_MAX: s = "MAXimum"; break;
+ default: s = "???"; break;
+ }
+ glp_format(fp, "c %-12s%s%s%.10g (%s)\n", "Objective:",
+ P->obj == NULL ? "" : P->obj,
+ P->obj == NULL ? "" : " = ", P->obj_val, s), count++;
+ glp_format(fp, "c\n"), count++;
+ /* write solution line */
+ glp_format(fp, "s bas %d %d ", P->m, P->n), count++;
+ switch (P->pbs_stat)
+ { case GLP_UNDEF: glp_format(fp, "u"); break;
+ case GLP_FEAS: glp_format(fp, "f"); break;
+ case GLP_INFEAS: glp_format(fp, "i"); break;
+ case GLP_NOFEAS: glp_format(fp, "n"); break;
+ default: glp_format(fp, "?"); break;
+ }
+ glp_format(fp, " ");
+ switch (P->dbs_stat)
+ { case GLP_UNDEF: glp_format(fp, "u"); break;
+ case GLP_FEAS: glp_format(fp, "f"); break;
+ case GLP_INFEAS: glp_format(fp, "i"); break;
+ case GLP_NOFEAS: glp_format(fp, "n"); break;
+ default: glp_format(fp, "?"); break;
+ }
+ glp_format(fp, " %.*g\n", DBL_DIG, P->obj_val);
+ /* write row solution descriptor lines */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ glp_format(fp, "i %d ", i), count++;
+ switch (row->stat)
+ { case GLP_BS:
+ glp_format(fp, "b");
+ break;
+ case GLP_NL:
+ glp_format(fp, "l");
+ break;
+ case GLP_NU:
+ glp_format(fp, "u");
+ break;
+ case GLP_NF:
+ glp_format(fp, "f");
+ break;
+ case GLP_NS:
+ glp_format(fp, "s");
+ break;
+ default:
+ xassert(row != row);
+ }
+ glp_format(fp, " %.*g %.*g\n", DBL_DIG, row->prim, DBL_DIG,
+ row->dual);
+ }
+ /* write column solution descriptor lines */
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ glp_format(fp, "j %d ", j), count++;
+ switch (col->stat)
+ { case GLP_BS:
+ glp_format(fp, "b");
+ break;
+ case GLP_NL:
+ glp_format(fp, "l");
+ break;
+ case GLP_NU:
+ glp_format(fp, "u");
+ break;
+ case GLP_NF:
+ glp_format(fp, "f");
+ break;
+ case GLP_NS:
+ glp_format(fp, "s");
+ break;
+ default:
+ xassert(col != col);
+ }
+ glp_format(fp, " %.*g %.*g\n", DBL_DIG, col->prim, DBL_DIG,
+ col->dual);
+ }
+ /* write end line */
+ glp_format(fp, "e o f\n"), count++;
+ if (glp_ioerr(fp))
+ { xprintf("Write error on '%s' - %s\n", fname, get_err_msg());
+ goto done;
+ }
+ /* basic solution has been successfully written */
+ xprintf("%d lines were written\n", count);
+ ret = 0;
+done: if (fp != NULL)
+ glp_close(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/btf.c b/test/monniaux/glpk-4.65/src/bflib/btf.c
new file mode 100644
index 00000000..993c9ca1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/btf.c
@@ -0,0 +1,569 @@
+/* btf.c (sparse block triangular LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "btf.h"
+#include "env.h"
+#include "luf.h"
+#include "mc13d.h"
+#include "mc21a.h"
+
+/***********************************************************************
+* btf_store_a_cols - store pattern of matrix A in column-wise format
+*
+* This routine stores the pattern (that is, only indices of non-zero
+* elements) of the original matrix A in column-wise format.
+*
+* On exit the routine returns the number of non-zeros in matrix A. */
+
+int btf_store_a_cols(BTF *btf, int (*col)(void *info, int j, int ind[],
+ double val[]), void *info, int ind[], double val[])
+{ int n = btf->n;
+ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ int j, len, ptr, nnz;
+ nnz = 0;
+ for (j = 1; j <= n; j++)
+ { /* get j-th column */
+ len = col(info, j, ind, val);
+ xassert(0 <= len && len <= n);
+ /* reserve locations for j-th column */
+ if (len > 0)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ }
+ sva_reserve_cap(sva, ac_ref+(j-1), len);
+ }
+ /* store pattern of j-th column */
+ ptr = ac_ptr[j];
+ memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
+ ac_len[j] = len;
+ nnz += len;
+ }
+ return nnz;
+}
+
+/***********************************************************************
+* btf_make_blocks - permutations to block triangular form
+*
+* This routine analyzes the pattern of the original matrix A and
+* determines permutation matrices P and Q such that A = P * A~* Q,
+* where A~ is an upper block triangular matrix.
+*
+* On exit the routine returns symbolic rank of matrix A. */
+
+int btf_make_blocks(BTF *btf)
+{ int n = btf->n;
+ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ int *pp_ind = btf->pp_ind;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int *qq_inv = btf->qq_inv;
+ int *beg = btf->beg;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ int i, j, rank, *iperm, *pr, *arp, *cv, *out, *ip, *lenr, *lowl,
+ *numb, *prev;
+ /* determine column permutation matrix M such that matrix A * M
+ * has zero-free diagonal */
+ iperm = qq_inv; /* matrix M */
+ pr = btf->p1_ind; /* working array */
+ arp = btf->p1_inv; /* working array */
+ cv = btf->q1_ind; /* working array */
+ out = btf->q1_inv; /* working array */
+ rank = mc21a(n, sv_ind, ac_ptr, ac_len, iperm, pr, arp, cv, out);
+ xassert(0 <= rank && rank <= n);
+ if (rank < n)
+ { /* A is structurally singular (rank is its symbolic rank) */
+ goto done;
+ }
+ /* build pattern of matrix A * M */
+ ip = pp_ind; /* working array */
+ lenr = qq_ind; /* working array */
+ for (j = 1; j <= n; j++)
+ { ip[j] = ac_ptr[iperm[j]];
+ lenr[j] = ac_len[iperm[j]];
+ }
+ /* determine symmetric permutation matrix S such that matrix
+ * S * (A * M) * S' = A~ is upper block triangular */
+ lowl = btf->p1_ind; /* working array */
+ numb = btf->p1_inv; /* working array */
+ prev = btf->q1_ind; /* working array */
+ btf->num =
+ mc13d(n, sv_ind, ip, lenr, pp_inv, beg, lowl, numb, prev);
+ xassert(beg[1] == 1);
+ beg[btf->num+1] = n+1;
+ /* A * M = S' * A~ * S ==> A = S' * A~ * (S * M') */
+ /* determine permutation matrix P = S' */
+ for (j = 1; j <= n; j++)
+ pp_ind[pp_inv[j]] = j;
+ /* determine permutation matrix Q = S * M' = P' * M' */
+ for (i = 1; i <= n; i++)
+ qq_ind[i] = iperm[pp_inv[i]];
+ for (i = 1; i <= n; i++)
+ qq_inv[qq_ind[i]] = i;
+done: return rank;
+}
+
+/***********************************************************************
+* btf_check_blocks - check structure of matrix A~
+*
+* This routine checks that structure of upper block triangular matrix
+* A~ is correct.
+*
+* NOTE: For testing/debugging only. */
+
+void btf_check_blocks(BTF *btf)
+{ int n = btf->n;
+ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ int *pp_ind = btf->pp_ind;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int *qq_inv = btf->qq_inv;
+ int num = btf->num;
+ int *beg = btf->beg;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ int i, ii, j, jj, k, size, ptr, end, diag;
+ xassert(n > 0);
+ /* check permutation matrices P and Q */
+ for (k = 1; k <= n; k++)
+ { xassert(1 <= pp_ind[k] && pp_ind[k] <= n);
+ xassert(pp_inv[pp_ind[k]] == k);
+ xassert(1 <= qq_ind[k] && qq_ind[k] <= n);
+ xassert(qq_inv[qq_ind[k]] == k);
+ }
+ /* check that matrix A~ is upper block triangular with non-zero
+ * diagonal */
+ xassert(1 <= num && num <= n);
+ xassert(beg[1] == 1);
+ xassert(beg[num+1] == n+1);
+ /* walk thru blocks of A~ */
+ for (k = 1; k <= num; k++)
+ { /* determine size of k-th block */
+ size = beg[k+1] - beg[k];
+ xassert(size >= 1);
+ /* walk thru columns of k-th block */
+ for (jj = beg[k]; jj < beg[k+1]; jj++)
+ { diag = 0;
+ /* jj-th column of A~ = j-th column of A */
+ j = qq_ind[jj];
+ /* walk thru elements of j-th column of A */
+ ptr = ac_ptr[j];
+ end = ptr + ac_len[j];
+ for (; ptr < end; ptr++)
+ { /* determine row index of a[i,j] */
+ i = sv_ind[ptr];
+ /* i-th row of A = ii-th row of A~ */
+ ii = pp_ind[i];
+ /* a~[ii,jj] should not be below k-th block */
+ xassert(ii < beg[k+1]);
+ if (ii == jj)
+ { /* non-zero diagonal element of A~ encountered */
+ diag = 1;
+ }
+ }
+ xassert(diag);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* btf_build_a_rows - build matrix A in row-wise format
+*
+* This routine builds the row-wise representation of matrix A in the
+* right part of SVA using its column-wise representation.
+*
+* The working array len should have at least 1+n elements (len[0] is
+* not used). */
+
+void btf_build_a_rows(BTF *btf, int len[/*1+n*/])
+{ int n = btf->n;
+ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int ar_ref = btf->ar_ref;
+ int *ar_ptr = &sva->ptr[ar_ref-1];
+ int *ar_len = &sva->len[ar_ref-1];
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ int i, j, end, nnz, ptr, ptr1;
+ /* calculate the number of non-zeros in each row of matrix A and
+ * the total number of non-zeros */
+ nnz = 0;
+ for (i = 1; i <= n; i++)
+ len[i] = 0;
+ for (j = 1; j <= n; j++)
+ { nnz += ac_len[j];
+ for (end = (ptr = ac_ptr[j]) + ac_len[j]; ptr < end; ptr++)
+ len[sv_ind[ptr]]++;
+ }
+ /* we need at least nnz free locations in SVA */
+ if (sva->r_ptr - sva->m_ptr < nnz)
+ { sva_more_space(sva, nnz);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ /* reserve locations for rows of matrix A */
+ for (i = 1; i <= n; i++)
+ { if (len[i] > 0)
+ sva_reserve_cap(sva, ar_ref-1+i, len[i]);
+ ar_len[i] = len[i];
+ }
+ /* walk thru columns of matrix A and build its rows */
+ for (j = 1; j <= n; j++)
+ { for (end = (ptr = ac_ptr[j]) + ac_len[j]; ptr < end; ptr++)
+ { i = sv_ind[ptr];
+ sv_ind[ptr1 = ar_ptr[i] + (--len[i])] = j;
+ sv_val[ptr1] = sv_val[ptr];
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* btf_a_solve - solve system A * x = b
+*
+* This routine solves the system A * x = b, where A is the original
+* matrix.
+*
+* On entry the array b should contain elements of the right-hand size
+* vector b in locations b[1], ..., b[n], where n is the order of the
+* matrix A. On exit the array x will contain elements of the solution
+* vector in locations x[1], ..., x[n]. Note that the array b will be
+* clobbered on exit.
+*
+* The routine also uses locations [1], ..., [max_size] of two working
+* arrays w1 and w2, where max_size is the maximal size of diagonal
+* blocks in BT-factorization (max_size <= n). */
+
+void btf_a_solve(BTF *btf, double b[/*1+n*/], double x[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/])
+{ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int num = btf->num;
+ int *beg = btf->beg;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ double *bb = w1;
+ double *xx = w2;
+ LUF luf;
+ int i, j, jj, k, beg_k, flag;
+ double t;
+ for (k = num; k >= 1; k--)
+ { /* determine order of diagonal block A~[k,k] */
+ luf.n = beg[k+1] - (beg_k = beg[k]);
+ if (luf.n == 1)
+ { /* trivial case */
+ /* solve system A~[k,k] * X[k] = B[k] */
+ t = x[qq_ind[beg_k]] =
+ b[pp_inv[beg_k]] / btf->vr_piv[beg_k];
+ /* substitute X[k] into other equations */
+ if (t != 0.0)
+ { int ptr = ac_ptr[qq_ind[beg_k]];
+ int end = ptr + ac_len[qq_ind[beg_k]];
+ for (; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * t;
+ }
+ }
+ else
+ { /* general case */
+ /* construct B[k] */
+ flag = 0;
+ for (i = 1; i <= luf.n; i++)
+ { if ((bb[i] = b[pp_inv[i + (beg_k-1)]]) != 0.0)
+ flag = 1;
+ }
+ /* solve system A~[k,k] * X[k] = B[k] */
+ if (!flag)
+ { /* B[k] = 0, so X[k] = 0 */
+ for (j = 1; j <= luf.n; j++)
+ x[qq_ind[j + (beg_k-1)]] = 0.0;
+ continue;
+ }
+ luf.sva = sva;
+ luf.fr_ref = btf->fr_ref + (beg_k-1);
+ luf.fc_ref = btf->fc_ref + (beg_k-1);
+ luf.vr_ref = btf->vr_ref + (beg_k-1);
+ luf.vr_piv = btf->vr_piv + (beg_k-1);
+ luf.vc_ref = btf->vc_ref + (beg_k-1);
+ luf.pp_ind = btf->p1_ind + (beg_k-1);
+ luf.pp_inv = btf->p1_inv + (beg_k-1);
+ luf.qq_ind = btf->q1_ind + (beg_k-1);
+ luf.qq_inv = btf->q1_inv + (beg_k-1);
+ luf_f_solve(&luf, bb);
+ luf_v_solve(&luf, bb, xx);
+ /* store X[k] and substitute it into other equations */
+ for (j = 1; j <= luf.n; j++)
+ { jj = j + (beg_k-1);
+ t = x[qq_ind[jj]] = xx[j];
+ if (t != 0.0)
+ { int ptr = ac_ptr[qq_ind[jj]];
+ int end = ptr + ac_len[qq_ind[jj]];
+ for (; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * t;
+ }
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* btf_at_solve - solve system A'* x = b
+*
+* This routine solves the system A'* x = b, where A' is a matrix
+* transposed to the original matrix A.
+*
+* On entry the array b should contain elements of the right-hand size
+* vector b in locations b[1], ..., b[n], where n is the order of the
+* matrix A. On exit the array x will contain elements of the solution
+* vector in locations x[1], ..., x[n]. Note that the array b will be
+* clobbered on exit.
+*
+* The routine also uses locations [1], ..., [max_size] of two working
+* arrays w1 and w2, where max_size is the maximal size of diagonal
+* blocks in BT-factorization (max_size <= n). */
+
+void btf_at_solve(BTF *btf, double b[/*1+n*/], double x[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/])
+{ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int num = btf->num;
+ int *beg = btf->beg;
+ int ar_ref = btf->ar_ref;
+ int *ar_ptr = &sva->ptr[ar_ref-1];
+ int *ar_len = &sva->len[ar_ref-1];
+ double *bb = w1;
+ double *xx = w2;
+ LUF luf;
+ int i, j, jj, k, beg_k, flag;
+ double t;
+ for (k = 1; k <= num; k++)
+ { /* determine order of diagonal block A~[k,k] */
+ luf.n = beg[k+1] - (beg_k = beg[k]);
+ if (luf.n == 1)
+ { /* trivial case */
+ /* solve system A~'[k,k] * X[k] = B[k] */
+ t = x[pp_inv[beg_k]] =
+ b[qq_ind[beg_k]] / btf->vr_piv[beg_k];
+ /* substitute X[k] into other equations */
+ if (t != 0.0)
+ { int ptr = ar_ptr[pp_inv[beg_k]];
+ int end = ptr + ar_len[pp_inv[beg_k]];
+ for (; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * t;
+ }
+ }
+ else
+ { /* general case */
+ /* construct B[k] */
+ flag = 0;
+ for (i = 1; i <= luf.n; i++)
+ { if ((bb[i] = b[qq_ind[i + (beg_k-1)]]) != 0.0)
+ flag = 1;
+ }
+ /* solve system A~'[k,k] * X[k] = B[k] */
+ if (!flag)
+ { /* B[k] = 0, so X[k] = 0 */
+ for (j = 1; j <= luf.n; j++)
+ x[pp_inv[j + (beg_k-1)]] = 0.0;
+ continue;
+ }
+ luf.sva = sva;
+ luf.fr_ref = btf->fr_ref + (beg_k-1);
+ luf.fc_ref = btf->fc_ref + (beg_k-1);
+ luf.vr_ref = btf->vr_ref + (beg_k-1);
+ luf.vr_piv = btf->vr_piv + (beg_k-1);
+ luf.vc_ref = btf->vc_ref + (beg_k-1);
+ luf.pp_ind = btf->p1_ind + (beg_k-1);
+ luf.pp_inv = btf->p1_inv + (beg_k-1);
+ luf.qq_ind = btf->q1_ind + (beg_k-1);
+ luf.qq_inv = btf->q1_inv + (beg_k-1);
+ luf_vt_solve(&luf, bb, xx);
+ luf_ft_solve(&luf, xx);
+ /* store X[k] and substitute it into other equations */
+ for (j = 1; j <= luf.n; j++)
+ { jj = j + (beg_k-1);
+ t = x[pp_inv[jj]] = xx[j];
+ if (t != 0.0)
+ { int ptr = ar_ptr[pp_inv[jj]];
+ int end = ptr + ar_len[pp_inv[jj]];
+ for (; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * t;
+ }
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* btf_at_solve1 - solve system A'* y = e' to cause growth in y
+*
+* This routine is a special version of btf_at_solve. It solves the
+* system A'* y = e' = e + delta e, where A' is a matrix transposed to
+* the original matrix A, e is the specified right-hand side vector,
+* and delta e is a vector of +1 and -1 chosen to cause growth in the
+* solution vector y.
+*
+* On entry the array e should contain elements of the right-hand size
+* vector e in locations e[1], ..., e[n], where n is the order of the
+* matrix A. On exit the array y will contain elements of the solution
+* vector in locations y[1], ..., y[n]. Note that the array e will be
+* clobbered on exit.
+*
+* The routine also uses locations [1], ..., [max_size] of two working
+* arrays w1 and w2, where max_size is the maximal size of diagonal
+* blocks in BT-factorization (max_size <= n). */
+
+void btf_at_solve1(BTF *btf, double e[/*1+n*/], double y[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/])
+{ SVA *sva = btf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int num = btf->num;
+ int *beg = btf->beg;
+ int ar_ref = btf->ar_ref;
+ int *ar_ptr = &sva->ptr[ar_ref-1];
+ int *ar_len = &sva->len[ar_ref-1];
+ double *ee = w1;
+ double *yy = w2;
+ LUF luf;
+ int i, j, jj, k, beg_k, ptr, end;
+ double e_k, y_k;
+ for (k = 1; k <= num; k++)
+ { /* determine order of diagonal block A~[k,k] */
+ luf.n = beg[k+1] - (beg_k = beg[k]);
+ if (luf.n == 1)
+ { /* trivial case */
+ /* determine E'[k] = E[k] + delta E[k] */
+ e_k = e[qq_ind[beg_k]];
+ e_k = (e_k >= 0.0 ? e_k + 1.0 : e_k - 1.0);
+ /* solve system A~'[k,k] * Y[k] = E[k] */
+ y_k = y[pp_inv[beg_k]] = e_k / btf->vr_piv[beg_k];
+ /* substitute Y[k] into other equations */
+ ptr = ar_ptr[pp_inv[beg_k]];
+ end = ptr + ar_len[pp_inv[beg_k]];
+ for (; ptr < end; ptr++)
+ e[sv_ind[ptr]] -= sv_val[ptr] * y_k;
+ }
+ else
+ { /* general case */
+ /* construct E[k] */
+ for (i = 1; i <= luf.n; i++)
+ ee[i] = e[qq_ind[i + (beg_k-1)]];
+ /* solve system A~'[k,k] * Y[k] = E[k] + delta E[k] */
+ luf.sva = sva;
+ luf.fr_ref = btf->fr_ref + (beg_k-1);
+ luf.fc_ref = btf->fc_ref + (beg_k-1);
+ luf.vr_ref = btf->vr_ref + (beg_k-1);
+ luf.vr_piv = btf->vr_piv + (beg_k-1);
+ luf.vc_ref = btf->vc_ref + (beg_k-1);
+ luf.pp_ind = btf->p1_ind + (beg_k-1);
+ luf.pp_inv = btf->p1_inv + (beg_k-1);
+ luf.qq_ind = btf->q1_ind + (beg_k-1);
+ luf.qq_inv = btf->q1_inv + (beg_k-1);
+ luf_vt_solve1(&luf, ee, yy);
+ luf_ft_solve(&luf, yy);
+ /* store Y[k] and substitute it into other equations */
+ for (j = 1; j <= luf.n; j++)
+ { jj = j + (beg_k-1);
+ y_k = y[pp_inv[jj]] = yy[j];
+ ptr = ar_ptr[pp_inv[jj]];
+ end = ptr + ar_len[pp_inv[jj]];
+ for (; ptr < end; ptr++)
+ e[sv_ind[ptr]] -= sv_val[ptr] * y_k;
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* btf_estimate_norm - estimate 1-norm of inv(A)
+*
+* This routine estimates 1-norm of inv(A) by one step of inverse
+* iteration for the small singular vector as described in [1]. This
+* involves solving two systems of equations:
+*
+* A'* y = e,
+*
+* A * z = y,
+*
+* where A' is a matrix transposed to A, and e is a vector of +1 and -1
+* chosen to cause growth in y. Then
+*
+* estimate 1-norm of inv(A) = (1-norm of z) / (1-norm of y)
+*
+* REFERENCES
+*
+* 1. G.E.Forsythe, M.A.Malcolm, C.B.Moler. Computer Methods for
+* Mathematical Computations. Prentice-Hall, Englewood Cliffs, N.J.,
+* pp. 30-62 (subroutines DECOMP and SOLVE). */
+
+double btf_estimate_norm(BTF *btf, double w1[/*1+n*/], double
+ w2[/*1+n*/], double w3[/*1+n*/], double w4[/*1+n*/])
+{ int n = btf->n;
+ double *e = w1;
+ double *y = w2;
+ double *z = w1;
+ int i;
+ double y_norm, z_norm;
+ /* compute y = inv(A') * e to cause growth in y */
+ for (i = 1; i <= n; i++)
+ e[i] = 0.0;
+ btf_at_solve1(btf, e, y, w3, w4);
+ /* compute 1-norm of y = sum |y[i]| */
+ y_norm = 0.0;
+ for (i = 1; i <= n; i++)
+ y_norm += (y[i] >= 0.0 ? +y[i] : -y[i]);
+ /* compute z = inv(A) * y */
+ btf_a_solve(btf, y, z, w3, w4);
+ /* compute 1-norm of z = sum |z[i]| */
+ z_norm = 0.0;
+ for (i = 1; i <= n; i++)
+ z_norm += (z[i] >= 0.0 ? +z[i] : -z[i]);
+ /* estimate 1-norm of inv(A) = (1-norm of z) / (1-norm of y) */
+ return z_norm / y_norm;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/btf.h b/test/monniaux/glpk-4.65/src/bflib/btf.h
new file mode 100644
index 00000000..3f1b5926
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/btf.h
@@ -0,0 +1,207 @@
+/* btf.h (sparse block triangular LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef BTF_H
+#define BTF_H
+
+#include "sva.h"
+
+/***********************************************************************
+* The structure BTF describes BT-factorization, which is sparse block
+* triangular LU-factorization.
+*
+* The BT-factorization has the following format:
+*
+* A = P * A~ * Q, (1)
+*
+* where A is a given (unsymmetric) square matrix, A~ is an upper block
+* triangular matrix (see below), P and Q are permutation matrices. All
+* the matrices have the same order n.
+*
+* The matrix A~, which is a permuted version of the original matrix A,
+* has the following structure:
+*
+* A~[1,1] A~[1,2] ... A~[1,num-1] A~[1,num]
+*
+* A~[2,2] ... A~[2,num-1] A~[2,num]
+*
+* . . . . . . . . . (2)
+*
+* A~[num-1,num-1] A~[num-1,num]
+*
+* A~[num,num]
+*
+* where A~[i,j] is a submatrix called a "block," num is the number of
+* blocks. Each diagonal block A~[k,k] is a non-singular square matrix,
+* and each subdiagonal block A~[i,j], i > j, is a zero submatrix, thus
+* A~ is an upper block triangular matrix.
+*
+* Permutation matrices P and Q are stored in ordinary arrays in both
+* row- and column-like formats.
+*
+* The original matrix A is stored in both row- and column-wise sparse
+* formats in the associated sparse vector area (SVA). Should note that
+* elements of all diagonal blocks A~[k,k] in matrix A are set to zero
+* (i.e. removed), so only elements of non-diagonal blocks are stored.
+*
+* Each diagonal block A~[k,k], 1 <= k <= num, is stored in the form of
+* LU-factorization (see the module LUF). */
+
+typedef struct BTF BTF;
+
+struct BTF
+{ /* sparse block triangular LU-factorization */
+ int n;
+ /* order of matrices A, A~, P, Q */
+ SVA *sva;
+ /* associated sparse vector area used to store rows and columns
+ * of matrix A as well as sparse vectors for LU-factorizations of
+ * all diagonal blocks A~[k,k] */
+ /*--------------------------------------------------------------*/
+ /* matrix P */
+ int *pp_ind; /* int pp_ind[1+n]; */
+ /* pp_ind[i] = j means that P[i,j] = 1 */
+ int *pp_inv; /* int pp_inv[1+n]; */
+ /* pp_inv[j] = i means that P[i,j] = 1 */
+ /* if i-th row of matrix A is i'-th row of matrix A~, then
+ * pp_ind[i] = i' and pp_inv[i'] = i */
+ /*--------------------------------------------------------------*/
+ /* matrix Q */
+ int *qq_ind; /* int qq_ind[1+n]; */
+ /* qq_ind[i] = j means that Q[i,j] = 1 */
+ int *qq_inv; /* int qq_inv[1+n]; */
+ /* qq_inv[j] = i means that Q[i,j] = 1 */
+ /* if j-th column of matrix A is j'-th column of matrix A~, then
+ * qq_ind[j'] = j and qq_inv[j] = j' */
+ /*--------------------------------------------------------------*/
+ /* block triangular structure of matrix A~ */
+ int num;
+ /* number of diagonal blocks, 1 <= num <= n */
+ int *beg; /* int beg[1+num+1]; */
+ /* beg[0] is not used;
+ * beg[k], 1 <= k <= num, is index of first row/column of k-th
+ * block of matrix A~;
+ * beg[num+1] is always n+1;
+ * note that order (size) of k-th diagonal block can be computed
+ * as beg[k+1] - beg[k] */
+ /*--------------------------------------------------------------*/
+ /* original matrix A in row-wise format */
+ /* NOTE: elements of all diagonal blocks A~[k,k] are removed */
+ int ar_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * row of matrix A */
+#if 0 + 0
+ int *ar_ptr = &sva->ptr[ar_ref-1];
+ /* ar_ptr[0] is not used;
+ * ar_ptr[i], 1 <= i <= n, is pointer to i-th row in SVA */
+ int *ar_len = &sva->ptr[ar_ref-1];
+ /* ar_len[0] is not used;
+ * ar_len[i], 1 <= i <= n, is length of i-th row */
+#endif
+ /*--------------------------------------------------------------*/
+ /* original matrix A in column-wise format */
+ /* NOTE: elements of all diagonal blocks A~[k,k] are removed */
+ int ac_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * column of matrix A */
+#if 0 + 0
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ /* ac_ptr[0] is not used;
+ * ac_ptr[j], 1 <= j <= n, is pointer to j-th column in SVA */
+ int *ac_len = &sva->ptr[ac_ref-1];
+ /* ac_len[0] is not used;
+ * ac_len[j], 1 <= j <= n, is length of j-th column */
+#endif
+ /*--------------------------------------------------------------*/
+ /* LU-factorizations of diagonal blocks A~[k,k] */
+ /* to decrease overhead expenses similar arrays for all LUFs are
+ * packed into a single array; for example, elements fr_ptr[1],
+ * ..., fr_ptr[n1], where n1 = beg[2] - beg[1], are related to
+ * LUF for first diagonal block A~[1,1], elements fr_ptr[n1+1],
+ * ..., fr_ptr[n1+n2], where n2 = beg[3] - beg[2], are related to
+ * LUF for second diagonal block A~[2,2], etc.; in other words,
+ * elements related to LUF for k-th diagonal block A~[k,k] have
+ * indices beg[k], beg[k]+1, ..., beg[k+1]-1 */
+ /* for details about LUF see description of the LUF module */
+ int fr_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ row of matrix F for first diagonal block A~[1,1] */
+ int fc_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ column of matrix F for first diagonal block A~[1,1] */
+ int vr_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ row of matrix V for first diagonal block A~[1,1] */
+ double *vr_piv; /* double vr_piv[1+n]; */
+ /* vr_piv[0] is not used;
+ vr_piv[1,...,n] are pivot elements for all diagonal blocks */
+ int vc_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ column of matrix V for first diagonal block A~[1,1] */
+ int *p1_ind; /* int p1_ind[1+n]; */
+ int *p1_inv; /* int p1_inv[1+n]; */
+ int *q1_ind; /* int q1_ind[1+n]; */
+ int *q1_inv; /* int q1_inv[1+n]; */
+ /* permutation matrices P and Q for all diagonal blocks */
+};
+
+#define btf_store_a_cols _glp_btf_store_a_cols
+int btf_store_a_cols(BTF *btf, int (*col)(void *info, int j, int ind[],
+ double val[]), void *info, int ind[], double val[]);
+/* store pattern of matrix A in column-wise format */
+
+#define btf_make_blocks _glp_btf_make_blocks
+int btf_make_blocks(BTF *btf);
+/* permutations to block triangular form */
+
+#define btf_check_blocks _glp_btf_check_blocks
+void btf_check_blocks(BTF *btf);
+/* check structure of matrix A~ */
+
+#define btf_build_a_rows _glp_btf_build_a_rows
+void btf_build_a_rows(BTF *btf, int len[/*1+n*/]);
+/* build matrix A in row-wise format */
+
+#define btf_a_solve _glp_btf_a_solve
+void btf_a_solve(BTF *btf, double b[/*1+n*/], double x[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/]);
+/* solve system A * x = b */
+
+#define btf_at_solve _glp_btf_at_solve
+void btf_at_solve(BTF *btf, double b[/*1+n*/], double x[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/]);
+/* solve system A'* x = b */
+
+#define btf_at_solve1 _glp_btf_at_solve1
+void btf_at_solve1(BTF *btf, double e[/*1+n*/], double y[/*1+n*/],
+ double w1[/*1+n*/], double w2[/*1+n*/]);
+/* solve system A'* y = e' to cause growth in y */
+
+#define btf_estimate_norm _glp_btf_estimate_norm
+double btf_estimate_norm(BTF *btf, double w1[/*1+n*/], double
+ w2[/*1+n*/], double w3[/*1+n*/], double w4[/*1+n*/]);
+/* estimate 1-norm of inv(A) */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/btfint.c b/test/monniaux/glpk-4.65/src/bflib/btfint.c
new file mode 100644
index 00000000..378d3a81
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/btfint.c
@@ -0,0 +1,407 @@
+/* btfint.c (interface to BT-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "btfint.h"
+
+BTFINT *btfint_create(void)
+{ /* create interface to BT-factorization */
+ BTFINT *fi;
+ fi = talloc(1, BTFINT);
+ fi->n_max = 0;
+ fi->valid = 0;
+ fi->sva = NULL;
+ fi->btf = NULL;
+ fi->sgf = NULL;
+ fi->sva_n_max = fi->sva_size = 0;
+ fi->delta_n0 = fi->delta_n = 0;
+ fi->sgf_piv_tol = 0.10;
+ fi->sgf_piv_lim = 4;
+ fi->sgf_suhl = 1;
+ fi->sgf_eps_tol = DBL_EPSILON;
+ return fi;
+}
+
+static void factorize_triv(BTFINT *fi, int k, int (*col)(void *info,
+ int j, int ind[], double val[]), void *info)
+{ /* compute LU-factorization of diagonal block A~[k,k] and store
+ * corresponding columns of matrix A except elements of A~[k,k]
+ * (trivial case when the block has unity size) */
+ SVA *sva = fi->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ BTF *btf = fi->btf;
+ int *pp_inv = btf->pp_inv;
+ int *qq_ind = btf->qq_ind;
+ int *beg = btf->beg;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ SGF *sgf = fi->sgf;
+ int *ind = (int *)sgf->vr_max; /* working array */
+ double *val = sgf->work; /* working array */
+ int i, j, t, len, ptr, beg_k;
+ /* diagonal block A~[k,k] has the only element in matrix A~,
+ * which is a~[beg[k],beg[k]] = a[i,j] */
+ beg_k = beg[k];
+ i = pp_inv[beg_k];
+ j = qq_ind[beg_k];
+ /* get j-th column of A */
+ len = col(info, j, ind, val);
+ /* find element a[i,j] = a~[beg[k],beg[k]] in j-th column */
+ for (t = 1; t <= len; t++)
+ { if (ind[t] == i)
+ break;
+ }
+ xassert(t <= len);
+ /* compute LU-factorization of diagonal block A~[k,k], where
+ * F = (1), V = (a[i,j]), P = Q = (1) (see the module LUF) */
+#if 1 /* FIXME */
+ xassert(val[t] != 0.0);
+#endif
+ btf->vr_piv[beg_k] = val[t];
+ btf->p1_ind[beg_k] = btf->p1_inv[beg_k] = 1;
+ btf->q1_ind[beg_k] = btf->q1_inv[beg_k] = 1;
+ /* remove element a[i,j] = a~[beg[k],beg[k]] from j-th column */
+ memmove(&ind[t], &ind[t+1], (len-t) * sizeof(int));
+ memmove(&val[t], &val[t+1], (len-t) * sizeof(double));
+ len--;
+ /* and store resulting j-th column of A into BTF */
+ if (len > 0)
+ { /* reserve locations for j-th column of A */
+ if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, ac_ref+(j-1), len);
+ /* store j-th column of A (except elements of A~[k,k]) */
+ ptr = ac_ptr[j];
+ memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
+ ac_len[j] = len;
+ }
+ return;
+}
+
+static int factorize_block(BTFINT *fi, int k, int (*col)(void *info,
+ int j, int ind[], double val[]), void *info)
+{ /* compute LU-factorization of diagonal block A~[k,k] and store
+ * corresponding columns of matrix A except elements of A~[k,k]
+ * (general case) */
+ SVA *sva = fi->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ BTF *btf = fi->btf;
+ int *pp_ind = btf->pp_ind;
+ int *qq_ind = btf->qq_ind;
+ int *beg = btf->beg;
+ int ac_ref = btf->ac_ref;
+ int *ac_ptr = &sva->ptr[ac_ref-1];
+ int *ac_len = &sva->len[ac_ref-1];
+ SGF *sgf = fi->sgf;
+ int *ind = (int *)sgf->vr_max; /* working array */
+ double *val = sgf->work; /* working array */
+ LUF luf;
+ int *vc_ptr, *vc_len, *vc_cap;
+ int i, ii, j, jj, t, len, cnt, ptr, beg_k;
+ /* construct fake LUF for LU-factorization of A~[k,k] */
+ sgf->luf = &luf;
+ luf.n = beg[k+1] - (beg_k = beg[k]);
+ luf.sva = sva;
+ luf.fr_ref = btf->fr_ref + (beg_k-1);
+ luf.fc_ref = btf->fc_ref + (beg_k-1);
+ luf.vr_ref = btf->vr_ref + (beg_k-1);
+ luf.vr_piv = btf->vr_piv + (beg_k-1);
+ luf.vc_ref = btf->vc_ref + (beg_k-1);
+ luf.pp_ind = btf->p1_ind + (beg_k-1);
+ luf.pp_inv = btf->p1_inv + (beg_k-1);
+ luf.qq_ind = btf->q1_ind + (beg_k-1);
+ luf.qq_inv = btf->q1_inv + (beg_k-1);
+ /* process columns of k-th block of matrix A~ */
+ vc_ptr = &sva->ptr[luf.vc_ref-1];
+ vc_len = &sva->len[luf.vc_ref-1];
+ vc_cap = &sva->cap[luf.vc_ref-1];
+ for (jj = 1; jj <= luf.n; jj++)
+ { /* jj-th column of A~ = j-th column of A */
+ j = qq_ind[jj + (beg_k-1)];
+ /* get j-th column of A */
+ len = col(info, j, ind, val);
+ /* move elements of diagonal block A~[k,k] to the beginning of
+ * the column list */
+ cnt = 0;
+ for (t = 1; t <= len; t++)
+ { /* i = row index of element a[i,j] */
+ i = ind[t];
+ /* i-th row of A = ii-th row of A~ */
+ ii = pp_ind[i];
+ if (ii >= beg_k)
+ { /* a~[ii,jj] = a[i,j] is in diagonal block A~[k,k] */
+ double temp;
+ cnt++;
+ ind[t] = ind[cnt];
+ ind[cnt] = ii - (beg_k-1); /* local index */
+ temp = val[t], val[t] = val[cnt], val[cnt] = temp;
+ }
+ }
+ /* first cnt elements in the column list give jj-th column of
+ * diagonal block A~[k,k], which is initial matrix V in LUF */
+ /* enlarge capacity of jj-th column of V = A~[k,k] */
+ if (vc_cap[jj] < cnt)
+ { if (sva->r_ptr - sva->m_ptr < cnt)
+ { sva_more_space(sva, cnt);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, luf.vc_ref+(jj-1), cnt, 0);
+ }
+ /* store jj-th column of V = A~[k,k] */
+ ptr = vc_ptr[jj];
+ memcpy(&sv_ind[ptr], &ind[1], cnt * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], cnt * sizeof(double));
+ vc_len[jj] = cnt;
+ /* other (len-cnt) elements in the column list are stored in
+ * j-th column of the original matrix A */
+ len -= cnt;
+ if (len > 0)
+ { /* reserve locations for j-th column of A */
+ if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, ac_ref-1+j, len);
+ /* store j-th column of A (except elements of A~[k,k]) */
+ ptr = ac_ptr[j];
+ memcpy(&sv_ind[ptr], &ind[cnt+1], len * sizeof(int));
+ memcpy(&sv_val[ptr], &val[cnt+1], len * sizeof(double));
+ ac_len[j] = len;
+ }
+ }
+ /* compute LU-factorization of diagonal block A~[k,k]; may note
+ * that A~[k,k] is irreducible (strongly connected), so singleton
+ * phase will have no effect */
+ k = sgf_factorize(sgf, 0 /* disable singleton phase */);
+ /* now left (dynamic) part of SVA should be empty (wichtig!) */
+ xassert(sva->m_ptr == 1);
+ return k;
+}
+
+int btfint_factorize(BTFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info)
+{ /* compute BT-factorization of specified matrix A */
+ SVA *sva;
+ BTF *btf;
+ SGF *sgf;
+ int k, rank;
+ xassert(n > 0);
+ fi->valid = 0;
+ /* create sparse vector area (SVA), if necessary */
+ sva = fi->sva;
+ if (sva == NULL)
+ { int sva_n_max = fi->sva_n_max;
+ int sva_size = fi->sva_size;
+ if (sva_n_max == 0)
+ sva_n_max = 6 * n;
+ if (sva_size == 0)
+ sva_size = 10 * n;
+ sva = fi->sva = sva_create_area(sva_n_max, sva_size);
+ }
+ /* allocate/reallocate underlying objects, if necessary */
+ if (fi->n_max < n)
+ { int n_max = fi->n_max;
+ if (n_max == 0)
+ n_max = fi->n_max = n + fi->delta_n0;
+ else
+ n_max = fi->n_max = n + fi->delta_n;
+ xassert(n_max >= n);
+ /* allocate/reallocate block triangular factorization (BTF) */
+ btf = fi->btf;
+ if (btf == NULL)
+ { btf = fi->btf = talloc(1, BTF);
+ memset(btf, 0, sizeof(BTF));
+ btf->sva = sva;
+ }
+ else
+ { tfree(btf->pp_ind);
+ tfree(btf->pp_inv);
+ tfree(btf->qq_ind);
+ tfree(btf->qq_inv);
+ tfree(btf->beg);
+ tfree(btf->vr_piv);
+ tfree(btf->p1_ind);
+ tfree(btf->p1_inv);
+ tfree(btf->q1_ind);
+ tfree(btf->q1_inv);
+ }
+ btf->pp_ind = talloc(1+n_max, int);
+ btf->pp_inv = talloc(1+n_max, int);
+ btf->qq_ind = talloc(1+n_max, int);
+ btf->qq_inv = talloc(1+n_max, int);
+ btf->beg = talloc(1+n_max+1, int);
+ btf->vr_piv = talloc(1+n_max, double);
+ btf->p1_ind = talloc(1+n_max, int);
+ btf->p1_inv = talloc(1+n_max, int);
+ btf->q1_ind = talloc(1+n_max, int);
+ btf->q1_inv = talloc(1+n_max, int);
+ /* allocate/reallocate factorizer workspace (SGF) */
+ /* (note that for SGF we could use the size of largest block
+ * rather than n_max) */
+ sgf = fi->sgf;
+ sgf = fi->sgf;
+ if (sgf == NULL)
+ { sgf = fi->sgf = talloc(1, SGF);
+ memset(sgf, 0, sizeof(SGF));
+ }
+ else
+ { tfree(sgf->rs_head);
+ tfree(sgf->rs_prev);
+ tfree(sgf->rs_next);
+ tfree(sgf->cs_head);
+ tfree(sgf->cs_prev);
+ tfree(sgf->cs_next);
+ tfree(sgf->vr_max);
+ tfree(sgf->flag);
+ tfree(sgf->work);
+ }
+ sgf->rs_head = talloc(1+n_max, int);
+ sgf->rs_prev = talloc(1+n_max, int);
+ sgf->rs_next = talloc(1+n_max, int);
+ sgf->cs_head = talloc(1+n_max, int);
+ sgf->cs_prev = talloc(1+n_max, int);
+ sgf->cs_next = talloc(1+n_max, int);
+ sgf->vr_max = talloc(1+n_max, double);
+ sgf->flag = talloc(1+n_max, char);
+ sgf->work = talloc(1+n_max, double);
+ }
+ btf = fi->btf;
+ btf->n = n;
+ sgf = fi->sgf;
+#if 1 /* FIXME */
+ /* initialize SVA */
+ sva->n = 0;
+ sva->m_ptr = 1;
+ sva->r_ptr = sva->size + 1;
+ sva->head = sva->tail = 0;
+#endif
+ /* store pattern of original matrix A in column-wise format */
+ btf->ac_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf_store_a_cols(btf, col, info, btf->pp_ind, btf->vr_piv);
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+#endif
+ /* analyze pattern of original matrix A and determine permutation
+ * matrices P and Q such that A = P * A~* Q, where A~ is an upper
+ * block triangular matrix */
+ rank = btf_make_blocks(btf);
+ if (rank != n)
+ { /* original matrix A is structurally singular */
+ return 1;
+ }
+#ifdef GLP_DEBUG
+ btf_check_blocks(btf);
+#endif
+#if 1 /* FIXME */
+ /* initialize SVA */
+ sva->n = 0;
+ sva->m_ptr = 1;
+ sva->r_ptr = sva->size + 1;
+ sva->head = sva->tail = 0;
+#endif
+ /* allocate sparse vectors in SVA */
+ btf->ar_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf->ac_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf->fr_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf->fc_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf->vr_ref = sva_alloc_vecs(btf->sva, btf->n);
+ btf->vc_ref = sva_alloc_vecs(btf->sva, btf->n);
+ /* setup factorizer control parameters */
+ sgf->updat = 0; /* wichtig! */
+ sgf->piv_tol = fi->sgf_piv_tol;
+ sgf->piv_lim = fi->sgf_piv_lim;
+ sgf->suhl = fi->sgf_suhl;
+ sgf->eps_tol = fi->sgf_eps_tol;
+ /* compute LU-factorizations of diagonal blocks A~[k,k] and also
+ * store corresponding columns of matrix A except elements of all
+ * blocks A~[k,k] */
+ for (k = 1; k <= btf->num; k++)
+ { if (btf->beg[k+1] - btf->beg[k] == 1)
+ { /* trivial case (A~[k,k] has unity order) */
+ factorize_triv(fi, k, col, info);
+ }
+ else
+ { /* general case */
+ if (factorize_block(fi, k, col, info) != 0)
+ return 2; /* factorization of A~[k,k] failed */
+ }
+ }
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+#endif
+ /* build row-wise representation of matrix A */
+ btf_build_a_rows(fi->btf, fi->sgf->rs_head);
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+#endif
+ /* BT-factorization has been successfully computed */
+ fi->valid = 1;
+ return 0;
+}
+
+void btfint_delete(BTFINT *fi)
+{ /* delete interface to BT-factorization */
+ SVA *sva = fi->sva;
+ BTF *btf = fi->btf;
+ SGF *sgf = fi->sgf;
+ if (sva != NULL)
+ sva_delete_area(sva);
+ if (btf != NULL)
+ { tfree(btf->pp_ind);
+ tfree(btf->pp_inv);
+ tfree(btf->qq_ind);
+ tfree(btf->qq_inv);
+ tfree(btf->beg);
+ tfree(btf->vr_piv);
+ tfree(btf->p1_ind);
+ tfree(btf->p1_inv);
+ tfree(btf->q1_ind);
+ tfree(btf->q1_inv);
+ tfree(btf);
+ }
+ if (sgf != NULL)
+ { tfree(sgf->rs_head);
+ tfree(sgf->rs_prev);
+ tfree(sgf->rs_next);
+ tfree(sgf->cs_head);
+ tfree(sgf->cs_prev);
+ tfree(sgf->cs_next);
+ tfree(sgf->vr_max);
+ tfree(sgf->flag);
+ tfree(sgf->work);
+ tfree(sgf);
+ }
+ tfree(fi);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/btfint.h b/test/monniaux/glpk-4.65/src/bflib/btfint.h
new file mode 100644
index 00000000..8d0e70e2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/btfint.h
@@ -0,0 +1,73 @@
+/* btfint.h (interface to BT-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef BTFINT_H
+#define BTFINT_H
+
+#include "btf.h"
+#include "sgf.h"
+
+typedef struct BTFINT BTFINT;
+
+struct BTFINT
+{ /* interface to BT-factorization */
+ int n_max;
+ /* maximal value of n (increased automatically) */
+ int valid;
+ /* factorization is valid only if this flag is set */
+ SVA *sva;
+ /* sparse vector area (SVA) */
+ BTF *btf;
+ /* sparse block triangular LU-factorization */
+ SGF *sgf;
+ /* sparse Gaussian factorizer workspace */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ int sva_n_max, sva_size;
+ /* parameters passed to sva_create_area */
+ int delta_n0, delta_n;
+ /* if n_max = 0, set n_max = n + delta_n0
+ * if n_max < n, set n_max = n + delta_n */
+ double sgf_piv_tol;
+ int sgf_piv_lim;
+ int sgf_suhl;
+ double sgf_eps_tol;
+ /* factorizer control parameters */
+};
+
+#define btfint_create _glp_btfint_create
+BTFINT *btfint_create(void);
+/* create interface to BT-factorization */
+
+#define btfint_factorize _glp_btfint_factorize
+int btfint_factorize(BTFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info);
+/* compute BT-factorization of specified matrix A */
+
+#define btfint_delete _glp_btfint_delete
+void btfint_delete(BTFINT *fi);
+/* delete interface to BT-factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/fhv.c b/test/monniaux/glpk-4.65/src/bflib/fhv.c
new file mode 100644
index 00000000..e4bdf855
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/fhv.c
@@ -0,0 +1,586 @@
+/* fhv.c (sparse updatable FHV-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "fhv.h"
+
+/***********************************************************************
+* fhv_ft_update - update FHV-factorization (Forrest-Tomlin)
+*
+* This routine updates FHV-factorization of the original matrix A
+* after replacing its j-th column by a new one. The routine is based
+* on the method proposed by Forrest and Tomlin [1].
+*
+* The parameter q specifies the number of column of A, which has been
+* replaced, 1 <= q <= n, where n is the order of A.
+*
+* Row indices and numerical values of non-zero elements of the new
+* j-th column of A should be placed in locations aq_ind[1], ...,
+* aq_ind[aq_len] and aq_val[1], ..., aq_val[aq_len], respectively,
+* where aq_len is the number of non-zeros. Neither zero nor duplicate
+* elements are allowed.
+*
+* The working arrays ind, val, and work should have at least 1+n
+* elements (0-th elements are not used).
+*
+* RETURNS
+*
+* 0 The factorization has been successfully updated.
+*
+* 1 New matrix U = P'* V * Q' is upper triangular with zero diagonal
+* element u[s,s]. (Elimination was not performed.)
+*
+* 2 New matrix U = P'* V * Q' is upper triangular, and its diagonal
+* element u[s,s] or u[t,t] is too small in magnitude. (Elimination
+* was not performed.)
+*
+* 3 The same as 2, but after performing elimination.
+*
+* 4 The factorization has not been updated, because maximal number of
+* updates has been reached.
+*
+* 5 Accuracy test failed for the updated factorization.
+*
+* BACKGROUND
+*
+* The routine is based on the updating method proposed by Forrest and
+* Tomlin [1].
+*
+* Let q-th column of the original matrix A have been replaced by new
+* column A[q]. Then, to keep the equality A = F * H * V, q-th column
+* of matrix V should be replaced by column V[q] = inv(F * H) * A[q].
+* From the standpoint of matrix U = P'* V * Q' such replacement is
+* equivalent to replacement of s-th column of matrix U, where s is
+* determined from q by permutation matrix Q. Thus, matrix U loses its
+* upper triangular form and becomes the following:
+*
+* 1 s t n
+* 1 x x * x x x x x x
+* . x * x x x x x x
+* s . . * x x x x x x
+* . . * x x x x x x
+* . . * . x x x x x
+* . . * . . x x x x
+* t . . * . . . x x x
+* . . . . . . . x x
+* n . . . . . . . . x
+*
+* where t is largest row index of a non-zero element in s-th column.
+*
+* The routine makes matrix U upper triangular as follows. First, it
+* moves rows and columns s+1, ..., t by one position to the left and
+* upwards, resp., and moves s-th row and s-th column to position t.
+* Due to such symmetric permutations matrix U becomes the following
+* (note that all diagonal elements remain on the diagonal, and element
+* u[s,s] becomes u[t,t]):
+*
+* 1 s t n
+* 1 x x x x x x * x x
+* . x x x x x * x x
+* s . . x x x x * x x
+* . . . x x x * x x
+* . . . . x x * x x
+* . . . . . x * x x
+* t . . x x x x * x x
+* . . . . . . . x x
+* n . . . . . . . . x
+*
+* Then the routine performs gaussian elimination to eliminate
+* subdiagonal elements u[t,s], ..., u[t,t-1] using diagonal elements
+* u[s,s], ..., u[t-1,t-1] as pivots. During the elimination process
+* the routine permutes neither rows nor columns, so only t-th row is
+* changed. Should note that actually all operations are performed on
+* matrix V = P * U * Q, since matrix U is not stored.
+*
+* To keep the equality A = F * H * V, the routine appends new row-like
+* factor H[k] to matrix H, and every time it applies elementary
+* gaussian transformation to eliminate u[t,j'] = v[p,j] using pivot
+* u[j',j'] = v[i,j], it also adds new element f[p,j] = v[p,j] / v[i,j]
+* (gaussian multiplier) to factor H[k], which initially is a unity
+* matrix. At the end of elimination process the row-like factor H[k]
+* may look as follows:
+*
+* 1 n 1 s t n
+* 1 1 . . . . . . . . 1 1 . . . . . . . .
+* . 1 . . . . . . . . 1 . . . . . . .
+* . . 1 . . . . . . s . . 1 . . . . . .
+* p . x x 1 . x . x . . . . 1 . . . . .
+* . . . . 1 . . . . . . . . 1 . . . .
+* . . . . . 1 . . . . . . . . 1 . . .
+* . . . . . . 1 . . t . . x x x x 1 . .
+* . . . . . . . 1 . . . . . . . . 1 .
+* n . . . . . . . . 1 n . . . . . . . . 1
+*
+* H[k] inv(P) * H[k] * P
+*
+* If, however, s = t, no elimination is needed, in which case no new
+* row-like factor is created.
+*
+* REFERENCES
+*
+* 1. J.J.H.Forrest and J.A.Tomlin, "Updated triangular factors of the
+* basis to maintain sparsity in the product form simplex method,"
+* Math. Prog. 2 (1972), pp. 263-78. */
+
+int fhv_ft_update(FHV *fhv, int q, int aq_len, const int aq_ind[],
+ const double aq_val[], int ind[/*1+n*/], double val[/*1+n*/],
+ double work[/*1+n*/])
+{ LUF *luf = fhv->luf;
+ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int *vr_cap = &sva->cap[vr_ref-1];
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *vc_cap = &sva->cap[vc_ref-1];
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int *hh_ind = fhv->hh_ind;
+ int hh_ref = fhv->hh_ref;
+ int *hh_ptr = &sva->ptr[hh_ref-1];
+ int *hh_len = &sva->len[hh_ref-1];
+#if 1 /* FIXME */
+ const double eps_tol = DBL_EPSILON;
+ const double vpq_tol = 1e-5;
+ const double err_tol = 1e-10;
+#endif
+ int end, i, i_end, i_ptr, j, j_end, j_ptr, k, len, nnz, p, p_end,
+ p_ptr, ptr, q_end, q_ptr, s, t;
+ double f, vpq, temp;
+ /*--------------------------------------------------------------*/
+ /* replace current q-th column of matrix V by new one */
+ /*--------------------------------------------------------------*/
+ xassert(1 <= q && q <= n);
+ /* convert new q-th column of matrix A to dense format */
+ for (i = 1; i <= n; i++)
+ val[i] = 0.0;
+ xassert(0 <= aq_len && aq_len <= n);
+ for (k = 1; k <= aq_len; k++)
+ { i = aq_ind[k];
+ xassert(1 <= i && i <= n);
+ xassert(val[i] == 0.0);
+ xassert(aq_val[k] != 0.0);
+ val[i] = aq_val[k];
+ }
+ /* compute new q-th column of matrix V:
+ * new V[q] = inv(F * H) * (new A[q]) */
+ luf->pp_ind = fhv->p0_ind;
+ luf->pp_inv = fhv->p0_inv;
+ luf_f_solve(luf, val);
+ luf->pp_ind = pp_ind;
+ luf->pp_inv = pp_inv;
+ fhv_h_solve(fhv, val);
+ /* q-th column of V = s-th column of U */
+ s = qq_inv[q];
+ /* determine row number of element v[p,q] that corresponds to
+ * diagonal element u[s,s] */
+ p = pp_inv[s];
+ /* convert new q-th column of V to sparse format;
+ * element v[p,q] = u[s,s] is not included in the element list
+ * and stored separately */
+ vpq = 0.0;
+ len = 0;
+ for (i = 1; i <= n; i++)
+ { temp = val[i];
+#if 1 /* FIXME */
+ if (-eps_tol < temp && temp < +eps_tol)
+#endif
+ /* nop */;
+ else if (i == p)
+ vpq = temp;
+ else
+ { ind[++len] = i;
+ val[len] = temp;
+ }
+ }
+ /* clear q-th column of matrix V */
+ for (q_end = (q_ptr = vc_ptr[q]) + vc_len[q];
+ q_ptr < q_end; q_ptr++)
+ { /* get row index of v[i,q] */
+ i = sv_ind[q_ptr];
+ /* find and remove v[i,q] from i-th row */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ sv_ind[i_ptr] != q; i_ptr++)
+ /* nop */;
+ xassert(i_ptr < i_end);
+ sv_ind[i_ptr] = sv_ind[i_end-1];
+ sv_val[i_ptr] = sv_val[i_end-1];
+ vr_len[i]--;
+ }
+ /* now q-th column of matrix V is empty */
+ vc_len[q] = 0;
+ /* put new q-th column of V (except element v[p,q] = u[s,s]) in
+ * column-wise format */
+ if (len > 0)
+ { if (vc_cap[q] < len)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vc_ref-1+q, len, 0);
+ }
+ ptr = vc_ptr[q];
+ memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
+ vc_len[q] = len;
+ }
+ /* put new q-th column of V (except element v[p,q] = u[s,s]) in
+ * row-wise format, and determine largest row number t such that
+ * u[s,t] != 0 */
+ t = (vpq == 0.0 ? 0 : s);
+ for (k = 1; k <= len; k++)
+ { /* get row index of v[i,q] */
+ i = ind[k];
+ /* put v[i,q] to i-th row */
+ if (vr_cap[i] == vr_len[i])
+ { /* reserve extra locations in i-th row to reduce further
+ * relocations of that row */
+#if 1 /* FIXME */
+ int need = vr_len[i] + 5;
+#endif
+ if (sva->r_ptr - sva->m_ptr < need)
+ { sva_more_space(sva, need);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vr_ref-1+i, need, 0);
+ }
+ sv_ind[ptr = vr_ptr[i] + (vr_len[i]++)] = q;
+ sv_val[ptr] = val[k];
+ /* v[i,q] is non-zero; increase t */
+ if (t < pp_ind[i])
+ t = pp_ind[i];
+ }
+ /*--------------------------------------------------------------*/
+ /* check if matrix U is already upper triangular */
+ /*--------------------------------------------------------------*/
+ /* check if there is a spike in s-th column of matrix U, which
+ * is q-th column of matrix V */
+ if (s >= t)
+ { /* no spike; matrix U is already upper triangular */
+ /* store its diagonal element u[s,s] = v[p,q] */
+ vr_piv[p] = vpq;
+ if (s > t)
+ { /* matrix U is structurally singular, because its diagonal
+ * element u[s,s] = v[p,q] is exact zero */
+ xassert(vpq == 0.0);
+ return 1;
+ }
+#if 1 /* FIXME */
+ else if (-vpq_tol < vpq && vpq < +vpq_tol)
+#endif
+ { /* matrix U is not well conditioned, because its diagonal
+ * element u[s,s] = v[p,q] is too small in magnitude */
+ return 2;
+ }
+ else
+ { /* normal case */
+ return 0;
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* perform implicit symmetric permutations of rows and columns */
+ /* of matrix U */
+ /*--------------------------------------------------------------*/
+ /* currently v[p,q] = u[s,s] */
+ xassert(p == pp_inv[s] && q == qq_ind[s]);
+ for (k = s; k < t; k++)
+ { pp_ind[pp_inv[k] = pp_inv[k+1]] = k;
+ qq_inv[qq_ind[k] = qq_ind[k+1]] = k;
+ }
+ /* now v[p,q] = u[t,t] */
+ pp_ind[pp_inv[t] = p] = qq_inv[qq_ind[t] = q] = t;
+ /*--------------------------------------------------------------*/
+ /* check if matrix U is already upper triangular */
+ /*--------------------------------------------------------------*/
+ /* check if there is a spike in t-th row of matrix U, which is
+ * p-th row of matrix V */
+ for (p_end = (p_ptr = vr_ptr[p]) + vr_len[p];
+ p_ptr < p_end; p_ptr++)
+ { if (qq_inv[sv_ind[p_ptr]] < t)
+ break; /* spike detected */
+ }
+ if (p_ptr == p_end)
+ { /* no spike; matrix U is already upper triangular */
+ /* store its diagonal element u[t,t] = v[p,q] */
+ vr_piv[p] = vpq;
+#if 1 /* FIXME */
+ if (-vpq_tol < vpq && vpq < +vpq_tol)
+#endif
+ { /* matrix U is not well conditioned, because its diagonal
+ * element u[t,t] = v[p,q] is too small in magnitude */
+ return 2;
+ }
+ else
+ { /* normal case */
+ return 0;
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* copy p-th row of matrix V, which is t-th row of matrix U, to */
+ /* working array */
+ /*--------------------------------------------------------------*/
+ /* copy p-th row of matrix V, including element v[p,q] = u[t,t],
+ * to the working array in dense format and remove these elements
+ * from matrix V; since no pivoting is used, only this row will
+ * change during elimination */
+ for (j = 1; j <= n; j++)
+ work[j] = 0.0;
+ work[q] = vpq;
+ for (p_end = (p_ptr = vr_ptr[p]) + vr_len[p];
+ p_ptr < p_end; p_ptr++)
+ { /* get column index of v[p,j] and store this element to the
+ * working array */
+ work[j = sv_ind[p_ptr]] = sv_val[p_ptr];
+ /* find and remove v[p,j] from j-th column */
+ for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ sv_ind[j_ptr] != p; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ sv_ind[j_ptr] = sv_ind[j_end-1];
+ sv_val[j_ptr] = sv_val[j_end-1];
+ vc_len[j]--;
+ }
+ /* now p-th row of matrix V is temporarily empty */
+ vr_len[p] = 0;
+ /*--------------------------------------------------------------*/
+ /* perform gaussian elimination */
+ /*--------------------------------------------------------------*/
+ /* transform p-th row of matrix V stored in working array, which
+ * is t-th row of matrix U, to eliminate subdiagonal elements
+ * u[t,s], ..., u[t,t-1]; corresponding gaussian multipliers will
+ * form non-trivial row of new row-like factor */
+ nnz = 0; /* number of non-zero gaussian multipliers */
+ for (k = s; k < t; k++)
+ { /* diagonal element u[k,k] = v[i,j] is used as pivot */
+ i = pp_inv[k], j = qq_ind[k];
+ /* take subdiagonal element u[t,k] = v[p,j] */
+ temp = work[j];
+#if 1 /* FIXME */
+ if (-eps_tol < temp && temp < +eps_tol)
+ continue;
+#endif
+ /* compute and save gaussian multiplier:
+ * f := u[t,k] / u[k,k] = v[p,j] / v[i,j] */
+ ind[++nnz] = i;
+ val[nnz] = f = work[j] / vr_piv[i];
+ /* gaussian transformation to eliminate u[t,k] = v[p,j]:
+ * (p-th row of V) := (p-th row of V) - f * (i-th row of V) */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ work[sv_ind[i_ptr]] -= f * sv_val[i_ptr];
+ }
+ /* now matrix U is again upper triangular */
+#if 1 /* FIXME */
+ if (-vpq_tol < work[q] && work[q] < +vpq_tol)
+#endif
+ { /* however, its new diagonal element u[t,t] = v[p,q] is too
+ * small in magnitude */
+ return 3;
+ }
+ /*--------------------------------------------------------------*/
+ /* create new row-like factor H[k] and add to eta file H */
+ /*--------------------------------------------------------------*/
+ /* (nnz = 0 means that all subdiagonal elements were too small
+ * in magnitude) */
+ if (nnz > 0)
+ { if (fhv->nfs == fhv->nfs_max)
+ { /* maximal number of row-like factors has been reached */
+ return 4;
+ }
+ k = ++(fhv->nfs);
+ hh_ind[k] = p;
+ /* store non-trivial row of H[k] in right (dynamic) part of
+ * SVA (diagonal unity element is not stored) */
+ if (sva->r_ptr - sva->m_ptr < nnz)
+ { sva_more_space(sva, nnz);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, fhv->hh_ref-1+k, nnz);
+ ptr = hh_ptr[k];
+ memcpy(&sv_ind[ptr], &ind[1], nnz * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], nnz * sizeof(double));
+ hh_len[k] = nnz;
+ }
+ /*--------------------------------------------------------------*/
+ /* copy transformed p-th row of matrix V, which is t-th row of */
+ /* matrix U, from working array back to matrix V */
+ /*--------------------------------------------------------------*/
+ /* copy elements of transformed p-th row of matrix V, which are
+ * non-diagonal elements u[t,t+1], ..., u[t,n] of matrix U, from
+ * working array to corresponding columns of matrix V (note that
+ * diagonal element u[t,t] = v[p,q] not copied); also transform
+ * p-th row of matrix V to sparse format */
+ len = 0;
+ for (k = t+1; k <= n; k++)
+ { /* j-th column of V = k-th column of U */
+ j = qq_ind[k];
+ /* take non-diagonal element v[p,j] = u[t,k] */
+ temp = work[j];
+#if 1 /* FIXME */
+ if (-eps_tol < temp && temp < +eps_tol)
+ continue;
+#endif
+ /* add v[p,j] to j-th column of matrix V */
+ if (vc_cap[j] == vc_len[j])
+ { /* reserve extra locations in j-th column to reduce further
+ * relocations of that column */
+#if 1 /* FIXME */
+ int need = vc_len[j] + 5;
+#endif
+ if (sva->r_ptr - sva->m_ptr < need)
+ { sva_more_space(sva, need);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vc_ref-1+j, need, 0);
+ }
+ sv_ind[ptr = vc_ptr[j] + (vc_len[j]++)] = p;
+ sv_val[ptr] = temp;
+ /* store element v[p,j] = u[t,k] to working sparse vector */
+ ind[++len] = j;
+ val[len] = temp;
+ }
+ /* copy elements from working sparse vector to p-th row of matrix
+ * V (this row is currently empty) */
+ if (vr_cap[p] < len)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vr_ref-1+p, len, 0);
+ }
+ ptr = vr_ptr[p];
+ memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
+ vr_len[p] = len;
+ /* store new diagonal element u[t,t] = v[p,q] */
+ vr_piv[p] = work[q];
+ /*--------------------------------------------------------------*/
+ /* perform accuracy test (only if new H[k] was added) */
+ /*--------------------------------------------------------------*/
+ if (nnz > 0)
+ { /* copy p-th (non-trivial) row of row-like factor H[k] (except
+ * unity diagonal element) to working array in dense format */
+ for (j = 1; j <= n; j++)
+ work[j] = 0.0;
+ k = fhv->nfs;
+ for (end = (ptr = hh_ptr[k]) + hh_len[k]; ptr < end; ptr++)
+ work[sv_ind[ptr]] = sv_val[ptr];
+ /* compute inner product of p-th (non-trivial) row of matrix
+ * H[k] and q-th column of matrix V */
+ temp = vr_piv[p]; /* 1 * v[p,q] */
+ ptr = vc_ptr[q];
+ end = ptr + vc_len[q];
+ for (; ptr < end; ptr++)
+ temp += work[sv_ind[ptr]] * sv_val[ptr];
+ /* inner product should be equal to element v[p,q] *before*
+ * matrix V was transformed */
+ /* compute relative error */
+ temp = fabs(vpq - temp) / (1.0 + fabs(vpq));
+#if 1 /* FIXME */
+ if (temp > err_tol)
+#endif
+ { /* relative error is too large */
+ return 5;
+ }
+ }
+ /* factorization has been successfully updated */
+ return 0;
+}
+
+/***********************************************************************
+* fhv_h_solve - solve system H * x = b
+*
+* This routine solves the system H * x = b, where the matrix H is the
+* middle factor of the sparse updatable FHV-factorization.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix H. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void fhv_h_solve(FHV *fhv, double x[/*1+n*/])
+{ SVA *sva = fhv->luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int nfs = fhv->nfs;
+ int *hh_ind = fhv->hh_ind;
+ int hh_ref = fhv->hh_ref;
+ int *hh_ptr = &sva->ptr[hh_ref-1];
+ int *hh_len = &sva->len[hh_ref-1];
+ int i, k, end, ptr;
+ double x_i;
+ for (k = 1; k <= nfs; k++)
+ { x_i = x[i = hh_ind[k]];
+ for (end = (ptr = hh_ptr[k]) + hh_len[k]; ptr < end; ptr++)
+ x_i -= sv_val[ptr] * x[sv_ind[ptr]];
+ x[i] = x_i;
+ }
+ return;
+}
+
+/***********************************************************************
+* fhv_ht_solve - solve system H' * x = b
+*
+* This routine solves the system H' * x = b, where H' is a matrix
+* transposed to the matrix H, which is the middle factor of the sparse
+* updatable FHV-factorization.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix H. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void fhv_ht_solve(FHV *fhv, double x[/*1+n*/])
+{ SVA *sva = fhv->luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int nfs = fhv->nfs;
+ int *hh_ind = fhv->hh_ind;
+ int hh_ref = fhv->hh_ref;
+ int *hh_ptr = &sva->ptr[hh_ref-1];
+ int *hh_len = &sva->len[hh_ref-1];
+ int k, end, ptr;
+ double x_j;
+ for (k = nfs; k >= 1; k--)
+ { if ((x_j = x[hh_ind[k]]) == 0.0)
+ continue;
+ for (end = (ptr = hh_ptr[k]) + hh_len[k]; ptr < end; ptr++)
+ x[sv_ind[ptr]] -= sv_val[ptr] * x_j;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/fhv.h b/test/monniaux/glpk-4.65/src/bflib/fhv.h
new file mode 100644
index 00000000..df39ca5c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/fhv.h
@@ -0,0 +1,114 @@
+/* fhv.h (sparse updatable FHV-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef FHV_H
+#define FHV_H
+
+#include "luf.h"
+
+/***********************************************************************
+* The structure FHV describes sparse updatable FHV-factorization.
+*
+* The FHV-factorization has the following format:
+*
+* A = F * H * V, (1)
+*
+* F = P0 * L * P0', (2)
+*
+* H = H[1] * H[2] * ... * H[nfs], (3)
+*
+* V = P * U * Q, (4)
+*
+* where: A is a given (unsymmetric) square matrix; F, H, V are matrix
+* factors actually computed; L is a lower triangular matrix with unity
+* diagonal; U is an upper tringular matrix; H[k], k = 1, 2, ..., nfs,
+* is a row-like factor, which differs from unity matrix only in one
+* row called a non-trivial row; P0, P, Q are permutation matrices; and
+* P0' is a matrix transposed to P0.
+*
+* Matrices F, V, P, Q are stored in the underlying LUF object.
+*
+* Non-trivial rows of factors H[k] are stored as sparse vectors in the
+* right (static) part of the sparse vector area (SVA). Note that unity
+* diagonal elements of non-trivial rows are not stored.
+*
+* Matrix P0 is stored in the same way as matrix P.
+*
+* Matrices L and U are completely defined by matrices F, V, P, and Q,
+* and therefore not stored explicitly. */
+
+typedef struct FHV FHV;
+
+struct FHV
+{ /* FHV-factorization */
+ LUF *luf;
+ /* LU-factorization (contains matrices F, V, P, Q) */
+ /*--------------------------------------------------------------*/
+ /* matrix H in the form of eta file */
+ int nfs_max;
+ /* maximal number of row-like factors (this limits the number of
+ * updates of the factorization) */
+ int nfs;
+ /* current number of row-like factors, 0 <= nfs <= nfs_max */
+ int *hh_ind; /* int hh_ind[1+nfs_max]; */
+ /* hh_ind[0] is not used;
+ * hh_ind[k], 1 <= k <= nfs, is number of non-trivial row of
+ * factor H[k] */
+ int hh_ref;
+ /* reference number of sparse vector in SVA, which is non-trivial
+ * row of factor H[1] */
+#if 0 + 0
+ int *hh_ptr = &sva->ptr[hh_ref-1];
+ /* hh_ptr[0] is not used;
+ * hh_ptr[k], 1 <= k <= nfs, is pointer to non-trivial row of
+ * factor H[k] */
+ int *hh_len = &sva->len[hh_ref-1];
+ /* hh_len[0] is not used;
+ * hh_len[k], 1 <= k <= nfs, is number of non-zero elements in
+ * non-trivial row of factor H[k] */
+#endif
+ /*--------------------------------------------------------------*/
+ /* matrix P0 */
+ int *p0_ind; /* int p0_ind[1+n]; */
+ /* p0_ind[i] = j means that P0[i,j] = 1 */
+ int *p0_inv; /* int p0_inv[1+n]; */
+ /* p0_inv[j] = i means that P0[i,j] = 1 */
+};
+
+#define fhv_ft_update _glp_fhv_ft_update
+int fhv_ft_update(FHV *fhv, int q, int aq_len, const int aq_ind[],
+ const double aq_val[], int ind[/*1+n*/], double val[/*1+n*/],
+ double work[/*1+n*/]);
+/* update FHV-factorization (Forrest-Tomlin) */
+
+#define fhv_h_solve _glp_fhv_h_solve
+void fhv_h_solve(FHV *fhv, double x[/*1+n*/]);
+/* solve system H * x = b */
+
+#define fhv_ht_solve _glp_fhv_ht_solve
+void fhv_ht_solve(FHV *fhv, double x[/*1+n*/]);
+/* solve system H' * x = b */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/fhvint.c b/test/monniaux/glpk-4.65/src/bflib/fhvint.c
new file mode 100644
index 00000000..a21b71c6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/fhvint.c
@@ -0,0 +1,168 @@
+/* fhvint.c (interface to FHV-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "fhvint.h"
+
+FHVINT *fhvint_create(void)
+{ /* create interface to FHV-factorization */
+ FHVINT *fi;
+ fi = talloc(1, FHVINT);
+ memset(fi, 0, sizeof(FHVINT));
+ fi->lufi = lufint_create();
+ return fi;
+}
+
+int fhvint_factorize(FHVINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info)
+{ /* compute FHV-factorization of specified matrix A */
+ int nfs_max, old_n_max, n_max, k, ret;
+ xassert(n > 0);
+ fi->valid = 0;
+ /* get required value of nfs_max */
+ nfs_max = fi->nfs_max;
+ if (nfs_max == 0)
+ nfs_max = 100;
+ xassert(nfs_max > 0);
+ /* compute factorization of specified matrix A */
+ old_n_max = fi->lufi->n_max;
+ fi->lufi->sva_n_max = 4 * n + nfs_max;
+ fi->lufi->sgf_updat = 1;
+ ret = lufint_factorize(fi->lufi, n, col, info);
+ n_max = fi->lufi->n_max;
+ /* allocate/reallocate arrays, if necessary */
+ if (fi->fhv.nfs_max != nfs_max)
+ { if (fi->fhv.hh_ind != NULL)
+ tfree(fi->fhv.hh_ind);
+ fi->fhv.hh_ind = talloc(1+nfs_max, int);
+ }
+ if (old_n_max < n_max)
+ { if (fi->fhv.p0_ind != NULL)
+ tfree(fi->fhv.p0_ind);
+ if (fi->fhv.p0_inv != NULL)
+ tfree(fi->fhv.p0_inv);
+ fi->fhv.p0_ind = talloc(1+n_max, int);
+ fi->fhv.p0_inv = talloc(1+n_max, int);
+ }
+ /* initialize FHV-factorization */
+ fi->fhv.luf = fi->lufi->luf;
+ fi->fhv.nfs_max = nfs_max;
+ /* H := I */
+ fi->fhv.nfs = 0;
+ fi->fhv.hh_ref = sva_alloc_vecs(fi->lufi->sva, nfs_max);
+ /* P0 := P */
+ for (k = 1; k <= n; k++)
+ { fi->fhv.p0_ind[k] = fi->fhv.luf->pp_ind[k];
+ fi->fhv.p0_inv[k] = fi->fhv.luf->pp_inv[k];
+ }
+ /* set validation flag */
+ if (ret == 0)
+ fi->valid = 1;
+ return ret;
+}
+
+int fhvint_update(FHVINT *fi, int j, int len, const int ind[],
+ const double val[])
+{ /* update FHV-factorization after replacing j-th column of A */
+ SGF *sgf = fi->lufi->sgf;
+ int *ind1 = sgf->rs_next;
+ double *val1 = sgf->vr_max;
+ double *work = sgf->work;
+ int ret;
+ xassert(fi->valid);
+ ret = fhv_ft_update(&fi->fhv, j, len, ind, val, ind1, val1, work);
+ if (ret != 0)
+ fi->valid = 0;
+ return ret;
+}
+
+void fhvint_ftran(FHVINT *fi, double x[])
+{ /* solve system A * x = b */
+ FHV *fhv = &fi->fhv;
+ LUF *luf = fhv->luf;
+ int n = luf->n;
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ SGF *sgf = fi->lufi->sgf;
+ double *work = sgf->work;
+ xassert(fi->valid);
+ /* A = F * H * V */
+ /* x = inv(A) * b = inv(V) * inv(H) * inv(F) * b */
+ luf->pp_ind = fhv->p0_ind;
+ luf->pp_inv = fhv->p0_inv;
+ luf_f_solve(luf, x);
+ luf->pp_ind = pp_ind;
+ luf->pp_inv = pp_inv;
+ fhv_h_solve(fhv, x);
+ luf_v_solve(luf, x, work);
+ memcpy(&x[1], &work[1], n * sizeof(double));
+ return;
+}
+
+void fhvint_btran(FHVINT *fi, double x[])
+{ /* solve system A'* x = b */
+ FHV *fhv = &fi->fhv;
+ LUF *luf = fhv->luf;
+ int n = luf->n;
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ SGF *sgf = fi->lufi->sgf;
+ double *work = sgf->work;
+ xassert(fi->valid);
+ /* A' = (F * H * V)' = V'* H'* F' */
+ /* x = inv(A') * b = inv(F') * inv(H') * inv(V') * b */
+ luf_vt_solve(luf, x, work);
+ fhv_ht_solve(fhv, work);
+ luf->pp_ind = fhv->p0_ind;
+ luf->pp_inv = fhv->p0_inv;
+ luf_ft_solve(luf, work);
+ luf->pp_ind = pp_ind;
+ luf->pp_inv = pp_inv;
+ memcpy(&x[1], &work[1], n * sizeof(double));
+ return;
+}
+
+double fhvint_estimate(FHVINT *fi)
+{ /* estimate 1-norm of inv(A) */
+ double norm;
+ xassert(fi->valid);
+ xassert(fi->fhv.nfs == 0);
+ norm = luf_estimate_norm(fi->fhv.luf, fi->lufi->sgf->vr_max,
+ fi->lufi->sgf->work);
+ return norm;
+}
+
+void fhvint_delete(FHVINT *fi)
+{ /* delete interface to FHV-factorization */
+ lufint_delete(fi->lufi);
+ if (fi->fhv.hh_ind != NULL)
+ tfree(fi->fhv.hh_ind);
+ if (fi->fhv.p0_ind != NULL)
+ tfree(fi->fhv.p0_ind);
+ if (fi->fhv.p0_inv != NULL)
+ tfree(fi->fhv.p0_inv);
+ tfree(fi);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/fhvint.h b/test/monniaux/glpk-4.65/src/bflib/fhvint.h
new file mode 100644
index 00000000..000829c6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/fhvint.h
@@ -0,0 +1,78 @@
+/* fhvint.h (interface to FHV-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef FHVINT_H
+#define FHVINT_H
+
+#include "fhv.h"
+#include "lufint.h"
+
+typedef struct FHVINT FHVINT;
+
+struct FHVINT
+{ /* interface to FHV-factorization */
+ int valid;
+ /* factorization is valid only if this flag is set */
+ FHV fhv;
+ /* FHV-factorization */
+ LUFINT *lufi;
+ /* interface to underlying LU-factorization */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ int nfs_max;
+ /* required maximal number of row-like factors */
+};
+
+#define fhvint_create _glp_fhvint_create
+FHVINT *fhvint_create(void);
+/* create interface to FHV-factorization */
+
+#define fhvint_factorize _glp_fhvint_factorize
+int fhvint_factorize(FHVINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info);
+/* compute FHV-factorization of specified matrix A */
+
+#define fhvint_update _glp_fhvint_update
+int fhvint_update(FHVINT *fi, int j, int len, const int ind[],
+ const double val[]);
+/* update FHV-factorization after replacing j-th column of A */
+
+#define fhvint_ftran _glp_fhvint_ftran
+void fhvint_ftran(FHVINT *fi, double x[]);
+/* solve system A * x = b */
+
+#define fhvint_btran _glp_fhvint_btran
+void fhvint_btran(FHVINT *fi, double x[]);
+/* solve system A'* x = b */
+
+#define fhvint_estimate _glp_fhvint_estimate
+double fhvint_estimate(FHVINT *fi);
+/* estimate 1-norm of inv(A) */
+
+#define fhvint_delete _glp_fhvint_delete
+void fhvint_delete(FHVINT *fi);
+/* delete interface to FHV-factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/ifu.c b/test/monniaux/glpk-4.65/src/bflib/ifu.c
new file mode 100644
index 00000000..aa47fb09
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/ifu.c
@@ -0,0 +1,392 @@
+/* ifu.c (dense updatable IFU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ifu.h"
+
+/***********************************************************************
+* ifu_expand - expand IFU-factorization
+*
+* This routine expands the IFU-factorization of the matrix A according
+* to the following expansion of A:
+*
+* ( A c )
+* new A = ( )
+* ( r' d )
+*
+* where c[1,...,n] is a new column, r[1,...,n] is a new row, and d is
+* a new diagonal element.
+*
+* From the main equality F * A = U it follows that:
+*
+* ( F 0 ) ( A c ) ( FA Fc ) ( U Fc )
+* ( ) ( ) = ( ) = ( ),
+* ( 0 1 ) ( r' d ) ( r' d ) ( r' d )
+*
+* thus,
+*
+* ( F 0 ) ( U Fc )
+* new F = ( ), new U = ( ).
+* ( 0 1 ) ( r' d )
+*
+* Note that the resulting matrix U loses its upper triangular form due
+* to row spike r', which should be eliminated. */
+
+void ifu_expand(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d)
+{ /* non-optimized version */
+ int n_max = ifu->n_max;
+ int n = ifu->n;
+ double *f_ = ifu->f;
+ double *u_ = ifu->u;
+ int i, j;
+ double t;
+# define f(i,j) f_[(i)*n_max+(j)]
+# define u(i,j) u_[(i)*n_max+(j)]
+ xassert(0 <= n && n < n_max);
+ /* adjust indexing */
+ c++, r++;
+ /* set new zero column of matrix F */
+ for (i = 0; i < n; i++)
+ f(i,n) = 0.0;
+ /* set new zero row of matrix F */
+ for (j = 0; j < n; j++)
+ f(n,j) = 0.0;
+ /* set new unity diagonal element of matrix F */
+ f(n,n) = 1.0;
+ /* set new column of matrix U to vector (old F) * c */
+ for (i = 0; i < n; i++)
+ { /* u[i,n] := (i-th row of old F) * c */
+ t = 0.0;
+ for (j = 0; j < n; j++)
+ t += f(i,j) * c[j];
+ u(i,n) = t;
+ }
+ /* set new row of matrix U to vector r */
+ for (j = 0; j < n; j++)
+ u(n,j) = r[j];
+ /* set new diagonal element of matrix U to scalar d */
+ u(n,n) = d;
+ /* increase factorization order */
+ ifu->n++;
+# undef f
+# undef u
+ return;
+}
+
+/***********************************************************************
+* ifu_bg_update - update IFU-factorization (Bartels-Golub)
+*
+* This routine updates IFU-factorization of the matrix A according to
+* its expansion (see comments to the routine ifu_expand). The routine
+* is based on the method proposed by Bartels and Golub [1].
+*
+* RETURNS
+*
+* 0 The factorization has been successfully updated.
+*
+* 1 On some elimination step diagional element u[k,k] to be used as
+* pivot is too small in magnitude.
+*
+* 2 Diagonal element u[n,n] is too small in magnitude (at the end of
+* update).
+*
+* REFERENCES
+*
+* 1. R.H.Bartels, G.H.Golub, "The Simplex Method of Linear Programming
+* Using LU-decomposition", Comm. ACM, 12, pp. 266-68, 1969. */
+
+int ifu_bg_update(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d)
+{ /* non-optimized version */
+ int n_max = ifu->n_max;
+ int n = ifu->n;
+ double *f_ = ifu->f;
+ double *u_ = ifu->u;
+#if 1 /* FIXME */
+ double tol = 1e-5;
+#endif
+ int j, k;
+ double t;
+# define f(i,j) f_[(i)*n_max+(j)]
+# define u(i,j) u_[(i)*n_max+(j)]
+ /* expand factorization */
+ ifu_expand(ifu, c, r, d);
+ /* NOTE: n keeps its old value */
+ /* eliminate spike (non-zero subdiagonal elements) in last row of
+ * matrix U */
+ for (k = 0; k < n; k++)
+ { /* if |u[k,k]| < |u[n,k]|, interchange k-th and n-th rows to
+ * provide |u[k,k]| >= |u[n,k]| for numeric stability */
+ if (fabs(u(k,k)) < fabs(u(n,k)))
+ { /* interchange k-th and n-th rows of matrix U */
+ for (j = k; j <= n; j++)
+ t = u(k,j), u(k,j) = u(n,j), u(n,j) = t;
+ /* interchange k-th and n-th rows of matrix F to keep the
+ * main equality F * A = U */
+ for (j = 0; j <= n; j++)
+ t = f(k,j), f(k,j) = f(n,j), f(n,j) = t;
+ }
+ /* now |u[k,k]| >= |u[n,k]| */
+ /* check if diagonal element u[k,k] can be used as pivot */
+ if (fabs(u(k,k)) < tol)
+ { /* u[k,k] is too small in magnitude */
+ return 1;
+ }
+ /* if u[n,k] = 0, elimination is not needed */
+ if (u(n,k) == 0.0)
+ continue;
+ /* compute gaussian multiplier t = u[n,k] / u[k,k] */
+ t = u(n,k) / u(k,k);
+ /* apply gaussian transformation to eliminate u[n,k] */
+ /* (n-th row of U) := (n-th row of U) - t * (k-th row of U) */
+ for (j = k+1; j <= n; j++)
+ u(n,j) -= t * u(k,j);
+ /* apply the same transformation to matrix F to keep the main
+ * equality F * A = U */
+ for (j = 0; j <= n; j++)
+ f(n,j) -= t * f(k,j);
+ }
+ /* now matrix U is upper triangular */
+ if (fabs(u(n,n)) < tol)
+ { /* u[n,n] is too small in magnitude */
+ return 2;
+ }
+# undef f
+# undef u
+ return 0;
+}
+
+/***********************************************************************
+* The routine givens computes the parameters of Givens plane rotation
+* c = cos(teta) and s = sin(teta) such that:
+*
+* ( c -s ) ( a ) ( r )
+* ( ) ( ) = ( ) ,
+* ( s c ) ( b ) ( 0 )
+*
+* where a and b are given scalars.
+*
+* REFERENCES
+*
+* G.H.Golub, C.F.Van Loan, "Matrix Computations", 2nd ed. */
+
+static void givens(double a, double b, double *c, double *s)
+{ /* non-optimized version */
+ double t;
+ if (b == 0.0)
+ (*c) = 1.0, (*s) = 0.0;
+ else if (fabs(a) <= fabs(b))
+ t = - a / b, (*s) = 1.0 / sqrt(1.0 + t * t), (*c) = (*s) * t;
+ else
+ t = - b / a, (*c) = 1.0 / sqrt(1.0 + t * t), (*s) = (*c) * t;
+ return;
+}
+
+/***********************************************************************
+* ifu_gr_update - update IFU-factorization (Givens rotations)
+*
+* This routine updates IFU-factorization of the matrix A according to
+* its expansion (see comments to the routine ifu_expand). The routine
+* is based on Givens plane rotations [1].
+*
+* RETURNS
+*
+* 0 The factorization has been successfully updated.
+*
+* 1 On some elimination step both elements u[k,k] and u[n,k] are too
+* small in magnitude.
+*
+* 2 Diagonal element u[n,n] is too small in magnitude (at the end of
+* update).
+*
+* REFERENCES
+*
+* 1. G.H.Golub, C.F.Van Loan, "Matrix Computations", 2nd ed. */
+
+int ifu_gr_update(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d)
+{ /* non-optimized version */
+ int n_max = ifu->n_max;
+ int n = ifu->n;
+ double *f_ = ifu->f;
+ double *u_ = ifu->u;
+#if 1 /* FIXME */
+ double tol = 1e-5;
+#endif
+ int j, k;
+ double cs, sn;
+# define f(i,j) f_[(i)*n_max+(j)]
+# define u(i,j) u_[(i)*n_max+(j)]
+ /* expand factorization */
+ ifu_expand(ifu, c, r, d);
+ /* NOTE: n keeps its old value */
+ /* eliminate spike (non-zero subdiagonal elements) in last row of
+ * matrix U */
+ for (k = 0; k < n; k++)
+ { /* check if elements u[k,k] and u[n,k] are eligible */
+ if (fabs(u(k,k)) < tol && fabs(u(n,k)) < tol)
+ { /* both u[k,k] and u[n,k] are too small in magnitude */
+ return 1;
+ }
+ /* if u[n,k] = 0, elimination is not needed */
+ if (u(n,k) == 0.0)
+ continue;
+ /* compute parameters of Givens plane rotation */
+ givens(u(k,k), u(n,k), &cs, &sn);
+ /* apply Givens rotation to k-th and n-th rows of matrix U to
+ * eliminate u[n,k] */
+ for (j = k; j <= n; j++)
+ { double ukj = u(k,j), unj = u(n,j);
+ u(k,j) = cs * ukj - sn * unj;
+ u(n,j) = sn * ukj + cs * unj;
+ }
+ /* apply the same transformation to matrix F to keep the main
+ * equality F * A = U */
+ for (j = 0; j <= n; j++)
+ { double fkj = f(k,j), fnj = f(n,j);
+ f(k,j) = cs * fkj - sn * fnj;
+ f(n,j) = sn * fkj + cs * fnj;
+ }
+ }
+ /* now matrix U is upper triangular */
+ if (fabs(u(n,n)) < tol)
+ { /* u[n,n] is too small in magnitude */
+ return 2;
+ }
+# undef f
+# undef u
+ return 0;
+}
+
+/***********************************************************************
+* ifu_a_solve - solve system A * x = b
+*
+* This routine solves the system A * x = b, where the matrix A is
+* specified by its IFU-factorization.
+*
+* Using the main equality F * A = U we have:
+*
+* A * x = b => F * A * x = F * b => U * x = F * b =>
+*
+* x = inv(U) * F * b.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix A. On exit this array will contain elements of the solution
+* vector x in the same locations.
+*
+* The working array w should have at least 1+n elements (0-th element
+* is not used). */
+
+void ifu_a_solve(IFU *ifu, double x[/*1+n*/], double w[/*1+n*/])
+{ /* non-optimized version */
+ int n_max = ifu->n_max;
+ int n = ifu->n;
+ double *f_ = ifu->f;
+ double *u_ = ifu->u;
+ int i, j;
+ double t;
+# define f(i,j) f_[(i)*n_max+(j)]
+# define u(i,j) u_[(i)*n_max+(j)]
+ xassert(0 <= n && n <= n_max);
+ /* adjust indexing */
+ x++, w++;
+ /* y := F * b */
+ memcpy(w, x, n * sizeof(double));
+ for (i = 0; i < n; i++)
+ { /* y[i] := (i-th row of F) * b */
+ t = 0.0;
+ for (j = 0; j < n; j++)
+ t += f(i,j) * w[j];
+ x[i] = t;
+ }
+ /* x := inv(U) * y */
+ for (i = n-1; i >= 0; i--)
+ { t = x[i];
+ for (j = i+1; j < n; j++)
+ t -= u(i,j) * x[j];
+ x[i] = t / u(i,i);
+ }
+# undef f
+# undef u
+ return;
+}
+
+/***********************************************************************
+* ifu_at_solve - solve system A'* x = b
+*
+* This routine solves the system A'* x = b, where A' is a matrix
+* transposed to the matrix A, specified by its IFU-factorization.
+*
+* Using the main equality F * A = U, from which it follows that
+* A'* F' = U', we have:
+*
+* A'* x = b => A'* F'* inv(F') * x = b =>
+*
+* U'* inv(F') * x = b => inv(F') * x = inv(U') * b =>
+*
+* x = F' * inv(U') * b.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix A. On exit this array will contain elements of the solution
+* vector x in the same locations.
+*
+* The working array w should have at least 1+n elements (0-th element
+* is not used). */
+
+void ifu_at_solve(IFU *ifu, double x[/*1+n*/], double w[/*1+n*/])
+{ /* non-optimized version */
+ int n_max = ifu->n_max;
+ int n = ifu->n;
+ double *f_ = ifu->f;
+ double *u_ = ifu->u;
+ int i, j;
+ double t;
+# define f(i,j) f_[(i)*n_max+(j)]
+# define u(i,j) u_[(i)*n_max+(j)]
+ xassert(0 <= n && n <= n_max);
+ /* adjust indexing */
+ x++, w++;
+ /* y := inv(U') * b */
+ for (i = 0; i < n; i++)
+ { t = (x[i] /= u(i,i));
+ for (j = i+1; j < n; j++)
+ x[j] -= u(i,j) * t;
+ }
+ /* x := F'* y */
+ for (j = 0; j < n; j++)
+ { /* x[j] := (j-th column of F) * y */
+ t = 0.0;
+ for (i = 0; i < n; i++)
+ t += f(i,j) * x[i];
+ w[j] = t;
+ }
+ memcpy(x, w, n * sizeof(double));
+# undef f
+# undef u
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/ifu.h b/test/monniaux/glpk-4.65/src/bflib/ifu.h
new file mode 100644
index 00000000..1c67a801
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/ifu.h
@@ -0,0 +1,99 @@
+/* ifu.h (dense updatable IFU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef IFU_H
+#define IFU_H
+
+/***********************************************************************
+* The structure IFU describes dense updatable IFU-factorization.
+*
+* The IFU-factorization has the following format:
+*
+* A = inv(F) * U, (1)
+*
+* where A is a given (unsymmetric) nxn square matrix, F is a square
+* matrix, U is an upper triangular matrix. Obviously, the equality (1)
+* is equivalent to the following equality:
+*
+* F * A = U. (2)
+*
+* It is assumed that matrix A is small and dense, so matrices F and U
+* are stored by rows in dense format as follows:
+*
+* 1 n n_max 1 n n_max
+* 1 * * * * * * x x x x 1 * * * * * * x x x x
+* * * * * * * x x x x ? * * * * * x x x x
+* * * * * * * x x x x ? ? * * * * x x x x
+* * * * * * * x x x x ? ? ? * * * x x x x
+* * * * * * * x x x x ? ? ? ? * * x x x x
+* n * * * * * * x x x x n ? ? ? ? ? * x x x x
+* x x x x x x x x x x x x x x x x x x x x
+* x x x x x x x x x x x x x x x x x x x x
+* x x x x x x x x x x x x x x x x x x x x
+* n_max x x x x x x x x x x n_max x x x x x x x x x x
+*
+* matrix F matrix U
+*
+* where '*' are matrix elements, '?' are unused locations, 'x' are
+* reserved locations. */
+
+typedef struct IFU IFU;
+
+struct IFU
+{ /* IFU-factorization */
+ int n_max;
+ /* maximal order of matrices A, F, U; n_max >= 1 */
+ int n;
+ /* current order of matrices A, F, U; 0 <= n <= n_max */
+ double *f; /* double f[n_max*n_max]; */
+ /* matrix F stored by rows */
+ double *u; /* double u[n_max*n_max]; */
+ /* matrix U stored by rows */
+};
+
+#define ifu_expand _glp_ifu_expand
+void ifu_expand(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d);
+/* expand IFU-factorization */
+
+#define ifu_bg_update _glp_ifu_bg_update
+int ifu_bg_update(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d);
+/* update IFU-factorization (Bartels-Golub) */
+
+#define ifu_gr_update _glp_ifu_gr_update
+int ifu_gr_update(IFU *ifu, double c[/*1+n*/], double r[/*1+n*/],
+ double d);
+/* update IFU-factorization (Givens rotations) */
+
+#define ifu_a_solve _glp_ifu_a_solve
+void ifu_a_solve(IFU *ifu, double x[/*1+n*/], double w[/*1+n*/]);
+/* solve system A * x = b */
+
+#define ifu_at_solve _glp_ifu_at_solve
+void ifu_at_solve(IFU *ifu, double x[/*1+n*/], double w[/*1+n*/]);
+/* solve system A'* x = b */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/luf.c b/test/monniaux/glpk-4.65/src/bflib/luf.c
new file mode 100644
index 00000000..2797407d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/luf.c
@@ -0,0 +1,713 @@
+/* luf.c (sparse LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "luf.h"
+
+/***********************************************************************
+* luf_store_v_cols - store matrix V = A in column-wise format
+*
+* This routine stores matrix V = A in column-wise format, where A is
+* the original matrix to be factorized.
+*
+* On exit the routine returns the number of non-zeros in matrix V. */
+
+int luf_store_v_cols(LUF *luf, int (*col)(void *info, int j, int ind[],
+ double val[]), void *info, int ind[], double val[])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *vc_cap = &sva->cap[vc_ref-1];
+ int j, len, ptr, nnz;
+ nnz = 0;
+ for (j = 1; j <= n; j++)
+ { /* get j-th column */
+ len = col(info, j, ind, val);
+ xassert(0 <= len && len <= n);
+ /* enlarge j-th column capacity */
+ if (vc_cap[j] < len)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vc_ref-1+j, len, 0);
+ }
+ /* store j-th column */
+ ptr = vc_ptr[j];
+ memcpy(&sv_ind[ptr], &ind[1], len * sizeof(int));
+ memcpy(&sv_val[ptr], &val[1], len * sizeof(double));
+ vc_len[j] = len;
+ nnz += len;
+ }
+ return nnz;
+}
+
+/***********************************************************************
+* luf_check_all - check LU-factorization before k-th elimination step
+*
+* This routine checks that before performing k-th elimination step,
+* 1 <= k <= n+1, all components of the LU-factorization are correct.
+*
+* In case of k = n+1, i.e. after last elimination step, it is assumed
+* that rows of F and columns of V are *not* built yet.
+*
+* NOTE: For testing/debugging only. */
+
+void luf_check_all(LUF *luf, int k)
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fr_ref = luf->fr_ref;
+ int *fr_len = &sva->len[fr_ref-1];
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int i, ii, i_ptr, i_end, j, jj, j_ptr, j_end;
+ xassert(n > 0);
+ xassert(1 <= k && k <= n+1);
+ /* check permutation matrix P */
+ for (i = 1; i <= n; i++)
+ { ii = pp_ind[i];
+ xassert(1 <= ii && ii <= n);
+ xassert(pp_inv[ii] == i);
+ }
+ /* check permutation matrix Q */
+ for (j = 1; j <= n; j++)
+ { jj = qq_inv[j];
+ xassert(1 <= jj && jj <= n);
+ xassert(qq_ind[jj] == j);
+ }
+ /* check row-wise representation of matrix F */
+ for (i = 1; i <= n; i++)
+ xassert(fr_len[i] == 0);
+ /* check column-wise representation of matrix F */
+ for (j = 1; j <= n; j++)
+ { /* j-th column of F = jj-th column of L */
+ jj = pp_ind[j];
+ if (jj < k)
+ { j_ptr = fc_ptr[j];
+ j_end = j_ptr + fc_len[j];
+ for (; j_ptr < j_end; j_ptr++)
+ { i = sv_ind[j_ptr];
+ xassert(1 <= i && i <= n);
+ ii = pp_ind[i]; /* f[i,j] = l[ii,jj] */
+ xassert(ii > jj);
+ xassert(sv_val[j_ptr] != 0.0);
+ }
+ }
+ else /* jj >= k */
+ xassert(fc_len[j] == 0);
+ }
+ /* check row-wise representation of matrix V */
+ for (i = 1; i <= n; i++)
+ { /* i-th row of V = ii-th row of U */
+ ii = pp_ind[i];
+ i_ptr = vr_ptr[i];
+ i_end = i_ptr + vr_len[i];
+ for (; i_ptr < i_end; i_ptr++)
+ { j = sv_ind[i_ptr];
+ xassert(1 <= j && j <= n);
+ jj = qq_inv[j]; /* v[i,j] = u[ii,jj] */
+ if (ii < k)
+ xassert(jj > ii);
+ else /* ii >= k */
+ { xassert(jj >= k);
+ /* find v[i,j] in j-th column */
+ j_ptr = vc_ptr[j];
+ j_end = j_ptr + vc_len[j];
+ for (; sv_ind[j_ptr] != i; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ }
+ xassert(sv_val[i_ptr] != 0.0);
+ }
+ }
+ /* check column-wise representation of matrix V */
+ for (j = 1; j <= n; j++)
+ { /* j-th column of V = jj-th column of U */
+ jj = qq_inv[j];
+ if (jj < k)
+ xassert(vc_len[j] == 0);
+ else /* jj >= k */
+ { j_ptr = vc_ptr[j];
+ j_end = j_ptr + vc_len[j];
+ for (; j_ptr < j_end; j_ptr++)
+ { i = sv_ind[j_ptr];
+ ii = pp_ind[i]; /* v[i,j] = u[ii,jj] */
+ xassert(ii >= k);
+ /* find v[i,j] in i-th row */
+ i_ptr = vr_ptr[i];
+ i_end = i_ptr + vr_len[i];
+ for (; sv_ind[i_ptr] != j; i_ptr++)
+ /* nop */;
+ xassert(i_ptr < i_end);
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_build_v_rows - build matrix V in row-wise format
+*
+* This routine builds the row-wise representation of matrix V in the
+* left part of SVA using its column-wise representation.
+*
+* NOTE: On entry to the routine all rows of matrix V should have zero
+* capacity.
+*
+* The working array len should have at least 1+n elements (len[0] is
+* not used). */
+
+void luf_build_v_rows(LUF *luf, int len[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int i, j, end, nnz, ptr, ptr1;
+ /* calculate the number of non-zeros in each row of matrix V and
+ * the total number of non-zeros */
+ nnz = 0;
+ for (i = 1; i <= n; i++)
+ len[i] = 0;
+ for (j = 1; j <= n; j++)
+ { nnz += vc_len[j];
+ for (end = (ptr = vc_ptr[j]) + vc_len[j]; ptr < end; ptr++)
+ len[sv_ind[ptr]]++;
+ }
+ /* we need at least nnz free locations in SVA */
+ if (sva->r_ptr - sva->m_ptr < nnz)
+ { sva_more_space(sva, nnz);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ /* reserve locations for rows of matrix V */
+ for (i = 1; i <= n; i++)
+ { if (len[i] > 0)
+ sva_enlarge_cap(sva, vr_ref-1+i, len[i], 0);
+ vr_len[i] = len[i];
+ }
+ /* walk thru column of matrix V and build its rows */
+ for (j = 1; j <= n; j++)
+ { for (end = (ptr = vc_ptr[j]) + vc_len[j]; ptr < end; ptr++)
+ { i = sv_ind[ptr];
+ sv_ind[ptr1 = vr_ptr[i] + (--len[i])] = j;
+ sv_val[ptr1] = sv_val[ptr];
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_build_f_rows - build matrix F in row-wise format
+*
+* This routine builds the row-wise representation of matrix F in the
+* right part of SVA using its column-wise representation.
+*
+* NOTE: On entry to the routine all rows of matrix F should have zero
+* capacity.
+*
+* The working array len should have at least 1+n elements (len[0] is
+* not used). */
+
+void luf_build_f_rows(LUF *luf, int len[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fr_ref = luf->fr_ref;
+ int *fr_ptr = &sva->ptr[fr_ref-1];
+ int *fr_len = &sva->len[fr_ref-1];
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int i, j, end, nnz, ptr, ptr1;
+ /* calculate the number of non-zeros in each row of matrix F and
+ * the total number of non-zeros (except diagonal elements) */
+ nnz = 0;
+ for (i = 1; i <= n; i++)
+ len[i] = 0;
+ for (j = 1; j <= n; j++)
+ { nnz += fc_len[j];
+ for (end = (ptr = fc_ptr[j]) + fc_len[j]; ptr < end; ptr++)
+ len[sv_ind[ptr]]++;
+ }
+ /* we need at least nnz free locations in SVA */
+ if (sva->r_ptr - sva->m_ptr < nnz)
+ { sva_more_space(sva, nnz);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ /* reserve locations for rows of matrix F */
+ for (i = 1; i <= n; i++)
+ { if (len[i] > 0)
+ sva_reserve_cap(sva, fr_ref-1+i, len[i]);
+ fr_len[i] = len[i];
+ }
+ /* walk through columns of matrix F and build its rows */
+ for (j = 1; j <= n; j++)
+ { for (end = (ptr = fc_ptr[j]) + fc_len[j]; ptr < end; ptr++)
+ { i = sv_ind[ptr];
+ sv_ind[ptr1 = fr_ptr[i] + (--len[i])] = j;
+ sv_val[ptr1] = sv_val[ptr];
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_build_v_cols - build matrix V in column-wise format
+*
+* This routine builds the column-wise representation of matrix V in
+* the left (if the flag updat is set) or right (if the flag updat is
+* clear) part of SVA using its row-wise representation.
+*
+* NOTE: On entry to the routine all columns of matrix V should have
+* zero capacity.
+*
+* The working array len should have at least 1+n elements (len[0] is
+* not used). */
+
+void luf_build_v_cols(LUF *luf, int updat, int len[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int i, j, end, nnz, ptr, ptr1;
+ /* calculate the number of non-zeros in each column of matrix V
+ * and the total number of non-zeros (except pivot elements) */
+ nnz = 0;
+ for (j = 1; j <= n; j++)
+ len[j] = 0;
+ for (i = 1; i <= n; i++)
+ { nnz += vr_len[i];
+ for (end = (ptr = vr_ptr[i]) + vr_len[i]; ptr < end; ptr++)
+ len[sv_ind[ptr]]++;
+ }
+ /* we need at least nnz free locations in SVA */
+ if (sva->r_ptr - sva->m_ptr < nnz)
+ { sva_more_space(sva, nnz);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ /* reserve locations for columns of matrix V */
+ for (j = 1; j <= n; j++)
+ { if (len[j] > 0)
+ { if (updat)
+ sva_enlarge_cap(sva, vc_ref-1+j, len[j], 0);
+ else
+ sva_reserve_cap(sva, vc_ref-1+j, len[j]);
+ }
+ vc_len[j] = len[j];
+ }
+ /* walk through rows of matrix V and build its columns */
+ for (i = 1; i <= n; i++)
+ { for (end = (ptr = vr_ptr[i]) + vr_len[i]; ptr < end; ptr++)
+ { j = sv_ind[ptr];
+ sv_ind[ptr1 = vc_ptr[j] + (--len[j])] = i;
+ sv_val[ptr1] = sv_val[ptr];
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_check_f_rc - check rows and columns of matrix F
+*
+* This routine checks that the row- and column-wise representations
+* of matrix F are identical.
+*
+* NOTE: For testing/debugging only. */
+
+void luf_check_f_rc(LUF *luf)
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fr_ref = luf->fr_ref;
+ int *fr_ptr = &sva->ptr[fr_ref-1];
+ int *fr_len = &sva->len[fr_ref-1];
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int i, i_end, i_ptr, j, j_end, j_ptr;
+ /* walk thru rows of matrix F */
+ for (i = 1; i <= n; i++)
+ { for (i_end = (i_ptr = fr_ptr[i]) + fr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { j = sv_ind[i_ptr];
+ /* find element f[i,j] in j-th column of matrix F */
+ for (j_end = (j_ptr = fc_ptr[j]) + fc_len[j];
+ sv_ind[j_ptr] != i; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ xassert(sv_val[i_ptr] == sv_val[j_ptr]);
+ /* mark element f[i,j] */
+ sv_ind[j_ptr] = -i;
+ }
+ }
+ /* walk thru column of matix F and check that all elements has
+ been marked */
+ for (j = 1; j <= n; j++)
+ { for (j_end = (j_ptr = fc_ptr[j]) + fc_len[j];
+ j_ptr < j_end; j_ptr++)
+ { xassert((i = sv_ind[j_ptr]) < 0);
+ /* unmark element f[i,j] */
+ sv_ind[j_ptr] = -i;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_check_v_rc - check rows and columns of matrix V
+*
+* This routine checks that the row- and column-wise representations
+* of matrix V are identical.
+*
+* NOTE: For testing/debugging only. */
+
+void luf_check_v_rc(LUF *luf)
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int i, i_end, i_ptr, j, j_end, j_ptr;
+ /* walk thru rows of matrix V */
+ for (i = 1; i <= n; i++)
+ { for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { j = sv_ind[i_ptr];
+ /* find element v[i,j] in j-th column of matrix V */
+ for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ sv_ind[j_ptr] != i; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ xassert(sv_val[i_ptr] == sv_val[j_ptr]);
+ /* mark element v[i,j] */
+ sv_ind[j_ptr] = -i;
+ }
+ }
+ /* walk thru column of matix V and check that all elements has
+ been marked */
+ for (j = 1; j <= n; j++)
+ { for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ j_ptr < j_end; j_ptr++)
+ { xassert((i = sv_ind[j_ptr]) < 0);
+ /* unmark element v[i,j] */
+ sv_ind[j_ptr] = -i;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_f_solve - solve system F * x = b
+*
+* This routine solves the system F * x = b, where the matrix F is the
+* left factor of the sparse LU-factorization.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix F. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void luf_f_solve(LUF *luf, double x[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int j, k, ptr, end;
+ double x_j;
+ for (k = 1; k <= n; k++)
+ { /* k-th column of L = j-th column of F */
+ j = pp_inv[k];
+ /* x[j] is already computed */
+ /* walk thru j-th column of matrix F and substitute x[j] into
+ * other equations */
+ if ((x_j = x[j]) != 0.0)
+ { for (end = (ptr = fc_ptr[j]) + fc_len[j]; ptr < end; ptr++)
+ x[sv_ind[ptr]] -= sv_val[ptr] * x_j;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_ft_solve - solve system F' * x = b
+*
+* This routine solves the system F' * x = b, where F' is a matrix
+* transposed to the matrix F, which is the left factor of the sparse
+* LU-factorization.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix F. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void luf_ft_solve(LUF *luf, double x[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fr_ref = luf->fr_ref;
+ int *fr_ptr = &sva->ptr[fr_ref-1];
+ int *fr_len = &sva->len[fr_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int i, k, ptr, end;
+ double x_i;
+ for (k = n; k >= 1; k--)
+ { /* k-th column of L' = i-th row of F */
+ i = pp_inv[k];
+ /* x[i] is already computed */
+ /* walk thru i-th row of matrix F and substitute x[i] into
+ * other equations */
+ if ((x_i = x[i]) != 0.0)
+ { for (end = (ptr = fr_ptr[i]) + fr_len[i]; ptr < end; ptr++)
+ x[sv_ind[ptr]] -= sv_val[ptr] * x_i;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_v_solve - solve system V * x = b
+*
+* This routine solves the system V * x = b, where the matrix V is the
+* right factor of the sparse LU-factorization.
+*
+* On entry the array b should contain elements of the right-hand side
+* vector b in locations b[1], ..., b[n], where n is the order of the
+* matrix V. On exit the array x will contain elements of the solution
+* vector x in locations x[1], ..., x[n]. Note that the array b will be
+* clobbered on exit. */
+
+void luf_v_solve(LUF *luf, double b[/*1+n*/], double x[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int i, j, k, ptr, end;
+ double x_j;
+ for (k = n; k >= 1; k--)
+ { /* k-th row of U = i-th row of V */
+ /* k-th column of U = j-th column of V */
+ i = pp_inv[k];
+ j = qq_ind[k];
+ /* compute x[j] = b[i] / u[k,k], where u[k,k] = v[i,j];
+ * walk through j-th column of matrix V and substitute x[j]
+ * into other equations */
+ if ((x_j = x[j] = b[i] / vr_piv[i]) != 0.0)
+ { for (end = (ptr = vc_ptr[j]) + vc_len[j]; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * x_j;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_vt_solve - solve system V' * x = b
+*
+* This routine solves the system V' * x = b, where V' is a matrix
+* transposed to the matrix V, which is the right factor of the sparse
+* LU-factorization.
+*
+* On entry the array b should contain elements of the right-hand side
+* vector b in locations b[1], ..., b[n], where n is the order of the
+* matrix V. On exit the array x will contain elements of the solution
+* vector x in locations x[1], ..., x[n]. Note that the array b will be
+* clobbered on exit. */
+
+void luf_vt_solve(LUF *luf, double b[/*1+n*/], double x[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ double *vr_piv = luf->vr_piv;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int i, j, k, ptr, end;
+ double x_i;
+ for (k = 1; k <= n; k++)
+ { /* k-th row of U' = j-th column of V */
+ /* k-th column of U' = i-th row of V */
+ i = pp_inv[k];
+ j = qq_ind[k];
+ /* compute x[i] = b[j] / u'[k,k], where u'[k,k] = v[i,j];
+ * walk through i-th row of matrix V and substitute x[i] into
+ * other equations */
+ if ((x_i = x[i] = b[j] / vr_piv[i]) != 0.0)
+ { for (end = (ptr = vr_ptr[i]) + vr_len[i]; ptr < end; ptr++)
+ b[sv_ind[ptr]] -= sv_val[ptr] * x_i;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_vt_solve1 - solve system V' * y = e' to cause growth in y
+*
+* This routine is a special version of luf_vt_solve. It solves the
+* system V'* y = e' = e + delta e, where V' is a matrix transposed to
+* the matrix V, e is the specified right-hand side vector, and delta e
+* is a vector of +1 and -1 chosen to cause growth in the solution
+* vector y.
+*
+* On entry the array e should contain elements of the right-hand side
+* vector e in locations e[1], ..., e[n], where n is the order of the
+* matrix V. On exit the array y will contain elements of the solution
+* vector y in locations y[1], ..., y[n]. Note that the array e will be
+* clobbered on exit. */
+
+void luf_vt_solve1(LUF *luf, double e[/*1+n*/], double y[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ double *vr_piv = luf->vr_piv;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int i, j, k, ptr, end;
+ double e_j, y_i;
+ for (k = 1; k <= n; k++)
+ { /* k-th row of U' = j-th column of V */
+ /* k-th column of U' = i-th row of V */
+ i = pp_inv[k];
+ j = qq_ind[k];
+ /* determine e'[j] = e[j] + delta e[j] */
+ e_j = (e[j] >= 0.0 ? e[j] + 1.0 : e[j] - 1.0);
+ /* compute y[i] = e'[j] / u'[k,k], where u'[k,k] = v[i,j] */
+ y_i = y[i] = e_j / vr_piv[i];
+ /* walk through i-th row of matrix V and substitute y[i] into
+ * other equations */
+ for (end = (ptr = vr_ptr[i]) + vr_len[i]; ptr < end; ptr++)
+ e[sv_ind[ptr]] -= sv_val[ptr] * y_i;
+ }
+ return;
+}
+
+/***********************************************************************
+* luf_estimate_norm - estimate 1-norm of inv(A)
+*
+* This routine estimates 1-norm of inv(A) by one step of inverse
+* iteration for the small singular vector as described in [1]. This
+* involves solving two systems of equations:
+*
+* A'* y = e,
+*
+* A * z = y,
+*
+* where A' is a matrix transposed to A, and e is a vector of +1 and -1
+* chosen to cause growth in y. Then
+*
+* estimate 1-norm of inv(A) = (1-norm of z) / (1-norm of y)
+*
+* REFERENCES
+*
+* 1. G.E.Forsythe, M.A.Malcolm, C.B.Moler. Computer Methods for
+* Mathematical Computations. Prentice-Hall, Englewood Cliffs, N.J.,
+* pp. 30-62 (subroutines DECOMP and SOLVE). */
+
+double luf_estimate_norm(LUF *luf, double w1[/*1+n*/], double
+ w2[/*1+n*/])
+{ int n = luf->n;
+ double *e = w1;
+ double *y = w2;
+ double *z = w1;
+ int i;
+ double y_norm, z_norm;
+ /* y = inv(A') * e = inv(F') * inv(V') * e */
+ /* compute y' = inv(V') * e to cause growth in y' */
+ for (i = 1; i <= n; i++)
+ e[i] = 0.0;
+ luf_vt_solve1(luf, e, y);
+ /* compute y = inv(F') * y' */
+ luf_ft_solve(luf, y);
+ /* compute 1-norm of y = sum |y[i]| */
+ y_norm = 0.0;
+ for (i = 1; i <= n; i++)
+ y_norm += (y[i] >= 0.0 ? +y[i] : -y[i]);
+ /* z = inv(A) * y = inv(V) * inv(F) * y */
+ /* compute z' = inv(F) * y */
+ luf_f_solve(luf, y);
+ /* compute z = inv(V) * z' */
+ luf_v_solve(luf, y, z);
+ /* compute 1-norm of z = sum |z[i]| */
+ z_norm = 0.0;
+ for (i = 1; i <= n; i++)
+ z_norm += (z[i] >= 0.0 ? +z[i] : -z[i]);
+ /* estimate 1-norm of inv(A) = (1-norm of z) / (1-norm of y) */
+ return z_norm / y_norm;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/luf.h b/test/monniaux/glpk-4.65/src/bflib/luf.h
new file mode 100644
index 00000000..5634a753
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/luf.h
@@ -0,0 +1,227 @@
+/* luf.h (sparse LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef LUF_H
+#define LUF_H
+
+#include "sva.h"
+
+/***********************************************************************
+* The structure LUF describes sparse LU-factorization.
+*
+* The LU-factorization has the following format:
+*
+* A = F * V = P * L * U * Q, (1)
+*
+* F = P * L * P', (2)
+*
+* V = P * U * Q, (3)
+*
+* where A is a given (unsymmetric) square matrix, F and V are matrix
+* factors actually computed, L is a lower triangular matrix with unity
+* diagonal, U is an upper triangular matrix, P and Q are permutation
+* matrices, P' is a matrix transposed to P. All the matrices have the
+* same order n.
+*
+* Matrices F and V are stored in both row- and column-wise sparse
+* formats in the associated sparse vector area (SVA). Unity diagonal
+* elements of matrix F are not stored. Pivot elements of matrix V
+* (which correspond to diagonal elements of matrix U) are stored in
+* a separate ordinary array.
+*
+* Permutation matrices P and Q are stored in ordinary arrays in both
+* row- and column-like formats.
+*
+* Matrices L and U are completely defined by matrices F, V, P, and Q,
+* and therefore not stored explicitly. */
+
+typedef struct LUF LUF;
+
+struct LUF
+{ /* sparse LU-factorization */
+ int n;
+ /* order of matrices A, F, V, P, Q */
+ SVA *sva;
+ /* associated sparse vector area (SVA) used to store rows and
+ * columns of matrices F and V; note that different objects may
+ * share the same SVA */
+ /*--------------------------------------------------------------*/
+ /* matrix F in row-wise format */
+ /* during the factorization process this object is not used */
+ int fr_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * row of matrix F */
+#if 0 + 0
+ int *fr_ptr = &sva->ptr[fr_ref-1];
+ /* fr_ptr[0] is not used;
+ * fr_ptr[i], 1 <= i <= n, is pointer to i-th row in SVA */
+ int *fr_len = &sva->len[fr_ref-1];
+ /* fr_len[0] is not used;
+ * fr_len[i], 1 <= i <= n, is length of i-th row */
+#endif
+ /*--------------------------------------------------------------*/
+ /* matrix F in column-wise format */
+ /* during the factorization process this object is constructed
+ * by columns */
+ int fc_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * column of matrix F */
+#if 0 + 0
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ /* fc_ptr[0] is not used;
+ * fc_ptr[j], 1 <= j <= n, is pointer to j-th column in SVA */
+ int *fc_len = &sva->len[fc_ref-1];
+ /* fc_len[0] is not used;
+ * fc_len[j], 1 <= j <= n, is length of j-th column */
+#endif
+ /*--------------------------------------------------------------*/
+ /* matrix V in row-wise format */
+ int vr_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * row of matrix V */
+#if 0 + 0
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ /* vr_ptr[0] is not used;
+ * vr_ptr[i], 1 <= i <= n, is pointer to i-th row in SVA */
+ int *vr_len = &sva->len[vr_ref-1];
+ /* vr_len[0] is not used;
+ * vr_len[i], 1 <= i <= n, is length of i-th row */
+ int *vr_cap = &sva->cap[vr_ref-1];
+ /* vr_cap[0] is not used;
+ * vr_cap[i], 1 <= i <= n, is capacity of i-th row */
+#endif
+ double *vr_piv; /* double vr_piv[1+n]; */
+ /* vr_piv[0] is not used;
+ * vr_piv[i], 1 <= i <= n, is pivot element of i-th row */
+ /*--------------------------------------------------------------*/
+ /* matrix V in column-wise format */
+ /* during the factorization process this object contains only the
+ * patterns (row indices) of columns of the active submatrix */
+ int vc_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * column of matrix V */
+#if 0 + 0
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ /* vc_ptr[0] is not used;
+ * vc_ptr[j], 1 <= j <= n, is pointer to j-th column in SVA */
+ int *vc_len = &sva->len[vc_ref-1];
+ /* vc_len[0] is not used;
+ * vc_len[j], 1 <= j <= n, is length of j-th column */
+ int *vc_cap = &sva->cap[vc_ref-1];
+ /* vc_cap[0] is not used;
+ * vc_cap[j], 1 <= j <= n, is capacity of j-th column */
+#endif
+ /*--------------------------------------------------------------*/
+ /* matrix P */
+ int *pp_ind; /* int pp_ind[1+n]; */
+ /* pp_ind[i] = j means that P[i,j] = 1 */
+ int *pp_inv; /* int pp_inv[1+n]; */
+ /* pp_inv[j] = i means that P[i,j] = 1 */
+ /* if i-th row or column of matrix F is i'-th row or column of
+ * matrix L, or if i-th row of matrix V is i'-th row of matrix U,
+ * then pp_ind[i] = i' and pp_inv[i'] = i */
+ /*--------------------------------------------------------------*/
+ /* matrix Q */
+ int *qq_ind; /* int qq_ind[1+n]; */
+ /* qq_ind[i] = j means that Q[i,j] = 1 */
+ int *qq_inv; /* int qq_inv[1+n]; */
+ /* qq_inv[j] = i means that Q[i,j] = 1 */
+ /* if j-th column of matrix V is j'-th column of matrix U, then
+ * qq_ind[j'] = j and qq_inv[j] = j' */
+};
+
+#define luf_swap_u_rows(i1, i2) \
+ do \
+ { int j1, j2; \
+ j1 = pp_inv[i1], j2 = pp_inv[i2]; \
+ pp_ind[j1] = i2, pp_inv[i2] = j1; \
+ pp_ind[j2] = i1, pp_inv[i1] = j2; \
+ } while (0)
+/* swap rows i1 and i2 of matrix U = P'* V * Q' */
+
+#define luf_swap_u_cols(j1, j2) \
+ do \
+ { int i1, i2; \
+ i1 = qq_ind[j1], i2 = qq_ind[j2]; \
+ qq_ind[j1] = i2, qq_inv[i2] = j1; \
+ qq_ind[j2] = i1, qq_inv[i1] = j2; \
+ } while (0)
+/* swap columns j1 and j2 of matrix U = P'* V * Q' */
+
+#define luf_store_v_cols _glp_luf_store_v_cols
+int luf_store_v_cols(LUF *luf, int (*col)(void *info, int j, int ind[],
+ double val[]), void *info, int ind[], double val[]);
+/* store matrix V = A in column-wise format */
+
+#define luf_check_all _glp_luf_check_all
+void luf_check_all(LUF *luf, int k);
+/* check LU-factorization before k-th elimination step */
+
+#define luf_build_v_rows _glp_luf_build_v_rows
+void luf_build_v_rows(LUF *luf, int len[/*1+n*/]);
+/* build matrix V in row-wise format */
+
+#define luf_build_f_rows _glp_luf_build_f_rows
+void luf_build_f_rows(LUF *luf, int len[/*1+n*/]);
+/* build matrix F in row-wise format */
+
+#define luf_build_v_cols _glp_luf_build_v_cols
+void luf_build_v_cols(LUF *luf, int updat, int len[/*1+n*/]);
+/* build matrix V in column-wise format */
+
+#define luf_check_f_rc _glp_luf_check_f_rc
+void luf_check_f_rc(LUF *luf);
+/* check rows and columns of matrix F */
+
+#define luf_check_v_rc _glp_luf_check_v_rc
+void luf_check_v_rc(LUF *luf);
+/* check rows and columns of matrix V */
+
+#define luf_f_solve _glp_luf_f_solve
+void luf_f_solve(LUF *luf, double x[/*1+n*/]);
+/* solve system F * x = b */
+
+#define luf_ft_solve _glp_luf_ft_solve
+void luf_ft_solve(LUF *luf, double x[/*1+n*/]);
+/* solve system F' * x = b */
+
+#define luf_v_solve _glp_luf_v_solve
+void luf_v_solve(LUF *luf, double b[/*1+n*/], double x[/*1+n*/]);
+/* solve system V * x = b */
+
+#define luf_vt_solve _glp_luf_vt_solve
+void luf_vt_solve(LUF *luf, double b[/*1+n*/], double x[/*1+n*/]);
+/* solve system V' * x = b */
+
+#define luf_vt_solve1 _glp_luf_vt_solve1
+void luf_vt_solve1(LUF *luf, double e[/*1+n*/], double y[/*1+n*/]);
+/* solve system V' * y = e' to cause growth in y */
+
+#define luf_estimate_norm _glp_luf_estimate_norm
+double luf_estimate_norm(LUF *luf, double w1[/*1+n*/], double
+ w2[/*1+n*/]);
+/* estimate 1-norm of inv(A) */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/lufint.c b/test/monniaux/glpk-4.65/src/bflib/lufint.c
new file mode 100644
index 00000000..7cd00924
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/lufint.c
@@ -0,0 +1,182 @@
+/* lufint.c (interface to LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "lufint.h"
+
+LUFINT *lufint_create(void)
+{ /* create interface to LU-factorization */
+ LUFINT *fi;
+ fi = talloc(1, LUFINT);
+ fi->n_max = 0;
+ fi->valid = 0;
+ fi->sva = NULL;
+ fi->luf = NULL;
+ fi->sgf = NULL;
+ fi->sva_n_max = fi->sva_size = 0;
+ fi->delta_n0 = fi->delta_n = 0;
+ fi->sgf_updat = 0;
+ fi->sgf_piv_tol = 0.10;
+ fi->sgf_piv_lim = 4;
+ fi->sgf_suhl = 1;
+ fi->sgf_eps_tol = DBL_EPSILON;
+ return fi;
+}
+
+int lufint_factorize(LUFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info)
+{ /* compute LU-factorization of specified matrix A */
+ SVA *sva;
+ LUF *luf;
+ SGF *sgf;
+ int k;
+ xassert(n > 0);
+ fi->valid = 0;
+ /* create sparse vector area (SVA), if necessary */
+ sva = fi->sva;
+ if (sva == NULL)
+ { int sva_n_max = fi->sva_n_max;
+ int sva_size = fi->sva_size;
+ if (sva_n_max == 0)
+ sva_n_max = 4 * n;
+ if (sva_size == 0)
+ sva_size = 10 * n;
+ sva = fi->sva = sva_create_area(sva_n_max, sva_size);
+ }
+ /* allocate/reallocate underlying objects, if necessary */
+ if (fi->n_max < n)
+ { int n_max = fi->n_max;
+ if (n_max == 0)
+ n_max = fi->n_max = n + fi->delta_n0;
+ else
+ n_max = fi->n_max = n + fi->delta_n;
+ xassert(n_max >= n);
+ /* allocate/reallocate LU-factorization (LUF) */
+ luf = fi->luf;
+ if (luf == NULL)
+ { luf = fi->luf = talloc(1, LUF);
+ memset(luf, 0, sizeof(LUF));
+ luf->sva = sva;
+ }
+ else
+ { tfree(luf->vr_piv);
+ tfree(luf->pp_ind);
+ tfree(luf->pp_inv);
+ tfree(luf->qq_ind);
+ tfree(luf->qq_inv);
+ }
+ luf->vr_piv = talloc(1+n_max, double);
+ luf->pp_ind = talloc(1+n_max, int);
+ luf->pp_inv = talloc(1+n_max, int);
+ luf->qq_ind = talloc(1+n_max, int);
+ luf->qq_inv = talloc(1+n_max, int);
+ /* allocate/reallocate factorizer workspace (SGF) */
+ sgf = fi->sgf;
+ if (sgf == NULL)
+ { sgf = fi->sgf = talloc(1, SGF);
+ memset(sgf, 0, sizeof(SGF));
+ sgf->luf = luf;
+ }
+ else
+ { tfree(sgf->rs_head);
+ tfree(sgf->rs_prev);
+ tfree(sgf->rs_next);
+ tfree(sgf->cs_head);
+ tfree(sgf->cs_prev);
+ tfree(sgf->cs_next);
+ tfree(sgf->vr_max);
+ tfree(sgf->flag);
+ tfree(sgf->work);
+ }
+ sgf->rs_head = talloc(1+n_max, int);
+ sgf->rs_prev = talloc(1+n_max, int);
+ sgf->rs_next = talloc(1+n_max, int);
+ sgf->cs_head = talloc(1+n_max, int);
+ sgf->cs_prev = talloc(1+n_max, int);
+ sgf->cs_next = talloc(1+n_max, int);
+ sgf->vr_max = talloc(1+n_max, double);
+ sgf->flag = talloc(1+n_max, char);
+ sgf->work = talloc(1+n_max, double);
+ }
+ luf = fi->luf;
+ sgf = fi->sgf;
+#if 1 /* FIXME */
+ /* initialize SVA */
+ sva->n = 0;
+ sva->m_ptr = 1;
+ sva->r_ptr = sva->size + 1;
+ sva->head = sva->tail = 0;
+#endif
+ /* allocate sparse vectors in SVA */
+ luf->n = n;
+ luf->fr_ref = sva_alloc_vecs(sva, n);
+ luf->fc_ref = sva_alloc_vecs(sva, n);
+ luf->vr_ref = sva_alloc_vecs(sva, n);
+ luf->vc_ref = sva_alloc_vecs(sva, n);
+ /* store matrix V = A in column-wise format */
+ luf_store_v_cols(luf, col, info, sgf->rs_prev, sgf->work);
+ /* setup factorizer control parameters */
+ sgf->updat = fi->sgf_updat;
+ sgf->piv_tol = fi->sgf_piv_tol;
+ sgf->piv_lim = fi->sgf_piv_lim;
+ sgf->suhl = fi->sgf_suhl;
+ sgf->eps_tol = fi->sgf_eps_tol;
+ /* compute LU-factorization of specified matrix A */
+ k = sgf_factorize(sgf, 1);
+ if (k == 0)
+ fi->valid = 1;
+ return k;
+}
+
+void lufint_delete(LUFINT *fi)
+{ /* delete interface to LU-factorization */
+ SVA *sva = fi->sva;
+ LUF *luf = fi->luf;
+ SGF *sgf = fi->sgf;
+ if (sva != NULL)
+ sva_delete_area(sva);
+ if (luf != NULL)
+ { tfree(luf->vr_piv);
+ tfree(luf->pp_ind);
+ tfree(luf->pp_inv);
+ tfree(luf->qq_ind);
+ tfree(luf->qq_inv);
+ tfree(luf);
+ }
+ if (sgf != NULL)
+ { tfree(sgf->rs_head);
+ tfree(sgf->rs_prev);
+ tfree(sgf->rs_next);
+ tfree(sgf->cs_head);
+ tfree(sgf->cs_prev);
+ tfree(sgf->cs_next);
+ tfree(sgf->vr_max);
+ tfree(sgf->flag);
+ tfree(sgf->work);
+ tfree(sgf);
+ }
+ tfree(fi);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/lufint.h b/test/monniaux/glpk-4.65/src/bflib/lufint.h
new file mode 100644
index 00000000..b3ad5b64
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/lufint.h
@@ -0,0 +1,73 @@
+/* lufint.h (interface to LU-factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef LUFINT_H
+#define LUFINT_H
+
+#include "sgf.h"
+
+typedef struct LUFINT LUFINT;
+
+struct LUFINT
+{ /* interface to LU-factorization */
+ int n_max;
+ /* maximal value of n (increased automatically) */
+ int valid;
+ /* factorization is valid only if this flag is set */
+ SVA *sva;
+ /* sparse vector area (SVA) */
+ LUF *luf;
+ /* sparse LU-factorization */
+ SGF *sgf;
+ /* sparse Gaussian factorizer workspace */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ int sva_n_max, sva_size;
+ /* parameters passed to sva_create_area */
+ int delta_n0, delta_n;
+ /* if n_max = 0, set n_max = n + delta_n0
+ * if n_max < n, set n_max = n + delta_n */
+ int sgf_updat;
+ double sgf_piv_tol;
+ int sgf_piv_lim;
+ int sgf_suhl;
+ double sgf_eps_tol;
+ /* factorizer control parameters */
+};
+
+#define lufint_create _glp_lufint_create
+LUFINT *lufint_create(void);
+/* create interface to LU-factorization */
+
+#define lufint_factorize _glp_lufint_factorize
+int lufint_factorize(LUFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info);
+/* compute LU-factorization of specified matrix A */
+
+#define lufint_delete _glp_lufint_delete
+void lufint_delete(LUFINT *fi);
+/* delete interface to LU-factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/scf.c b/test/monniaux/glpk-4.65/src/bflib/scf.c
new file mode 100644
index 00000000..556b1911
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/scf.c
@@ -0,0 +1,523 @@
+/* scf.c (sparse updatable Schur-complement-based factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "scf.h"
+
+/***********************************************************************
+* scf_r0_solve - solve system R0 * x = b or R0'* x = b
+*
+* This routine solves the system R0 * x = b (if tr is zero) or the
+* system R0'* x = b (if tr is non-zero), where R0 is the left factor
+* of the initial matrix A0 = R0 * S0.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n0], where n0 is the order of the
+* matrix R0. On exit the array x will contain elements of the solution
+* vector in the same locations. */
+
+void scf_r0_solve(SCF *scf, int tr, double x[/*1+n0*/])
+{ switch (scf->type)
+ { case 1:
+ /* A0 = F0 * V0, so R0 = F0 */
+ if (!tr)
+ luf_f_solve(scf->a0.luf, x);
+ else
+ luf_ft_solve(scf->a0.luf, x);
+ break;
+ case 2:
+ /* A0 = I * A0, so R0 = I */
+ break;
+ default:
+ xassert(scf != scf);
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_s0_solve - solve system S0 * x = b or S0'* x = b
+*
+* This routine solves the system S0 * x = b (if tr is zero) or the
+* system S0'* x = b (if tr is non-zero), where S0 is the right factor
+* of the initial matrix A0 = R0 * S0.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n0], where n0 is the order of the
+* matrix S0. On exit the array x will contain elements of the solution
+* vector in the same locations.
+*
+* The routine uses locations [1], ..., [n0] of three working arrays
+* w1, w2, and w3. (In case of type = 1 arrays w2 and w3 are not used
+* and can be specified as NULL.) */
+
+void scf_s0_solve(SCF *scf, int tr, double x[/*1+n0*/],
+ double w1[/*1+n0*/], double w2[/*1+n0*/], double w3[/*1+n0*/])
+{ int n0 = scf->n0;
+ switch (scf->type)
+ { case 1:
+ /* A0 = F0 * V0, so S0 = V0 */
+ if (!tr)
+ luf_v_solve(scf->a0.luf, x, w1);
+ else
+ luf_vt_solve(scf->a0.luf, x, w1);
+ break;
+ case 2:
+ /* A0 = I * A0, so S0 = A0 */
+ if (!tr)
+ btf_a_solve(scf->a0.btf, x, w1, w2, w3);
+ else
+ btf_at_solve(scf->a0.btf, x, w1, w2, w3);
+ break;
+ default:
+ xassert(scf != scf);
+ }
+ memcpy(&x[1], &w1[1], n0 * sizeof(double));
+ return;
+}
+
+/***********************************************************************
+* scf_r_prod - compute product y := y + alpha * R * x
+*
+* This routine computes the product y := y + alpha * R * x, where
+* x is a n0-vector, alpha is a scalar, y is a nn-vector.
+*
+* Since matrix R is available by rows, the product components are
+* computed as inner products:
+*
+* y[i] = y[i] + alpha * (i-th row of R) * x
+*
+* for i = 1, 2, ..., nn. */
+
+void scf_r_prod(SCF *scf, double y[/*1+nn*/], double a, const double
+ x[/*1+n0*/])
+{ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int rr_ref = scf->rr_ref;
+ int *rr_ptr = &sva->ptr[rr_ref-1];
+ int *rr_len = &sva->len[rr_ref-1];
+ int i, ptr, end;
+ double t;
+ for (i = 1; i <= nn; i++)
+ { /* t := (i-th row of R) * x */
+ t = 0.0;
+ for (end = (ptr = rr_ptr[i]) + rr_len[i]; ptr < end; ptr++)
+ t += sv_val[ptr] * x[sv_ind[ptr]];
+ /* y[i] := y[i] + alpha * t */
+ y[i] += a * t;
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_rt_prod - compute product y := y + alpha * R'* x
+*
+* This routine computes the product y := y + alpha * R'* x, where
+* R' is a matrix transposed to R, x is a nn-vector, alpha is a scalar,
+* y is a n0-vector.
+*
+* Since matrix R is available by rows, the product is computed as a
+* linear combination:
+*
+* y := y + alpha * (R'[1] * x[1] + ... + R'[nn] * x[nn]),
+*
+* where R'[i] is i-th row of R. */
+
+void scf_rt_prod(SCF *scf, double y[/*1+n0*/], double a, const double
+ x[/*1+nn*/])
+{ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int rr_ref = scf->rr_ref;
+ int *rr_ptr = &sva->ptr[rr_ref-1];
+ int *rr_len = &sva->len[rr_ref-1];
+ int i, ptr, end;
+ double t;
+ for (i = 1; i <= nn; i++)
+ { if (x[i] == 0.0)
+ continue;
+ /* y := y + alpha * R'[i] * x[i] */
+ t = a * x[i];
+ for (end = (ptr = rr_ptr[i]) + rr_len[i]; ptr < end; ptr++)
+ y[sv_ind[ptr]] += sv_val[ptr] * t;
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_s_prod - compute product y := y + alpha * S * x
+*
+* This routine computes the product y := y + alpha * S * x, where
+* x is a nn-vector, alpha is a scalar, y is a n0 vector.
+*
+* Since matrix S is available by columns, the product is computed as
+* a linear combination:
+*
+* y := y + alpha * (S[1] * x[1] + ... + S[nn] * x[nn]),
+*
+* where S[j] is j-th column of S. */
+
+void scf_s_prod(SCF *scf, double y[/*1+n0*/], double a, const double
+ x[/*1+nn*/])
+{ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int ss_ref = scf->ss_ref;
+ int *ss_ptr = &sva->ptr[ss_ref-1];
+ int *ss_len = &sva->len[ss_ref-1];
+ int j, ptr, end;
+ double t;
+ for (j = 1; j <= nn; j++)
+ { if (x[j] == 0.0)
+ continue;
+ /* y := y + alpha * S[j] * x[j] */
+ t = a * x[j];
+ for (end = (ptr = ss_ptr[j]) + ss_len[j]; ptr < end; ptr++)
+ y[sv_ind[ptr]] += sv_val[ptr] * t;
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_st_prod - compute product y := y + alpha * S'* x
+*
+* This routine computes the product y := y + alpha * S'* x, where
+* S' is a matrix transposed to S, x is a n0-vector, alpha is a scalar,
+* y is a nn-vector.
+*
+* Since matrix S is available by columns, the product components are
+* computed as inner products:
+*
+* y[j] := y[j] + alpha * (j-th column of S) * x
+*
+* for j = 1, 2, ..., nn. */
+
+void scf_st_prod(SCF *scf, double y[/*1+nn*/], double a, const double
+ x[/*1+n0*/])
+{ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int ss_ref = scf->ss_ref;
+ int *ss_ptr = &sva->ptr[ss_ref-1];
+ int *ss_len = &sva->len[ss_ref-1];
+ int j, ptr, end;
+ double t;
+ for (j = 1; j <= nn; j++)
+ { /* t := (j-th column of S) * x */
+ t = 0.0;
+ for (end = (ptr = ss_ptr[j]) + ss_len[j]; ptr < end; ptr++)
+ t += sv_val[ptr] * x[sv_ind[ptr]];
+ /* y[j] := y[j] + alpha * t */
+ y[j] += a * t;
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_a_solve - solve system A * x = b
+*
+* This routine solves the system A * x = b, where A is the current
+* matrix.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix A. On exit the array x will contain elements of the solution
+* vector in the same locations.
+*
+* For details see the program documentation. */
+
+void scf_a_solve(SCF *scf, double x[/*1+n*/],
+ double w[/*1+n0+nn*/], double work1[/*1+max(n0,nn)*/],
+ double work2[/*1+n*/], double work3[/*1+n*/])
+{ int n = scf->n;
+ int n0 = scf->n0;
+ int nn = scf->nn;
+ int *pp_ind = scf->pp_ind;
+ int *qq_inv = scf->qq_inv;
+ int i, ii;
+ /* (u1, u2) := inv(P) * (b, 0) */
+ for (ii = 1; ii <= n0+nn; ii++)
+ { i = pp_ind[ii];
+#if 1 /* FIXME: currently P = I */
+ xassert(i == ii);
+#endif
+ w[ii] = (i <= n ? x[i] : 0.0);
+ }
+ /* v1 := inv(R0) * u1 */
+ scf_r0_solve(scf, 0, &w[0]);
+ /* v2 := u2 - R * v1 */
+ scf_r_prod(scf, &w[n0], -1.0, &w[0]);
+ /* w2 := inv(C) * v2 */
+ ifu_a_solve(&scf->ifu, &w[n0], work1);
+ /* w1 := inv(S0) * (v1 - S * w2) */
+ scf_s_prod(scf, &w[0], -1.0, &w[n0]);
+ scf_s0_solve(scf, 0, &w[0], work1, work2, work3);
+ /* (x, x~) := inv(Q) * (w1, w2); x~ is not needed */
+ for (i = 1; i <= n; i++)
+ x[i] = w[qq_inv[i]];
+ return;
+}
+
+/***********************************************************************
+* scf_at_solve - solve system A'* x = b
+*
+* This routine solves the system A'* x = b, where A' is a matrix
+* transposed to the current matrix A.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix A. On exit the array x will contain elements of the solution
+* vector in the same locations.
+*
+* For details see the program documentation. */
+
+void scf_at_solve(SCF *scf, double x[/*1+n*/],
+ double w[/*1+n0+nn*/], double work1[/*1+max(n0,nn)*/],
+ double work2[/*1+n*/], double work3[/*1+n*/])
+{ int n = scf->n;
+ int n0 = scf->n0;
+ int nn = scf->nn;
+ int *pp_inv = scf->pp_inv;
+ int *qq_ind = scf->qq_ind;
+ int i, ii;
+ /* (u1, u2) := Q * (b, 0) */
+ for (ii = 1; ii <= n0+nn; ii++)
+ { i = qq_ind[ii];
+ w[ii] = (i <= n ? x[i] : 0.0);
+ }
+ /* v1 := inv(S0') * u1 */
+ scf_s0_solve(scf, 1, &w[0], work1, work2, work3);
+ /* v2 := inv(C') * (u2 - S'* v1) */
+ scf_st_prod(scf, &w[n0], -1.0, &w[0]);
+ ifu_at_solve(&scf->ifu, &w[n0], work1);
+ /* w2 := v2 */
+ /* nop */
+ /* w1 := inv(R0') * (v1 - R'* w2) */
+ scf_rt_prod(scf, &w[0], -1.0, &w[n0]);
+ scf_r0_solve(scf, 1, &w[0]);
+ /* compute (x, x~) := P * (w1, w2); x~ is not needed */
+ for (i = 1; i <= n; i++)
+ {
+#if 1 /* FIXME: currently P = I */
+ xassert(pp_inv[i] == i);
+#endif
+ x[i] = w[pp_inv[i]];
+ }
+ return;
+}
+
+/***********************************************************************
+* scf_add_r_row - add new row to matrix R
+*
+* This routine adds new (nn+1)-th row to matrix R, whose elements are
+* specified in locations w[1,...,n0]. */
+
+void scf_add_r_row(SCF *scf, const double w[/*1+n0*/])
+{ int n0 = scf->n0;
+ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int rr_ref = scf->rr_ref;
+ int *rr_ptr = &sva->ptr[rr_ref-1];
+ int *rr_len = &sva->len[rr_ref-1];
+ int j, len, ptr;
+ xassert(0 <= nn && nn < scf->nn_max);
+ /* determine length of new row */
+ len = 0;
+ for (j = 1; j <= n0; j++)
+ { if (w[j] != 0.0)
+ len++;
+ }
+ /* reserve locations for new row in static part of SVA */
+ if (len > 0)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, rr_ref + nn, len);
+ }
+ /* store new row in sparse format */
+ ptr = rr_ptr[nn+1];
+ for (j = 1; j <= n0; j++)
+ { if (w[j] != 0.0)
+ { sv_ind[ptr] = j;
+ sv_val[ptr] = w[j];
+ ptr++;
+ }
+ }
+ xassert(ptr - rr_ptr[nn+1] == len);
+ rr_len[nn+1] = len;
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+#endif
+ return;
+}
+
+/***********************************************************************
+* scf_add_s_col - add new column to matrix S
+*
+* This routine adds new (nn+1)-th column to matrix S, whose elements
+* are specified in locations v[1,...,n0]. */
+
+void scf_add_s_col(SCF *scf, const double v[/*1+n0*/])
+{ int n0 = scf->n0;
+ int nn = scf->nn;
+ SVA *sva = scf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int ss_ref = scf->ss_ref;
+ int *ss_ptr = &sva->ptr[ss_ref-1];
+ int *ss_len = &sva->len[ss_ref-1];
+ int i, len, ptr;
+ xassert(0 <= nn && nn < scf->nn_max);
+ /* determine length of new column */
+ len = 0;
+ for (i = 1; i <= n0; i++)
+ { if (v[i] != 0.0)
+ len++;
+ }
+ /* reserve locations for new column in static part of SVA */
+ if (len > 0)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, ss_ref + nn, len);
+ }
+ /* store new column in sparse format */
+ ptr = ss_ptr[nn+1];
+ for (i = 1; i <= n0; i++)
+ { if (v[i] != 0.0)
+ { sv_ind[ptr] = i;
+ sv_val[ptr] = v[i];
+ ptr++;
+ }
+ }
+ xassert(ptr - ss_ptr[nn+1] == len);
+ ss_len[nn+1] = len;
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+#endif
+ return;
+}
+
+/***********************************************************************
+* scf_update_aug - update factorization of augmented matrix
+*
+* Given factorization of the current augmented matrix:
+*
+* ( A0 A1 ) ( R0 ) ( S0 S )
+* ( ) = ( ) ( ),
+* ( A2 A3 ) ( R I ) ( C )
+*
+* this routine computes factorization of the new augmented matrix:
+*
+* ( A0 | A1 b )
+* ( ---+------ ) ( A0 A1^ ) ( R0 ) ( S0 S^ )
+* ( A2 | A3 f ) = ( ) = ( ) ( ),
+* ( | ) ( A2^ A3^ ) ( R^ I ) ( C^ )
+* ( d' | g' h )
+*
+* where b and d are specified n0-vectors, f and g are specified
+* nn-vectors, and h is a specified scalar. (Note that corresponding
+* arrays are clobbered on exit.)
+*
+* The parameter upd specifies how to update factorization of the Schur
+* complement C:
+*
+* 1 Bartels-Golub updating.
+*
+* 2 Givens rotations updating.
+*
+* The working arrays w1, w2, and w3 are used in the same way as in the
+* routine scf_s0_solve.
+*
+* RETURNS
+*
+* 0 Factorization has been successfully updated.
+*
+* 1 Updating limit has been reached.
+*
+* 2 Updating IFU-factorization of matrix C failed.
+*
+* For details see the program documentation. */
+
+int scf_update_aug(SCF *scf, double b[/*1+n0*/], double d[/*1+n0*/],
+ double f[/*1+nn*/], double g[/*1+nn*/], double h, int upd,
+ double w1[/*1+n0*/], double w2[/*1+n0*/], double w3[/*1+n0*/])
+{ int n0 = scf->n0;
+ int k, ret;
+ double *v, *w, *x, *y, z;
+ if (scf->nn == scf->nn_max)
+ { /* updating limit has been reached */
+ return 1;
+ }
+ /* v := inv(R0) * b */
+ scf_r0_solve(scf, 0, (v = b));
+ /* w := inv(S0') * d */
+ scf_s0_solve(scf, 1, (w = d), w1, w2, w3);
+ /* x := f - R * v */
+ scf_r_prod(scf, (x = f), -1.0, v);
+ /* y := g - S'* w */
+ scf_st_prod(scf, (y = g), -1.0, w);
+ /* z := h - v'* w */
+ z = h;
+ for (k = 1; k <= n0; k++)
+ z -= v[k] * w[k];
+ /* new R := R with row w added */
+ scf_add_r_row(scf, w);
+ /* new S := S with column v added */
+ scf_add_s_col(scf, v);
+ /* update IFU-factorization of C */
+ switch (upd)
+ { case 1:
+ ret = ifu_bg_update(&scf->ifu, x, y, z);
+ break;
+ case 2:
+ ret = ifu_gr_update(&scf->ifu, x, y, z);
+ break;
+ default:
+ xassert(upd != upd);
+ }
+ if (ret != 0)
+ { /* updating IFU-factorization failed */
+ return 2;
+ }
+ /* increase number of additional rows and columns */
+ scf->nn++;
+ /* expand P and Q */
+ k = n0 + scf->nn;
+ scf->pp_ind[k] = scf->pp_inv[k] = k;
+ scf->qq_ind[k] = scf->qq_inv[k] = k;
+ /* factorization has been successfully updated */
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/scf.h b/test/monniaux/glpk-4.65/src/bflib/scf.h
new file mode 100644
index 00000000..69d8cfc2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/scf.h
@@ -0,0 +1,211 @@
+/* scf.h (sparse updatable Schur-complement-based factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SCF_H
+#define SCF_H
+
+#include "btf.h"
+#include "ifu.h"
+#include "luf.h"
+
+/***********************************************************************
+* The structure SCF describes sparse updatable factorization based on
+* Schur complement.
+*
+* The SCF-factorization has the following format:
+*
+* ( A A1~ ) ( A0 A1 ) ( R0 ) ( S0 S )
+* ( ) = P ( ) Q = P ( ) ( ) Q, (1)
+* ( A2~ A3~ ) ( A2 A3 ) ( R I ) ( C )
+*
+* where:
+*
+* A is current (unsymmetric) square matrix (not stored);
+*
+* A1~, A2~, A3~ are some additional matrices (not stored);
+*
+* A0 is initial (unsymmetric) square matrix (not stored);
+*
+* A1, A2, A3 are some additional matrices (not stored);
+*
+* R0 and S0 are matrices that define factorization of the initial
+* matrix A0 = R0 * S0 (stored in an invertable form);
+*
+* R is a matrix defined from R * S0 = A2, so R = A2 * inv(S0) (stored
+* in row-wise sparse format);
+*
+* S is a matrix defined from R0 * S = A1, so S = inv(R0) * A1 (stored
+* in column-wise sparse format);
+*
+* C is Schur complement (to matrix A0) defined from R * S + C = A3,
+* so C = A3 - R * S = A3 - A2 * inv(A0) * A1 (stored in an invertable
+* form).
+*
+* P, Q are permutation matrices (stored in both row- and column-like
+* formats). */
+
+typedef struct SCF SCF;
+
+struct SCF
+{ /* Schur-complement-based factorization */
+ int n;
+ /* order of current matrix A */
+ /*--------------------------------------------------------------*/
+ /* initial matrix A0 = R0 * S0 of order n0 in invertable form */
+ int n0;
+ /* order of matrix A0 */
+ int type;
+ /* type of factorization used:
+ * 1 - LU-factorization (R0 = F0, S0 = V0)
+ * 2 - BT-factorization (R0 = I, S0 = A0) */
+ union
+ { LUF *luf; /* type = 1 */
+ BTF *btf; /* type = 2 */
+ } a0;
+ /* factorization of matrix A0 */
+ /*--------------------------------------------------------------*/
+ /* augmented matrix (A0, A1; A2, A3) of order n0+nn */
+ int nn_max;
+ /* maximal number of additional rows and columns in the augmented
+ * matrix (this limits the number of updates) */
+ int nn;
+ /* current number of additional rows and columns in the augmented
+ * matrix, 0 <= nn <= nn_max */
+ SVA *sva;
+ /* associated sparse vector area (SVA) used to store rows of
+ * matrix R and columns of matrix S */
+ /*--------------------------------------------------------------*/
+ /* nn*n0-matrix R in row-wise format */
+ int rr_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * row of matrix R */
+#if 0 + 0
+ int *rr_ptr = &sva->ptr[rr_ref-1];
+ /* rr_ptr[0] is not used;
+ * rr_ptr[i], 1 <= i <= nn, is pointer to i-th row in SVA;
+ * rr_ptr[nn+1,...,nn_max] are reserved locations */
+ int *rr_len = &sva->len[rr_ref-1];
+ /* rr_len[0] is not used;
+ * rr_len[i], 1 <= i <= nn, is length of i-th row;
+ * rr_len[nn+1,...,nn_max] are reserved locations */
+#endif
+ /*--------------------------------------------------------------*/
+ /* n0*nn-matrix S in column-wise format */
+ int ss_ref;
+ /* reference number of sparse vector in SVA, which is the first
+ * column of matrix S */
+#if 0 + 0
+ int *ss_ptr = &sva->ptr[ss_ref-1];
+ /* ss_ptr[0] is not used;
+ * ss_ptr[j], 1 <= j <= nn, is pointer to j-th column in SVA;
+ * ss_ptr[nn+1,...,nn_max] are reserved locations */
+ int *ss_len = &sva->len[ss_ref-1];
+ /* ss_len[0] is not used;
+ * ss_len[j], 1 <= j <= nn, is length of j-th column;
+ * ss_len[nn+1,...,nn_max] are reserved locations */
+#endif
+ /*--------------------------------------------------------------*/
+ /* Schur complement C of order nn in invertable form */
+ IFU ifu;
+ /* IFU-factorization of matrix C */
+ /*--------------------------------------------------------------*/
+ /* permutation matrix P of order n0+nn */
+ int *pp_ind; /* int pp_ind[1+n0+nn_max]; */
+ /* pp_ind[i] = j means that P[i,j] = 1 */
+ int *pp_inv; /* int pp_inv[1+n0+nn_max]; */
+ /* pp_inv[j] = i means that P[i,j] = 1 */
+ /*--------------------------------------------------------------*/
+ /* permutation matrix Q of order n0+nn */
+ int *qq_ind; /* int qq_ind[1+n0+nn_max]; */
+ /* qq_ind[i] = j means that Q[i,j] = 1 */
+ int *qq_inv; /* int qq_inv[1+n0+nn_max]; */
+ /* qq_inv[j] = i means that Q[i,j] = 1 */
+};
+
+#define scf_swap_q_cols(j1, j2) \
+ do \
+ { int i1, i2; \
+ i1 = qq_inv[j1], i2 = qq_inv[j2]; \
+ qq_ind[i1] = j2, qq_inv[j2] = i1; \
+ qq_ind[i2] = j1, qq_inv[j1] = i2; \
+ } while (0)
+/* swap columns j1 and j2 of permutation matrix Q */
+
+#define scf_r0_solve _glp_scf_r0_solve
+void scf_r0_solve(SCF *scf, int tr, double x[/*1+n0*/]);
+/* solve system R0 * x = b or R0'* x = b */
+
+#define scf_s0_solve _glp_scf_s0_solve
+void scf_s0_solve(SCF *scf, int tr, double x[/*1+n0*/],
+ double w1[/*1+n0*/], double w2[/*1+n0*/], double w3[/*1+n0*/]);
+/* solve system S0 * x = b or S0'* x = b */
+
+#define scf_r_prod _glp_scf_r_prod
+void scf_r_prod(SCF *scf, double y[/*1+nn*/], double a, const double
+ x[/*1+n0*/]);
+/* compute product y := y + alpha * R * x */
+
+#define scf_rt_prod _glp_scf_rt_prod
+void scf_rt_prod(SCF *scf, double y[/*1+n0*/], double a, const double
+ x[/*1+nn*/]);
+/* compute product y := y + alpha * R'* x */
+
+#define scf_s_prod _glp_scf_s_prod
+void scf_s_prod(SCF *scf, double y[/*1+n0*/], double a, const double
+ x[/*1+nn*/]);
+/* compute product y := y + alpha * S * x */
+
+#define scf_st_prod _glp_scf_st_prod
+void scf_st_prod(SCF *scf, double y[/*1+nn*/], double a, const double
+ x[/*1+n0*/]);
+/* compute product y := y + alpha * S'* x */
+
+#define scf_a_solve _glp_scf_a_solve
+void scf_a_solve(SCF *scf, double x[/*1+n*/],
+ double w[/*1+n0+nn*/], double work1[/*1+max(n0,nn)*/],
+ double work2[/*1+n*/], double work3[/*1+n*/]);
+/* solve system A * x = b */
+
+#define scf_at_solve _glp_scf_at_solve
+void scf_at_solve(SCF *scf, double x[/*1+n*/],
+ double w[/*1+n0+nn*/], double work1[/*1+max(n0,nn)*/],
+ double work2[/*1+n*/], double work3[/*1+n*/]);
+/* solve system A'* x = b */
+
+#define scf_add_r_row _glp_scf_add_r_row
+void scf_add_r_row(SCF *scf, const double w[/*1+n0*/]);
+/* add new row to matrix R */
+
+#define scf_add_s_col _glp_scf_add_s_col
+void scf_add_s_col(SCF *scf, const double v[/*1+n0*/]);
+/* add new column to matrix S */
+
+#define scf_update_aug _glp_scf_update_aug
+int scf_update_aug(SCF *scf, double b[/*1+n0*/], double d[/*1+n0*/],
+ double f[/*1+nn*/], double g[/*1+nn*/], double h, int upd,
+ double w1[/*1+n0*/], double w2[/*1+n0*/], double w3[/*1+n0*/]);
+/* update factorization of augmented matrix */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/scfint.c b/test/monniaux/glpk-4.65/src/bflib/scfint.c
new file mode 100644
index 00000000..06aa8f7d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/scfint.c
@@ -0,0 +1,255 @@
+/* scfint.c (interface to Schur-complement-based factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "scfint.h"
+
+SCFINT *scfint_create(int type)
+{ /* create interface to SC-factorization */
+ SCFINT *fi;
+ fi = talloc(1, SCFINT);
+ memset(fi, 0, sizeof(SCFINT));
+ switch ((fi->scf.type = type))
+ { case 1:
+ fi->u.lufi = lufint_create();
+ break;
+ case 2:
+ fi->u.btfi = btfint_create();
+ break;
+ default:
+ xassert(type != type);
+ }
+ return fi;
+}
+
+int scfint_factorize(SCFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info)
+{ /* compute SC-factorization of specified matrix A */
+ int nn_max, old_n0_max, n0_max, k, ret;
+ xassert(n > 0);
+ fi->valid = 0;
+ /* get required value of nn_max */
+ nn_max = fi->nn_max;
+ if (nn_max == 0)
+ nn_max = 100;
+ xassert(nn_max > 0);
+ /* compute factorization of specified matrix A */
+ switch (fi->scf.type)
+ { case 1:
+ old_n0_max = fi->u.lufi->n_max;
+ fi->u.lufi->sva_n_max = 4 * n + 2 * nn_max;
+ ret = lufint_factorize(fi->u.lufi, n, col, info);
+ n0_max = fi->u.lufi->n_max;
+ fi->scf.sva = fi->u.lufi->sva;
+ fi->scf.a0.luf = fi->u.lufi->luf;
+ break;
+ case 2:
+ old_n0_max = fi->u.btfi->n_max;
+ fi->u.btfi->sva_n_max = 6 * n + 2 * nn_max;
+ ret = btfint_factorize(fi->u.btfi, n, col, info);
+ n0_max = fi->u.btfi->n_max;
+ fi->scf.sva = fi->u.btfi->sva;
+ fi->scf.a0.btf = fi->u.btfi->btf;
+ break;
+ default:
+ xassert(fi != fi);
+ }
+ /* allocate/reallocate arrays, if necessary */
+ if (old_n0_max < n0_max)
+ { if (fi->w1 != NULL)
+ tfree(fi->w1);
+ if (fi->w2 != NULL)
+ tfree(fi->w2);
+ if (fi->w3 != NULL)
+ tfree(fi->w3);
+ fi->w1 = talloc(1+n0_max, double);
+ fi->w2 = talloc(1+n0_max, double);
+ fi->w3 = talloc(1+n0_max, double);
+ }
+ if (fi->scf.nn_max != nn_max)
+ { if (fi->scf.ifu.f != NULL)
+ tfree(fi->scf.ifu.f);
+ if (fi->scf.ifu.u != NULL)
+ tfree(fi->scf.ifu.u);
+ fi->scf.ifu.f = talloc(nn_max * nn_max, double);
+ fi->scf.ifu.u = talloc(nn_max * nn_max, double);
+ }
+ if (old_n0_max < n0_max || fi->scf.nn_max != nn_max)
+ { if (fi->scf.pp_ind != NULL)
+ tfree(fi->scf.pp_ind);
+ if (fi->scf.pp_inv != NULL)
+ tfree(fi->scf.pp_inv);
+ if (fi->scf.qq_ind != NULL)
+ tfree(fi->scf.qq_ind);
+ if (fi->scf.qq_inv != NULL)
+ tfree(fi->scf.qq_inv);
+ if (fi->w4 != NULL)
+ tfree(fi->w4);
+ if (fi->w5 != NULL)
+ tfree(fi->w5);
+ fi->scf.pp_ind = talloc(1+n0_max+nn_max, int);
+ fi->scf.pp_inv = talloc(1+n0_max+nn_max, int);
+ fi->scf.qq_ind = talloc(1+n0_max+nn_max, int);
+ fi->scf.qq_inv = talloc(1+n0_max+nn_max, int);
+ fi->w4 = talloc(1+n0_max+nn_max, double);
+ fi->w5 = talloc(1+n0_max+nn_max, double);
+ }
+ /* initialize SC-factorization */
+ fi->scf.n = n;
+ fi->scf.n0 = n;
+ fi->scf.nn_max = nn_max;
+ fi->scf.nn = 0;
+ fi->scf.rr_ref = sva_alloc_vecs(fi->scf.sva, nn_max);
+ fi->scf.ss_ref = sva_alloc_vecs(fi->scf.sva, nn_max);
+ fi->scf.ifu.n_max = nn_max;
+ fi->scf.ifu.n = 0;
+ for (k = 1; k <= n; k++)
+ { fi->scf.pp_ind[k] = k;
+ fi->scf.pp_inv[k] = k;
+ fi->scf.qq_ind[k] = k;
+ fi->scf.qq_inv[k] = k;
+ }
+ /* set validation flag */
+ if (ret == 0)
+ fi->valid = 1;
+ return ret;
+}
+
+int scfint_update(SCFINT *fi, int upd, int j, int len, const int ind[],
+ const double val[])
+{ /* update SC-factorization after replacing j-th column of A */
+ int n = fi->scf.n;
+ int n0 = fi->scf.n0;
+ int nn = fi->scf.nn;
+ int *pp_ind = fi->scf.pp_ind;
+ int *qq_ind = fi->scf.qq_ind;
+ int *qq_inv = fi->scf.qq_inv;
+ double *bf = fi->w4;
+ double *dg = fi->w5;
+ int k, t, ret;
+ xassert(fi->valid);
+ xassert(0 <= n && n <= n0+nn);
+ /* (b, f) := inv(P) * (beta, 0) */
+ for (k = 1; k <= n0+nn; k++)
+ bf[k] = 0.0;
+ for (t = 1; t <= len; t++)
+ { k = ind[t];
+ xassert(1 <= k && k <= n);
+#if 1 /* FIXME: currently P = I */
+ xassert(pp_ind[k] == k);
+#endif
+ xassert(bf[k] == 0.0);
+ xassert(val[t] != 0.0);
+ bf[k] = val[t];
+ }
+ /* (d, g) := Q * (cj, 0) */
+ for (k = 1; k <= n0+nn; k++)
+ dg[k] = 0.0;
+ xassert(1 <= j && j <= n);
+ dg[fi->scf.qq_inv[j]] = 1;
+ /* update factorization of augmented matrix */
+ ret = scf_update_aug(&fi->scf, &bf[0], &dg[0], &bf[n0], &dg[n0],
+ 0.0, upd, fi->w1, fi->w2, fi->w3);
+ if (ret == 0)
+ { /* swap j-th and last columns of new matrix Q */
+ scf_swap_q_cols(j, n0+nn+1);
+ }
+ else
+ { /* updating failed */
+ fi->valid = 0;
+ }
+ return ret;
+}
+
+void scfint_ftran(SCFINT *fi, double x[])
+{ /* solve system A * x = b */
+ xassert(fi->valid);
+ scf_a_solve(&fi->scf, x, fi->w4, fi->w5, fi->w1, fi->w2);
+ return;
+}
+
+void scfint_btran(SCFINT *fi, double x[])
+{ /* solve system A'* x = b */
+ xassert(fi->valid);
+ scf_at_solve(&fi->scf, x, fi->w4, fi->w5, fi->w1, fi->w2);
+ return;
+}
+
+double scfint_estimate(SCFINT *fi)
+{ /* estimate 1-norm of inv(A) */
+ double norm;
+ xassert(fi->valid);
+ xassert(fi->scf.n == fi->scf.n0);
+ switch (fi->scf.type)
+ { case 1:
+ norm = luf_estimate_norm(fi->scf.a0.luf, fi->w1, fi->w2);
+ break;
+ case 2:
+ norm = btf_estimate_norm(fi->scf.a0.btf, fi->w1, fi->w2,
+ fi->w3, fi->w4);
+ break;
+ default:
+ xassert(fi != fi);
+ }
+ return norm;
+}
+
+void scfint_delete(SCFINT *fi)
+{ /* delete interface to SC-factorization */
+ switch (fi->scf.type)
+ { case 1:
+ lufint_delete(fi->u.lufi);
+ break;
+ case 2:
+ btfint_delete(fi->u.btfi);
+ break;
+ default:
+ xassert(fi != fi);
+ }
+ if (fi->scf.ifu.f != NULL)
+ tfree(fi->scf.ifu.f);
+ if (fi->scf.ifu.u != NULL)
+ tfree(fi->scf.ifu.u);
+ if (fi->scf.pp_ind != NULL)
+ tfree(fi->scf.pp_ind);
+ if (fi->scf.pp_inv != NULL)
+ tfree(fi->scf.pp_inv);
+ if (fi->scf.qq_ind != NULL)
+ tfree(fi->scf.qq_ind);
+ if (fi->scf.qq_inv != NULL)
+ tfree(fi->scf.qq_inv);
+ if (fi->w1 != NULL)
+ tfree(fi->w1);
+ if (fi->w2 != NULL)
+ tfree(fi->w2);
+ if (fi->w3 != NULL)
+ tfree(fi->w3);
+ if (fi->w4 != NULL)
+ tfree(fi->w4);
+ if (fi->w5 != NULL)
+ tfree(fi->w5);
+ tfree(fi);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/scfint.h b/test/monniaux/glpk-4.65/src/bflib/scfint.h
new file mode 100644
index 00000000..3e56355b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/scfint.h
@@ -0,0 +1,89 @@
+/* scfint.h (interface to Schur-complement-based factorization) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013-2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SCFINT_H
+#define SCFINT_H
+
+#include "scf.h"
+#include "lufint.h"
+#include "btfint.h"
+
+typedef struct SCFINT SCFINT;
+
+struct SCFINT
+{ /* interface to SC-factorization */
+ int valid;
+ /* factorization is valid only if this flag is set */
+ SCF scf;
+ /* Schur-complement based factorization */
+ union
+ { LUFINT *lufi; /* scf.type = 1 */
+ BTFINT *btfi; /* scf.type = 2 */
+ } u;
+ /* interface to factorize initial matrix A0 */
+ /*--------------------------------------------------------------*/
+ /* working arrays */
+ double *w1; /* double w1[1+n0_max]; */
+ double *w2; /* double w2[1+n0_max]; */
+ double *w3; /* double w3[1+n0_max]; */
+ double *w4; /* double w4[1+n0_max+nn_max]; */
+ double *w5; /* double w5[1+n0_max+nn_max]; */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ int nn_max;
+ /* required maximal number of updates */
+};
+
+#define scfint_create _glp_scfint_create
+SCFINT *scfint_create(int type);
+/* create interface to SC-factorization */
+
+#define scfint_factorize _glp_scfint_factorize
+int scfint_factorize(SCFINT *fi, int n, int (*col)(void *info, int j,
+ int ind[], double val[]), void *info);
+/* compute SC-factorization of specified matrix A */
+
+#define scfint_update _glp_scfint_update
+int scfint_update(SCFINT *fi, int upd, int j, int len, const int ind[],
+ const double val[]);
+/* update SC-factorization after replacing j-th column of A */
+
+#define scfint_ftran _glp_scfint_ftran
+void scfint_ftran(SCFINT *fi, double x[]);
+/* solve system A * x = b */
+
+#define scfint_btran _glp_scfint_btran
+void scfint_btran(SCFINT *fi, double x[]);
+/* solve system A'* x = b */
+
+#define scfint_estimate _glp_scfint_estimate
+double scfint_estimate(SCFINT *fi);
+/* estimate 1-norm of inv(A) */
+
+#define scfint_delete _glp_scfint_delete
+void scfint_delete(SCFINT *fi);
+/* delete interface to SC-factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/sgf.c b/test/monniaux/glpk-4.65/src/bflib/sgf.c
new file mode 100644
index 00000000..1c1f49a6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/sgf.c
@@ -0,0 +1,1443 @@
+/* sgf.c (sparse Gaussian factorizer) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "sgf.h"
+
+/***********************************************************************
+* sgf_reduce_nuc - initial reordering to minimize nucleus size
+*
+* On entry to this routine it is assumed that V = A and F = P = Q = I,
+* where A is the original matrix to be factorized. It is also assumed
+* that matrix V = A is stored in both row- and column-wise formats.
+*
+* This routine performs (implicit) non-symmetric permutations of rows
+* and columns of matrix U = P'* V * Q' to reduce it to the form:
+*
+* 1 k1 k2 n
+* 1 x x x x x x x x x x
+* . x x x x x x x x x
+* . . x x x x x x x x
+* k1 . . . * * * * x x x
+* . . . * * * * x x x
+* . . . * * * * x x x
+* k2 . . . * * * * x x x
+* . . . . . . . x x x
+* . . . . . . . . x x
+* n . . . . . . . . . x
+*
+* where non-zeros in rows and columns k1, k1+1, ..., k2 constitute so
+* called nucleus ('*'), whose size is minimized by the routine.
+*
+* The numbers k1 and k2 are returned by the routine on exit. Usually,
+* if the nucleus exists, 1 <= k1 < k2 <= n. However, if the resultant
+* matrix U is upper triangular (has no nucleus), k1 = n+1 and k2 = n.
+*
+* Note that the routines sgf_choose_pivot and sgf_eliminate perform
+* exactly the same transformations (by processing row and columns
+* singletons), so preliminary minimization of the nucleus may not be
+* used. However, processing row and column singletons by the routines
+* sgf_minimize_nuc and sgf_singl_phase is more efficient. */
+
+#if 1 /* 21/II-2016 */
+/* Normally this routine returns zero. If the matrix is structurally
+* singular, the routine returns non-zero. */
+#endif
+
+int sgf_reduce_nuc(LUF *luf, int *k1_, int *k2_, int cnt[/*1+n*/],
+ int list[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int i, ii, j, jj, k1, k2, ns, ptr, end;
+ /* initial nucleus is U = V = A */
+ k1 = 1, k2 = n;
+ /*--------------------------------------------------------------*/
+ /* process column singletons */
+ /*--------------------------------------------------------------*/
+ /* determine initial counts of columns of V and initialize list
+ * of active column singletons */
+ ns = 0; /* number of active column singletons */
+ for (j = 1; j <= n; j++)
+ { if ((cnt[j] = vc_len[j]) == 1)
+ list[++ns] = j;
+ }
+ /* process active column singletons */
+ while (ns > 0)
+ { /* column singleton is in j-th column of V */
+ j = list[ns--];
+#if 1 /* 21/II-2016 */
+ if (cnt[j] == 0)
+ { /* j-th column in the current nucleus is actually empty */
+ /* this happened because on a previous step in the nucleus
+ * there were two or more identical column singletons (that
+ * means structural singularity), so removing one of them
+ * from the nucleus made other columns empty */
+ return 1;
+ }
+#endif
+ /* find i-th row of V containing column singleton */
+ ptr = vc_ptr[j];
+ end = ptr + vc_len[j];
+ for (; pp_ind[i = sv_ind[ptr]] < k1; ptr++)
+ /* nop */;
+ xassert(ptr < end);
+ /* permute rows and columns of U to move column singleton to
+ * position u[k1,k1] */
+ ii = pp_ind[i];
+ luf_swap_u_rows(k1, ii);
+ jj = qq_inv[j];
+ luf_swap_u_cols(k1, jj);
+ /* nucleus size decreased */
+ k1++;
+ /* walk thru i-th row of V and decrease column counts; this
+ * may cause new column singletons to appear */
+ ptr = vr_ptr[i];
+ end = ptr + vr_len[i];
+ for (; ptr < end; ptr++)
+ { if (--(cnt[j = sv_ind[ptr]]) == 1)
+ list[++ns] = j;
+ }
+ }
+ /* nucleus begins at k1-th row/column of U */
+ if (k1 > n)
+ { /* U is upper triangular; no nucleus exist */
+ goto done;
+ }
+ /*--------------------------------------------------------------*/
+ /* process row singletons */
+ /*--------------------------------------------------------------*/
+ /* determine initial counts of rows of V and initialize list of
+ * active row singletons */
+ ns = 0; /* number of active row singletons */
+ for (i = 1; i <= n; i++)
+ { if (pp_ind[i] < k1)
+ { /* corresponding row of U is above its k1-th row; set its
+ * count to zero to prevent including it in active list */
+ cnt[i] = 0;
+ }
+ else if ((cnt[i] = vr_len[i]) == 1)
+ list[++ns] = i;
+ }
+ /* process active row singletons */
+ while (ns > 0)
+ { /* row singleton is in i-th row of V */
+ i = list[ns--];
+#if 1 /* 21/II-2016 */
+ if (cnt[i] == 0)
+ { /* i-th row in the current nucleus is actually empty */
+ /* (see comments above for similar case of empty column) */
+ return 2;
+ }
+#endif
+ /* find j-th column of V containing row singleton */
+ ptr = vr_ptr[i];
+ end = ptr + vr_len[i];
+ for (; qq_inv[j = sv_ind[ptr]] > k2; ptr++)
+ /* nop */;
+ xassert(ptr < end);
+ /* permute rows and columns of U to move row singleton to
+ * position u[k2,k2] */
+ ii = pp_ind[i];
+ luf_swap_u_rows(k2, ii);
+ jj = qq_inv[j];
+ luf_swap_u_cols(k2, jj);
+ /* nucleus size decreased */
+ k2--;
+ /* walk thru j-th column of V and decrease row counts; this
+ * may cause new row singletons to appear */
+ ptr = vc_ptr[j];
+ end = ptr + vc_len[j];
+ for (; ptr < end; ptr++)
+ { if (--(cnt[i = sv_ind[ptr]]) == 1)
+ list[++ns] = i;
+ }
+ }
+ /* nucleus ends at k2-th row/column of U */
+ xassert(k1 < k2);
+done: *k1_ = k1, *k2_ = k2;
+ return 0;
+}
+
+/***********************************************************************
+* sgf_singl_phase - compute LU-factorization (singleton phase)
+*
+* It is assumed that on entry to the routine L = P'* F * P = F = I
+* and matrix U = P'* V * Q' has the following structure (provided by
+* the routine sgf_reduce_nuc):
+*
+* 1 k1 k2 n
+* 1 a a a b b b b c c c
+* . a a b b b b c c c
+* . . a b b b b c c c
+* k1 . . . * * * * d d d
+* . . . * * * * d d d
+* . . . * * * * d d d
+* k2 . . . * * * * d d d
+* . . . . . . . e e e
+* . . . . . . . . e e
+* n . . . . . . . . . e
+*
+* First, the routine performs (implicit) symmetric permutations of
+* rows and columns of matrix U to place them in the following order:
+*
+* 1, 2, ..., k1-1; n, n-1, ..., k2+1; k1, k1+1, ..., k2
+*
+* This changes the structure of matrix U as follows:
+*
+* 1 k1 k2' n
+* 1 a a a c c c b b b b
+* . a a c c c b b b b
+* . . a c c c b b b b
+* k1 . . . e . . . . . .
+* . . . e e . . . . .
+* . . . e e e . . . .
+* k2'. . . d d d * * * *
+* . . . d d d * * * *
+* . . . d d d * * * *
+* n . . . d d d * * * *
+*
+* where k2' = n - k2 + k1.
+*
+* Then the routine performs elementary gaussian transformations to
+* eliminate subdiagonal elements in columns k1, ..., k2'-1 of U. The
+* effect is the same as if the routine sgf_eliminate would be called
+* for k = 1, ..., k2'-1 using diagonal elements u[k,k] as pivots.
+*
+* After elimination matrices L and U becomes the following:
+*
+* 1 k1 k2' n 1 k1 k2' n
+* 1 1 . . . . . . . . . 1 a a a c c c b b b b
+* . 1 . . . . . . . . . a a c c c b b b b
+* . . 1 . . . . . . . . . a c c c b b b b
+* k1 . . . 1 . . . . . . k1 . . . e . . . . . .
+* . . . e'1 . . . . . . . . . e . . . . .
+* . . . e'e'1 . . . . . . . . . e . . . .
+* k2'. . . d'd'd'1 . . . k2'. . . . . . * * * *
+* . . . d'd'd'. 1 . . . . . . . . * * * *
+* . . . d'd'd'. . 1 . . . . . . . * * * *
+* n . . . d'd'd'. . . 1 n . . . . . . * * * *
+*
+* matrix L matrix U
+*
+* where columns k1, ..., k2'-1 of L consist of subdiagonal elements
+* of initial matrix U divided by pivots u[k,k].
+*
+* On exit the routine returns k2', the elimination step number, from
+* which computing of the factorization should be continued. Note that
+* k2' = n+1 means that matrix U is already upper triangular. */
+
+int sgf_singl_phase(LUF *luf, int k1, int k2, int updat,
+ int ind[/*1+n*/], double val[/*1+n*/])
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int i, j, k, ptr, ptr1, end, len;
+ double piv;
+ /* (see routine sgf_reduce_nuc) */
+ xassert((1 <= k1 && k1 < k2 && k2 <= n)
+ || (k1 == n+1 && k2 == n));
+ /* perform symmetric permutations of rows/columns of U */
+ for (k = k1; k <= k2; k++)
+ pp_ind[pp_inv[k]] = qq_inv[qq_ind[k]] = k - k2 + n;
+ for (k = k2+1; k <= n; k++)
+ pp_ind[pp_inv[k]] = qq_inv[qq_ind[k]] = n - k + k1;
+ for (k = 1; k <= n; k++)
+ pp_inv[pp_ind[k]] = qq_ind[qq_inv[k]] = k;
+ /* determine k2' */
+ k2 = n - k2 + k1;
+ /* process rows and columns of V corresponding to rows and
+ * columns 1, ..., k1-1 of U */
+ for (k = 1; k < k1; k++)
+ { /* k-th row of U = i-th row of V */
+ i = pp_inv[k];
+ /* find pivot u[k,k] = v[i,j] in i-th row of V */
+ ptr = vr_ptr[i];
+ end = ptr + vr_len[i];
+ for (; qq_inv[sv_ind[ptr]] != k; ptr++)
+ /* nop */;
+ xassert(ptr < end);
+ /* store pivot */
+ vr_piv[i] = sv_val[ptr];
+ /* and remove it from i-th row of V */
+ sv_ind[ptr] = sv_ind[end-1];
+ sv_val[ptr] = sv_val[end-1];
+ vr_len[i]--;
+ /* clear column of V corresponding to k-th column of U */
+ vc_len[qq_ind[k]] = 0;
+ }
+ /* clear rows of V corresponding to rows k1, ..., k2'-1 of U */
+ for (k = k1; k < k2; k++)
+ vr_len[pp_inv[k]] = 0;
+ /* process rows and columns of V corresponding to rows and
+ * columns k2', ..., n of U */
+ for (k = k2; k <= n; k++)
+ { /* k-th row of U = i-th row of V */
+ i = pp_inv[k];
+ /* remove elements from i-th row of V that correspond to
+ * elements u[k,k1], ..., u[k,k2'-1] */
+ ptr = ptr1 = vr_ptr[i];
+ end = ptr + vr_len[i];
+ for (; ptr < end; ptr++)
+ { if (qq_inv[sv_ind[ptr]] >= k2)
+ { sv_ind[ptr1] = sv_ind[ptr];
+ sv_val[ptr1] = sv_val[ptr];
+ ptr1++;
+ }
+ }
+ vr_len[i] = ptr1 - vr_ptr[i];
+ /* k-th column of U = j-th column of V */
+ j = qq_ind[k];
+ /* remove elements from j-th column of V that correspond to
+ * elements u[1,k], ..., u[k1-1,k] */
+ ptr = ptr1 = vc_ptr[j];
+ end = ptr + vc_len[j];
+ for (; ptr < end; ptr++)
+ { if (pp_ind[sv_ind[ptr]] >= k2)
+ /* element value is not needed in this case */
+ sv_ind[ptr1++] = sv_ind[ptr];
+ }
+ vc_len[j] = ptr1 - vc_ptr[j];
+ }
+ /* process columns of V corresponding to columns k1, ..., k2'-1
+ * of U, build columns of F */
+ for (k = k1; k < k2; k++)
+ { /* k-th column of U = j-th column of V */
+ j = qq_ind[k];
+ /* remove elements from j-th column of V that correspond to
+ * pivot (diagonal) element u[k,k] and subdiagonal elements
+ * u[k+1,k], ..., u[n,k]; subdiagonal elements are stored for
+ * further addition to matrix F */
+ len = 0;
+ piv = 0.0;
+ ptr = vc_ptr[j];
+ end = ptr + vc_len[j];
+ for (; ptr < end; ptr++)
+ { i = sv_ind[ptr]; /* v[i,j] */
+ if (pp_ind[i] == k)
+ { /* store pivot v[i,j] = u[k,k] */
+ piv = vr_piv[i] = sv_val[ptr];
+ }
+ else if (pp_ind[i] > k)
+ { /* store subdiagonal element v[i,j] = u[i',k] */
+ len++;
+ ind[len] = i;
+ val[len] = sv_val[ptr];
+ }
+ }
+ /* clear j-th column of V = k-th column of U */
+ vc_len[j] = 0;
+ /* build k-th column of L = j-th column of F */
+ j = pp_inv[k];
+ xassert(piv != 0.0);
+ if (len > 0)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, fc_ref-1+j, len);
+ for (ptr = fc_ptr[j], ptr1 = 1; ptr1 <= len; ptr++, ptr1++)
+ { sv_ind[ptr] = ind[ptr1];
+ sv_val[ptr] = val[ptr1] / piv;
+ }
+ fc_len[j] = len;
+ }
+ }
+ /* if it is not planned to update matrix V, relocate all its
+ * non-active rows corresponding to rows 1, ..., k2'-1 of U to
+ * the right (static) part of SVA */
+ if (!updat)
+ { for (k = 1; k < k2; k++)
+ { i = pp_inv[k];
+ len = vr_len[i];
+ if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_make_static(sva, vr_ref-1+i);
+ }
+ }
+ /* elimination steps 1, ..., k2'-1 have been performed */
+ return k2;
+}
+
+/***********************************************************************
+* sgf_choose_pivot - choose pivot element v[p,q]
+*
+* This routine chooses pivot element v[p,q], k <= p, q <= n, in the
+* active submatrix of matrix V = P * U * Q, where k is the number of
+* current elimination step, 1 <= k <= n.
+*
+* It is assumed that on entry to the routine matrix U = P'* V * Q' has
+* the following partially triangularized form:
+*
+* 1 k n
+* 1 x x x x x x x x x x
+* . x x x x x x x x x
+* . . x x x x x x x x
+* . . . x x x x x x x
+* k . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* n . . . . * * * * * *
+*
+* where rows and columns k, k+1, ..., n belong to the active submatrix
+* (its elements are marked by '*').
+*
+* Since the matrix U is not stored, the routine works with the matrix
+* V = P * U * Q. It is assumed that the row-wise representation
+* corresponds to the matrix V, but the column-wise representation
+* corresponds to the active submatrix of the matrix V, i.e. elements,
+* which are not in the active submatrix, are not included in column
+* vectors. It is also assumed that each active row of the matrix V is
+* in the set R[len], where len is the number of non-zeros in the row,
+* and each active column of the matrix V is in the set C[len], where
+* len is the number of non-zeros in the column (in the latter case
+* only elements of the active submatrix are counted; such elements are
+* marked by '*' on the figure above).
+*
+* For the reason of numerical stability the routine applies so called
+* threshold pivoting proposed by J.Reid. It is assumed that an element
+* v[i,j] can be selected as a pivot candidate if it is not very small
+* (in magnitude) among other elements in the same row, i.e. if it
+* satisfies to the stability condition |v[i,j]| >= tol * max|v[i,*]|,
+* where 0 < tol < 1 is a given tolerance.
+*
+* In order to keep sparsity of the matrix V the routine uses Markowitz
+* strategy, trying to choose such element v[p,q], which satisfies to
+* the stability condition (see above) and has smallest Markowitz cost
+* (nr[p]-1) * (nc[q]-1), where nr[p] and nc[q] are, resp., numbers of
+* non-zeros in p-th row and q-th column of the active submatrix.
+*
+* In order to reduce the search, i.e. not to walk through all elements
+* of the active submatrix, the routine uses a technique proposed by
+* I.Duff. This technique is based on using the sets R[len] and C[len]
+* of active rows and columns.
+*
+* If the pivot element v[p,q] has been chosen, the routine stores its
+* indices to locations *p and *q and returns zero. Otherwise, non-zero
+* is returned. */
+
+int sgf_choose_pivot(SGF *sgf, int *p_, int *q_)
+{ LUF *luf = sgf->luf;
+ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *rs_head = sgf->rs_head;
+ int *rs_next = sgf->rs_next;
+ int *cs_head = sgf->cs_head;
+ int *cs_prev = sgf->cs_prev;
+ int *cs_next = sgf->cs_next;
+ double *vr_max = sgf->vr_max;
+ double piv_tol = sgf->piv_tol;
+ int piv_lim = sgf->piv_lim;
+ int suhl = sgf->suhl;
+ int i, i_ptr, i_end, j, j_ptr, j_end, len, min_i, min_j, min_len,
+ ncand, next_j, p, q;
+ double best, big, cost, temp;
+ /* no pivot candidate has been chosen so far */
+ p = q = 0, best = DBL_MAX, ncand = 0;
+ /* if the active submatrix contains a column having the only
+ * non-zero element (column singleton), choose it as the pivot */
+ j = cs_head[1];
+ if (j != 0)
+ { xassert(vc_len[j] == 1);
+ p = sv_ind[vc_ptr[j]], q = j;
+ goto done;
+ }
+ /* if the active submatrix contains a row having the only
+ * non-zero element (row singleton), choose it as the pivot */
+ i = rs_head[1];
+ if (i != 0)
+ { xassert(vr_len[i] == 1);
+ p = i, q = sv_ind[vr_ptr[i]];
+ goto done;
+ }
+ /* the active submatrix contains no singletons; walk thru its
+ * other non-empty rows and columns */
+ for (len = 2; len <= n; len++)
+ { /* consider active columns containing len non-zeros */
+ for (j = cs_head[len]; j != 0; j = next_j)
+ { /* save the number of next column of the same length */
+ next_j = cs_next[j];
+ /* find an element in j-th column, which is placed in the
+ * row with minimal number of non-zeros and satisfies to
+ * the stability condition (such element may not exist) */
+ min_i = min_j = 0, min_len = INT_MAX;
+ for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ j_ptr < j_end; j_ptr++)
+ { /* get row index of v[i,j] */
+ i = sv_ind[j_ptr];
+ /* if i-th row is not shorter, skip v[i,j] */
+ if (vr_len[i] >= min_len)
+ continue;
+ /* big := max|v[i,*]| */
+ if ((big = vr_max[i]) < 0.0)
+ { /* largest magnitude is unknown; compute it */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { if ((temp = sv_val[i_ptr]) < 0.0)
+ temp = -temp;
+ if (big < temp)
+ big = temp;
+ }
+ xassert(big > 0.0);
+ vr_max[i] = big;
+ }
+ /* find v[i,j] in i-th row */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ sv_ind[i_ptr] != j; i_ptr++)
+ /* nop */;
+ xassert(i_ptr < i_end);
+ /* if |v[i,j]| < piv_tol * max|v[i,*]|, skip v[i,j] */
+ if ((temp = sv_val[i_ptr]) < 0.0)
+ temp = -temp;
+ if (temp < piv_tol * big)
+ continue;
+ /* v[i,j] is a better candidate */
+ min_i = i, min_j = j, min_len = vr_len[i];
+ /* if Markowitz cost of v[i,j] is not greater than
+ * (len-1)**2, v[i,j] can be chosen as the pivot right
+ * now; this heuristic reduces the search and works well
+ * in many cases */
+ if (min_len <= len)
+ { p = min_i, q = min_j;
+ goto done;
+ }
+ }
+ /* j-th column has been scanned */
+ if (min_i != 0)
+ { /* element v[min_i,min_j] is a next pivot candidate */
+ ncand++;
+ /* compute its Markowitz cost */
+ cost = (double)(min_len - 1) * (double)(len - 1);
+ /* if this element is better, choose it as the pivot */
+ if (cost < best)
+ p = min_i, q = min_j, best = cost;
+ /* if piv_lim candidates were considered, terminate
+ * the search, because it is doubtful that a much better
+ * candidate will be found */
+ if (ncand == piv_lim)
+ goto done;
+ }
+ else if (suhl)
+ { /* j-th column has no eligible elements that satisfy to
+ * the stability criterion; Uwe Suhl suggests to exclude
+ * such column from further considerations until it
+ * becomes a column singleton; in hard cases this may
+ * significantly reduce the time needed to choose the
+ * pivot element */
+ sgf_deactivate_col(j);
+ cs_prev[j] = cs_next[j] = j;
+ }
+ }
+ /* consider active rows containing len non-zeros */
+ for (i = rs_head[len]; i != 0; i = rs_next[i])
+ { /* big := max|v[i,*]| */
+ if ((big = vr_max[i]) < 0.0)
+ { /* largest magnitude is unknown; compute it */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { if ((temp = sv_val[i_ptr]) < 0.0)
+ temp = -temp;
+ if (big < temp)
+ big = temp;
+ }
+ xassert(big > 0.0);
+ vr_max[i] = big;
+ }
+ /* find an element in i-th row, which is placed in the
+ * column with minimal number of non-zeros and satisfies to
+ * the stability condition (such element always exists) */
+ min_i = min_j = 0, min_len = INT_MAX;
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { /* get column index of v[i,j] */
+ j = sv_ind[i_ptr];
+ /* if j-th column is not shorter, skip v[i,j] */
+ if (vc_len[j] >= min_len)
+ continue;
+ /* if |v[i,j]| < piv_tol * max|v[i,*]|, skip v[i,j] */
+ if ((temp = sv_val[i_ptr]) < 0.0)
+ temp = -temp;
+ if (temp < piv_tol * big)
+ continue;
+ /* v[i,j] is a better candidate */
+ min_i = i, min_j = j, min_len = vc_len[j];
+ /* if Markowitz cost of v[i,j] is not greater than
+ * (len-1)**2, v[i,j] can be chosen as the pivot right
+ * now; this heuristic reduces the search and works well
+ * in many cases */
+ if (min_len <= len)
+ { p = min_i, q = min_j;
+ goto done;
+ }
+ }
+ /* i-th row has been scanned */
+ if (min_i != 0)
+ { /* element v[min_i,min_j] is a next pivot candidate */
+ ncand++;
+ /* compute its Markowitz cost */
+ cost = (double)(len - 1) * (double)(min_len - 1);
+ /* if this element is better, choose it as the pivot */
+ if (cost < best)
+ p = min_i, q = min_j, best = cost;
+ /* if piv_lim candidates were considered, terminate
+ * the search, because it is doubtful that a much better
+ * candidate will be found */
+ if (ncand == piv_lim)
+ goto done;
+ }
+ else
+ { /* this can never be */
+ xassert(min_i != min_i);
+ }
+ }
+ }
+done: /* report the pivot to the factorization routine */
+ *p_ = p, *q_ = q;
+ return (p == 0);
+}
+
+/***********************************************************************
+* sgf_eliminate - perform gaussian elimination
+*
+* This routine performs elementary gaussian transformations in order
+* to eliminate subdiagonal elements in k-th column of matrix
+* U = P'* V * Q' using pivot element u[k,k], where k is the number of
+* current elimination step, 1 <= k <= n.
+*
+* The parameters p and q specify, resp., row and column indices of the
+* pivot element v[p,q] = u[k,k].
+*
+* On entry the routine assumes that partially triangularized matrices
+* L = P'* F * P and U = P'* V * Q' have the following structure:
+*
+* 1 k n 1 k n
+* 1 1 . . . . . . . . . 1 x x x x x x x x x x
+* x 1 . . . . . . . . . x x x x x x x x x
+* x x 1 . . . . . . . . . x x x x x x x x
+* x x x 1 . . . . . . . . . x x x x x x x
+* k x x x x 1 . . . . . k . . . . * * * * * *
+* x x x x _ 1 . . . . . . . . # * * * * *
+* x x x x _ . 1 . . . . . . . # * * * * *
+* x x x x _ . . 1 . . . . . . # * * * * *
+* x x x x _ . . . 1 . . . . . # * * * * *
+* n x x x x _ . . . . 1 n . . . . # * * * * *
+*
+* matrix L matrix U
+*
+* where rows and columns k, k+1, ..., n of matrix U constitute the
+* active submatrix. Elements to be eliminated are marked by '#', and
+* other elements of the active submatrix are marked by '*'. May note
+* that each eliminated non-zero element u[i,k] of matrix U gives
+* corresponding non-zero element l[i,k] of matrix L (marked by '_').
+*
+* Actually all operations are performed on matrix V. It is assumed
+* that the row-wise representation corresponds to matrix V, but the
+* column-wise representation corresponds to the active submatrix of
+* matrix V (or, more precisely, to its pattern, because only row
+* indices for columns of the active submatrix are used on this stage).
+*
+* Let u[k,k] = v[p,q] be the pivot. In order to eliminate subdiagonal
+* elements u[i',k] = v[i,q], i'= k+1, k+2, ..., n, the routine applies
+* the following elementary gaussian transformations:
+*
+* (i-th row of V) := (i-th row of V) - f[i,p] * (p-th row of V),
+*
+* where f[i,p] = v[i,q] / v[p,q] is a gaussian multiplier stored to
+* p-th column of matrix F to keep the main equality A = F * V
+* (corresponding elements l[i',k] of matrix L are marked by '_' on the
+* figure above).
+*
+* NOTE: On entry to the routine the working arrays flag and work
+* should contain zeros. This status is retained by the routine
+* on exit. */
+
+int sgf_eliminate(SGF *sgf, int p, int q)
+{ LUF *luf = sgf->luf;
+ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int *vr_cap = &sva->cap[vr_ref-1];
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_ptr = &sva->ptr[vc_ref-1];
+ int *vc_len = &sva->len[vc_ref-1];
+ int *vc_cap = &sva->cap[vc_ref-1];
+ int *rs_head = sgf->rs_head;
+ int *rs_prev = sgf->rs_prev;
+ int *rs_next = sgf->rs_next;
+ int *cs_head = sgf->cs_head;
+ int *cs_prev = sgf->cs_prev;
+ int *cs_next = sgf->cs_next;
+ double *vr_max = sgf->vr_max;
+ char *flag = sgf->flag;
+ double *work = sgf->work;
+ double eps_tol = sgf->eps_tol;
+ int nnz_diff = 0;
+ int fill, i, i_ptr, i_end, j, j_ptr, j_end, ptr, len, loc, loc1;
+ double vpq, fip, vij;
+ xassert(1 <= p && p <= n);
+ xassert(1 <= q && q <= n);
+ /* remove p-th row from the active set; this row will never
+ * return there */
+ sgf_deactivate_row(p);
+ /* process p-th (pivot) row */
+ ptr = 0;
+ for (i_end = (i_ptr = vr_ptr[p]) + vr_len[p];
+ i_ptr < i_end; i_ptr++)
+ { /* get column index of v[p,j] */
+ j = sv_ind[i_ptr];
+ if (j == q)
+ { /* save pointer to pivot v[p,q] */
+ ptr = i_ptr;
+ }
+ else
+ { /* store v[p,j], j != q, to working array */
+ flag[j] = 1;
+ work[j] = sv_val[i_ptr];
+ }
+ /* remove j-th column from the active set; q-th column will
+ * never return there while other columns will return to the
+ * active set with new length */
+ if (cs_next[j] == j)
+ { /* j-th column was marked by the pivoting routine according
+ * to Uwe Suhl's suggestion and is already inactive */
+ xassert(cs_prev[j] == j);
+ }
+ else
+ sgf_deactivate_col(j);
+ nnz_diff -= vc_len[j];
+ /* find and remove v[p,j] from j-th column */
+ for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ sv_ind[j_ptr] != p; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ sv_ind[j_ptr] = sv_ind[j_end-1];
+ vc_len[j]--;
+ }
+ /* save pivot v[p,q] and remove it from p-th row */
+ xassert(ptr > 0);
+ vpq = vr_piv[p] = sv_val[ptr];
+ sv_ind[ptr] = sv_ind[i_end-1];
+ sv_val[ptr] = sv_val[i_end-1];
+ vr_len[p]--;
+ /* if it is not planned to update matrix V, relocate p-th row to
+ * the right (static) part of SVA */
+ if (!sgf->updat)
+ { len = vr_len[p];
+ if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_make_static(sva, vr_ref-1+p);
+ }
+ /* copy the pattern (row indices) of q-th column of the active
+ * submatrix (from which v[p,q] has been just removed) to p-th
+ * column of matrix F (without unity diagonal element) */
+ len = vc_len[q];
+ if (len > 0)
+ { if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_reserve_cap(sva, fc_ref-1+p, len);
+ memcpy(&sv_ind[fc_ptr[p]], &sv_ind[vc_ptr[q]],
+ len * sizeof(int));
+ fc_len[p] = len;
+ }
+ /* make q-th column of the active submatrix empty */
+ vc_len[q] = 0;
+ /* transform non-pivot rows of the active submatrix */
+ for (loc = fc_len[p]-1; loc >= 0; loc--)
+ { /* get row index of v[i,q] = row index of f[i,p] */
+ i = sv_ind[fc_ptr[p] + loc];
+ xassert(i != p); /* v[p,q] was removed */
+ /* remove i-th row from the active set; this row will return
+ * there with new length */
+ sgf_deactivate_row(i);
+ /* find v[i,q] in i-th row */
+ for (i_end = (i_ptr = vr_ptr[i]) + vr_len[i];
+ sv_ind[i_ptr] != q; i_ptr++)
+ /* nop */;
+ xassert(i_ptr < i_end);
+ /* compute gaussian multiplier f[i,p] = v[i,q] / v[p,q] */
+ fip = sv_val[fc_ptr[p] + loc] = sv_val[i_ptr] / vpq;
+ /* remove v[i,q] from i-th row */
+ sv_ind[i_ptr] = sv_ind[i_end-1];
+ sv_val[i_ptr] = sv_val[i_end-1];
+ vr_len[i]--;
+ /* perform elementary gaussian transformation:
+ * (i-th row) := (i-th row) - f[i,p] * (p-th row)
+ * note that p-th row of V, which is in the working array,
+ * doesn't contain pivot v[p,q], and i-th row of V doesn't
+ * contain v[i,q] to be eliminated */
+ /* walk thru i-th row and transform existing elements */
+ fill = vr_len[p];
+ for (i_end = (i_ptr = ptr = vr_ptr[i]) + vr_len[i];
+ i_ptr < i_end; i_ptr++)
+ { /* get column index and value of v[i,j] */
+ j = sv_ind[i_ptr];
+ vij = sv_val[i_ptr];
+ if (flag[j])
+ { /* v[p,j] != 0 */
+ flag[j] = 0, fill--;
+ /* v[i,j] := v[i,j] - f[i,p] * v[p,j] */
+ vij -= fip * work[j];
+ if (-eps_tol < vij && vij < +eps_tol)
+ { /* new v[i,j] is close to zero; remove it from the
+ * active submatrix, i.e. replace it by exact zero */
+ /* find and remove v[i,j] from j-th column */
+ for (j_end = (j_ptr = vc_ptr[j]) + vc_len[j];
+ sv_ind[j_ptr] != i; j_ptr++)
+ /* nop */;
+ xassert(j_ptr < j_end);
+ sv_ind[j_ptr] = sv_ind[j_end-1];
+ vc_len[j]--;
+ continue;
+ }
+ }
+ /* keep new v[i,j] in i-th row */
+ sv_ind[ptr] = j;
+ sv_val[ptr] = vij;
+ ptr++;
+ }
+ /* (new length of i-th row may decrease because of numerical
+ * cancellation) */
+ vr_len[i] = len = ptr - vr_ptr[i];
+ /* now flag[*] is the pattern of the set v[p,*] \ v[i,*], and
+ * fill is the number of non-zeros in this set */
+ if (fill == 0)
+ { /* no fill-in occurs */
+ /* walk thru p-th row and restore the column flags */
+ for (i_end = (i_ptr = vr_ptr[p]) + vr_len[p];
+ i_ptr < i_end; i_ptr++)
+ flag[sv_ind[i_ptr]] = 1; /* v[p,j] != 0 */
+ goto skip;
+ }
+ /* up to fill new non-zero elements may appear in i-th row due
+ * to fill-in; reserve locations for these elements (note that
+ * actual length of i-th row is currently stored in len) */
+ if (vr_cap[i] < len + fill)
+ { if (sva->r_ptr - sva->m_ptr < len + fill)
+ { sva_more_space(sva, len + fill);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vr_ref-1+i, len + fill, 0);
+ }
+ vr_len[i] += fill;
+ /* walk thru p-th row and add new elements to i-th row */
+ for (loc1 = vr_len[p]-1; loc1 >= 0; loc1--)
+ { /* get column index of v[p,j] */
+ j = sv_ind[vr_ptr[p] + loc1];
+ if (!flag[j])
+ { /* restore j-th column flag */
+ flag[j] = 1;
+ /* v[i,j] was computed earlier on transforming existing
+ * elements of i-th row */
+ continue;
+ }
+ /* v[i,j] := 0 - f[i,p] * v[p,j] */
+ vij = - fip * work[j];
+ if (-eps_tol < vij && vij < +eps_tol)
+ { /* new v[i,j] is close to zero; do not add it to the
+ * active submatrix, i.e. replace it by exact zero */
+ continue;
+ }
+ /* add new v[i,j] to i-th row */
+ sv_ind[ptr = vr_ptr[i] + (len++)] = j;
+ sv_val[ptr] = vij;
+ /* add new v[i,j] to j-th column */
+ if (vc_cap[j] == vc_len[j])
+ { /* we reserve extra locations in j-th column to reduce
+ * further relocations of that column */
+#if 1 /* FIXME */
+ /* use control parameter to specify the number of extra
+ * locations reserved */
+ int need = vc_len[j] + 10;
+#endif
+ if (sva->r_ptr - sva->m_ptr < need)
+ { sva_more_space(sva, need);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_enlarge_cap(sva, vc_ref-1+j, need, 1);
+ }
+ sv_ind[vc_ptr[j] + (vc_len[j]++)] = i;
+ }
+ /* set final length of i-th row just transformed */
+ xassert(len <= vr_len[i]);
+ vr_len[i] = len;
+skip: /* return i-th row to the active set with new length */
+ sgf_activate_row(i);
+ /* since i-th row has been changed, largest magnitude of its
+ * elements becomes unknown */
+ vr_max[i] = -1.0;
+ }
+ /* walk thru p-th (pivot) row */
+ for (i_end = (i_ptr = vr_ptr[p]) + vr_len[p];
+ i_ptr < i_end; i_ptr++)
+ { /* get column index of v[p,j] */
+ j = sv_ind[i_ptr];
+ xassert(j != q); /* v[p,q] was removed */
+ /* return j-th column to the active set with new length */
+ if (cs_next[j] == j && vc_len[j] != 1)
+ { /* j-th column was marked by the pivoting routine and it is
+ * still not a column singleton, so leave it incative */
+ xassert(cs_prev[j] == j);
+ }
+ else
+ sgf_activate_col(j);
+ nnz_diff += vc_len[j];
+ /* restore zero content of the working arrays */
+ flag[j] = 0;
+ work[j] = 0.0;
+ }
+ /* return the difference between the numbers of non-zeros in the
+ * active submatrix on entry and on exit, resp. */
+ return nnz_diff;
+}
+
+/***********************************************************************
+* sgf_dense_lu - compute dense LU-factorization with full pivoting
+*
+* This routine performs Gaussian elimination with full pivoting to
+* compute dense LU-factorization of the specified matrix A of order n
+* in the form:
+*
+* A = P * L * U * Q, (1)
+*
+* where L is lower triangular matrix with unit diagonal, U is upper
+* triangular matrix, P and Q are permutation matrices.
+*
+* On entry to the routine elements of matrix A = (a[i,j]) should be
+* placed in the array elements a[0], ..., a[n^2-1] in dense row-wise
+* format. On exit from the routine matrix A is replaced by factors L
+* and U as follows:
+*
+* u[1,1] u[1,2] ... u[1,n-1] u[1,n]
+* l[2,1] u[2,2] ... u[2,n-1] u[2,n]
+* . . . . . . . . . . . . . .
+* l[n-1,1] l[n-1,2] u[n-1,n-1] u[n-1,n]
+* l[n,1] l[n,2] ... l[n,n-1] u[n,n]
+*
+* The unit diagonal elements of L are not stored.
+*
+* Information on permutations of rows and columns of active submatrix
+* during factorization is accumulated by the routine as follows. Every
+* time the routine permutes rows i and i' or columns j and j', it also
+* permutes elements r[i-1] and r[i'-1] or c[j-1] and c[j'-1], resp.
+* Thus, on entry to the routine elements r[0], r[1], ..., r[n-1] and
+* c[0], c[1], ..., c[n-1] should be initialized by some integers that
+* identify rows and columns of the original matrix A.
+*
+* If the factorization has been successfully computed, the routine
+* returns zero. Otherwise, if on k-th elimination step, 1 <= k <= n,
+* all elements of the active submatrix are close to zero, the routine
+* returns k, in which case a partial factorization is stored in the
+* array a. */
+
+int sgf_dense_lu(int n, double a_[], int r[], int c[], double eps)
+{ /* non-optimized version */
+ int i, j, k, p, q, ref;
+ double akk, big, temp;
+# define a(i,j) a_[(i)*n+(j)]
+ /* initially U = A, L = P = Q = I */
+ /* main elimination loop */
+ for (k = 0; k < n; k++)
+ { /* choose pivot u[p,q], k <= p, q <= n */
+ p = q = -1, big = eps;
+ for (i = k; i < n; i++)
+ { for (j = k; j < n; j++)
+ { /* temp = |u[i,j]| */
+ if ((temp = a(i,j)) < 0.0)
+ temp = -temp;
+ if (big < temp)
+ p = i, q = j, big = temp;
+ }
+ }
+ if (p < 0)
+ { /* k-th elimination step failed */
+ return k+1;
+ }
+ /* permute rows k and p */
+ if (k != p)
+ { for (j = 0; j < n; j++)
+ temp = a(k,j), a(k,j) = a(p,j), a(p,j) = temp;
+ ref = r[k], r[k] = r[p], r[p] = ref;
+ }
+ /* permute columns k and q */
+ if (k != q)
+ { for (i = 0; i < n; i++)
+ temp = a(i,k), a(i,k) = a(i,q), a(i,q) = temp;
+ ref = c[k], c[k] = c[q], c[q] = ref;
+ }
+ /* now pivot is in position u[k,k] */
+ akk = a(k,k);
+ /* eliminate subdiagonal elements u[k+1,k], ..., u[n,k] */
+ for (i = k+1; i < n; i++)
+ { if (a(i,k) != 0.0)
+ { /* gaussian multiplier l[i,k] := u[i,k] / u[k,k] */
+ temp = (a(i,k) /= akk);
+ /* (i-th row) := (i-th row) - l[i,k] * (k-th row) */
+ for (j = k+1; j < n; j++)
+ a(i,j) -= temp * a(k,j);
+ }
+ }
+ }
+# undef a
+ return 0;
+}
+
+/***********************************************************************
+* sgf_dense_phase - compute LU-factorization (dense phase)
+*
+* This routine performs dense phase of computing LU-factorization.
+*
+* The aim is two-fold. First, the main factorization routine switches
+* to dense phase when the active submatrix is relatively dense, so
+* using dense format allows significantly reduces overheads needed to
+* maintain sparse data structures. And second, that is more important,
+* on dense phase full pivoting is used (rather than partial pivoting)
+* that allows improving numerical stability, since round-off errors
+* tend to increase on last steps of the elimination process.
+*
+* On entry the routine assumes that elimination steps 1, 2, ..., k-1
+* have been performed, so partially transformed matrices L = P'* F * P
+* and U = P'* V * Q' have the following structure:
+*
+* 1 k n 1 k n
+* 1 1 . . . . . . . . . 1 x x x x x x x x x x
+* x 1 . . . . . . . . . x x x x x x x x x
+* x x 1 . . . . . . . . . x x x x x x x x
+* x x x 1 . . . . . . . . . x x x x x x x
+* k x x x x 1 . . . . . k . . . . * * * * * *
+* x x x x . 1 . . . . . . . . * * * * * *
+* x x x x . . 1 . . . . . . . * * * * * *
+* x x x x . . . 1 . . . . . . * * * * * *
+* x x x x . . . . 1 . . . . . * * * * * *
+* n x x x x . . . . . 1 n . . . . * * * * * *
+*
+* matrix L matrix U
+*
+* where rows and columns k, k+1, ..., n of matrix U constitute the
+* active submatrix A~, whose elements are marked by '*'.
+*
+* The routine copies the active submatrix A~ to a working array in
+* dense format, compute dense factorization A~ = P~* L~* U~* Q~ using
+* full pivoting, and then copies non-zero elements of factors L~ and
+* U~ back to factors L and U (more precisely, to factors F and V).
+*
+* If the factorization has been successfully computed, the routine
+* returns zero. Otherwise, if on k-th elimination step, 1 <= k <= n,
+* all elements of the active submatrix are close to zero, the routine
+* returns k (information on linearly dependent rows/columns in this
+* case is provided by matrices P and Q). */
+
+int sgf_dense_phase(LUF *luf, int k, int updat)
+{ int n = luf->n;
+ SVA *sva = luf->sva;
+ int *sv_ind = sva->ind;
+ double *sv_val = sva->val;
+ int fc_ref = luf->fc_ref;
+ int *fc_ptr = &sva->ptr[fc_ref-1];
+ int *fc_len = &sva->len[fc_ref-1];
+ int *fc_cap = &sva->cap[fc_ref-1];
+ int vr_ref = luf->vr_ref;
+ int *vr_ptr = &sva->ptr[vr_ref-1];
+ int *vr_len = &sva->len[vr_ref-1];
+ int *vr_cap = &sva->cap[vr_ref-1];
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_inv = luf->pp_inv;
+ int *pp_ind = luf->pp_ind;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int a_end, a_ptr, end, i, ia, ii, j, ja, jj, ka, len, na, ne,
+ need, ptr;
+ double *a_;
+ xassert(1 <= k && k <= n);
+ /* active columns of V are not longer needed; make them empty */
+ for (jj = k; jj <= n; jj++)
+ { /* jj is number of active column of U = P'* V * Q' */
+ vc_len[qq_ind[jj]] = 0;
+ }
+ /* determine order of active submatrix A~ of matrix U */
+ na = n - k + 1;
+ xassert(1 <= na && na <= n);
+ /* determine number of elements in dense triangular factor (L~ or
+ * U~), except diagonal elements */
+ ne = na * (na - 1) / 2;
+ /* we allocate active submatrix A~ in free (middle) part of SVA;
+ * to avoid defragmentation that could destroy A~ we also should
+ * reserve ne locations to build rows of V from rows of U~ and ne
+ * locations to build columns of F from columns of L~ */
+ need = na * na + ne + ne;
+ if (sva->r_ptr - sva->m_ptr < need)
+ { sva_more_space(sva, need);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ /* free (middle) part of SVA is structured as follows:
+ * end of left (dynamic) part
+ * ne free locations for new rows of V
+ * na free locations for active submatrix A~
+ * unused locations, if any
+ * ne free locations for new columns of F
+ * beginning of right (static) part */
+ a_ptr = sva->m_ptr + ne;
+ a_end = a_ptr + na * na;
+ /* copy active submatrix A~ from matrix V to working array in
+ * dense row-wise format */
+ a_ = &sva->val[a_ptr];
+# define a(ia, ja) a_[((ia) - 1) * na + ((ja) - 1)]
+ for (ia = 1; ia <= na; ia++)
+ { /* clear ia-th row of A~ */
+ for (ja = 1; ja <= na; ja++)
+ a(ia, ja) = 0.0;
+ /* ia-th row of A~ = (k-1+ia)-th row of U = i-th row of V */
+ i = pp_inv[k-1+ia];
+ ptr = vr_ptr[i];
+ end = ptr + vr_len[i];
+ for (; ptr < end; ptr++)
+ a(ia, qq_inv[sv_ind[ptr]]-k+1) = sv_val[ptr];
+ /* i-th row of V is no longer needed; make it empty */
+ vr_len[i] = 0;
+ }
+ /* compute dense factorization A~ = P~* L~* U~* Q~ */
+#if 1 /* FIXME: epsilon tolerance */
+ ka = sgf_dense_lu(na, &a(1, 1), &pp_inv[k], &qq_ind[k], 1e-20);
+#endif
+ /* rows of U with numbers pp_inv[k, k+1, ..., n] were permuted
+ * due to row permutations of A~; update matrix P using P~ */
+ for (ii = k; ii <= n; ii++)
+ pp_ind[pp_inv[ii]] = ii;
+ /* columns of U with numbers qq_ind[k, k+1, ..., n] were permuted
+ * due to column permutations of A~; update matrix Q using Q~ */
+ for (jj = k; jj <= n; jj++)
+ qq_inv[qq_ind[jj]] = jj;
+ /* check if dense factorization is complete */
+ if (ka != 0)
+ { /* A~ is singular to working precision */
+ /* information on linearly dependent rows/columns is provided
+ * by matrices P and Q */
+ xassert(1 <= ka && ka <= na);
+ return k - 1 + ka;
+ }
+ /* build new rows of V from rows of U~ */
+ for (ia = 1; ia <= na; ia++)
+ { /* ia-th row of U~ = (k-1+ia)-th row of U = i-th row of V */
+ i = pp_inv[k-1+ia];
+ xassert(vr_len[i] == 0);
+ /* store diagonal element u~[ia,ia] */
+ vr_piv[i] = a(ia, ia);
+ /* determine number of non-zero non-diagonal elements in ia-th
+ * row of U~ */
+ len = 0;
+ for (ja = ia+1; ja <= na; ja++)
+ { if (a(ia, ja) != 0.0)
+ len++;
+ }
+ /* reserve len locations for i-th row of matrix V in left
+ * (dynamic) part of SVA */
+ if (vr_cap[i] < len)
+ { /* there should be enough room in free part of SVA */
+ xassert(sva->r_ptr - sva->m_ptr >= len);
+ sva_enlarge_cap(sva, vr_ref-1+i, len, 0);
+ /* left part of SVA should not overlap matrix A~ */
+ xassert(sva->m_ptr <= a_ptr);
+ }
+ /* copy non-zero non-diaginal elements of ia-th row of U~ to
+ * i-th row of V */
+ ptr = vr_ptr[i];
+ for (ja = ia+1; ja <= na; ja++)
+ { if (a(ia, ja) != 0.0)
+ { sv_ind[ptr] = qq_ind[k-1+ja];
+ sv_val[ptr] = a(ia, ja);
+ ptr++;
+ }
+ }
+ xassert(ptr - vr_ptr[i] == len);
+ vr_len[i] = len;
+ }
+ /* build new columns of F from columns of L~ */
+ for (ja = 1; ja <= na; ja++)
+ { /* ja-th column of L~ = (k-1+ja)-th column of L = j-th column
+ * of F */
+ j = pp_inv[k-1+ja];
+ xassert(fc_len[j] == 0);
+ xassert(fc_cap[j] == 0);
+ /* determine number of non-zero non-diagonal elements in ja-th
+ * column of L~ */
+ len = 0;
+ for (ia = ja+1; ia <= na; ia++)
+ { if (a(ia, ja) != 0.0)
+ len++;
+ }
+ /* reserve len locations for j-th column of matrix F in right
+ * (static) part of SVA */
+ /* there should be enough room in free part of SVA */
+ xassert(sva->r_ptr - sva->m_ptr >= len);
+ if (len > 0)
+ sva_reserve_cap(sva, fc_ref-1+j, len);
+ /* right part of SVA should not overlap matrix A~ */
+ xassert(a_end <= sva->r_ptr);
+ /* copy non-zero non-diagonal elements of ja-th column of L~
+ * to j-th column of F */
+ ptr = fc_ptr[j];
+ for (ia = ja+1; ia <= na; ia++)
+ { if (a(ia, ja) != 0.0)
+ { sv_ind[ptr] = pp_inv[k-1+ia];
+ sv_val[ptr] = a(ia, ja);
+ ptr++;
+ }
+ }
+ xassert(ptr - fc_ptr[j] == len);
+ fc_len[j] = len;
+ }
+ /* factors L~ and U~ are no longer needed */
+# undef a
+ /* if it is not planned to update matrix V, relocate all its new
+ * rows to the right (static) part of SVA */
+ if (!updat)
+ { for (ia = 1; ia <= na; ia++)
+ { i = pp_inv[k-1+ia];
+ len = vr_len[i];
+ if (sva->r_ptr - sva->m_ptr < len)
+ { sva_more_space(sva, len);
+ sv_ind = sva->ind;
+ sv_val = sva->val;
+ }
+ sva_make_static(sva, vr_ref-1+i);
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* sgf_factorize - compute LU-factorization (main routine)
+*
+* This routine computes sparse LU-factorization of specified matrix A
+* using Gaussian elimination.
+*
+* On entry to the routine matrix V = A should be stored in column-wise
+* format.
+*
+* If the factorization has been successfully computed, the routine
+* returns zero. Otherwise, if on k-th elimination step, 1 <= k <= n,
+* all elements of the active submatrix are close to zero, the routine
+* returns k (information on linearly dependent rows/columns in this
+* case is provided by matrices P and Q). */
+
+#if 1 /* 21/II-2016 */
+/* If the matrix A is structurally singular, the routine returns -1.
+* NOTE: This case can be detected only if the singl flag is set. */
+#endif
+
+int sgf_factorize(SGF *sgf, int singl)
+{ LUF *luf = sgf->luf;
+ int n = luf->n;
+ SVA *sva = luf->sva;
+ int vr_ref = luf->vr_ref;
+ int *vr_len = &sva->len[vr_ref-1];
+ double *vr_piv = luf->vr_piv;
+ int vc_ref = luf->vc_ref;
+ int *vc_len = &sva->len[vc_ref-1];
+ int *pp_ind = luf->pp_ind;
+ int *pp_inv = luf->pp_inv;
+ int *qq_ind = luf->qq_ind;
+ int *qq_inv = luf->qq_inv;
+ int *rs_head = sgf->rs_head;
+ int *rs_prev = sgf->rs_prev;
+ int *rs_next = sgf->rs_next;
+ int *cs_head = sgf->cs_head;
+ int *cs_prev = sgf->cs_prev;
+ int *cs_next = sgf->cs_next;
+ double *vr_max = sgf->vr_max;
+ char *flag = sgf->flag;
+ double *work = sgf->work;
+ int i, j, k, k1, k2, p, q, nnz;
+ /* build matrix V = A in row-wise format */
+ luf_build_v_rows(luf, rs_prev);
+ /* P := Q := I, so V = U = A, F = L = I */
+ for (k = 1; k <= n; k++)
+ { vr_piv[k] = 0.0;
+ pp_ind[k] = pp_inv[k] = qq_ind[k] = qq_inv[k] = k;
+ }
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+ luf_check_all(luf, 1);
+#endif
+ /* perform singleton phase, if required */
+ if (!singl)
+ { /* assume that nucleus is entire matrix U */
+ k2 = 1;
+ }
+ else
+ { /* minimize nucleus size */
+#if 0 /* 21/II-2016 */
+ sgf_reduce_nuc(luf, &k1, &k2, rs_prev, rs_next);
+#else
+ if (sgf_reduce_nuc(luf, &k1, &k2, rs_prev, rs_next))
+ return -1;
+#endif
+#ifdef GLP_DEBUG
+ xprintf("n = %d; k1 = %d; k2 = %d\n", n, k1, k2);
+#endif
+ /* perform singleton phase */
+ k2 = sgf_singl_phase(luf, k1, k2, sgf->updat, rs_prev, work);
+ }
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+ luf_check_all(luf, k2);
+#endif
+ /* initialize working arrays */
+ rs_head[0] = cs_head[0] = 0;
+ for (k = 1; k <= n; k++)
+ { rs_head[k] = cs_head[k] = 0;
+ vr_max[k] = -1.0;
+ flag[k] = 0;
+ work[k] = 0.0;
+ }
+ /* build lists of active rows and columns of matrix V; determine
+ * number of non-zeros in initial active submatrix */
+ nnz = 0;
+ for (k = k2; k <= n; k++)
+ { i = pp_inv[k];
+ sgf_activate_row(i);
+ nnz += vr_len[i];
+ j = qq_ind[k];
+ sgf_activate_col(j);
+ }
+ /* main factorization loop */
+ for (k = k2; k <= n; k++)
+ { int na;
+ double den;
+ /* calculate density of active submatrix */
+ na = n - k + 1; /* order of active submatrix */
+#if 0 /* 21/VIII-2014 */
+ den = (double)nnz / (double)(na * na);
+#else
+ den = (double)nnz / ((double)(na) * (double)(na));
+#endif
+ /* if active submatrix is relatively dense, switch to dense
+ * phase */
+#if 1 /* FIXME */
+ if (na >= 5 && den >= 0.71)
+ {
+#ifdef GLP_DEBUG
+ xprintf("na = %d; nnz = %d; den = %g\n", na, nnz, den);
+#endif
+ break;
+ }
+#endif
+ /* choose pivot v[p,q] */
+ if (sgf_choose_pivot(sgf, &p, &q) != 0)
+ return k; /* failure */
+ /* u[i,j] = v[p,q], k <= i, j <= n */
+ i = pp_ind[p];
+ xassert(k <= i && i <= n);
+ j = qq_inv[q];
+ xassert(k <= j && j <= n);
+ /* move u[i,j] to position u[k,k] by implicit permutations of
+ * rows and columns of matrix U */
+ luf_swap_u_rows(k, i);
+ luf_swap_u_cols(k, j);
+ /* perform gaussian elimination */
+ nnz += sgf_eliminate(sgf, p, q);
+ }
+#if 1 /* FIXME */
+ if (k <= n)
+ { /* continue computing factorization in dense mode */
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+ luf_check_all(luf, k);
+#endif
+ k = sgf_dense_phase(luf, k, sgf->updat);
+ if (k != 0)
+ return k; /* failure */
+ }
+#endif
+#ifdef GLP_DEBUG
+ sva_check_area(sva);
+ luf_check_all(luf, n+1);
+#endif
+ /* defragment SVA; currently all columns of V are empty, so they
+ * will have zero capacity as required by luf_build_v_cols */
+ sva_defrag_area(sva);
+ /* build matrix F in row-wise format */
+ luf_build_f_rows(luf, rs_head);
+ /* build matrix V in column-wise format */
+ luf_build_v_cols(luf, sgf->updat, rs_head);
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/sgf.h b/test/monniaux/glpk-4.65/src/bflib/sgf.h
new file mode 100644
index 00000000..4f744610
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/sgf.h
@@ -0,0 +1,203 @@
+/* sgf.h (sparse Gaussian factorizer) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SGF_H
+#define SGF_H
+
+#include "luf.h"
+
+typedef struct SGF SGF;
+
+struct SGF
+{ /* sparse Gaussian factorizer workspace */
+ LUF *luf;
+ /* LU-factorization being computed */
+ /*--------------------------------------------------------------*/
+ /* to efficiently choose pivot elements according to Markowitz
+ * strategy, the search technique proposed by Iain Duff is used;
+ * it is based on using two families of sets {R[0], ..., R[n]}
+ * and {C[0], ..., C[n]}, where R[k] and C[k], 0 <= k <= n, are,
+ * respectively, sets of rows and columns of the active submatrix
+ * of matrix V having k non-zeros (i.e. whose length is k); each
+ * set R[k] and C[k] is implemented as a doubly linked list */
+ int *rs_head; /* int rs_head[1+n]; */
+ /* rs_head[k], 0 <= k <= n, is the number of first row, which
+ * has k non-zeros in the active submatrix */
+ int *rs_prev; /* int rs_prev[1+n]; */
+ /* rs_prev[0] is not used;
+ * rs_prev[i], 1 <= i <= n, is the number of previous row, which
+ * has the same number of non-zeros as i-th row;
+ * rs_prev[i] < 0 means that i-th row is inactive */
+ int *rs_next; /* int rs_next[1+n]; */
+ /* rs_next[0] is not used;
+ * rs_next[i], 1 <= i <= n, is the number of next row, which has
+ * the same number of non-zeros as i-th row;
+ * rs_next[i] < 0 means that i-th row is inactive */
+ int *cs_head; /* int cs_head[1+n]; */
+ /* cs_head[k], 0 <= k <= n, is the number of first column, which
+ * has k non-zeros in the active submatrix */
+ int *cs_prev; /* int cs_prev[1+n]; */
+ /* cs_prev[0] is not used;
+ * cs_prev[j], 1 <= j <= n, is the number of previous column,
+ * which has the same number of non-zeros as j-th column;
+ * cs_prev[j] < 0 means that j-th column is inactive */
+ int *cs_next; /* int cs_next[1+n]; */
+ /* cs_next[0] is not used;
+ * cs_next[j], 1 <= j <= n, is the number of next column, which
+ * has the same number of non-zeros as j-th column;
+ * cs_next[j] < 0 means that j-th column is inactive */
+ /* NOTE: cs_prev[j] = cs_next[j] = j means that j-th column was
+ * temporarily removed from corresponding set C[k] by the
+ * pivoting routine according to Uwe Suhl's heuristic */
+ /*--------------------------------------------------------------*/
+ /* working arrays */
+ double *vr_max; /* int vr_max[1+n]; */
+ /* vr_max[0] is not used;
+ * vr_max[i], 1 <= i <= n, is used only if i-th row of matrix V
+ * is active (i.e. belongs to the active submatrix), and is the
+ * largest magnitude of elements in that row; if vr_max[i] < 0,
+ * the largest magnitude is unknown yet */
+ char *flag; /* char flag[1+n]; */
+ /* boolean working array */
+ double *work; /* double work[1+n]; */
+ /* floating-point working array */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ int updat;
+ /* if this flag is set, the matrix V is assumed to be updatable;
+ * in this case factorized (non-active) part of V is stored in
+ * the left part of SVA rather than in its right part */
+ double piv_tol;
+ /* threshold pivoting tolerance, 0 < piv_tol < 1; element v[i,j]
+ * of the active submatrix fits to be pivot if it satisfies to
+ * the stability criterion |v[i,j]| >= piv_tol * max |v[i,*]|,
+ * i.e. if it is not very small in the magnitude among other
+ * elements in the same row; decreasing this parameter gives
+ * better sparsity at the expense of numerical accuracy and vice
+ * versa */
+ int piv_lim;
+ /* maximal allowable number of pivot candidates to be considered;
+ * if piv_lim pivot candidates have been considered, the pivoting
+ * routine terminates the search with the best candidate found */
+ int suhl;
+ /* if this flag is set, the pivoting routine applies a heuristic
+ * proposed by Uwe Suhl: if a column of the active submatrix has
+ * no eligible pivot candidates (i.e. all its elements do not
+ * satisfy to the stability criterion), the routine excludes it
+ * from futher consideration until it becomes column singleton;
+ * in many cases this allows reducing the time needed to choose
+ * the pivot */
+ double eps_tol;
+ /* epsilon tolerance; each element of the active submatrix, whose
+ * magnitude is less than eps_tol, is replaced by exact zero */
+#if 0 /* FIXME */
+ double den_lim;
+ /* density limit; if the density of the active submatrix reaches
+ * this limit, the factorization routine switches from sparse to
+ * dense mode */
+#endif
+};
+
+#define sgf_activate_row(i) \
+ do \
+ { int len = vr_len[i]; \
+ rs_prev[i] = 0; \
+ rs_next[i] = rs_head[len]; \
+ if (rs_next[i] != 0) \
+ rs_prev[rs_next[i]] = i; \
+ rs_head[len] = i; \
+ } while (0)
+/* include i-th row of matrix V in active set R[len] */
+
+#define sgf_deactivate_row(i) \
+ do \
+ { if (rs_prev[i] == 0) \
+ rs_head[vr_len[i]] = rs_next[i]; \
+ else \
+ rs_next[rs_prev[i]] = rs_next[i]; \
+ if (rs_next[i] == 0) \
+ ; \
+ else \
+ rs_prev[rs_next[i]] = rs_prev[i]; \
+ rs_prev[i] = rs_next[i] = -1; \
+ } while (0)
+/* remove i-th row of matrix V from active set R[len] */
+
+#define sgf_activate_col(j) \
+ do \
+ { int len = vc_len[j]; \
+ cs_prev[j] = 0; \
+ cs_next[j] = cs_head[len]; \
+ if (cs_next[j] != 0) \
+ cs_prev[cs_next[j]] = j; \
+ cs_head[len] = j; \
+ } while (0)
+/* include j-th column of matrix V in active set C[len] */
+
+#define sgf_deactivate_col(j) \
+ do \
+ { if (cs_prev[j] == 0) \
+ cs_head[vc_len[j]] = cs_next[j]; \
+ else \
+ cs_next[cs_prev[j]] = cs_next[j]; \
+ if (cs_next[j] == 0) \
+ ; \
+ else \
+ cs_prev[cs_next[j]] = cs_prev[j]; \
+ cs_prev[j] = cs_next[j] = -1; \
+ } while (0)
+/* remove j-th column of matrix V from active set C[len] */
+
+#define sgf_reduce_nuc _glp_sgf_reduce_nuc
+int sgf_reduce_nuc(LUF *luf, int *k1, int *k2, int cnt[/*1+n*/],
+ int list[/*1+n*/]);
+/* initial reordering to minimize nucleus size */
+
+#define sgf_singl_phase _glp_sgf_singl_phase
+int sgf_singl_phase(LUF *luf, int k1, int k2, int updat,
+ int ind[/*1+n*/], double val[/*1+n*/]);
+/* compute LU-factorization (singleton phase) */
+
+#define sgf_choose_pivot _glp_sgf_choose_pivot
+int sgf_choose_pivot(SGF *sgf, int *p, int *q);
+/* choose pivot element v[p,q] */
+
+#define sgf_eliminate _glp_sgf_eliminate
+int sgf_eliminate(SGF *sgf, int p, int q);
+/* perform gaussian elimination */
+
+#define sgf_dense_lu _glp_sgf_dense_lu
+int sgf_dense_lu(int n, double a[], int r[], int c[], double eps);
+/* compute dense LU-factorization with full pivoting */
+
+#define sgf_dense_phase _glp_sgf_dense_phase
+int sgf_dense_phase(LUF *luf, int k, int updat);
+/* compute LU-factorization (dense phase) */
+
+#define sgf_factorize _glp_sgf_factorize
+int sgf_factorize(SGF *sgf, int singl);
+/* compute LU-factorization (main routine) */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/sva.c b/test/monniaux/glpk-4.65/src/bflib/sva.c
new file mode 100644
index 00000000..e6a675cc
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/sva.c
@@ -0,0 +1,572 @@
+/* sva.c (sparse vector area) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "sva.h"
+
+/***********************************************************************
+* sva_create_area - create sparse vector area (SVA)
+*
+* This routine creates the sparse vector area (SVA), which initially
+* is empty.
+*
+* The parameter n_max specifies the initial number of vectors that can
+* be allocated in the SVA, n_max > 0.
+*
+* The parameter size specifies the initial number of free locations in
+* the SVA, size > 0.
+*
+* On exit the routine returns a pointer to the SVA created. */
+
+SVA *sva_create_area(int n_max, int size)
+{ SVA *sva;
+ xassert(0 < n_max && n_max < INT_MAX);
+ xassert(0 < size && size < INT_MAX);
+ sva = talloc(1, SVA);
+ sva->n_max = n_max;
+ sva->n = 0;
+ sva->ptr = talloc(1+n_max, int);
+ sva->len = talloc(1+n_max, int);
+ sva->cap = talloc(1+n_max, int);
+ sva->size = size;
+ sva->m_ptr = 1;
+ sva->r_ptr = size+1;
+ sva->head = sva->tail = 0;
+ sva->prev = talloc(1+n_max, int);
+ sva->next = talloc(1+n_max, int);
+ sva->ind = talloc(1+size, int);
+ sva->val = talloc(1+size, double);
+ sva->talky = 0;
+ return sva;
+}
+
+/***********************************************************************
+* sva_alloc_vecs - allocate new vectors in SVA
+*
+* This routine allocates nnn new empty vectors, nnn > 0, in the sparse
+* vector area (SVA).
+*
+* The new vectors are assigned reference numbers k, k+1, ..., k+nnn-1,
+* where k is a reference number assigned to the very first new vector,
+* which is returned by the routine on exit. */
+
+int sva_alloc_vecs(SVA *sva, int nnn)
+{ int n = sva->n;
+ int n_max = sva->n_max;
+ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ int *prev = sva->prev;
+ int *next = sva->next;
+ int k, new_n;
+#if 1
+ if (sva->talky)
+ xprintf("sva_alloc_vecs: nnn = %d\n", nnn);
+#endif
+ xassert(nnn > 0);
+ /* determine new number of vectors in SVA */
+ new_n = n + nnn;
+ xassert(new_n > n);
+ if (n_max < new_n)
+ { /* enlarge the SVA arrays */
+ while (n_max < new_n)
+ { n_max += n_max;
+ xassert(n_max > 0);
+ }
+ sva->n_max = n_max;
+ sva->ptr = ptr = trealloc(ptr, 1+n_max, int);
+ sva->len = len = trealloc(len, 1+n_max, int);
+ sva->cap = cap = trealloc(cap, 1+n_max, int);
+ sva->prev = prev = trealloc(prev, 1+n_max, int);
+ sva->next = next = trealloc(next, 1+n_max, int);
+ }
+ /* initialize new vectors */
+ sva->n = new_n;
+ for (k = n+1; k <= new_n; k++)
+ { ptr[k] = len[k] = cap[k] = 0;
+ prev[k] = next[k] = -1;
+ }
+#if 1
+ if (sva->talky)
+ xprintf("now sva->n_max = %d, sva->n = %d\n",
+ sva->n_max, sva->n);
+#endif
+ /* return reference number of very first new vector */
+ return n+1;
+}
+
+/***********************************************************************
+* sva_resize_area - change size of SVA storage
+*
+* This routine increases or decrases the size of the SVA storage by
+* reallocating it.
+*
+* The parameter delta specifies the number of location by which the
+* current size of the SVA storage should be increased (if delta > 0)
+* or decreased (if delta < 0). Note that if delta is negative, it
+* should not be less than the current size of the middle part.
+*
+* As a result of this operation the size of the middle part of SVA is
+* increased/decreased by delta locations.
+*
+* NOTE: This operation changes ptr[k] for all vectors stored in the
+* right part of SVA. */
+
+void sva_resize_area(SVA *sva, int delta)
+{ int n = sva->n;
+ int *ptr = sva->ptr;
+ int size = sva->size;
+ int m_ptr = sva->m_ptr;
+ int r_ptr = sva->r_ptr;
+ int k, r_size;
+#if 1
+ if (sva->talky)
+ xprintf("sva_resize_area: delta = %d\n", delta);
+#endif
+ xassert(delta != 0);
+ /* determine size of the right part, in locations */
+ r_size = size - r_ptr + 1;
+ /* relocate the right part in case of negative delta */
+ if (delta < 0)
+ { xassert(delta >= m_ptr - r_ptr);
+ sva->r_ptr += delta;
+ memmove(&sva->ind[sva->r_ptr], &sva->ind[r_ptr],
+ r_size * sizeof(int));
+ memmove(&sva->val[sva->r_ptr], &sva->val[r_ptr],
+ r_size * sizeof(double));
+ }
+ /* reallocate the storage arrays */
+ xassert(delta < INT_MAX - sva->size);
+ sva->size += delta;
+ sva->ind = trealloc(sva->ind, 1+sva->size, int);
+ sva->val = trealloc(sva->val, 1+sva->size, double);
+ /* relocate the right part in case of positive delta */
+ if (delta > 0)
+ { sva->r_ptr += delta;
+ memmove(&sva->ind[sva->r_ptr], &sva->ind[r_ptr],
+ r_size * sizeof(int));
+ memmove(&sva->val[sva->r_ptr], &sva->val[r_ptr],
+ r_size * sizeof(double));
+ }
+ /* update pointers to vectors stored in the right part */
+ for (k = 1; k <= n; k++)
+ { if (ptr[k] >= r_ptr)
+ ptr[k] += delta;
+ }
+#if 1
+ if (sva->talky)
+ xprintf("now sva->size = %d\n", sva->size);
+#endif
+ return;
+}
+
+/***********************************************************************
+* sva_defrag_area - defragment left part of SVA
+*
+* This routine performs "garbage" collection to defragment the left
+* part of SVA.
+*
+* NOTE: This operation may change ptr[k] and cap[k] for all vectors
+* stored in the left part of SVA. */
+
+void sva_defrag_area(SVA *sva)
+{ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ int *prev = sva->prev;
+ int *next = sva->next;
+ int *ind = sva->ind;
+ double *val = sva->val;
+ int k, next_k, ptr_k, len_k, m_ptr, head, tail;
+#if 1
+ if (sva->talky)
+ { xprintf("sva_defrag_area:\n");
+ xprintf("before defragmenting = %d %d %d\n", sva->m_ptr - 1,
+ sva->r_ptr - sva->m_ptr, sva->size + 1 - sva->r_ptr);
+ }
+#endif
+ m_ptr = 1;
+ head = tail = 0;
+ /* walk through the linked list of vectors stored in the left
+ * part of SVA */
+ for (k = sva->head; k != 0; k = next_k)
+ { /* save number of next vector in the list */
+ next_k = next[k];
+ /* determine length of k-th vector */
+ len_k = len[k];
+ if (len_k == 0)
+ { /* k-th vector is empty; remove it from the left part */
+ ptr[k] = cap[k] = 0;
+ prev[k] = next[k] = -1;
+ }
+ else
+ { /* determine pointer to first location of k-th vector */
+ ptr_k = ptr[k];
+ xassert(m_ptr <= ptr_k);
+ /* relocate k-th vector to the beginning of the left part,
+ * if necessary */
+ if (m_ptr < ptr_k)
+ { memmove(&ind[m_ptr], &ind[ptr_k],
+ len_k * sizeof(int));
+ memmove(&val[m_ptr], &val[ptr_k],
+ len_k * sizeof(double));
+ ptr[k] = m_ptr;
+ }
+ /* remove unused locations from k-th vector */
+ cap[k] = len_k;
+ /* the left part of SVA has been enlarged */
+ m_ptr += len_k;
+ /* add k-th vector to the end of the new linked list */
+ prev[k] = tail;
+ next[k] = 0;
+ if (head == 0)
+ head = k;
+ else
+ next[tail] = k;
+ tail = k;
+ }
+ }
+ /* set new pointer to the middle part of SVA */
+ xassert(m_ptr <= sva->r_ptr);
+ sva->m_ptr = m_ptr;
+ /* set new head and tail of the linked list */
+ sva->head = head;
+ sva->tail = tail;
+#if 1
+ if (sva->talky)
+ xprintf("after defragmenting = %d %d %d\n", sva->m_ptr - 1,
+ sva->r_ptr - sva->m_ptr, sva->size + 1 - sva->r_ptr);
+#endif
+ return;
+}
+
+/***********************************************************************
+* sva_more_space - increase size of middle (free) part of SVA
+*
+* This routine increases the size of the middle (free) part of the
+* sparse vector area (SVA).
+*
+* The parameter m_size specifies the minimal size, in locations, of
+* the middle part to be provided. This new size should be greater than
+* the current size of the middle part.
+*
+* First, the routine defragments the left part of SVA. Then, if the
+* size of the left part has not sufficiently increased, the routine
+* increases the total size of the SVA storage by reallocating it. */
+
+void sva_more_space(SVA *sva, int m_size)
+{ int size, delta;
+#if 1
+ if (sva->talky)
+ xprintf("sva_more_space: m_size = %d\n", m_size);
+#endif
+ xassert(m_size > sva->r_ptr - sva->m_ptr);
+ /* defragment the left part */
+ sva_defrag_area(sva);
+ /* set, heuristically, the minimal size of the middle part to be
+ * not less than the size of the defragmented left part */
+ if (m_size < sva->m_ptr - 1)
+ m_size = sva->m_ptr - 1;
+ /* if there is still not enough room, increase the total size of
+ * the SVA storage */
+ if (sva->r_ptr - sva->m_ptr < m_size)
+ { size = sva->size; /* new sva size */
+ for (;;)
+ { delta = size - sva->size;
+ if (sva->r_ptr - sva->m_ptr + delta >= m_size)
+ break;
+ size += size;
+ xassert(size > 0);
+ }
+ sva_resize_area(sva, delta);
+ xassert(sva->r_ptr - sva->m_ptr >= m_size);
+ }
+ return;
+}
+
+/***********************************************************************
+* sva_enlarge_cap - enlarge capacity of specified vector
+*
+* This routine enlarges the current capacity of the specified vector
+* by relocating its content.
+*
+* The parameter k specifies the reference number of the vector whose
+* capacity should be enlarged, 1 <= k <= n. This vector should either
+* have zero capacity or be stored in the left (dynamic) part of SVA.
+*
+* The parameter new_cap specifies the new capacity of the vector,
+* in locations. This new capacity should be greater than the current
+* capacity of the vector.
+*
+* The parameter skip is a flag. If this flag is set, the routine does
+* *not* copy numerical values of elements of the vector on relocating
+* its content, i.e. only element indices are copied.
+*
+* NOTE: On entry to the routine the middle part of SVA should have at
+* least new_cap free locations. */
+
+void sva_enlarge_cap(SVA *sva, int k, int new_cap, int skip)
+{ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ int *prev = sva->prev;
+ int *next = sva->next;
+ int *ind = sva->ind;
+ double *val = sva->val;
+ xassert(1 <= k && k <= sva->n);
+ xassert(new_cap > cap[k]);
+ /* there should be at least new_cap free locations */
+ xassert(sva->r_ptr - sva->m_ptr >= new_cap);
+ /* relocate the vector */
+ if (cap[k] == 0)
+ { /* the vector is empty */
+ xassert(ptr[k] == 0);
+ xassert(len[k] == 0);
+ }
+ else
+ { /* the vector has non-zero capacity */
+ xassert(ptr[k] + len[k] <= sva->m_ptr);
+ /* copy the current vector content to the beginning of the
+ * middle part */
+ if (len[k] > 0)
+ { memcpy(&ind[sva->m_ptr], &ind[ptr[k]],
+ len[k] * sizeof(int));
+ if (!skip)
+ memcpy(&val[sva->m_ptr], &val[ptr[k]],
+ len[k] * sizeof(double));
+ }
+ /* remove the vector from the linked list */
+ if (prev[k] == 0)
+ sva->head = next[k];
+ else
+ { /* preceding vector exists; increase its capacity */
+ cap[prev[k]] += cap[k];
+ next[prev[k]] = next[k];
+ }
+ if (next[k] == 0)
+ sva->tail = prev[k];
+ else
+ prev[next[k]] = prev[k];
+ }
+ /* set new pointer and capacity of the vector */
+ ptr[k] = sva->m_ptr;
+ cap[k] = new_cap;
+ /* add the vector to the end of the linked list */
+ prev[k] = sva->tail;
+ next[k] = 0;
+ if (sva->head == 0)
+ sva->head = k;
+ else
+ next[sva->tail] = k;
+ sva->tail = k;
+ /* new_cap free locations have been consumed */
+ sva->m_ptr += new_cap;
+ xassert(sva->m_ptr <= sva->r_ptr);
+ return;
+}
+
+/***********************************************************************
+* sva_reserve_cap - reserve locations for specified vector
+*
+* This routine reserves locations for the specified vector in the
+* right (static) part of SVA.
+*
+* The parameter k specifies the reference number of the vector (this
+* vector should have zero capacity), 1 <= k <= n.
+*
+* The parameter new_cap specifies a non-zero capacity of the vector,
+* in locations.
+*
+* NOTE: On entry to the routine the middle part of SVA should have at
+* least new_cap free locations. */
+
+void sva_reserve_cap(SVA *sva, int k, int new_cap)
+{ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ xassert(1 <= k && k <= sva->n);
+ xassert(new_cap > 0);
+ xassert(ptr[k] == 0 && len[k] == 0 && cap[k] == 0);
+ /* there should be at least new_cap free locations */
+ xassert(sva->r_ptr - sva->m_ptr >= new_cap);
+ /* set the pointer and capacity of the vector */
+ ptr[k] = sva->r_ptr - new_cap;
+ cap[k] = new_cap;
+ /* new_cap free locations have been consumed */
+ sva->r_ptr -= new_cap;
+ return;
+}
+
+/***********************************************************************
+* sva_make_static - relocate specified vector to right part of SVA
+*
+* Assuming that the specified vector is stored in the left (dynamic)
+* part of SVA, this routine makes the vector static by relocating its
+* content to the right (static) part of SVA. However, if the specified
+* vector has zero capacity, the routine does nothing.
+*
+* The parameter k specifies the reference number of the vector to be
+* relocated, 1 <= k <= n.
+*
+* NOTE: On entry to the routine the middle part of SVA should have at
+* least len[k] free locations, where len[k] is the length of the
+* vector to be relocated. */
+
+void sva_make_static(SVA *sva, int k)
+{ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ int *prev = sva->prev;
+ int *next = sva->next;
+ int *ind = sva->ind;
+ double *val = sva->val;
+ int ptr_k, len_k;
+ xassert(1 <= k && k <= sva->n);
+ /* if the vector has zero capacity, do nothing */
+ if (cap[k] == 0)
+ { xassert(ptr[k] == 0);
+ xassert(len[k] == 0);
+ goto done;
+ }
+ /* there should be at least len[k] free locations */
+ len_k = len[k];
+ xassert(sva->r_ptr - sva->m_ptr >= len_k);
+ /* remove the vector from the linked list */
+ if (prev[k] == 0)
+ sva->head = next[k];
+ else
+ { /* preceding vector exists; increase its capacity */
+ cap[prev[k]] += cap[k];
+ next[prev[k]] = next[k];
+ }
+ if (next[k] == 0)
+ sva->tail = prev[k];
+ else
+ prev[next[k]] = prev[k];
+ /* if the vector has zero length, make it empty */
+ if (len_k == 0)
+ { ptr[k] = cap[k] = 0;
+ goto done;
+ }
+ /* copy the vector content to the beginning of the right part */
+ ptr_k = sva->r_ptr - len_k;
+ memcpy(&ind[ptr_k], &ind[ptr[k]], len_k * sizeof(int));
+ memcpy(&val[ptr_k], &val[ptr[k]], len_k * sizeof(double));
+ /* set new pointer and capacity of the vector */
+ ptr[k] = ptr_k;
+ cap[k] = len_k;
+ /* len[k] free locations have been consumed */
+ sva->r_ptr -= len_k;
+done: return;
+}
+
+/***********************************************************************
+* sva_check_area - check sparse vector area (SVA)
+*
+* This routine checks the SVA data structures for correctness.
+*
+* NOTE: For testing/debugging only. */
+
+void sva_check_area(SVA *sva)
+{ int n_max = sva->n_max;
+ int n = sva->n;
+ int *ptr = sva->ptr;
+ int *len = sva->len;
+ int *cap = sva->cap;
+ int size = sva->size;
+ int m_ptr = sva->m_ptr;
+ int r_ptr = sva->r_ptr;
+ int head = sva->head;
+ int tail = sva->tail;
+ int *prev = sva->prev;
+ int *next = sva->next;
+ int k;
+#if 0 /* 16/II-2004; SVA may be empty */
+ xassert(1 <= n && n <= n_max);
+#else
+ xassert(0 <= n && n <= n_max);
+#endif
+ xassert(1 <= m_ptr && m_ptr <= r_ptr && r_ptr <= size+1);
+ /* all vectors included the linked list should have non-zero
+ * capacity and be stored in the left part */
+ for (k = head; k != 0; k = next[k])
+ { xassert(1 <= k && k <= n);
+ xassert(cap[k] > 0);
+ xassert(0 <= len[k] && len[k] <= cap[k]);
+ if (prev[k] == 0)
+ xassert(k == head);
+ else
+ { xassert(1 <= prev[k] && prev[k] <= n);
+ xassert(next[prev[k]] == k);
+ }
+ if (next[k] == 0)
+ { xassert(k == tail);
+ xassert(ptr[k] + cap[k] <= m_ptr);
+ }
+ else
+ { xassert(1 <= next[k] && next[k] <= n);
+ xassert(prev[next[k]] == k);
+ xassert(ptr[k] + cap[k] <= ptr[next[k]]);
+ }
+ cap[k] = -cap[k];
+ }
+ /* all other vectors should either have zero capacity or be
+ * stored in the right part */
+ for (k = 1; k <= n; k++)
+ { if (cap[k] < 0)
+ { /* k-th vector is stored in the left part */
+ cap[k] = -cap[k];
+ }
+ else if (cap[k] == 0)
+ { /* k-th vector has zero capacity */
+ xassert(ptr[k] == 0);
+ xassert(len[k] == 0);
+ }
+ else /* cap[k] > 0 */
+ { /* k-th vector is stored in the right part */
+ xassert(0 <= len[k] && len[k] <= cap[k]);
+ xassert(r_ptr <= ptr[k] && ptr[k] + cap[k] <= size+1);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* sva_delete_area - delete sparse vector area (SVA)
+*
+* This routine deletes the sparse vector area (SVA) freeing all the
+* memory allocated to it. */
+
+void sva_delete_area(SVA *sva)
+{ tfree(sva->ptr);
+ tfree(sva->len);
+ tfree(sva->cap);
+ tfree(sva->prev);
+ tfree(sva->next);
+ tfree(sva->ind);
+ tfree(sva->val);
+ tfree(sva);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/bflib/sva.h b/test/monniaux/glpk-4.65/src/bflib/sva.h
new file mode 100644
index 00000000..0eab317b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/bflib/sva.h
@@ -0,0 +1,161 @@
+/* sva.h (sparse vector area) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SVA_H
+#define SVA_H
+
+/***********************************************************************
+* Sparse Vector Area (SVA) is a container for sparse vectors. This
+* program object is used mainly on computing factorization, where the
+* sparse vectors are rows and columns of sparse matrices.
+*
+* The SVA storage is a set of locations numbered 1, 2, ..., size,
+* where size is the size of SVA, which is the total number of
+* locations currently allocated. Each location is identified by its
+* pointer p, 1 <= p <= size, and is the pair (ind[p], val[p]), where
+* ind[p] and val[p] are, respectively, the index and value fields used
+* to store the index and numeric value of a particular vector element.
+*
+* Each sparse vector is identified by its reference number k,
+* 1 <= k <= n, where n is the total number of vectors currently stored
+* in SVA, and defined by the triplet (ptr[k], len[k], cap[k]), where:
+* ptr[k] is a pointer to the first location of the vector; len[k] is
+* the vector length, which is the number of its non-zero elements,
+* len[k] >= 0; and cap[k] is the capacity of the vector, which is the
+* total number of adjacent locations allocated to that vector,
+* cap[k] >= len[k]. Thus, non-zero elements of k-th vector are stored
+* in locations ptr[k], ptr[k]+1, ..., ptr[k]+len[k]-1, and locations
+* ptr[k]+len[k], ptr[k]+len[k]+1, ..., ptr[k]+cap[k]-1 are reserved.
+*
+* The SVA storage is divided into three parts as follows:
+*
+* Locations 1, 2, ..., m_ptr-1 constitute the left (dynamic) part of
+* SVA. This part is used to store vectors, whose capacity may change.
+* Note that all vectors stored in the left part are also included in
+* a doubly linked list, where they are ordered by increasing their
+* pointers ptr[k] (this list is needed for efficient implementation
+* of the garbage collector used to defragment the left part of SVA);
+*
+* Locations m_ptr, m_ptr+1, ..., r_ptr-1 are free and constitute the
+* middle (free) part of SVA.
+*
+* Locations r_ptr, r_ptr+1, ..., size constitute the right (static)
+* part of SVA. This part is used to store vectors, whose capacity is
+* not changed. */
+
+typedef struct SVA SVA;
+
+struct SVA
+{ /* sparse vector area */
+ int n_max;
+ /* maximal value of n (enlarged automatically) */
+ int n;
+ /* number of currently allocated vectors, 0 <= n <= n_max */
+ int *ptr; /* int ptr[1+n_max]; */
+ /* ptr[0] is not used;
+ * ptr[k], 1 <= i <= n, is pointer to first location of k-th
+ * vector in the arrays ind and val */
+ int *len; /* int len[1+n_max]; */
+ /* len[0] is not used;
+ * len[k], 1 <= k <= n, is length of k-th vector, len[k] >= 0 */
+ int *cap; /* int cap[1+n_max]; */
+ /* cap[0] is not used;
+ * cap[k], 1 <= k <= n, is capacity of k-th vector (the number
+ * of adjacent locations allocated to it), cap[k] >= len[k] */
+ /* NOTE: if cap[k] = 0, then ptr[k] = 0 and len[k] = 0 */
+ int size;
+ /* total number of locations in SVA */
+ int m_ptr, r_ptr;
+ /* partitioning pointers that define the left, middle, and right
+ * parts of SVA (see above); 1 <= m_ptr <= r_ptr <= size+1 */
+ int head;
+ /* number of first (leftmost) vector in the linked list */
+ int tail;
+ /* number of last (rightmost) vector in the linked list */
+ int *prev; /* int prev[1+n_max]; */
+ /* prev[0] is not used;
+ * prev[k] is number of vector which precedes k-th vector in the
+ * linked list;
+ * prev[k] < 0 means that k-th vector is not in the list */
+ int *next; /* int next[1+n_max]; */
+ /* next[0] is not used;
+ * next[k] is number of vector which succedes k-th vector in the
+ * linked list;
+ * next[k] < 0 means that k-th vector is not in the list */
+ /* NOTE: only vectors having non-zero capacity and stored in the
+ * left part of SVA are included in this linked list */
+ int *ind; /* int ind[1+size]; */
+ /* ind[0] is not used;
+ * ind[p], 1 <= p <= size, is index field of location p */
+ double *val; /* double val[1+size]; */
+ /* val[0] is not used;
+ * val[p], 1 <= p <= size, is value field of location p */
+#if 1
+ int talky;
+ /* option to enable talky mode */
+#endif
+};
+
+#define sva_create_area _glp_sva_create_area
+SVA *sva_create_area(int n_max, int size);
+/* create sparse vector area (SVA) */
+
+#define sva_alloc_vecs _glp_sva_alloc_vecs
+int sva_alloc_vecs(SVA *sva, int nnn);
+/* allocate new vectors in SVA */
+
+#define sva_resize_area _glp_sva_resize_area
+void sva_resize_area(SVA *sva, int delta);
+/* change size of SVA storage */
+
+#define sva_defrag_area _glp_sva_defrag_area
+void sva_defrag_area(SVA *sva);
+/* defragment left part of SVA */
+
+#define sva_more_space _glp_sva_more_space
+void sva_more_space(SVA *sva, int m_size);
+/* increase size of middle (free) part of SVA */
+
+#define sva_enlarge_cap _glp_sva_enlarge_cap
+void sva_enlarge_cap(SVA *sva, int k, int new_cap, int skip);
+/* enlarge capacity of specified vector */
+
+#define sva_reserve_cap _glp_sva_reserve_cap
+void sva_reserve_cap(SVA *sva, int k, int new_cap);
+/* reserve locations for specified vector */
+
+#define sva_make_static _glp_sva_make_static
+void sva_make_static(SVA *sva, int k);
+/* relocate specified vector to right part of SVA */
+
+#define sva_check_area _glp_sva_check_area
+void sva_check_area(SVA *sva);
+/* check sparse vector area (SVA) */
+
+#define sva_delete_area _glp_sva_delete_area
+void sva_delete_area(SVA *sva);
+/* delete sparse vector area (SVA) */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/colamd/COPYING b/test/monniaux/glpk-4.65/src/colamd/COPYING
new file mode 100644
index 00000000..84bba36d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/colamd/COPYING
@@ -0,0 +1,502 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL. It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+ This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it. You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations below.
+
+ When we speak of free software, we are referring to freedom of use,
+not price. Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+ To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights. These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+ For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you. You must make sure that they, too, receive or can get the source
+code. If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it. And you must show them these terms so they know their rights.
+
+ We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+ To protect each distributor, we want to make it very clear that
+there is no warranty for the free library. Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+
+ Finally, software patents pose a constant threat to the existence of
+any free program. We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder. Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+ Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License. This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License. We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+ When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library. The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom. The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+ We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License. It also provides other free software developers Less
+of an advantage over competing non-free programs. These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries. However, the Lesser license provides advantages in certain
+special circumstances.
+
+ For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it becomes
+a de-facto standard. To achieve this, non-free programs must be
+allowed to use the library. A more frequent case is that a free
+library does the same job as widely used non-free libraries. In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+ In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software. For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+ Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+ The precise terms and conditions for copying, distribution and
+modification follow. Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library". The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+
+ GNU LESSER GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+ A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+ The "Library", below, refers to any such software library or work
+which has been distributed under these terms. A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language. (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+ "Source code" for a work means the preferred form of the work for
+making modifications to it. For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control compilation
+and installation of the library.
+
+ Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it). Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+ 1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+ You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+
+ 2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) The modified work must itself be a software library.
+
+ b) You must cause the files modified to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ c) You must cause the whole of the work to be licensed at no
+ charge to all third parties under the terms of this License.
+
+ d) If a facility in the modified Library refers to a function or a
+ table of data to be supplied by an application program that uses
+ the facility, other than as an argument passed when the facility
+ is invoked, then you must make a good faith effort to ensure that,
+ in the event an application does not supply such function or
+ table, the facility still operates, and performs whatever part of
+ its purpose remains meaningful.
+
+ (For example, a function in a library to compute square roots has
+ a purpose that is entirely well-defined independent of the
+ application. Therefore, Subsection 2d requires that any
+ application-supplied function or table used by this function must
+ be optional: if the application does not supply it, the square
+ root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library. To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License. (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.) Do not make any other change in
+these notices.
+
+ Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+ This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+ 4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+ If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library". Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+ However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library". The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+ When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library. The
+threshold for this to be true is not precisely defined by law.
+
+ If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work. (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+ Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+
+ 6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+ You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License. You must supply a copy of this License. If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License. Also, you must do one
+of these things:
+
+ a) Accompany the work with the complete corresponding
+ machine-readable source code for the Library including whatever
+ changes were used in the work (which must be distributed under
+ Sections 1 and 2 above); and, if the work is an executable linked
+ with the Library, with the complete machine-readable "work that
+ uses the Library", as object code and/or source code, so that the
+ user can modify the Library and then relink to produce a modified
+ executable containing the modified Library. (It is understood
+ that the user who changes the contents of definitions files in the
+ Library will not necessarily be able to recompile the application
+ to use the modified definitions.)
+
+ b) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (1) uses at run time a
+ copy of the library already present on the user's computer system,
+ rather than copying library functions into the executable, and (2)
+ will operate properly with a modified version of the library, if
+ the user installs one, as long as the modified version is
+ interface-compatible with the version that the work was made with.
+
+ c) Accompany the work with a written offer, valid for at
+ least three years, to give the same user the materials
+ specified in Subsection 6a, above, for a charge no more
+ than the cost of performing this distribution.
+
+ d) If distribution of the work is made by offering access to copy
+ from a designated place, offer equivalent access to copy the above
+ specified materials from the same place.
+
+ e) Verify that the user has already received a copy of these
+ materials or that you have already sent this user a copy.
+
+ For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it. However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+ It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system. Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+
+ 7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+ a) Accompany the combined library with a copy of the same work
+ based on the Library, uncombined with any other library
+ facilities. This must be distributed under the terms of the
+ Sections above.
+
+ b) Give prominent notice with the combined library of the fact
+ that part of it is a work based on the Library, and explaining
+ where to find the accompanying uncombined form of the same work.
+
+ 8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License. Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License. However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+ 9. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Library or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+ 10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+
+ 11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all. For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under any
+particular circumstance, the balance of the section is intended to apply,
+and the section as a whole is intended to apply in other circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License may add
+an explicit geographical distribution limitation excluding those countries,
+so that distribution is permitted only in or among countries not thus
+excluded. In such case, this License incorporates the limitation as if
+written in the body of this License.
+
+ 13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation. If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+
+ 14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission. For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this. Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+ NO WARRANTY
+
+ 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+ 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Libraries
+
+ If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change. You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms of the
+ordinary General Public License).
+
+ To apply these terms, attach the following notices to the library. It is
+safest to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least the
+"copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the library's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the
+ library `Frob' (a library for tweaking knobs) written by James Random Hacker.
+
+ <signature of Ty Coon>, 1 April 1990
+ Ty Coon, President of Vice
+
+That's all there is to it!
diff --git a/test/monniaux/glpk-4.65/src/colamd/README b/test/monniaux/glpk-4.65/src/colamd/README
new file mode 100644
index 00000000..a365059f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/colamd/README
@@ -0,0 +1,98 @@
+NOTE: Files in this subdirectory are NOT part of the GLPK package, but
+ are used with GLPK.
+
+ The original code was modified according to GLPK requirements by
+ Andrew Makhorin <mao@gnu.org>.
+************************************************************************
+COLAMD/SYMAMD Version 2.7, Copyright (C) 1998-2007, Timothy A. Davis,
+All Rights Reserved.
+
+Description:
+
+ colamd: an approximate minimum degree column ordering algorithm,
+ for LU factorization of symmetric or unsymmetric matrices,
+ QR factorization, least squares, interior point methods for
+ linear programming problems, and other related problems.
+
+ symamd: an approximate minimum degree ordering algorithm for
+ Cholesky factorization of symmetric matrices.
+
+Purpose:
+
+ Colamd computes a permutation Q such that the Cholesky factorization
+ of (AQ)'(AQ) has less fill-in and requires fewer floating point
+ operations than A'A. This also provides a good ordering for sparse
+ partial pivoting methods, P(AQ) = LU, where Q is computed prior to
+ numerical factorization, and P is computed during numerical
+ factorization via conventional partial pivoting with row
+ interchanges. Colamd is the column ordering method used in SuperLU,
+ part of the ScaLAPACK library. It is also available as built-in
+ function in MATLAB Version 6, available from MathWorks, Inc.
+ (http://www.mathworks.com). This routine can be used in place of
+ colmmd in MATLAB.
+
+ Symamd computes a permutation P of a symmetric matrix A such that
+ the Cholesky factorization of PAP' has less fill-in and requires
+ fewer floating point operations than A. Symamd constructs a matrix
+ M such that M'M has the same nonzero pattern of A, and then orders
+ the columns of M using colmmd. The column ordering of M is then
+ returned as the row and column ordering P of A.
+
+Authors:
+
+ The authors of the code itself are Stefan I. Larimore and Timothy A.
+ Davis (davis at cise.ufl.edu), University of Florida. The algorithm
+ was developed in collaboration with John Gilbert, Xerox PARC, and
+ Esmond Ng, Oak Ridge National Laboratory.
+
+Acknowledgements:
+
+ This work was supported by the National Science Foundation, under
+ grants DMS-9504974 and DMS-9803599.
+
+License:
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public License
+ as published by the Free Software Foundation; either version 2.1 of
+ the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
+ USA.
+
+ Permission is hereby granted to use or copy this program under the
+ terms of the GNU LGPL, provided that the Copyright, this License,
+ and the Availability of the original version is retained on all
+ copies. User documentation of any code that uses this code or any
+ modified version of this code must cite the Copyright, this License,
+ the Availability note, and "Used by permission." Permission to
+ modify the code and to distribute modified code is granted, provided
+ the Copyright, this License, and the Availability note are retained,
+ and a notice that the code was modified is included.
+
+ COLAMD is also available under alternate licenses, contact T. Davis
+ for details.
+
+Availability:
+
+ The colamd/symamd library is available at:
+
+ http://www.cise.ufl.edu/research/sparse/colamd/
+
+References:
+
+ T. A. Davis, J. R. Gilbert, S. Larimore, E. Ng, An approximate
+ column minimum degree ordering algorithm, ACM Transactions on
+ Mathematical Software, vol. 30, no. 3., pp. 353-376, 2004.
+
+ T. A. Davis, J. R. Gilbert, S. Larimore, E. Ng, Algorithm 836:
+ COLAMD, an approximate column minimum degree ordering algorithm, ACM
+ Transactions on Mathematical Software, vol. 30, no. 3., pp. 377-380,
+ 2004.
diff --git a/test/monniaux/glpk-4.65/src/colamd/colamd.c b/test/monniaux/glpk-4.65/src/colamd/colamd.c
new file mode 100644
index 00000000..86ddd6b7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/colamd/colamd.c
@@ -0,0 +1,3622 @@
+/* ========================================================================== */
+/* === colamd/symamd - a sparse matrix column ordering algorithm ============ */
+/* ========================================================================== */
+
+/* COLAMD / SYMAMD
+
+ colamd: an approximate minimum degree column ordering algorithm,
+ for LU factorization of symmetric or unsymmetric matrices,
+ QR factorization, least squares, interior point methods for
+ linear programming problems, and other related problems.
+
+ symamd: an approximate minimum degree ordering algorithm for Cholesky
+ factorization of symmetric matrices.
+
+ Purpose:
+
+ Colamd computes a permutation Q such that the Cholesky factorization of
+ (AQ)'(AQ) has less fill-in and requires fewer floating point operations
+ than A'A. This also provides a good ordering for sparse partial
+ pivoting methods, P(AQ) = LU, where Q is computed prior to numerical
+ factorization, and P is computed during numerical factorization via
+ conventional partial pivoting with row interchanges. Colamd is the
+ column ordering method used in SuperLU, part of the ScaLAPACK library.
+ It is also available as built-in function in MATLAB Version 6,
+ available from MathWorks, Inc. (http://www.mathworks.com). This
+ routine can be used in place of colmmd in MATLAB.
+
+ Symamd computes a permutation P of a symmetric matrix A such that the
+ Cholesky factorization of PAP' has less fill-in and requires fewer
+ floating point operations than A. Symamd constructs a matrix M such
+ that M'M has the same nonzero pattern of A, and then orders the columns
+ of M using colmmd. The column ordering of M is then returned as the
+ row and column ordering P of A.
+
+ Authors:
+
+ The authors of the code itself are Stefan I. Larimore and Timothy A.
+ Davis (davis at cise.ufl.edu), University of Florida. The algorithm was
+ developed in collaboration with John Gilbert, Xerox PARC, and Esmond
+ Ng, Oak Ridge National Laboratory.
+
+ Acknowledgements:
+
+ This work was supported by the National Science Foundation, under
+ grants DMS-9504974 and DMS-9803599.
+
+ Copyright and License:
+
+ Copyright (c) 1998-2007, Timothy A. Davis, All Rights Reserved.
+ COLAMD is also available under alternate licenses, contact T. Davis
+ for details.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301
+ USA
+
+ Permission is hereby granted to use or copy this program under the
+ terms of the GNU LGPL, provided that the Copyright, this License,
+ and the Availability of the original version is retained on all copies.
+ User documentation of any code that uses this code or any modified
+ version of this code must cite the Copyright, this License, the
+ Availability note, and "Used by permission." Permission to modify
+ the code and to distribute modified code is granted, provided the
+ Copyright, this License, and the Availability note are retained,
+ and a notice that the code was modified is included.
+
+ Availability:
+
+ The colamd/symamd library is available at
+
+ http://www.cise.ufl.edu/research/sparse/colamd/
+
+ This is the http://www.cise.ufl.edu/research/sparse/colamd/colamd.c
+ file. It requires the colamd.h file. It is required by the colamdmex.c
+ and symamdmex.c files, for the MATLAB interface to colamd and symamd.
+ Appears as ACM Algorithm 836.
+
+ See the ChangeLog file for changes since Version 1.0.
+
+ References:
+
+ T. A. Davis, J. R. Gilbert, S. Larimore, E. Ng, An approximate column
+ minimum degree ordering algorithm, ACM Transactions on Mathematical
+ Software, vol. 30, no. 3., pp. 353-376, 2004.
+
+ T. A. Davis, J. R. Gilbert, S. Larimore, E. Ng, Algorithm 836: COLAMD,
+ an approximate column minimum degree ordering algorithm, ACM
+ Transactions on Mathematical Software, vol. 30, no. 3., pp. 377-380,
+ 2004.
+
+*/
+
+/* ========================================================================== */
+/* === Description of user-callable routines ================================ */
+/* ========================================================================== */
+
+/* COLAMD includes both int and UF_long versions of all its routines. The
+ * description below is for the int version. For UF_long, all int arguments
+ * become UF_long. UF_long is normally defined as long, except for WIN64.
+
+ ----------------------------------------------------------------------------
+ colamd_recommended:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ size_t colamd_recommended (int nnz, int n_row, int n_col) ;
+ size_t colamd_l_recommended (UF_long nnz, UF_long n_row,
+ UF_long n_col) ;
+
+ Purpose:
+
+ Returns recommended value of Alen for use by colamd. Returns 0
+ if any input argument is negative. The use of this routine
+ is optional. Not needed for symamd, which dynamically allocates
+ its own memory.
+
+ Note that in v2.4 and earlier, these routines returned int or long.
+ They now return a value of type size_t.
+
+ Arguments (all input arguments):
+
+ int nnz ; Number of nonzeros in the matrix A. This must
+ be the same value as p [n_col] in the call to
+ colamd - otherwise you will get a wrong value
+ of the recommended memory to use.
+
+ int n_row ; Number of rows in the matrix A.
+
+ int n_col ; Number of columns in the matrix A.
+
+ ----------------------------------------------------------------------------
+ colamd_set_defaults:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ colamd_set_defaults (double knobs [COLAMD_KNOBS]) ;
+ colamd_l_set_defaults (double knobs [COLAMD_KNOBS]) ;
+
+ Purpose:
+
+ Sets the default parameters. The use of this routine is optional.
+
+ Arguments:
+
+ double knobs [COLAMD_KNOBS] ; Output only.
+
+ NOTE: the meaning of the dense row/col knobs has changed in v2.4
+
+ knobs [0] and knobs [1] control dense row and col detection:
+
+ Colamd: rows with more than
+ max (16, knobs [COLAMD_DENSE_ROW] * sqrt (n_col))
+ entries are removed prior to ordering. Columns with more than
+ max (16, knobs [COLAMD_DENSE_COL] * sqrt (MIN (n_row,n_col)))
+ entries are removed prior to
+ ordering, and placed last in the output column ordering.
+
+ Symamd: uses only knobs [COLAMD_DENSE_ROW], which is knobs [0].
+ Rows and columns with more than
+ max (16, knobs [COLAMD_DENSE_ROW] * sqrt (n))
+ entries are removed prior to ordering, and placed last in the
+ output ordering.
+
+ COLAMD_DENSE_ROW and COLAMD_DENSE_COL are defined as 0 and 1,
+ respectively, in colamd.h. Default values of these two knobs
+ are both 10. Currently, only knobs [0] and knobs [1] are
+ used, but future versions may use more knobs. If so, they will
+ be properly set to their defaults by the future version of
+ colamd_set_defaults, so that the code that calls colamd will
+ not need to change, assuming that you either use
+ colamd_set_defaults, or pass a (double *) NULL pointer as the
+ knobs array to colamd or symamd.
+
+ knobs [2]: aggressive absorption
+
+ knobs [COLAMD_AGGRESSIVE] controls whether or not to do
+ aggressive absorption during the ordering. Default is TRUE.
+
+
+ ----------------------------------------------------------------------------
+ colamd:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ int colamd (int n_row, int n_col, int Alen, int *A, int *p,
+ double knobs [COLAMD_KNOBS], int stats [COLAMD_STATS]) ;
+ UF_long colamd_l (UF_long n_row, UF_long n_col, UF_long Alen,
+ UF_long *A, UF_long *p, double knobs [COLAMD_KNOBS],
+ UF_long stats [COLAMD_STATS]) ;
+
+ Purpose:
+
+ Computes a column ordering (Q) of A such that P(AQ)=LU or
+ (AQ)'AQ=LL' have less fill-in and require fewer floating point
+ operations than factorizing the unpermuted matrix A or A'A,
+ respectively.
+
+ Returns:
+
+ TRUE (1) if successful, FALSE (0) otherwise.
+
+ Arguments:
+
+ int n_row ; Input argument.
+
+ Number of rows in the matrix A.
+ Restriction: n_row >= 0.
+ Colamd returns FALSE if n_row is negative.
+
+ int n_col ; Input argument.
+
+ Number of columns in the matrix A.
+ Restriction: n_col >= 0.
+ Colamd returns FALSE if n_col is negative.
+
+ int Alen ; Input argument.
+
+ Restriction (see note):
+ Alen >= 2*nnz + 6*(n_col+1) + 4*(n_row+1) + n_col
+ Colamd returns FALSE if these conditions are not met.
+
+ Note: this restriction makes an modest assumption regarding
+ the size of the two typedef's structures in colamd.h.
+ We do, however, guarantee that
+
+ Alen >= colamd_recommended (nnz, n_row, n_col)
+
+ will be sufficient. Note: the macro version does not check
+ for integer overflow, and thus is not recommended. Use
+ the colamd_recommended routine instead.
+
+ int A [Alen] ; Input argument, undefined on output.
+
+ A is an integer array of size Alen. Alen must be at least as
+ large as the bare minimum value given above, but this is very
+ low, and can result in excessive run time. For best
+ performance, we recommend that Alen be greater than or equal to
+ colamd_recommended (nnz, n_row, n_col), which adds
+ nnz/5 to the bare minimum value given above.
+
+ On input, the row indices of the entries in column c of the
+ matrix are held in A [(p [c]) ... (p [c+1]-1)]. The row indices
+ in a given column c need not be in ascending order, and
+ duplicate row indices may be be present. However, colamd will
+ work a little faster if both of these conditions are met
+ (Colamd puts the matrix into this format, if it finds that the
+ the conditions are not met).
+
+ The matrix is 0-based. That is, rows are in the range 0 to
+ n_row-1, and columns are in the range 0 to n_col-1. Colamd
+ returns FALSE if any row index is out of range.
+
+ The contents of A are modified during ordering, and are
+ undefined on output.
+
+ int p [n_col+1] ; Both input and output argument.
+
+ p is an integer array of size n_col+1. On input, it holds the
+ "pointers" for the column form of the matrix A. Column c of
+ the matrix A is held in A [(p [c]) ... (p [c+1]-1)]. The first
+ entry, p [0], must be zero, and p [c] <= p [c+1] must hold
+ for all c in the range 0 to n_col-1. The value p [n_col] is
+ thus the total number of entries in the pattern of the matrix A.
+ Colamd returns FALSE if these conditions are not met.
+
+ On output, if colamd returns TRUE, the array p holds the column
+ permutation (Q, for P(AQ)=LU or (AQ)'(AQ)=LL'), where p [0] is
+ the first column index in the new ordering, and p [n_col-1] is
+ the last. That is, p [k] = j means that column j of A is the
+ kth pivot column, in AQ, where k is in the range 0 to n_col-1
+ (p [0] = j means that column j of A is the first column in AQ).
+
+ If colamd returns FALSE, then no permutation is returned, and
+ p is undefined on output.
+
+ double knobs [COLAMD_KNOBS] ; Input argument.
+
+ See colamd_set_defaults for a description.
+
+ int stats [COLAMD_STATS] ; Output argument.
+
+ Statistics on the ordering, and error status.
+ See colamd.h for related definitions.
+ Colamd returns FALSE if stats is not present.
+
+ stats [0]: number of dense or empty rows ignored.
+
+ stats [1]: number of dense or empty columns ignored (and
+ ordered last in the output permutation p)
+ Note that a row can become "empty" if it
+ contains only "dense" and/or "empty" columns,
+ and similarly a column can become "empty" if it
+ only contains "dense" and/or "empty" rows.
+
+ stats [2]: number of garbage collections performed.
+ This can be excessively high if Alen is close
+ to the minimum required value.
+
+ stats [3]: status code. < 0 is an error code.
+ > 1 is a warning or notice.
+
+ 0 OK. Each column of the input matrix contained
+ row indices in increasing order, with no
+ duplicates.
+
+ 1 OK, but columns of input matrix were jumbled
+ (unsorted columns or duplicate entries). Colamd
+ had to do some extra work to sort the matrix
+ first and remove duplicate entries, but it
+ still was able to return a valid permutation
+ (return value of colamd was TRUE).
+
+ stats [4]: highest numbered column that
+ is unsorted or has duplicate
+ entries.
+ stats [5]: last seen duplicate or
+ unsorted row index.
+ stats [6]: number of duplicate or
+ unsorted row indices.
+
+ -1 A is a null pointer
+
+ -2 p is a null pointer
+
+ -3 n_row is negative
+
+ stats [4]: n_row
+
+ -4 n_col is negative
+
+ stats [4]: n_col
+
+ -5 number of nonzeros in matrix is negative
+
+ stats [4]: number of nonzeros, p [n_col]
+
+ -6 p [0] is nonzero
+
+ stats [4]: p [0]
+
+ -7 A is too small
+
+ stats [4]: required size
+ stats [5]: actual size (Alen)
+
+ -8 a column has a negative number of entries
+
+ stats [4]: column with < 0 entries
+ stats [5]: number of entries in col
+
+ -9 a row index is out of bounds
+
+ stats [4]: column with bad row index
+ stats [5]: bad row index
+ stats [6]: n_row, # of rows of matrx
+
+ -10 (unused; see symamd.c)
+
+ -999 (unused; see symamd.c)
+
+ Future versions may return more statistics in the stats array.
+
+ Example:
+
+ See http://www.cise.ufl.edu/research/sparse/colamd/example.c
+ for a complete example.
+
+ To order the columns of a 5-by-4 matrix with 11 nonzero entries in
+ the following nonzero pattern
+
+ x 0 x 0
+ x 0 x x
+ 0 x x 0
+ 0 0 x x
+ x x 0 0
+
+ with default knobs and no output statistics, do the following:
+
+ #include "colamd.h"
+ #define ALEN 100
+ int A [ALEN] = {0, 1, 4, 2, 4, 0, 1, 2, 3, 1, 3} ;
+ int p [ ] = {0, 3, 5, 9, 11} ;
+ int stats [COLAMD_STATS] ;
+ colamd (5, 4, ALEN, A, p, (double *) NULL, stats) ;
+
+ The permutation is returned in the array p, and A is destroyed.
+
+ ----------------------------------------------------------------------------
+ symamd:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ int symamd (int n, int *A, int *p, int *perm,
+ double knobs [COLAMD_KNOBS], int stats [COLAMD_STATS],
+ void (*allocate) (size_t, size_t), void (*release) (void *)) ;
+ UF_long symamd_l (UF_long n, UF_long *A, UF_long *p, UF_long *perm,
+ double knobs [COLAMD_KNOBS], UF_long stats [COLAMD_STATS],
+ void (*allocate) (size_t, size_t), void (*release) (void *)) ;
+
+ Purpose:
+
+ The symamd routine computes an ordering P of a symmetric sparse
+ matrix A such that the Cholesky factorization PAP' = LL' remains
+ sparse. It is based on a column ordering of a matrix M constructed
+ so that the nonzero pattern of M'M is the same as A. The matrix A
+ is assumed to be symmetric; only the strictly lower triangular part
+ is accessed. You must pass your selected memory allocator (usually
+ calloc/free or mxCalloc/mxFree) to symamd, for it to allocate
+ memory for the temporary matrix M.
+
+ Returns:
+
+ TRUE (1) if successful, FALSE (0) otherwise.
+
+ Arguments:
+
+ int n ; Input argument.
+
+ Number of rows and columns in the symmetrix matrix A.
+ Restriction: n >= 0.
+ Symamd returns FALSE if n is negative.
+
+ int A [nnz] ; Input argument.
+
+ A is an integer array of size nnz, where nnz = p [n].
+
+ The row indices of the entries in column c of the matrix are
+ held in A [(p [c]) ... (p [c+1]-1)]. The row indices in a
+ given column c need not be in ascending order, and duplicate
+ row indices may be present. However, symamd will run faster
+ if the columns are in sorted order with no duplicate entries.
+
+ The matrix is 0-based. That is, rows are in the range 0 to
+ n-1, and columns are in the range 0 to n-1. Symamd
+ returns FALSE if any row index is out of range.
+
+ The contents of A are not modified.
+
+ int p [n+1] ; Input argument.
+
+ p is an integer array of size n+1. On input, it holds the
+ "pointers" for the column form of the matrix A. Column c of
+ the matrix A is held in A [(p [c]) ... (p [c+1]-1)]. The first
+ entry, p [0], must be zero, and p [c] <= p [c+1] must hold
+ for all c in the range 0 to n-1. The value p [n] is
+ thus the total number of entries in the pattern of the matrix A.
+ Symamd returns FALSE if these conditions are not met.
+
+ The contents of p are not modified.
+
+ int perm [n+1] ; Output argument.
+
+ On output, if symamd returns TRUE, the array perm holds the
+ permutation P, where perm [0] is the first index in the new
+ ordering, and perm [n-1] is the last. That is, perm [k] = j
+ means that row and column j of A is the kth column in PAP',
+ where k is in the range 0 to n-1 (perm [0] = j means
+ that row and column j of A are the first row and column in
+ PAP'). The array is used as a workspace during the ordering,
+ which is why it must be of length n+1, not just n.
+
+ double knobs [COLAMD_KNOBS] ; Input argument.
+
+ See colamd_set_defaults for a description.
+
+ int stats [COLAMD_STATS] ; Output argument.
+
+ Statistics on the ordering, and error status.
+ See colamd.h for related definitions.
+ Symamd returns FALSE if stats is not present.
+
+ stats [0]: number of dense or empty row and columns ignored
+ (and ordered last in the output permutation
+ perm). Note that a row/column can become
+ "empty" if it contains only "dense" and/or
+ "empty" columns/rows.
+
+ stats [1]: (same as stats [0])
+
+ stats [2]: number of garbage collections performed.
+
+ stats [3]: status code. < 0 is an error code.
+ > 1 is a warning or notice.
+
+ 0 OK. Each column of the input matrix contained
+ row indices in increasing order, with no
+ duplicates.
+
+ 1 OK, but columns of input matrix were jumbled
+ (unsorted columns or duplicate entries). Symamd
+ had to do some extra work to sort the matrix
+ first and remove duplicate entries, but it
+ still was able to return a valid permutation
+ (return value of symamd was TRUE).
+
+ stats [4]: highest numbered column that
+ is unsorted or has duplicate
+ entries.
+ stats [5]: last seen duplicate or
+ unsorted row index.
+ stats [6]: number of duplicate or
+ unsorted row indices.
+
+ -1 A is a null pointer
+
+ -2 p is a null pointer
+
+ -3 (unused, see colamd.c)
+
+ -4 n is negative
+
+ stats [4]: n
+
+ -5 number of nonzeros in matrix is negative
+
+ stats [4]: # of nonzeros (p [n]).
+
+ -6 p [0] is nonzero
+
+ stats [4]: p [0]
+
+ -7 (unused)
+
+ -8 a column has a negative number of entries
+
+ stats [4]: column with < 0 entries
+ stats [5]: number of entries in col
+
+ -9 a row index is out of bounds
+
+ stats [4]: column with bad row index
+ stats [5]: bad row index
+ stats [6]: n_row, # of rows of matrx
+
+ -10 out of memory (unable to allocate temporary
+ workspace for M or count arrays using the
+ "allocate" routine passed into symamd).
+
+ Future versions may return more statistics in the stats array.
+
+ void * (*allocate) (size_t, size_t)
+
+ A pointer to a function providing memory allocation. The
+ allocated memory must be returned initialized to zero. For a
+ C application, this argument should normally be a pointer to
+ calloc. For a MATLAB mexFunction, the routine mxCalloc is
+ passed instead.
+
+ void (*release) (size_t, size_t)
+
+ A pointer to a function that frees memory allocated by the
+ memory allocation routine above. For a C application, this
+ argument should normally be a pointer to free. For a MATLAB
+ mexFunction, the routine mxFree is passed instead.
+
+
+ ----------------------------------------------------------------------------
+ colamd_report:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ colamd_report (int stats [COLAMD_STATS]) ;
+ colamd_l_report (UF_long stats [COLAMD_STATS]) ;
+
+ Purpose:
+
+ Prints the error status and statistics recorded in the stats
+ array on the standard error output (for a standard C routine)
+ or on the MATLAB output (for a mexFunction).
+
+ Arguments:
+
+ int stats [COLAMD_STATS] ; Input only. Statistics from colamd.
+
+
+ ----------------------------------------------------------------------------
+ symamd_report:
+ ----------------------------------------------------------------------------
+
+ C syntax:
+
+ #include "colamd.h"
+ symamd_report (int stats [COLAMD_STATS]) ;
+ symamd_l_report (UF_long stats [COLAMD_STATS]) ;
+
+ Purpose:
+
+ Prints the error status and statistics recorded in the stats
+ array on the standard error output (for a standard C routine)
+ or on the MATLAB output (for a mexFunction).
+
+ Arguments:
+
+ int stats [COLAMD_STATS] ; Input only. Statistics from symamd.
+
+
+*/
+
+/* ========================================================================== */
+/* === Scaffolding code definitions ======================================== */
+/* ========================================================================== */
+
+/* Ensure that debugging is turned off: */
+#ifndef NDEBUG
+#define NDEBUG
+#endif
+
+/* turn on debugging by uncommenting the following line
+ #undef NDEBUG
+*/
+
+/*
+ Our "scaffolding code" philosophy: In our opinion, well-written library
+ code should keep its "debugging" code, and just normally have it turned off
+ by the compiler so as not to interfere with performance. This serves
+ several purposes:
+
+ (1) assertions act as comments to the reader, telling you what the code
+ expects at that point. All assertions will always be true (unless
+ there really is a bug, of course).
+
+ (2) leaving in the scaffolding code assists anyone who would like to modify
+ the code, or understand the algorithm (by reading the debugging output,
+ one can get a glimpse into what the code is doing).
+
+ (3) (gasp!) for actually finding bugs. This code has been heavily tested
+ and "should" be fully functional and bug-free ... but you never know...
+
+ The code will become outrageously slow when debugging is
+ enabled. To control the level of debugging output, set an environment
+ variable D to 0 (little), 1 (some), 2, 3, or 4 (lots). When debugging,
+ you should see the following message on the standard output:
+
+ colamd: debug version, D = 1 (THIS WILL BE SLOW!)
+
+ or a similar message for symamd. If you don't, then debugging has not
+ been enabled.
+
+*/
+
+/* ========================================================================== */
+/* === Include files ======================================================== */
+/* ========================================================================== */
+
+#include "colamd.h"
+
+#if 0 /* by mao */
+#include <limits.h>
+#include <math.h>
+
+#ifdef MATLAB_MEX_FILE
+#include "mex.h"
+#include "matrix.h"
+#endif /* MATLAB_MEX_FILE */
+
+#if !defined (NPRINT) || !defined (NDEBUG)
+#include <stdio.h>
+#endif
+
+#ifndef NULL
+#define NULL ((void *) 0)
+#endif
+#endif
+
+/* ========================================================================== */
+/* === int or UF_long ======================================================= */
+/* ========================================================================== */
+
+#if 0 /* by mao */
+/* define UF_long */
+#include "UFconfig.h"
+#endif
+
+#ifdef DLONG
+
+#define Int UF_long
+#define ID UF_long_id
+#define Int_MAX UF_long_max
+
+#define COLAMD_recommended colamd_l_recommended
+#define COLAMD_set_defaults colamd_l_set_defaults
+#define COLAMD_MAIN colamd_l
+#define SYMAMD_MAIN symamd_l
+#define COLAMD_report colamd_l_report
+#define SYMAMD_report symamd_l_report
+
+#else
+
+#define Int int
+#define ID "%d"
+#define Int_MAX INT_MAX
+
+#define COLAMD_recommended colamd_recommended
+#define COLAMD_set_defaults colamd_set_defaults
+#define COLAMD_MAIN colamd
+#define SYMAMD_MAIN symamd
+#define COLAMD_report colamd_report
+#define SYMAMD_report symamd_report
+
+#endif
+
+/* ========================================================================== */
+/* === Row and Column structures ============================================ */
+/* ========================================================================== */
+
+/* User code that makes use of the colamd/symamd routines need not directly */
+/* reference these structures. They are used only for colamd_recommended. */
+
+typedef struct Colamd_Col_struct
+{
+ Int start ; /* index for A of first row in this column, or DEAD */
+ /* if column is dead */
+ Int length ; /* number of rows in this column */
+ union
+ {
+ Int thickness ; /* number of original columns represented by this */
+ /* col, if the column is alive */
+ Int parent ; /* parent in parent tree super-column structure, if */
+ /* the column is dead */
+ } shared1 ;
+ union
+ {
+ Int score ; /* the score used to maintain heap, if col is alive */
+ Int order ; /* pivot ordering of this column, if col is dead */
+ } shared2 ;
+ union
+ {
+ Int headhash ; /* head of a hash bucket, if col is at the head of */
+ /* a degree list */
+ Int hash ; /* hash value, if col is not in a degree list */
+ Int prev ; /* previous column in degree list, if col is in a */
+ /* degree list (but not at the head of a degree list) */
+ } shared3 ;
+ union
+ {
+ Int degree_next ; /* next column, if col is in a degree list */
+ Int hash_next ; /* next column, if col is in a hash list */
+ } shared4 ;
+
+} Colamd_Col ;
+
+typedef struct Colamd_Row_struct
+{
+ Int start ; /* index for A of first col in this row */
+ Int length ; /* number of principal columns in this row */
+ union
+ {
+ Int degree ; /* number of principal & non-principal columns in row */
+ Int p ; /* used as a row pointer in init_rows_cols () */
+ } shared1 ;
+ union
+ {
+ Int mark ; /* for computing set differences and marking dead rows*/
+ Int first_column ;/* first column in row (used in garbage collection) */
+ } shared2 ;
+
+} Colamd_Row ;
+
+/* ========================================================================== */
+/* === Definitions ========================================================== */
+/* ========================================================================== */
+
+/* Routines are either PUBLIC (user-callable) or PRIVATE (not user-callable) */
+#define PUBLIC
+#define PRIVATE static
+
+#define DENSE_DEGREE(alpha,n) \
+ ((Int) MAX (16.0, (alpha) * sqrt ((double) (n))))
+
+#define MAX(a,b) (((a) > (b)) ? (a) : (b))
+#define MIN(a,b) (((a) < (b)) ? (a) : (b))
+
+#define ONES_COMPLEMENT(r) (-(r)-1)
+
+/* -------------------------------------------------------------------------- */
+/* Change for version 2.1: define TRUE and FALSE only if not yet defined */
+/* -------------------------------------------------------------------------- */
+
+#ifndef TRUE
+#define TRUE (1)
+#endif
+
+#ifndef FALSE
+#define FALSE (0)
+#endif
+
+/* -------------------------------------------------------------------------- */
+
+#define EMPTY (-1)
+
+/* Row and column status */
+#define ALIVE (0)
+#define DEAD (-1)
+
+/* Column status */
+#define DEAD_PRINCIPAL (-1)
+#define DEAD_NON_PRINCIPAL (-2)
+
+/* Macros for row and column status update and checking. */
+#define ROW_IS_DEAD(r) ROW_IS_MARKED_DEAD (Row[r].shared2.mark)
+#define ROW_IS_MARKED_DEAD(row_mark) (row_mark < ALIVE)
+#define ROW_IS_ALIVE(r) (Row [r].shared2.mark >= ALIVE)
+#define COL_IS_DEAD(c) (Col [c].start < ALIVE)
+#define COL_IS_ALIVE(c) (Col [c].start >= ALIVE)
+#define COL_IS_DEAD_PRINCIPAL(c) (Col [c].start == DEAD_PRINCIPAL)
+#define KILL_ROW(r) { Row [r].shared2.mark = DEAD ; }
+#define KILL_PRINCIPAL_COL(c) { Col [c].start = DEAD_PRINCIPAL ; }
+#define KILL_NON_PRINCIPAL_COL(c) { Col [c].start = DEAD_NON_PRINCIPAL ; }
+
+/* ========================================================================== */
+/* === Colamd reporting mechanism =========================================== */
+/* ========================================================================== */
+
+#if defined (MATLAB_MEX_FILE) || defined (MATHWORKS)
+/* In MATLAB, matrices are 1-based to the user, but 0-based internally */
+#define INDEX(i) ((i)+1)
+#else
+/* In C, matrices are 0-based and indices are reported as such in *_report */
+#define INDEX(i) (i)
+#endif
+
+/* All output goes through the PRINTF macro. */
+#define PRINTF(params) { if (colamd_printf != NULL) (void) colamd_printf params ; }
+
+/* ========================================================================== */
+/* === Prototypes of PRIVATE routines ======================================= */
+/* ========================================================================== */
+
+PRIVATE Int init_rows_cols
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int p [],
+ Int stats [COLAMD_STATS]
+) ;
+
+PRIVATE void init_scoring
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int head [],
+ double knobs [COLAMD_KNOBS],
+ Int *p_n_row2,
+ Int *p_n_col2,
+ Int *p_max_deg
+) ;
+
+PRIVATE Int find_ordering
+(
+ Int n_row,
+ Int n_col,
+ Int Alen,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int head [],
+ Int n_col2,
+ Int max_deg,
+ Int pfree,
+ Int aggressive
+) ;
+
+PRIVATE void order_children
+(
+ Int n_col,
+ Colamd_Col Col [],
+ Int p []
+) ;
+
+PRIVATE void detect_super_cols
+(
+
+#ifndef NDEBUG
+ Int n_col,
+ Colamd_Row Row [],
+#endif /* NDEBUG */
+
+ Colamd_Col Col [],
+ Int A [],
+ Int head [],
+ Int row_start,
+ Int row_length
+) ;
+
+PRIVATE Int garbage_collection
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int *pfree
+) ;
+
+PRIVATE Int clear_mark
+(
+ Int tag_mark,
+ Int max_mark,
+ Int n_row,
+ Colamd_Row Row []
+) ;
+
+PRIVATE void print_report
+(
+ char *method,
+ Int stats [COLAMD_STATS]
+) ;
+
+/* ========================================================================== */
+/* === Debugging prototypes and definitions ================================= */
+/* ========================================================================== */
+
+#ifndef NDEBUG
+
+#if 0 /* by mao */
+#include <assert.h>
+#endif
+
+/* colamd_debug is the *ONLY* global variable, and is only */
+/* present when debugging */
+
+PRIVATE Int colamd_debug = 0 ; /* debug print level */
+
+#define DEBUG0(params) { PRINTF (params) ; }
+#define DEBUG1(params) { if (colamd_debug >= 1) PRINTF (params) ; }
+#define DEBUG2(params) { if (colamd_debug >= 2) PRINTF (params) ; }
+#define DEBUG3(params) { if (colamd_debug >= 3) PRINTF (params) ; }
+#define DEBUG4(params) { if (colamd_debug >= 4) PRINTF (params) ; }
+
+#if 0 /* by mao */
+#ifdef MATLAB_MEX_FILE
+#define ASSERT(expression) (mxAssert ((expression), ""))
+#else
+#define ASSERT(expression) (assert (expression))
+#endif /* MATLAB_MEX_FILE */
+#else
+#define ASSERT xassert
+#endif
+
+PRIVATE void colamd_get_debug /* gets the debug print level from getenv */
+(
+ char *method
+) ;
+
+PRIVATE void debug_deg_lists
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int head [],
+ Int min_score,
+ Int should,
+ Int max_deg
+) ;
+
+PRIVATE void debug_mark
+(
+ Int n_row,
+ Colamd_Row Row [],
+ Int tag_mark,
+ Int max_mark
+) ;
+
+PRIVATE void debug_matrix
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A []
+) ;
+
+PRIVATE void debug_structures
+(
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int n_col2
+) ;
+
+#else /* NDEBUG */
+
+/* === No debugging ========================================================= */
+
+#define DEBUG0(params) ;
+#define DEBUG1(params) ;
+#define DEBUG2(params) ;
+#define DEBUG3(params) ;
+#define DEBUG4(params) ;
+
+#define ASSERT(expression)
+
+#endif /* NDEBUG */
+
+/* ========================================================================== */
+/* === USER-CALLABLE ROUTINES: ============================================== */
+/* ========================================================================== */
+
+/* ========================================================================== */
+/* === colamd_recommended =================================================== */
+/* ========================================================================== */
+
+/*
+ The colamd_recommended routine returns the suggested size for Alen. This
+ value has been determined to provide good balance between the number of
+ garbage collections and the memory requirements for colamd. If any
+ argument is negative, or if integer overflow occurs, a 0 is returned as an
+ error condition. 2*nnz space is required for the row and column
+ indices of the matrix. COLAMD_C (n_col) + COLAMD_R (n_row) space is
+ required for the Col and Row arrays, respectively, which are internal to
+ colamd (roughly 6*n_col + 4*n_row). An additional n_col space is the
+ minimal amount of "elbow room", and nnz/5 more space is recommended for
+ run time efficiency.
+
+ Alen is approximately 2.2*nnz + 7*n_col + 4*n_row + 10.
+
+ This function is not needed when using symamd.
+*/
+
+/* add two values of type size_t, and check for integer overflow */
+static size_t t_add (size_t a, size_t b, int *ok)
+{
+ (*ok) = (*ok) && ((a + b) >= MAX (a,b)) ;
+ return ((*ok) ? (a + b) : 0) ;
+}
+
+/* compute a*k where k is a small integer, and check for integer overflow */
+static size_t t_mult (size_t a, size_t k, int *ok)
+{
+ size_t i, s = 0 ;
+ for (i = 0 ; i < k ; i++)
+ {
+ s = t_add (s, a, ok) ;
+ }
+ return (s) ;
+}
+
+/* size of the Col and Row structures */
+#define COLAMD_C(n_col,ok) \
+ ((t_mult (t_add (n_col, 1, ok), sizeof (Colamd_Col), ok) / sizeof (Int)))
+
+#define COLAMD_R(n_row,ok) \
+ ((t_mult (t_add (n_row, 1, ok), sizeof (Colamd_Row), ok) / sizeof (Int)))
+
+
+PUBLIC size_t COLAMD_recommended /* returns recommended value of Alen. */
+(
+ /* === Parameters ======================================================= */
+
+ Int nnz, /* number of nonzeros in A */
+ Int n_row, /* number of rows in A */
+ Int n_col /* number of columns in A */
+)
+{
+ size_t s, c, r ;
+ int ok = TRUE ;
+ if (nnz < 0 || n_row < 0 || n_col < 0)
+ {
+ return (0) ;
+ }
+ s = t_mult (nnz, 2, &ok) ; /* 2*nnz */
+ c = COLAMD_C (n_col, &ok) ; /* size of column structures */
+ r = COLAMD_R (n_row, &ok) ; /* size of row structures */
+ s = t_add (s, c, &ok) ;
+ s = t_add (s, r, &ok) ;
+ s = t_add (s, n_col, &ok) ; /* elbow room */
+ s = t_add (s, nnz/5, &ok) ; /* elbow room */
+ ok = ok && (s < Int_MAX) ;
+ return (ok ? s : 0) ;
+}
+
+
+/* ========================================================================== */
+/* === colamd_set_defaults ================================================== */
+/* ========================================================================== */
+
+/*
+ The colamd_set_defaults routine sets the default values of the user-
+ controllable parameters for colamd and symamd:
+
+ Colamd: rows with more than max (16, knobs [0] * sqrt (n_col))
+ entries are removed prior to ordering. Columns with more than
+ max (16, knobs [1] * sqrt (MIN (n_row,n_col))) entries are removed
+ prior to ordering, and placed last in the output column ordering.
+
+ Symamd: Rows and columns with more than max (16, knobs [0] * sqrt (n))
+ entries are removed prior to ordering, and placed last in the
+ output ordering.
+
+ knobs [0] dense row control
+
+ knobs [1] dense column control
+
+ knobs [2] if nonzero, do aggresive absorption
+
+ knobs [3..19] unused, but future versions might use this
+
+*/
+
+PUBLIC void COLAMD_set_defaults
+(
+ /* === Parameters ======================================================= */
+
+ double knobs [COLAMD_KNOBS] /* knob array */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int i ;
+
+ if (!knobs)
+ {
+ return ; /* no knobs to initialize */
+ }
+ for (i = 0 ; i < COLAMD_KNOBS ; i++)
+ {
+ knobs [i] = 0 ;
+ }
+ knobs [COLAMD_DENSE_ROW] = 10 ;
+ knobs [COLAMD_DENSE_COL] = 10 ;
+ knobs [COLAMD_AGGRESSIVE] = TRUE ; /* default: do aggressive absorption*/
+}
+
+
+/* ========================================================================== */
+/* === symamd =============================================================== */
+/* ========================================================================== */
+
+PUBLIC Int SYMAMD_MAIN /* return TRUE if OK, FALSE otherwise */
+(
+ /* === Parameters ======================================================= */
+
+ Int n, /* number of rows and columns of A */
+ Int A [], /* row indices of A */
+ Int p [], /* column pointers of A */
+ Int perm [], /* output permutation, size n+1 */
+ double knobs [COLAMD_KNOBS], /* parameters (uses defaults if NULL) */
+ Int stats [COLAMD_STATS], /* output statistics and error codes */
+ void * (*allocate) (size_t, size_t),
+ /* pointer to calloc (ANSI C) or */
+ /* mxCalloc (for MATLAB mexFunction) */
+ void (*release) (void *)
+ /* pointer to free (ANSI C) or */
+ /* mxFree (for MATLAB mexFunction) */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int *count ; /* length of each column of M, and col pointer*/
+ Int *mark ; /* mark array for finding duplicate entries */
+ Int *M ; /* row indices of matrix M */
+ size_t Mlen ; /* length of M */
+ Int n_row ; /* number of rows in M */
+ Int nnz ; /* number of entries in A */
+ Int i ; /* row index of A */
+ Int j ; /* column index of A */
+ Int k ; /* row index of M */
+ Int mnz ; /* number of nonzeros in M */
+ Int pp ; /* index into a column of A */
+ Int last_row ; /* last row seen in the current column */
+ Int length ; /* number of nonzeros in a column */
+
+ double cknobs [COLAMD_KNOBS] ; /* knobs for colamd */
+ double default_knobs [COLAMD_KNOBS] ; /* default knobs for colamd */
+
+#ifndef NDEBUG
+ colamd_get_debug ("symamd") ;
+#endif /* NDEBUG */
+
+ /* === Check the input arguments ======================================== */
+
+ if (!stats)
+ {
+ DEBUG0 (("symamd: stats not present\n")) ;
+ return (FALSE) ;
+ }
+ for (i = 0 ; i < COLAMD_STATS ; i++)
+ {
+ stats [i] = 0 ;
+ }
+ stats [COLAMD_STATUS] = COLAMD_OK ;
+ stats [COLAMD_INFO1] = -1 ;
+ stats [COLAMD_INFO2] = -1 ;
+
+ if (!A)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_A_not_present ;
+ DEBUG0 (("symamd: A not present\n")) ;
+ return (FALSE) ;
+ }
+
+ if (!p) /* p is not present */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_p_not_present ;
+ DEBUG0 (("symamd: p not present\n")) ;
+ return (FALSE) ;
+ }
+
+ if (n < 0) /* n must be >= 0 */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_ncol_negative ;
+ stats [COLAMD_INFO1] = n ;
+ DEBUG0 (("symamd: n negative %d\n", n)) ;
+ return (FALSE) ;
+ }
+
+ nnz = p [n] ;
+ if (nnz < 0) /* nnz must be >= 0 */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_nnz_negative ;
+ stats [COLAMD_INFO1] = nnz ;
+ DEBUG0 (("symamd: number of entries negative %d\n", nnz)) ;
+ return (FALSE) ;
+ }
+
+ if (p [0] != 0)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_p0_nonzero ;
+ stats [COLAMD_INFO1] = p [0] ;
+ DEBUG0 (("symamd: p[0] not zero %d\n", p [0])) ;
+ return (FALSE) ;
+ }
+
+ /* === If no knobs, set default knobs =================================== */
+
+ if (!knobs)
+ {
+ COLAMD_set_defaults (default_knobs) ;
+ knobs = default_knobs ;
+ }
+
+ /* === Allocate count and mark ========================================== */
+
+ count = (Int *) ((*allocate) (n+1, sizeof (Int))) ;
+ if (!count)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_out_of_memory ;
+ DEBUG0 (("symamd: allocate count (size %d) failed\n", n+1)) ;
+ return (FALSE) ;
+ }
+
+ mark = (Int *) ((*allocate) (n+1, sizeof (Int))) ;
+ if (!mark)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_out_of_memory ;
+ (*release) ((void *) count) ;
+ DEBUG0 (("symamd: allocate mark (size %d) failed\n", n+1)) ;
+ return (FALSE) ;
+ }
+
+ /* === Compute column counts of M, check if A is valid ================== */
+
+ stats [COLAMD_INFO3] = 0 ; /* number of duplicate or unsorted row indices*/
+
+ for (i = 0 ; i < n ; i++)
+ {
+ mark [i] = -1 ;
+ }
+
+ for (j = 0 ; j < n ; j++)
+ {
+ last_row = -1 ;
+
+ length = p [j+1] - p [j] ;
+ if (length < 0)
+ {
+ /* column pointers must be non-decreasing */
+ stats [COLAMD_STATUS] = COLAMD_ERROR_col_length_negative ;
+ stats [COLAMD_INFO1] = j ;
+ stats [COLAMD_INFO2] = length ;
+ (*release) ((void *) count) ;
+ (*release) ((void *) mark) ;
+ DEBUG0 (("symamd: col %d negative length %d\n", j, length)) ;
+ return (FALSE) ;
+ }
+
+ for (pp = p [j] ; pp < p [j+1] ; pp++)
+ {
+ i = A [pp] ;
+ if (i < 0 || i >= n)
+ {
+ /* row index i, in column j, is out of bounds */
+ stats [COLAMD_STATUS] = COLAMD_ERROR_row_index_out_of_bounds ;
+ stats [COLAMD_INFO1] = j ;
+ stats [COLAMD_INFO2] = i ;
+ stats [COLAMD_INFO3] = n ;
+ (*release) ((void *) count) ;
+ (*release) ((void *) mark) ;
+ DEBUG0 (("symamd: row %d col %d out of bounds\n", i, j)) ;
+ return (FALSE) ;
+ }
+
+ if (i <= last_row || mark [i] == j)
+ {
+ /* row index is unsorted or repeated (or both), thus col */
+ /* is jumbled. This is a notice, not an error condition. */
+ stats [COLAMD_STATUS] = COLAMD_OK_BUT_JUMBLED ;
+ stats [COLAMD_INFO1] = j ;
+ stats [COLAMD_INFO2] = i ;
+ (stats [COLAMD_INFO3]) ++ ;
+ DEBUG1 (("symamd: row %d col %d unsorted/duplicate\n", i, j)) ;
+ }
+
+ if (i > j && mark [i] != j)
+ {
+ /* row k of M will contain column indices i and j */
+ count [i]++ ;
+ count [j]++ ;
+ }
+
+ /* mark the row as having been seen in this column */
+ mark [i] = j ;
+
+ last_row = i ;
+ }
+ }
+
+ /* v2.4: removed free(mark) */
+
+ /* === Compute column pointers of M ===================================== */
+
+ /* use output permutation, perm, for column pointers of M */
+ perm [0] = 0 ;
+ for (j = 1 ; j <= n ; j++)
+ {
+ perm [j] = perm [j-1] + count [j-1] ;
+ }
+ for (j = 0 ; j < n ; j++)
+ {
+ count [j] = perm [j] ;
+ }
+
+ /* === Construct M ====================================================== */
+
+ mnz = perm [n] ;
+ n_row = mnz / 2 ;
+ Mlen = COLAMD_recommended (mnz, n_row, n) ;
+ M = (Int *) ((*allocate) (Mlen, sizeof (Int))) ;
+ DEBUG0 (("symamd: M is %d-by-%d with %d entries, Mlen = %g\n",
+ n_row, n, mnz, (double) Mlen)) ;
+
+ if (!M)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_out_of_memory ;
+ (*release) ((void *) count) ;
+ (*release) ((void *) mark) ;
+ DEBUG0 (("symamd: allocate M (size %g) failed\n", (double) Mlen)) ;
+ return (FALSE) ;
+ }
+
+ k = 0 ;
+
+ if (stats [COLAMD_STATUS] == COLAMD_OK)
+ {
+ /* Matrix is OK */
+ for (j = 0 ; j < n ; j++)
+ {
+ ASSERT (p [j+1] - p [j] >= 0) ;
+ for (pp = p [j] ; pp < p [j+1] ; pp++)
+ {
+ i = A [pp] ;
+ ASSERT (i >= 0 && i < n) ;
+ if (i > j)
+ {
+ /* row k of M contains column indices i and j */
+ M [count [i]++] = k ;
+ M [count [j]++] = k ;
+ k++ ;
+ }
+ }
+ }
+ }
+ else
+ {
+ /* Matrix is jumbled. Do not add duplicates to M. Unsorted cols OK. */
+ DEBUG0 (("symamd: Duplicates in A.\n")) ;
+ for (i = 0 ; i < n ; i++)
+ {
+ mark [i] = -1 ;
+ }
+ for (j = 0 ; j < n ; j++)
+ {
+ ASSERT (p [j+1] - p [j] >= 0) ;
+ for (pp = p [j] ; pp < p [j+1] ; pp++)
+ {
+ i = A [pp] ;
+ ASSERT (i >= 0 && i < n) ;
+ if (i > j && mark [i] != j)
+ {
+ /* row k of M contains column indices i and j */
+ M [count [i]++] = k ;
+ M [count [j]++] = k ;
+ k++ ;
+ mark [i] = j ;
+ }
+ }
+ }
+ /* v2.4: free(mark) moved below */
+ }
+
+ /* count and mark no longer needed */
+ (*release) ((void *) count) ;
+ (*release) ((void *) mark) ; /* v2.4: free (mark) moved here */
+ ASSERT (k == n_row) ;
+
+ /* === Adjust the knobs for M =========================================== */
+
+ for (i = 0 ; i < COLAMD_KNOBS ; i++)
+ {
+ cknobs [i] = knobs [i] ;
+ }
+
+ /* there are no dense rows in M */
+ cknobs [COLAMD_DENSE_ROW] = -1 ;
+ cknobs [COLAMD_DENSE_COL] = knobs [COLAMD_DENSE_ROW] ;
+
+ /* === Order the columns of M =========================================== */
+
+ /* v2.4: colamd cannot fail here, so the error check is removed */
+ (void) COLAMD_MAIN (n_row, n, (Int) Mlen, M, perm, cknobs, stats) ;
+
+ /* Note that the output permutation is now in perm */
+
+ /* === get the statistics for symamd from colamd ======================== */
+
+ /* a dense column in colamd means a dense row and col in symamd */
+ stats [COLAMD_DENSE_ROW] = stats [COLAMD_DENSE_COL] ;
+
+ /* === Free M =========================================================== */
+
+ (*release) ((void *) M) ;
+ DEBUG0 (("symamd: done.\n")) ;
+ return (TRUE) ;
+
+}
+
+/* ========================================================================== */
+/* === colamd =============================================================== */
+/* ========================================================================== */
+
+/*
+ The colamd routine computes a column ordering Q of a sparse matrix
+ A such that the LU factorization P(AQ) = LU remains sparse, where P is
+ selected via partial pivoting. The routine can also be viewed as
+ providing a permutation Q such that the Cholesky factorization
+ (AQ)'(AQ) = LL' remains sparse.
+*/
+
+PUBLIC Int COLAMD_MAIN /* returns TRUE if successful, FALSE otherwise*/
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row, /* number of rows in A */
+ Int n_col, /* number of columns in A */
+ Int Alen, /* length of A */
+ Int A [], /* row indices of A */
+ Int p [], /* pointers to columns in A */
+ double knobs [COLAMD_KNOBS],/* parameters (uses defaults if NULL) */
+ Int stats [COLAMD_STATS] /* output statistics and error codes */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int i ; /* loop index */
+ Int nnz ; /* nonzeros in A */
+ size_t Row_size ; /* size of Row [], in integers */
+ size_t Col_size ; /* size of Col [], in integers */
+ size_t need ; /* minimum required length of A */
+ Colamd_Row *Row ; /* pointer into A of Row [0..n_row] array */
+ Colamd_Col *Col ; /* pointer into A of Col [0..n_col] array */
+ Int n_col2 ; /* number of non-dense, non-empty columns */
+ Int n_row2 ; /* number of non-dense, non-empty rows */
+ Int ngarbage ; /* number of garbage collections performed */
+ Int max_deg ; /* maximum row degree */
+ double default_knobs [COLAMD_KNOBS] ; /* default knobs array */
+ Int aggressive ; /* do aggressive absorption */
+ int ok ;
+
+#ifndef NDEBUG
+ colamd_get_debug ("colamd") ;
+#endif /* NDEBUG */
+
+ /* === Check the input arguments ======================================== */
+
+ if (!stats)
+ {
+ DEBUG0 (("colamd: stats not present\n")) ;
+ return (FALSE) ;
+ }
+ for (i = 0 ; i < COLAMD_STATS ; i++)
+ {
+ stats [i] = 0 ;
+ }
+ stats [COLAMD_STATUS] = COLAMD_OK ;
+ stats [COLAMD_INFO1] = -1 ;
+ stats [COLAMD_INFO2] = -1 ;
+
+ if (!A) /* A is not present */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_A_not_present ;
+ DEBUG0 (("colamd: A not present\n")) ;
+ return (FALSE) ;
+ }
+
+ if (!p) /* p is not present */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_p_not_present ;
+ DEBUG0 (("colamd: p not present\n")) ;
+ return (FALSE) ;
+ }
+
+ if (n_row < 0) /* n_row must be >= 0 */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_nrow_negative ;
+ stats [COLAMD_INFO1] = n_row ;
+ DEBUG0 (("colamd: nrow negative %d\n", n_row)) ;
+ return (FALSE) ;
+ }
+
+ if (n_col < 0) /* n_col must be >= 0 */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_ncol_negative ;
+ stats [COLAMD_INFO1] = n_col ;
+ DEBUG0 (("colamd: ncol negative %d\n", n_col)) ;
+ return (FALSE) ;
+ }
+
+ nnz = p [n_col] ;
+ if (nnz < 0) /* nnz must be >= 0 */
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_nnz_negative ;
+ stats [COLAMD_INFO1] = nnz ;
+ DEBUG0 (("colamd: number of entries negative %d\n", nnz)) ;
+ return (FALSE) ;
+ }
+
+ if (p [0] != 0)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_p0_nonzero ;
+ stats [COLAMD_INFO1] = p [0] ;
+ DEBUG0 (("colamd: p[0] not zero %d\n", p [0])) ;
+ return (FALSE) ;
+ }
+
+ /* === If no knobs, set default knobs =================================== */
+
+ if (!knobs)
+ {
+ COLAMD_set_defaults (default_knobs) ;
+ knobs = default_knobs ;
+ }
+
+ aggressive = (knobs [COLAMD_AGGRESSIVE] != FALSE) ;
+
+ /* === Allocate the Row and Col arrays from array A ===================== */
+
+ ok = TRUE ;
+ Col_size = COLAMD_C (n_col, &ok) ; /* size of Col array of structs */
+ Row_size = COLAMD_R (n_row, &ok) ; /* size of Row array of structs */
+
+ /* need = 2*nnz + n_col + Col_size + Row_size ; */
+ need = t_mult (nnz, 2, &ok) ;
+ need = t_add (need, n_col, &ok) ;
+ need = t_add (need, Col_size, &ok) ;
+ need = t_add (need, Row_size, &ok) ;
+
+ if (!ok || need > (size_t) Alen || need > Int_MAX)
+ {
+ /* not enough space in array A to perform the ordering */
+ stats [COLAMD_STATUS] = COLAMD_ERROR_A_too_small ;
+ stats [COLAMD_INFO1] = need ;
+ stats [COLAMD_INFO2] = Alen ;
+ DEBUG0 (("colamd: Need Alen >= %d, given only Alen = %d\n", need,Alen));
+ return (FALSE) ;
+ }
+
+ Alen -= Col_size + Row_size ;
+ Col = (Colamd_Col *) &A [Alen] ;
+ Row = (Colamd_Row *) &A [Alen + Col_size] ;
+
+ /* === Construct the row and column data structures ===================== */
+
+ if (!init_rows_cols (n_row, n_col, Row, Col, A, p, stats))
+ {
+ /* input matrix is invalid */
+ DEBUG0 (("colamd: Matrix invalid\n")) ;
+ return (FALSE) ;
+ }
+
+ /* === Initialize scores, kill dense rows/columns ======================= */
+
+ init_scoring (n_row, n_col, Row, Col, A, p, knobs,
+ &n_row2, &n_col2, &max_deg) ;
+
+ /* === Order the supercolumns =========================================== */
+
+ ngarbage = find_ordering (n_row, n_col, Alen, Row, Col, A, p,
+ n_col2, max_deg, 2*nnz, aggressive) ;
+
+ /* === Order the non-principal columns ================================== */
+
+ order_children (n_col, Col, p) ;
+
+ /* === Return statistics in stats ======================================= */
+
+ stats [COLAMD_DENSE_ROW] = n_row - n_row2 ;
+ stats [COLAMD_DENSE_COL] = n_col - n_col2 ;
+ stats [COLAMD_DEFRAG_COUNT] = ngarbage ;
+ DEBUG0 (("colamd: done.\n")) ;
+ return (TRUE) ;
+}
+
+
+/* ========================================================================== */
+/* === colamd_report ======================================================== */
+/* ========================================================================== */
+
+PUBLIC void COLAMD_report
+(
+ Int stats [COLAMD_STATS]
+)
+{
+ print_report ("colamd", stats) ;
+}
+
+
+/* ========================================================================== */
+/* === symamd_report ======================================================== */
+/* ========================================================================== */
+
+PUBLIC void SYMAMD_report
+(
+ Int stats [COLAMD_STATS]
+)
+{
+ print_report ("symamd", stats) ;
+}
+
+
+
+/* ========================================================================== */
+/* === NON-USER-CALLABLE ROUTINES: ========================================== */
+/* ========================================================================== */
+
+/* There are no user-callable routines beyond this point in the file */
+
+
+/* ========================================================================== */
+/* === init_rows_cols ======================================================= */
+/* ========================================================================== */
+
+/*
+ Takes the column form of the matrix in A and creates the row form of the
+ matrix. Also, row and column attributes are stored in the Col and Row
+ structs. If the columns are un-sorted or contain duplicate row indices,
+ this routine will also sort and remove duplicate row indices from the
+ column form of the matrix. Returns FALSE if the matrix is invalid,
+ TRUE otherwise. Not user-callable.
+*/
+
+PRIVATE Int init_rows_cols /* returns TRUE if OK, or FALSE otherwise */
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row, /* number of rows of A */
+ Int n_col, /* number of columns of A */
+ Colamd_Row Row [], /* of size n_row+1 */
+ Colamd_Col Col [], /* of size n_col+1 */
+ Int A [], /* row indices of A, of size Alen */
+ Int p [], /* pointers to columns in A, of size n_col+1 */
+ Int stats [COLAMD_STATS] /* colamd statistics */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int col ; /* a column index */
+ Int row ; /* a row index */
+ Int *cp ; /* a column pointer */
+ Int *cp_end ; /* a pointer to the end of a column */
+ Int *rp ; /* a row pointer */
+ Int *rp_end ; /* a pointer to the end of a row */
+ Int last_row ; /* previous row */
+
+ /* === Initialize columns, and check column pointers ==================== */
+
+ for (col = 0 ; col < n_col ; col++)
+ {
+ Col [col].start = p [col] ;
+ Col [col].length = p [col+1] - p [col] ;
+
+ if (Col [col].length < 0)
+ {
+ /* column pointers must be non-decreasing */
+ stats [COLAMD_STATUS] = COLAMD_ERROR_col_length_negative ;
+ stats [COLAMD_INFO1] = col ;
+ stats [COLAMD_INFO2] = Col [col].length ;
+ DEBUG0 (("colamd: col %d length %d < 0\n", col, Col [col].length)) ;
+ return (FALSE) ;
+ }
+
+ Col [col].shared1.thickness = 1 ;
+ Col [col].shared2.score = 0 ;
+ Col [col].shared3.prev = EMPTY ;
+ Col [col].shared4.degree_next = EMPTY ;
+ }
+
+ /* p [0..n_col] no longer needed, used as "head" in subsequent routines */
+
+ /* === Scan columns, compute row degrees, and check row indices ========= */
+
+ stats [COLAMD_INFO3] = 0 ; /* number of duplicate or unsorted row indices*/
+
+ for (row = 0 ; row < n_row ; row++)
+ {
+ Row [row].length = 0 ;
+ Row [row].shared2.mark = -1 ;
+ }
+
+ for (col = 0 ; col < n_col ; col++)
+ {
+ last_row = -1 ;
+
+ cp = &A [p [col]] ;
+ cp_end = &A [p [col+1]] ;
+
+ while (cp < cp_end)
+ {
+ row = *cp++ ;
+
+ /* make sure row indices within range */
+ if (row < 0 || row >= n_row)
+ {
+ stats [COLAMD_STATUS] = COLAMD_ERROR_row_index_out_of_bounds ;
+ stats [COLAMD_INFO1] = col ;
+ stats [COLAMD_INFO2] = row ;
+ stats [COLAMD_INFO3] = n_row ;
+ DEBUG0 (("colamd: row %d col %d out of bounds\n", row, col)) ;
+ return (FALSE) ;
+ }
+
+ if (row <= last_row || Row [row].shared2.mark == col)
+ {
+ /* row index are unsorted or repeated (or both), thus col */
+ /* is jumbled. This is a notice, not an error condition. */
+ stats [COLAMD_STATUS] = COLAMD_OK_BUT_JUMBLED ;
+ stats [COLAMD_INFO1] = col ;
+ stats [COLAMD_INFO2] = row ;
+ (stats [COLAMD_INFO3]) ++ ;
+ DEBUG1 (("colamd: row %d col %d unsorted/duplicate\n",row,col));
+ }
+
+ if (Row [row].shared2.mark != col)
+ {
+ Row [row].length++ ;
+ }
+ else
+ {
+ /* this is a repeated entry in the column, */
+ /* it will be removed */
+ Col [col].length-- ;
+ }
+
+ /* mark the row as having been seen in this column */
+ Row [row].shared2.mark = col ;
+
+ last_row = row ;
+ }
+ }
+
+ /* === Compute row pointers ============================================= */
+
+ /* row form of the matrix starts directly after the column */
+ /* form of matrix in A */
+ Row [0].start = p [n_col] ;
+ Row [0].shared1.p = Row [0].start ;
+ Row [0].shared2.mark = -1 ;
+ for (row = 1 ; row < n_row ; row++)
+ {
+ Row [row].start = Row [row-1].start + Row [row-1].length ;
+ Row [row].shared1.p = Row [row].start ;
+ Row [row].shared2.mark = -1 ;
+ }
+
+ /* === Create row form ================================================== */
+
+ if (stats [COLAMD_STATUS] == COLAMD_OK_BUT_JUMBLED)
+ {
+ /* if cols jumbled, watch for repeated row indices */
+ for (col = 0 ; col < n_col ; col++)
+ {
+ cp = &A [p [col]] ;
+ cp_end = &A [p [col+1]] ;
+ while (cp < cp_end)
+ {
+ row = *cp++ ;
+ if (Row [row].shared2.mark != col)
+ {
+ A [(Row [row].shared1.p)++] = col ;
+ Row [row].shared2.mark = col ;
+ }
+ }
+ }
+ }
+ else
+ {
+ /* if cols not jumbled, we don't need the mark (this is faster) */
+ for (col = 0 ; col < n_col ; col++)
+ {
+ cp = &A [p [col]] ;
+ cp_end = &A [p [col+1]] ;
+ while (cp < cp_end)
+ {
+ A [(Row [*cp++].shared1.p)++] = col ;
+ }
+ }
+ }
+
+ /* === Clear the row marks and set row degrees ========================== */
+
+ for (row = 0 ; row < n_row ; row++)
+ {
+ Row [row].shared2.mark = 0 ;
+ Row [row].shared1.degree = Row [row].length ;
+ }
+
+ /* === See if we need to re-create columns ============================== */
+
+ if (stats [COLAMD_STATUS] == COLAMD_OK_BUT_JUMBLED)
+ {
+ DEBUG0 (("colamd: reconstructing column form, matrix jumbled\n")) ;
+
+#ifndef NDEBUG
+ /* make sure column lengths are correct */
+ for (col = 0 ; col < n_col ; col++)
+ {
+ p [col] = Col [col].length ;
+ }
+ for (row = 0 ; row < n_row ; row++)
+ {
+ rp = &A [Row [row].start] ;
+ rp_end = rp + Row [row].length ;
+ while (rp < rp_end)
+ {
+ p [*rp++]-- ;
+ }
+ }
+ for (col = 0 ; col < n_col ; col++)
+ {
+ ASSERT (p [col] == 0) ;
+ }
+ /* now p is all zero (different than when debugging is turned off) */
+#endif /* NDEBUG */
+
+ /* === Compute col pointers ========================================= */
+
+ /* col form of the matrix starts at A [0]. */
+ /* Note, we may have a gap between the col form and the row */
+ /* form if there were duplicate entries, if so, it will be */
+ /* removed upon the first garbage collection */
+ Col [0].start = 0 ;
+ p [0] = Col [0].start ;
+ for (col = 1 ; col < n_col ; col++)
+ {
+ /* note that the lengths here are for pruned columns, i.e. */
+ /* no duplicate row indices will exist for these columns */
+ Col [col].start = Col [col-1].start + Col [col-1].length ;
+ p [col] = Col [col].start ;
+ }
+
+ /* === Re-create col form =========================================== */
+
+ for (row = 0 ; row < n_row ; row++)
+ {
+ rp = &A [Row [row].start] ;
+ rp_end = rp + Row [row].length ;
+ while (rp < rp_end)
+ {
+ A [(p [*rp++])++] = row ;
+ }
+ }
+ }
+
+ /* === Done. Matrix is not (or no longer) jumbled ====================== */
+
+ return (TRUE) ;
+}
+
+
+/* ========================================================================== */
+/* === init_scoring ========================================================= */
+/* ========================================================================== */
+
+/*
+ Kills dense or empty columns and rows, calculates an initial score for
+ each column, and places all columns in the degree lists. Not user-callable.
+*/
+
+PRIVATE void init_scoring
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row, /* number of rows of A */
+ Int n_col, /* number of columns of A */
+ Colamd_Row Row [], /* of size n_row+1 */
+ Colamd_Col Col [], /* of size n_col+1 */
+ Int A [], /* column form and row form of A */
+ Int head [], /* of size n_col+1 */
+ double knobs [COLAMD_KNOBS],/* parameters */
+ Int *p_n_row2, /* number of non-dense, non-empty rows */
+ Int *p_n_col2, /* number of non-dense, non-empty columns */
+ Int *p_max_deg /* maximum row degree */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int c ; /* a column index */
+ Int r, row ; /* a row index */
+ Int *cp ; /* a column pointer */
+ Int deg ; /* degree of a row or column */
+ Int *cp_end ; /* a pointer to the end of a column */
+ Int *new_cp ; /* new column pointer */
+ Int col_length ; /* length of pruned column */
+ Int score ; /* current column score */
+ Int n_col2 ; /* number of non-dense, non-empty columns */
+ Int n_row2 ; /* number of non-dense, non-empty rows */
+ Int dense_row_count ; /* remove rows with more entries than this */
+ Int dense_col_count ; /* remove cols with more entries than this */
+ Int min_score ; /* smallest column score */
+ Int max_deg ; /* maximum row degree */
+ Int next_col ; /* Used to add to degree list.*/
+
+#ifndef NDEBUG
+ Int debug_count ; /* debug only. */
+#endif /* NDEBUG */
+
+ /* === Extract knobs ==================================================== */
+
+ /* Note: if knobs contains a NaN, this is undefined: */
+ if (knobs [COLAMD_DENSE_ROW] < 0)
+ {
+ /* only remove completely dense rows */
+ dense_row_count = n_col-1 ;
+ }
+ else
+ {
+ dense_row_count = DENSE_DEGREE (knobs [COLAMD_DENSE_ROW], n_col) ;
+ }
+ if (knobs [COLAMD_DENSE_COL] < 0)
+ {
+ /* only remove completely dense columns */
+ dense_col_count = n_row-1 ;
+ }
+ else
+ {
+ dense_col_count =
+ DENSE_DEGREE (knobs [COLAMD_DENSE_COL], MIN (n_row, n_col)) ;
+ }
+
+ DEBUG1 (("colamd: densecount: %d %d\n", dense_row_count, dense_col_count)) ;
+ max_deg = 0 ;
+ n_col2 = n_col ;
+ n_row2 = n_row ;
+
+ /* === Kill empty columns =============================================== */
+
+ /* Put the empty columns at the end in their natural order, so that LU */
+ /* factorization can proceed as far as possible. */
+ for (c = n_col-1 ; c >= 0 ; c--)
+ {
+ deg = Col [c].length ;
+ if (deg == 0)
+ {
+ /* this is a empty column, kill and order it last */
+ Col [c].shared2.order = --n_col2 ;
+ KILL_PRINCIPAL_COL (c) ;
+ }
+ }
+ DEBUG1 (("colamd: null columns killed: %d\n", n_col - n_col2)) ;
+
+ /* === Kill dense columns =============================================== */
+
+ /* Put the dense columns at the end, in their natural order */
+ for (c = n_col-1 ; c >= 0 ; c--)
+ {
+ /* skip any dead columns */
+ if (COL_IS_DEAD (c))
+ {
+ continue ;
+ }
+ deg = Col [c].length ;
+ if (deg > dense_col_count)
+ {
+ /* this is a dense column, kill and order it last */
+ Col [c].shared2.order = --n_col2 ;
+ /* decrement the row degrees */
+ cp = &A [Col [c].start] ;
+ cp_end = cp + Col [c].length ;
+ while (cp < cp_end)
+ {
+ Row [*cp++].shared1.degree-- ;
+ }
+ KILL_PRINCIPAL_COL (c) ;
+ }
+ }
+ DEBUG1 (("colamd: Dense and null columns killed: %d\n", n_col - n_col2)) ;
+
+ /* === Kill dense and empty rows ======================================== */
+
+ for (r = 0 ; r < n_row ; r++)
+ {
+ deg = Row [r].shared1.degree ;
+ ASSERT (deg >= 0 && deg <= n_col) ;
+ if (deg > dense_row_count || deg == 0)
+ {
+ /* kill a dense or empty row */
+ KILL_ROW (r) ;
+ --n_row2 ;
+ }
+ else
+ {
+ /* keep track of max degree of remaining rows */
+ max_deg = MAX (max_deg, deg) ;
+ }
+ }
+ DEBUG1 (("colamd: Dense and null rows killed: %d\n", n_row - n_row2)) ;
+
+ /* === Compute initial column scores ==================================== */
+
+ /* At this point the row degrees are accurate. They reflect the number */
+ /* of "live" (non-dense) columns in each row. No empty rows exist. */
+ /* Some "live" columns may contain only dead rows, however. These are */
+ /* pruned in the code below. */
+
+ /* now find the initial matlab score for each column */
+ for (c = n_col-1 ; c >= 0 ; c--)
+ {
+ /* skip dead column */
+ if (COL_IS_DEAD (c))
+ {
+ continue ;
+ }
+ score = 0 ;
+ cp = &A [Col [c].start] ;
+ new_cp = cp ;
+ cp_end = cp + Col [c].length ;
+ while (cp < cp_end)
+ {
+ /* get a row */
+ row = *cp++ ;
+ /* skip if dead */
+ if (ROW_IS_DEAD (row))
+ {
+ continue ;
+ }
+ /* compact the column */
+ *new_cp++ = row ;
+ /* add row's external degree */
+ score += Row [row].shared1.degree - 1 ;
+ /* guard against integer overflow */
+ score = MIN (score, n_col) ;
+ }
+ /* determine pruned column length */
+ col_length = (Int) (new_cp - &A [Col [c].start]) ;
+ if (col_length == 0)
+ {
+ /* a newly-made null column (all rows in this col are "dense" */
+ /* and have already been killed) */
+ DEBUG2 (("Newly null killed: %d\n", c)) ;
+ Col [c].shared2.order = --n_col2 ;
+ KILL_PRINCIPAL_COL (c) ;
+ }
+ else
+ {
+ /* set column length and set score */
+ ASSERT (score >= 0) ;
+ ASSERT (score <= n_col) ;
+ Col [c].length = col_length ;
+ Col [c].shared2.score = score ;
+ }
+ }
+ DEBUG1 (("colamd: Dense, null, and newly-null columns killed: %d\n",
+ n_col-n_col2)) ;
+
+ /* At this point, all empty rows and columns are dead. All live columns */
+ /* are "clean" (containing no dead rows) and simplicial (no supercolumns */
+ /* yet). Rows may contain dead columns, but all live rows contain at */
+ /* least one live column. */
+
+#ifndef NDEBUG
+ debug_structures (n_row, n_col, Row, Col, A, n_col2) ;
+#endif /* NDEBUG */
+
+ /* === Initialize degree lists ========================================== */
+
+#ifndef NDEBUG
+ debug_count = 0 ;
+#endif /* NDEBUG */
+
+ /* clear the hash buckets */
+ for (c = 0 ; c <= n_col ; c++)
+ {
+ head [c] = EMPTY ;
+ }
+ min_score = n_col ;
+ /* place in reverse order, so low column indices are at the front */
+ /* of the lists. This is to encourage natural tie-breaking */
+ for (c = n_col-1 ; c >= 0 ; c--)
+ {
+ /* only add principal columns to degree lists */
+ if (COL_IS_ALIVE (c))
+ {
+ DEBUG4 (("place %d score %d minscore %d ncol %d\n",
+ c, Col [c].shared2.score, min_score, n_col)) ;
+
+ /* === Add columns score to DList =============================== */
+
+ score = Col [c].shared2.score ;
+
+ ASSERT (min_score >= 0) ;
+ ASSERT (min_score <= n_col) ;
+ ASSERT (score >= 0) ;
+ ASSERT (score <= n_col) ;
+ ASSERT (head [score] >= EMPTY) ;
+
+ /* now add this column to dList at proper score location */
+ next_col = head [score] ;
+ Col [c].shared3.prev = EMPTY ;
+ Col [c].shared4.degree_next = next_col ;
+
+ /* if there already was a column with the same score, set its */
+ /* previous pointer to this new column */
+ if (next_col != EMPTY)
+ {
+ Col [next_col].shared3.prev = c ;
+ }
+ head [score] = c ;
+
+ /* see if this score is less than current min */
+ min_score = MIN (min_score, score) ;
+
+#ifndef NDEBUG
+ debug_count++ ;
+#endif /* NDEBUG */
+
+ }
+ }
+
+#ifndef NDEBUG
+ DEBUG1 (("colamd: Live cols %d out of %d, non-princ: %d\n",
+ debug_count, n_col, n_col-debug_count)) ;
+ ASSERT (debug_count == n_col2) ;
+ debug_deg_lists (n_row, n_col, Row, Col, head, min_score, n_col2, max_deg) ;
+#endif /* NDEBUG */
+
+ /* === Return number of remaining columns, and max row degree =========== */
+
+ *p_n_col2 = n_col2 ;
+ *p_n_row2 = n_row2 ;
+ *p_max_deg = max_deg ;
+}
+
+
+/* ========================================================================== */
+/* === find_ordering ======================================================== */
+/* ========================================================================== */
+
+/*
+ Order the principal columns of the supercolumn form of the matrix
+ (no supercolumns on input). Uses a minimum approximate column minimum
+ degree ordering method. Not user-callable.
+*/
+
+PRIVATE Int find_ordering /* return the number of garbage collections */
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row, /* number of rows of A */
+ Int n_col, /* number of columns of A */
+ Int Alen, /* size of A, 2*nnz + n_col or larger */
+ Colamd_Row Row [], /* of size n_row+1 */
+ Colamd_Col Col [], /* of size n_col+1 */
+ Int A [], /* column form and row form of A */
+ Int head [], /* of size n_col+1 */
+ Int n_col2, /* Remaining columns to order */
+ Int max_deg, /* Maximum row degree */
+ Int pfree, /* index of first free slot (2*nnz on entry) */
+ Int aggressive
+)
+{
+ /* === Local variables ================================================== */
+
+ Int k ; /* current pivot ordering step */
+ Int pivot_col ; /* current pivot column */
+ Int *cp ; /* a column pointer */
+ Int *rp ; /* a row pointer */
+ Int pivot_row ; /* current pivot row */
+ Int *new_cp ; /* modified column pointer */
+ Int *new_rp ; /* modified row pointer */
+ Int pivot_row_start ; /* pointer to start of pivot row */
+ Int pivot_row_degree ; /* number of columns in pivot row */
+ Int pivot_row_length ; /* number of supercolumns in pivot row */
+ Int pivot_col_score ; /* score of pivot column */
+ Int needed_memory ; /* free space needed for pivot row */
+ Int *cp_end ; /* pointer to the end of a column */
+ Int *rp_end ; /* pointer to the end of a row */
+ Int row ; /* a row index */
+ Int col ; /* a column index */
+ Int max_score ; /* maximum possible score */
+ Int cur_score ; /* score of current column */
+ unsigned Int hash ; /* hash value for supernode detection */
+ Int head_column ; /* head of hash bucket */
+ Int first_col ; /* first column in hash bucket */
+ Int tag_mark ; /* marker value for mark array */
+ Int row_mark ; /* Row [row].shared2.mark */
+ Int set_difference ; /* set difference size of row with pivot row */
+ Int min_score ; /* smallest column score */
+ Int col_thickness ; /* "thickness" (no. of columns in a supercol) */
+ Int max_mark ; /* maximum value of tag_mark */
+ Int pivot_col_thickness ; /* number of columns represented by pivot col */
+ Int prev_col ; /* Used by Dlist operations. */
+ Int next_col ; /* Used by Dlist operations. */
+ Int ngarbage ; /* number of garbage collections performed */
+
+#ifndef NDEBUG
+ Int debug_d ; /* debug loop counter */
+ Int debug_step = 0 ; /* debug loop counter */
+#endif /* NDEBUG */
+
+ /* === Initialization and clear mark ==================================== */
+
+ max_mark = INT_MAX - n_col ; /* INT_MAX defined in <limits.h> */
+ tag_mark = clear_mark (0, max_mark, n_row, Row) ;
+ min_score = 0 ;
+ ngarbage = 0 ;
+ DEBUG1 (("colamd: Ordering, n_col2=%d\n", n_col2)) ;
+
+ /* === Order the columns ================================================ */
+
+ for (k = 0 ; k < n_col2 ; /* 'k' is incremented below */)
+ {
+
+#ifndef NDEBUG
+ if (debug_step % 100 == 0)
+ {
+ DEBUG2 (("\n... Step k: %d out of n_col2: %d\n", k, n_col2)) ;
+ }
+ else
+ {
+ DEBUG3 (("\n----------Step k: %d out of n_col2: %d\n", k, n_col2)) ;
+ }
+ debug_step++ ;
+ debug_deg_lists (n_row, n_col, Row, Col, head,
+ min_score, n_col2-k, max_deg) ;
+ debug_matrix (n_row, n_col, Row, Col, A) ;
+#endif /* NDEBUG */
+
+ /* === Select pivot column, and order it ============================ */
+
+ /* make sure degree list isn't empty */
+ ASSERT (min_score >= 0) ;
+ ASSERT (min_score <= n_col) ;
+ ASSERT (head [min_score] >= EMPTY) ;
+
+#ifndef NDEBUG
+ for (debug_d = 0 ; debug_d < min_score ; debug_d++)
+ {
+ ASSERT (head [debug_d] == EMPTY) ;
+ }
+#endif /* NDEBUG */
+
+ /* get pivot column from head of minimum degree list */
+ while (head [min_score] == EMPTY && min_score < n_col)
+ {
+ min_score++ ;
+ }
+ pivot_col = head [min_score] ;
+ ASSERT (pivot_col >= 0 && pivot_col <= n_col) ;
+ next_col = Col [pivot_col].shared4.degree_next ;
+ head [min_score] = next_col ;
+ if (next_col != EMPTY)
+ {
+ Col [next_col].shared3.prev = EMPTY ;
+ }
+
+ ASSERT (COL_IS_ALIVE (pivot_col)) ;
+
+ /* remember score for defrag check */
+ pivot_col_score = Col [pivot_col].shared2.score ;
+
+ /* the pivot column is the kth column in the pivot order */
+ Col [pivot_col].shared2.order = k ;
+
+ /* increment order count by column thickness */
+ pivot_col_thickness = Col [pivot_col].shared1.thickness ;
+ k += pivot_col_thickness ;
+ ASSERT (pivot_col_thickness > 0) ;
+ DEBUG3 (("Pivot col: %d thick %d\n", pivot_col, pivot_col_thickness)) ;
+
+ /* === Garbage_collection, if necessary ============================= */
+
+ needed_memory = MIN (pivot_col_score, n_col - k) ;
+ if (pfree + needed_memory >= Alen)
+ {
+ pfree = garbage_collection (n_row, n_col, Row, Col, A, &A [pfree]) ;
+ ngarbage++ ;
+ /* after garbage collection we will have enough */
+ ASSERT (pfree + needed_memory < Alen) ;
+ /* garbage collection has wiped out the Row[].shared2.mark array */
+ tag_mark = clear_mark (0, max_mark, n_row, Row) ;
+
+#ifndef NDEBUG
+ debug_matrix (n_row, n_col, Row, Col, A) ;
+#endif /* NDEBUG */
+ }
+
+ /* === Compute pivot row pattern ==================================== */
+
+ /* get starting location for this new merged row */
+ pivot_row_start = pfree ;
+
+ /* initialize new row counts to zero */
+ pivot_row_degree = 0 ;
+
+ /* tag pivot column as having been visited so it isn't included */
+ /* in merged pivot row */
+ Col [pivot_col].shared1.thickness = -pivot_col_thickness ;
+
+ /* pivot row is the union of all rows in the pivot column pattern */
+ cp = &A [Col [pivot_col].start] ;
+ cp_end = cp + Col [pivot_col].length ;
+ while (cp < cp_end)
+ {
+ /* get a row */
+ row = *cp++ ;
+ DEBUG4 (("Pivot col pattern %d %d\n", ROW_IS_ALIVE (row), row)) ;
+ /* skip if row is dead */
+ if (ROW_IS_ALIVE (row))
+ {
+ rp = &A [Row [row].start] ;
+ rp_end = rp + Row [row].length ;
+ while (rp < rp_end)
+ {
+ /* get a column */
+ col = *rp++ ;
+ /* add the column, if alive and untagged */
+ col_thickness = Col [col].shared1.thickness ;
+ if (col_thickness > 0 && COL_IS_ALIVE (col))
+ {
+ /* tag column in pivot row */
+ Col [col].shared1.thickness = -col_thickness ;
+ ASSERT (pfree < Alen) ;
+ /* place column in pivot row */
+ A [pfree++] = col ;
+ pivot_row_degree += col_thickness ;
+ }
+ }
+ }
+ }
+
+ /* clear tag on pivot column */
+ Col [pivot_col].shared1.thickness = pivot_col_thickness ;
+ max_deg = MAX (max_deg, pivot_row_degree) ;
+
+#ifndef NDEBUG
+ DEBUG3 (("check2\n")) ;
+ debug_mark (n_row, Row, tag_mark, max_mark) ;
+#endif /* NDEBUG */
+
+ /* === Kill all rows used to construct pivot row ==================== */
+
+ /* also kill pivot row, temporarily */
+ cp = &A [Col [pivot_col].start] ;
+ cp_end = cp + Col [pivot_col].length ;
+ while (cp < cp_end)
+ {
+ /* may be killing an already dead row */
+ row = *cp++ ;
+ DEBUG3 (("Kill row in pivot col: %d\n", row)) ;
+ KILL_ROW (row) ;
+ }
+
+ /* === Select a row index to use as the new pivot row =============== */
+
+ pivot_row_length = pfree - pivot_row_start ;
+ if (pivot_row_length > 0)
+ {
+ /* pick the "pivot" row arbitrarily (first row in col) */
+ pivot_row = A [Col [pivot_col].start] ;
+ DEBUG3 (("Pivotal row is %d\n", pivot_row)) ;
+ }
+ else
+ {
+ /* there is no pivot row, since it is of zero length */
+ pivot_row = EMPTY ;
+ ASSERT (pivot_row_length == 0) ;
+ }
+ ASSERT (Col [pivot_col].length > 0 || pivot_row_length == 0) ;
+
+ /* === Approximate degree computation =============================== */
+
+ /* Here begins the computation of the approximate degree. The column */
+ /* score is the sum of the pivot row "length", plus the size of the */
+ /* set differences of each row in the column minus the pattern of the */
+ /* pivot row itself. The column ("thickness") itself is also */
+ /* excluded from the column score (we thus use an approximate */
+ /* external degree). */
+
+ /* The time taken by the following code (compute set differences, and */
+ /* add them up) is proportional to the size of the data structure */
+ /* being scanned - that is, the sum of the sizes of each column in */
+ /* the pivot row. Thus, the amortized time to compute a column score */
+ /* is proportional to the size of that column (where size, in this */
+ /* context, is the column "length", or the number of row indices */
+ /* in that column). The number of row indices in a column is */
+ /* monotonically non-decreasing, from the length of the original */
+ /* column on input to colamd. */
+
+ /* === Compute set differences ====================================== */
+
+ DEBUG3 (("** Computing set differences phase. **\n")) ;
+
+ /* pivot row is currently dead - it will be revived later. */
+
+ DEBUG3 (("Pivot row: ")) ;
+ /* for each column in pivot row */
+ rp = &A [pivot_row_start] ;
+ rp_end = rp + pivot_row_length ;
+ while (rp < rp_end)
+ {
+ col = *rp++ ;
+ ASSERT (COL_IS_ALIVE (col) && col != pivot_col) ;
+ DEBUG3 (("Col: %d\n", col)) ;
+
+ /* clear tags used to construct pivot row pattern */
+ col_thickness = -Col [col].shared1.thickness ;
+ ASSERT (col_thickness > 0) ;
+ Col [col].shared1.thickness = col_thickness ;
+
+ /* === Remove column from degree list =========================== */
+
+ cur_score = Col [col].shared2.score ;
+ prev_col = Col [col].shared3.prev ;
+ next_col = Col [col].shared4.degree_next ;
+ ASSERT (cur_score >= 0) ;
+ ASSERT (cur_score <= n_col) ;
+ ASSERT (cur_score >= EMPTY) ;
+ if (prev_col == EMPTY)
+ {
+ head [cur_score] = next_col ;
+ }
+ else
+ {
+ Col [prev_col].shared4.degree_next = next_col ;
+ }
+ if (next_col != EMPTY)
+ {
+ Col [next_col].shared3.prev = prev_col ;
+ }
+
+ /* === Scan the column ========================================== */
+
+ cp = &A [Col [col].start] ;
+ cp_end = cp + Col [col].length ;
+ while (cp < cp_end)
+ {
+ /* get a row */
+ row = *cp++ ;
+ row_mark = Row [row].shared2.mark ;
+ /* skip if dead */
+ if (ROW_IS_MARKED_DEAD (row_mark))
+ {
+ continue ;
+ }
+ ASSERT (row != pivot_row) ;
+ set_difference = row_mark - tag_mark ;
+ /* check if the row has been seen yet */
+ if (set_difference < 0)
+ {
+ ASSERT (Row [row].shared1.degree <= max_deg) ;
+ set_difference = Row [row].shared1.degree ;
+ }
+ /* subtract column thickness from this row's set difference */
+ set_difference -= col_thickness ;
+ ASSERT (set_difference >= 0) ;
+ /* absorb this row if the set difference becomes zero */
+ if (set_difference == 0 && aggressive)
+ {
+ DEBUG3 (("aggressive absorption. Row: %d\n", row)) ;
+ KILL_ROW (row) ;
+ }
+ else
+ {
+ /* save the new mark */
+ Row [row].shared2.mark = set_difference + tag_mark ;
+ }
+ }
+ }
+
+#ifndef NDEBUG
+ debug_deg_lists (n_row, n_col, Row, Col, head,
+ min_score, n_col2-k-pivot_row_degree, max_deg) ;
+#endif /* NDEBUG */
+
+ /* === Add up set differences for each column ======================= */
+
+ DEBUG3 (("** Adding set differences phase. **\n")) ;
+
+ /* for each column in pivot row */
+ rp = &A [pivot_row_start] ;
+ rp_end = rp + pivot_row_length ;
+ while (rp < rp_end)
+ {
+ /* get a column */
+ col = *rp++ ;
+ ASSERT (COL_IS_ALIVE (col) && col != pivot_col) ;
+ hash = 0 ;
+ cur_score = 0 ;
+ cp = &A [Col [col].start] ;
+ /* compact the column */
+ new_cp = cp ;
+ cp_end = cp + Col [col].length ;
+
+ DEBUG4 (("Adding set diffs for Col: %d.\n", col)) ;
+
+ while (cp < cp_end)
+ {
+ /* get a row */
+ row = *cp++ ;
+ ASSERT(row >= 0 && row < n_row) ;
+ row_mark = Row [row].shared2.mark ;
+ /* skip if dead */
+ if (ROW_IS_MARKED_DEAD (row_mark))
+ {
+ DEBUG4 ((" Row %d, dead\n", row)) ;
+ continue ;
+ }
+ DEBUG4 ((" Row %d, set diff %d\n", row, row_mark-tag_mark));
+ ASSERT (row_mark >= tag_mark) ;
+ /* compact the column */
+ *new_cp++ = row ;
+ /* compute hash function */
+ hash += row ;
+ /* add set difference */
+ cur_score += row_mark - tag_mark ;
+ /* integer overflow... */
+ cur_score = MIN (cur_score, n_col) ;
+ }
+
+ /* recompute the column's length */
+ Col [col].length = (Int) (new_cp - &A [Col [col].start]) ;
+
+ /* === Further mass elimination ================================= */
+
+ if (Col [col].length == 0)
+ {
+ DEBUG4 (("further mass elimination. Col: %d\n", col)) ;
+ /* nothing left but the pivot row in this column */
+ KILL_PRINCIPAL_COL (col) ;
+ pivot_row_degree -= Col [col].shared1.thickness ;
+ ASSERT (pivot_row_degree >= 0) ;
+ /* order it */
+ Col [col].shared2.order = k ;
+ /* increment order count by column thickness */
+ k += Col [col].shared1.thickness ;
+ }
+ else
+ {
+ /* === Prepare for supercolumn detection ==================== */
+
+ DEBUG4 (("Preparing supercol detection for Col: %d.\n", col)) ;
+
+ /* save score so far */
+ Col [col].shared2.score = cur_score ;
+
+ /* add column to hash table, for supercolumn detection */
+ hash %= n_col + 1 ;
+
+ DEBUG4 ((" Hash = %d, n_col = %d.\n", hash, n_col)) ;
+ ASSERT (((Int) hash) <= n_col) ;
+
+ head_column = head [hash] ;
+ if (head_column > EMPTY)
+ {
+ /* degree list "hash" is non-empty, use prev (shared3) of */
+ /* first column in degree list as head of hash bucket */
+ first_col = Col [head_column].shared3.headhash ;
+ Col [head_column].shared3.headhash = col ;
+ }
+ else
+ {
+ /* degree list "hash" is empty, use head as hash bucket */
+ first_col = - (head_column + 2) ;
+ head [hash] = - (col + 2) ;
+ }
+ Col [col].shared4.hash_next = first_col ;
+
+ /* save hash function in Col [col].shared3.hash */
+ Col [col].shared3.hash = (Int) hash ;
+ ASSERT (COL_IS_ALIVE (col)) ;
+ }
+ }
+
+ /* The approximate external column degree is now computed. */
+
+ /* === Supercolumn detection ======================================== */
+
+ DEBUG3 (("** Supercolumn detection phase. **\n")) ;
+
+ detect_super_cols (
+
+#ifndef NDEBUG
+ n_col, Row,
+#endif /* NDEBUG */
+
+ Col, A, head, pivot_row_start, pivot_row_length) ;
+
+ /* === Kill the pivotal column ====================================== */
+
+ KILL_PRINCIPAL_COL (pivot_col) ;
+
+ /* === Clear mark =================================================== */
+
+ tag_mark = clear_mark (tag_mark+max_deg+1, max_mark, n_row, Row) ;
+
+#ifndef NDEBUG
+ DEBUG3 (("check3\n")) ;
+ debug_mark (n_row, Row, tag_mark, max_mark) ;
+#endif /* NDEBUG */
+
+ /* === Finalize the new pivot row, and column scores ================ */
+
+ DEBUG3 (("** Finalize scores phase. **\n")) ;
+
+ /* for each column in pivot row */
+ rp = &A [pivot_row_start] ;
+ /* compact the pivot row */
+ new_rp = rp ;
+ rp_end = rp + pivot_row_length ;
+ while (rp < rp_end)
+ {
+ col = *rp++ ;
+ /* skip dead columns */
+ if (COL_IS_DEAD (col))
+ {
+ continue ;
+ }
+ *new_rp++ = col ;
+ /* add new pivot row to column */
+ A [Col [col].start + (Col [col].length++)] = pivot_row ;
+
+ /* retrieve score so far and add on pivot row's degree. */
+ /* (we wait until here for this in case the pivot */
+ /* row's degree was reduced due to mass elimination). */
+ cur_score = Col [col].shared2.score + pivot_row_degree ;
+
+ /* calculate the max possible score as the number of */
+ /* external columns minus the 'k' value minus the */
+ /* columns thickness */
+ max_score = n_col - k - Col [col].shared1.thickness ;
+
+ /* make the score the external degree of the union-of-rows */
+ cur_score -= Col [col].shared1.thickness ;
+
+ /* make sure score is less or equal than the max score */
+ cur_score = MIN (cur_score, max_score) ;
+ ASSERT (cur_score >= 0) ;
+
+ /* store updated score */
+ Col [col].shared2.score = cur_score ;
+
+ /* === Place column back in degree list ========================= */
+
+ ASSERT (min_score >= 0) ;
+ ASSERT (min_score <= n_col) ;
+ ASSERT (cur_score >= 0) ;
+ ASSERT (cur_score <= n_col) ;
+ ASSERT (head [cur_score] >= EMPTY) ;
+ next_col = head [cur_score] ;
+ Col [col].shared4.degree_next = next_col ;
+ Col [col].shared3.prev = EMPTY ;
+ if (next_col != EMPTY)
+ {
+ Col [next_col].shared3.prev = col ;
+ }
+ head [cur_score] = col ;
+
+ /* see if this score is less than current min */
+ min_score = MIN (min_score, cur_score) ;
+
+ }
+
+#ifndef NDEBUG
+ debug_deg_lists (n_row, n_col, Row, Col, head,
+ min_score, n_col2-k, max_deg) ;
+#endif /* NDEBUG */
+
+ /* === Resurrect the new pivot row ================================== */
+
+ if (pivot_row_degree > 0)
+ {
+ /* update pivot row length to reflect any cols that were killed */
+ /* during super-col detection and mass elimination */
+ Row [pivot_row].start = pivot_row_start ;
+ Row [pivot_row].length = (Int) (new_rp - &A[pivot_row_start]) ;
+ ASSERT (Row [pivot_row].length > 0) ;
+ Row [pivot_row].shared1.degree = pivot_row_degree ;
+ Row [pivot_row].shared2.mark = 0 ;
+ /* pivot row is no longer dead */
+
+ DEBUG1 (("Resurrect Pivot_row %d deg: %d\n",
+ pivot_row, pivot_row_degree)) ;
+ }
+ }
+
+ /* === All principal columns have now been ordered ====================== */
+
+ return (ngarbage) ;
+}
+
+
+/* ========================================================================== */
+/* === order_children ======================================================= */
+/* ========================================================================== */
+
+/*
+ The find_ordering routine has ordered all of the principal columns (the
+ representatives of the supercolumns). The non-principal columns have not
+ yet been ordered. This routine orders those columns by walking up the
+ parent tree (a column is a child of the column which absorbed it). The
+ final permutation vector is then placed in p [0 ... n_col-1], with p [0]
+ being the first column, and p [n_col-1] being the last. It doesn't look
+ like it at first glance, but be assured that this routine takes time linear
+ in the number of columns. Although not immediately obvious, the time
+ taken by this routine is O (n_col), that is, linear in the number of
+ columns. Not user-callable.
+*/
+
+PRIVATE void order_children
+(
+ /* === Parameters ======================================================= */
+
+ Int n_col, /* number of columns of A */
+ Colamd_Col Col [], /* of size n_col+1 */
+ Int p [] /* p [0 ... n_col-1] is the column permutation*/
+)
+{
+ /* === Local variables ================================================== */
+
+ Int i ; /* loop counter for all columns */
+ Int c ; /* column index */
+ Int parent ; /* index of column's parent */
+ Int order ; /* column's order */
+
+ /* === Order each non-principal column ================================== */
+
+ for (i = 0 ; i < n_col ; i++)
+ {
+ /* find an un-ordered non-principal column */
+ ASSERT (COL_IS_DEAD (i)) ;
+ if (!COL_IS_DEAD_PRINCIPAL (i) && Col [i].shared2.order == EMPTY)
+ {
+ parent = i ;
+ /* once found, find its principal parent */
+ do
+ {
+ parent = Col [parent].shared1.parent ;
+ } while (!COL_IS_DEAD_PRINCIPAL (parent)) ;
+
+ /* now, order all un-ordered non-principal columns along path */
+ /* to this parent. collapse tree at the same time */
+ c = i ;
+ /* get order of parent */
+ order = Col [parent].shared2.order ;
+
+ do
+ {
+ ASSERT (Col [c].shared2.order == EMPTY) ;
+
+ /* order this column */
+ Col [c].shared2.order = order++ ;
+ /* collaps tree */
+ Col [c].shared1.parent = parent ;
+
+ /* get immediate parent of this column */
+ c = Col [c].shared1.parent ;
+
+ /* continue until we hit an ordered column. There are */
+ /* guarranteed not to be anymore unordered columns */
+ /* above an ordered column */
+ } while (Col [c].shared2.order == EMPTY) ;
+
+ /* re-order the super_col parent to largest order for this group */
+ Col [parent].shared2.order = order ;
+ }
+ }
+
+ /* === Generate the permutation ========================================= */
+
+ for (c = 0 ; c < n_col ; c++)
+ {
+ p [Col [c].shared2.order] = c ;
+ }
+}
+
+
+/* ========================================================================== */
+/* === detect_super_cols ==================================================== */
+/* ========================================================================== */
+
+/*
+ Detects supercolumns by finding matches between columns in the hash buckets.
+ Check amongst columns in the set A [row_start ... row_start + row_length-1].
+ The columns under consideration are currently *not* in the degree lists,
+ and have already been placed in the hash buckets.
+
+ The hash bucket for columns whose hash function is equal to h is stored
+ as follows:
+
+ if head [h] is >= 0, then head [h] contains a degree list, so:
+
+ head [h] is the first column in degree bucket h.
+ Col [head [h]].headhash gives the first column in hash bucket h.
+
+ otherwise, the degree list is empty, and:
+
+ -(head [h] + 2) is the first column in hash bucket h.
+
+ For a column c in a hash bucket, Col [c].shared3.prev is NOT a "previous
+ column" pointer. Col [c].shared3.hash is used instead as the hash number
+ for that column. The value of Col [c].shared4.hash_next is the next column
+ in the same hash bucket.
+
+ Assuming no, or "few" hash collisions, the time taken by this routine is
+ linear in the sum of the sizes (lengths) of each column whose score has
+ just been computed in the approximate degree computation.
+ Not user-callable.
+*/
+
+PRIVATE void detect_super_cols
+(
+ /* === Parameters ======================================================= */
+
+#ifndef NDEBUG
+ /* these two parameters are only needed when debugging is enabled: */
+ Int n_col, /* number of columns of A */
+ Colamd_Row Row [], /* of size n_row+1 */
+#endif /* NDEBUG */
+
+ Colamd_Col Col [], /* of size n_col+1 */
+ Int A [], /* row indices of A */
+ Int head [], /* head of degree lists and hash buckets */
+ Int row_start, /* pointer to set of columns to check */
+ Int row_length /* number of columns to check */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int hash ; /* hash value for a column */
+ Int *rp ; /* pointer to a row */
+ Int c ; /* a column index */
+ Int super_c ; /* column index of the column to absorb into */
+ Int *cp1 ; /* column pointer for column super_c */
+ Int *cp2 ; /* column pointer for column c */
+ Int length ; /* length of column super_c */
+ Int prev_c ; /* column preceding c in hash bucket */
+ Int i ; /* loop counter */
+ Int *rp_end ; /* pointer to the end of the row */
+ Int col ; /* a column index in the row to check */
+ Int head_column ; /* first column in hash bucket or degree list */
+ Int first_col ; /* first column in hash bucket */
+
+ /* === Consider each column in the row ================================== */
+
+ rp = &A [row_start] ;
+ rp_end = rp + row_length ;
+ while (rp < rp_end)
+ {
+ col = *rp++ ;
+ if (COL_IS_DEAD (col))
+ {
+ continue ;
+ }
+
+ /* get hash number for this column */
+ hash = Col [col].shared3.hash ;
+ ASSERT (hash <= n_col) ;
+
+ /* === Get the first column in this hash bucket ===================== */
+
+ head_column = head [hash] ;
+ if (head_column > EMPTY)
+ {
+ first_col = Col [head_column].shared3.headhash ;
+ }
+ else
+ {
+ first_col = - (head_column + 2) ;
+ }
+
+ /* === Consider each column in the hash bucket ====================== */
+
+ for (super_c = first_col ; super_c != EMPTY ;
+ super_c = Col [super_c].shared4.hash_next)
+ {
+ ASSERT (COL_IS_ALIVE (super_c)) ;
+ ASSERT (Col [super_c].shared3.hash == hash) ;
+ length = Col [super_c].length ;
+
+ /* prev_c is the column preceding column c in the hash bucket */
+ prev_c = super_c ;
+
+ /* === Compare super_c with all columns after it ================ */
+
+ for (c = Col [super_c].shared4.hash_next ;
+ c != EMPTY ; c = Col [c].shared4.hash_next)
+ {
+ ASSERT (c != super_c) ;
+ ASSERT (COL_IS_ALIVE (c)) ;
+ ASSERT (Col [c].shared3.hash == hash) ;
+
+ /* not identical if lengths or scores are different */
+ if (Col [c].length != length ||
+ Col [c].shared2.score != Col [super_c].shared2.score)
+ {
+ prev_c = c ;
+ continue ;
+ }
+
+ /* compare the two columns */
+ cp1 = &A [Col [super_c].start] ;
+ cp2 = &A [Col [c].start] ;
+
+ for (i = 0 ; i < length ; i++)
+ {
+ /* the columns are "clean" (no dead rows) */
+ ASSERT (ROW_IS_ALIVE (*cp1)) ;
+ ASSERT (ROW_IS_ALIVE (*cp2)) ;
+ /* row indices will same order for both supercols, */
+ /* no gather scatter nessasary */
+ if (*cp1++ != *cp2++)
+ {
+ break ;
+ }
+ }
+
+ /* the two columns are different if the for-loop "broke" */
+ if (i != length)
+ {
+ prev_c = c ;
+ continue ;
+ }
+
+ /* === Got it! two columns are identical =================== */
+
+ ASSERT (Col [c].shared2.score == Col [super_c].shared2.score) ;
+
+ Col [super_c].shared1.thickness += Col [c].shared1.thickness ;
+ Col [c].shared1.parent = super_c ;
+ KILL_NON_PRINCIPAL_COL (c) ;
+ /* order c later, in order_children() */
+ Col [c].shared2.order = EMPTY ;
+ /* remove c from hash bucket */
+ Col [prev_c].shared4.hash_next = Col [c].shared4.hash_next ;
+ }
+ }
+
+ /* === Empty this hash bucket ======================================= */
+
+ if (head_column > EMPTY)
+ {
+ /* corresponding degree list "hash" is not empty */
+ Col [head_column].shared3.headhash = EMPTY ;
+ }
+ else
+ {
+ /* corresponding degree list "hash" is empty */
+ head [hash] = EMPTY ;
+ }
+ }
+}
+
+
+/* ========================================================================== */
+/* === garbage_collection =================================================== */
+/* ========================================================================== */
+
+/*
+ Defragments and compacts columns and rows in the workspace A. Used when
+ all avaliable memory has been used while performing row merging. Returns
+ the index of the first free position in A, after garbage collection. The
+ time taken by this routine is linear is the size of the array A, which is
+ itself linear in the number of nonzeros in the input matrix.
+ Not user-callable.
+*/
+
+PRIVATE Int garbage_collection /* returns the new value of pfree */
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row, /* number of rows */
+ Int n_col, /* number of columns */
+ Colamd_Row Row [], /* row info */
+ Colamd_Col Col [], /* column info */
+ Int A [], /* A [0 ... Alen-1] holds the matrix */
+ Int *pfree /* &A [0] ... pfree is in use */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int *psrc ; /* source pointer */
+ Int *pdest ; /* destination pointer */
+ Int j ; /* counter */
+ Int r ; /* a row index */
+ Int c ; /* a column index */
+ Int length ; /* length of a row or column */
+
+#ifndef NDEBUG
+ Int debug_rows ;
+ DEBUG2 (("Defrag..\n")) ;
+ for (psrc = &A[0] ; psrc < pfree ; psrc++) ASSERT (*psrc >= 0) ;
+ debug_rows = 0 ;
+#endif /* NDEBUG */
+
+ /* === Defragment the columns =========================================== */
+
+ pdest = &A[0] ;
+ for (c = 0 ; c < n_col ; c++)
+ {
+ if (COL_IS_ALIVE (c))
+ {
+ psrc = &A [Col [c].start] ;
+
+ /* move and compact the column */
+ ASSERT (pdest <= psrc) ;
+ Col [c].start = (Int) (pdest - &A [0]) ;
+ length = Col [c].length ;
+ for (j = 0 ; j < length ; j++)
+ {
+ r = *psrc++ ;
+ if (ROW_IS_ALIVE (r))
+ {
+ *pdest++ = r ;
+ }
+ }
+ Col [c].length = (Int) (pdest - &A [Col [c].start]) ;
+ }
+ }
+
+ /* === Prepare to defragment the rows =================================== */
+
+ for (r = 0 ; r < n_row ; r++)
+ {
+ if (ROW_IS_DEAD (r) || (Row [r].length == 0))
+ {
+ /* This row is already dead, or is of zero length. Cannot compact
+ * a row of zero length, so kill it. NOTE: in the current version,
+ * there are no zero-length live rows. Kill the row (for the first
+ * time, or again) just to be safe. */
+ KILL_ROW (r) ;
+ }
+ else
+ {
+ /* save first column index in Row [r].shared2.first_column */
+ psrc = &A [Row [r].start] ;
+ Row [r].shared2.first_column = *psrc ;
+ ASSERT (ROW_IS_ALIVE (r)) ;
+ /* flag the start of the row with the one's complement of row */
+ *psrc = ONES_COMPLEMENT (r) ;
+#ifndef NDEBUG
+ debug_rows++ ;
+#endif /* NDEBUG */
+ }
+ }
+
+ /* === Defragment the rows ============================================== */
+
+ psrc = pdest ;
+ while (psrc < pfree)
+ {
+ /* find a negative number ... the start of a row */
+ if (*psrc++ < 0)
+ {
+ psrc-- ;
+ /* get the row index */
+ r = ONES_COMPLEMENT (*psrc) ;
+ ASSERT (r >= 0 && r < n_row) ;
+ /* restore first column index */
+ *psrc = Row [r].shared2.first_column ;
+ ASSERT (ROW_IS_ALIVE (r)) ;
+ ASSERT (Row [r].length > 0) ;
+ /* move and compact the row */
+ ASSERT (pdest <= psrc) ;
+ Row [r].start = (Int) (pdest - &A [0]) ;
+ length = Row [r].length ;
+ for (j = 0 ; j < length ; j++)
+ {
+ c = *psrc++ ;
+ if (COL_IS_ALIVE (c))
+ {
+ *pdest++ = c ;
+ }
+ }
+ Row [r].length = (Int) (pdest - &A [Row [r].start]) ;
+ ASSERT (Row [r].length > 0) ;
+#ifndef NDEBUG
+ debug_rows-- ;
+#endif /* NDEBUG */
+ }
+ }
+ /* ensure we found all the rows */
+ ASSERT (debug_rows == 0) ;
+
+ /* === Return the new value of pfree ==================================== */
+
+ return ((Int) (pdest - &A [0])) ;
+}
+
+
+/* ========================================================================== */
+/* === clear_mark =========================================================== */
+/* ========================================================================== */
+
+/*
+ Clears the Row [].shared2.mark array, and returns the new tag_mark.
+ Return value is the new tag_mark. Not user-callable.
+*/
+
+PRIVATE Int clear_mark /* return the new value for tag_mark */
+(
+ /* === Parameters ======================================================= */
+
+ Int tag_mark, /* new value of tag_mark */
+ Int max_mark, /* max allowed value of tag_mark */
+
+ Int n_row, /* number of rows in A */
+ Colamd_Row Row [] /* Row [0 ... n_row-1].shared2.mark is set to zero */
+)
+{
+ /* === Local variables ================================================== */
+
+ Int r ;
+
+ if (tag_mark <= 0 || tag_mark >= max_mark)
+ {
+ for (r = 0 ; r < n_row ; r++)
+ {
+ if (ROW_IS_ALIVE (r))
+ {
+ Row [r].shared2.mark = 0 ;
+ }
+ }
+ tag_mark = 1 ;
+ }
+
+ return (tag_mark) ;
+}
+
+
+/* ========================================================================== */
+/* === print_report ========================================================= */
+/* ========================================================================== */
+
+PRIVATE void print_report
+(
+ char *method,
+ Int stats [COLAMD_STATS]
+)
+{
+
+ Int i1, i2, i3 ;
+
+ PRINTF (("\n%s version %d.%d, %s: ", method,
+ COLAMD_MAIN_VERSION, COLAMD_SUB_VERSION, COLAMD_DATE)) ;
+
+ if (!stats)
+ {
+ PRINTF (("No statistics available.\n")) ;
+ return ;
+ }
+
+ i1 = stats [COLAMD_INFO1] ;
+ i2 = stats [COLAMD_INFO2] ;
+ i3 = stats [COLAMD_INFO3] ;
+
+ if (stats [COLAMD_STATUS] >= 0)
+ {
+ PRINTF (("OK. ")) ;
+ }
+ else
+ {
+ PRINTF (("ERROR. ")) ;
+ }
+
+ switch (stats [COLAMD_STATUS])
+ {
+
+ case COLAMD_OK_BUT_JUMBLED:
+
+ PRINTF(("Matrix has unsorted or duplicate row indices.\n")) ;
+
+ PRINTF(("%s: number of duplicate or out-of-order row indices: %d\n",
+ method, i3)) ;
+
+ PRINTF(("%s: last seen duplicate or out-of-order row index: %d\n",
+ method, INDEX (i2))) ;
+
+ PRINTF(("%s: last seen in column: %d",
+ method, INDEX (i1))) ;
+
+ /* no break - fall through to next case instead */
+
+ case COLAMD_OK:
+
+ PRINTF(("\n")) ;
+
+ PRINTF(("%s: number of dense or empty rows ignored: %d\n",
+ method, stats [COLAMD_DENSE_ROW])) ;
+
+ PRINTF(("%s: number of dense or empty columns ignored: %d\n",
+ method, stats [COLAMD_DENSE_COL])) ;
+
+ PRINTF(("%s: number of garbage collections performed: %d\n",
+ method, stats [COLAMD_DEFRAG_COUNT])) ;
+ break ;
+
+ case COLAMD_ERROR_A_not_present:
+
+ PRINTF(("Array A (row indices of matrix) not present.\n")) ;
+ break ;
+
+ case COLAMD_ERROR_p_not_present:
+
+ PRINTF(("Array p (column pointers for matrix) not present.\n")) ;
+ break ;
+
+ case COLAMD_ERROR_nrow_negative:
+
+ PRINTF(("Invalid number of rows (%d).\n", i1)) ;
+ break ;
+
+ case COLAMD_ERROR_ncol_negative:
+
+ PRINTF(("Invalid number of columns (%d).\n", i1)) ;
+ break ;
+
+ case COLAMD_ERROR_nnz_negative:
+
+ PRINTF(("Invalid number of nonzero entries (%d).\n", i1)) ;
+ break ;
+
+ case COLAMD_ERROR_p0_nonzero:
+
+ PRINTF(("Invalid column pointer, p [0] = %d, must be zero.\n", i1));
+ break ;
+
+ case COLAMD_ERROR_A_too_small:
+
+ PRINTF(("Array A too small.\n")) ;
+ PRINTF((" Need Alen >= %d, but given only Alen = %d.\n",
+ i1, i2)) ;
+ break ;
+
+ case COLAMD_ERROR_col_length_negative:
+
+ PRINTF
+ (("Column %d has a negative number of nonzero entries (%d).\n",
+ INDEX (i1), i2)) ;
+ break ;
+
+ case COLAMD_ERROR_row_index_out_of_bounds:
+
+ PRINTF
+ (("Row index (row %d) out of bounds (%d to %d) in column %d.\n",
+ INDEX (i2), INDEX (0), INDEX (i3-1), INDEX (i1))) ;
+ break ;
+
+ case COLAMD_ERROR_out_of_memory:
+
+ PRINTF(("Out of memory.\n")) ;
+ break ;
+
+ /* v2.4: internal-error case deleted */
+ }
+}
+
+
+
+
+/* ========================================================================== */
+/* === colamd debugging routines ============================================ */
+/* ========================================================================== */
+
+/* When debugging is disabled, the remainder of this file is ignored. */
+
+#ifndef NDEBUG
+
+
+/* ========================================================================== */
+/* === debug_structures ===================================================== */
+/* ========================================================================== */
+
+/*
+ At this point, all empty rows and columns are dead. All live columns
+ are "clean" (containing no dead rows) and simplicial (no supercolumns
+ yet). Rows may contain dead columns, but all live rows contain at
+ least one live column.
+*/
+
+PRIVATE void debug_structures
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A [],
+ Int n_col2
+)
+{
+ /* === Local variables ================================================== */
+
+ Int i ;
+ Int c ;
+ Int *cp ;
+ Int *cp_end ;
+ Int len ;
+ Int score ;
+ Int r ;
+ Int *rp ;
+ Int *rp_end ;
+ Int deg ;
+
+ /* === Check A, Row, and Col ============================================ */
+
+ for (c = 0 ; c < n_col ; c++)
+ {
+ if (COL_IS_ALIVE (c))
+ {
+ len = Col [c].length ;
+ score = Col [c].shared2.score ;
+ DEBUG4 (("initial live col %5d %5d %5d\n", c, len, score)) ;
+ ASSERT (len > 0) ;
+ ASSERT (score >= 0) ;
+ ASSERT (Col [c].shared1.thickness == 1) ;
+ cp = &A [Col [c].start] ;
+ cp_end = cp + len ;
+ while (cp < cp_end)
+ {
+ r = *cp++ ;
+ ASSERT (ROW_IS_ALIVE (r)) ;
+ }
+ }
+ else
+ {
+ i = Col [c].shared2.order ;
+ ASSERT (i >= n_col2 && i < n_col) ;
+ }
+ }
+
+ for (r = 0 ; r < n_row ; r++)
+ {
+ if (ROW_IS_ALIVE (r))
+ {
+ i = 0 ;
+ len = Row [r].length ;
+ deg = Row [r].shared1.degree ;
+ ASSERT (len > 0) ;
+ ASSERT (deg > 0) ;
+ rp = &A [Row [r].start] ;
+ rp_end = rp + len ;
+ while (rp < rp_end)
+ {
+ c = *rp++ ;
+ if (COL_IS_ALIVE (c))
+ {
+ i++ ;
+ }
+ }
+ ASSERT (i > 0) ;
+ }
+ }
+}
+
+
+/* ========================================================================== */
+/* === debug_deg_lists ====================================================== */
+/* ========================================================================== */
+
+/*
+ Prints the contents of the degree lists. Counts the number of columns
+ in the degree list and compares it to the total it should have. Also
+ checks the row degrees.
+*/
+
+PRIVATE void debug_deg_lists
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int head [],
+ Int min_score,
+ Int should,
+ Int max_deg
+)
+{
+ /* === Local variables ================================================== */
+
+ Int deg ;
+ Int col ;
+ Int have ;
+ Int row ;
+
+ /* === Check the degree lists =========================================== */
+
+ if (n_col > 10000 && colamd_debug <= 0)
+ {
+ return ;
+ }
+ have = 0 ;
+ DEBUG4 (("Degree lists: %d\n", min_score)) ;
+ for (deg = 0 ; deg <= n_col ; deg++)
+ {
+ col = head [deg] ;
+ if (col == EMPTY)
+ {
+ continue ;
+ }
+ DEBUG4 (("%d:", deg)) ;
+ while (col != EMPTY)
+ {
+ DEBUG4 ((" %d", col)) ;
+ have += Col [col].shared1.thickness ;
+ ASSERT (COL_IS_ALIVE (col)) ;
+ col = Col [col].shared4.degree_next ;
+ }
+ DEBUG4 (("\n")) ;
+ }
+ DEBUG4 (("should %d have %d\n", should, have)) ;
+ ASSERT (should == have) ;
+
+ /* === Check the row degrees ============================================ */
+
+ if (n_row > 10000 && colamd_debug <= 0)
+ {
+ return ;
+ }
+ for (row = 0 ; row < n_row ; row++)
+ {
+ if (ROW_IS_ALIVE (row))
+ {
+ ASSERT (Row [row].shared1.degree <= max_deg) ;
+ }
+ }
+}
+
+
+/* ========================================================================== */
+/* === debug_mark =========================================================== */
+/* ========================================================================== */
+
+/*
+ Ensures that the tag_mark is less that the maximum and also ensures that
+ each entry in the mark array is less than the tag mark.
+*/
+
+PRIVATE void debug_mark
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row,
+ Colamd_Row Row [],
+ Int tag_mark,
+ Int max_mark
+)
+{
+ /* === Local variables ================================================== */
+
+ Int r ;
+
+ /* === Check the Row marks ============================================== */
+
+ ASSERT (tag_mark > 0 && tag_mark <= max_mark) ;
+ if (n_row > 10000 && colamd_debug <= 0)
+ {
+ return ;
+ }
+ for (r = 0 ; r < n_row ; r++)
+ {
+ ASSERT (Row [r].shared2.mark < tag_mark) ;
+ }
+}
+
+
+/* ========================================================================== */
+/* === debug_matrix ========================================================= */
+/* ========================================================================== */
+
+/*
+ Prints out the contents of the columns and the rows.
+*/
+
+PRIVATE void debug_matrix
+(
+ /* === Parameters ======================================================= */
+
+ Int n_row,
+ Int n_col,
+ Colamd_Row Row [],
+ Colamd_Col Col [],
+ Int A []
+)
+{
+ /* === Local variables ================================================== */
+
+ Int r ;
+ Int c ;
+ Int *rp ;
+ Int *rp_end ;
+ Int *cp ;
+ Int *cp_end ;
+
+ /* === Dump the rows and columns of the matrix ========================== */
+
+ if (colamd_debug < 3)
+ {
+ return ;
+ }
+ DEBUG3 (("DUMP MATRIX:\n")) ;
+ for (r = 0 ; r < n_row ; r++)
+ {
+ DEBUG3 (("Row %d alive? %d\n", r, ROW_IS_ALIVE (r))) ;
+ if (ROW_IS_DEAD (r))
+ {
+ continue ;
+ }
+ DEBUG3 (("start %d length %d degree %d\n",
+ Row [r].start, Row [r].length, Row [r].shared1.degree)) ;
+ rp = &A [Row [r].start] ;
+ rp_end = rp + Row [r].length ;
+ while (rp < rp_end)
+ {
+ c = *rp++ ;
+ DEBUG4 ((" %d col %d\n", COL_IS_ALIVE (c), c)) ;
+ }
+ }
+
+ for (c = 0 ; c < n_col ; c++)
+ {
+ DEBUG3 (("Col %d alive? %d\n", c, COL_IS_ALIVE (c))) ;
+ if (COL_IS_DEAD (c))
+ {
+ continue ;
+ }
+ DEBUG3 (("start %d length %d shared1 %d shared2 %d\n",
+ Col [c].start, Col [c].length,
+ Col [c].shared1.thickness, Col [c].shared2.score)) ;
+ cp = &A [Col [c].start] ;
+ cp_end = cp + Col [c].length ;
+ while (cp < cp_end)
+ {
+ r = *cp++ ;
+ DEBUG4 ((" %d row %d\n", ROW_IS_ALIVE (r), r)) ;
+ }
+ }
+}
+
+PRIVATE void colamd_get_debug
+(
+ char *method
+)
+{
+ FILE *f ;
+ colamd_debug = 0 ; /* no debug printing */
+ f = fopen ("debug", "r") ;
+ if (f == (FILE *) NULL)
+ {
+ colamd_debug = 0 ;
+ }
+ else
+ {
+ fscanf (f, "%d", &colamd_debug) ;
+ fclose (f) ;
+ }
+ DEBUG0 (("%s: debug version, D = %d (THIS WILL BE SLOW!)\n",
+ method, colamd_debug)) ;
+}
+
+#endif /* NDEBUG */
diff --git a/test/monniaux/glpk-4.65/src/colamd/colamd.h b/test/monniaux/glpk-4.65/src/colamd/colamd.h
new file mode 100644
index 00000000..511735e5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/colamd/colamd.h
@@ -0,0 +1,69 @@
+/* colamd.h */
+
+/* Written by Andrew Makhorin <mao@gnu.org>. */
+
+#ifndef COLAMD_H
+#define COLAMD_H
+
+#define _GLPSTD_STDIO
+#include "env.h"
+
+#define COLAMD_DATE "Nov 1, 2007"
+#define COLAMD_VERSION_CODE(main, sub) ((main) * 1000 + (sub))
+#define COLAMD_MAIN_VERSION 2
+#define COLAMD_SUB_VERSION 7
+#define COLAMD_SUBSUB_VERSION 1
+#define COLAMD_VERSION \
+ COLAMD_VERSION_CODE(COLAMD_MAIN_VERSION, COLAMD_SUB_VERSION)
+
+#define COLAMD_KNOBS 20
+#define COLAMD_STATS 20
+#define COLAMD_DENSE_ROW 0
+#define COLAMD_DENSE_COL 1
+#define COLAMD_AGGRESSIVE 2
+#define COLAMD_DEFRAG_COUNT 2
+#define COLAMD_STATUS 3
+#define COLAMD_INFO1 4
+#define COLAMD_INFO2 5
+#define COLAMD_INFO3 6
+
+#define COLAMD_OK (0)
+#define COLAMD_OK_BUT_JUMBLED (1)
+#define COLAMD_ERROR_A_not_present (-1)
+#define COLAMD_ERROR_p_not_present (-2)
+#define COLAMD_ERROR_nrow_negative (-3)
+#define COLAMD_ERROR_ncol_negative (-4)
+#define COLAMD_ERROR_nnz_negative (-5)
+#define COLAMD_ERROR_p0_nonzero (-6)
+#define COLAMD_ERROR_A_too_small (-7)
+#define COLAMD_ERROR_col_length_negative (-8)
+#define COLAMD_ERROR_row_index_out_of_bounds (-9)
+#define COLAMD_ERROR_out_of_memory (-10)
+#define COLAMD_ERROR_internal_error (-999)
+
+#define colamd_recommended _glp_colamd_recommended
+size_t colamd_recommended(int nnz, int n_row, int n_col);
+
+#define colamd_set_defaults _glp_colamd_set_defaults
+void colamd_set_defaults(double knobs [COLAMD_KNOBS]);
+
+#define colamd _glp_colamd
+int colamd(int n_row, int n_col, int Alen, int A[], int p[],
+ double knobs[COLAMD_KNOBS], int stats[COLAMD_STATS]);
+
+#define symamd _glp_symamd
+int symamd(int n, int A[], int p[], int perm[],
+ double knobs[COLAMD_KNOBS], int stats[COLAMD_STATS],
+ void *(*allocate)(size_t, size_t), void(*release)(void *));
+
+#define colamd_report _glp_colamd_report
+void colamd_report(int stats[COLAMD_STATS]);
+
+#define symamd_report _glp_symamd_report
+void symamd_report(int stats[COLAMD_STATS]);
+
+#define colamd_printf xprintf
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/bfd.c b/test/monniaux/glpk-4.65/src/draft/bfd.c
new file mode 100644
index 00000000..dece376c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/bfd.c
@@ -0,0 +1,544 @@
+/* bfd.c (LP basis factorization driver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2007, 2014 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "glpk.h"
+#include "env.h"
+#include "bfd.h"
+#include "fhvint.h"
+#include "scfint.h"
+#ifdef GLP_DEBUG
+#include "glpspm.h"
+#endif
+
+struct BFD
+{ /* LP basis factorization driver */
+ int valid;
+ /* factorization is valid only if this flag is set */
+ int type;
+ /* type of factorization used:
+ 0 - interface not established yet
+ 1 - FHV-factorization
+ 2 - Schur-complement-based factorization */
+ union
+ { void *none; /* type = 0 */
+ FHVINT *fhvi; /* type = 1 */
+ SCFINT *scfi; /* type = 2 */
+ } u;
+ /* interface to factorization of LP basis */
+ glp_bfcp parm;
+ /* factorization control parameters */
+#ifdef GLP_DEBUG
+ SPM *B;
+ /* current basis (for testing/debugging only) */
+#endif
+ int upd_cnt;
+ /* factorization update count */
+#if 1 /* 21/IV-2014 */
+ double b_norm;
+ /* 1-norm of matrix B */
+ double i_norm;
+ /* estimated 1-norm of matrix inv(B) */
+#endif
+};
+
+BFD *bfd_create_it(void)
+{ /* create LP basis factorization */
+ BFD *bfd;
+#ifdef GLP_DEBUG
+ xprintf("bfd_create_it: warning: debugging version used\n");
+#endif
+ bfd = talloc(1, BFD);
+ bfd->valid = 0;
+ bfd->type = 0;
+ bfd->u.none = NULL;
+ bfd_set_bfcp(bfd, NULL);
+#ifdef GLP_DEBUG
+ bfd->B = NULL;
+#endif
+ bfd->upd_cnt = 0;
+ return bfd;
+}
+
+#if 0 /* 08/III-2014 */
+void bfd_set_parm(BFD *bfd, const void *parm)
+{ /* change LP basis factorization control parameters */
+ memcpy(&bfd->parm, parm, sizeof(glp_bfcp));
+ return;
+}
+#endif
+
+void bfd_get_bfcp(BFD *bfd, void /* glp_bfcp */ *parm)
+{ /* retrieve LP basis factorization control parameters */
+ memcpy(parm, &bfd->parm, sizeof(glp_bfcp));
+ return;
+}
+
+void bfd_set_bfcp(BFD *bfd, const void /* glp_bfcp */ *parm)
+{ /* change LP basis factorization control parameters */
+ if (parm == NULL)
+ { /* reset to default */
+ memset(&bfd->parm, 0, sizeof(glp_bfcp));
+ bfd->parm.type = GLP_BF_LUF + GLP_BF_FT;
+ bfd->parm.piv_tol = 0.10;
+ bfd->parm.piv_lim = 4;
+ bfd->parm.suhl = 1;
+ bfd->parm.eps_tol = DBL_EPSILON;
+ bfd->parm.nfs_max = 100;
+ bfd->parm.nrs_max = 70;
+ }
+ else
+ memcpy(&bfd->parm, parm, sizeof(glp_bfcp));
+ return;
+}
+
+#if 1 /* 21/IV-2014 */
+struct bfd_info
+{ BFD *bfd;
+ int (*col)(void *info, int j, int ind[], double val[]);
+ void *info;
+};
+
+static int bfd_col(void *info_, int j, int ind[], double val[])
+{ struct bfd_info *info = info_;
+ int t, len;
+ double sum;
+ len = info->col(info->info, j, ind, val);
+ sum = 0.0;
+ for (t = 1; t <= len; t++)
+ { if (val[t] >= 0.0)
+ sum += val[t];
+ else
+ sum -= val[t];
+ }
+ if (info->bfd->b_norm < sum)
+ info->bfd->b_norm = sum;
+ return len;
+}
+#endif
+
+int bfd_factorize(BFD *bfd, int m, /*const int bh[],*/ int (*col1)
+ (void *info, int j, int ind[], double val[]), void *info1)
+{ /* compute LP basis factorization */
+#if 1 /* 21/IV-2014 */
+ struct bfd_info info;
+#endif
+ int type, ret;
+ /*xassert(bh == bh);*/
+ /* invalidate current factorization */
+ bfd->valid = 0;
+ /* determine required factorization type */
+ switch (bfd->parm.type)
+ { case GLP_BF_LUF + GLP_BF_FT:
+ type = 1;
+ break;
+ case GLP_BF_LUF + GLP_BF_BG:
+ case GLP_BF_LUF + GLP_BF_GR:
+ case GLP_BF_BTF + GLP_BF_BG:
+ case GLP_BF_BTF + GLP_BF_GR:
+ type = 2;
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+ /* delete factorization interface, if necessary */
+ switch (bfd->type)
+ { case 0:
+ break;
+ case 1:
+ if (type != 1)
+ { bfd->type = 0;
+ fhvint_delete(bfd->u.fhvi);
+ bfd->u.fhvi = NULL;
+ }
+ break;
+ case 2:
+ if (type != 2)
+ { bfd->type = 0;
+ scfint_delete(bfd->u.scfi);
+ bfd->u.scfi = NULL;
+ }
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+ /* establish factorization interface, if necessary */
+ if (bfd->type == 0)
+ { switch (type)
+ { case 1:
+ bfd->type = 1;
+ xassert(bfd->u.fhvi == NULL);
+ bfd->u.fhvi = fhvint_create();
+ break;
+ case 2:
+ bfd->type = 2;
+ xassert(bfd->u.scfi == NULL);
+ if (!(bfd->parm.type & GLP_BF_BTF))
+ bfd->u.scfi = scfint_create(1);
+ else
+ bfd->u.scfi = scfint_create(2);
+ break;
+ default:
+ xassert(type != type);
+ }
+ }
+ /* try to compute factorization */
+#if 1 /* 21/IV-2014 */
+ bfd->b_norm = bfd->i_norm = 0.0;
+ info.bfd = bfd;
+ info.col = col1;
+ info.info = info1;
+#endif
+ switch (bfd->type)
+ { case 1:
+ bfd->u.fhvi->lufi->sgf_piv_tol = bfd->parm.piv_tol;
+ bfd->u.fhvi->lufi->sgf_piv_lim = bfd->parm.piv_lim;
+ bfd->u.fhvi->lufi->sgf_suhl = bfd->parm.suhl;
+ bfd->u.fhvi->lufi->sgf_eps_tol = bfd->parm.eps_tol;
+ bfd->u.fhvi->nfs_max = bfd->parm.nfs_max;
+ ret = fhvint_factorize(bfd->u.fhvi, m, bfd_col, &info);
+#if 1 /* FIXME */
+ if (ret == 0)
+ bfd->i_norm = fhvint_estimate(bfd->u.fhvi);
+ else
+ ret = BFD_ESING;
+#endif
+ break;
+ case 2:
+ if (bfd->u.scfi->scf.type == 1)
+ { bfd->u.scfi->u.lufi->sgf_piv_tol = bfd->parm.piv_tol;
+ bfd->u.scfi->u.lufi->sgf_piv_lim = bfd->parm.piv_lim;
+ bfd->u.scfi->u.lufi->sgf_suhl = bfd->parm.suhl;
+ bfd->u.scfi->u.lufi->sgf_eps_tol = bfd->parm.eps_tol;
+ }
+ else if (bfd->u.scfi->scf.type == 2)
+ { bfd->u.scfi->u.btfi->sgf_piv_tol = bfd->parm.piv_tol;
+ bfd->u.scfi->u.btfi->sgf_piv_lim = bfd->parm.piv_lim;
+ bfd->u.scfi->u.btfi->sgf_suhl = bfd->parm.suhl;
+ bfd->u.scfi->u.btfi->sgf_eps_tol = bfd->parm.eps_tol;
+ }
+ else
+ xassert(bfd != bfd);
+ bfd->u.scfi->nn_max = bfd->parm.nrs_max;
+ ret = scfint_factorize(bfd->u.scfi, m, bfd_col, &info);
+#if 1 /* FIXME */
+ if (ret == 0)
+ bfd->i_norm = scfint_estimate(bfd->u.scfi);
+ else
+ ret = BFD_ESING;
+#endif
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+#ifdef GLP_DEBUG
+ /* save specified LP basis */
+ if (bfd->B != NULL)
+ spm_delete_mat(bfd->B);
+ bfd->B = spm_create_mat(m, m);
+ { int *ind = talloc(1+m, int);
+ double *val = talloc(1+m, double);
+ int j, k, len;
+ for (j = 1; j <= m; j++)
+ { len = col(info, j, ind, val);
+ for (k = 1; k <= len; k++)
+ spm_new_elem(bfd->B, ind[k], j, val[k]);
+ }
+ tfree(ind);
+ tfree(val);
+ }
+#endif
+ if (ret == 0)
+ { /* factorization has been successfully computed */
+ double cond;
+ bfd->valid = 1;
+#ifdef GLP_DEBUG
+ cond = bfd_condest(bfd);
+ if (cond > 1e9)
+ xprintf("bfd_factorize: warning: cond(B) = %g\n", cond);
+#endif
+ }
+#ifdef GLP_DEBUG
+ xprintf("bfd_factorize: m = %d; ret = %d\n", m, ret);
+#endif
+ bfd->upd_cnt = 0;
+ return ret;
+}
+
+#if 0 /* 21/IV-2014 */
+double bfd_estimate(BFD *bfd)
+{ /* estimate 1-norm of inv(B) */
+ double norm;
+ xassert(bfd->valid);
+ xassert(bfd->upd_cnt == 0);
+ switch (bfd->type)
+ { case 1:
+ norm = fhvint_estimate(bfd->u.fhvi);
+ break;
+ case 2:
+ norm = scfint_estimate(bfd->u.scfi);
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+ return norm;
+}
+#endif
+
+#if 1 /* 21/IV-2014 */
+double bfd_condest(BFD *bfd)
+{ /* estimate condition of B */
+ double cond;
+ xassert(bfd->valid);
+ /*xassert(bfd->upd_cnt == 0);*/
+ cond = bfd->b_norm * bfd->i_norm;
+ if (cond < 1.0)
+ cond = 1.0;
+ return cond;
+}
+#endif
+
+void bfd_ftran(BFD *bfd, double x[])
+{ /* perform forward transformation (solve system B * x = b) */
+#ifdef GLP_DEBUG
+ SPM *B = bfd->B;
+ int m = B->m;
+ double *b = talloc(1+m, double);
+ SPME *e;
+ int k;
+ double s, relerr, maxerr;
+ for (k = 1; k <= m; k++)
+ b[k] = x[k];
+#endif
+ xassert(bfd->valid);
+ switch (bfd->type)
+ { case 1:
+ fhvint_ftran(bfd->u.fhvi, x);
+ break;
+ case 2:
+ scfint_ftran(bfd->u.scfi, x);
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+#ifdef GLP_DEBUG
+ maxerr = 0.0;
+ for (k = 1; k <= m; k++)
+ { s = 0.0;
+ for (e = B->row[k]; e != NULL; e = e->r_next)
+ s += e->val * x[e->j];
+ relerr = (b[k] - s) / (1.0 + fabs(b[k]));
+ if (maxerr < relerr)
+ maxerr = relerr;
+ }
+ if (maxerr > 1e-8)
+ xprintf("bfd_ftran: maxerr = %g; relative error too large\n",
+ maxerr);
+ tfree(b);
+#endif
+ return;
+}
+
+#if 1 /* 30/III-2016 */
+void bfd_ftran_s(BFD *bfd, FVS *x)
+{ /* sparse version of bfd_ftran */
+ /* (sparse mode is not implemented yet) */
+ int n = x->n;
+ int *ind = x->ind;
+ double *vec = x->vec;
+ int j, nnz = 0;
+ bfd_ftran(bfd, vec);
+ for (j = n; j >= 1; j--)
+ { if (vec[j] != 0.0)
+ ind[++nnz] = j;
+ }
+ x->nnz = nnz;
+ return;
+}
+#endif
+
+void bfd_btran(BFD *bfd, double x[])
+{ /* perform backward transformation (solve system B'* x = b) */
+#ifdef GLP_DEBUG
+ SPM *B = bfd->B;
+ int m = B->m;
+ double *b = talloc(1+m, double);
+ SPME *e;
+ int k;
+ double s, relerr, maxerr;
+ for (k = 1; k <= m; k++)
+ b[k] = x[k];
+#endif
+ xassert(bfd->valid);
+ switch (bfd->type)
+ { case 1:
+ fhvint_btran(bfd->u.fhvi, x);
+ break;
+ case 2:
+ scfint_btran(bfd->u.scfi, x);
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+#ifdef GLP_DEBUG
+ maxerr = 0.0;
+ for (k = 1; k <= m; k++)
+ { s = 0.0;
+ for (e = B->col[k]; e != NULL; e = e->c_next)
+ s += e->val * x[e->i];
+ relerr = (b[k] - s) / (1.0 + fabs(b[k]));
+ if (maxerr < relerr)
+ maxerr = relerr;
+ }
+ if (maxerr > 1e-8)
+ xprintf("bfd_btran: maxerr = %g; relative error too large\n",
+ maxerr);
+ tfree(b);
+#endif
+ return;
+}
+
+#if 1 /* 30/III-2016 */
+void bfd_btran_s(BFD *bfd, FVS *x)
+{ /* sparse version of bfd_btran */
+ /* (sparse mode is not implemented yet) */
+ int n = x->n;
+ int *ind = x->ind;
+ double *vec = x->vec;
+ int j, nnz = 0;
+ bfd_btran(bfd, vec);
+ for (j = n; j >= 1; j--)
+ { if (vec[j] != 0.0)
+ ind[++nnz] = j;
+ }
+ x->nnz = nnz;
+ return;
+}
+#endif
+
+int bfd_update(BFD *bfd, int j, int len, const int ind[], const double
+ val[])
+{ /* update LP basis factorization */
+ int ret;
+ xassert(bfd->valid);
+ switch (bfd->type)
+ { case 1:
+ ret = fhvint_update(bfd->u.fhvi, j, len, ind, val);
+#if 1 /* FIXME */
+ switch (ret)
+ { case 0:
+ break;
+ case 1:
+ ret = BFD_ESING;
+ break;
+ case 2:
+ case 3:
+ ret = BFD_ECOND;
+ break;
+ case 4:
+ ret = BFD_ELIMIT;
+ break;
+ case 5:
+ ret = BFD_ECHECK;
+ break;
+ default:
+ xassert(ret != ret);
+ }
+#endif
+ break;
+ case 2:
+ switch (bfd->parm.type & 0x0F)
+ { case GLP_BF_BG:
+ ret = scfint_update(bfd->u.scfi, 1, j, len, ind, val);
+ break;
+ case GLP_BF_GR:
+ ret = scfint_update(bfd->u.scfi, 2, j, len, ind, val);
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+#if 1 /* FIXME */
+ switch (ret)
+ { case 0:
+ break;
+ case 1:
+ ret = BFD_ELIMIT;
+ break;
+ case 2:
+ ret = BFD_ECOND;
+ break;
+ default:
+ xassert(ret != ret);
+ }
+#endif
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+ if (ret != 0)
+ { /* updating factorization failed */
+ bfd->valid = 0;
+ }
+#ifdef GLP_DEBUG
+ /* save updated LP basis */
+ { SPME *e;
+ int k;
+ for (e = bfd->B->col[j]; e != NULL; e = e->c_next)
+ e->val = 0.0;
+ spm_drop_zeros(bfd->B, 0.0);
+ for (k = 1; k <= len; k++)
+ spm_new_elem(bfd->B, ind[k], j, val[k]);
+ }
+#endif
+ if (ret == 0)
+ bfd->upd_cnt++;
+ return ret;
+}
+
+int bfd_get_count(BFD *bfd)
+{ /* determine factorization update count */
+ return bfd->upd_cnt;
+}
+
+void bfd_delete_it(BFD *bfd)
+{ /* delete LP basis factorization */
+ switch (bfd->type)
+ { case 0:
+ break;
+ case 1:
+ fhvint_delete(bfd->u.fhvi);
+ break;
+ case 2:
+ scfint_delete(bfd->u.scfi);
+ break;
+ default:
+ xassert(bfd != bfd);
+ }
+#ifdef GLP_DEBUG
+ if (bfd->B != NULL)
+ spm_delete_mat(bfd->B);
+#endif
+ tfree(bfd);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/bfd.h b/test/monniaux/glpk-4.65/src/draft/bfd.h
new file mode 100644
index 00000000..0ef4c023
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/bfd.h
@@ -0,0 +1,107 @@
+/* bfd.h (LP basis factorization driver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef BFD_H
+#define BFD_H
+
+#if 1 /* 30/III-2016 */
+#include "fvs.h"
+#endif
+
+typedef struct BFD BFD;
+
+/* return codes: */
+#define BFD_ESING 1 /* singular matrix */
+#define BFD_ECOND 2 /* ill-conditioned matrix */
+#define BFD_ECHECK 3 /* insufficient accuracy */
+#define BFD_ELIMIT 4 /* update limit reached */
+#if 0 /* 05/III-2014 */
+#define BFD_EROOM 5 /* SVA overflow */
+#endif
+
+#define bfd_create_it _glp_bfd_create_it
+BFD *bfd_create_it(void);
+/* create LP basis factorization */
+
+#if 0 /* 08/III-2014 */
+#define bfd_set_parm _glp_bfd_set_parm
+void bfd_set_parm(BFD *bfd, const void *parm);
+/* change LP basis factorization control parameters */
+#endif
+
+#define bfd_get_bfcp _glp_bfd_get_bfcp
+void bfd_get_bfcp(BFD *bfd, void /* glp_bfcp */ *parm);
+/* retrieve LP basis factorization control parameters */
+
+#define bfd_set_bfcp _glp_bfd_set_bfcp
+void bfd_set_bfcp(BFD *bfd, const void /* glp_bfcp */ *parm);
+/* change LP basis factorization control parameters */
+
+#define bfd_factorize _glp_bfd_factorize
+int bfd_factorize(BFD *bfd, int m, /*const int bh[],*/ int (*col)
+ (void *info, int j, int ind[], double val[]), void *info);
+/* compute LP basis factorization */
+
+#if 1 /* 21/IV-2014 */
+#define bfd_condest _glp_bfd_condest
+double bfd_condest(BFD *bfd);
+/* estimate condition of B */
+#endif
+
+#define bfd_ftran _glp_bfd_ftran
+void bfd_ftran(BFD *bfd, double x[]);
+/* perform forward transformation (solve system B*x = b) */
+
+#if 1 /* 30/III-2016 */
+#define bfd_ftran_s _glp_bfd_ftran_s
+void bfd_ftran_s(BFD *bfd, FVS *x);
+/* sparse version of bfd_ftran */
+#endif
+
+#define bfd_btran _glp_bfd_btran
+void bfd_btran(BFD *bfd, double x[]);
+/* perform backward transformation (solve system B'*x = b) */
+
+#if 1 /* 30/III-2016 */
+#define bfd_btran_s _glp_bfd_btran_s
+void bfd_btran_s(BFD *bfd, FVS *x);
+/* sparse version of bfd_btran */
+#endif
+
+#define bfd_update _glp_bfd_update
+int bfd_update(BFD *bfd, int j, int len, const int ind[], const double
+ val[]);
+/* update LP basis factorization */
+
+#define bfd_get_count _glp_bfd_get_count
+int bfd_get_count(BFD *bfd);
+/* determine factorization update count */
+
+#define bfd_delete_it _glp_bfd_delete_it
+void bfd_delete_it(BFD *bfd);
+/* delete LP basis factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/bfx.c b/test/monniaux/glpk-4.65/src/draft/bfx.c
new file mode 100644
index 00000000..565480b6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/bfx.c
@@ -0,0 +1,89 @@
+/* bfx.c (LP basis factorization driver, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "bfx.h"
+#include "env.h"
+#include "lux.h"
+
+struct BFX
+{ int valid;
+ LUX *lux;
+};
+
+BFX *bfx_create_binv(void)
+{ /* create factorization of the basis matrix */
+ BFX *bfx;
+ bfx = xmalloc(sizeof(BFX));
+ bfx->valid = 0;
+ bfx->lux = NULL;
+ return bfx;
+}
+
+int bfx_factorize(BFX *binv, int m, int (*col)(void *info, int j,
+ int ind[], mpq_t val[]), void *info)
+{ /* compute factorization of the basis matrix */
+ int ret;
+ xassert(m > 0);
+ if (binv->lux != NULL && binv->lux->n != m)
+ { lux_delete(binv->lux);
+ binv->lux = NULL;
+ }
+ if (binv->lux == NULL)
+ binv->lux = lux_create(m);
+ ret = lux_decomp(binv->lux, col, info);
+ binv->valid = (ret == 0);
+ return ret;
+}
+
+void bfx_ftran(BFX *binv, mpq_t x[], int save)
+{ /* perform forward transformation (FTRAN) */
+ xassert(binv->valid);
+ lux_solve(binv->lux, 0, x);
+ xassert(save == save);
+ return;
+}
+
+void bfx_btran(BFX *binv, mpq_t x[])
+{ /* perform backward transformation (BTRAN) */
+ xassert(binv->valid);
+ lux_solve(binv->lux, 1, x);
+ return;
+}
+
+int bfx_update(BFX *binv, int j)
+{ /* update factorization of the basis matrix */
+ xassert(binv->valid);
+ xassert(1 <= j && j <= binv->lux->n);
+ return 1;
+}
+
+void bfx_delete_binv(BFX *binv)
+{ /* delete factorization of the basis matrix */
+ if (binv->lux != NULL)
+ lux_delete(binv->lux);
+ xfree(binv);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/bfx.h b/test/monniaux/glpk-4.65/src/draft/bfx.h
new file mode 100644
index 00000000..c67d5ea4
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/bfx.h
@@ -0,0 +1,67 @@
+/* bfx.h (LP basis factorization driver, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef BFX_H
+#define BFX_H
+
+#include "mygmp.h"
+
+typedef struct BFX BFX;
+
+#define bfx_create_binv _glp_bfx_create_binv
+BFX *bfx_create_binv(void);
+/* create factorization of the basis matrix */
+
+#define bfx_is_valid _glp_bfx_is_valid
+int bfx_is_valid(BFX *binv);
+/* check if factorization is valid */
+
+#define bfx_invalidate _glp_bfx_invalidate
+void bfx_invalidate(BFX *binv);
+/* invalidate factorization of the basis matrix */
+
+#define bfx_factorize _glp_bfx_factorize
+int bfx_factorize(BFX *binv, int m, int (*col)(void *info, int j,
+ int ind[], mpq_t val[]), void *info);
+/* compute factorization of the basis matrix */
+
+#define bfx_ftran _glp_bfx_ftran
+void bfx_ftran(BFX *binv, mpq_t x[], int save);
+/* perform forward transformation (FTRAN) */
+
+#define bfx_btran _glp_bfx_btran
+void bfx_btran(BFX *binv, mpq_t x[]);
+/* perform backward transformation (BTRAN) */
+
+#define bfx_update _glp_bfx_update
+int bfx_update(BFX *binv, int j);
+/* update factorization of the basis matrix */
+
+#define bfx_delete_binv _glp_bfx_delete_binv
+void bfx_delete_binv(BFX *binv);
+/* delete factorization of the basis matrix */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/draft.h b/test/monniaux/glpk-4.65/src/draft/draft.h
new file mode 100644
index 00000000..cefd2124
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/draft.h
@@ -0,0 +1,22 @@
+/* draft.h */
+
+/* (reserved for copyright notice) */
+
+#ifndef DRAFT_H
+#define DRAFT_H
+
+#if 1 /* 28/III-2016 */
+#define GLP_UNDOC 1
+#endif
+#include "glpk.h"
+
+#if 1 /* 28/XI-2009 */
+int _glp_analyze_row(glp_prob *P, int len, const int ind[],
+ const double val[], int type, double rhs, double eps, int *_piv,
+ double *_x, double *_dx, double *_y, double *_dy, double *_dz);
+/* simulate one iteration of dual simplex method */
+#endif
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi06.c b/test/monniaux/glpk-4.65/src/draft/glpapi06.c
new file mode 100644
index 00000000..a31e3968
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi06.c
@@ -0,0 +1,860 @@
+/* glpapi06.c (simplex method routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+#include "npp.h"
+#if 0 /* 07/XI-2015 */
+#include "glpspx.h"
+#else
+#include "simplex.h"
+#define spx_dual spy_dual
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_simplex - solve LP problem with the simplex method
+*
+* SYNOPSIS
+*
+* int glp_simplex(glp_prob *P, const glp_smcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_simplex is a driver to the LP solver based on the
+* simplex method. This routine retrieves problem data from the
+* specified problem object, calls the solver to solve the problem
+* instance, and stores results of computations back into the problem
+* object.
+*
+* The simplex solver has a set of control parameters. Values of the
+* control parameters can be passed in a structure glp_smcp, which the
+* parameter parm points to.
+*
+* The parameter parm can be specified as NULL, in which case the LP
+* solver uses default settings.
+*
+* RETURNS
+*
+* 0 The LP problem instance has been successfully solved. This code
+* does not necessarily mean that the solver has found optimal
+* solution. It only means that the solution process was successful.
+*
+* GLP_EBADB
+* Unable to start the search, because the initial basis specified
+* in the problem object is invalid--the number of basic (auxiliary
+* and structural) variables is not the same as the number of rows in
+* the problem object.
+*
+* GLP_ESING
+* Unable to start the search, because the basis matrix correspodning
+* to the initial basis is singular within the working precision.
+*
+* GLP_ECOND
+* Unable to start the search, because the basis matrix correspodning
+* to the initial basis is ill-conditioned, i.e. its condition number
+* is too large.
+*
+* GLP_EBOUND
+* Unable to start the search, because some double-bounded variables
+* have incorrect bounds.
+*
+* GLP_EFAIL
+* The search was prematurely terminated due to the solver failure.
+*
+* GLP_EOBJLL
+* The search was prematurely terminated, because the objective
+* function being maximized has reached its lower limit and continues
+* decreasing (dual simplex only).
+*
+* GLP_EOBJUL
+* The search was prematurely terminated, because the objective
+* function being minimized has reached its upper limit and continues
+* increasing (dual simplex only).
+*
+* GLP_EITLIM
+* The search was prematurely terminated, because the simplex
+* iteration limit has been exceeded.
+*
+* GLP_ETMLIM
+* The search was prematurely terminated, because the time limit has
+* been exceeded.
+*
+* GLP_ENOPFS
+* The LP problem instance has no primal feasible solution (only if
+* the LP presolver is used).
+*
+* GLP_ENODFS
+* The LP problem instance has no dual feasible solution (only if the
+* LP presolver is used). */
+
+static void trivial_lp(glp_prob *P, const glp_smcp *parm)
+{ /* solve trivial LP which has empty constraint matrix */
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j;
+ double p_infeas, d_infeas, zeta;
+ P->valid = 0;
+ P->pbs_stat = P->dbs_stat = GLP_FEAS;
+ P->obj_val = P->c0;
+ P->some = 0;
+ p_infeas = d_infeas = 0.0;
+ /* make all auxiliary variables basic */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ row->stat = GLP_BS;
+ row->prim = row->dual = 0.0;
+ /* check primal feasibility */
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ { /* row has lower bound */
+ if (row->lb > + parm->tol_bnd)
+ { P->pbs_stat = GLP_NOFEAS;
+ if (P->some == 0 && parm->meth != GLP_PRIMAL)
+ P->some = i;
+ }
+ if (p_infeas < + row->lb)
+ p_infeas = + row->lb;
+ }
+ if (row->type == GLP_UP || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ { /* row has upper bound */
+ if (row->ub < - parm->tol_bnd)
+ { P->pbs_stat = GLP_NOFEAS;
+ if (P->some == 0 && parm->meth != GLP_PRIMAL)
+ P->some = i;
+ }
+ if (p_infeas < - row->ub)
+ p_infeas = - row->ub;
+ }
+ }
+ /* determine scale factor for the objective row */
+ zeta = 1.0;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (zeta < fabs(col->coef)) zeta = fabs(col->coef);
+ }
+ zeta = (P->dir == GLP_MIN ? +1.0 : -1.0) / zeta;
+ /* make all structural variables non-basic */
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->type == GLP_FR)
+ col->stat = GLP_NF, col->prim = 0.0;
+ else if (col->type == GLP_LO)
+lo: col->stat = GLP_NL, col->prim = col->lb;
+ else if (col->type == GLP_UP)
+up: col->stat = GLP_NU, col->prim = col->ub;
+ else if (col->type == GLP_DB)
+ { if (zeta * col->coef > 0.0)
+ goto lo;
+ else if (zeta * col->coef < 0.0)
+ goto up;
+ else if (fabs(col->lb) <= fabs(col->ub))
+ goto lo;
+ else
+ goto up;
+ }
+ else if (col->type == GLP_FX)
+ col->stat = GLP_NS, col->prim = col->lb;
+ col->dual = col->coef;
+ P->obj_val += col->coef * col->prim;
+ /* check dual feasibility */
+ if (col->type == GLP_FR || col->type == GLP_LO)
+ { /* column has no upper bound */
+ if (zeta * col->dual < - parm->tol_dj)
+ { P->dbs_stat = GLP_NOFEAS;
+ if (P->some == 0 && parm->meth == GLP_PRIMAL)
+ P->some = P->m + j;
+ }
+ if (d_infeas < - zeta * col->dual)
+ d_infeas = - zeta * col->dual;
+ }
+ if (col->type == GLP_FR || col->type == GLP_UP)
+ { /* column has no lower bound */
+ if (zeta * col->dual > + parm->tol_dj)
+ { P->dbs_stat = GLP_NOFEAS;
+ if (P->some == 0 && parm->meth == GLP_PRIMAL)
+ P->some = P->m + j;
+ }
+ if (d_infeas < + zeta * col->dual)
+ d_infeas = + zeta * col->dual;
+ }
+ }
+ /* simulate the simplex solver output */
+ if (parm->msg_lev >= GLP_MSG_ON && parm->out_dly == 0)
+ { xprintf("~%6d: obj = %17.9e infeas = %10.3e\n", P->it_cnt,
+ P->obj_val, parm->meth == GLP_PRIMAL ? p_infeas : d_infeas);
+ }
+ if (parm->msg_lev >= GLP_MSG_ALL && parm->out_dly == 0)
+ { if (P->pbs_stat == GLP_FEAS && P->dbs_stat == GLP_FEAS)
+ xprintf("OPTIMAL SOLUTION FOUND\n");
+ else if (P->pbs_stat == GLP_NOFEAS)
+ xprintf("PROBLEM HAS NO FEASIBLE SOLUTION\n");
+ else if (parm->meth == GLP_PRIMAL)
+ xprintf("PROBLEM HAS UNBOUNDED SOLUTION\n");
+ else
+ xprintf("PROBLEM HAS NO DUAL FEASIBLE SOLUTION\n");
+ }
+ return;
+}
+
+static int solve_lp(glp_prob *P, const glp_smcp *parm)
+{ /* solve LP directly without using the preprocessor */
+ int ret;
+ if (!glp_bf_exists(P))
+ { ret = glp_factorize(P);
+ if (ret == 0)
+ ;
+ else if (ret == GLP_EBADB)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_simplex: initial basis is invalid\n");
+ }
+ else if (ret == GLP_ESING)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_simplex: initial basis is singular\n");
+ }
+ else if (ret == GLP_ECOND)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf(
+ "glp_simplex: initial basis is ill-conditioned\n");
+ }
+ else
+ xassert(ret != ret);
+ if (ret != 0) goto done;
+ }
+ if (parm->meth == GLP_PRIMAL)
+ ret = spx_primal(P, parm);
+ else if (parm->meth == GLP_DUALP)
+ { ret = spx_dual(P, parm);
+ if (ret == GLP_EFAIL && P->valid)
+ ret = spx_primal(P, parm);
+ }
+ else if (parm->meth == GLP_DUAL)
+ ret = spx_dual(P, parm);
+ else
+ xassert(parm != parm);
+done: return ret;
+}
+
+static int preprocess_and_solve_lp(glp_prob *P, const glp_smcp *parm)
+{ /* solve LP using the preprocessor */
+ NPP *npp;
+ glp_prob *lp = NULL;
+ glp_bfcp bfcp;
+ int ret;
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Preprocessing...\n");
+ /* create preprocessor workspace */
+ npp = npp_create_wksp();
+ /* load original problem into the preprocessor workspace */
+ npp_load_prob(npp, P, GLP_OFF, GLP_SOL, GLP_OFF);
+ /* process LP prior to applying primal/dual simplex method */
+ ret = npp_simplex(npp, parm);
+ if (ret == 0)
+ ;
+ else if (ret == GLP_ENOPFS)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("PROBLEM HAS NO PRIMAL FEASIBLE SOLUTION\n");
+ }
+ else if (ret == GLP_ENODFS)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("PROBLEM HAS NO DUAL FEASIBLE SOLUTION\n");
+ }
+ else
+ xassert(ret != ret);
+ if (ret != 0) goto done;
+ /* build transformed LP */
+ lp = glp_create_prob();
+ npp_build_prob(npp, lp);
+ /* if the transformed LP is empty, it has empty solution, which
+ is optimal */
+ if (lp->m == 0 && lp->n == 0)
+ { lp->pbs_stat = lp->dbs_stat = GLP_FEAS;
+ lp->obj_val = lp->c0;
+ if (parm->msg_lev >= GLP_MSG_ON && parm->out_dly == 0)
+ { xprintf("~%6d: obj = %17.9e infeas = %10.3e\n", P->it_cnt,
+ lp->obj_val, 0.0);
+ }
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("OPTIMAL SOLUTION FOUND BY LP PREPROCESSOR\n");
+ goto post;
+ }
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ { xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ lp->m, lp->m == 1 ? "" : "s", lp->n, lp->n == 1 ? "" : "s",
+ lp->nnz, lp->nnz == 1 ? "" : "s");
+ }
+ /* inherit basis factorization control parameters */
+ glp_get_bfcp(P, &bfcp);
+ glp_set_bfcp(lp, &bfcp);
+ /* scale the transformed problem */
+ { ENV *env = get_env_ptr();
+ int term_out = env->term_out;
+ if (!term_out || parm->msg_lev < GLP_MSG_ALL)
+ env->term_out = GLP_OFF;
+ else
+ env->term_out = GLP_ON;
+ glp_scale_prob(lp, GLP_SF_AUTO);
+ env->term_out = term_out;
+ }
+ /* build advanced initial basis */
+ { ENV *env = get_env_ptr();
+ int term_out = env->term_out;
+ if (!term_out || parm->msg_lev < GLP_MSG_ALL)
+ env->term_out = GLP_OFF;
+ else
+ env->term_out = GLP_ON;
+ glp_adv_basis(lp, 0);
+ env->term_out = term_out;
+ }
+ /* solve the transformed LP */
+ lp->it_cnt = P->it_cnt;
+ ret = solve_lp(lp, parm);
+ P->it_cnt = lp->it_cnt;
+ /* only optimal solution can be postprocessed */
+ if (!(ret == 0 && lp->pbs_stat == GLP_FEAS && lp->dbs_stat ==
+ GLP_FEAS))
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_simplex: unable to recover undefined or non-op"
+ "timal solution\n");
+ if (ret == 0)
+ { if (lp->pbs_stat == GLP_NOFEAS)
+ ret = GLP_ENOPFS;
+ else if (lp->dbs_stat == GLP_NOFEAS)
+ ret = GLP_ENODFS;
+ else
+ xassert(lp != lp);
+ }
+ goto done;
+ }
+post: /* postprocess solution from the transformed LP */
+ npp_postprocess(npp, lp);
+ /* the transformed LP is no longer needed */
+ glp_delete_prob(lp), lp = NULL;
+ /* store solution to the original problem */
+ npp_unload_sol(npp, P);
+ /* the original LP has been successfully solved */
+ ret = 0;
+done: /* delete the transformed LP, if it exists */
+ if (lp != NULL) glp_delete_prob(lp);
+ /* delete preprocessor workspace */
+ npp_delete_wksp(npp);
+ return ret;
+}
+
+int glp_simplex(glp_prob *P, const glp_smcp *parm)
+{ /* solve LP problem with the simplex method */
+ glp_smcp _parm;
+ int i, j, ret;
+ /* check problem object */
+#if 0 /* 04/IV-2016 */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_simplex: P = %p; invalid problem object\n", P);
+#endif
+ if (P->tree != NULL && P->tree->reason != 0)
+ xerror("glp_simplex: operation not allowed\n");
+ /* check control parameters */
+ if (parm == NULL)
+ parm = &_parm, glp_init_smcp((glp_smcp *)parm);
+ if (!(parm->msg_lev == GLP_MSG_OFF ||
+ parm->msg_lev == GLP_MSG_ERR ||
+ parm->msg_lev == GLP_MSG_ON ||
+ parm->msg_lev == GLP_MSG_ALL ||
+ parm->msg_lev == GLP_MSG_DBG))
+ xerror("glp_simplex: msg_lev = %d; invalid parameter\n",
+ parm->msg_lev);
+ if (!(parm->meth == GLP_PRIMAL ||
+ parm->meth == GLP_DUALP ||
+ parm->meth == GLP_DUAL))
+ xerror("glp_simplex: meth = %d; invalid parameter\n",
+ parm->meth);
+ if (!(parm->pricing == GLP_PT_STD ||
+ parm->pricing == GLP_PT_PSE))
+ xerror("glp_simplex: pricing = %d; invalid parameter\n",
+ parm->pricing);
+ if (!(parm->r_test == GLP_RT_STD ||
+#if 1 /* 16/III-2016 */
+ parm->r_test == GLP_RT_FLIP ||
+#endif
+ parm->r_test == GLP_RT_HAR))
+ xerror("glp_simplex: r_test = %d; invalid parameter\n",
+ parm->r_test);
+ if (!(0.0 < parm->tol_bnd && parm->tol_bnd < 1.0))
+ xerror("glp_simplex: tol_bnd = %g; invalid parameter\n",
+ parm->tol_bnd);
+ if (!(0.0 < parm->tol_dj && parm->tol_dj < 1.0))
+ xerror("glp_simplex: tol_dj = %g; invalid parameter\n",
+ parm->tol_dj);
+ if (!(0.0 < parm->tol_piv && parm->tol_piv < 1.0))
+ xerror("glp_simplex: tol_piv = %g; invalid parameter\n",
+ parm->tol_piv);
+ if (parm->it_lim < 0)
+ xerror("glp_simplex: it_lim = %d; invalid parameter\n",
+ parm->it_lim);
+ if (parm->tm_lim < 0)
+ xerror("glp_simplex: tm_lim = %d; invalid parameter\n",
+ parm->tm_lim);
+#if 0 /* 15/VII-2017 */
+ if (parm->out_frq < 1)
+#else
+ if (parm->out_frq < 0)
+#endif
+ xerror("glp_simplex: out_frq = %d; invalid parameter\n",
+ parm->out_frq);
+ if (parm->out_dly < 0)
+ xerror("glp_simplex: out_dly = %d; invalid parameter\n",
+ parm->out_dly);
+ if (!(parm->presolve == GLP_ON || parm->presolve == GLP_OFF))
+ xerror("glp_simplex: presolve = %d; invalid parameter\n",
+ parm->presolve);
+#if 1 /* 11/VII-2017 */
+ if (!(parm->excl == GLP_ON || parm->excl == GLP_OFF))
+ xerror("glp_simplex: excl = %d; invalid parameter\n",
+ parm->excl);
+ if (!(parm->shift == GLP_ON || parm->shift == GLP_OFF))
+ xerror("glp_simplex: shift = %d; invalid parameter\n",
+ parm->shift);
+ if (!(parm->aorn == GLP_USE_AT || parm->aorn == GLP_USE_NT))
+ xerror("glp_simplex: aorn = %d; invalid parameter\n",
+ parm->aorn);
+#endif
+ /* basic solution is currently undefined */
+ P->pbs_stat = P->dbs_stat = GLP_UNDEF;
+ P->obj_val = 0.0;
+ P->some = 0;
+ /* check bounds of double-bounded variables */
+ for (i = 1; i <= P->m; i++)
+ { GLPROW *row = P->row[i];
+ if (row->type == GLP_DB && row->lb >= row->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_simplex: row %d: lb = %g, ub = %g; incorrec"
+ "t bounds\n", i, row->lb, row->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if (col->type == GLP_DB && col->lb >= col->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_simplex: column %d: lb = %g, ub = %g; incor"
+ "rect bounds\n", j, col->lb, col->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ /* solve LP problem */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ { xprintf("GLPK Simplex Optimizer, v%s\n", glp_version());
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" : "s",
+ P->nnz, P->nnz == 1 ? "" : "s");
+ }
+ if (P->nnz == 0)
+ trivial_lp(P, parm), ret = 0;
+ else if (!parm->presolve)
+ ret = solve_lp(P, parm);
+ else
+ ret = preprocess_and_solve_lp(P, parm);
+done: /* return to the application program */
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_init_smcp - initialize simplex method control parameters
+*
+* SYNOPSIS
+*
+* void glp_init_smcp(glp_smcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_init_smcp initializes control parameters, which are
+* used by the simplex solver, with default values.
+*
+* Default values of the control parameters are stored in a glp_smcp
+* structure, which the parameter parm points to. */
+
+void glp_init_smcp(glp_smcp *parm)
+{ parm->msg_lev = GLP_MSG_ALL;
+ parm->meth = GLP_PRIMAL;
+ parm->pricing = GLP_PT_PSE;
+ parm->r_test = GLP_RT_HAR;
+ parm->tol_bnd = 1e-7;
+ parm->tol_dj = 1e-7;
+#if 0 /* 07/XI-2015 */
+ parm->tol_piv = 1e-10;
+#else
+ parm->tol_piv = 1e-9;
+#endif
+ parm->obj_ll = -DBL_MAX;
+ parm->obj_ul = +DBL_MAX;
+ parm->it_lim = INT_MAX;
+ parm->tm_lim = INT_MAX;
+#if 0 /* 15/VII-2017 */
+ parm->out_frq = 500;
+#else
+ parm->out_frq = 5000; /* 5 seconds */
+#endif
+ parm->out_dly = 0;
+ parm->presolve = GLP_OFF;
+#if 1 /* 11/VII-2017 */
+ parm->excl = GLP_ON;
+ parm->shift = GLP_ON;
+ parm->aorn = GLP_USE_NT;
+#endif
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_status - retrieve generic status of basic solution
+*
+* SYNOPSIS
+*
+* int glp_get_status(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_status reports the generic status of the basic
+* solution for the specified problem object as follows:
+*
+* GLP_OPT - solution is optimal;
+* GLP_FEAS - solution is feasible;
+* GLP_INFEAS - solution is infeasible;
+* GLP_NOFEAS - problem has no feasible solution;
+* GLP_UNBND - problem has unbounded solution;
+* GLP_UNDEF - solution is undefined. */
+
+int glp_get_status(glp_prob *lp)
+{ int status;
+ status = glp_get_prim_stat(lp);
+ switch (status)
+ { case GLP_FEAS:
+ switch (glp_get_dual_stat(lp))
+ { case GLP_FEAS:
+ status = GLP_OPT;
+ break;
+ case GLP_NOFEAS:
+ status = GLP_UNBND;
+ break;
+ case GLP_UNDEF:
+ case GLP_INFEAS:
+ status = status;
+ break;
+ default:
+ xassert(lp != lp);
+ }
+ break;
+ case GLP_UNDEF:
+ case GLP_INFEAS:
+ case GLP_NOFEAS:
+ status = status;
+ break;
+ default:
+ xassert(lp != lp);
+ }
+ return status;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_prim_stat - retrieve status of primal basic solution
+*
+* SYNOPSIS
+*
+* int glp_get_prim_stat(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_prim_stat reports the status of the primal basic
+* solution for the specified problem object as follows:
+*
+* GLP_UNDEF - primal solution is undefined;
+* GLP_FEAS - primal solution is feasible;
+* GLP_INFEAS - primal solution is infeasible;
+* GLP_NOFEAS - no primal feasible solution exists. */
+
+int glp_get_prim_stat(glp_prob *lp)
+{ int pbs_stat = lp->pbs_stat;
+ return pbs_stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_dual_stat - retrieve status of dual basic solution
+*
+* SYNOPSIS
+*
+* int glp_get_dual_stat(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_dual_stat reports the status of the dual basic
+* solution for the specified problem object as follows:
+*
+* GLP_UNDEF - dual solution is undefined;
+* GLP_FEAS - dual solution is feasible;
+* GLP_INFEAS - dual solution is infeasible;
+* GLP_NOFEAS - no dual feasible solution exists. */
+
+int glp_get_dual_stat(glp_prob *lp)
+{ int dbs_stat = lp->dbs_stat;
+ return dbs_stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_obj_val - retrieve objective value (basic solution)
+*
+* SYNOPSIS
+*
+* double glp_get_obj_val(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_obj_val returns value of the objective function
+* for basic solution. */
+
+double glp_get_obj_val(glp_prob *lp)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double z;
+ z = lp->obj_val;
+ /*if (cps->round && fabs(z) < 1e-9) z = 0.0;*/
+ return z;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_stat - retrieve row status
+*
+* SYNOPSIS
+*
+* int glp_get_row_stat(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_stat returns current status assigned to the
+* auxiliary variable associated with i-th row as follows:
+*
+* GLP_BS - basic variable;
+* GLP_NL - non-basic variable on its lower bound;
+* GLP_NU - non-basic variable on its upper bound;
+* GLP_NF - non-basic free (unbounded) variable;
+* GLP_NS - non-basic fixed variable. */
+
+int glp_get_row_stat(glp_prob *lp, int i)
+{ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_stat: i = %d; row number out of range\n",
+ i);
+ return lp->row[i]->stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_prim - retrieve row primal value (basic solution)
+*
+* SYNOPSIS
+*
+* double glp_get_row_prim(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_prim returns primal value of the auxiliary
+* variable associated with i-th row. */
+
+double glp_get_row_prim(glp_prob *lp, int i)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double prim;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_prim: i = %d; row number out of range\n",
+ i);
+ prim = lp->row[i]->prim;
+ /*if (cps->round && fabs(prim) < 1e-9) prim = 0.0;*/
+ return prim;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_dual - retrieve row dual value (basic solution)
+*
+* SYNOPSIS
+*
+* double glp_get_row_dual(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_dual returns dual value (i.e. reduced cost)
+* of the auxiliary variable associated with i-th row. */
+
+double glp_get_row_dual(glp_prob *lp, int i)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double dual;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_dual: i = %d; row number out of range\n",
+ i);
+ dual = lp->row[i]->dual;
+ /*if (cps->round && fabs(dual) < 1e-9) dual = 0.0;*/
+ return dual;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_stat - retrieve column status
+*
+* SYNOPSIS
+*
+* int glp_get_col_stat(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_stat returns current status assigned to the
+* structural variable associated with j-th column as follows:
+*
+* GLP_BS - basic variable;
+* GLP_NL - non-basic variable on its lower bound;
+* GLP_NU - non-basic variable on its upper bound;
+* GLP_NF - non-basic free (unbounded) variable;
+* GLP_NS - non-basic fixed variable. */
+
+int glp_get_col_stat(glp_prob *lp, int j)
+{ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_stat: j = %d; column number out of range\n"
+ , j);
+ return lp->col[j]->stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_prim - retrieve column primal value (basic solution)
+*
+* SYNOPSIS
+*
+* double glp_get_col_prim(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_prim returns primal value of the structural
+* variable associated with j-th column. */
+
+double glp_get_col_prim(glp_prob *lp, int j)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double prim;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_prim: j = %d; column number out of range\n"
+ , j);
+ prim = lp->col[j]->prim;
+ /*if (cps->round && fabs(prim) < 1e-9) prim = 0.0;*/
+ return prim;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_dual - retrieve column dual value (basic solution)
+*
+* SYNOPSIS
+*
+* double glp_get_col_dual(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_dual returns dual value (i.e. reduced cost)
+* of the structural variable associated with j-th column. */
+
+double glp_get_col_dual(glp_prob *lp, int j)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double dual;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_dual: j = %d; column number out of range\n"
+ , j);
+ dual = lp->col[j]->dual;
+ /*if (cps->round && fabs(dual) < 1e-9) dual = 0.0;*/
+ return dual;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_unbnd_ray - determine variable causing unboundedness
+*
+* SYNOPSIS
+*
+* int glp_get_unbnd_ray(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_get_unbnd_ray returns the number k of a variable,
+* which causes primal or dual unboundedness. If 1 <= k <= m, it is
+* k-th auxiliary variable, and if m+1 <= k <= m+n, it is (k-m)-th
+* structural variable, where m is the number of rows, n is the number
+* of columns in the problem object. If such variable is not defined,
+* the routine returns 0.
+*
+* COMMENTS
+*
+* If it is not exactly known which version of the simplex solver
+* detected unboundedness, i.e. whether the unboundedness is primal or
+* dual, it is sufficient to check the status of the variable reported
+* with the routine glp_get_row_stat or glp_get_col_stat. If the
+* variable is non-basic, the unboundedness is primal, otherwise, if
+* the variable is basic, the unboundedness is dual (the latter case
+* means that the problem has no primal feasible dolution). */
+
+int glp_get_unbnd_ray(glp_prob *lp)
+{ int k;
+ k = lp->some;
+ xassert(k >= 0);
+ if (k > lp->m + lp->n) k = 0;
+ return k;
+}
+
+#if 1 /* 08/VIII-2013 */
+int glp_get_it_cnt(glp_prob *P)
+{ /* get simplex solver iteration count */
+ return P->it_cnt;
+}
+#endif
+
+#if 1 /* 08/VIII-2013 */
+void glp_set_it_cnt(glp_prob *P, int it_cnt)
+{ /* set simplex solver iteration count */
+ P->it_cnt = it_cnt;
+ return;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi07.c b/test/monniaux/glpk-4.65/src/draft/glpapi07.c
new file mode 100644
index 00000000..9ac294bd
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi07.c
@@ -0,0 +1,499 @@
+/* glpapi07.c (exact simplex solver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "draft.h"
+#include "glpssx.h"
+#include "misc.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_exact - solve LP problem in exact arithmetic
+*
+* SYNOPSIS
+*
+* int glp_exact(glp_prob *lp, const glp_smcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_exact is a tentative implementation of the primal
+* two-phase simplex method based on exact (rational) arithmetic. It is
+* similar to the routine glp_simplex, however, for all internal
+* computations it uses arithmetic of rational numbers, which is exact
+* in mathematical sense, i.e. free of round-off errors unlike floating
+* point arithmetic.
+*
+* Note that the routine glp_exact uses inly two control parameters
+* passed in the structure glp_smcp, namely, it_lim and tm_lim.
+*
+* RETURNS
+*
+* 0 The LP problem instance has been successfully solved. This code
+* does not necessarily mean that the solver has found optimal
+* solution. It only means that the solution process was successful.
+*
+* GLP_EBADB
+* Unable to start the search, because the initial basis specified
+* in the problem object is invalid--the number of basic (auxiliary
+* and structural) variables is not the same as the number of rows in
+* the problem object.
+*
+* GLP_ESING
+* Unable to start the search, because the basis matrix correspodning
+* to the initial basis is exactly singular.
+*
+* GLP_EBOUND
+* Unable to start the search, because some double-bounded variables
+* have incorrect bounds.
+*
+* GLP_EFAIL
+* The problem has no rows/columns.
+*
+* GLP_EITLIM
+* The search was prematurely terminated, because the simplex
+* iteration limit has been exceeded.
+*
+* GLP_ETMLIM
+* The search was prematurely terminated, because the time limit has
+* been exceeded. */
+
+static void set_d_eps(mpq_t x, double val)
+{ /* convert double val to rational x obtaining a more adequate
+ fraction than provided by mpq_set_d due to allowing a small
+ approximation error specified by a given relative tolerance;
+ for example, mpq_set_d would give the following
+ 1/3 ~= 0.333333333333333314829616256247391... ->
+ -> 6004799503160661/18014398509481984
+ while this routine gives exactly 1/3 */
+ int s, n, j;
+ double f, p, q, eps = 1e-9;
+ mpq_t temp;
+ xassert(-DBL_MAX <= val && val <= +DBL_MAX);
+#if 1 /* 30/VII-2008 */
+ if (val == floor(val))
+ { /* if val is integral, do not approximate */
+ mpq_set_d(x, val);
+ goto done;
+ }
+#endif
+ if (val > 0.0)
+ s = +1;
+ else if (val < 0.0)
+ s = -1;
+ else
+ { mpq_set_si(x, 0, 1);
+ goto done;
+ }
+ f = frexp(fabs(val), &n);
+ /* |val| = f * 2^n, where 0.5 <= f < 1.0 */
+ fp2rat(f, 0.1 * eps, &p, &q);
+ /* f ~= p / q, where p and q are integers */
+ mpq_init(temp);
+ mpq_set_d(x, p);
+ mpq_set_d(temp, q);
+ mpq_div(x, x, temp);
+ mpq_set_si(temp, 1, 1);
+ for (j = 1; j <= abs(n); j++)
+ mpq_add(temp, temp, temp);
+ if (n > 0)
+ mpq_mul(x, x, temp);
+ else if (n < 0)
+ mpq_div(x, x, temp);
+ mpq_clear(temp);
+ if (s < 0) mpq_neg(x, x);
+ /* check that the desired tolerance has been attained */
+ xassert(fabs(val - mpq_get_d(x)) <= eps * (1.0 + fabs(val)));
+done: return;
+}
+
+static void load_data(SSX *ssx, glp_prob *lp)
+{ /* load LP problem data into simplex solver workspace */
+ int m = ssx->m;
+ int n = ssx->n;
+ int nnz = ssx->A_ptr[n+1]-1;
+ int j, k, type, loc, len, *ind;
+ double lb, ub, coef, *val;
+ xassert(lp->m == m);
+ xassert(lp->n == n);
+ xassert(lp->nnz == nnz);
+ /* types and bounds of rows and columns */
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ { type = lp->row[k]->type;
+ lb = lp->row[k]->lb;
+ ub = lp->row[k]->ub;
+ }
+ else
+ { type = lp->col[k-m]->type;
+ lb = lp->col[k-m]->lb;
+ ub = lp->col[k-m]->ub;
+ }
+ switch (type)
+ { case GLP_FR: type = SSX_FR; break;
+ case GLP_LO: type = SSX_LO; break;
+ case GLP_UP: type = SSX_UP; break;
+ case GLP_DB: type = SSX_DB; break;
+ case GLP_FX: type = SSX_FX; break;
+ default: xassert(type != type);
+ }
+ ssx->type[k] = type;
+ set_d_eps(ssx->lb[k], lb);
+ set_d_eps(ssx->ub[k], ub);
+ }
+ /* optimization direction */
+ switch (lp->dir)
+ { case GLP_MIN: ssx->dir = SSX_MIN; break;
+ case GLP_MAX: ssx->dir = SSX_MAX; break;
+ default: xassert(lp != lp);
+ }
+ /* objective coefficients */
+ for (k = 0; k <= m+n; k++)
+ { if (k == 0)
+ coef = lp->c0;
+ else if (k <= m)
+ coef = 0.0;
+ else
+ coef = lp->col[k-m]->coef;
+ set_d_eps(ssx->coef[k], coef);
+ }
+ /* constraint coefficients */
+ ind = xcalloc(1+m, sizeof(int));
+ val = xcalloc(1+m, sizeof(double));
+ loc = 0;
+ for (j = 1; j <= n; j++)
+ { ssx->A_ptr[j] = loc+1;
+ len = glp_get_mat_col(lp, j, ind, val);
+ for (k = 1; k <= len; k++)
+ { loc++;
+ ssx->A_ind[loc] = ind[k];
+ set_d_eps(ssx->A_val[loc], val[k]);
+ }
+ }
+ xassert(loc == nnz);
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+static int load_basis(SSX *ssx, glp_prob *lp)
+{ /* load current LP basis into simplex solver workspace */
+ int m = ssx->m;
+ int n = ssx->n;
+ int *type = ssx->type;
+ int *stat = ssx->stat;
+ int *Q_row = ssx->Q_row;
+ int *Q_col = ssx->Q_col;
+ int i, j, k;
+ xassert(lp->m == m);
+ xassert(lp->n == n);
+ /* statuses of rows and columns */
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ stat[k] = lp->row[k]->stat;
+ else
+ stat[k] = lp->col[k-m]->stat;
+ switch (stat[k])
+ { case GLP_BS:
+ stat[k] = SSX_BS;
+ break;
+ case GLP_NL:
+ stat[k] = SSX_NL;
+ xassert(type[k] == SSX_LO || type[k] == SSX_DB);
+ break;
+ case GLP_NU:
+ stat[k] = SSX_NU;
+ xassert(type[k] == SSX_UP || type[k] == SSX_DB);
+ break;
+ case GLP_NF:
+ stat[k] = SSX_NF;
+ xassert(type[k] == SSX_FR);
+ break;
+ case GLP_NS:
+ stat[k] = SSX_NS;
+ xassert(type[k] == SSX_FX);
+ break;
+ default:
+ xassert(stat != stat);
+ }
+ }
+ /* build permutation matix Q */
+ i = j = 0;
+ for (k = 1; k <= m+n; k++)
+ { if (stat[k] == SSX_BS)
+ { i++;
+ if (i > m) return 1;
+ Q_row[k] = i, Q_col[i] = k;
+ }
+ else
+ { j++;
+ if (j > n) return 1;
+ Q_row[k] = m+j, Q_col[m+j] = k;
+ }
+ }
+ xassert(i == m && j == n);
+ return 0;
+}
+
+int glp_exact(glp_prob *lp, const glp_smcp *parm)
+{ glp_smcp _parm;
+ SSX *ssx;
+ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int i, j, k, type, pst, dst, ret, stat;
+ double lb, ub, prim, dual, sum;
+ if (parm == NULL)
+ parm = &_parm, glp_init_smcp((glp_smcp *)parm);
+ /* check control parameters */
+#if 1 /* 25/XI-2017 */
+ switch (parm->msg_lev)
+ { case GLP_MSG_OFF:
+ case GLP_MSG_ERR:
+ case GLP_MSG_ON:
+ case GLP_MSG_ALL:
+ case GLP_MSG_DBG:
+ break;
+ default:
+ xerror("glp_exact: msg_lev = %d; invalid parameter\n",
+ parm->msg_lev);
+ }
+#endif
+ if (parm->it_lim < 0)
+ xerror("glp_exact: it_lim = %d; invalid parameter\n",
+ parm->it_lim);
+ if (parm->tm_lim < 0)
+ xerror("glp_exact: tm_lim = %d; invalid parameter\n",
+ parm->tm_lim);
+ /* the problem must have at least one row and one column */
+ if (!(m > 0 && n > 0))
+#if 0 /* 25/XI-2017 */
+ { xprintf("glp_exact: problem has no rows/columns\n");
+#else
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_exact: problem has no rows/columns\n");
+#endif
+ return GLP_EFAIL;
+ }
+#if 1
+ /* basic solution is currently undefined */
+ lp->pbs_stat = lp->dbs_stat = GLP_UNDEF;
+ lp->obj_val = 0.0;
+ lp->some = 0;
+#endif
+ /* check that all double-bounded variables have correct bounds */
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ { type = lp->row[k]->type;
+ lb = lp->row[k]->lb;
+ ub = lp->row[k]->ub;
+ }
+ else
+ { type = lp->col[k-m]->type;
+ lb = lp->col[k-m]->lb;
+ ub = lp->col[k-m]->ub;
+ }
+ if (type == GLP_DB && lb >= ub)
+#if 0 /* 25/XI-2017 */
+ { xprintf("glp_exact: %s %d has invalid bounds\n",
+ k <= m ? "row" : "column", k <= m ? k : k-m);
+#else
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_exact: %s %d has invalid bounds\n",
+ k <= m ? "row" : "column", k <= m ? k : k-m);
+#endif
+ return GLP_EBOUND;
+ }
+ }
+ /* create the simplex solver workspace */
+#if 1 /* 25/XI-2017 */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ {
+#endif
+ xprintf("glp_exact: %d rows, %d columns, %d non-zeros\n",
+ m, n, nnz);
+#ifdef HAVE_GMP
+ xprintf("GNU MP bignum library is being used\n");
+#else
+ xprintf("GLPK bignum module is being used\n");
+ xprintf("(Consider installing GNU MP to attain a much better perf"
+ "ormance.)\n");
+#endif
+#if 1 /* 25/XI-2017 */
+ }
+#endif
+ ssx = ssx_create(m, n, nnz);
+ /* load LP problem data into the workspace */
+ load_data(ssx, lp);
+ /* load current LP basis into the workspace */
+ if (load_basis(ssx, lp))
+#if 0 /* 25/XI-2017 */
+ { xprintf("glp_exact: initial LP basis is invalid\n");
+#else
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_exact: initial LP basis is invalid\n");
+#endif
+ ret = GLP_EBADB;
+ goto done;
+ }
+#if 0
+ /* inherit some control parameters from the LP object */
+ ssx->it_lim = lpx_get_int_parm(lp, LPX_K_ITLIM);
+ ssx->it_cnt = lpx_get_int_parm(lp, LPX_K_ITCNT);
+ ssx->tm_lim = lpx_get_real_parm(lp, LPX_K_TMLIM);
+#else
+#if 1 /* 25/XI-2017 */
+ ssx->msg_lev = parm->msg_lev;
+#endif
+ ssx->it_lim = parm->it_lim;
+ ssx->it_cnt = lp->it_cnt;
+ ssx->tm_lim = (double)parm->tm_lim / 1000.0;
+#endif
+ ssx->out_frq = 5.0;
+ ssx->tm_beg = xtime();
+#if 0 /* 10/VI-2013 */
+ ssx->tm_lag = xlset(0);
+#else
+ ssx->tm_lag = 0.0;
+#endif
+ /* solve LP */
+ ret = ssx_driver(ssx);
+#if 0
+ /* copy back some statistics to the LP object */
+ lpx_set_int_parm(lp, LPX_K_ITLIM, ssx->it_lim);
+ lpx_set_int_parm(lp, LPX_K_ITCNT, ssx->it_cnt);
+ lpx_set_real_parm(lp, LPX_K_TMLIM, ssx->tm_lim);
+#else
+ lp->it_cnt = ssx->it_cnt;
+#endif
+ /* analyze the return code */
+ switch (ret)
+ { case 0:
+ /* optimal solution found */
+ ret = 0;
+ pst = dst = GLP_FEAS;
+ break;
+ case 1:
+ /* problem has no feasible solution */
+ ret = 0;
+ pst = GLP_NOFEAS, dst = GLP_INFEAS;
+ break;
+ case 2:
+ /* problem has unbounded solution */
+ ret = 0;
+ pst = GLP_FEAS, dst = GLP_NOFEAS;
+#if 1
+ xassert(1 <= ssx->q && ssx->q <= n);
+ lp->some = ssx->Q_col[m + ssx->q];
+ xassert(1 <= lp->some && lp->some <= m+n);
+#endif
+ break;
+ case 3:
+ /* iteration limit exceeded (phase I) */
+ ret = GLP_EITLIM;
+ pst = dst = GLP_INFEAS;
+ break;
+ case 4:
+ /* iteration limit exceeded (phase II) */
+ ret = GLP_EITLIM;
+ pst = GLP_FEAS, dst = GLP_INFEAS;
+ break;
+ case 5:
+ /* time limit exceeded (phase I) */
+ ret = GLP_ETMLIM;
+ pst = dst = GLP_INFEAS;
+ break;
+ case 6:
+ /* time limit exceeded (phase II) */
+ ret = GLP_ETMLIM;
+ pst = GLP_FEAS, dst = GLP_INFEAS;
+ break;
+ case 7:
+ /* initial basis matrix is singular */
+ ret = GLP_ESING;
+ goto done;
+ default:
+ xassert(ret != ret);
+ }
+ /* store final basic solution components into LP object */
+ lp->pbs_stat = pst;
+ lp->dbs_stat = dst;
+ sum = lp->c0;
+ for (k = 1; k <= m+n; k++)
+ { if (ssx->stat[k] == SSX_BS)
+ { i = ssx->Q_row[k]; /* x[k] = xB[i] */
+ xassert(1 <= i && i <= m);
+ stat = GLP_BS;
+ prim = mpq_get_d(ssx->bbar[i]);
+ dual = 0.0;
+ }
+ else
+ { j = ssx->Q_row[k] - m; /* x[k] = xN[j] */
+ xassert(1 <= j && j <= n);
+ switch (ssx->stat[k])
+ { case SSX_NF:
+ stat = GLP_NF;
+ prim = 0.0;
+ break;
+ case SSX_NL:
+ stat = GLP_NL;
+ prim = mpq_get_d(ssx->lb[k]);
+ break;
+ case SSX_NU:
+ stat = GLP_NU;
+ prim = mpq_get_d(ssx->ub[k]);
+ break;
+ case SSX_NS:
+ stat = GLP_NS;
+ prim = mpq_get_d(ssx->lb[k]);
+ break;
+ default:
+ xassert(ssx != ssx);
+ }
+ dual = mpq_get_d(ssx->cbar[j]);
+ }
+ if (k <= m)
+ { glp_set_row_stat(lp, k, stat);
+ lp->row[k]->prim = prim;
+ lp->row[k]->dual = dual;
+ }
+ else
+ { glp_set_col_stat(lp, k-m, stat);
+ lp->col[k-m]->prim = prim;
+ lp->col[k-m]->dual = dual;
+ sum += lp->col[k-m]->coef * prim;
+ }
+ }
+ lp->obj_val = sum;
+done: /* delete the simplex solver workspace */
+ ssx_delete(ssx);
+#if 1 /* 23/XI-2015 */
+ xassert(gmp_pool_count() == 0);
+ gmp_free_mem();
+#endif
+ /* return to the application program */
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi08.c b/test/monniaux/glpk-4.65/src/draft/glpapi08.c
new file mode 100644
index 00000000..652292cb
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi08.c
@@ -0,0 +1,388 @@
+/* glpapi08.c (interior-point method routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpipm.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_interior - solve LP problem with the interior-point method
+*
+* SYNOPSIS
+*
+* int glp_interior(glp_prob *P, const glp_iptcp *parm);
+*
+* The routine glp_interior is a driver to the LP solver based on the
+* interior-point method.
+*
+* The interior-point solver has a set of control parameters. Values of
+* the control parameters can be passed in a structure glp_iptcp, which
+* the parameter parm points to.
+*
+* Currently this routine implements an easy variant of the primal-dual
+* interior-point method based on Mehrotra's technique.
+*
+* This routine transforms the original LP problem to an equivalent LP
+* problem in the standard formulation (all constraints are equalities,
+* all variables are non-negative), calls the routine ipm_main to solve
+* the transformed problem, and then transforms an obtained solution to
+* the solution of the original problem.
+*
+* RETURNS
+*
+* 0 The LP problem instance has been successfully solved. This code
+* does not necessarily mean that the solver has found optimal
+* solution. It only means that the solution process was successful.
+*
+* GLP_EFAIL
+* The problem has no rows/columns.
+*
+* GLP_ENOCVG
+* Very slow convergence or divergence.
+*
+* GLP_EITLIM
+* Iteration limit exceeded.
+*
+* GLP_EINSTAB
+* Numerical instability on solving Newtonian system. */
+
+static void transform(NPP *npp)
+{ /* transform LP to the standard formulation */
+ NPPROW *row, *prev_row;
+ NPPCOL *col, *prev_col;
+ for (row = npp->r_tail; row != NULL; row = prev_row)
+ { prev_row = row->prev;
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ npp_free_row(npp, row);
+ else if (row->lb == -DBL_MAX)
+ npp_leq_row(npp, row);
+ else if (row->ub == +DBL_MAX)
+ npp_geq_row(npp, row);
+ else if (row->lb != row->ub)
+ { if (fabs(row->lb) < fabs(row->ub))
+ npp_geq_row(npp, row);
+ else
+ npp_leq_row(npp, row);
+ }
+ }
+ for (col = npp->c_tail; col != NULL; col = prev_col)
+ { prev_col = col->prev;
+ if (col->lb == -DBL_MAX && col->ub == +DBL_MAX)
+ npp_free_col(npp, col);
+ else if (col->lb == -DBL_MAX)
+ npp_ubnd_col(npp, col);
+ else if (col->ub == +DBL_MAX)
+ { if (col->lb != 0.0)
+ npp_lbnd_col(npp, col);
+ }
+ else if (col->lb != col->ub)
+ { if (fabs(col->lb) < fabs(col->ub))
+ { if (col->lb != 0.0)
+ npp_lbnd_col(npp, col);
+ }
+ else
+ npp_ubnd_col(npp, col);
+ npp_dbnd_col(npp, col);
+ }
+ else
+ npp_fixed_col(npp, col);
+ }
+ for (row = npp->r_head; row != NULL; row = row->next)
+ xassert(row->lb == row->ub);
+ for (col = npp->c_head; col != NULL; col = col->next)
+ xassert(col->lb == 0.0 && col->ub == +DBL_MAX);
+ return;
+}
+
+int glp_interior(glp_prob *P, const glp_iptcp *parm)
+{ glp_iptcp _parm;
+ GLPROW *row;
+ GLPCOL *col;
+ NPP *npp = NULL;
+ glp_prob *prob = NULL;
+ int i, j, ret;
+ /* check control parameters */
+ if (parm == NULL)
+ glp_init_iptcp(&_parm), parm = &_parm;
+ if (!(parm->msg_lev == GLP_MSG_OFF ||
+ parm->msg_lev == GLP_MSG_ERR ||
+ parm->msg_lev == GLP_MSG_ON ||
+ parm->msg_lev == GLP_MSG_ALL))
+ xerror("glp_interior: msg_lev = %d; invalid parameter\n",
+ parm->msg_lev);
+ if (!(parm->ord_alg == GLP_ORD_NONE ||
+ parm->ord_alg == GLP_ORD_QMD ||
+ parm->ord_alg == GLP_ORD_AMD ||
+ parm->ord_alg == GLP_ORD_SYMAMD))
+ xerror("glp_interior: ord_alg = %d; invalid parameter\n",
+ parm->ord_alg);
+ /* interior-point solution is currently undefined */
+ P->ipt_stat = GLP_UNDEF;
+ P->ipt_obj = 0.0;
+ /* check bounds of double-bounded variables */
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->type == GLP_DB && row->lb >= row->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_interior: row %d: lb = %g, ub = %g; incorre"
+ "ct bounds\n", i, row->lb, row->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->type == GLP_DB && col->lb >= col->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_interior: column %d: lb = %g, ub = %g; inco"
+ "rrect bounds\n", j, col->lb, col->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ /* transform LP to the standard formulation */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Original LP has %d row(s), %d column(s), and %d non-z"
+ "ero(s)\n", P->m, P->n, P->nnz);
+ npp = npp_create_wksp();
+ npp_load_prob(npp, P, GLP_OFF, GLP_IPT, GLP_ON);
+ transform(npp);
+ prob = glp_create_prob();
+ npp_build_prob(npp, prob);
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Working LP has %d row(s), %d column(s), and %d non-ze"
+ "ro(s)\n", prob->m, prob->n, prob->nnz);
+#if 1
+ /* currently empty problem cannot be solved */
+ if (!(prob->m > 0 && prob->n > 0))
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_interior: unable to solve empty problem\n");
+ ret = GLP_EFAIL;
+ goto done;
+ }
+#endif
+ /* scale the resultant LP */
+ { ENV *env = get_env_ptr();
+ int term_out = env->term_out;
+ env->term_out = GLP_OFF;
+ glp_scale_prob(prob, GLP_SF_EQ);
+ env->term_out = term_out;
+ }
+ /* warn about dense columns */
+ if (parm->msg_lev >= GLP_MSG_ON && prob->m >= 200)
+ { int len, cnt = 0;
+ for (j = 1; j <= prob->n; j++)
+ { len = glp_get_mat_col(prob, j, NULL, NULL);
+ if ((double)len >= 0.20 * (double)prob->m) cnt++;
+ }
+ if (cnt == 1)
+ xprintf("WARNING: PROBLEM HAS ONE DENSE COLUMN\n");
+ else if (cnt > 0)
+ xprintf("WARNING: PROBLEM HAS %d DENSE COLUMNS\n", cnt);
+ }
+ /* solve the transformed LP */
+ ret = ipm_solve(prob, parm);
+ /* postprocess solution from the transformed LP */
+ npp_postprocess(npp, prob);
+ /* and store solution to the original LP */
+ npp_unload_sol(npp, P);
+done: /* free working program objects */
+ if (npp != NULL) npp_delete_wksp(npp);
+ if (prob != NULL) glp_delete_prob(prob);
+ /* return to the application program */
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_init_iptcp - initialize interior-point solver control parameters
+*
+* SYNOPSIS
+*
+* void glp_init_iptcp(glp_iptcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_init_iptcp initializes control parameters, which are
+* used by the interior-point solver, with default values.
+*
+* Default values of the control parameters are stored in the glp_iptcp
+* structure, which the parameter parm points to. */
+
+void glp_init_iptcp(glp_iptcp *parm)
+{ parm->msg_lev = GLP_MSG_ALL;
+ parm->ord_alg = GLP_ORD_AMD;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_status - retrieve status of interior-point solution
+*
+* SYNOPSIS
+*
+* int glp_ipt_status(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_ipt_status reports the status of solution found by
+* the interior-point solver as follows:
+*
+* GLP_UNDEF - interior-point solution is undefined;
+* GLP_OPT - interior-point solution is optimal;
+* GLP_INFEAS - interior-point solution is infeasible;
+* GLP_NOFEAS - no feasible solution exists. */
+
+int glp_ipt_status(glp_prob *lp)
+{ int ipt_stat = lp->ipt_stat;
+ return ipt_stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_obj_val - retrieve objective value (interior point)
+*
+* SYNOPSIS
+*
+* double glp_ipt_obj_val(glp_prob *lp);
+*
+* RETURNS
+*
+* The routine glp_ipt_obj_val returns value of the objective function
+* for interior-point solution. */
+
+double glp_ipt_obj_val(glp_prob *lp)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double z;
+ z = lp->ipt_obj;
+ /*if (cps->round && fabs(z) < 1e-9) z = 0.0;*/
+ return z;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_row_prim - retrieve row primal value (interior point)
+*
+* SYNOPSIS
+*
+* double glp_ipt_row_prim(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_ipt_row_prim returns primal value of the auxiliary
+* variable associated with i-th row. */
+
+double glp_ipt_row_prim(glp_prob *lp, int i)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double pval;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_ipt_row_prim: i = %d; row number out of range\n",
+ i);
+ pval = lp->row[i]->pval;
+ /*if (cps->round && fabs(pval) < 1e-9) pval = 0.0;*/
+ return pval;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_row_dual - retrieve row dual value (interior point)
+*
+* SYNOPSIS
+*
+* double glp_ipt_row_dual(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_ipt_row_dual returns dual value (i.e. reduced cost)
+* of the auxiliary variable associated with i-th row. */
+
+double glp_ipt_row_dual(glp_prob *lp, int i)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double dval;
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_ipt_row_dual: i = %d; row number out of range\n",
+ i);
+ dval = lp->row[i]->dval;
+ /*if (cps->round && fabs(dval) < 1e-9) dval = 0.0;*/
+ return dval;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_col_prim - retrieve column primal value (interior point)
+*
+* SYNOPSIS
+*
+* double glp_ipt_col_prim(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_ipt_col_prim returns primal value of the structural
+* variable associated with j-th column. */
+
+double glp_ipt_col_prim(glp_prob *lp, int j)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double pval;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_ipt_col_prim: j = %d; column number out of range\n"
+ , j);
+ pval = lp->col[j]->pval;
+ /*if (cps->round && fabs(pval) < 1e-9) pval = 0.0;*/
+ return pval;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ipt_col_dual - retrieve column dual value (interior point)
+*
+* SYNOPSIS
+*
+* double glp_ipt_col_dual(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_ipt_col_dual returns dual value (i.e. reduced cost)
+* of the structural variable associated with j-th column. */
+
+double glp_ipt_col_dual(glp_prob *lp, int j)
+{ /*struct LPXCPS *cps = lp->cps;*/
+ double dval;
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_ipt_col_dual: j = %d; column number out of range\n"
+ , j);
+ dval = lp->col[j]->dval;
+ /*if (cps->round && fabs(dval) < 1e-9) dval = 0.0;*/
+ return dval;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi09.c b/test/monniaux/glpk-4.65/src/draft/glpapi09.c
new file mode 100644
index 00000000..0d3ab57b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi09.c
@@ -0,0 +1,798 @@
+/* glpapi09.c (mixed integer programming routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "draft.h"
+#include "env.h"
+#include "ios.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_set_col_kind - set (change) column kind
+*
+* SYNOPSIS
+*
+* void glp_set_col_kind(glp_prob *mip, int j, int kind);
+*
+* DESCRIPTION
+*
+* The routine glp_set_col_kind sets (changes) the kind of j-th column
+* (structural variable) as specified by the parameter kind:
+*
+* GLP_CV - continuous variable;
+* GLP_IV - integer variable;
+* GLP_BV - binary variable. */
+
+void glp_set_col_kind(glp_prob *mip, int j, int kind)
+{ GLPCOL *col;
+ if (!(1 <= j && j <= mip->n))
+ xerror("glp_set_col_kind: j = %d; column number out of range\n"
+ , j);
+ col = mip->col[j];
+ switch (kind)
+ { case GLP_CV:
+ col->kind = GLP_CV;
+ break;
+ case GLP_IV:
+ col->kind = GLP_IV;
+ break;
+ case GLP_BV:
+ col->kind = GLP_IV;
+ if (!(col->type == GLP_DB && col->lb == 0.0 && col->ub ==
+ 1.0)) glp_set_col_bnds(mip, j, GLP_DB, 0.0, 1.0);
+ break;
+ default:
+ xerror("glp_set_col_kind: j = %d; kind = %d; invalid column"
+ " kind\n", j, kind);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_kind - retrieve column kind
+*
+* SYNOPSIS
+*
+* int glp_get_col_kind(glp_prob *mip, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_kind returns the kind of j-th column, i.e.
+* the kind of corresponding structural variable, as follows:
+*
+* GLP_CV - continuous variable;
+* GLP_IV - integer variable;
+* GLP_BV - binary variable */
+
+int glp_get_col_kind(glp_prob *mip, int j)
+{ GLPCOL *col;
+ int kind;
+ if (!(1 <= j && j <= mip->n))
+ xerror("glp_get_col_kind: j = %d; column number out of range\n"
+ , j);
+ col = mip->col[j];
+ kind = col->kind;
+ switch (kind)
+ { case GLP_CV:
+ break;
+ case GLP_IV:
+ if (col->type == GLP_DB && col->lb == 0.0 && col->ub == 1.0)
+ kind = GLP_BV;
+ break;
+ default:
+ xassert(kind != kind);
+ }
+ return kind;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_num_int - retrieve number of integer columns
+*
+* SYNOPSIS
+*
+* int glp_get_num_int(glp_prob *mip);
+*
+* RETURNS
+*
+* The routine glp_get_num_int returns the current number of columns,
+* which are marked as integer. */
+
+int glp_get_num_int(glp_prob *mip)
+{ GLPCOL *col;
+ int j, count = 0;
+ for (j = 1; j <= mip->n; j++)
+ { col = mip->col[j];
+ if (col->kind == GLP_IV) count++;
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_num_bin - retrieve number of binary columns
+*
+* SYNOPSIS
+*
+* int glp_get_num_bin(glp_prob *mip);
+*
+* RETURNS
+*
+* The routine glp_get_num_bin returns the current number of columns,
+* which are marked as binary. */
+
+int glp_get_num_bin(glp_prob *mip)
+{ GLPCOL *col;
+ int j, count = 0;
+ for (j = 1; j <= mip->n; j++)
+ { col = mip->col[j];
+ if (col->kind == GLP_IV && col->type == GLP_DB && col->lb ==
+ 0.0 && col->ub == 1.0) count++;
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_intopt - solve MIP problem with the branch-and-bound method
+*
+* SYNOPSIS
+*
+* int glp_intopt(glp_prob *P, const glp_iocp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_intopt is a driver to the MIP solver based on the
+* branch-and-bound method.
+*
+* On entry the problem object should contain optimal solution to LP
+* relaxation (which can be obtained with the routine glp_simplex).
+*
+* The MIP solver has a set of control parameters. Values of the control
+* parameters can be passed in a structure glp_iocp, which the parameter
+* parm points to.
+*
+* The parameter parm can be specified as NULL, in which case the MIP
+* solver uses default settings.
+*
+* RETURNS
+*
+* 0 The MIP problem instance has been successfully solved. This code
+* does not necessarily mean that the solver has found optimal
+* solution. It only means that the solution process was successful.
+*
+* GLP_EBOUND
+* Unable to start the search, because some double-bounded variables
+* have incorrect bounds or some integer variables have non-integer
+* (fractional) bounds.
+*
+* GLP_EROOT
+* Unable to start the search, because optimal basis for initial LP
+* relaxation is not provided.
+*
+* GLP_EFAIL
+* The search was prematurely terminated due to the solver failure.
+*
+* GLP_EMIPGAP
+* The search was prematurely terminated, because the relative mip
+* gap tolerance has been reached.
+*
+* GLP_ETMLIM
+* The search was prematurely terminated, because the time limit has
+* been exceeded.
+*
+* GLP_ENOPFS
+* The MIP problem instance has no primal feasible solution (only if
+* the MIP presolver is used).
+*
+* GLP_ENODFS
+* LP relaxation of the MIP problem instance has no dual feasible
+* solution (only if the MIP presolver is used).
+*
+* GLP_ESTOP
+* The search was prematurely terminated by application. */
+
+#if 0 /* 11/VII-2013 */
+static int solve_mip(glp_prob *P, const glp_iocp *parm)
+#else
+static int solve_mip(glp_prob *P, const glp_iocp *parm,
+ glp_prob *P0 /* problem passed to glp_intopt */,
+ NPP *npp /* preprocessor workspace or NULL */)
+#endif
+{ /* solve MIP directly without using the preprocessor */
+ glp_tree *T;
+ int ret;
+ /* optimal basis to LP relaxation must be provided */
+ if (glp_get_status(P) != GLP_OPT)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: optimal basis to initial LP relaxation"
+ " not provided\n");
+ ret = GLP_EROOT;
+ goto done;
+ }
+ /* it seems all is ok */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Integer optimization begins...\n");
+ /* create the branch-and-bound tree */
+ T = ios_create_tree(P, parm);
+#if 1 /* 11/VII-2013 */
+ T->P = P0;
+ T->npp = npp;
+#endif
+ /* solve the problem instance */
+ ret = ios_driver(T);
+ /* delete the branch-and-bound tree */
+ ios_delete_tree(T);
+ /* analyze exit code reported by the mip driver */
+ if (ret == 0)
+ { if (P->mip_stat == GLP_FEAS)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("INTEGER OPTIMAL SOLUTION FOUND\n");
+ P->mip_stat = GLP_OPT;
+ }
+ else
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("PROBLEM HAS NO INTEGER FEASIBLE SOLUTION\n");
+ P->mip_stat = GLP_NOFEAS;
+ }
+ }
+ else if (ret == GLP_EMIPGAP)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("RELATIVE MIP GAP TOLERANCE REACHED; SEARCH TERMINA"
+ "TED\n");
+ }
+ else if (ret == GLP_ETMLIM)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("TIME LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ }
+ else if (ret == GLP_EFAIL)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: cannot solve current LP relaxation\n");
+ }
+ else if (ret == GLP_ESTOP)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("SEARCH TERMINATED BY APPLICATION\n");
+ }
+ else
+ xassert(ret != ret);
+done: return ret;
+}
+
+static int preprocess_and_solve_mip(glp_prob *P, const glp_iocp *parm)
+{ /* solve MIP using the preprocessor */
+ ENV *env = get_env_ptr();
+ int term_out = env->term_out;
+ NPP *npp;
+ glp_prob *mip = NULL;
+ glp_bfcp bfcp;
+ glp_smcp smcp;
+ int ret;
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Preprocessing...\n");
+ /* create preprocessor workspace */
+ npp = npp_create_wksp();
+ /* load original problem into the preprocessor workspace */
+ npp_load_prob(npp, P, GLP_OFF, GLP_MIP, GLP_OFF);
+ /* process MIP prior to applying the branch-and-bound method */
+ if (!term_out || parm->msg_lev < GLP_MSG_ALL)
+ env->term_out = GLP_OFF;
+ else
+ env->term_out = GLP_ON;
+ ret = npp_integer(npp, parm);
+ env->term_out = term_out;
+ if (ret == 0)
+ ;
+ else if (ret == GLP_ENOPFS)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("PROBLEM HAS NO PRIMAL FEASIBLE SOLUTION\n");
+ }
+ else if (ret == GLP_ENODFS)
+ { if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("LP RELAXATION HAS NO DUAL FEASIBLE SOLUTION\n");
+ }
+ else
+ xassert(ret != ret);
+ if (ret != 0) goto done;
+ /* build transformed MIP */
+ mip = glp_create_prob();
+ npp_build_prob(npp, mip);
+ /* if the transformed MIP is empty, it has empty solution, which
+ is optimal */
+ if (mip->m == 0 && mip->n == 0)
+ { mip->mip_stat = GLP_OPT;
+ mip->mip_obj = mip->c0;
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ { xprintf("Objective value = %17.9e\n", mip->mip_obj);
+ xprintf("INTEGER OPTIMAL SOLUTION FOUND BY MIP PREPROCESSOR"
+ "\n");
+ }
+ goto post;
+ }
+ /* display some statistics */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ { int ni = glp_get_num_int(mip);
+ int nb = glp_get_num_bin(mip);
+ char s[50];
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ mip->m, mip->m == 1 ? "" : "s", mip->n, mip->n == 1 ? "" :
+ "s", mip->nnz, mip->nnz == 1 ? "" : "s");
+ if (nb == 0)
+ strcpy(s, "none of");
+ else if (ni == 1 && nb == 1)
+ strcpy(s, "");
+ else if (nb == 1)
+ strcpy(s, "one of");
+ else if (nb == ni)
+ strcpy(s, "all of");
+ else
+ sprintf(s, "%d of", nb);
+ xprintf("%d integer variable%s, %s which %s binary\n",
+ ni, ni == 1 ? "" : "s", s, nb == 1 ? "is" : "are");
+ }
+ /* inherit basis factorization control parameters */
+ glp_get_bfcp(P, &bfcp);
+ glp_set_bfcp(mip, &bfcp);
+ /* scale the transformed problem */
+ if (!term_out || parm->msg_lev < GLP_MSG_ALL)
+ env->term_out = GLP_OFF;
+ else
+ env->term_out = GLP_ON;
+ glp_scale_prob(mip,
+ GLP_SF_GM | GLP_SF_EQ | GLP_SF_2N | GLP_SF_SKIP);
+ env->term_out = term_out;
+ /* build advanced initial basis */
+ if (!term_out || parm->msg_lev < GLP_MSG_ALL)
+ env->term_out = GLP_OFF;
+ else
+ env->term_out = GLP_ON;
+ glp_adv_basis(mip, 0);
+ env->term_out = term_out;
+ /* solve initial LP relaxation */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Solving LP relaxation...\n");
+ glp_init_smcp(&smcp);
+ smcp.msg_lev = parm->msg_lev;
+ /* respect time limit */
+ smcp.tm_lim = parm->tm_lim;
+ mip->it_cnt = P->it_cnt;
+ ret = glp_simplex(mip, &smcp);
+ P->it_cnt = mip->it_cnt;
+ if (ret == GLP_ETMLIM)
+ goto done;
+ else if (ret != 0)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: cannot solve LP relaxation\n");
+ ret = GLP_EFAIL;
+ goto done;
+ }
+ /* check status of the basic solution */
+ ret = glp_get_status(mip);
+ if (ret == GLP_OPT)
+ ret = 0;
+ else if (ret == GLP_NOFEAS)
+ ret = GLP_ENOPFS;
+ else if (ret == GLP_UNBND)
+ ret = GLP_ENODFS;
+ else
+ xassert(ret != ret);
+ if (ret != 0) goto done;
+ /* solve the transformed MIP */
+ mip->it_cnt = P->it_cnt;
+#if 0 /* 11/VII-2013 */
+ ret = solve_mip(mip, parm);
+#else
+ if (parm->use_sol)
+ { mip->mip_stat = P->mip_stat;
+ mip->mip_obj = P->mip_obj;
+ }
+ ret = solve_mip(mip, parm, P, npp);
+#endif
+ P->it_cnt = mip->it_cnt;
+ /* only integer feasible solution can be postprocessed */
+ if (!(mip->mip_stat == GLP_OPT || mip->mip_stat == GLP_FEAS))
+ { P->mip_stat = mip->mip_stat;
+ goto done;
+ }
+ /* postprocess solution from the transformed MIP */
+post: npp_postprocess(npp, mip);
+ /* the transformed MIP is no longer needed */
+ glp_delete_prob(mip), mip = NULL;
+ /* store solution to the original problem */
+ npp_unload_sol(npp, P);
+done: /* delete the transformed MIP, if it exists */
+ if (mip != NULL) glp_delete_prob(mip);
+ /* delete preprocessor workspace */
+ npp_delete_wksp(npp);
+ return ret;
+}
+
+#ifndef HAVE_ALIEN_SOLVER /* 28/V-2010 */
+int _glp_intopt1(glp_prob *P, const glp_iocp *parm)
+{ xassert(P == P);
+ xassert(parm == parm);
+ xprintf("glp_intopt: no alien solver is available\n");
+ return GLP_EFAIL;
+}
+#endif
+
+int glp_intopt(glp_prob *P, const glp_iocp *parm)
+{ /* solve MIP problem with the branch-and-bound method */
+ glp_iocp _parm;
+ int i, j, ret;
+#if 0 /* 04/IV-2016 */
+ /* check problem object */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_intopt: P = %p; invalid problem object\n", P);
+#endif
+ if (P->tree != NULL)
+ xerror("glp_intopt: operation not allowed\n");
+ /* check control parameters */
+ if (parm == NULL)
+ parm = &_parm, glp_init_iocp((glp_iocp *)parm);
+ if (!(parm->msg_lev == GLP_MSG_OFF ||
+ parm->msg_lev == GLP_MSG_ERR ||
+ parm->msg_lev == GLP_MSG_ON ||
+ parm->msg_lev == GLP_MSG_ALL ||
+ parm->msg_lev == GLP_MSG_DBG))
+ xerror("glp_intopt: msg_lev = %d; invalid parameter\n",
+ parm->msg_lev);
+ if (!(parm->br_tech == GLP_BR_FFV ||
+ parm->br_tech == GLP_BR_LFV ||
+ parm->br_tech == GLP_BR_MFV ||
+ parm->br_tech == GLP_BR_DTH ||
+ parm->br_tech == GLP_BR_PCH))
+ xerror("glp_intopt: br_tech = %d; invalid parameter\n",
+ parm->br_tech);
+ if (!(parm->bt_tech == GLP_BT_DFS ||
+ parm->bt_tech == GLP_BT_BFS ||
+ parm->bt_tech == GLP_BT_BLB ||
+ parm->bt_tech == GLP_BT_BPH))
+ xerror("glp_intopt: bt_tech = %d; invalid parameter\n",
+ parm->bt_tech);
+ if (!(0.0 < parm->tol_int && parm->tol_int < 1.0))
+ xerror("glp_intopt: tol_int = %g; invalid parameter\n",
+ parm->tol_int);
+ if (!(0.0 < parm->tol_obj && parm->tol_obj < 1.0))
+ xerror("glp_intopt: tol_obj = %g; invalid parameter\n",
+ parm->tol_obj);
+ if (parm->tm_lim < 0)
+ xerror("glp_intopt: tm_lim = %d; invalid parameter\n",
+ parm->tm_lim);
+ if (parm->out_frq < 0)
+ xerror("glp_intopt: out_frq = %d; invalid parameter\n",
+ parm->out_frq);
+ if (parm->out_dly < 0)
+ xerror("glp_intopt: out_dly = %d; invalid parameter\n",
+ parm->out_dly);
+ if (!(0 <= parm->cb_size && parm->cb_size <= 256))
+ xerror("glp_intopt: cb_size = %d; invalid parameter\n",
+ parm->cb_size);
+ if (!(parm->pp_tech == GLP_PP_NONE ||
+ parm->pp_tech == GLP_PP_ROOT ||
+ parm->pp_tech == GLP_PP_ALL))
+ xerror("glp_intopt: pp_tech = %d; invalid parameter\n",
+ parm->pp_tech);
+ if (parm->mip_gap < 0.0)
+ xerror("glp_intopt: mip_gap = %g; invalid parameter\n",
+ parm->mip_gap);
+ if (!(parm->mir_cuts == GLP_ON || parm->mir_cuts == GLP_OFF))
+ xerror("glp_intopt: mir_cuts = %d; invalid parameter\n",
+ parm->mir_cuts);
+ if (!(parm->gmi_cuts == GLP_ON || parm->gmi_cuts == GLP_OFF))
+ xerror("glp_intopt: gmi_cuts = %d; invalid parameter\n",
+ parm->gmi_cuts);
+ if (!(parm->cov_cuts == GLP_ON || parm->cov_cuts == GLP_OFF))
+ xerror("glp_intopt: cov_cuts = %d; invalid parameter\n",
+ parm->cov_cuts);
+ if (!(parm->clq_cuts == GLP_ON || parm->clq_cuts == GLP_OFF))
+ xerror("glp_intopt: clq_cuts = %d; invalid parameter\n",
+ parm->clq_cuts);
+ if (!(parm->presolve == GLP_ON || parm->presolve == GLP_OFF))
+ xerror("glp_intopt: presolve = %d; invalid parameter\n",
+ parm->presolve);
+ if (!(parm->binarize == GLP_ON || parm->binarize == GLP_OFF))
+ xerror("glp_intopt: binarize = %d; invalid parameter\n",
+ parm->binarize);
+ if (!(parm->fp_heur == GLP_ON || parm->fp_heur == GLP_OFF))
+ xerror("glp_intopt: fp_heur = %d; invalid parameter\n",
+ parm->fp_heur);
+#if 1 /* 28/V-2010 */
+ if (!(parm->alien == GLP_ON || parm->alien == GLP_OFF))
+ xerror("glp_intopt: alien = %d; invalid parameter\n",
+ parm->alien);
+#endif
+#if 0 /* 11/VII-2013 */
+ /* integer solution is currently undefined */
+ P->mip_stat = GLP_UNDEF;
+ P->mip_obj = 0.0;
+#else
+ if (!parm->use_sol)
+ P->mip_stat = GLP_UNDEF;
+ if (P->mip_stat == GLP_NOFEAS)
+ P->mip_stat = GLP_UNDEF;
+ if (P->mip_stat == GLP_UNDEF)
+ P->mip_obj = 0.0;
+ else if (P->mip_stat == GLP_OPT)
+ P->mip_stat = GLP_FEAS;
+#endif
+ /* check bounds of double-bounded variables */
+ for (i = 1; i <= P->m; i++)
+ { GLPROW *row = P->row[i];
+ if (row->type == GLP_DB && row->lb >= row->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: row %d: lb = %g, ub = %g; incorrect"
+ " bounds\n", i, row->lb, row->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if (col->type == GLP_DB && col->lb >= col->ub)
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: column %d: lb = %g, ub = %g; incorr"
+ "ect bounds\n", j, col->lb, col->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ /* bounds of all integer variables must be integral */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if (col->kind != GLP_IV) continue;
+ if (col->type == GLP_LO || col->type == GLP_DB)
+ { if (col->lb != floor(col->lb))
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: integer column %d has non-intege"
+ "r lower bound %g\n", j, col->lb);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ if (col->type == GLP_UP || col->type == GLP_DB)
+ { if (col->ub != floor(col->ub))
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: integer column %d has non-intege"
+ "r upper bound %g\n", j, col->ub);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ if (col->type == GLP_FX)
+ { if (col->lb != floor(col->lb))
+ { if (parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("glp_intopt: integer column %d has non-intege"
+ "r fixed value %g\n", j, col->lb);
+ ret = GLP_EBOUND;
+ goto done;
+ }
+ }
+ }
+ /* solve MIP problem */
+ if (parm->msg_lev >= GLP_MSG_ALL)
+ { int ni = glp_get_num_int(P);
+ int nb = glp_get_num_bin(P);
+ char s[50];
+ xprintf("GLPK Integer Optimizer, v%s\n", glp_version());
+ xprintf("%d row%s, %d column%s, %d non-zero%s\n",
+ P->m, P->m == 1 ? "" : "s", P->n, P->n == 1 ? "" : "s",
+ P->nnz, P->nnz == 1 ? "" : "s");
+ if (nb == 0)
+ strcpy(s, "none of");
+ else if (ni == 1 && nb == 1)
+ strcpy(s, "");
+ else if (nb == 1)
+ strcpy(s, "one of");
+ else if (nb == ni)
+ strcpy(s, "all of");
+ else
+ sprintf(s, "%d of", nb);
+ xprintf("%d integer variable%s, %s which %s binary\n",
+ ni, ni == 1 ? "" : "s", s, nb == 1 ? "is" : "are");
+ }
+#if 1 /* 28/V-2010 */
+ if (parm->alien)
+ { /* use alien integer optimizer */
+ ret = _glp_intopt1(P, parm);
+ goto done;
+ }
+#endif
+ if (!parm->presolve)
+#if 0 /* 11/VII-2013 */
+ ret = solve_mip(P, parm);
+#else
+ ret = solve_mip(P, parm, P, NULL);
+#endif
+ else
+ ret = preprocess_and_solve_mip(P, parm);
+#if 1 /* 12/III-2013 */
+ if (ret == GLP_ENOPFS)
+ P->mip_stat = GLP_NOFEAS;
+#endif
+done: /* return to the application program */
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_init_iocp - initialize integer optimizer control parameters
+*
+* SYNOPSIS
+*
+* void glp_init_iocp(glp_iocp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_init_iocp initializes control parameters, which are
+* used by the integer optimizer, with default values.
+*
+* Default values of the control parameters are stored in a glp_iocp
+* structure, which the parameter parm points to. */
+
+void glp_init_iocp(glp_iocp *parm)
+{ parm->msg_lev = GLP_MSG_ALL;
+ parm->br_tech = GLP_BR_DTH;
+ parm->bt_tech = GLP_BT_BLB;
+ parm->tol_int = 1e-5;
+ parm->tol_obj = 1e-7;
+ parm->tm_lim = INT_MAX;
+ parm->out_frq = 5000;
+ parm->out_dly = 10000;
+ parm->cb_func = NULL;
+ parm->cb_info = NULL;
+ parm->cb_size = 0;
+ parm->pp_tech = GLP_PP_ALL;
+ parm->mip_gap = 0.0;
+ parm->mir_cuts = GLP_OFF;
+ parm->gmi_cuts = GLP_OFF;
+ parm->cov_cuts = GLP_OFF;
+ parm->clq_cuts = GLP_OFF;
+ parm->presolve = GLP_OFF;
+ parm->binarize = GLP_OFF;
+ parm->fp_heur = GLP_OFF;
+ parm->ps_heur = GLP_OFF;
+ parm->ps_tm_lim = 60000; /* 1 minute */
+ parm->sr_heur = GLP_ON;
+#if 1 /* 24/X-2015; not documented--should not be used */
+ parm->use_sol = GLP_OFF;
+ parm->save_sol = NULL;
+ parm->alien = GLP_OFF;
+#endif
+#if 0 /* 20/I-2018 */
+#if 1 /* 16/III-2016; not documented--should not be used */
+ parm->flip = GLP_OFF;
+#endif
+#else
+ parm->flip = GLP_ON;
+#endif
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mip_status - retrieve status of MIP solution
+*
+* SYNOPSIS
+*
+* int glp_mip_status(glp_prob *mip);
+*
+* RETURNS
+*
+* The routine lpx_mip_status reports the status of MIP solution found
+* by the branch-and-bound solver as follows:
+*
+* GLP_UNDEF - MIP solution is undefined;
+* GLP_OPT - MIP solution is integer optimal;
+* GLP_FEAS - MIP solution is integer feasible but its optimality
+* (or non-optimality) has not been proven, perhaps due to
+* premature termination of the search;
+* GLP_NOFEAS - problem has no integer feasible solution (proven by the
+* solver). */
+
+int glp_mip_status(glp_prob *mip)
+{ int mip_stat = mip->mip_stat;
+ return mip_stat;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mip_obj_val - retrieve objective value (MIP solution)
+*
+* SYNOPSIS
+*
+* double glp_mip_obj_val(glp_prob *mip);
+*
+* RETURNS
+*
+* The routine glp_mip_obj_val returns value of the objective function
+* for MIP solution. */
+
+double glp_mip_obj_val(glp_prob *mip)
+{ /*struct LPXCPS *cps = mip->cps;*/
+ double z;
+ z = mip->mip_obj;
+ /*if (cps->round && fabs(z) < 1e-9) z = 0.0;*/
+ return z;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mip_row_val - retrieve row value (MIP solution)
+*
+* SYNOPSIS
+*
+* double glp_mip_row_val(glp_prob *mip, int i);
+*
+* RETURNS
+*
+* The routine glp_mip_row_val returns value of the auxiliary variable
+* associated with i-th row. */
+
+double glp_mip_row_val(glp_prob *mip, int i)
+{ /*struct LPXCPS *cps = mip->cps;*/
+ double mipx;
+ if (!(1 <= i && i <= mip->m))
+ xerror("glp_mip_row_val: i = %d; row number out of range\n", i)
+ ;
+ mipx = mip->row[i]->mipx;
+ /*if (cps->round && fabs(mipx) < 1e-9) mipx = 0.0;*/
+ return mipx;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mip_col_val - retrieve column value (MIP solution)
+*
+* SYNOPSIS
+*
+* double glp_mip_col_val(glp_prob *mip, int j);
+*
+* RETURNS
+*
+* The routine glp_mip_col_val returns value of the structural variable
+* associated with j-th column. */
+
+double glp_mip_col_val(glp_prob *mip, int j)
+{ /*struct LPXCPS *cps = mip->cps;*/
+ double mipx;
+ if (!(1 <= j && j <= mip->n))
+ xerror("glp_mip_col_val: j = %d; column number out of range\n",
+ j);
+ mipx = mip->col[j]->mipx;
+ /*if (cps->round && fabs(mipx) < 1e-9) mipx = 0.0;*/
+ return mipx;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi10.c b/test/monniaux/glpk-4.65/src/draft/glpapi10.c
new file mode 100644
index 00000000..5550aa39
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi10.c
@@ -0,0 +1,305 @@
+/* glpapi10.c (solution checking routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+void glp_check_kkt(glp_prob *P, int sol, int cond, double *_ae_max,
+ int *_ae_ind, double *_re_max, int *_re_ind)
+{ /* check feasibility and optimality conditions */
+ int m = P->m;
+ int n = P->n;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, j, ae_ind, re_ind;
+ double e, sp, sn, t, ae_max, re_max;
+ if (!(sol == GLP_SOL || sol == GLP_IPT || sol == GLP_MIP))
+ xerror("glp_check_kkt: sol = %d; invalid solution indicator\n",
+ sol);
+ if (!(cond == GLP_KKT_PE || cond == GLP_KKT_PB ||
+ cond == GLP_KKT_DE || cond == GLP_KKT_DB ||
+ cond == GLP_KKT_CS))
+ xerror("glp_check_kkt: cond = %d; invalid condition indicator "
+ "\n", cond);
+ ae_max = re_max = 0.0;
+ ae_ind = re_ind = 0;
+ if (cond == GLP_KKT_PE)
+ { /* xR - A * xS = 0 */
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ sp = sn = 0.0;
+ /* t := xR[i] */
+ if (sol == GLP_SOL)
+ t = row->prim;
+ else if (sol == GLP_IPT)
+ t = row->pval;
+ else if (sol == GLP_MIP)
+ t = row->mipx;
+ else
+ xassert(sol != sol);
+ if (t >= 0.0) sp += t; else sn -= t;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ /* t := - a[i,j] * xS[j] */
+ if (sol == GLP_SOL)
+ t = - aij->val * col->prim;
+ else if (sol == GLP_IPT)
+ t = - aij->val * col->pval;
+ else if (sol == GLP_MIP)
+ t = - aij->val * col->mipx;
+ else
+ xassert(sol != sol);
+ if (t >= 0.0) sp += t; else sn -= t;
+ }
+ /* absolute error */
+ e = fabs(sp - sn);
+ if (ae_max < e)
+ ae_max = e, ae_ind = i;
+ /* relative error */
+ e /= (1.0 + sp + sn);
+ if (re_max < e)
+ re_max = e, re_ind = i;
+ }
+ }
+ else if (cond == GLP_KKT_PB)
+ { /* lR <= xR <= uR */
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ /* t := xR[i] */
+ if (sol == GLP_SOL)
+ t = row->prim;
+ else if (sol == GLP_IPT)
+ t = row->pval;
+ else if (sol == GLP_MIP)
+ t = row->mipx;
+ else
+ xassert(sol != sol);
+ /* check lower bound */
+ if (row->type == GLP_LO || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ { if (t < row->lb)
+ { /* absolute error */
+ e = row->lb - t;
+ if (ae_max < e)
+ ae_max = e, ae_ind = i;
+ /* relative error */
+ e /= (1.0 + fabs(row->lb));
+ if (re_max < e)
+ re_max = e, re_ind = i;
+ }
+ }
+ /* check upper bound */
+ if (row->type == GLP_UP || row->type == GLP_DB ||
+ row->type == GLP_FX)
+ { if (t > row->ub)
+ { /* absolute error */
+ e = t - row->ub;
+ if (ae_max < e)
+ ae_max = e, ae_ind = i;
+ /* relative error */
+ e /= (1.0 + fabs(row->ub));
+ if (re_max < e)
+ re_max = e, re_ind = i;
+ }
+ }
+ }
+ /* lS <= xS <= uS */
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ /* t := xS[j] */
+ if (sol == GLP_SOL)
+ t = col->prim;
+ else if (sol == GLP_IPT)
+ t = col->pval;
+ else if (sol == GLP_MIP)
+ t = col->mipx;
+ else
+ xassert(sol != sol);
+ /* check lower bound */
+ if (col->type == GLP_LO || col->type == GLP_DB ||
+ col->type == GLP_FX)
+ { if (t < col->lb)
+ { /* absolute error */
+ e = col->lb - t;
+ if (ae_max < e)
+ ae_max = e, ae_ind = m+j;
+ /* relative error */
+ e /= (1.0 + fabs(col->lb));
+ if (re_max < e)
+ re_max = e, re_ind = m+j;
+ }
+ }
+ /* check upper bound */
+ if (col->type == GLP_UP || col->type == GLP_DB ||
+ col->type == GLP_FX)
+ { if (t > col->ub)
+ { /* absolute error */
+ e = t - col->ub;
+ if (ae_max < e)
+ ae_max = e, ae_ind = m+j;
+ /* relative error */
+ e /= (1.0 + fabs(col->ub));
+ if (re_max < e)
+ re_max = e, re_ind = m+j;
+ }
+ }
+ }
+ }
+ else if (cond == GLP_KKT_DE)
+ { /* A' * (lambdaR - cR) + (lambdaS - cS) = 0 */
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ sp = sn = 0.0;
+ /* t := lambdaS[j] - cS[j] */
+ if (sol == GLP_SOL)
+ t = col->dual - col->coef;
+ else if (sol == GLP_IPT)
+ t = col->dval - col->coef;
+ else
+ xassert(sol != sol);
+ if (t >= 0.0) sp += t; else sn -= t;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ { row = aij->row;
+ /* t := a[i,j] * (lambdaR[i] - cR[i]) */
+ if (sol == GLP_SOL)
+ t = aij->val * row->dual;
+ else if (sol == GLP_IPT)
+ t = aij->val * row->dval;
+ else
+ xassert(sol != sol);
+ if (t >= 0.0) sp += t; else sn -= t;
+ }
+ /* absolute error */
+ e = fabs(sp - sn);
+ if (ae_max < e)
+ ae_max = e, ae_ind = m+j;
+ /* relative error */
+ e /= (1.0 + sp + sn);
+ if (re_max < e)
+ re_max = e, re_ind = m+j;
+ }
+ }
+ else if (cond == GLP_KKT_DB)
+ { /* check lambdaR */
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ /* t := lambdaR[i] */
+ if (sol == GLP_SOL)
+ t = row->dual;
+ else if (sol == GLP_IPT)
+ t = row->dval;
+ else
+ xassert(sol != sol);
+ /* correct sign */
+ if (P->dir == GLP_MIN)
+ t = + t;
+ else if (P->dir == GLP_MAX)
+ t = - t;
+ else
+ xassert(P != P);
+ /* check for positivity */
+#if 1 /* 08/III-2013 */
+ /* the former check was correct */
+ /* the bug reported by David Price is related to violation
+ of complementarity slackness, not to this condition */
+ if (row->type == GLP_FR || row->type == GLP_LO)
+#else
+ if (row->stat == GLP_NF || row->stat == GLP_NL)
+#endif
+ { if (t < 0.0)
+ { e = - t;
+ if (ae_max < e)
+ ae_max = re_max = e, ae_ind = re_ind = i;
+ }
+ }
+ /* check for negativity */
+#if 1 /* 08/III-2013 */
+ /* see comment above */
+ if (row->type == GLP_FR || row->type == GLP_UP)
+#else
+ if (row->stat == GLP_NF || row->stat == GLP_NU)
+#endif
+ { if (t > 0.0)
+ { e = + t;
+ if (ae_max < e)
+ ae_max = re_max = e, ae_ind = re_ind = i;
+ }
+ }
+ }
+ /* check lambdaS */
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ /* t := lambdaS[j] */
+ if (sol == GLP_SOL)
+ t = col->dual;
+ else if (sol == GLP_IPT)
+ t = col->dval;
+ else
+ xassert(sol != sol);
+ /* correct sign */
+ if (P->dir == GLP_MIN)
+ t = + t;
+ else if (P->dir == GLP_MAX)
+ t = - t;
+ else
+ xassert(P != P);
+ /* check for positivity */
+#if 1 /* 08/III-2013 */
+ /* see comment above */
+ if (col->type == GLP_FR || col->type == GLP_LO)
+#else
+ if (col->stat == GLP_NF || col->stat == GLP_NL)
+#endif
+ { if (t < 0.0)
+ { e = - t;
+ if (ae_max < e)
+ ae_max = re_max = e, ae_ind = re_ind = m+j;
+ }
+ }
+ /* check for negativity */
+#if 1 /* 08/III-2013 */
+ /* see comment above */
+ if (col->type == GLP_FR || col->type == GLP_UP)
+#else
+ if (col->stat == GLP_NF || col->stat == GLP_NU)
+#endif
+ { if (t > 0.0)
+ { e = + t;
+ if (ae_max < e)
+ ae_max = re_max = e, ae_ind = re_ind = m+j;
+ }
+ }
+ }
+ }
+ else
+ xassert(cond != cond);
+ if (_ae_max != NULL) *_ae_max = ae_max;
+ if (_ae_ind != NULL) *_ae_ind = ae_ind;
+ if (_re_max != NULL) *_re_max = re_max;
+ if (_re_ind != NULL) *_re_ind = re_ind;
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi12.c b/test/monniaux/glpk-4.65/src/draft/glpapi12.c
new file mode 100644
index 00000000..020c8981
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi12.c
@@ -0,0 +1,2185 @@
+/* glpapi12.c (basis factorization and simplex tableau routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "draft.h"
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_bf_exists - check if the basis factorization exists
+*
+* SYNOPSIS
+*
+* int glp_bf_exists(glp_prob *lp);
+*
+* RETURNS
+*
+* If the basis factorization for the current basis associated with
+* the specified problem object exists and therefore is available for
+* computations, the routine glp_bf_exists returns non-zero. Otherwise
+* the routine returns zero. */
+
+int glp_bf_exists(glp_prob *lp)
+{ int ret;
+ ret = (lp->m == 0 || lp->valid);
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_factorize - compute the basis factorization
+*
+* SYNOPSIS
+*
+* int glp_factorize(glp_prob *lp);
+*
+* DESCRIPTION
+*
+* The routine glp_factorize computes the basis factorization for the
+* current basis associated with the specified problem object.
+*
+* RETURNS
+*
+* 0 The basis factorization has been successfully computed.
+*
+* GLP_EBADB
+* The basis matrix is invalid, i.e. the number of basic (auxiliary
+* and structural) variables differs from the number of rows in the
+* problem object.
+*
+* GLP_ESING
+* The basis matrix is singular within the working precision.
+*
+* GLP_ECOND
+* The basis matrix is ill-conditioned. */
+
+static int b_col(void *info, int j, int ind[], double val[])
+{ glp_prob *lp = info;
+ int m = lp->m;
+ GLPAIJ *aij;
+ int k, len;
+ xassert(1 <= j && j <= m);
+ /* determine the ordinal number of basic auxiliary or structural
+ variable x[k] corresponding to basic variable xB[j] */
+ k = lp->head[j];
+ /* build j-th column of the basic matrix, which is k-th column of
+ the scaled augmented matrix (I | -R*A*S) */
+ if (k <= m)
+ { /* x[k] is auxiliary variable */
+ len = 1;
+ ind[1] = k;
+ val[1] = 1.0;
+ }
+ else
+ { /* x[k] is structural variable */
+ len = 0;
+ for (aij = lp->col[k-m]->ptr; aij != NULL; aij = aij->c_next)
+ { len++;
+ ind[len] = aij->row->i;
+ val[len] = - aij->row->rii * aij->val * aij->col->sjj;
+ }
+ }
+ return len;
+}
+
+int glp_factorize(glp_prob *lp)
+{ int m = lp->m;
+ int n = lp->n;
+ GLPROW **row = lp->row;
+ GLPCOL **col = lp->col;
+ int *head = lp->head;
+ int j, k, stat, ret;
+ /* invalidate the basis factorization */
+ lp->valid = 0;
+ /* build the basis header */
+ j = 0;
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ { stat = row[k]->stat;
+ row[k]->bind = 0;
+ }
+ else
+ { stat = col[k-m]->stat;
+ col[k-m]->bind = 0;
+ }
+ if (stat == GLP_BS)
+ { j++;
+ if (j > m)
+ { /* too many basic variables */
+ ret = GLP_EBADB;
+ goto fini;
+ }
+ head[j] = k;
+ if (k <= m)
+ row[k]->bind = j;
+ else
+ col[k-m]->bind = j;
+ }
+ }
+ if (j < m)
+ { /* too few basic variables */
+ ret = GLP_EBADB;
+ goto fini;
+ }
+ /* try to factorize the basis matrix */
+ if (m > 0)
+ { if (lp->bfd == NULL)
+ { lp->bfd = bfd_create_it();
+#if 0 /* 08/III-2014 */
+ copy_bfcp(lp);
+#endif
+ }
+ switch (bfd_factorize(lp->bfd, m, /*lp->head,*/ b_col, lp))
+ { case 0:
+ /* ok */
+ break;
+ case BFD_ESING:
+ /* singular matrix */
+ ret = GLP_ESING;
+ goto fini;
+ case BFD_ECOND:
+ /* ill-conditioned matrix */
+ ret = GLP_ECOND;
+ goto fini;
+ default:
+ xassert(lp != lp);
+ }
+ lp->valid = 1;
+ }
+ /* factorization successful */
+ ret = 0;
+fini: /* bring the return code to the calling program */
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_bf_updated - check if the basis factorization has been updated
+*
+* SYNOPSIS
+*
+* int glp_bf_updated(glp_prob *lp);
+*
+* RETURNS
+*
+* If the basis factorization has been just computed from scratch, the
+* routine glp_bf_updated returns zero. Otherwise, if the factorization
+* has been updated one or more times, the routine returns non-zero. */
+
+int glp_bf_updated(glp_prob *lp)
+{ int cnt;
+ if (!(lp->m == 0 || lp->valid))
+ xerror("glp_bf_update: basis factorization does not exist\n");
+#if 0 /* 15/XI-2009 */
+ cnt = (lp->m == 0 ? 0 : lp->bfd->upd_cnt);
+#else
+ cnt = (lp->m == 0 ? 0 : bfd_get_count(lp->bfd));
+#endif
+ return cnt;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_bfcp - retrieve basis factorization control parameters
+*
+* SYNOPSIS
+*
+* void glp_get_bfcp(glp_prob *lp, glp_bfcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_get_bfcp retrieves control parameters, which are
+* used on computing and updating the basis factorization associated
+* with the specified problem object.
+*
+* Current values of control parameters are stored by the routine in
+* a glp_bfcp structure, which the parameter parm points to. */
+
+#if 1 /* 08/III-2014 */
+void glp_get_bfcp(glp_prob *P, glp_bfcp *parm)
+{ if (P->bfd == NULL)
+ P->bfd = bfd_create_it();
+ bfd_get_bfcp(P->bfd, parm);
+ return;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_set_bfcp - change basis factorization control parameters
+*
+* SYNOPSIS
+*
+* void glp_set_bfcp(glp_prob *lp, const glp_bfcp *parm);
+*
+* DESCRIPTION
+*
+* The routine glp_set_bfcp changes control parameters, which are used
+* by internal GLPK routines in computing and updating the basis
+* factorization associated with the specified problem object.
+*
+* New values of the control parameters should be passed in a structure
+* glp_bfcp, which the parameter parm points to.
+*
+* The parameter parm can be specified as NULL, in which case all
+* control parameters are reset to their default values. */
+
+#if 1 /* 08/III-2014 */
+void glp_set_bfcp(glp_prob *P, const glp_bfcp *parm)
+{ if (P->bfd == NULL)
+ P->bfd = bfd_create_it();
+ if (parm != NULL)
+ { if (!(parm->type == GLP_BF_LUF + GLP_BF_FT ||
+ parm->type == GLP_BF_LUF + GLP_BF_BG ||
+ parm->type == GLP_BF_LUF + GLP_BF_GR ||
+ parm->type == GLP_BF_BTF + GLP_BF_BG ||
+ parm->type == GLP_BF_BTF + GLP_BF_GR))
+ xerror("glp_set_bfcp: type = 0x%02X; invalid parameter\n",
+ parm->type);
+ if (!(0.0 < parm->piv_tol && parm->piv_tol < 1.0))
+ xerror("glp_set_bfcp: piv_tol = %g; invalid parameter\n",
+ parm->piv_tol);
+ if (parm->piv_lim < 1)
+ xerror("glp_set_bfcp: piv_lim = %d; invalid parameter\n",
+ parm->piv_lim);
+ if (!(parm->suhl == GLP_ON || parm->suhl == GLP_OFF))
+ xerror("glp_set_bfcp: suhl = %d; invalid parameter\n",
+ parm->suhl);
+ if (!(0.0 <= parm->eps_tol && parm->eps_tol <= 1e-6))
+ xerror("glp_set_bfcp: eps_tol = %g; invalid parameter\n",
+ parm->eps_tol);
+ if (!(1 <= parm->nfs_max && parm->nfs_max <= 32767))
+ xerror("glp_set_bfcp: nfs_max = %d; invalid parameter\n",
+ parm->nfs_max);
+ if (!(1 <= parm->nrs_max && parm->nrs_max <= 32767))
+ xerror("glp_set_bfcp: nrs_max = %d; invalid parameter\n",
+ parm->nrs_max);
+ }
+ bfd_set_bfcp(P->bfd, parm);
+ return;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_get_bhead - retrieve the basis header information
+*
+* SYNOPSIS
+*
+* int glp_get_bhead(glp_prob *lp, int k);
+*
+* DESCRIPTION
+*
+* The routine glp_get_bhead returns the basis header information for
+* the current basis associated with the specified problem object.
+*
+* RETURNS
+*
+* If xB[k], 1 <= k <= m, is i-th auxiliary variable (1 <= i <= m), the
+* routine returns i. Otherwise, if xB[k] is j-th structural variable
+* (1 <= j <= n), the routine returns m+j. Here m is the number of rows
+* and n is the number of columns in the problem object. */
+
+int glp_get_bhead(glp_prob *lp, int k)
+{ if (!(lp->m == 0 || lp->valid))
+ xerror("glp_get_bhead: basis factorization does not exist\n");
+ if (!(1 <= k && k <= lp->m))
+ xerror("glp_get_bhead: k = %d; index out of range\n", k);
+ return lp->head[k];
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_row_bind - retrieve row index in the basis header
+*
+* SYNOPSIS
+*
+* int glp_get_row_bind(glp_prob *lp, int i);
+*
+* RETURNS
+*
+* The routine glp_get_row_bind returns the index k of basic variable
+* xB[k], 1 <= k <= m, which is i-th auxiliary variable, 1 <= i <= m,
+* in the current basis associated with the specified problem object,
+* where m is the number of rows. However, if i-th auxiliary variable
+* is non-basic, the routine returns zero. */
+
+int glp_get_row_bind(glp_prob *lp, int i)
+{ if (!(lp->m == 0 || lp->valid))
+ xerror("glp_get_row_bind: basis factorization does not exist\n"
+ );
+ if (!(1 <= i && i <= lp->m))
+ xerror("glp_get_row_bind: i = %d; row number out of range\n",
+ i);
+ return lp->row[i]->bind;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_get_col_bind - retrieve column index in the basis header
+*
+* SYNOPSIS
+*
+* int glp_get_col_bind(glp_prob *lp, int j);
+*
+* RETURNS
+*
+* The routine glp_get_col_bind returns the index k of basic variable
+* xB[k], 1 <= k <= m, which is j-th structural variable, 1 <= j <= n,
+* in the current basis associated with the specified problem object,
+* where m is the number of rows, n is the number of columns. However,
+* if j-th structural variable is non-basic, the routine returns zero.*/
+
+int glp_get_col_bind(glp_prob *lp, int j)
+{ if (!(lp->m == 0 || lp->valid))
+ xerror("glp_get_col_bind: basis factorization does not exist\n"
+ );
+ if (!(1 <= j && j <= lp->n))
+ xerror("glp_get_col_bind: j = %d; column number out of range\n"
+ , j);
+ return lp->col[j]->bind;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ftran - perform forward transformation (solve system B*x = b)
+*
+* SYNOPSIS
+*
+* void glp_ftran(glp_prob *lp, double x[]);
+*
+* DESCRIPTION
+*
+* The routine glp_ftran performs forward transformation, i.e. solves
+* the system B*x = b, where B is the basis matrix corresponding to the
+* current basis for the specified problem object, x is the vector of
+* unknowns to be computed, b is the vector of right-hand sides.
+*
+* On entry elements of the vector b should be stored in dense format
+* in locations x[1], ..., x[m], where m is the number of rows. On exit
+* the routine stores elements of the vector x in the same locations.
+*
+* SCALING/UNSCALING
+*
+* Let A~ = (I | -A) is the augmented constraint matrix of the original
+* (unscaled) problem. In the scaled LP problem instead the matrix A the
+* scaled matrix A" = R*A*S is actually used, so
+*
+* A~" = (I | A") = (I | R*A*S) = (R*I*inv(R) | R*A*S) =
+* (1)
+* = R*(I | A)*S~ = R*A~*S~,
+*
+* is the scaled augmented constraint matrix, where R and S are diagonal
+* scaling matrices used to scale rows and columns of the matrix A, and
+*
+* S~ = diag(inv(R) | S) (2)
+*
+* is an augmented diagonal scaling matrix.
+*
+* By definition:
+*
+* A~ = (B | N), (3)
+*
+* where B is the basic matrix, which consists of basic columns of the
+* augmented constraint matrix A~, and N is a matrix, which consists of
+* non-basic columns of A~. From (1) it follows that:
+*
+* A~" = (B" | N") = (R*B*SB | R*N*SN), (4)
+*
+* where SB and SN are parts of the augmented scaling matrix S~, which
+* correspond to basic and non-basic variables, respectively. Therefore
+*
+* B" = R*B*SB, (5)
+*
+* which is the scaled basis matrix. */
+
+void glp_ftran(glp_prob *lp, double x[])
+{ int m = lp->m;
+ GLPROW **row = lp->row;
+ GLPCOL **col = lp->col;
+ int i, k;
+ /* B*x = b ===> (R*B*SB)*(inv(SB)*x) = R*b ===>
+ B"*x" = b", where b" = R*b, x = SB*x" */
+ if (!(m == 0 || lp->valid))
+ xerror("glp_ftran: basis factorization does not exist\n");
+ /* b" := R*b */
+ for (i = 1; i <= m; i++)
+ x[i] *= row[i]->rii;
+ /* x" := inv(B")*b" */
+ if (m > 0) bfd_ftran(lp->bfd, x);
+ /* x := SB*x" */
+ for (i = 1; i <= m; i++)
+ { k = lp->head[i];
+ if (k <= m)
+ x[i] /= row[k]->rii;
+ else
+ x[i] *= col[k-m]->sjj;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_btran - perform backward transformation (solve system B'*x = b)
+*
+* SYNOPSIS
+*
+* void glp_btran(glp_prob *lp, double x[]);
+*
+* DESCRIPTION
+*
+* The routine glp_btran performs backward transformation, i.e. solves
+* the system B'*x = b, where B' is a matrix transposed to the basis
+* matrix corresponding to the current basis for the specified problem
+* problem object, x is the vector of unknowns to be computed, b is the
+* vector of right-hand sides.
+*
+* On entry elements of the vector b should be stored in dense format
+* in locations x[1], ..., x[m], where m is the number of rows. On exit
+* the routine stores elements of the vector x in the same locations.
+*
+* SCALING/UNSCALING
+*
+* See comments to the routine glp_ftran. */
+
+void glp_btran(glp_prob *lp, double x[])
+{ int m = lp->m;
+ GLPROW **row = lp->row;
+ GLPCOL **col = lp->col;
+ int i, k;
+ /* B'*x = b ===> (SB*B'*R)*(inv(R)*x) = SB*b ===>
+ (B")'*x" = b", where b" = SB*b, x = R*x" */
+ if (!(m == 0 || lp->valid))
+ xerror("glp_btran: basis factorization does not exist\n");
+ /* b" := SB*b */
+ for (i = 1; i <= m; i++)
+ { k = lp->head[i];
+ if (k <= m)
+ x[i] /= row[k]->rii;
+ else
+ x[i] *= col[k-m]->sjj;
+ }
+ /* x" := inv[(B")']*b" */
+ if (m > 0) bfd_btran(lp->bfd, x);
+ /* x := R*x" */
+ for (i = 1; i <= m; i++)
+ x[i] *= row[i]->rii;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_warm_up - "warm up" LP basis
+*
+* SYNOPSIS
+*
+* int glp_warm_up(glp_prob *P);
+*
+* DESCRIPTION
+*
+* The routine glp_warm_up "warms up" the LP basis for the specified
+* problem object using current statuses assigned to rows and columns
+* (that is, to auxiliary and structural variables).
+*
+* This operation includes computing factorization of the basis matrix
+* (if it does not exist), computing primal and dual components of basic
+* solution, and determining the solution status.
+*
+* RETURNS
+*
+* 0 The operation has been successfully performed.
+*
+* GLP_EBADB
+* The basis matrix is invalid, i.e. the number of basic (auxiliary
+* and structural) variables differs from the number of rows in the
+* problem object.
+*
+* GLP_ESING
+* The basis matrix is singular within the working precision.
+*
+* GLP_ECOND
+* The basis matrix is ill-conditioned. */
+
+int glp_warm_up(glp_prob *P)
+{ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, j, type, stat, ret;
+ double eps, temp, *work;
+ /* invalidate basic solution */
+ P->pbs_stat = P->dbs_stat = GLP_UNDEF;
+ P->obj_val = 0.0;
+ P->some = 0;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ row->prim = row->dual = 0.0;
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ col->prim = col->dual = 0.0;
+ }
+ /* compute the basis factorization, if necessary */
+ if (!glp_bf_exists(P))
+ { ret = glp_factorize(P);
+ if (ret != 0) goto done;
+ }
+ /* allocate working array */
+ work = xcalloc(1+P->m, sizeof(double));
+ /* determine and store values of non-basic variables, compute
+ vector (- N * xN) */
+ for (i = 1; i <= P->m; i++)
+ work[i] = 0.0;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->stat == GLP_BS)
+ continue;
+ else if (row->stat == GLP_NL)
+ row->prim = row->lb;
+ else if (row->stat == GLP_NU)
+ row->prim = row->ub;
+ else if (row->stat == GLP_NF)
+ row->prim = 0.0;
+ else if (row->stat == GLP_NS)
+ row->prim = row->lb;
+ else
+ xassert(row != row);
+ /* N[j] is i-th column of matrix (I|-A) */
+ work[i] -= row->prim;
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->stat == GLP_BS)
+ continue;
+ else if (col->stat == GLP_NL)
+ col->prim = col->lb;
+ else if (col->stat == GLP_NU)
+ col->prim = col->ub;
+ else if (col->stat == GLP_NF)
+ col->prim = 0.0;
+ else if (col->stat == GLP_NS)
+ col->prim = col->lb;
+ else
+ xassert(col != col);
+ /* N[j] is (m+j)-th column of matrix (I|-A) */
+ if (col->prim != 0.0)
+ { for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ work[aij->row->i] += aij->val * col->prim;
+ }
+ }
+ /* compute vector of basic variables xB = - inv(B) * N * xN */
+ glp_ftran(P, work);
+ /* store values of basic variables, check primal feasibility */
+ P->pbs_stat = GLP_FEAS;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->stat != GLP_BS)
+ continue;
+ row->prim = work[row->bind];
+ type = row->type;
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { eps = 1e-6 + 1e-9 * fabs(row->lb);
+ if (row->prim < row->lb - eps)
+ P->pbs_stat = GLP_INFEAS;
+ }
+ if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ { eps = 1e-6 + 1e-9 * fabs(row->ub);
+ if (row->prim > row->ub + eps)
+ P->pbs_stat = GLP_INFEAS;
+ }
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->stat != GLP_BS)
+ continue;
+ col->prim = work[col->bind];
+ type = col->type;
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { eps = 1e-6 + 1e-9 * fabs(col->lb);
+ if (col->prim < col->lb - eps)
+ P->pbs_stat = GLP_INFEAS;
+ }
+ if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ { eps = 1e-6 + 1e-9 * fabs(col->ub);
+ if (col->prim > col->ub + eps)
+ P->pbs_stat = GLP_INFEAS;
+ }
+ }
+ /* compute value of the objective function */
+ P->obj_val = P->c0;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ P->obj_val += col->coef * col->prim;
+ }
+ /* build vector cB of objective coefficients at basic variables */
+ for (i = 1; i <= P->m; i++)
+ work[i] = 0.0;
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->stat == GLP_BS)
+ work[col->bind] = col->coef;
+ }
+ /* compute vector of simplex multipliers pi = inv(B') * cB */
+ glp_btran(P, work);
+ /* compute and store reduced costs of non-basic variables d[j] =
+ c[j] - N'[j] * pi, check dual feasibility */
+ P->dbs_stat = GLP_FEAS;
+ for (i = 1; i <= P->m; i++)
+ { row = P->row[i];
+ if (row->stat == GLP_BS)
+ { row->dual = 0.0;
+ continue;
+ }
+ /* N[j] is i-th column of matrix (I|-A) */
+ row->dual = - work[i];
+#if 0 /* 07/III-2013 */
+ type = row->type;
+ temp = (P->dir == GLP_MIN ? + row->dual : - row->dual);
+ if ((type == GLP_FR || type == GLP_LO) && temp < -1e-5 ||
+ (type == GLP_FR || type == GLP_UP) && temp > +1e-5)
+ P->dbs_stat = GLP_INFEAS;
+#else
+ stat = row->stat;
+ temp = (P->dir == GLP_MIN ? + row->dual : - row->dual);
+ if ((stat == GLP_NF || stat == GLP_NL) && temp < -1e-5 ||
+ (stat == GLP_NF || stat == GLP_NU) && temp > +1e-5)
+ P->dbs_stat = GLP_INFEAS;
+#endif
+ }
+ for (j = 1; j <= P->n; j++)
+ { col = P->col[j];
+ if (col->stat == GLP_BS)
+ { col->dual = 0.0;
+ continue;
+ }
+ /* N[j] is (m+j)-th column of matrix (I|-A) */
+ col->dual = col->coef;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ col->dual += aij->val * work[aij->row->i];
+#if 0 /* 07/III-2013 */
+ type = col->type;
+ temp = (P->dir == GLP_MIN ? + col->dual : - col->dual);
+ if ((type == GLP_FR || type == GLP_LO) && temp < -1e-5 ||
+ (type == GLP_FR || type == GLP_UP) && temp > +1e-5)
+ P->dbs_stat = GLP_INFEAS;
+#else
+ stat = col->stat;
+ temp = (P->dir == GLP_MIN ? + col->dual : - col->dual);
+ if ((stat == GLP_NF || stat == GLP_NL) && temp < -1e-5 ||
+ (stat == GLP_NF || stat == GLP_NU) && temp > +1e-5)
+ P->dbs_stat = GLP_INFEAS;
+#endif
+ }
+ /* free working array */
+ xfree(work);
+ ret = 0;
+done: return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_eval_tab_row - compute row of the simplex tableau
+*
+* SYNOPSIS
+*
+* int glp_eval_tab_row(glp_prob *lp, int k, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_eval_tab_row computes a row of the current simplex
+* tableau for the basic variable, which is specified by the number k:
+* if 1 <= k <= m, x[k] is k-th auxiliary variable; if m+1 <= k <= m+n,
+* x[k] is (k-m)-th structural variable, where m is number of rows, and
+* n is number of columns. The current basis must be available.
+*
+* The routine stores column indices and numerical values of non-zero
+* elements of the computed row using sparse format to the locations
+* ind[1], ..., ind[len] and val[1], ..., val[len], respectively, where
+* 0 <= len <= n is number of non-zeros returned on exit.
+*
+* Element indices stored in the array ind have the same sense as the
+* index k, i.e. indices 1 to m denote auxiliary variables and indices
+* m+1 to m+n denote structural ones (all these variables are obviously
+* non-basic by definition).
+*
+* The computed row shows how the specified basic variable x[k] = xB[i]
+* depends on non-basic variables:
+*
+* xB[i] = alfa[i,1]*xN[1] + alfa[i,2]*xN[2] + ... + alfa[i,n]*xN[n],
+*
+* where alfa[i,j] are elements of the simplex table row, xN[j] are
+* non-basic (auxiliary and structural) variables.
+*
+* RETURNS
+*
+* The routine returns number of non-zero elements in the simplex table
+* row stored in the arrays ind and val.
+*
+* BACKGROUND
+*
+* The system of equality constraints of the LP problem is:
+*
+* xR = A * xS, (1)
+*
+* where xR is the vector of auxliary variables, xS is the vector of
+* structural variables, A is the matrix of constraint coefficients.
+*
+* The system (1) can be written in homogenous form as follows:
+*
+* A~ * x = 0, (2)
+*
+* where A~ = (I | -A) is the augmented constraint matrix (has m rows
+* and m+n columns), x = (xR | xS) is the vector of all (auxiliary and
+* structural) variables.
+*
+* By definition for the current basis we have:
+*
+* A~ = (B | N), (3)
+*
+* where B is the basis matrix. Thus, the system (2) can be written as:
+*
+* B * xB + N * xN = 0. (4)
+*
+* From (4) it follows that:
+*
+* xB = A^ * xN, (5)
+*
+* where the matrix
+*
+* A^ = - inv(B) * N (6)
+*
+* is called the simplex table.
+*
+* It is understood that i-th row of the simplex table is:
+*
+* e * A^ = - e * inv(B) * N, (7)
+*
+* where e is a unity vector with e[i] = 1.
+*
+* To compute i-th row of the simplex table the routine first computes
+* i-th row of the inverse:
+*
+* rho = inv(B') * e, (8)
+*
+* where B' is a matrix transposed to B, and then computes elements of
+* i-th row of the simplex table as scalar products:
+*
+* alfa[i,j] = - rho * N[j] for all j, (9)
+*
+* where N[j] is a column of the augmented constraint matrix A~, which
+* corresponds to some non-basic auxiliary or structural variable. */
+
+int glp_eval_tab_row(glp_prob *lp, int k, int ind[], double val[])
+{ int m = lp->m;
+ int n = lp->n;
+ int i, t, len, lll, *iii;
+ double alfa, *rho, *vvv;
+ if (!(m == 0 || lp->valid))
+ xerror("glp_eval_tab_row: basis factorization does not exist\n"
+ );
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_eval_tab_row: k = %d; variable number out of range"
+ , k);
+ /* determine xB[i] which corresponds to x[k] */
+ if (k <= m)
+ i = glp_get_row_bind(lp, k);
+ else
+ i = glp_get_col_bind(lp, k-m);
+ if (i == 0)
+ xerror("glp_eval_tab_row: k = %d; variable must be basic", k);
+ xassert(1 <= i && i <= m);
+ /* allocate working arrays */
+ rho = xcalloc(1+m, sizeof(double));
+ iii = xcalloc(1+m, sizeof(int));
+ vvv = xcalloc(1+m, sizeof(double));
+ /* compute i-th row of the inverse; see (8) */
+ for (t = 1; t <= m; t++) rho[t] = 0.0;
+ rho[i] = 1.0;
+ glp_btran(lp, rho);
+ /* compute i-th row of the simplex table */
+ len = 0;
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ { /* x[k] is auxiliary variable, so N[k] is a unity column */
+ if (glp_get_row_stat(lp, k) == GLP_BS) continue;
+ /* compute alfa[i,j]; see (9) */
+ alfa = - rho[k];
+ }
+ else
+ { /* x[k] is structural variable, so N[k] is a column of the
+ original constraint matrix A with negative sign */
+ if (glp_get_col_stat(lp, k-m) == GLP_BS) continue;
+ /* compute alfa[i,j]; see (9) */
+ lll = glp_get_mat_col(lp, k-m, iii, vvv);
+ alfa = 0.0;
+ for (t = 1; t <= lll; t++) alfa += rho[iii[t]] * vvv[t];
+ }
+ /* store alfa[i,j] */
+ if (alfa != 0.0) len++, ind[len] = k, val[len] = alfa;
+ }
+ xassert(len <= n);
+ /* free working arrays */
+ xfree(rho);
+ xfree(iii);
+ xfree(vvv);
+ /* return to the calling program */
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_eval_tab_col - compute column of the simplex tableau
+*
+* SYNOPSIS
+*
+* int glp_eval_tab_col(glp_prob *lp, int k, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_eval_tab_col computes a column of the current simplex
+* table for the non-basic variable, which is specified by the number k:
+* if 1 <= k <= m, x[k] is k-th auxiliary variable; if m+1 <= k <= m+n,
+* x[k] is (k-m)-th structural variable, where m is number of rows, and
+* n is number of columns. The current basis must be available.
+*
+* The routine stores row indices and numerical values of non-zero
+* elements of the computed column using sparse format to the locations
+* ind[1], ..., ind[len] and val[1], ..., val[len] respectively, where
+* 0 <= len <= m is number of non-zeros returned on exit.
+*
+* Element indices stored in the array ind have the same sense as the
+* index k, i.e. indices 1 to m denote auxiliary variables and indices
+* m+1 to m+n denote structural ones (all these variables are obviously
+* basic by the definition).
+*
+* The computed column shows how basic variables depend on the specified
+* non-basic variable x[k] = xN[j]:
+*
+* xB[1] = ... + alfa[1,j]*xN[j] + ...
+* xB[2] = ... + alfa[2,j]*xN[j] + ...
+* . . . . . .
+* xB[m] = ... + alfa[m,j]*xN[j] + ...
+*
+* where alfa[i,j] are elements of the simplex table column, xB[i] are
+* basic (auxiliary and structural) variables.
+*
+* RETURNS
+*
+* The routine returns number of non-zero elements in the simplex table
+* column stored in the arrays ind and val.
+*
+* BACKGROUND
+*
+* As it was explained in comments to the routine glp_eval_tab_row (see
+* above) the simplex table is the following matrix:
+*
+* A^ = - inv(B) * N. (1)
+*
+* Therefore j-th column of the simplex table is:
+*
+* A^ * e = - inv(B) * N * e = - inv(B) * N[j], (2)
+*
+* where e is a unity vector with e[j] = 1, B is the basis matrix, N[j]
+* is a column of the augmented constraint matrix A~, which corresponds
+* to the given non-basic auxiliary or structural variable. */
+
+int glp_eval_tab_col(glp_prob *lp, int k, int ind[], double val[])
+{ int m = lp->m;
+ int n = lp->n;
+ int t, len, stat;
+ double *col;
+ if (!(m == 0 || lp->valid))
+ xerror("glp_eval_tab_col: basis factorization does not exist\n"
+ );
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_eval_tab_col: k = %d; variable number out of range"
+ , k);
+ if (k <= m)
+ stat = glp_get_row_stat(lp, k);
+ else
+ stat = glp_get_col_stat(lp, k-m);
+ if (stat == GLP_BS)
+ xerror("glp_eval_tab_col: k = %d; variable must be non-basic",
+ k);
+ /* obtain column N[k] with negative sign */
+ col = xcalloc(1+m, sizeof(double));
+ for (t = 1; t <= m; t++) col[t] = 0.0;
+ if (k <= m)
+ { /* x[k] is auxiliary variable, so N[k] is a unity column */
+ col[k] = -1.0;
+ }
+ else
+ { /* x[k] is structural variable, so N[k] is a column of the
+ original constraint matrix A with negative sign */
+ len = glp_get_mat_col(lp, k-m, ind, val);
+ for (t = 1; t <= len; t++) col[ind[t]] = val[t];
+ }
+ /* compute column of the simplex table, which corresponds to the
+ specified non-basic variable x[k] */
+ glp_ftran(lp, col);
+ len = 0;
+ for (t = 1; t <= m; t++)
+ { if (col[t] != 0.0)
+ { len++;
+ ind[len] = glp_get_bhead(lp, t);
+ val[len] = col[t];
+ }
+ }
+ xfree(col);
+ /* return to the calling program */
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_transform_row - transform explicitly specified row
+*
+* SYNOPSIS
+*
+* int glp_transform_row(glp_prob *P, int len, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_transform_row performs the same operation as the
+* routine glp_eval_tab_row with exception that the row to be
+* transformed is specified explicitly as a sparse vector.
+*
+* The explicitly specified row may be thought as a linear form:
+*
+* x = a[1]*x[m+1] + a[2]*x[m+2] + ... + a[n]*x[m+n], (1)
+*
+* where x is an auxiliary variable for this row, a[j] are coefficients
+* of the linear form, x[m+j] are structural variables.
+*
+* On entry column indices and numerical values of non-zero elements of
+* the row should be stored in locations ind[1], ..., ind[len] and
+* val[1], ..., val[len], where len is the number of non-zero elements.
+*
+* This routine uses the system of equality constraints and the current
+* basis in order to express the auxiliary variable x in (1) through the
+* current non-basic variables (as if the transformed row were added to
+* the problem object and its auxiliary variable were basic), i.e. the
+* resultant row has the form:
+*
+* x = alfa[1]*xN[1] + alfa[2]*xN[2] + ... + alfa[n]*xN[n], (2)
+*
+* where xN[j] are non-basic (auxiliary or structural) variables, n is
+* the number of columns in the LP problem object.
+*
+* On exit the routine stores indices and numerical values of non-zero
+* elements of the resultant row (2) in locations ind[1], ..., ind[len']
+* and val[1], ..., val[len'], where 0 <= len' <= n is the number of
+* non-zero elements in the resultant row returned by the routine. Note
+* that indices (numbers) of non-basic variables stored in the array ind
+* correspond to original ordinal numbers of variables: indices 1 to m
+* mean auxiliary variables and indices m+1 to m+n mean structural ones.
+*
+* RETURNS
+*
+* The routine returns len', which is the number of non-zero elements in
+* the resultant row stored in the arrays ind and val.
+*
+* BACKGROUND
+*
+* The explicitly specified row (1) is transformed in the same way as it
+* were the objective function row.
+*
+* From (1) it follows that:
+*
+* x = aB * xB + aN * xN, (3)
+*
+* where xB is the vector of basic variables, xN is the vector of
+* non-basic variables.
+*
+* The simplex table, which corresponds to the current basis, is:
+*
+* xB = [-inv(B) * N] * xN. (4)
+*
+* Therefore substituting xB from (4) to (3) we have:
+*
+* x = aB * [-inv(B) * N] * xN + aN * xN =
+* (5)
+* = rho * (-N) * xN + aN * xN = alfa * xN,
+*
+* where:
+*
+* rho = inv(B') * aB, (6)
+*
+* and
+*
+* alfa = aN + rho * (-N) (7)
+*
+* is the resultant row computed by the routine. */
+
+int glp_transform_row(glp_prob *P, int len, int ind[], double val[])
+{ int i, j, k, m, n, t, lll, *iii;
+ double alfa, *a, *aB, *rho, *vvv;
+ if (!glp_bf_exists(P))
+ xerror("glp_transform_row: basis factorization does not exist "
+ "\n");
+ m = glp_get_num_rows(P);
+ n = glp_get_num_cols(P);
+ /* unpack the row to be transformed to the array a */
+ a = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++) a[j] = 0.0;
+ if (!(0 <= len && len <= n))
+ xerror("glp_transform_row: len = %d; invalid row length\n",
+ len);
+ for (t = 1; t <= len; t++)
+ { j = ind[t];
+ if (!(1 <= j && j <= n))
+ xerror("glp_transform_row: ind[%d] = %d; column index out o"
+ "f range\n", t, j);
+ if (val[t] == 0.0)
+ xerror("glp_transform_row: val[%d] = 0; zero coefficient no"
+ "t allowed\n", t);
+ if (a[j] != 0.0)
+ xerror("glp_transform_row: ind[%d] = %d; duplicate column i"
+ "ndices not allowed\n", t, j);
+ a[j] = val[t];
+ }
+ /* construct the vector aB */
+ aB = xcalloc(1+m, sizeof(double));
+ for (i = 1; i <= m; i++)
+ { k = glp_get_bhead(P, i);
+ /* xB[i] is k-th original variable */
+ xassert(1 <= k && k <= m+n);
+ aB[i] = (k <= m ? 0.0 : a[k-m]);
+ }
+ /* solve the system B'*rho = aB to compute the vector rho */
+ rho = aB, glp_btran(P, rho);
+ /* compute coefficients at non-basic auxiliary variables */
+ len = 0;
+ for (i = 1; i <= m; i++)
+ { if (glp_get_row_stat(P, i) != GLP_BS)
+ { alfa = - rho[i];
+ if (alfa != 0.0)
+ { len++;
+ ind[len] = i;
+ val[len] = alfa;
+ }
+ }
+ }
+ /* compute coefficients at non-basic structural variables */
+ iii = xcalloc(1+m, sizeof(int));
+ vvv = xcalloc(1+m, sizeof(double));
+ for (j = 1; j <= n; j++)
+ { if (glp_get_col_stat(P, j) != GLP_BS)
+ { alfa = a[j];
+ lll = glp_get_mat_col(P, j, iii, vvv);
+ for (t = 1; t <= lll; t++) alfa += vvv[t] * rho[iii[t]];
+ if (alfa != 0.0)
+ { len++;
+ ind[len] = m+j;
+ val[len] = alfa;
+ }
+ }
+ }
+ xassert(len <= n);
+ xfree(iii);
+ xfree(vvv);
+ xfree(aB);
+ xfree(a);
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_transform_col - transform explicitly specified column
+*
+* SYNOPSIS
+*
+* int glp_transform_col(glp_prob *P, int len, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* The routine glp_transform_col performs the same operation as the
+* routine glp_eval_tab_col with exception that the column to be
+* transformed is specified explicitly as a sparse vector.
+*
+* The explicitly specified column may be thought as if it were added
+* to the original system of equality constraints:
+*
+* x[1] = a[1,1]*x[m+1] + ... + a[1,n]*x[m+n] + a[1]*x
+* x[2] = a[2,1]*x[m+1] + ... + a[2,n]*x[m+n] + a[2]*x (1)
+* . . . . . . . . . . . . . . .
+* x[m] = a[m,1]*x[m+1] + ... + a[m,n]*x[m+n] + a[m]*x
+*
+* where x[i] are auxiliary variables, x[m+j] are structural variables,
+* x is a structural variable for the explicitly specified column, a[i]
+* are constraint coefficients for x.
+*
+* On entry row indices and numerical values of non-zero elements of
+* the column should be stored in locations ind[1], ..., ind[len] and
+* val[1], ..., val[len], where len is the number of non-zero elements.
+*
+* This routine uses the system of equality constraints and the current
+* basis in order to express the current basic variables through the
+* structural variable x in (1) (as if the transformed column were added
+* to the problem object and the variable x were non-basic), i.e. the
+* resultant column has the form:
+*
+* xB[1] = ... + alfa[1]*x
+* xB[2] = ... + alfa[2]*x (2)
+* . . . . . .
+* xB[m] = ... + alfa[m]*x
+*
+* where xB are basic (auxiliary and structural) variables, m is the
+* number of rows in the problem object.
+*
+* On exit the routine stores indices and numerical values of non-zero
+* elements of the resultant column (2) in locations ind[1], ...,
+* ind[len'] and val[1], ..., val[len'], where 0 <= len' <= m is the
+* number of non-zero element in the resultant column returned by the
+* routine. Note that indices (numbers) of basic variables stored in
+* the array ind correspond to original ordinal numbers of variables:
+* indices 1 to m mean auxiliary variables and indices m+1 to m+n mean
+* structural ones.
+*
+* RETURNS
+*
+* The routine returns len', which is the number of non-zero elements
+* in the resultant column stored in the arrays ind and val.
+*
+* BACKGROUND
+*
+* The explicitly specified column (1) is transformed in the same way
+* as any other column of the constraint matrix using the formula:
+*
+* alfa = inv(B) * a, (3)
+*
+* where alfa is the resultant column computed by the routine. */
+
+int glp_transform_col(glp_prob *P, int len, int ind[], double val[])
+{ int i, m, t;
+ double *a, *alfa;
+ if (!glp_bf_exists(P))
+ xerror("glp_transform_col: basis factorization does not exist "
+ "\n");
+ m = glp_get_num_rows(P);
+ /* unpack the column to be transformed to the array a */
+ a = xcalloc(1+m, sizeof(double));
+ for (i = 1; i <= m; i++) a[i] = 0.0;
+ if (!(0 <= len && len <= m))
+ xerror("glp_transform_col: len = %d; invalid column length\n",
+ len);
+ for (t = 1; t <= len; t++)
+ { i = ind[t];
+ if (!(1 <= i && i <= m))
+ xerror("glp_transform_col: ind[%d] = %d; row index out of r"
+ "ange\n", t, i);
+ if (val[t] == 0.0)
+ xerror("glp_transform_col: val[%d] = 0; zero coefficient no"
+ "t allowed\n", t);
+ if (a[i] != 0.0)
+ xerror("glp_transform_col: ind[%d] = %d; duplicate row indi"
+ "ces not allowed\n", t, i);
+ a[i] = val[t];
+ }
+ /* solve the system B*a = alfa to compute the vector alfa */
+ alfa = a, glp_ftran(P, alfa);
+ /* store resultant coefficients */
+ len = 0;
+ for (i = 1; i <= m; i++)
+ { if (alfa[i] != 0.0)
+ { len++;
+ ind[len] = glp_get_bhead(P, i);
+ val[len] = alfa[i];
+ }
+ }
+ xfree(a);
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_prim_rtest - perform primal ratio test
+*
+* SYNOPSIS
+*
+* int glp_prim_rtest(glp_prob *P, int len, const int ind[],
+* const double val[], int dir, double eps);
+*
+* DESCRIPTION
+*
+* The routine glp_prim_rtest performs the primal ratio test using an
+* explicitly specified column of the simplex table.
+*
+* The current basic solution associated with the LP problem object
+* must be primal feasible.
+*
+* The explicitly specified column of the simplex table shows how the
+* basic variables xB depend on some non-basic variable x (which is not
+* necessarily presented in the problem object):
+*
+* xB[1] = ... + alfa[1] * x + ...
+* xB[2] = ... + alfa[2] * x + ... (*)
+* . . . . . . . .
+* xB[m] = ... + alfa[m] * x + ...
+*
+* The column (*) is specifed on entry to the routine using the sparse
+* format. Ordinal numbers of basic variables xB[i] should be placed in
+* locations ind[1], ..., ind[len], where ordinal number 1 to m denote
+* auxiliary variables, and ordinal numbers m+1 to m+n denote structural
+* variables. The corresponding non-zero coefficients alfa[i] should be
+* placed in locations val[1], ..., val[len]. The arrays ind and val are
+* not changed on exit.
+*
+* The parameter dir specifies direction in which the variable x changes
+* on entering the basis: +1 means increasing, -1 means decreasing.
+*
+* The parameter eps is an absolute tolerance (small positive number)
+* used by the routine to skip small alfa[j] of the row (*).
+*
+* The routine determines which basic variable (among specified in
+* ind[1], ..., ind[len]) should leave the basis in order to keep primal
+* feasibility.
+*
+* RETURNS
+*
+* The routine glp_prim_rtest returns the index piv in the arrays ind
+* and val corresponding to the pivot element chosen, 1 <= piv <= len.
+* If the adjacent basic solution is primal unbounded and therefore the
+* choice cannot be made, the routine returns zero.
+*
+* COMMENTS
+*
+* If the non-basic variable x is presented in the LP problem object,
+* the column (*) can be computed with the routine glp_eval_tab_col;
+* otherwise it can be computed with the routine glp_transform_col. */
+
+int glp_prim_rtest(glp_prob *P, int len, const int ind[],
+ const double val[], int dir, double eps)
+{ int k, m, n, piv, t, type, stat;
+ double alfa, big, beta, lb, ub, temp, teta;
+ if (glp_get_prim_stat(P) != GLP_FEAS)
+ xerror("glp_prim_rtest: basic solution is not primal feasible "
+ "\n");
+ if (!(dir == +1 || dir == -1))
+ xerror("glp_prim_rtest: dir = %d; invalid parameter\n", dir);
+ if (!(0.0 < eps && eps < 1.0))
+ xerror("glp_prim_rtest: eps = %g; invalid parameter\n", eps);
+ m = glp_get_num_rows(P);
+ n = glp_get_num_cols(P);
+ /* initial settings */
+ piv = 0, teta = DBL_MAX, big = 0.0;
+ /* walk through the entries of the specified column */
+ for (t = 1; t <= len; t++)
+ { /* get the ordinal number of basic variable */
+ k = ind[t];
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_prim_rtest: ind[%d] = %d; variable number out o"
+ "f range\n", t, k);
+ /* determine type, bounds, status and primal value of basic
+ variable xB[i] = x[k] in the current basic solution */
+ if (k <= m)
+ { type = glp_get_row_type(P, k);
+ lb = glp_get_row_lb(P, k);
+ ub = glp_get_row_ub(P, k);
+ stat = glp_get_row_stat(P, k);
+ beta = glp_get_row_prim(P, k);
+ }
+ else
+ { type = glp_get_col_type(P, k-m);
+ lb = glp_get_col_lb(P, k-m);
+ ub = glp_get_col_ub(P, k-m);
+ stat = glp_get_col_stat(P, k-m);
+ beta = glp_get_col_prim(P, k-m);
+ }
+ if (stat != GLP_BS)
+ xerror("glp_prim_rtest: ind[%d] = %d; non-basic variable no"
+ "t allowed\n", t, k);
+ /* determine influence coefficient at basic variable xB[i]
+ in the explicitly specified column and turn to the case of
+ increasing the variable x in order to simplify the program
+ logic */
+ alfa = (dir > 0 ? + val[t] : - val[t]);
+ /* analyze main cases */
+ if (type == GLP_FR)
+ { /* xB[i] is free variable */
+ continue;
+ }
+ else if (type == GLP_LO)
+lo: { /* xB[i] has an lower bound */
+ if (alfa > - eps) continue;
+ temp = (lb - beta) / alfa;
+ }
+ else if (type == GLP_UP)
+up: { /* xB[i] has an upper bound */
+ if (alfa < + eps) continue;
+ temp = (ub - beta) / alfa;
+ }
+ else if (type == GLP_DB)
+ { /* xB[i] has both lower and upper bounds */
+ if (alfa < 0.0) goto lo; else goto up;
+ }
+ else if (type == GLP_FX)
+ { /* xB[i] is fixed variable */
+ if (- eps < alfa && alfa < + eps) continue;
+ temp = 0.0;
+ }
+ else
+ xassert(type != type);
+ /* if the value of the variable xB[i] violates its lower or
+ upper bound (slightly, because the current basis is assumed
+ to be primal feasible), temp is negative; we can think this
+ happens due to round-off errors and the value is exactly on
+ the bound; this allows replacing temp by zero */
+ if (temp < 0.0) temp = 0.0;
+ /* apply the minimal ratio test */
+ if (teta > temp || teta == temp && big < fabs(alfa))
+ piv = t, teta = temp, big = fabs(alfa);
+ }
+ /* return index of the pivot element chosen */
+ return piv;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_dual_rtest - perform dual ratio test
+*
+* SYNOPSIS
+*
+* int glp_dual_rtest(glp_prob *P, int len, const int ind[],
+* const double val[], int dir, double eps);
+*
+* DESCRIPTION
+*
+* The routine glp_dual_rtest performs the dual ratio test using an
+* explicitly specified row of the simplex table.
+*
+* The current basic solution associated with the LP problem object
+* must be dual feasible.
+*
+* The explicitly specified row of the simplex table is a linear form
+* that shows how some basic variable x (which is not necessarily
+* presented in the problem object) depends on non-basic variables xN:
+*
+* x = alfa[1] * xN[1] + alfa[2] * xN[2] + ... + alfa[n] * xN[n]. (*)
+*
+* The row (*) is specified on entry to the routine using the sparse
+* format. Ordinal numbers of non-basic variables xN[j] should be placed
+* in locations ind[1], ..., ind[len], where ordinal numbers 1 to m
+* denote auxiliary variables, and ordinal numbers m+1 to m+n denote
+* structural variables. The corresponding non-zero coefficients alfa[j]
+* should be placed in locations val[1], ..., val[len]. The arrays ind
+* and val are not changed on exit.
+*
+* The parameter dir specifies direction in which the variable x changes
+* on leaving the basis: +1 means that x goes to its lower bound, and -1
+* means that x goes to its upper bound.
+*
+* The parameter eps is an absolute tolerance (small positive number)
+* used by the routine to skip small alfa[j] of the row (*).
+*
+* The routine determines which non-basic variable (among specified in
+* ind[1], ..., ind[len]) should enter the basis in order to keep dual
+* feasibility.
+*
+* RETURNS
+*
+* The routine glp_dual_rtest returns the index piv in the arrays ind
+* and val corresponding to the pivot element chosen, 1 <= piv <= len.
+* If the adjacent basic solution is dual unbounded and therefore the
+* choice cannot be made, the routine returns zero.
+*
+* COMMENTS
+*
+* If the basic variable x is presented in the LP problem object, the
+* row (*) can be computed with the routine glp_eval_tab_row; otherwise
+* it can be computed with the routine glp_transform_row. */
+
+int glp_dual_rtest(glp_prob *P, int len, const int ind[],
+ const double val[], int dir, double eps)
+{ int k, m, n, piv, t, stat;
+ double alfa, big, cost, obj, temp, teta;
+ if (glp_get_dual_stat(P) != GLP_FEAS)
+ xerror("glp_dual_rtest: basic solution is not dual feasible\n")
+ ;
+ if (!(dir == +1 || dir == -1))
+ xerror("glp_dual_rtest: dir = %d; invalid parameter\n", dir);
+ if (!(0.0 < eps && eps < 1.0))
+ xerror("glp_dual_rtest: eps = %g; invalid parameter\n", eps);
+ m = glp_get_num_rows(P);
+ n = glp_get_num_cols(P);
+ /* take into account optimization direction */
+ obj = (glp_get_obj_dir(P) == GLP_MIN ? +1.0 : -1.0);
+ /* initial settings */
+ piv = 0, teta = DBL_MAX, big = 0.0;
+ /* walk through the entries of the specified row */
+ for (t = 1; t <= len; t++)
+ { /* get ordinal number of non-basic variable */
+ k = ind[t];
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_dual_rtest: ind[%d] = %d; variable number out o"
+ "f range\n", t, k);
+ /* determine status and reduced cost of non-basic variable
+ x[k] = xN[j] in the current basic solution */
+ if (k <= m)
+ { stat = glp_get_row_stat(P, k);
+ cost = glp_get_row_dual(P, k);
+ }
+ else
+ { stat = glp_get_col_stat(P, k-m);
+ cost = glp_get_col_dual(P, k-m);
+ }
+ if (stat == GLP_BS)
+ xerror("glp_dual_rtest: ind[%d] = %d; basic variable not al"
+ "lowed\n", t, k);
+ /* determine influence coefficient at non-basic variable xN[j]
+ in the explicitly specified row and turn to the case of
+ increasing the variable x in order to simplify the program
+ logic */
+ alfa = (dir > 0 ? + val[t] : - val[t]);
+ /* analyze main cases */
+ if (stat == GLP_NL)
+ { /* xN[j] is on its lower bound */
+ if (alfa < + eps) continue;
+ temp = (obj * cost) / alfa;
+ }
+ else if (stat == GLP_NU)
+ { /* xN[j] is on its upper bound */
+ if (alfa > - eps) continue;
+ temp = (obj * cost) / alfa;
+ }
+ else if (stat == GLP_NF)
+ { /* xN[j] is non-basic free variable */
+ if (- eps < alfa && alfa < + eps) continue;
+ temp = 0.0;
+ }
+ else if (stat == GLP_NS)
+ { /* xN[j] is non-basic fixed variable */
+ continue;
+ }
+ else
+ xassert(stat != stat);
+ /* if the reduced cost of the variable xN[j] violates its zero
+ bound (slightly, because the current basis is assumed to be
+ dual feasible), temp is negative; we can think this happens
+ due to round-off errors and the reduced cost is exact zero;
+ this allows replacing temp by zero */
+ if (temp < 0.0) temp = 0.0;
+ /* apply the minimal ratio test */
+ if (teta > temp || teta == temp && big < fabs(alfa))
+ piv = t, teta = temp, big = fabs(alfa);
+ }
+ /* return index of the pivot element chosen */
+ return piv;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_analyze_row - simulate one iteration of dual simplex method
+*
+* SYNOPSIS
+*
+* int glp_analyze_row(glp_prob *P, int len, const int ind[],
+* const double val[], int type, double rhs, double eps, int *piv,
+* double *x, double *dx, double *y, double *dy, double *dz);
+*
+* DESCRIPTION
+*
+* Let the current basis be optimal or dual feasible, and there be
+* specified a row (constraint), which is violated by the current basic
+* solution. The routine glp_analyze_row simulates one iteration of the
+* dual simplex method to determine some information on the adjacent
+* basis (see below), where the specified row becomes active constraint
+* (i.e. its auxiliary variable becomes non-basic).
+*
+* The current basic solution associated with the problem object passed
+* to the routine must be dual feasible, and its primal components must
+* be defined.
+*
+* The row to be analyzed must be previously transformed either with
+* the routine glp_eval_tab_row (if the row is in the problem object)
+* or with the routine glp_transform_row (if the row is external, i.e.
+* not in the problem object). This is needed to express the row only
+* through (auxiliary and structural) variables, which are non-basic in
+* the current basis:
+*
+* y = alfa[1] * xN[1] + alfa[2] * xN[2] + ... + alfa[n] * xN[n],
+*
+* where y is an auxiliary variable of the row, alfa[j] is an influence
+* coefficient, xN[j] is a non-basic variable.
+*
+* The row is passed to the routine in sparse format. Ordinal numbers
+* of non-basic variables are stored in locations ind[1], ..., ind[len],
+* where numbers 1 to m denote auxiliary variables while numbers m+1 to
+* m+n denote structural variables. Corresponding non-zero coefficients
+* alfa[j] are stored in locations val[1], ..., val[len]. The arrays
+* ind and val are ot changed on exit.
+*
+* The parameters type and rhs specify the row type and its right-hand
+* side as follows:
+*
+* type = GLP_LO: y = sum alfa[j] * xN[j] >= rhs
+*
+* type = GLP_UP: y = sum alfa[j] * xN[j] <= rhs
+*
+* The parameter eps is an absolute tolerance (small positive number)
+* used by the routine to skip small coefficients alfa[j] on performing
+* the dual ratio test.
+*
+* If the operation was successful, the routine stores the following
+* information to corresponding location (if some parameter is NULL,
+* its value is not stored):
+*
+* piv index in the array ind and val, 1 <= piv <= len, determining
+* the non-basic variable, which would enter the adjacent basis;
+*
+* x value of the non-basic variable in the current basis;
+*
+* dx difference between values of the non-basic variable in the
+* adjacent and current bases, dx = x.new - x.old;
+*
+* y value of the row (i.e. of its auxiliary variable) in the
+* current basis;
+*
+* dy difference between values of the row in the adjacent and
+* current bases, dy = y.new - y.old;
+*
+* dz difference between values of the objective function in the
+* adjacent and current bases, dz = z.new - z.old. Note that in
+* case of minimization dz >= 0, and in case of maximization
+* dz <= 0, i.e. in the adjacent basis the objective function
+* always gets worse (degrades). */
+
+int _glp_analyze_row(glp_prob *P, int len, const int ind[],
+ const double val[], int type, double rhs, double eps, int *_piv,
+ double *_x, double *_dx, double *_y, double *_dy, double *_dz)
+{ int t, k, dir, piv, ret = 0;
+ double x, dx, y, dy, dz;
+ if (P->pbs_stat == GLP_UNDEF)
+ xerror("glp_analyze_row: primal basic solution components are "
+ "undefined\n");
+ if (P->dbs_stat != GLP_FEAS)
+ xerror("glp_analyze_row: basic solution is not dual feasible\n"
+ );
+ /* compute the row value y = sum alfa[j] * xN[j] in the current
+ basis */
+ if (!(0 <= len && len <= P->n))
+ xerror("glp_analyze_row: len = %d; invalid row length\n", len);
+ y = 0.0;
+ for (t = 1; t <= len; t++)
+ { /* determine value of x[k] = xN[j] in the current basis */
+ k = ind[t];
+ if (!(1 <= k && k <= P->m+P->n))
+ xerror("glp_analyze_row: ind[%d] = %d; row/column index out"
+ " of range\n", t, k);
+ if (k <= P->m)
+ { /* x[k] is auxiliary variable */
+ if (P->row[k]->stat == GLP_BS)
+ xerror("glp_analyze_row: ind[%d] = %d; basic auxiliary v"
+ "ariable is not allowed\n", t, k);
+ x = P->row[k]->prim;
+ }
+ else
+ { /* x[k] is structural variable */
+ if (P->col[k-P->m]->stat == GLP_BS)
+ xerror("glp_analyze_row: ind[%d] = %d; basic structural "
+ "variable is not allowed\n", t, k);
+ x = P->col[k-P->m]->prim;
+ }
+ y += val[t] * x;
+ }
+ /* check if the row is primal infeasible in the current basis,
+ i.e. the constraint is violated at the current point */
+ if (type == GLP_LO)
+ { if (y >= rhs)
+ { /* the constraint is not violated */
+ ret = 1;
+ goto done;
+ }
+ /* in the adjacent basis y goes to its lower bound */
+ dir = +1;
+ }
+ else if (type == GLP_UP)
+ { if (y <= rhs)
+ { /* the constraint is not violated */
+ ret = 1;
+ goto done;
+ }
+ /* in the adjacent basis y goes to its upper bound */
+ dir = -1;
+ }
+ else
+ xerror("glp_analyze_row: type = %d; invalid parameter\n",
+ type);
+ /* compute dy = y.new - y.old */
+ dy = rhs - y;
+ /* perform dual ratio test to determine which non-basic variable
+ should enter the adjacent basis to keep it dual feasible */
+ piv = glp_dual_rtest(P, len, ind, val, dir, eps);
+ if (piv == 0)
+ { /* no dual feasible adjacent basis exists */
+ ret = 2;
+ goto done;
+ }
+ /* non-basic variable x[k] = xN[j] should enter the basis */
+ k = ind[piv];
+ xassert(1 <= k && k <= P->m+P->n);
+ /* determine its value in the current basis */
+ if (k <= P->m)
+ x = P->row[k]->prim;
+ else
+ x = P->col[k-P->m]->prim;
+ /* compute dx = x.new - x.old = dy / alfa[j] */
+ xassert(val[piv] != 0.0);
+ dx = dy / val[piv];
+ /* compute dz = z.new - z.old = d[j] * dx, where d[j] is reduced
+ cost of xN[j] in the current basis */
+ if (k <= P->m)
+ dz = P->row[k]->dual * dx;
+ else
+ dz = P->col[k-P->m]->dual * dx;
+ /* store the analysis results */
+ if (_piv != NULL) *_piv = piv;
+ if (_x != NULL) *_x = x;
+ if (_dx != NULL) *_dx = dx;
+ if (_y != NULL) *_y = y;
+ if (_dy != NULL) *_dy = dy;
+ if (_dz != NULL) *_dz = dz;
+done: return ret;
+}
+
+#if 0
+int main(void)
+{ /* example program for the routine glp_analyze_row */
+ glp_prob *P;
+ glp_smcp parm;
+ int i, k, len, piv, ret, ind[1+100];
+ double rhs, x, dx, y, dy, dz, val[1+100];
+ P = glp_create_prob();
+ /* read plan.mps (see glpk/examples) */
+ ret = glp_read_mps(P, GLP_MPS_DECK, NULL, "plan.mps");
+ glp_assert(ret == 0);
+ /* and solve it to optimality */
+ ret = glp_simplex(P, NULL);
+ glp_assert(ret == 0);
+ glp_assert(glp_get_status(P) == GLP_OPT);
+ /* the optimal objective value is 296.217 */
+ /* we would like to know what happens if we would add a new row
+ (constraint) to plan.mps:
+ .01 * bin1 + .01 * bin2 + .02 * bin4 + .02 * bin5 <= 12 */
+ /* first, we specify this new row */
+ glp_create_index(P);
+ len = 0;
+ ind[++len] = glp_find_col(P, "BIN1"), val[len] = .01;
+ ind[++len] = glp_find_col(P, "BIN2"), val[len] = .01;
+ ind[++len] = glp_find_col(P, "BIN4"), val[len] = .02;
+ ind[++len] = glp_find_col(P, "BIN5"), val[len] = .02;
+ rhs = 12;
+ /* then we can compute value of the row (i.e. of its auxiliary
+ variable) in the current basis to see if the constraint is
+ violated */
+ y = 0.0;
+ for (k = 1; k <= len; k++)
+ y += val[k] * glp_get_col_prim(P, ind[k]);
+ glp_printf("y = %g\n", y);
+ /* this prints y = 15.1372, so the constraint is violated, since
+ we require that y <= rhs = 12 */
+ /* now we transform the row to express it only through non-basic
+ (auxiliary and artificial) variables */
+ len = glp_transform_row(P, len, ind, val);
+ /* finally, we simulate one step of the dual simplex method to
+ obtain necessary information for the adjacent basis */
+ ret = _glp_analyze_row(P, len, ind, val, GLP_UP, rhs, 1e-9, &piv,
+ &x, &dx, &y, &dy, &dz);
+ glp_assert(ret == 0);
+ glp_printf("k = %d, x = %g; dx = %g; y = %g; dy = %g; dz = %g\n",
+ ind[piv], x, dx, y, dy, dz);
+ /* this prints dz = 5.64418 and means that in the adjacent basis
+ the objective function would be 296.217 + 5.64418 = 301.861 */
+ /* now we actually include the row into the problem object; note
+ that the arrays ind and val are clobbered, so we need to build
+ them once again */
+ len = 0;
+ ind[++len] = glp_find_col(P, "BIN1"), val[len] = .01;
+ ind[++len] = glp_find_col(P, "BIN2"), val[len] = .01;
+ ind[++len] = glp_find_col(P, "BIN4"), val[len] = .02;
+ ind[++len] = glp_find_col(P, "BIN5"), val[len] = .02;
+ rhs = 12;
+ i = glp_add_rows(P, 1);
+ glp_set_row_bnds(P, i, GLP_UP, 0, rhs);
+ glp_set_mat_row(P, i, len, ind, val);
+ /* and perform one dual simplex iteration */
+ glp_init_smcp(&parm);
+ parm.meth = GLP_DUAL;
+ parm.it_lim = 1;
+ glp_simplex(P, &parm);
+ /* the current objective value is 301.861 */
+ return 0;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_analyze_bound - analyze active bound of non-basic variable
+*
+* SYNOPSIS
+*
+* void glp_analyze_bound(glp_prob *P, int k, double *limit1, int *var1,
+* double *limit2, int *var2);
+*
+* DESCRIPTION
+*
+* The routine glp_analyze_bound analyzes the effect of varying the
+* active bound of specified non-basic variable.
+*
+* The non-basic variable is specified by the parameter k, where
+* 1 <= k <= m means auxiliary variable of corresponding row while
+* m+1 <= k <= m+n means structural variable (column).
+*
+* Note that the current basic solution must be optimal, and the basis
+* factorization must exist.
+*
+* Results of the analysis have the following meaning.
+*
+* value1 is the minimal value of the active bound, at which the basis
+* still remains primal feasible and thus optimal. -DBL_MAX means that
+* the active bound has no lower limit.
+*
+* var1 is the ordinal number of an auxiliary (1 to m) or structural
+* (m+1 to n) basic variable, which reaches its bound first and thereby
+* limits further decreasing the active bound being analyzed.
+* if value1 = -DBL_MAX, var1 is set to 0.
+*
+* value2 is the maximal value of the active bound, at which the basis
+* still remains primal feasible and thus optimal. +DBL_MAX means that
+* the active bound has no upper limit.
+*
+* var2 is the ordinal number of an auxiliary (1 to m) or structural
+* (m+1 to n) basic variable, which reaches its bound first and thereby
+* limits further increasing the active bound being analyzed.
+* if value2 = +DBL_MAX, var2 is set to 0. */
+
+void glp_analyze_bound(glp_prob *P, int k, double *value1, int *var1,
+ double *value2, int *var2)
+{ GLPROW *row;
+ GLPCOL *col;
+ int m, n, stat, kase, p, len, piv, *ind;
+ double x, new_x, ll, uu, xx, delta, *val;
+#if 0 /* 04/IV-2016 */
+ /* sanity checks */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_analyze_bound: P = %p; invalid problem object\n",
+ P);
+#endif
+ m = P->m, n = P->n;
+ if (!(P->pbs_stat == GLP_FEAS && P->dbs_stat == GLP_FEAS))
+ xerror("glp_analyze_bound: optimal basic solution required\n");
+ if (!(m == 0 || P->valid))
+ xerror("glp_analyze_bound: basis factorization required\n");
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_analyze_bound: k = %d; variable number out of rang"
+ "e\n", k);
+ /* retrieve information about the specified non-basic variable
+ x[k] whose active bound is to be analyzed */
+ if (k <= m)
+ { row = P->row[k];
+ stat = row->stat;
+ x = row->prim;
+ }
+ else
+ { col = P->col[k-m];
+ stat = col->stat;
+ x = col->prim;
+ }
+ if (stat == GLP_BS)
+ xerror("glp_analyze_bound: k = %d; basic variable not allowed "
+ "\n", k);
+ /* allocate working arrays */
+ ind = xcalloc(1+m, sizeof(int));
+ val = xcalloc(1+m, sizeof(double));
+ /* compute column of the simplex table corresponding to the
+ non-basic variable x[k] */
+ len = glp_eval_tab_col(P, k, ind, val);
+ xassert(0 <= len && len <= m);
+ /* perform analysis */
+ for (kase = -1; kase <= +1; kase += 2)
+ { /* kase < 0 means active bound of x[k] is decreasing;
+ kase > 0 means active bound of x[k] is increasing */
+ /* use the primal ratio test to determine some basic variable
+ x[p] which reaches its bound first */
+ piv = glp_prim_rtest(P, len, ind, val, kase, 1e-9);
+ if (piv == 0)
+ { /* nothing limits changing the active bound of x[k] */
+ p = 0;
+ new_x = (kase < 0 ? -DBL_MAX : +DBL_MAX);
+ goto store;
+ }
+ /* basic variable x[p] limits changing the active bound of
+ x[k]; determine its value in the current basis */
+ xassert(1 <= piv && piv <= len);
+ p = ind[piv];
+ if (p <= m)
+ { row = P->row[p];
+ ll = glp_get_row_lb(P, row->i);
+ uu = glp_get_row_ub(P, row->i);
+ stat = row->stat;
+ xx = row->prim;
+ }
+ else
+ { col = P->col[p-m];
+ ll = glp_get_col_lb(P, col->j);
+ uu = glp_get_col_ub(P, col->j);
+ stat = col->stat;
+ xx = col->prim;
+ }
+ xassert(stat == GLP_BS);
+ /* determine delta x[p] = bound of x[p] - value of x[p] */
+ if (kase < 0 && val[piv] > 0.0 ||
+ kase > 0 && val[piv] < 0.0)
+ { /* delta x[p] < 0, so x[p] goes toward its lower bound */
+ xassert(ll != -DBL_MAX);
+ delta = ll - xx;
+ }
+ else
+ { /* delta x[p] > 0, so x[p] goes toward its upper bound */
+ xassert(uu != +DBL_MAX);
+ delta = uu - xx;
+ }
+ /* delta x[p] = alfa[p,k] * delta x[k], so new x[k] = x[k] +
+ delta x[k] = x[k] + delta x[p] / alfa[p,k] is the value of
+ x[k] in the adjacent basis */
+ xassert(val[piv] != 0.0);
+ new_x = x + delta / val[piv];
+store: /* store analysis results */
+ if (kase < 0)
+ { if (value1 != NULL) *value1 = new_x;
+ if (var1 != NULL) *var1 = p;
+ }
+ else
+ { if (value2 != NULL) *value2 = new_x;
+ if (var2 != NULL) *var2 = p;
+ }
+ }
+ /* free working arrays */
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_analyze_coef - analyze objective coefficient at basic variable
+*
+* SYNOPSIS
+*
+* void glp_analyze_coef(glp_prob *P, int k, double *coef1, int *var1,
+* double *value1, double *coef2, int *var2, double *value2);
+*
+* DESCRIPTION
+*
+* The routine glp_analyze_coef analyzes the effect of varying the
+* objective coefficient at specified basic variable.
+*
+* The basic variable is specified by the parameter k, where
+* 1 <= k <= m means auxiliary variable of corresponding row while
+* m+1 <= k <= m+n means structural variable (column).
+*
+* Note that the current basic solution must be optimal, and the basis
+* factorization must exist.
+*
+* Results of the analysis have the following meaning.
+*
+* coef1 is the minimal value of the objective coefficient, at which
+* the basis still remains dual feasible and thus optimal. -DBL_MAX
+* means that the objective coefficient has no lower limit.
+*
+* var1 is the ordinal number of an auxiliary (1 to m) or structural
+* (m+1 to n) non-basic variable, whose reduced cost reaches its zero
+* bound first and thereby limits further decreasing the objective
+* coefficient being analyzed. If coef1 = -DBL_MAX, var1 is set to 0.
+*
+* value1 is value of the basic variable being analyzed in an adjacent
+* basis, which is defined as follows. Let the objective coefficient
+* reaches its minimal value (coef1) and continues decreasing. Then the
+* reduced cost of the limiting non-basic variable (var1) becomes dual
+* infeasible and the current basis becomes non-optimal that forces the
+* limiting non-basic variable to enter the basis replacing there some
+* basic variable that leaves the basis to keep primal feasibility.
+* Should note that on determining the adjacent basis current bounds
+* of the basic variable being analyzed are ignored as if it were free
+* (unbounded) variable, so it cannot leave the basis. It may happen
+* that no dual feasible adjacent basis exists, in which case value1 is
+* set to -DBL_MAX or +DBL_MAX.
+*
+* coef2 is the maximal value of the objective coefficient, at which
+* the basis still remains dual feasible and thus optimal. +DBL_MAX
+* means that the objective coefficient has no upper limit.
+*
+* var2 is the ordinal number of an auxiliary (1 to m) or structural
+* (m+1 to n) non-basic variable, whose reduced cost reaches its zero
+* bound first and thereby limits further increasing the objective
+* coefficient being analyzed. If coef2 = +DBL_MAX, var2 is set to 0.
+*
+* value2 is value of the basic variable being analyzed in an adjacent
+* basis, which is defined exactly in the same way as value1 above with
+* exception that now the objective coefficient is increasing. */
+
+void glp_analyze_coef(glp_prob *P, int k, double *coef1, int *var1,
+ double *value1, double *coef2, int *var2, double *value2)
+{ GLPROW *row; GLPCOL *col;
+ int m, n, type, stat, kase, p, q, dir, clen, cpiv, rlen, rpiv,
+ *cind, *rind;
+ double lb, ub, coef, x, lim_coef, new_x, d, delta, ll, uu, xx,
+ *rval, *cval;
+#if 0 /* 04/IV-2016 */
+ /* sanity checks */
+ if (P == NULL || P->magic != GLP_PROB_MAGIC)
+ xerror("glp_analyze_coef: P = %p; invalid problem object\n",
+ P);
+#endif
+ m = P->m, n = P->n;
+ if (!(P->pbs_stat == GLP_FEAS && P->dbs_stat == GLP_FEAS))
+ xerror("glp_analyze_coef: optimal basic solution required\n");
+ if (!(m == 0 || P->valid))
+ xerror("glp_analyze_coef: basis factorization required\n");
+ if (!(1 <= k && k <= m+n))
+ xerror("glp_analyze_coef: k = %d; variable number out of range"
+ "\n", k);
+ /* retrieve information about the specified basic variable x[k]
+ whose objective coefficient c[k] is to be analyzed */
+ if (k <= m)
+ { row = P->row[k];
+ type = row->type;
+ lb = row->lb;
+ ub = row->ub;
+ coef = 0.0;
+ stat = row->stat;
+ x = row->prim;
+ }
+ else
+ { col = P->col[k-m];
+ type = col->type;
+ lb = col->lb;
+ ub = col->ub;
+ coef = col->coef;
+ stat = col->stat;
+ x = col->prim;
+ }
+ if (stat != GLP_BS)
+ xerror("glp_analyze_coef: k = %d; non-basic variable not allow"
+ "ed\n", k);
+ /* allocate working arrays */
+ cind = xcalloc(1+m, sizeof(int));
+ cval = xcalloc(1+m, sizeof(double));
+ rind = xcalloc(1+n, sizeof(int));
+ rval = xcalloc(1+n, sizeof(double));
+ /* compute row of the simplex table corresponding to the basic
+ variable x[k] */
+ rlen = glp_eval_tab_row(P, k, rind, rval);
+ xassert(0 <= rlen && rlen <= n);
+ /* perform analysis */
+ for (kase = -1; kase <= +1; kase += 2)
+ { /* kase < 0 means objective coefficient c[k] is decreasing;
+ kase > 0 means objective coefficient c[k] is increasing */
+ /* note that decreasing c[k] is equivalent to increasing dual
+ variable lambda[k] and vice versa; we need to correctly set
+ the dir flag as required by the routine glp_dual_rtest */
+ if (P->dir == GLP_MIN)
+ dir = - kase;
+ else if (P->dir == GLP_MAX)
+ dir = + kase;
+ else
+ xassert(P != P);
+ /* use the dual ratio test to determine non-basic variable
+ x[q] whose reduced cost d[q] reaches zero bound first */
+ rpiv = glp_dual_rtest(P, rlen, rind, rval, dir, 1e-9);
+ if (rpiv == 0)
+ { /* nothing limits changing c[k] */
+ lim_coef = (kase < 0 ? -DBL_MAX : +DBL_MAX);
+ q = 0;
+ /* x[k] keeps its current value */
+ new_x = x;
+ goto store;
+ }
+ /* non-basic variable x[q] limits changing coefficient c[k];
+ determine its status and reduced cost d[k] in the current
+ basis */
+ xassert(1 <= rpiv && rpiv <= rlen);
+ q = rind[rpiv];
+ xassert(1 <= q && q <= m+n);
+ if (q <= m)
+ { row = P->row[q];
+ stat = row->stat;
+ d = row->dual;
+ }
+ else
+ { col = P->col[q-m];
+ stat = col->stat;
+ d = col->dual;
+ }
+ /* note that delta d[q] = new d[q] - d[q] = - d[q], because
+ new d[q] = 0; delta d[q] = alfa[k,q] * delta c[k], so
+ delta c[k] = delta d[q] / alfa[k,q] = - d[q] / alfa[k,q] */
+ xassert(rval[rpiv] != 0.0);
+ delta = - d / rval[rpiv];
+ /* compute new c[k] = c[k] + delta c[k], which is the limiting
+ value of the objective coefficient c[k] */
+ lim_coef = coef + delta;
+ /* let c[k] continue decreasing/increasing that makes d[q]
+ dual infeasible and forces x[q] to enter the basis;
+ to perform the primal ratio test we need to know in which
+ direction x[q] changes on entering the basis; we determine
+ that analyzing the sign of delta d[q] (see above), since
+ d[q] may be close to zero having wrong sign */
+ /* let, for simplicity, the problem is minimization */
+ if (kase < 0 && rval[rpiv] > 0.0 ||
+ kase > 0 && rval[rpiv] < 0.0)
+ { /* delta d[q] < 0, so d[q] being non-negative will become
+ negative, so x[q] will increase */
+ dir = +1;
+ }
+ else
+ { /* delta d[q] > 0, so d[q] being non-positive will become
+ positive, so x[q] will decrease */
+ dir = -1;
+ }
+ /* if the problem is maximization, correct the direction */
+ if (P->dir == GLP_MAX) dir = - dir;
+ /* check that we didn't make a silly mistake */
+ if (dir > 0)
+ xassert(stat == GLP_NL || stat == GLP_NF);
+ else
+ xassert(stat == GLP_NU || stat == GLP_NF);
+ /* compute column of the simplex table corresponding to the
+ non-basic variable x[q] */
+ clen = glp_eval_tab_col(P, q, cind, cval);
+ /* make x[k] temporarily free (unbounded) */
+ if (k <= m)
+ { row = P->row[k];
+ row->type = GLP_FR;
+ row->lb = row->ub = 0.0;
+ }
+ else
+ { col = P->col[k-m];
+ col->type = GLP_FR;
+ col->lb = col->ub = 0.0;
+ }
+ /* use the primal ratio test to determine some basic variable
+ which leaves the basis */
+ cpiv = glp_prim_rtest(P, clen, cind, cval, dir, 1e-9);
+ /* restore original bounds of the basic variable x[k] */
+ if (k <= m)
+ { row = P->row[k];
+ row->type = type;
+ row->lb = lb, row->ub = ub;
+ }
+ else
+ { col = P->col[k-m];
+ col->type = type;
+ col->lb = lb, col->ub = ub;
+ }
+ if (cpiv == 0)
+ { /* non-basic variable x[q] can change unlimitedly */
+ if (dir < 0 && rval[rpiv] > 0.0 ||
+ dir > 0 && rval[rpiv] < 0.0)
+ { /* delta x[k] = alfa[k,q] * delta x[q] < 0 */
+ new_x = -DBL_MAX;
+ }
+ else
+ { /* delta x[k] = alfa[k,q] * delta x[q] > 0 */
+ new_x = +DBL_MAX;
+ }
+ goto store;
+ }
+ /* some basic variable x[p] limits changing non-basic variable
+ x[q] in the adjacent basis */
+ xassert(1 <= cpiv && cpiv <= clen);
+ p = cind[cpiv];
+ xassert(1 <= p && p <= m+n);
+ xassert(p != k);
+ if (p <= m)
+ { row = P->row[p];
+ xassert(row->stat == GLP_BS);
+ ll = glp_get_row_lb(P, row->i);
+ uu = glp_get_row_ub(P, row->i);
+ xx = row->prim;
+ }
+ else
+ { col = P->col[p-m];
+ xassert(col->stat == GLP_BS);
+ ll = glp_get_col_lb(P, col->j);
+ uu = glp_get_col_ub(P, col->j);
+ xx = col->prim;
+ }
+ /* determine delta x[p] = new x[p] - x[p] */
+ if (dir < 0 && cval[cpiv] > 0.0 ||
+ dir > 0 && cval[cpiv] < 0.0)
+ { /* delta x[p] < 0, so x[p] goes toward its lower bound */
+ xassert(ll != -DBL_MAX);
+ delta = ll - xx;
+ }
+ else
+ { /* delta x[p] > 0, so x[p] goes toward its upper bound */
+ xassert(uu != +DBL_MAX);
+ delta = uu - xx;
+ }
+ /* compute new x[k] = x[k] + alfa[k,q] * delta x[q], where
+ delta x[q] = delta x[p] / alfa[p,q] */
+ xassert(cval[cpiv] != 0.0);
+ new_x = x + (rval[rpiv] / cval[cpiv]) * delta;
+store: /* store analysis results */
+ if (kase < 0)
+ { if (coef1 != NULL) *coef1 = lim_coef;
+ if (var1 != NULL) *var1 = q;
+ if (value1 != NULL) *value1 = new_x;
+ }
+ else
+ { if (coef2 != NULL) *coef2 = lim_coef;
+ if (var2 != NULL) *var2 = q;
+ if (value2 != NULL) *value2 = new_x;
+ }
+ }
+ /* free working arrays */
+ xfree(cind);
+ xfree(cval);
+ xfree(rind);
+ xfree(rval);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpapi13.c b/test/monniaux/glpk-4.65/src/draft/glpapi13.c
new file mode 100644
index 00000000..1181b397
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpapi13.c
@@ -0,0 +1,710 @@
+/* glpapi13.c (branch-and-bound interface routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_reason - determine reason for calling the callback routine
+*
+* SYNOPSIS
+*
+* glp_ios_reason(glp_tree *tree);
+*
+* RETURNS
+*
+* The routine glp_ios_reason returns a code, which indicates why the
+* user-defined callback routine is being called. */
+
+int glp_ios_reason(glp_tree *tree)
+{ return
+ tree->reason;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_get_prob - access the problem object
+*
+* SYNOPSIS
+*
+* glp_prob *glp_ios_get_prob(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_get_prob can be called from the user-defined
+* callback routine to access the problem object, which is used by the
+* MIP solver. It is the original problem object passed to the routine
+* glp_intopt if the MIP presolver is not used; otherwise it is an
+* internal problem object built by the presolver. If the current
+* subproblem exists, LP segment of the problem object corresponds to
+* its LP relaxation.
+*
+* RETURNS
+*
+* The routine glp_ios_get_prob returns a pointer to the problem object
+* used by the MIP solver. */
+
+glp_prob *glp_ios_get_prob(glp_tree *tree)
+{ return
+ tree->mip;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_tree_size - determine size of the branch-and-bound tree
+*
+* SYNOPSIS
+*
+* void glp_ios_tree_size(glp_tree *tree, int *a_cnt, int *n_cnt,
+* int *t_cnt);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_tree_size stores the following three counts which
+* characterize the current size of the branch-and-bound tree:
+*
+* a_cnt is the current number of active nodes, i.e. the current size of
+* the active list;
+*
+* n_cnt is the current number of all (active and inactive) nodes;
+*
+* t_cnt is the total number of nodes including those which have been
+* already removed from the tree. This count is increased whenever
+* a new node appears in the tree and never decreased.
+*
+* If some of the parameters a_cnt, n_cnt, t_cnt is a null pointer, the
+* corresponding count is not stored. */
+
+void glp_ios_tree_size(glp_tree *tree, int *a_cnt, int *n_cnt,
+ int *t_cnt)
+{ if (a_cnt != NULL) *a_cnt = tree->a_cnt;
+ if (n_cnt != NULL) *n_cnt = tree->n_cnt;
+ if (t_cnt != NULL) *t_cnt = tree->t_cnt;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_curr_node - determine current active subproblem
+*
+* SYNOPSIS
+*
+* int glp_ios_curr_node(glp_tree *tree);
+*
+* RETURNS
+*
+* The routine glp_ios_curr_node returns the reference number of the
+* current active subproblem. However, if the current subproblem does
+* not exist, the routine returns zero. */
+
+int glp_ios_curr_node(glp_tree *tree)
+{ IOSNPD *node;
+ /* obtain pointer to the current subproblem */
+ node = tree->curr;
+ /* return its reference number */
+ return node == NULL ? 0 : node->p;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_next_node - determine next active subproblem
+*
+* SYNOPSIS
+*
+* int glp_ios_next_node(glp_tree *tree, int p);
+*
+* RETURNS
+*
+* If the parameter p is zero, the routine glp_ios_next_node returns
+* the reference number of the first active subproblem. However, if the
+* tree is empty, zero is returned.
+*
+* If the parameter p is not zero, it must specify the reference number
+* of some active subproblem, in which case the routine returns the
+* reference number of the next active subproblem. However, if there is
+* no next active subproblem in the list, zero is returned.
+*
+* All subproblems in the active list are ordered chronologically, i.e.
+* subproblem A precedes subproblem B if A was created before B. */
+
+int glp_ios_next_node(glp_tree *tree, int p)
+{ IOSNPD *node;
+ if (p == 0)
+ { /* obtain pointer to the first active subproblem */
+ node = tree->head;
+ }
+ else
+ { /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_next_node: p = %d; invalid subproblem refer"
+ "ence number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* the specified subproblem must be active */
+ if (node->count != 0)
+ xerror("glp_ios_next_node: p = %d; subproblem not in the ac"
+ "tive list\n", p);
+ /* obtain pointer to the next active subproblem */
+ node = node->next;
+ }
+ /* return the reference number */
+ return node == NULL ? 0 : node->p;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_prev_node - determine previous active subproblem
+*
+* SYNOPSIS
+*
+* int glp_ios_prev_node(glp_tree *tree, int p);
+*
+* RETURNS
+*
+* If the parameter p is zero, the routine glp_ios_prev_node returns
+* the reference number of the last active subproblem. However, if the
+* tree is empty, zero is returned.
+*
+* If the parameter p is not zero, it must specify the reference number
+* of some active subproblem, in which case the routine returns the
+* reference number of the previous active subproblem. However, if there
+* is no previous active subproblem in the list, zero is returned.
+*
+* All subproblems in the active list are ordered chronologically, i.e.
+* subproblem A precedes subproblem B if A was created before B. */
+
+int glp_ios_prev_node(glp_tree *tree, int p)
+{ IOSNPD *node;
+ if (p == 0)
+ { /* obtain pointer to the last active subproblem */
+ node = tree->tail;
+ }
+ else
+ { /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_prev_node: p = %d; invalid subproblem refer"
+ "ence number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* the specified subproblem must be active */
+ if (node->count != 0)
+ xerror("glp_ios_prev_node: p = %d; subproblem not in the ac"
+ "tive list\n", p);
+ /* obtain pointer to the previous active subproblem */
+ node = node->prev;
+ }
+ /* return the reference number */
+ return node == NULL ? 0 : node->p;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_up_node - determine parent subproblem
+*
+* SYNOPSIS
+*
+* int glp_ios_up_node(glp_tree *tree, int p);
+*
+* RETURNS
+*
+* The parameter p must specify the reference number of some (active or
+* inactive) subproblem, in which case the routine iet_get_up_node
+* returns the reference number of its parent subproblem. However, if
+* the specified subproblem is the root of the tree and, therefore, has
+* no parent, the routine returns zero. */
+
+int glp_ios_up_node(glp_tree *tree, int p)
+{ IOSNPD *node;
+ /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_up_node: p = %d; invalid subproblem reference "
+ "number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* obtain pointer to the parent subproblem */
+ node = node->up;
+ /* return the reference number */
+ return node == NULL ? 0 : node->p;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_node_level - determine subproblem level
+*
+* SYNOPSIS
+*
+* int glp_ios_node_level(glp_tree *tree, int p);
+*
+* RETURNS
+*
+* The routine glp_ios_node_level returns the level of the subproblem,
+* whose reference number is p, in the branch-and-bound tree. (The root
+* subproblem has level 0, and the level of any other subproblem is the
+* level of its parent plus one.) */
+
+int glp_ios_node_level(glp_tree *tree, int p)
+{ IOSNPD *node;
+ /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_node_level: p = %d; invalid subproblem referen"
+ "ce number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* return the node level */
+ return node->level;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_node_bound - determine subproblem local bound
+*
+* SYNOPSIS
+*
+* double glp_ios_node_bound(glp_tree *tree, int p);
+*
+* RETURNS
+*
+* The routine glp_ios_node_bound returns the local bound for (active or
+* inactive) subproblem, whose reference number is p.
+*
+* COMMENTS
+*
+* The local bound for subproblem p is an lower (minimization) or upper
+* (maximization) bound for integer optimal solution to this subproblem
+* (not to the original problem). This bound is local in the sense that
+* only subproblems in the subtree rooted at node p cannot have better
+* integer feasible solutions.
+*
+* On creating a subproblem (due to the branching step) its local bound
+* is inherited from its parent and then may get only stronger (never
+* weaker). For the root subproblem its local bound is initially set to
+* -DBL_MAX (minimization) or +DBL_MAX (maximization) and then improved
+* as the root LP relaxation has been solved.
+*
+* Note that the local bound is not necessarily the optimal objective
+* value to corresponding LP relaxation; it may be stronger. */
+
+double glp_ios_node_bound(glp_tree *tree, int p)
+{ IOSNPD *node;
+ /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_node_bound: p = %d; invalid subproblem referen"
+ "ce number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* return the node local bound */
+ return node->bound;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_best_node - find active subproblem with best local bound
+*
+* SYNOPSIS
+*
+* int glp_ios_best_node(glp_tree *tree);
+*
+* RETURNS
+*
+* The routine glp_ios_best_node returns the reference number of the
+* active subproblem, whose local bound is best (i.e. smallest in case
+* of minimization or largest in case of maximization). However, if the
+* tree is empty, the routine returns zero.
+*
+* COMMENTS
+*
+* The best local bound is an lower (minimization) or upper
+* (maximization) bound for integer optimal solution to the original
+* MIP problem. */
+
+int glp_ios_best_node(glp_tree *tree)
+{ return
+ ios_best_node(tree);
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_mip_gap - compute relative MIP gap
+*
+* SYNOPSIS
+*
+* double glp_ios_mip_gap(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_mip_gap computes the relative MIP gap with the
+* following formula:
+*
+* gap = |best_mip - best_bnd| / (|best_mip| + DBL_EPSILON),
+*
+* where best_mip is the best integer feasible solution found so far,
+* best_bnd is the best (global) bound. If no integer feasible solution
+* has been found yet, gap is set to DBL_MAX.
+*
+* RETURNS
+*
+* The routine glp_ios_mip_gap returns the relative MIP gap. */
+
+double glp_ios_mip_gap(glp_tree *tree)
+{ return
+ ios_relative_gap(tree);
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_node_data - access subproblem application-specific data
+*
+* SYNOPSIS
+*
+* void *glp_ios_node_data(glp_tree *tree, int p);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_node_data allows the application accessing a
+* memory block allocated for the subproblem (which may be active or
+* inactive), whose reference number is p.
+*
+* The size of the block is defined by the control parameter cb_size
+* passed to the routine glp_intopt. The block is initialized by binary
+* zeros on creating corresponding subproblem, and its contents is kept
+* until the subproblem will be removed from the tree.
+*
+* The application may use these memory blocks to store specific data
+* for each subproblem.
+*
+* RETURNS
+*
+* The routine glp_ios_node_data returns a pointer to the memory block
+* for the specified subproblem. Note that if cb_size = 0, the routine
+* returns a null pointer. */
+
+void *glp_ios_node_data(glp_tree *tree, int p)
+{ IOSNPD *node;
+ /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_node_level: p = %d; invalid subproblem referen"
+ "ce number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* return pointer to the application-specific data */
+ return node->data;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_row_attr - retrieve additional row attributes
+*
+* SYNOPSIS
+*
+* void glp_ios_row_attr(glp_tree *tree, int i, glp_attr *attr);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_row_attr retrieves additional attributes of row
+* i and stores them in the structure glp_attr. */
+
+void glp_ios_row_attr(glp_tree *tree, int i, glp_attr *attr)
+{ GLPROW *row;
+ if (!(1 <= i && i <= tree->mip->m))
+ xerror("glp_ios_row_attr: i = %d; row number out of range\n",
+ i);
+ row = tree->mip->row[i];
+ attr->level = row->level;
+ attr->origin = row->origin;
+ attr->klass = row->klass;
+ return;
+}
+
+/**********************************************************************/
+
+int glp_ios_pool_size(glp_tree *tree)
+{ /* determine current size of the cut pool */
+ if (tree->reason != GLP_ICUTGEN)
+ xerror("glp_ios_pool_size: operation not allowed\n");
+ xassert(tree->local != NULL);
+#ifdef NEW_LOCAL /* 02/II-2018 */
+ return tree->local->m;
+#else
+ return tree->local->size;
+#endif
+}
+
+/**********************************************************************/
+
+int glp_ios_add_row(glp_tree *tree,
+ const char *name, int klass, int flags, int len, const int ind[],
+ const double val[], int type, double rhs)
+{ /* add row (constraint) to the cut pool */
+ int num;
+ if (tree->reason != GLP_ICUTGEN)
+ xerror("glp_ios_add_row: operation not allowed\n");
+ xassert(tree->local != NULL);
+ num = ios_add_row(tree, tree->local, name, klass, flags, len,
+ ind, val, type, rhs);
+ return num;
+}
+
+/**********************************************************************/
+
+void glp_ios_del_row(glp_tree *tree, int i)
+{ /* remove row (constraint) from the cut pool */
+ if (tree->reason != GLP_ICUTGEN)
+ xerror("glp_ios_del_row: operation not allowed\n");
+ ios_del_row(tree, tree->local, i);
+ return;
+}
+
+/**********************************************************************/
+
+void glp_ios_clear_pool(glp_tree *tree)
+{ /* remove all rows (constraints) from the cut pool */
+ if (tree->reason != GLP_ICUTGEN)
+ xerror("glp_ios_clear_pool: operation not allowed\n");
+ ios_clear_pool(tree, tree->local);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_can_branch - check if can branch upon specified variable
+*
+* SYNOPSIS
+*
+* int glp_ios_can_branch(glp_tree *tree, int j);
+*
+* RETURNS
+*
+* If j-th variable (column) can be used to branch upon, the routine
+* glp_ios_can_branch returns non-zero, otherwise zero. */
+
+int glp_ios_can_branch(glp_tree *tree, int j)
+{ if (!(1 <= j && j <= tree->mip->n))
+ xerror("glp_ios_can_branch: j = %d; column number out of range"
+ "\n", j);
+ return tree->non_int[j];
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_branch_upon - choose variable to branch upon
+*
+* SYNOPSIS
+*
+* void glp_ios_branch_upon(glp_tree *tree, int j, int sel);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_branch_upon can be called from the user-defined
+* callback routine in response to the reason GLP_IBRANCH to choose a
+* branching variable, whose ordinal number is j. Should note that only
+* variables, for which the routine glp_ios_can_branch returns non-zero,
+* can be used to branch upon.
+*
+* The parameter sel is a flag that indicates which branch (subproblem)
+* should be selected next to continue the search:
+*
+* GLP_DN_BRNCH - select down-branch;
+* GLP_UP_BRNCH - select up-branch;
+* GLP_NO_BRNCH - use general selection technique. */
+
+void glp_ios_branch_upon(glp_tree *tree, int j, int sel)
+{ if (!(1 <= j && j <= tree->mip->n))
+ xerror("glp_ios_branch_upon: j = %d; column number out of rang"
+ "e\n", j);
+ if (!(sel == GLP_DN_BRNCH || sel == GLP_UP_BRNCH ||
+ sel == GLP_NO_BRNCH))
+ xerror("glp_ios_branch_upon: sel = %d: invalid branch selectio"
+ "n flag\n", sel);
+ if (!(tree->non_int[j]))
+ xerror("glp_ios_branch_upon: j = %d; variable cannot be used t"
+ "o branch upon\n", j);
+ if (tree->br_var != 0)
+ xerror("glp_ios_branch_upon: branching variable already chosen"
+ "\n");
+ tree->br_var = j;
+ tree->br_sel = sel;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_select_node - select subproblem to continue the search
+*
+* SYNOPSIS
+*
+* void glp_ios_select_node(glp_tree *tree, int p);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_select_node can be called from the user-defined
+* callback routine in response to the reason GLP_ISELECT to select an
+* active subproblem, whose reference number is p. The search will be
+* continued from the subproblem selected. */
+
+void glp_ios_select_node(glp_tree *tree, int p)
+{ IOSNPD *node;
+ /* obtain pointer to the specified subproblem */
+ if (!(1 <= p && p <= tree->nslots))
+err: xerror("glp_ios_select_node: p = %d; invalid subproblem refere"
+ "nce number\n", p);
+ node = tree->slot[p].node;
+ if (node == NULL) goto err;
+ /* the specified subproblem must be active */
+ if (node->count != 0)
+ xerror("glp_ios_select_node: p = %d; subproblem not in the act"
+ "ive list\n", p);
+ /* no subproblem must be selected yet */
+ if (tree->next_p != 0)
+ xerror("glp_ios_select_node: subproblem already selected\n");
+ /* select the specified subproblem to continue the search */
+ tree->next_p = p;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_heur_sol - provide solution found by heuristic
+*
+* SYNOPSIS
+*
+* int glp_ios_heur_sol(glp_tree *tree, const double x[]);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_heur_sol can be called from the user-defined
+* callback routine in response to the reason GLP_IHEUR to provide an
+* integer feasible solution found by a primal heuristic.
+*
+* Primal values of *all* variables (columns) found by the heuristic
+* should be placed in locations x[1], ..., x[n], where n is the number
+* of columns in the original problem object. Note that the routine
+* glp_ios_heur_sol *does not* check primal feasibility of the solution
+* provided.
+*
+* Using the solution passed in the array x the routine computes value
+* of the objective function. If the objective value is better than the
+* best known integer feasible solution, the routine computes values of
+* auxiliary variables (rows) and stores all solution components in the
+* problem object.
+*
+* RETURNS
+*
+* If the provided solution is accepted, the routine glp_ios_heur_sol
+* returns zero. Otherwise, if the provided solution is rejected, the
+* routine returns non-zero. */
+
+int glp_ios_heur_sol(glp_tree *tree, const double x[])
+{ glp_prob *mip = tree->mip;
+ int m = tree->orig_m;
+ int n = tree->n;
+ int i, j;
+ double obj;
+ xassert(mip->m >= m);
+ xassert(mip->n == n);
+ /* check values of integer variables and compute value of the
+ objective function */
+ obj = mip->c0;
+ for (j = 1; j <= n; j++)
+ { GLPCOL *col = mip->col[j];
+ if (col->kind == GLP_IV)
+ { /* provided value must be integral */
+ if (x[j] != floor(x[j])) return 1;
+ }
+ obj += col->coef * x[j];
+ }
+ /* check if the provided solution is better than the best known
+ integer feasible solution */
+ if (mip->mip_stat == GLP_FEAS)
+ { switch (mip->dir)
+ { case GLP_MIN:
+ if (obj >= tree->mip->mip_obj) return 1;
+ break;
+ case GLP_MAX:
+ if (obj <= tree->mip->mip_obj) return 1;
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ }
+ /* it is better; store it in the problem object */
+ if (tree->parm->msg_lev >= GLP_MSG_ON)
+ xprintf("Solution found by heuristic: %.12g\n", obj);
+ mip->mip_stat = GLP_FEAS;
+ mip->mip_obj = obj;
+ for (j = 1; j <= n; j++)
+ mip->col[j]->mipx = x[j];
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = mip->row[i];
+ GLPAIJ *aij;
+ row->mipx = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ row->mipx += aij->val * aij->col->mipx;
+ }
+#if 1 /* 11/VII-2013 */
+ ios_process_sol(tree);
+#endif
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ios_terminate - terminate the solution process.
+*
+* SYNOPSIS
+*
+* void glp_ios_terminate(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine glp_ios_terminate sets a flag indicating that the MIP
+* solver should prematurely terminate the search. */
+
+void glp_ios_terminate(glp_tree *tree)
+{ if (tree->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("The search is prematurely terminated due to applicati"
+ "on request\n");
+ tree->stop = 1;
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glphbm.c b/test/monniaux/glpk-4.65/src/draft/glphbm.c
new file mode 100644
index 00000000..8b33c172
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glphbm.c
@@ -0,0 +1,533 @@
+/* glphbm.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glphbm.h"
+#include "misc.h"
+
+/***********************************************************************
+* NAME
+*
+* hbm_read_mat - read sparse matrix in Harwell-Boeing format
+*
+* SYNOPSIS
+*
+* #include "glphbm.h"
+* HBM *hbm_read_mat(const char *fname);
+*
+* DESCRIPTION
+*
+* The routine hbm_read_mat reads a sparse matrix in the Harwell-Boeing
+* format from a text file whose name is the character string fname.
+*
+* Detailed description of the Harwell-Boeing format recognised by this
+* routine is given in the following report:
+*
+* I.S.Duff, R.G.Grimes, J.G.Lewis. User's Guide for the Harwell-Boeing
+* Sparse Matrix Collection (Release I), TR/PA/92/86, October 1992.
+*
+* RETURNS
+*
+* If no error occured, the routine hbm_read_mat returns a pointer to
+* a data structure containing the matrix. In case of error the routine
+* prints an appropriate error message and returns NULL. */
+
+struct dsa
+{ /* working area used by routine hbm_read_mat */
+ const char *fname;
+ /* name of input text file */
+ FILE *fp;
+ /* stream assigned to input text file */
+ int seqn;
+ /* card sequential number */
+ char card[80+1];
+ /* card image buffer */
+ int fmt_p;
+ /* scale factor */
+ int fmt_k;
+ /* iterator */
+ int fmt_f;
+ /* format code */
+ int fmt_w;
+ /* field width */
+ int fmt_d;
+ /* number of decimal places after point */
+};
+
+/***********************************************************************
+* read_card - read next data card
+*
+* This routine reads the next 80-column card from the input text file
+* and stores its image into the character string card. If the card was
+* read successfully, the routine returns zero, otherwise non-zero. */
+
+#if 1 /* 11/III-2012 */
+static int read_card(struct dsa *dsa)
+{ int c, len = 0;
+ char buf[255+1];
+ dsa->seqn++;
+ for (;;)
+ { c = fgetc(dsa->fp);
+ if (c == EOF)
+ { if (ferror(dsa->fp))
+ xprintf("%s:%d: read error\n",
+ dsa->fname, dsa->seqn);
+ else
+ xprintf("%s:%d: unexpected end-of-file\n",
+ dsa->fname, dsa->seqn);
+ return 1;
+ }
+ else if (c == '\r')
+ /* nop */;
+ else if (c == '\n')
+ break;
+ else if (iscntrl(c))
+ { xprintf("%s:%d: invalid control character\n",
+ dsa->fname, dsa->seqn, c);
+ return 1;
+ }
+ else
+ { if (len == sizeof(buf)-1)
+ goto err;
+ buf[len++] = (char)c;
+ }
+ }
+ /* remove trailing spaces */
+ while (len > 80 && buf[len-1] == ' ')
+ len--;
+ buf[len] = '\0';
+ /* line should not be longer than 80 chars */
+ if (len > 80)
+err: { xerror("%s:%d: card image too long\n",
+ dsa->fname, dsa->seqn);
+ return 1;
+ }
+ /* padd by spaces to 80-column card image */
+ strcpy(dsa->card, buf);
+ memset(&dsa->card[len], ' ', 80 - len);
+ dsa->card[80] = '\0';
+ return 0;
+}
+#endif
+
+/***********************************************************************
+* scan_int - scan integer value from the current card
+*
+* This routine scans an integer value from the current card, where fld
+* is the name of the field, pos is the position of the field, width is
+* the width of the field, val points to a location to which the scanned
+* value should be stored. If the value was scanned successfully, the
+* routine returns zero, otherwise non-zero. */
+
+static int scan_int(struct dsa *dsa, char *fld, int pos, int width,
+ int *val)
+{ char str[80+1];
+ xassert(1 <= width && width <= 80);
+ memcpy(str, dsa->card + pos, width), str[width] = '\0';
+ if (str2int(strspx(str), val))
+ { xprintf("%s:%d: field '%s' contains invalid value '%s'\n",
+ dsa->fname, dsa->seqn, fld, str);
+ return 1;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* parse_fmt - parse Fortran format specification
+*
+* This routine parses the Fortran format specification represented as
+* character string which fmt points to and stores format elements into
+* appropriate static locations. Should note that not all valid Fortran
+* format specifications may be recognised. If the format specification
+* was recognised, the routine returns zero, otherwise non-zero. */
+
+static int parse_fmt(struct dsa *dsa, char *fmt)
+{ int k, s, val;
+ char str[80+1];
+ /* first character should be left parenthesis */
+ if (fmt[0] != '(')
+fail: { xprintf("hbm_read_mat: format '%s' not recognised\n", fmt);
+ return 1;
+ }
+ k = 1;
+ /* optional scale factor */
+ dsa->fmt_p = 0;
+ if (isdigit((unsigned char)fmt[k]))
+ { s = 0;
+ while (isdigit((unsigned char)fmt[k]))
+ { if (s == 80) goto fail;
+ str[s++] = fmt[k++];
+ }
+ str[s] = '\0';
+ if (str2int(str, &val)) goto fail;
+ if (toupper((unsigned char)fmt[k]) != 'P') goto iter;
+ dsa->fmt_p = val, k++;
+ if (!(0 <= dsa->fmt_p && dsa->fmt_p <= 255)) goto fail;
+ /* optional comma may follow scale factor */
+ if (fmt[k] == ',') k++;
+ }
+ /* optional iterator */
+ dsa->fmt_k = 1;
+ if (isdigit((unsigned char)fmt[k]))
+ { s = 0;
+ while (isdigit((unsigned char)fmt[k]))
+ { if (s == 80) goto fail;
+ str[s++] = fmt[k++];
+ }
+ str[s] = '\0';
+ if (str2int(str, &val)) goto fail;
+iter: dsa->fmt_k = val;
+ if (!(1 <= dsa->fmt_k && dsa->fmt_k <= 255)) goto fail;
+ }
+ /* format code */
+ dsa->fmt_f = toupper((unsigned char)fmt[k++]);
+ if (!(dsa->fmt_f == 'D' || dsa->fmt_f == 'E' ||
+ dsa->fmt_f == 'F' || dsa->fmt_f == 'G' ||
+ dsa->fmt_f == 'I')) goto fail;
+ /* field width */
+ if (!isdigit((unsigned char)fmt[k])) goto fail;
+ s = 0;
+ while (isdigit((unsigned char)fmt[k]))
+ { if (s == 80) goto fail;
+ str[s++] = fmt[k++];
+ }
+ str[s] = '\0';
+ if (str2int(str, &dsa->fmt_w)) goto fail;
+ if (!(1 <= dsa->fmt_w && dsa->fmt_w <= 255)) goto fail;
+ /* optional number of decimal places after point */
+ dsa->fmt_d = 0;
+ if (fmt[k] == '.')
+ { k++;
+ if (!isdigit((unsigned char)fmt[k])) goto fail;
+ s = 0;
+ while (isdigit((unsigned char)fmt[k]))
+ { if (s == 80) goto fail;
+ str[s++] = fmt[k++];
+ }
+ str[s] = '\0';
+ if (str2int(str, &dsa->fmt_d)) goto fail;
+ if (!(0 <= dsa->fmt_d && dsa->fmt_d <= 255)) goto fail;
+ }
+ /* last character should be right parenthesis */
+ if (!(fmt[k] == ')' && fmt[k+1] == '\0')) goto fail;
+ return 0;
+}
+
+/***********************************************************************
+* read_int_array - read array of integer type
+*
+* This routine reads an integer array from the input text file, where
+* name is array name, fmt is Fortran format specification that controls
+* reading, n is number of array elements, val is array of integer type.
+* If the array was read successful, the routine returns zero, otherwise
+* non-zero. */
+
+static int read_int_array(struct dsa *dsa, char *name, char *fmt,
+ int n, int val[])
+{ int k, pos;
+ char str[80+1];
+ if (parse_fmt(dsa, fmt)) return 1;
+ if (!(dsa->fmt_f == 'I' && dsa->fmt_w <= 80 &&
+ dsa->fmt_k * dsa->fmt_w <= 80))
+ { xprintf(
+ "%s:%d: can't read array '%s' - invalid format '%s'\n",
+ dsa->fname, dsa->seqn, name, fmt);
+ return 1;
+ }
+ for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
+ { if (pos >= dsa->fmt_k)
+ { if (read_card(dsa)) return 1;
+ pos = 0;
+ }
+ memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
+ str[dsa->fmt_w] = '\0';
+ strspx(str);
+ if (str2int(str, &val[k]))
+ { xprintf(
+ "%s:%d: can't read array '%s' - invalid value '%s'\n",
+ dsa->fname, dsa->seqn, name, str);
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* read_real_array - read array of real type
+*
+* This routine reads a real array from the input text file, where name
+* is array name, fmt is Fortran format specification that controls
+* reading, n is number of array elements, val is array of real type.
+* If the array was read successful, the routine returns zero, otherwise
+* non-zero. */
+
+static int read_real_array(struct dsa *dsa, char *name, char *fmt,
+ int n, double val[])
+{ int k, pos;
+ char str[80+1], *ptr;
+ if (parse_fmt(dsa, fmt)) return 1;
+ if (!(dsa->fmt_f != 'I' && dsa->fmt_w <= 80 &&
+ dsa->fmt_k * dsa->fmt_w <= 80))
+ { xprintf(
+ "%s:%d: can't read array '%s' - invalid format '%s'\n",
+ dsa->fname, dsa->seqn, name, fmt);
+ return 1;
+ }
+ for (k = 1, pos = INT_MAX; k <= n; k++, pos++)
+ { if (pos >= dsa->fmt_k)
+ { if (read_card(dsa)) return 1;
+ pos = 0;
+ }
+ memcpy(str, dsa->card + dsa->fmt_w * pos, dsa->fmt_w);
+ str[dsa->fmt_w] = '\0';
+ strspx(str);
+ if (strchr(str, '.') == NULL && strcmp(str, "0"))
+ { xprintf("%s(%d): can't read array '%s' - value '%s' has no "
+ "decimal point\n", dsa->fname, dsa->seqn, name, str);
+ return 1;
+ }
+ /* sometimes lower case letters appear */
+ for (ptr = str; *ptr; ptr++)
+ *ptr = (char)toupper((unsigned char)*ptr);
+ ptr = strchr(str, 'D');
+ if (ptr != NULL) *ptr = 'E';
+ /* value may appear with decimal exponent but without letters
+ E or D (for example, -123.456-012), so missing letter should
+ be inserted */
+ ptr = strchr(str+1, '+');
+ if (ptr == NULL) ptr = strchr(str+1, '-');
+ if (ptr != NULL && *(ptr-1) != 'E')
+ { xassert(strlen(str) < 80);
+ memmove(ptr+1, ptr, strlen(ptr)+1);
+ *ptr = 'E';
+ }
+ if (str2num(str, &val[k]))
+ { xprintf(
+ "%s:%d: can't read array '%s' - invalid value '%s'\n",
+ dsa->fname, dsa->seqn, name, str);
+ return 1;
+ }
+ }
+ return 0;
+}
+
+HBM *hbm_read_mat(const char *fname)
+{ struct dsa _dsa, *dsa = &_dsa;
+ HBM *hbm = NULL;
+ dsa->fname = fname;
+ xprintf("hbm_read_mat: reading matrix from '%s'...\n",
+ dsa->fname);
+ dsa->fp = fopen(dsa->fname, "r");
+ if (dsa->fp == NULL)
+ { xprintf("hbm_read_mat: unable to open '%s' - %s\n",
+#if 0 /* 29/I-2017 */
+ dsa->fname, strerror(errno));
+#else
+ dsa->fname, xstrerr(errno));
+#endif
+ goto fail;
+ }
+ dsa->seqn = 0;
+ hbm = xmalloc(sizeof(HBM));
+ memset(hbm, 0, sizeof(HBM));
+ /* read the first heading card */
+ if (read_card(dsa)) goto fail;
+ memcpy(hbm->title, dsa->card, 72), hbm->title[72] = '\0';
+ strtrim(hbm->title);
+ xprintf("%s\n", hbm->title);
+ memcpy(hbm->key, dsa->card+72, 8), hbm->key[8] = '\0';
+ strspx(hbm->key);
+ xprintf("key = %s\n", hbm->key);
+ /* read the second heading card */
+ if (read_card(dsa)) goto fail;
+ if (scan_int(dsa, "totcrd", 0, 14, &hbm->totcrd)) goto fail;
+ if (scan_int(dsa, "ptrcrd", 14, 14, &hbm->ptrcrd)) goto fail;
+ if (scan_int(dsa, "indcrd", 28, 14, &hbm->indcrd)) goto fail;
+ if (scan_int(dsa, "valcrd", 42, 14, &hbm->valcrd)) goto fail;
+ if (scan_int(dsa, "rhscrd", 56, 14, &hbm->rhscrd)) goto fail;
+ xprintf("totcrd = %d; ptrcrd = %d; indcrd = %d; valcrd = %d; rhsc"
+ "rd = %d\n", hbm->totcrd, hbm->ptrcrd, hbm->indcrd,
+ hbm->valcrd, hbm->rhscrd);
+ /* read the third heading card */
+ if (read_card(dsa)) goto fail;
+ memcpy(hbm->mxtype, dsa->card, 3), hbm->mxtype[3] = '\0';
+ if (strchr("RCP", hbm->mxtype[0]) == NULL ||
+ strchr("SUHZR", hbm->mxtype[1]) == NULL ||
+ strchr("AE", hbm->mxtype[2]) == NULL)
+ { xprintf("%s:%d: matrix type '%s' not recognised\n",
+ dsa->fname, dsa->seqn, hbm->mxtype);
+ goto fail;
+ }
+ if (scan_int(dsa, "nrow", 14, 14, &hbm->nrow)) goto fail;
+ if (scan_int(dsa, "ncol", 28, 14, &hbm->ncol)) goto fail;
+ if (scan_int(dsa, "nnzero", 42, 14, &hbm->nnzero)) goto fail;
+ if (scan_int(dsa, "neltvl", 56, 14, &hbm->neltvl)) goto fail;
+ xprintf("mxtype = %s; nrow = %d; ncol = %d; nnzero = %d; neltvl ="
+ " %d\n", hbm->mxtype, hbm->nrow, hbm->ncol, hbm->nnzero,
+ hbm->neltvl);
+ /* read the fourth heading card */
+ if (read_card(dsa)) goto fail;
+ memcpy(hbm->ptrfmt, dsa->card, 16), hbm->ptrfmt[16] = '\0';
+ strspx(hbm->ptrfmt);
+ memcpy(hbm->indfmt, dsa->card+16, 16), hbm->indfmt[16] = '\0';
+ strspx(hbm->indfmt);
+ memcpy(hbm->valfmt, dsa->card+32, 20), hbm->valfmt[20] = '\0';
+ strspx(hbm->valfmt);
+ memcpy(hbm->rhsfmt, dsa->card+52, 20), hbm->rhsfmt[20] = '\0';
+ strspx(hbm->rhsfmt);
+ xprintf("ptrfmt = %s; indfmt = %s; valfmt = %s; rhsfmt = %s\n",
+ hbm->ptrfmt, hbm->indfmt, hbm->valfmt, hbm->rhsfmt);
+ /* read the fifth heading card (optional) */
+ if (hbm->rhscrd <= 0)
+ { strcpy(hbm->rhstyp, "???");
+ hbm->nrhs = 0;
+ hbm->nrhsix = 0;
+ }
+ else
+ { if (read_card(dsa)) goto fail;
+ memcpy(hbm->rhstyp, dsa->card, 3), hbm->rhstyp[3] = '\0';
+ if (scan_int(dsa, "nrhs", 14, 14, &hbm->nrhs)) goto fail;
+ if (scan_int(dsa, "nrhsix", 28, 14, &hbm->nrhsix)) goto fail;
+ xprintf("rhstyp = '%s'; nrhs = %d; nrhsix = %d\n",
+ hbm->rhstyp, hbm->nrhs, hbm->nrhsix);
+ }
+ /* read matrix structure */
+ hbm->colptr = xcalloc(1+hbm->ncol+1, sizeof(int));
+ if (read_int_array(dsa, "colptr", hbm->ptrfmt, hbm->ncol+1,
+ hbm->colptr)) goto fail;
+ hbm->rowind = xcalloc(1+hbm->nnzero, sizeof(int));
+ if (read_int_array(dsa, "rowind", hbm->indfmt, hbm->nnzero,
+ hbm->rowind)) goto fail;
+ /* read matrix values */
+ if (hbm->valcrd <= 0) goto done;
+ if (hbm->mxtype[2] == 'A')
+ { /* assembled matrix */
+ hbm->values = xcalloc(1+hbm->nnzero, sizeof(double));
+ if (read_real_array(dsa, "values", hbm->valfmt, hbm->nnzero,
+ hbm->values)) goto fail;
+ }
+ else
+ { /* elemental (unassembled) matrix */
+ hbm->values = xcalloc(1+hbm->neltvl, sizeof(double));
+ if (read_real_array(dsa, "values", hbm->valfmt, hbm->neltvl,
+ hbm->values)) goto fail;
+ }
+ /* read right-hand sides */
+ if (hbm->nrhs <= 0) goto done;
+ if (hbm->rhstyp[0] == 'F')
+ { /* dense format */
+ hbm->nrhsvl = hbm->nrow * hbm->nrhs;
+ hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
+ if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
+ hbm->rhsval)) goto fail;
+ }
+ else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'A')
+ { /* sparse format */
+ /* read pointers */
+ hbm->rhsptr = xcalloc(1+hbm->nrhs+1, sizeof(int));
+ if (read_int_array(dsa, "rhsptr", hbm->ptrfmt, hbm->nrhs+1,
+ hbm->rhsptr)) goto fail;
+ /* read sparsity pattern */
+ hbm->rhsind = xcalloc(1+hbm->nrhsix, sizeof(int));
+ if (read_int_array(dsa, "rhsind", hbm->indfmt, hbm->nrhsix,
+ hbm->rhsind)) goto fail;
+ /* read values */
+ hbm->rhsval = xcalloc(1+hbm->nrhsix, sizeof(double));
+ if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsix,
+ hbm->rhsval)) goto fail;
+ }
+ else if (hbm->rhstyp[0] == 'M' && hbm->mxtype[2] == 'E')
+ { /* elemental format */
+ hbm->rhsval = xcalloc(1+hbm->nrhsvl, sizeof(double));
+ if (read_real_array(dsa, "rhsval", hbm->rhsfmt, hbm->nrhsvl,
+ hbm->rhsval)) goto fail;
+ }
+ else
+ { xprintf("%s:%d: right-hand side type '%c' not recognised\n",
+ dsa->fname, dsa->seqn, hbm->rhstyp[0]);
+ goto fail;
+ }
+ /* read starting guesses */
+ if (hbm->rhstyp[1] == 'G')
+ { hbm->nguess = hbm->nrow * hbm->nrhs;
+ hbm->sguess = xcalloc(1+hbm->nguess, sizeof(double));
+ if (read_real_array(dsa, "sguess", hbm->rhsfmt, hbm->nguess,
+ hbm->sguess)) goto fail;
+ }
+ /* read solution vectors */
+ if (hbm->rhstyp[2] == 'X')
+ { hbm->nexact = hbm->nrow * hbm->nrhs;
+ hbm->xexact = xcalloc(1+hbm->nexact, sizeof(double));
+ if (read_real_array(dsa, "xexact", hbm->rhsfmt, hbm->nexact,
+ hbm->xexact)) goto fail;
+ }
+done: /* reading has been completed */
+ xprintf("hbm_read_mat: %d cards were read\n", dsa->seqn);
+ fclose(dsa->fp);
+ return hbm;
+fail: /* something wrong in Danish kingdom */
+ if (hbm != NULL)
+ { if (hbm->colptr != NULL) xfree(hbm->colptr);
+ if (hbm->rowind != NULL) xfree(hbm->rowind);
+ if (hbm->rhsptr != NULL) xfree(hbm->rhsptr);
+ if (hbm->rhsind != NULL) xfree(hbm->rhsind);
+ if (hbm->values != NULL) xfree(hbm->values);
+ if (hbm->rhsval != NULL) xfree(hbm->rhsval);
+ if (hbm->sguess != NULL) xfree(hbm->sguess);
+ if (hbm->xexact != NULL) xfree(hbm->xexact);
+ xfree(hbm);
+ }
+ if (dsa->fp != NULL) fclose(dsa->fp);
+ return NULL;
+}
+
+/***********************************************************************
+* NAME
+*
+* hbm_free_mat - free sparse matrix in Harwell-Boeing format
+*
+* SYNOPSIS
+*
+* #include "glphbm.h"
+* void hbm_free_mat(HBM *hbm);
+*
+* DESCRIPTION
+*
+* The hbm_free_mat routine frees all the memory allocated to the data
+* structure containing a sparse matrix in the Harwell-Boeing format. */
+
+void hbm_free_mat(HBM *hbm)
+{ if (hbm->colptr != NULL) xfree(hbm->colptr);
+ if (hbm->rowind != NULL) xfree(hbm->rowind);
+ if (hbm->rhsptr != NULL) xfree(hbm->rhsptr);
+ if (hbm->rhsind != NULL) xfree(hbm->rhsind);
+ if (hbm->values != NULL) xfree(hbm->values);
+ if (hbm->rhsval != NULL) xfree(hbm->rhsval);
+ if (hbm->sguess != NULL) xfree(hbm->sguess);
+ if (hbm->xexact != NULL) xfree(hbm->xexact);
+ xfree(hbm);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glphbm.h b/test/monniaux/glpk-4.65/src/draft/glphbm.h
new file mode 100644
index 00000000..688a78ec
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glphbm.h
@@ -0,0 +1,127 @@
+/* glphbm.h (Harwell-Boeing sparse matrix format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPHBM_H
+#define GLPHBM_H
+
+typedef struct HBM HBM;
+
+struct HBM
+{ /* sparse matrix in Harwell-Boeing format; for details see the
+ report: I.S.Duff, R.G.Grimes, J.G.Lewis. User's Guide for the
+ Harwell-Boeing Sparse Matrix Collection (Release I), 1992 */
+ char title[72+1];
+ /* matrix title (informative) */
+ char key[8+1];
+ /* matrix key (informative) */
+ char mxtype[3+1];
+ /* matrix type:
+ R.. real matrix
+ C.. complex matrix
+ P.. pattern only (no numerical values supplied)
+ .S. symmetric (lower triangle + main diagonal)
+ .U. unsymmetric
+ .H. hermitian (lower triangle + main diagonal)
+ .Z. skew symmetric (lower triangle only)
+ .R. rectangular
+ ..A assembled
+ ..E elemental (unassembled) */
+ char rhstyp[3+1];
+ /* optional types:
+ F.. right-hand sides in dense format
+ M.. right-hand sides in same format as matrix
+ .G. starting vector(s) (guess) is supplied
+ ..X exact solution vector(s) is supplied */
+ char ptrfmt[16+1];
+ /* format for pointers */
+ char indfmt[16+1];
+ /* format for row (or variable) indices */
+ char valfmt[20+1];
+ /* format for numerical values of coefficient matrix */
+ char rhsfmt[20+1];
+ /* format for numerical values of right-hand sides */
+ int totcrd;
+ /* total number of cards excluding header */
+ int ptrcrd;
+ /* number of cards for ponters */
+ int indcrd;
+ /* number of cards for row (or variable) indices */
+ int valcrd;
+ /* number of cards for numerical values */
+ int rhscrd;
+ /* number of lines for right-hand sides;
+ including starting guesses and solution vectors if present;
+ zero indicates no right-hand side data is present */
+ int nrow;
+ /* number of rows (or variables) */
+ int ncol;
+ /* number of columns (or elements) */
+ int nnzero;
+ /* number of row (or variable) indices;
+ equal to number of entries for assembled matrix */
+ int neltvl;
+ /* number of elemental matrix entries;
+ zero in case of assembled matrix */
+ int nrhs;
+ /* number of right-hand sides */
+ int nrhsix;
+ /* number of row indices;
+ ignored in case of unassembled matrix */
+ int nrhsvl;
+ /* total number of entries in all right-hand sides */
+ int nguess;
+ /* total number of entries in all starting guesses */
+ int nexact;
+ /* total number of entries in all solution vectors */
+ int *colptr; /* alias: eltptr */
+ /* column pointers (in case of assembled matrix);
+ elemental matrix pointers (in case of unassembled matrix) */
+ int *rowind; /* alias: varind */
+ /* row indices (in case of assembled matrix);
+ variable indices (in case of unassembled matrix) */
+ int *rhsptr;
+ /* right-hand side pointers */
+ int *rhsind;
+ /* right-hand side indices */
+ double *values;
+ /* matrix values */
+ double *rhsval;
+ /* right-hand side values */
+ double *sguess;
+ /* starting guess values */
+ double *xexact;
+ /* solution vector values */
+};
+
+#define hbm_read_mat _glp_hbm_read_mat
+HBM *hbm_read_mat(const char *fname);
+/* read sparse matrix in Harwell-Boeing format */
+
+#define hbm_free_mat _glp_hbm_free_mat
+void hbm_free_mat(HBM *hbm);
+/* free sparse matrix in Harwell-Boeing format */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios01.c b/test/monniaux/glpk-4.65/src/draft/glpios01.c
new file mode 100644
index 00000000..cb1a0dab
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios01.c
@@ -0,0 +1,1685 @@
+/* glpios01.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+#include "misc.h"
+
+static int lpx_eval_tab_row(glp_prob *lp, int k, int ind[],
+ double val[])
+{ /* compute row of the simplex tableau */
+ return glp_eval_tab_row(lp, k, ind, val);
+}
+
+static int lpx_dual_ratio_test(glp_prob *lp, int len, const int ind[],
+ const double val[], int how, double tol)
+{ /* perform dual ratio test */
+ int piv;
+ piv = glp_dual_rtest(lp, len, ind, val, how, tol);
+ xassert(0 <= piv && piv <= len);
+ return piv == 0 ? 0 : ind[piv];
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_create_tree - create branch-and-bound tree
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* glp_tree *ios_create_tree(glp_prob *mip, const glp_iocp *parm);
+*
+* DESCRIPTION
+*
+* The routine ios_create_tree creates the branch-and-bound tree.
+*
+* Being created the tree consists of the only root subproblem whose
+* reference number is 1. Note that initially the root subproblem is in
+* frozen state and therefore needs to be revived.
+*
+* RETURNS
+*
+* The routine returns a pointer to the tree created. */
+
+static IOSNPD *new_node(glp_tree *tree, IOSNPD *parent);
+
+glp_tree *ios_create_tree(glp_prob *mip, const glp_iocp *parm)
+{ int m = mip->m;
+ int n = mip->n;
+ glp_tree *tree;
+ int i, j;
+ xassert(mip->tree == NULL);
+ mip->tree = tree = xmalloc(sizeof(glp_tree));
+ tree->pool = dmp_create_pool();
+ tree->n = n;
+ /* save original problem components */
+ tree->orig_m = m;
+ tree->orig_type = xcalloc(1+m+n, sizeof(char));
+ tree->orig_lb = xcalloc(1+m+n, sizeof(double));
+ tree->orig_ub = xcalloc(1+m+n, sizeof(double));
+ tree->orig_stat = xcalloc(1+m+n, sizeof(char));
+ tree->orig_prim = xcalloc(1+m+n, sizeof(double));
+ tree->orig_dual = xcalloc(1+m+n, sizeof(double));
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = mip->row[i];
+ tree->orig_type[i] = (char)row->type;
+ tree->orig_lb[i] = row->lb;
+ tree->orig_ub[i] = row->ub;
+ tree->orig_stat[i] = (char)row->stat;
+ tree->orig_prim[i] = row->prim;
+ tree->orig_dual[i] = row->dual;
+ }
+ for (j = 1; j <= n; j++)
+ { GLPCOL *col = mip->col[j];
+ tree->orig_type[m+j] = (char)col->type;
+ tree->orig_lb[m+j] = col->lb;
+ tree->orig_ub[m+j] = col->ub;
+ tree->orig_stat[m+j] = (char)col->stat;
+ tree->orig_prim[m+j] = col->prim;
+ tree->orig_dual[m+j] = col->dual;
+ }
+ tree->orig_obj = mip->obj_val;
+ /* initialize the branch-and-bound tree */
+ tree->nslots = 0;
+ tree->avail = 0;
+ tree->slot = NULL;
+ tree->head = tree->tail = NULL;
+ tree->a_cnt = tree->n_cnt = tree->t_cnt = 0;
+ /* the root subproblem is not solved yet, so its final components
+ are unknown so far */
+ tree->root_m = 0;
+ tree->root_type = NULL;
+ tree->root_lb = tree->root_ub = NULL;
+ tree->root_stat = NULL;
+ /* the current subproblem does not exist yet */
+ tree->curr = NULL;
+ tree->mip = mip;
+ /*tree->solved = 0;*/
+ tree->non_int = xcalloc(1+n, sizeof(char));
+ memset(&tree->non_int[1], 0, n);
+ /* arrays to save parent subproblem components will be allocated
+ later */
+ tree->pred_m = tree->pred_max = 0;
+ tree->pred_type = NULL;
+ tree->pred_lb = tree->pred_ub = NULL;
+ tree->pred_stat = NULL;
+ /* cut generators */
+ tree->local = ios_create_pool(tree);
+ /*tree->first_attempt = 1;*/
+ /*tree->max_added_cuts = 0;*/
+ /*tree->min_eff = 0.0;*/
+ /*tree->miss = 0;*/
+ /*tree->just_selected = 0;*/
+#ifdef NEW_COVER /* 13/II-2018 */
+ tree->cov_gen = NULL;
+#endif
+ tree->mir_gen = NULL;
+ tree->clq_gen = NULL;
+ /*tree->round = 0;*/
+#if 0
+ /* create the conflict graph */
+ tree->n_ref = xcalloc(1+n, sizeof(int));
+ memset(&tree->n_ref[1], 0, n * sizeof(int));
+ tree->c_ref = xcalloc(1+n, sizeof(int));
+ memset(&tree->c_ref[1], 0, n * sizeof(int));
+ tree->g = scg_create_graph(0);
+ tree->j_ref = xcalloc(1+tree->g->n_max, sizeof(int));
+#endif
+ /* pseudocost branching */
+ tree->pcost = NULL;
+ tree->iwrk = xcalloc(1+n, sizeof(int));
+ tree->dwrk = xcalloc(1+n, sizeof(double));
+ /* initialize control parameters */
+ tree->parm = parm;
+ tree->tm_beg = xtime();
+#if 0 /* 10/VI-2013 */
+ tree->tm_lag = xlset(0);
+#else
+ tree->tm_lag = 0.0;
+#endif
+ tree->sol_cnt = 0;
+#if 1 /* 11/VII-2013 */
+ tree->P = NULL;
+ tree->npp = NULL;
+ tree->save_sol = parm->save_sol;
+ tree->save_cnt = 0;
+#endif
+ /* initialize advanced solver interface */
+ tree->reason = 0;
+ tree->reopt = 0;
+ tree->reinv = 0;
+ tree->br_var = 0;
+ tree->br_sel = 0;
+ tree->child = 0;
+ tree->next_p = 0;
+ /*tree->btrack = NULL;*/
+ tree->stop = 0;
+ /* create the root subproblem, which initially is identical to
+ the original MIP */
+ new_node(tree, NULL);
+ return tree;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_revive_node - revive specified subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_revive_node(glp_tree *tree, int p);
+*
+* DESCRIPTION
+*
+* The routine ios_revive_node revives the specified subproblem, whose
+* reference number is p, and thereby makes it the current subproblem.
+* Note that the specified subproblem must be active. Besides, if the
+* current subproblem already exists, it must be frozen before reviving
+* another subproblem. */
+
+void ios_revive_node(glp_tree *tree, int p)
+{ glp_prob *mip = tree->mip;
+ IOSNPD *node, *root;
+ /* obtain pointer to the specified subproblem */
+ xassert(1 <= p && p <= tree->nslots);
+ node = tree->slot[p].node;
+ xassert(node != NULL);
+ /* the specified subproblem must be active */
+ xassert(node->count == 0);
+ /* the current subproblem must not exist */
+ xassert(tree->curr == NULL);
+ /* the specified subproblem becomes current */
+ tree->curr = node;
+ /*tree->solved = 0;*/
+ /* obtain pointer to the root subproblem */
+ root = tree->slot[1].node;
+ xassert(root != NULL);
+ /* at this point problem object components correspond to the root
+ subproblem, so if the root subproblem should be revived, there
+ is nothing more to do */
+ if (node == root) goto done;
+ xassert(mip->m == tree->root_m);
+ /* build path from the root to the current node */
+ node->temp = NULL;
+ for (node = node; node != NULL; node = node->up)
+ { if (node->up == NULL)
+ xassert(node == root);
+ else
+ node->up->temp = node;
+ }
+ /* go down from the root to the current node and make necessary
+ changes to restore components of the current subproblem */
+ for (node = root; node != NULL; node = node->temp)
+ { int m = mip->m;
+ int n = mip->n;
+ /* if the current node is reached, the problem object at this
+ point corresponds to its parent, so save attributes of rows
+ and columns for the parent subproblem */
+ if (node->temp == NULL)
+ { int i, j;
+ tree->pred_m = m;
+ /* allocate/reallocate arrays, if necessary */
+ if (tree->pred_max < m + n)
+ { int new_size = m + n + 100;
+ if (tree->pred_type != NULL) xfree(tree->pred_type);
+ if (tree->pred_lb != NULL) xfree(tree->pred_lb);
+ if (tree->pred_ub != NULL) xfree(tree->pred_ub);
+ if (tree->pred_stat != NULL) xfree(tree->pred_stat);
+ tree->pred_max = new_size;
+ tree->pred_type = xcalloc(1+new_size, sizeof(char));
+ tree->pred_lb = xcalloc(1+new_size, sizeof(double));
+ tree->pred_ub = xcalloc(1+new_size, sizeof(double));
+ tree->pred_stat = xcalloc(1+new_size, sizeof(char));
+ }
+ /* save row attributes */
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = mip->row[i];
+ tree->pred_type[i] = (char)row->type;
+ tree->pred_lb[i] = row->lb;
+ tree->pred_ub[i] = row->ub;
+ tree->pred_stat[i] = (char)row->stat;
+ }
+ /* save column attributes */
+ for (j = 1; j <= n; j++)
+ { GLPCOL *col = mip->col[j];
+ tree->pred_type[mip->m+j] = (char)col->type;
+ tree->pred_lb[mip->m+j] = col->lb;
+ tree->pred_ub[mip->m+j] = col->ub;
+ tree->pred_stat[mip->m+j] = (char)col->stat;
+ }
+ }
+ /* change bounds of rows and columns */
+ { IOSBND *b;
+ for (b = node->b_ptr; b != NULL; b = b->next)
+ { if (b->k <= m)
+ glp_set_row_bnds(mip, b->k, b->type, b->lb, b->ub);
+ else
+ glp_set_col_bnds(mip, b->k-m, b->type, b->lb, b->ub);
+ }
+ }
+ /* change statuses of rows and columns */
+ { IOSTAT *s;
+ for (s = node->s_ptr; s != NULL; s = s->next)
+ { if (s->k <= m)
+ glp_set_row_stat(mip, s->k, s->stat);
+ else
+ glp_set_col_stat(mip, s->k-m, s->stat);
+ }
+ }
+ /* add new rows */
+ if (node->r_ptr != NULL)
+ { IOSROW *r;
+ IOSAIJ *a;
+ int i, len, *ind;
+ double *val;
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ for (r = node->r_ptr; r != NULL; r = r->next)
+ { i = glp_add_rows(mip, 1);
+ glp_set_row_name(mip, i, r->name);
+#if 1 /* 20/IX-2008 */
+ xassert(mip->row[i]->level == 0);
+ mip->row[i]->level = node->level;
+ mip->row[i]->origin = r->origin;
+ mip->row[i]->klass = r->klass;
+#endif
+ glp_set_row_bnds(mip, i, r->type, r->lb, r->ub);
+ len = 0;
+ for (a = r->ptr; a != NULL; a = a->next)
+ len++, ind[len] = a->j, val[len] = a->val;
+ glp_set_mat_row(mip, i, len, ind, val);
+ glp_set_rii(mip, i, r->rii);
+ glp_set_row_stat(mip, i, r->stat);
+ }
+ xfree(ind);
+ xfree(val);
+ }
+#if 0
+ /* add new edges to the conflict graph */
+ /* add new cliques to the conflict graph */
+ /* (not implemented yet) */
+ xassert(node->own_nn == 0);
+ xassert(node->own_nc == 0);
+ xassert(node->e_ptr == NULL);
+#endif
+ }
+ /* the specified subproblem has been revived */
+ node = tree->curr;
+ /* delete its bound change list */
+ while (node->b_ptr != NULL)
+ { IOSBND *b;
+ b = node->b_ptr;
+ node->b_ptr = b->next;
+ dmp_free_atom(tree->pool, b, sizeof(IOSBND));
+ }
+ /* delete its status change list */
+ while (node->s_ptr != NULL)
+ { IOSTAT *s;
+ s = node->s_ptr;
+ node->s_ptr = s->next;
+ dmp_free_atom(tree->pool, s, sizeof(IOSTAT));
+ }
+#if 1 /* 20/XI-2009 */
+ /* delete its row addition list (additional rows may appear, for
+ example, due to branching on GUB constraints */
+ while (node->r_ptr != NULL)
+ { IOSROW *r;
+ r = node->r_ptr;
+ node->r_ptr = r->next;
+ xassert(r->name == NULL);
+ while (r->ptr != NULL)
+ { IOSAIJ *a;
+ a = r->ptr;
+ r->ptr = a->next;
+ dmp_free_atom(tree->pool, a, sizeof(IOSAIJ));
+ }
+ dmp_free_atom(tree->pool, r, sizeof(IOSROW));
+ }
+#endif
+done: return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_freeze_node - freeze current subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_freeze_node(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_freeze_node freezes the current subproblem. */
+
+void ios_freeze_node(glp_tree *tree)
+{ glp_prob *mip = tree->mip;
+ int m = mip->m;
+ int n = mip->n;
+ IOSNPD *node;
+ /* obtain pointer to the current subproblem */
+ node = tree->curr;
+ xassert(node != NULL);
+ if (node->up == NULL)
+ { /* freeze the root subproblem */
+ int k;
+ xassert(node->p == 1);
+ xassert(tree->root_m == 0);
+ xassert(tree->root_type == NULL);
+ xassert(tree->root_lb == NULL);
+ xassert(tree->root_ub == NULL);
+ xassert(tree->root_stat == NULL);
+ tree->root_m = m;
+ tree->root_type = xcalloc(1+m+n, sizeof(char));
+ tree->root_lb = xcalloc(1+m+n, sizeof(double));
+ tree->root_ub = xcalloc(1+m+n, sizeof(double));
+ tree->root_stat = xcalloc(1+m+n, sizeof(char));
+ for (k = 1; k <= m+n; k++)
+ { if (k <= m)
+ { GLPROW *row = mip->row[k];
+ tree->root_type[k] = (char)row->type;
+ tree->root_lb[k] = row->lb;
+ tree->root_ub[k] = row->ub;
+ tree->root_stat[k] = (char)row->stat;
+ }
+ else
+ { GLPCOL *col = mip->col[k-m];
+ tree->root_type[k] = (char)col->type;
+ tree->root_lb[k] = col->lb;
+ tree->root_ub[k] = col->ub;
+ tree->root_stat[k] = (char)col->stat;
+ }
+ }
+ }
+ else
+ { /* freeze non-root subproblem */
+ int root_m = tree->root_m;
+ int pred_m = tree->pred_m;
+ int i, j, k;
+ xassert(pred_m <= m);
+ /* build change lists for rows and columns which exist in the
+ parent subproblem */
+ xassert(node->b_ptr == NULL);
+ xassert(node->s_ptr == NULL);
+ for (k = 1; k <= pred_m + n; k++)
+ { int pred_type, pred_stat, type, stat;
+ double pred_lb, pred_ub, lb, ub;
+ /* determine attributes in the parent subproblem */
+ pred_type = tree->pred_type[k];
+ pred_lb = tree->pred_lb[k];
+ pred_ub = tree->pred_ub[k];
+ pred_stat = tree->pred_stat[k];
+ /* determine attributes in the current subproblem */
+ if (k <= pred_m)
+ { GLPROW *row = mip->row[k];
+ type = row->type;
+ lb = row->lb;
+ ub = row->ub;
+ stat = row->stat;
+ }
+ else
+ { GLPCOL *col = mip->col[k - pred_m];
+ type = col->type;
+ lb = col->lb;
+ ub = col->ub;
+ stat = col->stat;
+ }
+ /* save type and bounds of a row/column, if changed */
+ if (!(pred_type == type && pred_lb == lb && pred_ub == ub))
+ { IOSBND *b;
+ b = dmp_get_atom(tree->pool, sizeof(IOSBND));
+ b->k = k;
+ b->type = (unsigned char)type;
+ b->lb = lb;
+ b->ub = ub;
+ b->next = node->b_ptr;
+ node->b_ptr = b;
+ }
+ /* save status of a row/column, if changed */
+ if (pred_stat != stat)
+ { IOSTAT *s;
+ s = dmp_get_atom(tree->pool, sizeof(IOSTAT));
+ s->k = k;
+ s->stat = (unsigned char)stat;
+ s->next = node->s_ptr;
+ node->s_ptr = s;
+ }
+ }
+ /* save new rows added to the current subproblem */
+ xassert(node->r_ptr == NULL);
+ if (pred_m < m)
+ { int i, len, *ind;
+ double *val;
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ for (i = m; i > pred_m; i--)
+ { GLPROW *row = mip->row[i];
+ IOSROW *r;
+ const char *name;
+ r = dmp_get_atom(tree->pool, sizeof(IOSROW));
+ name = glp_get_row_name(mip, i);
+ if (name == NULL)
+ r->name = NULL;
+ else
+ { r->name = dmp_get_atom(tree->pool, strlen(name)+1);
+ strcpy(r->name, name);
+ }
+#if 1 /* 20/IX-2008 */
+ r->origin = row->origin;
+ r->klass = row->klass;
+#endif
+ r->type = (unsigned char)row->type;
+ r->lb = row->lb;
+ r->ub = row->ub;
+ r->ptr = NULL;
+ len = glp_get_mat_row(mip, i, ind, val);
+ for (k = 1; k <= len; k++)
+ { IOSAIJ *a;
+ a = dmp_get_atom(tree->pool, sizeof(IOSAIJ));
+ a->j = ind[k];
+ a->val = val[k];
+ a->next = r->ptr;
+ r->ptr = a;
+ }
+ r->rii = row->rii;
+ r->stat = (unsigned char)row->stat;
+ r->next = node->r_ptr;
+ node->r_ptr = r;
+ }
+ xfree(ind);
+ xfree(val);
+ }
+ /* remove all rows missing in the root subproblem */
+ if (m != root_m)
+ { int nrs, *num;
+ nrs = m - root_m;
+ xassert(nrs > 0);
+ num = xcalloc(1+nrs, sizeof(int));
+ for (i = 1; i <= nrs; i++) num[i] = root_m + i;
+ glp_del_rows(mip, nrs, num);
+ xfree(num);
+ }
+ m = mip->m;
+ /* and restore attributes of all rows and columns for the root
+ subproblem */
+ xassert(m == root_m);
+ for (i = 1; i <= m; i++)
+ { glp_set_row_bnds(mip, i, tree->root_type[i],
+ tree->root_lb[i], tree->root_ub[i]);
+ glp_set_row_stat(mip, i, tree->root_stat[i]);
+ }
+ for (j = 1; j <= n; j++)
+ { glp_set_col_bnds(mip, j, tree->root_type[m+j],
+ tree->root_lb[m+j], tree->root_ub[m+j]);
+ glp_set_col_stat(mip, j, tree->root_stat[m+j]);
+ }
+#if 1
+ /* remove all edges and cliques missing in the conflict graph
+ for the root subproblem */
+ /* (not implemented yet) */
+#endif
+ }
+ /* the current subproblem has been frozen */
+ tree->curr = NULL;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_clone_node - clone specified subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_clone_node(glp_tree *tree, int p, int nnn, int ref[]);
+*
+* DESCRIPTION
+*
+* The routine ios_clone_node clones the specified subproblem, whose
+* reference number is p, creating its nnn exact copies. Note that the
+* specified subproblem must be active and must be in the frozen state
+* (i.e. it must not be the current subproblem).
+*
+* Each clone, an exact copy of the specified subproblem, becomes a new
+* active subproblem added to the end of the active list. After cloning
+* the specified subproblem becomes inactive.
+*
+* The reference numbers of clone subproblems are stored to locations
+* ref[1], ..., ref[nnn]. */
+
+static int get_slot(glp_tree *tree)
+{ int p;
+ /* if no free slots are available, increase the room */
+ if (tree->avail == 0)
+ { int nslots = tree->nslots;
+ IOSLOT *save = tree->slot;
+ if (nslots == 0)
+ tree->nslots = 20;
+ else
+ { tree->nslots = nslots + nslots;
+ xassert(tree->nslots > nslots);
+ }
+ tree->slot = xcalloc(1+tree->nslots, sizeof(IOSLOT));
+ if (save != NULL)
+ { memcpy(&tree->slot[1], &save[1], nslots * sizeof(IOSLOT));
+ xfree(save);
+ }
+ /* push more free slots into the stack */
+ for (p = tree->nslots; p > nslots; p--)
+ { tree->slot[p].node = NULL;
+ tree->slot[p].next = tree->avail;
+ tree->avail = p;
+ }
+ }
+ /* pull a free slot from the stack */
+ p = tree->avail;
+ tree->avail = tree->slot[p].next;
+ xassert(tree->slot[p].node == NULL);
+ tree->slot[p].next = 0;
+ return p;
+}
+
+static IOSNPD *new_node(glp_tree *tree, IOSNPD *parent)
+{ IOSNPD *node;
+ int p;
+ /* pull a free slot for the new node */
+ p = get_slot(tree);
+ /* create descriptor of the new subproblem */
+ node = dmp_get_atom(tree->pool, sizeof(IOSNPD));
+ tree->slot[p].node = node;
+ node->p = p;
+ node->up = parent;
+ node->level = (parent == NULL ? 0 : parent->level + 1);
+ node->count = 0;
+ node->b_ptr = NULL;
+ node->s_ptr = NULL;
+ node->r_ptr = NULL;
+ node->solved = 0;
+#if 0
+ node->own_nn = node->own_nc = 0;
+ node->e_ptr = NULL;
+#endif
+#if 1 /* 04/X-2008 */
+ node->lp_obj = (parent == NULL ? (tree->mip->dir == GLP_MIN ?
+ -DBL_MAX : +DBL_MAX) : parent->lp_obj);
+#endif
+ node->bound = (parent == NULL ? (tree->mip->dir == GLP_MIN ?
+ -DBL_MAX : +DBL_MAX) : parent->bound);
+ node->br_var = 0;
+ node->br_val = 0.0;
+ node->ii_cnt = 0;
+ node->ii_sum = 0.0;
+#if 1 /* 30/XI-2009 */
+ node->changed = 0;
+#endif
+ if (tree->parm->cb_size == 0)
+ node->data = NULL;
+ else
+ { node->data = dmp_get_atom(tree->pool, tree->parm->cb_size);
+ memset(node->data, 0, tree->parm->cb_size);
+ }
+ node->temp = NULL;
+ node->prev = tree->tail;
+ node->next = NULL;
+ /* add the new subproblem to the end of the active list */
+ if (tree->head == NULL)
+ tree->head = node;
+ else
+ tree->tail->next = node;
+ tree->tail = node;
+ tree->a_cnt++;
+ tree->n_cnt++;
+ tree->t_cnt++;
+ /* increase the number of child subproblems */
+ if (parent == NULL)
+ xassert(p == 1);
+ else
+ parent->count++;
+ return node;
+}
+
+void ios_clone_node(glp_tree *tree, int p, int nnn, int ref[])
+{ IOSNPD *node;
+ int k;
+ /* obtain pointer to the subproblem to be cloned */
+ xassert(1 <= p && p <= tree->nslots);
+ node = tree->slot[p].node;
+ xassert(node != NULL);
+ /* the specified subproblem must be active */
+ xassert(node->count == 0);
+ /* and must be in the frozen state */
+ xassert(tree->curr != node);
+ /* remove the specified subproblem from the active list, because
+ it becomes inactive */
+ if (node->prev == NULL)
+ tree->head = node->next;
+ else
+ node->prev->next = node->next;
+ if (node->next == NULL)
+ tree->tail = node->prev;
+ else
+ node->next->prev = node->prev;
+ node->prev = node->next = NULL;
+ tree->a_cnt--;
+ /* create clone subproblems */
+ xassert(nnn > 0);
+ for (k = 1; k <= nnn; k++)
+ ref[k] = new_node(tree, node)->p;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_delete_node - delete specified subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_delete_node(glp_tree *tree, int p);
+*
+* DESCRIPTION
+*
+* The routine ios_delete_node deletes the specified subproblem, whose
+* reference number is p. The subproblem must be active and must be in
+* the frozen state (i.e. it must not be the current subproblem).
+*
+* Note that deletion is performed recursively, i.e. if a subproblem to
+* be deleted is the only child of its parent, the parent subproblem is
+* also deleted, etc. */
+
+void ios_delete_node(glp_tree *tree, int p)
+{ IOSNPD *node, *temp;
+ /* obtain pointer to the subproblem to be deleted */
+ xassert(1 <= p && p <= tree->nslots);
+ node = tree->slot[p].node;
+ xassert(node != NULL);
+ /* the specified subproblem must be active */
+ xassert(node->count == 0);
+ /* and must be in the frozen state */
+ xassert(tree->curr != node);
+ /* remove the specified subproblem from the active list, because
+ it is gone from the tree */
+ if (node->prev == NULL)
+ tree->head = node->next;
+ else
+ node->prev->next = node->next;
+ if (node->next == NULL)
+ tree->tail = node->prev;
+ else
+ node->next->prev = node->prev;
+ node->prev = node->next = NULL;
+ tree->a_cnt--;
+loop: /* recursive deletion starts here */
+ /* delete the bound change list */
+ { IOSBND *b;
+ while (node->b_ptr != NULL)
+ { b = node->b_ptr;
+ node->b_ptr = b->next;
+ dmp_free_atom(tree->pool, b, sizeof(IOSBND));
+ }
+ }
+ /* delete the status change list */
+ { IOSTAT *s;
+ while (node->s_ptr != NULL)
+ { s = node->s_ptr;
+ node->s_ptr = s->next;
+ dmp_free_atom(tree->pool, s, sizeof(IOSTAT));
+ }
+ }
+ /* delete the row addition list */
+ while (node->r_ptr != NULL)
+ { IOSROW *r;
+ r = node->r_ptr;
+ if (r->name != NULL)
+ dmp_free_atom(tree->pool, r->name, strlen(r->name)+1);
+ while (r->ptr != NULL)
+ { IOSAIJ *a;
+ a = r->ptr;
+ r->ptr = a->next;
+ dmp_free_atom(tree->pool, a, sizeof(IOSAIJ));
+ }
+ node->r_ptr = r->next;
+ dmp_free_atom(tree->pool, r, sizeof(IOSROW));
+ }
+#if 0
+ /* delete the edge addition list */
+ /* delete the clique addition list */
+ /* (not implemented yet) */
+ xassert(node->own_nn == 0);
+ xassert(node->own_nc == 0);
+ xassert(node->e_ptr == NULL);
+#endif
+ /* free application-specific data */
+ if (tree->parm->cb_size == 0)
+ xassert(node->data == NULL);
+ else
+ dmp_free_atom(tree->pool, node->data, tree->parm->cb_size);
+ /* free the corresponding node slot */
+ p = node->p;
+ xassert(tree->slot[p].node == node);
+ tree->slot[p].node = NULL;
+ tree->slot[p].next = tree->avail;
+ tree->avail = p;
+ /* save pointer to the parent subproblem */
+ temp = node->up;
+ /* delete the subproblem descriptor */
+ dmp_free_atom(tree->pool, node, sizeof(IOSNPD));
+ tree->n_cnt--;
+ /* take pointer to the parent subproblem */
+ node = temp;
+ if (node != NULL)
+ { /* the parent subproblem exists; decrease the number of its
+ child subproblems */
+ xassert(node->count > 0);
+ node->count--;
+ /* if now the parent subproblem has no childs, it also must be
+ deleted */
+ if (node->count == 0) goto loop;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_delete_tree - delete branch-and-bound tree
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_delete_tree(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_delete_tree deletes the branch-and-bound tree, which
+* the parameter tree points to, and frees all the memory allocated to
+* this program object.
+*
+* On exit components of the problem object are restored to correspond
+* to the original MIP passed to the routine ios_create_tree. */
+
+void ios_delete_tree(glp_tree *tree)
+{ glp_prob *mip = tree->mip;
+ int i, j;
+ int m = mip->m;
+ int n = mip->n;
+ xassert(mip->tree == tree);
+ /* remove all additional rows */
+ if (m != tree->orig_m)
+ { int nrs, *num;
+ nrs = m - tree->orig_m;
+ xassert(nrs > 0);
+ num = xcalloc(1+nrs, sizeof(int));
+ for (i = 1; i <= nrs; i++) num[i] = tree->orig_m + i;
+ glp_del_rows(mip, nrs, num);
+ xfree(num);
+ }
+ m = tree->orig_m;
+ /* restore original attributes of rows and columns */
+ xassert(m == tree->orig_m);
+ xassert(n == tree->n);
+ for (i = 1; i <= m; i++)
+ { glp_set_row_bnds(mip, i, tree->orig_type[i],
+ tree->orig_lb[i], tree->orig_ub[i]);
+ glp_set_row_stat(mip, i, tree->orig_stat[i]);
+ mip->row[i]->prim = tree->orig_prim[i];
+ mip->row[i]->dual = tree->orig_dual[i];
+ }
+ for (j = 1; j <= n; j++)
+ { glp_set_col_bnds(mip, j, tree->orig_type[m+j],
+ tree->orig_lb[m+j], tree->orig_ub[m+j]);
+ glp_set_col_stat(mip, j, tree->orig_stat[m+j]);
+ mip->col[j]->prim = tree->orig_prim[m+j];
+ mip->col[j]->dual = tree->orig_dual[m+j];
+ }
+ mip->pbs_stat = mip->dbs_stat = GLP_FEAS;
+ mip->obj_val = tree->orig_obj;
+ /* delete the branch-and-bound tree */
+ xassert(tree->local != NULL);
+ ios_delete_pool(tree, tree->local);
+ dmp_delete_pool(tree->pool);
+ xfree(tree->orig_type);
+ xfree(tree->orig_lb);
+ xfree(tree->orig_ub);
+ xfree(tree->orig_stat);
+ xfree(tree->orig_prim);
+ xfree(tree->orig_dual);
+ xfree(tree->slot);
+ if (tree->root_type != NULL) xfree(tree->root_type);
+ if (tree->root_lb != NULL) xfree(tree->root_lb);
+ if (tree->root_ub != NULL) xfree(tree->root_ub);
+ if (tree->root_stat != NULL) xfree(tree->root_stat);
+ xfree(tree->non_int);
+#if 0
+ xfree(tree->n_ref);
+ xfree(tree->c_ref);
+ xfree(tree->j_ref);
+#endif
+ if (tree->pcost != NULL) ios_pcost_free(tree);
+ xfree(tree->iwrk);
+ xfree(tree->dwrk);
+#if 0
+ scg_delete_graph(tree->g);
+#endif
+ if (tree->pred_type != NULL) xfree(tree->pred_type);
+ if (tree->pred_lb != NULL) xfree(tree->pred_lb);
+ if (tree->pred_ub != NULL) xfree(tree->pred_ub);
+ if (tree->pred_stat != NULL) xfree(tree->pred_stat);
+#if 0
+ xassert(tree->cut_gen == NULL);
+#endif
+ xassert(tree->mir_gen == NULL);
+ xassert(tree->clq_gen == NULL);
+ xfree(tree);
+ mip->tree = NULL;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_eval_degrad - estimate obj. degrad. for down- and up-branches
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_eval_degrad(glp_tree *tree, int j, double *dn, double *up);
+*
+* DESCRIPTION
+*
+* Given optimal basis to LP relaxation of the current subproblem the
+* routine ios_eval_degrad performs the dual ratio test to compute the
+* objective values in the adjacent basis for down- and up-branches,
+* which are stored in locations *dn and *up, assuming that x[j] is a
+* variable chosen to branch upon. */
+
+void ios_eval_degrad(glp_tree *tree, int j, double *dn, double *up)
+{ glp_prob *mip = tree->mip;
+ int m = mip->m, n = mip->n;
+ int len, kase, k, t, stat;
+ double alfa, beta, gamma, delta, dz;
+ int *ind = tree->iwrk;
+ double *val = tree->dwrk;
+ /* current basis must be optimal */
+ xassert(glp_get_status(mip) == GLP_OPT);
+ /* basis factorization must exist */
+ xassert(glp_bf_exists(mip));
+ /* obtain (fractional) value of x[j] in optimal basic solution
+ to LP relaxation of the current subproblem */
+ xassert(1 <= j && j <= n);
+ beta = mip->col[j]->prim;
+ /* since the value of x[j] is fractional, it is basic; compute
+ corresponding row of the simplex table */
+ len = lpx_eval_tab_row(mip, m+j, ind, val);
+ /* kase < 0 means down-branch; kase > 0 means up-branch */
+ for (kase = -1; kase <= +1; kase += 2)
+ { /* for down-branch we introduce new upper bound floor(beta)
+ for x[j]; similarly, for up-branch we introduce new lower
+ bound ceil(beta) for x[j]; in the current basis this new
+ upper/lower bound is violated, so in the adjacent basis
+ x[j] will leave the basis and go to its new upper/lower
+ bound; we need to know which non-basic variable x[k] should
+ enter the basis to keep dual feasibility */
+#if 0 /* 23/XI-2009 */
+ k = lpx_dual_ratio_test(mip, len, ind, val, kase, 1e-7);
+#else
+ k = lpx_dual_ratio_test(mip, len, ind, val, kase, 1e-9);
+#endif
+ /* if no variable has been chosen, current basis being primal
+ infeasible due to the new upper/lower bound of x[j] is dual
+ unbounded, therefore, LP relaxation to corresponding branch
+ has no primal feasible solution */
+ if (k == 0)
+ { if (mip->dir == GLP_MIN)
+ { if (kase < 0)
+ *dn = +DBL_MAX;
+ else
+ *up = +DBL_MAX;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (kase < 0)
+ *dn = -DBL_MAX;
+ else
+ *up = -DBL_MAX;
+ }
+ else
+ xassert(mip != mip);
+ continue;
+ }
+ xassert(1 <= k && k <= m+n);
+ /* row of the simplex table corresponding to specified basic
+ variable x[j] is the following:
+ x[j] = ... + alfa * x[k] + ... ;
+ we need to know influence coefficient, alfa, at non-basic
+ variable x[k] chosen with the dual ratio test */
+ for (t = 1; t <= len; t++)
+ if (ind[t] == k) break;
+ xassert(1 <= t && t <= len);
+ alfa = val[t];
+ /* determine status and reduced cost of variable x[k] */
+ if (k <= m)
+ { stat = mip->row[k]->stat;
+ gamma = mip->row[k]->dual;
+ }
+ else
+ { stat = mip->col[k-m]->stat;
+ gamma = mip->col[k-m]->dual;
+ }
+ /* x[k] cannot be basic or fixed non-basic */
+ xassert(stat == GLP_NL || stat == GLP_NU || stat == GLP_NF);
+ /* if the current basis is dual degenerative, some reduced
+ costs, which are close to zero, may have wrong sign due to
+ round-off errors, so correct the sign of gamma */
+ if (mip->dir == GLP_MIN)
+ { if (stat == GLP_NL && gamma < 0.0 ||
+ stat == GLP_NU && gamma > 0.0 ||
+ stat == GLP_NF) gamma = 0.0;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (stat == GLP_NL && gamma > 0.0 ||
+ stat == GLP_NU && gamma < 0.0 ||
+ stat == GLP_NF) gamma = 0.0;
+ }
+ else
+ xassert(mip != mip);
+ /* determine the change of x[j] in the adjacent basis:
+ delta x[j] = new x[j] - old x[j] */
+ delta = (kase < 0 ? floor(beta) : ceil(beta)) - beta;
+ /* compute the change of x[k] in the adjacent basis:
+ delta x[k] = new x[k] - old x[k] = delta x[j] / alfa */
+ delta /= alfa;
+ /* compute the change of the objective in the adjacent basis:
+ delta z = new z - old z = gamma * delta x[k] */
+ dz = gamma * delta;
+ if (mip->dir == GLP_MIN)
+ xassert(dz >= 0.0);
+ else if (mip->dir == GLP_MAX)
+ xassert(dz <= 0.0);
+ else
+ xassert(mip != mip);
+ /* compute the new objective value in the adjacent basis:
+ new z = old z + delta z */
+ if (kase < 0)
+ *dn = mip->obj_val + dz;
+ else
+ *up = mip->obj_val + dz;
+ }
+ /*xprintf("obj = %g; dn = %g; up = %g\n",
+ mip->obj_val, *dn, *up);*/
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_round_bound - improve local bound by rounding
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* double ios_round_bound(glp_tree *tree, double bound);
+*
+* RETURNS
+*
+* For the given local bound for any integer feasible solution to the
+* current subproblem the routine ios_round_bound returns an improved
+* local bound for the same integer feasible solution.
+*
+* BACKGROUND
+*
+* Let the current subproblem has the following objective function:
+*
+* z = sum c[j] * x[j] + s >= b, (1)
+* j in J
+*
+* where J = {j: c[j] is non-zero and integer, x[j] is integer}, s is
+* the sum of terms corresponding to fixed variables, b is an initial
+* local bound (minimization).
+*
+* From (1) it follows that:
+*
+* d * sum (c[j] / d) * x[j] + s >= b, (2)
+* j in J
+*
+* or, equivalently,
+*
+* sum (c[j] / d) * x[j] >= (b - s) / d = h, (3)
+* j in J
+*
+* where d = gcd(c[j]). Since the left-hand side of (3) is integer,
+* h = (b - s) / d can be rounded up to the nearest integer:
+*
+* h' = ceil(h) = (b' - s) / d, (4)
+*
+* that gives an rounded, improved local bound:
+*
+* b' = d * h' + s. (5)
+*
+* In case of maximization '>=' in (1) should be replaced by '<=' that
+* leads to the following formula:
+*
+* h' = floor(h) = (b' - s) / d, (6)
+*
+* which should used in the same way as (4).
+*
+* NOTE: If b is a valid local bound for a child of the current
+* subproblem, b' is also valid for that child subproblem. */
+
+double ios_round_bound(glp_tree *tree, double bound)
+{ glp_prob *mip = tree->mip;
+ int n = mip->n;
+ int d, j, nn, *c = tree->iwrk;
+ double s, h;
+ /* determine c[j] and compute s */
+ nn = 0, s = mip->c0, d = 0;
+ for (j = 1; j <= n; j++)
+ { GLPCOL *col = mip->col[j];
+ if (col->coef == 0.0) continue;
+ if (col->type == GLP_FX)
+ { /* fixed variable */
+ s += col->coef * col->prim;
+ }
+ else
+ { /* non-fixed variable */
+ if (col->kind != GLP_IV) goto skip;
+ if (col->coef != floor(col->coef)) goto skip;
+ if (fabs(col->coef) <= (double)INT_MAX)
+ c[++nn] = (int)fabs(col->coef);
+ else
+ d = 1;
+ }
+ }
+ /* compute d = gcd(c[1],...c[nn]) */
+ if (d == 0)
+ { if (nn == 0) goto skip;
+ d = gcdn(nn, c);
+ }
+ xassert(d > 0);
+ /* compute new local bound */
+ if (mip->dir == GLP_MIN)
+ { if (bound != +DBL_MAX)
+ { h = (bound - s) / (double)d;
+ if (h >= floor(h) + 0.001)
+ { /* round up */
+ h = ceil(h);
+ /*xprintf("d = %d; old = %g; ", d, bound);*/
+ bound = (double)d * h + s;
+ /*xprintf("new = %g\n", bound);*/
+ }
+ }
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (bound != -DBL_MAX)
+ { h = (bound - s) / (double)d;
+ if (h <= ceil(h) - 0.001)
+ { /* round down */
+ h = floor(h);
+ bound = (double)d * h + s;
+ }
+ }
+ }
+ else
+ xassert(mip != mip);
+skip: return bound;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_is_hopeful - check if subproblem is hopeful
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_is_hopeful(glp_tree *tree, double bound);
+*
+* DESCRIPTION
+*
+* Given the local bound of a subproblem the routine ios_is_hopeful
+* checks if the subproblem can have an integer optimal solution which
+* is better than the best one currently known.
+*
+* RETURNS
+*
+* If the subproblem can have a better integer optimal solution, the
+* routine returns non-zero; otherwise, if the corresponding branch can
+* be pruned, the routine returns zero. */
+
+int ios_is_hopeful(glp_tree *tree, double bound)
+{ glp_prob *mip = tree->mip;
+ int ret = 1;
+ double eps;
+ if (mip->mip_stat == GLP_FEAS)
+ { eps = tree->parm->tol_obj * (1.0 + fabs(mip->mip_obj));
+ switch (mip->dir)
+ { case GLP_MIN:
+ if (bound >= mip->mip_obj - eps) ret = 0;
+ break;
+ case GLP_MAX:
+ if (bound <= mip->mip_obj + eps) ret = 0;
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ }
+ else
+ { switch (mip->dir)
+ { case GLP_MIN:
+ if (bound == +DBL_MAX) ret = 0;
+ break;
+ case GLP_MAX:
+ if (bound == -DBL_MAX) ret = 0;
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ }
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_best_node - find active node with best local bound
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_best_node(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_best_node finds an active node whose local bound is
+* best among other active nodes.
+*
+* It is understood that the integer optimal solution of the original
+* mip problem cannot be better than the best bound, so the best bound
+* is an lower (minimization) or upper (maximization) global bound for
+* the original problem.
+*
+* RETURNS
+*
+* The routine ios_best_node returns the subproblem reference number
+* for the best node. However, if the tree is empty, it returns zero. */
+
+int ios_best_node(glp_tree *tree)
+{ IOSNPD *node, *best = NULL;
+ switch (tree->mip->dir)
+ { case GLP_MIN:
+ /* minimization */
+ for (node = tree->head; node != NULL; node = node->next)
+ if (best == NULL || best->bound > node->bound)
+ best = node;
+ break;
+ case GLP_MAX:
+ /* maximization */
+ for (node = tree->head; node != NULL; node = node->next)
+ if (best == NULL || best->bound < node->bound)
+ best = node;
+ break;
+ default:
+ xassert(tree != tree);
+ }
+ return best == NULL ? 0 : best->p;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_relative_gap - compute relative mip gap
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* double ios_relative_gap(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_relative_gap computes the relative mip gap using the
+* formula:
+*
+* gap = |best_mip - best_bnd| / (|best_mip| + DBL_EPSILON),
+*
+* where best_mip is the best integer feasible solution found so far,
+* best_bnd is the best (global) bound. If no integer feasible solution
+* has been found yet, rel_gap is set to DBL_MAX.
+*
+* RETURNS
+*
+* The routine ios_relative_gap returns the relative mip gap. */
+
+double ios_relative_gap(glp_tree *tree)
+{ glp_prob *mip = tree->mip;
+ int p;
+ double best_mip, best_bnd, gap;
+ if (mip->mip_stat == GLP_FEAS)
+ { best_mip = mip->mip_obj;
+ p = ios_best_node(tree);
+ if (p == 0)
+ { /* the tree is empty */
+ gap = 0.0;
+ }
+ else
+ { best_bnd = tree->slot[p].node->bound;
+ gap = fabs(best_mip - best_bnd) / (fabs(best_mip) +
+ DBL_EPSILON);
+ }
+ }
+ else
+ { /* no integer feasible solution has been found yet */
+ gap = DBL_MAX;
+ }
+ return gap;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_solve_node - solve LP relaxation of current subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_solve_node(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_solve_node re-optimizes LP relaxation of the current
+* subproblem using the dual simplex method.
+*
+* RETURNS
+*
+* The routine returns the code which is reported by glp_simplex. */
+
+int ios_solve_node(glp_tree *tree)
+{ glp_prob *mip = tree->mip;
+ glp_smcp parm;
+ int ret;
+ /* the current subproblem must exist */
+ xassert(tree->curr != NULL);
+ /* set some control parameters */
+ glp_init_smcp(&parm);
+ switch (tree->parm->msg_lev)
+ { case GLP_MSG_OFF:
+ parm.msg_lev = GLP_MSG_OFF; break;
+ case GLP_MSG_ERR:
+ parm.msg_lev = GLP_MSG_ERR; break;
+ case GLP_MSG_ON:
+ case GLP_MSG_ALL:
+ parm.msg_lev = GLP_MSG_ON; break;
+ case GLP_MSG_DBG:
+ parm.msg_lev = GLP_MSG_ALL; break;
+ default:
+ xassert(tree != tree);
+ }
+ parm.meth = GLP_DUALP;
+#if 1 /* 16/III-2016 */
+ if (tree->parm->flip)
+ parm.r_test = GLP_RT_FLIP;
+#endif
+ /* respect time limit */
+ if (tree->parm->tm_lim < INT_MAX)
+ parm.tm_lim = tree->parm->tm_lim - (glp_time() - tree->tm_beg);
+ if (parm.tm_lim < 0)
+ parm.tm_lim = 0;
+ if (tree->parm->msg_lev < GLP_MSG_DBG)
+ parm.out_dly = tree->parm->out_dly;
+ else
+ parm.out_dly = 0;
+ /* if the incumbent objective value is already known, use it to
+ prematurely terminate the dual simplex search */
+ if (mip->mip_stat == GLP_FEAS)
+ { switch (tree->mip->dir)
+ { case GLP_MIN:
+ parm.obj_ul = mip->mip_obj;
+ break;
+ case GLP_MAX:
+ parm.obj_ll = mip->mip_obj;
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ }
+ /* try to solve/re-optimize the LP relaxation */
+ ret = glp_simplex(mip, &parm);
+#if 1 /* 21/II-2016 by Chris */
+ if (ret == GLP_EFAIL)
+ { /* retry with a new basis */
+ glp_adv_basis(mip, 0);
+ ret = glp_simplex(mip, &parm);
+ }
+#endif
+ tree->curr->solved++;
+#if 0
+ xprintf("ret = %d; status = %d; pbs = %d; dbs = %d; some = %d\n",
+ ret, glp_get_status(mip), mip->pbs_stat, mip->dbs_stat,
+ mip->some);
+ lpx_print_sol(mip, "sol");
+#endif
+ return ret;
+}
+
+/**********************************************************************/
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+IOSPOOL *ios_create_pool(glp_tree *tree)
+{ /* create cut pool */
+ IOSPOOL *pool;
+ pool = glp_create_prob();
+ glp_add_cols(pool, tree->mip->n);
+ return pool;
+}
+#else
+IOSPOOL *ios_create_pool(glp_tree *tree)
+{ /* create cut pool */
+ IOSPOOL *pool;
+#if 0
+ pool = dmp_get_atom(tree->pool, sizeof(IOSPOOL));
+#else
+ xassert(tree == tree);
+ pool = xmalloc(sizeof(IOSPOOL));
+#endif
+ pool->size = 0;
+ pool->head = pool->tail = NULL;
+ pool->ord = 0, pool->curr = NULL;
+ return pool;
+}
+#endif
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+int ios_add_row(glp_tree *tree, IOSPOOL *pool,
+ const char *name, int klass, int flags, int len, const int ind[],
+ const double val[], int type, double rhs)
+{ /* add row (constraint) to the cut pool */
+ int i;
+ i = glp_add_rows(pool, 1);
+ glp_set_row_name(pool, i, name);
+ pool->row[i]->klass = klass;
+ xassert(flags == 0);
+ glp_set_mat_row(pool, i, len, ind, val);
+ glp_set_row_bnds(pool, i, type, rhs, rhs);
+ return i;
+}
+#else
+int ios_add_row(glp_tree *tree, IOSPOOL *pool,
+ const char *name, int klass, int flags, int len, const int ind[],
+ const double val[], int type, double rhs)
+{ /* add row (constraint) to the cut pool */
+ IOSCUT *cut;
+ IOSAIJ *aij;
+ int k;
+ xassert(pool != NULL);
+ cut = dmp_get_atom(tree->pool, sizeof(IOSCUT));
+ if (name == NULL || name[0] == '\0')
+ cut->name = NULL;
+ else
+ { for (k = 0; name[k] != '\0'; k++)
+ { if (k == 256)
+ xerror("glp_ios_add_row: cut name too long\n");
+ if (iscntrl((unsigned char)name[k]))
+ xerror("glp_ios_add_row: cut name contains invalid chara"
+ "cter(s)\n");
+ }
+ cut->name = dmp_get_atom(tree->pool, strlen(name)+1);
+ strcpy(cut->name, name);
+ }
+ if (!(0 <= klass && klass <= 255))
+ xerror("glp_ios_add_row: klass = %d; invalid cut class\n",
+ klass);
+ cut->klass = (unsigned char)klass;
+ if (flags != 0)
+ xerror("glp_ios_add_row: flags = %d; invalid cut flags\n",
+ flags);
+ cut->ptr = NULL;
+ if (!(0 <= len && len <= tree->n))
+ xerror("glp_ios_add_row: len = %d; invalid cut length\n",
+ len);
+ for (k = 1; k <= len; k++)
+ { aij = dmp_get_atom(tree->pool, sizeof(IOSAIJ));
+ if (!(1 <= ind[k] && ind[k] <= tree->n))
+ xerror("glp_ios_add_row: ind[%d] = %d; column index out of "
+ "range\n", k, ind[k]);
+ aij->j = ind[k];
+ aij->val = val[k];
+ aij->next = cut->ptr;
+ cut->ptr = aij;
+ }
+ if (!(type == GLP_LO || type == GLP_UP || type == GLP_FX))
+ xerror("glp_ios_add_row: type = %d; invalid cut type\n",
+ type);
+ cut->type = (unsigned char)type;
+ cut->rhs = rhs;
+ cut->prev = pool->tail;
+ cut->next = NULL;
+ if (cut->prev == NULL)
+ pool->head = cut;
+ else
+ cut->prev->next = cut;
+ pool->tail = cut;
+ pool->size++;
+ return pool->size;
+}
+#endif
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+IOSCUT *ios_find_row(IOSPOOL *pool, int i)
+{ /* find row (constraint) in the cut pool */
+ xassert(0);
+}
+#else
+IOSCUT *ios_find_row(IOSPOOL *pool, int i)
+{ /* find row (constraint) in the cut pool */
+ /* (smart linear search) */
+ xassert(pool != NULL);
+ xassert(1 <= i && i <= pool->size);
+ if (pool->ord == 0)
+ { xassert(pool->curr == NULL);
+ pool->ord = 1;
+ pool->curr = pool->head;
+ }
+ xassert(pool->curr != NULL);
+ if (i < pool->ord)
+ { if (i < pool->ord - i)
+ { pool->ord = 1;
+ pool->curr = pool->head;
+ while (pool->ord != i)
+ { pool->ord++;
+ xassert(pool->curr != NULL);
+ pool->curr = pool->curr->next;
+ }
+ }
+ else
+ { while (pool->ord != i)
+ { pool->ord--;
+ xassert(pool->curr != NULL);
+ pool->curr = pool->curr->prev;
+ }
+ }
+ }
+ else if (i > pool->ord)
+ { if (i - pool->ord < pool->size - i)
+ { while (pool->ord != i)
+ { pool->ord++;
+ xassert(pool->curr != NULL);
+ pool->curr = pool->curr->next;
+ }
+ }
+ else
+ { pool->ord = pool->size;
+ pool->curr = pool->tail;
+ while (pool->ord != i)
+ { pool->ord--;
+ xassert(pool->curr != NULL);
+ pool->curr = pool->curr->prev;
+ }
+ }
+ }
+ xassert(pool->ord == i);
+ xassert(pool->curr != NULL);
+ return pool->curr;
+}
+#endif
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+void ios_del_row(glp_tree *tree, IOSPOOL *pool, int i)
+{ /* remove row (constraint) from the cut pool */
+ xassert(0);
+}
+#else
+void ios_del_row(glp_tree *tree, IOSPOOL *pool, int i)
+{ /* remove row (constraint) from the cut pool */
+ IOSCUT *cut;
+ IOSAIJ *aij;
+ xassert(pool != NULL);
+ if (!(1 <= i && i <= pool->size))
+ xerror("glp_ios_del_row: i = %d; cut number out of range\n",
+ i);
+ cut = ios_find_row(pool, i);
+ xassert(pool->curr == cut);
+ if (cut->next != NULL)
+ pool->curr = cut->next;
+ else if (cut->prev != NULL)
+ pool->ord--, pool->curr = cut->prev;
+ else
+ pool->ord = 0, pool->curr = NULL;
+ if (cut->name != NULL)
+ dmp_free_atom(tree->pool, cut->name, strlen(cut->name)+1);
+ if (cut->prev == NULL)
+ { xassert(pool->head == cut);
+ pool->head = cut->next;
+ }
+ else
+ { xassert(cut->prev->next == cut);
+ cut->prev->next = cut->next;
+ }
+ if (cut->next == NULL)
+ { xassert(pool->tail == cut);
+ pool->tail = cut->prev;
+ }
+ else
+ { xassert(cut->next->prev == cut);
+ cut->next->prev = cut->prev;
+ }
+ while (cut->ptr != NULL)
+ { aij = cut->ptr;
+ cut->ptr = aij->next;
+ dmp_free_atom(tree->pool, aij, sizeof(IOSAIJ));
+ }
+ dmp_free_atom(tree->pool, cut, sizeof(IOSCUT));
+ pool->size--;
+ return;
+}
+#endif
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+void ios_clear_pool(glp_tree *tree, IOSPOOL *pool)
+{ /* remove all rows (constraints) from the cut pool */
+ if (pool->m > 0)
+ { int i, *num;
+ num = talloc(1+pool->m, int);
+ for (i = 1; i <= pool->m; i++)
+ num[i] = i;
+ glp_del_rows(pool, pool->m, num);
+ tfree(num);
+ }
+ return;
+}
+#else
+void ios_clear_pool(glp_tree *tree, IOSPOOL *pool)
+{ /* remove all rows (constraints) from the cut pool */
+ xassert(pool != NULL);
+ while (pool->head != NULL)
+ { IOSCUT *cut = pool->head;
+ pool->head = cut->next;
+ if (cut->name != NULL)
+ dmp_free_atom(tree->pool, cut->name, strlen(cut->name)+1);
+ while (cut->ptr != NULL)
+ { IOSAIJ *aij = cut->ptr;
+ cut->ptr = aij->next;
+ dmp_free_atom(tree->pool, aij, sizeof(IOSAIJ));
+ }
+ dmp_free_atom(tree->pool, cut, sizeof(IOSCUT));
+ }
+ pool->size = 0;
+ pool->head = pool->tail = NULL;
+ pool->ord = 0, pool->curr = NULL;
+ return;
+}
+#endif
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+void ios_delete_pool(glp_tree *tree, IOSPOOL *pool)
+{ /* delete cut pool */
+ xassert(pool != NULL);
+ glp_delete_prob(pool);
+ return;
+}
+#else
+void ios_delete_pool(glp_tree *tree, IOSPOOL *pool)
+{ /* delete cut pool */
+ xassert(pool != NULL);
+ ios_clear_pool(tree, pool);
+ xfree(pool);
+ return;
+}
+#endif
+
+#if 1 /* 11/VII-2013 */
+#include "npp.h"
+
+void ios_process_sol(glp_tree *T)
+{ /* process integer feasible solution just found */
+ if (T->npp != NULL)
+ { /* postprocess solution from transformed mip */
+ npp_postprocess(T->npp, T->mip);
+ /* store solution to problem passed to glp_intopt */
+ npp_unload_sol(T->npp, T->P);
+ }
+ xassert(T->P != NULL);
+ /* save solution to text file, if requested */
+ if (T->save_sol != NULL)
+ { char *fn, *mark;
+ fn = talloc(strlen(T->save_sol) + 50, char);
+ mark = strrchr(T->save_sol, '*');
+ if (mark == NULL)
+ strcpy(fn, T->save_sol);
+ else
+ { memcpy(fn, T->save_sol, mark - T->save_sol);
+ fn[mark - T->save_sol] = '\0';
+ sprintf(fn + strlen(fn), "%03d", ++(T->save_cnt));
+ strcat(fn, &mark[1]);
+ }
+ glp_write_mip(T->P, fn);
+ tfree(fn);
+ }
+ return;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios02.c b/test/monniaux/glpk-4.65/src/draft/glpios02.c
new file mode 100644
index 00000000..a73458aa
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios02.c
@@ -0,0 +1,826 @@
+/* glpios02.c (preprocess current subproblem) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* prepare_row_info - prepare row info to determine implied bounds
+*
+* Given a row (linear form)
+*
+* n
+* sum a[j] * x[j] (1)
+* j=1
+*
+* and bounds of columns (variables)
+*
+* l[j] <= x[j] <= u[j] (2)
+*
+* this routine computes f_min, j_min, f_max, j_max needed to determine
+* implied bounds.
+*
+* ALGORITHM
+*
+* Let J+ = {j : a[j] > 0} and J- = {j : a[j] < 0}.
+*
+* Parameters f_min and j_min are computed as follows:
+*
+* 1) if there is no x[k] such that k in J+ and l[k] = -inf or k in J-
+* and u[k] = +inf, then
+*
+* f_min := sum a[j] * l[j] + sum a[j] * u[j]
+* j in J+ j in J-
+* (3)
+* j_min := 0
+*
+* 2) if there is exactly one x[k] such that k in J+ and l[k] = -inf
+* or k in J- and u[k] = +inf, then
+*
+* f_min := sum a[j] * l[j] + sum a[j] * u[j]
+* j in J+\{k} j in J-\{k}
+* (4)
+* j_min := k
+*
+* 3) if there are two or more x[k] such that k in J+ and l[k] = -inf
+* or k in J- and u[k] = +inf, then
+*
+* f_min := -inf
+* (5)
+* j_min := 0
+*
+* Parameters f_max and j_max are computed in a similar way as follows:
+*
+* 1) if there is no x[k] such that k in J+ and u[k] = +inf or k in J-
+* and l[k] = -inf, then
+*
+* f_max := sum a[j] * u[j] + sum a[j] * l[j]
+* j in J+ j in J-
+* (6)
+* j_max := 0
+*
+* 2) if there is exactly one x[k] such that k in J+ and u[k] = +inf
+* or k in J- and l[k] = -inf, then
+*
+* f_max := sum a[j] * u[j] + sum a[j] * l[j]
+* j in J+\{k} j in J-\{k}
+* (7)
+* j_max := k
+*
+* 3) if there are two or more x[k] such that k in J+ and u[k] = +inf
+* or k in J- and l[k] = -inf, then
+*
+* f_max := +inf
+* (8)
+* j_max := 0 */
+
+struct f_info
+{ int j_min, j_max;
+ double f_min, f_max;
+};
+
+static void prepare_row_info(int n, const double a[], const double l[],
+ const double u[], struct f_info *f)
+{ int j, j_min, j_max;
+ double f_min, f_max;
+ xassert(n >= 0);
+ /* determine f_min and j_min */
+ f_min = 0.0, j_min = 0;
+ for (j = 1; j <= n; j++)
+ { if (a[j] > 0.0)
+ { if (l[j] == -DBL_MAX)
+ { if (j_min == 0)
+ j_min = j;
+ else
+ { f_min = -DBL_MAX, j_min = 0;
+ break;
+ }
+ }
+ else
+ f_min += a[j] * l[j];
+ }
+ else if (a[j] < 0.0)
+ { if (u[j] == +DBL_MAX)
+ { if (j_min == 0)
+ j_min = j;
+ else
+ { f_min = -DBL_MAX, j_min = 0;
+ break;
+ }
+ }
+ else
+ f_min += a[j] * u[j];
+ }
+ else
+ xassert(a != a);
+ }
+ f->f_min = f_min, f->j_min = j_min;
+ /* determine f_max and j_max */
+ f_max = 0.0, j_max = 0;
+ for (j = 1; j <= n; j++)
+ { if (a[j] > 0.0)
+ { if (u[j] == +DBL_MAX)
+ { if (j_max == 0)
+ j_max = j;
+ else
+ { f_max = +DBL_MAX, j_max = 0;
+ break;
+ }
+ }
+ else
+ f_max += a[j] * u[j];
+ }
+ else if (a[j] < 0.0)
+ { if (l[j] == -DBL_MAX)
+ { if (j_max == 0)
+ j_max = j;
+ else
+ { f_max = +DBL_MAX, j_max = 0;
+ break;
+ }
+ }
+ else
+ f_max += a[j] * l[j];
+ }
+ else
+ xassert(a != a);
+ }
+ f->f_max = f_max, f->j_max = j_max;
+ return;
+}
+
+/***********************************************************************
+* row_implied_bounds - determine row implied bounds
+*
+* Given a row (linear form)
+*
+* n
+* sum a[j] * x[j]
+* j=1
+*
+* and bounds of columns (variables)
+*
+* l[j] <= x[j] <= u[j]
+*
+* this routine determines implied bounds of the row.
+*
+* ALGORITHM
+*
+* Let J+ = {j : a[j] > 0} and J- = {j : a[j] < 0}.
+*
+* The implied lower bound of the row is computed as follows:
+*
+* L' := sum a[j] * l[j] + sum a[j] * u[j] (9)
+* j in J+ j in J-
+*
+* and as it follows from (3), (4), and (5):
+*
+* L' := if j_min = 0 then f_min else -inf (10)
+*
+* The implied upper bound of the row is computed as follows:
+*
+* U' := sum a[j] * u[j] + sum a[j] * l[j] (11)
+* j in J+ j in J-
+*
+* and as it follows from (6), (7), and (8):
+*
+* U' := if j_max = 0 then f_max else +inf (12)
+*
+* The implied bounds are stored in locations LL and UU. */
+
+static void row_implied_bounds(const struct f_info *f, double *LL,
+ double *UU)
+{ *LL = (f->j_min == 0 ? f->f_min : -DBL_MAX);
+ *UU = (f->j_max == 0 ? f->f_max : +DBL_MAX);
+ return;
+}
+
+/***********************************************************************
+* col_implied_bounds - determine column implied bounds
+*
+* Given a row (constraint)
+*
+* n
+* L <= sum a[j] * x[j] <= U (13)
+* j=1
+*
+* and bounds of columns (variables)
+*
+* l[j] <= x[j] <= u[j]
+*
+* this routine determines implied bounds of variable x[k].
+*
+* It is assumed that if L != -inf, the lower bound of the row can be
+* active, and if U != +inf, the upper bound of the row can be active.
+*
+* ALGORITHM
+*
+* From (13) it follows that
+*
+* L <= sum a[j] * x[j] + a[k] * x[k] <= U
+* j!=k
+* or
+*
+* L - sum a[j] * x[j] <= a[k] * x[k] <= U - sum a[j] * x[j]
+* j!=k j!=k
+*
+* Thus, if the row lower bound L can be active, implied lower bound of
+* term a[k] * x[k] can be determined as follows:
+*
+* ilb(a[k] * x[k]) = min(L - sum a[j] * x[j]) =
+* j!=k
+* (14)
+* = L - max sum a[j] * x[j]
+* j!=k
+*
+* where, as it follows from (6), (7), and (8)
+*
+* / f_max - a[k] * u[k], j_max = 0, a[k] > 0
+* |
+* | f_max - a[k] * l[k], j_max = 0, a[k] < 0
+* max sum a[j] * x[j] = {
+* j!=k | f_max, j_max = k
+* |
+* \ +inf, j_max != 0
+*
+* and if the upper bound U can be active, implied upper bound of term
+* a[k] * x[k] can be determined as follows:
+*
+* iub(a[k] * x[k]) = max(U - sum a[j] * x[j]) =
+* j!=k
+* (15)
+* = U - min sum a[j] * x[j]
+* j!=k
+*
+* where, as it follows from (3), (4), and (5)
+*
+* / f_min - a[k] * l[k], j_min = 0, a[k] > 0
+* |
+* | f_min - a[k] * u[k], j_min = 0, a[k] < 0
+* min sum a[j] * x[j] = {
+* j!=k | f_min, j_min = k
+* |
+* \ -inf, j_min != 0
+*
+* Since
+*
+* ilb(a[k] * x[k]) <= a[k] * x[k] <= iub(a[k] * x[k])
+*
+* implied lower and upper bounds of x[k] are determined as follows:
+*
+* l'[k] := if a[k] > 0 then ilb / a[k] else ulb / a[k] (16)
+*
+* u'[k] := if a[k] > 0 then ulb / a[k] else ilb / a[k] (17)
+*
+* The implied bounds are stored in locations ll and uu. */
+
+static void col_implied_bounds(const struct f_info *f, int n,
+ const double a[], double L, double U, const double l[],
+ const double u[], int k, double *ll, double *uu)
+{ double ilb, iub;
+ xassert(n >= 0);
+ xassert(1 <= k && k <= n);
+ /* determine implied lower bound of term a[k] * x[k] (14) */
+ if (L == -DBL_MAX || f->f_max == +DBL_MAX)
+ ilb = -DBL_MAX;
+ else if (f->j_max == 0)
+ { if (a[k] > 0.0)
+ { xassert(u[k] != +DBL_MAX);
+ ilb = L - (f->f_max - a[k] * u[k]);
+ }
+ else if (a[k] < 0.0)
+ { xassert(l[k] != -DBL_MAX);
+ ilb = L - (f->f_max - a[k] * l[k]);
+ }
+ else
+ xassert(a != a);
+ }
+ else if (f->j_max == k)
+ ilb = L - f->f_max;
+ else
+ ilb = -DBL_MAX;
+ /* determine implied upper bound of term a[k] * x[k] (15) */
+ if (U == +DBL_MAX || f->f_min == -DBL_MAX)
+ iub = +DBL_MAX;
+ else if (f->j_min == 0)
+ { if (a[k] > 0.0)
+ { xassert(l[k] != -DBL_MAX);
+ iub = U - (f->f_min - a[k] * l[k]);
+ }
+ else if (a[k] < 0.0)
+ { xassert(u[k] != +DBL_MAX);
+ iub = U - (f->f_min - a[k] * u[k]);
+ }
+ else
+ xassert(a != a);
+ }
+ else if (f->j_min == k)
+ iub = U - f->f_min;
+ else
+ iub = +DBL_MAX;
+ /* determine implied bounds of x[k] (16) and (17) */
+#if 1
+ /* do not use a[k] if it has small magnitude to prevent wrong
+ implied bounds; for example, 1e-15 * x1 >= x2 + x3, where
+ x1 >= -10, x2, x3 >= 0, would lead to wrong conclusion that
+ x1 >= 0 */
+ if (fabs(a[k]) < 1e-6)
+ *ll = -DBL_MAX, *uu = +DBL_MAX; else
+#endif
+ if (a[k] > 0.0)
+ { *ll = (ilb == -DBL_MAX ? -DBL_MAX : ilb / a[k]);
+ *uu = (iub == +DBL_MAX ? +DBL_MAX : iub / a[k]);
+ }
+ else if (a[k] < 0.0)
+ { *ll = (iub == +DBL_MAX ? -DBL_MAX : iub / a[k]);
+ *uu = (ilb == -DBL_MAX ? +DBL_MAX : ilb / a[k]);
+ }
+ else
+ xassert(a != a);
+ return;
+}
+
+/***********************************************************************
+* check_row_bounds - check and relax original row bounds
+*
+* Given a row (constraint)
+*
+* n
+* L <= sum a[j] * x[j] <= U
+* j=1
+*
+* and bounds of columns (variables)
+*
+* l[j] <= x[j] <= u[j]
+*
+* this routine checks the original row bounds L and U for feasibility
+* and redundancy. If the original lower bound L or/and upper bound U
+* cannot be active due to bounds of variables, the routine remove them
+* replacing by -inf or/and +inf, respectively.
+*
+* If no primal infeasibility is detected, the routine returns zero,
+* otherwise non-zero. */
+
+static int check_row_bounds(const struct f_info *f, double *L_,
+ double *U_)
+{ int ret = 0;
+ double L = *L_, U = *U_, LL, UU;
+ /* determine implied bounds of the row */
+ row_implied_bounds(f, &LL, &UU);
+ /* check if the original lower bound is infeasible */
+ if (L != -DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(L));
+ if (UU < L - eps)
+ { ret = 1;
+ goto done;
+ }
+ }
+ /* check if the original upper bound is infeasible */
+ if (U != +DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(U));
+ if (LL > U + eps)
+ { ret = 1;
+ goto done;
+ }
+ }
+ /* check if the original lower bound is redundant */
+ if (L != -DBL_MAX)
+ { double eps = 1e-12 * (1.0 + fabs(L));
+ if (LL > L - eps)
+ { /* it cannot be active, so remove it */
+ *L_ = -DBL_MAX;
+ }
+ }
+ /* check if the original upper bound is redundant */
+ if (U != +DBL_MAX)
+ { double eps = 1e-12 * (1.0 + fabs(U));
+ if (UU < U + eps)
+ { /* it cannot be active, so remove it */
+ *U_ = +DBL_MAX;
+ }
+ }
+done: return ret;
+}
+
+/***********************************************************************
+* check_col_bounds - check and tighten original column bounds
+*
+* Given a row (constraint)
+*
+* n
+* L <= sum a[j] * x[j] <= U
+* j=1
+*
+* and bounds of columns (variables)
+*
+* l[j] <= x[j] <= u[j]
+*
+* for column (variable) x[j] this routine checks the original column
+* bounds l[j] and u[j] for feasibility and redundancy. If the original
+* lower bound l[j] or/and upper bound u[j] cannot be active due to
+* bounds of the constraint and other variables, the routine tighten
+* them replacing by corresponding implied bounds, if possible.
+*
+* NOTE: It is assumed that if L != -inf, the row lower bound can be
+* active, and if U != +inf, the row upper bound can be active.
+*
+* The flag means that variable x[j] is required to be integer.
+*
+* New actual bounds for x[j] are stored in locations lj and uj.
+*
+* If no primal infeasibility is detected, the routine returns zero,
+* otherwise non-zero. */
+
+static int check_col_bounds(const struct f_info *f, int n,
+ const double a[], double L, double U, const double l[],
+ const double u[], int flag, int j, double *_lj, double *_uj)
+{ int ret = 0;
+ double lj, uj, ll, uu;
+ xassert(n >= 0);
+ xassert(1 <= j && j <= n);
+ lj = l[j], uj = u[j];
+ /* determine implied bounds of the column */
+ col_implied_bounds(f, n, a, L, U, l, u, j, &ll, &uu);
+ /* if x[j] is integral, round its implied bounds */
+ if (flag)
+ { if (ll != -DBL_MAX)
+ ll = (ll - floor(ll) < 1e-3 ? floor(ll) : ceil(ll));
+ if (uu != +DBL_MAX)
+ uu = (ceil(uu) - uu < 1e-3 ? ceil(uu) : floor(uu));
+ }
+ /* check if the original lower bound is infeasible */
+ if (lj != -DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(lj));
+ if (uu < lj - eps)
+ { ret = 1;
+ goto done;
+ }
+ }
+ /* check if the original upper bound is infeasible */
+ if (uj != +DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(uj));
+ if (ll > uj + eps)
+ { ret = 1;
+ goto done;
+ }
+ }
+ /* check if the original lower bound is redundant */
+ if (ll != -DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(ll));
+ if (lj < ll - eps)
+ { /* it cannot be active, so tighten it */
+ lj = ll;
+ }
+ }
+ /* check if the original upper bound is redundant */
+ if (uu != +DBL_MAX)
+ { double eps = 1e-3 * (1.0 + fabs(uu));
+ if (uj > uu + eps)
+ { /* it cannot be active, so tighten it */
+ uj = uu;
+ }
+ }
+ /* due to round-off errors it may happen that lj > uj (although
+ lj < uj + eps, since no primal infeasibility is detected), so
+ adjuct the new actual bounds to provide lj <= uj */
+ if (!(lj == -DBL_MAX || uj == +DBL_MAX))
+ { double t1 = fabs(lj), t2 = fabs(uj);
+ double eps = 1e-10 * (1.0 + (t1 <= t2 ? t1 : t2));
+ if (lj > uj - eps)
+ { if (lj == l[j])
+ uj = lj;
+ else if (uj == u[j])
+ lj = uj;
+ else if (t1 <= t2)
+ uj = lj;
+ else
+ lj = uj;
+ }
+ }
+ *_lj = lj, *_uj = uj;
+done: return ret;
+}
+
+/***********************************************************************
+* check_efficiency - check if change in column bounds is efficient
+*
+* Given the original bounds of a column l and u and its new actual
+* bounds l' and u' (possibly tighten by the routine check_col_bounds)
+* this routine checks if the change in the column bounds is efficient
+* enough. If so, the routine returns non-zero, otherwise zero.
+*
+* The flag means that the variable is required to be integer. */
+
+static int check_efficiency(int flag, double l, double u, double ll,
+ double uu)
+{ int eff = 0;
+ /* check efficiency for lower bound */
+ if (l < ll)
+ { if (flag || l == -DBL_MAX)
+ eff++;
+ else
+ { double r;
+ if (u == +DBL_MAX)
+ r = 1.0 + fabs(l);
+ else
+ r = 1.0 + (u - l);
+ if (ll - l >= 0.25 * r)
+ eff++;
+ }
+ }
+ /* check efficiency for upper bound */
+ if (u > uu)
+ { if (flag || u == +DBL_MAX)
+ eff++;
+ else
+ { double r;
+ if (l == -DBL_MAX)
+ r = 1.0 + fabs(u);
+ else
+ r = 1.0 + (u - l);
+ if (u - uu >= 0.25 * r)
+ eff++;
+ }
+ }
+ return eff;
+}
+
+/***********************************************************************
+* basic_preprocessing - perform basic preprocessing
+*
+* This routine performs basic preprocessing of the specified MIP that
+* includes relaxing some row bounds and tightening some column bounds.
+*
+* On entry the arrays L and U contains original row bounds, and the
+* arrays l and u contains original column bounds:
+*
+* L[0] is the lower bound of the objective row;
+* L[i], i = 1,...,m, is the lower bound of i-th row;
+* U[0] is the upper bound of the objective row;
+* U[i], i = 1,...,m, is the upper bound of i-th row;
+* l[0] is not used;
+* l[j], j = 1,...,n, is the lower bound of j-th column;
+* u[0] is not used;
+* u[j], j = 1,...,n, is the upper bound of j-th column.
+*
+* On exit the arrays L, U, l, and u contain new actual bounds of rows
+* and column in the same locations.
+*
+* The parameters nrs and num specify an initial list of rows to be
+* processed:
+*
+* nrs is the number of rows in the initial list, 0 <= nrs <= m+1;
+* num[0] is not used;
+* num[1,...,nrs] are row numbers (0 means the objective row).
+*
+* The parameter max_pass specifies the maximal number of times that
+* each row can be processed, max_pass > 0.
+*
+* If no primal infeasibility is detected, the routine returns zero,
+* otherwise non-zero. */
+
+static int basic_preprocessing(glp_prob *mip, double L[], double U[],
+ double l[], double u[], int nrs, const int num[], int max_pass)
+{ int m = mip->m;
+ int n = mip->n;
+ struct f_info f;
+ int i, j, k, len, size, ret = 0;
+ int *ind, *list, *mark, *pass;
+ double *val, *lb, *ub;
+ xassert(0 <= nrs && nrs <= m+1);
+ xassert(max_pass > 0);
+ /* allocate working arrays */
+ ind = xcalloc(1+n, sizeof(int));
+ list = xcalloc(1+m+1, sizeof(int));
+ mark = xcalloc(1+m+1, sizeof(int));
+ memset(&mark[0], 0, (m+1) * sizeof(int));
+ pass = xcalloc(1+m+1, sizeof(int));
+ memset(&pass[0], 0, (m+1) * sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ lb = xcalloc(1+n, sizeof(double));
+ ub = xcalloc(1+n, sizeof(double));
+ /* initialize the list of rows to be processed */
+ size = 0;
+ for (k = 1; k <= nrs; k++)
+ { i = num[k];
+ xassert(0 <= i && i <= m);
+ /* duplicate row numbers are not allowed */
+ xassert(!mark[i]);
+ list[++size] = i, mark[i] = 1;
+ }
+ xassert(size == nrs);
+ /* process rows in the list until it becomes empty */
+ while (size > 0)
+ { /* get a next row from the list */
+ i = list[size--], mark[i] = 0;
+ /* increase the row processing count */
+ pass[i]++;
+ /* if the row is free, skip it */
+ if (L[i] == -DBL_MAX && U[i] == +DBL_MAX) continue;
+ /* obtain coefficients of the row */
+ len = 0;
+ if (i == 0)
+ { for (j = 1; j <= n; j++)
+ { GLPCOL *col = mip->col[j];
+ if (col->coef != 0.0)
+ len++, ind[len] = j, val[len] = col->coef;
+ }
+ }
+ else
+ { GLPROW *row = mip->row[i];
+ GLPAIJ *aij;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ len++, ind[len] = aij->col->j, val[len] = aij->val;
+ }
+ /* determine lower and upper bounds of columns corresponding
+ to non-zero row coefficients */
+ for (k = 1; k <= len; k++)
+ j = ind[k], lb[k] = l[j], ub[k] = u[j];
+ /* prepare the row info to determine implied bounds */
+ prepare_row_info(len, val, lb, ub, &f);
+ /* check and relax bounds of the row */
+ if (check_row_bounds(&f, &L[i], &U[i]))
+ { /* the feasible region is empty */
+ ret = 1;
+ goto done;
+ }
+ /* if the row became free, drop it */
+ if (L[i] == -DBL_MAX && U[i] == +DBL_MAX) continue;
+ /* process columns having non-zero coefficients in the row */
+ for (k = 1; k <= len; k++)
+ { GLPCOL *col;
+ int flag, eff;
+ double ll, uu;
+ /* take a next column in the row */
+ j = ind[k], col = mip->col[j];
+ flag = col->kind != GLP_CV;
+ /* check and tighten bounds of the column */
+ if (check_col_bounds(&f, len, val, L[i], U[i], lb, ub,
+ flag, k, &ll, &uu))
+ { /* the feasible region is empty */
+ ret = 1;
+ goto done;
+ }
+ /* check if change in the column bounds is efficient */
+ eff = check_efficiency(flag, l[j], u[j], ll, uu);
+ /* set new actual bounds of the column */
+ l[j] = ll, u[j] = uu;
+ /* if the change is efficient, add all rows affected by the
+ corresponding column, to the list */
+ if (eff > 0)
+ { GLPAIJ *aij;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ { int ii = aij->row->i;
+ /* if the row was processed maximal number of times,
+ skip it */
+ if (pass[ii] >= max_pass) continue;
+ /* if the row is free, skip it */
+ if (L[ii] == -DBL_MAX && U[ii] == +DBL_MAX) continue;
+ /* put the row into the list */
+ if (mark[ii] == 0)
+ { xassert(size <= m);
+ list[++size] = ii, mark[ii] = 1;
+ }
+ }
+ }
+ }
+ }
+done: /* free working arrays */
+ xfree(ind);
+ xfree(list);
+ xfree(mark);
+ xfree(pass);
+ xfree(val);
+ xfree(lb);
+ xfree(ub);
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_preprocess_node - preprocess current subproblem
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_preprocess_node(glp_tree *tree, int max_pass);
+*
+* DESCRIPTION
+*
+* The routine ios_preprocess_node performs basic preprocessing of the
+* current subproblem.
+*
+* RETURNS
+*
+* If no primal infeasibility is detected, the routine returns zero,
+* otherwise non-zero. */
+
+int ios_preprocess_node(glp_tree *tree, int max_pass)
+{ glp_prob *mip = tree->mip;
+ int m = mip->m;
+ int n = mip->n;
+ int i, j, nrs, *num, ret = 0;
+ double *L, *U, *l, *u;
+ /* the current subproblem must exist */
+ xassert(tree->curr != NULL);
+ /* determine original row bounds */
+ L = xcalloc(1+m, sizeof(double));
+ U = xcalloc(1+m, sizeof(double));
+ switch (mip->mip_stat)
+ { case GLP_UNDEF:
+ L[0] = -DBL_MAX, U[0] = +DBL_MAX;
+ break;
+ case GLP_FEAS:
+ switch (mip->dir)
+ { case GLP_MIN:
+ L[0] = -DBL_MAX, U[0] = mip->mip_obj - mip->c0;
+ break;
+ case GLP_MAX:
+ L[0] = mip->mip_obj - mip->c0, U[0] = +DBL_MAX;
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ break;
+ default:
+ xassert(mip != mip);
+ }
+ for (i = 1; i <= m; i++)
+ { L[i] = glp_get_row_lb(mip, i);
+ U[i] = glp_get_row_ub(mip, i);
+ }
+ /* determine original column bounds */
+ l = xcalloc(1+n, sizeof(double));
+ u = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++)
+ { l[j] = glp_get_col_lb(mip, j);
+ u[j] = glp_get_col_ub(mip, j);
+ }
+ /* build the initial list of rows to be analyzed */
+ nrs = m + 1;
+ num = xcalloc(1+nrs, sizeof(int));
+ for (i = 1; i <= nrs; i++) num[i] = i - 1;
+ /* perform basic preprocessing */
+ if (basic_preprocessing(mip , L, U, l, u, nrs, num, max_pass))
+ { ret = 1;
+ goto done;
+ }
+ /* set new actual (relaxed) row bounds */
+ for (i = 1; i <= m; i++)
+ { /* consider only non-active rows to keep dual feasibility */
+ if (glp_get_row_stat(mip, i) == GLP_BS)
+ { if (L[i] == -DBL_MAX && U[i] == +DBL_MAX)
+ glp_set_row_bnds(mip, i, GLP_FR, 0.0, 0.0);
+ else if (U[i] == +DBL_MAX)
+ glp_set_row_bnds(mip, i, GLP_LO, L[i], 0.0);
+ else if (L[i] == -DBL_MAX)
+ glp_set_row_bnds(mip, i, GLP_UP, 0.0, U[i]);
+ }
+ }
+ /* set new actual (tightened) column bounds */
+ for (j = 1; j <= n; j++)
+ { int type;
+ if (l[j] == -DBL_MAX && u[j] == +DBL_MAX)
+ type = GLP_FR;
+ else if (u[j] == +DBL_MAX)
+ type = GLP_LO;
+ else if (l[j] == -DBL_MAX)
+ type = GLP_UP;
+ else if (l[j] != u[j])
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_col_bnds(mip, j, type, l[j], u[j]);
+ }
+done: /* free working arrays and return */
+ xfree(L);
+ xfree(U);
+ xfree(l);
+ xfree(u);
+ xfree(num);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios03.c b/test/monniaux/glpk-4.65/src/draft/glpios03.c
new file mode 100644
index 00000000..21d6a000
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios03.c
@@ -0,0 +1,1512 @@
+/* glpios03.c (branch-and-cut driver) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* show_progress - display current progress of the search
+*
+* This routine displays some information about current progress of the
+* search.
+*
+* The information includes:
+*
+* the current number of iterations performed by the simplex solver;
+*
+* the objective value for the best known integer feasible solution,
+* which is upper (minimization) or lower (maximization) global bound
+* for optimal solution of the original mip problem;
+*
+* the best local bound for active nodes, which is lower (minimization)
+* or upper (maximization) global bound for optimal solution of the
+* original mip problem;
+*
+* the relative mip gap, in percents;
+*
+* the number of open (active) subproblems;
+*
+* the number of completely explored subproblems, i.e. whose nodes have
+* been removed from the tree. */
+
+static void show_progress(glp_tree *T, int bingo)
+{ int p;
+ double temp;
+ char best_mip[50], best_bound[50], *rho, rel_gap[50];
+ /* format the best known integer feasible solution */
+ if (T->mip->mip_stat == GLP_FEAS)
+ sprintf(best_mip, "%17.9e", T->mip->mip_obj);
+ else
+ sprintf(best_mip, "%17s", "not found yet");
+ /* determine reference number of an active subproblem whose local
+ bound is best */
+ p = ios_best_node(T);
+ /* format the best bound */
+ if (p == 0)
+ sprintf(best_bound, "%17s", "tree is empty");
+ else
+ { temp = T->slot[p].node->bound;
+ if (temp == -DBL_MAX)
+ sprintf(best_bound, "%17s", "-inf");
+ else if (temp == +DBL_MAX)
+ sprintf(best_bound, "%17s", "+inf");
+ else
+ { if (fabs(temp) < 1e-9)
+ temp = 0;
+ sprintf(best_bound, "%17.9e", temp);
+ }
+ }
+ /* choose the relation sign between global bounds */
+ if (T->mip->dir == GLP_MIN)
+ rho = ">=";
+ else if (T->mip->dir == GLP_MAX)
+ rho = "<=";
+ else
+ xassert(T != T);
+ /* format the relative mip gap */
+ temp = ios_relative_gap(T);
+ if (temp == 0.0)
+ sprintf(rel_gap, " 0.0%%");
+ else if (temp < 0.001)
+ sprintf(rel_gap, "< 0.1%%");
+ else if (temp <= 9.999)
+ sprintf(rel_gap, "%5.1f%%", 100.0 * temp);
+ else
+ sprintf(rel_gap, "%6s", "");
+ /* display progress of the search */
+ xprintf("+%6d: %s %s %s %s %s (%d; %d)\n",
+ T->mip->it_cnt, bingo ? ">>>>>" : "mip =", best_mip, rho,
+ best_bound, rel_gap, T->a_cnt, T->t_cnt - T->n_cnt);
+ T->tm_lag = xtime();
+ return;
+}
+
+/***********************************************************************
+* is_branch_hopeful - check if specified branch is hopeful
+*
+* This routine checks if the specified subproblem can have an integer
+* optimal solution which is better than the best known one.
+*
+* The check is based on comparison of the local objective bound stored
+* in the subproblem descriptor and the incumbent objective value which
+* is the global objective bound.
+*
+* If there is a chance that the specified subproblem can have a better
+* integer optimal solution, the routine returns non-zero. Otherwise, if
+* the corresponding branch can pruned, zero is returned. */
+
+static int is_branch_hopeful(glp_tree *T, int p)
+{ xassert(1 <= p && p <= T->nslots);
+ xassert(T->slot[p].node != NULL);
+ return ios_is_hopeful(T, T->slot[p].node->bound);
+}
+
+/***********************************************************************
+* check_integrality - check integrality of basic solution
+*
+* This routine checks if the basic solution of LP relaxation of the
+* current subproblem satisfies to integrality conditions, i.e. that all
+* variables of integer kind have integral primal values. (The solution
+* is assumed to be optimal.)
+*
+* For each variable of integer kind the routine computes the following
+* quantity:
+*
+* ii(x[j]) = min(x[j] - floor(x[j]), ceil(x[j]) - x[j]), (1)
+*
+* which is a measure of the integer infeasibility (non-integrality) of
+* x[j] (for example, ii(2.1) = 0.1, ii(3.7) = 0.3, ii(5.0) = 0). It is
+* understood that 0 <= ii(x[j]) <= 0.5, and variable x[j] is integer
+* feasible if ii(x[j]) = 0. However, due to floating-point arithmetic
+* the routine checks less restrictive condition:
+*
+* ii(x[j]) <= tol_int, (2)
+*
+* where tol_int is a given tolerance (small positive number) and marks
+* each variable which does not satisfy to (2) as integer infeasible by
+* setting its fractionality flag.
+*
+* In order to characterize integer infeasibility of the basic solution
+* in the whole the routine computes two parameters: ii_cnt, which is
+* the number of variables with the fractionality flag set, and ii_sum,
+* which is the sum of integer infeasibilities (1). */
+
+static void check_integrality(glp_tree *T)
+{ glp_prob *mip = T->mip;
+ int j, type, ii_cnt = 0;
+ double lb, ub, x, temp1, temp2, ii_sum = 0.0;
+ /* walk through the set of columns (structural variables) */
+ for (j = 1; j <= mip->n; j++)
+ { GLPCOL *col = mip->col[j];
+ T->non_int[j] = 0;
+ /* if the column is not integer, skip it */
+ if (col->kind != GLP_IV) continue;
+ /* if the column is non-basic, it is integer feasible */
+ if (col->stat != GLP_BS) continue;
+ /* obtain the type and bounds of the column */
+ type = col->type, lb = col->lb, ub = col->ub;
+ /* obtain value of the column in optimal basic solution */
+ x = col->prim;
+ /* if the column's primal value is close to the lower bound,
+ the column is integer feasible within given tolerance */
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { temp1 = lb - T->parm->tol_int;
+ temp2 = lb + T->parm->tol_int;
+ if (temp1 <= x && x <= temp2) continue;
+#if 0
+ /* the lower bound must not be violated */
+ xassert(x >= lb);
+#else
+ if (x < lb) continue;
+#endif
+ }
+ /* if the column's primal value is close to the upper bound,
+ the column is integer feasible within given tolerance */
+ if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ { temp1 = ub - T->parm->tol_int;
+ temp2 = ub + T->parm->tol_int;
+ if (temp1 <= x && x <= temp2) continue;
+#if 0
+ /* the upper bound must not be violated */
+ xassert(x <= ub);
+#else
+ if (x > ub) continue;
+#endif
+ }
+ /* if the column's primal value is close to nearest integer,
+ the column is integer feasible within given tolerance */
+ temp1 = floor(x + 0.5) - T->parm->tol_int;
+ temp2 = floor(x + 0.5) + T->parm->tol_int;
+ if (temp1 <= x && x <= temp2) continue;
+ /* otherwise the column is integer infeasible */
+ T->non_int[j] = 1;
+ /* increase the number of fractional-valued columns */
+ ii_cnt++;
+ /* compute the sum of integer infeasibilities */
+ temp1 = x - floor(x);
+ temp2 = ceil(x) - x;
+ xassert(temp1 > 0.0 && temp2 > 0.0);
+ ii_sum += (temp1 <= temp2 ? temp1 : temp2);
+ }
+ /* store ii_cnt and ii_sum to the current problem descriptor */
+ xassert(T->curr != NULL);
+ T->curr->ii_cnt = ii_cnt;
+ T->curr->ii_sum = ii_sum;
+ /* and also display these parameters */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ { if (ii_cnt == 0)
+ xprintf("There are no fractional columns\n");
+ else if (ii_cnt == 1)
+ xprintf("There is one fractional column, integer infeasibil"
+ "ity is %.3e\n", ii_sum);
+ else
+ xprintf("There are %d fractional columns, integer infeasibi"
+ "lity is %.3e\n", ii_cnt, ii_sum);
+ }
+ return;
+}
+
+/***********************************************************************
+* record_solution - record better integer feasible solution
+*
+* This routine records optimal basic solution of LP relaxation of the
+* current subproblem, which being integer feasible is better than the
+* best known integer feasible solution. */
+
+static void record_solution(glp_tree *T)
+{ glp_prob *mip = T->mip;
+ int i, j;
+ mip->mip_stat = GLP_FEAS;
+ mip->mip_obj = mip->obj_val;
+ for (i = 1; i <= mip->m; i++)
+ { GLPROW *row = mip->row[i];
+ row->mipx = row->prim;
+ }
+ for (j = 1; j <= mip->n; j++)
+ { GLPCOL *col = mip->col[j];
+ if (col->kind == GLP_CV)
+ col->mipx = col->prim;
+ else if (col->kind == GLP_IV)
+ { /* value of the integer column must be integral */
+ col->mipx = floor(col->prim + 0.5);
+ }
+ else
+ xassert(col != col);
+ }
+ T->sol_cnt++;
+ return;
+}
+
+/***********************************************************************
+* fix_by_red_cost - fix non-basic integer columns by reduced costs
+*
+* This routine fixes some non-basic integer columns if their reduced
+* costs indicate that increasing (decreasing) the column at least by
+* one involves the objective value becoming worse than the incumbent
+* objective value. */
+
+static void fix_by_red_cost(glp_tree *T)
+{ glp_prob *mip = T->mip;
+ int j, stat, fixed = 0;
+ double obj, lb, ub, dj;
+ /* the global bound must exist */
+ xassert(T->mip->mip_stat == GLP_FEAS);
+ /* basic solution of LP relaxation must be optimal */
+ xassert(mip->pbs_stat == GLP_FEAS && mip->dbs_stat == GLP_FEAS);
+ /* determine the objective function value */
+ obj = mip->obj_val;
+ /* walk through the column list */
+ for (j = 1; j <= mip->n; j++)
+ { GLPCOL *col = mip->col[j];
+ /* if the column is not integer, skip it */
+ if (col->kind != GLP_IV) continue;
+ /* obtain bounds of j-th column */
+ lb = col->lb, ub = col->ub;
+ /* and determine its status and reduced cost */
+ stat = col->stat, dj = col->dual;
+ /* analyze the reduced cost */
+ switch (mip->dir)
+ { case GLP_MIN:
+ /* minimization */
+ if (stat == GLP_NL)
+ { /* j-th column is non-basic on its lower bound */
+ if (dj < 0.0) dj = 0.0;
+ if (obj + dj >= mip->mip_obj)
+ glp_set_col_bnds(mip, j, GLP_FX, lb, lb), fixed++;
+ }
+ else if (stat == GLP_NU)
+ { /* j-th column is non-basic on its upper bound */
+ if (dj > 0.0) dj = 0.0;
+ if (obj - dj >= mip->mip_obj)
+ glp_set_col_bnds(mip, j, GLP_FX, ub, ub), fixed++;
+ }
+ break;
+ case GLP_MAX:
+ /* maximization */
+ if (stat == GLP_NL)
+ { /* j-th column is non-basic on its lower bound */
+ if (dj > 0.0) dj = 0.0;
+ if (obj + dj <= mip->mip_obj)
+ glp_set_col_bnds(mip, j, GLP_FX, lb, lb), fixed++;
+ }
+ else if (stat == GLP_NU)
+ { /* j-th column is non-basic on its upper bound */
+ if (dj < 0.0) dj = 0.0;
+ if (obj - dj <= mip->mip_obj)
+ glp_set_col_bnds(mip, j, GLP_FX, ub, ub), fixed++;
+ }
+ break;
+ default:
+ xassert(T != T);
+ }
+ }
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ { if (fixed == 0)
+ /* nothing to say */;
+ else if (fixed == 1)
+ xprintf("One column has been fixed by reduced cost\n");
+ else
+ xprintf("%d columns have been fixed by reduced costs\n",
+ fixed);
+ }
+ /* fixing non-basic columns on their current bounds does not
+ change the basic solution */
+ xassert(mip->pbs_stat == GLP_FEAS && mip->dbs_stat == GLP_FEAS);
+ return;
+}
+
+/***********************************************************************
+* branch_on - perform branching on specified variable
+*
+* This routine performs branching on j-th column (structural variable)
+* of the current subproblem. The specified column must be of integer
+* kind and must have a fractional value in optimal basic solution of
+* LP relaxation of the current subproblem (i.e. only columns for which
+* the flag non_int[j] is set are valid candidates to branch on).
+*
+* Let x be j-th structural variable, and beta be its primal fractional
+* value in the current basic solution. Branching on j-th variable is
+* dividing the current subproblem into two new subproblems, which are
+* identical to the current subproblem with the following exception: in
+* the first subproblem that begins the down-branch x has a new upper
+* bound x <= floor(beta), and in the second subproblem that begins the
+* up-branch x has a new lower bound x >= ceil(beta).
+*
+* Depending on estimation of local bounds for down- and up-branches
+* this routine returns the following:
+*
+* 0 - both branches have been created;
+* 1 - one branch is hopeless and has been pruned, so now the current
+* subproblem is other branch;
+* 2 - both branches are hopeless and have been pruned; new subproblem
+* selection is needed to continue the search. */
+
+static int branch_on(glp_tree *T, int j, int next)
+{ glp_prob *mip = T->mip;
+ IOSNPD *node;
+ int m = mip->m;
+ int n = mip->n;
+ int type, dn_type, up_type, dn_bad, up_bad, p, ret, clone[1+2];
+ double lb, ub, beta, new_ub, new_lb, dn_lp, up_lp, dn_bnd, up_bnd;
+ /* determine bounds and value of x[j] in optimal solution to LP
+ relaxation of the current subproblem */
+ xassert(1 <= j && j <= n);
+ type = mip->col[j]->type;
+ lb = mip->col[j]->lb;
+ ub = mip->col[j]->ub;
+ beta = mip->col[j]->prim;
+ /* determine new bounds of x[j] for down- and up-branches */
+ new_ub = floor(beta);
+ new_lb = ceil(beta);
+ switch (type)
+ { case GLP_FR:
+ dn_type = GLP_UP;
+ up_type = GLP_LO;
+ break;
+ case GLP_LO:
+ xassert(lb <= new_ub);
+ dn_type = (lb == new_ub ? GLP_FX : GLP_DB);
+ xassert(lb + 1.0 <= new_lb);
+ up_type = GLP_LO;
+ break;
+ case GLP_UP:
+ xassert(new_ub <= ub - 1.0);
+ dn_type = GLP_UP;
+ xassert(new_lb <= ub);
+ up_type = (new_lb == ub ? GLP_FX : GLP_DB);
+ break;
+ case GLP_DB:
+ xassert(lb <= new_ub && new_ub <= ub - 1.0);
+ dn_type = (lb == new_ub ? GLP_FX : GLP_DB);
+ xassert(lb + 1.0 <= new_lb && new_lb <= ub);
+ up_type = (new_lb == ub ? GLP_FX : GLP_DB);
+ break;
+ default:
+ xassert(type != type);
+ }
+ /* compute local bounds to LP relaxation for both branches */
+ ios_eval_degrad(T, j, &dn_lp, &up_lp);
+ /* and improve them by rounding */
+ dn_bnd = ios_round_bound(T, dn_lp);
+ up_bnd = ios_round_bound(T, up_lp);
+ /* check local bounds for down- and up-branches */
+ dn_bad = !ios_is_hopeful(T, dn_bnd);
+ up_bad = !ios_is_hopeful(T, up_bnd);
+ if (dn_bad && up_bad)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Both down- and up-branches are hopeless\n");
+ ret = 2;
+ goto done;
+ }
+ else if (up_bad)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Up-branch is hopeless\n");
+ glp_set_col_bnds(mip, j, dn_type, lb, new_ub);
+ T->curr->lp_obj = dn_lp;
+ if (mip->dir == GLP_MIN)
+ { if (T->curr->bound < dn_bnd)
+ T->curr->bound = dn_bnd;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (T->curr->bound > dn_bnd)
+ T->curr->bound = dn_bnd;
+ }
+ else
+ xassert(mip != mip);
+ ret = 1;
+ goto done;
+ }
+ else if (dn_bad)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Down-branch is hopeless\n");
+ glp_set_col_bnds(mip, j, up_type, new_lb, ub);
+ T->curr->lp_obj = up_lp;
+ if (mip->dir == GLP_MIN)
+ { if (T->curr->bound < up_bnd)
+ T->curr->bound = up_bnd;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (T->curr->bound > up_bnd)
+ T->curr->bound = up_bnd;
+ }
+ else
+ xassert(mip != mip);
+ ret = 1;
+ goto done;
+ }
+ /* both down- and up-branches seem to be hopeful */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Branching on column %d, primal value is %.9e\n",
+ j, beta);
+ /* determine the reference number of the current subproblem */
+ xassert(T->curr != NULL);
+ p = T->curr->p;
+ T->curr->br_var = j;
+ T->curr->br_val = beta;
+ /* freeze the current subproblem */
+ ios_freeze_node(T);
+ /* create two clones of the current subproblem; the first clone
+ begins the down-branch, the second one begins the up-branch */
+ ios_clone_node(T, p, 2, clone);
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Node %d begins down branch, node %d begins up branch "
+ "\n", clone[1], clone[2]);
+ /* set new upper bound of j-th column in the down-branch */
+ node = T->slot[clone[1]].node;
+ xassert(node != NULL);
+ xassert(node->up != NULL);
+ xassert(node->b_ptr == NULL);
+ node->b_ptr = dmp_get_atom(T->pool, sizeof(IOSBND));
+ node->b_ptr->k = m + j;
+ node->b_ptr->type = (unsigned char)dn_type;
+ node->b_ptr->lb = lb;
+ node->b_ptr->ub = new_ub;
+ node->b_ptr->next = NULL;
+ node->lp_obj = dn_lp;
+ if (mip->dir == GLP_MIN)
+ { if (node->bound < dn_bnd)
+ node->bound = dn_bnd;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (node->bound > dn_bnd)
+ node->bound = dn_bnd;
+ }
+ else
+ xassert(mip != mip);
+ /* set new lower bound of j-th column in the up-branch */
+ node = T->slot[clone[2]].node;
+ xassert(node != NULL);
+ xassert(node->up != NULL);
+ xassert(node->b_ptr == NULL);
+ node->b_ptr = dmp_get_atom(T->pool, sizeof(IOSBND));
+ node->b_ptr->k = m + j;
+ node->b_ptr->type = (unsigned char)up_type;
+ node->b_ptr->lb = new_lb;
+ node->b_ptr->ub = ub;
+ node->b_ptr->next = NULL;
+ node->lp_obj = up_lp;
+ if (mip->dir == GLP_MIN)
+ { if (node->bound < up_bnd)
+ node->bound = up_bnd;
+ }
+ else if (mip->dir == GLP_MAX)
+ { if (node->bound > up_bnd)
+ node->bound = up_bnd;
+ }
+ else
+ xassert(mip != mip);
+ /* suggest the subproblem to be solved next */
+ xassert(T->child == 0);
+ if (next == GLP_NO_BRNCH)
+ T->child = 0;
+ else if (next == GLP_DN_BRNCH)
+ T->child = clone[1];
+ else if (next == GLP_UP_BRNCH)
+ T->child = clone[2];
+ else
+ xassert(next != next);
+ ret = 0;
+done: return ret;
+}
+
+/***********************************************************************
+* cleanup_the_tree - prune hopeless branches from the tree
+*
+* This routine walks through the active list and checks the local
+* bound for every active subproblem. If the local bound indicates that
+* the subproblem cannot have integer optimal solution better than the
+* incumbent objective value, the routine deletes such subproblem that,
+* in turn, involves pruning the corresponding branch of the tree. */
+
+static void cleanup_the_tree(glp_tree *T)
+{ IOSNPD *node, *next_node;
+ int count = 0;
+ /* the global bound must exist */
+ xassert(T->mip->mip_stat == GLP_FEAS);
+ /* walk through the list of active subproblems */
+ for (node = T->head; node != NULL; node = next_node)
+ { /* deleting some active problem node may involve deleting its
+ parents recursively; however, all its parents being created
+ *before* it are always *precede* it in the node list, so
+ the next problem node is never affected by such deletion */
+ next_node = node->next;
+ /* if the branch is hopeless, prune it */
+ if (!is_branch_hopeful(T, node->p))
+ ios_delete_node(T, node->p), count++;
+ }
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ { if (count == 1)
+ xprintf("One hopeless branch has been pruned\n");
+ else if (count > 1)
+ xprintf("%d hopeless branches have been pruned\n", count);
+ }
+ return;
+}
+
+/***********************************************************************
+* round_heur - simple rounding heuristic
+*
+* This routine attempts to guess an integer feasible solution by
+* simple rounding values of all integer variables in basic solution to
+* nearest integers. */
+
+static int round_heur(glp_tree *T)
+{ glp_prob *P = T->mip;
+ /*int m = P->m;*/
+ int n = P->n;
+ int i, j, ret;
+ double *x;
+ /* compute rounded values of variables */
+ x = talloc(1+n, double);
+ for (j = 1; j <= n; j++)
+ { GLPCOL *col = P->col[j];
+ if (col->kind == GLP_IV)
+ { /* integer variable */
+ x[j] = floor(col->prim + 0.5);
+ }
+ else if (col->type == GLP_FX)
+ { /* fixed variable */
+ x[j] = col->prim;
+ }
+ else
+ { /* non-integer non-fixed variable */
+ ret = 3;
+ goto done;
+ }
+ }
+ /* check that no constraints are violated */
+ for (i = 1; i <= T->orig_m; i++)
+ { int type = T->orig_type[i];
+ GLPAIJ *aij;
+ double sum;
+ if (type == GLP_FR)
+ continue;
+ /* compute value of linear form */
+ sum = 0.0;
+ for (aij = P->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ sum += aij->val * x[aij->col->j];
+ /* check lower bound */
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { if (sum < T->orig_lb[i] - 1e-9)
+ { /* lower bound is violated */
+ ret = 2;
+ goto done;
+ }
+ }
+ /* check upper bound */
+ if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ { if (sum > T->orig_ub[i] + 1e-9)
+ { /* upper bound is violated */
+ ret = 2;
+ goto done;
+ }
+ }
+ }
+ /* rounded solution is integer feasible */
+ if (glp_ios_heur_sol(T, x) == 0)
+ { /* solution is accepted */
+ ret = 0;
+ }
+ else
+ { /* solution is rejected */
+ ret = 1;
+ }
+done: tfree(x);
+ return ret;
+}
+
+/**********************************************************************/
+
+#if 1 /* 08/III-2016 */
+static void gmi_gen(glp_tree *T)
+{ /* generate Gomory's mixed integer cuts */
+ glp_prob *P, *pool;
+ P = T->mip;
+ pool = glp_create_prob();
+ glp_add_cols(pool, P->n);
+ glp_gmi_gen(P, pool, 50);
+ if (pool->m > 0)
+ { int i, len, *ind;
+ double *val;
+ ind = xcalloc(1+P->n, sizeof(int));
+ val = xcalloc(1+P->n, sizeof(double));
+ for (i = 1; i <= pool->m; i++)
+ { len = glp_get_mat_row(pool, i, ind, val);
+ glp_ios_add_row(T, NULL, GLP_RF_GMI, 0, len, ind, val,
+ GLP_LO, pool->row[i]->lb);
+ }
+ xfree(ind);
+ xfree(val);
+ }
+ glp_delete_prob(pool);
+ return;
+}
+#endif
+
+#ifdef NEW_COVER /* 13/II-2018 */
+static void cov_gen(glp_tree *T)
+{ /* generate cover cuts */
+ glp_prob *P, *pool;
+ if (T->cov_gen == NULL)
+ return;
+ P = T->mip;
+ pool = glp_create_prob();
+ glp_add_cols(pool, P->n);
+ glp_cov_gen1(P, T->cov_gen, pool);
+ if (pool->m > 0)
+ { int i, len, *ind;
+ double *val;
+ ind = xcalloc(1+P->n, sizeof(int));
+ val = xcalloc(1+P->n, sizeof(double));
+ for (i = 1; i <= pool->m; i++)
+ { len = glp_get_mat_row(pool, i, ind, val);
+ glp_ios_add_row(T, NULL, GLP_RF_COV, 0, len, ind, val,
+ GLP_UP, pool->row[i]->ub);
+ }
+ xfree(ind);
+ xfree(val);
+ }
+ glp_delete_prob(pool);
+ return;
+}
+#endif
+
+#if 1 /* 08/III-2016 */
+static void mir_gen(glp_tree *T)
+{ /* generate mixed integer rounding cuts */
+ glp_prob *P, *pool;
+ P = T->mip;
+ pool = glp_create_prob();
+ glp_add_cols(pool, P->n);
+ glp_mir_gen(P, T->mir_gen, pool);
+ if (pool->m > 0)
+ { int i, len, *ind;
+ double *val;
+ ind = xcalloc(1+P->n, sizeof(int));
+ val = xcalloc(1+P->n, sizeof(double));
+ for (i = 1; i <= pool->m; i++)
+ { len = glp_get_mat_row(pool, i, ind, val);
+ glp_ios_add_row(T, NULL, GLP_RF_MIR, 0, len, ind, val,
+ GLP_UP, pool->row[i]->ub);
+ }
+ xfree(ind);
+ xfree(val);
+ }
+ glp_delete_prob(pool);
+ return;
+}
+#endif
+
+#if 1 /* 08/III-2016 */
+static void clq_gen(glp_tree *T, glp_cfg *G)
+{ /* generate clique cut from conflict graph */
+ glp_prob *P = T->mip;
+ int n = P->n;
+ int len, *ind;
+ double *val;
+ ind = talloc(1+n, int);
+ val = talloc(1+n, double);
+ len = glp_clq_cut(T->mip, G, ind, val);
+ if (len > 0)
+ glp_ios_add_row(T, NULL, GLP_RF_CLQ, 0, len, ind, val, GLP_UP,
+ val[0]);
+ tfree(ind);
+ tfree(val);
+ return;
+}
+#endif
+
+static void generate_cuts(glp_tree *T)
+{ /* generate generic cuts with built-in generators */
+ if (!(T->parm->mir_cuts == GLP_ON ||
+ T->parm->gmi_cuts == GLP_ON ||
+ T->parm->cov_cuts == GLP_ON ||
+ T->parm->clq_cuts == GLP_ON)) goto done;
+#if 1 /* 20/IX-2008 */
+ { int i, max_cuts, added_cuts;
+ max_cuts = T->n;
+ if (max_cuts < 1000) max_cuts = 1000;
+ added_cuts = 0;
+ for (i = T->orig_m+1; i <= T->mip->m; i++)
+ { if (T->mip->row[i]->origin == GLP_RF_CUT)
+ added_cuts++;
+ }
+ /* xprintf("added_cuts = %d\n", added_cuts); */
+ if (added_cuts >= max_cuts) goto done;
+ }
+#endif
+ /* generate and add to POOL all cuts violated by x* */
+ if (T->parm->gmi_cuts == GLP_ON)
+ { if (T->curr->changed < 7)
+#if 0 /* 08/III-2016 */
+ ios_gmi_gen(T);
+#else
+ gmi_gen(T);
+#endif
+ }
+ if (T->parm->mir_cuts == GLP_ON)
+ { xassert(T->mir_gen != NULL);
+#if 0 /* 08/III-2016 */
+ ios_mir_gen(T, T->mir_gen);
+#else
+ mir_gen(T);
+#endif
+ }
+ if (T->parm->cov_cuts == GLP_ON)
+ { /* cover cuts works well along with mir cuts */
+#ifdef NEW_COVER /* 13/II-2018 */
+ cov_gen(T);
+#else
+ ios_cov_gen(T);
+#endif
+ }
+ if (T->parm->clq_cuts == GLP_ON)
+ { if (T->clq_gen != NULL)
+#if 0 /* 29/VI-2013 */
+ { if (T->curr->level == 0 && T->curr->changed < 50 ||
+ T->curr->level > 0 && T->curr->changed < 5)
+#else /* FIXME */
+ { if (T->curr->level == 0 && T->curr->changed < 500 ||
+ T->curr->level > 0 && T->curr->changed < 50)
+#endif
+#if 0 /* 08/III-2016 */
+ ios_clq_gen(T, T->clq_gen);
+#else
+ clq_gen(T, T->clq_gen);
+#endif
+ }
+ }
+done: return;
+}
+
+/**********************************************************************/
+
+static void remove_cuts(glp_tree *T)
+{ /* remove inactive cuts (some valueable globally valid cut might
+ be saved in the global cut pool) */
+ int i, cnt = 0, *num = NULL;
+ xassert(T->curr != NULL);
+ for (i = T->orig_m+1; i <= T->mip->m; i++)
+ { if (T->mip->row[i]->origin == GLP_RF_CUT &&
+ T->mip->row[i]->level == T->curr->level &&
+ T->mip->row[i]->stat == GLP_BS)
+ { if (num == NULL)
+ num = xcalloc(1+T->mip->m, sizeof(int));
+ num[++cnt] = i;
+ }
+ }
+ if (cnt > 0)
+ { glp_del_rows(T->mip, cnt, num);
+#if 0
+ xprintf("%d inactive cut(s) removed\n", cnt);
+#endif
+ xfree(num);
+ xassert(glp_factorize(T->mip) == 0);
+ }
+ return;
+}
+
+/**********************************************************************/
+
+static void display_cut_info(glp_tree *T)
+{ glp_prob *mip = T->mip;
+ int i, gmi = 0, mir = 0, cov = 0, clq = 0, app = 0;
+ for (i = mip->m; i > 0; i--)
+ { GLPROW *row;
+ row = mip->row[i];
+ /* if (row->level < T->curr->level) break; */
+ if (row->origin == GLP_RF_CUT)
+ { if (row->klass == GLP_RF_GMI)
+ gmi++;
+ else if (row->klass == GLP_RF_MIR)
+ mir++;
+ else if (row->klass == GLP_RF_COV)
+ cov++;
+ else if (row->klass == GLP_RF_CLQ)
+ clq++;
+ else
+ app++;
+ }
+ }
+ xassert(T->curr != NULL);
+ if (gmi + mir + cov + clq + app > 0)
+ { xprintf("Cuts on level %d:", T->curr->level);
+ if (gmi > 0) xprintf(" gmi = %d;", gmi);
+ if (mir > 0) xprintf(" mir = %d;", mir);
+ if (cov > 0) xprintf(" cov = %d;", cov);
+ if (clq > 0) xprintf(" clq = %d;", clq);
+ if (app > 0) xprintf(" app = %d;", app);
+ xprintf("\n");
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_driver - branch-and-cut driver
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_driver(glp_tree *T);
+*
+* DESCRIPTION
+*
+* The routine ios_driver is a branch-and-cut driver. It controls the
+* MIP solution process.
+*
+* RETURNS
+*
+* 0 The MIP problem instance has been successfully solved. This code
+* does not necessarily mean that the solver has found optimal
+* solution. It only means that the solution process was successful.
+*
+* GLP_EFAIL
+* The search was prematurely terminated due to the solver failure.
+*
+* GLP_EMIPGAP
+* The search was prematurely terminated, because the relative mip
+* gap tolerance has been reached.
+*
+* GLP_ETMLIM
+* The search was prematurely terminated, because the time limit has
+* been exceeded.
+*
+* GLP_ESTOP
+* The search was prematurely terminated by application. */
+
+int ios_driver(glp_tree *T)
+{ int p, curr_p, p_stat, d_stat, ret;
+#if 1 /* carry out to glp_tree */
+ int pred_p = 0;
+ /* if the current subproblem has been just created due to
+ branching, pred_p is the reference number of its parent
+ subproblem, otherwise pred_p is zero */
+#endif
+#if 1 /* 18/VII-2013 */
+ int bad_cut;
+ double old_obj;
+#endif
+#if 0 /* 10/VI-2013 */
+ glp_long ttt = T->tm_beg;
+#else
+ double ttt = T->tm_beg;
+#endif
+#if 1 /* 27/II-2016 by Chris */
+ int root_done = 0;
+#endif
+#if 0
+ ((glp_iocp *)T->parm)->msg_lev = GLP_MSG_DBG;
+#endif
+#if 1 /* 16/III-2016 */
+ if (((glp_iocp *)T->parm)->flip)
+#if 0 /* 20/I-2018 */
+ xprintf("WARNING: LONG-STEP DUAL SIMPLEX WILL BE USED\n");
+#else
+ xprintf("Long-step dual simplex will be used\n");
+#endif
+#endif
+ /* on entry to the B&B driver it is assumed that the active list
+ contains the only active (i.e. root) subproblem, which is the
+ original MIP problem to be solved */
+loop: /* main loop starts here */
+ /* at this point the current subproblem does not exist */
+ xassert(T->curr == NULL);
+ /* if the active list is empty, the search is finished */
+ if (T->head == NULL)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Active list is empty!\n");
+#if 0 /* 10/VI-2013 */
+ xassert(dmp_in_use(T->pool).lo == 0);
+#else
+ xassert(dmp_in_use(T->pool) == 0);
+#endif
+ ret = 0;
+ goto done;
+ }
+ /* select some active subproblem to continue the search */
+ xassert(T->next_p == 0);
+ /* let the application program select subproblem */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_ISELECT;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ }
+ if (T->next_p != 0)
+ { /* the application program has selected something */
+ ;
+ }
+ else if (T->a_cnt == 1)
+ { /* the only active subproblem exists, so select it */
+ xassert(T->head->next == NULL);
+ T->next_p = T->head->p;
+ }
+ else if (T->child != 0)
+ { /* select one of branching childs suggested by the branching
+ heuristic */
+ T->next_p = T->child;
+ }
+ else
+ { /* select active subproblem as specified by the backtracking
+ technique option */
+ T->next_p = ios_choose_node(T);
+ }
+ /* the active subproblem just selected becomes current */
+ ios_revive_node(T, T->next_p);
+ T->next_p = T->child = 0;
+ /* invalidate pred_p, if it is not the reference number of the
+ parent of the current subproblem */
+ if (T->curr->up != NULL && T->curr->up->p != pred_p) pred_p = 0;
+ /* determine the reference number of the current subproblem */
+ p = T->curr->p;
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ { xprintf("-----------------------------------------------------"
+ "-------------------\n");
+ xprintf("Processing node %d at level %d\n", p, T->curr->level);
+ }
+#if 0
+ if (p == 1)
+ glp_write_lp(T->mip, NULL, "root.lp");
+#endif
+#if 1 /* 24/X-2015 */
+ if (p == 1)
+ { if (T->parm->sr_heur == GLP_OFF)
+ { if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Simple rounding heuristic disabled\n");
+ }
+ }
+#endif
+ /* if it is the root subproblem, initialize cut generators */
+ if (p == 1)
+ { if (T->parm->gmi_cuts == GLP_ON)
+ { if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Gomory's cuts enabled\n");
+ }
+ if (T->parm->mir_cuts == GLP_ON)
+ { if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("MIR cuts enabled\n");
+ xassert(T->mir_gen == NULL);
+#if 0 /* 06/III-2016 */
+ T->mir_gen = ios_mir_init(T);
+#else
+ T->mir_gen = glp_mir_init(T->mip);
+#endif
+ }
+ if (T->parm->cov_cuts == GLP_ON)
+ { if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Cover cuts enabled\n");
+#ifdef NEW_COVER /* 13/II-2018 */
+ xassert(T->cov_gen == NULL);
+ T->cov_gen = glp_cov_init(T->mip);
+#endif
+ }
+ if (T->parm->clq_cuts == GLP_ON)
+ { xassert(T->clq_gen == NULL);
+ if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Clique cuts enabled\n");
+#if 0 /* 08/III-2016 */
+ T->clq_gen = ios_clq_init(T);
+#else
+ T->clq_gen = glp_cfg_init(T->mip);
+#endif
+ }
+ }
+#if 1 /* 18/VII-2013 */
+ bad_cut = 0;
+#endif
+more: /* minor loop starts here */
+ /* at this point the current subproblem needs either to be solved
+ for the first time or re-optimized due to reformulation */
+ /* display current progress of the search */
+ if (T->parm->msg_lev >= GLP_MSG_DBG ||
+ T->parm->msg_lev >= GLP_MSG_ON &&
+ (double)(T->parm->out_frq - 1) <=
+ 1000.0 * xdifftime(xtime(), T->tm_lag))
+ show_progress(T, 0);
+ if (T->parm->msg_lev >= GLP_MSG_ALL &&
+ xdifftime(xtime(), ttt) >= 60.0)
+#if 0 /* 16/II-2012 */
+ { glp_long total;
+ glp_mem_usage(NULL, NULL, &total, NULL);
+ xprintf("Time used: %.1f secs. Memory used: %.1f Mb.\n",
+ xdifftime(xtime(), T->tm_beg), xltod(total) / 1048576.0);
+ ttt = xtime();
+ }
+#else
+ { size_t total;
+ glp_mem_usage(NULL, NULL, &total, NULL);
+ xprintf("Time used: %.1f secs. Memory used: %.1f Mb.\n",
+ xdifftime(xtime(), T->tm_beg), (double)total / 1048576.0);
+ ttt = xtime();
+ }
+#endif
+ /* check the mip gap */
+ if (T->parm->mip_gap > 0.0 &&
+ ios_relative_gap(T) <= T->parm->mip_gap)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Relative gap tolerance reached; search terminated "
+ "\n");
+ ret = GLP_EMIPGAP;
+ goto done;
+ }
+ /* check if the time limit has been exhausted */
+ if (T->parm->tm_lim < INT_MAX &&
+ (double)(T->parm->tm_lim - 1) <=
+ 1000.0 * xdifftime(xtime(), T->tm_beg))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Time limit exhausted; search terminated\n");
+ ret = GLP_ETMLIM;
+ goto done;
+ }
+ /* let the application program preprocess the subproblem */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_IPREPRO;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ }
+ /* perform basic preprocessing */
+ if (T->parm->pp_tech == GLP_PP_NONE)
+ ;
+ else if (T->parm->pp_tech == GLP_PP_ROOT)
+#if 0 /* 27/II-2016 by Chris */
+ { if (T->curr->level == 0)
+#else
+ { if (!root_done)
+#endif
+ { if (ios_preprocess_node(T, 100))
+ goto fath;
+ }
+ }
+ else if (T->parm->pp_tech == GLP_PP_ALL)
+#if 0 /* 27/II-2016 by Chris */
+ { if (ios_preprocess_node(T, T->curr->level == 0 ? 100 : 10))
+#else
+ { if (ios_preprocess_node(T, !root_done ? 100 : 10))
+#endif
+ goto fath;
+ }
+ else
+ xassert(T != T);
+ /* preprocessing may improve the global bound */
+ if (!is_branch_hopeful(T, p))
+ { xprintf("*** not tested yet ***\n");
+ goto fath;
+ }
+ /* solve LP relaxation of the current subproblem */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Solving LP relaxation...\n");
+ ret = ios_solve_node(T);
+ if (ret == GLP_ETMLIM)
+ goto done;
+ else if (!(ret == 0 || ret == GLP_EOBJLL || ret == GLP_EOBJUL))
+ { if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("ios_driver: unable to solve current LP relaxation;"
+ " glp_simplex returned %d\n", ret);
+ ret = GLP_EFAIL;
+ goto done;
+ }
+ /* analyze status of the basic solution to LP relaxation found */
+ p_stat = T->mip->pbs_stat;
+ d_stat = T->mip->dbs_stat;
+ if (p_stat == GLP_FEAS && d_stat == GLP_FEAS)
+ { /* LP relaxation has optimal solution */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Found optimal solution to LP relaxation\n");
+ }
+ else if (d_stat == GLP_NOFEAS)
+ { /* LP relaxation has no dual feasible solution */
+ /* since the current subproblem cannot have a larger feasible
+ region than its parent, there is something wrong */
+ if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("ios_driver: current LP relaxation has no dual feas"
+ "ible solution\n");
+ ret = GLP_EFAIL;
+ goto done;
+ }
+ else if (p_stat == GLP_INFEAS && d_stat == GLP_FEAS)
+ { /* LP relaxation has no primal solution which is better than
+ the incumbent objective value */
+ xassert(T->mip->mip_stat == GLP_FEAS);
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("LP relaxation has no solution better than incumben"
+ "t objective value\n");
+ /* prune the branch */
+ goto fath;
+ }
+ else if (p_stat == GLP_NOFEAS)
+ { /* LP relaxation has no primal feasible solution */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("LP relaxation has no feasible solution\n");
+ /* prune the branch */
+ goto fath;
+ }
+ else
+ { /* other cases cannot appear */
+ xassert(T->mip != T->mip);
+ }
+ /* at this point basic solution to LP relaxation of the current
+ subproblem is optimal */
+ xassert(p_stat == GLP_FEAS && d_stat == GLP_FEAS);
+ xassert(T->curr != NULL);
+ T->curr->lp_obj = T->mip->obj_val;
+ /* thus, it defines a local bound to integer optimal solution of
+ the current subproblem */
+ { double bound = T->mip->obj_val;
+ /* some local bound to the current subproblem could be already
+ set before, so we should only improve it */
+ bound = ios_round_bound(T, bound);
+ if (T->mip->dir == GLP_MIN)
+ { if (T->curr->bound < bound)
+ T->curr->bound = bound;
+ }
+ else if (T->mip->dir == GLP_MAX)
+ { if (T->curr->bound > bound)
+ T->curr->bound = bound;
+ }
+ else
+ xassert(T->mip != T->mip);
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Local bound is %.9e\n", bound);
+ }
+ /* if the local bound indicates that integer optimal solution of
+ the current subproblem cannot be better than the global bound,
+ prune the branch */
+ if (!is_branch_hopeful(T, p))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Current branch is hopeless and can be pruned\n");
+ goto fath;
+ }
+ /* let the application program generate additional rows ("lazy"
+ constraints) */
+ xassert(T->reopt == 0);
+ xassert(T->reinv == 0);
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_IROWGEN;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ if (T->reopt)
+ { /* some rows were added; re-optimization is needed */
+ T->reopt = T->reinv = 0;
+ goto more;
+ }
+ if (T->reinv)
+ { /* no rows were added, however, some inactive rows were
+ removed */
+ T->reinv = 0;
+ xassert(glp_factorize(T->mip) == 0);
+ }
+ }
+ /* check if the basic solution is integer feasible */
+ check_integrality(T);
+ /* if the basic solution satisfies to all integrality conditions,
+ it is a new, better integer feasible solution */
+ if (T->curr->ii_cnt == 0)
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("New integer feasible solution found\n");
+ if (T->parm->msg_lev >= GLP_MSG_ALL)
+ display_cut_info(T);
+ record_solution(T);
+ if (T->parm->msg_lev >= GLP_MSG_ON)
+ show_progress(T, 1);
+#if 1 /* 11/VII-2013 */
+ ios_process_sol(T);
+#endif
+ /* make the application program happy */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_IBINGO;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ }
+ /* since the current subproblem has been fathomed, prune its
+ branch */
+ goto fath;
+ }
+ /* at this point basic solution to LP relaxation of the current
+ subproblem is optimal, but integer infeasible */
+ /* try to fix some non-basic structural variables of integer kind
+ on their current bounds due to reduced costs */
+ if (T->mip->mip_stat == GLP_FEAS)
+ fix_by_red_cost(T);
+ /* let the application program try to find some solution to the
+ original MIP with a primal heuristic */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_IHEUR;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ /* check if the current branch became hopeless */
+ if (!is_branch_hopeful(T, p))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Current branch became hopeless and can be prune"
+ "d\n");
+ goto fath;
+ }
+ }
+ /* try to find solution with the feasibility pump heuristic */
+#if 0 /* 27/II-2016 by Chris */
+ if (T->parm->fp_heur)
+#else
+ if (T->parm->fp_heur && !root_done)
+#endif
+ { xassert(T->reason == 0);
+ T->reason = GLP_IHEUR;
+ ios_feas_pump(T);
+ T->reason = 0;
+ /* check if the current branch became hopeless */
+ if (!is_branch_hopeful(T, p))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Current branch became hopeless and can be prune"
+ "d\n");
+ goto fath;
+ }
+ }
+#if 1 /* 25/V-2013 */
+ /* try to find solution with the proximity search heuristic */
+#if 0 /* 27/II-2016 by Chris */
+ if (T->parm->ps_heur)
+#else
+ if (T->parm->ps_heur && !root_done)
+#endif
+ { xassert(T->reason == 0);
+ T->reason = GLP_IHEUR;
+ ios_proxy_heur(T);
+ T->reason = 0;
+ /* check if the current branch became hopeless */
+ if (!is_branch_hopeful(T, p))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Current branch became hopeless and can be prune"
+ "d\n");
+ goto fath;
+ }
+ }
+#endif
+#if 1 /* 24/X-2015 */
+ /* try to find solution with a simple rounding heuristic */
+ if (T->parm->sr_heur)
+ { xassert(T->reason == 0);
+ T->reason = GLP_IHEUR;
+ round_heur(T);
+ T->reason = 0;
+ /* check if the current branch became hopeless */
+ if (!is_branch_hopeful(T, p))
+ { if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Current branch became hopeless and can be prune"
+ "d\n");
+ goto fath;
+ }
+ }
+#endif
+ /* it's time to generate cutting planes */
+ xassert(T->local != NULL);
+#ifdef NEW_LOCAL /* 02/II-2018 */
+ xassert(T->local->m == 0);
+#else
+ xassert(T->local->size == 0);
+#endif
+ /* let the application program generate some cuts; note that it
+ can add cuts either to the local cut pool or directly to the
+ current subproblem */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ T->reason = GLP_ICUTGEN;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ }
+#if 1 /* 18/VII-2013 */
+ if (T->curr->changed > 0)
+ { double degrad = fabs(T->curr->lp_obj - old_obj);
+ if (degrad < 1e-4 * (1.0 + fabs(old_obj)))
+ bad_cut++;
+ else
+ bad_cut = 0;
+ }
+ old_obj = T->curr->lp_obj;
+#if 0 /* 27/II-2016 by Chris */
+ if (bad_cut == 0 || (T->curr->level == 0 && bad_cut <= 3))
+#else
+ if (bad_cut == 0 || (!root_done && bad_cut <= 3))
+#endif
+#endif
+ /* try to generate generic cuts with built-in generators
+ (as suggested by Prof. Fischetti et al. the built-in cuts are
+ not generated at each branching node; an intense attempt of
+ generating new cuts is only made at the root node, and then
+ a moderate effort is spent after each backtracking step) */
+#if 0 /* 27/II-2016 by Chris */
+ if (T->curr->level == 0 || pred_p == 0)
+#else
+ if (!root_done || pred_p == 0)
+#endif
+ { xassert(T->reason == 0);
+ T->reason = GLP_ICUTGEN;
+ generate_cuts(T);
+ T->reason = 0;
+ }
+ /* if the local cut pool is not empty, select useful cuts and add
+ them to the current subproblem */
+#ifdef NEW_LOCAL /* 02/II-2018 */
+ if (T->local->m > 0)
+#else
+ if (T->local->size > 0)
+#endif
+ { xassert(T->reason == 0);
+ T->reason = GLP_ICUTGEN;
+ ios_process_cuts(T);
+ T->reason = 0;
+ }
+ /* clear the local cut pool */
+ ios_clear_pool(T, T->local);
+ /* perform re-optimization, if necessary */
+ if (T->reopt)
+ { T->reopt = 0;
+ T->curr->changed++;
+ goto more;
+ }
+ /* no cuts were generated; remove inactive cuts */
+ remove_cuts(T);
+#if 0 /* 27/II-2016 by Chris */
+ if (T->parm->msg_lev >= GLP_MSG_ALL && T->curr->level == 0)
+#else
+ if (T->parm->msg_lev >= GLP_MSG_ALL && !root_done)
+#endif
+ display_cut_info(T);
+#if 1 /* 27/II-2016 by Chris */
+ /* the first node will not be treated as root any more */
+ if (!root_done) root_done = 1;
+#endif
+ /* update history information used on pseudocost branching */
+ if (T->pcost != NULL) ios_pcost_update(T);
+ /* it's time to perform branching */
+ xassert(T->br_var == 0);
+ xassert(T->br_sel == 0);
+ /* let the application program choose variable to branch on */
+ if (T->parm->cb_func != NULL)
+ { xassert(T->reason == 0);
+ xassert(T->br_var == 0);
+ xassert(T->br_sel == 0);
+ T->reason = GLP_IBRANCH;
+ T->parm->cb_func(T, T->parm->cb_info);
+ T->reason = 0;
+ if (T->stop)
+ { ret = GLP_ESTOP;
+ goto done;
+ }
+ }
+ /* if nothing has been chosen, choose some variable as specified
+ by the branching technique option */
+ if (T->br_var == 0)
+ T->br_var = ios_choose_var(T, &T->br_sel);
+ /* perform actual branching */
+ curr_p = T->curr->p;
+ ret = branch_on(T, T->br_var, T->br_sel);
+ T->br_var = T->br_sel = 0;
+ if (ret == 0)
+ { /* both branches have been created */
+ pred_p = curr_p;
+ goto loop;
+ }
+ else if (ret == 1)
+ { /* one branch is hopeless and has been pruned, so now the
+ current subproblem is other branch */
+ /* the current subproblem should be considered as a new one,
+ since one bound of the branching variable was changed */
+ T->curr->solved = T->curr->changed = 0;
+#if 1 /* 18/VII-2013 */
+ /* bad_cut = 0; */
+#endif
+ goto more;
+ }
+ else if (ret == 2)
+ { /* both branches are hopeless and have been pruned; new
+ subproblem selection is needed to continue the search */
+ goto fath;
+ }
+ else
+ xassert(ret != ret);
+fath: /* the current subproblem has been fathomed */
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("Node %d fathomed\n", p);
+ /* freeze the current subproblem */
+ ios_freeze_node(T);
+ /* and prune the corresponding branch of the tree */
+ ios_delete_node(T, p);
+ /* if a new integer feasible solution has just been found, other
+ branches may become hopeless and therefore must be pruned */
+ if (T->mip->mip_stat == GLP_FEAS) cleanup_the_tree(T);
+ /* new subproblem selection is needed due to backtracking */
+ pred_p = 0;
+ goto loop;
+done: /* display progress of the search on exit from the solver */
+ if (T->parm->msg_lev >= GLP_MSG_ON)
+ show_progress(T, 0);
+ if (T->mir_gen != NULL)
+#if 0 /* 06/III-2016 */
+ ios_mir_term(T->mir_gen), T->mir_gen = NULL;
+#else
+ glp_mir_free(T->mir_gen), T->mir_gen = NULL;
+#endif
+#ifdef NEW_COVER /* 13/II-2018 */
+ if (T->cov_gen != NULL)
+ glp_cov_free(T->cov_gen), T->cov_gen = NULL;
+#endif
+ if (T->clq_gen != NULL)
+#if 0 /* 08/III-2016 */
+ ios_clq_term(T->clq_gen), T->clq_gen = NULL;
+#else
+ glp_cfg_free(T->clq_gen), T->clq_gen = NULL;
+#endif
+ /* return to the calling program */
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios07.c b/test/monniaux/glpk-4.65/src/draft/glpios07.c
new file mode 100644
index 00000000..f750e571
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios07.c
@@ -0,0 +1,551 @@
+/* glpios07.c (mixed cover cut generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/*----------------------------------------------------------------------
+-- COVER INEQUALITIES
+--
+-- Consider the set of feasible solutions to 0-1 knapsack problem:
+--
+-- sum a[j]*x[j] <= b, (1)
+-- j in J
+--
+-- x[j] is binary, (2)
+--
+-- where, wlog, we assume that a[j] > 0 (since 0-1 variables can be
+-- complemented) and a[j] <= b (since a[j] > b implies x[j] = 0).
+--
+-- A set C within J is called a cover if
+--
+-- sum a[j] > b. (3)
+-- j in C
+--
+-- For any cover C the inequality
+--
+-- sum x[j] <= |C| - 1 (4)
+-- j in C
+--
+-- is called a cover inequality and is valid for (1)-(2).
+--
+-- MIXED COVER INEQUALITIES
+--
+-- Consider the set of feasible solutions to mixed knapsack problem:
+--
+-- sum a[j]*x[j] + y <= b, (5)
+-- j in J
+--
+-- x[j] is binary, (6)
+--
+-- 0 <= y <= u is continuous, (7)
+--
+-- where again we assume that a[j] > 0.
+--
+-- Let C within J be some set. From (1)-(4) it follows that
+--
+-- sum a[j] > b - y (8)
+-- j in C
+--
+-- implies
+--
+-- sum x[j] <= |C| - 1. (9)
+-- j in C
+--
+-- Thus, we need to modify the inequality (9) in such a way that it be
+-- a constraint only if the condition (8) is satisfied.
+--
+-- Consider the following inequality:
+--
+-- sum x[j] <= |C| - t. (10)
+-- j in C
+--
+-- If 0 < t <= 1, then (10) is equivalent to (9), because all x[j] are
+-- binary variables. On the other hand, if t <= 0, (10) being satisfied
+-- for any values of x[j] is not a constraint.
+--
+-- Let
+--
+-- t' = sum a[j] + y - b. (11)
+-- j in C
+--
+-- It is understood that the condition t' > 0 is equivalent to (8).
+-- Besides, from (6)-(7) it follows that t' has an implied upper bound:
+--
+-- t'max = sum a[j] + u - b. (12)
+-- j in C
+--
+-- This allows to express the parameter t having desired properties:
+--
+-- t = t' / t'max. (13)
+--
+-- In fact, t <= 1 by definition, and t > 0 being equivalent to t' > 0
+-- is equivalent to (8).
+--
+-- Thus, the inequality (10), where t is given by formula (13) is valid
+-- for (5)-(7).
+--
+-- Note that if u = 0, then y = 0, so t = 1, and the conditions (8) and
+-- (10) is transformed to the conditions (3) and (4).
+--
+-- GENERATING MIXED COVER CUTS
+--
+-- To generate a mixed cover cut in the form (10) we need to find such
+-- set C which satisfies to the inequality (8) and for which, in turn,
+-- the inequality (10) is violated in the current point.
+--
+-- Substituting t from (13) to (10) gives:
+--
+-- 1
+-- sum x[j] <= |C| - ----- (sum a[j] + y - b), (14)
+-- j in C t'max j in C
+--
+-- and finally we have the cut inequality in the standard form:
+--
+-- sum x[j] + alfa * y <= beta, (15)
+-- j in C
+--
+-- where:
+--
+-- alfa = 1 / t'max, (16)
+--
+-- beta = |C| - alfa * (sum a[j] - b). (17)
+-- j in C */
+
+#if 1
+#define MAXTRY 1000
+#else
+#define MAXTRY 10000
+#endif
+
+static int cover2(int n, double a[], double b, double u, double x[],
+ double y, int cov[], double *_alfa, double *_beta)
+{ /* try to generate mixed cover cut using two-element cover */
+ int i, j, try = 0, ret = 0;
+ double eps, alfa, beta, temp, rmax = 0.001;
+ eps = 0.001 * (1.0 + fabs(b));
+ for (i = 0+1; i <= n; i++)
+ for (j = i+1; j <= n; j++)
+ { /* C = {i, j} */
+ try++;
+ if (try > MAXTRY) goto done;
+ /* check if condition (8) is satisfied */
+ if (a[i] + a[j] + y > b + eps)
+ { /* compute parameters for inequality (15) */
+ temp = a[i] + a[j] - b;
+ alfa = 1.0 / (temp + u);
+ beta = 2.0 - alfa * temp;
+ /* compute violation of inequality (15) */
+ temp = x[i] + x[j] + alfa * y - beta;
+ /* choose C providing maximum violation */
+ if (rmax < temp)
+ { rmax = temp;
+ cov[1] = i;
+ cov[2] = j;
+ *_alfa = alfa;
+ *_beta = beta;
+ ret = 1;
+ }
+ }
+ }
+done: return ret;
+}
+
+static int cover3(int n, double a[], double b, double u, double x[],
+ double y, int cov[], double *_alfa, double *_beta)
+{ /* try to generate mixed cover cut using three-element cover */
+ int i, j, k, try = 0, ret = 0;
+ double eps, alfa, beta, temp, rmax = 0.001;
+ eps = 0.001 * (1.0 + fabs(b));
+ for (i = 0+1; i <= n; i++)
+ for (j = i+1; j <= n; j++)
+ for (k = j+1; k <= n; k++)
+ { /* C = {i, j, k} */
+ try++;
+ if (try > MAXTRY) goto done;
+ /* check if condition (8) is satisfied */
+ if (a[i] + a[j] + a[k] + y > b + eps)
+ { /* compute parameters for inequality (15) */
+ temp = a[i] + a[j] + a[k] - b;
+ alfa = 1.0 / (temp + u);
+ beta = 3.0 - alfa * temp;
+ /* compute violation of inequality (15) */
+ temp = x[i] + x[j] + x[k] + alfa * y - beta;
+ /* choose C providing maximum violation */
+ if (rmax < temp)
+ { rmax = temp;
+ cov[1] = i;
+ cov[2] = j;
+ cov[3] = k;
+ *_alfa = alfa;
+ *_beta = beta;
+ ret = 1;
+ }
+ }
+ }
+done: return ret;
+}
+
+static int cover4(int n, double a[], double b, double u, double x[],
+ double y, int cov[], double *_alfa, double *_beta)
+{ /* try to generate mixed cover cut using four-element cover */
+ int i, j, k, l, try = 0, ret = 0;
+ double eps, alfa, beta, temp, rmax = 0.001;
+ eps = 0.001 * (1.0 + fabs(b));
+ for (i = 0+1; i <= n; i++)
+ for (j = i+1; j <= n; j++)
+ for (k = j+1; k <= n; k++)
+ for (l = k+1; l <= n; l++)
+ { /* C = {i, j, k, l} */
+ try++;
+ if (try > MAXTRY) goto done;
+ /* check if condition (8) is satisfied */
+ if (a[i] + a[j] + a[k] + a[l] + y > b + eps)
+ { /* compute parameters for inequality (15) */
+ temp = a[i] + a[j] + a[k] + a[l] - b;
+ alfa = 1.0 / (temp + u);
+ beta = 4.0 - alfa * temp;
+ /* compute violation of inequality (15) */
+ temp = x[i] + x[j] + x[k] + x[l] + alfa * y - beta;
+ /* choose C providing maximum violation */
+ if (rmax < temp)
+ { rmax = temp;
+ cov[1] = i;
+ cov[2] = j;
+ cov[3] = k;
+ cov[4] = l;
+ *_alfa = alfa;
+ *_beta = beta;
+ ret = 1;
+ }
+ }
+ }
+done: return ret;
+}
+
+static int cover(int n, double a[], double b, double u, double x[],
+ double y, int cov[], double *alfa, double *beta)
+{ /* try to generate mixed cover cut;
+ input (see (5)):
+ n is the number of binary variables;
+ a[1:n] are coefficients at binary variables;
+ b is the right-hand side;
+ u is upper bound of continuous variable;
+ x[1:n] are values of binary variables at current point;
+ y is value of continuous variable at current point;
+ output (see (15), (16), (17)):
+ cov[1:r] are indices of binary variables included in cover C,
+ where r is the set cardinality returned on exit;
+ alfa coefficient at continuous variable;
+ beta is the right-hand side; */
+ int j;
+ /* perform some sanity checks */
+ xassert(n >= 2);
+ for (j = 1; j <= n; j++) xassert(a[j] > 0.0);
+#if 1 /* ??? */
+ xassert(b > -1e-5);
+#else
+ xassert(b > 0.0);
+#endif
+ xassert(u >= 0.0);
+ for (j = 1; j <= n; j++) xassert(0.0 <= x[j] && x[j] <= 1.0);
+ xassert(0.0 <= y && y <= u);
+ /* try to generate mixed cover cut */
+ if (cover2(n, a, b, u, x, y, cov, alfa, beta)) return 2;
+ if (cover3(n, a, b, u, x, y, cov, alfa, beta)) return 3;
+ if (cover4(n, a, b, u, x, y, cov, alfa, beta)) return 4;
+ return 0;
+}
+
+/*----------------------------------------------------------------------
+-- lpx_cover_cut - generate mixed cover cut.
+--
+-- SYNOPSIS
+--
+-- int lpx_cover_cut(LPX *lp, int len, int ind[], double val[],
+-- double work[]);
+--
+-- DESCRIPTION
+--
+-- The routine lpx_cover_cut generates a mixed cover cut for a given
+-- row of the MIP problem.
+--
+-- The given row of the MIP problem should be explicitly specified in
+-- the form:
+--
+-- sum{j in J} a[j]*x[j] <= b. (1)
+--
+-- On entry indices (ordinal numbers) of structural variables, which
+-- have non-zero constraint coefficients, should be placed in locations
+-- ind[1], ..., ind[len], and corresponding constraint coefficients
+-- should be placed in locations val[1], ..., val[len]. The right-hand
+-- side b should be stored in location val[0].
+--
+-- The working array work should have at least nb locations, where nb
+-- is the number of binary variables in (1).
+--
+-- The routine generates a mixed cover cut in the same form as (1) and
+-- stores the cut coefficients and right-hand side in the same way as
+-- just described above.
+--
+-- RETURNS
+--
+-- If the cutting plane has been successfully generated, the routine
+-- returns 1 <= len' <= n, which is the number of non-zero coefficients
+-- in the inequality constraint. Otherwise, the routine returns zero. */
+
+static int lpx_cover_cut(glp_prob *lp, int len, int ind[],
+ double val[], double work[])
+{ int cov[1+4], j, k, nb, newlen, r;
+ double f_min, f_max, alfa, beta, u, *x = work, y;
+ /* substitute and remove fixed variables */
+ newlen = 0;
+ for (k = 1; k <= len; k++)
+ { j = ind[k];
+ if (glp_get_col_type(lp, j) == GLP_FX)
+ val[0] -= val[k] * glp_get_col_lb(lp, j);
+ else
+ { newlen++;
+ ind[newlen] = ind[k];
+ val[newlen] = val[k];
+ }
+ }
+ len = newlen;
+ /* move binary variables to the beginning of the list so that
+ elements 1, 2, ..., nb correspond to binary variables, and
+ elements nb+1, nb+2, ..., len correspond to rest variables */
+ nb = 0;
+ for (k = 1; k <= len; k++)
+ { j = ind[k];
+ if (glp_get_col_kind(lp, j) == GLP_BV)
+ { /* binary variable */
+ int ind_k;
+ double val_k;
+ nb++;
+ ind_k = ind[nb], val_k = val[nb];
+ ind[nb] = ind[k], val[nb] = val[k];
+ ind[k] = ind_k, val[k] = val_k;
+ }
+ }
+ /* now the specified row has the form:
+ sum a[j]*x[j] + sum a[j]*y[j] <= b,
+ where x[j] are binary variables, y[j] are rest variables */
+ /* at least two binary variables are needed */
+ if (nb < 2) return 0;
+ /* compute implied lower and upper bounds for sum a[j]*y[j] */
+ f_min = f_max = 0.0;
+ for (k = nb+1; k <= len; k++)
+ { j = ind[k];
+ /* both bounds must be finite */
+ if (glp_get_col_type(lp, j) != GLP_DB) return 0;
+ if (val[k] > 0.0)
+ { f_min += val[k] * glp_get_col_lb(lp, j);
+ f_max += val[k] * glp_get_col_ub(lp, j);
+ }
+ else
+ { f_min += val[k] * glp_get_col_ub(lp, j);
+ f_max += val[k] * glp_get_col_lb(lp, j);
+ }
+ }
+ /* sum a[j]*x[j] + sum a[j]*y[j] <= b ===>
+ sum a[j]*x[j] + (sum a[j]*y[j] - f_min) <= b - f_min ===>
+ sum a[j]*x[j] + y <= b - f_min,
+ where y = sum a[j]*y[j] - f_min;
+ note that 0 <= y <= u, u = f_max - f_min */
+ /* determine upper bound of y */
+ u = f_max - f_min;
+ /* determine value of y at the current point */
+ y = 0.0;
+ for (k = nb+1; k <= len; k++)
+ { j = ind[k];
+ y += val[k] * glp_get_col_prim(lp, j);
+ }
+ y -= f_min;
+ if (y < 0.0) y = 0.0;
+ if (y > u) y = u;
+ /* modify the right-hand side b */
+ val[0] -= f_min;
+ /* now the transformed row has the form:
+ sum a[j]*x[j] + y <= b, where 0 <= y <= u */
+ /* determine values of x[j] at the current point */
+ for (k = 1; k <= nb; k++)
+ { j = ind[k];
+ x[k] = glp_get_col_prim(lp, j);
+ if (x[k] < 0.0) x[k] = 0.0;
+ if (x[k] > 1.0) x[k] = 1.0;
+ }
+ /* if a[j] < 0, replace x[j] by its complement 1 - x'[j] */
+ for (k = 1; k <= nb; k++)
+ { if (val[k] < 0.0)
+ { ind[k] = - ind[k];
+ val[k] = - val[k];
+ val[0] += val[k];
+ x[k] = 1.0 - x[k];
+ }
+ }
+ /* try to generate a mixed cover cut for the transformed row */
+ r = cover(nb, val, val[0], u, x, y, cov, &alfa, &beta);
+ if (r == 0) return 0;
+ xassert(2 <= r && r <= 4);
+ /* now the cut is in the form:
+ sum{j in C} x[j] + alfa * y <= beta */
+ /* store the right-hand side beta */
+ ind[0] = 0, val[0] = beta;
+ /* restore the original ordinal numbers of x[j] */
+ for (j = 1; j <= r; j++) cov[j] = ind[cov[j]];
+ /* store cut coefficients at binary variables complementing back
+ the variables having negative row coefficients */
+ xassert(r <= nb);
+ for (k = 1; k <= r; k++)
+ { if (cov[k] > 0)
+ { ind[k] = +cov[k];
+ val[k] = +1.0;
+ }
+ else
+ { ind[k] = -cov[k];
+ val[k] = -1.0;
+ val[0] -= 1.0;
+ }
+ }
+ /* substitute y = sum a[j]*y[j] - f_min */
+ for (k = nb+1; k <= len; k++)
+ { r++;
+ ind[r] = ind[k];
+ val[r] = alfa * val[k];
+ }
+ val[0] += alfa * f_min;
+ xassert(r <= len);
+ len = r;
+ return len;
+}
+
+/*----------------------------------------------------------------------
+-- lpx_eval_row - compute explictily specified row.
+--
+-- SYNOPSIS
+--
+-- double lpx_eval_row(LPX *lp, int len, int ind[], double val[]);
+--
+-- DESCRIPTION
+--
+-- The routine lpx_eval_row computes the primal value of an explicitly
+-- specified row using current values of structural variables.
+--
+-- The explicitly specified row may be thought as a linear form:
+--
+-- y = a[1]*x[m+1] + a[2]*x[m+2] + ... + a[n]*x[m+n],
+--
+-- where y is an auxiliary variable for this row, a[j] are coefficients
+-- of the linear form, x[m+j] are structural variables.
+--
+-- On entry column indices and numerical values of non-zero elements of
+-- the row should be stored in locations ind[1], ..., ind[len] and
+-- val[1], ..., val[len], where len is the number of non-zero elements.
+-- The array ind and val are not changed on exit.
+--
+-- RETURNS
+--
+-- The routine returns a computed value of y, the auxiliary variable of
+-- the specified row. */
+
+static double lpx_eval_row(glp_prob *lp, int len, int ind[],
+ double val[])
+{ int n = glp_get_num_cols(lp);
+ int j, k;
+ double sum = 0.0;
+ if (len < 0)
+ xerror("lpx_eval_row: len = %d; invalid row length\n", len);
+ for (k = 1; k <= len; k++)
+ { j = ind[k];
+ if (!(1 <= j && j <= n))
+ xerror("lpx_eval_row: j = %d; column number out of range\n",
+ j);
+ sum += val[k] * glp_get_col_prim(lp, j);
+ }
+ return sum;
+}
+
+/***********************************************************************
+* NAME
+*
+* ios_cov_gen - generate mixed cover cuts
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_cov_gen(glp_tree *tree);
+*
+* DESCRIPTION
+*
+* The routine ios_cov_gen generates mixed cover cuts for the current
+* point and adds them to the cut pool. */
+
+void ios_cov_gen(glp_tree *tree)
+{ glp_prob *prob = tree->mip;
+ int m = glp_get_num_rows(prob);
+ int n = glp_get_num_cols(prob);
+ int i, k, type, kase, len, *ind;
+ double r, *val, *work;
+ xassert(glp_get_status(prob) == GLP_OPT);
+ /* allocate working arrays */
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ work = xcalloc(1+n, sizeof(double));
+ /* look through all rows */
+ for (i = 1; i <= m; i++)
+ for (kase = 1; kase <= 2; kase++)
+ { type = glp_get_row_type(prob, i);
+ if (kase == 1)
+ { /* consider rows of '<=' type */
+ if (!(type == GLP_UP || type == GLP_DB)) continue;
+ len = glp_get_mat_row(prob, i, ind, val);
+ val[0] = glp_get_row_ub(prob, i);
+ }
+ else
+ { /* consider rows of '>=' type */
+ if (!(type == GLP_LO || type == GLP_DB)) continue;
+ len = glp_get_mat_row(prob, i, ind, val);
+ for (k = 1; k <= len; k++) val[k] = - val[k];
+ val[0] = - glp_get_row_lb(prob, i);
+ }
+ /* generate mixed cover cut:
+ sum{j in J} a[j] * x[j] <= b */
+ len = lpx_cover_cut(prob, len, ind, val, work);
+ if (len == 0) continue;
+ /* at the current point the cut inequality is violated, i.e.
+ sum{j in J} a[j] * x[j] - b > 0 */
+ r = lpx_eval_row(prob, len, ind, val) - val[0];
+ if (r < 1e-3) continue;
+ /* add the cut to the cut pool */
+ glp_ios_add_row(tree, NULL, GLP_RF_COV, 0, len, ind, val,
+ GLP_UP, val[0]);
+ }
+ /* free working arrays */
+ xfree(ind);
+ xfree(val);
+ xfree(work);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios09.c b/test/monniaux/glpk-4.65/src/draft/glpios09.c
new file mode 100644
index 00000000..d80ed9a3
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios09.c
@@ -0,0 +1,664 @@
+/* glpios09.c (branching heuristics) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* NAME
+*
+* ios_choose_var - select variable to branch on
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_choose_var(glp_tree *T, int *next);
+*
+* The routine ios_choose_var chooses a variable from the candidate
+* list to branch on. Additionally the routine provides a flag stored
+* in the location next to suggests which of the child subproblems
+* should be solved next.
+*
+* RETURNS
+*
+* The routine ios_choose_var returns the ordinal number of the column
+* choosen. */
+
+static int branch_first(glp_tree *T, int *next);
+static int branch_last(glp_tree *T, int *next);
+static int branch_mostf(glp_tree *T, int *next);
+static int branch_drtom(glp_tree *T, int *next);
+
+int ios_choose_var(glp_tree *T, int *next)
+{ int j;
+ if (T->parm->br_tech == GLP_BR_FFV)
+ { /* branch on first fractional variable */
+ j = branch_first(T, next);
+ }
+ else if (T->parm->br_tech == GLP_BR_LFV)
+ { /* branch on last fractional variable */
+ j = branch_last(T, next);
+ }
+ else if (T->parm->br_tech == GLP_BR_MFV)
+ { /* branch on most fractional variable */
+ j = branch_mostf(T, next);
+ }
+ else if (T->parm->br_tech == GLP_BR_DTH)
+ { /* branch using the heuristic by Dreebeck and Tomlin */
+ j = branch_drtom(T, next);
+ }
+ else if (T->parm->br_tech == GLP_BR_PCH)
+ { /* hybrid pseudocost heuristic */
+ j = ios_pcost_branch(T, next);
+ }
+ else
+ xassert(T != T);
+ return j;
+}
+
+/***********************************************************************
+* branch_first - choose first branching variable
+*
+* This routine looks up the list of structural variables and chooses
+* the first one, which is of integer kind and has fractional value in
+* optimal solution to the current LP relaxation.
+*
+* This routine also selects the branch to be solved next where integer
+* infeasibility of the chosen variable is less than in other one. */
+
+static int branch_first(glp_tree *T, int *_next)
+{ int j, next;
+ double beta;
+ /* choose the column to branch on */
+ for (j = 1; j <= T->n; j++)
+ if (T->non_int[j]) break;
+ xassert(1 <= j && j <= T->n);
+ /* select the branch to be solved next */
+ beta = glp_get_col_prim(T->mip, j);
+ if (beta - floor(beta) < ceil(beta) - beta)
+ next = GLP_DN_BRNCH;
+ else
+ next = GLP_UP_BRNCH;
+ *_next = next;
+ return j;
+}
+
+/***********************************************************************
+* branch_last - choose last branching variable
+*
+* This routine looks up the list of structural variables and chooses
+* the last one, which is of integer kind and has fractional value in
+* optimal solution to the current LP relaxation.
+*
+* This routine also selects the branch to be solved next where integer
+* infeasibility of the chosen variable is less than in other one. */
+
+static int branch_last(glp_tree *T, int *_next)
+{ int j, next;
+ double beta;
+ /* choose the column to branch on */
+ for (j = T->n; j >= 1; j--)
+ if (T->non_int[j]) break;
+ xassert(1 <= j && j <= T->n);
+ /* select the branch to be solved next */
+ beta = glp_get_col_prim(T->mip, j);
+ if (beta - floor(beta) < ceil(beta) - beta)
+ next = GLP_DN_BRNCH;
+ else
+ next = GLP_UP_BRNCH;
+ *_next = next;
+ return j;
+}
+
+/***********************************************************************
+* branch_mostf - choose most fractional branching variable
+*
+* This routine looks up the list of structural variables and chooses
+* that one, which is of integer kind and has most fractional value in
+* optimal solution to the current LP relaxation.
+*
+* This routine also selects the branch to be solved next where integer
+* infeasibility of the chosen variable is less than in other one.
+*
+* (Alexander Martin notices that "...most infeasible is as good as
+* random...".) */
+
+static int branch_mostf(glp_tree *T, int *_next)
+{ int j, jj, next;
+ double beta, most, temp;
+ /* choose the column to branch on */
+ jj = 0, most = DBL_MAX;
+ for (j = 1; j <= T->n; j++)
+ { if (T->non_int[j])
+ { beta = glp_get_col_prim(T->mip, j);
+ temp = floor(beta) + 0.5;
+ if (most > fabs(beta - temp))
+ { jj = j, most = fabs(beta - temp);
+ if (beta < temp)
+ next = GLP_DN_BRNCH;
+ else
+ next = GLP_UP_BRNCH;
+ }
+ }
+ }
+ *_next = next;
+ return jj;
+}
+
+/***********************************************************************
+* branch_drtom - choose branching var using Driebeck-Tomlin heuristic
+*
+* This routine chooses a structural variable, which is required to be
+* integral and has fractional value in optimal solution of the current
+* LP relaxation, using a heuristic proposed by Driebeck and Tomlin.
+*
+* The routine also selects the branch to be solved next, again due to
+* Driebeck and Tomlin.
+*
+* This routine is based on the heuristic proposed in:
+*
+* Driebeck N.J. An algorithm for the solution of mixed-integer
+* programming problems, Management Science, 12: 576-87 (1966);
+*
+* and improved in:
+*
+* Tomlin J.A. Branch and bound methods for integer and non-convex
+* programming, in J.Abadie (ed.), Integer and Nonlinear Programming,
+* North-Holland, Amsterdam, pp. 437-50 (1970).
+*
+* Must note that this heuristic is time-expensive, because computing
+* one-step degradation (see the routine below) requires one BTRAN for
+* each fractional-valued structural variable. */
+
+static int branch_drtom(glp_tree *T, int *_next)
+{ glp_prob *mip = T->mip;
+ int m = mip->m;
+ int n = mip->n;
+ unsigned char *non_int = T->non_int;
+ int j, jj, k, t, next, kase, len, stat, *ind;
+ double x, dk, alfa, delta_j, delta_k, delta_z, dz_dn, dz_up,
+ dd_dn, dd_up, degrad, *val;
+ /* basic solution of LP relaxation must be optimal */
+ xassert(glp_get_status(mip) == GLP_OPT);
+ /* allocate working arrays */
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ /* nothing has been chosen so far */
+ jj = 0, degrad = -1.0;
+ /* walk through the list of columns (structural variables) */
+ for (j = 1; j <= n; j++)
+ { /* if j-th column is not marked as fractional, skip it */
+ if (!non_int[j]) continue;
+ /* obtain (fractional) value of j-th column in basic solution
+ of LP relaxation */
+ x = glp_get_col_prim(mip, j);
+ /* since the value of j-th column is fractional, the column is
+ basic; compute corresponding row of the simplex table */
+ len = glp_eval_tab_row(mip, m+j, ind, val);
+ /* the following fragment computes a change in the objective
+ function: delta Z = new Z - old Z, where old Z is the
+ objective value in the current optimal basis, and new Z is
+ the objective value in the adjacent basis, for two cases:
+ 1) if new upper bound ub' = floor(x[j]) is introduced for
+ j-th column (down branch);
+ 2) if new lower bound lb' = ceil(x[j]) is introduced for
+ j-th column (up branch);
+ since in both cases the solution remaining dual feasible
+ becomes primal infeasible, one implicit simplex iteration
+ is performed to determine the change delta Z;
+ it is obvious that new Z, which is never better than old Z,
+ is a lower (minimization) or upper (maximization) bound of
+ the objective function for down- and up-branches. */
+ for (kase = -1; kase <= +1; kase += 2)
+ { /* if kase < 0, the new upper bound of x[j] is introduced;
+ in this case x[j] should decrease in order to leave the
+ basis and go to its new upper bound */
+ /* if kase > 0, the new lower bound of x[j] is introduced;
+ in this case x[j] should increase in order to leave the
+ basis and go to its new lower bound */
+ /* apply the dual ratio test in order to determine which
+ auxiliary or structural variable should enter the basis
+ to keep dual feasibility */
+ k = glp_dual_rtest(mip, len, ind, val, kase, 1e-9);
+ if (k != 0) k = ind[k];
+ /* if no non-basic variable has been chosen, LP relaxation
+ of corresponding branch being primal infeasible and dual
+ unbounded has no primal feasible solution; in this case
+ the change delta Z is formally set to infinity */
+ if (k == 0)
+ { delta_z =
+ (T->mip->dir == GLP_MIN ? +DBL_MAX : -DBL_MAX);
+ goto skip;
+ }
+ /* row of the simplex table that corresponds to non-basic
+ variable x[k] choosen by the dual ratio test is:
+ x[j] = ... + alfa * x[k] + ...
+ where alfa is the influence coefficient (an element of
+ the simplex table row) */
+ /* determine the coefficient alfa */
+ for (t = 1; t <= len; t++) if (ind[t] == k) break;
+ xassert(1 <= t && t <= len);
+ alfa = val[t];
+ /* since in the adjacent basis the variable x[j] becomes
+ non-basic, knowing its value in the current basis we can
+ determine its change delta x[j] = new x[j] - old x[j] */
+ delta_j = (kase < 0 ? floor(x) : ceil(x)) - x;
+ /* and knowing the coefficient alfa we can determine the
+ corresponding change delta x[k] = new x[k] - old x[k],
+ where old x[k] is a value of x[k] in the current basis,
+ and new x[k] is a value of x[k] in the adjacent basis */
+ delta_k = delta_j / alfa;
+ /* Tomlin noticed that if the variable x[k] is of integer
+ kind, its change cannot be less (eventually) than one in
+ the magnitude */
+ if (k > m && glp_get_col_kind(mip, k-m) != GLP_CV)
+ { /* x[k] is structural integer variable */
+ if (fabs(delta_k - floor(delta_k + 0.5)) > 1e-3)
+ { if (delta_k > 0.0)
+ delta_k = ceil(delta_k); /* +3.14 -> +4 */
+ else
+ delta_k = floor(delta_k); /* -3.14 -> -4 */
+ }
+ }
+ /* now determine the status and reduced cost of x[k] in the
+ current basis */
+ if (k <= m)
+ { stat = glp_get_row_stat(mip, k);
+ dk = glp_get_row_dual(mip, k);
+ }
+ else
+ { stat = glp_get_col_stat(mip, k-m);
+ dk = glp_get_col_dual(mip, k-m);
+ }
+ /* if the current basis is dual degenerate, some reduced
+ costs which are close to zero may have wrong sign due to
+ round-off errors, so correct the sign of d[k] */
+ switch (T->mip->dir)
+ { case GLP_MIN:
+ if (stat == GLP_NL && dk < 0.0 ||
+ stat == GLP_NU && dk > 0.0 ||
+ stat == GLP_NF) dk = 0.0;
+ break;
+ case GLP_MAX:
+ if (stat == GLP_NL && dk > 0.0 ||
+ stat == GLP_NU && dk < 0.0 ||
+ stat == GLP_NF) dk = 0.0;
+ break;
+ default:
+ xassert(T != T);
+ }
+ /* now knowing the change of x[k] and its reduced cost d[k]
+ we can compute the corresponding change in the objective
+ function delta Z = new Z - old Z = d[k] * delta x[k];
+ note that due to Tomlin's modification new Z can be even
+ worse than in the adjacent basis */
+ delta_z = dk * delta_k;
+skip: /* new Z is never better than old Z, therefore the change
+ delta Z is always non-negative (in case of minimization)
+ or non-positive (in case of maximization) */
+ switch (T->mip->dir)
+ { case GLP_MIN: xassert(delta_z >= 0.0); break;
+ case GLP_MAX: xassert(delta_z <= 0.0); break;
+ default: xassert(T != T);
+ }
+ /* save the change in the objective fnction for down- and
+ up-branches, respectively */
+ if (kase < 0) dz_dn = delta_z; else dz_up = delta_z;
+ }
+ /* thus, in down-branch no integer feasible solution can be
+ better than Z + dz_dn, and in up-branch no integer feasible
+ solution can be better than Z + dz_up, where Z is value of
+ the objective function in the current basis */
+ /* following the heuristic by Driebeck and Tomlin we choose a
+ column (i.e. structural variable) which provides largest
+ degradation of the objective function in some of branches;
+ besides, we select the branch with smaller degradation to
+ be solved next and keep other branch with larger degradation
+ in the active list hoping to minimize the number of further
+ backtrackings */
+ if (degrad < fabs(dz_dn) || degrad < fabs(dz_up))
+ { jj = j;
+ if (fabs(dz_dn) < fabs(dz_up))
+ { /* select down branch to be solved next */
+ next = GLP_DN_BRNCH;
+ degrad = fabs(dz_up);
+ }
+ else
+ { /* select up branch to be solved next */
+ next = GLP_UP_BRNCH;
+ degrad = fabs(dz_dn);
+ }
+ /* save the objective changes for printing */
+ dd_dn = dz_dn, dd_up = dz_up;
+ /* if down- or up-branch has no feasible solution, we does
+ not need to consider other candidates (in principle, the
+ corresponding branch could be pruned right now) */
+ if (degrad == DBL_MAX) break;
+ }
+ }
+ /* free working arrays */
+ xfree(ind);
+ xfree(val);
+ /* something must be chosen */
+ xassert(1 <= jj && jj <= n);
+#if 1 /* 02/XI-2009 */
+ if (degrad < 1e-6 * (1.0 + 0.001 * fabs(mip->obj_val)))
+ { jj = branch_mostf(T, &next);
+ goto done;
+ }
+#endif
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ { xprintf("branch_drtom: column %d chosen to branch on\n", jj);
+ if (fabs(dd_dn) == DBL_MAX)
+ xprintf("branch_drtom: down-branch is infeasible\n");
+ else
+ xprintf("branch_drtom: down-branch bound is %.9e\n",
+ glp_get_obj_val(mip) + dd_dn);
+ if (fabs(dd_up) == DBL_MAX)
+ xprintf("branch_drtom: up-branch is infeasible\n");
+ else
+ xprintf("branch_drtom: up-branch bound is %.9e\n",
+ glp_get_obj_val(mip) + dd_up);
+ }
+done: *_next = next;
+ return jj;
+}
+
+/**********************************************************************/
+
+struct csa
+{ /* common storage area */
+ int *dn_cnt; /* int dn_cnt[1+n]; */
+ /* dn_cnt[j] is the number of subproblems, whose LP relaxations
+ have been solved and which are down-branches for variable x[j];
+ dn_cnt[j] = 0 means the down pseudocost is uninitialized */
+ double *dn_sum; /* double dn_sum[1+n]; */
+ /* dn_sum[j] is the sum of per unit degradations of the objective
+ over all dn_cnt[j] subproblems */
+ int *up_cnt; /* int up_cnt[1+n]; */
+ /* up_cnt[j] is the number of subproblems, whose LP relaxations
+ have been solved and which are up-branches for variable x[j];
+ up_cnt[j] = 0 means the up pseudocost is uninitialized */
+ double *up_sum; /* double up_sum[1+n]; */
+ /* up_sum[j] is the sum of per unit degradations of the objective
+ over all up_cnt[j] subproblems */
+};
+
+void *ios_pcost_init(glp_tree *tree)
+{ /* initialize working data used on pseudocost branching */
+ struct csa *csa;
+ int n = tree->n, j;
+ csa = xmalloc(sizeof(struct csa));
+ csa->dn_cnt = xcalloc(1+n, sizeof(int));
+ csa->dn_sum = xcalloc(1+n, sizeof(double));
+ csa->up_cnt = xcalloc(1+n, sizeof(int));
+ csa->up_sum = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++)
+ { csa->dn_cnt[j] = csa->up_cnt[j] = 0;
+ csa->dn_sum[j] = csa->up_sum[j] = 0.0;
+ }
+ return csa;
+}
+
+static double eval_degrad(glp_prob *P, int j, double bnd)
+{ /* compute degradation of the objective on fixing x[j] at given
+ value with a limited number of dual simplex iterations */
+ /* this routine fixes column x[j] at specified value bnd,
+ solves resulting LP, and returns a lower bound to degradation
+ of the objective, degrad >= 0 */
+ glp_prob *lp;
+ glp_smcp parm;
+ int ret;
+ double degrad;
+ /* the current basis must be optimal */
+ xassert(glp_get_status(P) == GLP_OPT);
+ /* create a copy of P */
+ lp = glp_create_prob();
+ glp_copy_prob(lp, P, 0);
+ /* fix column x[j] at specified value */
+ glp_set_col_bnds(lp, j, GLP_FX, bnd, bnd);
+ /* try to solve resulting LP */
+ glp_init_smcp(&parm);
+ parm.msg_lev = GLP_MSG_OFF;
+ parm.meth = GLP_DUAL;
+ parm.it_lim = 30;
+ parm.out_dly = 1000;
+ parm.meth = GLP_DUAL;
+ ret = glp_simplex(lp, &parm);
+ if (ret == 0 || ret == GLP_EITLIM)
+ { if (glp_get_prim_stat(lp) == GLP_NOFEAS)
+ { /* resulting LP has no primal feasible solution */
+ degrad = DBL_MAX;
+ }
+ else if (glp_get_dual_stat(lp) == GLP_FEAS)
+ { /* resulting basis is optimal or at least dual feasible,
+ so we have the correct lower bound to degradation */
+ if (P->dir == GLP_MIN)
+ degrad = lp->obj_val - P->obj_val;
+ else if (P->dir == GLP_MAX)
+ degrad = P->obj_val - lp->obj_val;
+ else
+ xassert(P != P);
+ /* degradation cannot be negative by definition */
+ /* note that the lower bound to degradation may be close
+ to zero even if its exact value is zero due to round-off
+ errors on computing the objective value */
+ if (degrad < 1e-6 * (1.0 + 0.001 * fabs(P->obj_val)))
+ degrad = 0.0;
+ }
+ else
+ { /* the final basis reported by the simplex solver is dual
+ infeasible, so we cannot determine a non-trivial lower
+ bound to degradation */
+ degrad = 0.0;
+ }
+ }
+ else
+ { /* the simplex solver failed */
+ degrad = 0.0;
+ }
+ /* delete the copy of P */
+ glp_delete_prob(lp);
+ return degrad;
+}
+
+void ios_pcost_update(glp_tree *tree)
+{ /* update history information for pseudocost branching */
+ /* this routine is called every time when LP relaxation of the
+ current subproblem has been solved to optimality with all lazy
+ and cutting plane constraints included */
+ int j;
+ double dx, dz, psi;
+ struct csa *csa = tree->pcost;
+ xassert(csa != NULL);
+ xassert(tree->curr != NULL);
+ /* if the current subproblem is the root, skip updating */
+ if (tree->curr->up == NULL) goto skip;
+ /* determine branching variable x[j], which was used in the
+ parent subproblem to create the current subproblem */
+ j = tree->curr->up->br_var;
+ xassert(1 <= j && j <= tree->n);
+ /* determine the change dx[j] = new x[j] - old x[j],
+ where new x[j] is a value of x[j] in optimal solution to LP
+ relaxation of the current subproblem, old x[j] is a value of
+ x[j] in optimal solution to LP relaxation of the parent
+ subproblem */
+ dx = tree->mip->col[j]->prim - tree->curr->up->br_val;
+ xassert(dx != 0.0);
+ /* determine corresponding change dz = new dz - old dz in the
+ objective function value */
+ dz = tree->mip->obj_val - tree->curr->up->lp_obj;
+ /* determine per unit degradation of the objective function */
+ psi = fabs(dz / dx);
+ /* update history information */
+ if (dx < 0.0)
+ { /* the current subproblem is down-branch */
+ csa->dn_cnt[j]++;
+ csa->dn_sum[j] += psi;
+ }
+ else /* dx > 0.0 */
+ { /* the current subproblem is up-branch */
+ csa->up_cnt[j]++;
+ csa->up_sum[j] += psi;
+ }
+skip: return;
+}
+
+void ios_pcost_free(glp_tree *tree)
+{ /* free working area used on pseudocost branching */
+ struct csa *csa = tree->pcost;
+ xassert(csa != NULL);
+ xfree(csa->dn_cnt);
+ xfree(csa->dn_sum);
+ xfree(csa->up_cnt);
+ xfree(csa->up_sum);
+ xfree(csa);
+ tree->pcost = NULL;
+ return;
+}
+
+static double eval_psi(glp_tree *T, int j, int brnch)
+{ /* compute estimation of pseudocost of variable x[j] for down-
+ or up-branch */
+ struct csa *csa = T->pcost;
+ double beta, degrad, psi;
+ xassert(csa != NULL);
+ xassert(1 <= j && j <= T->n);
+ if (brnch == GLP_DN_BRNCH)
+ { /* down-branch */
+ if (csa->dn_cnt[j] == 0)
+ { /* initialize down pseudocost */
+ beta = T->mip->col[j]->prim;
+ degrad = eval_degrad(T->mip, j, floor(beta));
+ if (degrad == DBL_MAX)
+ { psi = DBL_MAX;
+ goto done;
+ }
+ csa->dn_cnt[j] = 1;
+ csa->dn_sum[j] = degrad / (beta - floor(beta));
+ }
+ psi = csa->dn_sum[j] / (double)csa->dn_cnt[j];
+ }
+ else if (brnch == GLP_UP_BRNCH)
+ { /* up-branch */
+ if (csa->up_cnt[j] == 0)
+ { /* initialize up pseudocost */
+ beta = T->mip->col[j]->prim;
+ degrad = eval_degrad(T->mip, j, ceil(beta));
+ if (degrad == DBL_MAX)
+ { psi = DBL_MAX;
+ goto done;
+ }
+ csa->up_cnt[j] = 1;
+ csa->up_sum[j] = degrad / (ceil(beta) - beta);
+ }
+ psi = csa->up_sum[j] / (double)csa->up_cnt[j];
+ }
+ else
+ xassert(brnch != brnch);
+done: return psi;
+}
+
+static void progress(glp_tree *T)
+{ /* display progress of pseudocost initialization */
+ struct csa *csa = T->pcost;
+ int j, nv = 0, ni = 0;
+ for (j = 1; j <= T->n; j++)
+ { if (glp_ios_can_branch(T, j))
+ { nv++;
+ if (csa->dn_cnt[j] > 0 && csa->up_cnt[j] > 0) ni++;
+ }
+ }
+ xprintf("Pseudocosts initialized for %d of %d variables\n",
+ ni, nv);
+ return;
+}
+
+int ios_pcost_branch(glp_tree *T, int *_next)
+{ /* choose branching variable with pseudocost branching */
+#if 0 /* 10/VI-2013 */
+ glp_long t = xtime();
+#else
+ double t = xtime();
+#endif
+ int j, jjj, sel;
+ double beta, psi, d1, d2, d, dmax;
+ /* initialize the working arrays */
+ if (T->pcost == NULL)
+ T->pcost = ios_pcost_init(T);
+ /* nothing has been chosen so far */
+ jjj = 0, dmax = -1.0;
+ /* go through the list of branching candidates */
+ for (j = 1; j <= T->n; j++)
+ { if (!glp_ios_can_branch(T, j)) continue;
+ /* determine primal value of x[j] in optimal solution to LP
+ relaxation of the current subproblem */
+ beta = T->mip->col[j]->prim;
+ /* estimate pseudocost of x[j] for down-branch */
+ psi = eval_psi(T, j, GLP_DN_BRNCH);
+ if (psi == DBL_MAX)
+ { /* down-branch has no primal feasible solution */
+ jjj = j, sel = GLP_DN_BRNCH;
+ goto done;
+ }
+ /* estimate degradation of the objective for down-branch */
+ d1 = psi * (beta - floor(beta));
+ /* estimate pseudocost of x[j] for up-branch */
+ psi = eval_psi(T, j, GLP_UP_BRNCH);
+ if (psi == DBL_MAX)
+ { /* up-branch has no primal feasible solution */
+ jjj = j, sel = GLP_UP_BRNCH;
+ goto done;
+ }
+ /* estimate degradation of the objective for up-branch */
+ d2 = psi * (ceil(beta) - beta);
+ /* determine d = max(d1, d2) */
+ d = (d1 > d2 ? d1 : d2);
+ /* choose x[j] which provides maximal estimated degradation of
+ the objective either in down- or up-branch */
+ if (dmax < d)
+ { dmax = d;
+ jjj = j;
+ /* continue the search from a subproblem, where degradation
+ is less than in other one */
+ sel = (d1 <= d2 ? GLP_DN_BRNCH : GLP_UP_BRNCH);
+ }
+ /* display progress of pseudocost initialization */
+ if (T->parm->msg_lev >= GLP_ON)
+ { if (xdifftime(xtime(), t) >= 10.0)
+ { progress(T);
+ t = xtime();
+ }
+ }
+ }
+ if (dmax == 0.0)
+ { /* no degradation is indicated; choose a variable having most
+ fractional value */
+ jjj = branch_mostf(T, &sel);
+ }
+done: *_next = sel;
+ return jjj;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios11.c b/test/monniaux/glpk-4.65/src/draft/glpios11.c
new file mode 100644
index 00000000..09fccef6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios11.c
@@ -0,0 +1,435 @@
+/* glpios11.c (process cuts stored in the local cut pool) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017, 2018 Andrew Makhorin, Department for
+* Applied Informatics, Moscow Aviation Institute, Moscow, Russia. All
+* rights reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "draft.h"
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* NAME
+*
+* ios_process_cuts - process cuts stored in the local cut pool
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_process_cuts(glp_tree *T);
+*
+* DESCRIPTION
+*
+* The routine ios_process_cuts analyzes each cut currently stored in
+* the local cut pool, which must be non-empty, and either adds the cut
+* to the current subproblem or just discards it. All cuts are assumed
+* to be locally valid. On exit the local cut pool remains unchanged.
+*
+* REFERENCES
+*
+* 1. E.Balas, S.Ceria, G.Cornuejols, "Mixed 0-1 Programming by
+* Lift-and-Project in a Branch-and-Cut Framework", Management Sc.,
+* 42 (1996) 1229-1246.
+*
+* 2. G.Andreello, A.Caprara, and M.Fischetti, "Embedding Cuts in
+* a Branch&Cut Framework: a Computational Study with {0,1/2}-Cuts",
+* Preliminary Draft, October 28, 2003, pp.6-8. */
+
+struct info
+{ /* estimated cut efficiency */
+ IOSCUT *cut;
+ /* pointer to cut in the cut pool */
+ char flag;
+ /* if this flag is set, the cut is included into the current
+ subproblem */
+ double eff;
+ /* cut efficacy (normalized residual) */
+ double deg;
+ /* lower bound to objective degradation */
+};
+
+static int CDECL fcmp(const void *arg1, const void *arg2)
+{ const struct info *info1 = arg1, *info2 = arg2;
+ if (info1->deg == 0.0 && info2->deg == 0.0)
+ { if (info1->eff > info2->eff) return -1;
+ if (info1->eff < info2->eff) return +1;
+ }
+ else
+ { if (info1->deg > info2->deg) return -1;
+ if (info1->deg < info2->deg) return +1;
+ }
+ return 0;
+}
+
+static double parallel(IOSCUT *a, IOSCUT *b, double work[]);
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+void ios_process_cuts(glp_tree *T)
+{ IOSPOOL *pool;
+ IOSCUT *cut;
+ GLPAIJ *aij;
+ struct info *info;
+ int k, kk, max_cuts, len, ret, *ind;
+ double *val, *work, rhs;
+ /* the current subproblem must exist */
+ xassert(T->curr != NULL);
+ /* the pool must exist and be non-empty */
+ pool = T->local;
+ xassert(pool != NULL);
+ xassert(pool->m > 0);
+ /* allocate working arrays */
+ info = xcalloc(1+pool->m, sizeof(struct info));
+ ind = xcalloc(1+T->n, sizeof(int));
+ val = xcalloc(1+T->n, sizeof(double));
+ work = xcalloc(1+T->n, sizeof(double));
+ for (k = 1; k <= T->n; k++) work[k] = 0.0;
+ /* build the list of cuts stored in the cut pool */
+ for (k = 1; k <= pool->m; k++)
+ info[k].cut = pool->row[k], info[k].flag = 0;
+ /* estimate efficiency of all cuts in the cut pool */
+ for (k = 1; k <= pool->m; k++)
+ { double temp, dy, dz;
+ cut = info[k].cut;
+ /* build the vector of cut coefficients and compute its
+ Euclidean norm */
+ len = 0; temp = 0.0;
+ for (aij = cut->ptr; aij != NULL; aij = aij->r_next)
+ { xassert(1 <= aij->col->j && aij->col->j <= T->n);
+ len++, ind[len] = aij->col->j, val[len] = aij->val;
+ temp += aij->val * aij->val;
+ }
+ if (temp < DBL_EPSILON * DBL_EPSILON) temp = DBL_EPSILON;
+ /* transform the cut to express it only through non-basic
+ (auxiliary and structural) variables */
+ len = glp_transform_row(T->mip, len, ind, val);
+ /* determine change in the cut value and in the objective
+ value for the adjacent basis by simulating one step of the
+ dual simplex */
+ switch (cut->type)
+ { case GLP_LO: rhs = cut->lb; break;
+ case GLP_UP: rhs = cut->ub; break;
+ default: xassert(cut != cut);
+ }
+ ret = _glp_analyze_row(T->mip, len, ind, val, cut->type,
+ rhs, 1e-9, NULL, NULL, NULL, NULL, &dy, &dz);
+ /* determine normalized residual and lower bound to objective
+ degradation */
+ if (ret == 0)
+ { info[k].eff = fabs(dy) / sqrt(temp);
+ /* if some reduced costs violates (slightly) their zero
+ bounds (i.e. have wrong signs) due to round-off errors,
+ dz also may have wrong sign being close to zero */
+ if (T->mip->dir == GLP_MIN)
+ { if (dz < 0.0) dz = 0.0;
+ info[k].deg = + dz;
+ }
+ else /* GLP_MAX */
+ { if (dz > 0.0) dz = 0.0;
+ info[k].deg = - dz;
+ }
+ }
+ else if (ret == 1)
+ { /* the constraint is not violated at the current point */
+ info[k].eff = info[k].deg = 0.0;
+ }
+ else if (ret == 2)
+ { /* no dual feasible adjacent basis exists */
+ info[k].eff = 1.0;
+ info[k].deg = DBL_MAX;
+ }
+ else
+ xassert(ret != ret);
+ /* if the degradation is too small, just ignore it */
+ if (info[k].deg < 0.01) info[k].deg = 0.0;
+ }
+ /* sort the list of cuts by decreasing objective degradation and
+ then by decreasing efficacy */
+ qsort(&info[1], pool->m, sizeof(struct info), fcmp);
+ /* only first (most efficient) max_cuts in the list are qualified
+ as candidates to be added to the current subproblem */
+ max_cuts = (T->curr->level == 0 ? 90 : 10);
+ if (max_cuts > pool->m) max_cuts = pool->m;
+ /* add cuts to the current subproblem */
+#if 0
+ xprintf("*** adding cuts ***\n");
+#endif
+ for (k = 1; k <= max_cuts; k++)
+ { int i, len;
+ /* if this cut seems to be inefficient, skip it */
+ if (info[k].deg < 0.01 && info[k].eff < 0.01) continue;
+ /* if the angle between this cut and every other cut included
+ in the current subproblem is small, skip this cut */
+ for (kk = 1; kk < k; kk++)
+ { if (info[kk].flag)
+ { if (parallel(info[k].cut, info[kk].cut, work) > 0.90)
+ break;
+ }
+ }
+ if (kk < k) continue;
+ /* add this cut to the current subproblem */
+#if 0
+ xprintf("eff = %g; deg = %g\n", info[k].eff, info[k].deg);
+#endif
+ cut = info[k].cut, info[k].flag = 1;
+ i = glp_add_rows(T->mip, 1);
+ if (cut->name != NULL)
+ glp_set_row_name(T->mip, i, cut->name);
+ xassert(T->mip->row[i]->origin == GLP_RF_CUT);
+ T->mip->row[i]->klass = cut->klass;
+ len = 0;
+ for (aij = cut->ptr; aij != NULL; aij = aij->r_next)
+ len++, ind[len] = aij->col->j, val[len] = aij->val;
+ glp_set_mat_row(T->mip, i, len, ind, val);
+ switch (cut->type)
+ { case GLP_LO: rhs = cut->lb; break;
+ case GLP_UP: rhs = cut->ub; break;
+ default: xassert(cut != cut);
+ }
+ glp_set_row_bnds(T->mip, i, cut->type, rhs, rhs);
+ }
+ /* free working arrays */
+ xfree(info);
+ xfree(ind);
+ xfree(val);
+ xfree(work);
+ return;
+}
+#else
+void ios_process_cuts(glp_tree *T)
+{ IOSPOOL *pool;
+ IOSCUT *cut;
+ IOSAIJ *aij;
+ struct info *info;
+ int k, kk, max_cuts, len, ret, *ind;
+ double *val, *work;
+ /* the current subproblem must exist */
+ xassert(T->curr != NULL);
+ /* the pool must exist and be non-empty */
+ pool = T->local;
+ xassert(pool != NULL);
+ xassert(pool->size > 0);
+ /* allocate working arrays */
+ info = xcalloc(1+pool->size, sizeof(struct info));
+ ind = xcalloc(1+T->n, sizeof(int));
+ val = xcalloc(1+T->n, sizeof(double));
+ work = xcalloc(1+T->n, sizeof(double));
+ for (k = 1; k <= T->n; k++) work[k] = 0.0;
+ /* build the list of cuts stored in the cut pool */
+ for (k = 0, cut = pool->head; cut != NULL; cut = cut->next)
+ k++, info[k].cut = cut, info[k].flag = 0;
+ xassert(k == pool->size);
+ /* estimate efficiency of all cuts in the cut pool */
+ for (k = 1; k <= pool->size; k++)
+ { double temp, dy, dz;
+ cut = info[k].cut;
+ /* build the vector of cut coefficients and compute its
+ Euclidean norm */
+ len = 0; temp = 0.0;
+ for (aij = cut->ptr; aij != NULL; aij = aij->next)
+ { xassert(1 <= aij->j && aij->j <= T->n);
+ len++, ind[len] = aij->j, val[len] = aij->val;
+ temp += aij->val * aij->val;
+ }
+ if (temp < DBL_EPSILON * DBL_EPSILON) temp = DBL_EPSILON;
+ /* transform the cut to express it only through non-basic
+ (auxiliary and structural) variables */
+ len = glp_transform_row(T->mip, len, ind, val);
+ /* determine change in the cut value and in the objective
+ value for the adjacent basis by simulating one step of the
+ dual simplex */
+ ret = _glp_analyze_row(T->mip, len, ind, val, cut->type,
+ cut->rhs, 1e-9, NULL, NULL, NULL, NULL, &dy, &dz);
+ /* determine normalized residual and lower bound to objective
+ degradation */
+ if (ret == 0)
+ { info[k].eff = fabs(dy) / sqrt(temp);
+ /* if some reduced costs violates (slightly) their zero
+ bounds (i.e. have wrong signs) due to round-off errors,
+ dz also may have wrong sign being close to zero */
+ if (T->mip->dir == GLP_MIN)
+ { if (dz < 0.0) dz = 0.0;
+ info[k].deg = + dz;
+ }
+ else /* GLP_MAX */
+ { if (dz > 0.0) dz = 0.0;
+ info[k].deg = - dz;
+ }
+ }
+ else if (ret == 1)
+ { /* the constraint is not violated at the current point */
+ info[k].eff = info[k].deg = 0.0;
+ }
+ else if (ret == 2)
+ { /* no dual feasible adjacent basis exists */
+ info[k].eff = 1.0;
+ info[k].deg = DBL_MAX;
+ }
+ else
+ xassert(ret != ret);
+ /* if the degradation is too small, just ignore it */
+ if (info[k].deg < 0.01) info[k].deg = 0.0;
+ }
+ /* sort the list of cuts by decreasing objective degradation and
+ then by decreasing efficacy */
+ qsort(&info[1], pool->size, sizeof(struct info), fcmp);
+ /* only first (most efficient) max_cuts in the list are qualified
+ as candidates to be added to the current subproblem */
+ max_cuts = (T->curr->level == 0 ? 90 : 10);
+ if (max_cuts > pool->size) max_cuts = pool->size;
+ /* add cuts to the current subproblem */
+#if 0
+ xprintf("*** adding cuts ***\n");
+#endif
+ for (k = 1; k <= max_cuts; k++)
+ { int i, len;
+ /* if this cut seems to be inefficient, skip it */
+ if (info[k].deg < 0.01 && info[k].eff < 0.01) continue;
+ /* if the angle between this cut and every other cut included
+ in the current subproblem is small, skip this cut */
+ for (kk = 1; kk < k; kk++)
+ { if (info[kk].flag)
+ { if (parallel(info[k].cut, info[kk].cut, work) > 0.90)
+ break;
+ }
+ }
+ if (kk < k) continue;
+ /* add this cut to the current subproblem */
+#if 0
+ xprintf("eff = %g; deg = %g\n", info[k].eff, info[k].deg);
+#endif
+ cut = info[k].cut, info[k].flag = 1;
+ i = glp_add_rows(T->mip, 1);
+ if (cut->name != NULL)
+ glp_set_row_name(T->mip, i, cut->name);
+ xassert(T->mip->row[i]->origin == GLP_RF_CUT);
+ T->mip->row[i]->klass = cut->klass;
+ len = 0;
+ for (aij = cut->ptr; aij != NULL; aij = aij->next)
+ len++, ind[len] = aij->j, val[len] = aij->val;
+ glp_set_mat_row(T->mip, i, len, ind, val);
+ xassert(cut->type == GLP_LO || cut->type == GLP_UP);
+ glp_set_row_bnds(T->mip, i, cut->type, cut->rhs, cut->rhs);
+ }
+ /* free working arrays */
+ xfree(info);
+ xfree(ind);
+ xfree(val);
+ xfree(work);
+ return;
+}
+#endif
+
+#if 0
+/***********************************************************************
+* Given a cut a * x >= b (<= b) the routine efficacy computes the cut
+* efficacy as follows:
+*
+* eff = d * (a * x~ - b) / ||a||,
+*
+* where d is -1 (in case of '>= b') or +1 (in case of '<= b'), x~ is
+* the vector of values of structural variables in optimal solution to
+* LP relaxation of the current subproblem, ||a|| is the Euclidean norm
+* of the vector of cut coefficients.
+*
+* If the cut is violated at point x~, the efficacy eff is positive,
+* and its value is the Euclidean distance between x~ and the cut plane
+* a * x = b in the space of structural variables.
+*
+* Following geometrical intuition, it is quite natural to consider
+* this distance as a first-order measure of the expected efficacy of
+* the cut: the larger the distance the better the cut [1]. */
+
+static double efficacy(glp_tree *T, IOSCUT *cut)
+{ glp_prob *mip = T->mip;
+ IOSAIJ *aij;
+ double s = 0.0, t = 0.0, temp;
+ for (aij = cut->ptr; aij != NULL; aij = aij->next)
+ { xassert(1 <= aij->j && aij->j <= mip->n);
+ s += aij->val * mip->col[aij->j]->prim;
+ t += aij->val * aij->val;
+ }
+ temp = sqrt(t);
+ if (temp < DBL_EPSILON) temp = DBL_EPSILON;
+ if (cut->type == GLP_LO)
+ temp = (s >= cut->rhs ? 0.0 : (cut->rhs - s) / temp);
+ else if (cut->type == GLP_UP)
+ temp = (s <= cut->rhs ? 0.0 : (s - cut->rhs) / temp);
+ else
+ xassert(cut != cut);
+ return temp;
+}
+#endif
+
+/***********************************************************************
+* Given two cuts a1 * x >= b1 (<= b1) and a2 * x >= b2 (<= b2) the
+* routine parallel computes the cosine of angle between the cut planes
+* a1 * x = b1 and a2 * x = b2 (which is the acute angle between two
+* normals to these planes) in the space of structural variables as
+* follows:
+*
+* cos phi = (a1' * a2) / (||a1|| * ||a2||),
+*
+* where (a1' * a2) is a dot product of vectors of cut coefficients,
+* ||a1|| and ||a2|| are Euclidean norms of vectors a1 and a2.
+*
+* Note that requirement cos phi = 0 forces the cuts to be orthogonal,
+* i.e. with disjoint support, while requirement cos phi <= 0.999 means
+* only avoiding duplicate (parallel) cuts [1]. */
+
+#ifdef NEW_LOCAL /* 02/II-2018 */
+static double parallel(IOSCUT *a, IOSCUT *b, double work[])
+{ GLPAIJ *aij;
+ double s = 0.0, sa = 0.0, sb = 0.0, temp;
+ for (aij = a->ptr; aij != NULL; aij = aij->r_next)
+ { work[aij->col->j] = aij->val;
+ sa += aij->val * aij->val;
+ }
+ for (aij = b->ptr; aij != NULL; aij = aij->r_next)
+ { s += work[aij->col->j] * aij->val;
+ sb += aij->val * aij->val;
+ }
+ for (aij = a->ptr; aij != NULL; aij = aij->r_next)
+ work[aij->col->j] = 0.0;
+ temp = sqrt(sa) * sqrt(sb);
+ if (temp < DBL_EPSILON * DBL_EPSILON) temp = DBL_EPSILON;
+ return s / temp;
+}
+#else
+static double parallel(IOSCUT *a, IOSCUT *b, double work[])
+{ IOSAIJ *aij;
+ double s = 0.0, sa = 0.0, sb = 0.0, temp;
+ for (aij = a->ptr; aij != NULL; aij = aij->next)
+ { work[aij->j] = aij->val;
+ sa += aij->val * aij->val;
+ }
+ for (aij = b->ptr; aij != NULL; aij = aij->next)
+ { s += work[aij->j] * aij->val;
+ sb += aij->val * aij->val;
+ }
+ for (aij = a->ptr; aij != NULL; aij = aij->next)
+ work[aij->j] = 0.0;
+ temp = sqrt(sa) * sqrt(sb);
+ if (temp < DBL_EPSILON * DBL_EPSILON) temp = DBL_EPSILON;
+ return s / temp;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpios12.c b/test/monniaux/glpk-4.65/src/draft/glpios12.c
new file mode 100644
index 00000000..bec6fa2c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpios12.c
@@ -0,0 +1,177 @@
+/* glpios12.c (node selection heuristics) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+
+/***********************************************************************
+* NAME
+*
+* ios_choose_node - select subproblem to continue the search
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* int ios_choose_node(glp_tree *T);
+*
+* DESCRIPTION
+*
+* The routine ios_choose_node selects a subproblem from the active
+* list to continue the search. The choice depends on the backtracking
+* technique option.
+*
+* RETURNS
+*
+* The routine ios_choose_node return the reference number of the
+* subproblem selected. */
+
+static int most_feas(glp_tree *T);
+static int best_proj(glp_tree *T);
+static int best_node(glp_tree *T);
+
+int ios_choose_node(glp_tree *T)
+{ int p;
+ if (T->parm->bt_tech == GLP_BT_DFS)
+ { /* depth first search */
+ xassert(T->tail != NULL);
+ p = T->tail->p;
+ }
+ else if (T->parm->bt_tech == GLP_BT_BFS)
+ { /* breadth first search */
+ xassert(T->head != NULL);
+ p = T->head->p;
+ }
+ else if (T->parm->bt_tech == GLP_BT_BLB)
+ { /* select node with best local bound */
+ p = best_node(T);
+ }
+ else if (T->parm->bt_tech == GLP_BT_BPH)
+ { if (T->mip->mip_stat == GLP_UNDEF)
+ { /* "most integer feasible" subproblem */
+ p = most_feas(T);
+ }
+ else
+ { /* best projection heuristic */
+ p = best_proj(T);
+ }
+ }
+ else
+ xassert(T != T);
+ return p;
+}
+
+static int most_feas(glp_tree *T)
+{ /* select subproblem whose parent has minimal sum of integer
+ infeasibilities */
+ IOSNPD *node;
+ int p;
+ double best;
+ p = 0, best = DBL_MAX;
+ for (node = T->head; node != NULL; node = node->next)
+ { xassert(node->up != NULL);
+ if (best > node->up->ii_sum)
+ p = node->p, best = node->up->ii_sum;
+ }
+ return p;
+}
+
+static int best_proj(glp_tree *T)
+{ /* select subproblem using the best projection heuristic */
+ IOSNPD *root, *node;
+ int p;
+ double best, deg, obj;
+ /* the global bound must exist */
+ xassert(T->mip->mip_stat == GLP_FEAS);
+ /* obtain pointer to the root node, which must exist */
+ root = T->slot[1].node;
+ xassert(root != NULL);
+ /* deg estimates degradation of the objective function per unit
+ of the sum of integer infeasibilities */
+ xassert(root->ii_sum > 0.0);
+ deg = (T->mip->mip_obj - root->bound) / root->ii_sum;
+ /* nothing has been selected so far */
+ p = 0, best = DBL_MAX;
+ /* walk through the list of active subproblems */
+ for (node = T->head; node != NULL; node = node->next)
+ { xassert(node->up != NULL);
+ /* obj estimates optimal objective value if the sum of integer
+ infeasibilities were zero */
+ obj = node->up->bound + deg * node->up->ii_sum;
+ if (T->mip->dir == GLP_MAX) obj = - obj;
+ /* select the subproblem which has the best estimated optimal
+ objective value */
+ if (best > obj) p = node->p, best = obj;
+ }
+ return p;
+}
+
+static int best_node(glp_tree *T)
+{ /* select subproblem with best local bound */
+ IOSNPD *node, *best = NULL;
+ double bound, eps;
+ switch (T->mip->dir)
+ { case GLP_MIN:
+ bound = +DBL_MAX;
+ for (node = T->head; node != NULL; node = node->next)
+ if (bound > node->bound) bound = node->bound;
+ xassert(bound != +DBL_MAX);
+ eps = 1e-10 * (1.0 + fabs(bound));
+ for (node = T->head; node != NULL; node = node->next)
+ { if (node->bound <= bound + eps)
+ { xassert(node->up != NULL);
+ if (best == NULL ||
+#if 1
+ best->up->ii_sum > node->up->ii_sum) best = node;
+#else
+ best->lp_obj > node->lp_obj) best = node;
+#endif
+ }
+ }
+ break;
+ case GLP_MAX:
+ bound = -DBL_MAX;
+ for (node = T->head; node != NULL; node = node->next)
+ if (bound < node->bound) bound = node->bound;
+ xassert(bound != -DBL_MAX);
+ eps = 1e-10 * (1.0 + fabs(bound));
+ for (node = T->head; node != NULL; node = node->next)
+ { if (node->bound >= bound - eps)
+ { xassert(node->up != NULL);
+ if (best == NULL ||
+#if 1
+ best->up->ii_sum > node->up->ii_sum) best = node;
+#else
+ best->lp_obj < node->lp_obj) best = node;
+#endif
+ }
+ }
+ break;
+ default:
+ xassert(T != T);
+ }
+ xassert(best != NULL);
+ return best->p;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpipm.c b/test/monniaux/glpk-4.65/src/draft/glpipm.c
new file mode 100644
index 00000000..2b3a8176
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpipm.c
@@ -0,0 +1,1144 @@
+/* glpipm.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpipm.h"
+#include "glpmat.h"
+
+#define ITER_MAX 100
+/* maximal number of iterations */
+
+struct csa
+{ /* common storage area */
+ /*--------------------------------------------------------------*/
+ /* LP data */
+ int m;
+ /* number of rows (equality constraints) */
+ int n;
+ /* number of columns (structural variables) */
+ int *A_ptr; /* int A_ptr[1+m+1]; */
+ int *A_ind; /* int A_ind[A_ptr[m+1]]; */
+ double *A_val; /* double A_val[A_ptr[m+1]]; */
+ /* mxn-matrix A in storage-by-rows format */
+ double *b; /* double b[1+m]; */
+ /* m-vector b of right-hand sides */
+ double *c; /* double c[1+n]; */
+ /* n-vector c of objective coefficients; c[0] is constant term of
+ the objective function */
+ /*--------------------------------------------------------------*/
+ /* LP solution */
+ double *x; /* double x[1+n]; */
+ double *y; /* double y[1+m]; */
+ double *z; /* double z[1+n]; */
+ /* current point in primal-dual space; the best point on exit */
+ /*--------------------------------------------------------------*/
+ /* control parameters */
+ const glp_iptcp *parm;
+ /*--------------------------------------------------------------*/
+ /* working arrays and variables */
+ double *D; /* double D[1+n]; */
+ /* diagonal nxn-matrix D = X*inv(Z), where X = diag(x[j]) and
+ Z = diag(z[j]) */
+ int *P; /* int P[1+m+m]; */
+ /* permutation mxm-matrix P used to minimize fill-in in Cholesky
+ factorization */
+ int *S_ptr; /* int S_ptr[1+m+1]; */
+ int *S_ind; /* int S_ind[S_ptr[m+1]]; */
+ double *S_val; /* double S_val[S_ptr[m+1]]; */
+ double *S_diag; /* double S_diag[1+m]; */
+ /* symmetric mxm-matrix S = P*A*D*A'*P' whose upper triangular
+ part without diagonal elements is stored in S_ptr, S_ind, and
+ S_val in storage-by-rows format, diagonal elements are stored
+ in S_diag */
+ int *U_ptr; /* int U_ptr[1+m+1]; */
+ int *U_ind; /* int U_ind[U_ptr[m+1]]; */
+ double *U_val; /* double U_val[U_ptr[m+1]]; */
+ double *U_diag; /* double U_diag[1+m]; */
+ /* upper triangular mxm-matrix U defining Cholesky factorization
+ S = U'*U; its non-diagonal elements are stored in U_ptr, U_ind,
+ U_val in storage-by-rows format, diagonal elements are stored
+ in U_diag */
+ int iter;
+ /* iteration number (0, 1, 2, ...); iter = 0 corresponds to the
+ initial point */
+ double obj;
+ /* current value of the objective function */
+ double rpi;
+ /* relative primal infeasibility rpi = ||A*x-b||/(1+||b||) */
+ double rdi;
+ /* relative dual infeasibility rdi = ||A'*y+z-c||/(1+||c||) */
+ double gap;
+ /* primal-dual gap = |c'*x-b'*y|/(1+|c'*x|) which is a relative
+ difference between primal and dual objective functions */
+ double phi;
+ /* merit function phi = ||A*x-b||/max(1,||b||) +
+ + ||A'*y+z-c||/max(1,||c||) +
+ + |c'*x-b'*y|/max(1,||b||,||c||) */
+ double mu;
+ /* duality measure mu = x'*z/n (used as barrier parameter) */
+ double rmu;
+ /* rmu = max(||A*x-b||,||A'*y+z-c||)/mu */
+ double rmu0;
+ /* the initial value of rmu on iteration 0 */
+ double *phi_min; /* double phi_min[1+ITER_MAX]; */
+ /* phi_min[k] = min(phi[k]), where phi[k] is the value of phi on
+ k-th iteration, 0 <= k <= iter */
+ int best_iter;
+ /* iteration number, on which the value of phi reached its best
+ (minimal) value */
+ double *best_x; /* double best_x[1+n]; */
+ double *best_y; /* double best_y[1+m]; */
+ double *best_z; /* double best_z[1+n]; */
+ /* best point (in the sense of the merit function phi) which has
+ been reached on iteration iter_best */
+ double best_obj;
+ /* objective value at the best point */
+ double *dx_aff; /* double dx_aff[1+n]; */
+ double *dy_aff; /* double dy_aff[1+m]; */
+ double *dz_aff; /* double dz_aff[1+n]; */
+ /* affine scaling direction */
+ double alfa_aff_p, alfa_aff_d;
+ /* maximal primal and dual stepsizes in affine scaling direction,
+ on which x and z are still non-negative */
+ double mu_aff;
+ /* duality measure mu_aff = x_aff'*z_aff/n in the boundary point
+ x_aff' = x+alfa_aff_p*dx_aff, z_aff' = z+alfa_aff_d*dz_aff */
+ double sigma;
+ /* Mehrotra's heuristic parameter (0 <= sigma <= 1) */
+ double *dx_cc; /* double dx_cc[1+n]; */
+ double *dy_cc; /* double dy_cc[1+m]; */
+ double *dz_cc; /* double dz_cc[1+n]; */
+ /* centering corrector direction */
+ double *dx; /* double dx[1+n]; */
+ double *dy; /* double dy[1+m]; */
+ double *dz; /* double dz[1+n]; */
+ /* final combined direction dx = dx_aff+dx_cc, dy = dy_aff+dy_cc,
+ dz = dz_aff+dz_cc */
+ double alfa_max_p;
+ double alfa_max_d;
+ /* maximal primal and dual stepsizes in combined direction, on
+ which x and z are still non-negative */
+};
+
+/***********************************************************************
+* initialize - allocate and initialize common storage area
+*
+* This routine allocates and initializes the common storage area (CSA)
+* used by interior-point method routines. */
+
+static void initialize(struct csa *csa)
+{ int m = csa->m;
+ int n = csa->n;
+ int i;
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Matrix A has %d non-zeros\n", csa->A_ptr[m+1]-1);
+ csa->D = xcalloc(1+n, sizeof(double));
+ /* P := I */
+ csa->P = xcalloc(1+m+m, sizeof(int));
+ for (i = 1; i <= m; i++) csa->P[i] = csa->P[m+i] = i;
+ /* S := A*A', symbolically */
+ csa->S_ptr = xcalloc(1+m+1, sizeof(int));
+ csa->S_ind = adat_symbolic(m, n, csa->P, csa->A_ptr, csa->A_ind,
+ csa->S_ptr);
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Matrix S = A*A' has %d non-zeros (upper triangle)\n",
+ csa->S_ptr[m+1]-1 + m);
+ /* determine P using specified ordering algorithm */
+ if (csa->parm->ord_alg == GLP_ORD_NONE)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Original ordering is being used\n");
+ for (i = 1; i <= m; i++)
+ csa->P[i] = csa->P[m+i] = i;
+ }
+ else if (csa->parm->ord_alg == GLP_ORD_QMD)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Minimum degree ordering (QMD)...\n");
+ min_degree(m, csa->S_ptr, csa->S_ind, csa->P);
+ }
+ else if (csa->parm->ord_alg == GLP_ORD_AMD)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Approximate minimum degree ordering (AMD)...\n");
+ amd_order1(m, csa->S_ptr, csa->S_ind, csa->P);
+ }
+ else if (csa->parm->ord_alg == GLP_ORD_SYMAMD)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Approximate minimum degree ordering (SYMAMD)...\n")
+ ;
+ symamd_ord(m, csa->S_ptr, csa->S_ind, csa->P);
+ }
+ else
+ xassert(csa != csa);
+ /* S := P*A*A'*P', symbolically */
+ xfree(csa->S_ind);
+ csa->S_ind = adat_symbolic(m, n, csa->P, csa->A_ptr, csa->A_ind,
+ csa->S_ptr);
+ csa->S_val = xcalloc(csa->S_ptr[m+1], sizeof(double));
+ csa->S_diag = xcalloc(1+m, sizeof(double));
+ /* compute Cholesky factorization S = U'*U, symbolically */
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Computing Cholesky factorization S = L*L'...\n");
+ csa->U_ptr = xcalloc(1+m+1, sizeof(int));
+ csa->U_ind = chol_symbolic(m, csa->S_ptr, csa->S_ind, csa->U_ptr);
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Matrix L has %d non-zeros\n", csa->U_ptr[m+1]-1 + m);
+ csa->U_val = xcalloc(csa->U_ptr[m+1], sizeof(double));
+ csa->U_diag = xcalloc(1+m, sizeof(double));
+ csa->iter = 0;
+ csa->obj = 0.0;
+ csa->rpi = 0.0;
+ csa->rdi = 0.0;
+ csa->gap = 0.0;
+ csa->phi = 0.0;
+ csa->mu = 0.0;
+ csa->rmu = 0.0;
+ csa->rmu0 = 0.0;
+ csa->phi_min = xcalloc(1+ITER_MAX, sizeof(double));
+ csa->best_iter = 0;
+ csa->best_x = xcalloc(1+n, sizeof(double));
+ csa->best_y = xcalloc(1+m, sizeof(double));
+ csa->best_z = xcalloc(1+n, sizeof(double));
+ csa->best_obj = 0.0;
+ csa->dx_aff = xcalloc(1+n, sizeof(double));
+ csa->dy_aff = xcalloc(1+m, sizeof(double));
+ csa->dz_aff = xcalloc(1+n, sizeof(double));
+ csa->alfa_aff_p = 0.0;
+ csa->alfa_aff_d = 0.0;
+ csa->mu_aff = 0.0;
+ csa->sigma = 0.0;
+ csa->dx_cc = xcalloc(1+n, sizeof(double));
+ csa->dy_cc = xcalloc(1+m, sizeof(double));
+ csa->dz_cc = xcalloc(1+n, sizeof(double));
+ csa->dx = csa->dx_aff;
+ csa->dy = csa->dy_aff;
+ csa->dz = csa->dz_aff;
+ csa->alfa_max_p = 0.0;
+ csa->alfa_max_d = 0.0;
+ return;
+}
+
+/***********************************************************************
+* A_by_vec - compute y = A*x
+*
+* This routine computes matrix-vector product y = A*x, where A is the
+* constraint matrix. */
+
+static void A_by_vec(struct csa *csa, double x[], double y[])
+{ /* compute y = A*x */
+ int m = csa->m;
+ int *A_ptr = csa->A_ptr;
+ int *A_ind = csa->A_ind;
+ double *A_val = csa->A_val;
+ int i, t, beg, end;
+ double temp;
+ for (i = 1; i <= m; i++)
+ { temp = 0.0;
+ beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++) temp += A_val[t] * x[A_ind[t]];
+ y[i] = temp;
+ }
+ return;
+}
+
+/***********************************************************************
+* AT_by_vec - compute y = A'*x
+*
+* This routine computes matrix-vector product y = A'*x, where A' is a
+* matrix transposed to the constraint matrix A. */
+
+static void AT_by_vec(struct csa *csa, double x[], double y[])
+{ /* compute y = A'*x, where A' is transposed to A */
+ int m = csa->m;
+ int n = csa->n;
+ int *A_ptr = csa->A_ptr;
+ int *A_ind = csa->A_ind;
+ double *A_val = csa->A_val;
+ int i, j, t, beg, end;
+ double temp;
+ for (j = 1; j <= n; j++) y[j] = 0.0;
+ for (i = 1; i <= m; i++)
+ { temp = x[i];
+ if (temp == 0.0) continue;
+ beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++) y[A_ind[t]] += A_val[t] * temp;
+ }
+ return;
+}
+
+/***********************************************************************
+* decomp_NE - numeric factorization of matrix S = P*A*D*A'*P'
+*
+* This routine implements numeric phase of Cholesky factorization of
+* the matrix S = P*A*D*A'*P', which is a permuted matrix of the normal
+* equation system. Matrix D is assumed to be already computed. */
+
+static void decomp_NE(struct csa *csa)
+{ adat_numeric(csa->m, csa->n, csa->P, csa->A_ptr, csa->A_ind,
+ csa->A_val, csa->D, csa->S_ptr, csa->S_ind, csa->S_val,
+ csa->S_diag);
+ chol_numeric(csa->m, csa->S_ptr, csa->S_ind, csa->S_val,
+ csa->S_diag, csa->U_ptr, csa->U_ind, csa->U_val, csa->U_diag);
+ return;
+}
+
+/***********************************************************************
+* solve_NE - solve normal equation system
+*
+* This routine solves the normal equation system:
+*
+* A*D*A'*y = h.
+*
+* It is assumed that the matrix A*D*A' has been previously factorized
+* by the routine decomp_NE.
+*
+* On entry the array y contains the vector of right-hand sides h. On
+* exit this array contains the computed vector of unknowns y.
+*
+* Once the vector y has been computed the routine checks for numeric
+* stability. If the residual vector:
+*
+* r = A*D*A'*y - h
+*
+* is relatively small, the routine returns zero, otherwise non-zero is
+* returned. */
+
+static int solve_NE(struct csa *csa, double y[])
+{ int m = csa->m;
+ int n = csa->n;
+ int *P = csa->P;
+ int i, j, ret = 0;
+ double *h, *r, *w;
+ /* save vector of right-hand sides h */
+ h = xcalloc(1+m, sizeof(double));
+ for (i = 1; i <= m; i++) h[i] = y[i];
+ /* solve normal equation system (A*D*A')*y = h */
+ /* since S = P*A*D*A'*P' = U'*U, then A*D*A' = P'*U'*U*P, so we
+ have inv(A*D*A') = P'*inv(U)*inv(U')*P */
+ /* w := P*h */
+ w = xcalloc(1+m, sizeof(double));
+ for (i = 1; i <= m; i++) w[i] = y[P[i]];
+ /* w := inv(U')*w */
+ ut_solve(m, csa->U_ptr, csa->U_ind, csa->U_val, csa->U_diag, w);
+ /* w := inv(U)*w */
+ u_solve(m, csa->U_ptr, csa->U_ind, csa->U_val, csa->U_diag, w);
+ /* y := P'*w */
+ for (i = 1; i <= m; i++) y[i] = w[P[m+i]];
+ xfree(w);
+ /* compute residual vector r = A*D*A'*y - h */
+ r = xcalloc(1+m, sizeof(double));
+ /* w := A'*y */
+ w = xcalloc(1+n, sizeof(double));
+ AT_by_vec(csa, y, w);
+ /* w := D*w */
+ for (j = 1; j <= n; j++) w[j] *= csa->D[j];
+ /* r := A*w */
+ A_by_vec(csa, w, r);
+ xfree(w);
+ /* r := r - h */
+ for (i = 1; i <= m; i++) r[i] -= h[i];
+ /* check for numeric stability */
+ for (i = 1; i <= m; i++)
+ { if (fabs(r[i]) / (1.0 + fabs(h[i])) > 1e-4)
+ { ret = 1;
+ break;
+ }
+ }
+ xfree(h);
+ xfree(r);
+ return ret;
+}
+
+/***********************************************************************
+* solve_NS - solve Newtonian system
+*
+* This routine solves the Newtonian system:
+*
+* A*dx = p
+*
+* A'*dy + dz = q
+*
+* Z*dx + X*dz = r
+*
+* where X = diag(x[j]), Z = diag(z[j]), by reducing it to the normal
+* equation system:
+*
+* (A*inv(Z)*X*A')*dy = A*inv(Z)*(X*q-r)+p
+*
+* (it is assumed that the matrix A*inv(Z)*X*A' has been factorized by
+* the routine decomp_NE).
+*
+* Once vector dy has been computed the routine computes vectors dx and
+* dz as follows:
+*
+* dx = inv(Z)*(X*(A'*dy-q)+r)
+*
+* dz = inv(X)*(r-Z*dx)
+*
+* The routine solve_NS returns the same code which was reported by the
+* routine solve_NE (see above). */
+
+static int solve_NS(struct csa *csa, double p[], double q[], double r[],
+ double dx[], double dy[], double dz[])
+{ int m = csa->m;
+ int n = csa->n;
+ double *x = csa->x;
+ double *z = csa->z;
+ int i, j, ret;
+ double *w = dx;
+ /* compute the vector of right-hand sides A*inv(Z)*(X*q-r)+p for
+ the normal equation system */
+ for (j = 1; j <= n; j++)
+ w[j] = (x[j] * q[j] - r[j]) / z[j];
+ A_by_vec(csa, w, dy);
+ for (i = 1; i <= m; i++) dy[i] += p[i];
+ /* solve the normal equation system to compute vector dy */
+ ret = solve_NE(csa, dy);
+ /* compute vectors dx and dz */
+ AT_by_vec(csa, dy, dx);
+ for (j = 1; j <= n; j++)
+ { dx[j] = (x[j] * (dx[j] - q[j]) + r[j]) / z[j];
+ dz[j] = (r[j] - z[j] * dx[j]) / x[j];
+ }
+ return ret;
+}
+
+/***********************************************************************
+* initial_point - choose initial point using Mehrotra's heuristic
+*
+* This routine chooses a starting point using a heuristic proposed in
+* the paper:
+*
+* S. Mehrotra. On the implementation of a primal-dual interior point
+* method. SIAM J. on Optim., 2(4), pp. 575-601, 1992.
+*
+* The starting point x in the primal space is chosen as a solution of
+* the following least squares problem:
+*
+* minimize ||x||
+*
+* subject to A*x = b
+*
+* which can be computed explicitly as follows:
+*
+* x = A'*inv(A*A')*b
+*
+* Similarly, the starting point (y, z) in the dual space is chosen as
+* a solution of the following least squares problem:
+*
+* minimize ||z||
+*
+* subject to A'*y + z = c
+*
+* which can be computed explicitly as follows:
+*
+* y = inv(A*A')*A*c
+*
+* z = c - A'*y
+*
+* However, some components of the vectors x and z may be non-positive
+* or close to zero, so the routine uses a Mehrotra's heuristic to find
+* a more appropriate starting point. */
+
+static void initial_point(struct csa *csa)
+{ int m = csa->m;
+ int n = csa->n;
+ double *b = csa->b;
+ double *c = csa->c;
+ double *x = csa->x;
+ double *y = csa->y;
+ double *z = csa->z;
+ double *D = csa->D;
+ int i, j;
+ double dp, dd, ex, ez, xz;
+ /* factorize A*A' */
+ for (j = 1; j <= n; j++) D[j] = 1.0;
+ decomp_NE(csa);
+ /* x~ = A'*inv(A*A')*b */
+ for (i = 1; i <= m; i++) y[i] = b[i];
+ solve_NE(csa, y);
+ AT_by_vec(csa, y, x);
+ /* y~ = inv(A*A')*A*c */
+ A_by_vec(csa, c, y);
+ solve_NE(csa, y);
+ /* z~ = c - A'*y~ */
+ AT_by_vec(csa, y,z);
+ for (j = 1; j <= n; j++) z[j] = c[j] - z[j];
+ /* use Mehrotra's heuristic in order to choose more appropriate
+ starting point with positive components of vectors x and z */
+ dp = dd = 0.0;
+ for (j = 1; j <= n; j++)
+ { if (dp < -1.5 * x[j]) dp = -1.5 * x[j];
+ if (dd < -1.5 * z[j]) dd = -1.5 * z[j];
+ }
+ /* note that b = 0 involves x = 0, and c = 0 involves y = 0 and
+ z = 0, so we need to be careful */
+ if (dp == 0.0) dp = 1.5;
+ if (dd == 0.0) dd = 1.5;
+ ex = ez = xz = 0.0;
+ for (j = 1; j <= n; j++)
+ { ex += (x[j] + dp);
+ ez += (z[j] + dd);
+ xz += (x[j] + dp) * (z[j] + dd);
+ }
+ dp += 0.5 * (xz / ez);
+ dd += 0.5 * (xz / ex);
+ for (j = 1; j <= n; j++)
+ { x[j] += dp;
+ z[j] += dd;
+ xassert(x[j] > 0.0 && z[j] > 0.0);
+ }
+ return;
+}
+
+/***********************************************************************
+* basic_info - perform basic computations at the current point
+*
+* This routine computes the following quantities at the current point:
+*
+* 1) value of the objective function:
+*
+* F = c'*x + c[0]
+*
+* 2) relative primal infeasibility:
+*
+* rpi = ||A*x-b|| / (1+||b||)
+*
+* 3) relative dual infeasibility:
+*
+* rdi = ||A'*y+z-c|| / (1+||c||)
+*
+* 4) primal-dual gap (relative difference between the primal and the
+* dual objective function values):
+*
+* gap = |c'*x-b'*y| / (1+|c'*x|)
+*
+* 5) merit function:
+*
+* phi = ||A*x-b|| / max(1,||b||) + ||A'*y+z-c|| / max(1,||c||) +
+*
+* + |c'*x-b'*y| / max(1,||b||,||c||)
+*
+* 6) duality measure:
+*
+* mu = x'*z / n
+*
+* 7) the ratio of infeasibility to mu:
+*
+* rmu = max(||A*x-b||,||A'*y+z-c||) / mu
+*
+* where ||*|| denotes euclidian norm, *' denotes transposition. */
+
+static void basic_info(struct csa *csa)
+{ int m = csa->m;
+ int n = csa->n;
+ double *b = csa->b;
+ double *c = csa->c;
+ double *x = csa->x;
+ double *y = csa->y;
+ double *z = csa->z;
+ int i, j;
+ double norm1, bnorm, norm2, cnorm, cx, by, *work, temp;
+ /* compute value of the objective function */
+ temp = c[0];
+ for (j = 1; j <= n; j++) temp += c[j] * x[j];
+ csa->obj = temp;
+ /* norm1 = ||A*x-b|| */
+ work = xcalloc(1+m, sizeof(double));
+ A_by_vec(csa, x, work);
+ norm1 = 0.0;
+ for (i = 1; i <= m; i++)
+ norm1 += (work[i] - b[i]) * (work[i] - b[i]);
+ norm1 = sqrt(norm1);
+ xfree(work);
+ /* bnorm = ||b|| */
+ bnorm = 0.0;
+ for (i = 1; i <= m; i++) bnorm += b[i] * b[i];
+ bnorm = sqrt(bnorm);
+ /* compute relative primal infeasibility */
+ csa->rpi = norm1 / (1.0 + bnorm);
+ /* norm2 = ||A'*y+z-c|| */
+ work = xcalloc(1+n, sizeof(double));
+ AT_by_vec(csa, y, work);
+ norm2 = 0.0;
+ for (j = 1; j <= n; j++)
+ norm2 += (work[j] + z[j] - c[j]) * (work[j] + z[j] - c[j]);
+ norm2 = sqrt(norm2);
+ xfree(work);
+ /* cnorm = ||c|| */
+ cnorm = 0.0;
+ for (j = 1; j <= n; j++) cnorm += c[j] * c[j];
+ cnorm = sqrt(cnorm);
+ /* compute relative dual infeasibility */
+ csa->rdi = norm2 / (1.0 + cnorm);
+ /* by = b'*y */
+ by = 0.0;
+ for (i = 1; i <= m; i++) by += b[i] * y[i];
+ /* cx = c'*x */
+ cx = 0.0;
+ for (j = 1; j <= n; j++) cx += c[j] * x[j];
+ /* compute primal-dual gap */
+ csa->gap = fabs(cx - by) / (1.0 + fabs(cx));
+ /* compute merit function */
+ csa->phi = 0.0;
+ csa->phi += norm1 / (bnorm > 1.0 ? bnorm : 1.0);
+ csa->phi += norm2 / (cnorm > 1.0 ? cnorm : 1.0);
+ temp = 1.0;
+ if (temp < bnorm) temp = bnorm;
+ if (temp < cnorm) temp = cnorm;
+ csa->phi += fabs(cx - by) / temp;
+ /* compute duality measure */
+ temp = 0.0;
+ for (j = 1; j <= n; j++) temp += x[j] * z[j];
+ csa->mu = temp / (double)n;
+ /* compute the ratio of infeasibility to mu */
+ csa->rmu = (norm1 > norm2 ? norm1 : norm2) / csa->mu;
+ return;
+}
+
+/***********************************************************************
+* make_step - compute next point using Mehrotra's technique
+*
+* This routine computes the next point using the predictor-corrector
+* technique proposed in the paper:
+*
+* S. Mehrotra. On the implementation of a primal-dual interior point
+* method. SIAM J. on Optim., 2(4), pp. 575-601, 1992.
+*
+* At first, the routine computes so called affine scaling (predictor)
+* direction (dx_aff,dy_aff,dz_aff) which is a solution of the system:
+*
+* A*dx_aff = b - A*x
+*
+* A'*dy_aff + dz_aff = c - A'*y - z
+*
+* Z*dx_aff + X*dz_aff = - X*Z*e
+*
+* where (x,y,z) is the current point, X = diag(x[j]), Z = diag(z[j]),
+* e = (1,...,1)'.
+*
+* Then, the routine computes the centering parameter sigma, using the
+* following Mehrotra's heuristic:
+*
+* alfa_aff_p = inf{0 <= alfa <= 1 | x+alfa*dx_aff >= 0}
+*
+* alfa_aff_d = inf{0 <= alfa <= 1 | z+alfa*dz_aff >= 0}
+*
+* mu_aff = (x+alfa_aff_p*dx_aff)'*(z+alfa_aff_d*dz_aff)/n
+*
+* sigma = (mu_aff/mu)^3
+*
+* where alfa_aff_p is the maximal stepsize along the affine scaling
+* direction in the primal space, alfa_aff_d is the maximal stepsize
+* along the same direction in the dual space.
+*
+* After determining sigma the routine computes so called centering
+* (corrector) direction (dx_cc,dy_cc,dz_cc) which is the solution of
+* the system:
+*
+* A*dx_cc = 0
+*
+* A'*dy_cc + dz_cc = 0
+*
+* Z*dx_cc + X*dz_cc = sigma*mu*e - X*Z*e
+*
+* Finally, the routine computes the combined direction
+*
+* (dx,dy,dz) = (dx_aff,dy_aff,dz_aff) + (dx_cc,dy_cc,dz_cc)
+*
+* and determines maximal primal and dual stepsizes along the combined
+* direction:
+*
+* alfa_max_p = inf{0 <= alfa <= 1 | x+alfa*dx >= 0}
+*
+* alfa_max_d = inf{0 <= alfa <= 1 | z+alfa*dz >= 0}
+*
+* In order to prevent the next point to be too close to the boundary
+* of the positive ortant, the routine decreases maximal stepsizes:
+*
+* alfa_p = gamma_p * alfa_max_p
+*
+* alfa_d = gamma_d * alfa_max_d
+*
+* where gamma_p and gamma_d are scaling factors, and computes the next
+* point:
+*
+* x_new = x + alfa_p * dx
+*
+* y_new = y + alfa_d * dy
+*
+* z_new = z + alfa_d * dz
+*
+* which becomes the current point on the next iteration. */
+
+static int make_step(struct csa *csa)
+{ int m = csa->m;
+ int n = csa->n;
+ double *b = csa->b;
+ double *c = csa->c;
+ double *x = csa->x;
+ double *y = csa->y;
+ double *z = csa->z;
+ double *dx_aff = csa->dx_aff;
+ double *dy_aff = csa->dy_aff;
+ double *dz_aff = csa->dz_aff;
+ double *dx_cc = csa->dx_cc;
+ double *dy_cc = csa->dy_cc;
+ double *dz_cc = csa->dz_cc;
+ double *dx = csa->dx;
+ double *dy = csa->dy;
+ double *dz = csa->dz;
+ int i, j, ret = 0;
+ double temp, gamma_p, gamma_d, *p, *q, *r;
+ /* allocate working arrays */
+ p = xcalloc(1+m, sizeof(double));
+ q = xcalloc(1+n, sizeof(double));
+ r = xcalloc(1+n, sizeof(double));
+ /* p = b - A*x */
+ A_by_vec(csa, x, p);
+ for (i = 1; i <= m; i++) p[i] = b[i] - p[i];
+ /* q = c - A'*y - z */
+ AT_by_vec(csa, y,q);
+ for (j = 1; j <= n; j++) q[j] = c[j] - q[j] - z[j];
+ /* r = - X * Z * e */
+ for (j = 1; j <= n; j++) r[j] = - x[j] * z[j];
+ /* solve the first Newtonian system */
+ if (solve_NS(csa, p, q, r, dx_aff, dy_aff, dz_aff))
+ { ret = 1;
+ goto done;
+ }
+ /* alfa_aff_p = inf{0 <= alfa <= 1 | x + alfa*dx_aff >= 0} */
+ /* alfa_aff_d = inf{0 <= alfa <= 1 | z + alfa*dz_aff >= 0} */
+ csa->alfa_aff_p = csa->alfa_aff_d = 1.0;
+ for (j = 1; j <= n; j++)
+ { if (dx_aff[j] < 0.0)
+ { temp = - x[j] / dx_aff[j];
+ if (csa->alfa_aff_p > temp) csa->alfa_aff_p = temp;
+ }
+ if (dz_aff[j] < 0.0)
+ { temp = - z[j] / dz_aff[j];
+ if (csa->alfa_aff_d > temp) csa->alfa_aff_d = temp;
+ }
+ }
+ /* mu_aff = (x+alfa_aff_p*dx_aff)' * (z+alfa_aff_d*dz_aff) / n */
+ temp = 0.0;
+ for (j = 1; j <= n; j++)
+ temp += (x[j] + csa->alfa_aff_p * dx_aff[j]) *
+ (z[j] + csa->alfa_aff_d * dz_aff[j]);
+ csa->mu_aff = temp / (double)n;
+ /* sigma = (mu_aff/mu)^3 */
+ temp = csa->mu_aff / csa->mu;
+ csa->sigma = temp * temp * temp;
+ /* p = 0 */
+ for (i = 1; i <= m; i++) p[i] = 0.0;
+ /* q = 0 */
+ for (j = 1; j <= n; j++) q[j] = 0.0;
+ /* r = sigma * mu * e - X * Z * e */
+ for (j = 1; j <= n; j++)
+ r[j] = csa->sigma * csa->mu - dx_aff[j] * dz_aff[j];
+ /* solve the second Newtonian system with the same coefficients
+ but with altered right-hand sides */
+ if (solve_NS(csa, p, q, r, dx_cc, dy_cc, dz_cc))
+ { ret = 1;
+ goto done;
+ }
+ /* (dx,dy,dz) = (dx_aff,dy_aff,dz_aff) + (dx_cc,dy_cc,dz_cc) */
+ for (j = 1; j <= n; j++) dx[j] = dx_aff[j] + dx_cc[j];
+ for (i = 1; i <= m; i++) dy[i] = dy_aff[i] + dy_cc[i];
+ for (j = 1; j <= n; j++) dz[j] = dz_aff[j] + dz_cc[j];
+ /* alfa_max_p = inf{0 <= alfa <= 1 | x + alfa*dx >= 0} */
+ /* alfa_max_d = inf{0 <= alfa <= 1 | z + alfa*dz >= 0} */
+ csa->alfa_max_p = csa->alfa_max_d = 1.0;
+ for (j = 1; j <= n; j++)
+ { if (dx[j] < 0.0)
+ { temp = - x[j] / dx[j];
+ if (csa->alfa_max_p > temp) csa->alfa_max_p = temp;
+ }
+ if (dz[j] < 0.0)
+ { temp = - z[j] / dz[j];
+ if (csa->alfa_max_d > temp) csa->alfa_max_d = temp;
+ }
+ }
+ /* determine scale factors (not implemented yet) */
+ gamma_p = 0.90;
+ gamma_d = 0.90;
+ /* compute the next point */
+ for (j = 1; j <= n; j++)
+ { x[j] += gamma_p * csa->alfa_max_p * dx[j];
+ xassert(x[j] > 0.0);
+ }
+ for (i = 1; i <= m; i++)
+ y[i] += gamma_d * csa->alfa_max_d * dy[i];
+ for (j = 1; j <= n; j++)
+ { z[j] += gamma_d * csa->alfa_max_d * dz[j];
+ xassert(z[j] > 0.0);
+ }
+done: /* free working arrays */
+ xfree(p);
+ xfree(q);
+ xfree(r);
+ return ret;
+}
+
+/***********************************************************************
+* terminate - deallocate common storage area
+*
+* This routine frees all memory allocated to the common storage area
+* used by interior-point method routines. */
+
+static void terminate(struct csa *csa)
+{ xfree(csa->D);
+ xfree(csa->P);
+ xfree(csa->S_ptr);
+ xfree(csa->S_ind);
+ xfree(csa->S_val);
+ xfree(csa->S_diag);
+ xfree(csa->U_ptr);
+ xfree(csa->U_ind);
+ xfree(csa->U_val);
+ xfree(csa->U_diag);
+ xfree(csa->phi_min);
+ xfree(csa->best_x);
+ xfree(csa->best_y);
+ xfree(csa->best_z);
+ xfree(csa->dx_aff);
+ xfree(csa->dy_aff);
+ xfree(csa->dz_aff);
+ xfree(csa->dx_cc);
+ xfree(csa->dy_cc);
+ xfree(csa->dz_cc);
+ return;
+}
+
+/***********************************************************************
+* ipm_main - main interior-point method routine
+*
+* This is a main routine of the primal-dual interior-point method.
+*
+* The routine ipm_main returns one of the following codes:
+*
+* 0 - optimal solution found;
+* 1 - problem has no feasible (primal or dual) solution;
+* 2 - no convergence;
+* 3 - iteration limit exceeded;
+* 4 - numeric instability on solving Newtonian system.
+*
+* In case of non-zero return code the routine returns the best point,
+* which has been reached during optimization. */
+
+static int ipm_main(struct csa *csa)
+{ int m = csa->m;
+ int n = csa->n;
+ int i, j, status;
+ double temp;
+ /* choose initial point using Mehrotra's heuristic */
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Guessing initial point...\n");
+ initial_point(csa);
+ /* main loop starts here */
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Optimization begins...\n");
+ for (;;)
+ { /* perform basic computations at the current point */
+ basic_info(csa);
+ /* save initial value of rmu */
+ if (csa->iter == 0) csa->rmu0 = csa->rmu;
+ /* accumulate values of min(phi[k]) and save the best point */
+ xassert(csa->iter <= ITER_MAX);
+ if (csa->iter == 0 || csa->phi_min[csa->iter-1] > csa->phi)
+ { csa->phi_min[csa->iter] = csa->phi;
+ csa->best_iter = csa->iter;
+ for (j = 1; j <= n; j++) csa->best_x[j] = csa->x[j];
+ for (i = 1; i <= m; i++) csa->best_y[i] = csa->y[i];
+ for (j = 1; j <= n; j++) csa->best_z[j] = csa->z[j];
+ csa->best_obj = csa->obj;
+ }
+ else
+ csa->phi_min[csa->iter] = csa->phi_min[csa->iter-1];
+ /* display information at the current point */
+ if (csa->parm->msg_lev >= GLP_MSG_ON)
+ xprintf("%3d: obj = %17.9e; rpi = %8.1e; rdi = %8.1e; gap ="
+ " %8.1e\n", csa->iter, csa->obj, csa->rpi, csa->rdi,
+ csa->gap);
+ /* check if the current point is optimal */
+ if (csa->rpi < 1e-8 && csa->rdi < 1e-8 && csa->gap < 1e-8)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("OPTIMAL SOLUTION FOUND\n");
+ status = 0;
+ break;
+ }
+ /* check if the problem has no feasible solution */
+ temp = 1e5 * csa->phi_min[csa->iter];
+ if (temp < 1e-8) temp = 1e-8;
+ if (csa->phi >= temp)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("PROBLEM HAS NO FEASIBLE PRIMAL/DUAL SOLUTION\n")
+ ;
+ status = 1;
+ break;
+ }
+ /* check for very slow convergence or divergence */
+ if (((csa->rpi >= 1e-8 || csa->rdi >= 1e-8) && csa->rmu /
+ csa->rmu0 >= 1e6) ||
+ (csa->iter >= 30 && csa->phi_min[csa->iter] >= 0.5 *
+ csa->phi_min[csa->iter - 30]))
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("NO CONVERGENCE; SEARCH TERMINATED\n");
+ status = 2;
+ break;
+ }
+ /* check for maximal number of iterations */
+ if (csa->iter == ITER_MAX)
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("ITERATION LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ status = 3;
+ break;
+ }
+ /* start the next iteration */
+ csa->iter++;
+ /* factorize normal equation system */
+ for (j = 1; j <= n; j++) csa->D[j] = csa->x[j] / csa->z[j];
+ decomp_NE(csa);
+ /* compute the next point using Mehrotra's predictor-corrector
+ technique */
+ if (make_step(csa))
+ { if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("NUMERIC INSTABILITY; SEARCH TERMINATED\n");
+ status = 4;
+ break;
+ }
+ }
+ /* restore the best point */
+ if (status != 0)
+ { for (j = 1; j <= n; j++) csa->x[j] = csa->best_x[j];
+ for (i = 1; i <= m; i++) csa->y[i] = csa->best_y[i];
+ for (j = 1; j <= n; j++) csa->z[j] = csa->best_z[j];
+ if (csa->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Best point %17.9e was reached on iteration %d\n",
+ csa->best_obj, csa->best_iter);
+ }
+ /* return to the calling program */
+ return status;
+}
+
+/***********************************************************************
+* NAME
+*
+* ipm_solve - core LP solver based on the interior-point method
+*
+* SYNOPSIS
+*
+* #include "glpipm.h"
+* int ipm_solve(glp_prob *P, const glp_iptcp *parm);
+*
+* DESCRIPTION
+*
+* The routine ipm_solve is a core LP solver based on the primal-dual
+* interior-point method.
+*
+* The routine assumes the following standard formulation of LP problem
+* to be solved:
+*
+* minimize
+*
+* F = c[0] + c[1]*x[1] + c[2]*x[2] + ... + c[n]*x[n]
+*
+* subject to linear constraints
+*
+* a[1,1]*x[1] + a[1,2]*x[2] + ... + a[1,n]*x[n] = b[1]
+*
+* a[2,1]*x[1] + a[2,2]*x[2] + ... + a[2,n]*x[n] = b[2]
+*
+* . . . . . .
+*
+* a[m,1]*x[1] + a[m,2]*x[2] + ... + a[m,n]*x[n] = b[m]
+*
+* and non-negative variables
+*
+* x[1] >= 0, x[2] >= 0, ..., x[n] >= 0
+*
+* where:
+* F is the objective function;
+* x[1], ..., x[n] are (structural) variables;
+* c[0] is a constant term of the objective function;
+* c[1], ..., c[n] are objective coefficients;
+* a[1,1], ..., a[m,n] are constraint coefficients;
+* b[1], ..., b[n] are right-hand sides.
+*
+* The solution is three vectors x, y, and z, which are stored by the
+* routine in the arrays x, y, and z, respectively. These vectors
+* correspond to the best primal-dual point found during optimization.
+* They are approximate solution of the following system (which is the
+* Karush-Kuhn-Tucker optimality conditions):
+*
+* A*x = b (primal feasibility condition)
+*
+* A'*y + z = c (dual feasibility condition)
+*
+* x'*z = 0 (primal-dual complementarity condition)
+*
+* x >= 0, z >= 0 (non-negativity condition)
+*
+* where:
+* x[1], ..., x[n] are primal (structural) variables;
+* y[1], ..., y[m] are dual variables (Lagrange multipliers) for
+* equality constraints;
+* z[1], ..., z[n] are dual variables (Lagrange multipliers) for
+* non-negativity constraints.
+*
+* RETURNS
+*
+* 0 LP has been successfully solved.
+*
+* GLP_ENOCVG
+* No convergence.
+*
+* GLP_EITLIM
+* Iteration limit exceeded.
+*
+* GLP_EINSTAB
+* Numeric instability on solving Newtonian system.
+*
+* In case of non-zero return code the routine returns the best point,
+* which has been reached during optimization. */
+
+int ipm_solve(glp_prob *P, const glp_iptcp *parm)
+{ struct csa _dsa, *csa = &_dsa;
+ int m = P->m;
+ int n = P->n;
+ int nnz = P->nnz;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, j, loc, ret, *A_ind, *A_ptr;
+ double dir, *A_val, *b, *c, *x, *y, *z;
+ xassert(m > 0);
+ xassert(n > 0);
+ /* allocate working arrays */
+ A_ptr = xcalloc(1+m+1, sizeof(int));
+ A_ind = xcalloc(1+nnz, sizeof(int));
+ A_val = xcalloc(1+nnz, sizeof(double));
+ b = xcalloc(1+m, sizeof(double));
+ c = xcalloc(1+n, sizeof(double));
+ x = xcalloc(1+n, sizeof(double));
+ y = xcalloc(1+m, sizeof(double));
+ z = xcalloc(1+n, sizeof(double));
+ /* prepare rows and constraint coefficients */
+ loc = 1;
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ xassert(row->type == GLP_FX);
+ b[i] = row->lb * row->rii;
+ A_ptr[i] = loc;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { A_ind[loc] = aij->col->j;
+ A_val[loc] = row->rii * aij->val * aij->col->sjj;
+ loc++;
+ }
+ }
+ A_ptr[m+1] = loc;
+ xassert(loc-1 == nnz);
+ /* prepare columns and objective coefficients */
+ if (P->dir == GLP_MIN)
+ dir = +1.0;
+ else if (P->dir == GLP_MAX)
+ dir = -1.0;
+ else
+ xassert(P != P);
+ c[0] = dir * P->c0;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ xassert(col->type == GLP_LO && col->lb == 0.0);
+ c[j] = dir * col->coef * col->sjj;
+ }
+ /* allocate and initialize the common storage area */
+ csa->m = m;
+ csa->n = n;
+ csa->A_ptr = A_ptr;
+ csa->A_ind = A_ind;
+ csa->A_val = A_val;
+ csa->b = b;
+ csa->c = c;
+ csa->x = x;
+ csa->y = y;
+ csa->z = z;
+ csa->parm = parm;
+ initialize(csa);
+ /* solve LP with the interior-point method */
+ ret = ipm_main(csa);
+ /* deallocate the common storage area */
+ terminate(csa);
+ /* determine solution status */
+ if (ret == 0)
+ { /* optimal solution found */
+ P->ipt_stat = GLP_OPT;
+ ret = 0;
+ }
+ else if (ret == 1)
+ { /* problem has no feasible (primal or dual) solution */
+ P->ipt_stat = GLP_NOFEAS;
+ ret = 0;
+ }
+ else if (ret == 2)
+ { /* no convergence */
+ P->ipt_stat = GLP_INFEAS;
+ ret = GLP_ENOCVG;
+ }
+ else if (ret == 3)
+ { /* iteration limit exceeded */
+ P->ipt_stat = GLP_INFEAS;
+ ret = GLP_EITLIM;
+ }
+ else if (ret == 4)
+ { /* numeric instability on solving Newtonian system */
+ P->ipt_stat = GLP_INFEAS;
+ ret = GLP_EINSTAB;
+ }
+ else
+ xassert(ret != ret);
+ /* store row solution components */
+ for (i = 1; i <= m; i++)
+ { row = P->row[i];
+ row->pval = row->lb;
+ row->dval = dir * y[i] * row->rii;
+ }
+ /* store column solution components */
+ P->ipt_obj = P->c0;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ col->pval = x[j] * col->sjj;
+ col->dval = dir * z[j] / col->sjj;
+ P->ipt_obj += col->coef * col->pval;
+ }
+ /* free working arrays */
+ xfree(A_ptr);
+ xfree(A_ind);
+ xfree(A_val);
+ xfree(b);
+ xfree(c);
+ xfree(x);
+ xfree(y);
+ xfree(z);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpipm.h b/test/monniaux/glpk-4.65/src/draft/glpipm.h
new file mode 100644
index 00000000..a5f94fec
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpipm.h
@@ -0,0 +1,36 @@
+/* glpipm.h (primal-dual interior-point method) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPIPM_H
+#define GLPIPM_H
+
+#include "prob.h"
+
+#define ipm_solve _glp_ipm_solve
+int ipm_solve(glp_prob *P, const glp_iptcp *parm);
+/* core LP solver based on the interior-point method */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpmat.c b/test/monniaux/glpk-4.65/src/draft/glpmat.c
new file mode 100644
index 00000000..97d1c651
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpmat.c
@@ -0,0 +1,924 @@
+/* glpmat.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpmat.h"
+#include "qmd.h"
+#include "amd.h"
+#include "colamd.h"
+
+/*----------------------------------------------------------------------
+-- check_fvs - check sparse vector in full-vector storage format.
+--
+-- SYNOPSIS
+--
+-- #include "glpmat.h"
+-- int check_fvs(int n, int nnz, int ind[], double vec[]);
+--
+-- DESCRIPTION
+--
+-- The routine check_fvs checks if a given vector of dimension n in
+-- full-vector storage format has correct representation.
+--
+-- RETURNS
+--
+-- The routine returns one of the following codes:
+--
+-- 0 - the vector is correct;
+-- 1 - the number of elements (n) is negative;
+-- 2 - the number of non-zero elements (nnz) is negative;
+-- 3 - some element index is out of range;
+-- 4 - some element index is duplicate;
+-- 5 - some non-zero element is out of pattern. */
+
+int check_fvs(int n, int nnz, int ind[], double vec[])
+{ int i, t, ret, *flag = NULL;
+ /* check the number of elements */
+ if (n < 0)
+ { ret = 1;
+ goto done;
+ }
+ /* check the number of non-zero elements */
+ if (nnz < 0)
+ { ret = 2;
+ goto done;
+ }
+ /* check vector indices */
+ flag = xcalloc(1+n, sizeof(int));
+ for (i = 1; i <= n; i++) flag[i] = 0;
+ for (t = 1; t <= nnz; t++)
+ { i = ind[t];
+ if (!(1 <= i && i <= n))
+ { ret = 3;
+ goto done;
+ }
+ if (flag[i])
+ { ret = 4;
+ goto done;
+ }
+ flag[i] = 1;
+ }
+ /* check vector elements */
+ for (i = 1; i <= n; i++)
+ { if (!flag[i] && vec[i] != 0.0)
+ { ret = 5;
+ goto done;
+ }
+ }
+ /* the vector is ok */
+ ret = 0;
+done: if (flag != NULL) xfree(flag);
+ return ret;
+}
+
+/*----------------------------------------------------------------------
+-- check_pattern - check pattern of sparse matrix.
+--
+-- SYNOPSIS
+--
+-- #include "glpmat.h"
+-- int check_pattern(int m, int n, int A_ptr[], int A_ind[]);
+--
+-- DESCRIPTION
+--
+-- The routine check_pattern checks the pattern of a given mxn matrix
+-- in storage-by-rows format.
+--
+-- RETURNS
+--
+-- The routine returns one of the following codes:
+--
+-- 0 - the pattern is correct;
+-- 1 - the number of rows (m) is negative;
+-- 2 - the number of columns (n) is negative;
+-- 3 - A_ptr[1] is not 1;
+-- 4 - some column index is out of range;
+-- 5 - some column indices are duplicate. */
+
+int check_pattern(int m, int n, int A_ptr[], int A_ind[])
+{ int i, j, ptr, ret, *flag = NULL;
+ /* check the number of rows */
+ if (m < 0)
+ { ret = 1;
+ goto done;
+ }
+ /* check the number of columns */
+ if (n < 0)
+ { ret = 2;
+ goto done;
+ }
+ /* check location A_ptr[1] */
+ if (A_ptr[1] != 1)
+ { ret = 3;
+ goto done;
+ }
+ /* check row patterns */
+ flag = xcalloc(1+n, sizeof(int));
+ for (j = 1; j <= n; j++) flag[j] = 0;
+ for (i = 1; i <= m; i++)
+ { /* check pattern of row i */
+ for (ptr = A_ptr[i]; ptr < A_ptr[i+1]; ptr++)
+ { j = A_ind[ptr];
+ /* check column index */
+ if (!(1 <= j && j <= n))
+ { ret = 4;
+ goto done;
+ }
+ /* check for duplication */
+ if (flag[j])
+ { ret = 5;
+ goto done;
+ }
+ flag[j] = 1;
+ }
+ /* clear flags */
+ for (ptr = A_ptr[i]; ptr < A_ptr[i+1]; ptr++)
+ { j = A_ind[ptr];
+ flag[j] = 0;
+ }
+ }
+ /* the pattern is ok */
+ ret = 0;
+done: if (flag != NULL) xfree(flag);
+ return ret;
+}
+
+/*----------------------------------------------------------------------
+-- transpose - transpose sparse matrix.
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- void transpose(int m, int n, int A_ptr[], int A_ind[],
+-- double A_val[], int AT_ptr[], int AT_ind[], double AT_val[]);
+--
+-- *Description*
+--
+-- For a given mxn sparse matrix A the routine transpose builds a nxm
+-- sparse matrix A' which is a matrix transposed to A.
+--
+-- The arrays A_ptr, A_ind, and A_val specify a given mxn matrix A to
+-- be transposed in storage-by-rows format. The parameter A_val can be
+-- NULL, in which case numeric values are not copied. The arrays A_ptr,
+-- A_ind, and A_val are not changed on exit.
+--
+-- On entry the arrays AT_ptr, AT_ind, and AT_val must be allocated,
+-- but their content is ignored. On exit the routine stores a resultant
+-- nxm matrix A' in these arrays in storage-by-rows format. Note that
+-- if the parameter A_val is NULL, the array AT_val is not used.
+--
+-- The routine transpose has a side effect that elements in rows of the
+-- resultant matrix A' follow in ascending their column indices. */
+
+void transpose(int m, int n, int A_ptr[], int A_ind[], double A_val[],
+ int AT_ptr[], int AT_ind[], double AT_val[])
+{ int i, j, t, beg, end, pos, len;
+ /* determine row lengths of resultant matrix */
+ for (j = 1; j <= n; j++) AT_ptr[j] = 0;
+ for (i = 1; i <= m; i++)
+ { beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++) AT_ptr[A_ind[t]]++;
+ }
+ /* set up row pointers of resultant matrix */
+ pos = 1;
+ for (j = 1; j <= n; j++)
+ len = AT_ptr[j], pos += len, AT_ptr[j] = pos;
+ AT_ptr[n+1] = pos;
+ /* build resultant matrix */
+ for (i = m; i >= 1; i--)
+ { beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++)
+ { pos = --AT_ptr[A_ind[t]];
+ AT_ind[pos] = i;
+ if (A_val != NULL) AT_val[pos] = A_val[t];
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- adat_symbolic - compute S = P*A*D*A'*P' (symbolic phase).
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- int *adat_symbolic(int m, int n, int P_per[], int A_ptr[],
+-- int A_ind[], int S_ptr[]);
+--
+-- *Description*
+--
+-- The routine adat_symbolic implements the symbolic phase to compute
+-- symmetric matrix S = P*A*D*A'*P', where P is a permutation matrix,
+-- A is a given sparse matrix, D is a diagonal matrix, A' is a matrix
+-- transposed to A, P' is an inverse of P.
+--
+-- The parameter m is the number of rows in A and the order of P.
+--
+-- The parameter n is the number of columns in A and the order of D.
+--
+-- The array P_per specifies permutation matrix P. It is not changed on
+-- exit.
+--
+-- The arrays A_ptr and A_ind specify the pattern of matrix A. They are
+-- not changed on exit.
+--
+-- On exit the routine stores the pattern of upper triangular part of
+-- matrix S without diagonal elements in the arrays S_ptr and S_ind in
+-- storage-by-rows format. The array S_ptr should be allocated on entry,
+-- however, its content is ignored. The array S_ind is allocated by the
+-- routine itself which returns a pointer to it.
+--
+-- *Returns*
+--
+-- The routine returns a pointer to the array S_ind. */
+
+int *adat_symbolic(int m, int n, int P_per[], int A_ptr[], int A_ind[],
+ int S_ptr[])
+{ int i, j, t, ii, jj, tt, k, size, len;
+ int *S_ind, *AT_ptr, *AT_ind, *ind, *map, *temp;
+ /* build the pattern of A', which is a matrix transposed to A, to
+ efficiently access A in column-wise manner */
+ AT_ptr = xcalloc(1+n+1, sizeof(int));
+ AT_ind = xcalloc(A_ptr[m+1], sizeof(int));
+ transpose(m, n, A_ptr, A_ind, NULL, AT_ptr, AT_ind, NULL);
+ /* allocate the array S_ind */
+ size = A_ptr[m+1] - 1;
+ if (size < m) size = m;
+ S_ind = xcalloc(1+size, sizeof(int));
+ /* allocate and initialize working arrays */
+ ind = xcalloc(1+m, sizeof(int));
+ map = xcalloc(1+m, sizeof(int));
+ for (jj = 1; jj <= m; jj++) map[jj] = 0;
+ /* compute pattern of S; note that symbolically S = B*B', where
+ B = P*A, B' is matrix transposed to B */
+ S_ptr[1] = 1;
+ for (ii = 1; ii <= m; ii++)
+ { /* compute pattern of ii-th row of S */
+ len = 0;
+ i = P_per[ii]; /* i-th row of A = ii-th row of B */
+ for (t = A_ptr[i]; t < A_ptr[i+1]; t++)
+ { k = A_ind[t];
+ /* walk through k-th column of A */
+ for (tt = AT_ptr[k]; tt < AT_ptr[k+1]; tt++)
+ { j = AT_ind[tt];
+ jj = P_per[m+j]; /* j-th row of A = jj-th row of B */
+ /* a[i,k] != 0 and a[j,k] != 0 ergo s[ii,jj] != 0 */
+ if (ii < jj && !map[jj]) ind[++len] = jj, map[jj] = 1;
+ }
+ }
+ /* now (ind) is pattern of ii-th row of S */
+ S_ptr[ii+1] = S_ptr[ii] + len;
+ /* at least (S_ptr[ii+1] - 1) locations should be available in
+ the array S_ind */
+ if (S_ptr[ii+1] - 1 > size)
+ { temp = S_ind;
+ size += size;
+ S_ind = xcalloc(1+size, sizeof(int));
+ memcpy(&S_ind[1], &temp[1], (S_ptr[ii] - 1) * sizeof(int));
+ xfree(temp);
+ }
+ xassert(S_ptr[ii+1] - 1 <= size);
+ /* (ii-th row of S) := (ind) */
+ memcpy(&S_ind[S_ptr[ii]], &ind[1], len * sizeof(int));
+ /* clear the row pattern map */
+ for (t = 1; t <= len; t++) map[ind[t]] = 0;
+ }
+ /* free working arrays */
+ xfree(AT_ptr);
+ xfree(AT_ind);
+ xfree(ind);
+ xfree(map);
+ /* reallocate the array S_ind to free unused locations */
+ temp = S_ind;
+ size = S_ptr[m+1] - 1;
+ S_ind = xcalloc(1+size, sizeof(int));
+ memcpy(&S_ind[1], &temp[1], size * sizeof(int));
+ xfree(temp);
+ return S_ind;
+}
+
+/*----------------------------------------------------------------------
+-- adat_numeric - compute S = P*A*D*A'*P' (numeric phase).
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- void adat_numeric(int m, int n, int P_per[],
+-- int A_ptr[], int A_ind[], double A_val[], double D_diag[],
+-- int S_ptr[], int S_ind[], double S_val[], double S_diag[]);
+--
+-- *Description*
+--
+-- The routine adat_numeric implements the numeric phase to compute
+-- symmetric matrix S = P*A*D*A'*P', where P is a permutation matrix,
+-- A is a given sparse matrix, D is a diagonal matrix, A' is a matrix
+-- transposed to A, P' is an inverse of P.
+--
+-- The parameter m is the number of rows in A and the order of P.
+--
+-- The parameter n is the number of columns in A and the order of D.
+--
+-- The matrix P is specified in the array P_per, which is not changed
+-- on exit.
+--
+-- The matrix A is specified in the arrays A_ptr, A_ind, and A_val in
+-- storage-by-rows format. These arrays are not changed on exit.
+--
+-- Diagonal elements of the matrix D are specified in the array D_diag,
+-- where D_diag[0] is not used, D_diag[i] = d[i,i] for i = 1, ..., n.
+-- The array D_diag is not changed on exit.
+--
+-- The pattern of the upper triangular part of the matrix S without
+-- diagonal elements (previously computed by the routine adat_symbolic)
+-- is specified in the arrays S_ptr and S_ind, which are not changed on
+-- exit. Numeric values of non-diagonal elements of S are stored in
+-- corresponding locations of the array S_val, and values of diagonal
+-- elements of S are stored in locations S_diag[1], ..., S_diag[n]. */
+
+void adat_numeric(int m, int n, int P_per[],
+ int A_ptr[], int A_ind[], double A_val[], double D_diag[],
+ int S_ptr[], int S_ind[], double S_val[], double S_diag[])
+{ int i, j, t, ii, jj, tt, beg, end, beg1, end1, k;
+ double sum, *work;
+ work = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++) work[j] = 0.0;
+ /* compute S = B*D*B', where B = P*A, B' is a matrix transposed
+ to B */
+ for (ii = 1; ii <= m; ii++)
+ { i = P_per[ii]; /* i-th row of A = ii-th row of B */
+ /* (work) := (i-th row of A) */
+ beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++)
+ work[A_ind[t]] = A_val[t];
+ /* compute ii-th row of S */
+ beg = S_ptr[ii], end = S_ptr[ii+1];
+ for (t = beg; t < end; t++)
+ { jj = S_ind[t];
+ j = P_per[jj]; /* j-th row of A = jj-th row of B */
+ /* s[ii,jj] := sum a[i,k] * d[k,k] * a[j,k] */
+ sum = 0.0;
+ beg1 = A_ptr[j], end1 = A_ptr[j+1];
+ for (tt = beg1; tt < end1; tt++)
+ { k = A_ind[tt];
+ sum += work[k] * D_diag[k] * A_val[tt];
+ }
+ S_val[t] = sum;
+ }
+ /* s[ii,ii] := sum a[i,k] * d[k,k] * a[i,k] */
+ sum = 0.0;
+ beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++)
+ { k = A_ind[t];
+ sum += A_val[t] * D_diag[k] * A_val[t];
+ work[k] = 0.0;
+ }
+ S_diag[ii] = sum;
+ }
+ xfree(work);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- min_degree - minimum degree ordering.
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- void min_degree(int n, int A_ptr[], int A_ind[], int P_per[]);
+--
+-- *Description*
+--
+-- The routine min_degree uses the minimum degree ordering algorithm
+-- to find a permutation matrix P for a given sparse symmetric positive
+-- matrix A which minimizes the number of non-zeros in upper triangular
+-- factor U for Cholesky factorization P*A*P' = U'*U.
+--
+-- The parameter n is the order of matrices A and P.
+--
+-- The pattern of the given matrix A is specified on entry in the arrays
+-- A_ptr and A_ind in storage-by-rows format. Only the upper triangular
+-- part without diagonal elements (which all are assumed to be non-zero)
+-- should be specified as if A were upper triangular. The arrays A_ptr
+-- and A_ind are not changed on exit.
+--
+-- The permutation matrix P is stored by the routine in the array P_per
+-- on exit.
+--
+-- *Algorithm*
+--
+-- The routine min_degree is based on some subroutines from the package
+-- SPARSPAK (see comments in the module glpqmd). */
+
+void min_degree(int n, int A_ptr[], int A_ind[], int P_per[])
+{ int i, j, ne, t, pos, len;
+ int *xadj, *adjncy, *deg, *marker, *rchset, *nbrhd, *qsize,
+ *qlink, nofsub;
+ /* determine number of non-zeros in complete pattern */
+ ne = A_ptr[n+1] - 1;
+ ne += ne;
+ /* allocate working arrays */
+ xadj = xcalloc(1+n+1, sizeof(int));
+ adjncy = xcalloc(1+ne, sizeof(int));
+ deg = xcalloc(1+n, sizeof(int));
+ marker = xcalloc(1+n, sizeof(int));
+ rchset = xcalloc(1+n, sizeof(int));
+ nbrhd = xcalloc(1+n, sizeof(int));
+ qsize = xcalloc(1+n, sizeof(int));
+ qlink = xcalloc(1+n, sizeof(int));
+ /* determine row lengths in complete pattern */
+ for (i = 1; i <= n; i++) xadj[i] = 0;
+ for (i = 1; i <= n; i++)
+ { for (t = A_ptr[i]; t < A_ptr[i+1]; t++)
+ { j = A_ind[t];
+ xassert(i < j && j <= n);
+ xadj[i]++, xadj[j]++;
+ }
+ }
+ /* set up row pointers for complete pattern */
+ pos = 1;
+ for (i = 1; i <= n; i++)
+ len = xadj[i], pos += len, xadj[i] = pos;
+ xadj[n+1] = pos;
+ xassert(pos - 1 == ne);
+ /* construct complete pattern */
+ for (i = 1; i <= n; i++)
+ { for (t = A_ptr[i]; t < A_ptr[i+1]; t++)
+ { j = A_ind[t];
+ adjncy[--xadj[i]] = j, adjncy[--xadj[j]] = i;
+ }
+ }
+ /* call the main minimimum degree ordering routine */
+ genqmd(&n, xadj, adjncy, P_per, P_per + n, deg, marker, rchset,
+ nbrhd, qsize, qlink, &nofsub);
+ /* make sure that permutation matrix P is correct */
+ for (i = 1; i <= n; i++)
+ { j = P_per[i];
+ xassert(1 <= j && j <= n);
+ xassert(P_per[n+j] == i);
+ }
+ /* free working arrays */
+ xfree(xadj);
+ xfree(adjncy);
+ xfree(deg);
+ xfree(marker);
+ xfree(rchset);
+ xfree(nbrhd);
+ xfree(qsize);
+ xfree(qlink);
+ return;
+}
+
+/**********************************************************************/
+
+void amd_order1(int n, int A_ptr[], int A_ind[], int P_per[])
+{ /* approximate minimum degree ordering (AMD) */
+ int k, ret;
+ double Control[AMD_CONTROL], Info[AMD_INFO];
+ /* get the default parameters */
+ amd_defaults(Control);
+#if 0
+ /* and print them */
+ amd_control(Control);
+#endif
+ /* make all indices 0-based */
+ for (k = 1; k < A_ptr[n+1]; k++) A_ind[k]--;
+ for (k = 1; k <= n+1; k++) A_ptr[k]--;
+ /* call the ordering routine */
+ ret = amd_order(n, &A_ptr[1], &A_ind[1], &P_per[1], Control, Info)
+ ;
+#if 0
+ amd_info(Info);
+#endif
+ xassert(ret == AMD_OK || ret == AMD_OK_BUT_JUMBLED);
+ /* retsore 1-based indices */
+ for (k = 1; k <= n+1; k++) A_ptr[k]++;
+ for (k = 1; k < A_ptr[n+1]; k++) A_ind[k]++;
+ /* patch up permutation matrix */
+ memset(&P_per[n+1], 0, n * sizeof(int));
+ for (k = 1; k <= n; k++)
+ { P_per[k]++;
+ xassert(1 <= P_per[k] && P_per[k] <= n);
+ xassert(P_per[n+P_per[k]] == 0);
+ P_per[n+P_per[k]] = k;
+ }
+ return;
+}
+
+/**********************************************************************/
+
+static void *allocate(size_t n, size_t size)
+{ void *ptr;
+ ptr = xcalloc(n, size);
+ memset(ptr, 0, n * size);
+ return ptr;
+}
+
+static void release(void *ptr)
+{ xfree(ptr);
+ return;
+}
+
+void symamd_ord(int n, int A_ptr[], int A_ind[], int P_per[])
+{ /* approximate minimum degree ordering (SYMAMD) */
+ int k, ok;
+ int stats[COLAMD_STATS];
+ /* make all indices 0-based */
+ for (k = 1; k < A_ptr[n+1]; k++) A_ind[k]--;
+ for (k = 1; k <= n+1; k++) A_ptr[k]--;
+ /* call the ordering routine */
+ ok = symamd(n, &A_ind[1], &A_ptr[1], &P_per[1], NULL, stats,
+ allocate, release);
+#if 0
+ symamd_report(stats);
+#endif
+ xassert(ok);
+ /* restore 1-based indices */
+ for (k = 1; k <= n+1; k++) A_ptr[k]++;
+ for (k = 1; k < A_ptr[n+1]; k++) A_ind[k]++;
+ /* patch up permutation matrix */
+ memset(&P_per[n+1], 0, n * sizeof(int));
+ for (k = 1; k <= n; k++)
+ { P_per[k]++;
+ xassert(1 <= P_per[k] && P_per[k] <= n);
+ xassert(P_per[n+P_per[k]] == 0);
+ P_per[n+P_per[k]] = k;
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- chol_symbolic - compute Cholesky factorization (symbolic phase).
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- int *chol_symbolic(int n, int A_ptr[], int A_ind[], int U_ptr[]);
+--
+-- *Description*
+--
+-- The routine chol_symbolic implements the symbolic phase of Cholesky
+-- factorization A = U'*U, where A is a given sparse symmetric positive
+-- definite matrix, U is a resultant upper triangular factor, U' is a
+-- matrix transposed to U.
+--
+-- The parameter n is the order of matrices A and U.
+--
+-- The pattern of the given matrix A is specified on entry in the arrays
+-- A_ptr and A_ind in storage-by-rows format. Only the upper triangular
+-- part without diagonal elements (which all are assumed to be non-zero)
+-- should be specified as if A were upper triangular. The arrays A_ptr
+-- and A_ind are not changed on exit.
+--
+-- The pattern of the matrix U without diagonal elements (which all are
+-- assumed to be non-zero) is stored on exit from the routine in the
+-- arrays U_ptr and U_ind in storage-by-rows format. The array U_ptr
+-- should be allocated on entry, however, its content is ignored. The
+-- array U_ind is allocated by the routine which returns a pointer to it
+-- on exit.
+--
+-- *Returns*
+--
+-- The routine returns a pointer to the array U_ind.
+--
+-- *Method*
+--
+-- The routine chol_symbolic computes the pattern of the matrix U in a
+-- row-wise manner. No pivoting is used.
+--
+-- It is known that to compute the pattern of row k of the matrix U we
+-- need to merge the pattern of row k of the matrix A and the patterns
+-- of each row i of U, where u[i,k] is non-zero (these rows are already
+-- computed and placed above row k).
+--
+-- However, to reduce the number of rows to be merged the routine uses
+-- an advanced algorithm proposed in:
+--
+-- D.J.Rose, R.E.Tarjan, and G.S.Lueker. Algorithmic aspects of vertex
+-- elimination on graphs. SIAM J. Comput. 5, 1976, 266-83.
+--
+-- The authors of the cited paper show that we have the same result if
+-- we merge row k of the matrix A and such rows of the matrix U (among
+-- rows 1, ..., k-1) whose leftmost non-diagonal non-zero element is
+-- placed in k-th column. This feature signficantly reduces the number
+-- of rows to be merged, especially on the final steps, where rows of
+-- the matrix U become quite dense.
+--
+-- To determine rows, which should be merged on k-th step, for a fixed
+-- time the routine uses linked lists of row numbers of the matrix U.
+-- Location head[k] contains the number of a first row, whose leftmost
+-- non-diagonal non-zero element is placed in column k, and location
+-- next[i] contains the number of a next row with the same property as
+-- row i. */
+
+int *chol_symbolic(int n, int A_ptr[], int A_ind[], int U_ptr[])
+{ int i, j, k, t, len, size, beg, end, min_j, *U_ind, *head, *next,
+ *ind, *map, *temp;
+ /* initially we assume that on computing the pattern of U fill-in
+ will double the number of non-zeros in A */
+ size = A_ptr[n+1] - 1;
+ if (size < n) size = n;
+ size += size;
+ U_ind = xcalloc(1+size, sizeof(int));
+ /* allocate and initialize working arrays */
+ head = xcalloc(1+n, sizeof(int));
+ for (i = 1; i <= n; i++) head[i] = 0;
+ next = xcalloc(1+n, sizeof(int));
+ ind = xcalloc(1+n, sizeof(int));
+ map = xcalloc(1+n, sizeof(int));
+ for (j = 1; j <= n; j++) map[j] = 0;
+ /* compute the pattern of matrix U */
+ U_ptr[1] = 1;
+ for (k = 1; k <= n; k++)
+ { /* compute the pattern of k-th row of U, which is the union of
+ k-th row of A and those rows of U (among 1, ..., k-1) whose
+ leftmost non-diagonal non-zero is placed in k-th column */
+ /* (ind) := (k-th row of A) */
+ len = A_ptr[k+1] - A_ptr[k];
+ memcpy(&ind[1], &A_ind[A_ptr[k]], len * sizeof(int));
+ for (t = 1; t <= len; t++)
+ { j = ind[t];
+ xassert(k < j && j <= n);
+ map[j] = 1;
+ }
+ /* walk through rows of U whose leftmost non-diagonal non-zero
+ is placed in k-th column */
+ for (i = head[k]; i != 0; i = next[i])
+ { /* (ind) := (ind) union (i-th row of U) */
+ beg = U_ptr[i], end = U_ptr[i+1];
+ for (t = beg; t < end; t++)
+ { j = U_ind[t];
+ if (j > k && !map[j]) ind[++len] = j, map[j] = 1;
+ }
+ }
+ /* now (ind) is the pattern of k-th row of U */
+ U_ptr[k+1] = U_ptr[k] + len;
+ /* at least (U_ptr[k+1] - 1) locations should be available in
+ the array U_ind */
+ if (U_ptr[k+1] - 1 > size)
+ { temp = U_ind;
+ size += size;
+ U_ind = xcalloc(1+size, sizeof(int));
+ memcpy(&U_ind[1], &temp[1], (U_ptr[k] - 1) * sizeof(int));
+ xfree(temp);
+ }
+ xassert(U_ptr[k+1] - 1 <= size);
+ /* (k-th row of U) := (ind) */
+ memcpy(&U_ind[U_ptr[k]], &ind[1], len * sizeof(int));
+ /* determine column index of leftmost non-diagonal non-zero in
+ k-th row of U and clear the row pattern map */
+ min_j = n + 1;
+ for (t = 1; t <= len; t++)
+ { j = ind[t], map[j] = 0;
+ if (min_j > j) min_j = j;
+ }
+ /* include k-th row into corresponding linked list */
+ if (min_j <= n) next[k] = head[min_j], head[min_j] = k;
+ }
+ /* free working arrays */
+ xfree(head);
+ xfree(next);
+ xfree(ind);
+ xfree(map);
+ /* reallocate the array U_ind to free unused locations */
+ temp = U_ind;
+ size = U_ptr[n+1] - 1;
+ U_ind = xcalloc(1+size, sizeof(int));
+ memcpy(&U_ind[1], &temp[1], size * sizeof(int));
+ xfree(temp);
+ return U_ind;
+}
+
+/*----------------------------------------------------------------------
+-- chol_numeric - compute Cholesky factorization (numeric phase).
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- int chol_numeric(int n,
+-- int A_ptr[], int A_ind[], double A_val[], double A_diag[],
+-- int U_ptr[], int U_ind[], double U_val[], double U_diag[]);
+--
+-- *Description*
+--
+-- The routine chol_symbolic implements the numeric phase of Cholesky
+-- factorization A = U'*U, where A is a given sparse symmetric positive
+-- definite matrix, U is a resultant upper triangular factor, U' is a
+-- matrix transposed to U.
+--
+-- The parameter n is the order of matrices A and U.
+--
+-- Upper triangular part of the matrix A without diagonal elements is
+-- specified in the arrays A_ptr, A_ind, and A_val in storage-by-rows
+-- format. Diagonal elements of A are specified in the array A_diag,
+-- where A_diag[0] is not used, A_diag[i] = a[i,i] for i = 1, ..., n.
+-- The arrays A_ptr, A_ind, A_val, and A_diag are not changed on exit.
+--
+-- The pattern of the matrix U without diagonal elements (previously
+-- computed with the routine chol_symbolic) is specified in the arrays
+-- U_ptr and U_ind, which are not changed on exit. Numeric values of
+-- non-diagonal elements of U are stored in corresponding locations of
+-- the array U_val, and values of diagonal elements of U are stored in
+-- locations U_diag[1], ..., U_diag[n].
+--
+-- *Returns*
+--
+-- The routine returns the number of non-positive diagonal elements of
+-- the matrix U which have been replaced by a huge positive number (see
+-- the method description below). Zero return code means the matrix A
+-- has been successfully factorized.
+--
+-- *Method*
+--
+-- The routine chol_numeric computes the matrix U in a row-wise manner
+-- using standard gaussian elimination technique. No pivoting is used.
+--
+-- Initially the routine sets U = A, and before k-th elimination step
+-- the matrix U is the following:
+--
+-- 1 k n
+-- 1 x x x x x x x x x x
+-- . x x x x x x x x x
+-- . . x x x x x x x x
+-- . . . x x x x x x x
+-- k . . . . * * * * * *
+-- . . . . * * * * * *
+-- . . . . * * * * * *
+-- . . . . * * * * * *
+-- . . . . * * * * * *
+-- n . . . . * * * * * *
+--
+-- where 'x' are elements of already computed rows, '*' are elements of
+-- the active submatrix. (Note that the lower triangular part of the
+-- active submatrix being symmetric is not stored and diagonal elements
+-- are stored separately in the array U_diag.)
+--
+-- The matrix A is assumed to be positive definite. However, if it is
+-- close to semi-definite, on some elimination step a pivot u[k,k] may
+-- happen to be non-positive due to round-off errors. In this case the
+-- routine uses a technique proposed in:
+--
+-- S.J.Wright. The Cholesky factorization in interior-point and barrier
+-- methods. Preprint MCS-P600-0596, Mathematics and Computer Science
+-- Division, Argonne National Laboratory, Argonne, Ill., May 1996.
+--
+-- The routine just replaces non-positive u[k,k] by a huge positive
+-- number. This involves non-diagonal elements in k-th row of U to be
+-- close to zero that, in turn, involves k-th component of a solution
+-- vector to be close to zero. Note, however, that this technique works
+-- only if the system A*x = b is consistent. */
+
+int chol_numeric(int n,
+ int A_ptr[], int A_ind[], double A_val[], double A_diag[],
+ int U_ptr[], int U_ind[], double U_val[], double U_diag[])
+{ int i, j, k, t, t1, beg, end, beg1, end1, count = 0;
+ double ukk, uki, *work;
+ work = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++) work[j] = 0.0;
+ /* U := (upper triangle of A) */
+ /* note that the upper traingle of A is a subset of U */
+ for (i = 1; i <= n; i++)
+ { beg = A_ptr[i], end = A_ptr[i+1];
+ for (t = beg; t < end; t++)
+ j = A_ind[t], work[j] = A_val[t];
+ beg = U_ptr[i], end = U_ptr[i+1];
+ for (t = beg; t < end; t++)
+ j = U_ind[t], U_val[t] = work[j], work[j] = 0.0;
+ U_diag[i] = A_diag[i];
+ }
+ /* main elimination loop */
+ for (k = 1; k <= n; k++)
+ { /* transform k-th row of U */
+ ukk = U_diag[k];
+ if (ukk > 0.0)
+ U_diag[k] = ukk = sqrt(ukk);
+ else
+ U_diag[k] = ukk = DBL_MAX, count++;
+ /* (work) := (transformed k-th row) */
+ beg = U_ptr[k], end = U_ptr[k+1];
+ for (t = beg; t < end; t++)
+ work[U_ind[t]] = (U_val[t] /= ukk);
+ /* transform other rows of U */
+ for (t = beg; t < end; t++)
+ { i = U_ind[t];
+ xassert(i > k);
+ /* (i-th row) := (i-th row) - u[k,i] * (k-th row) */
+ uki = work[i];
+ beg1 = U_ptr[i], end1 = U_ptr[i+1];
+ for (t1 = beg1; t1 < end1; t1++)
+ U_val[t1] -= uki * work[U_ind[t1]];
+ U_diag[i] -= uki * uki;
+ }
+ /* (work) := 0 */
+ for (t = beg; t < end; t++)
+ work[U_ind[t]] = 0.0;
+ }
+ xfree(work);
+ return count;
+}
+
+/*----------------------------------------------------------------------
+-- u_solve - solve upper triangular system U*x = b.
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- void u_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+-- double U_diag[], double x[]);
+--
+-- *Description*
+--
+-- The routine u_solve solves an linear system U*x = b, where U is an
+-- upper triangular matrix.
+--
+-- The parameter n is the order of matrix U.
+--
+-- The matrix U without diagonal elements is specified in the arrays
+-- U_ptr, U_ind, and U_val in storage-by-rows format. Diagonal elements
+-- of U are specified in the array U_diag, where U_diag[0] is not used,
+-- U_diag[i] = u[i,i] for i = 1, ..., n. All these four arrays are not
+-- changed on exit.
+--
+-- The right-hand side vector b is specified on entry in the array x,
+-- where x[0] is not used, and x[i] = b[i] for i = 1, ..., n. On exit
+-- the routine stores computed components of the vector of unknowns x
+-- in the array x in the same manner. */
+
+void u_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+ double U_diag[], double x[])
+{ int i, t, beg, end;
+ double temp;
+ for (i = n; i >= 1; i--)
+ { temp = x[i];
+ beg = U_ptr[i], end = U_ptr[i+1];
+ for (t = beg; t < end; t++)
+ temp -= U_val[t] * x[U_ind[t]];
+ xassert(U_diag[i] != 0.0);
+ x[i] = temp / U_diag[i];
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- ut_solve - solve lower triangular system U'*x = b.
+--
+-- *Synopsis*
+--
+-- #include "glpmat.h"
+-- void ut_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+-- double U_diag[], double x[]);
+--
+-- *Description*
+--
+-- The routine ut_solve solves an linear system U'*x = b, where U is a
+-- matrix transposed to an upper triangular matrix.
+--
+-- The parameter n is the order of matrix U.
+--
+-- The matrix U without diagonal elements is specified in the arrays
+-- U_ptr, U_ind, and U_val in storage-by-rows format. Diagonal elements
+-- of U are specified in the array U_diag, where U_diag[0] is not used,
+-- U_diag[i] = u[i,i] for i = 1, ..., n. All these four arrays are not
+-- changed on exit.
+--
+-- The right-hand side vector b is specified on entry in the array x,
+-- where x[0] is not used, and x[i] = b[i] for i = 1, ..., n. On exit
+-- the routine stores computed components of the vector of unknowns x
+-- in the array x in the same manner. */
+
+void ut_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+ double U_diag[], double x[])
+{ int i, t, beg, end;
+ double temp;
+ for (i = 1; i <= n; i++)
+ { xassert(U_diag[i] != 0.0);
+ temp = (x[i] /= U_diag[i]);
+ if (temp == 0.0) continue;
+ beg = U_ptr[i], end = U_ptr[i+1];
+ for (t = beg; t < end; t++)
+ x[U_ind[t]] -= U_val[t] * temp;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpmat.h b/test/monniaux/glpk-4.65/src/draft/glpmat.h
new file mode 100644
index 00000000..5b058437
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpmat.h
@@ -0,0 +1,198 @@
+/* glpmat.h (linear algebra routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPMAT_H
+#define GLPMAT_H
+
+/***********************************************************************
+* FULL-VECTOR STORAGE
+*
+* For a sparse vector x having n elements, ne of which are non-zero,
+* the full-vector storage format uses two arrays x_ind and x_vec, which
+* are set up as follows:
+*
+* x_ind is an integer array of length [1+ne]. Location x_ind[0] is
+* not used, and locations x_ind[1], ..., x_ind[ne] contain indices of
+* non-zero elements in vector x.
+*
+* x_vec is a floating-point array of length [1+n]. Location x_vec[0]
+* is not used, and locations x_vec[1], ..., x_vec[n] contain numeric
+* values of ALL elements in vector x, including its zero elements.
+*
+* Let, for example, the following sparse vector x be given:
+*
+* (0, 1, 0, 0, 2, 3, 0, 4)
+*
+* Then the arrays are:
+*
+* x_ind = { X; 2, 5, 6, 8 }
+*
+* x_vec = { X; 0, 1, 0, 0, 2, 3, 0, 4 }
+*
+* COMPRESSED-VECTOR STORAGE
+*
+* For a sparse vector x having n elements, ne of which are non-zero,
+* the compressed-vector storage format uses two arrays x_ind and x_vec,
+* which are set up as follows:
+*
+* x_ind is an integer array of length [1+ne]. Location x_ind[0] is
+* not used, and locations x_ind[1], ..., x_ind[ne] contain indices of
+* non-zero elements in vector x.
+*
+* x_vec is a floating-point array of length [1+ne]. Location x_vec[0]
+* is not used, and locations x_vec[1], ..., x_vec[ne] contain numeric
+* values of corresponding non-zero elements in vector x.
+*
+* Let, for example, the following sparse vector x be given:
+*
+* (0, 1, 0, 0, 2, 3, 0, 4)
+*
+* Then the arrays are:
+*
+* x_ind = { X; 2, 5, 6, 8 }
+*
+* x_vec = { X; 1, 2, 3, 4 }
+*
+* STORAGE-BY-ROWS
+*
+* For a sparse matrix A, which has m rows, n columns, and ne non-zero
+* elements the storage-by-rows format uses three arrays A_ptr, A_ind,
+* and A_val, which are set up as follows:
+*
+* A_ptr is an integer array of length [1+m+1] also called "row pointer
+* array". It contains the relative starting positions of each row of A
+* in the arrays A_ind and A_val, i.e. element A_ptr[i], 1 <= i <= m,
+* indicates where row i begins in the arrays A_ind and A_val. If all
+* elements in row i are zero, then A_ptr[i] = A_ptr[i+1]. Location
+* A_ptr[0] is not used, location A_ptr[1] must contain 1, and location
+* A_ptr[m+1] must contain ne+1 that indicates the position after the
+* last element in the arrays A_ind and A_val.
+*
+* A_ind is an integer array of length [1+ne]. Location A_ind[0] is not
+* used, and locations A_ind[1], ..., A_ind[ne] contain column indices
+* of (non-zero) elements in matrix A.
+*
+* A_val is a floating-point array of length [1+ne]. Location A_val[0]
+* is not used, and locations A_val[1], ..., A_val[ne] contain numeric
+* values of non-zero elements in matrix A.
+*
+* Non-zero elements of matrix A are stored contiguously, and the rows
+* of matrix A are stored consecutively from 1 to m in the arrays A_ind
+* and A_val. The elements in each row of A may be stored in any order
+* in A_ind and A_val. Note that elements with duplicate column indices
+* are not allowed.
+*
+* Let, for example, the following sparse matrix A be given:
+*
+* | 11 . 13 . . . |
+* | 21 22 . 24 . . |
+* | . 32 33 . . . |
+* | . . 43 44 . 46 |
+* | . . . . . . |
+* | 61 62 . . . 66 |
+*
+* Then the arrays are:
+*
+* A_ptr = { X; 1, 3, 6, 8, 11, 11; 14 }
+*
+* A_ind = { X; 1, 3; 4, 2, 1; 2, 3; 4, 3, 6; 1, 2, 6 }
+*
+* A_val = { X; 11, 13; 24, 22, 21; 32, 33; 44, 43, 46; 61, 62, 66 }
+*
+* PERMUTATION MATRICES
+*
+* Let P be a permutation matrix of the order n. It is represented as
+* an integer array P_per of length [1+n+n] as follows: if p[i,j] = 1,
+* then P_per[i] = j and P_per[n+j] = i. Location P_per[0] is not used.
+*
+* Let A' = P*A. If i-th row of A corresponds to i'-th row of A', then
+* P_per[i'] = i and P_per[n+i] = i'.
+*
+* References:
+*
+* 1. Gustavson F.G. Some basic techniques for solving sparse systems of
+* linear equations. In Rose and Willoughby (1972), pp. 41-52.
+*
+* 2. Basic Linear Algebra Subprograms Technical (BLAST) Forum Standard.
+* University of Tennessee (2001). */
+
+#define check_fvs _glp_mat_check_fvs
+int check_fvs(int n, int nnz, int ind[], double vec[]);
+/* check sparse vector in full-vector storage format */
+
+#define check_pattern _glp_mat_check_pattern
+int check_pattern(int m, int n, int A_ptr[], int A_ind[]);
+/* check pattern of sparse matrix */
+
+#define transpose _glp_mat_transpose
+void transpose(int m, int n, int A_ptr[], int A_ind[], double A_val[],
+ int AT_ptr[], int AT_ind[], double AT_val[]);
+/* transpose sparse matrix */
+
+#define adat_symbolic _glp_mat_adat_symbolic
+int *adat_symbolic(int m, int n, int P_per[], int A_ptr[], int A_ind[],
+ int S_ptr[]);
+/* compute S = P*A*D*A'*P' (symbolic phase) */
+
+#define adat_numeric _glp_mat_adat_numeric
+void adat_numeric(int m, int n, int P_per[],
+ int A_ptr[], int A_ind[], double A_val[], double D_diag[],
+ int S_ptr[], int S_ind[], double S_val[], double S_diag[]);
+/* compute S = P*A*D*A'*P' (numeric phase) */
+
+#define min_degree _glp_mat_min_degree
+void min_degree(int n, int A_ptr[], int A_ind[], int P_per[]);
+/* minimum degree ordering */
+
+#define amd_order1 _glp_mat_amd_order1
+void amd_order1(int n, int A_ptr[], int A_ind[], int P_per[]);
+/* approximate minimum degree ordering (AMD) */
+
+#define symamd_ord _glp_mat_symamd_ord
+void symamd_ord(int n, int A_ptr[], int A_ind[], int P_per[]);
+/* approximate minimum degree ordering (SYMAMD) */
+
+#define chol_symbolic _glp_mat_chol_symbolic
+int *chol_symbolic(int n, int A_ptr[], int A_ind[], int U_ptr[]);
+/* compute Cholesky factorization (symbolic phase) */
+
+#define chol_numeric _glp_mat_chol_numeric
+int chol_numeric(int n,
+ int A_ptr[], int A_ind[], double A_val[], double A_diag[],
+ int U_ptr[], int U_ind[], double U_val[], double U_diag[]);
+/* compute Cholesky factorization (numeric phase) */
+
+#define u_solve _glp_mat_u_solve
+void u_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+ double U_diag[], double x[]);
+/* solve upper triangular system U*x = b */
+
+#define ut_solve _glp_mat_ut_solve
+void ut_solve(int n, int U_ptr[], int U_ind[], double U_val[],
+ double U_diag[], double x[]);
+/* solve lower triangular system U'*x = b */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glprgr.c b/test/monniaux/glpk-4.65/src/draft/glprgr.c
new file mode 100644
index 00000000..fbff6b8d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glprgr.c
@@ -0,0 +1,173 @@
+/* glprgr.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#define _GLPSTD_ERRNO
+#define _GLPSTD_STDIO
+#include "env.h"
+#include "glprgr.h"
+#define xfault xerror
+
+/***********************************************************************
+* NAME
+*
+* rgr_write_bmp16 - write 16-color raster image in BMP file format
+*
+* SYNOPSIS
+*
+* #include "glprgr.h"
+* int rgr_write_bmp16(const char *fname, int m, int n, const char
+* map[]);
+*
+* DESCRIPTION
+*
+* The routine rgr_write_bmp16 writes 16-color raster image in
+* uncompressed BMP file format (Windows bitmap) to a binary file whose
+* name is specified by the character string fname.
+*
+* The parameters m and n specify, respectively, the number of rows and
+* the numbers of columns (i.e. height and width) of the raster image.
+*
+* The character array map has m*n elements. Elements map[0, ..., n-1]
+* correspond to the first (top) scanline, elements map[n, ..., 2*n-1]
+* correspond to the second scanline, etc.
+*
+* Each element of the array map specifies a color of the corresponding
+* pixel as 8-bit binary number XXXXIRGB, where four high-order bits (X)
+* are ignored, I is high intensity bit, R is red color bit, G is green
+* color bit, and B is blue color bit. Thus, all 16 possible colors are
+* coded as following hexadecimal numbers:
+*
+* 0x00 = black 0x08 = dark gray
+* 0x01 = blue 0x09 = bright blue
+* 0x02 = green 0x0A = bright green
+* 0x03 = cyan 0x0B = bright cyan
+* 0x04 = red 0x0C = bright red
+* 0x05 = magenta 0x0D = bright magenta
+* 0x06 = brown 0x0E = yellow
+* 0x07 = light gray 0x0F = white
+*
+* RETURNS
+*
+* If no error occured, the routine returns zero; otherwise, it prints
+* an appropriate error message and returns non-zero. */
+
+static void put_byte(FILE *fp, int c)
+{ fputc(c, fp);
+ return;
+}
+
+static void put_word(FILE *fp, int w)
+{ /* big endian */
+ put_byte(fp, w);
+ put_byte(fp, w >> 8);
+ return;
+}
+
+static void put_dword(FILE *fp, int d)
+{ /* big endian */
+ put_word(fp, d);
+ put_word(fp, d >> 16);
+ return;
+}
+
+int rgr_write_bmp16(const char *fname, int m, int n, const char map[])
+{ FILE *fp;
+ int offset, bmsize, i, j, b, ret = 0;
+ if (!(1 <= m && m <= 32767))
+ xfault("rgr_write_bmp16: m = %d; invalid height\n", m);
+ if (!(1 <= n && n <= 32767))
+ xfault("rgr_write_bmp16: n = %d; invalid width\n", n);
+ fp = fopen(fname, "wb");
+ if (fp == NULL)
+ { xprintf("rgr_write_bmp16: unable to create '%s' - %s\n",
+#if 0 /* 29/I-2017 */
+ fname, strerror(errno));
+#else
+ fname, xstrerr(errno));
+#endif
+ ret = 1;
+ goto fini;
+ }
+ offset = 14 + 40 + 16 * 4;
+ bmsize = (4 * n + 31) / 32;
+ /* struct BMPFILEHEADER (14 bytes) */
+ /* UINT bfType */ put_byte(fp, 'B'), put_byte(fp, 'M');
+ /* DWORD bfSize */ put_dword(fp, offset + bmsize * 4);
+ /* UINT bfReserved1 */ put_word(fp, 0);
+ /* UNIT bfReserved2 */ put_word(fp, 0);
+ /* DWORD bfOffBits */ put_dword(fp, offset);
+ /* struct BMPINFOHEADER (40 bytes) */
+ /* DWORD biSize */ put_dword(fp, 40);
+ /* LONG biWidth */ put_dword(fp, n);
+ /* LONG biHeight */ put_dword(fp, m);
+ /* WORD biPlanes */ put_word(fp, 1);
+ /* WORD biBitCount */ put_word(fp, 4);
+ /* DWORD biCompression */ put_dword(fp, 0 /* BI_RGB */);
+ /* DWORD biSizeImage */ put_dword(fp, 0);
+ /* LONG biXPelsPerMeter */ put_dword(fp, 2953 /* 75 dpi */);
+ /* LONG biYPelsPerMeter */ put_dword(fp, 2953 /* 75 dpi */);
+ /* DWORD biClrUsed */ put_dword(fp, 0);
+ /* DWORD biClrImportant */ put_dword(fp, 0);
+ /* struct RGBQUAD (16 * 4 = 64 bytes) */
+ /* CGA-compatible colors: */
+ /* 0x00 = black */ put_dword(fp, 0x000000);
+ /* 0x01 = blue */ put_dword(fp, 0x000080);
+ /* 0x02 = green */ put_dword(fp, 0x008000);
+ /* 0x03 = cyan */ put_dword(fp, 0x008080);
+ /* 0x04 = red */ put_dword(fp, 0x800000);
+ /* 0x05 = magenta */ put_dword(fp, 0x800080);
+ /* 0x06 = brown */ put_dword(fp, 0x808000);
+ /* 0x07 = light gray */ put_dword(fp, 0xC0C0C0);
+ /* 0x08 = dark gray */ put_dword(fp, 0x808080);
+ /* 0x09 = bright blue */ put_dword(fp, 0x0000FF);
+ /* 0x0A = bright green */ put_dword(fp, 0x00FF00);
+ /* 0x0B = bright cyan */ put_dword(fp, 0x00FFFF);
+ /* 0x0C = bright red */ put_dword(fp, 0xFF0000);
+ /* 0x0D = bright magenta */ put_dword(fp, 0xFF00FF);
+ /* 0x0E = yellow */ put_dword(fp, 0xFFFF00);
+ /* 0x0F = white */ put_dword(fp, 0xFFFFFF);
+ /* pixel data bits */
+ b = 0;
+ for (i = m - 1; i >= 0; i--)
+ { for (j = 0; j < ((n + 7) / 8) * 8; j++)
+ { b <<= 4;
+ b |= (j < n ? map[i * n + j] & 15 : 0);
+ if (j & 1) put_byte(fp, b);
+ }
+ }
+ fflush(fp);
+ if (ferror(fp))
+ { xprintf("rgr_write_bmp16: write error on '%s' - %s\n",
+#if 0 /* 29/I-2017 */
+ fname, strerror(errno));
+#else
+ fname, xstrerr(errno));
+#endif
+ ret = 1;
+ }
+fini: if (fp != NULL) fclose(fp);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glprgr.h b/test/monniaux/glpk-4.65/src/draft/glprgr.h
new file mode 100644
index 00000000..71e089e9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glprgr.h
@@ -0,0 +1,34 @@
+/* glprgr.h (raster graphics) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPRGR_H
+#define GLPRGR_H
+
+#define rgr_write_bmp16 _glp_rgr_write_bmp16
+int rgr_write_bmp16(const char *fname, int m, int n, const char map[]);
+/* write 16-color raster image in BMP file format */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpscl.c b/test/monniaux/glpk-4.65/src/draft/glpscl.c
new file mode 100644
index 00000000..de769a8b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpscl.c
@@ -0,0 +1,478 @@
+/* glpscl.c (problem scaling routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+#include "prob.h"
+
+/***********************************************************************
+* min_row_aij - determine minimal |a[i,j]| in i-th row
+*
+* This routine returns minimal magnitude of (non-zero) constraint
+* coefficients in i-th row of the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If i-th row of the matrix is empty, the routine returns 1. */
+
+static double min_row_aij(glp_prob *lp, int i, int scaled)
+{ GLPAIJ *aij;
+ double min_aij, temp;
+ xassert(1 <= i && i <= lp->m);
+ min_aij = 1.0;
+ for (aij = lp->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { temp = fabs(aij->val);
+ if (scaled) temp *= (aij->row->rii * aij->col->sjj);
+ if (aij->r_prev == NULL || min_aij > temp)
+ min_aij = temp;
+ }
+ return min_aij;
+}
+
+/***********************************************************************
+* max_row_aij - determine maximal |a[i,j]| in i-th row
+*
+* This routine returns maximal magnitude of (non-zero) constraint
+* coefficients in i-th row of the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If i-th row of the matrix is empty, the routine returns 1. */
+
+static double max_row_aij(glp_prob *lp, int i, int scaled)
+{ GLPAIJ *aij;
+ double max_aij, temp;
+ xassert(1 <= i && i <= lp->m);
+ max_aij = 1.0;
+ for (aij = lp->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { temp = fabs(aij->val);
+ if (scaled) temp *= (aij->row->rii * aij->col->sjj);
+ if (aij->r_prev == NULL || max_aij < temp)
+ max_aij = temp;
+ }
+ return max_aij;
+}
+
+/***********************************************************************
+* min_col_aij - determine minimal |a[i,j]| in j-th column
+*
+* This routine returns minimal magnitude of (non-zero) constraint
+* coefficients in j-th column of the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If j-th column of the matrix is empty, the routine returns 1. */
+
+static double min_col_aij(glp_prob *lp, int j, int scaled)
+{ GLPAIJ *aij;
+ double min_aij, temp;
+ xassert(1 <= j && j <= lp->n);
+ min_aij = 1.0;
+ for (aij = lp->col[j]->ptr; aij != NULL; aij = aij->c_next)
+ { temp = fabs(aij->val);
+ if (scaled) temp *= (aij->row->rii * aij->col->sjj);
+ if (aij->c_prev == NULL || min_aij > temp)
+ min_aij = temp;
+ }
+ return min_aij;
+}
+
+/***********************************************************************
+* max_col_aij - determine maximal |a[i,j]| in j-th column
+*
+* This routine returns maximal magnitude of (non-zero) constraint
+* coefficients in j-th column of the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If j-th column of the matrix is empty, the routine returns 1. */
+
+static double max_col_aij(glp_prob *lp, int j, int scaled)
+{ GLPAIJ *aij;
+ double max_aij, temp;
+ xassert(1 <= j && j <= lp->n);
+ max_aij = 1.0;
+ for (aij = lp->col[j]->ptr; aij != NULL; aij = aij->c_next)
+ { temp = fabs(aij->val);
+ if (scaled) temp *= (aij->row->rii * aij->col->sjj);
+ if (aij->c_prev == NULL || max_aij < temp)
+ max_aij = temp;
+ }
+ return max_aij;
+}
+
+/***********************************************************************
+* min_mat_aij - determine minimal |a[i,j]| in constraint matrix
+*
+* This routine returns minimal magnitude of (non-zero) constraint
+* coefficients in the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If the matrix is empty, the routine returns 1. */
+
+static double min_mat_aij(glp_prob *lp, int scaled)
+{ int i;
+ double min_aij, temp;
+ min_aij = 1.0;
+ for (i = 1; i <= lp->m; i++)
+ { temp = min_row_aij(lp, i, scaled);
+ if (i == 1 || min_aij > temp)
+ min_aij = temp;
+ }
+ return min_aij;
+}
+
+/***********************************************************************
+* max_mat_aij - determine maximal |a[i,j]| in constraint matrix
+*
+* This routine returns maximal magnitude of (non-zero) constraint
+* coefficients in the constraint matrix.
+*
+* If the parameter scaled is zero, the original constraint matrix A is
+* assumed. Otherwise, the scaled constraint matrix R*A*S is assumed.
+*
+* If the matrix is empty, the routine returns 1. */
+
+static double max_mat_aij(glp_prob *lp, int scaled)
+{ int i;
+ double max_aij, temp;
+ max_aij = 1.0;
+ for (i = 1; i <= lp->m; i++)
+ { temp = max_row_aij(lp, i, scaled);
+ if (i == 1 || max_aij < temp)
+ max_aij = temp;
+ }
+ return max_aij;
+}
+
+/***********************************************************************
+* eq_scaling - perform equilibration scaling
+*
+* This routine performs equilibration scaling of rows and columns of
+* the constraint matrix.
+*
+* If the parameter flag is zero, the routine scales rows at first and
+* then columns. Otherwise, the routine scales columns and then rows.
+*
+* Rows are scaled as follows:
+*
+* n
+* a'[i,j] = a[i,j] / max |a[i,j]|, i = 1,...,m.
+* j=1
+*
+* This makes the infinity (maximum) norm of each row of the matrix
+* equal to 1.
+*
+* Columns are scaled as follows:
+*
+* m
+* a'[i,j] = a[i,j] / max |a[i,j]|, j = 1,...,n.
+* i=1
+*
+* This makes the infinity (maximum) norm of each column of the matrix
+* equal to 1. */
+
+static void eq_scaling(glp_prob *lp, int flag)
+{ int i, j, pass;
+ double temp;
+ xassert(flag == 0 || flag == 1);
+ for (pass = 0; pass <= 1; pass++)
+ { if (pass == flag)
+ { /* scale rows */
+ for (i = 1; i <= lp->m; i++)
+ { temp = max_row_aij(lp, i, 1);
+ glp_set_rii(lp, i, glp_get_rii(lp, i) / temp);
+ }
+ }
+ else
+ { /* scale columns */
+ for (j = 1; j <= lp->n; j++)
+ { temp = max_col_aij(lp, j, 1);
+ glp_set_sjj(lp, j, glp_get_sjj(lp, j) / temp);
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* gm_scaling - perform geometric mean scaling
+*
+* This routine performs geometric mean scaling of rows and columns of
+* the constraint matrix.
+*
+* If the parameter flag is zero, the routine scales rows at first and
+* then columns. Otherwise, the routine scales columns and then rows.
+*
+* Rows are scaled as follows:
+*
+* a'[i,j] = a[i,j] / sqrt(alfa[i] * beta[i]), i = 1,...,m,
+*
+* where:
+* n n
+* alfa[i] = min |a[i,j]|, beta[i] = max |a[i,j]|.
+* j=1 j=1
+*
+* This allows decreasing the ratio beta[i] / alfa[i] for each row of
+* the matrix.
+*
+* Columns are scaled as follows:
+*
+* a'[i,j] = a[i,j] / sqrt(alfa[j] * beta[j]), j = 1,...,n,
+*
+* where:
+* m m
+* alfa[j] = min |a[i,j]|, beta[j] = max |a[i,j]|.
+* i=1 i=1
+*
+* This allows decreasing the ratio beta[j] / alfa[j] for each column
+* of the matrix. */
+
+static void gm_scaling(glp_prob *lp, int flag)
+{ int i, j, pass;
+ double temp;
+ xassert(flag == 0 || flag == 1);
+ for (pass = 0; pass <= 1; pass++)
+ { if (pass == flag)
+ { /* scale rows */
+ for (i = 1; i <= lp->m; i++)
+ { temp = min_row_aij(lp, i, 1) * max_row_aij(lp, i, 1);
+ glp_set_rii(lp, i, glp_get_rii(lp, i) / sqrt(temp));
+ }
+ }
+ else
+ { /* scale columns */
+ for (j = 1; j <= lp->n; j++)
+ { temp = min_col_aij(lp, j, 1) * max_col_aij(lp, j, 1);
+ glp_set_sjj(lp, j, glp_get_sjj(lp, j) / sqrt(temp));
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* max_row_ratio - determine worst scaling "quality" for rows
+*
+* This routine returns the worst scaling "quality" for rows of the
+* currently scaled constraint matrix:
+*
+* m
+* ratio = max ratio[i],
+* i=1
+* where:
+* n n
+* ratio[i] = max |a[i,j]| / min |a[i,j]|, 1 <= i <= m,
+* j=1 j=1
+*
+* is the scaling "quality" of i-th row. */
+
+static double max_row_ratio(glp_prob *lp)
+{ int i;
+ double ratio, temp;
+ ratio = 1.0;
+ for (i = 1; i <= lp->m; i++)
+ { temp = max_row_aij(lp, i, 1) / min_row_aij(lp, i, 1);
+ if (i == 1 || ratio < temp) ratio = temp;
+ }
+ return ratio;
+}
+
+/***********************************************************************
+* max_col_ratio - determine worst scaling "quality" for columns
+*
+* This routine returns the worst scaling "quality" for columns of the
+* currently scaled constraint matrix:
+*
+* n
+* ratio = max ratio[j],
+* j=1
+* where:
+* m m
+* ratio[j] = max |a[i,j]| / min |a[i,j]|, 1 <= j <= n,
+* i=1 i=1
+*
+* is the scaling "quality" of j-th column. */
+
+static double max_col_ratio(glp_prob *lp)
+{ int j;
+ double ratio, temp;
+ ratio = 1.0;
+ for (j = 1; j <= lp->n; j++)
+ { temp = max_col_aij(lp, j, 1) / min_col_aij(lp, j, 1);
+ if (j == 1 || ratio < temp) ratio = temp;
+ }
+ return ratio;
+}
+
+/***********************************************************************
+* gm_iterate - perform iterative geometric mean scaling
+*
+* This routine performs iterative geometric mean scaling of rows and
+* columns of the constraint matrix.
+*
+* The parameter it_max specifies the maximal number of iterations.
+* Recommended value of it_max is 15.
+*
+* The parameter tau specifies a minimal improvement of the scaling
+* "quality" on each iteration, 0 < tau < 1. It means than the scaling
+* process continues while the following condition is satisfied:
+*
+* ratio[k] <= tau * ratio[k-1],
+*
+* where ratio = max |a[i,j]| / min |a[i,j]| is the scaling "quality"
+* to be minimized, k is the iteration number. Recommended value of tau
+* is 0.90. */
+
+static void gm_iterate(glp_prob *lp, int it_max, double tau)
+{ int k, flag;
+ double ratio = 0.0, r_old;
+ /* if the scaling "quality" for rows is better than for columns,
+ the rows are scaled first; otherwise, the columns are scaled
+ first */
+ flag = (max_row_ratio(lp) > max_col_ratio(lp));
+ for (k = 1; k <= it_max; k++)
+ { /* save the scaling "quality" from previous iteration */
+ r_old = ratio;
+ /* determine the current scaling "quality" */
+ ratio = max_mat_aij(lp, 1) / min_mat_aij(lp, 1);
+#if 0
+ xprintf("k = %d; ratio = %g\n", k, ratio);
+#endif
+ /* if improvement is not enough, terminate scaling */
+ if (k > 1 && ratio > tau * r_old) break;
+ /* otherwise, perform another iteration */
+ gm_scaling(lp, flag);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* scale_prob - scale problem data
+*
+* SYNOPSIS
+*
+* #include "glpscl.h"
+* void scale_prob(glp_prob *lp, int flags);
+*
+* DESCRIPTION
+*
+* The routine scale_prob performs automatic scaling of problem data
+* for the specified problem object. */
+
+static void scale_prob(glp_prob *lp, int flags)
+{ static const char *fmt =
+ "%s: min|aij| = %10.3e max|aij| = %10.3e ratio = %10.3e\n";
+ double min_aij, max_aij, ratio;
+ xprintf("Scaling...\n");
+ /* cancel the current scaling effect */
+ glp_unscale_prob(lp);
+ /* report original scaling "quality" */
+ min_aij = min_mat_aij(lp, 1);
+ max_aij = max_mat_aij(lp, 1);
+ ratio = max_aij / min_aij;
+ xprintf(fmt, " A", min_aij, max_aij, ratio);
+ /* check if the problem is well scaled */
+ if (min_aij >= 0.10 && max_aij <= 10.0)
+ { xprintf("Problem data seem to be well scaled\n");
+ /* skip scaling, if required */
+ if (flags & GLP_SF_SKIP) goto done;
+ }
+ /* perform iterative geometric mean scaling, if required */
+ if (flags & GLP_SF_GM)
+ { gm_iterate(lp, 15, 0.90);
+ min_aij = min_mat_aij(lp, 1);
+ max_aij = max_mat_aij(lp, 1);
+ ratio = max_aij / min_aij;
+ xprintf(fmt, "GM", min_aij, max_aij, ratio);
+ }
+ /* perform equilibration scaling, if required */
+ if (flags & GLP_SF_EQ)
+ { eq_scaling(lp, max_row_ratio(lp) > max_col_ratio(lp));
+ min_aij = min_mat_aij(lp, 1);
+ max_aij = max_mat_aij(lp, 1);
+ ratio = max_aij / min_aij;
+ xprintf(fmt, "EQ", min_aij, max_aij, ratio);
+ }
+ /* round scale factors to nearest power of two, if required */
+ if (flags & GLP_SF_2N)
+ { int i, j;
+ for (i = 1; i <= lp->m; i++)
+ glp_set_rii(lp, i, round2n(glp_get_rii(lp, i)));
+ for (j = 1; j <= lp->n; j++)
+ glp_set_sjj(lp, j, round2n(glp_get_sjj(lp, j)));
+ min_aij = min_mat_aij(lp, 1);
+ max_aij = max_mat_aij(lp, 1);
+ ratio = max_aij / min_aij;
+ xprintf(fmt, "2N", min_aij, max_aij, ratio);
+ }
+done: return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_scale_prob - scale problem data
+*
+* SYNOPSIS
+*
+* void glp_scale_prob(glp_prob *lp, int flags);
+*
+* DESCRIPTION
+*
+* The routine glp_scale_prob performs automatic scaling of problem
+* data for the specified problem object.
+*
+* The parameter flags specifies scaling options used by the routine.
+* Options can be combined with the bitwise OR operator and may be the
+* following:
+*
+* GLP_SF_GM perform geometric mean scaling;
+* GLP_SF_EQ perform equilibration scaling;
+* GLP_SF_2N round scale factors to nearest power of two;
+* GLP_SF_SKIP skip scaling, if the problem is well scaled.
+*
+* The parameter flags may be specified as GLP_SF_AUTO, in which case
+* the routine chooses scaling options automatically. */
+
+void glp_scale_prob(glp_prob *lp, int flags)
+{ if (flags & ~(GLP_SF_GM | GLP_SF_EQ | GLP_SF_2N | GLP_SF_SKIP |
+ GLP_SF_AUTO))
+ xerror("glp_scale_prob: flags = 0x%02X; invalid scaling option"
+ "s\n", flags);
+ if (flags & GLP_SF_AUTO)
+ flags = (GLP_SF_GM | GLP_SF_EQ | GLP_SF_SKIP);
+ scale_prob(lp, flags);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpspm.c b/test/monniaux/glpk-4.65/src/draft/glpspm.c
new file mode 100644
index 00000000..c6cfd25d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpspm.c
@@ -0,0 +1,847 @@
+/* glpspm.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "glphbm.h"
+#include "glprgr.h"
+#include "glpspm.h"
+#include "env.h"
+
+/***********************************************************************
+* NAME
+*
+* spm_create_mat - create general sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_create_mat(int m, int n);
+*
+* DESCRIPTION
+*
+* The routine spm_create_mat creates a general sparse matrix having
+* m rows and n columns. Being created the matrix is zero (empty), i.e.
+* has no elements.
+*
+* RETURNS
+*
+* The routine returns a pointer to the matrix created. */
+
+SPM *spm_create_mat(int m, int n)
+{ SPM *A;
+ xassert(0 <= m && m < INT_MAX);
+ xassert(0 <= n && n < INT_MAX);
+ A = xmalloc(sizeof(SPM));
+ A->m = m;
+ A->n = n;
+ if (m == 0 || n == 0)
+ { A->pool = NULL;
+ A->row = NULL;
+ A->col = NULL;
+ }
+ else
+ { int i, j;
+ A->pool = dmp_create_pool();
+ A->row = xcalloc(1+m, sizeof(SPME *));
+ for (i = 1; i <= m; i++) A->row[i] = NULL;
+ A->col = xcalloc(1+n, sizeof(SPME *));
+ for (j = 1; j <= n; j++) A->col[j] = NULL;
+ }
+ return A;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_new_elem - add new element to sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPME *spm_new_elem(SPM *A, int i, int j, double val);
+*
+* DESCRIPTION
+*
+* The routine spm_new_elem adds a new element to the specified sparse
+* matrix. Parameters i, j, and val specify the row number, the column
+* number, and a numerical value of the element, respectively.
+*
+* RETURNS
+*
+* The routine returns a pointer to the new element added. */
+
+SPME *spm_new_elem(SPM *A, int i, int j, double val)
+{ SPME *e;
+ xassert(1 <= i && i <= A->m);
+ xassert(1 <= j && j <= A->n);
+ e = dmp_get_atom(A->pool, sizeof(SPME));
+ e->i = i;
+ e->j = j;
+ e->val = val;
+ e->r_prev = NULL;
+ e->r_next = A->row[i];
+ if (e->r_next != NULL) e->r_next->r_prev = e;
+ e->c_prev = NULL;
+ e->c_next = A->col[j];
+ if (e->c_next != NULL) e->c_next->c_prev = e;
+ A->row[i] = A->col[j] = e;
+ return e;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_delete_mat - delete general sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* void spm_delete_mat(SPM *A);
+*
+* DESCRIPTION
+*
+* The routine deletes the specified general sparse matrix freeing all
+* the memory allocated to this object. */
+
+void spm_delete_mat(SPM *A)
+{ /* delete sparse matrix */
+ if (A->pool != NULL) dmp_delete_pool(A->pool);
+ if (A->row != NULL) xfree(A->row);
+ if (A->col != NULL) xfree(A->col);
+ xfree(A);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_test_mat_e - create test sparse matrix of E(n,c) class
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_test_mat_e(int n, int c);
+*
+* DESCRIPTION
+*
+* The routine spm_test_mat_e creates a test sparse matrix of E(n,c)
+* class as described in the book: Ole 0sterby, Zahari Zlatev. Direct
+* Methods for Sparse Matrices. Springer-Verlag, 1983.
+*
+* Matrix of E(n,c) class is a symmetric positive definite matrix of
+* the order n. It has the number 4 on its main diagonal and the number
+* -1 on its four co-diagonals, two of which are neighbour to the main
+* diagonal and two others are shifted from the main diagonal on the
+* distance c.
+*
+* It is necessary that n >= 3 and 2 <= c <= n-1.
+*
+* RETURNS
+*
+* The routine returns a pointer to the matrix created. */
+
+SPM *spm_test_mat_e(int n, int c)
+{ SPM *A;
+ int i;
+ xassert(n >= 3 && 2 <= c && c <= n-1);
+ A = spm_create_mat(n, n);
+ for (i = 1; i <= n; i++)
+ spm_new_elem(A, i, i, 4.0);
+ for (i = 1; i <= n-1; i++)
+ { spm_new_elem(A, i, i+1, -1.0);
+ spm_new_elem(A, i+1, i, -1.0);
+ }
+ for (i = 1; i <= n-c; i++)
+ { spm_new_elem(A, i, i+c, -1.0);
+ spm_new_elem(A, i+c, i, -1.0);
+ }
+ return A;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_test_mat_d - create test sparse matrix of D(n,c) class
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_test_mat_d(int n, int c);
+*
+* DESCRIPTION
+*
+* The routine spm_test_mat_d creates a test sparse matrix of D(n,c)
+* class as described in the book: Ole 0sterby, Zahari Zlatev. Direct
+* Methods for Sparse Matrices. Springer-Verlag, 1983.
+*
+* Matrix of D(n,c) class is a non-singular matrix of the order n. It
+* has unity main diagonal, three co-diagonals above the main diagonal
+* on the distance c, which are cyclically continued below the main
+* diagonal, and a triangle block of the size 10x10 in the upper right
+* corner.
+*
+* It is necessary that n >= 14 and 1 <= c <= n-13.
+*
+* RETURNS
+*
+* The routine returns a pointer to the matrix created. */
+
+SPM *spm_test_mat_d(int n, int c)
+{ SPM *A;
+ int i, j;
+ xassert(n >= 14 && 1 <= c && c <= n-13);
+ A = spm_create_mat(n, n);
+ for (i = 1; i <= n; i++)
+ spm_new_elem(A, i, i, 1.0);
+ for (i = 1; i <= n-c; i++)
+ spm_new_elem(A, i, i+c, (double)(i+1));
+ for (i = n-c+1; i <= n; i++)
+ spm_new_elem(A, i, i-n+c, (double)(i+1));
+ for (i = 1; i <= n-c-1; i++)
+ spm_new_elem(A, i, i+c+1, (double)(-i));
+ for (i = n-c; i <= n; i++)
+ spm_new_elem(A, i, i-n+c+1, (double)(-i));
+ for (i = 1; i <= n-c-2; i++)
+ spm_new_elem(A, i, i+c+2, 16.0);
+ for (i = n-c-1; i <= n; i++)
+ spm_new_elem(A, i, i-n+c+2, 16.0);
+ for (j = 1; j <= 10; j++)
+ for (i = 1; i <= 11-j; i++)
+ spm_new_elem(A, i, n-11+i+j, 100.0 * (double)j);
+ return A;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_show_mat - write sparse matrix pattern in BMP file format
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* int spm_show_mat(const SPM *A, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine spm_show_mat writes pattern of the specified sparse
+* matrix in uncompressed BMP file format (Windows bitmap) to a binary
+* file whose name is specified by the character string fname.
+*
+* Each pixel corresponds to one matrix element. The pixel colors have
+* the following meaning:
+*
+* Black structurally zero element
+* White positive element
+* Cyan negative element
+* Green zero element
+* Red duplicate element
+*
+* RETURNS
+*
+* If no error occured, the routine returns zero. Otherwise, it prints
+* an appropriate error message and returns non-zero. */
+
+int spm_show_mat(const SPM *A, const char *fname)
+{ int m = A->m;
+ int n = A->n;
+ int i, j, k, ret;
+ char *map;
+ xprintf("spm_show_mat: writing matrix pattern to '%s'...\n",
+ fname);
+ xassert(1 <= m && m <= 32767);
+ xassert(1 <= n && n <= 32767);
+ map = xmalloc(m * n);
+ memset(map, 0x08, m * n);
+ for (i = 1; i <= m; i++)
+ { SPME *e;
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ { j = e->j;
+ xassert(1 <= j && j <= n);
+ k = n * (i - 1) + (j - 1);
+ if (map[k] != 0x08)
+ map[k] = 0x0C;
+ else if (e->val > 0.0)
+ map[k] = 0x0F;
+ else if (e->val < 0.0)
+ map[k] = 0x0B;
+ else
+ map[k] = 0x0A;
+ }
+ }
+ ret = rgr_write_bmp16(fname, m, n, map);
+ xfree(map);
+ return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_read_hbm - read sparse matrix in Harwell-Boeing format
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_read_hbm(const char *fname);
+*
+* DESCRIPTION
+*
+* The routine spm_read_hbm reads a sparse matrix in the Harwell-Boeing
+* format from a text file whose name is the character string fname.
+*
+* Detailed description of the Harwell-Boeing format recognised by this
+* routine can be found in the following report:
+*
+* I.S.Duff, R.G.Grimes, J.G.Lewis. User's Guide for the Harwell-Boeing
+* Sparse Matrix Collection (Release I), TR/PA/92/86, October 1992.
+*
+* NOTE
+*
+* The routine spm_read_hbm reads the matrix "as is", due to which zero
+* and/or duplicate elements can appear in the matrix.
+*
+* RETURNS
+*
+* If no error occured, the routine returns a pointer to the matrix
+* created. Otherwise, the routine prints an appropriate error message
+* and returns NULL. */
+
+SPM *spm_read_hbm(const char *fname)
+{ SPM *A = NULL;
+ HBM *hbm;
+ int nrow, ncol, nnzero, i, j, beg, end, ptr, *colptr, *rowind;
+ double val, *values;
+ char *mxtype;
+ hbm = hbm_read_mat(fname);
+ if (hbm == NULL)
+ { xprintf("spm_read_hbm: unable to read matrix\n");
+ goto fini;
+ }
+ mxtype = hbm->mxtype;
+ nrow = hbm->nrow;
+ ncol = hbm->ncol;
+ nnzero = hbm->nnzero;
+ colptr = hbm->colptr;
+ rowind = hbm->rowind;
+ values = hbm->values;
+ if (!(strcmp(mxtype, "RSA") == 0 || strcmp(mxtype, "PSA") == 0 ||
+ strcmp(mxtype, "RUA") == 0 || strcmp(mxtype, "PUA") == 0 ||
+ strcmp(mxtype, "RRA") == 0 || strcmp(mxtype, "PRA") == 0))
+ { xprintf("spm_read_hbm: matrix type '%s' not supported\n",
+ mxtype);
+ goto fini;
+ }
+ A = spm_create_mat(nrow, ncol);
+ if (mxtype[1] == 'S' || mxtype[1] == 'U')
+ xassert(nrow == ncol);
+ for (j = 1; j <= ncol; j++)
+ { beg = colptr[j];
+ end = colptr[j+1];
+ xassert(1 <= beg && beg <= end && end <= nnzero + 1);
+ for (ptr = beg; ptr < end; ptr++)
+ { i = rowind[ptr];
+ xassert(1 <= i && i <= nrow);
+ if (mxtype[0] == 'R')
+ val = values[ptr];
+ else
+ val = 1.0;
+ spm_new_elem(A, i, j, val);
+ if (mxtype[1] == 'S' && i != j)
+ spm_new_elem(A, j, i, val);
+ }
+ }
+fini: if (hbm != NULL) hbm_free_mat(hbm);
+ return A;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_count_nnz - determine number of non-zeros in sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* int spm_count_nnz(const SPM *A);
+*
+* RETURNS
+*
+* The routine spm_count_nnz returns the number of structural non-zero
+* elements in the specified sparse matrix. */
+
+int spm_count_nnz(const SPM *A)
+{ SPME *e;
+ int i, nnz = 0;
+ for (i = 1; i <= A->m; i++)
+ for (e = A->row[i]; e != NULL; e = e->r_next) nnz++;
+ return nnz;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_drop_zeros - remove zero elements from sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* int spm_drop_zeros(SPM *A, double eps);
+*
+* DESCRIPTION
+*
+* The routine spm_drop_zeros removes all elements from the specified
+* sparse matrix, whose absolute value is less than eps.
+*
+* If the parameter eps is 0, only zero elements are removed from the
+* matrix.
+*
+* RETURNS
+*
+* The routine returns the number of elements removed. */
+
+int spm_drop_zeros(SPM *A, double eps)
+{ SPME *e, *next;
+ int i, count = 0;
+ for (i = 1; i <= A->m; i++)
+ { for (e = A->row[i]; e != NULL; e = next)
+ { next = e->r_next;
+ if (e->val == 0.0 || fabs(e->val) < eps)
+ { /* remove element from the row list */
+ if (e->r_prev == NULL)
+ A->row[e->i] = e->r_next;
+ else
+ e->r_prev->r_next = e->r_next;
+ if (e->r_next == NULL)
+ ;
+ else
+ e->r_next->r_prev = e->r_prev;
+ /* remove element from the column list */
+ if (e->c_prev == NULL)
+ A->col[e->j] = e->c_next;
+ else
+ e->c_prev->c_next = e->c_next;
+ if (e->c_next == NULL)
+ ;
+ else
+ e->c_next->c_prev = e->c_prev;
+ /* return element to the memory pool */
+ dmp_free_atom(A->pool, e, sizeof(SPME));
+ count++;
+ }
+ }
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* spm_read_mat - read sparse matrix from text file
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_read_mat(const char *fname);
+*
+* DESCRIPTION
+*
+* The routine reads a sparse matrix from a text file whose name is
+* specified by the parameter fname.
+*
+* For the file format see description of the routine spm_write_mat.
+*
+* RETURNS
+*
+* On success the routine returns a pointer to the matrix created,
+* otherwise NULL. */
+
+#if 1
+SPM *spm_read_mat(const char *fname)
+{ xassert(fname != fname);
+ return NULL;
+}
+#else
+SPM *spm_read_mat(const char *fname)
+{ SPM *A = NULL;
+ PDS *pds;
+ jmp_buf jump;
+ int i, j, k, m, n, nnz, fail = 0;
+ double val;
+ xprintf("spm_read_mat: reading matrix from '%s'...\n", fname);
+ pds = pds_open_file(fname);
+ if (pds == NULL)
+ { xprintf("spm_read_mat: unable to open '%s' - %s\n", fname,
+ strerror(errno));
+ fail = 1;
+ goto done;
+ }
+ if (setjmp(jump))
+ { fail = 1;
+ goto done;
+ }
+ pds_set_jump(pds, jump);
+ /* number of rows, number of columns, number of non-zeros */
+ m = pds_scan_int(pds);
+ if (m < 0)
+ pds_error(pds, "invalid number of rows\n");
+ n = pds_scan_int(pds);
+ if (n < 0)
+ pds_error(pds, "invalid number of columns\n");
+ nnz = pds_scan_int(pds);
+ if (nnz < 0)
+ pds_error(pds, "invalid number of non-zeros\n");
+ /* create matrix */
+ xprintf("spm_read_mat: %d rows, %d columns, %d non-zeros\n",
+ m, n, nnz);
+ A = spm_create_mat(m, n);
+ /* read matrix elements */
+ for (k = 1; k <= nnz; k++)
+ { /* row index, column index, element value */
+ i = pds_scan_int(pds);
+ if (!(1 <= i && i <= m))
+ pds_error(pds, "row index out of range\n");
+ j = pds_scan_int(pds);
+ if (!(1 <= j && j <= n))
+ pds_error(pds, "column index out of range\n");
+ val = pds_scan_num(pds);
+ /* add new element to the matrix */
+ spm_new_elem(A, i, j, val);
+ }
+ xprintf("spm_read_mat: %d lines were read\n", pds->count);
+done: if (pds != NULL) pds_close_file(pds);
+ if (fail && A != NULL) spm_delete_mat(A), A = NULL;
+ return A;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* spm_write_mat - write sparse matrix to text file
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* int spm_write_mat(const SPM *A, const char *fname);
+*
+* DESCRIPTION
+*
+* The routine spm_write_mat writes the specified sparse matrix to a
+* text file whose name is specified by the parameter fname. This file
+* can be read back with the routine spm_read_mat.
+*
+* RETURNS
+*
+* On success the routine returns zero, otherwise non-zero.
+*
+* FILE FORMAT
+*
+* The file created by the routine spm_write_mat is a plain text file,
+* which contains the following information:
+*
+* m n nnz
+* row[1] col[1] val[1]
+* row[2] col[2] val[2]
+* . . .
+* row[nnz] col[nnz] val[nnz]
+*
+* where:
+* m is the number of rows;
+* n is the number of columns;
+* nnz is the number of non-zeros;
+* row[k], k = 1,...,nnz, are row indices;
+* col[k], k = 1,...,nnz, are column indices;
+* val[k], k = 1,...,nnz, are element values. */
+
+#if 1
+int spm_write_mat(const SPM *A, const char *fname)
+{ xassert(A != A);
+ xassert(fname != fname);
+ return 0;
+}
+#else
+int spm_write_mat(const SPM *A, const char *fname)
+{ FILE *fp;
+ int i, nnz, ret = 0;
+ xprintf("spm_write_mat: writing matrix to '%s'...\n", fname);
+ fp = fopen(fname, "w");
+ if (fp == NULL)
+ { xprintf("spm_write_mat: unable to create '%s' - %s\n", fname,
+ strerror(errno));
+ ret = 1;
+ goto done;
+ }
+ /* number of rows, number of columns, number of non-zeros */
+ nnz = spm_count_nnz(A);
+ fprintf(fp, "%d %d %d\n", A->m, A->n, nnz);
+ /* walk through rows of the matrix */
+ for (i = 1; i <= A->m; i++)
+ { SPME *e;
+ /* walk through elements of i-th row */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ { /* row index, column index, element value */
+ fprintf(fp, "%d %d %.*g\n", e->i, e->j, DBL_DIG, e->val);
+ }
+ }
+ fflush(fp);
+ if (ferror(fp))
+ { xprintf("spm_write_mat: writing error on '%s' - %s\n", fname,
+ strerror(errno));
+ ret = 1;
+ goto done;
+ }
+ xprintf("spm_write_mat: %d lines were written\n", 1 + nnz);
+done: if (fp != NULL) fclose(fp);
+ return ret;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* spm_transpose - transpose sparse matrix
+*
+* SYNOPSIS
+*
+* #include "glpspm.h"
+* SPM *spm_transpose(const SPM *A);
+*
+* RETURNS
+*
+* The routine computes and returns sparse matrix B, which is a matrix
+* transposed to sparse matrix A. */
+
+SPM *spm_transpose(const SPM *A)
+{ SPM *B;
+ int i;
+ B = spm_create_mat(A->n, A->m);
+ for (i = 1; i <= A->m; i++)
+ { SPME *e;
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ spm_new_elem(B, e->j, i, e->val);
+ }
+ return B;
+}
+
+SPM *spm_add_sym(const SPM *A, const SPM *B)
+{ /* add two sparse matrices (symbolic phase) */
+ SPM *C;
+ int i, j, *flag;
+ xassert(A->m == B->m);
+ xassert(A->n == B->n);
+ /* create resultant matrix */
+ C = spm_create_mat(A->m, A->n);
+ /* allocate and clear the flag array */
+ flag = xcalloc(1+C->n, sizeof(int));
+ for (j = 1; j <= C->n; j++)
+ flag[j] = 0;
+ /* compute pattern of C = A + B */
+ for (i = 1; i <= C->m; i++)
+ { SPME *e;
+ /* at the beginning i-th row of C is empty */
+ /* (i-th row of C) := (i-th row of C) union (i-th row of A) */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ { /* (note that i-th row of A may have duplicate elements) */
+ j = e->j;
+ if (!flag[j])
+ { spm_new_elem(C, i, j, 0.0);
+ flag[j] = 1;
+ }
+ }
+ /* (i-th row of C) := (i-th row of C) union (i-th row of B) */
+ for (e = B->row[i]; e != NULL; e = e->r_next)
+ { /* (note that i-th row of B may have duplicate elements) */
+ j = e->j;
+ if (!flag[j])
+ { spm_new_elem(C, i, j, 0.0);
+ flag[j] = 1;
+ }
+ }
+ /* reset the flag array */
+ for (e = C->row[i]; e != NULL; e = e->r_next)
+ flag[e->j] = 0;
+ }
+ /* check and deallocate the flag array */
+ for (j = 1; j <= C->n; j++)
+ xassert(!flag[j]);
+ xfree(flag);
+ return C;
+}
+
+void spm_add_num(SPM *C, double alfa, const SPM *A, double beta,
+ const SPM *B)
+{ /* add two sparse matrices (numeric phase) */
+ int i, j;
+ double *work;
+ /* allocate and clear the working array */
+ work = xcalloc(1+C->n, sizeof(double));
+ for (j = 1; j <= C->n; j++)
+ work[j] = 0.0;
+ /* compute matrix C = alfa * A + beta * B */
+ for (i = 1; i <= C->n; i++)
+ { SPME *e;
+ /* work := alfa * (i-th row of A) + beta * (i-th row of B) */
+ /* (note that A and/or B may have duplicate elements) */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ work[e->j] += alfa * e->val;
+ for (e = B->row[i]; e != NULL; e = e->r_next)
+ work[e->j] += beta * e->val;
+ /* (i-th row of C) := work, work := 0 */
+ for (e = C->row[i]; e != NULL; e = e->r_next)
+ { j = e->j;
+ e->val = work[j];
+ work[j] = 0.0;
+ }
+ }
+ /* check and deallocate the working array */
+ for (j = 1; j <= C->n; j++)
+ xassert(work[j] == 0.0);
+ xfree(work);
+ return;
+}
+
+SPM *spm_add_mat(double alfa, const SPM *A, double beta, const SPM *B)
+{ /* add two sparse matrices (driver routine) */
+ SPM *C;
+ C = spm_add_sym(A, B);
+ spm_add_num(C, alfa, A, beta, B);
+ return C;
+}
+
+SPM *spm_mul_sym(const SPM *A, const SPM *B)
+{ /* multiply two sparse matrices (symbolic phase) */
+ int i, j, k, *flag;
+ SPM *C;
+ xassert(A->n == B->m);
+ /* create resultant matrix */
+ C = spm_create_mat(A->m, B->n);
+ /* allocate and clear the flag array */
+ flag = xcalloc(1+C->n, sizeof(int));
+ for (j = 1; j <= C->n; j++)
+ flag[j] = 0;
+ /* compute pattern of C = A * B */
+ for (i = 1; i <= C->m; i++)
+ { SPME *e, *ee;
+ /* compute pattern of i-th row of C */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ { k = e->j;
+ for (ee = B->row[k]; ee != NULL; ee = ee->r_next)
+ { j = ee->j;
+ /* if a[i,k] != 0 and b[k,j] != 0 then c[i,j] != 0 */
+ if (!flag[j])
+ { /* c[i,j] does not exist, so create it */
+ spm_new_elem(C, i, j, 0.0);
+ flag[j] = 1;
+ }
+ }
+ }
+ /* reset the flag array */
+ for (e = C->row[i]; e != NULL; e = e->r_next)
+ flag[e->j] = 0;
+ }
+ /* check and deallocate the flag array */
+ for (j = 1; j <= C->n; j++)
+ xassert(!flag[j]);
+ xfree(flag);
+ return C;
+}
+
+void spm_mul_num(SPM *C, const SPM *A, const SPM *B)
+{ /* multiply two sparse matrices (numeric phase) */
+ int i, j;
+ double *work;
+ /* allocate and clear the working array */
+ work = xcalloc(1+A->n, sizeof(double));
+ for (j = 1; j <= A->n; j++)
+ work[j] = 0.0;
+ /* compute matrix C = A * B */
+ for (i = 1; i <= C->m; i++)
+ { SPME *e, *ee;
+ double temp;
+ /* work := (i-th row of A) */
+ /* (note that A may have duplicate elements) */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ work[e->j] += e->val;
+ /* compute i-th row of C */
+ for (e = C->row[i]; e != NULL; e = e->r_next)
+ { j = e->j;
+ /* c[i,j] := work * (j-th column of B) */
+ temp = 0.0;
+ for (ee = B->col[j]; ee != NULL; ee = ee->c_next)
+ temp += work[ee->i] * ee->val;
+ e->val = temp;
+ }
+ /* reset the working array */
+ for (e = A->row[i]; e != NULL; e = e->r_next)
+ work[e->j] = 0.0;
+ }
+ /* check and deallocate the working array */
+ for (j = 1; j <= A->n; j++)
+ xassert(work[j] == 0.0);
+ xfree(work);
+ return;
+}
+
+SPM *spm_mul_mat(const SPM *A, const SPM *B)
+{ /* multiply two sparse matrices (driver routine) */
+ SPM *C;
+ C = spm_mul_sym(A, B);
+ spm_mul_num(C, A, B);
+ return C;
+}
+
+PER *spm_create_per(int n)
+{ /* create permutation matrix */
+ PER *P;
+ int k;
+ xassert(n >= 0);
+ P = xmalloc(sizeof(PER));
+ P->n = n;
+ P->row = xcalloc(1+n, sizeof(int));
+ P->col = xcalloc(1+n, sizeof(int));
+ /* initially it is identity matrix */
+ for (k = 1; k <= n; k++)
+ P->row[k] = P->col[k] = k;
+ return P;
+}
+
+void spm_check_per(PER *P)
+{ /* check permutation matrix for correctness */
+ int i, j;
+ xassert(P->n >= 0);
+ for (i = 1; i <= P->n; i++)
+ { j = P->row[i];
+ xassert(1 <= j && j <= P->n);
+ xassert(P->col[j] == i);
+ }
+ return;
+}
+
+void spm_delete_per(PER *P)
+{ /* delete permutation matrix */
+ xfree(P->row);
+ xfree(P->col);
+ xfree(P);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpspm.h b/test/monniaux/glpk-4.65/src/draft/glpspm.h
new file mode 100644
index 00000000..eda9f98f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpspm.h
@@ -0,0 +1,165 @@
+/* glpspm.h (general sparse matrix) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPSPM_H
+#define GLPSPM_H
+
+#include "dmp.h"
+
+typedef struct SPM SPM;
+typedef struct SPME SPME;
+
+struct SPM
+{ /* general sparse matrix */
+ int m;
+ /* number of rows, m >= 0 */
+ int n;
+ /* number of columns, n >= 0 */
+ DMP *pool;
+ /* memory pool to store matrix elements */
+ SPME **row; /* SPME *row[1+m]; */
+ /* row[i], 1 <= i <= m, is a pointer to i-th row list */
+ SPME **col; /* SPME *col[1+n]; */
+ /* col[j], 1 <= j <= n, is a pointer to j-th column list */
+};
+
+struct SPME
+{ /* sparse matrix element */
+ int i;
+ /* row number */
+ int j;
+ /* column number */
+ double val;
+ /* element value */
+ SPME *r_prev;
+ /* pointer to previous element in the same row */
+ SPME *r_next;
+ /* pointer to next element in the same row */
+ SPME *c_prev;
+ /* pointer to previous element in the same column */
+ SPME *c_next;
+ /* pointer to next element in the same column */
+};
+
+typedef struct PER PER;
+
+struct PER
+{ /* permutation matrix */
+ int n;
+ /* matrix order, n >= 0 */
+ int *row; /* int row[1+n]; */
+ /* row[i] = j means p[i,j] = 1 */
+ int *col; /* int col[1+n]; */
+ /* col[j] = i means p[i,j] = 1 */
+};
+
+#define spm_create_mat _glp_spm_create_mat
+SPM *spm_create_mat(int m, int n);
+/* create general sparse matrix */
+
+#define spm_new_elem _glp_spm_new_elem
+SPME *spm_new_elem(SPM *A, int i, int j, double val);
+/* add new element to sparse matrix */
+
+#define spm_delete_mat _glp_spm_delete_mat
+void spm_delete_mat(SPM *A);
+/* delete general sparse matrix */
+
+#define spm_test_mat_e _glp_spm_test_mat_e
+SPM *spm_test_mat_e(int n, int c);
+/* create test sparse matrix of E(n,c) class */
+
+#define spm_test_mat_d _glp_spm_test_mat_d
+SPM *spm_test_mat_d(int n, int c);
+/* create test sparse matrix of D(n,c) class */
+
+#define spm_show_mat _glp_spm_show_mat
+int spm_show_mat(const SPM *A, const char *fname);
+/* write sparse matrix pattern in BMP file format */
+
+#define spm_read_hbm _glp_spm_read_hbm
+SPM *spm_read_hbm(const char *fname);
+/* read sparse matrix in Harwell-Boeing format */
+
+#define spm_count_nnz _glp_spm_count_nnz
+int spm_count_nnz(const SPM *A);
+/* determine number of non-zeros in sparse matrix */
+
+#define spm_drop_zeros _glp_spm_drop_zeros
+int spm_drop_zeros(SPM *A, double eps);
+/* remove zero elements from sparse matrix */
+
+#define spm_read_mat _glp_spm_read_mat
+SPM *spm_read_mat(const char *fname);
+/* read sparse matrix from text file */
+
+#define spm_write_mat _glp_spm_write_mat
+int spm_write_mat(const SPM *A, const char *fname);
+/* write sparse matrix to text file */
+
+#define spm_transpose _glp_spm_transpose
+SPM *spm_transpose(const SPM *A);
+/* transpose sparse matrix */
+
+#define spm_add_sym _glp_spm_add_sym
+SPM *spm_add_sym(const SPM *A, const SPM *B);
+/* add two sparse matrices (symbolic phase) */
+
+#define spm_add_num _glp_spm_add_num
+void spm_add_num(SPM *C, double alfa, const SPM *A, double beta,
+ const SPM *B);
+/* add two sparse matrices (numeric phase) */
+
+#define spm_add_mat _glp_spm_add_mat
+SPM *spm_add_mat(double alfa, const SPM *A, double beta,
+ const SPM *B);
+/* add two sparse matrices (driver routine) */
+
+#define spm_mul_sym _glp_spm_mul_sym
+SPM *spm_mul_sym(const SPM *A, const SPM *B);
+/* multiply two sparse matrices (symbolic phase) */
+
+#define spm_mul_num _glp_spm_mul_num
+void spm_mul_num(SPM *C, const SPM *A, const SPM *B);
+/* multiply two sparse matrices (numeric phase) */
+
+#define spm_mul_mat _glp_spm_mul_mat
+SPM *spm_mul_mat(const SPM *A, const SPM *B);
+/* multiply two sparse matrices (driver routine) */
+
+#define spm_create_per _glp_spm_create_per
+PER *spm_create_per(int n);
+/* create permutation matrix */
+
+#define spm_check_per _glp_spm_check_per
+void spm_check_per(PER *P);
+/* check permutation matrix for correctness */
+
+#define spm_delete_per _glp_spm_delete_per
+void spm_delete_per(PER *P);
+/* delete permutation matrix */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpssx.h b/test/monniaux/glpk-4.65/src/draft/glpssx.h
new file mode 100644
index 00000000..3b52b3cc
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpssx.h
@@ -0,0 +1,437 @@
+/* glpssx.h (simplex method, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPSSX_H
+#define GLPSSX_H
+
+#include "bfx.h"
+#include "env.h"
+#if 1 /* 25/XI-2017 */
+#include "glpk.h"
+#endif
+
+typedef struct SSX SSX;
+
+struct SSX
+{ /* simplex solver workspace */
+/*----------------------------------------------------------------------
+// LP PROBLEM DATA
+//
+// It is assumed that LP problem has the following statement:
+//
+// minimize (or maximize)
+//
+// z = c[1]*x[1] + ... + c[m+n]*x[m+n] + c[0] (1)
+//
+// subject to equality constraints
+//
+// x[1] - a[1,1]*x[m+1] - ... - a[1,n]*x[m+n] = 0
+//
+// . . . . . . . (2)
+//
+// x[m] - a[m,1]*x[m+1] + ... - a[m,n]*x[m+n] = 0
+//
+// and bounds of variables
+//
+// l[1] <= x[1] <= u[1]
+//
+// . . . . . . . (3)
+//
+// l[m+n] <= x[m+n] <= u[m+n]
+//
+// where:
+// x[1], ..., x[m] - auxiliary variables;
+// x[m+1], ..., x[m+n] - structural variables;
+// z - objective function;
+// c[1], ..., c[m+n] - coefficients of the objective function;
+// c[0] - constant term of the objective function;
+// a[1,1], ..., a[m,n] - constraint coefficients;
+// l[1], ..., l[m+n] - lower bounds of variables;
+// u[1], ..., u[m+n] - upper bounds of variables.
+//
+// Bounds of variables can be finite as well as inifinite. Besides,
+// lower and upper bounds can be equal to each other. So the following
+// five types of variables are possible:
+//
+// Bounds of variable Type of variable
+// -------------------------------------------------
+// -inf < x[k] < +inf Free (unbounded) variable
+// l[k] <= x[k] < +inf Variable with lower bound
+// -inf < x[k] <= u[k] Variable with upper bound
+// l[k] <= x[k] <= u[k] Double-bounded variable
+// l[k] = x[k] = u[k] Fixed variable
+//
+// Using vector-matrix notations the LP problem (1)-(3) can be written
+// as follows:
+//
+// minimize (or maximize)
+//
+// z = c * x + c[0] (4)
+//
+// subject to equality constraints
+//
+// xR - A * xS = 0 (5)
+//
+// and bounds of variables
+//
+// l <= x <= u (6)
+//
+// where:
+// xR - vector of auxiliary variables;
+// xS - vector of structural variables;
+// x = (xR, xS) - vector of all variables;
+// z - objective function;
+// c - vector of objective coefficients;
+// c[0] - constant term of the objective function;
+// A - matrix of constraint coefficients (has m rows
+// and n columns);
+// l - vector of lower bounds of variables;
+// u - vector of upper bounds of variables.
+//
+// The simplex method makes no difference between auxiliary and
+// structural variables, so it is convenient to think the system of
+// equality constraints (5) written in a homogeneous form:
+//
+// (I | -A) * x = 0, (7)
+//
+// where (I | -A) is an augmented (m+n)xm constraint matrix, I is mxm
+// unity matrix whose columns correspond to auxiliary variables, and A
+// is the original mxn constraint matrix whose columns correspond to
+// structural variables. Note that only the matrix A is stored.
+----------------------------------------------------------------------*/
+ int m;
+ /* number of rows (auxiliary variables), m > 0 */
+ int n;
+ /* number of columns (structural variables), n > 0 */
+ int *type; /* int type[1+m+n]; */
+ /* type[0] is not used;
+ type[k], 1 <= k <= m+n, is the type of variable x[k]: */
+#define SSX_FR 0 /* free (unbounded) variable */
+#define SSX_LO 1 /* variable with lower bound */
+#define SSX_UP 2 /* variable with upper bound */
+#define SSX_DB 3 /* double-bounded variable */
+#define SSX_FX 4 /* fixed variable */
+ mpq_t *lb; /* mpq_t lb[1+m+n]; alias: l */
+ /* lb[0] is not used;
+ lb[k], 1 <= k <= m+n, is an lower bound of variable x[k];
+ if x[k] has no lower bound, lb[k] is zero */
+ mpq_t *ub; /* mpq_t ub[1+m+n]; alias: u */
+ /* ub[0] is not used;
+ ub[k], 1 <= k <= m+n, is an upper bound of variable x[k];
+ if x[k] has no upper bound, ub[k] is zero;
+ if x[k] is of fixed type, ub[k] is equal to lb[k] */
+ int dir;
+ /* optimization direction (sense of the objective function): */
+#define SSX_MIN 0 /* minimization */
+#define SSX_MAX 1 /* maximization */
+ mpq_t *coef; /* mpq_t coef[1+m+n]; alias: c */
+ /* coef[0] is a constant term of the objective function;
+ coef[k], 1 <= k <= m+n, is a coefficient of the objective
+ function at variable x[k];
+ note that auxiliary variables also may have non-zero objective
+ coefficients */
+ int *A_ptr; /* int A_ptr[1+n+1]; */
+ int *A_ind; /* int A_ind[A_ptr[n+1]]; */
+ mpq_t *A_val; /* mpq_t A_val[A_ptr[n+1]]; */
+ /* constraint matrix A (see (5)) in storage-by-columns format */
+/*----------------------------------------------------------------------
+// LP BASIS AND CURRENT BASIC SOLUTION
+//
+// The LP basis is defined by the following partition of the augmented
+// constraint matrix (7):
+//
+// (B | N) = (I | -A) * Q, (8)
+//
+// where B is a mxm non-singular basis matrix whose columns correspond
+// to basic variables xB, N is a mxn matrix whose columns correspond to
+// non-basic variables xN, and Q is a permutation (m+n)x(m+n) matrix.
+//
+// From (7) and (8) it follows that
+//
+// (I | -A) * x = (I | -A) * Q * Q' * x = (B | N) * (xB, xN),
+//
+// therefore
+//
+// (xB, xN) = Q' * x, (9)
+//
+// where x is the vector of all variables in the original order, xB is
+// a vector of basic variables, xN is a vector of non-basic variables,
+// Q' = inv(Q) is a matrix transposed to Q.
+//
+// Current values of non-basic variables xN[j], j = 1, ..., n, are not
+// stored; they are defined implicitly by their statuses as follows:
+//
+// 0, if xN[j] is free variable
+// lN[j], if xN[j] is on its lower bound (10)
+// uN[j], if xN[j] is on its upper bound
+// lN[j] = uN[j], if xN[j] is fixed variable
+//
+// where lN[j] and uN[j] are lower and upper bounds of xN[j].
+//
+// Current values of basic variables xB[i], i = 1, ..., m, are computed
+// as follows:
+//
+// beta = - inv(B) * N * xN, (11)
+//
+// where current values of xN are defined by (10).
+//
+// Current values of simplex multipliers pi[i], i = 1, ..., m (which
+// are values of Lagrange multipliers for equality constraints (7) also
+// called shadow prices) are computed as follows:
+//
+// pi = inv(B') * cB, (12)
+//
+// where B' is a matrix transposed to B, cB is a vector of objective
+// coefficients at basic variables xB.
+//
+// Current values of reduced costs d[j], j = 1, ..., n, (which are
+// values of Langrange multipliers for active inequality constraints
+// corresponding to non-basic variables) are computed as follows:
+//
+// d = cN - N' * pi, (13)
+//
+// where N' is a matrix transposed to N, cN is a vector of objective
+// coefficients at non-basic variables xN.
+----------------------------------------------------------------------*/
+ int *stat; /* int stat[1+m+n]; */
+ /* stat[0] is not used;
+ stat[k], 1 <= k <= m+n, is the status of variable x[k]: */
+#define SSX_BS 0 /* basic variable */
+#define SSX_NL 1 /* non-basic variable on lower bound */
+#define SSX_NU 2 /* non-basic variable on upper bound */
+#define SSX_NF 3 /* non-basic free variable */
+#define SSX_NS 4 /* non-basic fixed variable */
+ int *Q_row; /* int Q_row[1+m+n]; */
+ /* matrix Q in row-like format;
+ Q_row[0] is not used;
+ Q_row[i] = j means that q[i,j] = 1 */
+ int *Q_col; /* int Q_col[1+m+n]; */
+ /* matrix Q in column-like format;
+ Q_col[0] is not used;
+ Q_col[j] = i means that q[i,j] = 1 */
+ /* if k-th column of the matrix (I | A) is k'-th column of the
+ matrix (B | N), then Q_row[k] = k' and Q_col[k'] = k;
+ if x[k] is xB[i], then Q_row[k] = i and Q_col[i] = k;
+ if x[k] is xN[j], then Q_row[k] = m+j and Q_col[m+j] = k */
+ BFX *binv;
+ /* invertable form of the basis matrix B */
+ mpq_t *bbar; /* mpq_t bbar[1+m]; alias: beta */
+ /* bbar[0] is a value of the objective function;
+ bbar[i], 1 <= i <= m, is a value of basic variable xB[i] */
+ mpq_t *pi; /* mpq_t pi[1+m]; */
+ /* pi[0] is not used;
+ pi[i], 1 <= i <= m, is a simplex multiplier corresponding to
+ i-th row (equality constraint) */
+ mpq_t *cbar; /* mpq_t cbar[1+n]; alias: d */
+ /* cbar[0] is not used;
+ cbar[j], 1 <= j <= n, is a reduced cost of non-basic variable
+ xN[j] */
+/*----------------------------------------------------------------------
+// SIMPLEX TABLE
+//
+// Due to (8) and (9) the system of equality constraints (7) for the
+// current basis can be written as follows:
+//
+// xB = A~ * xN, (14)
+//
+// where
+//
+// A~ = - inv(B) * N (15)
+//
+// is a mxn matrix called the simplex table.
+//
+// The revised simplex method uses only two components of A~, namely,
+// pivot column corresponding to non-basic variable xN[q] chosen to
+// enter the basis, and pivot row corresponding to basic variable xB[p]
+// chosen to leave the basis.
+//
+// Pivot column alfa_q is q-th column of A~, so
+//
+// alfa_q = A~ * e[q] = - inv(B) * N * e[q] = - inv(B) * N[q], (16)
+//
+// where N[q] is q-th column of the matrix N.
+//
+// Pivot row alfa_p is p-th row of A~ or, equivalently, p-th column of
+// A~', a matrix transposed to A~, so
+//
+// alfa_p = A~' * e[p] = - N' * inv(B') * e[p] = - N' * rho_p, (17)
+//
+// where (*)' means transposition, and
+//
+// rho_p = inv(B') * e[p], (18)
+//
+// is p-th column of inv(B') or, that is the same, p-th row of inv(B).
+----------------------------------------------------------------------*/
+ int p;
+ /* number of basic variable xB[p], 1 <= p <= m, chosen to leave
+ the basis */
+ mpq_t *rho; /* mpq_t rho[1+m]; */
+ /* p-th row of the inverse inv(B); see (18) */
+ mpq_t *ap; /* mpq_t ap[1+n]; */
+ /* p-th row of the simplex table; see (17) */
+ int q;
+ /* number of non-basic variable xN[q], 1 <= q <= n, chosen to
+ enter the basis */
+ mpq_t *aq; /* mpq_t aq[1+m]; */
+ /* q-th column of the simplex table; see (16) */
+/*--------------------------------------------------------------------*/
+ int q_dir;
+ /* direction in which non-basic variable xN[q] should change on
+ moving to the adjacent vertex of the polyhedron:
+ +1 means that xN[q] increases
+ -1 means that xN[q] decreases */
+ int p_stat;
+ /* non-basic status which should be assigned to basic variable
+ xB[p] when it has left the basis and become xN[q] */
+ mpq_t delta;
+ /* actual change of xN[q] in the adjacent basis (it has the same
+ sign as q_dir) */
+/*--------------------------------------------------------------------*/
+#if 1 /* 25/XI-2017 */
+ int msg_lev;
+ /* verbosity level:
+ GLP_MSG_OFF no output
+ GLP_MSG_ERR report errors and warnings
+ GLP_MSG_ON normal output
+ GLP_MSG_ALL highest verbosity */
+#endif
+ int it_lim;
+ /* simplex iterations limit; if this value is positive, it is
+ decreased by one each time when one simplex iteration has been
+ performed, and reaching zero value signals the solver to stop
+ the search; negative value means no iterations limit */
+ int it_cnt;
+ /* simplex iterations count; this count is increased by one each
+ time when one simplex iteration has been performed */
+ double tm_lim;
+ /* searching time limit, in seconds; if this value is positive,
+ it is decreased each time when one simplex iteration has been
+ performed by the amount of time spent for the iteration, and
+ reaching zero value signals the solver to stop the search;
+ negative value means no time limit */
+ double out_frq;
+ /* output frequency, in seconds; this parameter specifies how
+ frequently the solver sends information about the progress of
+ the search to the standard output */
+#if 0 /* 10/VI-2013 */
+ glp_long tm_beg;
+#else
+ double tm_beg;
+#endif
+ /* starting time of the search, in seconds; the total time of the
+ search is the difference between xtime() and tm_beg */
+#if 0 /* 10/VI-2013 */
+ glp_long tm_lag;
+#else
+ double tm_lag;
+#endif
+ /* the most recent time, in seconds, at which the progress of the
+ the search was displayed */
+};
+
+#define ssx_create _glp_ssx_create
+#define ssx_factorize _glp_ssx_factorize
+#define ssx_get_xNj _glp_ssx_get_xNj
+#define ssx_eval_bbar _glp_ssx_eval_bbar
+#define ssx_eval_pi _glp_ssx_eval_pi
+#define ssx_eval_dj _glp_ssx_eval_dj
+#define ssx_eval_cbar _glp_ssx_eval_cbar
+#define ssx_eval_rho _glp_ssx_eval_rho
+#define ssx_eval_row _glp_ssx_eval_row
+#define ssx_eval_col _glp_ssx_eval_col
+#define ssx_chuzc _glp_ssx_chuzc
+#define ssx_chuzr _glp_ssx_chuzr
+#define ssx_update_bbar _glp_ssx_update_bbar
+#define ssx_update_pi _glp_ssx_update_pi
+#define ssx_update_cbar _glp_ssx_update_cbar
+#define ssx_change_basis _glp_ssx_change_basis
+#define ssx_delete _glp_ssx_delete
+
+#define ssx_phase_I _glp_ssx_phase_I
+#define ssx_phase_II _glp_ssx_phase_II
+#define ssx_driver _glp_ssx_driver
+
+SSX *ssx_create(int m, int n, int nnz);
+/* create simplex solver workspace */
+
+int ssx_factorize(SSX *ssx);
+/* factorize the current basis matrix */
+
+void ssx_get_xNj(SSX *ssx, int j, mpq_t x);
+/* determine value of non-basic variable */
+
+void ssx_eval_bbar(SSX *ssx);
+/* compute values of basic variables */
+
+void ssx_eval_pi(SSX *ssx);
+/* compute values of simplex multipliers */
+
+void ssx_eval_dj(SSX *ssx, int j, mpq_t dj);
+/* compute reduced cost of non-basic variable */
+
+void ssx_eval_cbar(SSX *ssx);
+/* compute reduced costs of all non-basic variables */
+
+void ssx_eval_rho(SSX *ssx);
+/* compute p-th row of the inverse */
+
+void ssx_eval_row(SSX *ssx);
+/* compute pivot row of the simplex table */
+
+void ssx_eval_col(SSX *ssx);
+/* compute pivot column of the simplex table */
+
+void ssx_chuzc(SSX *ssx);
+/* choose pivot column */
+
+void ssx_chuzr(SSX *ssx);
+/* choose pivot row */
+
+void ssx_update_bbar(SSX *ssx);
+/* update values of basic variables */
+
+void ssx_update_pi(SSX *ssx);
+/* update simplex multipliers */
+
+void ssx_update_cbar(SSX *ssx);
+/* update reduced costs of non-basic variables */
+
+void ssx_change_basis(SSX *ssx);
+/* change current basis to adjacent one */
+
+void ssx_delete(SSX *ssx);
+/* delete simplex solver workspace */
+
+int ssx_phase_I(SSX *ssx);
+/* find primal feasible solution */
+
+int ssx_phase_II(SSX *ssx);
+/* find optimal solution */
+
+int ssx_driver(SSX *ssx);
+/* base driver to exact simplex method */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpssx01.c b/test/monniaux/glpk-4.65/src/draft/glpssx01.c
new file mode 100644
index 00000000..9b70444e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpssx01.c
@@ -0,0 +1,839 @@
+/* glpssx01.c (simplex method, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpssx.h"
+#define xfault xerror
+
+/*----------------------------------------------------------------------
+// ssx_create - create simplex solver workspace.
+//
+// This routine creates the workspace used by simplex solver routines,
+// and returns a pointer to it.
+//
+// Parameters m, n, and nnz specify, respectively, the number of rows,
+// columns, and non-zero constraint coefficients.
+//
+// This routine only allocates the memory for the workspace components,
+// so the workspace needs to be saturated by data. */
+
+SSX *ssx_create(int m, int n, int nnz)
+{ SSX *ssx;
+ int i, j, k;
+ if (m < 1)
+ xfault("ssx_create: m = %d; invalid number of rows\n", m);
+ if (n < 1)
+ xfault("ssx_create: n = %d; invalid number of columns\n", n);
+ if (nnz < 0)
+ xfault("ssx_create: nnz = %d; invalid number of non-zero const"
+ "raint coefficients\n", nnz);
+ ssx = xmalloc(sizeof(SSX));
+ ssx->m = m;
+ ssx->n = n;
+ ssx->type = xcalloc(1+m+n, sizeof(int));
+ ssx->lb = xcalloc(1+m+n, sizeof(mpq_t));
+ for (k = 1; k <= m+n; k++) mpq_init(ssx->lb[k]);
+ ssx->ub = xcalloc(1+m+n, sizeof(mpq_t));
+ for (k = 1; k <= m+n; k++) mpq_init(ssx->ub[k]);
+ ssx->coef = xcalloc(1+m+n, sizeof(mpq_t));
+ for (k = 0; k <= m+n; k++) mpq_init(ssx->coef[k]);
+ ssx->A_ptr = xcalloc(1+n+1, sizeof(int));
+ ssx->A_ptr[n+1] = nnz+1;
+ ssx->A_ind = xcalloc(1+nnz, sizeof(int));
+ ssx->A_val = xcalloc(1+nnz, sizeof(mpq_t));
+ for (k = 1; k <= nnz; k++) mpq_init(ssx->A_val[k]);
+ ssx->stat = xcalloc(1+m+n, sizeof(int));
+ ssx->Q_row = xcalloc(1+m+n, sizeof(int));
+ ssx->Q_col = xcalloc(1+m+n, sizeof(int));
+ ssx->binv = bfx_create_binv();
+ ssx->bbar = xcalloc(1+m, sizeof(mpq_t));
+ for (i = 0; i <= m; i++) mpq_init(ssx->bbar[i]);
+ ssx->pi = xcalloc(1+m, sizeof(mpq_t));
+ for (i = 1; i <= m; i++) mpq_init(ssx->pi[i]);
+ ssx->cbar = xcalloc(1+n, sizeof(mpq_t));
+ for (j = 1; j <= n; j++) mpq_init(ssx->cbar[j]);
+ ssx->rho = xcalloc(1+m, sizeof(mpq_t));
+ for (i = 1; i <= m; i++) mpq_init(ssx->rho[i]);
+ ssx->ap = xcalloc(1+n, sizeof(mpq_t));
+ for (j = 1; j <= n; j++) mpq_init(ssx->ap[j]);
+ ssx->aq = xcalloc(1+m, sizeof(mpq_t));
+ for (i = 1; i <= m; i++) mpq_init(ssx->aq[i]);
+ mpq_init(ssx->delta);
+ return ssx;
+}
+
+/*----------------------------------------------------------------------
+// ssx_factorize - factorize the current basis matrix.
+//
+// This routine computes factorization of the current basis matrix B
+// and returns the singularity flag. If the matrix B is non-singular,
+// the flag is zero, otherwise non-zero. */
+
+static int basis_col(void *info, int j, int ind[], mpq_t val[])
+{ /* this auxiliary routine provides row indices and numeric values
+ of non-zero elements in j-th column of the matrix B */
+ SSX *ssx = info;
+ int m = ssx->m;
+ int n = ssx->n;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ int k, len, ptr;
+ xassert(1 <= j && j <= m);
+ k = Q_col[j]; /* x[k] = xB[j] */
+ xassert(1 <= k && k <= m+n);
+ /* j-th column of the matrix B is k-th column of the augmented
+ constraint matrix (I | -A) */
+ if (k <= m)
+ { /* it is a column of the unity matrix I */
+ len = 1, ind[1] = k, mpq_set_si(val[1], 1, 1);
+ }
+ else
+ { /* it is a column of the original constraint matrix -A */
+ len = 0;
+ for (ptr = A_ptr[k-m]; ptr < A_ptr[k-m+1]; ptr++)
+ { len++;
+ ind[len] = A_ind[ptr];
+ mpq_neg(val[len], A_val[ptr]);
+ }
+ }
+ return len;
+}
+
+int ssx_factorize(SSX *ssx)
+{ int ret;
+ ret = bfx_factorize(ssx->binv, ssx->m, basis_col, ssx);
+ return ret;
+}
+
+/*----------------------------------------------------------------------
+// ssx_get_xNj - determine value of non-basic variable.
+//
+// This routine determines the value of non-basic variable xN[j] in the
+// current basic solution defined as follows:
+//
+// 0, if xN[j] is free variable
+// lN[j], if xN[j] is on its lower bound
+// uN[j], if xN[j] is on its upper bound
+// lN[j] = uN[j], if xN[j] is fixed variable
+//
+// where lN[j] and uN[j] are lower and upper bounds of xN[j]. */
+
+void ssx_get_xNj(SSX *ssx, int j, mpq_t x)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *lb = ssx->lb;
+ mpq_t *ub = ssx->ub;
+ int *stat = ssx->stat;
+ int *Q_col = ssx->Q_col;
+ int k;
+ xassert(1 <= j && j <= n);
+ k = Q_col[m+j]; /* x[k] = xN[j] */
+ xassert(1 <= k && k <= m+n);
+ switch (stat[k])
+ { case SSX_NL:
+ /* xN[j] is on its lower bound */
+ mpq_set(x, lb[k]); break;
+ case SSX_NU:
+ /* xN[j] is on its upper bound */
+ mpq_set(x, ub[k]); break;
+ case SSX_NF:
+ /* xN[j] is free variable */
+ mpq_set_si(x, 0, 1); break;
+ case SSX_NS:
+ /* xN[j] is fixed variable */
+ mpq_set(x, lb[k]); break;
+ default:
+ xassert(stat != stat);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_bbar - compute values of basic variables.
+//
+// This routine computes values of basic variables xB in the current
+// basic solution as follows:
+//
+// beta = - inv(B) * N * xN,
+//
+// where B is the basis matrix, N is the matrix of non-basic columns,
+// xN is a vector of current values of non-basic variables. */
+
+void ssx_eval_bbar(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *coef = ssx->coef;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ mpq_t *bbar = ssx->bbar;
+ int i, j, k, ptr;
+ mpq_t x, temp;
+ mpq_init(x);
+ mpq_init(temp);
+ /* bbar := 0 */
+ for (i = 1; i <= m; i++)
+ mpq_set_si(bbar[i], 0, 1);
+ /* bbar := - N * xN = - N[1] * xN[1] - ... - N[n] * xN[n] */
+ for (j = 1; j <= n; j++)
+ { ssx_get_xNj(ssx, j, x);
+ if (mpq_sgn(x) == 0) continue;
+ k = Q_col[m+j]; /* x[k] = xN[j] */
+ if (k <= m)
+ { /* N[j] is a column of the unity matrix I */
+ mpq_sub(bbar[k], bbar[k], x);
+ }
+ else
+ { /* N[j] is a column of the original constraint matrix -A */
+ for (ptr = A_ptr[k-m]; ptr < A_ptr[k-m+1]; ptr++)
+ { mpq_mul(temp, A_val[ptr], x);
+ mpq_add(bbar[A_ind[ptr]], bbar[A_ind[ptr]], temp);
+ }
+ }
+ }
+ /* bbar := inv(B) * bbar */
+ bfx_ftran(ssx->binv, bbar, 0);
+#if 1
+ /* compute value of the objective function */
+ /* bbar[0] := c[0] */
+ mpq_set(bbar[0], coef[0]);
+ /* bbar[0] := bbar[0] + sum{i in B} cB[i] * xB[i] */
+ for (i = 1; i <= m; i++)
+ { k = Q_col[i]; /* x[k] = xB[i] */
+ if (mpq_sgn(coef[k]) == 0) continue;
+ mpq_mul(temp, coef[k], bbar[i]);
+ mpq_add(bbar[0], bbar[0], temp);
+ }
+ /* bbar[0] := bbar[0] + sum{j in N} cN[j] * xN[j] */
+ for (j = 1; j <= n; j++)
+ { k = Q_col[m+j]; /* x[k] = xN[j] */
+ if (mpq_sgn(coef[k]) == 0) continue;
+ ssx_get_xNj(ssx, j, x);
+ mpq_mul(temp, coef[k], x);
+ mpq_add(bbar[0], bbar[0], temp);
+ }
+#endif
+ mpq_clear(x);
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_pi - compute values of simplex multipliers.
+//
+// This routine computes values of simplex multipliers (shadow prices)
+// pi in the current basic solution as follows:
+//
+// pi = inv(B') * cB,
+//
+// where B' is a matrix transposed to the basis matrix B, cB is a vector
+// of objective coefficients at basic variables xB. */
+
+void ssx_eval_pi(SSX *ssx)
+{ int m = ssx->m;
+ mpq_t *coef = ssx->coef;
+ int *Q_col = ssx->Q_col;
+ mpq_t *pi = ssx->pi;
+ int i;
+ /* pi := cB */
+ for (i = 1; i <= m; i++) mpq_set(pi[i], coef[Q_col[i]]);
+ /* pi := inv(B') * cB */
+ bfx_btran(ssx->binv, pi);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_dj - compute reduced cost of non-basic variable.
+//
+// This routine computes reduced cost d[j] of non-basic variable xN[j]
+// in the current basic solution as follows:
+//
+// d[j] = cN[j] - N[j] * pi,
+//
+// where cN[j] is an objective coefficient at xN[j], N[j] is a column
+// of the augmented constraint matrix (I | -A) corresponding to xN[j],
+// pi is the vector of simplex multipliers (shadow prices). */
+
+void ssx_eval_dj(SSX *ssx, int j, mpq_t dj)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *coef = ssx->coef;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ mpq_t *pi = ssx->pi;
+ int k, ptr, end;
+ mpq_t temp;
+ mpq_init(temp);
+ xassert(1 <= j && j <= n);
+ k = Q_col[m+j]; /* x[k] = xN[j] */
+ xassert(1 <= k && k <= m+n);
+ /* j-th column of the matrix N is k-th column of the augmented
+ constraint matrix (I | -A) */
+ if (k <= m)
+ { /* it is a column of the unity matrix I */
+ mpq_sub(dj, coef[k], pi[k]);
+ }
+ else
+ { /* it is a column of the original constraint matrix -A */
+ mpq_set(dj, coef[k]);
+ for (ptr = A_ptr[k-m], end = A_ptr[k-m+1]; ptr < end; ptr++)
+ { mpq_mul(temp, A_val[ptr], pi[A_ind[ptr]]);
+ mpq_add(dj, dj, temp);
+ }
+ }
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_cbar - compute reduced costs of all non-basic variables.
+//
+// This routine computes the vector of reduced costs pi in the current
+// basic solution for all non-basic variables, including fixed ones. */
+
+void ssx_eval_cbar(SSX *ssx)
+{ int n = ssx->n;
+ mpq_t *cbar = ssx->cbar;
+ int j;
+ for (j = 1; j <= n; j++)
+ ssx_eval_dj(ssx, j, cbar[j]);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_rho - compute p-th row of the inverse.
+//
+// This routine computes p-th row of the matrix inv(B), where B is the
+// current basis matrix.
+//
+// p-th row of the inverse is computed using the following formula:
+//
+// rho = inv(B') * e[p],
+//
+// where B' is a matrix transposed to B, e[p] is a unity vector, which
+// contains one in p-th position. */
+
+void ssx_eval_rho(SSX *ssx)
+{ int m = ssx->m;
+ int p = ssx->p;
+ mpq_t *rho = ssx->rho;
+ int i;
+ xassert(1 <= p && p <= m);
+ /* rho := 0 */
+ for (i = 1; i <= m; i++) mpq_set_si(rho[i], 0, 1);
+ /* rho := e[p] */
+ mpq_set_si(rho[p], 1, 1);
+ /* rho := inv(B') * rho */
+ bfx_btran(ssx->binv, rho);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_row - compute pivot row of the simplex table.
+//
+// This routine computes p-th (pivot) row of the current simplex table
+// A~ = - inv(B) * N using the following formula:
+//
+// A~[p] = - N' * inv(B') * e[p] = - N' * rho[p],
+//
+// where N' is a matrix transposed to the matrix N, rho[p] is p-th row
+// of the inverse inv(B). */
+
+void ssx_eval_row(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ mpq_t *rho = ssx->rho;
+ mpq_t *ap = ssx->ap;
+ int j, k, ptr;
+ mpq_t temp;
+ mpq_init(temp);
+ for (j = 1; j <= n; j++)
+ { /* ap[j] := - N'[j] * rho (inner product) */
+ k = Q_col[m+j]; /* x[k] = xN[j] */
+ if (k <= m)
+ mpq_neg(ap[j], rho[k]);
+ else
+ { mpq_set_si(ap[j], 0, 1);
+ for (ptr = A_ptr[k-m]; ptr < A_ptr[k-m+1]; ptr++)
+ { mpq_mul(temp, A_val[ptr], rho[A_ind[ptr]]);
+ mpq_add(ap[j], ap[j], temp);
+ }
+ }
+ }
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_eval_col - compute pivot column of the simplex table.
+//
+// This routine computes q-th (pivot) column of the current simplex
+// table A~ = - inv(B) * N using the following formula:
+//
+// A~[q] = - inv(B) * N[q],
+//
+// where N[q] is q-th column of the matrix N corresponding to chosen
+// non-basic variable xN[q]. */
+
+void ssx_eval_col(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ int q = ssx->q;
+ mpq_t *aq = ssx->aq;
+ int i, k, ptr;
+ xassert(1 <= q && q <= n);
+ /* aq := 0 */
+ for (i = 1; i <= m; i++) mpq_set_si(aq[i], 0, 1);
+ /* aq := N[q] */
+ k = Q_col[m+q]; /* x[k] = xN[q] */
+ if (k <= m)
+ { /* N[q] is a column of the unity matrix I */
+ mpq_set_si(aq[k], 1, 1);
+ }
+ else
+ { /* N[q] is a column of the original constraint matrix -A */
+ for (ptr = A_ptr[k-m]; ptr < A_ptr[k-m+1]; ptr++)
+ mpq_neg(aq[A_ind[ptr]], A_val[ptr]);
+ }
+ /* aq := inv(B) * aq */
+ bfx_ftran(ssx->binv, aq, 1);
+ /* aq := - aq */
+ for (i = 1; i <= m; i++) mpq_neg(aq[i], aq[i]);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_chuzc - choose pivot column.
+//
+// This routine chooses non-basic variable xN[q] whose reduced cost
+// indicates possible improving of the objective function to enter it
+// in the basis.
+//
+// Currently the standard (textbook) pricing is used, i.e. that
+// non-basic variable is preferred which has greatest reduced cost (in
+// magnitude).
+//
+// If xN[q] has been chosen, the routine stores its number q and also
+// sets the flag q_dir that indicates direction in which xN[q] has to
+// change (+1 means increasing, -1 means decreasing).
+//
+// If the choice cannot be made, because the current basic solution is
+// dual feasible, the routine sets the number q to 0. */
+
+void ssx_chuzc(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int dir = (ssx->dir == SSX_MIN ? +1 : -1);
+ int *Q_col = ssx->Q_col;
+ int *stat = ssx->stat;
+ mpq_t *cbar = ssx->cbar;
+ int j, k, s, q, q_dir;
+ double best, temp;
+ /* nothing is chosen so far */
+ q = 0, q_dir = 0, best = 0.0;
+ /* look through the list of non-basic variables */
+ for (j = 1; j <= n; j++)
+ { k = Q_col[m+j]; /* x[k] = xN[j] */
+ s = dir * mpq_sgn(cbar[j]);
+ if ((stat[k] == SSX_NF || stat[k] == SSX_NL) && s < 0 ||
+ (stat[k] == SSX_NF || stat[k] == SSX_NU) && s > 0)
+ { /* reduced cost of xN[j] indicates possible improving of
+ the objective function */
+ temp = fabs(mpq_get_d(cbar[j]));
+ xassert(temp != 0.0);
+ if (q == 0 || best < temp)
+ q = j, q_dir = - s, best = temp;
+ }
+ }
+ ssx->q = q, ssx->q_dir = q_dir;
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_chuzr - choose pivot row.
+//
+// This routine looks through elements of q-th column of the simplex
+// table and chooses basic variable xB[p] which should leave the basis.
+//
+// The choice is based on the standard (textbook) ratio test.
+//
+// If xB[p] has been chosen, the routine stores its number p and also
+// sets its non-basic status p_stat which should be assigned to xB[p]
+// when it has left the basis and become xN[q].
+//
+// Special case p < 0 means that xN[q] is double-bounded variable and
+// it reaches its opposite bound before any basic variable does that,
+// so the current basis remains unchanged.
+//
+// If the choice cannot be made, because xN[q] can infinitely change in
+// the feasible direction, the routine sets the number p to 0. */
+
+void ssx_chuzr(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int *type = ssx->type;
+ mpq_t *lb = ssx->lb;
+ mpq_t *ub = ssx->ub;
+ int *Q_col = ssx->Q_col;
+ mpq_t *bbar = ssx->bbar;
+ int q = ssx->q;
+ mpq_t *aq = ssx->aq;
+ int q_dir = ssx->q_dir;
+ int i, k, s, t, p, p_stat;
+ mpq_t teta, temp;
+ mpq_init(teta);
+ mpq_init(temp);
+ xassert(1 <= q && q <= n);
+ xassert(q_dir == +1 || q_dir == -1);
+ /* nothing is chosen so far */
+ p = 0, p_stat = 0;
+ /* look through the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { s = q_dir * mpq_sgn(aq[i]);
+ if (s < 0)
+ { /* xB[i] decreases */
+ k = Q_col[i]; /* x[k] = xB[i] */
+ t = type[k];
+ if (t == SSX_LO || t == SSX_DB || t == SSX_FX)
+ { /* xB[i] has finite lower bound */
+ mpq_sub(temp, bbar[i], lb[k]);
+ mpq_div(temp, temp, aq[i]);
+ mpq_abs(temp, temp);
+ if (p == 0 || mpq_cmp(teta, temp) > 0)
+ { p = i;
+ p_stat = (t == SSX_FX ? SSX_NS : SSX_NL);
+ mpq_set(teta, temp);
+ }
+ }
+ }
+ else if (s > 0)
+ { /* xB[i] increases */
+ k = Q_col[i]; /* x[k] = xB[i] */
+ t = type[k];
+ if (t == SSX_UP || t == SSX_DB || t == SSX_FX)
+ { /* xB[i] has finite upper bound */
+ mpq_sub(temp, bbar[i], ub[k]);
+ mpq_div(temp, temp, aq[i]);
+ mpq_abs(temp, temp);
+ if (p == 0 || mpq_cmp(teta, temp) > 0)
+ { p = i;
+ p_stat = (t == SSX_FX ? SSX_NS : SSX_NU);
+ mpq_set(teta, temp);
+ }
+ }
+ }
+ /* if something has been chosen and the ratio test indicates
+ exact degeneracy, the search can be finished */
+ if (p != 0 && mpq_sgn(teta) == 0) break;
+ }
+ /* if xN[q] is double-bounded, check if it can reach its opposite
+ bound before any basic variable */
+ k = Q_col[m+q]; /* x[k] = xN[q] */
+ if (type[k] == SSX_DB)
+ { mpq_sub(temp, ub[k], lb[k]);
+ if (p == 0 || mpq_cmp(teta, temp) > 0)
+ { p = -1;
+ p_stat = -1;
+ mpq_set(teta, temp);
+ }
+ }
+ ssx->p = p;
+ ssx->p_stat = p_stat;
+ /* if xB[p] has been chosen, determine its actual change in the
+ adjacent basis (it has the same sign as q_dir) */
+ if (p != 0)
+ { xassert(mpq_sgn(teta) >= 0);
+ if (q_dir > 0)
+ mpq_set(ssx->delta, teta);
+ else
+ mpq_neg(ssx->delta, teta);
+ }
+ mpq_clear(teta);
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_update_bbar - update values of basic variables.
+//
+// This routine recomputes the current values of basic variables for
+// the adjacent basis.
+//
+// The simplex table for the current basis is the following:
+//
+// xB[i] = sum{j in 1..n} alfa[i,j] * xN[q], i = 1,...,m
+//
+// therefore
+//
+// delta xB[i] = alfa[i,q] * delta xN[q], i = 1,...,m
+//
+// where delta xN[q] = xN.new[q] - xN[q] is the change of xN[q] in the
+// adjacent basis, and delta xB[i] = xB.new[i] - xB[i] is the change of
+// xB[i]. This gives formulae for recomputing values of xB[i]:
+//
+// xB.new[p] = xN[q] + delta xN[q]
+//
+// (because xN[q] becomes xB[p] in the adjacent basis), and
+//
+// xB.new[i] = xB[i] + alfa[i,q] * delta xN[q], i != p
+//
+// for other basic variables. */
+
+void ssx_update_bbar(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *bbar = ssx->bbar;
+ mpq_t *cbar = ssx->cbar;
+ int p = ssx->p;
+ int q = ssx->q;
+ mpq_t *aq = ssx->aq;
+ int i;
+ mpq_t temp;
+ mpq_init(temp);
+ xassert(1 <= q && q <= n);
+ if (p < 0)
+ { /* xN[q] is double-bounded and goes to its opposite bound */
+ /* nop */;
+ }
+ else
+ { /* xN[q] becomes xB[p] in the adjacent basis */
+ /* xB.new[p] = xN[q] + delta xN[q] */
+ xassert(1 <= p && p <= m);
+ ssx_get_xNj(ssx, q, temp);
+ mpq_add(bbar[p], temp, ssx->delta);
+ }
+ /* update values of other basic variables depending on xN[q] */
+ for (i = 1; i <= m; i++)
+ { if (i == p) continue;
+ /* xB.new[i] = xB[i] + alfa[i,q] * delta xN[q] */
+ if (mpq_sgn(aq[i]) == 0) continue;
+ mpq_mul(temp, aq[i], ssx->delta);
+ mpq_add(bbar[i], bbar[i], temp);
+ }
+#if 1
+ /* update value of the objective function */
+ /* z.new = z + d[q] * delta xN[q] */
+ mpq_mul(temp, cbar[q], ssx->delta);
+ mpq_add(bbar[0], bbar[0], temp);
+#endif
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- ssx_update_pi - update simplex multipliers.
+--
+-- This routine recomputes the vector of simplex multipliers for the
+-- adjacent basis. */
+
+void ssx_update_pi(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *pi = ssx->pi;
+ mpq_t *cbar = ssx->cbar;
+ int p = ssx->p;
+ int q = ssx->q;
+ mpq_t *aq = ssx->aq;
+ mpq_t *rho = ssx->rho;
+ int i;
+ mpq_t new_dq, temp;
+ mpq_init(new_dq);
+ mpq_init(temp);
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n);
+ /* compute d[q] in the adjacent basis */
+ mpq_div(new_dq, cbar[q], aq[p]);
+ /* update the vector of simplex multipliers */
+ for (i = 1; i <= m; i++)
+ { if (mpq_sgn(rho[i]) == 0) continue;
+ mpq_mul(temp, new_dq, rho[i]);
+ mpq_sub(pi[i], pi[i], temp);
+ }
+ mpq_clear(new_dq);
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_update_cbar - update reduced costs of non-basic variables.
+//
+// This routine recomputes the vector of reduced costs of non-basic
+// variables for the adjacent basis. */
+
+void ssx_update_cbar(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ mpq_t *cbar = ssx->cbar;
+ int p = ssx->p;
+ int q = ssx->q;
+ mpq_t *ap = ssx->ap;
+ int j;
+ mpq_t temp;
+ mpq_init(temp);
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n);
+ /* compute d[q] in the adjacent basis */
+ /* d.new[q] = d[q] / alfa[p,q] */
+ mpq_div(cbar[q], cbar[q], ap[q]);
+ /* update reduced costs of other non-basic variables */
+ for (j = 1; j <= n; j++)
+ { if (j == q) continue;
+ /* d.new[j] = d[j] - (alfa[p,j] / alfa[p,q]) * d[q] */
+ if (mpq_sgn(ap[j]) == 0) continue;
+ mpq_mul(temp, ap[j], cbar[q]);
+ mpq_sub(cbar[j], cbar[j], temp);
+ }
+ mpq_clear(temp);
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_change_basis - change current basis to adjacent one.
+//
+// This routine changes the current basis to the adjacent one swapping
+// basic variable xB[p] and non-basic variable xN[q]. */
+
+void ssx_change_basis(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int *type = ssx->type;
+ int *stat = ssx->stat;
+ int *Q_row = ssx->Q_row;
+ int *Q_col = ssx->Q_col;
+ int p = ssx->p;
+ int q = ssx->q;
+ int p_stat = ssx->p_stat;
+ int k, kp, kq;
+ if (p < 0)
+ { /* special case: xN[q] goes to its opposite bound */
+ xassert(1 <= q && q <= n);
+ k = Q_col[m+q]; /* x[k] = xN[q] */
+ xassert(type[k] == SSX_DB);
+ switch (stat[k])
+ { case SSX_NL:
+ stat[k] = SSX_NU;
+ break;
+ case SSX_NU:
+ stat[k] = SSX_NL;
+ break;
+ default:
+ xassert(stat != stat);
+ }
+ }
+ else
+ { /* xB[p] leaves the basis, xN[q] enters the basis */
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n);
+ kp = Q_col[p]; /* x[kp] = xB[p] */
+ kq = Q_col[m+q]; /* x[kq] = xN[q] */
+ /* check non-basic status of xB[p] which becomes xN[q] */
+ switch (type[kp])
+ { case SSX_FR:
+ xassert(p_stat == SSX_NF);
+ break;
+ case SSX_LO:
+ xassert(p_stat == SSX_NL);
+ break;
+ case SSX_UP:
+ xassert(p_stat == SSX_NU);
+ break;
+ case SSX_DB:
+ xassert(p_stat == SSX_NL || p_stat == SSX_NU);
+ break;
+ case SSX_FX:
+ xassert(p_stat == SSX_NS);
+ break;
+ default:
+ xassert(type != type);
+ }
+ /* swap xB[p] and xN[q] */
+ stat[kp] = (char)p_stat, stat[kq] = SSX_BS;
+ Q_row[kp] = m+q, Q_row[kq] = p;
+ Q_col[p] = kq, Q_col[m+q] = kp;
+ /* update factorization of the basis matrix */
+ if (bfx_update(ssx->binv, p))
+ { if (ssx_factorize(ssx))
+ xassert(("Internal error: basis matrix is singular", 0));
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_delete - delete simplex solver workspace.
+//
+// This routine deletes the simplex solver workspace freeing all the
+// memory allocated to this object. */
+
+void ssx_delete(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int nnz = ssx->A_ptr[n+1]-1;
+ int i, j, k;
+ xfree(ssx->type);
+ for (k = 1; k <= m+n; k++) mpq_clear(ssx->lb[k]);
+ xfree(ssx->lb);
+ for (k = 1; k <= m+n; k++) mpq_clear(ssx->ub[k]);
+ xfree(ssx->ub);
+ for (k = 0; k <= m+n; k++) mpq_clear(ssx->coef[k]);
+ xfree(ssx->coef);
+ xfree(ssx->A_ptr);
+ xfree(ssx->A_ind);
+ for (k = 1; k <= nnz; k++) mpq_clear(ssx->A_val[k]);
+ xfree(ssx->A_val);
+ xfree(ssx->stat);
+ xfree(ssx->Q_row);
+ xfree(ssx->Q_col);
+ bfx_delete_binv(ssx->binv);
+ for (i = 0; i <= m; i++) mpq_clear(ssx->bbar[i]);
+ xfree(ssx->bbar);
+ for (i = 1; i <= m; i++) mpq_clear(ssx->pi[i]);
+ xfree(ssx->pi);
+ for (j = 1; j <= n; j++) mpq_clear(ssx->cbar[j]);
+ xfree(ssx->cbar);
+ for (i = 1; i <= m; i++) mpq_clear(ssx->rho[i]);
+ xfree(ssx->rho);
+ for (j = 1; j <= n; j++) mpq_clear(ssx->ap[j]);
+ xfree(ssx->ap);
+ for (i = 1; i <= m; i++) mpq_clear(ssx->aq[i]);
+ xfree(ssx->aq);
+ mpq_clear(ssx->delta);
+ xfree(ssx);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/glpssx02.c b/test/monniaux/glpk-4.65/src/draft/glpssx02.c
new file mode 100644
index 00000000..81db1350
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/glpssx02.c
@@ -0,0 +1,523 @@
+/* glpssx02.c (simplex method, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "glpssx.h"
+
+static void show_progress(SSX *ssx, int phase)
+{ /* this auxiliary routine displays information about progress of
+ the search */
+ int i, def = 0;
+ for (i = 1; i <= ssx->m; i++)
+ if (ssx->type[ssx->Q_col[i]] == SSX_FX) def++;
+ xprintf("%s%6d: %s = %22.15g (%d)\n", phase == 1 ? " " : "*",
+ ssx->it_cnt, phase == 1 ? "infsum" : "objval",
+ mpq_get_d(ssx->bbar[0]), def);
+#if 0
+ ssx->tm_lag = utime();
+#else
+ ssx->tm_lag = xtime();
+#endif
+ return;
+}
+
+/*----------------------------------------------------------------------
+// ssx_phase_I - find primal feasible solution.
+//
+// This routine implements phase I of the primal simplex method.
+//
+// On exit the routine returns one of the following codes:
+//
+// 0 - feasible solution found;
+// 1 - problem has no feasible solution;
+// 2 - iterations limit exceeded;
+// 3 - time limit exceeded.
+----------------------------------------------------------------------*/
+
+int ssx_phase_I(SSX *ssx)
+{ int m = ssx->m;
+ int n = ssx->n;
+ int *type = ssx->type;
+ mpq_t *lb = ssx->lb;
+ mpq_t *ub = ssx->ub;
+ mpq_t *coef = ssx->coef;
+ int *A_ptr = ssx->A_ptr;
+ int *A_ind = ssx->A_ind;
+ mpq_t *A_val = ssx->A_val;
+ int *Q_col = ssx->Q_col;
+ mpq_t *bbar = ssx->bbar;
+ mpq_t *pi = ssx->pi;
+ mpq_t *cbar = ssx->cbar;
+ int *orig_type, orig_dir;
+ mpq_t *orig_lb, *orig_ub, *orig_coef;
+ int i, k, ret;
+ /* save components of the original LP problem, which are changed
+ by the routine */
+ orig_type = xcalloc(1+m+n, sizeof(int));
+ orig_lb = xcalloc(1+m+n, sizeof(mpq_t));
+ orig_ub = xcalloc(1+m+n, sizeof(mpq_t));
+ orig_coef = xcalloc(1+m+n, sizeof(mpq_t));
+ for (k = 1; k <= m+n; k++)
+ { orig_type[k] = type[k];
+ mpq_init(orig_lb[k]);
+ mpq_set(orig_lb[k], lb[k]);
+ mpq_init(orig_ub[k]);
+ mpq_set(orig_ub[k], ub[k]);
+ }
+ orig_dir = ssx->dir;
+ for (k = 0; k <= m+n; k++)
+ { mpq_init(orig_coef[k]);
+ mpq_set(orig_coef[k], coef[k]);
+ }
+ /* build an artificial basic solution, which is primal feasible,
+ and also build an auxiliary objective function to minimize the
+ sum of infeasibilities for the original problem */
+ ssx->dir = SSX_MIN;
+ for (k = 0; k <= m+n; k++) mpq_set_si(coef[k], 0, 1);
+ mpq_set_si(bbar[0], 0, 1);
+ for (i = 1; i <= m; i++)
+ { int t;
+ k = Q_col[i]; /* x[k] = xB[i] */
+ t = type[k];
+ if (t == SSX_LO || t == SSX_DB || t == SSX_FX)
+ { /* in the original problem x[k] has lower bound */
+ if (mpq_cmp(bbar[i], lb[k]) < 0)
+ { /* which is violated */
+ type[k] = SSX_UP;
+ mpq_set(ub[k], lb[k]);
+ mpq_set_si(lb[k], 0, 1);
+ mpq_set_si(coef[k], -1, 1);
+ mpq_add(bbar[0], bbar[0], ub[k]);
+ mpq_sub(bbar[0], bbar[0], bbar[i]);
+ }
+ }
+ if (t == SSX_UP || t == SSX_DB || t == SSX_FX)
+ { /* in the original problem x[k] has upper bound */
+ if (mpq_cmp(bbar[i], ub[k]) > 0)
+ { /* which is violated */
+ type[k] = SSX_LO;
+ mpq_set(lb[k], ub[k]);
+ mpq_set_si(ub[k], 0, 1);
+ mpq_set_si(coef[k], +1, 1);
+ mpq_add(bbar[0], bbar[0], bbar[i]);
+ mpq_sub(bbar[0], bbar[0], lb[k]);
+ }
+ }
+ }
+ /* now the initial basic solution should be primal feasible due
+ to changes of bounds of some basic variables, which turned to
+ implicit artifical variables */
+ /* compute simplex multipliers and reduced costs */
+ ssx_eval_pi(ssx);
+ ssx_eval_cbar(ssx);
+ /* display initial progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+ show_progress(ssx, 1);
+ /* main loop starts here */
+ for (;;)
+ { /* display current progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+#if 0
+ if (utime() - ssx->tm_lag >= ssx->out_frq - 0.001)
+#else
+ if (xdifftime(xtime(), ssx->tm_lag) >= ssx->out_frq - 0.001)
+#endif
+ show_progress(ssx, 1);
+ /* we do not need to wait until all artificial variables have
+ left the basis */
+ if (mpq_sgn(bbar[0]) == 0)
+ { /* the sum of infeasibilities is zero, therefore the current
+ solution is primal feasible for the original problem */
+ ret = 0;
+ break;
+ }
+ /* check if the iterations limit has been exhausted */
+ if (ssx->it_lim == 0)
+ { ret = 2;
+ break;
+ }
+ /* check if the time limit has been exhausted */
+#if 0
+ if (ssx->tm_lim >= 0.0 && ssx->tm_lim <= utime() - ssx->tm_beg)
+#else
+ if (ssx->tm_lim >= 0.0 &&
+ ssx->tm_lim <= xdifftime(xtime(), ssx->tm_beg))
+#endif
+ { ret = 3;
+ break;
+ }
+ /* choose non-basic variable xN[q] */
+ ssx_chuzc(ssx);
+ /* if xN[q] cannot be chosen, the sum of infeasibilities is
+ minimal but non-zero; therefore the original problem has no
+ primal feasible solution */
+ if (ssx->q == 0)
+ { ret = 1;
+ break;
+ }
+ /* compute q-th column of the simplex table */
+ ssx_eval_col(ssx);
+ /* choose basic variable xB[p] */
+ ssx_chuzr(ssx);
+ /* the sum of infeasibilities cannot be negative, therefore
+ the auxiliary lp problem cannot have unbounded solution */
+ xassert(ssx->p != 0);
+ /* update values of basic variables */
+ ssx_update_bbar(ssx);
+ if (ssx->p > 0)
+ { /* compute p-th row of the inverse inv(B) */
+ ssx_eval_rho(ssx);
+ /* compute p-th row of the simplex table */
+ ssx_eval_row(ssx);
+ xassert(mpq_cmp(ssx->aq[ssx->p], ssx->ap[ssx->q]) == 0);
+ /* update simplex multipliers */
+ ssx_update_pi(ssx);
+ /* update reduced costs of non-basic variables */
+ ssx_update_cbar(ssx);
+ }
+ /* xB[p] is leaving the basis; if it is implicit artificial
+ variable, the corresponding residual vanishes; therefore
+ bounds of this variable should be restored to the original
+ values */
+ if (ssx->p > 0)
+ { k = Q_col[ssx->p]; /* x[k] = xB[p] */
+ if (type[k] != orig_type[k])
+ { /* x[k] is implicit artificial variable */
+ type[k] = orig_type[k];
+ mpq_set(lb[k], orig_lb[k]);
+ mpq_set(ub[k], orig_ub[k]);
+ xassert(ssx->p_stat == SSX_NL || ssx->p_stat == SSX_NU);
+ ssx->p_stat = (ssx->p_stat == SSX_NL ? SSX_NU : SSX_NL);
+ if (type[k] == SSX_FX) ssx->p_stat = SSX_NS;
+ /* nullify the objective coefficient at x[k] */
+ mpq_set_si(coef[k], 0, 1);
+ /* since coef[k] has been changed, we need to compute
+ new reduced cost of x[k], which it will have in the
+ adjacent basis */
+ /* the formula d[j] = cN[j] - pi' * N[j] is used (note
+ that the vector pi is not changed, because it depends
+ on objective coefficients at basic variables, but in
+ the adjacent basis, for which the vector pi has been
+ just recomputed, x[k] is non-basic) */
+ if (k <= m)
+ { /* x[k] is auxiliary variable */
+ mpq_neg(cbar[ssx->q], pi[k]);
+ }
+ else
+ { /* x[k] is structural variable */
+ int ptr;
+ mpq_t temp;
+ mpq_init(temp);
+ mpq_set_si(cbar[ssx->q], 0, 1);
+ for (ptr = A_ptr[k-m]; ptr < A_ptr[k-m+1]; ptr++)
+ { mpq_mul(temp, pi[A_ind[ptr]], A_val[ptr]);
+ mpq_add(cbar[ssx->q], cbar[ssx->q], temp);
+ }
+ mpq_clear(temp);
+ }
+ }
+ }
+ /* jump to the adjacent vertex of the polyhedron */
+ ssx_change_basis(ssx);
+ /* one simplex iteration has been performed */
+ if (ssx->it_lim > 0) ssx->it_lim--;
+ ssx->it_cnt++;
+ }
+ /* display final progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+ show_progress(ssx, 1);
+ /* restore components of the original problem, which were changed
+ by the routine */
+ for (k = 1; k <= m+n; k++)
+ { type[k] = orig_type[k];
+ mpq_set(lb[k], orig_lb[k]);
+ mpq_clear(orig_lb[k]);
+ mpq_set(ub[k], orig_ub[k]);
+ mpq_clear(orig_ub[k]);
+ }
+ ssx->dir = orig_dir;
+ for (k = 0; k <= m+n; k++)
+ { mpq_set(coef[k], orig_coef[k]);
+ mpq_clear(orig_coef[k]);
+ }
+ xfree(orig_type);
+ xfree(orig_lb);
+ xfree(orig_ub);
+ xfree(orig_coef);
+ /* return to the calling program */
+ return ret;
+}
+
+/*----------------------------------------------------------------------
+// ssx_phase_II - find optimal solution.
+//
+// This routine implements phase II of the primal simplex method.
+//
+// On exit the routine returns one of the following codes:
+//
+// 0 - optimal solution found;
+// 1 - problem has unbounded solution;
+// 2 - iterations limit exceeded;
+// 3 - time limit exceeded.
+----------------------------------------------------------------------*/
+
+int ssx_phase_II(SSX *ssx)
+{ int ret;
+ /* display initial progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+ show_progress(ssx, 2);
+ /* main loop starts here */
+ for (;;)
+ { /* display current progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+#if 0
+ if (utime() - ssx->tm_lag >= ssx->out_frq - 0.001)
+#else
+ if (xdifftime(xtime(), ssx->tm_lag) >= ssx->out_frq - 0.001)
+#endif
+ show_progress(ssx, 2);
+ /* check if the iterations limit has been exhausted */
+ if (ssx->it_lim == 0)
+ { ret = 2;
+ break;
+ }
+ /* check if the time limit has been exhausted */
+#if 0
+ if (ssx->tm_lim >= 0.0 && ssx->tm_lim <= utime() - ssx->tm_beg)
+#else
+ if (ssx->tm_lim >= 0.0 &&
+ ssx->tm_lim <= xdifftime(xtime(), ssx->tm_beg))
+#endif
+ { ret = 3;
+ break;
+ }
+ /* choose non-basic variable xN[q] */
+ ssx_chuzc(ssx);
+ /* if xN[q] cannot be chosen, the current basic solution is
+ dual feasible and therefore optimal */
+ if (ssx->q == 0)
+ { ret = 0;
+ break;
+ }
+ /* compute q-th column of the simplex table */
+ ssx_eval_col(ssx);
+ /* choose basic variable xB[p] */
+ ssx_chuzr(ssx);
+ /* if xB[p] cannot be chosen, the problem has no dual feasible
+ solution (i.e. unbounded) */
+ if (ssx->p == 0)
+ { ret = 1;
+ break;
+ }
+ /* update values of basic variables */
+ ssx_update_bbar(ssx);
+ if (ssx->p > 0)
+ { /* compute p-th row of the inverse inv(B) */
+ ssx_eval_rho(ssx);
+ /* compute p-th row of the simplex table */
+ ssx_eval_row(ssx);
+ xassert(mpq_cmp(ssx->aq[ssx->p], ssx->ap[ssx->q]) == 0);
+#if 0
+ /* update simplex multipliers */
+ ssx_update_pi(ssx);
+#endif
+ /* update reduced costs of non-basic variables */
+ ssx_update_cbar(ssx);
+ }
+ /* jump to the adjacent vertex of the polyhedron */
+ ssx_change_basis(ssx);
+ /* one simplex iteration has been performed */
+ if (ssx->it_lim > 0) ssx->it_lim--;
+ ssx->it_cnt++;
+ }
+ /* display final progress of the search */
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ON)
+#endif
+ show_progress(ssx, 2);
+ /* return to the calling program */
+ return ret;
+}
+
+/*----------------------------------------------------------------------
+// ssx_driver - base driver to exact simplex method.
+//
+// This routine is a base driver to a version of the primal simplex
+// method using exact (bignum) arithmetic.
+//
+// On exit the routine returns one of the following codes:
+//
+// 0 - optimal solution found;
+// 1 - problem has no feasible solution;
+// 2 - problem has unbounded solution;
+// 3 - iterations limit exceeded (phase I);
+// 4 - iterations limit exceeded (phase II);
+// 5 - time limit exceeded (phase I);
+// 6 - time limit exceeded (phase II);
+// 7 - initial basis matrix is exactly singular.
+----------------------------------------------------------------------*/
+
+int ssx_driver(SSX *ssx)
+{ int m = ssx->m;
+ int *type = ssx->type;
+ mpq_t *lb = ssx->lb;
+ mpq_t *ub = ssx->ub;
+ int *Q_col = ssx->Q_col;
+ mpq_t *bbar = ssx->bbar;
+ int i, k, ret;
+ ssx->tm_beg = xtime();
+ /* factorize the initial basis matrix */
+ if (ssx_factorize(ssx))
+#if 0 /* 25/XI-2017 */
+ { xprintf("Initial basis matrix is singular\n");
+#else
+ { if (ssx->msg_lev >= GLP_MSG_ERR)
+ xprintf("Initial basis matrix is singular\n");
+#endif
+ ret = 7;
+ goto done;
+ }
+ /* compute values of basic variables */
+ ssx_eval_bbar(ssx);
+ /* check if the initial basic solution is primal feasible */
+ for (i = 1; i <= m; i++)
+ { int t;
+ k = Q_col[i]; /* x[k] = xB[i] */
+ t = type[k];
+ if (t == SSX_LO || t == SSX_DB || t == SSX_FX)
+ { /* x[k] has lower bound */
+ if (mpq_cmp(bbar[i], lb[k]) < 0)
+ { /* which is violated */
+ break;
+ }
+ }
+ if (t == SSX_UP || t == SSX_DB || t == SSX_FX)
+ { /* x[k] has upper bound */
+ if (mpq_cmp(bbar[i], ub[k]) > 0)
+ { /* which is violated */
+ break;
+ }
+ }
+ }
+ if (i > m)
+ { /* no basic variable violates its bounds */
+ ret = 0;
+ goto skip;
+ }
+ /* phase I: find primal feasible solution */
+ ret = ssx_phase_I(ssx);
+ switch (ret)
+ { case 0:
+ ret = 0;
+ break;
+ case 1:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("PROBLEM HAS NO FEASIBLE SOLUTION\n");
+ ret = 1;
+ break;
+ case 2:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("ITERATIONS LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ ret = 3;
+ break;
+ case 3:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("TIME LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ ret = 5;
+ break;
+ default:
+ xassert(ret != ret);
+ }
+ /* compute values of basic variables (actually only the objective
+ value needs to be computed) */
+ ssx_eval_bbar(ssx);
+skip: /* compute simplex multipliers */
+ ssx_eval_pi(ssx);
+ /* compute reduced costs of non-basic variables */
+ ssx_eval_cbar(ssx);
+ /* if phase I failed, do not start phase II */
+ if (ret != 0) goto done;
+ /* phase II: find optimal solution */
+ ret = ssx_phase_II(ssx);
+ switch (ret)
+ { case 0:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("OPTIMAL SOLUTION FOUND\n");
+ ret = 0;
+ break;
+ case 1:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("PROBLEM HAS UNBOUNDED SOLUTION\n");
+ ret = 2;
+ break;
+ case 2:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("ITERATIONS LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ ret = 4;
+ break;
+ case 3:
+#if 1 /* 25/XI-2017 */
+ if (ssx->msg_lev >= GLP_MSG_ALL)
+#endif
+ xprintf("TIME LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ ret = 6;
+ break;
+ default:
+ xassert(ret != ret);
+ }
+done: /* decrease the time limit by the spent amount of time */
+ if (ssx->tm_lim >= 0.0)
+#if 0
+ { ssx->tm_lim -= utime() - ssx->tm_beg;
+#else
+ { ssx->tm_lim -= xdifftime(xtime(), ssx->tm_beg);
+#endif
+ if (ssx->tm_lim < 0.0) ssx->tm_lim = 0.0;
+ }
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/ios.h b/test/monniaux/glpk-4.65/src/draft/ios.h
new file mode 100644
index 00000000..1cb07ee0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/ios.h
@@ -0,0 +1,547 @@
+/* ios.h (integer optimization suite) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef IOS_H
+#define IOS_H
+
+#include "prob.h"
+
+#if 1 /* 02/II-2018 */
+#define NEW_LOCAL 1
+#endif
+
+#if 1 /* 15/II-2018 */
+#define NEW_COVER 1
+#endif
+
+typedef struct IOSLOT IOSLOT;
+typedef struct IOSNPD IOSNPD;
+typedef struct IOSBND IOSBND;
+typedef struct IOSTAT IOSTAT;
+typedef struct IOSROW IOSROW;
+typedef struct IOSAIJ IOSAIJ;
+#ifdef NEW_LOCAL /* 02/II-2018 */
+typedef glp_prob IOSPOOL;
+typedef GLPROW IOSCUT;
+#else
+typedef struct IOSPOOL IOSPOOL;
+typedef struct IOSCUT IOSCUT;
+#endif
+
+struct glp_tree
+{ /* branch-and-bound tree */
+ int magic;
+ /* magic value used for debugging */
+ DMP *pool;
+ /* memory pool to store all IOS components */
+ int n;
+ /* number of columns (variables) */
+ /*--------------------------------------------------------------*/
+ /* problem components corresponding to the original MIP and its
+ LP relaxation (used to restore the original problem object on
+ exit from the solver) */
+ int orig_m;
+ /* number of rows */
+ unsigned char *orig_type; /* uchar orig_type[1+orig_m+n]; */
+ /* types of all variables */
+ double *orig_lb; /* double orig_lb[1+orig_m+n]; */
+ /* lower bounds of all variables */
+ double *orig_ub; /* double orig_ub[1+orig_m+n]; */
+ /* upper bounds of all variables */
+ unsigned char *orig_stat; /* uchar orig_stat[1+orig_m+n]; */
+ /* statuses of all variables */
+ double *orig_prim; /* double orig_prim[1+orig_m+n]; */
+ /* primal values of all variables */
+ double *orig_dual; /* double orig_dual[1+orig_m+n]; */
+ /* dual values of all variables */
+ double orig_obj;
+ /* optimal objective value for LP relaxation */
+ /*--------------------------------------------------------------*/
+ /* branch-and-bound tree */
+ int nslots;
+ /* length of the array of slots (enlarged automatically) */
+ int avail;
+ /* index of the first free slot; 0 means all slots are in use */
+ IOSLOT *slot; /* IOSLOT slot[1+nslots]; */
+ /* array of slots:
+ slot[0] is not used;
+ slot[p], 1 <= p <= nslots, either contains a pointer to some
+ node of the branch-and-bound tree, in which case p is used on
+ API level as the reference number of corresponding subproblem,
+ or is free; all free slots are linked into single linked list;
+ slot[1] always contains a pointer to the root node (it is free
+ only if the tree is empty) */
+ IOSNPD *head;
+ /* pointer to the head of the active list */
+ IOSNPD *tail;
+ /* pointer to the tail of the active list */
+ /* the active list is a doubly linked list of active subproblems
+ which correspond to leaves of the tree; all subproblems in the
+ active list are ordered chronologically (each a new subproblem
+ is always added to the tail of the list) */
+ int a_cnt;
+ /* current number of active nodes (including the current one) */
+ int n_cnt;
+ /* current number of all (active and inactive) nodes */
+ int t_cnt;
+ /* total number of nodes including those which have been already
+ removed from the tree; this count is increased by one whenever
+ a new node is created and never decreased */
+ /*--------------------------------------------------------------*/
+ /* problem components corresponding to the root subproblem */
+ int root_m;
+ /* number of rows */
+ unsigned char *root_type; /* uchar root_type[1+root_m+n]; */
+ /* types of all variables */
+ double *root_lb; /* double root_lb[1+root_m+n]; */
+ /* lower bounds of all variables */
+ double *root_ub; /* double root_ub[1+root_m+n]; */
+ /* upper bounds of all variables */
+ unsigned char *root_stat; /* uchar root_stat[1+root_m+n]; */
+ /* statuses of all variables */
+ /*--------------------------------------------------------------*/
+ /* current subproblem and its LP relaxation */
+ IOSNPD *curr;
+ /* pointer to the current subproblem (which can be only active);
+ NULL means the current subproblem does not exist */
+ glp_prob *mip;
+ /* original problem object passed to the solver; if the current
+ subproblem exists, its LP segment corresponds to LP relaxation
+ of the current subproblem; if the current subproblem does not
+ exist, its LP segment corresponds to LP relaxation of the root
+ subproblem (note that the root subproblem may differ from the
+ original MIP, because it may be preprocessed and/or may have
+ additional rows) */
+ unsigned char *non_int; /* uchar non_int[1+n]; */
+ /* these column flags are set each time when LP relaxation of the
+ current subproblem has been solved;
+ non_int[0] is not used;
+ non_int[j], 1 <= j <= n, is j-th column flag; if this flag is
+ set, corresponding variable is required to be integer, but its
+ value in basic solution is fractional */
+ /*--------------------------------------------------------------*/
+ /* problem components corresponding to the parent (predecessor)
+ subproblem for the current subproblem; used to inspect changes
+ on freezing the current subproblem */
+ int pred_m;
+ /* number of rows */
+ int pred_max;
+ /* length of the following four arrays (enlarged automatically),
+ pred_max >= pred_m + n */
+ unsigned char *pred_type; /* uchar pred_type[1+pred_m+n]; */
+ /* types of all variables */
+ double *pred_lb; /* double pred_lb[1+pred_m+n]; */
+ /* lower bounds of all variables */
+ double *pred_ub; /* double pred_ub[1+pred_m+n]; */
+ /* upper bounds of all variables */
+ unsigned char *pred_stat; /* uchar pred_stat[1+pred_m+n]; */
+ /* statuses of all variables */
+ /****************************************************************/
+ /* built-in cut generators segment */
+ IOSPOOL *local;
+ /* local cut pool */
+#if 1 /* 13/II-2018 */
+ glp_cov *cov_gen;
+ /* pointer to working area used by the cover cut generator */
+#endif
+ glp_mir *mir_gen;
+ /* pointer to working area used by the MIR cut generator */
+ glp_cfg *clq_gen;
+ /* pointer to conflict graph used by the clique cut generator */
+ /*--------------------------------------------------------------*/
+ void *pcost;
+ /* pointer to working area used on pseudocost branching */
+ int *iwrk; /* int iwrk[1+n]; */
+ /* working array */
+ double *dwrk; /* double dwrk[1+n]; */
+ /* working array */
+ /*--------------------------------------------------------------*/
+ /* control parameters and statistics */
+ const glp_iocp *parm;
+ /* copy of control parameters passed to the solver */
+ double tm_beg;
+ /* starting time of the search, in seconds; the total time of the
+ search is the difference between xtime() and tm_beg */
+ double tm_lag;
+ /* the most recent time, in seconds, at which the progress of the
+ the search was displayed */
+ int sol_cnt;
+ /* number of integer feasible solutions found */
+#if 1 /* 11/VII-2013 */
+ void *P; /* glp_prob *P; */
+ /* problem passed to glp_intopt */
+ void *npp; /* NPP *npp; */
+ /* preprocessor workspace or NULL */
+ const char *save_sol;
+ /* filename (template) to save every new solution */
+ int save_cnt;
+ /* count to generate filename */
+#endif
+ /*--------------------------------------------------------------*/
+ /* advanced solver interface */
+ int reason;
+ /* flag indicating the reason why the callback routine is being
+ called (see glpk.h) */
+ int stop;
+ /* flag indicating that the callback routine requires premature
+ termination of the search */
+ int next_p;
+ /* reference number of active subproblem selected to continue
+ the search; 0 means no subproblem has been selected */
+ int reopt;
+ /* flag indicating that the current LP relaxation needs to be
+ re-optimized */
+ int reinv;
+ /* flag indicating that some (non-active) rows were removed from
+ the current LP relaxation, so if there no new rows appear, the
+ basis must be re-factorized */
+ int br_var;
+ /* the number of variable chosen to branch on */
+ int br_sel;
+ /* flag indicating which branch (subproblem) is suggested to be
+ selected to continue the search:
+ GLP_DN_BRNCH - select down-branch
+ GLP_UP_BRNCH - select up-branch
+ GLP_NO_BRNCH - use general selection technique */
+ int child;
+ /* subproblem reference number corresponding to br_sel */
+};
+
+struct IOSLOT
+{ /* node subproblem slot */
+ IOSNPD *node;
+ /* pointer to subproblem descriptor; NULL means free slot */
+ int next;
+ /* index of another free slot (only if this slot is free) */
+};
+
+struct IOSNPD
+{ /* node subproblem descriptor */
+ int p;
+ /* subproblem reference number (it is the index to corresponding
+ slot, i.e. slot[p] points to this descriptor) */
+ IOSNPD *up;
+ /* pointer to the parent subproblem; NULL means this node is the
+ root of the tree, in which case p = 1 */
+ int level;
+ /* node level (the root node has level 0) */
+ int count;
+ /* if count = 0, this subproblem is active; if count > 0, this
+ subproblem is inactive, in which case count is the number of
+ its child subproblems */
+ /* the following three linked lists are destroyed on reviving and
+ built anew on freezing the subproblem: */
+ IOSBND *b_ptr;
+ /* linked list of rows and columns of the parent subproblem whose
+ types and bounds were changed */
+ IOSTAT *s_ptr;
+ /* linked list of rows and columns of the parent subproblem whose
+ statuses were changed */
+ IOSROW *r_ptr;
+ /* linked list of rows (cuts) added to the parent subproblem */
+ int solved;
+ /* how many times LP relaxation of this subproblem was solved;
+ for inactive subproblem this count is always non-zero;
+ for active subproblem, which is not current, this count may be
+ non-zero, if the subproblem was temporarily suspended */
+ double lp_obj;
+ /* optimal objective value to LP relaxation of this subproblem;
+ on creating a subproblem this value is inherited from its
+ parent; for the root subproblem, which has no parent, this
+ value is initially set to -DBL_MAX (minimization) or +DBL_MAX
+ (maximization); each time the subproblem is re-optimized, this
+ value is appropriately changed */
+ double bound;
+ /* local lower (minimization) or upper (maximization) bound for
+ integer optimal solution to *this* subproblem; this bound is
+ local in the sense that only subproblems in the subtree rooted
+ at this node cannot have better integer feasible solutions;
+ on creating a subproblem its local bound is inherited from its
+ parent and then can be made stronger (never weaker); for the
+ root subproblem its local bound is initially set to -DBL_MAX
+ (minimization) or +DBL_MAX (maximization) and then improved as
+ the root LP relaxation has been solved */
+ /* the following two quantities are defined only if LP relaxation
+ of this subproblem was solved at least once (solved > 0): */
+ int ii_cnt;
+ /* number of integer variables whose value in optimal solution to
+ LP relaxation of this subproblem is fractional */
+ double ii_sum;
+ /* sum of integer infeasibilities */
+#if 1 /* 30/XI-2009 */
+ int changed;
+ /* how many times this subproblem was re-formulated (by adding
+ cutting plane constraints) */
+#endif
+ int br_var;
+ /* ordinal number of branching variable, 1 <= br_var <= n, used
+ to split this subproblem; 0 means that either this subproblem
+ is active or branching was made on a constraint */
+ double br_val;
+ /* (fractional) value of branching variable in optimal solution
+ to final LP relaxation of this subproblem */
+ void *data; /* char data[tree->cb_size]; */
+ /* pointer to the application-specific data */
+ IOSNPD *temp;
+ /* working pointer used by some routines */
+ IOSNPD *prev;
+ /* pointer to previous subproblem in the active list */
+ IOSNPD *next;
+ /* pointer to next subproblem in the active list */
+};
+
+struct IOSBND
+{ /* bounds change entry */
+ int k;
+ /* ordinal number of corresponding row (1 <= k <= m) or column
+ (m+1 <= k <= m+n), where m and n are the number of rows and
+ columns, resp., in the parent subproblem */
+ unsigned char type;
+ /* new type */
+ double lb;
+ /* new lower bound */
+ double ub;
+ /* new upper bound */
+ IOSBND *next;
+ /* pointer to next entry for the same subproblem */
+};
+
+struct IOSTAT
+{ /* status change entry */
+ int k;
+ /* ordinal number of corresponding row (1 <= k <= m) or column
+ (m+1 <= k <= m+n), where m and n are the number of rows and
+ columns, resp., in the parent subproblem */
+ unsigned char stat;
+ /* new status */
+ IOSTAT *next;
+ /* pointer to next entry for the same subproblem */
+};
+
+struct IOSROW
+{ /* row (constraint) addition entry */
+ char *name;
+ /* row name or NULL */
+ unsigned char origin;
+ /* row origin flag (see glp_attr.origin) */
+ unsigned char klass;
+ /* row class descriptor (see glp_attr.klass) */
+ unsigned char type;
+ /* row type (GLP_LO, GLP_UP, etc.) */
+ double lb;
+ /* row lower bound */
+ double ub;
+ /* row upper bound */
+ IOSAIJ *ptr;
+ /* pointer to the row coefficient list */
+ double rii;
+ /* row scale factor */
+ unsigned char stat;
+ /* row status (GLP_BS, GLP_NL, etc.) */
+ IOSROW *next;
+ /* pointer to next entry for the same subproblem */
+};
+
+struct IOSAIJ
+{ /* constraint coefficient */
+ int j;
+ /* variable (column) number, 1 <= j <= n */
+ double val;
+ /* non-zero coefficient value */
+ IOSAIJ *next;
+ /* pointer to next coefficient for the same row */
+};
+
+#ifndef NEW_LOCAL /* 02/II-2018 */
+struct IOSPOOL
+{ /* cut pool */
+ int size;
+ /* pool size = number of cuts in the pool */
+ IOSCUT *head;
+ /* pointer to the first cut */
+ IOSCUT *tail;
+ /* pointer to the last cut */
+ int ord;
+ /* ordinal number of the current cut, 1 <= ord <= size */
+ IOSCUT *curr;
+ /* pointer to the current cut */
+};
+#endif
+
+#ifndef NEW_LOCAL /* 02/II-2018 */
+struct IOSCUT
+{ /* cut (cutting plane constraint) */
+ char *name;
+ /* cut name or NULL */
+ unsigned char klass;
+ /* cut class descriptor (see glp_attr.klass) */
+ IOSAIJ *ptr;
+ /* pointer to the cut coefficient list */
+ unsigned char type;
+ /* cut type:
+ GLP_LO: sum a[j] * x[j] >= b
+ GLP_UP: sum a[j] * x[j] <= b
+ GLP_FX: sum a[j] * x[j] = b */
+ double rhs;
+ /* cut right-hand side */
+ IOSCUT *prev;
+ /* pointer to previous cut */
+ IOSCUT *next;
+ /* pointer to next cut */
+};
+#endif
+
+#define ios_create_tree _glp_ios_create_tree
+glp_tree *ios_create_tree(glp_prob *mip, const glp_iocp *parm);
+/* create branch-and-bound tree */
+
+#define ios_revive_node _glp_ios_revive_node
+void ios_revive_node(glp_tree *tree, int p);
+/* revive specified subproblem */
+
+#define ios_freeze_node _glp_ios_freeze_node
+void ios_freeze_node(glp_tree *tree);
+/* freeze current subproblem */
+
+#define ios_clone_node _glp_ios_clone_node
+void ios_clone_node(glp_tree *tree, int p, int nnn, int ref[]);
+/* clone specified subproblem */
+
+#define ios_delete_node _glp_ios_delete_node
+void ios_delete_node(glp_tree *tree, int p);
+/* delete specified subproblem */
+
+#define ios_delete_tree _glp_ios_delete_tree
+void ios_delete_tree(glp_tree *tree);
+/* delete branch-and-bound tree */
+
+#define ios_eval_degrad _glp_ios_eval_degrad
+void ios_eval_degrad(glp_tree *tree, int j, double *dn, double *up);
+/* estimate obj. degrad. for down- and up-branches */
+
+#define ios_round_bound _glp_ios_round_bound
+double ios_round_bound(glp_tree *tree, double bound);
+/* improve local bound by rounding */
+
+#define ios_is_hopeful _glp_ios_is_hopeful
+int ios_is_hopeful(glp_tree *tree, double bound);
+/* check if subproblem is hopeful */
+
+#define ios_best_node _glp_ios_best_node
+int ios_best_node(glp_tree *tree);
+/* find active node with best local bound */
+
+#define ios_relative_gap _glp_ios_relative_gap
+double ios_relative_gap(glp_tree *tree);
+/* compute relative mip gap */
+
+#define ios_solve_node _glp_ios_solve_node
+int ios_solve_node(glp_tree *tree);
+/* solve LP relaxation of current subproblem */
+
+#define ios_create_pool _glp_ios_create_pool
+IOSPOOL *ios_create_pool(glp_tree *tree);
+/* create cut pool */
+
+#define ios_add_row _glp_ios_add_row
+int ios_add_row(glp_tree *tree, IOSPOOL *pool,
+ const char *name, int klass, int flags, int len, const int ind[],
+ const double val[], int type, double rhs);
+/* add row (constraint) to the cut pool */
+
+#define ios_find_row _glp_ios_find_row
+IOSCUT *ios_find_row(IOSPOOL *pool, int i);
+/* find row (constraint) in the cut pool */
+
+#define ios_del_row _glp_ios_del_row
+void ios_del_row(glp_tree *tree, IOSPOOL *pool, int i);
+/* remove row (constraint) from the cut pool */
+
+#define ios_clear_pool _glp_ios_clear_pool
+void ios_clear_pool(glp_tree *tree, IOSPOOL *pool);
+/* remove all rows (constraints) from the cut pool */
+
+#define ios_delete_pool _glp_ios_delete_pool
+void ios_delete_pool(glp_tree *tree, IOSPOOL *pool);
+/* delete cut pool */
+
+#if 1 /* 11/VII-2013 */
+#define ios_process_sol _glp_ios_process_sol
+void ios_process_sol(glp_tree *T);
+/* process integer feasible solution just found */
+#endif
+
+#define ios_preprocess_node _glp_ios_preprocess_node
+int ios_preprocess_node(glp_tree *tree, int max_pass);
+/* preprocess current subproblem */
+
+#define ios_driver _glp_ios_driver
+int ios_driver(glp_tree *tree);
+/* branch-and-bound driver */
+
+#define ios_cov_gen _glp_ios_cov_gen
+void ios_cov_gen(glp_tree *tree);
+/* generate mixed cover cuts */
+
+#define ios_pcost_init _glp_ios_pcost_init
+void *ios_pcost_init(glp_tree *tree);
+/* initialize working data used on pseudocost branching */
+
+#define ios_pcost_branch _glp_ios_pcost_branch
+int ios_pcost_branch(glp_tree *T, int *next);
+/* choose branching variable with pseudocost branching */
+
+#define ios_pcost_update _glp_ios_pcost_update
+void ios_pcost_update(glp_tree *tree);
+/* update history information for pseudocost branching */
+
+#define ios_pcost_free _glp_ios_pcost_free
+void ios_pcost_free(glp_tree *tree);
+/* free working area used on pseudocost branching */
+
+#define ios_feas_pump _glp_ios_feas_pump
+void ios_feas_pump(glp_tree *T);
+/* feasibility pump heuristic */
+
+#if 1 /* 25/V-2013 */
+#define ios_proxy_heur _glp_ios_proxy_heur
+void ios_proxy_heur(glp_tree *T);
+/* proximity search heuristic */
+#endif
+
+#define ios_process_cuts _glp_ios_process_cuts
+void ios_process_cuts(glp_tree *T);
+/* process cuts stored in the local cut pool */
+
+#define ios_choose_node _glp_ios_choose_node
+int ios_choose_node(glp_tree *T);
+/* select subproblem to continue the search */
+
+#define ios_choose_var _glp_ios_choose_var
+int ios_choose_var(glp_tree *T, int *next);
+/* select variable to branch on */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/lux.c b/test/monniaux/glpk-4.65/src/draft/lux.c
new file mode 100644
index 00000000..38cb758c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/lux.c
@@ -0,0 +1,1030 @@
+/* lux.c (LU-factorization, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "lux.h"
+
+#define xfault xerror
+#define dmp_create_poolx(size) dmp_create_pool()
+
+/***********************************************************************
+* lux_create - create LU-factorization
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* LUX *lux_create(int n);
+*
+* DESCRIPTION
+*
+* The routine lux_create creates LU-factorization data structure for
+* a matrix of the order n. Initially the factorization corresponds to
+* the unity matrix (F = V = P = Q = I, so A = I).
+*
+* RETURNS
+*
+* The routine returns a pointer to the created LU-factorization data
+* structure, which represents the unity matrix of the order n. */
+
+LUX *lux_create(int n)
+{ LUX *lux;
+ int k;
+ if (n < 1)
+ xfault("lux_create: n = %d; invalid parameter\n", n);
+ lux = xmalloc(sizeof(LUX));
+ lux->n = n;
+ lux->pool = dmp_create_poolx(sizeof(LUXELM));
+ lux->F_row = xcalloc(1+n, sizeof(LUXELM *));
+ lux->F_col = xcalloc(1+n, sizeof(LUXELM *));
+ lux->V_piv = xcalloc(1+n, sizeof(mpq_t));
+ lux->V_row = xcalloc(1+n, sizeof(LUXELM *));
+ lux->V_col = xcalloc(1+n, sizeof(LUXELM *));
+ lux->P_row = xcalloc(1+n, sizeof(int));
+ lux->P_col = xcalloc(1+n, sizeof(int));
+ lux->Q_row = xcalloc(1+n, sizeof(int));
+ lux->Q_col = xcalloc(1+n, sizeof(int));
+ for (k = 1; k <= n; k++)
+ { lux->F_row[k] = lux->F_col[k] = NULL;
+ mpq_init(lux->V_piv[k]);
+ mpq_set_si(lux->V_piv[k], 1, 1);
+ lux->V_row[k] = lux->V_col[k] = NULL;
+ lux->P_row[k] = lux->P_col[k] = k;
+ lux->Q_row[k] = lux->Q_col[k] = k;
+ }
+ lux->rank = n;
+ return lux;
+}
+
+/***********************************************************************
+* initialize - initialize LU-factorization data structures
+*
+* This routine initializes data structures for subsequent computing
+* the LU-factorization of a given matrix A, which is specified by the
+* formal routine col. On exit V = A and F = P = Q = I, where I is the
+* unity matrix. */
+
+static void initialize(LUX *lux, int (*col)(void *info, int j,
+ int ind[], mpq_t val[]), void *info, LUXWKA *wka)
+{ int n = lux->n;
+ DMP *pool = lux->pool;
+ LUXELM **F_row = lux->F_row;
+ LUXELM **F_col = lux->F_col;
+ mpq_t *V_piv = lux->V_piv;
+ LUXELM **V_row = lux->V_row;
+ LUXELM **V_col = lux->V_col;
+ int *P_row = lux->P_row;
+ int *P_col = lux->P_col;
+ int *Q_row = lux->Q_row;
+ int *Q_col = lux->Q_col;
+ int *R_len = wka->R_len;
+ int *R_head = wka->R_head;
+ int *R_prev = wka->R_prev;
+ int *R_next = wka->R_next;
+ int *C_len = wka->C_len;
+ int *C_head = wka->C_head;
+ int *C_prev = wka->C_prev;
+ int *C_next = wka->C_next;
+ LUXELM *fij, *vij;
+ int i, j, k, len, *ind;
+ mpq_t *val;
+ /* F := I */
+ for (i = 1; i <= n; i++)
+ { while (F_row[i] != NULL)
+ { fij = F_row[i], F_row[i] = fij->r_next;
+ mpq_clear(fij->val);
+ dmp_free_atom(pool, fij, sizeof(LUXELM));
+ }
+ }
+ for (j = 1; j <= n; j++) F_col[j] = NULL;
+ /* V := 0 */
+ for (k = 1; k <= n; k++) mpq_set_si(V_piv[k], 0, 1);
+ for (i = 1; i <= n; i++)
+ { while (V_row[i] != NULL)
+ { vij = V_row[i], V_row[i] = vij->r_next;
+ mpq_clear(vij->val);
+ dmp_free_atom(pool, vij, sizeof(LUXELM));
+ }
+ }
+ for (j = 1; j <= n; j++) V_col[j] = NULL;
+ /* V := A */
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(mpq_t));
+ for (k = 1; k <= n; k++) mpq_init(val[k]);
+ for (j = 1; j <= n; j++)
+ { /* obtain j-th column of matrix A */
+ len = col(info, j, ind, val);
+ if (!(0 <= len && len <= n))
+ xfault("lux_decomp: j = %d: len = %d; invalid column length"
+ "\n", j, len);
+ /* copy elements of j-th column to matrix V */
+ for (k = 1; k <= len; k++)
+ { /* get row index of a[i,j] */
+ i = ind[k];
+ if (!(1 <= i && i <= n))
+ xfault("lux_decomp: j = %d: i = %d; row index out of ran"
+ "ge\n", j, i);
+ /* check for duplicate indices */
+ if (V_row[i] != NULL && V_row[i]->j == j)
+ xfault("lux_decomp: j = %d: i = %d; duplicate row indice"
+ "s not allowed\n", j, i);
+ /* check for zero value */
+ if (mpq_sgn(val[k]) == 0)
+ xfault("lux_decomp: j = %d: i = %d; zero elements not al"
+ "lowed\n", j, i);
+ /* add new element v[i,j] = a[i,j] to V */
+ vij = dmp_get_atom(pool, sizeof(LUXELM));
+ vij->i = i, vij->j = j;
+ mpq_init(vij->val);
+ mpq_set(vij->val, val[k]);
+ vij->r_prev = NULL;
+ vij->r_next = V_row[i];
+ vij->c_prev = NULL;
+ vij->c_next = V_col[j];
+ if (vij->r_next != NULL) vij->r_next->r_prev = vij;
+ if (vij->c_next != NULL) vij->c_next->c_prev = vij;
+ V_row[i] = V_col[j] = vij;
+ }
+ }
+ xfree(ind);
+ for (k = 1; k <= n; k++) mpq_clear(val[k]);
+ xfree(val);
+ /* P := Q := I */
+ for (k = 1; k <= n; k++)
+ P_row[k] = P_col[k] = Q_row[k] = Q_col[k] = k;
+ /* the rank of A and V is not determined yet */
+ lux->rank = -1;
+ /* initially the entire matrix V is active */
+ /* determine its row lengths */
+ for (i = 1; i <= n; i++)
+ { len = 0;
+ for (vij = V_row[i]; vij != NULL; vij = vij->r_next) len++;
+ R_len[i] = len;
+ }
+ /* build linked lists of active rows */
+ for (len = 0; len <= n; len++) R_head[len] = 0;
+ for (i = 1; i <= n; i++)
+ { len = R_len[i];
+ R_prev[i] = 0;
+ R_next[i] = R_head[len];
+ if (R_next[i] != 0) R_prev[R_next[i]] = i;
+ R_head[len] = i;
+ }
+ /* determine its column lengths */
+ for (j = 1; j <= n; j++)
+ { len = 0;
+ for (vij = V_col[j]; vij != NULL; vij = vij->c_next) len++;
+ C_len[j] = len;
+ }
+ /* build linked lists of active columns */
+ for (len = 0; len <= n; len++) C_head[len] = 0;
+ for (j = 1; j <= n; j++)
+ { len = C_len[j];
+ C_prev[j] = 0;
+ C_next[j] = C_head[len];
+ if (C_next[j] != 0) C_prev[C_next[j]] = j;
+ C_head[len] = j;
+ }
+ return;
+}
+
+/***********************************************************************
+* find_pivot - choose a pivot element
+*
+* This routine chooses a pivot element v[p,q] in the active submatrix
+* of matrix U = P*V*Q.
+*
+* It is assumed that on entry the matrix U has the following partially
+* triangularized form:
+*
+* 1 k n
+* 1 x x x x x x x x x x
+* . x x x x x x x x x
+* . . x x x x x x x x
+* . . . x x x x x x x
+* k . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* . . . . * * * * * *
+* n . . . . * * * * * *
+*
+* where rows and columns k, k+1, ..., n belong to the active submatrix
+* (elements of the active submatrix are marked by '*').
+*
+* Since the matrix U = P*V*Q is not stored, the routine works with the
+* matrix V. It is assumed that the row-wise representation corresponds
+* to the matrix V, but the column-wise representation corresponds to
+* the active submatrix of the matrix V, i.e. elements of the matrix V,
+* which does not belong to the active submatrix, are missing from the
+* column linked lists. It is also assumed that each active row of the
+* matrix V is in the set R[len], where len is number of non-zeros in
+* the row, and each active column of the matrix V is in the set C[len],
+* where len is number of non-zeros in the column (in the latter case
+* only elements of the active submatrix are counted; such elements are
+* marked by '*' on the figure above).
+*
+* Due to exact arithmetic any non-zero element of the active submatrix
+* can be chosen as a pivot. However, to keep sparsity of the matrix V
+* the routine uses Markowitz strategy, trying to choose such element
+* v[p,q], which has smallest Markowitz cost (nr[p]-1) * (nc[q]-1),
+* where nr[p] and nc[q] are the number of non-zero elements, resp., in
+* p-th row and in q-th column of the active submatrix.
+*
+* In order to reduce the search, i.e. not to walk through all elements
+* of the active submatrix, the routine exploits a technique proposed by
+* I.Duff. This technique is based on using the sets R[len] and C[len]
+* of active rows and columns.
+*
+* On exit the routine returns a pointer to a pivot v[p,q] chosen, or
+* NULL, if the active submatrix is empty. */
+
+static LUXELM *find_pivot(LUX *lux, LUXWKA *wka)
+{ int n = lux->n;
+ LUXELM **V_row = lux->V_row;
+ LUXELM **V_col = lux->V_col;
+ int *R_len = wka->R_len;
+ int *R_head = wka->R_head;
+ int *R_next = wka->R_next;
+ int *C_len = wka->C_len;
+ int *C_head = wka->C_head;
+ int *C_next = wka->C_next;
+ LUXELM *piv, *some, *vij;
+ int i, j, len, min_len, ncand, piv_lim = 5;
+ double best, cost;
+ /* nothing is chosen so far */
+ piv = NULL, best = DBL_MAX, ncand = 0;
+ /* if in the active submatrix there is a column that has the only
+ non-zero (column singleton), choose it as a pivot */
+ j = C_head[1];
+ if (j != 0)
+ { xassert(C_len[j] == 1);
+ piv = V_col[j];
+ xassert(piv != NULL && piv->c_next == NULL);
+ goto done;
+ }
+ /* if in the active submatrix there is a row that has the only
+ non-zero (row singleton), choose it as a pivot */
+ i = R_head[1];
+ if (i != 0)
+ { xassert(R_len[i] == 1);
+ piv = V_row[i];
+ xassert(piv != NULL && piv->r_next == NULL);
+ goto done;
+ }
+ /* there are no singletons in the active submatrix; walk through
+ other non-empty rows and columns */
+ for (len = 2; len <= n; len++)
+ { /* consider active columns having len non-zeros */
+ for (j = C_head[len]; j != 0; j = C_next[j])
+ { /* j-th column has len non-zeros */
+ /* find an element in the row of minimal length */
+ some = NULL, min_len = INT_MAX;
+ for (vij = V_col[j]; vij != NULL; vij = vij->c_next)
+ { if (min_len > R_len[vij->i])
+ some = vij, min_len = R_len[vij->i];
+ /* if Markowitz cost of this element is not greater than
+ (len-1)**2, it can be chosen right now; this heuristic
+ reduces the search and works well in many cases */
+ if (min_len <= len)
+ { piv = some;
+ goto done;
+ }
+ }
+ /* j-th column has been scanned */
+ /* the minimal element found is a next pivot candidate */
+ xassert(some != NULL);
+ ncand++;
+ /* compute its Markowitz cost */
+ cost = (double)(min_len - 1) * (double)(len - 1);
+ /* choose between the current candidate and this element */
+ if (cost < best) piv = some, best = cost;
+ /* if piv_lim candidates have been considered, there is a
+ doubt that a much better candidate exists; therefore it
+ is the time to terminate the search */
+ if (ncand == piv_lim) goto done;
+ }
+ /* now consider active rows having len non-zeros */
+ for (i = R_head[len]; i != 0; i = R_next[i])
+ { /* i-th row has len non-zeros */
+ /* find an element in the column of minimal length */
+ some = NULL, min_len = INT_MAX;
+ for (vij = V_row[i]; vij != NULL; vij = vij->r_next)
+ { if (min_len > C_len[vij->j])
+ some = vij, min_len = C_len[vij->j];
+ /* if Markowitz cost of this element is not greater than
+ (len-1)**2, it can be chosen right now; this heuristic
+ reduces the search and works well in many cases */
+ if (min_len <= len)
+ { piv = some;
+ goto done;
+ }
+ }
+ /* i-th row has been scanned */
+ /* the minimal element found is a next pivot candidate */
+ xassert(some != NULL);
+ ncand++;
+ /* compute its Markowitz cost */
+ cost = (double)(len - 1) * (double)(min_len - 1);
+ /* choose between the current candidate and this element */
+ if (cost < best) piv = some, best = cost;
+ /* if piv_lim candidates have been considered, there is a
+ doubt that a much better candidate exists; therefore it
+ is the time to terminate the search */
+ if (ncand == piv_lim) goto done;
+ }
+ }
+done: /* bring the pivot v[p,q] to the factorizing routine */
+ return piv;
+}
+
+/***********************************************************************
+* eliminate - perform gaussian elimination
+*
+* This routine performs elementary gaussian transformations in order
+* to eliminate subdiagonal elements in the k-th column of the matrix
+* U = P*V*Q using the pivot element u[k,k], where k is the number of
+* the current elimination step.
+*
+* The parameter piv specifies the pivot element v[p,q] = u[k,k].
+*
+* Each time when the routine applies the elementary transformation to
+* a non-pivot row of the matrix V, it stores the corresponding element
+* to the matrix F in order to keep the main equality A = F*V.
+*
+* The routine assumes that on entry the matrices L = P*F*inv(P) and
+* U = P*V*Q are the following:
+*
+* 1 k 1 k n
+* 1 1 . . . . . . . . . 1 x x x x x x x x x x
+* x 1 . . . . . . . . . x x x x x x x x x
+* x x 1 . . . . . . . . . x x x x x x x x
+* x x x 1 . . . . . . . . . x x x x x x x
+* k x x x x 1 . . . . . k . . . . * * * * * *
+* x x x x _ 1 . . . . . . . . # * * * * *
+* x x x x _ . 1 . . . . . . . # * * * * *
+* x x x x _ . . 1 . . . . . . # * * * * *
+* x x x x _ . . . 1 . . . . . # * * * * *
+* n x x x x _ . . . . 1 n . . . . # * * * * *
+*
+* matrix L matrix U
+*
+* where rows and columns of the matrix U with numbers k, k+1, ..., n
+* form the active submatrix (eliminated elements are marked by '#' and
+* other elements of the active submatrix are marked by '*'). Note that
+* each eliminated non-zero element u[i,k] of the matrix U gives the
+* corresponding element l[i,k] of the matrix L (marked by '_').
+*
+* Actually all operations are performed on the matrix V. Should note
+* that the row-wise representation corresponds to the matrix V, but the
+* column-wise representation corresponds to the active submatrix of the
+* matrix V, i.e. elements of the matrix V, which doesn't belong to the
+* active submatrix, are missing from the column linked lists.
+*
+* Let u[k,k] = v[p,q] be the pivot. In order to eliminate subdiagonal
+* elements u[i',k] = v[i,q], i' = k+1, k+2, ..., n, the routine applies
+* the following elementary gaussian transformations:
+*
+* (i-th row of V) := (i-th row of V) - f[i,p] * (p-th row of V),
+*
+* where f[i,p] = v[i,q] / v[p,q] is a gaussian multiplier.
+*
+* Additionally, in order to keep the main equality A = F*V, each time
+* when the routine applies the transformation to i-th row of the matrix
+* V, it also adds f[i,p] as a new element to the matrix F.
+*
+* IMPORTANT: On entry the working arrays flag and work should contain
+* zeros. This status is provided by the routine on exit. */
+
+static void eliminate(LUX *lux, LUXWKA *wka, LUXELM *piv, int flag[],
+ mpq_t work[])
+{ DMP *pool = lux->pool;
+ LUXELM **F_row = lux->F_row;
+ LUXELM **F_col = lux->F_col;
+ mpq_t *V_piv = lux->V_piv;
+ LUXELM **V_row = lux->V_row;
+ LUXELM **V_col = lux->V_col;
+ int *R_len = wka->R_len;
+ int *R_head = wka->R_head;
+ int *R_prev = wka->R_prev;
+ int *R_next = wka->R_next;
+ int *C_len = wka->C_len;
+ int *C_head = wka->C_head;
+ int *C_prev = wka->C_prev;
+ int *C_next = wka->C_next;
+ LUXELM *fip, *vij, *vpj, *viq, *next;
+ mpq_t temp;
+ int i, j, p, q;
+ mpq_init(temp);
+ /* determine row and column indices of the pivot v[p,q] */
+ xassert(piv != NULL);
+ p = piv->i, q = piv->j;
+ /* remove p-th (pivot) row from the active set; it will never
+ return there */
+ if (R_prev[p] == 0)
+ R_head[R_len[p]] = R_next[p];
+ else
+ R_next[R_prev[p]] = R_next[p];
+ if (R_next[p] == 0)
+ ;
+ else
+ R_prev[R_next[p]] = R_prev[p];
+ /* remove q-th (pivot) column from the active set; it will never
+ return there */
+ if (C_prev[q] == 0)
+ C_head[C_len[q]] = C_next[q];
+ else
+ C_next[C_prev[q]] = C_next[q];
+ if (C_next[q] == 0)
+ ;
+ else
+ C_prev[C_next[q]] = C_prev[q];
+ /* store the pivot value in a separate array */
+ mpq_set(V_piv[p], piv->val);
+ /* remove the pivot from p-th row */
+ if (piv->r_prev == NULL)
+ V_row[p] = piv->r_next;
+ else
+ piv->r_prev->r_next = piv->r_next;
+ if (piv->r_next == NULL)
+ ;
+ else
+ piv->r_next->r_prev = piv->r_prev;
+ R_len[p]--;
+ /* remove the pivot from q-th column */
+ if (piv->c_prev == NULL)
+ V_col[q] = piv->c_next;
+ else
+ piv->c_prev->c_next = piv->c_next;
+ if (piv->c_next == NULL)
+ ;
+ else
+ piv->c_next->c_prev = piv->c_prev;
+ C_len[q]--;
+ /* free the space occupied by the pivot */
+ mpq_clear(piv->val);
+ dmp_free_atom(pool, piv, sizeof(LUXELM));
+ /* walk through p-th (pivot) row, which already does not contain
+ the pivot v[p,q], and do the following... */
+ for (vpj = V_row[p]; vpj != NULL; vpj = vpj->r_next)
+ { /* get column index of v[p,j] */
+ j = vpj->j;
+ /* store v[p,j] in the working array */
+ flag[j] = 1;
+ mpq_set(work[j], vpj->val);
+ /* remove j-th column from the active set; it will return there
+ later with a new length */
+ if (C_prev[j] == 0)
+ C_head[C_len[j]] = C_next[j];
+ else
+ C_next[C_prev[j]] = C_next[j];
+ if (C_next[j] == 0)
+ ;
+ else
+ C_prev[C_next[j]] = C_prev[j];
+ /* v[p,j] leaves the active submatrix, so remove it from j-th
+ column; however, v[p,j] is kept in p-th row */
+ if (vpj->c_prev == NULL)
+ V_col[j] = vpj->c_next;
+ else
+ vpj->c_prev->c_next = vpj->c_next;
+ if (vpj->c_next == NULL)
+ ;
+ else
+ vpj->c_next->c_prev = vpj->c_prev;
+ C_len[j]--;
+ }
+ /* now walk through q-th (pivot) column, which already does not
+ contain the pivot v[p,q], and perform gaussian elimination */
+ while (V_col[q] != NULL)
+ { /* element v[i,q] has to be eliminated */
+ viq = V_col[q];
+ /* get row index of v[i,q] */
+ i = viq->i;
+ /* remove i-th row from the active set; later it will return
+ there with a new length */
+ if (R_prev[i] == 0)
+ R_head[R_len[i]] = R_next[i];
+ else
+ R_next[R_prev[i]] = R_next[i];
+ if (R_next[i] == 0)
+ ;
+ else
+ R_prev[R_next[i]] = R_prev[i];
+ /* compute gaussian multiplier f[i,p] = v[i,q] / v[p,q] and
+ store it in the matrix F */
+ fip = dmp_get_atom(pool, sizeof(LUXELM));
+ fip->i = i, fip->j = p;
+ mpq_init(fip->val);
+ mpq_div(fip->val, viq->val, V_piv[p]);
+ fip->r_prev = NULL;
+ fip->r_next = F_row[i];
+ fip->c_prev = NULL;
+ fip->c_next = F_col[p];
+ if (fip->r_next != NULL) fip->r_next->r_prev = fip;
+ if (fip->c_next != NULL) fip->c_next->c_prev = fip;
+ F_row[i] = F_col[p] = fip;
+ /* v[i,q] has to be eliminated, so remove it from i-th row */
+ if (viq->r_prev == NULL)
+ V_row[i] = viq->r_next;
+ else
+ viq->r_prev->r_next = viq->r_next;
+ if (viq->r_next == NULL)
+ ;
+ else
+ viq->r_next->r_prev = viq->r_prev;
+ R_len[i]--;
+ /* and also from q-th column */
+ V_col[q] = viq->c_next;
+ C_len[q]--;
+ /* free the space occupied by v[i,q] */
+ mpq_clear(viq->val);
+ dmp_free_atom(pool, viq, sizeof(LUXELM));
+ /* perform gaussian transformation:
+ (i-th row) := (i-th row) - f[i,p] * (p-th row)
+ note that now p-th row, which is in the working array,
+ does not contain the pivot v[p,q], and i-th row does not
+ contain the element v[i,q] to be eliminated */
+ /* walk through i-th row and transform existing non-zero
+ elements */
+ for (vij = V_row[i]; vij != NULL; vij = next)
+ { next = vij->r_next;
+ /* get column index of v[i,j] */
+ j = vij->j;
+ /* v[i,j] := v[i,j] - f[i,p] * v[p,j] */
+ if (flag[j])
+ { /* v[p,j] != 0 */
+ flag[j] = 0;
+ mpq_mul(temp, fip->val, work[j]);
+ mpq_sub(vij->val, vij->val, temp);
+ if (mpq_sgn(vij->val) == 0)
+ { /* new v[i,j] is zero, so remove it from the active
+ submatrix */
+ /* remove v[i,j] from i-th row */
+ if (vij->r_prev == NULL)
+ V_row[i] = vij->r_next;
+ else
+ vij->r_prev->r_next = vij->r_next;
+ if (vij->r_next == NULL)
+ ;
+ else
+ vij->r_next->r_prev = vij->r_prev;
+ R_len[i]--;
+ /* remove v[i,j] from j-th column */
+ if (vij->c_prev == NULL)
+ V_col[j] = vij->c_next;
+ else
+ vij->c_prev->c_next = vij->c_next;
+ if (vij->c_next == NULL)
+ ;
+ else
+ vij->c_next->c_prev = vij->c_prev;
+ C_len[j]--;
+ /* free the space occupied by v[i,j] */
+ mpq_clear(vij->val);
+ dmp_free_atom(pool, vij, sizeof(LUXELM));
+ }
+ }
+ }
+ /* now flag is the pattern of the set v[p,*] \ v[i,*] */
+ /* walk through p-th (pivot) row and create new elements in
+ i-th row, which appear due to fill-in */
+ for (vpj = V_row[p]; vpj != NULL; vpj = vpj->r_next)
+ { j = vpj->j;
+ if (flag[j])
+ { /* create new non-zero v[i,j] = 0 - f[i,p] * v[p,j] and
+ add it to i-th row and j-th column */
+ vij = dmp_get_atom(pool, sizeof(LUXELM));
+ vij->i = i, vij->j = j;
+ mpq_init(vij->val);
+ mpq_mul(vij->val, fip->val, work[j]);
+ mpq_neg(vij->val, vij->val);
+ vij->r_prev = NULL;
+ vij->r_next = V_row[i];
+ vij->c_prev = NULL;
+ vij->c_next = V_col[j];
+ if (vij->r_next != NULL) vij->r_next->r_prev = vij;
+ if (vij->c_next != NULL) vij->c_next->c_prev = vij;
+ V_row[i] = V_col[j] = vij;
+ R_len[i]++, C_len[j]++;
+ }
+ else
+ { /* there is no fill-in, because v[i,j] already exists in
+ i-th row; restore the flag, which was reset before */
+ flag[j] = 1;
+ }
+ }
+ /* now i-th row has been completely transformed and can return
+ to the active set with a new length */
+ R_prev[i] = 0;
+ R_next[i] = R_head[R_len[i]];
+ if (R_next[i] != 0) R_prev[R_next[i]] = i;
+ R_head[R_len[i]] = i;
+ }
+ /* at this point q-th (pivot) column must be empty */
+ xassert(C_len[q] == 0);
+ /* walk through p-th (pivot) row again and do the following... */
+ for (vpj = V_row[p]; vpj != NULL; vpj = vpj->r_next)
+ { /* get column index of v[p,j] */
+ j = vpj->j;
+ /* erase v[p,j] from the working array */
+ flag[j] = 0;
+ mpq_set_si(work[j], 0, 1);
+ /* now j-th column has been completely transformed, so it can
+ return to the active list with a new length */
+ C_prev[j] = 0;
+ C_next[j] = C_head[C_len[j]];
+ if (C_next[j] != 0) C_prev[C_next[j]] = j;
+ C_head[C_len[j]] = j;
+ }
+ mpq_clear(temp);
+ /* return to the factorizing routine */
+ return;
+}
+
+/***********************************************************************
+* lux_decomp - compute LU-factorization
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* int lux_decomp(LUX *lux, int (*col)(void *info, int j, int ind[],
+* mpq_t val[]), void *info);
+*
+* DESCRIPTION
+*
+* The routine lux_decomp computes LU-factorization of a given square
+* matrix A.
+*
+* The parameter lux specifies LU-factorization data structure built by
+* means of the routine lux_create.
+*
+* The formal routine col specifies the original matrix A. In order to
+* obtain j-th column of the matrix A the routine lux_decomp calls the
+* routine col with the parameter j (1 <= j <= n, where n is the order
+* of A). In response the routine col should store row indices and
+* numerical values of non-zero elements of j-th column of A to the
+* locations ind[1], ..., ind[len] and val[1], ..., val[len], resp.,
+* where len is the number of non-zeros in j-th column, which should be
+* returned on exit. Neiter zero nor duplicate elements are allowed.
+*
+* The parameter info is a transit pointer passed to the formal routine
+* col; it can be used for various purposes.
+*
+* RETURNS
+*
+* The routine lux_decomp returns the singularity flag. Zero flag means
+* that the original matrix A is non-singular while non-zero flag means
+* that A is (exactly!) singular.
+*
+* Note that LU-factorization is valid in both cases, however, in case
+* of singularity some rows of the matrix V (including pivot elements)
+* will be empty.
+*
+* REPAIRING SINGULAR MATRIX
+*
+* If the routine lux_decomp returns non-zero flag, it provides all
+* necessary information that can be used for "repairing" the matrix A,
+* where "repairing" means replacing linearly dependent columns of the
+* matrix A by appropriate columns of the unity matrix. This feature is
+* needed when the routine lux_decomp is used for reinverting the basis
+* matrix within the simplex method procedure.
+*
+* On exit linearly dependent columns of the matrix U have the numbers
+* rank+1, rank+2, ..., n, where rank is the exact rank of the matrix A
+* stored by the routine to the member lux->rank. The correspondence
+* between columns of A and U is the same as between columns of V and U.
+* Thus, linearly dependent columns of the matrix A have the numbers
+* Q_col[rank+1], Q_col[rank+2], ..., Q_col[n], where Q_col is an array
+* representing the permutation matrix Q in column-like format. It is
+* understood that each j-th linearly dependent column of the matrix U
+* should be replaced by the unity vector, where all elements are zero
+* except the unity diagonal element u[j,j]. On the other hand j-th row
+* of the matrix U corresponds to the row of the matrix V (and therefore
+* of the matrix A) with the number P_row[j], where P_row is an array
+* representing the permutation matrix P in row-like format. Thus, each
+* j-th linearly dependent column of the matrix U should be replaced by
+* a column of the unity matrix with the number P_row[j].
+*
+* The code that repairs the matrix A may look like follows:
+*
+* for (j = rank+1; j <= n; j++)
+* { replace column Q_col[j] of the matrix A by column P_row[j] of
+* the unity matrix;
+* }
+*
+* where rank, P_row, and Q_col are members of the structure LUX. */
+
+int lux_decomp(LUX *lux, int (*col)(void *info, int j, int ind[],
+ mpq_t val[]), void *info)
+{ int n = lux->n;
+ LUXELM **V_row = lux->V_row;
+ LUXELM **V_col = lux->V_col;
+ int *P_row = lux->P_row;
+ int *P_col = lux->P_col;
+ int *Q_row = lux->Q_row;
+ int *Q_col = lux->Q_col;
+ LUXELM *piv, *vij;
+ LUXWKA *wka;
+ int i, j, k, p, q, t, *flag;
+ mpq_t *work;
+ /* allocate working area */
+ wka = xmalloc(sizeof(LUXWKA));
+ wka->R_len = xcalloc(1+n, sizeof(int));
+ wka->R_head = xcalloc(1+n, sizeof(int));
+ wka->R_prev = xcalloc(1+n, sizeof(int));
+ wka->R_next = xcalloc(1+n, sizeof(int));
+ wka->C_len = xcalloc(1+n, sizeof(int));
+ wka->C_head = xcalloc(1+n, sizeof(int));
+ wka->C_prev = xcalloc(1+n, sizeof(int));
+ wka->C_next = xcalloc(1+n, sizeof(int));
+ /* initialize LU-factorization data structures */
+ initialize(lux, col, info, wka);
+ /* allocate working arrays */
+ flag = xcalloc(1+n, sizeof(int));
+ work = xcalloc(1+n, sizeof(mpq_t));
+ for (k = 1; k <= n; k++)
+ { flag[k] = 0;
+ mpq_init(work[k]);
+ }
+ /* main elimination loop */
+ for (k = 1; k <= n; k++)
+ { /* choose a pivot element v[p,q] */
+ piv = find_pivot(lux, wka);
+ if (piv == NULL)
+ { /* no pivot can be chosen, because the active submatrix is
+ empty */
+ break;
+ }
+ /* determine row and column indices of the pivot element */
+ p = piv->i, q = piv->j;
+ /* let v[p,q] correspond to u[i',j']; permute k-th and i'-th
+ rows and k-th and j'-th columns of the matrix U = P*V*Q to
+ move the element u[i',j'] to the position u[k,k] */
+ i = P_col[p], j = Q_row[q];
+ xassert(k <= i && i <= n && k <= j && j <= n);
+ /* permute k-th and i-th rows of the matrix U */
+ t = P_row[k];
+ P_row[i] = t, P_col[t] = i;
+ P_row[k] = p, P_col[p] = k;
+ /* permute k-th and j-th columns of the matrix U */
+ t = Q_col[k];
+ Q_col[j] = t, Q_row[t] = j;
+ Q_col[k] = q, Q_row[q] = k;
+ /* eliminate subdiagonal elements of k-th column of the matrix
+ U = P*V*Q using the pivot element u[k,k] = v[p,q] */
+ eliminate(lux, wka, piv, flag, work);
+ }
+ /* determine the rank of A (and V) */
+ lux->rank = k - 1;
+ /* free working arrays */
+ xfree(flag);
+ for (k = 1; k <= n; k++) mpq_clear(work[k]);
+ xfree(work);
+ /* build column lists of the matrix V using its row lists */
+ for (j = 1; j <= n; j++)
+ xassert(V_col[j] == NULL);
+ for (i = 1; i <= n; i++)
+ { for (vij = V_row[i]; vij != NULL; vij = vij->r_next)
+ { j = vij->j;
+ vij->c_prev = NULL;
+ vij->c_next = V_col[j];
+ if (vij->c_next != NULL) vij->c_next->c_prev = vij;
+ V_col[j] = vij;
+ }
+ }
+ /* free working area */
+ xfree(wka->R_len);
+ xfree(wka->R_head);
+ xfree(wka->R_prev);
+ xfree(wka->R_next);
+ xfree(wka->C_len);
+ xfree(wka->C_head);
+ xfree(wka->C_prev);
+ xfree(wka->C_next);
+ xfree(wka);
+ /* return to the calling program */
+ return (lux->rank < n);
+}
+
+/***********************************************************************
+* lux_f_solve - solve system F*x = b or F'*x = b
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* void lux_f_solve(LUX *lux, int tr, mpq_t x[]);
+*
+* DESCRIPTION
+*
+* The routine lux_f_solve solves either the system F*x = b (if the
+* flag tr is zero) or the system F'*x = b (if the flag tr is non-zero),
+* where the matrix F is a component of LU-factorization specified by
+* the parameter lux, F' is a matrix transposed to F.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix F. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void lux_f_solve(LUX *lux, int tr, mpq_t x[])
+{ int n = lux->n;
+ LUXELM **F_row = lux->F_row;
+ LUXELM **F_col = lux->F_col;
+ int *P_row = lux->P_row;
+ LUXELM *fik, *fkj;
+ int i, j, k;
+ mpq_t temp;
+ mpq_init(temp);
+ if (!tr)
+ { /* solve the system F*x = b */
+ for (j = 1; j <= n; j++)
+ { k = P_row[j];
+ if (mpq_sgn(x[k]) != 0)
+ { for (fik = F_col[k]; fik != NULL; fik = fik->c_next)
+ { mpq_mul(temp, fik->val, x[k]);
+ mpq_sub(x[fik->i], x[fik->i], temp);
+ }
+ }
+ }
+ }
+ else
+ { /* solve the system F'*x = b */
+ for (i = n; i >= 1; i--)
+ { k = P_row[i];
+ if (mpq_sgn(x[k]) != 0)
+ { for (fkj = F_row[k]; fkj != NULL; fkj = fkj->r_next)
+ { mpq_mul(temp, fkj->val, x[k]);
+ mpq_sub(x[fkj->j], x[fkj->j], temp);
+ }
+ }
+ }
+ }
+ mpq_clear(temp);
+ return;
+}
+
+/***********************************************************************
+* lux_v_solve - solve system V*x = b or V'*x = b
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* void lux_v_solve(LUX *lux, int tr, double x[]);
+*
+* DESCRIPTION
+*
+* The routine lux_v_solve solves either the system V*x = b (if the
+* flag tr is zero) or the system V'*x = b (if the flag tr is non-zero),
+* where the matrix V is a component of LU-factorization specified by
+* the parameter lux, V' is a matrix transposed to V.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix V. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void lux_v_solve(LUX *lux, int tr, mpq_t x[])
+{ int n = lux->n;
+ mpq_t *V_piv = lux->V_piv;
+ LUXELM **V_row = lux->V_row;
+ LUXELM **V_col = lux->V_col;
+ int *P_row = lux->P_row;
+ int *Q_col = lux->Q_col;
+ LUXELM *vij;
+ int i, j, k;
+ mpq_t *b, temp;
+ b = xcalloc(1+n, sizeof(mpq_t));
+ for (k = 1; k <= n; k++)
+ mpq_init(b[k]), mpq_set(b[k], x[k]), mpq_set_si(x[k], 0, 1);
+ mpq_init(temp);
+ if (!tr)
+ { /* solve the system V*x = b */
+ for (k = n; k >= 1; k--)
+ { i = P_row[k], j = Q_col[k];
+ if (mpq_sgn(b[i]) != 0)
+ { mpq_set(x[j], b[i]);
+ mpq_div(x[j], x[j], V_piv[i]);
+ for (vij = V_col[j]; vij != NULL; vij = vij->c_next)
+ { mpq_mul(temp, vij->val, x[j]);
+ mpq_sub(b[vij->i], b[vij->i], temp);
+ }
+ }
+ }
+ }
+ else
+ { /* solve the system V'*x = b */
+ for (k = 1; k <= n; k++)
+ { i = P_row[k], j = Q_col[k];
+ if (mpq_sgn(b[j]) != 0)
+ { mpq_set(x[i], b[j]);
+ mpq_div(x[i], x[i], V_piv[i]);
+ for (vij = V_row[i]; vij != NULL; vij = vij->r_next)
+ { mpq_mul(temp, vij->val, x[i]);
+ mpq_sub(b[vij->j], b[vij->j], temp);
+ }
+ }
+ }
+ }
+ for (k = 1; k <= n; k++) mpq_clear(b[k]);
+ mpq_clear(temp);
+ xfree(b);
+ return;
+}
+
+/***********************************************************************
+* lux_solve - solve system A*x = b or A'*x = b
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* void lux_solve(LUX *lux, int tr, mpq_t x[]);
+*
+* DESCRIPTION
+*
+* The routine lux_solve solves either the system A*x = b (if the flag
+* tr is zero) or the system A'*x = b (if the flag tr is non-zero),
+* where the parameter lux specifies LU-factorization of the matrix A,
+* A' is a matrix transposed to A.
+*
+* On entry the array x should contain elements of the right-hand side
+* vector b in locations x[1], ..., x[n], where n is the order of the
+* matrix A. On exit this array will contain elements of the solution
+* vector x in the same locations. */
+
+void lux_solve(LUX *lux, int tr, mpq_t x[])
+{ if (lux->rank < lux->n)
+ xfault("lux_solve: LU-factorization has incomplete rank\n");
+ if (!tr)
+ { /* A = F*V, therefore inv(A) = inv(V)*inv(F) */
+ lux_f_solve(lux, 0, x);
+ lux_v_solve(lux, 0, x);
+ }
+ else
+ { /* A' = V'*F', therefore inv(A') = inv(F')*inv(V') */
+ lux_v_solve(lux, 1, x);
+ lux_f_solve(lux, 1, x);
+ }
+ return;
+}
+
+/***********************************************************************
+* lux_delete - delete LU-factorization
+*
+* SYNOPSIS
+*
+* #include "lux.h"
+* void lux_delete(LUX *lux);
+*
+* DESCRIPTION
+*
+* The routine lux_delete deletes LU-factorization data structure,
+* which the parameter lux points to, freeing all the memory allocated
+* to this object. */
+
+void lux_delete(LUX *lux)
+{ int n = lux->n;
+ LUXELM *fij, *vij;
+ int i;
+ for (i = 1; i <= n; i++)
+ { for (fij = lux->F_row[i]; fij != NULL; fij = fij->r_next)
+ mpq_clear(fij->val);
+ mpq_clear(lux->V_piv[i]);
+ for (vij = lux->V_row[i]; vij != NULL; vij = vij->r_next)
+ mpq_clear(vij->val);
+ }
+ dmp_delete_pool(lux->pool);
+ xfree(lux->F_row);
+ xfree(lux->F_col);
+ xfree(lux->V_piv);
+ xfree(lux->V_row);
+ xfree(lux->V_col);
+ xfree(lux->P_row);
+ xfree(lux->P_col);
+ xfree(lux->Q_row);
+ xfree(lux->Q_col);
+ xfree(lux);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/draft/lux.h b/test/monniaux/glpk-4.65/src/draft/lux.h
new file mode 100644
index 00000000..8767bb8e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/draft/lux.h
@@ -0,0 +1,220 @@
+/* lux.h (LU-factorization, rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+* 2009, 2010, 2011, 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef LUX_H
+#define LUX_H
+
+#include "dmp.h"
+#include "mygmp.h"
+
+/***********************************************************************
+* The structure LUX defines LU-factorization of a square matrix A,
+* which is the following quartet:
+*
+* [A] = (F, V, P, Q), (1)
+*
+* where F and V are such matrices that
+*
+* A = F * V, (2)
+*
+* and P and Q are such permutation matrices that the matrix
+*
+* L = P * F * inv(P) (3)
+*
+* is lower triangular with unity diagonal, and the matrix
+*
+* U = P * V * Q (4)
+*
+* is upper triangular. All the matrices have the order n.
+*
+* The matrices F and V are stored in row/column-wise sparse format as
+* row and column linked lists of non-zero elements. Unity elements on
+* the main diagonal of the matrix F are not stored. Pivot elements of
+* the matrix V (that correspond to diagonal elements of the matrix U)
+* are also missing from the row and column lists and stored separately
+* in an ordinary array.
+*
+* The permutation matrices P and Q are stored as ordinary arrays using
+* both row- and column-like formats.
+*
+* The matrices L and U being completely defined by the matrices F, V,
+* P, and Q are not stored explicitly.
+*
+* It is easy to show that the factorization (1)-(3) is some version of
+* LU-factorization. Indeed, from (3) and (4) it follows that:
+*
+* F = inv(P) * L * P,
+*
+* V = inv(P) * U * inv(Q),
+*
+* and substitution into (2) gives:
+*
+* A = F * V = inv(P) * L * U * inv(Q).
+*
+* For more details see the program documentation. */
+
+typedef struct LUX LUX;
+typedef struct LUXELM LUXELM;
+typedef struct LUXWKA LUXWKA;
+
+struct LUX
+{ /* LU-factorization of a square matrix */
+ int n;
+ /* the order of matrices A, F, V, P, Q */
+ DMP *pool;
+ /* memory pool for elements of matrices F and V */
+ LUXELM **F_row; /* LUXELM *F_row[1+n]; */
+ /* F_row[0] is not used;
+ F_row[i], 1 <= i <= n, is a pointer to the list of elements in
+ i-th row of matrix F (diagonal elements are not stored) */
+ LUXELM **F_col; /* LUXELM *F_col[1+n]; */
+ /* F_col[0] is not used;
+ F_col[j], 1 <= j <= n, is a pointer to the list of elements in
+ j-th column of matrix F (diagonal elements are not stored) */
+ mpq_t *V_piv; /* mpq_t V_piv[1+n]; */
+ /* V_piv[0] is not used;
+ V_piv[p], 1 <= p <= n, is a pivot element v[p,q] corresponding
+ to a diagonal element u[k,k] of matrix U = P*V*Q (used on k-th
+ elimination step, k = 1, 2, ..., n) */
+ LUXELM **V_row; /* LUXELM *V_row[1+n]; */
+ /* V_row[0] is not used;
+ V_row[i], 1 <= i <= n, is a pointer to the list of elements in
+ i-th row of matrix V (except pivot elements) */
+ LUXELM **V_col; /* LUXELM *V_col[1+n]; */
+ /* V_col[0] is not used;
+ V_col[j], 1 <= j <= n, is a pointer to the list of elements in
+ j-th column of matrix V (except pivot elements) */
+ int *P_row; /* int P_row[1+n]; */
+ /* P_row[0] is not used;
+ P_row[i] = j means that p[i,j] = 1, where p[i,j] is an element
+ of permutation matrix P */
+ int *P_col; /* int P_col[1+n]; */
+ /* P_col[0] is not used;
+ P_col[j] = i means that p[i,j] = 1, where p[i,j] is an element
+ of permutation matrix P */
+ /* if i-th row or column of matrix F is i'-th row or column of
+ matrix L = P*F*inv(P), or if i-th row of matrix V is i'-th row
+ of matrix U = P*V*Q, then P_row[i'] = i and P_col[i] = i' */
+ int *Q_row; /* int Q_row[1+n]; */
+ /* Q_row[0] is not used;
+ Q_row[i] = j means that q[i,j] = 1, where q[i,j] is an element
+ of permutation matrix Q */
+ int *Q_col; /* int Q_col[1+n]; */
+ /* Q_col[0] is not used;
+ Q_col[j] = i means that q[i,j] = 1, where q[i,j] is an element
+ of permutation matrix Q */
+ /* if j-th column of matrix V is j'-th column of matrix U = P*V*Q,
+ then Q_row[j] = j' and Q_col[j'] = j */
+ int rank;
+ /* the (exact) rank of matrices A and V */
+};
+
+struct LUXELM
+{ /* element of matrix F or V */
+ int i;
+ /* row index, 1 <= i <= m */
+ int j;
+ /* column index, 1 <= j <= n */
+ mpq_t val;
+ /* numeric (non-zero) element value */
+ LUXELM *r_prev;
+ /* pointer to previous element in the same row */
+ LUXELM *r_next;
+ /* pointer to next element in the same row */
+ LUXELM *c_prev;
+ /* pointer to previous element in the same column */
+ LUXELM *c_next;
+ /* pointer to next element in the same column */
+};
+
+struct LUXWKA
+{ /* working area (used only during factorization) */
+ /* in order to efficiently implement Markowitz strategy and Duff
+ search technique there are two families {R[0], R[1], ..., R[n]}
+ and {C[0], C[1], ..., C[n]}; member R[k] is a set of active
+ rows of matrix V having k non-zeros, and member C[k] is a set
+ of active columns of matrix V having k non-zeros (in the active
+ submatrix); each set R[k] and C[k] is implemented as a separate
+ doubly linked list */
+ int *R_len; /* int R_len[1+n]; */
+ /* R_len[0] is not used;
+ R_len[i], 1 <= i <= n, is the number of non-zero elements in
+ i-th row of matrix V (that is the length of i-th row) */
+ int *R_head; /* int R_head[1+n]; */
+ /* R_head[k], 0 <= k <= n, is the number of a first row, which is
+ active and whose length is k */
+ int *R_prev; /* int R_prev[1+n]; */
+ /* R_prev[0] is not used;
+ R_prev[i], 1 <= i <= n, is the number of a previous row, which
+ is active and has the same length as i-th row */
+ int *R_next; /* int R_next[1+n]; */
+ /* R_prev[0] is not used;
+ R_prev[i], 1 <= i <= n, is the number of a next row, which is
+ active and has the same length as i-th row */
+ int *C_len; /* int C_len[1+n]; */
+ /* C_len[0] is not used;
+ C_len[j], 1 <= j <= n, is the number of non-zero elements in
+ j-th column of the active submatrix of matrix V (that is the
+ length of j-th column in the active submatrix) */
+ int *C_head; /* int C_head[1+n]; */
+ /* C_head[k], 0 <= k <= n, is the number of a first column, which
+ is active and whose length is k */
+ int *C_prev; /* int C_prev[1+n]; */
+ /* C_prev[0] is not used;
+ C_prev[j], 1 <= j <= n, is the number of a previous column,
+ which is active and has the same length as j-th column */
+ int *C_next; /* int C_next[1+n]; */
+ /* C_next[0] is not used;
+ C_next[j], 1 <= j <= n, is the number of a next column, which
+ is active and has the same length as j-th column */
+};
+
+#define lux_create _glp_lux_create
+LUX *lux_create(int n);
+/* create LU-factorization */
+
+#define lux_decomp _glp_lux_decomp
+int lux_decomp(LUX *lux, int (*col)(void *info, int j, int ind[],
+ mpq_t val[]), void *info);
+/* compute LU-factorization */
+
+#define lux_f_solve _glp_lux_f_solve
+void lux_f_solve(LUX *lux, int tr, mpq_t x[]);
+/* solve system F*x = b or F'*x = b */
+
+#define lux_v_solve _glp_lux_v_solve
+void lux_v_solve(LUX *lux, int tr, mpq_t x[]);
+/* solve system V*x = b or V'*x = b */
+
+#define lux_solve _glp_lux_solve
+void lux_solve(LUX *lux, int tr, mpq_t x[]);
+/* solve system A*x = b or A'*x = b */
+
+#define lux_delete _glp_lux_delete
+void lux_delete(LUX *lux);
+/* delete LU-factorization */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/alloc.c b/test/monniaux/glpk-4.65/src/env/alloc.c
new file mode 100644
index 00000000..8e2d613d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/alloc.c
@@ -0,0 +1,252 @@
+/* alloc.c (dynamic memory allocation) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+
+#define ALIGN 16
+/* some processors need data to be properly aligned, so this macro
+ * defines the alignment boundary, in bytes, provided by glpk memory
+ * allocation routines; looks like 16-byte alignment boundary is
+ * sufficient for all 32- and 64-bit platforms (8-byte boundary is not
+ * sufficient for some 64-bit platforms because of jmp_buf) */
+
+#define MBD_SIZE (((sizeof(MBD) + (ALIGN - 1)) / ALIGN) * ALIGN)
+/* size of memory block descriptor, in bytes, rounded up to multiple
+ * of the alignment boundary */
+
+/***********************************************************************
+* dma - dynamic memory allocation (basic routine)
+*
+* This routine performs dynamic memory allocation. It is similar to
+* the standard realloc function, however, it provides every allocated
+* memory block with a descriptor, which is used for sanity checks on
+* reallocating/freeing previously allocated memory blocks as well as
+* for book-keeping the memory usage statistics. */
+
+static void *dma(const char *func, void *ptr, size_t size)
+{ ENV *env = get_env_ptr();
+ MBD *mbd;
+ if (ptr == NULL)
+ { /* new memory block will be allocated */
+ mbd = NULL;
+ }
+ else
+ { /* allocated memory block will be reallocated or freed */
+ /* get pointer to the block descriptor */
+ mbd = (MBD *)((char *)ptr - MBD_SIZE);
+ /* make sure that the block descriptor is valid */
+ if (mbd->self != mbd)
+ xerror("%s: ptr = %p; invalid pointer\n", func, ptr);
+ /* remove the block from the linked list */
+ mbd->self = NULL;
+ if (mbd->prev == NULL)
+ env->mem_ptr = mbd->next;
+ else
+ mbd->prev->next = mbd->next;
+ if (mbd->next == NULL)
+ ;
+ else
+ mbd->next->prev = mbd->prev;
+ /* decrease usage counts */
+ if (!(env->mem_count >= 1 && env->mem_total >= mbd->size))
+ xerror("%s: memory allocation error\n", func);
+ env->mem_count--;
+ env->mem_total -= mbd->size;
+ if (size == 0)
+ { /* free the memory block */
+ free(mbd);
+ return NULL;
+ }
+ }
+ /* allocate/reallocate memory block */
+ if (size > SIZE_T_MAX - MBD_SIZE)
+ xerror("%s: block too large\n", func);
+ size += MBD_SIZE;
+ if (size > env->mem_limit - env->mem_total)
+ xerror("%s: memory allocation limit exceeded\n", func);
+ if (env->mem_count == INT_MAX)
+ xerror("%s: too many memory blocks allocated\n", func);
+ mbd = (mbd == NULL ? malloc(size) : realloc(mbd, size));
+ if (mbd == NULL)
+ xerror("%s: no memory available\n", func);
+ /* setup the block descriptor */
+ mbd->size = size;
+ mbd->self = mbd;
+ mbd->prev = NULL;
+ mbd->next = env->mem_ptr;
+ /* add the block to the beginning of the linked list */
+ if (mbd->next != NULL)
+ mbd->next->prev = mbd;
+ env->mem_ptr = mbd;
+ /* increase usage counts */
+ env->mem_count++;
+ if (env->mem_cpeak < env->mem_count)
+ env->mem_cpeak = env->mem_count;
+ env->mem_total += size;
+ if (env->mem_tpeak < env->mem_total)
+ env->mem_tpeak = env->mem_total;
+ return (char *)mbd + MBD_SIZE;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_alloc - allocate memory block
+*
+* SYNOPSIS
+*
+* void *glp_alloc(int n, int size);
+*
+* DESCRIPTION
+*
+* The routine glp_alloc allocates a memory block of n * size bytes
+* long.
+*
+* Note that being allocated the memory block contains arbitrary data
+* (not binary zeros!).
+*
+* RETURNS
+*
+* The routine glp_alloc returns a pointer to the block allocated.
+* To free this block the routine glp_free (not free!) must be used. */
+
+void *glp_alloc(int n, int size)
+{ if (n < 1)
+ xerror("glp_alloc: n = %d; invalid parameter\n", n);
+ if (size < 1)
+ xerror("glp_alloc: size = %d; invalid parameter\n", size);
+ if ((size_t)n > SIZE_T_MAX / (size_t)size)
+ xerror("glp_alloc: n = %d, size = %d; block too large\n",
+ n, size);
+ return dma("glp_alloc", NULL, (size_t)n * (size_t)size);
+}
+
+/**********************************************************************/
+
+void *glp_realloc(void *ptr, int n, int size)
+{ /* reallocate memory block */
+ if (ptr == NULL)
+ xerror("glp_realloc: ptr = %p; invalid pointer\n", ptr);
+ if (n < 1)
+ xerror("glp_realloc: n = %d; invalid parameter\n", n);
+ if (size < 1)
+ xerror("glp_realloc: size = %d; invalid parameter\n", size);
+ if ((size_t)n > SIZE_T_MAX / (size_t)size)
+ xerror("glp_realloc: n = %d, size = %d; block too large\n",
+ n, size);
+ return dma("glp_realloc", ptr, (size_t)n * (size_t)size);
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_free - free (deallocate) memory block
+*
+* SYNOPSIS
+*
+* void glp_free(void *ptr);
+*
+* DESCRIPTION
+*
+* The routine glp_free frees (deallocates) a memory block pointed to
+* by ptr, which was previuosly allocated by the routine glp_alloc or
+* reallocated by the routine glp_realloc. */
+
+void glp_free(void *ptr)
+{ if (ptr == NULL)
+ xerror("glp_free: ptr = %p; invalid pointer\n", ptr);
+ dma("glp_free", ptr, 0);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mem_limit - set memory usage limit
+*
+* SYNOPSIS
+*
+* void glp_mem_limit(int limit);
+*
+* DESCRIPTION
+*
+* The routine glp_mem_limit limits the amount of memory available for
+* dynamic allocation (in GLPK routines) to limit megabytes. */
+
+void glp_mem_limit(int limit)
+{ ENV *env = get_env_ptr();
+ if (limit < 1)
+ xerror("glp_mem_limit: limit = %d; invalid parameter\n",
+ limit);
+ if ((size_t)limit <= (SIZE_T_MAX >> 20))
+ env->mem_limit = (size_t)limit << 20;
+ else
+ env->mem_limit = SIZE_T_MAX;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mem_usage - get memory usage information
+*
+* SYNOPSIS
+*
+* void glp_mem_usage(int *count, int *cpeak, size_t *total,
+* size_t *tpeak);
+*
+* DESCRIPTION
+*
+* The routine glp_mem_usage reports some information about utilization
+* of the memory by GLPK routines. Information is stored to locations
+* specified by corresponding parameters (see below). Any parameter can
+* be specified as NULL, in which case its value is not stored.
+*
+* *count is the number of the memory blocks currently allocated by the
+* routines glp_malloc and glp_calloc (one call to glp_malloc or
+* glp_calloc results in allocating one memory block).
+*
+* *cpeak is the peak value of *count reached since the initialization
+* of the GLPK library environment.
+*
+* *total is the total amount, in bytes, of the memory blocks currently
+* allocated by the routines glp_malloc and glp_calloc.
+*
+* *tpeak is the peak value of *total reached since the initialization
+* of the GLPK library envirionment. */
+
+void glp_mem_usage(int *count, int *cpeak, size_t *total,
+ size_t *tpeak)
+{ ENV *env = get_env_ptr();
+ if (count != NULL)
+ *count = env->mem_count;
+ if (cpeak != NULL)
+ *cpeak = env->mem_cpeak;
+ if (total != NULL)
+ *total = env->mem_total;
+ if (tpeak != NULL)
+ *tpeak = env->mem_tpeak;
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/dlsup.c b/test/monniaux/glpk-4.65/src/env/dlsup.c
new file mode 100644
index 00000000..54c56c6d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/dlsup.c
@@ -0,0 +1,167 @@
+/* dlsup.c (dynamic linking support) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "env.h"
+
+/* GNU version ********************************************************/
+
+#if defined(HAVE_LTDL)
+
+#include <ltdl.h>
+
+void *xdlopen(const char *module)
+{ /* open dynamically linked library */
+ void *h = NULL;
+ if (lt_dlinit() != 0)
+ { put_err_msg(lt_dlerror());
+ goto done;
+ }
+ h = lt_dlopen(module);
+ if (h == NULL)
+ { put_err_msg(lt_dlerror());
+ if (lt_dlexit() != 0)
+ xerror("xdlopen: %s\n", lt_dlerror());
+ }
+done: return h;
+}
+
+void *xdlsym(void *h, const char *symbol)
+{ /* obtain address of symbol from dynamically linked library */
+ void *ptr;
+ xassert(h != NULL);
+ ptr = lt_dlsym(h, symbol);
+ if (ptr == NULL)
+ xerror("xdlsym: %s: %s\n", symbol, lt_dlerror());
+ return ptr;
+}
+
+void xdlclose(void *h)
+{ /* close dynamically linked library */
+ xassert(h != NULL);
+ if (lt_dlclose(h) != 0)
+ xerror("xdlclose: %s\n", lt_dlerror());
+ if (lt_dlexit() != 0)
+ xerror("xdlclose: %s\n", lt_dlerror());
+ return;
+}
+
+/* POSIX version ******************************************************/
+
+#elif defined(HAVE_DLFCN)
+
+#include <dlfcn.h>
+
+void *xdlopen(const char *module)
+{ /* open dynamically linked library */
+ void *h;
+ h = dlopen(module, RTLD_NOW);
+ if (h == NULL)
+ put_err_msg(dlerror());
+ return h;
+}
+
+void *xdlsym(void *h, const char *symbol)
+{ /* obtain address of symbol from dynamically linked library */
+ void *ptr;
+ xassert(h != NULL);
+ ptr = dlsym(h, symbol);
+ if (ptr == NULL)
+ xerror("xdlsym: %s: %s\n", symbol, dlerror());
+ return ptr;
+}
+
+void xdlclose(void *h)
+{ /* close dynamically linked library */
+ xassert(h != NULL);
+ if (dlclose(h) != 0)
+ xerror("xdlclose: %s\n", dlerror());
+ return;
+}
+
+/* MS Windows version *************************************************/
+
+#elif defined(__WOE__)
+
+#include <windows.h>
+
+void *xdlopen(const char *module)
+{ /* open dynamically linked library */
+ void *h;
+ h = LoadLibrary(module);
+ if (h == NULL)
+ { char msg[20];
+ sprintf(msg, "Error %d", GetLastError());
+ put_err_msg(msg);
+ }
+ return h;
+}
+
+void *xdlsym(void *h, const char *symbol)
+{ /* obtain address of symbol from dynamically linked library */
+ void *ptr;
+ xassert(h != NULL);
+ ptr = GetProcAddress(h, symbol);
+ if (ptr == NULL)
+ xerror("xdlsym: %s: Error %d\n", symbol, GetLastError());
+ return ptr;
+}
+
+void xdlclose(void *h)
+{ /* close dynamically linked library */
+ xassert(h != NULL);
+ if (!FreeLibrary(h))
+ xerror("xdlclose: Error %d\n", GetLastError());
+ return;
+}
+
+/* NULL version *******************************************************/
+
+#else
+
+void *xdlopen(const char *module)
+{ /* open dynamically linked library */
+ xassert(module == module);
+ put_err_msg("Shared libraries not supported");
+ return NULL;
+}
+
+void *xdlsym(void *h, const char *symbol)
+{ /* obtain address of symbol from dynamically linked library */
+ xassert(h != h);
+ xassert(symbol != symbol);
+ return NULL;
+}
+
+void xdlclose(void *h)
+{ /* close dynamically linked library */
+ xassert(h != h);
+ return;
+}
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/env.c b/test/monniaux/glpk-4.65/src/env/env.c
new file mode 100644
index 00000000..5b901f35
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/env.c
@@ -0,0 +1,316 @@
+/* env.c (GLPK environment initialization/termination) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "glpk.h"
+#include "env.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_init_env - initialize GLPK environment
+*
+* SYNOPSIS
+*
+* int glp_init_env(void);
+*
+* DESCRIPTION
+*
+* The routine glp_init_env initializes the GLPK environment. Normally
+* the application program does not need to call this routine, because
+* it is called automatically on the first call to any API routine.
+*
+* RETURNS
+*
+* The routine glp_init_env returns one of the following codes:
+*
+* 0 - initialization successful;
+* 1 - environment has been already initialized;
+* 2 - initialization failed (insufficient memory);
+* 3 - initialization failed (unsupported programming model). */
+
+int glp_init_env(void)
+{ ENV *env;
+ int ok;
+ /* check if the programming model is supported */
+ ok = (CHAR_BIT == 8 && sizeof(char) == 1 &&
+ sizeof(short) == 2 && sizeof(int) == 4 &&
+ (sizeof(void *) == 4 || sizeof(void *) == 8));
+ if (!ok)
+ return 3;
+ /* check if the environment is already initialized */
+ if (tls_get_ptr() != NULL)
+ return 1;
+ /* allocate and initialize the environment block */
+ env = malloc(sizeof(ENV));
+ if (env == NULL)
+ return 2;
+ memset(env, 0, sizeof(ENV));
+#if 0 /* 14/I-2017 */
+ sprintf(env->version, "%d.%d",
+ GLP_MAJOR_VERSION, GLP_MINOR_VERSION);
+#endif
+ env->self = env;
+ env->term_buf = malloc(TBUF_SIZE);
+ if (env->term_buf == NULL)
+ { free(env);
+ return 2;
+ }
+ env->term_out = GLP_ON;
+ env->term_hook = NULL;
+ env->term_info = NULL;
+ env->tee_file = NULL;
+#if 1 /* 23/XI-2015 */
+ env->err_st = 0;
+#endif
+ env->err_file = NULL;
+ env->err_line = 0;
+ env->err_hook = NULL;
+ env->err_info = NULL;
+ env->err_buf = malloc(EBUF_SIZE);
+ if (env->err_buf == NULL)
+ { free(env->term_buf);
+ free(env);
+ return 2;
+ }
+ env->err_buf[0] = '\0';
+ env->mem_limit = SIZE_T_MAX;
+ env->mem_ptr = NULL;
+ env->mem_count = env->mem_cpeak = 0;
+ env->mem_total = env->mem_tpeak = 0;
+#if 1 /* 23/XI-2015 */
+ env->gmp_pool = NULL;
+ env->gmp_size = 0;
+ env->gmp_work = NULL;
+#endif
+ env->h_odbc = env->h_mysql = NULL;
+ /* save pointer to the environment block */
+ tls_set_ptr(env);
+ /* initialization successful */
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* get_env_ptr - retrieve pointer to environment block
+*
+* SYNOPSIS
+*
+* #include "env.h"
+* ENV *get_env_ptr(void);
+*
+* DESCRIPTION
+*
+* The routine get_env_ptr retrieves and returns a pointer to the GLPK
+* environment block.
+*
+* If the GLPK environment has not been initialized yet, the routine
+* performs initialization. If initialization fails, the routine prints
+* an error message to stderr and terminates the program.
+*
+* RETURNS
+*
+* The routine returns a pointer to the environment block. */
+
+ENV *get_env_ptr(void)
+{ ENV *env = tls_get_ptr();
+ /* check if the environment has been initialized */
+ if (env == NULL)
+ { /* not initialized yet; perform initialization */
+ if (glp_init_env() != 0)
+ { /* initialization failed; display an error message */
+ fprintf(stderr, "GLPK initialization failed\n");
+ fflush(stderr);
+ /* and abnormally terminate the program */
+ abort();
+ }
+ /* initialization successful; retrieve the pointer */
+ env = tls_get_ptr();
+ }
+ /* check if the environment block is valid */
+ if (env->self != env)
+ { fprintf(stderr, "Invalid GLPK environment\n");
+ fflush(stderr);
+ abort();
+ }
+ return env;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_version - determine library version
+*
+* SYNOPSIS
+*
+* const char *glp_version(void);
+*
+* RETURNS
+*
+* The routine glp_version returns a pointer to a null-terminated
+* character string, which specifies the version of the GLPK library in
+* the form "X.Y", where X is the major version number, and Y is the
+* minor version number, for example, "4.16". */
+
+#define str(s) # s
+#define xstr(s) str(s)
+
+const char *glp_version(void)
+#if 0 /* 14/I-2017 */
+{ ENV *env = get_env_ptr();
+ return env->version;
+}
+#else /* suggested by Heinrich */
+{ return
+ xstr(GLP_MAJOR_VERSION) "." xstr(GLP_MINOR_VERSION);
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_config - determine library configuration
+*
+* SYNOPSIS
+*
+* const char *glp_config(const char *option);
+*
+* DESCRIPTION
+*
+* The routine glp_config determines some options which were specified
+* on configuring the GLPK library.
+*
+* RETURNS
+*
+* The routine glp_config returns a pointer to a null-terminating
+* string depending on the option inquired.
+*
+* For option = "TLS" the routine returns the thread local storage
+* class specifier used (e.g. "_Thread_local") if the GLPK library was
+* configured to run in multi-threaded environment, or NULL otherwise.
+*
+* For option = "ODBC_DLNAME" the routine returns the name of ODBC
+* shared library if this option was enabled, or NULL otherwise.
+*
+* For option = "MYSQL_DLNAME" the routine returns the name of MySQL
+* shared library if this option was enabled, or NULL otherwise. */
+
+const char *glp_config(const char *option)
+{ const char *s;
+ if (strcmp(option, "TLS") == 0)
+#ifndef TLS
+ s = NULL;
+#else
+ s = xstr(TLS);
+#endif
+ else if (strcmp(option, "ODBC_DLNAME") == 0)
+#ifndef ODBC_DLNAME
+ s = NULL;
+#else
+ s = ODBC_DLNAME;
+#endif
+ else if (strcmp(option, "MYSQL_DLNAME") == 0)
+#ifndef MYSQL_DLNAME
+ s = NULL;
+#else
+ s = MYSQL_DLNAME;
+#endif
+ else
+ { /* invalid option is always disabled */
+ s = NULL;
+ }
+ return s;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_free_env - free GLPK environment
+*
+* SYNOPSIS
+*
+* int glp_free_env(void);
+*
+* DESCRIPTION
+*
+* The routine glp_free_env frees all resources used by GLPK routines
+* (memory blocks, etc.) which are currently still in use.
+*
+* Normally the application program does not need to call this routine,
+* because GLPK routines always free all unused resources. However, if
+* the application program even has deleted all problem objects, there
+* will be several memory blocks still allocated for the library needs.
+* For some reasons the application program may want GLPK to free this
+* memory, in which case it should call glp_free_env.
+*
+* Note that a call to glp_free_env invalidates all problem objects as
+* if no GLPK routine were called.
+*
+* RETURNS
+*
+* 0 - termination successful;
+* 1 - environment is inactive (was not initialized). */
+
+int glp_free_env(void)
+{ ENV *env = tls_get_ptr();
+ MBD *desc;
+ /* check if the environment is active */
+ if (env == NULL)
+ return 1;
+ /* check if the environment block is valid */
+ if (env->self != env)
+ { fprintf(stderr, "Invalid GLPK environment\n");
+ fflush(stderr);
+ abort();
+ }
+ /* close handles to shared libraries */
+ if (env->h_odbc != NULL)
+ xdlclose(env->h_odbc);
+ if (env->h_mysql != NULL)
+ xdlclose(env->h_mysql);
+ /* free memory blocks which are still allocated */
+ while (env->mem_ptr != NULL)
+ { desc = env->mem_ptr;
+ env->mem_ptr = desc->next;
+ free(desc);
+ }
+ /* close text file used for copying terminal output */
+ if (env->tee_file != NULL)
+ fclose(env->tee_file);
+ /* invalidate the environment block */
+ env->self = NULL;
+ /* free memory allocated to the environment block */
+ free(env->term_buf);
+ free(env->err_buf);
+ free(env);
+ /* reset a pointer to the environment block */
+ tls_set_ptr(NULL);
+ /* termination successful */
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/env.h b/test/monniaux/glpk-4.65/src/env/env.h
new file mode 100644
index 00000000..67214ef6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/env.h
@@ -0,0 +1,274 @@
+/* env.h (GLPK environment) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef ENV_H
+#define ENV_H
+
+#include "stdc.h"
+
+typedef struct ENV ENV;
+typedef struct MBD MBD;
+
+#define SIZE_T_MAX (~(size_t)0)
+/* largest value of size_t type */
+
+#define TBUF_SIZE 4096
+/* terminal output buffer size, in bytes */
+
+#define EBUF_SIZE 1024
+/* error message buffer size, in bytes */
+
+/* enable/disable flag: */
+#define GLP_ON 1
+#define GLP_OFF 0
+
+struct ENV
+{ /* GLPK environment block */
+#if 0 /* 14/I-2007 */
+ char version[7+1];
+ /* version string returned by the routine glp_version */
+#endif
+ ENV *self;
+ /* pointer to this block to check its validity */
+ /*--------------------------------------------------------------*/
+ /* terminal output */
+ char *term_buf; /* char term_buf[TBUF_SIZE]; */
+ /* terminal output buffer */
+ int term_out;
+ /* flag to enable/disable terminal output */
+ int (*term_hook)(void *info, const char *s);
+ /* user-defined routine to intercept terminal output */
+ void *term_info;
+ /* transit pointer (cookie) passed to the routine term_hook */
+ FILE *tee_file;
+ /* output stream used to copy terminal output */
+ /*--------------------------------------------------------------*/
+ /* error handling */
+#if 1 /* 07/XI-2015 */
+ int err_st;
+ /* error state flag; set on entry to glp_error */
+#endif
+ const char *err_file;
+ /* value of the __FILE__ macro passed to glp_error */
+ int err_line;
+ /* value of the __LINE__ macro passed to glp_error */
+ void (*err_hook)(void *info);
+ /* user-defined routine to intercept abnormal termination */
+ void *err_info;
+ /* transit pointer (cookie) passed to the routine err_hook */
+ char *err_buf; /* char err_buf[EBUF_SIZE]; */
+ /* buffer to store error messages (used by I/O routines) */
+ /*--------------------------------------------------------------*/
+ /* dynamic memory allocation */
+ size_t mem_limit;
+ /* maximal amount of memory, in bytes, available for dynamic
+ * allocation */
+ MBD *mem_ptr;
+ /* pointer to the linked list of allocated memory blocks */
+ int mem_count;
+ /* total number of currently allocated memory blocks */
+ int mem_cpeak;
+ /* peak value of mem_count */
+ size_t mem_total;
+ /* total amount of currently allocated memory, in bytes; it is
+ * the sum of the size field over all memory block descriptors */
+ size_t mem_tpeak;
+ /* peak value of mem_total */
+#if 1 /* 23/XI-2015 */
+ /*--------------------------------------------------------------*/
+ /* bignum module working area */
+ void *gmp_pool; /* DMP *gmp_pool; */
+ /* working memory pool */
+ int gmp_size;
+ /* size of working array */
+ unsigned short *gmp_work; /* ushort gmp_work[gmp_size]; */
+ /* working array */
+#endif
+ /*--------------------------------------------------------------*/
+ /* dynamic linking support (optional) */
+ void *h_odbc;
+ /* handle to ODBC shared library */
+ void *h_mysql;
+ /* handle to MySQL shared library */
+};
+
+struct MBD
+{ /* memory block descriptor */
+ size_t size;
+ /* size of block, in bytes, including descriptor */
+ MBD *self;
+ /* pointer to this descriptor to check its validity */
+ MBD *prev;
+ /* pointer to previous memory block descriptor */
+ MBD *next;
+ /* pointer to next memory block descriptor */
+};
+
+#define get_env_ptr _glp_get_env_ptr
+ENV *get_env_ptr(void);
+/* retrieve pointer to environment block */
+
+#define tls_set_ptr _glp_tls_set_ptr
+void tls_set_ptr(void *ptr);
+/* store global pointer in TLS */
+
+#define tls_get_ptr _glp_tls_get_ptr
+void *tls_get_ptr(void);
+/* retrieve global pointer from TLS */
+
+#define xputs glp_puts
+void glp_puts(const char *s);
+/* write string on terminal */
+
+#define xprintf glp_printf
+void glp_printf(const char *fmt, ...);
+/* write formatted output on terminal */
+
+#define xvprintf glp_vprintf
+void glp_vprintf(const char *fmt, va_list arg);
+/* write formatted output on terminal */
+
+int glp_term_out(int flag);
+/* enable/disable terminal output */
+
+void glp_term_hook(int (*func)(void *info, const char *s), void *info);
+/* install hook to intercept terminal output */
+
+int glp_open_tee(const char *fname);
+/* start copying terminal output to text file */
+
+int glp_close_tee(void);
+/* stop copying terminal output to text file */
+
+#ifndef GLP_ERRFUNC_DEFINED
+#define GLP_ERRFUNC_DEFINED
+typedef void (*glp_errfunc)(const char *fmt, ...);
+#endif
+
+#define xerror glp_error_(__FILE__, __LINE__)
+glp_errfunc glp_error_(const char *file, int line);
+/* display fatal error message and terminate execution */
+
+#define xassert(expr) \
+ ((void)((expr) || (glp_assert_(#expr, __FILE__, __LINE__), 1)))
+void glp_assert_(const char *expr, const char *file, int line);
+/* check for logical condition */
+
+void glp_error_hook(void (*func)(void *info), void *info);
+/* install hook to intercept abnormal termination */
+
+#define put_err_msg _glp_put_err_msg
+void put_err_msg(const char *msg);
+/* provide error message string */
+
+#define get_err_msg _glp_get_err_msg
+const char *get_err_msg(void);
+/* obtain error message string */
+
+#define xmalloc(size) glp_alloc(1, size)
+/* allocate memory block (obsolete) */
+
+#define xcalloc(n, size) glp_alloc(n, size)
+/* allocate memory block (obsolete) */
+
+#define xalloc(n, size) glp_alloc(n, size)
+#define talloc(n, type) ((type *)glp_alloc(n, sizeof(type)))
+void *glp_alloc(int n, int size);
+/* allocate memory block */
+
+#define xrealloc(ptr, n, size) glp_realloc(ptr, n, size)
+#define trealloc(ptr, n, type) ((type *)glp_realloc(ptr, n, \
+ sizeof(type)))
+void *glp_realloc(void *ptr, int n, int size);
+/* reallocate memory block */
+
+#define xfree(ptr) glp_free(ptr)
+#define tfree(ptr) glp_free(ptr)
+void glp_free(void *ptr);
+/* free memory block */
+
+void glp_mem_limit(int limit);
+/* set memory usage limit */
+
+void glp_mem_usage(int *count, int *cpeak, size_t *total,
+ size_t *tpeak);
+/* get memory usage information */
+
+typedef struct glp_file glp_file;
+/* sequential stream descriptor */
+
+#define glp_open _glp_open
+glp_file *glp_open(const char *name, const char *mode);
+/* open stream */
+
+#define glp_eof _glp_eof
+int glp_eof(glp_file *f);
+/* test end-of-file indicator */
+
+#define glp_ioerr _glp_ioerr
+int glp_ioerr(glp_file *f);
+/* test I/O error indicator */
+
+#define glp_read _glp_read
+int glp_read(glp_file *f, void *buf, int nnn);
+/* read data from stream */
+
+#define glp_getc _glp_getc
+int glp_getc(glp_file *f);
+/* read character from stream */
+
+#define glp_write _glp_write
+int glp_write(glp_file *f, const void *buf, int nnn);
+/* write data to stream */
+
+#define glp_format _glp_format
+int glp_format(glp_file *f, const char *fmt, ...);
+/* write formatted data to stream */
+
+#define glp_close _glp_close
+int glp_close(glp_file *f);
+/* close stream */
+
+#define xtime glp_time
+double glp_time(void);
+/* determine current universal time */
+
+#define xdifftime glp_difftime
+double glp_difftime(double t1, double t0);
+/* compute difference between two time values */
+
+#define xdlopen _glp_dlopen
+void *xdlopen(const char *module);
+/* open dynamically linked library */
+
+#define xdlsym _glp_dlsym
+void *xdlsym(void *h, const char *symbol);
+/* obtain address of symbol from dynamically linked library */
+
+#define xdlclose _glp_dlclose
+void xdlclose(void *h);
+/* close dynamically linked library */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/error.c b/test/monniaux/glpk-4.65/src/env/error.c
new file mode 100644
index 00000000..a898b768
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/error.c
@@ -0,0 +1,200 @@
+/* error.c (error handling) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_error - display fatal error message and terminate execution
+*
+* SYNOPSIS
+*
+* void glp_error(const char *fmt, ...);
+*
+* DESCRIPTION
+*
+* The routine glp_error (implemented as a macro) formats its
+* parameters using the format control string fmt, writes the formatted
+* message on the terminal, and abnormally terminates the program. */
+
+static void errfunc(const char *fmt, ...)
+{ ENV *env = get_env_ptr();
+ va_list arg;
+#if 1 /* 07/XI-2015 */
+ env->err_st = 1;
+#endif
+ env->term_out = GLP_ON;
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ xprintf("Error detected in file %s at line %d\n",
+ env->err_file, env->err_line);
+ if (env->err_hook != NULL)
+ env->err_hook(env->err_info);
+ abort();
+ exit(EXIT_FAILURE);
+ /* no return */
+}
+
+glp_errfunc glp_error_(const char *file, int line)
+{ ENV *env = get_env_ptr();
+ env->err_file = file;
+ env->err_line = line;
+ return errfunc;
+}
+
+#if 1 /* 07/XI-2015 */
+/***********************************************************************
+* NAME
+*
+* glp_at_error - check for error state
+*
+* SYNOPSIS
+*
+* int glp_at_error(void);
+*
+* DESCRIPTION
+*
+* The routine glp_at_error checks if the GLPK environment is at error
+* state, i.e. if the call to the routine is (indirectly) made from the
+* glp_error routine via an user-defined hook routine.
+*
+* RETURNS
+*
+* If the GLPK environment is at error state, the routine glp_at_error
+* returns non-zero, otherwise zero. */
+
+int glp_at_error(void)
+{ ENV *env = get_env_ptr();
+ return env->err_st;
+}
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_assert - check for logical condition
+*
+* SYNOPSIS
+*
+* void glp_assert(int expr);
+*
+* DESCRIPTION
+*
+* The routine glp_assert (implemented as a macro) checks for a logical
+* condition specified by the parameter expr. If the condition is false
+* (i.e. the value of expr is zero), the routine writes a message on
+* the terminal and abnormally terminates the program. */
+
+void glp_assert_(const char *expr, const char *file, int line)
+{ glp_error_(file, line)("Assertion failed: %s\n", expr);
+ /* no return */
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_error_hook - install hook to intercept abnormal termination
+*
+* SYNOPSIS
+*
+* void glp_error_hook(void (*func)(void *info), void *info);
+*
+* DESCRIPTION
+*
+* The routine glp_error_hook installs a user-defined hook routine to
+* intercept abnormal termination.
+*
+* The parameter func specifies the user-defined hook routine. It is
+* called from the routine glp_error before the latter calls the abort
+* function to abnormally terminate the application program because of
+* fatal error. The parameter info is a transit pointer, specified in
+* the corresponding call to the routine glp_error_hook; it may be used
+* to pass some information to the hook routine.
+*
+* To uninstall the hook routine the parameters func and info should be
+* both specified as NULL. */
+
+void glp_error_hook(void (*func)(void *info), void *info)
+{ ENV *env = get_env_ptr();
+ if (func == NULL)
+ { env->err_hook = NULL;
+ env->err_info = NULL;
+ }
+ else
+ { env->err_hook = func;
+ env->err_info = info;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* put_err_msg - provide error message string
+*
+* SYNOPSIS
+*
+* #include "env.h"
+* void put_err_msg(const char *msg);
+*
+* DESCRIPTION
+*
+* The routine put_err_msg stores an error message string pointed to by
+* msg to the environment block. */
+
+void put_err_msg(const char *msg)
+{ ENV *env = get_env_ptr();
+ int len;
+ len = strlen(msg);
+ if (len >= EBUF_SIZE)
+ len = EBUF_SIZE - 1;
+ memcpy(env->err_buf, msg, len);
+ if (len > 0 && env->err_buf[len-1] == '\n')
+ len--;
+ env->err_buf[len] = '\0';
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* get_err_msg - obtain error message string
+*
+* SYNOPSIS
+*
+* #include "env.h"
+* const char *get_err_msg(void);
+*
+* RETURNS
+*
+* The routine get_err_msg returns a pointer to an error message string
+* previously stored by the routine put_err_msg. */
+
+const char *get_err_msg(void)
+{ ENV *env = get_env_ptr();
+ return env->err_buf;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/stdc.c b/test/monniaux/glpk-4.65/src/env/stdc.c
new file mode 100644
index 00000000..59331e22
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/stdc.c
@@ -0,0 +1,98 @@
+/* stdc.c (replacements for standard non-thread-safe functions) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+/* portable ANSI C version ********************************************/
+
+#if !defined(TLS)
+
+#define ENABLE_NON_SAFE
+#include "stdc.h"
+
+struct tm *xgmtime(const time_t *timer)
+{ return
+ gmtime(timer);
+}
+
+char *xstrerr(int errnum)
+{ return
+ strerror(errnum);
+}
+
+char *xstrtok(char *s1, const char *s2)
+{ return
+ strtok(s1, s2);
+}
+
+/* MS Windows version *************************************************/
+
+#elif defined(__WOE__)
+
+#include "stdc.h"
+
+struct tm *xgmtime(const time_t *timer)
+{ static TLS struct tm result;
+ gmtime_s(&result, timer);
+ return &result;
+}
+
+char *xstrerr(int errnum)
+{ static TLS char s[1023+1];
+ strerror_s(s, sizeof(s), errnum);
+ return s;
+}
+
+char *xstrtok(char *s1, const char *s2)
+{ static TLS char *ptr;
+ return strtok_s(s1, s2, &ptr);
+}
+
+/* GNU/Linux version **************************************************/
+
+#else
+
+#include "stdc.h"
+
+struct tm *xgmtime(const time_t *timer)
+{ static TLS struct tm result;
+ gmtime_r(timer, &result);
+ return &result;
+}
+
+char *xstrerr(int errnum)
+{ static TLS char s[1023+1];
+ strerror_r(errnum, s, sizeof(s));
+ return s;
+}
+
+char *xstrtok(char *s1, const char *s2)
+{ static TLS char *ptr;
+ return strtok_r(s1, s2, &ptr);
+}
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/stdc.h b/test/monniaux/glpk-4.65/src/env/stdc.h
new file mode 100644
index 00000000..a376f2c9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/stdc.h
@@ -0,0 +1,73 @@
+/* stdc.h (standard ANSI C headers) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef STDC_H
+#define STDC_H
+
+#include <ctype.h>
+#include <errno.h>
+#include <float.h>
+#include <limits.h>
+#include <math.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+
+#ifndef ENABLE_NON_SAFE /* 29/I-2017 */
+/* disable using non-thread-safe functions directly */
+#undef gmtime
+#define gmtime ???
+#undef strerror
+#define strerror ???
+#undef strtok
+#define strtok ???
+#endif
+
+#if 1 /* 29/I-2017 */
+/* provide replacements for these functions on a per-thread basis */
+#define xgmtime _glp_xgmtime
+struct tm *xgmtime(const time_t *);
+#define xstrerr _glp_xstrerr
+char *xstrerr(int);
+#define xstrtok _glp_xstrtok
+char *xstrtok(char *, const char *);
+#endif
+
+#if 1 /* 06/II-2018 */
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+#ifndef __WOE__
+#define CDECL
+#else
+#define CDECL __cdecl
+#endif
+#endif
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/stdout.c b/test/monniaux/glpk-4.65/src/env/stdout.c
new file mode 100644
index 00000000..94eee02a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/stdout.c
@@ -0,0 +1,262 @@
+/* stdout.c (terminal output) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#undef NDEBUG
+#include <assert.h>
+#include "env.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_puts - write string on terminal
+*
+* SYNOPSIS
+*
+* void glp_puts(const char *s);
+*
+* The routine glp_puts writes the string s on the terminal. */
+
+void glp_puts(const char *s)
+{ ENV *env = get_env_ptr();
+ /* if terminal output is disabled, do nothing */
+ if (!env->term_out)
+ goto skip;
+ /* pass the string to the hook routine, if defined */
+ if (env->term_hook != NULL)
+ { if (env->term_hook(env->term_info, s) != 0)
+ goto skip;
+ }
+ /* write the string on the terminal */
+ fputs(s, stdout);
+ fflush(stdout);
+ /* write the string on the tee file, if required */
+ if (env->tee_file != NULL)
+ { fputs(s, env->tee_file);
+ fflush(env->tee_file);
+ }
+skip: return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_printf - write formatted output on terminal
+*
+* SYNOPSIS
+*
+* void glp_printf(const char *fmt, ...);
+*
+* DESCRIPTION
+*
+* The routine glp_printf uses the format control string fmt to format
+* its parameters and writes the formatted output on the terminal. */
+
+void glp_printf(const char *fmt, ...)
+{ ENV *env = get_env_ptr();
+ va_list arg;
+ /* if terminal output is disabled, do nothing */
+ if (!env->term_out)
+ goto skip;
+ /* format the output */
+ va_start(arg, fmt);
+ vsprintf(env->term_buf, fmt, arg);
+ /* (do not use xassert) */
+ assert(strlen(env->term_buf) < TBUF_SIZE);
+ va_end(arg);
+ /* write the formatted output on the terminal */
+ glp_puts(env->term_buf);
+skip: return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_vprintf - write formatted output on terminal
+*
+* SYNOPSIS
+*
+* void glp_vprintf(const char *fmt, va_list arg);
+*
+* DESCRIPTION
+*
+* The routine glp_vprintf uses the format control string fmt to format
+* its parameters specified by the list arg and writes the formatted
+* output on the terminal. */
+
+void glp_vprintf(const char *fmt, va_list arg)
+{ ENV *env = get_env_ptr();
+ /* if terminal output is disabled, do nothing */
+ if (!env->term_out)
+ goto skip;
+ /* format the output */
+ vsprintf(env->term_buf, fmt, arg);
+ /* (do not use xassert) */
+ assert(strlen(env->term_buf) < TBUF_SIZE);
+ /* write the formatted output on the terminal */
+ glp_puts(env->term_buf);
+skip: return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_term_out - enable/disable terminal output
+*
+* SYNOPSIS
+*
+* int glp_term_out(int flag);
+*
+* DESCRIPTION
+*
+* Depending on the parameter flag the routine glp_term_out enables or
+* disables terminal output performed by glpk routines:
+*
+* GLP_ON - enable terminal output;
+* GLP_OFF - disable terminal output.
+*
+* RETURNS
+*
+* The routine glp_term_out returns the previous value of the terminal
+* output flag. */
+
+int glp_term_out(int flag)
+{ ENV *env = get_env_ptr();
+ int old = env->term_out;
+ if (!(flag == GLP_ON || flag == GLP_OFF))
+ xerror("glp_term_out: flag = %d; invalid parameter\n", flag);
+ env->term_out = flag;
+ return old;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_term_hook - install hook to intercept terminal output
+*
+* SYNOPSIS
+*
+* void glp_term_hook(int (*func)(void *info, const char *s),
+* void *info);
+*
+* DESCRIPTION
+*
+* The routine glp_term_hook installs a user-defined hook routine to
+* intercept all terminal output performed by glpk routines.
+*
+* This feature can be used to redirect the terminal output to other
+* destination, for example to a file or a text window.
+*
+* The parameter func specifies the user-defined hook routine. It is
+* called from an internal printing routine, which passes to it two
+* parameters: info and s. The parameter info is a transit pointer,
+* specified in the corresponding call to the routine glp_term_hook;
+* it may be used to pass some information to the hook routine. The
+* parameter s is a pointer to the null terminated character string,
+* which is intended to be written to the terminal. If the hook routine
+* returns zero, the printing routine writes the string s to the
+* terminal in a usual way; otherwise, if the hook routine returns
+* non-zero, no terminal output is performed.
+*
+* To uninstall the hook routine the parameters func and info should be
+* specified as NULL. */
+
+void glp_term_hook(int (*func)(void *info, const char *s), void *info)
+{ ENV *env = get_env_ptr();
+ if (func == NULL)
+ { env->term_hook = NULL;
+ env->term_info = NULL;
+ }
+ else
+ { env->term_hook = func;
+ env->term_info = info;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_open_tee - start copying terminal output to text file
+*
+* SYNOPSIS
+*
+* int glp_open_tee(const char *name);
+*
+* DESCRIPTION
+*
+* The routine glp_open_tee starts copying all the terminal output to
+* an output text file, whose name is specified by the character string
+* name.
+*
+* RETURNS
+*
+* 0 - operation successful
+* 1 - copying terminal output is already active
+* 2 - unable to create output file */
+
+int glp_open_tee(const char *name)
+{ ENV *env = get_env_ptr();
+ if (env->tee_file != NULL)
+ { /* copying terminal output is already active */
+ return 1;
+ }
+ env->tee_file = fopen(name, "w");
+ if (env->tee_file == NULL)
+ { /* unable to create output file */
+ return 2;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_close_tee - stop copying terminal output to text file
+*
+* SYNOPSIS
+*
+* int glp_close_tee(void);
+*
+* DESCRIPTION
+*
+* The routine glp_close_tee stops copying the terminal output to the
+* output text file previously open by the routine glp_open_tee closing
+* that file.
+*
+* RETURNS
+*
+* 0 - operation successful
+* 1 - copying terminal output was not started */
+
+int glp_close_tee(void)
+{ ENV *env = get_env_ptr();
+ if (env->tee_file == NULL)
+ { /* copying terminal output was not started */
+ return 1;
+ }
+ fclose(env->tee_file);
+ env->tee_file = NULL;
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/stream.c b/test/monniaux/glpk-4.65/src/env/stream.c
new file mode 100644
index 00000000..906e5b04
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/stream.c
@@ -0,0 +1,517 @@
+/* stream.c (stream input/output) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "zlib.h"
+
+struct glp_file
+{ /* sequential stream descriptor */
+ char *base;
+ /* pointer to buffer */
+ int size;
+ /* size of buffer, in bytes */
+ char *ptr;
+ /* pointer to next byte in buffer */
+ int cnt;
+ /* count of bytes in buffer */
+ int flag;
+ /* stream flags: */
+#define IONULL 0x01 /* null file */
+#define IOSTD 0x02 /* standard stream */
+#define IOGZIP 0x04 /* gzipped file */
+#define IOWRT 0x08 /* output stream */
+#define IOEOF 0x10 /* end of file */
+#define IOERR 0x20 /* input/output error */
+ void *file;
+ /* pointer to underlying control object */
+};
+
+/***********************************************************************
+* NAME
+*
+* glp_open - open stream
+*
+* SYNOPSIS
+*
+* glp_file *glp_open(const char *name, const char *mode);
+*
+* DESCRIPTION
+*
+* The routine glp_open opens a file whose name is a string pointed to
+* by name and associates a stream with it.
+*
+* The following special filenames are recognized by the routine (this
+* feature is platform independent):
+*
+* "/dev/null" empty (null) file;
+* "/dev/stdin" standard input stream;
+* "/dev/stdout" standard output stream;
+* "/dev/stderr" standard error stream.
+*
+* If the specified filename is ended with ".gz", it is assumed that
+* the file is in gzipped format. In this case the file is compressed
+* or decompressed by the I/O routines "on the fly".
+*
+* The parameter mode points to a string, which indicates the open mode
+* and should be one of the following:
+*
+* "r" open text file for reading;
+* "w" truncate to zero length or create text file for writing;
+* "a" append, open or create text file for writing at end-of-file;
+* "rb" open binary file for reading;
+* "wb" truncate to zero length or create binary file for writing;
+* "ab" append, open or create binary file for writing at end-of-file.
+*
+* RETURNS
+*
+* The routine glp_open returns a pointer to the object controlling the
+* stream. If the operation fails, the routine returns NULL. */
+
+glp_file *glp_open(const char *name, const char *mode)
+{ glp_file *f;
+ int flag;
+ void *file;
+ if (strcmp(mode, "r") == 0 || strcmp(mode, "rb") == 0)
+ flag = 0;
+ else if (strcmp(mode, "w") == 0 || strcmp(mode, "wb") == 0)
+ flag = IOWRT;
+#if 1 /* 08/V-2014 */
+ else if (strcmp(mode, "a") == 0 || strcmp(mode, "ab") == 0)
+ flag = IOWRT;
+#endif
+ else
+ xerror("glp_open: invalid mode string\n");
+ if (strcmp(name, "/dev/null") == 0)
+ { flag |= IONULL;
+ file = NULL;
+ }
+ else if (strcmp(name, "/dev/stdin") == 0)
+ { flag |= IOSTD;
+ file = stdin;
+ }
+ else if (strcmp(name, "/dev/stdout") == 0)
+ { flag |= IOSTD;
+ file = stdout;
+ }
+ else if (strcmp(name, "/dev/stderr") == 0)
+ { flag |= IOSTD;
+ file = stderr;
+ }
+ else
+ { char *ext = strrchr(name, '.');
+ if (ext == NULL || strcmp(ext, ".gz") != 0)
+ { file = fopen(name, mode);
+ if (file == NULL)
+#if 0 /* 29/I-2017 */
+ { put_err_msg(strerror(errno));
+#else
+ { put_err_msg(xstrerr(errno));
+#endif
+ return NULL;
+ }
+ }
+ else
+ { flag |= IOGZIP;
+ if (strcmp(mode, "r") == 0)
+ mode = "rb";
+ else if (strcmp(mode, "w") == 0)
+ mode = "wb";
+#if 1 /* 08/V-2014; this mode seems not to work */
+ else if (strcmp(mode, "a") == 0)
+ mode = "ab";
+#endif
+ file = gzopen(name, mode);
+ if (file == NULL)
+#if 0 /* 29/I-2017 */
+ { put_err_msg(strerror(errno));
+#else
+ { put_err_msg(xstrerr(errno));
+#endif
+ return NULL;
+ }
+ }
+ }
+ f = talloc(1, glp_file);
+ f->base = talloc(BUFSIZ, char);
+ f->size = BUFSIZ;
+ f->ptr = f->base;
+ f->cnt = 0;
+ f->flag = flag;
+ f->file = file;
+ return f;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_eof - test end-of-file indicator
+*
+* SYNOPSIS
+*
+* int glp_eof(glp_file *f);
+*
+* DESCRIPTION
+*
+* The routine glp_eof tests the end-of-file indicator for the stream
+* pointed to by f.
+*
+* RETURNS
+*
+* The routine glp_eof returns non-zero if and only if the end-of-file
+* indicator is set for the specified stream. */
+
+int glp_eof(glp_file *f)
+{ return
+ f->flag & IOEOF;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_ioerr - test I/O error indicator
+*
+* SYNOPSIS
+*
+* int glp_ioerr(glp_file *f);
+*
+* DESCRIPTION
+*
+* The routine glp_ioerr tests the I/O error indicator for the stream
+* pointed to by f.
+*
+* RETURNS
+*
+* The routine glp_ioerr returns non-zero if and only if the I/O error
+* indicator is set for the specified stream. */
+
+int glp_ioerr(glp_file *f)
+{ return
+ f->flag & IOERR;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_read - read data from stream
+*
+* SYNOPSIS
+*
+* int glp_read(glp_file *f, void *buf, int nnn);
+*
+* DESCRIPTION
+*
+* The routine glp_read reads, into the buffer pointed to by buf, up to
+* nnn bytes, from the stream pointed to by f.
+*
+* RETURNS
+*
+* The routine glp_read returns the number of bytes successfully read
+* (which may be less than nnn). If an end-of-file is encountered, the
+* end-of-file indicator for the stream is set and glp_read returns
+* zero. If a read error occurs, the error indicator for the stream is
+* set and glp_read returns a negative value. */
+
+int glp_read(glp_file *f, void *buf, int nnn)
+{ int nrd, cnt;
+ if (f->flag & IOWRT)
+ xerror("glp_read: attempt to read from output stream\n");
+ if (nnn < 1)
+ xerror("glp_read: nnn = %d; invalid parameter\n", nnn);
+ for (nrd = 0; nrd < nnn; nrd += cnt)
+ { if (f->cnt == 0)
+ { /* buffer is empty; fill it */
+ if (f->flag & IONULL)
+ cnt = 0;
+ else if (!(f->flag & IOGZIP))
+ { cnt = fread(f->base, 1, f->size, (FILE *)(f->file));
+ if (ferror((FILE *)(f->file)))
+ { f->flag |= IOERR;
+#if 0 /* 29/I-2017 */
+ put_err_msg(strerror(errno));
+#else
+ put_err_msg(xstrerr(errno));
+#endif
+ return EOF;
+ }
+ }
+ else
+ { int errnum;
+ const char *msg;
+ cnt = gzread((gzFile)(f->file), f->base, f->size);
+ if (cnt < 0)
+ { f->flag |= IOERR;
+ msg = gzerror((gzFile)(f->file), &errnum);
+ if (errnum == Z_ERRNO)
+#if 0 /* 29/I-2017 */
+ put_err_msg(strerror(errno));
+#else
+ put_err_msg(xstrerr(errno));
+#endif
+ else
+ put_err_msg(msg);
+ return EOF;
+ }
+ }
+ if (cnt == 0)
+ { if (nrd == 0)
+ f->flag |= IOEOF;
+ break;
+ }
+ f->ptr = f->base;
+ f->cnt = cnt;
+ }
+ cnt = nnn - nrd;
+ if (cnt > f->cnt)
+ cnt = f->cnt;
+ memcpy((char *)buf + nrd, f->ptr, cnt);
+ f->ptr += cnt;
+ f->cnt -= cnt;
+ }
+ return nrd;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_getc - read character from stream
+*
+* SYNOPSIS
+*
+* int glp_getc(glp_file *f);
+*
+* DESCRIPTION
+*
+* The routine glp_getc obtains a next character as an unsigned char
+* converted to an int from the input stream pointed to by f.
+*
+* RETURNS
+*
+* The routine glp_getc returns the next character obtained. However,
+* if an end-of-file is encountered or a read error occurs, the routine
+* returns EOF. (An end-of-file and a read error can be distinguished
+* by use of the routines glp_eof and glp_ioerr.) */
+
+int glp_getc(glp_file *f)
+{ unsigned char buf[1];
+ if (f->flag & IOWRT)
+ xerror("glp_getc: attempt to read from output stream\n");
+ if (glp_read(f, buf, 1) != 1)
+ return EOF;
+ return buf[0];
+}
+
+/***********************************************************************
+* do_flush - flush output stream
+*
+* This routine causes buffered data for the specified output stream to
+* be written to the associated file.
+*
+* If the operation was successful, the routine returns zero, otherwise
+* non-zero. */
+
+static int do_flush(glp_file *f)
+{ xassert(f->flag & IOWRT);
+ if (f->cnt > 0)
+ { if (f->flag & IONULL)
+ ;
+ else if (!(f->flag & IOGZIP))
+ { if ((int)fwrite(f->base, 1, f->cnt, (FILE *)(f->file))
+ != f->cnt)
+ { f->flag |= IOERR;
+#if 0 /* 29/I-2017 */
+ put_err_msg(strerror(errno));
+#else
+ put_err_msg(xstrerr(errno));
+#endif
+ return EOF;
+ }
+ }
+ else
+ { int errnum;
+ const char *msg;
+ if (gzwrite((gzFile)(f->file), f->base, f->cnt) != f->cnt)
+ { f->flag |= IOERR;
+ msg = gzerror((gzFile)(f->file), &errnum);
+ if (errnum == Z_ERRNO)
+#if 0 /* 29/I-2017 */
+ put_err_msg(strerror(errno));
+#else
+ put_err_msg(xstrerr(errno));
+#endif
+ else
+ put_err_msg(msg);
+ return EOF;
+ }
+ }
+ }
+ f->ptr = f->base;
+ f->cnt = 0;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_write - write data to stream
+*
+* SYNOPSIS
+*
+* int glp_write(glp_file *f, const void *buf, int nnn);
+*
+* DESCRIPTION
+*
+* The routine glp_write writes, from the buffer pointed to by buf, up
+* to nnn bytes, to the stream pointed to by f.
+*
+* RETURNS
+*
+* The routine glp_write returns the number of bytes successfully
+* written (which is equal to nnn). If a write error occurs, the error
+* indicator for the stream is set and glp_write returns a negative
+* value. */
+
+int glp_write(glp_file *f, const void *buf, int nnn)
+{ int nwr, cnt;
+ if (!(f->flag & IOWRT))
+ xerror("glp_write: attempt to write to input stream\n");
+ if (nnn < 1)
+ xerror("glp_write: nnn = %d; invalid parameter\n", nnn);
+ for (nwr = 0; nwr < nnn; nwr += cnt)
+ { cnt = nnn - nwr;
+ if (cnt > f->size - f->cnt)
+ cnt = f->size - f->cnt;
+ memcpy(f->ptr, (const char *)buf + nwr, cnt);
+ f->ptr += cnt;
+ f->cnt += cnt;
+ if (f->cnt == f->size)
+ { /* buffer is full; flush it */
+ if (do_flush(f) != 0)
+ return EOF;
+ }
+ }
+ return nwr;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_format - write formatted data to stream
+*
+* SYNOPSIS
+*
+* int glp_format(glp_file *f, const char *fmt, ...);
+*
+* DESCRIPTION
+*
+* The routine glp_format writes formatted data to the stream pointed
+* to by f. The format control string pointed to by fmt specifies how
+* subsequent arguments are converted for output.
+*
+* RETURNS
+*
+* The routine glp_format returns the number of characters written, or
+* a negative value if an output error occurs. */
+
+int glp_format(glp_file *f, const char *fmt, ...)
+{ ENV *env = get_env_ptr();
+ va_list arg;
+ int nnn;
+ if (!(f->flag & IOWRT))
+ xerror("glp_format: attempt to write to input stream\n");
+ va_start(arg, fmt);
+ nnn = vsprintf(env->term_buf, fmt, arg);
+ xassert(0 <= nnn && nnn < TBUF_SIZE);
+ va_end(arg);
+ return nnn == 0 ? 0 : glp_write(f, env->term_buf, nnn);
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_close - close stream
+*
+* SYNOPSIS
+*
+* int glp_close(glp_file *f);
+*
+* DESCRIPTION
+*
+* The routine glp_close closes the stream pointed to by f.
+*
+* RETURNS
+*
+* If the operation was successful, the routine returns zero, otherwise
+* non-zero. */
+
+int glp_close(glp_file *f)
+{ int ret = 0;
+ if (f->flag & IOWRT)
+ { if (do_flush(f) != 0)
+ ret = EOF;
+ }
+ if (f->flag & (IONULL | IOSTD))
+ ;
+ else if (!(f->flag & IOGZIP))
+ { if (fclose((FILE *)(f->file)) != 0)
+ { if (ret == 0)
+#if 0 /* 29/I-2017 */
+ { put_err_msg(strerror(errno));
+#else
+ { put_err_msg(xstrerr(errno));
+#endif
+ ret = EOF;
+ }
+ }
+ }
+ else
+ { int errnum;
+ errnum = gzclose((gzFile)(f->file));
+ if (errnum == Z_OK)
+ ;
+ else if (errnum == Z_ERRNO)
+ { if (ret == 0)
+#if 0 /* 29/I-2017 */
+ { put_err_msg(strerror(errno));
+#else
+ { put_err_msg(xstrerr(errno));
+#endif
+ ret = EOF;
+ }
+ }
+#if 1 /* FIXME */
+ else
+ { if (ret == 0)
+ { ENV *env = get_env_ptr();
+ sprintf(env->term_buf, "gzclose returned %d", errnum);
+ put_err_msg(env->term_buf);
+ ret = EOF;
+ }
+ }
+#endif
+ }
+ tfree(f->base);
+ tfree(f);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/time.c b/test/monniaux/glpk-4.65/src/env/time.c
new file mode 100644
index 00000000..1ffb28e9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/time.c
@@ -0,0 +1,150 @@
+/* time.c (standard time) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <address@hidden>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "env.h"
+#include "jd.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_time - determine current universal time
+*
+* SYNOPSIS
+*
+* double glp_time(void);
+*
+* RETURNS
+*
+* The routine glp_time returns the current universal time (UTC), in
+* milliseconds, elapsed since 00:00:00 GMT January 1, 1970. */
+
+#define EPOCH 2440588 /* = jday(1, 1, 1970) */
+
+/* POSIX version ******************************************************/
+
+#if defined(HAVE_SYS_TIME_H) && defined(HAVE_GETTIMEOFDAY)
+
+#if 0 /* 29/VI-2017 */
+#include <sys/time.h>
+#include <time.h>
+
+double glp_time(void)
+{ struct timeval tv;
+ struct tm *tm;
+ int j;
+ double t;
+ gettimeofday(&tv, NULL);
+#if 0 /* 29/I-2017 */
+ tm = gmtime(&tv.tv_sec);
+#else
+ tm = xgmtime(&tv.tv_sec);
+#endif
+ j = jday(tm->tm_mday, tm->tm_mon + 1, 1900 + tm->tm_year);
+ xassert(j >= 0);
+ t = ((((double)(j - EPOCH) * 24.0 + (double)tm->tm_hour) * 60.0 +
+ (double)tm->tm_min) * 60.0 + (double)tm->tm_sec) * 1000.0 +
+ (double)(tv.tv_usec / 1000);
+ return t;
+}
+#else
+#include <sys/time.h>
+
+double glp_time(void)
+{ struct timeval tv;
+ double t;
+ gettimeofday(&tv, NULL);
+ t = (double)tv.tv_sec + (double)(tv.tv_usec) / 1e6;
+ xassert(0.0 <= t && t < 4294967296.0);
+ return 1000.0 * t;
+}
+#endif
+
+/* MS Windows version *************************************************/
+
+#elif defined(__WOE__)
+
+#include <windows.h>
+
+double glp_time(void)
+{ SYSTEMTIME st;
+ int j;
+ double t;
+ GetSystemTime(&st);
+ j = jday(st.wDay, st.wMonth, st.wYear);
+ xassert(j >= 0);
+ t = ((((double)(j - EPOCH) * 24.0 + (double)st.wHour) * 60.0 +
+ (double)st.wMinute) * 60.0 + (double)st.wSecond) * 1000.0 +
+ (double)st.wMilliseconds;
+ return t;
+}
+
+/* portable ANSI C version ********************************************/
+
+#else
+
+#include <time.h>
+
+double glp_time(void)
+{ time_t timer;
+ struct tm *tm;
+ int j;
+ double t;
+ timer = time(NULL);
+#if 0 /* 29/I-2017 */
+ tm = gmtime(&timer);
+#else
+ tm = xgmtime(&timer);
+#endif
+ j = jday(tm->tm_mday, tm->tm_mon + 1, 1900 + tm->tm_year);
+ xassert(j >= 0);
+ t = ((((double)(j - EPOCH) * 24.0 + (double)tm->tm_hour) * 60.0 +
+ (double)tm->tm_min) * 60.0 + (double)tm->tm_sec) * 1000.0;
+ return t;
+}
+
+#endif
+
+/***********************************************************************
+* NAME
+*
+* glp_difftime - compute difference between two time values
+*
+* SYNOPSIS
+*
+* double glp_difftime(double t1, double t0);
+*
+* RETURNS
+*
+* The routine glp_difftime returns the difference between two time
+* values t1 and t0, expressed in seconds. */
+
+double glp_difftime(double t1, double t0)
+{ return
+ (t1 - t0) / 1000.0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/env/tls.c b/test/monniaux/glpk-4.65/src/env/tls.c
new file mode 100644
index 00000000..4062ee4c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/env/tls.c
@@ -0,0 +1,128 @@
+/* tls.c (thread local storage) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2001-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "env.h"
+
+#ifndef TLS
+static void *tls = NULL;
+#else
+static TLS void *tls = NULL;
+/* this option allows running multiple independent instances of GLPK in
+ * different threads of a multi-threaded application, in which case the
+ * variable tls should be placed in the Thread Local Storage (TLS);
+ * it is assumed that the macro TLS is previously defined to something
+ * like '__thread', '_Thread_local', etc. */
+#endif
+
+/***********************************************************************
+* NAME
+*
+* tls_set_ptr - store global pointer in TLS
+*
+* SYNOPSIS
+*
+* #include "env.h"
+* void tls_set_ptr(void *ptr);
+*
+* DESCRIPTION
+*
+* The routine tls_set_ptr stores a pointer specified by the parameter
+* ptr in the Thread Local Storage (TLS). */
+
+void tls_set_ptr(void *ptr)
+{ tls = ptr;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* tls_get_ptr - retrieve global pointer from TLS
+*
+* SYNOPSIS
+*
+* #include "env.h"
+* void *tls_get_ptr(void);
+*
+* RETURNS
+*
+* The routine tls_get_ptr returns a pointer previously stored by the
+* routine tls_set_ptr. If the latter has not been called yet, NULL is
+* returned. */
+
+void *tls_get_ptr(void)
+{ void *ptr;
+ ptr = tls;
+ return ptr;
+}
+
+/**********************************************************************/
+
+#ifdef __WOE__
+
+/*** Author: Heinrich Schuchardt <xypron.glpk@gmx.de> ***/
+
+#pragma comment(lib, "user32.lib")
+
+#include <windows.h>
+
+#define VISTA 0x06
+
+/* This is the main entry point of the DLL. */
+
+BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID
+ lpvReserved)
+{ DWORD version;
+ DWORD major_version;
+#ifdef TLS
+ switch (fdwReason)
+ { case DLL_PROCESS_ATTACH:
+ /* @TODO:
+ * GetVersion is deprecated but the version help functions are
+ * not available in Visual Studio 2010. So lets use it until
+ * we remove the outdated Build files. */
+ version = GetVersion();
+ major_version = version & 0xff;
+ if (major_version < VISTA)
+ { MessageBoxA(NULL,
+ "The GLPK library called by this application is configur"
+ "ed to use thread local storage which is not fully suppo"
+ "rted by your version of Microsoft Windows.\n\n"
+ "Microsoft Windows Vista or a later version of Windows i"
+ "s required to run this application.",
+ "GLPK", MB_OK | MB_ICONERROR);
+ return FALSE;
+ }
+ break;
+ }
+#endif /* TLS */
+ return TRUE;
+}
+
+#endif /* __WOE__ */
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/glpk.h b/test/monniaux/glpk-4.65/src/glpk.h
new file mode 100644
index 00000000..f4e250f9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/glpk.h
@@ -0,0 +1,1175 @@
+/* glpk.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef GLPK_H
+#define GLPK_H
+
+#include <stdarg.h>
+#include <stddef.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* library version numbers: */
+#define GLP_MAJOR_VERSION 4
+#define GLP_MINOR_VERSION 65
+
+typedef struct glp_prob glp_prob;
+/* LP/MIP problem object */
+
+/* optimization direction flag: */
+#define GLP_MIN 1 /* minimization */
+#define GLP_MAX 2 /* maximization */
+
+/* kind of structural variable: */
+#define GLP_CV 1 /* continuous variable */
+#define GLP_IV 2 /* integer variable */
+#define GLP_BV 3 /* binary variable */
+
+/* type of auxiliary/structural variable: */
+#define GLP_FR 1 /* free (unbounded) variable */
+#define GLP_LO 2 /* variable with lower bound */
+#define GLP_UP 3 /* variable with upper bound */
+#define GLP_DB 4 /* double-bounded variable */
+#define GLP_FX 5 /* fixed variable */
+
+/* status of auxiliary/structural variable: */
+#define GLP_BS 1 /* basic variable */
+#define GLP_NL 2 /* non-basic variable on lower bound */
+#define GLP_NU 3 /* non-basic variable on upper bound */
+#define GLP_NF 4 /* non-basic free (unbounded) variable */
+#define GLP_NS 5 /* non-basic fixed variable */
+
+/* scaling options: */
+#define GLP_SF_GM 0x01 /* perform geometric mean scaling */
+#define GLP_SF_EQ 0x10 /* perform equilibration scaling */
+#define GLP_SF_2N 0x20 /* round scale factors to power of two */
+#define GLP_SF_SKIP 0x40 /* skip if problem is well scaled */
+#define GLP_SF_AUTO 0x80 /* choose scaling options automatically */
+
+/* solution indicator: */
+#define GLP_SOL 1 /* basic solution */
+#define GLP_IPT 2 /* interior-point solution */
+#define GLP_MIP 3 /* mixed integer solution */
+
+/* solution status: */
+#define GLP_UNDEF 1 /* solution is undefined */
+#define GLP_FEAS 2 /* solution is feasible */
+#define GLP_INFEAS 3 /* solution is infeasible */
+#define GLP_NOFEAS 4 /* no feasible solution exists */
+#define GLP_OPT 5 /* solution is optimal */
+#define GLP_UNBND 6 /* solution is unbounded */
+
+typedef struct
+{ /* basis factorization control parameters */
+ int msg_lev; /* (not used) */
+ int type; /* factorization type: */
+#if 1 /* 05/III-2014 */
+#define GLP_BF_LUF 0x00 /* plain LU-factorization */
+#define GLP_BF_BTF 0x10 /* block triangular LU-factorization */
+#endif
+#define GLP_BF_FT 0x01 /* Forrest-Tomlin (LUF only) */
+#define GLP_BF_BG 0x02 /* Schur compl. + Bartels-Golub */
+#define GLP_BF_GR 0x03 /* Schur compl. + Givens rotation */
+ int lu_size; /* (not used) */
+ double piv_tol; /* sgf_piv_tol */
+ int piv_lim; /* sgf_piv_lim */
+ int suhl; /* sgf_suhl */
+ double eps_tol; /* sgf_eps_tol */
+ double max_gro; /* (not used) */
+ int nfs_max; /* fhvint.nfs_max */
+ double upd_tol; /* (not used) */
+ int nrs_max; /* scfint.nn_max */
+ int rs_size; /* (not used) */
+ double foo_bar[38]; /* (reserved) */
+} glp_bfcp;
+
+typedef struct
+{ /* simplex solver control parameters */
+ int msg_lev; /* message level: */
+#define GLP_MSG_OFF 0 /* no output */
+#define GLP_MSG_ERR 1 /* warning and error messages only */
+#define GLP_MSG_ON 2 /* normal output */
+#define GLP_MSG_ALL 3 /* full output */
+#define GLP_MSG_DBG 4 /* debug output */
+ int meth; /* simplex method option: */
+#define GLP_PRIMAL 1 /* use primal simplex */
+#define GLP_DUALP 2 /* use dual; if it fails, use primal */
+#define GLP_DUAL 3 /* use dual simplex */
+ int pricing; /* pricing technique: */
+#define GLP_PT_STD 0x11 /* standard (Dantzig's rule) */
+#define GLP_PT_PSE 0x22 /* projected steepest edge */
+ int r_test; /* ratio test technique: */
+#define GLP_RT_STD 0x11 /* standard (textbook) */
+#define GLP_RT_HAR 0x22 /* Harris' two-pass ratio test */
+#if 1 /* 16/III-2016 */
+#define GLP_RT_FLIP 0x33 /* long-step (flip-flop) ratio test */
+#endif
+ double tol_bnd; /* primal feasibility tolerance */
+ double tol_dj; /* dual feasibility tolerance */
+ double tol_piv; /* pivot tolerance */
+ double obj_ll; /* lower objective limit */
+ double obj_ul; /* upper objective limit */
+ int it_lim; /* simplex iteration limit */
+ int tm_lim; /* time limit, ms */
+ int out_frq; /* display output frequency, ms */
+ int out_dly; /* display output delay, ms */
+ int presolve; /* enable/disable using LP presolver */
+#if 1 /* 11/VII-2017 (not documented yet) */
+ int excl; /* exclude fixed non-basic variables */
+ int shift; /* shift bounds of variables to zero */
+ int aorn; /* option to use A or N: */
+#define GLP_USE_AT 1 /* use A matrix in row-wise format */
+#define GLP_USE_NT 2 /* use N matrix in row-wise format */
+ double foo_bar[33]; /* (reserved) */
+#endif
+} glp_smcp;
+
+typedef struct
+{ /* interior-point solver control parameters */
+ int msg_lev; /* message level (see glp_smcp) */
+ int ord_alg; /* ordering algorithm: */
+#define GLP_ORD_NONE 0 /* natural (original) ordering */
+#define GLP_ORD_QMD 1 /* quotient minimum degree (QMD) */
+#define GLP_ORD_AMD 2 /* approx. minimum degree (AMD) */
+#define GLP_ORD_SYMAMD 3 /* approx. minimum degree (SYMAMD) */
+ double foo_bar[48]; /* (reserved) */
+} glp_iptcp;
+
+typedef struct glp_tree glp_tree;
+/* branch-and-bound tree */
+
+typedef struct
+{ /* integer optimizer control parameters */
+ int msg_lev; /* message level (see glp_smcp) */
+ int br_tech; /* branching technique: */
+#define GLP_BR_FFV 1 /* first fractional variable */
+#define GLP_BR_LFV 2 /* last fractional variable */
+#define GLP_BR_MFV 3 /* most fractional variable */
+#define GLP_BR_DTH 4 /* heuristic by Driebeck and Tomlin */
+#define GLP_BR_PCH 5 /* hybrid pseudocost heuristic */
+ int bt_tech; /* backtracking technique: */
+#define GLP_BT_DFS 1 /* depth first search */
+#define GLP_BT_BFS 2 /* breadth first search */
+#define GLP_BT_BLB 3 /* best local bound */
+#define GLP_BT_BPH 4 /* best projection heuristic */
+ double tol_int; /* mip.tol_int */
+ double tol_obj; /* mip.tol_obj */
+ int tm_lim; /* mip.tm_lim (milliseconds) */
+ int out_frq; /* mip.out_frq (milliseconds) */
+ int out_dly; /* mip.out_dly (milliseconds) */
+ void (*cb_func)(glp_tree *T, void *info);
+ /* mip.cb_func */
+ void *cb_info; /* mip.cb_info */
+ int cb_size; /* mip.cb_size */
+ int pp_tech; /* preprocessing technique: */
+#define GLP_PP_NONE 0 /* disable preprocessing */
+#define GLP_PP_ROOT 1 /* preprocessing only on root level */
+#define GLP_PP_ALL 2 /* preprocessing on all levels */
+ double mip_gap; /* relative MIP gap tolerance */
+ int mir_cuts; /* MIR cuts (GLP_ON/GLP_OFF) */
+ int gmi_cuts; /* Gomory's cuts (GLP_ON/GLP_OFF) */
+ int cov_cuts; /* cover cuts (GLP_ON/GLP_OFF) */
+ int clq_cuts; /* clique cuts (GLP_ON/GLP_OFF) */
+ int presolve; /* enable/disable using MIP presolver */
+ int binarize; /* try to binarize integer variables */
+ int fp_heur; /* feasibility pump heuristic */
+ int ps_heur; /* proximity search heuristic */
+ int ps_tm_lim; /* proxy time limit, milliseconds */
+ int sr_heur; /* simple rounding heuristic */
+#if 1 /* 24/X-2015; not documented--should not be used */
+ int use_sol; /* use existing solution */
+ const char *save_sol; /* filename to save every new solution */
+ int alien; /* use alien solver */
+#endif
+#if 1 /* 16/III-2016; not documented--should not be used */
+ int flip; /* use long-step dual simplex */
+#endif
+ double foo_bar[23]; /* (reserved) */
+} glp_iocp;
+
+typedef struct
+{ /* additional row attributes */
+ int level;
+ /* subproblem level at which the row was added */
+ int origin;
+ /* row origin flag: */
+#define GLP_RF_REG 0 /* regular constraint */
+#define GLP_RF_LAZY 1 /* "lazy" constraint */
+#define GLP_RF_CUT 2 /* cutting plane constraint */
+ int klass;
+ /* row class descriptor: */
+#define GLP_RF_GMI 1 /* Gomory's mixed integer cut */
+#define GLP_RF_MIR 2 /* mixed integer rounding cut */
+#define GLP_RF_COV 3 /* mixed cover cut */
+#define GLP_RF_CLQ 4 /* clique cut */
+ double foo_bar[7];
+ /* (reserved) */
+} glp_attr;
+
+/* enable/disable flag: */
+#define GLP_ON 1 /* enable something */
+#define GLP_OFF 0 /* disable something */
+
+/* reason codes: */
+#define GLP_IROWGEN 0x01 /* request for row generation */
+#define GLP_IBINGO 0x02 /* better integer solution found */
+#define GLP_IHEUR 0x03 /* request for heuristic solution */
+#define GLP_ICUTGEN 0x04 /* request for cut generation */
+#define GLP_IBRANCH 0x05 /* request for branching */
+#define GLP_ISELECT 0x06 /* request for subproblem selection */
+#define GLP_IPREPRO 0x07 /* request for preprocessing */
+
+/* branch selection indicator: */
+#define GLP_NO_BRNCH 0 /* select no branch */
+#define GLP_DN_BRNCH 1 /* select down-branch */
+#define GLP_UP_BRNCH 2 /* select up-branch */
+
+/* return codes: */
+#define GLP_EBADB 0x01 /* invalid basis */
+#define GLP_ESING 0x02 /* singular matrix */
+#define GLP_ECOND 0x03 /* ill-conditioned matrix */
+#define GLP_EBOUND 0x04 /* invalid bounds */
+#define GLP_EFAIL 0x05 /* solver failed */
+#define GLP_EOBJLL 0x06 /* objective lower limit reached */
+#define GLP_EOBJUL 0x07 /* objective upper limit reached */
+#define GLP_EITLIM 0x08 /* iteration limit exceeded */
+#define GLP_ETMLIM 0x09 /* time limit exceeded */
+#define GLP_ENOPFS 0x0A /* no primal feasible solution */
+#define GLP_ENODFS 0x0B /* no dual feasible solution */
+#define GLP_EROOT 0x0C /* root LP optimum not provided */
+#define GLP_ESTOP 0x0D /* search terminated by application */
+#define GLP_EMIPGAP 0x0E /* relative mip gap tolerance reached */
+#define GLP_ENOFEAS 0x0F /* no primal/dual feasible solution */
+#define GLP_ENOCVG 0x10 /* no convergence */
+#define GLP_EINSTAB 0x11 /* numerical instability */
+#define GLP_EDATA 0x12 /* invalid data */
+#define GLP_ERANGE 0x13 /* result out of range */
+
+/* condition indicator: */
+#define GLP_KKT_PE 1 /* primal equalities */
+#define GLP_KKT_PB 2 /* primal bounds */
+#define GLP_KKT_DE 3 /* dual equalities */
+#define GLP_KKT_DB 4 /* dual bounds */
+#define GLP_KKT_CS 5 /* complementary slackness */
+
+/* MPS file format: */
+#define GLP_MPS_DECK 1 /* fixed (ancient) */
+#define GLP_MPS_FILE 2 /* free (modern) */
+
+typedef struct
+{ /* MPS format control parameters */
+ int blank;
+ /* character code to replace blanks in symbolic names */
+ char *obj_name;
+ /* objective row name */
+ double tol_mps;
+ /* zero tolerance for MPS data */
+ double foo_bar[17];
+ /* (reserved for use in the future) */
+} glp_mpscp;
+
+typedef struct
+{ /* CPLEX LP format control parameters */
+ double foo_bar[20];
+ /* (reserved for use in the future) */
+} glp_cpxcp;
+
+#if 1 /* 10/XII-2017 */
+typedef struct glp_prep glp_prep;
+/* LP/MIP preprocessor workspace */
+#endif
+
+typedef struct glp_tran glp_tran;
+/* MathProg translator workspace */
+
+glp_prob *glp_create_prob(void);
+/* create problem object */
+
+void glp_set_prob_name(glp_prob *P, const char *name);
+/* assign (change) problem name */
+
+void glp_set_obj_name(glp_prob *P, const char *name);
+/* assign (change) objective function name */
+
+void glp_set_obj_dir(glp_prob *P, int dir);
+/* set (change) optimization direction flag */
+
+int glp_add_rows(glp_prob *P, int nrs);
+/* add new rows to problem object */
+
+int glp_add_cols(glp_prob *P, int ncs);
+/* add new columns to problem object */
+
+void glp_set_row_name(glp_prob *P, int i, const char *name);
+/* assign (change) row name */
+
+void glp_set_col_name(glp_prob *P, int j, const char *name);
+/* assign (change) column name */
+
+void glp_set_row_bnds(glp_prob *P, int i, int type, double lb,
+ double ub);
+/* set (change) row bounds */
+
+void glp_set_col_bnds(glp_prob *P, int j, int type, double lb,
+ double ub);
+/* set (change) column bounds */
+
+void glp_set_obj_coef(glp_prob *P, int j, double coef);
+/* set (change) obj. coefficient or constant term */
+
+void glp_set_mat_row(glp_prob *P, int i, int len, const int ind[],
+ const double val[]);
+/* set (replace) row of the constraint matrix */
+
+void glp_set_mat_col(glp_prob *P, int j, int len, const int ind[],
+ const double val[]);
+/* set (replace) column of the constraint matrix */
+
+void glp_load_matrix(glp_prob *P, int ne, const int ia[],
+ const int ja[], const double ar[]);
+/* load (replace) the whole constraint matrix */
+
+int glp_check_dup(int m, int n, int ne, const int ia[], const int ja[]);
+/* check for duplicate elements in sparse matrix */
+
+void glp_sort_matrix(glp_prob *P);
+/* sort elements of the constraint matrix */
+
+void glp_del_rows(glp_prob *P, int nrs, const int num[]);
+/* delete specified rows from problem object */
+
+void glp_del_cols(glp_prob *P, int ncs, const int num[]);
+/* delete specified columns from problem object */
+
+void glp_copy_prob(glp_prob *dest, glp_prob *prob, int names);
+/* copy problem object content */
+
+void glp_erase_prob(glp_prob *P);
+/* erase problem object content */
+
+void glp_delete_prob(glp_prob *P);
+/* delete problem object */
+
+const char *glp_get_prob_name(glp_prob *P);
+/* retrieve problem name */
+
+const char *glp_get_obj_name(glp_prob *P);
+/* retrieve objective function name */
+
+int glp_get_obj_dir(glp_prob *P);
+/* retrieve optimization direction flag */
+
+int glp_get_num_rows(glp_prob *P);
+/* retrieve number of rows */
+
+int glp_get_num_cols(glp_prob *P);
+/* retrieve number of columns */
+
+const char *glp_get_row_name(glp_prob *P, int i);
+/* retrieve row name */
+
+const char *glp_get_col_name(glp_prob *P, int j);
+/* retrieve column name */
+
+int glp_get_row_type(glp_prob *P, int i);
+/* retrieve row type */
+
+double glp_get_row_lb(glp_prob *P, int i);
+/* retrieve row lower bound */
+
+double glp_get_row_ub(glp_prob *P, int i);
+/* retrieve row upper bound */
+
+int glp_get_col_type(glp_prob *P, int j);
+/* retrieve column type */
+
+double glp_get_col_lb(glp_prob *P, int j);
+/* retrieve column lower bound */
+
+double glp_get_col_ub(glp_prob *P, int j);
+/* retrieve column upper bound */
+
+double glp_get_obj_coef(glp_prob *P, int j);
+/* retrieve obj. coefficient or constant term */
+
+int glp_get_num_nz(glp_prob *P);
+/* retrieve number of constraint coefficients */
+
+int glp_get_mat_row(glp_prob *P, int i, int ind[], double val[]);
+/* retrieve row of the constraint matrix */
+
+int glp_get_mat_col(glp_prob *P, int j, int ind[], double val[]);
+/* retrieve column of the constraint matrix */
+
+void glp_create_index(glp_prob *P);
+/* create the name index */
+
+int glp_find_row(glp_prob *P, const char *name);
+/* find row by its name */
+
+int glp_find_col(glp_prob *P, const char *name);
+/* find column by its name */
+
+void glp_delete_index(glp_prob *P);
+/* delete the name index */
+
+void glp_set_rii(glp_prob *P, int i, double rii);
+/* set (change) row scale factor */
+
+void glp_set_sjj(glp_prob *P, int j, double sjj);
+/* set (change) column scale factor */
+
+double glp_get_rii(glp_prob *P, int i);
+/* retrieve row scale factor */
+
+double glp_get_sjj(glp_prob *P, int j);
+/* retrieve column scale factor */
+
+void glp_scale_prob(glp_prob *P, int flags);
+/* scale problem data */
+
+void glp_unscale_prob(glp_prob *P);
+/* unscale problem data */
+
+void glp_set_row_stat(glp_prob *P, int i, int stat);
+/* set (change) row status */
+
+void glp_set_col_stat(glp_prob *P, int j, int stat);
+/* set (change) column status */
+
+void glp_std_basis(glp_prob *P);
+/* construct standard initial LP basis */
+
+void glp_adv_basis(glp_prob *P, int flags);
+/* construct advanced initial LP basis */
+
+void glp_cpx_basis(glp_prob *P);
+/* construct Bixby's initial LP basis */
+
+int glp_simplex(glp_prob *P, const glp_smcp *parm);
+/* solve LP problem with the simplex method */
+
+int glp_exact(glp_prob *P, const glp_smcp *parm);
+/* solve LP problem in exact arithmetic */
+
+void glp_init_smcp(glp_smcp *parm);
+/* initialize simplex method control parameters */
+
+int glp_get_status(glp_prob *P);
+/* retrieve generic status of basic solution */
+
+int glp_get_prim_stat(glp_prob *P);
+/* retrieve status of primal basic solution */
+
+int glp_get_dual_stat(glp_prob *P);
+/* retrieve status of dual basic solution */
+
+double glp_get_obj_val(glp_prob *P);
+/* retrieve objective value (basic solution) */
+
+int glp_get_row_stat(glp_prob *P, int i);
+/* retrieve row status */
+
+double glp_get_row_prim(glp_prob *P, int i);
+/* retrieve row primal value (basic solution) */
+
+double glp_get_row_dual(glp_prob *P, int i);
+/* retrieve row dual value (basic solution) */
+
+int glp_get_col_stat(glp_prob *P, int j);
+/* retrieve column status */
+
+double glp_get_col_prim(glp_prob *P, int j);
+/* retrieve column primal value (basic solution) */
+
+double glp_get_col_dual(glp_prob *P, int j);
+/* retrieve column dual value (basic solution) */
+
+int glp_get_unbnd_ray(glp_prob *P);
+/* determine variable causing unboundedness */
+
+#if 1 /* 08/VIII-2013; not documented yet */
+int glp_get_it_cnt(glp_prob *P);
+/* get simplex solver iteration count */
+#endif
+
+#if 1 /* 08/VIII-2013; not documented yet */
+void glp_set_it_cnt(glp_prob *P, int it_cnt);
+/* set simplex solver iteration count */
+#endif
+
+int glp_interior(glp_prob *P, const glp_iptcp *parm);
+/* solve LP problem with the interior-point method */
+
+void glp_init_iptcp(glp_iptcp *parm);
+/* initialize interior-point solver control parameters */
+
+int glp_ipt_status(glp_prob *P);
+/* retrieve status of interior-point solution */
+
+double glp_ipt_obj_val(glp_prob *P);
+/* retrieve objective value (interior point) */
+
+double glp_ipt_row_prim(glp_prob *P, int i);
+/* retrieve row primal value (interior point) */
+
+double glp_ipt_row_dual(glp_prob *P, int i);
+/* retrieve row dual value (interior point) */
+
+double glp_ipt_col_prim(glp_prob *P, int j);
+/* retrieve column primal value (interior point) */
+
+double glp_ipt_col_dual(glp_prob *P, int j);
+/* retrieve column dual value (interior point) */
+
+void glp_set_col_kind(glp_prob *P, int j, int kind);
+/* set (change) column kind */
+
+int glp_get_col_kind(glp_prob *P, int j);
+/* retrieve column kind */
+
+int glp_get_num_int(glp_prob *P);
+/* retrieve number of integer columns */
+
+int glp_get_num_bin(glp_prob *P);
+/* retrieve number of binary columns */
+
+int glp_intopt(glp_prob *P, const glp_iocp *parm);
+/* solve MIP problem with the branch-and-bound method */
+
+void glp_init_iocp(glp_iocp *parm);
+/* initialize integer optimizer control parameters */
+
+int glp_mip_status(glp_prob *P);
+/* retrieve status of MIP solution */
+
+double glp_mip_obj_val(glp_prob *P);
+/* retrieve objective value (MIP solution) */
+
+double glp_mip_row_val(glp_prob *P, int i);
+/* retrieve row value (MIP solution) */
+
+double glp_mip_col_val(glp_prob *P, int j);
+/* retrieve column value (MIP solution) */
+
+void glp_check_kkt(glp_prob *P, int sol, int cond, double *ae_max,
+ int *ae_ind, double *re_max, int *re_ind);
+/* check feasibility/optimality conditions */
+
+int glp_print_sol(glp_prob *P, const char *fname);
+/* write basic solution in printable format */
+
+int glp_read_sol(glp_prob *P, const char *fname);
+/* read basic solution from text file */
+
+int glp_write_sol(glp_prob *P, const char *fname);
+/* write basic solution to text file */
+
+int glp_print_ranges(glp_prob *P, int len, const int list[],
+ int flags, const char *fname);
+/* print sensitivity analysis report */
+
+int glp_print_ipt(glp_prob *P, const char *fname);
+/* write interior-point solution in printable format */
+
+int glp_read_ipt(glp_prob *P, const char *fname);
+/* read interior-point solution from text file */
+
+int glp_write_ipt(glp_prob *P, const char *fname);
+/* write interior-point solution to text file */
+
+int glp_print_mip(glp_prob *P, const char *fname);
+/* write MIP solution in printable format */
+
+int glp_read_mip(glp_prob *P, const char *fname);
+/* read MIP solution from text file */
+
+int glp_write_mip(glp_prob *P, const char *fname);
+/* write MIP solution to text file */
+
+int glp_bf_exists(glp_prob *P);
+/* check if LP basis factorization exists */
+
+int glp_factorize(glp_prob *P);
+/* compute LP basis factorization */
+
+int glp_bf_updated(glp_prob *P);
+/* check if LP basis factorization has been updated */
+
+void glp_get_bfcp(glp_prob *P, glp_bfcp *parm);
+/* retrieve LP basis factorization control parameters */
+
+void glp_set_bfcp(glp_prob *P, const glp_bfcp *parm);
+/* change LP basis factorization control parameters */
+
+int glp_get_bhead(glp_prob *P, int k);
+/* retrieve LP basis header information */
+
+int glp_get_row_bind(glp_prob *P, int i);
+/* retrieve row index in the basis header */
+
+int glp_get_col_bind(glp_prob *P, int j);
+/* retrieve column index in the basis header */
+
+void glp_ftran(glp_prob *P, double x[]);
+/* perform forward transformation (solve system B*x = b) */
+
+void glp_btran(glp_prob *P, double x[]);
+/* perform backward transformation (solve system B'*x = b) */
+
+int glp_warm_up(glp_prob *P);
+/* "warm up" LP basis */
+
+int glp_eval_tab_row(glp_prob *P, int k, int ind[], double val[]);
+/* compute row of the simplex tableau */
+
+int glp_eval_tab_col(glp_prob *P, int k, int ind[], double val[]);
+/* compute column of the simplex tableau */
+
+int glp_transform_row(glp_prob *P, int len, int ind[], double val[]);
+/* transform explicitly specified row */
+
+int glp_transform_col(glp_prob *P, int len, int ind[], double val[]);
+/* transform explicitly specified column */
+
+int glp_prim_rtest(glp_prob *P, int len, const int ind[],
+ const double val[], int dir, double eps);
+/* perform primal ratio test */
+
+int glp_dual_rtest(glp_prob *P, int len, const int ind[],
+ const double val[], int dir, double eps);
+/* perform dual ratio test */
+
+void glp_analyze_bound(glp_prob *P, int k, double *value1, int *var1,
+ double *value2, int *var2);
+/* analyze active bound of non-basic variable */
+
+void glp_analyze_coef(glp_prob *P, int k, double *coef1, int *var1,
+ double *value1, double *coef2, int *var2, double *value2);
+/* analyze objective coefficient at basic variable */
+
+#if 1 /* 10/XII-2017 */
+glp_prep *glp_npp_alloc_wksp(void);
+/* allocate the preprocessor workspace */
+
+void glp_npp_load_prob(glp_prep *prep, glp_prob *P, int sol,
+ int names);
+/* load original problem instance */
+
+int glp_npp_preprocess1(glp_prep *prep, int hard);
+/* perform basic LP/MIP preprocessing */
+
+void glp_npp_build_prob(glp_prep *prep, glp_prob *Q);
+/* build resultant problem instance */
+
+void glp_npp_postprocess(glp_prep *prep, glp_prob *Q);
+/* postprocess solution to resultant problem */
+
+void glp_npp_obtain_sol(glp_prep *prep, glp_prob *P);
+/* obtain solution to original problem */
+
+void glp_npp_free_wksp(glp_prep *prep);
+/* free the preprocessor workspace */
+#endif
+
+int glp_ios_reason(glp_tree *T);
+/* determine reason for calling the callback routine */
+
+glp_prob *glp_ios_get_prob(glp_tree *T);
+/* access the problem object */
+
+void glp_ios_tree_size(glp_tree *T, int *a_cnt, int *n_cnt,
+ int *t_cnt);
+/* determine size of the branch-and-bound tree */
+
+int glp_ios_curr_node(glp_tree *T);
+/* determine current active subproblem */
+
+int glp_ios_next_node(glp_tree *T, int p);
+/* determine next active subproblem */
+
+int glp_ios_prev_node(glp_tree *T, int p);
+/* determine previous active subproblem */
+
+int glp_ios_up_node(glp_tree *T, int p);
+/* determine parent subproblem */
+
+int glp_ios_node_level(glp_tree *T, int p);
+/* determine subproblem level */
+
+double glp_ios_node_bound(glp_tree *T, int p);
+/* determine subproblem local bound */
+
+int glp_ios_best_node(glp_tree *T);
+/* find active subproblem with best local bound */
+
+double glp_ios_mip_gap(glp_tree *T);
+/* compute relative MIP gap */
+
+void *glp_ios_node_data(glp_tree *T, int p);
+/* access subproblem application-specific data */
+
+void glp_ios_row_attr(glp_tree *T, int i, glp_attr *attr);
+/* retrieve additional row attributes */
+
+int glp_ios_pool_size(glp_tree *T);
+/* determine current size of the cut pool */
+
+int glp_ios_add_row(glp_tree *T,
+ const char *name, int klass, int flags, int len, const int ind[],
+ const double val[], int type, double rhs);
+/* add row (constraint) to the cut pool */
+
+void glp_ios_del_row(glp_tree *T, int i);
+/* remove row (constraint) from the cut pool */
+
+void glp_ios_clear_pool(glp_tree *T);
+/* remove all rows (constraints) from the cut pool */
+
+int glp_ios_can_branch(glp_tree *T, int j);
+/* check if can branch upon specified variable */
+
+void glp_ios_branch_upon(glp_tree *T, int j, int sel);
+/* choose variable to branch upon */
+
+void glp_ios_select_node(glp_tree *T, int p);
+/* select subproblem to continue the search */
+
+int glp_ios_heur_sol(glp_tree *T, const double x[]);
+/* provide solution found by heuristic */
+
+void glp_ios_terminate(glp_tree *T);
+/* terminate the solution process */
+
+#ifdef GLP_UNDOC
+int glp_gmi_cut(glp_prob *P, int j, int ind[], double val[], double
+ phi[]);
+/* generate Gomory's mixed integer cut (core routine) */
+
+int glp_gmi_gen(glp_prob *P, glp_prob *pool, int max_cuts);
+/* generate Gomory's mixed integer cuts */
+
+typedef struct glp_cov glp_cov;
+/* cover cur generator workspace */
+
+glp_cov *glp_cov_init(glp_prob *P);
+/* create and initialize cover cut generator */
+
+void glp_cov_gen1(glp_prob *P, glp_cov *cov, glp_prob *pool);
+/* generate locally valid simple cover cuts */
+
+void glp_cov_free(glp_cov *cov);
+/* delete cover cut generator workspace */
+
+typedef struct glp_mir glp_mir;
+/* MIR cut generator workspace */
+
+glp_mir *glp_mir_init(glp_prob *P);
+/* create and initialize MIR cut generator */
+
+int glp_mir_gen(glp_prob *P, glp_mir *mir, glp_prob *pool);
+/* generate mixed integer rounding (MIR) cuts */
+
+void glp_mir_free(glp_mir *mir);
+/* delete MIR cut generator workspace */
+
+typedef struct glp_cfg glp_cfg;
+/* conflict graph descriptor */
+
+glp_cfg *glp_cfg_init(glp_prob *P);
+/* create and initialize conflict graph */
+
+void glp_cfg_free(glp_cfg *G);
+/* delete conflict graph descriptor */
+
+int glp_clq_cut(glp_prob *P, glp_cfg *G, int ind[], double val[]);
+/* generate clique cut from conflict graph */
+#endif /* GLP_UNDOC */
+
+void glp_init_mpscp(glp_mpscp *parm);
+/* initialize MPS format control parameters */
+
+int glp_read_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+ const char *fname);
+/* read problem data in MPS format */
+
+int glp_write_mps(glp_prob *P, int fmt, const glp_mpscp *parm,
+ const char *fname);
+/* write problem data in MPS format */
+
+void glp_init_cpxcp(glp_cpxcp *parm);
+/* initialize CPLEX LP format control parameters */
+
+int glp_read_lp(glp_prob *P, const glp_cpxcp *parm, const char *fname);
+/* read problem data in CPLEX LP format */
+
+int glp_write_lp(glp_prob *P, const glp_cpxcp *parm, const char *fname);
+/* write problem data in CPLEX LP format */
+
+int glp_read_prob(glp_prob *P, int flags, const char *fname);
+/* read problem data in GLPK format */
+
+int glp_write_prob(glp_prob *P, int flags, const char *fname);
+/* write problem data in GLPK format */
+
+glp_tran *glp_mpl_alloc_wksp(void);
+/* allocate the MathProg translator workspace */
+
+void glp_mpl_init_rand(glp_tran *tran, int seed);
+/* initialize pseudo-random number generator */
+
+int glp_mpl_read_model(glp_tran *tran, const char *fname, int skip);
+/* read and translate model section */
+
+int glp_mpl_read_data(glp_tran *tran, const char *fname);
+/* read and translate data section */
+
+int glp_mpl_generate(glp_tran *tran, const char *fname);
+/* generate the model */
+
+void glp_mpl_build_prob(glp_tran *tran, glp_prob *prob);
+/* build LP/MIP problem instance from the model */
+
+int glp_mpl_postsolve(glp_tran *tran, glp_prob *prob, int sol);
+/* postsolve the model */
+
+void glp_mpl_free_wksp(glp_tran *tran);
+/* free the MathProg translator workspace */
+
+int glp_read_cnfsat(glp_prob *P, const char *fname);
+/* read CNF-SAT problem data in DIMACS format */
+
+int glp_check_cnfsat(glp_prob *P);
+/* check for CNF-SAT problem instance */
+
+int glp_write_cnfsat(glp_prob *P, const char *fname);
+/* write CNF-SAT problem data in DIMACS format */
+
+int glp_minisat1(glp_prob *P);
+/* solve CNF-SAT problem with MiniSat solver */
+
+int glp_intfeas1(glp_prob *P, int use_bound, int obj_bound);
+/* solve integer feasibility problem */
+
+int glp_init_env(void);
+/* initialize GLPK environment */
+
+const char *glp_version(void);
+/* determine library version */
+
+const char *glp_config(const char *option);
+/* determine library configuration */
+
+int glp_free_env(void);
+/* free GLPK environment */
+
+void glp_puts(const char *s);
+/* write string on terminal */
+
+void glp_printf(const char *fmt, ...);
+/* write formatted output on terminal */
+
+void glp_vprintf(const char *fmt, va_list arg);
+/* write formatted output on terminal */
+
+int glp_term_out(int flag);
+/* enable/disable terminal output */
+
+void glp_term_hook(int (*func)(void *info, const char *s), void *info);
+/* install hook to intercept terminal output */
+
+int glp_open_tee(const char *name);
+/* start copying terminal output to text file */
+
+int glp_close_tee(void);
+/* stop copying terminal output to text file */
+
+#ifndef GLP_ERRFUNC_DEFINED
+#define GLP_ERRFUNC_DEFINED
+typedef void (*glp_errfunc)(const char *fmt, ...);
+#endif
+
+#define glp_error glp_error_(__FILE__, __LINE__)
+glp_errfunc glp_error_(const char *file, int line);
+/* display fatal error message and terminate execution */
+
+#if 1 /* 07/XI-2015 */
+int glp_at_error(void);
+/* check for error state */
+#endif
+
+#define glp_assert(expr) \
+ ((void)((expr) || (glp_assert_(#expr, __FILE__, __LINE__), 1)))
+void glp_assert_(const char *expr, const char *file, int line);
+/* check for logical condition */
+
+void glp_error_hook(void (*func)(void *info), void *info);
+/* install hook to intercept abnormal termination */
+
+#define glp_malloc(size) glp_alloc(1, size)
+/* allocate memory block (obsolete) */
+
+#define glp_calloc(n, size) glp_alloc(n, size)
+/* allocate memory block (obsolete) */
+
+void *glp_alloc(int n, int size);
+/* allocate memory block */
+
+void *glp_realloc(void *ptr, int n, int size);
+/* reallocate memory block */
+
+void glp_free(void *ptr);
+/* free (deallocate) memory block */
+
+void glp_mem_limit(int limit);
+/* set memory usage limit */
+
+void glp_mem_usage(int *count, int *cpeak, size_t *total,
+ size_t *tpeak);
+/* get memory usage information */
+
+double glp_time(void);
+/* determine current universal time */
+
+double glp_difftime(double t1, double t0);
+/* compute difference between two time values */
+
+typedef struct glp_graph glp_graph;
+typedef struct glp_vertex glp_vertex;
+typedef struct glp_arc glp_arc;
+
+struct glp_graph
+{ /* graph descriptor */
+ void *pool; /* DMP *pool; */
+ /* memory pool to store graph components */
+ char *name;
+ /* graph name (1 to 255 chars); NULL means no name is assigned
+ to the graph */
+ int nv_max;
+ /* length of the vertex list (enlarged automatically) */
+ int nv;
+ /* number of vertices in the graph, 0 <= nv <= nv_max */
+ int na;
+ /* number of arcs in the graph, na >= 0 */
+ glp_vertex **v; /* glp_vertex *v[1+nv_max]; */
+ /* v[i], 1 <= i <= nv, is a pointer to i-th vertex */
+ void *index; /* AVL *index; */
+ /* vertex index to find vertices by their names; NULL means the
+ index does not exist */
+ int v_size;
+ /* size of data associated with each vertex (0 to 256 bytes) */
+ int a_size;
+ /* size of data associated with each arc (0 to 256 bytes) */
+};
+
+struct glp_vertex
+{ /* vertex descriptor */
+ int i;
+ /* vertex ordinal number, 1 <= i <= nv */
+ char *name;
+ /* vertex name (1 to 255 chars); NULL means no name is assigned
+ to the vertex */
+ void *entry; /* AVLNODE *entry; */
+ /* pointer to corresponding entry in the vertex index; NULL means
+ that either the index does not exist or the vertex has no name
+ assigned */
+ void *data;
+ /* pointer to data associated with the vertex */
+ void *temp;
+ /* working pointer */
+ glp_arc *in;
+ /* pointer to the (unordered) list of incoming arcs */
+ glp_arc *out;
+ /* pointer to the (unordered) list of outgoing arcs */
+};
+
+struct glp_arc
+{ /* arc descriptor */
+ glp_vertex *tail;
+ /* pointer to the tail endpoint */
+ glp_vertex *head;
+ /* pointer to the head endpoint */
+ void *data;
+ /* pointer to data associated with the arc */
+ void *temp;
+ /* working pointer */
+ glp_arc *t_prev;
+ /* pointer to previous arc having the same tail endpoint */
+ glp_arc *t_next;
+ /* pointer to next arc having the same tail endpoint */
+ glp_arc *h_prev;
+ /* pointer to previous arc having the same head endpoint */
+ glp_arc *h_next;
+ /* pointer to next arc having the same head endpoint */
+};
+
+glp_graph *glp_create_graph(int v_size, int a_size);
+/* create graph */
+
+void glp_set_graph_name(glp_graph *G, const char *name);
+/* assign (change) graph name */
+
+int glp_add_vertices(glp_graph *G, int nadd);
+/* add new vertices to graph */
+
+void glp_set_vertex_name(glp_graph *G, int i, const char *name);
+/* assign (change) vertex name */
+
+glp_arc *glp_add_arc(glp_graph *G, int i, int j);
+/* add new arc to graph */
+
+void glp_del_vertices(glp_graph *G, int ndel, const int num[]);
+/* delete vertices from graph */
+
+void glp_del_arc(glp_graph *G, glp_arc *a);
+/* delete arc from graph */
+
+void glp_erase_graph(glp_graph *G, int v_size, int a_size);
+/* erase graph content */
+
+void glp_delete_graph(glp_graph *G);
+/* delete graph */
+
+void glp_create_v_index(glp_graph *G);
+/* create vertex name index */
+
+int glp_find_vertex(glp_graph *G, const char *name);
+/* find vertex by its name */
+
+void glp_delete_v_index(glp_graph *G);
+/* delete vertex name index */
+
+int glp_read_graph(glp_graph *G, const char *fname);
+/* read graph from plain text file */
+
+int glp_write_graph(glp_graph *G, const char *fname);
+/* write graph to plain text file */
+
+void glp_mincost_lp(glp_prob *P, glp_graph *G, int names, int v_rhs,
+ int a_low, int a_cap, int a_cost);
+/* convert minimum cost flow problem to LP */
+
+int glp_mincost_okalg(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, double *sol, int a_x, int v_pi);
+/* find minimum-cost flow with out-of-kilter algorithm */
+
+int glp_mincost_relax4(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, int crash, double *sol, int a_x, int a_rc);
+/* find minimum-cost flow with Bertsekas-Tseng relaxation method */
+
+void glp_maxflow_lp(glp_prob *P, glp_graph *G, int names, int s,
+ int t, int a_cap);
+/* convert maximum flow problem to LP */
+
+int glp_maxflow_ffalg(glp_graph *G, int s, int t, int a_cap,
+ double *sol, int a_x, int v_cut);
+/* find maximal flow with Ford-Fulkerson algorithm */
+
+int glp_check_asnprob(glp_graph *G, int v_set);
+/* check correctness of assignment problem data */
+
+/* assignment problem formulation: */
+#define GLP_ASN_MIN 1 /* perfect matching (minimization) */
+#define GLP_ASN_MAX 2 /* perfect matching (maximization) */
+#define GLP_ASN_MMP 3 /* maximum matching */
+
+int glp_asnprob_lp(glp_prob *P, int form, glp_graph *G, int names,
+ int v_set, int a_cost);
+/* convert assignment problem to LP */
+
+int glp_asnprob_okalg(int form, glp_graph *G, int v_set, int a_cost,
+ double *sol, int a_x);
+/* solve assignment problem with out-of-kilter algorithm */
+
+int glp_asnprob_hall(glp_graph *G, int v_set, int a_x);
+/* find bipartite matching of maximum cardinality */
+
+double glp_cpp(glp_graph *G, int v_t, int v_es, int v_ls);
+/* solve critical path problem */
+
+int glp_read_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, const char *fname);
+/* read min-cost flow problem data in DIMACS format */
+
+int glp_write_mincost(glp_graph *G, int v_rhs, int a_low, int a_cap,
+ int a_cost, const char *fname);
+/* write min-cost flow problem data in DIMACS format */
+
+int glp_read_maxflow(glp_graph *G, int *s, int *t, int a_cap,
+ const char *fname);
+/* read maximum flow problem data in DIMACS format */
+
+int glp_write_maxflow(glp_graph *G, int s, int t, int a_cap,
+ const char *fname);
+/* write maximum flow problem data in DIMACS format */
+
+int glp_read_asnprob(glp_graph *G, int v_set, int a_cost, const char
+ *fname);
+/* read assignment problem data in DIMACS format */
+
+int glp_write_asnprob(glp_graph *G, int v_set, int a_cost, const char
+ *fname);
+/* write assignment problem data in DIMACS format */
+
+int glp_read_ccdata(glp_graph *G, int v_wgt, const char *fname);
+/* read graph in DIMACS clique/coloring format */
+
+int glp_write_ccdata(glp_graph *G, int v_wgt, const char *fname);
+/* write graph in DIMACS clique/coloring format */
+
+int glp_netgen(glp_graph *G, int v_rhs, int a_cap, int a_cost,
+ const int parm[1+15]);
+/* Klingman's network problem generator */
+
+void glp_netgen_prob(int nprob, int parm[1+15]);
+/* Klingman's standard network problem instance */
+
+int glp_gridgen(glp_graph *G, int v_rhs, int a_cap, int a_cost,
+ const int parm[1+14]);
+/* grid-like network problem generator */
+
+int glp_rmfgen(glp_graph *G, int *s, int *t, int a_cap,
+ const int parm[1+5]);
+/* Goldfarb's maximum flow problem generator */
+
+int glp_weak_comp(glp_graph *G, int v_num);
+/* find all weakly connected components of graph */
+
+int glp_strong_comp(glp_graph *G, int v_num);
+/* find all strongly connected components of graph */
+
+int glp_top_sort(glp_graph *G, int v_num);
+/* topological sorting of acyclic digraph */
+
+int glp_wclique_exact(glp_graph *G, int v_wgt, double *sol, int v_set);
+/* find maximum weight clique with exact algorithm */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/cfg.c b/test/monniaux/glpk-4.65/src/intopt/cfg.c
new file mode 100644
index 00000000..ab73b2da
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/cfg.c
@@ -0,0 +1,409 @@
+/* cfg.c (conflict graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "cfg.h"
+#include "env.h"
+
+/***********************************************************************
+* cfg_create_graph - create conflict graph
+*
+* This routine creates the conflict graph, which initially is empty,
+* and returns a pointer to the graph descriptor.
+*
+* The parameter n specifies the number of *all* variables in MIP, for
+* which the conflict graph will be built.
+*
+* The parameter nv_max specifies maximal number of vertices in the
+* conflict graph. It should be the double number of binary variables
+* in corresponding MIP. */
+
+CFG *cfg_create_graph(int n, int nv_max)
+{ CFG *G;
+ xassert(n >= 0);
+ xassert(0 <= nv_max && nv_max <= n + n);
+ G = talloc(1, CFG);
+ G->n = n;
+ G->pos = talloc(1+n, int);
+ memset(&G->pos[1], 0, n * sizeof(int));
+ G->neg = talloc(1+n, int);
+ memset(&G->neg[1], 0, n * sizeof(int));
+ G->pool = dmp_create_pool();
+ G->nv_max = nv_max;
+ G->nv = 0;
+ G->ref = talloc(1+nv_max, int);
+ G->vptr = talloc(1+nv_max, CFGVLE *);
+ G->cptr = talloc(1+nv_max, CFGCLE *);
+ return G;
+}
+
+/***********************************************************************
+* cfg_add_clique - add clique to conflict graph
+*
+* This routine adds a clique to the conflict graph.
+*
+* The parameter size specifies the clique size, size >= 2. Note that
+* any edge can be considered as a clique of size 2.
+*
+* The array ind specifies vertices constituting the clique in elements
+* ind[k], 1 <= k <= size:
+*
+* ind[k] = +j means a vertex of the conflict graph that corresponds to
+* original binary variable x[j], 1 <= j <= n.
+*
+* ind[k] = -j means a vertex of the conflict graph that corresponds to
+* complement of original binary variable x[j], 1 <= j <= n.
+*
+* Note that if both vertices for x[j] and (1 - x[j]) have appeared in
+* the conflict graph, the routine automatically adds an edge incident
+* to these vertices. */
+
+static void add_edge(CFG *G, int v, int w)
+{ /* add clique of size 2 */
+ DMP *pool = G->pool;
+ int nv = G->nv;
+ CFGVLE **vptr = G->vptr;
+ CFGVLE *vle;
+ xassert(1 <= v && v <= nv);
+ xassert(1 <= w && w <= nv);
+ xassert(v != w);
+ vle = dmp_talloc(pool, CFGVLE);
+ vle->v = w;
+ vle->next = vptr[v];
+ vptr[v] = vle;
+ vle = dmp_talloc(pool, CFGVLE);
+ vle->v = v;
+ vle->next = vptr[w];
+ vptr[w] = vle;
+ return;
+}
+
+void cfg_add_clique(CFG *G, int size, const int ind[])
+{ int n = G->n;
+ int *pos = G->pos;
+ int *neg = G->neg;
+ DMP *pool = G->pool;
+ int nv_max = G->nv_max;
+ int *ref = G->ref;
+ CFGVLE **vptr = G->vptr;
+ CFGCLE **cptr = G->cptr;
+ int j, k, v;
+ xassert(2 <= size && size <= nv_max);
+ /* add new vertices to the conflict graph */
+ for (k = 1; k <= size; k++)
+ { j = ind[k];
+ if (j > 0)
+ { /* vertex corresponds to x[j] */
+ xassert(1 <= j && j <= n);
+ if (pos[j] == 0)
+ { /* no such vertex exists; add it */
+ v = pos[j] = ++(G->nv);
+ xassert(v <= nv_max);
+ ref[v] = j;
+ vptr[v] = NULL;
+ cptr[v] = NULL;
+ if (neg[j] != 0)
+ { /* now both vertices for x[j] and (1 - x[j]) exist */
+ add_edge(G, v, neg[j]);
+ }
+ }
+ }
+ else
+ { /* vertex corresponds to (1 - x[j]) */
+ j = -j;
+ xassert(1 <= j && j <= n);
+ if (neg[j] == 0)
+ { /* no such vertex exists; add it */
+ v = neg[j] = ++(G->nv);
+ xassert(v <= nv_max);
+ ref[v] = j;
+ vptr[v] = NULL;
+ cptr[v] = NULL;
+ if (pos[j] != 0)
+ { /* now both vertices for x[j] and (1 - x[j]) exist */
+ add_edge(G, v, pos[j]);
+ }
+ }
+ }
+ }
+ /* add specified clique to the conflict graph */
+ if (size == 2)
+ add_edge(G,
+ ind[1] > 0 ? pos[+ind[1]] : neg[-ind[1]],
+ ind[2] > 0 ? pos[+ind[2]] : neg[-ind[2]]);
+ else
+ { CFGVLE *vp, *vle;
+ CFGCLE *cle;
+ /* build list of clique vertices */
+ vp = NULL;
+ for (k = 1; k <= size; k++)
+ { vle = dmp_talloc(pool, CFGVLE);
+ vle->v = ind[k] > 0 ? pos[+ind[k]] : neg[-ind[k]];
+ vle->next = vp;
+ vp = vle;
+ }
+ /* attach the clique to all its vertices */
+ for (k = 1; k <= size; k++)
+ { cle = dmp_talloc(pool, CFGCLE);
+ cle->vptr = vp;
+ v = ind[k] > 0 ? pos[+ind[k]] : neg[-ind[k]];
+ cle->next = cptr[v];
+ cptr[v] = cle;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* cfg_get_adjacent - get vertices adjacent to specified vertex
+*
+* This routine stores numbers of all vertices adjacent to specified
+* vertex v of the conflict graph in locations ind[1], ..., ind[len],
+* and returns len, 1 <= len <= nv-1, where nv is the total number of
+* vertices in the conflict graph.
+*
+* Note that the conflict graph defined by this routine has neither
+* self-loops nor multiple edges. */
+
+int cfg_get_adjacent(CFG *G, int v, int ind[])
+{ int nv = G->nv;
+ int *ref = G->ref;
+ CFGVLE **vptr = G->vptr;
+ CFGCLE **cptr = G->cptr;
+ CFGVLE *vle;
+ CFGCLE *cle;
+ int k, w, len;
+ xassert(1 <= v && v <= nv);
+ len = 0;
+ /* walk thru the list of adjacent vertices */
+ for (vle = vptr[v]; vle != NULL; vle = vle->next)
+ { w = vle->v;
+ xassert(1 <= w && w <= nv);
+ xassert(w != v);
+ if (ref[w] > 0)
+ { ind[++len] = w;
+ ref[w] = -ref[w];
+ }
+ }
+ /* walk thru the list of incident cliques */
+ for (cle = cptr[v]; cle != NULL; cle = cle->next)
+ { /* walk thru the list of clique vertices */
+ for (vle = cle->vptr; vle != NULL; vle = vle->next)
+ { w = vle->v;
+ xassert(1 <= w && w <= nv);
+ if (w != v && ref[w] > 0)
+ { ind[++len] = w;
+ ref[w] = -ref[w];
+ }
+ }
+ }
+ xassert(1 <= len && len < nv);
+ /* unmark vertices included in the resultant adjacency list */
+ for (k = 1; k <= len; k++)
+ { w = ind[k];
+ ref[w] = -ref[w];
+ }
+ return len;
+}
+
+/***********************************************************************
+* cfg_expand_clique - expand specified clique to maximal clique
+*
+* Given some clique in the conflict graph this routine expands it to
+* a maximal clique by including in it new vertices.
+*
+* On entry vertex indices constituting the initial clique should be
+* stored in locations c_ind[1], ..., c_ind[c_len], where c_len is the
+* initial clique size. On exit the routine stores new vertex indices
+* to locations c_ind[c_len+1], ..., c_ind[c_len'], where c_len' is the
+* size of the maximal clique found, and returns c_len'.
+*
+* ALGORITHM
+*
+* Let G = (V, E) be a graph, C within V be a current clique to be
+* expanded, and D within V \ C be a subset of vertices adjacent to all
+* vertices from C. On every iteration the routine chooses some vertex
+* v in D, includes it into C, and removes from D the vertex v as well
+* as all vertices not adjacent to v. Initially C is empty and D = V.
+* Iterations repeat until D becomes an empty set. Obviously, the final
+* set C is a maximal clique in G.
+*
+* Now let C0 be an initial clique, and we want C0 to be a subset of
+* the final maximal clique C. To provide this condition the routine
+* starts constructing C by choosing only such vertices v in D, which
+* are in C0, until all vertices from C0 have been included in C. May
+* note that if on some iteration C0 \ C is non-empty (i.e. if not all
+* vertices from C0 have been included in C), C0 \ C is a subset of D,
+* because C0 is a clique. */
+
+static int intersection(int d_len, int d_ind[], int d_pos[], int len,
+ const int ind[])
+{ /* compute intersection D := D inter W, where W is some specified
+ * set of vertices */
+ int k, t, v, new_len;
+ /* walk thru vertices in W and mark vertices in D */
+ for (t = 1; t <= len; t++)
+ { /* v in W */
+ v = ind[t];
+ /* determine position of v in D */
+ k = d_pos[v];
+ if (k != 0)
+ { /* v in D */
+ xassert(d_ind[k] == v);
+ /* mark v to keep it in D */
+ d_ind[k] = -v;
+ }
+ }
+ /* remove all unmarked vertices from D */
+ new_len = 0;
+ for (k = 1; k <= d_len; k++)
+ { /* v in D */
+ v = d_ind[k];
+ if (v < 0)
+ { /* v is marked; keep it */
+ v = -v;
+ new_len++;
+ d_ind[new_len] = v;
+ d_pos[v] = new_len;
+ }
+ else
+ { /* v is not marked; remove it */
+ d_pos[v] = 0;
+ }
+ }
+ return new_len;
+}
+
+int cfg_expand_clique(CFG *G, int c_len, int c_ind[])
+{ int nv = G->nv;
+ int d_len, *d_ind, *d_pos, len, *ind;
+ int k, v;
+ xassert(0 <= c_len && c_len <= nv);
+ /* allocate working arrays */
+ d_ind = talloc(1+nv, int);
+ d_pos = talloc(1+nv, int);
+ ind = talloc(1+nv, int);
+ /* initialize C := 0, D := V */
+ d_len = nv;
+ for (k = 1; k <= nv; k++)
+ d_ind[k] = d_pos[k] = k;
+ /* expand C by vertices of specified initial clique C0 */
+ for (k = 1; k <= c_len; k++)
+ { /* v in C0 */
+ v = c_ind[k];
+ xassert(1 <= v && v <= nv);
+ /* since C0 is clique, v should be in D */
+ xassert(d_pos[v] != 0);
+ /* W := set of vertices adjacent to v */
+ len = cfg_get_adjacent(G, v, ind);
+ /* D := D inter W */
+ d_len = intersection(d_len, d_ind, d_pos, len, ind);
+ /* since v not in W, now v should be not in D */
+ xassert(d_pos[v] == 0);
+ }
+ /* expand C by some other vertices until D is empty */
+ while (d_len > 0)
+ { /* v in D */
+ v = d_ind[1];
+ xassert(1 <= v && v <= nv);
+ /* note that v is adjacent to all vertices in C (by design),
+ * so add v to C */
+ c_ind[++c_len] = v;
+ /* W := set of vertices adjacent to v */
+ len = cfg_get_adjacent(G, v, ind);
+ /* D := D inter W */
+ d_len = intersection(d_len, d_ind, d_pos, len, ind);
+ /* since v not in W, now v should be not in D */
+ xassert(d_pos[v] == 0);
+ }
+ /* free working arrays */
+ tfree(d_ind);
+ tfree(d_pos);
+ tfree(ind);
+ /* bring maximal clique to calling routine */
+ return c_len;
+}
+
+/***********************************************************************
+* cfg_check_clique - check clique in conflict graph
+*
+* This routine checks that vertices of the conflict graph specified
+* in locations c_ind[1], ..., c_ind[c_len] constitute a clique.
+*
+* NOTE: for testing/debugging only. */
+
+void cfg_check_clique(CFG *G, int c_len, const int c_ind[])
+{ int nv = G->nv;
+ int k, kk, v, w, len, *ind;
+ char *flag;
+ ind = talloc(1+nv, int);
+ flag = talloc(1+nv, char);
+ memset(&flag[1], 0, nv);
+ /* walk thru clique vertices */
+ xassert(c_len >= 0);
+ for (k = 1; k <= c_len; k++)
+ { /* get clique vertex v */
+ v = c_ind[k];
+ xassert(1 <= v && v <= nv);
+ /* get vertices adjacent to vertex v */
+ len = cfg_get_adjacent(G, v, ind);
+ for (kk = 1; kk <= len; kk++)
+ { w = ind[kk];
+ xassert(1 <= w && w <= nv);
+ xassert(w != v);
+ flag[w] = 1;
+ }
+ /* check that all clique vertices other than v are adjacent
+ to v */
+ for (kk = 1; kk <= c_len; kk++)
+ { w = c_ind[kk];
+ xassert(1 <= w && w <= nv);
+ if (w != v)
+ xassert(flag[w]);
+ }
+ /* reset vertex flags */
+ for (kk = 1; kk <= len; kk++)
+ flag[ind[kk]] = 0;
+ }
+ tfree(ind);
+ tfree(flag);
+ return;
+}
+
+/***********************************************************************
+* cfg_delete_graph - delete conflict graph
+*
+* This routine deletes the conflict graph by freeing all the memory
+* allocated to this program object. */
+
+void cfg_delete_graph(CFG *G)
+{ tfree(G->pos);
+ tfree(G->neg);
+ dmp_delete_pool(G->pool);
+ tfree(G->ref);
+ tfree(G->vptr);
+ tfree(G->cptr);
+ tfree(G);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/cfg.h b/test/monniaux/glpk-4.65/src/intopt/cfg.h
new file mode 100644
index 00000000..d478f6c0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/cfg.h
@@ -0,0 +1,138 @@
+/* cfg.h (conflict graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef CFG_H
+#define CFG_H
+
+#include "dmp.h"
+
+/***********************************************************************
+* The structure CFG describes the conflict graph.
+*
+* Conflict graph is an undirected graph G = (V, E), where V is a set
+* of vertices, E <= V x V is a set of edges. Each vertex v in V of the
+* conflict graph corresponds to a binary variable z[v], which is
+* either an original binary variable x[j] or its complement 1 - x[j].
+* Edge (v,w) in E means that z[v] and z[w] cannot take the value 1 at
+* the same time, i.e. it defines an inequality z[v] + z[w] <= 1, which
+* is assumed to be valid for original MIP.
+*
+* Since the conflict graph may be dense, it is stored as an union of
+* its cliques rather than explicitly. */
+
+#if 0 /* 08/III-2016 */
+typedef struct CFG CFG;
+#else
+typedef struct glp_cfg CFG;
+#endif
+typedef struct CFGVLE CFGVLE;
+typedef struct CFGCLE CFGCLE;
+
+#if 0 /* 08/III-2016 */
+struct CFG
+#else
+struct glp_cfg
+#endif
+{ /* conflict graph descriptor */
+ int n;
+ /* number of *all* variables (columns) in corresponding MIP */
+ int *pos; /* int pos[1+n]; */
+ /* pos[0] is not used;
+ * pos[j] = v, 1 <= j <= n, means that vertex v corresponds to
+ * original binary variable x[j], and pos[j] = 0 means that the
+ * conflict graph has no such vertex */
+ int *neg; /* int neg[1+n]; */
+ /* neg[0] is not used;
+ * neg[j] = v, 1 <= j <= n, means that vertex v corresponds to
+ * complement of original binary variable x[j], and neg[j] = 0
+ * means that the conflict graph has no such vertex */
+ DMP *pool;
+ /* memory pool to allocate elements of the conflict graph */
+ int nv_max;
+ /* maximal number of vertices in the conflict graph */
+ int nv;
+ /* current number of vertices in the conflict graph */
+ int *ref; /* int ref[1+nv_max]; */
+ /* ref[v] = j, 1 <= v <= nv, means that vertex v corresponds
+ * either to original binary variable x[j] or to its complement,
+ * i.e. either pos[j] = v or neg[j] = v */
+ CFGVLE **vptr; /* CFGVLE *vptr[1+nv_max]; */
+ /* vptr[v], 1 <= v <= nv, is an initial pointer to the list of
+ * vertices adjacent to vertex v */
+ CFGCLE **cptr; /* CFGCLE *cptr[1+nv_max]; */
+ /* cptr[v], 1 <= v <= nv, is an initial pointer to the list of
+ * cliques that contain vertex v */
+};
+
+struct CFGVLE
+{ /* vertex list element */
+ int v;
+ /* vertex number, 1 <= v <= nv */
+ CFGVLE *next;
+ /* pointer to next vertex list element */
+};
+
+struct CFGCLE
+{ /* clique list element */
+ CFGVLE *vptr;
+ /* initial pointer to the list of clique vertices */
+ CFGCLE *next;
+ /* pointer to next clique list element */
+};
+
+#define cfg_create_graph _glp_cfg_create_graph
+CFG *cfg_create_graph(int n, int nv_max);
+/* create conflict graph */
+
+#define cfg_add_clique _glp_cfg_add_clique
+void cfg_add_clique(CFG *G, int size, const int ind[]);
+/* add clique to conflict graph */
+
+#define cfg_get_adjacent _glp_cfg_get_adjacent
+int cfg_get_adjacent(CFG *G, int v, int ind[]);
+/* get vertices adjacent to specified vertex */
+
+#define cfg_expand_clique _glp_cfg_expand_clique
+int cfg_expand_clique(CFG *G, int c_len, int c_ind[]);
+/* expand specified clique to maximal clique */
+
+#define cfg_check_clique _glp_cfg_check_clique
+void cfg_check_clique(CFG *G, int c_len, const int c_ind[]);
+/* check clique in conflict graph */
+
+#define cfg_delete_graph _glp_cfg_delete_graph
+void cfg_delete_graph(CFG *G);
+/* delete conflict graph */
+
+#define cfg_build_graph _glp_cfg_build_graph
+CFG *cfg_build_graph(void /* glp_prob */ *P);
+/* build conflict graph */
+
+#define cfg_find_clique _glp_cfg_find_clique
+int cfg_find_clique(void /* glp_prob */ *P, CFG *G, int ind[],
+ double *sum);
+/* find maximum weight clique in conflict graph */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/cfg1.c b/test/monniaux/glpk-4.65/src/intopt/cfg1.c
new file mode 100644
index 00000000..80a2e834
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/cfg1.c
@@ -0,0 +1,703 @@
+/* cfg1.c (conflict graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "cfg.h"
+#include "env.h"
+#include "prob.h"
+#include "wclique.h"
+#include "wclique1.h"
+
+/***********************************************************************
+* cfg_build_graph - build conflict graph
+*
+* This routine builds the conflict graph. It analyzes the specified
+* problem object to discover original and implied packing inequalities
+* and adds corresponding cliques to the conflict graph.
+*
+* Packing inequality has the form:
+*
+* sum z[j] <= 1, (1)
+* j in J
+*
+* where z[j] = x[j] or z[j] = 1 - x[j], x[j] is an original binary
+* variable. Every packing inequality (1) is equivalent to a set of
+* edge inequalities:
+*
+* z[i] + z[j] <= 1 for all i, j in J, i != j, (2)
+*
+* and since every edge inequality (2) defines an edge in the conflict
+* graph, corresponding packing inequality (1) defines a clique.
+*
+* To discover packing inequalities the routine analyzes constraints
+* of the specified MIP. To simplify the analysis each constraint is
+* analyzed separately. The analysis is performed as follows.
+*
+* Let some original constraint be the following:
+*
+* L <= sum a[j] x[j] <= U. (3)
+*
+* To analyze it the routine analyzes two constraints of "not greater
+* than" type:
+*
+* sum (-a[j]) x[j] <= -L, (4)
+*
+* sum (+a[j]) x[j] <= +U, (5)
+*
+* which are relaxations of the original constraint (3). (If, however,
+* L = -oo, or U = +oo, corresponding constraint being redundant is not
+* analyzed.)
+*
+* Let a constraint of "not greater than" type be the following:
+*
+* sum a[j] x[j] + sum a[j] x[j] <= b, (6)
+* j in J j in J'
+*
+* where J is a subset of binary variables, J' is a subset of other
+* (continues and non-binary integer) variables. The constraint (6) is
+* is relaxed as follows, to eliminate non-binary variables:
+*
+* sum a[j] x[j] <= b - sum a[j] x[j] <= b', (7)
+* j in J j in J'
+*
+* b' = sup(b - sum a[j] x[j]) =
+* j in J'
+*
+* = b - inf(sum a[j] x[j]) =
+*
+* = b - sum inf(a[j] x[j]) = (8)
+*
+* = b - sum a[j] inf(x[j]) - sum a[j] sup(x[j]) =
+* a[j]>0 a[j]<0
+*
+* = b - sum a[j] l[j] - sum a[j] u[j],
+* a[j]>0 a[j]<0
+*
+* where l[j] and u[j] are, resp., lower and upper bounds of x[j].
+*
+* Then the routine transforms the relaxed constraint containing only
+* binary variables:
+*
+* sum a[j] x[j] <= b (9)
+*
+* to an equivalent 0-1 knapsack constraint as follows:
+*
+* sum a[j] x[j] + sum a[j] x[j] <= b ==>
+* a[j]>0 a[j]<0
+*
+* sum a[j] x[j] + sum a[j] (1 - x[j]) <= b ==>
+* a[j]>0 a[j]<0 (10)
+*
+* sum (+a[j]) x[j] + sum (-a[j]) x[j] <= b + sum (-a[j]) ==>
+* a[j]>0 a[j]<0 a[j]<0
+*
+* sum a'[j] z[j] <= b',
+*
+* where a'[j] = |a[j]| > 0, and
+*
+* ( x[j] if a[j] > 0
+* z[j] = <
+* ( 1 - x[j] if a[j] < 0
+*
+* is a binary variable, which is either original binary variable x[j]
+* or its complement.
+*
+* Finally, the routine analyzes the resultant 0-1 knapsack inequality:
+*
+* sum a[j] z[j] <= b, (11)
+* j in J
+*
+* where all a[j] are positive, to discover clique inequalities (1),
+* which are valid for (11) and therefore valid for (3). (It is assumed
+* that the original MIP has been preprocessed, so it is not checked,
+* for example, that b > 0 or that a[j] <= b.)
+*
+* In principle, to discover any edge inequalities valid for (11) it
+* is sufficient to check whether a[i] + a[j] > b for all i, j in J,
+* i < j. However, this way requires O(|J|^2) checks, so the routine
+* analyses (11) in the following way, which is much more efficient in
+* many practical cases.
+*
+* 1. Let a[p] and a[q] be two minimal coefficients:
+*
+* a[p] = min a[j], (12)
+*
+* a[q] = min a[j], j != p, (13)
+*
+* such that
+*
+* a[p] + a[q] > b. (14)
+*
+* This means that a[i] + a[j] > b for any i, j in J, i != j, so
+*
+* z[i] + z[j] <= 1 (15)
+*
+* are valid for (11) for any i, j in J, i != j. This case means that
+* J define a clique in the conflict graph.
+*
+* 2. Otherwise, let a[p] and [q] be two maximal coefficients:
+*
+* a[p] = max a[j], (16)
+*
+* a[q] = max a[j], j != p, (17)
+*
+* such that
+*
+* a[p] + a[q] <= b. (18)
+*
+* This means that a[i] + a[j] <= b for any i, j in J, i != j, so in
+* this case no valid edge inequalities for (11) exist.
+*
+* 3. Otherwise, let all a[j] be ordered by descending their values:
+*
+* a[1] >= a[2] >= ... >= a[p-1] >= a[p] >= a[p+1] >= ... (19)
+*
+* where p is such that
+*
+* a[p-1] + a[p] > b, (20)
+*
+* a[p] + a[p+1] <= b. (21)
+*
+* (May note that due to the former two cases in this case we always
+* have 2 <= p <= |J|-1.)
+*
+* Since a[p] and a[p-1] are two minimal coefficients in the set
+* J' = {1, ..., p}, J' define a clique in the conflict graph for the
+* same reason as in the first case. Similarly, since a[p] and a[p+1]
+* are two maximal coefficients in the set J" = {p, ..., |J|}, no edge
+* inequalities exist for all i, j in J" for the same reason as in the
+* second case. Thus, to discover other edge inequalities (15) valid
+* for (11), the routine checks if a[i] + a[j] > b for all i in J',
+* j in J", i != j. */
+
+#define is_binary(j) \
+ (P->col[j]->kind == GLP_IV && P->col[j]->type == GLP_DB && \
+ P->col[j]->lb == 0.0 && P->col[j]->ub == 1.0)
+/* check if x[j] is binary variable */
+
+struct term { int ind; double val; };
+/* term a[j] * z[j] used to sort a[j]'s */
+
+static int CDECL fcmp(const void *e1, const void *e2)
+{ /* auxiliary routine called from qsort */
+ const struct term *t1 = e1, *t2 = e2;
+ if (t1->val > t2->val)
+ return -1;
+ else if (t1->val < t2->val)
+ return +1;
+ else
+ return 0;
+}
+
+static void analyze_ineq(glp_prob *P, CFG *G, int len, int ind[],
+ double val[], double rhs, struct term t[])
+{ /* analyze inequality constraint (6) */
+ /* P is the original MIP
+ * G is the conflict graph to be built
+ * len is the number of terms in the constraint
+ * ind[1], ..., ind[len] are indices of variables x[j]
+ * val[1], ..., val[len] are constraint coefficients a[j]
+ * rhs is the right-hand side b
+ * t[1+len] is a working array */
+ int j, k, kk, p, q, type, new_len;
+ /* eliminate non-binary variables; see (7) and (8) */
+ new_len = 0;
+ for (k = 1; k <= len; k++)
+ { /* get index of variable x[j] */
+ j = ind[k];
+ if (is_binary(j))
+ { /* x[j] remains in relaxed constraint */
+ new_len++;
+ ind[new_len] = j;
+ val[new_len] = val[k];
+ }
+ else if (val[k] > 0.0)
+ { /* eliminate non-binary x[j] in case a[j] > 0 */
+ /* b := b - a[j] * l[j]; see (8) */
+ type = P->col[j]->type;
+ if (type == GLP_FR || type == GLP_UP)
+ { /* x[j] has no lower bound */
+ goto done;
+ }
+ rhs -= val[k] * P->col[j]->lb;
+ }
+ else /* val[j] < 0.0 */
+ { /* eliminate non-binary x[j] in case a[j] < 0 */
+ /* b := b - a[j] * u[j]; see (8) */
+ type = P->col[j]->type;
+ if (type == GLP_FR || type == GLP_LO)
+ { /* x[j] has no upper bound */
+ goto done;
+ }
+ rhs -= val[k] * P->col[j]->ub;
+ }
+ }
+ len = new_len;
+ /* now we have the constraint (9) */
+ if (len <= 1)
+ { /* at least two terms are needed */
+ goto done;
+ }
+ /* make all constraint coefficients positive; see (10) */
+ for (k = 1; k <= len; k++)
+ { if (val[k] < 0.0)
+ { /* a[j] < 0; substitute x[j] = 1 - x'[j], where x'[j] is
+ * a complement binary variable */
+ ind[k] = -ind[k];
+ val[k] = -val[k];
+ rhs += val[k];
+ }
+ }
+ /* now we have 0-1 knapsack inequality (11) */
+ /* increase the right-hand side a bit to avoid false checks due
+ * to rounding errors */
+ rhs += 0.001 * (1.0 + fabs(rhs));
+ /*** first case ***/
+ /* find two minimal coefficients a[p] and a[q] */
+ p = 0;
+ for (k = 1; k <= len; k++)
+ { if (p == 0 || val[p] > val[k])
+ p = k;
+ }
+ q = 0;
+ for (k = 1; k <= len; k++)
+ { if (k != p && (q == 0 || val[q] > val[k]))
+ q = k;
+ }
+ xassert(p != 0 && q != 0 && p != q);
+ /* check condition (14) */
+ if (val[p] + val[q] > rhs)
+ { /* all z[j] define a clique in the conflict graph */
+ cfg_add_clique(G, len, ind);
+ goto done;
+ }
+ /*** second case ***/
+ /* find two maximal coefficients a[p] and a[q] */
+ p = 0;
+ for (k = 1; k <= len; k++)
+ { if (p == 0 || val[p] < val[k])
+ p = k;
+ }
+ q = 0;
+ for (k = 1; k <= len; k++)
+ { if (k != p && (q == 0 || val[q] < val[k]))
+ q = k;
+ }
+ xassert(p != 0 && q != 0 && p != q);
+ /* check condition (18) */
+ if (val[p] + val[q] <= rhs)
+ { /* no valid edge inequalities exist */
+ goto done;
+ }
+ /*** third case ***/
+ xassert(len >= 3);
+ /* sort terms in descending order of coefficient values */
+ for (k = 1; k <= len; k++)
+ { t[k].ind = ind[k];
+ t[k].val = val[k];
+ }
+ qsort(&t[1], len, sizeof(struct term), fcmp);
+ for (k = 1; k <= len; k++)
+ { ind[k] = t[k].ind;
+ val[k] = t[k].val;
+ }
+ /* now a[1] >= a[2] >= ... >= a[len-1] >= a[len] */
+ /* note that a[1] + a[2] > b and a[len-1] + a[len] <= b due two
+ * the former two cases */
+ xassert(val[1] + val[2] > rhs);
+ xassert(val[len-1] + val[len] <= rhs);
+ /* find p according to conditions (20) and (21) */
+ for (p = 2; p < len; p++)
+ { if (val[p] + val[p+1] <= rhs)
+ break;
+ }
+ xassert(p < len);
+ /* z[1], ..., z[p] define a clique in the conflict graph */
+ cfg_add_clique(G, p, ind);
+ /* discover other edge inequalities */
+ for (k = 1; k <= p; k++)
+ { for (kk = p; kk <= len; kk++)
+ { if (k != kk && val[k] + val[kk] > rhs)
+ { int iii[1+2];
+ iii[1] = ind[k];
+ iii[2] = ind[kk];
+ cfg_add_clique(G, 2, iii);
+ }
+ }
+ }
+done: return;
+}
+
+CFG *cfg_build_graph(void *P_)
+{ glp_prob *P = P_;
+ int m = P->m;
+ int n = P->n;
+ CFG *G;
+ int i, k, type, len, *ind;
+ double *val;
+ struct term *t;
+ /* create the conflict graph (number of its vertices cannot be
+ * greater than double number of binary variables) */
+ G = cfg_create_graph(n, 2 * glp_get_num_bin(P));
+ /* allocate working arrays */
+ ind = talloc(1+n, int);
+ val = talloc(1+n, double);
+ t = talloc(1+n, struct term);
+ /* analyze constraints to discover edge inequalities */
+ for (i = 1; i <= m; i++)
+ { type = P->row[i]->type;
+ if (type == GLP_LO || type == GLP_DB || type == GLP_FX)
+ { /* i-th row has lower bound */
+ /* analyze inequality sum (-a[j]) * x[j] <= -lb */
+ len = glp_get_mat_row(P, i, ind, val);
+ for (k = 1; k <= len; k++)
+ val[k] = -val[k];
+ analyze_ineq(P, G, len, ind, val, -P->row[i]->lb, t);
+ }
+ if (type == GLP_UP || type == GLP_DB || type == GLP_FX)
+ { /* i-th row has upper bound */
+ /* analyze inequality sum (+a[j]) * x[j] <= +ub */
+ len = glp_get_mat_row(P, i, ind, val);
+ analyze_ineq(P, G, len, ind, val, +P->row[i]->ub, t);
+ }
+ }
+ /* free working arrays */
+ tfree(ind);
+ tfree(val);
+ tfree(t);
+ return G;
+}
+
+/***********************************************************************
+* cfg_find_clique - find maximum weight clique in conflict graph
+*
+* This routine finds a maximum weight clique in the conflict graph
+* G = (V, E), where the weight of vertex v in V is the value of
+* corresponding binary variable z (which is either an original binary
+* variable or its complement) in the optimal solution to LP relaxation
+* provided in the problem object. The goal is to find a clique in G,
+* whose weight is greater than 1, in which case corresponding packing
+* inequality is violated at the optimal point.
+*
+* On exit the routine stores vertex indices of the conflict graph
+* included in the clique found to locations ind[1], ..., ind[len], and
+* returns len, which is the clique size. The clique weight is stored
+* in location pointed to by the parameter sum. If no clique has been
+* found, the routine returns 0.
+*
+* Since the conflict graph may have a big number of vertices and be
+* quite dense, the routine uses an induced subgraph G' = (V', E'),
+* which is constructed as follows:
+*
+* 1. If the weight of some vertex v in V is zero (close to zero), it
+* is not included in V'. Obviously, including in a clique
+* zero-weight vertices does not change its weight, so if in G there
+* exist a clique of a non-zero weight, in G' exists a clique of the
+* same weight. This point is extremely important, because dropping
+* out zero-weight vertices can be done without retrieving lists of
+* adjacent vertices whose size may be very large.
+*
+* 2. Cumulative weight of vertex v in V is the sum of the weight of v
+* and weights of all vertices in V adjacent to v. Obviously, if
+* a clique includes a vertex v, the clique weight cannot be greater
+* than the cumulative weight of v. Since we are interested only in
+* cliques whose weight is greater than 1, vertices of V, whose
+* cumulative weight is not greater than 1, are not included in V'.
+*
+* May note that in many practical cases the size of the induced
+* subgraph G' is much less than the size of the original conflict
+* graph G due to many binary variables, whose optimal values are zero
+* or close to zero. For example, it may happen that |V| = 100,000 and
+* |E| = 1e9 while |V'| = 50 and |E'| = 1000. */
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* original MIP */
+ CFG *G;
+ /* original conflict graph G = (V, E), |V| = nv */
+ int *ind; /* int ind[1+nv]; */
+ /* working array */
+ /*--------------------------------------------------------------*/
+ /* induced subgraph G' = (V', E') of original conflict graph */
+ int nn;
+ /* number of vertices in V' */
+ int *vtoi; /* int vtoi[1+nv]; */
+ /* vtoi[v] = i, 1 <= v <= nv, means that vertex v in V is vertex
+ * i in V'; vtoi[v] = 0 means that vertex v is not included in
+ * the subgraph */
+ int *itov; /* int itov[1+nv]; */
+ /* itov[i] = v, 1 <= i <= nn, means that vertex i in V' is vertex
+ * v in V */
+ double *wgt; /* double wgt[1+nv]; */
+ /* wgt[i], 1 <= i <= nn, is a weight of vertex i in V', which is
+ * the value of corresponding binary variable in optimal solution
+ * to LP relaxation */
+};
+
+static void build_subgraph(struct csa *csa)
+{ /* build induced subgraph */
+ glp_prob *P = csa->P;
+ int n = P->n;
+ CFG *G = csa->G;
+ int *ind = csa->ind;
+ int *pos = G->pos;
+ int *neg = G->neg;
+ int nv = G->nv;
+ int *ref = G->ref;
+ int *vtoi = csa->vtoi;
+ int *itov = csa->itov;
+ double *wgt = csa->wgt;
+ int j, k, v, w, nn, len;
+ double z, sum;
+ /* initially induced subgraph is empty */
+ nn = 0;
+ /* walk thru vertices of original conflict graph */
+ for (v = 1; v <= nv; v++)
+ { /* determine value of binary variable z[j] that corresponds to
+ * vertex v */
+ j = ref[v];
+ xassert(1 <= j && j <= n);
+ if (pos[j] == v)
+ { /* z[j] = x[j], where x[j] is original variable */
+ z = P->col[j]->prim;
+ }
+ else if (neg[j] == v)
+ { /* z[j] = 1 - x[j], where x[j] is original variable */
+ z = 1.0 - P->col[j]->prim;
+ }
+ else
+ xassert(v != v);
+ /* if z[j] is close to zero, do not include v in the induced
+ * subgraph */
+ if (z < 0.001)
+ { vtoi[v] = 0;
+ continue;
+ }
+ /* calculate cumulative weight of vertex v */
+ sum = z;
+ /* walk thru all vertices adjacent to v */
+ len = cfg_get_adjacent(G, v, ind);
+ for (k = 1; k <= len; k++)
+ { /* there is an edge (v,w) in the conflict graph */
+ w = ind[k];
+ xassert(w != v);
+ /* add value of z[j] that corresponds to vertex w */
+ j = ref[w];
+ xassert(1 <= j && j <= n);
+ if (pos[j] == w)
+ sum += P->col[j]->prim;
+ else if (neg[j] == w)
+ sum += 1.0 - P->col[j]->prim;
+ else
+ xassert(w != w);
+ }
+ /* cumulative weight of vertex v is an upper bound of weight
+ * of any clique containing v; so if it not greater than 1, do
+ * not include v in the induced subgraph */
+ if (sum < 1.010)
+ { vtoi[v] = 0;
+ continue;
+ }
+ /* include vertex v in the induced subgraph */
+ nn++;
+ vtoi[v] = nn;
+ itov[nn] = v;
+ wgt[nn] = z;
+ }
+ /* induced subgraph has been built */
+ csa->nn = nn;
+ return;
+}
+
+static int sub_adjacent(struct csa *csa, int i, int adj[])
+{ /* retrieve vertices of induced subgraph adjacent to specified
+ * vertex */
+ CFG *G = csa->G;
+ int nv = G->nv;
+ int *ind = csa->ind;
+ int nn = csa->nn;
+ int *vtoi = csa->vtoi;
+ int *itov = csa->itov;
+ int j, k, v, w, len, len1;
+ /* determine original vertex v corresponding to vertex i */
+ xassert(1 <= i && i <= nn);
+ v = itov[i];
+ /* retrieve vertices adjacent to vertex v in original graph */
+ len1 = cfg_get_adjacent(G, v, ind);
+ /* keep only adjacent vertices which are in induced subgraph and
+ * change their numbers appropriately */
+ len = 0;
+ for (k = 1; k <= len1; k++)
+ { /* there exists edge (v, w) in original graph */
+ w = ind[k];
+ xassert(1 <= w && w <= nv && w != v);
+ j = vtoi[w];
+ if (j != 0)
+ { /* vertex w is vertex j in induced subgraph */
+ xassert(1 <= j && j <= nn && j != i);
+ adj[++len] = j;
+ }
+ }
+ return len;
+}
+
+static int find_clique(struct csa *csa, int c_ind[])
+{ /* find maximum weight clique in induced subgraph with exact
+ * Ostergard's algorithm */
+ int nn = csa->nn;
+ double *wgt = csa->wgt;
+ int i, j, k, p, q, t, ne, nb, len, *iwt, *ind;
+ unsigned char *a;
+ xassert(nn >= 2);
+ /* allocate working array */
+ ind = talloc(1+nn, int);
+ /* calculate the number of elements in lower triangle (without
+ * diagonal) of adjacency matrix of induced subgraph */
+ ne = (nn * (nn - 1)) / 2;
+ /* calculate the number of bytes needed to store lower triangle
+ * of adjacency matrix */
+ nb = (ne + (CHAR_BIT - 1)) / CHAR_BIT;
+ /* allocate lower triangle of adjacency matrix */
+ a = talloc(nb, unsigned char);
+ /* fill lower triangle of adjacency matrix */
+ memset(a, 0, nb);
+ for (p = 1; p <= nn; p++)
+ { /* retrieve vertices adjacent to vertex p */
+ len = sub_adjacent(csa, p, ind);
+ for (k = 1; k <= len; k++)
+ { /* there exists edge (p, q) in induced subgraph */
+ q = ind[k];
+ xassert(1 <= q && q <= nn && q != p);
+ /* determine row and column indices of this edge in lower
+ * triangle of adjacency matrix */
+ if (p > q)
+ i = p, j = q;
+ else /* p < q */
+ i = q, j = p;
+ /* set bit a[i,j] to 1, i > j */
+ t = ((i - 1) * (i - 2)) / 2 + (j - 1);
+ a[t / CHAR_BIT] |=
+ (unsigned char)(1 << ((CHAR_BIT - 1) - t % CHAR_BIT));
+ }
+ }
+ /* scale vertex weights by 1000 and convert them to integers as
+ * required by Ostergard's algorithm */
+ iwt = ind;
+ for (i = 1; i <= nn; i++)
+ { /* it is assumed that 0 <= wgt[i] <= 1 */
+ t = (int)(1000.0 * wgt[i] + 0.5);
+ if (t < 0)
+ t = 0;
+ else if (t > 1000)
+ t = 1000;
+ iwt[i] = t;
+ }
+ /* find maximum weight clique */
+ len = wclique(nn, iwt, a, c_ind);
+ /* free working arrays */
+ tfree(ind);
+ tfree(a);
+ /* return clique size to calling routine */
+ return len;
+}
+
+static int func(void *info, int i, int ind[])
+{ /* auxiliary routine used by routine find_clique1 */
+ struct csa *csa = info;
+ xassert(1 <= i && i <= csa->nn);
+ return sub_adjacent(csa, i, ind);
+}
+
+static int find_clique1(struct csa *csa, int c_ind[])
+{ /* find maximum weight clique in induced subgraph with greedy
+ * heuristic */
+ int nn = csa->nn;
+ double *wgt = csa->wgt;
+ int len;
+ xassert(nn >= 2);
+ len = wclique1(nn, wgt, func, csa, c_ind);
+ /* return clique size to calling routine */
+ return len;
+}
+
+int cfg_find_clique(void *P, CFG *G, int ind[], double *sum_)
+{ int nv = G->nv;
+ struct csa csa;
+ int i, k, len;
+ double sum;
+ /* initialize common storage area */
+ csa.P = P;
+ csa.G = G;
+ csa.ind = talloc(1+nv, int);
+ csa.nn = -1;
+ csa.vtoi = talloc(1+nv, int);
+ csa.itov = talloc(1+nv, int);
+ csa.wgt = talloc(1+nv, double);
+ /* build induced subgraph */
+ build_subgraph(&csa);
+#ifdef GLP_DEBUG
+ xprintf("nn = %d\n", csa.nn);
+#endif
+ /* if subgraph has less than two vertices, do nothing */
+ if (csa.nn < 2)
+ { len = 0;
+ sum = 0.0;
+ goto skip;
+ }
+ /* find maximum weight clique in induced subgraph */
+#if 1 /* FIXME */
+ if (csa.nn <= 50)
+#endif
+ { /* induced subgraph is small; use exact algorithm */
+ len = find_clique(&csa, ind);
+ }
+ else
+ { /* induced subgraph is large; use greedy heuristic */
+ len = find_clique1(&csa, ind);
+ }
+ /* do not report clique, if it has less than two vertices */
+ if (len < 2)
+ { len = 0;
+ sum = 0.0;
+ goto skip;
+ }
+ /* convert indices of clique vertices from induced subgraph to
+ * original conflict graph and compute clique weight */
+ sum = 0.0;
+ for (k = 1; k <= len; k++)
+ { i = ind[k];
+ xassert(1 <= i && i <= csa.nn);
+ sum += csa.wgt[i];
+ ind[k] = csa.itov[i];
+ }
+skip: /* free working arrays */
+ tfree(csa.ind);
+ tfree(csa.vtoi);
+ tfree(csa.itov);
+ tfree(csa.wgt);
+ /* return to calling routine */
+ *sum_ = sum;
+ return len;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/cfg2.c b/test/monniaux/glpk-4.65/src/intopt/cfg2.c
new file mode 100644
index 00000000..85c0705e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/cfg2.c
@@ -0,0 +1,91 @@
+/* cfg2.c (conflict graph) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "cfg.h"
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_cfg_init - create and initialize conflict graph
+*
+* SYNOPSIS
+*
+* glp_cfg *glp_cfg_init(glp_prob *P);
+*
+* DESCRIPTION
+*
+* This routine creates and initializes the conflict graph for the
+* specified problem object.
+*
+* RETURNS
+*
+* The routine returns a pointer to the conflict graph descriptor.
+* However, if the conflict graph is empty (no conflicts have been
+* found), the routine returns NULL. */
+
+glp_cfg *glp_cfg_init(glp_prob *P)
+{ glp_cfg *G;
+ int j, n1, n2;
+ xprintf("Constructing conflict graph...\n");
+ G = cfg_build_graph(P);
+ n1 = n2 = 0;
+ for (j = 1; j <= P->n; j++)
+ { if (G->pos[j])
+ n1 ++;
+ if (G->neg[j])
+ n2++;
+ }
+ if (n1 == 0 && n2 == 0)
+ { xprintf("No conflicts found\n");
+ cfg_delete_graph(G);
+ G = NULL;
+ }
+ else
+ xprintf("Conflict graph has %d + %d = %d vertices\n",
+ n1, n2, G->nv);
+ return G;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_cfg_free - delete conflict graph descriptor
+*
+* SYNOPSIS
+*
+* void glp_cfg_free(glp_cfg *G);
+*
+* DESCRIPTION
+*
+* This routine deletes the conflict graph descriptor and frees all the
+* memory allocated to it. */
+
+void glp_cfg_free(glp_cfg *G)
+{ xassert(G != NULL);
+ cfg_delete_graph(G);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/clqcut.c b/test/monniaux/glpk-4.65/src/intopt/clqcut.c
new file mode 100644
index 00000000..d3db5b39
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/clqcut.c
@@ -0,0 +1,134 @@
+/* clqcut.c (clique cut generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "cfg.h"
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_clq_cut - generate clique cut from conflict graph
+*
+* SYNOPSIS
+*
+* int glp_clq_cut(glp_prob *P, glp_cfg *G, int ind[], double val[]);
+*
+* DESCRIPTION
+*
+* This routine attempts to generate a clique cut.
+*
+* The cut generated by the routine is the following inequality:
+*
+* sum a[j] * x[j] <= b,
+*
+* which is expected to be violated at the current basic solution.
+*
+* If the cut has been successfully generated, the routine stores its
+* non-zero coefficients a[j] and corresponding column indices j in the
+* array locations val[1], ..., val[len] and ind[1], ..., ind[len],
+* where 1 <= len <= n is the number of non-zero coefficients. The
+* right-hand side value b is stored in val[0], and ind[0] is set to 0.
+*
+* RETURNS
+*
+* If the cut has been successfully generated, the routine returns
+* len, the number of non-zero coefficients in the cut, 1 <= len <= n.
+* Otherwise, the routine returns a non-positive value. */
+
+int glp_clq_cut(glp_prob *P, glp_cfg *G, int ind[], double val[])
+{ int n = P->n;
+ int *pos = G->pos;
+ int *neg = G->neg;
+ int nv = G->nv;
+ int *ref = G->ref;
+ int j, k, v, len;
+ double rhs, sum;
+ xassert(G->n == n);
+ /* find maximum weight clique in conflict graph */
+ len = cfg_find_clique(P, G, ind, &sum);
+#ifdef GLP_DEBUG
+ xprintf("len = %d; sum = %g\n", len, sum);
+ cfg_check_clique(G, len, ind);
+#endif
+ /* check if clique inequality is violated */
+ if (sum < 1.07)
+ return 0;
+ /* expand clique to maximal one */
+ len = cfg_expand_clique(G, len, ind);
+#ifdef GLP_DEBUG
+ xprintf("maximal clique size = %d\n", len);
+ cfg_check_clique(G, len, ind);
+#endif
+ /* construct clique cut (fixed binary variables are removed, so
+ this cut is only locally valid) */
+ rhs = 1.0;
+ for (j = 1; j <= n; j++)
+ val[j] = 0.0;
+ for (k = 1; k <= len; k++)
+ { /* v is clique vertex */
+ v = ind[k];
+ xassert(1 <= v && v <= nv);
+ /* j is number of corresponding binary variable */
+ j = ref[v];
+ xassert(1 <= j && j <= n);
+ if (pos[j] == v)
+ { /* v corresponds to x[j] */
+ if (P->col[j]->type == GLP_FX)
+ { /* x[j] is fixed */
+ rhs -= P->col[j]->prim;
+ }
+ else
+ { /* x[j] is not fixed */
+ val[j] += 1.0;
+ }
+ }
+ else if (neg[j] == v)
+ { /* v corresponds to (1 - x[j]) */
+ if (P->col[j]->type == GLP_FX)
+ { /* x[j] is fixed */
+ rhs -= (1.0 - P->col[j]->prim);
+ }
+ else
+ { /* x[j] is not fixed */
+ val[j] -= 1.0;
+ rhs -= 1.0;
+ }
+ }
+ else
+ xassert(v != v);
+ }
+ /* convert cut inequality to sparse format */
+ len = 0;
+ for (j = 1; j <= n; j++)
+ { if (val[j] != 0.0)
+ { len++;
+ ind[len] = j;
+ val[len] = val[j];
+ }
+ }
+ ind[0] = 0, val[0] = rhs;
+ return len;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/covgen.c b/test/monniaux/glpk-4.65/src/intopt/covgen.c
new file mode 100644
index 00000000..427c3aa8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/covgen.c
@@ -0,0 +1,885 @@
+/* covgen.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "fvs.h"
+#include "ks.h"
+#include "prob.h"
+
+struct glp_cov
+{ /* cover cut generator working area */
+ int n;
+ /* number of columns (variables) */
+ glp_prob *set;
+ /* set of globally valid 0-1 knapsack inequalities chosen from
+ * the root problem; each inequality is either original row or
+ * its relaxation (surrogate 0-1 knapsack) which is constructed
+ * by substitution of lower/upper single/variable bounds for
+ * continuous and general integer (non-binary) variables */
+};
+
+struct bnd
+{ /* simple or variable bound */
+ /* if z = 0, it is a simple bound x >= or <= b; if b = -DBL_MAX
+ * (b = +DBL_MAX), x has no lower (upper) bound; otherwise, if
+ * z != 0, it is a variable bound x >= or <= a * z + b */
+ int z;
+ /* number of binary variable or 0 */
+ double a, b;
+ /* bound parameters */
+};
+
+struct csa
+{ /* common storage area */
+ glp_prob *P;
+ /* original (root) MIP */
+ struct bnd *l; /* struct bnd l[1+P->n]; */
+ /* lower simple/variable bounds of variables */
+ struct bnd *u; /* struct bnd u[1+P->n]; */
+ /* upper simple/variable bounds of variables */
+ glp_prob *set;
+ /* see struct glp_cov above */
+};
+
+/***********************************************************************
+* init_bounds - initialize bounds of variables with simple bounds
+*
+* This routine initializes lower and upper bounds of all variables
+* with simple bounds specified in the original mip. */
+
+static void init_bounds(struct csa *csa)
+{ glp_prob *P = csa->P;
+ struct bnd *l = csa->l, *u = csa->u;
+ int j;
+ for (j = 1; j <= P->n; j++)
+ { l[j].z = u[j].z = 0;
+ l[j].a = u[j].a = 0;
+ l[j].b = glp_get_col_lb(P, j);
+ u[j].b = glp_get_col_ub(P, j);
+ }
+ return;
+}
+
+/***********************************************************************
+* check_vb - check variable bound
+*
+* This routine checks if the specified i-th row has the form
+*
+* a1 * x + a2 * z >= or <= rhs, (1)
+*
+* where x is a non-fixed continuous or general integer variable, and
+* z is a binary variable. If it is, the routine converts the row to
+* the following variable lower/upper bound (VLB/VUB) of x:
+*
+* x >= or <= a * z + b, (2)
+*
+* where a = - a2 / a1, b = rhs / a1. Note that the inequality type is
+* changed to opposite one when a1 < 0.
+*
+* If the row is identified as a variable bound, the routine returns
+* GLP_LO for VLB or GLP_UP for VUB and provides the reference numbers
+* of variables x and z and values of a and b. Otherwise, the routine
+* returns zero. */
+
+static int check_vb(struct csa *csa, int i, int *x, int *z, double *a,
+ double *b)
+{ glp_prob *P = csa->P;
+ GLPROW *row;
+ GLPAIJ *a1, *a2;
+ int type;
+ double rhs;
+ xassert(1 <= i && i <= P->m);
+ row = P->row[i];
+ /* check row type */
+ switch (row->type)
+ { case GLP_LO:
+ case GLP_UP:
+ break;
+ default:
+ return 0;
+ }
+ /* take first term of the row */
+ a1 = row->ptr;
+ if (a1 == NULL)
+ return 0;
+ /* take second term of the row */
+ a2 = a1->r_next;
+ if (a2 == NULL)
+ return 0;
+ /* there should be exactly two terms in the row */
+ if (a2->r_next != NULL)
+ return 0;
+ /* if first term is a binary variable, swap the terms */
+ if (glp_get_col_kind(P, a1->col->j) == GLP_BV)
+ { GLPAIJ *a;
+ a = a1, a1 = a2, a2 = a;
+ }
+ /* now first term should be a non-fixed continuous or general
+ * integer variable */
+ if (a1->col->type == GLP_FX)
+ return 0;
+ if (glp_get_col_kind(P, a1->col->j) == GLP_BV)
+ return 0;
+ /* and second term should be a binary variable */
+ if (glp_get_col_kind(P, a2->col->j) != GLP_BV)
+ return 0;
+ /* VLB/VUB row has been identified */
+ switch (row->type)
+ { case GLP_LO:
+ type = a1->val > 0 ? GLP_LO : GLP_UP;
+ rhs = row->lb;
+ break;
+ case GLP_UP:
+ type = a1->val > 0 ? GLP_UP : GLP_LO;
+ rhs = row->ub;
+ break;
+ default:
+ xassert(type != type);
+ }
+ *x = a1->col->j;
+ *z = a2->col->j;
+ *a = - a2->val / a1->val;
+ *b = rhs / a1->val;
+ return type;
+}
+
+/***********************************************************************
+* set_vb - set variable bound
+*
+* This routine sets lower or upper variable bound specified as
+*
+* x >= a * z + b (type = GLP_LO)
+*
+* x <= a * z + b (type = GLP_UP) */
+
+static void set_vb(struct csa *csa, int type, int x, int z, double a,
+ double b)
+{ glp_prob *P = csa->P;
+ struct bnd *l = csa->l, *u = csa->u;
+ xassert(glp_get_col_type(P, x) != GLP_FX);
+ xassert(glp_get_col_kind(P, x) != GLP_BV);
+ xassert(glp_get_col_kind(P, z) == GLP_BV);
+ xassert(a != 0);
+ switch (type)
+ { case GLP_LO:
+ /* FIXME: check existing simple lower bound? */
+ l[x].z = z, l[x].a = a, l[x].b = b;
+ break;
+ case GLP_UP:
+ /* FIXME: check existing simple upper bound? */
+ u[x].z = z, u[x].a = a, u[x].b = b;
+ break;
+ default:
+ xassert(type != type);
+ }
+ return;
+}
+
+/***********************************************************************
+* obtain_vbs - obtain and set variable bounds
+*
+* This routine walks thru all rows of the original mip, identifies
+* rows specifying variable lower/upper bounds, and sets these bounds
+* for corresponding (non-binary) variables. */
+
+static void obtain_vbs(struct csa *csa)
+{ glp_prob *P = csa->P;
+ int i, x, z, type, save;
+ double a, b;
+ for (i = 1; i <= P->m; i++)
+ { switch (P->row[i]->type)
+ { case GLP_FR:
+ break;
+ case GLP_LO:
+ case GLP_UP:
+ type = check_vb(csa, i, &x, &z, &a, &b);
+ if (type)
+ set_vb(csa, type, x, z, a, b);
+ break;
+ case GLP_DB:
+ case GLP_FX:
+ /* double-side inequality l <= ... <= u and equality
+ * ... = l = u are considered as two single inequalities
+ * ... >= l and ... <= u */
+ save = P->row[i]->type;
+ P->row[i]->type = GLP_LO;
+ type = check_vb(csa, i, &x, &z, &a, &b);
+ if (type)
+ set_vb(csa, type, x, z, a, b);
+ P->row[i]->type = GLP_UP;
+ type = check_vb(csa, i, &x, &z, &a, &b);
+ if (type)
+ set_vb(csa, type, x, z, a, b);
+ P->row[i]->type = save;
+ break;
+ default:
+ xassert(P != P);
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* add_term - add term to sparse vector
+*
+* This routine computes the following linear combination:
+*
+* v := v + a * e[j],
+*
+* where v is a sparse vector in full storage format, a is a non-zero
+* scalar, e[j] is j-th column of unity matrix. */
+
+static void add_term(FVS *v, int j, double a)
+{ xassert(1 <= j && j <= v->n);
+ xassert(a != 0);
+ if (v->vec[j] == 0)
+ { /* create j-th component */
+ v->nnz++;
+ xassert(v->nnz <= v->n);
+ v->ind[v->nnz] = j;
+ }
+ /* perform addition */
+ v->vec[j] += a;
+ if (fabs(v->vec[j]) < 1e-9 * (1 + fabs(a)))
+ { /* remove j-th component */
+ v->vec[j] = DBL_MIN;
+ }
+ return;
+}
+
+/***********************************************************************
+* build_ks - build "0-1 knapsack" inequality
+*
+* Given an inequality of "not greater" type:
+*
+* sum{j in 1..n} a[j]*x[j] <= b, (1)
+*
+* this routine attempts to transform it to equivalent or relaxed "0-1
+* knapsack" inequality that contains only binary variables.
+*
+* If x[j] is a binary variable, the term a[j]*x[j] is not changed.
+* Otherwise, if x[j] is a continuous or integer non-binary variable,
+* it is replaced by its lower (if a[j] > 0) or upper (if a[j] < 0)
+* single or variable bound. In the latter case, if x[j] is a non-fixed
+* variable, this results in a relaxation of original inequality known
+* as "surrogate knapsack". Thus, if the specified inequality is valid
+* for the original mip, the resulting inequality is also valid.
+*
+* Note that in both source and resulting inequalities coefficients
+* a[j] can have any sign.
+*
+* On entry to the routine the source inequality is specified by the
+* parameters n, ind (contains original numbers of x[j]), a, and b. The
+* parameter v is a working sparse vector whose components are assumed
+* to be zero.
+*
+* On exit the routine stores the resulting "0-1 knapsack" inequality
+* in the parameters ind, a, and b, and returns n which is the number
+* of terms in the resulting inequality. Zero content of the vector v
+* is restored before exit.
+*
+* If the resulting inequality cannot be constructed due to missing
+* lower/upper bounds of some variable, the routine returns a negative
+* value. */
+
+static int build_ks(struct csa *csa, int n, int ind[], double a[],
+ double *b, FVS *v)
+{ glp_prob *P = csa->P;
+ struct bnd *l = csa->l, *u = csa->u;
+ int j, k;
+ /* check that v = 0 */
+#ifdef GLP_DEBUG
+ fvs_check_vec(v);
+#endif
+ xassert(v->nnz == 0);
+ /* walk thru terms of original inequality */
+ for (j = 1; j <= n; j++)
+ { /* process term a[j]*x[j] */
+ k = ind[j]; /* original number of x[j] in mip */
+ if (glp_get_col_kind(P, k) == GLP_BV)
+ { /* x[j] is a binary variable */
+ /* include its term into resulting inequality */
+ add_term(v, k, a[j]);
+ }
+ else if (a[j] > 0)
+ { /* substitute x[j] by its lower bound */
+ if (l[k].b == -DBL_MAX)
+ { /* x[j] has no lower bound */
+ n = -1;
+ goto skip;
+ }
+ else if (l[k].z == 0)
+ { /* x[j] has simple lower bound */
+ *b -= a[j] * l[k].b;
+ }
+ else
+ { /* x[j] has variable lower bound (a * z + b) */
+ add_term(v, l[k].z, a[j] * l[k].a);
+ *b -= a[j] * l[k].b;
+ }
+ }
+ else /* a[j] < 0 */
+ { /* substitute x[j] by its upper bound */
+ if (u[k].b == +DBL_MAX)
+ { /* x[j] has no upper bound */
+ n = -1;
+ goto skip;
+ }
+ else if (u[k].z == 0)
+ { /* x[j] has simple upper bound */
+ *b -= a[j] * u[k].b;
+ }
+ else
+ { /* x[j] has variable upper bound (a * z + b) */
+ add_term(v, u[k].z, a[j] * u[k].a);
+ *b -= a[j] * u[k].b;
+ }
+ }
+ }
+ /* replace tiny coefficients by exact zeros (see add_term) */
+ fvs_adjust_vec(v, 2 * DBL_MIN);
+ /* copy terms of resulting inequality */
+ xassert(v->nnz <= n);
+ n = v->nnz;
+ for (j = 1; j <= n; j++)
+ { ind[j] = v->ind[j];
+ a[j] = v->vec[ind[j]];
+ }
+skip: /* restore zero content of v */
+ fvs_clear_vec(v);
+ return n;
+}
+
+/***********************************************************************
+* can_be_active - check if inequality can be active
+*
+* This routine checks if the specified "0-1 knapsack" inequality
+*
+* sum{j in 1..n} a[j]*x[j] <= b
+*
+* can be active. If so, the routine returns true, otherwise false. */
+
+static int can_be_active(int n, const double a[], double b)
+{ int j;
+ double s;
+ s = 0;
+ for (j = 1; j <= n; j++)
+ { if (a[j] > 0)
+ s += a[j];
+ }
+ return s > b + .001 * (1 + fabs(b));
+}
+
+/***********************************************************************
+* is_sos_ineq - check if inequality is packing (SOS) constraint
+*
+* This routine checks if the specified "0-1 knapsack" inequality
+*
+* sum{j in 1..n} a[j]*x[j] <= b (1)
+*
+* is equivalent to packing inequality (Padberg calls such inequalities
+* special ordered set or SOS constraints)
+*
+* sum{j in J'} x[j] - sum{j in J"} x[j] <= 1 - |J"|. (2)
+*
+* If so, the routine returns true, otherwise false.
+*
+* Note that if X is a set of feasible binary points satisfying to (2),
+* its convex hull conv(X) equals to the set of feasible points of LP
+* relaxation of (2), which is a n-dimensional simplex, so inequalities
+* (2) are useless for generating cover cuts (due to unimodularity).
+*
+* ALGORITHM
+*
+* First, we make all a[j] positive by complementing x[j] = 1 - x'[j]
+* in (1). This is performed implicitly (i.e. actually the array a is
+* not changed), but b is replaced by b - sum{j : a[j] < 0}.
+*
+* Then we find two smallest coefficients a[p] = min{j in 1..n} a[j]
+* and a[q] = min{j in 1..n : j != p} a[j]. It is obvious that if
+* a[p] + a[q] > b, then a[i] + a[j] > b for all i != j, from which it
+* follows that x[i] + x[j] <= 1 for all i != j. But the latter means
+* that the original inequality (with all a[j] > 0) is equivalent to
+* packing inequality
+*
+* sum{j in 1..n} x[j] <= 1. (3)
+*
+* Returning to original (uncomplemented) variables x'[j] = 1 - x[j]
+* we have that the original inequality is equivalent to (2), where
+* J' = {j : a[j] > 0} and J" = {j : a[j] < 0}. */
+
+static int is_sos_ineq(int n, const double a[], double b)
+{ int j, p, q;
+ xassert(n >= 2);
+ /* compute b := b - sum{j : a[j] < 0} */
+ for (j = 1; j <= n; j++)
+ { if (a[j] < 0)
+ b -= a[j];
+ }
+ /* find a[p] = min{j in 1..n} a[j] */
+ p = 1;
+ for (j = 2; j <= n; j++)
+ { if (fabs(a[p]) > fabs(a[j]))
+ p = j;
+ }
+ /* find a[q] = min{j in 1..n : j != p} a[j] */
+ q = 0;
+ for (j = 1; j <= n; j++)
+ { if (j != p)
+ { if (q == 0 || fabs(a[q]) > fabs(a[j]))
+ q = j;
+ }
+ }
+ xassert(q != 0);
+ /* check condition a[p] + a[q] > b */
+ return fabs(a[p]) + fabs(a[q]) > b + .001 * (1 + fabs(b));
+}
+
+/***********************************************************************
+* process_ineq - basic inequality processing
+*
+* This routine performs basic processing of an inequality of "not
+* greater" type
+*
+* sum{j in 1..n} a[j]*x[j] <= b
+*
+* specified by the parameters, n, ind, a, and b.
+*
+* If the inequality can be transformed to "0-1 knapsack" ineqiality
+* suitable for generating cover cuts, the routine adds it to the set
+* of "0-1 knapsack" inequalities.
+*
+* Note that the arrays ind and a are not saved on exit. */
+
+static void process_ineq(struct csa *csa, int n, int ind[], double a[],
+ double b, FVS *v)
+{ int i;
+ /* attempt to transform the specified inequality to equivalent or
+ * relaxed "0-1 knapsack" inequality */
+ n = build_ks(csa, n, ind, a, &b, v);
+ if (n <= 1)
+ { /* uninteresting inequality (in principle, such inequalities
+ * should be removed by the preprocessor) */
+ goto done;
+ }
+ if (!can_be_active(n, a, b))
+ { /* inequality is redundant (i.e. cannot be active) */
+ goto done;
+ }
+ if (is_sos_ineq(n, a, b))
+ { /* packing (SOS) inequality is useless for generating cover
+ * cuts; currently such inequalities are just ignored */
+ goto done;
+ }
+ /* add resulting "0-1 knapsack" inequality to the set */
+ i = glp_add_rows(csa->set, 1);
+ glp_set_mat_row(csa->set, i, n, ind, a);
+ glp_set_row_bnds(csa->set, i, GLP_UP, b, b);
+done: return;
+}
+
+/**********************************************************************/
+
+glp_cov *glp_cov_init(glp_prob *P)
+{ /* create and initialize cover cut generator */
+ glp_cov *cov;
+ struct csa csa;
+ int i, k, len, *ind;
+ double rhs, *val;
+ FVS fvs;
+ csa.P = P;
+ csa.l = talloc(1+P->n, struct bnd);
+ csa.u = talloc(1+P->n, struct bnd);
+ csa.set = glp_create_prob();
+ glp_add_cols(csa.set, P->n);
+ /* initialize bounds of variables with simple bounds */
+ init_bounds(&csa);
+ /* obtain and set variable bounds */
+ obtain_vbs(&csa);
+ /* allocate working arrays */
+ ind = talloc(1+P->n, int);
+ val = talloc(1+P->n, double);
+ fvs_alloc_vec(&fvs, P->n);
+ /* process all rows of the root mip */
+ for (i = 1; i <= P->m; i++)
+ { switch (P->row[i]->type)
+ { case GLP_FR:
+ break;
+ case GLP_LO:
+ /* obtain row of ">=" type */
+ len = glp_get_mat_row(P, i, ind, val);
+ rhs = P->row[i]->lb;
+ /* transforms it to row of "<=" type */
+ for (k = 1; k <= len; k++)
+ val[k] = - val[k];
+ rhs = - rhs;
+ /* process the row */
+ process_ineq(&csa, len, ind, val, rhs, &fvs);
+ break;
+ case GLP_UP:
+ /* obtain row of "<=" type */
+ len = glp_get_mat_row(P, i, ind, val);
+ rhs = P->row[i]->ub;
+ /* and process it */
+ process_ineq(&csa, len, ind, val, rhs, &fvs);
+ break;
+ case GLP_DB:
+ case GLP_FX:
+ /* double-sided inequalitiy and equality constraints are
+ * processed as two separate inequalities */
+ /* obtain row as if it were of ">=" type */
+ len = glp_get_mat_row(P, i, ind, val);
+ rhs = P->row[i]->lb;
+ /* transforms it to row of "<=" type */
+ for (k = 1; k <= len; k++)
+ val[k] = - val[k];
+ rhs = - rhs;
+ /* and process it */
+ process_ineq(&csa, len, ind, val, rhs, &fvs);
+ /* obtain the same row as if it were of "<=" type */
+ len = glp_get_mat_row(P, i, ind, val);
+ rhs = P->row[i]->ub;
+ /* and process it */
+ process_ineq(&csa, len, ind, val, rhs, &fvs);
+ break;
+ default:
+ xassert(P != P);
+ }
+ }
+ /* free working arrays */
+ tfree(ind);
+ tfree(val);
+ fvs_check_vec(&fvs);
+ fvs_free_vec(&fvs);
+ /* the set of "0-1 knapsack" inequalities has been built */
+ if (csa.set->m == 0)
+ { /* the set is empty */
+ xprintf("No 0-1 knapsack inequalities detected\n");
+ cov = NULL;
+ glp_delete_prob(csa.set);
+ }
+ else
+ { /* create the cover cut generator working area */
+ xprintf("Number of 0-1 knapsack inequalities = %d\n",
+ csa.set->m);
+ cov = talloc(1, glp_cov);
+ cov->n = P->n;
+ cov->set = csa.set;
+#if 0
+ glp_write_lp(cov->set, 0, "set.lp");
+#endif
+ }
+ tfree(csa.l);
+ tfree(csa.u);
+ return cov;
+}
+
+/***********************************************************************
+* solve_ks - solve 0-1 knapsack problem
+*
+* This routine finds (sub)optimal solution to 0-1 knapsack problem:
+*
+* maximize z = sum{j in 1..n} c[j]x[j] (1)
+*
+* s.t. sum{j in 1..n} a[j]x[j] <= b (2)
+*
+* x[j] in {0, 1} for all j in 1..n (3)
+*
+* It is assumed that the instance is non-normalized, i.e. parameters
+* a, b, and c may have any sign.
+*
+* On exit the routine stores the (sub)optimal point found in locations
+* x[1], ..., x[n] and returns the optimal objective value. However, if
+* the instance is infeasible, the routine returns INT_MIN. */
+
+static int solve_ks(int n, const int a[], int b, const int c[],
+ char x[])
+{ int z;
+ /* surprisingly, even for some small instances (n = 50-100)
+ * MT1 routine takes too much time, so it is used only for tiny
+ * instances */
+ if (n <= 16)
+#if 0
+ z = ks_enum(n, a, b, c, x);
+#else
+ z = ks_mt1(n, a, b, c, x);
+#endif
+ else
+ z = ks_greedy(n, a, b, c, x);
+ return z;
+}
+
+/***********************************************************************
+* simple_cover - find simple cover cut
+*
+* Given a 0-1 knapsack inequality (which may be globally as well as
+* locally valid)
+*
+* sum{j in 1..n} a[j]x[j] <= b, (1)
+*
+* where all x[j] are binary variables and all a[j] are positive, and
+* a fractional point x~{j in 1..n}, which is feasible to LP relaxation
+* of (1), this routine attempts to find a simple cover inequality
+*
+* sum{j in C} (1 - x[j]) >= 1, (2)
+*
+* which is valid for (1) and violated at x~.
+*
+* Actually, the routine finds a cover C, i.e. a subset of {1, ..., n}
+* such that
+*
+* sum{j in C} a[j] > b, (3)
+*
+* and which minimizes the left-hand side of (2) at x~
+*
+* zeta = sum{j in C} (1 - x~[j]). (4)
+*
+* On exit the routine stores the characteritic vector z{j in 1..n}
+* of the cover found (i.e. z[j] = 1 means j in C, and z[j] = 0 means
+* j not in C), and returns corresponding minimal value of zeta (4).
+* However, if no cover is found, the routine returns DBL_MAX.
+*
+* ALGORITHM
+*
+* The separation problem (3)-(4) is converted to 0-1 knapsack problem
+* as follows.
+*
+* First, note that the constraint (3) is equivalent to
+*
+* sum{j in 1..n} a[j]z[j] >= b + eps, (5)
+*
+* where eps > 0 is a sufficiently small number (in case of integral
+* a and b we may take eps = 1). Multiplying both sides of (5) by (-1)
+* gives
+*
+* sum{j in 1..n} (-a[j])z[j] <= - b - eps. (6)
+*
+* To make all coefficients in (6) positive, z[j] is complemented by
+* substitution z[j] = 1 - z'[j] that finally gives
+*
+* sum{j in 1..n} a[j]z'[j] <= sum{j in 1..n} a[j] - b - eps. (7)
+*
+* Minimization of zeta (4) is equivalent to maximization of
+*
+* -zeta = sum{j in 1..n} (x~[j] - 1)z[j]. (8)
+*
+* Substitution z[j] = 1 - z'[j] gives
+*
+* -zeta = sum{j in 1..n} (1 - x~[j])z'[j] - zeta0, (9)
+*
+* where zeta0 = sum{j in 1..n} (1 - x~[j]) is a constant term.
+*
+* Thus, the 0-1 knapsack problem to be solved is the following:
+*
+* maximize
+*
+* -zeta = sum{j in 1..n} (1 - x~[j])z'[j] - zeta0 (10)
+*
+* subject to
+*
+* sum{j in 1..n} a[j]z'[j] <= sum{j in 1..n} a[j] - b - eps (11)
+*
+* z'[j] in {0,1} for all j = 1,...,n (12)
+*
+* (The constant term zeta0 doesn't affect the solution, so it can be
+* dropped.) */
+
+static double simple_cover(int n, const double a[], double b, const
+ double x[], char z[])
+{ int j, *aa, bb, *cc;
+ double max_aj, min_aj, s, eps;
+ xassert(n >= 3);
+ /* allocate working arrays */
+ aa = talloc(1+n, int);
+ cc = talloc(1+n, int);
+ /* compute max{j in 1..n} a[j] and min{j in 1..n} a[j] */
+ max_aj = 0, min_aj = DBL_MAX;
+ for (j = 1; j <= n; j++)
+ { xassert(a[j] > 0);
+ if (max_aj < a[j])
+ max_aj = a[j];
+ if (min_aj > a[j])
+ min_aj = a[j];
+ }
+ /* scale and round constraint parameters to make them integral;
+ * note that we make the resulting inequality stronger than (11),
+ * so a[j]'s are rounded up while rhs is rounded down */
+ s = 0;
+ for (j = 1; j <= n; j++)
+ { s += a[j];
+ aa[j] = ceil(a[j] / max_aj * 1000);
+ }
+ bb = floor((s - b) / max_aj * 1000) - 1;
+ /* scale and round obj. coefficients to make them integral;
+ * again we make the objective function stronger than (10), so
+ * the coefficients are rounded down */
+ for (j = 1; j <= n; j++)
+ { xassert(0 <= x[j] && x[j] <= 1);
+ cc[j] = floor((1 - x[j]) * 1000);
+ }
+ /* solve separation problem */
+ if (solve_ks(n, aa, bb, cc, z) == INT_MIN)
+ { /* no cover exists */
+ s = DBL_MAX;
+ goto skip;
+ }
+ /* determine z[j] = 1 - z'[j] */
+ for (j = 1; j <= n; j++)
+ { xassert(z[j] == 0 || z[j] == 1);
+ z[j] ^= 1;
+ }
+ /* check condition (11) for original (non-scaled) parameters */
+ s = 0;
+ for (j = 1; j <= n; j++)
+ { if (z[j])
+ s += a[j];
+ }
+ eps = 0.01 * (min_aj >= 1 ? min_aj : 1);
+ if (!(s >= b + eps))
+ { /* no cover found within a precision req'd */
+ s = DBL_MAX;
+ goto skip;
+ }
+ /* compute corresponding zeta (4) for cover found */
+ s = 0;
+ for (j = 1; j <= n; j++)
+ { if (z[j])
+ s += 1 - x[j];
+ }
+skip: /* free working arrays */
+ tfree(aa);
+ tfree(cc);
+ return s;
+}
+
+/**********************************************************************/
+
+void glp_cov_gen1(glp_prob *P, glp_cov *cov, glp_prob *pool)
+{ /* generate locally valid simple cover cuts */
+ int i, k, len, new_len, *ind;
+ double *val, rhs, *x, zeta;
+ char *z;
+ xassert(P->n == cov->n && P->n == cov->set->n);
+ xassert(glp_get_status(P) == GLP_OPT);
+ /* allocate working arrays */
+ ind = talloc(1+P->n, int);
+ val = talloc(1+P->n, double);
+ x = talloc(1+P->n, double);
+ z = talloc(1+P->n, char);
+ /* walk thru 0-1 knapsack inequalities */
+ for (i = 1; i <= cov->set->m; i++)
+ { /* retrieve 0-1 knapsack inequality */
+ len = glp_get_mat_row(cov->set, i, ind, val);
+ rhs = glp_get_row_ub(cov->set, i);
+ xassert(rhs != +DBL_MAX);
+ /* FIXME: skip, if slack is too large? */
+ /* substitute and eliminate binary variables which have been
+ * fixed in the current subproblem (this makes the inequality
+ * only locally valid) */
+ new_len = 0;
+ for (k = 1; k <= len; k++)
+ { if (glp_get_col_type(P, ind[k]) == GLP_FX)
+ rhs -= val[k] * glp_get_col_prim(P, ind[k]);
+ else
+ { new_len++;
+ ind[new_len] = ind[k];
+ val[new_len] = val[k];
+ }
+ }
+ len = new_len;
+ /* we need at least 3 binary variables in the inequality */
+ if (len <= 2)
+ continue;
+ /* obtain values of binary variables from optimal solution to
+ * LP relaxation of current subproblem */
+ for (k = 1; k <= len; k++)
+ { xassert(glp_get_col_kind(P, ind[k]) == GLP_BV);
+ x[k] = glp_get_col_prim(P, ind[k]);
+ if (x[k] < 0.00001)
+ x[k] = 0;
+ else if (x[k] > 0.99999)
+ x[k] = 1;
+ /* if val[k] < 0, perform substitution x[k] = 1 - x'[k] to
+ * make all coefficients positive */
+ if (val[k] < 0)
+ { ind[k] = - ind[k]; /* x[k] is complemented */
+ val[k] = - val[k];
+ rhs += val[k];
+ x[k] = 1 - x[k];
+ }
+ }
+ /* find locally valid simple cover cut */
+ zeta = simple_cover(len, val, rhs, x, z);
+ if (zeta > 0.95)
+ { /* no violation or insufficient violation; see (2) */
+ continue;
+ }
+ /* construct cover inequality (2) for the cover found, which
+ * for original binary variables x[k] is equivalent to:
+ * sum{k in C'} x[k] + sum{k in C"} x'[k] <= |C| - 1
+ * or
+ * sum{k in C'} x[k] + sum{k in C"} (1 - x[k]) <= |C| - 1
+ * or
+ * sum{k in C'} x[k] - sum{k in C"} x[k] <= |C'| - 1
+ * since |C| - |C"| = |C'| */
+ new_len = 0;
+ rhs = -1;
+ for (k = 1; k <= len; k++)
+ { if (z[k])
+ { new_len++;
+ if (ind[k] > 0)
+ { ind[new_len] = +ind[k];
+ val[new_len] = +1;
+ rhs++;
+ }
+ else /* ind[k] < 0 */
+ { ind[new_len] = -ind[k];
+ val[new_len] = -1;
+ }
+ }
+ }
+ len = new_len;
+ /* add the cover inequality to the local cut pool */
+ k = glp_add_rows(pool, 1);
+ glp_set_mat_row(pool, k, len, ind, val);
+ glp_set_row_bnds(pool, k, GLP_UP, rhs, rhs);
+ }
+ /* free working arrays */
+ tfree(ind);
+ tfree(val);
+ tfree(x);
+ tfree(z);
+ return;
+}
+
+/**********************************************************************/
+
+void glp_cov_free(glp_cov *cov)
+{ /* delete cover cut generator workspace */
+ xassert(cov != NULL);
+ glp_delete_prob(cov->set);
+ tfree(cov);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/fpump.c b/test/monniaux/glpk-4.65/src/intopt/fpump.c
new file mode 100644
index 00000000..0bdd6d4e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/fpump.c
@@ -0,0 +1,360 @@
+/* fpump.c (feasibility pump heuristic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+#include "rng.h"
+
+/***********************************************************************
+* NAME
+*
+* ios_feas_pump - feasibility pump heuristic
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void ios_feas_pump(glp_tree *T);
+*
+* DESCRIPTION
+*
+* The routine ios_feas_pump is a simple implementation of the Feasi-
+* bility Pump heuristic.
+*
+* REFERENCES
+*
+* M.Fischetti, F.Glover, and A.Lodi. "The feasibility pump." Math.
+* Program., Ser. A 104, pp. 91-104 (2005). */
+
+struct VAR
+{ /* binary variable */
+ int j;
+ /* ordinal number */
+ int x;
+ /* value in the rounded solution (0 or 1) */
+ double d;
+ /* sorting key */
+};
+
+static int CDECL fcmp(const void *x, const void *y)
+{ /* comparison routine */
+ const struct VAR *vx = x, *vy = y;
+ if (vx->d > vy->d)
+ return -1;
+ else if (vx->d < vy->d)
+ return +1;
+ else
+ return 0;
+}
+
+void ios_feas_pump(glp_tree *T)
+{ glp_prob *P = T->mip;
+ int n = P->n;
+ glp_prob *lp = NULL;
+ struct VAR *var = NULL;
+ RNG *rand = NULL;
+ GLPCOL *col;
+ glp_smcp parm;
+ int j, k, new_x, nfail, npass, nv, ret, stalling;
+ double dist, tol;
+ xassert(glp_get_status(P) == GLP_OPT);
+ /* this heuristic is applied only once on the root level */
+ if (!(T->curr->level == 0 && T->curr->solved == 1)) goto done;
+ /* determine number of binary variables */
+ nv = 0;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ /* if x[j] is continuous, skip it */
+ if (col->kind == GLP_CV) continue;
+ /* if x[j] is fixed, skip it */
+ if (col->type == GLP_FX) continue;
+ /* x[j] is non-fixed integer */
+ xassert(col->kind == GLP_IV);
+ if (col->type == GLP_DB && col->lb == 0.0 && col->ub == 1.0)
+ { /* x[j] is binary */
+ nv++;
+ }
+ else
+ { /* x[j] is general integer */
+ if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("FPUMP heuristic cannot be applied due to genera"
+ "l integer variables\n");
+ goto done;
+ }
+ }
+ /* there must be at least one binary variable */
+ if (nv == 0) goto done;
+ if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Applying FPUMP heuristic...\n");
+ /* build the list of binary variables */
+ var = xcalloc(1+nv, sizeof(struct VAR));
+ k = 0;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ if (col->kind == GLP_IV && col->type == GLP_DB)
+ var[++k].j = j;
+ }
+ xassert(k == nv);
+ /* create working problem object */
+ lp = glp_create_prob();
+more: /* copy the original problem object to keep it intact */
+ glp_copy_prob(lp, P, GLP_OFF);
+ /* we are interested to find an integer feasible solution, which
+ is better than the best known one */
+ if (P->mip_stat == GLP_FEAS)
+ { int *ind;
+ double *val, bnd;
+ /* add a row and make it identical to the objective row */
+ glp_add_rows(lp, 1);
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++)
+ { ind[j] = j;
+ val[j] = P->col[j]->coef;
+ }
+ glp_set_mat_row(lp, lp->m, n, ind, val);
+ xfree(ind);
+ xfree(val);
+ /* introduce upper (minimization) or lower (maximization)
+ bound to the original objective function; note that this
+ additional constraint is not violated at the optimal point
+ to LP relaxation */
+#if 0 /* modified by xypron <xypron.glpk@gmx.de> */
+ if (P->dir == GLP_MIN)
+ { bnd = P->mip_obj - 0.10 * (1.0 + fabs(P->mip_obj));
+ if (bnd < P->obj_val) bnd = P->obj_val;
+ glp_set_row_bnds(lp, lp->m, GLP_UP, 0.0, bnd - P->c0);
+ }
+ else if (P->dir == GLP_MAX)
+ { bnd = P->mip_obj + 0.10 * (1.0 + fabs(P->mip_obj));
+ if (bnd > P->obj_val) bnd = P->obj_val;
+ glp_set_row_bnds(lp, lp->m, GLP_LO, bnd - P->c0, 0.0);
+ }
+ else
+ xassert(P != P);
+#else
+ bnd = 0.1 * P->obj_val + 0.9 * P->mip_obj;
+ /* xprintf("bnd = %f\n", bnd); */
+ if (P->dir == GLP_MIN)
+ glp_set_row_bnds(lp, lp->m, GLP_UP, 0.0, bnd - P->c0);
+ else if (P->dir == GLP_MAX)
+ glp_set_row_bnds(lp, lp->m, GLP_LO, bnd - P->c0, 0.0);
+ else
+ xassert(P != P);
+#endif
+ }
+ /* reset pass count */
+ npass = 0;
+ /* invalidate the rounded point */
+ for (k = 1; k <= nv; k++)
+ var[k].x = -1;
+pass: /* next pass starts here */
+ npass++;
+ if (T->parm->msg_lev >= GLP_MSG_ALL)
+ xprintf("Pass %d\n", npass);
+ /* initialize minimal distance between the basic point and the
+ rounded one obtained during this pass */
+ dist = DBL_MAX;
+ /* reset failure count (the number of succeeded iterations failed
+ to improve the distance) */
+ nfail = 0;
+ /* if it is not the first pass, perturb the last rounded point
+ rather than construct it from the basic solution */
+ if (npass > 1)
+ { double rho, temp;
+ if (rand == NULL)
+ rand = rng_create_rand();
+ for (k = 1; k <= nv; k++)
+ { j = var[k].j;
+ col = lp->col[j];
+ rho = rng_uniform(rand, -0.3, 0.7);
+ if (rho < 0.0) rho = 0.0;
+ temp = fabs((double)var[k].x - col->prim);
+ if (temp + rho > 0.5) var[k].x = 1 - var[k].x;
+ }
+ goto skip;
+ }
+loop: /* innermost loop begins here */
+ /* round basic solution (which is assumed primal feasible) */
+ stalling = 1;
+ for (k = 1; k <= nv; k++)
+ { col = lp->col[var[k].j];
+ if (col->prim < 0.5)
+ { /* rounded value is 0 */
+ new_x = 0;
+ }
+ else
+ { /* rounded value is 1 */
+ new_x = 1;
+ }
+ if (var[k].x != new_x)
+ { stalling = 0;
+ var[k].x = new_x;
+ }
+ }
+ /* if the rounded point has not changed (stalling), choose and
+ flip some its entries heuristically */
+ if (stalling)
+ { /* compute d[j] = |x[j] - round(x[j])| */
+ for (k = 1; k <= nv; k++)
+ { col = lp->col[var[k].j];
+ var[k].d = fabs(col->prim - (double)var[k].x);
+ }
+ /* sort the list of binary variables by descending d[j] */
+ qsort(&var[1], nv, sizeof(struct VAR), fcmp);
+ /* choose and flip some rounded components */
+ for (k = 1; k <= nv; k++)
+ { if (k >= 5 && var[k].d < 0.35 || k >= 10) break;
+ var[k].x = 1 - var[k].x;
+ }
+ }
+skip: /* check if the time limit has been exhausted */
+ if (T->parm->tm_lim < INT_MAX &&
+ (double)(T->parm->tm_lim - 1) <=
+ 1000.0 * xdifftime(xtime(), T->tm_beg)) goto done;
+ /* build the objective, which is the distance between the current
+ (basic) point and the rounded one */
+ lp->dir = GLP_MIN;
+ lp->c0 = 0.0;
+ for (j = 1; j <= n; j++)
+ lp->col[j]->coef = 0.0;
+ for (k = 1; k <= nv; k++)
+ { j = var[k].j;
+ if (var[k].x == 0)
+ lp->col[j]->coef = +1.0;
+ else
+ { lp->col[j]->coef = -1.0;
+ lp->c0 += 1.0;
+ }
+ }
+ /* minimize the distance with the simplex method */
+ glp_init_smcp(&parm);
+ if (T->parm->msg_lev <= GLP_MSG_ERR)
+ parm.msg_lev = T->parm->msg_lev;
+ else if (T->parm->msg_lev <= GLP_MSG_ALL)
+ { parm.msg_lev = GLP_MSG_ON;
+ parm.out_dly = 10000;
+ }
+ ret = glp_simplex(lp, &parm);
+ if (ret != 0)
+ { if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: glp_simplex returned %d\n", ret);
+ goto done;
+ }
+ ret = glp_get_status(lp);
+ if (ret != GLP_OPT)
+ { if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: glp_get_status returned %d\n", ret);
+ goto done;
+ }
+ if (T->parm->msg_lev >= GLP_MSG_DBG)
+ xprintf("delta = %g\n", lp->obj_val);
+ /* check if the basic solution is integer feasible; note that it
+ may be so even if the minimial distance is positive */
+ tol = 0.3 * T->parm->tol_int;
+ for (k = 1; k <= nv; k++)
+ { col = lp->col[var[k].j];
+ if (tol < col->prim && col->prim < 1.0 - tol) break;
+ }
+ if (k > nv)
+ { /* okay; the basic solution seems to be integer feasible */
+ double *x = xcalloc(1+n, sizeof(double));
+ for (j = 1; j <= n; j++)
+ { x[j] = lp->col[j]->prim;
+ if (P->col[j]->kind == GLP_IV) x[j] = floor(x[j] + 0.5);
+ }
+#if 1 /* modified by xypron <xypron.glpk@gmx.de> */
+ /* reset direction and right-hand side of objective */
+ lp->c0 = P->c0;
+ lp->dir = P->dir;
+ /* fix integer variables */
+ for (k = 1; k <= nv; k++)
+#if 0 /* 18/VI-2013; fixed by mao
+ * this bug causes numerical instability, because column statuses
+ * are not changed appropriately */
+ { lp->col[var[k].j]->lb = x[var[k].j];
+ lp->col[var[k].j]->ub = x[var[k].j];
+ lp->col[var[k].j]->type = GLP_FX;
+ }
+#else
+ glp_set_col_bnds(lp, var[k].j, GLP_FX, x[var[k].j], 0.);
+#endif
+ /* copy original objective function */
+ for (j = 1; j <= n; j++)
+ lp->col[j]->coef = P->col[j]->coef;
+ /* solve original LP and copy result */
+ ret = glp_simplex(lp, &parm);
+ if (ret != 0)
+ { if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: glp_simplex returned %d\n", ret);
+#if 1 /* 17/III-2016: fix memory leak */
+ xfree(x);
+#endif
+ goto done;
+ }
+ ret = glp_get_status(lp);
+ if (ret != GLP_OPT)
+ { if (T->parm->msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: glp_get_status returned %d\n", ret);
+#if 1 /* 17/III-2016: fix memory leak */
+ xfree(x);
+#endif
+ goto done;
+ }
+ for (j = 1; j <= n; j++)
+ if (P->col[j]->kind != GLP_IV) x[j] = lp->col[j]->prim;
+#endif
+ ret = glp_ios_heur_sol(T, x);
+ xfree(x);
+ if (ret == 0)
+ { /* the integer solution is accepted */
+ if (ios_is_hopeful(T, T->curr->bound))
+ { /* it is reasonable to apply the heuristic once again */
+ goto more;
+ }
+ else
+ { /* the best known integer feasible solution just found
+ is close to optimal solution to LP relaxation */
+ goto done;
+ }
+ }
+ }
+ /* the basic solution is fractional */
+ if (dist == DBL_MAX ||
+ lp->obj_val <= dist - 1e-6 * (1.0 + dist))
+ { /* the distance is reducing */
+ nfail = 0, dist = lp->obj_val;
+ }
+ else
+ { /* improving the distance failed */
+ nfail++;
+ }
+ if (nfail < 3) goto loop;
+ if (npass < 5) goto pass;
+done: /* delete working objects */
+ if (lp != NULL) glp_delete_prob(lp);
+ if (var != NULL) xfree(var);
+ if (rand != NULL) rng_delete_rand(rand);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/gmicut.c b/test/monniaux/glpk-4.65/src/intopt/gmicut.c
new file mode 100644
index 00000000..4ef0b746
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/gmicut.c
@@ -0,0 +1,284 @@
+/* gmicut.c (Gomory's mixed integer cut generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2002-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_gmi_cut - generate Gomory's mixed integer cut (core routine)
+*
+* SYNOPSIS
+*
+* int glp_gmi_cut(glp_prob *P, int j, int ind[], double val[], double
+* phi[]);
+*
+* DESCRIPTION
+*
+* This routine attempts to generate a Gomory's mixed integer cut for
+* specified integer column (structural variable), whose primal value
+* in current basic solution is integer infeasible (fractional).
+*
+* On entry to the routine the basic solution contained in the problem
+* object P should be optimal, and the basis factorization should be
+* valid. The parameter j should specify the ordinal number of column
+* (structural variable x[j]), for which the cut should be generated,
+* 1 <= j <= n, where n is the number of columns in the problem object.
+* This column should be integer, non-fixed, and basic, and its primal
+* value should be fractional.
+*
+* The cut generated by the routine is the following inequality:
+*
+* sum a[j] * x[j] >= b,
+*
+* which is expected to be violated at the current basic solution.
+*
+* If the cut has been successfully generated, the routine stores its
+* non-zero coefficients a[j] and corresponding column indices j in the
+* array locations val[1], ..., val[len] and ind[1], ..., ind[len],
+* where 1 <= len <= n is the number of non-zero coefficients. The
+* right-hand side value b is stored in val[0], and ind[0] is set to 0.
+*
+* The working array phi should have 1+m+n locations (location phi[0]
+* is not used), where m and n is the number of rows and columns in the
+* problem object, resp.
+*
+* RETURNS
+*
+* If the cut has been successfully generated, the routine returns
+* len, the number of non-zero coefficients in the cut, 1 <= len <= n.
+*
+* Otherwise, the routine returns one of the following codes:
+*
+* -1 current basis factorization is not valid;
+*
+* -2 current basic solution is not optimal;
+*
+* -3 column ordinal number j is out of range;
+*
+* -4 variable x[j] is not of integral kind;
+*
+* -5 variable x[j] is either fixed or non-basic;
+*
+* -6 primal value of variable x[j] in basic solution is too close
+* to nearest integer;
+*
+* -7 some coefficients in the simplex table row corresponding to
+* variable x[j] are too large in magnitude;
+*
+* -8 some free (unbounded) variables have non-zero coefficients in
+* the simplex table row corresponding to variable x[j].
+*
+* ALGORITHM
+*
+* See glpk/doc/notes/gomory (in Russian). */
+
+#define f(x) ((x) - floor(x))
+/* compute fractional part of x */
+
+int glp_gmi_cut(glp_prob *P, int j,
+ int ind[/*1+n*/], double val[/*1+n*/], double phi[/*1+m+n*/])
+{ int m = P->m;
+ int n = P->n;
+ GLPROW *row;
+ GLPCOL *col;
+ GLPAIJ *aij;
+ int i, k, len, kind, stat;
+ double lb, ub, alfa, beta, ksi, phi1, rhs;
+ /* sanity checks */
+ if (!(P->m == 0 || P->valid))
+ { /* current basis factorization is not valid */
+ return -1;
+ }
+ if (!(P->pbs_stat == GLP_FEAS && P->dbs_stat == GLP_FEAS))
+ { /* current basic solution is not optimal */
+ return -2;
+ }
+ if (!(1 <= j && j <= n))
+ { /* column ordinal number is out of range */
+ return -3;
+ }
+ col = P->col[j];
+ if (col->kind != GLP_IV)
+ { /* x[j] is not of integral kind */
+ return -4;
+ }
+ if (col->type == GLP_FX || col->stat != GLP_BS)
+ { /* x[j] is either fixed or non-basic */
+ return -5;
+ }
+ if (fabs(col->prim - floor(col->prim + 0.5)) < 0.001)
+ { /* primal value of x[j] is too close to nearest integer */
+ return -6;
+ }
+ /* compute row of the simplex tableau, which (row) corresponds
+ * to specified basic variable xB[i] = x[j]; see (23) */
+ len = glp_eval_tab_row(P, m+j, ind, val);
+ /* determine beta[i], which a value of xB[i] in optimal solution
+ * to current LP relaxation; note that this value is the same as
+ * if it would be computed with formula (27); it is assumed that
+ * beta[i] is fractional enough */
+ beta = P->col[j]->prim;
+ /* compute cut coefficients phi and right-hand side rho, which
+ * correspond to formula (30); dense format is used, because rows
+ * of the simplex tableau are usually dense */
+ for (k = 1; k <= m+n; k++)
+ phi[k] = 0.0;
+ rhs = f(beta); /* initial value of rho; see (28), (32) */
+ for (j = 1; j <= len; j++)
+ { /* determine original number of non-basic variable xN[j] */
+ k = ind[j];
+ xassert(1 <= k && k <= m+n);
+ /* determine the kind, bounds and current status of xN[j] in
+ * optimal solution to LP relaxation */
+ if (k <= m)
+ { /* auxiliary variable */
+ row = P->row[k];
+ kind = GLP_CV;
+ lb = row->lb;
+ ub = row->ub;
+ stat = row->stat;
+ }
+ else
+ { /* structural variable */
+ col = P->col[k-m];
+ kind = col->kind;
+ lb = col->lb;
+ ub = col->ub;
+ stat = col->stat;
+ }
+ /* xN[j] cannot be basic */
+ xassert(stat != GLP_BS);
+ /* determine row coefficient ksi[i,j] at xN[j]; see (23) */
+ ksi = val[j];
+ /* if ksi[i,j] is too large in magnitude, report failure */
+ if (fabs(ksi) > 1e+05)
+ return -7;
+ /* if ksi[i,j] is too small in magnitude, skip it */
+ if (fabs(ksi) < 1e-10)
+ goto skip;
+ /* compute row coefficient alfa[i,j] at y[j]; see (26) */
+ switch (stat)
+ { case GLP_NF:
+ /* xN[j] is free (unbounded) having non-zero ksi[i,j];
+ * report failure */
+ return -8;
+ case GLP_NL:
+ /* xN[j] has active lower bound */
+ alfa = - ksi;
+ break;
+ case GLP_NU:
+ /* xN[j] has active upper bound */
+ alfa = + ksi;
+ break;
+ case GLP_NS:
+ /* xN[j] is fixed; skip it */
+ goto skip;
+ default:
+ xassert(stat != stat);
+ }
+ /* compute cut coefficient phi'[j] at y[j]; see (21), (28) */
+ switch (kind)
+ { case GLP_IV:
+ /* y[j] is integer */
+ if (fabs(alfa - floor(alfa + 0.5)) < 1e-10)
+ { /* alfa[i,j] is close to nearest integer; skip it */
+ goto skip;
+ }
+ else if (f(alfa) <= f(beta))
+ phi1 = f(alfa);
+ else
+ phi1 = (f(beta) / (1.0 - f(beta))) * (1.0 - f(alfa));
+ break;
+ case GLP_CV:
+ /* y[j] is continuous */
+ if (alfa >= 0.0)
+ phi1 = + alfa;
+ else
+ phi1 = (f(beta) / (1.0 - f(beta))) * (- alfa);
+ break;
+ default:
+ xassert(kind != kind);
+ }
+ /* compute cut coefficient phi[j] at xN[j] and update right-
+ * hand side rho; see (31), (32) */
+ switch (stat)
+ { case GLP_NL:
+ /* xN[j] has active lower bound */
+ phi[k] = + phi1;
+ rhs += phi1 * lb;
+ break;
+ case GLP_NU:
+ /* xN[j] has active upper bound */
+ phi[k] = - phi1;
+ rhs -= phi1 * ub;
+ break;
+ default:
+ xassert(stat != stat);
+ }
+skip: ;
+ }
+ /* now the cut has the form sum_k phi[k] * x[k] >= rho, where cut
+ * coefficients are stored in the array phi in dense format;
+ * x[1,...,m] are auxiliary variables, x[m+1,...,m+n] are struc-
+ * tural variables; see (30) */
+ /* eliminate auxiliary variables in order to express the cut only
+ * through structural variables; see (33) */
+ for (i = 1; i <= m; i++)
+ { if (fabs(phi[i]) < 1e-10)
+ continue;
+ /* auxiliary variable x[i] has non-zero cut coefficient */
+ row = P->row[i];
+ /* x[i] cannot be fixed variable */
+ xassert(row->type != GLP_FX);
+ /* substitute x[i] = sum_j a[i,j] * x[m+j] */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ phi[m+aij->col->j] += phi[i] * aij->val;
+ }
+ /* convert the final cut to sparse format and substitute fixed
+ * (structural) variables */
+ len = 0;
+ for (j = 1; j <= n; j++)
+ { if (fabs(phi[m+j]) < 1e-10)
+ continue;
+ /* structural variable x[m+j] has non-zero cut coefficient */
+ col = P->col[j];
+ if (col->type == GLP_FX)
+ { /* eliminate x[m+j] */
+ rhs -= phi[m+j] * col->lb;
+ }
+ else
+ { len++;
+ ind[len] = j;
+ val[len] = phi[m+j];
+ }
+ }
+ if (fabs(rhs) < 1e-12)
+ rhs = 0.0;
+ ind[0] = 0, val[0] = rhs;
+ /* the cut has been successfully generated */
+ return len;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/gmigen.c b/test/monniaux/glpk-4.65/src/intopt/gmigen.c
new file mode 100644
index 00000000..627682cb
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/gmigen.c
@@ -0,0 +1,142 @@
+/* gmigen.c (Gomory's mixed integer cuts generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2002-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "prob.h"
+
+/***********************************************************************
+* NAME
+*
+* glp_gmi_gen - generate Gomory's mixed integer cuts
+*
+* SYNOPSIS
+*
+* int glp_gmi_gen(glp_prob *P, glp_prob *pool, int max_cuts);
+*
+* DESCRIPTION
+*
+* This routine attempts to generate Gomory's mixed integer cuts for
+* integer variables, whose primal values in current basic solution are
+* integer infeasible (fractional).
+*
+* On entry to the routine the basic solution contained in the problem
+* object P should be optimal, and the basis factorization should be
+* valid.
+*
+* The cutting plane inequalities generated by the routine are added to
+* the specified cut pool.
+*
+* The parameter max_cuts specifies the maximal number of cuts to be
+* generated. Note that the number of cuts cannot exceed the number of
+* basic variables, which is the number of rows in the problem object.
+*
+* RETURNS
+*
+* The routine returns the number of cuts that have been generated and
+* added to the cut pool. */
+
+#define f(x) ((x) - floor(x))
+/* compute fractional part of x */
+
+struct var { int j; double f; };
+
+static int CDECL fcmp(const void *p1, const void *p2)
+{ const struct var *v1 = p1, *v2 = p2;
+ if (v1->f > v2->f) return -1;
+ if (v1->f < v2->f) return +1;
+ return 0;
+}
+
+int glp_gmi_gen(glp_prob *P, glp_prob *pool, int max_cuts)
+{ int m = P->m;
+ int n = P->n;
+ GLPCOL *col;
+ struct var *var;
+ int i, j, k, t, len, nv, nnn, *ind;
+ double frac, *val, *phi;
+ /* sanity checks */
+ if (!(P->m == 0 || P->valid))
+ xerror("glp_gmi_gen: basis factorization does not exist\n");
+ if (!(P->pbs_stat == GLP_FEAS && P->dbs_stat == GLP_FEAS))
+ xerror("glp_gmi_gen: optimal basic solution required\n");
+ if (pool->n != n)
+ xerror("glp_gmi_gen: cut pool has wrong number of columns\n");
+ /* allocate working arrays */
+ var = xcalloc(1+n, sizeof(struct var));
+ ind = xcalloc(1+n, sizeof(int));
+ val = xcalloc(1+n, sizeof(double));
+ phi = xcalloc(1+m+n, sizeof(double));
+ /* build the list of integer structural variables, which are
+ * basic and have integer infeasible (fractional) primal values
+ * in optimal solution to specified LP */
+ nv = 0;
+ for (j = 1; j <= n; j++)
+ { col = P->col[j];
+ if (col->kind != GLP_IV)
+ continue;
+ if (col->type == GLP_FX)
+ continue;
+ if (col->stat != GLP_BS)
+ continue;
+ frac = f(col->prim);
+ if (!(0.05 <= frac && frac <= 0.95))
+ continue;
+ /* add variable to the list */
+ nv++, var[nv].j = j, var[nv].f = frac;
+ }
+ /* sort the list by descending fractionality */
+ qsort(&var[1], nv, sizeof(struct var), fcmp);
+ /* try to generate cuts by one for each variable in the list, but
+ * not more than max_cuts cuts */
+ nnn = 0;
+ for (t = 1; t <= nv; t++)
+ { len = glp_gmi_cut(P, var[t].j, ind, val, phi);
+ if (len < 1)
+ goto skip;
+ /* if the cut inequality seems to be badly scaled, reject it
+ * to avoid numerical difficulties */
+ for (k = 1; k <= len; k++)
+ { if (fabs(val[k]) < 1e-03)
+ goto skip;
+ if (fabs(val[k]) > 1e+03)
+ goto skip;
+ }
+ /* add the cut to the cut pool for further consideration */
+ i = glp_add_rows(pool, 1);
+ glp_set_row_bnds(pool, i, GLP_LO, val[0], 0);
+ glp_set_mat_row(pool, i, len, ind, val);
+ /* one cut has been generated */
+ nnn++;
+ if (nnn == max_cuts)
+ break;
+skip: ;
+ }
+ /* free working arrays */
+ xfree(var);
+ xfree(ind);
+ xfree(val);
+ xfree(phi);
+ return nnn;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/mirgen.c b/test/monniaux/glpk-4.65/src/intopt/mirgen.c
new file mode 100644
index 00000000..45a0a55d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/mirgen.c
@@ -0,0 +1,1529 @@
+/* mirgen.c (mixed integer rounding cuts generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2007-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#if 1 /* 29/II-2016 by Chris */
+/*----------------------------------------------------------------------
+Subject: Mir cut generation performance improvement
+From: Chris Matrakidis <cmatraki@gmail.com>
+To: Andrew Makhorin <mao@gnu.org>, help-glpk <help-glpk@gnu.org>
+
+Andrew,
+
+I noticed that mir cut generation takes considerable time on some large
+problems (like rocII-4-11 from miplib). The attached patch makes two
+improvements that considerably improve performance in such instances:
+1. A lot of time was spent on generating a temporary vector in function
+aggregate_row. It is a lot faster to reuse an existing vector.
+2. A search for an element in the same function was done in row order,
+where using the elements in the order they are in the column is more
+efficient. This changes the generated cuts in some cases, but seems
+neutral overall (0.3% less cuts in a test set of 64 miplib instances).
+
+Best Regards,
+
+Chris Matrakidis
+----------------------------------------------------------------------*/
+#endif
+
+#include "env.h"
+#include "prob.h"
+#include "spv.h"
+
+#define MIR_DEBUG 0
+
+#define MAXAGGR 5
+/* maximal number of rows that can be aggregated */
+
+struct glp_mir
+{ /* MIR cut generator working area */
+ /*--------------------------------------------------------------*/
+ /* global information valid for the root subproblem */
+ int m;
+ /* number of rows (in the root subproblem) */
+ int n;
+ /* number of columns */
+ char *skip; /* char skip[1+m]; */
+ /* skip[i], 1 <= i <= m, is a flag that means that row i should
+ not be used because (1) it is not suitable, or (2) because it
+ has been used in the aggregated constraint */
+ char *isint; /* char isint[1+m+n]; */
+ /* isint[k], 1 <= k <= m+n, is a flag that means that variable
+ x[k] is integer (otherwise, continuous) */
+ double *lb; /* double lb[1+m+n]; */
+ /* lb[k], 1 <= k <= m+n, is lower bound of x[k]; -DBL_MAX means
+ that x[k] has no lower bound */
+ int *vlb; /* int vlb[1+m+n]; */
+ /* vlb[k] = k', 1 <= k <= m+n, is the number of integer variable,
+ which defines variable lower bound x[k] >= lb[k] * x[k']; zero
+ means that x[k] has simple lower bound */
+ double *ub; /* double ub[1+m+n]; */
+ /* ub[k], 1 <= k <= m+n, is upper bound of x[k]; +DBL_MAX means
+ that x[k] has no upper bound */
+ int *vub; /* int vub[1+m+n]; */
+ /* vub[k] = k', 1 <= k <= m+n, is the number of integer variable,
+ which defines variable upper bound x[k] <= ub[k] * x[k']; zero
+ means that x[k] has simple upper bound */
+ /*--------------------------------------------------------------*/
+ /* current (fractional) point to be separated */
+ double *x; /* double x[1+m+n]; */
+ /* x[k] is current value of auxiliary (1 <= k <= m) or structural
+ (m+1 <= k <= m+n) variable */
+ /*--------------------------------------------------------------*/
+ /* aggregated constraint sum a[k] * x[k] = b, which is a linear
+ combination of original constraints transformed to equalities
+ by introducing auxiliary variables */
+ int agg_cnt;
+ /* number of rows (original constraints) used to build aggregated
+ constraint, 1 <= agg_cnt <= MAXAGGR */
+ int *agg_row; /* int agg_row[1+MAXAGGR]; */
+ /* agg_row[k], 1 <= k <= agg_cnt, is the row number used to build
+ aggregated constraint */
+ SPV *agg_vec; /* SPV agg_vec[1:m+n]; */
+ /* sparse vector of aggregated constraint coefficients, a[k] */
+ double agg_rhs;
+ /* right-hand side of the aggregated constraint, b */
+ /*--------------------------------------------------------------*/
+ /* bound substitution flags for modified constraint */
+ char *subst; /* char subst[1+m+n]; */
+ /* subst[k], 1 <= k <= m+n, is a bound substitution flag used for
+ variable x[k]:
+ '?' - x[k] is missing in modified constraint
+ 'L' - x[k] = (lower bound) + x'[k]
+ 'U' - x[k] = (upper bound) - x'[k] */
+ /*--------------------------------------------------------------*/
+ /* modified constraint sum a'[k] * x'[k] = b', where x'[k] >= 0,
+ derived from aggregated constraint by substituting bounds;
+ note that due to substitution of variable bounds there may be
+ additional terms in the modified constraint */
+ SPV *mod_vec; /* SPV mod_vec[1:m+n]; */
+ /* sparse vector of modified constraint coefficients, a'[k] */
+ double mod_rhs;
+ /* right-hand side of the modified constraint, b' */
+ /*--------------------------------------------------------------*/
+ /* cutting plane sum alpha[k] * x[k] <= beta */
+ SPV *cut_vec; /* SPV cut_vec[1:m+n]; */
+ /* sparse vector of cutting plane coefficients, alpha[k] */
+ double cut_rhs;
+ /* right-hand size of the cutting plane, beta */
+};
+
+/***********************************************************************
+* NAME
+*
+* glp_mir_init - create and initialize MIR cut generator
+*
+* SYNOPSIS
+*
+* glp_mir *glp_mir_init(glp_prob *P);
+*
+* DESCRIPTION
+*
+* This routine creates and initializes the MIR cut generator for the
+* specified problem object.
+*
+* RETURNS
+*
+* The routine returns a pointer to the MIR cut generator workspace. */
+
+static void set_row_attrib(glp_prob *mip, glp_mir *mir)
+{ /* set global row attributes */
+ int m = mir->m;
+ int k;
+ for (k = 1; k <= m; k++)
+ { GLPROW *row = mip->row[k];
+ mir->skip[k] = 0;
+ mir->isint[k] = 0;
+ switch (row->type)
+ { case GLP_FR:
+ mir->lb[k] = -DBL_MAX, mir->ub[k] = +DBL_MAX; break;
+ case GLP_LO:
+ mir->lb[k] = row->lb, mir->ub[k] = +DBL_MAX; break;
+ case GLP_UP:
+ mir->lb[k] = -DBL_MAX, mir->ub[k] = row->ub; break;
+ case GLP_DB:
+ mir->lb[k] = row->lb, mir->ub[k] = row->ub; break;
+ case GLP_FX:
+ mir->lb[k] = mir->ub[k] = row->lb; break;
+ default:
+ xassert(row != row);
+ }
+ mir->vlb[k] = mir->vub[k] = 0;
+ }
+ return;
+}
+
+static void set_col_attrib(glp_prob *mip, glp_mir *mir)
+{ /* set global column attributes */
+ int m = mir->m;
+ int n = mir->n;
+ int k;
+ for (k = m+1; k <= m+n; k++)
+ { GLPCOL *col = mip->col[k-m];
+ switch (col->kind)
+ { case GLP_CV:
+ mir->isint[k] = 0; break;
+ case GLP_IV:
+ mir->isint[k] = 1; break;
+ default:
+ xassert(col != col);
+ }
+ switch (col->type)
+ { case GLP_FR:
+ mir->lb[k] = -DBL_MAX, mir->ub[k] = +DBL_MAX; break;
+ case GLP_LO:
+ mir->lb[k] = col->lb, mir->ub[k] = +DBL_MAX; break;
+ case GLP_UP:
+ mir->lb[k] = -DBL_MAX, mir->ub[k] = col->ub; break;
+ case GLP_DB:
+ mir->lb[k] = col->lb, mir->ub[k] = col->ub; break;
+ case GLP_FX:
+ mir->lb[k] = mir->ub[k] = col->lb; break;
+ default:
+ xassert(col != col);
+ }
+ mir->vlb[k] = mir->vub[k] = 0;
+ }
+ return;
+}
+
+static void set_var_bounds(glp_prob *mip, glp_mir *mir)
+{ /* set variable bounds */
+ int m = mir->m;
+ GLPAIJ *aij;
+ int i, k1, k2;
+ double a1, a2;
+ for (i = 1; i <= m; i++)
+ { /* we need the row to be '>= 0' or '<= 0' */
+ if (!(mir->lb[i] == 0.0 && mir->ub[i] == +DBL_MAX ||
+ mir->lb[i] == -DBL_MAX && mir->ub[i] == 0.0)) continue;
+ /* take first term */
+ aij = mip->row[i]->ptr;
+ if (aij == NULL) continue;
+ k1 = m + aij->col->j, a1 = aij->val;
+ /* take second term */
+ aij = aij->r_next;
+ if (aij == NULL) continue;
+ k2 = m + aij->col->j, a2 = aij->val;
+ /* there must be only two terms */
+ if (aij->r_next != NULL) continue;
+ /* interchange terms, if needed */
+ if (!mir->isint[k1] && mir->isint[k2])
+ ;
+ else if (mir->isint[k1] && !mir->isint[k2])
+ { k2 = k1, a2 = a1;
+ k1 = m + aij->col->j, a1 = aij->val;
+ }
+ else
+ { /* both terms are either continuous or integer */
+ continue;
+ }
+ /* x[k2] should be double-bounded */
+ if (mir->lb[k2] == -DBL_MAX || mir->ub[k2] == +DBL_MAX ||
+ mir->lb[k2] == mir->ub[k2]) continue;
+ /* change signs, if necessary */
+ if (mir->ub[i] == 0.0) a1 = - a1, a2 = - a2;
+ /* now the row has the form a1 * x1 + a2 * x2 >= 0, where x1
+ is continuous, x2 is integer */
+ if (a1 > 0.0)
+ { /* x1 >= - (a2 / a1) * x2 */
+ if (mir->vlb[k1] == 0)
+ { /* set variable lower bound for x1 */
+ mir->lb[k1] = - a2 / a1;
+ mir->vlb[k1] = k2;
+ /* the row should not be used */
+ mir->skip[i] = 1;
+ }
+ }
+ else /* a1 < 0.0 */
+ { /* x1 <= - (a2 / a1) * x2 */
+ if (mir->vub[k1] == 0)
+ { /* set variable upper bound for x1 */
+ mir->ub[k1] = - a2 / a1;
+ mir->vub[k1] = k2;
+ /* the row should not be used */
+ mir->skip[i] = 1;
+ }
+ }
+ }
+ return;
+}
+
+static void mark_useless_rows(glp_prob *mip, glp_mir *mir)
+{ /* mark rows which should not be used */
+ int m = mir->m;
+ GLPAIJ *aij;
+ int i, k, nv;
+ for (i = 1; i <= m; i++)
+ { /* free rows should not be used */
+ if (mir->lb[i] == -DBL_MAX && mir->ub[i] == +DBL_MAX)
+ { mir->skip[i] = 1;
+ continue;
+ }
+ nv = 0;
+ for (aij = mip->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ { k = m + aij->col->j;
+ /* rows with free variables should not be used */
+ if (mir->lb[k] == -DBL_MAX && mir->ub[k] == +DBL_MAX)
+ { mir->skip[i] = 1;
+ break;
+ }
+ /* rows with integer variables having infinite (lower or
+ upper) bound should not be used */
+ if (mir->isint[k] && mir->lb[k] == -DBL_MAX ||
+ mir->isint[k] && mir->ub[k] == +DBL_MAX)
+ { mir->skip[i] = 1;
+ break;
+ }
+ /* count non-fixed variables */
+ if (!(mir->vlb[k] == 0 && mir->vub[k] == 0 &&
+ mir->lb[k] == mir->ub[k])) nv++;
+ }
+ /* rows with all variables fixed should not be used */
+ if (nv == 0)
+ { mir->skip[i] = 1;
+ continue;
+ }
+ }
+ return;
+}
+
+glp_mir *glp_mir_init(glp_prob *mip)
+{ /* create and initialize MIR cut generator */
+ int m = mip->m;
+ int n = mip->n;
+ glp_mir *mir;
+#if MIR_DEBUG
+ xprintf("ios_mir_init: warning: debug mode enabled\n");
+#endif
+ /* allocate working area */
+ mir = xmalloc(sizeof(glp_mir));
+ mir->m = m;
+ mir->n = n;
+ mir->skip = xcalloc(1+m, sizeof(char));
+ mir->isint = xcalloc(1+m+n, sizeof(char));
+ mir->lb = xcalloc(1+m+n, sizeof(double));
+ mir->vlb = xcalloc(1+m+n, sizeof(int));
+ mir->ub = xcalloc(1+m+n, sizeof(double));
+ mir->vub = xcalloc(1+m+n, sizeof(int));
+ mir->x = xcalloc(1+m+n, sizeof(double));
+ mir->agg_row = xcalloc(1+MAXAGGR, sizeof(int));
+ mir->agg_vec = spv_create_vec(m+n);
+ mir->subst = xcalloc(1+m+n, sizeof(char));
+ mir->mod_vec = spv_create_vec(m+n);
+ mir->cut_vec = spv_create_vec(m+n);
+ /* set global row attributes */
+ set_row_attrib(mip, mir);
+ /* set global column attributes */
+ set_col_attrib(mip, mir);
+ /* set variable bounds */
+ set_var_bounds(mip, mir);
+ /* mark rows which should not be used */
+ mark_useless_rows(mip, mir);
+ return mir;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mir_gen - generate mixed integer rounding (MIR) cuts
+*
+* SYNOPSIS
+*
+* int glp_mir_gen(glp_prob *P, glp_mir *mir, glp_prob *pool);
+*
+* DESCRIPTION
+*
+* This routine attempts to generate mixed integer rounding (MIR) cuts
+* for current basic solution to the specified problem object.
+*
+* The cutting plane inequalities generated by the routine are added to
+* the specified cut pool.
+*
+* RETURNS
+*
+* The routine returns the number of cuts that have been generated and
+* added to the cut pool. */
+
+static void get_current_point(glp_prob *mip, glp_mir *mir)
+{ /* obtain current point */
+ int m = mir->m;
+ int n = mir->n;
+ int k;
+ for (k = 1; k <= m; k++)
+ mir->x[k] = mip->row[k]->prim;
+ for (k = m+1; k <= m+n; k++)
+ mir->x[k] = mip->col[k-m]->prim;
+ return;
+}
+
+#if MIR_DEBUG
+static void check_current_point(glp_mir *mir)
+{ /* check current point */
+ int m = mir->m;
+ int n = mir->n;
+ int k, kk;
+ double lb, ub, eps;
+ for (k = 1; k <= m+n; k++)
+ { /* determine lower bound */
+ lb = mir->lb[k];
+ kk = mir->vlb[k];
+ if (kk != 0)
+ { xassert(lb != -DBL_MAX);
+ xassert(!mir->isint[k]);
+ xassert(mir->isint[kk]);
+ lb *= mir->x[kk];
+ }
+ /* check lower bound */
+ if (lb != -DBL_MAX)
+ { eps = 1e-6 * (1.0 + fabs(lb));
+ xassert(mir->x[k] >= lb - eps);
+ }
+ /* determine upper bound */
+ ub = mir->ub[k];
+ kk = mir->vub[k];
+ if (kk != 0)
+ { xassert(ub != +DBL_MAX);
+ xassert(!mir->isint[k]);
+ xassert(mir->isint[kk]);
+ ub *= mir->x[kk];
+ }
+ /* check upper bound */
+ if (ub != +DBL_MAX)
+ { eps = 1e-6 * (1.0 + fabs(ub));
+ xassert(mir->x[k] <= ub + eps);
+ }
+ }
+ return;
+}
+#endif
+
+static void initial_agg_row(glp_prob *mip, glp_mir *mir, int i)
+{ /* use original i-th row as initial aggregated constraint */
+ int m = mir->m;
+ GLPAIJ *aij;
+ xassert(1 <= i && i <= m);
+ xassert(!mir->skip[i]);
+ /* mark i-th row in order not to use it in the same aggregated
+ constraint */
+ mir->skip[i] = 2;
+ mir->agg_cnt = 1;
+ mir->agg_row[1] = i;
+ /* use x[i] - sum a[i,j] * x[m+j] = 0, where x[i] is auxiliary
+ variable of row i, x[m+j] are structural variables */
+ spv_clear_vec(mir->agg_vec);
+ spv_set_vj(mir->agg_vec, i, 1.0);
+ for (aij = mip->row[i]->ptr; aij != NULL; aij = aij->r_next)
+ spv_set_vj(mir->agg_vec, m + aij->col->j, - aij->val);
+ mir->agg_rhs = 0.0;
+#if MIR_DEBUG
+ spv_check_vec(mir->agg_vec);
+#endif
+ return;
+}
+
+#if MIR_DEBUG
+static void check_agg_row(glp_mir *mir)
+{ /* check aggregated constraint */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k;
+ double r, big;
+ /* compute the residual r = sum a[k] * x[k] - b and determine
+ big = max(1, |a[k]|, |b|) */
+ r = 0.0, big = 1.0;
+ for (j = 1; j <= mir->agg_vec->nnz; j++)
+ { k = mir->agg_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ r += mir->agg_vec->val[j] * mir->x[k];
+ if (big < fabs(mir->agg_vec->val[j]))
+ big = fabs(mir->agg_vec->val[j]);
+ }
+ r -= mir->agg_rhs;
+ if (big < fabs(mir->agg_rhs))
+ big = fabs(mir->agg_rhs);
+ /* the residual must be close to zero */
+ xassert(fabs(r) <= 1e-6 * big);
+ return;
+}
+#endif
+
+static void subst_fixed_vars(glp_mir *mir)
+{ /* substitute fixed variables into aggregated constraint */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k;
+ for (j = 1; j <= mir->agg_vec->nnz; j++)
+ { k = mir->agg_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->vlb[k] == 0 && mir->vub[k] == 0 &&
+ mir->lb[k] == mir->ub[k])
+ { /* x[k] is fixed */
+ mir->agg_rhs -= mir->agg_vec->val[j] * mir->lb[k];
+ mir->agg_vec->val[j] = 0.0;
+ }
+ }
+ /* remove terms corresponding to fixed variables */
+ spv_clean_vec(mir->agg_vec, DBL_EPSILON);
+#if MIR_DEBUG
+ spv_check_vec(mir->agg_vec);
+#endif
+ return;
+}
+
+static void bound_subst_heur(glp_mir *mir)
+{ /* bound substitution heuristic */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k, kk;
+ double d1, d2;
+ for (j = 1; j <= mir->agg_vec->nnz; j++)
+ { k = mir->agg_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->isint[k]) continue; /* skip integer variable */
+ /* compute distance from x[k] to its lower bound */
+ kk = mir->vlb[k];
+ if (kk == 0)
+ { if (mir->lb[k] == -DBL_MAX)
+ d1 = DBL_MAX;
+ else
+ d1 = mir->x[k] - mir->lb[k];
+ }
+ else
+ { xassert(1 <= kk && kk <= m+n);
+ xassert(mir->isint[kk]);
+ xassert(mir->lb[k] != -DBL_MAX);
+ d1 = mir->x[k] - mir->lb[k] * mir->x[kk];
+ }
+ /* compute distance from x[k] to its upper bound */
+ kk = mir->vub[k];
+ if (kk == 0)
+ { if (mir->vub[k] == +DBL_MAX)
+ d2 = DBL_MAX;
+ else
+ d2 = mir->ub[k] - mir->x[k];
+ }
+ else
+ { xassert(1 <= kk && kk <= m+n);
+ xassert(mir->isint[kk]);
+ xassert(mir->ub[k] != +DBL_MAX);
+ d2 = mir->ub[k] * mir->x[kk] - mir->x[k];
+ }
+ /* x[k] cannot be free */
+ xassert(d1 != DBL_MAX || d2 != DBL_MAX);
+ /* choose the bound which is closer to x[k] */
+ xassert(mir->subst[k] == '?');
+ if (d1 <= d2)
+ mir->subst[k] = 'L';
+ else
+ mir->subst[k] = 'U';
+ }
+ return;
+}
+
+static void build_mod_row(glp_mir *mir)
+{ /* substitute bounds and build modified constraint */
+ int m = mir->m;
+ int n = mir->n;
+ int j, jj, k, kk;
+ /* initially modified constraint is aggregated constraint */
+ spv_copy_vec(mir->mod_vec, mir->agg_vec);
+ mir->mod_rhs = mir->agg_rhs;
+#if MIR_DEBUG
+ spv_check_vec(mir->mod_vec);
+#endif
+ /* substitute bounds for continuous variables; note that due to
+ substitution of variable bounds additional terms may appear in
+ modified constraint */
+ for (j = mir->mod_vec->nnz; j >= 1; j--)
+ { k = mir->mod_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->isint[k]) continue; /* skip integer variable */
+ if (mir->subst[k] == 'L')
+ { /* x[k] = (lower bound) + x'[k] */
+ xassert(mir->lb[k] != -DBL_MAX);
+ kk = mir->vlb[k];
+ if (kk == 0)
+ { /* x[k] = lb[k] + x'[k] */
+ mir->mod_rhs -= mir->mod_vec->val[j] * mir->lb[k];
+ }
+ else
+ { /* x[k] = lb[k] * x[kk] + x'[k] */
+ xassert(mir->isint[kk]);
+ jj = mir->mod_vec->pos[kk];
+ if (jj == 0)
+ { spv_set_vj(mir->mod_vec, kk, 1.0);
+ jj = mir->mod_vec->pos[kk];
+ mir->mod_vec->val[jj] = 0.0;
+ }
+ mir->mod_vec->val[jj] +=
+ mir->mod_vec->val[j] * mir->lb[k];
+ }
+ }
+ else if (mir->subst[k] == 'U')
+ { /* x[k] = (upper bound) - x'[k] */
+ xassert(mir->ub[k] != +DBL_MAX);
+ kk = mir->vub[k];
+ if (kk == 0)
+ { /* x[k] = ub[k] - x'[k] */
+ mir->mod_rhs -= mir->mod_vec->val[j] * mir->ub[k];
+ }
+ else
+ { /* x[k] = ub[k] * x[kk] - x'[k] */
+ xassert(mir->isint[kk]);
+ jj = mir->mod_vec->pos[kk];
+ if (jj == 0)
+ { spv_set_vj(mir->mod_vec, kk, 1.0);
+ jj = mir->mod_vec->pos[kk];
+ mir->mod_vec->val[jj] = 0.0;
+ }
+ mir->mod_vec->val[jj] +=
+ mir->mod_vec->val[j] * mir->ub[k];
+ }
+ mir->mod_vec->val[j] = - mir->mod_vec->val[j];
+ }
+ else
+ xassert(k != k);
+ }
+#if MIR_DEBUG
+ spv_check_vec(mir->mod_vec);
+#endif
+ /* substitute bounds for integer variables */
+ for (j = 1; j <= mir->mod_vec->nnz; j++)
+ { k = mir->mod_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (!mir->isint[k]) continue; /* skip continuous variable */
+ xassert(mir->subst[k] == '?');
+ xassert(mir->vlb[k] == 0 && mir->vub[k] == 0);
+ xassert(mir->lb[k] != -DBL_MAX && mir->ub[k] != +DBL_MAX);
+ if (fabs(mir->lb[k]) <= fabs(mir->ub[k]))
+ { /* x[k] = lb[k] + x'[k] */
+ mir->subst[k] = 'L';
+ mir->mod_rhs -= mir->mod_vec->val[j] * mir->lb[k];
+ }
+ else
+ { /* x[k] = ub[k] - x'[k] */
+ mir->subst[k] = 'U';
+ mir->mod_rhs -= mir->mod_vec->val[j] * mir->ub[k];
+ mir->mod_vec->val[j] = - mir->mod_vec->val[j];
+ }
+ }
+#if MIR_DEBUG
+ spv_check_vec(mir->mod_vec);
+#endif
+ return;
+}
+
+#if MIR_DEBUG
+static void check_mod_row(glp_mir *mir)
+{ /* check modified constraint */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k, kk;
+ double r, big, x;
+ /* compute the residual r = sum a'[k] * x'[k] - b' and determine
+ big = max(1, |a[k]|, |b|) */
+ r = 0.0, big = 1.0;
+ for (j = 1; j <= mir->mod_vec->nnz; j++)
+ { k = mir->mod_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->subst[k] == 'L')
+ { /* x'[k] = x[k] - (lower bound) */
+ xassert(mir->lb[k] != -DBL_MAX);
+ kk = mir->vlb[k];
+ if (kk == 0)
+ x = mir->x[k] - mir->lb[k];
+ else
+ x = mir->x[k] - mir->lb[k] * mir->x[kk];
+ }
+ else if (mir->subst[k] == 'U')
+ { /* x'[k] = (upper bound) - x[k] */
+ xassert(mir->ub[k] != +DBL_MAX);
+ kk = mir->vub[k];
+ if (kk == 0)
+ x = mir->ub[k] - mir->x[k];
+ else
+ x = mir->ub[k] * mir->x[kk] - mir->x[k];
+ }
+ else
+ xassert(k != k);
+ r += mir->mod_vec->val[j] * x;
+ if (big < fabs(mir->mod_vec->val[j]))
+ big = fabs(mir->mod_vec->val[j]);
+ }
+ r -= mir->mod_rhs;
+ if (big < fabs(mir->mod_rhs))
+ big = fabs(mir->mod_rhs);
+ /* the residual must be close to zero */
+ xassert(fabs(r) <= 1e-6 * big);
+ return;
+}
+#endif
+
+/***********************************************************************
+* mir_ineq - construct MIR inequality
+*
+* Given the single constraint mixed integer set
+*
+* |N|
+* X = {(x,s) in Z x R : sum a[j] * x[j] <= b + s},
+* + + j in N
+*
+* this routine constructs the mixed integer rounding (MIR) inequality
+*
+* sum alpha[j] * x[j] <= beta + gamma * s,
+* j in N
+*
+* which is valid for X.
+*
+* If the MIR inequality has been successfully constructed, the routine
+* returns zero. Otherwise, if b is close to nearest integer, there may
+* be numeric difficulties due to big coefficients; so in this case the
+* routine returns non-zero. */
+
+static int mir_ineq(const int n, const double a[], const double b,
+ double alpha[], double *beta, double *gamma)
+{ int j;
+ double f, t;
+ if (fabs(b - floor(b + .5)) < 0.01)
+ return 1;
+ f = b - floor(b);
+ for (j = 1; j <= n; j++)
+ { t = (a[j] - floor(a[j])) - f;
+ if (t <= 0.0)
+ alpha[j] = floor(a[j]);
+ else
+ alpha[j] = floor(a[j]) + t / (1.0 - f);
+ }
+ *beta = floor(b);
+ *gamma = 1.0 / (1.0 - f);
+ return 0;
+}
+
+/***********************************************************************
+* cmir_ineq - construct c-MIR inequality
+*
+* Given the mixed knapsack set
+*
+* MK |N|
+* X = {(x,s) in Z x R : sum a[j] * x[j] <= b + s,
+* + + j in N
+*
+* x[j] <= u[j]},
+*
+* a subset C of variables to be complemented, and a divisor delta > 0,
+* this routine constructs the complemented MIR (c-MIR) inequality
+*
+* sum alpha[j] * x[j] <= beta + gamma * s,
+* j in N
+* MK
+* which is valid for X .
+*
+* If the c-MIR inequality has been successfully constructed, the
+* routine returns zero. Otherwise, if there is a risk of numerical
+* difficulties due to big coefficients (see comments to the routine
+* mir_ineq), the routine cmir_ineq returns non-zero. */
+
+static int cmir_ineq(const int n, const double a[], const double b,
+ const double u[], const char cset[], const double delta,
+ double alpha[], double *beta, double *gamma)
+{ int j;
+ double *aa, bb;
+ aa = alpha, bb = b;
+ for (j = 1; j <= n; j++)
+ { aa[j] = a[j] / delta;
+ if (cset[j])
+ aa[j] = - aa[j], bb -= a[j] * u[j];
+ }
+ bb /= delta;
+ if (mir_ineq(n, aa, bb, alpha, beta, gamma)) return 1;
+ for (j = 1; j <= n; j++)
+ { if (cset[j])
+ alpha[j] = - alpha[j], *beta += alpha[j] * u[j];
+ }
+ *gamma /= delta;
+ return 0;
+}
+
+/***********************************************************************
+* cmir_sep - c-MIR separation heuristic
+*
+* Given the mixed knapsack set
+*
+* MK |N|
+* X = {(x,s) in Z x R : sum a[j] * x[j] <= b + s,
+* + + j in N
+*
+* x[j] <= u[j]}
+*
+* * *
+* and a fractional point (x , s ), this routine tries to construct
+* c-MIR inequality
+*
+* sum alpha[j] * x[j] <= beta + gamma * s,
+* j in N
+* MK
+* which is valid for X and has (desirably maximal) violation at the
+* fractional point given. This is attained by choosing an appropriate
+* set C of variables to be complemented and a divisor delta > 0, which
+* together define corresponding c-MIR inequality.
+*
+* If a violated c-MIR inequality has been successfully constructed,
+* the routine returns its violation:
+*
+* * *
+* sum alpha[j] * x [j] - beta - gamma * s ,
+* j in N
+*
+* which is positive. In case of failure the routine returns zero. */
+
+struct vset { int j; double v; };
+
+static int CDECL cmir_cmp(const void *p1, const void *p2)
+{ const struct vset *v1 = p1, *v2 = p2;
+ if (v1->v < v2->v) return -1;
+ if (v1->v > v2->v) return +1;
+ return 0;
+}
+
+static double cmir_sep(const int n, const double a[], const double b,
+ const double u[], const double x[], const double s,
+ double alpha[], double *beta, double *gamma)
+{ int fail, j, k, nv, v;
+ double delta, eps, d_try[1+3], r, r_best;
+ char *cset;
+ struct vset *vset;
+ /* allocate working arrays */
+ cset = xcalloc(1+n, sizeof(char));
+ vset = xcalloc(1+n, sizeof(struct vset));
+ /* choose initial C */
+ for (j = 1; j <= n; j++)
+ cset[j] = (char)(x[j] >= 0.5 * u[j]);
+ /* choose initial delta */
+ r_best = delta = 0.0;
+ for (j = 1; j <= n; j++)
+ { xassert(a[j] != 0.0);
+ /* if x[j] is close to its bounds, skip it */
+ eps = 1e-9 * (1.0 + fabs(u[j]));
+ if (x[j] < eps || x[j] > u[j] - eps) continue;
+ /* try delta = |a[j]| to construct c-MIR inequality */
+ fail = cmir_ineq(n, a, b, u, cset, fabs(a[j]), alpha, beta,
+ gamma);
+ if (fail) continue;
+ /* compute violation */
+ r = - (*beta) - (*gamma) * s;
+ for (k = 1; k <= n; k++) r += alpha[k] * x[k];
+ if (r_best < r) r_best = r, delta = fabs(a[j]);
+ }
+ if (r_best < 0.001) r_best = 0.0;
+ if (r_best == 0.0) goto done;
+ xassert(delta > 0.0);
+ /* try to increase violation by dividing delta by 2, 4, and 8,
+ respectively */
+ d_try[1] = delta / 2.0;
+ d_try[2] = delta / 4.0;
+ d_try[3] = delta / 8.0;
+ for (j = 1; j <= 3; j++)
+ { /* construct c-MIR inequality */
+ fail = cmir_ineq(n, a, b, u, cset, d_try[j], alpha, beta,
+ gamma);
+ if (fail) continue;
+ /* compute violation */
+ r = - (*beta) - (*gamma) * s;
+ for (k = 1; k <= n; k++) r += alpha[k] * x[k];
+ if (r_best < r) r_best = r, delta = d_try[j];
+ }
+ /* build subset of variables lying strictly between their bounds
+ and order it by nondecreasing values of |x[j] - u[j]/2| */
+ nv = 0;
+ for (j = 1; j <= n; j++)
+ { /* if x[j] is close to its bounds, skip it */
+ eps = 1e-9 * (1.0 + fabs(u[j]));
+ if (x[j] < eps || x[j] > u[j] - eps) continue;
+ /* add x[j] to the subset */
+ nv++;
+ vset[nv].j = j;
+ vset[nv].v = fabs(x[j] - 0.5 * u[j]);
+ }
+ qsort(&vset[1], nv, sizeof(struct vset), cmir_cmp);
+ /* try to increase violation by successively complementing each
+ variable in the subset */
+ for (v = 1; v <= nv; v++)
+ { j = vset[v].j;
+ /* replace x[j] by its complement or vice versa */
+ cset[j] = (char)!cset[j];
+ /* construct c-MIR inequality */
+ fail = cmir_ineq(n, a, b, u, cset, delta, alpha, beta, gamma);
+ /* restore the variable */
+ cset[j] = (char)!cset[j];
+ /* do not replace the variable in case of failure */
+ if (fail) continue;
+ /* compute violation */
+ r = - (*beta) - (*gamma) * s;
+ for (k = 1; k <= n; k++) r += alpha[k] * x[k];
+ if (r_best < r) r_best = r, cset[j] = (char)!cset[j];
+ }
+ /* construct the best c-MIR inequality chosen */
+ fail = cmir_ineq(n, a, b, u, cset, delta, alpha, beta, gamma);
+ xassert(!fail);
+done: /* free working arrays */
+ xfree(cset);
+ xfree(vset);
+ /* return to the calling routine */
+ return r_best;
+}
+
+static double generate(glp_mir *mir)
+{ /* try to generate violated c-MIR cut for modified constraint */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k, kk, nint;
+ double s, *u, *x, *alpha, r_best = 0.0, b, beta, gamma;
+ spv_copy_vec(mir->cut_vec, mir->mod_vec);
+ mir->cut_rhs = mir->mod_rhs;
+ /* remove small terms, which can appear due to substitution of
+ variable bounds */
+ spv_clean_vec(mir->cut_vec, DBL_EPSILON);
+#if MIR_DEBUG
+ spv_check_vec(mir->cut_vec);
+#endif
+ /* remove positive continuous terms to obtain MK relaxation */
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (!mir->isint[k] && mir->cut_vec->val[j] > 0.0)
+ mir->cut_vec->val[j] = 0.0;
+ }
+ spv_clean_vec(mir->cut_vec, 0.0);
+#if MIR_DEBUG
+ spv_check_vec(mir->cut_vec);
+#endif
+ /* move integer terms to the beginning of the sparse vector and
+ determine the number of integer variables */
+ nint = 0;
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->isint[k])
+ { double temp;
+ nint++;
+ /* interchange elements [nint] and [j] */
+ kk = mir->cut_vec->ind[nint];
+ mir->cut_vec->pos[k] = nint;
+ mir->cut_vec->pos[kk] = j;
+ mir->cut_vec->ind[nint] = k;
+ mir->cut_vec->ind[j] = kk;
+ temp = mir->cut_vec->val[nint];
+ mir->cut_vec->val[nint] = mir->cut_vec->val[j];
+ mir->cut_vec->val[j] = temp;
+ }
+ }
+#if MIR_DEBUG
+ spv_check_vec(mir->cut_vec);
+#endif
+ /* if there is no integer variable, nothing to generate */
+ if (nint == 0) goto done;
+ /* allocate working arrays */
+ u = xcalloc(1+nint, sizeof(double));
+ x = xcalloc(1+nint, sizeof(double));
+ alpha = xcalloc(1+nint, sizeof(double));
+ /* determine u and x */
+ for (j = 1; j <= nint; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(m+1 <= k && k <= m+n);
+ xassert(mir->isint[k]);
+ u[j] = mir->ub[k] - mir->lb[k];
+ xassert(u[j] >= 1.0);
+ if (mir->subst[k] == 'L')
+ x[j] = mir->x[k] - mir->lb[k];
+ else if (mir->subst[k] == 'U')
+ x[j] = mir->ub[k] - mir->x[k];
+ else
+ xassert(k != k);
+#if 0 /* 06/III-2016; notorious bug reported many times */
+ xassert(x[j] >= -0.001);
+#else
+ if (x[j] < -0.001)
+ { xprintf("glp_mir_gen: warning: x[%d] = %g\n", j, x[j]);
+ r_best = 0.0;
+ goto skip;
+ }
+#endif
+ if (x[j] < 0.0) x[j] = 0.0;
+ }
+ /* compute s = - sum of continuous terms */
+ s = 0.0;
+ for (j = nint+1; j <= mir->cut_vec->nnz; j++)
+ { double x;
+ k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ /* must be continuous */
+ xassert(!mir->isint[k]);
+ if (mir->subst[k] == 'L')
+ { xassert(mir->lb[k] != -DBL_MAX);
+ kk = mir->vlb[k];
+ if (kk == 0)
+ x = mir->x[k] - mir->lb[k];
+ else
+ x = mir->x[k] - mir->lb[k] * mir->x[kk];
+ }
+ else if (mir->subst[k] == 'U')
+ { xassert(mir->ub[k] != +DBL_MAX);
+ kk = mir->vub[k];
+ if (kk == 0)
+ x = mir->ub[k] - mir->x[k];
+ else
+ x = mir->ub[k] * mir->x[kk] - mir->x[k];
+ }
+ else
+ xassert(k != k);
+#if 0 /* 06/III-2016; notorious bug reported many times */
+ xassert(x >= -0.001);
+#else
+ if (x < -0.001)
+ { xprintf("glp_mir_gen: warning: x = %g\n", x);
+ r_best = 0.0;
+ goto skip;
+ }
+#endif
+ if (x < 0.0) x = 0.0;
+ s -= mir->cut_vec->val[j] * x;
+ }
+ xassert(s >= 0.0);
+ /* apply heuristic to obtain most violated c-MIR inequality */
+ b = mir->cut_rhs;
+ r_best = cmir_sep(nint, mir->cut_vec->val, b, u, x, s, alpha,
+ &beta, &gamma);
+ if (r_best == 0.0) goto skip;
+ xassert(r_best > 0.0);
+ /* convert to raw cut */
+ /* sum alpha[j] * x[j] <= beta + gamma * s */
+ for (j = 1; j <= nint; j++)
+ mir->cut_vec->val[j] = alpha[j];
+ for (j = nint+1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ if (k <= m+n) mir->cut_vec->val[j] *= gamma;
+ }
+ mir->cut_rhs = beta;
+#if MIR_DEBUG
+ spv_check_vec(mir->cut_vec);
+#endif
+skip: /* free working arrays */
+ xfree(u);
+ xfree(x);
+ xfree(alpha);
+done: return r_best;
+}
+
+#if MIR_DEBUG
+static void check_raw_cut(glp_mir *mir, double r_best)
+{ /* check raw cut before back bound substitution */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k, kk;
+ double r, big, x;
+ /* compute the residual r = sum a[k] * x[k] - b and determine
+ big = max(1, |a[k]|, |b|) */
+ r = 0.0, big = 1.0;
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->subst[k] == 'L')
+ { xassert(mir->lb[k] != -DBL_MAX);
+ kk = mir->vlb[k];
+ if (kk == 0)
+ x = mir->x[k] - mir->lb[k];
+ else
+ x = mir->x[k] - mir->lb[k] * mir->x[kk];
+ }
+ else if (mir->subst[k] == 'U')
+ { xassert(mir->ub[k] != +DBL_MAX);
+ kk = mir->vub[k];
+ if (kk == 0)
+ x = mir->ub[k] - mir->x[k];
+ else
+ x = mir->ub[k] * mir->x[kk] - mir->x[k];
+ }
+ else
+ xassert(k != k);
+ r += mir->cut_vec->val[j] * x;
+ if (big < fabs(mir->cut_vec->val[j]))
+ big = fabs(mir->cut_vec->val[j]);
+ }
+ r -= mir->cut_rhs;
+ if (big < fabs(mir->cut_rhs))
+ big = fabs(mir->cut_rhs);
+ /* the residual must be close to r_best */
+ xassert(fabs(r - r_best) <= 1e-6 * big);
+ return;
+}
+#endif
+
+static void back_subst(glp_mir *mir)
+{ /* back substitution of original bounds */
+ int m = mir->m;
+ int n = mir->n;
+ int j, jj, k, kk;
+ /* at first, restore bounds of integer variables (because on
+ restoring variable bounds of continuous variables we need
+ original, not shifted, bounds of integer variables) */
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (!mir->isint[k]) continue; /* skip continuous */
+ if (mir->subst[k] == 'L')
+ { /* x'[k] = x[k] - lb[k] */
+ xassert(mir->lb[k] != -DBL_MAX);
+ xassert(mir->vlb[k] == 0);
+ mir->cut_rhs += mir->cut_vec->val[j] * mir->lb[k];
+ }
+ else if (mir->subst[k] == 'U')
+ { /* x'[k] = ub[k] - x[k] */
+ xassert(mir->ub[k] != +DBL_MAX);
+ xassert(mir->vub[k] == 0);
+ mir->cut_rhs -= mir->cut_vec->val[j] * mir->ub[k];
+ mir->cut_vec->val[j] = - mir->cut_vec->val[j];
+ }
+ else
+ xassert(k != k);
+ }
+ /* now restore bounds of continuous variables */
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (mir->isint[k]) continue; /* skip integer */
+ if (mir->subst[k] == 'L')
+ { /* x'[k] = x[k] - (lower bound) */
+ xassert(mir->lb[k] != -DBL_MAX);
+ kk = mir->vlb[k];
+ if (kk == 0)
+ { /* x'[k] = x[k] - lb[k] */
+ mir->cut_rhs += mir->cut_vec->val[j] * mir->lb[k];
+ }
+ else
+ { /* x'[k] = x[k] - lb[k] * x[kk] */
+ jj = mir->cut_vec->pos[kk];
+#if 0
+ xassert(jj != 0);
+#else
+ if (jj == 0)
+ { spv_set_vj(mir->cut_vec, kk, 1.0);
+ jj = mir->cut_vec->pos[kk];
+ xassert(jj != 0);
+ mir->cut_vec->val[jj] = 0.0;
+ }
+#endif
+ mir->cut_vec->val[jj] -= mir->cut_vec->val[j] *
+ mir->lb[k];
+ }
+ }
+ else if (mir->subst[k] == 'U')
+ { /* x'[k] = (upper bound) - x[k] */
+ xassert(mir->ub[k] != +DBL_MAX);
+ kk = mir->vub[k];
+ if (kk == 0)
+ { /* x'[k] = ub[k] - x[k] */
+ mir->cut_rhs -= mir->cut_vec->val[j] * mir->ub[k];
+ }
+ else
+ { /* x'[k] = ub[k] * x[kk] - x[k] */
+ jj = mir->cut_vec->pos[kk];
+ if (jj == 0)
+ { spv_set_vj(mir->cut_vec, kk, 1.0);
+ jj = mir->cut_vec->pos[kk];
+ xassert(jj != 0);
+ mir->cut_vec->val[jj] = 0.0;
+ }
+ mir->cut_vec->val[jj] += mir->cut_vec->val[j] *
+ mir->ub[k];
+ }
+ mir->cut_vec->val[j] = - mir->cut_vec->val[j];
+ }
+ else
+ xassert(k != k);
+ }
+#if MIR_DEBUG
+ spv_check_vec(mir->cut_vec);
+#endif
+ return;
+}
+
+#if MIR_DEBUG
+static void check_cut_row(glp_mir *mir, double r_best)
+{ /* check the cut after back bound substitution or elimination of
+ auxiliary variables */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k;
+ double r, big;
+ /* compute the residual r = sum a[k] * x[k] - b and determine
+ big = max(1, |a[k]|, |b|) */
+ r = 0.0, big = 1.0;
+ for (j = 1; j <= mir->cut_vec->nnz; j++)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ r += mir->cut_vec->val[j] * mir->x[k];
+ if (big < fabs(mir->cut_vec->val[j]))
+ big = fabs(mir->cut_vec->val[j]);
+ }
+ r -= mir->cut_rhs;
+ if (big < fabs(mir->cut_rhs))
+ big = fabs(mir->cut_rhs);
+ /* the residual must be close to r_best */
+ xassert(fabs(r - r_best) <= 1e-6 * big);
+ return;
+}
+#endif
+
+static void subst_aux_vars(glp_prob *mip, glp_mir *mir)
+{ /* final substitution to eliminate auxiliary variables */
+ int m = mir->m;
+ int n = mir->n;
+ GLPAIJ *aij;
+ int j, k, kk, jj;
+ for (j = mir->cut_vec->nnz; j >= 1; j--)
+ { k = mir->cut_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (k > m) continue; /* skip structurals */
+ for (aij = mip->row[k]->ptr; aij != NULL; aij = aij->r_next)
+ { kk = m + aij->col->j; /* structural */
+ jj = mir->cut_vec->pos[kk];
+ if (jj == 0)
+ { spv_set_vj(mir->cut_vec, kk, 1.0);
+ jj = mir->cut_vec->pos[kk];
+ mir->cut_vec->val[jj] = 0.0;
+ }
+ mir->cut_vec->val[jj] += mir->cut_vec->val[j] * aij->val;
+ }
+ mir->cut_vec->val[j] = 0.0;
+ }
+ spv_clean_vec(mir->cut_vec, 0.0);
+ return;
+}
+
+static void add_cut(glp_mir *mir, glp_prob *pool)
+{ /* add constructed cut inequality to the cut pool */
+ int m = mir->m;
+ int n = mir->n;
+ int j, k, len;
+ int *ind = xcalloc(1+n, sizeof(int));
+ double *val = xcalloc(1+n, sizeof(double));
+ len = 0;
+ for (j = mir->cut_vec->nnz; j >= 1; j--)
+ { k = mir->cut_vec->ind[j];
+ xassert(m+1 <= k && k <= m+n);
+ len++, ind[len] = k - m, val[len] = mir->cut_vec->val[j];
+ }
+#if 0
+#if 0
+ ios_add_cut_row(tree, pool, GLP_RF_MIR, len, ind, val, GLP_UP,
+ mir->cut_rhs);
+#else
+ glp_ios_add_row(tree, NULL, GLP_RF_MIR, 0, len, ind, val, GLP_UP,
+ mir->cut_rhs);
+#endif
+#else
+ { int i;
+ i = glp_add_rows(pool, 1);
+ glp_set_row_bnds(pool, i, GLP_UP, 0, mir->cut_rhs);
+ glp_set_mat_row(pool, i, len, ind, val);
+ }
+#endif
+ xfree(ind);
+ xfree(val);
+ return;
+}
+
+#if 0 /* 29/II-2016 by Chris */
+static int aggregate_row(glp_prob *mip, glp_mir *mir)
+#else
+static int aggregate_row(glp_prob *mip, glp_mir *mir, SPV *v)
+#endif
+{ /* try to aggregate another row */
+ int m = mir->m;
+ int n = mir->n;
+ GLPAIJ *aij;
+#if 0 /* 29/II-2016 by Chris */
+ SPV *v;
+#endif
+ int ii, j, jj, k, kk, kappa = 0, ret = 0;
+ double d1, d2, d, d_max = 0.0;
+ /* choose appropriate structural variable in the aggregated row
+ to be substituted */
+ for (j = 1; j <= mir->agg_vec->nnz; j++)
+ { k = mir->agg_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ if (k <= m) continue; /* skip auxiliary var */
+ if (mir->isint[k]) continue; /* skip integer var */
+ if (fabs(mir->agg_vec->val[j]) < 0.001) continue;
+ /* compute distance from x[k] to its lower bound */
+ kk = mir->vlb[k];
+ if (kk == 0)
+ { if (mir->lb[k] == -DBL_MAX)
+ d1 = DBL_MAX;
+ else
+ d1 = mir->x[k] - mir->lb[k];
+ }
+ else
+ { xassert(1 <= kk && kk <= m+n);
+ xassert(mir->isint[kk]);
+ xassert(mir->lb[k] != -DBL_MAX);
+ d1 = mir->x[k] - mir->lb[k] * mir->x[kk];
+ }
+ /* compute distance from x[k] to its upper bound */
+ kk = mir->vub[k];
+ if (kk == 0)
+ { if (mir->vub[k] == +DBL_MAX)
+ d2 = DBL_MAX;
+ else
+ d2 = mir->ub[k] - mir->x[k];
+ }
+ else
+ { xassert(1 <= kk && kk <= m+n);
+ xassert(mir->isint[kk]);
+ xassert(mir->ub[k] != +DBL_MAX);
+ d2 = mir->ub[k] * mir->x[kk] - mir->x[k];
+ }
+ /* x[k] cannot be free */
+ xassert(d1 != DBL_MAX || d2 != DBL_MAX);
+ /* d = min(d1, d2) */
+ d = (d1 <= d2 ? d1 : d2);
+ xassert(d != DBL_MAX);
+ /* should not be close to corresponding bound */
+ if (d < 0.001) continue;
+ if (d_max < d) d_max = d, kappa = k;
+ }
+ if (kappa == 0)
+ { /* nothing chosen */
+ ret = 1;
+ goto done;
+ }
+ /* x[kappa] has been chosen */
+ xassert(m+1 <= kappa && kappa <= m+n);
+ xassert(!mir->isint[kappa]);
+ /* find another row, which have not been used yet, to eliminate
+ x[kappa] from the aggregated row */
+#if 0 /* 29/II-2016 by Chris */
+ for (ii = 1; ii <= m; ii++)
+ { if (mir->skip[ii]) continue;
+ for (aij = mip->row[ii]->ptr; aij != NULL; aij = aij->r_next)
+ if (aij->col->j == kappa - m) break;
+ if (aij != NULL && fabs(aij->val) >= 0.001) break;
+#else
+ ii = 0;
+ for (aij = mip->col[kappa - m]->ptr; aij != NULL;
+ aij = aij->c_next)
+ { if (aij->row->i > m) continue;
+ if (mir->skip[aij->row->i]) continue;
+ if (fabs(aij->val) >= 0.001)
+ { ii = aij->row->i;
+ break;
+ }
+#endif
+ }
+#if 0 /* 29/II-2016 by Chris */
+ if (ii > m)
+#else
+ if (ii == 0)
+#endif
+ { /* nothing found */
+ ret = 2;
+ goto done;
+ }
+ /* row ii has been found; include it in the aggregated list */
+ mir->agg_cnt++;
+ xassert(mir->agg_cnt <= MAXAGGR);
+ mir->agg_row[mir->agg_cnt] = ii;
+ mir->skip[ii] = 2;
+ /* v := new row */
+#if 0 /* 29/II-2016 by Chris */
+ v = ios_create_vec(m+n);
+#else
+ spv_clear_vec(v);
+#endif
+ spv_set_vj(v, ii, 1.0);
+ for (aij = mip->row[ii]->ptr; aij != NULL; aij = aij->r_next)
+ spv_set_vj(v, m + aij->col->j, - aij->val);
+#if MIR_DEBUG
+ spv_check_vec(v);
+#endif
+ /* perform gaussian elimination to remove x[kappa] */
+ j = mir->agg_vec->pos[kappa];
+ xassert(j != 0);
+ jj = v->pos[kappa];
+ xassert(jj != 0);
+ spv_linear_comb(mir->agg_vec,
+ - mir->agg_vec->val[j] / v->val[jj], v);
+#if 0 /* 29/II-2016 by Chris */
+ ios_delete_vec(v);
+#endif
+ spv_set_vj(mir->agg_vec, kappa, 0.0);
+#if MIR_DEBUG
+ spv_check_vec(mir->agg_vec);
+#endif
+done: return ret;
+}
+
+int glp_mir_gen(glp_prob *mip, glp_mir *mir, glp_prob *pool)
+{ /* main routine to generate MIR cuts */
+ int m = mir->m;
+ int n = mir->n;
+ int i, nnn = 0;
+ double r_best;
+#if 1 /* 29/II-2016 by Chris */
+ SPV *work;
+#endif
+ xassert(mip->m >= m);
+ xassert(mip->n == n);
+ /* obtain current point */
+ get_current_point(mip, mir);
+#if MIR_DEBUG
+ /* check current point */
+ check_current_point(mir);
+#endif
+ /* reset bound substitution flags */
+ memset(&mir->subst[1], '?', m+n);
+#if 1 /* 29/II-2016 by Chris */
+ work = spv_create_vec(m+n);
+#endif
+ /* try to generate a set of violated MIR cuts */
+ for (i = 1; i <= m; i++)
+ { if (mir->skip[i]) continue;
+ /* use original i-th row as initial aggregated constraint */
+ initial_agg_row(mip, mir, i);
+loop: ;
+#if MIR_DEBUG
+ /* check aggregated row */
+ check_agg_row(mir);
+#endif
+ /* substitute fixed variables into aggregated constraint */
+ subst_fixed_vars(mir);
+#if MIR_DEBUG
+ /* check aggregated row */
+ check_agg_row(mir);
+#endif
+#if MIR_DEBUG
+ /* check bound substitution flags */
+ { int k;
+ for (k = 1; k <= m+n; k++)
+ xassert(mir->subst[k] == '?');
+ }
+#endif
+ /* apply bound substitution heuristic */
+ bound_subst_heur(mir);
+ /* substitute bounds and build modified constraint */
+ build_mod_row(mir);
+#if MIR_DEBUG
+ /* check modified row */
+ check_mod_row(mir);
+#endif
+ /* try to generate violated c-MIR cut for modified row */
+ r_best = generate(mir);
+ if (r_best > 0.0)
+ { /* success */
+#if MIR_DEBUG
+ /* check raw cut before back bound substitution */
+ check_raw_cut(mir, r_best);
+#endif
+ /* back substitution of original bounds */
+ back_subst(mir);
+#if MIR_DEBUG
+ /* check the cut after back bound substitution */
+ check_cut_row(mir, r_best);
+#endif
+ /* final substitution to eliminate auxiliary variables */
+ subst_aux_vars(mip, mir);
+#if MIR_DEBUG
+ /* check the cut after elimination of auxiliaries */
+ check_cut_row(mir, r_best);
+#endif
+ /* add constructed cut inequality to the cut pool */
+ add_cut(mir, pool), nnn++;
+ }
+ /* reset bound substitution flags */
+ { int j, k;
+ for (j = 1; j <= mir->mod_vec->nnz; j++)
+ { k = mir->mod_vec->ind[j];
+ xassert(1 <= k && k <= m+n);
+ xassert(mir->subst[k] != '?');
+ mir->subst[k] = '?';
+ }
+ }
+ if (r_best == 0.0)
+ { /* failure */
+ if (mir->agg_cnt < MAXAGGR)
+ { /* try to aggregate another row */
+#if 0 /* 29/II-2016 by Chris */
+ if (aggregate_row(mip, mir) == 0) goto loop;
+#else
+ if (aggregate_row(mip, mir, work) == 0) goto loop;
+#endif
+ }
+ }
+ /* unmark rows used in the aggregated constraint */
+ { int k, ii;
+ for (k = 1; k <= mir->agg_cnt; k++)
+ { ii = mir->agg_row[k];
+ xassert(1 <= ii && ii <= m);
+ xassert(mir->skip[ii] == 2);
+ mir->skip[ii] = 0;
+ }
+ }
+ }
+#if 1 /* 29/II-2016 by Chris */
+ spv_delete_vec(work);
+#endif
+ return nnn;
+}
+
+/***********************************************************************
+* NAME
+*
+* glp_mir_free - delete MIR cut generator workspace
+*
+* SYNOPSIS
+*
+* void glp_mir_free(glp_mir *mir);
+*
+* DESCRIPTION
+*
+* This routine deletes the MIR cut generator workspace and frees all
+* the memory allocated to it. */
+
+void glp_mir_free(glp_mir *mir)
+{ xfree(mir->skip);
+ xfree(mir->isint);
+ xfree(mir->lb);
+ xfree(mir->vlb);
+ xfree(mir->ub);
+ xfree(mir->vub);
+ xfree(mir->x);
+ xfree(mir->agg_row);
+ spv_delete_vec(mir->agg_vec);
+ xfree(mir->subst);
+ spv_delete_vec(mir->mod_vec);
+ spv_delete_vec(mir->cut_vec);
+ xfree(mir);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/spv.c b/test/monniaux/glpk-4.65/src/intopt/spv.c
new file mode 100644
index 00000000..502f3cd0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/spv.c
@@ -0,0 +1,303 @@
+/* spv.c (operations on sparse vectors) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2007-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spv.h"
+
+/***********************************************************************
+* NAME
+*
+* spv_create_vec - create sparse vector
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* SPV *spv_create_vec(int n);
+*
+* DESCRIPTION
+*
+* The routine spv_create_vec creates a sparse vector of dimension n,
+* which initially is a null vector.
+*
+* RETURNS
+*
+* The routine returns a pointer to the vector created. */
+
+SPV *spv_create_vec(int n)
+{ SPV *v;
+ xassert(n >= 0);
+ v = xmalloc(sizeof(SPV));
+ v->n = n;
+ v->nnz = 0;
+ v->pos = xcalloc(1+n, sizeof(int));
+ memset(&v->pos[1], 0, n * sizeof(int));
+ v->ind = xcalloc(1+n, sizeof(int));
+ v->val = xcalloc(1+n, sizeof(double));
+ return v;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_check_vec - check that sparse vector has correct representation
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_check_vec(SPV *v);
+*
+* DESCRIPTION
+*
+* The routine spv_check_vec checks that a sparse vector specified by
+* the parameter v has correct representation.
+*
+* NOTE
+*
+* Complexity of this operation is O(n). */
+
+void spv_check_vec(SPV *v)
+{ int j, k, nnz;
+ xassert(v->n >= 0);
+ nnz = 0;
+ for (j = v->n; j >= 1; j--)
+ { k = v->pos[j];
+ xassert(0 <= k && k <= v->nnz);
+ if (k != 0)
+ { xassert(v->ind[k] == j);
+ nnz++;
+ }
+ }
+ xassert(v->nnz == nnz);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_get_vj - retrieve component of sparse vector
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* double spv_get_vj(SPV *v, int j);
+*
+* RETURNS
+*
+* The routine spv_get_vj returns j-th component of a sparse vector
+* specified by the parameter v. */
+
+double spv_get_vj(SPV *v, int j)
+{ int k;
+ xassert(1 <= j && j <= v->n);
+ k = v->pos[j];
+ xassert(0 <= k && k <= v->nnz);
+ return (k == 0 ? 0.0 : v->val[k]);
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_set_vj - set/change component of sparse vector
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_set_vj(SPV *v, int j, double val);
+*
+* DESCRIPTION
+*
+* The routine spv_set_vj assigns val to j-th component of a sparse
+* vector specified by the parameter v. */
+
+void spv_set_vj(SPV *v, int j, double val)
+{ int k;
+ xassert(1 <= j && j <= v->n);
+ k = v->pos[j];
+ if (val == 0.0)
+ { if (k != 0)
+ { /* remove j-th component */
+ v->pos[j] = 0;
+ if (k < v->nnz)
+ { v->pos[v->ind[v->nnz]] = k;
+ v->ind[k] = v->ind[v->nnz];
+ v->val[k] = v->val[v->nnz];
+ }
+ v->nnz--;
+ }
+ }
+ else
+ { if (k == 0)
+ { /* create j-th component */
+ k = ++(v->nnz);
+ v->pos[j] = k;
+ v->ind[k] = j;
+ }
+ v->val[k] = val;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_clear_vec - set all components of sparse vector to zero
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_clear_vec(SPV *v);
+*
+* DESCRIPTION
+*
+* The routine spv_clear_vec sets all components of a sparse vector
+* specified by the parameter v to zero. */
+
+void spv_clear_vec(SPV *v)
+{ int k;
+ for (k = 1; k <= v->nnz; k++)
+ v->pos[v->ind[k]] = 0;
+ v->nnz = 0;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_clean_vec - remove zero or small components from sparse vector
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_clean_vec(SPV *v, double eps);
+*
+* DESCRIPTION
+*
+* The routine spv_clean_vec removes zero components and components
+* whose magnitude is less than eps from a sparse vector specified by
+* the parameter v. If eps is 0.0, only zero components are removed. */
+
+void spv_clean_vec(SPV *v, double eps)
+{ int k, nnz;
+ nnz = 0;
+ for (k = 1; k <= v->nnz; k++)
+ { if (fabs(v->val[k]) == 0.0 || fabs(v->val[k]) < eps)
+ { /* remove component */
+ v->pos[v->ind[k]] = 0;
+ }
+ else
+ { /* keep component */
+ nnz++;
+ v->pos[v->ind[k]] = nnz;
+ v->ind[nnz] = v->ind[k];
+ v->val[nnz] = v->val[k];
+ }
+ }
+ v->nnz = nnz;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_copy_vec - copy sparse vector (x := y)
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_copy_vec(SPV *x, SPV *y);
+*
+* DESCRIPTION
+*
+* The routine spv_copy_vec copies a sparse vector specified by the
+* parameter y to a sparse vector specified by the parameter x. */
+
+void spv_copy_vec(SPV *x, SPV *y)
+{ int j;
+ xassert(x != y);
+ xassert(x->n == y->n);
+ spv_clear_vec(x);
+ x->nnz = y->nnz;
+ memcpy(&x->ind[1], &y->ind[1], x->nnz * sizeof(int));
+ memcpy(&x->val[1], &y->val[1], x->nnz * sizeof(double));
+ for (j = 1; j <= x->nnz; j++)
+ x->pos[x->ind[j]] = j;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_linear_comb - compute linear combination (x := x + a * y)
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_linear_comb(SPV *x, double a, SPV *y);
+*
+* DESCRIPTION
+*
+* The routine spv_linear_comb computes the linear combination
+*
+* x := x + a * y,
+*
+* where x and y are sparse vectors, a is a scalar. */
+
+void spv_linear_comb(SPV *x, double a, SPV *y)
+{ int j, k;
+ double xj, yj;
+ xassert(x != y);
+ xassert(x->n == y->n);
+ for (k = 1; k <= y->nnz; k++)
+ { j = y->ind[k];
+ xj = spv_get_vj(x, j);
+ yj = y->val[k];
+ spv_set_vj(x, j, xj + a * yj);
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* spv_delete_vec - delete sparse vector
+*
+* SYNOPSIS
+*
+* #include "glpios.h"
+* void spv_delete_vec(SPV *v);
+*
+* DESCRIPTION
+*
+* The routine spv_delete_vec deletes a sparse vector specified by the
+* parameter v freeing all the memory allocated to this object. */
+
+void spv_delete_vec(SPV *v)
+{ /* delete sparse vector */
+ xfree(v->pos);
+ xfree(v->ind);
+ xfree(v->val);
+ xfree(v);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/intopt/spv.h b/test/monniaux/glpk-4.65/src/intopt/spv.h
new file mode 100644
index 00000000..d7d4699f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/intopt/spv.h
@@ -0,0 +1,83 @@
+/* spv.h (operations on sparse vectors) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2007-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPV_H
+#define SPV_H
+
+typedef struct SPV SPV;
+
+struct SPV
+{ /* sparse vector v = (v[j]) */
+ int n;
+ /* dimension, n >= 0 */
+ int nnz;
+ /* number of non-zero components, 0 <= nnz <= n */
+ int *pos; /* int pos[1+n]; */
+ /* pos[j] = k, 1 <= j <= n, is position of (non-zero) v[j] in the
+ * arrays ind and val, where 1 <= k <= nnz; pos[j] = 0 means that
+ * v[j] is structural zero */
+ int *ind; /* int ind[1+n]; */
+ /* ind[k] = j, 1 <= k <= nnz, is index of v[j] */
+ double *val; /* double val[1+n]; */
+ /* val[k], 1 <= k <= nnz, is a numeric value of v[j] */
+};
+
+#define spv_create_vec _glp_spv_create_vec
+SPV *spv_create_vec(int n);
+/* create sparse vector */
+
+#define spv_check_vec _glp_spv_check_vec
+void spv_check_vec(SPV *v);
+/* check that sparse vector has correct representation */
+
+#define spv_get_vj _glp_spv_get_vj
+double spv_get_vj(SPV *v, int j);
+/* retrieve component of sparse vector */
+
+#define spv_set_vj _glp_spv_set_vj
+void spv_set_vj(SPV *v, int j, double val);
+/* set/change component of sparse vector */
+
+#define spv_clear_vec _glp_spv_clear_vec
+void spv_clear_vec(SPV *v);
+/* set all components of sparse vector to zero */
+
+#define spv_clean_vec _glp_spv_clean_vec
+void spv_clean_vec(SPV *v, double eps);
+/* remove zero or small components from sparse vector */
+
+#define spv_copy_vec _glp_spv_copy_vec
+void spv_copy_vec(SPV *x, SPV *y);
+/* copy sparse vector (x := y) */
+
+#define spv_linear_comb _glp_spv_linear_comb
+void spv_linear_comb(SPV *x, double a, SPV *y);
+/* compute linear combination (x := x + a * y) */
+
+#define spv_delete_vec _glp_spv_delete_vec
+void spv_delete_vec(SPV *v);
+/* delete sparse vector */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/minisat/LICENSE b/test/monniaux/glpk-4.65/src/minisat/LICENSE
new file mode 100644
index 00000000..8a6b9f36
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/minisat/LICENSE
@@ -0,0 +1,20 @@
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/test/monniaux/glpk-4.65/src/minisat/README b/test/monniaux/glpk-4.65/src/minisat/README
new file mode 100644
index 00000000..c183c7d6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/minisat/README
@@ -0,0 +1,22 @@
+NOTE: Files in this subdirectory are NOT part of the GLPK package, but
+ are used with GLPK.
+
+ The original code was modified according to GLPK requirements by
+ Andrew Makhorin <mao@gnu.org>.
+************************************************************************
+MiniSat-C v1.14.1
+========================================
+
+* Fixed some serious bugs.
+* Tweaked to be Visual Studio friendly (by Alan Mishchenko).
+ This disabled reading of gzipped DIMACS files and signal handling,
+ but none of these features are essential (and easy to re-enable, if
+ wanted).
+
+MiniSat-C v1.14
+========================================
+
+Ok, we get it. You hate C++. You hate templates. We agree; C++ is a
+seriously messed up language. Although we are more pragmatic about the
+quirks and maldesigns in C++, we sympathize with you. So here is a
+pure C version of MiniSat, put together by Niklas Sorensson.
diff --git a/test/monniaux/glpk-4.65/src/minisat/minisat.c b/test/monniaux/glpk-4.65/src/minisat/minisat.c
new file mode 100644
index 00000000..2432d650
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/minisat/minisat.c
@@ -0,0 +1,1315 @@
+/* minisat.c */
+
+/* Modified by Andrew Makhorin <mao@gnu.org>, August 2011 */
+/* May 2017: Changes were made to provide 64-bit portability; thanks to
+ * Chris Matrakidis <cmatraki@gmail.com> for patch */
+
+/***********************************************************************
+* MiniSat -- Copyright (c) 2005, Niklas Sorensson
+* http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+*
+* Permission is hereby granted, free of charge, to any person
+* obtaining a copy of this software and associated documentation files
+* (the "Software"), to deal in the Software without restriction,
+* including without limitation the rights to use, copy, modify, merge,
+* publish, distribute, sublicense, and/or sell copies of the Software,
+* and to permit persons to whom the Software is furnished to do so,
+* subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be
+* included in all copies or substantial portions of the Software.
+*
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+* NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+* BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+* ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+* CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+* SOFTWARE.
+***********************************************************************/
+/* Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko */
+
+#include "env.h"
+#include "minisat.h"
+
+#if 1 /* by mao */
+static void *ymalloc(int size)
+{ void *ptr;
+ xassert(size > 0);
+ ptr = malloc(size);
+ if (ptr == NULL)
+ xerror("MiniSat: no memory available\n");
+ return ptr;
+}
+
+static void *yrealloc(void *ptr, int size)
+{ xassert(size > 0);
+ if (ptr == NULL)
+ ptr = malloc(size);
+ else
+ ptr = realloc(ptr, size);
+ if (ptr == NULL)
+ xerror("MiniSat: no memory available\n");
+ return ptr;
+}
+
+static void yfree(void *ptr)
+{ xassert(ptr != NULL);
+ free(ptr);
+ return;
+}
+
+#define assert xassert
+#define printf xprintf
+#define fflush(f) /* nop */
+#define malloc ymalloc
+#define realloc yrealloc
+#define free yfree
+#define inline /* empty */
+#endif
+
+/*====================================================================*/
+/* Debug: */
+
+#if 0
+#define VERBOSEDEBUG 1
+#endif
+
+/* For derivation output (verbosity level 2) */
+#define L_IND "%-*d"
+#define L_ind solver_dlevel(s)*3+3,solver_dlevel(s)
+#define L_LIT "%sx%d"
+#define L_lit(p) lit_sign(p)?"~":"", (lit_var(p))
+
+#if 0 /* by mao */
+/* Just like 'assert()' but expression will be evaluated in the release
+ version as well. */
+static inline void check(int expr) { assert(expr); }
+#endif
+
+#if 0 /* by mao */
+static void printlits(lit* begin, lit* end)
+{
+ int i;
+ for (i = 0; i < end - begin; i++)
+ printf(L_LIT" ",L_lit(begin[i]));
+}
+#endif
+
+/*====================================================================*/
+/* Random numbers: */
+
+/* Returns a random float 0 <= x < 1. Seed must never be 0. */
+static inline double drand(double* seed) {
+ int q;
+ *seed *= 1389796;
+ q = (int)(*seed / 2147483647);
+ *seed -= (double)q * 2147483647;
+ return *seed / 2147483647; }
+
+/* Returns a random integer 0 <= x < size. Seed must never be 0. */
+static inline int irand(double* seed, int size) {
+ return (int)(drand(seed) * size); }
+
+/*====================================================================*/
+/* Predeclarations: */
+
+static void sort(void** array, int size,
+ int(*comp)(const void *, const void *));
+
+/*====================================================================*/
+/* Clause datatype + minor functions: */
+
+#if 0 /* by mao; see minisat.h */
+struct clause_t
+{
+ int size_learnt;
+ lit lits[0];
+};
+#endif
+
+#define clause_size(c) ((c)->size_learnt >> 1)
+
+#define clause_begin(c) ((c)->lits)
+
+#define clause_learnt(c) ((c)->size_learnt & 1)
+
+#define clause_activity(c) \
+ (*((float*)&(c)->lits[(c)->size_learnt>>1]))
+
+#define clause_setactivity(c, a) \
+ (void)(*((float*)&(c)->lits[(c)->size_learnt>>1]) = (a))
+
+/*====================================================================*/
+/* Encode literals in clause pointers: */
+
+#if 0 /* 8/I-2017 by cmatraki (64-bit portability) */
+#define clause_from_lit(l) \
+ (clause*)((unsigned long)(l) + (unsigned long)(l) + 1)
+
+#define clause_is_lit(c) \
+ ((unsigned long)(c) & 1)
+
+#define clause_read_lit(c) \
+ (lit)((unsigned long)(c) >> 1)
+#else
+#define clause_from_lit(l) \
+ (clause*)((size_t)(l) + (size_t)(l) + 1)
+
+#define clause_is_lit(c) \
+ ((size_t)(c) & 1)
+
+#define clause_read_lit(c) \
+ (lit)((size_t)(c) >> 1)
+#endif
+
+/*====================================================================*/
+/* Simple helpers: */
+
+#define solver_dlevel(s) \
+ (int)veci_size(&(s)->trail_lim)
+
+#define solver_read_wlist(s, l) \
+ (vecp *)(&(s)->wlists[l])
+
+static inline void vecp_remove(vecp* v, void* e)
+{
+ void** ws = vecp_begin(v);
+ int j = 0;
+
+ for (; ws[j] != e ; j++);
+ assert(j < vecp_size(v));
+ for (; j < vecp_size(v)-1; j++) ws[j] = ws[j+1];
+ vecp_resize(v,vecp_size(v)-1);
+}
+
+/*====================================================================*/
+/* Variable order functions: */
+
+static inline void order_update(solver* s, int v)
+{ /* updateorder */
+ int* orderpos = s->orderpos;
+ double* activity = s->activity;
+ int* heap = veci_begin(&s->order);
+ int i = orderpos[v];
+ int x = heap[i];
+ int parent = (i - 1) / 2;
+
+ assert(s->orderpos[v] != -1);
+
+ while (i != 0 && activity[x] > activity[heap[parent]]){
+ heap[i] = heap[parent];
+ orderpos[heap[i]] = i;
+ i = parent;
+ parent = (i - 1) / 2;
+ }
+ heap[i] = x;
+ orderpos[x] = i;
+}
+
+#define order_assigned(s, v) /* nop */
+
+static inline void order_unassigned(solver* s, int v)
+{ /* undoorder */
+ int* orderpos = s->orderpos;
+ if (orderpos[v] == -1){
+ orderpos[v] = veci_size(&s->order);
+ veci_push(&s->order,v);
+ order_update(s,v);
+ }
+}
+
+static int order_select(solver* s, float random_var_freq)
+{ /* selectvar */
+ int* heap;
+ double* activity;
+ int* orderpos;
+
+ lbool* values = s->assigns;
+
+ /* Random decision: */
+ if (drand(&s->random_seed) < random_var_freq){
+ int next = irand(&s->random_seed,s->size);
+ assert(next >= 0 && next < s->size);
+ if (values[next] == l_Undef)
+ return next;
+ }
+
+ /* Activity based decision: */
+
+ heap = veci_begin(&s->order);
+ activity = s->activity;
+ orderpos = s->orderpos;
+
+ while (veci_size(&s->order) > 0){
+ int next = heap[0];
+ int size = veci_size(&s->order)-1;
+ int x = heap[size];
+
+ veci_resize(&s->order,size);
+
+ orderpos[next] = -1;
+
+ if (size > 0){
+ double act = activity[x];
+
+ int i = 0;
+ int child = 1;
+
+ while (child < size){
+ if (child+1 < size
+ && activity[heap[child]] < activity[heap[child+1]])
+ child++;
+
+ assert(child < size);
+
+ if (act >= activity[heap[child]])
+ break;
+
+ heap[i] = heap[child];
+ orderpos[heap[i]] = i;
+ i = child;
+ child = 2 * child + 1;
+ }
+ heap[i] = x;
+ orderpos[heap[i]] = i;
+ }
+
+ if (values[next] == l_Undef)
+ return next;
+ }
+
+ return var_Undef;
+}
+
+/*====================================================================*/
+/* Activity functions: */
+
+static inline void act_var_rescale(solver* s) {
+ double* activity = s->activity;
+ int i;
+ for (i = 0; i < s->size; i++)
+ activity[i] *= 1e-100;
+ s->var_inc *= 1e-100;
+}
+
+static inline void act_var_bump(solver* s, int v) {
+ double* activity = s->activity;
+ if ((activity[v] += s->var_inc) > 1e100)
+ act_var_rescale(s);
+
+ /* printf("bump %d %f\n", v-1, activity[v]); */
+
+ if (s->orderpos[v] != -1)
+ order_update(s,v);
+
+}
+
+static inline void act_var_decay(solver* s)
+ { s->var_inc *= s->var_decay; }
+
+static inline void act_clause_rescale(solver* s) {
+ clause** cs = (clause**)vecp_begin(&s->learnts);
+ int i;
+ for (i = 0; i < vecp_size(&s->learnts); i++){
+ float a = clause_activity(cs[i]);
+ clause_setactivity(cs[i], a * (float)1e-20);
+ }
+ s->cla_inc *= (float)1e-20;
+}
+
+static inline void act_clause_bump(solver* s, clause *c) {
+ float a = clause_activity(c) + s->cla_inc;
+ clause_setactivity(c,a);
+ if (a > 1e20) act_clause_rescale(s);
+}
+
+static inline void act_clause_decay(solver* s)
+ { s->cla_inc *= s->cla_decay; }
+
+/*====================================================================*/
+/* Clause functions: */
+
+/* pre: size > 1 && no variable occurs twice
+ */
+static clause* clause_new(solver* s, lit* begin, lit* end, int learnt)
+{
+ int size;
+ clause* c;
+ int i;
+
+ assert(end - begin > 1);
+ assert(learnt >= 0 && learnt < 2);
+ size = end - begin;
+ c = (clause*)malloc(sizeof(clause)
+ + sizeof(lit) * size + learnt * sizeof(float));
+ c->size_learnt = (size << 1) | learnt;
+#if 1 /* by mao & cmatraki; non-portable check that is a fundamental \
+ * assumption of minisat code: bit 0 is used as a flag (zero \
+ * for pointer, one for shifted int) so allocated memory should \
+ * be at least 16-bit aligned */
+ assert(((size_t)c & 1) == 0);
+#endif
+
+ for (i = 0; i < size; i++)
+ c->lits[i] = begin[i];
+
+ if (learnt)
+ *((float*)&c->lits[size]) = 0.0;
+
+ assert(begin[0] >= 0);
+ assert(begin[0] < s->size*2);
+ assert(begin[1] >= 0);
+ assert(begin[1] < s->size*2);
+
+ assert(lit_neg(begin[0]) < s->size*2);
+ assert(lit_neg(begin[1]) < s->size*2);
+
+ /* vecp_push(solver_read_wlist(s,lit_neg(begin[0])),(void*)c); */
+ /* vecp_push(solver_read_wlist(s,lit_neg(begin[1])),(void*)c); */
+
+ vecp_push(solver_read_wlist(s,lit_neg(begin[0])),
+ (void*)(size > 2 ? c : clause_from_lit(begin[1])));
+ vecp_push(solver_read_wlist(s,lit_neg(begin[1])),
+ (void*)(size > 2 ? c : clause_from_lit(begin[0])));
+
+ return c;
+}
+
+static void clause_remove(solver* s, clause* c)
+{
+ lit* lits = clause_begin(c);
+ assert(lit_neg(lits[0]) < s->size*2);
+ assert(lit_neg(lits[1]) < s->size*2);
+
+ /* vecp_remove(solver_read_wlist(s,lit_neg(lits[0])),(void*)c); */
+ /* vecp_remove(solver_read_wlist(s,lit_neg(lits[1])),(void*)c); */
+
+ assert(lits[0] < s->size*2);
+ vecp_remove(solver_read_wlist(s,lit_neg(lits[0])),
+ (void*)(clause_size(c) > 2 ? c : clause_from_lit(lits[1])));
+ vecp_remove(solver_read_wlist(s,lit_neg(lits[1])),
+ (void*)(clause_size(c) > 2 ? c : clause_from_lit(lits[0])));
+
+ if (clause_learnt(c)){
+ s->stats.learnts--;
+ s->stats.learnts_literals -= clause_size(c);
+ }else{
+ s->stats.clauses--;
+ s->stats.clauses_literals -= clause_size(c);
+ }
+
+ free(c);
+}
+
+static lbool clause_simplify(solver* s, clause* c)
+{
+ lit* lits = clause_begin(c);
+ lbool* values = s->assigns;
+ int i;
+
+ assert(solver_dlevel(s) == 0);
+
+ for (i = 0; i < clause_size(c); i++){
+ lbool sig = !lit_sign(lits[i]); sig += sig - 1;
+ if (values[lit_var(lits[i])] == sig)
+ return l_True;
+ }
+ return l_False;
+}
+
+/*====================================================================*/
+/* Minor (solver) functions: */
+
+void solver_setnvars(solver* s,int n)
+{
+ int var;
+
+ if (s->cap < n){
+
+ while (s->cap < n) s->cap = s->cap*2+1;
+
+ s->wlists = (vecp*) realloc(s->wlists,
+ sizeof(vecp)*s->cap*2);
+ s->activity = (double*) realloc(s->activity,
+ sizeof(double)*s->cap);
+ s->assigns = (lbool*) realloc(s->assigns,
+ sizeof(lbool)*s->cap);
+ s->orderpos = (int*) realloc(s->orderpos,
+ sizeof(int)*s->cap);
+ s->reasons = (clause**)realloc(s->reasons,
+ sizeof(clause*)*s->cap);
+ s->levels = (int*) realloc(s->levels,
+ sizeof(int)*s->cap);
+ s->tags = (lbool*) realloc(s->tags,
+ sizeof(lbool)*s->cap);
+ s->trail = (lit*) realloc(s->trail,
+ sizeof(lit)*s->cap);
+ }
+
+ for (var = s->size; var < n; var++){
+ vecp_new(&s->wlists[2*var]);
+ vecp_new(&s->wlists[2*var+1]);
+ s->activity [var] = 0;
+ s->assigns [var] = l_Undef;
+ s->orderpos [var] = veci_size(&s->order);
+ s->reasons [var] = (clause*)0;
+ s->levels [var] = 0;
+ s->tags [var] = l_Undef;
+
+ /* does not hold because variables enqueued at top level will
+ not be reinserted in the heap
+ assert(veci_size(&s->order) == var);
+ */
+ veci_push(&s->order,var);
+ order_update(s, var);
+ }
+
+ s->size = n > s->size ? n : s->size;
+}
+
+static inline bool enqueue(solver* s, lit l, clause* from)
+{
+ lbool* values = s->assigns;
+ int v = lit_var(l);
+ lbool val = values[v];
+ lbool sig;
+#ifdef VERBOSEDEBUG
+ printf(L_IND"enqueue("L_LIT")\n", L_ind, L_lit(l));
+#endif
+
+ /* lbool */ sig = !lit_sign(l); sig += sig - 1;
+ if (val != l_Undef){
+ return val == sig;
+ }else{
+ /* New fact -- store it. */
+ int* levels;
+ clause** reasons;
+#ifdef VERBOSEDEBUG
+ printf(L_IND"bind("L_LIT")\n", L_ind, L_lit(l));
+#endif
+ /* int* */ levels = s->levels;
+ /* clause** */ reasons = s->reasons;
+
+ values [v] = sig;
+ levels [v] = solver_dlevel(s);
+ reasons[v] = from;
+ s->trail[s->qtail++] = l;
+
+ order_assigned(s, v);
+ return true;
+ }
+}
+
+static inline void assume(solver* s, lit l){
+ assert(s->qtail == s->qhead);
+ assert(s->assigns[lit_var(l)] == l_Undef);
+#ifdef VERBOSEDEBUG
+ printf(L_IND"assume("L_LIT")\n", L_ind, L_lit(l));
+#endif
+ veci_push(&s->trail_lim,s->qtail);
+ enqueue(s,l,(clause*)0);
+}
+
+static inline void solver_canceluntil(solver* s, int level) {
+ lit* trail;
+ lbool* values;
+ clause** reasons;
+ int bound;
+ int c;
+
+ if (solver_dlevel(s) <= level)
+ return;
+
+ trail = s->trail;
+ values = s->assigns;
+ reasons = s->reasons;
+ bound = (veci_begin(&s->trail_lim))[level];
+
+ for (c = s->qtail-1; c >= bound; c--) {
+ int x = lit_var(trail[c]);
+ values [x] = l_Undef;
+ reasons[x] = (clause*)0;
+ }
+
+ for (c = s->qhead-1; c >= bound; c--)
+ order_unassigned(s,lit_var(trail[c]));
+
+ s->qhead = s->qtail = bound;
+ veci_resize(&s->trail_lim,level);
+}
+
+static void solver_record(solver* s, veci* cls)
+{
+ lit* begin = veci_begin(cls);
+ lit* end = begin + veci_size(cls);
+ clause* c = (veci_size(cls) > 1) ? clause_new(s,begin,end,1)
+ : (clause*)0;
+ enqueue(s,*begin,c);
+
+ assert(veci_size(cls) > 0);
+
+ if (c != 0) {
+ vecp_push(&s->learnts,c);
+ act_clause_bump(s,c);
+ s->stats.learnts++;
+ s->stats.learnts_literals += veci_size(cls);
+ }
+}
+
+static double solver_progress(solver* s)
+{
+ lbool* values = s->assigns;
+ int* levels = s->levels;
+ int i;
+
+ double progress = 0;
+ double F = 1.0 / s->size;
+ for (i = 0; i < s->size; i++)
+ if (values[i] != l_Undef)
+ progress += pow(F, levels[i]);
+ return progress / s->size;
+}
+
+/*====================================================================*/
+/* Major methods: */
+
+static bool solver_lit_removable(solver* s, lit l, int minl)
+{
+ lbool* tags = s->tags;
+ clause** reasons = s->reasons;
+ int* levels = s->levels;
+ int top = veci_size(&s->tagged);
+
+ assert(lit_var(l) >= 0 && lit_var(l) < s->size);
+ assert(reasons[lit_var(l)] != 0);
+ veci_resize(&s->stack,0);
+ veci_push(&s->stack,lit_var(l));
+
+ while (veci_size(&s->stack) > 0){
+ clause* c;
+ int v = veci_begin(&s->stack)[veci_size(&s->stack)-1];
+ assert(v >= 0 && v < s->size);
+ veci_resize(&s->stack,veci_size(&s->stack)-1);
+ assert(reasons[v] != 0);
+ c = reasons[v];
+
+ if (clause_is_lit(c)){
+ int v = lit_var(clause_read_lit(c));
+ if (tags[v] == l_Undef && levels[v] != 0){
+ if (reasons[v] != 0
+ && ((1 << (levels[v] & 31)) & minl)){
+ veci_push(&s->stack,v);
+ tags[v] = l_True;
+ veci_push(&s->tagged,v);
+ }else{
+ int* tagged = veci_begin(&s->tagged);
+ int j;
+ for (j = top; j < veci_size(&s->tagged); j++)
+ tags[tagged[j]] = l_Undef;
+ veci_resize(&s->tagged,top);
+ return false;
+ }
+ }
+ }else{
+ lit* lits = clause_begin(c);
+ int i, j;
+
+ for (i = 1; i < clause_size(c); i++){
+ int v = lit_var(lits[i]);
+ if (tags[v] == l_Undef && levels[v] != 0){
+ if (reasons[v] != 0
+ && ((1 << (levels[v] & 31)) & minl)){
+
+ veci_push(&s->stack,lit_var(lits[i]));
+ tags[v] = l_True;
+ veci_push(&s->tagged,v);
+ }else{
+ int* tagged = veci_begin(&s->tagged);
+ for (j = top; j < veci_size(&s->tagged); j++)
+ tags[tagged[j]] = l_Undef;
+ veci_resize(&s->tagged,top);
+ return false;
+ }
+ }
+ }
+ }
+ }
+
+ return true;
+}
+
+static void solver_analyze(solver* s, clause* c, veci* learnt)
+{
+ lit* trail = s->trail;
+ lbool* tags = s->tags;
+ clause** reasons = s->reasons;
+ int* levels = s->levels;
+ int cnt = 0;
+ lit p = lit_Undef;
+ int ind = s->qtail-1;
+ lit* lits;
+ int i, j, minl;
+ int* tagged;
+
+ veci_push(learnt,lit_Undef);
+
+ do{
+ assert(c != 0);
+
+ if (clause_is_lit(c)){
+ lit q = clause_read_lit(c);
+ assert(lit_var(q) >= 0 && lit_var(q) < s->size);
+ if (tags[lit_var(q)] == l_Undef && levels[lit_var(q)] > 0){
+ tags[lit_var(q)] = l_True;
+ veci_push(&s->tagged,lit_var(q));
+ act_var_bump(s,lit_var(q));
+ if (levels[lit_var(q)] == solver_dlevel(s))
+ cnt++;
+ else
+ veci_push(learnt,q);
+ }
+ }else{
+
+ if (clause_learnt(c))
+ act_clause_bump(s,c);
+
+ lits = clause_begin(c);
+ /* printlits(lits,lits+clause_size(c)); printf("\n"); */
+ for (j = (p == lit_Undef ? 0 : 1); j < clause_size(c); j++){
+ lit q = lits[j];
+ assert(lit_var(q) >= 0 && lit_var(q) < s->size);
+ if (tags[lit_var(q)] == l_Undef
+ && levels[lit_var(q)] > 0){
+ tags[lit_var(q)] = l_True;
+ veci_push(&s->tagged,lit_var(q));
+ act_var_bump(s,lit_var(q));
+ if (levels[lit_var(q)] == solver_dlevel(s))
+ cnt++;
+ else
+ veci_push(learnt,q);
+ }
+ }
+ }
+
+ while (tags[lit_var(trail[ind--])] == l_Undef);
+
+ p = trail[ind+1];
+ c = reasons[lit_var(p)];
+ cnt--;
+
+ }while (cnt > 0);
+
+ *veci_begin(learnt) = lit_neg(p);
+
+ lits = veci_begin(learnt);
+ minl = 0;
+ for (i = 1; i < veci_size(learnt); i++){
+ int lev = levels[lit_var(lits[i])];
+ minl |= 1 << (lev & 31);
+ }
+
+ /* simplify (full) */
+ for (i = j = 1; i < veci_size(learnt); i++){
+ if (reasons[lit_var(lits[i])] == 0
+ || !solver_lit_removable(s,lits[i],minl))
+ lits[j++] = lits[i];
+ }
+
+ /* update size of learnt + statistics */
+ s->stats.max_literals += veci_size(learnt);
+ veci_resize(learnt,j);
+ s->stats.tot_literals += j;
+
+ /* clear tags */
+ tagged = veci_begin(&s->tagged);
+ for (i = 0; i < veci_size(&s->tagged); i++)
+ tags[tagged[i]] = l_Undef;
+ veci_resize(&s->tagged,0);
+
+#ifdef DEBUG
+ for (i = 0; i < s->size; i++)
+ assert(tags[i] == l_Undef);
+#endif
+
+#ifdef VERBOSEDEBUG
+ printf(L_IND"Learnt {", L_ind);
+ for (i = 0; i < veci_size(learnt); i++)
+ printf(" "L_LIT, L_lit(lits[i]));
+#endif
+ if (veci_size(learnt) > 1){
+ int max_i = 1;
+ int max = levels[lit_var(lits[1])];
+ lit tmp;
+
+ for (i = 2; i < veci_size(learnt); i++)
+ if (levels[lit_var(lits[i])] > max){
+ max = levels[lit_var(lits[i])];
+ max_i = i;
+ }
+
+ tmp = lits[1];
+ lits[1] = lits[max_i];
+ lits[max_i] = tmp;
+ }
+#ifdef VERBOSEDEBUG
+ {
+ int lev = veci_size(learnt) > 1 ? levels[lit_var(lits[1])] : 0;
+ printf(" } at level %d\n", lev);
+ }
+#endif
+}
+
+clause* solver_propagate(solver* s)
+{
+ lbool* values = s->assigns;
+ clause* confl = (clause*)0;
+ lit* lits;
+
+ /* printf("solver_propagate\n"); */
+ while (confl == 0 && s->qtail - s->qhead > 0){
+ lit p = s->trail[s->qhead++];
+ vecp* ws = solver_read_wlist(s,p);
+ clause **begin = (clause**)vecp_begin(ws);
+ clause **end = begin + vecp_size(ws);
+ clause **i, **j;
+
+ s->stats.propagations++;
+ s->simpdb_props--;
+
+ /* printf("checking lit %d: "L_LIT"\n", veci_size(ws),
+ L_lit(p)); */
+ for (i = j = begin; i < end; ){
+ if (clause_is_lit(*i)){
+ *j++ = *i;
+ if (!enqueue(s,clause_read_lit(*i),clause_from_lit(p))){
+ confl = s->binary;
+ (clause_begin(confl))[1] = lit_neg(p);
+ (clause_begin(confl))[0] = clause_read_lit(*i++);
+
+ /* Copy the remaining watches: */
+ while (i < end)
+ *j++ = *i++;
+ }
+ }else{
+ lit false_lit;
+ lbool sig;
+
+ lits = clause_begin(*i);
+
+ /* Make sure the false literal is data[1]: */
+ false_lit = lit_neg(p);
+ if (lits[0] == false_lit){
+ lits[0] = lits[1];
+ lits[1] = false_lit;
+ }
+ assert(lits[1] == false_lit);
+ /* printf("checking clause: ");
+ printlits(lits, lits+clause_size(*i));
+ printf("\n"); */
+
+ /* If 0th watch is true, then clause is already
+ satisfied. */
+ sig = !lit_sign(lits[0]); sig += sig - 1;
+ if (values[lit_var(lits[0])] == sig){
+ *j++ = *i;
+ }else{
+ /* Look for new watch: */
+ lit* stop = lits + clause_size(*i);
+ lit* k;
+ for (k = lits + 2; k < stop; k++){
+ lbool sig = lit_sign(*k); sig += sig - 1;
+ if (values[lit_var(*k)] != sig){
+ lits[1] = *k;
+ *k = false_lit;
+ vecp_push(solver_read_wlist(s,
+ lit_neg(lits[1])),*i);
+ goto next; }
+ }
+
+ *j++ = *i;
+ /* Clause is unit under assignment: */
+ if (!enqueue(s,lits[0], *i)){
+ confl = *i++;
+ /* Copy the remaining watches: */
+ while (i < end)
+ *j++ = *i++;
+ }
+ }
+ }
+ next:
+ i++;
+ }
+
+ s->stats.inspects += j - (clause**)vecp_begin(ws);
+ vecp_resize(ws,j - (clause**)vecp_begin(ws));
+ }
+
+ return confl;
+}
+
+static inline int clause_cmp (const void* x, const void* y) {
+ return clause_size((clause*)x) > 2
+ && (clause_size((clause*)y) == 2
+ || clause_activity((clause*)x)
+ < clause_activity((clause*)y)) ? -1 : 1; }
+
+void solver_reducedb(solver* s)
+{
+ int i, j;
+ double extra_lim = s->cla_inc / vecp_size(&s->learnts);
+ /* Remove any clause below this activity */
+ clause** learnts = (clause**)vecp_begin(&s->learnts);
+ clause** reasons = s->reasons;
+
+ sort(vecp_begin(&s->learnts), vecp_size(&s->learnts), clause_cmp);
+
+ for (i = j = 0; i < vecp_size(&s->learnts) / 2; i++){
+ if (clause_size(learnts[i]) > 2
+ && reasons[lit_var(*clause_begin(learnts[i]))]
+ != learnts[i])
+ clause_remove(s,learnts[i]);
+ else
+ learnts[j++] = learnts[i];
+ }
+ for (; i < vecp_size(&s->learnts); i++){
+ if (clause_size(learnts[i]) > 2
+ && reasons[lit_var(*clause_begin(learnts[i]))]
+ != learnts[i]
+ && clause_activity(learnts[i]) < extra_lim)
+ clause_remove(s,learnts[i]);
+ else
+ learnts[j++] = learnts[i];
+ }
+
+ /* printf("reducedb deleted %d\n", vecp_size(&s->learnts) - j); */
+
+ vecp_resize(&s->learnts,j);
+}
+
+static lbool solver_search(solver* s, int nof_conflicts,
+ int nof_learnts)
+{
+ int* levels = s->levels;
+ double var_decay = 0.95;
+ double clause_decay = 0.999;
+ double random_var_freq = 0.02;
+
+ int conflictC = 0;
+ veci learnt_clause;
+
+ assert(s->root_level == solver_dlevel(s));
+
+ s->stats.starts++;
+ s->var_decay = (float)(1 / var_decay );
+ s->cla_decay = (float)(1 / clause_decay);
+ veci_resize(&s->model,0);
+ veci_new(&learnt_clause);
+
+ for (;;){
+ clause* confl = solver_propagate(s);
+ if (confl != 0){
+ /* CONFLICT */
+ int blevel;
+
+#ifdef VERBOSEDEBUG
+ printf(L_IND"**CONFLICT**\n", L_ind);
+#endif
+ s->stats.conflicts++; conflictC++;
+ if (solver_dlevel(s) == s->root_level){
+ veci_delete(&learnt_clause);
+ return l_False;
+ }
+
+ veci_resize(&learnt_clause,0);
+ solver_analyze(s, confl, &learnt_clause);
+ blevel = veci_size(&learnt_clause) > 1
+ ? levels[lit_var(veci_begin(&learnt_clause)[1])]
+ : s->root_level;
+ blevel = s->root_level > blevel ? s->root_level : blevel;
+ solver_canceluntil(s,blevel);
+ solver_record(s,&learnt_clause);
+ act_var_decay(s);
+ act_clause_decay(s);
+
+ }else{
+ /* NO CONFLICT */
+ int next;
+
+ if (nof_conflicts >= 0 && conflictC >= nof_conflicts){
+ /* Reached bound on number of conflicts: */
+ s->progress_estimate = solver_progress(s);
+ solver_canceluntil(s,s->root_level);
+ veci_delete(&learnt_clause);
+ return l_Undef; }
+
+ if (solver_dlevel(s) == 0)
+ /* Simplify the set of problem clauses: */
+ solver_simplify(s);
+
+ if (nof_learnts >= 0
+ && vecp_size(&s->learnts) - s->qtail >= nof_learnts)
+ /* Reduce the set of learnt clauses: */
+ solver_reducedb(s);
+
+ /* New variable decision: */
+ s->stats.decisions++;
+ next = order_select(s,(float)random_var_freq);
+
+ if (next == var_Undef){
+ /* Model found: */
+ lbool* values = s->assigns;
+ int i;
+ for (i = 0; i < s->size; i++)
+ veci_push(&s->model,(int)values[i]);
+ solver_canceluntil(s,s->root_level);
+ veci_delete(&learnt_clause);
+
+ /*
+ veci apa; veci_new(&apa);
+ for (i = 0; i < s->size; i++)
+ veci_push(&apa,(int)(s->model.ptr[i] == l_True
+ ? toLit(i) : lit_neg(toLit(i))));
+ printf("model: ");
+ printlits((lit*)apa.ptr,
+ (lit*)apa.ptr + veci_size(&apa)); printf("\n");
+ veci_delete(&apa);
+ */
+
+ return l_True;
+ }
+
+ assume(s,lit_neg(toLit(next)));
+ }
+ }
+
+#if 0 /* by mao; unreachable code */
+ return l_Undef; /* cannot happen */
+#endif
+}
+
+/*====================================================================*/
+/* External solver functions: */
+
+solver* solver_new(void)
+{
+ solver* s = (solver*)malloc(sizeof(solver));
+
+ /* initialize vectors */
+ vecp_new(&s->clauses);
+ vecp_new(&s->learnts);
+ veci_new(&s->order);
+ veci_new(&s->trail_lim);
+ veci_new(&s->tagged);
+ veci_new(&s->stack);
+ veci_new(&s->model);
+
+ /* initialize arrays */
+ s->wlists = 0;
+ s->activity = 0;
+ s->assigns = 0;
+ s->orderpos = 0;
+ s->reasons = 0;
+ s->levels = 0;
+ s->tags = 0;
+ s->trail = 0;
+
+ /* initialize other vars */
+ s->size = 0;
+ s->cap = 0;
+ s->qhead = 0;
+ s->qtail = 0;
+ s->cla_inc = 1;
+ s->cla_decay = 1;
+ s->var_inc = 1;
+ s->var_decay = 1;
+ s->root_level = 0;
+ s->simpdb_assigns = 0;
+ s->simpdb_props = 0;
+ s->random_seed = 91648253;
+ s->progress_estimate = 0;
+ s->binary = (clause*)malloc(sizeof(clause)
+ + sizeof(lit)*2);
+ s->binary->size_learnt = (2 << 1);
+ s->verbosity = 0;
+
+ s->stats.starts = 0;
+ s->stats.decisions = 0;
+ s->stats.propagations = 0;
+ s->stats.inspects = 0;
+ s->stats.conflicts = 0;
+ s->stats.clauses = 0;
+ s->stats.clauses_literals = 0;
+ s->stats.learnts = 0;
+ s->stats.learnts_literals = 0;
+ s->stats.max_literals = 0;
+ s->stats.tot_literals = 0;
+
+ return s;
+}
+
+void solver_delete(solver* s)
+{
+ int i;
+ for (i = 0; i < vecp_size(&s->clauses); i++)
+ free(vecp_begin(&s->clauses)[i]);
+
+ for (i = 0; i < vecp_size(&s->learnts); i++)
+ free(vecp_begin(&s->learnts)[i]);
+
+ /* delete vectors */
+ vecp_delete(&s->clauses);
+ vecp_delete(&s->learnts);
+ veci_delete(&s->order);
+ veci_delete(&s->trail_lim);
+ veci_delete(&s->tagged);
+ veci_delete(&s->stack);
+ veci_delete(&s->model);
+ free(s->binary);
+
+ /* delete arrays */
+ if (s->wlists != 0){
+ int i;
+ for (i = 0; i < s->size*2; i++)
+ vecp_delete(&s->wlists[i]);
+
+ /* if one is different from null, all are */
+ free(s->wlists);
+ free(s->activity );
+ free(s->assigns );
+ free(s->orderpos );
+ free(s->reasons );
+ free(s->levels );
+ free(s->trail );
+ free(s->tags );
+ }
+
+ free(s);
+}
+
+bool solver_addclause(solver* s, lit* begin, lit* end)
+{
+ lit *i,*j;
+ int maxvar;
+ lbool* values;
+ lit last;
+
+ if (begin == end) return false;
+
+ /* printlits(begin,end); printf("\n"); */
+ /* insertion sort */
+ maxvar = lit_var(*begin);
+ for (i = begin + 1; i < end; i++){
+ lit l = *i;
+ maxvar = lit_var(l) > maxvar ? lit_var(l) : maxvar;
+ for (j = i; j > begin && *(j-1) > l; j--)
+ *j = *(j-1);
+ *j = l;
+ }
+ solver_setnvars(s,maxvar+1);
+
+ /* printlits(begin,end); printf("\n"); */
+ values = s->assigns;
+
+ /* delete duplicates */
+ last = lit_Undef;
+ for (i = j = begin; i < end; i++){
+ /* printf("lit: "L_LIT", value = %d\n", L_lit(*i),
+ (lit_sign(*i) ? -values[lit_var(*i)] : values[lit_var(*i)])); */
+ lbool sig = !lit_sign(*i); sig += sig - 1;
+ if (*i == lit_neg(last) || sig == values[lit_var(*i)])
+ return true; /* tautology */
+ else if (*i != last && values[lit_var(*i)] == l_Undef)
+ last = *j++ = *i;
+ }
+
+ /* printf("final: "); printlits(begin,j); printf("\n"); */
+
+ if (j == begin) /* empty clause */
+ return false;
+ else if (j - begin == 1) /* unit clause */
+ return enqueue(s,*begin,(clause*)0);
+
+ /* create new clause */
+ vecp_push(&s->clauses,clause_new(s,begin,j,0));
+
+ s->stats.clauses++;
+ s->stats.clauses_literals += j - begin;
+
+ return true;
+}
+
+bool solver_simplify(solver* s)
+{
+ clause** reasons;
+ int type;
+
+ assert(solver_dlevel(s) == 0);
+
+ if (solver_propagate(s) != 0)
+ return false;
+
+ if (s->qhead == s->simpdb_assigns || s->simpdb_props > 0)
+ return true;
+
+ reasons = s->reasons;
+ for (type = 0; type < 2; type++){
+ vecp* cs = type ? &s->learnts : &s->clauses;
+ clause** cls = (clause**)vecp_begin(cs);
+
+ int i, j;
+ for (j = i = 0; i < vecp_size(cs); i++){
+ if (reasons[lit_var(*clause_begin(cls[i]))] != cls[i] &&
+ clause_simplify(s,cls[i]) == l_True)
+ clause_remove(s,cls[i]);
+ else
+ cls[j++] = cls[i];
+ }
+ vecp_resize(cs,j);
+ }
+
+ s->simpdb_assigns = s->qhead;
+ /* (shouldn't depend on 'stats' really, but it will do for now) */
+ s->simpdb_props = (int)(s->stats.clauses_literals
+ + s->stats.learnts_literals);
+
+ return true;
+}
+
+bool solver_solve(solver* s, lit* begin, lit* end)
+{
+ double nof_conflicts = 100;
+ double nof_learnts = solver_nclauses(s) / 3;
+ lbool status = l_Undef;
+ lbool* values = s->assigns;
+ lit* i;
+
+ /* printf("solve: "); printlits(begin, end); printf("\n"); */
+ for (i = begin; i < end; i++){
+ switch (lit_sign(*i) ? -values[lit_var(*i)]
+ : values[lit_var(*i)]){
+ case 1: /* l_True: */
+ break;
+ case 0: /* l_Undef */
+ assume(s, *i);
+ if (solver_propagate(s) == NULL)
+ break;
+ /* falltrough */
+ case -1: /* l_False */
+ solver_canceluntil(s, 0);
+ return false;
+ }
+ }
+
+ s->root_level = solver_dlevel(s);
+
+ if (s->verbosity >= 1){
+ printf("==================================[MINISAT]============"
+ "=======================\n");
+ printf("| Conflicts | ORIGINAL | LEARNT "
+ " | Progress |\n");
+ printf("| | Clauses Literals | Limit Clauses Litera"
+ "ls Lit/Cl | |\n");
+ printf("======================================================="
+ "=======================\n");
+ }
+
+ while (status == l_Undef){
+ double Ratio = (s->stats.learnts == 0)? 0.0 :
+ s->stats.learnts_literals / (double)s->stats.learnts;
+
+ if (s->verbosity >= 1){
+ printf("| %9.0f | %7.0f %8.0f | %7.0f %7.0f %8.0f %7.1f | %"
+ "6.3f %% |\n",
+ (double)s->stats.conflicts,
+ (double)s->stats.clauses,
+ (double)s->stats.clauses_literals,
+ (double)nof_learnts,
+ (double)s->stats.learnts,
+ (double)s->stats.learnts_literals,
+ Ratio,
+ s->progress_estimate*100);
+ fflush(stdout);
+ }
+ status = solver_search(s,(int)nof_conflicts, (int)nof_learnts);
+ nof_conflicts *= 1.5;
+ nof_learnts *= 1.1;
+ }
+ if (s->verbosity >= 1)
+ printf("======================================================="
+ "=======================\n");
+
+ solver_canceluntil(s,0);
+ return status != l_False;
+}
+
+int solver_nvars(solver* s)
+{
+ return s->size;
+}
+
+int solver_nclauses(solver* s)
+{
+ return vecp_size(&s->clauses);
+}
+
+int solver_nconflicts(solver* s)
+{
+ return (int)s->stats.conflicts;
+}
+
+/*====================================================================*/
+/* Sorting functions (sigh): */
+
+static inline void selectionsort(void** array, int size,
+ int(*comp)(const void *, const void *))
+{
+ int i, j, best_i;
+ void* tmp;
+
+ for (i = 0; i < size-1; i++){
+ best_i = i;
+ for (j = i+1; j < size; j++){
+ if (comp(array[j], array[best_i]) < 0)
+ best_i = j;
+ }
+ tmp = array[i]; array[i] = array[best_i]; array[best_i] = tmp;
+ }
+}
+
+static void sortrnd(void** array, int size,
+ int(*comp)(const void *, const void *),
+ double* seed)
+{
+ if (size <= 15)
+ selectionsort(array, size, comp);
+
+ else{
+ void* pivot = array[irand(seed, size)];
+ void* tmp;
+ int i = -1;
+ int j = size;
+
+ for(;;){
+ do i++; while(comp(array[i], pivot)<0);
+ do j--; while(comp(pivot, array[j])<0);
+
+ if (i >= j) break;
+
+ tmp = array[i]; array[i] = array[j]; array[j] = tmp;
+ }
+
+ sortrnd(array , i , comp, seed);
+ sortrnd(&array[i], size-i, comp, seed);
+ }
+}
+
+static void sort(void** array, int size,
+ int(*comp)(const void *, const void *))
+{
+ double seed = 91648253;
+ sortrnd(array,size,comp,&seed);
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/minisat/minisat.h b/test/monniaux/glpk-4.65/src/minisat/minisat.h
new file mode 100644
index 00000000..2733e8d6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/minisat/minisat.h
@@ -0,0 +1,230 @@
+/* minisat.h */
+
+/* Modified by Andrew Makhorin <mao@gnu.org>, August 2011 */
+
+/***********************************************************************
+* MiniSat -- Copyright (c) 2005, Niklas Sorensson
+* http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+*
+* Permission is hereby granted, free of charge, to any person
+* obtaining a copy of this software and associated documentation files
+* (the "Software"), to deal in the Software without restriction,
+* including without limitation the rights to use, copy, modify, merge,
+* publish, distribute, sublicense, and/or sell copies of the Software,
+* and to permit persons to whom the Software is furnished to do so,
+* subject to the following conditions:
+*
+* The above copyright notice and this permission notice shall be
+* included in all copies or substantial portions of the Software.
+*
+* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+* EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+* NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+* BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+* ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+* CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+* SOFTWARE.
+***********************************************************************/
+/* Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko */
+
+#ifndef MINISAT_H
+#define MINISAT_H
+
+/*====================================================================*/
+/* Simple types: */
+
+typedef int bool;
+
+#define true 1
+#define false 0
+
+typedef int lit;
+#if 0 /* by mao */
+typedef char lbool;
+#else
+typedef int lbool;
+#endif
+
+#define var_Undef (int)(-1)
+#define lit_Undef (lit)(-2)
+
+#define l_Undef (lbool)0
+#define l_True (lbool)1
+#define l_False (lbool)(-1)
+
+#define toLit(v) (lit)((v) + (v))
+#define lit_neg(l) (lit)((l) ^ 1)
+#define lit_var(l) (int)((l) >> 1)
+#define lit_sign(l) (int)((l) & 1)
+
+/*====================================================================*/
+/* Vectors: */
+
+/* vector of 32-bit intergers (added for 64-bit portability) */
+typedef struct /* veci_t */ {
+ int size;
+ int cap;
+ int* ptr;
+} veci;
+
+#define veci_new(v) \
+{ (v)->size = 0; \
+ (v)->cap = 4; \
+ (v)->ptr = (int*)malloc(sizeof(int)*(v)->cap); \
+}
+
+#define veci_delete(v) free((v)->ptr)
+
+#define veci_begin(v) ((v)->ptr)
+
+#define veci_size(v) ((v)->size)
+
+#define veci_resize(v, k) (void)((v)->size = (k))
+/* only safe to shrink !! */
+
+#define veci_push(v, e) \
+{ if ((v)->size == (v)->cap) \
+ { int newsize = (v)->cap * 2+1; \
+ (v)->ptr = (int*)realloc((v)->ptr,sizeof(int)*newsize); \
+ (v)->cap = newsize; \
+ } \
+ (v)->ptr[(v)->size++] = (e); \
+}
+
+/* vector of 32- or 64-bit pointers */
+typedef struct /* vecp_t */ {
+ int size;
+ int cap;
+ void** ptr;
+} vecp;
+
+#define vecp_new(v) \
+{ (v)->size = 0; \
+ (v)->cap = 4; \
+ (v)->ptr = (void**)malloc(sizeof(void*)*(v)->cap); \
+}
+
+#define vecp_delete(v) free((v)->ptr)
+
+#define vecp_begin(v) ((v)->ptr)
+
+#define vecp_size(v) ((v)->size)
+
+#define vecp_resize(v, k) (void)((v)->size = (k))
+/* only safe to shrink !! */
+
+#define vecp_push(v, e) \
+{ if ((v)->size == (v)->cap) \
+ { int newsize = (v)->cap * 2+1; \
+ (v)->ptr = (void**)realloc((v)->ptr,sizeof(void*)*newsize); \
+ (v)->cap = newsize; \
+ } \
+ (v)->ptr[(v)->size++] = (e); \
+}
+
+/*====================================================================*/
+/* Solver representation: */
+
+typedef struct /* clause_t */
+{
+ int size_learnt;
+ lit lits[1];
+} clause;
+
+typedef struct /* stats_t */
+{
+ double starts, decisions, propagations, inspects, conflicts;
+ double clauses, clauses_literals, learnts, learnts_literals,
+ max_literals, tot_literals;
+} stats;
+
+typedef struct /* solver_t */
+{
+ int size; /* nof variables */
+ int cap; /* size of varmaps */
+ int qhead; /* Head index of queue. */
+ int qtail; /* Tail index of queue. */
+
+ /* clauses */
+ vecp clauses; /* List of problem constraints.
+ (contains: clause*) */
+ vecp learnts; /* List of learnt clauses.
+ (contains: clause*) */
+
+ /* activities */
+ double var_inc; /* Amount to bump next variable with. */
+ double var_decay; /* INVERSE decay factor for variable
+ activity: stores 1/decay. */
+ float cla_inc; /* Amount to bump next clause with. */
+ float cla_decay; /* INVERSE decay factor for clause
+ activity: stores 1/decay. */
+
+ vecp* wlists;
+ double* activity; /* A heuristic measurement of the activity
+ of a variable. */
+ lbool* assigns; /* Current values of variables. */
+ int* orderpos; /* Index in variable order. */
+ clause** reasons;
+ int* levels;
+ lit* trail;
+
+ clause* binary; /* A temporary binary clause */
+ lbool* tags;
+ veci tagged; /* (contains: var) */
+ veci stack; /* (contains: var) */
+
+ veci order; /* Variable order. (heap) (contains: var) */
+ veci trail_lim; /* Separator indices for different decision
+ levels in 'trail'. (contains: int) */
+ veci model; /* If problem is solved, this vector
+ contains the model (contains: lbool). */
+
+ int root_level; /* Level of first proper decision. */
+ int simpdb_assigns;/* Number of top-level assignments at last
+ 'simplifyDB()'. */
+ int simpdb_props; /* Number of propagations before next
+ 'simplifyDB()'. */
+ double random_seed;
+ double progress_estimate;
+ int verbosity; /* Verbosity level.
+ 0=silent,
+ 1=some progress report,
+ 2=everything */
+
+ stats stats;
+} solver;
+
+/*====================================================================*/
+/* Public interface: */
+
+#if 1 /* by mao; to keep namespace clean */
+#define solver_new _glp_minisat_new
+#define solver_delete _glp_minisat_delete
+#define solver_addclause _glp_minisat_addclause
+#define solver_simplify _glp_minisat_simplify
+#define solver_solve _glp_minisat_solve
+#define solver_nvars _glp_minisat_nvars
+#define solver_nclauses _glp_minisat_nclauses
+#define solver_nconflicts _glp_minisat_nconflicts
+#define solver_setnvars _glp_minisat_setnvars
+#define solver_propagate _glp_minisat_propagate
+#define solver_reducedb _glp_minisat_reducedb
+#endif
+
+solver* solver_new(void);
+void solver_delete(solver* s);
+
+bool solver_addclause(solver* s, lit* begin, lit* end);
+bool solver_simplify(solver* s);
+bool solver_solve(solver* s, lit* begin, lit* end);
+
+int solver_nvars(solver* s);
+int solver_nclauses(solver* s);
+int solver_nconflicts(solver* s);
+
+void solver_setnvars(solver* s,int n);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/avl.c b/test/monniaux/glpk-4.65/src/misc/avl.c
new file mode 100644
index 00000000..c97cf13a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/avl.c
@@ -0,0 +1,405 @@
+/* avl.c (binary search tree) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "avl.h"
+#include "dmp.h"
+#include "env.h"
+
+struct AVL
+{ /* AVL tree (Adelson-Velsky & Landis binary search tree) */
+ DMP *pool;
+ /* memory pool for allocating nodes */
+ AVLNODE *root;
+ /* pointer to the root node */
+ int (*fcmp)(void *info, const void *key1, const void *key2);
+ /* application-defined key comparison routine */
+ void *info;
+ /* transit pointer passed to the routine fcmp */
+ int size;
+ /* the tree size (the total number of nodes) */
+ int height;
+ /* the tree height */
+};
+
+struct AVLNODE
+{ /* node of AVL tree */
+ const void *key;
+ /* pointer to the node key (data structure for representing keys
+ is supplied by the application) */
+ int rank;
+ /* node rank = relative position of the node in its own subtree =
+ the number of nodes in the left subtree plus one */
+ int type;
+ /* reserved for the application specific information */
+ void *link;
+ /* reserved for the application specific information */
+ AVLNODE *up;
+ /* pointer to the parent node */
+ short int flag;
+ /* node flag:
+ 0 - this node is the left child of its parent (or this node is
+ the root of the tree and has no parent)
+ 1 - this node is the right child of its parent */
+ short int bal;
+ /* node balance = the difference between heights of the right and
+ left subtrees:
+ -1 - the left subtree is higher than the right one;
+ 0 - the left and right subtrees have the same height;
+ +1 - the left subtree is lower than the right one */
+ AVLNODE *left;
+ /* pointer to the root of the left subtree */
+ AVLNODE *right;
+ /* pointer to the root of the right subtree */
+};
+
+AVL *avl_create_tree(int (*fcmp)(void *info, const void *key1,
+ const void *key2), void *info)
+{ /* create AVL tree */
+ AVL *tree;
+ tree = xmalloc(sizeof(AVL));
+ tree->pool = dmp_create_pool();
+ tree->root = NULL;
+ tree->fcmp = fcmp;
+ tree->info = info;
+ tree->size = 0;
+ tree->height = 0;
+ return tree;
+}
+
+int avl_strcmp(void *info, const void *key1, const void *key2)
+{ /* compare character string keys */
+ xassert(info == info);
+ return strcmp(key1, key2);
+}
+
+static AVLNODE *rotate_subtree(AVL *tree, AVLNODE *node);
+
+AVLNODE *avl_insert_node(AVL *tree, const void *key)
+{ /* insert new node into AVL tree */
+ AVLNODE *p, *q, *r;
+ short int flag;
+ /* find an appropriate point for insertion */
+ p = NULL; q = tree->root;
+ while (q != NULL)
+ { p = q;
+ if (tree->fcmp(tree->info, key, p->key) <= 0)
+ { flag = 0;
+ q = p->left;
+ p->rank++;
+ }
+ else
+ { flag = 1;
+ q = p->right;
+ }
+ }
+ /* create new node and insert it into the tree */
+ r = dmp_get_atom(tree->pool, sizeof(AVLNODE));
+ r->key = key; r->type = 0; r->link = NULL;
+ r->rank = 1; r->up = p;
+ r->flag = (short int)(p == NULL ? 0 : flag);
+ r->bal = 0; r->left = NULL; r->right = NULL;
+ tree->size++;
+ if (p == NULL)
+ tree->root = r;
+ else
+ if (flag == 0) p->left = r; else p->right = r;
+ /* go upstairs to the root and correct all subtrees affected by
+ insertion */
+ while (p != NULL)
+ { if (flag == 0)
+ { /* the height of the left subtree of [p] is increased */
+ if (p->bal > 0)
+ { p->bal = 0;
+ break;
+ }
+ if (p->bal < 0)
+ { rotate_subtree(tree, p);
+ break;
+ }
+ p->bal = -1; flag = p->flag; p = p->up;
+ }
+ else
+ { /* the height of the right subtree of [p] is increased */
+ if (p->bal < 0)
+ { p->bal = 0;
+ break;
+ }
+ if (p->bal > 0)
+ { rotate_subtree(tree, p);
+ break;
+ }
+ p->bal = +1; flag = p->flag; p = p->up;
+ }
+ }
+ /* if the root has been reached, the height of the entire tree is
+ increased */
+ if (p == NULL) tree->height++;
+ return r;
+}
+
+void avl_set_node_type(AVLNODE *node, int type)
+{ /* assign the type field of specified node */
+ node->type = type;
+ return;
+}
+
+void avl_set_node_link(AVLNODE *node, void *link)
+{ /* assign the link field of specified node */
+ node->link = link;
+ return;
+}
+
+AVLNODE *avl_find_node(AVL *tree, const void *key)
+{ /* find node in AVL tree */
+ AVLNODE *p;
+ int c;
+ p = tree->root;
+ while (p != NULL)
+ { c = tree->fcmp(tree->info, key, p->key);
+ if (c == 0) break;
+ p = (c < 0 ? p->left : p->right);
+ }
+ return p;
+}
+
+int avl_get_node_type(AVLNODE *node)
+{ /* retrieve the type field of specified node */
+ return node->type;
+}
+
+void *avl_get_node_link(AVLNODE *node)
+{ /* retrieve the link field of specified node */
+ return node->link;
+}
+
+static AVLNODE *find_next_node(AVL *tree, AVLNODE *node)
+{ /* find next node in AVL tree */
+ AVLNODE *p, *q;
+ if (tree->root == NULL) return NULL;
+ p = node;
+ q = (p == NULL ? tree->root : p->right);
+ if (q == NULL)
+ { /* go upstairs from the left subtree */
+ for (;;)
+ { q = p->up;
+ if (q == NULL) break;
+ if (p->flag == 0) break;
+ p = q;
+ }
+ }
+ else
+ { /* go downstairs into the right subtree */
+ for (;;)
+ { p = q->left;
+ if (p == NULL) break;
+ q = p;
+ }
+ }
+ return q;
+}
+
+void avl_delete_node(AVL *tree, AVLNODE *node)
+{ /* delete specified node from AVL tree */
+ AVLNODE *f, *p, *q, *r, *s, *x, *y;
+ short int flag;
+ p = node;
+ /* if both subtrees of the specified node are non-empty, the node
+ should be interchanged with the next one, at least one subtree
+ of which is always empty */
+ if (p->left == NULL || p->right == NULL) goto skip;
+ f = p->up; q = p->left;
+ r = find_next_node(tree, p); s = r->right;
+ if (p->right == r)
+ { if (f == NULL)
+ tree->root = r;
+ else
+ if (p->flag == 0) f->left = r; else f->right = r;
+ r->rank = p->rank; r->up = f;
+ r->flag = p->flag; r->bal = p->bal;
+ r->left = q; r->right = p;
+ q->up = r;
+ p->rank = 1; p->up = r; p->flag = 1;
+ p->bal = (short int)(s == NULL ? 0 : +1);
+ p->left = NULL; p->right = s;
+ if (s != NULL) s->up = p;
+ }
+ else
+ { x = p->right; y = r->up;
+ if (f == NULL)
+ tree->root = r;
+ else
+ if (p->flag == 0) f->left = r; else f->right = r;
+ r->rank = p->rank; r->up = f;
+ r->flag = p->flag; r->bal = p->bal;
+ r->left = q; r->right = x;
+ q->up = r; x->up = r; y->left = p;
+ p->rank = 1; p->up = y; p->flag = 0;
+ p->bal = (short int)(s == NULL ? 0 : +1);
+ p->left = NULL; p->right = s;
+ if (s != NULL) s->up = p;
+ }
+skip: /* now the specified node [p] has at least one empty subtree;
+ go upstairs to the root and adjust the rank field of all nodes
+ affected by deletion */
+ q = p; f = q->up;
+ while (f != NULL)
+ { if (q->flag == 0) f->rank--;
+ q = f; f = q->up;
+ }
+ /* delete the specified node from the tree */
+ f = p->up; flag = p->flag;
+ q = p->left != NULL ? p->left : p->right;
+ if (f == NULL)
+ tree->root = q;
+ else
+ if (flag == 0) f->left = q; else f->right = q;
+ if (q != NULL) q->up = f, q->flag = flag;
+ tree->size--;
+ /* go upstairs to the root and correct all subtrees affected by
+ deletion */
+ while (f != NULL)
+ { if (flag == 0)
+ { /* the height of the left subtree of [f] is decreased */
+ if (f->bal == 0)
+ { f->bal = +1;
+ break;
+ }
+ if (f->bal < 0)
+ f->bal = 0;
+ else
+ { f = rotate_subtree(tree, f);
+ if (f->bal < 0) break;
+ }
+ flag = f->flag; f = f->up;
+ }
+ else
+ { /* the height of the right subtree of [f] is decreased */
+ if (f->bal == 0)
+ { f->bal = -1;
+ break;
+ }
+ if (f->bal > 0)
+ f->bal = 0;
+ else
+ { f = rotate_subtree(tree, f);
+ if (f->bal > 0) break;
+ }
+ flag = f->flag; f = f->up;
+ }
+ }
+ /* if the root has been reached, the height of the entire tree is
+ decreased */
+ if (f == NULL) tree->height--;
+ /* returns the deleted node to the memory pool */
+ dmp_free_atom(tree->pool, p, sizeof(AVLNODE));
+ return;
+}
+
+static AVLNODE *rotate_subtree(AVL *tree, AVLNODE *node)
+{ /* restore balance of AVL subtree */
+ AVLNODE *f, *p, *q, *r, *x, *y;
+ xassert(node != NULL);
+ p = node;
+ if (p->bal < 0)
+ { /* perform negative (left) rotation */
+ f = p->up; q = p->left; r = q->right;
+ if (q->bal <= 0)
+ { /* perform single negative rotation */
+ if (f == NULL)
+ tree->root = q;
+ else
+ if (p->flag == 0) f->left = q; else f->right = q;
+ p->rank -= q->rank;
+ q->up = f; q->flag = p->flag; q->bal++; q->right = p;
+ p->up = q; p->flag = 1;
+ p->bal = (short int)(-q->bal); p->left = r;
+ if (r != NULL) r->up = p, r->flag = 0;
+ node = q;
+ }
+ else
+ { /* perform double negative rotation */
+ x = r->left; y = r->right;
+ if (f == NULL)
+ tree->root = r;
+ else
+ if (p->flag == 0) f->left = r; else f->right = r;
+ p->rank -= (q->rank + r->rank);
+ r->rank += q->rank;
+ p->bal = (short int)(r->bal >= 0 ? 0 : +1);
+ q->bal = (short int)(r->bal <= 0 ? 0 : -1);
+ r->up = f; r->flag = p->flag; r->bal = 0;
+ r->left = q; r->right = p;
+ p->up = r; p->flag = 1; p->left = y;
+ q->up = r; q->flag = 0; q->right = x;
+ if (x != NULL) x->up = q, x->flag = 1;
+ if (y != NULL) y->up = p, y->flag = 0;
+ node = r;
+ }
+ }
+ else
+ { /* perform positive (right) rotation */
+ f = p->up; q = p->right; r = q->left;
+ if (q->bal >= 0)
+ { /* perform single positive rotation */
+ if (f == NULL)
+ tree->root = q;
+ else
+ if (p->flag == 0) f->left = q; else f->right = q;
+ q->rank += p->rank;
+ q->up = f; q->flag = p->flag; q->bal--; q->left = p;
+ p->up = q; p->flag = 0;
+ p->bal = (short int)(-q->bal); p->right = r;
+ if (r != NULL) r->up = p, r->flag = 1;
+ node = q;
+ }
+ else
+ { /* perform double positive rotation */
+ x = r->left; y = r->right;
+ if (f == NULL)
+ tree->root = r;
+ else
+ if (p->flag == 0) f->left = r; else f->right = r;
+ q->rank -= r->rank;
+ r->rank += p->rank;
+ p->bal = (short int)(r->bal <= 0 ? 0 : -1);
+ q->bal = (short int)(r->bal >= 0 ? 0 : +1);
+ r->up = f; r->flag = p->flag; r->bal = 0;
+ r->left = p; r->right = q;
+ p->up = r; p->flag = 0; p->right = x;
+ q->up = r; q->flag = 1; q->left = y;
+ if (x != NULL) x->up = p, x->flag = 1;
+ if (y != NULL) y->up = q, y->flag = 0;
+ node = r;
+ }
+ }
+ return node;
+}
+
+void avl_delete_tree(AVL *tree)
+{ /* delete AVL tree */
+ dmp_delete_pool(tree->pool);
+ xfree(tree);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/avl.h b/test/monniaux/glpk-4.65/src/misc/avl.h
new file mode 100644
index 00000000..b0aaef61
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/avl.h
@@ -0,0 +1,73 @@
+/* avl.h (binary search tree) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef AVL_H
+#define AVL_H
+
+typedef struct AVL AVL;
+typedef struct AVLNODE AVLNODE;
+
+#define avl_create_tree _glp_avl_create_tree
+AVL *avl_create_tree(int (*fcmp)(void *info, const void *key1,
+ const void *key2), void *info);
+/* create AVL tree */
+
+#define avl_strcmp _glp_avl_strcmp
+int avl_strcmp(void *info, const void *key1, const void *key2);
+/* compare character string keys */
+
+#define avl_insert_node _glp_avl_insert_node
+AVLNODE *avl_insert_node(AVL *tree, const void *key);
+/* insert new node into AVL tree */
+
+#define avl_set_node_type _glp_avl_set_node_type
+void avl_set_node_type(AVLNODE *node, int type);
+/* assign the type field of specified node */
+
+#define avl_set_node_link _glp_avl_set_node_link
+void avl_set_node_link(AVLNODE *node, void *link);
+/* assign the link field of specified node */
+
+#define avl_find_node _glp_avl_find_node
+AVLNODE *avl_find_node(AVL *tree, const void *key);
+/* find node in AVL tree */
+
+#define avl_get_node_type _glp_avl_get_node_type
+int avl_get_node_type(AVLNODE *node);
+/* retrieve the type field of specified node */
+
+#define avl_get_node_link _glp_avl_get_node_link
+void *avl_get_node_link(AVLNODE *node);
+/* retrieve the link field of specified node */
+
+#define avl_delete_node _glp_avl_delete_node
+void avl_delete_node(AVL *tree, AVLNODE *node);
+/* delete specified node from AVL tree */
+
+#define avl_delete_tree _glp_avl_delete_tree
+void avl_delete_tree(AVL *tree);
+/* delete AVL tree */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/bignum.c b/test/monniaux/glpk-4.65/src/misc/bignum.c
new file mode 100644
index 00000000..540dd9fd
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/bignum.c
@@ -0,0 +1,286 @@
+/* bignum.c (bignum arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2006-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "bignum.h"
+
+/***********************************************************************
+* Two routines below are intended to multiply and divide unsigned
+* integer numbers of arbitrary precision.
+*
+* The routines assume that an unsigned integer number is represented in
+* the positional numeral system with the base 2^16 = 65536, i.e. each
+* "digit" of the number is in the range [0, 65535] and represented as
+* a 16-bit value of the unsigned short type. In other words, a number x
+* has the following representation:
+*
+* n-1
+* x = sum d[j] * 65536^j,
+* j=0
+*
+* where n is the number of places (positions), and d[j] is j-th "digit"
+* of x, 0 <= d[j] <= 65535.
+***********************************************************************/
+
+/***********************************************************************
+* NAME
+*
+* bigmul - multiply unsigned integer numbers of arbitrary precision
+*
+* SYNOPSIS
+*
+* #include "bignum.h"
+* void bigmul(int n, int m, unsigned short x[], unsigned short y[]);
+*
+* DESCRIPTION
+*
+* The routine bigmul multiplies unsigned integer numbers of arbitrary
+* precision.
+*
+* n is the number of digits of multiplicand, n >= 1;
+*
+* m is the number of digits of multiplier, m >= 1;
+*
+* x is an array containing digits of the multiplicand in elements
+* x[m], x[m+1], ..., x[n+m-1]. Contents of x[0], x[1], ..., x[m-1] are
+* ignored on entry.
+*
+* y is an array containing digits of the multiplier in elements y[0],
+* y[1], ..., y[m-1].
+*
+* On exit digits of the product are stored in elements x[0], x[1], ...,
+* x[n+m-1]. The array y is not changed. */
+
+void bigmul(int n, int m, unsigned short x[], unsigned short y[])
+{ int i, j;
+ unsigned int t;
+ xassert(n >= 1);
+ xassert(m >= 1);
+ for (j = 0; j < m; j++) x[j] = 0;
+ for (i = 0; i < n; i++)
+ { if (x[i+m])
+ { t = 0;
+ for (j = 0; j < m; j++)
+ { t += (unsigned int)x[i+m] * (unsigned int)y[j] +
+ (unsigned int)x[i+j];
+ x[i+j] = (unsigned short)t;
+ t >>= 16;
+ }
+ x[i+m] = (unsigned short)t;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* bigdiv - divide unsigned integer numbers of arbitrary precision
+*
+* SYNOPSIS
+*
+* #include "bignum.h"
+* void bigdiv(int n, int m, unsigned short x[], unsigned short y[]);
+*
+* DESCRIPTION
+*
+* The routine bigdiv divides one unsigned integer number of arbitrary
+* precision by another with the algorithm described in [1].
+*
+* n is the difference between the number of digits of dividend and the
+* number of digits of divisor, n >= 0.
+*
+* m is the number of digits of divisor, m >= 1.
+*
+* x is an array containing digits of the dividend in elements x[0],
+* x[1], ..., x[n+m-1].
+*
+* y is an array containing digits of the divisor in elements y[0],
+* y[1], ..., y[m-1]. The highest digit y[m-1] must be non-zero.
+*
+* On exit n+1 digits of the quotient are stored in elements x[m],
+* x[m+1], ..., x[n+m], and m digits of the remainder are stored in
+* elements x[0], x[1], ..., x[m-1]. The array y is changed but then
+* restored.
+*
+* REFERENCES
+*
+* 1. D. Knuth. The Art of Computer Programming. Vol. 2: Seminumerical
+* Algorithms. Stanford University, 1969. */
+
+void bigdiv(int n, int m, unsigned short x[], unsigned short y[])
+{ int i, j;
+ unsigned int t;
+ unsigned short d, q, r;
+ xassert(n >= 0);
+ xassert(m >= 1);
+ xassert(y[m-1] != 0);
+ /* special case when divisor has the only digit */
+ if (m == 1)
+ { d = 0;
+ for (i = n; i >= 0; i--)
+ { t = ((unsigned int)d << 16) + (unsigned int)x[i];
+ x[i+1] = (unsigned short)(t / y[0]);
+ d = (unsigned short)(t % y[0]);
+ }
+ x[0] = d;
+ goto done;
+ }
+ /* multiply dividend and divisor by a normalizing coefficient in
+ * order to provide the condition y[m-1] >= base / 2 */
+ d = (unsigned short)(0x10000 / ((unsigned int)y[m-1] + 1));
+ if (d == 1)
+ x[n+m] = 0;
+ else
+ { t = 0;
+ for (i = 0; i < n+m; i++)
+ { t += (unsigned int)x[i] * (unsigned int)d;
+ x[i] = (unsigned short)t;
+ t >>= 16;
+ }
+ x[n+m] = (unsigned short)t;
+ t = 0;
+ for (j = 0; j < m; j++)
+ { t += (unsigned int)y[j] * (unsigned int)d;
+ y[j] = (unsigned short)t;
+ t >>= 16;
+ }
+ }
+ /* main loop */
+ for (i = n; i >= 0; i--)
+ { /* estimate and correct the current digit of quotient */
+ if (x[i+m] < y[m-1])
+ { t = ((unsigned int)x[i+m] << 16) + (unsigned int)x[i+m-1];
+ q = (unsigned short)(t / (unsigned int)y[m-1]);
+ r = (unsigned short)(t % (unsigned int)y[m-1]);
+ if (q == 0) goto putq; else goto test;
+ }
+ q = 0;
+ r = x[i+m-1];
+decr: q--; /* if q = 0 then q-- = 0xFFFF */
+ t = (unsigned int)r + (unsigned int)y[m-1];
+ r = (unsigned short)t;
+ if (t > 0xFFFF) goto msub;
+test: t = (unsigned int)y[m-2] * (unsigned int)q;
+ if ((unsigned short)(t >> 16) > r) goto decr;
+ if ((unsigned short)(t >> 16) < r) goto msub;
+ if ((unsigned short)t > x[i+m-2]) goto decr;
+msub: /* now subtract divisor multiplied by the current digit of
+ * quotient from the current dividend */
+ if (q == 0) goto putq;
+ t = 0;
+ for (j = 0; j < m; j++)
+ { t += (unsigned int)y[j] * (unsigned int)q;
+ if (x[i+j] < (unsigned short)t) t += 0x10000;
+ x[i+j] -= (unsigned short)t;
+ t >>= 16;
+ }
+ if (x[i+m] >= (unsigned short)t) goto putq;
+ /* perform correcting addition, because the current digit of
+ * quotient is greater by one than its correct value */
+ q--;
+ t = 0;
+ for (j = 0; j < m; j++)
+ { t += (unsigned int)x[i+j] + (unsigned int)y[j];
+ x[i+j] = (unsigned short)t;
+ t >>= 16;
+ }
+putq: /* store the current digit of quotient */
+ x[i+m] = q;
+ }
+ /* divide divisor and remainder by the normalizing coefficient in
+ * order to restore their original values */
+ if (d > 1)
+ { t = 0;
+ for (i = m-1; i >= 0; i--)
+ { t = (t << 16) + (unsigned int)x[i];
+ x[i] = (unsigned short)(t / (unsigned int)d);
+ t %= (unsigned int)d;
+ }
+ t = 0;
+ for (j = m-1; j >= 0; j--)
+ { t = (t << 16) + (unsigned int)y[j];
+ y[j] = (unsigned short)(t / (unsigned int)d);
+ t %= (unsigned int)d;
+ }
+ }
+done: return;
+}
+
+/**********************************************************************/
+
+#ifdef GLP_TEST
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "rng.h"
+
+#define N_MAX 7
+/* maximal number of digits in multiplicand */
+
+#define M_MAX 5
+/* maximal number of digits in multiplier */
+
+#define N_TEST 1000000
+/* number of tests */
+
+int main(void)
+{ RNG *rand;
+ int d, j, n, m, test;
+ unsigned short x[N_MAX], y[M_MAX], z[N_MAX+M_MAX];
+ rand = rng_create_rand();
+ for (test = 1; test <= N_TEST; test++)
+ { /* x[0,...,n-1] := multiplicand */
+ n = 1 + rng_unif_rand(rand, N_MAX-1);
+ assert(1 <= n && n <= N_MAX);
+ for (j = 0; j < n; j++)
+ { d = rng_unif_rand(rand, 65536);
+ assert(0 <= d && d <= 65535);
+ x[j] = (unsigned short)d;
+ }
+ /* y[0,...,m-1] := multiplier */
+ m = 1 + rng_unif_rand(rand, M_MAX-1);
+ assert(1 <= m && m <= M_MAX);
+ for (j = 0; j < m; j++)
+ { d = rng_unif_rand(rand, 65536);
+ assert(0 <= d && d <= 65535);
+ y[j] = (unsigned short)d;
+ }
+ if (y[m-1] == 0) y[m-1] = 1;
+ /* z[0,...,n+m-1] := x * y */
+ for (j = 0; j < n; j++) z[m+j] = x[j];
+ bigmul(n, m, z, y);
+ /* z[0,...,m-1] := z mod y, z[m,...,n+m-1] := z div y */
+ bigdiv(n, m, z, y);
+ /* z mod y must be 0 */
+ for (j = 0; j < m; j++) assert(z[j] == 0);
+ /* z div y must be x */
+ for (j = 0; j < n; j++) assert(z[m+j] == x[j]);
+ }
+ fprintf(stderr, "%d tests successfully passed\n", N_TEST);
+ rng_delete_rand(rand);
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/bignum.h b/test/monniaux/glpk-4.65/src/misc/bignum.h
new file mode 100644
index 00000000..8567519b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/bignum.h
@@ -0,0 +1,37 @@
+/* bignum.h (bignum arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2006-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef BIGNUM_H
+#define BIGNUM_H
+
+#define bigmul _glp_bigmul
+void bigmul(int n, int m, unsigned short x[], unsigned short y[]);
+/* multiply unsigned integer numbers of arbitrary precision */
+
+#define bigdiv _glp_bigdiv
+void bigdiv(int n, int m, unsigned short x[], unsigned short y[]);
+/* divide unsigned integer numbers of arbitrary precision */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/dimacs.c b/test/monniaux/glpk-4.65/src/misc/dimacs.c
new file mode 100644
index 00000000..6aa630a5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/dimacs.c
@@ -0,0 +1,147 @@
+/* dimacs.c (reading data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "dimacs.h"
+
+void dmx_error(DMX *csa, const char *fmt, ...)
+{ /* print error message and terminate processing */
+ va_list arg;
+ xprintf("%s:%d: error: ", csa->fname, csa->count);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ xprintf("\n");
+ longjmp(csa->jump, 1);
+ /* no return */
+}
+
+void dmx_warning(DMX *csa, const char *fmt, ...)
+{ /* print warning message and continue processing */
+ va_list arg;
+ xprintf("%s:%d: warning: ", csa->fname, csa->count);
+ va_start(arg, fmt);
+ xvprintf(fmt, arg);
+ va_end(arg);
+ xprintf("\n");
+ return;
+}
+
+void dmx_read_char(DMX *csa)
+{ /* read character from input text file */
+ int c;
+ if (csa->c == '\n') csa->count++;
+ c = glp_getc(csa->fp);
+ if (c < 0)
+ { if (glp_ioerr(csa->fp))
+ dmx_error(csa, "read error - %s", get_err_msg());
+ else if (csa->c == '\n')
+ dmx_error(csa, "unexpected end of file");
+ else
+ { dmx_warning(csa, "missing final end of line");
+ c = '\n';
+ }
+ }
+ else if (c == '\n')
+ ;
+ else if (isspace(c))
+ c = ' ';
+ else if (iscntrl(c))
+ dmx_error(csa, "invalid control character 0x%02X", c);
+ csa->c = c;
+ return;
+}
+
+void dmx_read_designator(DMX *csa)
+{ /* read one-character line designator */
+ xassert(csa->c == '\n');
+ dmx_read_char(csa);
+ for (;;)
+ { /* skip preceding white-space characters */
+ while (csa->c == ' ')
+ dmx_read_char(csa);
+ if (csa->c == '\n')
+ { /* ignore empty line */
+ if (!csa->empty)
+ { dmx_warning(csa, "empty line ignored");
+ csa->empty = 1;
+ }
+ dmx_read_char(csa);
+ }
+ else if (csa->c == 'c')
+ { /* skip comment line */
+ while (csa->c != '\n')
+ dmx_read_char(csa);
+ dmx_read_char(csa);
+ }
+ else
+ { /* hmm... looks like a line designator */
+ csa->field[0] = (char)csa->c, csa->field[1] = '\0';
+ /* check that it is followed by a white-space character */
+ dmx_read_char(csa);
+ if (!(csa->c == ' ' || csa->c == '\n'))
+ dmx_error(csa, "line designator missing or invalid");
+ break;
+ }
+ }
+ return;
+}
+
+void dmx_read_field(DMX *csa)
+{ /* read data field */
+ int len = 0;
+ /* skip preceding white-space characters */
+ while (csa->c == ' ')
+ dmx_read_char(csa);
+ /* scan data field */
+ if (csa->c == '\n')
+ dmx_error(csa, "unexpected end of line");
+ while (!(csa->c == ' ' || csa->c == '\n'))
+ { if (len == sizeof(csa->field)-1)
+ dmx_error(csa, "data field '%.15s...' too long",
+ csa->field);
+ csa->field[len++] = (char)csa->c;
+ dmx_read_char(csa);
+ }
+ csa->field[len] = '\0';
+ return;
+}
+
+void dmx_end_of_line(DMX *csa)
+{ /* skip white-space characters until end of line */
+ while (csa->c == ' ')
+ dmx_read_char(csa);
+ if (csa->c != '\n')
+ dmx_error(csa, "too many data fields specified");
+ return;
+}
+
+void dmx_check_int(DMX *csa, double num)
+{ /* print a warning if non-integer data are detected */
+ if (!csa->nonint && num != floor(num))
+ { dmx_warning(csa, "non-integer data detected");
+ csa->nonint = 1;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/dimacs.h b/test/monniaux/glpk-4.65/src/misc/dimacs.h
new file mode 100644
index 00000000..42fb9996
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/dimacs.h
@@ -0,0 +1,81 @@
+/* dimacs.h (reading data in DIMACS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef DIMACS_H
+#define DIMACS_H
+
+#include "env.h"
+
+typedef struct DMX DMX;
+
+struct DMX
+{ /* DIMACS data reader */
+ jmp_buf jump;
+ /* label for go to in case of error */
+ const char *fname;
+ /* name of input text file */
+ glp_file *fp;
+ /* stream assigned to input text file */
+ int count;
+ /* line count */
+ int c;
+ /* current character */
+ char field[255+1];
+ /* data field */
+ int empty;
+ /* warning 'empty line ignored' was printed */
+ int nonint;
+ /* warning 'non-integer data detected' was printed */
+};
+
+#define dmx_error _glp_dmx_error
+void dmx_error(DMX *csa, const char *fmt, ...);
+/* print error message and terminate processing */
+
+#define dmx_warning _glp_dmx_warning
+void dmx_warning(DMX *csa, const char *fmt, ...);
+/* print warning message and continue processing */
+
+#define dmx_read_char _glp_dmx_read_char
+void dmx_read_char(DMX *csa);
+/* read character from input text file */
+
+#define dmx_read_designator _glp_dmx_read_designator
+void dmx_read_designator(DMX *csa);
+/* read one-character line designator */
+
+#define dmx_read_field _glp_dmx_read_field
+void dmx_read_field(DMX *csa);
+/* read data field */
+
+#define dmx_end_of_line _glp_dmx_end_of_line
+void dmx_end_of_line(DMX *csa);
+/* skip white-space characters until end of line */
+
+#define dmx_check_int _glp_dmx_check_int
+void dmx_check_int(DMX *csa, double num);
+/* print a warning if non-integer data are detected */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/dmp.c b/test/monniaux/glpk-4.65/src/misc/dmp.c
new file mode 100644
index 00000000..a4882c86
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/dmp.c
@@ -0,0 +1,243 @@
+/* dmp.c (dynamic memory pool) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "dmp.h"
+
+struct DMP
+{ /* dynamic memory pool */
+ void *avail[32];
+ /* avail[k], 0 <= k <= 31, is a pointer to first available (free)
+ * atom of (k+1)*8 bytes long; at the beginning of each free atom
+ * there is a pointer to another free atom of the same size */
+ void *block;
+ /* pointer to most recently allocated memory block; at the
+ * beginning of each allocated memory block there is a pointer to
+ * previously allocated memory block */
+ int used;
+ /* number of bytes used in most recently allocated memory block */
+ size_t count;
+ /* number of atoms which are currently in use */
+};
+
+#define DMP_BLK_SIZE 8000
+/* size of memory blocks, in bytes, allocated for memory pools */
+
+struct prefix
+{ /* atom prefix (for debugging only) */
+ DMP *pool;
+ /* dynamic memory pool */
+ int size;
+ /* original atom size, in bytes */
+};
+
+#define prefix_size ((sizeof(struct prefix) + 7) & ~7)
+/* size of atom prefix rounded up to multiple of 8 bytes */
+
+int dmp_debug;
+/* debug mode flag */
+
+/***********************************************************************
+* NAME
+*
+* dmp_create_pool - create dynamic memory pool
+*
+* SYNOPSIS
+*
+* #include "dmp.h"
+* DMP *dmp_create_pool(void);
+*
+* DESCRIPTION
+*
+* The routine dmp_create_pool creates a dynamic memory pool.
+*
+* RETURNS
+*
+* The routine returns a pointer to the memory pool created. */
+
+DMP *dmp_create_pool(void)
+{ DMP *pool;
+ int k;
+ xassert(sizeof(void *) <= 8);
+ if (dmp_debug)
+ xprintf("dmp_create_pool: warning: debug mode is on\n");
+ pool = talloc(1, DMP);
+ for (k = 0; k <= 31; k++)
+ pool->avail[k] = NULL;
+ pool->block = NULL;
+ pool->used = DMP_BLK_SIZE;
+ pool->count = 0;
+ return pool;
+}
+
+/***********************************************************************
+* NAME
+*
+* dmp_get_atom - get free atom from dynamic memory pool
+*
+* SYNOPSIS
+*
+* #include "dmp.h"
+* void *dmp_get_atom(DMP *pool, int size);
+*
+* DESCRIPTION
+*
+* The routine dmp_get_atom obtains a free atom (memory space) from the
+* specified memory pool.
+*
+* The parameter size is the atom size, in bytes, 1 <= size <= 256.
+*
+* Note that the free atom contains arbitrary data, not binary zeros.
+*
+* RETURNS
+*
+* The routine returns a pointer to the free atom obtained. */
+
+void *dmp_get_atom(DMP *pool, int size)
+{ void *atom;
+ int k, need;
+ xassert(1 <= size && size <= 256);
+ /* round up atom size to multiple of 8 bytes */
+ need = (size + 7) & ~7;
+ /* determine number of corresponding list of free atoms */
+ k = (need >> 3) - 1;
+ /* obtain free atom */
+ if (pool->avail[k] == NULL)
+ { /* corresponding list of free atoms is empty */
+ /* if debug mode is on, add atom prefix size */
+ if (dmp_debug)
+ need += prefix_size;
+ if (pool->used + need > DMP_BLK_SIZE)
+ { /* allocate new memory block */
+ void *block = talloc(DMP_BLK_SIZE, char);
+ *(void **)block = pool->block;
+ pool->block = block;
+ pool->used = 8; /* sufficient to store pointer */
+ }
+ /* allocate new atom in current memory block */
+ atom = (char *)pool->block + pool->used;
+ pool->used += need;
+ }
+ else
+ { /* obtain atom from corresponding list of free atoms */
+ atom = pool->avail[k];
+ pool->avail[k] = *(void **)atom;
+ }
+ /* if debug mode is on, fill atom prefix */
+ if (dmp_debug)
+ { ((struct prefix *)atom)->pool = pool;
+ ((struct prefix *)atom)->size = size;
+ atom = (char *)atom + prefix_size;
+ }
+ /* increase number of allocated atoms */
+ pool->count++;
+ return atom;
+}
+
+/***********************************************************************
+* NAME
+*
+* dmp_free_atom - return atom to dynamic memory pool
+*
+* SYNOPSIS
+*
+* #include "dmp.h"
+* void dmp_free_atom(DMP *pool, void *atom, int size);
+*
+* DESCRIPTION
+*
+* The routine dmp_free_atom returns the specified atom (memory space)
+* to the specified memory pool, making the atom free.
+*
+* The parameter size is the atom size, in bytes, 1 <= size <= 256.
+*
+* Note that the atom can be returned only to the pool, from which it
+* was obtained, and its size must be exactly the same as on obtaining
+* it from the pool. */
+
+void dmp_free_atom(DMP *pool, void *atom, int size)
+{ int k;
+ xassert(1 <= size && size <= 256);
+ /* determine number of corresponding list of free atoms */
+ k = ((size + 7) >> 3) - 1;
+ /* if debug mode is on, check atom prefix */
+ if (dmp_debug)
+ { atom = (char *)atom - prefix_size;
+ xassert(((struct prefix *)atom)->pool == pool);
+ xassert(((struct prefix *)atom)->size == size);
+ }
+ /* return atom to corresponding list of free atoms */
+ *(void **)atom = pool->avail[k];
+ pool->avail[k] = atom;
+ /* decrease number of allocated atoms */
+ xassert(pool->count > 0);
+ pool->count--;
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* dmp_in_use - determine how many atoms are still in use
+*
+* SYNOPSIS
+*
+* #include "dmp.h"
+* size_t dmp_in_use(DMP *pool);
+*
+* RETURNS
+*
+* The routine returns the number of atoms of the specified memory pool
+* which are still in use. */
+
+size_t dmp_in_use(DMP *pool)
+{ return
+ pool->count;
+}
+
+/***********************************************************************
+* NAME
+*
+* dmp_delete_pool - delete dynamic memory pool
+*
+* SYNOPSIS
+*
+* #include "dmp.h"
+* void dmp_delete_pool(DMP *pool);
+*
+* DESCRIPTION
+*
+* The routine dmp_delete_pool deletes the specified dynamic memory
+* pool freeing all the memory allocated to this object. */
+
+void dmp_delete_pool(DMP *pool)
+{ while (pool->block != NULL)
+ { void *block = pool->block;
+ pool->block = *(void **)block;
+ tfree(block);
+ }
+ tfree(pool);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/dmp.h b/test/monniaux/glpk-4.65/src/misc/dmp.h
new file mode 100644
index 00000000..85fe7176
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/dmp.h
@@ -0,0 +1,63 @@
+/* dmp.h (dynamic memory pool) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef DMP_H
+#define DMP_H
+
+#include "stdc.h"
+
+typedef struct DMP DMP;
+
+#define dmp_debug _glp_dmp_debug
+extern int dmp_debug;
+/* debug mode flag */
+
+#define dmp_create_pool _glp_dmp_create_pool
+DMP *dmp_create_pool(void);
+/* create dynamic memory pool */
+
+#define dmp_talloc(pool, type) \
+ ((type *)dmp_get_atom(pool, sizeof(type)))
+
+#define dmp_get_atom _glp_dmp_get_atom
+void *dmp_get_atom(DMP *pool, int size);
+/* get free atom from dynamic memory pool */
+
+#define dmp_tfree(pool, atom) \
+ dmp_free_atom(pool, atom, sizeof(*(atom)))
+
+#define dmp_free_atom _glp_dmp_free_atom
+void dmp_free_atom(DMP *pool, void *atom, int size);
+/* return atom to dynamic memory pool */
+
+#define dmp_in_use _glp_dmp_in_use
+size_t dmp_in_use(DMP *pool);
+/* determine how many atoms are still in use */
+
+#define dmp_delete_pool _glp_dmp_delete_pool
+void dmp_delete_pool(DMP *pool);
+/* delete dynamic memory pool */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/ffalg.c b/test/monniaux/glpk-4.65/src/misc/ffalg.c
new file mode 100644
index 00000000..4ea2913d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/ffalg.c
@@ -0,0 +1,221 @@
+/* ffalg.c (Ford-Fulkerson algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ffalg.h"
+
+/***********************************************************************
+* NAME
+*
+* ffalg - Ford-Fulkerson algorithm
+*
+* SYNOPSIS
+*
+* #include "ffalg.h"
+* void ffalg(int nv, int na, const int tail[], const int head[],
+* int s, int t, const int cap[], int x[], char cut[]);
+*
+* DESCRIPTION
+*
+* The routine ffalg implements the Ford-Fulkerson algorithm to find a
+* maximal flow in the specified flow network.
+*
+* INPUT PARAMETERS
+*
+* nv is the number of nodes, nv >= 2.
+*
+* na is the number of arcs, na >= 0.
+*
+* tail[a], a = 1,...,na, is the index of tail node of arc a.
+*
+* head[a], a = 1,...,na, is the index of head node of arc a.
+*
+* s is the source node index, 1 <= s <= nv.
+*
+* t is the sink node index, 1 <= t <= nv, t != s.
+*
+* cap[a], a = 1,...,na, is the capacity of arc a, cap[a] >= 0.
+*
+* NOTE: Multiple arcs are allowed, but self-loops are not allowed.
+*
+* OUTPUT PARAMETERS
+*
+* x[a], a = 1,...,na, is optimal value of the flow through arc a.
+*
+* cut[i], i = 1,...,nv, is 1 if node i is labelled, and 0 otherwise.
+* The set of arcs, whose one endpoint is labelled and other is not,
+* defines the minimal cut corresponding to the maximal flow found.
+* If the parameter cut is NULL, the cut information are not stored.
+*
+* REFERENCES
+*
+* L.R.Ford, Jr., and D.R.Fulkerson, "Flows in Networks," The RAND
+* Corp., Report R-375-PR (August 1962), Chap. I "Static Maximal Flow,"
+* pp.30-33. */
+
+void ffalg(int nv, int na, const int tail[], const int head[],
+ int s, int t, const int cap[], int x[], char cut[])
+{ int a, delta, i, j, k, pos1, pos2, temp,
+ *ptr, *arc, *link, *list;
+ /* sanity checks */
+ xassert(nv >= 2);
+ xassert(na >= 0);
+ xassert(1 <= s && s <= nv);
+ xassert(1 <= t && t <= nv);
+ xassert(s != t);
+ for (a = 1; a <= na; a++)
+ { i = tail[a], j = head[a];
+ xassert(1 <= i && i <= nv);
+ xassert(1 <= j && j <= nv);
+ xassert(i != j);
+ xassert(cap[a] >= 0);
+ }
+ /* allocate working arrays */
+ ptr = xcalloc(1+nv+1, sizeof(int));
+ arc = xcalloc(1+na+na, sizeof(int));
+ link = xcalloc(1+nv, sizeof(int));
+ list = xcalloc(1+nv, sizeof(int));
+ /* ptr[i] := (degree of node i) */
+ for (i = 1; i <= nv; i++)
+ ptr[i] = 0;
+ for (a = 1; a <= na; a++)
+ { ptr[tail[a]]++;
+ ptr[head[a]]++;
+ }
+ /* initialize arc pointers */
+ ptr[1]++;
+ for (i = 1; i < nv; i++)
+ ptr[i+1] += ptr[i];
+ ptr[nv+1] = ptr[nv];
+ /* build arc lists */
+ for (a = 1; a <= na; a++)
+ { arc[--ptr[tail[a]]] = a;
+ arc[--ptr[head[a]]] = a;
+ }
+ xassert(ptr[1] == 1);
+ xassert(ptr[nv+1] == na+na+1);
+ /* now the indices of arcs incident to node i are stored in
+ * locations arc[ptr[i]], arc[ptr[i]+1], ..., arc[ptr[i+1]-1] */
+ /* initialize arc flows */
+ for (a = 1; a <= na; a++)
+ x[a] = 0;
+loop: /* main loop starts here */
+ /* build augmenting tree rooted at s */
+ /* link[i] = 0 means that node i is not labelled yet;
+ * link[i] = a means that arc a immediately precedes node i */
+ /* initially node s is labelled as the root */
+ for (i = 1; i <= nv; i++)
+ link[i] = 0;
+ link[s] = -1, list[1] = s, pos1 = pos2 = 1;
+ /* breadth first search */
+ while (pos1 <= pos2)
+ { /* dequeue node i */
+ i = list[pos1++];
+ /* consider all arcs incident to node i */
+ for (k = ptr[i]; k < ptr[i+1]; k++)
+ { a = arc[k];
+ if (tail[a] == i)
+ { /* a = i->j is a forward arc from s to t */
+ j = head[a];
+ /* if node j has been labelled, skip the arc */
+ if (link[j] != 0) continue;
+ /* if the arc does not allow increasing the flow through
+ * it, skip the arc */
+ if (x[a] == cap[a]) continue;
+ }
+ else if (head[a] == i)
+ { /* a = i<-j is a backward arc from s to t */
+ j = tail[a];
+ /* if node j has been labelled, skip the arc */
+ if (link[j] != 0) continue;
+ /* if the arc does not allow decreasing the flow through
+ * it, skip the arc */
+ if (x[a] == 0) continue;
+ }
+ else
+ xassert(a != a);
+ /* label node j and enqueue it */
+ link[j] = a, list[++pos2] = j;
+ /* check for breakthrough */
+ if (j == t) goto brkt;
+ }
+ }
+ /* NONBREAKTHROUGH */
+ /* no augmenting path exists; current flow is maximal */
+ /* store minimal cut information, if necessary */
+ if (cut != NULL)
+ { for (i = 1; i <= nv; i++)
+ cut[i] = (char)(link[i] != 0);
+ }
+ goto done;
+brkt: /* BREAKTHROUGH */
+ /* walk through arcs of the augmenting path (s, ..., t) found in
+ * the reverse order and determine maximal change of the flow */
+ delta = 0;
+ for (j = t; j != s; j = i)
+ { /* arc a immediately precedes node j in the path */
+ a = link[j];
+ if (head[a] == j)
+ { /* a = i->j is a forward arc of the cycle */
+ i = tail[a];
+ /* x[a] may be increased until its upper bound */
+ temp = cap[a] - x[a];
+ }
+ else if (tail[a] == j)
+ { /* a = i<-j is a backward arc of the cycle */
+ i = head[a];
+ /* x[a] may be decreased until its lower bound */
+ temp = x[a];
+ }
+ else
+ xassert(a != a);
+ if (delta == 0 || delta > temp) delta = temp;
+ }
+ xassert(delta > 0);
+ /* increase the flow along the path */
+ for (j = t; j != s; j = i)
+ { /* arc a immediately precedes node j in the path */
+ a = link[j];
+ if (head[a] == j)
+ { /* a = i->j is a forward arc of the cycle */
+ i = tail[a];
+ x[a] += delta;
+ }
+ else if (tail[a] == j)
+ { /* a = i<-j is a backward arc of the cycle */
+ i = head[a];
+ x[a] -= delta;
+ }
+ else
+ xassert(a != a);
+ }
+ goto loop;
+done: /* free working arrays */
+ xfree(ptr);
+ xfree(arc);
+ xfree(link);
+ xfree(list);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/ffalg.h b/test/monniaux/glpk-4.65/src/misc/ffalg.h
new file mode 100644
index 00000000..7016f8fa
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/ffalg.h
@@ -0,0 +1,34 @@
+/* ffalg.h (Ford-Fulkerson algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef FFALG_H
+#define FFALG_H
+
+#define ffalg _glp_ffalg
+void ffalg(int nv, int na, const int tail[], const int head[],
+ int s, int t, const int cap[], int x[], char cut[]);
+/* Ford-Fulkerson algorithm */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/fp2rat.c b/test/monniaux/glpk-4.65/src/misc/fp2rat.c
new file mode 100644
index 00000000..4699bbd1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/fp2rat.c
@@ -0,0 +1,164 @@
+/* fp2rat.c (convert floating-point number to rational number) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+
+/***********************************************************************
+* NAME
+*
+* fp2rat - convert floating-point number to rational number
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* int fp2rat(double x, double eps, double *p, double *q);
+*
+* DESCRIPTION
+*
+* Given a floating-point number 0 <= x < 1 the routine fp2rat finds
+* its "best" rational approximation p / q, where p >= 0 and q > 0 are
+* integer numbers, such that |x - p / q| <= eps.
+*
+* RETURNS
+*
+* The routine fp2rat returns the number of iterations used to achieve
+* the specified precision eps.
+*
+* EXAMPLES
+*
+* For x = sqrt(2) - 1 = 0.414213562373095 and eps = 1e-6 the routine
+* gives p = 408 and q = 985, where 408 / 985 = 0.414213197969543.
+*
+* BACKGROUND
+*
+* It is well known that every positive real number x can be expressed
+* as the following continued fraction:
+*
+* x = b[0] + a[1]
+* ------------------------
+* b[1] + a[2]
+* -----------------
+* b[2] + a[3]
+* ----------
+* b[3] + ...
+*
+* where:
+*
+* a[k] = 1, k = 0, 1, 2, ...
+*
+* b[k] = floor(x[k]), k = 0, 1, 2, ...
+*
+* x[0] = x,
+*
+* x[k] = 1 / frac(x[k-1]), k = 1, 2, 3, ...
+*
+* To find the "best" rational approximation of x the routine computes
+* partial fractions f[k] by dropping after k terms as follows:
+*
+* f[k] = A[k] / B[k],
+*
+* where:
+*
+* A[-1] = 1, A[0] = b[0], B[-1] = 0, B[0] = 1,
+*
+* A[k] = b[k] * A[k-1] + a[k] * A[k-2],
+*
+* B[k] = b[k] * B[k-1] + a[k] * B[k-2].
+*
+* Once the condition
+*
+* |x - f[k]| <= eps
+*
+* has been satisfied, the routine reports p = A[k] and q = B[k] as the
+* final answer.
+*
+* In the table below here is some statistics obtained for one million
+* random numbers uniformly distributed in the range [0, 1).
+*
+* eps max p mean p max q mean q max k mean k
+* -------------------------------------------------------------
+* 1e-1 8 1.6 9 3.2 3 1.4
+* 1e-2 98 6.2 99 12.4 5 2.4
+* 1e-3 997 20.7 998 41.5 8 3.4
+* 1e-4 9959 66.6 9960 133.5 10 4.4
+* 1e-5 97403 211.7 97404 424.2 13 5.3
+* 1e-6 479669 669.9 479670 1342.9 15 6.3
+* 1e-7 1579030 2127.3 3962146 4257.8 16 7.3
+* 1e-8 26188823 6749.4 26188824 13503.4 19 8.2
+*
+* REFERENCES
+*
+* W. B. Jones and W. J. Thron, "Continued Fractions: Analytic Theory
+* and Applications," Encyclopedia on Mathematics and Its Applications,
+* Addison-Wesley, 1980. */
+
+int fp2rat(double x, double eps, double *p, double *q)
+{ int k;
+ double xk, Akm1, Ak, Bkm1, Bk, ak, bk, fk, temp;
+ xassert(0.0 <= x && x < 1.0);
+ for (k = 0; ; k++)
+ { xassert(k <= 100);
+ if (k == 0)
+ { /* x[0] = x */
+ xk = x;
+ /* A[-1] = 1 */
+ Akm1 = 1.0;
+ /* A[0] = b[0] = floor(x[0]) = 0 */
+ Ak = 0.0;
+ /* B[-1] = 0 */
+ Bkm1 = 0.0;
+ /* B[0] = 1 */
+ Bk = 1.0;
+ }
+ else
+ { /* x[k] = 1 / frac(x[k-1]) */
+ temp = xk - floor(xk);
+ xassert(temp != 0.0);
+ xk = 1.0 / temp;
+ /* a[k] = 1 */
+ ak = 1.0;
+ /* b[k] = floor(x[k]) */
+ bk = floor(xk);
+ /* A[k] = b[k] * A[k-1] + a[k] * A[k-2] */
+ temp = bk * Ak + ak * Akm1;
+ Akm1 = Ak, Ak = temp;
+ /* B[k] = b[k] * B[k-1] + a[k] * B[k-2] */
+ temp = bk * Bk + ak * Bkm1;
+ Bkm1 = Bk, Bk = temp;
+ }
+ /* f[k] = A[k] / B[k] */
+ fk = Ak / Bk;
+#if 0
+ print("%.*g / %.*g = %.*g",
+ DBL_DIG, Ak, DBL_DIG, Bk, DBL_DIG, fk);
+#endif
+ if (fabs(x - fk) <= eps)
+ break;
+ }
+ *p = Ak;
+ *q = Bk;
+ return k;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/fvs.c b/test/monniaux/glpk-4.65/src/misc/fvs.c
new file mode 100644
index 00000000..916a1bf9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/fvs.c
@@ -0,0 +1,137 @@
+/* fvs.c (sparse vector in FVS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "fvs.h"
+
+void fvs_alloc_vec(FVS *x, int n)
+{ /* allocate sparse vector */
+ int j;
+ xassert(n >= 0);
+ x->n = n;
+ x->nnz = 0;
+ x->ind = talloc(1+n, int);
+ x->vec = talloc(1+n, double);
+ for (j = 1; j <= n; j++)
+ x->vec[j] = 0.0;
+ return;
+}
+
+void fvs_check_vec(const FVS *x)
+{ /* check sparse vector */
+ /* NOTE: for testing/debugging only */
+ int n = x->n;
+ int nnz = x->nnz;
+ int *ind = x->ind;
+ double *vec = x->vec;
+ char *map;
+ int j, k;
+ xassert(n >= 0);
+ xassert(0 <= nnz && nnz <= n);
+ map = talloc(1+n, char);
+ for (j = 1; j <= n; j++)
+ map[j] = (vec[j] != 0.0);
+ for (k = 1; k <= nnz; k++)
+ { j = ind[k];
+ xassert(1 <= j && j <= n);
+ xassert(map[j]);
+ map[j] = 0;
+ }
+ for (j = 1; j <= n; j++)
+ xassert(!map[j]);
+ tfree(map);
+ return;
+}
+
+void fvs_gather_vec(FVS *x, double eps)
+{ /* gather sparse vector */
+ int n = x->n;
+ int *ind = x->ind;
+ double *vec = x->vec;
+ int j, nnz = 0;
+ for (j = n; j >= 1; j--)
+ { if (-eps < vec[j] && vec[j] < +eps)
+ vec[j] = 0.0;
+ else
+ ind[++nnz] = j;
+ }
+ x->nnz = nnz;
+ return;
+}
+
+void fvs_clear_vec(FVS *x)
+{ /* clear sparse vector */
+ int *ind = x->ind;
+ double *vec = x->vec;
+ int k;
+ for (k = x->nnz; k >= 1; k--)
+ vec[ind[k]] = 0.0;
+ x->nnz = 0;
+ return;
+}
+
+void fvs_copy_vec(FVS *x, const FVS *y)
+{ /* copy sparse vector */
+ int *x_ind = x->ind;
+ double *x_vec = x->vec;
+ int *y_ind = y->ind;
+ double *y_vec = y->vec;
+ int j, k;
+ xassert(x != y);
+ xassert(x->n == y->n);
+ fvs_clear_vec(x);
+ for (k = x->nnz = y->nnz; k >= 1; k--)
+ { j = x_ind[k] = y_ind[k];
+ x_vec[j] = y_vec[j];
+ }
+ return;
+}
+
+void fvs_adjust_vec(FVS *x, double eps)
+{ /* replace tiny vector elements by exact zeros */
+ int nnz = x->nnz;
+ int *ind = x->ind;
+ double *vec = x->vec;
+ int j, k, cnt = 0;
+ for (k = 1; k <= nnz; k++)
+ { j = ind[k];
+ if (-eps < vec[j] && vec[j] < +eps)
+ vec[j] = 0.0;
+ else
+ ind[++cnt] = j;
+ }
+ x->nnz = cnt;
+ return;
+}
+
+void fvs_free_vec(FVS *x)
+{ /* deallocate sparse vector */
+ tfree(x->ind);
+ tfree(x->vec);
+ x->n = x->nnz = -1;
+ x->ind = NULL;
+ x->vec = NULL;
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/fvs.h b/test/monniaux/glpk-4.65/src/misc/fvs.h
new file mode 100644
index 00000000..abfed8cc
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/fvs.h
@@ -0,0 +1,76 @@
+/* fvs.h (sparse vector in FVS format) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef FVS_H
+#define FVS_H
+
+typedef struct FVS FVS;
+
+struct FVS
+{ /* sparse vector in FVS (Full Vector Storage) format */
+ int n;
+ /* vector dimension (total number of elements) */
+ int nnz;
+ /* number of non-zero elements, 0 <= nnz <= n */
+ int *ind; /* int ind[1+n]; */
+ /* ind[0] is not used;
+ * ind[k] = j, 1 <= k <= nnz, means that vec[j] != 0
+ * non-zero indices in the array ind are stored in arbitrary
+ * order; if vec[j] = 0, its index j SHOULD NOT be presented in
+ * the array ind */
+ double *vec; /* double vec[1+n]; */
+ /* vec[0] is not used;
+ * vec[j], 1 <= j <= n, is a numeric value of j-th element */
+};
+
+#define fvs_alloc_vec _glp_fvs_alloc_vec
+void fvs_alloc_vec(FVS *x, int n);
+/* allocate sparse vector */
+
+#define fvs_check_vec _glp_fvs_check_vec
+void fvs_check_vec(const FVS *x);
+/* check sparse vector */
+
+#define fvs_gather_vec _glp_fvs_gather_vec
+void fvs_gather_vec(FVS *x, double eps);
+/* gather sparse vector */
+
+#define fvs_clear_vec _glp_fvs_clear_vec
+void fvs_clear_vec(FVS *x);
+/* clear sparse vector */
+
+#define fvs_copy_vec _glp_fvs_copy_vec
+void fvs_copy_vec(FVS *x, const FVS *y);
+/* copy sparse vector */
+
+#define fvs_adjust_vec _glp_fvs_adjust_vec
+void fvs_adjust_vec(FVS *x, double eps);
+/* replace tiny vector elements by exact zeros */
+
+#define fvs_free_vec _glp_fvs_free_vec
+void fvs_free_vec(FVS *x);
+/* deallocate sparse vector */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/gcd.c b/test/monniaux/glpk-4.65/src/misc/gcd.c
new file mode 100644
index 00000000..95c48cc0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/gcd.c
@@ -0,0 +1,102 @@
+/* gcd.c (greatest common divisor) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+
+/***********************************************************************
+* NAME
+*
+* gcd - find greatest common divisor of two integers
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* int gcd(int x, int y);
+*
+* RETURNS
+*
+* The routine gcd returns gcd(x, y), the greatest common divisor of
+* the two positive integers given.
+*
+* ALGORITHM
+*
+* The routine gcd is based on Euclid's algorithm.
+*
+* REFERENCES
+*
+* Don Knuth, The Art of Computer Programming, Vol.2: Seminumerical
+* Algorithms, 3rd Edition, Addison-Wesley, 1997. Section 4.5.2: The
+* Greatest Common Divisor, pp. 333-56. */
+
+int gcd(int x, int y)
+{ int r;
+ xassert(x > 0 && y > 0);
+ while (y > 0)
+ r = x % y, x = y, y = r;
+ return x;
+}
+
+/***********************************************************************
+* NAME
+*
+* gcdn - find greatest common divisor of n integers
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* int gcdn(int n, int x[]);
+*
+* RETURNS
+*
+* The routine gcdn returns gcd(x[1], x[2], ..., x[n]), the greatest
+* common divisor of n positive integers given, n > 0.
+*
+* BACKGROUND
+*
+* The routine gcdn is based on the following identity:
+*
+* gcd(x, y, z) = gcd(gcd(x, y), z).
+*
+* REFERENCES
+*
+* Don Knuth, The Art of Computer Programming, Vol.2: Seminumerical
+* Algorithms, 3rd Edition, Addison-Wesley, 1997. Section 4.5.2: The
+* Greatest Common Divisor, pp. 333-56. */
+
+int gcdn(int n, int x[])
+{ int d, j;
+ xassert(n > 0);
+ for (j = 1; j <= n; j++)
+ { xassert(x[j] > 0);
+ if (j == 1)
+ d = x[1];
+ else
+ d = gcd(d, x[j]);
+ if (d == 1)
+ break;
+ }
+ return d;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/jd.c b/test/monniaux/glpk-4.65/src/misc/jd.c
new file mode 100644
index 00000000..c9d63171
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/jd.c
@@ -0,0 +1,152 @@
+/* jd.c (conversions between calendar date and Julian day number) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include <stddef.h>
+#include "jd.h"
+
+/***********************************************************************
+* NAME
+*
+* jday - convert calendar date to Julian day number
+*
+* SYNOPSIS
+*
+* #include "jd.h"
+* int jday(int d, int m, int y);
+*
+* DESCRIPTION
+*
+* The routine jday converts a calendar date, Gregorian calendar, to
+* corresponding Julian day number j.
+*
+* From the given day d, month m, and year y, the Julian day number j
+* is computed without using tables.
+*
+* The routine is valid for 1 <= y <= 4000.
+*
+* RETURNS
+*
+* The routine jday returns the Julian day number, or negative value if
+* the specified date is incorrect.
+*
+* REFERENCES
+*
+* R. G. Tantzen, Algorithm 199: conversions between calendar date and
+* Julian day number, Communications of the ACM, vol. 6, no. 8, p. 444,
+* Aug. 1963. */
+
+int jday(int d, int m, int y)
+{ int c, ya, j, dd;
+ if (!(1 <= d && d <= 31 &&
+ 1 <= m && m <= 12 &&
+ 1 <= y && y <= 4000))
+ return -1;
+ if (m >= 3)
+ m -= 3;
+ else
+ m += 9, y--;
+ c = y / 100;
+ ya = y - 100 * c;
+ j = (146097 * c) / 4 + (1461 * ya) / 4 + (153 * m + 2) / 5 + d +
+ 1721119;
+ jdate(j, &dd, NULL, NULL);
+ if (d != dd)
+ return -1;
+ return j;
+}
+
+/***********************************************************************
+* NAME
+*
+* jdate - convert Julian day number to calendar date
+*
+* SYNOPSIS
+*
+* #include "jd.h"
+* int jdate(int j, int *d, int *m, int *y);
+*
+* DESCRIPTION
+*
+* The routine jdate converts a Julian day number j to corresponding
+* calendar date, Gregorian calendar.
+*
+* The day d, month m, and year y are computed without using tables and
+* stored in corresponding locations.
+*
+* The routine is valid for 1721426 <= j <= 3182395.
+*
+* RETURNS
+*
+* If the conversion is successful, the routine returns zero, otherwise
+* non-zero.
+*
+* REFERENCES
+*
+* R. G. Tantzen, Algorithm 199: conversions between calendar date and
+* Julian day number, Communications of the ACM, vol. 6, no. 8, p. 444,
+* Aug. 1963. */
+
+int jdate(int j, int *d_, int *m_, int *y_)
+{ int d, m, y;
+ if (!(1721426 <= j && j <= 3182395))
+ return 1;
+ j -= 1721119;
+ y = (4 * j - 1) / 146097;
+ j = (4 * j - 1) % 146097;
+ d = j / 4;
+ j = (4 * d + 3) / 1461;
+ d = (4 * d + 3) % 1461;
+ d = (d + 4) / 4;
+ m = (5 * d - 3) / 153;
+ d = (5 * d - 3) % 153;
+ d = (d + 5) / 5;
+ y = 100 * y + j;
+ if (m <= 9)
+ m += 3;
+ else m -= 9,
+ y++;
+ if (d_ != NULL) *d_ = d;
+ if (m_ != NULL) *m_ = m;
+ if (y_ != NULL) *y_ = y;
+ return 0;
+}
+
+#ifdef GLP_TEST
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+int main(void)
+{ int jbeg, jend, j, d, m, y;
+ jbeg = jday(1, 1, 1);
+ jend = jday(31, 12, 4000);
+ for (j = jbeg; j <= jend; j++)
+ { assert(jdate(j, &d, &m, &y) == 0);
+ assert(jday(d, m, y) == j);
+ }
+ printf("Routines jday and jdate work correctly.\n");
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/jd.h b/test/monniaux/glpk-4.65/src/misc/jd.h
new file mode 100644
index 00000000..009d2daa
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/jd.h
@@ -0,0 +1,32 @@
+/* jd.h (conversions between calendar date and Julian day number) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#define jday _glp_jday
+int jday(int d, int m, int y);
+/* convert calendar date to Julian day number */
+
+#define jdate _glp_jdate
+int jdate(int j, int *d, int *m, int *y);
+/* convert Julian day number to calendar date */
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/keller.c b/test/monniaux/glpk-4.65/src/misc/keller.c
new file mode 100644
index 00000000..d64d3c1e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/keller.c
@@ -0,0 +1,235 @@
+/* keller.c (cover edges by cliques, Kellerman's heuristic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "glpk.h"
+#include "env.h"
+#include "keller.h"
+
+/***********************************************************************
+* NAME
+*
+* kellerman - cover edges by cliques with Kellerman's heuristic
+*
+* SYNOPSIS
+*
+* #include "keller.h"
+* int kellerman(int n, int (*func)(void *info, int i, int ind[]),
+* void *info, glp_graph *H);
+*
+* DESCRIPTION
+*
+* The routine kellerman implements Kellerman's heuristic algorithm
+* to find a minimal set of cliques which cover all edges of specified
+* graph G = (V, E).
+*
+* The parameter n specifies the number of vertices |V|, n >= 0.
+*
+* Formal routine func specifies the set of edges E in the following
+* way. Running the routine kellerman calls the routine func and passes
+* to it parameter i, which is the number of some vertex, 1 <= i <= n.
+* In response the routine func should store numbers of all vertices
+* adjacent to vertex i to locations ind[1], ind[2], ..., ind[len] and
+* return the value of len, which is the number of adjacent vertices,
+* 0 <= len <= n. Self-loops are allowed, but ignored. Multiple edges
+* are not allowed.
+*
+* The parameter info is a transit pointer (magic cookie) passed to the
+* formal routine func as its first parameter.
+*
+* The result provided by the routine kellerman is the bipartite graph
+* H = (V union C, F), which defines the covering found. (The program
+* object of type glp_graph specified by the parameter H should be
+* previously created with the routine glp_create_graph. On entry the
+* routine kellerman erases the content of this object with the routine
+* glp_erase_graph.) Vertices of first part V correspond to vertices of
+* the graph G and have the same ordinal numbers 1, 2, ..., n. Vertices
+* of second part C correspond to cliques and have ordinal numbers
+* n+1, n+2, ..., n+k, where k is the total number of cliques in the
+* edge covering found. Every edge f in F in the program object H is
+* represented as arc f = (i->j), where i in V and j in C, which means
+* that vertex i of the graph G is in clique C[j], 1 <= j <= k. (Thus,
+* if two vertices of the graph G are in the same clique, these vertices
+* are adjacent in G, and corresponding edge is covered by that clique.)
+*
+* RETURNS
+*
+* The routine Kellerman returns k, the total number of cliques in the
+* edge covering found.
+*
+* REFERENCE
+*
+* For more details see: glpk/doc/notes/keller.pdf (in Russian). */
+
+struct set
+{ /* set of vertices */
+ int size;
+ /* size (cardinality) of the set, 0 <= card <= n */
+ int *list; /* int list[1+n]; */
+ /* the set contains vertices list[1,...,size] */
+ int *pos; /* int pos[1+n]; */
+ /* pos[i] > 0 means that vertex i is in the set and
+ * list[pos[i]] = i; pos[i] = 0 means that vertex i is not in
+ * the set */
+};
+
+int kellerman(int n, int (*func)(void *info, int i, int ind[]),
+ void *info, void /* glp_graph */ *H_)
+{ glp_graph *H = H_;
+ struct set W_, *W = &W_, V_, *V = &V_;
+ glp_arc *a;
+ int i, j, k, m, t, len, card, best;
+ xassert(n >= 0);
+ /* H := (V, 0; 0), where V is the set of vertices of graph G */
+ glp_erase_graph(H, H->v_size, H->a_size);
+ glp_add_vertices(H, n);
+ /* W := 0 */
+ W->size = 0;
+ W->list = xcalloc(1+n, sizeof(int));
+ W->pos = xcalloc(1+n, sizeof(int));
+ memset(&W->pos[1], 0, sizeof(int) * n);
+ /* V := 0 */
+ V->size = 0;
+ V->list = xcalloc(1+n, sizeof(int));
+ V->pos = xcalloc(1+n, sizeof(int));
+ memset(&V->pos[1], 0, sizeof(int) * n);
+ /* main loop */
+ for (i = 1; i <= n; i++)
+ { /* W must be empty */
+ xassert(W->size == 0);
+ /* W := { j : i > j and (i,j) in E } */
+ len = func(info, i, W->list);
+ xassert(0 <= len && len <= n);
+ for (t = 1; t <= len; t++)
+ { j = W->list[t];
+ xassert(1 <= j && j <= n);
+ if (j >= i) continue;
+ xassert(W->pos[j] == 0);
+ W->list[++W->size] = j, W->pos[j] = W->size;
+ }
+ /* on i-th iteration we need to cover edges (i,j) for all
+ * j in W */
+ /* if W is empty, it is a special case */
+ if (W->size == 0)
+ { /* set k := k + 1 and create new clique C[k] = { i } */
+ k = glp_add_vertices(H, 1) - n;
+ glp_add_arc(H, i, n + k);
+ continue;
+ }
+ /* try to include vertex i into existing cliques */
+ /* V must be empty */
+ xassert(V->size == 0);
+ /* k is the number of cliques found so far */
+ k = H->nv - n;
+ for (m = 1; m <= k; m++)
+ { /* do while V != W; since here V is within W, we can use
+ * equivalent condition: do while |V| < |W| */
+ if (V->size == W->size) break;
+ /* check if C[m] is within W */
+ for (a = H->v[n + m]->in; a != NULL; a = a->h_next)
+ { j = a->tail->i;
+ if (W->pos[j] == 0) break;
+ }
+ if (a != NULL) continue;
+ /* C[m] is within W, expand clique C[m] with vertex i */
+ /* C[m] := C[m] union {i} */
+ glp_add_arc(H, i, n + m);
+ /* V is a set of vertices whose incident edges are already
+ * covered by existing cliques */
+ /* V := V union C[m] */
+ for (a = H->v[n + m]->in; a != NULL; a = a->h_next)
+ { j = a->tail->i;
+ if (V->pos[j] == 0)
+ V->list[++V->size] = j, V->pos[j] = V->size;
+ }
+ }
+ /* remove from set W the vertices whose incident edges are
+ * already covered by existing cliques */
+ /* W := W \ V, V := 0 */
+ for (t = 1; t <= V->size; t++)
+ { j = V->list[t], V->pos[j] = 0;
+ if (W->pos[j] != 0)
+ { /* remove vertex j from W */
+ if (W->pos[j] != W->size)
+ { int jj = W->list[W->size];
+ W->list[W->pos[j]] = jj;
+ W->pos[jj] = W->pos[j];
+ }
+ W->size--, W->pos[j] = 0;
+ }
+ }
+ V->size = 0;
+ /* now set W contains only vertices whose incident edges are
+ * still not covered by existing cliques; create new cliques
+ * to cover remaining edges until set W becomes empty */
+ while (W->size > 0)
+ { /* find clique C[m], 1 <= m <= k, which shares maximal
+ * number of vertices with W; to break ties choose clique
+ * having smallest number m */
+ m = 0, best = -1;
+ k = H->nv - n;
+ for (t = 1; t <= k; t++)
+ { /* compute cardinality of intersection of W and C[t] */
+ card = 0;
+ for (a = H->v[n + t]->in; a != NULL; a = a->h_next)
+ { j = a->tail->i;
+ if (W->pos[j] != 0) card++;
+ }
+ if (best < card)
+ m = t, best = card;
+ }
+ xassert(m > 0);
+ /* set k := k + 1 and create new clique:
+ * C[k] := (W intersect C[m]) union { i }, which covers all
+ * edges incident to vertices from (W intersect C[m]) */
+ k = glp_add_vertices(H, 1) - n;
+ for (a = H->v[n + m]->in; a != NULL; a = a->h_next)
+ { j = a->tail->i;
+ if (W->pos[j] != 0)
+ { /* vertex j is in both W and C[m]; include it in new
+ * clique C[k] */
+ glp_add_arc(H, j, n + k);
+ /* remove vertex j from W, since edge (i,j) will be
+ * covered by new clique C[k] */
+ if (W->pos[j] != W->size)
+ { int jj = W->list[W->size];
+ W->list[W->pos[j]] = jj;
+ W->pos[jj] = W->pos[j];
+ }
+ W->size--, W->pos[j] = 0;
+ }
+ }
+ /* include vertex i to new clique C[k] to cover edges (i,j)
+ * incident to all vertices j just removed from W */
+ glp_add_arc(H, i, n + k);
+ }
+ }
+ /* free working arrays */
+ xfree(W->list);
+ xfree(W->pos);
+ xfree(V->list);
+ xfree(V->pos);
+ /* return the number of cliques in the edge covering found */
+ return H->nv - n;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/keller.h b/test/monniaux/glpk-4.65/src/misc/keller.h
new file mode 100644
index 00000000..d7a5b343
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/keller.h
@@ -0,0 +1,34 @@
+/* keller.h (cover edges by cliques, Kellerman's heuristic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef KELLER_H
+#define KELLER_H
+
+#define kellerman _glp_kellerman
+int kellerman(int n, int (*func)(void *info, int i, int ind[]),
+ void *info, void /* glp_graph */ *H);
+/* cover edges by cliques with Kellerman's heuristic */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/ks.c b/test/monniaux/glpk-4.65/src/misc/ks.c
new file mode 100644
index 00000000..0720cc90
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/ks.c
@@ -0,0 +1,466 @@
+/* ks.c (0-1 knapsack problem) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ks.h"
+#include "mt1.h"
+
+/***********************************************************************
+* 0-1 knapsack problem has the following formulation:
+*
+* maximize z = sum{j in 1..n} c[j]x[j] (1)
+*
+* s.t. sum{j in 1..n} a[j]x[j] <= b (2)
+*
+* x[j] in {0, 1} for all j in 1..n (3)
+*
+* In general case it is assumed that the instance is non-normalized,
+* i.e. parameters a, b, and c may have any sign.
+***********************************************************************/
+
+/***********************************************************************
+* ks_enum - solve 0-1 knapsack problem by complete enumeration
+*
+* This routine finds optimal solution to 0-1 knapsack problem (1)-(3)
+* by complete enumeration. It is intended mainly for testing purposes.
+*
+* The instance to be solved is specified by parameters n, a, b, and c.
+* Note that these parameters can have any sign, i.e. normalization is
+* not needed.
+*
+* On exit the routine stores the optimal point found in locations
+* x[1], ..., x[n] and returns the optimal objective value. However, if
+* the instance is infeasible, the routine returns INT_MIN.
+*
+* Since the complete enumeration is inefficient, this routine can be
+* used only for small instances (n <= 20-30). */
+
+#define N_MAX 40
+
+int ks_enum(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/])
+{ int j, s, z, z_best;
+ char x_best[1+N_MAX];
+ xassert(0 <= n && n <= N_MAX);
+ /* initialization */
+ memset(&x[1], 0, n * sizeof(char));
+ z_best = INT_MIN;
+loop: /* compute constraint and objective at current x */
+ s = z = 0;
+ for (j = 1; j <= n; j++)
+ { if (x[j])
+ s += a[j], z += c[j];
+ }
+ /* check constraint violation */
+ if (s > b)
+ goto next;
+ /* check objective function */
+ if (z_best < z)
+ { /* better solution has been found */
+ memcpy(&x_best[1], &x[1], n * sizeof(char));
+ z_best = z;
+ }
+next: /* generate next x */
+ for (j = 1; j <= n; j++)
+ { if (!x[j])
+ { x[j] = 1;
+ goto loop;
+ }
+ x[j] = 0;
+ }
+ /* report best (optimal) solution */
+ memcpy(&x[1], &x_best[1], n * sizeof(char));
+ return z_best;
+}
+
+/***********************************************************************
+* reduce - prepare reduced instance of 0-1 knapsack
+*
+* Given original instance of 0-1 knapsack (1)-(3) specified by the
+* parameters n, a, b, and c this routine transforms it to equivalent
+* reduced instance in the same format. The reduced instance is
+* normalized, i.e. the following additional conditions are met:
+*
+* n >= 2 (4)
+*
+* 1 <= a[j] <= b for all j in 1..n (5)
+*
+* sum{j in 1..n} a[j] >= b+1 (6)
+*
+* c[j] >= 1 for all j in 1..n (7)
+*
+* The routine creates the structure ks and stores there parameters n,
+* a, b, and c of the reduced instance as well as template of solution
+* to original instance.
+*
+* Normally the routine returns a pointer to the structure ks created.
+* However, if the original instance is infeasible, the routine returns
+* a null pointer. */
+
+struct ks
+{ int orig_n;
+ /* original problem dimension */
+ int n;
+ /* reduced problem dimension */
+ int *a; /* int a[1+orig_n]; */
+ /* a{j in 1..n} are constraint coefficients (2) */
+ int b;
+ /* b is constraint right-hand side (2) */
+ int *c; /* int c[1+orig_n]; */
+ /* c{j in 1..n} are objective coefficients (1) */
+ int c0;
+ /* c0 is objective constant term */
+ char *x; /* char x[1+orig_n]; */
+ /* x{j in 1..orig_n} is solution template to original instance:
+ * x[j] = 0 x[j] is fixed at 0
+ * x[j] = 1 x[j] is fixed at 1
+ * x[j] = 0x10 x[j] = x[j']
+ * x[j] = 0x11 x[j] = 1 - x[j']
+ * where x[j'] is corresponding solution to reduced instance */
+};
+
+static void free_ks(struct ks *ks);
+
+static struct ks *reduce(const int n, const int a[/*1+n*/], int b,
+ const int c[/*1+n*/])
+{ struct ks *ks;
+ int j, s;
+ xassert(n >= 0);
+ /* initially reduced instance is the same as original one */
+ ks = talloc(1, struct ks);
+ ks->orig_n = n;
+ ks->n = 0;
+ ks->a = talloc(1+n, int);
+ memcpy(&ks->a[1], &a[1], n * sizeof(int));
+ ks->b = b;
+ ks->c = talloc(1+n, int);
+ memcpy(&ks->c[1], &c[1], n * sizeof(int));
+ ks->c0 = 0;
+ ks->x = talloc(1+n, char);
+ /* make all a[j] non-negative */
+ for (j = 1; j <= n; j++)
+ { if (a[j] >= 0)
+ { /* keep original x[j] */
+ ks->x[j] = 0x10;
+ }
+ else /* a[j] < 0 */
+ { /* substitute x[j] = 1 - x'[j] */
+ ks->x[j] = 0x11;
+ /* ... + a[j]x[j] + ... <= b
+ * ... + a[j](1 - x'[j]) + ... <= b
+ * ... - a[j]x'[j] + ... <= b - a[j] */
+ ks->a[j] = - ks->a[j];
+ ks->b += ks->a[j];
+ /* z = ... + c[j]x[j] + ... + c0 =
+ * = ... + c[j](1 - x'[j]) + ... + c0 =
+ * = ... - c[j]x'[j] + ... + (c0 + c[j]) */
+ ks->c0 += ks->c[j];
+ ks->c[j] = - ks->c[j];
+ }
+ }
+ /* now a[j] >= 0 for all j in 1..n */
+ if (ks->b < 0)
+ { /* instance is infeasible */
+ free_ks(ks);
+ return NULL;
+ }
+ /* build reduced instance */
+ for (j = 1; j <= n; j++)
+ { if (ks->a[j] == 0)
+ { if (ks->c[j] <= 0)
+ { /* fix x[j] at 0 */
+ ks->x[j] ^= 0x10;
+ }
+ else
+ { /* fix x[j] at 1 */
+ ks->x[j] ^= 0x11;
+ ks->c0 += ks->c[j];
+ }
+ }
+ else if (ks->a[j] > ks->b || ks->c[j] <= 0)
+ { /* fix x[j] at 0 */
+ ks->x[j] ^= 0x10;
+ }
+ else
+ { /* include x[j] in reduced instance */
+ ks->n++;
+ ks->a[ks->n] = ks->a[j];
+ ks->c[ks->n] = ks->c[j];
+ }
+ }
+ /* now conditions (5) and (7) are met */
+ /* check condition (6) */
+ s = 0;
+ for (j = 1; j <= ks->n; j++)
+ { xassert(1 <= ks->a[j] && ks->a[j] <= ks->b);
+ xassert(ks->c[j] >= 1);
+ s += ks->a[j];
+ }
+ if (s <= ks->b)
+ { /* sum{j in 1..n} a[j] <= b */
+ /* fix all remaining x[j] at 1 to obtain trivial solution */
+ for (j = 1; j <= n; j++)
+ { if (ks->x[j] & 0x10)
+ ks->x[j] ^= 0x11;
+ }
+ for (j = 1; j <= ks->n; j++)
+ ks->c0 += ks->c[j];
+ /* reduced instance is empty */
+ ks->n = 0;
+ }
+ /* here n = 0 or n >= 2 due to condition (6) */
+ xassert(ks->n == 0 || ks->n >= 2);
+ return ks;
+}
+
+/***********************************************************************
+* restore - restore solution to original 0-1 knapsack instance
+*
+* Given optimal solution x{j in 1..ks->n} to the reduced 0-1 knapsack
+* instance (previously prepared by the routine reduce) this routine
+* constructs optimal solution to the original instance and stores it
+* in the array ks->x{j in 1..ks->orig_n}.
+*
+* On exit the routine returns optimal objective value for the original
+* instance.
+*
+* NOTE: This operation should be performed only once. */
+
+static int restore(struct ks *ks, char x[])
+{ int j, k, z;
+ z = ks->c0;
+ for (j = 1, k = 0; j <= ks->orig_n; j++)
+ { if (ks->x[j] & 0x10)
+ { k++;
+ xassert(k <= ks->n);
+ xassert(x[k] == 0 || x[k] == 1);
+ if (ks->x[j] & 1)
+ ks->x[j] = 1 - x[k];
+ else
+ ks->x[j] = x[k];
+ if (x[k])
+ z += ks->c[k];
+ }
+ }
+ xassert(k == ks->n);
+ return z;
+}
+
+/***********************************************************************
+* free_ks - deallocate structure ks
+*
+* This routine frees memory previously allocated to the structure ks
+* and all its components. */
+
+static void free_ks(struct ks *ks)
+{ xassert(ks != NULL);
+ tfree(ks->a);
+ tfree(ks->c);
+ tfree(ks->x);
+ tfree(ks);
+}
+
+/***********************************************************************
+* ks_mt1 - solve 0-1 knapsack problem with Martello & Toth algorithm
+*
+* This routine finds optimal solution to 0-1 knapsack problem (1)-(3)
+* with Martello & Toth algorithm MT1.
+*
+* The instance to be solved is specified by parameters n, a, b, and c.
+* Note that these parameters can have any sign, i.e. normalization is
+* not needed.
+*
+* On exit the routine stores the optimal point found in locations
+* x[1], ..., x[n] and returns the optimal objective value. However, if
+* the instance is infeasible, the routine returns INT_MIN.
+*
+* REFERENCES
+*
+* S.Martello, P.Toth. Knapsack Problems: Algorithms and Computer Imp-
+* lementations. John Wiley & Sons, 1990. */
+
+struct mt
+{ int j;
+ float r; /* r[j] = c[j] / a[j] */
+};
+
+static int CDECL fcmp(const void *p1, const void *p2)
+{ if (((struct mt *)p1)->r > ((struct mt *)p2)->r)
+ return -1;
+ else if (((struct mt *)p1)->r < ((struct mt *)p2)->r)
+ return +1;
+ else
+ return 0;
+}
+
+static int mt1a(int n, const int a[], int b, const int c[], char x[])
+{ /* interface routine to MT1 */
+ struct mt *mt;
+ int j, z, *p, *w, *x1, *xx, *min, *psign, *wsign, *zsign;
+ xassert(n >= 2);
+ /* allocate working arrays */
+ mt = talloc(1+n, struct mt);
+ p = talloc(1+n+1, int);
+ w = talloc(1+n+1, int);
+ x1 = talloc(1+n+1, int);
+ xx = talloc(1+n+1, int);
+ min = talloc(1+n+1, int);
+ psign = talloc(1+n+1, int);
+ wsign = talloc(1+n+1, int);
+ zsign = talloc(1+n+1, int);
+ /* reorder items to provide c[j] / a[j] >= a[j+1] / a[j+1] */
+ for (j = 1; j <= n; j++)
+ { mt[j].j = j;
+ mt[j].r = (float)c[j] / (float)a[j];
+ }
+ qsort(&mt[1], n, sizeof(struct mt), fcmp);
+ /* load instance parameters */
+ for (j = 1; j <= n; j++)
+ { p[j] = c[mt[j].j];
+ w[j] = a[mt[j].j];
+ }
+ /* find optimal solution */
+ z = mt1(n, p, w, b, x1, 1, xx, min, psign, wsign, zsign);
+ xassert(z >= 0);
+ /* store optimal point found */
+ for (j = 1; j <= n; j++)
+ { xassert(x1[j] == 0 || x1[j] == 1);
+ x[mt[j].j] = x1[j];
+ }
+ /* free working arrays */
+ tfree(mt);
+ tfree(p);
+ tfree(w);
+ tfree(x1);
+ tfree(xx);
+ tfree(min);
+ tfree(psign);
+ tfree(wsign);
+ tfree(zsign);
+ return z;
+}
+
+int ks_mt1(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/])
+{ struct ks *ks;
+ int j, s1, s2, z;
+ xassert(n >= 0);
+ /* prepare reduced instance */
+ ks = reduce(n, a, b, c);
+ if (ks == NULL)
+ { /* original instance is infeasible */
+ return INT_MIN;
+ }
+ /* find optimal solution to reduced instance */
+ if (ks->n > 0)
+ mt1a(ks->n, ks->a, ks->b, ks->c, x);
+ /* restore solution to original instance */
+ z = restore(ks, x);
+ memcpy(&x[1], &ks->x[1], n * sizeof(char));
+ free_ks(ks);
+ /* check solution found */
+ s1 = s2 = 0;
+ for (j = 1; j <= n; j++)
+ { xassert(x[j] == 0 || x[j] == 1);
+ if (x[j])
+ s1 += a[j], s2 += c[j];
+ }
+ xassert(s1 <= b);
+ xassert(s2 == z);
+ return z;
+}
+
+/***********************************************************************
+* ks_greedy - solve 0-1 knapsack problem with greedy heuristic
+*
+* This routine finds (sub)optimal solution to 0-1 knapsack problem
+* (1)-(3) with greedy heuristic.
+*
+* The instance to be solved is specified by parameters n, a, b, and c.
+* Note that these parameters can have any sign, i.e. normalization is
+* not needed.
+*
+* On exit the routine stores the optimal point found in locations
+* x[1], ..., x[n] and returns the optimal objective value. However, if
+* the instance is infeasible, the routine returns INT_MIN. */
+
+static int greedy(int n, const int a[], int b, const int c[], char x[])
+{ /* core routine for normalized 0-1 knapsack instance */
+ struct mt *mt;
+ int j, s, z;
+ xassert(n >= 2);
+ /* reorder items to provide c[j] / a[j] >= a[j+1] / a[j+1] */
+ mt = talloc(1+n, struct mt);
+ for (j = 1; j <= n; j++)
+ { mt[j].j = j;
+ mt[j].r = (float)c[j] / (float)a[j];
+ }
+ qsort(&mt[1], n, sizeof(struct mt), fcmp);
+ /* take items starting from most valuable ones until the knapsack
+ * is full */
+ s = z = 0;
+ for (j = 1; j <= n; j++)
+ { if (s + a[mt[j].j] > b)
+ break;
+ x[mt[j].j] = 1;
+ s += a[mt[j].j];
+ z += c[mt[j].j];
+ }
+ /* don't take remaining items */
+ for (j = j; j <= n; j++)
+ x[mt[j].j] = 0;
+ tfree(mt);
+ return z;
+}
+
+int ks_greedy(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/])
+{ struct ks *ks;
+ int j, s1, s2, z;
+ xassert(n >= 0);
+ /* prepare reduced instance */
+ ks = reduce(n, a, b, c);
+ if (ks == NULL)
+ { /* original instance is infeasible */
+ return INT_MIN;
+ }
+ /* find suboptimal solution to reduced instance */
+ if (ks->n > 0)
+ greedy(ks->n, ks->a, ks->b, ks->c, x);
+ /* restore solution to original instance */
+ z = restore(ks, x);
+ memcpy(&x[1], &ks->x[1], n * sizeof(char));
+ free_ks(ks);
+ /* check solution found */
+ s1 = s2 = 0;
+ for (j = 1; j <= n; j++)
+ { xassert(x[j] == 0 || x[j] == 1);
+ if (x[j])
+ s1 += a[j], s2 += c[j];
+ }
+ xassert(s1 <= b);
+ xassert(s2 == z);
+ return z;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/ks.h b/test/monniaux/glpk-4.65/src/misc/ks.h
new file mode 100644
index 00000000..d607dc44
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/ks.h
@@ -0,0 +1,44 @@
+/* ks.h (0-1 knapsack problem) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef KS_H
+#define KS_H
+
+#define ks_enum _glp_ks_enum
+int ks_enum(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/]);
+/* solve 0-1 knapsack problem by complete enumeration */
+
+#define ks_mt1 _glp_ks_mt1
+int ks_mt1(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/]);
+/* solve 0-1 knapsack problem with Martello & Toth algorithm */
+
+#define ks_greedy _glp_ks_greedy
+int ks_greedy(int n, const int a[/*1+n*/], int b, const int c[/*1+n*/],
+ char x[/*1+n*/]);
+/* solve 0-1 knapsack problem with greedy heuristic */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mc13d.c b/test/monniaux/glpk-4.65/src/misc/mc13d.c
new file mode 100644
index 00000000..d8bab398
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mc13d.c
@@ -0,0 +1,314 @@
+/* mc13d.c (permutations to block triangular form) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is the result of translation of the Fortran subroutines
+* MC13D and MC13E associated with the following paper:
+*
+* I.S.Duff, J.K.Reid, Algorithm 529: Permutations to block triangular
+* form, ACM Trans. on Math. Softw. 4 (1978), 189-192.
+*
+* Use of ACM Algorithms is subject to the ACM Software Copyright and
+* License Agreement. See <http://www.acm.org/publications/policies>.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mc13d.h"
+
+/***********************************************************************
+* NAME
+*
+* mc13d - permutations to block triangular form
+*
+* SYNOPSIS
+*
+* #include "mc13d.h"
+* int mc13d(int n, const int icn[], const int ip[], const int lenr[],
+* int ior[], int ib[], int lowl[], int numb[], int prev[]);
+*
+* DESCRIPTION
+*
+* Given the column numbers of the nonzeros in each row of the sparse
+* matrix, the routine mc13d finds a symmetric permutation that makes
+* the matrix block lower triangular.
+*
+* INPUT PARAMETERS
+*
+* n order of the matrix.
+*
+* icn array containing the column indices of the non-zeros. Those
+* belonging to a single row must be contiguous but the ordering
+* of column indices within each row is unimportant and wasted
+* space between rows is permitted.
+*
+* ip ip[i], i = 1,2,...,n, is the position in array icn of the
+* first column index of a non-zero in row i.
+*
+* lenr lenr[i], i = 1,2,...,n, is the number of non-zeros in row i.
+*
+* OUTPUT PARAMETERS
+*
+* ior ior[i], i = 1,2,...,n, gives the position on the original
+* ordering of the row or column which is in position i in the
+* permuted form.
+*
+* ib ib[i], i = 1,2,...,num, is the row number in the permuted
+* matrix of the beginning of block i, 1 <= num <= n.
+*
+* WORKING ARRAYS
+*
+* arp working array of length [1+n], where arp[0] is not used.
+* arp[i] is one less than the number of unsearched edges leaving
+* node i. At the end of the algorithm it is set to a permutation
+* which puts the matrix in block lower triangular form.
+*
+* ib working array of length [1+n], where ib[0] is not used.
+* ib[i] is the position in the ordering of the start of the ith
+* block. ib[n+1-i] holds the node number of the ith node on the
+* stack.
+*
+* lowl working array of length [1+n], where lowl[0] is not used.
+* lowl[i] is the smallest stack position of any node to which a
+* path from node i has been found. It is set to n+1 when node i
+* is removed from the stack.
+*
+* numb working array of length [1+n], where numb[0] is not used.
+* numb[i] is the position of node i in the stack if it is on it,
+* is the permuted order of node i for those nodes whose final
+* position has been found and is otherwise zero.
+*
+* prev working array of length [1+n], where prev[0] is not used.
+* prev[i] is the node at the end of the path when node i was
+* placed on the stack.
+*
+* RETURNS
+*
+* The routine mc13d returns num, the number of blocks found. */
+
+int mc13d(int n, const int icn[], const int ip[], const int lenr[],
+ int ior[], int ib[], int lowl[], int numb[], int prev[])
+{ int *arp = ior;
+ int dummy, i, i1, i2, icnt, ii, isn, ist, ist1, iv, iw, j, lcnt,
+ nnm1, num, stp;
+ /* icnt is the number of nodes whose positions in final ordering
+ * have been found. */
+ icnt = 0;
+ /* num is the number of blocks that have been found. */
+ num = 0;
+ nnm1 = n + n - 1;
+ /* Initialization of arrays. */
+ for (j = 1; j <= n; j++)
+ { numb[j] = 0;
+ arp[j] = lenr[j] - 1;
+ }
+ for (isn = 1; isn <= n; isn++)
+ { /* Look for a starting node. */
+ if (numb[isn] != 0) continue;
+ iv = isn;
+ /* ist is the number of nodes on the stack ... it is the stack
+ * pointer. */
+ ist = 1;
+ /* Put node iv at beginning of stack. */
+ lowl[iv] = numb[iv] = 1;
+ ib[n] = iv;
+ /* The body of this loop puts a new node on the stack or
+ * backtracks. */
+ for (dummy = 1; dummy <= nnm1; dummy++)
+ { i1 = arp[iv];
+ /* Have all edges leaving node iv been searched? */
+ if (i1 >= 0)
+ { i2 = ip[iv] + lenr[iv] - 1;
+ i1 = i2 - i1;
+ /* Look at edges leaving node iv until one enters a new
+ * node or all edges are exhausted. */
+ for (ii = i1; ii <= i2; ii++)
+ { iw = icn[ii];
+ /* Has node iw been on stack already? */
+ if (numb[iw] == 0) goto L70;
+ /* Update value of lowl[iv] if necessary. */
+ if (lowl[iw] < lowl[iv]) lowl[iv] = lowl[iw];
+ }
+ /* There are no more edges leaving node iv. */
+ arp[iv] = -1;
+ }
+ /* Is node iv the root of a block? */
+ if (lowl[iv] < numb[iv]) goto L60;
+ /* Order nodes in a block. */
+ num++;
+ ist1 = n + 1 - ist;
+ lcnt = icnt + 1;
+ /* Peel block off the top of the stack starting at the top
+ * and working down to the root of the block. */
+ for (stp = ist1; stp <= n; stp++)
+ { iw = ib[stp];
+ lowl[iw] = n + 1;
+ numb[iw] = ++icnt;
+ if (iw == iv) break;
+ }
+ ist = n - stp;
+ ib[num] = lcnt;
+ /* Are there any nodes left on the stack? */
+ if (ist != 0) goto L60;
+ /* Have all the nodes been ordered? */
+ if (icnt < n) break;
+ goto L100;
+L60: /* Backtrack to previous node on path. */
+ iw = iv;
+ iv = prev[iv];
+ /* Update value of lowl[iv] if necessary. */
+ if (lowl[iw] < lowl[iv]) lowl[iv] = lowl[iw];
+ continue;
+L70: /* Put new node on the stack. */
+ arp[iv] = i2 - ii - 1;
+ prev[iw] = iv;
+ iv = iw;
+ lowl[iv] = numb[iv] = ++ist;
+ ib[n+1-ist] = iv;
+ }
+ }
+L100: /* Put permutation in the required form. */
+ for (i = 1; i <= n; i++)
+ arp[numb[i]] = i;
+ return num;
+}
+
+/**********************************************************************/
+
+#ifdef GLP_TEST
+#include "env.h"
+
+void test(int n, int ipp);
+
+int main(void)
+{ /* test program for routine mc13d */
+ test( 1, 0);
+ test( 2, 1);
+ test( 2, 2);
+ test( 3, 3);
+ test( 4, 4);
+ test( 5, 10);
+ test(10, 10);
+ test(10, 20);
+ test(20, 20);
+ test(20, 50);
+ test(50, 50);
+ test(50, 200);
+ return 0;
+}
+
+void fa01bs(int max, int *nrand);
+
+void setup(int n, char a[1+50][1+50], int ip[], int icn[], int lenr[]);
+
+void test(int n, int ipp)
+{ int ip[1+50], icn[1+1000], ior[1+50], ib[1+51], iw[1+150],
+ lenr[1+50];
+ char a[1+50][1+50], hold[1+100];
+ int i, ii, iblock, ij, index, j, jblock, jj, k9, num;
+ xprintf("\n\n\nMatrix is of order %d and has %d off-diagonal non-"
+ "zeros\n", n, ipp);
+ for (j = 1; j <= n; j++)
+ { for (i = 1; i <= n; i++)
+ a[i][j] = 0;
+ a[j][j] = 1;
+ }
+ for (k9 = 1; k9 <= ipp; k9++)
+ { /* these statements should be replaced by calls to your
+ * favorite random number generator to place two pseudo-random
+ * numbers between 1 and n in the variables i and j */
+ for (;;)
+ { fa01bs(n, &i);
+ fa01bs(n, &j);
+ if (!a[i][j]) break;
+ }
+ a[i][j] = 1;
+ }
+ /* setup converts matrix a[i,j] to required sparsity-oriented
+ * storage format */
+ setup(n, a, ip, icn, lenr);
+ num = mc13d(n, icn, ip, lenr, ior, ib, &iw[0], &iw[n], &iw[n+n]);
+ /* output reordered matrix with blocking to improve clarity */
+ xprintf("\nThe reordered matrix which has %d block%s is of the fo"
+ "rm\n", num, num == 1 ? "" : "s");
+ ib[num+1] = n + 1;
+ index = 100;
+ iblock = 1;
+ for (i = 1; i <= n; i++)
+ { for (ij = 1; ij <= index; ij++)
+ hold[ij] = ' ';
+ if (i == ib[iblock])
+ { xprintf("\n");
+ iblock++;
+ }
+ jblock = 1;
+ index = 0;
+ for (j = 1; j <= n; j++)
+ { if (j == ib[jblock])
+ { hold[++index] = ' ';
+ jblock++;
+ }
+ ii = ior[i];
+ jj = ior[j];
+ hold[++index] = (char)(a[ii][jj] ? 'X' : '0');
+ }
+ xprintf("%.*s\n", index, &hold[1]);
+ }
+ xprintf("\nThe starting point for each block is given by\n");
+ for (i = 1; i <= num; i++)
+ { if ((i - 1) % 12 == 0) xprintf("\n");
+ xprintf(" %4d", ib[i]);
+ }
+ xprintf("\n");
+ return;
+}
+
+void setup(int n, char a[1+50][1+50], int ip[], int icn[], int lenr[])
+{ int i, j, ind;
+ for (i = 1; i <= n; i++)
+ lenr[i] = 0;
+ ind = 1;
+ for (i = 1; i <= n; i++)
+ { ip[i] = ind;
+ for (j = 1; j <= n; j++)
+ { if (a[i][j])
+ { lenr[i]++;
+ icn[ind++] = j;
+ }
+ }
+ }
+ return;
+}
+
+double g = 1431655765.0;
+
+double fa01as(int i)
+{ /* random number generator */
+ g = fmod(g * 9228907.0, 4294967296.0);
+ if (i >= 0)
+ return g / 4294967296.0;
+ else
+ return 2.0 * g / 4294967296.0 - 1.0;
+}
+
+void fa01bs(int max, int *nrand)
+{ *nrand = (int)(fa01as(1) * (double)max) + 1;
+ return;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mc13d.h b/test/monniaux/glpk-4.65/src/misc/mc13d.h
new file mode 100644
index 00000000..bdd57a19
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mc13d.h
@@ -0,0 +1,34 @@
+/* mc13d.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MC13D_H
+#define MC13D_H
+
+#define mc13d _glp_mc13d
+int mc13d(int n, const int icn[], const int ip[], const int lenr[],
+ int ior[], int ib[], int lowl[], int numb[], int prev[]);
+/* permutations to block triangular form */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mc21a.c b/test/monniaux/glpk-4.65/src/misc/mc21a.c
new file mode 100644
index 00000000..700d0f4e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mc21a.c
@@ -0,0 +1,301 @@
+/* mc21a.c (permutations for zero-free diagonal) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is the result of translation of the Fortran subroutines
+* MC21A and MC21B associated with the following paper:
+*
+* I.S.Duff, Algorithm 575: Permutations for zero-free diagonal, ACM
+* Trans. on Math. Softw. 7 (1981), 387-390.
+*
+* Use of ACM Algorithms is subject to the ACM Software Copyright and
+* License Agreement. See <http://www.acm.org/publications/policies>.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mc21a.h"
+
+/***********************************************************************
+* NAME
+*
+* mc21a - permutations for zero-free diagonal
+*
+* SYNOPSIS
+*
+* #include "mc21a.h"
+* int mc21a(int n, const int icn[], const int ip[], const int lenr[],
+* int iperm[], int pr[], int arp[], int cv[], int out[]);
+*
+* DESCRIPTION
+*
+* Given the pattern of nonzeros of a sparse matrix, the routine mc21a
+* attempts to find a permutation of its rows that makes the matrix have
+* no zeros on its diagonal.
+*
+* INPUT PARAMETERS
+*
+* n order of matrix.
+*
+* icn array containing the column indices of the non-zeros. Those
+* belonging to a single row must be contiguous but the ordering
+* of column indices within each row is unimportant and wasted
+* space between rows is permitted.
+*
+* ip ip[i], i = 1,2,...,n, is the position in array icn of the
+* first column index of a non-zero in row i.
+*
+* lenr lenr[i], i = 1,2,...,n, is the number of non-zeros in row i.
+*
+* OUTPUT PARAMETER
+*
+* iperm contains permutation to make diagonal have the smallest
+* number of zeros on it. Elements (iperm[i], i), i = 1,2,...,n,
+* are non-zero at the end of the algorithm unless the matrix is
+* structurally singular. In this case, (iperm[i], i) will be
+* zero for n - numnz entries.
+*
+* WORKING ARRAYS
+*
+* pr working array of length [1+n], where pr[0] is not used.
+* pr[i] is the previous row to i in the depth first search.
+*
+* arp working array of length [1+n], where arp[0] is not used.
+* arp[i] is one less than the number of non-zeros in row i which
+* have not been scanned when looking for a cheap assignment.
+*
+* cv working array of length [1+n], where cv[0] is not used.
+* cv[i] is the most recent row extension at which column i was
+* visited.
+*
+* out working array of length [1+n], where out[0] is not used.
+* out[i] is one less than the number of non-zeros in row i
+* which have not been scanned during one pass through the main
+* loop.
+*
+* RETURNS
+*
+* The routine mc21a returns numnz, the number of non-zeros on diagonal
+* of permuted matrix. */
+
+int mc21a(int n, const int icn[], const int ip[], const int lenr[],
+ int iperm[], int pr[], int arp[], int cv[], int out[])
+{ int i, ii, in1, in2, j, j1, jord, k, kk, numnz;
+ /* Initialization of arrays. */
+ for (i = 1; i <= n; i++)
+ { arp[i] = lenr[i] - 1;
+ cv[i] = iperm[i] = 0;
+ }
+ numnz = 0;
+ /* Main loop. */
+ /* Each pass round this loop either results in a new assignment
+ * or gives a row with no assignment. */
+ for (jord = 1; jord <= n; jord++)
+ { j = jord;
+ pr[j] = -1;
+ for (k = 1; k <= jord; k++)
+ { /* Look for a cheap assignment. */
+ in1 = arp[j];
+ if (in1 >= 0)
+ { in2 = ip[j] + lenr[j] - 1;
+ in1 = in2 - in1;
+ for (ii = in1; ii <= in2; ii++)
+ { i = icn[ii];
+ if (iperm[i] == 0) goto L110;
+ }
+ /* No cheap assignment in row. */
+ arp[j] = -1;
+ }
+ /* Begin looking for assignment chain starting with row j.*/
+ out[j] = lenr[j] - 1;
+ /* Inner loop. Extends chain by one or backtracks. */
+ for (kk = 1; kk <= jord; kk++)
+ { in1 = out[j];
+ if (in1 >= 0)
+ { in2 = ip[j] + lenr[j] - 1;
+ in1 = in2 - in1;
+ /* Forward scan. */
+ for (ii = in1; ii <= in2; ii++)
+ { i = icn[ii];
+ if (cv[i] != jord)
+ { /* Column i has not yet been accessed during
+ * this pass. */
+ j1 = j;
+ j = iperm[i];
+ cv[i] = jord;
+ pr[j] = j1;
+ out[j1] = in2 - ii - 1;
+ goto L100;
+ }
+ }
+ }
+ /* Backtracking step. */
+ j = pr[j];
+ if (j == -1) goto L130;
+ }
+L100: ;
+ }
+L110: /* New assignment is made. */
+ iperm[i] = j;
+ arp[j] = in2 - ii - 1;
+ numnz++;
+ for (k = 1; k <= jord; k++)
+ { j = pr[j];
+ if (j == -1) break;
+ ii = ip[j] + lenr[j] - out[j] - 2;
+ i = icn[ii];
+ iperm[i] = j;
+ }
+L130: ;
+ }
+ /* If matrix is structurally singular, we now complete the
+ * permutation iperm. */
+ if (numnz < n)
+ { for (i = 1; i <= n; i++)
+ arp[i] = 0;
+ k = 0;
+ for (i = 1; i <= n; i++)
+ { if (iperm[i] == 0)
+ out[++k] = i;
+ else
+ arp[iperm[i]] = i;
+ }
+ k = 0;
+ for (i = 1; i <= n; i++)
+ { if (arp[i] == 0)
+ iperm[out[++k]] = i;
+ }
+ }
+ return numnz;
+}
+
+/**********************************************************************/
+
+#ifdef GLP_TEST
+#include "env.h"
+
+int sing;
+
+void ranmat(int m, int n, int icn[], int iptr[], int nnnp1, int *knum,
+ int iw[]);
+
+void fa01bs(int max, int *nrand);
+
+int main(void)
+{ /* test program for the routine mc21a */
+ /* these runs on random matrices cause all possible statements in
+ * mc21a to be executed */
+ int i, iold, j, j1, j2, jj, knum, l, licn, n, nov4, num, numnz;
+ int ip[1+21], icn[1+1000], iperm[1+20], lenr[1+20], iw1[1+80];
+ licn = 1000;
+ /* run on random matrices of orders 1 through 20 */
+ for (n = 1; n <= 20; n++)
+ { nov4 = n / 4;
+ if (nov4 < 1) nov4 = 1;
+L10: fa01bs(nov4, &l);
+ knum = l * n;
+ /* knum is requested number of non-zeros in random matrix */
+ if (knum > licn) goto L10;
+ /* if sing is false, matrix is guaranteed structurally
+ * non-singular */
+ sing = ((n / 2) * 2 == n);
+ /* call to subroutine to generate random matrix */
+ ranmat(n, n, icn, ip, n+1, &knum, iw1);
+ /* knum is now actual number of non-zeros in random matrix */
+ if (knum > licn) goto L10;
+ xprintf("n = %2d; nz = %4d; sing = %d\n", n, knum, sing);
+ /* set up array of row lengths */
+ for (i = 1; i <= n; i++)
+ lenr[i] = ip[i+1] - ip[i];
+ /* call to mc21a */
+ numnz = mc21a(n, icn, ip, lenr, iperm, &iw1[0], &iw1[n],
+ &iw1[n+n], &iw1[n+n+n]);
+ /* testing to see if there are numnz non-zeros on the diagonal
+ * of the permuted matrix. */
+ num = 0;
+ for (i = 1; i <= n; i++)
+ { iold = iperm[i];
+ j1 = ip[iold];
+ j2 = j1 + lenr[iold] - 1;
+ if (j2 < j1) continue;
+ for (jj = j1; jj <= j2; jj++)
+ { j = icn[jj];
+ if (j == i)
+ { num++;
+ break;
+ }
+ }
+ }
+ if (num != numnz)
+ xprintf("Failure in mc21a, numnz = %d instead of %d\n",
+ numnz, num);
+ }
+ return 0;
+}
+
+void ranmat(int m, int n, int icn[], int iptr[], int nnnp1, int *knum,
+ int iw[])
+{ /* subroutine to generate random matrix */
+ int i, ii, inum, j, lrow, matnum;
+ inum = (*knum / n) * 2;
+ if (inum > n-1) inum = n-1;
+ matnum = 1;
+ /* each pass through this loop generates a row of the matrix */
+ for (j = 1; j <= m; j++)
+ { iptr[j] = matnum;
+ if (!(sing || j > n))
+ icn[matnum++] = j;
+ if (n == 1) continue;
+ for (i = 1; i <= n; i++) iw[i] = 0;
+ if (!sing) iw[j] = 1;
+ fa01bs(inum, &lrow);
+ lrow--;
+ if (lrow == 0) continue;
+ /* lrow off-diagonal non-zeros in row j of the matrix */
+ for (ii = 1; ii <= lrow; ii++)
+ { for (;;)
+ { fa01bs(n, &i);
+ if (iw[i] != 1) break;
+ }
+ iw[i] = 1;
+ icn[matnum++] = i;
+ }
+ }
+ for (i = m+1; i <= nnnp1; i++)
+ iptr[i] = matnum;
+ *knum = matnum - 1;
+ return;
+}
+
+double g = 1431655765.0;
+
+double fa01as(int i)
+{ /* random number generator */
+ g = fmod(g * 9228907.0, 4294967296.0);
+ if (i >= 0)
+ return g / 4294967296.0;
+ else
+ return 2.0 * g / 4294967296.0 - 1.0;
+}
+
+void fa01bs(int max, int *nrand)
+{ *nrand = (int)(fa01as(1) * (double)max) + 1;
+ return;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mc21a.h b/test/monniaux/glpk-4.65/src/misc/mc21a.h
new file mode 100644
index 00000000..755f28b2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mc21a.h
@@ -0,0 +1,34 @@
+/* mc21a.h (permutations for zero-free diagonal) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MC21A_H
+#define MC21A_H
+
+#define mc21a _glp_mc21a
+int mc21a(int n, const int icn[], const int ip[], const int lenr[],
+ int iperm[], int pr[], int arp[], int cv[], int out[]);
+/* permutations for zero-free diagonal */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/misc.h b/test/monniaux/glpk-4.65/src/misc/misc.h
new file mode 100644
index 00000000..1ba1dc50
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/misc.h
@@ -0,0 +1,61 @@
+/* misc.h (miscellaneous routines) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MISC_H
+#define MISC_H
+
+#define str2int _glp_str2int
+int str2int(const char *str, int *val);
+/* convert character string to value of int type */
+
+#define str2num _glp_str2num
+int str2num(const char *str, double *val);
+/* convert character string to value of double type */
+
+#define strspx _glp_strspx
+char *strspx(char *str);
+/* remove all spaces from character string */
+
+#define strtrim _glp_strtrim
+char *strtrim(char *str);
+/* remove trailing spaces from character string */
+
+#define gcd _glp_gcd
+int gcd(int x, int y);
+/* find greatest common divisor of two integers */
+
+#define gcdn _glp_gcdn
+int gcdn(int n, int x[]);
+/* find greatest common divisor of n integers */
+
+#define round2n _glp_round2n
+double round2n(double x);
+/* round floating-point number to nearest power of two */
+
+#define fp2rat _glp_fp2rat
+int fp2rat(double x, double eps, double *p, double *q);
+/* convert floating-point number to rational number */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mt1.c b/test/monniaux/glpk-4.65/src/misc/mt1.c
new file mode 100644
index 00000000..63a0f80e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mt1.c
@@ -0,0 +1,1110 @@
+/* mt1.c (0-1 knapsack problem; Martello & Toth algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* THIS CODE IS THE RESULT OF TRANSLATION OF THE FORTRAN SUBROUTINES
+* MT1 FROM THE BOOK:
+*
+* SILVANO MARTELLO, PAOLO TOTH. KNAPSACK PROBLEMS: ALGORITHMS AND
+* COMPUTER IMPLEMENTATIONS. JOHN WILEY & SONS, 1990.
+*
+* THE TRANSLATION HAS BEEN DONE WITH THE PERMISSION OF THE AUTHORS OF
+* THE ORIGINAL FORTRAN SUBROUTINES: SILVANO MARTELLO AND PAOLO TOTH.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#line 1 ""
+/* -- translated by f2c (version 20100827).
+ You must link the resulting object file with libf2c:
+ on Microsoft Windows system, link with libf2c.lib;
+ on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+ or, if you install libf2c.a in a standard place, with -lf2c -lm
+ -- in that order, at the end of the command line, as in
+ cc *.o -lf2c -lm
+ Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+ http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#if 0 /* by mao */
+#include "f2c.h"
+#else
+#include "env.h"
+#include "mt1.h"
+
+typedef int integer;
+typedef float real;
+#endif
+
+#line 1 ""
+/*< SUBROUTINE MT1(N,P,W,C,Z,X,JDIM,JCK,XX,MIN,PSIGN,WSIGN,ZSIGN) >*/
+#if 1 /* by mao */
+static int chmt1_(int *, int *, int *, int *, int *, int *);
+
+static
+#endif
+/* Subroutine */ int mt1_(integer *n, integer *p, integer *w, integer *c__,
+ integer *z__, integer *x, integer *jdim, integer *jck, integer *xx,
+ integer *min__, integer *psign, integer *wsign, integer *zsign)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ static real a, b;
+ static integer j, r__, t, j1, n1, ch, ii, jj, kk, in, ll, ip, nn, iu, ii1,
+ chs, lim, lim1, diff, lold, mink;
+ extern /* Subroutine */ int chmt1_(integer *, integer *, integer *,
+ integer *, integer *, integer *);
+ static integer profit;
+
+
+/* THIS SUBROUTINE SOLVES THE 0-1 SINGLE KNAPSACK PROBLEM */
+
+/* MAXIMIZE Z = P(1)*X(1) + ... + P(N)*X(N) */
+
+/* SUBJECT TO: W(1)*X(1) + ... + W(N)*X(N) .LE. C , */
+/* X(J) = 0 OR 1 FOR J=1,...,N. */
+
+/* THE PROGRAM IS INCLUDED IN THE VOLUME */
+/* S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS */
+/* AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990 */
+/* AND IMPLEMENTS THE BRANCH-AND-BOUND ALGORITHM DESCRIBED IN */
+/* SECTION 2.5.2 . */
+/* THE PROGRAM DERIVES FROM AN EARLIER CODE PRESENTED IN */
+/* S. MARTELLO, P. TOTH, "ALGORITHM FOR THE SOLUTION OF THE 0-1 SINGLE */
+/* KNAPSACK PROBLEM", COMPUTING, 1978. */
+
+/* THE INPUT PROBLEM MUST SATISFY THE CONDITIONS */
+
+/* 1) 2 .LE. N .LE. JDIM - 1 ; */
+/* 2) P(J), W(J), C POSITIVE INTEGERS; */
+/* 3) MAX (W(J)) .LE. C ; */
+/* 4) W(1) + ... + W(N) .GT. C ; */
+/* 5) P(J)/W(J) .GE. P(J+1)/W(J+1) FOR J=1,...,N-1. */
+
+/* MT1 CALLS 1 PROCEDURE: CHMT1. */
+
+/* THE PROGRAM IS COMPLETELY SELF-CONTAINED AND COMMUNICATION TO IT IS */
+/* ACHIEVED SOLELY THROUGH THE PARAMETER LIST OF MT1. */
+/* NO MACHINE-DEPENDENT CONSTANT IS USED. */
+/* THE PROGRAM IS WRITTEN IN 1967 AMERICAN NATIONAL STANDARD FORTRAN */
+/* AND IS ACCEPTED BY THE PFORT VERIFIER (PFORT IS THE PORTABLE */
+/* SUBSET OF ANSI DEFINED BY THE ASSOCIATION FOR COMPUTING MACHINERY). */
+/* THE PROGRAM HAS BEEN TESTED ON A DIGITAL VAX 11/780 AND AN H.P. */
+/* 9000/840. */
+
+/* MT1 NEEDS 8 ARRAYS ( P , W , X , XX , MIN , PSIGN , WSIGN */
+/* AND ZSIGN ) OF LENGTH AT LEAST N + 1 . */
+
+/* MEANING OF THE INPUT PARAMETERS: */
+/* N = NUMBER OF ITEMS; */
+/* P(J) = PROFIT OF ITEM J (J=1,...,N); */
+/* W(J) = WEIGHT OF ITEM J (J=1,...,N); */
+/* C = CAPACITY OF THE KNAPSACK; */
+/* JDIM = DIMENSION OF THE 8 ARRAYS; */
+/* JCK = 1 IF CHECK ON THE INPUT DATA IS DESIRED, */
+/* = 0 OTHERWISE. */
+
+/* MEANING OF THE OUTPUT PARAMETERS: */
+/* Z = VALUE OF THE OPTIMAL SOLUTION IF Z .GT. 0 , */
+/* = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI- */
+/* TION - Z IS VIOLATED; */
+/* X(J) = 1 IF ITEM J IS IN THE OPTIMAL SOLUTION, */
+/* = 0 OTHERWISE. */
+
+/* ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY. */
+
+/* ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT */
+/* PARAMETERS ARE UNCHANGED. */
+
+/*< INTEGER P(JDIM),W(JDIM),X(JDIM),C,Z >*/
+/*< INTEGER XX(JDIM),MIN(JDIM),PSIGN(JDIM),WSIGN(JDIM),ZSIGN(JDIM) >*/
+/*< INTEGER CH,CHS,DIFF,PROFIT,R,T >*/
+/*< Z = 0 >*/
+#line 65 ""
+ /* Parameter adjustments */
+#line 65 ""
+ --zsign;
+#line 65 ""
+ --wsign;
+#line 65 ""
+ --psign;
+#line 65 ""
+ --min__;
+#line 65 ""
+ --xx;
+#line 65 ""
+ --x;
+#line 65 ""
+ --w;
+#line 65 ""
+ --p;
+#line 65 ""
+
+#line 65 ""
+ /* Function Body */
+#line 65 ""
+ *z__ = 0;
+/*< IF ( JCK .EQ. 1 ) CALL CHMT1(N,P,W,C,Z,JDIM) >*/
+#line 66 ""
+ if (*jck == 1) {
+#line 66 ""
+ chmt1_(n, &p[1], &w[1], c__, z__, jdim);
+#line 66 ""
+ }
+/*< IF ( Z .LT. 0 ) RETURN >*/
+#line 67 ""
+ if (*z__ < 0) {
+#line 67 ""
+ return 0;
+#line 67 ""
+ }
+/* INITIALIZE. */
+/*< CH = C >*/
+#line 69 ""
+ ch = *c__;
+/*< IP = 0 >*/
+#line 70 ""
+ ip = 0;
+/*< CHS = CH >*/
+#line 71 ""
+ chs = ch;
+/*< DO 10 LL=1,N >*/
+#line 72 ""
+ i__1 = *n;
+#line 72 ""
+ for (ll = 1; ll <= i__1; ++ll) {
+/*< IF ( W(LL) .GT. CHS ) GO TO 20 >*/
+#line 73 ""
+ if (w[ll] > chs) {
+#line 73 ""
+ goto L20;
+#line 73 ""
+ }
+/*< IP = IP + P(LL) >*/
+#line 74 ""
+ ip += p[ll];
+/*< CHS = CHS - W(LL) >*/
+#line 75 ""
+ chs -= w[ll];
+/*< 10 CONTINUE >*/
+#line 76 ""
+/* L10: */
+#line 76 ""
+ }
+/*< 20 LL = LL - 1 >*/
+#line 77 ""
+L20:
+#line 77 ""
+ --ll;
+/*< IF ( CHS .EQ. 0 ) GO TO 50 >*/
+#line 78 ""
+ if (chs == 0) {
+#line 78 ""
+ goto L50;
+#line 78 ""
+ }
+/*< P(N+1) = 0 >*/
+#line 79 ""
+ p[*n + 1] = 0;
+/*< W(N+1) = CH + 1 >*/
+#line 80 ""
+ w[*n + 1] = ch + 1;
+/*< LIM = IP + CHS*P(LL+2)/W(LL+2) >*/
+#line 81 ""
+ lim = ip + chs * p[ll + 2] / w[ll + 2];
+/*< A = W(LL+1) - CHS >*/
+#line 82 ""
+ a = (real) (w[ll + 1] - chs);
+/*< B = IP + P(LL+1) >*/
+#line 83 ""
+ b = (real) (ip + p[ll + 1]);
+/*< LIM1 = B - A*FLOAT(P(LL))/FLOAT(W(LL)) >*/
+#line 84 ""
+ lim1 = b - a * (real) p[ll] / (real) w[ll];
+/*< IF ( LIM1 .GT. LIM ) LIM = LIM1 >*/
+#line 85 ""
+ if (lim1 > lim) {
+#line 85 ""
+ lim = lim1;
+#line 85 ""
+ }
+/*< MINK = CH + 1 >*/
+#line 86 ""
+ mink = ch + 1;
+/*< MIN(N) = MINK >*/
+#line 87 ""
+ min__[*n] = mink;
+/*< DO 30 J=2,N >*/
+#line 88 ""
+ i__1 = *n;
+#line 88 ""
+ for (j = 2; j <= i__1; ++j) {
+/*< KK = N + 2 - J >*/
+#line 89 ""
+ kk = *n + 2 - j;
+/*< IF ( W(KK) .LT. MINK ) MINK = W(KK) >*/
+#line 90 ""
+ if (w[kk] < mink) {
+#line 90 ""
+ mink = w[kk];
+#line 90 ""
+ }
+/*< MIN(KK-1) = MINK >*/
+#line 91 ""
+ min__[kk - 1] = mink;
+/*< 30 CONTINUE >*/
+#line 92 ""
+/* L30: */
+#line 92 ""
+ }
+/*< DO 40 J=1,N >*/
+#line 93 ""
+ i__1 = *n;
+#line 93 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< XX(J) = 0 >*/
+#line 94 ""
+ xx[j] = 0;
+/*< 40 CONTINUE >*/
+#line 95 ""
+/* L40: */
+#line 95 ""
+ }
+/*< Z = 0 >*/
+#line 96 ""
+ *z__ = 0;
+/*< PROFIT = 0 >*/
+#line 97 ""
+ profit = 0;
+/*< LOLD = N >*/
+#line 98 ""
+ lold = *n;
+/*< II = 1 >*/
+#line 99 ""
+ ii = 1;
+/*< GO TO 170 >*/
+#line 100 ""
+ goto L170;
+/*< 50 Z = IP >*/
+#line 101 ""
+L50:
+#line 101 ""
+ *z__ = ip;
+/*< DO 60 J=1,LL >*/
+#line 102 ""
+ i__1 = ll;
+#line 102 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< X(J) = 1 >*/
+#line 103 ""
+ x[j] = 1;
+/*< 60 CONTINUE >*/
+#line 104 ""
+/* L60: */
+#line 104 ""
+ }
+/*< NN = LL + 1 >*/
+#line 105 ""
+ nn = ll + 1;
+/*< DO 70 J=NN,N >*/
+#line 106 ""
+ i__1 = *n;
+#line 106 ""
+ for (j = nn; j <= i__1; ++j) {
+/*< X(J) = 0 >*/
+#line 107 ""
+ x[j] = 0;
+/*< 70 CONTINUE >*/
+#line 108 ""
+/* L70: */
+#line 108 ""
+ }
+/*< RETURN >*/
+#line 109 ""
+ return 0;
+/* TRY TO INSERT THE II-TH ITEM INTO THE CURRENT SOLUTION. */
+/*< 80 IF ( W(II) .LE. CH ) GO TO 90 >*/
+#line 111 ""
+L80:
+#line 111 ""
+ if (w[ii] <= ch) {
+#line 111 ""
+ goto L90;
+#line 111 ""
+ }
+/*< II1 = II + 1 >*/
+#line 112 ""
+ ii1 = ii + 1;
+/*< IF ( Z .GE. CH*P(II1)/W(II1) + PROFIT ) GO TO 280 >*/
+#line 113 ""
+ if (*z__ >= ch * p[ii1] / w[ii1] + profit) {
+#line 113 ""
+ goto L280;
+#line 113 ""
+ }
+/*< II = II1 >*/
+#line 114 ""
+ ii = ii1;
+/*< GO TO 80 >*/
+#line 115 ""
+ goto L80;
+/* BUILD A NEW CURRENT SOLUTION. */
+/*< 90 IP = PSIGN(II) >*/
+#line 117 ""
+L90:
+#line 117 ""
+ ip = psign[ii];
+/*< CHS = CH - WSIGN(II) >*/
+#line 118 ""
+ chs = ch - wsign[ii];
+/*< IN = ZSIGN(II) >*/
+#line 119 ""
+ in = zsign[ii];
+/*< DO 100 LL=IN,N >*/
+#line 120 ""
+ i__1 = *n;
+#line 120 ""
+ for (ll = in; ll <= i__1; ++ll) {
+/*< IF ( W(LL) .GT. CHS ) GO TO 160 >*/
+#line 121 ""
+ if (w[ll] > chs) {
+#line 121 ""
+ goto L160;
+#line 121 ""
+ }
+/*< IP = IP + P(LL) >*/
+#line 122 ""
+ ip += p[ll];
+/*< CHS = CHS - W(LL) >*/
+#line 123 ""
+ chs -= w[ll];
+/*< 100 CONTINUE >*/
+#line 124 ""
+/* L100: */
+#line 124 ""
+ }
+/*< LL = N >*/
+#line 125 ""
+ ll = *n;
+/*< 110 IF ( Z .GE. IP + PROFIT ) GO TO 280 >*/
+#line 126 ""
+L110:
+#line 126 ""
+ if (*z__ >= ip + profit) {
+#line 126 ""
+ goto L280;
+#line 126 ""
+ }
+/*< Z = IP + PROFIT >*/
+#line 127 ""
+ *z__ = ip + profit;
+/*< NN = II - 1 >*/
+#line 128 ""
+ nn = ii - 1;
+/*< DO 120 J=1,NN >*/
+#line 129 ""
+ i__1 = nn;
+#line 129 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< X(J) = XX(J) >*/
+#line 130 ""
+ x[j] = xx[j];
+/*< 120 CONTINUE >*/
+#line 131 ""
+/* L120: */
+#line 131 ""
+ }
+/*< DO 130 J=II,LL >*/
+#line 132 ""
+ i__1 = ll;
+#line 132 ""
+ for (j = ii; j <= i__1; ++j) {
+/*< X(J) = 1 >*/
+#line 133 ""
+ x[j] = 1;
+/*< 130 CONTINUE >*/
+#line 134 ""
+/* L130: */
+#line 134 ""
+ }
+/*< IF ( LL .EQ. N ) GO TO 150 >*/
+#line 135 ""
+ if (ll == *n) {
+#line 135 ""
+ goto L150;
+#line 135 ""
+ }
+/*< NN = LL + 1 >*/
+#line 136 ""
+ nn = ll + 1;
+/*< DO 140 J=NN,N >*/
+#line 137 ""
+ i__1 = *n;
+#line 137 ""
+ for (j = nn; j <= i__1; ++j) {
+/*< X(J) = 0 >*/
+#line 138 ""
+ x[j] = 0;
+/*< 140 CONTINUE >*/
+#line 139 ""
+/* L140: */
+#line 139 ""
+ }
+/*< 150 IF ( Z .NE. LIM ) GO TO 280 >*/
+#line 140 ""
+L150:
+#line 140 ""
+ if (*z__ != lim) {
+#line 140 ""
+ goto L280;
+#line 140 ""
+ }
+/*< RETURN >*/
+#line 141 ""
+ return 0;
+/*< 160 IU = CHS*P(LL)/W(LL) >*/
+#line 142 ""
+L160:
+#line 142 ""
+ iu = chs * p[ll] / w[ll];
+/*< LL = LL - 1 >*/
+#line 143 ""
+ --ll;
+/*< IF ( IU .EQ. 0 ) GO TO 110 >*/
+#line 144 ""
+ if (iu == 0) {
+#line 144 ""
+ goto L110;
+#line 144 ""
+ }
+/*< IF ( Z .GE. PROFIT + IP + IU ) GO TO 280 >*/
+#line 145 ""
+ if (*z__ >= profit + ip + iu) {
+#line 145 ""
+ goto L280;
+#line 145 ""
+ }
+/* SAVE THE CURRENT SOLUTION. */
+/*< 170 WSIGN(II) = CH - CHS >*/
+#line 147 ""
+L170:
+#line 147 ""
+ wsign[ii] = ch - chs;
+/*< PSIGN(II) = IP >*/
+#line 148 ""
+ psign[ii] = ip;
+/*< ZSIGN(II) = LL + 1 >*/
+#line 149 ""
+ zsign[ii] = ll + 1;
+/*< XX(II) = 1 >*/
+#line 150 ""
+ xx[ii] = 1;
+/*< NN = LL - 1 >*/
+#line 151 ""
+ nn = ll - 1;
+/*< IF ( NN .LT. II) GO TO 190 >*/
+#line 152 ""
+ if (nn < ii) {
+#line 152 ""
+ goto L190;
+#line 152 ""
+ }
+/*< DO 180 J=II,NN >*/
+#line 153 ""
+ i__1 = nn;
+#line 153 ""
+ for (j = ii; j <= i__1; ++j) {
+/*< WSIGN(J+1) = WSIGN(J) - W(J) >*/
+#line 154 ""
+ wsign[j + 1] = wsign[j] - w[j];
+/*< PSIGN(J+1) = PSIGN(J) - P(J) >*/
+#line 155 ""
+ psign[j + 1] = psign[j] - p[j];
+/*< ZSIGN(J+1) = LL + 1 >*/
+#line 156 ""
+ zsign[j + 1] = ll + 1;
+/*< XX(J+1) = 1 >*/
+#line 157 ""
+ xx[j + 1] = 1;
+/*< 180 CONTINUE >*/
+#line 158 ""
+/* L180: */
+#line 158 ""
+ }
+/*< 190 J1 = LL + 1 >*/
+#line 159 ""
+L190:
+#line 159 ""
+ j1 = ll + 1;
+/*< DO 200 J=J1,LOLD >*/
+#line 160 ""
+ i__1 = lold;
+#line 160 ""
+ for (j = j1; j <= i__1; ++j) {
+/*< WSIGN(J) = 0 >*/
+#line 161 ""
+ wsign[j] = 0;
+/*< PSIGN(J) = 0 >*/
+#line 162 ""
+ psign[j] = 0;
+/*< ZSIGN(J) = J >*/
+#line 163 ""
+ zsign[j] = j;
+/*< 200 CONTINUE >*/
+#line 164 ""
+/* L200: */
+#line 164 ""
+ }
+/*< LOLD = LL >*/
+#line 165 ""
+ lold = ll;
+/*< CH = CHS >*/
+#line 166 ""
+ ch = chs;
+/*< PROFIT = PROFIT + IP >*/
+#line 167 ""
+ profit += ip;
+/*< IF ( LL - (N - 2) ) 240, 220, 210 >*/
+#line 168 ""
+ if ((i__1 = ll - (*n - 2)) < 0) {
+#line 168 ""
+ goto L240;
+#line 168 ""
+ } else if (i__1 == 0) {
+#line 168 ""
+ goto L220;
+#line 168 ""
+ } else {
+#line 168 ""
+ goto L210;
+#line 168 ""
+ }
+/*< 210 II = N >*/
+#line 169 ""
+L210:
+#line 169 ""
+ ii = *n;
+/*< GO TO 250 >*/
+#line 170 ""
+ goto L250;
+/*< 220 IF ( CH .LT. W(N) ) GO TO 230 >*/
+#line 171 ""
+L220:
+#line 171 ""
+ if (ch < w[*n]) {
+#line 171 ""
+ goto L230;
+#line 171 ""
+ }
+/*< CH = CH - W(N) >*/
+#line 172 ""
+ ch -= w[*n];
+/*< PROFIT = PROFIT + P(N) >*/
+#line 173 ""
+ profit += p[*n];
+/*< XX(N) = 1 >*/
+#line 174 ""
+ xx[*n] = 1;
+/*< 230 II = N - 1 >*/
+#line 175 ""
+L230:
+#line 175 ""
+ ii = *n - 1;
+/*< GO TO 250 >*/
+#line 176 ""
+ goto L250;
+/*< 240 II = LL + 2 >*/
+#line 177 ""
+L240:
+#line 177 ""
+ ii = ll + 2;
+/*< IF ( CH .GE. MIN(II-1) ) GO TO 80 >*/
+#line 178 ""
+ if (ch >= min__[ii - 1]) {
+#line 178 ""
+ goto L80;
+#line 178 ""
+ }
+/* SAVE THE CURRENT OPTIMAL SOLUTION. */
+/*< 250 IF ( Z .GE. PROFIT ) GO TO 270 >*/
+#line 180 ""
+L250:
+#line 180 ""
+ if (*z__ >= profit) {
+#line 180 ""
+ goto L270;
+#line 180 ""
+ }
+/*< Z = PROFIT >*/
+#line 181 ""
+ *z__ = profit;
+/*< DO 260 J=1,N >*/
+#line 182 ""
+ i__1 = *n;
+#line 182 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< X(J) = XX(J) >*/
+#line 183 ""
+ x[j] = xx[j];
+/*< 260 CONTINUE >*/
+#line 184 ""
+/* L260: */
+#line 184 ""
+ }
+/*< IF ( Z .EQ. LIM ) RETURN >*/
+#line 185 ""
+ if (*z__ == lim) {
+#line 185 ""
+ return 0;
+#line 185 ""
+ }
+/*< 270 IF ( XX(N) .EQ. 0 ) GO TO 280 >*/
+#line 186 ""
+L270:
+#line 186 ""
+ if (xx[*n] == 0) {
+#line 186 ""
+ goto L280;
+#line 186 ""
+ }
+/*< XX(N) = 0 >*/
+#line 187 ""
+ xx[*n] = 0;
+/*< CH = CH + W(N) >*/
+#line 188 ""
+ ch += w[*n];
+/*< PROFIT = PROFIT - P(N) >*/
+#line 189 ""
+ profit -= p[*n];
+/* BACKTRACK. */
+/*< 280 NN = II - 1 >*/
+#line 191 ""
+L280:
+#line 191 ""
+ nn = ii - 1;
+/*< IF ( NN .EQ. 0 ) RETURN >*/
+#line 192 ""
+ if (nn == 0) {
+#line 192 ""
+ return 0;
+#line 192 ""
+ }
+/*< DO 290 J=1,NN >*/
+#line 193 ""
+ i__1 = nn;
+#line 193 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< KK = II - J >*/
+#line 194 ""
+ kk = ii - j;
+/*< IF ( XX(KK) .EQ. 1 ) GO TO 300 >*/
+#line 195 ""
+ if (xx[kk] == 1) {
+#line 195 ""
+ goto L300;
+#line 195 ""
+ }
+/*< 290 CONTINUE >*/
+#line 196 ""
+/* L290: */
+#line 196 ""
+ }
+/*< RETURN >*/
+#line 197 ""
+ return 0;
+/*< 300 R = CH >*/
+#line 198 ""
+L300:
+#line 198 ""
+ r__ = ch;
+/*< CH = CH + W(KK) >*/
+#line 199 ""
+ ch += w[kk];
+/*< PROFIT = PROFIT - P(KK) >*/
+#line 200 ""
+ profit -= p[kk];
+/*< XX(KK) = 0 >*/
+#line 201 ""
+ xx[kk] = 0;
+/*< IF ( R .LT. MIN(KK) ) GO TO 310 >*/
+#line 202 ""
+ if (r__ < min__[kk]) {
+#line 202 ""
+ goto L310;
+#line 202 ""
+ }
+/*< II = KK + 1 >*/
+#line 203 ""
+ ii = kk + 1;
+/*< GO TO 80 >*/
+#line 204 ""
+ goto L80;
+/*< 310 NN = KK + 1 >*/
+#line 205 ""
+L310:
+#line 205 ""
+ nn = kk + 1;
+/*< II = KK >*/
+#line 206 ""
+ ii = kk;
+/* TRY TO SUBSTITUTE THE NN-TH ITEM FOR THE KK-TH. */
+/*< 320 IF ( Z .GE. PROFIT + CH*P(NN)/W(NN) ) GO TO 280 >*/
+#line 208 ""
+L320:
+#line 208 ""
+ if (*z__ >= profit + ch * p[nn] / w[nn]) {
+#line 208 ""
+ goto L280;
+#line 208 ""
+ }
+/*< DIFF = W(NN) - W(KK) >*/
+#line 209 ""
+ diff = w[nn] - w[kk];
+/*< IF ( DIFF ) 370, 330, 340 >*/
+#line 210 ""
+ if (diff < 0) {
+#line 210 ""
+ goto L370;
+#line 210 ""
+ } else if (diff == 0) {
+#line 210 ""
+ goto L330;
+#line 210 ""
+ } else {
+#line 210 ""
+ goto L340;
+#line 210 ""
+ }
+/*< 330 NN = NN + 1 >*/
+#line 211 ""
+L330:
+#line 211 ""
+ ++nn;
+/*< GO TO 320 >*/
+#line 212 ""
+ goto L320;
+/*< 340 IF ( DIFF .GT. R ) GO TO 330 >*/
+#line 213 ""
+L340:
+#line 213 ""
+ if (diff > r__) {
+#line 213 ""
+ goto L330;
+#line 213 ""
+ }
+/*< IF ( Z .GE. PROFIT + P(NN) ) GO TO 330 >*/
+#line 214 ""
+ if (*z__ >= profit + p[nn]) {
+#line 214 ""
+ goto L330;
+#line 214 ""
+ }
+/*< Z = PROFIT + P(NN) >*/
+#line 215 ""
+ *z__ = profit + p[nn];
+/*< DO 350 J=1,KK >*/
+#line 216 ""
+ i__1 = kk;
+#line 216 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< X(J) = XX(J) >*/
+#line 217 ""
+ x[j] = xx[j];
+/*< 350 CONTINUE >*/
+#line 218 ""
+/* L350: */
+#line 218 ""
+ }
+/*< JJ = KK + 1 >*/
+#line 219 ""
+ jj = kk + 1;
+/*< DO 360 J=JJ,N >*/
+#line 220 ""
+ i__1 = *n;
+#line 220 ""
+ for (j = jj; j <= i__1; ++j) {
+/*< X(J) = 0 >*/
+#line 221 ""
+ x[j] = 0;
+/*< 360 CONTINUE >*/
+#line 222 ""
+/* L360: */
+#line 222 ""
+ }
+/*< X(NN) = 1 >*/
+#line 223 ""
+ x[nn] = 1;
+/*< IF ( Z .EQ. LIM ) RETURN >*/
+#line 224 ""
+ if (*z__ == lim) {
+#line 224 ""
+ return 0;
+#line 224 ""
+ }
+/*< R = R - DIFF >*/
+#line 225 ""
+ r__ -= diff;
+/*< KK = NN >*/
+#line 226 ""
+ kk = nn;
+/*< NN = NN + 1 >*/
+#line 227 ""
+ ++nn;
+/*< GO TO 320 >*/
+#line 228 ""
+ goto L320;
+/*< 370 T = R - DIFF >*/
+#line 229 ""
+L370:
+#line 229 ""
+ t = r__ - diff;
+/*< IF ( T .LT. MIN(NN) ) GO TO 330 >*/
+#line 230 ""
+ if (t < min__[nn]) {
+#line 230 ""
+ goto L330;
+#line 230 ""
+ }
+/*< IF ( Z .GE. PROFIT + P(NN) + T*P(NN+1)/W(NN+1)) GO TO 280 >*/
+#line 231 ""
+ if (*z__ >= profit + p[nn] + t * p[nn + 1] / w[nn + 1]) {
+#line 231 ""
+ goto L280;
+#line 231 ""
+ }
+/*< CH = CH - W(NN) >*/
+#line 232 ""
+ ch -= w[nn];
+/*< PROFIT = PROFIT + P(NN) >*/
+#line 233 ""
+ profit += p[nn];
+/*< XX(NN) = 1 >*/
+#line 234 ""
+ xx[nn] = 1;
+/*< II = NN + 1 >*/
+#line 235 ""
+ ii = nn + 1;
+/*< WSIGN(NN) = W(NN) >*/
+#line 236 ""
+ wsign[nn] = w[nn];
+/*< PSIGN(NN) = P(NN) >*/
+#line 237 ""
+ psign[nn] = p[nn];
+/*< ZSIGN(NN) = II >*/
+#line 238 ""
+ zsign[nn] = ii;
+/*< N1 = NN + 1 >*/
+#line 239 ""
+ n1 = nn + 1;
+/*< DO 380 J=N1,LOLD >*/
+#line 240 ""
+ i__1 = lold;
+#line 240 ""
+ for (j = n1; j <= i__1; ++j) {
+/*< WSIGN(J) = 0 >*/
+#line 241 ""
+ wsign[j] = 0;
+/*< PSIGN(J) = 0 >*/
+#line 242 ""
+ psign[j] = 0;
+/*< ZSIGN(J) = J >*/
+#line 243 ""
+ zsign[j] = j;
+/*< 380 CONTINUE >*/
+#line 244 ""
+/* L380: */
+#line 244 ""
+ }
+/*< LOLD = NN >*/
+#line 245 ""
+ lold = nn;
+/*< GO TO 80 >*/
+#line 246 ""
+ goto L80;
+/*< END >*/
+} /* mt1_ */
+
+/*< SUBROUTINE CHMT1(N,P,W,C,Z,JDIM) >*/
+#if 1 /* by mao */
+static
+#endif
+/* Subroutine */ int chmt1_(integer *n, integer *p, integer *w, integer *c__,
+ integer *z__, integer *jdim)
+{
+ /* System generated locals */
+ integer i__1;
+
+ /* Local variables */
+ static integer j;
+ static real r__, rr;
+ static integer jsw;
+
+
+/* CHECK THE INPUT DATA. */
+
+/*< INTEGER P(JDIM),W(JDIM),C,Z >*/
+/*< IF ( N .GE. 2 .AND. N .LE. JDIM - 1 ) GO TO 10 >*/
+#line 253 ""
+ /* Parameter adjustments */
+#line 253 ""
+ --w;
+#line 253 ""
+ --p;
+#line 253 ""
+
+#line 253 ""
+ /* Function Body */
+#line 253 ""
+ if (*n >= 2 && *n <= *jdim - 1) {
+#line 253 ""
+ goto L10;
+#line 253 ""
+ }
+/*< Z = - 1 >*/
+#line 254 ""
+ *z__ = -1;
+/*< RETURN >*/
+#line 255 ""
+ return 0;
+/*< 10 IF ( C .GT. 0 ) GO TO 30 >*/
+#line 256 ""
+L10:
+#line 256 ""
+ if (*c__ > 0) {
+#line 256 ""
+ goto L30;
+#line 256 ""
+ }
+/*< 20 Z = - 2 >*/
+#line 257 ""
+L20:
+#line 257 ""
+ *z__ = -2;
+/*< RETURN >*/
+#line 258 ""
+ return 0;
+/*< 30 JSW = 0 >*/
+#line 259 ""
+L30:
+#line 259 ""
+ jsw = 0;
+/*< RR = FLOAT(P(1))/FLOAT(W(1)) >*/
+#line 260 ""
+ rr = (real) p[1] / (real) w[1];
+/*< DO 50 J=1,N >*/
+#line 261 ""
+ i__1 = *n;
+#line 261 ""
+ for (j = 1; j <= i__1; ++j) {
+/*< R = RR >*/
+#line 262 ""
+ r__ = rr;
+/*< IF ( P(J) .LE. 0 ) GO TO 20 >*/
+#line 263 ""
+ if (p[j] <= 0) {
+#line 263 ""
+ goto L20;
+#line 263 ""
+ }
+/*< IF ( W(J) .LE. 0 ) GO TO 20 >*/
+#line 264 ""
+ if (w[j] <= 0) {
+#line 264 ""
+ goto L20;
+#line 264 ""
+ }
+/*< JSW = JSW + W(J) >*/
+#line 265 ""
+ jsw += w[j];
+/*< IF ( W(J) .LE. C ) GO TO 40 >*/
+#line 266 ""
+ if (w[j] <= *c__) {
+#line 266 ""
+ goto L40;
+#line 266 ""
+ }
+/*< Z = - 3 >*/
+#line 267 ""
+ *z__ = -3;
+/*< RETURN >*/
+#line 268 ""
+ return 0;
+/*< 40 RR = FLOAT(P(J))/FLOAT(W(J)) >*/
+#line 269 ""
+L40:
+#line 269 ""
+ rr = (real) p[j] / (real) w[j];
+/*< IF ( RR .LE. R ) GO TO 50 >*/
+#line 270 ""
+ if (rr <= r__) {
+#line 270 ""
+ goto L50;
+#line 270 ""
+ }
+/*< Z = - 5 >*/
+#line 271 ""
+ *z__ = -5;
+/*< RETURN >*/
+#line 272 ""
+ return 0;
+/*< 50 CONTINUE >*/
+#line 273 ""
+L50:
+#line 273 ""
+ ;
+#line 273 ""
+ }
+/*< IF ( JSW .GT. C ) RETURN >*/
+#line 274 ""
+ if (jsw > *c__) {
+#line 274 ""
+ return 0;
+#line 274 ""
+ }
+/*< Z = - 4 >*/
+#line 275 ""
+ *z__ = -4;
+/*< RETURN >*/
+#line 276 ""
+ return 0;
+/*< END >*/
+} /* chmt1_ */
+
+#if 1 /* by mao */
+int mt1(int n, int p[], int w[], int c, int x[], int jck, int xx[],
+ int min[], int psign[], int wsign[], int zsign[])
+{ /* solve 0-1 knapsack problem */
+ int z, jdim = n+1, j, s1, s2;
+ mt1_(&n, &p[1], &w[1], &c, &z, &x[1], &jdim, &jck, &xx[1],
+ &min[1], &psign[1], &wsign[1], &zsign[1]);
+ /* check solution found */
+ s1 = s2 = 0;
+ for (j = 1; j <= n; j++)
+ { xassert(x[j] == 0 || x[j] == 1);
+ if (x[j])
+ s1 += p[j], s2 += w[j];
+ }
+ xassert(s1 == z);
+ xassert(s2 <= c);
+ return z;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mt1.f b/test/monniaux/glpk-4.65/src/misc/mt1.f
new file mode 100644
index 00000000..82cc4a1b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mt1.f
@@ -0,0 +1,277 @@
+ SUBROUTINE MT1(N,P,W,C,Z,X,JDIM,JCK,XX,MIN,PSIGN,WSIGN,ZSIGN)
+C
+C THIS SUBROUTINE SOLVES THE 0-1 SINGLE KNAPSACK PROBLEM
+C
+C MAXIMIZE Z = P(1)*X(1) + ... + P(N)*X(N)
+C
+C SUBJECT TO: W(1)*X(1) + ... + W(N)*X(N) .LE. C ,
+C X(J) = 0 OR 1 FOR J=1,...,N.
+C
+C THE PROGRAM IS INCLUDED IN THE VOLUME
+C S. MARTELLO, P. TOTH, "KNAPSACK PROBLEMS: ALGORITHMS
+C AND COMPUTER IMPLEMENTATIONS", JOHN WILEY, 1990
+C AND IMPLEMENTS THE BRANCH-AND-BOUND ALGORITHM DESCRIBED IN
+C SECTION 2.5.2 .
+C THE PROGRAM DERIVES FROM AN EARLIER CODE PRESENTED IN
+C S. MARTELLO, P. TOTH, "ALGORITHM FOR THE SOLUTION OF THE 0-1 SINGLE
+C KNAPSACK PROBLEM", COMPUTING, 1978.
+C
+C THE INPUT PROBLEM MUST SATISFY THE CONDITIONS
+C
+C 1) 2 .LE. N .LE. JDIM - 1 ;
+C 2) P(J), W(J), C POSITIVE INTEGERS;
+C 3) MAX (W(J)) .LE. C ;
+C 4) W(1) + ... + W(N) .GT. C ;
+C 5) P(J)/W(J) .GE. P(J+1)/W(J+1) FOR J=1,...,N-1.
+C
+C MT1 CALLS 1 PROCEDURE: CHMT1.
+C
+C THE PROGRAM IS COMPLETELY SELF-CONTAINED AND COMMUNICATION TO IT IS
+C ACHIEVED SOLELY THROUGH THE PARAMETER LIST OF MT1.
+C NO MACHINE-DEPENDENT CONSTANT IS USED.
+C THE PROGRAM IS WRITTEN IN 1967 AMERICAN NATIONAL STANDARD FORTRAN
+C AND IS ACCEPTED BY THE PFORT VERIFIER (PFORT IS THE PORTABLE
+C SUBSET OF ANSI DEFINED BY THE ASSOCIATION FOR COMPUTING MACHINERY).
+C THE PROGRAM HAS BEEN TESTED ON A DIGITAL VAX 11/780 AND AN H.P.
+C 9000/840.
+C
+C MT1 NEEDS 8 ARRAYS ( P , W , X , XX , MIN , PSIGN , WSIGN
+C AND ZSIGN ) OF LENGTH AT LEAST N + 1 .
+C
+C MEANING OF THE INPUT PARAMETERS:
+C N = NUMBER OF ITEMS;
+C P(J) = PROFIT OF ITEM J (J=1,...,N);
+C W(J) = WEIGHT OF ITEM J (J=1,...,N);
+C C = CAPACITY OF THE KNAPSACK;
+C JDIM = DIMENSION OF THE 8 ARRAYS;
+C JCK = 1 IF CHECK ON THE INPUT DATA IS DESIRED,
+C = 0 OTHERWISE.
+C
+C MEANING OF THE OUTPUT PARAMETERS:
+C Z = VALUE OF THE OPTIMAL SOLUTION IF Z .GT. 0 ,
+C = ERROR IN THE INPUT DATA (WHEN JCK=1) IF Z .LT. 0 : CONDI-
+C TION - Z IS VIOLATED;
+C X(J) = 1 IF ITEM J IS IN THE OPTIMAL SOLUTION,
+C = 0 OTHERWISE.
+C
+C ARRAYS XX, MIN, PSIGN, WSIGN AND ZSIGN ARE DUMMY.
+C
+C ALL THE PARAMETERS ARE INTEGER. ON RETURN OF MT1 ALL THE INPUT
+C PARAMETERS ARE UNCHANGED.
+C
+ INTEGER P(JDIM),W(JDIM),X(JDIM),C,Z
+ INTEGER XX(JDIM),MIN(JDIM),PSIGN(JDIM),WSIGN(JDIM),ZSIGN(JDIM)
+ INTEGER CH,CHS,DIFF,PROFIT,R,T
+ Z = 0
+ IF ( JCK .EQ. 1 ) CALL CHMT1(N,P,W,C,Z,JDIM)
+ IF ( Z .LT. 0 ) RETURN
+C INITIALIZE.
+ CH = C
+ IP = 0
+ CHS = CH
+ DO 10 LL=1,N
+ IF ( W(LL) .GT. CHS ) GO TO 20
+ IP = IP + P(LL)
+ CHS = CHS - W(LL)
+ 10 CONTINUE
+ 20 LL = LL - 1
+ IF ( CHS .EQ. 0 ) GO TO 50
+ P(N+1) = 0
+ W(N+1) = CH + 1
+ LIM = IP + CHS*P(LL+2)/W(LL+2)
+ A = W(LL+1) - CHS
+ B = IP + P(LL+1)
+ LIM1 = B - A*FLOAT(P(LL))/FLOAT(W(LL))
+ IF ( LIM1 .GT. LIM ) LIM = LIM1
+ MINK = CH + 1
+ MIN(N) = MINK
+ DO 30 J=2,N
+ KK = N + 2 - J
+ IF ( W(KK) .LT. MINK ) MINK = W(KK)
+ MIN(KK-1) = MINK
+ 30 CONTINUE
+ DO 40 J=1,N
+ XX(J) = 0
+ 40 CONTINUE
+ Z = 0
+ PROFIT = 0
+ LOLD = N
+ II = 1
+ GO TO 170
+ 50 Z = IP
+ DO 60 J=1,LL
+ X(J) = 1
+ 60 CONTINUE
+ NN = LL + 1
+ DO 70 J=NN,N
+ X(J) = 0
+ 70 CONTINUE
+ RETURN
+C TRY TO INSERT THE II-TH ITEM INTO THE CURRENT SOLUTION.
+ 80 IF ( W(II) .LE. CH ) GO TO 90
+ II1 = II + 1
+ IF ( Z .GE. CH*P(II1)/W(II1) + PROFIT ) GO TO 280
+ II = II1
+ GO TO 80
+C BUILD A NEW CURRENT SOLUTION.
+ 90 IP = PSIGN(II)
+ CHS = CH - WSIGN(II)
+ IN = ZSIGN(II)
+ DO 100 LL=IN,N
+ IF ( W(LL) .GT. CHS ) GO TO 160
+ IP = IP + P(LL)
+ CHS = CHS - W(LL)
+ 100 CONTINUE
+ LL = N
+ 110 IF ( Z .GE. IP + PROFIT ) GO TO 280
+ Z = IP + PROFIT
+ NN = II - 1
+ DO 120 J=1,NN
+ X(J) = XX(J)
+ 120 CONTINUE
+ DO 130 J=II,LL
+ X(J) = 1
+ 130 CONTINUE
+ IF ( LL .EQ. N ) GO TO 150
+ NN = LL + 1
+ DO 140 J=NN,N
+ X(J) = 0
+ 140 CONTINUE
+ 150 IF ( Z .NE. LIM ) GO TO 280
+ RETURN
+ 160 IU = CHS*P(LL)/W(LL)
+ LL = LL - 1
+ IF ( IU .EQ. 0 ) GO TO 110
+ IF ( Z .GE. PROFIT + IP + IU ) GO TO 280
+C SAVE THE CURRENT SOLUTION.
+ 170 WSIGN(II) = CH - CHS
+ PSIGN(II) = IP
+ ZSIGN(II) = LL + 1
+ XX(II) = 1
+ NN = LL - 1
+ IF ( NN .LT. II) GO TO 190
+ DO 180 J=II,NN
+ WSIGN(J+1) = WSIGN(J) - W(J)
+ PSIGN(J+1) = PSIGN(J) - P(J)
+ ZSIGN(J+1) = LL + 1
+ XX(J+1) = 1
+ 180 CONTINUE
+ 190 J1 = LL + 1
+ DO 200 J=J1,LOLD
+ WSIGN(J) = 0
+ PSIGN(J) = 0
+ ZSIGN(J) = J
+ 200 CONTINUE
+ LOLD = LL
+ CH = CHS
+ PROFIT = PROFIT + IP
+ IF ( LL - (N - 2) ) 240, 220, 210
+ 210 II = N
+ GO TO 250
+ 220 IF ( CH .LT. W(N) ) GO TO 230
+ CH = CH - W(N)
+ PROFIT = PROFIT + P(N)
+ XX(N) = 1
+ 230 II = N - 1
+ GO TO 250
+ 240 II = LL + 2
+ IF ( CH .GE. MIN(II-1) ) GO TO 80
+C SAVE THE CURRENT OPTIMAL SOLUTION.
+ 250 IF ( Z .GE. PROFIT ) GO TO 270
+ Z = PROFIT
+ DO 260 J=1,N
+ X(J) = XX(J)
+ 260 CONTINUE
+ IF ( Z .EQ. LIM ) RETURN
+ 270 IF ( XX(N) .EQ. 0 ) GO TO 280
+ XX(N) = 0
+ CH = CH + W(N)
+ PROFIT = PROFIT - P(N)
+C BACKTRACK.
+ 280 NN = II - 1
+ IF ( NN .EQ. 0 ) RETURN
+ DO 290 J=1,NN
+ KK = II - J
+ IF ( XX(KK) .EQ. 1 ) GO TO 300
+ 290 CONTINUE
+ RETURN
+ 300 R = CH
+ CH = CH + W(KK)
+ PROFIT = PROFIT - P(KK)
+ XX(KK) = 0
+ IF ( R .LT. MIN(KK) ) GO TO 310
+ II = KK + 1
+ GO TO 80
+ 310 NN = KK + 1
+ II = KK
+C TRY TO SUBSTITUTE THE NN-TH ITEM FOR THE KK-TH.
+ 320 IF ( Z .GE. PROFIT + CH*P(NN)/W(NN) ) GO TO 280
+ DIFF = W(NN) - W(KK)
+ IF ( DIFF ) 370, 330, 340
+ 330 NN = NN + 1
+ GO TO 320
+ 340 IF ( DIFF .GT. R ) GO TO 330
+ IF ( Z .GE. PROFIT + P(NN) ) GO TO 330
+ Z = PROFIT + P(NN)
+ DO 350 J=1,KK
+ X(J) = XX(J)
+ 350 CONTINUE
+ JJ = KK + 1
+ DO 360 J=JJ,N
+ X(J) = 0
+ 360 CONTINUE
+ X(NN) = 1
+ IF ( Z .EQ. LIM ) RETURN
+ R = R - DIFF
+ KK = NN
+ NN = NN + 1
+ GO TO 320
+ 370 T = R - DIFF
+ IF ( T .LT. MIN(NN) ) GO TO 330
+ IF ( Z .GE. PROFIT + P(NN) + T*P(NN+1)/W(NN+1)) GO TO 280
+ CH = CH - W(NN)
+ PROFIT = PROFIT + P(NN)
+ XX(NN) = 1
+ II = NN + 1
+ WSIGN(NN) = W(NN)
+ PSIGN(NN) = P(NN)
+ ZSIGN(NN) = II
+ N1 = NN + 1
+ DO 380 J=N1,LOLD
+ WSIGN(J) = 0
+ PSIGN(J) = 0
+ ZSIGN(J) = J
+ 380 CONTINUE
+ LOLD = NN
+ GO TO 80
+ END
+ SUBROUTINE CHMT1(N,P,W,C,Z,JDIM)
+C
+C CHECK THE INPUT DATA.
+C
+ INTEGER P(JDIM),W(JDIM),C,Z
+ IF ( N .GE. 2 .AND. N .LE. JDIM - 1 ) GO TO 10
+ Z = - 1
+ RETURN
+ 10 IF ( C .GT. 0 ) GO TO 30
+ 20 Z = - 2
+ RETURN
+ 30 JSW = 0
+ RR = FLOAT(P(1))/FLOAT(W(1))
+ DO 50 J=1,N
+ R = RR
+ IF ( P(J) .LE. 0 ) GO TO 20
+ IF ( W(J) .LE. 0 ) GO TO 20
+ JSW = JSW + W(J)
+ IF ( W(J) .LE. C ) GO TO 40
+ Z = - 3
+ RETURN
+ 40 RR = FLOAT(P(J))/FLOAT(W(J))
+ IF ( RR .LE. R ) GO TO 50
+ Z = - 5
+ RETURN
+ 50 CONTINUE
+ IF ( JSW .GT. C ) RETURN
+ Z = - 4
+ RETURN
+ END
diff --git a/test/monniaux/glpk-4.65/src/misc/mt1.h b/test/monniaux/glpk-4.65/src/misc/mt1.h
new file mode 100644
index 00000000..cceebba9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mt1.h
@@ -0,0 +1,34 @@
+/* mt1.h (0-1 knapsack problem; Martello & Toth algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2017-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MT1_H
+#define MT1_H
+
+#define mt1 _glp_mt1
+int mt1(int n, int p[], int w[], int c, int x[], int jck, int xx[],
+ int min[], int psign[], int wsign[], int zsign[]);
+/* solve 0-1 single knapsack problem */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mygmp.c b/test/monniaux/glpk-4.65/src/misc/mygmp.c
new file mode 100644
index 00000000..89d053ae
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mygmp.c
@@ -0,0 +1,1162 @@
+/* mygmp.c (integer and rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mygmp.h"
+
+#ifdef HAVE_GMP /* use GNU MP library */
+
+/* nothing is needed */
+
+#else /* use GLPK MP module */
+
+#include "bignum.h"
+#include "dmp.h"
+#include "env.h"
+
+#define gmp_pool env->gmp_pool
+#define gmp_size env->gmp_size
+#define gmp_work env->gmp_work
+
+void *gmp_get_atom(int size)
+{ ENV *env = get_env_ptr();
+ if (gmp_pool == NULL)
+ gmp_pool = dmp_create_pool();
+ return dmp_get_atom(gmp_pool, size);
+}
+
+void gmp_free_atom(void *ptr, int size)
+{ ENV *env = get_env_ptr();
+ xassert(gmp_pool != NULL);
+ dmp_free_atom(gmp_pool, ptr, size);
+ return;
+}
+
+int gmp_pool_count(void)
+{ ENV *env = get_env_ptr();
+ if (gmp_pool == NULL)
+ return 0;
+ else
+ return dmp_in_use(gmp_pool);
+}
+
+unsigned short *gmp_get_work(int size)
+{ ENV *env = get_env_ptr();
+ xassert(size > 0);
+ if (gmp_size < size)
+ { if (gmp_size == 0)
+ { xassert(gmp_work == NULL);
+ gmp_size = 100;
+ }
+ else
+ { xassert(gmp_work != NULL);
+ xfree(gmp_work);
+ }
+ while (gmp_size < size)
+ gmp_size += gmp_size;
+ gmp_work = xcalloc(gmp_size, sizeof(unsigned short));
+ }
+ return gmp_work;
+}
+
+void gmp_free_mem(void)
+{ ENV *env = get_env_ptr();
+ if (gmp_pool != NULL)
+ dmp_delete_pool(gmp_pool);
+ if (gmp_work != NULL)
+ xfree(gmp_work);
+ gmp_pool = NULL;
+ gmp_size = 0;
+ gmp_work = NULL;
+ return;
+}
+
+/*--------------------------------------------------------------------*/
+
+mpz_t _mpz_init(void)
+{ /* initialize x and set its value to 0 */
+ mpz_t x;
+ x = gmp_get_atom(sizeof(struct mpz));
+ x->val = 0;
+ x->ptr = NULL;
+ return x;
+}
+
+void mpz_clear(mpz_t x)
+{ /* free the space occupied by x */
+ mpz_set_si(x, 0);
+ xassert(x->ptr == NULL);
+ /* free the number descriptor */
+ gmp_free_atom(x, sizeof(struct mpz));
+ return;
+}
+
+void mpz_set(mpz_t z, mpz_t x)
+{ /* set the value of z from x */
+ struct mpz_seg *e, *ee, *es;
+ if (z != x)
+ { mpz_set_si(z, 0);
+ z->val = x->val;
+ xassert(z->ptr == NULL);
+ for (e = x->ptr, es = NULL; e != NULL; e = e->next)
+ { ee = gmp_get_atom(sizeof(struct mpz_seg));
+ memcpy(ee->d, e->d, 12);
+ ee->next = NULL;
+ if (z->ptr == NULL)
+ z->ptr = ee;
+ else
+ es->next = ee;
+ es = ee;
+ }
+ }
+ return;
+}
+
+void mpz_set_si(mpz_t x, int val)
+{ /* set the value of x to val */
+ struct mpz_seg *e;
+ /* free existing segments, if any */
+ while (x->ptr != NULL)
+ { e = x->ptr;
+ x->ptr = e->next;
+ gmp_free_atom(e, sizeof(struct mpz_seg));
+ }
+ /* assign new value */
+ if (val == 0x80000000)
+ { /* long format is needed */
+ x->val = -1;
+ x->ptr = e = gmp_get_atom(sizeof(struct mpz_seg));
+ memset(e->d, 0, 12);
+ e->d[1] = 0x8000;
+ e->next = NULL;
+ }
+ else
+ { /* short format is enough */
+ x->val = val;
+ }
+ return;
+}
+
+double mpz_get_d(mpz_t x)
+{ /* convert x to a double, truncating if necessary */
+ struct mpz_seg *e;
+ int j;
+ double val, deg;
+ if (x->ptr == NULL)
+ val = (double)x->val;
+ else
+ { xassert(x->val != 0);
+ val = 0.0;
+ deg = 1.0;
+ for (e = x->ptr; e != NULL; e = e->next)
+ { for (j = 0; j <= 5; j++)
+ { val += deg * (double)((int)e->d[j]);
+ deg *= 65536.0;
+ }
+ }
+ if (x->val < 0)
+ val = - val;
+ }
+ return val;
+}
+
+double mpz_get_d_2exp(int *exp, mpz_t x)
+{ /* convert x to a double, truncating if necessary (i.e. rounding
+ * towards zero), and returning the exponent separately;
+ * the return value is in the range 0.5 <= |d| < 1 and the
+ * exponent is stored to *exp; d*2^exp is the (truncated) x value;
+ * if x is zero, the return is 0.0 and 0 is stored to *exp;
+ * this is similar to the standard C frexp function */
+ struct mpz_seg *e;
+ int j, n, n1;
+ double val;
+ if (x->ptr == NULL)
+ val = (double)x->val, n = 0;
+ else
+ { xassert(x->val != 0);
+ val = 0.0, n = 0;
+ for (e = x->ptr; e != NULL; e = e->next)
+ { for (j = 0; j <= 5; j++)
+ { val += (double)((int)e->d[j]);
+ val /= 65536.0, n += 16;
+ }
+ }
+ if (x->val < 0)
+ val = - val;
+ }
+ val = frexp(val, &n1);
+ *exp = n + n1;
+ return val;
+}
+
+void mpz_swap(mpz_t x, mpz_t y)
+{ /* swap the values x and y efficiently */
+ int val;
+ void *ptr;
+ val = x->val, ptr = x->ptr;
+ x->val = y->val, x->ptr = y->ptr;
+ y->val = val, y->ptr = ptr;
+ return;
+}
+
+static void normalize(mpz_t x)
+{ /* normalize integer x that includes removing non-significant
+ * (leading) zeros and converting to short format, if possible */
+ struct mpz_seg *es, *e;
+ /* if the integer is in short format, it remains unchanged */
+ if (x->ptr == NULL)
+ { xassert(x->val != 0x80000000);
+ goto done;
+ }
+ xassert(x->val == +1 || x->val == -1);
+ /* find the last (most significant) non-zero segment */
+ es = NULL;
+ for (e = x->ptr; e != NULL; e = e->next)
+ { if (e->d[0] || e->d[1] || e->d[2] ||
+ e->d[3] || e->d[4] || e->d[5])
+ es = e;
+ }
+ /* if all segments contain zeros, the integer is zero */
+ if (es == NULL)
+ { mpz_set_si(x, 0);
+ goto done;
+ }
+ /* remove non-significant (leading) zero segments */
+ while (es->next != NULL)
+ { e = es->next;
+ es->next = e->next;
+ gmp_free_atom(e, sizeof(struct mpz_seg));
+ }
+ /* convert the integer to short format, if possible */
+ e = x->ptr;
+ if (e->next == NULL && e->d[1] <= 0x7FFF &&
+ !e->d[2] && !e->d[3] && !e->d[4] && !e->d[5])
+ { int val;
+ val = (int)e->d[0] + ((int)e->d[1] << 16);
+ if (x->val < 0)
+ val = - val;
+ mpz_set_si(x, val);
+ }
+done: return;
+}
+
+void mpz_add(mpz_t z, mpz_t x, mpz_t y)
+{ /* set z to x + y */
+ static struct mpz_seg zero = { { 0, 0, 0, 0, 0, 0 }, NULL };
+ struct mpz_seg dumx, dumy, *ex, *ey, *ez, *es, *ee;
+ int k, sx, sy, sz;
+ unsigned int t;
+ /* if [x] = 0 then [z] = [y] */
+ if (x->val == 0)
+ { xassert(x->ptr == NULL);
+ mpz_set(z, y);
+ goto done;
+ }
+ /* if [y] = 0 then [z] = [x] */
+ if (y->val == 0)
+ { xassert(y->ptr == NULL);
+ mpz_set(z, x);
+ goto done;
+ }
+ /* special case when both [x] and [y] are in short format */
+ if (x->ptr == NULL && y->ptr == NULL)
+ { int xval = x->val, yval = y->val, zval = x->val + y->val;
+ xassert(xval != 0x80000000 && yval != 0x80000000);
+ if (!(xval > 0 && yval > 0 && zval <= 0 ||
+ xval < 0 && yval < 0 && zval >= 0))
+ { mpz_set_si(z, zval);
+ goto done;
+ }
+ }
+ /* convert [x] to long format, if necessary */
+ if (x->ptr == NULL)
+ { xassert(x->val != 0x80000000);
+ if (x->val >= 0)
+ { sx = +1;
+ t = (unsigned int)(+ x->val);
+ }
+ else
+ { sx = -1;
+ t = (unsigned int)(- x->val);
+ }
+ ex = &dumx;
+ ex->d[0] = (unsigned short)t;
+ ex->d[1] = (unsigned short)(t >> 16);
+ ex->d[2] = ex->d[3] = ex->d[4] = ex->d[5] = 0;
+ ex->next = NULL;
+ }
+ else
+ { sx = x->val;
+ xassert(sx == +1 || sx == -1);
+ ex = x->ptr;
+ }
+ /* convert [y] to long format, if necessary */
+ if (y->ptr == NULL)
+ { xassert(y->val != 0x80000000);
+ if (y->val >= 0)
+ { sy = +1;
+ t = (unsigned int)(+ y->val);
+ }
+ else
+ { sy = -1;
+ t = (unsigned int)(- y->val);
+ }
+ ey = &dumy;
+ ey->d[0] = (unsigned short)t;
+ ey->d[1] = (unsigned short)(t >> 16);
+ ey->d[2] = ey->d[3] = ey->d[4] = ey->d[5] = 0;
+ ey->next = NULL;
+ }
+ else
+ { sy = y->val;
+ xassert(sy == +1 || sy == -1);
+ ey = y->ptr;
+ }
+ /* main fragment */
+ sz = sx;
+ ez = es = NULL;
+ if (sx > 0 && sy > 0 || sx < 0 && sy < 0)
+ { /* [x] and [y] have identical signs -- addition */
+ t = 0;
+ for (; ex || ey; ex = ex->next, ey = ey->next)
+ { if (ex == NULL)
+ ex = &zero;
+ if (ey == NULL)
+ ey = &zero;
+ ee = gmp_get_atom(sizeof(struct mpz_seg));
+ for (k = 0; k <= 5; k++)
+ { t += (unsigned int)ex->d[k];
+ t += (unsigned int)ey->d[k];
+ ee->d[k] = (unsigned short)t;
+ t >>= 16;
+ }
+ ee->next = NULL;
+ if (ez == NULL)
+ ez = ee;
+ else
+ es->next = ee;
+ es = ee;
+ }
+ if (t)
+ { /* overflow -- one extra digit is needed */
+ ee = gmp_get_atom(sizeof(struct mpz_seg));
+ ee->d[0] = 1;
+ ee->d[1] = ee->d[2] = ee->d[3] = ee->d[4] = ee->d[5] = 0;
+ ee->next = NULL;
+ xassert(es != NULL);
+ es->next = ee;
+ }
+ }
+ else
+ { /* [x] and [y] have different signs -- subtraction */
+ t = 1;
+ for (; ex || ey; ex = ex->next, ey = ey->next)
+ { if (ex == NULL)
+ ex = &zero;
+ if (ey == NULL)
+ ey = &zero;
+ ee = gmp_get_atom(sizeof(struct mpz_seg));
+ for (k = 0; k <= 5; k++)
+ { t += (unsigned int)ex->d[k];
+ t += (0xFFFF - (unsigned int)ey->d[k]);
+ ee->d[k] = (unsigned short)t;
+ t >>= 16;
+ }
+ ee->next = NULL;
+ if (ez == NULL)
+ ez = ee;
+ else
+ es->next = ee;
+ es = ee;
+ }
+ if (!t)
+ { /* |[x]| < |[y]| -- result in complement coding */
+ sz = - sz;
+ t = 1;
+ for (ee = ez; ee != NULL; ee = ee->next)
+ { for (k = 0; k <= 5; k++)
+ { t += (0xFFFF - (unsigned int)ee->d[k]);
+ ee->d[k] = (unsigned short)t;
+ t >>= 16;
+ }
+ }
+ }
+ }
+ /* contruct and normalize result */
+ mpz_set_si(z, 0);
+ z->val = sz;
+ z->ptr = ez;
+ normalize(z);
+done: return;
+}
+
+void mpz_sub(mpz_t z, mpz_t x, mpz_t y)
+{ /* set z to x - y */
+ if (x == y)
+ mpz_set_si(z, 0);
+ else
+ { y->val = - y->val;
+ mpz_add(z, x, y);
+ if (y != z)
+ y->val = - y->val;
+ }
+ return;
+}
+
+void mpz_mul(mpz_t z, mpz_t x, mpz_t y)
+{ /* set z to x * y */
+ struct mpz_seg dumx, dumy, *ex, *ey, *es, *e;
+ int sx, sy, k, nx, ny, n;
+ unsigned int t;
+ unsigned short *work, *wx, *wy;
+ /* if [x] = 0 then [z] = 0 */
+ if (x->val == 0)
+ { xassert(x->ptr == NULL);
+ mpz_set_si(z, 0);
+ goto done;
+ }
+ /* if [y] = 0 then [z] = 0 */
+ if (y->val == 0)
+ { xassert(y->ptr == NULL);
+ mpz_set_si(z, 0);
+ goto done;
+ }
+ /* special case when both [x] and [y] are in short format */
+ if (x->ptr == NULL && y->ptr == NULL)
+ { int xval = x->val, yval = y->val, sz = +1;
+ xassert(xval != 0x80000000 && yval != 0x80000000);
+ if (xval < 0)
+ xval = - xval, sz = - sz;
+ if (yval < 0)
+ yval = - yval, sz = - sz;
+ if (xval <= 0x7FFFFFFF / yval)
+ { mpz_set_si(z, sz * (xval * yval));
+ goto done;
+ }
+ }
+ /* convert [x] to long format, if necessary */
+ if (x->ptr == NULL)
+ { xassert(x->val != 0x80000000);
+ if (x->val >= 0)
+ { sx = +1;
+ t = (unsigned int)(+ x->val);
+ }
+ else
+ { sx = -1;
+ t = (unsigned int)(- x->val);
+ }
+ ex = &dumx;
+ ex->d[0] = (unsigned short)t;
+ ex->d[1] = (unsigned short)(t >> 16);
+ ex->d[2] = ex->d[3] = ex->d[4] = ex->d[5] = 0;
+ ex->next = NULL;
+ }
+ else
+ { sx = x->val;
+ xassert(sx == +1 || sx == -1);
+ ex = x->ptr;
+ }
+ /* convert [y] to long format, if necessary */
+ if (y->ptr == NULL)
+ { xassert(y->val != 0x80000000);
+ if (y->val >= 0)
+ { sy = +1;
+ t = (unsigned int)(+ y->val);
+ }
+ else
+ { sy = -1;
+ t = (unsigned int)(- y->val);
+ }
+ ey = &dumy;
+ ey->d[0] = (unsigned short)t;
+ ey->d[1] = (unsigned short)(t >> 16);
+ ey->d[2] = ey->d[3] = ey->d[4] = ey->d[5] = 0;
+ ey->next = NULL;
+ }
+ else
+ { sy = y->val;
+ xassert(sy == +1 || sy == -1);
+ ey = y->ptr;
+ }
+ /* determine the number of digits of [x] */
+ nx = n = 0;
+ for (e = ex; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++)
+ { n++;
+ if (e->d[k])
+ nx = n;
+ }
+ }
+ xassert(nx > 0);
+ /* determine the number of digits of [y] */
+ ny = n = 0;
+ for (e = ey; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++)
+ { n++;
+ if (e->d[k])
+ ny = n;
+ }
+ }
+ xassert(ny > 0);
+ /* we need working array containing at least nx+ny+ny places */
+ work = gmp_get_work(nx+ny+ny);
+ /* load digits of [x] */
+ wx = &work[0];
+ for (n = 0; n < nx; n++)
+ wx[ny+n] = 0;
+ for (n = 0, e = ex; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++, n++)
+ { if (e->d[k])
+ wx[ny+n] = e->d[k];
+ }
+ }
+ /* load digits of [y] */
+ wy = &work[nx+ny];
+ for (n = 0; n < ny; n++) wy[n] = 0;
+ for (n = 0, e = ey; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++, n++)
+ { if (e->d[k])
+ wy[n] = e->d[k];
+ }
+ }
+ /* compute [x] * [y] */
+ bigmul(nx, ny, wx, wy);
+ /* construct and normalize result */
+ mpz_set_si(z, 0);
+ z->val = sx * sy;
+ es = NULL;
+ k = 6;
+ for (n = 0; n < nx+ny; n++)
+ { if (k > 5)
+ { e = gmp_get_atom(sizeof(struct mpz_seg));
+ e->d[0] = e->d[1] = e->d[2] = 0;
+ e->d[3] = e->d[4] = e->d[5] = 0;
+ e->next = NULL;
+ if (z->ptr == NULL)
+ z->ptr = e;
+ else
+ es->next = e;
+ es = e;
+ k = 0;
+ }
+ es->d[k++] = wx[n];
+ }
+ normalize(z);
+done: return;
+}
+
+void mpz_neg(mpz_t z, mpz_t x)
+{ /* set z to 0 - x */
+ mpz_set(z, x);
+ z->val = - z->val;
+ return;
+}
+
+void mpz_abs(mpz_t z, mpz_t x)
+{ /* set z to the absolute value of x */
+ mpz_set(z, x);
+ if (z->val < 0)
+ z->val = - z->val;
+ return;
+}
+
+void mpz_div(mpz_t q, mpz_t r, mpz_t x, mpz_t y)
+{ /* divide x by y, forming quotient q and/or remainder r
+ * if q = NULL then quotient is not stored; if r = NULL then
+ * remainder is not stored
+ * the sign of quotient is determined as in algebra while the
+ * sign of remainder is the same as the sign of dividend:
+ * +26 : +7 = +3, remainder is +5
+ * -26 : +7 = -3, remainder is -5
+ * +26 : -7 = -3, remainder is +5
+ * -26 : -7 = +3, remainder is -5 */
+ struct mpz_seg dumx, dumy, *ex, *ey, *es, *e;
+ int sx, sy, k, nx, ny, n;
+ unsigned int t;
+ unsigned short *work, *wx, *wy;
+ /* divide by zero is not allowed */
+ if (y->val == 0)
+ { xassert(y->ptr == NULL);
+ xerror("mpz_div: divide by zero not allowed\n");
+ }
+ /* if [x] = 0 then [q] = [r] = 0 */
+ if (x->val == 0)
+ { xassert(x->ptr == NULL);
+ if (q != NULL)
+ mpz_set_si(q, 0);
+ if (r != NULL)
+ mpz_set_si(r, 0);
+ goto done;
+ }
+ /* special case when both [x] and [y] are in short format */
+ if (x->ptr == NULL && y->ptr == NULL)
+ { int xval = x->val, yval = y->val;
+ xassert(xval != 0x80000000 && yval != 0x80000000);
+ /* FIXME: use div function */
+ if (q != NULL)
+ mpz_set_si(q, xval / yval);
+ if (r != NULL)
+ mpz_set_si(r, xval % yval);
+ goto done;
+ }
+ /* convert [x] to long format, if necessary */
+ if (x->ptr == NULL)
+ { xassert(x->val != 0x80000000);
+ if (x->val >= 0)
+ { sx = +1;
+ t = (unsigned int)(+ x->val);
+ }
+ else
+ { sx = -1;
+ t = (unsigned int)(- x->val);
+ }
+ ex = &dumx;
+ ex->d[0] = (unsigned short)t;
+ ex->d[1] = (unsigned short)(t >> 16);
+ ex->d[2] = ex->d[3] = ex->d[4] = ex->d[5] = 0;
+ ex->next = NULL;
+ }
+ else
+ { sx = x->val;
+ xassert(sx == +1 || sx == -1);
+ ex = x->ptr;
+ }
+ /* convert [y] to long format, if necessary */
+ if (y->ptr == NULL)
+ { xassert(y->val != 0x80000000);
+ if (y->val >= 0)
+ { sy = +1;
+ t = (unsigned int)(+ y->val);
+ }
+ else
+ { sy = -1;
+ t = (unsigned int)(- y->val);
+ }
+ ey = &dumy;
+ ey->d[0] = (unsigned short)t;
+ ey->d[1] = (unsigned short)(t >> 16);
+ ey->d[2] = ey->d[3] = ey->d[4] = ey->d[5] = 0;
+ ey->next = NULL;
+ }
+ else
+ { sy = y->val;
+ xassert(sy == +1 || sy == -1);
+ ey = y->ptr;
+ }
+ /* determine the number of digits of [x] */
+ nx = n = 0;
+ for (e = ex; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++)
+ { n++;
+ if (e->d[k])
+ nx = n;
+ }
+ }
+ xassert(nx > 0);
+ /* determine the number of digits of [y] */
+ ny = n = 0;
+ for (e = ey; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++)
+ { n++;
+ if (e->d[k])
+ ny = n;
+ }
+ }
+ xassert(ny > 0);
+ /* if nx < ny then [q] = 0 and [r] = [x] */
+ if (nx < ny)
+ { if (r != NULL)
+ mpz_set(r, x);
+ if (q != NULL)
+ mpz_set_si(q, 0);
+ goto done;
+ }
+ /* we need working array containing at least nx+ny+1 places */
+ work = gmp_get_work(nx+ny+1);
+ /* load digits of [x] */
+ wx = &work[0];
+ for (n = 0; n < nx; n++)
+ wx[n] = 0;
+ for (n = 0, e = ex; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++, n++)
+ if (e->d[k]) wx[n] = e->d[k];
+ }
+ /* load digits of [y] */
+ wy = &work[nx+1];
+ for (n = 0; n < ny; n++)
+ wy[n] = 0;
+ for (n = 0, e = ey; e != NULL; e = e->next)
+ { for (k = 0; k <= 5; k++, n++)
+ if (e->d[k]) wy[n] = e->d[k];
+ }
+ /* compute quotient and remainder */
+ xassert(wy[ny-1] != 0);
+ bigdiv(nx-ny, ny, wx, wy);
+ /* construct and normalize quotient */
+ if (q != NULL)
+ { mpz_set_si(q, 0);
+ q->val = sx * sy;
+ es = NULL;
+ k = 6;
+ for (n = ny; n <= nx; n++)
+ { if (k > 5)
+ { e = gmp_get_atom(sizeof(struct mpz_seg));
+ e->d[0] = e->d[1] = e->d[2] = 0;
+ e->d[3] = e->d[4] = e->d[5] = 0;
+ e->next = NULL;
+ if (q->ptr == NULL)
+ q->ptr = e;
+ else
+ es->next = e;
+ es = e;
+ k = 0;
+ }
+ es->d[k++] = wx[n];
+ }
+ normalize(q);
+ }
+ /* construct and normalize remainder */
+ if (r != NULL)
+ { mpz_set_si(r, 0);
+ r->val = sx;
+ es = NULL;
+ k = 6;
+ for (n = 0; n < ny; n++)
+ { if (k > 5)
+ { e = gmp_get_atom(sizeof(struct mpz_seg));
+ e->d[0] = e->d[1] = e->d[2] = 0;
+ e->d[3] = e->d[4] = e->d[5] = 0;
+ e->next = NULL;
+ if (r->ptr == NULL)
+ r->ptr = e;
+ else
+ es->next = e;
+ es = e;
+ k = 0;
+ }
+ es->d[k++] = wx[n];
+ }
+ normalize(r);
+ }
+done: return;
+}
+
+void mpz_gcd(mpz_t z, mpz_t x, mpz_t y)
+{ /* set z to the greatest common divisor of x and y */
+ /* in case of arbitrary integers GCD(x, y) = GCD(|x|, |y|), and,
+ * in particular, GCD(0, 0) = 0 */
+ mpz_t u, v, r;
+ mpz_init(u);
+ mpz_init(v);
+ mpz_init(r);
+ mpz_abs(u, x);
+ mpz_abs(v, y);
+ while (mpz_sgn(v))
+ { mpz_div(NULL, r, u, v);
+ mpz_set(u, v);
+ mpz_set(v, r);
+ }
+ mpz_set(z, u);
+ mpz_clear(u);
+ mpz_clear(v);
+ mpz_clear(r);
+ return;
+}
+
+int mpz_cmp(mpz_t x, mpz_t y)
+{ /* compare x and y; return a positive value if x > y, zero if
+ * x = y, or a nefative value if x < y */
+ static struct mpz_seg zero = { { 0, 0, 0, 0, 0, 0 }, NULL };
+ struct mpz_seg dumx, dumy, *ex, *ey;
+ int cc, sx, sy, k;
+ unsigned int t;
+ if (x == y)
+ { cc = 0;
+ goto done;
+ }
+ /* special case when both [x] and [y] are in short format */
+ if (x->ptr == NULL && y->ptr == NULL)
+ { int xval = x->val, yval = y->val;
+ xassert(xval != 0x80000000 && yval != 0x80000000);
+ cc = (xval > yval ? +1 : xval < yval ? -1 : 0);
+ goto done;
+ }
+ /* special case when [x] and [y] have different signs */
+ if (x->val > 0 && y->val <= 0 || x->val == 0 && y->val < 0)
+ { cc = +1;
+ goto done;
+ }
+ if (x->val < 0 && y->val >= 0 || x->val == 0 && y->val > 0)
+ { cc = -1;
+ goto done;
+ }
+ /* convert [x] to long format, if necessary */
+ if (x->ptr == NULL)
+ { xassert(x->val != 0x80000000);
+ if (x->val >= 0)
+ { sx = +1;
+ t = (unsigned int)(+ x->val);
+ }
+ else
+ { sx = -1;
+ t = (unsigned int)(- x->val);
+ }
+ ex = &dumx;
+ ex->d[0] = (unsigned short)t;
+ ex->d[1] = (unsigned short)(t >> 16);
+ ex->d[2] = ex->d[3] = ex->d[4] = ex->d[5] = 0;
+ ex->next = NULL;
+ }
+ else
+ { sx = x->val;
+ xassert(sx == +1 || sx == -1);
+ ex = x->ptr;
+ }
+ /* convert [y] to long format, if necessary */
+ if (y->ptr == NULL)
+ { xassert(y->val != 0x80000000);
+ if (y->val >= 0)
+ { sy = +1;
+ t = (unsigned int)(+ y->val);
+ }
+ else
+ { sy = -1;
+ t = (unsigned int)(- y->val);
+ }
+ ey = &dumy;
+ ey->d[0] = (unsigned short)t;
+ ey->d[1] = (unsigned short)(t >> 16);
+ ey->d[2] = ey->d[3] = ey->d[4] = ey->d[5] = 0;
+ ey->next = NULL;
+ }
+ else
+ { sy = y->val;
+ xassert(sy == +1 || sy == -1);
+ ey = y->ptr;
+ }
+ /* main fragment */
+ xassert(sx > 0 && sy > 0 || sx < 0 && sy < 0);
+ cc = 0;
+ for (; ex || ey; ex = ex->next, ey = ey->next)
+ { if (ex == NULL)
+ ex = &zero;
+ if (ey == NULL)
+ ey = &zero;
+ for (k = 0; k <= 5; k++)
+ { if (ex->d[k] > ey->d[k])
+ cc = +1;
+ if (ex->d[k] < ey->d[k])
+ cc = -1;
+ }
+ }
+ if (sx < 0) cc = - cc;
+done: return cc;
+}
+
+int mpz_sgn(mpz_t x)
+{ /* return +1 if x > 0, 0 if x = 0, and -1 if x < 0 */
+ int s;
+ s = (x->val > 0 ? +1 : x->val < 0 ? -1 : 0);
+ return s;
+}
+
+int mpz_out_str(void *_fp, int base, mpz_t x)
+{ /* output x on stream fp, as a string in given base; the base
+ * may vary from 2 to 36;
+ * return the number of bytes written, or if an error occurred,
+ * return 0 */
+ FILE *fp = _fp;
+ mpz_t b, y, r;
+ int n, j, nwr = 0;
+ unsigned char *d;
+ static char *set = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ";
+ if (!(2 <= base && base <= 36))
+ xerror("mpz_out_str: base = %d; invalid base\n", base);
+ mpz_init(b);
+ mpz_set_si(b, base);
+ mpz_init(y);
+ mpz_init(r);
+ /* determine the number of digits */
+ mpz_abs(y, x);
+ for (n = 0; mpz_sgn(y) != 0; n++)
+ mpz_div(y, NULL, y, b);
+ if (n == 0) n = 1;
+ /* compute the digits */
+ d = xmalloc(n);
+ mpz_abs(y, x);
+ for (j = 0; j < n; j++)
+ { mpz_div(y, r, y, b);
+ xassert(0 <= r->val && r->val < base && r->ptr == NULL);
+ d[j] = (unsigned char)r->val;
+ }
+ /* output the integer to the stream */
+ if (fp == NULL)
+ fp = stdout;
+ if (mpz_sgn(x) < 0)
+ fputc('-', fp), nwr++;
+ for (j = n-1; j >= 0; j--)
+ fputc(set[d[j]], fp), nwr++;
+ if (ferror(fp))
+ nwr = 0;
+ mpz_clear(b);
+ mpz_clear(y);
+ mpz_clear(r);
+ xfree(d);
+ return nwr;
+}
+
+/*--------------------------------------------------------------------*/
+
+mpq_t _mpq_init(void)
+{ /* initialize x, and set its value to 0/1 */
+ mpq_t x;
+ x = gmp_get_atom(sizeof(struct mpq));
+ x->p.val = 0;
+ x->p.ptr = NULL;
+ x->q.val = 1;
+ x->q.ptr = NULL;
+ return x;
+}
+
+void mpq_clear(mpq_t x)
+{ /* free the space occupied by x */
+ mpz_set_si(&x->p, 0);
+ xassert(x->p.ptr == NULL);
+ mpz_set_si(&x->q, 0);
+ xassert(x->q.ptr == NULL);
+ /* free the number descriptor */
+ gmp_free_atom(x, sizeof(struct mpq));
+ return;
+}
+
+void mpq_canonicalize(mpq_t x)
+{ /* remove any factors that are common to the numerator and
+ * denominator of x, and make the denominator positive */
+ mpz_t f;
+ xassert(x->q.val != 0);
+ if (x->q.val < 0)
+ { mpz_neg(&x->p, &x->p);
+ mpz_neg(&x->q, &x->q);
+ }
+ mpz_init(f);
+ mpz_gcd(f, &x->p, &x->q);
+ if (!(f->val == 1 && f->ptr == NULL))
+ { mpz_div(&x->p, NULL, &x->p, f);
+ mpz_div(&x->q, NULL, &x->q, f);
+ }
+ mpz_clear(f);
+ return;
+}
+
+void mpq_set(mpq_t z, mpq_t x)
+{ /* set the value of z from x */
+ if (z != x)
+ { mpz_set(&z->p, &x->p);
+ mpz_set(&z->q, &x->q);
+ }
+ return;
+}
+
+void mpq_set_si(mpq_t x, int p, unsigned int q)
+{ /* set the value of x to p/q */
+ if (q == 0)
+ xerror("mpq_set_si: zero denominator not allowed\n");
+ mpz_set_si(&x->p, p);
+ xassert(q <= 0x7FFFFFFF);
+ mpz_set_si(&x->q, q);
+ return;
+}
+
+double mpq_get_d(mpq_t x)
+{ /* convert x to a double, truncating if necessary */
+ int np, nq;
+ double p, q;
+ p = mpz_get_d_2exp(&np, &x->p);
+ q = mpz_get_d_2exp(&nq, &x->q);
+ return ldexp(p / q, np - nq);
+}
+
+void mpq_set_d(mpq_t x, double val)
+{ /* set x to val; there is no rounding, the conversion is exact */
+ int s, n, d, j;
+ double f;
+ mpz_t temp;
+ xassert(-DBL_MAX <= val && val <= +DBL_MAX);
+ mpq_set_si(x, 0, 1);
+ if (val > 0.0)
+ s = +1;
+ else if (val < 0.0)
+ s = -1;
+ else
+ goto done;
+ f = frexp(fabs(val), &n);
+ /* |val| = f * 2^n, where 0.5 <= f < 1.0 */
+ mpz_init(temp);
+ while (f != 0.0)
+ { f *= 16.0, n -= 4;
+ d = (int)f;
+ xassert(0 <= d && d <= 15);
+ f -= (double)d;
+ /* x := 16 * x + d */
+ mpz_set_si(temp, 16);
+ mpz_mul(&x->p, &x->p, temp);
+ mpz_set_si(temp, d);
+ mpz_add(&x->p, &x->p, temp);
+ }
+ mpz_clear(temp);
+ /* x := x * 2^n */
+ if (n > 0)
+ { for (j = 1; j <= n; j++)
+ mpz_add(&x->p, &x->p, &x->p);
+ }
+ else if (n < 0)
+ { for (j = 1; j <= -n; j++)
+ mpz_add(&x->q, &x->q, &x->q);
+ mpq_canonicalize(x);
+ }
+ if (s < 0)
+ mpq_neg(x, x);
+done: return;
+}
+
+void mpq_add(mpq_t z, mpq_t x, mpq_t y)
+{ /* set z to x + y */
+ mpz_t p, q;
+ mpz_init(p);
+ mpz_init(q);
+ mpz_mul(p, &x->p, &y->q);
+ mpz_mul(q, &x->q, &y->p);
+ mpz_add(p, p, q);
+ mpz_mul(q, &x->q, &y->q);
+ mpz_set(&z->p, p);
+ mpz_set(&z->q, q);
+ mpz_clear(p);
+ mpz_clear(q);
+ mpq_canonicalize(z);
+ return;
+}
+
+void mpq_sub(mpq_t z, mpq_t x, mpq_t y)
+{ /* set z to x - y */
+ mpz_t p, q;
+ mpz_init(p);
+ mpz_init(q);
+ mpz_mul(p, &x->p, &y->q);
+ mpz_mul(q, &x->q, &y->p);
+ mpz_sub(p, p, q);
+ mpz_mul(q, &x->q, &y->q);
+ mpz_set(&z->p, p);
+ mpz_set(&z->q, q);
+ mpz_clear(p);
+ mpz_clear(q);
+ mpq_canonicalize(z);
+ return;
+}
+
+void mpq_mul(mpq_t z, mpq_t x, mpq_t y)
+{ /* set z to x * y */
+ mpz_mul(&z->p, &x->p, &y->p);
+ mpz_mul(&z->q, &x->q, &y->q);
+ mpq_canonicalize(z);
+ return;
+}
+
+void mpq_div(mpq_t z, mpq_t x, mpq_t y)
+{ /* set z to x / y */
+ mpz_t p, q;
+ if (mpq_sgn(y) == 0)
+ xerror("mpq_div: zero divisor not allowed\n");
+ mpz_init(p);
+ mpz_init(q);
+ mpz_mul(p, &x->p, &y->q);
+ mpz_mul(q, &x->q, &y->p);
+ mpz_set(&z->p, p);
+ mpz_set(&z->q, q);
+ mpz_clear(p);
+ mpz_clear(q);
+ mpq_canonicalize(z);
+ return;
+}
+
+void mpq_neg(mpq_t z, mpq_t x)
+{ /* set z to 0 - x */
+ mpq_set(z, x);
+ mpz_neg(&z->p, &z->p);
+ return;
+}
+
+void mpq_abs(mpq_t z, mpq_t x)
+{ /* set z to the absolute value of x */
+ mpq_set(z, x);
+ mpz_abs(&z->p, &z->p);
+ xassert(mpz_sgn(&x->q) > 0);
+ return;
+}
+
+int mpq_cmp(mpq_t x, mpq_t y)
+{ /* compare x and y; return a positive value if x > y, zero if
+ * x = y, or a negative value if x < y */
+ mpq_t temp;
+ int s;
+ mpq_init(temp);
+ mpq_sub(temp, x, y);
+ s = mpq_sgn(temp);
+ mpq_clear(temp);
+ return s;
+}
+
+int mpq_sgn(mpq_t x)
+{ /* return +1 if x > 0, 0 if x = 0, and -1 if x < 0 */
+ int s;
+ s = mpz_sgn(&x->p);
+ xassert(mpz_sgn(&x->q) > 0);
+ return s;
+}
+
+int mpq_out_str(void *_fp, int base, mpq_t x)
+{ /* output x on stream fp, as a string in given base; the base
+ * may vary from 2 to 36; output is in the form 'num/den' or if
+ * the denominator is 1 then just 'num';
+ * if the parameter fp is a null pointer, stdout is assumed;
+ * return the number of bytes written, or if an error occurred,
+ * return 0 */
+ FILE *fp = _fp;
+ int nwr;
+ if (!(2 <= base && base <= 36))
+ xerror("mpq_out_str: base = %d; invalid base\n", base);
+ if (fp == NULL)
+ fp = stdout;
+ nwr = mpz_out_str(fp, base, &x->p);
+ if (x->q.val == 1 && x->q.ptr == NULL)
+ ;
+ else
+ { fputc('/', fp), nwr++;
+ nwr += mpz_out_str(fp, base, &x->q);
+ }
+ if (ferror(fp))
+ nwr = 0;
+ return nwr;
+}
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/mygmp.h b/test/monniaux/glpk-4.65/src/misc/mygmp.h
new file mode 100644
index 00000000..31d2024d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/mygmp.h
@@ -0,0 +1,254 @@
+/* mygmp.h (integer and rational arithmetic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2008-2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MYGMP_H
+#define MYGMP_H
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#ifdef HAVE_GMP /* use GNU MP library */
+
+#include <gmp.h>
+
+#define gmp_pool_count() 0
+
+#define gmp_free_mem() ((void)0)
+
+#else /* use GLPK MP module */
+
+/***********************************************************************
+* INTEGER NUMBERS
+* ---------------
+* Depending on its magnitude an integer number of arbitrary precision
+* is represented either in short format or in long format.
+*
+* Short format corresponds to the int type and allows representing
+* integer numbers in the range [-(2^31-1), +(2^31-1)]. Note that for
+* the most negative number of int type the short format is not used.
+*
+* In long format integer numbers are represented using the positional
+* system with the base (radix) 2^16 = 65536:
+*
+* x = (-1)^s sum{j in 0..n-1} d[j] * 65536^j,
+*
+* where x is the integer to be represented, s is its sign (+1 or -1),
+* d[j] are its digits (0 <= d[j] <= 65535).
+*
+* RATIONAL NUMBERS
+* ----------------
+* A rational number is represented as an irreducible fraction:
+*
+* p / q,
+*
+* where p (numerator) and q (denominator) are integer numbers (q > 0)
+* having no common divisors. */
+
+struct mpz
+{ /* integer number */
+ int val;
+ /* if ptr is a null pointer, the number is in short format, and
+ val is its value; otherwise, the number is in long format, and
+ val is its sign (+1 or -1) */
+ struct mpz_seg *ptr;
+ /* pointer to the linked list of the number segments ordered in
+ ascending of powers of the base */
+};
+
+struct mpz_seg
+{ /* integer number segment */
+ unsigned short d[6];
+ /* six digits of the number ordered in ascending of powers of the
+ base */
+ struct mpz_seg *next;
+ /* pointer to the next number segment */
+};
+
+struct mpq
+{ /* rational number (p / q) */
+ struct mpz p;
+ /* numerator */
+ struct mpz q;
+ /* denominator */
+};
+
+typedef struct mpz *mpz_t;
+typedef struct mpq *mpq_t;
+
+#define gmp_get_atom _glp_gmp_get_atom
+void *gmp_get_atom(int size);
+
+#define gmp_free_atom _glp_gmp_free_atom
+void gmp_free_atom(void *ptr, int size);
+
+#define gmp_pool_count _glp_gmp_pool_count
+int gmp_pool_count(void);
+
+#define gmp_get_work _glp_gmp_get_work
+unsigned short *gmp_get_work(int size);
+
+#define gmp_free_mem _glp_gmp_free_mem
+void gmp_free_mem(void);
+
+#define mpz_init(x) (void)((x) = _mpz_init())
+
+#define _mpz_init _glp_mpz_init
+mpz_t _mpz_init(void);
+/* initialize x and set its value to 0 */
+
+#define mpz_clear _glp_mpz_clear
+void mpz_clear(mpz_t x);
+/* free the space occupied by x */
+
+#define mpz_set _glp_mpz_set
+void mpz_set(mpz_t z, mpz_t x);
+/* set the value of z from x */
+
+#define mpz_set_si _glp_mpz_set_si
+void mpz_set_si(mpz_t x, int val);
+/* set the value of x to val */
+
+#define mpz_get_d _glp_mpz_get_d
+double mpz_get_d(mpz_t x);
+/* convert x to a double, truncating if necessary */
+
+#define mpz_get_d_2exp _glp_mpz_get_d_2exp
+double mpz_get_d_2exp(int *exp, mpz_t x);
+/* convert x to a double, returning the exponent separately */
+
+#define mpz_swap _glp_mpz_swap
+void mpz_swap(mpz_t x, mpz_t y);
+/* swap the values x and y efficiently */
+
+#define mpz_add _glp_mpz_add
+void mpz_add(mpz_t, mpz_t, mpz_t);
+/* set z to x + y */
+
+#define mpz_sub _glp_mpz_sub
+void mpz_sub(mpz_t, mpz_t, mpz_t);
+/* set z to x - y */
+
+#define mpz_mul _glp_mpz_mul
+void mpz_mul(mpz_t, mpz_t, mpz_t);
+/* set z to x * y */
+
+#define mpz_neg _glp_mpz_neg
+void mpz_neg(mpz_t z, mpz_t x);
+/* set z to 0 - x */
+
+#define mpz_abs _glp_mpz_abs
+void mpz_abs(mpz_t z, mpz_t x);
+/* set z to the absolute value of x */
+
+#define mpz_div _glp_mpz_div
+void mpz_div(mpz_t q, mpz_t r, mpz_t x, mpz_t y);
+/* divide x by y, forming quotient q and/or remainder r */
+
+#define mpz_gcd _glp_mpz_gcd
+void mpz_gcd(mpz_t z, mpz_t x, mpz_t y);
+/* set z to the greatest common divisor of x and y */
+
+#define mpz_cmp _glp_mpz_cmp
+int mpz_cmp(mpz_t x, mpz_t y);
+/* compare x and y */
+
+#define mpz_sgn _glp_mpz_sgn
+int mpz_sgn(mpz_t x);
+/* return +1 if x > 0, 0 if x = 0, and -1 if x < 0 */
+
+#define mpz_out_str _glp_mpz_out_str
+int mpz_out_str(void *fp, int base, mpz_t x);
+/* output x on stream fp, as a string in given base */
+
+#define mpq_init(x) (void)((x) = _mpq_init())
+
+#define _mpq_init _glp_mpq_init
+mpq_t _mpq_init(void);
+/* initialize x, and set its value to 0/1 */
+
+#define mpq_clear _glp_mpq_clear
+void mpq_clear(mpq_t x);
+/* free the space occupied by x */
+
+#define mpq_canonicalize _glp_mpq_canonicalize
+void mpq_canonicalize(mpq_t x);
+/* canonicalize x */
+
+#define mpq_set _glp_mpq_set
+void mpq_set(mpq_t z, mpq_t x);
+/* set the value of z from x */
+
+#define mpq_set_si _glp_mpq_set_si
+void mpq_set_si(mpq_t x, int p, unsigned int q);
+/* set the value of x to p/q */
+
+#define mpq_get_d _glp_mpq_get_d
+double mpq_get_d(mpq_t x);
+/* convert x to a double, truncating if necessary */
+
+#define mpq_set_d _glp_mpq_set_d
+void mpq_set_d(mpq_t x, double val);
+/* set x to val; there is no rounding, the conversion is exact */
+
+#define mpq_add _glp_mpq_add
+void mpq_add(mpq_t z, mpq_t x, mpq_t y);
+/* set z to x + y */
+
+#define mpq_sub _glp_mpq_sub
+void mpq_sub(mpq_t z, mpq_t x, mpq_t y);
+/* set z to x - y */
+
+#define mpq_mul _glp_mpq_mul
+void mpq_mul(mpq_t z, mpq_t x, mpq_t y);
+/* set z to x * y */
+
+#define mpq_div _glp_mpq_div
+void mpq_div(mpq_t z, mpq_t x, mpq_t y);
+/* set z to x / y */
+
+#define mpq_neg _glp_mpq_neg
+void mpq_neg(mpq_t z, mpq_t x);
+/* set z to 0 - x */
+
+#define mpq_abs _glp_mpq_abs
+void mpq_abs(mpq_t z, mpq_t x);
+/* set z to the absolute value of x */
+
+#define mpq_cmp _glp_mpq_cmp
+int mpq_cmp(mpq_t x, mpq_t y);
+/* compare x and y */
+
+#define mpq_sgn _glp_mpq_sgn
+int mpq_sgn(mpq_t x);
+/* return +1 if x > 0, 0 if x = 0, and -1 if x < 0 */
+
+#define mpq_out_str _glp_mpq_out_str
+int mpq_out_str(void *fp, int base, mpq_t x);
+/* output x on stream fp, as a string in given base */
+
+#endif
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/okalg.c b/test/monniaux/glpk-4.65/src/misc/okalg.c
new file mode 100644
index 00000000..8eecd6df
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/okalg.c
@@ -0,0 +1,382 @@
+/* okalg.c (out-of-kilter algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "okalg.h"
+
+/***********************************************************************
+* NAME
+*
+* okalg - out-of-kilter algorithm
+*
+* SYNOPSIS
+*
+* #include "okalg.h"
+* int okalg(int nv, int na, const int tail[], const int head[],
+* const int low[], const int cap[], const int cost[], int x[],
+* int pi[]);
+*
+* DESCRIPTION
+*
+* The routine okalg implements the out-of-kilter algorithm to find a
+* minimal-cost circulation in the specified flow network.
+*
+* INPUT PARAMETERS
+*
+* nv is the number of nodes, nv >= 0.
+*
+* na is the number of arcs, na >= 0.
+*
+* tail[a], a = 1,...,na, is the index of tail node of arc a.
+*
+* head[a], a = 1,...,na, is the index of head node of arc a.
+*
+* low[a], a = 1,...,na, is an lower bound to the flow through arc a.
+*
+* cap[a], a = 1,...,na, is an upper bound to the flow through arc a,
+* which is the capacity of the arc.
+*
+* cost[a], a = 1,...,na, is a per-unit cost of the flow through arc a.
+*
+* NOTES
+*
+* 1. Multiple arcs are allowed, but self-loops are not allowed.
+*
+* 2. It is required that 0 <= low[a] <= cap[a] for all arcs.
+*
+* 3. Arc costs may have any sign.
+*
+* OUTPUT PARAMETERS
+*
+* x[a], a = 1,...,na, is optimal value of the flow through arc a.
+*
+* pi[i], i = 1,...,nv, is Lagrange multiplier for flow conservation
+* equality constraint corresponding to node i (the node potential).
+*
+* RETURNS
+*
+* 0 optimal circulation found;
+*
+* 1 there is no feasible circulation;
+*
+* 2 integer overflow occured;
+*
+* 3 optimality test failed (logic error).
+*
+* REFERENCES
+*
+* L.R.Ford, Jr., and D.R.Fulkerson, "Flows in Networks," The RAND
+* Corp., Report R-375-PR (August 1962), Chap. III "Minimal Cost Flow
+* Problems," pp.113-26. */
+
+static int overflow(int u, int v)
+{ /* check for integer overflow on computing u + v */
+ if (u > 0 && v > 0 && u + v < 0) return 1;
+ if (u < 0 && v < 0 && u + v > 0) return 1;
+ return 0;
+}
+
+int okalg(int nv, int na, const int tail[], const int head[],
+ const int low[], const int cap[], const int cost[], int x[],
+ int pi[])
+{ int a, aok, delta, i, j, k, lambda, pos1, pos2, s, t, temp, ret,
+ *ptr, *arc, *link, *list;
+ /* sanity checks */
+ xassert(nv >= 0);
+ xassert(na >= 0);
+ for (a = 1; a <= na; a++)
+ { i = tail[a], j = head[a];
+ xassert(1 <= i && i <= nv);
+ xassert(1 <= j && j <= nv);
+ xassert(i != j);
+ xassert(0 <= low[a] && low[a] <= cap[a]);
+ }
+ /* allocate working arrays */
+ ptr = xcalloc(1+nv+1, sizeof(int));
+ arc = xcalloc(1+na+na, sizeof(int));
+ link = xcalloc(1+nv, sizeof(int));
+ list = xcalloc(1+nv, sizeof(int));
+ /* ptr[i] := (degree of node i) */
+ for (i = 1; i <= nv; i++)
+ ptr[i] = 0;
+ for (a = 1; a <= na; a++)
+ { ptr[tail[a]]++;
+ ptr[head[a]]++;
+ }
+ /* initialize arc pointers */
+ ptr[1]++;
+ for (i = 1; i < nv; i++)
+ ptr[i+1] += ptr[i];
+ ptr[nv+1] = ptr[nv];
+ /* build arc lists */
+ for (a = 1; a <= na; a++)
+ { arc[--ptr[tail[a]]] = a;
+ arc[--ptr[head[a]]] = a;
+ }
+ xassert(ptr[1] == 1);
+ xassert(ptr[nv+1] == na+na+1);
+ /* now the indices of arcs incident to node i are stored in
+ * locations arc[ptr[i]], arc[ptr[i]+1], ..., arc[ptr[i+1]-1] */
+ /* initialize arc flows and node potentials */
+ for (a = 1; a <= na; a++)
+ x[a] = 0;
+ for (i = 1; i <= nv; i++)
+ pi[i] = 0;
+loop: /* main loop starts here */
+ /* find out-of-kilter arc */
+ aok = 0;
+ for (a = 1; a <= na; a++)
+ { i = tail[a], j = head[a];
+ if (overflow(cost[a], pi[i] - pi[j]))
+ { ret = 2;
+ goto done;
+ }
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if (x[a] < low[a] || (lambda < 0 && x[a] < cap[a]))
+ { /* arc a = i->j is out of kilter, and we need to increase
+ * the flow through this arc */
+ aok = a, s = j, t = i;
+ break;
+ }
+ if (x[a] > cap[a] || (lambda > 0 && x[a] > low[a]))
+ { /* arc a = i->j is out of kilter, and we need to decrease
+ * the flow through this arc */
+ aok = a, s = i, t = j;
+ break;
+ }
+ }
+ if (aok == 0)
+ { /* all arcs are in kilter */
+ /* check for feasibility */
+ for (a = 1; a <= na; a++)
+ { if (!(low[a] <= x[a] && x[a] <= cap[a]))
+ { ret = 3;
+ goto done;
+ }
+ }
+ for (i = 1; i <= nv; i++)
+ { temp = 0;
+ for (k = ptr[i]; k < ptr[i+1]; k++)
+ { a = arc[k];
+ if (tail[a] == i)
+ { /* a is outgoing arc */
+ temp += x[a];
+ }
+ else if (head[a] == i)
+ { /* a is incoming arc */
+ temp -= x[a];
+ }
+ else
+ xassert(a != a);
+ }
+ if (temp != 0)
+ { ret = 3;
+ goto done;
+ }
+ }
+ /* check for optimality */
+ for (a = 1; a <= na; a++)
+ { i = tail[a], j = head[a];
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if ((lambda > 0 && x[a] != low[a]) ||
+ (lambda < 0 && x[a] != cap[a]))
+ { ret = 3;
+ goto done;
+ }
+ }
+ /* current circulation is optimal */
+ ret = 0;
+ goto done;
+ }
+ /* now we need to find a cycle (t, a, s, ..., t), which allows
+ * increasing the flow along it, where a is the out-of-kilter arc
+ * just found */
+ /* link[i] = 0 means that node i is not labelled yet;
+ * link[i] = a means that arc a immediately precedes node i */
+ /* initially only node s is labelled */
+ for (i = 1; i <= nv; i++)
+ link[i] = 0;
+ link[s] = aok, list[1] = s, pos1 = pos2 = 1;
+ /* breadth first search */
+ while (pos1 <= pos2)
+ { /* dequeue node i */
+ i = list[pos1++];
+ /* consider all arcs incident to node i */
+ for (k = ptr[i]; k < ptr[i+1]; k++)
+ { a = arc[k];
+ if (tail[a] == i)
+ { /* a = i->j is a forward arc from s to t */
+ j = head[a];
+ /* if node j has been labelled, skip the arc */
+ if (link[j] != 0) continue;
+ /* if the arc does not allow increasing the flow through
+ * it, skip the arc */
+ if (x[a] >= cap[a]) continue;
+ if (overflow(cost[a], pi[i] - pi[j]))
+ { ret = 2;
+ goto done;
+ }
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if (lambda > 0 && x[a] >= low[a]) continue;
+ }
+ else if (head[a] == i)
+ { /* a = i<-j is a backward arc from s to t */
+ j = tail[a];
+ /* if node j has been labelled, skip the arc */
+ if (link[j] != 0) continue;
+ /* if the arc does not allow decreasing the flow through
+ * it, skip the arc */
+ if (x[a] <= low[a]) continue;
+ if (overflow(cost[a], pi[j] - pi[i]))
+ { ret = 2;
+ goto done;
+ }
+ lambda = cost[a] + (pi[j] - pi[i]);
+ if (lambda < 0 && x[a] <= cap[a]) continue;
+ }
+ else
+ xassert(a != a);
+ /* label node j and enqueue it */
+ link[j] = a, list[++pos2] = j;
+ /* check for breakthrough */
+ if (j == t) goto brkt;
+ }
+ }
+ /* NONBREAKTHROUGH */
+ /* consider all arcs, whose one endpoint is labelled and other is
+ * not, and determine maximal change of node potentials */
+ delta = 0;
+ for (a = 1; a <= na; a++)
+ { i = tail[a], j = head[a];
+ if (link[i] != 0 && link[j] == 0)
+ { /* a = i->j, where node i is labelled, node j is not */
+ if (overflow(cost[a], pi[i] - pi[j]))
+ { ret = 2;
+ goto done;
+ }
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if (x[a] <= cap[a] && lambda > 0)
+ if (delta == 0 || delta > + lambda) delta = + lambda;
+ }
+ else if (link[i] == 0 && link[j] != 0)
+ { /* a = j<-i, where node j is labelled, node i is not */
+ if (overflow(cost[a], pi[i] - pi[j]))
+ { ret = 2;
+ goto done;
+ }
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if (x[a] >= low[a] && lambda < 0)
+ if (delta == 0 || delta > - lambda) delta = - lambda;
+ }
+ }
+ if (delta == 0)
+ { /* there is no feasible circulation */
+ ret = 1;
+ goto done;
+ }
+ /* increase potentials of all unlabelled nodes */
+ for (i = 1; i <= nv; i++)
+ { if (link[i] == 0)
+ { if (overflow(pi[i], delta))
+ { ret = 2;
+ goto done;
+ }
+ pi[i] += delta;
+ }
+ }
+ goto loop;
+brkt: /* BREAKTHROUGH */
+ /* walk through arcs of the cycle (t, a, s, ..., t) found in the
+ * reverse order and determine maximal change of the flow */
+ delta = 0;
+ for (j = t;; j = i)
+ { /* arc a immediately precedes node j in the cycle */
+ a = link[j];
+ if (head[a] == j)
+ { /* a = i->j is a forward arc of the cycle */
+ i = tail[a];
+ lambda = cost[a] + (pi[i] - pi[j]);
+ if (lambda > 0 && x[a] < low[a])
+ { /* x[a] may be increased until its lower bound */
+ temp = low[a] - x[a];
+ }
+ else if (lambda <= 0 && x[a] < cap[a])
+ { /* x[a] may be increased until its upper bound */
+ temp = cap[a] - x[a];
+ }
+ else
+ xassert(a != a);
+ }
+ else if (tail[a] == j)
+ { /* a = i<-j is a backward arc of the cycle */
+ i = head[a];
+ lambda = cost[a] + (pi[j] - pi[i]);
+ if (lambda < 0 && x[a] > cap[a])
+ { /* x[a] may be decreased until its upper bound */
+ temp = x[a] - cap[a];
+ }
+ else if (lambda >= 0 && x[a] > low[a])
+ { /* x[a] may be decreased until its lower bound */
+ temp = x[a] - low[a];
+ }
+ else
+ xassert(a != a);
+ }
+ else
+ xassert(a != a);
+ if (delta == 0 || delta > temp) delta = temp;
+ /* check for end of the cycle */
+ if (i == t) break;
+ }
+ xassert(delta > 0);
+ /* increase the flow along the cycle */
+ for (j = t;; j = i)
+ { /* arc a immediately precedes node j in the cycle */
+ a = link[j];
+ if (head[a] == j)
+ { /* a = i->j is a forward arc of the cycle */
+ i = tail[a];
+ /* overflow cannot occur */
+ x[a] += delta;
+ }
+ else if (tail[a] == j)
+ { /* a = i<-j is a backward arc of the cycle */
+ i = head[a];
+ /* overflow cannot occur */
+ x[a] -= delta;
+ }
+ else
+ xassert(a != a);
+ /* check for end of the cycle */
+ if (i == t) break;
+ }
+ goto loop;
+done: /* free working arrays */
+ xfree(ptr);
+ xfree(arc);
+ xfree(link);
+ xfree(list);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/okalg.h b/test/monniaux/glpk-4.65/src/misc/okalg.h
new file mode 100644
index 00000000..2f2d9740
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/okalg.h
@@ -0,0 +1,35 @@
+/* okalg.h (out-of-kilter algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef OKALG_H
+#define OKALG_H
+
+#define okalg _glp_okalg
+int okalg(int nv, int na, const int tail[], const int head[],
+ const int low[], const int cap[], const int cost[], int x[],
+ int pi[]);
+/* out-of-kilter algorithm */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/qmd.c b/test/monniaux/glpk-4.65/src/misc/qmd.c
new file mode 100644
index 00000000..a3397dcf
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/qmd.c
@@ -0,0 +1,584 @@
+/* qmd.c (quotient minimum degree algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* THIS CODE IS THE RESULT OF TRANSLATION OF THE FORTRAN SUBROUTINES
+* GENQMD, QMDRCH, QMDQT, QMDUPD, AND QMDMRG FROM THE BOOK:
+*
+* ALAN GEORGE, JOSEPH W-H LIU. COMPUTER SOLUTION OF LARGE SPARSE
+* POSITIVE DEFINITE SYSTEMS. PRENTICE-HALL, 1981.
+*
+* THE TRANSLATION HAS BEEN DONE WITH THE PERMISSION OF THE AUTHORS
+* OF THE ORIGINAL FORTRAN SUBROUTINES: ALAN GEORGE AND JOSEPH LIU,
+* UNIVERSITY OF WATERLOO, WATERLOO, ONTARIO, CANADA.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "qmd.h"
+
+/***********************************************************************
+* NAME
+*
+* genqmd - GENeral Quotient Minimum Degree algorithm
+*
+* SYNOPSIS
+*
+* #include "qmd.h"
+* void genqmd(int *neqns, int xadj[], int adjncy[], int perm[],
+* int invp[], int deg[], int marker[], int rchset[], int nbrhd[],
+* int qsize[], int qlink[], int *nofsub);
+*
+* PURPOSE
+*
+* This routine implements the minimum degree algorithm. It makes use
+* of the implicit representation of the elimination graph by quotient
+* graphs, and the notion of indistinguishable nodes.
+*
+* CAUTION
+*
+* The adjancy vector adjncy will be destroyed.
+*
+* INPUT PARAMETERS
+*
+* neqns - number of equations;
+* (xadj, adjncy) -
+* the adjancy structure.
+*
+* OUTPUT PARAMETERS
+*
+* perm - the minimum degree ordering;
+* invp - the inverse of perm.
+*
+* WORKING PARAMETERS
+*
+* deg - the degree vector. deg[i] is negative means node i has been
+* numbered;
+* marker - a marker vector, where marker[i] is negative means node i
+* has been merged with another nodeand thus can be ignored;
+* rchset - vector used for the reachable set;
+* nbrhd - vector used for neighborhood set;
+* qsize - vector used to store the size of indistinguishable
+* supernodes;
+* qlink - vector used to store indistinguishable nodes, i, qlink[i],
+* qlink[qlink[i]], ... are the members of the supernode
+* represented by i.
+*
+* PROGRAM SUBROUTINES
+*
+* qmdrch, qmdqt, qmdupd.
+***********************************************************************/
+
+void genqmd(int *_neqns, int xadj[], int adjncy[], int perm[],
+ int invp[], int deg[], int marker[], int rchset[], int nbrhd[],
+ int qsize[], int qlink[], int *_nofsub)
+{ int inode, ip, irch, j, mindeg, ndeg, nhdsze, node, np, num,
+ nump1, nxnode, rchsze, search, thresh;
+# define neqns (*_neqns)
+# define nofsub (*_nofsub)
+ /* Initialize degree vector and other working variables. */
+ mindeg = neqns;
+ nofsub = 0;
+ for (node = 1; node <= neqns; node++)
+ { perm[node] = node;
+ invp[node] = node;
+ marker[node] = 0;
+ qsize[node] = 1;
+ qlink[node] = 0;
+ ndeg = xadj[node+1] - xadj[node];
+ deg[node] = ndeg;
+ if (ndeg < mindeg) mindeg = ndeg;
+ }
+ num = 0;
+ /* Perform threshold search to get a node of min degree.
+ * Variable search point to where search should start. */
+s200: search = 1;
+ thresh = mindeg;
+ mindeg = neqns;
+s300: nump1 = num + 1;
+ if (nump1 > search) search = nump1;
+ for (j = search; j <= neqns; j++)
+ { node = perm[j];
+ if (marker[node] >= 0)
+ { ndeg = deg[node];
+ if (ndeg <= thresh) goto s500;
+ if (ndeg < mindeg) mindeg = ndeg;
+ }
+ }
+ goto s200;
+ /* Node has minimum degree. Find its reachable sets by calling
+ * qmdrch. */
+s500: search = j;
+ nofsub += deg[node];
+ marker[node] = 1;
+ qmdrch(&node, xadj, adjncy, deg, marker, &rchsze, rchset, &nhdsze,
+ nbrhd);
+ /* Eliminate all nodes indistinguishable from node. They are given
+ * by node, qlink[node], ... . */
+ nxnode = node;
+s600: num++;
+ np = invp[nxnode];
+ ip = perm[num];
+ perm[np] = ip;
+ invp[ip] = np;
+ perm[num] = nxnode;
+ invp[nxnode] = num;
+ deg[nxnode] = -1;
+ nxnode = qlink[nxnode];
+ if (nxnode > 0) goto s600;
+ if (rchsze > 0)
+ { /* Update the degrees of the nodes in the reachable set and
+ * identify indistinguishable nodes. */
+ qmdupd(xadj, adjncy, &rchsze, rchset, deg, qsize, qlink,
+ marker, &rchset[rchsze+1], &nbrhd[nhdsze+1]);
+ /* Reset marker value of nodes in reach set. Update threshold
+ * value for cyclic search. Also call qmdqt to form new
+ * quotient graph. */
+ marker[node] = 0;
+ for (irch = 1; irch <= rchsze; irch++)
+ { inode = rchset[irch];
+ if (marker[inode] >= 0)
+ { marker[inode] = 0;
+ ndeg = deg[inode];
+ if (ndeg < mindeg) mindeg = ndeg;
+ if (ndeg <= thresh)
+ { mindeg = thresh;
+ thresh = ndeg;
+ search = invp[inode];
+ }
+ }
+ }
+ if (nhdsze > 0)
+ qmdqt(&node, xadj, adjncy, marker, &rchsze, rchset, nbrhd);
+ }
+ if (num < neqns) goto s300;
+ return;
+# undef neqns
+# undef nofsub
+}
+
+/***********************************************************************
+* NAME
+*
+* qmdrch - Quotient MD ReaCHable set
+*
+* SYNOPSIS
+*
+* #include "qmd.h"
+* void qmdrch(int *root, int xadj[], int adjncy[], int deg[],
+* int marker[], int *rchsze, int rchset[], int *nhdsze,
+* int nbrhd[]);
+*
+* PURPOSE
+*
+* This subroutine determines the reachable set of a node through a
+* given subset. The adjancy structure is assumed to be stored in a
+* quotient graph format.
+*
+* INPUT PARAMETERS
+*
+* root - the given node not in the subset;
+* (xadj, adjncy) -
+* the adjancy structure pair;
+* deg - the degree vector. deg[i] < 0 means the node belongs to the
+* given subset.
+*
+* OUTPUT PARAMETERS
+*
+* (rchsze, rchset) -
+* the reachable set;
+* (nhdsze, nbrhd) -
+* the neighborhood set.
+*
+* UPDATED PARAMETERS
+*
+* marker - the marker vector for reach and nbrhd sets. > 0 means the
+* node is in reach set. < 0 means the node has been merged
+* with others in the quotient or it is in nbrhd set.
+***********************************************************************/
+
+void qmdrch(int *_root, int xadj[], int adjncy[], int deg[],
+ int marker[], int *_rchsze, int rchset[], int *_nhdsze,
+ int nbrhd[])
+{ int i, istop, istrt, j, jstop, jstrt, nabor, node;
+# define root (*_root)
+# define rchsze (*_rchsze)
+# define nhdsze (*_nhdsze)
+ /* Loop through the neighbors of root in the quotient graph. */
+ nhdsze = 0;
+ rchsze = 0;
+ istrt = xadj[root];
+ istop = xadj[root+1] - 1;
+ if (istop < istrt) return;
+ for (i = istrt; i <= istop; i++)
+ { nabor = adjncy[i];
+ if (nabor == 0) return;
+ if (marker[nabor] == 0)
+ { if (deg[nabor] >= 0)
+ { /* Include nabor into the reachable set. */
+ rchsze++;
+ rchset[rchsze] = nabor;
+ marker[nabor] = 1;
+ goto s600;
+ }
+ /* nabor has been eliminated. Find nodes reachable from
+ * it. */
+ marker[nabor] = -1;
+ nhdsze++;
+ nbrhd[nhdsze] = nabor;
+s300: jstrt = xadj[nabor];
+ jstop = xadj[nabor+1] - 1;
+ for (j = jstrt; j <= jstop; j++)
+ { node = adjncy[j];
+ nabor = - node;
+ if (node < 0) goto s300;
+ if (node == 0) goto s600;
+ if (marker[node] == 0)
+ { rchsze++;
+ rchset[rchsze] = node;
+ marker[node] = 1;
+ }
+ }
+ }
+s600: ;
+ }
+ return;
+# undef root
+# undef rchsze
+# undef nhdsze
+}
+
+/***********************************************************************
+* NAME
+*
+* qmdqt - Quotient MD Quotient graph Transformation
+*
+* SYNOPSIS
+*
+* #include "qmd.h"
+* void qmdqt(int *root, int xadj[], int adjncy[], int marker[],
+* int *rchsze, int rchset[], int nbrhd[]);
+*
+* PURPOSE
+*
+* This subroutine performs the quotient graph transformation after a
+* node has been eliminated.
+*
+* INPUT PARAMETERS
+*
+* root - the node just eliminated. It becomes the representative of
+* the new supernode;
+* (xadj, adjncy) -
+* the adjancy structure;
+* (rchsze, rchset) -
+* the reachable set of root in the old quotient graph;
+* nbrhd - the neighborhood set which will be merged with root to form
+* the new supernode;
+* marker - the marker vector.
+*
+* UPDATED PARAMETERS
+*
+* adjncy - becomes the adjncy of the quotient graph.
+***********************************************************************/
+
+void qmdqt(int *_root, int xadj[], int adjncy[], int marker[],
+ int *_rchsze, int rchset[], int nbrhd[])
+{ int inhd, irch, j, jstop, jstrt, link, nabor, node;
+# define root (*_root)
+# define rchsze (*_rchsze)
+ irch = 0;
+ inhd = 0;
+ node = root;
+s100: jstrt = xadj[node];
+ jstop = xadj[node+1] - 2;
+ if (jstop >= jstrt)
+ { /* Place reach nodes into the adjacent list of node. */
+ for (j = jstrt; j <= jstop; j++)
+ { irch++;
+ adjncy[j] = rchset[irch];
+ if (irch >= rchsze) goto s400;
+ }
+ }
+ /* Link to other space provided by the nbrhd set. */
+ link = adjncy[jstop+1];
+ node = - link;
+ if (link >= 0)
+ { inhd++;
+ node = nbrhd[inhd];
+ adjncy[jstop+1] = - node;
+ }
+ goto s100;
+ /* All reachable nodes have been saved. End the adjacent list.
+ * Add root to the neighborhood list of each node in the reach
+ * set. */
+s400: adjncy[j+1] = 0;
+ for (irch = 1; irch <= rchsze; irch++)
+ { node = rchset[irch];
+ if (marker[node] >= 0)
+ { jstrt = xadj[node];
+ jstop = xadj[node+1] - 1;
+ for (j = jstrt; j <= jstop; j++)
+ { nabor = adjncy[j];
+ if (marker[nabor] < 0)
+ { adjncy[j] = root;
+ goto s600;
+ }
+ }
+ }
+s600: ;
+ }
+ return;
+# undef root
+# undef rchsze
+}
+
+/***********************************************************************
+* NAME
+*
+* qmdupd - Quotient MD UPDate
+*
+* SYNOPSIS
+*
+* #include "qmd.h"
+* void qmdupd(int xadj[], int adjncy[], int *nlist, int list[],
+* int deg[], int qsize[], int qlink[], int marker[], int rchset[],
+* int nbrhd[]);
+*
+* PURPOSE
+*
+* This routine performs degree update for a set of nodes in the minimum
+* degree algorithm.
+*
+* INPUT PARAMETERS
+*
+* (xadj, adjncy) -
+* the adjancy structure;
+* (nlist, list) -
+* the list of nodes whose degree has to be updated.
+*
+* UPDATED PARAMETERS
+*
+* deg - the degree vector;
+* qsize - size of indistinguishable supernodes;
+* qlink - linked list for indistinguishable nodes;
+* marker - used to mark those nodes in reach/nbrhd sets.
+*
+* WORKING PARAMETERS
+*
+* rchset - the reachable set;
+* nbrhd - the neighborhood set.
+*
+* PROGRAM SUBROUTINES
+*
+* qmdmrg.
+***********************************************************************/
+
+void qmdupd(int xadj[], int adjncy[], int *_nlist, int list[],
+ int deg[], int qsize[], int qlink[], int marker[], int rchset[],
+ int nbrhd[])
+{ int deg0, deg1, il, inhd, inode, irch, j, jstop, jstrt, mark,
+ nabor, nhdsze, node, rchsze;
+# define nlist (*_nlist)
+ /* Find all eliminated supernodes that are adjacent to some nodes
+ * in the given list. Put them into (nhdsze, nbrhd). deg0 contains
+ * the number of nodes in the list. */
+ if (nlist <= 0) return;
+ deg0 = 0;
+ nhdsze = 0;
+ for (il = 1; il <= nlist; il++)
+ { node = list[il];
+ deg0 += qsize[node];
+ jstrt = xadj[node];
+ jstop = xadj[node+1] - 1;
+ for (j = jstrt; j <= jstop; j++)
+ { nabor = adjncy[j];
+ if (marker[nabor] == 0 && deg[nabor] < 0)
+ { marker[nabor] = -1;
+ nhdsze++;
+ nbrhd[nhdsze] = nabor;
+ }
+ }
+ }
+ /* Merge indistinguishable nodes in the list by calling the
+ * subroutine qmdmrg. */
+ if (nhdsze > 0)
+ qmdmrg(xadj, adjncy, deg, qsize, qlink, marker, &deg0, &nhdsze,
+ nbrhd, rchset, &nbrhd[nhdsze+1]);
+ /* Find the new degrees of the nodes that have not been merged. */
+ for (il = 1; il <= nlist; il++)
+ { node = list[il];
+ mark = marker[node];
+ if (mark == 0 || mark == 1)
+ { marker[node] = 2;
+ qmdrch(&node, xadj, adjncy, deg, marker, &rchsze, rchset,
+ &nhdsze, nbrhd);
+ deg1 = deg0;
+ if (rchsze > 0)
+ { for (irch = 1; irch <= rchsze; irch++)
+ { inode = rchset[irch];
+ deg1 += qsize[inode];
+ marker[inode] = 0;
+ }
+ }
+ deg[node] = deg1 - 1;
+ if (nhdsze > 0)
+ { for (inhd = 1; inhd <= nhdsze; inhd++)
+ { inode = nbrhd[inhd];
+ marker[inode] = 0;
+ }
+ }
+ }
+ }
+ return;
+# undef nlist
+}
+
+/***********************************************************************
+* NAME
+*
+* qmdmrg - Quotient MD MeRGe
+*
+* SYNOPSIS
+*
+* #include "qmd.h"
+* void qmdmrg(int xadj[], int adjncy[], int deg[], int qsize[],
+* int qlink[], int marker[], int *deg0, int *nhdsze, int nbrhd[],
+* int rchset[], int ovrlp[]);
+*
+* PURPOSE
+*
+* This routine merges indistinguishable nodes in the minimum degree
+* ordering algorithm. It also computes the new degrees of these new
+* supernodes.
+*
+* INPUT PARAMETERS
+*
+* (xadj, adjncy) -
+* the adjancy structure;
+* deg0 - the number of nodes in the given set;
+* (nhdsze, nbrhd) -
+* the set of eliminated supernodes adjacent to some nodes in
+* the set.
+*
+* UPDATED PARAMETERS
+*
+* deg - the degree vector;
+* qsize - size of indistinguishable nodes;
+* qlink - linked list for indistinguishable nodes;
+* marker - the given set is given by those nodes with marker value set
+* to 1. Those nodes with degree updated will have marker value
+* set to 2.
+*
+* WORKING PARAMETERS
+*
+* rchset - the reachable set;
+* ovrlp - temp vector to store the intersection of two reachable sets.
+***********************************************************************/
+
+void qmdmrg(int xadj[], int adjncy[], int deg[], int qsize[],
+ int qlink[], int marker[], int *_deg0, int *_nhdsze, int nbrhd[],
+ int rchset[], int ovrlp[])
+{ int deg1, head, inhd, iov, irch, j, jstop, jstrt, link, lnode,
+ mark, mrgsze, nabor, node, novrlp, rchsze, root;
+# define deg0 (*_deg0)
+# define nhdsze (*_nhdsze)
+ /* Initialization. */
+ if (nhdsze <= 0) return;
+ for (inhd = 1; inhd <= nhdsze; inhd++)
+ { root = nbrhd[inhd];
+ marker[root] = 0;
+ }
+ /* Loop through each eliminated supernode in the set
+ * (nhdsze, nbrhd). */
+ for (inhd = 1; inhd <= nhdsze; inhd++)
+ { root = nbrhd[inhd];
+ marker[root] = -1;
+ rchsze = 0;
+ novrlp = 0;
+ deg1 = 0;
+s200: jstrt = xadj[root];
+ jstop = xadj[root+1] - 1;
+ /* Determine the reachable set and its intersection with the
+ * input reachable set. */
+ for (j = jstrt; j <= jstop; j++)
+ { nabor = adjncy[j];
+ root = - nabor;
+ if (nabor < 0) goto s200;
+ if (nabor == 0) break;
+ mark = marker[nabor];
+ if (mark == 0)
+ { rchsze++;
+ rchset[rchsze] = nabor;
+ deg1 += qsize[nabor];
+ marker[nabor] = 1;
+ }
+ else if (mark == 1)
+ { novrlp++;
+ ovrlp[novrlp] = nabor;
+ marker[nabor] = 2;
+ }
+ }
+ /* From the overlapped set, determine the nodes that can be
+ * merged together. */
+ head = 0;
+ mrgsze = 0;
+ for (iov = 1; iov <= novrlp; iov++)
+ { node = ovrlp[iov];
+ jstrt = xadj[node];
+ jstop = xadj[node+1] - 1;
+ for (j = jstrt; j <= jstop; j++)
+ { nabor = adjncy[j];
+ if (marker[nabor] == 0)
+ { marker[node] = 1;
+ goto s1100;
+ }
+ }
+ /* Node belongs to the new merged supernode. Update the
+ * vectors qlink and qsize. */
+ mrgsze += qsize[node];
+ marker[node] = -1;
+ lnode = node;
+s900: link = qlink[lnode];
+ if (link > 0)
+ { lnode = link;
+ goto s900;
+ }
+ qlink[lnode] = head;
+ head = node;
+s1100: ;
+ }
+ if (head > 0)
+ { qsize[head] = mrgsze;
+ deg[head] = deg0 + deg1 - 1;
+ marker[head] = 2;
+ }
+ /* Reset marker values. */
+ root = nbrhd[inhd];
+ marker[root] = 0;
+ if (rchsze > 0)
+ { for (irch = 1; irch <= rchsze; irch++)
+ { node = rchset[irch];
+ marker[node] = 0;
+ }
+ }
+ }
+ return;
+# undef deg0
+# undef nhdsze
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/qmd.h b/test/monniaux/glpk-4.65/src/misc/qmd.h
new file mode 100644
index 00000000..e55d50f5
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/qmd.h
@@ -0,0 +1,58 @@
+/* qmd.h (quotient minimum degree algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2001-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef QMD_H
+#define QMD_H
+
+#define genqmd _glp_genqmd
+void genqmd(int *neqns, int xadj[], int adjncy[], int perm[],
+ int invp[], int deg[], int marker[], int rchset[], int nbrhd[],
+ int qsize[], int qlink[], int *nofsub);
+/* GENeral Quotient Minimum Degree algorithm */
+
+#define qmdrch _glp_qmdrch
+void qmdrch(int *root, int xadj[], int adjncy[], int deg[],
+ int marker[], int *rchsze, int rchset[], int *nhdsze,
+ int nbrhd[]);
+/* Quotient MD ReaCHable set */
+
+#define qmdqt _glp_qmdqt
+void qmdqt(int *root, int xadj[], int adjncy[], int marker[],
+ int *rchsze, int rchset[], int nbrhd[]);
+/* Quotient MD Quotient graph Transformation */
+
+#define qmdupd _glp_qmdupd
+void qmdupd(int xadj[], int adjncy[], int *nlist, int list[],
+ int deg[], int qsize[], int qlink[], int marker[], int rchset[],
+ int nbrhd[]);
+/* Quotient MD UPDate */
+
+#define qmdmrg _glp_qmdmrg
+void qmdmrg(int xadj[], int adjncy[], int deg[], int qsize[],
+ int qlink[], int marker[], int *deg0, int *nhdsze, int nbrhd[],
+ int rchset[], int ovrlp[]);
+/* Quotient MD MeRGe */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/relax4.c b/test/monniaux/glpk-4.65/src/misc/relax4.c
new file mode 100644
index 00000000..f0a47d6d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/relax4.c
@@ -0,0 +1,2850 @@
+/* relax4.c (relaxation method of Bertsekas and Tseng) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* THIS CODE IS THE RESULT OF TRANSLATION OF THE FORTRAN CODE RELAX4.
+*
+* THE TRANSLATION HAS BEEN DONE WITH THE PERMISSION OF THE AUTHOR OF
+* THE ORIGINAL FORTRAN CODE PROF. DIMITRI P. BERTSEKAS, MASSACHUSETTS
+* INSTITUTE OF TECHNOLOGY, CAMBRIDGE, MASSACHUSETTS, USA.
+*
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "relax4.h"
+
+/***********************************************************************
+* WARNING
+*
+* A serious bug was *tentatively* fixed in this code (see #if/#endif
+* marked by 'mao').
+*
+* This bug is inherited from the original Fortran version of the
+* RELAX-IV code. Unfortunately, the code is very intricate, so this
+* bug is still under investigation. Thanks to Sylvain Fournier for bug
+* report.
+*
+* RELAX-IV bug details
+* --------------------
+* In the original RELAX-IV code there are four similar fragments in
+* subroutines ascnt1 and ascnt2 like this:
+*
+* C
+* C DECREASE THE PRICES OF THE SCANNED NODES BY DELPRC.
+* C ADJUST FLOW TO MAINTAIN COMPLEMENTARY SLACKNESS WITH
+* C THE PRICES.
+* C
+* NB = 0
+* DO 6 I=1,NSAVE
+* . . .
+* IF (RC(ARC).EQ.0) THEN
+* DELX=DELX+U(ARC)
+* NB = NB + 1
+* PRDCSR(NB) = ARC
+* END IF
+* . . .
+*
+* On some instances the variable NB becomes greater than N (the number
+* of nodes) that leads to indexing error, because the array PRDCSR is
+* declared as array of N elements (more precisely, as array of MAXNN
+* elements, however, NB becomes even much greater than MAXNN).
+***********************************************************************/
+
+#define false 0
+#define true 1
+
+/***********************************************************************
+* NAME
+*
+* RELAX-IV (version of October 1994)
+*
+* PURPOSE
+*
+* This routine implements the relaxation method of Bertsekas and Tseng
+* (see [1], [2]) for linear cost ordinary network flow problems.
+*
+* [1] Bertsekas, D. P., "A Unified Framework for Primal-Dual Methods"
+* Mathematical Programming, Vol. 32, 1985, pp. 125-145.
+* [2] Bertsekas, D. P., and Tseng, P., "Relaxation Methods for
+* Minimum Cost" Operations Research, Vol. 26, 1988, pp. 93-114.
+*
+* The relaxation method is also described in the books:
+*
+* [3] Bertsekas, D. P., "Linear Network Optimization: Algorithms and
+* Codes" MIT Press, 1991.
+* [4] Bertsekas, D. P. and Tsitsiklis, J. N., "Parallel and Distributed
+* Computation: Numerical Methods", Prentice-Hall, 1989.
+* [5] Bertsekas, D. P., "Network Optimization: Continuous and Discrete
+* Models", Athena Scientific, 1998.
+*
+* RELEASE NOTE
+*
+* This version of relaxation code has option for a special crash
+* procedure for the initial price-flow pair. This is recommended for
+* difficult problems where the default initialization results in long
+* running times. crash = 1 corresponds to an auction/shortest path
+* method
+*
+* These initializations are recommended in the absence of any prior
+* information on a favorable initial flow-price vector pair that
+* satisfies complementary slackness.
+*
+* The relaxation portion of the code differs from the code RELAXT-III
+* and other earlier relaxation codes in that it maintains the set of
+* nodes with nonzero deficit in a fifo queue. Like its predecessor
+* RELAXT-III, this code maintains a linked list of balanced (i.e., of
+* zero reduced cost) arcs so to reduce the work in labeling and
+* scanning. Unlike RELAXT-III, it does not use selectively shortest
+* path iterations for initialization.
+*
+* SOURCE
+*
+* The original Fortran code was written by Dimitri P. Bertsekas and
+* Paul Tseng, with a contribution by Jonathan Eckstein in the phase II
+* initialization. The original Fortran routine AUCTION was written by
+* Dimitri P. Bertsekas and is based on the method described in the
+* paper:
+*
+* [6] Bertsekas, D. P., "An Auction/Sequential Shortest Path Algorithm
+* for the Minimum Cost Flow Problem", LIDS Report P-2146, MIT,
+* Nov. 1992.
+*
+* For inquiries about the original Fortran code, please contact:
+*
+* Dimitri P. Bertsekas
+* Laboratory for information and decision systems
+* Massachusetts Institute of Technology
+* Cambridge, MA 02139
+* (617) 253-7267, dimitrib@mit.edu
+*
+* This code is the result of translation of the original Fortran code.
+* The translation was made by Andrew Makhorin <mao@gnu.org>.
+*
+* USER GUIDELINES
+*
+* This routine is in the public domain to be used only for research
+* purposes. It cannot be used as part of a commercial product, or to
+* satisfy in any part commercial delivery requirements to government
+* or industry, without prior agreement with the authors. Users are
+* requested to acknowledge the authorship of the code, and the
+* relaxation method.
+*
+* No modification should be made to this code other than the minimal
+* necessary to make it compatible with specific platforms.
+*
+* INPUT PARAMETERS (see notes 1, 2, 4)
+*
+* n = number of nodes
+* na = number of arcs
+* large = a very large integer to represent infinity
+* (see note 3)
+* repeat = true if initialization is to be skipped
+* (false otherwise)
+* crash = 0 if default initialization is used
+* 1 if auction initialization is used
+* startn[j] = starting node for arc j, j = 1,...,na
+* endn[j] = ending node for arc j, j = 1,...,na
+* fou[i] = first arc out of node i, i = 1,...,n
+* nxtou[j] = next arc out of the starting node of arc j, j = 1,...,na
+* fin[i] = first arc into node i, i = 1,...,n
+* nxtin[j] = next arc into the ending node of arc j, j = 1,...,na
+*
+* UPDATED PARAMETERS (see notes 1, 3, 4)
+*
+* rc[j] = reduced cost of arc j, j = 1,...,na
+* u[j] = capacity of arc j on input
+* and (capacity of arc j) - x[j] on output, j = 1,...,na
+* dfct[i] = demand at node i on input
+* and zero on output, i = 1,...,n
+*
+* OUTPUT PARAMETERS (see notes 1, 3, 4)
+*
+* x[j] = flow on arc j, j = 1,...,na
+* nmultinode = number of multinode relaxation iterations in RELAX4
+* iter = number of relaxation iterations in RELAX4
+* num_augm = number of flow augmentation steps in RELAX4
+* num_ascnt = number of multinode ascent steps in RELAX4
+* nsp = number of auction/shortest path iterations
+*
+* WORKING PARAMETERS (see notes 1, 4, 5)
+*
+* label[1+n], prdcsr[1+n], save[1+na], tfstou[1+n], tnxtou[1+na],
+* tfstin[1+n], tnxtin[1+na], nxtqueue[1+n], scan[1+n], mark[1+n],
+* extend_arc[1+n], sb_level[1+n], sb_arc[1+n]
+*
+* RETURNS
+*
+* 0 = normal return
+* 1,...,8 = problem is found to be infeasible
+*
+* NOTE 1
+*
+* To run in limited memory systems, declare the arrays startn, endn,
+* nxtin, nxtou, fin, fou, label, prdcsr, save, tfstou, tnxtou, tfstin,
+* tnxtin, ddpos, ddneg, nxtqueue as short instead.
+*
+* NOTE 2
+*
+* This routine makes no effort to initialize with a favorable x from
+* amongst those flow vectors that satisfy complementary slackness with
+* the initial reduced cost vector rc. If a favorable x is known, then
+* it can be passed, together with the corresponding arrays u and dfct,
+* to this routine directly. This, however, requires that the capacity
+* tightening portion and the flow initialization portion of this
+* routine (up to line labeled 90) be skipped.
+*
+* NOTE 3
+*
+* All problem data should be less than large in magnitude, and large
+* should be less than, say, 1/4 the largest int of the machine used.
+* This will guard primarily against overflow in uncapacitated problems
+* where the arc capacities are taken finite but very large. Note,
+* however, that as in all codes operating with integers, overflow may
+* occur if some of the problem data takes very large values.
+*
+* NOTE 4
+*
+* [This note being specific to Fortran was removed.-A.M.]
+*
+* NOTE 5
+*
+* ddpos and ddneg are arrays that give the directional derivatives for
+* all positive and negative single-node price changes. These are used
+* only in phase II of the initialization procedure, before the linked
+* list of balanced arcs comes to play. Therefore, to reduce storage,
+* they are equivalence to tfstou and tfstin, which are of the same size
+* (number of nodes) and are used only after the tree comes into use. */
+
+static void ascnt1(struct relax4_csa *csa, int dm, int *delx,
+ int *nlabel, int *feasbl, int *svitch, int nscan, int curnode,
+ int *prevnode);
+
+static void ascnt2(struct relax4_csa *csa, int dm, int *delx,
+ int *nlabel, int *feasbl, int *svitch, int nscan, int curnode,
+ int *prevnode);
+
+static int auction(struct relax4_csa *csa);
+
+int relax4(struct relax4_csa *csa)
+{ /* input parameters */
+ int n = csa->n;
+ int na = csa->na;
+ int large = csa->large;
+ int repeat = csa->repeat;
+ int crash = csa->crash;
+ int *startn = csa->startn;
+ int *endn = csa->endn;
+ int *fou = csa->fou;
+ int *nxtou = csa->nxtou;
+ int *fin = csa->fin;
+ int *nxtin = csa->nxtin;
+ /* updated parameters */
+ int *rc = csa->rc;
+ int *u = csa->u;
+ int *dfct = csa->dfct;
+ /* output parameters */
+ int *x = csa->x;
+# define nmultinode (csa->nmultinode)
+# define iter (csa->iter)
+# define num_augm (csa->num_augm)
+# define num_ascnt (csa->num_ascnt)
+# define nsp (csa->nsp)
+ /* working parameters */
+ int *label = csa->label;
+ int *prdcsr = csa->prdcsr;
+ int *save = csa->save;
+ int *tfstou = csa->tfstou;
+ int *tnxtou = csa->tnxtou;
+ int *tfstin = csa->tfstin;
+ int *tnxtin = csa->tnxtin;
+ int *nxtqueue = csa->nxtqueue;
+ char *scan = csa->scan;
+ char *mark = csa->mark;
+ int *ddpos = tfstou;
+ int *ddneg = tfstin;
+ /* local variables */
+ int arc, augnod, capin, capout, defcit, delprc, delx, dm, dp,
+ dx, feasbl, i, ib, indef, j, lastqueue, maxcap, narc, nb,
+ nlabel, node, node2, node_def, naugnod, nscan, num_passes,
+ numnz, numnz_new, numpasses, nxtarc, nxtbrk, nxtnode, passes,
+ pchange, posit, prevnode, prvarc, quit, rdcost, scapin,
+ scapou, svitch, t, t1, t2, tmparc, tp, trc, ts;
+ /*--------------------------------------------------------------*/
+ /* Initialization phase I */
+ /* In this phase, we reduce the arc capacities by as much as
+ * possible without changing the problem; then we set the initial
+ * flow array x, together with the corresponding arrays u and
+ * dfct. */
+ /* This phase and phase II (from here up to line labeled 90) can
+ * be skipped (by setting repeat to true) if the calling program
+ * places in common user-chosen values for the arc flows, the
+ * residual arc capacities, and the nodal deficits. When this is
+ * done, it is critical that the flow and the reduced cost for
+ * each arc satisfy complementary slackness and the dfct array
+ * properly correspond to the initial arc/flows. */
+ if (repeat)
+ goto L90;
+ for (node = 1; node <= n; node++)
+ { node_def = dfct[node];
+ ddpos[node] = node_def;
+ ddneg[node] = -node_def;
+ maxcap = 0;
+ scapou = 0;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { if (scapou <= large - u[arc])
+ scapou += u[arc];
+ else
+ goto L10;
+ }
+ if (scapou <= large - node_def)
+ capout = scapou + node_def;
+ else
+ goto L10;
+ if (capout < 0)
+ { /* problem is infeasible */
+ /* exogenous flow into node exceeds out capacity */
+ return 1;
+ }
+ scapin = 0;
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { if (u[arc] > capout)
+ u[arc] = capout;
+ if (maxcap < u[arc])
+ maxcap = u[arc];
+ if (scapin <= large - u[arc])
+ scapin += u[arc];
+ else
+ goto L10;
+ }
+ if (scapin <= large + node_def)
+ capin = scapin - node_def;
+ else
+ goto L10;
+ if (capin < 0)
+ { /* problem is infeasible */
+ /* exogenous flow out of node exceeds in capacity */
+ return 2;
+ }
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { if (u[arc] > capin)
+ u[arc] = capin;
+ }
+L10: ;
+ }
+ /*--------------------------------------------------------------*/
+ /* Initialization phase II */
+ /* In this phase, we initialize the prices and flows by either
+ * calling the routine auction or by performing only single node
+ * (coordinate) relaxation iterations. */
+ if (crash == 1)
+ { nsp = 0;
+ if (auction(csa) != 0)
+ { /* problem is found to be infeasible */
+ return 3;
+ }
+ goto L70;
+ }
+ /* Initialize the arc flows to satisfy complementary slackness
+ * with the prices. u[arc] is the residual capacity of arc, and
+ * x[arc] is the flow. These two always add up to the total
+ * capacity for arc. Also compute the directional derivatives for
+ * each coordinate and compute the actual deficits. */
+ for (arc = 1; arc <= na; arc++)
+ { x[arc] = 0;
+ if (rc[arc] <= 0)
+ { t = u[arc];
+ t1 = startn[arc];
+ t2 = endn[arc];
+ ddpos[t1] += t;
+ ddneg[t2] += t;
+ if (rc[arc] < 0)
+ { x[arc] = t;
+ u[arc] = 0;
+ dfct[t1] += t;
+ dfct[t2] -= t;
+ ddneg[t1] -= t;
+ ddpos[t2] -= t;
+ }
+ }
+ }
+ /* Make 2 or 3 passes through all nodes, performing only single
+ * node relaxation iterations. The number of passes depends on the
+ * density of the network. */
+ if (na > n * 10)
+ numpasses = 2;
+ else
+ numpasses = 3;
+ for (passes = 1; passes <= numpasses; passes++)
+ for (node = 1; node <= n; node++)
+ { if (dfct[node] == 0)
+ continue;
+ if (ddpos[node] <= 0)
+ { /* Compute delprc, the stepsize to the next breakpoint in
+ * the dual cost as the price of node is increased.
+ * [Since the reduced cost of all outgoing (resp., incoming)
+ * arcs will decrease (resp., increase) as the price of node
+ * is increased, the next breakpoint is the minimum of the
+ * positive reduced cost on outgoing arcs and of the
+ * negative reduced cost on incoming arcs.] */
+ delprc = large;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { trc = rc[arc];
+ if ((trc > 0) && (trc < delprc))
+ delprc = trc;
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { trc = rc[arc];
+ if ((trc < 0) && (trc > -delprc))
+ delprc = -trc;
+ }
+ /* If no breakpoint is left and dual ascent is still
+ * possible, the problem is infeasible. */
+ if (delprc >= large)
+ { if (ddpos[node] == 0)
+ continue;
+ return 4;
+ }
+ /* delprc is the stepsize to next breakpoint. Increase
+ * price of node by delprc and compute the stepsize to the
+ * next breakpoint in the dual cost. */
+L53: nxtbrk = large;
+ /* Look at all arcs out of node. */
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { trc = rc[arc];
+ if (trc == 0)
+ { t1 = endn[arc];
+ t = u[arc];
+ if (t > 0)
+ { dfct[node] += t;
+ dfct[t1] -= t;
+ x[arc] = t;
+ u[arc] = 0;
+ }
+ else
+ t = x[arc];
+ ddneg[node] -= t;
+ ddpos[t1] -= t;
+ }
+ /* Decrease the reduced costs on all outgoing arcs. */
+ trc -= delprc;
+ if ((trc > 0) && (trc < nxtbrk))
+ nxtbrk = trc;
+ else if (trc == 0)
+ { /* Arc goes from inactive to balanced. Update the rate
+ * of dual ascent at node and at its neighbor. */
+ ddpos[node] += u[arc];
+ ddneg[endn[arc]] += u[arc];
+ }
+ rc[arc] = trc;
+ }
+ /* Look at all arcs into node. */
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { trc = rc[arc];
+ if (trc == 0)
+ { t1 = startn[arc];
+ t = x[arc];
+ if (t > 0)
+ { dfct[node] += t;
+ dfct[t1] -= t;
+ u[arc] = t;
+ x[arc] = 0;
+ }
+ else
+ t = u[arc];
+ ddpos[t1] -= t;
+ ddneg[node] -= t;
+ }
+ /* Increase the reduced cost on all incoming arcs. */
+ trc += delprc;
+ if ((trc < 0) && (trc > -nxtbrk))
+ nxtbrk = -trc;
+ else if (trc == 0)
+ { /* Arc goes from active to balanced. Update the rate
+ * of dual ascent at node and at its neighbor. */
+ ddneg[startn[arc]] += x[arc];
+ ddpos[node] += x[arc];
+ }
+ rc[arc] = trc;
+ }
+ /* If price of node can be increased further without
+ * decreasing the dual cost (even the dual cost doesn't
+ * increase), return to increase the price further. */
+ if ((ddpos[node] <= 0) && (nxtbrk < large))
+ { delprc = nxtbrk;
+ goto L53;
+ }
+ }
+ else if (ddneg[node] <= 0)
+ { /* Compute delprc, the stepsize to the next breakpoint in
+ * the dual cost as the price of node is decreased.
+ * [Since the reduced cost of all outgoing (resp., incoming)
+ * arcs will increase (resp., decrease) as the price of node
+ * is decreased, the next breakpoint is the minimum of the
+ * negative reduced cost on outgoing arcs and of the
+ * positive reduced cost on incoming arcs.] */
+ delprc = large;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { trc = rc[arc];
+ if ((trc < 0) && (trc > -delprc))
+ delprc = -trc;
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { trc = rc[arc];
+ if ((trc > 0) && (trc < delprc))
+ delprc = trc;
+ }
+ /* If no breakpoint is left and dual ascent is still
+ * possible, the problem is infeasible. */
+ if (delprc == large)
+ { if (ddneg[node] == 0)
+ continue;
+ return 5;
+ }
+ /* delprc is the stepsize to next breakpoint. Decrease
+ * price of node by delprc and compute the stepsize to the
+ * next breakpoint in the dual cost. */
+L63: nxtbrk = large;
+ /* Look at all arcs out of node. */
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { trc = rc[arc];
+ if (trc == 0)
+ { t1 = endn[arc];
+ t = x[arc];
+ if (t > 0)
+ { dfct[node] -= t;
+ dfct[t1] += t;
+ u[arc] = t;
+ x[arc] = 0;
+ }
+ else
+ t = u[arc];
+ ddpos[node] -= t;
+ ddneg[t1] -= t;
+ }
+ /* Increase the reduced cost on all outgoing arcs. */
+ trc += delprc;
+ if ((trc < 0) && (trc > -nxtbrk))
+ nxtbrk = -trc;
+ else if (trc == 0)
+ { /* Arc goes from active to balanced. Update the rate
+ * of dual ascent at node and at its neighbor. */
+ ddneg[node] += x[arc];
+ ddpos[endn[arc]] += x[arc];
+ }
+ rc[arc] = trc;
+ }
+ /* Look at all arcs into node. */
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { trc = rc[arc];
+ if (trc == 0)
+ { t1 = startn[arc];
+ t = u[arc];
+ if (t > 0)
+ { dfct[node] -= t;
+ dfct[t1] += t;
+ x[arc] = t;
+ u[arc] = 0;
+ }
+ else
+ t = x[arc];
+ ddneg[t1] -= t;
+ ddpos[node] -= t;
+ }
+ /* Decrease the reduced cost on all incoming arcs. */
+ trc -= delprc;
+ if ((trc > 0) && (trc < nxtbrk))
+ nxtbrk = trc;
+ else if (trc == 0)
+ { /* Arc goes from inactive to balanced. Update the rate
+ * of dual ascent at node and at its neighbor. */
+ ddpos[startn[arc]] += u[arc];
+ ddneg[node] += u[arc];
+ }
+ rc[arc] = trc;
+ }
+ /* If price of node can be decreased further without
+ * decreasing the dual cost (even the dual cost doesn't
+ * increase), return to decrease the price further. */
+ if ((ddneg[node] <= 0) && (nxtbrk < large))
+ { delprc = nxtbrk;
+ goto L63;
+ }
+ }
+ }
+ /*--------------------------------------------------------------*/
+L70: /* Initialize tree data structure. */
+ for (i = 1; i <= n; i++)
+ tfstou[i] = tfstin[i] = 0;
+ for (i = 1; i <= na; i++)
+ { tnxtin[i] = tnxtou[i] = -1;
+ if (rc[i] == 0)
+ { tnxtou[i] = tfstou[startn[i]];
+ tfstou[startn[i]] = i;
+ tnxtin[i] = tfstin[endn[i]];
+ tfstin[endn[i]] = i;
+ }
+ }
+L90: /* Initialize other variables. */
+ feasbl = true;
+ iter = 0;
+ nmultinode = 0;
+ num_augm = 0;
+ num_ascnt = 0;
+ num_passes = 0;
+ numnz = n;
+ numnz_new = 0;
+ svitch = false;
+ for (i = 1; i <= n; i++)
+ mark[i] = scan[i] = false;
+ nlabel = 0;
+ /* RELAX4 uses an adaptive strategy to decide whether to continue
+ * the scanning process after a multinode price change.
+ * The threshold parameter tp and ts that control this strategy
+ * are set in the next two lines. */
+ tp = 10;
+ ts = n / 15;
+ /* Initialize the queue of nodes with nonzero deficit. */
+ for (node = 1; node <= n - 1; node++)
+ nxtqueue[node] = node + 1;
+ nxtqueue[n] = 1;
+ node = lastqueue = n;
+ /*--------------------------------------------------------------*/
+ /* Start the relaxation algorithm. */
+L100: /* Code for advancing the queue of nonzero deficit nodes. */
+ prevnode = node;
+ node = nxtqueue[node];
+ defcit = dfct[node];
+ if (node == lastqueue)
+ { numnz = numnz_new;
+ numnz_new = 0;
+ lastqueue = prevnode;
+ num_passes++;
+ }
+ /* Code for deleting a node from the queue. */
+ if (defcit == 0)
+ { nxtnode = nxtqueue[node];
+ if (node == nxtnode)
+ return 0;
+ else
+ { nxtqueue[prevnode] = nxtnode;
+ nxtqueue[node] = 0;
+ node = nxtnode;
+ goto L100;
+ }
+ }
+ else
+ posit = (defcit > 0);
+ iter++;
+ numnz_new++;
+ if (posit)
+ { /* Attempt a single node iteration from node with positive
+ * deficit. */
+ pchange = false;
+ indef = defcit;
+ delx = 0;
+ nb = 0;
+ /* Check outgoing (probably) balanced arcs from node. */
+ for (arc = tfstou[node]; arc > 0; arc = tnxtou[arc])
+ { if ((rc[arc] == 0) && (x[arc] > 0))
+ { delx += x[arc];
+ nb++;
+ save[nb] = arc;
+ }
+ }
+ /* Check incoming arcs. */
+ for (arc = tfstin[node]; arc > 0; arc = tnxtin[arc])
+ { if ((rc[arc] == 0) && (u[arc] > 0))
+ { delx += u[arc];
+ nb++;
+ save[nb] = -arc;
+ }
+ }
+ /* End of initial node scan. */
+L4018: /* If no price change is possible, exit. */
+ if (delx > defcit)
+ { quit = (defcit < indef);
+ goto L4016;
+ }
+ /* RELAX4 searches along the ascent direction for the best
+ * price by checking the slope of the dual cost at successive
+ * break points. First, we compute the distance to the next
+ * break point. */
+ delprc = large;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { rdcost = rc[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { rdcost = rc[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ /* Check if problem is infeasible. */
+ if ((delx < defcit) && (delprc == large))
+ { /* The dual cost can be decreased without bound. */
+ return 6;
+ }
+ /* Skip flow adjustment if there is no flow to modify. */
+ if (delx == 0)
+ goto L4014;
+ /* Adjust the flow on the balanced arcs incident to node to
+ * maintain complementary slackness after the price change. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc > 0)
+ { node2 = endn[arc];
+ t1 = x[arc];
+ dfct[node2] += t1;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ u[arc] += t1;
+ x[arc] = 0;
+ }
+ else
+ { narc = -arc;
+ node2 = startn[narc];
+ t1 = u[narc];
+ dfct[node2] += t1;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[narc] += t1;
+ u[narc] = 0;
+ }
+ }
+ defcit -= delx;
+L4014: if (delprc == large)
+ { quit = true;
+ goto L4019;
+ }
+ /* Node corresponds to a dual ascent direction. Decrease the
+ * price of node by delprc and compute the stepsize to the next
+ * breakpoint in the dual cost. */
+ nb = 0;
+ pchange = true;
+ dp = delprc;
+ delprc = large;
+ delx = 0;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { rdcost = rc[arc] + dp;
+ rc[arc] = rdcost;
+ if (rdcost == 0)
+ { nb++;
+ save[nb] = arc;
+ delx += x[arc];
+ }
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { rdcost = rc[arc] - dp;
+ rc[arc] = rdcost;
+ if (rdcost == 0)
+ { nb++;
+ save[nb] = -arc;
+ delx += u[arc];
+ }
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ /* Return to check if another price change is possible. */
+ goto L4018;
+L4016: /* Perform flow augmentation at node. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc > 0)
+ { /* arc is an outgoing arc from node. */
+ node2 = endn[arc];
+ t1 = dfct[node2];
+ if (t1 < 0)
+ { /* Decrease the total deficit by decreasing flow of
+ * arc. */
+ quit = true;
+ t2 = x[arc];
+ dx = defcit;
+ if (dx > -t1) dx = -t1;
+ if (dx > t2) dx = t2;
+ defcit -= dx;
+ dfct[node2] = t1 + dx;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[arc] = t2 - dx;
+ u[arc] += dx;
+ if (defcit == 0)
+ break;
+ }
+ }
+ else
+ { /* -arc is an incoming arc to node. */
+ narc = -arc;
+ node2 = startn[narc];
+ t1 = dfct[node2];
+ if (t1 < 0)
+ { /* Decrease the total deficit by increasing flow of
+ * -arc. */
+ quit = true;
+ t2 = u[narc];
+ dx = defcit;
+ if (dx > -t1) dx = -t1;
+ if (dx > t2) dx = t2;
+ defcit -= dx;
+ dfct[node2] = t1 + dx;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[narc] += dx;
+ u[narc] = t2 - dx;
+ if (defcit == 0)
+ break;
+ }
+ }
+ }
+L4019: dfct[node] = defcit;
+ /* Reconstruct the linked list of balance arcs incident to this
+ * node. For each adjacent node, we add any newly balanced arcs
+ * to the list, but do not bother removing formerly balanced
+ * ones (they will be removed the next time each adjacent node
+ * is scanned). */
+ if (pchange)
+ { arc = tfstou[node];
+ tfstou[node] = 0;
+ while (arc > 0)
+ { nxtarc = tnxtou[arc];
+ tnxtou[arc] = -1;
+ arc = nxtarc;
+ }
+ arc = tfstin[node];
+ tfstin[node] = 0;
+ while (arc > 0)
+ { nxtarc = tnxtin[arc];
+ tnxtin[arc] = -1;
+ arc = nxtarc;
+ }
+ /* Now add the currently balanced arcs to the list for this
+ * node (which is now empty), and the appropriate adjacent
+ * ones. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc < 0)
+ arc = -arc;
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[startn[arc]];
+ tfstou[startn[arc]] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[endn[arc]];
+ tfstin[endn[arc]] = arc;
+ }
+ }
+ }
+ /* End of single node iteration for positive deficit node. */
+ }
+ else
+ { /* Attempt a single node iteration from node with negative
+ * deficit. */
+ pchange = false;
+ defcit = -defcit;
+ indef = defcit;
+ delx = 0;
+ nb = 0;
+ for (arc = tfstin[node]; arc > 0; arc = tnxtin[arc])
+ { if ((rc[arc] == 0) && (x[arc] > 0))
+ { delx += x[arc];
+ nb++;
+ save[nb] = arc;
+ }
+ }
+ for (arc = tfstou[node]; arc > 0; arc = tnxtou[arc])
+ { if ((rc[arc] == 0) && (u[arc] > 0))
+ { delx += u[arc];
+ nb++;
+ save[nb] = -arc;
+ }
+ }
+L4028: if (delx >= defcit)
+ { quit = (defcit < indef);
+ goto L4026;
+ }
+ /* Compute distance to next breakpoint. */
+ delprc = large;
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { rdcost = rc[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { rdcost = rc[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ /* Check if problem is infeasible. */
+ if ((delx < defcit) && (delprc == large))
+ return 7;
+ if (delx == 0)
+ goto L4024;
+ /* Flow augmentation is possible. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc > 0)
+ { node2 = startn[arc];
+ t1 = x[arc];
+ dfct[node2] -= t1;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ u[arc] += t1;
+ x[arc] = 0;
+ }
+ else
+ { narc = -arc;
+ node2 = endn[narc];
+ t1 = u[narc];
+ dfct[node2] -= t1;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[narc] += t1;
+ u[narc] = 0;
+ }
+ }
+ defcit -= delx;
+L4024: if (delprc == large)
+ { quit = true;
+ goto L4029;
+ }
+ /* Price increase at node is possible. */
+ nb = 0;
+ pchange = true;
+ dp = delprc;
+ delprc = large;
+ delx = 0;
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { rdcost = rc[arc] + dp;
+ rc[arc] = rdcost;
+ if (rdcost == 0)
+ { nb++;
+ save[nb] = arc;
+ delx += x[arc];
+ }
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { rdcost = rc[arc] - dp;
+ rc[arc] = rdcost;
+ if (rdcost == 0)
+ { nb++;
+ save[nb] = -arc;
+ delx += u[arc];
+ }
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ goto L4028;
+L4026: /* Perform flow augmentation at node. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc > 0)
+ { /* arc is an incoming arc to node. */
+ node2 = startn[arc];
+ t1 = dfct[node2];
+ if (t1 > 0)
+ { quit = true;
+ t2 = x[arc];
+ dx = defcit;
+ if (dx > t1) dx = t1;
+ if (dx > t2) dx = t2;
+ defcit -= dx;
+ dfct[node2] = t1 - dx;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[arc] = t2 - dx;
+ u[arc] += dx;
+ if (defcit == 0)
+ break;
+ }
+ }
+ else
+ { /* -arc is an outgoing arc from node. */
+ narc = -arc;
+ node2 = endn[narc];
+ t1 = dfct[node2];
+ if (t1 > 0)
+ { quit = true;
+ t2 = u[narc];
+ dx = defcit;
+ if (dx > t1) dx = t1;
+ if (dx > t2) dx = t2;
+ defcit -= dx;
+ dfct[node2] = t1 - dx;
+ if (nxtqueue[node2] == 0)
+ { nxtqueue[prevnode] = node2;
+ nxtqueue[node2] = node;
+ prevnode = node2;
+ }
+ x[narc] += dx;
+ u[narc] = t2 - dx;
+ if (defcit == 0)
+ break;
+ }
+ }
+ }
+L4029: dfct[node] = -defcit;
+ /* Reconstruct the list of balanced arcs incident to node. */
+ if (pchange)
+ { arc = tfstou[node];
+ tfstou[node] = 0;
+ while (arc > 0)
+ { nxtarc = tnxtou[arc];
+ tnxtou[arc] = -1;
+ arc = nxtarc;
+ }
+ arc = tfstin[node];
+ tfstin[node] = 0;
+ while (arc > 0)
+ { nxtarc = tnxtin[arc];
+ tnxtin[arc] = -1;
+ arc = nxtarc;
+ }
+ /* Now add the currently balanced arcs to the list for this
+ * node (which is now empty), and the appropriate adjacent
+ * ones. */
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc <= 0)
+ arc = -arc;
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[startn[arc]];
+ tfstou[startn[arc]] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[endn[arc]];
+ tfstin[endn[arc]] = arc;
+ }
+ }
+ }
+ /* End of single node iteration for a negative deficit node. */
+ }
+ if (quit || (num_passes <= 3))
+ goto L100;
+ /* Do a multinode iteration from node. */
+ nmultinode++;
+ /* If number of nonzero deficit nodes is small, continue labeling
+ * until a flow augmentation is done. */
+ svitch = (numnz < tp);
+ /* Unmark nodes labeled earlier. */
+ for (j = 1; j <= nlabel; j++)
+ { node2 = label[j];
+ mark[node2] = scan[node2] = false;
+ }
+ /* Initialize labeling. */
+ nlabel = 1;
+ label[1] = node;
+ mark[node] = true;
+ prdcsr[node] = 0;
+ /* Scan starting node. */
+ scan[node] = true;
+ nscan = 1;
+ dm = dfct[node];
+ delx = 0;
+ for (j = 1; j <= nb; j++)
+ { arc = save[j];
+ if (arc > 0)
+ { if (posit)
+ node2 = endn[arc];
+ else
+ node2 = startn[arc];
+ if (!mark[node2])
+ { nlabel++;
+ label[nlabel] = node2;
+ prdcsr[node2] = arc;
+ mark[node2] = true;
+ delx += x[arc];
+ }
+ }
+ else
+ { narc = -arc;
+ if (posit)
+ node2 = startn[narc];
+ else
+ node2 = endn[narc];
+ if (!mark[node2])
+ { nlabel++;
+ label[nlabel] = node2;
+ prdcsr[node2] = arc;
+ mark[node2] = true;
+ delx += u[narc];
+ }
+ }
+ }
+L4120:/* Start scanning a labeled but unscanned node. */
+ nscan++;
+ /* Check to see if switch needs to be set to true so to continue
+ * scanning even after a price change. */
+ svitch = svitch || ((nscan > ts) && (numnz < ts));
+ /* Scanning will continue until either an overestimate of the
+ * residual capacity across the cut corresponding to the scanned
+ * set of nodes (called delx) exceeds the absolute value of the
+ * total deficit of the scanned nodes (called dm), or else an
+ * augmenting path is found. Arcs that are in the tree but are not
+ * balanced are removed as part of the scanning process. */
+ i = label[nscan];
+ scan[i] = true;
+ naugnod = 0;
+ if (posit)
+ { /* Scanning node i in case of positive deficit. */
+ prvarc = 0;
+ arc = tfstou[i];
+ while (arc > 0)
+ { /* arc is an outgoing arc from node. */
+ if (rc[arc] == 0)
+ { if (x[arc] > 0)
+ { node2 = endn[arc];
+ if (!mark[node2])
+ { /* node2 is not labeled, so add node2 to the
+ labeled set. */
+ prdcsr[node2] = arc;
+ if (dfct[node2] < 0)
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ delx += x[arc];
+ }
+ }
+ prvarc = arc;
+ arc = tnxtou[arc];
+ }
+ else
+ { tmparc = arc;
+ arc = tnxtou[arc];
+ tnxtou[tmparc] = -1;
+ if (prvarc == 0)
+ tfstou[i] = arc;
+ else
+ tnxtou[prvarc] = arc;
+ }
+ }
+ prvarc = 0;
+ arc = tfstin[i];
+ while (arc > 0)
+ { /* arc is an incoming arc into node. */
+ if (rc[arc] == 0)
+ { if (u[arc] > 0)
+ { node2 = startn[arc];
+ if (!mark[node2])
+ { /* node2 is not labeled, so add node2 to the
+ * labeled set. */
+ prdcsr[node2] = -arc;
+ if (dfct[node2] < 0)
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ delx += u[arc];
+ }
+ }
+ prvarc = arc;
+ arc = tnxtin[arc];
+ }
+ else
+ { tmparc = arc;
+ arc = tnxtin[arc];
+ tnxtin[tmparc] = -1;
+ if (prvarc == 0)
+ tfstin[i] = arc;
+ else
+ tnxtin[prvarc] = arc;
+ }
+ }
+ /* Correct the residual capacity of the scanned node cut. */
+ arc = prdcsr[i];
+ if (arc > 0)
+ delx -= x[arc];
+ else
+ delx -= u[-arc];
+ /* End of scanning of node i for positive deficit case. */
+ }
+ else
+ { /* Scanning node i for negative deficit case. */
+ prvarc = 0;
+ arc = tfstin[i];
+ while (arc > 0)
+ { if (rc[arc] == 0)
+ { if (x[arc] > 0)
+ { node2 = startn[arc];
+ if (!mark[node2])
+ { prdcsr[node2] = arc;
+ if (dfct[node2] > 0)
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ delx += x[arc];
+ }
+ }
+ prvarc = arc;
+ arc = tnxtin[arc];
+ }
+ else
+ { tmparc = arc;
+ arc = tnxtin[arc];
+ tnxtin[tmparc] = -1;
+ if (prvarc == 0)
+ tfstin[i] = arc;
+ else
+ tnxtin[prvarc] = arc;
+ }
+ }
+ prvarc = 0;
+ arc = tfstou[i];
+ while (arc > 0)
+ { if (rc[arc] == 0)
+ { if (u[arc] > 0)
+ { node2 = endn[arc];
+ if (!mark[node2])
+ { prdcsr[node2] = -arc;
+ if (dfct[node2] > 0)
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ delx += u[arc];
+ }
+ }
+ prvarc = arc;
+ arc = tnxtou[arc];
+ }
+ else
+ { tmparc = arc;
+ arc = tnxtou[arc];
+ tnxtou[tmparc] = -1;
+ if (prvarc == 0)
+ tfstou[i] = arc;
+ else
+ tnxtou[prvarc] = arc;
+ }
+ }
+ arc = prdcsr[i];
+ if (arc > 0)
+ delx -= x[arc];
+ else
+ delx -= u[-arc];
+ }
+ /* Add deficit of node scanned to dm. */
+ dm += dfct[i];
+ /* Check if the set of scanned nodes correspond to a dual ascent
+ * direction; if yes, perform a price adjustment step, otherwise
+ * continue labeling. */
+ if (nscan < nlabel)
+ { if (svitch)
+ goto L4210;
+ if ((delx >= dm) && (delx >= -dm))
+ goto L4210;
+ }
+ /* Try a price change.
+ * [Note that since delx - abs(dm) is an overestimate of ascent
+ * slope, we may occasionally try a direction that is not an
+ * ascent direction. In this case the ascnt routines return with
+ * quit = false, so we continue labeling nodes.] */
+ if (posit)
+ { ascnt1(csa, dm, &delx, &nlabel, &feasbl, &svitch, nscan, node,
+ &prevnode);
+ num_ascnt++;
+ }
+ else
+ { ascnt2(csa, dm, &delx, &nlabel, &feasbl, &svitch, nscan, node,
+ &prevnode);
+ num_ascnt++;
+ }
+ if (!feasbl)
+ return 8;
+ if (!svitch)
+ goto L100;
+ /* Store those newly labeled nodes to which flow augmentation is
+ * possible. */
+ naugnod = 0;
+ for (j = nscan + 1; j <= nlabel; j++)
+ { node2 = label[j];
+ if (posit && (dfct[node2] < 0))
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ else if ((!posit) && (dfct[node2] > 0))
+ { naugnod++;
+ save[naugnod] = node2;
+ }
+ }
+L4210:/* Check if flow augmentation is possible. If not, return to scan
+ * another node. */
+ if (naugnod == 0)
+ goto L4120;
+ for (j = 1; j <= naugnod; j++)
+ { num_augm++;
+ augnod = save[j];
+ if (posit)
+ { /* Do the augmentation from node with positive deficit. */
+ dx = -dfct[augnod];
+ ib = augnod;
+ while (ib != node)
+ { arc = prdcsr[ib];
+ if (arc > 0)
+ { if (dx > x[arc]) dx = x[arc];
+ ib = startn[arc];
+ }
+ else
+ { if (dx > u[-arc]) dx = u[-arc];
+ ib = endn[-arc];
+ }
+ }
+ if (dx > dfct[node]) dx = dfct[node];
+ if (dx > 0)
+ { /* Increase (decrease) the flow of all forward (backward)
+ * arcs in the flow augmenting path. Adjust node deficit
+ * accordingly. */
+ if (nxtqueue[augnod] == 0)
+ { nxtqueue[prevnode] = augnod;
+ nxtqueue[augnod] = node;
+ prevnode = augnod;
+ }
+ dfct[augnod] += dx;
+ dfct[node] -= dx;
+ ib = augnod;
+ while (ib != node)
+ { arc = prdcsr[ib];
+ if (arc > 0)
+ { x[arc] -= dx;
+ u[arc] += dx;
+ ib = startn[arc];
+ }
+ else
+ { narc = -arc;
+ x[narc] += dx;
+ u[narc] -= dx;
+ ib = endn[narc];
+ }
+ }
+ }
+ }
+ else
+ { /* Do the augmentation from node with negative deficit. */
+ dx = dfct[augnod];
+ ib = augnod;
+ while (ib != node)
+ { arc = prdcsr[ib];
+ if (arc > 0)
+ { if (dx > x[arc]) dx = x[arc];
+ ib = endn[arc];
+ }
+ else
+ { if (dx > u[-arc]) dx = u[-arc];
+ ib = startn[-arc];
+ }
+ }
+ if (dx > -dfct[node]) dx = -dfct[node];
+ if (dx > 0)
+ { /* Update the flow and deficits. */
+ if (nxtqueue[augnod] == 0)
+ { nxtqueue[prevnode] = augnod;
+ nxtqueue[augnod] = node;
+ prevnode = augnod;
+ }
+ dfct[augnod] -= dx;
+ dfct[node] += dx;
+ ib = augnod;
+ while (ib != node)
+ { arc = prdcsr[ib];
+ if (arc > 0)
+ { x[arc] -= dx;
+ u[arc] += dx;
+ ib = endn[arc];
+ }
+ else
+ { narc = -arc;
+ x[narc] += dx;
+ u[narc] -= dx;
+ ib = startn[narc];
+ }
+ }
+ }
+ }
+ if (dfct[node] == 0)
+ goto L100;
+ if (dfct[augnod] != 0)
+ svitch = false;
+ }
+ /* If node still has nonzero deficit and all newly labeled nodes
+ * have same sign for their deficit as node, we can continue
+ * labeling. In this case, continue labeling only when flow
+ * augmentation is done relatively infrequently. */
+ if (svitch && (iter > 8 * num_augm))
+ goto L4120;
+ /* Return to do another relaxation iteration. */
+ goto L100;
+# undef nmultinode
+# undef iter
+# undef num_augm
+# undef num_ascnt
+# undef nsp
+}
+
+/***********************************************************************
+* NAME
+*
+* relax4_inidat - construct linked lists for network topology
+*
+* PURPOSE
+*
+* This routine constructs two linked lists for the network topology:
+* one list (given by fou, nxtou) for the outgoing arcs of nodes and
+* one list (given by fin, nxtin) for the incoming arcs of nodes. These
+* two lists are required by RELAX4.
+*
+* INPUT PARAMETERS
+*
+* n = number of nodes
+* na = number of arcs
+* startn[j] = starting node for arc j, j = 1,...,na
+* endn[j] = ending node for arc j, j = 1,...,na
+*
+* OUTPUT PARAMETERS
+*
+* fou[i] = first arc out of node i, i = 1,...,n
+* nxtou[j] = next arc out of the starting node of arc j, j = 1,...,na
+* fin[i] = first arc into node i, i = 1,...,n
+* nxtin[j] = next arc into the ending node of arc j, j = 1,...,na
+*
+* WORKING PARAMETERS
+*
+* tempin[1+n], tempou[1+n] */
+
+void relax4_inidat(struct relax4_csa *csa)
+{ /* input parameters */
+ int n = csa->n;
+ int na = csa->na;
+ int *startn = csa->startn;
+ int *endn = csa->endn;
+ /* output parameters */
+ int *fou = csa->fou;
+ int *nxtou = csa->nxtou;
+ int *fin = csa->fin;
+ int *nxtin = csa->nxtin;
+ /* working parameters */
+ int *tempin = csa->label;
+ int *tempou = csa->prdcsr;
+ /* local variables */
+ int i, i1, i2;
+ for (i = 1; i <= n; i++)
+ { fin[i] = fou[i] = 0;
+ tempin[i] = tempou[i] = 0;
+ }
+ for (i = 1; i <= na; i++)
+ { nxtin[i] = nxtou[i] = 0;
+ i1 = startn[i];
+ i2 = endn[i];
+ if (fou[i1] != 0)
+ nxtou[tempou[i1]] = i;
+ else
+ fou[i1] = i;
+ tempou[i1] = i;
+ if (fin[i2] != 0)
+ nxtin[tempin[i2]] = i;
+ else
+ fin[i2] = i;
+ tempin[i2] = i;
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* ascnt1 - multi-node price adjustment for positive deficit case
+*
+* PURPOSE
+*
+* This subroutine performs the multi-node price adjustment step for
+* the case where the scanned nodes have positive deficit. It first
+* checks if decreasing the price of the scanned nodes increases the
+* dual cost. If yes, then it decreases the price of all scanned nodes.
+* There are two possibilities for price decrease: if switch = true,
+* then the set of scanned nodes corresponds to an elementary direction
+* of maximal rate of ascent, in which case the price of all scanned
+* nodes are decreased until the next breakpoint in the dual cost is
+* encountered. At this point, some arc becomes balanced and more
+* node(s) are added to the labeled set and the subroutine is exited.
+* If switch = false, then the price of all scanned nodes are decreased
+* until the rate of ascent becomes negative (this corresponds to the
+* price adjustment step in which both the line search and the
+* degenerate ascent iteration are implemented).
+*
+* INPUT PARAMETERS
+*
+* dm = total deficit of scanned nodes
+* switch = true if labeling is to continue after price change
+* nscan = number of scanned nodes
+* curnode = most recently scanned node
+* n = number of nodes
+* na = number of arcs
+* large = a very large integer to represent infinity (see note 3)
+* startn[i] = starting node for the i-th arc, i = 1,...,na
+* endn[i] = ending node for the i-th arc, i = 1,...,na
+* fou[i] = first arc leaving i-th node, i = 1,...,n
+* nxtou[i] = next arc leaving the starting node of j-th arc,
+* i = 1,...,na
+* fin[i] = first arc entering i-th node, i = 1,...,n
+* nxtin[i] = next arc entering the ending node of j-th arc,
+* i = 1,...,na
+*
+* UPDATED PARAMETERS
+*
+* delx = a lower estimate of the total flow on balanced arcs in
+* the scanned-nodes cut
+* nlabel = number of labeled nodes
+* feasbl = false if problem is found to be infeasible
+* prevnode = the node before curnode in queue
+* rc[j] = reduced cost of arc j, j = 1,...,na
+* u[j] = residual capacity of arc j, j = 1,...,na
+* x[j] = flow on arc j, j = 1,...,na
+* dfct[i] = deficit at node i, i = 1,...,n
+* label[k] = k-th node labeled, k = 1,...,nlabel
+* prdcsr[i] = predecessor of node i in tree of labeled nodes (0 if i
+* is unlabeled), i = 1,...,n
+* tfstou[i] = first balanced arc out of node i, i = 1,...,n
+* tnxtou[j] = next balanced arc out of the starting node of arc j,
+* j = 1,...,na
+* tfstin[i] = first balanced arc into node i, i = 1,...,n
+* tnxtin[j] = next balanced arc into the ending node of arc j,
+* j = 1,...,na
+* nxtqueue[i] = node following node i in the fifo queue (0 if node is
+* not in the queue), i = 1,...,n
+* scan[i] = true if node i is scanned, i = 1,...,n
+* mark[i] = true if node i is labeled, i = 1,...,n
+*
+* WORKING PARAMETERS
+*
+* save[1+na] */
+
+static void ascnt1(struct relax4_csa *csa, int dm, int *delx,
+ int *nlabel, int *feasbl, int *svitch, int nscan, int curnode,
+ int *prevnode)
+{ /* input parameters */
+ int n = csa->n;
+ /* int na = csa->na; */
+ int large = csa->large;
+ int *startn = csa->startn;
+ int *endn = csa->endn;
+ int *fou = csa->fou;
+ int *nxtou = csa->nxtou;
+ int *fin = csa->fin;
+ int *nxtin = csa->nxtin;
+ /* updated parameters */
+# define delx (*delx)
+# define nlabel (*nlabel)
+# define feasbl (*feasbl)
+# define svitch (*svitch)
+# define prevnode (*prevnode)
+ int *rc = csa->rc;
+ int *u = csa->u;
+ int *x = csa->x;
+ int *dfct = csa->dfct;
+ int *label = csa->label;
+ int *prdcsr = csa->prdcsr;
+ int *tfstou = csa->tfstou;
+ int *tnxtou = csa->tnxtou;
+ int *tfstin = csa->tfstin;
+ int *tnxtin = csa->tnxtin;
+ int *nxtqueue = csa->nxtqueue;
+ char *scan = csa->scan;
+ char *mark = csa->mark;
+ int *save = csa->save;
+ /* local variables */
+ int arc, delprc, dlx, i, j, nb, node, node2, nsave, rdcost, t1,
+ t2, t3;
+ /* Store the arcs between the set of scanned nodes and its
+ * complement in save and compute delprc, the stepsize to the next
+ * breakpoint in the dual cost in the direction of decreasing
+ * prices of the scanned nodes.
+ * [The arcs are stored into save by looking at the arcs incident
+ * to either the set of scanned nodes or its complement, depending
+ * on whether nscan > n/2 or not. This improves the efficiency of
+ * storing.] */
+ delprc = large;
+ dlx = 0;
+ nsave = 0;
+ if (nscan <= n / 2)
+ { for (i = 1; i <= nscan; i++)
+ { node = label[i];
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { /* arc points from scanned node to an unscanned node. */
+ node2 = endn[arc];
+ if (!scan[node2])
+ { nsave++;
+ save[nsave] = arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node2] != arc))
+ dlx += x[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { /* arc points from unscanned node to scanned node. */
+ node2 = startn[arc];
+ if (!scan[node2])
+ { nsave++;
+ save[nsave] = -arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node2] != -arc))
+ dlx += u[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ }
+ }
+ else
+ { for (node = 1; node <= n; node++)
+ { if (scan[node])
+ continue;
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { node2 = startn[arc];
+ if (scan[node2])
+ { nsave++;
+ save[nsave] = arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node] != arc))
+ dlx += x[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ }
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { node2 = endn[arc];
+ if (scan[node2])
+ { nsave++;
+ save[nsave] = -arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node] != -arc))
+ dlx += u[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ }
+ }
+ /* Check if the set of scanned nodes truly corresponds to a dual
+ * ascent direction. [Here delx + dlx is the exact sum of the flow
+ * on arcs from the scanned set to the unscanned set plus the
+ * (capacity - flow) on arcs from the unscanned set to the scanned
+ * set.] If this were not the case, set switch to true and exit
+ * subroutine. */
+ if ((!svitch) && (delx + dlx >= dm))
+ { svitch = true;
+ return;
+ }
+ delx += dlx;
+L4: /* Check that the problem is feasible. */
+ if (delprc == large)
+ { /* We can increase the dual cost without bound, so the primal
+ * problem is infeasible. */
+ feasbl = false;
+ return;
+ }
+ /* Decrease the prices of the scanned nodes, add more nodes to
+ * the labeled set and check if a newly labeled node has negative
+ * deficit. */
+ if (svitch)
+ { for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { rc[arc] += delprc;
+ if (rc[arc] == 0)
+ { node2 = endn[arc];
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[startn[arc]];
+ tfstou[startn[arc]] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[node2];
+ tfstin[node2] = arc;
+ }
+ if (!mark[node2])
+ { prdcsr[node2] = arc;
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ }
+ }
+ }
+ else
+ { arc = -arc;
+ rc[arc] -= delprc;
+ if (rc[arc] == 0)
+ { node2 = startn[arc];
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[node2];
+ tfstou[node2] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[endn[arc]];
+ tfstin[endn[arc]] = arc;
+ }
+ if (!mark[node2])
+ { prdcsr[node2] = -arc;
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ }
+ }
+ }
+ }
+ return;
+ }
+ else
+ { /* Decrease the prices of the scanned nodes by delprc. Adjust
+ * flow to maintain complementary slackness with the prices. */
+ nb = 0;
+ for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { t1 = rc[arc];
+ if (t1 == 0)
+ { t2 = x[arc];
+ t3 = startn[arc];
+ dfct[t3] -= t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ t3 = endn[arc];
+ dfct[t3] += t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ u[arc] += t2;
+ x[arc] = 0;
+ }
+ rc[arc] = t1 + delprc;
+#if 0 /* by mao; 26/IV-2013 */
+ if (rc[arc] == 0)
+#else
+ if (rc[arc] == 0 && nb < n)
+#endif
+ { delx += x[arc];
+ nb++;
+ prdcsr[nb] = arc;
+ }
+ }
+ else
+ { arc = -arc;
+ t1 = rc[arc];
+ if (t1 == 0)
+ { t2 = u[arc];
+ t3 = startn[arc];
+ dfct[t3] += t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ t3 = endn[arc];
+ dfct[t3] -= t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ x[arc] += t2;
+ u[arc] = 0;
+ }
+ rc[arc] = t1 - delprc;
+#if 0 /* by mao; 26/IV-2013 */
+ if (rc[arc] == 0)
+#else
+ if (rc[arc] == 0 && nb < n)
+#endif
+ { delx += u[arc];
+ nb++;
+ prdcsr[nb] = arc;
+ }
+ }
+ }
+ }
+ if (delx <= dm)
+ { /* The set of scanned nodes still corresponds to a dual
+ * (possibly degenerate) ascent direction. Compute the stepsize
+ * delprc to the next breakpoint in the dual cost. */
+ delprc = large;
+ for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { rdcost = rc[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ else
+ { arc = -arc;
+ rdcost = rc[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ if ((delprc != large) || (delx < dm))
+ goto L4;
+ }
+ /* Add new balanced arcs to the superset of balanced arcs. */
+ for (i = 1; i <= nb; i++)
+ { arc = prdcsr[i];
+ if (tnxtin[arc] == -1)
+ { j = endn[arc];
+ tnxtin[arc] = tfstin[j];
+ tfstin[j] = arc;
+ }
+ if (tnxtou[arc] == -1)
+ { j = startn[arc];
+ tnxtou[arc] = tfstou[j];
+ tfstou[j] = arc;
+ }
+ }
+ return;
+# undef delx
+# undef nlabel
+# undef feasbl
+# undef svitch
+# undef prevnode
+}
+
+/***********************************************************************
+* NAME
+*
+* ascnt2 - multi-node price adjustment for negative deficit case
+*
+* PURPOSE
+*
+* This routine is analogous to ascnt1 but for the case where the
+* scanned nodes have negative deficit. */
+
+static void ascnt2(struct relax4_csa *csa, int dm, int *delx,
+ int *nlabel, int *feasbl, int *svitch, int nscan, int curnode,
+ int *prevnode)
+{ /* input parameters */
+ int n = csa->n;
+ /* int na = csa->na; */
+ int large = csa->large;
+ int *startn = csa->startn;
+ int *endn = csa->endn;
+ int *fou = csa->fou;
+ int *nxtou = csa->nxtou;
+ int *fin = csa->fin;
+ int *nxtin = csa->nxtin;
+ /* updated parameters */
+# define delx (*delx)
+# define nlabel (*nlabel)
+# define feasbl (*feasbl)
+# define svitch (*svitch)
+# define prevnode (*prevnode)
+ int *rc = csa->rc;
+ int *u = csa->u;
+ int *x = csa->x;
+ int *dfct = csa->dfct;
+ int *label = csa->label;
+ int *prdcsr = csa->prdcsr;
+ int *tfstou = csa->tfstou;
+ int *tnxtou = csa->tnxtou;
+ int *tfstin = csa->tfstin;
+ int *tnxtin = csa->tnxtin;
+ int *nxtqueue = csa->nxtqueue;
+ char *scan = csa->scan;
+ char *mark = csa->mark;
+ int *save = csa->save;
+ /* local variables */
+ int arc, delprc, dlx, i, j, nb, node, node2, nsave, rdcost, t1,
+ t2, t3;
+ /* Store the arcs between the set of scanned nodes and its
+ * complement in save and compute delprc, the stepsize to the next
+ * breakpoint in the dual cost in the direction of increasing
+ * prices of the scanned nodes. */
+ delprc = large;
+ dlx = 0;
+ nsave = 0;
+ if (nscan <= n / 2)
+ { for (i = 1; i <= nscan; i++)
+ { node = label[i];
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { node2 = startn[arc];
+ if (!scan[node2])
+ { nsave++;
+ save[nsave] = arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node2] != arc))
+ dlx += x[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ }
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { node2 = endn[arc];
+ if (!scan[node2])
+ { nsave++;
+ save[nsave] = -arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node2] != -arc))
+ dlx += u[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ }
+ }
+ else
+ { for (node = 1; node <= n; node++)
+ { if (scan[node])
+ continue;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { node2 = endn[arc];
+ if (scan[node2])
+ { nsave++;
+ save[nsave] = arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node] != arc))
+ dlx += x[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ }
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { node2 = startn[arc];
+ if (scan[node2])
+ { nsave++;
+ save[nsave] = -arc;
+ rdcost = rc[arc];
+ if ((rdcost == 0) && (prdcsr[node] != -arc))
+ dlx += u[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ }
+ }
+ if ((!svitch) && (delx + dlx >= -dm))
+ { svitch = true;
+ return;
+ }
+ delx += dlx;
+ /* Check that the problem is feasible. */
+L4: if (delprc == large)
+ { feasbl = false;
+ return;
+ }
+ /* Increase the prices of the scanned nodes, add more nodes to
+ * the labeled set and check if a newly labeled node has positive
+ * deficit. */
+ if (svitch)
+ { for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { rc[arc] += delprc;
+ if (rc[arc] == 0)
+ { node2 = startn[arc];
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[node2];
+ tfstou[node2] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[endn[arc]];
+ tfstin[endn[arc]] = arc;
+ }
+ if (!mark[node2])
+ { prdcsr[node2] = arc;
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ }
+ }
+ }
+ else
+ { arc = -arc;
+ rc[arc] -= delprc;
+ if (rc[arc] == 0)
+ { node2 = endn[arc];
+ if (tnxtou[arc] < 0)
+ { tnxtou[arc] = tfstou[startn[arc]];
+ tfstou[startn[arc]] = arc;
+ }
+ if (tnxtin[arc] < 0)
+ { tnxtin[arc] = tfstin[node2];
+ tfstin[node2] = arc;
+ }
+ if (!mark[node2])
+ { prdcsr[node2] = -arc;
+ nlabel++;
+ label[nlabel] = node2;
+ mark[node2] = true;
+ }
+ }
+ }
+ }
+ return;
+ }
+ else
+ { nb = 0;
+ for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { t1 = rc[arc];
+ if (t1 == 0)
+ { t2 = x[arc];
+ t3 = startn[arc];
+ dfct[t3] -= t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ t3 = endn[arc];
+ dfct[t3] += t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ u[arc] += t2;
+ x[arc] = 0;
+ }
+ rc[arc] = t1 + delprc;
+#if 0 /* by mao; 26/IV-2013 */
+ if (rc[arc] == 0)
+#else
+ if (rc[arc] == 0 && nb < n)
+#endif
+ { delx += x[arc];
+ nb++;
+ prdcsr[nb] = arc;
+ }
+ }
+ else
+ { arc = -arc;
+ t1 = rc[arc];
+ if (t1 == 0)
+ { t2 = u[arc];
+ t3 = startn[arc];
+ dfct[t3] += t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ t3 = endn[arc];
+ dfct[t3] -= t2;
+ if (nxtqueue[t3] == 0)
+ { nxtqueue[prevnode] = t3;
+ nxtqueue[t3] = curnode;
+ prevnode = t3;
+ }
+ x[arc] += t2;
+ u[arc] = 0;
+ }
+ rc[arc] = t1 - delprc;
+#if 0 /* by mao; 26/IV-2013 */
+ if (rc[arc] == 0)
+#else
+ if (rc[arc] == 0 && nb < n)
+#endif
+ { delx += u[arc];
+ nb++;
+ prdcsr[nb] = arc;
+ }
+ }
+ }
+ }
+ if (delx <= -dm)
+ { delprc = large;
+ for (i = 1; i <= nsave; i++)
+ { arc = save[i];
+ if (arc > 0)
+ { rdcost = rc[arc];
+ if ((rdcost < 0) && (rdcost > -delprc))
+ delprc = -rdcost;
+ }
+ else
+ { arc = -arc;
+ rdcost = rc[arc];
+ if ((rdcost > 0) && (rdcost < delprc))
+ delprc = rdcost;
+ }
+ }
+ if ((delprc != large) || (delx < -dm))
+ goto L4;
+ }
+ /* Add new balanced arcs to the superset of balanced arcs. */
+ for (i = 1; i <= nb; i++)
+ { arc = prdcsr[i];
+ if (tnxtin[arc] == -1)
+ { j = endn[arc];
+ tnxtin[arc] = tfstin[j];
+ tfstin[j] = arc;
+ }
+ if (tnxtou[arc] == -1)
+ { j = startn[arc];
+ tnxtou[arc] = tfstou[j];
+ tfstou[j] = arc;
+ }
+ }
+ return;
+# undef delx
+# undef nlabel
+# undef feasbl
+# undef svitch
+# undef prevnode
+}
+
+/***********************************************************************
+* NAME
+*
+* auction - compute good initial flow and prices
+*
+* PURPOSE
+*
+* This subroutine uses a version of the auction algorithm for min
+* cost network flow to compute a good initial flow and prices for the
+* problem.
+*
+* INPUT PARAMETERS
+*
+* n = number of nodes
+* na = number of arcs
+* large = a very large integer to represent infinity (see note 3)
+* startn[i] = starting node for the i-th arc, i = 1,...,na
+* endn[i] = ending node for the i-th arc, i = 1,...,na
+* fou[i] = first arc leaving i-th node, i = 1,...,n
+* nxtou[i] = next arc leaving the starting node of j-th arc,
+* i = 1,...,na
+* fin[i] = first arc entering i-th node, i = 1,...,n
+* nxtin[i] = next arc entering the ending node of j-th arc,
+* i = 1,...,na
+*
+* UPDATED PARAMETERS
+*
+* rc[j] = reduced cost of arc j, j = 1,...,na
+* u[j] = residual capacity of arc j, j = 1,...,na
+* x[j] = flow on arc j, j = 1,...,na
+* dfct[i] = deficit at node i, i = 1,...,n
+*
+* OUTPUT PARAMETERS
+*
+* nsp = number of auction/shortest path iterations
+*
+* WORKING PARAMETERS
+*
+* p[1+n], prdcsr[1+n], save[1+na], fpushf[1+n], nxtpushf[1+na],
+* fpushb[1+n], nxtpushb[1+na], nxtqueue[1+n], extend_arc[1+n],
+* sb_level[1+n], sb_arc[1+n], path_id[1+n]
+*
+* RETURNS
+*
+* 0 = normal return
+* 1 = problem is found to be infeasible */
+
+static int auction(struct relax4_csa *csa)
+{ /* input parameters */
+ int n = csa->n;
+ int na = csa->na;
+ int large = csa->large;
+ int *startn = csa->startn;
+ int *endn = csa->endn;
+ int *fou = csa->fou;
+ int *nxtou = csa->nxtou;
+ int *fin = csa->fin;
+ int *nxtin = csa->nxtin;
+ /* updated parameters */
+# define crash (csa->crash)
+ int *rc = csa->rc;
+ int *u = csa->u;
+ int *x = csa->x;
+ int *dfct = csa->dfct;
+ /* output parameters */
+# define nsp (csa->nsp)
+ /* working parameters */
+ int *p = csa->label;
+ int *prdcsr = csa->prdcsr;
+ int *save = csa->save;
+ int *fpushf = csa->tfstou;
+ int *nxtpushf = csa->tnxtou;
+ int *fpushb = csa->tfstin;
+ int *nxtpushb = csa->tnxtin;
+ int *nxtqueue = csa->nxtqueue;
+ int *extend_arc = csa->extend_arc;
+ int *sb_level = csa->sb_level;
+ int *sb_arc = csa->sb_arc;
+ char *path_id = csa->mark;
+ /* local variables */
+ int arc, bstlevel, end, eps, extarc, factor, flow, i, incr,
+ last, lastqueue, maxcost, mincost, nas, naug, new_level, node,
+ nolist, num_passes, nxtnode, pass, pend, pr_term, prd,
+ prevarc, prevlevel, prevnode, pstart, pterm, rdcost, red_cost,
+ resid, root, secarc, seclevel, start, term, thresh_dfct;
+ /* start initialization using auction */
+ naug = 0;
+ pass = 0;
+ thresh_dfct = 0;
+ /* factor determines by how much epsilon is reduced at each
+ * minimization */
+ factor = 3;
+ /* num_passes determines how many auction scaling phases are
+ * performed */
+ num_passes = 1;
+ /* set arc flows to satisfy cs and calculate maxcost and
+ * mincost */
+ maxcost = -large;
+ mincost = large;
+ for (arc = 1; arc <= na; arc++)
+ { start = startn[arc];
+ end = endn[arc];
+ rdcost = rc[arc];
+ if (maxcost < rdcost)
+ maxcost = rdcost;
+ if (mincost > rdcost)
+ mincost = rdcost;
+ if (rdcost < 0)
+ { dfct[start] += u[arc];
+ dfct[end] -= u[arc];
+ x[arc] = u[arc];
+ u[arc] = 0;
+ }
+ else
+ x[arc] = 0;
+ }
+ /* set initial epsilon */
+ if ((maxcost - mincost) >= 8)
+ eps = (maxcost - mincost) / 8;
+ else
+ eps = 1;
+ /* set initial prices to zero */
+ for (node = 1; node <= n; node++)
+ p[node] = 0;
+ /* Initialization using auction/shortest paths. */
+L100: /* Start of the first scaling phase. */
+ pass++;
+ if ((pass == num_passes) || (eps == 1))
+ crash = 0;
+ nolist = 0;
+ /* construct list of positive surplus nodes and queue of negative
+ * surplus nodes */
+ for (node = 1; node <= n; node++)
+ { prdcsr[node] = 0;
+ path_id[node] = false;
+ extend_arc[node] = 0;
+ sb_level[node] = -large;
+ nxtqueue[node] = node + 1;
+ if (dfct[node] > 0)
+ { nolist++;
+ save[nolist] = node;
+ }
+ }
+ nxtqueue[n] = 1;
+ root = 1;
+ prevnode = lastqueue = n;
+ /* initialization with down iterations for negative surplus
+ * nodes */
+ for (i = 1; i <= nolist; i++)
+ { node = save[i];
+ nsp++;
+ /* build the list of arcs w/ room for pushing flow and find
+ * proper price for down iteration */
+ bstlevel = -large;
+ fpushf[node] = 0;
+ for (arc = fou[node]; arc > 0; arc = nxtou[arc])
+ { if (u[arc] > 0)
+ { if (fpushf[node] == 0)
+ { fpushf[node] = arc;
+ nxtpushf[arc] = 0;
+ last = arc;
+ }
+ else
+ { nxtpushf[last] = arc;
+ nxtpushf[arc] = 0;
+ last = arc;
+ }
+ }
+ if (x[arc] > 0)
+ { new_level = p[endn[arc]] + rc[arc];
+ if (new_level > bstlevel)
+ { bstlevel = new_level;
+ extarc = arc;
+ }
+ }
+ }
+ fpushb[node] = 0;
+ for (arc = fin[node]; arc > 0; arc = nxtin[arc])
+ { if (x[arc] > 0)
+ { if (fpushb[node] == 0)
+ { fpushb[node] = arc;
+ nxtpushb[arc] = 0;
+ last = arc;
+ }
+ else
+ { nxtpushb[last] = arc;
+ nxtpushb[arc] = 0;
+ last = arc;
+ }
+ }
+ if (u[arc] > 0)
+ { new_level = p[startn[arc]] - rc[arc];
+ if (new_level > bstlevel)
+ { bstlevel = new_level;
+ extarc = -arc;
+ }
+ }
+ }
+ extend_arc[node] = extarc;
+ p[node] = bstlevel - eps;
+ }
+L200: /* Start the augmentation cycles of the new scaling phase. */
+ if (dfct[root] >= thresh_dfct)
+ goto L3000;
+ term = root;
+ path_id[root] = true;
+L500: /* Main forward algorithm with root as origin. */
+ /* start of a new forward iteration */
+ pterm = p[term];
+ extarc = extend_arc[term];
+ if (extarc == 0)
+ { /* build the list of arcs w/ room for pushing flow */
+ fpushf[term] = 0;
+ for (arc = fou[term]; arc > 0; arc = nxtou[arc])
+ { if (u[arc] > 0)
+ { if (fpushf[term] == 0)
+ { fpushf[term] = arc;
+ nxtpushf[arc] = 0;
+ last = arc;
+ }
+ else
+ { nxtpushf[last] = arc;
+ nxtpushf[arc] = 0;
+ last = arc;
+ }
+ }
+ }
+ fpushb[term] = 0;
+ for (arc = fin[term]; arc > 0; arc = nxtin[arc])
+ { if (x[arc] > 0)
+ { if (fpushb[term] == 0)
+ { fpushb[term] = arc;
+ nxtpushb[arc] = 0;
+ last = arc;
+ }
+ else
+ { nxtpushb[last] = arc;
+ nxtpushb[arc] = 0;
+ last = arc;
+ }
+ }
+ }
+ goto L600;
+ }
+ /* speculative path extension attempt */
+ /* note: arc > 0 means that arc is oriented from the root to the
+ * destinations
+ * arc < 0 means that arc is oriented from the destinations to the
+ * root
+ * extarc = 0 or prdarc = 0, means the extension arc or the
+ * predecessor arc, respectively, has not been established */
+ if (extarc > 0)
+ { if (u[extarc] == 0)
+ { seclevel = sb_level[term];
+ goto L580;
+ }
+ end = endn[extarc];
+ bstlevel = p[end] + rc[extarc];
+ if (pterm >= bstlevel)
+ { if (path_id[end])
+ goto L1200;
+ term = end;
+ prdcsr[term] = extarc;
+ path_id[term] = true;
+ /* if negative surplus node is found, do an augmentation */
+ if (dfct[term] > 0)
+ goto L2000;
+ /* return for another iteration */
+ goto L500;
+ }
+ }
+ else
+ { extarc = -extarc;
+ if (x[extarc] == 0)
+ { seclevel = sb_level[term];
+ goto L580;
+ }
+ start = startn[extarc];
+ bstlevel = p[start] - rc[extarc];
+ if (pterm >= bstlevel)
+ { if (path_id[start])
+ goto L1200;
+ term = start;
+ prdcsr[term] = -extarc;
+ path_id[term] = true;
+ /* if negative surplus node is found, do an augmentation */
+ if (dfct[term] > 0)
+ goto L2000;
+ /* return for another iteration */
+ goto L500;
+ }
+ }
+L550: /* second best logic test applied to save a full node scan
+ * if old best level continues to be best go for another
+ * contraction */
+ seclevel = sb_level[term];
+ if (bstlevel <= seclevel)
+ goto L800;
+L580: /* if second best can be used do either a contraction or start
+ * over with a speculative extension */
+ if (seclevel > -large)
+ { extarc = sb_arc[term];
+ if (extarc > 0)
+ { if (u[extarc] == 0)
+ goto L600;
+ bstlevel = p[endn[extarc]] + rc[extarc];
+ }
+ else
+ { if (x[-extarc] == 0)
+ goto L600;
+ bstlevel = p[startn[-extarc]] - rc[-extarc];
+ }
+ if (bstlevel == seclevel)
+ { sb_level[term] = -large;
+ extend_arc[term] = extarc;
+ goto L800;
+ }
+ }
+L600: /* extension/contraction attempt was unsuccessful, so scan
+ * terminal node */
+ nsp++;
+ bstlevel = seclevel = large;
+ for (arc = fpushf[term]; arc > 0; arc = nxtpushf[arc])
+ { new_level = p[endn[arc]] + rc[arc];
+ if (new_level < seclevel)
+ { if (new_level < bstlevel)
+ { seclevel = bstlevel;
+ bstlevel = new_level;
+ secarc = extarc;
+ extarc = arc;
+ }
+ else
+ { seclevel = new_level;
+ secarc = arc;
+ }
+ }
+ }
+ for (arc = fpushb[term]; arc > 0; arc = nxtpushb[arc])
+ { new_level = p[startn[arc]] - rc[arc];
+ if (new_level < seclevel)
+ { if (new_level < bstlevel)
+ { seclevel = bstlevel;
+ bstlevel = new_level;
+ secarc = extarc;
+ extarc = -arc;
+ }
+ else
+ { seclevel = new_level;
+ secarc = -arc;
+ }
+ }
+ }
+ sb_level[term] = seclevel;
+ sb_arc[term] = secarc;
+ extend_arc[term] = extarc;
+L800: /* End of node scan. */
+ /* if the terminal node is the root, adjust its price and change
+ * root */
+ if (term == root)
+ { p[term] = bstlevel + eps;
+ if (p[term] >= large)
+ { /* no path to the destination */
+ /* problem is found to be infeasible */
+ return 1;
+ }
+ path_id[root] = false;
+ prevnode = root;
+ root = nxtqueue[root];
+ goto L200;
+ }
+ /* check whether extension or contraction */
+ prd = prdcsr[term];
+ if (prd > 0)
+ { pr_term = startn[prd];
+ prevlevel = p[pr_term] - rc[prd];
+ }
+ else
+ { pr_term = endn[-prd];
+ prevlevel = p[pr_term] + rc[-prd];
+ }
+ if (prevlevel > bstlevel)
+ { /* path extension */
+ if (prevlevel >= bstlevel + eps)
+ p[term] = bstlevel + eps;
+ else
+ p[term] = prevlevel;
+ if (extarc > 0)
+ { end = endn[extarc];
+ if (path_id[end])
+ goto L1200;
+ term = end;
+ }
+ else
+ { start = startn[-extarc];
+ if (path_id[start])
+ goto L1200;
+ term = start;
+ }
+ prdcsr[term] = extarc;
+ path_id[term] = true;
+ /* if negative surplus node is found, do an augmentation */
+ if (dfct[term] > 0)
+ goto L2000;
+ /* return for another iteration */
+ goto L500;
+ }
+ else
+ { /* path contraction */
+ p[term] = bstlevel + eps;
+ path_id[term] = false;
+ term = pr_term;
+ if (pr_term != root)
+ { if (bstlevel <= pterm + eps)
+ goto L2000;
+ }
+ pterm = p[term];
+ extarc = prd;
+ if (prd > 0)
+ bstlevel += eps + rc[prd];
+ else
+ bstlevel += eps - rc[-prd];
+ /* do a second best test and if that fails, do a full node
+ * scan */
+ goto L550;
+ }
+L1200:/* A cycle is about to form; do a retreat sequence. */
+ node = term;
+L1600:if (node != root)
+ { path_id[node] = false;
+ prd = prdcsr[node];
+ if (prd > 0)
+ { pr_term = startn[prd];
+ if (p[pr_term] == p[node] + rc[prd] + eps)
+ { node = pr_term;
+ goto L1600;
+ }
+ }
+ else
+ { pr_term = endn[-prd];
+ if (p[pr_term] == p[node] - rc[-prd] + eps)
+ { node = pr_term;
+ goto L1600;
+ }
+ }
+ /* do a full scan and price rise at pr_term */
+ nsp++;
+ bstlevel = seclevel = large;
+ for (arc = fpushf[pr_term]; arc > 0; arc = nxtpushf[arc])
+ { new_level = p[endn[arc]] + rc[arc];
+ if (new_level < seclevel)
+ { if (new_level < bstlevel)
+ { seclevel = bstlevel;
+ bstlevel = new_level;
+ secarc = extarc;
+ extarc = arc;
+ }
+ else
+ { seclevel = new_level;
+ secarc = arc;
+ }
+ }
+ }
+ for (arc = fpushb[pr_term]; arc > 0; arc = nxtpushb[arc])
+ { new_level = p[startn[arc]] - rc[arc];
+ if (new_level < seclevel)
+ { if (new_level < bstlevel)
+ { seclevel = bstlevel;
+ bstlevel = new_level;
+ secarc = extarc;
+ extarc = -arc;
+ }
+ else
+ { seclevel = new_level;
+ secarc = -arc;
+ }
+ }
+ }
+ sb_level[pr_term] = seclevel;
+ sb_arc[pr_term] = secarc;
+ extend_arc[pr_term] = extarc;
+ p[pr_term] = bstlevel + eps;
+ if (pr_term == root)
+ { prevnode = root;
+ path_id[root] = false;
+ root = nxtqueue[root];
+ goto L200;
+ }
+ path_id[pr_term] = false;
+ prd = prdcsr[pr_term];
+ if (prd > 0)
+ term = startn[prd];
+ else
+ term = endn[-prd];
+ if (term == root)
+ { prevnode = root;
+ path_id[root] = false;
+ root = nxtqueue[root];
+ goto L200;
+ }
+ else
+ goto L2000;
+ }
+L2000:/* End of auction/shortest path routine. */
+ /* do augmentation from root and correct the push lists */
+ incr = -dfct[root];
+ for (node = root;;)
+ { extarc = extend_arc[node];
+ path_id[node] = false;
+ if (extarc > 0)
+ { node = endn[extarc];
+ if (incr > u[extarc])
+ incr = u[extarc];
+ }
+ else
+ { node = startn[-extarc];
+ if (incr > x[-extarc])
+ incr = x[-extarc];
+ }
+ if (node == term)
+ break;
+ }
+ path_id[term] = false;
+ if (dfct[term] > 0)
+ { if (incr > dfct[term])
+ incr = dfct[term];
+ }
+ for (node = root;;)
+ { extarc = extend_arc[node];
+ if (extarc > 0)
+ { end = endn[extarc];
+ /* add arc to the reduced graph */
+ if (x[extarc] == 0)
+ { nxtpushb[extarc] = fpushb[end];
+ fpushb[end] = extarc;
+ new_level = p[node] - rc[extarc];
+ if (sb_level[end] > new_level)
+ { sb_level[end] = new_level;
+ sb_arc[end] = -extarc;
+ }
+ }
+ x[extarc] += incr;
+ u[extarc] -= incr;
+ /* remove arc from the reduced graph */
+ if (u[extarc] == 0)
+ { nas++;
+ arc = fpushf[node];
+ if (arc == extarc)
+ fpushf[node] = nxtpushf[arc];
+ else
+ { prevarc = arc;
+ arc = nxtpushf[arc];
+ while (arc > 0)
+ { if (arc == extarc)
+ { nxtpushf[prevarc] = nxtpushf[arc];
+ break;
+ }
+ prevarc = arc;
+ arc = nxtpushf[arc];
+ }
+ }
+ }
+ node = end;
+ }
+ else
+ { extarc = -extarc;
+ start = startn[extarc];
+ /* add arc to the reduced graph */
+ if (u[extarc] == 0)
+ { nxtpushf[extarc] = fpushf[start];
+ fpushf[start] = extarc;
+ new_level = p[node] + rc[extarc];
+ if (sb_level[start] > new_level)
+ { sb_level[start] = new_level;
+ sb_arc[start] = extarc;
+ }
+ }
+ u[extarc] += incr;
+ x[extarc] -= incr;
+ /* remove arc from the reduced graph */
+ if (x[extarc] == 0)
+ { nas++;
+ arc = fpushb[node];
+ if (arc == extarc)
+ fpushb[node] = nxtpushb[arc];
+ else
+ { prevarc = arc;
+ arc = nxtpushb[arc];
+ while (arc > 0)
+ { if (arc == extarc)
+ { nxtpushb[prevarc] = nxtpushb[arc];
+ break;
+ }
+ prevarc = arc;
+ arc = nxtpushb[arc];
+ }
+ }
+ }
+ node = start;
+ }
+ if (node == term)
+ break;
+ }
+ dfct[term] -= incr;
+ dfct[root] += incr;
+ /* insert term in the queue if it has a large enough surplus */
+ if (dfct[term] < thresh_dfct)
+ { if (nxtqueue[term] == 0)
+ { nxtnode = nxtqueue[root];
+ if ((p[term] >= p[nxtnode]) && (root != nxtnode))
+ { nxtqueue[root] = term;
+ nxtqueue[term] = nxtnode;
+ }
+ else
+ { nxtqueue[prevnode] = term;
+ nxtqueue[term] = root;
+ prevnode = term;
+ }
+ }
+ }
+ /* if root has a large enough surplus, keep it in the queue and
+ * return for another iteration */
+ if (dfct[root] < thresh_dfct)
+ { prevnode = root;
+ root = nxtqueue[root];
+ goto L200;
+ }
+L3000:/* end of augmentation cycle */
+ /* Check for termination of scaling phase. If scaling phase is not
+ * finished, advance the queue and return to take another node. */
+ nxtnode = nxtqueue[root];
+ if (root != nxtnode)
+ { nxtqueue[root] = 0;
+ nxtqueue[prevnode] = nxtnode;
+ root = nxtnode;
+ goto L200;
+ }
+ /* End of subproblem (scaling phase). */
+ /* Reduce epsilon. */
+ eps /= factor;
+ if (eps < 1) eps = 1;
+ thresh_dfct /= factor;
+ if (eps == 1) thresh_dfct = 0;
+ /* if another auction scaling phase remains, reset the flows &
+ * the push lists; else reset arc flows to satisfy cs and compute
+ * reduced costs */
+ if (crash == 1)
+ { for (arc = 1; arc <= na; arc++)
+ { start = startn[arc];
+ end = endn[arc];
+ pstart = p[start];
+ pend = p[end];
+ if (pstart > pend + eps + rc[arc])
+ { resid = u[arc];
+ if (resid > 0)
+ { dfct[start] += resid;
+ dfct[end] -= resid;
+ x[arc] += resid;
+ u[arc] = 0;
+ }
+ }
+ else if (pstart < pend - eps + rc[arc])
+ { flow = x[arc];
+ if (flow > 0)
+ { dfct[start] -= flow;
+ dfct[end] += flow;
+ x[arc] = 0;
+ u[arc] += flow;
+ }
+ }
+ }
+ /* return for another phase */
+ goto L100;
+ }
+ else
+ { crash = 1;
+ for (arc = 1; arc <= na; arc++)
+ { start = startn[arc];
+ end = endn[arc];
+ red_cost = rc[arc] + p[end] - p[start];
+ if (red_cost < 0)
+ { resid = u[arc];
+ if (resid > 0)
+ { dfct[start] += resid;
+ dfct[end] -= resid;
+ x[arc] += resid;
+ u[arc] = 0;
+ }
+ }
+ else if (red_cost > 0)
+ { flow = x[arc];
+ if (flow > 0)
+ { dfct[start] -= flow;
+ dfct[end] += flow;
+ x[arc] = 0;
+ u[arc] += flow;
+ }
+ }
+ rc[arc] = red_cost;
+ }
+ }
+ return 0;
+# undef crash
+# undef nsp
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/relax4.h b/test/monniaux/glpk-4.65/src/misc/relax4.h
new file mode 100644
index 00000000..f48b8508
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/relax4.h
@@ -0,0 +1,102 @@
+/* relax4.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef RELAX4_H
+#define RELAX4_H
+
+struct relax4_csa
+{ /* common storage area */
+ /* input parameters --------------------------------------------*/
+ int n;
+ /* number of nodes */
+ int na;
+ /* number of arcs */
+ int large;
+ /* very large int to represent infinity */
+ int repeat;
+ /* true if initialization is to be skipped (false otherwise) */
+ int crash;
+ /* 0 if default initialization is used
+ * 1 if auction initialization is used */
+ int *startn; /* int startn[1+na]; */
+ /* startn[j] = starting node for arc j, j = 1,...,na */
+ int *endn; /* int endn[1+na] */
+ /* endn[j] = ending node for arc j, j = 1,...,na */
+ int *fou; /* int fou[1+n]; */
+ /* fou[i] = first arc out of node i, i = 1,...,n */
+ int *nxtou; /* int nxtou[1+na]; */
+ /* nxtou[j] = next arc out of the starting node of arc j,
+ * j = 1,...,na */
+ int *fin; /* int fin[1+n]; */
+ /* fin[i] = first arc into node i, i = 1,...,n */
+ int *nxtin; /* int nxtin[1+na]; */
+ /* nxtin[j] = next arc into the ending node of arc j,
+ * j = 1,...,na */
+ /* updated parameters ------------------------------------------*/
+ int *rc; /* int rc[1+na]; */
+ /* rc[j] = reduced cost of arc j, j = 1,...,na */
+ int *u; /* int u[1+na]; */
+ /* u[j] = capacity of arc j on input
+ * and (capacity of arc j) - x(j) on output, j = 1,...,na */
+ int *dfct; /* int dfct[1+n]; */
+ /* dfct[i] = demand at node i on input
+ * and zero on output, i = 1,...,n */
+ /* output parameters -------------------------------------------*/
+ int *x; /* int x[1+na]; */
+ /* x[j] = flow on arc j, j = 1,...,na */
+ int nmultinode;
+ /* number of multinode relaxation iterations in RELAX4 */
+ int iter;
+ /* number of relaxation iterations in RELAX4 */
+ int num_augm;
+ /* number of flow augmentation steps in RELAX4 */
+ int num_ascnt;
+ /* number of multinode ascent steps in RELAX4 */
+ int nsp;
+ /* number of auction/shortest path iterations */
+ /* working parameters ------------------------------------------*/
+ int *label; /* int label, tempin, p[1+n]; */
+ int *prdcsr; /* int prdcsr, tempou, price[1+n]; */
+ int *save; /* int save[1+na]; */
+ int *tfstou; /* int tfstou, fpushf[1+n]; */
+ int *tnxtou; /* int tnxtou, nxtpushf[1+na]; */
+ int *tfstin; /* int tfstin, fpushb[1+n]; */
+ int *tnxtin; /* int tnxtin, nxtpushb[1+na]; */
+ int *nxtqueue; /* int nxtqueue[1+n]; */
+ char *scan; /* bool scan[1+n]; */
+ char *mark; /* bool mark, path_id[1+n]; */
+ /* working parameters used by routine auction only -------------*/
+ int *extend_arc; /* int extend_arc[1+n]; */
+ int *sb_level; /* int sb_level[1+n]; */
+ int *sb_arc; /* int sb_arc[1+n]; */
+};
+
+#define relax4 _glp_relax4
+int relax4(struct relax4_csa *csa);
+
+#define relax4_inidat _glp_relax4_inidat
+void relax4_inidat(struct relax4_csa *csa);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/rng.c b/test/monniaux/glpk-4.65/src/misc/rng.c
new file mode 100644
index 00000000..e0acb53a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/rng.c
@@ -0,0 +1,227 @@
+/* rng.c (pseudo-random number generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* This code is a modified version of the module GB_FLIP, a portable
+* pseudo-random number generator. The original version of GB_FLIP is
+* a part of The Stanford GraphBase developed by Donald E. Knuth (see
+* http://www-cs-staff.stanford.edu/~knuth/sgb.html).
+*
+* Note that all changes concern only external names, so this modified
+* version produces exactly the same results as the original version.
+*
+* Changes were made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "rng.h"
+
+#if 0
+int A[56] = { -1 };
+#else
+#define A (rand->A)
+#endif
+/* pseudo-random values */
+
+#if 0
+int *fptr = A;
+#else
+#define fptr (rand->fptr)
+#endif
+/* the next A value to be exported */
+
+#define mod_diff(x, y) (((x) - (y)) & 0x7FFFFFFF)
+/* difference modulo 2^31 */
+
+static int flip_cycle(RNG *rand)
+{ /* this is an auxiliary routine to do 55 more steps of the basic
+ * recurrence, at high speed, and to reset fptr */
+ int *ii, *jj;
+ for (ii = &A[1], jj = &A[32]; jj <= &A[55]; ii++, jj++)
+ *ii = mod_diff(*ii, *jj);
+ for (jj = &A[1]; ii <= &A[55]; ii++, jj++)
+ *ii = mod_diff(*ii, *jj);
+ fptr = &A[54];
+ return A[55];
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_create_rand - create pseudo-random number generator
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* RNG *rng_create_rand(void);
+*
+* DESCRIPTION
+*
+* The routine rng_create_rand creates and initializes a pseudo-random
+* number generator.
+*
+* RETURNS
+*
+* The routine returns a pointer to the generator created. */
+
+RNG *rng_create_rand(void)
+{ RNG *rand;
+ int i;
+ rand = talloc(1, RNG);
+ A[0] = -1;
+ for (i = 1; i <= 55; i++) A[i] = 0;
+ fptr = A;
+ rng_init_rand(rand, 1);
+ return rand;
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_init_rand - initialize pseudo-random number generator
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* void rng_init_rand(RNG *rand, int seed);
+*
+* DESCRIPTION
+*
+* The routine rng_init_rand initializes the pseudo-random number
+* generator. The parameter seed may be any integer number. Note that
+* on creating the generator this routine is called with the parameter
+* seed equal to 1. */
+
+void rng_init_rand(RNG *rand, int seed)
+{ int i;
+ int prev = seed, next = 1;
+ seed = prev = mod_diff(prev, 0);
+ A[55] = prev;
+ for (i = 21; i; i = (i + 21) % 55)
+ { A[i] = next;
+ next = mod_diff(prev, next);
+ if (seed & 1)
+ seed = 0x40000000 + (seed >> 1);
+ else
+ seed >>= 1;
+ next = mod_diff(next, seed);
+ prev = A[i];
+ }
+ flip_cycle(rand);
+ flip_cycle(rand);
+ flip_cycle(rand);
+ flip_cycle(rand);
+ flip_cycle(rand);
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_next_rand - obtain pseudo-random integer in the range [0, 2^31-1]
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* int rng_next_rand(RNG *rand);
+*
+* RETURNS
+*
+* The routine rng_next_rand returns a next pseudo-random integer which
+* is uniformly distributed between 0 and 2^31-1, inclusive. The period
+* length of the generated numbers is 2^85 - 2^30. The low order bits of
+* the generated numbers are just as random as the high-order bits. */
+
+int rng_next_rand(RNG *rand)
+{ return
+ *fptr >= 0 ? *fptr-- : flip_cycle(rand);
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_unif_rand - obtain pseudo-random integer in the range [0, m-1]
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* int rng_unif_rand(RNG *rand, int m);
+*
+* RETURNS
+*
+* The routine rng_unif_rand returns a next pseudo-random integer which
+* is uniformly distributed between 0 and m-1, inclusive, where m is any
+* positive integer less than 2^31. */
+
+#define two_to_the_31 ((unsigned int)0x80000000)
+
+int rng_unif_rand(RNG *rand, int m)
+{ unsigned int t = two_to_the_31 - (two_to_the_31 % m);
+ int r;
+ xassert(m > 0);
+ do { r = rng_next_rand(rand); } while (t <= (unsigned int)r);
+ return r % m;
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_delete_rand - delete pseudo-random number generator
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* void rng_delete_rand(RNG *rand);
+*
+* DESCRIPTION
+*
+* The routine rng_delete_rand frees all the memory allocated to the
+* specified pseudo-random number generator. */
+
+void rng_delete_rand(RNG *rand)
+{ tfree(rand);
+ return;
+}
+
+/**********************************************************************/
+
+#ifdef GLP_TEST
+/* To be sure that this modified version produces the same results as
+ * the original version, run this validation program. */
+
+int main(void)
+{ RNG *rand;
+ int j;
+ rand = rng_create_rand();
+ rng_init_rand(rand, -314159);
+ if (rng_next_rand(rand) != 119318998)
+ { fprintf(stderr, "Failure on the first try!\n");
+ return -1;
+ }
+ for (j = 1; j <= 133; j++) rng_next_rand(rand);
+ if (rng_unif_rand(rand, 0x55555555) != 748103812)
+ { fprintf(stderr, "Failure on the second try!\n");
+ return -2;
+ }
+ fprintf(stderr, "OK, the random-number generator routines seem to"
+ " work!\n");
+ rng_delete_rand(rand);
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/rng.h b/test/monniaux/glpk-4.65/src/misc/rng.h
new file mode 100644
index 00000000..49725e05
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/rng.h
@@ -0,0 +1,67 @@
+/* rng.h (pseudo-random number generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef RNG_H
+#define RNG_H
+
+typedef struct RNG RNG;
+
+struct RNG
+{ /* Knuth's portable pseudo-random number generator */
+ int A[56];
+ /* pseudo-random values */
+ int *fptr;
+ /* the next A value to be exported */
+};
+
+#define rng_create_rand _glp_rng_create_rand
+RNG *rng_create_rand(void);
+/* create pseudo-random number generator */
+
+#define rng_init_rand _glp_rng_init_rand
+void rng_init_rand(RNG *rand, int seed);
+/* initialize pseudo-random number generator */
+
+#define rng_next_rand _glp_rng_next_rand
+int rng_next_rand(RNG *rand);
+/* obtain pseudo-random integer in the range [0, 2^31-1] */
+
+#define rng_unif_rand _glp_rng_unif_rand
+int rng_unif_rand(RNG *rand, int m);
+/* obtain pseudo-random integer in the range [0, m-1] */
+
+#define rng_delete_rand _glp_rng_delete_rand
+void rng_delete_rand(RNG *rand);
+/* delete pseudo-random number generator */
+
+#define rng_unif_01 _glp_rng_unif_01
+double rng_unif_01(RNG *rand);
+/* obtain pseudo-random number in the range [0, 1] */
+
+#define rng_uniform _glp_rng_uniform
+double rng_uniform(RNG *rand, double a, double b);
+/* obtain pseudo-random number in the range [a, b] */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/rng1.c b/test/monniaux/glpk-4.65/src/misc/rng1.c
new file mode 100644
index 00000000..b89f676f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/rng1.c
@@ -0,0 +1,73 @@
+/* rng1.c (pseudo-random number generator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "rng.h"
+
+/***********************************************************************
+* NAME
+*
+* rng_unif_01 - obtain pseudo-random number in the range [0, 1]
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* double rng_unif_01(RNG *rand);
+*
+* RETURNS
+*
+* The routine rng_unif_01 returns a next pseudo-random number which is
+* uniformly distributed in the range [0, 1]. */
+
+double rng_unif_01(RNG *rand)
+{ double x;
+ x = (double)rng_next_rand(rand) / 2147483647.0;
+ xassert(0.0 <= x && x <= 1.0);
+ return x;
+}
+
+/***********************************************************************
+* NAME
+*
+* rng_uniform - obtain pseudo-random number in the range [a, b]
+*
+* SYNOPSIS
+*
+* #include "rng.h"
+* double rng_uniform(RNG *rand, double a, double b);
+*
+* RETURNS
+*
+* The routine rng_uniform returns a next pseudo-random number which is
+* uniformly distributed in the range [a, b]. */
+
+double rng_uniform(RNG *rand, double a, double b)
+{ double x;
+ xassert(a < b);
+ x = rng_unif_01(rand);
+ x = a * (1.0 - x) + b * x;
+ xassert(a <= x && x <= b);
+ return x;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/round2n.c b/test/monniaux/glpk-4.65/src/misc/round2n.c
new file mode 100644
index 00000000..8a94c616
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/round2n.c
@@ -0,0 +1,64 @@
+/* round2n.c (round floating-point number to nearest power of two) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "misc.h"
+
+/***********************************************************************
+* NAME
+*
+* round2n - round floating-point number to nearest power of two
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* double round2n(double x);
+*
+* RETURNS
+*
+* Given a positive floating-point value x the routine round2n returns
+* 2^n such that |x - 2^n| is minimal.
+*
+* EXAMPLES
+*
+* round2n(10.1) = 2^3 = 8
+* round2n(15.3) = 2^4 = 16
+* round2n(0.01) = 2^(-7) = 0.0078125
+*
+* BACKGROUND
+*
+* Let x = f * 2^e, where 0.5 <= f < 1 is a normalized fractional part,
+* e is an integer exponent. Then, obviously, 0.5 * 2^e <= x < 2^e, so
+* if x - 0.5 * 2^e <= 2^e - x, we choose 0.5 * 2^e = 2^(e-1), and 2^e
+* otherwise. The latter condition can be written as 2 * x <= 1.5 * 2^e
+* or 2 * f * 2^e <= 1.5 * 2^e or, finally, f <= 0.75. */
+
+double round2n(double x)
+{ int e;
+ double f;
+ xassert(x > 0.0);
+ f = frexp(x, &e);
+ return ldexp(1.0, f <= 0.75 ? e-1 : e);
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/str2int.c b/test/monniaux/glpk-4.65/src/misc/str2int.c
new file mode 100644
index 00000000..cbd6e953
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/str2int.c
@@ -0,0 +1,92 @@
+/* str2int.c (convert string to int) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "misc.h"
+#include "stdc.h"
+
+/***********************************************************************
+* NAME
+*
+* str2int - convert character string to value of int type
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* int str2int(const char *str, int *val);
+*
+* DESCRIPTION
+*
+* The routine str2int converts the character string str to a value of
+* integer type and stores the value into location, which the parameter
+* val points to (in the case of error content of this location is not
+* changed).
+*
+* RETURNS
+*
+* The routine returns one of the following error codes:
+*
+* 0 - no error;
+* 1 - value out of range;
+* 2 - character string is syntactically incorrect. */
+
+int str2int(const char *str, int *val_)
+{ int d, k, s, val = 0;
+ /* scan optional sign */
+ if (str[0] == '+')
+ s = +1, k = 1;
+ else if (str[0] == '-')
+ s = -1, k = 1;
+ else
+ s = +1, k = 0;
+ /* check for the first digit */
+ if (!isdigit((unsigned char)str[k]))
+ return 2;
+ /* scan digits */
+ while (isdigit((unsigned char)str[k]))
+ { d = str[k++] - '0';
+ if (s > 0)
+ { if (val > INT_MAX / 10)
+ return 1;
+ val *= 10;
+ if (val > INT_MAX - d)
+ return 1;
+ val += d;
+ }
+ else /* s < 0 */
+ { if (val < INT_MIN / 10)
+ return 1;
+ val *= 10;
+ if (val < INT_MIN + d)
+ return 1;
+ val -= d;
+ }
+ }
+ /* check for terminator */
+ if (str[k] != '\0')
+ return 2;
+ /* conversion has been done */
+ *val_ = val;
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/str2num.c b/test/monniaux/glpk-4.65/src/misc/str2num.c
new file mode 100644
index 00000000..26c2f68f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/str2num.c
@@ -0,0 +1,110 @@
+/* str2num.c (convert string to double) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "misc.h"
+#include "stdc.h"
+
+/***********************************************************************
+* NAME
+*
+* str2num - convert character string to value of double type
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* int str2num(const char *str, double *val);
+*
+* DESCRIPTION
+*
+* The routine str2num converts the character string str to a value of
+* double type and stores the value into location, which the parameter
+* val points to (in the case of error content of this location is not
+* changed).
+*
+* RETURNS
+*
+* The routine returns one of the following error codes:
+*
+* 0 - no error;
+* 1 - value out of range;
+* 2 - character string is syntactically incorrect. */
+
+int str2num(const char *str, double *val_)
+{ int k;
+ double val;
+ /* scan optional sign */
+ k = (str[0] == '+' || str[0] == '-' ? 1 : 0);
+ /* check for decimal point */
+ if (str[k] == '.')
+ { k++;
+ /* a digit should follow it */
+ if (!isdigit((unsigned char)str[k]))
+ return 2;
+ k++;
+ goto frac;
+ }
+ /* integer part should start with a digit */
+ if (!isdigit((unsigned char)str[k]))
+ return 2;
+ /* scan integer part */
+ while (isdigit((unsigned char)str[k]))
+ k++;
+ /* check for decimal point */
+ if (str[k] == '.') k++;
+frac: /* scan optional fraction part */
+ while (isdigit((unsigned char)str[k]))
+ k++;
+ /* check for decimal exponent */
+ if (str[k] == 'E' || str[k] == 'e')
+ { k++;
+ /* scan optional sign */
+ if (str[k] == '+' || str[k] == '-')
+ k++;
+ /* a digit should follow E, E+ or E- */
+ if (!isdigit((unsigned char)str[k]))
+ return 2;
+ }
+ /* scan optional exponent part */
+ while (isdigit((unsigned char)str[k]))
+ k++;
+ /* check for terminator */
+ if (str[k] != '\0')
+ return 2;
+ /* perform conversion */
+ { char *endptr;
+ val = strtod(str, &endptr);
+ if (*endptr != '\0')
+ return 2;
+ }
+ /* check for overflow */
+ if (!(-DBL_MAX <= val && val <= +DBL_MAX))
+ return 1;
+ /* check for underflow */
+ if (-DBL_MIN < val && val < +DBL_MIN)
+ val = 0.0;
+ /* conversion has been done */
+ *val_ = val;
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/strspx.c b/test/monniaux/glpk-4.65/src/misc/strspx.c
new file mode 100644
index 00000000..fe8a2a10
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/strspx.c
@@ -0,0 +1,60 @@
+/* strspx.c (remove all spaces from string) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "misc.h"
+
+/***********************************************************************
+* NAME
+*
+* strspx - remove all spaces from character string
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* char *strspx(char *str);
+*
+* DESCRIPTION
+*
+* The routine strspx removes all spaces from the character string str.
+*
+* RETURNS
+*
+* The routine returns a pointer to the character string.
+*
+* EXAMPLES
+*
+* strspx(" Errare humanum est ") => "Errarehumanumest"
+*
+* strspx(" ") => "" */
+
+char *strspx(char *str)
+{ char *s, *t;
+ for (s = t = str; *s; s++)
+ { if (*s != ' ')
+ *t++ = *s;
+ }
+ *t = '\0';
+ return str;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/strtrim.c b/test/monniaux/glpk-4.65/src/misc/strtrim.c
new file mode 100644
index 00000000..9992c4b0
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/strtrim.c
@@ -0,0 +1,62 @@
+/* strtrim.c (remove trailing spaces from string) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2000-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "misc.h"
+#include "stdc.h"
+
+/***********************************************************************
+* NAME
+*
+* strtrim - remove trailing spaces from character string
+*
+* SYNOPSIS
+*
+* #include "misc.h"
+* char *strtrim(char *str);
+*
+* DESCRIPTION
+*
+* The routine strtrim removes trailing spaces from the character
+* string str.
+*
+* RETURNS
+*
+* The routine returns a pointer to the character string.
+*
+* EXAMPLES
+*
+* strtrim("Errare humanum est ") => "Errare humanum est"
+*
+* strtrim(" ") => "" */
+
+char *strtrim(char *str)
+{ char *t;
+ for (t = strrchr(str, '\0') - 1; t >= str; t--)
+ { if (*t != ' ')
+ break;
+ *t = '\0';
+ }
+ return str;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/triang.c b/test/monniaux/glpk-4.65/src/misc/triang.c
new file mode 100644
index 00000000..99ba4d60
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/triang.c
@@ -0,0 +1,311 @@
+/* triang.c (find maximal triangular part of rectangular matrix) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "triang.h"
+
+/***********************************************************************
+* triang - find maximal triangular part of rectangular matrix
+*
+* Given a mxn sparse matrix A this routine finds permutation matrices
+* P and Q such that matrix A' = P * A * Q has the following structure:
+*
+* 1 s n
+* 1 * . . . . . x x x x x
+* * * . . . . x x x x x
+* * * * . . . x x x x x
+* * * * * . . x x x x x
+* * * * * * . x x x x x
+* s * * * * * * x x x x x
+* x x x x x x x x x x x
+* x x x x x x x x x x x
+* m x x x x x x x x x x x
+*
+* where '*' are elements of the triangular part, '.' are structural
+* zeros, 'x' are other elements.
+*
+* The formal routine mat specifies the original matrix A in both row-
+* and column-wise format. If the routine mat is called with k = +i,
+* 1 <= i <= m, it should store column indices and values of non-zero
+* elements of i-th row of A in locations ind[1], ..., ind[len] and
+* val[1], ..., val[len], resp., where len is the returned number of
+* non-zeros in the row, 0 <= len <= n. Similarly, if the routine mat
+* is called with k = -j, 1 <= j <= n, it should store row indices and
+* values of non-zero elements of j-th column of A and return len, the
+* number of non-zeros in the column, 0 <= len <= m. Should note that
+* duplicate indices are not allowed.
+*
+* The parameter info is a transit pointer passed to the routine mat.
+*
+* The parameter tol is a tolerance. The routine triang guarantees that
+* each diagonal element in the triangular part of matrix A' is not
+* less in magnitude than tol * max, where max is the maximal magnitude
+* of elements in corresponding column.
+*
+* On exit the routine triang stores information on the triangular part
+* found in the arrays rn and cn. Elements rn[1], ..., rn[s] specify
+* row numbers and elements cn[1], ..., cn[s] specify column numbers
+* of the original matrix A, which correspond to rows/columns 1, ..., s
+* of matrix A', where s is the size of the triangular part returned by
+* the routine, 0 <= s <= min(m, n). The order of rows and columns that
+* are not included in the triangular part remains unspecified.
+*
+* ALGORITHM
+*
+* The routine triang uses a simple greedy heuristic.
+*
+* At some step the matrix A' = P * A * Q has the following structure:
+*
+* 1 n
+* 1 * . . . . . . . x x x
+* * * . . . . . . x x x
+* * * * . . . . . x x x
+* * * * * . . . . x x x
+* x x x x # # # # x x x
+* x x x x # # # # x x x
+* x x x x # # # # x x x
+* x x x x # # # # x x x
+* m x x x x # # # # x x x
+*
+* where '#' are elements of active submatrix. Initially P = Q = I, so
+* the active submatrix is the original matrix A = A'.
+*
+* If some row has exactly one non-zero in the active submatrix (row
+* singleton), the routine includes this row and corresponding column
+* in the triangular part, and removes the column from the active
+* submatrix. Otherwise, the routine simply removes a column having
+* maximal number of non-zeros from the active submatrix in the hope
+* that new row singleton(s) will appear.
+*
+* COMPLEXITY
+*
+* The time complexity of the routine triang is O(nnz), where nnz is
+* number of non-zeros in the original matrix A. */
+
+int triang(int m, int n, int (*mat)(void *info, int k, int ind[],
+ double val[]), void *info, double tol, int rn[], int cn[])
+{ int head, i, j, jj, k, kk, ks, len, len2, next_j, ns, size;
+ int *cind, *rind, *cnt, *ptr, *list, *prev, *next;
+ double *cval, *rval, *big;
+ char *flag;
+ /* allocate working arrays */
+ cind = talloc(1+m, int);
+ cval = talloc(1+m, double);
+ rind = talloc(1+n, int);
+ rval = talloc(1+n, double);
+ cnt = ptr = talloc(1+m, int);
+ list = talloc(1+n, int);
+ prev = talloc(1+n, int);
+ next = talloc(1+n, int);
+ big = talloc(1+n, double);
+ flag = talloc(1+n, char);
+ /*--------------------------------------------------------------*/
+ /* build linked lists of columns having equal lengths */
+ /*--------------------------------------------------------------*/
+ /* ptr[len], 0 <= len <= m, is number of first column of length
+ * len;
+ * next[j], 1 <= j <= n, is number of next column having the same
+ * length as column j;
+ * big[j], 1 <= j <= n, is maximal magnitude of elements in j-th
+ * column */
+ for (len = 0; len <= m; len++)
+ ptr[len] = 0;
+ for (j = 1; j <= n; j++)
+ { /* get j-th column */
+ len = mat(info, -j, cind, cval);
+ xassert(0 <= len && len <= m);
+ /* add this column to beginning of list ptr[len] */
+ next[j] = ptr[len];
+ ptr[len] = j;
+ /* determine maximal magnitude of elements in this column */
+ big[j] = 0.0;
+ for (k = 1; k <= len; k++)
+ { if (big[j] < fabs(cval[k]))
+ big[j] = fabs(cval[k]);
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* build doubly linked list of columns ordered by decreasing */
+ /* column lengths */
+ /*--------------------------------------------------------------*/
+ /* head is number of first column in the list;
+ * prev[j], 1 <= j <= n, is number of column that precedes j-th
+ * column in the list;
+ * next[j], 1 <= j <= n, is number of column that follows j-th
+ * column in the list */
+ head = 0;
+ for (len = 0; len <= m; len++)
+ { /* walk thru list of columns of length len */
+ for (j = ptr[len]; j != 0; j = next_j)
+ { next_j = next[j];
+ /* add j-th column to beginning of the column list */
+ prev[j] = 0;
+ next[j] = head;
+ if (head != 0)
+ prev[head] = j;
+ head = j;
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* build initial singleton list */
+ /*--------------------------------------------------------------*/
+ /* there are used two list of columns:
+ * 1) doubly linked list of active columns, in which all columns
+ * are ordered by decreasing column lengths;
+ * 2) singleton list; an active column is included in this list
+ * if it has at least one row singleton in active submatrix */
+ /* flag[j], 1 <= j <= n, is a flag of j-th column:
+ * 0 j-th column is inactive;
+ * 1 j-th column is active;
+ * 2 j-th column is active and has row singleton(s) */
+ /* initially all columns are active */
+ for (j = 1; j <= n; j++)
+ flag[j] = 1;
+ /* initialize row counts and build initial singleton list */
+ /* cnt[i], 1 <= i <= m, is number of non-zeros, which i-th row
+ * has in active submatrix;
+ * ns is size of singleton list;
+ * list[1], ..., list[ns] are numbers of active columns included
+ * in the singleton list */
+ ns = 0;
+ for (i = 1; i <= m; i++)
+ { /* get i-th row */
+ len = cnt[i] = mat(info, +i, rind, rval);
+ xassert(0 <= len && len <= n);
+ if (len == 1)
+ { /* a[i,j] is row singleton */
+ j = rind[1];
+ xassert(1 <= j && j <= n);
+ if (flag[j] != 2)
+ { /* include j-th column in singleton list */
+ flag[j] = 2;
+ list[++ns] = j;
+ }
+ }
+ }
+ /*--------------------------------------------------------------*/
+ /* main loop */
+ /*--------------------------------------------------------------*/
+ size = 0; /* size of triangular part */
+ /* loop until active column list is non-empty, i.e. until the
+ * active submatrix has at least one column */
+ while (head != 0)
+ { if (ns == 0)
+ { /* singleton list is empty */
+ /* remove from the active submatrix a column of maximal
+ * length in the hope that some row singletons appear */
+ j = head;
+ len = mat(info, -j, cind, cval);
+ xassert(0 <= len && len <= m);
+ goto drop;
+ }
+ /* take column j from the singleton list */
+ j = list[ns--];
+ xassert(flag[j] == 2);
+ /* j-th column has at least one row singleton in the active
+ * submatrix; choose one having maximal magnitude */
+ len = mat(info, -j, cind, cval);
+ xassert(0 <= len && len <= m);
+ kk = 0;
+ for (k = 1; k <= len; k++)
+ { i = cind[k];
+ xassert(1 <= i && i <= m);
+ if (cnt[i] == 1)
+ { /* a[i,j] is row singleton */
+ if (kk == 0 || fabs(cval[kk]) < fabs(cval[k]))
+ kk = k;
+ }
+ }
+ xassert(kk > 0);
+ /* check magnitude of the row singleton chosen */
+ if (fabs(cval[kk]) < tol * big[j])
+ { /* all row singletons are too small in magnitude; drop j-th
+ * column */
+ goto drop;
+ }
+ /* row singleton a[i,j] is ok; add i-th row and j-th column to
+ * the triangular part */
+ size++;
+ rn[size] = cind[kk];
+ cn[size] = j;
+drop: /* remove j-th column from the active submatrix */
+ xassert(flag[j]);
+ flag[j] = 0;
+ if (prev[j] == 0)
+ head = next[j];
+ else
+ next[prev[j]] = next[j];
+ if (next[j] == 0)
+ ;
+ else
+ prev[next[j]] = prev[j];
+ /* decrease row counts */
+ for (k = 1; k <= len; k++)
+ { i = cind[k];
+ xassert(1 <= i && i <= m);
+ xassert(cnt[i] > 0);
+ cnt[i]--;
+ if (cnt[i] == 1)
+ { /* new singleton appeared in i-th row; determine number
+ * of corresponding column (it is the only active column
+ * in this row) */
+ len2 = mat(info, +i, rind, rval);
+ xassert(0 <= len2 && len2 <= n);
+ ks = 0;
+ for (kk = 1; kk <= len2; kk++)
+ { jj = rind[kk];
+ xassert(1 <= jj && jj <= n);
+ if (flag[jj])
+ { xassert(ks == 0);
+ ks = kk;
+ }
+ }
+ xassert(ks > 0);
+ /* a[i,jj] is new row singleton */
+ jj = rind[ks];
+ if (flag[jj] != 2)
+ { /* include jj-th column in the singleton list */
+ flag[jj] = 2;
+ list[++ns] = jj;
+ }
+ }
+ }
+ }
+ /* now all row counts should be zero */
+ for (i = 1; i <= m; i++)
+ xassert(cnt[i] == 0);
+ /* deallocate working arrays */
+ tfree(cind);
+ tfree(cval);
+ tfree(rind);
+ tfree(rval);
+ tfree(ptr);
+ tfree(list);
+ tfree(prev);
+ tfree(next);
+ tfree(big);
+ tfree(flag);
+ return size;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/triang.h b/test/monniaux/glpk-4.65/src/misc/triang.h
new file mode 100644
index 00000000..1e50d44d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/triang.h
@@ -0,0 +1,34 @@
+/* triang.h (find maximal triangular part of rectangular matrix) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef TRIANG_H
+#define TRIANG_H
+
+#define triang _glp_triang
+int triang(int m, int n, int (*mat)(void *info, int k, int ind[],
+ double val[]), void *info, double tol, int rn[], int cn[]);
+/* find maximal triangular part of rectangular matrix */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/wclique.c b/test/monniaux/glpk-4.65/src/misc/wclique.c
new file mode 100644
index 00000000..5daa69cf
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/wclique.c
@@ -0,0 +1,242 @@
+/* wclique.c (maximum weight clique, Ostergard's algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Two subroutines sub() and wclique() below are intended to find a
+* maximum weight clique in a given undirected graph. These subroutines
+* are slightly modified version of the program WCLIQUE developed by
+* Patric Ostergard <http://www.tcs.hut.fi/~pat/wclique.html> and based
+* on ideas from the article "P. R. J. Ostergard, A new algorithm for
+* the maximum-weight clique problem, submitted for publication", which
+* in turn is a generalization of the algorithm for unweighted graphs
+* presented in "P. R. J. Ostergard, A fast algorithm for the maximum
+* clique problem, submitted for publication".
+*
+* USED WITH PERMISSION OF THE AUTHOR OF THE ORIGINAL CODE.
+*
+* Changes were made by Andrew Makhorin <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "wclique.h"
+
+/***********************************************************************
+* NAME
+*
+* wclique - find maximum weight clique with Ostergard's algorithm
+*
+* SYNOPSIS
+*
+* #include "wclique.h"
+* int wclique(int n, const int w[], const unsigned char a[],
+* int ind[]);
+*
+* DESCRIPTION
+*
+* The routine wclique finds a maximum weight clique in an undirected
+* graph with Ostergard's algorithm.
+*
+* INPUT PARAMETERS
+*
+* n is the number of vertices, n > 0.
+*
+* w[i], i = 1,...,n, is a weight of vertex i.
+*
+* a[*] is the strict (without main diagonal) lower triangle of the
+* graph adjacency matrix in packed format.
+*
+* OUTPUT PARAMETER
+*
+* ind[k], k = 1,...,size, is the number of a vertex included in the
+* clique found, 1 <= ind[k] <= n, where size is the number of vertices
+* in the clique returned on exit.
+*
+* RETURNS
+*
+* The routine returns the clique size, i.e. the number of vertices in
+* the clique. */
+
+struct csa
+{ /* common storage area */
+ int n;
+ /* number of vertices */
+ const int *wt; /* int wt[0:n-1]; */
+ /* weights */
+ const unsigned char *a;
+ /* adjacency matrix (packed lower triangle without main diag.) */
+ int record;
+ /* weight of best clique */
+ int rec_level;
+ /* number of vertices in best clique */
+ int *rec; /* int rec[0:n-1]; */
+ /* best clique so far */
+ int *clique; /* int clique[0:n-1]; */
+ /* table for pruning */
+ int *set; /* int set[0:n-1]; */
+ /* current clique */
+};
+
+#define n (csa->n)
+#define wt (csa->wt)
+#define a (csa->a)
+#define record (csa->record)
+#define rec_level (csa->rec_level)
+#define rec (csa->rec)
+#define clique (csa->clique)
+#define set (csa->set)
+
+#if 0
+static int is_edge(struct csa *csa, int i, int j)
+{ /* if there is arc (i,j), the routine returns true; otherwise
+ * false; 0 <= i, j < n */
+ int k;
+ xassert(0 <= i && i < n);
+ xassert(0 <= j && j < n);
+ if (i == j) return 0;
+ if (i < j) k = i, i = j, j = k;
+ k = (i * (i - 1)) / 2 + j;
+ return a[k / CHAR_BIT] &
+ (unsigned char)(1 << ((CHAR_BIT - 1) - k % CHAR_BIT));
+}
+#else
+#define is_edge(csa, i, j) ((i) == (j) ? 0 : \
+ (i) > (j) ? is_edge1(i, j) : is_edge1(j, i))
+#define is_edge1(i, j) is_edge2(((i) * ((i) - 1)) / 2 + (j))
+#define is_edge2(k) (a[(k) / CHAR_BIT] & \
+ (unsigned char)(1 << ((CHAR_BIT - 1) - (k) % CHAR_BIT)))
+#endif
+
+static void sub(struct csa *csa, int ct, int table[], int level,
+ int weight, int l_weight)
+{ int i, j, k, curr_weight, left_weight, *p1, *p2, *newtable;
+ newtable = xcalloc(n, sizeof(int));
+ if (ct <= 0)
+ { /* 0 or 1 elements left; include these */
+ if (ct == 0)
+ { set[level++] = table[0];
+ weight += l_weight;
+ }
+ if (weight > record)
+ { record = weight;
+ rec_level = level;
+ for (i = 0; i < level; i++) rec[i] = set[i];
+ }
+ goto done;
+ }
+ for (i = ct; i >= 0; i--)
+ { if ((level == 0) && (i < ct)) goto done;
+ k = table[i];
+ if ((level > 0) && (clique[k] <= (record - weight)))
+ goto done; /* prune */
+ set[level] = k;
+ curr_weight = weight + wt[k];
+ l_weight -= wt[k];
+ if (l_weight <= (record - curr_weight))
+ goto done; /* prune */
+ p1 = newtable;
+ p2 = table;
+ left_weight = 0;
+ while (p2 < table + i)
+ { j = *p2++;
+ if (is_edge(csa, j, k))
+ { *p1++ = j;
+ left_weight += wt[j];
+ }
+ }
+ if (left_weight <= (record - curr_weight)) continue;
+ sub(csa, p1 - newtable - 1, newtable, level + 1, curr_weight,
+ left_weight);
+ }
+done: xfree(newtable);
+ return;
+}
+
+int wclique(int n_, const int w[], const unsigned char a_[], int ind[])
+{ struct csa csa_, *csa = &csa_;
+ int i, j, p, max_wt, max_nwt, wth, *used, *nwt, *pos;
+ double timer;
+ n = n_;
+ xassert(n > 0);
+ wt = &w[1];
+ a = a_;
+ record = 0;
+ rec_level = 0;
+ rec = &ind[1];
+ clique = xcalloc(n, sizeof(int));
+ set = xcalloc(n, sizeof(int));
+ used = xcalloc(n, sizeof(int));
+ nwt = xcalloc(n, sizeof(int));
+ pos = xcalloc(n, sizeof(int));
+ /* start timer */
+ timer = xtime();
+ /* order vertices */
+ for (i = 0; i < n; i++)
+ { nwt[i] = 0;
+ for (j = 0; j < n; j++)
+ if (is_edge(csa, i, j)) nwt[i] += wt[j];
+ }
+ for (i = 0; i < n; i++)
+ used[i] = 0;
+ for (i = n-1; i >= 0; i--)
+ { max_wt = -1;
+ max_nwt = -1;
+ for (j = 0; j < n; j++)
+ { if ((!used[j]) && ((wt[j] > max_wt) || (wt[j] == max_wt
+ && nwt[j] > max_nwt)))
+ { max_wt = wt[j];
+ max_nwt = nwt[j];
+ p = j;
+ }
+ }
+ pos[i] = p;
+ used[p] = 1;
+ for (j = 0; j < n; j++)
+ if ((!used[j]) && (j != p) && (is_edge(csa, p, j)))
+ nwt[j] -= wt[p];
+ }
+ /* main routine */
+ wth = 0;
+ for (i = 0; i < n; i++)
+ { wth += wt[pos[i]];
+ sub(csa, i, pos, 0, 0, wth);
+ clique[pos[i]] = record;
+ if (xdifftime(xtime(), timer) >= 5.0 - 0.001)
+ { /* print current record and reset timer */
+ xprintf("level = %d (%d); best = %d\n", i+1, n, record);
+ timer = xtime();
+ }
+ }
+ xfree(clique);
+ xfree(set);
+ xfree(used);
+ xfree(nwt);
+ xfree(pos);
+ /* return the solution found */
+ for (i = 1; i <= rec_level; i++) ind[i]++;
+ return rec_level;
+}
+
+#undef n
+#undef wt
+#undef a
+#undef record
+#undef rec_level
+#undef rec
+#undef clique
+#undef set
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/wclique.h b/test/monniaux/glpk-4.65/src/misc/wclique.h
new file mode 100644
index 00000000..d52dc805
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/wclique.h
@@ -0,0 +1,33 @@
+/* wclique.h (maximum weight clique, Ostergard's algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef WCLIQUE_H
+#define WCLIQUE_H
+
+#define wclique _glp_wclique
+int wclique(int n, const int w[], const unsigned char a[], int ind[]);
+/* find maximum weight clique with Ostergard's algorithm */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/wclique1.c b/test/monniaux/glpk-4.65/src/misc/wclique1.c
new file mode 100644
index 00000000..a3d89542
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/wclique1.c
@@ -0,0 +1,317 @@
+/* wclique1.c (maximum weight clique, greedy heuristic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "wclique1.h"
+
+/***********************************************************************
+* NAME
+*
+* wclique1 - find maximum weight clique with greedy heuristic
+*
+* SYNOPSIS
+*
+* #include "wclique1.h"
+* int wclique1(int n, const double w[],
+* int (*func)(void *info, int i, int ind[]), void *info, int c[]);
+*
+* DESCRIPTION
+*
+* The routine wclique1 implements a sequential greedy heuristic to
+* find maximum weight clique in a given (undirected) graph G = (V, E).
+*
+* The parameter n specifies the number of vertices |V| in the graph,
+* n >= 0.
+*
+* The array w specifies vertex weights in locations w[i], i = 1,...,n.
+* All weights must be non-negative.
+*
+* The formal routine func specifies the graph. For a given vertex i,
+* 1 <= i <= n, it stores indices of all vertices adjacent to vertex i
+* in locations ind[1], ..., ind[deg], where deg is the degree of
+* vertex i, 0 <= deg < n, returned on exit. Note that self-loops and
+* multiple edges are not allowed.
+*
+* The parameter info is a cookie passed to the routine func.
+*
+* On exit the routine wclique1 stores vertex indices included in
+* the clique found to locations c[1], ..., c[size], where size is the
+* clique size returned by the routine, 0 <= size <= n.
+*
+* RETURNS
+*
+* The routine wclique1 returns the size of the clique found. */
+
+struct vertex { int i; double cw; };
+
+static int CDECL fcmp(const void *xx, const void *yy)
+{ const struct vertex *x = xx, *y = yy;
+ if (x->cw > y->cw) return -1;
+ if (x->cw < y->cw) return +1;
+ return 0;
+}
+
+int wclique1(int n, const double w[],
+ int (*func)(void *info, int i, int ind[]), void *info, int c[])
+{ struct vertex *v_list;
+ int deg, c_size, d_size, i, j, k, kk, l, *ind, *c_list, *d_list,
+ size = 0;
+ double c_wght, d_wght, *sw, best = 0.0;
+ char *d_flag, *skip;
+ /* perform sanity checks */
+ xassert(n >= 0);
+ for (i = 1; i <= n; i++)
+ xassert(w[i] >= 0.0);
+ /* if the graph is empty, nothing to do */
+ if (n == 0) goto done;
+ /* allocate working arrays */
+ ind = xcalloc(1+n, sizeof(int));
+ v_list = xcalloc(1+n, sizeof(struct vertex));
+ c_list = xcalloc(1+n, sizeof(int));
+ d_list = xcalloc(1+n, sizeof(int));
+ d_flag = xcalloc(1+n, sizeof(char));
+ skip = xcalloc(1+n, sizeof(char));
+ sw = xcalloc(1+n, sizeof(double));
+ /* build the vertex list */
+ for (i = 1; i <= n; i++)
+ { v_list[i].i = i;
+ /* compute the cumulative weight of each vertex i, which is
+ * cw[i] = w[i] + sum{j : (i,j) in E} w[j] */
+ v_list[i].cw = w[i];
+ deg = func(info, i, ind);
+ xassert(0 <= deg && deg < n);
+ for (k = 1; k <= deg; k++)
+ { j = ind[k];
+ xassert(1 <= j && j <= n && j != i);
+ v_list[i].cw += w[j];
+ }
+ }
+ /* sort the vertex list to access vertices in descending order of
+ * cumulative weights */
+ qsort(&v_list[1], n, sizeof(struct vertex), fcmp);
+ /* initially all vertices are unmarked */
+ memset(&skip[1], 0, sizeof(char) * n);
+ /* clear flags of all vertices */
+ memset(&d_flag[1], 0, sizeof(char) * n);
+ /* look through all vertices of the graph */
+ for (l = 1; l <= n; l++)
+ { /* take vertex i */
+ i = v_list[l].i;
+ /* if this vertex was already included in one of previosuly
+ * constructed cliques, skip it */
+ if (skip[i]) continue;
+ /* use vertex i as the initial clique vertex */
+ c_size = 1; /* size of current clique */
+ c_list[1] = i; /* list of vertices in current clique */
+ c_wght = w[i]; /* weight of current clique */
+ /* determine the candidate set D = { j : (i,j) in E } */
+ d_size = func(info, i, d_list);
+ xassert(0 <= d_size && d_size < n);
+ d_wght = 0.0; /* weight of set D */
+ for (k = 1; k <= d_size; k++)
+ { j = d_list[k];
+ xassert(1 <= j && j <= n && j != i);
+ xassert(!d_flag[j]);
+ d_flag[j] = 1;
+ d_wght += w[j];
+ }
+ /* check an upper bound to the final clique weight */
+ if (c_wght + d_wght < best + 1e-5 * (1.0 + fabs(best)))
+ { /* skip constructing the current clique */
+ goto next;
+ }
+ /* compute the summary weight of each vertex i in D, which is
+ * sw[i] = w[i] + sum{j in D and (i,j) in E} w[j] */
+ for (k = 1; k <= d_size; k++)
+ { i = d_list[k];
+ sw[i] = w[i];
+ /* consider vertices adjacent to vertex i */
+ deg = func(info, i, ind);
+ xassert(0 <= deg && deg < n);
+ for (kk = 1; kk <= deg; kk++)
+ { j = ind[kk];
+ xassert(1 <= j && j <= n && j != i);
+ if (d_flag[j]) sw[i] += w[j];
+ }
+ }
+ /* grow the current clique by adding vertices from D */
+ while (d_size > 0)
+ { /* check an upper bound to the final clique weight */
+ if (c_wght + d_wght < best + 1e-5 * (1.0 + fabs(best)))
+ { /* skip constructing the current clique */
+ goto next;
+ }
+ /* choose vertex i in D having maximal summary weight */
+ i = d_list[1];
+ for (k = 2; k <= d_size; k++)
+ { j = d_list[k];
+ if (sw[i] < sw[j]) i = j;
+ }
+ /* include vertex i in the current clique */
+ c_size++;
+ c_list[c_size] = i;
+ c_wght += w[i];
+ /* remove all vertices not adjacent to vertex i, including
+ * vertex i itself, from the candidate set D */
+ deg = func(info, i, ind);
+ xassert(0 <= deg && deg < n);
+ for (k = 1; k <= deg; k++)
+ { j = ind[k];
+ xassert(1 <= j && j <= n && j != i);
+ /* vertex j is adjacent to vertex i */
+ if (d_flag[j])
+ { xassert(d_flag[j] == 1);
+ /* mark vertex j to keep it in D */
+ d_flag[j] = 2;
+ }
+ }
+ kk = d_size, d_size = 0;
+ for (k = 1; k <= kk; k++)
+ { j = d_list[k];
+ if (d_flag[j] == 1)
+ { /* remove vertex j from D */
+ d_flag[j] = 0;
+ d_wght -= w[j];
+ }
+ else if (d_flag[j] == 2)
+ { /* keep vertex j in D */
+ d_list[++d_size] = j;
+ d_flag[j] = 1;
+ }
+ else
+ xassert(d_flag != d_flag);
+ }
+ }
+ /* the current clique has been completely constructed */
+ if (best < c_wght)
+ { best = c_wght;
+ size = c_size;
+ xassert(1 <= size && size <= n);
+ memcpy(&c[1], &c_list[1], size * sizeof(int));
+ }
+next: /* mark the current clique vertices in order not to use them
+ * as initial vertices anymore */
+ for (k = 1; k <= c_size; k++)
+ skip[c_list[k]] = 1;
+ /* set D can be non-empty, so clean up vertex flags */
+ for (k = 1; k <= d_size; k++)
+ d_flag[d_list[k]] = 0;
+ }
+ /* free working arrays */
+ xfree(ind);
+ xfree(v_list);
+ xfree(c_list);
+ xfree(d_list);
+ xfree(d_flag);
+ xfree(skip);
+ xfree(sw);
+done: /* return to the calling program */
+ return size;
+}
+
+/**********************************************************************/
+
+#ifdef GLP_TEST
+#include "glpk.h"
+#include "rng.h"
+
+typedef struct { double w; } v_data;
+
+#define weight(v) (((v_data *)((v)->data))->w)
+
+glp_graph *G;
+
+char *flag;
+
+int func(void *info, int i, int ind[])
+{ glp_arc *e;
+ int j, k, deg = 0;
+ xassert(info == NULL);
+ xassert(1 <= i && i <= G->nv);
+ /* look through incoming arcs */
+ for (e = G->v[i]->in; e != NULL; e = e->h_next)
+ { j = e->tail->i; /* j->i */
+ if (j != i && !flag[j]) ind[++deg] = j, flag[j] = 1;
+ }
+ /* look through outgoing arcs */
+ for (e = G->v[i]->out; e != NULL; e = e->t_next)
+ { j = e->head->i; /* i->j */
+ if (j != i && !flag[j]) ind[++deg] = j, flag[j] = 1;
+ }
+ /* clear the flag array */
+ xassert(deg < G->nv);
+ for (k = 1; k <= deg; k++) flag[ind[k]] = 0;
+ return deg;
+}
+
+int main(int argc, char *argv[])
+{ RNG *rand;
+ int i, k, kk, size, *c, *ind, deg;
+ double *w, sum, t;
+ /* read graph in DIMACS format */
+ G = glp_create_graph(sizeof(v_data), 0);
+ xassert(argc == 2);
+ xassert(glp_read_ccdata(G, offsetof(v_data, w), argv[1]) == 0);
+ /* print the number of connected components */
+ xprintf("nc = %d\n", glp_weak_comp(G, -1));
+ /* assign random weights unformly distributed in [1,100] */
+ w = xcalloc(1+G->nv, sizeof(double));
+ rand = rng_create_rand();
+ for (i = 1; i <= G->nv; i++)
+#if 0
+ w[i] = weight(G->v[i]) = 1.0;
+#else
+ w[i] = weight(G->v[i]) = rng_unif_rand(rand, 100) + 1;
+#endif
+ /* write graph in DIMACS format */
+ xassert(glp_write_ccdata(G, offsetof(v_data, w), "graph") == 0);
+ /* find maximum weight clique */
+ c = xcalloc(1+G->nv, sizeof(int));
+ flag = xcalloc(1+G->nv, sizeof(char));
+ memset(&flag[1], 0, G->nv);
+ t = xtime();
+ size = wclique1(G->nv, w, func, NULL, c);
+ xprintf("Time used: %.1f s\n", xdifftime(xtime(), t));
+ /* check the clique found */
+ ind = xcalloc(1+G->nv, sizeof(int));
+ for (k = 1; k <= size; k++)
+ { i = c[k];
+ deg = func(NULL, i, ind);
+ for (kk = 1; kk <= size; kk++)
+ flag[c[kk]] = 1;
+ flag[i] = 0;
+ for (kk = 1; kk <= deg; kk++)
+ flag[ind[kk]] = 0;
+ for (kk = 1; kk <= size; kk++)
+ xassert(flag[c[kk]] == 0);
+ }
+ /* compute the clique weight */
+ sum = 0.0;
+ for (i = 1; i <= size; i++)
+ sum += w[c[i]];
+ xprintf("size = %d; sum = %g\n", size, sum);
+ return 0;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/misc/wclique1.h b/test/monniaux/glpk-4.65/src/misc/wclique1.h
new file mode 100644
index 00000000..588f3257
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/misc/wclique1.h
@@ -0,0 +1,34 @@
+/* wclique1.h (maximum weight clique, greedy heuristic) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2012-2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef WCLIQUE1_H
+#define WCLIQUE1_H
+
+#define wclique1 _glp_wclique1
+int wclique1(int n, const double w[],
+ int (*func)(void *info, int i, int ind[]), void *info, int c[]);
+/* find maximum weight clique with greedy heuristic */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl.h b/test/monniaux/glpk-4.65/src/mpl/mpl.h
new file mode 100644
index 00000000..ddd31543
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl.h
@@ -0,0 +1,2598 @@
+/* mpl.h (GNU MathProg translator) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MPL_H
+#define MPL_H
+
+#include "avl.h"
+#include "dmp.h"
+#include "env.h"
+#include "misc.h"
+#include "rng.h"
+
+#if 0 /* 22/I-2013 */
+typedef struct MPL MPL;
+#else
+typedef struct glp_tran MPL;
+#endif
+typedef char STRING;
+typedef struct SYMBOL SYMBOL;
+typedef struct TUPLE TUPLE;
+typedef struct ARRAY ELEMSET;
+typedef struct ELEMVAR ELEMVAR;
+typedef struct FORMULA FORMULA;
+typedef struct ELEMCON ELEMCON;
+typedef union VALUE VALUE;
+typedef struct ARRAY ARRAY;
+typedef struct MEMBER MEMBER;
+#if 1
+/* many C compilers have DOMAIN declared in <math.h> :( */
+#undef DOMAIN
+#define DOMAIN DOMAIN1
+#endif
+typedef struct DOMAIN DOMAIN;
+typedef struct DOMAIN_BLOCK DOMAIN_BLOCK;
+typedef struct DOMAIN_SLOT DOMAIN_SLOT;
+typedef struct SET SET;
+typedef struct WITHIN WITHIN;
+typedef struct GADGET GADGET;
+typedef struct PARAMETER PARAMETER;
+typedef struct CONDITION CONDITION;
+typedef struct VARIABLE VARIABLE;
+typedef struct CONSTRAINT CONSTRAINT;
+typedef struct TABLE TABLE;
+typedef struct TABARG TABARG;
+typedef struct TABFLD TABFLD;
+typedef struct TABIN TABIN;
+typedef struct TABOUT TABOUT;
+typedef struct TABDCA TABDCA;
+typedef union OPERANDS OPERANDS;
+typedef struct ARG_LIST ARG_LIST;
+typedef struct CODE CODE;
+typedef struct CHECK CHECK;
+typedef struct DISPLAY DISPLAY;
+typedef struct DISPLAY1 DISPLAY1;
+typedef struct PRINTF PRINTF;
+typedef struct PRINTF1 PRINTF1;
+typedef struct FOR FOR;
+typedef struct STATEMENT STATEMENT;
+typedef struct TUPLE SLICE;
+
+/**********************************************************************/
+/* * * TRANSLATOR DATABASE * * */
+/**********************************************************************/
+
+#define A_BINARY 101 /* something binary */
+#define A_CHECK 102 /* check statement */
+#define A_CONSTRAINT 103 /* model constraint */
+#define A_DISPLAY 104 /* display statement */
+#define A_ELEMCON 105 /* elemental constraint/objective */
+#define A_ELEMSET 106 /* elemental set */
+#define A_ELEMVAR 107 /* elemental variable */
+#define A_EXPRESSION 108 /* expression */
+#define A_FOR 109 /* for statement */
+#define A_FORMULA 110 /* formula */
+#define A_INDEX 111 /* dummy index */
+#define A_INPUT 112 /* input table */
+#define A_INTEGER 113 /* something integer */
+#define A_LOGICAL 114 /* something logical */
+#define A_MAXIMIZE 115 /* objective has to be maximized */
+#define A_MINIMIZE 116 /* objective has to be minimized */
+#define A_NONE 117 /* nothing */
+#define A_NUMERIC 118 /* something numeric */
+#define A_OUTPUT 119 /* output table */
+#define A_PARAMETER 120 /* model parameter */
+#define A_PRINTF 121 /* printf statement */
+#define A_SET 122 /* model set */
+#define A_SOLVE 123 /* solve statement */
+#define A_SYMBOLIC 124 /* something symbolic */
+#define A_TABLE 125 /* data table */
+#define A_TUPLE 126 /* n-tuple */
+#define A_VARIABLE 127 /* model variable */
+
+#define MAX_LENGTH 100
+/* maximal length of any symbolic value (this includes symbolic names,
+ numeric and string literals, and all symbolic values that may appear
+ during the evaluation phase) */
+
+#define CONTEXT_SIZE 60
+/* size of the context queue, in characters */
+
+#define OUTBUF_SIZE 1024
+/* size of the output buffer, in characters */
+
+#if 0 /* 22/I-2013 */
+struct MPL
+#else
+struct glp_tran
+#endif
+{ /* translator database */
+ /*--------------------------------------------------------------*/
+ /* scanning segment */
+ int line;
+ /* number of the current text line */
+ int c;
+ /* the current character or EOF */
+ int token;
+ /* the current token: */
+#define T_EOF 201 /* end of file */
+#define T_NAME 202 /* symbolic name (model section only) */
+#define T_SYMBOL 203 /* symbol (data section only) */
+#define T_NUMBER 204 /* numeric literal */
+#define T_STRING 205 /* string literal */
+#define T_AND 206 /* and && */
+#define T_BY 207 /* by */
+#define T_CROSS 208 /* cross */
+#define T_DIFF 209 /* diff */
+#define T_DIV 210 /* div */
+#define T_ELSE 211 /* else */
+#define T_IF 212 /* if */
+#define T_IN 213 /* in */
+#define T_INFINITY 214 /* Infinity */
+#define T_INTER 215 /* inter */
+#define T_LESS 216 /* less */
+#define T_MOD 217 /* mod */
+#define T_NOT 218 /* not ! */
+#define T_OR 219 /* or || */
+#define T_SPTP 220 /* s.t. */
+#define T_SYMDIFF 221 /* symdiff */
+#define T_THEN 222 /* then */
+#define T_UNION 223 /* union */
+#define T_WITHIN 224 /* within */
+#define T_PLUS 225 /* + */
+#define T_MINUS 226 /* - */
+#define T_ASTERISK 227 /* * */
+#define T_SLASH 228 /* / */
+#define T_POWER 229 /* ^ ** */
+#define T_LT 230 /* < */
+#define T_LE 231 /* <= */
+#define T_EQ 232 /* = == */
+#define T_GE 233 /* >= */
+#define T_GT 234 /* > */
+#define T_NE 235 /* <> != */
+#define T_CONCAT 236 /* & */
+#define T_BAR 237 /* | */
+#define T_POINT 238 /* . */
+#define T_COMMA 239 /* , */
+#define T_COLON 240 /* : */
+#define T_SEMICOLON 241 /* ; */
+#define T_ASSIGN 242 /* := */
+#define T_DOTS 243 /* .. */
+#define T_LEFT 244 /* ( */
+#define T_RIGHT 245 /* ) */
+#define T_LBRACKET 246 /* [ */
+#define T_RBRACKET 247 /* ] */
+#define T_LBRACE 248 /* { */
+#define T_RBRACE 249 /* } */
+#define T_APPEND 250 /* >> */
+#define T_TILDE 251 /* ~ */
+#define T_INPUT 252 /* <- */
+ int imlen;
+ /* length of the current token */
+ char *image; /* char image[MAX_LENGTH+1]; */
+ /* image of the current token */
+ double value;
+ /* value of the current token (for T_NUMBER only) */
+ int b_token;
+ /* the previous token */
+ int b_imlen;
+ /* length of the previous token */
+ char *b_image; /* char b_image[MAX_LENGTH+1]; */
+ /* image of the previous token */
+ double b_value;
+ /* value of the previous token (if token is T_NUMBER) */
+ int f_dots;
+ /* if this flag is set, the next token should be recognized as
+ T_DOTS, not as T_POINT */
+ int f_scan;
+ /* if this flag is set, the next token is already scanned */
+ int f_token;
+ /* the next token */
+ int f_imlen;
+ /* length of the next token */
+ char *f_image; /* char f_image[MAX_LENGTH+1]; */
+ /* image of the next token */
+ double f_value;
+ /* value of the next token (if token is T_NUMBER) */
+ char *context; /* char context[CONTEXT_SIZE]; */
+ /* context circular queue (not null-terminated!) */
+ int c_ptr;
+ /* pointer to the current position in the context queue */
+ int flag_d;
+ /* if this flag is set, the data section is being processed */
+ /*--------------------------------------------------------------*/
+ /* translating segment */
+ DMP *pool;
+ /* memory pool used to allocate all data instances created during
+ the translation phase */
+ AVL *tree;
+ /* symbolic name table:
+ node.type = A_INDEX => node.link -> DOMAIN_SLOT
+ node.type = A_SET => node.link -> SET
+ node.type = A_PARAMETER => node.link -> PARAMETER
+ node.type = A_VARIABLE => node.link -> VARIABLE
+ node.type = A_CONSTRANT => node.link -> CONSTRAINT */
+ STATEMENT *model;
+ /* linked list of model statements in the original order */
+ int flag_x;
+ /* if this flag is set, the current token being left parenthesis
+ begins a slice that allows recognizing any undeclared symbolic
+ names as dummy indices; this flag is automatically reset once
+ the next token has been scanned */
+ int as_within;
+ /* the warning "in understood as within" has been issued */
+ int as_in;
+ /* the warning "within understood as in" has been issued */
+ int as_binary;
+ /* the warning "logical understood as binary" has been issued */
+ int flag_s;
+ /* if this flag is set, the solve statement has been parsed */
+ /*--------------------------------------------------------------*/
+ /* common segment */
+ DMP *strings;
+ /* memory pool to allocate STRING data structures */
+ DMP *symbols;
+ /* memory pool to allocate SYMBOL data structures */
+ DMP *tuples;
+ /* memory pool to allocate TUPLE data structures */
+ DMP *arrays;
+ /* memory pool to allocate ARRAY data structures */
+ DMP *members;
+ /* memory pool to allocate MEMBER data structures */
+ DMP *elemvars;
+ /* memory pool to allocate ELEMVAR data structures */
+ DMP *formulae;
+ /* memory pool to allocate FORMULA data structures */
+ DMP *elemcons;
+ /* memory pool to allocate ELEMCON data structures */
+ ARRAY *a_list;
+ /* linked list of all arrays in the database */
+ char *sym_buf; /* char sym_buf[255+1]; */
+ /* working buffer used by the routine format_symbol */
+ char *tup_buf; /* char tup_buf[255+1]; */
+ /* working buffer used by the routine format_tuple */
+ /*--------------------------------------------------------------*/
+ /* generating/postsolving segment */
+ RNG *rand;
+ /* pseudo-random number generator */
+ int flag_p;
+ /* if this flag is set, the postsolving phase is in effect */
+ STATEMENT *stmt;
+ /* model statement being currently executed */
+ TABDCA *dca;
+ /* pointer to table driver communication area for table statement
+ currently executed */
+ int m;
+ /* number of rows in the problem, m >= 0 */
+ int n;
+ /* number of columns in the problem, n >= 0 */
+ ELEMCON **row; /* ELEMCON *row[1+m]; */
+ /* row[0] is not used;
+ row[i] is elemental constraint or objective, which corresponds
+ to i-th row of the problem, 1 <= i <= m */
+ ELEMVAR **col; /* ELEMVAR *col[1+n]; */
+ /* col[0] is not used;
+ col[j] is elemental variable, which corresponds to j-th column
+ of the problem, 1 <= j <= n */
+ /*--------------------------------------------------------------*/
+ /* input/output segment */
+ glp_file *in_fp;
+ /* stream assigned to the input text file */
+ char *in_file;
+ /* name of the input text file */
+ glp_file *out_fp;
+ /* stream assigned to the output text file used to write all data
+ produced by display and printf statements; NULL means the data
+ should be sent to stdout via the routine xprintf */
+ char *out_file;
+ /* name of the output text file */
+#if 0 /* 08/XI-2009 */
+ char *out_buf; /* char out_buf[OUTBUF_SIZE] */
+ /* buffer to accumulate output data */
+ int out_cnt;
+ /* count of data bytes stored in the output buffer */
+#endif
+ glp_file *prt_fp;
+ /* stream assigned to the print text file; may be NULL */
+ char *prt_file;
+ /* name of the output print file */
+ /*--------------------------------------------------------------*/
+ /* solver interface segment */
+ jmp_buf jump;
+ /* jump address for non-local go to in case of error */
+ int phase;
+ /* phase of processing:
+ 0 - database is being or has been initialized
+ 1 - model section is being or has been read
+ 2 - data section is being or has been read
+ 3 - model is being or has been generated/postsolved
+ 4 - model processing error has occurred */
+ char *mod_file;
+ /* name of the input text file, which contains model section */
+ char *mpl_buf; /* char mpl_buf[255+1]; */
+ /* working buffer used by some interface routines */
+};
+
+/**********************************************************************/
+/* * * PROCESSING MODEL SECTION * * */
+/**********************************************************************/
+
+#define alloc(type) ((type *)dmp_get_atomv(mpl->pool, sizeof(type)))
+/* allocate atom of given type */
+
+#define enter_context _glp_mpl_enter_context
+void enter_context(MPL *mpl);
+/* enter current token into context queue */
+
+#define print_context _glp_mpl_print_context
+void print_context(MPL *mpl);
+/* print current content of context queue */
+
+#define get_char _glp_mpl_get_char
+void get_char(MPL *mpl);
+/* scan next character from input text file */
+
+#define append_char _glp_mpl_append_char
+void append_char(MPL *mpl);
+/* append character to current token */
+
+#define get_token _glp_mpl_get_token
+void get_token(MPL *mpl);
+/* scan next token from input text file */
+
+#define unget_token _glp_mpl_unget_token
+void unget_token(MPL *mpl);
+/* return current token back to input stream */
+
+#define is_keyword _glp_mpl_is_keyword
+int is_keyword(MPL *mpl, char *keyword);
+/* check if current token is given non-reserved keyword */
+
+#define is_reserved _glp_mpl_is_reserved
+int is_reserved(MPL *mpl);
+/* check if current token is reserved keyword */
+
+#define make_code _glp_mpl_make_code
+CODE *make_code(MPL *mpl, int op, OPERANDS *arg, int type, int dim);
+/* generate pseudo-code (basic routine) */
+
+#define make_unary _glp_mpl_make_unary
+CODE *make_unary(MPL *mpl, int op, CODE *x, int type, int dim);
+/* generate pseudo-code for unary operation */
+
+#define make_binary _glp_mpl_make_binary
+CODE *make_binary(MPL *mpl, int op, CODE *x, CODE *y, int type,
+ int dim);
+/* generate pseudo-code for binary operation */
+
+#define make_ternary _glp_mpl_make_ternary
+CODE *make_ternary(MPL *mpl, int op, CODE *x, CODE *y, CODE *z,
+ int type, int dim);
+/* generate pseudo-code for ternary operation */
+
+#define numeric_literal _glp_mpl_numeric_literal
+CODE *numeric_literal(MPL *mpl);
+/* parse reference to numeric literal */
+
+#define string_literal _glp_mpl_string_literal
+CODE *string_literal(MPL *mpl);
+/* parse reference to string literal */
+
+#define create_arg_list _glp_mpl_create_arg_list
+ARG_LIST *create_arg_list(MPL *mpl);
+/* create empty operands list */
+
+#define expand_arg_list _glp_mpl_expand_arg_list
+ARG_LIST *expand_arg_list(MPL *mpl, ARG_LIST *list, CODE *x);
+/* append operand to operands list */
+
+#define arg_list_len _glp_mpl_arg_list_len
+int arg_list_len(MPL *mpl, ARG_LIST *list);
+/* determine length of operands list */
+
+#define subscript_list _glp_mpl_subscript_list
+ARG_LIST *subscript_list(MPL *mpl);
+/* parse subscript list */
+
+#define object_reference _glp_mpl_object_reference
+CODE *object_reference(MPL *mpl);
+/* parse reference to named object */
+
+#define numeric_argument _glp_mpl_numeric_argument
+CODE *numeric_argument(MPL *mpl, char *func);
+/* parse argument passed to built-in function */
+
+#define symbolic_argument _glp_mpl_symbolic_argument
+CODE *symbolic_argument(MPL *mpl, char *func);
+
+#define elemset_argument _glp_mpl_elemset_argument
+CODE *elemset_argument(MPL *mpl, char *func);
+
+#define function_reference _glp_mpl_function_reference
+CODE *function_reference(MPL *mpl);
+/* parse reference to built-in function */
+
+#define create_domain _glp_mpl_create_domain
+DOMAIN *create_domain(MPL *mpl);
+/* create empty domain */
+
+#define create_block _glp_mpl_create_block
+DOMAIN_BLOCK *create_block(MPL *mpl);
+/* create empty domain block */
+
+#define append_block _glp_mpl_append_block
+void append_block(MPL *mpl, DOMAIN *domain, DOMAIN_BLOCK *block);
+/* append domain block to specified domain */
+
+#define append_slot _glp_mpl_append_slot
+DOMAIN_SLOT *append_slot(MPL *mpl, DOMAIN_BLOCK *block, char *name,
+ CODE *code);
+/* create and append new slot to domain block */
+
+#define expression_list _glp_mpl_expression_list
+CODE *expression_list(MPL *mpl);
+/* parse expression list */
+
+#define literal_set _glp_mpl_literal_set
+CODE *literal_set(MPL *mpl, CODE *code);
+/* parse literal set */
+
+#define indexing_expression _glp_mpl_indexing_expression
+DOMAIN *indexing_expression(MPL *mpl);
+/* parse indexing expression */
+
+#define close_scope _glp_mpl_close_scope
+void close_scope(MPL *mpl, DOMAIN *domain);
+/* close scope of indexing expression */
+
+#define iterated_expression _glp_mpl_iterated_expression
+CODE *iterated_expression(MPL *mpl);
+/* parse iterated expression */
+
+#define domain_arity _glp_mpl_domain_arity
+int domain_arity(MPL *mpl, DOMAIN *domain);
+/* determine arity of domain */
+
+#define set_expression _glp_mpl_set_expression
+CODE *set_expression(MPL *mpl);
+/* parse set expression */
+
+#define branched_expression _glp_mpl_branched_expression
+CODE *branched_expression(MPL *mpl);
+/* parse conditional expression */
+
+#define primary_expression _glp_mpl_primary_expression
+CODE *primary_expression(MPL *mpl);
+/* parse primary expression */
+
+#define error_preceding _glp_mpl_error_preceding
+void error_preceding(MPL *mpl, char *opstr);
+/* raise error if preceding operand has wrong type */
+
+#define error_following _glp_mpl_error_following
+void error_following(MPL *mpl, char *opstr);
+/* raise error if following operand has wrong type */
+
+#define error_dimension _glp_mpl_error_dimension
+void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2);
+/* raise error if operands have different dimension */
+
+#define expression_0 _glp_mpl_expression_0
+CODE *expression_0(MPL *mpl);
+/* parse expression of level 0 */
+
+#define expression_1 _glp_mpl_expression_1
+CODE *expression_1(MPL *mpl);
+/* parse expression of level 1 */
+
+#define expression_2 _glp_mpl_expression_2
+CODE *expression_2(MPL *mpl);
+/* parse expression of level 2 */
+
+#define expression_3 _glp_mpl_expression_3
+CODE *expression_3(MPL *mpl);
+/* parse expression of level 3 */
+
+#define expression_4 _glp_mpl_expression_4
+CODE *expression_4(MPL *mpl);
+/* parse expression of level 4 */
+
+#define expression_5 _glp_mpl_expression_5
+CODE *expression_5(MPL *mpl);
+/* parse expression of level 5 */
+
+#define expression_6 _glp_mpl_expression_6
+CODE *expression_6(MPL *mpl);
+/* parse expression of level 6 */
+
+#define expression_7 _glp_mpl_expression_7
+CODE *expression_7(MPL *mpl);
+/* parse expression of level 7 */
+
+#define expression_8 _glp_mpl_expression_8
+CODE *expression_8(MPL *mpl);
+/* parse expression of level 8 */
+
+#define expression_9 _glp_mpl_expression_9
+CODE *expression_9(MPL *mpl);
+/* parse expression of level 9 */
+
+#define expression_10 _glp_mpl_expression_10
+CODE *expression_10(MPL *mpl);
+/* parse expression of level 10 */
+
+#define expression_11 _glp_mpl_expression_11
+CODE *expression_11(MPL *mpl);
+/* parse expression of level 11 */
+
+#define expression_12 _glp_mpl_expression_12
+CODE *expression_12(MPL *mpl);
+/* parse expression of level 12 */
+
+#define expression_13 _glp_mpl_expression_13
+CODE *expression_13(MPL *mpl);
+/* parse expression of level 13 */
+
+#define set_statement _glp_mpl_set_statement
+SET *set_statement(MPL *mpl);
+/* parse set statement */
+
+#define parameter_statement _glp_mpl_parameter_statement
+PARAMETER *parameter_statement(MPL *mpl);
+/* parse parameter statement */
+
+#define variable_statement _glp_mpl_variable_statement
+VARIABLE *variable_statement(MPL *mpl);
+/* parse variable statement */
+
+#define constraint_statement _glp_mpl_constraint_statement
+CONSTRAINT *constraint_statement(MPL *mpl);
+/* parse constraint statement */
+
+#define objective_statement _glp_mpl_objective_statement
+CONSTRAINT *objective_statement(MPL *mpl);
+/* parse objective statement */
+
+#define table_statement _glp_mpl_table_statement
+TABLE *table_statement(MPL *mpl);
+/* parse table statement */
+
+#define solve_statement _glp_mpl_solve_statement
+void *solve_statement(MPL *mpl);
+/* parse solve statement */
+
+#define check_statement _glp_mpl_check_statement
+CHECK *check_statement(MPL *mpl);
+/* parse check statement */
+
+#define display_statement _glp_mpl_display_statement
+DISPLAY *display_statement(MPL *mpl);
+/* parse display statement */
+
+#define printf_statement _glp_mpl_printf_statement
+PRINTF *printf_statement(MPL *mpl);
+/* parse printf statement */
+
+#define for_statement _glp_mpl_for_statement
+FOR *for_statement(MPL *mpl);
+/* parse for statement */
+
+#define end_statement _glp_mpl_end_statement
+void end_statement(MPL *mpl);
+/* parse end statement */
+
+#define simple_statement _glp_mpl_simple_statement
+STATEMENT *simple_statement(MPL *mpl, int spec);
+/* parse simple statement */
+
+#define model_section _glp_mpl_model_section
+void model_section(MPL *mpl);
+/* parse model section */
+
+/**********************************************************************/
+/* * * PROCESSING DATA SECTION * * */
+/**********************************************************************/
+
+#if 2 + 2 == 5
+struct SLICE /* see TUPLE */
+{ /* component of slice; the slice itself is associated with its
+ first component; slices are similar to n-tuples with exception
+ that some slice components (which are indicated by asterisks)
+ don't refer to any symbols */
+ SYMBOL *sym;
+ /* symbol, which this component refers to; can be NULL */
+ SLICE *next;
+ /* the next component of slice */
+};
+#endif
+
+#define create_slice _glp_mpl_create_slice
+SLICE *create_slice(MPL *mpl);
+/* create slice */
+
+#define expand_slice _glp_mpl_expand_slice
+SLICE *expand_slice
+( MPL *mpl,
+ SLICE *slice, /* destroyed */
+ SYMBOL *sym /* destroyed */
+);
+/* append new component to slice */
+
+#define slice_dimen _glp_mpl_slice_dimen
+int slice_dimen
+( MPL *mpl,
+ SLICE *slice /* not changed */
+);
+/* determine dimension of slice */
+
+#define slice_arity _glp_mpl_slice_arity
+int slice_arity
+( MPL *mpl,
+ SLICE *slice /* not changed */
+);
+/* determine arity of slice */
+
+#define fake_slice _glp_mpl_fake_slice
+SLICE *fake_slice(MPL *mpl, int dim);
+/* create fake slice of all asterisks */
+
+#define delete_slice _glp_mpl_delete_slice
+void delete_slice
+( MPL *mpl,
+ SLICE *slice /* destroyed */
+);
+/* delete slice */
+
+#define is_number _glp_mpl_is_number
+int is_number(MPL *mpl);
+/* check if current token is number */
+
+#define is_symbol _glp_mpl_is_symbol
+int is_symbol(MPL *mpl);
+/* check if current token is symbol */
+
+#define is_literal _glp_mpl_is_literal
+int is_literal(MPL *mpl, char *literal);
+/* check if current token is given symbolic literal */
+
+#define read_number _glp_mpl_read_number
+double read_number(MPL *mpl);
+/* read number */
+
+#define read_symbol _glp_mpl_read_symbol
+SYMBOL *read_symbol(MPL *mpl);
+/* read symbol */
+
+#define read_slice _glp_mpl_read_slice
+SLICE *read_slice
+( MPL *mpl,
+ char *name, /* not changed */
+ int dim
+);
+/* read slice */
+
+#define select_set _glp_mpl_select_set
+SET *select_set
+( MPL *mpl,
+ char *name /* not changed */
+);
+/* select set to saturate it with elemental sets */
+
+#define simple_format _glp_mpl_simple_format
+void simple_format
+( MPL *mpl,
+ SET *set, /* not changed */
+ MEMBER *memb, /* modified */
+ SLICE *slice /* not changed */
+);
+/* read set data block in simple format */
+
+#define matrix_format _glp_mpl_matrix_format
+void matrix_format
+( MPL *mpl,
+ SET *set, /* not changed */
+ MEMBER *memb, /* modified */
+ SLICE *slice, /* not changed */
+ int tr
+);
+/* read set data block in matrix format */
+
+#define set_data _glp_mpl_set_data
+void set_data(MPL *mpl);
+/* read set data */
+
+#define select_parameter _glp_mpl_select_parameter
+PARAMETER *select_parameter
+( MPL *mpl,
+ char *name /* not changed */
+);
+/* select parameter to saturate it with data */
+
+#define set_default _glp_mpl_set_default
+void set_default
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SYMBOL *altval /* destroyed */
+);
+/* set default parameter value */
+
+#define read_value _glp_mpl_read_value
+MEMBER *read_value
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* destroyed */
+);
+/* read value and assign it to parameter member */
+
+#define plain_format _glp_mpl_plain_format
+void plain_format
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SLICE *slice /* not changed */
+);
+/* read parameter data block in plain format */
+
+#define tabular_format _glp_mpl_tabular_format
+void tabular_format
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SLICE *slice, /* not changed */
+ int tr
+);
+/* read parameter data block in tabular format */
+
+#define tabbing_format _glp_mpl_tabbing_format
+void tabbing_format
+( MPL *mpl,
+ SYMBOL *altval /* not changed */
+);
+/* read parameter data block in tabbing format */
+
+#define parameter_data _glp_mpl_parameter_data
+void parameter_data(MPL *mpl);
+/* read parameter data */
+
+#define data_section _glp_mpl_data_section
+void data_section(MPL *mpl);
+/* read data section */
+
+/**********************************************************************/
+/* * * FLOATING-POINT NUMBERS * * */
+/**********************************************************************/
+
+#define fp_add _glp_mpl_fp_add
+double fp_add(MPL *mpl, double x, double y);
+/* floating-point addition */
+
+#define fp_sub _glp_mpl_fp_sub
+double fp_sub(MPL *mpl, double x, double y);
+/* floating-point subtraction */
+
+#define fp_less _glp_mpl_fp_less
+double fp_less(MPL *mpl, double x, double y);
+/* floating-point non-negative subtraction */
+
+#define fp_mul _glp_mpl_fp_mul
+double fp_mul(MPL *mpl, double x, double y);
+/* floating-point multiplication */
+
+#define fp_div _glp_mpl_fp_div
+double fp_div(MPL *mpl, double x, double y);
+/* floating-point division */
+
+#define fp_idiv _glp_mpl_fp_idiv
+double fp_idiv(MPL *mpl, double x, double y);
+/* floating-point quotient of exact division */
+
+#define fp_mod _glp_mpl_fp_mod
+double fp_mod(MPL *mpl, double x, double y);
+/* floating-point remainder of exact division */
+
+#define fp_power _glp_mpl_fp_power
+double fp_power(MPL *mpl, double x, double y);
+/* floating-point exponentiation (raise to power) */
+
+#define fp_exp _glp_mpl_fp_exp
+double fp_exp(MPL *mpl, double x);
+/* floating-point base-e exponential */
+
+#define fp_log _glp_mpl_fp_log
+double fp_log(MPL *mpl, double x);
+/* floating-point natural logarithm */
+
+#define fp_log10 _glp_mpl_fp_log10
+double fp_log10(MPL *mpl, double x);
+/* floating-point common (decimal) logarithm */
+
+#define fp_sqrt _glp_mpl_fp_sqrt
+double fp_sqrt(MPL *mpl, double x);
+/* floating-point square root */
+
+#define fp_sin _glp_mpl_fp_sin
+double fp_sin(MPL *mpl, double x);
+/* floating-point trigonometric sine */
+
+#define fp_cos _glp_mpl_fp_cos
+double fp_cos(MPL *mpl, double x);
+/* floating-point trigonometric cosine */
+
+#define fp_tan _glp_mpl_fp_tan
+double fp_tan(MPL *mpl, double x);
+/* floating-point trigonometric tangent */
+
+#define fp_atan _glp_mpl_fp_atan
+double fp_atan(MPL *mpl, double x);
+/* floating-point trigonometric arctangent */
+
+#define fp_atan2 _glp_mpl_fp_atan2
+double fp_atan2(MPL *mpl, double y, double x);
+/* floating-point trigonometric arctangent */
+
+#define fp_round _glp_mpl_fp_round
+double fp_round(MPL *mpl, double x, double n);
+/* round floating-point value to n fractional digits */
+
+#define fp_trunc _glp_mpl_fp_trunc
+double fp_trunc(MPL *mpl, double x, double n);
+/* truncate floating-point value to n fractional digits */
+
+/**********************************************************************/
+/* * * PSEUDO-RANDOM NUMBER GENERATORS * * */
+/**********************************************************************/
+
+#define fp_irand224 _glp_mpl_fp_irand224
+double fp_irand224(MPL *mpl);
+/* pseudo-random integer in the range [0, 2^24) */
+
+#define fp_uniform01 _glp_mpl_fp_uniform01
+double fp_uniform01(MPL *mpl);
+/* pseudo-random number in the range [0, 1) */
+
+#define fp_uniform _glp_mpl_uniform
+double fp_uniform(MPL *mpl, double a, double b);
+/* pseudo-random number in the range [a, b) */
+
+#define fp_normal01 _glp_mpl_fp_normal01
+double fp_normal01(MPL *mpl);
+/* Gaussian random variate with mu = 0 and sigma = 1 */
+
+#define fp_normal _glp_mpl_fp_normal
+double fp_normal(MPL *mpl, double mu, double sigma);
+/* Gaussian random variate with specified mu and sigma */
+
+/**********************************************************************/
+/* * * DATE/TIME * * */
+/**********************************************************************/
+
+#define fn_gmtime _glp_mpl_fn_gmtime
+double fn_gmtime(MPL *mpl);
+/* obtain the current calendar time (UTC) */
+
+#define fn_str2time _glp_mpl_fn_str2time
+double fn_str2time(MPL *mpl, const char *str, const char *fmt);
+/* convert character string to the calendar time */
+
+#define fn_time2str _glp_mpl_fn_time2str
+void fn_time2str(MPL *mpl, char *str, double t, const char *fmt);
+/* convert the calendar time to character string */
+
+/**********************************************************************/
+/* * * CHARACTER STRINGS * * */
+/**********************************************************************/
+
+#define create_string _glp_mpl_create_string
+STRING *create_string
+( MPL *mpl,
+ char buf[MAX_LENGTH+1] /* not changed */
+);
+/* create character string */
+
+#define copy_string _glp_mpl_copy_string
+STRING *copy_string
+( MPL *mpl,
+ STRING *str /* not changed */
+);
+/* make copy of character string */
+
+#define compare_strings _glp_mpl_compare_strings
+int compare_strings
+( MPL *mpl,
+ STRING *str1, /* not changed */
+ STRING *str2 /* not changed */
+);
+/* compare one character string with another */
+
+#define fetch_string _glp_mpl_fetch_string
+char *fetch_string
+( MPL *mpl,
+ STRING *str, /* not changed */
+ char buf[MAX_LENGTH+1] /* modified */
+);
+/* extract content of character string */
+
+#define delete_string _glp_mpl_delete_string
+void delete_string
+( MPL *mpl,
+ STRING *str /* destroyed */
+);
+/* delete character string */
+
+/**********************************************************************/
+/* * * SYMBOLS * * */
+/**********************************************************************/
+
+struct SYMBOL
+{ /* symbol (numeric or abstract quantity) */
+ double num;
+ /* numeric value of symbol (used only if str == NULL) */
+ STRING *str;
+ /* abstract value of symbol (used only if str != NULL) */
+};
+
+#define create_symbol_num _glp_mpl_create_symbol_num
+SYMBOL *create_symbol_num(MPL *mpl, double num);
+/* create symbol of numeric type */
+
+#define create_symbol_str _glp_mpl_create_symbol_str
+SYMBOL *create_symbol_str
+( MPL *mpl,
+ STRING *str /* destroyed */
+);
+/* create symbol of abstract type */
+
+#define copy_symbol _glp_mpl_copy_symbol
+SYMBOL *copy_symbol
+( MPL *mpl,
+ SYMBOL *sym /* not changed */
+);
+/* make copy of symbol */
+
+#define compare_symbols _glp_mpl_compare_symbols
+int compare_symbols
+( MPL *mpl,
+ SYMBOL *sym1, /* not changed */
+ SYMBOL *sym2 /* not changed */
+);
+/* compare one symbol with another */
+
+#define delete_symbol _glp_mpl_delete_symbol
+void delete_symbol
+( MPL *mpl,
+ SYMBOL *sym /* destroyed */
+);
+/* delete symbol */
+
+#define format_symbol _glp_mpl_format_symbol
+char *format_symbol
+( MPL *mpl,
+ SYMBOL *sym /* not changed */
+);
+/* format symbol for displaying or printing */
+
+#define concat_symbols _glp_mpl_concat_symbols
+SYMBOL *concat_symbols
+( MPL *mpl,
+ SYMBOL *sym1, /* destroyed */
+ SYMBOL *sym2 /* destroyed */
+);
+/* concatenate one symbol with another */
+
+/**********************************************************************/
+/* * * N-TUPLES * * */
+/**********************************************************************/
+
+struct TUPLE
+{ /* component of n-tuple; the n-tuple itself is associated with
+ its first component; (note that 0-tuple has no components) */
+ SYMBOL *sym;
+ /* symbol, which the component refers to; cannot be NULL */
+ TUPLE *next;
+ /* the next component of n-tuple */
+};
+
+#define create_tuple _glp_mpl_create_tuple
+TUPLE *create_tuple(MPL *mpl);
+/* create n-tuple */
+
+#define expand_tuple _glp_mpl_expand_tuple
+TUPLE *expand_tuple
+( MPL *mpl,
+ TUPLE *tuple, /* destroyed */
+ SYMBOL *sym /* destroyed */
+);
+/* append symbol to n-tuple */
+
+#define tuple_dimen _glp_mpl_tuple_dimen
+int tuple_dimen
+( MPL *mpl,
+ TUPLE *tuple /* not changed */
+);
+/* determine dimension of n-tuple */
+
+#define copy_tuple _glp_mpl_copy_tuple
+TUPLE *copy_tuple
+( MPL *mpl,
+ TUPLE *tuple /* not changed */
+);
+/* make copy of n-tuple */
+
+#define compare_tuples _glp_mpl_compare_tuples
+int compare_tuples
+( MPL *mpl,
+ TUPLE *tuple1, /* not changed */
+ TUPLE *tuple2 /* not changed */
+);
+/* compare one n-tuple with another */
+
+#define build_subtuple _glp_mpl_build_subtuple
+TUPLE *build_subtuple
+( MPL *mpl,
+ TUPLE *tuple, /* not changed */
+ int dim
+);
+/* build subtuple of given n-tuple */
+
+#define delete_tuple _glp_mpl_delete_tuple
+void delete_tuple
+( MPL *mpl,
+ TUPLE *tuple /* destroyed */
+);
+/* delete n-tuple */
+
+#define format_tuple _glp_mpl_format_tuple
+char *format_tuple
+( MPL *mpl,
+ int c,
+ TUPLE *tuple /* not changed */
+);
+/* format n-tuple for displaying or printing */
+
+/**********************************************************************/
+/* * * ELEMENTAL SETS * * */
+/**********************************************************************/
+
+#if 2 + 2 == 5
+struct ELEMSET /* see ARRAY */
+{ /* elemental set of n-tuples; formally it is a "value" assigned
+ to members of model sets (like numbers and symbols, which are
+ values assigned to members of model parameters); note that a
+ simple model set is not an elemental set, it is 0-dimensional
+ array, the only member of which (if it exists) is assigned an
+ elemental set */
+#endif
+
+#define create_elemset _glp_mpl_create_elemset
+ELEMSET *create_elemset(MPL *mpl, int dim);
+/* create elemental set */
+
+#define find_tuple _glp_mpl_find_tuple
+MEMBER *find_tuple
+( MPL *mpl,
+ ELEMSET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* check if elemental set contains given n-tuple */
+
+#define add_tuple _glp_mpl_add_tuple
+MEMBER *add_tuple
+( MPL *mpl,
+ ELEMSET *set, /* modified */
+ TUPLE *tuple /* destroyed */
+);
+/* add new n-tuple to elemental set */
+
+#define check_then_add _glp_mpl_check_then_add
+MEMBER *check_then_add
+( MPL *mpl,
+ ELEMSET *set, /* modified */
+ TUPLE *tuple /* destroyed */
+);
+/* check and add new n-tuple to elemental set */
+
+#define copy_elemset _glp_mpl_copy_elemset
+ELEMSET *copy_elemset
+( MPL *mpl,
+ ELEMSET *set /* not changed */
+);
+/* make copy of elemental set */
+
+#define delete_elemset _glp_mpl_delete_elemset
+void delete_elemset
+( MPL *mpl,
+ ELEMSET *set /* destroyed */
+);
+/* delete elemental set */
+
+#define arelset_size _glp_mpl_arelset_size
+int arelset_size(MPL *mpl, double t0, double tf, double dt);
+/* compute size of "arithmetic" elemental set */
+
+#define arelset_member _glp_mpl_arelset_member
+double arelset_member(MPL *mpl, double t0, double tf, double dt, int j);
+/* compute member of "arithmetic" elemental set */
+
+#define create_arelset _glp_mpl_create_arelset
+ELEMSET *create_arelset(MPL *mpl, double t0, double tf, double dt);
+/* create "arithmetic" elemental set */
+
+#define set_union _glp_mpl_set_union
+ELEMSET *set_union
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+);
+/* union of two elemental sets */
+
+#define set_diff _glp_mpl_set_diff
+ELEMSET *set_diff
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+);
+/* difference between two elemental sets */
+
+#define set_symdiff _glp_mpl_set_symdiff
+ELEMSET *set_symdiff
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+);
+/* symmetric difference between two elemental sets */
+
+#define set_inter _glp_mpl_set_inter
+ELEMSET *set_inter
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+);
+/* intersection of two elemental sets */
+
+#define set_cross _glp_mpl_set_cross
+ELEMSET *set_cross
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+);
+/* cross (Cartesian) product of two elemental sets */
+
+/**********************************************************************/
+/* * * ELEMENTAL VARIABLES * * */
+/**********************************************************************/
+
+struct ELEMVAR
+{ /* elemental variable; formally it is a "value" assigned to
+ members of model variables (like numbers and symbols, which
+ are values assigned to members of model parameters) */
+ int j;
+ /* LP column number assigned to this elemental variable */
+ VARIABLE *var;
+ /* model variable, which contains this elemental variable */
+ MEMBER *memb;
+ /* array member, which is assigned this elemental variable */
+ double lbnd;
+ /* lower bound */
+ double ubnd;
+ /* upper bound */
+ double temp;
+ /* working quantity used in operations on linear forms; normally
+ it contains floating-point zero */
+#if 1 /* 15/V-2010 */
+ int stat;
+ double prim, dual;
+ /* solution components provided by the solver */
+#endif
+};
+
+/**********************************************************************/
+/* * * LINEAR FORMS * * */
+/**********************************************************************/
+
+struct FORMULA
+{ /* term of linear form c * x, where c is a coefficient, x is an
+ elemental variable; the linear form itself is the sum of terms
+ and is associated with its first term; (note that the linear
+ form may be empty that means the sum is equal to zero) */
+ double coef;
+ /* coefficient at elemental variable or constant term */
+ ELEMVAR *var;
+ /* reference to elemental variable; NULL means constant term */
+ FORMULA *next;
+ /* the next term of linear form */
+};
+
+#define constant_term _glp_mpl_constant_term
+FORMULA *constant_term(MPL *mpl, double coef);
+/* create constant term */
+
+#define single_variable _glp_mpl_single_variable
+FORMULA *single_variable
+( MPL *mpl,
+ ELEMVAR *var /* referenced */
+);
+/* create single variable */
+
+#define copy_formula _glp_mpl_copy_formula
+FORMULA *copy_formula
+( MPL *mpl,
+ FORMULA *form /* not changed */
+);
+/* make copy of linear form */
+
+#define delete_formula _glp_mpl_delete_formula
+void delete_formula
+( MPL *mpl,
+ FORMULA *form /* destroyed */
+);
+/* delete linear form */
+
+#define linear_comb _glp_mpl_linear_comb
+FORMULA *linear_comb
+( MPL *mpl,
+ double a, FORMULA *fx, /* destroyed */
+ double b, FORMULA *fy /* destroyed */
+);
+/* linear combination of two linear forms */
+
+#define remove_constant _glp_mpl_remove_constant
+FORMULA *remove_constant
+( MPL *mpl,
+ FORMULA *form, /* destroyed */
+ double *coef /* modified */
+);
+/* remove constant term from linear form */
+
+#define reduce_terms _glp_mpl_reduce_terms
+FORMULA *reduce_terms
+( MPL *mpl,
+ FORMULA *form /* destroyed */
+);
+/* reduce identical terms in linear form */
+
+/**********************************************************************/
+/* * * ELEMENTAL CONSTRAINTS * * */
+/**********************************************************************/
+
+struct ELEMCON
+{ /* elemental constraint; formally it is a "value" assigned to
+ members of model constraints (like numbers or symbols, which
+ are values assigned to members of model parameters) */
+ int i;
+ /* LP row number assigned to this elemental constraint */
+ CONSTRAINT *con;
+ /* model constraint, which contains this elemental constraint */
+ MEMBER *memb;
+ /* array member, which is assigned this elemental constraint */
+ FORMULA *form;
+ /* linear form */
+ double lbnd;
+ /* lower bound */
+ double ubnd;
+ /* upper bound */
+#if 1 /* 15/V-2010 */
+ int stat;
+ double prim, dual;
+ /* solution components provided by the solver */
+#endif
+};
+
+/**********************************************************************/
+/* * * GENERIC VALUES * * */
+/**********************************************************************/
+
+union VALUE
+{ /* generic value, which can be assigned to object member or be a
+ result of evaluation of expression */
+ /* indicator that specifies the particular type of generic value
+ is stored in the corresponding array or pseudo-code descriptor
+ and can be one of the following:
+ A_NONE - no value
+ A_NUMERIC - floating-point number
+ A_SYMBOLIC - symbol
+ A_LOGICAL - logical value
+ A_TUPLE - n-tuple
+ A_ELEMSET - elemental set
+ A_ELEMVAR - elemental variable
+ A_FORMULA - linear form
+ A_ELEMCON - elemental constraint */
+ void *none; /* null */
+ double num; /* value */
+ SYMBOL *sym; /* value */
+ int bit; /* value */
+ TUPLE *tuple; /* value */
+ ELEMSET *set; /* value */
+ ELEMVAR *var; /* reference */
+ FORMULA *form; /* value */
+ ELEMCON *con; /* reference */
+};
+
+#define delete_value _glp_mpl_delete_value
+void delete_value
+( MPL *mpl,
+ int type,
+ VALUE *value /* content destroyed */
+);
+/* delete generic value */
+
+/**********************************************************************/
+/* * * SYMBOLICALLY INDEXED ARRAYS * * */
+/**********************************************************************/
+
+struct ARRAY
+{ /* multi-dimensional array, a set of members indexed over simple
+ or compound sets of symbols; arrays are used to represent the
+ contents of model objects (i.e. sets, parameters, variables,
+ constraints, and objectives); arrays also are used as "values"
+ that are assigned to members of set objects, in which case the
+ array itself represents an elemental set */
+ int type;
+ /* type of generic values assigned to the array members:
+ A_NONE - none (members have no assigned values)
+ A_NUMERIC - floating-point numbers
+ A_SYMBOLIC - symbols
+ A_ELEMSET - elemental sets
+ A_ELEMVAR - elemental variables
+ A_ELEMCON - elemental constraints */
+ int dim;
+ /* dimension of the array that determines number of components in
+ n-tuples for all members of the array, dim >= 0; dim = 0 means
+ the array is 0-dimensional */
+ int size;
+ /* size of the array, i.e. number of its members */
+ MEMBER *head;
+ /* the first array member; NULL means the array is empty */
+ MEMBER *tail;
+ /* the last array member; NULL means the array is empty */
+ AVL *tree;
+ /* the search tree intended to find array members for logarithmic
+ time; NULL means the search tree doesn't exist */
+ ARRAY *prev;
+ /* the previous array in the translator database */
+ ARRAY *next;
+ /* the next array in the translator database */
+};
+
+struct MEMBER
+{ /* array member */
+ TUPLE *tuple;
+ /* n-tuple, which identifies the member; number of its components
+ is the same for all members within the array and determined by
+ the array dimension; duplicate members are not allowed */
+ MEMBER *next;
+ /* the next array member */
+ VALUE value;
+ /* generic value assigned to the member */
+};
+
+#define create_array _glp_mpl_create_array
+ARRAY *create_array(MPL *mpl, int type, int dim);
+/* create array */
+
+#define find_member _glp_mpl_find_member
+MEMBER *find_member
+( MPL *mpl,
+ ARRAY *array, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* find array member with given n-tuple */
+
+#define add_member _glp_mpl_add_member
+MEMBER *add_member
+( MPL *mpl,
+ ARRAY *array, /* modified */
+ TUPLE *tuple /* destroyed */
+);
+/* add new member to array */
+
+#define delete_array _glp_mpl_delete_array
+void delete_array
+( MPL *mpl,
+ ARRAY *array /* destroyed */
+);
+/* delete array */
+
+/**********************************************************************/
+/* * * DOMAINS AND DUMMY INDICES * * */
+/**********************************************************************/
+
+struct DOMAIN
+{ /* domain (a simple or compound set); syntactically domain looks
+ like '{ i in I, (j,k) in S, t in T : <predicate> }'; domains
+ are used to define sets, over which model objects are indexed,
+ and also as constituents of iterated operators */
+ DOMAIN_BLOCK *list;
+ /* linked list of domain blocks (in the example above such blocks
+ are 'i in I', '(j,k) in S', and 't in T'); this list cannot be
+ empty */
+ CODE *code;
+ /* pseudo-code for computing the logical predicate, which follows
+ the colon; NULL means no predicate is specified */
+};
+
+struct DOMAIN_BLOCK
+{ /* domain block; syntactically domain blocks look like 'i in I',
+ '(j,k) in S', and 't in T' in the example above (in the sequel
+ sets like I, S, and T are called basic sets) */
+ DOMAIN_SLOT *list;
+ /* linked list of domain slots (i.e. indexing positions); number
+ of slots in this list is the same as dimension of n-tuples in
+ the basic set; this list cannot be empty */
+ CODE *code;
+ /* pseudo-code for computing basic set; cannot be NULL */
+ TUPLE *backup;
+ /* if this n-tuple is not empty, current values of dummy indices
+ in the domain block are the same as components of this n-tuple
+ (note that this n-tuple may have larger dimension than number
+ of dummy indices in this block, in which case extra components
+ are ignored); this n-tuple is used to restore former values of
+ dummy indices, if they were changed due to recursive calls to
+ the domain block */
+ DOMAIN_BLOCK *next;
+ /* the next block in the same domain */
+};
+
+struct DOMAIN_SLOT
+{ /* domain slot; it specifies an individual indexing position and
+ defines the corresponding dummy index */
+ char *name;
+ /* symbolic name of the dummy index; null pointer means the dummy
+ index is not explicitly specified */
+ CODE *code;
+ /* pseudo-code for computing symbolic value, at which the dummy
+ index is bound; NULL means the dummy index is free within the
+ domain scope */
+ SYMBOL *value;
+ /* current value assigned to the dummy index; NULL means no value
+ is assigned at the moment */
+ CODE *list;
+ /* linked list of pseudo-codes with operation O_INDEX referring
+ to this slot; this linked list is used to invalidate resultant
+ values of the operation, which depend on this dummy index */
+ DOMAIN_SLOT *next;
+ /* the next slot in the same domain block */
+};
+
+#define assign_dummy_index _glp_mpl_assign_dummy_index
+void assign_dummy_index
+( MPL *mpl,
+ DOMAIN_SLOT *slot, /* modified */
+ SYMBOL *value /* not changed */
+);
+/* assign new value to dummy index */
+
+#define update_dummy_indices _glp_mpl_update_dummy_indices
+void update_dummy_indices
+( MPL *mpl,
+ DOMAIN_BLOCK *block /* not changed */
+);
+/* update current values of dummy indices */
+
+#define enter_domain_block _glp_mpl_enter_domain_block
+int enter_domain_block
+( MPL *mpl,
+ DOMAIN_BLOCK *block, /* not changed */
+ TUPLE *tuple, /* not changed */
+ void *info, void (*func)(MPL *mpl, void *info)
+);
+/* enter domain block */
+
+#define eval_within_domain _glp_mpl_eval_within_domain
+int eval_within_domain
+( MPL *mpl,
+ DOMAIN *domain, /* not changed */
+ TUPLE *tuple, /* not changed */
+ void *info, void (*func)(MPL *mpl, void *info)
+);
+/* perform evaluation within domain scope */
+
+#define loop_within_domain _glp_mpl_loop_within_domain
+void loop_within_domain
+( MPL *mpl,
+ DOMAIN *domain, /* not changed */
+ void *info, int (*func)(MPL *mpl, void *info)
+);
+/* perform iterations within domain scope */
+
+#define out_of_domain _glp_mpl_out_of_domain
+void out_of_domain
+( MPL *mpl,
+ char *name, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* raise domain exception */
+
+#define get_domain_tuple _glp_mpl_get_domain_tuple
+TUPLE *get_domain_tuple
+( MPL *mpl,
+ DOMAIN *domain /* not changed */
+);
+/* obtain current n-tuple from domain */
+
+#define clean_domain _glp_mpl_clean_domain
+void clean_domain(MPL *mpl, DOMAIN *domain);
+/* clean domain */
+
+/**********************************************************************/
+/* * * MODEL SETS * * */
+/**********************************************************************/
+
+struct SET
+{ /* model set */
+ char *name;
+ /* symbolic name; cannot be NULL */
+ char *alias;
+ /* alias; NULL means alias is not specified */
+ int dim; /* aka arity */
+ /* dimension (number of subscripts); dim = 0 means 0-dimensional
+ (unsubscripted) set, dim > 0 means set of sets */
+ DOMAIN *domain;
+ /* subscript domain; NULL for 0-dimensional set */
+ int dimen;
+ /* dimension of n-tuples, which members of this set consist of
+ (note that the model set itself is an array of elemental sets,
+ which are its members; so, don't confuse this dimension with
+ dimension of the model set); always non-zero */
+ WITHIN *within;
+ /* list of supersets, which restrict each member of the set to be
+ in every superset from this list; this list can be empty */
+ CODE *assign;
+ /* pseudo-code for computing assigned value; can be NULL */
+ CODE *option;
+ /* pseudo-code for computing default value; can be NULL */
+ GADGET *gadget;
+ /* plain set used to initialize the array of sets; can be NULL */
+ int data;
+ /* data status flag:
+ 0 - no data are provided in the data section
+ 1 - data are provided, but not checked yet
+ 2 - data are provided and have been checked */
+ ARRAY *array;
+ /* array of members, which are assigned elemental sets */
+};
+
+struct WITHIN
+{ /* restricting superset list entry */
+ CODE *code;
+ /* pseudo-code for computing the superset; cannot be NULL */
+ WITHIN *next;
+ /* the next entry for the same set or parameter */
+};
+
+struct GADGET
+{ /* plain set used to initialize the array of sets with data */
+ SET *set;
+ /* pointer to plain set; cannot be NULL */
+ int ind[20]; /* ind[dim+dimen]; */
+ /* permutation of integers 1, 2, ..., dim+dimen */
+};
+
+#define check_elem_set _glp_mpl_check_elem_set
+void check_elem_set
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple, /* not changed */
+ ELEMSET *refer /* not changed */
+);
+/* check elemental set assigned to set member */
+
+#define take_member_set _glp_mpl_take_member_set
+ELEMSET *take_member_set /* returns reference, not value */
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* obtain elemental set assigned to set member */
+
+#define eval_member_set _glp_mpl_eval_member_set
+ELEMSET *eval_member_set /* returns reference, not value */
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* evaluate elemental set assigned to set member */
+
+#define eval_whole_set _glp_mpl_eval_whole_set
+void eval_whole_set(MPL *mpl, SET *set);
+/* evaluate model set over entire domain */
+
+#define clean_set _glp_mpl_clean_set
+void clean_set(MPL *mpl, SET *set);
+/* clean model set */
+
+/**********************************************************************/
+/* * * MODEL PARAMETERS * * */
+/**********************************************************************/
+
+struct PARAMETER
+{ /* model parameter */
+ char *name;
+ /* symbolic name; cannot be NULL */
+ char *alias;
+ /* alias; NULL means alias is not specified */
+ int dim; /* aka arity */
+ /* dimension (number of subscripts); dim = 0 means 0-dimensional
+ (unsubscripted) parameter */
+ DOMAIN *domain;
+ /* subscript domain; NULL for 0-dimensional parameter */
+ int type;
+ /* parameter type:
+ A_NUMERIC - numeric
+ A_INTEGER - integer
+ A_BINARY - binary
+ A_SYMBOLIC - symbolic */
+ CONDITION *cond;
+ /* list of conditions, which restrict each parameter member to
+ satisfy to every condition from this list; this list is used
+ only for numeric parameters and can be empty */
+ WITHIN *in;
+ /* list of supersets, which restrict each parameter member to be
+ in every superset from this list; this list is used only for
+ symbolic parameters and can be empty */
+ CODE *assign;
+ /* pseudo-code for computing assigned value; can be NULL */
+ CODE *option;
+ /* pseudo-code for computing default value; can be NULL */
+ int data;
+ /* data status flag:
+ 0 - no data are provided in the data section
+ 1 - data are provided, but not checked yet
+ 2 - data are provided and have been checked */
+ SYMBOL *defval;
+ /* default value provided in the data section; can be NULL */
+ ARRAY *array;
+ /* array of members, which are assigned numbers or symbols */
+};
+
+struct CONDITION
+{ /* restricting condition list entry */
+ int rho;
+ /* flag that specifies the form of the condition:
+ O_LT - less than
+ O_LE - less than or equal to
+ O_EQ - equal to
+ O_GE - greater than or equal to
+ O_GT - greater than
+ O_NE - not equal to */
+ CODE *code;
+ /* pseudo-code for computing the reference value */
+ CONDITION *next;
+ /* the next entry for the same parameter */
+};
+
+#define check_value_num _glp_mpl_check_value_num
+void check_value_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple, /* not changed */
+ double value
+);
+/* check numeric value assigned to parameter member */
+
+#define take_member_num _glp_mpl_take_member_num
+double take_member_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* obtain numeric value assigned to parameter member */
+
+#define eval_member_num _glp_mpl_eval_member_num
+double eval_member_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* evaluate numeric value assigned to parameter member */
+
+#define check_value_sym _glp_mpl_check_value_sym
+void check_value_sym
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple, /* not changed */
+ SYMBOL *value /* not changed */
+);
+/* check symbolic value assigned to parameter member */
+
+#define take_member_sym _glp_mpl_take_member_sym
+SYMBOL *take_member_sym /* returns value, not reference */
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* obtain symbolic value assigned to parameter member */
+
+#define eval_member_sym _glp_mpl_eval_member_sym
+SYMBOL *eval_member_sym /* returns value, not reference */
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* evaluate symbolic value assigned to parameter member */
+
+#define eval_whole_par _glp_mpl_eval_whole_par
+void eval_whole_par(MPL *mpl, PARAMETER *par);
+/* evaluate model parameter over entire domain */
+
+#define clean_parameter _glp_mpl_clean_parameter
+void clean_parameter(MPL *mpl, PARAMETER *par);
+/* clean model parameter */
+
+/**********************************************************************/
+/* * * MODEL VARIABLES * * */
+/**********************************************************************/
+
+struct VARIABLE
+{ /* model variable */
+ char *name;
+ /* symbolic name; cannot be NULL */
+ char *alias;
+ /* alias; NULL means alias is not specified */
+ int dim; /* aka arity */
+ /* dimension (number of subscripts); dim = 0 means 0-dimensional
+ (unsubscripted) variable */
+ DOMAIN *domain;
+ /* subscript domain; NULL for 0-dimensional variable */
+ int type;
+ /* variable type:
+ A_NUMERIC - continuous
+ A_INTEGER - integer
+ A_BINARY - binary */
+ CODE *lbnd;
+ /* pseudo-code for computing lower bound; NULL means lower bound
+ is not specified */
+ CODE *ubnd;
+ /* pseudo-code for computing upper bound; NULL means upper bound
+ is not specified */
+ /* if both the pointers lbnd and ubnd refer to the same code, the
+ variable is fixed at the corresponding value */
+ ARRAY *array;
+ /* array of members, which are assigned elemental variables */
+};
+
+#define take_member_var _glp_mpl_take_member_var
+ELEMVAR *take_member_var /* returns reference */
+( MPL *mpl,
+ VARIABLE *var, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* obtain reference to elemental variable */
+
+#define eval_member_var _glp_mpl_eval_member_var
+ELEMVAR *eval_member_var /* returns reference */
+( MPL *mpl,
+ VARIABLE *var, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* evaluate reference to elemental variable */
+
+#define eval_whole_var _glp_mpl_eval_whole_var
+void eval_whole_var(MPL *mpl, VARIABLE *var);
+/* evaluate model variable over entire domain */
+
+#define clean_variable _glp_mpl_clean_variable
+void clean_variable(MPL *mpl, VARIABLE *var);
+/* clean model variable */
+
+/**********************************************************************/
+/* * * MODEL CONSTRAINTS AND OBJECTIVES * * */
+/**********************************************************************/
+
+struct CONSTRAINT
+{ /* model constraint or objective */
+ char *name;
+ /* symbolic name; cannot be NULL */
+ char *alias;
+ /* alias; NULL means alias is not specified */
+ int dim; /* aka arity */
+ /* dimension (number of subscripts); dim = 0 means 0-dimensional
+ (unsubscripted) constraint */
+ DOMAIN *domain;
+ /* subscript domain; NULL for 0-dimensional constraint */
+ int type;
+ /* constraint type:
+ A_CONSTRAINT - constraint
+ A_MINIMIZE - objective (minimization)
+ A_MAXIMIZE - objective (maximization) */
+ CODE *code;
+ /* pseudo-code for computing main linear form; cannot be NULL */
+ CODE *lbnd;
+ /* pseudo-code for computing lower bound; NULL means lower bound
+ is not specified */
+ CODE *ubnd;
+ /* pseudo-code for computing upper bound; NULL means upper bound
+ is not specified */
+ /* if both the pointers lbnd and ubnd refer to the same code, the
+ constraint has the form of equation */
+ ARRAY *array;
+ /* array of members, which are assigned elemental constraints */
+};
+
+#define take_member_con _glp_mpl_take_member_con
+ELEMCON *take_member_con /* returns reference */
+( MPL *mpl,
+ CONSTRAINT *con, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* obtain reference to elemental constraint */
+
+#define eval_member_con _glp_mpl_eval_member_con
+ELEMCON *eval_member_con /* returns reference */
+( MPL *mpl,
+ CONSTRAINT *con, /* not changed */
+ TUPLE *tuple /* not changed */
+);
+/* evaluate reference to elemental constraint */
+
+#define eval_whole_con _glp_mpl_eval_whole_con
+void eval_whole_con(MPL *mpl, CONSTRAINT *con);
+/* evaluate model constraint over entire domain */
+
+#define clean_constraint _glp_mpl_clean_constraint
+void clean_constraint(MPL *mpl, CONSTRAINT *con);
+/* clean model constraint */
+
+/**********************************************************************/
+/* * * DATA TABLES * * */
+/**********************************************************************/
+
+struct TABLE
+{ /* data table */
+ char *name;
+ /* symbolic name; cannot be NULL */
+ char *alias;
+ /* alias; NULL means alias is not specified */
+ int type;
+ /* table type:
+ A_INPUT - input table
+ A_OUTPUT - output table */
+ TABARG *arg;
+ /* argument list; cannot be empty */
+ union
+ { struct
+ { SET *set;
+ /* input set; NULL means the set is not specified */
+ TABFLD *fld;
+ /* field list; cannot be empty */
+ TABIN *list;
+ /* input list; can be empty */
+ } in;
+ struct
+ { DOMAIN *domain;
+ /* subscript domain; cannot be NULL */
+ TABOUT *list;
+ /* output list; cannot be empty */
+ } out;
+ } u;
+};
+
+struct TABARG
+{ /* table argument list entry */
+ CODE *code;
+ /* pseudo-code for computing the argument */
+ TABARG *next;
+ /* next entry for the same table */
+};
+
+struct TABFLD
+{ /* table field list entry */
+ char *name;
+ /* field name; cannot be NULL */
+ TABFLD *next;
+ /* next entry for the same table */
+};
+
+struct TABIN
+{ /* table input list entry */
+ PARAMETER *par;
+ /* parameter to be read; cannot be NULL */
+ char *name;
+ /* column name; cannot be NULL */
+ TABIN *next;
+ /* next entry for the same table */
+};
+
+struct TABOUT
+{ /* table output list entry */
+ CODE *code;
+ /* pseudo-code for computing the value to be written */
+ char *name;
+ /* column name; cannot be NULL */
+ TABOUT *next;
+ /* next entry for the same table */
+};
+
+struct TABDCA
+{ /* table driver communication area */
+ int id;
+ /* driver identifier (set by mpl_tab_drv_open) */
+ void *link;
+ /* driver link pointer (set by mpl_tab_drv_open) */
+ int na;
+ /* number of arguments */
+ char **arg; /* char *arg[1+ns]; */
+ /* arg[k], 1 <= k <= ns, is pointer to k-th argument */
+ int nf;
+ /* number of fields */
+ char **name; /* char *name[1+nc]; */
+ /* name[k], 1 <= k <= nc, is name of k-th field */
+ int *type; /* int type[1+nc]; */
+ /* type[k], 1 <= k <= nc, is type of k-th field:
+ '?' - value not assigned
+ 'N' - number
+ 'S' - character string */
+ double *num; /* double num[1+nc]; */
+ /* num[k], 1 <= k <= nc, is numeric value of k-th field */
+ char **str;
+ /* str[k], 1 <= k <= nc, is string value of k-th field */
+};
+
+#define mpl_tab_num_args _glp_mpl_tab_num_args
+int mpl_tab_num_args(TABDCA *dca);
+
+#define mpl_tab_get_arg _glp_mpl_tab_get_arg
+const char *mpl_tab_get_arg(TABDCA *dca, int k);
+
+#define mpl_tab_num_flds _glp_mpl_tab_num_flds
+int mpl_tab_num_flds(TABDCA *dca);
+
+#define mpl_tab_get_name _glp_mpl_tab_get_name
+const char *mpl_tab_get_name(TABDCA *dca, int k);
+
+#define mpl_tab_get_type _glp_mpl_tab_get_type
+int mpl_tab_get_type(TABDCA *dca, int k);
+
+#define mpl_tab_get_num _glp_mpl_tab_get_num
+double mpl_tab_get_num(TABDCA *dca, int k);
+
+#define mpl_tab_get_str _glp_mpl_tab_get_str
+const char *mpl_tab_get_str(TABDCA *dca, int k);
+
+#define mpl_tab_set_num _glp_mpl_tab_set_num
+void mpl_tab_set_num(TABDCA *dca, int k, double num);
+
+#define mpl_tab_set_str _glp_mpl_tab_set_str
+void mpl_tab_set_str(TABDCA *dca, int k, const char *str);
+
+#define mpl_tab_drv_open _glp_mpl_tab_drv_open
+void mpl_tab_drv_open(MPL *mpl, int mode);
+
+#define mpl_tab_drv_read _glp_mpl_tab_drv_read
+int mpl_tab_drv_read(MPL *mpl);
+
+#define mpl_tab_drv_write _glp_mpl_tab_drv_write
+void mpl_tab_drv_write(MPL *mpl);
+
+#define mpl_tab_drv_close _glp_mpl_tab_drv_close
+void mpl_tab_drv_close(MPL *mpl);
+
+/**********************************************************************/
+/* * * PSEUDO-CODE * * */
+/**********************************************************************/
+
+union OPERANDS
+{ /* operands that participate in pseudo-code operation (choice of
+ particular operands depends on the operation code) */
+ /*--------------------------------------------------------------*/
+ double num; /* O_NUMBER */
+ /* floaing-point number to be taken */
+ /*--------------------------------------------------------------*/
+ char *str; /* O_STRING */
+ /* character string to be taken */
+ /*--------------------------------------------------------------*/
+ struct /* O_INDEX */
+ { DOMAIN_SLOT *slot;
+ /* domain slot, which contains dummy index to be taken */
+ CODE *next;
+ /* the next pseudo-code with op = O_INDEX, which refers to the
+ same slot as this one; pointer to the beginning of this list
+ is stored in the corresponding domain slot */
+ } index;
+ /*--------------------------------------------------------------*/
+ struct /* O_MEMNUM, O_MEMSYM */
+ { PARAMETER *par;
+ /* model parameter, which contains member to be taken */
+ ARG_LIST *list;
+ /* list of subscripts; NULL for 0-dimensional parameter */
+ } par;
+ /*--------------------------------------------------------------*/
+ struct /* O_MEMSET */
+ { SET *set;
+ /* model set, which contains member to be taken */
+ ARG_LIST *list;
+ /* list of subscripts; NULL for 0-dimensional set */
+ } set;
+ /*--------------------------------------------------------------*/
+ struct /* O_MEMVAR */
+ { VARIABLE *var;
+ /* model variable, which contains member to be taken */
+ ARG_LIST *list;
+ /* list of subscripts; NULL for 0-dimensional variable */
+#if 1 /* 15/V-2010 */
+ int suff;
+ /* suffix specified: */
+#define DOT_NONE 0x00 /* none (means variable itself) */
+#define DOT_LB 0x01 /* .lb (lower bound) */
+#define DOT_UB 0x02 /* .ub (upper bound) */
+#define DOT_STATUS 0x03 /* .status (status) */
+#define DOT_VAL 0x04 /* .val (primal value) */
+#define DOT_DUAL 0x05 /* .dual (dual value) */
+#endif
+ } var;
+#if 1 /* 15/V-2010 */
+ /*--------------------------------------------------------------*/
+ struct /* O_MEMCON */
+ { CONSTRAINT *con;
+ /* model constraint, which contains member to be taken */
+ ARG_LIST *list;
+ /* list of subscripys; NULL for 0-dimensional constraint */
+ int suff;
+ /* suffix specified (see O_MEMVAR above) */
+ } con;
+#endif
+ /*--------------------------------------------------------------*/
+ ARG_LIST *list; /* O_TUPLE, O_MAKE, n-ary operations */
+ /* list of operands */
+ /*--------------------------------------------------------------*/
+ DOMAIN_BLOCK *slice; /* O_SLICE */
+ /* domain block, which specifies slice (i.e. n-tuple that contains
+ free dummy indices); this operation is never evaluated */
+ /*--------------------------------------------------------------*/
+ struct /* unary, binary, ternary operations */
+ { CODE *x;
+ /* pseudo-code for computing first operand */
+ CODE *y;
+ /* pseudo-code for computing second operand */
+ CODE *z;
+ /* pseudo-code for computing third operand */
+ } arg;
+ /*--------------------------------------------------------------*/
+ struct /* iterated operations */
+ { DOMAIN *domain;
+ /* domain, over which the operation is performed */
+ CODE *x;
+ /* pseudo-code for computing "integrand" */
+ } loop;
+ /*--------------------------------------------------------------*/
+};
+
+struct ARG_LIST
+{ /* operands list entry */
+ CODE *x;
+ /* pseudo-code for computing operand */
+ ARG_LIST *next;
+ /* the next operand of the same operation */
+};
+
+struct CODE
+{ /* pseudo-code (internal form of expressions) */
+ int op;
+ /* operation code: */
+#define O_NUMBER 301 /* take floating-point number */
+#define O_STRING 302 /* take character string */
+#define O_INDEX 303 /* take dummy index */
+#define O_MEMNUM 304 /* take member of numeric parameter */
+#define O_MEMSYM 305 /* take member of symbolic parameter */
+#define O_MEMSET 306 /* take member of set */
+#define O_MEMVAR 307 /* take member of variable */
+#define O_MEMCON 308 /* take member of constraint */
+#define O_TUPLE 309 /* make n-tuple */
+#define O_MAKE 310 /* make elemental set of n-tuples */
+#define O_SLICE 311 /* define domain block (dummy op) */
+ /* 0-ary operations --------------------*/
+#define O_IRAND224 312 /* pseudo-random in [0, 2^24-1] */
+#define O_UNIFORM01 313 /* pseudo-random in [0, 1) */
+#define O_NORMAL01 314 /* gaussian random, mu = 0, sigma = 1 */
+#define O_GMTIME 315 /* current calendar time (UTC) */
+ /* unary operations --------------------*/
+#define O_CVTNUM 316 /* conversion to numeric */
+#define O_CVTSYM 317 /* conversion to symbolic */
+#define O_CVTLOG 318 /* conversion to logical */
+#define O_CVTTUP 319 /* conversion to 1-tuple */
+#define O_CVTLFM 320 /* conversion to linear form */
+#define O_PLUS 321 /* unary plus */
+#define O_MINUS 322 /* unary minus */
+#define O_NOT 323 /* negation (logical "not") */
+#define O_ABS 324 /* absolute value */
+#define O_CEIL 325 /* round upward ("ceiling of x") */
+#define O_FLOOR 326 /* round downward ("floor of x") */
+#define O_EXP 327 /* base-e exponential */
+#define O_LOG 328 /* natural logarithm */
+#define O_LOG10 329 /* common (decimal) logarithm */
+#define O_SQRT 330 /* square root */
+#define O_SIN 331 /* trigonometric sine */
+#define O_COS 332 /* trigonometric cosine */
+#define O_TAN 333 /* trigonometric tangent */
+#define O_ATAN 334 /* trigonometric arctangent */
+#define O_ROUND 335 /* round to nearest integer */
+#define O_TRUNC 336 /* truncate to nearest integer */
+#define O_CARD 337 /* cardinality of set */
+#define O_LENGTH 338 /* length of symbolic value */
+ /* binary operations -------------------*/
+#define O_ADD 339 /* addition */
+#define O_SUB 340 /* subtraction */
+#define O_LESS 341 /* non-negative subtraction */
+#define O_MUL 342 /* multiplication */
+#define O_DIV 343 /* division */
+#define O_IDIV 344 /* quotient of exact division */
+#define O_MOD 345 /* remainder of exact division */
+#define O_POWER 346 /* exponentiation (raise to power) */
+#define O_ATAN2 347 /* trigonometric arctangent */
+#define O_ROUND2 348 /* round to n fractional digits */
+#define O_TRUNC2 349 /* truncate to n fractional digits */
+#define O_UNIFORM 350 /* pseudo-random in [a, b) */
+#define O_NORMAL 351 /* gaussian random, given mu and sigma */
+#define O_CONCAT 352 /* concatenation */
+#define O_LT 353 /* comparison on 'less than' */
+#define O_LE 354 /* comparison on 'not greater than' */
+#define O_EQ 355 /* comparison on 'equal to' */
+#define O_GE 356 /* comparison on 'not less than' */
+#define O_GT 357 /* comparison on 'greater than' */
+#define O_NE 358 /* comparison on 'not equal to' */
+#define O_AND 359 /* conjunction (logical "and") */
+#define O_OR 360 /* disjunction (logical "or") */
+#define O_UNION 361 /* union */
+#define O_DIFF 362 /* difference */
+#define O_SYMDIFF 363 /* symmetric difference */
+#define O_INTER 364 /* intersection */
+#define O_CROSS 365 /* cross (Cartesian) product */
+#define O_IN 366 /* test on 'x in Y' */
+#define O_NOTIN 367 /* test on 'x not in Y' */
+#define O_WITHIN 368 /* test on 'X within Y' */
+#define O_NOTWITHIN 369 /* test on 'X not within Y' */
+#define O_SUBSTR 370 /* substring */
+#define O_STR2TIME 371 /* convert string to time */
+#define O_TIME2STR 372 /* convert time to string */
+ /* ternary operations ------------------*/
+#define O_DOTS 373 /* build "arithmetic" set */
+#define O_FORK 374 /* if-then-else */
+#define O_SUBSTR3 375 /* substring */
+ /* n-ary operations --------------------*/
+#define O_MIN 376 /* minimal value (n-ary) */
+#define O_MAX 377 /* maximal value (n-ary) */
+ /* iterated operations -----------------*/
+#define O_SUM 378 /* summation */
+#define O_PROD 379 /* multiplication */
+#define O_MINIMUM 380 /* minimum */
+#define O_MAXIMUM 381 /* maximum */
+#define O_FORALL 382 /* conjunction (A-quantification) */
+#define O_EXISTS 383 /* disjunction (E-quantification) */
+#define O_SETOF 384 /* compute elemental set */
+#define O_BUILD 385 /* build elemental set */
+ OPERANDS arg;
+ /* operands that participate in the operation */
+ int type;
+ /* type of the resultant value:
+ A_NUMERIC - numeric
+ A_SYMBOLIC - symbolic
+ A_LOGICAL - logical
+ A_TUPLE - n-tuple
+ A_ELEMSET - elemental set
+ A_FORMULA - linear form */
+ int dim;
+ /* dimension of the resultant value; for A_TUPLE and A_ELEMSET it
+ is the dimension of the corresponding n-tuple(s) and cannot be
+ zero; for other resultant types it is always zero */
+ CODE *up;
+ /* parent pseudo-code, which refers to this pseudo-code as to its
+ operand; NULL means this pseudo-code has no parent and defines
+ an expression, which is not contained in another expression */
+ int vflag;
+ /* volatile flag; being set this flag means that this operation
+ has a side effect; for primary expressions this flag is set
+ directly by corresponding parsing routines (for example, if
+ primary expression is a reference to a function that generates
+ pseudo-random numbers); in other cases this flag is inherited
+ from operands */
+ int valid;
+ /* if this flag is set, the resultant value, which is a temporary
+ result of evaluating this operation on particular values of
+ operands, is valid; if this flag is clear, the resultant value
+ doesn't exist and therefore not valid; having been evaluated
+ the resultant value is stored here and not destroyed until the
+ dummy indices, which this value depends on, have been changed
+ (and if it doesn't depend on dummy indices at all, it is never
+ destroyed); thus, if the resultant value is valid, evaluating
+ routine can immediately take its copy not computing the result
+ from scratch; this mechanism is similar to moving invariants
+ out of loops and allows improving efficiency at the expense of
+ some extra memory needed to keep temporary results */
+ /* however, if the volatile flag (see above) is set, even if the
+ resultant value is valid, evaluating routine computes it as if
+ it were not valid, i.e. caching is not used in this case */
+ VALUE value;
+ /* resultant value in generic format */
+};
+
+#define eval_numeric _glp_mpl_eval_numeric
+double eval_numeric(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to determine numeric value */
+
+#define eval_symbolic _glp_mpl_eval_symbolic
+SYMBOL *eval_symbolic(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to determine symbolic value */
+
+#define eval_logical _glp_mpl_eval_logical
+int eval_logical(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to determine logical value */
+
+#define eval_tuple _glp_mpl_eval_tuple
+TUPLE *eval_tuple(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to construct n-tuple */
+
+#define eval_elemset _glp_mpl_eval_elemset
+ELEMSET *eval_elemset(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to construct elemental set */
+
+#define is_member _glp_mpl_is_member
+int is_member(MPL *mpl, CODE *code, TUPLE *tuple);
+/* check if n-tuple is in set specified by pseudo-code */
+
+#define eval_formula _glp_mpl_eval_formula
+FORMULA *eval_formula(MPL *mpl, CODE *code);
+/* evaluate pseudo-code to construct linear form */
+
+#define clean_code _glp_mpl_clean_code
+void clean_code(MPL *mpl, CODE *code);
+/* clean pseudo-code */
+
+/**********************************************************************/
+/* * * MODEL STATEMENTS * * */
+/**********************************************************************/
+
+struct CHECK
+{ /* check statement */
+ DOMAIN *domain;
+ /* subscript domain; NULL means domain is not used */
+ CODE *code;
+ /* code for computing the predicate to be checked */
+};
+
+struct DISPLAY
+{ /* display statement */
+ DOMAIN *domain;
+ /* subscript domain; NULL means domain is not used */
+ DISPLAY1 *list;
+ /* display list; cannot be empty */
+};
+
+struct DISPLAY1
+{ /* display list entry */
+ int type;
+ /* item type:
+ A_INDEX - dummy index
+ A_SET - model set
+ A_PARAMETER - model parameter
+ A_VARIABLE - model variable
+ A_CONSTRAINT - model constraint/objective
+ A_EXPRESSION - expression */
+ union
+ { DOMAIN_SLOT *slot;
+ SET *set;
+ PARAMETER *par;
+ VARIABLE *var;
+ CONSTRAINT *con;
+ CODE *code;
+ } u;
+ /* item to be displayed */
+#if 0 /* 15/V-2010 */
+ ARG_LIST *list;
+ /* optional subscript list (for constraint/objective only) */
+#endif
+ DISPLAY1 *next;
+ /* the next entry for the same statement */
+};
+
+struct PRINTF
+{ /* printf statement */
+ DOMAIN *domain;
+ /* subscript domain; NULL means domain is not used */
+ CODE *fmt;
+ /* pseudo-code for computing format string */
+ PRINTF1 *list;
+ /* printf list; can be empty */
+ CODE *fname;
+ /* pseudo-code for computing filename to redirect the output;
+ NULL means the output goes to stdout */
+ int app;
+ /* if this flag is set, the output is appended */
+};
+
+struct PRINTF1
+{ /* printf list entry */
+ CODE *code;
+ /* pseudo-code for computing value to be printed */
+ PRINTF1 *next;
+ /* the next entry for the same statement */
+};
+
+struct FOR
+{ /* for statement */
+ DOMAIN *domain;
+ /* subscript domain; cannot be NULL */
+ STATEMENT *list;
+ /* linked list of model statements within this for statement in
+ the original order */
+};
+
+struct STATEMENT
+{ /* model statement */
+ int line;
+ /* number of source text line, where statement begins */
+ int type;
+ /* statement type:
+ A_SET - set statement
+ A_PARAMETER - parameter statement
+ A_VARIABLE - variable statement
+ A_CONSTRAINT - constraint/objective statement
+ A_TABLE - table statement
+ A_SOLVE - solve statement
+ A_CHECK - check statement
+ A_DISPLAY - display statement
+ A_PRINTF - printf statement
+ A_FOR - for statement */
+ union
+ { SET *set;
+ PARAMETER *par;
+ VARIABLE *var;
+ CONSTRAINT *con;
+ TABLE *tab;
+ void *slv; /* currently not used (set to NULL) */
+ CHECK *chk;
+ DISPLAY *dpy;
+ PRINTF *prt;
+ FOR *fur;
+ } u;
+ /* specific part of statement */
+ STATEMENT *next;
+ /* the next statement; in this list statements follow in the same
+ order as they appear in the model section */
+};
+
+#define execute_table _glp_mpl_execute_table
+void execute_table(MPL *mpl, TABLE *tab);
+/* execute table statement */
+
+#define free_dca _glp_mpl_free_dca
+void free_dca(MPL *mpl);
+/* free table driver communucation area */
+
+#define clean_table _glp_mpl_clean_table
+void clean_table(MPL *mpl, TABLE *tab);
+/* clean table statement */
+
+#define execute_check _glp_mpl_execute_check
+void execute_check(MPL *mpl, CHECK *chk);
+/* execute check statement */
+
+#define clean_check _glp_mpl_clean_check
+void clean_check(MPL *mpl, CHECK *chk);
+/* clean check statement */
+
+#define execute_display _glp_mpl_execute_display
+void execute_display(MPL *mpl, DISPLAY *dpy);
+/* execute display statement */
+
+#define clean_display _glp_mpl_clean_display
+void clean_display(MPL *mpl, DISPLAY *dpy);
+/* clean display statement */
+
+#define execute_printf _glp_mpl_execute_printf
+void execute_printf(MPL *mpl, PRINTF *prt);
+/* execute printf statement */
+
+#define clean_printf _glp_mpl_clean_printf
+void clean_printf(MPL *mpl, PRINTF *prt);
+/* clean printf statement */
+
+#define execute_for _glp_mpl_execute_for
+void execute_for(MPL *mpl, FOR *fur);
+/* execute for statement */
+
+#define clean_for _glp_mpl_clean_for
+void clean_for(MPL *mpl, FOR *fur);
+/* clean for statement */
+
+#define execute_statement _glp_mpl_execute_statement
+void execute_statement(MPL *mpl, STATEMENT *stmt);
+/* execute specified model statement */
+
+#define clean_statement _glp_mpl_clean_statement
+void clean_statement(MPL *mpl, STATEMENT *stmt);
+/* clean specified model statement */
+
+/**********************************************************************/
+/* * * GENERATING AND POSTSOLVING MODEL * * */
+/**********************************************************************/
+
+#define alloc_content _glp_mpl_alloc_content
+void alloc_content(MPL *mpl);
+/* allocate content arrays for all model objects */
+
+#define generate_model _glp_mpl_generate_model
+void generate_model(MPL *mpl);
+/* generate model */
+
+#define build_problem _glp_mpl_build_problem
+void build_problem(MPL *mpl);
+/* build problem instance */
+
+#define postsolve_model _glp_mpl_postsolve_model
+void postsolve_model(MPL *mpl);
+/* postsolve model */
+
+#define clean_model _glp_mpl_clean_model
+void clean_model(MPL *mpl);
+/* clean model content */
+
+/**********************************************************************/
+/* * * INPUT/OUTPUT * * */
+/**********************************************************************/
+
+#define open_input _glp_mpl_open_input
+void open_input(MPL *mpl, char *file);
+/* open input text file */
+
+#define read_char _glp_mpl_read_char
+int read_char(MPL *mpl);
+/* read next character from input text file */
+
+#define close_input _glp_mpl_close_input
+void close_input(MPL *mpl);
+/* close input text file */
+
+#define open_output _glp_mpl_open_output
+void open_output(MPL *mpl, char *file);
+/* open output text file */
+
+#define write_char _glp_mpl_write_char
+void write_char(MPL *mpl, int c);
+/* write next character to output text file */
+
+#define write_text _glp_mpl_write_text
+void write_text(MPL *mpl, char *fmt, ...);
+/* format and write text to output text file */
+
+#define flush_output _glp_mpl_flush_output
+void flush_output(MPL *mpl);
+/* finalize writing data to output text file */
+
+/**********************************************************************/
+/* * * SOLVER INTERFACE * * */
+/**********************************************************************/
+
+#define MPL_FR 401 /* free (unbounded) */
+#define MPL_LO 402 /* lower bound */
+#define MPL_UP 403 /* upper bound */
+#define MPL_DB 404 /* both lower and upper bounds */
+#define MPL_FX 405 /* fixed */
+
+#define MPL_ST 411 /* constraint */
+#define MPL_MIN 412 /* objective (minimization) */
+#define MPL_MAX 413 /* objective (maximization) */
+
+#define MPL_NUM 421 /* continuous */
+#define MPL_INT 422 /* integer */
+#define MPL_BIN 423 /* binary */
+
+#define error _glp_mpl_error
+void error(MPL *mpl, char *fmt, ...);
+/* print error message and terminate model processing */
+
+#define warning _glp_mpl_warning
+void warning(MPL *mpl, char *fmt, ...);
+/* print warning message and continue model processing */
+
+#define mpl_initialize _glp_mpl_initialize
+MPL *mpl_initialize(void);
+/* create and initialize translator database */
+
+#define mpl_read_model _glp_mpl_read_model
+int mpl_read_model(MPL *mpl, char *file, int skip_data);
+/* read model section and optional data section */
+
+#define mpl_read_data _glp_mpl_read_data
+int mpl_read_data(MPL *mpl, char *file);
+/* read data section */
+
+#define mpl_generate _glp_mpl_generate
+int mpl_generate(MPL *mpl, char *file);
+/* generate model */
+
+#define mpl_get_prob_name _glp_mpl_get_prob_name
+char *mpl_get_prob_name(MPL *mpl);
+/* obtain problem (model) name */
+
+#define mpl_get_num_rows _glp_mpl_get_num_rows
+int mpl_get_num_rows(MPL *mpl);
+/* determine number of rows */
+
+#define mpl_get_num_cols _glp_mpl_get_num_cols
+int mpl_get_num_cols(MPL *mpl);
+/* determine number of columns */
+
+#define mpl_get_row_name _glp_mpl_get_row_name
+char *mpl_get_row_name(MPL *mpl, int i);
+/* obtain row name */
+
+#define mpl_get_row_kind _glp_mpl_get_row_kind
+int mpl_get_row_kind(MPL *mpl, int i);
+/* determine row kind */
+
+#define mpl_get_row_bnds _glp_mpl_get_row_bnds
+int mpl_get_row_bnds(MPL *mpl, int i, double *lb, double *ub);
+/* obtain row bounds */
+
+#define mpl_get_mat_row _glp_mpl_get_mat_row
+int mpl_get_mat_row(MPL *mpl, int i, int ndx[], double val[]);
+/* obtain row of the constraint matrix */
+
+#define mpl_get_row_c0 _glp_mpl_get_row_c0
+double mpl_get_row_c0(MPL *mpl, int i);
+/* obtain constant term of free row */
+
+#define mpl_get_col_name _glp_mpl_get_col_name
+char *mpl_get_col_name(MPL *mpl, int j);
+/* obtain column name */
+
+#define mpl_get_col_kind _glp_mpl_get_col_kind
+int mpl_get_col_kind(MPL *mpl, int j);
+/* determine column kind */
+
+#define mpl_get_col_bnds _glp_mpl_get_col_bnds
+int mpl_get_col_bnds(MPL *mpl, int j, double *lb, double *ub);
+/* obtain column bounds */
+
+#define mpl_has_solve_stmt _glp_mpl_has_solve_stmt
+int mpl_has_solve_stmt(MPL *mpl);
+/* check if model has solve statement */
+
+#if 1 /* 15/V-2010 */
+#define mpl_put_row_soln _glp_mpl_put_row_soln
+void mpl_put_row_soln(MPL *mpl, int i, int stat, double prim,
+ double dual);
+/* store row (constraint/objective) solution components */
+#endif
+
+#if 1 /* 15/V-2010 */
+#define mpl_put_col_soln _glp_mpl_put_col_soln
+void mpl_put_col_soln(MPL *mpl, int j, int stat, double prim,
+ double dual);
+/* store column (variable) solution components */
+#endif
+
+#if 0 /* 15/V-2010 */
+#define mpl_put_col_value _glp_mpl_put_col_value
+void mpl_put_col_value(MPL *mpl, int j, double val);
+/* store column value */
+#endif
+
+#define mpl_postsolve _glp_mpl_postsolve
+int mpl_postsolve(MPL *mpl);
+/* postsolve model */
+
+#define mpl_terminate _glp_mpl_terminate
+void mpl_terminate(MPL *mpl);
+/* free all resources used by translator */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl1.c b/test/monniaux/glpk-4.65/src/mpl/mpl1.c
new file mode 100644
index 00000000..7dc3cd79
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl1.c
@@ -0,0 +1,4718 @@
+/* mpl1.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+
+#define dmp_get_atomv dmp_get_atom
+
+/**********************************************************************/
+/* * * PROCESSING MODEL SECTION * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- enter_context - enter current token into context queue.
+--
+-- This routine enters the current token into the context queue. */
+
+void enter_context(MPL *mpl)
+{ char *image, *s;
+ if (mpl->token == T_EOF)
+ image = "_|_";
+ else if (mpl->token == T_STRING)
+ image = "'...'";
+ else
+ image = mpl->image;
+ xassert(0 <= mpl->c_ptr && mpl->c_ptr < CONTEXT_SIZE);
+ mpl->context[mpl->c_ptr++] = ' ';
+ if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0;
+ for (s = image; *s != '\0'; s++)
+ { mpl->context[mpl->c_ptr++] = *s;
+ if (mpl->c_ptr == CONTEXT_SIZE) mpl->c_ptr = 0;
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- print_context - print current content of context queue.
+--
+-- This routine prints current content of the context queue. */
+
+void print_context(MPL *mpl)
+{ int c;
+ while (mpl->c_ptr > 0)
+ { mpl->c_ptr--;
+ c = mpl->context[0];
+ memmove(mpl->context, mpl->context+1, CONTEXT_SIZE-1);
+ mpl->context[CONTEXT_SIZE-1] = (char)c;
+ }
+ xprintf("Context: %s%.*s\n", mpl->context[0] == ' ' ? "" : "...",
+ CONTEXT_SIZE, mpl->context);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- get_char - scan next character from input text file.
+--
+-- This routine scans a next ASCII character from the input text file.
+-- In case of end-of-file, the character is assigned EOF. */
+
+void get_char(MPL *mpl)
+{ int c;
+ if (mpl->c == EOF) goto done;
+ if (mpl->c == '\n') mpl->line++;
+ c = read_char(mpl);
+ if (c == EOF)
+ { if (mpl->c == '\n')
+ mpl->line--;
+ else
+ warning(mpl, "final NL missing before end of file");
+ }
+ else if (c == '\n')
+ ;
+ else if (isspace(c))
+ c = ' ';
+ else if (iscntrl(c))
+ { enter_context(mpl);
+ error(mpl, "control character 0x%02X not allowed", c);
+ }
+ mpl->c = c;
+done: return;
+}
+
+/*----------------------------------------------------------------------
+-- append_char - append character to current token.
+--
+-- This routine appends the current character to the current token and
+-- then scans a next character. */
+
+void append_char(MPL *mpl)
+{ xassert(0 <= mpl->imlen && mpl->imlen <= MAX_LENGTH);
+ if (mpl->imlen == MAX_LENGTH)
+ { switch (mpl->token)
+ { case T_NAME:
+ enter_context(mpl);
+ error(mpl, "symbolic name %s... too long", mpl->image);
+ case T_SYMBOL:
+ enter_context(mpl);
+ error(mpl, "symbol %s... too long", mpl->image);
+ case T_NUMBER:
+ enter_context(mpl);
+ error(mpl, "numeric literal %s... too long", mpl->image);
+ case T_STRING:
+ enter_context(mpl);
+ error(mpl, "string literal too long");
+ default:
+ xassert(mpl != mpl);
+ }
+ }
+ mpl->image[mpl->imlen++] = (char)mpl->c;
+ mpl->image[mpl->imlen] = '\0';
+ get_char(mpl);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- get_token - scan next token from input text file.
+--
+-- This routine scans a next token from the input text file using the
+-- standard finite automation technique. */
+
+void get_token(MPL *mpl)
+{ /* save the current token */
+ mpl->b_token = mpl->token;
+ mpl->b_imlen = mpl->imlen;
+ strcpy(mpl->b_image, mpl->image);
+ mpl->b_value = mpl->value;
+ /* if the next token is already scanned, make it current */
+ if (mpl->f_scan)
+ { mpl->f_scan = 0;
+ mpl->token = mpl->f_token;
+ mpl->imlen = mpl->f_imlen;
+ strcpy(mpl->image, mpl->f_image);
+ mpl->value = mpl->f_value;
+ goto done;
+ }
+loop: /* nothing has been scanned so far */
+ mpl->token = 0;
+ mpl->imlen = 0;
+ mpl->image[0] = '\0';
+ mpl->value = 0.0;
+ /* skip any uninteresting characters */
+ while (mpl->c == ' ' || mpl->c == '\n') get_char(mpl);
+ /* recognize and construct the token */
+ if (mpl->c == EOF)
+ { /* end-of-file reached */
+ mpl->token = T_EOF;
+ }
+ else if (mpl->c == '#')
+ { /* comment; skip anything until end-of-line */
+ while (mpl->c != '\n' && mpl->c != EOF) get_char(mpl);
+ goto loop;
+ }
+ else if (!mpl->flag_d && (isalpha(mpl->c) || mpl->c == '_'))
+ { /* symbolic name or reserved keyword */
+ mpl->token = T_NAME;
+ while (isalnum(mpl->c) || mpl->c == '_') append_char(mpl);
+ if (strcmp(mpl->image, "and") == 0)
+ mpl->token = T_AND;
+ else if (strcmp(mpl->image, "by") == 0)
+ mpl->token = T_BY;
+ else if (strcmp(mpl->image, "cross") == 0)
+ mpl->token = T_CROSS;
+ else if (strcmp(mpl->image, "diff") == 0)
+ mpl->token = T_DIFF;
+ else if (strcmp(mpl->image, "div") == 0)
+ mpl->token = T_DIV;
+ else if (strcmp(mpl->image, "else") == 0)
+ mpl->token = T_ELSE;
+ else if (strcmp(mpl->image, "if") == 0)
+ mpl->token = T_IF;
+ else if (strcmp(mpl->image, "in") == 0)
+ mpl->token = T_IN;
+#if 1 /* 21/VII-2006 */
+ else if (strcmp(mpl->image, "Infinity") == 0)
+ mpl->token = T_INFINITY;
+#endif
+ else if (strcmp(mpl->image, "inter") == 0)
+ mpl->token = T_INTER;
+ else if (strcmp(mpl->image, "less") == 0)
+ mpl->token = T_LESS;
+ else if (strcmp(mpl->image, "mod") == 0)
+ mpl->token = T_MOD;
+ else if (strcmp(mpl->image, "not") == 0)
+ mpl->token = T_NOT;
+ else if (strcmp(mpl->image, "or") == 0)
+ mpl->token = T_OR;
+ else if (strcmp(mpl->image, "s") == 0 && mpl->c == '.')
+ { mpl->token = T_SPTP;
+ append_char(mpl);
+ if (mpl->c != 't')
+sptp: { enter_context(mpl);
+ error(mpl, "keyword s.t. incomplete");
+ }
+ append_char(mpl);
+ if (mpl->c != '.') goto sptp;
+ append_char(mpl);
+ }
+ else if (strcmp(mpl->image, "symdiff") == 0)
+ mpl->token = T_SYMDIFF;
+ else if (strcmp(mpl->image, "then") == 0)
+ mpl->token = T_THEN;
+ else if (strcmp(mpl->image, "union") == 0)
+ mpl->token = T_UNION;
+ else if (strcmp(mpl->image, "within") == 0)
+ mpl->token = T_WITHIN;
+ }
+ else if (!mpl->flag_d && isdigit(mpl->c))
+ { /* numeric literal */
+ mpl->token = T_NUMBER;
+ /* scan integer part */
+ while (isdigit(mpl->c)) append_char(mpl);
+ /* scan optional fractional part */
+ if (mpl->c == '.')
+ { append_char(mpl);
+ if (mpl->c == '.')
+ { /* hmm, it is not the fractional part, it is dots that
+ follow the integer part */
+ mpl->imlen--;
+ mpl->image[mpl->imlen] = '\0';
+ mpl->f_dots = 1;
+ goto conv;
+ }
+frac: while (isdigit(mpl->c)) append_char(mpl);
+ }
+ /* scan optional decimal exponent */
+ if (mpl->c == 'e' || mpl->c == 'E')
+ { append_char(mpl);
+ if (mpl->c == '+' || mpl->c == '-') append_char(mpl);
+ if (!isdigit(mpl->c))
+ { enter_context(mpl);
+ error(mpl, "numeric literal %s incomplete", mpl->image);
+ }
+ while (isdigit(mpl->c)) append_char(mpl);
+ }
+ /* there must be no letter following the numeric literal */
+ if (isalpha(mpl->c) || mpl->c == '_')
+ { enter_context(mpl);
+ error(mpl, "symbol %s%c... should be enclosed in quotes",
+ mpl->image, mpl->c);
+ }
+conv: /* convert numeric literal to floating-point */
+ if (str2num(mpl->image, &mpl->value))
+err: { enter_context(mpl);
+ error(mpl, "cannot convert numeric literal %s to floating-p"
+ "oint number", mpl->image);
+ }
+ }
+ else if (mpl->c == '\'' || mpl->c == '"')
+ { /* character string */
+ int quote = mpl->c;
+ mpl->token = T_STRING;
+ get_char(mpl);
+ for (;;)
+ { if (mpl->c == '\n' || mpl->c == EOF)
+ { enter_context(mpl);
+ error(mpl, "unexpected end of line; string literal incom"
+ "plete");
+ }
+ if (mpl->c == quote)
+ { get_char(mpl);
+ if (mpl->c != quote) break;
+ }
+ append_char(mpl);
+ }
+ }
+ else if (!mpl->flag_d && mpl->c == '+')
+ mpl->token = T_PLUS, append_char(mpl);
+ else if (!mpl->flag_d && mpl->c == '-')
+ mpl->token = T_MINUS, append_char(mpl);
+ else if (mpl->c == '*')
+ { mpl->token = T_ASTERISK, append_char(mpl);
+ if (mpl->c == '*')
+ mpl->token = T_POWER, append_char(mpl);
+ }
+ else if (mpl->c == '/')
+ { mpl->token = T_SLASH, append_char(mpl);
+ if (mpl->c == '*')
+ { /* comment sequence */
+ get_char(mpl);
+ for (;;)
+ { if (mpl->c == EOF)
+ { /* do not call enter_context at this point */
+ error(mpl, "unexpected end of file; comment sequence "
+ "incomplete");
+ }
+ else if (mpl->c == '*')
+ { get_char(mpl);
+ if (mpl->c == '/') break;
+ }
+ else
+ get_char(mpl);
+ }
+ get_char(mpl);
+ goto loop;
+ }
+ }
+ else if (mpl->c == '^')
+ mpl->token = T_POWER, append_char(mpl);
+ else if (mpl->c == '<')
+ { mpl->token = T_LT, append_char(mpl);
+ if (mpl->c == '=')
+ mpl->token = T_LE, append_char(mpl);
+ else if (mpl->c == '>')
+ mpl->token = T_NE, append_char(mpl);
+#if 1 /* 11/II-2008 */
+ else if (mpl->c == '-')
+ mpl->token = T_INPUT, append_char(mpl);
+#endif
+ }
+ else if (mpl->c == '=')
+ { mpl->token = T_EQ, append_char(mpl);
+ if (mpl->c == '=') append_char(mpl);
+ }
+ else if (mpl->c == '>')
+ { mpl->token = T_GT, append_char(mpl);
+ if (mpl->c == '=')
+ mpl->token = T_GE, append_char(mpl);
+#if 1 /* 14/VII-2006 */
+ else if (mpl->c == '>')
+ mpl->token = T_APPEND, append_char(mpl);
+#endif
+ }
+ else if (mpl->c == '!')
+ { mpl->token = T_NOT, append_char(mpl);
+ if (mpl->c == '=')
+ mpl->token = T_NE, append_char(mpl);
+ }
+ else if (mpl->c == '&')
+ { mpl->token = T_CONCAT, append_char(mpl);
+ if (mpl->c == '&')
+ mpl->token = T_AND, append_char(mpl);
+ }
+ else if (mpl->c == '|')
+ { mpl->token = T_BAR, append_char(mpl);
+ if (mpl->c == '|')
+ mpl->token = T_OR, append_char(mpl);
+ }
+ else if (!mpl->flag_d && mpl->c == '.')
+ { mpl->token = T_POINT, append_char(mpl);
+ if (mpl->f_dots)
+ { /* dots; the first dot was read on the previous call to the
+ scanner, so the current character is the second dot */
+ mpl->token = T_DOTS;
+ mpl->imlen = 2;
+ strcpy(mpl->image, "..");
+ mpl->f_dots = 0;
+ }
+ else if (mpl->c == '.')
+ mpl->token = T_DOTS, append_char(mpl);
+ else if (isdigit(mpl->c))
+ { /* numeric literal that begins with the decimal point */
+ mpl->token = T_NUMBER, append_char(mpl);
+ goto frac;
+ }
+ }
+ else if (mpl->c == ',')
+ mpl->token = T_COMMA, append_char(mpl);
+ else if (mpl->c == ':')
+ { mpl->token = T_COLON, append_char(mpl);
+ if (mpl->c == '=')
+ mpl->token = T_ASSIGN, append_char(mpl);
+ }
+ else if (mpl->c == ';')
+ mpl->token = T_SEMICOLON, append_char(mpl);
+ else if (mpl->c == '(')
+ mpl->token = T_LEFT, append_char(mpl);
+ else if (mpl->c == ')')
+ mpl->token = T_RIGHT, append_char(mpl);
+ else if (mpl->c == '[')
+ mpl->token = T_LBRACKET, append_char(mpl);
+ else if (mpl->c == ']')
+ mpl->token = T_RBRACKET, append_char(mpl);
+ else if (mpl->c == '{')
+ mpl->token = T_LBRACE, append_char(mpl);
+ else if (mpl->c == '}')
+ mpl->token = T_RBRACE, append_char(mpl);
+#if 1 /* 11/II-2008 */
+ else if (mpl->c == '~')
+ mpl->token = T_TILDE, append_char(mpl);
+#endif
+ else if (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL)
+ { /* symbol */
+ xassert(mpl->flag_d);
+ mpl->token = T_SYMBOL;
+ while (isalnum(mpl->c) || strchr("+-._", mpl->c) != NULL)
+ append_char(mpl);
+ switch (str2num(mpl->image, &mpl->value))
+ { case 0:
+ mpl->token = T_NUMBER;
+ break;
+ case 1:
+ goto err;
+ case 2:
+ break;
+ default:
+ xassert(mpl != mpl);
+ }
+ }
+ else
+ { enter_context(mpl);
+ error(mpl, "character %c not allowed", mpl->c);
+ }
+ /* enter the current token into the context queue */
+ enter_context(mpl);
+ /* reset the flag, which may be set by indexing_expression() and
+ is used by expression_list() */
+ mpl->flag_x = 0;
+done: return;
+}
+
+/*----------------------------------------------------------------------
+-- unget_token - return current token back to input stream.
+--
+-- This routine returns the current token back to the input stream, so
+-- the previously scanned token becomes the current one. */
+
+void unget_token(MPL *mpl)
+{ /* save the current token, which becomes the next one */
+ xassert(!mpl->f_scan);
+ mpl->f_scan = 1;
+ mpl->f_token = mpl->token;
+ mpl->f_imlen = mpl->imlen;
+ strcpy(mpl->f_image, mpl->image);
+ mpl->f_value = mpl->value;
+ /* restore the previous token, which becomes the current one */
+ mpl->token = mpl->b_token;
+ mpl->imlen = mpl->b_imlen;
+ strcpy(mpl->image, mpl->b_image);
+ mpl->value = mpl->b_value;
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- is_keyword - check if current token is given non-reserved keyword.
+--
+-- If the current token is given (non-reserved) keyword, this routine
+-- returns non-zero. Otherwise zero is returned. */
+
+int is_keyword(MPL *mpl, char *keyword)
+{ return
+ mpl->token == T_NAME && strcmp(mpl->image, keyword) == 0;
+}
+
+/*----------------------------------------------------------------------
+-- is_reserved - check if current token is reserved keyword.
+--
+-- If the current token is a reserved keyword, this routine returns
+-- non-zero. Otherwise zero is returned. */
+
+int is_reserved(MPL *mpl)
+{ return
+ mpl->token == T_AND && mpl->image[0] == 'a' ||
+ mpl->token == T_BY ||
+ mpl->token == T_CROSS ||
+ mpl->token == T_DIFF ||
+ mpl->token == T_DIV ||
+ mpl->token == T_ELSE ||
+ mpl->token == T_IF ||
+ mpl->token == T_IN ||
+ mpl->token == T_INTER ||
+ mpl->token == T_LESS ||
+ mpl->token == T_MOD ||
+ mpl->token == T_NOT && mpl->image[0] == 'n' ||
+ mpl->token == T_OR && mpl->image[0] == 'o' ||
+ mpl->token == T_SYMDIFF ||
+ mpl->token == T_THEN ||
+ mpl->token == T_UNION ||
+ mpl->token == T_WITHIN;
+}
+
+/*----------------------------------------------------------------------
+-- make_code - generate pseudo-code (basic routine).
+--
+-- This routine generates specified pseudo-code. It is assumed that all
+-- other translator routines use this basic routine. */
+
+CODE *make_code(MPL *mpl, int op, OPERANDS *arg, int type, int dim)
+{ CODE *code;
+ DOMAIN *domain;
+ DOMAIN_BLOCK *block;
+ ARG_LIST *e;
+ /* generate pseudo-code */
+ code = alloc(CODE);
+ code->op = op;
+ code->vflag = 0; /* is inherited from operand(s) */
+ /* copy operands and also make them referring to the pseudo-code
+ being generated, because the latter becomes the parent for all
+ its operands */
+ memset(&code->arg, '?', sizeof(OPERANDS));
+ switch (op)
+ { case O_NUMBER:
+ code->arg.num = arg->num;
+ break;
+ case O_STRING:
+ code->arg.str = arg->str;
+ break;
+ case O_INDEX:
+ code->arg.index.slot = arg->index.slot;
+ code->arg.index.next = arg->index.next;
+ break;
+ case O_MEMNUM:
+ case O_MEMSYM:
+ for (e = arg->par.list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.par.par = arg->par.par;
+ code->arg.par.list = arg->par.list;
+ break;
+ case O_MEMSET:
+ for (e = arg->set.list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.set.set = arg->set.set;
+ code->arg.set.list = arg->set.list;
+ break;
+ case O_MEMVAR:
+ for (e = arg->var.list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.var.var = arg->var.var;
+ code->arg.var.list = arg->var.list;
+#if 1 /* 15/V-2010 */
+ code->arg.var.suff = arg->var.suff;
+#endif
+ break;
+#if 1 /* 15/V-2010 */
+ case O_MEMCON:
+ for (e = arg->con.list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.con.con = arg->con.con;
+ code->arg.con.list = arg->con.list;
+ code->arg.con.suff = arg->con.suff;
+ break;
+#endif
+ case O_TUPLE:
+ case O_MAKE:
+ for (e = arg->list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.list = arg->list;
+ break;
+ case O_SLICE:
+ xassert(arg->slice != NULL);
+ code->arg.slice = arg->slice;
+ break;
+ case O_IRAND224:
+ case O_UNIFORM01:
+ case O_NORMAL01:
+ case O_GMTIME:
+ code->vflag = 1;
+ break;
+ case O_CVTNUM:
+ case O_CVTSYM:
+ case O_CVTLOG:
+ case O_CVTTUP:
+ case O_CVTLFM:
+ case O_PLUS:
+ case O_MINUS:
+ case O_NOT:
+ case O_ABS:
+ case O_CEIL:
+ case O_FLOOR:
+ case O_EXP:
+ case O_LOG:
+ case O_LOG10:
+ case O_SQRT:
+ case O_SIN:
+ case O_COS:
+ case O_TAN:
+ case O_ATAN:
+ case O_ROUND:
+ case O_TRUNC:
+ case O_CARD:
+ case O_LENGTH:
+ /* unary operation */
+ xassert(arg->arg.x != NULL);
+ xassert(arg->arg.x->up == NULL);
+ arg->arg.x->up = code;
+ code->vflag |= arg->arg.x->vflag;
+ code->arg.arg.x = arg->arg.x;
+ break;
+ case O_ADD:
+ case O_SUB:
+ case O_LESS:
+ case O_MUL:
+ case O_DIV:
+ case O_IDIV:
+ case O_MOD:
+ case O_POWER:
+ case O_ATAN2:
+ case O_ROUND2:
+ case O_TRUNC2:
+ case O_UNIFORM:
+ if (op == O_UNIFORM) code->vflag = 1;
+ case O_NORMAL:
+ if (op == O_NORMAL) code->vflag = 1;
+ case O_CONCAT:
+ case O_LT:
+ case O_LE:
+ case O_EQ:
+ case O_GE:
+ case O_GT:
+ case O_NE:
+ case O_AND:
+ case O_OR:
+ case O_UNION:
+ case O_DIFF:
+ case O_SYMDIFF:
+ case O_INTER:
+ case O_CROSS:
+ case O_IN:
+ case O_NOTIN:
+ case O_WITHIN:
+ case O_NOTWITHIN:
+ case O_SUBSTR:
+ case O_STR2TIME:
+ case O_TIME2STR:
+ /* binary operation */
+ xassert(arg->arg.x != NULL);
+ xassert(arg->arg.x->up == NULL);
+ arg->arg.x->up = code;
+ code->vflag |= arg->arg.x->vflag;
+ xassert(arg->arg.y != NULL);
+ xassert(arg->arg.y->up == NULL);
+ arg->arg.y->up = code;
+ code->vflag |= arg->arg.y->vflag;
+ code->arg.arg.x = arg->arg.x;
+ code->arg.arg.y = arg->arg.y;
+ break;
+ case O_DOTS:
+ case O_FORK:
+ case O_SUBSTR3:
+ /* ternary operation */
+ xassert(arg->arg.x != NULL);
+ xassert(arg->arg.x->up == NULL);
+ arg->arg.x->up = code;
+ code->vflag |= arg->arg.x->vflag;
+ xassert(arg->arg.y != NULL);
+ xassert(arg->arg.y->up == NULL);
+ arg->arg.y->up = code;
+ code->vflag |= arg->arg.y->vflag;
+ if (arg->arg.z != NULL)
+ { xassert(arg->arg.z->up == NULL);
+ arg->arg.z->up = code;
+ code->vflag |= arg->arg.z->vflag;
+ }
+ code->arg.arg.x = arg->arg.x;
+ code->arg.arg.y = arg->arg.y;
+ code->arg.arg.z = arg->arg.z;
+ break;
+ case O_MIN:
+ case O_MAX:
+ /* n-ary operation */
+ for (e = arg->list; e != NULL; e = e->next)
+ { xassert(e->x != NULL);
+ xassert(e->x->up == NULL);
+ e->x->up = code;
+ code->vflag |= e->x->vflag;
+ }
+ code->arg.list = arg->list;
+ break;
+ case O_SUM:
+ case O_PROD:
+ case O_MINIMUM:
+ case O_MAXIMUM:
+ case O_FORALL:
+ case O_EXISTS:
+ case O_SETOF:
+ case O_BUILD:
+ /* iterated operation */
+ domain = arg->loop.domain;
+ xassert(domain != NULL);
+ if (domain->code != NULL)
+ { xassert(domain->code->up == NULL);
+ domain->code->up = code;
+ code->vflag |= domain->code->vflag;
+ }
+ for (block = domain->list; block != NULL; block =
+ block->next)
+ { xassert(block->code != NULL);
+ xassert(block->code->up == NULL);
+ block->code->up = code;
+ code->vflag |= block->code->vflag;
+ }
+ if (arg->loop.x != NULL)
+ { xassert(arg->loop.x->up == NULL);
+ arg->loop.x->up = code;
+ code->vflag |= arg->loop.x->vflag;
+ }
+ code->arg.loop.domain = arg->loop.domain;
+ code->arg.loop.x = arg->loop.x;
+ break;
+ default:
+ xassert(op != op);
+ }
+ /* set other attributes of the pseudo-code */
+ code->type = type;
+ code->dim = dim;
+ code->up = NULL;
+ code->valid = 0;
+ memset(&code->value, '?', sizeof(VALUE));
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- make_unary - generate pseudo-code for unary operation.
+--
+-- This routine generates pseudo-code for unary operation. */
+
+CODE *make_unary(MPL *mpl, int op, CODE *x, int type, int dim)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(x != NULL);
+ arg.arg.x = x;
+ code = make_code(mpl, op, &arg, type, dim);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- make_binary - generate pseudo-code for binary operation.
+--
+-- This routine generates pseudo-code for binary operation. */
+
+CODE *make_binary(MPL *mpl, int op, CODE *x, CODE *y, int type,
+ int dim)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(x != NULL);
+ xassert(y != NULL);
+ arg.arg.x = x;
+ arg.arg.y = y;
+ code = make_code(mpl, op, &arg, type, dim);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- make_ternary - generate pseudo-code for ternary operation.
+--
+-- This routine generates pseudo-code for ternary operation. */
+
+CODE *make_ternary(MPL *mpl, int op, CODE *x, CODE *y, CODE *z,
+ int type, int dim)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(x != NULL);
+ xassert(y != NULL);
+ /* third operand can be NULL */
+ arg.arg.x = x;
+ arg.arg.y = y;
+ arg.arg.z = z;
+ code = make_code(mpl, op, &arg, type, dim);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- numeric_literal - parse reference to numeric literal.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <numeric literal> */
+
+CODE *numeric_literal(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(mpl->token == T_NUMBER);
+ arg.num = mpl->value;
+ code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0);
+ get_token(mpl /* <numeric literal> */);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- string_literal - parse reference to string literal.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <string literal> */
+
+CODE *string_literal(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(mpl->token == T_STRING);
+ arg.str = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(arg.str, mpl->image);
+ code = make_code(mpl, O_STRING, &arg, A_SYMBOLIC, 0);
+ get_token(mpl /* <string literal> */);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- create_arg_list - create empty operands list.
+--
+-- This routine creates operands list, which is initially empty. */
+
+ARG_LIST *create_arg_list(MPL *mpl)
+{ ARG_LIST *list;
+ xassert(mpl == mpl);
+ list = NULL;
+ return list;
+}
+
+/*----------------------------------------------------------------------
+-- expand_arg_list - append operand to operands list.
+--
+-- This routine appends new operand to specified operands list. */
+
+ARG_LIST *expand_arg_list(MPL *mpl, ARG_LIST *list, CODE *x)
+{ ARG_LIST *tail, *temp;
+ xassert(x != NULL);
+ /* create new operands list entry */
+ tail = alloc(ARG_LIST);
+ tail->x = x;
+ tail->next = NULL;
+ /* and append it to the operands list */
+ if (list == NULL)
+ list = tail;
+ else
+ { for (temp = list; temp->next != NULL; temp = temp->next);
+ temp->next = tail;
+ }
+ return list;
+}
+
+/*----------------------------------------------------------------------
+-- arg_list_len - determine length of operands list.
+--
+-- This routine returns the number of operands in operands list. */
+
+int arg_list_len(MPL *mpl, ARG_LIST *list)
+{ ARG_LIST *temp;
+ int len;
+ xassert(mpl == mpl);
+ len = 0;
+ for (temp = list; temp != NULL; temp = temp->next) len++;
+ return len;
+}
+
+/*----------------------------------------------------------------------
+-- subscript_list - parse subscript list.
+--
+-- This routine parses subscript list using the syntax:
+--
+-- <subscript list> ::= <subscript>
+-- <subscript list> ::= <subscript list> , <subscript>
+-- <subscript> ::= <expression 5> */
+
+ARG_LIST *subscript_list(MPL *mpl)
+{ ARG_LIST *list;
+ CODE *x;
+ list = create_arg_list(mpl);
+ for (;;)
+ { /* parse subscript expression */
+ x = expression_5(mpl);
+ /* convert it to symbolic type, if necessary */
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);
+ /* check that now the expression is of symbolic type */
+ if (x->type != A_SYMBOLIC)
+ error(mpl, "subscript expression has invalid type");
+ xassert(x->dim == 0);
+ /* and append it to the subscript list */
+ list = expand_arg_list(mpl, list, x);
+ /* check a token that follows the subscript expression */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RBRACKET)
+ break;
+ else
+ error(mpl, "syntax error in subscript list");
+ }
+ return list;
+}
+
+#if 1 /* 15/V-2010 */
+/*----------------------------------------------------------------------
+-- object_reference - parse reference to named object.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <dummy index>
+-- <primary expression> ::= <set name>
+-- <primary expression> ::= <set name> [ <subscript list> ]
+-- <primary expression> ::= <parameter name>
+-- <primary expression> ::= <parameter name> [ <subscript list> ]
+-- <primary expression> ::= <variable name> <suffix>
+-- <primary expression> ::= <variable name> [ <subscript list> ]
+-- <suffix>
+-- <primary expression> ::= <constraint name> <suffix>
+-- <primary expression> ::= <constraint name> [ <subscript list> ]
+-- <suffix>
+-- <dummy index> ::= <symbolic name>
+-- <set name> ::= <symbolic name>
+-- <parameter name> ::= <symbolic name>
+-- <variable name> ::= <symbolic name>
+-- <constraint name> ::= <symbolic name>
+-- <suffix> ::= <empty> | .lb | .ub | .status | .val | .dual */
+
+CODE *object_reference(MPL *mpl)
+{ AVLNODE *node;
+ DOMAIN_SLOT *slot;
+ SET *set;
+ PARAMETER *par;
+ VARIABLE *var;
+ CONSTRAINT *con;
+ ARG_LIST *list;
+ OPERANDS arg;
+ CODE *code;
+ char *name;
+ int dim, suff;
+ /* find the object in the symbolic name table */
+ xassert(mpl->token == T_NAME);
+ node = avl_find_node(mpl->tree, mpl->image);
+ if (node == NULL)
+ error(mpl, "%s not defined", mpl->image);
+ /* check the object type and obtain its dimension */
+ switch (avl_get_node_type(node))
+ { case A_INDEX:
+ /* dummy index */
+ slot = (DOMAIN_SLOT *)avl_get_node_link(node);
+ name = slot->name;
+ dim = 0;
+ break;
+ case A_SET:
+ /* model set */
+ set = (SET *)avl_get_node_link(node);
+ name = set->name;
+ dim = set->dim;
+ /* if a set object is referenced in its own declaration and
+ the dimen attribute is not specified yet, use dimen 1 by
+ default */
+ if (set->dimen == 0) set->dimen = 1;
+ break;
+ case A_PARAMETER:
+ /* model parameter */
+ par = (PARAMETER *)avl_get_node_link(node);
+ name = par->name;
+ dim = par->dim;
+ break;
+ case A_VARIABLE:
+ /* model variable */
+ var = (VARIABLE *)avl_get_node_link(node);
+ name = var->name;
+ dim = var->dim;
+ break;
+ case A_CONSTRAINT:
+ /* model constraint or objective */
+ con = (CONSTRAINT *)avl_get_node_link(node);
+ name = con->name;
+ dim = con->dim;
+ break;
+ default:
+ xassert(node != node);
+ }
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional subscript list */
+ if (mpl->token == T_LBRACKET)
+ { /* subscript list is specified */
+ if (dim == 0)
+ error(mpl, "%s cannot be subscripted", name);
+ get_token(mpl /* [ */);
+ list = subscript_list(mpl);
+ if (dim != arg_list_len(mpl, list))
+ error(mpl, "%s must have %d subscript%s rather than %d",
+ name, dim, dim == 1 ? "" : "s", arg_list_len(mpl, list));
+ xassert(mpl->token == T_RBRACKET);
+ get_token(mpl /* ] */);
+ }
+ else
+ { /* subscript list is not specified */
+ if (dim != 0)
+ error(mpl, "%s must be subscripted", name);
+ list = create_arg_list(mpl);
+ }
+ /* parse optional suffix */
+ if (!mpl->flag_s && avl_get_node_type(node) == A_VARIABLE)
+ suff = DOT_NONE;
+ else
+ suff = DOT_VAL;
+ if (mpl->token == T_POINT)
+ { get_token(mpl /* . */);
+ if (mpl->token != T_NAME)
+ error(mpl, "invalid use of period");
+ if (!(avl_get_node_type(node) == A_VARIABLE ||
+ avl_get_node_type(node) == A_CONSTRAINT))
+ error(mpl, "%s cannot have a suffix", name);
+ if (strcmp(mpl->image, "lb") == 0)
+ suff = DOT_LB;
+ else if (strcmp(mpl->image, "ub") == 0)
+ suff = DOT_UB;
+ else if (strcmp(mpl->image, "status") == 0)
+ suff = DOT_STATUS;
+ else if (strcmp(mpl->image, "val") == 0)
+ suff = DOT_VAL;
+ else if (strcmp(mpl->image, "dual") == 0)
+ suff = DOT_DUAL;
+ else
+ error(mpl, "suffix .%s invalid", mpl->image);
+ get_token(mpl /* suffix */);
+ }
+ /* generate pseudo-code to take value of the object */
+ switch (avl_get_node_type(node))
+ { case A_INDEX:
+ arg.index.slot = slot;
+ arg.index.next = slot->list;
+ code = make_code(mpl, O_INDEX, &arg, A_SYMBOLIC, 0);
+ slot->list = code;
+ break;
+ case A_SET:
+ arg.set.set = set;
+ arg.set.list = list;
+ code = make_code(mpl, O_MEMSET, &arg, A_ELEMSET,
+ set->dimen);
+ break;
+ case A_PARAMETER:
+ arg.par.par = par;
+ arg.par.list = list;
+ if (par->type == A_SYMBOLIC)
+ code = make_code(mpl, O_MEMSYM, &arg, A_SYMBOLIC, 0);
+ else
+ code = make_code(mpl, O_MEMNUM, &arg, A_NUMERIC, 0);
+ break;
+ case A_VARIABLE:
+ if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL
+ || suff == DOT_DUAL))
+ error(mpl, "invalid reference to status, primal value, o"
+ "r dual value of variable %s above solve statement",
+ var->name);
+ arg.var.var = var;
+ arg.var.list = list;
+ arg.var.suff = suff;
+ code = make_code(mpl, O_MEMVAR, &arg, suff == DOT_NONE ?
+ A_FORMULA : A_NUMERIC, 0);
+ break;
+ case A_CONSTRAINT:
+ if (!mpl->flag_s && (suff == DOT_STATUS || suff == DOT_VAL
+ || suff == DOT_DUAL))
+ error(mpl, "invalid reference to status, primal value, o"
+ "r dual value of %s %s above solve statement",
+ con->type == A_CONSTRAINT ? "constraint" : "objective"
+ , con->name);
+ arg.con.con = con;
+ arg.con.list = list;
+ arg.con.suff = suff;
+ code = make_code(mpl, O_MEMCON, &arg, A_NUMERIC, 0);
+ break;
+ default:
+ xassert(node != node);
+ }
+ return code;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- numeric_argument - parse argument passed to built-in function.
+--
+-- This routine parses an argument passed to numeric built-in function
+-- using the syntax:
+--
+-- <arg> ::= <expression 5> */
+
+CODE *numeric_argument(MPL *mpl, char *func)
+{ CODE *x;
+ x = expression_5(mpl);
+ /* convert the argument to numeric type, if necessary */
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ /* check that now the argument is of numeric type */
+ if (x->type != A_NUMERIC)
+ error(mpl, "argument for %s has invalid type", func);
+ xassert(x->dim == 0);
+ return x;
+}
+
+#if 1 /* 15/VII-2006 */
+CODE *symbolic_argument(MPL *mpl, char *func)
+{ CODE *x;
+ x = expression_5(mpl);
+ /* convert the argument to symbolic type, if necessary */
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);
+ /* check that now the argument is of symbolic type */
+ if (x->type != A_SYMBOLIC)
+ error(mpl, "argument for %s has invalid type", func);
+ xassert(x->dim == 0);
+ return x;
+}
+#endif
+
+#if 1 /* 15/VII-2006 */
+CODE *elemset_argument(MPL *mpl, char *func)
+{ CODE *x;
+ x = expression_9(mpl);
+ if (x->type != A_ELEMSET)
+ error(mpl, "argument for %s has invalid type", func);
+ xassert(x->dim > 0);
+ return x;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- function_reference - parse reference to built-in function.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= abs ( <arg> )
+-- <primary expression> ::= ceil ( <arg> )
+-- <primary expression> ::= floor ( <arg> )
+-- <primary expression> ::= exp ( <arg> )
+-- <primary expression> ::= log ( <arg> )
+-- <primary expression> ::= log10 ( <arg> )
+-- <primary expression> ::= max ( <arg list> )
+-- <primary expression> ::= min ( <arg list> )
+-- <primary expression> ::= sqrt ( <arg> )
+-- <primary expression> ::= sin ( <arg> )
+-- <primary expression> ::= cos ( <arg> )
+-- <primary expression> ::= tan ( <arg> )
+-- <primary expression> ::= atan ( <arg> )
+-- <primary expression> ::= atan2 ( <arg> , <arg> )
+-- <primary expression> ::= round ( <arg> )
+-- <primary expression> ::= round ( <arg> , <arg> )
+-- <primary expression> ::= trunc ( <arg> )
+-- <primary expression> ::= trunc ( <arg> , <arg> )
+-- <primary expression> ::= Irand224 ( )
+-- <primary expression> ::= Uniform01 ( )
+-- <primary expression> ::= Uniform ( <arg> , <arg> )
+-- <primary expression> ::= Normal01 ( )
+-- <primary expression> ::= Normal ( <arg> , <arg> )
+-- <primary expression> ::= card ( <arg> )
+-- <primary expression> ::= length ( <arg> )
+-- <primary expression> ::= substr ( <arg> , <arg> )
+-- <primary expression> ::= substr ( <arg> , <arg> , <arg> )
+-- <primary expression> ::= str2time ( <arg> , <arg> )
+-- <primary expression> ::= time2str ( <arg> , <arg> )
+-- <primary expression> ::= gmtime ( )
+-- <arg list> ::= <arg>
+-- <arg list> ::= <arg list> , <arg> */
+
+CODE *function_reference(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ int op;
+ char func[15+1];
+ /* determine operation code */
+ xassert(mpl->token == T_NAME);
+ if (strcmp(mpl->image, "abs") == 0)
+ op = O_ABS;
+ else if (strcmp(mpl->image, "ceil") == 0)
+ op = O_CEIL;
+ else if (strcmp(mpl->image, "floor") == 0)
+ op = O_FLOOR;
+ else if (strcmp(mpl->image, "exp") == 0)
+ op = O_EXP;
+ else if (strcmp(mpl->image, "log") == 0)
+ op = O_LOG;
+ else if (strcmp(mpl->image, "log10") == 0)
+ op = O_LOG10;
+ else if (strcmp(mpl->image, "sqrt") == 0)
+ op = O_SQRT;
+ else if (strcmp(mpl->image, "sin") == 0)
+ op = O_SIN;
+ else if (strcmp(mpl->image, "cos") == 0)
+ op = O_COS;
+ else if (strcmp(mpl->image, "tan") == 0)
+ op = O_TAN;
+ else if (strcmp(mpl->image, "atan") == 0)
+ op = O_ATAN;
+ else if (strcmp(mpl->image, "min") == 0)
+ op = O_MIN;
+ else if (strcmp(mpl->image, "max") == 0)
+ op = O_MAX;
+ else if (strcmp(mpl->image, "round") == 0)
+ op = O_ROUND;
+ else if (strcmp(mpl->image, "trunc") == 0)
+ op = O_TRUNC;
+ else if (strcmp(mpl->image, "Irand224") == 0)
+ op = O_IRAND224;
+ else if (strcmp(mpl->image, "Uniform01") == 0)
+ op = O_UNIFORM01;
+ else if (strcmp(mpl->image, "Uniform") == 0)
+ op = O_UNIFORM;
+ else if (strcmp(mpl->image, "Normal01") == 0)
+ op = O_NORMAL01;
+ else if (strcmp(mpl->image, "Normal") == 0)
+ op = O_NORMAL;
+ else if (strcmp(mpl->image, "card") == 0)
+ op = O_CARD;
+ else if (strcmp(mpl->image, "length") == 0)
+ op = O_LENGTH;
+ else if (strcmp(mpl->image, "substr") == 0)
+ op = O_SUBSTR;
+ else if (strcmp(mpl->image, "str2time") == 0)
+ op = O_STR2TIME;
+ else if (strcmp(mpl->image, "time2str") == 0)
+ op = O_TIME2STR;
+ else if (strcmp(mpl->image, "gmtime") == 0)
+ op = O_GMTIME;
+ else
+ error(mpl, "function %s unknown", mpl->image);
+ /* save symbolic name of the function */
+ strcpy(func, mpl->image);
+ xassert(strlen(func) < sizeof(func));
+ get_token(mpl /* <symbolic name> */);
+ /* check the left parenthesis that follows the function name */
+ xassert(mpl->token == T_LEFT);
+ get_token(mpl /* ( */);
+ /* parse argument list */
+ if (op == O_MIN || op == O_MAX)
+ { /* min and max allow arbitrary number of arguments */
+ arg.list = create_arg_list(mpl);
+ /* parse argument list */
+ for (;;)
+ { /* parse argument and append it to the operands list */
+ arg.list = expand_arg_list(mpl, arg.list,
+ numeric_argument(mpl, func));
+ /* check a token that follows the argument */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RIGHT)
+ break;
+ else
+ error(mpl, "syntax error in argument list for %s", func);
+ }
+ }
+ else if (op == O_IRAND224 || op == O_UNIFORM01 || op ==
+ O_NORMAL01 || op == O_GMTIME)
+ { /* Irand224, Uniform01, Normal01, gmtime need no arguments */
+ if (mpl->token != T_RIGHT)
+ error(mpl, "%s needs no arguments", func);
+ }
+ else if (op == O_UNIFORM || op == O_NORMAL)
+ { /* Uniform and Normal need two arguments */
+ /* parse the first argument */
+ arg.arg.x = numeric_argument(mpl, func);
+ /* check a token that follows the first argument */
+ if (mpl->token == T_COMMA)
+ ;
+ else if (mpl->token == T_RIGHT)
+ error(mpl, "%s needs two arguments", func);
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ get_token(mpl /* , */);
+ /* parse the second argument */
+ arg.arg.y = numeric_argument(mpl, func);
+ /* check a token that follows the second argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs two argument", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ else if (op == O_ATAN || op == O_ROUND || op == O_TRUNC)
+ { /* atan, round, and trunc need one or two arguments */
+ /* parse the first argument */
+ arg.arg.x = numeric_argument(mpl, func);
+ /* parse the second argument, if specified */
+ if (mpl->token == T_COMMA)
+ { switch (op)
+ { case O_ATAN: op = O_ATAN2; break;
+ case O_ROUND: op = O_ROUND2; break;
+ case O_TRUNC: op = O_TRUNC2; break;
+ default: xassert(op != op);
+ }
+ get_token(mpl /* , */);
+ arg.arg.y = numeric_argument(mpl, func);
+ }
+ /* check a token that follows the last argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs one or two arguments", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ else if (op == O_SUBSTR)
+ { /* substr needs two or three arguments */
+ /* parse the first argument */
+ arg.arg.x = symbolic_argument(mpl, func);
+ /* check a token that follows the first argument */
+ if (mpl->token == T_COMMA)
+ ;
+ else if (mpl->token == T_RIGHT)
+ error(mpl, "%s needs two or three arguments", func);
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ get_token(mpl /* , */);
+ /* parse the second argument */
+ arg.arg.y = numeric_argument(mpl, func);
+ /* parse the third argument, if specified */
+ if (mpl->token == T_COMMA)
+ { op = O_SUBSTR3;
+ get_token(mpl /* , */);
+ arg.arg.z = numeric_argument(mpl, func);
+ }
+ /* check a token that follows the last argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs two or three arguments", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ else if (op == O_STR2TIME)
+ { /* str2time needs two arguments, both symbolic */
+ /* parse the first argument */
+ arg.arg.x = symbolic_argument(mpl, func);
+ /* check a token that follows the first argument */
+ if (mpl->token == T_COMMA)
+ ;
+ else if (mpl->token == T_RIGHT)
+ error(mpl, "%s needs two arguments", func);
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ get_token(mpl /* , */);
+ /* parse the second argument */
+ arg.arg.y = symbolic_argument(mpl, func);
+ /* check a token that follows the second argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs two argument", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ else if (op == O_TIME2STR)
+ { /* time2str needs two arguments, numeric and symbolic */
+ /* parse the first argument */
+ arg.arg.x = numeric_argument(mpl, func);
+ /* check a token that follows the first argument */
+ if (mpl->token == T_COMMA)
+ ;
+ else if (mpl->token == T_RIGHT)
+ error(mpl, "%s needs two arguments", func);
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ get_token(mpl /* , */);
+ /* parse the second argument */
+ arg.arg.y = symbolic_argument(mpl, func);
+ /* check a token that follows the second argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs two argument", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ else
+ { /* other functions need one argument */
+ if (op == O_CARD)
+ arg.arg.x = elemset_argument(mpl, func);
+ else if (op == O_LENGTH)
+ arg.arg.x = symbolic_argument(mpl, func);
+ else
+ arg.arg.x = numeric_argument(mpl, func);
+ /* check a token that follows the argument */
+ if (mpl->token == T_COMMA)
+ error(mpl, "%s needs one argument", func);
+ else if (mpl->token == T_RIGHT)
+ ;
+ else
+ error(mpl, "syntax error in argument for %s", func);
+ }
+ /* make pseudo-code to call the built-in function */
+ if (op == O_SUBSTR || op == O_SUBSTR3 || op == O_TIME2STR)
+ code = make_code(mpl, op, &arg, A_SYMBOLIC, 0);
+ else
+ code = make_code(mpl, op, &arg, A_NUMERIC, 0);
+ /* the reference ends with the right parenthesis */
+ xassert(mpl->token == T_RIGHT);
+ get_token(mpl /* ) */);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- create_domain - create empty domain.
+--
+-- This routine creates empty domain, which is initially empty, i.e.
+-- has no domain blocks. */
+
+DOMAIN *create_domain(MPL *mpl)
+{ DOMAIN *domain;
+ domain = alloc(DOMAIN);
+ domain->list = NULL;
+ domain->code = NULL;
+ return domain;
+}
+
+/*----------------------------------------------------------------------
+-- create_block - create empty domain block.
+--
+-- This routine creates empty domain block, which is initially empty,
+-- i.e. has no domain slots. */
+
+DOMAIN_BLOCK *create_block(MPL *mpl)
+{ DOMAIN_BLOCK *block;
+ block = alloc(DOMAIN_BLOCK);
+ block->list = NULL;
+ block->code = NULL;
+ block->backup = NULL;
+ block->next = NULL;
+ return block;
+}
+
+/*----------------------------------------------------------------------
+-- append_block - append domain block to specified domain.
+--
+-- This routine adds given domain block to the end of the block list of
+-- specified domain. */
+
+void append_block(MPL *mpl, DOMAIN *domain, DOMAIN_BLOCK *block)
+{ DOMAIN_BLOCK *temp;
+ xassert(mpl == mpl);
+ xassert(domain != NULL);
+ xassert(block != NULL);
+ xassert(block->next == NULL);
+ if (domain->list == NULL)
+ domain->list = block;
+ else
+ { for (temp = domain->list; temp->next != NULL; temp =
+ temp->next);
+ temp->next = block;
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- append_slot - create and append new slot to domain block.
+--
+-- This routine creates new domain slot and adds it to the end of slot
+-- list of specified domain block.
+--
+-- The parameter name is symbolic name of the dummy index associated
+-- with the slot (the character string must be allocated). NULL means
+-- the dummy index is not explicitly specified.
+--
+-- The parameter code is pseudo-code for computing symbolic value, at
+-- which the dummy index is bounded. NULL means the dummy index is free
+-- in the domain scope. */
+
+DOMAIN_SLOT *append_slot(MPL *mpl, DOMAIN_BLOCK *block, char *name,
+ CODE *code)
+{ DOMAIN_SLOT *slot, *temp;
+ xassert(block != NULL);
+ slot = alloc(DOMAIN_SLOT);
+ slot->name = name;
+ slot->code = code;
+ slot->value = NULL;
+ slot->list = NULL;
+ slot->next = NULL;
+ if (block->list == NULL)
+ block->list = slot;
+ else
+ { for (temp = block->list; temp->next != NULL; temp =
+ temp->next);
+ temp->next = slot;
+ }
+ return slot;
+}
+
+/*----------------------------------------------------------------------
+-- expression_list - parse expression list.
+--
+-- This routine parses a list of one or more expressions enclosed into
+-- the parentheses using the syntax:
+--
+-- <primary expression> ::= ( <expression list> )
+-- <expression list> ::= <expression 13>
+-- <expression list> ::= <expression 13> , <expression list>
+--
+-- Note that this construction may have three different meanings:
+--
+-- 1. If <expression list> consists of only one expression, <primary
+-- expression> is a parenthesized expression, which may be of any
+-- valid type (not necessarily 1-tuple).
+--
+-- 2. If <expression list> consists of several expressions separated by
+-- commae, where no expression is undeclared symbolic name, <primary
+-- expression> is a n-tuple.
+--
+-- 3. If <expression list> consists of several expressions separated by
+-- commae, where at least one expression is undeclared symbolic name
+-- (that denotes a dummy index), <primary expression> is a slice and
+-- can be only used as constituent of indexing expression. */
+
+#define max_dim 20
+/* maximal number of components allowed within parentheses */
+
+CODE *expression_list(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ struct { char *name; CODE *code; } list[1+max_dim];
+ int flag_x, next_token, dim, j, slice = 0;
+ xassert(mpl->token == T_LEFT);
+ /* the flag, which allows recognizing undeclared symbolic names
+ as dummy indices, will be automatically reset by get_token(),
+ so save it before scanning the next token */
+ flag_x = mpl->flag_x;
+ get_token(mpl /* ( */);
+ /* parse <expression list> */
+ for (dim = 1; ; dim++)
+ { if (dim > max_dim)
+ error(mpl, "too many components within parentheses");
+ /* current component of <expression list> can be either dummy
+ index or expression */
+ if (mpl->token == T_NAME)
+ { /* symbolic name is recognized as dummy index only if:
+ the flag, which allows that, is set, and
+ the name is followed by comma or right parenthesis, and
+ the name is undeclared */
+ get_token(mpl /* <symbolic name> */);
+ next_token = mpl->token;
+ unget_token(mpl);
+ if (!(flag_x &&
+ (next_token == T_COMMA || next_token == T_RIGHT) &&
+ avl_find_node(mpl->tree, mpl->image) == NULL))
+ { /* this is not dummy index */
+ goto expr;
+ }
+ /* all dummy indices within the same slice must have unique
+ symbolic names */
+ for (j = 1; j < dim; j++)
+ { if (list[j].name != NULL && strcmp(list[j].name,
+ mpl->image) == 0)
+ error(mpl, "duplicate dummy index %s not allowed",
+ mpl->image);
+ }
+ /* current component of <expression list> is dummy index */
+ list[dim].name
+ = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(list[dim].name, mpl->image);
+ list[dim].code = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* <expression list> is a slice, because at least one dummy
+ index has appeared */
+ slice = 1;
+ /* note that the context ( <dummy index> ) is not allowed,
+ i.e. in this case <primary expression> is considered as
+ a parenthesized expression */
+ if (dim == 1 && mpl->token == T_RIGHT)
+ error(mpl, "%s not defined", list[dim].name);
+ }
+ else
+expr: { /* current component of <expression list> is expression */
+ code = expression_13(mpl);
+ /* if the current expression is followed by comma or it is
+ not the very first expression, entire <expression list>
+ is n-tuple or slice, in which case the current expression
+ should be converted to symbolic type, if necessary */
+ if (mpl->token == T_COMMA || dim > 1)
+ { if (code->type == A_NUMERIC)
+ code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0);
+ /* now the expression must be of symbolic type */
+ if (code->type != A_SYMBOLIC)
+ error(mpl, "component expression has invalid type");
+ xassert(code->dim == 0);
+ }
+ list[dim].name = NULL;
+ list[dim].code = code;
+ }
+ /* check a token that follows the current component */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RIGHT)
+ break;
+ else
+ error(mpl, "right parenthesis missing where expected");
+ }
+ /* generate pseudo-code for <primary expression> */
+ if (dim == 1 && !slice)
+ { /* <primary expression> is a parenthesized expression */
+ code = list[1].code;
+ }
+ else if (!slice)
+ { /* <primary expression> is a n-tuple */
+ arg.list = create_arg_list(mpl);
+ for (j = 1; j <= dim; j++)
+ arg.list = expand_arg_list(mpl, arg.list, list[j].code);
+ code = make_code(mpl, O_TUPLE, &arg, A_TUPLE, dim);
+ }
+ else
+ { /* <primary expression> is a slice */
+ arg.slice = create_block(mpl);
+ for (j = 1; j <= dim; j++)
+ append_slot(mpl, arg.slice, list[j].name, list[j].code);
+ /* note that actually pseudo-codes with op = O_SLICE are never
+ evaluated */
+ code = make_code(mpl, O_SLICE, &arg, A_TUPLE, dim);
+ }
+ get_token(mpl /* ) */);
+ /* if <primary expression> is a slice, there must be the keyword
+ 'in', which follows the right parenthesis */
+ if (slice && mpl->token != T_IN)
+ error(mpl, "keyword in missing where expected");
+ /* if the slice flag is set and there is the keyword 'in', which
+ follows <primary expression>, the latter must be a slice */
+ if (flag_x && mpl->token == T_IN && !slice)
+ { if (dim == 1)
+ error(mpl, "syntax error in indexing expression");
+ else
+ error(mpl, "0-ary slice not allowed");
+ }
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- literal set - parse literal set.
+--
+-- This routine parses literal set using the syntax:
+--
+-- <literal set> ::= { <member list> }
+-- <member list> ::= <member expression>
+-- <member list> ::= <member list> , <member expression>
+-- <member expression> ::= <expression 5>
+--
+-- It is assumed that the left curly brace and the very first member
+-- expression that follows it are already parsed. The right curly brace
+-- remains unscanned on exit. */
+
+CODE *literal_set(MPL *mpl, CODE *code)
+{ OPERANDS arg;
+ int j;
+ xassert(code != NULL);
+ arg.list = create_arg_list(mpl);
+ /* parse <member list> */
+ for (j = 1; ; j++)
+ { /* all member expressions must be n-tuples; so, if the current
+ expression is not n-tuple, convert it to 1-tuple */
+ if (code->type == A_NUMERIC)
+ code = make_unary(mpl, O_CVTSYM, code, A_SYMBOLIC, 0);
+ if (code->type == A_SYMBOLIC)
+ code = make_unary(mpl, O_CVTTUP, code, A_TUPLE, 1);
+ /* now the expression must be n-tuple */
+ if (code->type != A_TUPLE)
+ error(mpl, "member expression has invalid type");
+ /* all member expressions must have identical dimension */
+ if (arg.list != NULL && arg.list->x->dim != code->dim)
+ error(mpl, "member %d has %d component%s while member %d ha"
+ "s %d component%s",
+ j-1, arg.list->x->dim, arg.list->x->dim == 1 ? "" : "s",
+ j, code->dim, code->dim == 1 ? "" : "s");
+ /* append the current expression to the member list */
+ arg.list = expand_arg_list(mpl, arg.list, code);
+ /* check a token that follows the current expression */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RBRACE)
+ break;
+ else
+ error(mpl, "syntax error in literal set");
+ /* parse the next expression that follows the comma */
+ code = expression_5(mpl);
+ }
+ /* generate pseudo-code for <literal set> */
+ code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, arg.list->x->dim);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- indexing_expression - parse indexing expression.
+--
+-- This routine parses indexing expression using the syntax:
+--
+-- <indexing expression> ::= <literal set>
+-- <indexing expression> ::= { <indexing list> }
+-- <indexing expression> ::= { <indexing list> : <logical expression> }
+-- <indexing list> ::= <indexing element>
+-- <indexing list> ::= <indexing list> , <indexing element>
+-- <indexing element> ::= <basic expression>
+-- <indexing element> ::= <dummy index> in <basic expression>
+-- <indexing element> ::= <slice> in <basic expression>
+-- <dummy index> ::= <symbolic name>
+-- <slice> ::= ( <expression list> )
+-- <basic expression> ::= <expression 9>
+-- <logical expression> ::= <expression 13>
+--
+-- This routine creates domain for <indexing expression>, where each
+-- domain block corresponds to <indexing element>, and each domain slot
+-- corresponds to individual indexing position. */
+
+DOMAIN *indexing_expression(MPL *mpl)
+{ DOMAIN *domain;
+ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ CODE *code;
+ xassert(mpl->token == T_LBRACE);
+ get_token(mpl /* { */);
+ if (mpl->token == T_RBRACE)
+ error(mpl, "empty indexing expression not allowed");
+ /* create domain to be constructed */
+ domain = create_domain(mpl);
+ /* parse either <member list> or <indexing list> that follows the
+ left brace */
+ for (;;)
+ { /* domain block for <indexing element> is not created yet */
+ block = NULL;
+ /* pseudo-code for <basic expression> is not generated yet */
+ code = NULL;
+ /* check a token, which <indexing element> begins with */
+ if (mpl->token == T_NAME)
+ { /* it is a symbolic name */
+ int next_token;
+ char *name;
+ /* symbolic name is recognized as dummy index only if it is
+ followed by the keyword 'in' and not declared */
+ get_token(mpl /* <symbolic name> */);
+ next_token = mpl->token;
+ unget_token(mpl);
+ if (!(next_token == T_IN &&
+ avl_find_node(mpl->tree, mpl->image) == NULL))
+ { /* this is not dummy index; the symbolic name begins an
+ expression, which is either <basic expression> or the
+ very first <member expression> in <literal set> */
+ goto expr;
+ }
+ /* create domain block with one slot, which is assigned the
+ dummy index */
+ block = create_block(mpl);
+ name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(name, mpl->image);
+ append_slot(mpl, block, name, NULL);
+ get_token(mpl /* <symbolic name> */);
+ /* the keyword 'in' is already checked above */
+ xassert(mpl->token == T_IN);
+ get_token(mpl /* in */);
+ /* <basic expression> that follows the keyword 'in' will be
+ parsed below */
+ }
+ else if (mpl->token == T_LEFT)
+ { /* it is the left parenthesis; parse expression that begins
+ with this parenthesis (the flag is set in order to allow
+ recognizing slices; see the routine expression_list) */
+ mpl->flag_x = 1;
+ code = expression_9(mpl);
+ if (code->op != O_SLICE)
+ { /* this is either <basic expression> or the very first
+ <member expression> in <literal set> */
+ goto expr;
+ }
+ /* this is a slice; besides the corresponding domain block
+ is already created by expression_list() */
+ block = code->arg.slice;
+ code = NULL; /* <basic expression> is not parsed yet */
+ /* the keyword 'in' following the slice is already checked
+ by expression_list() */
+ xassert(mpl->token == T_IN);
+ get_token(mpl /* in */);
+ /* <basic expression> that follows the keyword 'in' will be
+ parsed below */
+ }
+expr: /* parse expression that follows either the keyword 'in' (in
+ which case it can be <basic expression) or the left brace
+ (in which case it can be <basic expression> as well as the
+ very first <member expression> in <literal set>); note that
+ this expression can be already parsed above */
+ if (code == NULL) code = expression_9(mpl);
+ /* check the type of the expression just parsed */
+ if (code->type != A_ELEMSET)
+ { /* it is not <basic expression> and therefore it can only
+ be the very first <member expression> in <literal set>;
+ however, then there must be no dummy index neither slice
+ between the left brace and this expression */
+ if (block != NULL)
+ error(mpl, "domain expression has invalid type");
+ /* parse the rest part of <literal set> and make this set
+ be <basic expression>, i.e. the construction {a, b, c}
+ is parsed as it were written as {A}, where A = {a, b, c}
+ is a temporary elemental set */
+ code = literal_set(mpl, code);
+ }
+ /* now pseudo-code for <basic set> has been built */
+ xassert(code != NULL);
+ xassert(code->type == A_ELEMSET);
+ xassert(code->dim > 0);
+ /* if domain block for the current <indexing element> is still
+ not created, create it for fake slice of the same dimension
+ as <basic set> */
+ if (block == NULL)
+ { int j;
+ block = create_block(mpl);
+ for (j = 1; j <= code->dim; j++)
+ append_slot(mpl, block, NULL, NULL);
+ }
+ /* number of indexing positions in <indexing element> must be
+ the same as dimension of n-tuples in basic set */
+ { int dim = 0;
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ dim++;
+ if (dim != code->dim)
+ error(mpl,"%d %s specified for set of dimension %d",
+ dim, dim == 1 ? "index" : "indices", code->dim);
+ }
+ /* store pseudo-code for <basic set> in the domain block */
+ xassert(block->code == NULL);
+ block->code = code;
+ /* and append the domain block to the domain */
+ append_block(mpl, domain, block);
+ /* the current <indexing element> has been completely parsed;
+ include all its dummy indices into the symbolic name table
+ to make them available for referencing from expressions;
+ implicit declarations of dummy indices remain valid while
+ the corresponding domain scope is valid */
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ if (slot->name != NULL)
+ { AVLNODE *node;
+ xassert(avl_find_node(mpl->tree, slot->name) == NULL);
+ node = avl_insert_node(mpl->tree, slot->name);
+ avl_set_node_type(node, A_INDEX);
+ avl_set_node_link(node, (void *)slot);
+ }
+ /* check a token that follows <indexing element> */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_COLON || mpl->token == T_RBRACE)
+ break;
+ else
+ error(mpl, "syntax error in indexing expression");
+ }
+ /* parse <logical expression> that follows the colon */
+ if (mpl->token == T_COLON)
+ { get_token(mpl /* : */);
+ code = expression_13(mpl);
+ /* convert the expression to logical type, if necessary */
+ if (code->type == A_SYMBOLIC)
+ code = make_unary(mpl, O_CVTNUM, code, A_NUMERIC, 0);
+ if (code->type == A_NUMERIC)
+ code = make_unary(mpl, O_CVTLOG, code, A_LOGICAL, 0);
+ /* now the expression must be of logical type */
+ if (code->type != A_LOGICAL)
+ error(mpl, "expression following colon has invalid type");
+ xassert(code->dim == 0);
+ domain->code = code;
+ /* the right brace must follow the logical expression */
+ if (mpl->token != T_RBRACE)
+ error(mpl, "syntax error in indexing expression");
+ }
+ get_token(mpl /* } */);
+ return domain;
+}
+
+/*----------------------------------------------------------------------
+-- close_scope - close scope of indexing expression.
+--
+-- The routine closes the scope of indexing expression specified by its
+-- domain and thereby makes all dummy indices introduced in the indexing
+-- expression no longer available for referencing. */
+
+void close_scope(MPL *mpl, DOMAIN *domain)
+{ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ AVLNODE *node;
+ xassert(domain != NULL);
+ /* remove all dummy indices from the symbolic names table */
+ for (block = domain->list; block != NULL; block = block->next)
+ { for (slot = block->list; slot != NULL; slot = slot->next)
+ { if (slot->name != NULL)
+ { node = avl_find_node(mpl->tree, slot->name);
+ xassert(node != NULL);
+ xassert(avl_get_node_type(node) == A_INDEX);
+ avl_delete_node(mpl->tree, node);
+ }
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- iterated_expression - parse iterated expression.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <iterated expression>
+-- <iterated expression> ::= sum <indexing expression> <expression 3>
+-- <iterated expression> ::= prod <indexing expression> <expression 3>
+-- <iterated expression> ::= min <indexing expression> <expression 3>
+-- <iterated expression> ::= max <indexing expression> <expression 3>
+-- <iterated expression> ::= exists <indexing expression>
+-- <expression 12>
+-- <iterated expression> ::= forall <indexing expression>
+-- <expression 12>
+-- <iterated expression> ::= setof <indexing expression> <expression 5>
+--
+-- Note that parsing "integrand" depends on the iterated operator. */
+
+#if 1 /* 07/IX-2008 */
+static void link_up(CODE *code)
+{ /* if we have something like sum{(i+1,j,k-1) in E} x[i,j,k],
+ where i and k are dummy indices defined out of the iterated
+ expression, we should link up pseudo-code for computing i+1
+ and k-1 to pseudo-code for computing the iterated expression;
+ this is needed to invalidate current value of the iterated
+ expression once i or k have been changed */
+ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ for (block = code->arg.loop.domain->list; block != NULL;
+ block = block->next)
+ { for (slot = block->list; slot != NULL; slot = slot->next)
+ { if (slot->code != NULL)
+ { xassert(slot->code->up == NULL);
+ slot->code->up = code;
+ }
+ }
+ }
+ return;
+}
+#endif
+
+CODE *iterated_expression(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ int op;
+ char opstr[8];
+ /* determine operation code */
+ xassert(mpl->token == T_NAME);
+ if (strcmp(mpl->image, "sum") == 0)
+ op = O_SUM;
+ else if (strcmp(mpl->image, "prod") == 0)
+ op = O_PROD;
+ else if (strcmp(mpl->image, "min") == 0)
+ op = O_MINIMUM;
+ else if (strcmp(mpl->image, "max") == 0)
+ op = O_MAXIMUM;
+ else if (strcmp(mpl->image, "forall") == 0)
+ op = O_FORALL;
+ else if (strcmp(mpl->image, "exists") == 0)
+ op = O_EXISTS;
+ else if (strcmp(mpl->image, "setof") == 0)
+ op = O_SETOF;
+ else
+ error(mpl, "operator %s unknown", mpl->image);
+ strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ get_token(mpl /* <symbolic name> */);
+ /* check the left brace that follows the operator name */
+ xassert(mpl->token == T_LBRACE);
+ /* parse indexing expression that controls iterating */
+ arg.loop.domain = indexing_expression(mpl);
+ /* parse "integrand" expression and generate pseudo-code */
+ switch (op)
+ { case O_SUM:
+ case O_PROD:
+ case O_MINIMUM:
+ case O_MAXIMUM:
+ arg.loop.x = expression_3(mpl);
+ /* convert the integrand to numeric type, if necessary */
+ if (arg.loop.x->type == A_SYMBOLIC)
+ arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,
+ A_NUMERIC, 0);
+ /* now the integrand must be of numeric type or linear form
+ (the latter is only allowed for the sum operator) */
+ if (!(arg.loop.x->type == A_NUMERIC ||
+ op == O_SUM && arg.loop.x->type == A_FORMULA))
+err: error(mpl, "integrand following %s{...} has invalid type"
+ , opstr);
+ xassert(arg.loop.x->dim == 0);
+ /* generate pseudo-code */
+ code = make_code(mpl, op, &arg, arg.loop.x->type, 0);
+ break;
+ case O_FORALL:
+ case O_EXISTS:
+ arg.loop.x = expression_12(mpl);
+ /* convert the integrand to logical type, if necessary */
+ if (arg.loop.x->type == A_SYMBOLIC)
+ arg.loop.x = make_unary(mpl, O_CVTNUM, arg.loop.x,
+ A_NUMERIC, 0);
+ if (arg.loop.x->type == A_NUMERIC)
+ arg.loop.x = make_unary(mpl, O_CVTLOG, arg.loop.x,
+ A_LOGICAL, 0);
+ /* now the integrand must be of logical type */
+ if (arg.loop.x->type != A_LOGICAL) goto err;
+ xassert(arg.loop.x->dim == 0);
+ /* generate pseudo-code */
+ code = make_code(mpl, op, &arg, A_LOGICAL, 0);
+ break;
+ case O_SETOF:
+ arg.loop.x = expression_5(mpl);
+ /* convert the integrand to 1-tuple, if necessary */
+ if (arg.loop.x->type == A_NUMERIC)
+ arg.loop.x = make_unary(mpl, O_CVTSYM, arg.loop.x,
+ A_SYMBOLIC, 0);
+ if (arg.loop.x->type == A_SYMBOLIC)
+ arg.loop.x = make_unary(mpl, O_CVTTUP, arg.loop.x,
+ A_TUPLE, 1);
+ /* now the integrand must be n-tuple */
+ if (arg.loop.x->type != A_TUPLE) goto err;
+ xassert(arg.loop.x->dim > 0);
+ /* generate pseudo-code */
+ code = make_code(mpl, op, &arg, A_ELEMSET, arg.loop.x->dim);
+ break;
+ default:
+ xassert(op != op);
+ }
+ /* close the scope of the indexing expression */
+ close_scope(mpl, arg.loop.domain);
+#if 1 /* 07/IX-2008 */
+ link_up(code);
+#endif
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- domain_arity - determine arity of domain.
+--
+-- This routine returns arity of specified domain, which is number of
+-- its free dummy indices. */
+
+int domain_arity(MPL *mpl, DOMAIN *domain)
+{ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ int arity;
+ xassert(mpl == mpl);
+ arity = 0;
+ for (block = domain->list; block != NULL; block = block->next)
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ if (slot->code == NULL) arity++;
+ return arity;
+}
+
+/*----------------------------------------------------------------------
+-- set_expression - parse set expression.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= { }
+-- <primary expression> ::= <indexing expression> */
+
+CODE *set_expression(MPL *mpl)
+{ CODE *code;
+ OPERANDS arg;
+ xassert(mpl->token == T_LBRACE);
+ get_token(mpl /* { */);
+ /* check a token that follows the left brace */
+ if (mpl->token == T_RBRACE)
+ { /* it is the right brace, so the resultant is an empty set of
+ dimension 1 */
+ arg.list = NULL;
+ /* generate pseudo-code to build the resultant set */
+ code = make_code(mpl, O_MAKE, &arg, A_ELEMSET, 1);
+ get_token(mpl /* } */);
+ }
+ else
+ { /* the next token begins an indexing expression */
+ unget_token(mpl);
+ arg.loop.domain = indexing_expression(mpl);
+ arg.loop.x = NULL; /* integrand is not used */
+ /* close the scope of the indexing expression */
+ close_scope(mpl, arg.loop.domain);
+ /* generate pseudo-code to build the resultant set */
+ code = make_code(mpl, O_BUILD, &arg, A_ELEMSET,
+ domain_arity(mpl, arg.loop.domain));
+#if 1 /* 07/IX-2008 */
+ link_up(code);
+#endif
+ }
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- branched_expression - parse conditional expression.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <branched expression>
+-- <branched expression> ::= if <logical expression> then <expression 9>
+-- <branched expression> ::= if <logical expression> then <expression 9>
+-- else <expression 9>
+-- <logical expression> ::= <expression 13> */
+
+CODE *branched_expression(MPL *mpl)
+{ CODE *code, *x, *y, *z;
+ xassert(mpl->token == T_IF);
+ get_token(mpl /* if */);
+ /* parse <logical expression> that follows 'if' */
+ x = expression_13(mpl);
+ /* convert the expression to logical type, if necessary */
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);
+ /* now the expression must be of logical type */
+ if (x->type != A_LOGICAL)
+ error(mpl, "expression following if has invalid type");
+ xassert(x->dim == 0);
+ /* the keyword 'then' must follow the logical expression */
+ if (mpl->token != T_THEN)
+ error(mpl, "keyword then missing where expected");
+ get_token(mpl /* then */);
+ /* parse <expression> that follows 'then' and check its type */
+ y = expression_9(mpl);
+ if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC ||
+ y->type == A_ELEMSET || y->type == A_FORMULA))
+ error(mpl, "expression following then has invalid type");
+ /* if the expression that follows the keyword 'then' is elemental
+ set, the keyword 'else' cannot be omitted; otherwise else-part
+ is optional */
+ if (mpl->token != T_ELSE)
+ { if (y->type == A_ELEMSET)
+ error(mpl, "keyword else missing where expected");
+ z = NULL;
+ goto skip;
+ }
+ get_token(mpl /* else */);
+ /* parse <expression> that follow 'else' and check its type */
+ z = expression_9(mpl);
+ if (!(z->type == A_NUMERIC || z->type == A_SYMBOLIC ||
+ z->type == A_ELEMSET || z->type == A_FORMULA))
+ error(mpl, "expression following else has invalid type");
+ /* convert to identical types, if necessary */
+ if (y->type == A_FORMULA || z->type == A_FORMULA)
+ { if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);
+ if (z->type == A_SYMBOLIC)
+ z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);
+ if (z->type == A_NUMERIC)
+ z = make_unary(mpl, O_CVTLFM, z, A_FORMULA, 0);
+ }
+ if (y->type == A_SYMBOLIC || z->type == A_SYMBOLIC)
+ { if (y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);
+ if (z->type == A_NUMERIC)
+ z = make_unary(mpl, O_CVTSYM, z, A_SYMBOLIC, 0);
+ }
+ /* now both expressions must have identical types */
+ if (y->type != z->type)
+ error(mpl, "expressions following then and else have incompati"
+ "ble types");
+ /* and identical dimensions */
+ if (y->dim != z->dim)
+ error(mpl, "expressions following then and else have different"
+ " dimensions %d and %d, respectively", y->dim, z->dim);
+skip: /* generate pseudo-code to perform branching */
+ code = make_ternary(mpl, O_FORK, x, y, z, y->type, y->dim);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- primary_expression - parse primary expression.
+--
+-- This routine parses primary expression using the syntax:
+--
+-- <primary expression> ::= <numeric literal>
+-- <primary expression> ::= Infinity
+-- <primary expression> ::= <string literal>
+-- <primary expression> ::= <dummy index>
+-- <primary expression> ::= <set name>
+-- <primary expression> ::= <set name> [ <subscript list> ]
+-- <primary expression> ::= <parameter name>
+-- <primary expression> ::= <parameter name> [ <subscript list> ]
+-- <primary expression> ::= <variable name>
+-- <primary expression> ::= <variable name> [ <subscript list> ]
+-- <primary expression> ::= <built-in function> ( <argument list> )
+-- <primary expression> ::= ( <expression list> )
+-- <primary expression> ::= <iterated expression>
+-- <primary expression> ::= { }
+-- <primary expression> ::= <indexing expression>
+-- <primary expression> ::= <branched expression>
+--
+-- For complete list of syntactic rules for <primary expression> see
+-- comments to the corresponding parsing routines. */
+
+CODE *primary_expression(MPL *mpl)
+{ CODE *code;
+ if (mpl->token == T_NUMBER)
+ { /* parse numeric literal */
+ code = numeric_literal(mpl);
+ }
+#if 1 /* 21/VII-2006 */
+ else if (mpl->token == T_INFINITY)
+ { /* parse "infinity" */
+ OPERANDS arg;
+ arg.num = DBL_MAX;
+ code = make_code(mpl, O_NUMBER, &arg, A_NUMERIC, 0);
+ get_token(mpl /* Infinity */);
+ }
+#endif
+ else if (mpl->token == T_STRING)
+ { /* parse string literal */
+ code = string_literal(mpl);
+ }
+ else if (mpl->token == T_NAME)
+ { int next_token;
+ get_token(mpl /* <symbolic name> */);
+ next_token = mpl->token;
+ unget_token(mpl);
+ /* check a token that follows <symbolic name> */
+ switch (next_token)
+ { case T_LBRACKET:
+ /* parse reference to subscripted object */
+ code = object_reference(mpl);
+ break;
+ case T_LEFT:
+ /* parse reference to built-in function */
+ code = function_reference(mpl);
+ break;
+ case T_LBRACE:
+ /* parse iterated expression */
+ code = iterated_expression(mpl);
+ break;
+ default:
+ /* parse reference to unsubscripted object */
+ code = object_reference(mpl);
+ break;
+ }
+ }
+ else if (mpl->token == T_LEFT)
+ { /* parse parenthesized expression */
+ code = expression_list(mpl);
+ }
+ else if (mpl->token == T_LBRACE)
+ { /* parse set expression */
+ code = set_expression(mpl);
+ }
+ else if (mpl->token == T_IF)
+ { /* parse conditional expression */
+ code = branched_expression(mpl);
+ }
+ else if (is_reserved(mpl))
+ { /* other reserved keywords cannot be used here */
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ }
+ else
+ error(mpl, "syntax error in expression");
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- error_preceding - raise error if preceding operand has wrong type.
+--
+-- This routine is called to raise error if operand that precedes some
+-- infix operator has invalid type. */
+
+void error_preceding(MPL *mpl, char *opstr)
+{ error(mpl, "operand preceding %s has invalid type", opstr);
+ /* no return */
+}
+
+/*----------------------------------------------------------------------
+-- error_following - raise error if following operand has wrong type.
+--
+-- This routine is called to raise error if operand that follows some
+-- infix operator has invalid type. */
+
+void error_following(MPL *mpl, char *opstr)
+{ error(mpl, "operand following %s has invalid type", opstr);
+ /* no return */
+}
+
+/*----------------------------------------------------------------------
+-- error_dimension - raise error if operands have different dimension.
+--
+-- This routine is called to raise error if two operands of some infix
+-- operator have different dimension. */
+
+void error_dimension(MPL *mpl, char *opstr, int dim1, int dim2)
+{ error(mpl, "operands preceding and following %s have different di"
+ "mensions %d and %d, respectively", opstr, dim1, dim2);
+ /* no return */
+}
+
+/*----------------------------------------------------------------------
+-- expression_0 - parse expression of level 0.
+--
+-- This routine parses expression of level 0 using the syntax:
+--
+-- <expression 0> ::= <primary expression> */
+
+CODE *expression_0(MPL *mpl)
+{ CODE *code;
+ code = primary_expression(mpl);
+ return code;
+}
+
+/*----------------------------------------------------------------------
+-- expression_1 - parse expression of level 1.
+--
+-- This routine parses expression of level 1 using the syntax:
+--
+-- <expression 1> ::= <expression 0>
+-- <expression 1> ::= <expression 0> <power> <expression 1>
+-- <expression 1> ::= <expression 0> <power> <expression 2>
+-- <power> ::= ^ | ** */
+
+CODE *expression_1(MPL *mpl)
+{ CODE *x, *y;
+ char opstr[8];
+ x = expression_0(mpl);
+ if (mpl->token == T_POWER)
+ { strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* ^ | ** */);
+ if (mpl->token == T_PLUS || mpl->token == T_MINUS)
+ y = expression_2(mpl);
+ else
+ y = expression_1(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, opstr);
+ x = make_binary(mpl, O_POWER, x, y, A_NUMERIC, 0);
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_2 - parse expression of level 2.
+--
+-- This routine parses expression of level 2 using the syntax:
+--
+-- <expression 2> ::= <expression 1>
+-- <expression 2> ::= + <expression 1>
+-- <expression 2> ::= - <expression 1> */
+
+CODE *expression_2(MPL *mpl)
+{ CODE *x;
+ if (mpl->token == T_PLUS)
+ { get_token(mpl /* + */);
+ x = expression_1(mpl);
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_following(mpl, "+");
+ x = make_unary(mpl, O_PLUS, x, x->type, 0);
+ }
+ else if (mpl->token == T_MINUS)
+ { get_token(mpl /* - */);
+ x = expression_1(mpl);
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_following(mpl, "-");
+ x = make_unary(mpl, O_MINUS, x, x->type, 0);
+ }
+ else
+ x = expression_1(mpl);
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_3 - parse expression of level 3.
+--
+-- This routine parses expression of level 3 using the syntax:
+--
+-- <expression 3> ::= <expression 2>
+-- <expression 3> ::= <expression 3> * <expression 2>
+-- <expression 3> ::= <expression 3> / <expression 2>
+-- <expression 3> ::= <expression 3> div <expression 2>
+-- <expression 3> ::= <expression 3> mod <expression 2> */
+
+CODE *expression_3(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_2(mpl);
+ for (;;)
+ { if (mpl->token == T_ASTERISK)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_preceding(mpl, "*");
+ get_token(mpl /* * */);
+ y = expression_2(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (!(y->type == A_NUMERIC || y->type == A_FORMULA))
+ error_following(mpl, "*");
+ if (x->type == A_FORMULA && y->type == A_FORMULA)
+ error(mpl, "multiplication of linear forms not allowed");
+ if (x->type == A_NUMERIC && y->type == A_NUMERIC)
+ x = make_binary(mpl, O_MUL, x, y, A_NUMERIC, 0);
+ else
+ x = make_binary(mpl, O_MUL, x, y, A_FORMULA, 0);
+ }
+ else if (mpl->token == T_SLASH)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_preceding(mpl, "/");
+ get_token(mpl /* / */);
+ y = expression_2(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, "/");
+ if (x->type == A_NUMERIC)
+ x = make_binary(mpl, O_DIV, x, y, A_NUMERIC, 0);
+ else
+ x = make_binary(mpl, O_DIV, x, y, A_FORMULA, 0);
+ }
+ else if (mpl->token == T_DIV)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, "div");
+ get_token(mpl /* div */);
+ y = expression_2(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, "div");
+ x = make_binary(mpl, O_IDIV, x, y, A_NUMERIC, 0);
+ }
+ else if (mpl->token == T_MOD)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, "mod");
+ get_token(mpl /* mod */);
+ y = expression_2(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, "mod");
+ x = make_binary(mpl, O_MOD, x, y, A_NUMERIC, 0);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_4 - parse expression of level 4.
+--
+-- This routine parses expression of level 4 using the syntax:
+--
+-- <expression 4> ::= <expression 3>
+-- <expression 4> ::= <expression 4> + <expression 3>
+-- <expression 4> ::= <expression 4> - <expression 3>
+-- <expression 4> ::= <expression 4> less <expression 3> */
+
+CODE *expression_4(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_3(mpl);
+ for (;;)
+ { if (mpl->token == T_PLUS)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_preceding(mpl, "+");
+ get_token(mpl /* + */);
+ y = expression_3(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (!(y->type == A_NUMERIC || y->type == A_FORMULA))
+ error_following(mpl, "+");
+ if (x->type == A_NUMERIC && y->type == A_FORMULA)
+ x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);
+ if (x->type == A_FORMULA && y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);
+ x = make_binary(mpl, O_ADD, x, y, x->type, 0);
+ }
+ else if (mpl->token == T_MINUS)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (!(x->type == A_NUMERIC || x->type == A_FORMULA))
+ error_preceding(mpl, "-");
+ get_token(mpl /* - */);
+ y = expression_3(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (!(y->type == A_NUMERIC || y->type == A_FORMULA))
+ error_following(mpl, "-");
+ if (x->type == A_NUMERIC && y->type == A_FORMULA)
+ x = make_unary(mpl, O_CVTLFM, x, A_FORMULA, 0);
+ if (x->type == A_FORMULA && y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTLFM, y, A_FORMULA, 0);
+ x = make_binary(mpl, O_SUB, x, y, x->type, 0);
+ }
+ else if (mpl->token == T_LESS)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, "less");
+ get_token(mpl /* less */);
+ y = expression_3(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, "less");
+ x = make_binary(mpl, O_LESS, x, y, A_NUMERIC, 0);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_5 - parse expression of level 5.
+--
+-- This routine parses expression of level 5 using the syntax:
+--
+-- <expression 5> ::= <expression 4>
+-- <expression 5> ::= <expression 5> & <expression 4> */
+
+CODE *expression_5(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_4(mpl);
+ for (;;)
+ { if (mpl->token == T_CONCAT)
+ { if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);
+ if (x->type != A_SYMBOLIC)
+ error_preceding(mpl, "&");
+ get_token(mpl /* & */);
+ y = expression_4(mpl);
+ if (y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);
+ if (y->type != A_SYMBOLIC)
+ error_following(mpl, "&");
+ x = make_binary(mpl, O_CONCAT, x, y, A_SYMBOLIC, 0);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_6 - parse expression of level 6.
+--
+-- This routine parses expression of level 6 using the syntax:
+--
+-- <expression 6> ::= <expression 5>
+-- <expression 6> ::= <expression 5> .. <expression 5>
+-- <expression 6> ::= <expression 5> .. <expression 5> by
+-- <expression 5> */
+
+CODE *expression_6(MPL *mpl)
+{ CODE *x, *y, *z;
+ x = expression_5(mpl);
+ if (mpl->token == T_DOTS)
+ { if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, "..");
+ get_token(mpl /* .. */);
+ y = expression_5(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, "..");
+ if (mpl->token == T_BY)
+ { get_token(mpl /* by */);
+ z = expression_5(mpl);
+ if (z->type == A_SYMBOLIC)
+ z = make_unary(mpl, O_CVTNUM, z, A_NUMERIC, 0);
+ if (z->type != A_NUMERIC)
+ error_following(mpl, "by");
+ }
+ else
+ z = NULL;
+ x = make_ternary(mpl, O_DOTS, x, y, z, A_ELEMSET, 1);
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_7 - parse expression of level 7.
+--
+-- This routine parses expression of level 7 using the syntax:
+--
+-- <expression 7> ::= <expression 6>
+-- <expression 7> ::= <expression 7> cross <expression 6> */
+
+CODE *expression_7(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_6(mpl);
+ for (;;)
+ { if (mpl->token == T_CROSS)
+ { if (x->type != A_ELEMSET)
+ error_preceding(mpl, "cross");
+ get_token(mpl /* cross */);
+ y = expression_6(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, "cross");
+ x = make_binary(mpl, O_CROSS, x, y, A_ELEMSET,
+ x->dim + y->dim);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_8 - parse expression of level 8.
+--
+-- This routine parses expression of level 8 using the syntax:
+--
+-- <expression 8> ::= <expression 7>
+-- <expression 8> ::= <expression 8> inter <expression 7> */
+
+CODE *expression_8(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_7(mpl);
+ for (;;)
+ { if (mpl->token == T_INTER)
+ { if (x->type != A_ELEMSET)
+ error_preceding(mpl, "inter");
+ get_token(mpl /* inter */);
+ y = expression_7(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, "inter");
+ if (x->dim != y->dim)
+ error_dimension(mpl, "inter", x->dim, y->dim);
+ x = make_binary(mpl, O_INTER, x, y, A_ELEMSET, x->dim);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_9 - parse expression of level 9.
+--
+-- This routine parses expression of level 9 using the syntax:
+--
+-- <expression 9> ::= <expression 8>
+-- <expression 9> ::= <expression 9> union <expression 8>
+-- <expression 9> ::= <expression 9> diff <expression 8>
+-- <expression 9> ::= <expression 9> symdiff <expression 8> */
+
+CODE *expression_9(MPL *mpl)
+{ CODE *x, *y;
+ x = expression_8(mpl);
+ for (;;)
+ { if (mpl->token == T_UNION)
+ { if (x->type != A_ELEMSET)
+ error_preceding(mpl, "union");
+ get_token(mpl /* union */);
+ y = expression_8(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, "union");
+ if (x->dim != y->dim)
+ error_dimension(mpl, "union", x->dim, y->dim);
+ x = make_binary(mpl, O_UNION, x, y, A_ELEMSET, x->dim);
+ }
+ else if (mpl->token == T_DIFF)
+ { if (x->type != A_ELEMSET)
+ error_preceding(mpl, "diff");
+ get_token(mpl /* diff */);
+ y = expression_8(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, "diff");
+ if (x->dim != y->dim)
+ error_dimension(mpl, "diff", x->dim, y->dim);
+ x = make_binary(mpl, O_DIFF, x, y, A_ELEMSET, x->dim);
+ }
+ else if (mpl->token == T_SYMDIFF)
+ { if (x->type != A_ELEMSET)
+ error_preceding(mpl, "symdiff");
+ get_token(mpl /* symdiff */);
+ y = expression_8(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, "symdiff");
+ if (x->dim != y->dim)
+ error_dimension(mpl, "symdiff", x->dim, y->dim);
+ x = make_binary(mpl, O_SYMDIFF, x, y, A_ELEMSET, x->dim);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_10 - parse expression of level 10.
+--
+-- This routine parses expression of level 10 using the syntax:
+--
+-- <expression 10> ::= <expression 9>
+-- <expression 10> ::= <expression 9> <rho> <expression 9>
+-- <rho> ::= < | <= | = | == | >= | > | <> | != | in | not in | ! in |
+-- within | not within | ! within */
+
+CODE *expression_10(MPL *mpl)
+{ CODE *x, *y;
+ int op = -1;
+ char opstr[16];
+ x = expression_9(mpl);
+ strcpy(opstr, "");
+ switch (mpl->token)
+ { case T_LT:
+ op = O_LT; break;
+ case T_LE:
+ op = O_LE; break;
+ case T_EQ:
+ op = O_EQ; break;
+ case T_GE:
+ op = O_GE; break;
+ case T_GT:
+ op = O_GT; break;
+ case T_NE:
+ op = O_NE; break;
+ case T_IN:
+ op = O_IN; break;
+ case T_WITHIN:
+ op = O_WITHIN; break;
+ case T_NOT:
+ strcpy(opstr, mpl->image);
+ get_token(mpl /* not | ! */);
+ if (mpl->token == T_IN)
+ op = O_NOTIN;
+ else if (mpl->token == T_WITHIN)
+ op = O_NOTWITHIN;
+ else
+ error(mpl, "invalid use of %s", opstr);
+ strcat(opstr, " ");
+ break;
+ default:
+ goto done;
+ }
+ strcat(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ switch (op)
+ { case O_EQ:
+ case O_NE:
+#if 1 /* 02/VIII-2008 */
+ case O_LT:
+ case O_LE:
+ case O_GT:
+ case O_GE:
+#endif
+ if (!(x->type == A_NUMERIC || x->type == A_SYMBOLIC))
+ error_preceding(mpl, opstr);
+ get_token(mpl /* <rho> */);
+ y = expression_9(mpl);
+ if (!(y->type == A_NUMERIC || y->type == A_SYMBOLIC))
+ error_following(mpl, opstr);
+ if (x->type == A_NUMERIC && y->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);
+ if (x->type == A_SYMBOLIC && y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTSYM, y, A_SYMBOLIC, 0);
+ x = make_binary(mpl, op, x, y, A_LOGICAL, 0);
+ break;
+#if 0 /* 02/VIII-2008 */
+ case O_LT:
+ case O_LE:
+ case O_GT:
+ case O_GE:
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type != A_NUMERIC)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* <rho> */);
+ y = expression_9(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type != A_NUMERIC)
+ error_following(mpl, opstr);
+ x = make_binary(mpl, op, x, y, A_LOGICAL, 0);
+ break;
+#endif
+ case O_IN:
+ case O_NOTIN:
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTSYM, x, A_SYMBOLIC, 0);
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTTUP, x, A_TUPLE, 1);
+ if (x->type != A_TUPLE)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* <rho> */);
+ y = expression_9(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, opstr);
+ if (x->dim != y->dim)
+ error_dimension(mpl, opstr, x->dim, y->dim);
+ x = make_binary(mpl, op, x, y, A_LOGICAL, 0);
+ break;
+ case O_WITHIN:
+ case O_NOTWITHIN:
+ if (x->type != A_ELEMSET)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* <rho> */);
+ y = expression_9(mpl);
+ if (y->type != A_ELEMSET)
+ error_following(mpl, opstr);
+ if (x->dim != y->dim)
+ error_dimension(mpl, opstr, x->dim, y->dim);
+ x = make_binary(mpl, op, x, y, A_LOGICAL, 0);
+ break;
+ default:
+ xassert(op != op);
+ }
+done: return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_11 - parse expression of level 11.
+--
+-- This routine parses expression of level 11 using the syntax:
+--
+-- <expression 11> ::= <expression 10>
+-- <expression 11> ::= not <expression 10>
+-- <expression 11> ::= ! <expression 10> */
+
+CODE *expression_11(MPL *mpl)
+{ CODE *x;
+ char opstr[8];
+ if (mpl->token == T_NOT)
+ { strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ get_token(mpl /* not | ! */);
+ x = expression_10(mpl);
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);
+ if (x->type != A_LOGICAL)
+ error_following(mpl, opstr);
+ x = make_unary(mpl, O_NOT, x, A_LOGICAL, 0);
+ }
+ else
+ x = expression_10(mpl);
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_12 - parse expression of level 12.
+--
+-- This routine parses expression of level 12 using the syntax:
+--
+-- <expression 12> ::= <expression 11>
+-- <expression 12> ::= <expression 12> and <expression 11>
+-- <expression 12> ::= <expression 12> && <expression 11> */
+
+CODE *expression_12(MPL *mpl)
+{ CODE *x, *y;
+ char opstr[8];
+ x = expression_11(mpl);
+ for (;;)
+ { if (mpl->token == T_AND)
+ { strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);
+ if (x->type != A_LOGICAL)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* and | && */);
+ y = expression_11(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);
+ if (y->type != A_LOGICAL)
+ error_following(mpl, opstr);
+ x = make_binary(mpl, O_AND, x, y, A_LOGICAL, 0);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- expression_13 - parse expression of level 13.
+--
+-- This routine parses expression of level 13 using the syntax:
+--
+-- <expression 13> ::= <expression 12>
+-- <expression 13> ::= <expression 13> or <expression 12>
+-- <expression 13> ::= <expression 13> || <expression 12> */
+
+CODE *expression_13(MPL *mpl)
+{ CODE *x, *y;
+ char opstr[8];
+ x = expression_12(mpl);
+ for (;;)
+ { if (mpl->token == T_OR)
+ { strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ if (x->type == A_SYMBOLIC)
+ x = make_unary(mpl, O_CVTNUM, x, A_NUMERIC, 0);
+ if (x->type == A_NUMERIC)
+ x = make_unary(mpl, O_CVTLOG, x, A_LOGICAL, 0);
+ if (x->type != A_LOGICAL)
+ error_preceding(mpl, opstr);
+ get_token(mpl /* or | || */);
+ y = expression_12(mpl);
+ if (y->type == A_SYMBOLIC)
+ y = make_unary(mpl, O_CVTNUM, y, A_NUMERIC, 0);
+ if (y->type == A_NUMERIC)
+ y = make_unary(mpl, O_CVTLOG, y, A_LOGICAL, 0);
+ if (y->type != A_LOGICAL)
+ error_following(mpl, opstr);
+ x = make_binary(mpl, O_OR, x, y, A_LOGICAL, 0);
+ }
+ else
+ break;
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- set_statement - parse set statement.
+--
+-- This routine parses set statement using the syntax:
+--
+-- <set statement> ::= set <symbolic name> <alias> <domain>
+-- <attributes> ;
+-- <alias> ::= <empty>
+-- <alias> ::= <string literal>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <attributes> ::= <empty>
+-- <attributes> ::= <attributes> , dimen <numeric literal>
+-- <attributes> ::= <attributes> , within <expression 9>
+-- <attributes> ::= <attributes> , := <expression 9>
+-- <attributes> ::= <attributes> , default <expression 9>
+--
+-- Commae in <attributes> are optional and may be omitted anywhere. */
+
+SET *set_statement(MPL *mpl)
+{ SET *set;
+ int dimen_used = 0;
+ xassert(is_keyword(mpl, "set"));
+ get_token(mpl /* set */);
+ /* symbolic name must follow the keyword 'set' */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create model set */
+ set = alloc(SET);
+ set->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(set->name, mpl->image);
+ set->alias = NULL;
+ set->dim = 0;
+ set->domain = NULL;
+ set->dimen = 0;
+ set->within = NULL;
+ set->assign = NULL;
+ set->option = NULL;
+ set->gadget = NULL;
+ set->data = 0;
+ set->array = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { set->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(set->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { set->domain = indexing_expression(mpl);
+ set->dim = domain_arity(mpl, set->domain);
+ }
+ /* include the set name in the symbolic names table */
+ { AVLNODE *node;
+ node = avl_insert_node(mpl->tree, set->name);
+ avl_set_node_type(node, A_SET);
+ avl_set_node_link(node, (void *)set);
+ }
+ /* parse the list of optional attributes */
+ for (;;)
+ { if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_SEMICOLON)
+ break;
+ if (is_keyword(mpl, "dimen"))
+ { /* dimension of set members */
+ int dimen;
+ get_token(mpl /* dimen */);
+ if (!(mpl->token == T_NUMBER &&
+ 1.0 <= mpl->value && mpl->value <= 20.0 &&
+ floor(mpl->value) == mpl->value))
+ error(mpl, "dimension must be integer between 1 and 20");
+ dimen = (int)(mpl->value + 0.5);
+ if (dimen_used)
+ error(mpl, "at most one dimension attribute allowed");
+ if (set->dimen > 0)
+ error(mpl, "dimension %d conflicts with dimension %d alr"
+ "eady determined", dimen, set->dimen);
+ set->dimen = dimen;
+ dimen_used = 1;
+ get_token(mpl /* <numeric literal> */);
+ }
+ else if (mpl->token == T_WITHIN || mpl->token == T_IN)
+ { /* restricting superset */
+ WITHIN *within, *temp;
+ if (mpl->token == T_IN && !mpl->as_within)
+ { warning(mpl, "keyword in understood as within");
+ mpl->as_within = 1;
+ }
+ get_token(mpl /* within */);
+ /* create new restricting superset list entry and append it
+ to the within-list */
+ within = alloc(WITHIN);
+ within->code = NULL;
+ within->next = NULL;
+ if (set->within == NULL)
+ set->within = within;
+ else
+ { for (temp = set->within; temp->next != NULL; temp =
+ temp->next);
+ temp->next = within;
+ }
+ /* parse an expression that follows 'within' */
+ within->code = expression_9(mpl);
+ if (within->code->type != A_ELEMSET)
+ error(mpl, "expression following within has invalid type"
+ );
+ xassert(within->code->dim > 0);
+ /* check/set dimension of set members */
+ if (set->dimen == 0) set->dimen = within->code->dim;
+ if (set->dimen != within->code->dim)
+ error(mpl, "set expression following within must have di"
+ "mension %d rather than %d",
+ set->dimen, within->code->dim);
+ }
+ else if (mpl->token == T_ASSIGN)
+ { /* assignment expression */
+ if (!(set->assign == NULL && set->option == NULL &&
+ set->gadget == NULL))
+err: error(mpl, "at most one := or default/data allowed");
+ get_token(mpl /* := */);
+ /* parse an expression that follows ':=' */
+ set->assign = expression_9(mpl);
+ if (set->assign->type != A_ELEMSET)
+ error(mpl, "expression following := has invalid type");
+ xassert(set->assign->dim > 0);
+ /* check/set dimension of set members */
+ if (set->dimen == 0) set->dimen = set->assign->dim;
+ if (set->dimen != set->assign->dim)
+ error(mpl, "set expression following := must have dimens"
+ "ion %d rather than %d",
+ set->dimen, set->assign->dim);
+ }
+ else if (is_keyword(mpl, "default"))
+ { /* expression for default value */
+ if (!(set->assign == NULL && set->option == NULL)) goto err;
+ get_token(mpl /* := */);
+ /* parse an expression that follows 'default' */
+ set->option = expression_9(mpl);
+ if (set->option->type != A_ELEMSET)
+ error(mpl, "expression following default has invalid typ"
+ "e");
+ xassert(set->option->dim > 0);
+ /* check/set dimension of set members */
+ if (set->dimen == 0) set->dimen = set->option->dim;
+ if (set->dimen != set->option->dim)
+ error(mpl, "set expression following default must have d"
+ "imension %d rather than %d",
+ set->dimen, set->option->dim);
+ }
+#if 1 /* 12/XII-2008 */
+ else if (is_keyword(mpl, "data"))
+ { /* gadget to initialize the set by data from plain set */
+ GADGET *gadget;
+ AVLNODE *node;
+ int i, k, fff[20];
+ if (!(set->assign == NULL && set->gadget == NULL)) goto err;
+ get_token(mpl /* data */);
+ set->gadget = gadget = alloc(GADGET);
+ /* set name must follow the keyword 'data' */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s",
+ mpl->image);
+ else
+ error(mpl, "set name missing where expected");
+ /* find the set in the symbolic name table */
+ node = avl_find_node(mpl->tree, mpl->image);
+ if (node == NULL)
+ error(mpl, "%s not defined", mpl->image);
+ if (avl_get_node_type(node) != A_SET)
+err1: error(mpl, "%s not a plain set", mpl->image);
+ gadget->set = avl_get_node_link(node);
+ if (gadget->set->dim != 0) goto err1;
+ if (gadget->set == set)
+ error(mpl, "set cannot be initialized by itself");
+ /* check and set dimensions */
+ if (set->dim >= gadget->set->dimen)
+err2: error(mpl, "dimension of %s too small", mpl->image);
+ if (set->dimen == 0)
+ set->dimen = gadget->set->dimen - set->dim;
+ if (set->dim + set->dimen > gadget->set->dimen)
+ goto err2;
+ else if (set->dim + set->dimen < gadget->set->dimen)
+ error(mpl, "dimension of %s too big", mpl->image);
+ get_token(mpl /* set name */);
+ /* left parenthesis must follow the set name */
+ if (mpl->token == T_LEFT)
+ get_token(mpl /* ( */);
+ else
+ error(mpl, "left parenthesis missing where expected");
+ /* parse permutation of component numbers */
+ for (k = 0; k < gadget->set->dimen; k++) fff[k] = 0;
+ k = 0;
+ for (;;)
+ { if (mpl->token != T_NUMBER)
+ error(mpl, "component number missing where expected");
+ if (str2int(mpl->image, &i) != 0)
+err3: error(mpl, "component number must be integer between "
+ "1 and %d", gadget->set->dimen);
+ if (!(1 <= i && i <= gadget->set->dimen)) goto err3;
+ if (fff[i-1] != 0)
+ error(mpl, "component %d multiply specified", i);
+ gadget->ind[k++] = i, fff[i-1] = 1;
+ xassert(k <= gadget->set->dimen);
+ get_token(mpl /* number */);
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RIGHT)
+ break;
+ else
+ error(mpl, "syntax error in data attribute");
+ }
+ if (k < gadget->set->dimen)
+ error(mpl, "there are must be %d components rather than "
+ "%d", gadget->set->dimen, k);
+ get_token(mpl /* ) */);
+ }
+#endif
+ else
+ error(mpl, "syntax error in set statement");
+ }
+ /* close the domain scope */
+ if (set->domain != NULL) close_scope(mpl, set->domain);
+ /* if dimension of set members is still unknown, set it to 1 */
+ if (set->dimen == 0) set->dimen = 1;
+ /* the set statement has been completely parsed */
+ xassert(mpl->token == T_SEMICOLON);
+ get_token(mpl /* ; */);
+ return set;
+}
+
+/*----------------------------------------------------------------------
+-- parameter_statement - parse parameter statement.
+--
+-- This routine parses parameter statement using the syntax:
+--
+-- <parameter statement> ::= param <symbolic name> <alias> <domain>
+-- <attributes> ;
+-- <alias> ::= <empty>
+-- <alias> ::= <string literal>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <attributes> ::= <empty>
+-- <attributes> ::= <attributes> , integer
+-- <attributes> ::= <attributes> , binary
+-- <attributes> ::= <attributes> , symbolic
+-- <attributes> ::= <attributes> , <rho> <expression 5>
+-- <attributes> ::= <attributes> , in <expression 9>
+-- <attributes> ::= <attributes> , := <expression 5>
+-- <attributes> ::= <attributes> , default <expression 5>
+-- <rho> ::= < | <= | = | == | >= | > | <> | !=
+--
+-- Commae in <attributes> are optional and may be omitted anywhere. */
+
+PARAMETER *parameter_statement(MPL *mpl)
+{ PARAMETER *par;
+ int integer_used = 0, binary_used = 0, symbolic_used = 0;
+ xassert(is_keyword(mpl, "param"));
+ get_token(mpl /* param */);
+ /* symbolic name must follow the keyword 'param' */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create model parameter */
+ par = alloc(PARAMETER);
+ par->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(par->name, mpl->image);
+ par->alias = NULL;
+ par->dim = 0;
+ par->domain = NULL;
+ par->type = A_NUMERIC;
+ par->cond = NULL;
+ par->in = NULL;
+ par->assign = NULL;
+ par->option = NULL;
+ par->data = 0;
+ par->defval = NULL;
+ par->array = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { par->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(par->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { par->domain = indexing_expression(mpl);
+ par->dim = domain_arity(mpl, par->domain);
+ }
+ /* include the parameter name in the symbolic names table */
+ { AVLNODE *node;
+ node = avl_insert_node(mpl->tree, par->name);
+ avl_set_node_type(node, A_PARAMETER);
+ avl_set_node_link(node, (void *)par);
+ }
+ /* parse the list of optional attributes */
+ for (;;)
+ { if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_SEMICOLON)
+ break;
+ if (is_keyword(mpl, "integer"))
+ { if (integer_used)
+ error(mpl, "at most one integer allowed");
+ if (par->type == A_SYMBOLIC)
+ error(mpl, "symbolic parameter cannot be integer");
+ if (par->type != A_BINARY) par->type = A_INTEGER;
+ integer_used = 1;
+ get_token(mpl /* integer */);
+ }
+ else if (is_keyword(mpl, "binary"))
+bin: { if (binary_used)
+ error(mpl, "at most one binary allowed");
+ if (par->type == A_SYMBOLIC)
+ error(mpl, "symbolic parameter cannot be binary");
+ par->type = A_BINARY;
+ binary_used = 1;
+ get_token(mpl /* binary */);
+ }
+ else if (is_keyword(mpl, "logical"))
+ { if (!mpl->as_binary)
+ { warning(mpl, "keyword logical understood as binary");
+ mpl->as_binary = 1;
+ }
+ goto bin;
+ }
+ else if (is_keyword(mpl, "symbolic"))
+ { if (symbolic_used)
+ error(mpl, "at most one symbolic allowed");
+ if (par->type != A_NUMERIC)
+ error(mpl, "integer or binary parameter cannot be symbol"
+ "ic");
+ /* the parameter may be referenced from expressions given
+ in the same parameter declaration, so its type must be
+ completed before parsing that expressions */
+ if (!(par->cond == NULL && par->in == NULL &&
+ par->assign == NULL && par->option == NULL))
+ error(mpl, "keyword symbolic must precede any other para"
+ "meter attributes");
+ par->type = A_SYMBOLIC;
+ symbolic_used = 1;
+ get_token(mpl /* symbolic */);
+ }
+ else if (mpl->token == T_LT || mpl->token == T_LE ||
+ mpl->token == T_EQ || mpl->token == T_GE ||
+ mpl->token == T_GT || mpl->token == T_NE)
+ { /* restricting condition */
+ CONDITION *cond, *temp;
+ char opstr[8];
+ /* create new restricting condition list entry and append
+ it to the conditions list */
+ cond = alloc(CONDITION);
+ switch (mpl->token)
+ { case T_LT:
+ cond->rho = O_LT, strcpy(opstr, mpl->image); break;
+ case T_LE:
+ cond->rho = O_LE, strcpy(opstr, mpl->image); break;
+ case T_EQ:
+ cond->rho = O_EQ, strcpy(opstr, mpl->image); break;
+ case T_GE:
+ cond->rho = O_GE, strcpy(opstr, mpl->image); break;
+ case T_GT:
+ cond->rho = O_GT, strcpy(opstr, mpl->image); break;
+ case T_NE:
+ cond->rho = O_NE, strcpy(opstr, mpl->image); break;
+ default:
+ xassert(mpl->token != mpl->token);
+ }
+ xassert(strlen(opstr) < sizeof(opstr));
+ cond->code = NULL;
+ cond->next = NULL;
+ if (par->cond == NULL)
+ par->cond = cond;
+ else
+ { for (temp = par->cond; temp->next != NULL; temp =
+ temp->next);
+ temp->next = cond;
+ }
+#if 0 /* 13/VIII-2008 */
+ if (par->type == A_SYMBOLIC &&
+ !(cond->rho == O_EQ || cond->rho == O_NE))
+ error(mpl, "inequality restriction not allowed");
+#endif
+ get_token(mpl /* rho */);
+ /* parse an expression that follows relational operator */
+ cond->code = expression_5(mpl);
+ if (!(cond->code->type == A_NUMERIC ||
+ cond->code->type == A_SYMBOLIC))
+ error(mpl, "expression following %s has invalid type",
+ opstr);
+ xassert(cond->code->dim == 0);
+ /* convert to the parameter type, if necessary */
+ if (par->type != A_SYMBOLIC && cond->code->type ==
+ A_SYMBOLIC)
+ cond->code = make_unary(mpl, O_CVTNUM, cond->code,
+ A_NUMERIC, 0);
+ if (par->type == A_SYMBOLIC && cond->code->type !=
+ A_SYMBOLIC)
+ cond->code = make_unary(mpl, O_CVTSYM, cond->code,
+ A_SYMBOLIC, 0);
+ }
+ else if (mpl->token == T_IN || mpl->token == T_WITHIN)
+ { /* restricting superset */
+ WITHIN *in, *temp;
+ if (mpl->token == T_WITHIN && !mpl->as_in)
+ { warning(mpl, "keyword within understood as in");
+ mpl->as_in = 1;
+ }
+ get_token(mpl /* in */);
+ /* create new restricting superset list entry and append it
+ to the in-list */
+ in = alloc(WITHIN);
+ in->code = NULL;
+ in->next = NULL;
+ if (par->in == NULL)
+ par->in = in;
+ else
+ { for (temp = par->in; temp->next != NULL; temp =
+ temp->next);
+ temp->next = in;
+ }
+ /* parse an expression that follows 'in' */
+ in->code = expression_9(mpl);
+ if (in->code->type != A_ELEMSET)
+ error(mpl, "expression following in has invalid type");
+ xassert(in->code->dim > 0);
+ if (in->code->dim != 1)
+ error(mpl, "set expression following in must have dimens"
+ "ion 1 rather than %d", in->code->dim);
+ }
+ else if (mpl->token == T_ASSIGN)
+ { /* assignment expression */
+ if (!(par->assign == NULL && par->option == NULL))
+err: error(mpl, "at most one := or default allowed");
+ get_token(mpl /* := */);
+ /* parse an expression that follows ':=' */
+ par->assign = expression_5(mpl);
+ /* the expression must be of numeric/symbolic type */
+ if (!(par->assign->type == A_NUMERIC ||
+ par->assign->type == A_SYMBOLIC))
+ error(mpl, "expression following := has invalid type");
+ xassert(par->assign->dim == 0);
+ /* convert to the parameter type, if necessary */
+ if (par->type != A_SYMBOLIC && par->assign->type ==
+ A_SYMBOLIC)
+ par->assign = make_unary(mpl, O_CVTNUM, par->assign,
+ A_NUMERIC, 0);
+ if (par->type == A_SYMBOLIC && par->assign->type !=
+ A_SYMBOLIC)
+ par->assign = make_unary(mpl, O_CVTSYM, par->assign,
+ A_SYMBOLIC, 0);
+ }
+ else if (is_keyword(mpl, "default"))
+ { /* expression for default value */
+ if (!(par->assign == NULL && par->option == NULL)) goto err;
+ get_token(mpl /* default */);
+ /* parse an expression that follows 'default' */
+ par->option = expression_5(mpl);
+ if (!(par->option->type == A_NUMERIC ||
+ par->option->type == A_SYMBOLIC))
+ error(mpl, "expression following default has invalid typ"
+ "e");
+ xassert(par->option->dim == 0);
+ /* convert to the parameter type, if necessary */
+ if (par->type != A_SYMBOLIC && par->option->type ==
+ A_SYMBOLIC)
+ par->option = make_unary(mpl, O_CVTNUM, par->option,
+ A_NUMERIC, 0);
+ if (par->type == A_SYMBOLIC && par->option->type !=
+ A_SYMBOLIC)
+ par->option = make_unary(mpl, O_CVTSYM, par->option,
+ A_SYMBOLIC, 0);
+ }
+ else
+ error(mpl, "syntax error in parameter statement");
+ }
+ /* close the domain scope */
+ if (par->domain != NULL) close_scope(mpl, par->domain);
+ /* the parameter statement has been completely parsed */
+ xassert(mpl->token == T_SEMICOLON);
+ get_token(mpl /* ; */);
+ return par;
+}
+
+/*----------------------------------------------------------------------
+-- variable_statement - parse variable statement.
+--
+-- This routine parses variable statement using the syntax:
+--
+-- <variable statement> ::= var <symbolic name> <alias> <domain>
+-- <attributes> ;
+-- <alias> ::= <empty>
+-- <alias> ::= <string literal>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <attributes> ::= <empty>
+-- <attributes> ::= <attributes> , integer
+-- <attributes> ::= <attributes> , binary
+-- <attributes> ::= <attributes> , <rho> <expression 5>
+-- <rho> ::= >= | <= | = | ==
+--
+-- Commae in <attributes> are optional and may be omitted anywhere. */
+
+VARIABLE *variable_statement(MPL *mpl)
+{ VARIABLE *var;
+ int integer_used = 0, binary_used = 0;
+ xassert(is_keyword(mpl, "var"));
+ if (mpl->flag_s)
+ error(mpl, "variable statement must precede solve statement");
+ get_token(mpl /* var */);
+ /* symbolic name must follow the keyword 'var' */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create model variable */
+ var = alloc(VARIABLE);
+ var->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(var->name, mpl->image);
+ var->alias = NULL;
+ var->dim = 0;
+ var->domain = NULL;
+ var->type = A_NUMERIC;
+ var->lbnd = NULL;
+ var->ubnd = NULL;
+ var->array = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { var->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(var->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { var->domain = indexing_expression(mpl);
+ var->dim = domain_arity(mpl, var->domain);
+ }
+ /* include the variable name in the symbolic names table */
+ { AVLNODE *node;
+ node = avl_insert_node(mpl->tree, var->name);
+ avl_set_node_type(node, A_VARIABLE);
+ avl_set_node_link(node, (void *)var);
+ }
+ /* parse the list of optional attributes */
+ for (;;)
+ { if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_SEMICOLON)
+ break;
+ if (is_keyword(mpl, "integer"))
+ { if (integer_used)
+ error(mpl, "at most one integer allowed");
+ if (var->type != A_BINARY) var->type = A_INTEGER;
+ integer_used = 1;
+ get_token(mpl /* integer */);
+ }
+ else if (is_keyword(mpl, "binary"))
+bin: { if (binary_used)
+ error(mpl, "at most one binary allowed");
+ var->type = A_BINARY;
+ binary_used = 1;
+ get_token(mpl /* binary */);
+ }
+ else if (is_keyword(mpl, "logical"))
+ { if (!mpl->as_binary)
+ { warning(mpl, "keyword logical understood as binary");
+ mpl->as_binary = 1;
+ }
+ goto bin;
+ }
+ else if (is_keyword(mpl, "symbolic"))
+ error(mpl, "variable cannot be symbolic");
+ else if (mpl->token == T_GE)
+ { /* lower bound */
+ if (var->lbnd != NULL)
+ { if (var->lbnd == var->ubnd)
+ error(mpl, "both fixed value and lower bound not allo"
+ "wed");
+ else
+ error(mpl, "at most one lower bound allowed");
+ }
+ get_token(mpl /* >= */);
+ /* parse an expression that specifies the lower bound */
+ var->lbnd = expression_5(mpl);
+ if (var->lbnd->type == A_SYMBOLIC)
+ var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,
+ A_NUMERIC, 0);
+ if (var->lbnd->type != A_NUMERIC)
+ error(mpl, "expression following >= has invalid type");
+ xassert(var->lbnd->dim == 0);
+ }
+ else if (mpl->token == T_LE)
+ { /* upper bound */
+ if (var->ubnd != NULL)
+ { if (var->ubnd == var->lbnd)
+ error(mpl, "both fixed value and upper bound not allo"
+ "wed");
+ else
+ error(mpl, "at most one upper bound allowed");
+ }
+ get_token(mpl /* <= */);
+ /* parse an expression that specifies the upper bound */
+ var->ubnd = expression_5(mpl);
+ if (var->ubnd->type == A_SYMBOLIC)
+ var->ubnd = make_unary(mpl, O_CVTNUM, var->ubnd,
+ A_NUMERIC, 0);
+ if (var->ubnd->type != A_NUMERIC)
+ error(mpl, "expression following <= has invalid type");
+ xassert(var->ubnd->dim == 0);
+ }
+ else if (mpl->token == T_EQ)
+ { /* fixed value */
+ char opstr[8];
+ if (!(var->lbnd == NULL && var->ubnd == NULL))
+ { if (var->lbnd == var->ubnd)
+ error(mpl, "at most one fixed value allowed");
+ else if (var->lbnd != NULL)
+ error(mpl, "both lower bound and fixed value not allo"
+ "wed");
+ else
+ error(mpl, "both upper bound and fixed value not allo"
+ "wed");
+ }
+ strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ get_token(mpl /* = | == */);
+ /* parse an expression that specifies the fixed value */
+ var->lbnd = expression_5(mpl);
+ if (var->lbnd->type == A_SYMBOLIC)
+ var->lbnd = make_unary(mpl, O_CVTNUM, var->lbnd,
+ A_NUMERIC, 0);
+ if (var->lbnd->type != A_NUMERIC)
+ error(mpl, "expression following %s has invalid type",
+ opstr);
+ xassert(var->lbnd->dim == 0);
+ /* indicate that the variable is fixed, not bounded */
+ var->ubnd = var->lbnd;
+ }
+ else if (mpl->token == T_LT || mpl->token == T_GT ||
+ mpl->token == T_NE)
+ error(mpl, "strict bound not allowed");
+ else
+ error(mpl, "syntax error in variable statement");
+ }
+ /* close the domain scope */
+ if (var->domain != NULL) close_scope(mpl, var->domain);
+ /* the variable statement has been completely parsed */
+ xassert(mpl->token == T_SEMICOLON);
+ get_token(mpl /* ; */);
+ return var;
+}
+
+/*----------------------------------------------------------------------
+-- constraint_statement - parse constraint statement.
+--
+-- This routine parses constraint statement using the syntax:
+--
+-- <constraint statement> ::= <subject to> <symbolic name> <alias>
+-- <domain> : <constraint> ;
+-- <subject to> ::= <empty>
+-- <subject to> ::= subject to
+-- <subject to> ::= subj to
+-- <subject to> ::= s.t.
+-- <alias> ::= <empty>
+-- <alias> ::= <string literal>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <constraint> ::= <formula> , >= <formula>
+-- <constraint> ::= <formula> , <= <formula>
+-- <constraint> ::= <formula> , = <formula>
+-- <constraint> ::= <formula> , <= <formula> , <= <formula>
+-- <constraint> ::= <formula> , >= <formula> , >= <formula>
+-- <formula> ::= <expression 5>
+--
+-- Commae in <constraint> are optional and may be omitted anywhere. */
+
+CONSTRAINT *constraint_statement(MPL *mpl)
+{ CONSTRAINT *con;
+ CODE *first, *second, *third;
+ int rho;
+ char opstr[8];
+ if (mpl->flag_s)
+ error(mpl, "constraint statement must precede solve statement")
+ ;
+ if (is_keyword(mpl, "subject"))
+ { get_token(mpl /* subject */);
+ if (!is_keyword(mpl, "to"))
+ error(mpl, "keyword subject to incomplete");
+ get_token(mpl /* to */);
+ }
+ else if (is_keyword(mpl, "subj"))
+ { get_token(mpl /* subj */);
+ if (!is_keyword(mpl, "to"))
+ error(mpl, "keyword subj to incomplete");
+ get_token(mpl /* to */);
+ }
+ else if (mpl->token == T_SPTP)
+ get_token(mpl /* s.t. */);
+ /* the current token must be symbolic name of constraint */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create model constraint */
+ con = alloc(CONSTRAINT);
+ con->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(con->name, mpl->image);
+ con->alias = NULL;
+ con->dim = 0;
+ con->domain = NULL;
+ con->type = A_CONSTRAINT;
+ con->code = NULL;
+ con->lbnd = NULL;
+ con->ubnd = NULL;
+ con->array = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { con->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(con->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { con->domain = indexing_expression(mpl);
+ con->dim = domain_arity(mpl, con->domain);
+ }
+ /* include the constraint name in the symbolic names table */
+ { AVLNODE *node;
+ node = avl_insert_node(mpl->tree, con->name);
+ avl_set_node_type(node, A_CONSTRAINT);
+ avl_set_node_link(node, (void *)con);
+ }
+ /* the colon must precede the first expression */
+ if (mpl->token != T_COLON)
+ error(mpl, "colon missing where expected");
+ get_token(mpl /* : */);
+ /* parse the first expression */
+ first = expression_5(mpl);
+ if (first->type == A_SYMBOLIC)
+ first = make_unary(mpl, O_CVTNUM, first, A_NUMERIC, 0);
+ if (!(first->type == A_NUMERIC || first->type == A_FORMULA))
+ error(mpl, "expression following colon has invalid type");
+ xassert(first->dim == 0);
+ /* relational operator must follow the first expression */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ switch (mpl->token)
+ { case T_LE:
+ case T_GE:
+ case T_EQ:
+ break;
+ case T_LT:
+ case T_GT:
+ case T_NE:
+ error(mpl, "strict inequality not allowed");
+ case T_SEMICOLON:
+ error(mpl, "constraint must be equality or inequality");
+ default:
+ goto err;
+ }
+ rho = mpl->token;
+ strcpy(opstr, mpl->image);
+ xassert(strlen(opstr) < sizeof(opstr));
+ get_token(mpl /* rho */);
+ /* parse the second expression */
+ second = expression_5(mpl);
+ if (second->type == A_SYMBOLIC)
+ second = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);
+ if (!(second->type == A_NUMERIC || second->type == A_FORMULA))
+ error(mpl, "expression following %s has invalid type", opstr);
+ xassert(second->dim == 0);
+ /* check a token that follow the second expression */
+ if (mpl->token == T_COMMA)
+ { get_token(mpl /* , */);
+ if (mpl->token == T_SEMICOLON) goto err;
+ }
+ if (mpl->token == T_LT || mpl->token == T_LE ||
+ mpl->token == T_EQ || mpl->token == T_GE ||
+ mpl->token == T_GT || mpl->token == T_NE)
+ { /* it is another relational operator, therefore the constraint
+ is double inequality */
+ if (rho == T_EQ || mpl->token != rho)
+ error(mpl, "double inequality must be ... <= ... <= ... or "
+ "... >= ... >= ...");
+ /* the first expression cannot be linear form */
+ if (first->type == A_FORMULA)
+ error(mpl, "leftmost expression in double inequality cannot"
+ " be linear form");
+ get_token(mpl /* rho */);
+ /* parse the third expression */
+ third = expression_5(mpl);
+ if (third->type == A_SYMBOLIC)
+ third = make_unary(mpl, O_CVTNUM, second, A_NUMERIC, 0);
+ if (!(third->type == A_NUMERIC || third->type == A_FORMULA))
+ error(mpl, "rightmost expression in double inequality const"
+ "raint has invalid type");
+ xassert(third->dim == 0);
+ /* the third expression also cannot be linear form */
+ if (third->type == A_FORMULA)
+ error(mpl, "rightmost expression in double inequality canno"
+ "t be linear form");
+ }
+ else
+ { /* the constraint is equality or single inequality */
+ third = NULL;
+ }
+ /* close the domain scope */
+ if (con->domain != NULL) close_scope(mpl, con->domain);
+ /* convert all expressions to linear form, if necessary */
+ if (first->type != A_FORMULA)
+ first = make_unary(mpl, O_CVTLFM, first, A_FORMULA, 0);
+ if (second->type != A_FORMULA)
+ second = make_unary(mpl, O_CVTLFM, second, A_FORMULA, 0);
+ if (third != NULL)
+ third = make_unary(mpl, O_CVTLFM, third, A_FORMULA, 0);
+ /* arrange expressions in the constraint */
+ if (third == NULL)
+ { /* the constraint is equality or single inequality */
+ switch (rho)
+ { case T_LE:
+ /* first <= second */
+ con->code = first;
+ con->lbnd = NULL;
+ con->ubnd = second;
+ break;
+ case T_GE:
+ /* first >= second */
+ con->code = first;
+ con->lbnd = second;
+ con->ubnd = NULL;
+ break;
+ case T_EQ:
+ /* first = second */
+ con->code = first;
+ con->lbnd = second;
+ con->ubnd = second;
+ break;
+ default:
+ xassert(rho != rho);
+ }
+ }
+ else
+ { /* the constraint is double inequality */
+ switch (rho)
+ { case T_LE:
+ /* first <= second <= third */
+ con->code = second;
+ con->lbnd = first;
+ con->ubnd = third;
+ break;
+ case T_GE:
+ /* first >= second >= third */
+ con->code = second;
+ con->lbnd = third;
+ con->ubnd = first;
+ break;
+ default:
+ xassert(rho != rho);
+ }
+ }
+ /* the constraint statement has been completely parsed */
+ if (mpl->token != T_SEMICOLON)
+err: error(mpl, "syntax error in constraint statement");
+ get_token(mpl /* ; */);
+ return con;
+}
+
+/*----------------------------------------------------------------------
+-- objective_statement - parse objective statement.
+--
+-- This routine parses objective statement using the syntax:
+--
+-- <objective statement> ::= <verb> <symbolic name> <alias> <domain> :
+-- <formula> ;
+-- <verb> ::= minimize
+-- <verb> ::= maximize
+-- <alias> ::= <empty>
+-- <alias> ::= <string literal>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <formula> ::= <expression 5> */
+
+CONSTRAINT *objective_statement(MPL *mpl)
+{ CONSTRAINT *obj;
+ int type;
+ if (is_keyword(mpl, "minimize"))
+ type = A_MINIMIZE;
+ else if (is_keyword(mpl, "maximize"))
+ type = A_MAXIMIZE;
+ else
+ xassert(mpl != mpl);
+ if (mpl->flag_s)
+ error(mpl, "objective statement must precede solve statement");
+ get_token(mpl /* minimize | maximize */);
+ /* symbolic name must follow the verb 'minimize' or 'maximize' */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create model objective */
+ obj = alloc(CONSTRAINT);
+ obj->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(obj->name, mpl->image);
+ obj->alias = NULL;
+ obj->dim = 0;
+ obj->domain = NULL;
+ obj->type = type;
+ obj->code = NULL;
+ obj->lbnd = NULL;
+ obj->ubnd = NULL;
+ obj->array = NULL;
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { obj->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(obj->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { obj->domain = indexing_expression(mpl);
+ obj->dim = domain_arity(mpl, obj->domain);
+ }
+ /* include the constraint name in the symbolic names table */
+ { AVLNODE *node;
+ node = avl_insert_node(mpl->tree, obj->name);
+ avl_set_node_type(node, A_CONSTRAINT);
+ avl_set_node_link(node, (void *)obj);
+ }
+ /* the colon must precede the objective expression */
+ if (mpl->token != T_COLON)
+ error(mpl, "colon missing where expected");
+ get_token(mpl /* : */);
+ /* parse the objective expression */
+ obj->code = expression_5(mpl);
+ if (obj->code->type == A_SYMBOLIC)
+ obj->code = make_unary(mpl, O_CVTNUM, obj->code, A_NUMERIC, 0);
+ if (obj->code->type == A_NUMERIC)
+ obj->code = make_unary(mpl, O_CVTLFM, obj->code, A_FORMULA, 0);
+ if (obj->code->type != A_FORMULA)
+ error(mpl, "expression following colon has invalid type");
+ xassert(obj->code->dim == 0);
+ /* close the domain scope */
+ if (obj->domain != NULL) close_scope(mpl, obj->domain);
+ /* the objective statement has been completely parsed */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in objective statement");
+ get_token(mpl /* ; */);
+ return obj;
+}
+
+#if 1 /* 11/II-2008 */
+/***********************************************************************
+* table_statement - parse table statement
+*
+* This routine parses table statement using the syntax:
+*
+* <table statement> ::= <input table statement>
+* <table statement> ::= <output table statement>
+*
+* <input table statement> ::=
+* table <table name> <alias> IN <argument list> :
+* <input set> [ <field list> ] , <input list> ;
+* <alias> ::= <empty>
+* <alias> ::= <string literal>
+* <argument list> ::= <expression 5>
+* <argument list> ::= <argument list> <expression 5>
+* <argument list> ::= <argument list> , <expression 5>
+* <input set> ::= <empty>
+* <input set> ::= <set name> <-
+* <field list> ::= <field name>
+* <field list> ::= <field list> , <field name>
+* <input list> ::= <input item>
+* <input list> ::= <input list> , <input item>
+* <input item> ::= <parameter name>
+* <input item> ::= <parameter name> ~ <field name>
+*
+* <output table statement> ::=
+* table <table name> <alias> <domain> OUT <argument list> :
+* <output list> ;
+* <domain> ::= <indexing expression>
+* <output list> ::= <output item>
+* <output list> ::= <output list> , <output item>
+* <output item> ::= <expression 5>
+* <output item> ::= <expression 5> ~ <field name> */
+
+TABLE *table_statement(MPL *mpl)
+{ TABLE *tab;
+ TABARG *last_arg, *arg;
+ TABFLD *last_fld, *fld;
+ TABIN *last_in, *in;
+ TABOUT *last_out, *out;
+ AVLNODE *node;
+ int nflds;
+ char name[MAX_LENGTH+1];
+ xassert(is_keyword(mpl, "table"));
+ get_token(mpl /* solve */);
+ /* symbolic name must follow the keyword table */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "symbolic name missing where expected");
+ /* there must be no other object with the same name */
+ if (avl_find_node(mpl->tree, mpl->image) != NULL)
+ error(mpl, "%s multiply declared", mpl->image);
+ /* create data table */
+ tab = alloc(TABLE);
+ tab->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(tab->name, mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional alias */
+ if (mpl->token == T_STRING)
+ { tab->alias = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(tab->alias, mpl->image);
+ get_token(mpl /* <string literal> */);
+ }
+ else
+ tab->alias = NULL;
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { /* this is output table */
+ tab->type = A_OUTPUT;
+ tab->u.out.domain = indexing_expression(mpl);
+ if (!is_keyword(mpl, "OUT"))
+ error(mpl, "keyword OUT missing where expected");
+ get_token(mpl /* OUT */);
+ }
+ else
+ { /* this is input table */
+ tab->type = A_INPUT;
+ if (!is_keyword(mpl, "IN"))
+ error(mpl, "keyword IN missing where expected");
+ get_token(mpl /* IN */);
+ }
+ /* parse argument list */
+ tab->arg = last_arg = NULL;
+ for (;;)
+ { /* create argument list entry */
+ arg = alloc(TABARG);
+ /* parse argument expression */
+ if (mpl->token == T_COMMA || mpl->token == T_COLON ||
+ mpl->token == T_SEMICOLON)
+ error(mpl, "argument expression missing where expected");
+ arg->code = expression_5(mpl);
+ /* convert the result to symbolic type, if necessary */
+ if (arg->code->type == A_NUMERIC)
+ arg->code =
+ make_unary(mpl, O_CVTSYM, arg->code, A_SYMBOLIC, 0);
+ /* check that now the result is of symbolic type */
+ if (arg->code->type != A_SYMBOLIC)
+ error(mpl, "argument expression has invalid type");
+ /* add the entry to the end of the list */
+ arg->next = NULL;
+ if (last_arg == NULL)
+ tab->arg = arg;
+ else
+ last_arg->next = arg;
+ last_arg = arg;
+ /* argument expression has been parsed */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_COLON || mpl->token == T_SEMICOLON)
+ break;
+ }
+ xassert(tab->arg != NULL);
+ /* argument list must end with colon */
+ if (mpl->token == T_COLON)
+ get_token(mpl /* : */);
+ else
+ error(mpl, "colon missing where expected");
+ /* parse specific part of the table statement */
+ switch (tab->type)
+ { case A_INPUT: goto input_table;
+ case A_OUTPUT: goto output_table;
+ default: xassert(tab != tab);
+ }
+input_table:
+ /* parse optional set name */
+ if (mpl->token == T_NAME)
+ { node = avl_find_node(mpl->tree, mpl->image);
+ if (node == NULL)
+ error(mpl, "%s not defined", mpl->image);
+ if (avl_get_node_type(node) != A_SET)
+ error(mpl, "%s not a set", mpl->image);
+ tab->u.in.set = (SET *)avl_get_node_link(node);
+ if (tab->u.in.set->assign != NULL)
+ error(mpl, "%s needs no data", mpl->image);
+ if (tab->u.in.set->dim != 0)
+ error(mpl, "%s must be a simple set", mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ if (mpl->token == T_INPUT)
+ get_token(mpl /* <- */);
+ else
+ error(mpl, "delimiter <- missing where expected");
+ }
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ tab->u.in.set = NULL;
+ /* parse field list */
+ tab->u.in.fld = last_fld = NULL;
+ nflds = 0;
+ if (mpl->token == T_LBRACKET)
+ get_token(mpl /* [ */);
+ else
+ error(mpl, "field list missing where expected");
+ for (;;)
+ { /* create field list entry */
+ fld = alloc(TABFLD);
+ /* parse field name */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl,
+ "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "field name missing where expected");
+ fld->name = dmp_get_atomv(mpl->pool, strlen(mpl->image)+1);
+ strcpy(fld->name, mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ /* add the entry to the end of the list */
+ fld->next = NULL;
+ if (last_fld == NULL)
+ tab->u.in.fld = fld;
+ else
+ last_fld->next = fld;
+ last_fld = fld;
+ nflds++;
+ /* field name has been parsed */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RBRACKET)
+ break;
+ else
+ error(mpl, "syntax error in field list");
+ }
+ /* check that the set dimen is equal to the number of fields */
+ if (tab->u.in.set != NULL && tab->u.in.set->dimen != nflds)
+ error(mpl, "there must be %d field%s rather than %d",
+ tab->u.in.set->dimen, tab->u.in.set->dimen == 1 ? "" : "s",
+ nflds);
+ get_token(mpl /* ] */);
+ /* parse optional input list */
+ tab->u.in.list = last_in = NULL;
+ while (mpl->token == T_COMMA)
+ { get_token(mpl /* , */);
+ /* create input list entry */
+ in = alloc(TABIN);
+ /* parse parameter name */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl,
+ "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "parameter name missing where expected");
+ node = avl_find_node(mpl->tree, mpl->image);
+ if (node == NULL)
+ error(mpl, "%s not defined", mpl->image);
+ if (avl_get_node_type(node) != A_PARAMETER)
+ error(mpl, "%s not a parameter", mpl->image);
+ in->par = (PARAMETER *)avl_get_node_link(node);
+ if (in->par->dim != nflds)
+ error(mpl, "%s must have %d subscript%s rather than %d",
+ mpl->image, nflds, nflds == 1 ? "" : "s", in->par->dim);
+ if (in->par->assign != NULL)
+ error(mpl, "%s needs no data", mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ /* parse optional field name */
+ if (mpl->token == T_TILDE)
+ { get_token(mpl /* ~ */);
+ /* parse field name */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl,
+ "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "field name missing where expected");
+ xassert(strlen(mpl->image) < sizeof(name));
+ strcpy(name, mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ }
+ else
+ { /* field name is the same as the parameter name */
+ xassert(strlen(in->par->name) < sizeof(name));
+ strcpy(name, in->par->name);
+ }
+ /* assign field name */
+ in->name = dmp_get_atomv(mpl->pool, strlen(name)+1);
+ strcpy(in->name, name);
+ /* add the entry to the end of the list */
+ in->next = NULL;
+ if (last_in == NULL)
+ tab->u.in.list = in;
+ else
+ last_in->next = in;
+ last_in = in;
+ }
+ goto end_of_table;
+output_table:
+ /* parse output list */
+ tab->u.out.list = last_out = NULL;
+ for (;;)
+ { /* create output list entry */
+ out = alloc(TABOUT);
+ /* parse expression */
+ if (mpl->token == T_COMMA || mpl->token == T_SEMICOLON)
+ error(mpl, "expression missing where expected");
+ if (mpl->token == T_NAME)
+ { xassert(strlen(mpl->image) < sizeof(name));
+ strcpy(name, mpl->image);
+ }
+ else
+ name[0] = '\0';
+ out->code = expression_5(mpl);
+ /* parse optional field name */
+ if (mpl->token == T_TILDE)
+ { get_token(mpl /* ~ */);
+ /* parse field name */
+ if (mpl->token == T_NAME)
+ ;
+ else if (is_reserved(mpl))
+ error(mpl,
+ "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "field name missing where expected");
+ xassert(strlen(mpl->image) < sizeof(name));
+ strcpy(name, mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ }
+ /* assign field name */
+ if (name[0] == '\0')
+ error(mpl, "field name required");
+ out->name = dmp_get_atomv(mpl->pool, strlen(name)+1);
+ strcpy(out->name, name);
+ /* add the entry to the end of the list */
+ out->next = NULL;
+ if (last_out == NULL)
+ tab->u.out.list = out;
+ else
+ last_out->next = out;
+ last_out = out;
+ /* output item has been parsed */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_SEMICOLON)
+ break;
+ else
+ error(mpl, "syntax error in output list");
+ }
+ /* close the domain scope */
+ close_scope(mpl,tab->u.out.domain);
+end_of_table:
+ /* the table statement must end with semicolon */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in table statement");
+ get_token(mpl /* ; */);
+ return tab;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- solve_statement - parse solve statement.
+--
+-- This routine parses solve statement using the syntax:
+--
+-- <solve statement> ::= solve ;
+--
+-- The solve statement can be used at most once. */
+
+void *solve_statement(MPL *mpl)
+{ xassert(is_keyword(mpl, "solve"));
+ if (mpl->flag_s)
+ error(mpl, "at most one solve statement allowed");
+ mpl->flag_s = 1;
+ get_token(mpl /* solve */);
+ /* semicolon must follow solve statement */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in solve statement");
+ get_token(mpl /* ; */);
+ return NULL;
+}
+
+/*----------------------------------------------------------------------
+-- check_statement - parse check statement.
+--
+-- This routine parses check statement using the syntax:
+--
+-- <check statement> ::= check <domain> : <expression 13> ;
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+--
+-- If <domain> is omitted, colon following it may also be omitted. */
+
+CHECK *check_statement(MPL *mpl)
+{ CHECK *chk;
+ xassert(is_keyword(mpl, "check"));
+ /* create check descriptor */
+ chk = alloc(CHECK);
+ chk->domain = NULL;
+ chk->code = NULL;
+ get_token(mpl /* check */);
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { chk->domain = indexing_expression(mpl);
+#if 0
+ if (mpl->token != T_COLON)
+ error(mpl, "colon missing where expected");
+#endif
+ }
+ /* skip optional colon */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* parse logical expression */
+ chk->code = expression_13(mpl);
+ if (chk->code->type != A_LOGICAL)
+ error(mpl, "expression has invalid type");
+ xassert(chk->code->dim == 0);
+ /* close the domain scope */
+ if (chk->domain != NULL) close_scope(mpl, chk->domain);
+ /* the check statement has been completely parsed */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in check statement");
+ get_token(mpl /* ; */);
+ return chk;
+}
+
+#if 1 /* 15/V-2010 */
+/*----------------------------------------------------------------------
+-- display_statement - parse display statement.
+--
+-- This routine parses display statement using the syntax:
+--
+-- <display statement> ::= display <domain> : <display list> ;
+-- <display statement> ::= display <domain> <display list> ;
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <display list> ::= <display entry>
+-- <display list> ::= <display list> , <display entry>
+-- <display entry> ::= <dummy index>
+-- <display entry> ::= <set name>
+-- <display entry> ::= <set name> [ <subscript list> ]
+-- <display entry> ::= <parameter name>
+-- <display entry> ::= <parameter name> [ <subscript list> ]
+-- <display entry> ::= <variable name>
+-- <display entry> ::= <variable name> [ <subscript list> ]
+-- <display entry> ::= <constraint name>
+-- <display entry> ::= <constraint name> [ <subscript list> ]
+-- <display entry> ::= <expression 13> */
+
+DISPLAY *display_statement(MPL *mpl)
+{ DISPLAY *dpy;
+ DISPLAY1 *entry, *last_entry;
+ xassert(is_keyword(mpl, "display"));
+ /* create display descriptor */
+ dpy = alloc(DISPLAY);
+ dpy->domain = NULL;
+ dpy->list = last_entry = NULL;
+ get_token(mpl /* display */);
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ dpy->domain = indexing_expression(mpl);
+ /* skip optional colon */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* parse display list */
+ for (;;)
+ { /* create new display entry */
+ entry = alloc(DISPLAY1);
+ entry->type = 0;
+ entry->next = NULL;
+ /* and append it to the display list */
+ if (dpy->list == NULL)
+ dpy->list = entry;
+ else
+ last_entry->next = entry;
+ last_entry = entry;
+ /* parse display entry */
+ if (mpl->token == T_NAME)
+ { AVLNODE *node;
+ int next_token;
+ get_token(mpl /* <symbolic name> */);
+ next_token = mpl->token;
+ unget_token(mpl);
+ if (!(next_token == T_COMMA || next_token == T_SEMICOLON))
+ { /* symbolic name begins expression */
+ goto expr;
+ }
+ /* display entry is dummy index or model object */
+ node = avl_find_node(mpl->tree, mpl->image);
+ if (node == NULL)
+ error(mpl, "%s not defined", mpl->image);
+ entry->type = avl_get_node_type(node);
+ switch (avl_get_node_type(node))
+ { case A_INDEX:
+ entry->u.slot =
+ (DOMAIN_SLOT *)avl_get_node_link(node);
+ break;
+ case A_SET:
+ entry->u.set = (SET *)avl_get_node_link(node);
+ break;
+ case A_PARAMETER:
+ entry->u.par = (PARAMETER *)avl_get_node_link(node);
+ break;
+ case A_VARIABLE:
+ entry->u.var = (VARIABLE *)avl_get_node_link(node);
+ if (!mpl->flag_s)
+ error(mpl, "invalid reference to variable %s above"
+ " solve statement", entry->u.var->name);
+ break;
+ case A_CONSTRAINT:
+ entry->u.con = (CONSTRAINT *)avl_get_node_link(node);
+ if (!mpl->flag_s)
+ error(mpl, "invalid reference to %s %s above solve"
+ " statement",
+ entry->u.con->type == A_CONSTRAINT ?
+ "constraint" : "objective", entry->u.con->name);
+ break;
+ default:
+ xassert(node != node);
+ }
+ get_token(mpl /* <symbolic name> */);
+ }
+ else
+expr: { /* display entry is expression */
+ entry->type = A_EXPRESSION;
+ entry->u.code = expression_13(mpl);
+ }
+ /* check a token that follows the entry parsed */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else
+ break;
+ }
+ /* close the domain scope */
+ if (dpy->domain != NULL) close_scope(mpl, dpy->domain);
+ /* the display statement has been completely parsed */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in display statement");
+ get_token(mpl /* ; */);
+ return dpy;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- printf_statement - parse printf statement.
+--
+-- This routine parses print statement using the syntax:
+--
+-- <printf statement> ::= <printf clause> ;
+-- <printf statement> ::= <printf clause> > <file name> ;
+-- <printf statement> ::= <printf clause> >> <file name> ;
+-- <printf clause> ::= printf <domain> : <format> <printf list>
+-- <printf clause> ::= printf <domain> <format> <printf list>
+-- <domain> ::= <empty>
+-- <domain> ::= <indexing expression>
+-- <format> ::= <expression 5>
+-- <printf list> ::= <empty>
+-- <printf list> ::= <printf list> , <printf entry>
+-- <printf entry> ::= <expression 9>
+-- <file name> ::= <expression 5> */
+
+PRINTF *printf_statement(MPL *mpl)
+{ PRINTF *prt;
+ PRINTF1 *entry, *last_entry;
+ xassert(is_keyword(mpl, "printf"));
+ /* create printf descriptor */
+ prt = alloc(PRINTF);
+ prt->domain = NULL;
+ prt->fmt = NULL;
+ prt->list = last_entry = NULL;
+ get_token(mpl /* printf */);
+ /* parse optional indexing expression */
+ if (mpl->token == T_LBRACE)
+ { prt->domain = indexing_expression(mpl);
+#if 0
+ if (mpl->token != T_COLON)
+ error(mpl, "colon missing where expected");
+#endif
+ }
+ /* skip optional colon */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* parse expression for format string */
+ prt->fmt = expression_5(mpl);
+ /* convert it to symbolic type, if necessary */
+ if (prt->fmt->type == A_NUMERIC)
+ prt->fmt = make_unary(mpl, O_CVTSYM, prt->fmt, A_SYMBOLIC, 0);
+ /* check that now the expression is of symbolic type */
+ if (prt->fmt->type != A_SYMBOLIC)
+ error(mpl, "format expression has invalid type");
+ /* parse printf list */
+ while (mpl->token == T_COMMA)
+ { get_token(mpl /* , */);
+ /* create new printf entry */
+ entry = alloc(PRINTF1);
+ entry->code = NULL;
+ entry->next = NULL;
+ /* and append it to the printf list */
+ if (prt->list == NULL)
+ prt->list = entry;
+ else
+ last_entry->next = entry;
+ last_entry = entry;
+ /* parse printf entry */
+ entry->code = expression_9(mpl);
+ if (!(entry->code->type == A_NUMERIC ||
+ entry->code->type == A_SYMBOLIC ||
+ entry->code->type == A_LOGICAL))
+ error(mpl, "only numeric, symbolic, or logical expression a"
+ "llowed");
+ }
+ /* close the domain scope */
+ if (prt->domain != NULL) close_scope(mpl, prt->domain);
+#if 1 /* 14/VII-2006 */
+ /* parse optional redirection */
+ prt->fname = NULL, prt->app = 0;
+ if (mpl->token == T_GT || mpl->token == T_APPEND)
+ { prt->app = (mpl->token == T_APPEND);
+ get_token(mpl /* > or >> */);
+ /* parse expression for file name string */
+ prt->fname = expression_5(mpl);
+ /* convert it to symbolic type, if necessary */
+ if (prt->fname->type == A_NUMERIC)
+ prt->fname = make_unary(mpl, O_CVTSYM, prt->fname,
+ A_SYMBOLIC, 0);
+ /* check that now the expression is of symbolic type */
+ if (prt->fname->type != A_SYMBOLIC)
+ error(mpl, "file name expression has invalid type");
+ }
+#endif
+ /* the printf statement has been completely parsed */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "syntax error in printf statement");
+ get_token(mpl /* ; */);
+ return prt;
+}
+
+/*----------------------------------------------------------------------
+-- for_statement - parse for statement.
+--
+-- This routine parses for statement using the syntax:
+--
+-- <for statement> ::= for <domain> <statement>
+-- <for statement> ::= for <domain> { <statement list> }
+-- <domain> ::= <indexing expression>
+-- <statement list> ::= <empty>
+-- <statement list> ::= <statement list> <statement>
+-- <statement> ::= <check statement>
+-- <statement> ::= <display statement>
+-- <statement> ::= <printf statement>
+-- <statement> ::= <for statement> */
+
+FOR *for_statement(MPL *mpl)
+{ FOR *fur;
+ STATEMENT *stmt, *last_stmt;
+ xassert(is_keyword(mpl, "for"));
+ /* create for descriptor */
+ fur = alloc(FOR);
+ fur->domain = NULL;
+ fur->list = last_stmt = NULL;
+ get_token(mpl /* for */);
+ /* parse indexing expression */
+ if (mpl->token != T_LBRACE)
+ error(mpl, "indexing expression missing where expected");
+ fur->domain = indexing_expression(mpl);
+ /* skip optional colon */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* parse for statement body */
+ if (mpl->token != T_LBRACE)
+ { /* parse simple statement */
+ fur->list = simple_statement(mpl, 1);
+ }
+ else
+ { /* parse compound statement */
+ get_token(mpl /* { */);
+ while (mpl->token != T_RBRACE)
+ { /* parse statement */
+ stmt = simple_statement(mpl, 1);
+ /* and append it to the end of the statement list */
+ if (last_stmt == NULL)
+ fur->list = stmt;
+ else
+ last_stmt->next = stmt;
+ last_stmt = stmt;
+ }
+ get_token(mpl /* } */);
+ }
+ /* close the domain scope */
+ xassert(fur->domain != NULL);
+ close_scope(mpl, fur->domain);
+ /* the for statement has been completely parsed */
+ return fur;
+}
+
+/*----------------------------------------------------------------------
+-- end_statement - parse end statement.
+--
+-- This routine parses end statement using the syntax:
+--
+-- <end statement> ::= end ; <eof> */
+
+void end_statement(MPL *mpl)
+{ if (!mpl->flag_d && is_keyword(mpl, "end") ||
+ mpl->flag_d && is_literal(mpl, "end"))
+ { get_token(mpl /* end */);
+ if (mpl->token == T_SEMICOLON)
+ get_token(mpl /* ; */);
+ else
+ warning(mpl, "no semicolon following end statement; missing"
+ " semicolon inserted");
+ }
+ else
+ warning(mpl, "unexpected end of file; missing end statement in"
+ "serted");
+ if (mpl->token != T_EOF)
+ warning(mpl, "some text detected beyond end statement; text ig"
+ "nored");
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- simple_statement - parse simple statement.
+--
+-- This routine parses simple statement using the syntax:
+--
+-- <statement> ::= <set statement>
+-- <statement> ::= <parameter statement>
+-- <statement> ::= <variable statement>
+-- <statement> ::= <constraint statement>
+-- <statement> ::= <objective statement>
+-- <statement> ::= <solve statement>
+-- <statement> ::= <check statement>
+-- <statement> ::= <display statement>
+-- <statement> ::= <printf statement>
+-- <statement> ::= <for statement>
+--
+-- If the flag spec is set, some statements cannot be used. */
+
+STATEMENT *simple_statement(MPL *mpl, int spec)
+{ STATEMENT *stmt;
+ stmt = alloc(STATEMENT);
+ stmt->line = mpl->line;
+ stmt->next = NULL;
+ if (is_keyword(mpl, "set"))
+ { if (spec)
+ error(mpl, "set statement not allowed here");
+ stmt->type = A_SET;
+ stmt->u.set = set_statement(mpl);
+ }
+ else if (is_keyword(mpl, "param"))
+ { if (spec)
+ error(mpl, "parameter statement not allowed here");
+ stmt->type = A_PARAMETER;
+ stmt->u.par = parameter_statement(mpl);
+ }
+ else if (is_keyword(mpl, "var"))
+ { if (spec)
+ error(mpl, "variable statement not allowed here");
+ stmt->type = A_VARIABLE;
+ stmt->u.var = variable_statement(mpl);
+ }
+ else if (is_keyword(mpl, "subject") ||
+ is_keyword(mpl, "subj") ||
+ mpl->token == T_SPTP)
+ { if (spec)
+ error(mpl, "constraint statement not allowed here");
+ stmt->type = A_CONSTRAINT;
+ stmt->u.con = constraint_statement(mpl);
+ }
+ else if (is_keyword(mpl, "minimize") ||
+ is_keyword(mpl, "maximize"))
+ { if (spec)
+ error(mpl, "objective statement not allowed here");
+ stmt->type = A_CONSTRAINT;
+ stmt->u.con = objective_statement(mpl);
+ }
+#if 1 /* 11/II-2008 */
+ else if (is_keyword(mpl, "table"))
+ { if (spec)
+ error(mpl, "table statement not allowed here");
+ stmt->type = A_TABLE;
+ stmt->u.tab = table_statement(mpl);
+ }
+#endif
+ else if (is_keyword(mpl, "solve"))
+ { if (spec)
+ error(mpl, "solve statement not allowed here");
+ stmt->type = A_SOLVE;
+ stmt->u.slv = solve_statement(mpl);
+ }
+ else if (is_keyword(mpl, "check"))
+ { stmt->type = A_CHECK;
+ stmt->u.chk = check_statement(mpl);
+ }
+ else if (is_keyword(mpl, "display"))
+ { stmt->type = A_DISPLAY;
+ stmt->u.dpy = display_statement(mpl);
+ }
+ else if (is_keyword(mpl, "printf"))
+ { stmt->type = A_PRINTF;
+ stmt->u.prt = printf_statement(mpl);
+ }
+ else if (is_keyword(mpl, "for"))
+ { stmt->type = A_FOR;
+ stmt->u.fur = for_statement(mpl);
+ }
+ else if (mpl->token == T_NAME)
+ { if (spec)
+ error(mpl, "constraint statement not allowed here");
+ stmt->type = A_CONSTRAINT;
+ stmt->u.con = constraint_statement(mpl);
+ }
+ else if (is_reserved(mpl))
+ error(mpl, "invalid use of reserved keyword %s", mpl->image);
+ else
+ error(mpl, "syntax error in model section");
+ return stmt;
+}
+
+/*----------------------------------------------------------------------
+-- model_section - parse model section.
+--
+-- This routine parses model section using the syntax:
+--
+-- <model section> ::= <empty>
+-- <model section> ::= <model section> <statement>
+--
+-- Parsing model section is terminated by either the keyword 'data', or
+-- the keyword 'end', or the end of file. */
+
+void model_section(MPL *mpl)
+{ STATEMENT *stmt, *last_stmt;
+ xassert(mpl->model == NULL);
+ last_stmt = NULL;
+ while (!(mpl->token == T_EOF || is_keyword(mpl, "data") ||
+ is_keyword(mpl, "end")))
+ { /* parse statement */
+ stmt = simple_statement(mpl, 0);
+ /* and append it to the end of the statement list */
+ if (last_stmt == NULL)
+ mpl->model = stmt;
+ else
+ last_stmt->next = stmt;
+ last_stmt = stmt;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl2.c b/test/monniaux/glpk-4.65/src/mpl/mpl2.c
new file mode 100644
index 00000000..0f99528b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl2.c
@@ -0,0 +1,1202 @@
+/* mpl2.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+
+/**********************************************************************/
+/* * * PROCESSING DATA SECTION * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_slice - create slice.
+--
+-- This routine creates a slice, which initially has no components. */
+
+SLICE *create_slice(MPL *mpl)
+{ SLICE *slice;
+ xassert(mpl == mpl);
+ slice = NULL;
+ return slice;
+}
+
+/*----------------------------------------------------------------------
+-- expand_slice - append new component to slice.
+--
+-- This routine expands slice appending to it either a given symbol or
+-- null component, which becomes the last component of the slice. */
+
+SLICE *expand_slice
+( MPL *mpl,
+ SLICE *slice, /* destroyed */
+ SYMBOL *sym /* destroyed */
+)
+{ SLICE *tail, *temp;
+ /* create a new component */
+ tail = dmp_get_atom(mpl->tuples, sizeof(SLICE));
+ tail->sym = sym;
+ tail->next = NULL;
+ /* and append it to the component list */
+ if (slice == NULL)
+ slice = tail;
+ else
+ { for (temp = slice; temp->next != NULL; temp = temp->next);
+ temp->next = tail;
+ }
+ return slice;
+}
+
+/*----------------------------------------------------------------------
+-- slice_dimen - determine dimension of slice.
+--
+-- This routine returns dimension of slice, which is number of all its
+-- components including null ones. */
+
+int slice_dimen
+( MPL *mpl,
+ SLICE *slice /* not changed */
+)
+{ SLICE *temp;
+ int dim;
+ xassert(mpl == mpl);
+ dim = 0;
+ for (temp = slice; temp != NULL; temp = temp->next) dim++;
+ return dim;
+}
+
+/*----------------------------------------------------------------------
+-- slice_arity - determine arity of slice.
+--
+-- This routine returns arity of slice, i.e. number of null components
+-- (indicated by asterisks) in the slice. */
+
+int slice_arity
+( MPL *mpl,
+ SLICE *slice /* not changed */
+)
+{ SLICE *temp;
+ int arity;
+ xassert(mpl == mpl);
+ arity = 0;
+ for (temp = slice; temp != NULL; temp = temp->next)
+ if (temp->sym == NULL) arity++;
+ return arity;
+}
+
+/*----------------------------------------------------------------------
+-- fake_slice - create fake slice of all asterisks.
+--
+-- This routine creates a fake slice of given dimension, which contains
+-- asterisks in all components. Zero dimension is allowed. */
+
+SLICE *fake_slice(MPL *mpl, int dim)
+{ SLICE *slice;
+ slice = create_slice(mpl);
+ while (dim-- > 0) slice = expand_slice(mpl, slice, NULL);
+ return slice;
+}
+
+/*----------------------------------------------------------------------
+-- delete_slice - delete slice.
+--
+-- This routine deletes specified slice. */
+
+void delete_slice
+( MPL *mpl,
+ SLICE *slice /* destroyed */
+)
+{ SLICE *temp;
+ while (slice != NULL)
+ { temp = slice;
+ slice = temp->next;
+ if (temp->sym != NULL) delete_symbol(mpl, temp->sym);
+xassert(sizeof(SLICE) == sizeof(TUPLE));
+ dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- is_number - check if current token is number.
+--
+-- If the current token is a number, this routine returns non-zero.
+-- Otherwise zero is returned. */
+
+int is_number(MPL *mpl)
+{ return
+ mpl->token == T_NUMBER;
+}
+
+/*----------------------------------------------------------------------
+-- is_symbol - check if current token is symbol.
+--
+-- If the current token is suitable to be a symbol, the routine returns
+-- non-zero. Otherwise zero is returned. */
+
+int is_symbol(MPL *mpl)
+{ return
+ mpl->token == T_NUMBER ||
+ mpl->token == T_SYMBOL ||
+ mpl->token == T_STRING;
+}
+
+/*----------------------------------------------------------------------
+-- is_literal - check if current token is given symbolic literal.
+--
+-- If the current token is given symbolic literal, this routine returns
+-- non-zero. Otherwise zero is returned.
+--
+-- This routine is used on processing the data section in the same way
+-- as the routine is_keyword on processing the model section. */
+
+int is_literal(MPL *mpl, char *literal)
+{ return
+ is_symbol(mpl) && strcmp(mpl->image, literal) == 0;
+}
+
+/*----------------------------------------------------------------------
+-- read_number - read number.
+--
+-- This routine reads the current token, which must be a number, and
+-- returns its numeric value. */
+
+double read_number(MPL *mpl)
+{ double num;
+ xassert(is_number(mpl));
+ num = mpl->value;
+ get_token(mpl /* <number> */);
+ return num;
+}
+
+/*----------------------------------------------------------------------
+-- read_symbol - read symbol.
+--
+-- This routine reads the current token, which must be a symbol, and
+-- returns its symbolic value. */
+
+SYMBOL *read_symbol(MPL *mpl)
+{ SYMBOL *sym;
+ xassert(is_symbol(mpl));
+ if (is_number(mpl))
+ sym = create_symbol_num(mpl, mpl->value);
+ else
+ sym = create_symbol_str(mpl, create_string(mpl, mpl->image));
+ get_token(mpl /* <symbol> */);
+ return sym;
+}
+
+/*----------------------------------------------------------------------
+-- read_slice - read slice.
+--
+-- This routine reads slice using the syntax:
+--
+-- <slice> ::= [ <symbol list> ]
+-- <slice> ::= ( <symbol list> )
+-- <symbol list> ::= <symbol or star>
+-- <symbol list> ::= <symbol list> , <symbol or star>
+-- <symbol or star> ::= <symbol>
+-- <symbol or star> ::= *
+--
+-- The bracketed form of slice is used for members of multi-dimensional
+-- objects while the parenthesized form is used for elemental sets. */
+
+SLICE *read_slice
+( MPL *mpl,
+ char *name, /* not changed */
+ int dim
+)
+{ SLICE *slice;
+ int close;
+ xassert(name != NULL);
+ switch (mpl->token)
+ { case T_LBRACKET:
+ close = T_RBRACKET;
+ break;
+ case T_LEFT:
+ xassert(dim > 0);
+ close = T_RIGHT;
+ break;
+ default:
+ xassert(mpl != mpl);
+ }
+ if (dim == 0)
+ error(mpl, "%s cannot be subscripted", name);
+ get_token(mpl /* ( | [ */);
+ /* read slice components */
+ slice = create_slice(mpl);
+ for (;;)
+ { /* the current token must be a symbol or asterisk */
+ if (is_symbol(mpl))
+ slice = expand_slice(mpl, slice, read_symbol(mpl));
+ else if (mpl->token == T_ASTERISK)
+ { slice = expand_slice(mpl, slice, NULL);
+ get_token(mpl /* * */);
+ }
+ else
+ error(mpl, "number, symbol, or asterisk missing where expec"
+ "ted");
+ /* check a token that follows the symbol */
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == close)
+ break;
+ else
+ error(mpl, "syntax error in slice");
+ }
+ /* number of slice components must be the same as the appropriate
+ dimension */
+ if (slice_dimen(mpl, slice) != dim)
+ { switch (close)
+ { case T_RBRACKET:
+ error(mpl, "%s must have %d subscript%s, not %d", name,
+ dim, dim == 1 ? "" : "s", slice_dimen(mpl, slice));
+ break;
+ case T_RIGHT:
+ error(mpl, "%s has dimension %d, not %d", name, dim,
+ slice_dimen(mpl, slice));
+ break;
+ default:
+ xassert(close != close);
+ }
+ }
+ get_token(mpl /* ) | ] */);
+ return slice;
+}
+
+/*----------------------------------------------------------------------
+-- select_set - select set to saturate it with elemental sets.
+--
+-- This routine selects set to saturate it with elemental sets provided
+-- in the data section. */
+
+SET *select_set
+( MPL *mpl,
+ char *name /* not changed */
+)
+{ SET *set;
+ AVLNODE *node;
+ xassert(name != NULL);
+ node = avl_find_node(mpl->tree, name);
+ if (node == NULL || avl_get_node_type(node) != A_SET)
+ error(mpl, "%s not a set", name);
+ set = (SET *)avl_get_node_link(node);
+ if (set->assign != NULL || set->gadget != NULL)
+ error(mpl, "%s needs no data", name);
+ set->data = 1;
+ return set;
+}
+
+/*----------------------------------------------------------------------
+-- simple_format - read set data block in simple format.
+--
+-- This routine reads set data block using the syntax:
+--
+-- <simple format> ::= <symbol> , <symbol> , ... , <symbol>
+--
+-- where <symbols> are used to construct a complete n-tuple, which is
+-- included in elemental set assigned to the set member. Commae between
+-- symbols are optional and may be omitted anywhere.
+--
+-- Number of components in the slice must be the same as dimension of
+-- n-tuples in elemental sets assigned to the set members. To construct
+-- complete n-tuple the routine replaces null positions in the slice by
+-- corresponding <symbols>.
+--
+-- If the slice contains at least one null position, the current token
+-- must be symbol. Otherwise, the routine reads no symbols to construct
+-- the n-tuple, so the current token is not checked. */
+
+void simple_format
+( MPL *mpl,
+ SET *set, /* not changed */
+ MEMBER *memb, /* modified */
+ SLICE *slice /* not changed */
+)
+{ TUPLE *tuple;
+ SLICE *temp;
+ SYMBOL *sym, *with = NULL;
+ xassert(set != NULL);
+ xassert(memb != NULL);
+ xassert(slice != NULL);
+ xassert(set->dimen == slice_dimen(mpl, slice));
+ xassert(memb->value.set->dim == set->dimen);
+ if (slice_arity(mpl, slice) > 0) xassert(is_symbol(mpl));
+ /* read symbols and construct complete n-tuple */
+ tuple = create_tuple(mpl);
+ for (temp = slice; temp != NULL; temp = temp->next)
+ { if (temp->sym == NULL)
+ { /* substitution is needed; read symbol */
+ if (!is_symbol(mpl))
+ { int lack = slice_arity(mpl, temp);
+ /* with cannot be null due to assertion above */
+ xassert(with != NULL);
+ if (lack == 1)
+ error(mpl, "one item missing in data group beginning "
+ "with %s", format_symbol(mpl, with));
+ else
+ error(mpl, "%d items missing in data group beginning "
+ "with %s", lack, format_symbol(mpl, with));
+ }
+ sym = read_symbol(mpl);
+ if (with == NULL) with = sym;
+ }
+ else
+ { /* copy symbol from the slice */
+ sym = copy_symbol(mpl, temp->sym);
+ }
+ /* append the symbol to the n-tuple */
+ tuple = expand_tuple(mpl, tuple, sym);
+ /* skip optional comma *between* <symbols> */
+ if (temp->next != NULL && mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ }
+ /* add constructed n-tuple to elemental set */
+ check_then_add(mpl, memb->value.set, tuple);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- matrix_format - read set data block in matrix format.
+--
+-- This routine reads set data block using the syntax:
+--
+-- <matrix format> ::= <column> <column> ... <column> :=
+-- <row> +/- +/- ... +/-
+-- <row> +/- +/- ... +/-
+-- . . . . . . . . . . .
+-- <row> +/- +/- ... +/-
+--
+-- where <rows> are symbols that denote rows of the matrix, <columns>
+-- are symbols that denote columns of the matrix, "+" and "-" indicate
+-- whether corresponding n-tuple needs to be included in the elemental
+-- set or not, respectively.
+--
+-- Number of the slice components must be the same as dimension of the
+-- elemental set. The slice must have two null positions. To construct
+-- complete n-tuple for particular element of the matrix the routine
+-- replaces first null position of the slice by the corresponding <row>
+-- (or <column>, if the flag tr is on) and second null position by the
+-- corresponding <column> (or by <row>, if the flag tr is on). */
+
+void matrix_format
+( MPL *mpl,
+ SET *set, /* not changed */
+ MEMBER *memb, /* modified */
+ SLICE *slice, /* not changed */
+ int tr
+)
+{ SLICE *list, *col, *temp;
+ TUPLE *tuple;
+ SYMBOL *row;
+ xassert(set != NULL);
+ xassert(memb != NULL);
+ xassert(slice != NULL);
+ xassert(set->dimen == slice_dimen(mpl, slice));
+ xassert(memb->value.set->dim == set->dimen);
+ xassert(slice_arity(mpl, slice) == 2);
+ /* read the matrix heading that contains column symbols (there
+ may be no columns at all) */
+ list = create_slice(mpl);
+ while (mpl->token != T_ASSIGN)
+ { /* read column symbol and append it to the column list */
+ if (!is_symbol(mpl))
+ error(mpl, "number, symbol, or := missing where expected");
+ list = expand_slice(mpl, list, read_symbol(mpl));
+ }
+ get_token(mpl /* := */);
+ /* read zero or more rows that contain matrix data */
+ while (is_symbol(mpl))
+ { /* read row symbol (if the matrix has no columns, row symbols
+ are just ignored) */
+ row = read_symbol(mpl);
+ /* read the matrix row accordingly to the column list */
+ for (col = list; col != NULL; col = col->next)
+ { int which = 0;
+ /* check indicator */
+ if (is_literal(mpl, "+"))
+ ;
+ else if (is_literal(mpl, "-"))
+ { get_token(mpl /* - */);
+ continue;
+ }
+ else
+ { int lack = slice_dimen(mpl, col);
+ if (lack == 1)
+ error(mpl, "one item missing in data group beginning "
+ "with %s", format_symbol(mpl, row));
+ else
+ error(mpl, "%d items missing in data group beginning "
+ "with %s", lack, format_symbol(mpl, row));
+ }
+ /* construct complete n-tuple */
+ tuple = create_tuple(mpl);
+ for (temp = slice; temp != NULL; temp = temp->next)
+ { if (temp->sym == NULL)
+ { /* substitution is needed */
+ switch (++which)
+ { case 1:
+ /* substitute in the first null position */
+ tuple = expand_tuple(mpl, tuple,
+ copy_symbol(mpl, tr ? col->sym : row));
+ break;
+ case 2:
+ /* substitute in the second null position */
+ tuple = expand_tuple(mpl, tuple,
+ copy_symbol(mpl, tr ? row : col->sym));
+ break;
+ default:
+ xassert(which != which);
+ }
+ }
+ else
+ { /* copy symbol from the slice */
+ tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
+ temp->sym));
+ }
+ }
+ xassert(which == 2);
+ /* add constructed n-tuple to elemental set */
+ check_then_add(mpl, memb->value.set, tuple);
+ get_token(mpl /* + */);
+ }
+ /* delete the row symbol */
+ delete_symbol(mpl, row);
+ }
+ /* delete the column list */
+ delete_slice(mpl, list);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- set_data - read set data.
+--
+-- This routine reads set data using the syntax:
+--
+-- <set data> ::= set <set name> <assignments> ;
+-- <set data> ::= set <set name> [ <symbol list> ] <assignments> ;
+-- <set name> ::= <symbolic name>
+-- <assignments> ::= <empty>
+-- <assignments> ::= <assignments> , :=
+-- <assignments> ::= <assignments> , ( <symbol list> )
+-- <assignments> ::= <assignments> , <simple format>
+-- <assignments> ::= <assignments> , : <matrix format>
+-- <assignments> ::= <assignments> , (tr) <matrix format>
+-- <assignments> ::= <assignments> , (tr) : <matrix format>
+--
+-- Commae in <assignments> are optional and may be omitted anywhere. */
+
+void set_data(MPL *mpl)
+{ SET *set;
+ TUPLE *tuple;
+ MEMBER *memb;
+ SLICE *slice;
+ int tr = 0;
+ xassert(is_literal(mpl, "set"));
+ get_token(mpl /* set */);
+ /* symbolic name of set must follows the keyword 'set' */
+ if (!is_symbol(mpl))
+ error(mpl, "set name missing where expected");
+ /* select the set to saturate it with data */
+ set = select_set(mpl, mpl->image);
+ get_token(mpl /* <symbolic name> */);
+ /* read optional subscript list, which identifies member of the
+ set to be read */
+ tuple = create_tuple(mpl);
+ if (mpl->token == T_LBRACKET)
+ { /* subscript list is specified */
+ if (set->dim == 0)
+ error(mpl, "%s cannot be subscripted", set->name);
+ get_token(mpl /* [ */);
+ /* read symbols and construct subscript list */
+ for (;;)
+ { if (!is_symbol(mpl))
+ error(mpl, "number or symbol missing where expected");
+ tuple = expand_tuple(mpl, tuple, read_symbol(mpl));
+ if (mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ else if (mpl->token == T_RBRACKET)
+ break;
+ else
+ error(mpl, "syntax error in subscript list");
+ }
+ if (set->dim != tuple_dimen(mpl, tuple))
+ error(mpl, "%s must have %d subscript%s rather than %d",
+ set->name, set->dim, set->dim == 1 ? "" : "s",
+ tuple_dimen(mpl, tuple));
+ get_token(mpl /* ] */);
+ }
+ else
+ { /* subscript list is not specified */
+ if (set->dim != 0)
+ error(mpl, "%s must be subscripted", set->name);
+ }
+ /* there must be no member with the same subscript list */
+ if (find_member(mpl, set->array, tuple) != NULL)
+ error(mpl, "%s%s already defined",
+ set->name, format_tuple(mpl, '[', tuple));
+ /* add new member to the set and assign it empty elemental set */
+ memb = add_member(mpl, set->array, tuple);
+ memb->value.set = create_elemset(mpl, set->dimen);
+ /* create an initial fake slice of all asterisks */
+ slice = fake_slice(mpl, set->dimen);
+ /* read zero or more data assignments */
+ for (;;)
+ { /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ /* process assignment element */
+ if (mpl->token == T_ASSIGN)
+ { /* assignment ligature is non-significant element */
+ get_token(mpl /* := */);
+ }
+ else if (mpl->token == T_LEFT)
+ { /* left parenthesis begins either new slice or "transpose"
+ indicator */
+ int is_tr;
+ get_token(mpl /* ( */);
+ is_tr = is_literal(mpl, "tr");
+ unget_token(mpl /* ( */);
+ if (is_tr) goto left;
+ /* delete the current slice and read new one */
+ delete_slice(mpl, slice);
+ slice = read_slice(mpl, set->name, set->dimen);
+ /* each new slice resets the "transpose" indicator */
+ tr = 0;
+ /* if the new slice is 0-ary, formally there is one 0-tuple
+ (in the simple format) that follows it */
+ if (slice_arity(mpl, slice) == 0)
+ simple_format(mpl, set, memb, slice);
+ }
+ else if (is_symbol(mpl))
+ { /* number or symbol begins data in the simple format */
+ simple_format(mpl, set, memb, slice);
+ }
+ else if (mpl->token == T_COLON)
+ { /* colon begins data in the matrix format */
+ if (slice_arity(mpl, slice) != 2)
+err1: error(mpl, "slice currently used must specify 2 asterisk"
+ "s, not %d", slice_arity(mpl, slice));
+ get_token(mpl /* : */);
+ /* read elemental set data in the matrix format */
+ matrix_format(mpl, set, memb, slice, tr);
+ }
+ else if (mpl->token == T_LEFT)
+left: { /* left parenthesis begins the "transpose" indicator, which
+ is followed by data in the matrix format */
+ get_token(mpl /* ( */);
+ if (!is_literal(mpl, "tr"))
+err2: error(mpl, "transpose indicator (tr) incomplete");
+ if (slice_arity(mpl, slice) != 2) goto err1;
+ get_token(mpl /* tr */);
+ if (mpl->token != T_RIGHT) goto err2;
+ get_token(mpl /* ) */);
+ /* in this case the colon is optional */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* set the "transpose" indicator */
+ tr = 1;
+ /* read elemental set data in the matrix format */
+ matrix_format(mpl, set, memb, slice, tr);
+ }
+ else if (mpl->token == T_SEMICOLON)
+ { /* semicolon terminates the data block */
+ get_token(mpl /* ; */);
+ break;
+ }
+ else
+ error(mpl, "syntax error in set data block");
+ }
+ /* delete the current slice */
+ delete_slice(mpl, slice);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- select_parameter - select parameter to saturate it with data.
+--
+-- This routine selects parameter to saturate it with data provided in
+-- the data section. */
+
+PARAMETER *select_parameter
+( MPL *mpl,
+ char *name /* not changed */
+)
+{ PARAMETER *par;
+ AVLNODE *node;
+ xassert(name != NULL);
+ node = avl_find_node(mpl->tree, name);
+ if (node == NULL || avl_get_node_type(node) != A_PARAMETER)
+ error(mpl, "%s not a parameter", name);
+ par = (PARAMETER *)avl_get_node_link(node);
+ if (par->assign != NULL)
+ error(mpl, "%s needs no data", name);
+ if (par->data)
+ error(mpl, "%s already provided with data", name);
+ par->data = 1;
+ return par;
+}
+
+/*----------------------------------------------------------------------
+-- set_default - set default parameter value.
+--
+-- This routine sets default value for specified parameter. */
+
+void set_default
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SYMBOL *altval /* destroyed */
+)
+{ xassert(par != NULL);
+ xassert(altval != NULL);
+ if (par->option != NULL)
+ error(mpl, "default value for %s already specified in model se"
+ "ction", par->name);
+ xassert(par->defval == NULL);
+ par->defval = altval;
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- read_value - read value and assign it to parameter member.
+--
+-- This routine reads numeric or symbolic value from the input stream
+-- and assigns to new parameter member specified by its n-tuple, which
+-- (the member) is created and added to the parameter array. */
+
+MEMBER *read_value
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* destroyed */
+)
+{ MEMBER *memb;
+ xassert(par != NULL);
+ xassert(is_symbol(mpl));
+ /* there must be no member with the same n-tuple */
+ if (find_member(mpl, par->array, tuple) != NULL)
+ error(mpl, "%s%s already defined",
+ par->name, format_tuple(mpl, '[', tuple));
+ /* create new parameter member with given n-tuple */
+ memb = add_member(mpl, par->array, tuple);
+ /* read value and assigns it to the new parameter member */
+ switch (par->type)
+ { case A_NUMERIC:
+ case A_INTEGER:
+ case A_BINARY:
+ if (!is_number(mpl))
+ error(mpl, "%s requires numeric data", par->name);
+ memb->value.num = read_number(mpl);
+ break;
+ case A_SYMBOLIC:
+ memb->value.sym = read_symbol(mpl);
+ break;
+ default:
+ xassert(par != par);
+ }
+ return memb;
+}
+
+/*----------------------------------------------------------------------
+-- plain_format - read parameter data block in plain format.
+--
+-- This routine reads parameter data block using the syntax:
+--
+-- <plain format> ::= <symbol> , <symbol> , ... , <symbol> , <value>
+--
+-- where <symbols> are used to determine a complete subscript list for
+-- parameter member, <value> is a numeric or symbolic value assigned to
+-- the parameter member. Commae between data items are optional and may
+-- be omitted anywhere.
+--
+-- Number of components in the slice must be the same as dimension of
+-- the parameter. To construct the complete subscript list the routine
+-- replaces null positions in the slice by corresponding <symbols>. */
+
+void plain_format
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SLICE *slice /* not changed */
+)
+{ TUPLE *tuple;
+ SLICE *temp;
+ SYMBOL *sym, *with = NULL;
+ xassert(par != NULL);
+ xassert(par->dim == slice_dimen(mpl, slice));
+ xassert(is_symbol(mpl));
+ /* read symbols and construct complete subscript list */
+ tuple = create_tuple(mpl);
+ for (temp = slice; temp != NULL; temp = temp->next)
+ { if (temp->sym == NULL)
+ { /* substitution is needed; read symbol */
+ if (!is_symbol(mpl))
+ { int lack = slice_arity(mpl, temp) + 1;
+ xassert(with != NULL);
+ xassert(lack > 1);
+ error(mpl, "%d items missing in data group beginning wit"
+ "h %s", lack, format_symbol(mpl, with));
+ }
+ sym = read_symbol(mpl);
+ if (with == NULL) with = sym;
+ }
+ else
+ { /* copy symbol from the slice */
+ sym = copy_symbol(mpl, temp->sym);
+ }
+ /* append the symbol to the subscript list */
+ tuple = expand_tuple(mpl, tuple, sym);
+ /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ }
+ /* read value and assign it to new parameter member */
+ if (!is_symbol(mpl))
+ { xassert(with != NULL);
+ error(mpl, "one item missing in data group beginning with %s",
+ format_symbol(mpl, with));
+ }
+ read_value(mpl, par, tuple);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- tabular_format - read parameter data block in tabular format.
+--
+-- This routine reads parameter data block using the syntax:
+--
+-- <tabular format> ::= <column> <column> ... <column> :=
+-- <row> <value> <value> ... <value>
+-- <row> <value> <value> ... <value>
+-- . . . . . . . . . . .
+-- <row> <value> <value> ... <value>
+--
+-- where <rows> are symbols that denote rows of the table, <columns>
+-- are symbols that denote columns of the table, <values> are numeric
+-- or symbolic values assigned to the corresponding parameter members.
+-- If <value> is specified as single point, no value is provided.
+--
+-- Number of components in the slice must be the same as dimension of
+-- the parameter. The slice must have two null positions. To construct
+-- complete subscript list for particular <value> the routine replaces
+-- the first null position of the slice by the corresponding <row> (or
+-- <column>, if the flag tr is on) and the second null position by the
+-- corresponding <column> (or by <row>, if the flag tr is on). */
+
+void tabular_format
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ SLICE *slice, /* not changed */
+ int tr
+)
+{ SLICE *list, *col, *temp;
+ TUPLE *tuple;
+ SYMBOL *row;
+ xassert(par != NULL);
+ xassert(par->dim == slice_dimen(mpl, slice));
+ xassert(slice_arity(mpl, slice) == 2);
+ /* read the table heading that contains column symbols (the table
+ may have no columns) */
+ list = create_slice(mpl);
+ while (mpl->token != T_ASSIGN)
+ { /* read column symbol and append it to the column list */
+ if (!is_symbol(mpl))
+ error(mpl, "number, symbol, or := missing where expected");
+ list = expand_slice(mpl, list, read_symbol(mpl));
+ }
+ get_token(mpl /* := */);
+ /* read zero or more rows that contain tabular data */
+ while (is_symbol(mpl))
+ { /* read row symbol (if the table has no columns, these symbols
+ are just ignored) */
+ row = read_symbol(mpl);
+ /* read values accordingly to the column list */
+ for (col = list; col != NULL; col = col->next)
+ { int which = 0;
+ /* if the token is single point, no value is provided */
+ if (is_literal(mpl, "."))
+ { get_token(mpl /* . */);
+ continue;
+ }
+ /* construct complete subscript list */
+ tuple = create_tuple(mpl);
+ for (temp = slice; temp != NULL; temp = temp->next)
+ { if (temp->sym == NULL)
+ { /* substitution is needed */
+ switch (++which)
+ { case 1:
+ /* substitute in the first null position */
+ tuple = expand_tuple(mpl, tuple,
+ copy_symbol(mpl, tr ? col->sym : row));
+ break;
+ case 2:
+ /* substitute in the second null position */
+ tuple = expand_tuple(mpl, tuple,
+ copy_symbol(mpl, tr ? row : col->sym));
+ break;
+ default:
+ xassert(which != which);
+ }
+ }
+ else
+ { /* copy symbol from the slice */
+ tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
+ temp->sym));
+ }
+ }
+ xassert(which == 2);
+ /* read value and assign it to new parameter member */
+ if (!is_symbol(mpl))
+ { int lack = slice_dimen(mpl, col);
+ if (lack == 1)
+ error(mpl, "one item missing in data group beginning "
+ "with %s", format_symbol(mpl, row));
+ else
+ error(mpl, "%d items missing in data group beginning "
+ "with %s", lack, format_symbol(mpl, row));
+ }
+ read_value(mpl, par, tuple);
+ }
+ /* delete the row symbol */
+ delete_symbol(mpl, row);
+ }
+ /* delete the column list */
+ delete_slice(mpl, list);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- tabbing_format - read parameter data block in tabbing format.
+--
+-- This routine reads parameter data block using the syntax:
+--
+-- <tabbing format> ::= <prefix> <name> , ... , <name> , := ,
+-- <symbol> , ... , <symbol> , <value> , ... , <value> ,
+-- <symbol> , ... , <symbol> , <value> , ... , <value> ,
+-- . . . . . . . . . . . . . . . . .
+-- <symbol> , ... , <symbol> , <value> , ... , <value>
+-- <prefix> ::= <empty>
+-- <prefix> ::= <set name> :
+--
+-- where <names> are names of parameters (all the parameters must be
+-- subscripted and have identical dimensions), <symbols> are symbols
+-- used to define subscripts of parameter members, <values> are numeric
+-- or symbolic values assigned to the corresponding parameter members.
+-- Optional <prefix> may specify a simple set, in which case n-tuples
+-- built of <symbols> for each row of the data table (i.e. subscripts
+-- of parameter members) are added to the specified set. Commae between
+-- data items are optional and may be omitted anywhere.
+--
+-- If the parameter altval is not NULL, it specifies a default value
+-- provided for all the parameters specified in the data block. */
+
+void tabbing_format
+( MPL *mpl,
+ SYMBOL *altval /* not changed */
+)
+{ SET *set = NULL;
+ PARAMETER *par;
+ SLICE *list, *col;
+ TUPLE *tuple;
+ int next_token, j, dim = 0;
+ char *last_name = NULL;
+ /* read the optional <prefix> */
+ if (is_symbol(mpl))
+ { get_token(mpl /* <symbol> */);
+ next_token = mpl->token;
+ unget_token(mpl /* <symbol> */);
+ if (next_token == T_COLON)
+ { /* select the set to saturate it with data */
+ set = select_set(mpl, mpl->image);
+ /* the set must be simple (i.e. not set of sets) */
+ if (set->dim != 0)
+ error(mpl, "%s must be a simple set", set->name);
+ /* and must not be defined yet */
+ if (set->array->head != NULL)
+ error(mpl, "%s already defined", set->name);
+ /* add new (the only) member to the set and assign it empty
+ elemental set */
+ add_member(mpl, set->array, NULL)->value.set =
+ create_elemset(mpl, set->dimen);
+ last_name = set->name, dim = set->dimen;
+ get_token(mpl /* <symbol> */);
+ xassert(mpl->token == T_COLON);
+ get_token(mpl /* : */);
+ }
+ }
+ /* read the table heading that contains parameter names */
+ list = create_slice(mpl);
+ while (mpl->token != T_ASSIGN)
+ { /* there must be symbolic name of parameter */
+ if (!is_symbol(mpl))
+ error(mpl, "parameter name or := missing where expected");
+ /* select the parameter to saturate it with data */
+ par = select_parameter(mpl, mpl->image);
+ /* the parameter must be subscripted */
+ if (par->dim == 0)
+ error(mpl, "%s not a subscripted parameter", mpl->image);
+ /* the set (if specified) and all the parameters in the data
+ block must have identical dimension */
+ if (dim != 0 && par->dim != dim)
+ { xassert(last_name != NULL);
+ error(mpl, "%s has dimension %d while %s has dimension %d",
+ last_name, dim, par->name, par->dim);
+ }
+ /* set default value for the parameter (if specified) */
+ if (altval != NULL)
+ set_default(mpl, par, copy_symbol(mpl, altval));
+ /* append the parameter to the column list */
+ list = expand_slice(mpl, list, (SYMBOL *)par);
+ last_name = par->name, dim = par->dim;
+ get_token(mpl /* <symbol> */);
+ /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ }
+ if (slice_dimen(mpl, list) == 0)
+ error(mpl, "at least one parameter name required");
+ get_token(mpl /* := */);
+ /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ /* read rows that contain tabbing data */
+ while (is_symbol(mpl))
+ { /* read subscript list */
+ tuple = create_tuple(mpl);
+ for (j = 1; j <= dim; j++)
+ { /* read j-th subscript */
+ if (!is_symbol(mpl))
+ { int lack = slice_dimen(mpl, list) + dim - j + 1;
+ xassert(tuple != NULL);
+ xassert(lack > 1);
+ error(mpl, "%d items missing in data group beginning wit"
+ "h %s", lack, format_symbol(mpl, tuple->sym));
+ }
+ /* read and append j-th subscript to the n-tuple */
+ tuple = expand_tuple(mpl, tuple, read_symbol(mpl));
+ /* skip optional comma *between* <symbols> */
+ if (j < dim && mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ }
+ /* if the set is specified, add to it new n-tuple, which is a
+ copy of the subscript list just read */
+ if (set != NULL)
+ check_then_add(mpl, set->array->head->value.set,
+ copy_tuple(mpl, tuple));
+ /* skip optional comma between <symbol> and <value> */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ /* read values accordingly to the column list */
+ for (col = list; col != NULL; col = col->next)
+ { /* if the token is single point, no value is provided */
+ if (is_literal(mpl, "."))
+ { get_token(mpl /* . */);
+ continue;
+ }
+ /* read value and assign it to new parameter member */
+ if (!is_symbol(mpl))
+ { int lack = slice_dimen(mpl, col);
+ xassert(tuple != NULL);
+ if (lack == 1)
+ error(mpl, "one item missing in data group beginning "
+ "with %s", format_symbol(mpl, tuple->sym));
+ else
+ error(mpl, "%d items missing in data group beginning "
+ "with %s", lack, format_symbol(mpl, tuple->sym));
+ }
+ read_value(mpl, (PARAMETER *)col->sym, copy_tuple(mpl,
+ tuple));
+ /* skip optional comma preceding the next value */
+ if (col->next != NULL && mpl->token == T_COMMA)
+ get_token(mpl /* , */);
+ }
+ /* delete the original subscript list */
+ delete_tuple(mpl, tuple);
+ /* skip optional comma (only if there is next data group) */
+ if (mpl->token == T_COMMA)
+ { get_token(mpl /* , */);
+ if (!is_symbol(mpl)) unget_token(mpl /* , */);
+ }
+ }
+ /* delete the column list (it contains parameters, not symbols,
+ so nullify it before) */
+ for (col = list; col != NULL; col = col->next) col->sym = NULL;
+ delete_slice(mpl, list);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- parameter_data - read parameter data.
+--
+-- This routine reads parameter data using the syntax:
+--
+-- <parameter data> ::= param <default value> : <tabbing format> ;
+-- <parameter data> ::= param <parameter name> <default value>
+-- <assignments> ;
+-- <parameter name> ::= <symbolic name>
+-- <default value> ::= <empty>
+-- <default value> ::= default <symbol>
+-- <assignments> ::= <empty>
+-- <assignments> ::= <assignments> , :=
+-- <assignments> ::= <assignments> , [ <symbol list> ]
+-- <assignments> ::= <assignments> , <plain format>
+-- <assignemnts> ::= <assignments> , : <tabular format>
+-- <assignments> ::= <assignments> , (tr) <tabular format>
+-- <assignments> ::= <assignments> , (tr) : <tabular format>
+--
+-- Commae in <assignments> are optional and may be omitted anywhere. */
+
+void parameter_data(MPL *mpl)
+{ PARAMETER *par;
+ SYMBOL *altval = NULL;
+ SLICE *slice;
+ int tr = 0;
+ xassert(is_literal(mpl, "param"));
+ get_token(mpl /* param */);
+ /* read optional default value */
+ if (is_literal(mpl, "default"))
+ { get_token(mpl /* default */);
+ if (!is_symbol(mpl))
+ error(mpl, "default value missing where expected");
+ altval = read_symbol(mpl);
+ /* if the default value follows the keyword 'param', the next
+ token must be only the colon */
+ if (mpl->token != T_COLON)
+ error(mpl, "colon missing where expected");
+ }
+ /* being used after the keyword 'param' or the optional default
+ value the colon begins data in the tabbing format */
+ if (mpl->token == T_COLON)
+ { get_token(mpl /* : */);
+ /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ /* read parameter data in the tabbing format */
+ tabbing_format(mpl, altval);
+ /* on reading data in the tabbing format the default value is
+ always copied, so delete the original symbol */
+ if (altval != NULL) delete_symbol(mpl, altval);
+ /* the next token must be only semicolon */
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "symbol, number, or semicolon missing where expe"
+ "cted");
+ get_token(mpl /* ; */);
+ goto done;
+ }
+ /* in other cases there must be symbolic name of parameter, which
+ follows the keyword 'param' */
+ if (!is_symbol(mpl))
+ error(mpl, "parameter name missing where expected");
+ /* select the parameter to saturate it with data */
+ par = select_parameter(mpl, mpl->image);
+ get_token(mpl /* <symbol> */);
+ /* read optional default value */
+ if (is_literal(mpl, "default"))
+ { get_token(mpl /* default */);
+ if (!is_symbol(mpl))
+ error(mpl, "default value missing where expected");
+ altval = read_symbol(mpl);
+ /* set default value for the parameter */
+ set_default(mpl, par, altval);
+ }
+ /* create initial fake slice of all asterisks */
+ slice = fake_slice(mpl, par->dim);
+ /* read zero or more data assignments */
+ for (;;)
+ { /* skip optional comma */
+ if (mpl->token == T_COMMA) get_token(mpl /* , */);
+ /* process current assignment */
+ if (mpl->token == T_ASSIGN)
+ { /* assignment ligature is non-significant element */
+ get_token(mpl /* := */);
+ }
+ else if (mpl->token == T_LBRACKET)
+ { /* left bracket begins new slice; delete the current slice
+ and read new one */
+ delete_slice(mpl, slice);
+ slice = read_slice(mpl, par->name, par->dim);
+ /* each new slice resets the "transpose" indicator */
+ tr = 0;
+ }
+ else if (is_symbol(mpl))
+ { /* number or symbol begins data in the plain format */
+ plain_format(mpl, par, slice);
+ }
+ else if (mpl->token == T_COLON)
+ { /* colon begins data in the tabular format */
+ if (par->dim == 0)
+err1: error(mpl, "%s not a subscripted parameter",
+ par->name);
+ if (slice_arity(mpl, slice) != 2)
+err2: error(mpl, "slice currently used must specify 2 asterisk"
+ "s, not %d", slice_arity(mpl, slice));
+ get_token(mpl /* : */);
+ /* read parameter data in the tabular format */
+ tabular_format(mpl, par, slice, tr);
+ }
+ else if (mpl->token == T_LEFT)
+ { /* left parenthesis begins the "transpose" indicator, which
+ is followed by data in the tabular format */
+ get_token(mpl /* ( */);
+ if (!is_literal(mpl, "tr"))
+err3: error(mpl, "transpose indicator (tr) incomplete");
+ if (par->dim == 0) goto err1;
+ if (slice_arity(mpl, slice) != 2) goto err2;
+ get_token(mpl /* tr */);
+ if (mpl->token != T_RIGHT) goto err3;
+ get_token(mpl /* ) */);
+ /* in this case the colon is optional */
+ if (mpl->token == T_COLON) get_token(mpl /* : */);
+ /* set the "transpose" indicator */
+ tr = 1;
+ /* read parameter data in the tabular format */
+ tabular_format(mpl, par, slice, tr);
+ }
+ else if (mpl->token == T_SEMICOLON)
+ { /* semicolon terminates the data block */
+ get_token(mpl /* ; */);
+ break;
+ }
+ else
+ error(mpl, "syntax error in parameter data block");
+ }
+ /* delete the current slice */
+ delete_slice(mpl, slice);
+done: return;
+}
+
+/*----------------------------------------------------------------------
+-- data_section - read data section.
+--
+-- This routine reads data section using the syntax:
+--
+-- <data section> ::= <empty>
+-- <data section> ::= <data section> <data block> ;
+-- <data block> ::= <set data>
+-- <data block> ::= <parameter data>
+--
+-- Reading data section is terminated by either the keyword 'end' or
+-- the end of file. */
+
+void data_section(MPL *mpl)
+{ while (!(mpl->token == T_EOF || is_literal(mpl, "end")))
+ { if (is_literal(mpl, "set"))
+ set_data(mpl);
+ else if (is_literal(mpl, "param"))
+ parameter_data(mpl);
+ else
+ error(mpl, "syntax error in data section");
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl3.c b/test/monniaux/glpk-4.65/src/mpl/mpl3.c
new file mode 100644
index 00000000..2489db27
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl3.c
@@ -0,0 +1,6100 @@
+/* mpl3.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+
+/**********************************************************************/
+/* * * FLOATING-POINT NUMBERS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- fp_add - floating-point addition.
+--
+-- This routine computes the sum x + y. */
+
+double fp_add(MPL *mpl, double x, double y)
+{ if (x > 0.0 && y > 0.0 && x > + 0.999 * DBL_MAX - y ||
+ x < 0.0 && y < 0.0 && x < - 0.999 * DBL_MAX - y)
+ error(mpl, "%.*g + %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ return x + y;
+}
+
+/*----------------------------------------------------------------------
+-- fp_sub - floating-point subtraction.
+--
+-- This routine computes the difference x - y. */
+
+double fp_sub(MPL *mpl, double x, double y)
+{ if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y ||
+ x < 0.0 && y > 0.0 && x < - 0.999 * DBL_MAX + y)
+ error(mpl, "%.*g - %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ return x - y;
+}
+
+/*----------------------------------------------------------------------
+-- fp_less - floating-point non-negative subtraction.
+--
+-- This routine computes the non-negative difference max(0, x - y). */
+
+double fp_less(MPL *mpl, double x, double y)
+{ if (x < y) return 0.0;
+ if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y)
+ error(mpl, "%.*g less %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ return x - y;
+}
+
+/*----------------------------------------------------------------------
+-- fp_mul - floating-point multiplication.
+--
+-- This routine computes the product x * y. */
+
+double fp_mul(MPL *mpl, double x, double y)
+{ if (fabs(y) > 1.0 && fabs(x) > (0.999 * DBL_MAX) / fabs(y))
+ error(mpl, "%.*g * %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ return x * y;
+}
+
+/*----------------------------------------------------------------------
+-- fp_div - floating-point division.
+--
+-- This routine computes the quotient x / y. */
+
+double fp_div(MPL *mpl, double x, double y)
+{ if (fabs(y) < DBL_MIN)
+ error(mpl, "%.*g / %.*g; floating-point zero divide",
+ DBL_DIG, x, DBL_DIG, y);
+ if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y))
+ error(mpl, "%.*g / %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ return x / y;
+}
+
+/*----------------------------------------------------------------------
+-- fp_idiv - floating-point quotient of exact division.
+--
+-- This routine computes the quotient of exact division x div y. */
+
+double fp_idiv(MPL *mpl, double x, double y)
+{ if (fabs(y) < DBL_MIN)
+ error(mpl, "%.*g div %.*g; floating-point zero divide",
+ DBL_DIG, x, DBL_DIG, y);
+ if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y))
+ error(mpl, "%.*g div %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ x /= y;
+ return x > 0.0 ? floor(x) : x < 0.0 ? ceil(x) : 0.0;
+}
+
+/*----------------------------------------------------------------------
+-- fp_mod - floating-point remainder of exact division.
+--
+-- This routine computes the remainder of exact division x mod y.
+--
+-- NOTE: By definition x mod y = x - y * floor(x / y). */
+
+double fp_mod(MPL *mpl, double x, double y)
+{ double r;
+ xassert(mpl == mpl);
+ if (x == 0.0)
+ r = 0.0;
+ else if (y == 0.0)
+ r = x;
+ else
+ { r = fmod(fabs(x), fabs(y));
+ if (r != 0.0)
+ { if (x < 0.0) r = - r;
+ if (x > 0.0 && y < 0.0 || x < 0.0 && y > 0.0) r += y;
+ }
+ }
+ return r;
+}
+
+/*----------------------------------------------------------------------
+-- fp_power - floating-point exponentiation (raise to power).
+--
+-- This routine computes the exponentiation x ** y. */
+
+double fp_power(MPL *mpl, double x, double y)
+{ double r;
+ if (x == 0.0 && y <= 0.0 || x < 0.0 && y != floor(y))
+ error(mpl, "%.*g ** %.*g; result undefined",
+ DBL_DIG, x, DBL_DIG, y);
+ if (x == 0.0) goto eval;
+ if (fabs(x) > 1.0 && y > +1.0 &&
+ +log(fabs(x)) > (0.999 * log(DBL_MAX)) / y ||
+ fabs(x) < 1.0 && y < -1.0 &&
+ +log(fabs(x)) < (0.999 * log(DBL_MAX)) / y)
+ error(mpl, "%.*g ** %.*g; floating-point overflow",
+ DBL_DIG, x, DBL_DIG, y);
+ if (fabs(x) > 1.0 && y < -1.0 &&
+ -log(fabs(x)) < (0.999 * log(DBL_MAX)) / y ||
+ fabs(x) < 1.0 && y > +1.0 &&
+ -log(fabs(x)) > (0.999 * log(DBL_MAX)) / y)
+ r = 0.0;
+ else
+eval: r = pow(x, y);
+ return r;
+}
+
+/*----------------------------------------------------------------------
+-- fp_exp - floating-point base-e exponential.
+--
+-- This routine computes the base-e exponential e ** x. */
+
+double fp_exp(MPL *mpl, double x)
+{ if (x > 0.999 * log(DBL_MAX))
+ error(mpl, "exp(%.*g); floating-point overflow", DBL_DIG, x);
+ return exp(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_log - floating-point natural logarithm.
+--
+-- This routine computes the natural logarithm log x. */
+
+double fp_log(MPL *mpl, double x)
+{ if (x <= 0.0)
+ error(mpl, "log(%.*g); non-positive argument", DBL_DIG, x);
+ return log(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_log10 - floating-point common (decimal) logarithm.
+--
+-- This routine computes the common (decimal) logarithm lg x. */
+
+double fp_log10(MPL *mpl, double x)
+{ if (x <= 0.0)
+ error(mpl, "log10(%.*g); non-positive argument", DBL_DIG, x);
+ return log10(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_sqrt - floating-point square root.
+--
+-- This routine computes the square root x ** 0.5. */
+
+double fp_sqrt(MPL *mpl, double x)
+{ if (x < 0.0)
+ error(mpl, "sqrt(%.*g); negative argument", DBL_DIG, x);
+ return sqrt(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_sin - floating-point trigonometric sine.
+--
+-- This routine computes the trigonometric sine sin(x). */
+
+double fp_sin(MPL *mpl, double x)
+{ if (!(-1e6 <= x && x <= +1e6))
+ error(mpl, "sin(%.*g); argument too large", DBL_DIG, x);
+ return sin(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_cos - floating-point trigonometric cosine.
+--
+-- This routine computes the trigonometric cosine cos(x). */
+
+double fp_cos(MPL *mpl, double x)
+{ if (!(-1e6 <= x && x <= +1e6))
+ error(mpl, "cos(%.*g); argument too large", DBL_DIG, x);
+ return cos(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_tan - floating-point trigonometric tangent.
+--
+-- This routine computes the trigonometric tangent tan(x). */
+
+double fp_tan(MPL *mpl, double x)
+{ if (!(-1e6 <= x && x <= +1e6))
+ error(mpl, "tan(%.*g); argument too large", DBL_DIG, x);
+ return tan(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_atan - floating-point trigonometric arctangent.
+--
+-- This routine computes the trigonometric arctangent atan(x). */
+
+double fp_atan(MPL *mpl, double x)
+{ xassert(mpl == mpl);
+ return atan(x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_atan2 - floating-point trigonometric arctangent.
+--
+-- This routine computes the trigonometric arctangent atan(y / x). */
+
+double fp_atan2(MPL *mpl, double y, double x)
+{ xassert(mpl == mpl);
+ return atan2(y, x);
+}
+
+/*----------------------------------------------------------------------
+-- fp_round - round floating-point value to n fractional digits.
+--
+-- This routine rounds given floating-point value x to n fractional
+-- digits with the formula:
+--
+-- round(x, n) = floor(x * 10^n + 0.5) / 10^n.
+--
+-- The parameter n is assumed to be integer. */
+
+double fp_round(MPL *mpl, double x, double n)
+{ double ten_to_n;
+ if (n != floor(n))
+ error(mpl, "round(%.*g, %.*g); non-integer second argument",
+ DBL_DIG, x, DBL_DIG, n);
+ if (n <= DBL_DIG + 2)
+ { ten_to_n = pow(10.0, n);
+ if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n)
+ { x = floor(x * ten_to_n + 0.5);
+ if (x != 0.0) x /= ten_to_n;
+ }
+ }
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- fp_trunc - truncate floating-point value to n fractional digits.
+--
+-- This routine truncates given floating-point value x to n fractional
+-- digits with the formula:
+--
+-- ( floor(x * 10^n) / 10^n, if x >= 0
+-- trunc(x, n) = <
+-- ( ceil(x * 10^n) / 10^n, if x < 0
+--
+-- The parameter n is assumed to be integer. */
+
+double fp_trunc(MPL *mpl, double x, double n)
+{ double ten_to_n;
+ if (n != floor(n))
+ error(mpl, "trunc(%.*g, %.*g); non-integer second argument",
+ DBL_DIG, x, DBL_DIG, n);
+ if (n <= DBL_DIG + 2)
+ { ten_to_n = pow(10.0, n);
+ if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n)
+ { x = (x >= 0.0 ? floor(x * ten_to_n) : ceil(x * ten_to_n));
+ if (x != 0.0) x /= ten_to_n;
+ }
+ }
+ return x;
+}
+
+/**********************************************************************/
+/* * * PSEUDO-RANDOM NUMBER GENERATORS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- fp_irand224 - pseudo-random integer in the range [0, 2^24).
+--
+-- This routine returns a next pseudo-random integer (converted to
+-- floating-point) which is uniformly distributed between 0 and 2^24-1,
+-- inclusive. */
+
+#define two_to_the_24 0x1000000
+
+double fp_irand224(MPL *mpl)
+{ return
+ (double)rng_unif_rand(mpl->rand, two_to_the_24);
+}
+
+/*----------------------------------------------------------------------
+-- fp_uniform01 - pseudo-random number in the range [0, 1).
+--
+-- This routine returns a next pseudo-random number which is uniformly
+-- distributed in the range [0, 1). */
+
+#define two_to_the_31 ((unsigned int)0x80000000)
+
+double fp_uniform01(MPL *mpl)
+{ return
+ (double)rng_next_rand(mpl->rand) / (double)two_to_the_31;
+}
+
+/*----------------------------------------------------------------------
+-- fp_uniform - pseudo-random number in the range [a, b).
+--
+-- This routine returns a next pseudo-random number which is uniformly
+-- distributed in the range [a, b). */
+
+double fp_uniform(MPL *mpl, double a, double b)
+{ double x;
+ if (a >= b)
+ error(mpl, "Uniform(%.*g, %.*g); invalid range",
+ DBL_DIG, a, DBL_DIG, b);
+ x = fp_uniform01(mpl);
+#if 0
+ x = a * (1.0 - x) + b * x;
+#else
+ x = fp_add(mpl, a * (1.0 - x), b * x);
+#endif
+ return x;
+}
+
+/*----------------------------------------------------------------------
+-- fp_normal01 - Gaussian random variate with mu = 0 and sigma = 1.
+--
+-- This routine returns a Gaussian random variate with zero mean and
+-- unit standard deviation. The polar (Box-Mueller) method is used.
+--
+-- This code is a modified version of the routine gsl_ran_gaussian from
+-- the GNU Scientific Library Version 1.0. */
+
+double fp_normal01(MPL *mpl)
+{ double x, y, r2;
+ do
+ { /* choose x, y in uniform square (-1,-1) to (+1,+1) */
+ x = -1.0 + 2.0 * fp_uniform01(mpl);
+ y = -1.0 + 2.0 * fp_uniform01(mpl);
+ /* see if it is in the unit circle */
+ r2 = x * x + y * y;
+ } while (r2 > 1.0 || r2 == 0.0);
+ /* Box-Muller transform */
+ return y * sqrt(-2.0 * log (r2) / r2);
+}
+
+/*----------------------------------------------------------------------
+-- fp_normal - Gaussian random variate with specified mu and sigma.
+--
+-- This routine returns a Gaussian random variate with mean mu and
+-- standard deviation sigma. */
+
+double fp_normal(MPL *mpl, double mu, double sigma)
+{ double x;
+#if 0
+ x = mu + sigma * fp_normal01(mpl);
+#else
+ x = fp_add(mpl, mu, fp_mul(mpl, sigma, fp_normal01(mpl)));
+#endif
+ return x;
+}
+
+/**********************************************************************/
+/* * * SEGMENTED CHARACTER STRINGS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_string - create character string.
+--
+-- This routine creates a segmented character string, which is exactly
+-- equivalent to specified character string. */
+
+STRING *create_string
+( MPL *mpl,
+ char buf[MAX_LENGTH+1] /* not changed */
+)
+#if 0
+{ STRING *head, *tail;
+ int i, j;
+ xassert(buf != NULL);
+ xassert(strlen(buf) <= MAX_LENGTH);
+ head = tail = dmp_get_atom(mpl->strings, sizeof(STRING));
+ for (i = j = 0; ; i++)
+ { if ((tail->seg[j++] = buf[i]) == '\0') break;
+ if (j == STRSEG_SIZE)
+tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING))), j = 0;
+ }
+ tail->next = NULL;
+ return head;
+}
+#else
+{ STRING *str;
+ xassert(strlen(buf) <= MAX_LENGTH);
+ str = dmp_get_atom(mpl->strings, strlen(buf)+1);
+ strcpy(str, buf);
+ return str;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- copy_string - make copy of character string.
+--
+-- This routine returns an exact copy of segmented character string. */
+
+STRING *copy_string
+( MPL *mpl,
+ STRING *str /* not changed */
+)
+#if 0
+{ STRING *head, *tail;
+ xassert(str != NULL);
+ head = tail = dmp_get_atom(mpl->strings, sizeof(STRING));
+ for (; str != NULL; str = str->next)
+ { memcpy(tail->seg, str->seg, STRSEG_SIZE);
+ if (str->next != NULL)
+tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING)));
+ }
+ tail->next = NULL;
+ return head;
+}
+#else
+{ xassert(mpl == mpl);
+ return create_string(mpl, str);
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- compare_strings - compare one character string with another.
+--
+-- This routine compares one segmented character strings with another
+-- and returns the result of comparison as follows:
+--
+-- = 0 - both strings are identical;
+-- < 0 - the first string precedes the second one;
+-- > 0 - the first string follows the second one. */
+
+int compare_strings
+( MPL *mpl,
+ STRING *str1, /* not changed */
+ STRING *str2 /* not changed */
+)
+#if 0
+{ int j, c1, c2;
+ xassert(mpl == mpl);
+ for (;; str1 = str1->next, str2 = str2->next)
+ { xassert(str1 != NULL);
+ xassert(str2 != NULL);
+ for (j = 0; j < STRSEG_SIZE; j++)
+ { c1 = (unsigned char)str1->seg[j];
+ c2 = (unsigned char)str2->seg[j];
+ if (c1 < c2) return -1;
+ if (c1 > c2) return +1;
+ if (c1 == '\0') goto done;
+ }
+ }
+done: return 0;
+}
+#else
+{ xassert(mpl == mpl);
+ return strcmp(str1, str2);
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- fetch_string - extract content of character string.
+--
+-- This routine returns a character string, which is exactly equivalent
+-- to specified segmented character string. */
+
+char *fetch_string
+( MPL *mpl,
+ STRING *str, /* not changed */
+ char buf[MAX_LENGTH+1] /* modified */
+)
+#if 0
+{ int i, j;
+ xassert(mpl == mpl);
+ xassert(buf != NULL);
+ for (i = 0; ; str = str->next)
+ { xassert(str != NULL);
+ for (j = 0; j < STRSEG_SIZE; j++)
+ if ((buf[i++] = str->seg[j]) == '\0') goto done;
+ }
+done: xassert(strlen(buf) <= MAX_LENGTH);
+ return buf;
+}
+#else
+{ xassert(mpl == mpl);
+ return strcpy(buf, str);
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- delete_string - delete character string.
+--
+-- This routine deletes specified segmented character string. */
+
+void delete_string
+( MPL *mpl,
+ STRING *str /* destroyed */
+)
+#if 0
+{ STRING *temp;
+ xassert(str != NULL);
+ while (str != NULL)
+ { temp = str;
+ str = str->next;
+ dmp_free_atom(mpl->strings, temp, sizeof(STRING));
+ }
+ return;
+}
+#else
+{ dmp_free_atom(mpl->strings, str, strlen(str)+1);
+ return;
+}
+#endif
+
+/**********************************************************************/
+/* * * SYMBOLS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_symbol_num - create symbol of numeric type.
+--
+-- This routine creates a symbol, which has a numeric value specified
+-- as floating-point number. */
+
+SYMBOL *create_symbol_num(MPL *mpl, double num)
+{ SYMBOL *sym;
+ sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
+ sym->num = num;
+ sym->str = NULL;
+ return sym;
+}
+
+/*----------------------------------------------------------------------
+-- create_symbol_str - create symbol of abstract type.
+--
+-- This routine creates a symbol, which has an abstract value specified
+-- as segmented character string. */
+
+SYMBOL *create_symbol_str
+( MPL *mpl,
+ STRING *str /* destroyed */
+)
+{ SYMBOL *sym;
+ xassert(str != NULL);
+ sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
+ sym->num = 0.0;
+ sym->str = str;
+ return sym;
+}
+
+/*----------------------------------------------------------------------
+-- copy_symbol - make copy of symbol.
+--
+-- This routine returns an exact copy of symbol. */
+
+SYMBOL *copy_symbol
+( MPL *mpl,
+ SYMBOL *sym /* not changed */
+)
+{ SYMBOL *copy;
+ xassert(sym != NULL);
+ copy = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
+ if (sym->str == NULL)
+ { copy->num = sym->num;
+ copy->str = NULL;
+ }
+ else
+ { copy->num = 0.0;
+ copy->str = copy_string(mpl, sym->str);
+ }
+ return copy;
+}
+
+/*----------------------------------------------------------------------
+-- compare_symbols - compare one symbol with another.
+--
+-- This routine compares one symbol with another and returns the result
+-- of comparison as follows:
+--
+-- = 0 - both symbols are identical;
+-- < 0 - the first symbol precedes the second one;
+-- > 0 - the first symbol follows the second one.
+--
+-- Note that the linear order, in which symbols follow each other, is
+-- implementation-dependent. It may be not an alphabetical order. */
+
+int compare_symbols
+( MPL *mpl,
+ SYMBOL *sym1, /* not changed */
+ SYMBOL *sym2 /* not changed */
+)
+{ xassert(sym1 != NULL);
+ xassert(sym2 != NULL);
+ /* let all numeric quantities precede all symbolic quantities */
+ if (sym1->str == NULL && sym2->str == NULL)
+ { if (sym1->num < sym2->num) return -1;
+ if (sym1->num > sym2->num) return +1;
+ return 0;
+ }
+ if (sym1->str == NULL) return -1;
+ if (sym2->str == NULL) return +1;
+ return compare_strings(mpl, sym1->str, sym2->str);
+}
+
+/*----------------------------------------------------------------------
+-- delete_symbol - delete symbol.
+--
+-- This routine deletes specified symbol. */
+
+void delete_symbol
+( MPL *mpl,
+ SYMBOL *sym /* destroyed */
+)
+{ xassert(sym != NULL);
+ if (sym->str != NULL) delete_string(mpl, sym->str);
+ dmp_free_atom(mpl->symbols, sym, sizeof(SYMBOL));
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- format_symbol - format symbol for displaying or printing.
+--
+-- This routine converts specified symbol to a charater string, which
+-- is suitable for displaying or printing.
+--
+-- The resultant string is never longer than 255 characters. If it gets
+-- longer, it is truncated from the right and appended by dots. */
+
+char *format_symbol
+( MPL *mpl,
+ SYMBOL *sym /* not changed */
+)
+{ char *buf = mpl->sym_buf;
+ xassert(sym != NULL);
+ if (sym->str == NULL)
+ sprintf(buf, "%.*g", DBL_DIG, sym->num);
+ else
+ { char str[MAX_LENGTH+1];
+ int quoted, j, len;
+ fetch_string(mpl, sym->str, str);
+ if (!(isalpha((unsigned char)str[0]) || str[0] == '_'))
+ quoted = 1;
+ else
+ { quoted = 0;
+ for (j = 1; str[j] != '\0'; j++)
+ { if (!(isalnum((unsigned char)str[j]) ||
+ strchr("+-._", (unsigned char)str[j]) != NULL))
+ { quoted = 1;
+ break;
+ }
+ }
+ }
+# define safe_append(c) \
+ (void)(len < 255 ? (buf[len++] = (char)(c)) : 0)
+ buf[0] = '\0', len = 0;
+ if (quoted) safe_append('\'');
+ for (j = 0; str[j] != '\0'; j++)
+ { if (quoted && str[j] == '\'') safe_append('\'');
+ safe_append(str[j]);
+ }
+ if (quoted) safe_append('\'');
+# undef safe_append
+ buf[len] = '\0';
+ if (len == 255) strcpy(buf+252, "...");
+ }
+ xassert(strlen(buf) <= 255);
+ return buf;
+}
+
+/*----------------------------------------------------------------------
+-- concat_symbols - concatenate one symbol with another.
+--
+-- This routine concatenates values of two given symbols and assigns
+-- the resultant character string to a new symbol, which is returned on
+-- exit. Both original symbols are destroyed. */
+
+SYMBOL *concat_symbols
+( MPL *mpl,
+ SYMBOL *sym1, /* destroyed */
+ SYMBOL *sym2 /* destroyed */
+)
+{ char str1[MAX_LENGTH+1], str2[MAX_LENGTH+1];
+ xassert(MAX_LENGTH >= DBL_DIG + DBL_DIG);
+ if (sym1->str == NULL)
+ sprintf(str1, "%.*g", DBL_DIG, sym1->num);
+ else
+ fetch_string(mpl, sym1->str, str1);
+ if (sym2->str == NULL)
+ sprintf(str2, "%.*g", DBL_DIG, sym2->num);
+ else
+ fetch_string(mpl, sym2->str, str2);
+ if (strlen(str1) + strlen(str2) > MAX_LENGTH)
+ { char buf[255+1];
+ strcpy(buf, format_symbol(mpl, sym1));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s & %s; resultant symbol exceeds %d characters",
+ buf, format_symbol(mpl, sym2), MAX_LENGTH);
+ }
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ return create_symbol_str(mpl, create_string(mpl, strcat(str1,
+ str2)));
+}
+
+/**********************************************************************/
+/* * * N-TUPLES * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_tuple - create n-tuple.
+--
+-- This routine creates a n-tuple, which initially has no components,
+-- i.e. which is 0-tuple. */
+
+TUPLE *create_tuple(MPL *mpl)
+{ TUPLE *tuple;
+ xassert(mpl == mpl);
+ tuple = NULL;
+ return tuple;
+}
+
+/*----------------------------------------------------------------------
+-- expand_tuple - append symbol to n-tuple.
+--
+-- This routine expands n-tuple appending to it a given symbol, which
+-- becomes its new last component. */
+
+TUPLE *expand_tuple
+( MPL *mpl,
+ TUPLE *tuple, /* destroyed */
+ SYMBOL *sym /* destroyed */
+)
+{ TUPLE *tail, *temp;
+ xassert(sym != NULL);
+ /* create a new component */
+ tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
+ tail->sym = sym;
+ tail->next = NULL;
+ /* and append it to the component list */
+ if (tuple == NULL)
+ tuple = tail;
+ else
+ { for (temp = tuple; temp->next != NULL; temp = temp->next);
+ temp->next = tail;
+ }
+ return tuple;
+}
+
+/*----------------------------------------------------------------------
+-- tuple_dimen - determine dimension of n-tuple.
+--
+-- This routine returns dimension of n-tuple, i.e. number of components
+-- in the n-tuple. */
+
+int tuple_dimen
+( MPL *mpl,
+ TUPLE *tuple /* not changed */
+)
+{ TUPLE *temp;
+ int dim = 0;
+ xassert(mpl == mpl);
+ for (temp = tuple; temp != NULL; temp = temp->next) dim++;
+ return dim;
+}
+
+/*----------------------------------------------------------------------
+-- copy_tuple - make copy of n-tuple.
+--
+-- This routine returns an exact copy of n-tuple. */
+
+TUPLE *copy_tuple
+( MPL *mpl,
+ TUPLE *tuple /* not changed */
+)
+{ TUPLE *head, *tail;
+ if (tuple == NULL)
+ head = NULL;
+ else
+ { head = tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
+ for (; tuple != NULL; tuple = tuple->next)
+ { xassert(tuple->sym != NULL);
+ tail->sym = copy_symbol(mpl, tuple->sym);
+ if (tuple->next != NULL)
+tail = (tail->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE)));
+ }
+ tail->next = NULL;
+ }
+ return head;
+}
+
+/*----------------------------------------------------------------------
+-- compare_tuples - compare one n-tuple with another.
+--
+-- This routine compares two given n-tuples, which must have the same
+-- dimension (not checked for the sake of efficiency), and returns one
+-- of the following codes:
+--
+-- = 0 - both n-tuples are identical;
+-- < 0 - the first n-tuple precedes the second one;
+-- > 0 - the first n-tuple follows the second one.
+--
+-- Note that the linear order, in which n-tuples follow each other, is
+-- implementation-dependent. It may be not an alphabetical order. */
+
+int compare_tuples
+( MPL *mpl,
+ TUPLE *tuple1, /* not changed */
+ TUPLE *tuple2 /* not changed */
+)
+{ TUPLE *item1, *item2;
+ int ret;
+ xassert(mpl == mpl);
+ for (item1 = tuple1, item2 = tuple2; item1 != NULL;
+ item1 = item1->next, item2 = item2->next)
+ { xassert(item2 != NULL);
+ xassert(item1->sym != NULL);
+ xassert(item2->sym != NULL);
+ ret = compare_symbols(mpl, item1->sym, item2->sym);
+ if (ret != 0) return ret;
+ }
+ xassert(item2 == NULL);
+ return 0;
+}
+
+/*----------------------------------------------------------------------
+-- build_subtuple - build subtuple of given n-tuple.
+--
+-- This routine builds subtuple, which consists of first dim components
+-- of given n-tuple. */
+
+TUPLE *build_subtuple
+( MPL *mpl,
+ TUPLE *tuple, /* not changed */
+ int dim
+)
+{ TUPLE *head, *temp;
+ int j;
+ head = create_tuple(mpl);
+ for (j = 1, temp = tuple; j <= dim; j++, temp = temp->next)
+ { xassert(temp != NULL);
+ head = expand_tuple(mpl, head, copy_symbol(mpl, temp->sym));
+ }
+ return head;
+}
+
+/*----------------------------------------------------------------------
+-- delete_tuple - delete n-tuple.
+--
+-- This routine deletes specified n-tuple. */
+
+void delete_tuple
+( MPL *mpl,
+ TUPLE *tuple /* destroyed */
+)
+{ TUPLE *temp;
+ while (tuple != NULL)
+ { temp = tuple;
+ tuple = temp->next;
+ xassert(temp->sym != NULL);
+ delete_symbol(mpl, temp->sym);
+ dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- format_tuple - format n-tuple for displaying or printing.
+--
+-- This routine converts specified n-tuple to a character string, which
+-- is suitable for displaying or printing.
+--
+-- The resultant string is never longer than 255 characters. If it gets
+-- longer, it is truncated from the right and appended by dots. */
+
+char *format_tuple
+( MPL *mpl,
+ int c,
+ TUPLE *tuple /* not changed */
+)
+{ TUPLE *temp;
+ int dim, j, len;
+ char *buf = mpl->tup_buf, str[255+1], *save;
+# define safe_append(c) \
+ (void)(len < 255 ? (buf[len++] = (char)(c)) : 0)
+ buf[0] = '\0', len = 0;
+ dim = tuple_dimen(mpl, tuple);
+ if (c == '[' && dim > 0) safe_append('[');
+ if (c == '(' && dim > 1) safe_append('(');
+ for (temp = tuple; temp != NULL; temp = temp->next)
+ { if (temp != tuple) safe_append(',');
+ xassert(temp->sym != NULL);
+ save = mpl->sym_buf;
+ mpl->sym_buf = str;
+ format_symbol(mpl, temp->sym);
+ mpl->sym_buf = save;
+ xassert(strlen(str) < sizeof(str));
+ for (j = 0; str[j] != '\0'; j++) safe_append(str[j]);
+ }
+ if (c == '[' && dim > 0) safe_append(']');
+ if (c == '(' && dim > 1) safe_append(')');
+# undef safe_append
+ buf[len] = '\0';
+ if (len == 255) strcpy(buf+252, "...");
+ xassert(strlen(buf) <= 255);
+ return buf;
+}
+
+/**********************************************************************/
+/* * * ELEMENTAL SETS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_elemset - create elemental set.
+--
+-- This routine creates an elemental set, whose members are n-tuples of
+-- specified dimension. Being created the set is initially empty. */
+
+ELEMSET *create_elemset(MPL *mpl, int dim)
+{ ELEMSET *set;
+ xassert(dim > 0);
+ set = create_array(mpl, A_NONE, dim);
+ return set;
+}
+
+/*----------------------------------------------------------------------
+-- find_tuple - check if elemental set contains given n-tuple.
+--
+-- This routine finds given n-tuple in specified elemental set in order
+-- to check if the set contains that n-tuple. If the n-tuple is found,
+-- the routine returns pointer to corresponding array member. Otherwise
+-- null pointer is returned. */
+
+MEMBER *find_tuple
+( MPL *mpl,
+ ELEMSET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ xassert(set != NULL);
+ xassert(set->type == A_NONE);
+ xassert(set->dim == tuple_dimen(mpl, tuple));
+ return find_member(mpl, set, tuple);
+}
+
+/*----------------------------------------------------------------------
+-- add_tuple - add new n-tuple to elemental set.
+--
+-- This routine adds given n-tuple to specified elemental set.
+--
+-- For the sake of efficiency this routine doesn't check whether the
+-- set already contains the same n-tuple or not. Therefore the calling
+-- program should use the routine find_tuple (if necessary) in order to
+-- make sure that the given n-tuple is not contained in the set, since
+-- duplicate n-tuples within the same set are not allowed. */
+
+MEMBER *add_tuple
+( MPL *mpl,
+ ELEMSET *set, /* modified */
+ TUPLE *tuple /* destroyed */
+)
+{ MEMBER *memb;
+ xassert(set != NULL);
+ xassert(set->type == A_NONE);
+ xassert(set->dim == tuple_dimen(mpl, tuple));
+ memb = add_member(mpl, set, tuple);
+ memb->value.none = NULL;
+ return memb;
+}
+
+/*----------------------------------------------------------------------
+-- check_then_add - check and add new n-tuple to elemental set.
+--
+-- This routine is equivalent to the routine add_tuple except that it
+-- does check for duplicate n-tuples. */
+
+MEMBER *check_then_add
+( MPL *mpl,
+ ELEMSET *set, /* modified */
+ TUPLE *tuple /* destroyed */
+)
+{ if (find_tuple(mpl, set, tuple) != NULL)
+ error(mpl, "duplicate tuple %s detected", format_tuple(mpl,
+ '(', tuple));
+ return add_tuple(mpl, set, tuple);
+}
+
+/*----------------------------------------------------------------------
+-- copy_elemset - make copy of elemental set.
+--
+-- This routine makes an exact copy of elemental set. */
+
+ELEMSET *copy_elemset
+( MPL *mpl,
+ ELEMSET *set /* not changed */
+)
+{ ELEMSET *copy;
+ MEMBER *memb;
+ xassert(set != NULL);
+ xassert(set->type == A_NONE);
+ xassert(set->dim > 0);
+ copy = create_elemset(mpl, set->dim);
+ for (memb = set->head; memb != NULL; memb = memb->next)
+ add_tuple(mpl, copy, copy_tuple(mpl, memb->tuple));
+ return copy;
+}
+
+/*----------------------------------------------------------------------
+-- delete_elemset - delete elemental set.
+--
+-- This routine deletes specified elemental set. */
+
+void delete_elemset
+( MPL *mpl,
+ ELEMSET *set /* destroyed */
+)
+{ xassert(set != NULL);
+ xassert(set->type == A_NONE);
+ delete_array(mpl, set);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- arelset_size - compute size of "arithmetic" elemental set.
+--
+-- This routine computes the size of "arithmetic" elemental set, which
+-- is specified in the form of arithmetic progression:
+--
+-- { t0 .. tf by dt }.
+--
+-- The size is computed using the formula:
+--
+-- n = max(0, floor((tf - t0) / dt) + 1). */
+
+int arelset_size(MPL *mpl, double t0, double tf, double dt)
+{ double temp;
+ if (dt == 0.0)
+ error(mpl, "%.*g .. %.*g by %.*g; zero stride not allowed",
+ DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt);
+ if (tf > 0.0 && t0 < 0.0 && tf > + 0.999 * DBL_MAX + t0)
+ temp = +DBL_MAX;
+ else if (tf < 0.0 && t0 > 0.0 && tf < - 0.999 * DBL_MAX + t0)
+ temp = -DBL_MAX;
+ else
+ temp = tf - t0;
+ if (fabs(dt) < 1.0 && fabs(temp) > (0.999 * DBL_MAX) * fabs(dt))
+ { if (temp > 0.0 && dt > 0.0 || temp < 0.0 && dt < 0.0)
+ temp = +DBL_MAX;
+ else
+ temp = 0.0;
+ }
+ else
+ { temp = floor(temp / dt) + 1.0;
+ if (temp < 0.0) temp = 0.0;
+ }
+ xassert(temp >= 0.0);
+ if (temp > (double)(INT_MAX - 1))
+ error(mpl, "%.*g .. %.*g by %.*g; set too large",
+ DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt);
+ return (int)(temp + 0.5);
+}
+
+/*----------------------------------------------------------------------
+-- arelset_member - compute member of "arithmetic" elemental set.
+--
+-- This routine returns a numeric value of symbol, which is equivalent
+-- to j-th member of given "arithmetic" elemental set specified in the
+-- form of arithmetic progression:
+--
+-- { t0 .. tf by dt }.
+--
+-- The symbol value is computed with the formula:
+--
+-- j-th member = t0 + (j - 1) * dt,
+--
+-- The number j must satisfy to the restriction 1 <= j <= n, where n is
+-- the set size computed by the routine arelset_size. */
+
+double arelset_member(MPL *mpl, double t0, double tf, double dt, int j)
+{ xassert(1 <= j && j <= arelset_size(mpl, t0, tf, dt));
+ return t0 + (double)(j - 1) * dt;
+}
+
+/*----------------------------------------------------------------------
+-- create_arelset - create "arithmetic" elemental set.
+--
+-- This routine creates "arithmetic" elemental set, which is specified
+-- in the form of arithmetic progression:
+--
+-- { t0 .. tf by dt }.
+--
+-- Components of this set are 1-tuples. */
+
+ELEMSET *create_arelset(MPL *mpl, double t0, double tf, double dt)
+{ ELEMSET *set;
+ int j, n;
+ set = create_elemset(mpl, 1);
+ n = arelset_size(mpl, t0, tf, dt);
+ for (j = 1; j <= n; j++)
+ { add_tuple
+ ( mpl,
+ set,
+ expand_tuple
+ ( mpl,
+ create_tuple(mpl),
+ create_symbol_num
+ ( mpl,
+ arelset_member(mpl, t0, tf, dt, j)
+ )
+ )
+ );
+ }
+ return set;
+}
+
+/*----------------------------------------------------------------------
+-- set_union - union of two elemental sets.
+--
+-- This routine computes the union:
+--
+-- X U Y = { j | (j in X) or (j in Y) },
+--
+-- where X and Y are given elemental sets (destroyed on exit). */
+
+ELEMSET *set_union
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+)
+{ MEMBER *memb;
+ xassert(X != NULL);
+ xassert(X->type == A_NONE);
+ xassert(X->dim > 0);
+ xassert(Y != NULL);
+ xassert(Y->type == A_NONE);
+ xassert(Y->dim > 0);
+ xassert(X->dim == Y->dim);
+ for (memb = Y->head; memb != NULL; memb = memb->next)
+ { if (find_tuple(mpl, X, memb->tuple) == NULL)
+ add_tuple(mpl, X, copy_tuple(mpl, memb->tuple));
+ }
+ delete_elemset(mpl, Y);
+ return X;
+}
+
+/*----------------------------------------------------------------------
+-- set_diff - difference between two elemental sets.
+--
+-- This routine computes the difference:
+--
+-- X \ Y = { j | (j in X) and (j not in Y) },
+--
+-- where X and Y are given elemental sets (destroyed on exit). */
+
+ELEMSET *set_diff
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+)
+{ ELEMSET *Z;
+ MEMBER *memb;
+ xassert(X != NULL);
+ xassert(X->type == A_NONE);
+ xassert(X->dim > 0);
+ xassert(Y != NULL);
+ xassert(Y->type == A_NONE);
+ xassert(Y->dim > 0);
+ xassert(X->dim == Y->dim);
+ Z = create_elemset(mpl, X->dim);
+ for (memb = X->head; memb != NULL; memb = memb->next)
+ { if (find_tuple(mpl, Y, memb->tuple) == NULL)
+ add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
+ }
+ delete_elemset(mpl, X);
+ delete_elemset(mpl, Y);
+ return Z;
+}
+
+/*----------------------------------------------------------------------
+-- set_symdiff - symmetric difference between two elemental sets.
+--
+-- This routine computes the symmetric difference:
+--
+-- X (+) Y = (X \ Y) U (Y \ X),
+--
+-- where X and Y are given elemental sets (destroyed on exit). */
+
+ELEMSET *set_symdiff
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+)
+{ ELEMSET *Z;
+ MEMBER *memb;
+ xassert(X != NULL);
+ xassert(X->type == A_NONE);
+ xassert(X->dim > 0);
+ xassert(Y != NULL);
+ xassert(Y->type == A_NONE);
+ xassert(Y->dim > 0);
+ xassert(X->dim == Y->dim);
+ /* Z := X \ Y */
+ Z = create_elemset(mpl, X->dim);
+ for (memb = X->head; memb != NULL; memb = memb->next)
+ { if (find_tuple(mpl, Y, memb->tuple) == NULL)
+ add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
+ }
+ /* Z := Z U (Y \ X) */
+ for (memb = Y->head; memb != NULL; memb = memb->next)
+ { if (find_tuple(mpl, X, memb->tuple) == NULL)
+ add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
+ }
+ delete_elemset(mpl, X);
+ delete_elemset(mpl, Y);
+ return Z;
+}
+
+/*----------------------------------------------------------------------
+-- set_inter - intersection of two elemental sets.
+--
+-- This routine computes the intersection:
+--
+-- X ^ Y = { j | (j in X) and (j in Y) },
+--
+-- where X and Y are given elemental sets (destroyed on exit). */
+
+ELEMSET *set_inter
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+)
+{ ELEMSET *Z;
+ MEMBER *memb;
+ xassert(X != NULL);
+ xassert(X->type == A_NONE);
+ xassert(X->dim > 0);
+ xassert(Y != NULL);
+ xassert(Y->type == A_NONE);
+ xassert(Y->dim > 0);
+ xassert(X->dim == Y->dim);
+ Z = create_elemset(mpl, X->dim);
+ for (memb = X->head; memb != NULL; memb = memb->next)
+ { if (find_tuple(mpl, Y, memb->tuple) != NULL)
+ add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
+ }
+ delete_elemset(mpl, X);
+ delete_elemset(mpl, Y);
+ return Z;
+}
+
+/*----------------------------------------------------------------------
+-- set_cross - cross (Cartesian) product of two elemental sets.
+--
+-- This routine computes the cross (Cartesian) product:
+--
+-- X x Y = { (i,j) | (i in X) and (j in Y) },
+--
+-- where X and Y are given elemental sets (destroyed on exit). */
+
+ELEMSET *set_cross
+( MPL *mpl,
+ ELEMSET *X, /* destroyed */
+ ELEMSET *Y /* destroyed */
+)
+{ ELEMSET *Z;
+ MEMBER *memx, *memy;
+ TUPLE *tuple, *temp;
+ xassert(X != NULL);
+ xassert(X->type == A_NONE);
+ xassert(X->dim > 0);
+ xassert(Y != NULL);
+ xassert(Y->type == A_NONE);
+ xassert(Y->dim > 0);
+ Z = create_elemset(mpl, X->dim + Y->dim);
+ for (memx = X->head; memx != NULL; memx = memx->next)
+ { for (memy = Y->head; memy != NULL; memy = memy->next)
+ { tuple = copy_tuple(mpl, memx->tuple);
+ for (temp = memy->tuple; temp != NULL; temp = temp->next)
+ tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
+ temp->sym));
+ add_tuple(mpl, Z, tuple);
+ }
+ }
+ delete_elemset(mpl, X);
+ delete_elemset(mpl, Y);
+ return Z;
+}
+
+/**********************************************************************/
+/* * * ELEMENTAL VARIABLES * * */
+/**********************************************************************/
+
+/* (there are no specific routines for elemental variables) */
+
+/**********************************************************************/
+/* * * LINEAR FORMS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- constant_term - create constant term.
+--
+-- This routine creates the linear form, which is a constant term. */
+
+FORMULA *constant_term(MPL *mpl, double coef)
+{ FORMULA *form;
+ if (coef == 0.0)
+ form = NULL;
+ else
+ { form = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ form->coef = coef;
+ form->var = NULL;
+ form->next = NULL;
+ }
+ return form;
+}
+
+/*----------------------------------------------------------------------
+-- single_variable - create single variable.
+--
+-- This routine creates the linear form, which is a single elemental
+-- variable. */
+
+FORMULA *single_variable
+( MPL *mpl,
+ ELEMVAR *var /* referenced */
+)
+{ FORMULA *form;
+ xassert(var != NULL);
+ form = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ form->coef = 1.0;
+ form->var = var;
+ form->next = NULL;
+ return form;
+}
+
+/*----------------------------------------------------------------------
+-- copy_formula - make copy of linear form.
+--
+-- This routine returns an exact copy of linear form. */
+
+FORMULA *copy_formula
+( MPL *mpl,
+ FORMULA *form /* not changed */
+)
+{ FORMULA *head, *tail;
+ if (form == NULL)
+ head = NULL;
+ else
+ { head = tail = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ for (; form != NULL; form = form->next)
+ { tail->coef = form->coef;
+ tail->var = form->var;
+ if (form->next != NULL)
+tail = (tail->next = dmp_get_atom(mpl->formulae, sizeof(FORMULA)));
+ }
+ tail->next = NULL;
+ }
+ return head;
+}
+
+/*----------------------------------------------------------------------
+-- delete_formula - delete linear form.
+--
+-- This routine deletes specified linear form. */
+
+void delete_formula
+( MPL *mpl,
+ FORMULA *form /* destroyed */
+)
+{ FORMULA *temp;
+ while (form != NULL)
+ { temp = form;
+ form = form->next;
+ dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA));
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- linear_comb - linear combination of two linear forms.
+--
+-- This routine computes the linear combination:
+--
+-- a * fx + b * fy,
+--
+-- where a and b are numeric coefficients, fx and fy are linear forms
+-- (destroyed on exit). */
+
+FORMULA *linear_comb
+( MPL *mpl,
+ double a, FORMULA *fx, /* destroyed */
+ double b, FORMULA *fy /* destroyed */
+)
+{ FORMULA *form = NULL, *term, *temp;
+ double c0 = 0.0;
+ for (term = fx; term != NULL; term = term->next)
+ { if (term->var == NULL)
+ c0 = fp_add(mpl, c0, fp_mul(mpl, a, term->coef));
+ else
+ term->var->temp =
+ fp_add(mpl, term->var->temp, fp_mul(mpl, a, term->coef));
+ }
+ for (term = fy; term != NULL; term = term->next)
+ { if (term->var == NULL)
+ c0 = fp_add(mpl, c0, fp_mul(mpl, b, term->coef));
+ else
+ term->var->temp =
+ fp_add(mpl, term->var->temp, fp_mul(mpl, b, term->coef));
+ }
+ for (term = fx; term != NULL; term = term->next)
+ { if (term->var != NULL && term->var->temp != 0.0)
+ { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ temp->coef = term->var->temp, temp->var = term->var;
+ temp->next = form, form = temp;
+ term->var->temp = 0.0;
+ }
+ }
+ for (term = fy; term != NULL; term = term->next)
+ { if (term->var != NULL && term->var->temp != 0.0)
+ { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ temp->coef = term->var->temp, temp->var = term->var;
+ temp->next = form, form = temp;
+ term->var->temp = 0.0;
+ }
+ }
+ if (c0 != 0.0)
+ { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
+ temp->coef = c0, temp->var = NULL;
+ temp->next = form, form = temp;
+ }
+ delete_formula(mpl, fx);
+ delete_formula(mpl, fy);
+ return form;
+}
+
+/*----------------------------------------------------------------------
+-- remove_constant - remove constant term from linear form.
+--
+-- This routine removes constant term from linear form and stores its
+-- value to given location. */
+
+FORMULA *remove_constant
+( MPL *mpl,
+ FORMULA *form, /* destroyed */
+ double *coef /* modified */
+)
+{ FORMULA *head = NULL, *temp;
+ *coef = 0.0;
+ while (form != NULL)
+ { temp = form;
+ form = form->next;
+ if (temp->var == NULL)
+ { /* constant term */
+ *coef = fp_add(mpl, *coef, temp->coef);
+ dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA));
+ }
+ else
+ { /* linear term */
+ temp->next = head;
+ head = temp;
+ }
+ }
+ return head;
+}
+
+/*----------------------------------------------------------------------
+-- reduce_terms - reduce identical terms in linear form.
+--
+-- This routine reduces identical terms in specified linear form. */
+
+FORMULA *reduce_terms
+( MPL *mpl,
+ FORMULA *form /* destroyed */
+)
+{ FORMULA *term, *next_term;
+ double c0 = 0.0;
+ for (term = form; term != NULL; term = term->next)
+ { if (term->var == NULL)
+ c0 = fp_add(mpl, c0, term->coef);
+ else
+ term->var->temp = fp_add(mpl, term->var->temp, term->coef);
+ }
+ next_term = form, form = NULL;
+ for (term = next_term; term != NULL; term = next_term)
+ { next_term = term->next;
+ if (term->var == NULL && c0 != 0.0)
+ { term->coef = c0, c0 = 0.0;
+ term->next = form, form = term;
+ }
+ else if (term->var != NULL && term->var->temp != 0.0)
+ { term->coef = term->var->temp, term->var->temp = 0.0;
+ term->next = form, form = term;
+ }
+ else
+ dmp_free_atom(mpl->formulae, term, sizeof(FORMULA));
+ }
+ return form;
+}
+
+/**********************************************************************/
+/* * * ELEMENTAL CONSTRAINTS * * */
+/**********************************************************************/
+
+/* (there are no specific routines for elemental constraints) */
+
+/**********************************************************************/
+/* * * GENERIC VALUES * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- delete_value - delete generic value.
+--
+-- This routine deletes specified generic value.
+--
+-- NOTE: The generic value to be deleted must be valid. */
+
+void delete_value
+( MPL *mpl,
+ int type,
+ VALUE *value /* content destroyed */
+)
+{ xassert(value != NULL);
+ switch (type)
+ { case A_NONE:
+ value->none = NULL;
+ break;
+ case A_NUMERIC:
+ value->num = 0.0;
+ break;
+ case A_SYMBOLIC:
+ delete_symbol(mpl, value->sym), value->sym = NULL;
+ break;
+ case A_LOGICAL:
+ value->bit = 0;
+ break;
+ case A_TUPLE:
+ delete_tuple(mpl, value->tuple), value->tuple = NULL;
+ break;
+ case A_ELEMSET:
+ delete_elemset(mpl, value->set), value->set = NULL;
+ break;
+ case A_ELEMVAR:
+ value->var = NULL;
+ break;
+ case A_FORMULA:
+ delete_formula(mpl, value->form), value->form = NULL;
+ break;
+ case A_ELEMCON:
+ value->con = NULL;
+ break;
+ default:
+ xassert(type != type);
+ }
+ return;
+}
+
+/**********************************************************************/
+/* * * SYMBOLICALLY INDEXED ARRAYS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- create_array - create array.
+--
+-- This routine creates an array of specified type and dimension. Being
+-- created the array is initially empty.
+--
+-- The type indicator determines generic values, which can be assigned
+-- to the array members:
+--
+-- A_NONE - none (members have no assigned values)
+-- A_NUMERIC - floating-point numbers
+-- A_SYMBOLIC - symbols
+-- A_ELEMSET - elemental sets
+-- A_ELEMVAR - elemental variables
+-- A_ELEMCON - elemental constraints
+--
+-- The dimension may be 0, in which case the array consists of the only
+-- member (such arrays represent 0-dimensional objects). */
+
+ARRAY *create_array(MPL *mpl, int type, int dim)
+{ ARRAY *array;
+ xassert(type == A_NONE || type == A_NUMERIC ||
+ type == A_SYMBOLIC || type == A_ELEMSET ||
+ type == A_ELEMVAR || type == A_ELEMCON);
+ xassert(dim >= 0);
+ array = dmp_get_atom(mpl->arrays, sizeof(ARRAY));
+ array->type = type;
+ array->dim = dim;
+ array->size = 0;
+ array->head = NULL;
+ array->tail = NULL;
+ array->tree = NULL;
+ array->prev = NULL;
+ array->next = mpl->a_list;
+ /* include the array in the global array list */
+ if (array->next != NULL) array->next->prev = array;
+ mpl->a_list = array;
+ return array;
+}
+
+/*----------------------------------------------------------------------
+-- find_member - find array member with given n-tuple.
+--
+-- This routine finds an array member, which has given n-tuple. If the
+-- array is short, the linear search is used. Otherwise the routine
+-- autimatically creates the search tree (i.e. the array index) to find
+-- members for logarithmic time. */
+
+static int compare_member_tuples(void *info, const void *key1,
+ const void *key2)
+{ /* this is an auxiliary routine used to compare keys, which are
+ n-tuples assigned to array members */
+ return compare_tuples((MPL *)info, (TUPLE *)key1, (TUPLE *)key2);
+}
+
+MEMBER *find_member
+( MPL *mpl,
+ ARRAY *array, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ xassert(array != NULL);
+ /* the n-tuple must have the same dimension as the array */
+ xassert(tuple_dimen(mpl, tuple) == array->dim);
+ /* if the array is large enough, create the search tree and index
+ all existing members of the array */
+ if (array->size > 30 && array->tree == NULL)
+ { array->tree = avl_create_tree(compare_member_tuples, mpl);
+ for (memb = array->head; memb != NULL; memb = memb->next)
+avl_set_node_link(avl_insert_node(array->tree, memb->tuple),
+ (void *)memb);
+ }
+ /* find a member, which has the given tuple */
+ if (array->tree == NULL)
+ { /* the search tree doesn't exist; use the linear search */
+ for (memb = array->head; memb != NULL; memb = memb->next)
+ if (compare_tuples(mpl, memb->tuple, tuple) == 0) break;
+ }
+ else
+ { /* the search tree exists; use the binary search */
+ AVLNODE *node;
+ node = avl_find_node(array->tree, tuple);
+memb = (MEMBER *)(node == NULL ? NULL : avl_get_node_link(node));
+ }
+ return memb;
+}
+
+/*----------------------------------------------------------------------
+-- add_member - add new member to array.
+--
+-- This routine creates a new member with given n-tuple and adds it to
+-- specified array.
+--
+-- For the sake of efficiency this routine doesn't check whether the
+-- array already contains a member with the given n-tuple or not. Thus,
+-- if necessary, the calling program should use the routine find_member
+-- in order to be sure that the array contains no member with the same
+-- n-tuple, because members with duplicate n-tuples are not allowed.
+--
+-- This routine assigns no generic value to the new member, because the
+-- calling program must do that. */
+
+MEMBER *add_member
+( MPL *mpl,
+ ARRAY *array, /* modified */
+ TUPLE *tuple /* destroyed */
+)
+{ MEMBER *memb;
+ xassert(array != NULL);
+ /* the n-tuple must have the same dimension as the array */
+ xassert(tuple_dimen(mpl, tuple) == array->dim);
+ /* create new member */
+ memb = dmp_get_atom(mpl->members, sizeof(MEMBER));
+ memb->tuple = tuple;
+ memb->next = NULL;
+ memset(&memb->value, '?', sizeof(VALUE));
+ /* and append it to the member list */
+ array->size++;
+ if (array->head == NULL)
+ array->head = memb;
+ else
+ array->tail->next = memb;
+ array->tail = memb;
+ /* if the search tree exists, index the new member */
+ if (array->tree != NULL)
+avl_set_node_link(avl_insert_node(array->tree, memb->tuple),
+ (void *)memb);
+ return memb;
+}
+
+/*----------------------------------------------------------------------
+-- delete_array - delete array.
+--
+-- This routine deletes specified array.
+--
+-- Generic values assigned to the array members are not deleted by this
+-- routine. The calling program itself must delete all assigned generic
+-- values before deleting the array. */
+
+void delete_array
+( MPL *mpl,
+ ARRAY *array /* destroyed */
+)
+{ MEMBER *memb;
+ xassert(array != NULL);
+ /* delete all existing array members */
+ while (array->head != NULL)
+ { memb = array->head;
+ array->head = memb->next;
+ delete_tuple(mpl, memb->tuple);
+ dmp_free_atom(mpl->members, memb, sizeof(MEMBER));
+ }
+ /* if the search tree exists, also delete it */
+ if (array->tree != NULL) avl_delete_tree(array->tree);
+ /* remove the array from the global array list */
+ if (array->prev == NULL)
+ mpl->a_list = array->next;
+ else
+ array->prev->next = array->next;
+ if (array->next == NULL)
+ ;
+ else
+ array->next->prev = array->prev;
+ /* delete the array descriptor */
+ dmp_free_atom(mpl->arrays, array, sizeof(ARRAY));
+ return;
+}
+
+/**********************************************************************/
+/* * * DOMAINS AND DUMMY INDICES * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- assign_dummy_index - assign new value to dummy index.
+--
+-- This routine assigns new value to specified dummy index and, that is
+-- important, invalidates all temporary resultant values, which depends
+-- on that dummy index. */
+
+void assign_dummy_index
+( MPL *mpl,
+ DOMAIN_SLOT *slot, /* modified */
+ SYMBOL *value /* not changed */
+)
+{ CODE *leaf, *code;
+ xassert(slot != NULL);
+ xassert(value != NULL);
+ /* delete the current value assigned to the dummy index */
+ if (slot->value != NULL)
+ { /* if the current value and the new one are identical, actual
+ assignment is not needed */
+ if (compare_symbols(mpl, slot->value, value) == 0) goto done;
+ /* delete a symbol, which is the current value */
+ delete_symbol(mpl, slot->value), slot->value = NULL;
+ }
+ /* now walk through all the pseudo-codes with op = O_INDEX, which
+ refer to the dummy index to be changed (these pseudo-codes are
+ leaves in the forest of *all* expressions in the database) */
+ for (leaf = slot->list; leaf != NULL; leaf = leaf->arg.index.
+ next)
+ { xassert(leaf->op == O_INDEX);
+ /* invalidate all resultant values, which depend on the dummy
+ index, walking from the current leaf toward the root of the
+ corresponding expression tree */
+ for (code = leaf; code != NULL; code = code->up)
+ { if (code->valid)
+ { /* invalidate and delete resultant value */
+ code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ }
+ }
+ /* assign new value to the dummy index */
+ slot->value = copy_symbol(mpl, value);
+done: return;
+}
+
+/*----------------------------------------------------------------------
+-- update_dummy_indices - update current values of dummy indices.
+--
+-- This routine assigns components of "backup" n-tuple to dummy indices
+-- of specified domain block. If no "backup" n-tuple is defined for the
+-- domain block, values of the dummy indices remain untouched. */
+
+void update_dummy_indices
+( MPL *mpl,
+ DOMAIN_BLOCK *block /* not changed */
+)
+{ DOMAIN_SLOT *slot;
+ TUPLE *temp;
+ if (block->backup != NULL)
+ { for (slot = block->list, temp = block->backup; slot != NULL;
+ slot = slot->next, temp = temp->next)
+ { xassert(temp != NULL);
+ xassert(temp->sym != NULL);
+ assign_dummy_index(mpl, slot, temp->sym);
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- enter_domain_block - enter domain block.
+--
+-- Let specified domain block have the form:
+--
+-- { ..., (j1, j2, ..., jn) in J, ... }
+--
+-- where j1, j2, ..., jn are dummy indices, J is a basic set.
+--
+-- This routine does the following:
+--
+-- 1. Checks if the given n-tuple is a member of the basic set J. Note
+-- that J being *out of the scope* of the domain block cannot depend
+-- on the dummy indices in the same and inner domain blocks, so it
+-- can be computed before the dummy indices are assigned new values.
+-- If this check fails, the routine returns with non-zero code.
+--
+-- 2. Saves current values of the dummy indices j1, j2, ..., jn.
+--
+-- 3. Assigns new values, which are components of the given n-tuple, to
+-- the dummy indices j1, j2, ..., jn. If dimension of the n-tuple is
+-- larger than n, its extra components n+1, n+2, ... are not used.
+--
+-- 4. Calls the formal routine func which either enters the next domain
+-- block or evaluates some code within the domain scope.
+--
+-- 5. Restores former values of the dummy indices j1, j2, ..., jn.
+--
+-- Since current values assigned to the dummy indices on entry to this
+-- routine are restored on exit, the formal routine func is allowed to
+-- call this routine recursively. */
+
+int enter_domain_block
+( MPL *mpl,
+ DOMAIN_BLOCK *block, /* not changed */
+ TUPLE *tuple, /* not changed */
+ void *info, void (*func)(MPL *mpl, void *info)
+)
+{ TUPLE *backup;
+ int ret = 0;
+ /* check if the given n-tuple is a member of the basic set */
+ xassert(block->code != NULL);
+ if (!is_member(mpl, block->code, tuple))
+ { ret = 1;
+ goto done;
+ }
+ /* save reference to "backup" n-tuple, which was used to assign
+ current values of the dummy indices (it is sufficient to save
+ reference, not value, because that n-tuple is defined in some
+ outer level of recursion and therefore cannot be changed on
+ this and deeper recursive calls) */
+ backup = block->backup;
+ /* set up new "backup" n-tuple, which defines new values of the
+ dummy indices */
+ block->backup = tuple;
+ /* assign new values to the dummy indices */
+ update_dummy_indices(mpl, block);
+ /* call the formal routine that does the rest part of the job */
+ func(mpl, info);
+ /* restore reference to the former "backup" n-tuple */
+ block->backup = backup;
+ /* restore former values of the dummy indices; note that if the
+ domain block just escaped has no other active instances which
+ may exist due to recursion (it is indicated by a null pointer
+ to the former n-tuple), former values of the dummy indices are
+ undefined; therefore in this case the routine keeps currently
+ assigned values of the dummy indices that involves keeping all
+ dependent temporary results and thereby, if this domain block
+ is not used recursively, allows improving efficiency */
+ update_dummy_indices(mpl, block);
+done: return ret;
+}
+
+/*----------------------------------------------------------------------
+-- eval_within_domain - perform evaluation within domain scope.
+--
+-- This routine assigns new values (symbols) to all dummy indices of
+-- specified domain and calls the formal routine func, which is used to
+-- evaluate some code in the domain scope. Each free dummy index in the
+-- domain is assigned a value specified in the corresponding component
+-- of given n-tuple. Non-free dummy indices are assigned values, which
+-- are computed by this routine.
+--
+-- Number of components in the given n-tuple must be the same as number
+-- of free indices in the domain.
+--
+-- If the given n-tuple is not a member of the domain set, the routine
+-- func is not called, and non-zero code is returned.
+--
+-- For the sake of convenience it is allowed to specify domain as NULL
+-- (then n-tuple also must be 0-tuple, i.e. empty), in which case this
+-- routine just calls the routine func and returns zero.
+--
+-- This routine allows recursive calls from the routine func providing
+-- correct values of dummy indices for each instance.
+--
+-- NOTE: The n-tuple passed to this routine must not be changed by any
+-- other routines called from the formal routine func until this
+-- routine has returned. */
+
+struct eval_domain_info
+{ /* working info used by the routine eval_within_domain */
+ DOMAIN *domain;
+ /* domain, which has to be entered */
+ DOMAIN_BLOCK *block;
+ /* domain block, which is currently processed */
+ TUPLE *tuple;
+ /* tail of original n-tuple, whose components have to be assigned
+ to free dummy indices in the current domain block */
+ void *info;
+ /* transit pointer passed to the formal routine func */
+ void (*func)(MPL *mpl, void *info);
+ /* routine, which has to be executed in the domain scope */
+ int failure;
+ /* this flag indicates that given n-tuple is not a member of the
+ domain set */
+};
+
+static void eval_domain_func(MPL *mpl, void *_my_info)
+{ /* this routine recursively enters into the domain scope and then
+ calls the routine func */
+ struct eval_domain_info *my_info = _my_info;
+ if (my_info->block != NULL)
+ { /* the current domain block to be entered exists */
+ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ TUPLE *tuple = NULL, *temp = NULL;
+ /* save pointer to the current domain block */
+ block = my_info->block;
+ /* and get ready to enter the next block (if it exists) */
+ my_info->block = block->next;
+ /* construct temporary n-tuple, whose components correspond to
+ dummy indices (slots) of the current domain; components of
+ the temporary n-tuple that correspond to free dummy indices
+ are assigned references (not values!) to symbols specified
+ in the corresponding components of the given n-tuple, while
+ other components that correspond to non-free dummy indices
+ are assigned symbolic values computed here */
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ { /* create component that corresponds to the current slot */
+ if (tuple == NULL)
+ tuple = temp = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
+ else
+temp = (temp->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE)));
+ if (slot->code == NULL)
+ { /* dummy index is free; take reference to symbol, which
+ is specified in the corresponding component of given
+ n-tuple */
+ xassert(my_info->tuple != NULL);
+ temp->sym = my_info->tuple->sym;
+ xassert(temp->sym != NULL);
+ my_info->tuple = my_info->tuple->next;
+ }
+ else
+ { /* dummy index is non-free; compute symbolic value to be
+ temporarily assigned to the dummy index */
+ temp->sym = eval_symbolic(mpl, slot->code);
+ }
+ }
+ temp->next = NULL;
+ /* enter the current domain block */
+ if (enter_domain_block(mpl, block, tuple, my_info,
+ eval_domain_func)) my_info->failure = 1;
+ /* delete temporary n-tuple as well as symbols that correspond
+ to non-free dummy indices (they were computed here) */
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ { xassert(tuple != NULL);
+ temp = tuple;
+ tuple = tuple->next;
+ if (slot->code != NULL)
+ { /* dummy index is non-free; delete symbolic value */
+ delete_symbol(mpl, temp->sym);
+ }
+ /* delete component that corresponds to the current slot */
+ dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
+ }
+ }
+ else
+ { /* there are no more domain blocks, i.e. we have reached the
+ domain scope */
+ xassert(my_info->tuple == NULL);
+ /* check optional predicate specified for the domain */
+ if (my_info->domain->code != NULL && !eval_logical(mpl,
+ my_info->domain->code))
+ { /* the predicate is false */
+ my_info->failure = 2;
+ }
+ else
+ { /* the predicate is true; do the job */
+ my_info->func(mpl, my_info->info);
+ }
+ }
+ return;
+}
+
+int eval_within_domain
+( MPL *mpl,
+ DOMAIN *domain, /* not changed */
+ TUPLE *tuple, /* not changed */
+ void *info, void (*func)(MPL *mpl, void *info)
+)
+{ /* this routine performs evaluation within domain scope */
+ struct eval_domain_info _my_info, *my_info = &_my_info;
+ if (domain == NULL)
+ { xassert(tuple == NULL);
+ func(mpl, info);
+ my_info->failure = 0;
+ }
+ else
+ { xassert(tuple != NULL);
+ my_info->domain = domain;
+ my_info->block = domain->list;
+ my_info->tuple = tuple;
+ my_info->info = info;
+ my_info->func = func;
+ my_info->failure = 0;
+ /* enter the very first domain block */
+ eval_domain_func(mpl, my_info);
+ }
+ return my_info->failure;
+}
+
+/*----------------------------------------------------------------------
+-- loop_within_domain - perform iterations within domain scope.
+--
+-- This routine iteratively assigns new values (symbols) to the dummy
+-- indices of specified domain by enumerating all n-tuples, which are
+-- members of the domain set, and for every n-tuple it calls the formal
+-- routine func to evaluate some code within the domain scope.
+--
+-- If the routine func returns non-zero, enumeration within the domain
+-- is prematurely terminated.
+--
+-- For the sake of convenience it is allowed to specify domain as NULL,
+-- in which case this routine just calls the routine func only once and
+-- returns zero.
+--
+-- This routine allows recursive calls from the routine func providing
+-- correct values of dummy indices for each instance. */
+
+struct loop_domain_info
+{ /* working info used by the routine loop_within_domain */
+ DOMAIN *domain;
+ /* domain, which has to be entered */
+ DOMAIN_BLOCK *block;
+ /* domain block, which is currently processed */
+ int looping;
+ /* clearing this flag leads to terminating enumeration */
+ void *info;
+ /* transit pointer passed to the formal routine func */
+ int (*func)(MPL *mpl, void *info);
+ /* routine, which needs to be executed in the domain scope */
+};
+
+static void loop_domain_func(MPL *mpl, void *_my_info)
+{ /* this routine enumerates all n-tuples in the basic set of the
+ current domain block, enters recursively into the domain scope
+ for every n-tuple, and then calls the routine func */
+ struct loop_domain_info *my_info = _my_info;
+ if (my_info->block != NULL)
+ { /* the current domain block to be entered exists */
+ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ TUPLE *bound;
+ /* save pointer to the current domain block */
+ block = my_info->block;
+ /* and get ready to enter the next block (if it exists) */
+ my_info->block = block->next;
+ /* compute symbolic values, at which non-free dummy indices of
+ the current domain block are bound; since that values don't
+ depend on free dummy indices of the current block, they can
+ be computed once out of the enumeration loop */
+ bound = create_tuple(mpl);
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ { if (slot->code != NULL)
+ bound = expand_tuple(mpl, bound, eval_symbolic(mpl,
+ slot->code));
+ }
+ /* start enumeration */
+ xassert(block->code != NULL);
+ if (block->code->op == O_DOTS)
+ { /* the basic set is "arithmetic", in which case it doesn't
+ need to be computed explicitly */
+ TUPLE *tuple;
+ int n, j;
+ double t0, tf, dt;
+ /* compute "parameters" of the basic set */
+ t0 = eval_numeric(mpl, block->code->arg.arg.x);
+ tf = eval_numeric(mpl, block->code->arg.arg.y);
+ if (block->code->arg.arg.z == NULL)
+ dt = 1.0;
+ else
+ dt = eval_numeric(mpl, block->code->arg.arg.z);
+ /* determine cardinality of the basic set */
+ n = arelset_size(mpl, t0, tf, dt);
+ /* create dummy 1-tuple for members of the basic set */
+ tuple = expand_tuple(mpl, create_tuple(mpl),
+ create_symbol_num(mpl, 0.0));
+ /* in case of "arithmetic" set there is exactly one dummy
+ index, which cannot be non-free */
+ xassert(bound == NULL);
+ /* walk through 1-tuples of the basic set */
+ for (j = 1; j <= n && my_info->looping; j++)
+ { /* construct dummy 1-tuple for the current member */
+ tuple->sym->num = arelset_member(mpl, t0, tf, dt, j);
+ /* enter the current domain block */
+ enter_domain_block(mpl, block, tuple, my_info,
+ loop_domain_func);
+ }
+ /* delete dummy 1-tuple */
+ delete_tuple(mpl, tuple);
+ }
+ else
+ { /* the basic set is of general kind, in which case it needs
+ to be explicitly computed */
+ ELEMSET *set;
+ MEMBER *memb;
+ TUPLE *temp1, *temp2;
+ /* compute the basic set */
+ set = eval_elemset(mpl, block->code);
+ /* walk through all n-tuples of the basic set */
+ for (memb = set->head; memb != NULL && my_info->looping;
+ memb = memb->next)
+ { /* all components of the current n-tuple that correspond
+ to non-free dummy indices must be feasible; otherwise
+ the n-tuple is not in the basic set */
+ temp1 = memb->tuple;
+ temp2 = bound;
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ { xassert(temp1 != NULL);
+ if (slot->code != NULL)
+ { /* non-free dummy index */
+ xassert(temp2 != NULL);
+ if (compare_symbols(mpl, temp1->sym, temp2->sym)
+ != 0)
+ { /* the n-tuple is not in the basic set */
+ goto skip;
+ }
+ temp2 = temp2->next;
+ }
+ temp1 = temp1->next;
+ }
+ xassert(temp1 == NULL);
+ xassert(temp2 == NULL);
+ /* enter the current domain block */
+ enter_domain_block(mpl, block, memb->tuple, my_info,
+ loop_domain_func);
+skip: ;
+ }
+ /* delete the basic set */
+ delete_elemset(mpl, set);
+ }
+ /* delete symbolic values binding non-free dummy indices */
+ delete_tuple(mpl, bound);
+ /* restore pointer to the current domain block */
+ my_info->block = block;
+ }
+ else
+ { /* there are no more domain blocks, i.e. we have reached the
+ domain scope */
+ /* check optional predicate specified for the domain */
+ if (my_info->domain->code != NULL && !eval_logical(mpl,
+ my_info->domain->code))
+ { /* the predicate is false */
+ /* nop */;
+ }
+ else
+ { /* the predicate is true; do the job */
+ my_info->looping = !my_info->func(mpl, my_info->info);
+ }
+ }
+ return;
+}
+
+void loop_within_domain
+( MPL *mpl,
+ DOMAIN *domain, /* not changed */
+ void *info, int (*func)(MPL *mpl, void *info)
+)
+{ /* this routine performs iterations within domain scope */
+ struct loop_domain_info _my_info, *my_info = &_my_info;
+ if (domain == NULL)
+ func(mpl, info);
+ else
+ { my_info->domain = domain;
+ my_info->block = domain->list;
+ my_info->looping = 1;
+ my_info->info = info;
+ my_info->func = func;
+ /* enter the very first domain block */
+ loop_domain_func(mpl, my_info);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- out_of_domain - raise domain exception.
+--
+-- This routine is called when a reference is made to a member of some
+-- model object, but its n-tuple is out of the object domain. */
+
+void out_of_domain
+( MPL *mpl,
+ char *name, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ xassert(name != NULL);
+ xassert(tuple != NULL);
+ error(mpl, "%s%s out of domain", name, format_tuple(mpl, '[',
+ tuple));
+ /* no return */
+}
+
+/*----------------------------------------------------------------------
+-- get_domain_tuple - obtain current n-tuple from domain.
+--
+-- This routine constructs n-tuple, whose components are current values
+-- assigned to *free* dummy indices of specified domain.
+--
+-- For the sake of convenience it is allowed to specify domain as NULL,
+-- in which case this routine returns 0-tuple.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+TUPLE *get_domain_tuple
+( MPL *mpl,
+ DOMAIN *domain /* not changed */
+)
+{ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ TUPLE *tuple;
+ tuple = create_tuple(mpl);
+ if (domain != NULL)
+ { for (block = domain->list; block != NULL; block = block->next)
+ { for (slot = block->list; slot != NULL; slot = slot->next)
+ { if (slot->code == NULL)
+ { xassert(slot->value != NULL);
+ tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
+ slot->value));
+ }
+ }
+ }
+ }
+ return tuple;
+}
+
+/*----------------------------------------------------------------------
+-- clean_domain - clean domain.
+--
+-- This routine cleans specified domain that assumes deleting all stuff
+-- dynamically allocated during the generation phase. */
+
+void clean_domain(MPL *mpl, DOMAIN *domain)
+{ DOMAIN_BLOCK *block;
+ DOMAIN_SLOT *slot;
+ /* if no domain is specified, do nothing */
+ if (domain == NULL) goto done;
+ /* clean all domain blocks */
+ for (block = domain->list; block != NULL; block = block->next)
+ { /* clean all domain slots */
+ for (slot = block->list; slot != NULL; slot = slot->next)
+ { /* clean pseudo-code for computing bound value */
+ clean_code(mpl, slot->code);
+ /* delete symbolic value assigned to dummy index */
+ if (slot->value != NULL)
+ delete_symbol(mpl, slot->value), slot->value = NULL;
+ }
+ /* clean pseudo-code for computing basic set */
+ clean_code(mpl, block->code);
+ }
+ /* clean pseudo-code for computing domain predicate */
+ clean_code(mpl, domain->code);
+done: return;
+}
+
+/**********************************************************************/
+/* * * MODEL SETS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- check_elem_set - check elemental set assigned to set member.
+--
+-- This routine checks if given elemental set being assigned to member
+-- of specified model set satisfies to all restrictions.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+void check_elem_set
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple, /* not changed */
+ ELEMSET *refer /* not changed */
+)
+{ WITHIN *within;
+ MEMBER *memb;
+ int eqno;
+ /* elemental set must be within all specified supersets */
+ for (within = set->within, eqno = 1; within != NULL; within =
+ within->next, eqno++)
+ { xassert(within->code != NULL);
+ for (memb = refer->head; memb != NULL; memb = memb->next)
+ { if (!is_member(mpl, within->code, memb->tuple))
+ { char buf[255+1];
+ strcpy(buf, format_tuple(mpl, '(', memb->tuple));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s contains %s which not within specified "
+ "set; see (%d)", set->name, format_tuple(mpl, '[',
+ tuple), buf, eqno);
+ }
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- take_member_set - obtain elemental set assigned to set member.
+--
+-- This routine obtains a reference to elemental set assigned to given
+-- member of specified model set and returns it on exit.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+ELEMSET *take_member_set /* returns reference, not value */
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ ELEMSET *refer;
+ /* find member in the set array */
+ memb = find_member(mpl, set->array, tuple);
+ if (memb != NULL)
+ { /* member exists, so just take the reference */
+ refer = memb->value.set;
+ }
+ else if (set->assign != NULL)
+ { /* compute value using assignment expression */
+ refer = eval_elemset(mpl, set->assign);
+add: /* check that the elemental set satisfies to all restrictions,
+ assign it to new member, and add the member to the array */
+ check_elem_set(mpl, set, tuple, refer);
+ memb = add_member(mpl, set->array, copy_tuple(mpl, tuple));
+ memb->value.set = refer;
+ }
+ else if (set->option != NULL)
+ { /* compute default elemental set */
+ refer = eval_elemset(mpl, set->option);
+ goto add;
+ }
+ else
+ { /* no value (elemental set) is provided */
+ error(mpl, "no value for %s%s", set->name, format_tuple(mpl,
+ '[', tuple));
+ }
+ return refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_member_set - evaluate elemental set assigned to set member.
+--
+-- This routine evaluates a reference to elemental set assigned to given
+-- member of specified model set and returns it on exit. */
+
+struct eval_set_info
+{ /* working info used by the routine eval_member_set */
+ SET *set;
+ /* model set */
+ TUPLE *tuple;
+ /* n-tuple, which defines set member */
+ MEMBER *memb;
+ /* normally this pointer is NULL; the routine uses this pointer
+ to check data provided in the data section, in which case it
+ points to a member currently checked; this check is performed
+ automatically only once when a reference to any member occurs
+ for the first time */
+ ELEMSET *refer;
+ /* evaluated reference to elemental set */
+};
+
+static void eval_set_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine to work within domain scope */
+ struct eval_set_info *info = _info;
+ if (info->memb != NULL)
+ { /* checking call; check elemental set being assigned */
+ check_elem_set(mpl, info->set, info->memb->tuple,
+ info->memb->value.set);
+ }
+ else
+ { /* normal call; evaluate member, which has given n-tuple */
+ info->refer = take_member_set(mpl, info->set, info->tuple);
+ }
+ return;
+}
+
+#if 1 /* 12/XII-2008 */
+static void saturate_set(MPL *mpl, SET *set)
+{ GADGET *gadget = set->gadget;
+ ELEMSET *data;
+ MEMBER *elem, *memb;
+ TUPLE *tuple, *work[20];
+ int i;
+ xprintf("Generating %s...\n", set->name);
+ eval_whole_set(mpl, gadget->set);
+ /* gadget set must have exactly one member */
+ xassert(gadget->set->array != NULL);
+ xassert(gadget->set->array->head != NULL);
+ xassert(gadget->set->array->head == gadget->set->array->tail);
+ data = gadget->set->array->head->value.set;
+ xassert(data->type == A_NONE);
+ xassert(data->dim == gadget->set->dimen);
+ /* walk thru all elements of the plain set */
+ for (elem = data->head; elem != NULL; elem = elem->next)
+ { /* create a copy of n-tuple */
+ tuple = copy_tuple(mpl, elem->tuple);
+ /* rearrange component of the n-tuple */
+ for (i = 0; i < gadget->set->dimen; i++)
+ work[i] = NULL;
+ for (i = 0; tuple != NULL; tuple = tuple->next)
+ work[gadget->ind[i++]-1] = tuple;
+ xassert(i == gadget->set->dimen);
+ for (i = 0; i < gadget->set->dimen; i++)
+ { xassert(work[i] != NULL);
+ work[i]->next = work[i+1];
+ }
+ /* construct subscript list from first set->dim components */
+ if (set->dim == 0)
+ tuple = NULL;
+ else
+ tuple = work[0], work[set->dim-1]->next = NULL;
+ /* find corresponding member of the set to be initialized */
+ memb = find_member(mpl, set->array, tuple);
+ if (memb == NULL)
+ { /* not found; add new member to the set and assign it empty
+ elemental set */
+ memb = add_member(mpl, set->array, tuple);
+ memb->value.set = create_elemset(mpl, set->dimen);
+ }
+ else
+ { /* found; free subscript list */
+ delete_tuple(mpl, tuple);
+ }
+ /* construct new n-tuple from rest set->dimen components */
+ tuple = work[set->dim];
+ xassert(set->dim + set->dimen == gadget->set->dimen);
+ work[gadget->set->dimen-1]->next = NULL;
+ /* and add it to the elemental set assigned to the member
+ (no check for duplicates is needed) */
+ add_tuple(mpl, memb->value.set, tuple);
+ }
+ /* the set has been saturated with data */
+ set->data = 1;
+ return;
+}
+#endif
+
+ELEMSET *eval_member_set /* returns reference, not value */
+( MPL *mpl,
+ SET *set, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ /* this routine evaluates set member */
+ struct eval_set_info _info, *info = &_info;
+ xassert(set->dim == tuple_dimen(mpl, tuple));
+ info->set = set;
+ info->tuple = tuple;
+#if 1 /* 12/XII-2008 */
+ if (set->gadget != NULL && set->data == 0)
+ { /* initialize the set with data from a plain set */
+ saturate_set(mpl, set);
+ }
+#endif
+ if (set->data == 1)
+ { /* check data, which are provided in the data section, but not
+ checked yet */
+ /* save pointer to the last array member; note that during the
+ check new members may be added beyond the last member due to
+ references to the same parameter from default expression as
+ well as from expressions that define restricting supersets;
+ however, values assigned to the new members will be checked
+ by other routine, so we don't need to check them here */
+ MEMBER *tail = set->array->tail;
+ /* change the data status to prevent infinite recursive loop
+ due to references to the same set during the check */
+ set->data = 2;
+ /* check elemental sets assigned to array members in the data
+ section until the marked member has been reached */
+ for (info->memb = set->array->head; info->memb != NULL;
+ info->memb = info->memb->next)
+ { if (eval_within_domain(mpl, set->domain, info->memb->tuple,
+ info, eval_set_func))
+ out_of_domain(mpl, set->name, info->memb->tuple);
+ if (info->memb == tail) break;
+ }
+ /* the check has been finished */
+ }
+ /* evaluate member, which has given n-tuple */
+ info->memb = NULL;
+ if (eval_within_domain(mpl, info->set->domain, info->tuple, info,
+ eval_set_func))
+ out_of_domain(mpl, set->name, info->tuple);
+ /* bring evaluated reference to the calling program */
+ return info->refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_whole_set - evaluate model set over entire domain.
+--
+-- This routine evaluates all members of specified model set over entire
+-- domain. */
+
+static int whole_set_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ SET *set = (SET *)info;
+ TUPLE *tuple = get_domain_tuple(mpl, set->domain);
+ eval_member_set(mpl, set, tuple);
+ delete_tuple(mpl, tuple);
+ return 0;
+}
+
+void eval_whole_set(MPL *mpl, SET *set)
+{ loop_within_domain(mpl, set->domain, set, whole_set_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean set - clean model set.
+--
+-- This routine cleans specified model set that assumes deleting all
+-- stuff dynamically allocated during the generation phase. */
+
+void clean_set(MPL *mpl, SET *set)
+{ WITHIN *within;
+ MEMBER *memb;
+ /* clean subscript domain */
+ clean_domain(mpl, set->domain);
+ /* clean pseudo-code for computing supersets */
+ for (within = set->within; within != NULL; within = within->next)
+ clean_code(mpl, within->code);
+ /* clean pseudo-code for computing assigned value */
+ clean_code(mpl, set->assign);
+ /* clean pseudo-code for computing default value */
+ clean_code(mpl, set->option);
+ /* reset data status flag */
+ set->data = 0;
+ /* delete content array */
+ for (memb = set->array->head; memb != NULL; memb = memb->next)
+ delete_value(mpl, set->array->type, &memb->value);
+ delete_array(mpl, set->array), set->array = NULL;
+ return;
+}
+
+/**********************************************************************/
+/* * * MODEL PARAMETERS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- check_value_num - check numeric value assigned to parameter member.
+--
+-- This routine checks if numeric value being assigned to some member
+-- of specified numeric model parameter satisfies to all restrictions.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+void check_value_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple, /* not changed */
+ double value
+)
+{ CONDITION *cond;
+ WITHIN *in;
+ int eqno;
+ /* the value must satisfy to the parameter type */
+ switch (par->type)
+ { case A_NUMERIC:
+ break;
+ case A_INTEGER:
+ if (value != floor(value))
+ error(mpl, "%s%s = %.*g not integer", par->name,
+ format_tuple(mpl, '[', tuple), DBL_DIG, value);
+ break;
+ case A_BINARY:
+ if (!(value == 0.0 || value == 1.0))
+ error(mpl, "%s%s = %.*g not binary", par->name,
+ format_tuple(mpl, '[', tuple), DBL_DIG, value);
+ break;
+ default:
+ xassert(par != par);
+ }
+ /* the value must satisfy to all specified conditions */
+ for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next,
+ eqno++)
+ { double bound;
+ char *rho;
+ xassert(cond->code != NULL);
+ bound = eval_numeric(mpl, cond->code);
+ switch (cond->rho)
+ { case O_LT:
+ if (!(value < bound))
+ { rho = "<";
+err: error(mpl, "%s%s = %.*g not %s %.*g; see (%d)",
+ par->name, format_tuple(mpl, '[', tuple), DBL_DIG,
+ value, rho, DBL_DIG, bound, eqno);
+ }
+ break;
+ case O_LE:
+ if (!(value <= bound)) { rho = "<="; goto err; }
+ break;
+ case O_EQ:
+ if (!(value == bound)) { rho = "="; goto err; }
+ break;
+ case O_GE:
+ if (!(value >= bound)) { rho = ">="; goto err; }
+ break;
+ case O_GT:
+ if (!(value > bound)) { rho = ">"; goto err; }
+ break;
+ case O_NE:
+ if (!(value != bound)) { rho = "<>"; goto err; }
+ break;
+ default:
+ xassert(cond != cond);
+ }
+ }
+ /* the value must be in all specified supersets */
+ for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++)
+ { TUPLE *dummy;
+ xassert(in->code != NULL);
+ xassert(in->code->dim == 1);
+ dummy = expand_tuple(mpl, create_tuple(mpl),
+ create_symbol_num(mpl, value));
+ if (!is_member(mpl, in->code, dummy))
+ error(mpl, "%s%s = %.*g not in specified set; see (%d)",
+ par->name, format_tuple(mpl, '[', tuple), DBL_DIG,
+ value, eqno);
+ delete_tuple(mpl, dummy);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- take_member_num - obtain num. value assigned to parameter member.
+--
+-- This routine obtains a numeric value assigned to member of specified
+-- numeric model parameter and returns it on exit.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+double take_member_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ double value;
+ /* find member in the parameter array */
+ memb = find_member(mpl, par->array, tuple);
+ if (memb != NULL)
+ { /* member exists, so just take its value */
+ value = memb->value.num;
+ }
+ else if (par->assign != NULL)
+ { /* compute value using assignment expression */
+ value = eval_numeric(mpl, par->assign);
+add: /* check that the value satisfies to all restrictions, assign
+ it to new member, and add the member to the array */
+ check_value_num(mpl, par, tuple, value);
+ memb = add_member(mpl, par->array, copy_tuple(mpl, tuple));
+ memb->value.num = value;
+ }
+ else if (par->option != NULL)
+ { /* compute default value */
+ value = eval_numeric(mpl, par->option);
+ goto add;
+ }
+ else if (par->defval != NULL)
+ { /* take default value provided in the data section */
+ if (par->defval->str != NULL)
+ error(mpl, "cannot convert %s to floating-point number",
+ format_symbol(mpl, par->defval));
+ value = par->defval->num;
+ goto add;
+ }
+ else
+ { /* no value is provided */
+ error(mpl, "no value for %s%s", par->name, format_tuple(mpl,
+ '[', tuple));
+ }
+ return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_member_num - evaluate num. value assigned to parameter member.
+--
+-- This routine evaluates a numeric value assigned to given member of
+-- specified numeric model parameter and returns it on exit. */
+
+struct eval_num_info
+{ /* working info used by the routine eval_member_num */
+ PARAMETER *par;
+ /* model parameter */
+ TUPLE *tuple;
+ /* n-tuple, which defines parameter member */
+ MEMBER *memb;
+ /* normally this pointer is NULL; the routine uses this pointer
+ to check data provided in the data section, in which case it
+ points to a member currently checked; this check is performed
+ automatically only once when a reference to any member occurs
+ for the first time */
+ double value;
+ /* evaluated numeric value */
+};
+
+static void eval_num_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine to work within domain scope */
+ struct eval_num_info *info = _info;
+ if (info->memb != NULL)
+ { /* checking call; check numeric value being assigned */
+ check_value_num(mpl, info->par, info->memb->tuple,
+ info->memb->value.num);
+ }
+ else
+ { /* normal call; evaluate member, which has given n-tuple */
+ info->value = take_member_num(mpl, info->par, info->tuple);
+ }
+ return;
+}
+
+double eval_member_num
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ /* this routine evaluates numeric parameter member */
+ struct eval_num_info _info, *info = &_info;
+ xassert(par->type == A_NUMERIC || par->type == A_INTEGER ||
+ par->type == A_BINARY);
+ xassert(par->dim == tuple_dimen(mpl, tuple));
+ info->par = par;
+ info->tuple = tuple;
+ if (par->data == 1)
+ { /* check data, which are provided in the data section, but not
+ checked yet */
+ /* save pointer to the last array member; note that during the
+ check new members may be added beyond the last member due to
+ references to the same parameter from default expression as
+ well as from expressions that define restricting conditions;
+ however, values assigned to the new members will be checked
+ by other routine, so we don't need to check them here */
+ MEMBER *tail = par->array->tail;
+ /* change the data status to prevent infinite recursive loop
+ due to references to the same parameter during the check */
+ par->data = 2;
+ /* check values assigned to array members in the data section
+ until the marked member has been reached */
+ for (info->memb = par->array->head; info->memb != NULL;
+ info->memb = info->memb->next)
+ { if (eval_within_domain(mpl, par->domain, info->memb->tuple,
+ info, eval_num_func))
+ out_of_domain(mpl, par->name, info->memb->tuple);
+ if (info->memb == tail) break;
+ }
+ /* the check has been finished */
+ }
+ /* evaluate member, which has given n-tuple */
+ info->memb = NULL;
+ if (eval_within_domain(mpl, info->par->domain, info->tuple, info,
+ eval_num_func))
+ out_of_domain(mpl, par->name, info->tuple);
+ /* bring evaluated value to the calling program */
+ return info->value;
+}
+
+/*----------------------------------------------------------------------
+-- check_value_sym - check symbolic value assigned to parameter member.
+--
+-- This routine checks if symbolic value being assigned to some member
+-- of specified symbolic model parameter satisfies to all restrictions.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+void check_value_sym
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple, /* not changed */
+ SYMBOL *value /* not changed */
+)
+{ CONDITION *cond;
+ WITHIN *in;
+ int eqno;
+ /* the value must satisfy to all specified conditions */
+ for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next,
+ eqno++)
+ { SYMBOL *bound;
+ char buf[255+1];
+ xassert(cond->code != NULL);
+ bound = eval_symbolic(mpl, cond->code);
+ switch (cond->rho)
+ {
+#if 1 /* 13/VIII-2008 */
+ case O_LT:
+ if (!(compare_symbols(mpl, value, bound) < 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not < %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+ case O_LE:
+ if (!(compare_symbols(mpl, value, bound) <= 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not <= %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+#endif
+ case O_EQ:
+ if (!(compare_symbols(mpl, value, bound) == 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not = %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+#if 1 /* 13/VIII-2008 */
+ case O_GE:
+ if (!(compare_symbols(mpl, value, bound) >= 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not >= %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+ case O_GT:
+ if (!(compare_symbols(mpl, value, bound) > 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not > %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+#endif
+ case O_NE:
+ if (!(compare_symbols(mpl, value, bound) != 0))
+ { strcpy(buf, format_symbol(mpl, bound));
+ xassert(strlen(buf) < sizeof(buf));
+ error(mpl, "%s%s = %s not <> %s",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), buf, eqno);
+ }
+ break;
+ default:
+ xassert(cond != cond);
+ }
+ delete_symbol(mpl, bound);
+ }
+ /* the value must be in all specified supersets */
+ for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++)
+ { TUPLE *dummy;
+ xassert(in->code != NULL);
+ xassert(in->code->dim == 1);
+ dummy = expand_tuple(mpl, create_tuple(mpl), copy_symbol(mpl,
+ value));
+ if (!is_member(mpl, in->code, dummy))
+ error(mpl, "%s%s = %s not in specified set; see (%d)",
+ par->name, format_tuple(mpl, '[', tuple),
+ format_symbol(mpl, value), eqno);
+ delete_tuple(mpl, dummy);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- take_member_sym - obtain symb. value assigned to parameter member.
+--
+-- This routine obtains a symbolic value assigned to member of specified
+-- symbolic model parameter and returns it on exit.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+SYMBOL *take_member_sym /* returns value, not reference */
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ SYMBOL *value;
+ /* find member in the parameter array */
+ memb = find_member(mpl, par->array, tuple);
+ if (memb != NULL)
+ { /* member exists, so just take its value */
+ value = copy_symbol(mpl, memb->value.sym);
+ }
+ else if (par->assign != NULL)
+ { /* compute value using assignment expression */
+ value = eval_symbolic(mpl, par->assign);
+add: /* check that the value satisfies to all restrictions, assign
+ it to new member, and add the member to the array */
+ check_value_sym(mpl, par, tuple, value);
+ memb = add_member(mpl, par->array, copy_tuple(mpl, tuple));
+ memb->value.sym = copy_symbol(mpl, value);
+ }
+ else if (par->option != NULL)
+ { /* compute default value */
+ value = eval_symbolic(mpl, par->option);
+ goto add;
+ }
+ else if (par->defval != NULL)
+ { /* take default value provided in the data section */
+ value = copy_symbol(mpl, par->defval);
+ goto add;
+ }
+ else
+ { /* no value is provided */
+ error(mpl, "no value for %s%s", par->name, format_tuple(mpl,
+ '[', tuple));
+ }
+ return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_member_sym - evaluate symb. value assigned to parameter member.
+--
+-- This routine evaluates a symbolic value assigned to given member of
+-- specified symbolic model parameter and returns it on exit. */
+
+struct eval_sym_info
+{ /* working info used by the routine eval_member_sym */
+ PARAMETER *par;
+ /* model parameter */
+ TUPLE *tuple;
+ /* n-tuple, which defines parameter member */
+ MEMBER *memb;
+ /* normally this pointer is NULL; the routine uses this pointer
+ to check data provided in the data section, in which case it
+ points to a member currently checked; this check is performed
+ automatically only once when a reference to any member occurs
+ for the first time */
+ SYMBOL *value;
+ /* evaluated symbolic value */
+};
+
+static void eval_sym_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine to work within domain scope */
+ struct eval_sym_info *info = _info;
+ if (info->memb != NULL)
+ { /* checking call; check symbolic value being assigned */
+ check_value_sym(mpl, info->par, info->memb->tuple,
+ info->memb->value.sym);
+ }
+ else
+ { /* normal call; evaluate member, which has given n-tuple */
+ info->value = take_member_sym(mpl, info->par, info->tuple);
+ }
+ return;
+}
+
+SYMBOL *eval_member_sym /* returns value, not reference */
+( MPL *mpl,
+ PARAMETER *par, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ /* this routine evaluates symbolic parameter member */
+ struct eval_sym_info _info, *info = &_info;
+ xassert(par->type == A_SYMBOLIC);
+ xassert(par->dim == tuple_dimen(mpl, tuple));
+ info->par = par;
+ info->tuple = tuple;
+ if (par->data == 1)
+ { /* check data, which are provided in the data section, but not
+ checked yet */
+ /* save pointer to the last array member; note that during the
+ check new members may be added beyond the last member due to
+ references to the same parameter from default expression as
+ well as from expressions that define restricting conditions;
+ however, values assigned to the new members will be checked
+ by other routine, so we don't need to check them here */
+ MEMBER *tail = par->array->tail;
+ /* change the data status to prevent infinite recursive loop
+ due to references to the same parameter during the check */
+ par->data = 2;
+ /* check values assigned to array members in the data section
+ until the marked member has been reached */
+ for (info->memb = par->array->head; info->memb != NULL;
+ info->memb = info->memb->next)
+ { if (eval_within_domain(mpl, par->domain, info->memb->tuple,
+ info, eval_sym_func))
+ out_of_domain(mpl, par->name, info->memb->tuple);
+ if (info->memb == tail) break;
+ }
+ /* the check has been finished */
+ }
+ /* evaluate member, which has given n-tuple */
+ info->memb = NULL;
+ if (eval_within_domain(mpl, info->par->domain, info->tuple, info,
+ eval_sym_func))
+ out_of_domain(mpl, par->name, info->tuple);
+ /* bring evaluated value to the calling program */
+ return info->value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_whole_par - evaluate model parameter over entire domain.
+--
+-- This routine evaluates all members of specified model parameter over
+-- entire domain. */
+
+static int whole_par_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ PARAMETER *par = (PARAMETER *)info;
+ TUPLE *tuple = get_domain_tuple(mpl, par->domain);
+ switch (par->type)
+ { case A_NUMERIC:
+ case A_INTEGER:
+ case A_BINARY:
+ eval_member_num(mpl, par, tuple);
+ break;
+ case A_SYMBOLIC:
+ delete_symbol(mpl, eval_member_sym(mpl, par, tuple));
+ break;
+ default:
+ xassert(par != par);
+ }
+ delete_tuple(mpl, tuple);
+ return 0;
+}
+
+void eval_whole_par(MPL *mpl, PARAMETER *par)
+{ loop_within_domain(mpl, par->domain, par, whole_par_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_parameter - clean model parameter.
+--
+-- This routine cleans specified model parameter that assumes deleting
+-- all stuff dynamically allocated during the generation phase. */
+
+void clean_parameter(MPL *mpl, PARAMETER *par)
+{ CONDITION *cond;
+ WITHIN *in;
+ MEMBER *memb;
+ /* clean subscript domain */
+ clean_domain(mpl, par->domain);
+ /* clean pseudo-code for computing restricting conditions */
+ for (cond = par->cond; cond != NULL; cond = cond->next)
+ clean_code(mpl, cond->code);
+ /* clean pseudo-code for computing restricting supersets */
+ for (in = par->in; in != NULL; in = in->next)
+ clean_code(mpl, in->code);
+ /* clean pseudo-code for computing assigned value */
+ clean_code(mpl, par->assign);
+ /* clean pseudo-code for computing default value */
+ clean_code(mpl, par->option);
+ /* reset data status flag */
+ par->data = 0;
+ /* delete default symbolic value */
+ if (par->defval != NULL)
+ delete_symbol(mpl, par->defval), par->defval = NULL;
+ /* delete content array */
+ for (memb = par->array->head; memb != NULL; memb = memb->next)
+ delete_value(mpl, par->array->type, &memb->value);
+ delete_array(mpl, par->array), par->array = NULL;
+ return;
+}
+
+/**********************************************************************/
+/* * * MODEL VARIABLES * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- take_member_var - obtain reference to elemental variable.
+--
+-- This routine obtains a reference to elemental variable assigned to
+-- given member of specified model variable and returns it on exit. If
+-- necessary, new elemental variable is created.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+ELEMVAR *take_member_var /* returns reference */
+( MPL *mpl,
+ VARIABLE *var, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ ELEMVAR *refer;
+ /* find member in the variable array */
+ memb = find_member(mpl, var->array, tuple);
+ if (memb != NULL)
+ { /* member exists, so just take the reference */
+ refer = memb->value.var;
+ }
+ else
+ { /* member is referenced for the first time and therefore does
+ not exist; create new elemental variable, assign it to new
+ member, and add the member to the variable array */
+ memb = add_member(mpl, var->array, copy_tuple(mpl, tuple));
+ refer = (memb->value.var =
+ dmp_get_atom(mpl->elemvars, sizeof(ELEMVAR)));
+ refer->j = 0;
+ refer->var = var;
+ refer->memb = memb;
+ /* compute lower bound */
+ if (var->lbnd == NULL)
+ refer->lbnd = 0.0;
+ else
+ refer->lbnd = eval_numeric(mpl, var->lbnd);
+ /* compute upper bound */
+ if (var->ubnd == NULL)
+ refer->ubnd = 0.0;
+ else if (var->ubnd == var->lbnd)
+ refer->ubnd = refer->lbnd;
+ else
+ refer->ubnd = eval_numeric(mpl, var->ubnd);
+ /* nullify working quantity */
+ refer->temp = 0.0;
+#if 1 /* 15/V-2010 */
+ /* solution has not been obtained by the solver yet */
+ refer->stat = 0;
+ refer->prim = refer->dual = 0.0;
+#endif
+ }
+ return refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_member_var - evaluate reference to elemental variable.
+--
+-- This routine evaluates a reference to elemental variable assigned to
+-- member of specified model variable and returns it on exit. */
+
+struct eval_var_info
+{ /* working info used by the routine eval_member_var */
+ VARIABLE *var;
+ /* model variable */
+ TUPLE *tuple;
+ /* n-tuple, which defines variable member */
+ ELEMVAR *refer;
+ /* evaluated reference to elemental variable */
+};
+
+static void eval_var_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine to work within domain scope */
+ struct eval_var_info *info = _info;
+ info->refer = take_member_var(mpl, info->var, info->tuple);
+ return;
+}
+
+ELEMVAR *eval_member_var /* returns reference */
+( MPL *mpl,
+ VARIABLE *var, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ /* this routine evaluates variable member */
+ struct eval_var_info _info, *info = &_info;
+ xassert(var->dim == tuple_dimen(mpl, tuple));
+ info->var = var;
+ info->tuple = tuple;
+ /* evaluate member, which has given n-tuple */
+ if (eval_within_domain(mpl, info->var->domain, info->tuple, info,
+ eval_var_func))
+ out_of_domain(mpl, var->name, info->tuple);
+ /* bring evaluated reference to the calling program */
+ return info->refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_whole_var - evaluate model variable over entire domain.
+--
+-- This routine evaluates all members of specified model variable over
+-- entire domain. */
+
+static int whole_var_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ VARIABLE *var = (VARIABLE *)info;
+ TUPLE *tuple = get_domain_tuple(mpl, var->domain);
+ eval_member_var(mpl, var, tuple);
+ delete_tuple(mpl, tuple);
+ return 0;
+}
+
+void eval_whole_var(MPL *mpl, VARIABLE *var)
+{ loop_within_domain(mpl, var->domain, var, whole_var_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_variable - clean model variable.
+--
+-- This routine cleans specified model variable that assumes deleting
+-- all stuff dynamically allocated during the generation phase. */
+
+void clean_variable(MPL *mpl, VARIABLE *var)
+{ MEMBER *memb;
+ /* clean subscript domain */
+ clean_domain(mpl, var->domain);
+ /* clean code for computing lower bound */
+ clean_code(mpl, var->lbnd);
+ /* clean code for computing upper bound */
+ if (var->ubnd != var->lbnd) clean_code(mpl, var->ubnd);
+ /* delete content array */
+ for (memb = var->array->head; memb != NULL; memb = memb->next)
+ dmp_free_atom(mpl->elemvars, memb->value.var, sizeof(ELEMVAR));
+ delete_array(mpl, var->array), var->array = NULL;
+ return;
+}
+
+/**********************************************************************/
+/* * * MODEL CONSTRAINTS AND OBJECTIVES * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- take_member_con - obtain reference to elemental constraint.
+--
+-- This routine obtains a reference to elemental constraint assigned
+-- to given member of specified model constraint and returns it on exit.
+-- If necessary, new elemental constraint is created.
+--
+-- NOTE: This routine must not be called out of domain scope. */
+
+ELEMCON *take_member_con /* returns reference */
+( MPL *mpl,
+ CONSTRAINT *con, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ MEMBER *memb;
+ ELEMCON *refer;
+ /* find member in the constraint array */
+ memb = find_member(mpl, con->array, tuple);
+ if (memb != NULL)
+ { /* member exists, so just take the reference */
+ refer = memb->value.con;
+ }
+ else
+ { /* member is referenced for the first time and therefore does
+ not exist; create new elemental constraint, assign it to new
+ member, and add the member to the constraint array */
+ memb = add_member(mpl, con->array, copy_tuple(mpl, tuple));
+ refer = (memb->value.con =
+ dmp_get_atom(mpl->elemcons, sizeof(ELEMCON)));
+ refer->i = 0;
+ refer->con = con;
+ refer->memb = memb;
+ /* compute linear form */
+ xassert(con->code != NULL);
+ refer->form = eval_formula(mpl, con->code);
+ /* compute lower and upper bounds */
+ if (con->lbnd == NULL && con->ubnd == NULL)
+ { /* objective has no bounds */
+ double temp;
+ xassert(con->type == A_MINIMIZE || con->type == A_MAXIMIZE);
+ /* carry the constant term to the right-hand side */
+ refer->form = remove_constant(mpl, refer->form, &temp);
+ refer->lbnd = refer->ubnd = - temp;
+ }
+ else if (con->lbnd != NULL && con->ubnd == NULL)
+ { /* constraint a * x + b >= c * y + d is transformed to the
+ standard form a * x - c * y >= d - b */
+ double temp;
+ xassert(con->type == A_CONSTRAINT);
+ refer->form = linear_comb(mpl,
+ +1.0, refer->form,
+ -1.0, eval_formula(mpl, con->lbnd));
+ refer->form = remove_constant(mpl, refer->form, &temp);
+ refer->lbnd = - temp;
+ refer->ubnd = 0.0;
+ }
+ else if (con->lbnd == NULL && con->ubnd != NULL)
+ { /* constraint a * x + b <= c * y + d is transformed to the
+ standard form a * x - c * y <= d - b */
+ double temp;
+ xassert(con->type == A_CONSTRAINT);
+ refer->form = linear_comb(mpl,
+ +1.0, refer->form,
+ -1.0, eval_formula(mpl, con->ubnd));
+ refer->form = remove_constant(mpl, refer->form, &temp);
+ refer->lbnd = 0.0;
+ refer->ubnd = - temp;
+ }
+ else if (con->lbnd == con->ubnd)
+ { /* constraint a * x + b = c * y + d is transformed to the
+ standard form a * x - c * y = d - b */
+ double temp;
+ xassert(con->type == A_CONSTRAINT);
+ refer->form = linear_comb(mpl,
+ +1.0, refer->form,
+ -1.0, eval_formula(mpl, con->lbnd));
+ refer->form = remove_constant(mpl, refer->form, &temp);
+ refer->lbnd = refer->ubnd = - temp;
+ }
+ else
+ { /* ranged constraint c <= a * x + b <= d is transformed to
+ the standard form c - b <= a * x <= d - b */
+ double temp, temp1, temp2;
+ xassert(con->type == A_CONSTRAINT);
+ refer->form = remove_constant(mpl, refer->form, &temp);
+ xassert(remove_constant(mpl, eval_formula(mpl, con->lbnd),
+ &temp1) == NULL);
+ xassert(remove_constant(mpl, eval_formula(mpl, con->ubnd),
+ &temp2) == NULL);
+ refer->lbnd = fp_sub(mpl, temp1, temp);
+ refer->ubnd = fp_sub(mpl, temp2, temp);
+ }
+#if 1 /* 15/V-2010 */
+ /* solution has not been obtained by the solver yet */
+ refer->stat = 0;
+ refer->prim = refer->dual = 0.0;
+#endif
+ }
+ return refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_member_con - evaluate reference to elemental constraint.
+--
+-- This routine evaluates a reference to elemental constraint assigned
+-- to member of specified model constraint and returns it on exit. */
+
+struct eval_con_info
+{ /* working info used by the routine eval_member_con */
+ CONSTRAINT *con;
+ /* model constraint */
+ TUPLE *tuple;
+ /* n-tuple, which defines constraint member */
+ ELEMCON *refer;
+ /* evaluated reference to elemental constraint */
+};
+
+static void eval_con_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine to work within domain scope */
+ struct eval_con_info *info = _info;
+ info->refer = take_member_con(mpl, info->con, info->tuple);
+ return;
+}
+
+ELEMCON *eval_member_con /* returns reference */
+( MPL *mpl,
+ CONSTRAINT *con, /* not changed */
+ TUPLE *tuple /* not changed */
+)
+{ /* this routine evaluates constraint member */
+ struct eval_con_info _info, *info = &_info;
+ xassert(con->dim == tuple_dimen(mpl, tuple));
+ info->con = con;
+ info->tuple = tuple;
+ /* evaluate member, which has given n-tuple */
+ if (eval_within_domain(mpl, info->con->domain, info->tuple, info,
+ eval_con_func))
+ out_of_domain(mpl, con->name, info->tuple);
+ /* bring evaluated reference to the calling program */
+ return info->refer;
+}
+
+/*----------------------------------------------------------------------
+-- eval_whole_con - evaluate model constraint over entire domain.
+--
+-- This routine evaluates all members of specified model constraint over
+-- entire domain. */
+
+static int whole_con_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ CONSTRAINT *con = (CONSTRAINT *)info;
+ TUPLE *tuple = get_domain_tuple(mpl, con->domain);
+ eval_member_con(mpl, con, tuple);
+ delete_tuple(mpl, tuple);
+ return 0;
+}
+
+void eval_whole_con(MPL *mpl, CONSTRAINT *con)
+{ loop_within_domain(mpl, con->domain, con, whole_con_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_constraint - clean model constraint.
+--
+-- This routine cleans specified model constraint that assumes deleting
+-- all stuff dynamically allocated during the generation phase. */
+
+void clean_constraint(MPL *mpl, CONSTRAINT *con)
+{ MEMBER *memb;
+ /* clean subscript domain */
+ clean_domain(mpl, con->domain);
+ /* clean code for computing main linear form */
+ clean_code(mpl, con->code);
+ /* clean code for computing lower bound */
+ clean_code(mpl, con->lbnd);
+ /* clean code for computing upper bound */
+ if (con->ubnd != con->lbnd) clean_code(mpl, con->ubnd);
+ /* delete content array */
+ for (memb = con->array->head; memb != NULL; memb = memb->next)
+ { delete_formula(mpl, memb->value.con->form);
+ dmp_free_atom(mpl->elemcons, memb->value.con, sizeof(ELEMCON));
+ }
+ delete_array(mpl, con->array), con->array = NULL;
+ return;
+}
+
+/**********************************************************************/
+/* * * PSEUDO-CODE * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- eval_numeric - evaluate pseudo-code to determine numeric value.
+--
+-- This routine evaluates specified pseudo-code to determine resultant
+-- numeric value, which is returned on exit. */
+
+struct iter_num_info
+{ /* working info used by the routine iter_num_func */
+ CODE *code;
+ /* pseudo-code for iterated operation to be performed */
+ double value;
+ /* resultant value */
+};
+
+static int iter_num_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine used to perform iterated operation
+ on numeric "integrand" within domain scope */
+ struct iter_num_info *info = _info;
+ double temp;
+ temp = eval_numeric(mpl, info->code->arg.loop.x);
+ switch (info->code->op)
+ { case O_SUM:
+ /* summation over domain */
+ info->value = fp_add(mpl, info->value, temp);
+ break;
+ case O_PROD:
+ /* multiplication over domain */
+ info->value = fp_mul(mpl, info->value, temp);
+ break;
+ case O_MINIMUM:
+ /* minimum over domain */
+ if (info->value > temp) info->value = temp;
+ break;
+ case O_MAXIMUM:
+ /* maximum over domain */
+ if (info->value < temp) info->value = temp;
+ break;
+ default:
+ xassert(info != info);
+ }
+ return 0;
+}
+
+double eval_numeric(MPL *mpl, CODE *code)
+{ double value;
+ xassert(code != NULL);
+ xassert(code->type == A_NUMERIC);
+ xassert(code->dim == 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = code->value.num;
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_NUMBER:
+ /* take floating-point number */
+ value = code->arg.num;
+ break;
+ case O_MEMNUM:
+ /* take member of numeric parameter */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+ tuple = create_tuple(mpl);
+ for (e = code->arg.par.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+ value = eval_member_num(mpl, code->arg.par.par, tuple);
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_MEMVAR:
+ /* take computed value of elemental variable */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+#if 1 /* 15/V-2010 */
+ ELEMVAR *var;
+#endif
+ tuple = create_tuple(mpl);
+ for (e = code->arg.var.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+#if 0 /* 15/V-2010 */
+ value = eval_member_var(mpl, code->arg.var.var, tuple)
+ ->value;
+#else
+ var = eval_member_var(mpl, code->arg.var.var, tuple);
+ switch (code->arg.var.suff)
+ { case DOT_LB:
+ if (var->var->lbnd == NULL)
+ value = -DBL_MAX;
+ else
+ value = var->lbnd;
+ break;
+ case DOT_UB:
+ if (var->var->ubnd == NULL)
+ value = +DBL_MAX;
+ else
+ value = var->ubnd;
+ break;
+ case DOT_STATUS:
+ value = var->stat;
+ break;
+ case DOT_VAL:
+ value = var->prim;
+ break;
+ case DOT_DUAL:
+ value = var->dual;
+ break;
+ default:
+ xassert(code != code);
+ }
+#endif
+ delete_tuple(mpl, tuple);
+ }
+ break;
+#if 1 /* 15/V-2010 */
+ case O_MEMCON:
+ /* take computed value of elemental constraint */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+ ELEMCON *con;
+ tuple = create_tuple(mpl);
+ for (e = code->arg.con.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+ con = eval_member_con(mpl, code->arg.con.con, tuple);
+ switch (code->arg.con.suff)
+ { case DOT_LB:
+ if (con->con->lbnd == NULL)
+ value = -DBL_MAX;
+ else
+ value = con->lbnd;
+ break;
+ case DOT_UB:
+ if (con->con->ubnd == NULL)
+ value = +DBL_MAX;
+ else
+ value = con->ubnd;
+ break;
+ case DOT_STATUS:
+ value = con->stat;
+ break;
+ case DOT_VAL:
+ value = con->prim;
+ break;
+ case DOT_DUAL:
+ value = con->dual;
+ break;
+ default:
+ xassert(code != code);
+ }
+ delete_tuple(mpl, tuple);
+ }
+ break;
+#endif
+ case O_IRAND224:
+ /* pseudo-random in [0, 2^24-1] */
+ value = fp_irand224(mpl);
+ break;
+ case O_UNIFORM01:
+ /* pseudo-random in [0, 1) */
+ value = fp_uniform01(mpl);
+ break;
+ case O_NORMAL01:
+ /* gaussian random, mu = 0, sigma = 1 */
+ value = fp_normal01(mpl);
+ break;
+ case O_GMTIME:
+ /* current calendar time */
+ value = fn_gmtime(mpl);
+ break;
+ case O_CVTNUM:
+ /* conversion to numeric */
+ { SYMBOL *sym;
+ sym = eval_symbolic(mpl, code->arg.arg.x);
+#if 0 /* 23/XI-2008 */
+ if (sym->str != NULL)
+ error(mpl, "cannot convert %s to floating-point numbe"
+ "r", format_symbol(mpl, sym));
+ value = sym->num;
+#else
+ if (sym->str == NULL)
+ value = sym->num;
+ else
+ { if (str2num(sym->str, &value))
+ error(mpl, "cannot convert %s to floating-point nu"
+ "mber", format_symbol(mpl, sym));
+ }
+#endif
+ delete_symbol(mpl, sym);
+ }
+ break;
+ case O_PLUS:
+ /* unary plus */
+ value = + eval_numeric(mpl, code->arg.arg.x);
+ break;
+ case O_MINUS:
+ /* unary minus */
+ value = - eval_numeric(mpl, code->arg.arg.x);
+ break;
+ case O_ABS:
+ /* absolute value */
+ value = fabs(eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_CEIL:
+ /* round upward ("ceiling of x") */
+ value = ceil(eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_FLOOR:
+ /* round downward ("floor of x") */
+ value = floor(eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_EXP:
+ /* base-e exponential */
+ value = fp_exp(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_LOG:
+ /* natural logarithm */
+ value = fp_log(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_LOG10:
+ /* common (decimal) logarithm */
+ value = fp_log10(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_SQRT:
+ /* square root */
+ value = fp_sqrt(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_SIN:
+ /* trigonometric sine */
+ value = fp_sin(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_COS:
+ /* trigonometric cosine */
+ value = fp_cos(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_TAN:
+ /* trigonometric tangent */
+ value = fp_tan(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_ATAN:
+ /* trigonometric arctangent (one argument) */
+ value = fp_atan(mpl, eval_numeric(mpl, code->arg.arg.x));
+ break;
+ case O_ATAN2:
+ /* trigonometric arctangent (two arguments) */
+ value = fp_atan2(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_ROUND:
+ /* round to nearest integer */
+ value = fp_round(mpl,
+ eval_numeric(mpl, code->arg.arg.x), 0.0);
+ break;
+ case O_ROUND2:
+ /* round to n fractional digits */
+ value = fp_round(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_TRUNC:
+ /* truncate to nearest integer */
+ value = fp_trunc(mpl,
+ eval_numeric(mpl, code->arg.arg.x), 0.0);
+ break;
+ case O_TRUNC2:
+ /* truncate to n fractional digits */
+ value = fp_trunc(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_ADD:
+ /* addition */
+ value = fp_add(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_SUB:
+ /* subtraction */
+ value = fp_sub(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_LESS:
+ /* non-negative subtraction */
+ value = fp_less(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_MUL:
+ /* multiplication */
+ value = fp_mul(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_DIV:
+ /* division */
+ value = fp_div(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_IDIV:
+ /* quotient of exact division */
+ value = fp_idiv(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_MOD:
+ /* remainder of exact division */
+ value = fp_mod(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_POWER:
+ /* exponentiation (raise to power) */
+ value = fp_power(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_UNIFORM:
+ /* pseudo-random in [a, b) */
+ value = fp_uniform(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_NORMAL:
+ /* gaussian random, given mu and sigma */
+ value = fp_normal(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y));
+ break;
+ case O_CARD:
+ { ELEMSET *set;
+ set = eval_elemset(mpl, code->arg.arg.x);
+ value = set->size;
+ delete_array(mpl, set);
+ }
+ break;
+ case O_LENGTH:
+ { SYMBOL *sym;
+ char str[MAX_LENGTH+1];
+ sym = eval_symbolic(mpl, code->arg.arg.x);
+ if (sym->str == NULL)
+ sprintf(str, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, str);
+ delete_symbol(mpl, sym);
+ value = strlen(str);
+ }
+ break;
+ case O_STR2TIME:
+ { SYMBOL *sym;
+ char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1];
+ sym = eval_symbolic(mpl, code->arg.arg.x);
+ if (sym->str == NULL)
+ sprintf(str, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, str);
+ delete_symbol(mpl, sym);
+ sym = eval_symbolic(mpl, code->arg.arg.y);
+ if (sym->str == NULL)
+ sprintf(fmt, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, fmt);
+ delete_symbol(mpl, sym);
+ value = fn_str2time(mpl, str, fmt);
+ }
+ break;
+ case O_FORK:
+ /* if-then-else */
+ if (eval_logical(mpl, code->arg.arg.x))
+ value = eval_numeric(mpl, code->arg.arg.y);
+ else if (code->arg.arg.z == NULL)
+ value = 0.0;
+ else
+ value = eval_numeric(mpl, code->arg.arg.z);
+ break;
+ case O_MIN:
+ /* minimal value (n-ary) */
+ { ARG_LIST *e;
+ double temp;
+ value = +DBL_MAX;
+ for (e = code->arg.list; e != NULL; e = e->next)
+ { temp = eval_numeric(mpl, e->x);
+ if (value > temp) value = temp;
+ }
+ }
+ break;
+ case O_MAX:
+ /* maximal value (n-ary) */
+ { ARG_LIST *e;
+ double temp;
+ value = -DBL_MAX;
+ for (e = code->arg.list; e != NULL; e = e->next)
+ { temp = eval_numeric(mpl, e->x);
+ if (value < temp) value = temp;
+ }
+ }
+ break;
+ case O_SUM:
+ /* summation over domain */
+ { struct iter_num_info _info, *info = &_info;
+ info->code = code;
+ info->value = 0.0;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_num_func);
+ value = info->value;
+ }
+ break;
+ case O_PROD:
+ /* multiplication over domain */
+ { struct iter_num_info _info, *info = &_info;
+ info->code = code;
+ info->value = 1.0;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_num_func);
+ value = info->value;
+ }
+ break;
+ case O_MINIMUM:
+ /* minimum over domain */
+ { struct iter_num_info _info, *info = &_info;
+ info->code = code;
+ info->value = +DBL_MAX;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_num_func);
+ if (info->value == +DBL_MAX)
+ error(mpl, "min{} over empty set; result undefined");
+ value = info->value;
+ }
+ break;
+ case O_MAXIMUM:
+ /* maximum over domain */
+ { struct iter_num_info _info, *info = &_info;
+ info->code = code;
+ info->value = -DBL_MAX;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_num_func);
+ if (info->value == -DBL_MAX)
+ error(mpl, "max{} over empty set; result undefined");
+ value = info->value;
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.num = value;
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_symbolic - evaluate pseudo-code to determine symbolic value.
+--
+-- This routine evaluates specified pseudo-code to determine resultant
+-- symbolic value, which is returned on exit. */
+
+SYMBOL *eval_symbolic(MPL *mpl, CODE *code)
+{ SYMBOL *value;
+ xassert(code != NULL);
+ xassert(code->type == A_SYMBOLIC);
+ xassert(code->dim == 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = copy_symbol(mpl, code->value.sym);
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_STRING:
+ /* take character string */
+ value = create_symbol_str(mpl, create_string(mpl,
+ code->arg.str));
+ break;
+ case O_INDEX:
+ /* take dummy index */
+ xassert(code->arg.index.slot->value != NULL);
+ value = copy_symbol(mpl, code->arg.index.slot->value);
+ break;
+ case O_MEMSYM:
+ /* take member of symbolic parameter */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+ tuple = create_tuple(mpl);
+ for (e = code->arg.par.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+ value = eval_member_sym(mpl, code->arg.par.par, tuple);
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_CVTSYM:
+ /* conversion to symbolic */
+ value = create_symbol_num(mpl, eval_numeric(mpl,
+ code->arg.arg.x));
+ break;
+ case O_CONCAT:
+ /* concatenation */
+ value = concat_symbols(mpl,
+ eval_symbolic(mpl, code->arg.arg.x),
+ eval_symbolic(mpl, code->arg.arg.y));
+ break;
+ case O_FORK:
+ /* if-then-else */
+ if (eval_logical(mpl, code->arg.arg.x))
+ value = eval_symbolic(mpl, code->arg.arg.y);
+ else if (code->arg.arg.z == NULL)
+ value = create_symbol_num(mpl, 0.0);
+ else
+ value = eval_symbolic(mpl, code->arg.arg.z);
+ break;
+ case O_SUBSTR:
+ case O_SUBSTR3:
+ { double pos, len;
+ char str[MAX_LENGTH+1];
+ value = eval_symbolic(mpl, code->arg.arg.x);
+ if (value->str == NULL)
+ sprintf(str, "%.*g", DBL_DIG, value->num);
+ else
+ fetch_string(mpl, value->str, str);
+ delete_symbol(mpl, value);
+ if (code->op == O_SUBSTR)
+ { pos = eval_numeric(mpl, code->arg.arg.y);
+ if (pos != floor(pos))
+ error(mpl, "substr('...', %.*g); non-integer secon"
+ "d argument", DBL_DIG, pos);
+ if (pos < 1 || pos > strlen(str) + 1)
+ error(mpl, "substr('...', %.*g); substring out of "
+ "range", DBL_DIG, pos);
+ }
+ else
+ { pos = eval_numeric(mpl, code->arg.arg.y);
+ len = eval_numeric(mpl, code->arg.arg.z);
+ if (pos != floor(pos) || len != floor(len))
+ error(mpl, "substr('...', %.*g, %.*g); non-integer"
+ " second and/or third argument", DBL_DIG, pos,
+ DBL_DIG, len);
+ if (pos < 1 || len < 0 || pos + len > strlen(str) + 1)
+ error(mpl, "substr('...', %.*g, %.*g); substring o"
+ "ut of range", DBL_DIG, pos, DBL_DIG, len);
+ str[(int)pos + (int)len - 1] = '\0';
+ }
+ value = create_symbol_str(mpl, create_string(mpl, str +
+ (int)pos - 1));
+ }
+ break;
+ case O_TIME2STR:
+ { double num;
+ SYMBOL *sym;
+ char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1];
+ num = eval_numeric(mpl, code->arg.arg.x);
+ sym = eval_symbolic(mpl, code->arg.arg.y);
+ if (sym->str == NULL)
+ sprintf(fmt, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, fmt);
+ delete_symbol(mpl, sym);
+ fn_time2str(mpl, str, num, fmt);
+ value = create_symbol_str(mpl, create_string(mpl, str));
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.sym = copy_symbol(mpl, value);
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_logical - evaluate pseudo-code to determine logical value.
+--
+-- This routine evaluates specified pseudo-code to determine resultant
+-- logical value, which is returned on exit. */
+
+struct iter_log_info
+{ /* working info used by the routine iter_log_func */
+ CODE *code;
+ /* pseudo-code for iterated operation to be performed */
+ int value;
+ /* resultant value */
+};
+
+static int iter_log_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine used to perform iterated operation
+ on logical "integrand" within domain scope */
+ struct iter_log_info *info = _info;
+ int ret = 0;
+ switch (info->code->op)
+ { case O_FORALL:
+ /* conjunction over domain */
+ info->value &= eval_logical(mpl, info->code->arg.loop.x);
+ if (!info->value) ret = 1;
+ break;
+ case O_EXISTS:
+ /* disjunction over domain */
+ info->value |= eval_logical(mpl, info->code->arg.loop.x);
+ if (info->value) ret = 1;
+ break;
+ default:
+ xassert(info != info);
+ }
+ return ret;
+}
+
+int eval_logical(MPL *mpl, CODE *code)
+{ int value;
+ xassert(code->type == A_LOGICAL);
+ xassert(code->dim == 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = code->value.bit;
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_CVTLOG:
+ /* conversion to logical */
+ value = (eval_numeric(mpl, code->arg.arg.x) != 0.0);
+ break;
+ case O_NOT:
+ /* negation (logical "not") */
+ value = !eval_logical(mpl, code->arg.arg.x);
+ break;
+ case O_LT:
+ /* comparison on 'less than' */
+#if 0 /* 02/VIII-2008 */
+ value = (eval_numeric(mpl, code->arg.arg.x) <
+ eval_numeric(mpl, code->arg.arg.y));
+#else
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) <
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) < 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+#endif
+ break;
+ case O_LE:
+ /* comparison on 'not greater than' */
+#if 0 /* 02/VIII-2008 */
+ value = (eval_numeric(mpl, code->arg.arg.x) <=
+ eval_numeric(mpl, code->arg.arg.y));
+#else
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) <=
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) <= 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+#endif
+ break;
+ case O_EQ:
+ /* comparison on 'equal to' */
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) ==
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) == 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+ break;
+ case O_GE:
+ /* comparison on 'not less than' */
+#if 0 /* 02/VIII-2008 */
+ value = (eval_numeric(mpl, code->arg.arg.x) >=
+ eval_numeric(mpl, code->arg.arg.y));
+#else
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) >=
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) >= 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+#endif
+ break;
+ case O_GT:
+ /* comparison on 'greater than' */
+#if 0 /* 02/VIII-2008 */
+ value = (eval_numeric(mpl, code->arg.arg.x) >
+ eval_numeric(mpl, code->arg.arg.y));
+#else
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) >
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) > 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+#endif
+ break;
+ case O_NE:
+ /* comparison on 'not equal to' */
+ xassert(code->arg.arg.x != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ value = (eval_numeric(mpl, code->arg.arg.x) !=
+ eval_numeric(mpl, code->arg.arg.y));
+ else
+ { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
+ SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
+ value = (compare_symbols(mpl, sym1, sym2) != 0);
+ delete_symbol(mpl, sym1);
+ delete_symbol(mpl, sym2);
+ }
+ break;
+ case O_AND:
+ /* conjunction (logical "and") */
+ value = eval_logical(mpl, code->arg.arg.x) &&
+ eval_logical(mpl, code->arg.arg.y);
+ break;
+ case O_OR:
+ /* disjunction (logical "or") */
+ value = eval_logical(mpl, code->arg.arg.x) ||
+ eval_logical(mpl, code->arg.arg.y);
+ break;
+ case O_IN:
+ /* test on 'x in Y' */
+ { TUPLE *tuple;
+ tuple = eval_tuple(mpl, code->arg.arg.x);
+ value = is_member(mpl, code->arg.arg.y, tuple);
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_NOTIN:
+ /* test on 'x not in Y' */
+ { TUPLE *tuple;
+ tuple = eval_tuple(mpl, code->arg.arg.x);
+ value = !is_member(mpl, code->arg.arg.y, tuple);
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_WITHIN:
+ /* test on 'X within Y' */
+ { ELEMSET *set;
+ MEMBER *memb;
+ set = eval_elemset(mpl, code->arg.arg.x);
+ value = 1;
+ for (memb = set->head; memb != NULL; memb = memb->next)
+ { if (!is_member(mpl, code->arg.arg.y, memb->tuple))
+ { value = 0;
+ break;
+ }
+ }
+ delete_elemset(mpl, set);
+ }
+ break;
+ case O_NOTWITHIN:
+ /* test on 'X not within Y' */
+ { ELEMSET *set;
+ MEMBER *memb;
+ set = eval_elemset(mpl, code->arg.arg.x);
+ value = 1;
+ for (memb = set->head; memb != NULL; memb = memb->next)
+ { if (is_member(mpl, code->arg.arg.y, memb->tuple))
+ { value = 0;
+ break;
+ }
+ }
+ delete_elemset(mpl, set);
+ }
+ break;
+ case O_FORALL:
+ /* conjunction (A-quantification) */
+ { struct iter_log_info _info, *info = &_info;
+ info->code = code;
+ info->value = 1;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_log_func);
+ value = info->value;
+ }
+ break;
+ case O_EXISTS:
+ /* disjunction (E-quantification) */
+ { struct iter_log_info _info, *info = &_info;
+ info->code = code;
+ info->value = 0;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_log_func);
+ value = info->value;
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.bit = value;
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_tuple - evaluate pseudo-code to construct n-tuple.
+--
+-- This routine evaluates specified pseudo-code to construct resultant
+-- n-tuple, which is returned on exit. */
+
+TUPLE *eval_tuple(MPL *mpl, CODE *code)
+{ TUPLE *value;
+ xassert(code != NULL);
+ xassert(code->type == A_TUPLE);
+ xassert(code->dim > 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = copy_tuple(mpl, code->value.tuple);
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_TUPLE:
+ /* make n-tuple */
+ { ARG_LIST *e;
+ value = create_tuple(mpl);
+ for (e = code->arg.list; e != NULL; e = e->next)
+ value = expand_tuple(mpl, value, eval_symbolic(mpl,
+ e->x));
+ }
+ break;
+ case O_CVTTUP:
+ /* convert to 1-tuple */
+ value = expand_tuple(mpl, create_tuple(mpl),
+ eval_symbolic(mpl, code->arg.arg.x));
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.tuple = copy_tuple(mpl, value);
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_elemset - evaluate pseudo-code to construct elemental set.
+--
+-- This routine evaluates specified pseudo-code to construct resultant
+-- elemental set, which is returned on exit. */
+
+struct iter_set_info
+{ /* working info used by the routine iter_set_func */
+ CODE *code;
+ /* pseudo-code for iterated operation to be performed */
+ ELEMSET *value;
+ /* resultant value */
+};
+
+static int iter_set_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine used to perform iterated operation
+ on n-tuple "integrand" within domain scope */
+ struct iter_set_info *info = _info;
+ TUPLE *tuple;
+ switch (info->code->op)
+ { case O_SETOF:
+ /* compute next n-tuple and add it to the set; in this case
+ duplicate n-tuples are silently ignored */
+ tuple = eval_tuple(mpl, info->code->arg.loop.x);
+ if (find_tuple(mpl, info->value, tuple) == NULL)
+ add_tuple(mpl, info->value, tuple);
+ else
+ delete_tuple(mpl, tuple);
+ break;
+ case O_BUILD:
+ /* construct next n-tuple using current values assigned to
+ *free* dummy indices as its components and add it to the
+ set; in this case duplicate n-tuples cannot appear */
+ add_tuple(mpl, info->value, get_domain_tuple(mpl,
+ info->code->arg.loop.domain));
+ break;
+ default:
+ xassert(info != info);
+ }
+ return 0;
+}
+
+ELEMSET *eval_elemset(MPL *mpl, CODE *code)
+{ ELEMSET *value;
+ xassert(code != NULL);
+ xassert(code->type == A_ELEMSET);
+ xassert(code->dim > 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = copy_elemset(mpl, code->value.set);
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_MEMSET:
+ /* take member of set */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+ tuple = create_tuple(mpl);
+ for (e = code->arg.set.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+ value = copy_elemset(mpl,
+ eval_member_set(mpl, code->arg.set.set, tuple));
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_MAKE:
+ /* make elemental set of n-tuples */
+ { ARG_LIST *e;
+ value = create_elemset(mpl, code->dim);
+ for (e = code->arg.list; e != NULL; e = e->next)
+ check_then_add(mpl, value, eval_tuple(mpl, e->x));
+ }
+ break;
+ case O_UNION:
+ /* union of two elemental sets */
+ value = set_union(mpl,
+ eval_elemset(mpl, code->arg.arg.x),
+ eval_elemset(mpl, code->arg.arg.y));
+ break;
+ case O_DIFF:
+ /* difference between two elemental sets */
+ value = set_diff(mpl,
+ eval_elemset(mpl, code->arg.arg.x),
+ eval_elemset(mpl, code->arg.arg.y));
+ break;
+ case O_SYMDIFF:
+ /* symmetric difference between two elemental sets */
+ value = set_symdiff(mpl,
+ eval_elemset(mpl, code->arg.arg.x),
+ eval_elemset(mpl, code->arg.arg.y));
+ break;
+ case O_INTER:
+ /* intersection of two elemental sets */
+ value = set_inter(mpl,
+ eval_elemset(mpl, code->arg.arg.x),
+ eval_elemset(mpl, code->arg.arg.y));
+ break;
+ case O_CROSS:
+ /* cross (Cartesian) product of two elemental sets */
+ value = set_cross(mpl,
+ eval_elemset(mpl, code->arg.arg.x),
+ eval_elemset(mpl, code->arg.arg.y));
+ break;
+ case O_DOTS:
+ /* build "arithmetic" elemental set */
+ value = create_arelset(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_numeric(mpl, code->arg.arg.y),
+ code->arg.arg.z == NULL ? 1.0 : eval_numeric(mpl,
+ code->arg.arg.z));
+ break;
+ case O_FORK:
+ /* if-then-else */
+ if (eval_logical(mpl, code->arg.arg.x))
+ value = eval_elemset(mpl, code->arg.arg.y);
+ else
+ value = eval_elemset(mpl, code->arg.arg.z);
+ break;
+ case O_SETOF:
+ /* compute elemental set */
+ { struct iter_set_info _info, *info = &_info;
+ info->code = code;
+ info->value = create_elemset(mpl, code->dim);
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_set_func);
+ value = info->value;
+ }
+ break;
+ case O_BUILD:
+ /* build elemental set identical to domain set */
+ { struct iter_set_info _info, *info = &_info;
+ info->code = code;
+ info->value = create_elemset(mpl, code->dim);
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_set_func);
+ value = info->value;
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.set = copy_elemset(mpl, value);
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- is_member - check if n-tuple is in set specified by pseudo-code.
+--
+-- This routine checks if given n-tuple is a member of elemental set
+-- specified in the form of pseudo-code (i.e. by expression).
+--
+-- The n-tuple may have more components that dimension of the elemental
+-- set, in which case the extra components are ignored. */
+
+static void null_func(MPL *mpl, void *info)
+{ /* this is dummy routine used to enter the domain scope */
+ xassert(mpl == mpl);
+ xassert(info == NULL);
+ return;
+}
+
+int is_member(MPL *mpl, CODE *code, TUPLE *tuple)
+{ int value;
+ xassert(code != NULL);
+ xassert(code->type == A_ELEMSET);
+ xassert(code->dim > 0);
+ xassert(tuple != NULL);
+ switch (code->op)
+ { case O_MEMSET:
+ /* check if given n-tuple is member of elemental set, which
+ is assigned to member of model set */
+ { ARG_LIST *e;
+ TUPLE *temp;
+ ELEMSET *set;
+ /* evaluate reference to elemental set */
+ temp = create_tuple(mpl);
+ for (e = code->arg.set.list; e != NULL; e = e->next)
+ temp = expand_tuple(mpl, temp, eval_symbolic(mpl,
+ e->x));
+ set = eval_member_set(mpl, code->arg.set.set, temp);
+ delete_tuple(mpl, temp);
+ /* check if the n-tuple is contained in the set array */
+ temp = build_subtuple(mpl, tuple, set->dim);
+ value = (find_tuple(mpl, set, temp) != NULL);
+ delete_tuple(mpl, temp);
+ }
+ break;
+ case O_MAKE:
+ /* check if given n-tuple is member of literal set */
+ { ARG_LIST *e;
+ TUPLE *temp, *that;
+ value = 0;
+ temp = build_subtuple(mpl, tuple, code->dim);
+ for (e = code->arg.list; e != NULL; e = e->next)
+ { that = eval_tuple(mpl, e->x);
+ value = (compare_tuples(mpl, temp, that) == 0);
+ delete_tuple(mpl, that);
+ if (value) break;
+ }
+ delete_tuple(mpl, temp);
+ }
+ break;
+ case O_UNION:
+ value = is_member(mpl, code->arg.arg.x, tuple) ||
+ is_member(mpl, code->arg.arg.y, tuple);
+ break;
+ case O_DIFF:
+ value = is_member(mpl, code->arg.arg.x, tuple) &&
+ !is_member(mpl, code->arg.arg.y, tuple);
+ break;
+ case O_SYMDIFF:
+ { int in1 = is_member(mpl, code->arg.arg.x, tuple);
+ int in2 = is_member(mpl, code->arg.arg.y, tuple);
+ value = (in1 && !in2) || (!in1 && in2);
+ }
+ break;
+ case O_INTER:
+ value = is_member(mpl, code->arg.arg.x, tuple) &&
+ is_member(mpl, code->arg.arg.y, tuple);
+ break;
+ case O_CROSS:
+ { int j;
+ value = is_member(mpl, code->arg.arg.x, tuple);
+ if (value)
+ { for (j = 1; j <= code->arg.arg.x->dim; j++)
+ { xassert(tuple != NULL);
+ tuple = tuple->next;
+ }
+ value = is_member(mpl, code->arg.arg.y, tuple);
+ }
+ }
+ break;
+ case O_DOTS:
+ /* check if given 1-tuple is member of "arithmetic" set */
+ { int j;
+ double x, t0, tf, dt;
+ xassert(code->dim == 1);
+ /* compute "parameters" of the "arithmetic" set */
+ t0 = eval_numeric(mpl, code->arg.arg.x);
+ tf = eval_numeric(mpl, code->arg.arg.y);
+ if (code->arg.arg.z == NULL)
+ dt = 1.0;
+ else
+ dt = eval_numeric(mpl, code->arg.arg.z);
+ /* make sure the parameters are correct */
+ arelset_size(mpl, t0, tf, dt);
+ /* if component of 1-tuple is symbolic, not numeric, the
+ 1-tuple cannot be member of "arithmetic" set */
+ xassert(tuple->sym != NULL);
+ if (tuple->sym->str != NULL)
+ { value = 0;
+ break;
+ }
+ /* determine numeric value of the component */
+ x = tuple->sym->num;
+ /* if the component value is out of the set range, the
+ 1-tuple is not in the set */
+ if (dt > 0.0 && !(t0 <= x && x <= tf) ||
+ dt < 0.0 && !(tf <= x && x <= t0))
+ { value = 0;
+ break;
+ }
+ /* estimate ordinal number of the 1-tuple in the set */
+ j = (int)(((x - t0) / dt) + 0.5) + 1;
+ /* perform the main check */
+ value = (arelset_member(mpl, t0, tf, dt, j) == x);
+ }
+ break;
+ case O_FORK:
+ /* check if given n-tuple is member of conditional set */
+ if (eval_logical(mpl, code->arg.arg.x))
+ value = is_member(mpl, code->arg.arg.y, tuple);
+ else
+ value = is_member(mpl, code->arg.arg.z, tuple);
+ break;
+ case O_SETOF:
+ /* check if given n-tuple is member of computed set */
+ /* it is not clear how to efficiently perform the check not
+ computing the entire elemental set :+( */
+ error(mpl, "implementation restriction; in/within setof{} n"
+ "ot allowed");
+ break;
+ case O_BUILD:
+ /* check if given n-tuple is member of domain set */
+ { TUPLE *temp;
+ temp = build_subtuple(mpl, tuple, code->dim);
+ /* try to enter the domain scope; if it is successful,
+ the n-tuple is in the domain set */
+ value = (eval_within_domain(mpl, code->arg.loop.domain,
+ temp, NULL, null_func) == 0);
+ delete_tuple(mpl, temp);
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ return value;
+}
+
+/*----------------------------------------------------------------------
+-- eval_formula - evaluate pseudo-code to construct linear form.
+--
+-- This routine evaluates specified pseudo-code to construct resultant
+-- linear form, which is returned on exit. */
+
+struct iter_form_info
+{ /* working info used by the routine iter_form_func */
+ CODE *code;
+ /* pseudo-code for iterated operation to be performed */
+ FORMULA *value;
+ /* resultant value */
+ FORMULA *tail;
+ /* pointer to the last term */
+};
+
+static int iter_form_func(MPL *mpl, void *_info)
+{ /* this is auxiliary routine used to perform iterated operation
+ on linear form "integrand" within domain scope */
+ struct iter_form_info *info = _info;
+ switch (info->code->op)
+ { case O_SUM:
+ /* summation over domain */
+#if 0
+ info->value =
+ linear_comb(mpl,
+ +1.0, info->value,
+ +1.0, eval_formula(mpl, info->code->arg.loop.x));
+#else
+ /* the routine linear_comb needs to look through all terms
+ of both linear forms to reduce identical terms, so using
+ it here is not a good idea (for example, evaluation of
+ sum{i in 1..n} x[i] required quadratic time); the better
+ idea is to gather all terms of the integrand in one list
+ and reduce identical terms only once after all terms of
+ the resultant linear form have been evaluated */
+ { FORMULA *form, *term;
+ form = eval_formula(mpl, info->code->arg.loop.x);
+ if (info->value == NULL)
+ { xassert(info->tail == NULL);
+ info->value = form;
+ }
+ else
+ { xassert(info->tail != NULL);
+ info->tail->next = form;
+ }
+ for (term = form; term != NULL; term = term->next)
+ info->tail = term;
+ }
+#endif
+ break;
+ default:
+ xassert(info != info);
+ }
+ return 0;
+}
+
+FORMULA *eval_formula(MPL *mpl, CODE *code)
+{ FORMULA *value;
+ xassert(code != NULL);
+ xassert(code->type == A_FORMULA);
+ xassert(code->dim == 0);
+ /* if the operation has a side effect, invalidate and delete the
+ resultant value */
+ if (code->vflag && code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* if resultant value is valid, no evaluation is needed */
+ if (code->valid)
+ { value = copy_formula(mpl, code->value.form);
+ goto done;
+ }
+ /* evaluate pseudo-code recursively */
+ switch (code->op)
+ { case O_MEMVAR:
+ /* take member of variable */
+ { TUPLE *tuple;
+ ARG_LIST *e;
+ tuple = create_tuple(mpl);
+ for (e = code->arg.var.list; e != NULL; e = e->next)
+ tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
+ e->x));
+#if 1 /* 15/V-2010 */
+ xassert(code->arg.var.suff == DOT_NONE);
+#endif
+ value = single_variable(mpl,
+ eval_member_var(mpl, code->arg.var.var, tuple));
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case O_CVTLFM:
+ /* convert to linear form */
+ value = constant_term(mpl, eval_numeric(mpl,
+ code->arg.arg.x));
+ break;
+ case O_PLUS:
+ /* unary plus */
+ value = linear_comb(mpl,
+ 0.0, constant_term(mpl, 0.0),
+ +1.0, eval_formula(mpl, code->arg.arg.x));
+ break;
+ case O_MINUS:
+ /* unary minus */
+ value = linear_comb(mpl,
+ 0.0, constant_term(mpl, 0.0),
+ -1.0, eval_formula(mpl, code->arg.arg.x));
+ break;
+ case O_ADD:
+ /* addition */
+ value = linear_comb(mpl,
+ +1.0, eval_formula(mpl, code->arg.arg.x),
+ +1.0, eval_formula(mpl, code->arg.arg.y));
+ break;
+ case O_SUB:
+ /* subtraction */
+ value = linear_comb(mpl,
+ +1.0, eval_formula(mpl, code->arg.arg.x),
+ -1.0, eval_formula(mpl, code->arg.arg.y));
+ break;
+ case O_MUL:
+ /* multiplication */
+ xassert(code->arg.arg.x != NULL);
+ xassert(code->arg.arg.y != NULL);
+ if (code->arg.arg.x->type == A_NUMERIC)
+ { xassert(code->arg.arg.y->type == A_FORMULA);
+ value = linear_comb(mpl,
+ eval_numeric(mpl, code->arg.arg.x),
+ eval_formula(mpl, code->arg.arg.y),
+ 0.0, constant_term(mpl, 0.0));
+ }
+ else
+ { xassert(code->arg.arg.x->type == A_FORMULA);
+ xassert(code->arg.arg.y->type == A_NUMERIC);
+ value = linear_comb(mpl,
+ eval_numeric(mpl, code->arg.arg.y),
+ eval_formula(mpl, code->arg.arg.x),
+ 0.0, constant_term(mpl, 0.0));
+ }
+ break;
+ case O_DIV:
+ /* division */
+ value = linear_comb(mpl,
+ fp_div(mpl, 1.0, eval_numeric(mpl, code->arg.arg.y)),
+ eval_formula(mpl, code->arg.arg.x),
+ 0.0, constant_term(mpl, 0.0));
+ break;
+ case O_FORK:
+ /* if-then-else */
+ if (eval_logical(mpl, code->arg.arg.x))
+ value = eval_formula(mpl, code->arg.arg.y);
+ else if (code->arg.arg.z == NULL)
+ value = constant_term(mpl, 0.0);
+ else
+ value = eval_formula(mpl, code->arg.arg.z);
+ break;
+ case O_SUM:
+ /* summation over domain */
+ { struct iter_form_info _info, *info = &_info;
+ info->code = code;
+ info->value = constant_term(mpl, 0.0);
+ info->tail = NULL;
+ loop_within_domain(mpl, code->arg.loop.domain, info,
+ iter_form_func);
+ value = reduce_terms(mpl, info->value);
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ /* save resultant value */
+ xassert(!code->valid);
+ code->valid = 1;
+ code->value.form = copy_formula(mpl, value);
+done: return value;
+}
+
+/*----------------------------------------------------------------------
+-- clean_code - clean pseudo-code.
+--
+-- This routine recursively cleans specified pseudo-code that assumes
+-- deleting all temporary resultant values. */
+
+void clean_code(MPL *mpl, CODE *code)
+{ ARG_LIST *e;
+ /* if no pseudo-code is specified, do nothing */
+ if (code == NULL) goto done;
+ /* if resultant value is valid (exists), delete it */
+ if (code->valid)
+ { code->valid = 0;
+ delete_value(mpl, code->type, &code->value);
+ }
+ /* recursively clean pseudo-code for operands */
+ switch (code->op)
+ { case O_NUMBER:
+ case O_STRING:
+ case O_INDEX:
+ break;
+ case O_MEMNUM:
+ case O_MEMSYM:
+ for (e = code->arg.par.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+ case O_MEMSET:
+ for (e = code->arg.set.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+ case O_MEMVAR:
+ for (e = code->arg.var.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+#if 1 /* 15/V-2010 */
+ case O_MEMCON:
+ for (e = code->arg.con.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+#endif
+ case O_TUPLE:
+ case O_MAKE:
+ for (e = code->arg.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+ case O_SLICE:
+ xassert(code != code);
+ case O_IRAND224:
+ case O_UNIFORM01:
+ case O_NORMAL01:
+ case O_GMTIME:
+ break;
+ case O_CVTNUM:
+ case O_CVTSYM:
+ case O_CVTLOG:
+ case O_CVTTUP:
+ case O_CVTLFM:
+ case O_PLUS:
+ case O_MINUS:
+ case O_NOT:
+ case O_ABS:
+ case O_CEIL:
+ case O_FLOOR:
+ case O_EXP:
+ case O_LOG:
+ case O_LOG10:
+ case O_SQRT:
+ case O_SIN:
+ case O_COS:
+ case O_TAN:
+ case O_ATAN:
+ case O_ROUND:
+ case O_TRUNC:
+ case O_CARD:
+ case O_LENGTH:
+ /* unary operation */
+ clean_code(mpl, code->arg.arg.x);
+ break;
+ case O_ADD:
+ case O_SUB:
+ case O_LESS:
+ case O_MUL:
+ case O_DIV:
+ case O_IDIV:
+ case O_MOD:
+ case O_POWER:
+ case O_ATAN2:
+ case O_ROUND2:
+ case O_TRUNC2:
+ case O_UNIFORM:
+ case O_NORMAL:
+ case O_CONCAT:
+ case O_LT:
+ case O_LE:
+ case O_EQ:
+ case O_GE:
+ case O_GT:
+ case O_NE:
+ case O_AND:
+ case O_OR:
+ case O_UNION:
+ case O_DIFF:
+ case O_SYMDIFF:
+ case O_INTER:
+ case O_CROSS:
+ case O_IN:
+ case O_NOTIN:
+ case O_WITHIN:
+ case O_NOTWITHIN:
+ case O_SUBSTR:
+ case O_STR2TIME:
+ case O_TIME2STR:
+ /* binary operation */
+ clean_code(mpl, code->arg.arg.x);
+ clean_code(mpl, code->arg.arg.y);
+ break;
+ case O_DOTS:
+ case O_FORK:
+ case O_SUBSTR3:
+ /* ternary operation */
+ clean_code(mpl, code->arg.arg.x);
+ clean_code(mpl, code->arg.arg.y);
+ clean_code(mpl, code->arg.arg.z);
+ break;
+ case O_MIN:
+ case O_MAX:
+ /* n-ary operation */
+ for (e = code->arg.list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+ break;
+ case O_SUM:
+ case O_PROD:
+ case O_MINIMUM:
+ case O_MAXIMUM:
+ case O_FORALL:
+ case O_EXISTS:
+ case O_SETOF:
+ case O_BUILD:
+ /* iterated operation */
+ clean_domain(mpl, code->arg.loop.domain);
+ clean_code(mpl, code->arg.loop.x);
+ break;
+ default:
+ xassert(code->op != code->op);
+ }
+done: return;
+}
+
+#if 1 /* 11/II-2008 */
+/**********************************************************************/
+/* * * DATA TABLES * * */
+/**********************************************************************/
+
+int mpl_tab_num_args(TABDCA *dca)
+{ /* returns the number of arguments */
+ return dca->na;
+}
+
+const char *mpl_tab_get_arg(TABDCA *dca, int k)
+{ /* returns pointer to k-th argument */
+ xassert(1 <= k && k <= dca->na);
+ return dca->arg[k];
+}
+
+int mpl_tab_num_flds(TABDCA *dca)
+{ /* returns the number of fields */
+ return dca->nf;
+}
+
+const char *mpl_tab_get_name(TABDCA *dca, int k)
+{ /* returns pointer to name of k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ return dca->name[k];
+}
+
+int mpl_tab_get_type(TABDCA *dca, int k)
+{ /* returns type of k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ return dca->type[k];
+}
+
+double mpl_tab_get_num(TABDCA *dca, int k)
+{ /* returns numeric value of k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ xassert(dca->type[k] == 'N');
+ return dca->num[k];
+}
+
+const char *mpl_tab_get_str(TABDCA *dca, int k)
+{ /* returns pointer to string value of k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ xassert(dca->type[k] == 'S');
+ xassert(dca->str[k] != NULL);
+ return dca->str[k];
+}
+
+void mpl_tab_set_num(TABDCA *dca, int k, double num)
+{ /* assign numeric value to k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ xassert(dca->type[k] == '?');
+ dca->type[k] = 'N';
+ dca->num[k] = num;
+ return;
+}
+
+void mpl_tab_set_str(TABDCA *dca, int k, const char *str)
+{ /* assign string value to k-th field */
+ xassert(1 <= k && k <= dca->nf);
+ xassert(dca->type[k] == '?');
+ xassert(strlen(str) <= MAX_LENGTH);
+ xassert(dca->str[k] != NULL);
+ dca->type[k] = 'S';
+ strcpy(dca->str[k], str);
+ return;
+}
+
+static int write_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ TABLE *tab = info;
+ TABDCA *dca = mpl->dca;
+ TABOUT *out;
+ SYMBOL *sym;
+ int k;
+ char buf[MAX_LENGTH+1];
+ /* evaluate field values */
+ k = 0;
+ for (out = tab->u.out.list; out != NULL; out = out->next)
+ { k++;
+ switch (out->code->type)
+ { case A_NUMERIC:
+ dca->type[k] = 'N';
+ dca->num[k] = eval_numeric(mpl, out->code);
+ dca->str[k][0] = '\0';
+ break;
+ case A_SYMBOLIC:
+ sym = eval_symbolic(mpl, out->code);
+ if (sym->str == NULL)
+ { dca->type[k] = 'N';
+ dca->num[k] = sym->num;
+ dca->str[k][0] = '\0';
+ }
+ else
+ { dca->type[k] = 'S';
+ dca->num[k] = 0.0;
+ fetch_string(mpl, sym->str, buf);
+ strcpy(dca->str[k], buf);
+ }
+ delete_symbol(mpl, sym);
+ break;
+ default:
+ xassert(out != out);
+ }
+ }
+ /* write record to output table */
+ mpl_tab_drv_write(mpl);
+ return 0;
+}
+
+void execute_table(MPL *mpl, TABLE *tab)
+{ /* execute table statement */
+ TABARG *arg;
+ TABFLD *fld;
+ TABIN *in;
+ TABOUT *out;
+ TABDCA *dca;
+ SET *set;
+ int k;
+ char buf[MAX_LENGTH+1];
+ /* allocate table driver communication area */
+ xassert(mpl->dca == NULL);
+ mpl->dca = dca = xmalloc(sizeof(TABDCA));
+ dca->id = 0;
+ dca->link = NULL;
+ dca->na = 0;
+ dca->arg = NULL;
+ dca->nf = 0;
+ dca->name = NULL;
+ dca->type = NULL;
+ dca->num = NULL;
+ dca->str = NULL;
+ /* allocate arguments */
+ xassert(dca->na == 0);
+ for (arg = tab->arg; arg != NULL; arg = arg->next)
+ dca->na++;
+ dca->arg = xcalloc(1+dca->na, sizeof(char *));
+#if 1 /* 28/IX-2008 */
+ for (k = 1; k <= dca->na; k++) dca->arg[k] = NULL;
+#endif
+ /* evaluate argument values */
+ k = 0;
+ for (arg = tab->arg; arg != NULL; arg = arg->next)
+ { SYMBOL *sym;
+ k++;
+ xassert(arg->code->type == A_SYMBOLIC);
+ sym = eval_symbolic(mpl, arg->code);
+ if (sym->str == NULL)
+ sprintf(buf, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, buf);
+ delete_symbol(mpl, sym);
+ dca->arg[k] = xmalloc(strlen(buf)+1);
+ strcpy(dca->arg[k], buf);
+ }
+ /* perform table input/output */
+ switch (tab->type)
+ { case A_INPUT: goto read_table;
+ case A_OUTPUT: goto write_table;
+ default: xassert(tab != tab);
+ }
+read_table:
+ /* read data from input table */
+ /* add the only member to the control set and assign it empty
+ elemental set */
+ set = tab->u.in.set;
+ if (set != NULL)
+ { if (set->data)
+ error(mpl, "%s already provided with data", set->name);
+ xassert(set->array->head == NULL);
+ add_member(mpl, set->array, NULL)->value.set =
+ create_elemset(mpl, set->dimen);
+ set->data = 1;
+ }
+ /* check parameters specified in the input list */
+ for (in = tab->u.in.list; in != NULL; in = in->next)
+ { if (in->par->data)
+ error(mpl, "%s already provided with data", in->par->name);
+ in->par->data = 1;
+ }
+ /* allocate and initialize fields */
+ xassert(dca->nf == 0);
+ for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
+ dca->nf++;
+ for (in = tab->u.in.list; in != NULL; in = in->next)
+ dca->nf++;
+ dca->name = xcalloc(1+dca->nf, sizeof(char *));
+ dca->type = xcalloc(1+dca->nf, sizeof(int));
+ dca->num = xcalloc(1+dca->nf, sizeof(double));
+ dca->str = xcalloc(1+dca->nf, sizeof(char *));
+ k = 0;
+ for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
+ { k++;
+ dca->name[k] = fld->name;
+ dca->type[k] = '?';
+ dca->num[k] = 0.0;
+ dca->str[k] = xmalloc(MAX_LENGTH+1);
+ dca->str[k][0] = '\0';
+ }
+ for (in = tab->u.in.list; in != NULL; in = in->next)
+ { k++;
+ dca->name[k] = in->name;
+ dca->type[k] = '?';
+ dca->num[k] = 0.0;
+ dca->str[k] = xmalloc(MAX_LENGTH+1);
+ dca->str[k][0] = '\0';
+ }
+ /* open input table */
+ mpl_tab_drv_open(mpl, 'R');
+ /* read and process records */
+ for (;;)
+ { TUPLE *tup;
+ /* reset field types */
+ for (k = 1; k <= dca->nf; k++)
+ dca->type[k] = '?';
+ /* read next record */
+ if (mpl_tab_drv_read(mpl)) break;
+ /* all fields must be set by the driver */
+ for (k = 1; k <= dca->nf; k++)
+ { if (dca->type[k] == '?')
+ error(mpl, "field %s missing in input table",
+ dca->name[k]);
+ }
+ /* construct n-tuple */
+ tup = create_tuple(mpl);
+ k = 0;
+ for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
+ { k++;
+ xassert(k <= dca->nf);
+ switch (dca->type[k])
+ { case 'N':
+ tup = expand_tuple(mpl, tup, create_symbol_num(mpl,
+ dca->num[k]));
+ break;
+ case 'S':
+ xassert(strlen(dca->str[k]) <= MAX_LENGTH);
+ tup = expand_tuple(mpl, tup, create_symbol_str(mpl,
+ create_string(mpl, dca->str[k])));
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ }
+ /* add n-tuple just read to the control set */
+ if (tab->u.in.set != NULL)
+ check_then_add(mpl, tab->u.in.set->array->head->value.set,
+ copy_tuple(mpl, tup));
+ /* assign values to the parameters in the input list */
+ for (in = tab->u.in.list; in != NULL; in = in->next)
+ { MEMBER *memb;
+ k++;
+ xassert(k <= dca->nf);
+ /* there must be no member with the same n-tuple */
+ if (find_member(mpl, in->par->array, tup) != NULL)
+ error(mpl, "%s%s already defined", in->par->name,
+ format_tuple(mpl, '[', tup));
+ /* create new parameter member with given n-tuple */
+ memb = add_member(mpl, in->par->array, copy_tuple(mpl, tup))
+ ;
+ /* assign value to the parameter member */
+ switch (in->par->type)
+ { case A_NUMERIC:
+ case A_INTEGER:
+ case A_BINARY:
+ if (dca->type[k] != 'N')
+ error(mpl, "%s requires numeric data",
+ in->par->name);
+ memb->value.num = dca->num[k];
+ break;
+ case A_SYMBOLIC:
+ switch (dca->type[k])
+ { case 'N':
+ memb->value.sym = create_symbol_num(mpl,
+ dca->num[k]);
+ break;
+ case 'S':
+ xassert(strlen(dca->str[k]) <= MAX_LENGTH);
+ memb->value.sym = create_symbol_str(mpl,
+ create_string(mpl,dca->str[k]));
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ break;
+ default:
+ xassert(in != in);
+ }
+ }
+ /* n-tuple is no more needed */
+ delete_tuple(mpl, tup);
+ }
+ /* close input table */
+ mpl_tab_drv_close(mpl);
+ goto done;
+write_table:
+ /* write data to output table */
+ /* allocate and initialize fields */
+ xassert(dca->nf == 0);
+ for (out = tab->u.out.list; out != NULL; out = out->next)
+ dca->nf++;
+ dca->name = xcalloc(1+dca->nf, sizeof(char *));
+ dca->type = xcalloc(1+dca->nf, sizeof(int));
+ dca->num = xcalloc(1+dca->nf, sizeof(double));
+ dca->str = xcalloc(1+dca->nf, sizeof(char *));
+ k = 0;
+ for (out = tab->u.out.list; out != NULL; out = out->next)
+ { k++;
+ dca->name[k] = out->name;
+ dca->type[k] = '?';
+ dca->num[k] = 0.0;
+ dca->str[k] = xmalloc(MAX_LENGTH+1);
+ dca->str[k][0] = '\0';
+ }
+ /* open output table */
+ mpl_tab_drv_open(mpl, 'W');
+ /* evaluate fields and write records */
+ loop_within_domain(mpl, tab->u.out.domain, tab, write_func);
+ /* close output table */
+ mpl_tab_drv_close(mpl);
+done: /* free table driver communication area */
+ free_dca(mpl);
+ return;
+}
+
+void free_dca(MPL *mpl)
+{ /* free table driver communucation area */
+ TABDCA *dca = mpl->dca;
+ int k;
+ if (dca != NULL)
+ { if (dca->link != NULL)
+ mpl_tab_drv_close(mpl);
+ if (dca->arg != NULL)
+ { for (k = 1; k <= dca->na; k++)
+#if 1 /* 28/IX-2008 */
+ if (dca->arg[k] != NULL)
+#endif
+ xfree(dca->arg[k]);
+ xfree(dca->arg);
+ }
+ if (dca->name != NULL) xfree(dca->name);
+ if (dca->type != NULL) xfree(dca->type);
+ if (dca->num != NULL) xfree(dca->num);
+ if (dca->str != NULL)
+ { for (k = 1; k <= dca->nf; k++)
+ xfree(dca->str[k]);
+ xfree(dca->str);
+ }
+ xfree(dca), mpl->dca = NULL;
+ }
+ return;
+}
+
+void clean_table(MPL *mpl, TABLE *tab)
+{ /* clean table statement */
+ TABARG *arg;
+ TABOUT *out;
+ /* clean string list */
+ for (arg = tab->arg; arg != NULL; arg = arg->next)
+ clean_code(mpl, arg->code);
+ switch (tab->type)
+ { case A_INPUT:
+ break;
+ case A_OUTPUT:
+ /* clean subscript domain */
+ clean_domain(mpl, tab->u.out.domain);
+ /* clean output list */
+ for (out = tab->u.out.list; out != NULL; out = out->next)
+ clean_code(mpl, out->code);
+ break;
+ default:
+ xassert(tab != tab);
+ }
+ return;
+}
+#endif
+
+/**********************************************************************/
+/* * * MODEL STATEMENTS * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- execute_check - execute check statement.
+--
+-- This routine executes specified check statement. */
+
+static int check_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ CHECK *chk = (CHECK *)info;
+ if (!eval_logical(mpl, chk->code))
+ error(mpl, "check%s failed", format_tuple(mpl, '[',
+ get_domain_tuple(mpl, chk->domain)));
+ return 0;
+}
+
+void execute_check(MPL *mpl, CHECK *chk)
+{ loop_within_domain(mpl, chk->domain, chk, check_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_check - clean check statement.
+--
+-- This routine cleans specified check statement that assumes deleting
+-- all stuff dynamically allocated on generating/postsolving phase. */
+
+void clean_check(MPL *mpl, CHECK *chk)
+{ /* clean subscript domain */
+ clean_domain(mpl, chk->domain);
+ /* clean pseudo-code for computing predicate */
+ clean_code(mpl, chk->code);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- execute_display - execute display statement.
+--
+-- This routine executes specified display statement. */
+
+static void display_set(MPL *mpl, SET *set, MEMBER *memb)
+{ /* display member of model set */
+ ELEMSET *s = memb->value.set;
+ MEMBER *m;
+ write_text(mpl, "%s%s%s\n", set->name,
+ format_tuple(mpl, '[', memb->tuple),
+ s->head == NULL ? " is empty" : ":");
+ for (m = s->head; m != NULL; m = m->next)
+ write_text(mpl, " %s\n", format_tuple(mpl, '(', m->tuple));
+ return;
+}
+
+static void display_par(MPL *mpl, PARAMETER *par, MEMBER *memb)
+{ /* display member of model parameter */
+ switch (par->type)
+ { case A_NUMERIC:
+ case A_INTEGER:
+ case A_BINARY:
+ write_text(mpl, "%s%s = %.*g\n", par->name,
+ format_tuple(mpl, '[', memb->tuple),
+ DBL_DIG, memb->value.num);
+ break;
+ case A_SYMBOLIC:
+ write_text(mpl, "%s%s = %s\n", par->name,
+ format_tuple(mpl, '[', memb->tuple),
+ format_symbol(mpl, memb->value.sym));
+ break;
+ default:
+ xassert(par != par);
+ }
+ return;
+}
+
+#if 1 /* 15/V-2010 */
+static void display_var(MPL *mpl, VARIABLE *var, MEMBER *memb,
+ int suff)
+{ /* display member of model variable */
+ if (suff == DOT_NONE || suff == DOT_VAL)
+ write_text(mpl, "%s%s.val = %.*g\n", var->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.var->prim);
+ else if (suff == DOT_LB)
+ write_text(mpl, "%s%s.lb = %.*g\n", var->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.var->var->lbnd == NULL ? -DBL_MAX :
+ memb->value.var->lbnd);
+ else if (suff == DOT_UB)
+ write_text(mpl, "%s%s.ub = %.*g\n", var->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.var->var->ubnd == NULL ? +DBL_MAX :
+ memb->value.var->ubnd);
+ else if (suff == DOT_STATUS)
+ write_text(mpl, "%s%s.status = %d\n", var->name, format_tuple
+ (mpl, '[', memb->tuple), memb->value.var->stat);
+ else if (suff == DOT_DUAL)
+ write_text(mpl, "%s%s.dual = %.*g\n", var->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.var->dual);
+ else
+ xassert(suff != suff);
+ return;
+}
+#endif
+
+#if 1 /* 15/V-2010 */
+static void display_con(MPL *mpl, CONSTRAINT *con, MEMBER *memb,
+ int suff)
+{ /* display member of model constraint */
+ if (suff == DOT_NONE || suff == DOT_VAL)
+ write_text(mpl, "%s%s.val = %.*g\n", con->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.con->prim);
+ else if (suff == DOT_LB)
+ write_text(mpl, "%s%s.lb = %.*g\n", con->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.con->con->lbnd == NULL ? -DBL_MAX :
+ memb->value.con->lbnd);
+ else if (suff == DOT_UB)
+ write_text(mpl, "%s%s.ub = %.*g\n", con->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.con->con->ubnd == NULL ? +DBL_MAX :
+ memb->value.con->ubnd);
+ else if (suff == DOT_STATUS)
+ write_text(mpl, "%s%s.status = %d\n", con->name, format_tuple
+ (mpl, '[', memb->tuple), memb->value.con->stat);
+ else if (suff == DOT_DUAL)
+ write_text(mpl, "%s%s.dual = %.*g\n", con->name,
+ format_tuple(mpl, '[', memb->tuple), DBL_DIG,
+ memb->value.con->dual);
+ else
+ xassert(suff != suff);
+ return;
+}
+#endif
+
+static void display_memb(MPL *mpl, CODE *code)
+{ /* display member specified by pseudo-code */
+ MEMBER memb;
+ ARG_LIST *e;
+ xassert(code->op == O_MEMNUM || code->op == O_MEMSYM
+ || code->op == O_MEMSET || code->op == O_MEMVAR
+ || code->op == O_MEMCON);
+ memb.tuple = create_tuple(mpl);
+ for (e = code->arg.par.list; e != NULL; e = e->next)
+ memb.tuple = expand_tuple(mpl, memb.tuple, eval_symbolic(mpl,
+ e->x));
+ switch (code->op)
+ { case O_MEMNUM:
+ memb.value.num = eval_member_num(mpl, code->arg.par.par,
+ memb.tuple);
+ display_par(mpl, code->arg.par.par, &memb);
+ break;
+ case O_MEMSYM:
+ memb.value.sym = eval_member_sym(mpl, code->arg.par.par,
+ memb.tuple);
+ display_par(mpl, code->arg.par.par, &memb);
+ delete_symbol(mpl, memb.value.sym);
+ break;
+ case O_MEMSET:
+ memb.value.set = eval_member_set(mpl, code->arg.set.set,
+ memb.tuple);
+ display_set(mpl, code->arg.set.set, &memb);
+ break;
+ case O_MEMVAR:
+ memb.value.var = eval_member_var(mpl, code->arg.var.var,
+ memb.tuple);
+ display_var
+ (mpl, code->arg.var.var, &memb, code->arg.var.suff);
+ break;
+ case O_MEMCON:
+ memb.value.con = eval_member_con(mpl, code->arg.con.con,
+ memb.tuple);
+ display_con
+ (mpl, code->arg.con.con, &memb, code->arg.con.suff);
+ break;
+ default:
+ xassert(code != code);
+ }
+ delete_tuple(mpl, memb.tuple);
+ return;
+}
+
+static void display_code(MPL *mpl, CODE *code)
+{ /* display value of expression */
+ switch (code->type)
+ { case A_NUMERIC:
+ /* numeric value */
+ { double num;
+ num = eval_numeric(mpl, code);
+ write_text(mpl, "%.*g\n", DBL_DIG, num);
+ }
+ break;
+ case A_SYMBOLIC:
+ /* symbolic value */
+ { SYMBOL *sym;
+ sym = eval_symbolic(mpl, code);
+ write_text(mpl, "%s\n", format_symbol(mpl, sym));
+ delete_symbol(mpl, sym);
+ }
+ break;
+ case A_LOGICAL:
+ /* logical value */
+ { int bit;
+ bit = eval_logical(mpl, code);
+ write_text(mpl, "%s\n", bit ? "true" : "false");
+ }
+ break;
+ case A_TUPLE:
+ /* n-tuple */
+ { TUPLE *tuple;
+ tuple = eval_tuple(mpl, code);
+ write_text(mpl, "%s\n", format_tuple(mpl, '(', tuple));
+ delete_tuple(mpl, tuple);
+ }
+ break;
+ case A_ELEMSET:
+ /* elemental set */
+ { ELEMSET *set;
+ MEMBER *memb;
+ set = eval_elemset(mpl, code);
+ if (set->head == 0)
+ write_text(mpl, "set is empty\n");
+ for (memb = set->head; memb != NULL; memb = memb->next)
+ write_text(mpl, " %s\n", format_tuple(mpl, '(',
+ memb->tuple));
+ delete_elemset(mpl, set);
+ }
+ break;
+ case A_FORMULA:
+ /* linear form */
+ { FORMULA *form, *term;
+ form = eval_formula(mpl, code);
+ if (form == NULL)
+ write_text(mpl, "linear form is empty\n");
+ for (term = form; term != NULL; term = term->next)
+ { if (term->var == NULL)
+ write_text(mpl, " %.*g\n", term->coef);
+ else
+ write_text(mpl, " %.*g %s%s\n", DBL_DIG,
+ term->coef, term->var->var->name,
+ format_tuple(mpl, '[', term->var->memb->tuple));
+ }
+ delete_formula(mpl, form);
+ }
+ break;
+ default:
+ xassert(code != code);
+ }
+ return;
+}
+
+static int display_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ DISPLAY *dpy = (DISPLAY *)info;
+ DISPLAY1 *entry;
+ for (entry = dpy->list; entry != NULL; entry = entry->next)
+ { if (entry->type == A_INDEX)
+ { /* dummy index */
+ DOMAIN_SLOT *slot = entry->u.slot;
+ write_text(mpl, "%s = %s\n", slot->name,
+ format_symbol(mpl, slot->value));
+ }
+ else if (entry->type == A_SET)
+ { /* model set */
+ SET *set = entry->u.set;
+ MEMBER *memb;
+ if (set->assign != NULL)
+ { /* the set has assignment expression; evaluate all its
+ members over entire domain */
+ eval_whole_set(mpl, set);
+ }
+ else
+ { /* the set has no assignment expression; refer to its
+ any existing member ignoring resultant value to check
+ the data provided the data section */
+#if 1 /* 12/XII-2008 */
+ if (set->gadget != NULL && set->data == 0)
+ { /* initialize the set with data from a plain set */
+ saturate_set(mpl, set);
+ }
+#endif
+ if (set->array->head != NULL)
+ eval_member_set(mpl, set, set->array->head->tuple);
+ }
+ /* display all members of the set array */
+ if (set->array->head == NULL)
+ write_text(mpl, "%s has empty content\n", set->name);
+ for (memb = set->array->head; memb != NULL; memb =
+ memb->next) display_set(mpl, set, memb);
+ }
+ else if (entry->type == A_PARAMETER)
+ { /* model parameter */
+ PARAMETER *par = entry->u.par;
+ MEMBER *memb;
+ if (par->assign != NULL)
+ { /* the parameter has an assignment expression; evaluate
+ all its member over entire domain */
+ eval_whole_par(mpl, par);
+ }
+ else
+ { /* the parameter has no assignment expression; refer to
+ its any existing member ignoring resultant value to
+ check the data provided in the data section */
+ if (par->array->head != NULL)
+ { if (par->type != A_SYMBOLIC)
+ eval_member_num(mpl, par, par->array->head->tuple);
+ else
+ delete_symbol(mpl, eval_member_sym(mpl, par,
+ par->array->head->tuple));
+ }
+ }
+ /* display all members of the parameter array */
+ if (par->array->head == NULL)
+ write_text(mpl, "%s has empty content\n", par->name);
+ for (memb = par->array->head; memb != NULL; memb =
+ memb->next) display_par(mpl, par, memb);
+ }
+ else if (entry->type == A_VARIABLE)
+ { /* model variable */
+ VARIABLE *var = entry->u.var;
+ MEMBER *memb;
+ xassert(mpl->flag_p);
+ /* display all members of the variable array */
+ if (var->array->head == NULL)
+ write_text(mpl, "%s has empty content\n", var->name);
+ for (memb = var->array->head; memb != NULL; memb =
+ memb->next) display_var(mpl, var, memb, DOT_NONE);
+ }
+ else if (entry->type == A_CONSTRAINT)
+ { /* model constraint */
+ CONSTRAINT *con = entry->u.con;
+ MEMBER *memb;
+ xassert(mpl->flag_p);
+ /* display all members of the constraint array */
+ if (con->array->head == NULL)
+ write_text(mpl, "%s has empty content\n", con->name);
+ for (memb = con->array->head; memb != NULL; memb =
+ memb->next) display_con(mpl, con, memb, DOT_NONE);
+ }
+ else if (entry->type == A_EXPRESSION)
+ { /* expression */
+ CODE *code = entry->u.code;
+ if (code->op == O_MEMNUM || code->op == O_MEMSYM ||
+ code->op == O_MEMSET || code->op == O_MEMVAR ||
+ code->op == O_MEMCON)
+ display_memb(mpl, code);
+ else
+ display_code(mpl, code);
+ }
+ else
+ xassert(entry != entry);
+ }
+ return 0;
+}
+
+void execute_display(MPL *mpl, DISPLAY *dpy)
+{ loop_within_domain(mpl, dpy->domain, dpy, display_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_display - clean display statement.
+--
+-- This routine cleans specified display statement that assumes deleting
+-- all stuff dynamically allocated on generating/postsolving phase. */
+
+void clean_display(MPL *mpl, DISPLAY *dpy)
+{ DISPLAY1 *d;
+#if 0 /* 15/V-2010 */
+ ARG_LIST *e;
+#endif
+ /* clean subscript domain */
+ clean_domain(mpl, dpy->domain);
+ /* clean display list */
+ for (d = dpy->list; d != NULL; d = d->next)
+ { /* clean pseudo-code for computing expression */
+ if (d->type == A_EXPRESSION)
+ clean_code(mpl, d->u.code);
+#if 0 /* 15/V-2010 */
+ /* clean pseudo-code for computing subscripts */
+ for (e = d->list; e != NULL; e = e->next)
+ clean_code(mpl, e->x);
+#endif
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- execute_printf - execute printf statement.
+--
+-- This routine executes specified printf statement. */
+
+#if 1 /* 14/VII-2006 */
+static void print_char(MPL *mpl, int c)
+{ if (mpl->prt_fp == NULL)
+ write_char(mpl, c);
+ else
+#if 0 /* 04/VIII-2013 */
+ xfputc(c, mpl->prt_fp);
+#else
+ { unsigned char buf[1];
+ buf[0] = (unsigned char)c;
+ glp_write(mpl->prt_fp, buf, 1);
+ }
+#endif
+ return;
+}
+
+static void print_text(MPL *mpl, char *fmt, ...)
+{ va_list arg;
+ char buf[OUTBUF_SIZE], *c;
+ va_start(arg, fmt);
+ vsprintf(buf, fmt, arg);
+ xassert(strlen(buf) < sizeof(buf));
+ va_end(arg);
+ for (c = buf; *c != '\0'; c++) print_char(mpl, *c);
+ return;
+}
+#endif
+
+static int printf_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ PRINTF *prt = (PRINTF *)info;
+ PRINTF1 *entry;
+ SYMBOL *sym;
+ char fmt[MAX_LENGTH+1], *c, *from, save;
+ /* evaluate format control string */
+ sym = eval_symbolic(mpl, prt->fmt);
+ if (sym->str == NULL)
+ sprintf(fmt, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, fmt);
+ delete_symbol(mpl, sym);
+ /* scan format control string and perform formatting output */
+ entry = prt->list;
+ for (c = fmt; *c != '\0'; c++)
+ { if (*c == '%')
+ { /* scan format specifier */
+ from = c++;
+ if (*c == '%')
+ { print_char(mpl, '%');
+ continue;
+ }
+ if (entry == NULL) break;
+ /* scan optional flags */
+ while (*c == '-' || *c == '+' || *c == ' ' || *c == '#' ||
+ *c == '0') c++;
+ /* scan optional minimum field width */
+ while (isdigit((unsigned char)*c)) c++;
+ /* scan optional precision */
+ if (*c == '.')
+ { c++;
+ while (isdigit((unsigned char)*c)) c++;
+ }
+ /* scan conversion specifier and perform formatting */
+ save = *(c+1), *(c+1) = '\0';
+ if (*c == 'd' || *c == 'i' || *c == 'e' || *c == 'E' ||
+ *c == 'f' || *c == 'F' || *c == 'g' || *c == 'G')
+ { /* the specifier requires numeric value */
+ double value;
+ xassert(entry != NULL);
+ switch (entry->code->type)
+ { case A_NUMERIC:
+ value = eval_numeric(mpl, entry->code);
+ break;
+ case A_SYMBOLIC:
+ sym = eval_symbolic(mpl, entry->code);
+ if (sym->str != NULL)
+ error(mpl, "cannot convert %s to floating-point"
+ " number", format_symbol(mpl, sym));
+ value = sym->num;
+ delete_symbol(mpl, sym);
+ break;
+ case A_LOGICAL:
+ if (eval_logical(mpl, entry->code))
+ value = 1.0;
+ else
+ value = 0.0;
+ break;
+ default:
+ xassert(entry != entry);
+ }
+ if (*c == 'd' || *c == 'i')
+ { double int_max = (double)INT_MAX;
+ if (!(-int_max <= value && value <= +int_max))
+ error(mpl, "cannot convert %.*g to integer",
+ DBL_DIG, value);
+ print_text(mpl, from, (int)floor(value + 0.5));
+ }
+ else
+ print_text(mpl, from, value);
+ }
+ else if (*c == 's')
+ { /* the specifier requires symbolic value */
+ char value[MAX_LENGTH+1];
+ switch (entry->code->type)
+ { case A_NUMERIC:
+ sprintf(value, "%.*g", DBL_DIG, eval_numeric(mpl,
+ entry->code));
+ break;
+ case A_LOGICAL:
+ if (eval_logical(mpl, entry->code))
+ strcpy(value, "T");
+ else
+ strcpy(value, "F");
+ break;
+ case A_SYMBOLIC:
+ sym = eval_symbolic(mpl, entry->code);
+ if (sym->str == NULL)
+ sprintf(value, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, value);
+ delete_symbol(mpl, sym);
+ break;
+ default:
+ xassert(entry != entry);
+ }
+ print_text(mpl, from, value);
+ }
+ else
+ error(mpl, "format specifier missing or invalid");
+ *(c+1) = save;
+ entry = entry->next;
+ }
+ else if (*c == '\\')
+ { /* write some control character */
+ c++;
+ if (*c == 't')
+ print_char(mpl, '\t');
+ else if (*c == 'n')
+ print_char(mpl, '\n');
+#if 1 /* 28/X-2010 */
+ else if (*c == '\0')
+ { /* format string ends with backslash */
+ error(mpl, "invalid use of escape character \\ in format"
+ " control string");
+ }
+#endif
+ else
+ print_char(mpl, *c);
+ }
+ else
+ { /* write character without formatting */
+ print_char(mpl, *c);
+ }
+ }
+ return 0;
+}
+
+#if 0 /* 14/VII-2006 */
+void execute_printf(MPL *mpl, PRINTF *prt)
+{ loop_within_domain(mpl, prt->domain, prt, printf_func);
+ return;
+}
+#else
+void execute_printf(MPL *mpl, PRINTF *prt)
+{ if (prt->fname == NULL)
+ { /* switch to the standard output */
+ if (mpl->prt_fp != NULL)
+ { glp_close(mpl->prt_fp), mpl->prt_fp = NULL;
+ xfree(mpl->prt_file), mpl->prt_file = NULL;
+ }
+ }
+ else
+ { /* evaluate file name string */
+ SYMBOL *sym;
+ char fname[MAX_LENGTH+1];
+ sym = eval_symbolic(mpl, prt->fname);
+ if (sym->str == NULL)
+ sprintf(fname, "%.*g", DBL_DIG, sym->num);
+ else
+ fetch_string(mpl, sym->str, fname);
+ delete_symbol(mpl, sym);
+ /* close the current print file, if necessary */
+ if (mpl->prt_fp != NULL &&
+ (!prt->app || strcmp(mpl->prt_file, fname) != 0))
+ { glp_close(mpl->prt_fp), mpl->prt_fp = NULL;
+ xfree(mpl->prt_file), mpl->prt_file = NULL;
+ }
+ /* open the specified print file, if necessary */
+ if (mpl->prt_fp == NULL)
+ { mpl->prt_fp = glp_open(fname, prt->app ? "a" : "w");
+ if (mpl->prt_fp == NULL)
+ error(mpl, "unable to open '%s' for writing - %s",
+ fname, get_err_msg());
+ mpl->prt_file = xmalloc(strlen(fname)+1);
+ strcpy(mpl->prt_file, fname);
+ }
+ }
+ loop_within_domain(mpl, prt->domain, prt, printf_func);
+ if (mpl->prt_fp != NULL)
+ {
+#if 0 /* FIXME */
+ xfflush(mpl->prt_fp);
+#endif
+ if (glp_ioerr(mpl->prt_fp))
+ error(mpl, "writing error to '%s' - %s", mpl->prt_file,
+ get_err_msg());
+ }
+ return;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- clean_printf - clean printf statement.
+--
+-- This routine cleans specified printf statement that assumes deleting
+-- all stuff dynamically allocated on generating/postsolving phase. */
+
+void clean_printf(MPL *mpl, PRINTF *prt)
+{ PRINTF1 *p;
+ /* clean subscript domain */
+ clean_domain(mpl, prt->domain);
+ /* clean pseudo-code for computing format string */
+ clean_code(mpl, prt->fmt);
+ /* clean printf list */
+ for (p = prt->list; p != NULL; p = p->next)
+ { /* clean pseudo-code for computing value to be printed */
+ clean_code(mpl, p->code);
+ }
+#if 1 /* 14/VII-2006 */
+ /* clean pseudo-code for computing file name string */
+ clean_code(mpl, prt->fname);
+#endif
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- execute_for - execute for statement.
+--
+-- This routine executes specified for statement. */
+
+static int for_func(MPL *mpl, void *info)
+{ /* this is auxiliary routine to work within domain scope */
+ FOR *fur = (FOR *)info;
+ STATEMENT *stmt, *save;
+ save = mpl->stmt;
+ for (stmt = fur->list; stmt != NULL; stmt = stmt->next)
+ execute_statement(mpl, stmt);
+ mpl->stmt = save;
+ return 0;
+}
+
+void execute_for(MPL *mpl, FOR *fur)
+{ loop_within_domain(mpl, fur->domain, fur, for_func);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_for - clean for statement.
+--
+-- This routine cleans specified for statement that assumes deleting all
+-- stuff dynamically allocated on generating/postsolving phase. */
+
+void clean_for(MPL *mpl, FOR *fur)
+{ STATEMENT *stmt;
+ /* clean subscript domain */
+ clean_domain(mpl, fur->domain);
+ /* clean all sub-statements */
+ for (stmt = fur->list; stmt != NULL; stmt = stmt->next)
+ clean_statement(mpl, stmt);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- execute_statement - execute specified model statement.
+--
+-- This routine executes specified model statement. */
+
+void execute_statement(MPL *mpl, STATEMENT *stmt)
+{ mpl->stmt = stmt;
+ switch (stmt->type)
+ { case A_SET:
+ case A_PARAMETER:
+ case A_VARIABLE:
+ break;
+ case A_CONSTRAINT:
+ xprintf("Generating %s...\n", stmt->u.con->name);
+ eval_whole_con(mpl, stmt->u.con);
+ break;
+ case A_TABLE:
+ switch (stmt->u.tab->type)
+ { case A_INPUT:
+ xprintf("Reading %s...\n", stmt->u.tab->name);
+ break;
+ case A_OUTPUT:
+ xprintf("Writing %s...\n", stmt->u.tab->name);
+ break;
+ default:
+ xassert(stmt != stmt);
+ }
+ execute_table(mpl, stmt->u.tab);
+ break;
+ case A_SOLVE:
+ break;
+ case A_CHECK:
+ xprintf("Checking (line %d)...\n", stmt->line);
+ execute_check(mpl, stmt->u.chk);
+ break;
+ case A_DISPLAY:
+ write_text(mpl, "Display statement at line %d\n",
+ stmt->line);
+ execute_display(mpl, stmt->u.dpy);
+ break;
+ case A_PRINTF:
+ execute_printf(mpl, stmt->u.prt);
+ break;
+ case A_FOR:
+ execute_for(mpl, stmt->u.fur);
+ break;
+ default:
+ xassert(stmt != stmt);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_statement - clean specified model statement.
+--
+-- This routine cleans specified model statement that assumes deleting
+-- all stuff dynamically allocated on generating/postsolving phase. */
+
+void clean_statement(MPL *mpl, STATEMENT *stmt)
+{ switch(stmt->type)
+ { case A_SET:
+ clean_set(mpl, stmt->u.set); break;
+ case A_PARAMETER:
+ clean_parameter(mpl, stmt->u.par); break;
+ case A_VARIABLE:
+ clean_variable(mpl, stmt->u.var); break;
+ case A_CONSTRAINT:
+ clean_constraint(mpl, stmt->u.con); break;
+#if 1 /* 11/II-2008 */
+ case A_TABLE:
+ clean_table(mpl, stmt->u.tab); break;
+#endif
+ case A_SOLVE:
+ break;
+ case A_CHECK:
+ clean_check(mpl, stmt->u.chk); break;
+ case A_DISPLAY:
+ clean_display(mpl, stmt->u.dpy); break;
+ case A_PRINTF:
+ clean_printf(mpl, stmt->u.prt); break;
+ case A_FOR:
+ clean_for(mpl, stmt->u.fur); break;
+ default:
+ xassert(stmt != stmt);
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl4.c b/test/monniaux/glpk-4.65/src/mpl/mpl4.c
new file mode 100644
index 00000000..6e80499c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl4.c
@@ -0,0 +1,1426 @@
+/* mpl4.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+
+#define xfault xerror
+#define xfprintf glp_format
+#define dmp_create_poolx(size) dmp_create_pool()
+
+/**********************************************************************/
+/* * * GENERATING AND POSTSOLVING MODEL * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- alloc_content - allocate content arrays for all model objects.
+--
+-- This routine allocates content arrays for all existing model objects
+-- and thereby finalizes creating model.
+--
+-- This routine must be called immediately after reading model section,
+-- i.e. before reading data section or generating model. */
+
+void alloc_content(MPL *mpl)
+{ STATEMENT *stmt;
+ /* walk through all model statements */
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { switch (stmt->type)
+ { case A_SET:
+ /* model set */
+ xassert(stmt->u.set->array == NULL);
+ stmt->u.set->array = create_array(mpl, A_ELEMSET,
+ stmt->u.set->dim);
+ break;
+ case A_PARAMETER:
+ /* model parameter */
+ xassert(stmt->u.par->array == NULL);
+ switch (stmt->u.par->type)
+ { case A_NUMERIC:
+ case A_INTEGER:
+ case A_BINARY:
+ stmt->u.par->array = create_array(mpl, A_NUMERIC,
+ stmt->u.par->dim);
+ break;
+ case A_SYMBOLIC:
+ stmt->u.par->array = create_array(mpl, A_SYMBOLIC,
+ stmt->u.par->dim);
+ break;
+ default:
+ xassert(stmt != stmt);
+ }
+ break;
+ case A_VARIABLE:
+ /* model variable */
+ xassert(stmt->u.var->array == NULL);
+ stmt->u.var->array = create_array(mpl, A_ELEMVAR,
+ stmt->u.var->dim);
+ break;
+ case A_CONSTRAINT:
+ /* model constraint/objective */
+ xassert(stmt->u.con->array == NULL);
+ stmt->u.con->array = create_array(mpl, A_ELEMCON,
+ stmt->u.con->dim);
+ break;
+#if 1 /* 11/II-2008 */
+ case A_TABLE:
+#endif
+ case A_SOLVE:
+ case A_CHECK:
+ case A_DISPLAY:
+ case A_PRINTF:
+ case A_FOR:
+ /* functional statements have no content array */
+ break;
+ default:
+ xassert(stmt != stmt);
+ }
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- generate_model - generate model.
+--
+-- This routine executes the model statements which precede the solve
+-- statement. */
+
+void generate_model(MPL *mpl)
+{ STATEMENT *stmt;
+ xassert(!mpl->flag_p);
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { execute_statement(mpl, stmt);
+ if (mpl->stmt->type == A_SOLVE) break;
+ }
+ mpl->stmt = stmt;
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- build_problem - build problem instance.
+--
+-- This routine builds lists of rows and columns for problem instance,
+-- which corresponds to the generated model. */
+
+void build_problem(MPL *mpl)
+{ STATEMENT *stmt;
+ MEMBER *memb;
+ VARIABLE *v;
+ CONSTRAINT *c;
+ FORMULA *t;
+ int i, j;
+ xassert(mpl->m == 0);
+ xassert(mpl->n == 0);
+ xassert(mpl->row == NULL);
+ xassert(mpl->col == NULL);
+ /* check that all elemental variables has zero column numbers */
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { if (stmt->type == A_VARIABLE)
+ { v = stmt->u.var;
+ for (memb = v->array->head; memb != NULL; memb = memb->next)
+ xassert(memb->value.var->j == 0);
+ }
+ }
+ /* assign row numbers to elemental constraints and objectives */
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { if (stmt->type == A_CONSTRAINT)
+ { c = stmt->u.con;
+ for (memb = c->array->head; memb != NULL; memb = memb->next)
+ { xassert(memb->value.con->i == 0);
+ memb->value.con->i = ++mpl->m;
+ /* walk through linear form and mark elemental variables,
+ which are referenced at least once */
+ for (t = memb->value.con->form; t != NULL; t = t->next)
+ { xassert(t->var != NULL);
+ t->var->memb->value.var->j = -1;
+ }
+ }
+ }
+ }
+ /* assign column numbers to marked elemental variables */
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { if (stmt->type == A_VARIABLE)
+ { v = stmt->u.var;
+ for (memb = v->array->head; memb != NULL; memb = memb->next)
+ if (memb->value.var->j != 0) memb->value.var->j =
+ ++mpl->n;
+ }
+ }
+ /* build list of rows */
+ mpl->row = xcalloc(1+mpl->m, sizeof(ELEMCON *));
+ for (i = 1; i <= mpl->m; i++) mpl->row[i] = NULL;
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { if (stmt->type == A_CONSTRAINT)
+ { c = stmt->u.con;
+ for (memb = c->array->head; memb != NULL; memb = memb->next)
+ { i = memb->value.con->i;
+ xassert(1 <= i && i <= mpl->m);
+ xassert(mpl->row[i] == NULL);
+ mpl->row[i] = memb->value.con;
+ }
+ }
+ }
+ for (i = 1; i <= mpl->m; i++) xassert(mpl->row[i] != NULL);
+ /* build list of columns */
+ mpl->col = xcalloc(1+mpl->n, sizeof(ELEMVAR *));
+ for (j = 1; j <= mpl->n; j++) mpl->col[j] = NULL;
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ { if (stmt->type == A_VARIABLE)
+ { v = stmt->u.var;
+ for (memb = v->array->head; memb != NULL; memb = memb->next)
+ { j = memb->value.var->j;
+ if (j == 0) continue;
+ xassert(1 <= j && j <= mpl->n);
+ xassert(mpl->col[j] == NULL);
+ mpl->col[j] = memb->value.var;
+ }
+ }
+ }
+ for (j = 1; j <= mpl->n; j++) xassert(mpl->col[j] != NULL);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- postsolve_model - postsolve model.
+--
+-- This routine executes the model statements which follow the solve
+-- statement. */
+
+void postsolve_model(MPL *mpl)
+{ STATEMENT *stmt;
+ xassert(!mpl->flag_p);
+ mpl->flag_p = 1;
+ for (stmt = mpl->stmt; stmt != NULL; stmt = stmt->next)
+ execute_statement(mpl, stmt);
+ mpl->stmt = NULL;
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- clean_model - clean model content.
+--
+-- This routine cleans the model content that assumes deleting all stuff
+-- dynamically allocated on generating/postsolving phase.
+--
+-- Actually cleaning model content is not needed. This function is used
+-- mainly to be sure that there were no logical errors on using dynamic
+-- memory pools during the generation phase.
+--
+-- NOTE: This routine must not be called if any errors were detected on
+-- the generation phase. */
+
+void clean_model(MPL *mpl)
+{ STATEMENT *stmt;
+ for (stmt = mpl->model; stmt != NULL; stmt = stmt->next)
+ clean_statement(mpl, stmt);
+ /* check that all atoms have been returned to their pools */
+ if (dmp_in_use(mpl->strings) != 0)
+ error(mpl, "internal logic error: %d string segment(s) were lo"
+ "st", dmp_in_use(mpl->strings));
+ if (dmp_in_use(mpl->symbols) != 0)
+ error(mpl, "internal logic error: %d symbol(s) were lost",
+ dmp_in_use(mpl->symbols));
+ if (dmp_in_use(mpl->tuples) != 0)
+ error(mpl, "internal logic error: %d n-tuple component(s) were"
+ " lost", dmp_in_use(mpl->tuples));
+ if (dmp_in_use(mpl->arrays) != 0)
+ error(mpl, "internal logic error: %d array(s) were lost",
+ dmp_in_use(mpl->arrays));
+ if (dmp_in_use(mpl->members) != 0)
+ error(mpl, "internal logic error: %d array member(s) were lost"
+ , dmp_in_use(mpl->members));
+ if (dmp_in_use(mpl->elemvars) != 0)
+ error(mpl, "internal logic error: %d elemental variable(s) wer"
+ "e lost", dmp_in_use(mpl->elemvars));
+ if (dmp_in_use(mpl->formulae) != 0)
+ error(mpl, "internal logic error: %d linear term(s) were lost",
+ dmp_in_use(mpl->formulae));
+ if (dmp_in_use(mpl->elemcons) != 0)
+ error(mpl, "internal logic error: %d elemental constraint(s) w"
+ "ere lost", dmp_in_use(mpl->elemcons));
+ return;
+}
+
+/**********************************************************************/
+/* * * INPUT/OUTPUT * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- open_input - open input text file.
+--
+-- This routine opens the input text file for scanning. */
+
+void open_input(MPL *mpl, char *file)
+{ mpl->line = 0;
+ mpl->c = '\n';
+ mpl->token = 0;
+ mpl->imlen = 0;
+ mpl->image[0] = '\0';
+ mpl->value = 0.0;
+ mpl->b_token = T_EOF;
+ mpl->b_imlen = 0;
+ mpl->b_image[0] = '\0';
+ mpl->b_value = 0.0;
+ mpl->f_dots = 0;
+ mpl->f_scan = 0;
+ mpl->f_token = 0;
+ mpl->f_imlen = 0;
+ mpl->f_image[0] = '\0';
+ mpl->f_value = 0.0;
+ memset(mpl->context, ' ', CONTEXT_SIZE);
+ mpl->c_ptr = 0;
+ xassert(mpl->in_fp == NULL);
+ mpl->in_fp = glp_open(file, "r");
+ if (mpl->in_fp == NULL)
+ error(mpl, "unable to open %s - %s", file, get_err_msg());
+ mpl->in_file = file;
+ /* scan the very first character */
+ get_char(mpl);
+ /* scan the very first token */
+ get_token(mpl);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- read_char - read next character from input text file.
+--
+-- This routine returns a next ASCII character read from the input text
+-- file. If the end of file has been reached, EOF is returned. */
+
+int read_char(MPL *mpl)
+{ int c;
+ xassert(mpl->in_fp != NULL);
+ c = glp_getc(mpl->in_fp);
+ if (c < 0)
+ { if (glp_ioerr(mpl->in_fp))
+ error(mpl, "read error on %s - %s", mpl->in_file,
+ get_err_msg());
+ c = EOF;
+ }
+ return c;
+}
+
+/*----------------------------------------------------------------------
+-- close_input - close input text file.
+--
+-- This routine closes the input text file. */
+
+void close_input(MPL *mpl)
+{ xassert(mpl->in_fp != NULL);
+ glp_close(mpl->in_fp);
+ mpl->in_fp = NULL;
+ mpl->in_file = NULL;
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- open_output - open output text file.
+--
+-- This routine opens the output text file for writing data produced by
+-- display and printf statements. */
+
+void open_output(MPL *mpl, char *file)
+{ xassert(mpl->out_fp == NULL);
+ if (file == NULL)
+ { file = "<stdout>";
+ mpl->out_fp = (void *)stdout;
+ }
+ else
+ { mpl->out_fp = glp_open(file, "w");
+ if (mpl->out_fp == NULL)
+ error(mpl, "unable to create %s - %s", file, get_err_msg());
+ }
+ mpl->out_file = xmalloc(strlen(file)+1);
+ strcpy(mpl->out_file, file);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- write_char - write next character to output text file.
+--
+-- This routine writes an ASCII character to the output text file. */
+
+void write_char(MPL *mpl, int c)
+{ xassert(mpl->out_fp != NULL);
+ if (mpl->out_fp == (void *)stdout)
+ xprintf("%c", c);
+ else
+ xfprintf(mpl->out_fp, "%c", c);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- write_text - format and write text to output text file.
+--
+-- This routine formats a text using the format control string and then
+-- writes this text to the output text file. */
+
+void write_text(MPL *mpl, char *fmt, ...)
+{ va_list arg;
+ char buf[OUTBUF_SIZE], *c;
+ va_start(arg, fmt);
+ vsprintf(buf, fmt, arg);
+ xassert(strlen(buf) < sizeof(buf));
+ va_end(arg);
+ for (c = buf; *c != '\0'; c++) write_char(mpl, *c);
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- flush_output - finalize writing data to output text file.
+--
+-- This routine finalizes writing data to the output text file. */
+
+void flush_output(MPL *mpl)
+{ xassert(mpl->out_fp != NULL);
+ if (mpl->out_fp != (void *)stdout)
+ {
+#if 0 /* FIXME */
+ xfflush(mpl->out_fp);
+#endif
+ if (glp_ioerr(mpl->out_fp))
+ error(mpl, "write error on %s - %s", mpl->out_file,
+ get_err_msg());
+ }
+ return;
+}
+
+/**********************************************************************/
+/* * * SOLVER INTERFACE * * */
+/**********************************************************************/
+
+/*----------------------------------------------------------------------
+-- error - print error message and terminate model processing.
+--
+-- This routine formats and prints an error message and then terminates
+-- model processing. */
+
+void error(MPL *mpl, char *fmt, ...)
+{ va_list arg;
+ char msg[4095+1];
+ va_start(arg, fmt);
+ vsprintf(msg, fmt, arg);
+ xassert(strlen(msg) < sizeof(msg));
+ va_end(arg);
+ switch (mpl->phase)
+ { case 1:
+ case 2:
+ /* translation phase */
+ xprintf("%s:%d: %s\n",
+ mpl->in_file == NULL ? "(unknown)" : mpl->in_file,
+ mpl->line, msg);
+ print_context(mpl);
+ break;
+ case 3:
+ /* generation/postsolve phase */
+ xprintf("%s:%d: %s\n",
+ mpl->mod_file == NULL ? "(unknown)" : mpl->mod_file,
+ mpl->stmt == NULL ? 0 : mpl->stmt->line, msg);
+ break;
+ default:
+ xassert(mpl != mpl);
+ }
+ mpl->phase = 4;
+ longjmp(mpl->jump, 1);
+ /* no return */
+}
+
+/*----------------------------------------------------------------------
+-- warning - print warning message and continue model processing.
+--
+-- This routine formats and prints a warning message and returns to the
+-- calling program. */
+
+void warning(MPL *mpl, char *fmt, ...)
+{ va_list arg;
+ char msg[4095+1];
+ va_start(arg, fmt);
+ vsprintf(msg, fmt, arg);
+ xassert(strlen(msg) < sizeof(msg));
+ va_end(arg);
+ switch (mpl->phase)
+ { case 1:
+ case 2:
+ /* translation phase */
+ xprintf("%s:%d: warning: %s\n",
+ mpl->in_file == NULL ? "(unknown)" : mpl->in_file,
+ mpl->line, msg);
+ break;
+ case 3:
+ /* generation/postsolve phase */
+ xprintf("%s:%d: warning: %s\n",
+ mpl->mod_file == NULL ? "(unknown)" : mpl->mod_file,
+ mpl->stmt == NULL ? 0 : mpl->stmt->line, msg);
+ break;
+ default:
+ xassert(mpl != mpl);
+ }
+ return;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_initialize - create and initialize translator database.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- MPL *mpl_initialize(void);
+--
+-- *Description*
+--
+-- The routine mpl_initialize creates and initializes the database used
+-- by the GNU MathProg translator.
+--
+-- *Returns*
+--
+-- The routine returns a pointer to the database created. */
+
+MPL *mpl_initialize(void)
+{ MPL *mpl;
+ mpl = xmalloc(sizeof(MPL));
+ /* scanning segment */
+ mpl->line = 0;
+ mpl->c = 0;
+ mpl->token = 0;
+ mpl->imlen = 0;
+ mpl->image = xcalloc(MAX_LENGTH+1, sizeof(char));
+ mpl->image[0] = '\0';
+ mpl->value = 0.0;
+ mpl->b_token = 0;
+ mpl->b_imlen = 0;
+ mpl->b_image = xcalloc(MAX_LENGTH+1, sizeof(char));
+ mpl->b_image[0] = '\0';
+ mpl->b_value = 0.0;
+ mpl->f_dots = 0;
+ mpl->f_scan = 0;
+ mpl->f_token = 0;
+ mpl->f_imlen = 0;
+ mpl->f_image = xcalloc(MAX_LENGTH+1, sizeof(char));
+ mpl->f_image[0] = '\0';
+ mpl->f_value = 0.0;
+ mpl->context = xcalloc(CONTEXT_SIZE, sizeof(char));
+ memset(mpl->context, ' ', CONTEXT_SIZE);
+ mpl->c_ptr = 0;
+ mpl->flag_d = 0;
+ /* translating segment */
+ mpl->pool = dmp_create_poolx(0);
+ mpl->tree = avl_create_tree(avl_strcmp, NULL);
+ mpl->model = NULL;
+ mpl->flag_x = 0;
+ mpl->as_within = 0;
+ mpl->as_in = 0;
+ mpl->as_binary = 0;
+ mpl->flag_s = 0;
+ /* common segment */
+ mpl->strings = dmp_create_poolx(sizeof(STRING));
+ mpl->symbols = dmp_create_poolx(sizeof(SYMBOL));
+ mpl->tuples = dmp_create_poolx(sizeof(TUPLE));
+ mpl->arrays = dmp_create_poolx(sizeof(ARRAY));
+ mpl->members = dmp_create_poolx(sizeof(MEMBER));
+ mpl->elemvars = dmp_create_poolx(sizeof(ELEMVAR));
+ mpl->formulae = dmp_create_poolx(sizeof(FORMULA));
+ mpl->elemcons = dmp_create_poolx(sizeof(ELEMCON));
+ mpl->a_list = NULL;
+ mpl->sym_buf = xcalloc(255+1, sizeof(char));
+ mpl->sym_buf[0] = '\0';
+ mpl->tup_buf = xcalloc(255+1, sizeof(char));
+ mpl->tup_buf[0] = '\0';
+ /* generating/postsolving segment */
+ mpl->rand = rng_create_rand();
+ mpl->flag_p = 0;
+ mpl->stmt = NULL;
+#if 1 /* 11/II-2008 */
+ mpl->dca = NULL;
+#endif
+ mpl->m = 0;
+ mpl->n = 0;
+ mpl->row = NULL;
+ mpl->col = NULL;
+ /* input/output segment */
+ mpl->in_fp = NULL;
+ mpl->in_file = NULL;
+ mpl->out_fp = NULL;
+ mpl->out_file = NULL;
+ mpl->prt_fp = NULL;
+ mpl->prt_file = NULL;
+ /* solver interface segment */
+ if (setjmp(mpl->jump)) xassert(mpl != mpl);
+ mpl->phase = 0;
+ mpl->mod_file = NULL;
+ mpl->mpl_buf = xcalloc(255+1, sizeof(char));
+ mpl->mpl_buf[0] = '\0';
+ return mpl;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_read_model - read model section and optional data section.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_read_model(MPL *mpl, char *file, int skip_data);
+--
+-- *Description*
+--
+-- The routine mpl_read_model reads model section and optionally data
+-- section, which may follow the model section, from the text file,
+-- whose name is the character string file, performs translating model
+-- statements and data blocks, and stores all the information in the
+-- translator database.
+--
+-- The parameter skip_data is a flag. If the input file contains the
+-- data section and this flag is set, the data section is not read as
+-- if there were no data section and a warning message is issued. This
+-- allows reading the data section from another input file.
+--
+-- This routine should be called once after the routine mpl_initialize
+-- and before other API routines.
+--
+-- *Returns*
+--
+-- The routine mpl_read_model returns one the following codes:
+--
+-- 1 - translation successful. The input text file contains only model
+-- section. In this case the calling program may call the routine
+-- mpl_read_data to read data section from another file.
+-- 2 - translation successful. The input text file contains both model
+-- and data section.
+-- 4 - processing failed due to some errors. In this case the calling
+-- program should call the routine mpl_terminate to terminate model
+-- processing. */
+
+int mpl_read_model(MPL *mpl, char *file, int skip_data)
+{ if (mpl->phase != 0)
+ xfault("mpl_read_model: invalid call sequence\n");
+ if (file == NULL)
+ xfault("mpl_read_model: no input filename specified\n");
+ /* set up error handler */
+ if (setjmp(mpl->jump)) goto done;
+ /* translate model section */
+ mpl->phase = 1;
+ xprintf("Reading model section from %s...\n", file);
+ open_input(mpl, file);
+ model_section(mpl);
+ if (mpl->model == NULL)
+ error(mpl, "empty model section not allowed");
+ /* save name of the input text file containing model section for
+ error diagnostics during the generation phase */
+ mpl->mod_file = xcalloc(strlen(file)+1, sizeof(char));
+ strcpy(mpl->mod_file, mpl->in_file);
+ /* allocate content arrays for all model objects */
+ alloc_content(mpl);
+ /* optional data section may begin with the keyword 'data' */
+ if (is_keyword(mpl, "data"))
+ { if (skip_data)
+ { warning(mpl, "data section ignored");
+ goto skip;
+ }
+ mpl->flag_d = 1;
+ get_token(mpl /* data */);
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "semicolon missing where expected");
+ get_token(mpl /* ; */);
+ /* translate data section */
+ mpl->phase = 2;
+ xprintf("Reading data section from %s...\n", file);
+ data_section(mpl);
+ }
+ /* process end statement */
+ end_statement(mpl);
+skip: xprintf("%d line%s were read\n",
+ mpl->line, mpl->line == 1 ? "" : "s");
+ close_input(mpl);
+done: /* return to the calling program */
+ return mpl->phase;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_read_data - read data section.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_read_data(MPL *mpl, char *file);
+--
+-- *Description*
+--
+-- The routine mpl_read_data reads data section from the text file,
+-- whose name is the character string file, performs translating data
+-- blocks, and stores the data read in the translator database.
+--
+-- If this routine is used, it should be called once after the routine
+-- mpl_read_model and if the latter returned the code 1.
+--
+-- *Returns*
+--
+-- The routine mpl_read_data returns one of the following codes:
+--
+-- 2 - data section has been successfully processed.
+-- 4 - processing failed due to some errors. In this case the calling
+-- program should call the routine mpl_terminate to terminate model
+-- processing. */
+
+int mpl_read_data(MPL *mpl, char *file)
+#if 0 /* 02/X-2008 */
+{ if (mpl->phase != 1)
+#else
+{ if (!(mpl->phase == 1 || mpl->phase == 2))
+#endif
+ xfault("mpl_read_data: invalid call sequence\n");
+ if (file == NULL)
+ xfault("mpl_read_data: no input filename specified\n");
+ /* set up error handler */
+ if (setjmp(mpl->jump)) goto done;
+ /* process data section */
+ mpl->phase = 2;
+ xprintf("Reading data section from %s...\n", file);
+ mpl->flag_d = 1;
+ open_input(mpl, file);
+ /* in this case the keyword 'data' is optional */
+ if (is_literal(mpl, "data"))
+ { get_token(mpl /* data */);
+ if (mpl->token != T_SEMICOLON)
+ error(mpl, "semicolon missing where expected");
+ get_token(mpl /* ; */);
+ }
+ data_section(mpl);
+ /* process end statement */
+ end_statement(mpl);
+ xprintf("%d line%s were read\n",
+ mpl->line, mpl->line == 1 ? "" : "s");
+ close_input(mpl);
+done: /* return to the calling program */
+ return mpl->phase;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_generate - generate model.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_generate(MPL *mpl, char *file);
+--
+-- *Description*
+--
+-- The routine mpl_generate generates the model using its description
+-- stored in the translator database. This phase means generating all
+-- variables, constraints, and objectives, executing check and display
+-- statements, which precede the solve statement (if it is presented),
+-- and building the problem instance.
+--
+-- The character string file specifies the name of output text file, to
+-- which output produced by display statements should be written. It is
+-- allowed to specify NULL, in which case the output goes to stdout via
+-- the routine print.
+--
+-- This routine should be called once after the routine mpl_read_model
+-- or mpl_read_data and if one of the latters returned the code 2.
+--
+-- *Returns*
+--
+-- The routine mpl_generate returns one of the following codes:
+--
+-- 3 - model has been successfully generated. In this case the calling
+-- program may call other api routines to obtain components of the
+-- problem instance from the translator database.
+-- 4 - processing failed due to some errors. In this case the calling
+-- program should call the routine mpl_terminate to terminate model
+-- processing. */
+
+int mpl_generate(MPL *mpl, char *file)
+{ if (!(mpl->phase == 1 || mpl->phase == 2))
+ xfault("mpl_generate: invalid call sequence\n");
+ /* set up error handler */
+ if (setjmp(mpl->jump)) goto done;
+ /* generate model */
+ mpl->phase = 3;
+ open_output(mpl, file);
+ generate_model(mpl);
+ flush_output(mpl);
+ /* build problem instance */
+ build_problem(mpl);
+ /* generation phase has been finished */
+ xprintf("Model has been successfully generated\n");
+done: /* return to the calling program */
+ return mpl->phase;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_prob_name - obtain problem (model) name.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- char *mpl_get_prob_name(MPL *mpl);
+--
+-- *Returns*
+--
+-- The routine mpl_get_prob_name returns a pointer to internal buffer,
+-- which contains symbolic name of the problem (model).
+--
+-- *Note*
+--
+-- Currently MathProg has no feature to assign a symbolic name to the
+-- model. Therefore the routine mpl_get_prob_name tries to construct
+-- such name using the name of input text file containing model section,
+-- although this is not a good idea (due to portability problems). */
+
+char *mpl_get_prob_name(MPL *mpl)
+{ char *name = mpl->mpl_buf;
+ char *file = mpl->mod_file;
+ int k;
+ if (mpl->phase != 3)
+ xfault("mpl_get_prob_name: invalid call sequence\n");
+ for (;;)
+ { if (strchr(file, '/') != NULL)
+ file = strchr(file, '/') + 1;
+ else if (strchr(file, '\\') != NULL)
+ file = strchr(file, '\\') + 1;
+ else if (strchr(file, ':') != NULL)
+ file = strchr(file, ':') + 1;
+ else
+ break;
+ }
+ for (k = 0; ; k++)
+ { if (k == 255) break;
+ if (!(isalnum((unsigned char)*file) || *file == '_')) break;
+ name[k] = *file++;
+ }
+ if (k == 0)
+ strcpy(name, "Unknown");
+ else
+ name[k] = '\0';
+ xassert(strlen(name) <= 255);
+ return name;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_num_rows - determine number of rows.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_num_rows(MPL *mpl);
+--
+-- *Returns*
+--
+-- The routine mpl_get_num_rows returns total number of rows in the
+-- problem, where each row is an individual constraint or objective. */
+
+int mpl_get_num_rows(MPL *mpl)
+{ if (mpl->phase != 3)
+ xfault("mpl_get_num_rows: invalid call sequence\n");
+ return mpl->m;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_num_cols - determine number of columns.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_num_cols(MPL *mpl);
+--
+-- *Returns*
+--
+-- The routine mpl_get_num_cols returns total number of columns in the
+-- problem, where each column is an individual variable. */
+
+int mpl_get_num_cols(MPL *mpl)
+{ if (mpl->phase != 3)
+ xfault("mpl_get_num_cols: invalid call sequence\n");
+ return mpl->n;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_row_name - obtain row name.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- char *mpl_get_row_name(MPL *mpl, int i);
+--
+-- *Returns*
+--
+-- The routine mpl_get_row_name returns a pointer to internal buffer,
+-- which contains symbolic name of i-th row of the problem. */
+
+char *mpl_get_row_name(MPL *mpl, int i)
+{ char *name = mpl->mpl_buf, *t;
+ int len;
+ if (mpl->phase != 3)
+ xfault("mpl_get_row_name: invalid call sequence\n");
+ if (!(1 <= i && i <= mpl->m))
+ xfault("mpl_get_row_name: i = %d; row number out of range\n",
+ i);
+ strcpy(name, mpl->row[i]->con->name);
+ len = strlen(name);
+ xassert(len <= 255);
+ t = format_tuple(mpl, '[', mpl->row[i]->memb->tuple);
+ while (*t)
+ { if (len == 255) break;
+ name[len++] = *t++;
+ }
+ name[len] = '\0';
+ if (len == 255) strcpy(name+252, "...");
+ xassert(strlen(name) <= 255);
+ return name;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_row_kind - determine row kind.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_row_kind(MPL *mpl, int i);
+--
+-- *Returns*
+--
+-- The routine mpl_get_row_kind returns the kind of i-th row, which can
+-- be one of the following:
+--
+-- MPL_ST - non-free (constraint) row;
+-- MPL_MIN - free (objective) row to be minimized;
+-- MPL_MAX - free (objective) row to be maximized. */
+
+int mpl_get_row_kind(MPL *mpl, int i)
+{ int kind;
+ if (mpl->phase != 3)
+ xfault("mpl_get_row_kind: invalid call sequence\n");
+ if (!(1 <= i && i <= mpl->m))
+ xfault("mpl_get_row_kind: i = %d; row number out of range\n",
+ i);
+ switch (mpl->row[i]->con->type)
+ { case A_CONSTRAINT:
+ kind = MPL_ST; break;
+ case A_MINIMIZE:
+ kind = MPL_MIN; break;
+ case A_MAXIMIZE:
+ kind = MPL_MAX; break;
+ default:
+ xassert(mpl != mpl);
+ }
+ return kind;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_row_bnds - obtain row bounds.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_row_bnds(MPL *mpl, int i, double *lb, double *ub);
+--
+-- *Description*
+--
+-- The routine mpl_get_row_bnds stores lower and upper bounds of i-th
+-- row of the problem to the locations, which the parameters lb and ub
+-- point to, respectively. Besides the routine returns the type of the
+-- i-th row.
+--
+-- If some of the parameters lb and ub is NULL, the corresponding bound
+-- value is not stored.
+--
+-- Types and bounds have the following meaning:
+--
+-- Type Bounds Note
+-- -----------------------------------------------------------
+-- MPL_FR -inf < f(x) < +inf Free linear form
+-- MPL_LO lb <= f(x) < +inf Inequality f(x) >= lb
+-- MPL_UP -inf < f(x) <= ub Inequality f(x) <= ub
+-- MPL_DB lb <= f(x) <= ub Inequality lb <= f(x) <= ub
+-- MPL_FX f(x) = lb Equality f(x) = lb
+--
+-- where f(x) is the corresponding linear form of the i-th row.
+--
+-- If the row has no lower bound, *lb is set to zero; if the row has
+-- no upper bound, *ub is set to zero; and if the row is of fixed type,
+-- both *lb and *ub are set to the same value.
+--
+-- *Returns*
+--
+-- The routine returns the type of the i-th row as it is stated in the
+-- table above. */
+
+int mpl_get_row_bnds(MPL *mpl, int i, double *_lb, double *_ub)
+{ ELEMCON *con;
+ int type;
+ double lb, ub;
+ if (mpl->phase != 3)
+ xfault("mpl_get_row_bnds: invalid call sequence\n");
+ if (!(1 <= i && i <= mpl->m))
+ xfault("mpl_get_row_bnds: i = %d; row number out of range\n",
+ i);
+ con = mpl->row[i];
+#if 0 /* 21/VII-2006 */
+ if (con->con->lbnd == NULL && con->con->ubnd == NULL)
+ type = MPL_FR, lb = ub = 0.0;
+ else if (con->con->ubnd == NULL)
+ type = MPL_LO, lb = con->lbnd, ub = 0.0;
+ else if (con->con->lbnd == NULL)
+ type = MPL_UP, lb = 0.0, ub = con->ubnd;
+ else if (con->con->lbnd != con->con->ubnd)
+ type = MPL_DB, lb = con->lbnd, ub = con->ubnd;
+ else
+ type = MPL_FX, lb = ub = con->lbnd;
+#else
+ lb = (con->con->lbnd == NULL ? -DBL_MAX : con->lbnd);
+ ub = (con->con->ubnd == NULL ? +DBL_MAX : con->ubnd);
+ if (lb == -DBL_MAX && ub == +DBL_MAX)
+ type = MPL_FR, lb = ub = 0.0;
+ else if (ub == +DBL_MAX)
+ type = MPL_LO, ub = 0.0;
+ else if (lb == -DBL_MAX)
+ type = MPL_UP, lb = 0.0;
+ else if (con->con->lbnd != con->con->ubnd)
+ type = MPL_DB;
+ else
+ type = MPL_FX;
+#endif
+ if (_lb != NULL) *_lb = lb;
+ if (_ub != NULL) *_ub = ub;
+ return type;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_mat_row - obtain row of the constraint matrix.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_mat_row(MPL *mpl, int i, int ndx[], double val[]);
+--
+-- *Description*
+--
+-- The routine mpl_get_mat_row stores column indices and numeric values
+-- of constraint coefficients for the i-th row to locations ndx[1], ...,
+-- ndx[len] and val[1], ..., val[len], respectively, where 0 <= len <= n
+-- is number of (structural) non-zero constraint coefficients, and n is
+-- number of columns in the problem.
+--
+-- If the parameter ndx is NULL, column indices are not stored. If the
+-- parameter val is NULL, numeric values are not stored.
+--
+-- Note that free rows may have constant terms, which are not part of
+-- the constraint matrix and therefore not reported by this routine. The
+-- constant term of a particular row can be obtained, if necessary, via
+-- the routine mpl_get_row_c0.
+--
+-- *Returns*
+--
+-- The routine mpl_get_mat_row returns len, which is length of i-th row
+-- of the constraint matrix (i.e. number of non-zero coefficients). */
+
+int mpl_get_mat_row(MPL *mpl, int i, int ndx[], double val[])
+{ FORMULA *term;
+ int len = 0;
+ if (mpl->phase != 3)
+ xfault("mpl_get_mat_row: invalid call sequence\n");
+ if (!(1 <= i && i <= mpl->m))
+ xfault("mpl_get_mat_row: i = %d; row number out of range\n",
+ i);
+ for (term = mpl->row[i]->form; term != NULL; term = term->next)
+ { xassert(term->var != NULL);
+ len++;
+ xassert(len <= mpl->n);
+ if (ndx != NULL) ndx[len] = term->var->j;
+ if (val != NULL) val[len] = term->coef;
+ }
+ return len;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_row_c0 - obtain constant term of free row.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- double mpl_get_row_c0(MPL *mpl, int i);
+--
+-- *Returns*
+--
+-- The routine mpl_get_row_c0 returns numeric value of constant term of
+-- i-th row.
+--
+-- Note that only free rows may have non-zero constant terms. Therefore
+-- if i-th row is not free, the routine returns zero. */
+
+double mpl_get_row_c0(MPL *mpl, int i)
+{ ELEMCON *con;
+ double c0;
+ if (mpl->phase != 3)
+ xfault("mpl_get_row_c0: invalid call sequence\n");
+ if (!(1 <= i && i <= mpl->m))
+ xfault("mpl_get_row_c0: i = %d; row number out of range\n",
+ i);
+ con = mpl->row[i];
+ if (con->con->lbnd == NULL && con->con->ubnd == NULL)
+ c0 = - con->lbnd;
+ else
+ c0 = 0.0;
+ return c0;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_col_name - obtain column name.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- char *mpl_get_col_name(MPL *mpl, int j);
+--
+-- *Returns*
+--
+-- The routine mpl_get_col_name returns a pointer to internal buffer,
+-- which contains symbolic name of j-th column of the problem. */
+
+char *mpl_get_col_name(MPL *mpl, int j)
+{ char *name = mpl->mpl_buf, *t;
+ int len;
+ if (mpl->phase != 3)
+ xfault("mpl_get_col_name: invalid call sequence\n");
+ if (!(1 <= j && j <= mpl->n))
+ xfault("mpl_get_col_name: j = %d; column number out of range\n"
+ , j);
+ strcpy(name, mpl->col[j]->var->name);
+ len = strlen(name);
+ xassert(len <= 255);
+ t = format_tuple(mpl, '[', mpl->col[j]->memb->tuple);
+ while (*t)
+ { if (len == 255) break;
+ name[len++] = *t++;
+ }
+ name[len] = '\0';
+ if (len == 255) strcpy(name+252, "...");
+ xassert(strlen(name) <= 255);
+ return name;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_col_kind - determine column kind.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_col_kind(MPL *mpl, int j);
+--
+-- *Returns*
+--
+-- The routine mpl_get_col_kind returns the kind of j-th column, which
+-- can be one of the following:
+--
+-- MPL_NUM - continuous variable;
+-- MPL_INT - integer variable;
+-- MPL_BIN - binary variable.
+--
+-- Note that column kinds are defined independently on type and bounds
+-- (reported by the routine mpl_get_col_bnds) of corresponding columns.
+-- This means, in particular, that bounds of an integer column may be
+-- fractional, or a binary column may have lower and upper bounds that
+-- are not 0 and 1 (or it may have no lower/upper bound at all). */
+
+int mpl_get_col_kind(MPL *mpl, int j)
+{ int kind;
+ if (mpl->phase != 3)
+ xfault("mpl_get_col_kind: invalid call sequence\n");
+ if (!(1 <= j && j <= mpl->n))
+ xfault("mpl_get_col_kind: j = %d; column number out of range\n"
+ , j);
+ switch (mpl->col[j]->var->type)
+ { case A_NUMERIC:
+ kind = MPL_NUM; break;
+ case A_INTEGER:
+ kind = MPL_INT; break;
+ case A_BINARY:
+ kind = MPL_BIN; break;
+ default:
+ xassert(mpl != mpl);
+ }
+ return kind;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_get_col_bnds - obtain column bounds.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_get_col_bnds(MPL *mpl, int j, double *lb, double *ub);
+--
+-- *Description*
+--
+-- The routine mpl_get_col_bnds stores lower and upper bound of j-th
+-- column of the problem to the locations, which the parameters lb and
+-- ub point to, respectively. Besides the routine returns the type of
+-- the j-th column.
+--
+-- If some of the parameters lb and ub is NULL, the corresponding bound
+-- value is not stored.
+--
+-- Types and bounds have the following meaning:
+--
+-- Type Bounds Note
+-- ------------------------------------------------------
+-- MPL_FR -inf < x < +inf Free (unbounded) variable
+-- MPL_LO lb <= x < +inf Variable with lower bound
+-- MPL_UP -inf < x <= ub Variable with upper bound
+-- MPL_DB lb <= x <= ub Double-bounded variable
+-- MPL_FX x = lb Fixed variable
+--
+-- where x is individual variable corresponding to the j-th column.
+--
+-- If the column has no lower bound, *lb is set to zero; if the column
+-- has no upper bound, *ub is set to zero; and if the column is of fixed
+-- type, both *lb and *ub are set to the same value.
+--
+-- *Returns*
+--
+-- The routine returns the type of the j-th column as it is stated in
+-- the table above. */
+
+int mpl_get_col_bnds(MPL *mpl, int j, double *_lb, double *_ub)
+{ ELEMVAR *var;
+ int type;
+ double lb, ub;
+ if (mpl->phase != 3)
+ xfault("mpl_get_col_bnds: invalid call sequence\n");
+ if (!(1 <= j && j <= mpl->n))
+ xfault("mpl_get_col_bnds: j = %d; column number out of range\n"
+ , j);
+ var = mpl->col[j];
+#if 0 /* 21/VII-2006 */
+ if (var->var->lbnd == NULL && var->var->ubnd == NULL)
+ type = MPL_FR, lb = ub = 0.0;
+ else if (var->var->ubnd == NULL)
+ type = MPL_LO, lb = var->lbnd, ub = 0.0;
+ else if (var->var->lbnd == NULL)
+ type = MPL_UP, lb = 0.0, ub = var->ubnd;
+ else if (var->var->lbnd != var->var->ubnd)
+ type = MPL_DB, lb = var->lbnd, ub = var->ubnd;
+ else
+ type = MPL_FX, lb = ub = var->lbnd;
+#else
+ lb = (var->var->lbnd == NULL ? -DBL_MAX : var->lbnd);
+ ub = (var->var->ubnd == NULL ? +DBL_MAX : var->ubnd);
+ if (lb == -DBL_MAX && ub == +DBL_MAX)
+ type = MPL_FR, lb = ub = 0.0;
+ else if (ub == +DBL_MAX)
+ type = MPL_LO, ub = 0.0;
+ else if (lb == -DBL_MAX)
+ type = MPL_UP, lb = 0.0;
+ else if (var->var->lbnd != var->var->ubnd)
+ type = MPL_DB;
+ else
+ type = MPL_FX;
+#endif
+ if (_lb != NULL) *_lb = lb;
+ if (_ub != NULL) *_ub = ub;
+ return type;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_has_solve_stmt - check if model has solve statement.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_has_solve_stmt(MPL *mpl);
+--
+-- *Returns*
+--
+-- If the model has the solve statement, the routine returns non-zero,
+-- otherwise zero is returned. */
+
+int mpl_has_solve_stmt(MPL *mpl)
+{ if (mpl->phase != 3)
+ xfault("mpl_has_solve_stmt: invalid call sequence\n");
+ return mpl->flag_s;
+}
+
+#if 1 /* 15/V-2010 */
+void mpl_put_row_soln(MPL *mpl, int i, int stat, double prim,
+ double dual)
+{ /* store row (constraint/objective) solution components */
+ xassert(mpl->phase == 3);
+ xassert(1 <= i && i <= mpl->m);
+ mpl->row[i]->stat = stat;
+ mpl->row[i]->prim = prim;
+ mpl->row[i]->dual = dual;
+ return;
+}
+#endif
+
+#if 1 /* 15/V-2010 */
+void mpl_put_col_soln(MPL *mpl, int j, int stat, double prim,
+ double dual)
+{ /* store column (variable) solution components */
+ xassert(mpl->phase == 3);
+ xassert(1 <= j && j <= mpl->n);
+ mpl->col[j]->stat = stat;
+ mpl->col[j]->prim = prim;
+ mpl->col[j]->dual = dual;
+ return;
+}
+#endif
+
+#if 0 /* 15/V-2010 */
+/*----------------------------------------------------------------------
+-- mpl_put_col_value - store column value.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- void mpl_put_col_value(MPL *mpl, int j, double val);
+--
+-- *Description*
+--
+-- The routine mpl_put_col_value stores numeric value of j-th column
+-- into the translator database. It is assumed that the column value is
+-- provided by the solver. */
+
+void mpl_put_col_value(MPL *mpl, int j, double val)
+{ if (mpl->phase != 3)
+ xfault("mpl_put_col_value: invalid call sequence\n");
+ if (!(1 <= j && j <= mpl->n))
+ xfault(
+ "mpl_put_col_value: j = %d; column number out of range\n", j);
+ mpl->col[j]->prim = val;
+ return;
+}
+#endif
+
+/*----------------------------------------------------------------------
+-- mpl_postsolve - postsolve model.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- int mpl_postsolve(MPL *mpl);
+--
+-- *Description*
+--
+-- The routine mpl_postsolve performs postsolving of the model using
+-- its description stored in the translator database. This phase means
+-- executing statements, which follow the solve statement.
+--
+-- If this routine is used, it should be called once after the routine
+-- mpl_generate and if the latter returned the code 3.
+--
+-- *Returns*
+--
+-- The routine mpl_postsolve returns one of the following codes:
+--
+-- 3 - model has been successfully postsolved.
+-- 4 - processing failed due to some errors. In this case the calling
+-- program should call the routine mpl_terminate to terminate model
+-- processing. */
+
+int mpl_postsolve(MPL *mpl)
+{ if (!(mpl->phase == 3 && !mpl->flag_p))
+ xfault("mpl_postsolve: invalid call sequence\n");
+ /* set up error handler */
+ if (setjmp(mpl->jump)) goto done;
+ /* perform postsolving */
+ postsolve_model(mpl);
+ flush_output(mpl);
+ /* postsolving phase has been finished */
+ xprintf("Model has been successfully processed\n");
+done: /* return to the calling program */
+ return mpl->phase;
+}
+
+/*----------------------------------------------------------------------
+-- mpl_terminate - free all resources used by translator.
+--
+-- *Synopsis*
+--
+-- #include "glpmpl.h"
+-- void mpl_terminate(MPL *mpl);
+--
+-- *Description*
+--
+-- The routine mpl_terminate frees all the resources used by the GNU
+-- MathProg translator. */
+
+void mpl_terminate(MPL *mpl)
+{ if (setjmp(mpl->jump)) xassert(mpl != mpl);
+ switch (mpl->phase)
+ { case 0:
+ case 1:
+ case 2:
+ case 3:
+ /* there were no errors; clean the model content */
+ clean_model(mpl);
+ xassert(mpl->a_list == NULL);
+#if 1 /* 11/II-2008 */
+ xassert(mpl->dca == NULL);
+#endif
+ break;
+ case 4:
+ /* model processing has been finished due to error; delete
+ search trees, which may be created for some arrays */
+ { ARRAY *a;
+ for (a = mpl->a_list; a != NULL; a = a->next)
+ if (a->tree != NULL) avl_delete_tree(a->tree);
+ }
+#if 1 /* 11/II-2008 */
+ free_dca(mpl);
+#endif
+ break;
+ default:
+ xassert(mpl != mpl);
+ }
+ /* delete the translator database */
+ xfree(mpl->image);
+ xfree(mpl->b_image);
+ xfree(mpl->f_image);
+ xfree(mpl->context);
+ dmp_delete_pool(mpl->pool);
+ avl_delete_tree(mpl->tree);
+ dmp_delete_pool(mpl->strings);
+ dmp_delete_pool(mpl->symbols);
+ dmp_delete_pool(mpl->tuples);
+ dmp_delete_pool(mpl->arrays);
+ dmp_delete_pool(mpl->members);
+ dmp_delete_pool(mpl->elemvars);
+ dmp_delete_pool(mpl->formulae);
+ dmp_delete_pool(mpl->elemcons);
+ xfree(mpl->sym_buf);
+ xfree(mpl->tup_buf);
+ rng_delete_rand(mpl->rand);
+ if (mpl->row != NULL) xfree(mpl->row);
+ if (mpl->col != NULL) xfree(mpl->col);
+ if (mpl->in_fp != NULL) glp_close(mpl->in_fp);
+ if (mpl->out_fp != NULL && mpl->out_fp != (void *)stdout)
+ glp_close(mpl->out_fp);
+ if (mpl->out_file != NULL) xfree(mpl->out_file);
+ if (mpl->prt_fp != NULL) glp_close(mpl->prt_fp);
+ if (mpl->prt_file != NULL) xfree(mpl->prt_file);
+ if (mpl->mod_file != NULL) xfree(mpl->mod_file);
+ xfree(mpl->mpl_buf);
+ xfree(mpl);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl5.c b/test/monniaux/glpk-4.65/src/mpl/mpl5.c
new file mode 100644
index 00000000..c5374c9c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl5.c
@@ -0,0 +1,566 @@
+/* mpl5.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Authors: Andrew Makhorin <mao@gnu.org>
+* Heinrich Schuchardt <xypron.glpk@gmx.de>
+*
+* Copyright (C) 2003-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#if 1 /* 11/VI-2013 */
+#include "jd.h"
+#endif
+#include "mpl.h"
+
+double fn_gmtime(MPL *mpl)
+{ /* obtain the current calendar time (UTC) */
+ time_t timer;
+ struct tm *tm;
+ int j;
+ time(&timer);
+ if (timer == (time_t)(-1))
+err: error(mpl, "gmtime(); unable to obtain current calendar time");
+#if 0 /* 29/I-2017 */
+ tm = gmtime(&timer);
+#else
+ tm = xgmtime(&timer);
+#endif
+ if (tm == NULL) goto err;
+ j = jday(tm->tm_mday, tm->tm_mon + 1, 1900 + tm->tm_year);
+ if (j < 0) goto err;
+ return (((double)(j - jday(1, 1, 1970)) * 24.0 +
+ (double)tm->tm_hour) * 60.0 + (double)tm->tm_min) * 60.0 +
+ (double)tm->tm_sec;
+}
+
+static char *week[] = { "Monday", "Tuesday", "Wednesday", "Thursday",
+ "Friday", "Saturday", "Sunday" };
+
+static char *moon[] = { "January", "February", "March", "April", "May",
+ "June", "July", "August", "September", "October", "November",
+ "December" };
+
+static void error1(MPL *mpl, const char *str, const char *s,
+ const char *fmt, const char *f, const char *msg)
+{ xprintf("Input string passed to str2time:\n");
+ xprintf("%s\n", str);
+ xprintf("%*s\n", (s - str) + 1, "^");
+ xprintf("Format string passed to str2time:\n");
+ xprintf("%s\n", fmt);
+ xprintf("%*s\n", (f - fmt) + 1, "^");
+ error(mpl, "%s", msg);
+ /* no return */
+}
+
+double fn_str2time(MPL *mpl, const char *str, const char *fmt)
+{ /* convert character string to the calendar time */
+ int j, year, month, day, hh, mm, ss, zone;
+ const char *s, *f;
+ year = month = day = hh = mm = ss = -1, zone = INT_MAX;
+ s = str;
+ for (f = fmt; *f != '\0'; f++)
+ { if (*f == '%')
+ { f++;
+ if (*f == 'b' || *f == 'h')
+ { /* the abbreviated month name */
+ int k;
+ char *name;
+ if (month >= 0)
+ error1(mpl, str, s, fmt, f, "month multiply specified"
+ );
+ while (*s == ' ') s++;
+ for (month = 1; month <= 12; month++)
+ { name = moon[month-1];
+ for (k = 0; k <= 2; k++)
+ { if (toupper((unsigned char)s[k]) !=
+ toupper((unsigned char)name[k])) goto next;
+ }
+ s += 3;
+ for (k = 3; name[k] != '\0'; k++)
+ { if (toupper((unsigned char)*s) !=
+ toupper((unsigned char)name[k])) break;
+ s++;
+ }
+ break;
+next: ;
+ }
+ if (month > 12)
+ error1(mpl, str, s, fmt, f, "abbreviated month name m"
+ "issing or invalid");
+ }
+ else if (*f == 'd')
+ { /* the day of the month as a decimal number (01..31) */
+ if (day >= 0)
+ error1(mpl, str, s, fmt, f, "day multiply specified");
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "day missing or invalid");
+ day = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ day = 10 * day + ((*s++) - '0');
+ if (!(1 <= day && day <= 31))
+ error1(mpl, str, s, fmt, f, "day out of range");
+ }
+ else if (*f == 'H')
+ { /* the hour as a decimal number, using a 24-hour clock
+ (00..23) */
+ if (hh >= 0)
+ error1(mpl, str, s, fmt, f, "hour multiply specified")
+ ;
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "hour missing or invalid")
+ ;
+ hh = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ hh = 10 * hh + ((*s++) - '0');
+ if (!(0 <= hh && hh <= 23))
+ error1(mpl, str, s, fmt, f, "hour out of range");
+ }
+ else if (*f == 'm')
+ { /* the month as a decimal number (01..12) */
+ if (month >= 0)
+ error1(mpl, str, s, fmt, f, "month multiply specified"
+ );
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "month missing or invalid"
+ );
+ month = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ month = 10 * month + ((*s++) - '0');
+ if (!(1 <= month && month <= 12))
+ error1(mpl, str, s, fmt, f, "month out of range");
+ }
+ else if (*f == 'M')
+ { /* the minute as a decimal number (00..59) */
+ if (mm >= 0)
+ error1(mpl, str, s, fmt, f, "minute multiply specifie"
+ "d");
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "minute missing or invali"
+ "d");
+ mm = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ mm = 10 * mm + ((*s++) - '0');
+ if (!(0 <= mm && mm <= 59))
+ error1(mpl, str, s, fmt, f, "minute out of range");
+ }
+ else if (*f == 'S')
+ { /* the second as a decimal number (00..60) */
+ if (ss >= 0)
+ error1(mpl, str, s, fmt, f, "second multiply specifie"
+ "d");
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "second missing or invali"
+ "d");
+ ss = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ ss = 10 * ss + ((*s++) - '0');
+ if (!(0 <= ss && ss <= 60))
+ error1(mpl, str, s, fmt, f, "second out of range");
+ }
+ else if (*f == 'y')
+ { /* the year without a century as a decimal number
+ (00..99); the values 00 to 68 mean the years 2000 to
+ 2068 while the values 69 to 99 mean the years 1969 to
+ 1999 */
+ if (year >= 0)
+ error1(mpl, str, s, fmt, f, "year multiply specified")
+ ;
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "year missing or invalid")
+ ;
+ year = (*s++) - '0';
+ if ('0' <= *s && *s <= '9')
+ year = 10 * year + ((*s++) - '0');
+ year += (year >= 69 ? 1900 : 2000);
+ }
+ else if (*f == 'Y')
+ { /* the year as a decimal number, using the Gregorian
+ calendar */
+ if (year >= 0)
+ error1(mpl, str, s, fmt, f, "year multiply specified")
+ ;
+ while (*s == ' ') s++;
+ if (!('0' <= *s && *s <= '9'))
+ error1(mpl, str, s, fmt, f, "year missing or invalid")
+ ;
+ year = 0;
+ for (j = 1; j <= 4; j++)
+ { if (!('0' <= *s && *s <= '9')) break;
+ year = 10 * year + ((*s++) - '0');
+ }
+ if (!(1 <= year && year <= 4000))
+ error1(mpl, str, s, fmt, f, "year out of range");
+ }
+ else if (*f == 'z')
+ { /* time zone offset in the form zhhmm */
+ int z, hh, mm;
+ if (zone != INT_MAX)
+ error1(mpl, str, s, fmt, f, "time zone offset multipl"
+ "y specified");
+ while (*s == ' ') s++;
+ if (*s == 'Z')
+ { z = hh = mm = 0, s++;
+ goto skip;
+ }
+ if (*s == '+')
+ z = +1, s++;
+ else if (*s == '-')
+ z = -1, s++;
+ else
+ error1(mpl, str, s, fmt, f, "time zone offset sign mi"
+ "ssing");
+ hh = 0;
+ for (j = 1; j <= 2; j++)
+ { if (!('0' <= *s && *s <= '9'))
+err1: error1(mpl, str, s, fmt, f, "time zone offset valu"
+ "e incomplete or invalid");
+ hh = 10 * hh + ((*s++) - '0');
+ }
+ if (hh > 23)
+err2: error1(mpl, str, s, fmt, f, "time zone offset value o"
+ "ut of range");
+ if (*s == ':')
+ { s++;
+ if (!('0' <= *s && *s <= '9')) goto err1;
+ }
+ mm = 0;
+ if (!('0' <= *s && *s <= '9')) goto skip;
+ for (j = 1; j <= 2; j++)
+ { if (!('0' <= *s && *s <= '9')) goto err1;
+ mm = 10 * mm + ((*s++) - '0');
+ }
+ if (mm > 59) goto err2;
+skip: zone = z * (60 * hh + mm);
+ }
+ else if (*f == '%')
+ { /* literal % character */
+ goto test;
+ }
+ else
+ error1(mpl, str, s, fmt, f, "invalid conversion specifie"
+ "r");
+ }
+ else if (*f == ' ')
+ ;
+ else
+test: { /* check a matching character in the input string */
+ if (*s != *f)
+ error1(mpl, str, s, fmt, f, "character mismatch");
+ s++;
+ }
+ }
+ if (year < 0) year = 1970;
+ if (month < 0) month = 1;
+ if (day < 0) day = 1;
+ if (hh < 0) hh = 0;
+ if (mm < 0) mm = 0;
+ if (ss < 0) ss = 0;
+ if (zone == INT_MAX) zone = 0;
+ j = jday(day, month, year);
+ xassert(j >= 0);
+ return (((double)(j - jday(1, 1, 1970)) * 24.0 + (double)hh) *
+ 60.0 + (double)mm) * 60.0 + (double)ss - 60.0 * (double)zone;
+}
+
+static void error2(MPL *mpl, const char *fmt, const char *f,
+ const char *msg)
+{ xprintf("Format string passed to time2str:\n");
+ xprintf("%s\n", fmt);
+ xprintf("%*s\n", (f - fmt) + 1, "^");
+ error(mpl, "%s", msg);
+ /* no return */
+}
+
+static int weekday(int j)
+{ /* determine weekday number (1 = Mon, ..., 7 = Sun) */
+ return (j + jday(1, 1, 1970)) % 7 + 1;
+}
+
+static int firstday(int year)
+{ /* determine the first day of the first week for a specified year
+ according to ISO 8601 */
+ int j;
+ /* if 1 January is Monday, Tuesday, Wednesday or Thursday, it is
+ in week 01; if 1 January is Friday, Saturday or Sunday, it is
+ in week 52 or 53 of the previous year */
+ j = jday(1, 1, year) - jday(1, 1, 1970);
+ switch (weekday(j))
+ { case 1: /* 1 Jan is Mon */ j += 0; break;
+ case 2: /* 1 Jan is Tue */ j -= 1; break;
+ case 3: /* 1 Jan is Wed */ j -= 2; break;
+ case 4: /* 1 Jan is Thu */ j -= 3; break;
+ case 5: /* 1 Jan is Fri */ j += 3; break;
+ case 6: /* 1 Jan is Sat */ j += 2; break;
+ case 7: /* 1 Jan is Sun */ j += 1; break;
+ default: xassert(j != j);
+ }
+ /* the first day of the week must be Monday */
+ xassert(weekday(j) == 1);
+ return j;
+}
+
+void fn_time2str(MPL *mpl, char *str, double t, const char *fmt)
+{ /* convert the calendar time to character string */
+ int j, year, month, day, hh, mm, ss, len;
+ double temp;
+ const char *f;
+ char buf[MAX_LENGTH+1];
+ if (!(-62135596800.0 <= t && t <= 64092211199.0))
+ error(mpl, "time2str(%.*g,...); argument out of range",
+ DBL_DIG, t);
+ t = floor(t + 0.5);
+ temp = fabs(t) / 86400.0;
+ j = (int)floor(temp);
+ if (t < 0.0)
+ { if (temp == floor(temp))
+ j = - j;
+ else
+ j = - (j + 1);
+ }
+ xassert(jdate(j + jday(1, 1, 1970), &day, &month, &year) == 0);
+ ss = (int)(t - 86400.0 * (double)j);
+ xassert(0 <= ss && ss < 86400);
+ mm = ss / 60, ss %= 60;
+ hh = mm / 60, mm %= 60;
+ len = 0;
+ for (f = fmt; *f != '\0'; f++)
+ { if (*f == '%')
+ { f++;
+ if (*f == 'a')
+ { /* the abbreviated weekday name */
+ memcpy(buf, week[weekday(j)-1], 3), buf[3] = '\0';
+ }
+ else if (*f == 'A')
+ { /* the full weekday name */
+ strcpy(buf, week[weekday(j)-1]);
+ }
+ else if (*f == 'b' || *f == 'h')
+ { /* the abbreviated month name */
+ memcpy(buf, moon[month-1], 3), buf[3] = '\0';
+ }
+ else if (*f == 'B')
+ { /* the full month name */
+ strcpy(buf, moon[month-1]);
+ }
+ else if (*f == 'C')
+ { /* the century of the year */
+ sprintf(buf, "%02d", year / 100);
+ }
+ else if (*f == 'd')
+ { /* the day of the month as a decimal number (01..31) */
+ sprintf(buf, "%02d", day);
+ }
+ else if (*f == 'D')
+ { /* the date using the format %m/%d/%y */
+ sprintf(buf, "%02d/%02d/%02d", month, day, year % 100);
+ }
+ else if (*f == 'e')
+ { /* the day of the month like with %d, but padded with
+ blank (1..31) */
+ sprintf(buf, "%2d", day);
+ }
+ else if (*f == 'F')
+ { /* the date using the format %Y-%m-%d */
+ sprintf(buf, "%04d-%02d-%02d", year, month, day);
+ }
+ else if (*f == 'g')
+ { /* the year corresponding to the ISO week number, but
+ without the century (range 00 through 99); this has
+ the same format and value as %y, except that if the
+ ISO week number (see %V) belongs to the previous or
+ next year, that year is used instead */
+ int iso;
+ if (j < firstday(year))
+ iso = year - 1;
+ else if (j < firstday(year + 1))
+ iso = year;
+ else
+ iso = year + 1;
+ sprintf(buf, "%02d", iso % 100);
+ }
+ else if (*f == 'G')
+ { /* the year corresponding to the ISO week number; this
+ has the same format and value as %Y, excepth that if
+ the ISO week number (see %V) belongs to the previous
+ or next year, that year is used instead */
+ int iso;
+ if (j < firstday(year))
+ iso = year - 1;
+ else if (j < firstday(year + 1))
+ iso = year;
+ else
+ iso = year + 1;
+ sprintf(buf, "%04d", iso);
+ }
+ else if (*f == 'H')
+ { /* the hour as a decimal number, using a 24-hour clock
+ (00..23) */
+ sprintf(buf, "%02d", hh);
+ }
+ else if (*f == 'I')
+ { /* the hour as a decimal number, using a 12-hour clock
+ (01..12) */
+ sprintf(buf, "%02d",
+ hh == 0 ? 12 : hh <= 12 ? hh : hh - 12);
+ }
+ else if (*f == 'j')
+ { /* the day of the year as a decimal number (001..366) */
+ sprintf(buf, "%03d",
+ jday(day, month, year) - jday(1, 1, year) + 1);
+ }
+ else if (*f == 'k')
+ { /* the hour as a decimal number, using a 24-hour clock
+ like %H, but padded with blank (0..23) */
+ sprintf(buf, "%2d", hh);
+ }
+ else if (*f == 'l')
+ { /* the hour as a decimal number, using a 12-hour clock
+ like %I, but padded with blank (1..12) */
+ sprintf(buf, "%2d",
+ hh == 0 ? 12 : hh <= 12 ? hh : hh - 12);
+ }
+ else if (*f == 'm')
+ { /* the month as a decimal number (01..12) */
+ sprintf(buf, "%02d", month);
+ }
+ else if (*f == 'M')
+ { /* the minute as a decimal number (00..59) */
+ sprintf(buf, "%02d", mm);
+ }
+ else if (*f == 'p')
+ { /* either AM or PM, according to the given time value;
+ noon is treated as PM and midnight as AM */
+ strcpy(buf, hh <= 11 ? "AM" : "PM");
+ }
+ else if (*f == 'P')
+ { /* either am or pm, according to the given time value;
+ noon is treated as pm and midnight as am */
+ strcpy(buf, hh <= 11 ? "am" : "pm");
+ }
+ else if (*f == 'r')
+ { /* the calendar time using the format %I:%M:%S %p */
+ sprintf(buf, "%02d:%02d:%02d %s",
+ hh == 0 ? 12 : hh <= 12 ? hh : hh - 12,
+ mm, ss, hh <= 11 ? "AM" : "PM");
+ }
+ else if (*f == 'R')
+ { /* the hour and minute using the format %H:%M */
+ sprintf(buf, "%02d:%02d", hh, mm);
+ }
+ else if (*f == 'S')
+ { /* the second as a decimal number (00..59) */
+ sprintf(buf, "%02d", ss);
+ }
+ else if (*f == 'T')
+ { /* the time of day using the format %H:%M:%S */
+ sprintf(buf, "%02d:%02d:%02d", hh, mm, ss);
+ }
+ else if (*f == 'u')
+ { /* the day of the week as a decimal number (1..7),
+ Monday being 1 */
+ sprintf(buf, "%d", weekday(j));
+ }
+ else if (*f == 'U')
+ { /* the week number of the current year as a decimal
+ number (range 00 through 53), starting with the first
+ Sunday as the first day of the first week; days
+ preceding the first Sunday in the year are considered
+ to be in week 00 */
+#if 1 /* 09/I-2009 */
+#undef sun
+/* causes compilation error in SunOS */
+#endif
+ int sun;
+ /* sun = the first Sunday of the year */
+ sun = jday(1, 1, year) - jday(1, 1, 1970);
+ sun += (7 - weekday(sun));
+ sprintf(buf, "%02d", (j + 7 - sun) / 7);
+ }
+ else if (*f == 'V')
+ { /* the ISO week number as a decimal number (range 01
+ through 53); ISO weeks start with Monday and end with
+ Sunday; week 01 of a year is the first week which has
+ the majority of its days in that year; week 01 of
+ a year can contain days from the previous year; the
+ week before week 01 of a year is the last week (52 or
+ 53) of the previous year even if it contains days
+ from the new year */
+ int iso;
+ if (j < firstday(year))
+ iso = j - firstday(year - 1);
+ else if (j < firstday(year + 1))
+ iso = j - firstday(year);
+ else
+ iso = j - firstday(year + 1);
+ sprintf(buf, "%02d", iso / 7 + 1);
+ }
+ else if (*f == 'w')
+ { /* the day of the week as a decimal number (0..6),
+ Sunday being 0 */
+ sprintf(buf, "%d", weekday(j) % 7);
+ }
+ else if (*f == 'W')
+ { /* the week number of the current year as a decimal
+ number (range 00 through 53), starting with the first
+ Monday as the first day of the first week; days
+ preceding the first Monday in the year are considered
+ to be in week 00 */
+ int mon;
+ /* mon = the first Monday of the year */
+ mon = jday(1, 1, year) - jday(1, 1, 1970);
+ mon += (8 - weekday(mon)) % 7;
+ sprintf(buf, "%02d", (j + 7 - mon) / 7);
+ }
+ else if (*f == 'y')
+ { /* the year without a century as a decimal number
+ (00..99) */
+ sprintf(buf, "%02d", year % 100);
+ }
+ else if (*f == 'Y')
+ { /* the year as a decimal number, using the Gregorian
+ calendar */
+ sprintf(buf, "%04d", year);
+ }
+ else if (*f == '%')
+ { /* a literal % character */
+ buf[0] = '%', buf[1] = '\0';
+ }
+ else
+ error2(mpl, fmt, f, "invalid conversion specifier");
+ }
+ else
+ buf[0] = *f, buf[1] = '\0';
+ if (len + strlen(buf) > MAX_LENGTH)
+ error(mpl, "time2str; output string length exceeds %d chara"
+ "cters", MAX_LENGTH);
+ memcpy(str+len, buf, strlen(buf));
+ len += strlen(buf);
+ }
+ str[len] = '\0';
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mpl6.c b/test/monniaux/glpk-4.65/src/mpl/mpl6.c
new file mode 100644
index 00000000..ac2a0393
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mpl6.c
@@ -0,0 +1,1039 @@
+/* mpl6.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2003-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "mpl.h"
+#include "mplsql.h"
+
+/**********************************************************************/
+
+#define CSV_FIELD_MAX 50
+/* maximal number of fields in record */
+
+#define CSV_FDLEN_MAX 100
+/* maximal field length */
+
+struct csv
+{ /* comma-separated values file */
+ int mode;
+ /* 'R' = reading; 'W' = writing */
+ char *fname;
+ /* name of csv file */
+ FILE *fp;
+ /* stream assigned to csv file */
+ jmp_buf jump;
+ /* address for non-local go to in case of error */
+ int count;
+ /* record count */
+ /*--------------------------------------------------------------*/
+ /* used only for input csv file */
+ int c;
+ /* current character or EOF */
+ int what;
+ /* current marker: */
+#define CSV_EOF 0 /* end-of-file */
+#define CSV_EOR 1 /* end-of-record */
+#define CSV_NUM 2 /* floating-point number */
+#define CSV_STR 3 /* character string */
+ char field[CSV_FDLEN_MAX+1];
+ /* current field just read */
+ int nf;
+ /* number of fields in the csv file */
+ int ref[1+CSV_FIELD_MAX];
+ /* ref[k] = k', if k-th field of the csv file corresponds to
+ k'-th field in the table statement; if ref[k] = 0, k-th field
+ of the csv file is ignored */
+#if 1 /* 01/VI-2010 */
+ int nskip;
+ /* number of comment records preceding the header record */
+#endif
+};
+
+#undef read_char
+
+static void read_char(struct csv *csv)
+{ /* read character from csv data file */
+ int c;
+ xassert(csv->c != EOF);
+ if (csv->c == '\n') csv->count++;
+loop: c = fgetc(csv->fp);
+ if (ferror(csv->fp))
+ { xprintf("%s:%d: read error - %s\n", csv->fname, csv->count,
+#if 0 /* 29/I-2017 */
+ strerror(errno));
+#else
+ xstrerr(errno));
+#endif
+ longjmp(csv->jump, 0);
+ }
+ if (feof(csv->fp))
+ { if (csv->c == '\n')
+ { csv->count--;
+ c = EOF;
+ }
+ else
+ { xprintf("%s:%d: warning: missing final end-of-line\n",
+ csv->fname, csv->count);
+ c = '\n';
+ }
+ }
+ else if (c == '\r')
+ goto loop;
+ else if (c == '\n')
+ ;
+ else if (iscntrl(c))
+ { xprintf("%s:%d: invalid control character 0x%02X\n",
+ csv->fname, csv->count, c);
+ longjmp(csv->jump, 0);
+ }
+ csv->c = c;
+ return;
+}
+
+static void read_field(struct csv *csv)
+{ /* read field from csv data file */
+ /* check for end of file */
+ if (csv->c == EOF)
+ { csv->what = CSV_EOF;
+ strcpy(csv->field, "EOF");
+ goto done;
+ }
+ /* check for end of record */
+ if (csv->c == '\n')
+ { csv->what = CSV_EOR;
+ strcpy(csv->field, "EOR");
+ read_char(csv);
+ if (csv->c == ',')
+err1: { xprintf("%s:%d: empty field not allowed\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+ if (csv->c == '\n')
+ { xprintf("%s:%d: empty record not allowed\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+#if 1 /* 01/VI-2010 */
+ /* skip comment records; may appear only before the very first
+ record containing field names */
+ if (csv->c == '#' && csv->count == 1)
+ { while (csv->c == '#')
+ { while (csv->c != '\n')
+ read_char(csv);
+ read_char(csv);
+ csv->nskip++;
+ }
+ }
+#endif
+ goto done;
+ }
+ /* skip comma before next field */
+ if (csv->c == ',')
+ read_char(csv);
+ /* read field */
+ if (csv->c == '\'' || csv->c == '"')
+ { /* read a field enclosed in quotes */
+ int quote = csv->c, len = 0;
+ csv->what = CSV_STR;
+ /* skip opening quote */
+ read_char(csv);
+ /* read field characters within quotes */
+ for (;;)
+ { /* check for closing quote and read it */
+ if (csv->c == quote)
+ { read_char(csv);
+ if (csv->c == quote)
+ ;
+ else if (csv->c == ',' || csv->c == '\n')
+ break;
+ else
+ { xprintf("%s:%d: invalid field\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+ }
+ /* check the current field length */
+ if (len == CSV_FDLEN_MAX)
+err2: { xprintf("%s:%d: field too long\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+ /* add the current character to the field */
+ csv->field[len++] = (char)csv->c;
+ /* read the next character */
+ read_char(csv);
+ }
+ /* the field has been read */
+ if (len == 0) goto err1;
+ csv->field[len] = '\0';
+ }
+ else
+ { /* read a field not enclosed in quotes */
+ int len = 0;
+ double temp;
+ csv->what = CSV_NUM;
+ while (!(csv->c == ',' || csv->c == '\n'))
+ { /* quotes within the field are not allowed */
+ if (csv->c == '\'' || csv->c == '"')
+ { xprintf("%s:%d: invalid use of single or double quote wi"
+ "thin field\n", csv->fname, csv->count);
+ longjmp(csv->jump, 0);
+ }
+ /* check the current field length */
+ if (len == CSV_FDLEN_MAX) goto err2;
+ /* add the current character to the field */
+ csv->field[len++] = (char)csv->c;
+ /* read the next character */
+ read_char(csv);
+ }
+ /* the field has been read */
+ if (len == 0) goto err1;
+ csv->field[len] = '\0';
+ /* check the field type */
+ if (str2num(csv->field, &temp)) csv->what = CSV_STR;
+ }
+done: return;
+}
+
+static struct csv *csv_open_file(TABDCA *dca, int mode)
+{ /* open csv data file */
+ struct csv *csv;
+ /* create control structure */
+ csv = xmalloc(sizeof(struct csv));
+ csv->mode = mode;
+ csv->fname = NULL;
+ csv->fp = NULL;
+ if (setjmp(csv->jump)) goto fail;
+ csv->count = 0;
+ csv->c = '\n';
+ csv->what = 0;
+ csv->field[0] = '\0';
+ csv->nf = 0;
+ /* try to open the csv data file */
+ if (mpl_tab_num_args(dca) < 2)
+ { xprintf("csv_driver: file name not specified\n");
+ longjmp(csv->jump, 0);
+ }
+ csv->fname = xmalloc(strlen(mpl_tab_get_arg(dca, 2))+1);
+ strcpy(csv->fname, mpl_tab_get_arg(dca, 2));
+ if (mode == 'R')
+ { /* open the file for reading */
+ int k;
+ csv->fp = fopen(csv->fname, "r");
+ if (csv->fp == NULL)
+ { xprintf("csv_driver: unable to open %s - %s\n",
+#if 0 /* 29/I-2017 */
+ csv->fname, strerror(errno));
+#else
+ csv->fname, xstrerr(errno));
+#endif
+ longjmp(csv->jump, 0);
+ }
+#if 1 /* 01/VI-2010 */
+ csv->nskip = 0;
+#endif
+ /* skip fake new-line */
+ read_field(csv);
+ xassert(csv->what == CSV_EOR);
+ /* read field names */
+ xassert(csv->nf == 0);
+ for (;;)
+ { read_field(csv);
+ if (csv->what == CSV_EOR)
+ break;
+ if (csv->what != CSV_STR)
+ { xprintf("%s:%d: invalid field name\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+ if (csv->nf == CSV_FIELD_MAX)
+ { xprintf("%s:%d: too many fields\n", csv->fname,
+ csv->count);
+ longjmp(csv->jump, 0);
+ }
+ csv->nf++;
+ /* find corresponding field in the table statement */
+ for (k = mpl_tab_num_flds(dca); k >= 1; k--)
+ { if (strcmp(mpl_tab_get_name(dca, k), csv->field) == 0)
+ break;
+ }
+ csv->ref[csv->nf] = k;
+ }
+ /* find dummy RECNO field in the table statement */
+ for (k = mpl_tab_num_flds(dca); k >= 1; k--)
+ if (strcmp(mpl_tab_get_name(dca, k), "RECNO") == 0) break;
+ csv->ref[0] = k;
+ }
+ else if (mode == 'W')
+ { /* open the file for writing */
+ int k, nf;
+ csv->fp = fopen(csv->fname, "w");
+ if (csv->fp == NULL)
+ { xprintf("csv_driver: unable to create %s - %s\n",
+#if 0 /* 29/I-2017 */
+ csv->fname, strerror(errno));
+#else
+ csv->fname, xstrerr(errno));
+#endif
+ longjmp(csv->jump, 0);
+ }
+ /* write field names */
+ nf = mpl_tab_num_flds(dca);
+ for (k = 1; k <= nf; k++)
+ fprintf(csv->fp, "%s%c", mpl_tab_get_name(dca, k),
+ k < nf ? ',' : '\n');
+ csv->count++;
+ }
+ else
+ xassert(mode != mode);
+ /* the file has been open */
+ return csv;
+fail: /* the file cannot be open */
+ if (csv->fname != NULL) xfree(csv->fname);
+ if (csv->fp != NULL) fclose(csv->fp);
+ xfree(csv);
+ return NULL;
+}
+
+static int csv_read_record(TABDCA *dca, struct csv *csv)
+{ /* read next record from csv data file */
+ int k, ret = 0;
+ xassert(csv->mode == 'R');
+ if (setjmp(csv->jump))
+ { ret = 1;
+ goto done;
+ }
+ /* read dummy RECNO field */
+ if (csv->ref[0] > 0)
+#if 0 /* 01/VI-2010 */
+ mpl_tab_set_num(dca, csv->ref[0], csv->count-1);
+#else
+ mpl_tab_set_num(dca, csv->ref[0], csv->count-csv->nskip-1);
+#endif
+ /* read fields */
+ for (k = 1; k <= csv->nf; k++)
+ { read_field(csv);
+ if (csv->what == CSV_EOF)
+ { /* end-of-file reached */
+ xassert(k == 1);
+ ret = -1;
+ goto done;
+ }
+ else if (csv->what == CSV_EOR)
+ { /* end-of-record reached */
+ int lack = csv->nf - k + 1;
+ if (lack == 1)
+ xprintf("%s:%d: one field missing\n", csv->fname,
+ csv->count);
+ else
+ xprintf("%s:%d: %d fields missing\n", csv->fname,
+ csv->count, lack);
+ longjmp(csv->jump, 0);
+ }
+ else if (csv->what == CSV_NUM)
+ { /* floating-point number */
+ if (csv->ref[k] > 0)
+ { double num;
+ xassert(str2num(csv->field, &num) == 0);
+ mpl_tab_set_num(dca, csv->ref[k], num);
+ }
+ }
+ else if (csv->what == CSV_STR)
+ { /* character string */
+ if (csv->ref[k] > 0)
+ mpl_tab_set_str(dca, csv->ref[k], csv->field);
+ }
+ else
+ xassert(csv != csv);
+ }
+ /* now there must be NL */
+ read_field(csv);
+ xassert(csv->what != CSV_EOF);
+ if (csv->what != CSV_EOR)
+ { xprintf("%s:%d: too many fields\n", csv->fname, csv->count);
+ longjmp(csv->jump, 0);
+ }
+done: return ret;
+}
+
+static int csv_write_record(TABDCA *dca, struct csv *csv)
+{ /* write next record to csv data file */
+ int k, nf, ret = 0;
+ const char *c;
+ xassert(csv->mode == 'W');
+ nf = mpl_tab_num_flds(dca);
+ for (k = 1; k <= nf; k++)
+ { switch (mpl_tab_get_type(dca, k))
+ { case 'N':
+ fprintf(csv->fp, "%.*g", DBL_DIG,
+ mpl_tab_get_num(dca, k));
+ break;
+ case 'S':
+ fputc('"', csv->fp);
+ for (c = mpl_tab_get_str(dca, k); *c != '\0'; c++)
+ { if (*c == '"')
+ fputc('"', csv->fp), fputc('"', csv->fp);
+ else
+ fputc(*c, csv->fp);
+ }
+ fputc('"', csv->fp);
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ fputc(k < nf ? ',' : '\n', csv->fp);
+ }
+ csv->count++;
+ if (ferror(csv->fp))
+ { xprintf("%s:%d: write error - %s\n", csv->fname, csv->count,
+#if 0 /* 29/I-2017 */
+ strerror(errno));
+#else
+ xstrerr(errno));
+#endif
+ ret = 1;
+ }
+ return ret;
+}
+
+static int csv_close_file(TABDCA *dca, struct csv *csv)
+{ /* close csv data file */
+ int ret = 0;
+ xassert(dca == dca);
+ if (csv->mode == 'W')
+ { fflush(csv->fp);
+ if (ferror(csv->fp))
+ { xprintf("%s:%d: write error - %s\n", csv->fname,
+#if 0 /* 29/I-2017 */
+ csv->count, strerror(errno));
+#else
+ csv->count, xstrerr(errno));
+#endif
+ ret = 1;
+ }
+ }
+ xfree(csv->fname);
+ fclose(csv->fp);
+ xfree(csv);
+ return ret;
+}
+
+/**********************************************************************/
+
+#define DBF_FIELD_MAX 50
+/* maximal number of fields in record */
+
+#define DBF_FDLEN_MAX 100
+/* maximal field length */
+
+struct dbf
+{ /* xBASE data file */
+ int mode;
+ /* 'R' = reading; 'W' = writing */
+ char *fname;
+ /* name of xBASE file */
+ FILE *fp;
+ /* stream assigned to xBASE file */
+ jmp_buf jump;
+ /* address for non-local go to in case of error */
+ int offset;
+ /* offset of a byte to be read next */
+ int count;
+ /* record count */
+ int nf;
+ /* number of fields */
+ int ref[1+DBF_FIELD_MAX];
+ /* ref[k] = k', if k-th field of the csv file corresponds to
+ k'-th field in the table statement; if ref[k] = 0, k-th field
+ of the csv file is ignored */
+ int type[1+DBF_FIELD_MAX];
+ /* type[k] is type of k-th field */
+ int len[1+DBF_FIELD_MAX];
+ /* len[k] is length of k-th field */
+ int prec[1+DBF_FIELD_MAX];
+ /* prec[k] is precision of k-th field */
+};
+
+static int read_byte(struct dbf *dbf)
+{ /* read byte from xBASE data file */
+ int b;
+ b = fgetc(dbf->fp);
+ if (ferror(dbf->fp))
+ { xprintf("%s:0x%X: read error - %s\n", dbf->fname,
+#if 0 /* 29/I-2017 */
+ dbf->offset, strerror(errno));
+#else
+ dbf->offset, xstrerr(errno));
+#endif
+ longjmp(dbf->jump, 0);
+ }
+ if (feof(dbf->fp))
+ { xprintf("%s:0x%X: unexpected end of file\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ xassert(0x00 <= b && b <= 0xFF);
+ dbf->offset++;
+ return b;
+}
+
+static void read_header(TABDCA *dca, struct dbf *dbf)
+{ /* read xBASE data file header */
+ int b, j, k, recl;
+ char name[10+1];
+ /* (ignored) */
+ for (j = 1; j <= 10; j++)
+ read_byte(dbf);
+ /* length of each record, in bytes */
+ recl = read_byte(dbf);
+ recl += read_byte(dbf) << 8;
+ /* (ignored) */
+ for (j = 1; j <= 20; j++)
+ read_byte(dbf);
+ /* field descriptor array */
+ xassert(dbf->nf == 0);
+ for (;;)
+ { /* check for end of array */
+ b = read_byte(dbf);
+ if (b == 0x0D) break;
+ if (dbf->nf == DBF_FIELD_MAX)
+ { xprintf("%s:0x%X: too many fields\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ dbf->nf++;
+ /* field name */
+ name[0] = (char)b;
+ for (j = 1; j < 10; j++)
+ { b = read_byte(dbf);
+ name[j] = (char)b;
+ }
+ name[10] = '\0';
+ b = read_byte(dbf);
+ if (b != 0x00)
+ { xprintf("%s:0x%X: invalid field name\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ /* find corresponding field in the table statement */
+ for (k = mpl_tab_num_flds(dca); k >= 1; k--)
+ if (strcmp(mpl_tab_get_name(dca, k), name) == 0) break;
+ dbf->ref[dbf->nf] = k;
+ /* field type */
+ b = read_byte(dbf);
+ if (!(b == 'C' || b == 'N'))
+ { xprintf("%s:0x%X: invalid field type\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ dbf->type[dbf->nf] = b;
+ /* (ignored) */
+ for (j = 1; j <= 4; j++)
+ read_byte(dbf);
+ /* field length */
+ b = read_byte(dbf);
+ if (b == 0)
+ { xprintf("%s:0x%X: invalid field length\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ if (b > DBF_FDLEN_MAX)
+ { xprintf("%s:0x%X: field too long\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ dbf->len[dbf->nf] = b;
+ recl -= b;
+ /* (ignored) */
+ for (j = 1; j <= 15; j++)
+ read_byte(dbf);
+ }
+ if (recl != 1)
+ { xprintf("%s:0x%X: invalid file header\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ /* find dummy RECNO field in the table statement */
+ for (k = mpl_tab_num_flds(dca); k >= 1; k--)
+ if (strcmp(mpl_tab_get_name(dca, k), "RECNO") == 0) break;
+ dbf->ref[0] = k;
+ return;
+}
+
+static void parse_third_arg(TABDCA *dca, struct dbf *dbf)
+{ /* parse xBASE file format (third argument) */
+ int j, k, temp;
+ const char *arg;
+ dbf->nf = mpl_tab_num_flds(dca);
+ arg = mpl_tab_get_arg(dca, 3), j = 0;
+ for (k = 1; k <= dbf->nf; k++)
+ { /* parse specification of k-th field */
+ if (arg[j] == '\0')
+ { xprintf("xBASE driver: field %s: specification missing\n",
+ mpl_tab_get_name(dca, k));
+ longjmp(dbf->jump, 0);
+ }
+ /* parse field type */
+ if (arg[j] == 'C' || arg[j] == 'N')
+ dbf->type[k] = arg[j], j++;
+ else
+ { xprintf("xBASE driver: field %s: invalid field type\n",
+ mpl_tab_get_name(dca, k));
+ longjmp(dbf->jump, 0);
+ }
+ /* check for left parenthesis */
+ if (arg[j] == '(')
+ j++;
+ else
+err: { xprintf("xBASE driver: field %s: invalid field format\n",
+ mpl_tab_get_name(dca, k));
+ longjmp(dbf->jump, 0);
+ }
+ /* parse field length */
+ temp = 0;
+ while (isdigit(arg[j]))
+ { if (temp > DBF_FDLEN_MAX) break;
+ temp = 10 * temp + (arg[j] - '0'), j++;
+ }
+ if (!(1 <= temp && temp <= DBF_FDLEN_MAX))
+ { xprintf("xBASE driver: field %s: invalid field length\n",
+ mpl_tab_get_name(dca, k));
+ longjmp(dbf->jump, 0);
+ }
+ dbf->len[k] = temp;
+ /* parse optional field precision */
+ if (dbf->type[k] == 'N' && arg[j] == ',')
+ { j++;
+ temp = 0;
+ while (isdigit(arg[j]))
+ { if (temp > dbf->len[k]) break;
+ temp = 10 * temp + (arg[j] - '0'), j++;
+ }
+ if (temp > dbf->len[k])
+ { xprintf("xBASE driver: field %s: invalid field precision"
+ "\n", mpl_tab_get_name(dca, k));
+ longjmp(dbf->jump, 0);
+ }
+ dbf->prec[k] = temp;
+ }
+ else
+ dbf->prec[k] = 0;
+ /* check for right parenthesis */
+ if (arg[j] == ')')
+ j++;
+ else
+ goto err;
+ }
+ /* ignore other specifications */
+ return;
+}
+
+static void write_byte(struct dbf *dbf, int b)
+{ /* write byte to xBASE data file */
+ fputc(b, dbf->fp);
+ dbf->offset++;
+ return;
+}
+
+static void write_header(TABDCA *dca, struct dbf *dbf)
+{ /* write xBASE data file header */
+ int j, k, temp;
+ const char *name;
+ /* version number */
+ write_byte(dbf, 0x03 /* file without DBT */);
+ /* date of last update (YYMMDD) */
+ write_byte(dbf, 70 /* 1970 */);
+ write_byte(dbf, 1 /* January */);
+ write_byte(dbf, 1 /* 1st */);
+ /* number of records (unknown so far) */
+ for (j = 1; j <= 4; j++)
+ write_byte(dbf, 0xFF);
+ /* length of the header, in bytes */
+ temp = 32 + dbf->nf * 32 + 1;
+ write_byte(dbf, temp);
+ write_byte(dbf, temp >> 8);
+ /* length of each record, in bytes */
+ temp = 1;
+ for (k = 1; k <= dbf->nf; k++)
+ temp += dbf->len[k];
+ write_byte(dbf, temp);
+ write_byte(dbf, temp >> 8);
+ /* (reserved) */
+ for (j = 1; j <= 20; j++)
+ write_byte(dbf, 0x00);
+ /* field descriptor array */
+ for (k = 1; k <= dbf->nf; k++)
+ { /* field name (terminated by 0x00) */
+ name = mpl_tab_get_name(dca, k);
+ for (j = 0; j < 10 && name[j] != '\0'; j++)
+ write_byte(dbf, name[j]);
+ for (j = j; j < 11; j++)
+ write_byte(dbf, 0x00);
+ /* field type */
+ write_byte(dbf, dbf->type[k]);
+ /* (reserved) */
+ for (j = 1; j <= 4; j++)
+ write_byte(dbf, 0x00);
+ /* field length */
+ write_byte(dbf, dbf->len[k]);
+ /* field precision */
+ write_byte(dbf, dbf->prec[k]);
+ /* (reserved) */
+ for (j = 1; j <= 14; j++)
+ write_byte(dbf, 0x00);
+ }
+ /* end of header */
+ write_byte(dbf, 0x0D);
+ return;
+}
+
+static struct dbf *dbf_open_file(TABDCA *dca, int mode)
+{ /* open xBASE data file */
+ struct dbf *dbf;
+ /* create control structure */
+ dbf = xmalloc(sizeof(struct dbf));
+ dbf->mode = mode;
+ dbf->fname = NULL;
+ dbf->fp = NULL;
+ if (setjmp(dbf->jump)) goto fail;
+ dbf->offset = 0;
+ dbf->count = 0;
+ dbf->nf = 0;
+ /* try to open the xBASE data file */
+ if (mpl_tab_num_args(dca) < 2)
+ { xprintf("xBASE driver: file name not specified\n");
+ longjmp(dbf->jump, 0);
+ }
+ dbf->fname = xmalloc(strlen(mpl_tab_get_arg(dca, 2))+1);
+ strcpy(dbf->fname, mpl_tab_get_arg(dca, 2));
+ if (mode == 'R')
+ { /* open the file for reading */
+ dbf->fp = fopen(dbf->fname, "rb");
+ if (dbf->fp == NULL)
+ { xprintf("xBASE driver: unable to open %s - %s\n",
+#if 0 /* 29/I-2017 */
+ dbf->fname, strerror(errno));
+#else
+ dbf->fname, xstrerr(errno));
+#endif
+ longjmp(dbf->jump, 0);
+ }
+ read_header(dca, dbf);
+ }
+ else if (mode == 'W')
+ { /* open the file for writing */
+ if (mpl_tab_num_args(dca) < 3)
+ { xprintf("xBASE driver: file format not specified\n");
+ longjmp(dbf->jump, 0);
+ }
+ parse_third_arg(dca, dbf);
+ dbf->fp = fopen(dbf->fname, "wb");
+ if (dbf->fp == NULL)
+ { xprintf("xBASE driver: unable to create %s - %s\n",
+#if 0 /* 29/I-2017 */
+ dbf->fname, strerror(errno));
+#else
+ dbf->fname, xstrerr(errno));
+#endif
+ longjmp(dbf->jump, 0);
+ }
+ write_header(dca, dbf);
+ }
+ else
+ xassert(mode != mode);
+ /* the file has been open */
+ return dbf;
+fail: /* the file cannot be open */
+ if (dbf->fname != NULL) xfree(dbf->fname);
+ if (dbf->fp != NULL) fclose(dbf->fp);
+ xfree(dbf);
+ return NULL;
+}
+
+static int dbf_read_record(TABDCA *dca, struct dbf *dbf)
+{ /* read next record from xBASE data file */
+ int b, j, k, ret = 0;
+ char buf[DBF_FDLEN_MAX+1];
+ xassert(dbf->mode == 'R');
+ if (setjmp(dbf->jump))
+ { ret = 1;
+ goto done;
+ }
+ /* check record flag */
+ b = read_byte(dbf);
+ if (b == 0x1A)
+ { /* end of data */
+ ret = -1;
+ goto done;
+ }
+ if (b != 0x20)
+ { xprintf("%s:0x%X: invalid record flag\n", dbf->fname,
+ dbf->offset);
+ longjmp(dbf->jump, 0);
+ }
+ /* read dummy RECNO field */
+ if (dbf->ref[0] > 0)
+ mpl_tab_set_num(dca, dbf->ref[0], dbf->count+1);
+ /* read fields */
+ for (k = 1; k <= dbf->nf; k++)
+ { /* read k-th field */
+ for (j = 0; j < dbf->len[k]; j++)
+ buf[j] = (char)read_byte(dbf);
+ buf[dbf->len[k]] = '\0';
+ /* set field value */
+ if (dbf->type[k] == 'C')
+ { /* character field */
+ if (dbf->ref[k] > 0)
+ mpl_tab_set_str(dca, dbf->ref[k], strtrim(buf));
+ }
+ else if (dbf->type[k] == 'N')
+ { /* numeric field */
+ if (dbf->ref[k] > 0)
+ { double num;
+ strspx(buf);
+ xassert(str2num(buf, &num) == 0);
+ mpl_tab_set_num(dca, dbf->ref[k], num);
+ }
+ }
+ else
+ xassert(dbf != dbf);
+ }
+ /* increase record count */
+ dbf->count++;
+done: return ret;
+}
+
+static int dbf_write_record(TABDCA *dca, struct dbf *dbf)
+{ /* write next record to xBASE data file */
+ int j, k, ret = 0;
+ char buf[255+1];
+ xassert(dbf->mode == 'W');
+ if (setjmp(dbf->jump))
+ { ret = 1;
+ goto done;
+ }
+ /* record flag */
+ write_byte(dbf, 0x20);
+ xassert(dbf->nf == mpl_tab_num_flds(dca));
+ for (k = 1; k <= dbf->nf; k++)
+ { if (dbf->type[k] == 'C')
+ { /* character field */
+ const char *str;
+ if (mpl_tab_get_type(dca, k) == 'N')
+ { sprintf(buf, "%.*g", DBL_DIG, mpl_tab_get_num(dca, k));
+ str = buf;
+ }
+ else if (mpl_tab_get_type(dca, k) == 'S')
+ str = mpl_tab_get_str(dca, k);
+ else
+ xassert(dca != dca);
+ if ((int)strlen(str) > dbf->len[k])
+ { xprintf("xBASE driver: field %s: cannot convert %.15s..."
+ " to field format\n", mpl_tab_get_name(dca, k), str);
+ longjmp(dbf->jump, 0);
+ }
+ for (j = 0; j < dbf->len[k] && str[j] != '\0'; j++)
+ write_byte(dbf, str[j]);
+ for (j = j; j < dbf->len[k]; j++)
+ write_byte(dbf, ' ');
+ }
+ else if (dbf->type[k] == 'N')
+ { /* numeric field */
+ double num = mpl_tab_get_num(dca, k);
+ if (fabs(num) > 1e20)
+err: { xprintf("xBASE driver: field %s: cannot convert %g to fi"
+ "eld format\n", mpl_tab_get_name(dca, k), num);
+ longjmp(dbf->jump, 0);
+ }
+ sprintf(buf, "%*.*f", dbf->len[k], dbf->prec[k], num);
+ xassert(strlen(buf) < sizeof(buf));
+ if ((int)strlen(buf) != dbf->len[k]) goto err;
+ for (j = 0; j < dbf->len[k]; j++)
+ write_byte(dbf, buf[j]);
+ }
+ else
+ xassert(dbf != dbf);
+ }
+ /* increase record count */
+ dbf->count++;
+done: return ret;
+}
+
+static int dbf_close_file(TABDCA *dca, struct dbf *dbf)
+{ /* close xBASE data file */
+ int ret = 0;
+ xassert(dca == dca);
+ if (dbf->mode == 'W')
+ { if (setjmp(dbf->jump))
+ { ret = 1;
+ goto skip;
+ }
+ /* end-of-file flag */
+ write_byte(dbf, 0x1A);
+ /* number of records */
+ dbf->offset = 4;
+ if (fseek(dbf->fp, dbf->offset, SEEK_SET))
+ { xprintf("%s:0x%X: seek error - %s\n", dbf->fname,
+#if 0 /* 29/I-2017 */
+ dbf->offset, strerror(errno));
+#else
+ dbf->offset, xstrerr(errno));
+#endif
+ longjmp(dbf->jump, 0);
+ }
+ write_byte(dbf, dbf->count);
+ write_byte(dbf, dbf->count >> 8);
+ write_byte(dbf, dbf->count >> 16);
+ write_byte(dbf, dbf->count >> 24);
+ fflush(dbf->fp);
+ if (ferror(dbf->fp))
+ { xprintf("%s:0x%X: write error - %s\n", dbf->fname,
+#if 0 /* 29/I-2017 */
+ dbf->offset, strerror(errno));
+#else
+ dbf->offset, xstrerr(errno));
+#endif
+ longjmp(dbf->jump, 0);
+ }
+skip: ;
+ }
+ xfree(dbf->fname);
+ fclose(dbf->fp);
+ xfree(dbf);
+ return ret;
+}
+
+/**********************************************************************/
+
+#define TAB_CSV 1
+#define TAB_XBASE 2
+#define TAB_ODBC 3
+#define TAB_MYSQL 4
+
+void mpl_tab_drv_open(MPL *mpl, int mode)
+{ TABDCA *dca = mpl->dca;
+ xassert(dca->id == 0);
+ xassert(dca->link == NULL);
+ xassert(dca->na >= 1);
+ if (strcmp(dca->arg[1], "CSV") == 0)
+ { dca->id = TAB_CSV;
+ dca->link = csv_open_file(dca, mode);
+ }
+ else if (strcmp(dca->arg[1], "xBASE") == 0)
+ { dca->id = TAB_XBASE;
+ dca->link = dbf_open_file(dca, mode);
+ }
+ else if (strcmp(dca->arg[1], "ODBC") == 0 ||
+ strcmp(dca->arg[1], "iODBC") == 0)
+ { dca->id = TAB_ODBC;
+ dca->link = db_iodbc_open(dca, mode);
+ }
+ else if (strcmp(dca->arg[1], "MySQL") == 0)
+ { dca->id = TAB_MYSQL;
+ dca->link = db_mysql_open(dca, mode);
+ }
+ else
+ xprintf("Invalid table driver '%s'\n", dca->arg[1]);
+ if (dca->link == NULL)
+ error(mpl, "error on opening table %s",
+ mpl->stmt->u.tab->name);
+ return;
+}
+
+int mpl_tab_drv_read(MPL *mpl)
+{ TABDCA *dca = mpl->dca;
+ int ret;
+ switch (dca->id)
+ { case TAB_CSV:
+ ret = csv_read_record(dca, dca->link);
+ break;
+ case TAB_XBASE:
+ ret = dbf_read_record(dca, dca->link);
+ break;
+ case TAB_ODBC:
+ ret = db_iodbc_read(dca, dca->link);
+ break;
+ case TAB_MYSQL:
+ ret = db_mysql_read(dca, dca->link);
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ if (ret > 0)
+ error(mpl, "error on reading data from table %s",
+ mpl->stmt->u.tab->name);
+ return ret;
+}
+
+void mpl_tab_drv_write(MPL *mpl)
+{ TABDCA *dca = mpl->dca;
+ int ret;
+ switch (dca->id)
+ { case TAB_CSV:
+ ret = csv_write_record(dca, dca->link);
+ break;
+ case TAB_XBASE:
+ ret = dbf_write_record(dca, dca->link);
+ break;
+ case TAB_ODBC:
+ ret = db_iodbc_write(dca, dca->link);
+ break;
+ case TAB_MYSQL:
+ ret = db_mysql_write(dca, dca->link);
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ if (ret)
+ error(mpl, "error on writing data to table %s",
+ mpl->stmt->u.tab->name);
+ return;
+}
+
+void mpl_tab_drv_close(MPL *mpl)
+{ TABDCA *dca = mpl->dca;
+ int ret;
+ switch (dca->id)
+ { case TAB_CSV:
+ ret = csv_close_file(dca, dca->link);
+ break;
+ case TAB_XBASE:
+ ret = dbf_close_file(dca, dca->link);
+ break;
+ case TAB_ODBC:
+ ret = db_iodbc_close(dca, dca->link);
+ break;
+ case TAB_MYSQL:
+ ret = db_mysql_close(dca, dca->link);
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ dca->id = 0;
+ dca->link = NULL;
+ if (ret)
+ error(mpl, "error on closing table %s",
+ mpl->stmt->u.tab->name);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mplsql.c b/test/monniaux/glpk-4.65/src/mpl/mplsql.c
new file mode 100644
index 00000000..fcd2afa6
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mplsql.c
@@ -0,0 +1,1659 @@
+/* mplsql.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Author: Heinrich Schuchardt <xypron.glpk@gmx.de>.
+*
+* Copyright (C) 2003-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "mpl.h"
+#include "mplsql.h"
+
+#ifdef ODBC_DLNAME
+#define HAVE_ODBC
+#define libodbc ODBC_DLNAME
+#define h_odbc (get_env_ptr()->h_odbc)
+#endif
+
+#ifdef MYSQL_DLNAME
+#define HAVE_MYSQL
+#define libmysql MYSQL_DLNAME
+#define h_mysql (get_env_ptr()->h_mysql)
+#endif
+
+static void *db_iodbc_open_int(TABDCA *dca, int mode, const char
+ **sqllines);
+static void *db_mysql_open_int(TABDCA *dca, int mode, const char
+ **sqllines);
+
+/**********************************************************************/
+
+#if defined(HAVE_ODBC) || defined(HAVE_MYSQL)
+
+#define SQL_FIELD_MAX 100
+/* maximal field count */
+
+#define SQL_FDLEN_MAX 255
+/* maximal field length */
+
+/***********************************************************************
+* NAME
+*
+* args_concat - concatenate arguments
+*
+* SYNOPSIS
+*
+* static char **args_concat(TABDCA *dca);
+*
+* DESCRIPTION
+*
+* The arguments passed in dca are SQL statements. A SQL statement may
+* be split over multiple arguments. The last argument of a SQL
+* statement will be terminated with a semilocon. Each SQL statement is
+* merged into a single zero terminated string. Boundaries between
+* arguments are replaced by space.
+*
+* RETURNS
+*
+* Buffer with SQL statements */
+
+static char **args_concat(TABDCA *dca)
+{
+ const char *arg;
+ int i;
+ int j;
+ int j0;
+ int j1;
+ size_t len;
+ int lentot;
+ int narg;
+ int nline = 0;
+ char **sqllines = NULL;
+
+ narg = mpl_tab_num_args(dca);
+ /* The SQL statements start with argument 3. */
+ if (narg < 3)
+ return NULL;
+ /* Count the SQL statements */
+ for (j = 3; j <= narg; j++)
+ {
+ arg = mpl_tab_get_arg(dca, j);
+ len = strlen(arg);
+ if (arg[len-1] == ';' || j == narg)
+ nline ++;
+ }
+ /* Allocate string buffer. */
+ sqllines = (char **) xmalloc((nline+1) * sizeof(char **));
+ /* Join arguments */
+ sqllines[0] = NULL;
+ j0 = 3;
+ i = 0;
+ lentot = 0;
+ for (j = 3; j <= narg; j++)
+ {
+ arg = mpl_tab_get_arg(dca, j);
+ len = strlen(arg);
+ /* add length of part */
+ lentot += len;
+ /* add length of space separating parts or 0x00 at end of SQL
+ statement */
+ lentot++;
+ if (arg[len-1] == ';' || j == narg)
+ { /* Join arguments for a single SQL statement */
+ sqllines[i] = xmalloc(lentot);
+ sqllines[i+1] = NULL;
+ sqllines[i][0] = 0x00;
+ for (j1 = j0; j1 <= j; j1++)
+ { if(j1>j0)
+ strcat(sqllines[i], " ");
+ strcat(sqllines[i], mpl_tab_get_arg(dca, j1));
+ }
+ len = strlen(sqllines[i]);
+ if (sqllines[i][len-1] == ';')
+ sqllines[i][len-1] = 0x00;
+ j0 = j+1;
+ i++;
+ lentot = 0;
+ }
+ }
+ return sqllines;
+}
+
+/***********************************************************************
+* NAME
+*
+* free_buffer - free multiline string buffer
+*
+* SYNOPSIS
+*
+* static void free_buffer(char **buf);
+*
+* DESCRIPTION
+*
+* buf is a list of strings terminated by NULL.
+* The memory for the strings and for the list is released. */
+
+static void free_buffer(char **buf)
+{ int i;
+
+ for(i = 0; buf[i] != NULL; i++)
+ xfree(buf[i]);
+ xfree(buf);
+}
+
+static int db_escaped_string_length(const char* from)
+/* length of escaped string */
+{
+ int count;
+ const char *pointer;
+
+ for (pointer = from, count = 0; *pointer != (char) '\0'; pointer++,
+ count++)
+ {
+ switch (*pointer)
+ {
+ case '\'':
+ count++;
+ break;
+ }
+ }
+
+ return count;
+}
+
+static void db_escape_string (char *to, const char *from)
+/* escape string*/
+{
+ const char *source = from;
+ char *target = to;
+ size_t remaining;
+
+ remaining = strlen(from);
+
+ if (to == NULL)
+ to = (char *) (from + remaining);
+
+ while (remaining > 0)
+ {
+ switch (*source)
+ {
+ case '\'':
+ *target = '\'';
+ target++;
+ *target = '\'';
+ break;
+
+ default:
+ *target = *source;
+ }
+ source++;
+ target++;
+ remaining--;
+ }
+
+ /* Write the terminating NUL character. */
+ *target = '\0';
+}
+
+static char *db_generate_select_stmt(TABDCA *dca)
+/* generate select statement */
+{
+ char *arg;
+ char const *field;
+ char *query;
+ int j;
+ int narg;
+ int nf;
+ int total;
+
+ total = 50;
+ nf = mpl_tab_num_flds(dca);
+ narg = mpl_tab_num_args(dca);
+ for (j=1; j <= nf && j <= SQL_FIELD_MAX; j++)
+ {
+ field = mpl_tab_get_name(dca, j);
+ total += strlen(field);
+ total += 2;
+ }
+ arg = (char *) mpl_tab_get_arg(dca, narg);
+ total += strlen(arg);
+ query = xmalloc( total * sizeof(char));
+ strcpy (query, "SELECT ");
+ for (j=1; j <= nf && j <= SQL_FIELD_MAX; j++)
+ {
+ field = mpl_tab_get_name(dca, j);
+ strcat(query, field);
+ if ( j < nf )
+ strcat(query, ", ");
+ }
+ strcat(query, " FROM ");
+ strcat(query, arg);
+ return query;
+}
+
+static char *db_generate_insert_stmt(TABDCA *dca)
+/* generate insert statement */
+{
+ char *arg;
+ char const *field;
+ char *query;
+ int j;
+ int narg;
+ int nf;
+ int total;
+
+ total = 50;
+ nf = mpl_tab_num_flds(dca);
+ narg = mpl_tab_num_args(dca);
+ for (j=1; j <= nf && j <= SQL_FIELD_MAX; j++)
+ {
+ field = mpl_tab_get_name(dca, j);
+ total += strlen(field);
+ total += 5;
+ }
+ arg = (char *) mpl_tab_get_arg(dca, narg);
+ total += strlen(arg);
+ query = xmalloc( (total+1) * sizeof(char));
+ strcpy (query, "INSERT INTO ");
+ strcat(query, arg);
+ strcat(query, " ( ");
+ for (j=1; j <= nf && j <= SQL_FIELD_MAX; j++)
+ {
+ field = mpl_tab_get_name(dca, j);
+ strcat(query, field);
+ if ( j < nf )
+ strcat(query, ", ");
+ }
+ strcat(query, " ) VALUES ( ");
+ for (j=1; j <= nf && j <= SQL_FIELD_MAX; j++)
+ {
+ strcat(query, "?");
+ if ( j < nf )
+ strcat(query, ", ");
+ }
+ strcat(query, " )");
+ return query;
+}
+
+#endif
+
+/**********************************************************************/
+
+#ifndef HAVE_ODBC
+
+void *db_iodbc_open(TABDCA *dca, int mode)
+{ xassert(dca == dca);
+ xassert(mode == mode);
+ xprintf("iODBC table driver not supported\n");
+ return NULL;
+}
+
+int db_iodbc_read(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+int db_iodbc_write(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+int db_iodbc_close(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+#else
+
+#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WOE__)
+#include <windows.h>
+#endif
+
+#include <sql.h>
+#include <sqlext.h>
+
+struct db_odbc
+{
+ int mode; /*'R' = Read, 'W' = Write*/
+ SQLHDBC hdbc; /*connection handle*/
+ SQLHENV henv; /*environment handle*/
+ SQLHSTMT hstmt; /*statement handle*/
+ SQLSMALLINT nresultcols; /* columns in result*/
+ SQLULEN collen[SQL_FIELD_MAX+1];
+ SQLLEN outlen[SQL_FIELD_MAX+1];
+ SQLSMALLINT coltype[SQL_FIELD_MAX+1];
+ SQLCHAR data[SQL_FIELD_MAX+1][SQL_FDLEN_MAX+1];
+#if 1 /* 12/I-2014 */
+ SQLDOUBLE datanum[SQL_FIELD_MAX+1];
+#endif
+ SQLCHAR colname[SQL_FIELD_MAX+1][SQL_FDLEN_MAX+1];
+ int isnumeric[SQL_FIELD_MAX+1];
+ int nf;
+ /* number of fields in the csv file */
+ int ref[1+SQL_FIELD_MAX];
+ /* ref[k] = k', if k-th field of the csv file corresponds to
+ k'-th field in the table statement; if ref[k] = 0, k-th field
+ of the csv file is ignored */
+ SQLCHAR *query;
+ /* query generated by db_iodbc_open */
+};
+
+SQLRETURN SQL_API dl_SQLAllocHandle (
+ SQLSMALLINT HandleType,
+ SQLHANDLE InputHandle,
+ SQLHANDLE *OutputHandle)
+{
+ typedef SQLRETURN SQL_API ep_SQLAllocHandle(
+ SQLSMALLINT HandleType,
+ SQLHANDLE InputHandle,
+ SQLHANDLE *OutputHandle);
+
+ ep_SQLAllocHandle *fn;
+ fn = (ep_SQLAllocHandle *) xdlsym(h_odbc, "SQLAllocHandle");
+ xassert(fn != NULL);
+ return (*fn)(HandleType, InputHandle, OutputHandle);
+}
+
+SQLRETURN SQL_API dl_SQLBindCol (
+ SQLHSTMT StatementHandle,
+ SQLUSMALLINT ColumnNumber,
+ SQLSMALLINT TargetType,
+ SQLPOINTER TargetValue,
+ SQLLEN BufferLength,
+ SQLLEN *StrLen_or_Ind)
+{
+ typedef SQLRETURN SQL_API ep_SQLBindCol(
+ SQLHSTMT StatementHandle,
+ SQLUSMALLINT ColumnNumber,
+ SQLSMALLINT TargetType,
+ SQLPOINTER TargetValue,
+ SQLLEN BufferLength,
+ SQLLEN *StrLen_or_Ind);
+ ep_SQLBindCol *fn;
+ fn = (ep_SQLBindCol *) xdlsym(h_odbc, "SQLBindCol");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle, ColumnNumber, TargetType,
+ TargetValue, BufferLength, StrLen_or_Ind);
+}
+
+SQLRETURN SQL_API dl_SQLCloseCursor (
+ SQLHSTMT StatementHandle)
+{
+ typedef SQLRETURN SQL_API ep_SQLCloseCursor (
+ SQLHSTMT StatementHandle);
+
+ ep_SQLCloseCursor *fn;
+ fn = (ep_SQLCloseCursor *) xdlsym(h_odbc, "SQLCloseCursor");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle);
+}
+
+
+SQLRETURN SQL_API dl_SQLDisconnect (
+ SQLHDBC ConnectionHandle)
+{
+ typedef SQLRETURN SQL_API ep_SQLDisconnect(
+ SQLHDBC ConnectionHandle);
+
+ ep_SQLDisconnect *fn;
+ fn = (ep_SQLDisconnect *) xdlsym(h_odbc, "SQLDisconnect");
+ xassert(fn != NULL);
+ return (*fn)(ConnectionHandle);
+}
+
+SQLRETURN SQL_API dl_SQLDriverConnect (
+ SQLHDBC hdbc,
+ SQLHWND hwnd,
+ SQLCHAR *szConnStrIn,
+ SQLSMALLINT cbConnStrIn,
+ SQLCHAR *szConnStrOut,
+ SQLSMALLINT cbConnStrOutMax,
+ SQLSMALLINT *pcbConnStrOut,
+ SQLUSMALLINT fDriverCompletion)
+{
+ typedef SQLRETURN SQL_API ep_SQLDriverConnect(
+ SQLHDBC hdbc,
+ SQLHWND hwnd,
+ SQLCHAR * szConnStrIn,
+ SQLSMALLINT cbConnStrIn,
+ SQLCHAR * szConnStrOut,
+ SQLSMALLINT cbConnStrOutMax,
+ SQLSMALLINT * pcbConnStrOut,
+ SQLUSMALLINT fDriverCompletion);
+
+ ep_SQLDriverConnect *fn;
+ fn = (ep_SQLDriverConnect *) xdlsym(h_odbc, "SQLDriverConnect");
+ xassert(fn != NULL);
+ return (*fn)(hdbc, hwnd, szConnStrIn, cbConnStrIn, szConnStrOut,
+ cbConnStrOutMax, pcbConnStrOut, fDriverCompletion);
+}
+
+SQLRETURN SQL_API dl_SQLEndTran (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle,
+ SQLSMALLINT CompletionType)
+{
+ typedef SQLRETURN SQL_API ep_SQLEndTran (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle,
+ SQLSMALLINT CompletionType);
+
+ ep_SQLEndTran *fn;
+ fn = (ep_SQLEndTran *) xdlsym(h_odbc, "SQLEndTran");
+ xassert(fn != NULL);
+ return (*fn)(HandleType, Handle, CompletionType);
+}
+
+SQLRETURN SQL_API dl_SQLExecDirect (
+ SQLHSTMT StatementHandle,
+ SQLCHAR * StatementText,
+ SQLINTEGER TextLength)
+{
+ typedef SQLRETURN SQL_API ep_SQLExecDirect (
+ SQLHSTMT StatementHandle,
+ SQLCHAR * StatementText,
+ SQLINTEGER TextLength);
+
+ ep_SQLExecDirect *fn;
+ fn = (ep_SQLExecDirect *) xdlsym(h_odbc, "SQLExecDirect");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle, StatementText, TextLength);
+}
+
+SQLRETURN SQL_API dl_SQLFetch (
+ SQLHSTMT StatementHandle)
+{
+ typedef SQLRETURN SQL_API ep_SQLFetch (
+ SQLHSTMT StatementHandle);
+
+ ep_SQLFetch *fn;
+ fn = (ep_SQLFetch*) xdlsym(h_odbc, "SQLFetch");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle);
+}
+
+SQLRETURN SQL_API dl_SQLFreeHandle (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle)
+{
+ typedef SQLRETURN SQL_API ep_SQLFreeHandle (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle);
+
+ ep_SQLFreeHandle *fn;
+ fn = (ep_SQLFreeHandle *) xdlsym(h_odbc, "SQLFreeHandle");
+ xassert(fn != NULL);
+ return (*fn)(HandleType, Handle);
+}
+
+SQLRETURN SQL_API dl_SQLDescribeCol (
+ SQLHSTMT StatementHandle,
+ SQLUSMALLINT ColumnNumber,
+ SQLCHAR * ColumnName,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT * NameLength,
+ SQLSMALLINT * DataType,
+ SQLULEN * ColumnSize,
+ SQLSMALLINT * DecimalDigits,
+ SQLSMALLINT * Nullable)
+{
+ typedef SQLRETURN SQL_API ep_SQLDescribeCol (
+ SQLHSTMT StatementHandle,
+ SQLUSMALLINT ColumnNumber,
+ SQLCHAR *ColumnName,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT *NameLength,
+ SQLSMALLINT *DataType,
+ SQLULEN *ColumnSize,
+ SQLSMALLINT *DecimalDigits,
+ SQLSMALLINT *Nullable);
+
+ ep_SQLDescribeCol *fn;
+ fn = (ep_SQLDescribeCol *) xdlsym(h_odbc, "SQLDescribeCol");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle, ColumnNumber, ColumnName,
+ BufferLength, NameLength,
+ DataType, ColumnSize, DecimalDigits, Nullable);
+}
+
+SQLRETURN SQL_API dl_SQLGetDiagRec (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle,
+ SQLSMALLINT RecNumber,
+ SQLCHAR *Sqlstate,
+ SQLINTEGER *NativeError,
+ SQLCHAR *MessageText,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT *TextLength)
+{
+ typedef SQLRETURN SQL_API ep_SQLGetDiagRec (
+ SQLSMALLINT HandleType,
+ SQLHANDLE Handle,
+ SQLSMALLINT RecNumber,
+ SQLCHAR *Sqlstate,
+ SQLINTEGER *NativeError,
+ SQLCHAR *MessageText,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT *TextLength);
+
+ ep_SQLGetDiagRec *fn;
+ fn = (ep_SQLGetDiagRec *) xdlsym(h_odbc, "SQLGetDiagRec");
+ xassert(fn != NULL);
+ return (*fn)(HandleType, Handle, RecNumber, Sqlstate,
+ NativeError, MessageText, BufferLength, TextLength);
+}
+
+SQLRETURN SQL_API dl_SQLGetInfo (
+ SQLHDBC ConnectionHandle,
+ SQLUSMALLINT InfoType,
+ SQLPOINTER InfoValue,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT *StringLength)
+{
+ typedef SQLRETURN SQL_API ep_SQLGetInfo (
+ SQLHDBC ConnectionHandle,
+ SQLUSMALLINT InfoType,
+ SQLPOINTER InfoValue,
+ SQLSMALLINT BufferLength,
+ SQLSMALLINT *StringLength);
+
+ ep_SQLGetInfo *fn;
+ fn = (ep_SQLGetInfo *) xdlsym(h_odbc, "SQLGetInfo");
+ xassert(fn != NULL);
+ return (*fn)(ConnectionHandle, InfoType, InfoValue, BufferLength,
+ StringLength);
+}
+
+SQLRETURN SQL_API dl_SQLNumResultCols (
+ SQLHSTMT StatementHandle,
+ SQLSMALLINT *ColumnCount)
+{
+ typedef SQLRETURN SQL_API ep_SQLNumResultCols (
+ SQLHSTMT StatementHandle,
+ SQLSMALLINT *ColumnCount);
+
+ ep_SQLNumResultCols *fn;
+ fn = (ep_SQLNumResultCols *) xdlsym(h_odbc, "SQLNumResultCols");
+ xassert(fn != NULL);
+ return (*fn)(StatementHandle, ColumnCount);
+}
+
+SQLRETURN SQL_API dl_SQLSetConnectAttr (
+ SQLHDBC ConnectionHandle,
+ SQLINTEGER Attribute,
+ SQLPOINTER Value,
+ SQLINTEGER StringLength)
+{
+ typedef SQLRETURN SQL_API ep_SQLSetConnectAttr (
+ SQLHDBC ConnectionHandle,
+ SQLINTEGER Attribute,
+ SQLPOINTER Value,
+ SQLINTEGER StringLength);
+
+ ep_SQLSetConnectAttr *fn;
+ fn = (ep_SQLSetConnectAttr *) xdlsym(h_odbc, "SQLSetConnectAttr");
+ xassert(fn != NULL);
+ return (*fn)(ConnectionHandle, Attribute, Value, StringLength);
+}
+
+SQLRETURN SQL_API dl_SQLSetEnvAttr (
+ SQLHENV EnvironmentHandle,
+ SQLINTEGER Attribute,
+ SQLPOINTER Value,
+ SQLINTEGER StringLength)
+{
+ typedef SQLRETURN SQL_API ep_SQLSetEnvAttr (
+ SQLHENV EnvironmentHandle,
+ SQLINTEGER Attribute,
+ SQLPOINTER Value,
+ SQLINTEGER StringLength);
+
+ ep_SQLSetEnvAttr *fn;
+ fn = (ep_SQLSetEnvAttr *) xdlsym(h_odbc, "SQLSetEnvAttr");
+ xassert(fn != NULL);
+ return (*fn)(EnvironmentHandle, Attribute, Value, StringLength);
+}
+
+static void extract_error(
+ char *fn,
+ SQLHANDLE handle,
+ SQLSMALLINT type);
+
+static int is_numeric(
+ SQLSMALLINT coltype);
+
+/***********************************************************************
+* NAME
+*
+* db_iodbc_open - open connection to ODBC data base
+*
+* SYNOPSIS
+*
+* #include "mplsql.h"
+* void *db_iodbc_open(TABDCA *dca, int mode);
+*
+* DESCRIPTION
+*
+* The routine db_iodbc_open opens a connection to an ODBC data base.
+* It then executes the sql statements passed.
+*
+* In the case of table read the SELECT statement is executed.
+*
+* In the case of table write the INSERT statement is prepared.
+* RETURNS
+*
+* The routine returns a pointer to data storage area created. */
+void *db_iodbc_open(TABDCA *dca, int mode)
+{ void *ret;
+ char **sqllines;
+
+ sqllines = args_concat(dca);
+ if (sqllines == NULL)
+ { xprintf("Missing arguments in table statement.\n"
+ "Please, supply table driver, dsn, and query.\n");
+ return NULL;
+ }
+ ret = db_iodbc_open_int(dca, mode, (const char **) sqllines);
+ free_buffer(sqllines);
+ return ret;
+}
+
+static void *db_iodbc_open_int(TABDCA *dca, int mode, const char
+ **sqllines)
+{
+ struct db_odbc *sql;
+ SQLRETURN ret;
+ SQLCHAR FAR *dsn;
+ SQLCHAR info[256];
+ SQLSMALLINT colnamelen;
+ SQLSMALLINT nullable;
+ SQLSMALLINT scale;
+ const char *arg;
+ int narg;
+ int i, j;
+ int total;
+
+ if (libodbc == NULL)
+ {
+ xprintf("No loader for shared ODBC library available\n");
+ return NULL;
+ }
+
+ if (h_odbc == NULL)
+ {
+ h_odbc = xdlopen(libodbc);
+ if (h_odbc == NULL)
+ { xprintf("unable to open library %s\n", libodbc);
+ xprintf("%s\n", get_err_msg());
+ return NULL;
+ }
+ }
+
+ sql = (struct db_odbc *) xmalloc(sizeof(struct db_odbc));
+ if (sql == NULL)
+ return NULL;
+
+ sql->mode = mode;
+ sql->hdbc = NULL;
+ sql->henv = NULL;
+ sql->hstmt = NULL;
+ sql->query = NULL;
+ narg = mpl_tab_num_args(dca);
+
+ dsn = (SQLCHAR FAR *) mpl_tab_get_arg(dca, 2);
+ /* allocate an environment handle */
+ ret = dl_SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE,
+ &(sql->henv));
+ /* set attribute to enable application to run as ODBC 3.0
+ application */
+ ret = dl_SQLSetEnvAttr(sql->henv, SQL_ATTR_ODBC_VERSION,
+ (void *) SQL_OV_ODBC3, 0);
+ /* allocate a connection handle */
+ ret = dl_SQLAllocHandle(SQL_HANDLE_DBC, sql->henv, &(sql->hdbc));
+ /* connect */
+ ret = dl_SQLDriverConnect(sql->hdbc, NULL, dsn, SQL_NTS, NULL, 0,
+ NULL, SQL_DRIVER_COMPLETE);
+ if (SQL_SUCCEEDED(ret))
+ { /* output information about data base connection */
+ xprintf("Connected to ");
+ dl_SQLGetInfo(sql->hdbc, SQL_DBMS_NAME, (SQLPOINTER)info,
+ sizeof(info), NULL);
+ xprintf("%s ", info);
+ dl_SQLGetInfo(sql->hdbc, SQL_DBMS_VER, (SQLPOINTER)info,
+ sizeof(info), NULL);
+ xprintf("%s - ", info);
+ dl_SQLGetInfo(sql->hdbc, SQL_DATABASE_NAME, (SQLPOINTER)info,
+ sizeof(info), NULL);
+ xprintf("%s\n", info);
+ }
+ else
+ { /* describe error */
+ xprintf("Failed to connect\n");
+ extract_error("SQLDriverConnect", sql->hdbc, SQL_HANDLE_DBC);
+ dl_SQLFreeHandle(SQL_HANDLE_DBC, sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_ENV, sql->henv);
+ xfree(sql);
+ return NULL;
+ }
+ /* set AUTOCOMMIT on*/
+ ret = dl_SQLSetConnectAttr(sql->hdbc, SQL_ATTR_AUTOCOMMIT,
+ (SQLPOINTER)SQL_AUTOCOMMIT_ON, 0);
+ /* allocate a statement handle */
+ ret = dl_SQLAllocHandle(SQL_HANDLE_STMT, sql->hdbc, &(sql->hstmt));
+
+ /* initialization queries */
+ for(j = 0; sqllines[j+1] != NULL; j++)
+ {
+ sql->query = (SQLCHAR *) sqllines[j];
+ xprintf("%s\n", sql->query);
+ ret = dl_SQLExecDirect(sql->hstmt, sql->query, SQL_NTS);
+ switch (ret)
+ {
+ case SQL_SUCCESS:
+ case SQL_SUCCESS_WITH_INFO:
+ case SQL_NO_DATA_FOUND:
+ break;
+ default:
+ xprintf("db_iodbc_open: Query\n\"%s\"\nfailed.\n",
+ sql->query);
+ extract_error("SQLExecDirect", sql->hstmt, SQL_HANDLE_STMT);
+ dl_SQLFreeHandle(SQL_HANDLE_STMT, sql->hstmt);
+ dl_SQLDisconnect(sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_DBC, sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_ENV, sql->henv);
+ xfree(sql);
+ return NULL;
+ }
+ /* commit statement */
+ dl_SQLEndTran(SQL_HANDLE_ENV, sql->henv, SQL_COMMIT);
+ }
+
+ if ( sql->mode == 'R' )
+ { sql->nf = mpl_tab_num_flds(dca);
+ for(j = 0; sqllines[j] != NULL; j++)
+ arg = sqllines[j];
+ total = strlen(arg);
+ if (total > 7 && 0 == strncmp(arg, "SELECT ", 7))
+ {
+ total = strlen(arg);
+ sql->query = xmalloc( (total+1) * sizeof(char));
+ strcpy (sql->query, arg);
+ }
+ else
+ {
+ sql->query = db_generate_select_stmt(dca);
+ }
+ xprintf("%s\n", sql->query);
+ if (dl_SQLExecDirect(sql->hstmt, sql->query, SQL_NTS) !=
+ SQL_SUCCESS)
+ {
+ xprintf("db_iodbc_open: Query\n\"%s\"\nfailed.\n", sql->query);
+ extract_error("SQLExecDirect", sql->hstmt, SQL_HANDLE_STMT);
+ dl_SQLFreeHandle(SQL_HANDLE_STMT, sql->hstmt);
+ dl_SQLDisconnect(sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_DBC, sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_ENV, sql->henv);
+ xfree(sql->query);
+ xfree(sql);
+ return NULL;
+ }
+ xfree(sql->query);
+ /* determine number of result columns */
+ ret = dl_SQLNumResultCols(sql->hstmt, &sql->nresultcols);
+ total = sql->nresultcols;
+ if (total > SQL_FIELD_MAX)
+ { xprintf("db_iodbc_open: Too many fields (> %d) in query.\n"
+ "\"%s\"\n", SQL_FIELD_MAX, sql->query);
+ dl_SQLFreeHandle(SQL_HANDLE_STMT, sql->hstmt);
+ dl_SQLDisconnect(sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_DBC, sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_ENV, sql->henv);
+ xfree(sql->query);
+ return NULL;
+ }
+ for (i = 1; i <= total; i++)
+ { /* return a set of attributes for a column */
+ ret = dl_SQLDescribeCol(sql->hstmt, (SQLSMALLINT) i,
+ sql->colname[i], SQL_FDLEN_MAX,
+ &colnamelen, &(sql->coltype[i]), &(sql->collen[i]), &scale,
+ &nullable);
+ sql->isnumeric[i] = is_numeric(sql->coltype[i]);
+ /* bind columns to program vars, converting all types to CHAR*/
+ if (sql->isnumeric[i])
+#if 0 /* 12/I-2014 */
+ { dl_SQLBindCol(sql->hstmt, i, SQL_DOUBLE, sql->data[i],
+#else
+ { dl_SQLBindCol(sql->hstmt, i, SQL_DOUBLE, &sql->datanum[i],
+#endif
+ SQL_FDLEN_MAX, &(sql->outlen[i]));
+ } else
+ { dl_SQLBindCol(sql->hstmt, i, SQL_CHAR, sql->data[i],
+ SQL_FDLEN_MAX, &(sql->outlen[i]));
+ }
+ for (j = sql->nf; j >= 1; j--)
+ { if (strcmp(mpl_tab_get_name(dca, j), sql->colname[i]) == 0)
+ break;
+ }
+ sql->ref[i] = j;
+ }
+ }
+ else if ( sql->mode == 'W' )
+ { for(j = 0; sqllines[j] != NULL; j++)
+ arg = sqllines[j];
+ if ( NULL != strchr(arg, '?') )
+ {
+ total = strlen(arg);
+ sql->query = xmalloc( (total+1) * sizeof(char));
+ strcpy (sql->query, arg);
+ }
+ else
+ {
+ sql->query = db_generate_insert_stmt(dca);
+ }
+ xprintf("%s\n", sql->query);
+ }
+ return sql;
+}
+
+int db_iodbc_read(TABDCA *dca, void *link)
+{
+ struct db_odbc *sql;
+ SQLRETURN ret;
+ char buf[SQL_FDLEN_MAX+1];
+ int i;
+ int len;
+ double num;
+
+ sql = (struct db_odbc *) link;
+
+ xassert(sql != NULL);
+ xassert(sql->mode == 'R');
+
+ ret=dl_SQLFetch(sql->hstmt);
+ if (ret== SQL_ERROR)
+ return -1;
+ if (ret== SQL_NO_DATA_FOUND)
+ return -1; /*EOF*/
+ for (i=1; i <= sql->nresultcols; i++)
+ {
+ if (sql->ref[i] > 0)
+ {
+ len = sql->outlen[i];
+ if (len != SQL_NULL_DATA)
+ {
+ if (sql->isnumeric[i])
+ { mpl_tab_set_num(dca, sql->ref[i],
+#if 0 /* 12/I-2014 */
+ *((const double *) sql->data[i]));
+#else
+ (const double) sql->datanum[i]);
+#endif
+ }
+ else
+ { if (len > SQL_FDLEN_MAX)
+ len = SQL_FDLEN_MAX;
+ else if (len < 0)
+ len = 0;
+ strncpy(buf, (const char *) sql->data[i], len);
+ buf[len] = 0x00;
+ mpl_tab_set_str(dca, sql->ref[i], strtrim(buf));
+ }
+ }
+ }
+ }
+ return 0;
+}
+
+int db_iodbc_write(TABDCA *dca, void *link)
+{
+ struct db_odbc *sql;
+ char *part;
+ char *query;
+ char *template;
+ char num[50];
+ int k;
+ int len;
+ int nf;
+
+ sql = (struct db_odbc *) link;
+ xassert(sql != NULL);
+ xassert(sql->mode == 'W');
+
+ len = strlen(sql->query);
+ template = (char *) xmalloc( (len + 1) * sizeof(char) );
+ strcpy(template, sql->query);
+
+ nf = mpl_tab_num_flds(dca);
+ for (k = 1; k <= nf; k++)
+ { switch (mpl_tab_get_type(dca, k))
+ { case 'N':
+ len += 20;
+ break;
+ case 'S':
+ len += db_escaped_string_length(mpl_tab_get_str(dca, k));
+ len += 2;
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ }
+ query = xmalloc( (len + 1 ) * sizeof(char) );
+ query[0] = 0x00;
+#if 0 /* 29/I-2017 */
+ for (k = 1, part = strtok (template, "?"); (part != NULL);
+ part = strtok (NULL, "?"), k++)
+#else
+ for (k = 1, part = xstrtok (template, "?"); (part != NULL);
+ part = xstrtok (NULL, "?"), k++)
+#endif
+ {
+ if (k > nf) break;
+ strcat( query, part );
+ switch (mpl_tab_get_type(dca, k))
+ { case 'N':
+#if 0 /* 02/XI-2010 by xypron */
+ sprintf(num, "%-18g",mpl_tab_get_num(dca, k));
+#else
+ sprintf(num, "%.*g", DBL_DIG, mpl_tab_get_num(dca, k));
+#endif
+ strcat( query, num );
+ break;
+ case 'S':
+ strcat( query, "'");
+ db_escape_string( query + strlen(query),
+ mpl_tab_get_str(dca, k) );
+ strcat( query, "'");
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ }
+ if (part != NULL)
+ strcat(query, part);
+ if (dl_SQLExecDirect(sql->hstmt, (SQLCHAR *) query, SQL_NTS)
+ != SQL_SUCCESS)
+ {
+ xprintf("db_iodbc_write: Query\n\"%s\"\nfailed.\n", query);
+ extract_error("SQLExecDirect", sql->hdbc, SQL_HANDLE_DBC);
+ xfree(query);
+ xfree(template);
+ return 1;
+ }
+
+ xfree(query);
+ xfree(template);
+ return 0;
+}
+
+int db_iodbc_close(TABDCA *dca, void *link)
+{
+ struct db_odbc *sql;
+
+ sql = (struct db_odbc *) link;
+ xassert(sql != NULL);
+ /* Commit */
+ if ( sql->mode == 'W' )
+ dl_SQLEndTran(SQL_HANDLE_ENV, sql->henv, SQL_COMMIT);
+ if ( sql->mode == 'R' )
+ dl_SQLCloseCursor(sql->hstmt);
+
+ dl_SQLFreeHandle(SQL_HANDLE_STMT, sql->hstmt);
+ dl_SQLDisconnect(sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_DBC, sql->hdbc);
+ dl_SQLFreeHandle(SQL_HANDLE_ENV, sql->henv);
+ if ( sql->mode == 'W' )
+ xfree(sql->query);
+ xfree(sql);
+ dca->link = NULL;
+ return 0;
+}
+
+static void extract_error(
+ char *fn,
+ SQLHANDLE handle,
+ SQLSMALLINT type)
+{
+ SQLINTEGER i = 0;
+ SQLINTEGER native;
+ SQLCHAR state[ 7 ];
+ SQLCHAR text[256];
+ SQLSMALLINT len;
+ SQLRETURN ret;
+
+ xprintf("\nThe driver reported the following diagnostics whilst "
+ "running %s\n", fn);
+
+ do
+ {
+ ret = dl_SQLGetDiagRec(type, handle, ++i, state, &native, text,
+ sizeof(text), &len );
+ if (SQL_SUCCEEDED(ret))
+ xprintf("%s:%ld:%ld:%s\n", state, i, native, text);
+ }
+ while( ret == SQL_SUCCESS );
+}
+
+static int is_numeric(SQLSMALLINT coltype)
+{
+ int ret = 0;
+ switch (coltype)
+ {
+ case SQL_DECIMAL:
+ case SQL_NUMERIC:
+ case SQL_SMALLINT:
+ case SQL_INTEGER:
+ case SQL_REAL:
+ case SQL_FLOAT:
+ case SQL_DOUBLE:
+ case SQL_TINYINT:
+ case SQL_BIGINT:
+ ret = 1;
+ break;
+ }
+ return ret;
+}
+
+#endif
+
+/**********************************************************************/
+
+#ifndef HAVE_MYSQL
+
+void *db_mysql_open(TABDCA *dca, int mode)
+{ xassert(dca == dca);
+ xassert(mode == mode);
+ xprintf("MySQL table driver not supported\n");
+ return NULL;
+}
+
+int db_mysql_read(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+int db_mysql_write(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+int db_mysql_close(TABDCA *dca, void *link)
+{ xassert(dca != dca);
+ xassert(link != link);
+ return 0;
+}
+
+#else
+
+#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(__WOE__)
+#include <windows.h>
+#endif
+
+#ifdef __CYGWIN__
+#define byte_defined 1
+#endif
+
+#if 0 /* 12/II-2014; to fix namespace bug */
+#include <my_global.h>
+#include <my_sys.h>
+#endif
+#include <mysql.h>
+
+struct db_mysql
+{
+ int mode; /*'R' = Read, 'W' = Write*/
+ MYSQL *con; /*connection*/
+ MYSQL_RES *res; /*result*/
+ int nf;
+ /* number of fields in the csv file */
+ int ref[1+SQL_FIELD_MAX];
+ /* ref[k] = k', if k-th field of the csv file corresponds to
+ k'-th field in the table statement; if ref[k] = 0, k-th field
+ of the csv file is ignored */
+ char *query;
+ /* query generated by db_mysql_open */
+};
+
+void STDCALL dl_mysql_close(MYSQL *sock)
+{
+ typedef void STDCALL ep_mysql_close(MYSQL *sock);
+
+ ep_mysql_close *fn;
+ fn = (ep_mysql_close *) xdlsym(h_mysql, "mysql_close");
+ xassert(fn != NULL);
+ return (*fn)(sock);
+}
+
+const char * STDCALL dl_mysql_error(MYSQL *mysql)
+{
+ typedef const char * STDCALL ep_mysql_error(MYSQL *mysql);
+
+ ep_mysql_error *fn;
+ fn = (ep_mysql_error *) xdlsym(h_mysql, "mysql_error");
+ xassert(fn != NULL);
+ return (*fn)(mysql);
+}
+
+MYSQL_FIELD * STDCALL dl_mysql_fetch_fields(MYSQL_RES *res)
+{
+ typedef MYSQL_FIELD * STDCALL
+ ep_mysql_fetch_fields(MYSQL_RES *res);
+
+ ep_mysql_fetch_fields *fn;
+ fn = (ep_mysql_fetch_fields *) xdlsym(h_mysql, "mysql_fetch_fields");
+ xassert(fn != NULL);
+ return (*fn)(res);
+}
+
+unsigned long * STDCALL dl_mysql_fetch_lengths(MYSQL_RES *result)
+{
+ typedef unsigned long * STDCALL
+ ep_mysql_fetch_lengths(MYSQL_RES *result);
+
+ ep_mysql_fetch_lengths *fn;
+ fn = (ep_mysql_fetch_lengths *) xdlsym(h_mysql,
+ "mysql_fetch_lengths");
+ xassert(fn != NULL);
+ return (*fn)(result);
+}
+
+MYSQL_ROW STDCALL dl_mysql_fetch_row(MYSQL_RES *result)
+{
+ typedef MYSQL_ROW STDCALL ep_mysql_fetch_row(MYSQL_RES *result);
+
+ ep_mysql_fetch_row *fn;
+ fn = (ep_mysql_fetch_row *) xdlsym(h_mysql, "mysql_fetch_row");
+ xassert(fn != NULL);
+ return (*fn)(result);
+}
+
+unsigned int STDCALL dl_mysql_field_count(MYSQL *mysql)
+{
+ typedef unsigned int STDCALL ep_mysql_field_count(MYSQL *mysql);
+
+ ep_mysql_field_count *fn;
+ fn = (ep_mysql_field_count *) xdlsym(h_mysql, "mysql_field_count");
+ xassert(fn != NULL);
+ return (*fn)(mysql);
+}
+
+MYSQL * STDCALL dl_mysql_init(MYSQL *mysql)
+{
+ typedef MYSQL * STDCALL ep_mysql_init(MYSQL *mysql);
+
+ ep_mysql_init *fn;
+ fn = (ep_mysql_init *) xdlsym(h_mysql, "mysql_init");
+ xassert(fn != NULL);
+ return (*fn)(mysql);
+}
+
+unsigned int STDCALL dl_mysql_num_fields(MYSQL_RES *res)
+{
+ typedef unsigned int STDCALL ep_mysql_num_fields(MYSQL_RES *res);
+
+ ep_mysql_num_fields *fn;
+ fn = (ep_mysql_num_fields *) xdlsym(h_mysql, "mysql_num_fields");
+ xassert(fn != NULL);
+ return (*fn)(res);
+}
+
+int STDCALL dl_mysql_query(MYSQL *mysql, const char *q)
+{
+ typedef int STDCALL ep_mysql_query(MYSQL *mysql, const char *q);
+
+ ep_mysql_query *fn;
+ fn = (ep_mysql_query *) xdlsym(h_mysql, "mysql_query");
+ xassert(fn != NULL);
+ return (*fn)(mysql, q);
+}
+
+MYSQL * STDCALL dl_mysql_real_connect(MYSQL *mysql, const char *host,
+ const char *user,
+ const char *passwd,
+ const char *db,
+ unsigned int port,
+ const char *unix_socket,
+ unsigned long clientflag)
+{
+ typedef MYSQL * STDCALL ep_mysql_real_connect(MYSQL *mysql,
+ const char *host,
+ const char *user,
+ const char *passwd,
+ const char *db,
+ unsigned int port,
+ const char *unix_socket,
+ unsigned long clientflag);
+
+ ep_mysql_real_connect *fn;
+ fn = (ep_mysql_real_connect *) xdlsym(h_mysql,
+ "mysql_real_connect");
+ xassert(fn != NULL);
+ return (*fn)(mysql, host, user, passwd, db, port, unix_socket,
+ clientflag);
+}
+
+MYSQL_RES * STDCALL dl_mysql_use_result(MYSQL *mysql)
+{
+ typedef MYSQL_RES * STDCALL ep_mysql_use_result(MYSQL *mysql);
+ ep_mysql_use_result *fn;
+ fn = (ep_mysql_use_result *) xdlsym(h_mysql, "mysql_use_result");
+ xassert(fn != NULL);
+ return (*fn)(mysql);
+}
+
+/***********************************************************************
+* NAME
+*
+* db_mysql_open - open connection to ODBC data base
+*
+* SYNOPSIS
+*
+* #include "mplsql.h"
+* void *db_mysql_open(TABDCA *dca, int mode);
+*
+* DESCRIPTION
+*
+* The routine db_mysql_open opens a connection to a MySQL data base.
+* It then executes the sql statements passed.
+*
+* In the case of table read the SELECT statement is executed.
+*
+* In the case of table write the INSERT statement is prepared.
+* RETURNS
+*
+* The routine returns a pointer to data storage area created. */
+
+void *db_mysql_open(TABDCA *dca, int mode)
+{ void *ret;
+ char **sqllines;
+
+ sqllines = args_concat(dca);
+ if (sqllines == NULL)
+ { xprintf("Missing arguments in table statement.\n"
+ "Please, supply table driver, dsn, and query.\n");
+ return NULL;
+ }
+ ret = db_mysql_open_int(dca, mode, (const char **) sqllines);
+ free_buffer(sqllines);
+ return ret;
+}
+
+static void *db_mysql_open_int(TABDCA *dca, int mode, const char
+ **sqllines)
+{
+ struct db_mysql *sql = NULL;
+ char *arg = NULL;
+ const char *field;
+ MYSQL_FIELD *fields;
+ char *keyword;
+ char *value;
+ char *query;
+ char *dsn;
+/* "Server=[server_name];Database=[database_name];UID=[username];*/
+/* PWD=[password];Port=[port]"*/
+ char *server = NULL; /* Server */
+ char *user = NULL; /* UID */
+ char *password = NULL; /* PWD */
+ char *database = NULL; /* Database */
+ unsigned int port = 0; /* Port */
+ int narg;
+ int i, j, total;
+
+ if (libmysql == NULL)
+ {
+ xprintf("No loader for shared MySQL library available\n");
+ return NULL;
+ }
+
+ if (h_mysql == NULL)
+ {
+ h_mysql = xdlopen(libmysql);
+ if (h_mysql == NULL)
+ { xprintf("unable to open library %s\n", libmysql);
+ xprintf("%s\n", get_err_msg());
+ return NULL;
+ }
+ }
+
+ sql = (struct db_mysql *) xmalloc(sizeof(struct db_mysql));
+ if (sql == NULL)
+ return NULL;
+ sql->mode = mode;
+ sql->res = NULL;
+ sql->query = NULL;
+ sql->nf = mpl_tab_num_flds(dca);
+
+ narg = mpl_tab_num_args(dca);
+ if (narg < 3 )
+ xprintf("MySQL driver: string list too short \n");
+
+ /* get connection string*/
+ dsn = (char *) mpl_tab_get_arg(dca, 2);
+ /* copy connection string*/
+ i = strlen(dsn);
+ i++;
+ arg = xmalloc(i * sizeof(char));
+ strcpy(arg, dsn);
+ /*tokenize connection string*/
+#if 0 /* 29/I-2017 */
+ for (i = 1, keyword = strtok (arg, "="); (keyword != NULL);
+ keyword = strtok (NULL, "="), i++)
+#else
+ for (i = 1, keyword = xstrtok (arg, "="); (keyword != NULL);
+ keyword = xstrtok (NULL, "="), i++)
+#endif
+ {
+#if 0 /* 29/I-2017 */
+ value = strtok (NULL, ";");
+#else
+ value = xstrtok (NULL, ";");
+#endif
+ if (value==NULL)
+ {
+ xprintf("db_mysql_open: Missing value for keyword %s\n",
+ keyword);
+ xfree(arg);
+ xfree(sql);
+ return NULL;
+ }
+ if (0 == strcmp(keyword, "Server"))
+ server = value;
+ else if (0 == strcmp(keyword, "Database"))
+ database = value;
+ else if (0 == strcmp(keyword, "UID"))
+ user = value;
+ else if (0 == strcmp(keyword, "PWD"))
+ password = value;
+ else if (0 == strcmp(keyword, "Port"))
+ port = (unsigned int) atol(value);
+ }
+ /* Connect to database */
+ sql->con = dl_mysql_init(NULL);
+ if (!dl_mysql_real_connect(sql->con, server, user, password, database,
+ port, NULL, 0))
+ {
+ xprintf("db_mysql_open: Connect failed\n");
+ xprintf("%s\n", dl_mysql_error(sql->con));
+ xfree(arg);
+ xfree(sql);
+ return NULL;
+ }
+ xfree(arg);
+
+ for(j = 0; sqllines[j+1] != NULL; j++)
+ { query = (char *) sqllines[j];
+ xprintf("%s\n", query);
+ if (dl_mysql_query(sql->con, query))
+ {
+ xprintf("db_mysql_open: Query\n\"%s\"\nfailed.\n", query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ dl_mysql_close(sql->con);
+ xfree(sql);
+ return NULL;
+ }
+ }
+
+ if ( sql->mode == 'R' )
+ { sql->nf = mpl_tab_num_flds(dca);
+ for(j = 0; sqllines[j] != NULL; j++)
+ arg = (char *) sqllines[j];
+ total = strlen(arg);
+ if (total > 7 && 0 == strncmp(arg, "SELECT ", 7))
+ {
+ total = strlen(arg);
+ query = xmalloc( (total+1) * sizeof(char));
+ strcpy (query, arg);
+ }
+ else
+ {
+ query = db_generate_select_stmt(dca);
+ }
+ xprintf("%s\n", query);
+ if (dl_mysql_query(sql->con, query))
+ {
+ xprintf("db_mysql_open: Query\n\"%s\"\nfailed.\n", query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ dl_mysql_close(sql->con);
+ xfree(query);
+ xfree(sql);
+ return NULL;
+ }
+ xfree(query);
+ sql->res = dl_mysql_use_result(sql->con);
+ if (sql->res)
+ {
+ /* create references between query results and table fields*/
+ total = dl_mysql_num_fields(sql->res);
+ if (total > SQL_FIELD_MAX)
+ { xprintf("db_mysql_open: Too many fields (> %d) in query.\n"
+ "\"%s\"\n", SQL_FIELD_MAX, query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ dl_mysql_close(sql->con);
+ xfree(query);
+ xfree(sql);
+ return NULL;
+ }
+ fields = dl_mysql_fetch_fields(sql->res);
+ for (i = 1; i <= total; i++)
+ {
+ for (j = sql->nf; j >= 1; j--)
+ {
+ if (strcmp(mpl_tab_get_name(dca, j), fields[i-1].name)
+ == 0)
+ break;
+ }
+ sql->ref[i] = j;
+ }
+ }
+ else
+ {
+ if(dl_mysql_field_count(sql->con) == 0)
+ {
+ xprintf("db_mysql_open: Query was not a SELECT\n\"%s\"\n",
+ query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ xfree(query);
+ xfree(sql);
+ return NULL;
+ }
+ else
+ {
+ xprintf("db_mysql_open: Query\n\"%s\"\nfailed.\n", query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ xfree(query);
+ xfree(sql);
+ return NULL;
+ }
+ }
+ }
+ else if ( sql->mode == 'W' )
+ { for(j = 0; sqllines[j] != NULL; j++)
+ arg = (char *) sqllines[j];
+ if ( NULL != strchr(arg, '?') )
+ {
+ total = strlen(arg);
+ query = xmalloc( (total+1) * sizeof(char));
+ strcpy (query, arg);
+ }
+ else
+ query = db_generate_insert_stmt(dca);
+ sql->query = query;
+ xprintf("%s\n", query);
+ }
+ return sql;
+}
+
+int db_mysql_read(TABDCA *dca, void *link)
+{ struct db_mysql *sql;
+ char buf[255+1];
+ char **row;
+ unsigned long *lengths;
+ MYSQL_FIELD *fields;
+ double num;
+ int len;
+ unsigned long num_fields;
+ int i;
+
+ sql = (struct db_mysql *) link;
+
+ xassert(sql != NULL);
+ xassert(sql->mode == 'R');
+ if (NULL == sql->res)
+ {
+ xprintf("db_mysql_read: no result set available");
+ return 1;
+ }
+ if (NULL==(row = (char **)dl_mysql_fetch_row(sql->res))) {
+ return -1; /*EOF*/
+ }
+ lengths = dl_mysql_fetch_lengths(sql->res);
+ fields = dl_mysql_fetch_fields(sql->res);
+ num_fields = dl_mysql_num_fields(sql->res);
+ for (i=1; i <= num_fields; i++)
+ {
+ if (row[i-1] != NULL)
+ { len = (size_t) lengths[i-1];
+ if (len > 255)
+ len = 255;
+ strncpy(buf, (const char *) row[i-1], len);
+ buf[len] = 0x00;
+ if (0 != (fields[i-1].flags & NUM_FLAG))
+ { strspx(buf); /* remove spaces*/
+ if (str2num(buf, &num) != 0)
+ { xprintf("'%s' cannot be converted to a number.\n", buf);
+ return 1;
+ }
+ if (sql->ref[i] > 0)
+ mpl_tab_set_num(dca, sql->ref[i], num);
+ }
+ else
+ { if (sql->ref[i] > 0)
+ mpl_tab_set_str(dca, sql->ref[i], strtrim(buf));
+ }
+ }
+ }
+ return 0;
+}
+
+int db_mysql_write(TABDCA *dca, void *link)
+{
+ struct db_mysql *sql;
+ char *part;
+ char *query;
+ char *template;
+ char num[50];
+ int k;
+ int len;
+ int nf;
+
+ sql = (struct db_mysql *) link;
+ xassert(sql != NULL);
+ xassert(sql->mode == 'W');
+
+ len = strlen(sql->query);
+ template = (char *) xmalloc( (len + 1) * sizeof(char) );
+ strcpy(template, sql->query);
+
+ nf = mpl_tab_num_flds(dca);
+ for (k = 1; k <= nf; k++)
+ { switch (mpl_tab_get_type(dca, k))
+ { case 'N':
+ len += 20;
+ break;
+ case 'S':
+ len += db_escaped_string_length(mpl_tab_get_str(dca, k));
+ len += 2;
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ }
+ query = xmalloc( (len + 1 ) * sizeof(char) );
+ query[0] = 0x00;
+#if 0 /* 29/I-2017 */
+ for (k = 1, part = strtok (template, "?"); (part != NULL);
+ part = strtok (NULL, "?"), k++)
+#else
+ for (k = 1, part = xstrtok (template, "?"); (part != NULL);
+ part = xstrtok (NULL, "?"), k++)
+#endif
+ {
+ if (k > nf) break;
+ strcat( query, part );
+ switch (mpl_tab_get_type(dca, k))
+ { case 'N':
+#if 0 /* 02/XI-2010 by xypron */
+ sprintf(num, "%-18g",mpl_tab_get_num(dca, k));
+#else
+ sprintf(num, "%.*g", DBL_DIG, mpl_tab_get_num(dca, k));
+#endif
+ strcat( query, num );
+ break;
+ case 'S':
+ strcat( query, "'");
+ db_escape_string( query + strlen(query),
+ mpl_tab_get_str(dca, k) );
+ strcat( query, "'");
+ break;
+ default:
+ xassert(dca != dca);
+ }
+ }
+ if (part != NULL)
+ strcat(query, part);
+ if (dl_mysql_query(sql->con, query))
+ {
+ xprintf("db_mysql_write: Query\n\"%s\"\nfailed.\n", query);
+ xprintf("%s\n",dl_mysql_error(sql->con));
+ xfree(query);
+ xfree(template);
+ return 1;
+ }
+
+ xfree(query);
+ xfree(template);
+ return 0;
+ }
+
+int db_mysql_close(TABDCA *dca, void *link)
+{
+ struct db_mysql *sql;
+
+ sql = (struct db_mysql *) link;
+ xassert(sql != NULL);
+ dl_mysql_close(sql->con);
+ if ( sql->mode == 'W' )
+ xfree(sql->query);
+ xfree(sql);
+ dca->link = NULL;
+ return 0;
+}
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/mpl/mplsql.h b/test/monniaux/glpk-4.65/src/mpl/mplsql.h
new file mode 100644
index 00000000..11d438bb
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/mpl/mplsql.h
@@ -0,0 +1,63 @@
+/* mplsql.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Author: Heinrich Schuchardt <heinrich.schuchardt@gmx.de>.
+*
+* Copyright (C) 2003-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef MPLSQL_H
+#define MPLSQL_H
+
+#define db_iodbc_open _glp_db_iodbc_open
+void *db_iodbc_open(TABDCA *dca, int mode);
+/* open iODBC database connection */
+
+#define db_iodbc_read _glp_db_iodbc_read
+int db_iodbc_read(TABDCA *dca, void *link);
+/* read data from iODBC */
+
+#define db_iodbc_write _glp_db_iodbc_write
+int db_iodbc_write(TABDCA *dca, void *link);
+/* write data to iODBC */
+
+#define db_iodbc_close _glp_db_iodbc_close
+int db_iodbc_close(TABDCA *dca, void *link);
+/* close iODBC database connection */
+
+#define db_mysql_open _glp_db_mysql_open
+void *db_mysql_open(TABDCA *dca, int mode);
+/* open MySQL database connection */
+
+#define db_mysql_read _glp_db_mysql_read
+int db_mysql_read(TABDCA *dca, void *link);
+/* read data from MySQL */
+
+#define db_mysql_write _glp_db_mysql_write
+int db_mysql_write(TABDCA *dca, void *link);
+/* write data to MySQL */
+
+#define db_mysql_close _glp_db_mysql_close
+int db_mysql_close(TABDCA *dca, void *link);
+/* close MySQL database connection */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp.h b/test/monniaux/glpk-4.65/src/npp/npp.h
new file mode 100644
index 00000000..428cb23c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp.h
@@ -0,0 +1,645 @@
+/* npp.h (LP/MIP preprocessor) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef NPP_H
+#define NPP_H
+
+#include "prob.h"
+
+#if 0 /* 20/XI-2017 */
+typedef struct NPP NPP;
+#else
+typedef struct glp_prep NPP;
+#endif
+typedef struct NPPROW NPPROW;
+typedef struct NPPCOL NPPCOL;
+typedef struct NPPAIJ NPPAIJ;
+typedef struct NPPTSE NPPTSE;
+typedef struct NPPLFE NPPLFE;
+
+#if 0 /* 20/XI-2017 */
+struct NPP
+#else
+struct glp_prep
+#endif
+{ /* LP/MIP preprocessor workspace */
+ /*--------------------------------------------------------------*/
+ /* original problem segment */
+ int orig_dir;
+ /* optimization direction flag:
+ GLP_MIN - minimization
+ GLP_MAX - maximization */
+ int orig_m;
+ /* number of rows */
+ int orig_n;
+ /* number of columns */
+ int orig_nnz;
+ /* number of non-zero constraint coefficients */
+ /*--------------------------------------------------------------*/
+ /* transformed problem segment (always minimization) */
+ DMP *pool;
+ /* memory pool to store problem components */
+ char *name;
+ /* problem name (1 to 255 chars); NULL means no name is assigned
+ to the problem */
+ char *obj;
+ /* objective function name (1 to 255 chars); NULL means no name
+ is assigned to the objective function */
+ double c0;
+ /* constant term of the objective function */
+ int nrows;
+ /* number of rows introduced into the problem; this count
+ increases by one every time a new row is added and never
+ decreases; thus, actual number of rows may be less than nrows
+ due to row deletions */
+ int ncols;
+ /* number of columns introduced into the problem; this count
+ increases by one every time a new column is added and never
+ decreases; thus, actual number of column may be less than
+ ncols due to column deletions */
+ NPPROW *r_head;
+ /* pointer to the beginning of the row list */
+ NPPROW *r_tail;
+ /* pointer to the end of the row list */
+ NPPCOL *c_head;
+ /* pointer to the beginning of the column list */
+ NPPCOL *c_tail;
+ /* pointer to the end of the column list */
+ /*--------------------------------------------------------------*/
+ /* transformation history */
+ DMP *stack;
+ /* memory pool to store transformation entries */
+ NPPTSE *top;
+ /* pointer to most recent transformation entry */
+#if 0 /* 16/XII-2009 */
+ int count[1+25];
+ /* transformation statistics */
+#endif
+ /*--------------------------------------------------------------*/
+ /* resultant (preprocessed) problem segment */
+ int m;
+ /* number of rows */
+ int n;
+ /* number of columns */
+ int nnz;
+ /* number of non-zero constraint coefficients */
+ int *row_ref; /* int row_ref[1+m]; */
+ /* row_ref[i], 1 <= i <= m, is the reference number assigned to
+ a row, which is i-th row of the resultant problem */
+ int *col_ref; /* int col_ref[1+n]; */
+ /* col_ref[j], 1 <= j <= n, is the reference number assigned to
+ a column, which is j-th column of the resultant problem */
+ /*--------------------------------------------------------------*/
+ /* recovered solution segment */
+ int sol;
+ /* solution indicator:
+ GLP_SOL - basic solution
+ GLP_IPT - interior-point solution
+ GLP_MIP - mixed integer solution */
+ int scaling;
+ /* scaling option:
+ GLP_OFF - scaling is disabled
+ GLP_ON - scaling is enabled */
+ int p_stat;
+ /* status of primal basic solution:
+ GLP_UNDEF - primal solution is undefined
+ GLP_FEAS - primal solution is feasible
+ GLP_INFEAS - primal solution is infeasible
+ GLP_NOFEAS - no primal feasible solution exists */
+ int d_stat;
+ /* status of dual basic solution:
+ GLP_UNDEF - dual solution is undefined
+ GLP_FEAS - dual solution is feasible
+ GLP_INFEAS - dual solution is infeasible
+ GLP_NOFEAS - no dual feasible solution exists */
+ int t_stat;
+ /* status of interior-point solution:
+ GLP_UNDEF - interior solution is undefined
+ GLP_OPT - interior solution is optimal */
+ int i_stat;
+ /* status of mixed integer solution:
+ GLP_UNDEF - integer solution is undefined
+ GLP_OPT - integer solution is optimal
+ GLP_FEAS - integer solution is feasible
+ GLP_NOFEAS - no integer solution exists */
+ char *r_stat; /* char r_stat[1+nrows]; */
+ /* r_stat[i], 1 <= i <= nrows, is status of i-th row:
+ GLP_BS - inactive constraint
+ GLP_NL - active constraint on lower bound
+ GLP_NU - active constraint on upper bound
+ GLP_NF - active free row
+ GLP_NS - active equality constraint */
+ char *c_stat; /* char c_stat[1+nrows]; */
+ /* c_stat[j], 1 <= j <= nrows, is status of j-th column:
+ GLP_BS - basic variable
+ GLP_NL - non-basic variable on lower bound
+ GLP_NU - non-basic variable on upper bound
+ GLP_NF - non-basic free variable
+ GLP_NS - non-basic fixed variable */
+ double *r_pi; /* double r_pi[1+nrows]; */
+ /* r_pi[i], 1 <= i <= nrows, is Lagrange multiplier (dual value)
+ for i-th row (constraint) */
+ double *c_value; /* double c_value[1+ncols]; */
+ /* c_value[j], 1 <= j <= ncols, is primal value of j-th column
+ (structural variable) */
+};
+
+struct NPPROW
+{ /* row (constraint) */
+ int i;
+ /* reference number assigned to the row, 1 <= i <= nrows */
+ char *name;
+ /* row name (1 to 255 chars); NULL means no name is assigned to
+ the row */
+ double lb;
+ /* lower bound; -DBL_MAX means the row has no lower bound */
+ double ub;
+ /* upper bound; +DBL_MAX means the row has no upper bound */
+ NPPAIJ *ptr;
+ /* pointer to the linked list of constraint coefficients */
+ int temp;
+ /* working field used by preprocessor routines */
+ NPPROW *prev;
+ /* pointer to previous row in the row list */
+ NPPROW *next;
+ /* pointer to next row in the row list */
+};
+
+struct NPPCOL
+{ /* column (variable) */
+ int j;
+ /* reference number assigned to the column, 1 <= j <= ncols */
+ char *name;
+ /* column name (1 to 255 chars); NULL means no name is assigned
+ to the column */
+ char is_int;
+ /* 0 means continuous variable; 1 means integer variable */
+ double lb;
+ /* lower bound; -DBL_MAX means the column has no lower bound */
+ double ub;
+ /* upper bound; +DBL_MAX means the column has no upper bound */
+ double coef;
+ /* objective coefficient */
+ NPPAIJ *ptr;
+ /* pointer to the linked list of constraint coefficients */
+ int temp;
+ /* working field used by preprocessor routines */
+#if 1 /* 28/XII-2009 */
+ union
+ { double ll;
+ /* implied column lower bound */
+ int pos;
+ /* vertex ordinal number corresponding to this binary column
+ in the conflict graph (0, if the vertex does not exist) */
+ } ll;
+ union
+ { double uu;
+ /* implied column upper bound */
+ int neg;
+ /* vertex ordinal number corresponding to complement of this
+ binary column in the conflict graph (0, if the vertex does
+ not exist) */
+ } uu;
+#endif
+ NPPCOL *prev;
+ /* pointer to previous column in the column list */
+ NPPCOL *next;
+ /* pointer to next column in the column list */
+};
+
+struct NPPAIJ
+{ /* constraint coefficient */
+ NPPROW *row;
+ /* pointer to corresponding row */
+ NPPCOL *col;
+ /* pointer to corresponding column */
+ double val;
+ /* (non-zero) coefficient value */
+ NPPAIJ *r_prev;
+ /* pointer to previous coefficient in the same row */
+ NPPAIJ *r_next;
+ /* pointer to next coefficient in the same row */
+ NPPAIJ *c_prev;
+ /* pointer to previous coefficient in the same column */
+ NPPAIJ *c_next;
+ /* pointer to next coefficient in the same column */
+};
+
+struct NPPTSE
+{ /* transformation stack entry */
+ int (*func)(NPP *npp, void *info);
+ /* pointer to routine performing back transformation */
+ void *info;
+ /* pointer to specific info (depends on the transformation) */
+ NPPTSE *link;
+ /* pointer to another entry created *before* this entry */
+};
+
+struct NPPLFE
+{ /* linear form element */
+ int ref;
+ /* row/column reference number */
+ double val;
+ /* (non-zero) coefficient value */
+ NPPLFE *next;
+ /* pointer to another element */
+};
+
+#define npp_create_wksp _glp_npp_create_wksp
+NPP *npp_create_wksp(void);
+/* create LP/MIP preprocessor workspace */
+
+#define npp_insert_row _glp_npp_insert_row
+void npp_insert_row(NPP *npp, NPPROW *row, int where);
+/* insert row to the row list */
+
+#define npp_remove_row _glp_npp_remove_row
+void npp_remove_row(NPP *npp, NPPROW *row);
+/* remove row from the row list */
+
+#define npp_activate_row _glp_npp_activate_row
+void npp_activate_row(NPP *npp, NPPROW *row);
+/* make row active */
+
+#define npp_deactivate_row _glp_npp_deactivate_row
+void npp_deactivate_row(NPP *npp, NPPROW *row);
+/* make row inactive */
+
+#define npp_insert_col _glp_npp_insert_col
+void npp_insert_col(NPP *npp, NPPCOL *col, int where);
+/* insert column to the column list */
+
+#define npp_remove_col _glp_npp_remove_col
+void npp_remove_col(NPP *npp, NPPCOL *col);
+/* remove column from the column list */
+
+#define npp_activate_col _glp_npp_activate_col
+void npp_activate_col(NPP *npp, NPPCOL *col);
+/* make column active */
+
+#define npp_deactivate_col _glp_npp_deactivate_col
+void npp_deactivate_col(NPP *npp, NPPCOL *col);
+/* make column inactive */
+
+#define npp_add_row _glp_npp_add_row
+NPPROW *npp_add_row(NPP *npp);
+/* add new row to the current problem */
+
+#define npp_add_col _glp_npp_add_col
+NPPCOL *npp_add_col(NPP *npp);
+/* add new column to the current problem */
+
+#define npp_add_aij _glp_npp_add_aij
+NPPAIJ *npp_add_aij(NPP *npp, NPPROW *row, NPPCOL *col, double val);
+/* add new element to the constraint matrix */
+
+#define npp_row_nnz _glp_npp_row_nnz
+int npp_row_nnz(NPP *npp, NPPROW *row);
+/* count number of non-zero coefficients in row */
+
+#define npp_col_nnz _glp_npp_col_nnz
+int npp_col_nnz(NPP *npp, NPPCOL *col);
+/* count number of non-zero coefficients in column */
+
+#define npp_push_tse _glp_npp_push_tse
+void *npp_push_tse(NPP *npp, int (*func)(NPP *npp, void *info),
+ int size);
+/* push new entry to the transformation stack */
+
+#define npp_erase_row _glp_npp_erase_row
+void npp_erase_row(NPP *npp, NPPROW *row);
+/* erase row content to make it empty */
+
+#define npp_del_row _glp_npp_del_row
+void npp_del_row(NPP *npp, NPPROW *row);
+/* remove row from the current problem */
+
+#define npp_del_col _glp_npp_del_col
+void npp_del_col(NPP *npp, NPPCOL *col);
+/* remove column from the current problem */
+
+#define npp_del_aij _glp_npp_del_aij
+void npp_del_aij(NPP *npp, NPPAIJ *aij);
+/* remove element from the constraint matrix */
+
+#define npp_load_prob _glp_npp_load_prob
+void npp_load_prob(NPP *npp, glp_prob *orig, int names, int sol,
+ int scaling);
+/* load original problem into the preprocessor workspace */
+
+#define npp_build_prob _glp_npp_build_prob
+void npp_build_prob(NPP *npp, glp_prob *prob);
+/* build resultant (preprocessed) problem */
+
+#define npp_postprocess _glp_npp_postprocess
+void npp_postprocess(NPP *npp, glp_prob *prob);
+/* postprocess solution from the resultant problem */
+
+#define npp_unload_sol _glp_npp_unload_sol
+void npp_unload_sol(NPP *npp, glp_prob *orig);
+/* store solution to the original problem */
+
+#define npp_delete_wksp _glp_npp_delete_wksp
+void npp_delete_wksp(NPP *npp);
+/* delete LP/MIP preprocessor workspace */
+
+#define npp_error()
+
+#define npp_free_row _glp_npp_free_row
+void npp_free_row(NPP *npp, NPPROW *p);
+/* process free (unbounded) row */
+
+#define npp_geq_row _glp_npp_geq_row
+void npp_geq_row(NPP *npp, NPPROW *p);
+/* process row of 'not less than' type */
+
+#define npp_leq_row _glp_npp_leq_row
+void npp_leq_row(NPP *npp, NPPROW *p);
+/* process row of 'not greater than' type */
+
+#define npp_free_col _glp_npp_free_col
+void npp_free_col(NPP *npp, NPPCOL *q);
+/* process free (unbounded) column */
+
+#define npp_lbnd_col _glp_npp_lbnd_col
+void npp_lbnd_col(NPP *npp, NPPCOL *q);
+/* process column with (non-zero) lower bound */
+
+#define npp_ubnd_col _glp_npp_ubnd_col
+void npp_ubnd_col(NPP *npp, NPPCOL *q);
+/* process column with upper bound */
+
+#define npp_dbnd_col _glp_npp_dbnd_col
+void npp_dbnd_col(NPP *npp, NPPCOL *q);
+/* process non-negative column with upper bound */
+
+#define npp_fixed_col _glp_npp_fixed_col
+void npp_fixed_col(NPP *npp, NPPCOL *q);
+/* process fixed column */
+
+#define npp_make_equality _glp_npp_make_equality
+int npp_make_equality(NPP *npp, NPPROW *p);
+/* process row with almost identical bounds */
+
+#define npp_make_fixed _glp_npp_make_fixed
+int npp_make_fixed(NPP *npp, NPPCOL *q);
+/* process column with almost identical bounds */
+
+#define npp_empty_row _glp_npp_empty_row
+int npp_empty_row(NPP *npp, NPPROW *p);
+/* process empty row */
+
+#define npp_empty_col _glp_npp_empty_col
+int npp_empty_col(NPP *npp, NPPCOL *q);
+/* process empty column */
+
+#define npp_implied_value _glp_npp_implied_value
+int npp_implied_value(NPP *npp, NPPCOL *q, double s);
+/* process implied column value */
+
+#define npp_eq_singlet _glp_npp_eq_singlet
+int npp_eq_singlet(NPP *npp, NPPROW *p);
+/* process row singleton (equality constraint) */
+
+#define npp_implied_lower _glp_npp_implied_lower
+int npp_implied_lower(NPP *npp, NPPCOL *q, double l);
+/* process implied column lower bound */
+
+#define npp_implied_upper _glp_npp_implied_upper
+int npp_implied_upper(NPP *npp, NPPCOL *q, double u);
+/* process implied upper bound of column */
+
+#define npp_ineq_singlet _glp_npp_ineq_singlet
+int npp_ineq_singlet(NPP *npp, NPPROW *p);
+/* process row singleton (inequality constraint) */
+
+#define npp_implied_slack _glp_npp_implied_slack
+void npp_implied_slack(NPP *npp, NPPCOL *q);
+/* process column singleton (implied slack variable) */
+
+#define npp_implied_free _glp_npp_implied_free
+int npp_implied_free(NPP *npp, NPPCOL *q);
+/* process column singleton (implied free variable) */
+
+#define npp_eq_doublet _glp_npp_eq_doublet
+NPPCOL *npp_eq_doublet(NPP *npp, NPPROW *p);
+/* process row doubleton (equality constraint) */
+
+#define npp_forcing_row _glp_npp_forcing_row
+int npp_forcing_row(NPP *npp, NPPROW *p, int at);
+/* process forcing row */
+
+#define npp_analyze_row _glp_npp_analyze_row
+int npp_analyze_row(NPP *npp, NPPROW *p);
+/* perform general row analysis */
+
+#define npp_inactive_bound _glp_npp_inactive_bound
+void npp_inactive_bound(NPP *npp, NPPROW *p, int which);
+/* remove row lower/upper inactive bound */
+
+#define npp_implied_bounds _glp_npp_implied_bounds
+void npp_implied_bounds(NPP *npp, NPPROW *p);
+/* determine implied column bounds */
+
+#define npp_binarize_prob _glp_npp_binarize_prob
+int npp_binarize_prob(NPP *npp);
+/* binarize MIP problem */
+
+#define npp_is_packing _glp_npp_is_packing
+int npp_is_packing(NPP *npp, NPPROW *row);
+/* test if constraint is packing inequality */
+
+#define npp_hidden_packing _glp_npp_hidden_packing
+int npp_hidden_packing(NPP *npp, NPPROW *row);
+/* identify hidden packing inequality */
+
+#define npp_implied_packing _glp_npp_implied_packing
+int npp_implied_packing(NPP *npp, NPPROW *row, int which,
+ NPPCOL *var[], char set[]);
+/* identify implied packing inequality */
+
+#define npp_is_covering _glp_npp_is_covering
+int npp_is_covering(NPP *npp, NPPROW *row);
+/* test if constraint is covering inequality */
+
+#define npp_hidden_covering _glp_npp_hidden_covering
+int npp_hidden_covering(NPP *npp, NPPROW *row);
+/* identify hidden covering inequality */
+
+#define npp_is_partitioning _glp_npp_is_partitioning
+int npp_is_partitioning(NPP *npp, NPPROW *row);
+/* test if constraint is partitioning equality */
+
+#define npp_reduce_ineq_coef _glp_npp_reduce_ineq_coef
+int npp_reduce_ineq_coef(NPP *npp, NPPROW *row);
+/* reduce inequality constraint coefficients */
+
+#define npp_clean_prob _glp_npp_clean_prob
+void npp_clean_prob(NPP *npp);
+/* perform initial LP/MIP processing */
+
+#define npp_process_row _glp_npp_process_row
+int npp_process_row(NPP *npp, NPPROW *row, int hard);
+/* perform basic row processing */
+
+#define npp_improve_bounds _glp_npp_improve_bounds
+int npp_improve_bounds(NPP *npp, NPPROW *row, int flag);
+/* improve current column bounds */
+
+#define npp_process_col _glp_npp_process_col
+int npp_process_col(NPP *npp, NPPCOL *col);
+/* perform basic column processing */
+
+#define npp_process_prob _glp_npp_process_prob
+int npp_process_prob(NPP *npp, int hard);
+/* perform basic LP/MIP processing */
+
+#define npp_simplex _glp_npp_simplex
+int npp_simplex(NPP *npp, const glp_smcp *parm);
+/* process LP prior to applying primal/dual simplex method */
+
+#define npp_integer _glp_npp_integer
+int npp_integer(NPP *npp, const glp_iocp *parm);
+/* process MIP prior to applying branch-and-bound method */
+
+/**********************************************************************/
+
+#define npp_sat_free_row _glp_npp_sat_free_row
+void npp_sat_free_row(NPP *npp, NPPROW *p);
+/* process free (unbounded) row */
+
+#define npp_sat_fixed_col _glp_npp_sat_fixed_col
+int npp_sat_fixed_col(NPP *npp, NPPCOL *q);
+/* process fixed column */
+
+#define npp_sat_is_bin_comb _glp_npp_sat_is_bin_comb
+int npp_sat_is_bin_comb(NPP *npp, NPPROW *row);
+/* test if row is binary combination */
+
+#define npp_sat_num_pos_coef _glp_npp_sat_num_pos_coef
+int npp_sat_num_pos_coef(NPP *npp, NPPROW *row);
+/* determine number of positive coefficients */
+
+#define npp_sat_num_neg_coef _glp_npp_sat_num_neg_coef
+int npp_sat_num_neg_coef(NPP *npp, NPPROW *row);
+/* determine number of negative coefficients */
+
+#define npp_sat_is_cover_ineq _glp_npp_sat_is_cover_ineq
+int npp_sat_is_cover_ineq(NPP *npp, NPPROW *row);
+/* test if row is covering inequality */
+
+#define npp_sat_is_pack_ineq _glp_npp_sat_is_pack_ineq
+int npp_sat_is_pack_ineq(NPP *npp, NPPROW *row);
+/* test if row is packing inequality */
+
+#define npp_sat_is_partn_eq _glp_npp_sat_is_partn_eq
+int npp_sat_is_partn_eq(NPP *npp, NPPROW *row);
+/* test if row is partitioning equality */
+
+#define npp_sat_reverse_row _glp_npp_sat_reverse_row
+int npp_sat_reverse_row(NPP *npp, NPPROW *row);
+/* multiply both sides of row by -1 */
+
+#define npp_sat_split_pack _glp_npp_sat_split_pack
+NPPROW *npp_sat_split_pack(NPP *npp, NPPROW *row, int nnn);
+/* split packing inequality */
+
+#define npp_sat_encode_pack _glp_npp_sat_encode_pack
+void npp_sat_encode_pack(NPP *npp, NPPROW *row);
+/* encode packing inequality */
+
+typedef struct NPPLIT NPPLIT;
+typedef struct NPPLSE NPPLSE;
+typedef struct NPPSED NPPSED;
+
+struct NPPLIT
+{ /* literal (binary variable or its negation) */
+ NPPCOL *col;
+ /* pointer to binary variable; NULL means constant false */
+ int neg;
+ /* negation flag:
+ 0 - literal is variable (or constant false)
+ 1 - literal is negation of variable (or constant true) */
+};
+
+struct NPPLSE
+{ /* literal set element */
+ NPPLIT lit;
+ /* literal */
+ NPPLSE *next;
+ /* pointer to another element */
+};
+
+struct NPPSED
+{ /* summation encoding descriptor */
+ /* this struct describes the equality
+ x + y + z = s + 2 * c,
+ which was encoded as CNF and included into the transformed
+ problem; here x and y are literals, z is either a literal or
+ constant zero, s and c are binary variables modeling, resp.,
+ the low and high (carry) sum bits */
+ NPPLIT x, y, z;
+ /* literals; if z.col = NULL, z is constant zero */
+ NPPCOL *s, *c;
+ /* binary variables modeling the sum bits */
+};
+
+#define npp_sat_encode_sum2 _glp_npp_sat_encode_sum2
+void npp_sat_encode_sum2(NPP *npp, NPPLSE *set, NPPSED *sed);
+/* encode 2-bit summation */
+
+#define npp_sat_encode_sum3 _glp_npp_sat_encode_sum3
+void npp_sat_encode_sum3(NPP *npp, NPPLSE *set, NPPSED *sed);
+/* encode 3-bit summation */
+
+#define npp_sat_encode_sum_ax _glp_npp_sat_encode_sum_ax
+int npp_sat_encode_sum_ax(NPP *npp, NPPROW *row, NPPLIT y[]);
+/* encode linear combination of 0-1 variables */
+
+#define npp_sat_normalize_clause _glp_npp_sat_normalize_clause
+int npp_sat_normalize_clause(NPP *npp, int size, NPPLIT lit[]);
+/* normalize clause */
+
+#define npp_sat_encode_clause _glp_npp_sat_encode_clause
+NPPROW *npp_sat_encode_clause(NPP *npp, int size, NPPLIT lit[]);
+/* translate clause to cover inequality */
+
+#define npp_sat_encode_geq _glp_npp_sat_encode_geq
+int npp_sat_encode_geq(NPP *npp, int n, NPPLIT y[], int rhs);
+/* encode "not less than" constraint */
+
+#define npp_sat_encode_leq _glp_npp_sat_encode_leq
+int npp_sat_encode_leq(NPP *npp, int n, NPPLIT y[], int rhs);
+/* encode "not greater than" constraint */
+
+#define npp_sat_encode_row _glp_npp_sat_encode_row
+int npp_sat_encode_row(NPP *npp, NPPROW *row);
+/* encode constraint (row) of general type */
+
+#define npp_sat_encode_prob _glp_npp_sat_encode_prob
+int npp_sat_encode_prob(NPP *npp);
+/* encode 0-1 feasibility problem */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp1.c b/test/monniaux/glpk-4.65/src/npp/npp1.c
new file mode 100644
index 00000000..51758bad
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp1.c
@@ -0,0 +1,937 @@
+/* npp1.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+NPP *npp_create_wksp(void)
+{ /* create LP/MIP preprocessor workspace */
+ NPP *npp;
+ npp = xmalloc(sizeof(NPP));
+ npp->orig_dir = 0;
+ npp->orig_m = npp->orig_n = npp->orig_nnz = 0;
+ npp->pool = dmp_create_pool();
+ npp->name = npp->obj = NULL;
+ npp->c0 = 0.0;
+ npp->nrows = npp->ncols = 0;
+ npp->r_head = npp->r_tail = NULL;
+ npp->c_head = npp->c_tail = NULL;
+ npp->stack = dmp_create_pool();
+ npp->top = NULL;
+#if 0 /* 16/XII-2009 */
+ memset(&npp->count, 0, sizeof(npp->count));
+#endif
+ npp->m = npp->n = npp->nnz = 0;
+ npp->row_ref = npp->col_ref = NULL;
+ npp->sol = npp->scaling = 0;
+ npp->p_stat = npp->d_stat = npp->t_stat = npp->i_stat = 0;
+ npp->r_stat = NULL;
+ /*npp->r_prim =*/ npp->r_pi = NULL;
+ npp->c_stat = NULL;
+ npp->c_value = /*npp->c_dual =*/ NULL;
+ return npp;
+}
+
+void npp_insert_row(NPP *npp, NPPROW *row, int where)
+{ /* insert row to the row list */
+ if (where == 0)
+ { /* insert row to the beginning of the row list */
+ row->prev = NULL;
+ row->next = npp->r_head;
+ if (row->next == NULL)
+ npp->r_tail = row;
+ else
+ row->next->prev = row;
+ npp->r_head = row;
+ }
+ else
+ { /* insert row to the end of the row list */
+ row->prev = npp->r_tail;
+ row->next = NULL;
+ if (row->prev == NULL)
+ npp->r_head = row;
+ else
+ row->prev->next = row;
+ npp->r_tail = row;
+ }
+ return;
+}
+
+void npp_remove_row(NPP *npp, NPPROW *row)
+{ /* remove row from the row list */
+ if (row->prev == NULL)
+ npp->r_head = row->next;
+ else
+ row->prev->next = row->next;
+ if (row->next == NULL)
+ npp->r_tail = row->prev;
+ else
+ row->next->prev = row->prev;
+ return;
+}
+
+void npp_activate_row(NPP *npp, NPPROW *row)
+{ /* make row active */
+ if (!row->temp)
+ { row->temp = 1;
+ /* move the row to the beginning of the row list */
+ npp_remove_row(npp, row);
+ npp_insert_row(npp, row, 0);
+ }
+ return;
+}
+
+void npp_deactivate_row(NPP *npp, NPPROW *row)
+{ /* make row inactive */
+ if (row->temp)
+ { row->temp = 0;
+ /* move the row to the end of the row list */
+ npp_remove_row(npp, row);
+ npp_insert_row(npp, row, 1);
+ }
+ return;
+}
+
+void npp_insert_col(NPP *npp, NPPCOL *col, int where)
+{ /* insert column to the column list */
+ if (where == 0)
+ { /* insert column to the beginning of the column list */
+ col->prev = NULL;
+ col->next = npp->c_head;
+ if (col->next == NULL)
+ npp->c_tail = col;
+ else
+ col->next->prev = col;
+ npp->c_head = col;
+ }
+ else
+ { /* insert column to the end of the column list */
+ col->prev = npp->c_tail;
+ col->next = NULL;
+ if (col->prev == NULL)
+ npp->c_head = col;
+ else
+ col->prev->next = col;
+ npp->c_tail = col;
+ }
+ return;
+}
+
+void npp_remove_col(NPP *npp, NPPCOL *col)
+{ /* remove column from the column list */
+ if (col->prev == NULL)
+ npp->c_head = col->next;
+ else
+ col->prev->next = col->next;
+ if (col->next == NULL)
+ npp->c_tail = col->prev;
+ else
+ col->next->prev = col->prev;
+ return;
+}
+
+void npp_activate_col(NPP *npp, NPPCOL *col)
+{ /* make column active */
+ if (!col->temp)
+ { col->temp = 1;
+ /* move the column to the beginning of the column list */
+ npp_remove_col(npp, col);
+ npp_insert_col(npp, col, 0);
+ }
+ return;
+}
+
+void npp_deactivate_col(NPP *npp, NPPCOL *col)
+{ /* make column inactive */
+ if (col->temp)
+ { col->temp = 0;
+ /* move the column to the end of the column list */
+ npp_remove_col(npp, col);
+ npp_insert_col(npp, col, 1);
+ }
+ return;
+}
+
+NPPROW *npp_add_row(NPP *npp)
+{ /* add new row to the current problem */
+ NPPROW *row;
+ row = dmp_get_atom(npp->pool, sizeof(NPPROW));
+ row->i = ++(npp->nrows);
+ row->name = NULL;
+ row->lb = -DBL_MAX, row->ub = +DBL_MAX;
+ row->ptr = NULL;
+ row->temp = 0;
+ npp_insert_row(npp, row, 1);
+ return row;
+}
+
+NPPCOL *npp_add_col(NPP *npp)
+{ /* add new column to the current problem */
+ NPPCOL *col;
+ col = dmp_get_atom(npp->pool, sizeof(NPPCOL));
+ col->j = ++(npp->ncols);
+ col->name = NULL;
+#if 0
+ col->kind = GLP_CV;
+#else
+ col->is_int = 0;
+#endif
+ col->lb = col->ub = col->coef = 0.0;
+ col->ptr = NULL;
+ col->temp = 0;
+ npp_insert_col(npp, col, 1);
+ return col;
+}
+
+NPPAIJ *npp_add_aij(NPP *npp, NPPROW *row, NPPCOL *col, double val)
+{ /* add new element to the constraint matrix */
+ NPPAIJ *aij;
+ aij = dmp_get_atom(npp->pool, sizeof(NPPAIJ));
+ aij->row = row;
+ aij->col = col;
+ aij->val = val;
+ aij->r_prev = NULL;
+ aij->r_next = row->ptr;
+ aij->c_prev = NULL;
+ aij->c_next = col->ptr;
+ if (aij->r_next != NULL)
+ aij->r_next->r_prev = aij;
+ if (aij->c_next != NULL)
+ aij->c_next->c_prev = aij;
+ row->ptr = col->ptr = aij;
+ return aij;
+}
+
+int npp_row_nnz(NPP *npp, NPPROW *row)
+{ /* count number of non-zero coefficients in row */
+ NPPAIJ *aij;
+ int nnz;
+ xassert(npp == npp);
+ nnz = 0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ nnz++;
+ return nnz;
+}
+
+int npp_col_nnz(NPP *npp, NPPCOL *col)
+{ /* count number of non-zero coefficients in column */
+ NPPAIJ *aij;
+ int nnz;
+ xassert(npp == npp);
+ nnz = 0;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ nnz++;
+ return nnz;
+}
+
+void *npp_push_tse(NPP *npp, int (*func)(NPP *npp, void *info),
+ int size)
+{ /* push new entry to the transformation stack */
+ NPPTSE *tse;
+ tse = dmp_get_atom(npp->stack, sizeof(NPPTSE));
+ tse->func = func;
+ tse->info = dmp_get_atom(npp->stack, size);
+ tse->link = npp->top;
+ npp->top = tse;
+ return tse->info;
+}
+
+#if 1 /* 23/XII-2009 */
+void npp_erase_row(NPP *npp, NPPROW *row)
+{ /* erase row content to make it empty */
+ NPPAIJ *aij;
+ while (row->ptr != NULL)
+ { aij = row->ptr;
+ row->ptr = aij->r_next;
+ if (aij->c_prev == NULL)
+ aij->col->ptr = aij->c_next;
+ else
+ aij->c_prev->c_next = aij->c_next;
+ if (aij->c_next == NULL)
+ ;
+ else
+ aij->c_next->c_prev = aij->c_prev;
+ dmp_free_atom(npp->pool, aij, sizeof(NPPAIJ));
+ }
+ return;
+}
+#endif
+
+void npp_del_row(NPP *npp, NPPROW *row)
+{ /* remove row from the current problem */
+#if 0 /* 23/XII-2009 */
+ NPPAIJ *aij;
+#endif
+ if (row->name != NULL)
+ dmp_free_atom(npp->pool, row->name, strlen(row->name)+1);
+#if 0 /* 23/XII-2009 */
+ while (row->ptr != NULL)
+ { aij = row->ptr;
+ row->ptr = aij->r_next;
+ if (aij->c_prev == NULL)
+ aij->col->ptr = aij->c_next;
+ else
+ aij->c_prev->c_next = aij->c_next;
+ if (aij->c_next == NULL)
+ ;
+ else
+ aij->c_next->c_prev = aij->c_prev;
+ dmp_free_atom(npp->pool, aij, sizeof(NPPAIJ));
+ }
+#else
+ npp_erase_row(npp, row);
+#endif
+ npp_remove_row(npp, row);
+ dmp_free_atom(npp->pool, row, sizeof(NPPROW));
+ return;
+}
+
+void npp_del_col(NPP *npp, NPPCOL *col)
+{ /* remove column from the current problem */
+ NPPAIJ *aij;
+ if (col->name != NULL)
+ dmp_free_atom(npp->pool, col->name, strlen(col->name)+1);
+ while (col->ptr != NULL)
+ { aij = col->ptr;
+ col->ptr = aij->c_next;
+ if (aij->r_prev == NULL)
+ aij->row->ptr = aij->r_next;
+ else
+ aij->r_prev->r_next = aij->r_next;
+ if (aij->r_next == NULL)
+ ;
+ else
+ aij->r_next->r_prev = aij->r_prev;
+ dmp_free_atom(npp->pool, aij, sizeof(NPPAIJ));
+ }
+ npp_remove_col(npp, col);
+ dmp_free_atom(npp->pool, col, sizeof(NPPCOL));
+ return;
+}
+
+void npp_del_aij(NPP *npp, NPPAIJ *aij)
+{ /* remove element from the constraint matrix */
+ if (aij->r_prev == NULL)
+ aij->row->ptr = aij->r_next;
+ else
+ aij->r_prev->r_next = aij->r_next;
+ if (aij->r_next == NULL)
+ ;
+ else
+ aij->r_next->r_prev = aij->r_prev;
+ if (aij->c_prev == NULL)
+ aij->col->ptr = aij->c_next;
+ else
+ aij->c_prev->c_next = aij->c_next;
+ if (aij->c_next == NULL)
+ ;
+ else
+ aij->c_next->c_prev = aij->c_prev;
+ dmp_free_atom(npp->pool, aij, sizeof(NPPAIJ));
+ return;
+}
+
+void npp_load_prob(NPP *npp, glp_prob *orig, int names, int sol,
+ int scaling)
+{ /* load original problem into the preprocessor workspace */
+ int m = orig->m;
+ int n = orig->n;
+ NPPROW **link;
+ int i, j;
+ double dir;
+ xassert(names == GLP_OFF || names == GLP_ON);
+ xassert(sol == GLP_SOL || sol == GLP_IPT || sol == GLP_MIP);
+ xassert(scaling == GLP_OFF || scaling == GLP_ON);
+ if (sol == GLP_MIP) xassert(!scaling);
+ npp->orig_dir = orig->dir;
+ if (npp->orig_dir == GLP_MIN)
+ dir = +1.0;
+ else if (npp->orig_dir == GLP_MAX)
+ dir = -1.0;
+ else
+ xassert(npp != npp);
+ npp->orig_m = m;
+ npp->orig_n = n;
+ npp->orig_nnz = orig->nnz;
+ if (names && orig->name != NULL)
+ { npp->name = dmp_get_atom(npp->pool, strlen(orig->name)+1);
+ strcpy(npp->name, orig->name);
+ }
+ if (names && orig->obj != NULL)
+ { npp->obj = dmp_get_atom(npp->pool, strlen(orig->obj)+1);
+ strcpy(npp->obj, orig->obj);
+ }
+ npp->c0 = dir * orig->c0;
+ /* load rows */
+ link = xcalloc(1+m, sizeof(NPPROW *));
+ for (i = 1; i <= m; i++)
+ { GLPROW *rrr = orig->row[i];
+ NPPROW *row;
+ link[i] = row = npp_add_row(npp);
+ xassert(row->i == i);
+ if (names && rrr->name != NULL)
+ { row->name = dmp_get_atom(npp->pool, strlen(rrr->name)+1);
+ strcpy(row->name, rrr->name);
+ }
+ if (!scaling)
+ { if (rrr->type == GLP_FR)
+ row->lb = -DBL_MAX, row->ub = +DBL_MAX;
+ else if (rrr->type == GLP_LO)
+ row->lb = rrr->lb, row->ub = +DBL_MAX;
+ else if (rrr->type == GLP_UP)
+ row->lb = -DBL_MAX, row->ub = rrr->ub;
+ else if (rrr->type == GLP_DB)
+ row->lb = rrr->lb, row->ub = rrr->ub;
+ else if (rrr->type == GLP_FX)
+ row->lb = row->ub = rrr->lb;
+ else
+ xassert(rrr != rrr);
+ }
+ else
+ { double rii = rrr->rii;
+ if (rrr->type == GLP_FR)
+ row->lb = -DBL_MAX, row->ub = +DBL_MAX;
+ else if (rrr->type == GLP_LO)
+ row->lb = rrr->lb * rii, row->ub = +DBL_MAX;
+ else if (rrr->type == GLP_UP)
+ row->lb = -DBL_MAX, row->ub = rrr->ub * rii;
+ else if (rrr->type == GLP_DB)
+ row->lb = rrr->lb * rii, row->ub = rrr->ub * rii;
+ else if (rrr->type == GLP_FX)
+ row->lb = row->ub = rrr->lb * rii;
+ else
+ xassert(rrr != rrr);
+ }
+ }
+ /* load columns and constraint coefficients */
+ for (j = 1; j <= n; j++)
+ { GLPCOL *ccc = orig->col[j];
+ GLPAIJ *aaa;
+ NPPCOL *col;
+ col = npp_add_col(npp);
+ xassert(col->j == j);
+ if (names && ccc->name != NULL)
+ { col->name = dmp_get_atom(npp->pool, strlen(ccc->name)+1);
+ strcpy(col->name, ccc->name);
+ }
+ if (sol == GLP_MIP)
+#if 0
+ col->kind = ccc->kind;
+#else
+ col->is_int = (char)(ccc->kind == GLP_IV);
+#endif
+ if (!scaling)
+ { if (ccc->type == GLP_FR)
+ col->lb = -DBL_MAX, col->ub = +DBL_MAX;
+ else if (ccc->type == GLP_LO)
+ col->lb = ccc->lb, col->ub = +DBL_MAX;
+ else if (ccc->type == GLP_UP)
+ col->lb = -DBL_MAX, col->ub = ccc->ub;
+ else if (ccc->type == GLP_DB)
+ col->lb = ccc->lb, col->ub = ccc->ub;
+ else if (ccc->type == GLP_FX)
+ col->lb = col->ub = ccc->lb;
+ else
+ xassert(ccc != ccc);
+ col->coef = dir * ccc->coef;
+ for (aaa = ccc->ptr; aaa != NULL; aaa = aaa->c_next)
+ npp_add_aij(npp, link[aaa->row->i], col, aaa->val);
+ }
+ else
+ { double sjj = ccc->sjj;
+ if (ccc->type == GLP_FR)
+ col->lb = -DBL_MAX, col->ub = +DBL_MAX;
+ else if (ccc->type == GLP_LO)
+ col->lb = ccc->lb / sjj, col->ub = +DBL_MAX;
+ else if (ccc->type == GLP_UP)
+ col->lb = -DBL_MAX, col->ub = ccc->ub / sjj;
+ else if (ccc->type == GLP_DB)
+ col->lb = ccc->lb / sjj, col->ub = ccc->ub / sjj;
+ else if (ccc->type == GLP_FX)
+ col->lb = col->ub = ccc->lb / sjj;
+ else
+ xassert(ccc != ccc);
+ col->coef = dir * ccc->coef * sjj;
+ for (aaa = ccc->ptr; aaa != NULL; aaa = aaa->c_next)
+ npp_add_aij(npp, link[aaa->row->i], col,
+ aaa->row->rii * aaa->val * sjj);
+ }
+ }
+ xfree(link);
+ /* keep solution indicator and scaling option */
+ npp->sol = sol;
+ npp->scaling = scaling;
+ return;
+}
+
+void npp_build_prob(NPP *npp, glp_prob *prob)
+{ /* build resultant (preprocessed) problem */
+ NPPROW *row;
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int i, j, type, len, *ind;
+ double dir, *val;
+ glp_erase_prob(prob);
+ glp_set_prob_name(prob, npp->name);
+ glp_set_obj_name(prob, npp->obj);
+ glp_set_obj_dir(prob, npp->orig_dir);
+ if (npp->orig_dir == GLP_MIN)
+ dir = +1.0;
+ else if (npp->orig_dir == GLP_MAX)
+ dir = -1.0;
+ else
+ xassert(npp != npp);
+ glp_set_obj_coef(prob, 0, dir * npp->c0);
+ /* build rows */
+ for (row = npp->r_head; row != NULL; row = row->next)
+ { row->temp = i = glp_add_rows(prob, 1);
+ glp_set_row_name(prob, i, row->name);
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ type = GLP_FR;
+ else if (row->ub == +DBL_MAX)
+ type = GLP_LO;
+ else if (row->lb == -DBL_MAX)
+ type = GLP_UP;
+ else if (row->lb != row->ub)
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_row_bnds(prob, i, type, row->lb, row->ub);
+ }
+ /* build columns and the constraint matrix */
+ ind = xcalloc(1+prob->m, sizeof(int));
+ val = xcalloc(1+prob->m, sizeof(double));
+ for (col = npp->c_head; col != NULL; col = col->next)
+ { j = glp_add_cols(prob, 1);
+ glp_set_col_name(prob, j, col->name);
+#if 0
+ glp_set_col_kind(prob, j, col->kind);
+#else
+ glp_set_col_kind(prob, j, col->is_int ? GLP_IV : GLP_CV);
+#endif
+ if (col->lb == -DBL_MAX && col->ub == +DBL_MAX)
+ type = GLP_FR;
+ else if (col->ub == +DBL_MAX)
+ type = GLP_LO;
+ else if (col->lb == -DBL_MAX)
+ type = GLP_UP;
+ else if (col->lb != col->ub)
+ type = GLP_DB;
+ else
+ type = GLP_FX;
+ glp_set_col_bnds(prob, j, type, col->lb, col->ub);
+ glp_set_obj_coef(prob, j, dir * col->coef);
+ len = 0;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ { len++;
+ ind[len] = aij->row->temp;
+ val[len] = aij->val;
+ }
+ glp_set_mat_col(prob, j, len, ind, val);
+ }
+ xfree(ind);
+ xfree(val);
+ /* resultant problem has been built */
+ npp->m = prob->m;
+ npp->n = prob->n;
+ npp->nnz = prob->nnz;
+ npp->row_ref = xcalloc(1+npp->m, sizeof(int));
+ npp->col_ref = xcalloc(1+npp->n, sizeof(int));
+ for (row = npp->r_head, i = 0; row != NULL; row = row->next)
+ npp->row_ref[++i] = row->i;
+ for (col = npp->c_head, j = 0; col != NULL; col = col->next)
+ npp->col_ref[++j] = col->j;
+ /* transformed problem segment is no longer needed */
+ dmp_delete_pool(npp->pool), npp->pool = NULL;
+ npp->name = npp->obj = NULL;
+ npp->c0 = 0.0;
+ npp->r_head = npp->r_tail = NULL;
+ npp->c_head = npp->c_tail = NULL;
+ return;
+}
+
+void npp_postprocess(NPP *npp, glp_prob *prob)
+{ /* postprocess solution from the resultant problem */
+ GLPROW *row;
+ GLPCOL *col;
+ NPPTSE *tse;
+ int i, j, k;
+ double dir;
+ xassert(npp->orig_dir == prob->dir);
+ if (npp->orig_dir == GLP_MIN)
+ dir = +1.0;
+ else if (npp->orig_dir == GLP_MAX)
+ dir = -1.0;
+ else
+ xassert(npp != npp);
+#if 0 /* 11/VII-2013; due to call from ios_main */
+ xassert(npp->m == prob->m);
+#else
+ if (npp->sol != GLP_MIP)
+ xassert(npp->m == prob->m);
+#endif
+ xassert(npp->n == prob->n);
+#if 0 /* 11/VII-2013; due to call from ios_main */
+ xassert(npp->nnz == prob->nnz);
+#else
+ if (npp->sol != GLP_MIP)
+ xassert(npp->nnz == prob->nnz);
+#endif
+ /* copy solution status */
+ if (npp->sol == GLP_SOL)
+ { npp->p_stat = prob->pbs_stat;
+ npp->d_stat = prob->dbs_stat;
+ }
+ else if (npp->sol == GLP_IPT)
+ npp->t_stat = prob->ipt_stat;
+ else if (npp->sol == GLP_MIP)
+ npp->i_stat = prob->mip_stat;
+ else
+ xassert(npp != npp);
+ /* allocate solution arrays */
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat == NULL)
+ npp->r_stat = xcalloc(1+npp->nrows, sizeof(char));
+ for (i = 1; i <= npp->nrows; i++)
+ npp->r_stat[i] = 0;
+ if (npp->c_stat == NULL)
+ npp->c_stat = xcalloc(1+npp->ncols, sizeof(char));
+ for (j = 1; j <= npp->ncols; j++)
+ npp->c_stat[j] = 0;
+ }
+#if 0
+ if (npp->r_prim == NULL)
+ npp->r_prim = xcalloc(1+npp->nrows, sizeof(double));
+ for (i = 1; i <= npp->nrows; i++)
+ npp->r_prim[i] = DBL_MAX;
+#endif
+ if (npp->c_value == NULL)
+ npp->c_value = xcalloc(1+npp->ncols, sizeof(double));
+ for (j = 1; j <= npp->ncols; j++)
+ npp->c_value[j] = DBL_MAX;
+ if (npp->sol != GLP_MIP)
+ { if (npp->r_pi == NULL)
+ npp->r_pi = xcalloc(1+npp->nrows, sizeof(double));
+ for (i = 1; i <= npp->nrows; i++)
+ npp->r_pi[i] = DBL_MAX;
+#if 0
+ if (npp->c_dual == NULL)
+ npp->c_dual = xcalloc(1+npp->ncols, sizeof(double));
+ for (j = 1; j <= npp->ncols; j++)
+ npp->c_dual[j] = DBL_MAX;
+#endif
+ }
+ /* copy solution components from the resultant problem */
+ if (npp->sol == GLP_SOL)
+ { for (i = 1; i <= npp->m; i++)
+ { row = prob->row[i];
+ k = npp->row_ref[i];
+ npp->r_stat[k] = (char)row->stat;
+ /*npp->r_prim[k] = row->prim;*/
+ npp->r_pi[k] = dir * row->dual;
+ }
+ for (j = 1; j <= npp->n; j++)
+ { col = prob->col[j];
+ k = npp->col_ref[j];
+ npp->c_stat[k] = (char)col->stat;
+ npp->c_value[k] = col->prim;
+ /*npp->c_dual[k] = dir * col->dual;*/
+ }
+ }
+ else if (npp->sol == GLP_IPT)
+ { for (i = 1; i <= npp->m; i++)
+ { row = prob->row[i];
+ k = npp->row_ref[i];
+ /*npp->r_prim[k] = row->pval;*/
+ npp->r_pi[k] = dir * row->dval;
+ }
+ for (j = 1; j <= npp->n; j++)
+ { col = prob->col[j];
+ k = npp->col_ref[j];
+ npp->c_value[k] = col->pval;
+ /*npp->c_dual[k] = dir * col->dval;*/
+ }
+ }
+ else if (npp->sol == GLP_MIP)
+ {
+#if 0
+ for (i = 1; i <= npp->m; i++)
+ { row = prob->row[i];
+ k = npp->row_ref[i];
+ /*npp->r_prim[k] = row->mipx;*/
+ }
+#endif
+ for (j = 1; j <= npp->n; j++)
+ { col = prob->col[j];
+ k = npp->col_ref[j];
+ npp->c_value[k] = col->mipx;
+ }
+ }
+ else
+ xassert(npp != npp);
+ /* perform postprocessing to construct solution to the original
+ problem */
+ for (tse = npp->top; tse != NULL; tse = tse->link)
+ { xassert(tse->func != NULL);
+ xassert(tse->func(npp, tse->info) == 0);
+ }
+ return;
+}
+
+void npp_unload_sol(NPP *npp, glp_prob *orig)
+{ /* store solution to the original problem */
+ GLPROW *row;
+ GLPCOL *col;
+ int i, j;
+ double dir;
+ xassert(npp->orig_dir == orig->dir);
+ if (npp->orig_dir == GLP_MIN)
+ dir = +1.0;
+ else if (npp->orig_dir == GLP_MAX)
+ dir = -1.0;
+ else
+ xassert(npp != npp);
+ xassert(npp->orig_m == orig->m);
+ xassert(npp->orig_n == orig->n);
+ xassert(npp->orig_nnz == orig->nnz);
+ if (npp->sol == GLP_SOL)
+ { /* store basic solution */
+ orig->valid = 0;
+ orig->pbs_stat = npp->p_stat;
+ orig->dbs_stat = npp->d_stat;
+ orig->obj_val = orig->c0;
+ orig->some = 0;
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ row->stat = npp->r_stat[i];
+ if (!npp->scaling)
+ { /*row->prim = npp->r_prim[i];*/
+ row->dual = dir * npp->r_pi[i];
+ }
+ else
+ { /*row->prim = npp->r_prim[i] / row->rii;*/
+ row->dual = dir * npp->r_pi[i] * row->rii;
+ }
+ if (row->stat == GLP_BS)
+ row->dual = 0.0;
+ else if (row->stat == GLP_NL)
+ { xassert(row->type == GLP_LO || row->type == GLP_DB);
+ row->prim = row->lb;
+ }
+ else if (row->stat == GLP_NU)
+ { xassert(row->type == GLP_UP || row->type == GLP_DB);
+ row->prim = row->ub;
+ }
+ else if (row->stat == GLP_NF)
+ { xassert(row->type == GLP_FR);
+ row->prim = 0.0;
+ }
+ else if (row->stat == GLP_NS)
+ { xassert(row->type == GLP_FX);
+ row->prim = row->lb;
+ }
+ else
+ xassert(row != row);
+ }
+ for (j = 1; j <= orig->n; j++)
+ { col = orig->col[j];
+ col->stat = npp->c_stat[j];
+ if (!npp->scaling)
+ { col->prim = npp->c_value[j];
+ /*col->dual = dir * npp->c_dual[j];*/
+ }
+ else
+ { col->prim = npp->c_value[j] * col->sjj;
+ /*col->dual = dir * npp->c_dual[j] / col->sjj;*/
+ }
+ if (col->stat == GLP_BS)
+ col->dual = 0.0;
+#if 1
+ else if (col->stat == GLP_NL)
+ { xassert(col->type == GLP_LO || col->type == GLP_DB);
+ col->prim = col->lb;
+ }
+ else if (col->stat == GLP_NU)
+ { xassert(col->type == GLP_UP || col->type == GLP_DB);
+ col->prim = col->ub;
+ }
+ else if (col->stat == GLP_NF)
+ { xassert(col->type == GLP_FR);
+ col->prim = 0.0;
+ }
+ else if (col->stat == GLP_NS)
+ { xassert(col->type == GLP_FX);
+ col->prim = col->lb;
+ }
+ else
+ xassert(col != col);
+#endif
+ orig->obj_val += col->coef * col->prim;
+ }
+#if 1
+ /* compute primal values of inactive rows */
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ if (row->stat == GLP_BS)
+ { GLPAIJ *aij;
+ double temp;
+ temp = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ temp += aij->val * aij->col->prim;
+ row->prim = temp;
+ }
+ }
+ /* compute reduced costs of active columns */
+ for (j = 1; j <= orig->n; j++)
+ { col = orig->col[j];
+ if (col->stat != GLP_BS)
+ { GLPAIJ *aij;
+ double temp;
+ temp = col->coef;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ temp -= aij->val * aij->row->dual;
+ col->dual = temp;
+ }
+ }
+#endif
+ }
+ else if (npp->sol == GLP_IPT)
+ { /* store interior-point solution */
+ orig->ipt_stat = npp->t_stat;
+ orig->ipt_obj = orig->c0;
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ if (!npp->scaling)
+ { /*row->pval = npp->r_prim[i];*/
+ row->dval = dir * npp->r_pi[i];
+ }
+ else
+ { /*row->pval = npp->r_prim[i] / row->rii;*/
+ row->dval = dir * npp->r_pi[i] * row->rii;
+ }
+ }
+ for (j = 1; j <= orig->n; j++)
+ { col = orig->col[j];
+ if (!npp->scaling)
+ { col->pval = npp->c_value[j];
+ /*col->dval = dir * npp->c_dual[j];*/
+ }
+ else
+ { col->pval = npp->c_value[j] * col->sjj;
+ /*col->dval = dir * npp->c_dual[j] / col->sjj;*/
+ }
+ orig->ipt_obj += col->coef * col->pval;
+ }
+#if 1
+ /* compute row primal values */
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ { GLPAIJ *aij;
+ double temp;
+ temp = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ temp += aij->val * aij->col->pval;
+ row->pval = temp;
+ }
+ }
+ /* compute column dual values */
+ for (j = 1; j <= orig->n; j++)
+ { col = orig->col[j];
+ { GLPAIJ *aij;
+ double temp;
+ temp = col->coef;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ temp -= aij->val * aij->row->dval;
+ col->dval = temp;
+ }
+ }
+#endif
+ }
+ else if (npp->sol == GLP_MIP)
+ { /* store MIP solution */
+ xassert(!npp->scaling);
+ orig->mip_stat = npp->i_stat;
+ orig->mip_obj = orig->c0;
+#if 0
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ /*row->mipx = npp->r_prim[i];*/
+ }
+#endif
+ for (j = 1; j <= orig->n; j++)
+ { col = orig->col[j];
+ col->mipx = npp->c_value[j];
+ if (col->kind == GLP_IV)
+ xassert(col->mipx == floor(col->mipx));
+ orig->mip_obj += col->coef * col->mipx;
+ }
+#if 1
+ /* compute row primal values */
+ for (i = 1; i <= orig->m; i++)
+ { row = orig->row[i];
+ { GLPAIJ *aij;
+ double temp;
+ temp = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ temp += aij->val * aij->col->mipx;
+ row->mipx = temp;
+ }
+ }
+#endif
+ }
+ else
+ xassert(npp != npp);
+ return;
+}
+
+void npp_delete_wksp(NPP *npp)
+{ /* delete LP/MIP preprocessor workspace */
+ if (npp->pool != NULL)
+ dmp_delete_pool(npp->pool);
+ if (npp->stack != NULL)
+ dmp_delete_pool(npp->stack);
+ if (npp->row_ref != NULL)
+ xfree(npp->row_ref);
+ if (npp->col_ref != NULL)
+ xfree(npp->col_ref);
+ if (npp->r_stat != NULL)
+ xfree(npp->r_stat);
+#if 0
+ if (npp->r_prim != NULL)
+ xfree(npp->r_prim);
+#endif
+ if (npp->r_pi != NULL)
+ xfree(npp->r_pi);
+ if (npp->c_stat != NULL)
+ xfree(npp->c_stat);
+ if (npp->c_value != NULL)
+ xfree(npp->c_value);
+#if 0
+ if (npp->c_dual != NULL)
+ xfree(npp->c_dual);
+#endif
+ xfree(npp);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp2.c b/test/monniaux/glpk-4.65/src/npp/npp2.c
new file mode 100644
index 00000000..4efcf1d1
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp2.c
@@ -0,0 +1,1433 @@
+/* npp2.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* npp_free_row - process free (unbounded) row
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_free_row(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_free_row processes row p, which is free (i.e. has
+* no finite bounds):
+*
+* -inf < sum a[p,j] x[j] < +inf. (1)
+* j
+*
+* PROBLEM TRANSFORMATION
+*
+* Constraint (1) cannot be active, so it is redundant and can be
+* removed from the original problem.
+*
+* Removing row p leads to removing a column of multiplier pi[p] for
+* this row in the dual system. Since row p has no bounds, pi[p] = 0,
+* so removing the column does not affect the dual solution.
+*
+* RECOVERING BASIC SOLUTION
+*
+* In solution to the original problem row p is inactive constraint,
+* so it is assigned status GLP_BS, and multiplier pi[p] is assigned
+* zero value.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* In solution to the original problem row p is inactive constraint,
+* so its multiplier pi[p] is assigned zero value.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct free_row
+{ /* free (unbounded) row */
+ int p;
+ /* row reference number */
+};
+
+static int rcv_free_row(NPP *npp, void *info);
+
+void npp_free_row(NPP *npp, NPPROW *p)
+{ /* process free (unbounded) row */
+ struct free_row *info;
+ /* the row must be free */
+ xassert(p->lb == -DBL_MAX && p->ub == +DBL_MAX);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_free_row, sizeof(struct free_row));
+ info->p = p->i;
+ /* remove the row from the problem */
+ npp_del_row(npp, p);
+ return;
+}
+
+static int rcv_free_row(NPP *npp, void *_info)
+{ /* recover free (unbounded) row */
+ struct free_row *info = _info;
+ if (npp->sol == GLP_SOL)
+ npp->r_stat[info->p] = GLP_BS;
+ if (npp->sol != GLP_MIP)
+ npp->r_pi[info->p] = 0.0;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_geq_row - process row of 'not less than' type
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_geq_row(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_geq_row processes row p, which is 'not less than'
+* inequality constraint:
+*
+* L[p] <= sum a[p,j] x[j] (<= U[p]), (1)
+* j
+*
+* where L[p] < U[p], and upper bound may not exist (U[p] = +oo).
+*
+* PROBLEM TRANSFORMATION
+*
+* Constraint (1) can be replaced by equality constraint:
+*
+* sum a[p,j] x[j] - s = L[p], (2)
+* j
+*
+* where
+*
+* 0 <= s (<= U[p] - L[p]) (3)
+*
+* is a non-negative surplus variable.
+*
+* Since in the primal system there appears column s having the only
+* non-zero coefficient in row p, in the dual system there appears a
+* new row:
+*
+* (-1) pi[p] + lambda = 0, (4)
+*
+* where (-1) is coefficient of column s in row p, pi[p] is multiplier
+* of row p, lambda is multiplier of column q, 0 is coefficient of
+* column s in the objective row.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of row p in solution to the original problem is determined
+* by its status and status of column q in solution to the transformed
+* problem as follows:
+*
+* +--------------------------------------+------------------+
+* | Transformed problem | Original problem |
+* +-----------------+--------------------+------------------+
+* | Status of row p | Status of column s | Status of row p |
+* +-----------------+--------------------+------------------+
+* | GLP_BS | GLP_BS | N/A |
+* | GLP_BS | GLP_NL | GLP_BS |
+* | GLP_BS | GLP_NU | GLP_BS |
+* | GLP_NS | GLP_BS | GLP_BS |
+* | GLP_NS | GLP_NL | GLP_NL |
+* | GLP_NS | GLP_NU | GLP_NU |
+* +-----------------+--------------------+------------------+
+*
+* Value of row multiplier pi[p] in solution to the original problem
+* is the same as in solution to the transformed problem.
+*
+* 1. In solution to the transformed problem row p and column q cannot
+* be basic at the same time; otherwise the basis matrix would have
+* two linear dependent columns: unity column of auxiliary variable
+* of row p and unity column of variable s.
+*
+* 2. Though in the transformed problem row p is equality constraint,
+* it may be basic due to primal degenerate solution.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of row multiplier pi[p] in solution to the original problem
+* is the same as in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct ineq_row
+{ /* inequality constraint row */
+ int p;
+ /* row reference number */
+ int s;
+ /* column reference number for slack/surplus variable */
+};
+
+static int rcv_geq_row(NPP *npp, void *info);
+
+void npp_geq_row(NPP *npp, NPPROW *p)
+{ /* process row of 'not less than' type */
+ struct ineq_row *info;
+ NPPCOL *s;
+ /* the row must have lower bound */
+ xassert(p->lb != -DBL_MAX);
+ xassert(p->lb < p->ub);
+ /* create column for surplus variable */
+ s = npp_add_col(npp);
+ s->lb = 0.0;
+ s->ub = (p->ub == +DBL_MAX ? +DBL_MAX : p->ub - p->lb);
+ /* and add it to the transformed problem */
+ npp_add_aij(npp, p, s, -1.0);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_geq_row, sizeof(struct ineq_row));
+ info->p = p->i;
+ info->s = s->j;
+ /* replace the row by equality constraint */
+ p->ub = p->lb;
+ return;
+}
+
+static int rcv_geq_row(NPP *npp, void *_info)
+{ /* recover row of 'not less than' type */
+ struct ineq_row *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] == GLP_BS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ { npp_error();
+ return 1;
+ }
+ else if (npp->c_stat[info->s] == GLP_NL ||
+ npp->c_stat[info->s] == GLP_NU)
+ npp->r_stat[info->p] = GLP_BS;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else if (npp->r_stat[info->p] == GLP_NS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ npp->r_stat[info->p] = GLP_BS;
+ else if (npp->c_stat[info->s] == GLP_NL)
+ npp->r_stat[info->p] = GLP_NL;
+ else if (npp->c_stat[info->s] == GLP_NU)
+ npp->r_stat[info->p] = GLP_NU;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_leq_row - process row of 'not greater than' type
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_leq_row(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_leq_row processes row p, which is 'not greater than'
+* inequality constraint:
+*
+* (L[p] <=) sum a[p,j] x[j] <= U[p], (1)
+* j
+*
+* where L[p] < U[p], and lower bound may not exist (L[p] = +oo).
+*
+* PROBLEM TRANSFORMATION
+*
+* Constraint (1) can be replaced by equality constraint:
+*
+* sum a[p,j] x[j] + s = L[p], (2)
+* j
+*
+* where
+*
+* 0 <= s (<= U[p] - L[p]) (3)
+*
+* is a non-negative slack variable.
+*
+* Since in the primal system there appears column s having the only
+* non-zero coefficient in row p, in the dual system there appears a
+* new row:
+*
+* (+1) pi[p] + lambda = 0, (4)
+*
+* where (+1) is coefficient of column s in row p, pi[p] is multiplier
+* of row p, lambda is multiplier of column q, 0 is coefficient of
+* column s in the objective row.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of row p in solution to the original problem is determined
+* by its status and status of column q in solution to the transformed
+* problem as follows:
+*
+* +--------------------------------------+------------------+
+* | Transformed problem | Original problem |
+* +-----------------+--------------------+------------------+
+* | Status of row p | Status of column s | Status of row p |
+* +-----------------+--------------------+------------------+
+* | GLP_BS | GLP_BS | N/A |
+* | GLP_BS | GLP_NL | GLP_BS |
+* | GLP_BS | GLP_NU | GLP_BS |
+* | GLP_NS | GLP_BS | GLP_BS |
+* | GLP_NS | GLP_NL | GLP_NU |
+* | GLP_NS | GLP_NU | GLP_NL |
+* +-----------------+--------------------+------------------+
+*
+* Value of row multiplier pi[p] in solution to the original problem
+* is the same as in solution to the transformed problem.
+*
+* 1. In solution to the transformed problem row p and column q cannot
+* be basic at the same time; otherwise the basis matrix would have
+* two linear dependent columns: unity column of auxiliary variable
+* of row p and unity column of variable s.
+*
+* 2. Though in the transformed problem row p is equality constraint,
+* it may be basic due to primal degeneracy.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of row multiplier pi[p] in solution to the original problem
+* is the same as in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+static int rcv_leq_row(NPP *npp, void *info);
+
+void npp_leq_row(NPP *npp, NPPROW *p)
+{ /* process row of 'not greater than' type */
+ struct ineq_row *info;
+ NPPCOL *s;
+ /* the row must have upper bound */
+ xassert(p->ub != +DBL_MAX);
+ xassert(p->lb < p->ub);
+ /* create column for slack variable */
+ s = npp_add_col(npp);
+ s->lb = 0.0;
+ s->ub = (p->lb == -DBL_MAX ? +DBL_MAX : p->ub - p->lb);
+ /* and add it to the transformed problem */
+ npp_add_aij(npp, p, s, +1.0);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_leq_row, sizeof(struct ineq_row));
+ info->p = p->i;
+ info->s = s->j;
+ /* replace the row by equality constraint */
+ p->lb = p->ub;
+ return;
+}
+
+static int rcv_leq_row(NPP *npp, void *_info)
+{ /* recover row of 'not greater than' type */
+ struct ineq_row *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] == GLP_BS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ { npp_error();
+ return 1;
+ }
+ else if (npp->c_stat[info->s] == GLP_NL ||
+ npp->c_stat[info->s] == GLP_NU)
+ npp->r_stat[info->p] = GLP_BS;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else if (npp->r_stat[info->p] == GLP_NS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ npp->r_stat[info->p] = GLP_BS;
+ else if (npp->c_stat[info->s] == GLP_NL)
+ npp->r_stat[info->p] = GLP_NU;
+ else if (npp->c_stat[info->s] == GLP_NU)
+ npp->r_stat[info->p] = GLP_NL;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_free_col - process free (unbounded) column
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_free_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_free_col processes column q, which is free (i.e. has
+* no finite bounds):
+*
+* -oo < x[q] < +oo. (1)
+*
+* PROBLEM TRANSFORMATION
+*
+* Free (unbounded) variable can be replaced by the difference of two
+* non-negative variables:
+*
+* x[q] = s' - s'', s', s'' >= 0. (2)
+*
+* Assuming that in the transformed problem x[q] becomes s',
+* transformation (2) causes new column s'' to appear, which differs
+* from column s' only in the sign of coefficients in constraint and
+* objective rows. Thus, if in the dual system the following row
+* corresponds to column s':
+*
+* sum a[i,q] pi[i] + lambda' = c[q], (3)
+* i
+*
+* the row which corresponds to column s'' is the following:
+*
+* sum (-a[i,q]) pi[i] + lambda'' = -c[q]. (4)
+* i
+*
+* Then from (3) and (4) it follows that:
+*
+* lambda' + lambda'' = 0 => lambda' = lmabda'' = 0, (5)
+*
+* where lambda' and lambda'' are multipliers for columns s' and s'',
+* resp.
+*
+* RECOVERING BASIC SOLUTION
+*
+* With respect to (5) status of column q in solution to the original
+* problem is determined by statuses of columns s' and s'' in solution
+* to the transformed problem as follows:
+*
+* +--------------------------------------+------------------+
+* | Transformed problem | Original problem |
+* +------------------+-------------------+------------------+
+* | Status of col s' | Status of col s'' | Status of col q |
+* +------------------+-------------------+------------------+
+* | GLP_BS | GLP_BS | N/A |
+* | GLP_BS | GLP_NL | GLP_BS |
+* | GLP_NL | GLP_BS | GLP_BS |
+* | GLP_NL | GLP_NL | GLP_NF |
+* +------------------+-------------------+------------------+
+*
+* Value of column q is computed with formula (2).
+*
+* 1. In solution to the transformed problem columns s' and s'' cannot
+* be basic at the same time, because they differ only in the sign,
+* hence, are linear dependent.
+*
+* 2. Though column q is free, it can be non-basic due to dual
+* degeneracy.
+*
+* 3. If column q is integral, columns s' and s'' are also integral.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q is computed with formula (2).
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is computed with formula (2). */
+
+struct free_col
+{ /* free (unbounded) column */
+ int q;
+ /* column reference number for variables x[q] and s' */
+ int s;
+ /* column reference number for variable s'' */
+};
+
+static int rcv_free_col(NPP *npp, void *info);
+
+void npp_free_col(NPP *npp, NPPCOL *q)
+{ /* process free (unbounded) column */
+ struct free_col *info;
+ NPPCOL *s;
+ NPPAIJ *aij;
+ /* the column must be free */
+ xassert(q->lb == -DBL_MAX && q->ub == +DBL_MAX);
+ /* variable x[q] becomes s' */
+ q->lb = 0.0, q->ub = +DBL_MAX;
+ /* create variable s'' */
+ s = npp_add_col(npp);
+ s->is_int = q->is_int;
+ s->lb = 0.0, s->ub = +DBL_MAX;
+ /* duplicate objective coefficient */
+ s->coef = -q->coef;
+ /* duplicate column of the constraint matrix */
+ for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ npp_add_aij(npp, aij->row, s, -aij->val);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_free_col, sizeof(struct free_col));
+ info->q = q->j;
+ info->s = s->j;
+ return;
+}
+
+static int rcv_free_col(NPP *npp, void *_info)
+{ /* recover free (unbounded) column */
+ struct free_col *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->c_stat[info->q] == GLP_BS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ { npp_error();
+ return 1;
+ }
+ else if (npp->c_stat[info->s] == GLP_NL)
+ npp->c_stat[info->q] = GLP_BS;
+ else
+ { npp_error();
+ return -1;
+ }
+ }
+ else if (npp->c_stat[info->q] == GLP_NL)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ npp->c_stat[info->q] = GLP_BS;
+ else if (npp->c_stat[info->s] == GLP_NL)
+ npp->c_stat[info->q] = GLP_NF;
+ else
+ { npp_error();
+ return -1;
+ }
+ }
+ else
+ { npp_error();
+ return -1;
+ }
+ }
+ /* compute value of x[q] with formula (2) */
+ npp->c_value[info->q] -= npp->c_value[info->s];
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_lbnd_col - process column with (non-zero) lower bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_lbnd_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_lbnd_col processes column q, which has (non-zero)
+* lower bound:
+*
+* l[q] <= x[q] (<= u[q]), (1)
+*
+* where l[q] < u[q], and upper bound may not exist (u[q] = +oo).
+*
+* PROBLEM TRANSFORMATION
+*
+* Column q can be replaced as follows:
+*
+* x[q] = l[q] + s, (2)
+*
+* where
+*
+* 0 <= s (<= u[q] - l[q]) (3)
+*
+* is a non-negative variable.
+*
+* Substituting x[q] from (2) into the objective row, we have:
+*
+* z = sum c[j] x[j] + c0 =
+* j
+*
+* = sum c[j] x[j] + c[q] x[q] + c0 =
+* j!=q
+*
+* = sum c[j] x[j] + c[q] (l[q] + s) + c0 =
+* j!=q
+*
+* = sum c[j] x[j] + c[q] s + c~0,
+*
+* where
+*
+* c~0 = c0 + c[q] l[q] (4)
+*
+* is the constant term of the objective in the transformed problem.
+* Similarly, substituting x[q] into constraint row i, we have:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i] ==>
+* j
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] x[q] <= U[i] ==>
+* j!=q
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] (l[q] + s) <= U[i] ==>
+* j!=q
+*
+* L~[i] <= sum a[i,j] x[j] + a[i,q] s <= U~[i],
+* j!=q
+*
+* where
+*
+* L~[i] = L[i] - a[i,q] l[q], U~[i] = U[i] - a[i,q] l[q] (5)
+*
+* are lower and upper bounds of row i in the transformed problem,
+* resp.
+*
+* Transformation (2) does not affect the dual system.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of column q in solution to the original problem is the same
+* as in solution to the transformed problem (GLP_BS, GLP_NL or GLP_NU).
+* Value of column q is computed with formula (2).
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q is computed with formula (2).
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is computed with formula (2). */
+
+struct bnd_col
+{ /* bounded column */
+ int q;
+ /* column reference number for variables x[q] and s */
+ double bnd;
+ /* lower/upper bound l[q] or u[q] */
+};
+
+static int rcv_lbnd_col(NPP *npp, void *info);
+
+void npp_lbnd_col(NPP *npp, NPPCOL *q)
+{ /* process column with (non-zero) lower bound */
+ struct bnd_col *info;
+ NPPROW *i;
+ NPPAIJ *aij;
+ /* the column must have non-zero lower bound */
+ xassert(q->lb != 0.0);
+ xassert(q->lb != -DBL_MAX);
+ xassert(q->lb < q->ub);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_lbnd_col, sizeof(struct bnd_col));
+ info->q = q->j;
+ info->bnd = q->lb;
+ /* substitute x[q] into objective row */
+ npp->c0 += q->coef * q->lb;
+ /* substitute x[q] into constraint rows */
+ for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row;
+ if (i->lb == i->ub)
+ i->ub = (i->lb -= aij->val * q->lb);
+ else
+ { if (i->lb != -DBL_MAX)
+ i->lb -= aij->val * q->lb;
+ if (i->ub != +DBL_MAX)
+ i->ub -= aij->val * q->lb;
+ }
+ }
+ /* column x[q] becomes column s */
+ if (q->ub != +DBL_MAX)
+ q->ub -= q->lb;
+ q->lb = 0.0;
+ return;
+}
+
+static int rcv_lbnd_col(NPP *npp, void *_info)
+{ /* recover column with (non-zero) lower bound */
+ struct bnd_col *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->c_stat[info->q] == GLP_BS ||
+ npp->c_stat[info->q] == GLP_NL ||
+ npp->c_stat[info->q] == GLP_NU)
+ npp->c_stat[info->q] = npp->c_stat[info->q];
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ /* compute value of x[q] with formula (2) */
+ npp->c_value[info->q] = info->bnd + npp->c_value[info->q];
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_ubnd_col - process column with upper bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_ubnd_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_ubnd_col processes column q, which has upper bound:
+*
+* (l[q] <=) x[q] <= u[q], (1)
+*
+* where l[q] < u[q], and lower bound may not exist (l[q] = -oo).
+*
+* PROBLEM TRANSFORMATION
+*
+* Column q can be replaced as follows:
+*
+* x[q] = u[q] - s, (2)
+*
+* where
+*
+* 0 <= s (<= u[q] - l[q]) (3)
+*
+* is a non-negative variable.
+*
+* Substituting x[q] from (2) into the objective row, we have:
+*
+* z = sum c[j] x[j] + c0 =
+* j
+*
+* = sum c[j] x[j] + c[q] x[q] + c0 =
+* j!=q
+*
+* = sum c[j] x[j] + c[q] (u[q] - s) + c0 =
+* j!=q
+*
+* = sum c[j] x[j] - c[q] s + c~0,
+*
+* where
+*
+* c~0 = c0 + c[q] u[q] (4)
+*
+* is the constant term of the objective in the transformed problem.
+* Similarly, substituting x[q] into constraint row i, we have:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i] ==>
+* j
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] x[q] <= U[i] ==>
+* j!=q
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] (u[q] - s) <= U[i] ==>
+* j!=q
+*
+* L~[i] <= sum a[i,j] x[j] - a[i,q] s <= U~[i],
+* j!=q
+*
+* where
+*
+* L~[i] = L[i] - a[i,q] u[q], U~[i] = U[i] - a[i,q] u[q] (5)
+*
+* are lower and upper bounds of row i in the transformed problem,
+* resp.
+*
+* Note that in the transformed problem coefficients c[q] and a[i,q]
+* change their sign. Thus, the row of the dual system corresponding to
+* column q:
+*
+* sum a[i,q] pi[i] + lambda[q] = c[q] (6)
+* i
+*
+* in the transformed problem becomes the following:
+*
+* sum (-a[i,q]) pi[i] + lambda[s] = -c[q]. (7)
+* i
+*
+* Therefore:
+*
+* lambda[q] = - lambda[s], (8)
+*
+* where lambda[q] is multiplier for column q, lambda[s] is multiplier
+* for column s.
+*
+* RECOVERING BASIC SOLUTION
+*
+* With respect to (8) status of column q in solution to the original
+* problem is determined by status of column s in solution to the
+* transformed problem as follows:
+*
+* +-----------------------+--------------------+
+* | Status of column s | Status of column q |
+* | (transformed problem) | (original problem) |
+* +-----------------------+--------------------+
+* | GLP_BS | GLP_BS |
+* | GLP_NL | GLP_NU |
+* | GLP_NU | GLP_NL |
+* +-----------------------+--------------------+
+*
+* Value of column q is computed with formula (2).
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q is computed with formula (2).
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is computed with formula (2). */
+
+static int rcv_ubnd_col(NPP *npp, void *info);
+
+void npp_ubnd_col(NPP *npp, NPPCOL *q)
+{ /* process column with upper bound */
+ struct bnd_col *info;
+ NPPROW *i;
+ NPPAIJ *aij;
+ /* the column must have upper bound */
+ xassert(q->ub != +DBL_MAX);
+ xassert(q->lb < q->ub);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_ubnd_col, sizeof(struct bnd_col));
+ info->q = q->j;
+ info->bnd = q->ub;
+ /* substitute x[q] into objective row */
+ npp->c0 += q->coef * q->ub;
+ q->coef = -q->coef;
+ /* substitute x[q] into constraint rows */
+ for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row;
+ if (i->lb == i->ub)
+ i->ub = (i->lb -= aij->val * q->ub);
+ else
+ { if (i->lb != -DBL_MAX)
+ i->lb -= aij->val * q->ub;
+ if (i->ub != +DBL_MAX)
+ i->ub -= aij->val * q->ub;
+ }
+ aij->val = -aij->val;
+ }
+ /* column x[q] becomes column s */
+ if (q->lb != -DBL_MAX)
+ q->ub -= q->lb;
+ else
+ q->ub = +DBL_MAX;
+ q->lb = 0.0;
+ return;
+}
+
+static int rcv_ubnd_col(NPP *npp, void *_info)
+{ /* recover column with upper bound */
+ struct bnd_col *info = _info;
+ if (npp->sol == GLP_BS)
+ { if (npp->c_stat[info->q] == GLP_BS)
+ npp->c_stat[info->q] = GLP_BS;
+ else if (npp->c_stat[info->q] == GLP_NL)
+ npp->c_stat[info->q] = GLP_NU;
+ else if (npp->c_stat[info->q] == GLP_NU)
+ npp->c_stat[info->q] = GLP_NL;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ /* compute value of x[q] with formula (2) */
+ npp->c_value[info->q] = info->bnd - npp->c_value[info->q];
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_dbnd_col - process non-negative column with upper bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_dbnd_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_dbnd_col processes column q, which is non-negative
+* and has upper bound:
+*
+* 0 <= x[q] <= u[q], (1)
+*
+* where u[q] > 0.
+*
+* PROBLEM TRANSFORMATION
+*
+* Upper bound of column q can be replaced by the following equality
+* constraint:
+*
+* x[q] + s = u[q], (2)
+*
+* where s >= 0 is a non-negative complement variable.
+*
+* Since in the primal system along with new row (2) there appears a
+* new column s having the only non-zero coefficient in this row, in
+* the dual system there appears a new row:
+*
+* (+1)pi + lambda[s] = 0, (3)
+*
+* where (+1) is coefficient at column s in row (2), pi is multiplier
+* for row (2), lambda[s] is multiplier for column s, 0 is coefficient
+* at column s in the objective row.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of column q in solution to the original problem is determined
+* by its status and status of column s in solution to the transformed
+* problem as follows:
+*
+* +-----------------------------------+------------------+
+* | Transformed problem | Original problem |
+* +-----------------+-----------------+------------------+
+* | Status of col q | Status of col s | Status of col q |
+* +-----------------+-----------------+------------------+
+* | GLP_BS | GLP_BS | GLP_BS |
+* | GLP_BS | GLP_NL | GLP_NU |
+* | GLP_NL | GLP_BS | GLP_NL |
+* | GLP_NL | GLP_NL | GLP_NL (*) |
+* +-----------------+-----------------+------------------+
+*
+* Value of column q in solution to the original problem is the same as
+* in solution to the transformed problem.
+*
+* 1. Formally, in solution to the transformed problem columns q and s
+* cannot be non-basic at the same time, since the constraint (2)
+* would be violated. However, if u[q] is close to zero, violation
+* may be less than a working precision even if both columns q and s
+* are non-basic. In this degenerate case row (2) can be only basic,
+* i.e. non-active constraint (otherwise corresponding row of the
+* basis matrix would be zero). This allows to pivot out auxiliary
+* variable and pivot in column s, in which case the row becomes
+* active while column s becomes basic.
+*
+* 2. If column q is integral, column s is also integral.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q in solution to the original problem is the same as
+* in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q in solution to the original problem is the same as
+* in solution to the transformed problem. */
+
+struct dbnd_col
+{ /* double-bounded column */
+ int q;
+ /* column reference number for variable x[q] */
+ int s;
+ /* column reference number for complement variable s */
+};
+
+static int rcv_dbnd_col(NPP *npp, void *info);
+
+void npp_dbnd_col(NPP *npp, NPPCOL *q)
+{ /* process non-negative column with upper bound */
+ struct dbnd_col *info;
+ NPPROW *p;
+ NPPCOL *s;
+ /* the column must be non-negative with upper bound */
+ xassert(q->lb == 0.0);
+ xassert(q->ub > 0.0);
+ xassert(q->ub != +DBL_MAX);
+ /* create variable s */
+ s = npp_add_col(npp);
+ s->is_int = q->is_int;
+ s->lb = 0.0, s->ub = +DBL_MAX;
+ /* create equality constraint (2) */
+ p = npp_add_row(npp);
+ p->lb = p->ub = q->ub;
+ npp_add_aij(npp, p, q, +1.0);
+ npp_add_aij(npp, p, s, +1.0);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_dbnd_col, sizeof(struct dbnd_col));
+ info->q = q->j;
+ info->s = s->j;
+ /* remove upper bound of x[q] */
+ q->ub = +DBL_MAX;
+ return;
+}
+
+static int rcv_dbnd_col(NPP *npp, void *_info)
+{ /* recover non-negative column with upper bound */
+ struct dbnd_col *info = _info;
+ if (npp->sol == GLP_BS)
+ { if (npp->c_stat[info->q] == GLP_BS)
+ { if (npp->c_stat[info->s] == GLP_BS)
+ npp->c_stat[info->q] = GLP_BS;
+ else if (npp->c_stat[info->s] == GLP_NL)
+ npp->c_stat[info->q] = GLP_NU;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else if (npp->c_stat[info->q] == GLP_NL)
+ { if (npp->c_stat[info->s] == GLP_BS ||
+ npp->c_stat[info->s] == GLP_NL)
+ npp->c_stat[info->q] = GLP_NL;
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_fixed_col - process fixed column
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_fixed_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_fixed_col processes column q, which is fixed:
+*
+* x[q] = s[q], (1)
+*
+* where s[q] is a fixed column value.
+*
+* PROBLEM TRANSFORMATION
+*
+* The value of a fixed column can be substituted into the objective
+* and constraint rows that allows removing the column from the problem.
+*
+* Substituting x[q] = s[q] into the objective row, we have:
+*
+* z = sum c[j] x[j] + c0 =
+* j
+*
+* = sum c[j] x[j] + c[q] x[q] + c0 =
+* j!=q
+*
+* = sum c[j] x[j] + c[q] s[q] + c0 =
+* j!=q
+*
+* = sum c[j] x[j] + c~0,
+* j!=q
+*
+* where
+*
+* c~0 = c0 + c[q] s[q] (2)
+*
+* is the constant term of the objective in the transformed problem.
+* Similarly, substituting x[q] = s[q] into constraint row i, we have:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i] ==>
+* j
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] x[q] <= U[i] ==>
+* j!=q
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] s[q] <= U[i] ==>
+* j!=q
+*
+* L~[i] <= sum a[i,j] x[j] + a[i,q] s <= U~[i],
+* j!=q
+*
+* where
+*
+* L~[i] = L[i] - a[i,q] s[q], U~[i] = U[i] - a[i,q] s[q] (3)
+*
+* are lower and upper bounds of row i in the transformed problem,
+* resp.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Column q is assigned status GLP_NS and its value is assigned s[q].
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q is assigned s[q].
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is assigned s[q]. */
+
+struct fixed_col
+{ /* fixed column */
+ int q;
+ /* column reference number for variable x[q] */
+ double s;
+ /* value, at which x[q] is fixed */
+};
+
+static int rcv_fixed_col(NPP *npp, void *info);
+
+void npp_fixed_col(NPP *npp, NPPCOL *q)
+{ /* process fixed column */
+ struct fixed_col *info;
+ NPPROW *i;
+ NPPAIJ *aij;
+ /* the column must be fixed */
+ xassert(q->lb == q->ub);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_fixed_col, sizeof(struct fixed_col));
+ info->q = q->j;
+ info->s = q->lb;
+ /* substitute x[q] = s[q] into objective row */
+ npp->c0 += q->coef * q->lb;
+ /* substitute x[q] = s[q] into constraint rows */
+ for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row;
+ if (i->lb == i->ub)
+ i->ub = (i->lb -= aij->val * q->lb);
+ else
+ { if (i->lb != -DBL_MAX)
+ i->lb -= aij->val * q->lb;
+ if (i->ub != +DBL_MAX)
+ i->ub -= aij->val * q->lb;
+ }
+ }
+ /* remove the column from the problem */
+ npp_del_col(npp, q);
+ return;
+}
+
+static int rcv_fixed_col(NPP *npp, void *_info)
+{ /* recover fixed column */
+ struct fixed_col *info = _info;
+ if (npp->sol == GLP_SOL)
+ npp->c_stat[info->q] = GLP_NS;
+ npp->c_value[info->q] = info->s;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_make_equality - process row with almost identical bounds
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_make_equality(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_make_equality processes row p:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p], (1)
+* j
+*
+* where -oo < L[p] < U[p] < +oo, i.e. which is double-sided inequality
+* constraint.
+*
+* RETURNS
+*
+* 0 - row bounds have not been changed;
+*
+* 1 - row has been replaced by equality constraint.
+*
+* PROBLEM TRANSFORMATION
+*
+* If bounds of row (1) are very close to each other:
+*
+* U[p] - L[p] <= eps, (2)
+*
+* where eps is an absolute tolerance for row value, the row can be
+* replaced by the following almost equivalent equiality constraint:
+*
+* sum a[p,j] x[j] = b, (3)
+* j
+*
+* where b = (L[p] + U[p]) / 2. If the right-hand side in (3) happens
+* to be very close to its nearest integer:
+*
+* |b - floor(b + 0.5)| <= eps, (4)
+*
+* it is reasonable to use this nearest integer as the right-hand side.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of row p in solution to the original problem is determined
+* by its status and the sign of its multiplier pi[p] in solution to
+* the transformed problem as follows:
+*
+* +-----------------------+---------+--------------------+
+* | Status of row p | Sign of | Status of row p |
+* | (transformed problem) | pi[p] | (original problem) |
+* +-----------------------+---------+--------------------+
+* | GLP_BS | + / - | GLP_BS |
+* | GLP_NS | + | GLP_NL |
+* | GLP_NS | - | GLP_NU |
+* +-----------------------+---------+--------------------+
+*
+* Value of row multiplier pi[p] in solution to the original problem is
+* the same as in solution to the transformed problem.
+*
+* RECOVERING INTERIOR POINT SOLUTION
+*
+* Value of row multiplier pi[p] in solution to the original problem is
+* the same as in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct make_equality
+{ /* row with almost identical bounds */
+ int p;
+ /* row reference number */
+};
+
+static int rcv_make_equality(NPP *npp, void *info);
+
+int npp_make_equality(NPP *npp, NPPROW *p)
+{ /* process row with almost identical bounds */
+ struct make_equality *info;
+ double b, eps, nint;
+ /* the row must be double-sided inequality */
+ xassert(p->lb != -DBL_MAX);
+ xassert(p->ub != +DBL_MAX);
+ xassert(p->lb < p->ub);
+ /* check row bounds */
+ eps = 1e-9 + 1e-12 * fabs(p->lb);
+ if (p->ub - p->lb > eps) return 0;
+ /* row bounds are very close to each other */
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_make_equality, sizeof(struct make_equality));
+ info->p = p->i;
+ /* compute right-hand side */
+ b = 0.5 * (p->ub + p->lb);
+ nint = floor(b + 0.5);
+ if (fabs(b - nint) <= eps) b = nint;
+ /* replace row p by almost equivalent equality constraint */
+ p->lb = p->ub = b;
+ return 1;
+}
+
+int rcv_make_equality(NPP *npp, void *_info)
+{ /* recover row with almost identical bounds */
+ struct make_equality *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] == GLP_BS)
+ npp->r_stat[info->p] = GLP_BS;
+ else if (npp->r_stat[info->p] == GLP_NS)
+ { if (npp->r_pi[info->p] >= 0.0)
+ npp->r_stat[info->p] = GLP_NL;
+ else
+ npp->r_stat[info->p] = GLP_NU;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_make_fixed - process column with almost identical bounds
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_make_fixed(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_make_fixed processes column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where -oo < l[q] < u[q] < +oo, i.e. which has both lower and upper
+* bounds.
+*
+* RETURNS
+*
+* 0 - column bounds have not been changed;
+*
+* 1 - column has been fixed.
+*
+* PROBLEM TRANSFORMATION
+*
+* If bounds of column (1) are very close to each other:
+*
+* u[q] - l[q] <= eps, (2)
+*
+* where eps is an absolute tolerance for column value, the column can
+* be fixed:
+*
+* x[q] = s[q], (3)
+*
+* where s[q] = (l[q] + u[q]) / 2. And if the fixed column value s[q]
+* happens to be very close to its nearest integer:
+*
+* |s[q] - floor(s[q] + 0.5)| <= eps, (4)
+*
+* it is reasonable to use this nearest integer as the fixed value.
+*
+* RECOVERING BASIC SOLUTION
+*
+* In the dual system of the original (as well as transformed) problem
+* column q corresponds to the following row:
+*
+* sum a[i,q] pi[i] + lambda[q] = c[q]. (5)
+* i
+*
+* Since multipliers pi[i] are known for all rows from solution to the
+* transformed problem, formula (5) allows computing value of multiplier
+* (reduced cost) for column q:
+*
+* lambda[q] = c[q] - sum a[i,q] pi[i]. (6)
+* i
+*
+* Status of column q in solution to the original problem is determined
+* by its status and the sign of its multiplier lambda[q] in solution to
+* the transformed problem as follows:
+*
+* +-----------------------+-----------+--------------------+
+* | Status of column q | Sign of | Status of column q |
+* | (transformed problem) | lambda[q] | (original problem) |
+* +-----------------------+-----------+--------------------+
+* | GLP_BS | + / - | GLP_BS |
+* | GLP_NS | + | GLP_NL |
+* | GLP_NS | - | GLP_NU |
+* +-----------------------+-----------+--------------------+
+*
+* Value of column q in solution to the original problem is the same as
+* in solution to the transformed problem.
+*
+* RECOVERING INTERIOR POINT SOLUTION
+*
+* Value of column q in solution to the original problem is the same as
+* in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct make_fixed
+{ /* column with almost identical bounds */
+ int q;
+ /* column reference number */
+ double c;
+ /* objective coefficient at x[q] */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[i,q] */
+};
+
+static int rcv_make_fixed(NPP *npp, void *info);
+
+int npp_make_fixed(NPP *npp, NPPCOL *q)
+{ /* process column with almost identical bounds */
+ struct make_fixed *info;
+ NPPAIJ *aij;
+ NPPLFE *lfe;
+ double s, eps, nint;
+ /* the column must be double-bounded */
+ xassert(q->lb != -DBL_MAX);
+ xassert(q->ub != +DBL_MAX);
+ xassert(q->lb < q->ub);
+ /* check column bounds */
+ eps = 1e-9 + 1e-12 * fabs(q->lb);
+ if (q->ub - q->lb > eps) return 0;
+ /* column bounds are very close to each other */
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_make_fixed, sizeof(struct make_fixed));
+ info->q = q->j;
+ info->c = q->coef;
+ info->ptr = NULL;
+ /* save column coefficients a[i,q] (needed for basic solution
+ only) */
+ if (npp->sol == GLP_SOL)
+ { for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = aij->row->i;
+ lfe->val = aij->val;
+ lfe->next = info->ptr;
+ info->ptr = lfe;
+ }
+ }
+ /* compute column fixed value */
+ s = 0.5 * (q->ub + q->lb);
+ nint = floor(s + 0.5);
+ if (fabs(s - nint) <= eps) s = nint;
+ /* make column q fixed */
+ q->lb = q->ub = s;
+ return 1;
+}
+
+static int rcv_make_fixed(NPP *npp, void *_info)
+{ /* recover column with almost identical bounds */
+ struct make_fixed *info = _info;
+ NPPLFE *lfe;
+ double lambda;
+ if (npp->sol == GLP_SOL)
+ { if (npp->c_stat[info->q] == GLP_BS)
+ npp->c_stat[info->q] = GLP_BS;
+ else if (npp->c_stat[info->q] == GLP_NS)
+ { /* compute multiplier for column q with formula (6) */
+ lambda = info->c;
+ for (lfe = info->ptr; lfe != NULL; lfe = lfe->next)
+ lambda -= lfe->val * npp->r_pi[lfe->ref];
+ /* assign status to non-basic column */
+ if (lambda >= 0.0)
+ npp->c_stat[info->q] = GLP_NL;
+ else
+ npp->c_stat[info->q] = GLP_NU;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp3.c b/test/monniaux/glpk-4.65/src/npp/npp3.c
new file mode 100644
index 00000000..883af127
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp3.c
@@ -0,0 +1,2861 @@
+/* npp3.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* npp_empty_row - process empty row
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_empty_row(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_empty_row processes row p, which is empty, i.e.
+* coefficients at all columns in this row are zero:
+*
+* L[p] <= sum 0 x[j] <= U[p], (1)
+*
+* where L[p] <= U[p].
+*
+* RETURNS
+*
+* 0 - success;
+*
+* 1 - problem has no primal feasible solution.
+*
+* PROBLEM TRANSFORMATION
+*
+* If the following conditions hold:
+*
+* L[p] <= +eps, U[p] >= -eps, (2)
+*
+* where eps is an absolute tolerance for row value, the row p is
+* redundant. In this case it can be replaced by equivalent redundant
+* row, which is free (unbounded), and then removed from the problem.
+* Otherwise, the row p is infeasible and, thus, the problem has no
+* primal feasible solution.
+*
+* RECOVERING BASIC SOLUTION
+*
+* See the routine npp_free_row.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* See the routine npp_free_row.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+int npp_empty_row(NPP *npp, NPPROW *p)
+{ /* process empty row */
+ double eps = 1e-3;
+ /* the row must be empty */
+ xassert(p->ptr == NULL);
+ /* check primal feasibility */
+ if (p->lb > +eps || p->ub < -eps)
+ return 1;
+ /* replace the row by equivalent free (unbounded) row */
+ p->lb = -DBL_MAX, p->ub = +DBL_MAX;
+ /* and process it */
+ npp_free_row(npp, p);
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_empty_col - process empty column
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_empty_col(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_empty_col processes column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] <= u[q], which is empty, i.e. has zero coefficients in
+* all constraint rows.
+*
+* RETURNS
+*
+* 0 - success;
+*
+* 1 - problem has no dual feasible solution.
+*
+* PROBLEM TRANSFORMATION
+*
+* The row of the dual system corresponding to the empty column is the
+* following:
+*
+* sum 0 pi[i] + lambda[q] = c[q], (2)
+* i
+*
+* from which it follows that:
+*
+* lambda[q] = c[q]. (3)
+*
+* If the following condition holds:
+*
+* c[q] < - eps, (4)
+*
+* where eps is an absolute tolerance for column multiplier, the lower
+* column bound l[q] must be active to provide dual feasibility (note
+* that being preprocessed the problem is always minimization). In this
+* case the column can be fixed on its lower bound and removed from the
+* problem (if the column is integral, its bounds are also assumed to
+* be integral). And if the column has no lower bound (l[q] = -oo), the
+* problem has no dual feasible solution.
+*
+* If the following condition holds:
+*
+* c[q] > + eps, (5)
+*
+* the upper column bound u[q] must be active to provide dual
+* feasibility. In this case the column can be fixed on its upper bound
+* and removed from the problem. And if the column has no upper bound
+* (u[q] = +oo), the problem has no dual feasible solution.
+*
+* Finally, if the following condition holds:
+*
+* - eps <= c[q] <= +eps, (6)
+*
+* dual feasibility does not depend on a particular value of column q.
+* In this case the column can be fixed either on its lower bound (if
+* l[q] > -oo) or on its upper bound (if u[q] < +oo) or at zero (if the
+* column is unbounded) and then removed from the problem.
+*
+* RECOVERING BASIC SOLUTION
+*
+* See the routine npp_fixed_col. Having been recovered the column
+* is assigned status GLP_NS. However, if actually it is not fixed
+* (l[q] < u[q]), its status should be changed to GLP_NL, GLP_NU, or
+* GLP_NF depending on which bound it was fixed on transformation stage.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* See the routine npp_fixed_col.
+*
+* RECOVERING MIP SOLUTION
+*
+* See the routine npp_fixed_col. */
+
+struct empty_col
+{ /* empty column */
+ int q;
+ /* column reference number */
+ char stat;
+ /* status in basic solution */
+};
+
+static int rcv_empty_col(NPP *npp, void *info);
+
+int npp_empty_col(NPP *npp, NPPCOL *q)
+{ /* process empty column */
+ struct empty_col *info;
+ double eps = 1e-3;
+ /* the column must be empty */
+ xassert(q->ptr == NULL);
+ /* check dual feasibility */
+ if (q->coef > +eps && q->lb == -DBL_MAX)
+ return 1;
+ if (q->coef < -eps && q->ub == +DBL_MAX)
+ return 1;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_empty_col, sizeof(struct empty_col));
+ info->q = q->j;
+ /* fix the column */
+ if (q->lb == -DBL_MAX && q->ub == +DBL_MAX)
+ { /* free column */
+ info->stat = GLP_NF;
+ q->lb = q->ub = 0.0;
+ }
+ else if (q->ub == +DBL_MAX)
+lo: { /* column with lower bound */
+ info->stat = GLP_NL;
+ q->ub = q->lb;
+ }
+ else if (q->lb == -DBL_MAX)
+up: { /* column with upper bound */
+ info->stat = GLP_NU;
+ q->lb = q->ub;
+ }
+ else if (q->lb != q->ub)
+ { /* double-bounded column */
+ if (q->coef >= +DBL_EPSILON) goto lo;
+ if (q->coef <= -DBL_EPSILON) goto up;
+ if (fabs(q->lb) <= fabs(q->ub)) goto lo; else goto up;
+ }
+ else
+ { /* fixed column */
+ info->stat = GLP_NS;
+ }
+ /* process fixed column */
+ npp_fixed_col(npp, q);
+ return 0;
+}
+
+static int rcv_empty_col(NPP *npp, void *_info)
+{ /* recover empty column */
+ struct empty_col *info = _info;
+ if (npp->sol == GLP_SOL)
+ npp->c_stat[info->q] = info->stat;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_value - process implied column value
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_implied_value(NPP *npp, NPPCOL *q, double s);
+*
+* DESCRIPTION
+*
+* For column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] < u[q], the routine npp_implied_value processes its
+* implied value s[q]. If this implied value satisfies to the current
+* column bounds and integrality condition, the routine fixes column q
+* at the given point. Note that the column is kept in the problem in
+* any case.
+*
+* RETURNS
+*
+* 0 - column has been fixed;
+*
+* 1 - implied value violates to current column bounds;
+*
+* 2 - implied value violates integrality condition.
+*
+* ALGORITHM
+*
+* Implied column value s[q] satisfies to the current column bounds if
+* the following condition holds:
+*
+* l[q] - eps <= s[q] <= u[q] + eps, (2)
+*
+* where eps is an absolute tolerance for column value. If the column
+* is integral, the following condition also must hold:
+*
+* |s[q] - floor(s[q]+0.5)| <= eps, (3)
+*
+* where floor(s[q]+0.5) is the nearest integer to s[q].
+*
+* If both condition (2) and (3) are satisfied, the column can be fixed
+* at the value s[q], or, if it is integral, at floor(s[q]+0.5).
+* Otherwise, if s[q] violates (2) or (3), the problem has no feasible
+* solution.
+*
+* Note: If s[q] is close to l[q] or u[q], it seems to be reasonable to
+* fix the column at its lower or upper bound, resp. rather than at the
+* implied value. */
+
+int npp_implied_value(NPP *npp, NPPCOL *q, double s)
+{ /* process implied column value */
+ double eps, nint;
+ xassert(npp == npp);
+ /* column must not be fixed */
+ xassert(q->lb < q->ub);
+ /* check integrality */
+ if (q->is_int)
+ { nint = floor(s + 0.5);
+ if (fabs(s - nint) <= 1e-5)
+ s = nint;
+ else
+ return 2;
+ }
+ /* check current column lower bound */
+ if (q->lb != -DBL_MAX)
+ { eps = (q->is_int ? 1e-5 : 1e-5 + 1e-8 * fabs(q->lb));
+ if (s < q->lb - eps) return 1;
+ /* if s[q] is close to l[q], fix column at its lower bound
+ rather than at the implied value */
+ if (s < q->lb + 1e-3 * eps)
+ { q->ub = q->lb;
+ return 0;
+ }
+ }
+ /* check current column upper bound */
+ if (q->ub != +DBL_MAX)
+ { eps = (q->is_int ? 1e-5 : 1e-5 + 1e-8 * fabs(q->ub));
+ if (s > q->ub + eps) return 1;
+ /* if s[q] is close to u[q], fix column at its upper bound
+ rather than at the implied value */
+ if (s > q->ub - 1e-3 * eps)
+ { q->lb = q->ub;
+ return 0;
+ }
+ }
+ /* fix column at the implied value */
+ q->lb = q->ub = s;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_eq_singlet - process row singleton (equality constraint)
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_eq_singlet(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_eq_singlet processes row p, which is equiality
+* constraint having the only non-zero coefficient:
+*
+* a[p,q] x[q] = b. (1)
+*
+* RETURNS
+*
+* 0 - success;
+*
+* 1 - problem has no primal feasible solution;
+*
+* 2 - problem has no integer feasible solution.
+*
+* PROBLEM TRANSFORMATION
+*
+* The equality constraint defines implied value of column q:
+*
+* x[q] = s[q] = b / a[p,q]. (2)
+*
+* If the implied value s[q] satisfies to the column bounds (see the
+* routine npp_implied_value), the column can be fixed at s[q] and
+* removed from the problem. In this case row p becomes redundant, so
+* it can be replaced by equivalent free row and also removed from the
+* problem.
+*
+* Note that the routine removes from the problem only row p. Column q
+* becomes fixed, however, it is kept in the problem.
+*
+* RECOVERING BASIC SOLUTION
+*
+* In solution to the original problem row p is assigned status GLP_NS
+* (active equality constraint), and column q is assigned status GLP_BS
+* (basic column).
+*
+* Multiplier for row p can be computed as follows. In the dual system
+* of the original problem column q corresponds to the following row:
+*
+* sum a[i,q] pi[i] + lambda[q] = c[q] ==>
+* i
+*
+* sum a[i,q] pi[i] + a[p,q] pi[p] + lambda[q] = c[q].
+* i!=p
+*
+* Therefore:
+*
+* 1
+* pi[p] = ------ (c[q] - lambda[q] - sum a[i,q] pi[i]), (3)
+* a[p,q] i!=q
+*
+* where lambda[q] = 0 (since column[q] is basic), and pi[i] for all
+* i != p are known in solution to the transformed problem.
+*
+* Value of column q in solution to the original problem is assigned
+* its implied value s[q].
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Multiplier for row p is computed with formula (3). Value of column
+* q is assigned its implied value s[q].
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is assigned its implied value s[q]. */
+
+struct eq_singlet
+{ /* row singleton (equality constraint) */
+ int p;
+ /* row reference number */
+ int q;
+ /* column reference number */
+ double apq;
+ /* constraint coefficient a[p,q] */
+ double c;
+ /* objective coefficient at x[q] */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[i,q], i != p */
+};
+
+static int rcv_eq_singlet(NPP *npp, void *info);
+
+int npp_eq_singlet(NPP *npp, NPPROW *p)
+{ /* process row singleton (equality constraint) */
+ struct eq_singlet *info;
+ NPPCOL *q;
+ NPPAIJ *aij;
+ NPPLFE *lfe;
+ int ret;
+ double s;
+ /* the row must be singleton equality constraint */
+ xassert(p->lb == p->ub);
+ xassert(p->ptr != NULL && p->ptr->r_next == NULL);
+ /* compute and process implied column value */
+ aij = p->ptr;
+ q = aij->col;
+ s = p->lb / aij->val;
+ ret = npp_implied_value(npp, q, s);
+ xassert(0 <= ret && ret <= 2);
+ if (ret != 0) return ret;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_eq_singlet, sizeof(struct eq_singlet));
+ info->p = p->i;
+ info->q = q->j;
+ info->apq = aij->val;
+ info->c = q->coef;
+ info->ptr = NULL;
+ /* save column coefficients a[i,q], i != p (not needed for MIP
+ solution) */
+ if (npp->sol != GLP_MIP)
+ { for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { if (aij->row == p) continue; /* skip a[p,q] */
+ lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = aij->row->i;
+ lfe->val = aij->val;
+ lfe->next = info->ptr;
+ info->ptr = lfe;
+ }
+ }
+ /* remove the row from the problem */
+ npp_del_row(npp, p);
+ return 0;
+}
+
+static int rcv_eq_singlet(NPP *npp, void *_info)
+{ /* recover row singleton (equality constraint) */
+ struct eq_singlet *info = _info;
+ NPPLFE *lfe;
+ double temp;
+ if (npp->sol == GLP_SOL)
+ { /* column q must be already recovered as GLP_NS */
+ if (npp->c_stat[info->q] != GLP_NS)
+ { npp_error();
+ return 1;
+ }
+ npp->r_stat[info->p] = GLP_NS;
+ npp->c_stat[info->q] = GLP_BS;
+ }
+ if (npp->sol != GLP_MIP)
+ { /* compute multiplier for row p with formula (3) */
+ temp = info->c;
+ for (lfe = info->ptr; lfe != NULL; lfe = lfe->next)
+ temp -= lfe->val * npp->r_pi[lfe->ref];
+ npp->r_pi[info->p] = temp / info->apq;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_lower - process implied column lower bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_implied_lower(NPP *npp, NPPCOL *q, double l);
+*
+* DESCRIPTION
+*
+* For column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] < u[q], the routine npp_implied_lower processes its
+* implied lower bound l'[q]. As the result the current column lower
+* bound may increase. Note that the column is kept in the problem in
+* any case.
+*
+* RETURNS
+*
+* 0 - current column lower bound has not changed;
+*
+* 1 - current column lower bound has changed, but not significantly;
+*
+* 2 - current column lower bound has significantly changed;
+*
+* 3 - column has been fixed on its upper bound;
+*
+* 4 - implied lower bound violates current column upper bound.
+*
+* ALGORITHM
+*
+* If column q is integral, before processing its implied lower bound
+* should be rounded up:
+*
+* ( floor(l'[q]+0.5), if |l'[q] - floor(l'[q]+0.5)| <= eps
+* l'[q] := < (2)
+* ( ceil(l'[q]), otherwise
+*
+* where floor(l'[q]+0.5) is the nearest integer to l'[q], ceil(l'[q])
+* is smallest integer not less than l'[q], and eps is an absolute
+* tolerance for column value.
+*
+* Processing implied column lower bound l'[q] includes the following
+* cases:
+*
+* 1) if l'[q] < l[q] + eps, implied lower bound is redundant;
+*
+* 2) if l[q] + eps <= l[q] <= u[q] + eps, current column lower bound
+* l[q] can be strengthened by replacing it with l'[q]. If in this
+* case new column lower bound becomes close to current column upper
+* bound u[q], the column can be fixed on its upper bound;
+*
+* 3) if l'[q] > u[q] + eps, implied lower bound violates current
+* column upper bound u[q], in which case the problem has no primal
+* feasible solution. */
+
+int npp_implied_lower(NPP *npp, NPPCOL *q, double l)
+{ /* process implied column lower bound */
+ int ret;
+ double eps, nint;
+ xassert(npp == npp);
+ /* column must not be fixed */
+ xassert(q->lb < q->ub);
+ /* implied lower bound must be finite */
+ xassert(l != -DBL_MAX);
+ /* if column is integral, round up l'[q] */
+ if (q->is_int)
+ { nint = floor(l + 0.5);
+ if (fabs(l - nint) <= 1e-5)
+ l = nint;
+ else
+ l = ceil(l);
+ }
+ /* check current column lower bound */
+ if (q->lb != -DBL_MAX)
+ { eps = (q->is_int ? 1e-3 : 1e-3 + 1e-6 * fabs(q->lb));
+ if (l < q->lb + eps)
+ { ret = 0; /* redundant */
+ goto done;
+ }
+ }
+ /* check current column upper bound */
+ if (q->ub != +DBL_MAX)
+ { eps = (q->is_int ? 1e-5 : 1e-5 + 1e-8 * fabs(q->ub));
+ if (l > q->ub + eps)
+ { ret = 4; /* infeasible */
+ goto done;
+ }
+ /* if l'[q] is close to u[q], fix column at its upper bound */
+ if (l > q->ub - 1e-3 * eps)
+ { q->lb = q->ub;
+ ret = 3; /* fixed */
+ goto done;
+ }
+ }
+ /* check if column lower bound changes significantly */
+ if (q->lb == -DBL_MAX)
+ ret = 2; /* significantly */
+ else if (q->is_int && l > q->lb + 0.5)
+ ret = 2; /* significantly */
+ else if (l > q->lb + 0.30 * (1.0 + fabs(q->lb)))
+ ret = 2; /* significantly */
+ else
+ ret = 1; /* not significantly */
+ /* set new column lower bound */
+ q->lb = l;
+done: return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_upper - process implied column upper bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_implied_upper(NPP *npp, NPPCOL *q, double u);
+*
+* DESCRIPTION
+*
+* For column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] < u[q], the routine npp_implied_upper processes its
+* implied upper bound u'[q]. As the result the current column upper
+* bound may decrease. Note that the column is kept in the problem in
+* any case.
+*
+* RETURNS
+*
+* 0 - current column upper bound has not changed;
+*
+* 1 - current column upper bound has changed, but not significantly;
+*
+* 2 - current column upper bound has significantly changed;
+*
+* 3 - column has been fixed on its lower bound;
+*
+* 4 - implied upper bound violates current column lower bound.
+*
+* ALGORITHM
+*
+* If column q is integral, before processing its implied upper bound
+* should be rounded down:
+*
+* ( floor(u'[q]+0.5), if |u'[q] - floor(l'[q]+0.5)| <= eps
+* u'[q] := < (2)
+* ( floor(l'[q]), otherwise
+*
+* where floor(u'[q]+0.5) is the nearest integer to u'[q],
+* floor(u'[q]) is largest integer not greater than u'[q], and eps is
+* an absolute tolerance for column value.
+*
+* Processing implied column upper bound u'[q] includes the following
+* cases:
+*
+* 1) if u'[q] > u[q] - eps, implied upper bound is redundant;
+*
+* 2) if l[q] - eps <= u[q] <= u[q] - eps, current column upper bound
+* u[q] can be strengthened by replacing it with u'[q]. If in this
+* case new column upper bound becomes close to current column lower
+* bound, the column can be fixed on its lower bound;
+*
+* 3) if u'[q] < l[q] - eps, implied upper bound violates current
+* column lower bound l[q], in which case the problem has no primal
+* feasible solution. */
+
+int npp_implied_upper(NPP *npp, NPPCOL *q, double u)
+{ int ret;
+ double eps, nint;
+ xassert(npp == npp);
+ /* column must not be fixed */
+ xassert(q->lb < q->ub);
+ /* implied upper bound must be finite */
+ xassert(u != +DBL_MAX);
+ /* if column is integral, round down u'[q] */
+ if (q->is_int)
+ { nint = floor(u + 0.5);
+ if (fabs(u - nint) <= 1e-5)
+ u = nint;
+ else
+ u = floor(u);
+ }
+ /* check current column upper bound */
+ if (q->ub != +DBL_MAX)
+ { eps = (q->is_int ? 1e-3 : 1e-3 + 1e-6 * fabs(q->ub));
+ if (u > q->ub - eps)
+ { ret = 0; /* redundant */
+ goto done;
+ }
+ }
+ /* check current column lower bound */
+ if (q->lb != -DBL_MAX)
+ { eps = (q->is_int ? 1e-5 : 1e-5 + 1e-8 * fabs(q->lb));
+ if (u < q->lb - eps)
+ { ret = 4; /* infeasible */
+ goto done;
+ }
+ /* if u'[q] is close to l[q], fix column at its lower bound */
+ if (u < q->lb + 1e-3 * eps)
+ { q->ub = q->lb;
+ ret = 3; /* fixed */
+ goto done;
+ }
+ }
+ /* check if column upper bound changes significantly */
+ if (q->ub == +DBL_MAX)
+ ret = 2; /* significantly */
+ else if (q->is_int && u < q->ub - 0.5)
+ ret = 2; /* significantly */
+ else if (u < q->ub - 0.30 * (1.0 + fabs(q->ub)))
+ ret = 2; /* significantly */
+ else
+ ret = 1; /* not significantly */
+ /* set new column upper bound */
+ q->ub = u;
+done: return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_ineq_singlet - process row singleton (inequality constraint)
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_ineq_singlet(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_ineq_singlet processes row p, which is inequality
+* constraint having the only non-zero coefficient:
+*
+* L[p] <= a[p,q] * x[q] <= U[p], (1)
+*
+* where L[p] < U[p], L[p] > -oo and/or U[p] < +oo.
+*
+* RETURNS
+*
+* 0 - current column bounds have not changed;
+*
+* 1 - current column bounds have changed, but not significantly;
+*
+* 2 - current column bounds have significantly changed;
+*
+* 3 - column has been fixed on its lower or upper bound;
+*
+* 4 - problem has no primal feasible solution.
+*
+* PROBLEM TRANSFORMATION
+*
+* Inequality constraint (1) defines implied bounds of column q:
+*
+* ( L[p] / a[p,q], if a[p,q] > 0
+* l'[q] = < (2)
+* ( U[p] / a[p,q], if a[p,q] < 0
+*
+* ( U[p] / a[p,q], if a[p,q] > 0
+* u'[q] = < (3)
+* ( L[p] / a[p,q], if a[p,q] < 0
+*
+* If these implied bounds do not violate current bounds of column q:
+*
+* l[q] <= x[q] <= u[q], (4)
+*
+* they can be used to strengthen the current column bounds:
+*
+* l[q] := max(l[q], l'[q]), (5)
+*
+* u[q] := min(u[q], u'[q]). (6)
+*
+* (See the routines npp_implied_lower and npp_implied_upper.)
+*
+* Once bounds of row p (1) have been carried over column q, the row
+* becomes redundant, so it can be replaced by equivalent free row and
+* removed from the problem.
+*
+* Note that the routine removes from the problem only row p. Column q,
+* even it has been fixed, is kept in the problem.
+*
+* RECOVERING BASIC SOLUTION
+*
+* Note that the row in the dual system corresponding to column q is
+* the following:
+*
+* sum a[i,q] pi[i] + lambda[q] = c[q] ==>
+* i
+* (7)
+* sum a[i,q] pi[i] + a[p,q] pi[p] + lambda[q] = c[q],
+* i!=p
+*
+* where pi[i] for all i != p are known in solution to the transformed
+* problem. Row p does not exist in the transformed problem, so it has
+* zero multiplier there. This allows computing multiplier for column q
+* in solution to the transformed problem:
+*
+* lambda~[q] = c[q] - sum a[i,q] pi[i]. (8)
+* i!=p
+*
+* Let in solution to the transformed problem column q be non-basic
+* with lower bound active (GLP_NL, lambda~[q] >= 0), and this lower
+* bound be implied one l'[q]. From the original problem's standpoint
+* this then means that actually the original column lower bound l[q]
+* is inactive, and active is that row bound L[p] or U[p] that defines
+* the implied bound l'[q] (2). In this case in solution to the
+* original problem column q is assigned status GLP_BS while row p is
+* assigned status GLP_NL (if a[p,q] > 0) or GLP_NU (if a[p,q] < 0).
+* Since now column q is basic, its multiplier lambda[q] is zero. This
+* allows using (7) and (8) to find multiplier for row p in solution to
+* the original problem:
+*
+* 1
+* pi[p] = ------ (c[q] - sum a[i,q] pi[i]) = lambda~[q] / a[p,q] (9)
+* a[p,q] i!=p
+*
+* Now let in solution to the transformed problem column q be non-basic
+* with upper bound active (GLP_NU, lambda~[q] <= 0), and this upper
+* bound be implied one u'[q]. As in the previous case this then means
+* that from the original problem's standpoint actually the original
+* column upper bound u[q] is inactive, and active is that row bound
+* L[p] or U[p] that defines the implied bound u'[q] (3). In this case
+* in solution to the original problem column q is assigned status
+* GLP_BS, row p is assigned status GLP_NU (if a[p,q] > 0) or GLP_NL
+* (if a[p,q] < 0), and its multiplier is computed with formula (9).
+*
+* Strengthening bounds of column q according to (5) and (6) may make
+* it fixed. Thus, if in solution to the transformed problem column q is
+* non-basic and fixed (GLP_NS), we can suppose that if lambda~[q] > 0,
+* column q has active lower bound (GLP_NL), and if lambda~[q] < 0,
+* column q has active upper bound (GLP_NU), reducing this case to two
+* previous ones. If, however, lambda~[q] is close to zero or
+* corresponding bound of row p does not exist (this may happen if
+* lambda~[q] has wrong sign due to round-off errors, in which case it
+* is expected to be close to zero, since solution is assumed to be dual
+* feasible), column q can be assigned status GLP_BS (basic), and row p
+* can be made active on its existing bound. In the latter case row
+* multiplier pi[p] computed with formula (9) will be also close to
+* zero, and dual feasibility will be kept.
+*
+* In all other cases, namely, if in solution to the transformed
+* problem column q is basic (GLP_BS), or non-basic with original lower
+* bound l[q] active (GLP_NL), or non-basic with original upper bound
+* u[q] active (GLP_NU), constraint (1) is inactive. So in solution to
+* the original problem status of column q remains unchanged, row p is
+* assigned status GLP_BS, and its multiplier pi[p] is assigned zero
+* value.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* First, value of multiplier for column q in solution to the original
+* problem is computed with formula (8). If lambda~[q] > 0 and column q
+* has implied lower bound, or if lambda~[q] < 0 and column q has
+* implied upper bound, this means that from the original problem's
+* standpoint actually row p has corresponding active bound, in which
+* case its multiplier pi[p] is computed with formula (9). In other
+* cases, when the sign of lambda~[q] corresponds to original bound of
+* column q, or when lambda~[q] =~ 0, value of row multiplier pi[p] is
+* assigned zero value.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct ineq_singlet
+{ /* row singleton (inequality constraint) */
+ int p;
+ /* row reference number */
+ int q;
+ /* column reference number */
+ double apq;
+ /* constraint coefficient a[p,q] */
+ double c;
+ /* objective coefficient at x[q] */
+ double lb;
+ /* row lower bound */
+ double ub;
+ /* row upper bound */
+ char lb_changed;
+ /* this flag is set if column lower bound was changed */
+ char ub_changed;
+ /* this flag is set if column upper bound was changed */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[i,q], i != p */
+};
+
+static int rcv_ineq_singlet(NPP *npp, void *info);
+
+int npp_ineq_singlet(NPP *npp, NPPROW *p)
+{ /* process row singleton (inequality constraint) */
+ struct ineq_singlet *info;
+ NPPCOL *q;
+ NPPAIJ *apq, *aij;
+ NPPLFE *lfe;
+ int lb_changed, ub_changed;
+ double ll, uu;
+ /* the row must be singleton inequality constraint */
+ xassert(p->lb != -DBL_MAX || p->ub != +DBL_MAX);
+ xassert(p->lb < p->ub);
+ xassert(p->ptr != NULL && p->ptr->r_next == NULL);
+ /* compute implied column bounds */
+ apq = p->ptr;
+ q = apq->col;
+ xassert(q->lb < q->ub);
+ if (apq->val > 0.0)
+ { ll = (p->lb == -DBL_MAX ? -DBL_MAX : p->lb / apq->val);
+ uu = (p->ub == +DBL_MAX ? +DBL_MAX : p->ub / apq->val);
+ }
+ else
+ { ll = (p->ub == +DBL_MAX ? -DBL_MAX : p->ub / apq->val);
+ uu = (p->lb == -DBL_MAX ? +DBL_MAX : p->lb / apq->val);
+ }
+ /* process implied column lower bound */
+ if (ll == -DBL_MAX)
+ lb_changed = 0;
+ else
+ { lb_changed = npp_implied_lower(npp, q, ll);
+ xassert(0 <= lb_changed && lb_changed <= 4);
+ if (lb_changed == 4) return 4; /* infeasible */
+ }
+ /* process implied column upper bound */
+ if (uu == +DBL_MAX)
+ ub_changed = 0;
+ else if (lb_changed == 3)
+ { /* column was fixed on its upper bound due to l'[q] = u[q] */
+ /* note that L[p] < U[p], so l'[q] = u[q] < u'[q] */
+ ub_changed = 0;
+ }
+ else
+ { ub_changed = npp_implied_upper(npp, q, uu);
+ xassert(0 <= ub_changed && ub_changed <= 4);
+ if (ub_changed == 4) return 4; /* infeasible */
+ }
+ /* if neither lower nor upper column bound was changed, the row
+ is originally redundant and can be replaced by free row */
+ if (!lb_changed && !ub_changed)
+ { p->lb = -DBL_MAX, p->ub = +DBL_MAX;
+ npp_free_row(npp, p);
+ return 0;
+ }
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_ineq_singlet, sizeof(struct ineq_singlet));
+ info->p = p->i;
+ info->q = q->j;
+ info->apq = apq->val;
+ info->c = q->coef;
+ info->lb = p->lb;
+ info->ub = p->ub;
+ info->lb_changed = (char)lb_changed;
+ info->ub_changed = (char)ub_changed;
+ info->ptr = NULL;
+ /* save column coefficients a[i,q], i != p (not needed for MIP
+ solution) */
+ if (npp->sol != GLP_MIP)
+ { for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { if (aij == apq) continue; /* skip a[p,q] */
+ lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = aij->row->i;
+ lfe->val = aij->val;
+ lfe->next = info->ptr;
+ info->ptr = lfe;
+ }
+ }
+ /* remove the row from the problem */
+ npp_del_row(npp, p);
+ return lb_changed >= ub_changed ? lb_changed : ub_changed;
+}
+
+static int rcv_ineq_singlet(NPP *npp, void *_info)
+{ /* recover row singleton (inequality constraint) */
+ struct ineq_singlet *info = _info;
+ NPPLFE *lfe;
+ double lambda;
+ if (npp->sol == GLP_MIP) goto done;
+ /* compute lambda~[q] in solution to the transformed problem
+ with formula (8) */
+ lambda = info->c;
+ for (lfe = info->ptr; lfe != NULL; lfe = lfe->next)
+ lambda -= lfe->val * npp->r_pi[lfe->ref];
+ if (npp->sol == GLP_SOL)
+ { /* recover basic solution */
+ if (npp->c_stat[info->q] == GLP_BS)
+ { /* column q is basic, so row p is inactive */
+ npp->r_stat[info->p] = GLP_BS;
+ npp->r_pi[info->p] = 0.0;
+ }
+ else if (npp->c_stat[info->q] == GLP_NL)
+nl: { /* column q is non-basic with lower bound active */
+ if (info->lb_changed)
+ { /* it is implied bound, so actually row p is active
+ while column q is basic */
+ npp->r_stat[info->p] =
+ (char)(info->apq > 0.0 ? GLP_NL : GLP_NU);
+ npp->c_stat[info->q] = GLP_BS;
+ npp->r_pi[info->p] = lambda / info->apq;
+ }
+ else
+ { /* it is original bound, so row p is inactive */
+ npp->r_stat[info->p] = GLP_BS;
+ npp->r_pi[info->p] = 0.0;
+ }
+ }
+ else if (npp->c_stat[info->q] == GLP_NU)
+nu: { /* column q is non-basic with upper bound active */
+ if (info->ub_changed)
+ { /* it is implied bound, so actually row p is active
+ while column q is basic */
+ npp->r_stat[info->p] =
+ (char)(info->apq > 0.0 ? GLP_NU : GLP_NL);
+ npp->c_stat[info->q] = GLP_BS;
+ npp->r_pi[info->p] = lambda / info->apq;
+ }
+ else
+ { /* it is original bound, so row p is inactive */
+ npp->r_stat[info->p] = GLP_BS;
+ npp->r_pi[info->p] = 0.0;
+ }
+ }
+ else if (npp->c_stat[info->q] == GLP_NS)
+ { /* column q is non-basic and fixed; note, however, that in
+ in the original problem it is non-fixed */
+ if (lambda > +1e-7)
+ { if (info->apq > 0.0 && info->lb != -DBL_MAX ||
+ info->apq < 0.0 && info->ub != +DBL_MAX ||
+ !info->lb_changed)
+ { /* either corresponding bound of row p exists or
+ column q remains non-basic with its original lower
+ bound active */
+ npp->c_stat[info->q] = GLP_NL;
+ goto nl;
+ }
+ }
+ if (lambda < -1e-7)
+ { if (info->apq > 0.0 && info->ub != +DBL_MAX ||
+ info->apq < 0.0 && info->lb != -DBL_MAX ||
+ !info->ub_changed)
+ { /* either corresponding bound of row p exists or
+ column q remains non-basic with its original upper
+ bound active */
+ npp->c_stat[info->q] = GLP_NU;
+ goto nu;
+ }
+ }
+ /* either lambda~[q] is close to zero, or corresponding
+ bound of row p does not exist, because lambda~[q] has
+ wrong sign due to round-off errors; in the latter case
+ lambda~[q] is also assumed to be close to zero; so, we
+ can make row p active on its existing bound and column q
+ basic; pi[p] will have wrong sign, but it also will be
+ close to zero (rarus casus of dual degeneracy) */
+ if (info->lb != -DBL_MAX && info->ub == +DBL_MAX)
+ { /* row lower bound exists, but upper bound doesn't */
+ npp->r_stat[info->p] = GLP_NL;
+ }
+ else if (info->lb == -DBL_MAX && info->ub != +DBL_MAX)
+ { /* row upper bound exists, but lower bound doesn't */
+ npp->r_stat[info->p] = GLP_NU;
+ }
+ else if (info->lb != -DBL_MAX && info->ub != +DBL_MAX)
+ { /* both row lower and upper bounds exist */
+ /* to choose proper active row bound we should not use
+ lambda~[q], because its value being close to zero is
+ unreliable; so we choose that bound which provides
+ primal feasibility for original constraint (1) */
+ if (info->apq * npp->c_value[info->q] <=
+ 0.5 * (info->lb + info->ub))
+ npp->r_stat[info->p] = GLP_NL;
+ else
+ npp->r_stat[info->p] = GLP_NU;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ npp->c_stat[info->q] = GLP_BS;
+ npp->r_pi[info->p] = lambda / info->apq;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ if (npp->sol == GLP_IPT)
+ { /* recover interior-point solution */
+ if (lambda > +DBL_EPSILON && info->lb_changed ||
+ lambda < -DBL_EPSILON && info->ub_changed)
+ { /* actually row p has corresponding active bound */
+ npp->r_pi[info->p] = lambda / info->apq;
+ }
+ else
+ { /* either bounds of column q are both inactive or its
+ original bound is active */
+ npp->r_pi[info->p] = 0.0;
+ }
+ }
+done: return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_slack - process column singleton (implied slack variable)
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_implied_slack(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_implied_slack processes column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] < u[q], having the only non-zero coefficient in row p,
+* which is equality constraint:
+*
+* sum a[p,j] x[j] + a[p,q] x[q] = b. (2)
+* j!=q
+*
+* PROBLEM TRANSFORMATION
+*
+* (If x[q] is integral, this transformation must not be used.)
+*
+* The term a[p,q] x[q] in constraint (2) can be considered as a slack
+* variable that allows to carry bounds of column q over row p and then
+* remove column q from the problem.
+*
+* Constraint (2) can be written as follows:
+*
+* sum a[p,j] x[j] = b - a[p,q] x[q]. (3)
+* j!=q
+*
+* According to (1) constraint (3) is equivalent to the following
+* inequality constraint:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p], (4)
+* j!=q
+*
+* where
+*
+* ( b - a[p,q] u[q], if a[p,q] > 0
+* L[p] = < (5)
+* ( b - a[p,q] l[q], if a[p,q] < 0
+*
+* ( b - a[p,q] l[q], if a[p,q] > 0
+* U[p] = < (6)
+* ( b - a[p,q] u[q], if a[p,q] < 0
+*
+* From (2) it follows that:
+*
+* 1
+* x[q] = ------ (b - sum a[p,j] x[j]). (7)
+* a[p,q] j!=q
+*
+* In order to eliminate x[q] from the objective row we substitute it
+* from (6) to that row:
+*
+* z = sum c[j] x[j] + c[q] x[q] + c[0] =
+* j!=q
+* 1
+* = sum c[j] x[j] + c[q] [------ (b - sum a[p,j] x[j])] + c0 =
+* j!=q a[p,q] j!=q
+*
+* = sum c~[j] x[j] + c~[0],
+* j!=q
+* a[p,j] b
+* c~[j] = c[j] - c[q] ------, c~0 = c0 - c[q] ------ (8)
+* a[p,q] a[p,q]
+*
+* are values of objective coefficients and constant term, resp., in
+* the transformed problem.
+*
+* Note that column q is column singleton, so in the dual system of the
+* original problem it corresponds to the following row singleton:
+*
+* a[p,q] pi[p] + lambda[q] = c[q]. (9)
+*
+* In the transformed problem row (9) would be the following:
+*
+* a[p,q] pi~[p] + lambda[q] = c~[q] = 0. (10)
+*
+* Subtracting (10) from (9) we have:
+*
+* a[p,q] (pi[p] - pi~[p]) = c[q]
+*
+* that gives the following formula to compute multiplier for row p in
+* solution to the original problem using its value in solution to the
+* transformed problem:
+*
+* pi[p] = pi~[p] + c[q] / a[p,q]. (11)
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of column q in solution to the original problem is defined
+* by status of row p in solution to the transformed problem and the
+* sign of coefficient a[p,q] in the original inequality constraint (2)
+* as follows:
+*
+* +-----------------------+---------+--------------------+
+* | Status of row p | Sign of | Status of column q |
+* | (transformed problem) | a[p,q] | (original problem) |
+* +-----------------------+---------+--------------------+
+* | GLP_BS | + / - | GLP_BS |
+* | GLP_NL | + | GLP_NU |
+* | GLP_NL | - | GLP_NL |
+* | GLP_NU | + | GLP_NL |
+* | GLP_NU | - | GLP_NU |
+* | GLP_NF | + / - | GLP_NF |
+* +-----------------------+---------+--------------------+
+*
+* Value of column q is computed with formula (7). Since originally row
+* p is equality constraint, its status is assigned GLP_NS, and value of
+* its multiplier pi[p] is computed with formula (11).
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of column q is computed with formula (7). Row multiplier value
+* pi[p] is computed with formula (11).
+*
+* RECOVERING MIP SOLUTION
+*
+* Value of column q is computed with formula (7). */
+
+struct implied_slack
+{ /* column singleton (implied slack variable) */
+ int p;
+ /* row reference number */
+ int q;
+ /* column reference number */
+ double apq;
+ /* constraint coefficient a[p,q] */
+ double b;
+ /* right-hand side of original equality constraint */
+ double c;
+ /* original objective coefficient at x[q] */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[p,j], j != q */
+};
+
+static int rcv_implied_slack(NPP *npp, void *info);
+
+void npp_implied_slack(NPP *npp, NPPCOL *q)
+{ /* process column singleton (implied slack variable) */
+ struct implied_slack *info;
+ NPPROW *p;
+ NPPAIJ *aij;
+ NPPLFE *lfe;
+ /* the column must be non-integral non-fixed singleton */
+ xassert(!q->is_int);
+ xassert(q->lb < q->ub);
+ xassert(q->ptr != NULL && q->ptr->c_next == NULL);
+ /* corresponding row must be equality constraint */
+ aij = q->ptr;
+ p = aij->row;
+ xassert(p->lb == p->ub);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_implied_slack, sizeof(struct implied_slack));
+ info->p = p->i;
+ info->q = q->j;
+ info->apq = aij->val;
+ info->b = p->lb;
+ info->c = q->coef;
+ info->ptr = NULL;
+ /* save row coefficients a[p,j], j != q, and substitute x[q]
+ into the objective row */
+ for (aij = p->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->col == q) continue; /* skip a[p,q] */
+ lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = aij->col->j;
+ lfe->val = aij->val;
+ lfe->next = info->ptr;
+ info->ptr = lfe;
+ aij->col->coef -= info->c * (aij->val / info->apq);
+ }
+ npp->c0 += info->c * (info->b / info->apq);
+ /* compute new row bounds */
+ if (info->apq > 0.0)
+ { p->lb = (q->ub == +DBL_MAX ?
+ -DBL_MAX : info->b - info->apq * q->ub);
+ p->ub = (q->lb == -DBL_MAX ?
+ +DBL_MAX : info->b - info->apq * q->lb);
+ }
+ else
+ { p->lb = (q->lb == -DBL_MAX ?
+ -DBL_MAX : info->b - info->apq * q->lb);
+ p->ub = (q->ub == +DBL_MAX ?
+ +DBL_MAX : info->b - info->apq * q->ub);
+ }
+ /* remove the column from the problem */
+ npp_del_col(npp, q);
+ return;
+}
+
+static int rcv_implied_slack(NPP *npp, void *_info)
+{ /* recover column singleton (implied slack variable) */
+ struct implied_slack *info = _info;
+ NPPLFE *lfe;
+ double temp;
+ if (npp->sol == GLP_SOL)
+ { /* assign statuses to row p and column q */
+ if (npp->r_stat[info->p] == GLP_BS ||
+ npp->r_stat[info->p] == GLP_NF)
+ npp->c_stat[info->q] = npp->r_stat[info->p];
+ else if (npp->r_stat[info->p] == GLP_NL)
+ npp->c_stat[info->q] =
+ (char)(info->apq > 0.0 ? GLP_NU : GLP_NL);
+ else if (npp->r_stat[info->p] == GLP_NU)
+ npp->c_stat[info->q] =
+ (char)(info->apq > 0.0 ? GLP_NL : GLP_NU);
+ else
+ { npp_error();
+ return 1;
+ }
+ npp->r_stat[info->p] = GLP_NS;
+ }
+ if (npp->sol != GLP_MIP)
+ { /* compute multiplier for row p */
+ npp->r_pi[info->p] += info->c / info->apq;
+ }
+ /* compute value of column q */
+ temp = info->b;
+ for (lfe = info->ptr; lfe != NULL; lfe = lfe->next)
+ temp -= lfe->val * npp->c_value[lfe->ref];
+ npp->c_value[info->q] = temp / info->apq;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_free - process column singleton (implied free variable)
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_implied_free(NPP *npp, NPPCOL *q);
+*
+* DESCRIPTION
+*
+* The routine npp_implied_free processes column q:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* having non-zero coefficient in the only row p, which is inequality
+* constraint:
+*
+* L[p] <= sum a[p,j] x[j] + a[p,q] x[q] <= U[p], (2)
+* j!=q
+*
+* where l[q] < u[q], L[p] < U[p], L[p] > -oo and/or U[p] < +oo.
+*
+* RETURNS
+*
+* 0 - success;
+*
+* 1 - column lower and/or upper bound(s) can be active;
+*
+* 2 - problem has no dual feasible solution.
+*
+* PROBLEM TRANSFORMATION
+*
+* Constraint (2) can be written as follows:
+*
+* L[p] - sum a[p,j] x[j] <= a[p,q] x[q] <= U[p] - sum a[p,j] x[j],
+* j!=q j!=q
+*
+* from which it follows that:
+*
+* alfa <= a[p,q] x[q] <= beta, (3)
+*
+* where
+*
+* alfa = inf(L[p] - sum a[p,j] x[j]) =
+* j!=q
+*
+* = L[p] - sup sum a[p,j] x[j] = (4)
+* j!=q
+*
+* = L[p] - sum a[p,j] u[j] - sum a[p,j] l[j],
+* j in Jp j in Jn
+*
+* beta = sup(L[p] - sum a[p,j] x[j]) =
+* j!=q
+*
+* = L[p] - inf sum a[p,j] x[j] = (5)
+* j!=q
+*
+* = L[p] - sum a[p,j] l[j] - sum a[p,j] u[j],
+* j in Jp j in Jn
+*
+* Jp = {j != q: a[p,j] > 0}, Jn = {j != q: a[p,j] < 0}. (6)
+*
+* Inequality (3) defines implied bounds of variable x[q]:
+*
+* l'[q] <= x[q] <= u'[q], (7)
+*
+* where
+*
+* ( alfa / a[p,q], if a[p,q] > 0
+* l'[q] = < (8a)
+* ( beta / a[p,q], if a[p,q] < 0
+*
+* ( beta / a[p,q], if a[p,q] > 0
+* u'[q] = < (8b)
+* ( alfa / a[p,q], if a[p,q] < 0
+*
+* Thus, if l'[q] > l[q] - eps and u'[q] < u[q] + eps, where eps is
+* an absolute tolerance for column value, column bounds (1) cannot be
+* active, in which case column q can be replaced by equivalent free
+* (unbounded) column.
+*
+* Note that column q is column singleton, so in the dual system of the
+* original problem it corresponds to the following row singleton:
+*
+* a[p,q] pi[p] + lambda[q] = c[q], (9)
+*
+* from which it follows that:
+*
+* pi[p] = (c[q] - lambda[q]) / a[p,q]. (10)
+*
+* Let x[q] be implied free (unbounded) variable. Then column q can be
+* only basic, so its multiplier lambda[q] is equal to zero, and from
+* (10) we have:
+*
+* pi[p] = c[q] / a[p,q]. (11)
+*
+* There are possible three cases:
+*
+* 1) pi[p] < -eps, where eps is an absolute tolerance for row
+* multiplier. In this case, to provide dual feasibility of the
+* original problem, row p must be active on its lower bound, and
+* if its lower bound does not exist (L[p] = -oo), the problem has
+* no dual feasible solution;
+*
+* 2) pi[p] > +eps. In this case row p must be active on its upper
+* bound, and if its upper bound does not exist (U[p] = +oo), the
+* problem has no dual feasible solution;
+*
+* 3) -eps <= pi[p] <= +eps. In this case any (either lower or upper)
+* bound of row p can be active, because this does not affect dual
+* feasibility.
+*
+* Thus, in all three cases original inequality constraint (2) can be
+* replaced by equality constraint, where the right-hand side is either
+* lower or upper bound of row p, and bounds of column q can be removed
+* that makes it free (unbounded). (May note that this transformation
+* can be followed by transformation "Column singleton (implied slack
+* variable)" performed by the routine npp_implied_slack.)
+*
+* RECOVERING BASIC SOLUTION
+*
+* Status of row p in solution to the original problem is determined
+* by its status in solution to the transformed problem and its bound,
+* which was choosen to be active:
+*
+* +-----------------------+--------+--------------------+
+* | Status of row p | Active | Status of row p |
+* | (transformed problem) | bound | (original problem) |
+* +-----------------------+--------+--------------------+
+* | GLP_BS | L[p] | GLP_BS |
+* | GLP_BS | U[p] | GLP_BS |
+* | GLP_NS | L[p] | GLP_NL |
+* | GLP_NS | U[p] | GLP_NU |
+* +-----------------------+--------+--------------------+
+*
+* Value of row multiplier pi[p] (as well as value of column q) in
+* solution to the original problem is the same as in solution to the
+* transformed problem.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of row multiplier pi[p] in solution to the original problem is
+* the same as in solution to the transformed problem.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct implied_free
+{ /* column singleton (implied free variable) */
+ int p;
+ /* row reference number */
+ char stat;
+ /* row status:
+ GLP_NL - active constraint on lower bound
+ GLP_NU - active constraint on upper bound */
+};
+
+static int rcv_implied_free(NPP *npp, void *info);
+
+int npp_implied_free(NPP *npp, NPPCOL *q)
+{ /* process column singleton (implied free variable) */
+ struct implied_free *info;
+ NPPROW *p;
+ NPPAIJ *apq, *aij;
+ double alfa, beta, l, u, pi, eps;
+ /* the column must be non-fixed singleton */
+ xassert(q->lb < q->ub);
+ xassert(q->ptr != NULL && q->ptr->c_next == NULL);
+ /* corresponding row must be inequality constraint */
+ apq = q->ptr;
+ p = apq->row;
+ xassert(p->lb != -DBL_MAX || p->ub != +DBL_MAX);
+ xassert(p->lb < p->ub);
+ /* compute alfa */
+ alfa = p->lb;
+ if (alfa != -DBL_MAX)
+ { for (aij = p->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij == apq) continue; /* skip a[p,q] */
+ if (aij->val > 0.0)
+ { if (aij->col->ub == +DBL_MAX)
+ { alfa = -DBL_MAX;
+ break;
+ }
+ alfa -= aij->val * aij->col->ub;
+ }
+ else /* < 0.0 */
+ { if (aij->col->lb == -DBL_MAX)
+ { alfa = -DBL_MAX;
+ break;
+ }
+ alfa -= aij->val * aij->col->lb;
+ }
+ }
+ }
+ /* compute beta */
+ beta = p->ub;
+ if (beta != +DBL_MAX)
+ { for (aij = p->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij == apq) continue; /* skip a[p,q] */
+ if (aij->val > 0.0)
+ { if (aij->col->lb == -DBL_MAX)
+ { beta = +DBL_MAX;
+ break;
+ }
+ beta -= aij->val * aij->col->lb;
+ }
+ else /* < 0.0 */
+ { if (aij->col->ub == +DBL_MAX)
+ { beta = +DBL_MAX;
+ break;
+ }
+ beta -= aij->val * aij->col->ub;
+ }
+ }
+ }
+ /* compute implied column lower bound l'[q] */
+ if (apq->val > 0.0)
+ l = (alfa == -DBL_MAX ? -DBL_MAX : alfa / apq->val);
+ else /* < 0.0 */
+ l = (beta == +DBL_MAX ? -DBL_MAX : beta / apq->val);
+ /* compute implied column upper bound u'[q] */
+ if (apq->val > 0.0)
+ u = (beta == +DBL_MAX ? +DBL_MAX : beta / apq->val);
+ else
+ u = (alfa == -DBL_MAX ? +DBL_MAX : alfa / apq->val);
+ /* check if column lower bound l[q] can be active */
+ if (q->lb != -DBL_MAX)
+ { eps = 1e-9 + 1e-12 * fabs(q->lb);
+ if (l < q->lb - eps) return 1; /* yes, it can */
+ }
+ /* check if column upper bound u[q] can be active */
+ if (q->ub != +DBL_MAX)
+ { eps = 1e-9 + 1e-12 * fabs(q->ub);
+ if (u > q->ub + eps) return 1; /* yes, it can */
+ }
+ /* okay; make column q free (unbounded) */
+ q->lb = -DBL_MAX, q->ub = +DBL_MAX;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_implied_free, sizeof(struct implied_free));
+ info->p = p->i;
+ info->stat = -1;
+ /* compute row multiplier pi[p] */
+ pi = q->coef / apq->val;
+ /* check dual feasibility for row p */
+ if (pi > +DBL_EPSILON)
+ { /* lower bound L[p] must be active */
+ if (p->lb != -DBL_MAX)
+nl: { info->stat = GLP_NL;
+ p->ub = p->lb;
+ }
+ else
+ { if (pi > +1e-5) return 2; /* dual infeasibility */
+ /* take a chance on U[p] */
+ xassert(p->ub != +DBL_MAX);
+ goto nu;
+ }
+ }
+ else if (pi < -DBL_EPSILON)
+ { /* upper bound U[p] must be active */
+ if (p->ub != +DBL_MAX)
+nu: { info->stat = GLP_NU;
+ p->lb = p->ub;
+ }
+ else
+ { if (pi < -1e-5) return 2; /* dual infeasibility */
+ /* take a chance on L[p] */
+ xassert(p->lb != -DBL_MAX);
+ goto nl;
+ }
+ }
+ else
+ { /* any bound (either L[p] or U[p]) can be made active */
+ if (p->ub == +DBL_MAX)
+ { xassert(p->lb != -DBL_MAX);
+ goto nl;
+ }
+ if (p->lb == -DBL_MAX)
+ { xassert(p->ub != +DBL_MAX);
+ goto nu;
+ }
+ if (fabs(p->lb) <= fabs(p->ub)) goto nl; else goto nu;
+ }
+ return 0;
+}
+
+static int rcv_implied_free(NPP *npp, void *_info)
+{ /* recover column singleton (implied free variable) */
+ struct implied_free *info = _info;
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] == GLP_BS)
+ npp->r_stat[info->p] = GLP_BS;
+ else if (npp->r_stat[info->p] == GLP_NS)
+ { xassert(info->stat == GLP_NL || info->stat == GLP_NU);
+ npp->r_stat[info->p] = info->stat;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_eq_doublet - process row doubleton (equality constraint)
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* NPPCOL *npp_eq_doublet(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_eq_doublet processes row p, which is equality
+* constraint having exactly two non-zero coefficients:
+*
+* a[p,q] x[q] + a[p,r] x[r] = b. (1)
+*
+* As the result of processing one of columns q or r is eliminated from
+* all other rows and, thus, becomes column singleton of type "implied
+* slack variable". Row p is not changed and along with column q and r
+* remains in the problem.
+*
+* RETURNS
+*
+* The routine npp_eq_doublet returns pointer to the descriptor of that
+* column q or r which has been eliminated. If, due to some reason, the
+* elimination was not performed, the routine returns NULL.
+*
+* PROBLEM TRANSFORMATION
+*
+* First, we decide which column q or r will be eliminated. Let it be
+* column q. Consider i-th constraint row, where column q has non-zero
+* coefficient a[i,q] != 0:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i]. (2)
+* j
+*
+* In order to eliminate column q from row (2) we subtract from it row
+* (1) multiplied by gamma[i] = a[i,q] / a[p,q], i.e. we replace in the
+* transformed problem row (2) by its linear combination with row (1).
+* This transformation changes only coefficients in columns q and r,
+* and bounds of row i as follows:
+*
+* a~[i,q] = a[i,q] - gamma[i] a[p,q] = 0, (3)
+*
+* a~[i,r] = a[i,r] - gamma[i] a[p,r], (4)
+*
+* L~[i] = L[i] - gamma[i] b, (5)
+*
+* U~[i] = U[i] - gamma[i] b. (6)
+*
+* RECOVERING BASIC SOLUTION
+*
+* The transformation of the primal system of the original problem:
+*
+* L <= A x <= U (7)
+*
+* is equivalent to multiplying from the left a transformation matrix F
+* by components of this primal system, which in the transformed problem
+* becomes the following:
+*
+* F L <= F A x <= F U ==> L~ <= A~x <= U~. (8)
+*
+* The matrix F has the following structure:
+*
+* ( 1 -gamma[1] )
+* ( )
+* ( 1 -gamma[2] )
+* ( )
+* ( ... ... )
+* ( )
+* F = ( 1 -gamma[p-1] ) (9)
+* ( )
+* ( 1 )
+* ( )
+* ( -gamma[p+1] 1 )
+* ( )
+* ( ... ... )
+*
+* where its column containing elements -gamma[i] corresponds to row p
+* of the primal system.
+*
+* From (8) it follows that the dual system of the original problem:
+*
+* A'pi + lambda = c, (10)
+*
+* in the transformed problem becomes the following:
+*
+* A'F'inv(F')pi + lambda = c ==> (A~)'pi~ + lambda = c, (11)
+*
+* where:
+*
+* pi~ = inv(F')pi (12)
+*
+* is the vector of row multipliers in the transformed problem. Thus:
+*
+* pi = F'pi~. (13)
+*
+* Therefore, as it follows from (13), value of multiplier for row p in
+* solution to the original problem can be computed as follows:
+*
+* pi[p] = pi~[p] - sum gamma[i] pi~[i], (14)
+* i
+*
+* where pi~[i] = pi[i] is multiplier for row i (i != p).
+*
+* Note that the statuses of all rows and columns are not changed.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Multiplier for row p in solution to the original problem is computed
+* with formula (14).
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct eq_doublet
+{ /* row doubleton (equality constraint) */
+ int p;
+ /* row reference number */
+ double apq;
+ /* constraint coefficient a[p,q] */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[i,q], i != p */
+};
+
+static int rcv_eq_doublet(NPP *npp, void *info);
+
+NPPCOL *npp_eq_doublet(NPP *npp, NPPROW *p)
+{ /* process row doubleton (equality constraint) */
+ struct eq_doublet *info;
+ NPPROW *i;
+ NPPCOL *q, *r;
+ NPPAIJ *apq, *apr, *aiq, *air, *next;
+ NPPLFE *lfe;
+ double gamma;
+ /* the row must be doubleton equality constraint */
+ xassert(p->lb == p->ub);
+ xassert(p->ptr != NULL && p->ptr->r_next != NULL &&
+ p->ptr->r_next->r_next == NULL);
+ /* choose column to be eliminated */
+ { NPPAIJ *a1, *a2;
+ a1 = p->ptr, a2 = a1->r_next;
+ if (fabs(a2->val) < 0.001 * fabs(a1->val))
+ { /* only first column can be eliminated, because second one
+ has too small constraint coefficient */
+ apq = a1, apr = a2;
+ }
+ else if (fabs(a1->val) < 0.001 * fabs(a2->val))
+ { /* only second column can be eliminated, because first one
+ has too small constraint coefficient */
+ apq = a2, apr = a1;
+ }
+ else
+ { /* both columns are appropriate; choose that one which is
+ shorter to minimize fill-in */
+ if (npp_col_nnz(npp, a1->col) <= npp_col_nnz(npp, a2->col))
+ { /* first column is shorter */
+ apq = a1, apr = a2;
+ }
+ else
+ { /* second column is shorter */
+ apq = a2, apr = a1;
+ }
+ }
+ }
+ /* now columns q and r have been chosen */
+ q = apq->col, r = apr->col;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_eq_doublet, sizeof(struct eq_doublet));
+ info->p = p->i;
+ info->apq = apq->val;
+ info->ptr = NULL;
+ /* transform each row i (i != p), where a[i,q] != 0, to eliminate
+ column q */
+ for (aiq = q->ptr; aiq != NULL; aiq = next)
+ { next = aiq->c_next;
+ if (aiq == apq) continue; /* skip row p */
+ i = aiq->row; /* row i to be transformed */
+ /* save constraint coefficient a[i,q] */
+ if (npp->sol != GLP_MIP)
+ { lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = i->i;
+ lfe->val = aiq->val;
+ lfe->next = info->ptr;
+ info->ptr = lfe;
+ }
+ /* find coefficient a[i,r] in row i */
+ for (air = i->ptr; air != NULL; air = air->r_next)
+ if (air->col == r) break;
+ /* if a[i,r] does not exist, create a[i,r] = 0 */
+ if (air == NULL)
+ air = npp_add_aij(npp, i, r, 0.0);
+ /* compute gamma[i] = a[i,q] / a[p,q] */
+ gamma = aiq->val / apq->val;
+ /* (row i) := (row i) - gamma[i] * (row p); see (3)-(6) */
+ /* new a[i,q] is exact zero due to elimnation; remove it from
+ row i */
+ npp_del_aij(npp, aiq);
+ /* compute new a[i,r] */
+ air->val -= gamma * apr->val;
+ /* if new a[i,r] is close to zero due to numeric cancelation,
+ remove it from row i */
+ if (fabs(air->val) <= 1e-10)
+ npp_del_aij(npp, air);
+ /* compute new lower and upper bounds of row i */
+ if (i->lb == i->ub)
+ i->lb = i->ub = (i->lb - gamma * p->lb);
+ else
+ { if (i->lb != -DBL_MAX)
+ i->lb -= gamma * p->lb;
+ if (i->ub != +DBL_MAX)
+ i->ub -= gamma * p->lb;
+ }
+ }
+ return q;
+}
+
+static int rcv_eq_doublet(NPP *npp, void *_info)
+{ /* recover row doubleton (equality constraint) */
+ struct eq_doublet *info = _info;
+ NPPLFE *lfe;
+ double gamma, temp;
+ /* we assume that processing row p is followed by processing
+ column q as singleton of type "implied slack variable", in
+ which case row p must always be active equality constraint */
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] != GLP_NS)
+ { npp_error();
+ return 1;
+ }
+ }
+ if (npp->sol != GLP_MIP)
+ { /* compute value of multiplier for row p; see (14) */
+ temp = npp->r_pi[info->p];
+ for (lfe = info->ptr; lfe != NULL; lfe = lfe->next)
+ { gamma = lfe->val / info->apq; /* a[i,q] / a[p,q] */
+ temp -= gamma * npp->r_pi[lfe->ref];
+ }
+ npp->r_pi[info->p] = temp;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_forcing_row - process forcing row
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_forcing_row(NPP *npp, NPPROW *p, int at);
+*
+* DESCRIPTION
+*
+* The routine npp_forcing row processes row p of general format:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p], (1)
+* j
+*
+* l[j] <= x[j] <= u[j], (2)
+*
+* where L[p] <= U[p] and l[j] < u[j] for all a[p,j] != 0. It is also
+* assumed that:
+*
+* 1) if at = 0 then |L[p] - U'[p]| <= eps, where U'[p] is implied
+* row upper bound (see below), eps is an absolute tolerance for row
+* value;
+*
+* 2) if at = 1 then |U[p] - L'[p]| <= eps, where L'[p] is implied
+* row lower bound (see below).
+*
+* RETURNS
+*
+* 0 - success;
+*
+* 1 - cannot fix columns due to too small constraint coefficients.
+*
+* PROBLEM TRANSFORMATION
+*
+* Implied lower and upper bounds of row (1) are determined by bounds
+* of corresponding columns (variables) as follows:
+*
+* L'[p] = inf sum a[p,j] x[j] =
+* j
+* (3)
+* = sum a[p,j] l[j] + sum a[p,j] u[j],
+* j in Jp j in Jn
+*
+* U'[p] = sup sum a[p,j] x[j] =
+* (4)
+* = sum a[p,j] u[j] + sum a[p,j] l[j],
+* j in Jp j in Jn
+*
+* Jp = {j: a[p,j] > 0}, Jn = {j: a[p,j] < 0}. (5)
+*
+* If L[p] =~ U'[p] (at = 0), solution can be primal feasible only when
+* all variables take their boundary values as defined by (4):
+*
+* ( u[j], if j in Jp
+* x[j] = < (6)
+* ( l[j], if j in Jn
+*
+* Similarly, if U[p] =~ L'[p] (at = 1), solution can be primal feasible
+* only when all variables take their boundary values as defined by (3):
+*
+* ( l[j], if j in Jp
+* x[j] = < (7)
+* ( u[j], if j in Jn
+*
+* Condition (6) or (7) allows fixing all columns (variables x[j])
+* in row (1) on their bounds and then removing them from the problem
+* (see the routine npp_fixed_col). Due to this row p becomes redundant,
+* so it can be replaced by equivalent free (unbounded) row and also
+* removed from the problem (see the routine npp_free_row).
+*
+* 1. To apply this transformation row (1) should not have coefficients
+* whose magnitude is too small, i.e. all a[p,j] should satisfy to
+* the following condition:
+*
+* |a[p,j]| >= eps * max(1, |a[p,k]|), (8)
+* k
+* where eps is a relative tolerance for constraint coefficients.
+* Otherwise, fixing columns may be numerically unreliable and may
+* lead to wrong solution.
+*
+* 2. The routine fixes columns and remove bounds of row p, however,
+* it does not remove the row and columns from the problem.
+*
+* RECOVERING BASIC SOLUTION
+*
+* In the transformed problem row p being inactive constraint is
+* assigned status GLP_BS (as the result of transformation of free
+* row), and all columns in this row are assigned status GLP_NS (as the
+* result of transformation of fixed columns).
+*
+* Note that in the dual system of the transformed (as well as original)
+* problem every column j in row p corresponds to the following row:
+*
+* sum a[i,j] pi[i] + a[p,j] pi[p] + lambda[j] = c[j], (9)
+* i!=p
+*
+* from which it follows that:
+*
+* lambda[j] = c[j] - sum a[i,j] pi[i] - a[p,j] pi[p]. (10)
+* i!=p
+*
+* In the transformed problem values of all multipliers pi[i] are known
+* (including pi[i], whose value is zero, since row p is inactive).
+* Thus, using formula (10) it is possible to compute values of
+* multipliers lambda[j] for all columns in row p.
+*
+* Note also that in the original problem all columns in row p are
+* bounded, not fixed. So status GLP_NS assigned to every such column
+* must be changed to GLP_NL or GLP_NU depending on which bound the
+* corresponding column has been fixed. This status change may lead to
+* dual feasibility violation for solution of the original problem,
+* because now column multipliers must satisfy to the following
+* condition:
+*
+* ( >= 0, if status of column j is GLP_NL,
+* lambda[j] < (11)
+* ( <= 0, if status of column j is GLP_NU.
+*
+* If this condition holds, solution to the original problem is the
+* same as to the transformed problem. Otherwise, we have to perform
+* one degenerate pivoting step of the primal simplex method to obtain
+* dual feasible (hence, optimal) solution to the original problem as
+* follows. If, on problem transformation, row p was made active on its
+* lower bound (case at = 0), we change its status to GLP_NL (or GLP_NS)
+* and start increasing its multiplier pi[p]. Otherwise, if row p was
+* made active on its upper bound (case at = 1), we change its status
+* to GLP_NU (or GLP_NS) and start decreasing pi[p]. From (10) it
+* follows that:
+*
+* delta lambda[j] = - a[p,j] * delta pi[p] = - a[p,j] pi[p]. (12)
+*
+* Simple analysis of formulae (3)-(5) shows that changing pi[p] in the
+* specified direction causes increasing lambda[j] for every column j
+* assigned status GLP_NL (delta lambda[j] > 0) and decreasing lambda[j]
+* for every column j assigned status GLP_NU (delta lambda[j] < 0). It
+* is understood that once the last lambda[q], which violates condition
+* (11), has reached zero, multipliers lambda[j] for all columns get
+* valid signs. Such column q can be determined as follows. Let d[j] be
+* initial value of lambda[j] (i.e. reduced cost of column j) in the
+* transformed problem computed with formula (10) when pi[p] = 0. Then
+* lambda[j] = d[j] + delta lambda[j], and from (12) it follows that
+* lambda[j] becomes zero if:
+*
+* delta lambda[j] = - a[p,j] pi[p] = - d[j] ==>
+* (13)
+* pi[p] = d[j] / a[p,j].
+*
+* Therefore, the last column q, for which lambda[q] becomes zero, can
+* be determined from the following condition:
+*
+* |d[q] / a[p,q]| = max |pi[p]| = max |d[j] / a[p,j]|, (14)
+* j in D j in D
+*
+* where D is a set of columns j whose, reduced costs d[j] have invalid
+* signs, i.e. violate condition (11). (Thus, if D is empty, solution
+* to the original problem is the same as solution to the transformed
+* problem, and no correction is needed as was noticed above.) In
+* solution to the original problem column q is assigned status GLP_BS,
+* since it replaces column of auxiliary variable of row p (becoming
+* active) in the basis, and multiplier for row p is assigned its new
+* value, which is pi[p] = d[q] / a[p,q]. Note that due to primal
+* degeneracy values of all columns having non-zero coefficients in row
+* p remain unchanged.
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* Value of multiplier pi[p] in solution to the original problem is
+* corrected in the same way as for basic solution. Values of all
+* columns having non-zero coefficients in row p remain unchanged.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct forcing_col
+{ /* column fixed on its bound by forcing row */
+ int j;
+ /* column reference number */
+ char stat;
+ /* original column status:
+ GLP_NL - fixed on lower bound
+ GLP_NU - fixed on upper bound */
+ double a;
+ /* constraint coefficient a[p,j] */
+ double c;
+ /* objective coefficient c[j] */
+ NPPLFE *ptr;
+ /* list of non-zero coefficients a[i,j], i != p */
+ struct forcing_col *next;
+ /* pointer to another column fixed by forcing row */
+};
+
+struct forcing_row
+{ /* forcing row */
+ int p;
+ /* row reference number */
+ char stat;
+ /* status assigned to the row if it becomes active:
+ GLP_NS - active equality constraint
+ GLP_NL - inequality constraint with lower bound active
+ GLP_NU - inequality constraint with upper bound active */
+ struct forcing_col *ptr;
+ /* list of all columns having non-zero constraint coefficient
+ a[p,j] in the forcing row */
+};
+
+static int rcv_forcing_row(NPP *npp, void *info);
+
+int npp_forcing_row(NPP *npp, NPPROW *p, int at)
+{ /* process forcing row */
+ struct forcing_row *info;
+ struct forcing_col *col = NULL;
+ NPPCOL *j;
+ NPPAIJ *apj, *aij;
+ NPPLFE *lfe;
+ double big;
+ xassert(at == 0 || at == 1);
+ /* determine maximal magnitude of the row coefficients */
+ big = 1.0;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ if (big < fabs(apj->val)) big = fabs(apj->val);
+ /* if there are too small coefficients in the row, transformation
+ should not be applied */
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ if (fabs(apj->val) < 1e-7 * big) return 1;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_forcing_row, sizeof(struct forcing_row));
+ info->p = p->i;
+ if (p->lb == p->ub)
+ { /* equality constraint */
+ info->stat = GLP_NS;
+ }
+ else if (at == 0)
+ { /* inequality constraint; case L[p] = U'[p] */
+ info->stat = GLP_NL;
+ xassert(p->lb != -DBL_MAX);
+ }
+ else /* at == 1 */
+ { /* inequality constraint; case U[p] = L'[p] */
+ info->stat = GLP_NU;
+ xassert(p->ub != +DBL_MAX);
+ }
+ info->ptr = NULL;
+ /* scan the forcing row, fix columns at corresponding bounds, and
+ save column information (the latter is not needed for MIP) */
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { /* column j has non-zero coefficient in the forcing row */
+ j = apj->col;
+ /* it must be non-fixed */
+ xassert(j->lb < j->ub);
+ /* allocate stack entry to save column information */
+ if (npp->sol != GLP_MIP)
+ { col = dmp_get_atom(npp->stack, sizeof(struct forcing_col));
+ col->j = j->j;
+ col->stat = -1; /* will be set below */
+ col->a = apj->val;
+ col->c = j->coef;
+ col->ptr = NULL;
+ col->next = info->ptr;
+ info->ptr = col;
+ }
+ /* fix column j */
+ if (at == 0 && apj->val < 0.0 || at != 0 && apj->val > 0.0)
+ { /* at its lower bound */
+ if (npp->sol != GLP_MIP)
+ col->stat = GLP_NL;
+ xassert(j->lb != -DBL_MAX);
+ j->ub = j->lb;
+ }
+ else
+ { /* at its upper bound */
+ if (npp->sol != GLP_MIP)
+ col->stat = GLP_NU;
+ xassert(j->ub != +DBL_MAX);
+ j->lb = j->ub;
+ }
+ /* save column coefficients a[i,j], i != p */
+ if (npp->sol != GLP_MIP)
+ { for (aij = j->ptr; aij != NULL; aij = aij->c_next)
+ { if (aij == apj) continue; /* skip a[p,j] */
+ lfe = dmp_get_atom(npp->stack, sizeof(NPPLFE));
+ lfe->ref = aij->row->i;
+ lfe->val = aij->val;
+ lfe->next = col->ptr;
+ col->ptr = lfe;
+ }
+ }
+ }
+ /* make the row free (unbounded) */
+ p->lb = -DBL_MAX, p->ub = +DBL_MAX;
+ return 0;
+}
+
+static int rcv_forcing_row(NPP *npp, void *_info)
+{ /* recover forcing row */
+ struct forcing_row *info = _info;
+ struct forcing_col *col, *piv;
+ NPPLFE *lfe;
+ double d, big, temp;
+ if (npp->sol == GLP_MIP) goto done;
+ /* initially solution to the original problem is the same as
+ to the transformed problem, where row p is inactive constraint
+ with pi[p] = 0, and all columns are non-basic */
+ if (npp->sol == GLP_SOL)
+ { if (npp->r_stat[info->p] != GLP_BS)
+ { npp_error();
+ return 1;
+ }
+ for (col = info->ptr; col != NULL; col = col->next)
+ { if (npp->c_stat[col->j] != GLP_NS)
+ { npp_error();
+ return 1;
+ }
+ npp->c_stat[col->j] = col->stat; /* original status */
+ }
+ }
+ /* compute reduced costs d[j] for all columns with formula (10)
+ and store them in col.c instead objective coefficients */
+ for (col = info->ptr; col != NULL; col = col->next)
+ { d = col->c;
+ for (lfe = col->ptr; lfe != NULL; lfe = lfe->next)
+ d -= lfe->val * npp->r_pi[lfe->ref];
+ col->c = d;
+ }
+ /* consider columns j, whose multipliers lambda[j] has wrong
+ sign in solution to the transformed problem (where lambda[j] =
+ d[j]), and choose column q, whose multipler lambda[q] reaches
+ zero last on changing row multiplier pi[p]; see (14) */
+ piv = NULL, big = 0.0;
+ for (col = info->ptr; col != NULL; col = col->next)
+ { d = col->c; /* d[j] */
+ temp = fabs(d / col->a);
+ if (col->stat == GLP_NL)
+ { /* column j has active lower bound */
+ if (d < 0.0 && big < temp)
+ piv = col, big = temp;
+ }
+ else if (col->stat == GLP_NU)
+ { /* column j has active upper bound */
+ if (d > 0.0 && big < temp)
+ piv = col, big = temp;
+ }
+ else
+ { npp_error();
+ return 1;
+ }
+ }
+ /* if column q does not exist, no correction is needed */
+ if (piv != NULL)
+ { /* correct solution; row p becomes active constraint while
+ column q becomes basic */
+ if (npp->sol == GLP_SOL)
+ { npp->r_stat[info->p] = info->stat;
+ npp->c_stat[piv->j] = GLP_BS;
+ }
+ /* assign new value to row multiplier pi[p] = d[p] / a[p,q] */
+ npp->r_pi[info->p] = piv->c / piv->a;
+ }
+done: return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_analyze_row - perform general row analysis
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_analyze_row(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_analyze_row performs analysis of row p of general
+* format:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p], (1)
+* j
+*
+* l[j] <= x[j] <= u[j], (2)
+*
+* where L[p] <= U[p] and l[j] <= u[j] for all a[p,j] != 0.
+*
+* RETURNS
+*
+* 0x?0 - row lower bound does not exist or is redundant;
+*
+* 0x?1 - row lower bound can be active;
+*
+* 0x?2 - row lower bound is a forcing bound;
+*
+* 0x0? - row upper bound does not exist or is redundant;
+*
+* 0x1? - row upper bound can be active;
+*
+* 0x2? - row upper bound is a forcing bound;
+*
+* 0x33 - row bounds are inconsistent with column bounds.
+*
+* ALGORITHM
+*
+* Analysis of row (1) is based on analysis of its implied lower and
+* upper bounds, which are determined by bounds of corresponding columns
+* (variables) as follows:
+*
+* L'[p] = inf sum a[p,j] x[j] =
+* j
+* (3)
+* = sum a[p,j] l[j] + sum a[p,j] u[j],
+* j in Jp j in Jn
+*
+* U'[p] = sup sum a[p,j] x[j] =
+* (4)
+* = sum a[p,j] u[j] + sum a[p,j] l[j],
+* j in Jp j in Jn
+*
+* Jp = {j: a[p,j] > 0}, Jn = {j: a[p,j] < 0}. (5)
+*
+* (Note that bounds of all columns in row p are assumed to be correct,
+* so L'[p] <= U'[p].)
+*
+* Analysis of row lower bound L[p] includes the following cases:
+*
+* 1) if L[p] > U'[p] + eps, where eps is an absolute tolerance for row
+* value, row lower bound L[p] and implied row upper bound U'[p] are
+* inconsistent, ergo, the problem has no primal feasible solution;
+*
+* 2) if U'[p] - eps <= L[p] <= U'[p] + eps, i.e. if L[p] =~ U'[p],
+* the row is a forcing row on its lower bound (see description of
+* the routine npp_forcing_row);
+*
+* 3) if L[p] > L'[p] + eps, row lower bound L[p] can be active (this
+* conclusion does not account other rows in the problem);
+*
+* 4) if L[p] <= L'[p] + eps, row lower bound L[p] cannot be active, so
+* it is redundant and can be removed (replaced by -oo).
+*
+* Analysis of row upper bound U[p] is performed in a similar way and
+* includes the following cases:
+*
+* 1) if U[p] < L'[p] - eps, row upper bound U[p] and implied row lower
+* bound L'[p] are inconsistent, ergo the problem has no primal
+* feasible solution;
+*
+* 2) if L'[p] - eps <= U[p] <= L'[p] + eps, i.e. if U[p] =~ L'[p],
+* the row is a forcing row on its upper bound (see description of
+* the routine npp_forcing_row);
+*
+* 3) if U[p] < U'[p] - eps, row upper bound U[p] can be active (this
+* conclusion does not account other rows in the problem);
+*
+* 4) if U[p] >= U'[p] - eps, row upper bound U[p] cannot be active, so
+* it is redundant and can be removed (replaced by +oo). */
+
+int npp_analyze_row(NPP *npp, NPPROW *p)
+{ /* perform general row analysis */
+ NPPAIJ *aij;
+ int ret = 0x00;
+ double l, u, eps;
+ xassert(npp == npp);
+ /* compute implied lower bound L'[p]; see (3) */
+ l = 0.0;
+ for (aij = p->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->val > 0.0)
+ { if (aij->col->lb == -DBL_MAX)
+ { l = -DBL_MAX;
+ break;
+ }
+ l += aij->val * aij->col->lb;
+ }
+ else /* aij->val < 0.0 */
+ { if (aij->col->ub == +DBL_MAX)
+ { l = -DBL_MAX;
+ break;
+ }
+ l += aij->val * aij->col->ub;
+ }
+ }
+ /* compute implied upper bound U'[p]; see (4) */
+ u = 0.0;
+ for (aij = p->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->val > 0.0)
+ { if (aij->col->ub == +DBL_MAX)
+ { u = +DBL_MAX;
+ break;
+ }
+ u += aij->val * aij->col->ub;
+ }
+ else /* aij->val < 0.0 */
+ { if (aij->col->lb == -DBL_MAX)
+ { u = +DBL_MAX;
+ break;
+ }
+ u += aij->val * aij->col->lb;
+ }
+ }
+ /* column bounds are assumed correct, so L'[p] <= U'[p] */
+ /* check if row lower bound is consistent */
+ if (p->lb != -DBL_MAX)
+ { eps = 1e-3 + 1e-6 * fabs(p->lb);
+ if (p->lb - eps > u)
+ { ret = 0x33;
+ goto done;
+ }
+ }
+ /* check if row upper bound is consistent */
+ if (p->ub != +DBL_MAX)
+ { eps = 1e-3 + 1e-6 * fabs(p->ub);
+ if (p->ub + eps < l)
+ { ret = 0x33;
+ goto done;
+ }
+ }
+ /* check if row lower bound can be active/forcing */
+ if (p->lb != -DBL_MAX)
+ { eps = 1e-9 + 1e-12 * fabs(p->lb);
+ if (p->lb - eps > l)
+ { if (p->lb + eps <= u)
+ ret |= 0x01;
+ else
+ ret |= 0x02;
+ }
+ }
+ /* check if row upper bound can be active/forcing */
+ if (p->ub != +DBL_MAX)
+ { eps = 1e-9 + 1e-12 * fabs(p->ub);
+ if (p->ub + eps < u)
+ { /* check if the upper bound is forcing */
+ if (p->ub - eps >= l)
+ ret |= 0x10;
+ else
+ ret |= 0x20;
+ }
+ }
+done: return ret;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_inactive_bound - remove row lower/upper inactive bound
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_inactive_bound(NPP *npp, NPPROW *p, int which);
+*
+* DESCRIPTION
+*
+* The routine npp_inactive_bound removes lower (if which = 0) or upper
+* (if which = 1) bound of row p:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p],
+*
+* which (bound) is assumed to be redundant.
+*
+* PROBLEM TRANSFORMATION
+*
+* If which = 0, current lower bound L[p] of row p is assigned -oo.
+* If which = 1, current upper bound U[p] of row p is assigned +oo.
+*
+* RECOVERING BASIC SOLUTION
+*
+* If in solution to the transformed problem row p is inactive
+* constraint (GLP_BS), its status is not changed in solution to the
+* original problem. Otherwise, status of row p in solution to the
+* original problem is defined by its type before transformation and
+* its status in solution to the transformed problem as follows:
+*
+* +---------------------+-------+---------------+---------------+
+* | Row | Flag | Row status in | Row status in |
+* | type | which | transfmd soln | original soln |
+* +---------------------+-------+---------------+---------------+
+* | sum >= L[p] | 0 | GLP_NF | GLP_NL |
+* | sum <= U[p] | 1 | GLP_NF | GLP_NU |
+* | L[p] <= sum <= U[p] | 0 | GLP_NU | GLP_NU |
+* | L[p] <= sum <= U[p] | 1 | GLP_NL | GLP_NL |
+* | sum = L[p] = U[p] | 0 | GLP_NU | GLP_NS |
+* | sum = L[p] = U[p] | 1 | GLP_NL | GLP_NS |
+* +---------------------+-------+---------------+---------------+
+*
+* RECOVERING INTERIOR-POINT SOLUTION
+*
+* None needed.
+*
+* RECOVERING MIP SOLUTION
+*
+* None needed. */
+
+struct inactive_bound
+{ /* row inactive bound */
+ int p;
+ /* row reference number */
+ char stat;
+ /* row status (if active constraint) */
+};
+
+static int rcv_inactive_bound(NPP *npp, void *info);
+
+void npp_inactive_bound(NPP *npp, NPPROW *p, int which)
+{ /* remove row lower/upper inactive bound */
+ struct inactive_bound *info;
+ if (npp->sol == GLP_SOL)
+ { /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_inactive_bound, sizeof(struct inactive_bound));
+ info->p = p->i;
+ if (p->ub == +DBL_MAX)
+ info->stat = GLP_NL;
+ else if (p->lb == -DBL_MAX)
+ info->stat = GLP_NU;
+ else if (p->lb != p->ub)
+ info->stat = (char)(which == 0 ? GLP_NU : GLP_NL);
+ else
+ info->stat = GLP_NS;
+ }
+ /* remove row inactive bound */
+ if (which == 0)
+ { xassert(p->lb != -DBL_MAX);
+ p->lb = -DBL_MAX;
+ }
+ else if (which == 1)
+ { xassert(p->ub != +DBL_MAX);
+ p->ub = +DBL_MAX;
+ }
+ else
+ xassert(which != which);
+ return;
+}
+
+static int rcv_inactive_bound(NPP *npp, void *_info)
+{ /* recover row status */
+ struct inactive_bound *info = _info;
+ if (npp->sol != GLP_SOL)
+ { npp_error();
+ return 1;
+ }
+ if (npp->r_stat[info->p] == GLP_BS)
+ npp->r_stat[info->p] = GLP_BS;
+ else
+ npp->r_stat[info->p] = info->stat;
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_bounds - determine implied column bounds
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_implied_bounds(NPP *npp, NPPROW *p);
+*
+* DESCRIPTION
+*
+* The routine npp_implied_bounds inspects general row (constraint) p:
+*
+* L[p] <= sum a[p,j] x[j] <= U[p], (1)
+*
+* l[j] <= x[j] <= u[j], (2)
+*
+* where L[p] <= U[p] and l[j] <= u[j] for all a[p,j] != 0, to compute
+* implied bounds of columns (variables x[j]) in this row.
+*
+* The routine stores implied column bounds l'[j] and u'[j] in column
+* descriptors (NPPCOL); it does not change current column bounds l[j]
+* and u[j]. (Implied column bounds can be then used to strengthen the
+* current column bounds; see the routines npp_implied_lower and
+* npp_implied_upper).
+*
+* ALGORITHM
+*
+* Current column bounds (2) define implied lower and upper bounds of
+* row (1) as follows:
+*
+* L'[p] = inf sum a[p,j] x[j] =
+* j
+* (3)
+* = sum a[p,j] l[j] + sum a[p,j] u[j],
+* j in Jp j in Jn
+*
+* U'[p] = sup sum a[p,j] x[j] =
+* (4)
+* = sum a[p,j] u[j] + sum a[p,j] l[j],
+* j in Jp j in Jn
+*
+* Jp = {j: a[p,j] > 0}, Jn = {j: a[p,j] < 0}. (5)
+*
+* (Note that bounds of all columns in row p are assumed to be correct,
+* so L'[p] <= U'[p].)
+*
+* If L[p] > L'[p] and/or U[p] < U'[p], the lower and/or upper bound of
+* row (1) can be active, in which case such row defines implied bounds
+* of its variables.
+*
+* Let x[k] be some variable having in row (1) coefficient a[p,k] != 0.
+* Consider a case when row lower bound can be active (L[p] > L'[p]):
+*
+* sum a[p,j] x[j] >= L[p] ==>
+* j
+*
+* sum a[p,j] x[j] + a[p,k] x[k] >= L[p] ==>
+* j!=k
+* (6)
+* a[p,k] x[k] >= L[p] - sum a[p,j] x[j] ==>
+* j!=k
+*
+* a[p,k] x[k] >= L[p,k],
+*
+* where
+*
+* L[p,k] = inf(L[p] - sum a[p,j] x[j]) =
+* j!=k
+*
+* = L[p] - sup sum a[p,j] x[j] = (7)
+* j!=k
+*
+* = L[p] - sum a[p,j] u[j] - sum a[p,j] l[j].
+* j in Jp\{k} j in Jn\{k}
+*
+* Thus:
+*
+* x[k] >= l'[k] = L[p,k] / a[p,k], if a[p,k] > 0, (8)
+*
+* x[k] <= u'[k] = L[p,k] / a[p,k], if a[p,k] < 0. (9)
+*
+* where l'[k] and u'[k] are implied lower and upper bounds of variable
+* x[k], resp.
+*
+* Now consider a similar case when row upper bound can be active
+* (U[p] < U'[p]):
+*
+* sum a[p,j] x[j] <= U[p] ==>
+* j
+*
+* sum a[p,j] x[j] + a[p,k] x[k] <= U[p] ==>
+* j!=k
+* (10)
+* a[p,k] x[k] <= U[p] - sum a[p,j] x[j] ==>
+* j!=k
+*
+* a[p,k] x[k] <= U[p,k],
+*
+* where:
+*
+* U[p,k] = sup(U[p] - sum a[p,j] x[j]) =
+* j!=k
+*
+* = U[p] - inf sum a[p,j] x[j] = (11)
+* j!=k
+*
+* = U[p] - sum a[p,j] l[j] - sum a[p,j] u[j].
+* j in Jp\{k} j in Jn\{k}
+*
+* Thus:
+*
+* x[k] <= u'[k] = U[p,k] / a[p,k], if a[p,k] > 0, (12)
+*
+* x[k] >= l'[k] = U[p,k] / a[p,k], if a[p,k] < 0. (13)
+*
+* Note that in formulae (8), (9), (12), and (13) coefficient a[p,k]
+* must not be too small in magnitude relatively to other non-zero
+* coefficients in row (1), i.e. the following condition must hold:
+*
+* |a[p,k]| >= eps * max(1, |a[p,j]|), (14)
+* j
+*
+* where eps is a relative tolerance for constraint coefficients.
+* Otherwise the implied column bounds can be numerical inreliable. For
+* example, using formula (8) for the following inequality constraint:
+*
+* 1e-12 x1 - x2 - x3 >= 0,
+*
+* where x1 >= -1, x2, x3, >= 0, may lead to numerically unreliable
+* conclusion that x1 >= 0.
+*
+* Using formulae (8), (9), (12), and (13) to compute implied bounds
+* for one variable requires |J| operations, where J = {j: a[p,j] != 0},
+* because this needs computing L[p,k] and U[p,k]. Thus, computing
+* implied bounds for all variables in row (1) would require |J|^2
+* operations, that is not a good technique. However, the total number
+* of operations can be reduced to |J| as follows.
+*
+* Let a[p,k] > 0. Then from (7) and (11) we have:
+*
+* L[p,k] = L[p] - (U'[p] - a[p,k] u[k]) =
+*
+* = L[p] - U'[p] + a[p,k] u[k],
+*
+* U[p,k] = U[p] - (L'[p] - a[p,k] l[k]) =
+*
+* = U[p] - L'[p] + a[p,k] l[k],
+*
+* where L'[p] and U'[p] are implied row lower and upper bounds defined
+* by formulae (3) and (4). Substituting these expressions into (8) and
+* (12) gives:
+*
+* l'[k] = L[p,k] / a[p,k] = u[k] + (L[p] - U'[p]) / a[p,k], (15)
+*
+* u'[k] = U[p,k] / a[p,k] = l[k] + (U[p] - L'[p]) / a[p,k]. (16)
+*
+* Similarly, if a[p,k] < 0, according to (7) and (11) we have:
+*
+* L[p,k] = L[p] - (U'[p] - a[p,k] l[k]) =
+*
+* = L[p] - U'[p] + a[p,k] l[k],
+*
+* U[p,k] = U[p] - (L'[p] - a[p,k] u[k]) =
+*
+* = U[p] - L'[p] + a[p,k] u[k],
+*
+* and substituting these expressions into (8) and (12) gives:
+*
+* l'[k] = U[p,k] / a[p,k] = u[k] + (U[p] - L'[p]) / a[p,k], (17)
+*
+* u'[k] = L[p,k] / a[p,k] = l[k] + (L[p] - U'[p]) / a[p,k]. (18)
+*
+* Note that formulae (15)-(18) can be used only if L'[p] and U'[p]
+* exist. However, if for some variable x[j] it happens that l[j] = -oo
+* and/or u[j] = +oo, values of L'[p] (if a[p,j] > 0) and/or U'[p] (if
+* a[p,j] < 0) are undefined. Consider, therefore, the most general
+* situation, when some column bounds (2) may not exist.
+*
+* Let:
+*
+* J' = {j : (a[p,j] > 0 and l[j] = -oo) or
+* (19)
+* (a[p,j] < 0 and u[j] = +oo)}.
+*
+* Then (assuming that row upper bound U[p] can be active) the following
+* three cases are possible:
+*
+* 1) |J'| = 0. In this case L'[p] exists, thus, for all variables x[j]
+* in row (1) we can use formulae (16) and (17);
+*
+* 2) J' = {k}. In this case L'[p] = -oo, however, U[p,k] (11) exists,
+* so for variable x[k] we can use formulae (12) and (13). Note that
+* for all other variables x[j] (j != k) l'[j] = -oo (if a[p,j] < 0)
+* or u'[j] = +oo (if a[p,j] > 0);
+*
+* 3) |J'| > 1. In this case for all variables x[j] in row [1] we have
+* l'[j] = -oo (if a[p,j] < 0) or u'[j] = +oo (if a[p,j] > 0).
+*
+* Similarly, let:
+*
+* J'' = {j : (a[p,j] > 0 and u[j] = +oo) or
+* (20)
+* (a[p,j] < 0 and l[j] = -oo)}.
+*
+* Then (assuming that row lower bound L[p] can be active) the following
+* three cases are possible:
+*
+* 1) |J''| = 0. In this case U'[p] exists, thus, for all variables x[j]
+* in row (1) we can use formulae (15) and (18);
+*
+* 2) J'' = {k}. In this case U'[p] = +oo, however, L[p,k] (7) exists,
+* so for variable x[k] we can use formulae (8) and (9). Note that
+* for all other variables x[j] (j != k) l'[j] = -oo (if a[p,j] > 0)
+* or u'[j] = +oo (if a[p,j] < 0);
+*
+* 3) |J''| > 1. In this case for all variables x[j] in row (1) we have
+* l'[j] = -oo (if a[p,j] > 0) or u'[j] = +oo (if a[p,j] < 0). */
+
+void npp_implied_bounds(NPP *npp, NPPROW *p)
+{ NPPAIJ *apj, *apk;
+ double big, eps, temp;
+ xassert(npp == npp);
+ /* initialize implied bounds for all variables and determine
+ maximal magnitude of row coefficients a[p,j] */
+ big = 1.0;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { apj->col->ll.ll = -DBL_MAX, apj->col->uu.uu = +DBL_MAX;
+ if (big < fabs(apj->val)) big = fabs(apj->val);
+ }
+ eps = 1e-6 * big;
+ /* process row lower bound (assuming that it can be active) */
+ if (p->lb != -DBL_MAX)
+ { apk = NULL;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj->val > 0.0 && apj->col->ub == +DBL_MAX ||
+ apj->val < 0.0 && apj->col->lb == -DBL_MAX)
+ { if (apk == NULL)
+ apk = apj;
+ else
+ goto skip1;
+ }
+ }
+ /* if a[p,k] = NULL then |J'| = 0 else J' = { k } */
+ temp = p->lb;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj == apk)
+ /* skip a[p,k] */;
+ else if (apj->val > 0.0)
+ temp -= apj->val * apj->col->ub;
+ else /* apj->val < 0.0 */
+ temp -= apj->val * apj->col->lb;
+ }
+ /* compute column implied bounds */
+ if (apk == NULL)
+ { /* temp = L[p] - U'[p] */
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj->val >= +eps)
+ { /* l'[j] := u[j] + (L[p] - U'[p]) / a[p,j] */
+ apj->col->ll.ll = apj->col->ub + temp / apj->val;
+ }
+ else if (apj->val <= -eps)
+ { /* u'[j] := l[j] + (L[p] - U'[p]) / a[p,j] */
+ apj->col->uu.uu = apj->col->lb + temp / apj->val;
+ }
+ }
+ }
+ else
+ { /* temp = L[p,k] */
+ if (apk->val >= +eps)
+ { /* l'[k] := L[p,k] / a[p,k] */
+ apk->col->ll.ll = temp / apk->val;
+ }
+ else if (apk->val <= -eps)
+ { /* u'[k] := L[p,k] / a[p,k] */
+ apk->col->uu.uu = temp / apk->val;
+ }
+ }
+skip1: ;
+ }
+ /* process row upper bound (assuming that it can be active) */
+ if (p->ub != +DBL_MAX)
+ { apk = NULL;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj->val > 0.0 && apj->col->lb == -DBL_MAX ||
+ apj->val < 0.0 && apj->col->ub == +DBL_MAX)
+ { if (apk == NULL)
+ apk = apj;
+ else
+ goto skip2;
+ }
+ }
+ /* if a[p,k] = NULL then |J''| = 0 else J'' = { k } */
+ temp = p->ub;
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj == apk)
+ /* skip a[p,k] */;
+ else if (apj->val > 0.0)
+ temp -= apj->val * apj->col->lb;
+ else /* apj->val < 0.0 */
+ temp -= apj->val * apj->col->ub;
+ }
+ /* compute column implied bounds */
+ if (apk == NULL)
+ { /* temp = U[p] - L'[p] */
+ for (apj = p->ptr; apj != NULL; apj = apj->r_next)
+ { if (apj->val >= +eps)
+ { /* u'[j] := l[j] + (U[p] - L'[p]) / a[p,j] */
+ apj->col->uu.uu = apj->col->lb + temp / apj->val;
+ }
+ else if (apj->val <= -eps)
+ { /* l'[j] := u[j] + (U[p] - L'[p]) / a[p,j] */
+ apj->col->ll.ll = apj->col->ub + temp / apj->val;
+ }
+ }
+ }
+ else
+ { /* temp = U[p,k] */
+ if (apk->val >= +eps)
+ { /* u'[k] := U[p,k] / a[p,k] */
+ apk->col->uu.uu = temp / apk->val;
+ }
+ else if (apk->val <= -eps)
+ { /* l'[k] := U[p,k] / a[p,k] */
+ apk->col->ll.ll = temp / apk->val;
+ }
+ }
+skip2: ;
+ }
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp4.c b/test/monniaux/glpk-4.65/src/npp/npp4.c
new file mode 100644
index 00000000..d7dd0e86
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp4.c
@@ -0,0 +1,1414 @@
+/* npp4.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* npp_binarize_prob - binarize MIP problem
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_binarize_prob(NPP *npp);
+*
+* DESCRIPTION
+*
+* The routine npp_binarize_prob replaces in the original MIP problem
+* every integer variable:
+*
+* l[q] <= x[q] <= u[q], (1)
+*
+* where l[q] < u[q], by an equivalent sum of binary variables.
+*
+* RETURNS
+*
+* The routine returns the number of integer variables for which the
+* transformation failed, because u[q] - l[q] > d_max.
+*
+* PROBLEM TRANSFORMATION
+*
+* If variable x[q] has non-zero lower bound, it is first processed
+* with the routine npp_lbnd_col. Thus, we can assume that:
+*
+* 0 <= x[q] <= u[q]. (2)
+*
+* If u[q] = 1, variable x[q] is already binary, so further processing
+* is not needed. Let, therefore, that 2 <= u[q] <= d_max, and n be a
+* smallest integer such that u[q] <= 2^n - 1 (n >= 2, since u[q] >= 2).
+* Then variable x[q] can be replaced by the following sum:
+*
+* n-1
+* x[q] = sum 2^k x[k], (3)
+* k=0
+*
+* where x[k] are binary columns (variables). If u[q] < 2^n - 1, the
+* following additional inequality constraint must be also included in
+* the transformed problem:
+*
+* n-1
+* sum 2^k x[k] <= u[q]. (4)
+* k=0
+*
+* Note: Assuming that in the transformed problem x[q] becomes binary
+* variable x[0], this transformation causes new n-1 binary variables
+* to appear.
+*
+* Substituting x[q] from (3) to the objective row gives:
+*
+* z = sum c[j] x[j] + c[0] =
+* j
+*
+* = sum c[j] x[j] + c[q] x[q] + c[0] =
+* j!=q
+* n-1
+* = sum c[j] x[j] + c[q] sum 2^k x[k] + c[0] =
+* j!=q k=0
+* n-1
+* = sum c[j] x[j] + sum c[k] x[k] + c[0],
+* j!=q k=0
+*
+* where:
+*
+* c[k] = 2^k c[q], k = 0, ..., n-1. (5)
+*
+* And substituting x[q] from (3) to i-th constraint row i gives:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i] ==>
+* j
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] x[q] <= U[i] ==>
+* j!=q
+* n-1
+* L[i] <= sum a[i,j] x[j] + a[i,q] sum 2^k x[k] <= U[i] ==>
+* j!=q k=0
+* n-1
+* L[i] <= sum a[i,j] x[j] + sum a[i,k] x[k] <= U[i],
+* j!=q k=0
+*
+* where:
+*
+* a[i,k] = 2^k a[i,q], k = 0, ..., n-1. (6)
+*
+* RECOVERING SOLUTION
+*
+* Value of variable x[q] is computed with formula (3). */
+
+struct binarize
+{ int q;
+ /* column reference number for x[q] = x[0] */
+ int j;
+ /* column reference number for x[1]; x[2] has reference number
+ j+1, x[3] - j+2, etc. */
+ int n;
+ /* total number of binary variables, n >= 2 */
+};
+
+static int rcv_binarize_prob(NPP *npp, void *info);
+
+int npp_binarize_prob(NPP *npp)
+{ /* binarize MIP problem */
+ struct binarize *info;
+ NPPROW *row;
+ NPPCOL *col, *bin;
+ NPPAIJ *aij;
+ int u, n, k, temp, nfails, nvars, nbins, nrows;
+ /* new variables will be added to the end of the column list, so
+ we go from the end to beginning of the column list */
+ nfails = nvars = nbins = nrows = 0;
+ for (col = npp->c_tail; col != NULL; col = col->prev)
+ { /* skip continuous variable */
+ if (!col->is_int) continue;
+ /* skip fixed variable */
+ if (col->lb == col->ub) continue;
+ /* skip binary variable */
+ if (col->lb == 0.0 && col->ub == 1.0) continue;
+ /* check if the transformation is applicable */
+ if (col->lb < -1e6 || col->ub > +1e6 ||
+ col->ub - col->lb > 4095.0)
+ { /* unfortunately, not */
+ nfails++;
+ continue;
+ }
+ /* process integer non-binary variable x[q] */
+ nvars++;
+ /* make x[q] non-negative, if its lower bound is non-zero */
+ if (col->lb != 0.0)
+ npp_lbnd_col(npp, col);
+ /* now 0 <= x[q] <= u[q] */
+ xassert(col->lb == 0.0);
+ u = (int)col->ub;
+ xassert(col->ub == (double)u);
+ /* if x[q] is binary, further processing is not needed */
+ if (u == 1) continue;
+ /* determine smallest n such that u <= 2^n - 1 (thus, n is the
+ number of binary variables needed) */
+ n = 2, temp = 4;
+ while (u >= temp)
+ n++, temp += temp;
+ nbins += n;
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_binarize_prob, sizeof(struct binarize));
+ info->q = col->j;
+ info->j = 0; /* will be set below */
+ info->n = n;
+ /* if u < 2^n - 1, we need one additional row for (4) */
+ if (u < temp - 1)
+ { row = npp_add_row(npp), nrows++;
+ row->lb = -DBL_MAX, row->ub = u;
+ }
+ else
+ row = NULL;
+ /* in the transformed problem variable x[q] becomes binary
+ variable x[0], so its objective and constraint coefficients
+ are not changed */
+ col->ub = 1.0;
+ /* include x[0] into constraint (4) */
+ if (row != NULL)
+ npp_add_aij(npp, row, col, 1.0);
+ /* add other binary variables x[1], ..., x[n-1] */
+ for (k = 1, temp = 2; k < n; k++, temp += temp)
+ { /* add new binary variable x[k] */
+ bin = npp_add_col(npp);
+ bin->is_int = 1;
+ bin->lb = 0.0, bin->ub = 1.0;
+ bin->coef = (double)temp * col->coef;
+ /* store column reference number for x[1] */
+ if (info->j == 0)
+ info->j = bin->j;
+ else
+ xassert(info->j + (k-1) == bin->j);
+ /* duplicate constraint coefficients for x[k]; this also
+ automatically includes x[k] into constraint (4) */
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ npp_add_aij(npp, aij->row, bin, (double)temp * aij->val);
+ }
+ }
+ if (nvars > 0)
+ xprintf("%d integer variable(s) were replaced by %d binary one"
+ "s\n", nvars, nbins);
+ if (nrows > 0)
+ xprintf("%d row(s) were added due to binarization\n", nrows);
+ if (nfails > 0)
+ xprintf("Binarization failed for %d integer variable(s)\n",
+ nfails);
+ return nfails;
+}
+
+static int rcv_binarize_prob(NPP *npp, void *_info)
+{ /* recovery binarized variable */
+ struct binarize *info = _info;
+ int k, temp;
+ double sum;
+ /* compute value of x[q]; see formula (3) */
+ sum = npp->c_value[info->q];
+ for (k = 1, temp = 2; k < info->n; k++, temp += temp)
+ sum += (double)temp * npp->c_value[info->j + (k-1)];
+ npp->c_value[info->q] = sum;
+ return 0;
+}
+
+/**********************************************************************/
+
+struct elem
+{ /* linear form element a[j] x[j] */
+ double aj;
+ /* non-zero coefficient value */
+ NPPCOL *xj;
+ /* pointer to variable (column) */
+ struct elem *next;
+ /* pointer to another term */
+};
+
+static struct elem *copy_form(NPP *npp, NPPROW *row, double s)
+{ /* copy linear form */
+ NPPAIJ *aij;
+ struct elem *ptr, *e;
+ ptr = NULL;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { e = dmp_get_atom(npp->pool, sizeof(struct elem));
+ e->aj = s * aij->val;
+ e->xj = aij->col;
+ e->next = ptr;
+ ptr = e;
+ }
+ return ptr;
+}
+
+static void drop_form(NPP *npp, struct elem *ptr)
+{ /* drop linear form */
+ struct elem *e;
+ while (ptr != NULL)
+ { e = ptr;
+ ptr = e->next;
+ dmp_free_atom(npp->pool, e, sizeof(struct elem));
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_is_packing - test if constraint is packing inequality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_is_packing(NPP *npp, NPPROW *row);
+*
+* RETURNS
+*
+* If the specified row (constraint) is packing inequality (see below),
+* the routine npp_is_packing returns non-zero. Otherwise, it returns
+* zero.
+*
+* PACKING INEQUALITIES
+*
+* In canonical format the packing inequality is the following:
+*
+* sum x[j] <= 1, (1)
+* j in J
+*
+* where all variables x[j] are binary. This inequality expresses the
+* condition that in any integer feasible solution at most one variable
+* from set J can take non-zero (unity) value while other variables
+* must be equal to zero. W.l.o.g. it is assumed that |J| >= 2, because
+* if J is empty or |J| = 1, the inequality (1) is redundant.
+*
+* In general case the packing inequality may include original variables
+* x[j] as well as their complements x~[j]:
+*
+* sum x[j] + sum x~[j] <= 1, (2)
+* j in Jp j in Jn
+*
+* where Jp and Jn are not intersected. Therefore, using substitution
+* x~[j] = 1 - x[j] gives the packing inequality in generalized format:
+*
+* sum x[j] - sum x[j] <= 1 - |Jn|. (3)
+* j in Jp j in Jn */
+
+int npp_is_packing(NPP *npp, NPPROW *row)
+{ /* test if constraint is packing inequality */
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int b;
+ xassert(npp == npp);
+ if (!(row->lb == -DBL_MAX && row->ub != +DBL_MAX))
+ return 0;
+ b = 1;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ return 0;
+ if (aij->val == +1.0)
+ ;
+ else if (aij->val == -1.0)
+ b--;
+ else
+ return 0;
+ }
+ if (row->ub != (double)b) return 0;
+ return 1;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_hidden_packing - identify hidden packing inequality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_hidden_packing(NPP *npp, NPPROW *row);
+*
+* DESCRIPTION
+*
+* The routine npp_hidden_packing processes specified inequality
+* constraint, which includes only binary variables, and the number of
+* the variables is not less than two. If the original inequality is
+* equivalent to a packing inequality, the routine replaces it by this
+* equivalent inequality. If the original constraint is double-sided
+* inequality, it is replaced by a pair of single-sided inequalities,
+* if necessary.
+*
+* RETURNS
+*
+* If the original inequality constraint was replaced by equivalent
+* packing inequality, the routine npp_hidden_packing returns non-zero.
+* Otherwise, it returns zero.
+*
+* PROBLEM TRANSFORMATION
+*
+* Consider an inequality constraint:
+*
+* sum a[j] x[j] <= b, (1)
+* j in J
+*
+* where all variables x[j] are binary, and |J| >= 2. (In case of '>='
+* inequality it can be transformed to '<=' format by multiplying both
+* its sides by -1.)
+*
+* Let Jp = {j: a[j] > 0}, Jn = {j: a[j] < 0}. Performing substitution
+* x[j] = 1 - x~[j] for all j in Jn, we have:
+*
+* sum a[j] x[j] <= b ==>
+* j in J
+*
+* sum a[j] x[j] + sum a[j] x[j] <= b ==>
+* j in Jp j in Jn
+*
+* sum a[j] x[j] + sum a[j] (1 - x~[j]) <= b ==>
+* j in Jp j in Jn
+*
+* sum a[j] x[j] - sum a[j] x~[j] <= b - sum a[j].
+* j in Jp j in Jn j in Jn
+*
+* Thus, meaning the transformation above, we can assume that in
+* inequality (1) all coefficients a[j] are positive. Moreover, we can
+* assume that a[j] <= b. In fact, let a[j] > b; then the following
+* three cases are possible:
+*
+* 1) b < 0. In this case inequality (1) is infeasible, so the problem
+* has no feasible solution (see the routine npp_analyze_row);
+*
+* 2) b = 0. In this case inequality (1) is a forcing inequality on its
+* upper bound (see the routine npp_forcing row), from which it
+* follows that all variables x[j] should be fixed at zero;
+*
+* 3) b > 0. In this case inequality (1) defines an implied zero upper
+* bound for variable x[j] (see the routine npp_implied_bounds), from
+* which it follows that x[j] should be fixed at zero.
+*
+* It is assumed that all three cases listed above have been recognized
+* by the routine npp_process_prob, which performs basic MIP processing
+* prior to a call the routine npp_hidden_packing. So, if one of these
+* cases occurs, we should just skip processing such constraint.
+*
+* Thus, let 0 < a[j] <= b. Then it is obvious that constraint (1) is
+* equivalent to packing inquality only if:
+*
+* a[j] + a[k] > b + eps (2)
+*
+* for all j, k in J, j != k, where eps is an absolute tolerance for
+* row (linear form) value. Checking the condition (2) for all j and k,
+* j != k, requires time O(|J|^2). However, this time can be reduced to
+* O(|J|), if use minimal a[j] and a[k], in which case it is sufficient
+* to check the condition (2) only once.
+*
+* Once the original inequality (1) is replaced by equivalent packing
+* inequality, we need to perform back substitution x~[j] = 1 - x[j] for
+* all j in Jn (see above).
+*
+* RECOVERING SOLUTION
+*
+* None needed. */
+
+static int hidden_packing(NPP *npp, struct elem *ptr, double *_b)
+{ /* process inequality constraint: sum a[j] x[j] <= b;
+ 0 - specified row is NOT hidden packing inequality;
+ 1 - specified row is packing inequality;
+ 2 - specified row is hidden packing inequality. */
+ struct elem *e, *ej, *ek;
+ int neg;
+ double b = *_b, eps;
+ xassert(npp == npp);
+ /* a[j] must be non-zero, x[j] must be binary, for all j in J */
+ for (e = ptr; e != NULL; e = e->next)
+ { xassert(e->aj != 0.0);
+ xassert(e->xj->is_int);
+ xassert(e->xj->lb == 0.0 && e->xj->ub == 1.0);
+ }
+ /* check if the specified inequality constraint already has the
+ form of packing inequality */
+ neg = 0; /* neg is |Jn| */
+ for (e = ptr; e != NULL; e = e->next)
+ { if (e->aj == +1.0)
+ ;
+ else if (e->aj == -1.0)
+ neg++;
+ else
+ break;
+ }
+ if (e == NULL)
+ { /* all coefficients a[j] are +1 or -1; check rhs b */
+ if (b == (double)(1 - neg))
+ { /* it is packing inequality; no processing is needed */
+ return 1;
+ }
+ }
+ /* substitute x[j] = 1 - x~[j] for all j in Jn to make all a[j]
+ positive; the result is a~[j] = |a[j]| and new rhs b */
+ for (e = ptr; e != NULL; e = e->next)
+ if (e->aj < 0) b -= e->aj;
+ /* now a[j] > 0 for all j in J (actually |a[j]| are used) */
+ /* if a[j] > b, skip processing--this case must not appear */
+ for (e = ptr; e != NULL; e = e->next)
+ if (fabs(e->aj) > b) return 0;
+ /* now 0 < a[j] <= b for all j in J */
+ /* find two minimal coefficients a[j] and a[k], j != k */
+ ej = NULL;
+ for (e = ptr; e != NULL; e = e->next)
+ if (ej == NULL || fabs(ej->aj) > fabs(e->aj)) ej = e;
+ xassert(ej != NULL);
+ ek = NULL;
+ for (e = ptr; e != NULL; e = e->next)
+ if (e != ej)
+ if (ek == NULL || fabs(ek->aj) > fabs(e->aj)) ek = e;
+ xassert(ek != NULL);
+ /* the specified constraint is equivalent to packing inequality
+ iff a[j] + a[k] > b + eps */
+ eps = 1e-3 + 1e-6 * fabs(b);
+ if (fabs(ej->aj) + fabs(ek->aj) <= b + eps) return 0;
+ /* perform back substitution x~[j] = 1 - x[j] and construct the
+ final equivalent packing inequality in generalized format */
+ b = 1.0;
+ for (e = ptr; e != NULL; e = e->next)
+ { if (e->aj > 0.0)
+ e->aj = +1.0;
+ else /* e->aj < 0.0 */
+ e->aj = -1.0, b -= 1.0;
+ }
+ *_b = b;
+ return 2;
+}
+
+int npp_hidden_packing(NPP *npp, NPPROW *row)
+{ /* identify hidden packing inequality */
+ NPPROW *copy;
+ NPPAIJ *aij;
+ struct elem *ptr, *e;
+ int kase, ret, count = 0;
+ double b;
+ /* the row must be inequality constraint */
+ xassert(row->lb < row->ub);
+ for (kase = 0; kase <= 1; kase++)
+ { if (kase == 0)
+ { /* process row upper bound */
+ if (row->ub == +DBL_MAX) continue;
+ ptr = copy_form(npp, row, +1.0);
+ b = + row->ub;
+ }
+ else
+ { /* process row lower bound */
+ if (row->lb == -DBL_MAX) continue;
+ ptr = copy_form(npp, row, -1.0);
+ b = - row->lb;
+ }
+ /* now the inequality has the form "sum a[j] x[j] <= b" */
+ ret = hidden_packing(npp, ptr, &b);
+ xassert(0 <= ret && ret <= 2);
+ if (kase == 1 && ret == 1 || ret == 2)
+ { /* the original inequality has been identified as hidden
+ packing inequality */
+ count++;
+#ifdef GLP_DEBUG
+ xprintf("Original constraint:\n");
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ xprintf(" %+g x%d", aij->val, aij->col->j);
+ if (row->lb != -DBL_MAX) xprintf(", >= %g", row->lb);
+ if (row->ub != +DBL_MAX) xprintf(", <= %g", row->ub);
+ xprintf("\n");
+ xprintf("Equivalent packing inequality:\n");
+ for (e = ptr; e != NULL; e = e->next)
+ xprintf(" %sx%d", e->aj > 0.0 ? "+" : "-", e->xj->j);
+ xprintf(", <= %g\n", b);
+#endif
+ if (row->lb == -DBL_MAX || row->ub == +DBL_MAX)
+ { /* the original row is single-sided inequality; no copy
+ is needed */
+ copy = NULL;
+ }
+ else
+ { /* the original row is double-sided inequality; we need
+ to create its copy for other bound before replacing it
+ with the equivalent inequality */
+ copy = npp_add_row(npp);
+ if (kase == 0)
+ { /* the copy is for lower bound */
+ copy->lb = row->lb, copy->ub = +DBL_MAX;
+ }
+ else
+ { /* the copy is for upper bound */
+ copy->lb = -DBL_MAX, copy->ub = row->ub;
+ }
+ /* copy original row coefficients */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_add_aij(npp, copy, aij->col, aij->val);
+ }
+ /* replace the original inequality by equivalent one */
+ npp_erase_row(npp, row);
+ row->lb = -DBL_MAX, row->ub = b;
+ for (e = ptr; e != NULL; e = e->next)
+ npp_add_aij(npp, row, e->xj, e->aj);
+ /* continue processing lower bound for the copy */
+ if (copy != NULL) row = copy;
+ }
+ drop_form(npp, ptr);
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_implied_packing - identify implied packing inequality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_implied_packing(NPP *npp, NPPROW *row, int which,
+* NPPCOL *var[], char set[]);
+*
+* DESCRIPTION
+*
+* The routine npp_implied_packing processes specified row (constraint)
+* of general format:
+*
+* L <= sum a[j] x[j] <= U. (1)
+* j
+*
+* If which = 0, only lower bound L, which must exist, is considered,
+* while upper bound U is ignored. Similarly, if which = 1, only upper
+* bound U, which must exist, is considered, while lower bound L is
+* ignored. Thus, if the specified row is a double-sided inequality or
+* equality constraint, this routine should be called twice for both
+* lower and upper bounds.
+*
+* The routine npp_implied_packing attempts to find a non-trivial (i.e.
+* having not less than two binary variables) packing inequality:
+*
+* sum x[j] - sum x[j] <= 1 - |Jn|, (2)
+* j in Jp j in Jn
+*
+* which is relaxation of the constraint (1) in the sense that any
+* solution satisfying to that constraint also satisfies to the packing
+* inequality (2). If such relaxation exists, the routine stores
+* pointers to descriptors of corresponding binary variables and their
+* flags, resp., to locations var[1], var[2], ..., var[len] and set[1],
+* set[2], ..., set[len], where set[j] = 0 means that j in Jp and
+* set[j] = 1 means that j in Jn.
+*
+* RETURNS
+*
+* The routine npp_implied_packing returns len, which is the total
+* number of binary variables in the packing inequality found, len >= 2.
+* However, if the relaxation does not exist, the routine returns zero.
+*
+* ALGORITHM
+*
+* If which = 0, the constraint coefficients (1) are multiplied by -1
+* and b is assigned -L; if which = 1, the constraint coefficients (1)
+* are not changed and b is assigned +U. In both cases the specified
+* constraint gets the following format:
+*
+* sum a[j] x[j] <= b. (3)
+* j
+*
+* (Note that (3) is a relaxation of (1), because one of bounds L or U
+* is ignored.)
+*
+* Let J be set of binary variables, Kp be set of non-binary (integer
+* or continuous) variables with a[j] > 0, and Kn be set of non-binary
+* variables with a[j] < 0. Then the inequality (3) can be written as
+* follows:
+*
+* sum a[j] x[j] <= b - sum a[j] x[j] - sum a[j] x[j]. (4)
+* j in J j in Kp j in Kn
+*
+* To get rid of non-binary variables we can replace the inequality (4)
+* by the following relaxed inequality:
+*
+* sum a[j] x[j] <= b~, (5)
+* j in J
+*
+* where:
+*
+* b~ = sup(b - sum a[j] x[j] - sum a[j] x[j]) =
+* j in Kp j in Kn
+*
+* = b - inf sum a[j] x[j] - inf sum a[j] x[j] = (6)
+* j in Kp j in Kn
+*
+* = b - sum a[j] l[j] - sum a[j] u[j].
+* j in Kp j in Kn
+*
+* Note that if lower bound l[j] (if j in Kp) or upper bound u[j]
+* (if j in Kn) of some non-binary variable x[j] does not exist, then
+* formally b = +oo, in which case further analysis is not performed.
+*
+* Let Bp = {j in J: a[j] > 0}, Bn = {j in J: a[j] < 0}. To make all
+* the inequality coefficients in (5) positive, we replace all x[j] in
+* Bn by their complementaries, substituting x[j] = 1 - x~[j] for all
+* j in Bn, that gives:
+*
+* sum a[j] x[j] - sum a[j] x~[j] <= b~ - sum a[j]. (7)
+* j in Bp j in Bn j in Bn
+*
+* This inequality is a relaxation of the original constraint (1), and
+* it is a binary knapsack inequality. Writing it in the standard format
+* we have:
+*
+* sum alfa[j] z[j] <= beta, (8)
+* j in J
+*
+* where:
+* ( + a[j], if j in Bp,
+* alfa[j] = < (9)
+* ( - a[j], if j in Bn,
+*
+* ( x[j], if j in Bp,
+* z[j] = < (10)
+* ( 1 - x[j], if j in Bn,
+*
+* beta = b~ - sum a[j]. (11)
+* j in Bn
+*
+* In the inequality (8) all coefficients are positive, therefore, the
+* packing relaxation to be found for this inequality is the following:
+*
+* sum z[j] <= 1. (12)
+* j in P
+*
+* It is obvious that set P within J, which we would like to find, must
+* satisfy to the following condition:
+*
+* alfa[j] + alfa[k] > beta + eps for all j, k in P, j != k, (13)
+*
+* where eps is an absolute tolerance for value of the linear form.
+* Thus, it is natural to take P = {j: alpha[j] > (beta + eps) / 2}.
+* Moreover, if in the equality (8) there exist coefficients alfa[k],
+* for which alfa[k] <= (beta + eps) / 2, but which, nevertheless,
+* satisfies to the condition (13) for all j in P, *one* corresponding
+* variable z[k] (having, for example, maximal coefficient alfa[k]) can
+* be included in set P, that allows increasing the number of binary
+* variables in (12) by one.
+*
+* Once the set P has been built, for the inequality (12) we need to
+* perform back substitution according to (10) in order to express it
+* through the original binary variables. As the result of such back
+* substitution the relaxed packing inequality get its final format (2),
+* where Jp = J intersect Bp, and Jn = J intersect Bn. */
+
+int npp_implied_packing(NPP *npp, NPPROW *row, int which,
+ NPPCOL *var[], char set[])
+{ struct elem *ptr, *e, *i, *k;
+ int len = 0;
+ double b, eps;
+ /* build inequality (3) */
+ if (which == 0)
+ { ptr = copy_form(npp, row, -1.0);
+ xassert(row->lb != -DBL_MAX);
+ b = - row->lb;
+ }
+ else if (which == 1)
+ { ptr = copy_form(npp, row, +1.0);
+ xassert(row->ub != +DBL_MAX);
+ b = + row->ub;
+ }
+ /* remove non-binary variables to build relaxed inequality (5);
+ compute its right-hand side b~ with formula (6) */
+ for (e = ptr; e != NULL; e = e->next)
+ { if (!(e->xj->is_int && e->xj->lb == 0.0 && e->xj->ub == 1.0))
+ { /* x[j] is non-binary variable */
+ if (e->aj > 0.0)
+ { if (e->xj->lb == -DBL_MAX) goto done;
+ b -= e->aj * e->xj->lb;
+ }
+ else /* e->aj < 0.0 */
+ { if (e->xj->ub == +DBL_MAX) goto done;
+ b -= e->aj * e->xj->ub;
+ }
+ /* a[j] = 0 means that variable x[j] is removed */
+ e->aj = 0.0;
+ }
+ }
+ /* substitute x[j] = 1 - x~[j] to build knapsack inequality (8);
+ compute its right-hand side beta with formula (11) */
+ for (e = ptr; e != NULL; e = e->next)
+ if (e->aj < 0.0) b -= e->aj;
+ /* if beta is close to zero, the knapsack inequality is either
+ infeasible or forcing inequality; this must never happen, so
+ we skip further analysis */
+ if (b < 1e-3) goto done;
+ /* build set P as well as sets Jp and Jn, and determine x[k] as
+ explained above in comments to the routine */
+ eps = 1e-3 + 1e-6 * b;
+ i = k = NULL;
+ for (e = ptr; e != NULL; e = e->next)
+ { /* note that alfa[j] = |a[j]| */
+ if (fabs(e->aj) > 0.5 * (b + eps))
+ { /* alfa[j] > (b + eps) / 2; include x[j] in set P, i.e. in
+ set Jp or Jn */
+ var[++len] = e->xj;
+ set[len] = (char)(e->aj > 0.0 ? 0 : 1);
+ /* alfa[i] = min alfa[j] over all j included in set P */
+ if (i == NULL || fabs(i->aj) > fabs(e->aj)) i = e;
+ }
+ else if (fabs(e->aj) >= 1e-3)
+ { /* alfa[k] = max alfa[j] over all j not included in set P;
+ we skip coefficient a[j] if it is close to zero to avoid
+ numerically unreliable results */
+ if (k == NULL || fabs(k->aj) < fabs(e->aj)) k = e;
+ }
+ }
+ /* if alfa[k] satisfies to condition (13) for all j in P, include
+ x[k] in P */
+ if (i != NULL && k != NULL && fabs(i->aj) + fabs(k->aj) > b + eps)
+ { var[++len] = k->xj;
+ set[len] = (char)(k->aj > 0.0 ? 0 : 1);
+ }
+ /* trivial packing inequality being redundant must never appear,
+ so we just ignore it */
+ if (len < 2) len = 0;
+done: drop_form(npp, ptr);
+ return len;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_is_covering - test if constraint is covering inequality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_is_covering(NPP *npp, NPPROW *row);
+*
+* RETURNS
+*
+* If the specified row (constraint) is covering inequality (see below),
+* the routine npp_is_covering returns non-zero. Otherwise, it returns
+* zero.
+*
+* COVERING INEQUALITIES
+*
+* In canonical format the covering inequality is the following:
+*
+* sum x[j] >= 1, (1)
+* j in J
+*
+* where all variables x[j] are binary. This inequality expresses the
+* condition that in any integer feasible solution variables in set J
+* cannot be all equal to zero at the same time, i.e. at least one
+* variable must take non-zero (unity) value. W.l.o.g. it is assumed
+* that |J| >= 2, because if J is empty, the inequality (1) is
+* infeasible, and if |J| = 1, the inequality (1) is a forcing row.
+*
+* In general case the covering inequality may include original
+* variables x[j] as well as their complements x~[j]:
+*
+* sum x[j] + sum x~[j] >= 1, (2)
+* j in Jp j in Jn
+*
+* where Jp and Jn are not intersected. Therefore, using substitution
+* x~[j] = 1 - x[j] gives the packing inequality in generalized format:
+*
+* sum x[j] - sum x[j] >= 1 - |Jn|. (3)
+* j in Jp j in Jn
+*
+* (May note that the inequality (3) cuts off infeasible solutions,
+* where x[j] = 0 for all j in Jp and x[j] = 1 for all j in Jn.)
+*
+* NOTE: If |J| = 2, the inequality (3) is equivalent to packing
+* inequality (see the routine npp_is_packing). */
+
+int npp_is_covering(NPP *npp, NPPROW *row)
+{ /* test if constraint is covering inequality */
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int b;
+ xassert(npp == npp);
+ if (!(row->lb != -DBL_MAX && row->ub == +DBL_MAX))
+ return 0;
+ b = 1;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ return 0;
+ if (aij->val == +1.0)
+ ;
+ else if (aij->val == -1.0)
+ b--;
+ else
+ return 0;
+ }
+ if (row->lb != (double)b) return 0;
+ return 1;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_hidden_covering - identify hidden covering inequality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_hidden_covering(NPP *npp, NPPROW *row);
+*
+* DESCRIPTION
+*
+* The routine npp_hidden_covering processes specified inequality
+* constraint, which includes only binary variables, and the number of
+* the variables is not less than three. If the original inequality is
+* equivalent to a covering inequality (see below), the routine
+* replaces it by the equivalent inequality. If the original constraint
+* is double-sided inequality, it is replaced by a pair of single-sided
+* inequalities, if necessary.
+*
+* RETURNS
+*
+* If the original inequality constraint was replaced by equivalent
+* covering inequality, the routine npp_hidden_covering returns
+* non-zero. Otherwise, it returns zero.
+*
+* PROBLEM TRANSFORMATION
+*
+* Consider an inequality constraint:
+*
+* sum a[j] x[j] >= b, (1)
+* j in J
+*
+* where all variables x[j] are binary, and |J| >= 3. (In case of '<='
+* inequality it can be transformed to '>=' format by multiplying both
+* its sides by -1.)
+*
+* Let Jp = {j: a[j] > 0}, Jn = {j: a[j] < 0}. Performing substitution
+* x[j] = 1 - x~[j] for all j in Jn, we have:
+*
+* sum a[j] x[j] >= b ==>
+* j in J
+*
+* sum a[j] x[j] + sum a[j] x[j] >= b ==>
+* j in Jp j in Jn
+*
+* sum a[j] x[j] + sum a[j] (1 - x~[j]) >= b ==>
+* j in Jp j in Jn
+*
+* sum m a[j] x[j] - sum a[j] x~[j] >= b - sum a[j].
+* j in Jp j in Jn j in Jn
+*
+* Thus, meaning the transformation above, we can assume that in
+* inequality (1) all coefficients a[j] are positive. Moreover, we can
+* assume that b > 0, because otherwise the inequality (1) would be
+* redundant (see the routine npp_analyze_row). It is then obvious that
+* constraint (1) is equivalent to covering inequality only if:
+*
+* a[j] >= b, (2)
+*
+* for all j in J.
+*
+* Once the original inequality (1) is replaced by equivalent covering
+* inequality, we need to perform back substitution x~[j] = 1 - x[j] for
+* all j in Jn (see above).
+*
+* RECOVERING SOLUTION
+*
+* None needed. */
+
+static int hidden_covering(NPP *npp, struct elem *ptr, double *_b)
+{ /* process inequality constraint: sum a[j] x[j] >= b;
+ 0 - specified row is NOT hidden covering inequality;
+ 1 - specified row is covering inequality;
+ 2 - specified row is hidden covering inequality. */
+ struct elem *e;
+ int neg;
+ double b = *_b, eps;
+ xassert(npp == npp);
+ /* a[j] must be non-zero, x[j] must be binary, for all j in J */
+ for (e = ptr; e != NULL; e = e->next)
+ { xassert(e->aj != 0.0);
+ xassert(e->xj->is_int);
+ xassert(e->xj->lb == 0.0 && e->xj->ub == 1.0);
+ }
+ /* check if the specified inequality constraint already has the
+ form of covering inequality */
+ neg = 0; /* neg is |Jn| */
+ for (e = ptr; e != NULL; e = e->next)
+ { if (e->aj == +1.0)
+ ;
+ else if (e->aj == -1.0)
+ neg++;
+ else
+ break;
+ }
+ if (e == NULL)
+ { /* all coefficients a[j] are +1 or -1; check rhs b */
+ if (b == (double)(1 - neg))
+ { /* it is covering inequality; no processing is needed */
+ return 1;
+ }
+ }
+ /* substitute x[j] = 1 - x~[j] for all j in Jn to make all a[j]
+ positive; the result is a~[j] = |a[j]| and new rhs b */
+ for (e = ptr; e != NULL; e = e->next)
+ if (e->aj < 0) b -= e->aj;
+ /* now a[j] > 0 for all j in J (actually |a[j]| are used) */
+ /* if b <= 0, skip processing--this case must not appear */
+ if (b < 1e-3) return 0;
+ /* now a[j] > 0 for all j in J, and b > 0 */
+ /* the specified constraint is equivalent to covering inequality
+ iff a[j] >= b for all j in J */
+ eps = 1e-9 + 1e-12 * fabs(b);
+ for (e = ptr; e != NULL; e = e->next)
+ if (fabs(e->aj) < b - eps) return 0;
+ /* perform back substitution x~[j] = 1 - x[j] and construct the
+ final equivalent covering inequality in generalized format */
+ b = 1.0;
+ for (e = ptr; e != NULL; e = e->next)
+ { if (e->aj > 0.0)
+ e->aj = +1.0;
+ else /* e->aj < 0.0 */
+ e->aj = -1.0, b -= 1.0;
+ }
+ *_b = b;
+ return 2;
+}
+
+int npp_hidden_covering(NPP *npp, NPPROW *row)
+{ /* identify hidden covering inequality */
+ NPPROW *copy;
+ NPPAIJ *aij;
+ struct elem *ptr, *e;
+ int kase, ret, count = 0;
+ double b;
+ /* the row must be inequality constraint */
+ xassert(row->lb < row->ub);
+ for (kase = 0; kase <= 1; kase++)
+ { if (kase == 0)
+ { /* process row lower bound */
+ if (row->lb == -DBL_MAX) continue;
+ ptr = copy_form(npp, row, +1.0);
+ b = + row->lb;
+ }
+ else
+ { /* process row upper bound */
+ if (row->ub == +DBL_MAX) continue;
+ ptr = copy_form(npp, row, -1.0);
+ b = - row->ub;
+ }
+ /* now the inequality has the form "sum a[j] x[j] >= b" */
+ ret = hidden_covering(npp, ptr, &b);
+ xassert(0 <= ret && ret <= 2);
+ if (kase == 1 && ret == 1 || ret == 2)
+ { /* the original inequality has been identified as hidden
+ covering inequality */
+ count++;
+#ifdef GLP_DEBUG
+ xprintf("Original constraint:\n");
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ xprintf(" %+g x%d", aij->val, aij->col->j);
+ if (row->lb != -DBL_MAX) xprintf(", >= %g", row->lb);
+ if (row->ub != +DBL_MAX) xprintf(", <= %g", row->ub);
+ xprintf("\n");
+ xprintf("Equivalent covering inequality:\n");
+ for (e = ptr; e != NULL; e = e->next)
+ xprintf(" %sx%d", e->aj > 0.0 ? "+" : "-", e->xj->j);
+ xprintf(", >= %g\n", b);
+#endif
+ if (row->lb == -DBL_MAX || row->ub == +DBL_MAX)
+ { /* the original row is single-sided inequality; no copy
+ is needed */
+ copy = NULL;
+ }
+ else
+ { /* the original row is double-sided inequality; we need
+ to create its copy for other bound before replacing it
+ with the equivalent inequality */
+ copy = npp_add_row(npp);
+ if (kase == 0)
+ { /* the copy is for upper bound */
+ copy->lb = -DBL_MAX, copy->ub = row->ub;
+ }
+ else
+ { /* the copy is for lower bound */
+ copy->lb = row->lb, copy->ub = +DBL_MAX;
+ }
+ /* copy original row coefficients */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_add_aij(npp, copy, aij->col, aij->val);
+ }
+ /* replace the original inequality by equivalent one */
+ npp_erase_row(npp, row);
+ row->lb = b, row->ub = +DBL_MAX;
+ for (e = ptr; e != NULL; e = e->next)
+ npp_add_aij(npp, row, e->xj, e->aj);
+ /* continue processing upper bound for the copy */
+ if (copy != NULL) row = copy;
+ }
+ drop_form(npp, ptr);
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_is_partitioning - test if constraint is partitioning equality
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_is_partitioning(NPP *npp, NPPROW *row);
+*
+* RETURNS
+*
+* If the specified row (constraint) is partitioning equality (see
+* below), the routine npp_is_partitioning returns non-zero. Otherwise,
+* it returns zero.
+*
+* PARTITIONING EQUALITIES
+*
+* In canonical format the partitioning equality is the following:
+*
+* sum x[j] = 1, (1)
+* j in J
+*
+* where all variables x[j] are binary. This equality expresses the
+* condition that in any integer feasible solution exactly one variable
+* in set J must take non-zero (unity) value while other variables must
+* be equal to zero. W.l.o.g. it is assumed that |J| >= 2, because if
+* J is empty, the inequality (1) is infeasible, and if |J| = 1, the
+* inequality (1) is a fixing row.
+*
+* In general case the partitioning equality may include original
+* variables x[j] as well as their complements x~[j]:
+*
+* sum x[j] + sum x~[j] = 1, (2)
+* j in Jp j in Jn
+*
+* where Jp and Jn are not intersected. Therefore, using substitution
+* x~[j] = 1 - x[j] leads to the partitioning equality in generalized
+* format:
+*
+* sum x[j] - sum x[j] = 1 - |Jn|. (3)
+* j in Jp j in Jn */
+
+int npp_is_partitioning(NPP *npp, NPPROW *row)
+{ /* test if constraint is partitioning equality */
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int b;
+ xassert(npp == npp);
+ if (row->lb != row->ub) return 0;
+ b = 1;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ return 0;
+ if (aij->val == +1.0)
+ ;
+ else if (aij->val == -1.0)
+ b--;
+ else
+ return 0;
+ }
+ if (row->lb != (double)b) return 0;
+ return 1;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_reduce_ineq_coef - reduce inequality constraint coefficients
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_reduce_ineq_coef(NPP *npp, NPPROW *row);
+*
+* DESCRIPTION
+*
+* The routine npp_reduce_ineq_coef processes specified inequality
+* constraint attempting to replace it by an equivalent constraint,
+* where magnitude of coefficients at binary variables is smaller than
+* in the original constraint. If the inequality is double-sided, it is
+* replaced by a pair of single-sided inequalities, if necessary.
+*
+* RETURNS
+*
+* The routine npp_reduce_ineq_coef returns the number of coefficients
+* reduced.
+*
+* BACKGROUND
+*
+* Consider an inequality constraint:
+*
+* sum a[j] x[j] >= b. (1)
+* j in J
+*
+* (In case of '<=' inequality it can be transformed to '>=' format by
+* multiplying both its sides by -1.) Let x[k] be a binary variable;
+* other variables can be integer as well as continuous. We can write
+* constraint (1) as follows:
+*
+* a[k] x[k] + t[k] >= b, (2)
+*
+* where:
+*
+* t[k] = sum a[j] x[j]. (3)
+* j in J\{k}
+*
+* Since x[k] is binary, constraint (2) is equivalent to disjunction of
+* the following two constraints:
+*
+* x[k] = 0, t[k] >= b (4)
+*
+* OR
+*
+* x[k] = 1, t[k] >= b - a[k]. (5)
+*
+* Let also that for the partial sum t[k] be known some its implied
+* lower bound inf t[k].
+*
+* Case a[k] > 0. Let inf t[k] < b, since otherwise both constraints
+* (4) and (5) and therefore constraint (2) are redundant.
+* If inf t[k] > b - a[k], only constraint (5) is redundant, in which
+* case it can be replaced with the following redundant and therefore
+* equivalent constraint:
+*
+* t[k] >= b - a'[k] = inf t[k], (6)
+*
+* where:
+*
+* a'[k] = b - inf t[k]. (7)
+*
+* Thus, the original constraint (2) is equivalent to the following
+* constraint with coefficient at variable x[k] changed:
+*
+* a'[k] x[k] + t[k] >= b. (8)
+*
+* From inf t[k] < b it follows that a'[k] > 0, i.e. the coefficient
+* at x[k] keeps its sign. And from inf t[k] > b - a[k] it follows that
+* a'[k] < a[k], i.e. the coefficient reduces in magnitude.
+*
+* Case a[k] < 0. Let inf t[k] < b - a[k], since otherwise both
+* constraints (4) and (5) and therefore constraint (2) are redundant.
+* If inf t[k] > b, only constraint (4) is redundant, in which case it
+* can be replaced with the following redundant and therefore equivalent
+* constraint:
+*
+* t[k] >= b' = inf t[k]. (9)
+*
+* Rewriting constraint (5) as follows:
+*
+* t[k] >= b - a[k] = b' - a'[k], (10)
+*
+* where:
+*
+* a'[k] = a[k] + b' - b = a[k] + inf t[k] - b, (11)
+*
+* we can see that disjunction of constraint (9) and (10) is equivalent
+* to disjunction of constraint (4) and (5), from which it follows that
+* the original constraint (2) is equivalent to the following constraint
+* with both coefficient at variable x[k] and right-hand side changed:
+*
+* a'[k] x[k] + t[k] >= b'. (12)
+*
+* From inf t[k] < b - a[k] it follows that a'[k] < 0, i.e. the
+* coefficient at x[k] keeps its sign. And from inf t[k] > b it follows
+* that a'[k] > a[k], i.e. the coefficient reduces in magnitude.
+*
+* PROBLEM TRANSFORMATION
+*
+* In the routine npp_reduce_ineq_coef the following implied lower
+* bound of the partial sum (3) is used:
+*
+* inf t[k] = sum a[j] l[j] + sum a[j] u[j], (13)
+* j in Jp\{k} k in Jn\{k}
+*
+* where Jp = {j : a[j] > 0}, Jn = {j : a[j] < 0}, l[j] and u[j] are
+* lower and upper bounds, resp., of variable x[j].
+*
+* In order to compute inf t[k] more efficiently, the following formula,
+* which is equivalent to (13), is actually used:
+*
+* ( h - a[k] l[k] = h, if a[k] > 0,
+* inf t[k] = < (14)
+* ( h - a[k] u[k] = h - a[k], if a[k] < 0,
+*
+* where:
+*
+* h = sum a[j] l[j] + sum a[j] u[j] (15)
+* j in Jp j in Jn
+*
+* is the implied lower bound of row (1).
+*
+* Reduction of positive coefficient (a[k] > 0) does not change value
+* of h, since l[k] = 0. In case of reduction of negative coefficient
+* (a[k] < 0) from (11) it follows that:
+*
+* delta a[k] = a'[k] - a[k] = inf t[k] - b (> 0), (16)
+*
+* so new value of h (accounting that u[k] = 1) can be computed as
+* follows:
+*
+* h := h + delta a[k] = h + (inf t[k] - b). (17)
+*
+* RECOVERING SOLUTION
+*
+* None needed. */
+
+static int reduce_ineq_coef(NPP *npp, struct elem *ptr, double *_b)
+{ /* process inequality constraint: sum a[j] x[j] >= b */
+ /* returns: the number of coefficients reduced */
+ struct elem *e;
+ int count = 0;
+ double h, inf_t, new_a, b = *_b;
+ xassert(npp == npp);
+ /* compute h; see (15) */
+ h = 0.0;
+ for (e = ptr; e != NULL; e = e->next)
+ { if (e->aj > 0.0)
+ { if (e->xj->lb == -DBL_MAX) goto done;
+ h += e->aj * e->xj->lb;
+ }
+ else /* e->aj < 0.0 */
+ { if (e->xj->ub == +DBL_MAX) goto done;
+ h += e->aj * e->xj->ub;
+ }
+ }
+ /* perform reduction of coefficients at binary variables */
+ for (e = ptr; e != NULL; e = e->next)
+ { /* skip non-binary variable */
+ if (!(e->xj->is_int && e->xj->lb == 0.0 && e->xj->ub == 1.0))
+ continue;
+ if (e->aj > 0.0)
+ { /* compute inf t[k]; see (14) */
+ inf_t = h;
+ if (b - e->aj < inf_t && inf_t < b)
+ { /* compute reduced coefficient a'[k]; see (7) */
+ new_a = b - inf_t;
+ if (new_a >= +1e-3 &&
+ e->aj - new_a >= 0.01 * (1.0 + e->aj))
+ { /* accept a'[k] */
+#ifdef GLP_DEBUG
+ xprintf("+");
+#endif
+ e->aj = new_a;
+ count++;
+ }
+ }
+ }
+ else /* e->aj < 0.0 */
+ { /* compute inf t[k]; see (14) */
+ inf_t = h - e->aj;
+ if (b < inf_t && inf_t < b - e->aj)
+ { /* compute reduced coefficient a'[k]; see (11) */
+ new_a = e->aj + (inf_t - b);
+ if (new_a <= -1e-3 &&
+ new_a - e->aj >= 0.01 * (1.0 - e->aj))
+ { /* accept a'[k] */
+#ifdef GLP_DEBUG
+ xprintf("-");
+#endif
+ e->aj = new_a;
+ /* update h; see (17) */
+ h += (inf_t - b);
+ /* compute b'; see (9) */
+ b = inf_t;
+ count++;
+ }
+ }
+ }
+ }
+ *_b = b;
+done: return count;
+}
+
+int npp_reduce_ineq_coef(NPP *npp, NPPROW *row)
+{ /* reduce inequality constraint coefficients */
+ NPPROW *copy;
+ NPPAIJ *aij;
+ struct elem *ptr, *e;
+ int kase, count[2];
+ double b;
+ /* the row must be inequality constraint */
+ xassert(row->lb < row->ub);
+ count[0] = count[1] = 0;
+ for (kase = 0; kase <= 1; kase++)
+ { if (kase == 0)
+ { /* process row lower bound */
+ if (row->lb == -DBL_MAX) continue;
+#ifdef GLP_DEBUG
+ xprintf("L");
+#endif
+ ptr = copy_form(npp, row, +1.0);
+ b = + row->lb;
+ }
+ else
+ { /* process row upper bound */
+ if (row->ub == +DBL_MAX) continue;
+#ifdef GLP_DEBUG
+ xprintf("U");
+#endif
+ ptr = copy_form(npp, row, -1.0);
+ b = - row->ub;
+ }
+ /* now the inequality has the form "sum a[j] x[j] >= b" */
+ count[kase] = reduce_ineq_coef(npp, ptr, &b);
+ if (count[kase] > 0)
+ { /* the original inequality has been replaced by equivalent
+ one with coefficients reduced */
+ if (row->lb == -DBL_MAX || row->ub == +DBL_MAX)
+ { /* the original row is single-sided inequality; no copy
+ is needed */
+ copy = NULL;
+ }
+ else
+ { /* the original row is double-sided inequality; we need
+ to create its copy for other bound before replacing it
+ with the equivalent inequality */
+#ifdef GLP_DEBUG
+ xprintf("*");
+#endif
+ copy = npp_add_row(npp);
+ if (kase == 0)
+ { /* the copy is for upper bound */
+ copy->lb = -DBL_MAX, copy->ub = row->ub;
+ }
+ else
+ { /* the copy is for lower bound */
+ copy->lb = row->lb, copy->ub = +DBL_MAX;
+ }
+ /* copy original row coefficients */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_add_aij(npp, copy, aij->col, aij->val);
+ }
+ /* replace the original inequality by equivalent one */
+ npp_erase_row(npp, row);
+ row->lb = b, row->ub = +DBL_MAX;
+ for (e = ptr; e != NULL; e = e->next)
+ npp_add_aij(npp, row, e->xj, e->aj);
+ /* continue processing upper bound for the copy */
+ if (copy != NULL) row = copy;
+ }
+ drop_form(npp, ptr);
+ }
+ return count[0] + count[1];
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp5.c b/test/monniaux/glpk-4.65/src/npp/npp5.c
new file mode 100644
index 00000000..2fad496d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp5.c
@@ -0,0 +1,809 @@
+/* npp5.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2009-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+/***********************************************************************
+* NAME
+*
+* npp_clean_prob - perform initial LP/MIP processing
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* void npp_clean_prob(NPP *npp);
+*
+* DESCRIPTION
+*
+* The routine npp_clean_prob performs initial LP/MIP processing that
+* currently includes:
+*
+* 1) removing free rows;
+*
+* 2) replacing double-sided constraint rows with almost identical
+* bounds, by equality constraint rows;
+*
+* 3) removing fixed columns;
+*
+* 4) replacing double-bounded columns with almost identical bounds by
+* fixed columns and removing those columns;
+*
+* 5) initial processing constraint coefficients (not implemented);
+*
+* 6) initial processing objective coefficients (not implemented). */
+
+void npp_clean_prob(NPP *npp)
+{ /* perform initial LP/MIP processing */
+ NPPROW *row, *next_row;
+ NPPCOL *col, *next_col;
+ int ret;
+ xassert(npp == npp);
+ /* process rows which originally are free */
+ for (row = npp->r_head; row != NULL; row = next_row)
+ { next_row = row->next;
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ { /* process free row */
+#ifdef GLP_DEBUG
+ xprintf("1");
+#endif
+ npp_free_row(npp, row);
+ /* row was deleted */
+ }
+ }
+ /* process rows which originally are double-sided inequalities */
+ for (row = npp->r_head; row != NULL; row = next_row)
+ { next_row = row->next;
+ if (row->lb != -DBL_MAX && row->ub != +DBL_MAX &&
+ row->lb < row->ub)
+ { ret = npp_make_equality(npp, row);
+ if (ret == 0)
+ ;
+ else if (ret == 1)
+ { /* row was replaced by equality constraint */
+#ifdef GLP_DEBUG
+ xprintf("2");
+#endif
+ }
+ else
+ xassert(ret != ret);
+ }
+ }
+ /* process columns which are originally fixed */
+ for (col = npp->c_head; col != NULL; col = next_col)
+ { next_col = col->next;
+ if (col->lb == col->ub)
+ { /* process fixed column */
+#ifdef GLP_DEBUG
+ xprintf("3");
+#endif
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ }
+ }
+ /* process columns which are originally double-bounded */
+ for (col = npp->c_head; col != NULL; col = next_col)
+ { next_col = col->next;
+ if (col->lb != -DBL_MAX && col->ub != +DBL_MAX &&
+ col->lb < col->ub)
+ { ret = npp_make_fixed(npp, col);
+ if (ret == 0)
+ ;
+ else if (ret == 1)
+ { /* column was replaced by fixed column; process it */
+#ifdef GLP_DEBUG
+ xprintf("4");
+#endif
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_process_row - perform basic row processing
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_process_row(NPP *npp, NPPROW *row, int hard);
+*
+* DESCRIPTION
+*
+* The routine npp_process_row performs basic row processing that
+* currently includes:
+*
+* 1) removing empty row;
+*
+* 2) removing equality constraint row singleton and corresponding
+* column;
+*
+* 3) removing inequality constraint row singleton and corresponding
+* column if it was fixed;
+*
+* 4) performing general row analysis;
+*
+* 5) removing redundant row bounds;
+*
+* 6) removing forcing row and corresponding columns;
+*
+* 7) removing row which becomes free due to redundant bounds;
+*
+* 8) computing implied bounds for all columns in the row and using
+* them to strengthen current column bounds (MIP only, optional,
+* performed if the flag hard is on).
+*
+* Additionally the routine may activate affected rows and/or columns
+* for further processing.
+*
+* RETURNS
+*
+* 0 success;
+*
+* GLP_ENOPFS primal/integer infeasibility detected;
+*
+* GLP_ENODFS dual infeasibility detected. */
+
+int npp_process_row(NPP *npp, NPPROW *row, int hard)
+{ /* perform basic row processing */
+ NPPCOL *col;
+ NPPAIJ *aij, *next_aij, *aaa;
+ int ret;
+ /* row must not be free */
+ xassert(!(row->lb == -DBL_MAX && row->ub == +DBL_MAX));
+ /* start processing row */
+ if (row->ptr == NULL)
+ { /* empty row */
+ ret = npp_empty_row(npp, row);
+ if (ret == 0)
+ { /* row was deleted */
+#ifdef GLP_DEBUG
+ xprintf("A");
+#endif
+ return 0;
+ }
+ else if (ret == 1)
+ { /* primal infeasibility */
+ return GLP_ENOPFS;
+ }
+ else
+ xassert(ret != ret);
+ }
+ if (row->ptr->r_next == NULL)
+ { /* row singleton */
+ col = row->ptr->col;
+ if (row->lb == row->ub)
+ { /* equality constraint */
+ ret = npp_eq_singlet(npp, row);
+ if (ret == 0)
+ { /* column was fixed, row was deleted */
+#ifdef GLP_DEBUG
+ xprintf("B");
+#endif
+ /* activate rows affected by column */
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ npp_activate_row(npp, aij->row);
+ /* process fixed column */
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ return 0;
+ }
+ else if (ret == 1 || ret == 2)
+ { /* primal/integer infeasibility */
+ return GLP_ENOPFS;
+ }
+ else
+ xassert(ret != ret);
+ }
+ else
+ { /* inequality constraint */
+ ret = npp_ineq_singlet(npp, row);
+ if (0 <= ret && ret <= 3)
+ { /* row was deleted */
+#ifdef GLP_DEBUG
+ xprintf("C");
+#endif
+ /* activate column, since its length was changed due to
+ row deletion */
+ npp_activate_col(npp, col);
+ if (ret >= 2)
+ { /* column bounds changed significantly or column was
+ fixed */
+ /* activate rows affected by column */
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ npp_activate_row(npp, aij->row);
+ }
+ if (ret == 3)
+ { /* column was fixed; process it */
+#ifdef GLP_DEBUG
+ xprintf("D");
+#endif
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ }
+ return 0;
+ }
+ else if (ret == 4)
+ { /* primal infeasibility */
+ return GLP_ENOPFS;
+ }
+ else
+ xassert(ret != ret);
+ }
+ }
+#if 0
+ /* sometimes this causes too large round-off errors; probably
+ pivot coefficient should be chosen more carefully */
+ if (row->ptr->r_next->r_next == NULL)
+ { /* row doubleton */
+ if (row->lb == row->ub)
+ { /* equality constraint */
+ if (!(row->ptr->col->is_int ||
+ row->ptr->r_next->col->is_int))
+ { /* both columns are continuous */
+ NPPCOL *q;
+ q = npp_eq_doublet(npp, row);
+ if (q != NULL)
+ { /* column q was eliminated */
+#ifdef GLP_DEBUG
+ xprintf("E");
+#endif
+ /* now column q is singleton of type "implied slack
+ variable"; we process it here to make sure that on
+ recovering basic solution the row is always active
+ equality constraint (as required by the routine
+ rcv_eq_doublet) */
+ xassert(npp_process_col(npp, q) == 0);
+ /* column q was deleted; note that row p also may be
+ deleted */
+ return 0;
+ }
+ }
+ }
+ }
+#endif
+ /* general row analysis */
+ ret = npp_analyze_row(npp, row);
+ xassert(0x00 <= ret && ret <= 0xFF);
+ if (ret == 0x33)
+ { /* row bounds are inconsistent with column bounds */
+ return GLP_ENOPFS;
+ }
+ if ((ret & 0x0F) == 0x00)
+ { /* row lower bound does not exist or redundant */
+ if (row->lb != -DBL_MAX)
+ { /* remove redundant row lower bound */
+#ifdef GLP_DEBUG
+ xprintf("F");
+#endif
+ npp_inactive_bound(npp, row, 0);
+ }
+ }
+ else if ((ret & 0x0F) == 0x01)
+ { /* row lower bound can be active */
+ /* see below */
+ }
+ else if ((ret & 0x0F) == 0x02)
+ { /* row lower bound is a forcing bound */
+#ifdef GLP_DEBUG
+ xprintf("G");
+#endif
+ /* process forcing row */
+ if (npp_forcing_row(npp, row, 0) == 0)
+fixup: { /* columns were fixed, row was made free */
+ for (aij = row->ptr; aij != NULL; aij = next_aij)
+ { /* process column fixed by forcing row */
+#ifdef GLP_DEBUG
+ xprintf("H");
+#endif
+ col = aij->col;
+ next_aij = aij->r_next;
+ /* activate rows affected by column */
+ for (aaa = col->ptr; aaa != NULL; aaa = aaa->c_next)
+ npp_activate_row(npp, aaa->row);
+ /* process fixed column */
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ }
+ /* process free row (which now is empty due to deletion of
+ all its columns) */
+ npp_free_row(npp, row);
+ /* row was deleted */
+ return 0;
+ }
+ }
+ else
+ xassert(ret != ret);
+ if ((ret & 0xF0) == 0x00)
+ { /* row upper bound does not exist or redundant */
+ if (row->ub != +DBL_MAX)
+ { /* remove redundant row upper bound */
+#ifdef GLP_DEBUG
+ xprintf("I");
+#endif
+ npp_inactive_bound(npp, row, 1);
+ }
+ }
+ else if ((ret & 0xF0) == 0x10)
+ { /* row upper bound can be active */
+ /* see below */
+ }
+ else if ((ret & 0xF0) == 0x20)
+ { /* row upper bound is a forcing bound */
+#ifdef GLP_DEBUG
+ xprintf("J");
+#endif
+ /* process forcing row */
+ if (npp_forcing_row(npp, row, 1) == 0) goto fixup;
+ }
+ else
+ xassert(ret != ret);
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ { /* row became free due to redundant bounds removal */
+#ifdef GLP_DEBUG
+ xprintf("K");
+#endif
+ /* activate its columns, since their length will change due
+ to row deletion */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_activate_col(npp, aij->col);
+ /* process free row */
+ npp_free_row(npp, row);
+ /* row was deleted */
+ return 0;
+ }
+#if 1 /* 23/XII-2009 */
+ /* row lower and/or upper bounds can be active */
+ if (npp->sol == GLP_MIP && hard)
+ { /* improve current column bounds (optional) */
+ if (npp_improve_bounds(npp, row, 1) < 0)
+ return GLP_ENOPFS;
+ }
+#endif
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_improve_bounds - improve current column bounds
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_improve_bounds(NPP *npp, NPPROW *row, int flag);
+*
+* DESCRIPTION
+*
+* The routine npp_improve_bounds analyzes specified row (inequality
+* or equality constraint) to determine implied column bounds and then
+* uses these bounds to improve (strengthen) current column bounds.
+*
+* If the flag is on and current column bounds changed significantly
+* or the column was fixed, the routine activate rows affected by the
+* column for further processing. (This feature is intended to be used
+* in the main loop of the routine npp_process_row.)
+*
+* NOTE: This operation can be used for MIP problem only.
+*
+* RETURNS
+*
+* The routine npp_improve_bounds returns the number of significantly
+* changed bounds plus the number of column having been fixed due to
+* bound improvements. However, if the routine detects primal/integer
+* infeasibility, it returns a negative value. */
+
+int npp_improve_bounds(NPP *npp, NPPROW *row, int flag)
+{ /* improve current column bounds */
+ NPPCOL *col;
+ NPPAIJ *aij, *next_aij, *aaa;
+ int kase, ret, count = 0;
+ double lb, ub;
+ xassert(npp->sol == GLP_MIP);
+ /* row must not be free */
+ xassert(!(row->lb == -DBL_MAX && row->ub == +DBL_MAX));
+ /* determine implied column bounds */
+ npp_implied_bounds(npp, row);
+ /* and use these bounds to strengthen current column bounds */
+ for (aij = row->ptr; aij != NULL; aij = next_aij)
+ { col = aij->col;
+ next_aij = aij->r_next;
+ for (kase = 0; kase <= 1; kase++)
+ { /* save current column bounds */
+ lb = col->lb, ub = col->ub;
+ if (kase == 0)
+ { /* process implied column lower bound */
+ if (col->ll.ll == -DBL_MAX) continue;
+ ret = npp_implied_lower(npp, col, col->ll.ll);
+ }
+ else
+ { /* process implied column upper bound */
+ if (col->uu.uu == +DBL_MAX) continue;
+ ret = npp_implied_upper(npp, col, col->uu.uu);
+ }
+ if (ret == 0 || ret == 1)
+ { /* current column bounds did not change or changed, but
+ not significantly; restore current column bounds */
+ col->lb = lb, col->ub = ub;
+ }
+ else if (ret == 2 || ret == 3)
+ { /* current column bounds changed significantly or column
+ was fixed */
+#ifdef GLP_DEBUG
+ xprintf("L");
+#endif
+ count++;
+ /* activate other rows affected by column, if required */
+ if (flag)
+ { for (aaa = col->ptr; aaa != NULL; aaa = aaa->c_next)
+ { if (aaa->row != row)
+ npp_activate_row(npp, aaa->row);
+ }
+ }
+ if (ret == 3)
+ { /* process fixed column */
+#ifdef GLP_DEBUG
+ xprintf("M");
+#endif
+ npp_fixed_col(npp, col);
+ /* column was deleted */
+ break; /* for kase */
+ }
+ }
+ else if (ret == 4)
+ { /* primal/integer infeasibility */
+ return -1;
+ }
+ else
+ xassert(ret != ret);
+ }
+ }
+ return count;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_process_col - perform basic column processing
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_process_col(NPP *npp, NPPCOL *col);
+*
+* DESCRIPTION
+*
+* The routine npp_process_col performs basic column processing that
+* currently includes:
+*
+* 1) fixing and removing empty column;
+*
+* 2) removing column singleton, which is implied slack variable, and
+* corresponding row if it becomes free;
+*
+* 3) removing bounds of column, which is implied free variable, and
+* replacing corresponding row by equality constraint.
+*
+* Additionally the routine may activate affected rows and/or columns
+* for further processing.
+*
+* RETURNS
+*
+* 0 success;
+*
+* GLP_ENOPFS primal/integer infeasibility detected;
+*
+* GLP_ENODFS dual infeasibility detected. */
+
+int npp_process_col(NPP *npp, NPPCOL *col)
+{ /* perform basic column processing */
+ NPPROW *row;
+ NPPAIJ *aij;
+ int ret;
+ /* column must not be fixed */
+ xassert(col->lb < col->ub);
+ /* start processing column */
+ if (col->ptr == NULL)
+ { /* empty column */
+ ret = npp_empty_col(npp, col);
+ if (ret == 0)
+ { /* column was fixed and deleted */
+#ifdef GLP_DEBUG
+ xprintf("N");
+#endif
+ return 0;
+ }
+ else if (ret == 1)
+ { /* dual infeasibility */
+ return GLP_ENODFS;
+ }
+ else
+ xassert(ret != ret);
+ }
+ if (col->ptr->c_next == NULL)
+ { /* column singleton */
+ row = col->ptr->row;
+ if (row->lb == row->ub)
+ { /* equality constraint */
+ if (!col->is_int)
+slack: { /* implied slack variable */
+#ifdef GLP_DEBUG
+ xprintf("O");
+#endif
+ npp_implied_slack(npp, col);
+ /* column was deleted */
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ { /* row became free due to implied slack variable */
+#ifdef GLP_DEBUG
+ xprintf("P");
+#endif
+ /* activate columns affected by row */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_activate_col(npp, aij->col);
+ /* process free row */
+ npp_free_row(npp, row);
+ /* row was deleted */
+ }
+ else
+ { /* row became inequality constraint; activate it
+ since its length changed due to column deletion */
+ npp_activate_row(npp, row);
+ }
+ return 0;
+ }
+ }
+ else
+ { /* inequality constraint */
+ if (!col->is_int)
+ { ret = npp_implied_free(npp, col);
+ if (ret == 0)
+ { /* implied free variable */
+#ifdef GLP_DEBUG
+ xprintf("Q");
+#endif
+ /* column bounds were removed, row was replaced by
+ equality constraint */
+ goto slack;
+ }
+ else if (ret == 1)
+ { /* column is not implied free variable, because its
+ lower and/or upper bounds can be active */
+ }
+ else if (ret == 2)
+ { /* dual infeasibility */
+ return GLP_ENODFS;
+ }
+ }
+ }
+ }
+ /* column still exists */
+ return 0;
+}
+
+/***********************************************************************
+* NAME
+*
+* npp_process_prob - perform basic LP/MIP processing
+*
+* SYNOPSIS
+*
+* #include "glpnpp.h"
+* int npp_process_prob(NPP *npp, int hard);
+*
+* DESCRIPTION
+*
+* The routine npp_process_prob performs basic LP/MIP processing that
+* currently includes:
+*
+* 1) initial LP/MIP processing (see the routine npp_clean_prob),
+*
+* 2) basic row processing (see the routine npp_process_row), and
+*
+* 3) basic column processing (see the routine npp_process_col).
+*
+* If the flag hard is on, the routine attempts to improve current
+* column bounds multiple times within the main processing loop, in
+* which case this feature may take a time. Otherwise, if the flag hard
+* is off, improving column bounds is performed only once at the end of
+* the main loop. (Note that this feature is used for MIP only.)
+*
+* The routine uses two sets: the set of active rows and the set of
+* active columns. Rows/columns are marked by a flag (the field temp in
+* NPPROW/NPPCOL). If the flag is non-zero, the row/column is active,
+* in which case it is placed in the beginning of the row/column list;
+* otherwise, if the flag is zero, the row/column is inactive, in which
+* case it is placed in the end of the row/column list. If a row/column
+* being currently processed may affect other rows/columns, the latters
+* are activated for further processing.
+*
+* RETURNS
+*
+* 0 success;
+*
+* GLP_ENOPFS primal/integer infeasibility detected;
+*
+* GLP_ENODFS dual infeasibility detected. */
+
+int npp_process_prob(NPP *npp, int hard)
+{ /* perform basic LP/MIP processing */
+ NPPROW *row;
+ NPPCOL *col;
+ int processing, ret;
+ /* perform initial LP/MIP processing */
+ npp_clean_prob(npp);
+ /* activate all remaining rows and columns */
+ for (row = npp->r_head; row != NULL; row = row->next)
+ row->temp = 1;
+ for (col = npp->c_head; col != NULL; col = col->next)
+ col->temp = 1;
+ /* main processing loop */
+ processing = 1;
+ while (processing)
+ { processing = 0;
+ /* process all active rows */
+ for (;;)
+ { row = npp->r_head;
+ if (row == NULL || !row->temp) break;
+ npp_deactivate_row(npp, row);
+ ret = npp_process_row(npp, row, hard);
+ if (ret != 0) goto done;
+ processing = 1;
+ }
+ /* process all active columns */
+ for (;;)
+ { col = npp->c_head;
+ if (col == NULL || !col->temp) break;
+ npp_deactivate_col(npp, col);
+ ret = npp_process_col(npp, col);
+ if (ret != 0) goto done;
+ processing = 1;
+ }
+ }
+#if 1 /* 23/XII-2009 */
+ if (npp->sol == GLP_MIP && !hard)
+ { /* improve current column bounds (optional) */
+ for (row = npp->r_head; row != NULL; row = row->next)
+ { if (npp_improve_bounds(npp, row, 0) < 0)
+ { ret = GLP_ENOPFS;
+ goto done;
+ }
+ }
+ }
+#endif
+ /* all seems ok */
+ ret = 0;
+done: xassert(ret == 0 || ret == GLP_ENOPFS || ret == GLP_ENODFS);
+#ifdef GLP_DEBUG
+ xprintf("\n");
+#endif
+ return ret;
+}
+
+/**********************************************************************/
+
+int npp_simplex(NPP *npp, const glp_smcp *parm)
+{ /* process LP prior to applying primal/dual simplex method */
+ int ret;
+ xassert(npp->sol == GLP_SOL);
+ xassert(parm == parm);
+ ret = npp_process_prob(npp, 0);
+ return ret;
+}
+
+/**********************************************************************/
+
+int npp_integer(NPP *npp, const glp_iocp *parm)
+{ /* process MIP prior to applying branch-and-bound method */
+ NPPROW *row, *prev_row;
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int count, ret;
+ xassert(npp->sol == GLP_MIP);
+ xassert(parm == parm);
+ /*==============================================================*/
+ /* perform basic MIP processing */
+ ret = npp_process_prob(npp, 1);
+ if (ret != 0) goto done;
+ /*==============================================================*/
+ /* binarize problem, if required */
+ if (parm->binarize)
+ npp_binarize_prob(npp);
+ /*==============================================================*/
+ /* identify hidden packing inequalities */
+ count = 0;
+ /* new rows will be added to the end of the row list, so we go
+ from the end to beginning of the row list */
+ for (row = npp->r_tail; row != NULL; row = prev_row)
+ { prev_row = row->prev;
+ /* skip free row */
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX) continue;
+ /* skip equality constraint */
+ if (row->lb == row->ub) continue;
+ /* skip row having less than two variables */
+ if (row->ptr == NULL || row->ptr->r_next == NULL) continue;
+ /* skip row having non-binary variables */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ break;
+ }
+ if (aij != NULL) continue;
+ count += npp_hidden_packing(npp, row);
+ }
+ if (count > 0)
+ xprintf("%d hidden packing inequaliti(es) were detected\n",
+ count);
+ /*==============================================================*/
+ /* identify hidden covering inequalities */
+ count = 0;
+ /* new rows will be added to the end of the row list, so we go
+ from the end to beginning of the row list */
+ for (row = npp->r_tail; row != NULL; row = prev_row)
+ { prev_row = row->prev;
+ /* skip free row */
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX) continue;
+ /* skip equality constraint */
+ if (row->lb == row->ub) continue;
+ /* skip row having less than three variables */
+ if (row->ptr == NULL || row->ptr->r_next == NULL ||
+ row->ptr->r_next->r_next == NULL) continue;
+ /* skip row having non-binary variables */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ break;
+ }
+ if (aij != NULL) continue;
+ count += npp_hidden_covering(npp, row);
+ }
+ if (count > 0)
+ xprintf("%d hidden covering inequaliti(es) were detected\n",
+ count);
+ /*==============================================================*/
+ /* reduce inequality constraint coefficients */
+ count = 0;
+ /* new rows will be added to the end of the row list, so we go
+ from the end to beginning of the row list */
+ for (row = npp->r_tail; row != NULL; row = prev_row)
+ { prev_row = row->prev;
+ /* skip equality constraint */
+ if (row->lb == row->ub) continue;
+ count += npp_reduce_ineq_coef(npp, row);
+ }
+ if (count > 0)
+ xprintf("%d constraint coefficient(s) were reduced\n", count);
+ /*==============================================================*/
+#ifdef GLP_DEBUG
+ routine(npp);
+#endif
+ /*==============================================================*/
+ /* all seems ok */
+ ret = 0;
+done: return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/npp/npp6.c b/test/monniaux/glpk-4.65/src/npp/npp6.c
new file mode 100644
index 00000000..b57f8615
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/npp/npp6.c
@@ -0,0 +1,1500 @@
+/* npp6.c (translate feasibility problem to CNF-SAT) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2011-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "npp.h"
+
+/***********************************************************************
+* npp_sat_free_row - process free (unbounded) row
+*
+* This routine processes row p, which is free (i.e. has no finite
+* bounds):
+*
+* -inf < sum a[p,j] x[j] < +inf. (1)
+*
+* The constraint (1) cannot be active and therefore it is redundant,
+* so the routine simply removes it from the original problem. */
+
+void npp_sat_free_row(NPP *npp, NPPROW *p)
+{ /* the row should be free */
+ xassert(p->lb == -DBL_MAX && p->ub == +DBL_MAX);
+ /* remove the row from the problem */
+ npp_del_row(npp, p);
+ return;
+}
+
+/***********************************************************************
+* npp_sat_fixed_col - process fixed column
+*
+* This routine processes column q, which is fixed:
+*
+* x[q] = s[q], (1)
+*
+* where s[q] is a fixed column value.
+*
+* The routine substitutes fixed value s[q] into constraint rows and
+* then removes column x[q] from the original problem.
+*
+* Substitution of x[q] = s[q] into row i gives:
+*
+* L[i] <= sum a[i,j] x[j] <= U[i] ==>
+* j
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] x[q] <= U[i] ==>
+* j!=q
+*
+* L[i] <= sum a[i,j] x[j] + a[i,q] s[q] <= U[i] ==>
+* j!=q
+*
+* L~[i] <= sum a[i,j] x[j] <= U~[i],
+* j!=q
+*
+* where
+*
+* L~[i] = L[i] - a[i,q] s[q], (2)
+*
+* U~[i] = U[i] - a[i,q] s[q] (3)
+*
+* are, respectively, lower and upper bound of row i in the transformed
+* problem.
+*
+* On recovering solution x[q] is assigned the value of s[q]. */
+
+struct sat_fixed_col
+{ /* fixed column */
+ int q;
+ /* column reference number for variable x[q] */
+ int s;
+ /* value, at which x[q] is fixed */
+};
+
+static int rcv_sat_fixed_col(NPP *, void *);
+
+int npp_sat_fixed_col(NPP *npp, NPPCOL *q)
+{ struct sat_fixed_col *info;
+ NPPROW *i;
+ NPPAIJ *aij;
+ int temp;
+ /* the column should be fixed */
+ xassert(q->lb == q->ub);
+ /* create transformation stack entry */
+ info = npp_push_tse(npp,
+ rcv_sat_fixed_col, sizeof(struct sat_fixed_col));
+ info->q = q->j;
+ info->s = (int)q->lb;
+ xassert((double)info->s == q->lb);
+ /* substitute x[q] = s[q] into constraint rows */
+ if (info->s == 0)
+ goto skip;
+ for (aij = q->ptr; aij != NULL; aij = aij->c_next)
+ { i = aij->row;
+ if (i->lb != -DBL_MAX)
+ { i->lb -= aij->val * (double)info->s;
+ temp = (int)i->lb;
+ if ((double)temp != i->lb)
+ return 1; /* integer arithmetic error */
+ }
+ if (i->ub != +DBL_MAX)
+ { i->ub -= aij->val * (double)info->s;
+ temp = (int)i->ub;
+ if ((double)temp != i->ub)
+ return 2; /* integer arithmetic error */
+ }
+ }
+skip: /* remove the column from the problem */
+ npp_del_col(npp, q);
+ return 0;
+}
+
+static int rcv_sat_fixed_col(NPP *npp, void *info_)
+{ struct sat_fixed_col *info = info_;
+ npp->c_value[info->q] = (double)info->s;
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_is_bin_comb - test if row is binary combination
+*
+* This routine tests if the specified row is a binary combination,
+* i.e. all its constraint coefficients are +1 and -1 and all variables
+* are binary. If the test was passed, the routine returns non-zero,
+* otherwise zero. */
+
+int npp_sat_is_bin_comb(NPP *npp, NPPROW *row)
+{ NPPCOL *col;
+ NPPAIJ *aij;
+ xassert(npp == npp);
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { if (!(aij->val == +1.0 || aij->val == -1.0))
+ return 0; /* non-unity coefficient */
+ col = aij->col;
+ if (!(col->is_int && col->lb == 0.0 && col->ub == 1.0))
+ return 0; /* non-binary column */
+ }
+ return 1; /* test was passed */
+}
+
+/***********************************************************************
+* npp_sat_num_pos_coef - determine number of positive coefficients
+*
+* This routine returns the number of positive coefficients in the
+* specified row. */
+
+int npp_sat_num_pos_coef(NPP *npp, NPPROW *row)
+{ NPPAIJ *aij;
+ int num = 0;
+ xassert(npp == npp);
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->val > 0.0)
+ num++;
+ }
+ return num;
+}
+
+/***********************************************************************
+* npp_sat_num_neg_coef - determine number of negative coefficients
+*
+* This routine returns the number of negative coefficients in the
+* specified row. */
+
+int npp_sat_num_neg_coef(NPP *npp, NPPROW *row)
+{ NPPAIJ *aij;
+ int num = 0;
+ xassert(npp == npp);
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->val < 0.0)
+ num++;
+ }
+ return num;
+}
+
+/***********************************************************************
+* npp_sat_is_cover_ineq - test if row is covering inequality
+*
+* The canonical form of a covering inequality is the following:
+*
+* sum x[j] >= 1, (1)
+* j in J
+*
+* where all x[j] are binary variables.
+*
+* In general case a covering inequality may have one of the following
+* two forms:
+*
+* sum x[j] - sum x[j] >= 1 - |J-|, (2)
+* j in J+ j in J-
+*
+*
+* sum x[j] - sum x[j] <= |J+| - 1. (3)
+* j in J+ j in J-
+*
+* Obviously, the inequality (2) can be transformed to the form (1) by
+* substitution x[j] = 1 - x'[j] for all j in J-, where x'[j] is the
+* negation of variable x[j]. And the inequality (3) can be transformed
+* to (2) by multiplying both left- and right-hand sides by -1.
+*
+* This routine returns one of the following codes:
+*
+* 0, if the specified row is not a covering inequality;
+*
+* 1, if the specified row has the form (2);
+*
+* 2, if the specified row has the form (3). */
+
+int npp_sat_is_cover_ineq(NPP *npp, NPPROW *row)
+{ xassert(npp == npp);
+ if (row->lb != -DBL_MAX && row->ub == +DBL_MAX)
+ { /* row is inequality of '>=' type */
+ if (npp_sat_is_bin_comb(npp, row))
+ { /* row is a binary combination */
+ if (row->lb == 1.0 - npp_sat_num_neg_coef(npp, row))
+ { /* row has the form (2) */
+ return 1;
+ }
+ }
+ }
+ else if (row->lb == -DBL_MAX && row->ub != +DBL_MAX)
+ { /* row is inequality of '<=' type */
+ if (npp_sat_is_bin_comb(npp, row))
+ { /* row is a binary combination */
+ if (row->ub == npp_sat_num_pos_coef(npp, row) - 1.0)
+ { /* row has the form (3) */
+ return 2;
+ }
+ }
+ }
+ /* row is not a covering inequality */
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_is_pack_ineq - test if row is packing inequality
+*
+* The canonical form of a packing inequality is the following:
+*
+* sum x[j] <= 1, (1)
+* j in J
+*
+* where all x[j] are binary variables.
+*
+* In general case a packing inequality may have one of the following
+* two forms:
+*
+* sum x[j] - sum x[j] <= 1 - |J-|, (2)
+* j in J+ j in J-
+*
+*
+* sum x[j] - sum x[j] >= |J+| - 1. (3)
+* j in J+ j in J-
+*
+* Obviously, the inequality (2) can be transformed to the form (1) by
+* substitution x[j] = 1 - x'[j] for all j in J-, where x'[j] is the
+* negation of variable x[j]. And the inequality (3) can be transformed
+* to (2) by multiplying both left- and right-hand sides by -1.
+*
+* This routine returns one of the following codes:
+*
+* 0, if the specified row is not a packing inequality;
+*
+* 1, if the specified row has the form (2);
+*
+* 2, if the specified row has the form (3). */
+
+int npp_sat_is_pack_ineq(NPP *npp, NPPROW *row)
+{ xassert(npp == npp);
+ if (row->lb == -DBL_MAX && row->ub != +DBL_MAX)
+ { /* row is inequality of '<=' type */
+ if (npp_sat_is_bin_comb(npp, row))
+ { /* row is a binary combination */
+ if (row->ub == 1.0 - npp_sat_num_neg_coef(npp, row))
+ { /* row has the form (2) */
+ return 1;
+ }
+ }
+ }
+ else if (row->lb != -DBL_MAX && row->ub == +DBL_MAX)
+ { /* row is inequality of '>=' type */
+ if (npp_sat_is_bin_comb(npp, row))
+ { /* row is a binary combination */
+ if (row->lb == npp_sat_num_pos_coef(npp, row) - 1.0)
+ { /* row has the form (3) */
+ return 2;
+ }
+ }
+ }
+ /* row is not a packing inequality */
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_is_partn_eq - test if row is partitioning equality
+*
+* The canonical form of a partitioning equality is the following:
+*
+* sum x[j] = 1, (1)
+* j in J
+*
+* where all x[j] are binary variables.
+*
+* In general case a partitioning equality may have one of the following
+* two forms:
+*
+* sum x[j] - sum x[j] = 1 - |J-|, (2)
+* j in J+ j in J-
+*
+*
+* sum x[j] - sum x[j] = |J+| - 1. (3)
+* j in J+ j in J-
+*
+* Obviously, the equality (2) can be transformed to the form (1) by
+* substitution x[j] = 1 - x'[j] for all j in J-, where x'[j] is the
+* negation of variable x[j]. And the equality (3) can be transformed
+* to (2) by multiplying both left- and right-hand sides by -1.
+*
+* This routine returns one of the following codes:
+*
+* 0, if the specified row is not a partitioning equality;
+*
+* 1, if the specified row has the form (2);
+*
+* 2, if the specified row has the form (3). */
+
+int npp_sat_is_partn_eq(NPP *npp, NPPROW *row)
+{ xassert(npp == npp);
+ if (row->lb == row->ub)
+ { /* row is equality constraint */
+ if (npp_sat_is_bin_comb(npp, row))
+ { /* row is a binary combination */
+ if (row->lb == 1.0 - npp_sat_num_neg_coef(npp, row))
+ { /* row has the form (2) */
+ return 1;
+ }
+ if (row->ub == npp_sat_num_pos_coef(npp, row) - 1.0)
+ { /* row has the form (3) */
+ return 2;
+ }
+ }
+ }
+ /* row is not a partitioning equality */
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_reverse_row - multiply both sides of row by -1
+*
+* This routines multiplies by -1 both left- and right-hand sides of
+* the specified row:
+*
+* L <= sum x[j] <= U,
+*
+* that results in the following row:
+*
+* -U <= sum (-x[j]) <= -L.
+*
+* If no integer overflow occured, the routine returns zero, otherwise
+* non-zero. */
+
+int npp_sat_reverse_row(NPP *npp, NPPROW *row)
+{ NPPAIJ *aij;
+ int temp, ret = 0;
+ double old_lb, old_ub;
+ xassert(npp == npp);
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { aij->val = -aij->val;
+ temp = (int)aij->val;
+ if ((double)temp != aij->val)
+ ret = 1;
+ }
+ old_lb = row->lb, old_ub = row->ub;
+ if (old_ub == +DBL_MAX)
+ row->lb = -DBL_MAX;
+ else
+ { row->lb = -old_ub;
+ temp = (int)row->lb;
+ if ((double)temp != row->lb)
+ ret = 2;
+ }
+ if (old_lb == -DBL_MAX)
+ row->ub = +DBL_MAX;
+ else
+ { row->ub = -old_lb;
+ temp = (int)row->ub;
+ if ((double)temp != row->ub)
+ ret = 3;
+ }
+ return ret;
+}
+
+/***********************************************************************
+* npp_sat_split_pack - split packing inequality
+*
+* Let there be given a packing inequality in canonical form:
+*
+* sum t[j] <= 1, (1)
+* j in J
+*
+* where t[j] = x[j] or t[j] = 1 - x[j], x[j] is a binary variable.
+* And let J = J1 U J2 is a partition of the set of literals. Then the
+* inequality (1) is obviously equivalent to the following two packing
+* inequalities:
+*
+* sum t[j] <= y <--> sum t[j] + (1 - y) <= 1, (2)
+* j in J1 j in J1
+*
+* sum t[j] <= 1 - y <--> sum t[j] + y <= 1, (3)
+* j in J2 j in J2
+*
+* where y is a new binary variable added to the transformed problem.
+*
+* Assuming that the specified row is a packing inequality (1), this
+* routine constructs the set J1 by including there first nlit literals
+* (terms) from the specified row, and the set J2 = J \ J1. Then the
+* routine creates a new row, which corresponds to inequality (2), and
+* replaces the specified row with inequality (3). */
+
+NPPROW *npp_sat_split_pack(NPP *npp, NPPROW *row, int nlit)
+{ NPPROW *rrr;
+ NPPCOL *col;
+ NPPAIJ *aij;
+ int k;
+ /* original row should be packing inequality (1) */
+ xassert(npp_sat_is_pack_ineq(npp, row) == 1);
+ /* and nlit should be less than the number of literals (terms)
+ in the original row */
+ xassert(0 < nlit && nlit < npp_row_nnz(npp, row));
+ /* create new row corresponding to inequality (2) */
+ rrr = npp_add_row(npp);
+ rrr->lb = -DBL_MAX, rrr->ub = 1.0;
+ /* move first nlit literals (terms) from the original row to the
+ new row; the original row becomes inequality (3) */
+ for (k = 1; k <= nlit; k++)
+ { aij = row->ptr;
+ xassert(aij != NULL);
+ /* add literal to the new row */
+ npp_add_aij(npp, rrr, aij->col, aij->val);
+ /* correct rhs */
+ if (aij->val < 0.0)
+ rrr->ub -= 1.0, row->ub += 1.0;
+ /* remove literal from the original row */
+ npp_del_aij(npp, aij);
+ }
+ /* create new binary variable y */
+ col = npp_add_col(npp);
+ col->is_int = 1, col->lb = 0.0, col->ub = 1.0;
+ /* include literal (1 - y) in the new row */
+ npp_add_aij(npp, rrr, col, -1.0);
+ rrr->ub -= 1.0;
+ /* include literal y in the original row */
+ npp_add_aij(npp, row, col, +1.0);
+ return rrr;
+}
+
+/***********************************************************************
+* npp_sat_encode_pack - encode packing inequality
+*
+* Given a packing inequality in canonical form:
+*
+* sum t[j] <= 1, (1)
+* j in J
+*
+* where t[j] = x[j] or t[j] = 1 - x[j], x[j] is a binary variable,
+* this routine translates it to CNF by replacing it with the following
+* equivalent set of edge packing inequalities:
+*
+* t[j] + t[k] <= 1 for all j, k in J, j != k. (2)
+*
+* Then the routine transforms each edge packing inequality (2) to
+* corresponding covering inequality (that encodes two-literal clause)
+* by multiplying both its part by -1:
+*
+* - t[j] - t[k] >= -1 <--> (1 - t[j]) + (1 - t[k]) >= 1. (3)
+*
+* On exit the routine removes the original row from the problem. */
+
+void npp_sat_encode_pack(NPP *npp, NPPROW *row)
+{ NPPROW *rrr;
+ NPPAIJ *aij, *aik;
+ /* original row should be packing inequality (1) */
+ xassert(npp_sat_is_pack_ineq(npp, row) == 1);
+ /* create equivalent system of covering inequalities (3) */
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { /* due to symmetry only one of inequalities t[j] + t[k] <= 1
+ and t[k] <= t[j] <= 1 can be considered */
+ for (aik = aij->r_next; aik != NULL; aik = aik->r_next)
+ { /* create edge packing inequality (2) */
+ rrr = npp_add_row(npp);
+ rrr->lb = -DBL_MAX, rrr->ub = 1.0;
+ npp_add_aij(npp, rrr, aij->col, aij->val);
+ if (aij->val < 0.0)
+ rrr->ub -= 1.0;
+ npp_add_aij(npp, rrr, aik->col, aik->val);
+ if (aik->val < 0.0)
+ rrr->ub -= 1.0;
+ /* and transform it to covering inequality (3) */
+ npp_sat_reverse_row(npp, rrr);
+ xassert(npp_sat_is_cover_ineq(npp, rrr) == 1);
+ }
+ }
+ /* remove the original row from the problem */
+ npp_del_row(npp, row);
+ return;
+}
+
+/***********************************************************************
+* npp_sat_encode_sum2 - encode 2-bit summation
+*
+* Given a set containing two literals x and y this routine encodes
+* the equality
+*
+* x + y = s + 2 * c, (1)
+*
+* where
+*
+* s = (x + y) % 2 (2)
+*
+* is a binary variable modeling the low sum bit, and
+*
+* c = (x + y) / 2 (3)
+*
+* is a binary variable modeling the high (carry) sum bit. */
+
+void npp_sat_encode_sum2(NPP *npp, NPPLSE *set, NPPSED *sed)
+{ NPPROW *row;
+ int x, y, s, c;
+ /* the set should contain exactly two literals */
+ xassert(set != NULL);
+ xassert(set->next != NULL);
+ xassert(set->next->next == NULL);
+ sed->x = set->lit;
+ xassert(sed->x.neg == 0 || sed->x.neg == 1);
+ sed->y = set->next->lit;
+ xassert(sed->y.neg == 0 || sed->y.neg == 1);
+ sed->z.col = NULL, sed->z.neg = 0;
+ /* perform encoding s = (x + y) % 2 */
+ sed->s = npp_add_col(npp);
+ sed->s->is_int = 1, sed->s->lb = 0.0, sed->s->ub = 1.0;
+ for (x = 0; x <= 1; x++)
+ { for (y = 0; y <= 1; y++)
+ { for (s = 0; s <= 1; s++)
+ { if ((x + y) % 2 != s)
+ { /* generate CNF clause to disable infeasible
+ combination */
+ row = npp_add_row(npp);
+ row->lb = 1.0, row->ub = +DBL_MAX;
+ if (x == sed->x.neg)
+ npp_add_aij(npp, row, sed->x.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->x.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (y == sed->y.neg)
+ npp_add_aij(npp, row, sed->y.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->y.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (s == 0)
+ npp_add_aij(npp, row, sed->s, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->s, -1.0);
+ row->lb -= 1.0;
+ }
+ }
+ }
+ }
+ }
+ /* perform encoding c = (x + y) / 2 */
+ sed->c = npp_add_col(npp);
+ sed->c->is_int = 1, sed->c->lb = 0.0, sed->c->ub = 1.0;
+ for (x = 0; x <= 1; x++)
+ { for (y = 0; y <= 1; y++)
+ { for (c = 0; c <= 1; c++)
+ { if ((x + y) / 2 != c)
+ { /* generate CNF clause to disable infeasible
+ combination */
+ row = npp_add_row(npp);
+ row->lb = 1.0, row->ub = +DBL_MAX;
+ if (x == sed->x.neg)
+ npp_add_aij(npp, row, sed->x.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->x.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (y == sed->y.neg)
+ npp_add_aij(npp, row, sed->y.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->y.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (c == 0)
+ npp_add_aij(npp, row, sed->c, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->c, -1.0);
+ row->lb -= 1.0;
+ }
+ }
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* npp_sat_encode_sum3 - encode 3-bit summation
+*
+* Given a set containing at least three literals this routine chooses
+* some literals x, y, z from that set and encodes the equality
+*
+* x + y + z = s + 2 * c, (1)
+*
+* where
+*
+* s = (x + y + z) % 2 (2)
+*
+* is a binary variable modeling the low sum bit, and
+*
+* c = (x + y + z) / 2 (3)
+*
+* is a binary variable modeling the high (carry) sum bit. */
+
+void npp_sat_encode_sum3(NPP *npp, NPPLSE *set, NPPSED *sed)
+{ NPPROW *row;
+ int x, y, z, s, c;
+ /* the set should contain at least three literals */
+ xassert(set != NULL);
+ xassert(set->next != NULL);
+ xassert(set->next->next != NULL);
+ sed->x = set->lit;
+ xassert(sed->x.neg == 0 || sed->x.neg == 1);
+ sed->y = set->next->lit;
+ xassert(sed->y.neg == 0 || sed->y.neg == 1);
+ sed->z = set->next->next->lit;
+ xassert(sed->z.neg == 0 || sed->z.neg == 1);
+ /* perform encoding s = (x + y + z) % 2 */
+ sed->s = npp_add_col(npp);
+ sed->s->is_int = 1, sed->s->lb = 0.0, sed->s->ub = 1.0;
+ for (x = 0; x <= 1; x++)
+ { for (y = 0; y <= 1; y++)
+ { for (z = 0; z <= 1; z++)
+ { for (s = 0; s <= 1; s++)
+ { if ((x + y + z) % 2 != s)
+ { /* generate CNF clause to disable infeasible
+ combination */
+ row = npp_add_row(npp);
+ row->lb = 1.0, row->ub = +DBL_MAX;
+ if (x == sed->x.neg)
+ npp_add_aij(npp, row, sed->x.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->x.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (y == sed->y.neg)
+ npp_add_aij(npp, row, sed->y.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->y.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (z == sed->z.neg)
+ npp_add_aij(npp, row, sed->z.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->z.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (s == 0)
+ npp_add_aij(npp, row, sed->s, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->s, -1.0);
+ row->lb -= 1.0;
+ }
+ }
+ }
+ }
+ }
+ }
+ /* perform encoding c = (x + y + z) / 2 */
+ sed->c = npp_add_col(npp);
+ sed->c->is_int = 1, sed->c->lb = 0.0, sed->c->ub = 1.0;
+ for (x = 0; x <= 1; x++)
+ { for (y = 0; y <= 1; y++)
+ { for (z = 0; z <= 1; z++)
+ { for (c = 0; c <= 1; c++)
+ { if ((x + y + z) / 2 != c)
+ { /* generate CNF clause to disable infeasible
+ combination */
+ row = npp_add_row(npp);
+ row->lb = 1.0, row->ub = +DBL_MAX;
+ if (x == sed->x.neg)
+ npp_add_aij(npp, row, sed->x.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->x.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (y == sed->y.neg)
+ npp_add_aij(npp, row, sed->y.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->y.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (z == sed->z.neg)
+ npp_add_aij(npp, row, sed->z.col, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->z.col, -1.0);
+ row->lb -= 1.0;
+ }
+ if (c == 0)
+ npp_add_aij(npp, row, sed->c, +1.0);
+ else
+ { npp_add_aij(npp, row, sed->c, -1.0);
+ row->lb -= 1.0;
+ }
+ }
+ }
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* npp_sat_encode_sum_ax - encode linear combination of 0-1 variables
+*
+* PURPOSE
+*
+* Given a linear combination of binary variables:
+*
+* sum a[j] x[j], (1)
+* j
+*
+* which is the linear form of the specified row, this routine encodes
+* (i.e. translates to CNF) the following equality:
+*
+* n
+* sum |a[j]| t[j] = sum 2**(k-1) * y[k], (2)
+* j k=1
+*
+* where t[j] = x[j] (if a[j] > 0) or t[j] = 1 - x[j] (if a[j] < 0),
+* and y[k] is either t[j] or a new literal created by the routine or
+* a constant zero. Note that the sum in the right-hand side of (2) can
+* be thought as a n-bit representation of the sum in the left-hand
+* side, which is a non-negative integer number.
+*
+* ALGORITHM
+*
+* First, the number of bits, n, sufficient to represent any value in
+* the left-hand side of (2) is determined. Obviously, n is the number
+* of bits sufficient to represent the sum (sum |a[j]|).
+*
+* Let
+*
+* n
+* |a[j]| = sum 2**(k-1) b[j,k], (3)
+* k=1
+*
+* where b[j,k] is k-th bit in a n-bit representation of |a[j]|. Then
+*
+* m n
+* sum |a[j]| * t[j] = sum 2**(k-1) sum b[j,k] * t[j]. (4)
+* j k=1 j=1
+*
+* Introducing the set
+*
+* J[k] = { j : b[j,k] = 1 } (5)
+*
+* allows rewriting (4) as follows:
+*
+* n
+* sum |a[j]| * t[j] = sum 2**(k-1) sum t[j]. (6)
+* j k=1 j in J[k]
+*
+* Thus, our goal is to provide |J[k]| <= 1 for all k, in which case
+* we will have the representation (1).
+*
+* Let |J[k]| = 2, i.e. J[k] has exactly two literals u and v. In this
+* case we can apply the following transformation:
+*
+* u + v = s + 2 * c, (7)
+*
+* where s and c are, respectively, low (sum) and high (carry) bits of
+* the sum of two bits. This allows to replace two literals u and v in
+* J[k] by one literal s, and carry out literal c to J[k+1].
+*
+* If |J[k]| >= 3, i.e. J[k] has at least three literals u, v, and w,
+* we can apply the following transformation:
+*
+* u + v + w = s + 2 * c. (8)
+*
+* Again, literal s replaces literals u, v, and w in J[k], and literal
+* c goes into J[k+1].
+*
+* On exit the routine stores each literal from J[k] in element y[k],
+* 1 <= k <= n. If J[k] is empty, y[k] is set to constant false.
+*
+* RETURNS
+*
+* The routine returns n, the number of literals in the right-hand side
+* of (2), 0 <= n <= NBIT_MAX. If the sum (sum |a[j]|) is too large, so
+* more than NBIT_MAX (= 31) literals are needed to encode the original
+* linear combination, the routine returns a negative value. */
+
+#define NBIT_MAX 31
+/* maximal number of literals in the right hand-side of (2) */
+
+static NPPLSE *remove_lse(NPP *npp, NPPLSE *set, NPPCOL *col)
+{ /* remove specified literal from specified literal set */
+ NPPLSE *lse, *prev = NULL;
+ for (lse = set; lse != NULL; prev = lse, lse = lse->next)
+ if (lse->lit.col == col) break;
+ xassert(lse != NULL);
+ if (prev == NULL)
+ set = lse->next;
+ else
+ prev->next = lse->next;
+ dmp_free_atom(npp->pool, lse, sizeof(NPPLSE));
+ return set;
+}
+
+int npp_sat_encode_sum_ax(NPP *npp, NPPROW *row, NPPLIT y[])
+{ NPPAIJ *aij;
+ NPPLSE *set[1+NBIT_MAX], *lse;
+ NPPSED sed;
+ int k, n, temp;
+ double sum;
+ /* compute the sum (sum |a[j]|) */
+ sum = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ sum += fabs(aij->val);
+ /* determine n, the number of bits in the sum */
+ temp = (int)sum;
+ if ((double)temp != sum)
+ return -1; /* integer arithmetic error */
+ for (n = 0; temp > 0; n++, temp >>= 1);
+ xassert(0 <= n && n <= NBIT_MAX);
+ /* build initial sets J[k], 1 <= k <= n; see (5) */
+ /* set[k] is a pointer to the list of literals in J[k] */
+ for (k = 1; k <= n; k++)
+ set[k] = NULL;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { temp = (int)fabs(aij->val);
+ xassert((int)temp == fabs(aij->val));
+ for (k = 1; temp > 0; k++, temp >>= 1)
+ { if (temp & 1)
+ { xassert(k <= n);
+ lse = dmp_get_atom(npp->pool, sizeof(NPPLSE));
+ lse->lit.col = aij->col;
+ lse->lit.neg = (aij->val > 0.0 ? 0 : 1);
+ lse->next = set[k];
+ set[k] = lse;
+ }
+ }
+ }
+ /* main transformation loop */
+ for (k = 1; k <= n; k++)
+ { /* reduce J[k] and set y[k] */
+ for (;;)
+ { if (set[k] == NULL)
+ { /* J[k] is empty */
+ /* set y[k] to constant false */
+ y[k].col = NULL, y[k].neg = 0;
+ break;
+ }
+ if (set[k]->next == NULL)
+ { /* J[k] contains one literal */
+ /* set y[k] to that literal */
+ y[k] = set[k]->lit;
+ dmp_free_atom(npp->pool, set[k], sizeof(NPPLSE));
+ break;
+ }
+ if (set[k]->next->next == NULL)
+ { /* J[k] contains two literals */
+ /* apply transformation (7) */
+ npp_sat_encode_sum2(npp, set[k], &sed);
+ }
+ else
+ { /* J[k] contains at least three literals */
+ /* apply transformation (8) */
+ npp_sat_encode_sum3(npp, set[k], &sed);
+ /* remove third literal from set[k] */
+ set[k] = remove_lse(npp, set[k], sed.z.col);
+ }
+ /* remove second literal from set[k] */
+ set[k] = remove_lse(npp, set[k], sed.y.col);
+ /* remove first literal from set[k] */
+ set[k] = remove_lse(npp, set[k], sed.x.col);
+ /* include new literal s to set[k] */
+ lse = dmp_get_atom(npp->pool, sizeof(NPPLSE));
+ lse->lit.col = sed.s, lse->lit.neg = 0;
+ lse->next = set[k];
+ set[k] = lse;
+ /* include new literal c to set[k+1] */
+ xassert(k < n); /* FIXME: can "overflow" happen? */
+ lse = dmp_get_atom(npp->pool, sizeof(NPPLSE));
+ lse->lit.col = sed.c, lse->lit.neg = 0;
+ lse->next = set[k+1];
+ set[k+1] = lse;
+ }
+ }
+ return n;
+}
+
+/***********************************************************************
+* npp_sat_normalize_clause - normalize clause
+*
+* This routine normalizes the specified clause, which is a disjunction
+* of literals, by replacing multiple literals, which refer to the same
+* binary variable, with a single literal.
+*
+* On exit the routine returns the number of literals in the resulting
+* clause. However, if the specified clause includes both a literal and
+* its negation, the routine returns a negative value meaning that the
+* clause is equivalent to the value true. */
+
+int npp_sat_normalize_clause(NPP *npp, int size, NPPLIT lit[])
+{ int j, k, new_size;
+ xassert(npp == npp);
+ xassert(size >= 0);
+ new_size = 0;
+ for (k = 1; k <= size; k++)
+ { for (j = 1; j <= new_size; j++)
+ { if (lit[k].col == lit[j].col)
+ { /* lit[k] refers to the same variable as lit[j], which
+ is already included in the resulting clause */
+ if (lit[k].neg == lit[j].neg)
+ { /* ignore lit[k] due to the idempotent law */
+ goto skip;
+ }
+ else
+ { /* lit[k] is NOT lit[j]; the clause is equivalent to
+ the value true */
+ return -1;
+ }
+ }
+ }
+ /* include lit[k] in the resulting clause */
+ lit[++new_size] = lit[k];
+skip: ;
+ }
+ return new_size;
+}
+
+/***********************************************************************
+* npp_sat_encode_clause - translate clause to cover inequality
+*
+* Given a clause
+*
+* OR t[j], (1)
+* j in J
+*
+* where t[j] is a literal, i.e. t[j] = x[j] or t[j] = NOT x[j], this
+* routine translates it to the following equivalent cover inequality,
+* which is added to the transformed problem:
+*
+* sum t[j] >= 1, (2)
+* j in J
+*
+* where t[j] = x[j] or t[j] = 1 - x[j].
+*
+* If necessary, the clause should be normalized before a call to this
+* routine. */
+
+NPPROW *npp_sat_encode_clause(NPP *npp, int size, NPPLIT lit[])
+{ NPPROW *row;
+ int k;
+ xassert(size >= 1);
+ row = npp_add_row(npp);
+ row->lb = 1.0, row->ub = +DBL_MAX;
+ for (k = 1; k <= size; k++)
+ { xassert(lit[k].col != NULL);
+ if (lit[k].neg == 0)
+ npp_add_aij(npp, row, lit[k].col, +1.0);
+ else if (lit[k].neg == 1)
+ { npp_add_aij(npp, row, lit[k].col, -1.0);
+ row->lb -= 1.0;
+ }
+ else
+ xassert(lit != lit);
+ }
+ return row;
+}
+
+/***********************************************************************
+* npp_sat_encode_geq - encode "not less than" constraint
+*
+* PURPOSE
+*
+* This routine translates to CNF the following constraint:
+*
+* n
+* sum 2**(k-1) * y[k] >= b, (1)
+* k=1
+*
+* where y[k] is either a literal (i.e. y[k] = x[k] or y[k] = 1 - x[k])
+* or constant false (zero), b is a given lower bound.
+*
+* ALGORITHM
+*
+* If b < 0, the constraint is redundant, so assume that b >= 0. Let
+*
+* n
+* b = sum 2**(k-1) b[k], (2)
+* k=1
+*
+* where b[k] is k-th binary digit of b. (Note that if b >= 2**n and
+* therefore cannot be represented in the form (2), the constraint (1)
+* is infeasible.) In this case the condition (1) is equivalent to the
+* following condition:
+*
+* y[n] y[n-1] ... y[2] y[1] >= b[n] b[n-1] ... b[2] b[1], (3)
+*
+* where ">=" is understood lexicographically.
+*
+* Algorithmically the condition (3) can be tested as follows:
+*
+* for (k = n; k >= 1; k--)
+* { if (y[k] < b[k])
+* y is less than b;
+* if (y[k] > b[k])
+* y is greater than b;
+* }
+* y is equal to b;
+*
+* Thus, y is less than b iff there exists k, 1 <= k <= n, for which
+* the following condition is satisfied:
+*
+* y[n] = b[n] AND ... AND y[k+1] = b[k+1] AND y[k] < b[k]. (4)
+*
+* Negating the condition (4) we have that y is not less than b iff for
+* all k, 1 <= k <= n, the following condition is satisfied:
+*
+* y[n] != b[n] OR ... OR y[k+1] != b[k+1] OR y[k] >= b[k]. (5)
+*
+* Note that if b[k] = 0, the literal y[k] >= b[k] is always true, in
+* which case the entire clause (5) is true and can be omitted.
+*
+* RETURNS
+*
+* Normally the routine returns zero. However, if the constraint (1) is
+* infeasible, the routine returns non-zero. */
+
+int npp_sat_encode_geq(NPP *npp, int n, NPPLIT y[], int rhs)
+{ NPPLIT lit[1+NBIT_MAX];
+ int j, k, size, temp, b[1+NBIT_MAX];
+ xassert(0 <= n && n <= NBIT_MAX);
+ /* if the constraint (1) is redundant, do nothing */
+ if (rhs < 0)
+ return 0;
+ /* determine binary digits of b according to (2) */
+ for (k = 1, temp = rhs; k <= n; k++, temp >>= 1)
+ b[k] = temp & 1;
+ if (temp != 0)
+ { /* b >= 2**n; the constraint (1) is infeasible */
+ return 1;
+ }
+ /* main transformation loop */
+ for (k = 1; k <= n; k++)
+ { /* build the clause (5) for current k */
+ size = 0; /* clause size = number of literals */
+ /* add literal y[k] >= b[k] */
+ if (b[k] == 0)
+ { /* b[k] = 0 -> the literal is true */
+ goto skip;
+ }
+ else if (y[k].col == NULL)
+ { /* y[k] = 0, b[k] = 1 -> the literal is false */
+ xassert(y[k].neg == 0);
+ }
+ else
+ { /* add literal y[k] = 1 */
+ lit[++size] = y[k];
+ }
+ for (j = k+1; j <= n; j++)
+ { /* add literal y[j] != b[j] */
+ if (y[j].col == NULL)
+ { xassert(y[j].neg == 0);
+ if (b[j] == 0)
+ { /* y[j] = 0, b[j] = 0 -> the literal is false */
+ continue;
+ }
+ else
+ { /* y[j] = 0, b[j] = 1 -> the literal is true */
+ goto skip;
+ }
+ }
+ else
+ { lit[++size] = y[j];
+ if (b[j] != 0)
+ lit[size].neg = 1 - lit[size].neg;
+ }
+ }
+ /* normalize the clause */
+ size = npp_sat_normalize_clause(npp, size, lit);
+ if (size < 0)
+ { /* the clause is equivalent to the value true */
+ goto skip;
+ }
+ if (size == 0)
+ { /* the clause is equivalent to the value false; this means
+ that the constraint (1) is infeasible */
+ return 2;
+ }
+ /* translate the clause to corresponding cover inequality */
+ npp_sat_encode_clause(npp, size, lit);
+skip: ;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_encode_leq - encode "not greater than" constraint
+*
+* PURPOSE
+*
+* This routine translates to CNF the following constraint:
+*
+* n
+* sum 2**(k-1) * y[k] <= b, (1)
+* k=1
+*
+* where y[k] is either a literal (i.e. y[k] = x[k] or y[k] = 1 - x[k])
+* or constant false (zero), b is a given upper bound.
+*
+* ALGORITHM
+*
+* If b < 0, the constraint is infeasible, so assume that b >= 0. Let
+*
+* n
+* b = sum 2**(k-1) b[k], (2)
+* k=1
+*
+* where b[k] is k-th binary digit of b. (Note that if b >= 2**n and
+* therefore cannot be represented in the form (2), the constraint (1)
+* is redundant.) In this case the condition (1) is equivalent to the
+* following condition:
+*
+* y[n] y[n-1] ... y[2] y[1] <= b[n] b[n-1] ... b[2] b[1], (3)
+*
+* where "<=" is understood lexicographically.
+*
+* Algorithmically the condition (3) can be tested as follows:
+*
+* for (k = n; k >= 1; k--)
+* { if (y[k] < b[k])
+* y is less than b;
+* if (y[k] > b[k])
+* y is greater than b;
+* }
+* y is equal to b;
+*
+* Thus, y is greater than b iff there exists k, 1 <= k <= n, for which
+* the following condition is satisfied:
+*
+* y[n] = b[n] AND ... AND y[k+1] = b[k+1] AND y[k] > b[k]. (4)
+*
+* Negating the condition (4) we have that y is not greater than b iff
+* for all k, 1 <= k <= n, the following condition is satisfied:
+*
+* y[n] != b[n] OR ... OR y[k+1] != b[k+1] OR y[k] <= b[k]. (5)
+*
+* Note that if b[k] = 1, the literal y[k] <= b[k] is always true, in
+* which case the entire clause (5) is true and can be omitted.
+*
+* RETURNS
+*
+* Normally the routine returns zero. However, if the constraint (1) is
+* infeasible, the routine returns non-zero. */
+
+int npp_sat_encode_leq(NPP *npp, int n, NPPLIT y[], int rhs)
+{ NPPLIT lit[1+NBIT_MAX];
+ int j, k, size, temp, b[1+NBIT_MAX];
+ xassert(0 <= n && n <= NBIT_MAX);
+ /* check if the constraint (1) is infeasible */
+ if (rhs < 0)
+ return 1;
+ /* determine binary digits of b according to (2) */
+ for (k = 1, temp = rhs; k <= n; k++, temp >>= 1)
+ b[k] = temp & 1;
+ if (temp != 0)
+ { /* b >= 2**n; the constraint (1) is redundant */
+ return 0;
+ }
+ /* main transformation loop */
+ for (k = 1; k <= n; k++)
+ { /* build the clause (5) for current k */
+ size = 0; /* clause size = number of literals */
+ /* add literal y[k] <= b[k] */
+ if (b[k] == 1)
+ { /* b[k] = 1 -> the literal is true */
+ goto skip;
+ }
+ else if (y[k].col == NULL)
+ { /* y[k] = 0, b[k] = 0 -> the literal is true */
+ xassert(y[k].neg == 0);
+ goto skip;
+ }
+ else
+ { /* add literal y[k] = 0 */
+ lit[++size] = y[k];
+ lit[size].neg = 1 - lit[size].neg;
+ }
+ for (j = k+1; j <= n; j++)
+ { /* add literal y[j] != b[j] */
+ if (y[j].col == NULL)
+ { xassert(y[j].neg == 0);
+ if (b[j] == 0)
+ { /* y[j] = 0, b[j] = 0 -> the literal is false */
+ continue;
+ }
+ else
+ { /* y[j] = 0, b[j] = 1 -> the literal is true */
+ goto skip;
+ }
+ }
+ else
+ { lit[++size] = y[j];
+ if (b[j] != 0)
+ lit[size].neg = 1 - lit[size].neg;
+ }
+ }
+ /* normalize the clause */
+ size = npp_sat_normalize_clause(npp, size, lit);
+ if (size < 0)
+ { /* the clause is equivalent to the value true */
+ goto skip;
+ }
+ if (size == 0)
+ { /* the clause is equivalent to the value false; this means
+ that the constraint (1) is infeasible */
+ return 2;
+ }
+ /* translate the clause to corresponding cover inequality */
+ npp_sat_encode_clause(npp, size, lit);
+skip: ;
+ }
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_encode_row - encode constraint (row) of general type
+*
+* PURPOSE
+*
+* This routine translates to CNF the following constraint (row):
+*
+* L <= sum a[j] x[j] <= U, (1)
+* j
+*
+* where all x[j] are binary variables.
+*
+* ALGORITHM
+*
+* First, the routine performs substitution x[j] = t[j] for j in J+
+* and x[j] = 1 - t[j] for j in J-, where J+ = { j : a[j] > 0 } and
+* J- = { j : a[j] < 0 }. This gives:
+*
+* L <= sum a[j] t[j] + sum a[j] (1 - t[j]) <= U ==>
+* j in J+ j in J-
+*
+* L' <= sum |a[j]| t[j] <= U', (2)
+* j
+*
+* where
+*
+* L' = L - sum a[j], U' = U - sum a[j]. (3)
+* j in J- j in J-
+*
+* (Actually only new bounds L' and U' are computed.)
+*
+* Then the routine translates to CNF the following equality:
+*
+* n
+* sum |a[j]| t[j] = sum 2**(k-1) * y[k], (4)
+* j k=1
+*
+* where y[k] is either some t[j] or a new literal or a constant zero
+* (see the routine npp_sat_encode_sum_ax).
+*
+* Finally, the routine translates to CNF the following conditions:
+*
+* n
+* sum 2**(k-1) * y[k] >= L' (5)
+* k=1
+*
+* and
+*
+* n
+* sum 2**(k-1) * y[k] <= U' (6)
+* k=1
+*
+* (see the routines npp_sat_encode_geq and npp_sat_encode_leq).
+*
+* All resulting clauses are encoded as cover inequalities and included
+* into the transformed problem.
+*
+* Note that on exit the routine removes the specified constraint (row)
+* from the original problem.
+*
+* RETURNS
+*
+* The routine returns one of the following codes:
+*
+* 0 - translation was successful;
+* 1 - constraint (1) was found infeasible;
+* 2 - integer arithmetic error occured. */
+
+int npp_sat_encode_row(NPP *npp, NPPROW *row)
+{ NPPAIJ *aij;
+ NPPLIT y[1+NBIT_MAX];
+ int n, rhs;
+ double lb, ub;
+ /* the row should not be free */
+ xassert(!(row->lb == -DBL_MAX && row->ub == +DBL_MAX));
+ /* compute new bounds L' and U' (3) */
+ lb = row->lb;
+ ub = row->ub;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ { if (aij->val < 0.0)
+ { if (lb != -DBL_MAX)
+ lb -= aij->val;
+ if (ub != -DBL_MAX)
+ ub -= aij->val;
+ }
+ }
+ /* encode the equality (4) */
+ n = npp_sat_encode_sum_ax(npp, row, y);
+ if (n < 0)
+ return 2; /* integer arithmetic error */
+ /* encode the condition (5) */
+ if (lb != -DBL_MAX)
+ { rhs = (int)lb;
+ if ((double)rhs != lb)
+ return 2; /* integer arithmetic error */
+ if (npp_sat_encode_geq(npp, n, y, rhs) != 0)
+ return 1; /* original constraint is infeasible */
+ }
+ /* encode the condition (6) */
+ if (ub != +DBL_MAX)
+ { rhs = (int)ub;
+ if ((double)rhs != ub)
+ return 2; /* integer arithmetic error */
+ if (npp_sat_encode_leq(npp, n, y, rhs) != 0)
+ return 1; /* original constraint is infeasible */
+ }
+ /* remove the specified row from the problem */
+ npp_del_row(npp, row);
+ return 0;
+}
+
+/***********************************************************************
+* npp_sat_encode_prob - encode 0-1 feasibility problem
+*
+* This routine translates the specified 0-1 feasibility problem to an
+* equivalent SAT-CNF problem.
+*
+* N.B. Currently this is a very crude implementation.
+*
+* RETURNS
+*
+* 0 success;
+*
+* GLP_ENOPFS primal/integer infeasibility detected;
+*
+* GLP_ERANGE integer overflow occured. */
+
+int npp_sat_encode_prob(NPP *npp)
+{ NPPROW *row, *next_row, *prev_row;
+ NPPCOL *col, *next_col;
+ int cover = 0, pack = 0, partn = 0, ret;
+ /* process and remove free rows */
+ for (row = npp->r_head; row != NULL; row = next_row)
+ { next_row = row->next;
+ if (row->lb == -DBL_MAX && row->ub == +DBL_MAX)
+ npp_sat_free_row(npp, row);
+ }
+ /* process and remove fixed columns */
+ for (col = npp->c_head; col != NULL; col = next_col)
+ { next_col = col->next;
+ if (col->lb == col->ub)
+ xassert(npp_sat_fixed_col(npp, col) == 0);
+ }
+ /* only binary variables should remain */
+ for (col = npp->c_head; col != NULL; col = col->next)
+ xassert(col->is_int && col->lb == 0.0 && col->ub == 1.0);
+ /* new rows may be added to the end of the row list, so we walk
+ from the end to beginning of the list */
+ for (row = npp->r_tail; row != NULL; row = prev_row)
+ { prev_row = row->prev;
+ /* process special cases */
+ ret = npp_sat_is_cover_ineq(npp, row);
+ if (ret != 0)
+ { /* row is covering inequality */
+ cover++;
+ /* since it already encodes a clause, just transform it to
+ canonical form */
+ if (ret == 2)
+ { xassert(npp_sat_reverse_row(npp, row) == 0);
+ ret = npp_sat_is_cover_ineq(npp, row);
+ }
+ xassert(ret == 1);
+ continue;
+ }
+ ret = npp_sat_is_partn_eq(npp, row);
+ if (ret != 0)
+ { /* row is partitioning equality */
+ NPPROW *cov;
+ NPPAIJ *aij;
+ partn++;
+ /* transform it to canonical form */
+ if (ret == 2)
+ { xassert(npp_sat_reverse_row(npp, row) == 0);
+ ret = npp_sat_is_partn_eq(npp, row);
+ }
+ xassert(ret == 1);
+ /* and split it into covering and packing inequalities,
+ both in canonical forms */
+ cov = npp_add_row(npp);
+ cov->lb = row->lb, cov->ub = +DBL_MAX;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ npp_add_aij(npp, cov, aij->col, aij->val);
+ xassert(npp_sat_is_cover_ineq(npp, cov) == 1);
+ /* the cover inequality already encodes a clause and do
+ not need any further processing */
+ row->lb = -DBL_MAX;
+ xassert(npp_sat_is_pack_ineq(npp, row) == 1);
+ /* the packing inequality will be processed below */
+ pack--;
+ }
+ ret = npp_sat_is_pack_ineq(npp, row);
+ if (ret != 0)
+ { /* row is packing inequality */
+ NPPROW *rrr;
+ int nlit, desired_nlit = 4;
+ pack++;
+ /* transform it to canonical form */
+ if (ret == 2)
+ { xassert(npp_sat_reverse_row(npp, row) == 0);
+ ret = npp_sat_is_pack_ineq(npp, row);
+ }
+ xassert(ret == 1);
+ /* process the packing inequality */
+ for (;;)
+ { /* determine the number of literals in the remaining
+ inequality */
+ nlit = npp_row_nnz(npp, row);
+ if (nlit <= desired_nlit)
+ break;
+ /* split the current inequality into one having not more
+ than desired_nlit literals and remaining one */
+ rrr = npp_sat_split_pack(npp, row, desired_nlit-1);
+ /* translate the former inequality to CNF and remove it
+ from the original problem */
+ npp_sat_encode_pack(npp, rrr);
+ }
+ /* translate the remaining inequality to CNF and remove it
+ from the original problem */
+ npp_sat_encode_pack(npp, row);
+ continue;
+ }
+ /* translate row of general type to CNF and remove it from the
+ original problem */
+ ret = npp_sat_encode_row(npp, row);
+ if (ret == 0)
+ ;
+ else if (ret == 1)
+ ret = GLP_ENOPFS;
+ else if (ret == 2)
+ ret = GLP_ERANGE;
+ else
+ xassert(ret != ret);
+ if (ret != 0)
+ goto done;
+ }
+ ret = 0;
+ if (cover != 0)
+ xprintf("%d covering inequalities\n", cover);
+ if (pack != 0)
+ xprintf("%d packing inequalities\n", pack);
+ if (partn != 0)
+ xprintf("%d partitioning equalities\n", partn);
+done: return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/proxy/main.c.disabled b/test/monniaux/glpk-4.65/src/proxy/main.c.disabled
new file mode 100644
index 00000000..a7d1e2b8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/proxy/main.c.disabled
@@ -0,0 +1,87 @@
+/* Last update: 08-May-2013 */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include "glpk.h"
+#include "proxy.h"
+
+/**********************************************************************/
+int main(int argc, char **argv)
+/**********************************************************************/
+{
+ glp_prob *lp;
+ int ncols, status;
+ double *initsol, zstar, *xstar;
+
+ /* check arguments */
+ if ( (argc == 1) || (argc > 3) ) {
+ printf("ERROR: Usage: ts <instance> <(possibly) xml initsols>\n"
+ );
+ exit(1);
+ }
+
+ /* creating the problem */
+ lp = glp_create_prob();
+ glp_set_prob_name(lp, "Proxy");
+
+ /* reading the problem */
+ glp_term_out(GLP_OFF);
+#if 0 /* by mao */
+ status = glp_read_lp(lp, NULL, argv[1]);
+#else
+ status = glp_read_mps(lp, GLP_MPS_FILE, NULL, argv[1]);
+#endif
+ glp_term_out(GLP_ON);
+ if ( status ) {
+ printf("Problem %s does not exist!!!, status %d\n",
+ argv[1], status);
+ exit(1);
+ }
+
+ ncols = glp_get_num_cols(lp);
+
+ initsol = (double *) calloc(ncols+1, sizeof(double));
+
+ if (argc == 3) {
+ FILE *fp=fopen(argv[2],"r");
+ char tmp[256]={0x0};
+ int counter = 1;
+ while(fp!=NULL && fgets(tmp, sizeof(tmp),fp)!=NULL)
+ {
+ char *valini = strstr(tmp, "value");
+ if (valini!=NULL){
+ int num;
+ double dnum;
+ valini +=7;
+ sscanf(valini, "%d%*s",&num);
+ dnum = (double)num;
+ initsol[counter] = dnum;
+ counter++;
+ }
+ }
+ fclose(fp);
+ }
+
+ xstar = (double *) calloc(ncols+1, sizeof(double));
+
+ if (argc == 3) {
+ status = proxy(lp, &zstar, xstar, initsol, 0.0, 0, 1);
+ }
+ else {
+ status = proxy(lp, &zstar, xstar, NULL, 0.0, 0, 1);
+ }
+
+ printf("Status = %d; ZSTAR = %f\n",status,zstar);
+ /*
+ int i;
+ for (i=1; i< ncols+1; i++) {
+ printf("XSTAR[%d] = %f\n",i, xstar[i]);
+ }
+ */
+
+ glp_delete_prob(lp);
+
+ return 0;
+}
diff --git a/test/monniaux/glpk-4.65/src/proxy/proxy.c b/test/monniaux/glpk-4.65/src/proxy/proxy.c
new file mode 100644
index 00000000..7d890003
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/proxy/proxy.c
@@ -0,0 +1,1073 @@
+/* proxy.c (proximity search heuristic algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Author: Giorgio Sartor <0gioker0@gmail.com>.
+*
+* Copyright (C) 2013, 2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+*
+************************************************************************
+*
+* THIS CODE IS AN IMPLEMENTATION OF THE ALGORITHM PROPOSED IN
+*
+* M. Fischetti, M. Monaci,
+* "Proximity Search for 0-1 Mixed-Integer Convex Programming"
+* Technical Report DEI, University of Padua, March 2013.
+*
+* AVAILABLE AT
+* http://www.dei.unipd.it/~fisch/papers/proximity_search.pdf
+*
+* THE CODE HAS BEEN WRITTEN BY GIORGIO SARTOR, " 0gioker0@gmail.com "
+*
+* BASIC IDEA:
+*
+* The initial feasible solution x_tilde is defined. This initial
+* solution can be found by an ad-hoc heuristic and proxy can be used to
+* refine it by exploiting an underlying MIP model whose solution from
+* scratch turned out to be problematic. Otherwise, x_tilde can be found
+* by running the GLPK mip solver until a first feasible solution is
+* found, setting a conservative time limit of 10 minutes (by default).
+* Time limit can be modified passing variable tlim [ms].
+*
+* Then the cutoff tolerance "delta" is defined. The default tolerance
+* is 1% of the last feasible solution obj value--rounded to integer if
+* all the variables and obj coefficients are integer.
+*
+* Next, the objective function c' x is replaced by the Hamming distance
+* between x (the actual obj coefficients) and x_tilde (the given
+* solution). Distance is only computed wrt the binary variables.
+*
+* The GLPK solver is then invoked to hopefully find a new incumbent
+* x_star with cost c' x_star <= c' x_tilde - delta. A crucial property
+* here is that the root-node solution of the LP relaxation is expected
+* to be not too different from x_tilde, as this latter solution would
+* be optimal without the cutoff constraint, that for a small delta can
+* typically be fulfilled with just local adjustments.
+*
+* If no new solution x_star is found within the time limit the
+* algorithm stops. Of course, if the MIP solver proved infeasibility
+* for the given delta, we have that c' x_tilde - delta is a valid lower
+* bound (in case of minimazation) on the optimal value of the original
+* MIP.
+*
+* The new solution x_star, if any, is possibly improved by solving a
+* simplified problem (refinement) where all binary variables have been
+* fixed to their value in x_star so as to find the best solution within
+* the neighborhood.
+*
+* Finally, the approach is reapplied on x_star (that replaces x_tilde)
+* so as to recenter the distance Hamming function and by modifying the
+* cutoff tolerance delta.
+*
+* In this way, there will be a series of hopefully not-too-difficult
+* sub-MIPs to solve, each leading to an improvement of the incumbent.
+* More aggressive policies on the definition of tolerance delta can
+* lead to a better performance, but would require an ad-hoc tuning.
+*
+************************************************************************
+*
+* int proxy(glp_prob *lp, double *zstar, double *xstar,
+* const double[] initsol, double rel_impr, int tlim,
+* int verbose)
+*
+* lp : GLPK problem pointer to a MIP with binary variables
+*
+* zstar : the value of objective function of the best solution found
+*
+* xstar : best solution with components xstar[1],...,xstar[ncols]
+*
+* initsol : pointer to a initial feasible solution, see
+* glp_ios_heur_sol
+* If initsol = NULL, the procedure finds the first solution
+* by itself.
+*
+* rel_impr : minimum relative obj improvement to be achieved at each
+* internal step; if <= 0.0 a default value of 0.01 (1%) is
+* used; for some problems (e.g., set covering with small
+* integer costs) a more-conservative choice of 0.001 (0.1%)
+* can lead to a better final solution; values larger than
+* 0.05 (5%) are typically too aggressive and do not work
+* well.
+*
+* tlim : time limit to find a new solution, in ms.
+* If tlim = 0, it is set to its default value, 600000 ms
+*
+* verbose : if 1 the output is activated. If 0 only errors are
+* displayed
+*
+* The procedure returns -1 if an error occurred, 0 otherwise (possibly,
+* time limit)
+*
+***********************************************************************/
+
+/**********************************************************************/
+/* 1. INCLUDE */
+/**********************************************************************/
+
+#include "glpk.h"
+#include "env.h"
+#include "proxy.h"
+
+/**********************************************************************/
+/* 2. PARAMETERS AND CONSTANTS */
+/**********************************************************************/
+
+#define TDAY 86400.0
+#define TRUE 1
+#define FALSE 0
+#define EPS 1e-6
+#define RINF 1e38
+#define MAXVAL 1e20
+#define MINVAL -1e20
+#if 0 /* by gioker */
+ #define PROXY_DEBUG
+#endif
+
+/**********************************************************************/
+/* 3. GLOBAL VARIABLES */
+/**********************************************************************/
+
+struct csa {
+
+int integer_obj; /* TRUE if each feasible solution has an
+ integral cost */
+int b_vars_exist; /* TRUE if there is at least one binary
+ variable in the problem */
+int i_vars_exist; /* TRUE if there is at least one general
+ integer variable in the problem */
+const double *startsol; /* Pointer to the initial solution */
+
+int *ckind; /* Store the kind of the structural variables
+ of the problem */
+double *clb; /* Store the lower bound on the structural
+ variables of the problem */
+double *cub; /* Store the upper bound on the structural
+ variables of the problem */
+double *true_obj; /* Store the obj coefficients of the problem */
+
+int dir; /* Minimization or maximization problem */
+int ncols; /* Number of structural variables of the
+ problem */
+
+time_t GLOtstart; /* starting time of the algorithm */
+
+glp_prob *lp_ref; /* glp problem for refining only*/
+
+};
+
+/**********************************************************************/
+/* 4. FUNCTIONS PROTOTYPES */
+/**********************************************************************/
+
+static void callback(glp_tree *tree, void *info);
+static void get_info(struct csa *csa, glp_prob *lp);
+static int is_integer(struct csa *csa);
+static void check_integrality(struct csa *csa);
+static int check_ref(struct csa *csa, glp_prob *lp, double *xref);
+static double second(void);
+static int add_cutoff(struct csa *csa, glp_prob *lp);
+static void get_sol(struct csa *csa, glp_prob *lp, double *xstar);
+static double elapsed_time(struct csa *csa);
+static void redefine_obj(glp_prob *lp, double *xtilde, int ncols,
+ int *ckind, double *clb, double *cub);
+static double update_cutoff(struct csa *csa, glp_prob *lp,
+ double zstar, int index, double rel_impr);
+static double compute_delta(struct csa *csa, double z,
+ double rel_impr);
+static double objval(int ncols, double *x, double *true_obj);
+static void array_copy(int begin, int end, double *source,
+ double *destination);
+static int do_refine(struct csa *csa, glp_prob *lp_ref, int ncols,
+ int *ckind, double *xref, int *tlim, int tref_lim,
+ int verbose);
+static void deallocate(struct csa *csa, int refine);
+
+/**********************************************************************/
+/* 5. FUNCTIONS */
+/**********************************************************************/
+
+int proxy(glp_prob *lp, double *zfinal, double *xfinal,
+ const double initsol[], double rel_impr, int tlim,
+ int verbose)
+
+{ struct csa csa_, *csa = &csa_;
+ glp_iocp parm;
+ glp_smcp parm_lp;
+ size_t tpeak;
+ int refine, tref_lim, err, cutoff_row, niter, status, i, tout;
+ double *xref, *xstar, zstar, tela, cutoff, zz;
+
+ memset(csa, 0, sizeof(struct csa));
+
+
+ /********** **********/
+ /********** RETRIEVING PROBLEM INFO **********/
+ /********** **********/
+
+ /* getting problem direction (min or max) */
+ csa->dir = glp_get_obj_dir(lp);
+
+ /* getting number of variables */
+ csa->ncols = glp_get_num_cols(lp);
+
+ /* getting kind, bounds and obj coefficient of each variable
+ information is stored in ckind, cub, clb, true_obj */
+ get_info(csa, lp);
+
+ /* checking if the objective function is always integral */
+ check_integrality(csa);
+
+ /* Proximity search cannot be used if there are no binary
+ variables */
+ if (csa->b_vars_exist == FALSE) {
+ if (verbose) {
+ xprintf("The problem has not binary variables. Proximity se"
+ "arch cannot be used.\n");
+ }
+ tfree(csa->ckind);
+ tfree(csa->clb);
+ tfree(csa->cub);
+ tfree(csa->true_obj);
+ return -1;
+ }
+
+ /* checking if the problem needs refinement, i.e., not all
+ variables are binary. If so, the routine creates a copy of the
+ lp problem named lp_ref and initializes the solution xref to
+ zero. */
+ xref = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(xref, 0, sizeof(double)*(csa->ncols+1));
+#endif
+ refine = check_ref(csa, lp, xref);
+#ifdef PROXY_DEBUG
+ xprintf("REFINE = %d\n",refine);
+#endif
+
+ /* Initializing the solution */
+ xstar = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(xstar, 0, sizeof(double)*(csa->ncols+1));
+#endif
+
+ /********** **********/
+ /********** FINDING FIRST SOLUTION **********/
+ /********** **********/
+
+ if (verbose) {
+ xprintf("Applying PROXY heuristic...\n");
+ }
+
+ /* get the initial time */
+ csa->GLOtstart = second();
+
+ /* setting the optimization parameters */
+ glp_init_iocp(&parm);
+ glp_init_smcp(&parm_lp);
+#if 0 /* by gioker */
+ /* Preprocessing should be disabled because the mip passed
+ to proxy is already preprocessed */
+ parm.presolve = GLP_ON;
+#endif
+#if 1 /* by mao */
+ /* best projection backtracking seems to be more efficient to find
+ any integer feasible solution */
+ parm.bt_tech = GLP_BT_BPH;
+#endif
+
+ /* Setting the default value of the minimum relative improvement
+ to 1% */
+ if ( rel_impr <= 0.0 ) {
+ rel_impr = 0.01;
+ }
+
+ /* Setting the default value of time limit to 10 minutes */
+ if (tlim <= 0) {
+ tlim = INT_MAX;
+ }
+ if (verbose) {
+ xprintf("Proxy's time limit set to %d seconds.\n",tlim/1000);
+ xprintf("Proxy's relative improvement "
+ "set to %2.2lf %c.\n",rel_impr*100,37);
+ }
+
+ parm_lp.tm_lim = tlim;
+
+ parm.mip_gap = 9999999.9; /* to stop the optimization at the first
+ feasible solution found */
+
+ /* finding the first solution */
+ if (verbose) {
+ xprintf("Searching for a feasible solution...\n");
+ }
+
+ /* verifying the existence of an input starting solution */
+ if (initsol != NULL) {
+ csa->startsol = initsol;
+ parm.cb_func = callback;
+ parm.cb_info = csa;
+ if (verbose) {
+ xprintf("Input solution found.\n");
+ }
+ }
+
+ tout = glp_term_out(GLP_OFF);
+ err = glp_simplex(lp,&parm_lp);
+ glp_term_out(tout);
+
+ status = glp_get_status(lp);
+
+ if (status != GLP_OPT) {
+ if (verbose) {
+ xprintf("Proxy heuristic terminated.\n");
+ }
+#ifdef PROXY_DEBUG
+ /* For debug only */
+ xprintf("GLP_SIMPLEX status = %d\n",status);
+ xprintf("GLP_SIMPLEX error code = %d\n",err);
+#endif
+ tfree(xref);
+ tfree(xstar);
+ deallocate(csa, refine);
+ return -1;
+ }
+
+ tela = elapsed_time(csa);
+ if (tlim-tela*1000 <= 0) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy could not "
+ "find optimal solution to LP relaxation.\n");
+ xprintf("Proxy heuristic aborted.\n");
+ }
+ tfree(xref);
+ tfree(xstar);
+ deallocate(csa, refine);
+ return -1;
+ }
+
+ parm.tm_lim = tlim - tela*1000;
+ tref_lim = (tlim - tela *1000) / 20;
+
+ tout = glp_term_out(GLP_OFF);
+ err = glp_intopt(lp, &parm);
+ glp_term_out(tout);
+
+ status = glp_mip_status(lp);
+
+ /***** If no solution was found *****/
+
+ if (status == GLP_NOFEAS || status == GLP_UNDEF) {
+ if (err == GLP_ETMLIM) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy could not "
+ "find an initial integer feasible solution.\n");
+ xprintf("Proxy heuristic aborted.\n");
+ }
+ }
+ else {
+ if (verbose) {
+ xprintf("Proxy could not "
+ "find an initial integer feasible solution.\n");
+ xprintf("Proxy heuristic aborted.\n");
+ }
+ }
+ tfree(xref);
+ tfree(xstar);
+ deallocate(csa, refine);
+ return -1;
+ }
+
+ /* getting the first solution and its value */
+ get_sol(csa, lp,xstar);
+ zstar = glp_mip_obj_val(lp);
+
+ if (verbose) {
+ xprintf(">>>>> first solution = %e;\n", zstar);
+ }
+
+ /* If a feasible solution was found but the time limit is
+ exceeded */
+ if (err == GLP_ETMLIM) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy heuristic terminated.\n");
+ }
+ goto done;
+ }
+
+ tela = elapsed_time(csa);
+ tpeak = 0;
+ glp_mem_usage(NULL, NULL, NULL, &tpeak);
+ if (verbose) {
+ xprintf("Time used: %3.1lf secs. Memory used: %2.1lf Mb\n",
+ tela,(double)tpeak/1048576);
+ xprintf("Starting proximity search...\n");
+ }
+
+ /********** **********/
+ /********** PREPARING THE PROBLEM FOR PROXY **********/
+ /********** **********/
+
+ /* adding a dummy cutoff constraint */
+ cutoff_row = add_cutoff(csa, lp);
+
+ /* proximity search needs minimization direction
+ even if the problem is a maximization one */
+ if (csa->dir == GLP_MAX) {
+ glp_set_obj_dir(lp, GLP_MIN);
+ }
+
+ /********** **********/
+ /********** STARTING PROXIMITY SEARCH **********/
+ /********** **********/
+
+
+ niter = 0;
+
+ while (TRUE) {
+ niter++;
+
+ /********** CHANGING THE OBJ FUNCTION **********/
+
+ redefine_obj(lp,xstar, csa->ncols, csa->ckind, csa->clb,
+ csa->cub);
+
+ /********** UPDATING THE CUTOFF CONSTRAINT **********/
+
+ cutoff = update_cutoff(csa, lp,zstar, cutoff_row, rel_impr);
+
+#ifdef PROXY_DEBUG
+ xprintf("TRUE_OBJ[0] = %f\n",csa->true_obj[0]);
+ xprintf("ZSTAR = %f\n",zstar);
+ xprintf("CUTOFF = %f\n",cutoff);
+#endif
+
+ /********** SEARCHING FOR A BETTER SOLUTION **********/
+
+ tela = elapsed_time(csa);
+ if (tlim-tela*1000 <= 0) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy heuristic "
+ "terminated.\n");
+ }
+ goto done;
+ }
+#ifdef PROXY_DEBUG
+ xprintf("TELA = %3.1lf\n",tela*1000);
+ xprintf("TLIM = %3.1lf\n",tlim - tela*1000);
+#endif
+ parm_lp.tm_lim = tlim -tela*1000;
+
+ tout = glp_term_out(GLP_OFF);
+ err = glp_simplex(lp,&parm_lp);
+ glp_term_out(tout);
+
+ status = glp_get_status(lp);
+
+ if (status != GLP_OPT) {
+ if (status == GLP_NOFEAS) {
+ if (verbose) {
+ xprintf("Bound exceeded = %f. ",cutoff);
+ }
+ }
+ if (verbose) {
+ xprintf("Proxy heuristic terminated.\n");
+ }
+#ifdef PROXY_DEBUG
+ xprintf("GLP_SIMPLEX status = %d\n",status);
+ xprintf("GLP_SIMPLEX error code = %d\n",err);
+#endif
+ goto done;
+ }
+
+ tela = elapsed_time(csa);
+ if (tlim-tela*1000 <= 0) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy heuristic "
+ "terminated.\n");
+ }
+ goto done;
+ }
+ parm.tm_lim = tlim - tela*1000;
+ parm.cb_func = NULL;
+#if 0 /* by gioker */
+ /* Preprocessing should be disabled because the mip passed
+ to proxy is already preprocessed */
+ parm.presolve = GLP_ON;
+#endif
+ tout = glp_term_out(GLP_OFF);
+ err = glp_intopt(lp, &parm);
+ glp_term_out(tout);
+
+ /********** MANAGEMENT OF THE SOLUTION **********/
+
+ status = glp_mip_status(lp);
+
+ /***** No feasible solutions *****/
+
+ if (status == GLP_NOFEAS) {
+ if (verbose) {
+ xprintf("Bound exceeded = %f. Proxy heuristic "
+ "terminated.\n",cutoff);
+ }
+ goto done;
+ }
+
+ /***** Undefined solution *****/
+
+ if (status == GLP_UNDEF) {
+ if (err == GLP_ETMLIM) {
+ if (verbose) {
+ xprintf("Time limit exceeded. Proxy heuristic "
+ "terminated.\n");
+ }
+ }
+ else {
+ if (verbose) {
+ xprintf("Proxy terminated unexpectedly.\n");
+#ifdef PROXY_DEBUG
+ xprintf("GLP_INTOPT error code = %d\n",err);
+#endif
+ }
+ }
+ goto done;
+ }
+
+ /***** Feasible solution *****/
+
+ if ((status == GLP_FEAS) || (status == GLP_OPT)) {
+
+ /* getting the solution and computing its value */
+ get_sol(csa, lp,xstar);
+ zz = objval(csa->ncols, xstar, csa->true_obj);
+
+ /* Comparing the incumbent solution with the current best
+ one */
+#ifdef PROXY_DEBUG
+ xprintf("ZZ = %f\n",zz);
+ xprintf("ZSTAR = %f\n",zstar);
+ xprintf("REFINE = %d\n",refine);
+#endif
+ if (((zz<zstar) && (csa->dir == GLP_MIN)) ||
+ ((zz>zstar) && (csa->dir == GLP_MAX))) {
+
+ /* refining (possibly) the solution */
+ if (refine) {
+
+ /* copying the incumbent solution in the refinement
+ one */
+ array_copy(1, csa->ncols +1, xstar, xref);
+ err = do_refine(csa, csa->lp_ref, csa->ncols,
+ csa->ckind, xref, &tlim, tref_lim, verbose);
+ if (!err) {
+ double zref = objval(csa->ncols, xref,
+ csa->true_obj);
+ if (((zref<zz) && (csa->dir == GLP_MIN)) ||
+ ((zref>zz) && (csa->dir == GLP_MAX))) {
+ zz = zref;
+ /* copying the refinement solution in the
+ incumbent one */
+ array_copy(1, csa->ncols +1, xref, xstar);
+ }
+ }
+ }
+ zstar = zz;
+ tela = elapsed_time(csa);
+ if (verbose) {
+ xprintf(">>>>> it: %3d: mip = %e; elapsed time "
+ "%3.1lf sec.s\n", niter,zstar,tela);
+ }
+ }
+ }
+ }
+
+done:
+ tela = elapsed_time(csa);
+ glp_mem_usage(NULL, NULL, NULL, &tpeak);
+ if (verbose) {
+ xprintf("Time used: %3.1lf. Memory used: %2.1lf Mb\n",
+ tela,(double)tpeak/1048576);
+ }
+
+
+ /* Exporting solution and obj val */
+ *zfinal = zstar;
+
+ for (i=1; i < (csa->ncols + 1); i++) {
+ xfinal[i]=xstar[i];
+ }
+
+ /* Freeing allocated memory */
+ tfree(xref);
+ tfree(xstar);
+ deallocate(csa, refine);
+
+ return 0;
+}
+
+/**********************************************************************/
+static void callback(glp_tree *tree, void *info){
+/**********************************************************************/
+ struct csa *csa = info;
+ switch(glp_ios_reason(tree)) {
+ case GLP_IHEUR:
+ glp_ios_heur_sol(tree, csa->startsol);
+ break;
+ default: break;
+ }
+}
+
+/**********************************************************************/
+static void get_info(struct csa *csa, glp_prob *lp)
+/**********************************************************************/
+{
+ int i;
+
+ /* Storing helpful info of the problem */
+
+ csa->ckind = talloc(csa->ncols+1, int);
+#if 0 /* by mao */
+ memset(csa->ckind, 0, sizeof(int)*(csa->ncols+1));
+#endif
+ csa->clb = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(csa->clb, 0, sizeof(double)*(csa->ncols+1));
+#endif
+ csa->cub = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(csa->cub, 0, sizeof(double)*(csa->ncols+1));
+#endif
+ csa->true_obj = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(csa->true_obj, 0, sizeof(double)*(csa->ncols+1));
+#endif
+ for( i = 1 ; i < (csa->ncols + 1); i++ ) {
+ csa->ckind[i] = glp_get_col_kind(lp, i);
+ csa->clb[i] = glp_get_col_lb(lp, i);
+ csa->cub[i] = glp_get_col_ub(lp, i);
+ csa->true_obj[i] = glp_get_obj_coef(lp, i);
+ }
+ csa->true_obj[0] = glp_get_obj_coef(lp, 0);
+}
+
+/**********************************************************************/
+static int is_integer(struct csa *csa)
+/**********************************************************************/
+{
+ int i;
+ csa->integer_obj = TRUE;
+ for ( i = 1; i < (csa->ncols + 1); i++ ) {
+ if (fabs(csa->true_obj[i]) > INT_MAX ) {
+ csa->integer_obj = FALSE;
+ }
+ if (fabs(csa->true_obj[i]) <= INT_MAX) {
+ double tmp, rem;
+ if (fabs(csa->true_obj[i]) - floor(fabs(csa->true_obj[i]))
+ < 0.5) {
+ tmp = floor(fabs(csa->true_obj[i]));
+ }
+ else {
+ tmp = ceil(fabs(csa->true_obj[i]));
+ }
+ rem = fabs(csa->true_obj[i]) - tmp;
+ rem = fabs(rem);
+ if (rem > EPS) {
+ csa->integer_obj = FALSE;
+ }
+
+ }
+ }
+ return csa->integer_obj;
+}
+
+/**********************************************************************/
+static void check_integrality(struct csa *csa)
+/**********************************************************************/
+{
+ /*
+ Checking if the problem has binary, integer or continuos variables.
+ integer_obj is TRUE if the problem has no continuous variables
+ and all the obj coefficients are integer (and < INT_MAX).
+ */
+
+ int i;
+ csa->integer_obj = is_integer(csa);
+ csa->b_vars_exist = FALSE;
+ csa->i_vars_exist = FALSE;
+ for ( i = 1; i < (csa->ncols + 1); i++ ) {
+ if ( csa->ckind[i] == GLP_IV ){
+ csa->i_vars_exist = TRUE;
+ continue;
+ }
+ if ( csa->ckind[i] == GLP_BV ){
+ csa->b_vars_exist =TRUE;
+ continue;
+ }
+ csa->integer_obj = FALSE;
+ }
+}
+
+/**********************************************************************/
+static int check_ref(struct csa *csa, glp_prob *lp, double *xref)
+/**********************************************************************/
+{
+ /*
+ checking if the problem has continuos or integer variables. If so,
+ refinement is prepared.
+ */
+ int refine = FALSE;
+ int i;
+ for ( i = 1; i < (csa->ncols + 1); i++ ) {
+ if ( csa->ckind[i] != GLP_BV) {
+ refine = TRUE;
+ break;
+ }
+ }
+
+ /* possibly creating a mip clone for refinement only */
+ if ( refine ) {
+ csa->lp_ref = glp_create_prob();
+ glp_copy_prob(csa->lp_ref, lp, GLP_ON);
+ }
+
+ return refine;
+}
+
+/**********************************************************************/
+static double second(void)
+/**********************************************************************/
+{
+#if 0 /* by mao */
+ return ((double)clock()/(double)CLOCKS_PER_SEC);
+#else
+ return xtime() / 1000.0;
+#endif
+}
+
+/**********************************************************************/
+static int add_cutoff(struct csa *csa, glp_prob *lp)
+/**********************************************************************/
+{
+ /*
+ Adding a cutoff constraint to set an upper bound (in case of
+ minimaztion) on the obj value of the next solution, i.e., the next
+ value of the true obj function that we would like to find
+ */
+
+ /* store non-zero coefficients in the objective function */
+ int *obj_index = talloc(csa->ncols+1, int);
+#if 0 /* by mao */
+ memset(obj_index, 0, sizeof(int)*(csa->ncols+1));
+#endif
+ double *obj_value = talloc(csa->ncols+1, double);
+#if 0 /* by mao */
+ memset(obj_value, 0, sizeof(double)*(csa->ncols+1));
+#endif
+ int obj_nzcnt = 0;
+ int i, irow;
+ const char *rowname;
+ for ( i = 1; i < (csa->ncols + 1); i++ ) {
+ if ( fabs(csa->true_obj[i]) > EPS ) {
+ obj_nzcnt++;
+ obj_index[obj_nzcnt] = i;
+ obj_value[obj_nzcnt] = csa->true_obj[i];
+ }
+ }
+
+ irow = glp_add_rows(lp, 1);
+ rowname = "Cutoff";
+ glp_set_row_name(lp, irow, rowname);
+ if (csa->dir == GLP_MIN) {
+ /* minimization problem */
+ glp_set_row_bnds(lp, irow, GLP_UP, MAXVAL, MAXVAL);
+ }
+ else {
+ /* maximization problem */
+ glp_set_row_bnds(lp, irow, GLP_LO, MINVAL, MINVAL);
+ }
+
+ glp_set_mat_row(lp, irow, obj_nzcnt, obj_index, obj_value);
+
+ tfree(obj_index);
+ tfree(obj_value);
+
+ return irow;
+}
+
+/**********************************************************************/
+static void get_sol(struct csa *csa, glp_prob *lp, double *xstar)
+/**********************************************************************/
+{
+ /* Retrieving and storing the coefficients of the solution */
+
+ int i;
+ for (i = 1; i < (csa->ncols +1); i++) {
+ xstar[i] = glp_mip_col_val(lp, i);
+ }
+}
+
+/**********************************************************************/
+static double elapsed_time(struct csa *csa)
+/**********************************************************************/
+{
+ double tela = second() - csa->GLOtstart;
+ if ( tela < 0 ) tela += TDAY;
+ return(tela);
+}
+
+/**********************************************************************/
+static void redefine_obj(glp_prob *lp, double *xtilde, int ncols,
+ int *ckind, double *clb, double *cub)
+/**********************************************************************/
+
+/*
+ Redefine the lp objective function obj as the distance-to-integrality
+ (Hamming distance) from xtilde (the incumbent feasible solution), wrt
+ to binary vars only
+ */
+
+{
+ int j;
+ double *delta = talloc(ncols+1, double);
+#if 0 /* by mao */
+ memset(delta, 0, sizeof(double)*(ncols+1));
+#endif
+
+ for ( j = 1; j < (ncols +1); j++ ) {
+ delta[j] = 0.0;
+ /* skip continuous variables */
+ if ( ckind[j] == GLP_CV ) continue;
+
+ /* skip integer variables that have been fixed */
+ if ( cub[j]-clb[j] < 0.5 ) continue;
+
+ /* binary variable */
+ if ( ckind[j] == GLP_BV ) {
+ if ( xtilde[j] > 0.5 ) {
+ delta[j] = -1.0;
+ }
+ else {
+ delta[j] = 1.0;
+ }
+ }
+ }
+
+ /* changing the obj coeff. for all variables, including continuous
+ ones */
+ for ( j = 1; j < (ncols +1); j++ ) {
+ glp_set_obj_coef(lp, j, delta[j]);
+ }
+ glp_set_obj_coef(lp, 0, 0.0);
+
+ tfree(delta);
+}
+
+/**********************************************************************/
+static double update_cutoff(struct csa *csa, glp_prob *lp,
+ double zstar, int cutoff_row,
+ double rel_impr)
+/**********************************************************************/
+{
+ /*
+ Updating the cutoff constraint with the value we would like to
+ find during the next optimization
+ */
+ double cutoff;
+ zstar -= csa->true_obj[0];
+ if (csa->dir == GLP_MIN) {
+ cutoff = zstar - compute_delta(csa, zstar, rel_impr);
+ glp_set_row_bnds(lp, cutoff_row, GLP_UP, cutoff, cutoff);
+ }
+ else {
+ cutoff = zstar + compute_delta(csa, zstar, rel_impr);
+ glp_set_row_bnds(lp, cutoff_row, GLP_LO, cutoff, cutoff);
+ }
+
+ return cutoff;
+}
+
+/**********************************************************************/
+static double compute_delta(struct csa *csa, double z, double rel_impr)
+/**********************************************************************/
+{
+ /* Computing the offset for the next best solution */
+
+ double delta = rel_impr * fabs(z);
+ if ( csa->integer_obj ) delta = ceil(delta);
+
+ return(delta);
+}
+
+/**********************************************************************/
+static double objval(int ncols, double *x, double *true_obj)
+/**********************************************************************/
+{
+ /* Computing the true cost of x (using the original obj coeff.s) */
+
+ int j;
+ double z = 0.0;
+ for ( j = 1; j < (ncols +1); j++ ) {
+ z += x[j] * true_obj[j];
+ }
+ return z + true_obj[0];
+}
+
+/**********************************************************************/
+static void array_copy(int begin, int end, double *source,
+ double *destination)
+/**********************************************************************/
+{
+ int i;
+ for (i = begin; i < end; i++) {
+ destination[i] = source[i];
+ }
+}
+/**********************************************************************/
+static int do_refine(struct csa *csa, glp_prob *lp_ref, int ncols,
+ int *ckind, double *xref, int *tlim, int tref_lim,
+ int verbose)
+/**********************************************************************/
+{
+ /*
+ Refinement is applied when the variables of the problem are not
+ all binary. Binary variables are fixed to their value and
+ remaining ones are optimized. If there are only continuos
+ variables (in addition to those binary) the problem becomes just
+ an LP. Otherwise, it remains a MIP but of smaller size.
+ */
+
+ int j, tout;
+ double refineStart = second();
+ double val, tela, tlimit;
+
+ if ( glp_get_num_cols(lp_ref) != ncols ) {
+ if (verbose) {
+ xprintf("Error in Proxy refinement: ");
+ xprintf("wrong number of columns (%d vs %d).\n",
+ ncols, glp_get_num_cols(lp_ref));
+ }
+ return 1;
+ }
+
+ val = -1.0;
+
+ /* fixing all binary variables to their current value in xref */
+ for ( j = 1; j < (ncols + 1); j++ ) {
+ if ( ckind[j] == GLP_BV ) {
+ val = 0.0;
+ if ( xref[j] > 0.5 ) val = 1.0;
+ glp_set_col_bnds(lp_ref, j, GLP_FX, val, val);
+ }
+ }
+
+ /* re-optimizing (refining) if some bound has been changed */
+ if ( val > -1.0 ) {
+ glp_iocp parm_ref;
+ glp_smcp parm_ref_lp;
+ int err, status;
+
+ glp_init_iocp(&parm_ref);
+ parm_ref.presolve = GLP_ON;
+ glp_init_smcp(&parm_ref_lp);
+ /*
+ If there are no general integer variable the problem becomes
+ an LP (after fixing the binary variables) and can be solved
+ quickly. Otherwise the problem is still a MIP problem and a
+ timelimit has to be set.
+ */
+ parm_ref.tm_lim = tref_lim;
+ if (parm_ref.tm_lim > *tlim) {
+ parm_ref.tm_lim = *tlim;
+ }
+ parm_ref_lp.tm_lim = parm_ref.tm_lim;
+#ifdef PROXY_DEBUG
+ xprintf("***** REFINING *****\n");
+#endif
+ tout = glp_term_out(GLP_OFF);
+ if (csa->i_vars_exist == TRUE) {
+ err = glp_intopt(lp_ref, &parm_ref);
+ }
+ else {
+ err = glp_simplex(lp_ref, &parm_ref_lp);
+ }
+ glp_term_out(tout);
+
+ if (csa->i_vars_exist == TRUE) {
+ status = glp_mip_status(lp_ref);
+ }
+ else {
+ status = glp_get_status(lp_ref);
+ }
+
+#if 1 /* 29/II-2016 by mao as reported by Chris */
+ switch (status)
+ { case GLP_OPT:
+ case GLP_FEAS:
+ break;
+ default:
+ status = GLP_UNDEF;
+ break;
+ }
+#endif
+
+#ifdef PROXY_DEBUG
+ xprintf("STATUS REFINING = %d\n",status);
+#endif
+ if (status == GLP_UNDEF) {
+ if (err == GLP_ETMLIM) {
+#ifdef PROXY_DEBUG
+ xprintf("Time limit exceeded on Proxy refining.\n");
+#endif
+ return 1;
+ }
+ }
+ for( j = 1 ; j < (ncols + 1); j++ ){
+ if (ckind[j] != GLP_BV) {
+ if (csa->i_vars_exist == TRUE) {
+ xref[j] = glp_mip_col_val(lp_ref, j);
+ }
+ else{
+ xref[j] = glp_get_col_prim(lp_ref, j);
+ }
+ }
+ }
+ }
+ tela = second() - refineStart;
+#ifdef PROXY_DEBUG
+ xprintf("REFINE TELA = %3.1lf\n",tela*1000);
+#endif
+ return 0;
+}
+/**********************************************************************/
+static void deallocate(struct csa *csa, int refine)
+/**********************************************************************/
+{
+ /* Deallocating routine */
+
+ if (refine) {
+ glp_delete_prob(csa->lp_ref);
+ }
+
+ tfree(csa->ckind);
+ tfree(csa->clb);
+ tfree(csa->cub);
+ tfree(csa->true_obj);
+
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/proxy/proxy.h b/test/monniaux/glpk-4.65/src/proxy/proxy.h
new file mode 100644
index 00000000..a91e36f2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/proxy/proxy.h
@@ -0,0 +1,36 @@
+/* proxy.h (proximity search heuristic algorithm) */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Author: Giorgio Sartor <0gioker0@gmail.com>.
+*
+* Copyright (C) 2013 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef PROXY_H
+#define PROXY_H
+
+#define proxy _glp_proxy
+int proxy(glp_prob *lp, double *zstar, double *xstar,
+ const double initsol[], double rel_impr, int tlim,
+ int verbose);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/proxy/proxy1.c b/test/monniaux/glpk-4.65/src/proxy/proxy1.c
new file mode 100644
index 00000000..5f9850d4
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/proxy/proxy1.c
@@ -0,0 +1,88 @@
+/* proxy1.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2013, 2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "ios.h"
+#include "proxy.h"
+
+void ios_proxy_heur(glp_tree *T)
+{ glp_prob *prob;
+ int j, status;
+ double *xstar, zstar;
+ /* this heuristic is applied only once on the root level */
+ if (!(T->curr->level == 0 && T->curr->solved == 1))
+ goto done;
+ prob = glp_create_prob();
+ glp_copy_prob(prob, T->mip, 0);
+ xstar = xcalloc(1+prob->n, sizeof(double));
+ for (j = 1; j <= prob->n; j++)
+ xstar[j] = 0.0;
+ if (T->mip->mip_stat != GLP_FEAS)
+ status = proxy(prob, &zstar, xstar, NULL, 0.0,
+ T->parm->ps_tm_lim, 1);
+ else
+ { double *xinit = xcalloc(1+prob->n, sizeof(double));
+ for (j = 1; j <= prob->n; j++)
+ xinit[j] = T->mip->col[j]->mipx;
+ status = proxy(prob, &zstar, xstar, xinit, 0.0,
+ T->parm->ps_tm_lim, 1);
+ xfree(xinit);
+ }
+ if (status == 0)
+#if 0 /* 17/III-2016 */
+ glp_ios_heur_sol(T, xstar);
+#else
+ { /* sometimes the proxy heuristic reports a wrong solution, so
+ * make sure that the solution is really integer feasible */
+ int i, feas1, feas2, ae_ind, re_ind;
+ double ae_max, re_max;
+ glp_copy_prob(prob, T->mip, 0);
+ for (j = 1; j <= prob->n; j++)
+ prob->col[j]->mipx = xstar[j];
+ for (i = 1; i <= prob->m; i++)
+ { GLPROW *row;
+ GLPAIJ *aij;
+ row = prob->row[i];
+ row->mipx = 0.0;
+ for (aij = row->ptr; aij != NULL; aij = aij->r_next)
+ row->mipx += aij->val * aij->col->mipx;
+ }
+ glp_check_kkt(prob, GLP_MIP, GLP_KKT_PE, &ae_max, &ae_ind,
+ &re_max, &re_ind);
+ feas1 = (re_max <= 1e-6);
+ glp_check_kkt(prob, GLP_MIP, GLP_KKT_PB, &ae_max, &ae_ind,
+ &re_max, &re_ind);
+ feas2 = (re_max <= 1e-6);
+ if (feas1 && feas2)
+ glp_ios_heur_sol(T, xstar);
+ else
+ xprintf("WARNING: PROXY HEURISTIC REPORTED WRONG SOLUTION; "
+ "SOLUTION REJECTED\n");
+ }
+#endif
+ xfree(xstar);
+ glp_delete_prob(prob);
+done: return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/simplex.h b/test/monniaux/glpk-4.65/src/simplex/simplex.h
new file mode 100644
index 00000000..9a5acdb2
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/simplex.h
@@ -0,0 +1,39 @@
+/* simplex.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SIMPLEX_H
+#define SIMPLEX_H
+
+#include "prob.h"
+
+#define spx_primal _glp_spx_primal
+int spx_primal(glp_prob *P, const glp_smcp *parm);
+/* driver to the primal simplex method */
+
+#define spy_dual _glp_spy_dual
+int spy_dual(glp_prob *P, const glp_smcp *parm);
+/* driver to the dual simplex method */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxat.c b/test/monniaux/glpk-4.65/src/simplex/spxat.c
new file mode 100644
index 00000000..3570a18c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxat.c
@@ -0,0 +1,265 @@
+/* spxat.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxat.h"
+
+/***********************************************************************
+* spx_alloc_at - allocate constraint matrix in sparse row-wise format
+*
+* This routine allocates the memory for arrays needed to represent the
+* constraint matrix in sparse row-wise format. */
+
+void spx_alloc_at(SPXLP *lp, SPXAT *at)
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ at->ptr = talloc(1+m+1, int);
+ at->ind = talloc(1+nnz, int);
+ at->val = talloc(1+nnz, double);
+ at->work = talloc(1+n, double);
+ return;
+}
+
+/***********************************************************************
+* spx_build_at - build constraint matrix in sparse row-wise format
+*
+* This routine builds sparse row-wise representation of the constraint
+* matrix A using its sparse column-wise representation stored in the
+* lp object, and stores the result in the at object. */
+
+void spx_build_at(SPXLP *lp, SPXAT *at)
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int *AT_ptr = at->ptr;
+ int *AT_ind = at->ind;
+ double *AT_val = at->val;
+ int i, k, ptr, end, pos;
+ /* calculate AT_ptr[i] = number of non-zeros in i-th row */
+ memset(&AT_ptr[1], 0, m * sizeof(int));
+ for (k = 1; k <= n; k++)
+ { ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ AT_ptr[A_ind[ptr]]++;
+ }
+ /* set AT_ptr[i] to position after last element in i-th row */
+ AT_ptr[1]++;
+ for (i = 2; i <= m; i++)
+ AT_ptr[i] += AT_ptr[i-1];
+ xassert(AT_ptr[m] == nnz+1);
+ AT_ptr[m+1] = nnz+1;
+ /* build row-wise representation and re-arrange AT_ptr[i] */
+ for (k = n; k >= 1; k--)
+ { /* copy elements from k-th column to corresponding rows */
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ { pos = --AT_ptr[A_ind[ptr]];
+ AT_ind[pos] = k;
+ AT_val[pos] = A_val[ptr];
+ }
+ }
+ xassert(AT_ptr[1] == 1);
+ return;
+}
+
+/***********************************************************************
+* spx_at_prod - compute product y := y + s * A'* x
+*
+* This routine computes the product:
+*
+* y := y + s * A'* x,
+*
+* where A' is a matrix transposed to the mxn-matrix A of constraint
+* coefficients, x is a m-vector, s is a scalar, y is a n-vector.
+*
+* The routine uses the row-wise representation of the matrix A and
+* computes the product as a linear combination:
+*
+* y := y + s * (A'[1] * x[1] + ... + A'[m] * x[m]),
+*
+* where A'[i] is i-th row of A, 1 <= i <= m. */
+
+void spx_at_prod(SPXLP *lp, SPXAT *at, double y[/*1+n*/], double s,
+ const double x[/*1+m*/])
+{ int m = lp->m;
+ int *AT_ptr = at->ptr;
+ int *AT_ind = at->ind;
+ double *AT_val = at->val;
+ int i, ptr, end;
+ double t;
+ for (i = 1; i <= m; i++)
+ { if (x[i] != 0.0)
+ { /* y := y + s * (i-th row of A) * x[i] */
+ t = s * x[i];
+ ptr = AT_ptr[i];
+ end = AT_ptr[i+1];
+ for (; ptr < end; ptr++)
+ y[AT_ind[ptr]] += AT_val[ptr] * t;
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_nt_prod1 - compute product y := y + s * N'* x
+*
+* This routine computes the product:
+*
+* y := y + s * N'* x,
+*
+* where N' is a matrix transposed to the mx(n-m)-matrix N composed
+* from non-basic columns of the constraint matrix A, x is a m-vector,
+* s is a scalar, y is (n-m)-vector.
+*
+* If the flag ign is non-zero, the routine ignores the input content
+* of the array y assuming that y = 0. */
+
+void spx_nt_prod1(SPXLP *lp, SPXAT *at, double y[/*1+n-m*/], int ign,
+ double s, const double x[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ double *work = at->work;
+ int j, k;
+ for (k = 1; k <= n; k++)
+ work[k] = 0.0;
+ if (!ign)
+ { for (j = 1; j <= n-m; j++)
+ work[head[m+j]] = y[j];
+ }
+ spx_at_prod(lp, at, work, s, x);
+ for (j = 1; j <= n-m; j++)
+ y[j] = work[head[m+j]];
+ return;
+}
+
+/***********************************************************************
+* spx_eval_trow1 - compute i-th row of simplex table
+*
+* This routine computes i-th row of the current simplex table
+* T = (T[i,j]) = - inv(B) * N, 1 <= i <= m, using representation of
+* the constraint matrix A in row-wise format.
+*
+* The vector rho = (rho[j]), which is i-th row of the basis inverse
+* inv(B), should be previously computed with the routine spx_eval_rho.
+* It is assumed that elements of this vector are stored in the array
+* locations rho[1], ..., rho[m].
+*
+* There exist two ways to compute the simplex table row.
+*
+* 1. T[i,j], j = 1,...,n-m, is computed as inner product:
+*
+* m
+* T[i,j] = - sum a[i,k] * rho[i],
+* i=1
+*
+* where N[j] = A[k] is a column of the constraint matrix corresponding
+* to non-basic variable xN[j]. The estimated number of operations in
+* this case is:
+*
+* n1 = (n - m) * (nnz(A) / n),
+*
+* (n - m) is the number of columns of N, nnz(A) / n is the average
+* number of non-zeros in one column of A and, therefore, of N.
+*
+* 2. The simplex table row is computed as part of a linear combination
+* of rows of A with coefficients rho[i] != 0. The estimated number
+* of operations in this case is:
+*
+* n2 = nnz(rho) * (nnz(A) / m),
+*
+* where nnz(rho) is the number of non-zeros in the vector rho,
+* nnz(A) / m is the average number of non-zeros in one row of A.
+*
+* If n1 < n2, the routine computes the simples table row using the
+* first way (like the routine spx_eval_trow). Otherwise, the routine
+* uses the second way calling the routine spx_nt_prod1.
+*
+* On exit components of the simplex table row are stored in the array
+* locations trow[1], ... trow[n-m]. */
+
+void spx_eval_trow1(SPXLP *lp, SPXAT *at, const double rho[/*1+m*/],
+ double trow[/*1+n-m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int i, j, nnz_rho;
+ double cnt1, cnt2;
+ /* determine nnz(rho) */
+ nnz_rho = 0;
+ for (i = 1; i <= m; i++)
+ { if (rho[i] != 0.0)
+ nnz_rho++;
+ }
+ /* estimate the number of operations for both ways */
+ cnt1 = (double)(n - m) * ((double)nnz / (double)n);
+ cnt2 = (double)nnz_rho * ((double)nnz / (double)m);
+ /* compute i-th row of simplex table */
+ if (cnt1 < cnt2)
+ { /* as inner products */
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int *head = lp->head;
+ int k, ptr, end;
+ double tij;
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* compute t[i,j] = - N'[j] * pi */
+ tij = 0.0;
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ tij -= A_val[ptr] * rho[A_ind[ptr]];
+ trow[j] = tij;
+ }
+ }
+ else
+ { /* as linear combination */
+ spx_nt_prod1(lp, at, trow, 1, -1.0, rho);
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_free_at - deallocate constraint matrix in sparse row-wise format
+*
+* This routine deallocates the memory used for arrays of the program
+* object at. */
+
+void spx_free_at(SPXLP *lp, SPXAT *at)
+{ xassert(lp == lp);
+ tfree(at->ptr);
+ tfree(at->ind);
+ tfree(at->val);
+ tfree(at->work);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxat.h b/test/monniaux/glpk-4.65/src/simplex/spxat.h
new file mode 100644
index 00000000..98d5b003
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxat.h
@@ -0,0 +1,80 @@
+/* spxat.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXAT_H
+#define SPXAT_H
+
+#include "spxlp.h"
+
+typedef struct SPXAT SPXAT;
+
+struct SPXAT
+{ /* mxn-matrix A of constraint coefficients in sparse row-wise
+ * format */
+ int *ptr; /* int ptr[1+m+1]; */
+ /* ptr[0] is not used;
+ * ptr[i], 1 <= i <= m, is starting position of i-th row in
+ * arrays ind and val; note that ptr[1] is always 1;
+ * ptr[m+1] indicates the position after the last element in
+ * arrays ind and val, i.e. ptr[m+1] = nnz+1, where nnz is the
+ * number of non-zero elements in matrix A;
+ * the length of i-th row (the number of non-zero elements in
+ * that row) can be calculated as ptr[i+1] - ptr[i] */
+ int *ind; /* int ind[1+nnz]; */
+ /* column indices */
+ double *val; /* double val[1+nnz]; */
+ /* non-zero element values */
+ double *work; /* double work[1+n]; */
+ /* working array */
+};
+
+#define spx_alloc_at _glp_spx_alloc_at
+void spx_alloc_at(SPXLP *lp, SPXAT *at);
+/* allocate constraint matrix in sparse row-wise format */
+
+#define spx_build_at _glp_spx_build_at
+void spx_build_at(SPXLP *lp, SPXAT *at);
+/* build constraint matrix in sparse row-wise format */
+
+#define spx_at_prod _glp_spx_at_prod
+void spx_at_prod(SPXLP *lp, SPXAT *at, double y[/*1+n*/], double s,
+ const double x[/*1+m*/]);
+/* compute product y := y + s * A'* x */
+
+#define spx_nt_prod1 _glp_spx_nt_prod1
+void spx_nt_prod1(SPXLP *lp, SPXAT *at, double y[/*1+n-m*/], int ign,
+ double s, const double x[/*1+m*/]);
+/* compute product y := y + s * N'* x */
+
+#define spx_eval_trow1 _glp_spx_eval_trow1
+void spx_eval_trow1(SPXLP *lp, SPXAT *at, const double rho[/*1+m*/],
+ double trow[/*1+n-m*/]);
+/* compute i-th row of simplex table */
+
+#define spx_free_at _glp_spx_free_at
+void spx_free_at(SPXLP *lp, SPXAT *at);
+/* deallocate constraint matrix in sparse row-wise format */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxchuzc.c b/test/monniaux/glpk-4.65/src/simplex/spxchuzc.c
new file mode 100644
index 00000000..c60ccabc
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxchuzc.c
@@ -0,0 +1,381 @@
+/* spxchuzc.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxchuzc.h"
+
+/***********************************************************************
+* spx_chuzc_sel - select eligible non-basic variables
+*
+* This routine selects eligible non-basic variables xN[j], whose
+* reduced costs d[j] have "wrong" sign, i.e. changing such xN[j] in
+* feasible direction improves (decreases) the objective function.
+*
+* Reduced costs of non-basic variables should be placed in the array
+* locations d[1], ..., d[n-m].
+*
+* Non-basic variable xN[j] is considered eligible if:
+*
+* d[j] <= -eps[j] and xN[j] can increase
+*
+* d[j] >= +eps[j] and xN[j] can decrease
+*
+* for
+*
+* eps[j] = tol + tol1 * |cN[j]|,
+*
+* where cN[j] is the objective coefficient at xN[j], tol and tol1 are
+* specified tolerances.
+*
+* On exit the routine stores indices j of eligible non-basic variables
+* xN[j] to the array locations list[1], ..., list[num] and returns the
+* number of such variables 0 <= num <= n-m. (If the parameter list is
+* specified as NULL, no indices are stored.) */
+
+int spx_chuzc_sel(SPXLP *lp, const double d[/*1+n-m*/], double tol,
+ double tol1, int list[/*1+n-m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k, num;
+ double ck, eps;
+ num = 0;
+ /* walk thru list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == u[k])
+ { /* xN[j] is fixed variable; skip it */
+ continue;
+ }
+ /* determine absolute tolerance eps[j] */
+ ck = c[k];
+ eps = tol + tol1 * (ck >= 0.0 ? +ck : -ck);
+ /* check if xN[j] is eligible */
+ if (d[j] <= -eps)
+ { /* xN[j] should be able to increase */
+ if (flag[j])
+ { /* but its upper bound is active */
+ continue;
+ }
+ }
+ else if (d[j] >= +eps)
+ { /* xN[j] should be able to decrease */
+ if (!flag[j] && l[k] != -DBL_MAX)
+ { /* but its lower bound is active */
+ continue;
+ }
+ }
+ else /* -eps < d[j] < +eps */
+ { /* xN[j] does not affect the objective function within the
+ * specified tolerance */
+ continue;
+ }
+ /* xN[j] is eligible non-basic variable */
+ num++;
+ if (list != NULL)
+ list[num] = j;
+ }
+ return num;
+}
+
+/***********************************************************************
+* spx_chuzc_std - choose non-basic variable (Dantzig's rule)
+*
+* This routine chooses most eligible non-basic variable xN[q]
+* according to Dantzig's ("standard") rule:
+*
+* d[q] = max |d[j]|,
+* j in J
+*
+* where J <= {1, ..., n-m} is the set of indices of eligible non-basic
+* variables, d[j] is the reduced cost of non-basic variable xN[j] in
+* the current basis.
+*
+* Reduced costs of non-basic variables should be placed in the array
+* locations d[1], ..., d[n-m].
+*
+* Indices of eligible non-basic variables j in J should be placed in
+* the array locations list[1], ..., list[num], where num = |J| > 0 is
+* the total number of such variables.
+*
+* On exit the routine returns q, the index of the non-basic variable
+* xN[q] chosen. */
+
+int spx_chuzc_std(SPXLP *lp, const double d[/*1+n-m*/], int num,
+ const int list[])
+{ int m = lp->m;
+ int n = lp->n;
+ int j, q, t;
+ double abs_dj, abs_dq;
+ xassert(0 < num && num <= n-m);
+ q = 0, abs_dq = -1.0;
+ for (t = 1; t <= num; t++)
+ { j = list[t];
+ abs_dj = (d[j] >= 0.0 ? +d[j] : -d[j]);
+ if (abs_dq < abs_dj)
+ q = j, abs_dq = abs_dj;
+ }
+ xassert(q != 0);
+ return q;
+}
+
+/***********************************************************************
+* spx_alloc_se - allocate pricing data block
+*
+* This routine allocates the memory for arrays used in the pricing
+* data block. */
+
+void spx_alloc_se(SPXLP *lp, SPXSE *se)
+{ int m = lp->m;
+ int n = lp->n;
+ se->valid = 0;
+ se->refsp = talloc(1+n, char);
+ se->gamma = talloc(1+n-m, double);
+ se->work = talloc(1+m, double);
+ return;
+}
+
+/***********************************************************************
+* spx_reset_refsp - reset reference space
+*
+* This routine resets (re-initializes) the reference space composing
+* it from variables which are non-basic in the current basis, and sets
+* all weights gamma[j] to 1. */
+
+void spx_reset_refsp(SPXLP *lp, SPXSE *se)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *gamma = se->gamma;
+ int j, k;
+ se->valid = 1;
+ memset(&refsp[1], 0, n * sizeof(char));
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ refsp[k] = 1;
+ gamma[j] = 1.0;
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_eval_gamma_j - compute projected steepest edge weight directly
+*
+* This routine computes projected steepest edge weight gamma[j],
+* 1 <= j <= n-m, for the current basis directly with the formula:
+*
+* m
+* gamma[j] = delta[j] + sum eta[i] * T[i,j]**2,
+* i=1
+*
+* where T[i,j] is element of the current simplex table, and
+*
+* ( 1, if xB[i] is in the reference space
+* eta[i] = {
+* ( 0, otherwise
+*
+* ( 1, if xN[j] is in the reference space
+* delta[j] = {
+* ( 0, otherwise
+*
+* NOTE: For testing/debugging only. */
+
+double spx_eval_gamma_j(SPXLP *lp, SPXSE *se, int j)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *tcol = se->work;
+ int i, k;
+ double gamma_j;
+ xassert(se->valid);
+ xassert(1 <= j && j <= n-m);
+ k = head[m+j]; /* x[k] = xN[j] */
+ gamma_j = (refsp[k] ? 1.0 : 0.0);
+ spx_eval_tcol(lp, j, tcol);
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ if (refsp[k])
+ gamma_j += tcol[i] * tcol[i];
+ }
+ return gamma_j;
+}
+
+/***********************************************************************
+* spx_chuzc_pse - choose non-basic variable (projected steepest edge)
+*
+* This routine chooses most eligible non-basic variable xN[q]
+* according to the projected steepest edge method:
+*
+* d[q]**2 d[j]**2
+* -------- = max -------- ,
+* gamma[q] j in J gamma[j]
+*
+* where J <= {1, ..., n-m} is the set of indices of eligible non-basic
+* variable, d[j] is the reduced cost of non-basic variable xN[j] in
+* the current basis, gamma[j] is the projected steepest edge weight.
+*
+* Reduced costs of non-basic variables should be placed in the array
+* locations d[1], ..., d[n-m].
+*
+* Indices of eligible non-basic variables j in J should be placed in
+* the array locations list[1], ..., list[num], where num = |J| > 0 is
+* the total number of such variables.
+*
+* On exit the routine returns q, the index of the non-basic variable
+* xN[q] chosen. */
+
+int spx_chuzc_pse(SPXLP *lp, SPXSE *se, const double d[/*1+n-m*/],
+ int num, const int list[])
+{ int m = lp->m;
+ int n = lp->n;
+ double *gamma = se->gamma;
+ int j, q, t;
+ double best, temp;
+ xassert(se->valid);
+ xassert(0 < num && num <= n-m);
+ q = 0, best = -1.0;
+ for (t = 1; t <= num; t++)
+ { j = list[t];
+ /* FIXME */
+ if (gamma[j] < DBL_EPSILON)
+ temp = 0.0;
+ else
+ temp = (d[j] * d[j]) / gamma[j];
+ if (best < temp)
+ q = j, best = temp;
+ }
+ xassert(q != 0);
+ return q;
+}
+
+/***********************************************************************
+* spx_update_gamma - update projected steepest edge weights exactly
+*
+* This routine updates the vector gamma = (gamma[j]) of projected
+* steepest edge weights exactly, for the adjacent basis.
+*
+* On entry to the routine the content of the se object should be valid
+* and should correspond to the current basis.
+*
+* The parameter 1 <= p <= m specifies basic variable xB[p] which
+* becomes non-basic variable xN[q] in the adjacent basis.
+*
+* The parameter 1 <= q <= n-m specified non-basic variable xN[q] which
+* becomes basic variable xB[p] in the adjacent basis.
+*
+* It is assumed that the array trow contains elements of p-th (pivot)
+* row T'[p] of the simplex table in locations trow[1], ..., trow[n-m].
+* It is also assumed that the array tcol contains elements of q-th
+* (pivot) column T[q] of the simple table in locations tcol[1], ...,
+* tcol[m]. (These row and column should be computed for the current
+* basis.)
+*
+* For details about the formulae used see the program documentation.
+*
+* The routine also computes the relative error:
+*
+* e = |gamma[q] - gamma'[q]| / (1 + |gamma[q]|),
+*
+* where gamma'[q] is the weight for xN[q] on entry to the routine,
+* and returns e on exit. (If e happens to be large enough, the calling
+* program may reset the reference space, since other weights also may
+* be inaccurate.) */
+
+double spx_update_gamma(SPXLP *lp, SPXSE *se, int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *gamma = se->gamma;
+ double *u = se->work;
+ int i, j, k, ptr, end;
+ double gamma_q, delta_q, e, r, s, t1, t2;
+ xassert(se->valid);
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* compute gamma[q] in current basis more accurately; also
+ * compute auxiliary vector u */
+ k = head[m+q]; /* x[k] = xN[q] */
+ gamma_q = delta_q = (refsp[k] ? 1.0 : 0.0);
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ if (refsp[k])
+ { gamma_q += tcol[i] * tcol[i];
+ u[i] = tcol[i];
+ }
+ else
+ u[i] = 0.0;
+ }
+ bfd_btran(lp->bfd, u);
+ /* compute relative error in gamma[q] */
+ e = fabs(gamma_q - gamma[q]) / (1.0 + gamma_q);
+ /* compute new gamma[q] */
+ gamma[q] = gamma_q / (tcol[p] * tcol[p]);
+ /* compute new gamma[j] for all j != q */
+ for (j = 1; j <= n-m; j++)
+ { if (j == q)
+ continue;
+ if (-1e-9 < trow[j] && trow[j] < +1e-9)
+ { /* T[p,j] is close to zero; gamma[j] is not changed */
+ continue;
+ }
+ /* compute r[j] = T[p,j] / T[p,q] */
+ r = trow[j] / tcol[p];
+ /* compute inner product s[j] = N'[j] * u, where N[j] = A[k]
+ * is constraint matrix column corresponding to xN[j] */
+ s = 0.0;
+ k = head[m+j]; /* x[k] = xN[j] */
+ ptr = lp->A_ptr[k];
+ end = lp->A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ s += lp->A_val[ptr] * u[lp->A_ind[ptr]];
+ /* compute new gamma[j] */
+ t1 = gamma[j] + r * (r * gamma_q + s + s);
+ t2 = (refsp[k] ? 1.0 : 0.0) + delta_q * r * r;
+ gamma[j] = (t1 >= t2 ? t1 : t2);
+ }
+ return e;
+}
+
+/***********************************************************************
+* spx_free_se - deallocate pricing data block
+*
+* This routine deallocates the memory used for arrays in the pricing
+* data block. */
+
+void spx_free_se(SPXLP *lp, SPXSE *se)
+{ xassert(lp == lp);
+ tfree(se->refsp);
+ tfree(se->gamma);
+ tfree(se->work);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxchuzc.h b/test/monniaux/glpk-4.65/src/simplex/spxchuzc.h
new file mode 100644
index 00000000..c09cca9a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxchuzc.h
@@ -0,0 +1,85 @@
+/* spxchuzc.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXCHUZC_H
+#define SPXCHUZC_H
+
+#include "spxlp.h"
+
+#define spx_chuzc_sel _glp_spx_chuzc_sel
+int spx_chuzc_sel(SPXLP *lp, const double d[/*1+n-m*/], double tol,
+ double tol1, int list[/*1+n-m*/]);
+/* select eligible non-basic variables */
+
+#define spx_chuzc_std _glp_spx_chuzc_std
+int spx_chuzc_std(SPXLP *lp, const double d[/*1+n-m*/], int num,
+ const int list[]);
+/* choose non-basic variable (Dantzig's rule) */
+
+typedef struct SPXSE SPXSE;
+
+struct SPXSE
+{ /* projected steepest edge and Devex pricing data block */
+ int valid;
+ /* content validity flag */
+ char *refsp; /* char refsp[1+n]; */
+ /* refsp[0] is not used;
+ * refsp[k], 1 <= k <= n, is the flag meaning that variable x[k]
+ * is in the reference space */
+ double *gamma; /* double gamma[1+n-m]; */
+ /* gamma[0] is not used;
+ * gamma[j], 1 <= j <= n-m, is the weight for reduced cost d[j]
+ * of non-basic variable xN[j] in the current basis */
+ double *work; /* double work[1+m]; */
+ /* working array */
+};
+
+#define spx_alloc_se _glp_spx_alloc_se
+void spx_alloc_se(SPXLP *lp, SPXSE *se);
+/* allocate pricing data block */
+
+#define spx_reset_refsp _glp_spx_reset_refsp
+void spx_reset_refsp(SPXLP *lp, SPXSE *se);
+/* reset reference space */
+
+#define spx_eval_gamma_j _glp_spx_eval_gamma_j
+double spx_eval_gamma_j(SPXLP *lp, SPXSE *se, int j);
+/* compute projeted steepest edge weight directly */
+
+#define spx_chuzc_pse _glp_spx_chuzc_pse
+int spx_chuzc_pse(SPXLP *lp, SPXSE *se, const double d[/*1+n-m*/],
+ int num, const int list[]);
+/* choose non-basic variable (projected steepest edge) */
+
+#define spx_update_gamma _glp_spx_update_gamma
+double spx_update_gamma(SPXLP *lp, SPXSE *se, int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/]);
+/* update projected steepest edge weights exactly */
+
+#define spx_free_se _glp_spx_free_se
+void spx_free_se(SPXLP *lp, SPXSE *se);
+/* deallocate pricing data block */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxchuzr.c b/test/monniaux/glpk-4.65/src/simplex/spxchuzr.c
new file mode 100644
index 00000000..8bef77ba
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxchuzr.c
@@ -0,0 +1,594 @@
+/* spxchuzr.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxchuzr.h"
+
+/***********************************************************************
+* spx_chuzr_std - choose basic variable (textbook ratio test)
+*
+* This routine implements an improved textbook ratio test to choose
+* basic variable xB[p].
+*
+* The parameter phase specifies the search phase:
+*
+* 1 - searching for feasible basic solution. In this case the routine
+* uses artificial bounds of basic variables that correspond to
+* breakpoints of the penalty function:
+*
+* ( lB[i], if cB[i] = 0
+* (
+* lB'[i] = { uB[i], if cB[i] > 0
+* (
+* ( -inf, if cB[i] < 0
+*
+* ( uB[i], if cB[i] = 0
+* (
+* uB'[i] = { +inf, if cB[i] > 0
+* (
+* ( lB[i], if cB[i] < 0
+*
+* where lB[i] and uB[i] are original bounds of variable xB[i],
+* cB[i] is the penalty (objective) coefficient of that variable.
+*
+* 2 - searching for optimal basic solution. In this case the routine
+* uses original bounds of basic variables.
+*
+* Current values of basic variables should be placed in the array
+* locations beta[1], ..., beta[m].
+*
+* The parameter 1 <= q <= n-m specifies the index of non-basic
+* variable xN[q] chosen.
+*
+* The parameter s specifies the direction in which xN[q] changes:
+* s = +1.0 means xN[q] increases, and s = -1.0 means xN[q] decreases.
+* (Thus, the corresponding ray parameter is theta = s (xN[q] - f[q]),
+* where f[q] is the active bound of xN[q] in the current basis.)
+*
+* Elements of q-th simplex table column T[q] = (t[i,q]) corresponding
+* to non-basic variable xN[q] should be placed in the array locations
+* tcol[1], ..., tcol[m].
+*
+* The parameter tol_piv specifies a tolerance for elements of the
+* simplex table column T[q]. If |t[i,q]| < tol_piv, basic variable
+* xB[i] is skipped, i.e. it is assumed that it does not depend on the
+* ray parameter theta.
+*
+* The parameters tol and tol1 specify tolerances used to increase the
+* choice freedom by simulating an artificial degeneracy as follows.
+* If beta[i] <= lB[i] + delta[i], where delta[i] = tol + tol1 |lB[i]|,
+* it is assumed that beta[i] is exactly the same as lB[i]. Similarly,
+* if beta[i] >= uB[i] - delta[i], where delta[i] = tol + tol1 |uB[i]|,
+* it is assumed that beta[i] is exactly the same as uB[i].
+*
+* The routine determines the index 1 <= p <= m of basic variable xB[p]
+* that reaches its (lower or upper) bound first on increasing the ray
+* parameter theta, stores the bound flag (0 - lower bound or fixed
+* value, 1 - upper bound) to the location pointed to by the pointer
+* p_flag, and returns the index p. If non-basic variable xN[q] is
+* double-bounded and reaches its opposite bound first, the routine
+* returns (-1). And if the ray parameter may increase unlimitedly, the
+* routine returns zero.
+*
+* Should note that the bound flag stored to the location pointed to by
+* p_flag corresponds to the original (not artficial) bound of variable
+* xB[p] and defines the active bound flag lp->flag[q] to be set in the
+* adjacent basis for that basic variable. */
+
+int spx_chuzr_std(SPXLP *lp, int phase, const double beta[/*1+m*/],
+ int q, double s, const double tcol[/*1+m*/], int *p_flag,
+ double tol_piv, double tol, double tol1)
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, i_flag, k, p;
+ double alfa, biga, delta, lk, uk, teta, teta_min;
+ xassert(phase == 1 || phase == 2);
+ xassert(1 <= q && q <= n-m);
+ xassert(s == +1.0 || s == -1.0);
+ /* determine initial teta_min */
+ k = head[m+q]; /* x[k] = xN[q] */
+ if (l[k] == -DBL_MAX || u[k] == +DBL_MAX)
+ { /* xN[q] has no opposite bound */
+ p = 0, *p_flag = 0, teta_min = DBL_MAX, biga = 0.0;
+ }
+ else
+ { /* xN[q] have both lower and upper bounds */
+ p = -1, *p_flag = 0, teta_min = fabs(l[k] - u[k]), biga = 1.0;
+ }
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ /* determine alfa such that delta xB[i] = alfa * teta */
+ alfa = s * tcol[i];
+ if (alfa <= -tol_piv)
+ { /* xB[i] decreases */
+ /* determine actual lower bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* xB[i] has no actual lower bound */
+ continue;
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* actual lower bound of xB[i] is its upper bound */
+ lk = u[k];
+ xassert(lk != +DBL_MAX);
+ i_flag = 1;
+ }
+ else
+ { /* actual lower bound of xB[i] is its original bound */
+ lk = l[k];
+ if (lk == -DBL_MAX)
+ continue;
+ i_flag = 0;
+ }
+ /* determine teta on which xB[i] reaches its lower bound */
+ delta = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] <= lk + delta)
+ teta = 0.0;
+ else
+ teta = (lk - beta[i]) / alfa;
+ }
+ else if (alfa >= +tol_piv)
+ { /* xB[i] increases */
+ /* determine actual upper bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* actual upper bound of xB[i] is its lower bound */
+ uk = l[k];
+ xassert(uk != -DBL_MAX);
+ i_flag = 0;
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* xB[i] has no actual upper bound */
+ continue;
+ }
+ else
+ { /* actual upper bound of xB[i] is its original bound */
+ uk = u[k];
+ if (uk == +DBL_MAX)
+ continue;
+ i_flag = 1;
+ }
+ /* determine teta on which xB[i] reaches its upper bound */
+ delta = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] >= uk - delta)
+ teta = 0.0;
+ else
+ teta = (uk - beta[i]) / alfa;
+ }
+ else
+ { /* xB[i] does not depend on teta */
+ continue;
+ }
+ /* choose basic variable xB[p] for which teta is minimal */
+ xassert(teta >= 0.0);
+ alfa = (alfa >= 0.0 ? +alfa : -alfa);
+ if (teta_min > teta || (teta_min == teta && biga < alfa))
+ p = i, *p_flag = i_flag, teta_min = teta, biga = alfa;
+ }
+ /* if xB[p] is fixed variable, adjust its bound flag */
+ if (p > 0)
+ { k = head[p];
+ if (l[k] == u[k])
+ *p_flag = 0;
+ }
+ return p;
+}
+
+/***********************************************************************
+* spx_chuzr_harris - choose basic variable (Harris' ratio test)
+*
+* This routine implements Harris' ratio test to choose basic variable
+* xB[p].
+*
+* All the parameters, except tol and tol1, as well as the returned
+* value have the same meaning as for the routine spx_chuzr_std (see
+* above).
+*
+* The parameters tol and tol1 specify tolerances on bound violations
+* for basic variables. For the lower bound of basic variable xB[i] the
+* tolerance is delta[i] = tol + tol1 |lB[i]|, and for the upper bound
+* the tolerance is delta[i] = tol + tol1 |uB[i]|. */
+
+int spx_chuzr_harris(SPXLP *lp, int phase, const double beta[/*1+m*/],
+ int q, double s, const double tcol[/*1+m*/], int *p_flag,
+ double tol_piv, double tol, double tol1)
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, i_flag, k, p;
+ double alfa, biga, delta, lk, uk, teta, teta_min;
+ xassert(phase == 1 || phase == 2);
+ xassert(1 <= q && q <= n-m);
+ xassert(s == +1.0 || s == -1.0);
+ /*--------------------------------------------------------------*/
+ /* first pass: determine teta_min for relaxed bounds */
+ /*--------------------------------------------------------------*/
+ teta_min = DBL_MAX;
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ /* determine alfa such that delta xB[i] = alfa * teta */
+ alfa = s * tcol[i];
+ if (alfa <= -tol_piv)
+ { /* xB[i] decreases */
+ /* determine actual lower bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* xB[i] has no actual lower bound */
+ continue;
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* actual lower bound of xB[i] is its upper bound */
+ lk = u[k];
+ xassert(lk != +DBL_MAX);
+ }
+ else
+ { /* actual lower bound of xB[i] is its original bound */
+ lk = l[k];
+ if (lk == -DBL_MAX)
+ continue;
+ }
+ /* determine teta on which xB[i] reaches its relaxed lower
+ * bound */
+ delta = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] < lk)
+ teta = - delta / alfa;
+ else
+ teta = ((lk - delta) - beta[i]) / alfa;
+ }
+ else if (alfa >= +tol_piv)
+ { /* xB[i] increases */
+ /* determine actual upper bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* actual upper bound of xB[i] is its lower bound */
+ uk = l[k];
+ xassert(uk != -DBL_MAX);
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* xB[i] has no actual upper bound */
+ continue;
+ }
+ else
+ { /* actual upper bound of xB[i] is its original bound */
+ uk = u[k];
+ if (uk == +DBL_MAX)
+ continue;
+ }
+ /* determine teta on which xB[i] reaches its relaxed upper
+ * bound */
+ delta = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] > uk)
+ teta = + delta / alfa;
+ else
+ teta = ((uk + delta) - beta[i]) / alfa;
+ }
+ else
+ { /* xB[i] does not depend on teta */
+ continue;
+ }
+ xassert(teta >= 0.0);
+ if (teta_min > teta)
+ teta_min = teta;
+ }
+ /*--------------------------------------------------------------*/
+ /* second pass: choose basic variable xB[p] */
+ /*--------------------------------------------------------------*/
+ k = head[m+q]; /* x[k] = xN[q] */
+ if (l[k] != -DBL_MAX && u[k] != +DBL_MAX)
+ { /* xN[q] has both lower and upper bounds */
+ if (fabs(l[k] - u[k]) <= teta_min)
+ { /* and reaches its opposite bound */
+ p = -1, *p_flag = 0;
+ goto done;
+ }
+ }
+ if (teta_min == DBL_MAX)
+ { /* teta may increase unlimitedly */
+ p = 0, *p_flag = 0;
+ goto done;
+ }
+ /* nothing is chosen so far */
+ p = 0, *p_flag = 0, biga = 0.0;
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ /* determine alfa such that delta xB[i] = alfa * teta */
+ alfa = s * tcol[i];
+ if (alfa <= -tol_piv)
+ { /* xB[i] decreases */
+ /* determine actual lower bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* xB[i] has no actual lower bound */
+ continue;
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* actual lower bound of xB[i] is its upper bound */
+ lk = u[k];
+ xassert(lk != +DBL_MAX);
+ i_flag = 1;
+ }
+ else
+ { /* actual lower bound of xB[i] is its original bound */
+ lk = l[k];
+ if (lk == -DBL_MAX)
+ continue;
+ i_flag = 0;
+ }
+ /* determine teta on which xB[i] reaches its lower bound */
+ teta = (lk - beta[i]) / alfa;
+ }
+ else if (alfa >= +tol_piv)
+ { /* xB[i] increases */
+ /* determine actual upper bound of xB[i] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* actual upper bound of xB[i] is its lower bound */
+ uk = l[k];
+ xassert(uk != -DBL_MAX);
+ i_flag = 0;
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* xB[i] has no actual upper bound */
+ continue;
+ }
+ else
+ { /* actual upper bound of xB[i] is its original bound */
+ uk = u[k];
+ if (uk == +DBL_MAX)
+ continue;
+ i_flag = 1;
+ }
+ /* determine teta on which xB[i] reaches its upper bound */
+ teta = (uk - beta[i]) / alfa;
+ }
+ else
+ { /* xB[i] does not depend on teta */
+ continue;
+ }
+ /* choose basic variable for which teta is not greater than
+ * teta_min determined for relaxed bounds and which has best
+ * (largest in magnitude) pivot */
+ alfa = (alfa >= 0.0 ? +alfa : -alfa);
+ if (teta <= teta_min && biga < alfa)
+ p = i, *p_flag = i_flag, biga = alfa;
+ }
+ /* something must be chosen */
+ xassert(1 <= p && p <= m);
+ /* if xB[p] is fixed variable, adjust its bound flag */
+ k = head[p];
+ if (l[k] == u[k])
+ *p_flag = 0;
+done: return p;
+}
+
+#if 1 /* 22/VI-2017 */
+/***********************************************************************
+* spx_ls_eval_bp - determine penalty function break points
+*
+* This routine determines break points of the penalty function (which
+* is the sum of primal infeasibilities).
+*
+* The parameters lp, beta, q, dq, tcol, and tol_piv have the same
+* meaning as for the routine spx_chuzr_std (see above).
+*
+* The routine stores the break-points determined to the array elements
+* bp[1], ..., bp[nbp] in *arbitrary* order, where 0 <= nbp <= 2*m+1 is
+* the number of break-points returned by the routine on exit. */
+
+int spx_ls_eval_bp(SPXLP *lp, const double beta[/*1+m*/],
+ int q, double dq, const double tcol[/*1+m*/], double tol_piv,
+ SPXBP bp[/*1+2*m+1*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, k, nbp;
+ double s, alfa;
+ xassert(1 <= q && q <= n-m);
+ xassert(dq != 0.0);
+ s = (dq < 0.0 ? +1.0 : -1.0);
+ nbp = 0;
+ /* if chosen non-basic variable xN[q] is double-bounded, include
+ * it in the list, because it can cross its opposite bound */
+ k = head[m+q]; /* x[k] = xN[q] */
+ if (l[k] != -DBL_MAX && u[k] != +DBL_MAX)
+ { nbp++;
+ bp[nbp].i = 0;
+ xassert(l[k] < u[k]); /* xN[q] cannot be fixed */
+ bp[nbp].teta = u[k] - l[k];
+ bp[nbp].dc = s;
+ }
+ /* build the list of all basic variables xB[i] that can cross
+ * their bound(s) for the ray parameter 0 <= teta < teta_max */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ xassert(l[k] <= u[k]);
+ /* determine alfa such that (delta xB[i]) = alfa * teta */
+ alfa = s * tcol[i];
+ if (alfa >= +tol_piv)
+ { /* xB[i] increases on increasing teta */
+ if (l[k] == u[k])
+ { /* xB[i] is fixed at lB[i] = uB[i] */
+ if (c[k] <= 0.0)
+ { /* increasing xB[i] can cross its fixed value lB[i],
+ * because currently xB[i] <= lB[i] */
+ nbp++;
+ bp[nbp].i = +i;
+ bp[nbp].teta = (l[k] - beta[i]) / alfa;
+ /* if xB[i] > lB[i] then cB[i] = +1 */
+ bp[nbp].dc = +1.0 - c[k];
+ }
+ }
+ else
+ { if (l[k] != -DBL_MAX && c[k] < 0.0)
+ { /* increasing xB[i] can cross its lower bound lB[i],
+ * because currently xB[i] < lB[i] */
+ nbp++;
+ bp[nbp].i = +i;
+ bp[nbp].teta = (l[k] - beta[i]) / alfa;
+ bp[nbp].dc = +1.0;
+ }
+ if (u[k] != +DBL_MAX && c[k] <= 0.0)
+ { /* increasing xB[i] can cross its upper bound uB[i],
+ * because currently xB[i] does not violate it */
+ nbp++;
+ bp[nbp].i = -i;
+ bp[nbp].teta = (u[k] - beta[i]) / alfa;
+ bp[nbp].dc = +1.0;
+ }
+ }
+ }
+ else if (alfa <= -tol_piv)
+ { /* xB[i] decreases on increasing teta */
+ if (l[k] == u[k])
+ { /* xB[i] is fixed at lB[i] = uB[i] */
+ if (c[k] >= 0.0)
+ { /* decreasing xB[i] can cross its fixed value lB[i],
+ * because currently xB[i] >= lB[i] */
+ nbp++;
+ bp[nbp].i = +i;
+ bp[nbp].teta = (l[k] - beta[i]) / alfa;
+ /* if xB[i] < lB[i] then cB[i] = -1 */
+ bp[nbp].dc = -1.0 - c[k];
+ }
+ }
+ else
+ { if (l[k] != -DBL_MAX && c[k] >= 0.0)
+ { /* decreasing xB[i] can cross its lower bound lB[i],
+ * because currently xB[i] does not violate it */
+ nbp++;
+ bp[nbp].i = +i;
+ bp[nbp].teta = (l[k] - beta[i]) / alfa;
+ bp[nbp].dc = -1.0;
+ }
+ if (u[k] != +DBL_MAX && c[k] > 0.0)
+ { /* decreasing xB[i] can cross its upper bound uB[i],
+ * because currently xB[i] > uB[i] */
+ nbp++;
+ bp[nbp].i = -i;
+ bp[nbp].teta = (u[k] - beta[i]) / alfa;
+ bp[nbp].dc = -1.0;
+ }
+ }
+ }
+ else
+ { /* xB[i] does not depend on teta within a tolerance */
+ continue;
+ }
+ /* teta < 0 may happen only due to round-off errors when the
+ * current value of xB[i] is *close* to its (lower or upper)
+ * bound; in this case we replace teta by exact zero */
+ if (bp[nbp].teta < 0.0)
+ bp[nbp].teta = 0.0;
+ }
+ xassert(nbp <= 2*m+1);
+ return nbp;
+}
+#endif
+
+#if 1 /* 22/VI-2017 */
+/***********************************************************************
+* spx_ls_select_bp - select and process penalty function break points
+*
+* This routine selects a next portion of the penalty function break
+* points and processes them.
+*
+* On entry to the routine it is assumed that break points bp[1], ...,
+* bp[num] are already processed, and slope is the penalty function
+* slope to the right of the last processed break point bp[num].
+* (Initially, when num = 0, slope should be specified as -fabs(d[q]),
+* where d[q] is the reduced cost of chosen non-basic variable xN[q].)
+*
+* The routine selects break points among bp[num+1], ..., bp[nbp], for
+* which teta <= teta_lim, and moves these break points to the array
+* elements bp[num+1], ..., bp[num1], where num <= num1 <= 2*m+1 is the
+* new number of processed break points returned by the routine on
+* exit. Then the routine sorts the break points by ascending teta and
+* computes the change of the penalty function relative to its value at
+* teta = 0.
+*
+* On exit the routine also replaces the parameter slope with a new
+* value that corresponds to the new last break-point bp[num1]. */
+
+static int CDECL fcmp(const void *v1, const void *v2)
+{ const SPXBP *p1 = v1, *p2 = v2;
+ if (p1->teta < p2->teta)
+ return -1;
+ else if (p1->teta > p2->teta)
+ return +1;
+ else
+ return 0;
+}
+
+int spx_ls_select_bp(SPXLP *lp, const double tcol[/*1+m*/],
+ int nbp, SPXBP bp[/*1+m+m+1*/], int num, double *slope, double
+ teta_lim)
+{ int m = lp->m;
+ int i, t, num1;
+ double teta, dz;
+ xassert(0 <= num && num <= nbp && nbp <= m+m+1);
+ /* select a new portion of break points */
+ num1 = num;
+ for (t = num+1; t <= nbp; t++)
+ { if (bp[t].teta <= teta_lim)
+ { /* move break point to the beginning of the new portion */
+ num1++;
+ i = bp[num1].i, teta = bp[num1].teta, dz = bp[num1].dc;
+ bp[num1].i = bp[t].i, bp[num1].teta = bp[t].teta,
+ bp[num1].dc = bp[t].dc;
+ bp[t].i = i, bp[t].teta = teta, bp[t].dc = dz;
+ }
+ }
+ /* sort new break points bp[num+1], ..., bp[num1] by ascending
+ * the ray parameter teta */
+ if (num1 - num > 1)
+ qsort(&bp[num+1], num1 - num, sizeof(SPXBP), fcmp);
+ /* calculate the penalty function change at the new break points
+ * selected */
+ for (t = num+1; t <= num1; t++)
+ { /* calculate the penalty function change relative to its value
+ * at break point bp[t-1] */
+ dz = (*slope) * (bp[t].teta - (t == 1 ? 0.0 : bp[t-1].teta));
+ /* calculate the penalty function change relative to its value
+ * at teta = 0 */
+ bp[t].dz = (t == 1 ? 0.0 : bp[t-1].dz) + dz;
+ /* calculate a new slope of the penalty function to the right
+ * of the current break point bp[t] */
+ i = (bp[t].i >= 0 ? bp[t].i : -bp[t].i);
+ xassert(0 <= i && i <= m);
+ if (i == 0)
+ *slope += fabs(1.0 * bp[t].dc);
+ else
+ *slope += fabs(tcol[i] * bp[t].dc);
+ }
+ return num1;
+}
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxchuzr.h b/test/monniaux/glpk-4.65/src/simplex/spxchuzr.h
new file mode 100644
index 00000000..3ec90050
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxchuzr.h
@@ -0,0 +1,77 @@
+/* spxchuzr.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXCHUZR_H
+#define SPXCHUZR_H
+
+#include "spxlp.h"
+
+#define spx_chuzr_std _glp_spx_chuzr_std
+int spx_chuzr_std(SPXLP *lp, int phase, const double beta[/*1+m*/],
+ int q, double s, const double tcol[/*1+m*/], int *p_flag,
+ double tol_piv, double tol, double tol1);
+/* choose basic variable (textbook ratio test) */
+
+#define spx_chuzr_harris _glp_spx_chuzr_harris
+int spx_chuzr_harris(SPXLP *lp, int phase, const double beta[/*1+m*/],
+ int q, double s, const double tcol[/*1+m*/], int *p_flag,
+ double tol_piv, double tol, double tol1);
+/* choose basic variable (Harris' ratio test) */
+
+#if 1 /* 22/VI-2017 */
+typedef struct SPXBP SPXBP;
+
+struct SPXBP
+{ /* penalty function (sum of infeasibilities) break point */
+ int i;
+ /* basic variable xB[i], 1 <= i <= m, that intersects its bound
+ * at this break point
+ * i > 0 if xB[i] intersects its lower bound (or fixed value)
+ * i < 0 if xB[i] intersects its upper bound
+ * i = 0 if xN[q] intersects its opposite bound */
+ double teta;
+ /* ray parameter value, teta >= 0, at this break point */
+ double dc;
+ /* increment of the penalty function coefficient cB[i] at this
+ * break point */
+ double dz;
+ /* increment, z[t] - z[0], of the penalty function at this break
+ * point */
+};
+
+#define spx_ls_eval_bp _glp_spx_ls_eval_bp
+int spx_ls_eval_bp(SPXLP *lp, const double beta[/*1+m*/],
+ int q, double dq, const double tcol[/*1+m*/], double tol_piv,
+ SPXBP bp[/*1+2*m+1*/]);
+/* determine penalty function break points */
+
+#define spx_ls_select_bp _glp_spx_ls_select_bp
+int spx_ls_select_bp(SPXLP *lp, const double tcol[/*1+m*/],
+ int nbp, SPXBP bp[/*1+m+m+1*/], int num, double *slope, double
+ teta_lim);
+/* select and process penalty function break points */
+#endif
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxlp.c b/test/monniaux/glpk-4.65/src/simplex/spxlp.c
new file mode 100644
index 00000000..90ce2636
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxlp.c
@@ -0,0 +1,819 @@
+/* spxlp.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxlp.h"
+
+/***********************************************************************
+* spx_factorize - compute factorization of current basis matrix
+*
+* This routine computes factorization of the current basis matrix B.
+*
+* If the factorization has been successfully computed, the routine
+* validates it and returns zero. Otherwise, the routine invalidates
+* the factorization and returns the code provided by the factorization
+* driver (bfd_factorize). */
+
+static int jth_col(void *info, int j, int ind[], double val[])
+{ /* provide column B[j] */
+ SPXLP *lp = info;
+ int m = lp->m;
+ int *A_ptr = lp->A_ptr;
+ int *head = lp->head;
+ int k, ptr, len;
+ xassert(1 <= j && j <= m);
+ k = head[j]; /* x[k] = xB[j] */
+ ptr = A_ptr[k];
+ len = A_ptr[k+1] - ptr;
+ memcpy(&ind[1], &lp->A_ind[ptr], len * sizeof(int));
+ memcpy(&val[1], &lp->A_val[ptr], len * sizeof(double));
+ return len;
+}
+
+int spx_factorize(SPXLP *lp)
+{ int ret;
+ ret = bfd_factorize(lp->bfd, lp->m, jth_col, lp);
+ lp->valid = (ret == 0);
+ return ret;
+}
+
+/***********************************************************************
+* spx_eval_beta - compute current values of basic variables
+*
+* This routine computes vector beta = (beta[i]) of current values of
+* basic variables xB = (xB[i]). (Factorization of the current basis
+* matrix should be valid.)
+*
+* First the routine computes a modified vector of right-hand sides:
+*
+* n-m
+* y = b - N * f = b - sum N[j] * f[j],
+* j=1
+*
+* where b = (b[i]) is the original vector of right-hand sides, N is
+* a matrix composed from columns of the original constraint matrix A,
+* which (columns) correspond to non-basic variables, f = (f[j]) is the
+* vector of active bounds of non-basic variables xN = (xN[j]),
+* N[j] = A[k] is a column of matrix A corresponding to non-basic
+* variable xN[j] = x[k], f[j] is current active bound lN[j] = l[k] or
+* uN[j] = u[k] of non-basic variable xN[j] = x[k]. The matrix-vector
+* product N * f is computed as a linear combination of columns of N,
+* so if f[j] = 0, column N[j] can be skipped.
+*
+* Then the routine performs FTRAN to compute the vector beta:
+*
+* beta = inv(B) * y.
+*
+* On exit the routine stores components of the vector beta to array
+* locations beta[1], ..., beta[m]. */
+
+void spx_eval_beta(SPXLP *lp, double beta[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ double *b = lp->b;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k, ptr, end;
+ double fj, *y;
+ /* compute y = b - N * xN */
+ /* y := b */
+ y = beta;
+ memcpy(&y[1], &b[1], m * sizeof(double));
+ /* y := y - N * f */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* f[j] := active bound of xN[j] */
+ fj = flag[j] ? u[k] : l[k];
+ if (fj == 0.0 || fj == -DBL_MAX)
+ { /* either xN[j] has zero active bound or it is unbounded;
+ * in the latter case its value is assumed to be zero */
+ continue;
+ }
+ /* y := y - N[j] * f[j] */
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ y[A_ind[ptr]] -= A_val[ptr] * fj;
+ }
+ /* compute beta = inv(B) * y */
+ xassert(lp->valid);
+ bfd_ftran(lp->bfd, beta);
+ return;
+}
+
+/***********************************************************************
+* spx_eval_obj - compute current value of objective function
+*
+* This routine computes the value of the objective function in the
+* current basic solution:
+*
+* z = cB'* beta + cN'* f + c[0] =
+*
+* m n-m
+* = sum cB[i] * beta[i] + sum cN[j] * f[j] + c[0],
+* i=1 j=1
+*
+* where cB = (cB[i]) is the vector of objective coefficients at basic
+* variables, beta = (beta[i]) is the vector of current values of basic
+* variables, cN = (cN[j]) is the vector of objective coefficients at
+* non-basic variables, f = (f[j]) is the vector of current active
+* bounds of non-basic variables, c[0] is the constant term of the
+* objective function.
+*
+* It as assumed that components of the vector beta are stored in the
+* array locations beta[1], ..., beta[m]. */
+
+double spx_eval_obj(SPXLP *lp, const double beta[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int i, j, k;
+ double fj, z;
+ /* compute z = cB'* beta + cN'* f + c0 */
+ /* z := c0 */
+ z = c[0];
+ /* z := z + cB'* beta */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ z += c[k] * beta[i];
+ }
+ /* z := z + cN'* f */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* f[j] := active bound of xN[j] */
+ fj = flag[j] ? u[k] : l[k];
+ if (fj == 0.0 || fj == -DBL_MAX)
+ { /* either xN[j] has zero active bound or it is unbounded;
+ * in the latter case its value is assumed to be zero */
+ continue;
+ }
+ z += c[k] * fj;
+ }
+ return z;
+}
+
+/***********************************************************************
+* spx_eval_pi - compute simplex multipliers in current basis
+*
+* This routine computes vector pi = (pi[i]) of simplex multipliers in
+* the current basis. (Factorization of the current basis matrix should
+* be valid.)
+*
+* The vector pi is computed by performing BTRAN:
+*
+* pi = inv(B') * cB,
+*
+* where cB = (cB[i]) is the vector of objective coefficients at basic
+* variables xB = (xB[i]).
+*
+* On exit components of vector pi are stored in the array locations
+* pi[1], ..., pi[m]. */
+
+void spx_eval_pi(SPXLP *lp, double pi[/*1+m*/])
+{ int m = lp->m;
+ double *c = lp->c;
+ int *head = lp->head;
+ int i;
+ double *cB;
+ /* construct cB */
+ cB = pi;
+ for (i = 1; i <= m; i++)
+ cB[i] = c[head[i]];
+ /* compute pi = inv(B) * cB */
+ bfd_btran(lp->bfd, pi);
+ return;
+}
+
+/***********************************************************************
+* spx_eval_dj - compute reduced cost of j-th non-basic variable
+*
+* This routine computes reduced cost d[j] of non-basic variable
+* xN[j] = x[k], 1 <= j <= n-m, in the current basic solution:
+*
+* d[j] = c[k] - A'[k] * pi,
+*
+* where c[k] is the objective coefficient at x[k], A[k] is k-th column
+* of the constraint matrix, pi is the vector of simplex multipliers in
+* the current basis.
+*
+* It as assumed that components of the vector pi are stored in the
+* array locations pi[1], ..., pi[m]. */
+
+double spx_eval_dj(SPXLP *lp, const double pi[/*1+m*/], int j)
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int k, ptr, end;
+ double dj;
+ xassert(1 <= j && j <= n-m);
+ k = lp->head[m+j]; /* x[k] = xN[j] */
+ /* dj := c[k] */
+ dj = lp->c[k];
+ /* dj := dj - A'[k] * pi */
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ dj -= A_val[ptr] * pi[A_ind[ptr]];
+ return dj;
+}
+
+/***********************************************************************
+* spx_eval_tcol - compute j-th column of simplex table
+*
+* This routine computes j-th column of the current simplex table
+* T = (T[i,j]) = - inv(B) * N, 1 <= j <= n-m. (Factorization of the
+* current basis matrix should be valid.)
+*
+* The simplex table column is computed by performing FTRAN:
+*
+* tcol = - inv(B) * N[j],
+*
+* where B is the current basis matrix, N[j] = A[k] is a column of the
+* constraint matrix corresponding to non-basic variable xN[j] = x[k].
+*
+* On exit components of the simplex table column are stored in the
+* array locations tcol[1], ... tcol[m]. */
+
+void spx_eval_tcol(SPXLP *lp, int j, double tcol[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int *head = lp->head;
+ int i, k, ptr, end;
+ xassert(1 <= j && j <= n-m);
+ k = head[m+j]; /* x[k] = xN[j] */
+ /* compute tcol = - inv(B) * N[j] */
+ for (i = 1; i <= m; i++)
+ tcol[i] = 0.0;
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ tcol[A_ind[ptr]] = -A_val[ptr];
+ bfd_ftran(lp->bfd, tcol);
+ return;
+}
+
+/***********************************************************************
+* spx_eval_rho - compute i-th row of basis matrix inverse
+*
+* This routine computes i-th row of the matrix inv(B), where B is
+* the current basis matrix, 1 <= i <= m. (Factorization of the current
+* basis matrix should be valid.)
+*
+* The inverse row is computed by performing BTRAN:
+*
+* rho = inv(B') * e[i],
+*
+* where e[i] is i-th column of unity matrix.
+*
+* On exit components of the row are stored in the array locations
+* row[1], ..., row[m]. */
+
+void spx_eval_rho(SPXLP *lp, int i, double rho[/*1+m*/])
+{ int m = lp->m;
+ int j;
+ xassert(1 <= i && i <= m);
+ /* compute rho = inv(B') * e[i] */
+ for (j = 1; j <= m; j++)
+ rho[j] = 0.0;
+ rho[i] = 1.0;
+ bfd_btran(lp->bfd, rho);
+ return;
+}
+
+#if 1 /* 31/III-2016 */
+void spx_eval_rho_s(SPXLP *lp, int i, FVS *rho)
+{ /* sparse version of spx_eval_rho */
+ int m = lp->m;
+ xassert(1 <= i && i <= m);
+ /* compute rho = inv(B') * e[i] */
+ xassert(rho->n == m);
+ fvs_clear_vec(rho);
+ rho->nnz = 1;
+ rho->ind[1] = i;
+ rho->vec[i] = 1.0;
+ bfd_btran_s(lp->bfd, rho);
+ return;
+}
+#endif
+
+/***********************************************************************
+* spx_eval_tij - compute element T[i,j] of simplex table
+*
+* This routine computes element T[i,j] of the current simplex table
+* T = - inv(B) * N, 1 <= i <= m, 1 <= j <= n-m, with the following
+* formula:
+*
+* T[i,j] = - N'[j] * rho, (1)
+*
+* where N[j] = A[k] is a column of the constraint matrix corresponding
+* to non-basic variable xN[j] = x[k], rho is i-th row of the inverse
+* matrix inv(B).
+*
+* It as assumed that components of the inverse row rho = (rho[j]) are
+* stored in the array locations rho[1], ..., rho[m]. */
+
+double spx_eval_tij(SPXLP *lp, const double rho[/*1+m*/], int j)
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int k, ptr, end;
+ double tij;
+ xassert(1 <= j && j <= n-m);
+ k = lp->head[m+j]; /* x[k] = xN[j] */
+ /* compute t[i,j] = - N'[j] * pi */
+ tij = 0.0;
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ tij -= A_val[ptr] * rho[A_ind[ptr]];
+ return tij;
+}
+
+/***********************************************************************
+* spx_eval_trow - compute i-th row of simplex table
+*
+* This routine computes i-th row of the current simplex table
+* T = (T[i,j]) = - inv(B) * N, 1 <= i <= m.
+*
+* Elements of the row T[i] = (T[i,j]), j = 1, ..., n-m, are computed
+* directly with the routine spx_eval_tij.
+*
+* The vector rho = (rho[j]), which is i-th row of the basis inverse
+* inv(B), should be previously computed with the routine spx_eval_rho.
+* It is assumed that elements of this vector are stored in the array
+* locations rho[1], ..., rho[m].
+*
+* On exit components of the simplex table row are stored in the array
+* locations trow[1], ... trow[n-m].
+*
+* NOTE: For testing/debugging only. */
+
+void spx_eval_trow(SPXLP *lp, const double rho[/*1+m*/], double
+ trow[/*1+n-m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int j;
+ for (j = 1; j <= n-m; j++)
+ trow[j] = spx_eval_tij(lp, rho, j);
+ return;
+}
+
+/***********************************************************************
+* spx_update_beta - update values of basic variables
+*
+* This routine updates the vector beta = (beta[i]) of values of basic
+* variables xB = (xB[i]) for the adjacent basis.
+*
+* On entry to the routine components of the vector beta in the current
+* basis should be placed in array locations beta[1], ..., beta[m].
+*
+* The parameter 1 <= p <= m specifies basic variable xB[p] which
+* becomes non-basic variable xN[q] in the adjacent basis. The special
+* case p < 0 means that non-basic variable xN[q] goes from its current
+* active bound to opposite one in the adjacent basis.
+*
+* If the flag p_flag is set, the active bound of xB[p] in the adjacent
+* basis is set to its upper bound. (In this case xB[p] should have its
+* upper bound and should not be fixed.)
+*
+* The parameter 1 <= q <= n-m specifies non-basic variable xN[q] which
+* becomes basic variable xB[p] in the adjacent basis (if 1 <= p <= m),
+* or goes to its opposite bound (if p < 0). (In the latter case xN[q]
+* should have both lower and upper bounds and should not be fixed.)
+*
+* It is assumed that the array tcol contains elements of q-th (pivot)
+* column T[q] of the simple table in locations tcol[1], ..., tcol[m].
+* (This column should be computed for the current basis.)
+*
+* First, the routine determines the increment of basic variable xB[p]
+* in the adjacent basis (but only if 1 <= p <= m):
+*
+* ( - beta[p], if -inf < xB[p] < +inf
+* (
+* delta xB[p] = { lB[p] - beta[p], if p_flag = 0
+* (
+* ( uB[p] - beta[p], if p_flag = 1
+*
+* where beta[p] is the value of xB[p] in the current basis, lB[p] and
+* uB[p] are its lower and upper bounds. Then, the routine determines
+* the increment of non-basic variable xN[q] in the adjacent basis:
+*
+* ( delta xB[p] / T[p,q], if 1 <= p <= m
+* (
+* delta xN[q] = { uN[q] - lN[q], if p < 0 and f[q] = lN[q]
+* (
+* ( lN[q] - uN[q], if p < 0 and f[q] = uN[q]
+*
+* where T[p,q] is the pivot element of the simplex table, f[q] is the
+* active bound of xN[q] in the current basis.
+*
+* If 1 <= p <= m, in the adjacent basis xN[q] becomes xB[p], so:
+*
+* new beta[p] = f[q] + delta xN[q].
+*
+* Values of other basic variables xB[i] for 1 <= i <= m, i != p, are
+* updated as follows:
+*
+* new beta[i] = beta[i] + T[i,q] * delta xN[q].
+*
+* On exit the routine stores updated components of the vector beta to
+* the same locations, where the input vector beta was stored. */
+
+void spx_update_beta(SPXLP *lp, double beta[/*1+m*/], int p,
+ int p_flag, int q, const double tcol[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int i, k;
+ double delta_p, delta_q;
+ if (p < 0)
+ { /* special case: xN[q] goes to its opposite bound */
+ xassert(1 <= q && q <= n-m);
+ /* xN[q] should be double-bounded variable */
+ k = head[m+q]; /* x[k] = xN[q] */
+ xassert(l[k] != -DBL_MAX && u[k] != +DBL_MAX && l[k] != u[k]);
+ /* determine delta xN[q] */
+ if (flag[q])
+ { /* xN[q] goes from its upper bound to its lower bound */
+ delta_q = l[k] - u[k];
+ }
+ else
+ { /* xN[q] goes from its lower bound to its upper bound */
+ delta_q = u[k] - l[k];
+ }
+ }
+ else
+ { /* xB[p] leaves the basis, xN[q] enters the basis */
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* determine delta xB[p] */
+ k = head[p]; /* x[k] = xB[p] */
+ if (p_flag)
+ { /* xB[p] goes to its upper bound */
+ xassert(l[k] != u[k] && u[k] != +DBL_MAX);
+ delta_p = u[k] - beta[p];
+ }
+ else if (l[k] == -DBL_MAX)
+ { /* unbounded xB[p] becomes non-basic (unusual case) */
+ xassert(u[k] == +DBL_MAX);
+ delta_p = 0.0 - beta[p];
+ }
+ else
+ { /* xB[p] goes to its lower bound or becomes fixed */
+ delta_p = l[k] - beta[p];
+ }
+ /* determine delta xN[q] */
+ delta_q = delta_p / tcol[p];
+ /* compute new beta[p], which is the value of xN[q] in the
+ * adjacent basis */
+ k = head[m+q]; /* x[k] = xN[q] */
+ if (flag[q])
+ { /* xN[q] has its upper bound active */
+ xassert(l[k] != u[k] && u[k] != +DBL_MAX);
+ beta[p] = u[k] + delta_q;
+ }
+ else if (l[k] == -DBL_MAX)
+ { /* xN[q] is non-basic unbounded variable */
+ xassert(u[k] == +DBL_MAX);
+ beta[p] = 0.0 + delta_q;
+ }
+ else
+ { /* xN[q] has its lower bound active or is fixed (latter
+ * case is unusual) */
+ beta[p] = l[k] + delta_q;
+ }
+ }
+ /* compute new beta[i] for all i != p */
+ for (i = 1; i <= m; i++)
+ { if (i != p)
+ beta[i] += tcol[i] * delta_q;
+ }
+ return;
+}
+
+#if 1 /* 30/III-2016 */
+void spx_update_beta_s(SPXLP *lp, double beta[/*1+m*/], int p,
+ int p_flag, int q, const FVS *tcol)
+{ /* sparse version of spx_update_beta */
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int nnz = tcol->nnz;
+ int *ind = tcol->ind;
+ double *vec = tcol->vec;
+ int i, k;
+ double delta_p, delta_q;
+ xassert(tcol->n == m);
+ if (p < 0)
+ { /* special case: xN[q] goes to its opposite bound */
+#if 0 /* 11/VI-2017 */
+ /* FIXME: not tested yet */
+ xassert(0);
+#endif
+ xassert(1 <= q && q <= n-m);
+ /* xN[q] should be double-bounded variable */
+ k = head[m+q]; /* x[k] = xN[q] */
+ xassert(l[k] != -DBL_MAX && u[k] != +DBL_MAX && l[k] != u[k]);
+ /* determine delta xN[q] */
+ if (flag[q])
+ { /* xN[q] goes from its upper bound to its lower bound */
+ delta_q = l[k] - u[k];
+ }
+ else
+ { /* xN[q] goes from its lower bound to its upper bound */
+ delta_q = u[k] - l[k];
+ }
+ }
+ else
+ { /* xB[p] leaves the basis, xN[q] enters the basis */
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* determine delta xB[p] */
+ k = head[p]; /* x[k] = xB[p] */
+ if (p_flag)
+ { /* xB[p] goes to its upper bound */
+ xassert(l[k] != u[k] && u[k] != +DBL_MAX);
+ delta_p = u[k] - beta[p];
+ }
+ else if (l[k] == -DBL_MAX)
+ { /* unbounded xB[p] becomes non-basic (unusual case) */
+ xassert(u[k] == +DBL_MAX);
+ delta_p = 0.0 - beta[p];
+ }
+ else
+ { /* xB[p] goes to its lower bound or becomes fixed */
+ delta_p = l[k] - beta[p];
+ }
+ /* determine delta xN[q] */
+ delta_q = delta_p / vec[p];
+ /* compute new beta[p], which is the value of xN[q] in the
+ * adjacent basis */
+ k = head[m+q]; /* x[k] = xN[q] */
+ if (flag[q])
+ { /* xN[q] has its upper bound active */
+ xassert(l[k] != u[k] && u[k] != +DBL_MAX);
+ beta[p] = u[k] + delta_q;
+ }
+ else if (l[k] == -DBL_MAX)
+ { /* xN[q] is non-basic unbounded variable */
+ xassert(u[k] == +DBL_MAX);
+ beta[p] = 0.0 + delta_q;
+ }
+ else
+ { /* xN[q] has its lower bound active or is fixed (latter
+ * case is unusual) */
+ beta[p] = l[k] + delta_q;
+ }
+ }
+ /* compute new beta[i] for all i != p */
+ for (k = 1; k <= nnz; k++)
+ { i = ind[k];
+ if (i != p)
+ beta[i] += vec[i] * delta_q;
+ }
+ return;
+}
+#endif
+
+/***********************************************************************
+* spx_update_d - update reduced costs of non-basic variables
+*
+* This routine updates the vector d = (d[j]) of reduced costs of
+* non-basic variables xN = (xN[j]) for the adjacent basis.
+*
+* On entry to the routine components of the vector d in the current
+* basis should be placed in locations d[1], ..., d[n-m].
+*
+* The parameter 1 <= p <= m specifies basic variable xB[p] which
+* becomes non-basic variable xN[q] in the adjacent basis.
+*
+* The parameter 1 <= q <= n-m specified non-basic variable xN[q] which
+* becomes basic variable xB[p] in the adjacent basis.
+*
+* It is assumed that the array trow contains elements of p-th (pivot)
+* row T'[p] of the simplex table in locations trow[1], ..., trow[n-m].
+* It is also assumed that the array tcol contains elements of q-th
+* (pivot) column T[q] of the simple table in locations tcol[1], ...,
+* tcol[m]. (These row and column should be computed for the current
+* basis.)
+*
+* First, the routine computes more accurate reduced cost d[q] in the
+* current basis using q-th column of the simplex table:
+*
+* n-m
+* d[q] = cN[q] + sum t[i,q] * cB[i],
+* i=1
+*
+* where cN[q] and cB[i] are objective coefficients at variables xN[q]
+* and xB[i], resp. The routine also computes the relative error:
+*
+* e = |d[q] - d'[q]| / (1 + |d[q]|),
+*
+* where d'[q] is the reduced cost of xN[q] on entry to the routine,
+* and returns e on exit. (If e happens to be large enough, the calling
+* program may compute the reduced costs directly, since other reduced
+* costs also may be inaccurate.)
+*
+* In the adjacent basis xB[p] becomes xN[q], so:
+*
+* new d[q] = d[q] / T[p,q],
+*
+* where T[p,q] is the pivot element of the simplex table (it is taken
+* from column T[q] as more accurate). Reduced costs of other non-basic
+* variables xN[j] for 1 <= j <= n-m, j != q, are updated as follows:
+*
+* new d[j] = d[j] + T[p,j] * new d[q].
+*
+* On exit the routine stores updated components of the vector d to the
+* same locations, where the input vector d was stored. */
+
+double spx_update_d(SPXLP *lp, double d[/*1+n-m*/], int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ int *head = lp->head;
+ int i, j, k;
+ double dq, e;
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n);
+ /* compute d[q] in current basis more accurately */
+ k = head[m+q]; /* x[k] = xN[q] */
+ dq = c[k];
+ for (i = 1; i <= m; i++)
+ dq += tcol[i] * c[head[i]];
+ /* compute relative error in d[q] */
+ e = fabs(dq - d[q]) / (1.0 + fabs(dq));
+ /* compute new d[q], which is the reduced cost of xB[p] in the
+ * adjacent basis */
+ d[q] = (dq /= tcol[p]);
+ /* compute new d[j] for all j != q */
+ for (j = 1; j <= n-m; j++)
+ { if (j != q)
+ d[j] -= trow[j] * dq;
+ }
+ return e;
+}
+
+#if 1 /* 30/III-2016 */
+double spx_update_d_s(SPXLP *lp, double d[/*1+n-m*/], int p, int q,
+ const FVS *trow, const FVS *tcol)
+{ /* sparse version of spx_update_d */
+ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ int *head = lp->head;
+ int trow_nnz = trow->nnz;
+ int *trow_ind = trow->ind;
+ double *trow_vec = trow->vec;
+ int tcol_nnz = tcol->nnz;
+ int *tcol_ind = tcol->ind;
+ double *tcol_vec = tcol->vec;
+ int i, j, k;
+ double dq, e;
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n);
+ xassert(trow->n == n-m);
+ xassert(tcol->n == m);
+ /* compute d[q] in current basis more accurately */
+ k = head[m+q]; /* x[k] = xN[q] */
+ dq = c[k];
+ for (k = 1; k <= tcol_nnz; k++)
+ { i = tcol_ind[k];
+ dq += tcol_vec[i] * c[head[i]];
+ }
+ /* compute relative error in d[q] */
+ e = fabs(dq - d[q]) / (1.0 + fabs(dq));
+ /* compute new d[q], which is the reduced cost of xB[p] in the
+ * adjacent basis */
+ d[q] = (dq /= tcol_vec[p]);
+ /* compute new d[j] for all j != q */
+ for (k = 1; k <= trow_nnz; k++)
+ { j = trow_ind[k];
+ if (j != q)
+ d[j] -= trow_vec[j] * dq;
+ }
+ return e;
+}
+#endif
+
+/***********************************************************************
+* spx_change_basis - change current basis to adjacent one
+*
+* This routine changes the current basis to the adjacent one making
+* necessary changes in lp->head and lp->flag members.
+*
+* The parameters p, p_flag, and q have the same meaning as for the
+* routine spx_update_beta. */
+
+void spx_change_basis(SPXLP *lp, int p, int p_flag, int q)
+{ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int k;
+ if (p < 0)
+ { /* special case: xN[q] goes to its opposite bound */
+ xassert(1 <= q && q <= n-m);
+ /* xN[q] should be double-bounded variable */
+ k = head[m+q]; /* x[k] = xN[q] */
+ xassert(l[k] != -DBL_MAX && u[k] != +DBL_MAX && l[k] != u[k]);
+ /* change active bound flag */
+ flag[q] = 1 - flag[q];
+ }
+ else
+ { /* xB[p] leaves the basis, xN[q] enters the basis */
+ xassert(1 <= p && p <= m);
+ xassert(p_flag == 0 || p_flag == 1);
+ xassert(1 <= q && q <= n-m);
+ k = head[p]; /* xB[p] = x[k] */
+ if (p_flag)
+ { /* xB[p] goes to its upper bound */
+ xassert(l[k] != u[k] && u[k] != +DBL_MAX);
+ }
+ /* swap xB[p] and xN[q] in the basis */
+ head[p] = head[m+q], head[m+q] = k;
+ /* and set active bound flag for new xN[q] */
+ lp->flag[q] = p_flag;
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_update_invb - update factorization of basis matrix
+*
+* This routine updates factorization of the basis matrix B when i-th
+* column of B is replaced by k-th column of the constraint matrix A.
+*
+* The parameter 1 <= i <= m specifies the number of column of matrix B
+* to be replaced by a new column.
+*
+* The parameter 1 <= k <= n specifies the number of column of matrix A
+* to be used for replacement.
+*
+* If the factorization has been successfully updated, the routine
+* validates it and returns zero. Otherwise, the routine invalidates
+* the factorization and returns the code provided by the factorization
+* driver (bfd_update). */
+
+int spx_update_invb(SPXLP *lp, int i, int k)
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int ptr, len, ret;
+ xassert(1 <= i && i <= m);
+ xassert(1 <= k && k <= n);
+ ptr = A_ptr[k];
+ len = A_ptr[k+1] - ptr;
+ ret = bfd_update(lp->bfd, i, len, &A_ind[ptr-1], &A_val[ptr-1]);
+ lp->valid = (ret == 0);
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxlp.h b/test/monniaux/glpk-4.65/src/simplex/spxlp.h
new file mode 100644
index 00000000..29a135fe
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxlp.h
@@ -0,0 +1,234 @@
+/* spxlp.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXLP_H
+#define SPXLP_H
+
+#include "bfd.h"
+
+/***********************************************************************
+* The structure SPXLP describes LP problem and its current basis.
+*
+* It is assumed that LP problem has the following formulation (this is
+* so called "working format"):
+*
+* z = c'* x + c0 -> min (1)
+*
+* A * x = b (2)
+*
+* l <= x <= u (3)
+*
+* where:
+*
+* x = (x[k]) is a n-vector of variables;
+*
+* z is an objective function;
+*
+* c = (c[k]) is a n-vector of objective coefficients;
+*
+* c0 is a constant term of the objective function;
+*
+* A = (a[i,k]) is a mxn-matrix of constraint coefficients;
+*
+* b = (b[i]) is a m-vector of right-hand sides;
+*
+* l = (l[k]) is a n-vector of lower bounds of variables;
+*
+* u = (u[k]) is a n-vector of upper bounds of variables.
+*
+* If variable x[k] has no lower (upper) bound, it is formally assumed
+* that l[k] = -inf (u[k] = +inf). Variable having no bounds is called
+* free (unbounded) variable. If l[k] = u[k], variable x[k] is assumed
+* to be fixed.
+*
+* It is also assumed that matrix A has full row rank: rank(A) = m,
+* i.e. all its rows are linearly independent, so m <= n.
+*
+* The (current) basis is defined by an appropriate permutation matrix
+* P of order n such that:
+*
+* ( xB )
+* P * x = ( ), (4)
+* ( xN )
+*
+* where xB = (xB[i]) is a m-vector of basic variables, xN = (xN[j]) is
+* a (n-m)-vector of non-basic variables. If a non-basic variable xN[j]
+* has both lower and upper bounds, there is used an additional flag to
+* indicate which bound is active.
+*
+* From (2) and (4) it follows that:
+*
+* A * P'* P * x = b <=> B * xB + N * xN = b, (5)
+*
+* where P' is a matrix transposed to P, and
+*
+* A * P' = (B | N). (6)
+*
+* Here B is the basis matrix, which is a square non-singular matrix
+* of order m composed from columns of matrix A that correspond to
+* basic variables xB, and N is a mx(n-m) matrix composed from columns
+* of matrix A that correspond to non-basic variables xN. */
+
+typedef struct SPXLP SPXLP;
+
+struct SPXLP
+{ /* LP problem data and its (current) basis */
+ int m;
+ /* number of equality constraints, m > 0 */
+ int n;
+ /* number of variables, n >= m */
+ int nnz;
+ /* number of non-zeros in constraint matrix A */
+ /*--------------------------------------------------------------*/
+ /* mxn-matrix A of constraint coefficients in sparse column-wise
+ * format */
+ int *A_ptr; /* int A_ptr[1+n+1]; */
+ /* A_ptr[0] is not used;
+ * A_ptr[k], 1 <= k <= n, is starting position of k-th column in
+ * arrays A_ind and A_val; note that A_ptr[1] is always 1;
+ * A_ptr[n+1] indicates the position after the last element in
+ * arrays A_ind and A_val, i.e. A_ptr[n+1] = nnz+1, where nnz is
+ * the number of non-zero elements in matrix A;
+ * the length of k-th column (the number of non-zero elements in
+ * that column) can be calculated as A_ptr[k+1] - A_ptr[k] */
+ int *A_ind; /* int A_ind[1+nnz]; */
+ /* row indices */
+ double *A_val; /* double A_val[1+nnz]; */
+ /* non-zero element values (constraint coefficients) */
+ /*--------------------------------------------------------------*/
+ /* principal vectors of LP formulation */
+ double *b; /* double b[1+m]; */
+ /* b[0] is not used;
+ * b[i], 1 <= i <= m, is the right-hand side of i-th equality
+ * constraint */
+ double *c; /* double c[1+n]; */
+ /* c[0] is the constant term of the objective function;
+ * c[k], 1 <= k <= n, is the objective function coefficient at
+ * variable x[k] */
+ double *l; /* double l[1+n]; */
+ /* l[0] is not used;
+ * l[k], 1 <= k <= n, is the lower bound of variable x[k];
+ * if x[k] has no lower bound, l[k] = -DBL_MAX */
+ double *u; /* double u[1+n]; */
+ /* u[0] is not used;
+ * u[k], 1 <= k <= n, is the upper bound of variable u[k];
+ * if x[k] has no upper bound, u[k] = +DBL_MAX;
+ * note that l[k] = u[k] means that x[k] is fixed variable */
+ /*--------------------------------------------------------------*/
+ /* LP basis */
+ int *head; /* int head[1+n]; */
+ /* basis header, which is permutation matrix P (4):
+ * head[0] is not used;
+ * head[i] = k means that xB[i] = x[k], 1 <= i <= m;
+ * head[m+j] = k, means that xN[j] = x[k], 1 <= j <= n-m */
+ char *flag; /* char flag[1+n-m]; */
+ /* flags of non-basic variables:
+ * flag[0] is not used;
+ * flag[j], 1 <= j <= n-m, indicates that non-basic variable
+ * xN[j] is non-fixed and has its upper bound active */
+ /*--------------------------------------------------------------*/
+ /* basis matrix B of order m stored in factorized form */
+ int valid;
+ /* factorization validity flag */
+ BFD *bfd;
+ /* driver to factorization of the basis matrix */
+};
+
+#define spx_factorize _glp_spx_factorize
+int spx_factorize(SPXLP *lp);
+/* compute factorization of current basis matrix */
+
+#define spx_eval_beta _glp_spx_eval_beta
+void spx_eval_beta(SPXLP *lp, double beta[/*1+m*/]);
+/* compute values of basic variables */
+
+#define spx_eval_obj _glp_spx_eval_obj
+double spx_eval_obj(SPXLP *lp, const double beta[/*1+m*/]);
+/* compute value of objective function */
+
+#define spx_eval_pi _glp_spx_eval_pi
+void spx_eval_pi(SPXLP *lp, double pi[/*1+m*/]);
+/* compute simplex multipliers */
+
+#define spx_eval_dj _glp_spx_eval_dj
+double spx_eval_dj(SPXLP *lp, const double pi[/*1+m*/], int j);
+/* compute reduced cost of j-th non-basic variable */
+
+#define spx_eval_tcol _glp_spx_eval_tcol
+void spx_eval_tcol(SPXLP *lp, int j, double tcol[/*1+m*/]);
+/* compute j-th column of simplex table */
+
+#define spx_eval_rho _glp_spx_eval_rho
+void spx_eval_rho(SPXLP *lp, int i, double rho[/*1+m*/]);
+/* compute i-th row of basis matrix inverse */
+
+#if 1 /* 31/III-2016 */
+#define spx_eval_rho_s _glp_spx_eval_rho_s
+void spx_eval_rho_s(SPXLP *lp, int i, FVS *rho);
+/* sparse version of spx_eval_rho */
+#endif
+
+#define spx_eval_tij _glp_spx_eval_tij
+double spx_eval_tij(SPXLP *lp, const double rho[/*1+m*/], int j);
+/* compute element T[i,j] of simplex table */
+
+#define spx_eval_trow _glp_spx_eval_trow
+void spx_eval_trow(SPXLP *lp, const double rho[/*1+m*/], double
+ trow[/*1+n-m*/]);
+/* compute i-th row of simplex table */
+
+#define spx_update_beta _glp_spx_update_beta
+void spx_update_beta(SPXLP *lp, double beta[/*1+m*/], int p,
+ int p_flag, int q, const double tcol[/*1+m*/]);
+/* update values of basic variables */
+
+#if 1 /* 30/III-2016 */
+#define spx_update_beta_s _glp_spx_update_beta_s
+void spx_update_beta_s(SPXLP *lp, double beta[/*1+m*/], int p,
+ int p_flag, int q, const FVS *tcol);
+/* sparse version of spx_update_beta */
+#endif
+
+#define spx_update_d _glp_spx_update_d
+double spx_update_d(SPXLP *lp, double d[/*1+n-m*/], int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/]);
+/* update reduced costs of non-basic variables */
+
+#if 1 /* 30/III-2016 */
+#define spx_update_d_s _glp_spx_update_d_s
+double spx_update_d_s(SPXLP *lp, double d[/*1+n-m*/], int p, int q,
+ const FVS *trow, const FVS *tcol);
+/* sparse version of spx_update_d */
+#endif
+
+#define spx_change_basis _glp_spx_change_basis
+void spx_change_basis(SPXLP *lp, int p, int p_flag, int q);
+/* change current basis to adjacent one */
+
+#define spx_update_invb _glp_spx_update_invb
+int spx_update_invb(SPXLP *lp, int i, int k);
+/* update factorization of basis matrix */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxnt.c b/test/monniaux/glpk-4.65/src/simplex/spxnt.c
new file mode 100644
index 00000000..7eaac852
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxnt.c
@@ -0,0 +1,303 @@
+/* spxnt.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxnt.h"
+
+/***********************************************************************
+* spx_alloc_nt - allocate matrix N in sparse row-wise format
+*
+* This routine allocates the memory for arrays needed to represent the
+* matrix N composed of non-basic columns of the constraint matrix A. */
+
+void spx_alloc_nt(SPXLP *lp, SPXNT *nt)
+{ int m = lp->m;
+ int nnz = lp->nnz;
+ nt->ptr = talloc(1+m, int);
+ nt->len = talloc(1+m, int);
+ nt->ind = talloc(1+nnz, int);
+ nt->val = talloc(1+nnz, double);
+ return;
+}
+
+/***********************************************************************
+* spx_init_nt - initialize row pointers for matrix N
+*
+* This routine initializes (sets up) row pointers for the matrix N
+* using column-wise representation of the constraint matrix A.
+*
+* This routine needs to be called only once. */
+
+void spx_init_nt(SPXLP *lp, SPXNT *nt)
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ int *NT_ptr = nt->ptr;
+ int *NT_len = nt->len;
+ int i, k, ptr, end;
+ /* calculate NT_len[i] = maximal number of non-zeros in i-th row
+ * of N = number of non-zeros in i-th row of A */
+ memset(&NT_len[1], 0, m * sizeof(int));
+ for (k = 1; k <= n; k++)
+ { ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ NT_len[A_ind[ptr]]++;
+ }
+ /* initialize row pointers NT_ptr[i], i = 1,...,n-m */
+ NT_ptr[1] = 1;
+ for (i = 2; i <= m; i++)
+ NT_ptr[i] = NT_ptr[i-1] + NT_len[i-1];
+ xassert(NT_ptr[m] + NT_len[m] == nnz+1);
+ return;
+}
+
+/***********************************************************************
+* spx_nt_add_col - add column N[j] = A[k] to matrix N
+*
+* This routine adds elements of column N[j] = A[k], 1 <= j <= n-m,
+* 1 <= k <= n, to the row-wise represntation of the matrix N. It is
+* assumed (with no check) that elements of the specified column are
+* missing in the row-wise represntation of N. */
+
+void spx_nt_add_col(SPXLP *lp, SPXNT *nt, int j, int k)
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ int *NT_ptr = nt->ptr;
+ int *NT_len = nt->len;
+ int *NT_ind = nt->ind;
+ double *NT_val = nt->val;
+ int i, ptr, end, pos;
+ xassert(1 <= j && j <= n-m);
+ xassert(1 <= k && k <= n);
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ { i = A_ind[ptr];
+ /* add element N[i,j] = A[i,k] to i-th row of matrix N */
+ pos = NT_ptr[i] + (NT_len[i]++);
+ if (i < m)
+ xassert(pos < NT_ptr[i+1]);
+ else
+ xassert(pos <= nnz);
+ NT_ind[pos] = j;
+ NT_val[pos] = A_val[ptr];
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_build_nt - build matrix N for current basis
+*
+* This routine builds the row-wise represntation of the matrix N
+* for the current basis by adding columns of the constraint matrix A
+* corresponding to non-basic variables. */
+
+void spx_build_nt(SPXLP *lp, SPXNT *nt)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ int *NT_len = nt->len;
+ int j, k;
+ /* N := 0 */
+ memset(&NT_len[1], 0, m * sizeof(int));
+ /* add non-basic columns N[j] = A[k] */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ spx_nt_add_col(lp, nt, j, k);
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_nt_del_col - remove column N[j] = A[k] from matrix N
+*
+* This routine removes elements of column N[j] = A[k], 1 <= j <= n-m,
+* 1 <= k <= n, from the row-wise representation of the matrix N. It is
+* assumed (with no check) that elements of the specified column are
+* present in the row-wise representation of N. */
+
+void spx_nt_del_col(SPXLP *lp, SPXNT *nt, int j, int k)
+{ int m = lp->m;
+ int n = lp->n;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ int *NT_ptr = nt->ptr;
+ int *NT_len = nt->len;
+ int *NT_ind = nt->ind;
+ double *NT_val = nt->val;
+ int i, ptr, end, ptr1, end1;
+ xassert(1 <= j && j <= n-m);
+ xassert(1 <= k && k <= n);
+ ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ { i = A_ind[ptr];
+ /* find element N[i,j] = A[i,k] in i-th row of matrix N */
+ ptr1 = NT_ptr[i];
+ end1 = ptr1 + NT_len[i];
+ for (; NT_ind[ptr1] != j; ptr1++)
+ /* nop */;
+ xassert(ptr1 < end1);
+ /* and remove it from i-th row element list */
+ NT_len[i]--;
+ NT_ind[ptr1] = NT_ind[end1-1];
+ NT_val[ptr1] = NT_val[end1-1];
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_update_nt - update matrix N for adjacent basis
+*
+* This routine updates the row-wise represntation of matrix N for
+* the adjacent basis, where column N[q], 1 <= q <= n-m, is replaced by
+* column B[p], 1 <= p <= m, of the current basis matrix B. */
+
+void spx_update_nt(SPXLP *lp, SPXNT *nt, int p, int q)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* remove old column N[q] corresponding to variable xN[q] */
+ spx_nt_del_col(lp, nt, q, head[m+q]);
+ /* add new column N[q] corresponding to variable xB[p] */
+ spx_nt_add_col(lp, nt, q, head[p]);
+ return;
+}
+
+/***********************************************************************
+* spx_nt_prod - compute product y := y + s * N'* x
+*
+* This routine computes the product:
+*
+* y := y + s * N'* x,
+*
+* where N' is a matrix transposed to the mx(n-m)-matrix N composed
+* from non-basic columns of the constraint matrix A, x is a m-vector,
+* s is a scalar, y is (n-m)-vector.
+*
+* If the flag ign is non-zero, the routine ignores the input content
+* of the array y assuming that y = 0.
+*
+* The routine uses the row-wise representation of the matrix N and
+* computes the product as a linear combination:
+*
+* y := y + s * (N'[1] * x[1] + ... + N'[m] * x[m]),
+*
+* where N'[i] is i-th row of N, 1 <= i <= m. */
+
+void spx_nt_prod(SPXLP *lp, SPXNT *nt, double y[/*1+n-m*/], int ign,
+ double s, const double x[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *NT_ptr = nt->ptr;
+ int *NT_len = nt->len;
+ int *NT_ind = nt->ind;
+ double *NT_val = nt->val;
+ int i, j, ptr, end;
+ double t;
+ if (ign)
+ { /* y := 0 */
+ for (j = 1; j <= n-m; j++)
+ y[j] = 0.0;
+ }
+ for (i = 1; i <= m; i++)
+ { if (x[i] != 0.0)
+ { /* y := y + s * (i-th row of N) * x[i] */
+ t = s * x[i];
+ ptr = NT_ptr[i];
+ end = ptr + NT_len[i];
+ for (; ptr < end; ptr++)
+ y[NT_ind[ptr]] += NT_val[ptr] * t;
+ }
+ }
+ return;
+}
+
+#if 1 /* 31/III-2016 */
+void spx_nt_prod_s(SPXLP *lp, SPXNT *nt, FVS *y, int ign, double s,
+ const FVS *x, double eps)
+{ /* sparse version of spx_nt_prod */
+ int *NT_ptr = nt->ptr;
+ int *NT_len = nt->len;
+ int *NT_ind = nt->ind;
+ double *NT_val = nt->val;
+ int *x_ind = x->ind;
+ double *x_vec = x->vec;
+ int *y_ind = y->ind;
+ double *y_vec = y->vec;
+ int i, j, k, nnz, ptr, end;
+ double t;
+ xassert(x->n == lp->m);
+ xassert(y->n == lp->n-lp->m);
+ if (ign)
+ { /* y := 0 */
+ fvs_clear_vec(y);
+ }
+ nnz = y->nnz;
+ for (k = x->nnz; k >= 1; k--)
+ { i = x_ind[k];
+ /* y := y + s * (i-th row of N) * x[i] */
+ t = s * x_vec[i];
+ ptr = NT_ptr[i];
+ end = ptr + NT_len[i];
+ for (; ptr < end; ptr++)
+ { j = NT_ind[ptr];
+ if (y_vec[j] == 0.0)
+ y_ind[++nnz] = j;
+ y_vec[j] += NT_val[ptr] * t;
+ /* don't forget about numeric cancellation */
+ if (y_vec[j] == 0.0)
+ y_vec[j] = DBL_MIN;
+ }
+ }
+ y->nnz = nnz;
+ fvs_adjust_vec(y, eps);
+ return;
+}
+#endif
+
+/***********************************************************************
+* spx_free_nt - deallocate matrix N in sparse row-wise format
+*
+* This routine deallocates the memory used for arrays of the program
+* object nt. */
+
+void spx_free_nt(SPXLP *lp, SPXNT *nt)
+{ xassert(lp == lp);
+ tfree(nt->ptr);
+ tfree(nt->len);
+ tfree(nt->ind);
+ tfree(nt->val);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxnt.h b/test/monniaux/glpk-4.65/src/simplex/spxnt.h
new file mode 100644
index 00000000..857917b8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxnt.h
@@ -0,0 +1,96 @@
+/* spxnt.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXNT_H
+#define SPXNT_H
+
+#include "spxlp.h"
+
+typedef struct SPXNT SPXNT;
+
+struct SPXNT
+{ /* mx(n-m)-matrix N composed of non-basic columns of constraint
+ * matrix A, in sparse row-wise format */
+ int *ptr; /* int ptr[1+m]; */
+ /* ptr[0] is not used;
+ * ptr[i], 1 <= i <= m, is starting position of i-th row in
+ * arrays ind and val; note that ptr[1] is always 1;
+ * these starting positions are set up *once* as if they would
+ * correspond to rows of matrix A stored without gaps, i.e.
+ * ptr[i+1] - ptr[i] is the number of non-zeros in i-th (i < m)
+ * row of matrix A, and (nnz+1) - ptr[m] is the number of
+ * non-zero in m-th (last) row of matrix A, where nnz is the
+ * total number of non-zeros in matrix A */
+ int *len; /* int len[1+m]; */
+ /* len[0] is not used;
+ * len[i], 1 <= i <= m, is the number of non-zeros in i-th row
+ * of current matrix N */
+ int *ind; /* int ind[1+nnz]; */
+ /* column indices */
+ double *val; /* double val[1+nnz]; */
+ /* non-zero element values */
+};
+
+#define spx_alloc_nt _glp_spx_alloc_nt
+void spx_alloc_nt(SPXLP *lp, SPXNT *nt);
+/* allocate matrix N in sparse row-wise format */
+
+#define spx_init_nt _glp_spx_init_nt
+void spx_init_nt(SPXLP *lp, SPXNT *nt);
+/* initialize row pointers for matrix N */
+
+#define spx_nt_add_col _glp_spx_nt_add_col
+void spx_nt_add_col(SPXLP *lp, SPXNT *nt, int j, int k);
+/* add column N[j] = A[k] */
+
+#define spx_build_nt _glp_spx_build_nt
+void spx_build_nt(SPXLP *lp, SPXNT *nt);
+/* build matrix N for current basis */
+
+#define spx_nt_del_col _glp_spx_nt_del_col
+void spx_nt_del_col(SPXLP *lp, SPXNT *nt, int j, int k);
+/* remove column N[j] = A[k] from matrix N */
+
+#define spx_update_nt _glp_spx_update_nt
+void spx_update_nt(SPXLP *lp, SPXNT *nt, int p, int q);
+/* update matrix N for adjacent basis */
+
+#define spx_nt_prod _glp_spx_nt_prod
+void spx_nt_prod(SPXLP *lp, SPXNT *nt, double y[/*1+n-m*/], int ign,
+ double s, const double x[/*1+m*/]);
+/* compute product y := y + s * N'* x */
+
+#if 1 /* 31/III-2016 */
+#define spx_nt_prod_s _glp_spx_nt_prod_s
+void spx_nt_prod_s(SPXLP *lp, SPXNT *nt, FVS *y, int ign, double s,
+ const FVS *x, double eps);
+/* sparse version of spx_nt_prod */
+#endif
+
+#define spx_free_nt _glp_spx_free_nt
+void spx_free_nt(SPXLP *lp, SPXNT *nt);
+/* deallocate matrix N in sparse row-wise format */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxprim.c b/test/monniaux/glpk-4.65/src/simplex/spxprim.c
new file mode 100644
index 00000000..e1cdfb5a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxprim.c
@@ -0,0 +1,1860 @@
+/* spxprim.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#if 1 /* 18/VII-2017 */
+#define SCALE_Z 1
+#endif
+
+#include "env.h"
+#include "simplex.h"
+#include "spxat.h"
+#include "spxnt.h"
+#include "spxchuzc.h"
+#include "spxchuzr.h"
+#include "spxprob.h"
+
+#define CHECK_ACCURACY 0
+/* (for debugging) */
+
+struct csa
+{ /* common storage area */
+ SPXLP *lp;
+ /* LP problem data and its (current) basis; this LP has m rows
+ * and n columns */
+ int dir;
+ /* original optimization direction:
+ * +1 - minimization
+ * -1 - maximization */
+#if SCALE_Z
+ double fz;
+ /* factor used to scale original objective */
+#endif
+ double *orig_c; /* double orig_c[1+n]; */
+ /* copy of original objective coefficients */
+ double *orig_l; /* double orig_l[1+n]; */
+ /* copy of original lower bounds */
+ double *orig_u; /* double orig_u[1+n]; */
+ /* copy of original upper bounds */
+ SPXAT *at;
+ /* mxn-matrix A of constraint coefficients, in sparse row-wise
+ * format (NULL if not used) */
+ SPXNT *nt;
+ /* mx(n-m)-matrix N composed of non-basic columns of constraint
+ * matrix A, in sparse row-wise format (NULL if not used) */
+ int phase;
+ /* search phase:
+ * 0 - not determined yet
+ * 1 - searching for primal feasible solution
+ * 2 - searching for optimal solution */
+ double *beta; /* double beta[1+m]; */
+ /* beta[i] is a primal value of basic variable xB[i] */
+ int beta_st;
+ /* status of the vector beta:
+ * 0 - undefined
+ * 1 - just computed
+ * 2 - updated */
+ double *d; /* double d[1+n-m]; */
+ /* d[j] is a reduced cost of non-basic variable xN[j] */
+ int d_st;
+ /* status of the vector d:
+ * 0 - undefined
+ * 1 - just computed
+ * 2 - updated */
+ SPXSE *se;
+ /* projected steepest edge and Devex pricing data block (NULL if
+ * not used) */
+ int num;
+ /* number of eligible non-basic variables */
+ int *list; /* int list[1+n-m]; */
+ /* list[1], ..., list[num] are indices j of eligible non-basic
+ * variables xN[j] */
+ int q;
+ /* xN[q] is a non-basic variable chosen to enter the basis */
+#if 0 /* 11/VI-2017 */
+ double *tcol; /* double tcol[1+m]; */
+#else
+ FVS tcol; /* FVS tcol[1:m]; */
+#endif
+ /* q-th (pivot) column of the simplex table */
+#if 1 /* 23/VI-2017 */
+ SPXBP *bp; /* SPXBP bp[1+2*m+1]; */
+ /* penalty function break points */
+#endif
+ int p;
+ /* xB[p] is a basic variable chosen to leave the basis;
+ * p = 0 means that no basic variable reaches its bound;
+ * p < 0 means that non-basic variable xN[q] reaches its opposite
+ * bound before any basic variable */
+ int p_flag;
+ /* if this flag is set, the active bound of xB[p] in the adjacent
+ * basis should be set to the upper bound */
+#if 0 /* 11/VI-2017 */
+ double *trow; /* double trow[1+n-m]; */
+#else
+ FVS trow; /* FVS trow[1:n-m]; */
+#endif
+ /* p-th (pivot) row of the simplex table */
+#if 0 /* 09/VII-2017 */
+ double *work; /* double work[1+m]; */
+ /* working array */
+#else
+ FVS work; /* FVS work[1:m]; */
+ /* working vector */
+#endif
+ int p_stat, d_stat;
+ /* primal and dual solution statuses */
+ /*--------------------------------------------------------------*/
+ /* control parameters (see struct glp_smcp) */
+ int msg_lev;
+ /* message level */
+#if 0 /* 23/VI-2017 */
+ int harris;
+ /* ratio test technique:
+ * 0 - textbook ratio test
+ * 1 - Harris' two pass ratio test */
+#else
+ int r_test;
+ /* ratio test technique:
+ * GLP_RT_STD - textbook ratio test
+ * GLP_RT_HAR - Harris' two pass ratio test
+ * GLP_RT_FLIP - long-step ratio test (only for phase I) */
+#endif
+ double tol_bnd, tol_bnd1;
+ /* primal feasibility tolerances */
+ double tol_dj, tol_dj1;
+ /* dual feasibility tolerances */
+ double tol_piv;
+ /* pivot tolerance */
+ int it_lim;
+ /* iteration limit */
+ int tm_lim;
+ /* time limit, milliseconds */
+ int out_frq;
+#if 0 /* 15/VII-2017 */
+ /* display output frequency, iterations */
+#else
+ /* display output frequency, milliseconds */
+#endif
+ int out_dly;
+ /* display output delay, milliseconds */
+ /*--------------------------------------------------------------*/
+ /* working parameters */
+ double tm_beg;
+ /* time value at the beginning of the search */
+ int it_beg;
+ /* simplex iteration count at the beginning of the search */
+ int it_cnt;
+ /* simplex iteration count; it increases by one every time the
+ * basis changes (including the case when a non-basic variable
+ * jumps to its opposite bound) */
+ int it_dpy;
+ /* simplex iteration count at most recent display output */
+#if 1 /* 15/VII-2017 */
+ double tm_dpy;
+ /* time value at most recent display output */
+#endif
+ int inv_cnt;
+ /* basis factorization count since most recent display output */
+#if 1 /* 01/VII-2017 */
+ int degen;
+ /* count of successive degenerate iterations; this count is used
+ * to detect stalling */
+#endif
+#if 1 /* 23/VI-2017 */
+ int ns_cnt, ls_cnt;
+ /* normal and long-step iteration counts */
+#endif
+};
+
+/***********************************************************************
+* set_penalty - set penalty function coefficients
+*
+* This routine sets up objective coefficients of the penalty function,
+* which is the sum of primal infeasibilities, as follows:
+*
+* if beta[i] < l[k] - eps1, set c[k] = -1,
+*
+* if beta[i] > u[k] + eps2, set c[k] = +1,
+*
+* otherwise, set c[k] = 0,
+*
+* where beta[i] is current value of basic variable xB[i] = x[k], l[k]
+* and u[k] are original bounds of x[k], and
+*
+* eps1 = tol + tol1 * |l[k]|,
+*
+* eps2 = tol + tol1 * |u[k]|.
+*
+* The routine returns the number of non-zero objective coefficients,
+* which is the number of basic variables violating their bounds. Thus,
+* if the value returned is zero, the current basis is primal feasible
+* within the specified tolerances. */
+
+static int set_penalty(struct csa *csa, double tol, double tol1)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *beta = csa->beta;
+ int i, k, count = 0;
+ double t, eps;
+ /* reset objective coefficients */
+ for (k = 0; k <= n; k++)
+ c[k] = 0.0;
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ /* check lower bound */
+ if ((t = l[k]) != -DBL_MAX)
+ { eps = tol + tol1 * (t >= 0.0 ? +t : -t);
+ if (beta[i] < t - eps)
+ { /* lower bound is violated */
+ c[k] = -1.0, count++;
+ }
+ }
+ /* check upper bound */
+ if ((t = u[k]) != +DBL_MAX)
+ { eps = tol + tol1 * (t >= 0.0 ? +t : -t);
+ if (beta[i] > t + eps)
+ { /* upper bound is violated */
+ c[k] = +1.0, count++;
+ }
+ }
+ }
+ return count;
+}
+
+/***********************************************************************
+* check_feas - check primal feasibility of basic solution
+*
+* This routine checks if the specified values of all basic variables
+* beta = (beta[i]) are within their bounds.
+*
+* Let l[k] and u[k] be original bounds of basic variable xB[i] = x[k].
+* The actual bounds of x[k] are determined as follows:
+*
+* 1) if phase = 1 and c[k] < 0, x[k] violates its lower bound, so its
+* actual bounds are artificial: -inf < x[k] <= l[k];
+*
+* 2) if phase = 1 and c[k] > 0, x[k] violates its upper bound, so its
+* actual bounds are artificial: u[k] <= x[k] < +inf;
+*
+* 3) in all other cases (if phase = 1 and c[k] = 0, or if phase = 2)
+* actual bounds are original: l[k] <= x[k] <= u[k].
+*
+* The parameters tol and tol1 are bound violation tolerances. The
+* actual bounds l'[k] and u'[k] are considered as non-violated within
+* the specified tolerance if
+*
+* l'[k] - eps1 <= beta[i] <= u'[k] + eps2,
+*
+* where eps1 = tol + tol1 * |l'[k]|, eps2 = tol + tol1 * |u'[k]|.
+*
+* The routine returns one of the following codes:
+*
+* 0 - solution is feasible (no actual bounds are violated);
+*
+* 1 - solution is infeasible, however, only artificial bounds are
+* violated (this is possible only if phase = 1);
+*
+* 2 - solution is infeasible and at least one original bound is
+* violated. */
+
+static int check_feas(struct csa *csa, int phase, double tol, double
+ tol1)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *beta = csa->beta;
+ int i, k, orig, ret = 0;
+ double lk, uk, eps;
+ xassert(phase == 1 || phase == 2);
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ /* determine actual bounds of x[k] */
+ if (phase == 1 && c[k] < 0.0)
+ { /* -inf < x[k] <= l[k] */
+ lk = -DBL_MAX, uk = l[k];
+ orig = 0; /* artificial bounds */
+ }
+ else if (phase == 1 && c[k] > 0.0)
+ { /* u[k] <= x[k] < +inf */
+ lk = u[k], uk = +DBL_MAX;
+ orig = 0; /* artificial bounds */
+ }
+ else
+ { /* l[k] <= x[k] <= u[k] */
+ lk = l[k], uk = u[k];
+ orig = 1; /* original bounds */
+ }
+ /* check actual lower bound */
+ if (lk != -DBL_MAX)
+ { eps = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] < lk - eps)
+ { /* actual lower bound is violated */
+ if (orig)
+ { ret = 2;
+ break;
+ }
+ ret = 1;
+ }
+ }
+ /* check actual upper bound */
+ if (uk != +DBL_MAX)
+ { eps = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] > uk + eps)
+ { /* actual upper bound is violated */
+ if (orig)
+ { ret = 2;
+ break;
+ }
+ ret = 1;
+ }
+ }
+ }
+ return ret;
+}
+
+/***********************************************************************
+* adjust_penalty - adjust penalty function coefficients
+*
+* On searching for primal feasible solution it may happen that some
+* basic variable xB[i] = x[k] has non-zero objective coefficient c[k]
+* indicating that xB[i] violates its lower (if c[k] < 0) or upper (if
+* c[k] > 0) original bound, but due to primal degenarcy the violation
+* is close to zero.
+*
+* This routine identifies such basic variables and sets objective
+* coefficients at these variables to zero that allows avoiding zero-
+* step simplex iterations.
+*
+* The parameters tol and tol1 are bound violation tolerances. The
+* original bounds l[k] and u[k] are considered as non-violated within
+* the specified tolerance if
+*
+* l[k] - eps1 <= beta[i] <= u[k] + eps2,
+*
+* where beta[i] is value of basic variable xB[i] = x[k] in the current
+* basis, eps1 = tol + tol1 * |l[k]|, eps2 = tol + tol1 * |u[k]|.
+*
+* The routine returns the number of objective coefficients which were
+* set to zero. */
+
+#if 0
+static int adjust_penalty(struct csa *csa, double tol, double tol1)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *beta = csa->beta;
+ int i, k, count = 0;
+ double t, eps;
+ xassert(csa->phase == 1);
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ if (c[k] < 0.0)
+ { /* x[k] violates its original lower bound l[k] */
+ xassert((t = l[k]) != -DBL_MAX);
+ eps = tol + tol1 * (t >= 0.0 ? +t : -t);
+ if (beta[i] >= t - eps)
+ { /* however, violation is close to zero */
+ c[k] = 0.0, count++;
+ }
+ }
+ else if (c[k] > 0.0)
+ { /* x[k] violates its original upper bound u[k] */
+ xassert((t = u[k]) != +DBL_MAX);
+ eps = tol + tol1 * (t >= 0.0 ? +t : -t);
+ if (beta[i] <= t + eps)
+ { /* however, violation is close to zero */
+ c[k] = 0.0, count++;
+ }
+ }
+ }
+ return count;
+}
+#else
+static int adjust_penalty(struct csa *csa, int num, const int
+ ind[/*1+num*/], double tol, double tol1)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *beta = csa->beta;
+ int i, k, t, cnt = 0;
+ double lk, uk, eps;
+ xassert(csa->phase == 1);
+ /* walk thru the specified list of basic variables */
+ for (t = 1; t <= num; t++)
+ { i = ind[t];
+ xassert(1 <= i && i <= m);
+ k = head[i]; /* x[k] = xB[i] */
+ if (c[k] < 0.0)
+ { /* x[k] violates its original lower bound */
+ lk = l[k];
+ xassert(lk != -DBL_MAX);
+ eps = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] >= lk - eps)
+ { /* however, violation is close to zero */
+ c[k] = 0.0, cnt++;
+ }
+ }
+ else if (c[k] > 0.0)
+ { /* x[k] violates its original upper bound */
+ uk = u[k];
+ xassert(uk != +DBL_MAX);
+ eps = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] <= uk + eps)
+ { /* however, violation is close to zero */
+ c[k] = 0.0, cnt++;
+ }
+ }
+ }
+ return cnt;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_vec - compute maximal relative error between two vectors
+*
+* This routine computes and returns maximal relative error between
+* n-vectors x and y:
+*
+* err_max = max |x[i] - y[i]| / (1 + |x[i]|).
+*
+* NOTE: This routine is intended only for debugginig purposes. */
+
+static double err_in_vec(int n, const double x[], const double y[])
+{ int i;
+ double err, err_max;
+ err_max = 0.0;
+ for (i = 1; i <= n; i++)
+ { err = fabs(x[i] - y[i]) / (1.0 + fabs(x[i]));
+ if (err_max < err)
+ err_max = err;
+ }
+ return err_max;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_beta - compute maximal relative error in vector beta
+*
+* This routine computes and returns maximal relative error in vector
+* of values of basic variables beta = (beta[i]).
+*
+* NOTE: This routine is intended only for debugginig purposes. */
+
+static double err_in_beta(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double err, *beta;
+ beta = talloc(1+m, double);
+ spx_eval_beta(lp, beta);
+ err = err_in_vec(m, beta, csa->beta);
+ tfree(beta);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_d - compute maximal relative error in vector d
+*
+* This routine computes and returns maximal relative error in vector
+* of reduced costs of non-basic variables d = (d[j]).
+*
+* NOTE: This routine is intended only for debugginig purposes. */
+
+static double err_in_d(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ int j;
+ double err, *pi, *d;
+ pi = talloc(1+m, double);
+ d = talloc(1+n-m, double);
+ spx_eval_pi(lp, pi);
+ for (j = 1; j <= n-m; j++)
+ d[j] = spx_eval_dj(lp, pi, j);
+ err = err_in_vec(n-m, d, csa->d);
+ tfree(pi);
+ tfree(d);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_gamma - compute maximal relative error in vector gamma
+*
+* This routine computes and returns maximal relative error in vector
+* of projected steepest edge weights gamma = (gamma[j]).
+*
+* NOTE: This routine is intended only for debugginig purposes. */
+
+static double err_in_gamma(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ SPXSE *se = csa->se;
+ int j;
+ double err, *gamma;
+ xassert(se != NULL);
+ gamma = talloc(1+n-m, double);
+ for (j = 1; j <= n-m; j++)
+ gamma[j] = spx_eval_gamma_j(lp, se, j);
+ err = err_in_vec(n-m, gamma, se->gamma);
+ tfree(gamma);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* check_accuracy - check accuracy of basic solution components
+*
+* This routine checks accuracy of current basic solution components.
+*
+* NOTE: This routine is intended only for debugginig purposes. */
+
+static void check_accuracy(struct csa *csa)
+{ double e_beta, e_d, e_gamma;
+ e_beta = err_in_beta(csa);
+ e_d = err_in_d(csa);
+ if (csa->se == NULL)
+ e_gamma = 0.;
+ else
+ e_gamma = err_in_gamma(csa);
+ xprintf("e_beta = %10.3e; e_d = %10.3e; e_gamma = %10.3e\n",
+ e_beta, e_d, e_gamma);
+ xassert(e_beta <= 1e-5 && e_d <= 1e-5 && e_gamma <= 1e-3);
+ return;
+}
+#endif
+
+/***********************************************************************
+* choose_pivot - choose xN[q] and xB[p]
+*
+* Given the list of eligible non-basic variables this routine first
+* chooses non-basic variable xN[q]. This choice is always possible,
+* because the list is assumed to be non-empty. Then the routine
+* computes q-th column T[*,q] of the simplex table T[i,j] and chooses
+* basic variable xB[p]. If the pivot T[p,q] is small in magnitude,
+* the routine attempts to choose another xN[q] and xB[p] in order to
+* avoid badly conditioned adjacent bases. */
+
+#if 1 /* 17/III-2016 */
+#define MIN_RATIO 0.0001
+
+static int choose_pivot(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *beta = csa->beta;
+ double *d = csa->d;
+ SPXSE *se = csa->se;
+ int *list = csa->list;
+#if 0 /* 09/VII-2017 */
+ double *tcol = csa->work;
+#else
+ double *tcol = csa->work.vec;
+#endif
+ double tol_piv = csa->tol_piv;
+ int try, nnn, /*i,*/ p, p_flag, q, t;
+ double big, /*temp,*/ best_ratio;
+#if 1 /* 23/VI-2017 */
+ double *c = lp->c;
+ int *head = lp->head;
+ SPXBP *bp = csa->bp;
+ int nbp, t_best, ret, k;
+ double dz_best;
+#endif
+ xassert(csa->beta_st);
+ xassert(csa->d_st);
+more: /* initial number of eligible non-basic variables */
+ nnn = csa->num;
+ /* nothing has been chosen so far */
+ csa->q = 0;
+ best_ratio = 0.0;
+#if 0 /* 23/VI-2017 */
+ try = 0;
+#else
+ try = ret = 0;
+#endif
+try: /* choose non-basic variable xN[q] */
+ xassert(nnn > 0);
+ try++;
+ if (se == NULL)
+ { /* Dantzig's rule */
+ q = spx_chuzc_std(lp, d, nnn, list);
+ }
+ else
+ { /* projected steepest edge */
+ q = spx_chuzc_pse(lp, se, d, nnn, list);
+ }
+ xassert(1 <= q && q <= n-m);
+ /* compute q-th column of the simplex table */
+ spx_eval_tcol(lp, q, tcol);
+#if 0
+ /* big := max(1, |tcol[1]|, ..., |tcol[m]|) */
+ big = 1.0;
+ for (i = 1; i <= m; i++)
+ { temp = tcol[i];
+ if (temp < 0.0)
+ temp = - temp;
+ if (big < temp)
+ big = temp;
+ }
+#else
+ /* this still puzzles me */
+ big = 1.0;
+#endif
+ /* choose basic variable xB[p] */
+#if 1 /* 23/VI-2017 */
+ if (csa->phase == 1 && csa->r_test == GLP_RT_FLIP && try <= 2)
+ { /* long-step ratio test */
+ int t, num, num1;
+ double slope, teta_lim;
+ /* determine penalty function break points */
+ nbp = spx_ls_eval_bp(lp, beta, q, d[q], tcol, tol_piv, bp);
+ if (nbp < 2)
+ goto skip;
+ /* set initial slope */
+ slope = - fabs(d[q]);
+ /* estimate initial teta_lim */
+ teta_lim = DBL_MAX;
+ for (t = 1; t <= nbp; t++)
+ { if (teta_lim > bp[t].teta)
+ teta_lim = bp[t].teta;
+ }
+ xassert(teta_lim >= 0.0);
+ if (teta_lim < 1e-3)
+ teta_lim = 1e-3;
+ /* nothing has been chosen so far */
+ t_best = 0, dz_best = 0.0, num = 0;
+ /* choose appropriate break point */
+ while (num < nbp)
+ { /* select and process a new portion of break points */
+ num1 = spx_ls_select_bp(lp, tcol, nbp, bp, num, &slope,
+ teta_lim);
+ for (t = num+1; t <= num1; t++)
+ { int i = (bp[t].i >= 0 ? bp[t].i : -bp[t].i);
+ xassert(0 <= i && i <= m);
+ if (i == 0 || fabs(tcol[i]) / big >= MIN_RATIO)
+ { if (dz_best > bp[t].dz)
+ t_best = t, dz_best = bp[t].dz;
+ }
+#if 0
+ if (i == 0)
+ { /* do not consider further break points beyond this
+ * point, where xN[q] reaches its opposite bound;
+ * in principle (see spx_ls_eval_bp), this break
+ * point should be the last one, however, due to
+ * round-off errors there may be other break points
+ * with the same teta beyond this one */
+ slope = +1.0;
+ }
+#endif
+ }
+ if (slope > 0.0)
+ { /* penalty function starts increasing */
+ break;
+ }
+ /* penalty function continues decreasing */
+ num = num1;
+ teta_lim += teta_lim;
+ }
+ if (dz_best == 0.0)
+ goto skip;
+ /* the choice has been made */
+ xassert(1 <= t_best && t_best <= num1);
+ if (t_best == 1)
+ { /* the very first break point was chosen; it is reasonable
+ * to use the short-step ratio test */
+ goto skip;
+ }
+ csa->q = q;
+ memcpy(&csa->tcol.vec[1], &tcol[1], m * sizeof(double));
+ fvs_gather_vec(&csa->tcol, DBL_EPSILON);
+ if (bp[t_best].i == 0)
+ { /* xN[q] goes to its opposite bound */
+ csa->p = -1;
+ csa->p_flag = 0;
+ best_ratio = 1.0;
+ }
+ else if (bp[t_best].i > 0)
+ { /* xB[p] leaves the basis and goes to its lower bound */
+ csa->p = + bp[t_best].i;
+ xassert(1 <= csa->p && csa->p <= m);
+ csa->p_flag = 0;
+ best_ratio = fabs(tcol[csa->p]) / big;
+ }
+ else
+ { /* xB[p] leaves the basis and goes to its upper bound */
+ csa->p = - bp[t_best].i;
+ xassert(1 <= csa->p && csa->p <= m);
+ csa->p_flag = 1;
+ best_ratio = fabs(tcol[csa->p]) / big;
+ }
+#if 0
+ xprintf("num1 = %d; t_best = %d; dz = %g\n", num1, t_best,
+ bp[t_best].dz);
+#endif
+ ret = 1;
+ goto done;
+skip: ;
+ }
+#endif
+#if 0 /* 23/VI-2017 */
+ if (!csa->harris)
+#else
+ if (csa->r_test == GLP_RT_STD)
+#endif
+ { /* textbook ratio test */
+ p = spx_chuzr_std(lp, csa->phase, beta, q,
+ d[q] < 0.0 ? +1. : -1., tcol, &p_flag, tol_piv,
+ .30 * csa->tol_bnd, .30 * csa->tol_bnd1);
+ }
+ else
+ { /* Harris' two-pass ratio test */
+ p = spx_chuzr_harris(lp, csa->phase, beta, q,
+ d[q] < 0.0 ? +1. : -1., tcol, &p_flag , tol_piv,
+ .50 * csa->tol_bnd, .50 * csa->tol_bnd1);
+ }
+ if (p <= 0)
+ { /* primal unboundedness or special case */
+ csa->q = q;
+#if 0 /* 11/VI-2017 */
+ memcpy(&csa->tcol[1], &tcol[1], m * sizeof(double));
+#else
+ memcpy(&csa->tcol.vec[1], &tcol[1], m * sizeof(double));
+ fvs_gather_vec(&csa->tcol, DBL_EPSILON);
+#endif
+ csa->p = p;
+ csa->p_flag = p_flag;
+ best_ratio = 1.0;
+ goto done;
+ }
+ /* either keep previous choice or accept new choice depending on
+ * which one is better */
+ if (best_ratio < fabs(tcol[p]) / big)
+ { csa->q = q;
+#if 0 /* 11/VI-2017 */
+ memcpy(&csa->tcol[1], &tcol[1], m * sizeof(double));
+#else
+ memcpy(&csa->tcol.vec[1], &tcol[1], m * sizeof(double));
+ fvs_gather_vec(&csa->tcol, DBL_EPSILON);
+#endif
+ csa->p = p;
+ csa->p_flag = p_flag;
+ best_ratio = fabs(tcol[p]) / big;
+ }
+ /* check if the current choice is acceptable */
+ if (best_ratio >= MIN_RATIO || nnn == 1 || try == 5)
+ goto done;
+ /* try to choose other xN[q] and xB[p] */
+ /* find xN[q] in the list */
+ for (t = 1; t <= nnn; t++)
+ if (list[t] == q) break;
+ xassert(t <= nnn);
+ /* move xN[q] to the end of the list */
+ list[t] = list[nnn], list[nnn] = q;
+ /* and exclude it from consideration */
+ nnn--;
+ /* repeat the choice */
+ goto try;
+done: /* the choice has been made */
+#if 1 /* FIXME: currently just to avoid badly conditioned basis */
+ if (best_ratio < .001 * MIN_RATIO)
+ { /* looks like this helps */
+ if (bfd_get_count(lp->bfd) > 0)
+ return -1;
+ /* didn't help; last chance to improve the choice */
+ if (tol_piv == csa->tol_piv)
+ { tol_piv *= 1000.;
+ goto more;
+ }
+ }
+#endif
+#if 0 /* 23/VI-2017 */
+ return 0;
+#else /* FIXME */
+ if (ret)
+ { /* invalidate dual basic solution components */
+ csa->d_st = 0;
+ /* change penalty function coefficients at basic variables for
+ * all break points preceding the chosen one */
+ for (t = 1; t < t_best; t++)
+ { int i = (bp[t].i >= 0 ? bp[t].i : -bp[t].i);
+ xassert(0 <= i && i <= m);
+ if (i == 0)
+ { /* xN[q] crosses its opposite bound */
+ xassert(1 <= csa->q && csa->q <= n-m);
+ k = head[m+csa->q];
+ }
+ else
+ { /* xB[i] crosses its (lower or upper) bound */
+ k = head[i]; /* x[k] = xB[i] */
+ }
+ c[k] += bp[t].dc;
+ xassert(c[k] == 0.0 || c[k] == +1.0 || c[k] == -1.0);
+ }
+ }
+ return ret;
+#endif
+}
+#endif
+
+/***********************************************************************
+* play_bounds - play bounds of primal variables
+*
+* This routine is called after the primal values of basic variables
+* beta[i] were updated and the basis was changed to the adjacent one.
+*
+* It is assumed that before updating all the primal values beta[i]
+* were strongly feasible, so in the adjacent basis beta[i] remain
+* feasible within a tolerance, i.e. if some beta[i] violates its lower
+* or upper bound, the violation is insignificant.
+*
+* If some beta[i] violates its lower or upper bound, this routine
+* changes (perturbs) the bound to remove such violation, i.e. to make
+* all beta[i] strongly feasible. Otherwise, if beta[i] has a feasible
+* value, this routine attempts to reduce (or remove) perturbation of
+* corresponding lower/upper bound keeping strong feasibility. */
+
+/* FIXME: what to do if l[k] = u[k]? */
+
+/* FIXME: reduce/remove perturbation if x[k] becomes non-basic? */
+
+static void play_bounds(struct csa *csa, int all)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *orig_l = csa->orig_l;
+ double *orig_u = csa->orig_u;
+ double *beta = csa->beta;
+#if 0 /* 11/VI-2017 */
+ const double *tcol = csa->tcol; /* was used to update beta */
+#else
+ const double *tcol = csa->tcol.vec;
+#endif
+ int i, k;
+ xassert(csa->phase == 1 || csa->phase == 2);
+ /* primal values beta = (beta[i]) should be valid */
+ xassert(csa->beta_st);
+ /* walk thru the list of basic variables xB = (xB[i]) */
+ for (i = 1; i <= m; i++)
+ { if (all || tcol[i] != 0.0)
+ { /* beta[i] has changed in the adjacent basis */
+ k = head[i]; /* x[k] = xB[i] */
+ if (csa->phase == 1 && c[k] < 0.0)
+ { /* -inf < xB[i] <= lB[i] (artificial bounds) */
+ if (beta[i] < l[k] - 1e-9)
+ continue;
+ /* restore actual bounds */
+ c[k] = 0.0;
+ csa->d_st = 0; /* since c[k] = cB[i] has changed */
+ }
+ if (csa->phase == 1 && c[k] > 0.0)
+ { /* uB[i] <= xB[i] < +inf (artificial bounds) */
+ if (beta[i] > u[k] + 1e-9)
+ continue;
+ /* restore actual bounds */
+ c[k] = 0.0;
+ csa->d_st = 0; /* since c[k] = cB[i] has changed */
+ }
+ /* lB[i] <= xB[i] <= uB[i] */
+ if (csa->phase == 1)
+ xassert(c[k] == 0.0);
+ if (l[k] != -DBL_MAX)
+ { /* xB[i] has lower bound */
+ if (beta[i] < l[k])
+ { /* strong feasibility means xB[i] >= lB[i] */
+#if 0 /* 11/VI-2017 */
+ l[k] = beta[i];
+#else
+ l[k] = beta[i] - 1e-9;
+#endif
+ }
+ else if (l[k] < orig_l[k])
+ { /* remove/reduce perturbation of lB[i] */
+ if (beta[i] >= orig_l[k])
+ l[k] = orig_l[k];
+ else
+ l[k] = beta[i];
+ }
+ }
+ if (u[k] != +DBL_MAX)
+ { /* xB[i] has upper bound */
+ if (beta[i] > u[k])
+ { /* strong feasibility means xB[i] <= uB[i] */
+#if 0 /* 11/VI-2017 */
+ u[k] = beta[i];
+#else
+ u[k] = beta[i] + 1e-9;
+#endif
+ }
+ else if (u[k] > orig_u[k])
+ { /* remove/reduce perturbation of uB[i] */
+ if (beta[i] <= orig_u[k])
+ u[k] = orig_u[k];
+ else
+ u[k] = beta[i];
+ }
+ }
+ }
+ }
+ return;
+}
+
+static void remove_perturb(struct csa *csa)
+{ /* remove perturbation */
+ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *orig_l = csa->orig_l;
+ double *orig_u = csa->orig_u;
+ int j, k;
+ /* restore original bounds of variables */
+ memcpy(l, orig_l, (1+n) * sizeof(double));
+ memcpy(u, orig_u, (1+n) * sizeof(double));
+ /* adjust flags of fixed non-basic variables, because in the
+ * perturbed problem such variables might be changed to double-
+ * bounded type */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == u[k])
+ flag[j] = 0;
+ }
+ /* removing perturbation changes primal solution components */
+ csa->phase = csa->beta_st = 0;
+#if 1
+ if (csa->msg_lev >= GLP_MSG_ALL)
+ xprintf("Removing LP perturbation [%d]...\n",
+ csa->it_cnt);
+#endif
+ return;
+}
+
+/***********************************************************************
+* sum_infeas - compute sum of primal infeasibilities
+*
+* This routine compute the sum of primal infeasibilities, which is the
+* current penalty function value. */
+
+static double sum_infeas(SPXLP *lp, const double beta[/*1+m*/])
+{ int m = lp->m;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, k;
+ double sum = 0.0;
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ if (l[k] != -DBL_MAX && beta[i] < l[k])
+ sum += l[k] - beta[i];
+ if (u[k] != +DBL_MAX && beta[i] > u[k])
+ sum += beta[i] - u[k];
+ }
+ return sum;
+}
+
+/***********************************************************************
+* display - display search progress
+*
+* This routine displays some information about the search progress
+* that includes:
+*
+* search phase;
+*
+* number of simplex iterations performed by the solver;
+*
+* original objective value;
+*
+* sum of (scaled) primal infeasibilities;
+*
+* number of infeasibilities (phase I) or non-optimalities (phase II);
+*
+* number of basic factorizations since last display output. */
+
+static void display(struct csa *csa, int spec)
+{ int nnn, k;
+ double obj, sum, *save, *save1;
+#if 1 /* 15/VII-2017 */
+ double tm_cur;
+#endif
+ /* check if the display output should be skipped */
+ if (csa->msg_lev < GLP_MSG_ON) goto skip;
+#if 1 /* 15/VII-2017 */
+ tm_cur = xtime();
+#endif
+ if (csa->out_dly > 0 &&
+#if 0 /* 15/VII-2017 */
+ 1000.0 * xdifftime(xtime(), csa->tm_beg) < csa->out_dly)
+#else
+ 1000.0 * xdifftime(tm_cur, csa->tm_beg) < csa->out_dly)
+#endif
+ goto skip;
+ if (csa->it_cnt == csa->it_dpy) goto skip;
+#if 0 /* 15/VII-2017 */
+ if (!spec && csa->it_cnt % csa->out_frq != 0) goto skip;
+#else
+ if (!spec &&
+ 1000.0 * xdifftime(tm_cur, csa->tm_dpy) < csa->out_frq)
+ goto skip;
+#endif
+ /* compute original objective value */
+ save = csa->lp->c;
+ csa->lp->c = csa->orig_c;
+ obj = csa->dir * spx_eval_obj(csa->lp, csa->beta);
+ csa->lp->c = save;
+#if SCALE_Z
+ obj *= csa->fz;
+#endif
+ /* compute sum of (scaled) primal infeasibilities */
+#if 1 /* 01/VII-2017 */
+ save = csa->lp->l;
+ save1 = csa->lp->u;
+ csa->lp->l = csa->orig_l;
+ csa->lp->u = csa->orig_u;
+#endif
+ sum = sum_infeas(csa->lp, csa->beta);
+#if 1 /* 01/VII-2017 */
+ csa->lp->l = save;
+ csa->lp->u = save1;
+#endif
+ /* compute number of infeasibilities/non-optimalities */
+ switch (csa->phase)
+ { case 1:
+ nnn = 0;
+ for (k = 1; k <= csa->lp->n; k++)
+ if (csa->lp->c[k] != 0.0) nnn++;
+ break;
+ case 2:
+ xassert(csa->d_st);
+ nnn = spx_chuzc_sel(csa->lp, csa->d, csa->tol_dj,
+ csa->tol_dj1, NULL);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ /* display search progress */
+ xprintf("%c%6d: obj = %17.9e inf = %11.3e (%d)",
+ csa->phase == 2 ? '*' : ' ', csa->it_cnt, obj, sum, nnn);
+ if (csa->inv_cnt)
+ { /* number of basis factorizations performed */
+ xprintf(" %d", csa->inv_cnt);
+ csa->inv_cnt = 0;
+ }
+#if 1 /* 23/VI-2017 */
+ if (csa->phase == 1 && csa->r_test == GLP_RT_FLIP)
+ { /*xprintf(" %d,%d", csa->ns_cnt, csa->ls_cnt);*/
+ if (csa->ns_cnt + csa->ls_cnt)
+ xprintf(" %d%%",
+ (100 * csa->ls_cnt) / (csa->ns_cnt + csa->ls_cnt));
+ csa->ns_cnt = csa->ls_cnt = 0;
+ }
+#endif
+ xprintf("\n");
+ csa->it_dpy = csa->it_cnt;
+#if 1 /* 15/VII-2017 */
+ csa->tm_dpy = tm_cur;
+#endif
+skip: return;
+}
+
+/***********************************************************************
+* spx_primal - driver to the primal simplex method
+*
+* This routine is a driver to the two-phase primal simplex method.
+*
+* On exit this routine returns one of the following codes:
+*
+* 0 LP instance has been successfully solved.
+*
+* GLP_EITLIM
+* Iteration limit has been exhausted.
+*
+* GLP_ETMLIM
+* Time limit has been exhausted.
+*
+* GLP_EFAIL
+* The solver failed to solve LP instance. */
+
+static int primal_simplex(struct csa *csa)
+{ /* primal simplex method main logic routine */
+ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ int *head = lp->head;
+ SPXAT *at = csa->at;
+ SPXNT *nt = csa->nt;
+ double *beta = csa->beta;
+ double *d = csa->d;
+ SPXSE *se = csa->se;
+ int *list = csa->list;
+#if 0 /* 11/VI-2017 */
+ double *tcol = csa->tcol;
+ double *trow = csa->trow;
+#endif
+#if 0 /* 09/VII-2017 */
+ double *pi = csa->work;
+ double *rho = csa->work;
+#else
+ double *pi = csa->work.vec;
+ double *rho = csa->work.vec;
+#endif
+ int msg_lev = csa->msg_lev;
+ double tol_bnd = csa->tol_bnd;
+ double tol_bnd1 = csa->tol_bnd1;
+ double tol_dj = csa->tol_dj;
+ double tol_dj1 = csa->tol_dj1;
+ int perturb = -1;
+ /* -1 = perturbation is not used, but enabled
+ * 0 = perturbation is not used and disabled
+ * +1 = perturbation is being used */
+ int j, refct, ret;
+loop: /* main loop starts here */
+ /* compute factorization of the basis matrix */
+ if (!lp->valid)
+ { double cond;
+ ret = spx_factorize(lp);
+ csa->inv_cnt++;
+ if (ret != 0)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: unable to factorize the basis matrix (%d"
+ ")\n", ret);
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+ /* check condition of the basis matrix */
+ cond = bfd_condest(lp->bfd);
+ if (cond > 1.0 / DBL_EPSILON)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: basis matrix is singular to working prec"
+ "ision (cond = %.3g)\n", cond);
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+ if (cond > 0.001 / DBL_EPSILON)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: basis matrix is ill-conditioned (cond "
+ "= %.3g)\n", cond);
+ }
+ /* invalidate basic solution components */
+ csa->beta_st = csa->d_st = 0;
+ }
+ /* compute values of basic variables beta = (beta[i]) */
+ if (!csa->beta_st)
+ { spx_eval_beta(lp, beta);
+ csa->beta_st = 1; /* just computed */
+ /* determine the search phase, if not determined yet */
+ if (!csa->phase)
+ { if (set_penalty(csa, 0.97 * tol_bnd, 0.97 * tol_bnd1))
+ { /* current basic solution is primal infeasible */
+ /* start to minimize the sum of infeasibilities */
+ csa->phase = 1;
+ }
+ else
+ { /* current basic solution is primal feasible */
+ /* start to minimize the original objective function */
+ csa->phase = 2;
+ memcpy(c, csa->orig_c, (1+n) * sizeof(double));
+ }
+ /* working objective coefficients have been changed, so
+ * invalidate reduced costs */
+ csa->d_st = 0;
+ }
+ /* make sure that the current basic solution remains primal
+ * feasible (or pseudo-feasible on phase I) */
+ if (perturb <= 0)
+ { if (check_feas(csa, csa->phase, tol_bnd, tol_bnd1))
+ { /* excessive bound violations due to round-off errors */
+#if 1 /* 01/VII-2017 */
+ if (perturb < 0)
+ { if (msg_lev >= GLP_MSG_ALL)
+ xprintf("Perturbing LP to avoid instability [%d].."
+ ".\n", csa->it_cnt);
+ perturb = 1;
+ goto loop;
+ }
+#endif
+ if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: numerical instability (primal simpl"
+ "ex, phase %s)\n", csa->phase == 1 ? "I" : "II");
+ /* restart the search */
+ lp->valid = 0;
+ csa->phase = 0;
+ goto loop;
+ }
+ if (csa->phase == 1)
+ { int i, cnt;
+ for (i = 1; i <= m; i++)
+ csa->tcol.ind[i] = i;
+ cnt = adjust_penalty(csa, m, csa->tcol.ind,
+ 0.99 * tol_bnd, 0.99 * tol_bnd1);
+ if (cnt)
+ { /*xprintf("*** cnt = %d\n", cnt);*/
+ csa->d_st = 0;
+ }
+ }
+ }
+ else
+ { /* FIXME */
+ play_bounds(csa, 1);
+ }
+ }
+ /* at this point the search phase is determined */
+ xassert(csa->phase == 1 || csa->phase == 2);
+ /* compute reduced costs of non-basic variables d = (d[j]) */
+ if (!csa->d_st)
+ { spx_eval_pi(lp, pi);
+ for (j = 1; j <= n-m; j++)
+ d[j] = spx_eval_dj(lp, pi, j);
+ csa->d_st = 1; /* just computed */
+ }
+ /* reset the reference space, if necessary */
+ if (se != NULL && !se->valid)
+ spx_reset_refsp(lp, se), refct = 1000;
+ /* at this point the basis factorization and all basic solution
+ * components are valid */
+ xassert(lp->valid && csa->beta_st && csa->d_st);
+#if CHECK_ACCURACY
+ /* check accuracy of current basic solution components (only for
+ * debugging) */
+ check_accuracy(csa);
+#endif
+ /* check if the iteration limit has been exhausted */
+ if (csa->it_cnt - csa->it_beg >= csa->it_lim)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("ITERATION LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ csa->p_stat = (csa->phase == 2 ? GLP_FEAS : GLP_INFEAS);
+ csa->d_stat = GLP_UNDEF; /* will be set below */
+ ret = GLP_EITLIM;
+ goto fini;
+ }
+ /* check if the time limit has been exhausted */
+ if (1000.0 * xdifftime(xtime(), csa->tm_beg) >= csa->tm_lim)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("TIME LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ csa->p_stat = (csa->phase == 2 ? GLP_FEAS : GLP_INFEAS);
+ csa->d_stat = GLP_UNDEF; /* will be set below */
+ ret = GLP_ETMLIM;
+ goto fini;
+ }
+ /* display the search progress */
+ display(csa, 0);
+ /* select eligible non-basic variables */
+ switch (csa->phase)
+ { case 1:
+ csa->num = spx_chuzc_sel(lp, d, 1e-8, 0.0, list);
+ break;
+ case 2:
+ csa->num = spx_chuzc_sel(lp, d, tol_dj, tol_dj1, list);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ /* check for optimality */
+ if (csa->num == 0)
+ { if (perturb > 0 && csa->phase == 2)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ /* current basis is optimal */
+ display(csa, 1);
+ switch (csa->phase)
+ { case 1:
+ /* check for primal feasibility */
+ if (!check_feas(csa, 2, tol_bnd, tol_bnd1))
+ { /* feasible solution found; switch to phase II */
+ memcpy(c, csa->orig_c, (1+n) * sizeof(double));
+ csa->phase = 2;
+ csa->d_st = 0;
+ goto loop;
+ }
+ /* no feasible solution exists */
+#if 1 /* 09/VII-2017 */
+ /* FIXME: remove perturbation */
+#endif
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("LP HAS NO PRIMAL FEASIBLE SOLUTION\n");
+ csa->p_stat = GLP_NOFEAS;
+ csa->d_stat = GLP_UNDEF; /* will be set below */
+ ret = 0;
+ goto fini;
+ case 2:
+ /* optimal solution found */
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("OPTIMAL LP SOLUTION FOUND\n");
+ csa->p_stat = csa->d_stat = GLP_FEAS;
+ ret = 0;
+ goto fini;
+ default:
+ xassert(csa != csa);
+ }
+ }
+ /* choose xN[q] and xB[p] */
+#if 0 /* 23/VI-2017 */
+#if 0 /* 17/III-2016 */
+ choose_pivot(csa);
+#else
+ if (choose_pivot(csa) < 0)
+ { lp->valid = 0;
+ goto loop;
+ }
+#endif
+#else
+ ret = choose_pivot(csa);
+ if (ret < 0)
+ { lp->valid = 0;
+ goto loop;
+ }
+ if (ret == 0)
+ csa->ns_cnt++;
+ else
+ csa->ls_cnt++;
+#endif
+ /* check for unboundedness */
+ if (csa->p == 0)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ switch (csa->phase)
+ { case 1:
+ /* this should never happen */
+ if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: primal simplex failed\n");
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ case 2:
+ /* primal unboundedness detected */
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("LP HAS UNBOUNDED PRIMAL SOLUTION\n");
+ csa->p_stat = GLP_FEAS;
+ csa->d_stat = GLP_NOFEAS;
+ ret = 0;
+ goto fini;
+ default:
+ xassert(csa != csa);
+ }
+ }
+#if 1 /* 01/VII-2017 */
+ /* check for stalling */
+ if (csa->p > 0)
+ { int k;
+ xassert(1 <= csa->p && csa->p <= m);
+ k = head[csa->p]; /* x[k] = xB[p] */
+ if (lp->l[k] != lp->u[k])
+ { if (csa->p_flag)
+ { /* xB[p] goes to its upper bound */
+ xassert(lp->u[k] != +DBL_MAX);
+ if (fabs(beta[csa->p] - lp->u[k]) >= 1e-6)
+ { csa->degen = 0;
+ goto skip1;
+ }
+ }
+ else if (lp->l[k] == -DBL_MAX)
+ { /* unusual case */
+ goto skip1;
+ }
+ else
+ { /* xB[p] goes to its lower bound */
+ xassert(lp->l[k] != -DBL_MAX);
+ if (fabs(beta[csa->p] - lp->l[k]) >= 1e-6)
+ { csa->degen = 0;
+ goto skip1;
+ }
+ }
+ /* degenerate iteration has been detected */
+ csa->degen++;
+ if (perturb < 0 && csa->degen >= 200)
+ { if (msg_lev >= GLP_MSG_ALL)
+ xprintf("Perturbing LP to avoid stalling [%d]...\n",
+ csa->it_cnt);
+ perturb = 1;
+ }
+skip1: ;
+ }
+ }
+#endif
+ /* update values of basic variables for adjacent basis */
+#if 0 /* 11/VI-2017 */
+ spx_update_beta(lp, beta, csa->p, csa->p_flag, csa->q, tcol);
+#else
+ spx_update_beta_s(lp, beta, csa->p, csa->p_flag, csa->q,
+ &csa->tcol);
+#endif
+ csa->beta_st = 2;
+ /* p < 0 means that xN[q] jumps to its opposite bound */
+ if (csa->p < 0)
+ goto skip;
+ /* xN[q] enters and xB[p] leaves the basis */
+ /* compute p-th row of inv(B) */
+ spx_eval_rho(lp, csa->p, rho);
+ /* compute p-th (pivot) row of the simplex table */
+#if 0 /* 11/VI-2017 */
+ if (at != NULL)
+ spx_eval_trow1(lp, at, rho, trow);
+ else
+ spx_nt_prod(lp, nt, trow, 1, -1.0, rho);
+#else
+ if (at != NULL)
+ spx_eval_trow1(lp, at, rho, csa->trow.vec);
+ else
+ spx_nt_prod(lp, nt, csa->trow.vec, 1, -1.0, rho);
+ fvs_gather_vec(&csa->trow, DBL_EPSILON);
+#endif
+ /* FIXME: tcol[p] and trow[q] should be close to each other */
+#if 0 /* 26/V-2017 by cmatraki */
+ xassert(trow[csa->q] != 0.0);
+#else
+ if (csa->trow.vec[csa->q] == 0.0)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: trow[q] = 0.0\n");
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+#endif
+ /* update reduced costs of non-basic variables for adjacent
+ * basis */
+#if 1 /* 23/VI-2017 */
+ /* dual solution may be invalidated due to long step */
+ if (csa->d_st)
+#endif
+#if 0 /* 11/VI-2017 */
+ if (spx_update_d(lp, d, csa->p, csa->q, trow, tcol) <= 1e-9)
+#else
+ if (spx_update_d_s(lp, d, csa->p, csa->q, &csa->trow, &csa->tcol)
+ <= 1e-9)
+#endif
+ { /* successful updating */
+ csa->d_st = 2;
+ if (csa->phase == 1)
+ { /* adjust reduced cost of xN[q] in adjacent basis, since
+ * its penalty coefficient changes (see below) */
+ d[csa->q] -= c[head[csa->p]];
+ }
+ }
+ else
+ { /* new reduced costs are inaccurate */
+ csa->d_st = 0;
+ }
+ if (csa->phase == 1)
+ { /* xB[p] leaves the basis replacing xN[q], so set its penalty
+ * coefficient to zero */
+ c[head[csa->p]] = 0.0;
+ }
+ /* update steepest edge weights for adjacent basis, if used */
+ if (se != NULL)
+ { if (refct > 0)
+#if 0 /* 11/VI-2017 */
+ { if (spx_update_gamma(lp, se, csa->p, csa->q, trow, tcol)
+ <= 1e-3)
+#else /* FIXME: spx_update_gamma_s */
+ { if (spx_update_gamma(lp, se, csa->p, csa->q, csa->trow.vec,
+ csa->tcol.vec) <= 1e-3)
+#endif
+ { /* successful updating */
+ refct--;
+ }
+ else
+ { /* new weights are inaccurate; reset reference space */
+ se->valid = 0;
+ }
+ }
+ else
+ { /* too many updates; reset reference space */
+ se->valid = 0;
+ }
+ }
+ /* update matrix N for adjacent basis, if used */
+ if (nt != NULL)
+ spx_update_nt(lp, nt, csa->p, csa->q);
+skip: /* change current basis header to adjacent one */
+ spx_change_basis(lp, csa->p, csa->p_flag, csa->q);
+ /* and update factorization of the basis matrix */
+ if (csa->p > 0)
+ spx_update_invb(lp, csa->p, head[csa->p]);
+#if 1
+ if (perturb <= 0)
+ { if (csa->phase == 1)
+ { int cnt;
+ /* adjust penalty function coefficients */
+ cnt = adjust_penalty(csa, csa->tcol.nnz, csa->tcol.ind,
+ 0.99 * tol_bnd, 0.99 * tol_bnd1);
+ if (cnt)
+ { /* some coefficients were changed, so invalidate reduced
+ * costs of non-basic variables */
+ /*xprintf("... cnt = %d\n", cnt);*/
+ csa->d_st = 0;
+ }
+ }
+ }
+ else
+ { /* FIXME */
+ play_bounds(csa, 0);
+ }
+#endif
+ /* simplex iteration complete */
+ csa->it_cnt++;
+ goto loop;
+fini: /* restore original objective function */
+ memcpy(c, csa->orig_c, (1+n) * sizeof(double));
+ /* compute reduced costs of non-basic variables and determine
+ * solution dual status, if necessary */
+ if (csa->p_stat != GLP_UNDEF && csa->d_stat == GLP_UNDEF)
+ { xassert(ret != GLP_EFAIL);
+ spx_eval_pi(lp, pi);
+ for (j = 1; j <= n-m; j++)
+ d[j] = spx_eval_dj(lp, pi, j);
+ csa->num = spx_chuzc_sel(lp, d, tol_dj, tol_dj1, NULL);
+ csa->d_stat = (csa->num == 0 ? GLP_FEAS : GLP_INFEAS);
+ }
+ return ret;
+}
+
+int spx_primal(glp_prob *P, const glp_smcp *parm)
+{ /* driver to the primal simplex method */
+ struct csa csa_, *csa = &csa_;
+ SPXLP lp;
+ SPXAT at;
+ SPXNT nt;
+ SPXSE se;
+ int ret, *map, *daeh;
+#if SCALE_Z
+ int i, j, k;
+#endif
+ /* build working LP and its initial basis */
+ memset(csa, 0, sizeof(struct csa));
+ csa->lp = &lp;
+ spx_init_lp(csa->lp, P, parm->excl);
+ spx_alloc_lp(csa->lp);
+ map = talloc(1+P->m+P->n, int);
+ spx_build_lp(csa->lp, P, parm->excl, parm->shift, map);
+ spx_build_basis(csa->lp, P, map);
+ switch (P->dir)
+ { case GLP_MIN:
+ csa->dir = +1;
+ break;
+ case GLP_MAX:
+ csa->dir = -1;
+ break;
+ default:
+ xassert(P != P);
+ }
+#if SCALE_Z
+ csa->fz = 0.0;
+ for (k = 1; k <= csa->lp->n; k++)
+ { double t = fabs(csa->lp->c[k]);
+ if (csa->fz < t)
+ csa->fz = t;
+ }
+ if (csa->fz <= 1000.0)
+ csa->fz = 1.0;
+ else
+ csa->fz /= 1000.0;
+ /*xprintf("csa->fz = %g\n", csa->fz);*/
+ for (k = 0; k <= csa->lp->n; k++)
+ csa->lp->c[k] /= csa->fz;
+#endif
+ csa->orig_c = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_c, csa->lp->c, (1+csa->lp->n) * sizeof(double));
+#if 1 /*PERTURB*/
+ csa->orig_l = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_l, csa->lp->l, (1+csa->lp->n) * sizeof(double));
+ csa->orig_u = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_u, csa->lp->u, (1+csa->lp->n) * sizeof(double));
+#else
+ csa->orig_l = csa->orig_u = NULL;
+#endif
+ switch (parm->aorn)
+ { case GLP_USE_AT:
+ /* build matrix A in row-wise format */
+ csa->at = &at;
+ csa->nt = NULL;
+ spx_alloc_at(csa->lp, csa->at);
+ spx_build_at(csa->lp, csa->at);
+ break;
+ case GLP_USE_NT:
+ /* build matrix N in row-wise format for initial basis */
+ csa->at = NULL;
+ csa->nt = &nt;
+ spx_alloc_nt(csa->lp, csa->nt);
+ spx_init_nt(csa->lp, csa->nt);
+ spx_build_nt(csa->lp, csa->nt);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+ /* allocate and initialize working components */
+ csa->phase = 0;
+ csa->beta = talloc(1+csa->lp->m, double);
+ csa->beta_st = 0;
+ csa->d = talloc(1+csa->lp->n-csa->lp->m, double);
+ csa->d_st = 0;
+ switch (parm->pricing)
+ { case GLP_PT_STD:
+ csa->se = NULL;
+ break;
+ case GLP_PT_PSE:
+ csa->se = &se;
+ spx_alloc_se(csa->lp, csa->se);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+ csa->list = talloc(1+csa->lp->n-csa->lp->m, int);
+#if 0 /* 11/VI-2017 */
+ csa->tcol = talloc(1+csa->lp->m, double);
+ csa->trow = talloc(1+csa->lp->n-csa->lp->m, double);
+#else
+ fvs_alloc_vec(&csa->tcol, csa->lp->m);
+ fvs_alloc_vec(&csa->trow, csa->lp->n-csa->lp->m);
+#endif
+#if 1 /* 23/VI-2017 */
+ csa->bp = NULL;
+#endif
+#if 0 /* 09/VII-2017 */
+ csa->work = talloc(1+csa->lp->m, double);
+#else
+ fvs_alloc_vec(&csa->work, csa->lp->m);
+#endif
+ /* initialize control parameters */
+ csa->msg_lev = parm->msg_lev;
+#if 0 /* 23/VI-2017 */
+ switch (parm->r_test)
+ { case GLP_RT_STD:
+ csa->harris = 0;
+ break;
+ case GLP_RT_HAR:
+#if 1 /* 16/III-2016 */
+ case GLP_RT_FLIP:
+ /* FIXME */
+ /* currently for primal simplex GLP_RT_FLIP is equivalent
+ * to GLP_RT_HAR */
+#endif
+ csa->harris = 1;
+ break;
+ default:
+ xassert(parm != parm);
+ }
+#else
+ switch (parm->r_test)
+ { case GLP_RT_STD:
+ case GLP_RT_HAR:
+ break;
+ case GLP_RT_FLIP:
+ csa->bp = talloc(1+2*csa->lp->m+1, SPXBP);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+ csa->r_test = parm->r_test;
+#endif
+ csa->tol_bnd = parm->tol_bnd;
+ csa->tol_bnd1 = .001 * parm->tol_bnd;
+ csa->tol_dj = parm->tol_dj;
+ csa->tol_dj1 = .001 * parm->tol_dj;
+ csa->tol_piv = parm->tol_piv;
+ csa->it_lim = parm->it_lim;
+ csa->tm_lim = parm->tm_lim;
+ csa->out_frq = parm->out_frq;
+ csa->out_dly = parm->out_dly;
+ /* initialize working parameters */
+ csa->tm_beg = xtime();
+ csa->it_beg = csa->it_cnt = P->it_cnt;
+ csa->it_dpy = -1;
+#if 1 /* 15/VII-2017 */
+ csa->tm_dpy = 0.0;
+#endif
+ csa->inv_cnt = 0;
+#if 1 /* 01/VII-2017 */
+ csa->degen = 0;
+#endif
+#if 1 /* 23/VI-2017 */
+ csa->ns_cnt = csa->ls_cnt = 0;
+#endif
+ /* try to solve working LP */
+ ret = primal_simplex(csa);
+ /* return basis factorization back to problem object */
+ P->valid = csa->lp->valid;
+ P->bfd = csa->lp->bfd;
+ /* set solution status */
+ P->pbs_stat = csa->p_stat;
+ P->dbs_stat = csa->d_stat;
+ /* if the solver failed, do not store basis header and basic
+ * solution components to problem object */
+ if (ret == GLP_EFAIL)
+ goto skip;
+ /* convert working LP basis to original LP basis and store it to
+ * problem object */
+ daeh = talloc(1+csa->lp->n, int);
+ spx_store_basis(csa->lp, P, map, daeh);
+ /* compute simplex multipliers for final basic solution found by
+ * the solver */
+#if 0 /* 09/VII-2017 */
+ spx_eval_pi(csa->lp, csa->work);
+#else
+ spx_eval_pi(csa->lp, csa->work.vec);
+#endif
+ /* convert working LP solution to original LP solution and store
+ * it into the problem object */
+#if SCALE_Z
+ for (i = 1; i <= csa->lp->m; i++)
+ csa->work.vec[i] *= csa->fz;
+ for (j = 1; j <= csa->lp->n-csa->lp->m; j++)
+ csa->d[j] *= csa->fz;
+#endif
+#if 0 /* 09/VII-2017 */
+ spx_store_sol(csa->lp, P, SHIFT, map, daeh, csa->beta, csa->work,
+ csa->d);
+#else
+ spx_store_sol(csa->lp, P, parm->shift, map, daeh, csa->beta,
+ csa->work.vec, csa->d);
+#endif
+ tfree(daeh);
+ /* save simplex iteration count */
+ P->it_cnt = csa->it_cnt;
+ /* report auxiliary/structural variable causing unboundedness */
+ P->some = 0;
+ if (csa->p_stat == GLP_FEAS && csa->d_stat == GLP_NOFEAS)
+ { int k, kk;
+ /* xN[q] = x[k] causes unboundedness */
+ xassert(1 <= csa->q && csa->q <= csa->lp->n - csa->lp->m);
+ k = csa->lp->head[csa->lp->m + csa->q];
+ xassert(1 <= k && k <= csa->lp->n);
+ /* convert to number of original variable */
+ for (kk = 1; kk <= P->m + P->n; kk++)
+ { if (abs(map[kk]) == k)
+ { P->some = kk;
+ break;
+ }
+ }
+ xassert(P->some != 0);
+ }
+skip: /* deallocate working objects and arrays */
+ spx_free_lp(csa->lp);
+ tfree(map);
+ tfree(csa->orig_c);
+#if 1 /*PERTURB*/
+ tfree(csa->orig_l);
+ tfree(csa->orig_u);
+#endif
+ if (csa->at != NULL)
+ spx_free_at(csa->lp, csa->at);
+ if (csa->nt != NULL)
+ spx_free_nt(csa->lp, csa->nt);
+ tfree(csa->beta);
+ tfree(csa->d);
+ if (csa->se != NULL)
+ spx_free_se(csa->lp, csa->se);
+ tfree(csa->list);
+#if 0 /* 11/VI-2017 */
+ tfree(csa->tcol);
+ tfree(csa->trow);
+#else
+ fvs_free_vec(&csa->tcol);
+ fvs_free_vec(&csa->trow);
+#endif
+#if 1 /* 23/VI-2017 */
+ if (csa->bp != NULL)
+ tfree(csa->bp);
+#endif
+#if 0 /* 09/VII-2017 */
+ tfree(csa->work);
+#else
+ fvs_free_vec(&csa->work);
+#endif
+ /* return to calling program */
+ return ret;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxprob.c b/test/monniaux/glpk-4.65/src/simplex/spxprob.c
new file mode 100644
index 00000000..4bebe2e7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxprob.c
@@ -0,0 +1,679 @@
+/* spxprob.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spxprob.h"
+
+/***********************************************************************
+* spx_init_lp - initialize working LP object
+*
+* This routine determines the number of equality constraints m, the
+* number of variables n, and the number of non-zero elements nnz in
+* the constraint matrix for the working LP, which corresponds to the
+* original LP, and stores these dimensions to the working LP object.
+* (The working LP object should be allocated by the calling routine.)
+*
+* If the flag excl is set, the routine assumes that non-basic fixed
+* variables will be excluded from the working LP. */
+
+void spx_init_lp(SPXLP *lp, glp_prob *P, int excl)
+{ int i, j, m, n, nnz;
+ m = P->m;
+ xassert(m > 0);
+ n = 0;
+ nnz = P->nnz;
+ xassert(P->valid);
+ /* scan rows of original LP */
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = P->row[i];
+ if (excl && row->stat == GLP_NS)
+ { /* skip non-basic fixed auxiliary variable */
+ /* nop */
+ }
+ else
+ { /* include auxiliary variable in working LP */
+ n++;
+ nnz++; /* unity column */
+ }
+ }
+ /* scan columns of original LP */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if (excl && col->stat == GLP_NS)
+ { /* skip non-basic fixed structural variable */
+ GLPAIJ *aij;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ nnz--;
+ }
+ else
+ { /* include structural variable in working LP */
+ n++;
+ }
+ }
+ /* initialize working LP data block */
+ memset(lp, 0, sizeof(SPXLP));
+ lp->m = m;
+ xassert(n > 0);
+ lp->n = n;
+ lp->nnz = nnz;
+ return;
+}
+
+/***********************************************************************
+* spx_alloc_lp - allocate working LP arrays
+*
+* This routine allocates the memory for all arrays in the working LP
+* object. */
+
+void spx_alloc_lp(SPXLP *lp)
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ lp->A_ptr = talloc(1+n+1, int);
+ lp->A_ind = talloc(1+nnz, int);
+ lp->A_val = talloc(1+nnz, double);
+ lp->b = talloc(1+m, double);
+ lp->c = talloc(1+n, double);
+ lp->l = talloc(1+n, double);
+ lp->u = talloc(1+n, double);
+ lp->head = talloc(1+n, int);
+ lp->flag = talloc(1+n-m, char);
+ return;
+}
+
+/***********************************************************************
+* spx_build_lp - convert original LP to working LP
+*
+* This routine converts components (except the current basis) of the
+* original LP to components of the working LP and perform scaling of
+* these components. Also, if the original LP is maximization, the
+* routine changes the signs of the objective coefficients and constant
+* term to opposite ones.
+*
+* If the flag excl is set, original non-basic fixed variables are
+* *not* included in the working LP. Otherwise, all (auxiliary and
+* structural) original variables are included in the working LP. Note
+* that this flag should have the same value as it has in a call to the
+* routine spx_init_lp.
+*
+* If the flag shift is set, the routine shift bounds of variables
+* included in the working LP to make at least one bound to be zero.
+* If a variable has both lower and upper bounds, the bound having
+* smaller magnitude is shifted to zero.
+*
+* On exit the routine stores information about correspondence between
+* numbers of variables in the original and working LPs to the array
+* map, which should have 1+P->m+P->n locations (location [0] is not
+* used), where P->m is the numbers of rows and P->n is the number of
+* columns in the original LP:
+*
+* map[i] = +k, 1 <= i <= P->m, means that i-th auxiliary variable of
+* the original LP corresponds to variable x[k] of the working LP;
+*
+* map[i] = -k, 1 <= i <= P->m, means that i-th auxiliary variable of
+* the original LP corresponds to variable x[k] of the working LP, and
+* the upper bound of that variable was shifted to zero;
+*
+* map[i] = 0, 1 <= i <= P->m, means that i-th auxiliary variable of
+* the original LP was excluded from the working LP;
+*
+* map[P->m+j], 1 <= j <= P->n, has the same sense as above, however,
+* for j-th structural variable of the original LP. */
+
+void spx_build_lp(SPXLP *lp, glp_prob *P, int excl, int shift,
+ int map[/*1+P->m+P->n*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int nnz = lp->nnz;
+ int *A_ptr = lp->A_ptr;
+ int *A_ind = lp->A_ind;
+ double *A_val = lp->A_val;
+ double *b = lp->b;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int i, j, k, kk, ptr, end;
+ double dir, delta;
+ /* working LP is always minimization */
+ switch (P->dir)
+ { case GLP_MIN:
+ dir = +1.0;
+ break;
+ case GLP_MAX:
+ dir = -1.0;
+ break;
+ default:
+ xassert(P != P);
+ }
+ /* initialize constant term of the objective */
+ c[0] = dir * P->c0;
+ k = 0; /* number of variable in working LP */
+ ptr = 1; /* current available position in A_ind/A_val */
+ /* process rows of original LP */
+ xassert(P->m == m);
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = P->row[i];
+ if (excl && row->stat == GLP_NS)
+ { /* i-th auxiliary variable is non-basic and fixed */
+ /* substitute its scaled value in working LP */
+ xassert(row->type == GLP_FX);
+ map[i] = 0;
+ b[i] = - row->lb * row->rii;
+ }
+ else
+ { /* include i-th auxiliary variable in working LP */
+ map[i] = ++k;
+ /* setup k-th column of working constraint matrix which is
+ * i-th column of unity matrix */
+ A_ptr[k] = ptr;
+ A_ind[ptr] = i;
+ A_val[ptr] = 1.0;
+ ptr++;
+ /* initialize right-hand side of i-th equality constraint
+ * and setup zero objective coefficient at variable x[k] */
+ b[i] = c[k] = 0.0;
+ /* setup scaled bounds of variable x[k] */
+ switch (row->type)
+ { case GLP_FR:
+ l[k] = -DBL_MAX, u[k] = +DBL_MAX;
+ break;
+ case GLP_LO:
+ l[k] = row->lb * row->rii, u[k] = +DBL_MAX;
+ break;
+ case GLP_UP:
+ l[k] = -DBL_MAX, u[k] = row->ub * row->rii;
+ break;
+ case GLP_DB:
+ l[k] = row->lb * row->rii, u[k] = row->ub * row->rii;
+ xassert(l[k] != u[k]);
+ break;
+ case GLP_FX:
+ l[k] = u[k] = row->lb * row->rii;
+ break;
+ default:
+ xassert(row != row);
+ }
+ }
+ }
+ /* process columns of original LP */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ GLPAIJ *aij;
+ if (excl && col->stat == GLP_NS)
+ { /* j-th structural variable is non-basic and fixed */
+ /* substitute its scaled value in working LP */
+ xassert(col->type == GLP_FX);
+ map[m+j] = 0;
+ if (col->lb != 0.0)
+ { /* (note that sjj scale factor is cancelled) */
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ b[aij->row->i] +=
+ (aij->row->rii * aij->val) * col->lb;
+ c[0] += (dir * col->coef) * col->lb;
+ }
+ }
+ else
+ { /* include j-th structural variable in working LP */
+ map[m+j] = ++k;
+ /* setup k-th column of working constraint matrix which is
+ * scaled j-th column of original constraint matrix (-A) */
+ A_ptr[k] = ptr;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ { A_ind[ptr] = aij->row->i;
+ A_val[ptr] = - aij->row->rii * aij->val * col->sjj;
+ ptr++;
+ }
+ /* setup scaled objective coefficient at variable x[k] */
+ c[k] = dir * col->coef * col->sjj;
+ /* setup scaled bounds of variable x[k] */
+ switch (col->type)
+ { case GLP_FR:
+ l[k] = -DBL_MAX, u[k] = +DBL_MAX;
+ break;
+ case GLP_LO:
+ l[k] = col->lb / col->sjj, u[k] = +DBL_MAX;
+ break;
+ case GLP_UP:
+ l[k] = -DBL_MAX, u[k] = col->ub / col->sjj;
+ break;
+ case GLP_DB:
+ l[k] = col->lb / col->sjj, u[k] = col->ub / col->sjj;
+ xassert(l[k] != u[k]);
+ break;
+ case GLP_FX:
+ l[k] = u[k] = col->lb / col->sjj;
+ break;
+ default:
+ xassert(col != col);
+ }
+ }
+ }
+ xassert(k == n);
+ xassert(ptr == nnz+1);
+ A_ptr[n+1] = ptr;
+ /* shift bounds of all variables of working LP (optionally) */
+ if (shift)
+ { for (kk = 1; kk <= m+P->n; kk++)
+ { k = map[kk];
+ if (k == 0)
+ { /* corresponding original variable was excluded */
+ continue;
+ }
+ /* shift bounds of variable x[k] */
+ if (l[k] == -DBL_MAX && u[k] == +DBL_MAX)
+ { /* x[k] is unbounded variable */
+ delta = 0.0;
+ }
+ else if (l[k] != -DBL_MAX && u[k] == +DBL_MAX)
+ { /* shift lower bound to zero */
+ delta = l[k];
+ l[k] = 0.0;
+ }
+ else if (l[k] == -DBL_MAX && u[k] != +DBL_MAX)
+ { /* shift upper bound to zero */
+ map[kk] = -k;
+ delta = u[k];
+ u[k] = 0.0;
+ }
+ else if (l[k] != u[k])
+ { /* x[k] is double bounded variable */
+ if (fabs(l[k]) <= fabs(u[k]))
+ { /* shift lower bound to zero */
+ delta = l[k];
+ l[k] = 0.0, u[k] -= delta;
+ }
+ else
+ { /* shift upper bound to zero */
+ map[kk] = -k;
+ delta = u[k];
+ l[k] -= delta, u[k] = 0.0;
+ }
+ xassert(l[k] != u[k]);
+ }
+ else
+ { /* shift fixed value to zero */
+ delta = l[k];
+ l[k] = u[k] = 0.0;
+ }
+ /* substitute x[k] = x'[k] + delta into all constraints
+ * and the objective function of working LP */
+ if (delta != 0.0)
+ { ptr = A_ptr[k];
+ end = A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ b[A_ind[ptr]] -= A_val[ptr] * delta;
+ c[0] += c[k] * delta;
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_build_basis - convert original LP basis to working LP basis
+*
+* This routine converts the current basis of the original LP to
+* corresponding initial basis of the working LP, and moves the basis
+* factorization driver from the original LP object to the working LP
+* object.
+*
+* The array map should contain information provided by the routine
+* spx_build_lp. */
+
+void spx_build_basis(SPXLP *lp, glp_prob *P, const int map[])
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int i, j, k, ii, jj;
+ /* original basis factorization should be valid that guarantees
+ * the basis is correct */
+ xassert(P->m == m);
+ xassert(P->valid);
+ /* initialize basis header for working LP */
+ memset(&head[1], 0, m * sizeof(int));
+ jj = 0;
+ /* scan rows of original LP */
+ xassert(P->m == m);
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = P->row[i];
+ /* determine ordinal number of x[k] in working LP */
+ if ((k = map[i]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* corresponding original variable was excluded */
+ continue;
+ }
+ xassert(1 <= k && k <= n);
+ if (row->stat == GLP_BS)
+ { /* x[k] is basic variable xB[ii] */
+ ii = row->bind;
+ xassert(1 <= ii && ii <= m);
+ xassert(head[ii] == 0);
+ head[ii] = k;
+ }
+ else
+ { /* x[k] is non-basic variable xN[jj] */
+ jj++;
+ head[m+jj] = k;
+ flag[jj] = (row->stat == GLP_NU);
+ }
+ }
+ /* scan columns of original LP */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ /* determine ordinal number of x[k] in working LP */
+ if ((k = map[m+j]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* corresponding original variable was excluded */
+ continue;
+ }
+ xassert(1 <= k && k <= n);
+ if (col->stat == GLP_BS)
+ { /* x[k] is basic variable xB[ii] */
+ ii = col->bind;
+ xassert(1 <= ii && ii <= m);
+ xassert(head[ii] == 0);
+ head[ii] = k;
+ }
+ else
+ { /* x[k] is non-basic variable xN[jj] */
+ jj++;
+ head[m+jj] = k;
+ flag[jj] = (col->stat == GLP_NU);
+ }
+ }
+ xassert(m+jj == n);
+ /* acquire basis factorization */
+ lp->valid = 1;
+ lp->bfd = P->bfd;
+ P->valid = 0;
+ P->bfd = NULL;
+ return;
+}
+
+/***********************************************************************
+* spx_store_basis - convert working LP basis to original LP basis
+*
+* This routine converts the current working LP basis to corresponding
+* original LP basis. This operations includes determining and setting
+* statuses of all rows (auxiliary variables) and columns (structural
+* variables), and building the basis header.
+*
+* The array map should contain information provided by the routine
+* spx_build_lp.
+*
+* On exit the routine fills the array daeh. This array should have
+* 1+lp->n locations (location [0] is not used) and contain the inverse
+* of the working basis header lp->head, i.e. head[k'] = k means that
+* daeh[k] = k'. */
+
+void spx_store_basis(SPXLP *lp, glp_prob *P, const int map[],
+ int daeh[/*1+n*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int i, j, k, kk;
+ /* determine inverse of working basis header */
+ for (kk = 1; kk <= n; kk++)
+ daeh[head[kk]] = kk;
+ /* set row statuses */
+ xassert(P->m == m);
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = P->row[i];
+ if ((k = map[i]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* non-basic fixed auxiliary variable was excluded */
+ xassert(row->type == GLP_FX);
+ row->stat = GLP_NS;
+ row->bind = 0;
+ }
+ else
+ { /* auxiliary variable corresponds to variable x[k] */
+ kk = daeh[k];
+ if (kk <= m)
+ { /* x[k] = xB[kk] */
+ P->head[kk] = i;
+ row->stat = GLP_BS;
+ row->bind = kk;
+ }
+ else
+ { /* x[k] = xN[kk-m] */
+ switch (row->type)
+ { case GLP_FR:
+ row->stat = GLP_NF;
+ break;
+ case GLP_LO:
+ row->stat = GLP_NL;
+ break;
+ case GLP_UP:
+ row->stat = GLP_NU;
+ break;
+ case GLP_DB:
+ row->stat = (flag[kk-m] ? GLP_NU : GLP_NL);
+ break;
+ case GLP_FX:
+ row->stat = GLP_NS;
+ break;
+ default:
+ xassert(row != row);
+ }
+ row->bind = 0;
+ }
+ }
+ }
+ /* set column statuses */
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if ((k = map[m+j]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* non-basic fixed structural variable was excluded */
+ xassert(col->type == GLP_FX);
+ col->stat = GLP_NS;
+ col->bind = 0;
+ }
+ else
+ { /* structural variable corresponds to variable x[k] */
+ kk = daeh[k];
+ if (kk <= m)
+ { /* x[k] = xB[kk] */
+ P->head[kk] = m+j;
+ col->stat = GLP_BS;
+ col->bind = kk;
+ }
+ else
+ { /* x[k] = xN[kk-m] */
+ switch (col->type)
+ { case GLP_FR:
+ col->stat = GLP_NF;
+ break;
+ case GLP_LO:
+ col->stat = GLP_NL;
+ break;
+ case GLP_UP:
+ col->stat = GLP_NU;
+ break;
+ case GLP_DB:
+ col->stat = (flag[kk-m] ? GLP_NU : GLP_NL);
+ break;
+ case GLP_FX:
+ col->stat = GLP_NS;
+ break;
+ default:
+ xassert(col != col);
+ }
+ col->bind = 0;
+ }
+ }
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_store_sol - convert working LP solution to original LP solution
+*
+* This routine converts the current basic solution of the working LP
+* (values of basic variables, simplex multipliers, reduced costs of
+* non-basic variables) to corresponding basic solution of the original
+* LP (values and reduced costs of auxiliary and structural variables).
+* This conversion includes unscaling all basic solution components,
+* computing reduced costs of excluded non-basic variables, recovering
+* unshifted values of basic variables, changing the signs of reduced
+* costs (if the original LP is maximization), and computing the value
+* of the objective function.
+*
+* The flag shift should have the same value as it has in a call to the
+* routine spx_build_lp.
+*
+* The array map should contain information provided by the routine
+* spx_build_lp.
+*
+* The array daeh should contain information provided by the routine
+* spx_store_basis.
+*
+* The arrays beta, pi, and d should contain basic solution components
+* for the working LP:
+*
+* array locations beta[1], ..., beta[m] should contain values of basic
+* variables beta = (beta[i]);
+*
+* array locations pi[1], ..., pi[m] should contain simplex multipliers
+* pi = (pi[i]);
+*
+* array locations d[1], ..., d[n-m] should contain reduced costs of
+* non-basic variables d = (d[j]). */
+
+void spx_store_sol(SPXLP *lp, glp_prob *P, int shift,
+ const int map[], const int daeh[], const double beta[],
+ const double pi[], const double d[])
+{ int m = lp->m;
+ char *flag = lp->flag;
+ int i, j, k, kk;
+ double dir;
+ /* working LP is always minimization */
+ switch (P->dir)
+ { case GLP_MIN:
+ dir = +1.0;
+ break;
+ case GLP_MAX:
+ dir = -1.0;
+ break;
+ default:
+ xassert(P != P);
+ }
+ /* compute row solution components */
+ xassert(P->m == m);
+ for (i = 1; i <= m; i++)
+ { GLPROW *row = P->row[i];
+ if ((k = map[i]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* non-basic fixed auxiliary variable was excluded */
+ xassert(row->type == GLP_FX);
+ row->prim = row->lb;
+ /* compute reduced cost d[k] = c[k] - A'[k] * pi as if x[k]
+ * would be non-basic in working LP */
+ row->dual = - dir * pi[i] * row->rii;
+ }
+ else
+ { /* auxiliary variable corresponds to variable x[k] */
+ kk = daeh[k];
+ if (kk <= m)
+ { /* x[k] = xB[kk] */
+ row->prim = beta[kk] / row->rii;
+ if (shift)
+ row->prim += (map[i] < 0 ? row->ub : row->lb);
+ row->dual = 0.0;
+ }
+ else
+ { /* x[k] = xN[kk-m] */
+ row->prim = (flag[kk-m] ? row->ub : row->lb);
+ row->dual = (dir * d[kk-m]) * row->rii;
+ }
+ }
+ }
+ /* compute column solution components and objective value */
+ P->obj_val = P->c0;
+ for (j = 1; j <= P->n; j++)
+ { GLPCOL *col = P->col[j];
+ if ((k = map[m+j]) < 0)
+ k = -k;
+ if (k == 0)
+ { /* non-basic fixed structural variable was excluded */
+ GLPAIJ *aij;
+ double dk;
+ xassert(col->type == GLP_FX);
+ col->prim = col->lb;
+ /* compute reduced cost d[k] = c[k] - A'[k] * pi as if x[k]
+ * would be non-basic in working LP */
+ /* (note that sjj scale factor is cancelled) */
+ dk = dir * col->coef;
+ for (aij = col->ptr; aij != NULL; aij = aij->c_next)
+ dk += (aij->row->rii * aij->val) * pi[aij->row->i];
+ col->dual = dir * dk;
+ }
+ else
+ { /* structural variable corresponds to variable x[k] */
+ kk = daeh[k];
+ if (kk <= m)
+ { /* x[k] = xB[kk] */
+ col->prim = beta[kk] * col->sjj;
+ if (shift)
+ col->prim += (map[m+j] < 0 ? col->ub : col->lb);
+ col->dual = 0.0;
+ }
+ else
+ { /* x[k] = xN[kk-m] */
+ col->prim = (flag[kk-m] ? col->ub : col->lb);
+ col->dual = (dir * d[kk-m]) / col->sjj;
+ }
+ }
+ P->obj_val += col->coef * col->prim;
+ }
+ return;
+}
+
+/***********************************************************************
+* spx_free_lp - deallocate working LP arrays
+*
+* This routine deallocates the memory used for arrays of the working
+* LP object. */
+
+void spx_free_lp(SPXLP *lp)
+{ tfree(lp->A_ptr);
+ tfree(lp->A_ind);
+ tfree(lp->A_val);
+ tfree(lp->b);
+ tfree(lp->c);
+ tfree(lp->l);
+ tfree(lp->u);
+ tfree(lp->head);
+ tfree(lp->flag);
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spxprob.h b/test/monniaux/glpk-4.65/src/simplex/spxprob.h
new file mode 100644
index 00000000..b7d87fa7
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spxprob.h
@@ -0,0 +1,64 @@
+/* spxprob.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPXPROB_H
+#define SPXPROB_H
+
+#include "prob.h"
+#include "spxlp.h"
+
+#define spx_init_lp _glp_spx_init_lp
+void spx_init_lp(SPXLP *lp, glp_prob *P, int excl);
+/* initialize working LP object */
+
+#define spx_alloc_lp _glp_spx_alloc_lp
+void spx_alloc_lp(SPXLP *lp);
+/* allocate working LP arrays */
+
+#define spx_build_lp _glp_spx_build_lp
+void spx_build_lp(SPXLP *lp, glp_prob *P, int excl, int shift,
+ int map[/*1+P->m+P->n*/]);
+/* convert original LP to working LP */
+
+#define spx_build_basis _glp_spx_build_basis
+void spx_build_basis(SPXLP *lp, glp_prob *P, const int map[]);
+/* convert original LP basis to working LP basis */
+
+#define spx_store_basis _glp_spx_store_basis
+void spx_store_basis(SPXLP *lp, glp_prob *P, const int map[],
+ int daeh[/*1+n*/]);
+/* convert working LP basis to original LP basis */
+
+#define spx_store_sol _glp_spx_store_sol
+void spx_store_sol(SPXLP *lp, glp_prob *P, int shift,
+ const int map[], const int daeh[], const double beta[],
+ const double pi[], const double d[]);
+/* convert working LP solution to original LP solution */
+
+#define spx_free_lp _glp_spx_free_lp
+void spx_free_lp(SPXLP *lp);
+/* deallocate working LP arrays */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spychuzc.c b/test/monniaux/glpk-4.65/src/simplex/spychuzc.c
new file mode 100644
index 00000000..b9221298
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spychuzc.c
@@ -0,0 +1,567 @@
+/* spychuzc.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2018 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spychuzc.h"
+
+/***********************************************************************
+* spy_chuzc_std - choose non-basic variable (dual textbook ratio test)
+*
+* This routine implements an improved dual textbook ratio test to
+* choose non-basic variable xN[q].
+*
+* Current reduced costs of non-basic variables should be placed in the
+* array locations d[1], ..., d[n-m]. Note that d[j] is a value of dual
+* basic variable lambdaN[j] in the current basis.
+*
+#if 0 (* 14/III-2016 *)
+* The parameter s specifies the sign of bound violation for basic
+* variable xB[p] chosen: s = +1.0 means that xB[p] violates its lower
+* bound, so dual non-basic variable lambdaB[p] = lambda^+B[p]
+* increases, and s = -1.0 means that xB[p] violates its upper bound,
+* so dual non-basic variable lambdaB[p] = lambda^-B[p] decreases.
+* (Thus, the dual ray parameter theta = s * lambdaB[p] >= 0.)
+#else
+* The parameter r specifies the bound violation for basic variable
+* xB[p] chosen:
+*
+* r = lB[p] - beta[p] > 0 means that xB[p] violates its lower bound,
+* so dual non-basic variable lambdaB[p] = lambda^+B[p] increases; and
+*
+* r = uB[p] - beta[p] < 0 means that xB[p] violates its upper bound,
+* so dual non-basic variable lambdaB[p] = lambda^-B[p] decreases.
+*
+* (Note that r is the dual reduced cost of lambdaB[p].)
+#endif
+*
+* Elements of p-th simplex table row t[p] = (t[p,j]) corresponding
+* to basic variable xB[p] should be placed in the array locations
+* trow[1], ..., trow[n-m].
+*
+* The parameter tol_piv specifies a tolerance for elements of the
+* simplex table row t[p]. If |t[p,j]| < tol_piv, dual basic variable
+* lambdaN[j] is skipped, i.e. it is assumed that it does not depend on
+* the dual ray parameter theta.
+*
+* The parameters tol and tol1 specify tolerances used to increase the
+* choice freedom by simulating an artificial degeneracy as follows.
+* If lambdaN[j] = lambda^+N[j] >= 0 and d[j] <= +delta[j], or if
+* lambdaN[j] = lambda^-N[j] <= 0 and d[j] >= -delta[j], where
+* delta[j] = tol + tol1 * |cN[j]|, cN[j] is objective coefficient at
+* xN[j], then it is assumed that reduced cost d[j] is equal to zero.
+*
+* The routine determines the index 1 <= q <= n-m of non-basic variable
+* xN[q], for which corresponding dual basic variable lambda^+N[j] or
+* lambda^-N[j] reaches its zero bound first on increasing the dual ray
+* parameter theta, and returns p on exit. And if theta may increase
+* unlimitedly, the routine returns zero. */
+
+int spy_chuzc_std(SPXLP *lp, const double d[/*1+n-m*/],
+#if 0 /* 14/III-2016 */
+ double s, const double trow[/*1+n-m*/], double tol_piv,
+#else
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+#endif
+ double tol, double tol1)
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k, q;
+ double alfa, biga, delta, teta, teta_min;
+#if 0 /* 14/III-2016 */
+ xassert(s == +1.0 || s == -1.0);
+#else
+ double s;
+ xassert(r != 0.0);
+ s = (r > 0.0 ? +1.0 : -1.0);
+#endif
+ /* nothing is chosen so far */
+ q = 0, teta_min = DBL_MAX, biga = 0.0;
+ /* walk thru the list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* if xN[j] is fixed variable, skip it */
+ if (l[k] == u[k])
+ continue;
+ alfa = s * trow[j];
+ if (alfa >= +tol_piv && !flag[j])
+ { /* xN[j] is either free or has its lower bound active, so
+ * lambdaN[j] = d[j] >= 0 decreases down to zero */
+ delta = tol + tol1 * (c[k] >= 0.0 ? +c[k] : -c[k]);
+ /* determine theta on which lambdaN[j] reaches zero */
+ teta = (d[j] < +delta ? 0.0 : d[j] / alfa);
+ }
+ else if (alfa <= -tol_piv && (l[k] == -DBL_MAX || flag[j]))
+ { /* xN[j] is either free or has its upper bound active, so
+ * lambdaN[j] = d[j] <= 0 increases up to zero */
+ delta = tol + tol1 * (c[k] >= 0.0 ? +c[k] : -c[k]);
+ /* determine theta on which lambdaN[j] reaches zero */
+ teta = (d[j] > -delta ? 0.0 : d[j] / alfa);
+ }
+ else
+ { /* lambdaN[j] cannot reach zero on increasing theta */
+ continue;
+ }
+ /* choose non-basic variable xN[q] by corresponding dual basic
+ * variable lambdaN[q] for which theta is minimal */
+ xassert(teta >= 0.0);
+ alfa = (alfa >= 0.0 ? +alfa : -alfa);
+ if (teta_min > teta || (teta_min == teta && biga < alfa))
+ q = j, teta_min = teta, biga = alfa;
+ }
+ return q;
+}
+
+/***********************************************************************
+* spy_chuzc_harris - choose non-basic var. (dual Harris' ratio test)
+*
+* This routine implements dual Harris' ratio test to choose non-basic
+* variable xN[q].
+*
+* All the parameters, except tol and tol1, as well as the returned
+* value have the same meaning as for the routine spx_chuzr_std (see
+* above).
+*
+* The parameters tol and tol1 specify tolerances on zero bound
+* violations for reduced costs of non-basic variables. For reduced
+* cost d[j] the tolerance is delta[j] = tol + tol1 |cN[j]|, where
+* cN[j] is objective coefficient at non-basic variable xN[j]. */
+
+int spy_chuzc_harris(SPXLP *lp, const double d[/*1+n-m*/],
+#if 0 /* 14/III-2016 */
+ double s, const double trow[/*1+n-m*/], double tol_piv,
+#else
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+#endif
+ double tol, double tol1)
+{ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k, q;
+ double alfa, biga, delta, teta, teta_min;
+#if 0 /* 14/III-2016 */
+ xassert(s == +1.0 || s == -1.0);
+#else
+ double s;
+ xassert(r != 0.0);
+ s = (r > 0.0 ? +1.0 : -1.0);
+#endif
+ /*--------------------------------------------------------------*/
+ /* first pass: determine teta_min for relaxed bounds */
+ /*--------------------------------------------------------------*/
+ teta_min = DBL_MAX;
+ /* walk thru the list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* if xN[j] is fixed variable, skip it */
+ if (l[k] == u[k])
+ continue;
+ alfa = s * trow[j];
+ if (alfa >= +tol_piv && !flag[j])
+ { /* xN[j] is either free or has its lower bound active, so
+ * lambdaN[j] = d[j] >= 0 decreases down to zero */
+ delta = tol + tol1 * (c[k] >= 0.0 ? +c[k] : -c[k]);
+ /* determine theta on which lambdaN[j] reaches -delta */
+ teta = ((d[j] < 0.0 ? 0.0 : d[j]) + delta) / alfa;
+ }
+ else if (alfa <= -tol_piv && (l[k] == -DBL_MAX || flag[j]))
+ { /* xN[j] is either free or has its upper bound active, so
+ * lambdaN[j] = d[j] <= 0 increases up to zero */
+ delta = tol + tol1 * (c[k] >= 0.0 ? +c[k] : -c[k]);
+ /* determine theta on which lambdaN[j] reaches +delta */
+ teta = ((d[j] > 0.0 ? 0.0 : d[j]) - delta) / alfa;
+ }
+ else
+ { /* lambdaN[j] cannot reach zero on increasing theta */
+ continue;
+ }
+ xassert(teta >= 0.0);
+ if (teta_min > teta)
+ teta_min = teta;
+ }
+ /*--------------------------------------------------------------*/
+ /* second pass: choose non-basic variable xN[q] */
+ /*--------------------------------------------------------------*/
+ if (teta_min == DBL_MAX)
+ { /* theta may increase unlimitedly */
+ q = 0;
+ goto done;
+ }
+ /* nothing is chosen so far */
+ q = 0, biga = 0.0;
+ /* walk thru the list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* if xN[j] is fixed variable, skip it */
+ if (l[k] == u[k])
+ continue;
+ alfa = s * trow[j];
+ if (alfa >= +tol_piv && !flag[j])
+ { /* xN[j] is either free or has its lower bound active, so
+ * lambdaN[j] = d[j] >= 0 decreases down to zero */
+ /* determine theta on which lambdaN[j] reaches zero */
+ teta = d[j] / alfa;
+ }
+ else if (alfa <= -tol_piv && (l[k] == -DBL_MAX || flag[j]))
+ { /* xN[j] is either free or has its upper bound active, so
+ * lambdaN[j] = d[j] <= 0 increases up to zero */
+ /* determine theta on which lambdaN[j] reaches zero */
+ teta = d[j] / alfa;
+ }
+ else
+ { /* lambdaN[j] cannot reach zero on increasing theta */
+ continue;
+ }
+ /* choose non-basic variable for which theta is not greater
+ * than theta_min determined for relaxed bounds and which has
+ * best (largest in magnitude) pivot */
+ alfa = (alfa >= 0.0 ? +alfa : -alfa);
+ if (teta <= teta_min && biga < alfa)
+ q = j, biga = alfa;
+ }
+ /* something must be chosen */
+ xassert(1 <= q && q <= n-m);
+done: return q;
+}
+
+#if 0 /* 23/III-2016 */
+/***********************************************************************
+* spy_eval_bp - determine dual objective function break-points
+*
+* This routine determines the dual objective function break-points.
+*
+* The parameters lp, d, r, trow, and tol_piv have the same meaning as
+* for the routine spx_chuzc_std (see above).
+*
+* On exit the routine stores the break-points determined to the array
+* elements bp[1], ..., bp[num], where 0 <= num <= n-m is the number of
+* break-points returned by the routine.
+*
+* The break-points stored in the array bp are ordered by ascending
+* the ray parameter teta >= 0. The break-points numbered 1, ..., num-1
+* always correspond to non-basic non-fixed variables xN[j] of primal
+* LP having both lower and upper bounds while the last break-point
+* numbered num may correspond to a non-basic variable having only one
+* lower or upper bound, if such variable prevents further increasing
+* of the ray parameter teta. Besides, the routine includes in the
+* array bp only the break-points that correspond to positive increment
+* of the dual objective. */
+
+static int CDECL fcmp(const void *v1, const void *v2)
+{ const SPYBP *p1 = v1, *p2 = v2;
+ if (p1->teta < p2->teta)
+ return -1;
+ else if (p1->teta > p2->teta)
+ return +1;
+ else
+ return 0;
+}
+
+int spy_eval_bp(SPXLP *lp, const double d[/*1+n-m*/],
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+ SPYBP bp[/*1+n-m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, j_max, k, t, nnn, num;
+ double s, alfa, teta, teta_max, dz, v;
+ xassert(r != 0.0);
+ s = (r > 0.0 ? +1.0 : -1.0);
+ /* build the list of all dual basic variables lambdaN[j] that
+ * can reach zero on increasing the ray parameter teta >= 0 */
+ num = 0;
+ /* walk thru the list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* if xN[j] is fixed variable, skip it */
+ if (l[k] == u[k])
+ continue;
+ alfa = s * trow[j];
+ if (alfa >= +tol_piv && !flag[j])
+ { /* xN[j] is either free or has its lower bound active, so
+ * lambdaN[j] = d[j] >= 0 decreases down to zero */
+ /* determine teta[j] on which lambdaN[j] reaches zero */
+ teta = (d[j] < 0.0 ? 0.0 : d[j] / alfa);
+ }
+ else if (alfa <= -tol_piv && (l[k] == -DBL_MAX || flag[j]))
+ { /* xN[j] is either free or has its upper bound active, so
+ * lambdaN[j] = d[j] <= 0 increases up to zero */
+ /* determine teta[j] on which lambdaN[j] reaches zero */
+ teta = (d[j] > 0.0 ? 0.0 : d[j] / alfa);
+ }
+ else
+ { /* lambdaN[j] cannot reach zero on increasing teta */
+ continue;
+ }
+ /* add lambdaN[j] to the list */
+ num++;
+ bp[num].j = j;
+ bp[num].teta = teta;
+ }
+ if (num == 0)
+ { /* dual unboundedness */
+ goto done;
+ }
+ /* determine "blocking" dual basic variable lambdaN[j_max] that
+ * prevents increasing teta more than teta_max */
+ j_max = 0, teta_max = DBL_MAX;
+ for (t = 1; t <= num; t++)
+ { j = bp[t].j;
+ k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == -DBL_MAX || u[k] == +DBL_MAX)
+ { /* lambdaN[j] cannot intersect zero */
+ if (j_max == 0
+ || teta_max > bp[t].teta
+ || (teta_max == bp[t].teta
+ && fabs(trow[j_max]) < fabs(trow[j])))
+ j_max = j, teta_max = bp[t].teta;
+ }
+ }
+ /* keep in the list only dual basic variables lambdaN[j] that
+ * correspond to primal double-bounded variables xN[j] and whose
+ * teta[j] is not greater than teta_max */
+ nnn = 0;
+ for (t = 1; t <= num; t++)
+ { j = bp[t].j;
+ k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] != -DBL_MAX && u[k] != +DBL_MAX
+ && bp[t].teta <= teta_max)
+ { nnn++;
+ bp[nnn].j = j;
+ bp[nnn].teta = bp[t].teta;
+ }
+ }
+ num = nnn;
+ /* sort break-points by ascending teta[j] */
+ qsort(&bp[1], num, sizeof(SPYBP), fcmp);
+ /* add lambdaN[j_max] to the end of the list */
+ if (j_max != 0)
+ { xassert(num < n-m);
+ num++;
+ bp[num].j = j_max;
+ bp[num].teta = teta_max;
+ }
+ /* compute increments of the dual objective at all break-points
+ * (relative to its value at teta = 0) */
+ dz = 0.0; /* dual objective increment */
+ v = fabs(r); /* dual objective slope d zeta / d teta */
+ for (t = 1; t <= num; t++)
+ { /* compute increment at current break-point */
+ dz += v * (bp[t].teta - (t == 1 ? 0.0 : bp[t-1].teta));
+ if (dz < 0.001)
+ { /* break-point with non-positive increment reached */
+ num = t - 1;
+ break;
+ }
+ bp[t].dz = dz;
+ /* compute next slope on the right to current break-point */
+ if (t < num)
+ { j = bp[t].j;
+ k = head[m+j]; /* x[k] = xN[j] */
+ xassert(-DBL_MAX < l[k] && l[k] < u[k] && u[k] < +DBL_MAX);
+ v -= fabs(trow[j]) * (u[k] - l[k]);
+ }
+ }
+done: return num;
+}
+#endif
+
+/***********************************************************************
+* spy_ls_eval_bp - determine dual objective function break-points
+*
+* This routine determines the dual objective function break-points.
+*
+* The parameters lp, d, r, trow, and tol_piv have the same meaning as
+* for the routine spx_chuzc_std (see above).
+*
+* The routine stores the break-points determined to the array elements
+* bp[1], ..., bp[nbp] in *arbitrary* order, where 0 <= nbp <= n-m is
+* the number of break-points returned by the routine on exit. */
+
+int spy_ls_eval_bp(SPXLP *lp, const double d[/*1+n-m*/],
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+ SPYBP bp[/*1+n-m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k, t, nnn, nbp;
+ double s, alfa, teta, teta_max;
+ xassert(r != 0.0);
+ s = (r > 0.0 ? +1.0 : -1.0);
+ /* build the list of all dual basic variables lambdaN[j] that
+ * can reach zero on increasing the ray parameter teta >= 0 */
+ nnn = 0, teta_max = DBL_MAX;
+ /* walk thru the list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ /* if xN[j] is fixed variable, skip it */
+ if (l[k] == u[k])
+ continue;
+ alfa = s * trow[j];
+ if (alfa >= +tol_piv && !flag[j])
+ { /* xN[j] is either free or has its lower bound active, so
+ * lambdaN[j] = d[j] >= 0 decreases down to zero */
+ /* determine teta[j] on which lambdaN[j] reaches zero */
+ teta = (d[j] < 0.0 ? 0.0 : d[j] / alfa);
+ /* if xN[j] has no upper bound, lambdaN[j] cannot become
+ * negative and thereby blocks further increasing teta */
+ if (u[k] == +DBL_MAX && teta_max > teta)
+ teta_max = teta;
+ }
+ else if (alfa <= -tol_piv && (l[k] == -DBL_MAX || flag[j]))
+ { /* xN[j] is either free or has its upper bound active, so
+ * lambdaN[j] = d[j] <= 0 increases up to zero */
+ /* determine teta[j] on which lambdaN[j] reaches zero */
+ teta = (d[j] > 0.0 ? 0.0 : d[j] / alfa);
+ /* if xN[j] has no lower bound, lambdaN[j] cannot become
+ * positive and thereby blocks further increasing teta */
+ if (l[k] == -DBL_MAX && teta_max > teta)
+ teta_max = teta;
+ }
+ else
+ { /* lambdaN[j] cannot reach zero on increasing teta */
+ continue;
+ }
+ /* add lambdaN[j] to the list */
+ nnn++;
+ bp[nnn].j = j;
+ bp[nnn].teta = teta;
+ }
+ /* remove from the list all dual basic variables lambdaN[j], for
+ * which teta[j] > teta_max */
+ nbp = 0;
+ for (t = 1; t <= nnn; t++)
+ { if (bp[t].teta <= teta_max + 1e-6)
+ { nbp++;
+ bp[nbp].j = bp[t].j;
+ bp[nbp].teta = bp[t].teta;
+ }
+ }
+ return nbp;
+}
+
+/***********************************************************************
+* spy_ls_select_bp - select and process dual objective break-points
+*
+* This routine selects a next portion of the dual objective function
+* break-points and processes them.
+*
+* On entry to the routine it is assumed that break-points bp[1], ...,
+* bp[num] are already processed, and slope is the dual objective slope
+* to the right of the last processed break-point bp[num]. (Initially,
+* when num = 0, slope should be specified as fabs(r), where r has the
+* same meaning as above.)
+*
+* The routine selects break-points among bp[num+1], ..., bp[nbp], for
+* which teta <= teta_lim, and moves these break-points to the array
+* elements bp[num+1], ..., bp[num1], where num <= num1 <= n-m is the
+* new number of processed break-points returned by the routine on
+* exit. Then the routine sorts these break-points by ascending teta
+* and computes the change of the dual objective function relative to
+* its value at teta = 0.
+*
+* On exit the routine also replaces the parameter slope with a new
+* value that corresponds to the new last break-point bp[num1]. */
+
+static int CDECL fcmp(const void *v1, const void *v2)
+{ const SPYBP *p1 = v1, *p2 = v2;
+ if (p1->teta < p2->teta)
+ return -1;
+ else if (p1->teta > p2->teta)
+ return +1;
+ else
+ return 0;
+}
+
+int spy_ls_select_bp(SPXLP *lp, const double trow[/*1+n-m*/],
+ int nbp, SPYBP bp[/*1+n-m*/], int num, double *slope, double
+ teta_lim)
+{ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int j, k, t, num1;
+ double teta, dz;
+ xassert(0 <= num && num <= nbp && nbp <= n-m);
+ /* select a new portion of break-points */
+ num1 = num;
+ for (t = num+1; t <= nbp; t++)
+ { if (bp[t].teta <= teta_lim)
+ { /* move break-point to the beginning of the new portion */
+ num1++;
+ j = bp[num1].j, teta = bp[num1].teta;
+ bp[num1].j = bp[t].j, bp[num1].teta = bp[t].teta;
+ bp[t].j = j, bp[t].teta = teta;
+ }
+ }
+ /* sort new break-points bp[num+1], ..., bp[num1] by ascending
+ * the ray parameter teta */
+ if (num1 - num > 1)
+ qsort(&bp[num+1], num1 - num, sizeof(SPYBP), fcmp);
+ /* calculate the dual objective change at the new break-points */
+ for (t = num+1; t <= num1; t++)
+ { /* calculate the dual objective change relative to its value
+ * at break-point bp[t-1] */
+ if (*slope == -DBL_MAX)
+ dz = -DBL_MAX;
+ else
+ dz = (*slope) *
+ (bp[t].teta - (t == 1 ? 0.0 : bp[t-1].teta));
+ /* calculate the dual objective change relative to its value
+ * at teta = 0 */
+ if (dz == -DBL_MAX)
+ bp[t].dz = -DBL_MAX;
+ else
+ bp[t].dz = (t == 1 ? 0.0 : bp[t-1].dz) + dz;
+ /* calculate a new slope of the dual objective to the right of
+ * the current break-point bp[t] */
+ if (*slope != -DBL_MAX)
+ { j = bp[t].j;
+ k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == -DBL_MAX || u[k] == +DBL_MAX)
+ *slope = -DBL_MAX; /* blocking break-point reached */
+ else
+ { xassert(l[k] < u[k]);
+ *slope -= fabs(trow[j]) * (u[k] - l[k]);
+ }
+ }
+ }
+ return num1;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spychuzc.h b/test/monniaux/glpk-4.65/src/simplex/spychuzc.h
new file mode 100644
index 00000000..8aa45a07
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spychuzc.h
@@ -0,0 +1,85 @@
+/* spychuzc.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2016 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPYCHUZC_H
+#define SPYCHUZC_H
+
+#include "spxlp.h"
+
+#define spy_chuzc_std _glp_spy_chuzc_std
+int spy_chuzc_std(SPXLP *lp, const double d[/*1+n-m*/],
+#if 0 /* 14/III-2016 */
+ double s, const double trow[/*1+n-m*/], double tol_piv,
+#else
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+#endif
+ double tol, double tol1);
+/* choose non-basic variable (dual textbook ratio test) */
+
+#define spy_chuzc_harris _glp_spy_chuzc_harris
+int spy_chuzc_harris(SPXLP *lp, const double d[/*1+n-m*/],
+#if 0 /* 14/III-2016 */
+ double s, const double trow[/*1+n-m*/], double tol_piv,
+#else
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+#endif
+ double tol, double tol1);
+/* choose non-basic variable (dual Harris' ratio test) */
+
+typedef struct SPYBP SPYBP;
+
+struct SPYBP
+{ /* dual objective function break point */
+ int j;
+ /* dual basic variable lambdaN[j], 1 <= j <= n-m, that intersects
+ * zero at this break point */
+ double teta;
+ /* ray parameter value, teta[j] >= 0, at this break point */
+ double dz;
+ /* increment, zeta[j] - zeta[0], of the dual objective function
+ * at this break point */
+};
+
+#if 0 /* 23/III-2016 */
+#define spy_eval_bp _glp_spy_eval_bp
+int spy_eval_bp(SPXLP *lp, const double d[/*1+n-m*/],
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+ SPYBP bp[/*1+n-m*/]);
+/* determine dual objective function break-points */
+#endif
+
+#define spy_ls_eval_bp _glp_spy_ls_eval_bp
+int spy_ls_eval_bp(SPXLP *lp, const double d[/*1+n-m*/],
+ double r, const double trow[/*1+n-m*/], double tol_piv,
+ SPYBP bp[/*1+n-m*/]);
+/* determine dual objective function break-points */
+
+#define spy_ls_select_bp _glp_spy_ls_select_bp
+int spy_ls_select_bp(SPXLP *lp, const double trow[/*1+n-m*/],
+ int nbp, SPYBP bp[/*1+n-m*/], int num, double *slope, double
+ teta_lim);
+/* select and process dual objective break-points */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spychuzr.c b/test/monniaux/glpk-4.65/src/simplex/spychuzr.c
new file mode 100644
index 00000000..63079c17
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spychuzr.c
@@ -0,0 +1,483 @@
+/* spychuzr.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#include "env.h"
+#include "spychuzr.h"
+
+/***********************************************************************
+* spy_chuzr_sel - select eligible basic variables
+*
+* This routine selects eligible basic variables xB[i], whose value
+* beta[i] violates corresponding lower lB[i] or upper uB[i] bound.
+* Positive bound violation rp[i] = lb[i] - beta[i] > 0 is the reduced
+* cost of non-basic dual variable lambda^+B[i] >= 0, so increasing it
+* increases the dual objective. Similarly, negative bound violation
+* rn[i] = ub[i] - beta[i] < 0 is the reduced cost of non-basic dual
+* variable lambda^-B[i] <= 0, so decreasing it also increases the dual
+* objective.
+*
+* Current values of basic variables should be placed in the array
+* locations beta[1], ..., beta[m].
+*
+* Basic variable xB[i] is considered eligible, if:
+*
+* beta[i] <= lB[i] - eps1[i], or
+*
+* beta[i] >= uB[i] + eps2[i],
+*
+* for
+*
+* eps1[i] = tol + tol1 * |lB[i]|,
+*
+* eps2[i] = tol + tol2 * |uB[i]|,
+*
+* where lB[i] and uB[i] are, resp., lower and upper bounds of xB[i],
+* tol and tol1 are specified tolerances.
+*
+* On exit the routine stores indices i of eligible basic variables
+* xB[i] to the array locations list[1], ..., list[num] and returns the
+* number of such variables 0 <= num <= m. (If the parameter list is
+* specified as NULL, no indices are stored.) */
+
+int spy_chuzr_sel(SPXLP *lp, const double beta[/*1+m*/], double tol,
+ double tol1, int list[/*1+m*/])
+{ int m = lp->m;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, k, num;
+ double lk, uk, eps;
+ num = 0;
+ /* walk thru list of basic variables */
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ lk = l[k], uk = u[k];
+ /* check if xB[i] is eligible */
+ if (beta[i] < lk)
+ { /* determine absolute tolerance eps1[i] */
+ eps = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] < lk - eps)
+ { /* lower bound is violated */
+ num++;
+ if (list != NULL)
+ list[num] = i;
+ }
+ }
+ else if (beta[i] > uk)
+ { /* determine absolute tolerance eps2[i] */
+ eps = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] > uk + eps)
+ { /* upper bound is violated */
+ num++;
+ if (list != NULL)
+ list[num] = i;
+ }
+ }
+ }
+ return num;
+}
+
+/***********************************************************************
+* spy_chuzr_std - choose basic variable (dual Dantzig's rule)
+*
+* This routine chooses most eligible basic variable xB[p] according
+* to dual Dantzig's ("standard") rule:
+*
+* r[p] = max |r[i]|,
+* i in I
+*
+* ( lB[i] - beta[i], if beta[i] < lB[i]
+* (
+* r[i] = { 0, if lB[i] <= beta[i] <= uB[i]
+* (
+* ( uB[i] - beta[i], if beta[i] > uB[i]
+*
+* where I <= {1, ..., m} is the set of indices of eligible basic
+* variables, beta[i] is current value of xB[i], lB[i] and uB[i] are,
+* resp., lower and upper bounds of xB[i], r[i] is bound violation.
+*
+* Current values of basic variables should be placed in the array
+* locations beta[1], ..., beta[m].
+*
+* Indices of eligible basic variables i in I should be placed in the
+* array locations list[1], ..., list[num], where num = |J| > 0 is the
+* total number of such variables.
+*
+* On exit the routine returns p, the index of the basic variable xB[p]
+* chosen. */
+
+int spy_chuzr_std(SPXLP *lp, const double beta[/*1+m*/], int num,
+ const int list[])
+{ int m = lp->m;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int i, k, p, t;
+ double abs_ri, abs_rp;
+ xassert(0 < num && num <= m);
+ p = 0, abs_rp = -1.0;
+ for (t = 1; t <= num; t++)
+ { i = list[t];
+ k = head[i]; /* x[k] = xB[i] */
+ if (beta[i] < l[k])
+ abs_ri = l[k] - beta[i];
+ else if (beta[i] > u[k])
+ abs_ri = beta[i] - u[k];
+ else
+ xassert(t != t);
+ if (abs_rp < abs_ri)
+ p = i, abs_rp = abs_ri;
+ }
+ xassert(p != 0);
+ return p;
+}
+
+/***********************************************************************
+* spy_alloc_se - allocate dual pricing data block
+*
+* This routine allocates the memory for arrays used in the dual
+* pricing data block. */
+
+void spy_alloc_se(SPXLP *lp, SPYSE *se)
+{ int m = lp->m;
+ int n = lp->n;
+#if 1 /* 30/III-2016 */
+ int i;
+#endif
+ se->valid = 0;
+ se->refsp = talloc(1+n, char);
+ se->gamma = talloc(1+m, double);
+ se->work = talloc(1+m, double);
+#if 1 /* 30/III-2016 */
+ se->u.n = m;
+ se->u.nnz = 0;
+ se->u.ind = talloc(1+m, int);
+ se->u.vec = talloc(1+m, double);
+ for (i = 1; i <= m; i++)
+ se->u.vec[i] = 0.0;
+#endif
+ return;
+}
+
+/***********************************************************************
+* spy_reset_refsp - reset dual reference space
+*
+* This routine resets (re-initializes) the dual reference space
+* composing it from dual variables which are non-basic (corresponding
+* to basic primal variables) in the current basis, and sets all
+* weights gamma[i] to 1. */
+
+void spy_reset_refsp(SPXLP *lp, SPYSE *se)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *gamma = se->gamma;
+ int i, k;
+ se->valid = 1;
+ memset(&refsp[1], 0, n * sizeof(char));
+ for (i = 1; i <= m; i++)
+ { k = head[i]; /* x[k] = xB[i] */
+ refsp[k] = 1;
+ gamma[i] = 1.0;
+ }
+ return;
+}
+
+/***********************************************************************
+* spy_eval_gamma_i - compute dual proj. steepest edge weight directly
+*
+* This routine computes dual projected steepest edge weight gamma[i],
+* 1 <= i <= m, for the current basis directly with the formula:
+*
+* n-m
+* gamma[i] = delta[i] + sum eta[j] * T[i,j]**2,
+* j=1
+*
+* where T[i,j] is element of the current simplex table, and
+*
+* ( 1, if lambdaN[j] is in the reference space
+* eta[j] = {
+* ( 0, otherwise
+*
+* ( 1, if lambdaB[i] is in the reference space
+* delta[i] = {
+* ( 0, otherwise
+*
+* Dual basic variable lambdaN[j] corresponds to primal non-basic
+* variable xN[j], and dual non-basic variable lambdaB[j] corresponds
+* to primal basic variable xB[i].
+*
+* NOTE: For testing/debugging only. */
+
+double spy_eval_gamma_i(SPXLP *lp, SPYSE *se, int i)
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *rho = se->work;
+ int j, k;
+ double gamma_i, t_ij;
+ xassert(se->valid);
+ xassert(1 <= i && i <= m);
+ k = head[i]; /* x[k] = xB[i] */
+ gamma_i = (refsp[k] ? 1.0 : 0.0);
+ spx_eval_rho(lp, i, rho);
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (refsp[k])
+ { t_ij = spx_eval_tij(lp, rho, j);
+ gamma_i += t_ij * t_ij;
+ }
+ }
+ return gamma_i;
+}
+
+/***********************************************************************
+* spy_chuzr_pse - choose basic variable (dual projected steepest edge)
+*
+* This routine chooses most eligible basic variable xB[p] according
+* to the dual projected steepest edge method:
+*
+* r[p]**2 r[i]**2
+* -------- = max -------- ,
+* gamma[p] i in I gamma[i]
+*
+* ( lB[i] - beta[i], if beta[i] < lB[i]
+* (
+* r[i] = { 0, if lB[i] <= beta[i] <= uB[i]
+* (
+* ( uB[i] - beta[i], if beta[i] > uB[i]
+*
+* where I <= {1, ..., m} is the set of indices of eligible basic
+* variables, beta[i] is current value of xB[i], lB[i] and uB[i] are,
+* resp., lower and upper bounds of xB[i], r[i] is bound violation.
+*
+* Current values of basic variables should be placed in the array
+* locations beta[1], ..., beta[m].
+*
+* Indices of eligible basic variables i in I should be placed in the
+* array locations list[1], ..., list[num], where num = |J| > 0 is the
+* total number of such variables.
+*
+* On exit the routine returns p, the index of the basic variable xB[p]
+* chosen. */
+
+int spy_chuzr_pse(SPXLP *lp, SPYSE *se, const double beta[/*1+m*/],
+ int num, const int list[])
+{ int m = lp->m;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ double *gamma = se->gamma;
+ int i, k, p, t;
+ double best, ri, temp;
+ xassert(0 < num && num <= m);
+ p = 0, best = -1.0;
+ for (t = 1; t <= num; t++)
+ { i = list[t];
+ k = head[i]; /* x[k] = xB[i] */
+ if (beta[i] < l[k])
+ ri = l[k] - beta[i];
+ else if (beta[i] > u[k])
+ ri = u[k] - beta[i];
+ else
+ xassert(t != t);
+ /* FIXME */
+ if (gamma[i] < DBL_EPSILON)
+ temp = 0.0;
+ else
+ temp = (ri * ri) / gamma[i];
+ if (best < temp)
+ p = i, best = temp;
+ }
+ xassert(p != 0);
+ return p;
+}
+
+/***********************************************************************
+* spy_update_gamma - update dual proj. steepest edge weights exactly
+*
+* This routine updates the vector gamma = (gamma[i]) of dual projected
+* steepest edge weights exactly, for the adjacent basis.
+*
+* On entry to the routine the content of the se object should be valid
+* and should correspond to the current basis.
+*
+* The parameter 1 <= p <= m specifies basic variable xB[p] which
+* becomes non-basic variable xN[q] in the adjacent basis.
+*
+* The parameter 1 <= q <= n-m specified non-basic variable xN[q] which
+* becomes basic variable xB[p] in the adjacent basis.
+*
+* It is assumed that the array trow contains elements of p-th (pivot)
+* row T'[p] of the simplex table in locations trow[1], ..., trow[n-m].
+* It is also assumed that the array tcol contains elements of q-th
+* (pivot) column T[q] of the simple table in locations tcol[1], ...,
+* tcol[m]. (These row and column should be computed for the current
+* basis.)
+*
+* For details about the formulae used see the program documentation.
+*
+* The routine also computes the relative error:
+*
+* e = |gamma[p] - gamma'[p]| / (1 + |gamma[p]|),
+*
+* where gamma'[p] is the weight for lambdaB[p] (which is dual
+* non-basic variable corresponding to xB[p]) on entry to the routine,
+* and returns e on exit. (If e happens to be large enough, the calling
+* program may reset the reference space, since other weights also may
+* be inaccurate.) */
+
+double spy_update_gamma(SPXLP *lp, SPYSE *se, int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/])
+{ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *gamma = se->gamma;
+ double *u = se->work;
+ int i, j, k, ptr, end;
+ double gamma_p, delta_p, e, r, t1, t2;
+ xassert(se->valid);
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* compute gamma[p] in current basis more accurately; also
+ * compute auxiliary vector u */
+ k = head[p]; /* x[k] = xB[p] */
+ gamma_p = delta_p = (refsp[k] ? 1.0 : 0.0);
+ for (i = 1; i <= m; i++)
+ u[i] = 0.0;
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (refsp[k] && trow[j] != 0.0)
+ { gamma_p += trow[j] * trow[j];
+ /* u := u + T[p,j] * N[j], where N[j] = A[k] is constraint
+ * matrix column corresponding to xN[j] */
+ ptr = lp->A_ptr[k];
+ end = lp->A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ u[lp->A_ind[ptr]] += trow[j] * lp->A_val[ptr];
+ }
+ }
+ bfd_ftran(lp->bfd, u);
+ /* compute relative error in gamma[p] */
+ e = fabs(gamma_p - gamma[p]) / (1.0 + gamma_p);
+ /* compute new gamma[p] */
+ gamma[p] = gamma_p / (tcol[p] * tcol[p]);
+ /* compute new gamma[i] for all i != p */
+ for (i = 1; i <= m; i++)
+ { if (i == p)
+ continue;
+ /* compute r[i] = T[i,q] / T[p,q] */
+ r = tcol[i] / tcol[p];
+ /* compute new gamma[i] */
+ t1 = gamma[i] + r * (r * gamma_p + u[i] + u[i]);
+ k = head[i]; /* x[k] = xB[i] */
+ t2 = (refsp[k] ? 1.0 : 0.0) + delta_p * r * r;
+ gamma[i] = (t1 >= t2 ? t1 : t2);
+ }
+ return e;
+}
+
+#if 1 /* 30/III-2016 */
+double spy_update_gamma_s(SPXLP *lp, SPYSE *se, int p, int q,
+ const FVS *trow, const FVS *tcol)
+{ /* sparse version of spy_update_gamma */
+ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *refsp = se->refsp;
+ double *gamma = se->gamma;
+ double *u = se->work;
+ int trow_nnz = trow->nnz;
+ int *trow_ind = trow->ind;
+ double *trow_vec = trow->vec;
+ int tcol_nnz = tcol->nnz;
+ int *tcol_ind = tcol->ind;
+ double *tcol_vec = tcol->vec;
+ int i, j, k, t, ptr, end;
+ double gamma_p, delta_p, e, r, t1, t2;
+ xassert(se->valid);
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ /* compute gamma[p] in current basis more accurately; also
+ * compute auxiliary vector u */
+ k = head[p]; /* x[k] = xB[p] */
+ gamma_p = delta_p = (refsp[k] ? 1.0 : 0.0);
+ for (i = 1; i <= m; i++)
+ u[i] = 0.0;
+ for (t = 1; t <= trow_nnz; t++)
+ { j = trow_ind[t];
+ k = head[m+j]; /* x[k] = xN[j] */
+ if (refsp[k])
+ { gamma_p += trow_vec[j] * trow_vec[j];
+ /* u := u + T[p,j] * N[j], where N[j] = A[k] is constraint
+ * matrix column corresponding to xN[j] */
+ ptr = lp->A_ptr[k];
+ end = lp->A_ptr[k+1];
+ for (; ptr < end; ptr++)
+ u[lp->A_ind[ptr]] += trow_vec[j] * lp->A_val[ptr];
+ }
+ }
+ bfd_ftran(lp->bfd, u);
+ /* compute relative error in gamma[p] */
+ e = fabs(gamma_p - gamma[p]) / (1.0 + gamma_p);
+ /* compute new gamma[p] */
+ gamma[p] = gamma_p / (tcol_vec[p] * tcol_vec[p]);
+ /* compute new gamma[i] for all i != p */
+ for (t = 1; t <= tcol_nnz; t++)
+ { i = tcol_ind[t];
+ if (i == p)
+ continue;
+ /* compute r[i] = T[i,q] / T[p,q] */
+ r = tcol_vec[i] / tcol_vec[p];
+ /* compute new gamma[i] */
+ t1 = gamma[i] + r * (r * gamma_p + u[i] + u[i]);
+ k = head[i]; /* x[k] = xB[i] */
+ t2 = (refsp[k] ? 1.0 : 0.0) + delta_p * r * r;
+ gamma[i] = (t1 >= t2 ? t1 : t2);
+ }
+ return e;
+}
+#endif
+
+/***********************************************************************
+* spy_free_se - deallocate dual pricing data block
+*
+* This routine deallocates the memory used for arrays in the dual
+* pricing data block. */
+
+void spy_free_se(SPXLP *lp, SPYSE *se)
+{ xassert(lp == lp);
+ tfree(se->refsp);
+ tfree(se->gamma);
+ tfree(se->work);
+#if 1 /* 30/III-2016 */
+ tfree(se->u.ind);
+ tfree(se->u.vec);
+#endif
+ return;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spychuzr.h b/test/monniaux/glpk-4.65/src/simplex/spychuzr.h
new file mode 100644
index 00000000..31f01b78
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spychuzr.h
@@ -0,0 +1,97 @@
+/* spychuzr.h */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#ifndef SPYCHUZR_H
+#define SPYCHUZR_H
+
+#include "spxlp.h"
+
+#define spy_chuzr_sel _glp_spy_chuzr_sel
+int spy_chuzr_sel(SPXLP *lp, const double beta[/*1+m*/], double tol,
+ double tol1, int list[/*1+m*/]);
+/* select eligible basic variables */
+
+#define spy_chuzr_std _glp_spy_chuzr_std
+int spy_chuzr_std(SPXLP *lp, const double beta[/*1+m*/], int num,
+ const int list[]);
+/* choose basic variable (dual Dantzig's rule) */
+
+typedef struct SPYSE SPYSE;
+
+struct SPYSE
+{ /* dual projected steepest edge and Devex pricing data block */
+ int valid;
+ /* content validity flag */
+ char *refsp; /* char refsp[1+n]; */
+ /* refsp[0] is not used;
+ * refsp[k], 1 <= k <= n, is the flag meaning that dual variable
+ * lambda[k] is in the dual reference space */
+ double *gamma; /* double gamma[1+m]; */
+ /* gamma[0] is not used;
+ * gamma[i], 1 <= i <= m, is the weight for reduced cost r[i]
+ * of dual non-basic variable lambdaB[j] in the current basis
+ * (r[i] is bound violation for basic variable xB[i]) */
+ double *work; /* double work[1+m]; */
+ /* working array */
+#if 1 /* 30/III-2016 */
+ FVS u; /* FVS u[1:m]; */
+ /* working vector */
+#endif
+};
+
+#define spy_alloc_se _glp_spy_alloc_se
+void spy_alloc_se(SPXLP *lp, SPYSE *se);
+/* allocate dual pricing data block */
+
+#define spy_reset_refsp _glp_spy_reset_refsp
+void spy_reset_refsp(SPXLP *lp, SPYSE *se);
+/* reset dual reference space */
+
+#define spy_eval_gamma_i _glp_spy_eval_gamma_i
+double spy_eval_gamma_i(SPXLP *lp, SPYSE *se, int i);
+/* compute dual projected steepest edge weight directly */
+
+#define spy_chuzr_pse _glp_spy_chuzr_pse
+int spy_chuzr_pse(SPXLP *lp, SPYSE *se, const double beta[/*1+m*/],
+ int num, const int list[]);
+/* choose basic variable (dual projected steepest edge) */
+
+#define spy_update_gamma _glp_spy_update_gamma
+double spy_update_gamma(SPXLP *lp, SPYSE *se, int p, int q,
+ const double trow[/*1+n-m*/], const double tcol[/*1+m*/]);
+/* update dual projected steepest edge weights exactly */
+
+#if 1 /* 30/III-2016 */
+#define spy_update_gamma_s _glp_spy_update_gamma_s
+double spy_update_gamma_s(SPXLP *lp, SPYSE *se, int p, int q,
+ const FVS *trow, const FVS *tcol);
+/* sparse version of spy_update_gamma */
+#endif
+
+#define spy_free_se _glp_spy_free_se
+void spy_free_se(SPXLP *lp, SPYSE *se);
+/* deallocate dual pricing data block */
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/simplex/spydual.c b/test/monniaux/glpk-4.65/src/simplex/spydual.c
new file mode 100644
index 00000000..89d98db9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/simplex/spydual.c
@@ -0,0 +1,2101 @@
+/* spydual.c */
+
+/***********************************************************************
+* This code is part of GLPK (GNU Linear Programming Kit).
+*
+* Copyright (C) 2015-2017 Andrew Makhorin, Department for Applied
+* Informatics, Moscow Aviation Institute, Moscow, Russia. All rights
+* reserved. E-mail: <mao@gnu.org>.
+*
+* GLPK 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 of the License, or
+* (at your option) any later version.
+*
+* GLPK is distributed in the hope that 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 GLPK. If not, see <http://www.gnu.org/licenses/>.
+***********************************************************************/
+
+#if 1 /* 18/VII-2017 */
+#define SCALE_Z 1
+#endif
+
+#include "env.h"
+#include "simplex.h"
+#include "spxat.h"
+#include "spxnt.h"
+#include "spxprob.h"
+#include "spychuzc.h"
+#include "spychuzr.h"
+#if 0 /* 11/VI-2017 */
+#if 1 /* 29/III-2016 */
+#include "fvs.h"
+#endif
+#endif
+
+#define CHECK_ACCURACY 0
+/* (for debugging) */
+
+struct csa
+{ /* common storage area */
+ SPXLP *lp;
+ /* LP problem data and its (current) basis; this LP has m rows
+ * and n columns */
+ int dir;
+ /* original optimization direction:
+ * +1 - minimization
+ * -1 - maximization */
+#if SCALE_Z
+ double fz;
+ /* factor used to scale original objective */
+#endif
+ double *orig_b; /* double orig_b[1+m]; */
+ /* copy of original right-hand sides */
+ double *orig_c; /* double orig_c[1+n]; */
+ /* copy of original objective coefficients */
+ double *orig_l; /* double orig_l[1+n]; */
+ /* copy of original lower bounds */
+ double *orig_u; /* double orig_u[1+n]; */
+ /* copy of original upper bounds */
+ SPXAT *at;
+ /* mxn-matrix A of constraint coefficients, in sparse row-wise
+ * format (NULL if not used) */
+ SPXNT *nt;
+ /* mx(n-m)-matrix N composed of non-basic columns of constraint
+ * matrix A, in sparse row-wise format (NULL if not used) */
+ int phase;
+ /* search phase:
+ * 0 - not determined yet
+ * 1 - searching for dual feasible solution
+ * 2 - searching for optimal solution */
+ double *beta; /* double beta[1+m]; */
+ /* beta[i] is primal value of basic variable xB[i] */
+ int beta_st;
+ /* status of the vector beta:
+ * 0 - undefined
+ * 1 - just computed
+ * 2 - updated */
+ double *d; /* double d[1+n-m]; */
+ /* d[j] is reduced cost of non-basic variable xN[j] */
+ int d_st;
+ /* status of the vector d:
+ * 0 - undefined
+ * 1 - just computed
+ * 2 - updated */
+ SPYSE *se;
+ /* dual projected steepest edge and Devex pricing data block
+ * (NULL if not used) */
+#if 0 /* 30/III-2016 */
+ int num;
+ /* number of eligible basic variables */
+ int *list; /* int list[1+m]; */
+ /* list[1], ..., list[num] are indices i of eligible basic
+ * variables xB[i] */
+#else
+ FVS r; /* FVS r[1:m]; */
+ /* vector of primal infeasibilities */
+ /* r->nnz = num; r->ind = list */
+ /* vector r has the same status as vector beta (see above) */
+#endif
+ int p;
+ /* xB[p] is a basic variable chosen to leave the basis */
+#if 0 /* 29/III-2016 */
+ double *trow; /* double trow[1+n-m]; */
+#else
+ FVS trow; /* FVS trow[1:n-m]; */
+#endif
+ /* p-th (pivot) row of the simplex table */
+#if 1 /* 16/III-2016 */
+ SPYBP *bp; /* SPYBP bp[1+n-m]; */
+ /* dual objective break-points */
+#endif
+ int q;
+ /* xN[q] is a non-basic variable chosen to enter the basis */
+#if 0 /* 29/III-2016 */
+ double *tcol; /* double tcol[1+m]; */
+#else
+ FVS tcol; /* FVS tcol[1:m]; */
+#endif
+ /* q-th (pivot) column of the simplex table */
+ double *work; /* double work[1+m]; */
+ /* working array */
+ double *work1; /* double work1[1+n-m]; */
+ /* another working array */
+#if 0 /* 11/VI-2017 */
+#if 1 /* 31/III-2016 */
+ FVS wrow; /* FVS wrow[1:n-m]; */
+ FVS wcol; /* FVS wcol[1:m]; */
+ /* working sparse vectors */
+#endif
+#endif
+ int p_stat, d_stat;
+ /* primal and dual solution statuses */
+ /*--------------------------------------------------------------*/
+ /* control parameters (see struct glp_smcp) */
+ int msg_lev;
+ /* message level */
+ int dualp;
+ /* if this flag is set, report failure in case of instability */
+#if 0 /* 16/III-2016 */
+ int harris;
+ /* dual ratio test technique:
+ * 0 - textbook ratio test
+ * 1 - Harris' two pass ratio test */
+#else
+ int r_test;
+ /* dual ratio test technique:
+ * GLP_RT_STD - textbook ratio test
+ * GLP_RT_HAR - Harris' two pass ratio test
+ * GLP_RT_FLIP - long-step (flip-flop) ratio test */
+#endif
+ double tol_bnd, tol_bnd1;
+ /* primal feasibility tolerances */
+ double tol_dj, tol_dj1;
+ /* dual feasibility tolerances */
+ double tol_piv;
+ /* pivot tolerance */
+ double obj_lim;
+ /* objective limit */
+ int it_lim;
+ /* iteration limit */
+ int tm_lim;
+ /* time limit, milliseconds */
+ int out_frq;
+#if 0 /* 15/VII-2017 */
+ /* display output frequency, iterations */
+#else
+ /* display output frequency, milliseconds */
+#endif
+ int out_dly;
+ /* display output delay, milliseconds */
+ /*--------------------------------------------------------------*/
+ /* working parameters */
+ double tm_beg;
+ /* time value at the beginning of the search */
+ int it_beg;
+ /* simplex iteration count at the beginning of the search */
+ int it_cnt;
+ /* simplex iteration count; it increases by one every time the
+ * basis changes */
+ int it_dpy;
+ /* simplex iteration count at most recent display output */
+#if 1 /* 15/VII-2017 */
+ double tm_dpy;
+ /* time value at most recent display output */
+#endif
+ int inv_cnt;
+ /* basis factorization count since most recent display output */
+#if 1 /* 11/VII-2017 */
+ int degen;
+ /* count of successive degenerate iterations; this count is used
+ * to detect stalling */
+#endif
+#if 1 /* 23/III-2016 */
+ int ns_cnt, ls_cnt;
+ /* normal and long-step iteration count */
+#endif
+};
+
+/***********************************************************************
+* check_flags - check correctness of active bound flags
+*
+* This routine checks that flags specifying active bounds of all
+* non-basic variables are correct.
+*
+* NOTE: It is important to note that if bounds of variables have been
+* changed, active bound flags should be corrected accordingly. */
+
+static void check_flags(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ int j, k;
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == -DBL_MAX && u[k] == +DBL_MAX)
+ xassert(!flag[j]);
+ else if (l[k] != -DBL_MAX && u[k] == +DBL_MAX)
+ xassert(!flag[j]);
+ else if (l[k] == -DBL_MAX && u[k] != +DBL_MAX)
+ xassert(flag[j]);
+ else if (l[k] == u[k])
+ xassert(!flag[j]);
+ }
+ return;
+}
+
+/***********************************************************************
+* set_art_bounds - set artificial right-hand sides and bounds
+*
+* This routine sets artificial right-hand sides and artificial bounds
+* for all variables to minimize the sum of dual infeasibilities on
+* phase I. Given current reduced costs d = (d[j]) this routine also
+* sets active artificial bounds of non-basic variables to provide dual
+* feasibility (this is always possible because all variables have both
+* lower and upper artificial bounds). */
+
+static void set_art_bounds(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *b = lp->b;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *d = csa->d;
+ int i, j, k;
+#if 1 /* 31/III-2016: FIXME */
+ /* set artificial right-hand sides */
+ for (i = 1; i <= m; i++)
+ b[i] = 0.0;
+ /* set artificial bounds depending on types of variables */
+ for (k = 1; k <= n; k++)
+ { if (csa->orig_l[k] == -DBL_MAX && csa->orig_u[k] == +DBL_MAX)
+ { /* force free variables to enter the basis */
+ l[k] = -1e3, u[k] = +1e3;
+ }
+ else if (csa->orig_l[k] != -DBL_MAX && csa->orig_u[k] == +DBL_MAX)
+ l[k] = 0.0, u[k] = +1.0;
+ else if (csa->orig_l[k] == -DBL_MAX && csa->orig_u[k] != +DBL_MAX)
+ l[k] = -1.0, u[k] = 0.0;
+ else
+ l[k] = u[k] = 0.0;
+ }
+#endif
+ /* set active artificial bounds for non-basic variables */
+ xassert(csa->d_st == 1);
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ flag[j] = (l[k] != u[k] && d[j] < 0.0);
+ }
+ /* invalidate values of basic variables, since active bounds of
+ * non-basic variables have been changed */
+ csa->beta_st = 0;
+ return;
+}
+
+/***********************************************************************
+* set_orig_bounds - restore original right-hand sides and bounds
+*
+* This routine restores original right-hand sides and original bounds
+* for all variables. This routine also sets active original bounds for
+* non-basic variables; for double-bounded non-basic variables current
+* reduced costs d = (d[j]) are used to decide which bound (lower or
+* upper) should be made active. */
+
+static void set_orig_bounds(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *b = lp->b;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *d = csa->d;
+ int j, k;
+ /* restore original right-hand sides */
+ memcpy(b, csa->orig_b, (1+m) * sizeof(double));
+ /* restore original bounds of all variables */
+ memcpy(l, csa->orig_l, (1+n) * sizeof(double));
+ memcpy(u, csa->orig_u, (1+n) * sizeof(double));
+ /* set active original bounds for non-basic variables */
+ xassert(csa->d_st == 1);
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == -DBL_MAX && u[k] == +DBL_MAX)
+ flag[j] = 0;
+ else if (l[k] != -DBL_MAX && u[k] == +DBL_MAX)
+ flag[j] = 0;
+ else if (l[k] == -DBL_MAX && u[k] != +DBL_MAX)
+ flag[j] = 1;
+ else if (l[k] != u[k])
+ flag[j] = (d[j] < 0.0);
+ else
+ flag[j] = 0;
+ }
+ /* invalidate values of basic variables, since active bounds of
+ * non-basic variables have been changed */
+ csa->beta_st = 0;
+ return;
+}
+
+/***********************************************************************
+* check_feas - check dual feasibility of basic solution
+*
+* This routine checks that reduced costs of all non-basic variables
+* d = (d[j]) have correct signs.
+*
+* Reduced cost d[j] is considered as having correct sign within the
+* specified tolerance depending on status of non-basic variable xN[j]
+* if one of the following conditions is met:
+*
+* xN[j] is free -eps <= d[j] <= +eps
+*
+* xN[j] has its lower bound active d[j] >= -eps
+*
+* xN[j] has its upper bound active d[j] <= +eps
+*
+* xN[j] is fixed d[j] has any value
+*
+* where eps = tol + tol1 * |cN[j]|, cN[j] is the objective coefficient
+* at xN[j]. (See also the routine spx_chuzc_sel.)
+*
+* The flag recov allows the routine to recover dual feasibility by
+* changing active bounds of non-basic variables. (For example, if
+* xN[j] has its lower bound active and d[j] < -eps, the feasibility
+* can be recovered by making xN[j] active on its upper bound.)
+*
+* If the basic solution is dual feasible, the routine returns zero.
+* If the basic solution is dual infeasible, but its dual feasibility
+* can be recovered (or has been recovered, if the flag recov is set),
+* the routine returns a negative value. Otherwise, the routine returns
+* the number j of some non-basic variable xN[j], whose reduced cost
+* d[j] is dual infeasible and cannot be recovered. */
+
+static int check_feas(struct csa *csa, double tol, double tol1,
+ int recov)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *d = csa->d;
+ int j, k, ret = 0;
+ double eps;
+ /* reduced costs should be just computed */
+ xassert(csa->d_st == 1);
+ /* walk thru list of non-basic variables */
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == u[k])
+ { /* xN[j] is fixed variable; skip it */
+ continue;
+ }
+ /* determine absolute tolerance eps[j] */
+ eps = tol + tol1 * (c[k] >= 0.0 ? +c[k] : -c[k]);
+ /* check dual feasibility of xN[j] */
+ if (d[j] > +eps)
+ { /* xN[j] should have its lower bound active */
+ if (l[k] == -DBL_MAX || flag[j])
+ { /* but it either has no lower bound or its lower bound
+ * is inactive */
+ if (l[k] == -DBL_MAX)
+ { /* cannot recover, since xN[j] has no lower bound */
+ ret = j;
+ break;
+ }
+ /* recovering is possible */
+ if (recov)
+ flag[j] = 0;
+ ret = -1;
+ }
+ }
+ else if (d[j] < -eps)
+ { /* xN[j] should have its upper bound active */
+ if (!flag[j])
+ { /* but it either has no upper bound or its upper bound
+ * is inactive */
+ if (u[k] == +DBL_MAX)
+ { /* cannot recover, since xN[j] has no upper bound */
+ ret = j;
+ break;
+ }
+ /* recovering is possible */
+ if (recov)
+ flag[j] = 1;
+ ret = -1;
+ }
+ }
+ }
+ if (recov && ret)
+ { /* invalidate values of basic variables, since active bounds
+ * of non-basic variables have been changed */
+ csa->beta_st = 0;
+ }
+ return ret;
+}
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_vec - compute maximal relative error between two vectors
+*
+* This routine computes and returns maximal relative error between
+* n-vectors x and y:
+*
+* err_max = max |x[i] - y[i]| / (1 + |x[i]|).
+*
+* NOTE: This routine is intended only for debugging purposes. */
+
+static double err_in_vec(int n, const double x[], const double y[])
+{ int i;
+ double err, err_max;
+ err_max = 0.0;
+ for (i = 1; i <= n; i++)
+ { err = fabs(x[i] - y[i]) / (1.0 + fabs(x[i]));
+ if (err_max < err)
+ err_max = err;
+ }
+ return err_max;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_beta - compute maximal relative error in vector beta
+*
+* This routine computes and returns maximal relative error in vector
+* of values of basic variables beta = (beta[i]).
+*
+* NOTE: This routine is intended only for debugging purposes. */
+
+static double err_in_beta(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ double err, *beta;
+ beta = talloc(1+m, double);
+ spx_eval_beta(lp, beta);
+ err = err_in_vec(m, beta, csa->beta);
+ tfree(beta);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+static double err_in_r(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int i, k;
+ double err, *r;
+ r = talloc(1+m, double);
+ for (i = 1; i <= m; i++)
+ { k = lp->head[i];
+ if (csa->beta[i] < lp->l[k])
+ r[i] = lp->l[k] - csa->beta[i];
+ else if (csa->beta[i] > lp->u[k])
+ r[i] = lp->u[k] - csa->beta[i];
+ else
+ r[i] = 0.0;
+
+if (fabs(r[i] - csa->r.vec[i]) > 1e-6)
+printf("i = %d; r = %g; csa->r = %g\n", i, r[i], csa->r.vec[i]);
+
+
+ }
+ err = err_in_vec(m, r, csa->r.vec);
+ tfree(r);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_d - compute maximal relative error in vector d
+*
+* This routine computes and returns maximal relative error in vector
+* of reduced costs of non-basic variables d = (d[j]).
+*
+* NOTE: This routine is intended only for debugging purposes. */
+
+static double err_in_d(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ int j;
+ double err, *pi, *d;
+ pi = talloc(1+m, double);
+ d = talloc(1+n-m, double);
+ spx_eval_pi(lp, pi);
+ for (j = 1; j <= n-m; j++)
+ d[j] = spx_eval_dj(lp, pi, j);
+ err = err_in_vec(n-m, d, csa->d);
+ tfree(pi);
+ tfree(d);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* err_in_gamma - compute maximal relative error in vector gamma
+*
+* This routine computes and returns maximal relative error in vector
+* of projected steepest edge weights gamma = (gamma[j]).
+*
+* NOTE: This routine is intended only for debugging purposes. */
+
+static double err_in_gamma(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ SPYSE *se = csa->se;
+ int i;
+ double err, *gamma;
+ xassert(se != NULL);
+gamma = talloc(1+m, double);
+ for (i = 1; i <= m; i++)
+ gamma[i] = spy_eval_gamma_i(lp, se, i);
+ err = err_in_vec(m, gamma, se->gamma);
+ tfree(gamma);
+ return err;
+}
+#endif
+
+#if CHECK_ACCURACY
+/***********************************************************************
+* check_accuracy - check accuracy of basic solution components
+*
+* This routine checks accuracy of current basic solution components.
+*
+* NOTE: This routine is intended only for debugging purposes. */
+
+static void check_accuracy(struct csa *csa)
+{ double e_beta, e_r, e_d, e_gamma;
+ e_beta = err_in_beta(csa);
+ e_r = err_in_r(csa);
+ e_d = err_in_d(csa);
+ if (csa->se == NULL)
+ e_gamma = 0.;
+ else
+ e_gamma = err_in_gamma(csa);
+ xprintf("e_beta = %10.3e; e_r = %10.3e; e_d = %10.3e; e_gamma = %"
+ "10.3e\n", e_beta, e_r, e_d, e_gamma);
+ xassert(e_beta <= 1e-5 && e_d <= 1e-5 && e_gamma <= 1e-3);
+ return;
+}
+#endif
+
+#if 1 /* 30/III-2016 */
+static
+void spy_eval_r(SPXLP *lp, const double beta[/*1+m*/], double tol,
+ double tol1, FVS *r)
+{ /* this routine computes the vector of primal infeasibilities:
+ *
+ * ( lB[i] - beta[i] > 0, if beta[i] < lb[i]
+ * r[i] = { 0, if lb[i] <= beta[i] <= ub[i]
+ * ( ub[i] - beta[i] < 0, if beta[i] > ub[i]
+ *
+ * (this routine replaces spy_chuzr_sel) */
+ int m = lp->m;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int *ind = r->ind;
+ double *vec = r->vec;
+ int i, k, nnz = 0;
+ double lk, uk, eps;
+ xassert(r->n == m);
+ /* walk thru the list of basic variables */
+ for (i = 1; i <= m; i++)
+ { vec[i] = 0.0;
+ k = head[i]; /* x[k] = xB[i] */
+ lk = l[k], uk = u[k];
+ /* check primal feasibility */
+ if (beta[i] < lk)
+ { /* determine absolute tolerance eps1[i] */
+ eps = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] < lk - eps)
+ { /* lower bound is violated */
+ ind[++nnz] = i;
+ vec[i] = lk - beta[i];
+ }
+ }
+ else if (beta[i] > uk)
+ { /* determine absolute tolerance eps2[i] */
+ eps = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] > uk + eps)
+ { /* upper bound is violated */
+ ind[++nnz] = i;
+ vec[i] = uk - beta[i];
+ }
+ }
+ }
+ r->nnz = nnz;
+ return;
+}
+#endif
+
+/***********************************************************************
+* choose_pivot - choose xB[p] and xN[q]
+*
+* Given the list of eligible basic variables this routine first
+* chooses basic variable xB[p]. This choice is always possible,
+* because the list is assumed to be non-empty. Then the routine
+* computes p-th row T[p,*] of the simplex table T[i,j] and chooses
+* non-basic variable xN[q]. If the pivot T[p,q] is small in magnitude,
+* the routine attempts to choose another xB[p] and xN[q] in order to
+* avoid badly conditioned adjacent bases.
+*
+* If the normal choice was made, the routine returns zero. Otherwise,
+* if the long-step choice was made, the routine returns non-zero. */
+
+#ifdef TIMING /* 31/III-2016 */
+
+#include "choose_pivot.c"
+
+#else
+
+#define MIN_RATIO 0.0001
+
+static int choose_pivot(struct csa *csa)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ SPXAT *at = csa->at;
+ SPXNT *nt = csa->nt;
+ double *beta = csa->beta;
+ double *d = csa->d;
+ SPYSE *se = csa->se;
+#if 0 /* 30/III-2016 */
+ int *list = csa->list;
+#else
+ int *list = csa->r.ind;
+#endif
+ double *rho = csa->work;
+ double *trow = csa->work1;
+ SPYBP *bp = csa->bp;
+ double tol_piv = csa->tol_piv;
+ int try, nnn, j, k, p, q, t, t_best, nbp, ret;
+ double big, temp, r, best_ratio, dz_best;
+ xassert(csa->beta_st);
+ xassert(csa->d_st);
+more: /* initial number of eligible basic variables */
+#if 0 /* 30/III-2016 */
+ nnn = csa->num;
+#else
+ nnn = csa->r.nnz;
+#endif
+ /* nothing has been chosen so far */
+ csa->p = 0;
+ best_ratio = 0.0;
+ try = ret = 0;
+try: /* choose basic variable xB[p] */
+ xassert(nnn > 0);
+ try++;
+ if (se == NULL)
+ { /* dual Dantzig's rule */
+ p = spy_chuzr_std(lp, beta, nnn, list);
+ }
+ else
+ { /* dual projected steepest edge */
+ p = spy_chuzr_pse(lp, se, beta, nnn, list);
+ }
+ xassert(1 <= p && p <= m);
+ /* compute p-th row of inv(B) */
+ spx_eval_rho(lp, p, rho);
+ /* compute p-th row of the simplex table */
+ if (at != NULL)
+ spx_eval_trow1(lp, at, rho, trow);
+ else
+ spx_nt_prod(lp, nt, trow, 1, -1.0, rho);
+#if 1 /* 23/III-2016 */
+ /* big := max(1, |trow[1]|, ..., |trow[n-m]|) */
+ big = 1.0;
+ for (j = 1; j <= n-m; j++)
+ { temp = trow[j];
+ if (temp < 0.0)
+ temp = - temp;
+ if (big < temp)
+ big = temp;
+ }
+#else
+ /* this still puzzles me */
+ big = 1.0;
+#endif
+ /* choose non-basic variable xN[q] */
+ k = head[p]; /* x[k] = xB[p] */
+ xassert(beta[p] < l[k] || beta[p] > u[k]);
+ r = beta[p] < l[k] ? l[k] - beta[p] : u[k] - beta[p];
+ if (csa->r_test == GLP_RT_FLIP && try <= 2)
+ { /* long-step ratio test */
+#if 0 /* 23/III-2016 */
+ /* determine dual objective break-points */
+ nbp = spy_eval_bp(lp, d, r, trow, tol_piv, bp);
+ if (nbp <= 1)
+ goto skip;
+ /* choose appropriate break-point */
+ t_best = 0, dz_best = -DBL_MAX;
+ for (t = 1; t <= nbp; t++)
+ { if (fabs(trow[bp[t].j]) / big >= MIN_RATIO)
+ { if (dz_best < bp[t].dz)
+ t_best = t, dz_best = bp[t].dz;
+ }
+ }
+ if (t_best == 0)
+ goto skip;
+#else
+ int t, num, num1;
+ double slope, teta_lim;
+ /* determine dual objective break-points */
+ nbp = spy_ls_eval_bp(lp, d, r, trow, tol_piv, bp);
+ if (nbp < 2)
+ goto skip;
+ /* set initial slope */
+ slope = fabs(r);
+ /* estimate initial teta_lim */
+ teta_lim = DBL_MAX;
+ for (t = 1; t <= nbp; t++)
+ { if (teta_lim > bp[t].teta)
+ teta_lim = bp[t].teta;
+ }
+ xassert(teta_lim >= 0.0);
+ if (teta_lim < 1e-6)
+ teta_lim = 1e-6;
+ /* nothing has been chosen so far */
+ t_best = 0, dz_best = 0.0, num = 0;
+ /* choose appropriate break-point */
+ while (num < nbp)
+ { /* select and process a new portion of break-points */
+ num1 = spy_ls_select_bp(lp, trow, nbp, bp, num, &slope,
+ teta_lim);
+ for (t = num+1; t <= num1; t++)
+ { if (fabs(trow[bp[t].j]) / big >= MIN_RATIO)
+ { if (dz_best < bp[t].dz)
+ t_best = t, dz_best = bp[t].dz;
+ }
+ }
+ if (slope < 0.0)
+ { /* the dual objective starts decreasing */
+ break;
+ }
+ /* the dual objective continues increasing */
+ num = num1;
+ teta_lim += teta_lim;
+ }
+ if (dz_best == 0.0)
+ goto skip;
+ xassert(1 <= t_best && t_best <= num1);
+#endif
+ /* the choice has been made */
+ csa->p = p;
+#if 0 /* 29/III-2016 */
+ memcpy(&csa->trow[1], &trow[1], (n-m) * sizeof(double));
+#else
+ memcpy(&csa->trow.vec[1], &trow[1], (n-m) * sizeof(double));
+ fvs_gather_vec(&csa->trow, DBL_EPSILON);
+#endif
+ csa->q = bp[t_best].j;
+ best_ratio = fabs(trow[bp[t_best].j]) / big;
+#if 0
+ xprintf("num = %d; t_best = %d; dz = %g\n", num, t_best,
+ bp[t_best].dz);
+#endif
+ ret = 1;
+ goto done;
+skip: ;
+ }
+ if (csa->r_test == GLP_RT_STD)
+ { /* textbook dual ratio test */
+ q = spy_chuzc_std(lp, d, r, trow, tol_piv,
+ .30 * csa->tol_dj, .30 * csa->tol_dj1);
+ }
+ else
+ { /* Harris' two-pass dual ratio test */
+ q = spy_chuzc_harris(lp, d, r, trow, tol_piv,
+ .35 * csa->tol_dj, .35 * csa->tol_dj1);
+ }
+ if (q == 0)
+ { /* dual unboundedness */
+ csa->p = p;
+#if 0 /* 29/III-2016 */
+ memcpy(&csa->trow[1], &trow[1], (n-m) * sizeof(double));
+#else
+ memcpy(&csa->trow.vec[1], &trow[1], (n-m) * sizeof(double));
+ fvs_gather_vec(&csa->trow, DBL_EPSILON);
+#endif
+ csa->q = q;
+ best_ratio = 1.0;
+ goto done;
+ }
+ /* either keep previous choice or accept new choice depending on
+ * which one is better */
+ if (best_ratio < fabs(trow[q]) / big)
+ { csa->p = p;
+#if 0 /* 29/III-2016 */
+ memcpy(&csa->trow[1], &trow[1], (n-m) * sizeof(double));
+#else
+ memcpy(&csa->trow.vec[1], &trow[1], (n-m) * sizeof(double));
+ fvs_gather_vec(&csa->trow, DBL_EPSILON);
+#endif
+ csa->q = q;
+ best_ratio = fabs(trow[q]) / big;
+ }
+ /* check if the current choice is acceptable */
+ if (best_ratio >= MIN_RATIO || nnn == 1 || try == 5)
+ goto done;
+ /* try to choose other xB[p] and xN[q] */
+ /* find xB[p] in the list */
+ for (t = 1; t <= nnn; t++)
+ if (list[t] == p) break;
+ xassert(t <= nnn);
+ /* move xB[p] to the end of the list */
+ list[t] = list[nnn], list[nnn] = p;
+ /* and exclude it from consideration */
+ nnn--;
+ /* repeat the choice */
+ goto try;
+done: /* the choice has been made */
+#if 1 /* FIXME: currently just to avoid badly conditioned basis */
+ if (best_ratio < .001 * MIN_RATIO)
+ { /* looks like this helps */
+ if (bfd_get_count(lp->bfd) > 0)
+ return -1;
+ /* didn't help; last chance to improve the choice */
+ if (tol_piv == csa->tol_piv)
+ { tol_piv *= 1000.;
+ goto more;
+ }
+ }
+#endif
+#if 1 /* FIXME */
+ if (ret)
+ { /* invalidate basic solution components */
+#if 0 /* 28/III-2016 */
+ csa->beta_st = csa->d_st = 0;
+#else
+ /* dual solution remains valid */
+ csa->beta_st = 0;
+#endif
+ /* set double-bounded non-basic variables to opposite bounds
+ * for all break-points preceding the chosen one */
+ for (t = 1; t < t_best; t++)
+ { k = head[m + bp[t].j];
+ xassert(-DBL_MAX < l[k] && l[k] < u[k] && u[k] < +DBL_MAX);
+ lp->flag[bp[t].j] = !(lp->flag[bp[t].j]);
+ }
+ }
+#endif
+ return ret;
+}
+
+#endif
+
+/***********************************************************************
+* play_coef - play objective coefficients
+*
+* This routine is called after the reduced costs d[j] was updated and
+* the basis was changed to the adjacent one.
+*
+* It is assumed that before updating all the reduced costs d[j] were
+* strongly feasible, so in the adjacent basis d[j] remain feasible
+* within a tolerance, i.e. if some d[j] violates its zero bound, the
+* violation is insignificant.
+*
+* If some d[j] violates its zero bound, the routine changes (perturbs)
+* objective coefficient cN[j] to provide d[j] = 0, i.e. to make all
+* d[j] strongly feasible. Otherwise, if d[j] has a feasible value, the
+* routine attempts to reduce (or remove) perturbation in cN[j] by
+* shifting d[j] to its zero bound keeping strong feasibility. */
+
+static void play_coef(struct csa *csa, int all)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *c = lp->c;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *orig_c = csa->orig_c;
+ double *d = csa->d;
+ const double *trow = csa->trow.vec;
+ /* this vector was used to update d = (d[j]) */
+ int j, k;
+ static const double eps = 1e-9;
+ /* reduced costs d = (d[j]) should be valid */
+ xassert(csa->d_st);
+ /* walk thru the list of non-basic variables xN = (xN[j]) */
+ for (j = 1; j <= n-m; j++)
+ { if (all || trow[j] != 0.0)
+ { /* d[j] has changed in the adjacent basis */
+ k = head[m+j]; /* x[k] = xN[j] */
+ if (l[k] == u[k])
+ { /* xN[j] is fixed variable */
+ /* d[j] may have any sign */
+ }
+ else if (l[k] == -DBL_MAX && u[k] == +DBL_MAX)
+ { /* xN[j] is free (unbounded) variable */
+ /* strong feasibility means d[j] = 0 */
+ c[k] -= d[j], d[j] = 0.0;
+ /* in this case dual degeneracy is not critical, since
+ * if xN[j] enters the basis, it never leaves it */
+ }
+ else if (!flag[j])
+ { /* xN[j] has its lower bound active */
+ xassert(l[k] != -DBL_MAX);
+ /* first, we remove current perturbation to provide
+ * c[k] = orig_c[k] */
+ d[j] -= c[k] - orig_c[k], c[k] = orig_c[k];
+ /* strong feasibility means d[j] >= 0, but we provide
+ * d[j] >= +eps to prevent dual degeneracy */
+ if (d[j] < +eps)
+ c[k] -= d[j] - eps, d[j] = +eps;
+ }
+ else
+ { /* xN[j] has its upper bound active */
+ xassert(u[k] != +DBL_MAX);
+ /* similarly, we remove current perturbation to provide
+ * c[k] = orig_c[k] */
+ d[j] -= c[k] - orig_c[k], c[k] = orig_c[k];
+ /* strong feasibility means d[j] <= 0, but we provide
+ * d[j] <= -eps to prevent dual degeneracy */
+ if (d[j] > -eps)
+ c[k] -= d[j] + eps, d[j] = -eps;
+ }
+ }
+ }
+ return;
+}
+
+#if 1 /* 11/VII-2017 */
+static void remove_perturb(struct csa *csa)
+{ /* remove perturbation */
+ SPXLP *lp = csa->lp;
+ int n = lp->n;
+ double *c = lp->c;
+ double *orig_c = csa->orig_c;
+ memcpy(c, orig_c, (1+n) * sizeof(double));
+ /* removing perturbation changes dual solution components */
+ csa->phase = csa->d_st = 0;
+#if 1
+ if (csa->msg_lev >= GLP_MSG_ALL)
+ xprintf("Removing LP perturbation [%d]...\n",
+ csa->it_cnt);
+#endif
+ return;
+}
+#endif
+
+/***********************************************************************
+* display - display search progress
+*
+* This routine displays some information about the search progress
+* that includes:
+*
+* search phase;
+*
+* number of simplex iterations performed by the solver;
+*
+* original objective value (only on phase II);
+*
+* sum of (scaled) dual infeasibilities for original bounds;
+*
+* number of dual infeasibilities (phase I) or primal infeasibilities
+* (phase II);
+*
+* number of basic factorizations since last display output. */
+
+static void display(struct csa *csa, int spec)
+{ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ int *head = lp->head;
+ char *flag = lp->flag;
+ double *l = csa->orig_l; /* original lower bounds */
+ double *u = csa->orig_u; /* original upper bounds */
+ double *beta = csa->beta;
+ double *d = csa->d;
+ int j, k, nnn;
+ double sum;
+#if 1 /* 15/VII-2017 */
+ double tm_cur;
+#endif
+ /* check if the display output should be skipped */
+ if (csa->msg_lev < GLP_MSG_ON) goto skip;
+#if 1 /* 15/VII-2017 */
+ tm_cur = xtime();
+#endif
+ if (csa->out_dly > 0 &&
+#if 0 /* 15/VII-2017 */
+ 1000.0 * xdifftime(xtime(), csa->tm_beg) < csa->out_dly)
+#else
+ 1000.0 * xdifftime(tm_cur, csa->tm_beg) < csa->out_dly)
+#endif
+ goto skip;
+ if (csa->it_cnt == csa->it_dpy) goto skip;
+#if 0 /* 15/VII-2017 */
+ if (!spec && csa->it_cnt % csa->out_frq != 0) goto skip;
+#else
+ if (!spec &&
+ 1000.0 * xdifftime(tm_cur, csa->tm_dpy) < csa->out_frq)
+ goto skip;
+#endif
+ /* display search progress depending on search phase */
+ switch (csa->phase)
+ { case 1:
+ /* compute sum and number of (scaled) dual infeasibilities
+ * for original bounds */
+ sum = 0.0, nnn = 0;
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (d[j] > 0.0)
+ { /* xN[j] should have lower bound */
+ if (l[k] == -DBL_MAX)
+ { sum += d[j];
+ if (d[j] > +1e-7)
+ nnn++;
+ }
+ }
+ else if (d[j] < 0.0)
+ { /* xN[j] should have upper bound */
+ if (u[k] == +DBL_MAX)
+ { sum -= d[j];
+ if (d[j] < -1e-7)
+ nnn++;
+ }
+ }
+ }
+ /* on phase I variables have artificial bounds which are
+ * meaningless for original LP, so corresponding objective
+ * function value is also meaningless */
+#if 0 /* 27/III-2016 */
+ xprintf(" %6d: %23s inf = %11.3e (%d)",
+ csa->it_cnt, "", sum, nnn);
+#else
+ xprintf(" %6d: sum = %17.9e inf = %11.3e (%d)",
+ csa->it_cnt, lp->c[0] - spx_eval_obj(lp, beta),
+ sum, nnn);
+#endif
+ break;
+ case 2:
+ /* compute sum of (scaled) dual infeasibilities */
+ sum = 0.0, nnn = 0;
+ for (j = 1; j <= n-m; j++)
+ { k = head[m+j]; /* x[k] = xN[j] */
+ if (d[j] > 0.0)
+ { /* xN[j] should have its lower bound active */
+ if (l[k] == -DBL_MAX || flag[j])
+ sum += d[j];
+ }
+ else if (d[j] < 0.0)
+ { /* xN[j] should have its upper bound active */
+ if (l[k] != u[k] && !flag[j])
+ sum -= d[j];
+ }
+ }
+ /* compute number of primal infeasibilities */
+ nnn = spy_chuzr_sel(lp, beta, csa->tol_bnd, csa->tol_bnd1,
+ NULL);
+ xprintf("#%6d: obj = %17.9e inf = %11.3e (%d)",
+#if SCALE_Z
+ csa->it_cnt,
+ (double)csa->dir * csa->fz * spx_eval_obj(lp, beta),
+#else
+ csa->it_cnt, (double)csa->dir * spx_eval_obj(lp, beta),
+#endif
+ sum, nnn);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ if (csa->inv_cnt)
+ { /* number of basis factorizations performed */
+ xprintf(" %d", csa->inv_cnt);
+ csa->inv_cnt = 0;
+ }
+#if 1 /* 23/III-2016 */
+ if (csa->r_test == GLP_RT_FLIP)
+ { /*xprintf(" %d,%d", csa->ns_cnt, csa->ls_cnt);*/
+ if (csa->ns_cnt + csa->ls_cnt)
+ xprintf(" %d%%",
+ (100 * csa->ls_cnt) / (csa->ns_cnt + csa->ls_cnt));
+ csa->ns_cnt = csa->ls_cnt = 0;
+ }
+#endif
+ xprintf("\n");
+ csa->it_dpy = csa->it_cnt;
+#if 1 /* 15/VII-2017 */
+ csa->tm_dpy = tm_cur;
+#endif
+skip: return;
+}
+
+#if 1 /* 31/III-2016 */
+static
+void spy_update_r(SPXLP *lp, int p, int q, const double beta[/*1+m*/],
+ const FVS *tcol, double tol, double tol1, FVS *r)
+{ /* update vector r of primal infeasibilities */
+ /* it is assumed that xB[p] leaves the basis, xN[q] enters the
+ * basis, and beta corresponds to the adjacent basis (i.e. this
+ * routine should be called after spx_update_beta) */
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ int *tcol_ind = tcol->ind;
+ int *ind = r->ind;
+ double *vec = r->vec;
+ int i, k, t, nnz;
+ double lk, uk, ri, eps;
+ xassert(1 <= p && p <= m);
+ xassert(1 <= q && q <= n-m);
+ nnz = r->nnz;
+ for (t = tcol->nnz; t >= 1; t--)
+ { i = tcol_ind[t];
+ /* xB[i] changes in the adjacent basis to beta[i], so only
+ * r[i] should be updated */
+ if (i == p)
+ k = head[m+q]; /* x[k] = new xB[p] = old xN[q] */
+ else
+ k = head[i]; /* x[k] = new xB[i] = old xB[i] */
+ lk = l[k], uk = u[k];
+ /* determine new value of r[i]; see spy_eval_r */
+ ri = 0.0;
+ if (beta[i] < lk)
+ { /* determine absolute tolerance eps1[i] */
+ eps = tol + tol1 * (lk >= 0.0 ? +lk : -lk);
+ if (beta[i] < lk - eps)
+ { /* lower bound is violated */
+ ri = lk - beta[i];
+ }
+ }
+ else if (beta[i] > uk)
+ { /* determine absolute tolerance eps2[i] */
+ eps = tol + tol1 * (uk >= 0.0 ? +uk : -uk);
+ if (beta[i] > uk + eps)
+ { /* upper bound is violated */
+ ri = uk - beta[i];
+ }
+ }
+ if (ri == 0.0)
+ { if (vec[i] != 0.0)
+ vec[i] = DBL_MIN; /* will be removed */
+ }
+ else
+ { if (vec[i] == 0.0)
+ ind[++nnz] = i;
+ vec[i] = ri;
+ }
+
+ }
+ r->nnz = nnz;
+ /* remove zero elements */
+ fvs_adjust_vec(r, DBL_MIN + DBL_MIN);
+ return;
+}
+#endif
+
+/***********************************************************************
+* spy_dual - driver to the dual simplex method
+*
+* This routine is a driver to the two-phase dual simplex method.
+*
+* On exit this routine returns one of the following codes:
+*
+* 0 LP instance has been successfully solved.
+*
+* GLP_EOBJLL
+* Objective lower limit has been reached (maximization).
+*
+* GLP_EOBJUL
+* Objective upper limit has been reached (minimization).
+*
+* GLP_EITLIM
+* Iteration limit has been exhausted.
+*
+* GLP_ETMLIM
+* Time limit has been exhausted.
+*
+* GLP_EFAIL
+* The solver failed to solve LP instance. */
+
+static int dual_simplex(struct csa *csa)
+{ /* dual simplex method main logic routine */
+ SPXLP *lp = csa->lp;
+ int m = lp->m;
+ int n = lp->n;
+ double *l = lp->l;
+ double *u = lp->u;
+ int *head = lp->head;
+ SPXNT *nt = csa->nt;
+ double *beta = csa->beta;
+ double *d = csa->d;
+ SPYSE *se = csa->se;
+#if 0 /* 30/III-2016 */
+ int *list = csa->list;
+#endif
+#if 0 /* 31/III-2016 */
+ double *trow = csa->trow;
+ double *tcol = csa->tcol;
+#endif
+ double *pi = csa->work;
+ int msg_lev = csa->msg_lev;
+ double tol_bnd = csa->tol_bnd;
+ double tol_bnd1 = csa->tol_bnd1;
+ double tol_dj = csa->tol_dj;
+ double tol_dj1 = csa->tol_dj1;
+ int j, k, p_flag, refct, ret;
+ int perturb = -1;
+ /* -1 = perturbation is not used, but enabled
+ * 0 = perturbation is not used and disabled
+ * +1 = perturbation is being used */
+#if 1 /* 27/III-2016 */
+ int instab = 0; /* instability count */
+#endif
+#ifdef TIMING
+ double t_total = timer(); /* total time */
+ double t_fact = 0.0; /* computing factorization */
+ double t_rtest = 0.0; /* performing ratio test */
+ double t_pivcol = 0.0; /* computing pivot column */
+ double t_upd1 = 0.0; /* updating primal values */
+ double t_upd2 = 0.0; /* updating dual values */
+ double t_upd3 = 0.0; /* updating se weights */
+ double t_upd4 = 0.0; /* updating matrix N */
+ double t_upd5 = 0.0; /* updating factorization */
+ double t_start;
+#endif
+ check_flags(csa);
+loop: /* main loop starts here */
+ /* compute factorization of the basis matrix */
+ if (!lp->valid)
+ { double cond;
+#ifdef TIMING
+ t_start = timer();
+#endif
+ ret = spx_factorize(lp);
+#ifdef TIMING
+ t_fact += timer() - t_start;
+#endif
+ csa->inv_cnt++;
+ if (ret != 0)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: unable to factorize the basis matrix (%d"
+ ")\n", ret);
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+ /* check condition of the basis matrix */
+ cond = bfd_condest(lp->bfd);
+ if (cond > 1.0 / DBL_EPSILON)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: basis matrix is singular to working prec"
+ "ision (cond = %.3g)\n", cond);
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+ if (cond > 0.001 / DBL_EPSILON)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: basis matrix is ill-conditioned (cond "
+ "= %.3g)\n", cond);
+ }
+ /* invalidate basic solution components */
+ csa->beta_st = csa->d_st = 0;
+ }
+ /* compute reduced costs of non-basic variables d = (d[j]) */
+ if (!csa->d_st)
+ { spx_eval_pi(lp, pi);
+ for (j = 1; j <= n-m; j++)
+ d[j] = spx_eval_dj(lp, pi, j);
+ csa->d_st = 1; /* just computed */
+ /* determine the search phase, if not determined yet (this is
+ * performed only once at the beginning of the search for the
+ * original bounds) */
+ if (!csa->phase)
+ { j = check_feas(csa, 0.97 * tol_dj, 0.97 * tol_dj1, 1);
+ if (j > 0)
+ { /* initial basic solution is dual infeasible and cannot
+ * be recovered */
+ /* start to search for dual feasible solution */
+ set_art_bounds(csa);
+ csa->phase = 1;
+ }
+ else
+ { /* initial basic solution is either dual feasible or its
+ * dual feasibility has been recovered */
+ /* start to search for optimal solution */
+ csa->phase = 2;
+ }
+ }
+ /* make sure that current basic solution is dual feasible */
+#if 1 /* 11/VII-2017 */
+ if (perturb <= 0)
+ { if (check_feas(csa, tol_dj, tol_dj1, 0))
+ { /* dual feasibility is broken due to excessive round-off
+ * errors */
+ if (perturb < 0)
+ { if (msg_lev >= GLP_MSG_ALL)
+ xprintf("Perturbing LP to avoid instability [%d].."
+ ".\n", csa->it_cnt);
+ perturb = 1;
+ goto loop;
+ }
+ if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: numerical instability (dual simplex"
+ ", phase %s)\n", csa->phase == 1 ? "I" : "II");
+ instab++;
+ if (csa->dualp && instab >= 10)
+ { /* do not continue the search; report failure */
+ if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Warning: dual simplex failed due to exces"
+ "sive numerical instability\n");
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = -1; /* special case of GLP_EFAIL */
+ goto fini;
+ }
+ /* try to recover dual feasibility */
+ j = check_feas(csa, 0.97 * tol_dj, 0.97 * tol_dj1, 1);
+ if (j > 0)
+ { /* dual feasibility cannot be recovered (this may
+ * happen only on phase II) */
+ xassert(csa->phase == 2);
+ /* restart to search for dual feasible solution */
+ set_art_bounds(csa);
+ csa->phase = 1;
+ }
+ }
+ }
+ else
+ { /* FIXME */
+ play_coef(csa, 1);
+ }
+ }
+#endif
+ /* at this point the search phase is determined */
+ xassert(csa->phase == 1 || csa->phase == 2);
+ /* compute values of basic variables beta = (beta[i]) */
+ if (!csa->beta_st)
+ { spx_eval_beta(lp, beta);
+#if 1 /* 31/III-2016 */
+ /* also compute vector r of primal infeasibilities */
+ switch (csa->phase)
+ { case 1:
+ spy_eval_r(lp, beta, 1e-8, 0.0, &csa->r);
+ break;
+ case 2:
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+#endif
+ csa->beta_st = 1; /* just computed */
+ }
+ /* reset the dual reference space, if necessary */
+ if (se != NULL && !se->valid)
+ spy_reset_refsp(lp, se), refct = 1000;
+ /* at this point the basis factorization and all basic solution
+ * components are valid */
+ xassert(lp->valid && csa->beta_st && csa->d_st);
+#ifdef GLP_DEBUG
+ check_flags(csa);
+#endif
+#if CHECK_ACCURACY
+ /* check accuracy of current basic solution components (only for
+ * debugging) */
+ check_accuracy(csa);
+#endif
+ /* check if the objective limit has been reached */
+ if (csa->phase == 2 && csa->obj_lim != DBL_MAX
+ && spx_eval_obj(lp, beta) >= csa->obj_lim)
+ {
+#if 1 /* 26/V-2017 by mao */
+ if (perturb > 0)
+ { /* remove perturbation */
+ /* [Should note that perturbing of objective coefficients
+ * implemented in play_coef is equivalent to *relaxing* of
+ * (zero) bounds of dual variables, so the perturbed
+ * objective is always better (*greater*) that the original
+ * one at the same basic point.] */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+#endif
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("OBJECTIVE %s LIMIT REACHED; SEARCH TERMINATED\n",
+ csa->dir > 0 ? "UPPER" : "LOWER");
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, tol_bnd, tol_bnd1, list);
+ csa->p_stat = (csa->num == 0 ? GLP_FEAS : GLP_INFEAS);
+#else
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+ csa->p_stat = (csa->r.nnz == 0 ? GLP_FEAS : GLP_INFEAS);
+#endif
+ csa->d_stat = GLP_FEAS;
+ ret = (csa->dir > 0 ? GLP_EOBJUL : GLP_EOBJLL);
+ goto fini;
+ }
+ /* check if the iteration limit has been exhausted */
+ if (csa->it_cnt - csa->it_beg >= csa->it_lim)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("ITERATION LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ if (csa->phase == 1)
+ { set_orig_bounds(csa);
+ check_flags(csa);
+ spx_eval_beta(lp, beta);
+ }
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, tol_bnd, tol_bnd1, list);
+ csa->p_stat = (csa->num == 0 ? GLP_FEAS : GLP_INFEAS);
+#else
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+ csa->p_stat = (csa->r.nnz == 0 ? GLP_FEAS : GLP_INFEAS);
+#endif
+ csa->d_stat = (csa->phase == 1 ? GLP_INFEAS : GLP_FEAS);
+ ret = GLP_EITLIM;
+ goto fini;
+ }
+ /* check if the time limit has been exhausted */
+ if (1000.0 * xdifftime(xtime(), csa->tm_beg) >= csa->tm_lim)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("TIME LIMIT EXCEEDED; SEARCH TERMINATED\n");
+ if (csa->phase == 1)
+ { set_orig_bounds(csa);
+ check_flags(csa);
+ spx_eval_beta(lp, beta);
+ }
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, tol_bnd, tol_bnd1, list);
+ csa->p_stat = (csa->num == 0 ? GLP_FEAS : GLP_INFEAS);
+#else
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+ csa->p_stat = (csa->r.nnz == 0 ? GLP_FEAS : GLP_INFEAS);
+#endif
+ csa->d_stat = (csa->phase == 1 ? GLP_INFEAS : GLP_FEAS);
+ ret = GLP_ETMLIM;
+ goto fini;
+ }
+ /* display the search progress */
+ display(csa, 0);
+ /* select eligible basic variables */
+#if 0 /* 31/III-2016; not needed because r is valid */
+ switch (csa->phase)
+ { case 1:
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, 1e-8, 0.0, list);
+#else
+ spy_eval_r(lp, beta, 1e-8, 0.0, &csa->r);
+#endif
+ break;
+ case 2:
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, tol_bnd, tol_bnd1, list);
+#else
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+#endif
+ break;
+ default:
+ xassert(csa != csa);
+ }
+#endif
+ /* check for optimality */
+#if 0 /* 30/III-2016 */
+ if (csa->num == 0)
+#else
+ if (csa->r.nnz == 0)
+#endif
+ { if (perturb > 0 && csa->phase == 2)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ /* current basis is optimal */
+ display(csa, 1);
+ switch (csa->phase)
+ { case 1:
+ /* check for dual feasibility */
+ set_orig_bounds(csa);
+ check_flags(csa);
+ if (check_feas(csa, tol_dj, tol_dj1, 0) == 0)
+ { /* dual feasible solution found; switch to phase II */
+ csa->phase = 2;
+ xassert(!csa->beta_st);
+ goto loop;
+ }
+#if 1 /* 26/V-2017 by cmatraki */
+ if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ goto loop;
+ }
+#endif
+ /* no dual feasible solution exists */
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("LP HAS NO DUAL FEASIBLE SOLUTION\n");
+ spx_eval_beta(lp, beta);
+#if 0 /* 30/III-2016 */
+ csa->num = spy_chuzr_sel(lp, beta, tol_bnd, tol_bnd1,
+ list);
+ csa->p_stat = (csa->num == 0 ? GLP_FEAS : GLP_INFEAS);
+#else
+ spy_eval_r(lp, beta, tol_bnd, tol_bnd1, &csa->r);
+ csa->p_stat = (csa->r.nnz == 0 ? GLP_FEAS : GLP_INFEAS);
+#endif
+ csa->d_stat = GLP_NOFEAS;
+ ret = 0;
+ goto fini;
+ case 2:
+ /* optimal solution found */
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("OPTIMAL LP SOLUTION FOUND\n");
+ csa->p_stat = csa->d_stat = GLP_FEAS;
+ ret = 0;
+ goto fini;
+ default:
+ xassert(csa != csa);
+ }
+ }
+ /* choose xB[p] and xN[q] */
+#if 0 /* 23/III-2016 */
+ choose_pivot(csa);
+#else
+#ifdef TIMING
+ t_start = timer();
+#endif
+#if 1 /* 31/III-2016 */
+ ret = choose_pivot(csa);
+#endif
+#ifdef TIMING
+ t_rtest += timer() - t_start;
+#endif
+ if (ret < 0)
+ { lp->valid = 0;
+ goto loop;
+ }
+ if (ret == 0)
+ csa->ns_cnt++;
+ else
+ csa->ls_cnt++;
+#endif
+ /* check for dual unboundedness */
+ if (csa->q == 0)
+ { if (perturb > 0)
+ { /* remove perturbation */
+ remove_perturb(csa);
+ perturb = 0;
+ }
+ if (csa->beta_st != 1)
+ csa->beta_st = 0;
+ if (csa->d_st != 1)
+ csa->d_st = 0;
+ if (!(csa->beta_st && csa->d_st))
+ goto loop;
+ display(csa, 1);
+ switch (csa->phase)
+ { case 1:
+ /* this should never happen */
+ if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: dual simplex failed\n");
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ case 2:
+ /* dual unboundedness detected */
+ if (msg_lev >= GLP_MSG_ALL)
+ xprintf("LP HAS NO PRIMAL FEASIBLE SOLUTION\n");
+ csa->p_stat = GLP_NOFEAS;
+ csa->d_stat = GLP_FEAS;
+ ret = 0;
+ goto fini;
+ default:
+ xassert(csa != csa);
+ }
+ }
+ /* compute q-th column of the simplex table */
+#ifdef TIMING
+ t_start = timer();
+#endif
+#if 0 /* 31/III-2016 */
+ spx_eval_tcol(lp, csa->q, tcol);
+#else
+ spx_eval_tcol(lp, csa->q, csa->tcol.vec);
+ fvs_gather_vec(&csa->tcol, DBL_EPSILON);
+#endif
+#ifdef TIMING
+ t_pivcol += timer() - t_start;
+#endif
+ /* FIXME: tcol[p] and trow[q] should be close to each other */
+#if 0 /* 26/V-2017 by cmatraki */
+ xassert(csa->tcol.vec[csa->p] != 0.0);
+#else
+ if (csa->tcol.vec[csa->p] == 0.0)
+ { if (msg_lev >= GLP_MSG_ERR)
+ xprintf("Error: tcol[p] = 0.0\n");
+ csa->p_stat = csa->d_stat = GLP_UNDEF;
+ ret = GLP_EFAIL;
+ goto fini;
+ }
+#endif
+ /* update values of basic variables for adjacent basis */
+ k = head[csa->p]; /* x[k] = xB[p] */
+ p_flag = (l[k] != u[k] && beta[csa->p] > u[k]);
+#if 0 /* 16/III-2016 */
+ spx_update_beta(lp, beta, csa->p, p_flag, csa->q, tcol);
+ csa->beta_st = 2;
+#else
+ /* primal solution may be invalidated due to long step */
+#ifdef TIMING
+ t_start = timer();
+#endif
+ if (csa->beta_st)
+#if 0 /* 30/III-2016 */
+ { spx_update_beta(lp, beta, csa->p, p_flag, csa->q, tcol);
+#else
+ { spx_update_beta_s(lp, beta, csa->p, p_flag, csa->q,
+ &csa->tcol);
+ /* also update vector r of primal infeasibilities */
+ /*fvs_check_vec(&csa->r);*/
+ switch (csa->phase)
+ { case 1:
+ spy_update_r(lp, csa->p, csa->q, beta, &csa->tcol,
+ 1e-8, 0.0, &csa->r);
+ break;
+ case 2:
+ spy_update_r(lp, csa->p, csa->q, beta, &csa->tcol,
+ tol_bnd, tol_bnd1, &csa->r);
+ break;
+ default:
+ xassert(csa != csa);
+ }
+ /*fvs_check_vec(&csa->r);*/
+#endif
+ csa->beta_st = 2;
+ }
+#ifdef TIMING
+ t_upd1 += timer() - t_start;
+#endif
+#endif
+#if 1 /* 11/VII-2017 */
+ /* check for stalling */
+ { int k;
+ xassert(1 <= csa->p && csa->p <= m);
+ xassert(1 <= csa->q && csa->q <= n-m);
+ /* FIXME: recompute d[q]; see spx_update_d */
+ k = head[m+csa->q]; /* x[k] = xN[q] */
+ if (!(lp->l[k] == -DBL_MAX && lp->u[k] == +DBL_MAX))
+ { if (fabs(d[csa->q]) >= 1e-6)
+ { csa->degen = 0;
+ goto skip1;
+ }
+ /* degenerate iteration has been detected */
+ csa->degen++;
+ if (perturb < 0 && csa->degen >= 200)
+ { if (msg_lev >= GLP_MSG_ALL)
+ xprintf("Perturbing LP to avoid stalling [%d]...\n",
+ csa->it_cnt);
+ perturb = 1;
+ }
+skip1: ;
+ }
+ }
+#endif
+ /* update reduced costs of non-basic variables for adjacent
+ * basis */
+#if 1 /* 28/III-2016 */
+ xassert(csa->d_st);
+#endif
+#ifdef TIMING
+ t_start = timer();
+#endif
+#if 0 /* 30/III-2016 */
+ if (spx_update_d(lp, d, csa->p, csa->q, trow, tcol) <= 1e-9)
+#else
+ if (spx_update_d_s(lp, d, csa->p, csa->q, &csa->trow, &csa->tcol)
+ <= 1e-9)
+#endif
+ { /* successful updating */
+ csa->d_st = 2;
+ }
+ else
+ { /* new reduced costs are inaccurate */
+ csa->d_st = 0;
+ }
+#ifdef TIMING
+ t_upd2 += timer() - t_start;
+#endif
+ /* update steepest edge weights for adjacent basis, if used */
+#ifdef TIMING
+ t_start = timer();
+#endif
+ if (se != NULL)
+ { if (refct > 0)
+#if 0 /* 30/III-2016 */
+ { if (spy_update_gamma(lp, se, csa->p, csa->q, trow, tcol)
+ <= 1e-3)
+#else
+ { if (spy_update_gamma_s(lp, se, csa->p, csa->q, &csa->trow,
+ &csa->tcol) <= 1e-3)
+#endif
+ { /* successful updating */
+ refct--;
+ }
+ else
+ { /* new weights are inaccurate; reset reference space */
+ se->valid = 0;
+ }
+ }
+ else
+ { /* too many updates; reset reference space */
+ se->valid = 0;
+ }
+ }
+#ifdef TIMING
+ t_upd3 += timer() - t_start;
+#endif
+#ifdef TIMING
+ t_start = timer();
+#endif
+ /* update matrix N for adjacent basis, if used */
+ if (nt != NULL)
+ spx_update_nt(lp, nt, csa->p, csa->q);
+#ifdef TIMING
+ t_upd4 += timer() - t_start;
+#endif
+ /* change current basis header to adjacent one */
+ spx_change_basis(lp, csa->p, p_flag, csa->q);
+ /* and update factorization of the basis matrix */
+#ifdef TIMING
+ t_start = timer();
+#endif
+#if 0 /* 16/III-2016 */
+ if (csa->p > 0)
+#endif
+ spx_update_invb(lp, csa->p, head[csa->p]);
+#ifdef TIMING
+ t_upd5 += timer() - t_start;
+#endif
+ if (perturb > 0 && csa->d_st)
+ play_coef(csa, 0);
+ /* dual simplex iteration complete */
+ csa->it_cnt++;
+ goto loop;
+fini:
+#ifdef TIMING
+ t_total = timer() - t_total;
+ xprintf("Total time = %10.3f\n", t_total);
+ xprintf("Factorization = %10.3f\n", t_fact);
+ xprintf("Ratio test = %10.3f\n", t_rtest);
+ xprintf("Pivot column = %10.3f\n", t_pivcol);
+ xprintf("Updating beta = %10.3f\n", t_upd1);
+ xprintf("Updating d = %10.3f\n", t_upd2);
+ xprintf("Updating gamma = %10.3f\n", t_upd3);
+ xprintf("Updating N = %10.3f\n", t_upd4);
+ xprintf("Updating inv(B) = %10.3f\n", t_upd5);
+#endif
+ return ret;
+}
+
+int spy_dual(glp_prob *P, const glp_smcp *parm)
+{ /* driver to the dual simplex method */
+ struct csa csa_, *csa = &csa_;
+ SPXLP lp;
+ SPXAT at;
+ SPXNT nt;
+ SPYSE se;
+ int ret, *map, *daeh;
+#if SCALE_Z
+ int i, j, k;
+#endif
+ /* build working LP and its initial basis */
+ memset(csa, 0, sizeof(struct csa));
+ csa->lp = &lp;
+ spx_init_lp(csa->lp, P, parm->excl);
+ spx_alloc_lp(csa->lp);
+ map = talloc(1+P->m+P->n, int);
+ spx_build_lp(csa->lp, P, parm->excl, parm->shift, map);
+ spx_build_basis(csa->lp, P, map);
+ switch (P->dir)
+ { case GLP_MIN:
+ csa->dir = +1;
+ break;
+ case GLP_MAX:
+ csa->dir = -1;
+ break;
+ default:
+ xassert(P != P);
+ }
+#if SCALE_Z
+ csa->fz = 0.0;
+ for (k = 1; k <= csa->lp->n; k++)
+ { double t = fabs(csa->lp->c[k]);
+ if (csa->fz < t)
+ csa->fz = t;
+ }
+ if (csa->fz <= 1000.0)
+ csa->fz = 1.0;
+ else
+ csa->fz /= 1000.0;
+ /*xprintf("csa->fz = %g\n", csa->fz);*/
+ for (k = 0; k <= csa->lp->n; k++)
+ csa->lp->c[k] /= csa->fz;
+#endif
+ csa->orig_b = talloc(1+csa->lp->m, double);
+ memcpy(csa->orig_b, csa->lp->b, (1+csa->lp->m) * sizeof(double));
+ csa->orig_c = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_c, csa->lp->c, (1+csa->lp->n) * sizeof(double));
+ csa->orig_l = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_l, csa->lp->l, (1+csa->lp->n) * sizeof(double));
+ csa->orig_u = talloc(1+csa->lp->n, double);
+ memcpy(csa->orig_u, csa->lp->u, (1+csa->lp->n) * sizeof(double));
+ switch (parm->aorn)
+ { case GLP_USE_AT:
+ /* build matrix A in row-wise format */
+ csa->at = &at;
+ csa->nt = NULL;
+ spx_alloc_at(csa->lp, csa->at);
+ spx_build_at(csa->lp, csa->at);
+ break;
+ case GLP_USE_NT:
+ /* build matrix N in row-wise format for initial basis */
+ csa->at = NULL;
+ csa->nt = &nt;
+ spx_alloc_nt(csa->lp, csa->nt);
+ spx_init_nt(csa->lp, csa->nt);
+ spx_build_nt(csa->lp, csa->nt);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+ /* allocate and initialize working components */
+ csa->phase = 0;
+ csa->beta = talloc(1+csa->lp->m, double);
+ csa->beta_st = 0;
+ csa->d = talloc(1+csa->lp->n-csa->lp->m, double);
+ csa->d_st = 0;
+ switch (parm->pricing)
+ { case GLP_PT_STD:
+ csa->se = NULL;
+ break;
+ case GLP_PT_PSE:
+ csa->se = &se;
+ spy_alloc_se(csa->lp, csa->se);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+#if 0 /* 30/III-2016 */
+ csa->list = talloc(1+csa->lp->m, int);
+ csa->trow = talloc(1+csa->lp->n-csa->lp->m, double);
+ csa->tcol = talloc(1+csa->lp->m, double);
+#else
+ fvs_alloc_vec(&csa->r, csa->lp->m);
+ fvs_alloc_vec(&csa->trow, csa->lp->n-csa->lp->m);
+ fvs_alloc_vec(&csa->tcol, csa->lp->m);
+#endif
+#if 1 /* 16/III-2016 */
+ csa->bp = NULL;
+#endif
+ csa->work = talloc(1+csa->lp->m, double);
+ csa->work1 = talloc(1+csa->lp->n-csa->lp->m, double);
+#if 0 /* 11/VI-2017 */
+#if 1 /* 31/III-2016 */
+ fvs_alloc_vec(&csa->wrow, csa->lp->n-csa->lp->m);
+ fvs_alloc_vec(&csa->wcol, csa->lp->m);
+#endif
+#endif
+ /* initialize control parameters */
+ csa->msg_lev = parm->msg_lev;
+ csa->dualp = (parm->meth == GLP_DUALP);
+#if 0 /* 16/III-2016 */
+ switch (parm->r_test)
+ { case GLP_RT_STD:
+ csa->harris = 0;
+ break;
+ case GLP_RT_HAR:
+ csa->harris = 1;
+ break;
+ default:
+ xassert(parm != parm);
+ }
+#else
+ switch (parm->r_test)
+ { case GLP_RT_STD:
+ case GLP_RT_HAR:
+ break;
+ case GLP_RT_FLIP:
+ csa->bp = talloc(1+csa->lp->n-csa->lp->m, SPYBP);
+ break;
+ default:
+ xassert(parm != parm);
+ }
+ csa->r_test = parm->r_test;
+#endif
+ csa->tol_bnd = parm->tol_bnd;
+ csa->tol_bnd1 = .001 * parm->tol_bnd;
+ csa->tol_dj = parm->tol_dj;
+ csa->tol_dj1 = .001 * parm->tol_dj;
+#if 0
+ csa->tol_dj1 = 1e-9 * parm->tol_dj;
+#endif
+ csa->tol_piv = parm->tol_piv;
+ switch (P->dir)
+ { case GLP_MIN:
+ csa->obj_lim = + parm->obj_ul;
+ break;
+ case GLP_MAX:
+ csa->obj_lim = - parm->obj_ll;
+ break;
+ default:
+ xassert(parm != parm);
+ }
+#if SCALE_Z
+ if (csa->obj_lim != DBL_MAX)
+ csa->obj_lim /= csa->fz;
+#endif
+ csa->it_lim = parm->it_lim;
+ csa->tm_lim = parm->tm_lim;
+ csa->out_frq = parm->out_frq;
+ csa->out_dly = parm->out_dly;
+ /* initialize working parameters */
+ csa->tm_beg = xtime();
+ csa->it_beg = csa->it_cnt = P->it_cnt;
+ csa->it_dpy = -1;
+#if 1 /* 15/VII-2017 */
+ csa->tm_dpy = 0.0;
+#endif
+ csa->inv_cnt = 0;
+#if 1 /* 11/VII-2017 */
+ csa->degen = 0;
+#endif
+#if 1 /* 23/III-2016 */
+ csa->ns_cnt = csa->ls_cnt = 0;
+#endif
+ /* try to solve working LP */
+ ret = dual_simplex(csa);
+ /* return basis factorization back to problem object */
+ P->valid = csa->lp->valid;
+ P->bfd = csa->lp->bfd;
+ /* set solution status */
+ P->pbs_stat = csa->p_stat;
+ P->dbs_stat = csa->d_stat;
+ /* if the solver failed, do not store basis header and basic
+ * solution components to problem object */
+ if (ret == GLP_EFAIL)
+ goto skip;
+ /* convert working LP basis to original LP basis and store it to
+ * problem object */
+ daeh = talloc(1+csa->lp->n, int);
+ spx_store_basis(csa->lp, P, map, daeh);
+ /* compute simplex multipliers for final basic solution found by
+ * the solver */
+ spx_eval_pi(csa->lp, csa->work);
+ /* convert working LP solution to original LP solution and store
+ * it to problem object */
+#if SCALE_Z
+ for (i = 1; i <= csa->lp->m; i++)
+ csa->work[i] *= csa->fz;
+ for (j = 1; j <= csa->lp->n-csa->lp->m; j++)
+ csa->d[j] *= csa->fz;
+#endif
+ spx_store_sol(csa->lp, P, parm->shift, map, daeh, csa->beta,
+ csa->work, csa->d);
+ tfree(daeh);
+ /* save simplex iteration count */
+ P->it_cnt = csa->it_cnt;
+ /* report auxiliary/structural variable causing unboundedness */
+ P->some = 0;
+ if (csa->p_stat == GLP_NOFEAS && csa->d_stat == GLP_FEAS)
+ { int k, kk;
+ /* xB[p] = x[k] causes dual unboundedness */
+ xassert(1 <= csa->p && csa->p <= csa->lp->m);
+ k = csa->lp->head[csa->p];
+ xassert(1 <= k && k <= csa->lp->n);
+ /* convert to number of original variable */
+ for (kk = 1; kk <= P->m + P->n; kk++)
+ { if (abs(map[kk]) == k)
+ { P->some = kk;
+ break;
+ }
+ }
+ xassert(P->some != 0);
+ }
+skip: /* deallocate working objects and arrays */
+ spx_free_lp(csa->lp);
+ tfree(map);
+ tfree(csa->orig_b);
+ tfree(csa->orig_c);
+ tfree(csa->orig_l);
+ tfree(csa->orig_u);
+ if (csa->at != NULL)
+ spx_free_at(csa->lp, csa->at);
+ if (csa->nt != NULL)
+ spx_free_nt(csa->lp, csa->nt);
+ tfree(csa->beta);
+ tfree(csa->d);
+ if (csa->se != NULL)
+ spy_free_se(csa->lp, csa->se);
+#if 0 /* 30/III-2016 */
+ tfree(csa->list);
+ tfree(csa->trow);
+#else
+ fvs_free_vec(&csa->r);
+ fvs_free_vec(&csa->trow);
+#endif
+#if 1 /* 16/III-2016 */
+ if (csa->bp != NULL)
+ tfree(csa->bp);
+#endif
+#if 0 /* 29/III-2016 */
+ tfree(csa->tcol);
+#else
+ fvs_free_vec(&csa->tcol);
+#endif
+ tfree(csa->work);
+ tfree(csa->work1);
+#if 0 /* 11/VI-2017 */
+#if 1 /* 31/III-2016 */
+ fvs_free_vec(&csa->wrow);
+ fvs_free_vec(&csa->wcol);
+#endif
+#endif
+ /* return to calling program */
+ return ret >= 0 ? ret : GLP_EFAIL;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/zlib/README b/test/monniaux/glpk-4.65/src/zlib/README
new file mode 100644
index 00000000..2796312f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/README
@@ -0,0 +1,45 @@
+NOTE: Files in this subdirectory are NOT part of the GLPK package, but
+ are used with GLPK.
+
+ The original code was modified according to GLPK requirements by
+ Andrew Makhorin <mao@gnu.org>.
+
+ The following files were rewritten:
+ gzguts.h, zconf.h, zutil.h.
+
+ The following files were added:
+ zio.h, zio.c.
+
+ Other files were not changed.
+************************************************************************
+zlib general purpose compression library
+version 1.2.5, April 19th, 2010
+
+Copyright (C) 1995-2010 Jean-loup Gailly and Mark Adler
+
+This software is provided 'as-is', without any express or implied
+warranty. In no event will the authors be held liable for any damages
+arising from the use of this software.
+
+Permission is granted to anyone to use this software for any purpose,
+including commercial applications, and to alter it and redistribute it
+freely, subject to the following restrictions:
+
+1. The origin of this software must not be misrepresented; you must not
+ claim that you wrote the original software. If you use this software
+ in a product, an acknowledgment in the product documentation would
+ be appreciated but is not required.
+
+2. Altered source versions must be plainly marked as such, and must not
+ be misrepresented as being the original software.
+
+3. This notice may not be removed or altered from any source
+ distribution.
+
+Jean-loup Gailly Mark Adler
+jloup@gzip.org madler@alumni.caltech.edu
+
+The data format used by the zlib library is described by RFCs (Request
+for Comments) 1950 to 1952 in the files
+http://www.ietf.org/rfc/rfc1950.txt (zlib format), rfc1951.txt (deflate
+format) and rfc1952.txt (gzip format).
diff --git a/test/monniaux/glpk-4.65/src/zlib/adler32.c b/test/monniaux/glpk-4.65/src/zlib/adler32.c
new file mode 100644
index 00000000..65ad6a5a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/adler32.c
@@ -0,0 +1,169 @@
+/* adler32.c -- compute the Adler-32 checksum of a data stream
+ * Copyright (C) 1995-2007 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#include "zutil.h"
+
+#define local static
+
+local uLong adler32_combine_(uLong adler1, uLong adler2, z_off64_t len2);
+
+#define BASE 65521UL /* largest prime smaller than 65536 */
+#define NMAX 5552
+/* NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 */
+
+#define DO1(buf,i) {adler += (buf)[i]; sum2 += adler;}
+#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
+#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
+#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
+#define DO16(buf) DO8(buf,0); DO8(buf,8);
+
+/* use NO_DIVIDE if your processor does not do division in hardware */
+#ifdef NO_DIVIDE
+# define MOD(a) \
+ do { \
+ if (a >= (BASE << 16)) a -= (BASE << 16); \
+ if (a >= (BASE << 15)) a -= (BASE << 15); \
+ if (a >= (BASE << 14)) a -= (BASE << 14); \
+ if (a >= (BASE << 13)) a -= (BASE << 13); \
+ if (a >= (BASE << 12)) a -= (BASE << 12); \
+ if (a >= (BASE << 11)) a -= (BASE << 11); \
+ if (a >= (BASE << 10)) a -= (BASE << 10); \
+ if (a >= (BASE << 9)) a -= (BASE << 9); \
+ if (a >= (BASE << 8)) a -= (BASE << 8); \
+ if (a >= (BASE << 7)) a -= (BASE << 7); \
+ if (a >= (BASE << 6)) a -= (BASE << 6); \
+ if (a >= (BASE << 5)) a -= (BASE << 5); \
+ if (a >= (BASE << 4)) a -= (BASE << 4); \
+ if (a >= (BASE << 3)) a -= (BASE << 3); \
+ if (a >= (BASE << 2)) a -= (BASE << 2); \
+ if (a >= (BASE << 1)) a -= (BASE << 1); \
+ if (a >= BASE) a -= BASE; \
+ } while (0)
+# define MOD4(a) \
+ do { \
+ if (a >= (BASE << 4)) a -= (BASE << 4); \
+ if (a >= (BASE << 3)) a -= (BASE << 3); \
+ if (a >= (BASE << 2)) a -= (BASE << 2); \
+ if (a >= (BASE << 1)) a -= (BASE << 1); \
+ if (a >= BASE) a -= BASE; \
+ } while (0)
+#else
+# define MOD(a) a %= BASE
+# define MOD4(a) a %= BASE
+#endif
+
+/* ========================================================================= */
+uLong ZEXPORT adler32(adler, buf, len)
+ uLong adler;
+ const Bytef *buf;
+ uInt len;
+{
+ unsigned long sum2;
+ unsigned n;
+
+ /* split Adler-32 into component sums */
+ sum2 = (adler >> 16) & 0xffff;
+ adler &= 0xffff;
+
+ /* in case user likes doing a byte at a time, keep it fast */
+ if (len == 1) {
+ adler += buf[0];
+ if (adler >= BASE)
+ adler -= BASE;
+ sum2 += adler;
+ if (sum2 >= BASE)
+ sum2 -= BASE;
+ return adler | (sum2 << 16);
+ }
+
+ /* initial Adler-32 value (deferred check for len == 1 speed) */
+ if (buf == Z_NULL)
+ return 1L;
+
+ /* in case short lengths are provided, keep it somewhat fast */
+ if (len < 16) {
+ while (len--) {
+ adler += *buf++;
+ sum2 += adler;
+ }
+ if (adler >= BASE)
+ adler -= BASE;
+ MOD4(sum2); /* only added so many BASE's */
+ return adler | (sum2 << 16);
+ }
+
+ /* do length NMAX blocks -- requires just one modulo operation */
+ while (len >= NMAX) {
+ len -= NMAX;
+ n = NMAX / 16; /* NMAX is divisible by 16 */
+ do {
+ DO16(buf); /* 16 sums unrolled */
+ buf += 16;
+ } while (--n);
+ MOD(adler);
+ MOD(sum2);
+ }
+
+ /* do remaining bytes (less than NMAX, still just one modulo) */
+ if (len) { /* avoid modulos if none remaining */
+ while (len >= 16) {
+ len -= 16;
+ DO16(buf);
+ buf += 16;
+ }
+ while (len--) {
+ adler += *buf++;
+ sum2 += adler;
+ }
+ MOD(adler);
+ MOD(sum2);
+ }
+
+ /* return recombined sums */
+ return adler | (sum2 << 16);
+}
+
+/* ========================================================================= */
+local uLong adler32_combine_(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off64_t len2;
+{
+ unsigned long sum1;
+ unsigned long sum2;
+ unsigned rem;
+
+ /* the derivation of this formula is left as an exercise for the reader */
+ rem = (unsigned)(len2 % BASE);
+ sum1 = adler1 & 0xffff;
+ sum2 = rem * sum1;
+ MOD(sum2);
+ sum1 += (adler2 & 0xffff) + BASE - 1;
+ sum2 += ((adler1 >> 16) & 0xffff) + ((adler2 >> 16) & 0xffff) + BASE - rem;
+ if (sum1 >= BASE) sum1 -= BASE;
+ if (sum1 >= BASE) sum1 -= BASE;
+ if (sum2 >= (BASE << 1)) sum2 -= (BASE << 1);
+ if (sum2 >= BASE) sum2 -= BASE;
+ return sum1 | (sum2 << 16);
+}
+
+/* ========================================================================= */
+uLong ZEXPORT adler32_combine(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off_t len2;
+{
+ return adler32_combine_(adler1, adler2, len2);
+}
+
+uLong ZEXPORT adler32_combine64(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off64_t len2;
+{
+ return adler32_combine_(adler1, adler2, len2);
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/compress.c b/test/monniaux/glpk-4.65/src/zlib/compress.c
new file mode 100644
index 00000000..ea4dfbe9
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/compress.c
@@ -0,0 +1,80 @@
+/* compress.c -- compress a memory buffer
+ * Copyright (C) 1995-2005 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#define ZLIB_INTERNAL
+#include "zlib.h"
+
+/* ===========================================================================
+ Compresses the source buffer into the destination buffer. The level
+ parameter has the same meaning as in deflateInit. sourceLen is the byte
+ length of the source buffer. Upon entry, destLen is the total size of the
+ destination buffer, which must be at least 0.1% larger than sourceLen plus
+ 12 bytes. Upon exit, destLen is the actual size of the compressed buffer.
+
+ compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+ Z_STREAM_ERROR if the level parameter is invalid.
+*/
+int ZEXPORT compress2 (dest, destLen, source, sourceLen, level)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+ int level;
+{
+ z_stream stream;
+ int err;
+
+ stream.next_in = (Bytef*)source;
+ stream.avail_in = (uInt)sourceLen;
+#ifdef MAXSEG_64K
+ /* Check for source > 64K on 16-bit machine: */
+ if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR;
+#endif
+ stream.next_out = dest;
+ stream.avail_out = (uInt)*destLen;
+ if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR;
+
+ stream.zalloc = (alloc_func)0;
+ stream.zfree = (free_func)0;
+ stream.opaque = (voidpf)0;
+
+ err = deflateInit(&stream, level);
+ if (err != Z_OK) return err;
+
+ err = deflate(&stream, Z_FINISH);
+ if (err != Z_STREAM_END) {
+ deflateEnd(&stream);
+ return err == Z_OK ? Z_BUF_ERROR : err;
+ }
+ *destLen = stream.total_out;
+
+ err = deflateEnd(&stream);
+ return err;
+}
+
+/* ===========================================================================
+ */
+int ZEXPORT compress (dest, destLen, source, sourceLen)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+{
+ return compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION);
+}
+
+/* ===========================================================================
+ If the default memLevel or windowBits for deflateInit() is changed, then
+ this function needs to be updated.
+ */
+uLong ZEXPORT compressBound (sourceLen)
+ uLong sourceLen;
+{
+ return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) +
+ (sourceLen >> 25) + 13;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/crc32.c b/test/monniaux/glpk-4.65/src/zlib/crc32.c
new file mode 100644
index 00000000..91be372d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/crc32.c
@@ -0,0 +1,442 @@
+/* crc32.c -- compute the CRC-32 of a data stream
+ * Copyright (C) 1995-2006, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ *
+ * Thanks to Rodney Brown <rbrown64@csc.com.au> for his contribution of faster
+ * CRC methods: exclusive-oring 32 bits of data at a time, and pre-computing
+ * tables for updating the shift register in one step with three exclusive-ors
+ * instead of four steps with four exclusive-ors. This results in about a
+ * factor of two increase in speed on a Power PC G4 (PPC7455) using gcc -O3.
+ */
+
+/* @(#) $Id$ */
+
+/*
+ Note on the use of DYNAMIC_CRC_TABLE: there is no mutex or semaphore
+ protection on the static variables used to control the first-use generation
+ of the crc tables. Therefore, if you #define DYNAMIC_CRC_TABLE, you should
+ first call get_crc_table() to initialize the tables before allowing more than
+ one thread to use crc32().
+ */
+
+#ifdef MAKECRCH
+# include <stdio.h>
+# ifndef DYNAMIC_CRC_TABLE
+# define DYNAMIC_CRC_TABLE
+# endif /* !DYNAMIC_CRC_TABLE */
+#endif /* MAKECRCH */
+
+#include "zutil.h" /* for STDC and FAR definitions */
+
+#define local static
+
+/* Find a four-byte integer type for crc32_little() and crc32_big(). */
+#ifndef NOBYFOUR
+# ifdef STDC /* need ANSI C limits.h to determine sizes */
+# include <limits.h>
+# define BYFOUR
+# if (UINT_MAX == 0xffffffffUL)
+ typedef unsigned int u4;
+# else
+# if (ULONG_MAX == 0xffffffffUL)
+ typedef unsigned long u4;
+# else
+# if (USHRT_MAX == 0xffffffffUL)
+ typedef unsigned short u4;
+# else
+# undef BYFOUR /* can't find a four-byte integer type! */
+# endif
+# endif
+# endif
+# endif /* STDC */
+#endif /* !NOBYFOUR */
+
+/* Definitions for doing the crc four data bytes at a time. */
+#ifdef BYFOUR
+# define REV(w) ((((w)>>24)&0xff)+(((w)>>8)&0xff00)+ \
+ (((w)&0xff00)<<8)+(((w)&0xff)<<24))
+ local unsigned long crc32_little OF((unsigned long,
+ const unsigned char FAR *, unsigned));
+ local unsigned long crc32_big OF((unsigned long,
+ const unsigned char FAR *, unsigned));
+# define TBLS 8
+#else
+# define TBLS 1
+#endif /* BYFOUR */
+
+/* Local functions for crc concatenation */
+local unsigned long gf2_matrix_times OF((unsigned long *mat,
+ unsigned long vec));
+local void gf2_matrix_square OF((unsigned long *square, unsigned long *mat));
+local uLong crc32_combine_(uLong crc1, uLong crc2, z_off64_t len2);
+
+
+#ifdef DYNAMIC_CRC_TABLE
+
+local volatile int crc_table_empty = 1;
+local unsigned long FAR crc_table[TBLS][256];
+local void make_crc_table OF((void));
+#ifdef MAKECRCH
+ local void write_table OF((FILE *, const unsigned long FAR *));
+#endif /* MAKECRCH */
+/*
+ Generate tables for a byte-wise 32-bit CRC calculation on the polynomial:
+ x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
+
+ Polynomials over GF(2) are represented in binary, one bit per coefficient,
+ with the lowest powers in the most significant bit. Then adding polynomials
+ is just exclusive-or, and multiplying a polynomial by x is a right shift by
+ one. If we call the above polynomial p, and represent a byte as the
+ polynomial q, also with the lowest power in the most significant bit (so the
+ byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
+ where a mod b means the remainder after dividing a by b.
+
+ This calculation is done using the shift-register method of multiplying and
+ taking the remainder. The register is initialized to zero, and for each
+ incoming bit, x^32 is added mod p to the register if the bit is a one (where
+ x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
+ x (which is shifting right by one and adding x^32 mod p if the bit shifted
+ out is a one). We start with the highest power (least significant bit) of
+ q and repeat for all eight bits of q.
+
+ The first table is simply the CRC of all possible eight bit values. This is
+ all the information needed to generate CRCs on data a byte at a time for all
+ combinations of CRC register values and incoming bytes. The remaining tables
+ allow for word-at-a-time CRC calculation for both big-endian and little-
+ endian machines, where a word is four bytes.
+*/
+local void make_crc_table()
+{
+ unsigned long c;
+ int n, k;
+ unsigned long poly; /* polynomial exclusive-or pattern */
+ /* terms of polynomial defining this crc (except x^32): */
+ static volatile int first = 1; /* flag to limit concurrent making */
+ static const unsigned char p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26};
+
+ /* See if another task is already doing this (not thread-safe, but better
+ than nothing -- significantly reduces duration of vulnerability in
+ case the advice about DYNAMIC_CRC_TABLE is ignored) */
+ if (first) {
+ first = 0;
+
+ /* make exclusive-or pattern from polynomial (0xedb88320UL) */
+ poly = 0UL;
+ for (n = 0; n < sizeof(p)/sizeof(unsigned char); n++)
+ poly |= 1UL << (31 - p[n]);
+
+ /* generate a crc for every 8-bit value */
+ for (n = 0; n < 256; n++) {
+ c = (unsigned long)n;
+ for (k = 0; k < 8; k++)
+ c = c & 1 ? poly ^ (c >> 1) : c >> 1;
+ crc_table[0][n] = c;
+ }
+
+#ifdef BYFOUR
+ /* generate crc for each value followed by one, two, and three zeros,
+ and then the byte reversal of those as well as the first table */
+ for (n = 0; n < 256; n++) {
+ c = crc_table[0][n];
+ crc_table[4][n] = REV(c);
+ for (k = 1; k < 4; k++) {
+ c = crc_table[0][c & 0xff] ^ (c >> 8);
+ crc_table[k][n] = c;
+ crc_table[k + 4][n] = REV(c);
+ }
+ }
+#endif /* BYFOUR */
+
+ crc_table_empty = 0;
+ }
+ else { /* not first */
+ /* wait for the other guy to finish (not efficient, but rare) */
+ while (crc_table_empty)
+ ;
+ }
+
+#ifdef MAKECRCH
+ /* write out CRC tables to crc32.h */
+ {
+ FILE *out;
+
+ out = fopen("crc32.h", "w");
+ if (out == NULL) return;
+ fprintf(out, "/* crc32.h -- tables for rapid CRC calculation\n");
+ fprintf(out, " * Generated automatically by crc32.c\n */\n\n");
+ fprintf(out, "local const unsigned long FAR ");
+ fprintf(out, "crc_table[TBLS][256] =\n{\n {\n");
+ write_table(out, crc_table[0]);
+# ifdef BYFOUR
+ fprintf(out, "#ifdef BYFOUR\n");
+ for (k = 1; k < 8; k++) {
+ fprintf(out, " },\n {\n");
+ write_table(out, crc_table[k]);
+ }
+ fprintf(out, "#endif\n");
+# endif /* BYFOUR */
+ fprintf(out, " }\n};\n");
+ fclose(out);
+ }
+#endif /* MAKECRCH */
+}
+
+#ifdef MAKECRCH
+local void write_table(out, table)
+ FILE *out;
+ const unsigned long FAR *table;
+{
+ int n;
+
+ for (n = 0; n < 256; n++)
+ fprintf(out, "%s0x%08lxUL%s", n % 5 ? "" : " ", table[n],
+ n == 255 ? "\n" : (n % 5 == 4 ? ",\n" : ", "));
+}
+#endif /* MAKECRCH */
+
+#else /* !DYNAMIC_CRC_TABLE */
+/* ========================================================================
+ * Tables of CRC-32s of all single-byte values, made by make_crc_table().
+ */
+#include "crc32.h"
+#endif /* DYNAMIC_CRC_TABLE */
+
+/* =========================================================================
+ * This function can be used by asm versions of crc32()
+ */
+const unsigned long FAR * ZEXPORT get_crc_table()
+{
+#ifdef DYNAMIC_CRC_TABLE
+ if (crc_table_empty)
+ make_crc_table();
+#endif /* DYNAMIC_CRC_TABLE */
+ return (const unsigned long FAR *)crc_table;
+}
+
+/* ========================================================================= */
+#define DO1 crc = crc_table[0][((int)crc ^ (*buf++)) & 0xff] ^ (crc >> 8)
+#define DO8 DO1; DO1; DO1; DO1; DO1; DO1; DO1; DO1
+
+/* ========================================================================= */
+unsigned long ZEXPORT crc32(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ uInt len;
+{
+ if (buf == Z_NULL) return 0UL;
+
+#ifdef DYNAMIC_CRC_TABLE
+ if (crc_table_empty)
+ make_crc_table();
+#endif /* DYNAMIC_CRC_TABLE */
+
+#ifdef BYFOUR
+ if (sizeof(void *) == sizeof(ptrdiff_t)) {
+ u4 endian;
+
+ endian = 1;
+ if (*((unsigned char *)(&endian)))
+ return crc32_little(crc, buf, len);
+ else
+ return crc32_big(crc, buf, len);
+ }
+#endif /* BYFOUR */
+ crc = crc ^ 0xffffffffUL;
+ while (len >= 8) {
+ DO8;
+ len -= 8;
+ }
+ if (len) do {
+ DO1;
+ } while (--len);
+ return crc ^ 0xffffffffUL;
+}
+
+#ifdef BYFOUR
+
+/* ========================================================================= */
+#define DOLIT4 c ^= *buf4++; \
+ c = crc_table[3][c & 0xff] ^ crc_table[2][(c >> 8) & 0xff] ^ \
+ crc_table[1][(c >> 16) & 0xff] ^ crc_table[0][c >> 24]
+#define DOLIT32 DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4
+
+/* ========================================================================= */
+local unsigned long crc32_little(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ unsigned len;
+{
+ register u4 c;
+ register const u4 FAR *buf4;
+
+ c = (u4)crc;
+ c = ~c;
+ while (len && ((ptrdiff_t)buf & 3)) {
+ c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8);
+ len--;
+ }
+
+ buf4 = (const u4 FAR *)(const void FAR *)buf;
+ while (len >= 32) {
+ DOLIT32;
+ len -= 32;
+ }
+ while (len >= 4) {
+ DOLIT4;
+ len -= 4;
+ }
+ buf = (const unsigned char FAR *)buf4;
+
+ if (len) do {
+ c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8);
+ } while (--len);
+ c = ~c;
+ return (unsigned long)c;
+}
+
+/* ========================================================================= */
+#define DOBIG4 c ^= *++buf4; \
+ c = crc_table[4][c & 0xff] ^ crc_table[5][(c >> 8) & 0xff] ^ \
+ crc_table[6][(c >> 16) & 0xff] ^ crc_table[7][c >> 24]
+#define DOBIG32 DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4
+
+/* ========================================================================= */
+local unsigned long crc32_big(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ unsigned len;
+{
+ register u4 c;
+ register const u4 FAR *buf4;
+
+ c = REV((u4)crc);
+ c = ~c;
+ while (len && ((ptrdiff_t)buf & 3)) {
+ c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8);
+ len--;
+ }
+
+ buf4 = (const u4 FAR *)(const void FAR *)buf;
+ buf4--;
+ while (len >= 32) {
+ DOBIG32;
+ len -= 32;
+ }
+ while (len >= 4) {
+ DOBIG4;
+ len -= 4;
+ }
+ buf4++;
+ buf = (const unsigned char FAR *)buf4;
+
+ if (len) do {
+ c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8);
+ } while (--len);
+ c = ~c;
+ return (unsigned long)(REV(c));
+}
+
+#endif /* BYFOUR */
+
+#define GF2_DIM 32 /* dimension of GF(2) vectors (length of CRC) */
+
+/* ========================================================================= */
+local unsigned long gf2_matrix_times(mat, vec)
+ unsigned long *mat;
+ unsigned long vec;
+{
+ unsigned long sum;
+
+ sum = 0;
+ while (vec) {
+ if (vec & 1)
+ sum ^= *mat;
+ vec >>= 1;
+ mat++;
+ }
+ return sum;
+}
+
+/* ========================================================================= */
+local void gf2_matrix_square(square, mat)
+ unsigned long *square;
+ unsigned long *mat;
+{
+ int n;
+
+ for (n = 0; n < GF2_DIM; n++)
+ square[n] = gf2_matrix_times(mat, mat[n]);
+}
+
+/* ========================================================================= */
+local uLong crc32_combine_(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off64_t len2;
+{
+ int n;
+ unsigned long row;
+ unsigned long even[GF2_DIM]; /* even-power-of-two zeros operator */
+ unsigned long odd[GF2_DIM]; /* odd-power-of-two zeros operator */
+
+ /* degenerate case (also disallow negative lengths) */
+ if (len2 <= 0)
+ return crc1;
+
+ /* put operator for one zero bit in odd */
+ odd[0] = 0xedb88320UL; /* CRC-32 polynomial */
+ row = 1;
+ for (n = 1; n < GF2_DIM; n++) {
+ odd[n] = row;
+ row <<= 1;
+ }
+
+ /* put operator for two zero bits in even */
+ gf2_matrix_square(even, odd);
+
+ /* put operator for four zero bits in odd */
+ gf2_matrix_square(odd, even);
+
+ /* apply len2 zeros to crc1 (first square will put the operator for one
+ zero byte, eight zero bits, in even) */
+ do {
+ /* apply zeros operator for this bit of len2 */
+ gf2_matrix_square(even, odd);
+ if (len2 & 1)
+ crc1 = gf2_matrix_times(even, crc1);
+ len2 >>= 1;
+
+ /* if no more bits set, then done */
+ if (len2 == 0)
+ break;
+
+ /* another iteration of the loop with odd and even swapped */
+ gf2_matrix_square(odd, even);
+ if (len2 & 1)
+ crc1 = gf2_matrix_times(odd, crc1);
+ len2 >>= 1;
+
+ /* if no more bits set, then done */
+ } while (len2 != 0);
+
+ /* return combined crc */
+ crc1 ^= crc2;
+ return crc1;
+}
+
+/* ========================================================================= */
+uLong ZEXPORT crc32_combine(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off_t len2;
+{
+ return crc32_combine_(crc1, crc2, len2);
+}
+
+uLong ZEXPORT crc32_combine64(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off64_t len2;
+{
+ return crc32_combine_(crc1, crc2, len2);
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/crc32.h b/test/monniaux/glpk-4.65/src/zlib/crc32.h
new file mode 100644
index 00000000..8053b611
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/crc32.h
@@ -0,0 +1,441 @@
+/* crc32.h -- tables for rapid CRC calculation
+ * Generated automatically by crc32.c
+ */
+
+local const unsigned long FAR crc_table[TBLS][256] =
+{
+ {
+ 0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL,
+ 0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL,
+ 0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL,
+ 0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL,
+ 0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL,
+ 0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL,
+ 0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL,
+ 0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL,
+ 0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL,
+ 0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL,
+ 0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL,
+ 0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL,
+ 0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL,
+ 0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL,
+ 0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL,
+ 0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL,
+ 0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL,
+ 0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL,
+ 0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL,
+ 0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL,
+ 0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL,
+ 0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL,
+ 0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL,
+ 0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL,
+ 0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL,
+ 0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL,
+ 0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL,
+ 0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL,
+ 0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL,
+ 0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL,
+ 0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL,
+ 0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL,
+ 0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL,
+ 0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL,
+ 0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL,
+ 0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL,
+ 0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL,
+ 0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL,
+ 0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL,
+ 0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL,
+ 0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL,
+ 0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL,
+ 0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL,
+ 0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL,
+ 0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL,
+ 0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL,
+ 0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL,
+ 0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL,
+ 0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL,
+ 0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL,
+ 0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL,
+ 0x2d02ef8dUL
+#ifdef BYFOUR
+ },
+ {
+ 0x00000000UL, 0x191b3141UL, 0x32366282UL, 0x2b2d53c3UL, 0x646cc504UL,
+ 0x7d77f445UL, 0x565aa786UL, 0x4f4196c7UL, 0xc8d98a08UL, 0xd1c2bb49UL,
+ 0xfaefe88aUL, 0xe3f4d9cbUL, 0xacb54f0cUL, 0xb5ae7e4dUL, 0x9e832d8eUL,
+ 0x87981ccfUL, 0x4ac21251UL, 0x53d92310UL, 0x78f470d3UL, 0x61ef4192UL,
+ 0x2eaed755UL, 0x37b5e614UL, 0x1c98b5d7UL, 0x05838496UL, 0x821b9859UL,
+ 0x9b00a918UL, 0xb02dfadbUL, 0xa936cb9aUL, 0xe6775d5dUL, 0xff6c6c1cUL,
+ 0xd4413fdfUL, 0xcd5a0e9eUL, 0x958424a2UL, 0x8c9f15e3UL, 0xa7b24620UL,
+ 0xbea97761UL, 0xf1e8e1a6UL, 0xe8f3d0e7UL, 0xc3de8324UL, 0xdac5b265UL,
+ 0x5d5daeaaUL, 0x44469febUL, 0x6f6bcc28UL, 0x7670fd69UL, 0x39316baeUL,
+ 0x202a5aefUL, 0x0b07092cUL, 0x121c386dUL, 0xdf4636f3UL, 0xc65d07b2UL,
+ 0xed705471UL, 0xf46b6530UL, 0xbb2af3f7UL, 0xa231c2b6UL, 0x891c9175UL,
+ 0x9007a034UL, 0x179fbcfbUL, 0x0e848dbaUL, 0x25a9de79UL, 0x3cb2ef38UL,
+ 0x73f379ffUL, 0x6ae848beUL, 0x41c51b7dUL, 0x58de2a3cUL, 0xf0794f05UL,
+ 0xe9627e44UL, 0xc24f2d87UL, 0xdb541cc6UL, 0x94158a01UL, 0x8d0ebb40UL,
+ 0xa623e883UL, 0xbf38d9c2UL, 0x38a0c50dUL, 0x21bbf44cUL, 0x0a96a78fUL,
+ 0x138d96ceUL, 0x5ccc0009UL, 0x45d73148UL, 0x6efa628bUL, 0x77e153caUL,
+ 0xbabb5d54UL, 0xa3a06c15UL, 0x888d3fd6UL, 0x91960e97UL, 0xded79850UL,
+ 0xc7cca911UL, 0xece1fad2UL, 0xf5facb93UL, 0x7262d75cUL, 0x6b79e61dUL,
+ 0x4054b5deUL, 0x594f849fUL, 0x160e1258UL, 0x0f152319UL, 0x243870daUL,
+ 0x3d23419bUL, 0x65fd6ba7UL, 0x7ce65ae6UL, 0x57cb0925UL, 0x4ed03864UL,
+ 0x0191aea3UL, 0x188a9fe2UL, 0x33a7cc21UL, 0x2abcfd60UL, 0xad24e1afUL,
+ 0xb43fd0eeUL, 0x9f12832dUL, 0x8609b26cUL, 0xc94824abUL, 0xd05315eaUL,
+ 0xfb7e4629UL, 0xe2657768UL, 0x2f3f79f6UL, 0x362448b7UL, 0x1d091b74UL,
+ 0x04122a35UL, 0x4b53bcf2UL, 0x52488db3UL, 0x7965de70UL, 0x607eef31UL,
+ 0xe7e6f3feUL, 0xfefdc2bfUL, 0xd5d0917cUL, 0xcccba03dUL, 0x838a36faUL,
+ 0x9a9107bbUL, 0xb1bc5478UL, 0xa8a76539UL, 0x3b83984bUL, 0x2298a90aUL,
+ 0x09b5fac9UL, 0x10aecb88UL, 0x5fef5d4fUL, 0x46f46c0eUL, 0x6dd93fcdUL,
+ 0x74c20e8cUL, 0xf35a1243UL, 0xea412302UL, 0xc16c70c1UL, 0xd8774180UL,
+ 0x9736d747UL, 0x8e2de606UL, 0xa500b5c5UL, 0xbc1b8484UL, 0x71418a1aUL,
+ 0x685abb5bUL, 0x4377e898UL, 0x5a6cd9d9UL, 0x152d4f1eUL, 0x0c367e5fUL,
+ 0x271b2d9cUL, 0x3e001cddUL, 0xb9980012UL, 0xa0833153UL, 0x8bae6290UL,
+ 0x92b553d1UL, 0xddf4c516UL, 0xc4eff457UL, 0xefc2a794UL, 0xf6d996d5UL,
+ 0xae07bce9UL, 0xb71c8da8UL, 0x9c31de6bUL, 0x852aef2aUL, 0xca6b79edUL,
+ 0xd37048acUL, 0xf85d1b6fUL, 0xe1462a2eUL, 0x66de36e1UL, 0x7fc507a0UL,
+ 0x54e85463UL, 0x4df36522UL, 0x02b2f3e5UL, 0x1ba9c2a4UL, 0x30849167UL,
+ 0x299fa026UL, 0xe4c5aeb8UL, 0xfdde9ff9UL, 0xd6f3cc3aUL, 0xcfe8fd7bUL,
+ 0x80a96bbcUL, 0x99b25afdUL, 0xb29f093eUL, 0xab84387fUL, 0x2c1c24b0UL,
+ 0x350715f1UL, 0x1e2a4632UL, 0x07317773UL, 0x4870e1b4UL, 0x516bd0f5UL,
+ 0x7a468336UL, 0x635db277UL, 0xcbfad74eUL, 0xd2e1e60fUL, 0xf9ccb5ccUL,
+ 0xe0d7848dUL, 0xaf96124aUL, 0xb68d230bUL, 0x9da070c8UL, 0x84bb4189UL,
+ 0x03235d46UL, 0x1a386c07UL, 0x31153fc4UL, 0x280e0e85UL, 0x674f9842UL,
+ 0x7e54a903UL, 0x5579fac0UL, 0x4c62cb81UL, 0x8138c51fUL, 0x9823f45eUL,
+ 0xb30ea79dUL, 0xaa1596dcUL, 0xe554001bUL, 0xfc4f315aUL, 0xd7626299UL,
+ 0xce7953d8UL, 0x49e14f17UL, 0x50fa7e56UL, 0x7bd72d95UL, 0x62cc1cd4UL,
+ 0x2d8d8a13UL, 0x3496bb52UL, 0x1fbbe891UL, 0x06a0d9d0UL, 0x5e7ef3ecUL,
+ 0x4765c2adUL, 0x6c48916eUL, 0x7553a02fUL, 0x3a1236e8UL, 0x230907a9UL,
+ 0x0824546aUL, 0x113f652bUL, 0x96a779e4UL, 0x8fbc48a5UL, 0xa4911b66UL,
+ 0xbd8a2a27UL, 0xf2cbbce0UL, 0xebd08da1UL, 0xc0fdde62UL, 0xd9e6ef23UL,
+ 0x14bce1bdUL, 0x0da7d0fcUL, 0x268a833fUL, 0x3f91b27eUL, 0x70d024b9UL,
+ 0x69cb15f8UL, 0x42e6463bUL, 0x5bfd777aUL, 0xdc656bb5UL, 0xc57e5af4UL,
+ 0xee530937UL, 0xf7483876UL, 0xb809aeb1UL, 0xa1129ff0UL, 0x8a3fcc33UL,
+ 0x9324fd72UL
+ },
+ {
+ 0x00000000UL, 0x01c26a37UL, 0x0384d46eUL, 0x0246be59UL, 0x0709a8dcUL,
+ 0x06cbc2ebUL, 0x048d7cb2UL, 0x054f1685UL, 0x0e1351b8UL, 0x0fd13b8fUL,
+ 0x0d9785d6UL, 0x0c55efe1UL, 0x091af964UL, 0x08d89353UL, 0x0a9e2d0aUL,
+ 0x0b5c473dUL, 0x1c26a370UL, 0x1de4c947UL, 0x1fa2771eUL, 0x1e601d29UL,
+ 0x1b2f0bacUL, 0x1aed619bUL, 0x18abdfc2UL, 0x1969b5f5UL, 0x1235f2c8UL,
+ 0x13f798ffUL, 0x11b126a6UL, 0x10734c91UL, 0x153c5a14UL, 0x14fe3023UL,
+ 0x16b88e7aUL, 0x177ae44dUL, 0x384d46e0UL, 0x398f2cd7UL, 0x3bc9928eUL,
+ 0x3a0bf8b9UL, 0x3f44ee3cUL, 0x3e86840bUL, 0x3cc03a52UL, 0x3d025065UL,
+ 0x365e1758UL, 0x379c7d6fUL, 0x35dac336UL, 0x3418a901UL, 0x3157bf84UL,
+ 0x3095d5b3UL, 0x32d36beaUL, 0x331101ddUL, 0x246be590UL, 0x25a98fa7UL,
+ 0x27ef31feUL, 0x262d5bc9UL, 0x23624d4cUL, 0x22a0277bUL, 0x20e69922UL,
+ 0x2124f315UL, 0x2a78b428UL, 0x2bbade1fUL, 0x29fc6046UL, 0x283e0a71UL,
+ 0x2d711cf4UL, 0x2cb376c3UL, 0x2ef5c89aUL, 0x2f37a2adUL, 0x709a8dc0UL,
+ 0x7158e7f7UL, 0x731e59aeUL, 0x72dc3399UL, 0x7793251cUL, 0x76514f2bUL,
+ 0x7417f172UL, 0x75d59b45UL, 0x7e89dc78UL, 0x7f4bb64fUL, 0x7d0d0816UL,
+ 0x7ccf6221UL, 0x798074a4UL, 0x78421e93UL, 0x7a04a0caUL, 0x7bc6cafdUL,
+ 0x6cbc2eb0UL, 0x6d7e4487UL, 0x6f38fadeUL, 0x6efa90e9UL, 0x6bb5866cUL,
+ 0x6a77ec5bUL, 0x68315202UL, 0x69f33835UL, 0x62af7f08UL, 0x636d153fUL,
+ 0x612bab66UL, 0x60e9c151UL, 0x65a6d7d4UL, 0x6464bde3UL, 0x662203baUL,
+ 0x67e0698dUL, 0x48d7cb20UL, 0x4915a117UL, 0x4b531f4eUL, 0x4a917579UL,
+ 0x4fde63fcUL, 0x4e1c09cbUL, 0x4c5ab792UL, 0x4d98dda5UL, 0x46c49a98UL,
+ 0x4706f0afUL, 0x45404ef6UL, 0x448224c1UL, 0x41cd3244UL, 0x400f5873UL,
+ 0x4249e62aUL, 0x438b8c1dUL, 0x54f16850UL, 0x55330267UL, 0x5775bc3eUL,
+ 0x56b7d609UL, 0x53f8c08cUL, 0x523aaabbUL, 0x507c14e2UL, 0x51be7ed5UL,
+ 0x5ae239e8UL, 0x5b2053dfUL, 0x5966ed86UL, 0x58a487b1UL, 0x5deb9134UL,
+ 0x5c29fb03UL, 0x5e6f455aUL, 0x5fad2f6dUL, 0xe1351b80UL, 0xe0f771b7UL,
+ 0xe2b1cfeeUL, 0xe373a5d9UL, 0xe63cb35cUL, 0xe7fed96bUL, 0xe5b86732UL,
+ 0xe47a0d05UL, 0xef264a38UL, 0xeee4200fUL, 0xeca29e56UL, 0xed60f461UL,
+ 0xe82fe2e4UL, 0xe9ed88d3UL, 0xebab368aUL, 0xea695cbdUL, 0xfd13b8f0UL,
+ 0xfcd1d2c7UL, 0xfe976c9eUL, 0xff5506a9UL, 0xfa1a102cUL, 0xfbd87a1bUL,
+ 0xf99ec442UL, 0xf85cae75UL, 0xf300e948UL, 0xf2c2837fUL, 0xf0843d26UL,
+ 0xf1465711UL, 0xf4094194UL, 0xf5cb2ba3UL, 0xf78d95faUL, 0xf64fffcdUL,
+ 0xd9785d60UL, 0xd8ba3757UL, 0xdafc890eUL, 0xdb3ee339UL, 0xde71f5bcUL,
+ 0xdfb39f8bUL, 0xddf521d2UL, 0xdc374be5UL, 0xd76b0cd8UL, 0xd6a966efUL,
+ 0xd4efd8b6UL, 0xd52db281UL, 0xd062a404UL, 0xd1a0ce33UL, 0xd3e6706aUL,
+ 0xd2241a5dUL, 0xc55efe10UL, 0xc49c9427UL, 0xc6da2a7eUL, 0xc7184049UL,
+ 0xc25756ccUL, 0xc3953cfbUL, 0xc1d382a2UL, 0xc011e895UL, 0xcb4dafa8UL,
+ 0xca8fc59fUL, 0xc8c97bc6UL, 0xc90b11f1UL, 0xcc440774UL, 0xcd866d43UL,
+ 0xcfc0d31aUL, 0xce02b92dUL, 0x91af9640UL, 0x906dfc77UL, 0x922b422eUL,
+ 0x93e92819UL, 0x96a63e9cUL, 0x976454abUL, 0x9522eaf2UL, 0x94e080c5UL,
+ 0x9fbcc7f8UL, 0x9e7eadcfUL, 0x9c381396UL, 0x9dfa79a1UL, 0x98b56f24UL,
+ 0x99770513UL, 0x9b31bb4aUL, 0x9af3d17dUL, 0x8d893530UL, 0x8c4b5f07UL,
+ 0x8e0de15eUL, 0x8fcf8b69UL, 0x8a809decUL, 0x8b42f7dbUL, 0x89044982UL,
+ 0x88c623b5UL, 0x839a6488UL, 0x82580ebfUL, 0x801eb0e6UL, 0x81dcdad1UL,
+ 0x8493cc54UL, 0x8551a663UL, 0x8717183aUL, 0x86d5720dUL, 0xa9e2d0a0UL,
+ 0xa820ba97UL, 0xaa6604ceUL, 0xaba46ef9UL, 0xaeeb787cUL, 0xaf29124bUL,
+ 0xad6fac12UL, 0xacadc625UL, 0xa7f18118UL, 0xa633eb2fUL, 0xa4755576UL,
+ 0xa5b73f41UL, 0xa0f829c4UL, 0xa13a43f3UL, 0xa37cfdaaUL, 0xa2be979dUL,
+ 0xb5c473d0UL, 0xb40619e7UL, 0xb640a7beUL, 0xb782cd89UL, 0xb2cddb0cUL,
+ 0xb30fb13bUL, 0xb1490f62UL, 0xb08b6555UL, 0xbbd72268UL, 0xba15485fUL,
+ 0xb853f606UL, 0xb9919c31UL, 0xbcde8ab4UL, 0xbd1ce083UL, 0xbf5a5edaUL,
+ 0xbe9834edUL
+ },
+ {
+ 0x00000000UL, 0xb8bc6765UL, 0xaa09c88bUL, 0x12b5afeeUL, 0x8f629757UL,
+ 0x37def032UL, 0x256b5fdcUL, 0x9dd738b9UL, 0xc5b428efUL, 0x7d084f8aUL,
+ 0x6fbde064UL, 0xd7018701UL, 0x4ad6bfb8UL, 0xf26ad8ddUL, 0xe0df7733UL,
+ 0x58631056UL, 0x5019579fUL, 0xe8a530faUL, 0xfa109f14UL, 0x42acf871UL,
+ 0xdf7bc0c8UL, 0x67c7a7adUL, 0x75720843UL, 0xcdce6f26UL, 0x95ad7f70UL,
+ 0x2d111815UL, 0x3fa4b7fbUL, 0x8718d09eUL, 0x1acfe827UL, 0xa2738f42UL,
+ 0xb0c620acUL, 0x087a47c9UL, 0xa032af3eUL, 0x188ec85bUL, 0x0a3b67b5UL,
+ 0xb28700d0UL, 0x2f503869UL, 0x97ec5f0cUL, 0x8559f0e2UL, 0x3de59787UL,
+ 0x658687d1UL, 0xdd3ae0b4UL, 0xcf8f4f5aUL, 0x7733283fUL, 0xeae41086UL,
+ 0x525877e3UL, 0x40edd80dUL, 0xf851bf68UL, 0xf02bf8a1UL, 0x48979fc4UL,
+ 0x5a22302aUL, 0xe29e574fUL, 0x7f496ff6UL, 0xc7f50893UL, 0xd540a77dUL,
+ 0x6dfcc018UL, 0x359fd04eUL, 0x8d23b72bUL, 0x9f9618c5UL, 0x272a7fa0UL,
+ 0xbafd4719UL, 0x0241207cUL, 0x10f48f92UL, 0xa848e8f7UL, 0x9b14583dUL,
+ 0x23a83f58UL, 0x311d90b6UL, 0x89a1f7d3UL, 0x1476cf6aUL, 0xaccaa80fUL,
+ 0xbe7f07e1UL, 0x06c36084UL, 0x5ea070d2UL, 0xe61c17b7UL, 0xf4a9b859UL,
+ 0x4c15df3cUL, 0xd1c2e785UL, 0x697e80e0UL, 0x7bcb2f0eUL, 0xc377486bUL,
+ 0xcb0d0fa2UL, 0x73b168c7UL, 0x6104c729UL, 0xd9b8a04cUL, 0x446f98f5UL,
+ 0xfcd3ff90UL, 0xee66507eUL, 0x56da371bUL, 0x0eb9274dUL, 0xb6054028UL,
+ 0xa4b0efc6UL, 0x1c0c88a3UL, 0x81dbb01aUL, 0x3967d77fUL, 0x2bd27891UL,
+ 0x936e1ff4UL, 0x3b26f703UL, 0x839a9066UL, 0x912f3f88UL, 0x299358edUL,
+ 0xb4446054UL, 0x0cf80731UL, 0x1e4da8dfUL, 0xa6f1cfbaUL, 0xfe92dfecUL,
+ 0x462eb889UL, 0x549b1767UL, 0xec277002UL, 0x71f048bbUL, 0xc94c2fdeUL,
+ 0xdbf98030UL, 0x6345e755UL, 0x6b3fa09cUL, 0xd383c7f9UL, 0xc1366817UL,
+ 0x798a0f72UL, 0xe45d37cbUL, 0x5ce150aeUL, 0x4e54ff40UL, 0xf6e89825UL,
+ 0xae8b8873UL, 0x1637ef16UL, 0x048240f8UL, 0xbc3e279dUL, 0x21e91f24UL,
+ 0x99557841UL, 0x8be0d7afUL, 0x335cb0caUL, 0xed59b63bUL, 0x55e5d15eUL,
+ 0x47507eb0UL, 0xffec19d5UL, 0x623b216cUL, 0xda874609UL, 0xc832e9e7UL,
+ 0x708e8e82UL, 0x28ed9ed4UL, 0x9051f9b1UL, 0x82e4565fUL, 0x3a58313aUL,
+ 0xa78f0983UL, 0x1f336ee6UL, 0x0d86c108UL, 0xb53aa66dUL, 0xbd40e1a4UL,
+ 0x05fc86c1UL, 0x1749292fUL, 0xaff54e4aUL, 0x322276f3UL, 0x8a9e1196UL,
+ 0x982bbe78UL, 0x2097d91dUL, 0x78f4c94bUL, 0xc048ae2eUL, 0xd2fd01c0UL,
+ 0x6a4166a5UL, 0xf7965e1cUL, 0x4f2a3979UL, 0x5d9f9697UL, 0xe523f1f2UL,
+ 0x4d6b1905UL, 0xf5d77e60UL, 0xe762d18eUL, 0x5fdeb6ebUL, 0xc2098e52UL,
+ 0x7ab5e937UL, 0x680046d9UL, 0xd0bc21bcUL, 0x88df31eaUL, 0x3063568fUL,
+ 0x22d6f961UL, 0x9a6a9e04UL, 0x07bda6bdUL, 0xbf01c1d8UL, 0xadb46e36UL,
+ 0x15080953UL, 0x1d724e9aUL, 0xa5ce29ffUL, 0xb77b8611UL, 0x0fc7e174UL,
+ 0x9210d9cdUL, 0x2aacbea8UL, 0x38191146UL, 0x80a57623UL, 0xd8c66675UL,
+ 0x607a0110UL, 0x72cfaefeUL, 0xca73c99bUL, 0x57a4f122UL, 0xef189647UL,
+ 0xfdad39a9UL, 0x45115eccUL, 0x764dee06UL, 0xcef18963UL, 0xdc44268dUL,
+ 0x64f841e8UL, 0xf92f7951UL, 0x41931e34UL, 0x5326b1daUL, 0xeb9ad6bfUL,
+ 0xb3f9c6e9UL, 0x0b45a18cUL, 0x19f00e62UL, 0xa14c6907UL, 0x3c9b51beUL,
+ 0x842736dbUL, 0x96929935UL, 0x2e2efe50UL, 0x2654b999UL, 0x9ee8defcUL,
+ 0x8c5d7112UL, 0x34e11677UL, 0xa9362eceUL, 0x118a49abUL, 0x033fe645UL,
+ 0xbb838120UL, 0xe3e09176UL, 0x5b5cf613UL, 0x49e959fdUL, 0xf1553e98UL,
+ 0x6c820621UL, 0xd43e6144UL, 0xc68bceaaUL, 0x7e37a9cfUL, 0xd67f4138UL,
+ 0x6ec3265dUL, 0x7c7689b3UL, 0xc4caeed6UL, 0x591dd66fUL, 0xe1a1b10aUL,
+ 0xf3141ee4UL, 0x4ba87981UL, 0x13cb69d7UL, 0xab770eb2UL, 0xb9c2a15cUL,
+ 0x017ec639UL, 0x9ca9fe80UL, 0x241599e5UL, 0x36a0360bUL, 0x8e1c516eUL,
+ 0x866616a7UL, 0x3eda71c2UL, 0x2c6fde2cUL, 0x94d3b949UL, 0x090481f0UL,
+ 0xb1b8e695UL, 0xa30d497bUL, 0x1bb12e1eUL, 0x43d23e48UL, 0xfb6e592dUL,
+ 0xe9dbf6c3UL, 0x516791a6UL, 0xccb0a91fUL, 0x740cce7aUL, 0x66b96194UL,
+ 0xde0506f1UL
+ },
+ {
+ 0x00000000UL, 0x96300777UL, 0x2c610eeeUL, 0xba510999UL, 0x19c46d07UL,
+ 0x8ff46a70UL, 0x35a563e9UL, 0xa395649eUL, 0x3288db0eUL, 0xa4b8dc79UL,
+ 0x1ee9d5e0UL, 0x88d9d297UL, 0x2b4cb609UL, 0xbd7cb17eUL, 0x072db8e7UL,
+ 0x911dbf90UL, 0x6410b71dUL, 0xf220b06aUL, 0x4871b9f3UL, 0xde41be84UL,
+ 0x7dd4da1aUL, 0xebe4dd6dUL, 0x51b5d4f4UL, 0xc785d383UL, 0x56986c13UL,
+ 0xc0a86b64UL, 0x7af962fdUL, 0xecc9658aUL, 0x4f5c0114UL, 0xd96c0663UL,
+ 0x633d0ffaUL, 0xf50d088dUL, 0xc8206e3bUL, 0x5e10694cUL, 0xe44160d5UL,
+ 0x727167a2UL, 0xd1e4033cUL, 0x47d4044bUL, 0xfd850dd2UL, 0x6bb50aa5UL,
+ 0xfaa8b535UL, 0x6c98b242UL, 0xd6c9bbdbUL, 0x40f9bcacUL, 0xe36cd832UL,
+ 0x755cdf45UL, 0xcf0dd6dcUL, 0x593dd1abUL, 0xac30d926UL, 0x3a00de51UL,
+ 0x8051d7c8UL, 0x1661d0bfUL, 0xb5f4b421UL, 0x23c4b356UL, 0x9995bacfUL,
+ 0x0fa5bdb8UL, 0x9eb80228UL, 0x0888055fUL, 0xb2d90cc6UL, 0x24e90bb1UL,
+ 0x877c6f2fUL, 0x114c6858UL, 0xab1d61c1UL, 0x3d2d66b6UL, 0x9041dc76UL,
+ 0x0671db01UL, 0xbc20d298UL, 0x2a10d5efUL, 0x8985b171UL, 0x1fb5b606UL,
+ 0xa5e4bf9fUL, 0x33d4b8e8UL, 0xa2c90778UL, 0x34f9000fUL, 0x8ea80996UL,
+ 0x18980ee1UL, 0xbb0d6a7fUL, 0x2d3d6d08UL, 0x976c6491UL, 0x015c63e6UL,
+ 0xf4516b6bUL, 0x62616c1cUL, 0xd8306585UL, 0x4e0062f2UL, 0xed95066cUL,
+ 0x7ba5011bUL, 0xc1f40882UL, 0x57c40ff5UL, 0xc6d9b065UL, 0x50e9b712UL,
+ 0xeab8be8bUL, 0x7c88b9fcUL, 0xdf1ddd62UL, 0x492dda15UL, 0xf37cd38cUL,
+ 0x654cd4fbUL, 0x5861b24dUL, 0xce51b53aUL, 0x7400bca3UL, 0xe230bbd4UL,
+ 0x41a5df4aUL, 0xd795d83dUL, 0x6dc4d1a4UL, 0xfbf4d6d3UL, 0x6ae96943UL,
+ 0xfcd96e34UL, 0x468867adUL, 0xd0b860daUL, 0x732d0444UL, 0xe51d0333UL,
+ 0x5f4c0aaaUL, 0xc97c0dddUL, 0x3c710550UL, 0xaa410227UL, 0x10100bbeUL,
+ 0x86200cc9UL, 0x25b56857UL, 0xb3856f20UL, 0x09d466b9UL, 0x9fe461ceUL,
+ 0x0ef9de5eUL, 0x98c9d929UL, 0x2298d0b0UL, 0xb4a8d7c7UL, 0x173db359UL,
+ 0x810db42eUL, 0x3b5cbdb7UL, 0xad6cbac0UL, 0x2083b8edUL, 0xb6b3bf9aUL,
+ 0x0ce2b603UL, 0x9ad2b174UL, 0x3947d5eaUL, 0xaf77d29dUL, 0x1526db04UL,
+ 0x8316dc73UL, 0x120b63e3UL, 0x843b6494UL, 0x3e6a6d0dUL, 0xa85a6a7aUL,
+ 0x0bcf0ee4UL, 0x9dff0993UL, 0x27ae000aUL, 0xb19e077dUL, 0x44930ff0UL,
+ 0xd2a30887UL, 0x68f2011eUL, 0xfec20669UL, 0x5d5762f7UL, 0xcb676580UL,
+ 0x71366c19UL, 0xe7066b6eUL, 0x761bd4feUL, 0xe02bd389UL, 0x5a7ada10UL,
+ 0xcc4add67UL, 0x6fdfb9f9UL, 0xf9efbe8eUL, 0x43beb717UL, 0xd58eb060UL,
+ 0xe8a3d6d6UL, 0x7e93d1a1UL, 0xc4c2d838UL, 0x52f2df4fUL, 0xf167bbd1UL,
+ 0x6757bca6UL, 0xdd06b53fUL, 0x4b36b248UL, 0xda2b0dd8UL, 0x4c1b0aafUL,
+ 0xf64a0336UL, 0x607a0441UL, 0xc3ef60dfUL, 0x55df67a8UL, 0xef8e6e31UL,
+ 0x79be6946UL, 0x8cb361cbUL, 0x1a8366bcUL, 0xa0d26f25UL, 0x36e26852UL,
+ 0x95770cccUL, 0x03470bbbUL, 0xb9160222UL, 0x2f260555UL, 0xbe3bbac5UL,
+ 0x280bbdb2UL, 0x925ab42bUL, 0x046ab35cUL, 0xa7ffd7c2UL, 0x31cfd0b5UL,
+ 0x8b9ed92cUL, 0x1daede5bUL, 0xb0c2649bUL, 0x26f263ecUL, 0x9ca36a75UL,
+ 0x0a936d02UL, 0xa906099cUL, 0x3f360eebUL, 0x85670772UL, 0x13570005UL,
+ 0x824abf95UL, 0x147ab8e2UL, 0xae2bb17bUL, 0x381bb60cUL, 0x9b8ed292UL,
+ 0x0dbed5e5UL, 0xb7efdc7cUL, 0x21dfdb0bUL, 0xd4d2d386UL, 0x42e2d4f1UL,
+ 0xf8b3dd68UL, 0x6e83da1fUL, 0xcd16be81UL, 0x5b26b9f6UL, 0xe177b06fUL,
+ 0x7747b718UL, 0xe65a0888UL, 0x706a0fffUL, 0xca3b0666UL, 0x5c0b0111UL,
+ 0xff9e658fUL, 0x69ae62f8UL, 0xd3ff6b61UL, 0x45cf6c16UL, 0x78e20aa0UL,
+ 0xeed20dd7UL, 0x5483044eUL, 0xc2b30339UL, 0x612667a7UL, 0xf71660d0UL,
+ 0x4d476949UL, 0xdb776e3eUL, 0x4a6ad1aeUL, 0xdc5ad6d9UL, 0x660bdf40UL,
+ 0xf03bd837UL, 0x53aebca9UL, 0xc59ebbdeUL, 0x7fcfb247UL, 0xe9ffb530UL,
+ 0x1cf2bdbdUL, 0x8ac2bacaUL, 0x3093b353UL, 0xa6a3b424UL, 0x0536d0baUL,
+ 0x9306d7cdUL, 0x2957de54UL, 0xbf67d923UL, 0x2e7a66b3UL, 0xb84a61c4UL,
+ 0x021b685dUL, 0x942b6f2aUL, 0x37be0bb4UL, 0xa18e0cc3UL, 0x1bdf055aUL,
+ 0x8def022dUL
+ },
+ {
+ 0x00000000UL, 0x41311b19UL, 0x82623632UL, 0xc3532d2bUL, 0x04c56c64UL,
+ 0x45f4777dUL, 0x86a75a56UL, 0xc796414fUL, 0x088ad9c8UL, 0x49bbc2d1UL,
+ 0x8ae8effaUL, 0xcbd9f4e3UL, 0x0c4fb5acUL, 0x4d7eaeb5UL, 0x8e2d839eUL,
+ 0xcf1c9887UL, 0x5112c24aUL, 0x1023d953UL, 0xd370f478UL, 0x9241ef61UL,
+ 0x55d7ae2eUL, 0x14e6b537UL, 0xd7b5981cUL, 0x96848305UL, 0x59981b82UL,
+ 0x18a9009bUL, 0xdbfa2db0UL, 0x9acb36a9UL, 0x5d5d77e6UL, 0x1c6c6cffUL,
+ 0xdf3f41d4UL, 0x9e0e5acdUL, 0xa2248495UL, 0xe3159f8cUL, 0x2046b2a7UL,
+ 0x6177a9beUL, 0xa6e1e8f1UL, 0xe7d0f3e8UL, 0x2483dec3UL, 0x65b2c5daUL,
+ 0xaaae5d5dUL, 0xeb9f4644UL, 0x28cc6b6fUL, 0x69fd7076UL, 0xae6b3139UL,
+ 0xef5a2a20UL, 0x2c09070bUL, 0x6d381c12UL, 0xf33646dfUL, 0xb2075dc6UL,
+ 0x715470edUL, 0x30656bf4UL, 0xf7f32abbUL, 0xb6c231a2UL, 0x75911c89UL,
+ 0x34a00790UL, 0xfbbc9f17UL, 0xba8d840eUL, 0x79dea925UL, 0x38efb23cUL,
+ 0xff79f373UL, 0xbe48e86aUL, 0x7d1bc541UL, 0x3c2ade58UL, 0x054f79f0UL,
+ 0x447e62e9UL, 0x872d4fc2UL, 0xc61c54dbUL, 0x018a1594UL, 0x40bb0e8dUL,
+ 0x83e823a6UL, 0xc2d938bfUL, 0x0dc5a038UL, 0x4cf4bb21UL, 0x8fa7960aUL,
+ 0xce968d13UL, 0x0900cc5cUL, 0x4831d745UL, 0x8b62fa6eUL, 0xca53e177UL,
+ 0x545dbbbaUL, 0x156ca0a3UL, 0xd63f8d88UL, 0x970e9691UL, 0x5098d7deUL,
+ 0x11a9ccc7UL, 0xd2fae1ecUL, 0x93cbfaf5UL, 0x5cd76272UL, 0x1de6796bUL,
+ 0xdeb55440UL, 0x9f844f59UL, 0x58120e16UL, 0x1923150fUL, 0xda703824UL,
+ 0x9b41233dUL, 0xa76bfd65UL, 0xe65ae67cUL, 0x2509cb57UL, 0x6438d04eUL,
+ 0xa3ae9101UL, 0xe29f8a18UL, 0x21cca733UL, 0x60fdbc2aUL, 0xafe124adUL,
+ 0xeed03fb4UL, 0x2d83129fUL, 0x6cb20986UL, 0xab2448c9UL, 0xea1553d0UL,
+ 0x29467efbUL, 0x687765e2UL, 0xf6793f2fUL, 0xb7482436UL, 0x741b091dUL,
+ 0x352a1204UL, 0xf2bc534bUL, 0xb38d4852UL, 0x70de6579UL, 0x31ef7e60UL,
+ 0xfef3e6e7UL, 0xbfc2fdfeUL, 0x7c91d0d5UL, 0x3da0cbccUL, 0xfa368a83UL,
+ 0xbb07919aUL, 0x7854bcb1UL, 0x3965a7a8UL, 0x4b98833bUL, 0x0aa99822UL,
+ 0xc9fab509UL, 0x88cbae10UL, 0x4f5def5fUL, 0x0e6cf446UL, 0xcd3fd96dUL,
+ 0x8c0ec274UL, 0x43125af3UL, 0x022341eaUL, 0xc1706cc1UL, 0x804177d8UL,
+ 0x47d73697UL, 0x06e62d8eUL, 0xc5b500a5UL, 0x84841bbcUL, 0x1a8a4171UL,
+ 0x5bbb5a68UL, 0x98e87743UL, 0xd9d96c5aUL, 0x1e4f2d15UL, 0x5f7e360cUL,
+ 0x9c2d1b27UL, 0xdd1c003eUL, 0x120098b9UL, 0x533183a0UL, 0x9062ae8bUL,
+ 0xd153b592UL, 0x16c5f4ddUL, 0x57f4efc4UL, 0x94a7c2efUL, 0xd596d9f6UL,
+ 0xe9bc07aeUL, 0xa88d1cb7UL, 0x6bde319cUL, 0x2aef2a85UL, 0xed796bcaUL,
+ 0xac4870d3UL, 0x6f1b5df8UL, 0x2e2a46e1UL, 0xe136de66UL, 0xa007c57fUL,
+ 0x6354e854UL, 0x2265f34dUL, 0xe5f3b202UL, 0xa4c2a91bUL, 0x67918430UL,
+ 0x26a09f29UL, 0xb8aec5e4UL, 0xf99fdefdUL, 0x3accf3d6UL, 0x7bfde8cfUL,
+ 0xbc6ba980UL, 0xfd5ab299UL, 0x3e099fb2UL, 0x7f3884abUL, 0xb0241c2cUL,
+ 0xf1150735UL, 0x32462a1eUL, 0x73773107UL, 0xb4e17048UL, 0xf5d06b51UL,
+ 0x3683467aUL, 0x77b25d63UL, 0x4ed7facbUL, 0x0fe6e1d2UL, 0xccb5ccf9UL,
+ 0x8d84d7e0UL, 0x4a1296afUL, 0x0b238db6UL, 0xc870a09dUL, 0x8941bb84UL,
+ 0x465d2303UL, 0x076c381aUL, 0xc43f1531UL, 0x850e0e28UL, 0x42984f67UL,
+ 0x03a9547eUL, 0xc0fa7955UL, 0x81cb624cUL, 0x1fc53881UL, 0x5ef42398UL,
+ 0x9da70eb3UL, 0xdc9615aaUL, 0x1b0054e5UL, 0x5a314ffcUL, 0x996262d7UL,
+ 0xd85379ceUL, 0x174fe149UL, 0x567efa50UL, 0x952dd77bUL, 0xd41ccc62UL,
+ 0x138a8d2dUL, 0x52bb9634UL, 0x91e8bb1fUL, 0xd0d9a006UL, 0xecf37e5eUL,
+ 0xadc26547UL, 0x6e91486cUL, 0x2fa05375UL, 0xe836123aUL, 0xa9070923UL,
+ 0x6a542408UL, 0x2b653f11UL, 0xe479a796UL, 0xa548bc8fUL, 0x661b91a4UL,
+ 0x272a8abdUL, 0xe0bccbf2UL, 0xa18dd0ebUL, 0x62defdc0UL, 0x23efe6d9UL,
+ 0xbde1bc14UL, 0xfcd0a70dUL, 0x3f838a26UL, 0x7eb2913fUL, 0xb924d070UL,
+ 0xf815cb69UL, 0x3b46e642UL, 0x7a77fd5bUL, 0xb56b65dcUL, 0xf45a7ec5UL,
+ 0x370953eeUL, 0x763848f7UL, 0xb1ae09b8UL, 0xf09f12a1UL, 0x33cc3f8aUL,
+ 0x72fd2493UL
+ },
+ {
+ 0x00000000UL, 0x376ac201UL, 0x6ed48403UL, 0x59be4602UL, 0xdca80907UL,
+ 0xebc2cb06UL, 0xb27c8d04UL, 0x85164f05UL, 0xb851130eUL, 0x8f3bd10fUL,
+ 0xd685970dUL, 0xe1ef550cUL, 0x64f91a09UL, 0x5393d808UL, 0x0a2d9e0aUL,
+ 0x3d475c0bUL, 0x70a3261cUL, 0x47c9e41dUL, 0x1e77a21fUL, 0x291d601eUL,
+ 0xac0b2f1bUL, 0x9b61ed1aUL, 0xc2dfab18UL, 0xf5b56919UL, 0xc8f23512UL,
+ 0xff98f713UL, 0xa626b111UL, 0x914c7310UL, 0x145a3c15UL, 0x2330fe14UL,
+ 0x7a8eb816UL, 0x4de47a17UL, 0xe0464d38UL, 0xd72c8f39UL, 0x8e92c93bUL,
+ 0xb9f80b3aUL, 0x3cee443fUL, 0x0b84863eUL, 0x523ac03cUL, 0x6550023dUL,
+ 0x58175e36UL, 0x6f7d9c37UL, 0x36c3da35UL, 0x01a91834UL, 0x84bf5731UL,
+ 0xb3d59530UL, 0xea6bd332UL, 0xdd011133UL, 0x90e56b24UL, 0xa78fa925UL,
+ 0xfe31ef27UL, 0xc95b2d26UL, 0x4c4d6223UL, 0x7b27a022UL, 0x2299e620UL,
+ 0x15f32421UL, 0x28b4782aUL, 0x1fdeba2bUL, 0x4660fc29UL, 0x710a3e28UL,
+ 0xf41c712dUL, 0xc376b32cUL, 0x9ac8f52eUL, 0xada2372fUL, 0xc08d9a70UL,
+ 0xf7e75871UL, 0xae591e73UL, 0x9933dc72UL, 0x1c259377UL, 0x2b4f5176UL,
+ 0x72f11774UL, 0x459bd575UL, 0x78dc897eUL, 0x4fb64b7fUL, 0x16080d7dUL,
+ 0x2162cf7cUL, 0xa4748079UL, 0x931e4278UL, 0xcaa0047aUL, 0xfdcac67bUL,
+ 0xb02ebc6cUL, 0x87447e6dUL, 0xdefa386fUL, 0xe990fa6eUL, 0x6c86b56bUL,
+ 0x5bec776aUL, 0x02523168UL, 0x3538f369UL, 0x087faf62UL, 0x3f156d63UL,
+ 0x66ab2b61UL, 0x51c1e960UL, 0xd4d7a665UL, 0xe3bd6464UL, 0xba032266UL,
+ 0x8d69e067UL, 0x20cbd748UL, 0x17a11549UL, 0x4e1f534bUL, 0x7975914aUL,
+ 0xfc63de4fUL, 0xcb091c4eUL, 0x92b75a4cUL, 0xa5dd984dUL, 0x989ac446UL,
+ 0xaff00647UL, 0xf64e4045UL, 0xc1248244UL, 0x4432cd41UL, 0x73580f40UL,
+ 0x2ae64942UL, 0x1d8c8b43UL, 0x5068f154UL, 0x67023355UL, 0x3ebc7557UL,
+ 0x09d6b756UL, 0x8cc0f853UL, 0xbbaa3a52UL, 0xe2147c50UL, 0xd57ebe51UL,
+ 0xe839e25aUL, 0xdf53205bUL, 0x86ed6659UL, 0xb187a458UL, 0x3491eb5dUL,
+ 0x03fb295cUL, 0x5a456f5eUL, 0x6d2fad5fUL, 0x801b35e1UL, 0xb771f7e0UL,
+ 0xeecfb1e2UL, 0xd9a573e3UL, 0x5cb33ce6UL, 0x6bd9fee7UL, 0x3267b8e5UL,
+ 0x050d7ae4UL, 0x384a26efUL, 0x0f20e4eeUL, 0x569ea2ecUL, 0x61f460edUL,
+ 0xe4e22fe8UL, 0xd388ede9UL, 0x8a36abebUL, 0xbd5c69eaUL, 0xf0b813fdUL,
+ 0xc7d2d1fcUL, 0x9e6c97feUL, 0xa90655ffUL, 0x2c101afaUL, 0x1b7ad8fbUL,
+ 0x42c49ef9UL, 0x75ae5cf8UL, 0x48e900f3UL, 0x7f83c2f2UL, 0x263d84f0UL,
+ 0x115746f1UL, 0x944109f4UL, 0xa32bcbf5UL, 0xfa958df7UL, 0xcdff4ff6UL,
+ 0x605d78d9UL, 0x5737bad8UL, 0x0e89fcdaUL, 0x39e33edbUL, 0xbcf571deUL,
+ 0x8b9fb3dfUL, 0xd221f5ddUL, 0xe54b37dcUL, 0xd80c6bd7UL, 0xef66a9d6UL,
+ 0xb6d8efd4UL, 0x81b22dd5UL, 0x04a462d0UL, 0x33cea0d1UL, 0x6a70e6d3UL,
+ 0x5d1a24d2UL, 0x10fe5ec5UL, 0x27949cc4UL, 0x7e2adac6UL, 0x494018c7UL,
+ 0xcc5657c2UL, 0xfb3c95c3UL, 0xa282d3c1UL, 0x95e811c0UL, 0xa8af4dcbUL,
+ 0x9fc58fcaUL, 0xc67bc9c8UL, 0xf1110bc9UL, 0x740744ccUL, 0x436d86cdUL,
+ 0x1ad3c0cfUL, 0x2db902ceUL, 0x4096af91UL, 0x77fc6d90UL, 0x2e422b92UL,
+ 0x1928e993UL, 0x9c3ea696UL, 0xab546497UL, 0xf2ea2295UL, 0xc580e094UL,
+ 0xf8c7bc9fUL, 0xcfad7e9eUL, 0x9613389cUL, 0xa179fa9dUL, 0x246fb598UL,
+ 0x13057799UL, 0x4abb319bUL, 0x7dd1f39aUL, 0x3035898dUL, 0x075f4b8cUL,
+ 0x5ee10d8eUL, 0x698bcf8fUL, 0xec9d808aUL, 0xdbf7428bUL, 0x82490489UL,
+ 0xb523c688UL, 0x88649a83UL, 0xbf0e5882UL, 0xe6b01e80UL, 0xd1dadc81UL,
+ 0x54cc9384UL, 0x63a65185UL, 0x3a181787UL, 0x0d72d586UL, 0xa0d0e2a9UL,
+ 0x97ba20a8UL, 0xce0466aaUL, 0xf96ea4abUL, 0x7c78ebaeUL, 0x4b1229afUL,
+ 0x12ac6fadUL, 0x25c6adacUL, 0x1881f1a7UL, 0x2feb33a6UL, 0x765575a4UL,
+ 0x413fb7a5UL, 0xc429f8a0UL, 0xf3433aa1UL, 0xaafd7ca3UL, 0x9d97bea2UL,
+ 0xd073c4b5UL, 0xe71906b4UL, 0xbea740b6UL, 0x89cd82b7UL, 0x0cdbcdb2UL,
+ 0x3bb10fb3UL, 0x620f49b1UL, 0x55658bb0UL, 0x6822d7bbUL, 0x5f4815baUL,
+ 0x06f653b8UL, 0x319c91b9UL, 0xb48adebcUL, 0x83e01cbdUL, 0xda5e5abfUL,
+ 0xed3498beUL
+ },
+ {
+ 0x00000000UL, 0x6567bcb8UL, 0x8bc809aaUL, 0xeeafb512UL, 0x5797628fUL,
+ 0x32f0de37UL, 0xdc5f6b25UL, 0xb938d79dUL, 0xef28b4c5UL, 0x8a4f087dUL,
+ 0x64e0bd6fUL, 0x018701d7UL, 0xb8bfd64aUL, 0xddd86af2UL, 0x3377dfe0UL,
+ 0x56106358UL, 0x9f571950UL, 0xfa30a5e8UL, 0x149f10faUL, 0x71f8ac42UL,
+ 0xc8c07bdfUL, 0xada7c767UL, 0x43087275UL, 0x266fcecdUL, 0x707fad95UL,
+ 0x1518112dUL, 0xfbb7a43fUL, 0x9ed01887UL, 0x27e8cf1aUL, 0x428f73a2UL,
+ 0xac20c6b0UL, 0xc9477a08UL, 0x3eaf32a0UL, 0x5bc88e18UL, 0xb5673b0aUL,
+ 0xd00087b2UL, 0x6938502fUL, 0x0c5fec97UL, 0xe2f05985UL, 0x8797e53dUL,
+ 0xd1878665UL, 0xb4e03addUL, 0x5a4f8fcfUL, 0x3f283377UL, 0x8610e4eaUL,
+ 0xe3775852UL, 0x0dd8ed40UL, 0x68bf51f8UL, 0xa1f82bf0UL, 0xc49f9748UL,
+ 0x2a30225aUL, 0x4f579ee2UL, 0xf66f497fUL, 0x9308f5c7UL, 0x7da740d5UL,
+ 0x18c0fc6dUL, 0x4ed09f35UL, 0x2bb7238dUL, 0xc518969fUL, 0xa07f2a27UL,
+ 0x1947fdbaUL, 0x7c204102UL, 0x928ff410UL, 0xf7e848a8UL, 0x3d58149bUL,
+ 0x583fa823UL, 0xb6901d31UL, 0xd3f7a189UL, 0x6acf7614UL, 0x0fa8caacUL,
+ 0xe1077fbeUL, 0x8460c306UL, 0xd270a05eUL, 0xb7171ce6UL, 0x59b8a9f4UL,
+ 0x3cdf154cUL, 0x85e7c2d1UL, 0xe0807e69UL, 0x0e2fcb7bUL, 0x6b4877c3UL,
+ 0xa20f0dcbUL, 0xc768b173UL, 0x29c70461UL, 0x4ca0b8d9UL, 0xf5986f44UL,
+ 0x90ffd3fcUL, 0x7e5066eeUL, 0x1b37da56UL, 0x4d27b90eUL, 0x284005b6UL,
+ 0xc6efb0a4UL, 0xa3880c1cUL, 0x1ab0db81UL, 0x7fd76739UL, 0x9178d22bUL,
+ 0xf41f6e93UL, 0x03f7263bUL, 0x66909a83UL, 0x883f2f91UL, 0xed589329UL,
+ 0x546044b4UL, 0x3107f80cUL, 0xdfa84d1eUL, 0xbacff1a6UL, 0xecdf92feUL,
+ 0x89b82e46UL, 0x67179b54UL, 0x027027ecUL, 0xbb48f071UL, 0xde2f4cc9UL,
+ 0x3080f9dbUL, 0x55e74563UL, 0x9ca03f6bUL, 0xf9c783d3UL, 0x176836c1UL,
+ 0x720f8a79UL, 0xcb375de4UL, 0xae50e15cUL, 0x40ff544eUL, 0x2598e8f6UL,
+ 0x73888baeUL, 0x16ef3716UL, 0xf8408204UL, 0x9d273ebcUL, 0x241fe921UL,
+ 0x41785599UL, 0xafd7e08bUL, 0xcab05c33UL, 0x3bb659edUL, 0x5ed1e555UL,
+ 0xb07e5047UL, 0xd519ecffUL, 0x6c213b62UL, 0x094687daUL, 0xe7e932c8UL,
+ 0x828e8e70UL, 0xd49eed28UL, 0xb1f95190UL, 0x5f56e482UL, 0x3a31583aUL,
+ 0x83098fa7UL, 0xe66e331fUL, 0x08c1860dUL, 0x6da63ab5UL, 0xa4e140bdUL,
+ 0xc186fc05UL, 0x2f294917UL, 0x4a4ef5afUL, 0xf3762232UL, 0x96119e8aUL,
+ 0x78be2b98UL, 0x1dd99720UL, 0x4bc9f478UL, 0x2eae48c0UL, 0xc001fdd2UL,
+ 0xa566416aUL, 0x1c5e96f7UL, 0x79392a4fUL, 0x97969f5dUL, 0xf2f123e5UL,
+ 0x05196b4dUL, 0x607ed7f5UL, 0x8ed162e7UL, 0xebb6de5fUL, 0x528e09c2UL,
+ 0x37e9b57aUL, 0xd9460068UL, 0xbc21bcd0UL, 0xea31df88UL, 0x8f566330UL,
+ 0x61f9d622UL, 0x049e6a9aUL, 0xbda6bd07UL, 0xd8c101bfUL, 0x366eb4adUL,
+ 0x53090815UL, 0x9a4e721dUL, 0xff29cea5UL, 0x11867bb7UL, 0x74e1c70fUL,
+ 0xcdd91092UL, 0xa8beac2aUL, 0x46111938UL, 0x2376a580UL, 0x7566c6d8UL,
+ 0x10017a60UL, 0xfeaecf72UL, 0x9bc973caUL, 0x22f1a457UL, 0x479618efUL,
+ 0xa939adfdUL, 0xcc5e1145UL, 0x06ee4d76UL, 0x6389f1ceUL, 0x8d2644dcUL,
+ 0xe841f864UL, 0x51792ff9UL, 0x341e9341UL, 0xdab12653UL, 0xbfd69aebUL,
+ 0xe9c6f9b3UL, 0x8ca1450bUL, 0x620ef019UL, 0x07694ca1UL, 0xbe519b3cUL,
+ 0xdb362784UL, 0x35999296UL, 0x50fe2e2eUL, 0x99b95426UL, 0xfcdee89eUL,
+ 0x12715d8cUL, 0x7716e134UL, 0xce2e36a9UL, 0xab498a11UL, 0x45e63f03UL,
+ 0x208183bbUL, 0x7691e0e3UL, 0x13f65c5bUL, 0xfd59e949UL, 0x983e55f1UL,
+ 0x2106826cUL, 0x44613ed4UL, 0xaace8bc6UL, 0xcfa9377eUL, 0x38417fd6UL,
+ 0x5d26c36eUL, 0xb389767cUL, 0xd6eecac4UL, 0x6fd61d59UL, 0x0ab1a1e1UL,
+ 0xe41e14f3UL, 0x8179a84bUL, 0xd769cb13UL, 0xb20e77abUL, 0x5ca1c2b9UL,
+ 0x39c67e01UL, 0x80fea99cUL, 0xe5991524UL, 0x0b36a036UL, 0x6e511c8eUL,
+ 0xa7166686UL, 0xc271da3eUL, 0x2cde6f2cUL, 0x49b9d394UL, 0xf0810409UL,
+ 0x95e6b8b1UL, 0x7b490da3UL, 0x1e2eb11bUL, 0x483ed243UL, 0x2d596efbUL,
+ 0xc3f6dbe9UL, 0xa6916751UL, 0x1fa9b0ccUL, 0x7ace0c74UL, 0x9461b966UL,
+ 0xf10605deUL
+#endif
+ }
+};
diff --git a/test/monniaux/glpk-4.65/src/zlib/deflate.c b/test/monniaux/glpk-4.65/src/zlib/deflate.c
new file mode 100644
index 00000000..5c4022f3
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/deflate.c
@@ -0,0 +1,1834 @@
+/* deflate.c -- compress data using the deflation algorithm
+ * Copyright (C) 1995-2010 Jean-loup Gailly and Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * ALGORITHM
+ *
+ * The "deflation" process depends on being able to identify portions
+ * of the input text which are identical to earlier input (within a
+ * sliding window trailing behind the input currently being processed).
+ *
+ * The most straightforward technique turns out to be the fastest for
+ * most input files: try all possible matches and select the longest.
+ * The key feature of this algorithm is that insertions into the string
+ * dictionary are very simple and thus fast, and deletions are avoided
+ * completely. Insertions are performed at each input character, whereas
+ * string matches are performed only when the previous match ends. So it
+ * is preferable to spend more time in matches to allow very fast string
+ * insertions and avoid deletions. The matching algorithm for small
+ * strings is inspired from that of Rabin & Karp. A brute force approach
+ * is used to find longer strings when a small match has been found.
+ * A similar algorithm is used in comic (by Jan-Mark Wams) and freeze
+ * (by Leonid Broukhis).
+ * A previous version of this file used a more sophisticated algorithm
+ * (by Fiala and Greene) which is guaranteed to run in linear amortized
+ * time, but has a larger average cost, uses more memory and is patented.
+ * However the F&G algorithm may be faster for some highly redundant
+ * files if the parameter max_chain_length (described below) is too large.
+ *
+ * ACKNOWLEDGEMENTS
+ *
+ * The idea of lazy evaluation of matches is due to Jan-Mark Wams, and
+ * I found it in 'freeze' written by Leonid Broukhis.
+ * Thanks to many people for bug reports and testing.
+ *
+ * REFERENCES
+ *
+ * Deutsch, L.P.,"DEFLATE Compressed Data Format Specification".
+ * Available in http://www.ietf.org/rfc/rfc1951.txt
+ *
+ * A description of the Rabin and Karp algorithm is given in the book
+ * "Algorithms" by R. Sedgewick, Addison-Wesley, p252.
+ *
+ * Fiala,E.R., and Greene,D.H.
+ * Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595
+ *
+ */
+
+/* @(#) $Id$ */
+
+#include "deflate.h"
+
+const char deflate_copyright[] =
+ " deflate 1.2.5 Copyright 1995-2010 Jean-loup Gailly and Mark Adler ";
+/*
+ If you use the zlib library in a product, an acknowledgment is welcome
+ in the documentation of your product. If for some reason you cannot
+ include such an acknowledgment, I would appreciate that you keep this
+ copyright string in the executable of your product.
+ */
+
+/* ===========================================================================
+ * Function prototypes.
+ */
+typedef enum {
+ need_more, /* block not completed, need more input or more output */
+ block_done, /* block flush performed */
+ finish_started, /* finish started, need only more output at next deflate */
+ finish_done /* finish done, accept no more input or output */
+} block_state;
+
+typedef block_state (*compress_func) OF((deflate_state *s, int flush));
+/* Compression function. Returns the block state after the call. */
+
+local void fill_window OF((deflate_state *s));
+local block_state deflate_stored OF((deflate_state *s, int flush));
+local block_state deflate_fast OF((deflate_state *s, int flush));
+#ifndef FASTEST
+local block_state deflate_slow OF((deflate_state *s, int flush));
+#endif
+local block_state deflate_rle OF((deflate_state *s, int flush));
+local block_state deflate_huff OF((deflate_state *s, int flush));
+local void lm_init OF((deflate_state *s));
+local void putShortMSB OF((deflate_state *s, uInt b));
+local void flush_pending OF((z_streamp strm));
+local int read_buf OF((z_streamp strm, Bytef *buf, unsigned size));
+#ifdef ASMV
+ void match_init OF((void)); /* asm code initialization */
+ uInt longest_match OF((deflate_state *s, IPos cur_match));
+#else
+local uInt longest_match OF((deflate_state *s, IPos cur_match));
+#endif
+
+#ifdef DEBUG
+local void check_match OF((deflate_state *s, IPos start, IPos match,
+ int length));
+#endif
+
+/* ===========================================================================
+ * Local data
+ */
+
+#define NIL 0
+/* Tail of hash chains */
+
+#ifndef TOO_FAR
+# define TOO_FAR 4096
+#endif
+/* Matches of length 3 are discarded if their distance exceeds TOO_FAR */
+
+/* Values for max_lazy_match, good_match and max_chain_length, depending on
+ * the desired pack level (0..9). The values given below have been tuned to
+ * exclude worst case performance for pathological files. Better values may be
+ * found for specific files.
+ */
+typedef struct config_s {
+ ush good_length; /* reduce lazy search above this match length */
+ ush max_lazy; /* do not perform lazy search above this match length */
+ ush nice_length; /* quit search above this match length */
+ ush max_chain;
+ compress_func func;
+} config;
+
+#ifdef FASTEST
+local const config configuration_table[2] = {
+/* good lazy nice chain */
+/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */
+/* 1 */ {4, 4, 8, 4, deflate_fast}}; /* max speed, no lazy matches */
+#else
+local const config configuration_table[10] = {
+/* good lazy nice chain */
+/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */
+/* 1 */ {4, 4, 8, 4, deflate_fast}, /* max speed, no lazy matches */
+/* 2 */ {4, 5, 16, 8, deflate_fast},
+/* 3 */ {4, 6, 32, 32, deflate_fast},
+
+/* 4 */ {4, 4, 16, 16, deflate_slow}, /* lazy matches */
+/* 5 */ {8, 16, 32, 32, deflate_slow},
+/* 6 */ {8, 16, 128, 128, deflate_slow},
+/* 7 */ {8, 32, 128, 256, deflate_slow},
+/* 8 */ {32, 128, 258, 1024, deflate_slow},
+/* 9 */ {32, 258, 258, 4096, deflate_slow}}; /* max compression */
+#endif
+
+/* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4
+ * For deflate_fast() (levels <= 3) good is ignored and lazy has a different
+ * meaning.
+ */
+
+#define EQUAL 0
+/* result of memcmp for equal strings */
+
+#ifndef NO_DUMMY_DECL
+struct static_tree_desc_s {int dummy;}; /* for buggy compilers */
+#endif
+
+/* ===========================================================================
+ * Update a hash value with the given input byte
+ * IN assertion: all calls to to UPDATE_HASH are made with consecutive
+ * input characters, so that a running hash key can be computed from the
+ * previous key instead of complete recalculation each time.
+ */
+#define UPDATE_HASH(s,h,c) (h = (((h)<<s->hash_shift) ^ (c)) & s->hash_mask)
+
+
+/* ===========================================================================
+ * Insert string str in the dictionary and set match_head to the previous head
+ * of the hash chain (the most recent string with same hash key). Return
+ * the previous length of the hash chain.
+ * If this file is compiled with -DFASTEST, the compression level is forced
+ * to 1, and no hash chains are maintained.
+ * IN assertion: all calls to to INSERT_STRING are made with consecutive
+ * input characters and the first MIN_MATCH bytes of str are valid
+ * (except for the last MIN_MATCH-1 bytes of the input file).
+ */
+#ifdef FASTEST
+#define INSERT_STRING(s, str, match_head) \
+ (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+ match_head = s->head[s->ins_h], \
+ s->head[s->ins_h] = (Pos)(str))
+#else
+#define INSERT_STRING(s, str, match_head) \
+ (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+ match_head = s->prev[(str) & s->w_mask] = s->head[s->ins_h], \
+ s->head[s->ins_h] = (Pos)(str))
+#endif
+
+/* ===========================================================================
+ * Initialize the hash table (avoiding 64K overflow for 16 bit systems).
+ * prev[] will be initialized on the fly.
+ */
+#define CLEAR_HASH(s) \
+ s->head[s->hash_size-1] = NIL; \
+ zmemzero((Bytef *)s->head, (unsigned)(s->hash_size-1)*sizeof(*s->head));
+
+/* ========================================================================= */
+int ZEXPORT deflateInit_(strm, level, version, stream_size)
+ z_streamp strm;
+ int level;
+ const char *version;
+ int stream_size;
+{
+ return deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, DEF_MEM_LEVEL,
+ Z_DEFAULT_STRATEGY, version, stream_size);
+ /* To do: ignore strm->next_in if we use it as window */
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy,
+ version, stream_size)
+ z_streamp strm;
+ int level;
+ int method;
+ int windowBits;
+ int memLevel;
+ int strategy;
+ const char *version;
+ int stream_size;
+{
+ deflate_state *s;
+ int wrap = 1;
+ static const char my_version[] = ZLIB_VERSION;
+
+ ushf *overlay;
+ /* We overlay pending_buf and d_buf+l_buf. This works since the average
+ * output size for (length,distance) codes is <= 24 bits.
+ */
+
+ if (version == Z_NULL || version[0] != my_version[0] ||
+ stream_size != sizeof(z_stream)) {
+ return Z_VERSION_ERROR;
+ }
+ if (strm == Z_NULL) return Z_STREAM_ERROR;
+
+ strm->msg = Z_NULL;
+ if (strm->zalloc == (alloc_func)0) {
+ strm->zalloc = zcalloc;
+ strm->opaque = (voidpf)0;
+ }
+ if (strm->zfree == (free_func)0) strm->zfree = zcfree;
+
+#ifdef FASTEST
+ if (level != 0) level = 1;
+#else
+ if (level == Z_DEFAULT_COMPRESSION) level = 6;
+#endif
+
+ if (windowBits < 0) { /* suppress zlib wrapper */
+ wrap = 0;
+ windowBits = -windowBits;
+ }
+#ifdef GZIP
+ else if (windowBits > 15) {
+ wrap = 2; /* write gzip wrapper instead */
+ windowBits -= 16;
+ }
+#endif
+ if (memLevel < 1 || memLevel > MAX_MEM_LEVEL || method != Z_DEFLATED ||
+ windowBits < 8 || windowBits > 15 || level < 0 || level > 9 ||
+ strategy < 0 || strategy > Z_FIXED) {
+ return Z_STREAM_ERROR;
+ }
+ if (windowBits == 8) windowBits = 9; /* until 256-byte window bug fixed */
+ s = (deflate_state *) ZALLOC(strm, 1, sizeof(deflate_state));
+ if (s == Z_NULL) return Z_MEM_ERROR;
+ strm->state = (struct internal_state FAR *)s;
+ s->strm = strm;
+
+ s->wrap = wrap;
+ s->gzhead = Z_NULL;
+ s->w_bits = windowBits;
+ s->w_size = 1 << s->w_bits;
+ s->w_mask = s->w_size - 1;
+
+ s->hash_bits = memLevel + 7;
+ s->hash_size = 1 << s->hash_bits;
+ s->hash_mask = s->hash_size - 1;
+ s->hash_shift = ((s->hash_bits+MIN_MATCH-1)/MIN_MATCH);
+
+ s->window = (Bytef *) ZALLOC(strm, s->w_size, 2*sizeof(Byte));
+ s->prev = (Posf *) ZALLOC(strm, s->w_size, sizeof(Pos));
+ s->head = (Posf *) ZALLOC(strm, s->hash_size, sizeof(Pos));
+
+ s->high_water = 0; /* nothing written to s->window yet */
+
+ s->lit_bufsize = 1 << (memLevel + 6); /* 16K elements by default */
+
+ overlay = (ushf *) ZALLOC(strm, s->lit_bufsize, sizeof(ush)+2);
+ s->pending_buf = (uchf *) overlay;
+ s->pending_buf_size = (ulg)s->lit_bufsize * (sizeof(ush)+2L);
+
+ if (s->window == Z_NULL || s->prev == Z_NULL || s->head == Z_NULL ||
+ s->pending_buf == Z_NULL) {
+ s->status = FINISH_STATE;
+ strm->msg = (char*)ERR_MSG(Z_MEM_ERROR);
+ deflateEnd (strm);
+ return Z_MEM_ERROR;
+ }
+ s->d_buf = overlay + s->lit_bufsize/sizeof(ush);
+ s->l_buf = s->pending_buf + (1+sizeof(ush))*s->lit_bufsize;
+
+ s->level = level;
+ s->strategy = strategy;
+ s->method = (Byte)method;
+
+ return deflateReset(strm);
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength)
+ z_streamp strm;
+ const Bytef *dictionary;
+ uInt dictLength;
+{
+ deflate_state *s;
+ uInt length = dictLength;
+ uInt n;
+ IPos hash_head = 0;
+
+ if (strm == Z_NULL || strm->state == Z_NULL || dictionary == Z_NULL ||
+ strm->state->wrap == 2 ||
+ (strm->state->wrap == 1 && strm->state->status != INIT_STATE))
+ return Z_STREAM_ERROR;
+
+ s = strm->state;
+ if (s->wrap)
+ strm->adler = adler32(strm->adler, dictionary, dictLength);
+
+ if (length < MIN_MATCH) return Z_OK;
+ if (length > s->w_size) {
+ length = s->w_size;
+ dictionary += dictLength - length; /* use the tail of the dictionary */
+ }
+ zmemcpy(s->window, dictionary, length);
+ s->strstart = length;
+ s->block_start = (long)length;
+
+ /* Insert all strings in the hash table (except for the last two bytes).
+ * s->lookahead stays null, so s->ins_h will be recomputed at the next
+ * call of fill_window.
+ */
+ s->ins_h = s->window[0];
+ UPDATE_HASH(s, s->ins_h, s->window[1]);
+ for (n = 0; n <= length - MIN_MATCH; n++) {
+ INSERT_STRING(s, n, hash_head);
+ }
+ if (hash_head) hash_head = 0; /* to make compiler happy */
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateReset (strm)
+ z_streamp strm;
+{
+ deflate_state *s;
+
+ if (strm == Z_NULL || strm->state == Z_NULL ||
+ strm->zalloc == (alloc_func)0 || strm->zfree == (free_func)0) {
+ return Z_STREAM_ERROR;
+ }
+
+ strm->total_in = strm->total_out = 0;
+ strm->msg = Z_NULL; /* use zfree if we ever allocate msg dynamically */
+ strm->data_type = Z_UNKNOWN;
+
+ s = (deflate_state *)strm->state;
+ s->pending = 0;
+ s->pending_out = s->pending_buf;
+
+ if (s->wrap < 0) {
+ s->wrap = -s->wrap; /* was made negative by deflate(..., Z_FINISH); */
+ }
+ s->status = s->wrap ? INIT_STATE : BUSY_STATE;
+ strm->adler =
+#ifdef GZIP
+ s->wrap == 2 ? crc32(0L, Z_NULL, 0) :
+#endif
+ adler32(0L, Z_NULL, 0);
+ s->last_flush = Z_NO_FLUSH;
+
+ _tr_init(s);
+ lm_init(s);
+
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateSetHeader (strm, head)
+ z_streamp strm;
+ gz_headerp head;
+{
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ if (strm->state->wrap != 2) return Z_STREAM_ERROR;
+ strm->state->gzhead = head;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflatePrime (strm, bits, value)
+ z_streamp strm;
+ int bits;
+ int value;
+{
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ strm->state->bi_valid = bits;
+ strm->state->bi_buf = (ush)(value & ((1 << bits) - 1));
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateParams(strm, level, strategy)
+ z_streamp strm;
+ int level;
+ int strategy;
+{
+ deflate_state *s;
+ compress_func func;
+ int err = Z_OK;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ s = strm->state;
+
+#ifdef FASTEST
+ if (level != 0) level = 1;
+#else
+ if (level == Z_DEFAULT_COMPRESSION) level = 6;
+#endif
+ if (level < 0 || level > 9 || strategy < 0 || strategy > Z_FIXED) {
+ return Z_STREAM_ERROR;
+ }
+ func = configuration_table[s->level].func;
+
+ if ((strategy != s->strategy || func != configuration_table[level].func) &&
+ strm->total_in != 0) {
+ /* Flush the last buffer: */
+ err = deflate(strm, Z_BLOCK);
+ }
+ if (s->level != level) {
+ s->level = level;
+ s->max_lazy_match = configuration_table[level].max_lazy;
+ s->good_match = configuration_table[level].good_length;
+ s->nice_match = configuration_table[level].nice_length;
+ s->max_chain_length = configuration_table[level].max_chain;
+ }
+ s->strategy = strategy;
+ return err;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateTune(strm, good_length, max_lazy, nice_length, max_chain)
+ z_streamp strm;
+ int good_length;
+ int max_lazy;
+ int nice_length;
+ int max_chain;
+{
+ deflate_state *s;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ s = strm->state;
+ s->good_match = good_length;
+ s->max_lazy_match = max_lazy;
+ s->nice_match = nice_length;
+ s->max_chain_length = max_chain;
+ return Z_OK;
+}
+
+/* =========================================================================
+ * For the default windowBits of 15 and memLevel of 8, this function returns
+ * a close to exact, as well as small, upper bound on the compressed size.
+ * They are coded as constants here for a reason--if the #define's are
+ * changed, then this function needs to be changed as well. The return
+ * value for 15 and 8 only works for those exact settings.
+ *
+ * For any setting other than those defaults for windowBits and memLevel,
+ * the value returned is a conservative worst case for the maximum expansion
+ * resulting from using fixed blocks instead of stored blocks, which deflate
+ * can emit on compressed data for some combinations of the parameters.
+ *
+ * This function could be more sophisticated to provide closer upper bounds for
+ * every combination of windowBits and memLevel. But even the conservative
+ * upper bound of about 14% expansion does not seem onerous for output buffer
+ * allocation.
+ */
+uLong ZEXPORT deflateBound(strm, sourceLen)
+ z_streamp strm;
+ uLong sourceLen;
+{
+ deflate_state *s;
+ uLong complen, wraplen;
+ Bytef *str;
+
+ /* conservative upper bound for compressed data */
+ complen = sourceLen +
+ ((sourceLen + 7) >> 3) + ((sourceLen + 63) >> 6) + 5;
+
+ /* if can't get parameters, return conservative bound plus zlib wrapper */
+ if (strm == Z_NULL || strm->state == Z_NULL)
+ return complen + 6;
+
+ /* compute wrapper length */
+ s = strm->state;
+ switch (s->wrap) {
+ case 0: /* raw deflate */
+ wraplen = 0;
+ break;
+ case 1: /* zlib wrapper */
+ wraplen = 6 + (s->strstart ? 4 : 0);
+ break;
+ case 2: /* gzip wrapper */
+ wraplen = 18;
+ if (s->gzhead != Z_NULL) { /* user-supplied gzip header */
+ if (s->gzhead->extra != Z_NULL)
+ wraplen += 2 + s->gzhead->extra_len;
+ str = s->gzhead->name;
+ if (str != Z_NULL)
+ do {
+ wraplen++;
+ } while (*str++);
+ str = s->gzhead->comment;
+ if (str != Z_NULL)
+ do {
+ wraplen++;
+ } while (*str++);
+ if (s->gzhead->hcrc)
+ wraplen += 2;
+ }
+ break;
+ default: /* for compiler happiness */
+ wraplen = 6;
+ }
+
+ /* if not default parameters, return conservative bound */
+ if (s->w_bits != 15 || s->hash_bits != 8 + 7)
+ return complen + wraplen;
+
+ /* default settings: return tight bound for that case */
+ return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) +
+ (sourceLen >> 25) + 13 - 6 + wraplen;
+}
+
+/* =========================================================================
+ * Put a short in the pending buffer. The 16-bit value is put in MSB order.
+ * IN assertion: the stream state is correct and there is enough room in
+ * pending_buf.
+ */
+local void putShortMSB (s, b)
+ deflate_state *s;
+ uInt b;
+{
+ put_byte(s, (Byte)(b >> 8));
+ put_byte(s, (Byte)(b & 0xff));
+}
+
+/* =========================================================================
+ * Flush as much pending output as possible. All deflate() output goes
+ * through this function so some applications may wish to modify it
+ * to avoid allocating a large strm->next_out buffer and copying into it.
+ * (See also read_buf()).
+ */
+local void flush_pending(strm)
+ z_streamp strm;
+{
+ unsigned len = strm->state->pending;
+
+ if (len > strm->avail_out) len = strm->avail_out;
+ if (len == 0) return;
+
+ zmemcpy(strm->next_out, strm->state->pending_out, len);
+ strm->next_out += len;
+ strm->state->pending_out += len;
+ strm->total_out += len;
+ strm->avail_out -= len;
+ strm->state->pending -= len;
+ if (strm->state->pending == 0) {
+ strm->state->pending_out = strm->state->pending_buf;
+ }
+}
+
+/* ========================================================================= */
+int ZEXPORT deflate (strm, flush)
+ z_streamp strm;
+ int flush;
+{
+ int old_flush; /* value of flush param for previous deflate call */
+ deflate_state *s;
+
+ if (strm == Z_NULL || strm->state == Z_NULL ||
+ flush > Z_BLOCK || flush < 0) {
+ return Z_STREAM_ERROR;
+ }
+ s = strm->state;
+
+ if (strm->next_out == Z_NULL ||
+ (strm->next_in == Z_NULL && strm->avail_in != 0) ||
+ (s->status == FINISH_STATE && flush != Z_FINISH)) {
+ ERR_RETURN(strm, Z_STREAM_ERROR);
+ }
+ if (strm->avail_out == 0) ERR_RETURN(strm, Z_BUF_ERROR);
+
+ s->strm = strm; /* just in case */
+ old_flush = s->last_flush;
+ s->last_flush = flush;
+
+ /* Write the header */
+ if (s->status == INIT_STATE) {
+#ifdef GZIP
+ if (s->wrap == 2) {
+ strm->adler = crc32(0L, Z_NULL, 0);
+ put_byte(s, 31);
+ put_byte(s, 139);
+ put_byte(s, 8);
+ if (s->gzhead == Z_NULL) {
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, s->level == 9 ? 2 :
+ (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ?
+ 4 : 0));
+ put_byte(s, OS_CODE);
+ s->status = BUSY_STATE;
+ }
+ else {
+ put_byte(s, (s->gzhead->text ? 1 : 0) +
+ (s->gzhead->hcrc ? 2 : 0) +
+ (s->gzhead->extra == Z_NULL ? 0 : 4) +
+ (s->gzhead->name == Z_NULL ? 0 : 8) +
+ (s->gzhead->comment == Z_NULL ? 0 : 16)
+ );
+ put_byte(s, (Byte)(s->gzhead->time & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 8) & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 16) & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 24) & 0xff));
+ put_byte(s, s->level == 9 ? 2 :
+ (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ?
+ 4 : 0));
+ put_byte(s, s->gzhead->os & 0xff);
+ if (s->gzhead->extra != Z_NULL) {
+ put_byte(s, s->gzhead->extra_len & 0xff);
+ put_byte(s, (s->gzhead->extra_len >> 8) & 0xff);
+ }
+ if (s->gzhead->hcrc)
+ strm->adler = crc32(strm->adler, s->pending_buf,
+ s->pending);
+ s->gzindex = 0;
+ s->status = EXTRA_STATE;
+ }
+ }
+ else
+#endif
+ {
+ uInt header = (Z_DEFLATED + ((s->w_bits-8)<<4)) << 8;
+ uInt level_flags;
+
+ if (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2)
+ level_flags = 0;
+ else if (s->level < 6)
+ level_flags = 1;
+ else if (s->level == 6)
+ level_flags = 2;
+ else
+ level_flags = 3;
+ header |= (level_flags << 6);
+ if (s->strstart != 0) header |= PRESET_DICT;
+ header += 31 - (header % 31);
+
+ s->status = BUSY_STATE;
+ putShortMSB(s, header);
+
+ /* Save the adler32 of the preset dictionary: */
+ if (s->strstart != 0) {
+ putShortMSB(s, (uInt)(strm->adler >> 16));
+ putShortMSB(s, (uInt)(strm->adler & 0xffff));
+ }
+ strm->adler = adler32(0L, Z_NULL, 0);
+ }
+ }
+#ifdef GZIP
+ if (s->status == EXTRA_STATE) {
+ if (s->gzhead->extra != Z_NULL) {
+ uInt beg = s->pending; /* start of bytes to update crc */
+
+ while (s->gzindex < (s->gzhead->extra_len & 0xffff)) {
+ if (s->pending == s->pending_buf_size) {
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ flush_pending(strm);
+ beg = s->pending;
+ if (s->pending == s->pending_buf_size)
+ break;
+ }
+ put_byte(s, s->gzhead->extra[s->gzindex]);
+ s->gzindex++;
+ }
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ if (s->gzindex == s->gzhead->extra_len) {
+ s->gzindex = 0;
+ s->status = NAME_STATE;
+ }
+ }
+ else
+ s->status = NAME_STATE;
+ }
+ if (s->status == NAME_STATE) {
+ if (s->gzhead->name != Z_NULL) {
+ uInt beg = s->pending; /* start of bytes to update crc */
+ int val;
+
+ do {
+ if (s->pending == s->pending_buf_size) {
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ flush_pending(strm);
+ beg = s->pending;
+ if (s->pending == s->pending_buf_size) {
+ val = 1;
+ break;
+ }
+ }
+ val = s->gzhead->name[s->gzindex++];
+ put_byte(s, val);
+ } while (val != 0);
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ if (val == 0) {
+ s->gzindex = 0;
+ s->status = COMMENT_STATE;
+ }
+ }
+ else
+ s->status = COMMENT_STATE;
+ }
+ if (s->status == COMMENT_STATE) {
+ if (s->gzhead->comment != Z_NULL) {
+ uInt beg = s->pending; /* start of bytes to update crc */
+ int val;
+
+ do {
+ if (s->pending == s->pending_buf_size) {
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ flush_pending(strm);
+ beg = s->pending;
+ if (s->pending == s->pending_buf_size) {
+ val = 1;
+ break;
+ }
+ }
+ val = s->gzhead->comment[s->gzindex++];
+ put_byte(s, val);
+ } while (val != 0);
+ if (s->gzhead->hcrc && s->pending > beg)
+ strm->adler = crc32(strm->adler, s->pending_buf + beg,
+ s->pending - beg);
+ if (val == 0)
+ s->status = HCRC_STATE;
+ }
+ else
+ s->status = HCRC_STATE;
+ }
+ if (s->status == HCRC_STATE) {
+ if (s->gzhead->hcrc) {
+ if (s->pending + 2 > s->pending_buf_size)
+ flush_pending(strm);
+ if (s->pending + 2 <= s->pending_buf_size) {
+ put_byte(s, (Byte)(strm->adler & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 8) & 0xff));
+ strm->adler = crc32(0L, Z_NULL, 0);
+ s->status = BUSY_STATE;
+ }
+ }
+ else
+ s->status = BUSY_STATE;
+ }
+#endif
+
+ /* Flush as much pending output as possible */
+ if (s->pending != 0) {
+ flush_pending(strm);
+ if (strm->avail_out == 0) {
+ /* Since avail_out is 0, deflate will be called again with
+ * more output space, but possibly with both pending and
+ * avail_in equal to zero. There won't be anything to do,
+ * but this is not an error situation so make sure we
+ * return OK instead of BUF_ERROR at next call of deflate:
+ */
+ s->last_flush = -1;
+ return Z_OK;
+ }
+
+ /* Make sure there is something to do and avoid duplicate consecutive
+ * flushes. For repeated and useless calls with Z_FINISH, we keep
+ * returning Z_STREAM_END instead of Z_BUF_ERROR.
+ */
+ } else if (strm->avail_in == 0 && flush <= old_flush &&
+ flush != Z_FINISH) {
+ ERR_RETURN(strm, Z_BUF_ERROR);
+ }
+
+ /* User must not provide more input after the first FINISH: */
+ if (s->status == FINISH_STATE && strm->avail_in != 0) {
+ ERR_RETURN(strm, Z_BUF_ERROR);
+ }
+
+ /* Start a new block or continue the current one.
+ */
+ if (strm->avail_in != 0 || s->lookahead != 0 ||
+ (flush != Z_NO_FLUSH && s->status != FINISH_STATE)) {
+ block_state bstate;
+
+ bstate = s->strategy == Z_HUFFMAN_ONLY ? deflate_huff(s, flush) :
+ (s->strategy == Z_RLE ? deflate_rle(s, flush) :
+ (*(configuration_table[s->level].func))(s, flush));
+
+ if (bstate == finish_started || bstate == finish_done) {
+ s->status = FINISH_STATE;
+ }
+ if (bstate == need_more || bstate == finish_started) {
+ if (strm->avail_out == 0) {
+ s->last_flush = -1; /* avoid BUF_ERROR next call, see above */
+ }
+ return Z_OK;
+ /* If flush != Z_NO_FLUSH && avail_out == 0, the next call
+ * of deflate should use the same flush parameter to make sure
+ * that the flush is complete. So we don't have to output an
+ * empty block here, this will be done at next call. This also
+ * ensures that for a very small output buffer, we emit at most
+ * one empty block.
+ */
+ }
+ if (bstate == block_done) {
+ if (flush == Z_PARTIAL_FLUSH) {
+ _tr_align(s);
+ } else if (flush != Z_BLOCK) { /* FULL_FLUSH or SYNC_FLUSH */
+ _tr_stored_block(s, (char*)0, 0L, 0);
+ /* For a full flush, this empty block will be recognized
+ * as a special marker by inflate_sync().
+ */
+ if (flush == Z_FULL_FLUSH) {
+ CLEAR_HASH(s); /* forget history */
+ if (s->lookahead == 0) {
+ s->strstart = 0;
+ s->block_start = 0L;
+ }
+ }
+ }
+ flush_pending(strm);
+ if (strm->avail_out == 0) {
+ s->last_flush = -1; /* avoid BUF_ERROR at next call, see above */
+ return Z_OK;
+ }
+ }
+ }
+ Assert(strm->avail_out > 0, "bug2");
+
+ if (flush != Z_FINISH) return Z_OK;
+ if (s->wrap <= 0) return Z_STREAM_END;
+
+ /* Write the trailer */
+#ifdef GZIP
+ if (s->wrap == 2) {
+ put_byte(s, (Byte)(strm->adler & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 8) & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 16) & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 24) & 0xff));
+ put_byte(s, (Byte)(strm->total_in & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 8) & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 16) & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 24) & 0xff));
+ }
+ else
+#endif
+ {
+ putShortMSB(s, (uInt)(strm->adler >> 16));
+ putShortMSB(s, (uInt)(strm->adler & 0xffff));
+ }
+ flush_pending(strm);
+ /* If avail_out is zero, the application will call deflate again
+ * to flush the rest.
+ */
+ if (s->wrap > 0) s->wrap = -s->wrap; /* write the trailer only once! */
+ return s->pending != 0 ? Z_OK : Z_STREAM_END;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateEnd (strm)
+ z_streamp strm;
+{
+ int status;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+
+ status = strm->state->status;
+ if (status != INIT_STATE &&
+ status != EXTRA_STATE &&
+ status != NAME_STATE &&
+ status != COMMENT_STATE &&
+ status != HCRC_STATE &&
+ status != BUSY_STATE &&
+ status != FINISH_STATE) {
+ return Z_STREAM_ERROR;
+ }
+
+ /* Deallocate in reverse order of allocations: */
+ TRY_FREE(strm, strm->state->pending_buf);
+ TRY_FREE(strm, strm->state->head);
+ TRY_FREE(strm, strm->state->prev);
+ TRY_FREE(strm, strm->state->window);
+
+ ZFREE(strm, strm->state);
+ strm->state = Z_NULL;
+
+ return status == BUSY_STATE ? Z_DATA_ERROR : Z_OK;
+}
+
+/* =========================================================================
+ * Copy the source state to the destination state.
+ * To simplify the source, this is not supported for 16-bit MSDOS (which
+ * doesn't have enough memory anyway to duplicate compression states).
+ */
+int ZEXPORT deflateCopy (dest, source)
+ z_streamp dest;
+ z_streamp source;
+{
+#ifdef MAXSEG_64K
+ return Z_STREAM_ERROR;
+#else
+ deflate_state *ds;
+ deflate_state *ss;
+ ushf *overlay;
+
+
+ if (source == Z_NULL || dest == Z_NULL || source->state == Z_NULL) {
+ return Z_STREAM_ERROR;
+ }
+
+ ss = source->state;
+
+ zmemcpy(dest, source, sizeof(z_stream));
+
+ ds = (deflate_state *) ZALLOC(dest, 1, sizeof(deflate_state));
+ if (ds == Z_NULL) return Z_MEM_ERROR;
+ dest->state = (struct internal_state FAR *) ds;
+ zmemcpy(ds, ss, sizeof(deflate_state));
+ ds->strm = dest;
+
+ ds->window = (Bytef *) ZALLOC(dest, ds->w_size, 2*sizeof(Byte));
+ ds->prev = (Posf *) ZALLOC(dest, ds->w_size, sizeof(Pos));
+ ds->head = (Posf *) ZALLOC(dest, ds->hash_size, sizeof(Pos));
+ overlay = (ushf *) ZALLOC(dest, ds->lit_bufsize, sizeof(ush)+2);
+ ds->pending_buf = (uchf *) overlay;
+
+ if (ds->window == Z_NULL || ds->prev == Z_NULL || ds->head == Z_NULL ||
+ ds->pending_buf == Z_NULL) {
+ deflateEnd (dest);
+ return Z_MEM_ERROR;
+ }
+ /* following zmemcpy do not work for 16-bit MSDOS */
+ zmemcpy(ds->window, ss->window, ds->w_size * 2 * sizeof(Byte));
+ zmemcpy(ds->prev, ss->prev, ds->w_size * sizeof(Pos));
+ zmemcpy(ds->head, ss->head, ds->hash_size * sizeof(Pos));
+ zmemcpy(ds->pending_buf, ss->pending_buf, (uInt)ds->pending_buf_size);
+
+ ds->pending_out = ds->pending_buf + (ss->pending_out - ss->pending_buf);
+ ds->d_buf = overlay + ds->lit_bufsize/sizeof(ush);
+ ds->l_buf = ds->pending_buf + (1+sizeof(ush))*ds->lit_bufsize;
+
+ ds->l_desc.dyn_tree = ds->dyn_ltree;
+ ds->d_desc.dyn_tree = ds->dyn_dtree;
+ ds->bl_desc.dyn_tree = ds->bl_tree;
+
+ return Z_OK;
+#endif /* MAXSEG_64K */
+}
+
+/* ===========================================================================
+ * Read a new buffer from the current input stream, update the adler32
+ * and total number of bytes read. All deflate() input goes through
+ * this function so some applications may wish to modify it to avoid
+ * allocating a large strm->next_in buffer and copying from it.
+ * (See also flush_pending()).
+ */
+local int read_buf(strm, buf, size)
+ z_streamp strm;
+ Bytef *buf;
+ unsigned size;
+{
+ unsigned len = strm->avail_in;
+
+ if (len > size) len = size;
+ if (len == 0) return 0;
+
+ strm->avail_in -= len;
+
+ if (strm->state->wrap == 1) {
+ strm->adler = adler32(strm->adler, strm->next_in, len);
+ }
+#ifdef GZIP
+ else if (strm->state->wrap == 2) {
+ strm->adler = crc32(strm->adler, strm->next_in, len);
+ }
+#endif
+ zmemcpy(buf, strm->next_in, len);
+ strm->next_in += len;
+ strm->total_in += len;
+
+ return (int)len;
+}
+
+/* ===========================================================================
+ * Initialize the "longest match" routines for a new zlib stream
+ */
+local void lm_init (s)
+ deflate_state *s;
+{
+ s->window_size = (ulg)2L*s->w_size;
+
+ CLEAR_HASH(s);
+
+ /* Set the default configuration parameters:
+ */
+ s->max_lazy_match = configuration_table[s->level].max_lazy;
+ s->good_match = configuration_table[s->level].good_length;
+ s->nice_match = configuration_table[s->level].nice_length;
+ s->max_chain_length = configuration_table[s->level].max_chain;
+
+ s->strstart = 0;
+ s->block_start = 0L;
+ s->lookahead = 0;
+ s->match_length = s->prev_length = MIN_MATCH-1;
+ s->match_available = 0;
+ s->ins_h = 0;
+#ifndef FASTEST
+#ifdef ASMV
+ match_init(); /* initialize the asm code */
+#endif
+#endif
+}
+
+#ifndef FASTEST
+/* ===========================================================================
+ * Set match_start to the longest match starting at the given string and
+ * return its length. Matches shorter or equal to prev_length are discarded,
+ * in which case the result is equal to prev_length and match_start is
+ * garbage.
+ * IN assertions: cur_match is the head of the hash chain for the current
+ * string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1
+ * OUT assertion: the match length is not greater than s->lookahead.
+ */
+#ifndef ASMV
+/* For 80x86 and 680x0, an optimized version will be provided in match.asm or
+ * match.S. The code will be functionally equivalent.
+ */
+local uInt longest_match(s, cur_match)
+ deflate_state *s;
+ IPos cur_match; /* current match */
+{
+ unsigned chain_length = s->max_chain_length;/* max hash chain length */
+ register Bytef *scan = s->window + s->strstart; /* current string */
+ register Bytef *match; /* matched string */
+ register int len; /* length of current match */
+ int best_len = s->prev_length; /* best match length so far */
+ int nice_match = s->nice_match; /* stop if match long enough */
+ IPos limit = s->strstart > (IPos)MAX_DIST(s) ?
+ s->strstart - (IPos)MAX_DIST(s) : NIL;
+ /* Stop when cur_match becomes <= limit. To simplify the code,
+ * we prevent matches with the string of window index 0.
+ */
+ Posf *prev = s->prev;
+ uInt wmask = s->w_mask;
+
+#ifdef UNALIGNED_OK
+ /* Compare two bytes at a time. Note: this is not always beneficial.
+ * Try with and without -DUNALIGNED_OK to check.
+ */
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1;
+ register ush scan_start = *(ushf*)scan;
+ register ush scan_end = *(ushf*)(scan+best_len-1);
+#else
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+ register Byte scan_end1 = scan[best_len-1];
+ register Byte scan_end = scan[best_len];
+#endif
+
+ /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ * It is easy to get rid of this optimization if necessary.
+ */
+ Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+ /* Do not waste too much time if we already have a good match: */
+ if (s->prev_length >= s->good_match) {
+ chain_length >>= 2;
+ }
+ /* Do not look for matches beyond the end of the input. This is necessary
+ * to make deflate deterministic.
+ */
+ if ((uInt)nice_match > s->lookahead) nice_match = s->lookahead;
+
+ Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+ do {
+ Assert(cur_match < s->strstart, "no future");
+ match = s->window + cur_match;
+
+ /* Skip to next match if the match length cannot increase
+ * or if the match length is less than 2. Note that the checks below
+ * for insufficient lookahead only occur occasionally for performance
+ * reasons. Therefore uninitialized memory will be accessed, and
+ * conditional jumps will be made that depend on those values.
+ * However the length of the match is limited to the lookahead, so
+ * the output of deflate is not affected by the uninitialized values.
+ */
+#if (defined(UNALIGNED_OK) && MAX_MATCH == 258)
+ /* This code assumes sizeof(unsigned short) == 2. Do not use
+ * UNALIGNED_OK if your compiler uses a different size.
+ */
+ if (*(ushf*)(match+best_len-1) != scan_end ||
+ *(ushf*)match != scan_start) continue;
+
+ /* It is not necessary to compare scan[2] and match[2] since they are
+ * always equal when the other bytes match, given that the hash keys
+ * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at
+ * strstart+3, +5, ... up to strstart+257. We check for insufficient
+ * lookahead only every 4th comparison; the 128th check will be made
+ * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is
+ * necessary to put more guard bytes at the end of the window, or
+ * to check more often for insufficient lookahead.
+ */
+ Assert(scan[2] == match[2], "scan[2]?");
+ scan++, match++;
+ do {
+ } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ scan < strend);
+ /* The funny "do {}" generates better code on most compilers */
+
+ /* Here, scan <= window+strstart+257 */
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+ if (*scan == *match) scan++;
+
+ len = (MAX_MATCH - 1) - (int)(strend-scan);
+ scan = strend - (MAX_MATCH-1);
+
+#else /* UNALIGNED_OK */
+
+ if (match[best_len] != scan_end ||
+ match[best_len-1] != scan_end1 ||
+ *match != *scan ||
+ *++match != scan[1]) continue;
+
+ /* The check at best_len-1 can be removed because it will be made
+ * again later. (This heuristic is not always a win.)
+ * It is not necessary to compare scan[2] and match[2] since they
+ * are always equal when the other bytes match, given that
+ * the hash keys are equal and that HASH_BITS >= 8.
+ */
+ scan += 2, match++;
+ Assert(*scan == *match, "match[2]?");
+
+ /* We check for insufficient lookahead only every 8th comparison;
+ * the 256th check will be made at strstart+258.
+ */
+ do {
+ } while (*++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ scan < strend);
+
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+ len = MAX_MATCH - (int)(strend - scan);
+ scan = strend - MAX_MATCH;
+
+#endif /* UNALIGNED_OK */
+
+ if (len > best_len) {
+ s->match_start = cur_match;
+ best_len = len;
+ if (len >= nice_match) break;
+#ifdef UNALIGNED_OK
+ scan_end = *(ushf*)(scan+best_len-1);
+#else
+ scan_end1 = scan[best_len-1];
+ scan_end = scan[best_len];
+#endif
+ }
+ } while ((cur_match = prev[cur_match & wmask]) > limit
+ && --chain_length != 0);
+
+ if ((uInt)best_len <= s->lookahead) return (uInt)best_len;
+ return s->lookahead;
+}
+#endif /* ASMV */
+
+#else /* FASTEST */
+
+/* ---------------------------------------------------------------------------
+ * Optimized version for FASTEST only
+ */
+local uInt longest_match(s, cur_match)
+ deflate_state *s;
+ IPos cur_match; /* current match */
+{
+ register Bytef *scan = s->window + s->strstart; /* current string */
+ register Bytef *match; /* matched string */
+ register int len; /* length of current match */
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+
+ /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ * It is easy to get rid of this optimization if necessary.
+ */
+ Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+ Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+ Assert(cur_match < s->strstart, "no future");
+
+ match = s->window + cur_match;
+
+ /* Return failure if the match length is less than 2:
+ */
+ if (match[0] != scan[0] || match[1] != scan[1]) return MIN_MATCH-1;
+
+ /* The check at best_len-1 can be removed because it will be made
+ * again later. (This heuristic is not always a win.)
+ * It is not necessary to compare scan[2] and match[2] since they
+ * are always equal when the other bytes match, given that
+ * the hash keys are equal and that HASH_BITS >= 8.
+ */
+ scan += 2, match += 2;
+ Assert(*scan == *match, "match[2]?");
+
+ /* We check for insufficient lookahead only every 8th comparison;
+ * the 256th check will be made at strstart+258.
+ */
+ do {
+ } while (*++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ scan < strend);
+
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+ len = MAX_MATCH - (int)(strend - scan);
+
+ if (len < MIN_MATCH) return MIN_MATCH - 1;
+
+ s->match_start = cur_match;
+ return (uInt)len <= s->lookahead ? (uInt)len : s->lookahead;
+}
+
+#endif /* FASTEST */
+
+#ifdef DEBUG
+/* ===========================================================================
+ * Check that the match at match_start is indeed a match.
+ */
+local void check_match(s, start, match, length)
+ deflate_state *s;
+ IPos start, match;
+ int length;
+{
+ /* check that the match is indeed a match */
+ if (zmemcmp(s->window + match,
+ s->window + start, length) != EQUAL) {
+ fprintf(stderr, " start %u, match %u, length %d\n",
+ start, match, length);
+ do {
+ fprintf(stderr, "%c%c", s->window[match++], s->window[start++]);
+ } while (--length != 0);
+ z_error("invalid match");
+ }
+ if (z_verbose > 1) {
+ fprintf(stderr,"\\[%d,%d]", start-match, length);
+ do { putc(s->window[start++], stderr); } while (--length != 0);
+ }
+}
+#else
+# define check_match(s, start, match, length)
+#endif /* DEBUG */
+
+/* ===========================================================================
+ * Fill the window when the lookahead becomes insufficient.
+ * Updates strstart and lookahead.
+ *
+ * IN assertion: lookahead < MIN_LOOKAHEAD
+ * OUT assertions: strstart <= window_size-MIN_LOOKAHEAD
+ * At least one byte has been read, or avail_in == 0; reads are
+ * performed for at least two bytes (required for the zip translate_eol
+ * option -- not supported here).
+ */
+local void fill_window(s)
+ deflate_state *s;
+{
+ register unsigned n, m;
+ register Posf *p;
+ unsigned more; /* Amount of free space at the end of the window. */
+ uInt wsize = s->w_size;
+
+ do {
+ more = (unsigned)(s->window_size -(ulg)s->lookahead -(ulg)s->strstart);
+
+ /* Deal with !@#$% 64K limit: */
+ if (sizeof(int) <= 2) {
+ if (more == 0 && s->strstart == 0 && s->lookahead == 0) {
+ more = wsize;
+
+ } else if (more == (unsigned)(-1)) {
+ /* Very unlikely, but possible on 16 bit machine if
+ * strstart == 0 && lookahead == 1 (input done a byte at time)
+ */
+ more--;
+ }
+ }
+
+ /* If the window is almost full and there is insufficient lookahead,
+ * move the upper half to the lower one to make room in the upper half.
+ */
+ if (s->strstart >= wsize+MAX_DIST(s)) {
+
+ zmemcpy(s->window, s->window+wsize, (unsigned)wsize);
+ s->match_start -= wsize;
+ s->strstart -= wsize; /* we now have strstart >= MAX_DIST */
+ s->block_start -= (long) wsize;
+
+ /* Slide the hash table (could be avoided with 32 bit values
+ at the expense of memory usage). We slide even when level == 0
+ to keep the hash table consistent if we switch back to level > 0
+ later. (Using level 0 permanently is not an optimal usage of
+ zlib, so we don't care about this pathological case.)
+ */
+ n = s->hash_size;
+ p = &s->head[n];
+ do {
+ m = *--p;
+ *p = (Pos)(m >= wsize ? m-wsize : NIL);
+ } while (--n);
+
+ n = wsize;
+#ifndef FASTEST
+ p = &s->prev[n];
+ do {
+ m = *--p;
+ *p = (Pos)(m >= wsize ? m-wsize : NIL);
+ /* If n is not on any hash chain, prev[n] is garbage but
+ * its value will never be used.
+ */
+ } while (--n);
+#endif
+ more += wsize;
+ }
+ if (s->strm->avail_in == 0) return;
+
+ /* If there was no sliding:
+ * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 &&
+ * more == window_size - lookahead - strstart
+ * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1)
+ * => more >= window_size - 2*WSIZE + 2
+ * In the BIG_MEM or MMAP case (not yet supported),
+ * window_size == input_size + MIN_LOOKAHEAD &&
+ * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD.
+ * Otherwise, window_size == 2*WSIZE so more >= 2.
+ * If there was sliding, more >= WSIZE. So in all cases, more >= 2.
+ */
+ Assert(more >= 2, "more < 2");
+
+ n = read_buf(s->strm, s->window + s->strstart + s->lookahead, more);
+ s->lookahead += n;
+
+ /* Initialize the hash value now that we have some input: */
+ if (s->lookahead >= MIN_MATCH) {
+ s->ins_h = s->window[s->strstart];
+ UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]);
+#if MIN_MATCH != 3
+ Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+ }
+ /* If the whole input has less than MIN_MATCH bytes, ins_h is garbage,
+ * but this is not important since only literal bytes will be emitted.
+ */
+
+ } while (s->lookahead < MIN_LOOKAHEAD && s->strm->avail_in != 0);
+
+ /* If the WIN_INIT bytes after the end of the current data have never been
+ * written, then zero those bytes in order to avoid memory check reports of
+ * the use of uninitialized (or uninitialised as Julian writes) bytes by
+ * the longest match routines. Update the high water mark for the next
+ * time through here. WIN_INIT is set to MAX_MATCH since the longest match
+ * routines allow scanning to strstart + MAX_MATCH, ignoring lookahead.
+ */
+ if (s->high_water < s->window_size) {
+ ulg curr = s->strstart + (ulg)(s->lookahead);
+ ulg init;
+
+ if (s->high_water < curr) {
+ /* Previous high water mark below current data -- zero WIN_INIT
+ * bytes or up to end of window, whichever is less.
+ */
+ init = s->window_size - curr;
+ if (init > WIN_INIT)
+ init = WIN_INIT;
+ zmemzero(s->window + curr, (unsigned)init);
+ s->high_water = curr + init;
+ }
+ else if (s->high_water < (ulg)curr + WIN_INIT) {
+ /* High water mark at or above current data, but below current data
+ * plus WIN_INIT -- zero out to current data plus WIN_INIT, or up
+ * to end of window, whichever is less.
+ */
+ init = (ulg)curr + WIN_INIT - s->high_water;
+ if (init > s->window_size - s->high_water)
+ init = s->window_size - s->high_water;
+ zmemzero(s->window + s->high_water, (unsigned)init);
+ s->high_water += init;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Flush the current block, with given end-of-file flag.
+ * IN assertion: strstart is set to the end of the current match.
+ */
+#define FLUSH_BLOCK_ONLY(s, last) { \
+ _tr_flush_block(s, (s->block_start >= 0L ? \
+ (charf *)&s->window[(unsigned)s->block_start] : \
+ (charf *)Z_NULL), \
+ (ulg)((long)s->strstart - s->block_start), \
+ (last)); \
+ s->block_start = s->strstart; \
+ flush_pending(s->strm); \
+ Tracev((stderr,"[FLUSH]")); \
+}
+
+/* Same but force premature exit if necessary. */
+#define FLUSH_BLOCK(s, last) { \
+ FLUSH_BLOCK_ONLY(s, last); \
+ if (s->strm->avail_out == 0) return (last) ? finish_started : need_more; \
+}
+
+/* ===========================================================================
+ * Copy without compression as much as possible from the input stream, return
+ * the current block state.
+ * This function does not insert new strings in the dictionary since
+ * uncompressible data is probably not useful. This function is used
+ * only for the level=0 compression option.
+ * NOTE: this function should be optimized to avoid extra copying from
+ * window to pending_buf.
+ */
+local block_state deflate_stored(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ /* Stored blocks are limited to 0xffff bytes, pending_buf is limited
+ * to pending_buf_size, and each stored block has a 5 byte header:
+ */
+ ulg max_block_size = 0xffff;
+ ulg max_start;
+
+ if (max_block_size > s->pending_buf_size - 5) {
+ max_block_size = s->pending_buf_size - 5;
+ }
+
+ /* Copy as much as possible from input to output: */
+ for (;;) {
+ /* Fill the window as much as possible: */
+ if (s->lookahead <= 1) {
+
+ Assert(s->strstart < s->w_size+MAX_DIST(s) ||
+ s->block_start >= (long)s->w_size, "slide too late");
+
+ fill_window(s);
+ if (s->lookahead == 0 && flush == Z_NO_FLUSH) return need_more;
+
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+ Assert(s->block_start >= 0L, "block gone");
+
+ s->strstart += s->lookahead;
+ s->lookahead = 0;
+
+ /* Emit a stored block if pending_buf will be full: */
+ max_start = s->block_start + max_block_size;
+ if (s->strstart == 0 || (ulg)s->strstart >= max_start) {
+ /* strstart == 0 is possible when wraparound on 16-bit machine */
+ s->lookahead = (uInt)(s->strstart - max_start);
+ s->strstart = (uInt)max_start;
+ FLUSH_BLOCK(s, 0);
+ }
+ /* Flush if we may have to slide, otherwise block_start may become
+ * negative and the data will be gone:
+ */
+ if (s->strstart - (uInt)s->block_start >= MAX_DIST(s)) {
+ FLUSH_BLOCK(s, 0);
+ }
+ }
+ FLUSH_BLOCK(s, flush == Z_FINISH);
+ return flush == Z_FINISH ? finish_done : block_done;
+}
+
+/* ===========================================================================
+ * Compress as much as possible from the input stream, return the current
+ * block state.
+ * This function does not perform lazy evaluation of matches and inserts
+ * new strings in the dictionary only for unmatched strings or for short
+ * matches. It is used only for the fast compression options.
+ */
+local block_state deflate_fast(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ IPos hash_head; /* head of the hash chain */
+ int bflush; /* set if current block must be flushed */
+
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the next match, plus MIN_MATCH bytes to insert the
+ * string following the next match.
+ */
+ if (s->lookahead < MIN_LOOKAHEAD) {
+ fill_window(s);
+ if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* Insert the string window[strstart .. strstart+2] in the
+ * dictionary, and set hash_head to the head of the hash chain:
+ */
+ hash_head = NIL;
+ if (s->lookahead >= MIN_MATCH) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+
+ /* Find the longest match, discarding those <= prev_length.
+ * At this point we have always match_length < MIN_MATCH
+ */
+ if (hash_head != NIL && s->strstart - hash_head <= MAX_DIST(s)) {
+ /* To simplify the code, we prevent matches with the string
+ * of window index 0 (in particular we have to avoid a match
+ * of the string with itself at the start of the input file).
+ */
+ s->match_length = longest_match (s, hash_head);
+ /* longest_match() sets match_start */
+ }
+ if (s->match_length >= MIN_MATCH) {
+ check_match(s, s->strstart, s->match_start, s->match_length);
+
+ _tr_tally_dist(s, s->strstart - s->match_start,
+ s->match_length - MIN_MATCH, bflush);
+
+ s->lookahead -= s->match_length;
+
+ /* Insert new strings in the hash table only if the match length
+ * is not too large. This saves time but degrades compression.
+ */
+#ifndef FASTEST
+ if (s->match_length <= s->max_insert_length &&
+ s->lookahead >= MIN_MATCH) {
+ s->match_length--; /* string at strstart already in table */
+ do {
+ s->strstart++;
+ INSERT_STRING(s, s->strstart, hash_head);
+ /* strstart never exceeds WSIZE-MAX_MATCH, so there are
+ * always MIN_MATCH bytes ahead.
+ */
+ } while (--s->match_length != 0);
+ s->strstart++;
+ } else
+#endif
+ {
+ s->strstart += s->match_length;
+ s->match_length = 0;
+ s->ins_h = s->window[s->strstart];
+ UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]);
+#if MIN_MATCH != 3
+ Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+ /* If lookahead < MIN_MATCH, ins_h is garbage, but it does not
+ * matter since it will be recomputed at next deflate call.
+ */
+ }
+ } else {
+ /* No match, output a literal byte */
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ }
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ FLUSH_BLOCK(s, flush == Z_FINISH);
+ return flush == Z_FINISH ? finish_done : block_done;
+}
+
+#ifndef FASTEST
+/* ===========================================================================
+ * Same as above, but achieves better compression. We use a lazy
+ * evaluation for matches: a match is finally adopted only if there is
+ * no better match at the next window position.
+ */
+local block_state deflate_slow(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ IPos hash_head; /* head of hash chain */
+ int bflush; /* set if current block must be flushed */
+
+ /* Process the input block. */
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the next match, plus MIN_MATCH bytes to insert the
+ * string following the next match.
+ */
+ if (s->lookahead < MIN_LOOKAHEAD) {
+ fill_window(s);
+ if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* Insert the string window[strstart .. strstart+2] in the
+ * dictionary, and set hash_head to the head of the hash chain:
+ */
+ hash_head = NIL;
+ if (s->lookahead >= MIN_MATCH) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+
+ /* Find the longest match, discarding those <= prev_length.
+ */
+ s->prev_length = s->match_length, s->prev_match = s->match_start;
+ s->match_length = MIN_MATCH-1;
+
+ if (hash_head != NIL && s->prev_length < s->max_lazy_match &&
+ s->strstart - hash_head <= MAX_DIST(s)) {
+ /* To simplify the code, we prevent matches with the string
+ * of window index 0 (in particular we have to avoid a match
+ * of the string with itself at the start of the input file).
+ */
+ s->match_length = longest_match (s, hash_head);
+ /* longest_match() sets match_start */
+
+ if (s->match_length <= 5 && (s->strategy == Z_FILTERED
+#if TOO_FAR <= 32767
+ || (s->match_length == MIN_MATCH &&
+ s->strstart - s->match_start > TOO_FAR)
+#endif
+ )) {
+
+ /* If prev_match is also MIN_MATCH, match_start is garbage
+ * but we will ignore the current match anyway.
+ */
+ s->match_length = MIN_MATCH-1;
+ }
+ }
+ /* If there was a match at the previous step and the current
+ * match is not better, output the previous match:
+ */
+ if (s->prev_length >= MIN_MATCH && s->match_length <= s->prev_length) {
+ uInt max_insert = s->strstart + s->lookahead - MIN_MATCH;
+ /* Do not insert strings in hash table beyond this. */
+
+ check_match(s, s->strstart-1, s->prev_match, s->prev_length);
+
+ _tr_tally_dist(s, s->strstart -1 - s->prev_match,
+ s->prev_length - MIN_MATCH, bflush);
+
+ /* Insert in hash table all strings up to the end of the match.
+ * strstart-1 and strstart are already inserted. If there is not
+ * enough lookahead, the last two strings are not inserted in
+ * the hash table.
+ */
+ s->lookahead -= s->prev_length-1;
+ s->prev_length -= 2;
+ do {
+ if (++s->strstart <= max_insert) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+ } while (--s->prev_length != 0);
+ s->match_available = 0;
+ s->match_length = MIN_MATCH-1;
+ s->strstart++;
+
+ if (bflush) FLUSH_BLOCK(s, 0);
+
+ } else if (s->match_available) {
+ /* If there was no match at the previous position, output a
+ * single literal. If there was a match but the current match
+ * is longer, truncate the previous match to a single literal.
+ */
+ Tracevv((stderr,"%c", s->window[s->strstart-1]));
+ _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+ if (bflush) {
+ FLUSH_BLOCK_ONLY(s, 0);
+ }
+ s->strstart++;
+ s->lookahead--;
+ if (s->strm->avail_out == 0) return need_more;
+ } else {
+ /* There is no previous match to compare with, wait for
+ * the next step to decide.
+ */
+ s->match_available = 1;
+ s->strstart++;
+ s->lookahead--;
+ }
+ }
+ Assert (flush != Z_NO_FLUSH, "no flush?");
+ if (s->match_available) {
+ Tracevv((stderr,"%c", s->window[s->strstart-1]));
+ _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+ s->match_available = 0;
+ }
+ FLUSH_BLOCK(s, flush == Z_FINISH);
+ return flush == Z_FINISH ? finish_done : block_done;
+}
+#endif /* FASTEST */
+
+/* ===========================================================================
+ * For Z_RLE, simply look for runs of bytes, generate matches only of distance
+ * one. Do not maintain a hash table. (It will be regenerated if this run of
+ * deflate switches away from Z_RLE.)
+ */
+local block_state deflate_rle(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ int bflush; /* set if current block must be flushed */
+ uInt prev; /* byte at distance one to match */
+ Bytef *scan, *strend; /* scan goes up to strend for length of run */
+
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the longest encodable run.
+ */
+ if (s->lookahead < MAX_MATCH) {
+ fill_window(s);
+ if (s->lookahead < MAX_MATCH && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* See how many times the previous byte repeats */
+ s->match_length = 0;
+ if (s->lookahead >= MIN_MATCH && s->strstart > 0) {
+ scan = s->window + s->strstart - 1;
+ prev = *scan;
+ if (prev == *++scan && prev == *++scan && prev == *++scan) {
+ strend = s->window + s->strstart + MAX_MATCH;
+ do {
+ } while (prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ scan < strend);
+ s->match_length = MAX_MATCH - (int)(strend - scan);
+ if (s->match_length > s->lookahead)
+ s->match_length = s->lookahead;
+ }
+ }
+
+ /* Emit match if have run of MIN_MATCH or longer, else emit literal */
+ if (s->match_length >= MIN_MATCH) {
+ check_match(s, s->strstart, s->strstart - 1, s->match_length);
+
+ _tr_tally_dist(s, 1, s->match_length - MIN_MATCH, bflush);
+
+ s->lookahead -= s->match_length;
+ s->strstart += s->match_length;
+ s->match_length = 0;
+ } else {
+ /* No match, output a literal byte */
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ }
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ FLUSH_BLOCK(s, flush == Z_FINISH);
+ return flush == Z_FINISH ? finish_done : block_done;
+}
+
+/* ===========================================================================
+ * For Z_HUFFMAN_ONLY, do not look for matches. Do not maintain a hash table.
+ * (It will be regenerated if this run of deflate switches away from Huffman.)
+ */
+local block_state deflate_huff(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ int bflush; /* set if current block must be flushed */
+
+ for (;;) {
+ /* Make sure that we have a literal to write. */
+ if (s->lookahead == 0) {
+ fill_window(s);
+ if (s->lookahead == 0) {
+ if (flush == Z_NO_FLUSH)
+ return need_more;
+ break; /* flush the current block */
+ }
+ }
+
+ /* Output a literal byte */
+ s->match_length = 0;
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ FLUSH_BLOCK(s, flush == Z_FINISH);
+ return flush == Z_FINISH ? finish_done : block_done;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/deflate.h b/test/monniaux/glpk-4.65/src/zlib/deflate.h
new file mode 100644
index 00000000..cbf0d1ea
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/deflate.h
@@ -0,0 +1,342 @@
+/* deflate.h -- internal compression state
+ * Copyright (C) 1995-2010 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* @(#) $Id$ */
+
+#ifndef DEFLATE_H
+#define DEFLATE_H
+
+#include "zutil.h"
+
+/* define NO_GZIP when compiling if you want to disable gzip header and
+ trailer creation by deflate(). NO_GZIP would be used to avoid linking in
+ the crc code when it is not needed. For shared libraries, gzip encoding
+ should be left enabled. */
+#ifndef NO_GZIP
+# define GZIP
+#endif
+
+/* ===========================================================================
+ * Internal compression state.
+ */
+
+#define LENGTH_CODES 29
+/* number of length codes, not counting the special END_BLOCK code */
+
+#define LITERALS 256
+/* number of literal bytes 0..255 */
+
+#define L_CODES (LITERALS+1+LENGTH_CODES)
+/* number of Literal or Length codes, including the END_BLOCK code */
+
+#define D_CODES 30
+/* number of distance codes */
+
+#define BL_CODES 19
+/* number of codes used to transfer the bit lengths */
+
+#define HEAP_SIZE (2*L_CODES+1)
+/* maximum heap size */
+
+#define MAX_BITS 15
+/* All codes must not exceed MAX_BITS bits */
+
+#define INIT_STATE 42
+#define EXTRA_STATE 69
+#define NAME_STATE 73
+#define COMMENT_STATE 91
+#define HCRC_STATE 103
+#define BUSY_STATE 113
+#define FINISH_STATE 666
+/* Stream status */
+
+
+/* Data structure describing a single value and its code string. */
+typedef struct ct_data_s {
+ union {
+ ush freq; /* frequency count */
+ ush code; /* bit string */
+ } fc;
+ union {
+ ush dad; /* father node in Huffman tree */
+ ush len; /* length of bit string */
+ } dl;
+} FAR ct_data;
+
+#define Freq fc.freq
+#define Code fc.code
+#define Dad dl.dad
+#define Len dl.len
+
+typedef struct static_tree_desc_s static_tree_desc;
+
+typedef struct tree_desc_s {
+ ct_data *dyn_tree; /* the dynamic tree */
+ int max_code; /* largest code with non zero frequency */
+ static_tree_desc *stat_desc; /* the corresponding static tree */
+} FAR tree_desc;
+
+typedef ush Pos;
+typedef Pos FAR Posf;
+typedef unsigned IPos;
+
+/* A Pos is an index in the character window. We use short instead of int to
+ * save space in the various tables. IPos is used only for parameter passing.
+ */
+
+typedef struct internal_state {
+ z_streamp strm; /* pointer back to this zlib stream */
+ int status; /* as the name implies */
+ Bytef *pending_buf; /* output still pending */
+ ulg pending_buf_size; /* size of pending_buf */
+ Bytef *pending_out; /* next pending byte to output to the stream */
+ uInt pending; /* nb of bytes in the pending buffer */
+ int wrap; /* bit 0 true for zlib, bit 1 true for gzip */
+ gz_headerp gzhead; /* gzip header information to write */
+ uInt gzindex; /* where in extra, name, or comment */
+ Byte method; /* STORED (for zip only) or DEFLATED */
+ int last_flush; /* value of flush param for previous deflate call */
+
+ /* used by deflate.c: */
+
+ uInt w_size; /* LZ77 window size (32K by default) */
+ uInt w_bits; /* log2(w_size) (8..16) */
+ uInt w_mask; /* w_size - 1 */
+
+ Bytef *window;
+ /* Sliding window. Input bytes are read into the second half of the window,
+ * and move to the first half later to keep a dictionary of at least wSize
+ * bytes. With this organization, matches are limited to a distance of
+ * wSize-MAX_MATCH bytes, but this ensures that IO is always
+ * performed with a length multiple of the block size. Also, it limits
+ * the window size to 64K, which is quite useful on MSDOS.
+ * To do: use the user input buffer as sliding window.
+ */
+
+ ulg window_size;
+ /* Actual size of window: 2*wSize, except when the user input buffer
+ * is directly used as sliding window.
+ */
+
+ Posf *prev;
+ /* Link to older string with same hash index. To limit the size of this
+ * array to 64K, this link is maintained only for the last 32K strings.
+ * An index in this array is thus a window index modulo 32K.
+ */
+
+ Posf *head; /* Heads of the hash chains or NIL. */
+
+ uInt ins_h; /* hash index of string to be inserted */
+ uInt hash_size; /* number of elements in hash table */
+ uInt hash_bits; /* log2(hash_size) */
+ uInt hash_mask; /* hash_size-1 */
+
+ uInt hash_shift;
+ /* Number of bits by which ins_h must be shifted at each input
+ * step. It must be such that after MIN_MATCH steps, the oldest
+ * byte no longer takes part in the hash key, that is:
+ * hash_shift * MIN_MATCH >= hash_bits
+ */
+
+ long block_start;
+ /* Window position at the beginning of the current output block. Gets
+ * negative when the window is moved backwards.
+ */
+
+ uInt match_length; /* length of best match */
+ IPos prev_match; /* previous match */
+ int match_available; /* set if previous match exists */
+ uInt strstart; /* start of string to insert */
+ uInt match_start; /* start of matching string */
+ uInt lookahead; /* number of valid bytes ahead in window */
+
+ uInt prev_length;
+ /* Length of the best match at previous step. Matches not greater than this
+ * are discarded. This is used in the lazy match evaluation.
+ */
+
+ uInt max_chain_length;
+ /* To speed up deflation, hash chains are never searched beyond this
+ * length. A higher limit improves compression ratio but degrades the
+ * speed.
+ */
+
+ uInt max_lazy_match;
+ /* Attempt to find a better match only when the current match is strictly
+ * smaller than this value. This mechanism is used only for compression
+ * levels >= 4.
+ */
+# define max_insert_length max_lazy_match
+ /* Insert new strings in the hash table only if the match length is not
+ * greater than this length. This saves time but degrades compression.
+ * max_insert_length is used only for compression levels <= 3.
+ */
+
+ int level; /* compression level (1..9) */
+ int strategy; /* favor or force Huffman coding*/
+
+ uInt good_match;
+ /* Use a faster search when the previous match is longer than this */
+
+ int nice_match; /* Stop searching when current match exceeds this */
+
+ /* used by trees.c: */
+ /* Didn't use ct_data typedef below to supress compiler warning */
+ struct ct_data_s dyn_ltree[HEAP_SIZE]; /* literal and length tree */
+ struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */
+ struct ct_data_s bl_tree[2*BL_CODES+1]; /* Huffman tree for bit lengths */
+
+ struct tree_desc_s l_desc; /* desc. for literal tree */
+ struct tree_desc_s d_desc; /* desc. for distance tree */
+ struct tree_desc_s bl_desc; /* desc. for bit length tree */
+
+ ush bl_count[MAX_BITS+1];
+ /* number of codes at each bit length for an optimal tree */
+
+ int heap[2*L_CODES+1]; /* heap used to build the Huffman trees */
+ int heap_len; /* number of elements in the heap */
+ int heap_max; /* element of largest frequency */
+ /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
+ * The same heap array is used to build all trees.
+ */
+
+ uch depth[2*L_CODES+1];
+ /* Depth of each subtree used as tie breaker for trees of equal frequency
+ */
+
+ uchf *l_buf; /* buffer for literals or lengths */
+
+ uInt lit_bufsize;
+ /* Size of match buffer for literals/lengths. There are 4 reasons for
+ * limiting lit_bufsize to 64K:
+ * - frequencies can be kept in 16 bit counters
+ * - if compression is not successful for the first block, all input
+ * data is still in the window so we can still emit a stored block even
+ * when input comes from standard input. (This can also be done for
+ * all blocks if lit_bufsize is not greater than 32K.)
+ * - if compression is not successful for a file smaller than 64K, we can
+ * even emit a stored file instead of a stored block (saving 5 bytes).
+ * This is applicable only for zip (not gzip or zlib).
+ * - creating new Huffman trees less frequently may not provide fast
+ * adaptation to changes in the input data statistics. (Take for
+ * example a binary file with poorly compressible code followed by
+ * a highly compressible string table.) Smaller buffer sizes give
+ * fast adaptation but have of course the overhead of transmitting
+ * trees more frequently.
+ * - I can't count above 4
+ */
+
+ uInt last_lit; /* running index in l_buf */
+
+ ushf *d_buf;
+ /* Buffer for distances. To simplify the code, d_buf and l_buf have
+ * the same number of elements. To use different lengths, an extra flag
+ * array would be necessary.
+ */
+
+ ulg opt_len; /* bit length of current block with optimal trees */
+ ulg static_len; /* bit length of current block with static trees */
+ uInt matches; /* number of string matches in current block */
+ int last_eob_len; /* bit length of EOB code for last block */
+
+#ifdef DEBUG
+ ulg compressed_len; /* total bit length of compressed file mod 2^32 */
+ ulg bits_sent; /* bit length of compressed data sent mod 2^32 */
+#endif
+
+ ush bi_buf;
+ /* Output buffer. bits are inserted starting at the bottom (least
+ * significant bits).
+ */
+ int bi_valid;
+ /* Number of valid bits in bi_buf. All bits above the last valid bit
+ * are always zero.
+ */
+
+ ulg high_water;
+ /* High water mark offset in window for initialized bytes -- bytes above
+ * this are set to zero in order to avoid memory check warnings when
+ * longest match routines access bytes past the input. This is then
+ * updated to the new high water mark.
+ */
+
+} FAR deflate_state;
+
+/* Output a byte on the stream.
+ * IN assertion: there is enough room in pending_buf.
+ */
+#define put_byte(s, c) {s->pending_buf[s->pending++] = (c);}
+
+
+#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1)
+/* Minimum amount of lookahead, except at the end of the input file.
+ * See deflate.c for comments about the MIN_MATCH+1.
+ */
+
+#define MAX_DIST(s) ((s)->w_size-MIN_LOOKAHEAD)
+/* In order to simplify the code, particularly on 16 bit machines, match
+ * distances are limited to MAX_DIST instead of WSIZE.
+ */
+
+#define WIN_INIT MAX_MATCH
+/* Number of bytes after end of data in window to initialize in order to avoid
+ memory checker errors from longest match routines */
+
+ /* in trees.c */
+void ZLIB_INTERNAL _tr_init OF((deflate_state *s));
+int ZLIB_INTERNAL _tr_tally OF((deflate_state *s, unsigned dist, unsigned lc));
+void ZLIB_INTERNAL _tr_flush_block OF((deflate_state *s, charf *buf,
+ ulg stored_len, int last));
+void ZLIB_INTERNAL _tr_align OF((deflate_state *s));
+void ZLIB_INTERNAL _tr_stored_block OF((deflate_state *s, charf *buf,
+ ulg stored_len, int last));
+
+#define d_code(dist) \
+ ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)])
+/* Mapping from a distance to a distance code. dist is the distance - 1 and
+ * must not have side effects. _dist_code[256] and _dist_code[257] are never
+ * used.
+ */
+
+#ifndef DEBUG
+/* Inline versions of _tr_tally for speed: */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+ extern uch ZLIB_INTERNAL _length_code[];
+ extern uch ZLIB_INTERNAL _dist_code[];
+#else
+ extern const uch ZLIB_INTERNAL _length_code[];
+ extern const uch ZLIB_INTERNAL _dist_code[];
+#endif
+
+# define _tr_tally_lit(s, c, flush) \
+ { uch cc = (c); \
+ s->d_buf[s->last_lit] = 0; \
+ s->l_buf[s->last_lit++] = cc; \
+ s->dyn_ltree[cc].Freq++; \
+ flush = (s->last_lit == s->lit_bufsize-1); \
+ }
+# define _tr_tally_dist(s, distance, length, flush) \
+ { uch len = (length); \
+ ush dist = (distance); \
+ s->d_buf[s->last_lit] = dist; \
+ s->l_buf[s->last_lit++] = len; \
+ dist--; \
+ s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \
+ s->dyn_dtree[d_code(dist)].Freq++; \
+ flush = (s->last_lit == s->lit_bufsize-1); \
+ }
+#else
+# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c)
+# define _tr_tally_dist(s, distance, length, flush) \
+ flush = _tr_tally(s, distance, length)
+#endif
+
+#endif /* DEFLATE_H */
diff --git a/test/monniaux/glpk-4.65/src/zlib/gzclose.c b/test/monniaux/glpk-4.65/src/zlib/gzclose.c
new file mode 100644
index 00000000..caeb99a3
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/gzclose.c
@@ -0,0 +1,25 @@
+/* gzclose.c -- zlib gzclose() function
+ * Copyright (C) 2004, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* gzclose() is in a separate file so that it is linked in only if it is used.
+ That way the other gzclose functions can be used instead to avoid linking in
+ unneeded compression or decompression routines. */
+int ZEXPORT gzclose(file)
+ gzFile file;
+{
+#ifndef NO_GZCOMPRESS
+ gz_statep state;
+
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ return state->mode == GZ_READ ? gzclose_r(file) : gzclose_w(file);
+#else
+ return gzclose_r(file);
+#endif
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/gzguts.h b/test/monniaux/glpk-4.65/src/zlib/gzguts.h
new file mode 100644
index 00000000..9d01ac7b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/gzguts.h
@@ -0,0 +1,74 @@
+/* gzguts.h (zlib internal header definitions for gz* operations) */
+
+/* Modified by Andrew Makhorin <mao@gnu.org>, April 2011 */
+
+/* Copyright (C) 2004, 2005, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in
+ * zlib.h */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h. */
+
+#ifndef GZGUTS_H
+#define GZGUTS_H
+
+#define ZLIB_INTERNAL
+
+#include <errno.h>
+#include <limits.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "zio.h"
+#include "zlib.h"
+
+#define local static
+
+#define zstrerror() strerror(errno)
+
+#define GZBUFSIZE 8192
+
+#define GZ_NONE 0
+#define GZ_READ 7247
+#define GZ_WRITE 31153
+#define GZ_APPEND 1
+
+#define LOOK 0
+#define COPY 1
+#define GZIP 2
+
+typedef struct
+{ int mode;
+ int fd;
+ char *path;
+ z_off64_t pos;
+ unsigned size;
+ unsigned want;
+ unsigned char *in;
+ unsigned char *out;
+ unsigned char *next;
+ unsigned have;
+ int eof;
+ z_off64_t start;
+ z_off64_t raw;
+ int how;
+ int direct;
+ int level;
+ int strategy;
+ z_off64_t skip;
+ int seek;
+ int err;
+ char *msg;
+ z_stream strm;
+} gz_state;
+
+typedef gz_state *gz_statep;
+
+void ZLIB_INTERNAL gz_error OF((gz_statep, int, const char *));
+
+#define GT_OFF(x) (sizeof(int) == sizeof(z_off64_t) && (x) > INT_MAX)
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/zlib/gzlib.c b/test/monniaux/glpk-4.65/src/zlib/gzlib.c
new file mode 100644
index 00000000..603e60ed
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/gzlib.c
@@ -0,0 +1,537 @@
+/* gzlib.c -- zlib functions common to reading and writing gzip files
+ * Copyright (C) 2004, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0
+# define LSEEK lseek64
+#else
+# define LSEEK lseek
+#endif
+
+/* Local functions */
+local void gz_reset OF((gz_statep));
+local gzFile gz_open OF((const char *, int, const char *));
+
+#if defined UNDER_CE
+
+/* Map the Windows error number in ERROR to a locale-dependent error message
+ string and return a pointer to it. Typically, the values for ERROR come
+ from GetLastError.
+
+ The string pointed to shall not be modified by the application, but may be
+ overwritten by a subsequent call to gz_strwinerror
+
+ The gz_strwinerror function does not change the current setting of
+ GetLastError. */
+char ZLIB_INTERNAL *gz_strwinerror (error)
+ DWORD error;
+{
+ static char buf[1024];
+
+ wchar_t *msgbuf;
+ DWORD lasterr = GetLastError();
+ DWORD chars = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL,
+ error,
+ 0, /* Default language */
+ (LPVOID)&msgbuf,
+ 0,
+ NULL);
+ if (chars != 0) {
+ /* If there is an \r\n appended, zap it. */
+ if (chars >= 2
+ && msgbuf[chars - 2] == '\r' && msgbuf[chars - 1] == '\n') {
+ chars -= 2;
+ msgbuf[chars] = 0;
+ }
+
+ if (chars > sizeof (buf) - 1) {
+ chars = sizeof (buf) - 1;
+ msgbuf[chars] = 0;
+ }
+
+ wcstombs(buf, msgbuf, chars + 1);
+ LocalFree(msgbuf);
+ }
+ else {
+ sprintf(buf, "unknown win32 error (%ld)", error);
+ }
+
+ SetLastError(lasterr);
+ return buf;
+}
+
+#endif /* UNDER_CE */
+
+/* Reset gzip file state */
+local void gz_reset(state)
+ gz_statep state;
+{
+ if (state->mode == GZ_READ) { /* for reading ... */
+ state->have = 0; /* no output data available */
+ state->eof = 0; /* not at end of file */
+ state->how = LOOK; /* look for gzip header */
+ state->direct = 1; /* default for empty file */
+ }
+ state->seek = 0; /* no seek request pending */
+ gz_error(state, Z_OK, NULL); /* clear error */
+ state->pos = 0; /* no uncompressed data yet */
+ state->strm.avail_in = 0; /* no input data yet */
+}
+
+/* Open a gzip file either by name or file descriptor. */
+local gzFile gz_open(path, fd, mode)
+ const char *path;
+ int fd;
+ const char *mode;
+{
+ gz_statep state;
+
+ /* allocate gzFile structure to return */
+ state = malloc(sizeof(gz_state));
+ if (state == NULL)
+ return NULL;
+ state->size = 0; /* no buffers allocated yet */
+ state->want = GZBUFSIZE; /* requested buffer size */
+ state->msg = NULL; /* no error message yet */
+
+ /* interpret mode */
+ state->mode = GZ_NONE;
+ state->level = Z_DEFAULT_COMPRESSION;
+ state->strategy = Z_DEFAULT_STRATEGY;
+ while (*mode) {
+ if (*mode >= '0' && *mode <= '9')
+ state->level = *mode - '0';
+ else
+ switch (*mode) {
+ case 'r':
+ state->mode = GZ_READ;
+ break;
+#ifndef NO_GZCOMPRESS
+ case 'w':
+ state->mode = GZ_WRITE;
+ break;
+ case 'a':
+ state->mode = GZ_APPEND;
+ break;
+#endif
+ case '+': /* can't read and write at the same time */
+ free(state);
+ return NULL;
+ case 'b': /* ignore -- will request binary anyway */
+ break;
+ case 'f':
+ state->strategy = Z_FILTERED;
+ break;
+ case 'h':
+ state->strategy = Z_HUFFMAN_ONLY;
+ break;
+ case 'R':
+ state->strategy = Z_RLE;
+ break;
+ case 'F':
+ state->strategy = Z_FIXED;
+ default: /* could consider as an error, but just ignore */
+ ;
+ }
+ mode++;
+ }
+
+ /* must provide an "r", "w", or "a" */
+ if (state->mode == GZ_NONE) {
+ free(state);
+ return NULL;
+ }
+
+ /* save the path name for error messages */
+ state->path = malloc(strlen(path) + 1);
+ if (state->path == NULL) {
+ free(state);
+ return NULL;
+ }
+ strcpy(state->path, path);
+
+ /* open the file with the appropriate mode (or just use fd) */
+ state->fd = fd != -1 ? fd :
+ open(path,
+#ifdef O_LARGEFILE
+ O_LARGEFILE |
+#endif
+#ifdef O_BINARY
+ O_BINARY |
+#endif
+ (state->mode == GZ_READ ?
+ O_RDONLY :
+ (O_WRONLY | O_CREAT | (
+ state->mode == GZ_WRITE ?
+ O_TRUNC :
+ O_APPEND))),
+ 0666);
+ if (state->fd == -1) {
+ free(state->path);
+ free(state);
+ return NULL;
+ }
+ if (state->mode == GZ_APPEND)
+ state->mode = GZ_WRITE; /* simplify later checks */
+
+ /* save the current position for rewinding (only if reading) */
+ if (state->mode == GZ_READ) {
+ state->start = LSEEK(state->fd, 0, SEEK_CUR);
+ if (state->start == -1) state->start = 0;
+ }
+
+ /* initialize stream */
+ gz_reset(state);
+
+ /* return stream */
+ return (gzFile)state;
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzopen(path, mode)
+ const char *path;
+ const char *mode;
+{
+ return gz_open(path, -1, mode);
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzopen64(path, mode)
+ const char *path;
+ const char *mode;
+{
+ return gz_open(path, -1, mode);
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzdopen(fd, mode)
+ int fd;
+ const char *mode;
+{
+ char *path; /* identifier for error messages */
+ gzFile gz;
+
+ if (fd == -1 || (path = malloc(7 + 3 * sizeof(int))) == NULL)
+ return NULL;
+ sprintf(path, "<fd:%d>", fd); /* for debugging */
+ gz = gz_open(path, fd, mode);
+ free(path);
+ return gz;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzbuffer(file, size)
+ gzFile file;
+ unsigned size;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* make sure we haven't already allocated memory */
+ if (state->size != 0)
+ return -1;
+
+ /* check and set requested size */
+ if (size == 0)
+ return -1;
+ state->want = size;
+ return 0;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzrewind(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ || state->err != Z_OK)
+ return -1;
+
+ /* back up and start over */
+ if (LSEEK(state->fd, state->start, SEEK_SET) == -1)
+ return -1;
+ gz_reset(state);
+ return 0;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gzseek64(file, offset, whence)
+ gzFile file;
+ z_off64_t offset;
+ int whence;
+{
+ unsigned n;
+ z_off64_t ret;
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* check that there's no error */
+ if (state->err != Z_OK)
+ return -1;
+
+ /* can only seek from start or relative to current position */
+ if (whence != SEEK_SET && whence != SEEK_CUR)
+ return -1;
+
+ /* normalize offset to a SEEK_CUR specification */
+ if (whence == SEEK_SET)
+ offset -= state->pos;
+ else if (state->seek)
+ offset += state->skip;
+ state->seek = 0;
+
+ /* if within raw area while reading, just go there */
+ if (state->mode == GZ_READ && state->how == COPY &&
+ state->pos + offset >= state->raw) {
+ ret = LSEEK(state->fd, offset - state->have, SEEK_CUR);
+ if (ret == -1)
+ return -1;
+ state->have = 0;
+ state->eof = 0;
+ state->seek = 0;
+ gz_error(state, Z_OK, NULL);
+ state->strm.avail_in = 0;
+ state->pos += offset;
+ return state->pos;
+ }
+
+ /* calculate skip amount, rewinding if needed for back seek when reading */
+ if (offset < 0) {
+ if (state->mode != GZ_READ) /* writing -- can't go backwards */
+ return -1;
+ offset += state->pos;
+ if (offset < 0) /* before start of file! */
+ return -1;
+ if (gzrewind(file) == -1) /* rewind, then skip to offset */
+ return -1;
+ }
+
+ /* if reading, skip what's in output buffer (one less gzgetc() check) */
+ if (state->mode == GZ_READ) {
+ n = GT_OFF(state->have) || (z_off64_t)state->have > offset ?
+ (unsigned)offset : state->have;
+ state->have -= n;
+ state->next += n;
+ state->pos += n;
+ offset -= n;
+ }
+
+ /* request skip (if not zero) */
+ if (offset) {
+ state->seek = 1;
+ state->skip = offset;
+ }
+ return state->pos + offset;
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gzseek(file, offset, whence)
+ gzFile file;
+ z_off_t offset;
+ int whence;
+{
+ z_off64_t ret;
+
+ ret = gzseek64(file, (z_off64_t)offset, whence);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gztell64(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* return position */
+ return state->pos + (state->seek ? state->skip : 0);
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gztell(file)
+ gzFile file;
+{
+ z_off64_t ret;
+
+ ret = gztell64(file);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gzoffset64(file)
+ gzFile file;
+{
+ z_off64_t offset;
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* compute and return effective offset in file */
+ offset = LSEEK(state->fd, 0, SEEK_CUR);
+ if (offset == -1)
+ return -1;
+ if (state->mode == GZ_READ) /* reading */
+ offset -= state->strm.avail_in; /* don't count buffered input */
+ return offset;
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gzoffset(file)
+ gzFile file;
+{
+ z_off64_t ret;
+
+ ret = gzoffset64(file);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzeof(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return 0;
+
+ /* return end-of-file state */
+ return state->mode == GZ_READ ?
+ (state->eof && state->strm.avail_in == 0 && state->have == 0) : 0;
+}
+
+/* -- see zlib.h -- */
+const char * ZEXPORT gzerror(file, errnum)
+ gzFile file;
+ int *errnum;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return NULL;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return NULL;
+
+ /* return error information */
+ if (errnum != NULL)
+ *errnum = state->err;
+ return state->msg == NULL ? "" : state->msg;
+}
+
+/* -- see zlib.h -- */
+void ZEXPORT gzclearerr(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return;
+
+ /* clear error and end-of-file */
+ if (state->mode == GZ_READ)
+ state->eof = 0;
+ gz_error(state, Z_OK, NULL);
+}
+
+/* Create an error message in allocated memory and set state->err and
+ state->msg accordingly. Free any previous error message already there. Do
+ not try to free or allocate space if the error is Z_MEM_ERROR (out of
+ memory). Simply save the error message as a static string. If there is an
+ allocation failure constructing the error message, then convert the error to
+ out of memory. */
+void ZLIB_INTERNAL gz_error(state, err, msg)
+ gz_statep state;
+ int err;
+ const char *msg;
+{
+ /* free previously allocated message and clear */
+ if (state->msg != NULL) {
+ if (state->err != Z_MEM_ERROR)
+ free(state->msg);
+ state->msg = NULL;
+ }
+
+ /* set error code, and if no message, then done */
+ state->err = err;
+ if (msg == NULL)
+ return;
+
+ /* for an out of memory error, save as static string */
+ if (err == Z_MEM_ERROR) {
+ state->msg = (char *)msg;
+ return;
+ }
+
+ /* construct error message with path */
+ if ((state->msg = malloc(strlen(state->path) + strlen(msg) + 3)) == NULL) {
+ state->err = Z_MEM_ERROR;
+ state->msg = (char *)"out of memory";
+ return;
+ }
+ strcpy(state->msg, state->path);
+ strcat(state->msg, ": ");
+ strcat(state->msg, msg);
+ return;
+}
+
+#ifndef INT_MAX
+/* portably return maximum value for an int (when limits.h presumed not
+ available) -- we need to do this to cover cases where 2's complement not
+ used, since C standard permits 1's complement and sign-bit representations,
+ otherwise we could just use ((unsigned)-1) >> 1 */
+unsigned ZLIB_INTERNAL gz_intmax()
+{
+ unsigned p, q;
+
+ p = 1;
+ do {
+ q = p;
+ p <<= 1;
+ p++;
+ } while (p > q);
+ return q >> 1;
+}
+#endif
diff --git a/test/monniaux/glpk-4.65/src/zlib/gzread.c b/test/monniaux/glpk-4.65/src/zlib/gzread.c
new file mode 100644
index 00000000..548201ab
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/gzread.c
@@ -0,0 +1,653 @@
+/* gzread.c -- zlib functions for reading gzip files
+ * Copyright (C) 2004, 2005, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* Local functions */
+local int gz_load OF((gz_statep, unsigned char *, unsigned, unsigned *));
+local int gz_avail OF((gz_statep));
+local int gz_next4 OF((gz_statep, unsigned long *));
+local int gz_head OF((gz_statep));
+local int gz_decomp OF((gz_statep));
+local int gz_make OF((gz_statep));
+local int gz_skip OF((gz_statep, z_off64_t));
+
+/* Use read() to load a buffer -- return -1 on error, otherwise 0. Read from
+ state->fd, and update state->eof, state->err, and state->msg as appropriate.
+ This function needs to loop on read(), since read() is not guaranteed to
+ read the number of bytes requested, depending on the type of descriptor. */
+local int gz_load(state, buf, len, have)
+ gz_statep state;
+ unsigned char *buf;
+ unsigned len;
+ unsigned *have;
+{
+ int ret;
+
+ *have = 0;
+ do {
+ ret = read(state->fd, buf + *have, len - *have);
+ if (ret <= 0)
+ break;
+ *have += ret;
+ } while (*have < len);
+ if (ret < 0) {
+ gz_error(state, Z_ERRNO, zstrerror());
+ return -1;
+ }
+ if (ret == 0)
+ state->eof = 1;
+ return 0;
+}
+
+/* Load up input buffer and set eof flag if last data loaded -- return -1 on
+ error, 0 otherwise. Note that the eof flag is set when the end of the input
+ file is reached, even though there may be unused data in the buffer. Once
+ that data has been used, no more attempts will be made to read the file.
+ gz_avail() assumes that strm->avail_in == 0. */
+local int gz_avail(state)
+ gz_statep state;
+{
+ z_streamp strm = &(state->strm);
+
+ if (state->err != Z_OK)
+ return -1;
+ if (state->eof == 0) {
+ if (gz_load(state, state->in, state->size,
+ (unsigned *)&(strm->avail_in)) == -1)
+ return -1;
+ strm->next_in = state->in;
+ }
+ return 0;
+}
+
+/* Get next byte from input, or -1 if end or error. */
+#define NEXT() ((strm->avail_in == 0 && gz_avail(state) == -1) ? -1 : \
+ (strm->avail_in == 0 ? -1 : \
+ (strm->avail_in--, *(strm->next_in)++)))
+
+/* Get a four-byte little-endian integer and return 0 on success and the value
+ in *ret. Otherwise -1 is returned and *ret is not modified. */
+local int gz_next4(state, ret)
+ gz_statep state;
+ unsigned long *ret;
+{
+ int ch;
+ unsigned long val;
+ z_streamp strm = &(state->strm);
+
+ val = NEXT();
+ val += (unsigned)NEXT() << 8;
+ val += (unsigned long)NEXT() << 16;
+ ch = NEXT();
+ if (ch == -1)
+ return -1;
+ val += (unsigned long)ch << 24;
+ *ret = val;
+ return 0;
+}
+
+/* Look for gzip header, set up for inflate or copy. state->have must be zero.
+ If this is the first time in, allocate required memory. state->how will be
+ left unchanged if there is no more input data available, will be set to COPY
+ if there is no gzip header and direct copying will be performed, or it will
+ be set to GZIP for decompression, and the gzip header will be skipped so
+ that the next available input data is the raw deflate stream. If direct
+ copying, then leftover input data from the input buffer will be copied to
+ the output buffer. In that case, all further file reads will be directly to
+ either the output buffer or a user buffer. If decompressing, the inflate
+ state and the check value will be initialized. gz_head() will return 0 on
+ success or -1 on failure. Failures may include read errors or gzip header
+ errors. */
+local int gz_head(state)
+ gz_statep state;
+{
+ z_streamp strm = &(state->strm);
+ int flags;
+ unsigned len;
+
+ /* allocate read buffers and inflate memory */
+ if (state->size == 0) {
+ /* allocate buffers */
+ state->in = malloc(state->want);
+ state->out = malloc(state->want << 1);
+ if (state->in == NULL || state->out == NULL) {
+ if (state->out != NULL)
+ free(state->out);
+ if (state->in != NULL)
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ state->size = state->want;
+
+ /* allocate inflate memory */
+ state->strm.zalloc = Z_NULL;
+ state->strm.zfree = Z_NULL;
+ state->strm.opaque = Z_NULL;
+ state->strm.avail_in = 0;
+ state->strm.next_in = Z_NULL;
+ if (inflateInit2(&(state->strm), -15) != Z_OK) { /* raw inflate */
+ free(state->out);
+ free(state->in);
+ state->size = 0;
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ }
+
+ /* get some data in the input buffer */
+ if (strm->avail_in == 0) {
+ if (gz_avail(state) == -1)
+ return -1;
+ if (strm->avail_in == 0)
+ return 0;
+ }
+
+ /* look for the gzip magic header bytes 31 and 139 */
+ if (strm->next_in[0] == 31) {
+ strm->avail_in--;
+ strm->next_in++;
+ if (strm->avail_in == 0 && gz_avail(state) == -1)
+ return -1;
+ if (strm->avail_in && strm->next_in[0] == 139) {
+ /* we have a gzip header, woo hoo! */
+ strm->avail_in--;
+ strm->next_in++;
+
+ /* skip rest of header */
+ if (NEXT() != 8) { /* compression method */
+ gz_error(state, Z_DATA_ERROR, "unknown compression method");
+ return -1;
+ }
+ flags = NEXT();
+ if (flags & 0xe0) { /* reserved flag bits */
+ gz_error(state, Z_DATA_ERROR, "unknown header flags set");
+ return -1;
+ }
+ NEXT(); /* modification time */
+ NEXT();
+ NEXT();
+ NEXT();
+ NEXT(); /* extra flags */
+ NEXT(); /* operating system */
+ if (flags & 4) { /* extra field */
+ len = (unsigned)NEXT();
+ len += (unsigned)NEXT() << 8;
+ while (len--)
+ if (NEXT() < 0)
+ break;
+ }
+ if (flags & 8) /* file name */
+ while (NEXT() > 0)
+ ;
+ if (flags & 16) /* comment */
+ while (NEXT() > 0)
+ ;
+ if (flags & 2) { /* header crc */
+ NEXT();
+ NEXT();
+ }
+ /* an unexpected end of file is not checked for here -- it will be
+ noticed on the first request for uncompressed data */
+
+ /* set up for decompression */
+ inflateReset(strm);
+ strm->adler = crc32(0L, Z_NULL, 0);
+ state->how = GZIP;
+ state->direct = 0;
+ return 0;
+ }
+ else {
+ /* not a gzip file -- save first byte (31) and fall to raw i/o */
+ state->out[0] = 31;
+ state->have = 1;
+ }
+ }
+
+ /* doing raw i/o, save start of raw data for seeking, copy any leftover
+ input to output -- this assumes that the output buffer is larger than
+ the input buffer, which also assures space for gzungetc() */
+ state->raw = state->pos;
+ state->next = state->out;
+ if (strm->avail_in) {
+ memcpy(state->next + state->have, strm->next_in, strm->avail_in);
+ state->have += strm->avail_in;
+ strm->avail_in = 0;
+ }
+ state->how = COPY;
+ state->direct = 1;
+ return 0;
+}
+
+/* Decompress from input to the provided next_out and avail_out in the state.
+ If the end of the compressed data is reached, then verify the gzip trailer
+ check value and length (modulo 2^32). state->have and state->next are set
+ to point to the just decompressed data, and the crc is updated. If the
+ trailer is verified, state->how is reset to LOOK to look for the next gzip
+ stream or raw data, once state->have is depleted. Returns 0 on success, -1
+ on failure. Failures may include invalid compressed data or a failed gzip
+ trailer verification. */
+local int gz_decomp(state)
+ gz_statep state;
+{
+ int ret;
+ unsigned had;
+ unsigned long crc, len;
+ z_streamp strm = &(state->strm);
+
+ /* fill output buffer up to end of deflate stream */
+ had = strm->avail_out;
+ do {
+ /* get more input for inflate() */
+ if (strm->avail_in == 0 && gz_avail(state) == -1)
+ return -1;
+ if (strm->avail_in == 0) {
+ gz_error(state, Z_DATA_ERROR, "unexpected end of file");
+ return -1;
+ }
+
+ /* decompress and handle errors */
+ ret = inflate(strm, Z_NO_FLUSH);
+ if (ret == Z_STREAM_ERROR || ret == Z_NEED_DICT) {
+ gz_error(state, Z_STREAM_ERROR,
+ "internal error: inflate stream corrupt");
+ return -1;
+ }
+ if (ret == Z_MEM_ERROR) {
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ if (ret == Z_DATA_ERROR) { /* deflate stream invalid */
+ gz_error(state, Z_DATA_ERROR,
+ strm->msg == NULL ? "compressed data error" : strm->msg);
+ return -1;
+ }
+ } while (strm->avail_out && ret != Z_STREAM_END);
+
+ /* update available output and crc check value */
+ state->have = had - strm->avail_out;
+ state->next = strm->next_out - state->have;
+ strm->adler = crc32(strm->adler, state->next, state->have);
+
+ /* check gzip trailer if at end of deflate stream */
+ if (ret == Z_STREAM_END) {
+ if (gz_next4(state, &crc) == -1 || gz_next4(state, &len) == -1) {
+ gz_error(state, Z_DATA_ERROR, "unexpected end of file");
+ return -1;
+ }
+ if (crc != strm->adler) {
+ gz_error(state, Z_DATA_ERROR, "incorrect data check");
+ return -1;
+ }
+ if (len != (strm->total_out & 0xffffffffL)) {
+ gz_error(state, Z_DATA_ERROR, "incorrect length check");
+ return -1;
+ }
+ state->how = LOOK; /* ready for next stream, once have is 0 (leave
+ state->direct unchanged to remember how) */
+ }
+
+ /* good decompression */
+ return 0;
+}
+
+/* Make data and put in the output buffer. Assumes that state->have == 0.
+ Data is either copied from the input file or decompressed from the input
+ file depending on state->how. If state->how is LOOK, then a gzip header is
+ looked for (and skipped if found) to determine wither to copy or decompress.
+ Returns -1 on error, otherwise 0. gz_make() will leave state->have as COPY
+ or GZIP unless the end of the input file has been reached and all data has
+ been processed. */
+local int gz_make(state)
+ gz_statep state;
+{
+ z_streamp strm = &(state->strm);
+
+ if (state->how == LOOK) { /* look for gzip header */
+ if (gz_head(state) == -1)
+ return -1;
+ if (state->have) /* got some data from gz_head() */
+ return 0;
+ }
+ if (state->how == COPY) { /* straight copy */
+ if (gz_load(state, state->out, state->size << 1, &(state->have)) == -1)
+ return -1;
+ state->next = state->out;
+ }
+ else if (state->how == GZIP) { /* decompress */
+ strm->avail_out = state->size << 1;
+ strm->next_out = state->out;
+ if (gz_decomp(state) == -1)
+ return -1;
+ }
+ return 0;
+}
+
+/* Skip len uncompressed bytes of output. Return -1 on error, 0 on success. */
+local int gz_skip(state, len)
+ gz_statep state;
+ z_off64_t len;
+{
+ unsigned n;
+
+ /* skip over len bytes or reach end-of-file, whichever comes first */
+ while (len)
+ /* skip over whatever is in output buffer */
+ if (state->have) {
+ n = GT_OFF(state->have) || (z_off64_t)state->have > len ?
+ (unsigned)len : state->have;
+ state->have -= n;
+ state->next += n;
+ state->pos += n;
+ len -= n;
+ }
+
+ /* output buffer empty -- return if we're at the end of the input */
+ else if (state->eof && state->strm.avail_in == 0)
+ break;
+
+ /* need more data to skip -- load up output buffer */
+ else {
+ /* get more output, looking for header if required */
+ if (gz_make(state) == -1)
+ return -1;
+ }
+ return 0;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzread(file, buf, len)
+ gzFile file;
+ voidp buf;
+ unsigned len;
+{
+ unsigned got, n;
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ || state->err != Z_OK)
+ return -1;
+
+ /* since an int is returned, make sure len fits in one, otherwise return
+ with an error (this avoids the flaw in the interface) */
+ if ((int)len < 0) {
+ gz_error(state, Z_BUF_ERROR, "requested length does not fit in int");
+ return -1;
+ }
+
+ /* if len is zero, avoid unnecessary operations */
+ if (len == 0)
+ return 0;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* get len bytes to buf, or less than len if at the end */
+ got = 0;
+ do {
+ /* first just try copying data from the output buffer */
+ if (state->have) {
+ n = state->have > len ? len : state->have;
+ memcpy(buf, state->next, n);
+ state->next += n;
+ state->have -= n;
+ }
+
+ /* output buffer empty -- return if we're at the end of the input */
+ else if (state->eof && strm->avail_in == 0)
+ break;
+
+ /* need output data -- for small len or new stream load up our output
+ buffer */
+ else if (state->how == LOOK || len < (state->size << 1)) {
+ /* get more output, looking for header if required */
+ if (gz_make(state) == -1)
+ return -1;
+ continue; /* no progress yet -- go back to memcpy() above */
+ /* the copy above assures that we will leave with space in the
+ output buffer, allowing at least one gzungetc() to succeed */
+ }
+
+ /* large len -- read directly into user buffer */
+ else if (state->how == COPY) { /* read directly */
+ if (gz_load(state, buf, len, &n) == -1)
+ return -1;
+ }
+
+ /* large len -- decompress directly into user buffer */
+ else { /* state->how == GZIP */
+ strm->avail_out = len;
+ strm->next_out = buf;
+ if (gz_decomp(state) == -1)
+ return -1;
+ n = state->have;
+ state->have = 0;
+ }
+
+ /* update progress */
+ len -= n;
+ buf = (char *)buf + n;
+ got += n;
+ state->pos += n;
+ } while (len);
+
+ /* return number of bytes read into user buffer (will fit in int) */
+ return (int)got;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzgetc(file)
+ gzFile file;
+{
+ int ret;
+ unsigned char buf[1];
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ || state->err != Z_OK)
+ return -1;
+
+ /* try output buffer (no need to check for skip request) */
+ if (state->have) {
+ state->have--;
+ state->pos++;
+ return *(state->next)++;
+ }
+
+ /* nothing there -- try gzread() */
+ ret = gzread(file, buf, 1);
+ return ret < 1 ? -1 : buf[0];
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzungetc(c, file)
+ int c;
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ || state->err != Z_OK)
+ return -1;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* can't push EOF */
+ if (c < 0)
+ return -1;
+
+ /* if output buffer empty, put byte at end (allows more pushing) */
+ if (state->have == 0) {
+ state->have = 1;
+ state->next = state->out + (state->size << 1) - 1;
+ state->next[0] = c;
+ state->pos--;
+ return c;
+ }
+
+ /* if no room, give up (must have already done a gzungetc()) */
+ if (state->have == (state->size << 1)) {
+ gz_error(state, Z_BUF_ERROR, "out of room to push characters");
+ return -1;
+ }
+
+ /* slide output data if needed and insert byte before existing data */
+ if (state->next == state->out) {
+ unsigned char *src = state->out + state->have;
+ unsigned char *dest = state->out + (state->size << 1);
+ while (src > state->out)
+ *--dest = *--src;
+ state->next = dest;
+ }
+ state->have++;
+ state->next--;
+ state->next[0] = c;
+ state->pos--;
+ return c;
+}
+
+/* -- see zlib.h -- */
+char * ZEXPORT gzgets(file, buf, len)
+ gzFile file;
+ char *buf;
+ int len;
+{
+ unsigned left, n;
+ char *str;
+ unsigned char *eol;
+ gz_statep state;
+
+ /* check parameters and get internal structure */
+ if (file == NULL || buf == NULL || len < 1)
+ return NULL;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ || state->err != Z_OK)
+ return NULL;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return NULL;
+ }
+
+ /* copy output bytes up to new line or len - 1, whichever comes first --
+ append a terminating zero to the string (we don't check for a zero in
+ the contents, let the user worry about that) */
+ str = buf;
+ left = (unsigned)len - 1;
+ if (left) do {
+ /* assure that something is in the output buffer */
+ if (state->have == 0) {
+ if (gz_make(state) == -1)
+ return NULL; /* error */
+ if (state->have == 0) { /* end of file */
+ if (buf == str) /* got bupkus */
+ return NULL;
+ break; /* got something -- return it */
+ }
+ }
+
+ /* look for end-of-line in current output buffer */
+ n = state->have > left ? left : state->have;
+ eol = memchr(state->next, '\n', n);
+ if (eol != NULL)
+ n = (unsigned)(eol - state->next) + 1;
+
+ /* copy through end-of-line, or remainder if not found */
+ memcpy(buf, state->next, n);
+ state->have -= n;
+ state->next += n;
+ state->pos += n;
+ left -= n;
+ buf += n;
+ } while (left && eol == NULL);
+
+ /* found end-of-line or out of space -- terminate string and return it */
+ buf[0] = 0;
+ return str;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzdirect(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+
+ /* check that we're reading */
+ if (state->mode != GZ_READ)
+ return 0;
+
+ /* if the state is not known, but we can find out, then do so (this is
+ mainly for right after a gzopen() or gzdopen()) */
+ if (state->how == LOOK && state->have == 0)
+ (void)gz_head(state);
+
+ /* return 1 if reading direct, 0 if decompressing a gzip stream */
+ return state->direct;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzclose_r(file)
+ gzFile file;
+{
+ int ret;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ /* check that we're reading */
+ if (state->mode != GZ_READ)
+ return Z_STREAM_ERROR;
+
+ /* free memory and close file */
+ if (state->size) {
+ inflateEnd(&(state->strm));
+ free(state->out);
+ free(state->in);
+ }
+ gz_error(state, Z_OK, NULL);
+ free(state->path);
+ ret = close(state->fd);
+ free(state);
+ return ret ? Z_ERRNO : Z_OK;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/gzwrite.c b/test/monniaux/glpk-4.65/src/zlib/gzwrite.c
new file mode 100644
index 00000000..13c5558e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/gzwrite.c
@@ -0,0 +1,531 @@
+/* gzwrite.c -- zlib functions for writing gzip files
+ * Copyright (C) 2004, 2005, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* Local functions */
+local int gz_init OF((gz_statep));
+local int gz_comp OF((gz_statep, int));
+local int gz_zero OF((gz_statep, z_off64_t));
+
+/* Initialize state for writing a gzip file. Mark initialization by setting
+ state->size to non-zero. Return -1 on failure or 0 on success. */
+local int gz_init(state)
+ gz_statep state;
+{
+ int ret;
+ z_streamp strm = &(state->strm);
+
+ /* allocate input and output buffers */
+ state->in = malloc(state->want);
+ state->out = malloc(state->want);
+ if (state->in == NULL || state->out == NULL) {
+ if (state->out != NULL)
+ free(state->out);
+ if (state->in != NULL)
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+
+ /* allocate deflate memory, set up for gzip compression */
+ strm->zalloc = Z_NULL;
+ strm->zfree = Z_NULL;
+ strm->opaque = Z_NULL;
+ ret = deflateInit2(strm, state->level, Z_DEFLATED,
+ 15 + 16, 8, state->strategy);
+ if (ret != Z_OK) {
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+
+ /* mark state as initialized */
+ state->size = state->want;
+
+ /* initialize write buffer */
+ strm->avail_out = state->size;
+ strm->next_out = state->out;
+ state->next = strm->next_out;
+ return 0;
+}
+
+/* Compress whatever is at avail_in and next_in and write to the output file.
+ Return -1 if there is an error writing to the output file, otherwise 0.
+ flush is assumed to be a valid deflate() flush value. If flush is Z_FINISH,
+ then the deflate() state is reset to start a new gzip stream. */
+local int gz_comp(state, flush)
+ gz_statep state;
+ int flush;
+{
+ int ret, got;
+ unsigned have;
+ z_streamp strm = &(state->strm);
+
+ /* allocate memory if this is the first time through */
+ if (state->size == 0 && gz_init(state) == -1)
+ return -1;
+
+ /* run deflate() on provided input until it produces no more output */
+ ret = Z_OK;
+ do {
+ /* write out current buffer contents if full, or if flushing, but if
+ doing Z_FINISH then don't write until we get to Z_STREAM_END */
+ if (strm->avail_out == 0 || (flush != Z_NO_FLUSH &&
+ (flush != Z_FINISH || ret == Z_STREAM_END))) {
+ have = (unsigned)(strm->next_out - state->next);
+ if (have && ((got = write(state->fd, state->next, have)) < 0 ||
+ (unsigned)got != have)) {
+ gz_error(state, Z_ERRNO, zstrerror());
+ return -1;
+ }
+ if (strm->avail_out == 0) {
+ strm->avail_out = state->size;
+ strm->next_out = state->out;
+ }
+ state->next = strm->next_out;
+ }
+
+ /* compress */
+ have = strm->avail_out;
+ ret = deflate(strm, flush);
+ if (ret == Z_STREAM_ERROR) {
+ gz_error(state, Z_STREAM_ERROR,
+ "internal error: deflate stream corrupt");
+ return -1;
+ }
+ have -= strm->avail_out;
+ } while (have);
+
+ /* if that completed a deflate stream, allow another to start */
+ if (flush == Z_FINISH)
+ deflateReset(strm);
+
+ /* all done, no errors */
+ return 0;
+}
+
+/* Compress len zeros to output. Return -1 on error, 0 on success. */
+local int gz_zero(state, len)
+ gz_statep state;
+ z_off64_t len;
+{
+ int first;
+ unsigned n;
+ z_streamp strm = &(state->strm);
+
+ /* consume whatever's left in the input buffer */
+ if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return -1;
+
+ /* compress len zeros (len guaranteed > 0) */
+ first = 1;
+ while (len) {
+ n = GT_OFF(state->size) || (z_off64_t)state->size > len ?
+ (unsigned)len : state->size;
+ if (first) {
+ memset(state->in, 0, n);
+ first = 0;
+ }
+ strm->avail_in = n;
+ strm->next_in = state->in;
+ state->pos += n;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return -1;
+ len -= n;
+ }
+ return 0;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzwrite(file, buf, len)
+ gzFile file;
+ voidpc buf;
+ unsigned len;
+{
+ unsigned put = len;
+ unsigned n;
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return 0;
+
+ /* since an int is returned, make sure len fits in one, otherwise return
+ with an error (this avoids the flaw in the interface) */
+ if ((int)len < 0) {
+ gz_error(state, Z_BUF_ERROR, "requested length does not fit in int");
+ return 0;
+ }
+
+ /* if len is zero, avoid unnecessary operations */
+ if (len == 0)
+ return 0;
+
+ /* allocate memory if this is the first time through */
+ if (state->size == 0 && gz_init(state) == -1)
+ return 0;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return 0;
+ }
+
+ /* for small len, copy to input buffer, otherwise compress directly */
+ if (len < state->size) {
+ /* copy to input buffer, compress when full */
+ do {
+ if (strm->avail_in == 0)
+ strm->next_in = state->in;
+ n = state->size - strm->avail_in;
+ if (n > len)
+ n = len;
+ memcpy(strm->next_in + strm->avail_in, buf, n);
+ strm->avail_in += n;
+ state->pos += n;
+ buf = (char *)buf + n;
+ len -= n;
+ if (len && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+ } while (len);
+ }
+ else {
+ /* consume whatever's left in the input buffer */
+ if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+
+ /* directly compress user buffer to file */
+ strm->avail_in = len;
+ strm->next_in = (voidp)buf;
+ state->pos += len;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+ }
+
+ /* input was all buffered or compressed (put will fit in int) */
+ return (int)put;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzputc(file, c)
+ gzFile file;
+ int c;
+{
+ unsigned char buf[1];
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return -1;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* try writing to input buffer for speed (state->size == 0 if buffer not
+ initialized) */
+ if (strm->avail_in < state->size) {
+ if (strm->avail_in == 0)
+ strm->next_in = state->in;
+ strm->next_in[strm->avail_in++] = c;
+ state->pos++;
+ return c;
+ }
+
+ /* no room in buffer or not initialized, use gz_write() */
+ buf[0] = c;
+ if (gzwrite(file, buf, 1) != 1)
+ return -1;
+ return c;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzputs(file, str)
+ gzFile file;
+ const char *str;
+{
+ int ret;
+ unsigned len;
+
+ /* write string */
+ len = (unsigned)strlen(str);
+ ret = gzwrite(file, str, len);
+ return ret == 0 && len != 0 ? -1 : ret;
+}
+
+#ifdef STDC
+#include <stdarg.h>
+
+/* -- see zlib.h -- */
+int ZEXPORTVA gzprintf (gzFile file, const char *format, ...)
+{
+ int size, len;
+ gz_statep state;
+ z_streamp strm;
+ va_list va;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return 0;
+
+ /* make sure we have some buffer space */
+ if (state->size == 0 && gz_init(state) == -1)
+ return 0;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return 0;
+ }
+
+ /* consume whatever's left in the input buffer */
+ if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+
+ /* do the printf() into the input buffer, put length in len */
+ size = (int)(state->size);
+ state->in[size - 1] = 0;
+ va_start(va, format);
+#ifdef NO_vsnprintf
+# ifdef HAS_vsprintf_void
+ (void)vsprintf(state->in, format, va);
+ va_end(va);
+ for (len = 0; len < size; len++)
+ if (state->in[len] == 0) break;
+# else
+ len = vsprintf((char *)state->in, format, va);
+ va_end(va);
+# endif
+#else
+# ifdef HAS_vsnprintf_void
+ (void)vsnprintf(state->in, size, format, va);
+ va_end(va);
+ len = strlen(state->in);
+# else
+ len = vsnprintf((char *)(state->in), size, format, va);
+ va_end(va);
+# endif
+#endif
+
+ /* check that printf() results fit in buffer */
+ if (len <= 0 || len >= (int)size || state->in[size - 1] != 0)
+ return 0;
+
+ /* update buffer and position, defer compression until needed */
+ strm->avail_in = (unsigned)len;
+ strm->next_in = state->in;
+ state->pos += len;
+ return len;
+}
+
+#else /* !STDC */
+
+/* -- see zlib.h -- */
+int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+ a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)
+ gzFile file;
+ const char *format;
+ int a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+ a11, a12, a13, a14, a15, a16, a17, a18, a19, a20;
+{
+ int size, len;
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return 0;
+
+ /* make sure we have some buffer space */
+ if (state->size == 0 && gz_init(state) == -1)
+ return 0;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return 0;
+ }
+
+ /* consume whatever's left in the input buffer */
+ if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+
+ /* do the printf() into the input buffer, put length in len */
+ size = (int)(state->size);
+ state->in[size - 1] = 0;
+#ifdef NO_snprintf
+# ifdef HAS_sprintf_void
+ sprintf(state->in, format, a1, a2, a3, a4, a5, a6, a7, a8,
+ a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+ for (len = 0; len < size; len++)
+ if (state->in[len] == 0) break;
+# else
+ len = sprintf(state->in, format, a1, a2, a3, a4, a5, a6, a7, a8,
+ a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+# endif
+#else
+# ifdef HAS_snprintf_void
+ snprintf(state->in, size, format, a1, a2, a3, a4, a5, a6, a7, a8,
+ a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+ len = strlen(state->in);
+# else
+ len = snprintf(state->in, size, format, a1, a2, a3, a4, a5, a6, a7, a8,
+ a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+# endif
+#endif
+
+ /* check that printf() results fit in buffer */
+ if (len <= 0 || len >= (int)size || state->in[size - 1] != 0)
+ return 0;
+
+ /* update buffer and position, defer compression until needed */
+ strm->avail_in = (unsigned)len;
+ strm->next_in = state->in;
+ state->pos += len;
+ return len;
+}
+
+#endif
+
+/* -- see zlib.h -- */
+int ZEXPORT gzflush(file, flush)
+ gzFile file;
+ int flush;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* check flush parameter */
+ if (flush < 0 || flush > Z_FINISH)
+ return Z_STREAM_ERROR;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* compress remaining data with requested flush */
+ gz_comp(state, flush);
+ return state->err;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzsetparams(file, level, strategy)
+ gzFile file;
+ int level;
+ int strategy;
+{
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* if no change is requested, then do nothing */
+ if (level == state->level && strategy == state->strategy)
+ return Z_OK;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* change compression parameters for subsequent input */
+ if (state->size) {
+ /* flush previous input with previous parameters before changing */
+ if (strm->avail_in && gz_comp(state, Z_PARTIAL_FLUSH) == -1)
+ return state->err;
+ deflateParams(strm, level, strategy);
+ }
+ state->level = level;
+ state->strategy = strategy;
+ return Z_OK;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzclose_w(file)
+ gzFile file;
+{
+ int ret = 0;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ /* check that we're writing */
+ if (state->mode != GZ_WRITE)
+ return Z_STREAM_ERROR;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ ret += gz_zero(state, state->skip);
+ }
+
+ /* flush, free memory, and close file */
+ ret += gz_comp(state, Z_FINISH);
+ (void)deflateEnd(&(state->strm));
+ free(state->out);
+ free(state->in);
+ gz_error(state, Z_OK, NULL);
+ free(state->path);
+ ret += close(state->fd);
+ free(state);
+ return ret ? Z_ERRNO : Z_OK;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/inffast.c b/test/monniaux/glpk-4.65/src/zlib/inffast.c
new file mode 100644
index 00000000..2f1d60b4
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inffast.c
@@ -0,0 +1,340 @@
+/* inffast.c -- fast decoding
+ * Copyright (C) 1995-2008, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "inflate.h"
+#include "inffast.h"
+
+#ifndef ASMINF
+
+/* Allow machine dependent optimization for post-increment or pre-increment.
+ Based on testing to date,
+ Pre-increment preferred for:
+ - PowerPC G3 (Adler)
+ - MIPS R5000 (Randers-Pehrson)
+ Post-increment preferred for:
+ - none
+ No measurable difference:
+ - Pentium III (Anderson)
+ - M68060 (Nikl)
+ */
+#ifdef POSTINC
+# define OFF 0
+# define PUP(a) *(a)++
+#else
+# define OFF 1
+# define PUP(a) *++(a)
+#endif
+
+/*
+ Decode literal, length, and distance codes and write out the resulting
+ literal and match bytes until either not enough input or output is
+ available, an end-of-block is encountered, or a data error is encountered.
+ When large enough input and output buffers are supplied to inflate(), for
+ example, a 16K input buffer and a 64K output buffer, more than 95% of the
+ inflate execution time is spent in this routine.
+
+ Entry assumptions:
+
+ state->mode == LEN
+ strm->avail_in >= 6
+ strm->avail_out >= 258
+ start >= strm->avail_out
+ state->bits < 8
+
+ On return, state->mode is one of:
+
+ LEN -- ran out of enough output space or enough available input
+ TYPE -- reached end of block code, inflate() to interpret next block
+ BAD -- error in block data
+
+ Notes:
+
+ - The maximum input bits used by a length/distance pair is 15 bits for the
+ length code, 5 bits for the length extra, 15 bits for the distance code,
+ and 13 bits for the distance extra. This totals 48 bits, or six bytes.
+ Therefore if strm->avail_in >= 6, then there is enough input to avoid
+ checking for available input while decoding.
+
+ - The maximum bytes that a single length/distance pair can output is 258
+ bytes, which is the maximum length that can be coded. inflate_fast()
+ requires strm->avail_out >= 258 for each loop to avoid checking for
+ output space.
+ */
+void ZLIB_INTERNAL inflate_fast(strm, start)
+z_streamp strm;
+unsigned start; /* inflate()'s starting value for strm->avail_out */
+{
+ struct inflate_state FAR *state;
+ unsigned char FAR *in; /* local strm->next_in */
+ unsigned char FAR *last; /* while in < last, enough input available */
+ unsigned char FAR *out; /* local strm->next_out */
+ unsigned char FAR *beg; /* inflate()'s initial strm->next_out */
+ unsigned char FAR *end; /* while out < end, enough space available */
+#ifdef INFLATE_STRICT
+ unsigned dmax; /* maximum distance from zlib header */
+#endif
+ unsigned wsize; /* window size or zero if not using window */
+ unsigned whave; /* valid bytes in the window */
+ unsigned wnext; /* window write index */
+ unsigned char FAR *window; /* allocated sliding window, if wsize != 0 */
+ unsigned long hold; /* local strm->hold */
+ unsigned bits; /* local strm->bits */
+ code const FAR *lcode; /* local strm->lencode */
+ code const FAR *dcode; /* local strm->distcode */
+ unsigned lmask; /* mask for first level of length codes */
+ unsigned dmask; /* mask for first level of distance codes */
+ code here; /* retrieved table entry */
+ unsigned op; /* code bits, operation, extra bits, or */
+ /* window position, window bytes to copy */
+ unsigned len; /* match length, unused bytes */
+ unsigned dist; /* match distance */
+ unsigned char FAR *from; /* where to copy match from */
+
+ /* copy state to local variables */
+ state = (struct inflate_state FAR *)strm->state;
+ in = strm->next_in - OFF;
+ last = in + (strm->avail_in - 5);
+ out = strm->next_out - OFF;
+ beg = out - (start - strm->avail_out);
+ end = out + (strm->avail_out - 257);
+#ifdef INFLATE_STRICT
+ dmax = state->dmax;
+#endif
+ wsize = state->wsize;
+ whave = state->whave;
+ wnext = state->wnext;
+ window = state->window;
+ hold = state->hold;
+ bits = state->bits;
+ lcode = state->lencode;
+ dcode = state->distcode;
+ lmask = (1U << state->lenbits) - 1;
+ dmask = (1U << state->distbits) - 1;
+
+ /* decode literals and length/distances until end-of-block or not enough
+ input data or output space */
+ do {
+ if (bits < 15) {
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ }
+ here = lcode[hold & lmask];
+ dolen:
+ op = (unsigned)(here.bits);
+ hold >>= op;
+ bits -= op;
+ op = (unsigned)(here.op);
+ if (op == 0) { /* literal */
+ Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ?
+ "inflate: literal '%c'\n" :
+ "inflate: literal 0x%02x\n", here.val));
+ PUP(out) = (unsigned char)(here.val);
+ }
+ else if (op & 16) { /* length base */
+ len = (unsigned)(here.val);
+ op &= 15; /* number of extra bits */
+ if (op) {
+ if (bits < op) {
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ }
+ len += (unsigned)hold & ((1U << op) - 1);
+ hold >>= op;
+ bits -= op;
+ }
+ Tracevv((stderr, "inflate: length %u\n", len));
+ if (bits < 15) {
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ }
+ here = dcode[hold & dmask];
+ dodist:
+ op = (unsigned)(here.bits);
+ hold >>= op;
+ bits -= op;
+ op = (unsigned)(here.op);
+ if (op & 16) { /* distance base */
+ dist = (unsigned)(here.val);
+ op &= 15; /* number of extra bits */
+ if (bits < op) {
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ if (bits < op) {
+ hold += (unsigned long)(PUP(in)) << bits;
+ bits += 8;
+ }
+ }
+ dist += (unsigned)hold & ((1U << op) - 1);
+#ifdef INFLATE_STRICT
+ if (dist > dmax) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ hold >>= op;
+ bits -= op;
+ Tracevv((stderr, "inflate: distance %u\n", dist));
+ op = (unsigned)(out - beg); /* max distance in output */
+ if (dist > op) { /* see if copy from window */
+ op = dist - op; /* distance back in window */
+ if (op > whave) {
+ if (state->sane) {
+ strm->msg =
+ (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ if (len <= op - whave) {
+ do {
+ PUP(out) = 0;
+ } while (--len);
+ continue;
+ }
+ len -= op - whave;
+ do {
+ PUP(out) = 0;
+ } while (--op > whave);
+ if (op == 0) {
+ from = out - dist;
+ do {
+ PUP(out) = PUP(from);
+ } while (--len);
+ continue;
+ }
+#endif
+ }
+ from = window - OFF;
+ if (wnext == 0) { /* very common case */
+ from += wsize - op;
+ if (op < len) { /* some from window */
+ len -= op;
+ do {
+ PUP(out) = PUP(from);
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ else if (wnext < op) { /* wrap around window */
+ from += wsize + wnext - op;
+ op -= wnext;
+ if (op < len) { /* some from end of window */
+ len -= op;
+ do {
+ PUP(out) = PUP(from);
+ } while (--op);
+ from = window - OFF;
+ if (wnext < len) { /* some from start of window */
+ op = wnext;
+ len -= op;
+ do {
+ PUP(out) = PUP(from);
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ }
+ else { /* contiguous in window */
+ from += wnext - op;
+ if (op < len) { /* some from window */
+ len -= op;
+ do {
+ PUP(out) = PUP(from);
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ while (len > 2) {
+ PUP(out) = PUP(from);
+ PUP(out) = PUP(from);
+ PUP(out) = PUP(from);
+ len -= 3;
+ }
+ if (len) {
+ PUP(out) = PUP(from);
+ if (len > 1)
+ PUP(out) = PUP(from);
+ }
+ }
+ else {
+ from = out - dist; /* copy direct from output */
+ do { /* minimum length is three */
+ PUP(out) = PUP(from);
+ PUP(out) = PUP(from);
+ PUP(out) = PUP(from);
+ len -= 3;
+ } while (len > 2);
+ if (len) {
+ PUP(out) = PUP(from);
+ if (len > 1)
+ PUP(out) = PUP(from);
+ }
+ }
+ }
+ else if ((op & 64) == 0) { /* 2nd level distance code */
+ here = dcode[here.val + (hold & ((1U << op) - 1))];
+ goto dodist;
+ }
+ else {
+ strm->msg = (char *)"invalid distance code";
+ state->mode = BAD;
+ break;
+ }
+ }
+ else if ((op & 64) == 0) { /* 2nd level length code */
+ here = lcode[here.val + (hold & ((1U << op) - 1))];
+ goto dolen;
+ }
+ else if (op & 32) { /* end-of-block */
+ Tracevv((stderr, "inflate: end of block\n"));
+ state->mode = TYPE;
+ break;
+ }
+ else {
+ strm->msg = (char *)"invalid literal/length code";
+ state->mode = BAD;
+ break;
+ }
+ } while (in < last && out < end);
+
+ /* return unused bytes (on entry, bits < 8, so in won't go too far back) */
+ len = bits >> 3;
+ in -= len;
+ bits -= len << 3;
+ hold &= (1U << bits) - 1;
+
+ /* update state and return */
+ strm->next_in = in + OFF;
+ strm->next_out = out + OFF;
+ strm->avail_in = (unsigned)(in < last ? 5 + (last - in) : 5 - (in - last));
+ strm->avail_out = (unsigned)(out < end ?
+ 257 + (end - out) : 257 - (out - end));
+ state->hold = hold;
+ state->bits = bits;
+ return;
+}
+
+/*
+ inflate_fast() speedups that turned out slower (on a PowerPC G3 750CXe):
+ - Using bit fields for code structure
+ - Different op definition to avoid & for extra bits (do & for table bits)
+ - Three separate decoding do-loops for direct, window, and wnext == 0
+ - Special case for distance > 1 copies to do overlapped load and store copy
+ - Explicit branch predictions (based on measured branch probabilities)
+ - Deferring match copy and interspersed it with decoding subsequent codes
+ - Swapping literal/length else
+ - Swapping window/direct else
+ - Larger unrolled copy loops (three is about right)
+ - Moving len -= 3 statement into middle of loop
+ */
+
+#endif /* !ASMINF */
diff --git a/test/monniaux/glpk-4.65/src/zlib/inffast.h b/test/monniaux/glpk-4.65/src/zlib/inffast.h
new file mode 100644
index 00000000..e5c1aa4c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inffast.h
@@ -0,0 +1,11 @@
+/* inffast.h -- header to use inffast.c
+ * Copyright (C) 1995-2003, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+void ZLIB_INTERNAL inflate_fast OF((z_streamp strm, unsigned start));
diff --git a/test/monniaux/glpk-4.65/src/zlib/inffixed.h b/test/monniaux/glpk-4.65/src/zlib/inffixed.h
new file mode 100644
index 00000000..75ed4b59
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inffixed.h
@@ -0,0 +1,94 @@
+ /* inffixed.h -- table for decoding fixed codes
+ * Generated automatically by makefixed().
+ */
+
+ /* WARNING: this file should *not* be used by applications. It
+ is part of the implementation of the compression library and
+ is subject to change. Applications should only use zlib.h.
+ */
+
+ static const code lenfix[512] = {
+ {96,7,0},{0,8,80},{0,8,16},{20,8,115},{18,7,31},{0,8,112},{0,8,48},
+ {0,9,192},{16,7,10},{0,8,96},{0,8,32},{0,9,160},{0,8,0},{0,8,128},
+ {0,8,64},{0,9,224},{16,7,6},{0,8,88},{0,8,24},{0,9,144},{19,7,59},
+ {0,8,120},{0,8,56},{0,9,208},{17,7,17},{0,8,104},{0,8,40},{0,9,176},
+ {0,8,8},{0,8,136},{0,8,72},{0,9,240},{16,7,4},{0,8,84},{0,8,20},
+ {21,8,227},{19,7,43},{0,8,116},{0,8,52},{0,9,200},{17,7,13},{0,8,100},
+ {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232},{16,7,8},
+ {0,8,92},{0,8,28},{0,9,152},{20,7,83},{0,8,124},{0,8,60},{0,9,216},
+ {18,7,23},{0,8,108},{0,8,44},{0,9,184},{0,8,12},{0,8,140},{0,8,76},
+ {0,9,248},{16,7,3},{0,8,82},{0,8,18},{21,8,163},{19,7,35},{0,8,114},
+ {0,8,50},{0,9,196},{17,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2},
+ {0,8,130},{0,8,66},{0,9,228},{16,7,7},{0,8,90},{0,8,26},{0,9,148},
+ {20,7,67},{0,8,122},{0,8,58},{0,9,212},{18,7,19},{0,8,106},{0,8,42},
+ {0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244},{16,7,5},{0,8,86},
+ {0,8,22},{64,8,0},{19,7,51},{0,8,118},{0,8,54},{0,9,204},{17,7,15},
+ {0,8,102},{0,8,38},{0,9,172},{0,8,6},{0,8,134},{0,8,70},{0,9,236},
+ {16,7,9},{0,8,94},{0,8,30},{0,9,156},{20,7,99},{0,8,126},{0,8,62},
+ {0,9,220},{18,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142},
+ {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{21,8,131},{18,7,31},
+ {0,8,113},{0,8,49},{0,9,194},{16,7,10},{0,8,97},{0,8,33},{0,9,162},
+ {0,8,1},{0,8,129},{0,8,65},{0,9,226},{16,7,6},{0,8,89},{0,8,25},
+ {0,9,146},{19,7,59},{0,8,121},{0,8,57},{0,9,210},{17,7,17},{0,8,105},
+ {0,8,41},{0,9,178},{0,8,9},{0,8,137},{0,8,73},{0,9,242},{16,7,4},
+ {0,8,85},{0,8,21},{16,8,258},{19,7,43},{0,8,117},{0,8,53},{0,9,202},
+ {17,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133},{0,8,69},
+ {0,9,234},{16,7,8},{0,8,93},{0,8,29},{0,9,154},{20,7,83},{0,8,125},
+ {0,8,61},{0,9,218},{18,7,23},{0,8,109},{0,8,45},{0,9,186},{0,8,13},
+ {0,8,141},{0,8,77},{0,9,250},{16,7,3},{0,8,83},{0,8,19},{21,8,195},
+ {19,7,35},{0,8,115},{0,8,51},{0,9,198},{17,7,11},{0,8,99},{0,8,35},
+ {0,9,166},{0,8,3},{0,8,131},{0,8,67},{0,9,230},{16,7,7},{0,8,91},
+ {0,8,27},{0,9,150},{20,7,67},{0,8,123},{0,8,59},{0,9,214},{18,7,19},
+ {0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139},{0,8,75},{0,9,246},
+ {16,7,5},{0,8,87},{0,8,23},{64,8,0},{19,7,51},{0,8,119},{0,8,55},
+ {0,9,206},{17,7,15},{0,8,103},{0,8,39},{0,9,174},{0,8,7},{0,8,135},
+ {0,8,71},{0,9,238},{16,7,9},{0,8,95},{0,8,31},{0,9,158},{20,7,99},
+ {0,8,127},{0,8,63},{0,9,222},{18,7,27},{0,8,111},{0,8,47},{0,9,190},
+ {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80},{0,8,16},
+ {20,8,115},{18,7,31},{0,8,112},{0,8,48},{0,9,193},{16,7,10},{0,8,96},
+ {0,8,32},{0,9,161},{0,8,0},{0,8,128},{0,8,64},{0,9,225},{16,7,6},
+ {0,8,88},{0,8,24},{0,9,145},{19,7,59},{0,8,120},{0,8,56},{0,9,209},
+ {17,7,17},{0,8,104},{0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72},
+ {0,9,241},{16,7,4},{0,8,84},{0,8,20},{21,8,227},{19,7,43},{0,8,116},
+ {0,8,52},{0,9,201},{17,7,13},{0,8,100},{0,8,36},{0,9,169},{0,8,4},
+ {0,8,132},{0,8,68},{0,9,233},{16,7,8},{0,8,92},{0,8,28},{0,9,153},
+ {20,7,83},{0,8,124},{0,8,60},{0,9,217},{18,7,23},{0,8,108},{0,8,44},
+ {0,9,185},{0,8,12},{0,8,140},{0,8,76},{0,9,249},{16,7,3},{0,8,82},
+ {0,8,18},{21,8,163},{19,7,35},{0,8,114},{0,8,50},{0,9,197},{17,7,11},
+ {0,8,98},{0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229},
+ {16,7,7},{0,8,90},{0,8,26},{0,9,149},{20,7,67},{0,8,122},{0,8,58},
+ {0,9,213},{18,7,19},{0,8,106},{0,8,42},{0,9,181},{0,8,10},{0,8,138},
+ {0,8,74},{0,9,245},{16,7,5},{0,8,86},{0,8,22},{64,8,0},{19,7,51},
+ {0,8,118},{0,8,54},{0,9,205},{17,7,15},{0,8,102},{0,8,38},{0,9,173},
+ {0,8,6},{0,8,134},{0,8,70},{0,9,237},{16,7,9},{0,8,94},{0,8,30},
+ {0,9,157},{20,7,99},{0,8,126},{0,8,62},{0,9,221},{18,7,27},{0,8,110},
+ {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253},{96,7,0},
+ {0,8,81},{0,8,17},{21,8,131},{18,7,31},{0,8,113},{0,8,49},{0,9,195},
+ {16,7,10},{0,8,97},{0,8,33},{0,9,163},{0,8,1},{0,8,129},{0,8,65},
+ {0,9,227},{16,7,6},{0,8,89},{0,8,25},{0,9,147},{19,7,59},{0,8,121},
+ {0,8,57},{0,9,211},{17,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9},
+ {0,8,137},{0,8,73},{0,9,243},{16,7,4},{0,8,85},{0,8,21},{16,8,258},
+ {19,7,43},{0,8,117},{0,8,53},{0,9,203},{17,7,13},{0,8,101},{0,8,37},
+ {0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235},{16,7,8},{0,8,93},
+ {0,8,29},{0,9,155},{20,7,83},{0,8,125},{0,8,61},{0,9,219},{18,7,23},
+ {0,8,109},{0,8,45},{0,9,187},{0,8,13},{0,8,141},{0,8,77},{0,9,251},
+ {16,7,3},{0,8,83},{0,8,19},{21,8,195},{19,7,35},{0,8,115},{0,8,51},
+ {0,9,199},{17,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131},
+ {0,8,67},{0,9,231},{16,7,7},{0,8,91},{0,8,27},{0,9,151},{20,7,67},
+ {0,8,123},{0,8,59},{0,9,215},{18,7,19},{0,8,107},{0,8,43},{0,9,183},
+ {0,8,11},{0,8,139},{0,8,75},{0,9,247},{16,7,5},{0,8,87},{0,8,23},
+ {64,8,0},{19,7,51},{0,8,119},{0,8,55},{0,9,207},{17,7,15},{0,8,103},
+ {0,8,39},{0,9,175},{0,8,7},{0,8,135},{0,8,71},{0,9,239},{16,7,9},
+ {0,8,95},{0,8,31},{0,9,159},{20,7,99},{0,8,127},{0,8,63},{0,9,223},
+ {18,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143},{0,8,79},
+ {0,9,255}
+ };
+
+ static const code distfix[32] = {
+ {16,5,1},{23,5,257},{19,5,17},{27,5,4097},{17,5,5},{25,5,1025},
+ {21,5,65},{29,5,16385},{16,5,3},{24,5,513},{20,5,33},{28,5,8193},
+ {18,5,9},{26,5,2049},{22,5,129},{64,5,0},{16,5,2},{23,5,385},
+ {19,5,25},{27,5,6145},{17,5,7},{25,5,1537},{21,5,97},{29,5,24577},
+ {16,5,4},{24,5,769},{20,5,49},{28,5,12289},{18,5,13},{26,5,3073},
+ {22,5,193},{64,5,0}
+ };
diff --git a/test/monniaux/glpk-4.65/src/zlib/inflate.c b/test/monniaux/glpk-4.65/src/zlib/inflate.c
new file mode 100644
index 00000000..a8431abe
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inflate.c
@@ -0,0 +1,1480 @@
+/* inflate.c -- zlib decompression
+ * Copyright (C) 1995-2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * Change history:
+ *
+ * 1.2.beta0 24 Nov 2002
+ * - First version -- complete rewrite of inflate to simplify code, avoid
+ * creation of window when not needed, minimize use of window when it is
+ * needed, make inffast.c even faster, implement gzip decoding, and to
+ * improve code readability and style over the previous zlib inflate code
+ *
+ * 1.2.beta1 25 Nov 2002
+ * - Use pointers for available input and output checking in inffast.c
+ * - Remove input and output counters in inffast.c
+ * - Change inffast.c entry and loop from avail_in >= 7 to >= 6
+ * - Remove unnecessary second byte pull from length extra in inffast.c
+ * - Unroll direct copy to three copies per loop in inffast.c
+ *
+ * 1.2.beta2 4 Dec 2002
+ * - Change external routine names to reduce potential conflicts
+ * - Correct filename to inffixed.h for fixed tables in inflate.c
+ * - Make hbuf[] unsigned char to match parameter type in inflate.c
+ * - Change strm->next_out[-state->offset] to *(strm->next_out - state->offset)
+ * to avoid negation problem on Alphas (64 bit) in inflate.c
+ *
+ * 1.2.beta3 22 Dec 2002
+ * - Add comments on state->bits assertion in inffast.c
+ * - Add comments on op field in inftrees.h
+ * - Fix bug in reuse of allocated window after inflateReset()
+ * - Remove bit fields--back to byte structure for speed
+ * - Remove distance extra == 0 check in inflate_fast()--only helps for lengths
+ * - Change post-increments to pre-increments in inflate_fast(), PPC biased?
+ * - Add compile time option, POSTINC, to use post-increments instead (Intel?)
+ * - Make MATCH copy in inflate() much faster for when inflate_fast() not used
+ * - Use local copies of stream next and avail values, as well as local bit
+ * buffer and bit count in inflate()--for speed when inflate_fast() not used
+ *
+ * 1.2.beta4 1 Jan 2003
+ * - Split ptr - 257 statements in inflate_table() to avoid compiler warnings
+ * - Move a comment on output buffer sizes from inffast.c to inflate.c
+ * - Add comments in inffast.c to introduce the inflate_fast() routine
+ * - Rearrange window copies in inflate_fast() for speed and simplification
+ * - Unroll last copy for window match in inflate_fast()
+ * - Use local copies of window variables in inflate_fast() for speed
+ * - Pull out common wnext == 0 case for speed in inflate_fast()
+ * - Make op and len in inflate_fast() unsigned for consistency
+ * - Add FAR to lcode and dcode declarations in inflate_fast()
+ * - Simplified bad distance check in inflate_fast()
+ * - Added inflateBackInit(), inflateBack(), and inflateBackEnd() in new
+ * source file infback.c to provide a call-back interface to inflate for
+ * programs like gzip and unzip -- uses window as output buffer to avoid
+ * window copying
+ *
+ * 1.2.beta5 1 Jan 2003
+ * - Improved inflateBack() interface to allow the caller to provide initial
+ * input in strm.
+ * - Fixed stored blocks bug in inflateBack()
+ *
+ * 1.2.beta6 4 Jan 2003
+ * - Added comments in inffast.c on effectiveness of POSTINC
+ * - Typecasting all around to reduce compiler warnings
+ * - Changed loops from while (1) or do {} while (1) to for (;;), again to
+ * make compilers happy
+ * - Changed type of window in inflateBackInit() to unsigned char *
+ *
+ * 1.2.beta7 27 Jan 2003
+ * - Changed many types to unsigned or unsigned short to avoid warnings
+ * - Added inflateCopy() function
+ *
+ * 1.2.0 9 Mar 2003
+ * - Changed inflateBack() interface to provide separate opaque descriptors
+ * for the in() and out() functions
+ * - Changed inflateBack() argument and in_func typedef to swap the length
+ * and buffer address return values for the input function
+ * - Check next_in and next_out for Z_NULL on entry to inflate()
+ *
+ * The history for versions after 1.2.0 are in ChangeLog in zlib distribution.
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "inflate.h"
+#include "inffast.h"
+
+#ifdef MAKEFIXED
+# ifndef BUILDFIXED
+# define BUILDFIXED
+# endif
+#endif
+
+/* function prototypes */
+local void fixedtables OF((struct inflate_state FAR *state));
+local int updatewindow OF((z_streamp strm, unsigned out));
+#ifdef BUILDFIXED
+ void makefixed OF((void));
+#endif
+local unsigned syncsearch OF((unsigned FAR *have, unsigned char FAR *buf,
+ unsigned len));
+
+int ZEXPORT inflateReset(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ strm->total_in = strm->total_out = state->total = 0;
+ strm->msg = Z_NULL;
+ strm->adler = 1; /* to support ill-conceived Java test suite */
+ state->mode = HEAD;
+ state->last = 0;
+ state->havedict = 0;
+ state->dmax = 32768U;
+ state->head = Z_NULL;
+ state->wsize = 0;
+ state->whave = 0;
+ state->wnext = 0;
+ state->hold = 0;
+ state->bits = 0;
+ state->lencode = state->distcode = state->next = state->codes;
+ state->sane = 1;
+ state->back = -1;
+ Tracev((stderr, "inflate: reset\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateReset2(strm, windowBits)
+z_streamp strm;
+int windowBits;
+{
+ int wrap;
+ struct inflate_state FAR *state;
+
+ /* get the state */
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* extract wrap request from windowBits parameter */
+ if (windowBits < 0) {
+ wrap = 0;
+ windowBits = -windowBits;
+ }
+ else {
+ wrap = (windowBits >> 4) + 1;
+#ifdef GUNZIP
+ if (windowBits < 48)
+ windowBits &= 15;
+#endif
+ }
+
+ /* set number of window bits, free window if different */
+ if (windowBits && (windowBits < 8 || windowBits > 15))
+ return Z_STREAM_ERROR;
+ if (state->window != Z_NULL && state->wbits != (unsigned)windowBits) {
+ ZFREE(strm, state->window);
+ state->window = Z_NULL;
+ }
+
+ /* update state and reset the rest of it */
+ state->wrap = wrap;
+ state->wbits = (unsigned)windowBits;
+ return inflateReset(strm);
+}
+
+int ZEXPORT inflateInit2_(strm, windowBits, version, stream_size)
+z_streamp strm;
+int windowBits;
+const char *version;
+int stream_size;
+{
+ int ret;
+ struct inflate_state FAR *state;
+
+ if (version == Z_NULL || version[0] != ZLIB_VERSION[0] ||
+ stream_size != (int)(sizeof(z_stream)))
+ return Z_VERSION_ERROR;
+ if (strm == Z_NULL) return Z_STREAM_ERROR;
+ strm->msg = Z_NULL; /* in case we return an error */
+ if (strm->zalloc == (alloc_func)0) {
+ strm->zalloc = zcalloc;
+ strm->opaque = (voidpf)0;
+ }
+ if (strm->zfree == (free_func)0) strm->zfree = zcfree;
+ state = (struct inflate_state FAR *)
+ ZALLOC(strm, 1, sizeof(struct inflate_state));
+ if (state == Z_NULL) return Z_MEM_ERROR;
+ Tracev((stderr, "inflate: allocated\n"));
+ strm->state = (struct internal_state FAR *)state;
+ state->window = Z_NULL;
+ ret = inflateReset2(strm, windowBits);
+ if (ret != Z_OK) {
+ ZFREE(strm, state);
+ strm->state = Z_NULL;
+ }
+ return ret;
+}
+
+int ZEXPORT inflateInit_(strm, version, stream_size)
+z_streamp strm;
+const char *version;
+int stream_size;
+{
+ return inflateInit2_(strm, DEF_WBITS, version, stream_size);
+}
+
+int ZEXPORT inflatePrime(strm, bits, value)
+z_streamp strm;
+int bits;
+int value;
+{
+ struct inflate_state FAR *state;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (bits < 0) {
+ state->hold = 0;
+ state->bits = 0;
+ return Z_OK;
+ }
+ if (bits > 16 || state->bits + bits > 32) return Z_STREAM_ERROR;
+ value &= (1L << bits) - 1;
+ state->hold += value << state->bits;
+ state->bits += bits;
+ return Z_OK;
+}
+
+/*
+ Return state with length and distance decoding tables and index sizes set to
+ fixed code decoding. Normally this returns fixed tables from inffixed.h.
+ If BUILDFIXED is defined, then instead this routine builds the tables the
+ first time it's called, and returns those tables the first time and
+ thereafter. This reduces the size of the code by about 2K bytes, in
+ exchange for a little execution time. However, BUILDFIXED should not be
+ used for threaded applications, since the rewriting of the tables and virgin
+ may not be thread-safe.
+ */
+local void fixedtables(state)
+struct inflate_state FAR *state;
+{
+#ifdef BUILDFIXED
+ static int virgin = 1;
+ static code *lenfix, *distfix;
+ static code fixed[544];
+
+ /* build fixed huffman tables if first call (may not be thread safe) */
+ if (virgin) {
+ unsigned sym, bits;
+ static code *next;
+
+ /* literal/length table */
+ sym = 0;
+ while (sym < 144) state->lens[sym++] = 8;
+ while (sym < 256) state->lens[sym++] = 9;
+ while (sym < 280) state->lens[sym++] = 7;
+ while (sym < 288) state->lens[sym++] = 8;
+ next = fixed;
+ lenfix = next;
+ bits = 9;
+ inflate_table(LENS, state->lens, 288, &(next), &(bits), state->work);
+
+ /* distance table */
+ sym = 0;
+ while (sym < 32) state->lens[sym++] = 5;
+ distfix = next;
+ bits = 5;
+ inflate_table(DISTS, state->lens, 32, &(next), &(bits), state->work);
+
+ /* do this just once */
+ virgin = 0;
+ }
+#else /* !BUILDFIXED */
+# include "inffixed.h"
+#endif /* BUILDFIXED */
+ state->lencode = lenfix;
+ state->lenbits = 9;
+ state->distcode = distfix;
+ state->distbits = 5;
+}
+
+#ifdef MAKEFIXED
+#include <stdio.h>
+
+/*
+ Write out the inffixed.h that is #include'd above. Defining MAKEFIXED also
+ defines BUILDFIXED, so the tables are built on the fly. makefixed() writes
+ those tables to stdout, which would be piped to inffixed.h. A small program
+ can simply call makefixed to do this:
+
+ void makefixed(void);
+
+ int main(void)
+ {
+ makefixed();
+ return 0;
+ }
+
+ Then that can be linked with zlib built with MAKEFIXED defined and run:
+
+ a.out > inffixed.h
+ */
+void makefixed()
+{
+ unsigned low, size;
+ struct inflate_state state;
+
+ fixedtables(&state);
+ puts(" /* inffixed.h -- table for decoding fixed codes");
+ puts(" * Generated automatically by makefixed().");
+ puts(" */");
+ puts("");
+ puts(" /* WARNING: this file should *not* be used by applications.");
+ puts(" It is part of the implementation of this library and is");
+ puts(" subject to change. Applications should only use zlib.h.");
+ puts(" */");
+ puts("");
+ size = 1U << 9;
+ printf(" static const code lenfix[%u] = {", size);
+ low = 0;
+ for (;;) {
+ if ((low % 7) == 0) printf("\n ");
+ printf("{%u,%u,%d}", state.lencode[low].op, state.lencode[low].bits,
+ state.lencode[low].val);
+ if (++low == size) break;
+ putchar(',');
+ }
+ puts("\n };");
+ size = 1U << 5;
+ printf("\n static const code distfix[%u] = {", size);
+ low = 0;
+ for (;;) {
+ if ((low % 6) == 0) printf("\n ");
+ printf("{%u,%u,%d}", state.distcode[low].op, state.distcode[low].bits,
+ state.distcode[low].val);
+ if (++low == size) break;
+ putchar(',');
+ }
+ puts("\n };");
+}
+#endif /* MAKEFIXED */
+
+/*
+ Update the window with the last wsize (normally 32K) bytes written before
+ returning. If window does not exist yet, create it. This is only called
+ when a window is already in use, or when output has been written during this
+ inflate call, but the end of the deflate stream has not been reached yet.
+ It is also called to create a window for dictionary data when a dictionary
+ is loaded.
+
+ Providing output buffers larger than 32K to inflate() should provide a speed
+ advantage, since only the last 32K of output is copied to the sliding window
+ upon return from inflate(), and since all distances after the first 32K of
+ output will fall in the output data, making match copies simpler and faster.
+ The advantage may be dependent on the size of the processor's data caches.
+ */
+local int updatewindow(strm, out)
+z_streamp strm;
+unsigned out;
+{
+ struct inflate_state FAR *state;
+ unsigned copy, dist;
+
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* if it hasn't been done already, allocate space for the window */
+ if (state->window == Z_NULL) {
+ state->window = (unsigned char FAR *)
+ ZALLOC(strm, 1U << state->wbits,
+ sizeof(unsigned char));
+ if (state->window == Z_NULL) return 1;
+ }
+
+ /* if window not in use yet, initialize */
+ if (state->wsize == 0) {
+ state->wsize = 1U << state->wbits;
+ state->wnext = 0;
+ state->whave = 0;
+ }
+
+ /* copy state->wsize or less output bytes into the circular window */
+ copy = out - strm->avail_out;
+ if (copy >= state->wsize) {
+ zmemcpy(state->window, strm->next_out - state->wsize, state->wsize);
+ state->wnext = 0;
+ state->whave = state->wsize;
+ }
+ else {
+ dist = state->wsize - state->wnext;
+ if (dist > copy) dist = copy;
+ zmemcpy(state->window + state->wnext, strm->next_out - copy, dist);
+ copy -= dist;
+ if (copy) {
+ zmemcpy(state->window, strm->next_out - copy, copy);
+ state->wnext = copy;
+ state->whave = state->wsize;
+ }
+ else {
+ state->wnext += dist;
+ if (state->wnext == state->wsize) state->wnext = 0;
+ if (state->whave < state->wsize) state->whave += dist;
+ }
+ }
+ return 0;
+}
+
+/* Macros for inflate(): */
+
+/* check function to use adler32() for zlib or crc32() for gzip */
+#ifdef GUNZIP
+# define UPDATE(check, buf, len) \
+ (state->flags ? crc32(check, buf, len) : adler32(check, buf, len))
+#else
+# define UPDATE(check, buf, len) adler32(check, buf, len)
+#endif
+
+/* check macros for header crc */
+#ifdef GUNZIP
+# define CRC2(check, word) \
+ do { \
+ hbuf[0] = (unsigned char)(word); \
+ hbuf[1] = (unsigned char)((word) >> 8); \
+ check = crc32(check, hbuf, 2); \
+ } while (0)
+
+# define CRC4(check, word) \
+ do { \
+ hbuf[0] = (unsigned char)(word); \
+ hbuf[1] = (unsigned char)((word) >> 8); \
+ hbuf[2] = (unsigned char)((word) >> 16); \
+ hbuf[3] = (unsigned char)((word) >> 24); \
+ check = crc32(check, hbuf, 4); \
+ } while (0)
+#endif
+
+/* Load registers with state in inflate() for speed */
+#define LOAD() \
+ do { \
+ put = strm->next_out; \
+ left = strm->avail_out; \
+ next = strm->next_in; \
+ have = strm->avail_in; \
+ hold = state->hold; \
+ bits = state->bits; \
+ } while (0)
+
+/* Restore state from registers in inflate() */
+#define RESTORE() \
+ do { \
+ strm->next_out = put; \
+ strm->avail_out = left; \
+ strm->next_in = next; \
+ strm->avail_in = have; \
+ state->hold = hold; \
+ state->bits = bits; \
+ } while (0)
+
+/* Clear the input bit accumulator */
+#define INITBITS() \
+ do { \
+ hold = 0; \
+ bits = 0; \
+ } while (0)
+
+/* Get a byte of input into the bit accumulator, or return from inflate()
+ if there is no input available. */
+#define PULLBYTE() \
+ do { \
+ if (have == 0) goto inf_leave; \
+ have--; \
+ hold += (unsigned long)(*next++) << bits; \
+ bits += 8; \
+ } while (0)
+
+/* Assure that there are at least n bits in the bit accumulator. If there is
+ not enough available input to do that, then return from inflate(). */
+#define NEEDBITS(n) \
+ do { \
+ while (bits < (unsigned)(n)) \
+ PULLBYTE(); \
+ } while (0)
+
+/* Return the low n bits of the bit accumulator (n < 16) */
+#define BITS(n) \
+ ((unsigned)hold & ((1U << (n)) - 1))
+
+/* Remove n bits from the bit accumulator */
+#define DROPBITS(n) \
+ do { \
+ hold >>= (n); \
+ bits -= (unsigned)(n); \
+ } while (0)
+
+/* Remove zero to seven bits as needed to go to a byte boundary */
+#define BYTEBITS() \
+ do { \
+ hold >>= bits & 7; \
+ bits -= bits & 7; \
+ } while (0)
+
+/* Reverse the bytes in a 32-bit value */
+#define REVERSE(q) \
+ ((((q) >> 24) & 0xff) + (((q) >> 8) & 0xff00) + \
+ (((q) & 0xff00) << 8) + (((q) & 0xff) << 24))
+
+/*
+ inflate() uses a state machine to process as much input data and generate as
+ much output data as possible before returning. The state machine is
+ structured roughly as follows:
+
+ for (;;) switch (state) {
+ ...
+ case STATEn:
+ if (not enough input data or output space to make progress)
+ return;
+ ... make progress ...
+ state = STATEm;
+ break;
+ ...
+ }
+
+ so when inflate() is called again, the same case is attempted again, and
+ if the appropriate resources are provided, the machine proceeds to the
+ next state. The NEEDBITS() macro is usually the way the state evaluates
+ whether it can proceed or should return. NEEDBITS() does the return if
+ the requested bits are not available. The typical use of the BITS macros
+ is:
+
+ NEEDBITS(n);
+ ... do something with BITS(n) ...
+ DROPBITS(n);
+
+ where NEEDBITS(n) either returns from inflate() if there isn't enough
+ input left to load n bits into the accumulator, or it continues. BITS(n)
+ gives the low n bits in the accumulator. When done, DROPBITS(n) drops
+ the low n bits off the accumulator. INITBITS() clears the accumulator
+ and sets the number of available bits to zero. BYTEBITS() discards just
+ enough bits to put the accumulator on a byte boundary. After BYTEBITS()
+ and a NEEDBITS(8), then BITS(8) would return the next byte in the stream.
+
+ NEEDBITS(n) uses PULLBYTE() to get an available byte of input, or to return
+ if there is no input available. The decoding of variable length codes uses
+ PULLBYTE() directly in order to pull just enough bytes to decode the next
+ code, and no more.
+
+ Some states loop until they get enough input, making sure that enough
+ state information is maintained to continue the loop where it left off
+ if NEEDBITS() returns in the loop. For example, want, need, and keep
+ would all have to actually be part of the saved state in case NEEDBITS()
+ returns:
+
+ case STATEw:
+ while (want < need) {
+ NEEDBITS(n);
+ keep[want++] = BITS(n);
+ DROPBITS(n);
+ }
+ state = STATEx;
+ case STATEx:
+
+ As shown above, if the next state is also the next case, then the break
+ is omitted.
+
+ A state may also return if there is not enough output space available to
+ complete that state. Those states are copying stored data, writing a
+ literal byte, and copying a matching string.
+
+ When returning, a "goto inf_leave" is used to update the total counters,
+ update the check value, and determine whether any progress has been made
+ during that inflate() call in order to return the proper return code.
+ Progress is defined as a change in either strm->avail_in or strm->avail_out.
+ When there is a window, goto inf_leave will update the window with the last
+ output written. If a goto inf_leave occurs in the middle of decompression
+ and there is no window currently, goto inf_leave will create one and copy
+ output to the window for the next call of inflate().
+
+ In this implementation, the flush parameter of inflate() only affects the
+ return code (per zlib.h). inflate() always writes as much as possible to
+ strm->next_out, given the space available and the provided input--the effect
+ documented in zlib.h of Z_SYNC_FLUSH. Furthermore, inflate() always defers
+ the allocation of and copying into a sliding window until necessary, which
+ provides the effect documented in zlib.h for Z_FINISH when the entire input
+ stream available. So the only thing the flush parameter actually does is:
+ when flush is set to Z_FINISH, inflate() cannot return Z_OK. Instead it
+ will return Z_BUF_ERROR if it has not reached the end of the stream.
+ */
+
+int ZEXPORT inflate(strm, flush)
+z_streamp strm;
+int flush;
+{
+ struct inflate_state FAR *state;
+ unsigned char FAR *next; /* next input */
+ unsigned char FAR *put; /* next output */
+ unsigned have, left; /* available input and output */
+ unsigned long hold; /* bit buffer */
+ unsigned bits; /* bits in bit buffer */
+ unsigned in, out; /* save starting available input and output */
+ unsigned copy; /* number of stored or match bytes to copy */
+ unsigned char FAR *from; /* where to copy match bytes from */
+ code here; /* current decoding table entry */
+ code last; /* parent table entry */
+ unsigned len; /* length to copy for repeats, bits to drop */
+ int ret; /* return code */
+#ifdef GUNZIP
+ unsigned char hbuf[4]; /* buffer for gzip header crc calculation */
+#endif
+ static const unsigned short order[19] = /* permutation of code lengths */
+ {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15};
+
+ if (strm == Z_NULL || strm->state == Z_NULL || strm->next_out == Z_NULL ||
+ (strm->next_in == Z_NULL && strm->avail_in != 0))
+ return Z_STREAM_ERROR;
+
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->mode == TYPE) state->mode = TYPEDO; /* skip check */
+ LOAD();
+ in = have;
+ out = left;
+ ret = Z_OK;
+ for (;;)
+ switch (state->mode) {
+ case HEAD:
+ if (state->wrap == 0) {
+ state->mode = TYPEDO;
+ break;
+ }
+ NEEDBITS(16);
+#ifdef GUNZIP
+ if ((state->wrap & 2) && hold == 0x8b1f) { /* gzip header */
+ state->check = crc32(0L, Z_NULL, 0);
+ CRC2(state->check, hold);
+ INITBITS();
+ state->mode = FLAGS;
+ break;
+ }
+ state->flags = 0; /* expect zlib header */
+ if (state->head != Z_NULL)
+ state->head->done = -1;
+ if (!(state->wrap & 1) || /* check if zlib header allowed */
+#else
+ if (
+#endif
+ ((BITS(8) << 8) + (hold >> 8)) % 31) {
+ strm->msg = (char *)"incorrect header check";
+ state->mode = BAD;
+ break;
+ }
+ if (BITS(4) != Z_DEFLATED) {
+ strm->msg = (char *)"unknown compression method";
+ state->mode = BAD;
+ break;
+ }
+ DROPBITS(4);
+ len = BITS(4) + 8;
+ if (state->wbits == 0)
+ state->wbits = len;
+ else if (len > state->wbits) {
+ strm->msg = (char *)"invalid window size";
+ state->mode = BAD;
+ break;
+ }
+ state->dmax = 1U << len;
+ Tracev((stderr, "inflate: zlib header ok\n"));
+ strm->adler = state->check = adler32(0L, Z_NULL, 0);
+ state->mode = hold & 0x200 ? DICTID : TYPE;
+ INITBITS();
+ break;
+#ifdef GUNZIP
+ case FLAGS:
+ NEEDBITS(16);
+ state->flags = (int)(hold);
+ if ((state->flags & 0xff) != Z_DEFLATED) {
+ strm->msg = (char *)"unknown compression method";
+ state->mode = BAD;
+ break;
+ }
+ if (state->flags & 0xe000) {
+ strm->msg = (char *)"unknown header flags set";
+ state->mode = BAD;
+ break;
+ }
+ if (state->head != Z_NULL)
+ state->head->text = (int)((hold >> 8) & 1);
+ if (state->flags & 0x0200) CRC2(state->check, hold);
+ INITBITS();
+ state->mode = TIME;
+ case TIME:
+ NEEDBITS(32);
+ if (state->head != Z_NULL)
+ state->head->time = hold;
+ if (state->flags & 0x0200) CRC4(state->check, hold);
+ INITBITS();
+ state->mode = OS;
+ case OS:
+ NEEDBITS(16);
+ if (state->head != Z_NULL) {
+ state->head->xflags = (int)(hold & 0xff);
+ state->head->os = (int)(hold >> 8);
+ }
+ if (state->flags & 0x0200) CRC2(state->check, hold);
+ INITBITS();
+ state->mode = EXLEN;
+ case EXLEN:
+ if (state->flags & 0x0400) {
+ NEEDBITS(16);
+ state->length = (unsigned)(hold);
+ if (state->head != Z_NULL)
+ state->head->extra_len = (unsigned)hold;
+ if (state->flags & 0x0200) CRC2(state->check, hold);
+ INITBITS();
+ }
+ else if (state->head != Z_NULL)
+ state->head->extra = Z_NULL;
+ state->mode = EXTRA;
+ case EXTRA:
+ if (state->flags & 0x0400) {
+ copy = state->length;
+ if (copy > have) copy = have;
+ if (copy) {
+ if (state->head != Z_NULL &&
+ state->head->extra != Z_NULL) {
+ len = state->head->extra_len - state->length;
+ zmemcpy(state->head->extra + len, next,
+ len + copy > state->head->extra_max ?
+ state->head->extra_max - len : copy);
+ }
+ if (state->flags & 0x0200)
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ state->length -= copy;
+ }
+ if (state->length) goto inf_leave;
+ }
+ state->length = 0;
+ state->mode = NAME;
+ case NAME:
+ if (state->flags & 0x0800) {
+ if (have == 0) goto inf_leave;
+ copy = 0;
+ do {
+ len = (unsigned)(next[copy++]);
+ if (state->head != Z_NULL &&
+ state->head->name != Z_NULL &&
+ state->length < state->head->name_max)
+ state->head->name[state->length++] = len;
+ } while (len && copy < have);
+ if (state->flags & 0x0200)
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ if (len) goto inf_leave;
+ }
+ else if (state->head != Z_NULL)
+ state->head->name = Z_NULL;
+ state->length = 0;
+ state->mode = COMMENT;
+ case COMMENT:
+ if (state->flags & 0x1000) {
+ if (have == 0) goto inf_leave;
+ copy = 0;
+ do {
+ len = (unsigned)(next[copy++]);
+ if (state->head != Z_NULL &&
+ state->head->comment != Z_NULL &&
+ state->length < state->head->comm_max)
+ state->head->comment[state->length++] = len;
+ } while (len && copy < have);
+ if (state->flags & 0x0200)
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ if (len) goto inf_leave;
+ }
+ else if (state->head != Z_NULL)
+ state->head->comment = Z_NULL;
+ state->mode = HCRC;
+ case HCRC:
+ if (state->flags & 0x0200) {
+ NEEDBITS(16);
+ if (hold != (state->check & 0xffff)) {
+ strm->msg = (char *)"header crc mismatch";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ }
+ if (state->head != Z_NULL) {
+ state->head->hcrc = (int)((state->flags >> 9) & 1);
+ state->head->done = 1;
+ }
+ strm->adler = state->check = crc32(0L, Z_NULL, 0);
+ state->mode = TYPE;
+ break;
+#endif
+ case DICTID:
+ NEEDBITS(32);
+ strm->adler = state->check = REVERSE(hold);
+ INITBITS();
+ state->mode = DICT;
+ case DICT:
+ if (state->havedict == 0) {
+ RESTORE();
+ return Z_NEED_DICT;
+ }
+ strm->adler = state->check = adler32(0L, Z_NULL, 0);
+ state->mode = TYPE;
+ case TYPE:
+ if (flush == Z_BLOCK || flush == Z_TREES) goto inf_leave;
+ case TYPEDO:
+ if (state->last) {
+ BYTEBITS();
+ state->mode = CHECK;
+ break;
+ }
+ NEEDBITS(3);
+ state->last = BITS(1);
+ DROPBITS(1);
+ switch (BITS(2)) {
+ case 0: /* stored block */
+ Tracev((stderr, "inflate: stored block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = STORED;
+ break;
+ case 1: /* fixed block */
+ fixedtables(state);
+ Tracev((stderr, "inflate: fixed codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = LEN_; /* decode codes */
+ if (flush == Z_TREES) {
+ DROPBITS(2);
+ goto inf_leave;
+ }
+ break;
+ case 2: /* dynamic block */
+ Tracev((stderr, "inflate: dynamic codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = TABLE;
+ break;
+ case 3:
+ strm->msg = (char *)"invalid block type";
+ state->mode = BAD;
+ }
+ DROPBITS(2);
+ break;
+ case STORED:
+ BYTEBITS(); /* go to byte boundary */
+ NEEDBITS(32);
+ if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) {
+ strm->msg = (char *)"invalid stored block lengths";
+ state->mode = BAD;
+ break;
+ }
+ state->length = (unsigned)hold & 0xffff;
+ Tracev((stderr, "inflate: stored length %u\n",
+ state->length));
+ INITBITS();
+ state->mode = COPY_;
+ if (flush == Z_TREES) goto inf_leave;
+ case COPY_:
+ state->mode = COPY;
+ case COPY:
+ copy = state->length;
+ if (copy) {
+ if (copy > have) copy = have;
+ if (copy > left) copy = left;
+ if (copy == 0) goto inf_leave;
+ zmemcpy(put, next, copy);
+ have -= copy;
+ next += copy;
+ left -= copy;
+ put += copy;
+ state->length -= copy;
+ break;
+ }
+ Tracev((stderr, "inflate: stored end\n"));
+ state->mode = TYPE;
+ break;
+ case TABLE:
+ NEEDBITS(14);
+ state->nlen = BITS(5) + 257;
+ DROPBITS(5);
+ state->ndist = BITS(5) + 1;
+ DROPBITS(5);
+ state->ncode = BITS(4) + 4;
+ DROPBITS(4);
+#ifndef PKZIP_BUG_WORKAROUND
+ if (state->nlen > 286 || state->ndist > 30) {
+ strm->msg = (char *)"too many length or distance symbols";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ Tracev((stderr, "inflate: table sizes ok\n"));
+ state->have = 0;
+ state->mode = LENLENS;
+ case LENLENS:
+ while (state->have < state->ncode) {
+ NEEDBITS(3);
+ state->lens[order[state->have++]] = (unsigned short)BITS(3);
+ DROPBITS(3);
+ }
+ while (state->have < 19)
+ state->lens[order[state->have++]] = 0;
+ state->next = state->codes;
+ state->lencode = (code const FAR *)(state->next);
+ state->lenbits = 7;
+ ret = inflate_table(CODES, state->lens, 19, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid code lengths set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: code lengths ok\n"));
+ state->have = 0;
+ state->mode = CODELENS;
+ case CODELENS:
+ while (state->have < state->nlen + state->ndist) {
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.val < 16) {
+ NEEDBITS(here.bits);
+ DROPBITS(here.bits);
+ state->lens[state->have++] = here.val;
+ }
+ else {
+ if (here.val == 16) {
+ NEEDBITS(here.bits + 2);
+ DROPBITS(here.bits);
+ if (state->have == 0) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ len = state->lens[state->have - 1];
+ copy = 3 + BITS(2);
+ DROPBITS(2);
+ }
+ else if (here.val == 17) {
+ NEEDBITS(here.bits + 3);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 3 + BITS(3);
+ DROPBITS(3);
+ }
+ else {
+ NEEDBITS(here.bits + 7);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 11 + BITS(7);
+ DROPBITS(7);
+ }
+ if (state->have + copy > state->nlen + state->ndist) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ while (copy--)
+ state->lens[state->have++] = (unsigned short)len;
+ }
+ }
+
+ /* handle error breaks in while */
+ if (state->mode == BAD) break;
+
+ /* check for end-of-block code (better have one) */
+ if (state->lens[256] == 0) {
+ strm->msg = (char *)"invalid code -- missing end-of-block";
+ state->mode = BAD;
+ break;
+ }
+
+ /* build code tables -- note: do not change the lenbits or distbits
+ values here (9 and 6) without reading the comments in inftrees.h
+ concerning the ENOUGH constants, which depend on those values */
+ state->next = state->codes;
+ state->lencode = (code const FAR *)(state->next);
+ state->lenbits = 9;
+ ret = inflate_table(LENS, state->lens, state->nlen, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid literal/lengths set";
+ state->mode = BAD;
+ break;
+ }
+ state->distcode = (code const FAR *)(state->next);
+ state->distbits = 6;
+ ret = inflate_table(DISTS, state->lens + state->nlen, state->ndist,
+ &(state->next), &(state->distbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid distances set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: codes ok\n"));
+ state->mode = LEN_;
+ if (flush == Z_TREES) goto inf_leave;
+ case LEN_:
+ state->mode = LEN;
+ case LEN:
+ if (have >= 6 && left >= 258) {
+ RESTORE();
+ inflate_fast(strm, out);
+ LOAD();
+ if (state->mode == TYPE)
+ state->back = -1;
+ break;
+ }
+ state->back = 0;
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.op && (here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->lencode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ state->back += last.bits;
+ }
+ DROPBITS(here.bits);
+ state->back += here.bits;
+ state->length = (unsigned)here.val;
+ if ((int)(here.op) == 0) {
+ Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ?
+ "inflate: literal '%c'\n" :
+ "inflate: literal 0x%02x\n", here.val));
+ state->mode = LIT;
+ break;
+ }
+ if (here.op & 32) {
+ Tracevv((stderr, "inflate: end of block\n"));
+ state->back = -1;
+ state->mode = TYPE;
+ break;
+ }
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid literal/length code";
+ state->mode = BAD;
+ break;
+ }
+ state->extra = (unsigned)(here.op) & 15;
+ state->mode = LENEXT;
+ case LENEXT:
+ if (state->extra) {
+ NEEDBITS(state->extra);
+ state->length += BITS(state->extra);
+ DROPBITS(state->extra);
+ state->back += state->extra;
+ }
+ Tracevv((stderr, "inflate: length %u\n", state->length));
+ state->was = state->length;
+ state->mode = DIST;
+ case DIST:
+ for (;;) {
+ here = state->distcode[BITS(state->distbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if ((here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->distcode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ state->back += last.bits;
+ }
+ DROPBITS(here.bits);
+ state->back += here.bits;
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid distance code";
+ state->mode = BAD;
+ break;
+ }
+ state->offset = (unsigned)here.val;
+ state->extra = (unsigned)(here.op) & 15;
+ state->mode = DISTEXT;
+ case DISTEXT:
+ if (state->extra) {
+ NEEDBITS(state->extra);
+ state->offset += BITS(state->extra);
+ DROPBITS(state->extra);
+ state->back += state->extra;
+ }
+#ifdef INFLATE_STRICT
+ if (state->offset > state->dmax) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ Tracevv((stderr, "inflate: distance %u\n", state->offset));
+ state->mode = MATCH;
+ case MATCH:
+ if (left == 0) goto inf_leave;
+ copy = out - left;
+ if (state->offset > copy) { /* copy from window */
+ copy = state->offset - copy;
+ if (copy > state->whave) {
+ if (state->sane) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ Trace((stderr, "inflate.c too far\n"));
+ copy -= state->whave;
+ if (copy > state->length) copy = state->length;
+ if (copy > left) copy = left;
+ left -= copy;
+ state->length -= copy;
+ do {
+ *put++ = 0;
+ } while (--copy);
+ if (state->length == 0) state->mode = LEN;
+ break;
+#endif
+ }
+ if (copy > state->wnext) {
+ copy -= state->wnext;
+ from = state->window + (state->wsize - copy);
+ }
+ else
+ from = state->window + (state->wnext - copy);
+ if (copy > state->length) copy = state->length;
+ }
+ else { /* copy from output */
+ from = put - state->offset;
+ copy = state->length;
+ }
+ if (copy > left) copy = left;
+ left -= copy;
+ state->length -= copy;
+ do {
+ *put++ = *from++;
+ } while (--copy);
+ if (state->length == 0) state->mode = LEN;
+ break;
+ case LIT:
+ if (left == 0) goto inf_leave;
+ *put++ = (unsigned char)(state->length);
+ left--;
+ state->mode = LEN;
+ break;
+ case CHECK:
+ if (state->wrap) {
+ NEEDBITS(32);
+ out -= left;
+ strm->total_out += out;
+ state->total += out;
+ if (out)
+ strm->adler = state->check =
+ UPDATE(state->check, put - out, out);
+ out = left;
+ if ((
+#ifdef GUNZIP
+ state->flags ? hold :
+#endif
+ REVERSE(hold)) != state->check) {
+ strm->msg = (char *)"incorrect data check";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ Tracev((stderr, "inflate: check matches trailer\n"));
+ }
+#ifdef GUNZIP
+ state->mode = LENGTH;
+ case LENGTH:
+ if (state->wrap && state->flags) {
+ NEEDBITS(32);
+ if (hold != (state->total & 0xffffffffUL)) {
+ strm->msg = (char *)"incorrect length check";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ Tracev((stderr, "inflate: length matches trailer\n"));
+ }
+#endif
+ state->mode = DONE;
+ case DONE:
+ ret = Z_STREAM_END;
+ goto inf_leave;
+ case BAD:
+ ret = Z_DATA_ERROR;
+ goto inf_leave;
+ case MEM:
+ return Z_MEM_ERROR;
+ case SYNC:
+ default:
+ return Z_STREAM_ERROR;
+ }
+
+ /*
+ Return from inflate(), updating the total counts and the check value.
+ If there was no progress during the inflate() call, return a buffer
+ error. Call updatewindow() to create and/or update the window state.
+ Note: a memory error from inflate() is non-recoverable.
+ */
+ inf_leave:
+ RESTORE();
+ if (state->wsize || (state->mode < CHECK && out != strm->avail_out))
+ if (updatewindow(strm, out)) {
+ state->mode = MEM;
+ return Z_MEM_ERROR;
+ }
+ in -= strm->avail_in;
+ out -= strm->avail_out;
+ strm->total_in += in;
+ strm->total_out += out;
+ state->total += out;
+ if (state->wrap && out)
+ strm->adler = state->check =
+ UPDATE(state->check, strm->next_out - out, out);
+ strm->data_type = state->bits + (state->last ? 64 : 0) +
+ (state->mode == TYPE ? 128 : 0) +
+ (state->mode == LEN_ || state->mode == COPY_ ? 256 : 0);
+ if (((in == 0 && out == 0) || flush == Z_FINISH) && ret == Z_OK)
+ ret = Z_BUF_ERROR;
+ return ret;
+}
+
+int ZEXPORT inflateEnd(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+ if (strm == Z_NULL || strm->state == Z_NULL || strm->zfree == (free_func)0)
+ return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->window != Z_NULL) ZFREE(strm, state->window);
+ ZFREE(strm, strm->state);
+ strm->state = Z_NULL;
+ Tracev((stderr, "inflate: end\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateSetDictionary(strm, dictionary, dictLength)
+z_streamp strm;
+const Bytef *dictionary;
+uInt dictLength;
+{
+ struct inflate_state FAR *state;
+ unsigned long id;
+
+ /* check state */
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->wrap != 0 && state->mode != DICT)
+ return Z_STREAM_ERROR;
+
+ /* check for correct dictionary id */
+ if (state->mode == DICT) {
+ id = adler32(0L, Z_NULL, 0);
+ id = adler32(id, dictionary, dictLength);
+ if (id != state->check)
+ return Z_DATA_ERROR;
+ }
+
+ /* copy dictionary to window */
+ if (updatewindow(strm, strm->avail_out)) {
+ state->mode = MEM;
+ return Z_MEM_ERROR;
+ }
+ if (dictLength > state->wsize) {
+ zmemcpy(state->window, dictionary + dictLength - state->wsize,
+ state->wsize);
+ state->whave = state->wsize;
+ }
+ else {
+ zmemcpy(state->window + state->wsize - dictLength, dictionary,
+ dictLength);
+ state->whave = dictLength;
+ }
+ state->havedict = 1;
+ Tracev((stderr, "inflate: dictionary set\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateGetHeader(strm, head)
+z_streamp strm;
+gz_headerp head;
+{
+ struct inflate_state FAR *state;
+
+ /* check state */
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if ((state->wrap & 2) == 0) return Z_STREAM_ERROR;
+
+ /* save header structure */
+ state->head = head;
+ head->done = 0;
+ return Z_OK;
+}
+
+/*
+ Search buf[0..len-1] for the pattern: 0, 0, 0xff, 0xff. Return when found
+ or when out of input. When called, *have is the number of pattern bytes
+ found in order so far, in 0..3. On return *have is updated to the new
+ state. If on return *have equals four, then the pattern was found and the
+ return value is how many bytes were read including the last byte of the
+ pattern. If *have is less than four, then the pattern has not been found
+ yet and the return value is len. In the latter case, syncsearch() can be
+ called again with more data and the *have state. *have is initialized to
+ zero for the first call.
+ */
+local unsigned syncsearch(have, buf, len)
+unsigned FAR *have;
+unsigned char FAR *buf;
+unsigned len;
+{
+ unsigned got;
+ unsigned next;
+
+ got = *have;
+ next = 0;
+ while (next < len && got < 4) {
+ if ((int)(buf[next]) == (got < 2 ? 0 : 0xff))
+ got++;
+ else if (buf[next])
+ got = 0;
+ else
+ got = 4 - got;
+ next++;
+ }
+ *have = got;
+ return next;
+}
+
+int ZEXPORT inflateSync(strm)
+z_streamp strm;
+{
+ unsigned len; /* number of bytes to look at or looked at */
+ unsigned long in, out; /* temporary to save total_in and total_out */
+ unsigned char buf[4]; /* to restore bit buffer to byte string */
+ struct inflate_state FAR *state;
+
+ /* check parameters */
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (strm->avail_in == 0 && state->bits < 8) return Z_BUF_ERROR;
+
+ /* if first time, start search in bit buffer */
+ if (state->mode != SYNC) {
+ state->mode = SYNC;
+ state->hold <<= state->bits & 7;
+ state->bits -= state->bits & 7;
+ len = 0;
+ while (state->bits >= 8) {
+ buf[len++] = (unsigned char)(state->hold);
+ state->hold >>= 8;
+ state->bits -= 8;
+ }
+ state->have = 0;
+ syncsearch(&(state->have), buf, len);
+ }
+
+ /* search available input */
+ len = syncsearch(&(state->have), strm->next_in, strm->avail_in);
+ strm->avail_in -= len;
+ strm->next_in += len;
+ strm->total_in += len;
+
+ /* return no joy or set up to restart inflate() on a new block */
+ if (state->have != 4) return Z_DATA_ERROR;
+ in = strm->total_in; out = strm->total_out;
+ inflateReset(strm);
+ strm->total_in = in; strm->total_out = out;
+ state->mode = TYPE;
+ return Z_OK;
+}
+
+/*
+ Returns true if inflate is currently at the end of a block generated by
+ Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP
+ implementation to provide an additional safety check. PPP uses
+ Z_SYNC_FLUSH but removes the length bytes of the resulting empty stored
+ block. When decompressing, PPP checks that at the end of input packet,
+ inflate is waiting for these length bytes.
+ */
+int ZEXPORT inflateSyncPoint(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ return state->mode == STORED && state->bits == 0;
+}
+
+int ZEXPORT inflateCopy(dest, source)
+z_streamp dest;
+z_streamp source;
+{
+ struct inflate_state FAR *state;
+ struct inflate_state FAR *copy;
+ unsigned char FAR *window;
+ unsigned wsize;
+
+ /* check input */
+ if (dest == Z_NULL || source == Z_NULL || source->state == Z_NULL ||
+ source->zalloc == (alloc_func)0 || source->zfree == (free_func)0)
+ return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)source->state;
+
+ /* allocate space */
+ copy = (struct inflate_state FAR *)
+ ZALLOC(source, 1, sizeof(struct inflate_state));
+ if (copy == Z_NULL) return Z_MEM_ERROR;
+ window = Z_NULL;
+ if (state->window != Z_NULL) {
+ window = (unsigned char FAR *)
+ ZALLOC(source, 1U << state->wbits, sizeof(unsigned char));
+ if (window == Z_NULL) {
+ ZFREE(source, copy);
+ return Z_MEM_ERROR;
+ }
+ }
+
+ /* copy state */
+ zmemcpy(dest, source, sizeof(z_stream));
+ zmemcpy(copy, state, sizeof(struct inflate_state));
+ if (state->lencode >= state->codes &&
+ state->lencode <= state->codes + ENOUGH - 1) {
+ copy->lencode = copy->codes + (state->lencode - state->codes);
+ copy->distcode = copy->codes + (state->distcode - state->codes);
+ }
+ copy->next = copy->codes + (state->next - state->codes);
+ if (window != Z_NULL) {
+ wsize = 1U << state->wbits;
+ zmemcpy(window, state->window, wsize);
+ }
+ copy->window = window;
+ dest->state = (struct internal_state FAR *)copy;
+ return Z_OK;
+}
+
+int ZEXPORT inflateUndermine(strm, subvert)
+z_streamp strm;
+int subvert;
+{
+ struct inflate_state FAR *state;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ state->sane = !subvert;
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ return Z_OK;
+#else
+ state->sane = 1;
+ return Z_DATA_ERROR;
+#endif
+}
+
+long ZEXPORT inflateMark(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (strm == Z_NULL || strm->state == Z_NULL) return -1L << 16;
+ state = (struct inflate_state FAR *)strm->state;
+ return ((long)(state->back) << 16) +
+ (state->mode == COPY ? state->length :
+ (state->mode == MATCH ? state->was - state->length : 0));
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/inflate.h b/test/monniaux/glpk-4.65/src/zlib/inflate.h
new file mode 100644
index 00000000..95f4986d
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inflate.h
@@ -0,0 +1,122 @@
+/* inflate.h -- internal inflate state definition
+ * Copyright (C) 1995-2009 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* define NO_GZIP when compiling if you want to disable gzip header and
+ trailer decoding by inflate(). NO_GZIP would be used to avoid linking in
+ the crc code when it is not needed. For shared libraries, gzip decoding
+ should be left enabled. */
+#ifndef NO_GZIP
+# define GUNZIP
+#endif
+
+/* Possible inflate modes between inflate() calls */
+typedef enum {
+ HEAD, /* i: waiting for magic header */
+ FLAGS, /* i: waiting for method and flags (gzip) */
+ TIME, /* i: waiting for modification time (gzip) */
+ OS, /* i: waiting for extra flags and operating system (gzip) */
+ EXLEN, /* i: waiting for extra length (gzip) */
+ EXTRA, /* i: waiting for extra bytes (gzip) */
+ NAME, /* i: waiting for end of file name (gzip) */
+ COMMENT, /* i: waiting for end of comment (gzip) */
+ HCRC, /* i: waiting for header crc (gzip) */
+ DICTID, /* i: waiting for dictionary check value */
+ DICT, /* waiting for inflateSetDictionary() call */
+ TYPE, /* i: waiting for type bits, including last-flag bit */
+ TYPEDO, /* i: same, but skip check to exit inflate on new block */
+ STORED, /* i: waiting for stored size (length and complement) */
+ COPY_, /* i/o: same as COPY below, but only first time in */
+ COPY, /* i/o: waiting for input or output to copy stored block */
+ TABLE, /* i: waiting for dynamic block table lengths */
+ LENLENS, /* i: waiting for code length code lengths */
+ CODELENS, /* i: waiting for length/lit and distance code lengths */
+ LEN_, /* i: same as LEN below, but only first time in */
+ LEN, /* i: waiting for length/lit/eob code */
+ LENEXT, /* i: waiting for length extra bits */
+ DIST, /* i: waiting for distance code */
+ DISTEXT, /* i: waiting for distance extra bits */
+ MATCH, /* o: waiting for output space to copy string */
+ LIT, /* o: waiting for output space to write literal */
+ CHECK, /* i: waiting for 32-bit check value */
+ LENGTH, /* i: waiting for 32-bit length (gzip) */
+ DONE, /* finished check, done -- remain here until reset */
+ BAD, /* got a data error -- remain here until reset */
+ MEM, /* got an inflate() memory error -- remain here until reset */
+ SYNC /* looking for synchronization bytes to restart inflate() */
+} inflate_mode;
+
+/*
+ State transitions between above modes -
+
+ (most modes can go to BAD or MEM on error -- not shown for clarity)
+
+ Process header:
+ HEAD -> (gzip) or (zlib) or (raw)
+ (gzip) -> FLAGS -> TIME -> OS -> EXLEN -> EXTRA -> NAME -> COMMENT ->
+ HCRC -> TYPE
+ (zlib) -> DICTID or TYPE
+ DICTID -> DICT -> TYPE
+ (raw) -> TYPEDO
+ Read deflate blocks:
+ TYPE -> TYPEDO -> STORED or TABLE or LEN_ or CHECK
+ STORED -> COPY_ -> COPY -> TYPE
+ TABLE -> LENLENS -> CODELENS -> LEN_
+ LEN_ -> LEN
+ Read deflate codes in fixed or dynamic block:
+ LEN -> LENEXT or LIT or TYPE
+ LENEXT -> DIST -> DISTEXT -> MATCH -> LEN
+ LIT -> LEN
+ Process trailer:
+ CHECK -> LENGTH -> DONE
+ */
+
+/* state maintained between inflate() calls. Approximately 10K bytes. */
+struct inflate_state {
+ inflate_mode mode; /* current inflate mode */
+ int last; /* true if processing last block */
+ int wrap; /* bit 0 true for zlib, bit 1 true for gzip */
+ int havedict; /* true if dictionary provided */
+ int flags; /* gzip header method and flags (0 if zlib) */
+ unsigned dmax; /* zlib header max distance (INFLATE_STRICT) */
+ unsigned long check; /* protected copy of check value */
+ unsigned long total; /* protected copy of output count */
+ gz_headerp head; /* where to save gzip header information */
+ /* sliding window */
+ unsigned wbits; /* log base 2 of requested window size */
+ unsigned wsize; /* window size or zero if not using window */
+ unsigned whave; /* valid bytes in the window */
+ unsigned wnext; /* window write index */
+ unsigned char FAR *window; /* allocated sliding window, if needed */
+ /* bit accumulator */
+ unsigned long hold; /* input bit accumulator */
+ unsigned bits; /* number of bits in "in" */
+ /* for string and stored block copying */
+ unsigned length; /* literal or length of data to copy */
+ unsigned offset; /* distance back to copy string from */
+ /* for table and code decoding */
+ unsigned extra; /* extra bits needed */
+ /* fixed and dynamic code tables */
+ code const FAR *lencode; /* starting table for length/literal codes */
+ code const FAR *distcode; /* starting table for distance codes */
+ unsigned lenbits; /* index bits for lencode */
+ unsigned distbits; /* index bits for distcode */
+ /* dynamic table building */
+ unsigned ncode; /* number of code length code lengths */
+ unsigned nlen; /* number of length code lengths */
+ unsigned ndist; /* number of distance code lengths */
+ unsigned have; /* number of code lengths in lens[] */
+ code FAR *next; /* next available space in codes[] */
+ unsigned short lens[320]; /* temporary storage for code lengths */
+ unsigned short work[288]; /* work area for code table building */
+ code codes[ENOUGH]; /* space for code tables */
+ int sane; /* if false, allow invalid distance too far */
+ int back; /* bits back of last unprocessed length/lit */
+ unsigned was; /* initial length of match */
+};
diff --git a/test/monniaux/glpk-4.65/src/zlib/inftrees.c b/test/monniaux/glpk-4.65/src/zlib/inftrees.c
new file mode 100644
index 00000000..11e9c52a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inftrees.c
@@ -0,0 +1,330 @@
+/* inftrees.c -- generate Huffman trees for efficient decoding
+ * Copyright (C) 1995-2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+
+#define MAXBITS 15
+
+const char inflate_copyright[] =
+ " inflate 1.2.5 Copyright 1995-2010 Mark Adler ";
+/*
+ If you use the zlib library in a product, an acknowledgment is welcome
+ in the documentation of your product. If for some reason you cannot
+ include such an acknowledgment, I would appreciate that you keep this
+ copyright string in the executable of your product.
+ */
+
+/*
+ Build a set of tables to decode the provided canonical Huffman code.
+ The code lengths are lens[0..codes-1]. The result starts at *table,
+ whose indices are 0..2^bits-1. work is a writable array of at least
+ lens shorts, which is used as a work area. type is the type of code
+ to be generated, CODES, LENS, or DISTS. On return, zero is success,
+ -1 is an invalid code, and +1 means that ENOUGH isn't enough. table
+ on return points to the next available entry's address. bits is the
+ requested root table index bits, and on return it is the actual root
+ table index bits. It will differ if the request is greater than the
+ longest code or if it is less than the shortest code.
+ */
+int ZLIB_INTERNAL inflate_table(type, lens, codes, table, bits, work)
+codetype type;
+unsigned short FAR *lens;
+unsigned codes;
+code FAR * FAR *table;
+unsigned FAR *bits;
+unsigned short FAR *work;
+{
+ unsigned len; /* a code's length in bits */
+ unsigned sym; /* index of code symbols */
+ unsigned min, max; /* minimum and maximum code lengths */
+ unsigned root; /* number of index bits for root table */
+ unsigned curr; /* number of index bits for current table */
+ unsigned drop; /* code bits to drop for sub-table */
+ int left; /* number of prefix codes available */
+ unsigned used; /* code entries in table used */
+ unsigned huff; /* Huffman code */
+ unsigned incr; /* for incrementing code, index */
+ unsigned fill; /* index for replicating entries */
+ unsigned low; /* low bits for current root entry */
+ unsigned mask; /* mask for low root bits */
+ code here; /* table entry for duplication */
+ code FAR *next; /* next available space in table */
+ const unsigned short FAR *base; /* base value table to use */
+ const unsigned short FAR *extra; /* extra bits table to use */
+ int end; /* use base and extra for symbol > end */
+ unsigned short count[MAXBITS+1]; /* number of codes of each length */
+ unsigned short offs[MAXBITS+1]; /* offsets in table for each length */
+ static const unsigned short lbase[31] = { /* Length codes 257..285 base */
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
+ 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0};
+ static const unsigned short lext[31] = { /* Length codes 257..285 extra */
+ 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18,
+ 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 73, 195};
+ static const unsigned short dbase[32] = { /* Distance codes 0..29 base */
+ 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
+ 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
+ 8193, 12289, 16385, 24577, 0, 0};
+ static const unsigned short dext[32] = { /* Distance codes 0..29 extra */
+ 16, 16, 16, 16, 17, 17, 18, 18, 19, 19, 20, 20, 21, 21, 22, 22,
+ 23, 23, 24, 24, 25, 25, 26, 26, 27, 27,
+ 28, 28, 29, 29, 64, 64};
+
+ /*
+ Process a set of code lengths to create a canonical Huffman code. The
+ code lengths are lens[0..codes-1]. Each length corresponds to the
+ symbols 0..codes-1. The Huffman code is generated by first sorting the
+ symbols by length from short to long, and retaining the symbol order
+ for codes with equal lengths. Then the code starts with all zero bits
+ for the first code of the shortest length, and the codes are integer
+ increments for the same length, and zeros are appended as the length
+ increases. For the deflate format, these bits are stored backwards
+ from their more natural integer increment ordering, and so when the
+ decoding tables are built in the large loop below, the integer codes
+ are incremented backwards.
+
+ This routine assumes, but does not check, that all of the entries in
+ lens[] are in the range 0..MAXBITS. The caller must assure this.
+ 1..MAXBITS is interpreted as that code length. zero means that that
+ symbol does not occur in this code.
+
+ The codes are sorted by computing a count of codes for each length,
+ creating from that a table of starting indices for each length in the
+ sorted table, and then entering the symbols in order in the sorted
+ table. The sorted table is work[], with that space being provided by
+ the caller.
+
+ The length counts are used for other purposes as well, i.e. finding
+ the minimum and maximum length codes, determining if there are any
+ codes at all, checking for a valid set of lengths, and looking ahead
+ at length counts to determine sub-table sizes when building the
+ decoding tables.
+ */
+
+ /* accumulate lengths for codes (assumes lens[] all in 0..MAXBITS) */
+ for (len = 0; len <= MAXBITS; len++)
+ count[len] = 0;
+ for (sym = 0; sym < codes; sym++)
+ count[lens[sym]]++;
+
+ /* bound code lengths, force root to be within code lengths */
+ root = *bits;
+ for (max = MAXBITS; max >= 1; max--)
+ if (count[max] != 0) break;
+ if (root > max) root = max;
+ if (max == 0) { /* no symbols to code at all */
+ here.op = (unsigned char)64; /* invalid code marker */
+ here.bits = (unsigned char)1;
+ here.val = (unsigned short)0;
+ *(*table)++ = here; /* make a table to force an error */
+ *(*table)++ = here;
+ *bits = 1;
+ return 0; /* no symbols, but wait for decoding to report error */
+ }
+ for (min = 1; min < max; min++)
+ if (count[min] != 0) break;
+ if (root < min) root = min;
+
+ /* check for an over-subscribed or incomplete set of lengths */
+ left = 1;
+ for (len = 1; len <= MAXBITS; len++) {
+ left <<= 1;
+ left -= count[len];
+ if (left < 0) return -1; /* over-subscribed */
+ }
+ if (left > 0 && (type == CODES || max != 1))
+ return -1; /* incomplete set */
+
+ /* generate offsets into symbol table for each length for sorting */
+ offs[1] = 0;
+ for (len = 1; len < MAXBITS; len++)
+ offs[len + 1] = offs[len] + count[len];
+
+ /* sort symbols by length, by symbol order within each length */
+ for (sym = 0; sym < codes; sym++)
+ if (lens[sym] != 0) work[offs[lens[sym]]++] = (unsigned short)sym;
+
+ /*
+ Create and fill in decoding tables. In this loop, the table being
+ filled is at next and has curr index bits. The code being used is huff
+ with length len. That code is converted to an index by dropping drop
+ bits off of the bottom. For codes where len is less than drop + curr,
+ those top drop + curr - len bits are incremented through all values to
+ fill the table with replicated entries.
+
+ root is the number of index bits for the root table. When len exceeds
+ root, sub-tables are created pointed to by the root entry with an index
+ of the low root bits of huff. This is saved in low to check for when a
+ new sub-table should be started. drop is zero when the root table is
+ being filled, and drop is root when sub-tables are being filled.
+
+ When a new sub-table is needed, it is necessary to look ahead in the
+ code lengths to determine what size sub-table is needed. The length
+ counts are used for this, and so count[] is decremented as codes are
+ entered in the tables.
+
+ used keeps track of how many table entries have been allocated from the
+ provided *table space. It is checked for LENS and DIST tables against
+ the constants ENOUGH_LENS and ENOUGH_DISTS to guard against changes in
+ the initial root table size constants. See the comments in inftrees.h
+ for more information.
+
+ sym increments through all symbols, and the loop terminates when
+ all codes of length max, i.e. all codes, have been processed. This
+ routine permits incomplete codes, so another loop after this one fills
+ in the rest of the decoding tables with invalid code markers.
+ */
+
+ /* set up for code type */
+ switch (type) {
+ case CODES:
+ base = extra = work; /* dummy value--not used */
+ end = 19;
+ break;
+ case LENS:
+ base = lbase;
+ base -= 257;
+ extra = lext;
+ extra -= 257;
+ end = 256;
+ break;
+ default: /* DISTS */
+ base = dbase;
+ extra = dext;
+ end = -1;
+ }
+
+ /* initialize state for loop */
+ huff = 0; /* starting code */
+ sym = 0; /* starting code symbol */
+ len = min; /* starting code length */
+ next = *table; /* current table to fill in */
+ curr = root; /* current table index bits */
+ drop = 0; /* current bits to drop from code for index */
+ low = (unsigned)(-1); /* trigger new sub-table when len > root */
+ used = 1U << root; /* use root table entries */
+ mask = used - 1; /* mask for comparing low */
+
+ /* check available table space */
+ if ((type == LENS && used >= ENOUGH_LENS) ||
+ (type == DISTS && used >= ENOUGH_DISTS))
+ return 1;
+
+ /* process all codes and make table entries */
+ for (;;) {
+ /* create table entry */
+ here.bits = (unsigned char)(len - drop);
+ if ((int)(work[sym]) < end) {
+ here.op = (unsigned char)0;
+ here.val = work[sym];
+ }
+ else if ((int)(work[sym]) > end) {
+ here.op = (unsigned char)(extra[work[sym]]);
+ here.val = base[work[sym]];
+ }
+ else {
+ here.op = (unsigned char)(32 + 64); /* end of block */
+ here.val = 0;
+ }
+
+ /* replicate for those indices with low len bits equal to huff */
+ incr = 1U << (len - drop);
+ fill = 1U << curr;
+ min = fill; /* save offset to next table */
+ do {
+ fill -= incr;
+ next[(huff >> drop) + fill] = here;
+ } while (fill != 0);
+
+ /* backwards increment the len-bit code huff */
+ incr = 1U << (len - 1);
+ while (huff & incr)
+ incr >>= 1;
+ if (incr != 0) {
+ huff &= incr - 1;
+ huff += incr;
+ }
+ else
+ huff = 0;
+
+ /* go to next symbol, update count, len */
+ sym++;
+ if (--(count[len]) == 0) {
+ if (len == max) break;
+ len = lens[work[sym]];
+ }
+
+ /* create new sub-table if needed */
+ if (len > root && (huff & mask) != low) {
+ /* if first time, transition to sub-tables */
+ if (drop == 0)
+ drop = root;
+
+ /* increment past last table */
+ next += min; /* here min is 1 << curr */
+
+ /* determine length of next table */
+ curr = len - drop;
+ left = (int)(1 << curr);
+ while (curr + drop < max) {
+ left -= count[curr + drop];
+ if (left <= 0) break;
+ curr++;
+ left <<= 1;
+ }
+
+ /* check for enough space */
+ used += 1U << curr;
+ if ((type == LENS && used >= ENOUGH_LENS) ||
+ (type == DISTS && used >= ENOUGH_DISTS))
+ return 1;
+
+ /* point entry in root table to sub-table */
+ low = huff & mask;
+ (*table)[low].op = (unsigned char)curr;
+ (*table)[low].bits = (unsigned char)root;
+ (*table)[low].val = (unsigned short)(next - *table);
+ }
+ }
+
+ /*
+ Fill in rest of table for incomplete codes. This loop is similar to the
+ loop above in incrementing huff for table indices. It is assumed that
+ len is equal to curr + drop, so there is no loop needed to increment
+ through high index bits. When the current sub-table is filled, the loop
+ drops back to the root table to fill in any remaining entries there.
+ */
+ here.op = (unsigned char)64; /* invalid code marker */
+ here.bits = (unsigned char)(len - drop);
+ here.val = (unsigned short)0;
+ while (huff != 0) {
+ /* when done with sub-table, drop back to root table */
+ if (drop != 0 && (huff & mask) != low) {
+ drop = 0;
+ len = root;
+ next = *table;
+ here.bits = (unsigned char)len;
+ }
+
+ /* put invalid code marker in table */
+ next[huff >> drop] = here;
+
+ /* backwards increment the len-bit code huff */
+ incr = 1U << (len - 1);
+ while (huff & incr)
+ incr >>= 1;
+ if (incr != 0) {
+ huff &= incr - 1;
+ huff += incr;
+ }
+ else
+ huff = 0;
+ }
+
+ /* set return parameters */
+ *table += used;
+ *bits = root;
+ return 0;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/inftrees.h b/test/monniaux/glpk-4.65/src/zlib/inftrees.h
new file mode 100644
index 00000000..baa53a0b
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/inftrees.h
@@ -0,0 +1,62 @@
+/* inftrees.h -- header to use inftrees.c
+ * Copyright (C) 1995-2005, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* Structure for decoding tables. Each entry provides either the
+ information needed to do the operation requested by the code that
+ indexed that table entry, or it provides a pointer to another
+ table that indexes more bits of the code. op indicates whether
+ the entry is a pointer to another table, a literal, a length or
+ distance, an end-of-block, or an invalid code. For a table
+ pointer, the low four bits of op is the number of index bits of
+ that table. For a length or distance, the low four bits of op
+ is the number of extra bits to get after the code. bits is
+ the number of bits in this code or part of the code to drop off
+ of the bit buffer. val is the actual byte to output in the case
+ of a literal, the base length or distance, or the offset from
+ the current table to the next table. Each entry is four bytes. */
+typedef struct {
+ unsigned char op; /* operation, extra bits, table bits */
+ unsigned char bits; /* bits in this part of the code */
+ unsigned short val; /* offset in table or code value */
+} code;
+
+/* op values as set by inflate_table():
+ 00000000 - literal
+ 0000tttt - table link, tttt != 0 is the number of table index bits
+ 0001eeee - length or distance, eeee is the number of extra bits
+ 01100000 - end of block
+ 01000000 - invalid code
+ */
+
+/* Maximum size of the dynamic table. The maximum number of code structures is
+ 1444, which is the sum of 852 for literal/length codes and 592 for distance
+ codes. These values were found by exhaustive searches using the program
+ examples/enough.c found in the zlib distribtution. The arguments to that
+ program are the number of symbols, the initial root table size, and the
+ maximum bit length of a code. "enough 286 9 15" for literal/length codes
+ returns returns 852, and "enough 30 6 15" for distance codes returns 592.
+ The initial root table size (9 or 6) is found in the fifth argument of the
+ inflate_table() calls in inflate.c and infback.c. If the root table size is
+ changed, then these maximum sizes would be need to be recalculated and
+ updated. */
+#define ENOUGH_LENS 852
+#define ENOUGH_DISTS 592
+#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS)
+
+/* Type of code to build for inflate_table() */
+typedef enum {
+ CODES,
+ LENS,
+ DISTS
+} codetype;
+
+int ZLIB_INTERNAL inflate_table OF((codetype type, unsigned short FAR *lens,
+ unsigned codes, code FAR * FAR *table,
+ unsigned FAR *bits, unsigned short FAR *work));
diff --git a/test/monniaux/glpk-4.65/src/zlib/trees.c b/test/monniaux/glpk-4.65/src/zlib/trees.c
new file mode 100644
index 00000000..56e9bb1c
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/trees.c
@@ -0,0 +1,1244 @@
+/* trees.c -- output deflated data using Huffman coding
+ * Copyright (C) 1995-2010 Jean-loup Gailly
+ * detect_data_type() function provided freely by Cosmin Truta, 2006
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * ALGORITHM
+ *
+ * The "deflation" process uses several Huffman trees. The more
+ * common source values are represented by shorter bit sequences.
+ *
+ * Each code tree is stored in a compressed form which is itself
+ * a Huffman encoding of the lengths of all the code strings (in
+ * ascending order by source values). The actual code strings are
+ * reconstructed from the lengths in the inflate process, as described
+ * in the deflate specification.
+ *
+ * REFERENCES
+ *
+ * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
+ * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
+ *
+ * Storer, James A.
+ * Data Compression: Methods and Theory, pp. 49-50.
+ * Computer Science Press, 1988. ISBN 0-7167-8156-5.
+ *
+ * Sedgewick, R.
+ * Algorithms, p290.
+ * Addison-Wesley, 1983. ISBN 0-201-06672-6.
+ */
+
+/* @(#) $Id$ */
+
+/* #define GEN_TREES_H */
+
+#include "deflate.h"
+
+#ifdef DEBUG
+# include <ctype.h>
+#endif
+
+/* ===========================================================================
+ * Constants
+ */
+
+#define MAX_BL_BITS 7
+/* Bit length codes must not exceed MAX_BL_BITS bits */
+
+#define END_BLOCK 256
+/* end of block literal code */
+
+#define REP_3_6 16
+/* repeat previous bit length 3-6 times (2 bits of repeat count) */
+
+#define REPZ_3_10 17
+/* repeat a zero length 3-10 times (3 bits of repeat count) */
+
+#define REPZ_11_138 18
+/* repeat a zero length 11-138 times (7 bits of repeat count) */
+
+local const int extra_lbits[LENGTH_CODES] /* extra bits for each length code */
+ = {0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0};
+
+local const int extra_dbits[D_CODES] /* extra bits for each distance code */
+ = {0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13};
+
+local const int extra_blbits[BL_CODES]/* extra bits for each bit length code */
+ = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7};
+
+local const uch bl_order[BL_CODES]
+ = {16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15};
+/* The lengths of the bit length codes are sent in order of decreasing
+ * probability, to avoid transmitting the lengths for unused bit length codes.
+ */
+
+#define Buf_size (8 * 2*sizeof(char))
+/* Number of bits used within bi_buf. (bi_buf might be implemented on
+ * more than 16 bits on some systems.)
+ */
+
+/* ===========================================================================
+ * Local data. These are initialized only once.
+ */
+
+#define DIST_CODE_LEN 512 /* see definition of array dist_code below */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+/* non ANSI compilers may not accept trees.h */
+
+local ct_data static_ltree[L_CODES+2];
+/* The static literal tree. Since the bit lengths are imposed, there is no
+ * need for the L_CODES extra codes used during heap construction. However
+ * The codes 286 and 287 are needed to build a canonical tree (see _tr_init
+ * below).
+ */
+
+local ct_data static_dtree[D_CODES];
+/* The static distance tree. (Actually a trivial tree since all codes use
+ * 5 bits.)
+ */
+
+uch _dist_code[DIST_CODE_LEN];
+/* Distance codes. The first 256 values correspond to the distances
+ * 3 .. 258, the last 256 values correspond to the top 8 bits of
+ * the 15 bit distances.
+ */
+
+uch _length_code[MAX_MATCH-MIN_MATCH+1];
+/* length code for each normalized match length (0 == MIN_MATCH) */
+
+local int base_length[LENGTH_CODES];
+/* First normalized length for each code (0 = MIN_MATCH) */
+
+local int base_dist[D_CODES];
+/* First normalized distance for each code (0 = distance of 1) */
+
+#else
+# include "trees.h"
+#endif /* GEN_TREES_H */
+
+struct static_tree_desc_s {
+ const ct_data *static_tree; /* static tree or NULL */
+ const intf *extra_bits; /* extra bits for each code or NULL */
+ int extra_base; /* base index for extra_bits */
+ int elems; /* max number of elements in the tree */
+ int max_length; /* max bit length for the codes */
+};
+
+local static_tree_desc static_l_desc =
+{static_ltree, extra_lbits, LITERALS+1, L_CODES, MAX_BITS};
+
+local static_tree_desc static_d_desc =
+{static_dtree, extra_dbits, 0, D_CODES, MAX_BITS};
+
+local static_tree_desc static_bl_desc =
+{(const ct_data *)0, extra_blbits, 0, BL_CODES, MAX_BL_BITS};
+
+/* ===========================================================================
+ * Local (static) routines in this file.
+ */
+
+local void tr_static_init OF((void));
+local void init_block OF((deflate_state *s));
+local void pqdownheap OF((deflate_state *s, ct_data *tree, int k));
+local void gen_bitlen OF((deflate_state *s, tree_desc *desc));
+local void gen_codes OF((ct_data *tree, int max_code, ushf *bl_count));
+local void build_tree OF((deflate_state *s, tree_desc *desc));
+local void scan_tree OF((deflate_state *s, ct_data *tree, int max_code));
+local void send_tree OF((deflate_state *s, ct_data *tree, int max_code));
+local int build_bl_tree OF((deflate_state *s));
+local void send_all_trees OF((deflate_state *s, int lcodes, int dcodes,
+ int blcodes));
+local void compress_block OF((deflate_state *s, ct_data *ltree,
+ ct_data *dtree));
+local int detect_data_type OF((deflate_state *s));
+local unsigned bi_reverse OF((unsigned value, int length));
+local void bi_windup OF((deflate_state *s));
+local void bi_flush OF((deflate_state *s));
+local void copy_block OF((deflate_state *s, charf *buf, unsigned len,
+ int header));
+
+#ifdef GEN_TREES_H
+local void gen_trees_header OF((void));
+#endif
+
+#ifndef DEBUG
+# define send_code(s, c, tree) send_bits(s, tree[c].Code, tree[c].Len)
+ /* Send a code of the given tree. c and tree must not have side effects */
+
+#else /* DEBUG */
+# define send_code(s, c, tree) \
+ { if (z_verbose>2) fprintf(stderr,"\ncd %3d ",(c)); \
+ send_bits(s, tree[c].Code, tree[c].Len); }
+#endif
+
+/* ===========================================================================
+ * Output a short LSB first on the stream.
+ * IN assertion: there is enough room in pendingBuf.
+ */
+#define put_short(s, w) { \
+ put_byte(s, (uch)((w) & 0xff)); \
+ put_byte(s, (uch)((ush)(w) >> 8)); \
+}
+
+/* ===========================================================================
+ * Send a value on a given number of bits.
+ * IN assertion: length <= 16 and value fits in length bits.
+ */
+#ifdef DEBUG
+local void send_bits OF((deflate_state *s, int value, int length));
+
+local void send_bits(s, value, length)
+ deflate_state *s;
+ int value; /* value to send */
+ int length; /* number of bits */
+{
+ Tracevv((stderr," l %2d v %4x ", length, value));
+ Assert(length > 0 && length <= 15, "invalid length");
+ s->bits_sent += (ulg)length;
+
+ /* If not enough room in bi_buf, use (valid) bits from bi_buf and
+ * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
+ * unused bits in value.
+ */
+ if (s->bi_valid > (int)Buf_size - length) {
+ s->bi_buf |= (ush)value << s->bi_valid;
+ put_short(s, s->bi_buf);
+ s->bi_buf = (ush)value >> (Buf_size - s->bi_valid);
+ s->bi_valid += length - Buf_size;
+ } else {
+ s->bi_buf |= (ush)value << s->bi_valid;
+ s->bi_valid += length;
+ }
+}
+#else /* !DEBUG */
+
+#define send_bits(s, value, length) \
+{ int len = length;\
+ if (s->bi_valid > (int)Buf_size - len) {\
+ int val = value;\
+ s->bi_buf |= (ush)val << s->bi_valid;\
+ put_short(s, s->bi_buf);\
+ s->bi_buf = (ush)val >> (Buf_size - s->bi_valid);\
+ s->bi_valid += len - Buf_size;\
+ } else {\
+ s->bi_buf |= (ush)(value) << s->bi_valid;\
+ s->bi_valid += len;\
+ }\
+}
+#endif /* DEBUG */
+
+
+/* the arguments must not have side effects */
+
+/* ===========================================================================
+ * Initialize the various 'constant' tables.
+ */
+local void tr_static_init()
+{
+#if defined(GEN_TREES_H) || !defined(STDC)
+ static int static_init_done = 0;
+ int n; /* iterates over tree elements */
+ int bits; /* bit counter */
+ int length; /* length value */
+ int code; /* code value */
+ int dist; /* distance index */
+ ush bl_count[MAX_BITS+1];
+ /* number of codes at each bit length for an optimal tree */
+
+ if (static_init_done) return;
+
+ /* For some embedded targets, global variables are not initialized: */
+#ifdef NO_INIT_GLOBAL_POINTERS
+ static_l_desc.static_tree = static_ltree;
+ static_l_desc.extra_bits = extra_lbits;
+ static_d_desc.static_tree = static_dtree;
+ static_d_desc.extra_bits = extra_dbits;
+ static_bl_desc.extra_bits = extra_blbits;
+#endif
+
+ /* Initialize the mapping length (0..255) -> length code (0..28) */
+ length = 0;
+ for (code = 0; code < LENGTH_CODES-1; code++) {
+ base_length[code] = length;
+ for (n = 0; n < (1<<extra_lbits[code]); n++) {
+ _length_code[length++] = (uch)code;
+ }
+ }
+ Assert (length == 256, "tr_static_init: length != 256");
+ /* Note that the length 255 (match length 258) can be represented
+ * in two different ways: code 284 + 5 bits or code 285, so we
+ * overwrite length_code[255] to use the best encoding:
+ */
+ _length_code[length-1] = (uch)code;
+
+ /* Initialize the mapping dist (0..32K) -> dist code (0..29) */
+ dist = 0;
+ for (code = 0 ; code < 16; code++) {
+ base_dist[code] = dist;
+ for (n = 0; n < (1<<extra_dbits[code]); n++) {
+ _dist_code[dist++] = (uch)code;
+ }
+ }
+ Assert (dist == 256, "tr_static_init: dist != 256");
+ dist >>= 7; /* from now on, all distances are divided by 128 */
+ for ( ; code < D_CODES; code++) {
+ base_dist[code] = dist << 7;
+ for (n = 0; n < (1<<(extra_dbits[code]-7)); n++) {
+ _dist_code[256 + dist++] = (uch)code;
+ }
+ }
+ Assert (dist == 256, "tr_static_init: 256+dist != 512");
+
+ /* Construct the codes of the static literal tree */
+ for (bits = 0; bits <= MAX_BITS; bits++) bl_count[bits] = 0;
+ n = 0;
+ while (n <= 143) static_ltree[n++].Len = 8, bl_count[8]++;
+ while (n <= 255) static_ltree[n++].Len = 9, bl_count[9]++;
+ while (n <= 279) static_ltree[n++].Len = 7, bl_count[7]++;
+ while (n <= 287) static_ltree[n++].Len = 8, bl_count[8]++;
+ /* Codes 286 and 287 do not exist, but we must include them in the
+ * tree construction to get a canonical Huffman tree (longest code
+ * all ones)
+ */
+ gen_codes((ct_data *)static_ltree, L_CODES+1, bl_count);
+
+ /* The static distance tree is trivial: */
+ for (n = 0; n < D_CODES; n++) {
+ static_dtree[n].Len = 5;
+ static_dtree[n].Code = bi_reverse((unsigned)n, 5);
+ }
+ static_init_done = 1;
+
+# ifdef GEN_TREES_H
+ gen_trees_header();
+# endif
+#endif /* defined(GEN_TREES_H) || !defined(STDC) */
+}
+
+/* ===========================================================================
+ * Genererate the file trees.h describing the static trees.
+ */
+#ifdef GEN_TREES_H
+# ifndef DEBUG
+# include <stdio.h>
+# endif
+
+# define SEPARATOR(i, last, width) \
+ ((i) == (last)? "\n};\n\n" : \
+ ((i) % (width) == (width)-1 ? ",\n" : ", "))
+
+void gen_trees_header()
+{
+ FILE *header = fopen("trees.h", "w");
+ int i;
+
+ Assert (header != NULL, "Can't open trees.h");
+ fprintf(header,
+ "/* header created automatically with -DGEN_TREES_H */\n\n");
+
+ fprintf(header, "local const ct_data static_ltree[L_CODES+2] = {\n");
+ for (i = 0; i < L_CODES+2; i++) {
+ fprintf(header, "{{%3u},{%3u}}%s", static_ltree[i].Code,
+ static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
+ }
+
+ fprintf(header, "local const ct_data static_dtree[D_CODES] = {\n");
+ for (i = 0; i < D_CODES; i++) {
+ fprintf(header, "{{%2u},{%2u}}%s", static_dtree[i].Code,
+ static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
+ }
+
+ fprintf(header, "const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {\n");
+ for (i = 0; i < DIST_CODE_LEN; i++) {
+ fprintf(header, "%2u%s", _dist_code[i],
+ SEPARATOR(i, DIST_CODE_LEN-1, 20));
+ }
+
+ fprintf(header,
+ "const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {\n");
+ for (i = 0; i < MAX_MATCH-MIN_MATCH+1; i++) {
+ fprintf(header, "%2u%s", _length_code[i],
+ SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
+ }
+
+ fprintf(header, "local const int base_length[LENGTH_CODES] = {\n");
+ for (i = 0; i < LENGTH_CODES; i++) {
+ fprintf(header, "%1u%s", base_length[i],
+ SEPARATOR(i, LENGTH_CODES-1, 20));
+ }
+
+ fprintf(header, "local const int base_dist[D_CODES] = {\n");
+ for (i = 0; i < D_CODES; i++) {
+ fprintf(header, "%5u%s", base_dist[i],
+ SEPARATOR(i, D_CODES-1, 10));
+ }
+
+ fclose(header);
+}
+#endif /* GEN_TREES_H */
+
+/* ===========================================================================
+ * Initialize the tree data structures for a new zlib stream.
+ */
+void ZLIB_INTERNAL _tr_init(s)
+ deflate_state *s;
+{
+ tr_static_init();
+
+ s->l_desc.dyn_tree = s->dyn_ltree;
+ s->l_desc.stat_desc = &static_l_desc;
+
+ s->d_desc.dyn_tree = s->dyn_dtree;
+ s->d_desc.stat_desc = &static_d_desc;
+
+ s->bl_desc.dyn_tree = s->bl_tree;
+ s->bl_desc.stat_desc = &static_bl_desc;
+
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+ s->last_eob_len = 8; /* enough lookahead for inflate */
+#ifdef DEBUG
+ s->compressed_len = 0L;
+ s->bits_sent = 0L;
+#endif
+
+ /* Initialize the first block of the first file: */
+ init_block(s);
+}
+
+/* ===========================================================================
+ * Initialize a new block.
+ */
+local void init_block(s)
+ deflate_state *s;
+{
+ int n; /* iterates over tree elements */
+
+ /* Initialize the trees. */
+ for (n = 0; n < L_CODES; n++) s->dyn_ltree[n].Freq = 0;
+ for (n = 0; n < D_CODES; n++) s->dyn_dtree[n].Freq = 0;
+ for (n = 0; n < BL_CODES; n++) s->bl_tree[n].Freq = 0;
+
+ s->dyn_ltree[END_BLOCK].Freq = 1;
+ s->opt_len = s->static_len = 0L;
+ s->last_lit = s->matches = 0;
+}
+
+#define SMALLEST 1
+/* Index within the heap array of least frequent node in the Huffman tree */
+
+
+/* ===========================================================================
+ * Remove the smallest element from the heap and recreate the heap with
+ * one less element. Updates heap and heap_len.
+ */
+#define pqremove(s, tree, top) \
+{\
+ top = s->heap[SMALLEST]; \
+ s->heap[SMALLEST] = s->heap[s->heap_len--]; \
+ pqdownheap(s, tree, SMALLEST); \
+}
+
+/* ===========================================================================
+ * Compares to subtrees, using the tree depth as tie breaker when
+ * the subtrees have equal frequency. This minimizes the worst case length.
+ */
+#define smaller(tree, n, m, depth) \
+ (tree[n].Freq < tree[m].Freq || \
+ (tree[n].Freq == tree[m].Freq && depth[n] <= depth[m]))
+
+/* ===========================================================================
+ * Restore the heap property by moving down the tree starting at node k,
+ * exchanging a node with the smallest of its two sons if necessary, stopping
+ * when the heap property is re-established (each father smaller than its
+ * two sons).
+ */
+local void pqdownheap(s, tree, k)
+ deflate_state *s;
+ ct_data *tree; /* the tree to restore */
+ int k; /* node to move down */
+{
+ int v = s->heap[k];
+ int j = k << 1; /* left son of k */
+ while (j <= s->heap_len) {
+ /* Set j to the smallest of the two sons: */
+ if (j < s->heap_len &&
+ smaller(tree, s->heap[j+1], s->heap[j], s->depth)) {
+ j++;
+ }
+ /* Exit if v is smaller than both sons */
+ if (smaller(tree, v, s->heap[j], s->depth)) break;
+
+ /* Exchange v with the smallest son */
+ s->heap[k] = s->heap[j]; k = j;
+
+ /* And continue down the tree, setting j to the left son of k */
+ j <<= 1;
+ }
+ s->heap[k] = v;
+}
+
+/* ===========================================================================
+ * Compute the optimal bit lengths for a tree and update the total bit length
+ * for the current block.
+ * IN assertion: the fields freq and dad are set, heap[heap_max] and
+ * above are the tree nodes sorted by increasing frequency.
+ * OUT assertions: the field len is set to the optimal bit length, the
+ * array bl_count contains the frequencies for each bit length.
+ * The length opt_len is updated; static_len is also updated if stree is
+ * not null.
+ */
+local void gen_bitlen(s, desc)
+ deflate_state *s;
+ tree_desc *desc; /* the tree descriptor */
+{
+ ct_data *tree = desc->dyn_tree;
+ int max_code = desc->max_code;
+ const ct_data *stree = desc->stat_desc->static_tree;
+ const intf *extra = desc->stat_desc->extra_bits;
+ int base = desc->stat_desc->extra_base;
+ int max_length = desc->stat_desc->max_length;
+ int h; /* heap index */
+ int n, m; /* iterate over the tree elements */
+ int bits; /* bit length */
+ int xbits; /* extra bits */
+ ush f; /* frequency */
+ int overflow = 0; /* number of elements with bit length too large */
+
+ for (bits = 0; bits <= MAX_BITS; bits++) s->bl_count[bits] = 0;
+
+ /* In a first pass, compute the optimal bit lengths (which may
+ * overflow in the case of the bit length tree).
+ */
+ tree[s->heap[s->heap_max]].Len = 0; /* root of the heap */
+
+ for (h = s->heap_max+1; h < HEAP_SIZE; h++) {
+ n = s->heap[h];
+ bits = tree[tree[n].Dad].Len + 1;
+ if (bits > max_length) bits = max_length, overflow++;
+ tree[n].Len = (ush)bits;
+ /* We overwrite tree[n].Dad which is no longer needed */
+
+ if (n > max_code) continue; /* not a leaf node */
+
+ s->bl_count[bits]++;
+ xbits = 0;
+ if (n >= base) xbits = extra[n-base];
+ f = tree[n].Freq;
+ s->opt_len += (ulg)f * (bits + xbits);
+ if (stree) s->static_len += (ulg)f * (stree[n].Len + xbits);
+ }
+ if (overflow == 0) return;
+
+ Trace((stderr,"\nbit length overflow\n"));
+ /* This happens for example on obj2 and pic of the Calgary corpus */
+
+ /* Find the first bit length which could increase: */
+ do {
+ bits = max_length-1;
+ while (s->bl_count[bits] == 0) bits--;
+ s->bl_count[bits]--; /* move one leaf down the tree */
+ s->bl_count[bits+1] += 2; /* move one overflow item as its brother */
+ s->bl_count[max_length]--;
+ /* The brother of the overflow item also moves one step up,
+ * but this does not affect bl_count[max_length]
+ */
+ overflow -= 2;
+ } while (overflow > 0);
+
+ /* Now recompute all bit lengths, scanning in increasing frequency.
+ * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
+ * lengths instead of fixing only the wrong ones. This idea is taken
+ * from 'ar' written by Haruhiko Okumura.)
+ */
+ for (bits = max_length; bits != 0; bits--) {
+ n = s->bl_count[bits];
+ while (n != 0) {
+ m = s->heap[--h];
+ if (m > max_code) continue;
+ if ((unsigned) tree[m].Len != (unsigned) bits) {
+ Trace((stderr,"code %d bits %d->%d\n", m, tree[m].Len, bits));
+ s->opt_len += ((long)bits - (long)tree[m].Len)
+ *(long)tree[m].Freq;
+ tree[m].Len = (ush)bits;
+ }
+ n--;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Generate the codes for a given tree and bit counts (which need not be
+ * optimal).
+ * IN assertion: the array bl_count contains the bit length statistics for
+ * the given tree and the field len is set for all tree elements.
+ * OUT assertion: the field code is set for all tree elements of non
+ * zero code length.
+ */
+local void gen_codes (tree, max_code, bl_count)
+ ct_data *tree; /* the tree to decorate */
+ int max_code; /* largest code with non zero frequency */
+ ushf *bl_count; /* number of codes at each bit length */
+{
+ ush next_code[MAX_BITS+1]; /* next code value for each bit length */
+ ush code = 0; /* running code value */
+ int bits; /* bit index */
+ int n; /* code index */
+
+ /* The distribution counts are first used to generate the code values
+ * without bit reversal.
+ */
+ for (bits = 1; bits <= MAX_BITS; bits++) {
+ next_code[bits] = code = (code + bl_count[bits-1]) << 1;
+ }
+ /* Check that the bit counts in bl_count are consistent. The last code
+ * must be all ones.
+ */
+ Assert (code + bl_count[MAX_BITS]-1 == (1<<MAX_BITS)-1,
+ "inconsistent bit counts");
+ Tracev((stderr,"\ngen_codes: max_code %d ", max_code));
+
+ for (n = 0; n <= max_code; n++) {
+ int len = tree[n].Len;
+ if (len == 0) continue;
+ /* Now reverse the bits */
+ tree[n].Code = bi_reverse(next_code[len]++, len);
+
+ Tracecv(tree != static_ltree, (stderr,"\nn %3d %c l %2d c %4x (%x) ",
+ n, (isgraph(n) ? n : ' '), len, tree[n].Code, next_code[len]-1));
+ }
+}
+
+/* ===========================================================================
+ * Construct one Huffman tree and assigns the code bit strings and lengths.
+ * Update the total bit length for the current block.
+ * IN assertion: the field freq is set for all tree elements.
+ * OUT assertions: the fields len and code are set to the optimal bit length
+ * and corresponding code. The length opt_len is updated; static_len is
+ * also updated if stree is not null. The field max_code is set.
+ */
+local void build_tree(s, desc)
+ deflate_state *s;
+ tree_desc *desc; /* the tree descriptor */
+{
+ ct_data *tree = desc->dyn_tree;
+ const ct_data *stree = desc->stat_desc->static_tree;
+ int elems = desc->stat_desc->elems;
+ int n, m; /* iterate over heap elements */
+ int max_code = -1; /* largest code with non zero frequency */
+ int node; /* new node being created */
+
+ /* Construct the initial heap, with least frequent element in
+ * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
+ * heap[0] is not used.
+ */
+ s->heap_len = 0, s->heap_max = HEAP_SIZE;
+
+ for (n = 0; n < elems; n++) {
+ if (tree[n].Freq != 0) {
+ s->heap[++(s->heap_len)] = max_code = n;
+ s->depth[n] = 0;
+ } else {
+ tree[n].Len = 0;
+ }
+ }
+
+ /* The pkzip format requires that at least one distance code exists,
+ * and that at least one bit should be sent even if there is only one
+ * possible code. So to avoid special checks later on we force at least
+ * two codes of non zero frequency.
+ */
+ while (s->heap_len < 2) {
+ node = s->heap[++(s->heap_len)] = (max_code < 2 ? ++max_code : 0);
+ tree[node].Freq = 1;
+ s->depth[node] = 0;
+ s->opt_len--; if (stree) s->static_len -= stree[node].Len;
+ /* node is 0 or 1 so it does not have extra bits */
+ }
+ desc->max_code = max_code;
+
+ /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
+ * establish sub-heaps of increasing lengths:
+ */
+ for (n = s->heap_len/2; n >= 1; n--) pqdownheap(s, tree, n);
+
+ /* Construct the Huffman tree by repeatedly combining the least two
+ * frequent nodes.
+ */
+ node = elems; /* next internal node of the tree */
+ do {
+ pqremove(s, tree, n); /* n = node of least frequency */
+ m = s->heap[SMALLEST]; /* m = node of next least frequency */
+
+ s->heap[--(s->heap_max)] = n; /* keep the nodes sorted by frequency */
+ s->heap[--(s->heap_max)] = m;
+
+ /* Create a new node father of n and m */
+ tree[node].Freq = tree[n].Freq + tree[m].Freq;
+ s->depth[node] = (uch)((s->depth[n] >= s->depth[m] ?
+ s->depth[n] : s->depth[m]) + 1);
+ tree[n].Dad = tree[m].Dad = (ush)node;
+#ifdef DUMP_BL_TREE
+ if (tree == s->bl_tree) {
+ fprintf(stderr,"\nnode %d(%d), sons %d(%d) %d(%d)",
+ node, tree[node].Freq, n, tree[n].Freq, m, tree[m].Freq);
+ }
+#endif
+ /* and insert the new node in the heap */
+ s->heap[SMALLEST] = node++;
+ pqdownheap(s, tree, SMALLEST);
+
+ } while (s->heap_len >= 2);
+
+ s->heap[--(s->heap_max)] = s->heap[SMALLEST];
+
+ /* At this point, the fields freq and dad are set. We can now
+ * generate the bit lengths.
+ */
+ gen_bitlen(s, (tree_desc *)desc);
+
+ /* The field len is now set, we can generate the bit codes */
+ gen_codes ((ct_data *)tree, max_code, s->bl_count);
+}
+
+/* ===========================================================================
+ * Scan a literal or distance tree to determine the frequencies of the codes
+ * in the bit length tree.
+ */
+local void scan_tree (s, tree, max_code)
+ deflate_state *s;
+ ct_data *tree; /* the tree to be scanned */
+ int max_code; /* and its largest code of non zero frequency */
+{
+ int n; /* iterates over all tree elements */
+ int prevlen = -1; /* last emitted length */
+ int curlen; /* length of current code */
+ int nextlen = tree[0].Len; /* length of next code */
+ int count = 0; /* repeat count of the current code */
+ int max_count = 7; /* max repeat count */
+ int min_count = 4; /* min repeat count */
+
+ if (nextlen == 0) max_count = 138, min_count = 3;
+ tree[max_code+1].Len = (ush)0xffff; /* guard */
+
+ for (n = 0; n <= max_code; n++) {
+ curlen = nextlen; nextlen = tree[n+1].Len;
+ if (++count < max_count && curlen == nextlen) {
+ continue;
+ } else if (count < min_count) {
+ s->bl_tree[curlen].Freq += count;
+ } else if (curlen != 0) {
+ if (curlen != prevlen) s->bl_tree[curlen].Freq++;
+ s->bl_tree[REP_3_6].Freq++;
+ } else if (count <= 10) {
+ s->bl_tree[REPZ_3_10].Freq++;
+ } else {
+ s->bl_tree[REPZ_11_138].Freq++;
+ }
+ count = 0; prevlen = curlen;
+ if (nextlen == 0) {
+ max_count = 138, min_count = 3;
+ } else if (curlen == nextlen) {
+ max_count = 6, min_count = 3;
+ } else {
+ max_count = 7, min_count = 4;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Send a literal or distance tree in compressed form, using the codes in
+ * bl_tree.
+ */
+local void send_tree (s, tree, max_code)
+ deflate_state *s;
+ ct_data *tree; /* the tree to be scanned */
+ int max_code; /* and its largest code of non zero frequency */
+{
+ int n; /* iterates over all tree elements */
+ int prevlen = -1; /* last emitted length */
+ int curlen; /* length of current code */
+ int nextlen = tree[0].Len; /* length of next code */
+ int count = 0; /* repeat count of the current code */
+ int max_count = 7; /* max repeat count */
+ int min_count = 4; /* min repeat count */
+
+ /* tree[max_code+1].Len = -1; */ /* guard already set */
+ if (nextlen == 0) max_count = 138, min_count = 3;
+
+ for (n = 0; n <= max_code; n++) {
+ curlen = nextlen; nextlen = tree[n+1].Len;
+ if (++count < max_count && curlen == nextlen) {
+ continue;
+ } else if (count < min_count) {
+ do { send_code(s, curlen, s->bl_tree); } while (--count != 0);
+
+ } else if (curlen != 0) {
+ if (curlen != prevlen) {
+ send_code(s, curlen, s->bl_tree); count--;
+ }
+ Assert(count >= 3 && count <= 6, " 3_6?");
+ send_code(s, REP_3_6, s->bl_tree); send_bits(s, count-3, 2);
+
+ } else if (count <= 10) {
+ send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count-3, 3);
+
+ } else {
+ send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count-11, 7);
+ }
+ count = 0; prevlen = curlen;
+ if (nextlen == 0) {
+ max_count = 138, min_count = 3;
+ } else if (curlen == nextlen) {
+ max_count = 6, min_count = 3;
+ } else {
+ max_count = 7, min_count = 4;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Construct the Huffman tree for the bit lengths and return the index in
+ * bl_order of the last bit length code to send.
+ */
+local int build_bl_tree(s)
+ deflate_state *s;
+{
+ int max_blindex; /* index of last bit length code of non zero freq */
+
+ /* Determine the bit length frequencies for literal and distance trees */
+ scan_tree(s, (ct_data *)s->dyn_ltree, s->l_desc.max_code);
+ scan_tree(s, (ct_data *)s->dyn_dtree, s->d_desc.max_code);
+
+ /* Build the bit length tree: */
+ build_tree(s, (tree_desc *)(&(s->bl_desc)));
+ /* opt_len now includes the length of the tree representations, except
+ * the lengths of the bit lengths codes and the 5+5+4 bits for the counts.
+ */
+
+ /* Determine the number of bit length codes to send. The pkzip format
+ * requires that at least 4 bit length codes be sent. (appnote.txt says
+ * 3 but the actual value used is 4.)
+ */
+ for (max_blindex = BL_CODES-1; max_blindex >= 3; max_blindex--) {
+ if (s->bl_tree[bl_order[max_blindex]].Len != 0) break;
+ }
+ /* Update opt_len to include the bit length tree and counts */
+ s->opt_len += 3*(max_blindex+1) + 5+5+4;
+ Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld",
+ s->opt_len, s->static_len));
+
+ return max_blindex;
+}
+
+/* ===========================================================================
+ * Send the header for a block using dynamic Huffman trees: the counts, the
+ * lengths of the bit length codes, the literal tree and the distance tree.
+ * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4.
+ */
+local void send_all_trees(s, lcodes, dcodes, blcodes)
+ deflate_state *s;
+ int lcodes, dcodes, blcodes; /* number of codes for each tree */
+{
+ int rank; /* index in bl_order */
+
+ Assert (lcodes >= 257 && dcodes >= 1 && blcodes >= 4, "not enough codes");
+ Assert (lcodes <= L_CODES && dcodes <= D_CODES && blcodes <= BL_CODES,
+ "too many codes");
+ Tracev((stderr, "\nbl counts: "));
+ send_bits(s, lcodes-257, 5); /* not +255 as stated in appnote.txt */
+ send_bits(s, dcodes-1, 5);
+ send_bits(s, blcodes-4, 4); /* not -3 as stated in appnote.txt */
+ for (rank = 0; rank < blcodes; rank++) {
+ Tracev((stderr, "\nbl code %2d ", bl_order[rank]));
+ send_bits(s, s->bl_tree[bl_order[rank]].Len, 3);
+ }
+ Tracev((stderr, "\nbl tree: sent %ld", s->bits_sent));
+
+ send_tree(s, (ct_data *)s->dyn_ltree, lcodes-1); /* literal tree */
+ Tracev((stderr, "\nlit tree: sent %ld", s->bits_sent));
+
+ send_tree(s, (ct_data *)s->dyn_dtree, dcodes-1); /* distance tree */
+ Tracev((stderr, "\ndist tree: sent %ld", s->bits_sent));
+}
+
+/* ===========================================================================
+ * Send a stored block
+ */
+void ZLIB_INTERNAL _tr_stored_block(s, buf, stored_len, last)
+ deflate_state *s;
+ charf *buf; /* input block */
+ ulg stored_len; /* length of input block */
+ int last; /* one if this is the last block for a file */
+{
+ send_bits(s, (STORED_BLOCK<<1)+last, 3); /* send block type */
+#ifdef DEBUG
+ s->compressed_len = (s->compressed_len + 3 + 7) & (ulg)~7L;
+ s->compressed_len += (stored_len + 4) << 3;
+#endif
+ copy_block(s, buf, (unsigned)stored_len, 1); /* with header */
+}
+
+/* ===========================================================================
+ * Send one empty static block to give enough lookahead for inflate.
+ * This takes 10 bits, of which 7 may remain in the bit buffer.
+ * The current inflate code requires 9 bits of lookahead. If the
+ * last two codes for the previous block (real code plus EOB) were coded
+ * on 5 bits or less, inflate may have only 5+3 bits of lookahead to decode
+ * the last real code. In this case we send two empty static blocks instead
+ * of one. (There are no problems if the previous block is stored or fixed.)
+ * To simplify the code, we assume the worst case of last real code encoded
+ * on one bit only.
+ */
+void ZLIB_INTERNAL _tr_align(s)
+ deflate_state *s;
+{
+ send_bits(s, STATIC_TREES<<1, 3);
+ send_code(s, END_BLOCK, static_ltree);
+#ifdef DEBUG
+ s->compressed_len += 10L; /* 3 for block type, 7 for EOB */
+#endif
+ bi_flush(s);
+ /* Of the 10 bits for the empty block, we have already sent
+ * (10 - bi_valid) bits. The lookahead for the last real code (before
+ * the EOB of the previous block) was thus at least one plus the length
+ * of the EOB plus what we have just sent of the empty static block.
+ */
+ if (1 + s->last_eob_len + 10 - s->bi_valid < 9) {
+ send_bits(s, STATIC_TREES<<1, 3);
+ send_code(s, END_BLOCK, static_ltree);
+#ifdef DEBUG
+ s->compressed_len += 10L;
+#endif
+ bi_flush(s);
+ }
+ s->last_eob_len = 7;
+}
+
+/* ===========================================================================
+ * Determine the best encoding for the current block: dynamic trees, static
+ * trees or store, and output the encoded block to the zip file.
+ */
+void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last)
+ deflate_state *s;
+ charf *buf; /* input block, or NULL if too old */
+ ulg stored_len; /* length of input block */
+ int last; /* one if this is the last block for a file */
+{
+ ulg opt_lenb, static_lenb; /* opt_len and static_len in bytes */
+ int max_blindex = 0; /* index of last bit length code of non zero freq */
+
+ /* Build the Huffman trees unless a stored block is forced */
+ if (s->level > 0) {
+
+ /* Check if the file is binary or text */
+ if (s->strm->data_type == Z_UNKNOWN)
+ s->strm->data_type = detect_data_type(s);
+
+ /* Construct the literal and distance trees */
+ build_tree(s, (tree_desc *)(&(s->l_desc)));
+ Tracev((stderr, "\nlit data: dyn %ld, stat %ld", s->opt_len,
+ s->static_len));
+
+ build_tree(s, (tree_desc *)(&(s->d_desc)));
+ Tracev((stderr, "\ndist data: dyn %ld, stat %ld", s->opt_len,
+ s->static_len));
+ /* At this point, opt_len and static_len are the total bit lengths of
+ * the compressed block data, excluding the tree representations.
+ */
+
+ /* Build the bit length tree for the above two trees, and get the index
+ * in bl_order of the last bit length code to send.
+ */
+ max_blindex = build_bl_tree(s);
+
+ /* Determine the best encoding. Compute the block lengths in bytes. */
+ opt_lenb = (s->opt_len+3+7)>>3;
+ static_lenb = (s->static_len+3+7)>>3;
+
+ Tracev((stderr, "\nopt %lu(%lu) stat %lu(%lu) stored %lu lit %u ",
+ opt_lenb, s->opt_len, static_lenb, s->static_len, stored_len,
+ s->last_lit));
+
+ if (static_lenb <= opt_lenb) opt_lenb = static_lenb;
+
+ } else {
+ Assert(buf != (char*)0, "lost buf");
+ opt_lenb = static_lenb = stored_len + 5; /* force a stored block */
+ }
+
+#ifdef FORCE_STORED
+ if (buf != (char*)0) { /* force stored block */
+#else
+ if (stored_len+4 <= opt_lenb && buf != (char*)0) {
+ /* 4: two words for the lengths */
+#endif
+ /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE.
+ * Otherwise we can't have processed more than WSIZE input bytes since
+ * the last block flush, because compression would have been
+ * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
+ * transform a block into a stored block.
+ */
+ _tr_stored_block(s, buf, stored_len, last);
+
+#ifdef FORCE_STATIC
+ } else if (static_lenb >= 0) { /* force static trees */
+#else
+ } else if (s->strategy == Z_FIXED || static_lenb == opt_lenb) {
+#endif
+ send_bits(s, (STATIC_TREES<<1)+last, 3);
+ compress_block(s, (ct_data *)static_ltree, (ct_data *)static_dtree);
+#ifdef DEBUG
+ s->compressed_len += 3 + s->static_len;
+#endif
+ } else {
+ send_bits(s, (DYN_TREES<<1)+last, 3);
+ send_all_trees(s, s->l_desc.max_code+1, s->d_desc.max_code+1,
+ max_blindex+1);
+ compress_block(s, (ct_data *)s->dyn_ltree, (ct_data *)s->dyn_dtree);
+#ifdef DEBUG
+ s->compressed_len += 3 + s->opt_len;
+#endif
+ }
+ Assert (s->compressed_len == s->bits_sent, "bad compressed size");
+ /* The above check is made mod 2^32, for files larger than 512 MB
+ * and uLong implemented on 32 bits.
+ */
+ init_block(s);
+
+ if (last) {
+ bi_windup(s);
+#ifdef DEBUG
+ s->compressed_len += 7; /* align on byte boundary */
+#endif
+ }
+ Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len>>3,
+ s->compressed_len-7*last));
+}
+
+/* ===========================================================================
+ * Save the match info and tally the frequency counts. Return true if
+ * the current block must be flushed.
+ */
+int ZLIB_INTERNAL _tr_tally (s, dist, lc)
+ deflate_state *s;
+ unsigned dist; /* distance of matched string */
+ unsigned lc; /* match length-MIN_MATCH or unmatched char (if dist==0) */
+{
+ s->d_buf[s->last_lit] = (ush)dist;
+ s->l_buf[s->last_lit++] = (uch)lc;
+ if (dist == 0) {
+ /* lc is the unmatched char */
+ s->dyn_ltree[lc].Freq++;
+ } else {
+ s->matches++;
+ /* Here, lc is the match length - MIN_MATCH */
+ dist--; /* dist = match distance - 1 */
+ Assert((ush)dist < (ush)MAX_DIST(s) &&
+ (ush)lc <= (ush)(MAX_MATCH-MIN_MATCH) &&
+ (ush)d_code(dist) < (ush)D_CODES, "_tr_tally: bad match");
+
+ s->dyn_ltree[_length_code[lc]+LITERALS+1].Freq++;
+ s->dyn_dtree[d_code(dist)].Freq++;
+ }
+
+#ifdef TRUNCATE_BLOCK
+ /* Try to guess if it is profitable to stop the current block here */
+ if ((s->last_lit & 0x1fff) == 0 && s->level > 2) {
+ /* Compute an upper bound for the compressed length */
+ ulg out_length = (ulg)s->last_lit*8L;
+ ulg in_length = (ulg)((long)s->strstart - s->block_start);
+ int dcode;
+ for (dcode = 0; dcode < D_CODES; dcode++) {
+ out_length += (ulg)s->dyn_dtree[dcode].Freq *
+ (5L+extra_dbits[dcode]);
+ }
+ out_length >>= 3;
+ Tracev((stderr,"\nlast_lit %u, in %ld, out ~%ld(%ld%%) ",
+ s->last_lit, in_length, out_length,
+ 100L - out_length*100L/in_length));
+ if (s->matches < s->last_lit/2 && out_length < in_length/2) return 1;
+ }
+#endif
+ return (s->last_lit == s->lit_bufsize-1);
+ /* We avoid equality with lit_bufsize because of wraparound at 64K
+ * on 16 bit machines and because stored blocks are restricted to
+ * 64K-1 bytes.
+ */
+}
+
+/* ===========================================================================
+ * Send the block data compressed using the given Huffman trees
+ */
+local void compress_block(s, ltree, dtree)
+ deflate_state *s;
+ ct_data *ltree; /* literal tree */
+ ct_data *dtree; /* distance tree */
+{
+ unsigned dist; /* distance of matched string */
+ int lc; /* match length or unmatched char (if dist == 0) */
+ unsigned lx = 0; /* running index in l_buf */
+ unsigned code; /* the code to send */
+ int extra; /* number of extra bits to send */
+
+ if (s->last_lit != 0) do {
+ dist = s->d_buf[lx];
+ lc = s->l_buf[lx++];
+ if (dist == 0) {
+ send_code(s, lc, ltree); /* send a literal byte */
+ Tracecv(isgraph(lc), (stderr," '%c' ", lc));
+ } else {
+ /* Here, lc is the match length - MIN_MATCH */
+ code = _length_code[lc];
+ send_code(s, code+LITERALS+1, ltree); /* send the length code */
+ extra = extra_lbits[code];
+ if (extra != 0) {
+ lc -= base_length[code];
+ send_bits(s, lc, extra); /* send the extra length bits */
+ }
+ dist--; /* dist is now the match distance - 1 */
+ code = d_code(dist);
+ Assert (code < D_CODES, "bad d_code");
+
+ send_code(s, code, dtree); /* send the distance code */
+ extra = extra_dbits[code];
+ if (extra != 0) {
+ dist -= base_dist[code];
+ send_bits(s, dist, extra); /* send the extra distance bits */
+ }
+ } /* literal or match pair ? */
+
+ /* Check that the overlay between pending_buf and d_buf+l_buf is ok: */
+ Assert((uInt)(s->pending) < s->lit_bufsize + 2*lx,
+ "pendingBuf overflow");
+
+ } while (lx < s->last_lit);
+
+ send_code(s, END_BLOCK, ltree);
+ s->last_eob_len = ltree[END_BLOCK].Len;
+}
+
+/* ===========================================================================
+ * Check if the data type is TEXT or BINARY, using the following algorithm:
+ * - TEXT if the two conditions below are satisfied:
+ * a) There are no non-portable control characters belonging to the
+ * "black list" (0..6, 14..25, 28..31).
+ * b) There is at least one printable character belonging to the
+ * "white list" (9 {TAB}, 10 {LF}, 13 {CR}, 32..255).
+ * - BINARY otherwise.
+ * - The following partially-portable control characters form a
+ * "gray list" that is ignored in this detection algorithm:
+ * (7 {BEL}, 8 {BS}, 11 {VT}, 12 {FF}, 26 {SUB}, 27 {ESC}).
+ * IN assertion: the fields Freq of dyn_ltree are set.
+ */
+local int detect_data_type(s)
+ deflate_state *s;
+{
+ /* black_mask is the bit mask of black-listed bytes
+ * set bits 0..6, 14..25, and 28..31
+ * 0xf3ffc07f = binary 11110011111111111100000001111111
+ */
+ unsigned long black_mask = 0xf3ffc07fUL;
+ int n;
+
+ /* Check for non-textual ("black-listed") bytes. */
+ for (n = 0; n <= 31; n++, black_mask >>= 1)
+ if ((black_mask & 1) && (s->dyn_ltree[n].Freq != 0))
+ return Z_BINARY;
+
+ /* Check for textual ("white-listed") bytes. */
+ if (s->dyn_ltree[9].Freq != 0 || s->dyn_ltree[10].Freq != 0
+ || s->dyn_ltree[13].Freq != 0)
+ return Z_TEXT;
+ for (n = 32; n < LITERALS; n++)
+ if (s->dyn_ltree[n].Freq != 0)
+ return Z_TEXT;
+
+ /* There are no "black-listed" or "white-listed" bytes:
+ * this stream either is empty or has tolerated ("gray-listed") bytes only.
+ */
+ return Z_BINARY;
+}
+
+/* ===========================================================================
+ * Reverse the first len bits of a code, using straightforward code (a faster
+ * method would use a table)
+ * IN assertion: 1 <= len <= 15
+ */
+local unsigned bi_reverse(code, len)
+ unsigned code; /* the value to invert */
+ int len; /* its bit length */
+{
+ register unsigned res = 0;
+ do {
+ res |= code & 1;
+ code >>= 1, res <<= 1;
+ } while (--len > 0);
+ return res >> 1;
+}
+
+/* ===========================================================================
+ * Flush the bit buffer, keeping at most 7 bits in it.
+ */
+local void bi_flush(s)
+ deflate_state *s;
+{
+ if (s->bi_valid == 16) {
+ put_short(s, s->bi_buf);
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+ } else if (s->bi_valid >= 8) {
+ put_byte(s, (Byte)s->bi_buf);
+ s->bi_buf >>= 8;
+ s->bi_valid -= 8;
+ }
+}
+
+/* ===========================================================================
+ * Flush the bit buffer and align the output on a byte boundary
+ */
+local void bi_windup(s)
+ deflate_state *s;
+{
+ if (s->bi_valid > 8) {
+ put_short(s, s->bi_buf);
+ } else if (s->bi_valid > 0) {
+ put_byte(s, (Byte)s->bi_buf);
+ }
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+#ifdef DEBUG
+ s->bits_sent = (s->bits_sent+7) & ~7;
+#endif
+}
+
+/* ===========================================================================
+ * Copy a stored block, storing first the length and its
+ * one's complement if requested.
+ */
+local void copy_block(s, buf, len, header)
+ deflate_state *s;
+ charf *buf; /* the input data */
+ unsigned len; /* its length */
+ int header; /* true if block header must be written */
+{
+ bi_windup(s); /* align on byte boundary */
+ s->last_eob_len = 8; /* enough lookahead for inflate */
+
+ if (header) {
+ put_short(s, (ush)len);
+ put_short(s, (ush)~len);
+#ifdef DEBUG
+ s->bits_sent += 2*16;
+#endif
+ }
+#ifdef DEBUG
+ s->bits_sent += (ulg)len<<3;
+#endif
+ while (len--) {
+ put_byte(s, *buf++);
+ }
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/trees.h b/test/monniaux/glpk-4.65/src/zlib/trees.h
new file mode 100644
index 00000000..d35639d8
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/trees.h
@@ -0,0 +1,128 @@
+/* header created automatically with -DGEN_TREES_H */
+
+local const ct_data static_ltree[L_CODES+2] = {
+{{ 12},{ 8}}, {{140},{ 8}}, {{ 76},{ 8}}, {{204},{ 8}}, {{ 44},{ 8}},
+{{172},{ 8}}, {{108},{ 8}}, {{236},{ 8}}, {{ 28},{ 8}}, {{156},{ 8}},
+{{ 92},{ 8}}, {{220},{ 8}}, {{ 60},{ 8}}, {{188},{ 8}}, {{124},{ 8}},
+{{252},{ 8}}, {{ 2},{ 8}}, {{130},{ 8}}, {{ 66},{ 8}}, {{194},{ 8}},
+{{ 34},{ 8}}, {{162},{ 8}}, {{ 98},{ 8}}, {{226},{ 8}}, {{ 18},{ 8}},
+{{146},{ 8}}, {{ 82},{ 8}}, {{210},{ 8}}, {{ 50},{ 8}}, {{178},{ 8}},
+{{114},{ 8}}, {{242},{ 8}}, {{ 10},{ 8}}, {{138},{ 8}}, {{ 74},{ 8}},
+{{202},{ 8}}, {{ 42},{ 8}}, {{170},{ 8}}, {{106},{ 8}}, {{234},{ 8}},
+{{ 26},{ 8}}, {{154},{ 8}}, {{ 90},{ 8}}, {{218},{ 8}}, {{ 58},{ 8}},
+{{186},{ 8}}, {{122},{ 8}}, {{250},{ 8}}, {{ 6},{ 8}}, {{134},{ 8}},
+{{ 70},{ 8}}, {{198},{ 8}}, {{ 38},{ 8}}, {{166},{ 8}}, {{102},{ 8}},
+{{230},{ 8}}, {{ 22},{ 8}}, {{150},{ 8}}, {{ 86},{ 8}}, {{214},{ 8}},
+{{ 54},{ 8}}, {{182},{ 8}}, {{118},{ 8}}, {{246},{ 8}}, {{ 14},{ 8}},
+{{142},{ 8}}, {{ 78},{ 8}}, {{206},{ 8}}, {{ 46},{ 8}}, {{174},{ 8}},
+{{110},{ 8}}, {{238},{ 8}}, {{ 30},{ 8}}, {{158},{ 8}}, {{ 94},{ 8}},
+{{222},{ 8}}, {{ 62},{ 8}}, {{190},{ 8}}, {{126},{ 8}}, {{254},{ 8}},
+{{ 1},{ 8}}, {{129},{ 8}}, {{ 65},{ 8}}, {{193},{ 8}}, {{ 33},{ 8}},
+{{161},{ 8}}, {{ 97},{ 8}}, {{225},{ 8}}, {{ 17},{ 8}}, {{145},{ 8}},
+{{ 81},{ 8}}, {{209},{ 8}}, {{ 49},{ 8}}, {{177},{ 8}}, {{113},{ 8}},
+{{241},{ 8}}, {{ 9},{ 8}}, {{137},{ 8}}, {{ 73},{ 8}}, {{201},{ 8}},
+{{ 41},{ 8}}, {{169},{ 8}}, {{105},{ 8}}, {{233},{ 8}}, {{ 25},{ 8}},
+{{153},{ 8}}, {{ 89},{ 8}}, {{217},{ 8}}, {{ 57},{ 8}}, {{185},{ 8}},
+{{121},{ 8}}, {{249},{ 8}}, {{ 5},{ 8}}, {{133},{ 8}}, {{ 69},{ 8}},
+{{197},{ 8}}, {{ 37},{ 8}}, {{165},{ 8}}, {{101},{ 8}}, {{229},{ 8}},
+{{ 21},{ 8}}, {{149},{ 8}}, {{ 85},{ 8}}, {{213},{ 8}}, {{ 53},{ 8}},
+{{181},{ 8}}, {{117},{ 8}}, {{245},{ 8}}, {{ 13},{ 8}}, {{141},{ 8}},
+{{ 77},{ 8}}, {{205},{ 8}}, {{ 45},{ 8}}, {{173},{ 8}}, {{109},{ 8}},
+{{237},{ 8}}, {{ 29},{ 8}}, {{157},{ 8}}, {{ 93},{ 8}}, {{221},{ 8}},
+{{ 61},{ 8}}, {{189},{ 8}}, {{125},{ 8}}, {{253},{ 8}}, {{ 19},{ 9}},
+{{275},{ 9}}, {{147},{ 9}}, {{403},{ 9}}, {{ 83},{ 9}}, {{339},{ 9}},
+{{211},{ 9}}, {{467},{ 9}}, {{ 51},{ 9}}, {{307},{ 9}}, {{179},{ 9}},
+{{435},{ 9}}, {{115},{ 9}}, {{371},{ 9}}, {{243},{ 9}}, {{499},{ 9}},
+{{ 11},{ 9}}, {{267},{ 9}}, {{139},{ 9}}, {{395},{ 9}}, {{ 75},{ 9}},
+{{331},{ 9}}, {{203},{ 9}}, {{459},{ 9}}, {{ 43},{ 9}}, {{299},{ 9}},
+{{171},{ 9}}, {{427},{ 9}}, {{107},{ 9}}, {{363},{ 9}}, {{235},{ 9}},
+{{491},{ 9}}, {{ 27},{ 9}}, {{283},{ 9}}, {{155},{ 9}}, {{411},{ 9}},
+{{ 91},{ 9}}, {{347},{ 9}}, {{219},{ 9}}, {{475},{ 9}}, {{ 59},{ 9}},
+{{315},{ 9}}, {{187},{ 9}}, {{443},{ 9}}, {{123},{ 9}}, {{379},{ 9}},
+{{251},{ 9}}, {{507},{ 9}}, {{ 7},{ 9}}, {{263},{ 9}}, {{135},{ 9}},
+{{391},{ 9}}, {{ 71},{ 9}}, {{327},{ 9}}, {{199},{ 9}}, {{455},{ 9}},
+{{ 39},{ 9}}, {{295},{ 9}}, {{167},{ 9}}, {{423},{ 9}}, {{103},{ 9}},
+{{359},{ 9}}, {{231},{ 9}}, {{487},{ 9}}, {{ 23},{ 9}}, {{279},{ 9}},
+{{151},{ 9}}, {{407},{ 9}}, {{ 87},{ 9}}, {{343},{ 9}}, {{215},{ 9}},
+{{471},{ 9}}, {{ 55},{ 9}}, {{311},{ 9}}, {{183},{ 9}}, {{439},{ 9}},
+{{119},{ 9}}, {{375},{ 9}}, {{247},{ 9}}, {{503},{ 9}}, {{ 15},{ 9}},
+{{271},{ 9}}, {{143},{ 9}}, {{399},{ 9}}, {{ 79},{ 9}}, {{335},{ 9}},
+{{207},{ 9}}, {{463},{ 9}}, {{ 47},{ 9}}, {{303},{ 9}}, {{175},{ 9}},
+{{431},{ 9}}, {{111},{ 9}}, {{367},{ 9}}, {{239},{ 9}}, {{495},{ 9}},
+{{ 31},{ 9}}, {{287},{ 9}}, {{159},{ 9}}, {{415},{ 9}}, {{ 95},{ 9}},
+{{351},{ 9}}, {{223},{ 9}}, {{479},{ 9}}, {{ 63},{ 9}}, {{319},{ 9}},
+{{191},{ 9}}, {{447},{ 9}}, {{127},{ 9}}, {{383},{ 9}}, {{255},{ 9}},
+{{511},{ 9}}, {{ 0},{ 7}}, {{ 64},{ 7}}, {{ 32},{ 7}}, {{ 96},{ 7}},
+{{ 16},{ 7}}, {{ 80},{ 7}}, {{ 48},{ 7}}, {{112},{ 7}}, {{ 8},{ 7}},
+{{ 72},{ 7}}, {{ 40},{ 7}}, {{104},{ 7}}, {{ 24},{ 7}}, {{ 88},{ 7}},
+{{ 56},{ 7}}, {{120},{ 7}}, {{ 4},{ 7}}, {{ 68},{ 7}}, {{ 36},{ 7}},
+{{100},{ 7}}, {{ 20},{ 7}}, {{ 84},{ 7}}, {{ 52},{ 7}}, {{116},{ 7}},
+{{ 3},{ 8}}, {{131},{ 8}}, {{ 67},{ 8}}, {{195},{ 8}}, {{ 35},{ 8}},
+{{163},{ 8}}, {{ 99},{ 8}}, {{227},{ 8}}
+};
+
+local const ct_data static_dtree[D_CODES] = {
+{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}},
+{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}},
+{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}},
+{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}},
+{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}},
+{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}}
+};
+
+const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {
+ 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
+ 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,
+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,
+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
+};
+
+const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,
+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
+};
+
+local const int base_length[LENGTH_CODES] = {
+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
+64, 80, 96, 112, 128, 160, 192, 224, 0
+};
+
+local const int base_dist[D_CODES] = {
+ 0, 1, 2, 3, 4, 6, 8, 12, 16, 24,
+ 32, 48, 64, 96, 128, 192, 256, 384, 512, 768,
+ 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576
+};
+
diff --git a/test/monniaux/glpk-4.65/src/zlib/uncompr.c b/test/monniaux/glpk-4.65/src/zlib/uncompr.c
new file mode 100644
index 00000000..ad98be3a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/uncompr.c
@@ -0,0 +1,59 @@
+/* uncompr.c -- decompress a memory buffer
+ * Copyright (C) 1995-2003, 2010 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#define ZLIB_INTERNAL
+#include "zlib.h"
+
+/* ===========================================================================
+ Decompresses the source buffer into the destination buffer. sourceLen is
+ the byte length of the source buffer. Upon entry, destLen is the total
+ size of the destination buffer, which must be large enough to hold the
+ entire uncompressed data. (The size of the uncompressed data must have
+ been saved previously by the compressor and transmitted to the decompressor
+ by some mechanism outside the scope of this compression library.)
+ Upon exit, destLen is the actual size of the compressed buffer.
+
+ uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_BUF_ERROR if there was not enough room in the output
+ buffer, or Z_DATA_ERROR if the input data was corrupted.
+*/
+int ZEXPORT uncompress (dest, destLen, source, sourceLen)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+{
+ z_stream stream;
+ int err;
+
+ stream.next_in = (Bytef*)source;
+ stream.avail_in = (uInt)sourceLen;
+ /* Check for source > 64K on 16-bit machine: */
+ if ((uLong)stream.avail_in != sourceLen) return Z_BUF_ERROR;
+
+ stream.next_out = dest;
+ stream.avail_out = (uInt)*destLen;
+ if ((uLong)stream.avail_out != *destLen) return Z_BUF_ERROR;
+
+ stream.zalloc = (alloc_func)0;
+ stream.zfree = (free_func)0;
+
+ err = inflateInit(&stream);
+ if (err != Z_OK) return err;
+
+ err = inflate(&stream, Z_FINISH);
+ if (err != Z_STREAM_END) {
+ inflateEnd(&stream);
+ if (err == Z_NEED_DICT || (err == Z_BUF_ERROR && stream.avail_in == 0))
+ return Z_DATA_ERROR;
+ return err;
+ }
+ *destLen = stream.total_out;
+
+ err = inflateEnd(&stream);
+ return err;
+}
diff --git a/test/monniaux/glpk-4.65/src/zlib/zconf.h b/test/monniaux/glpk-4.65/src/zlib/zconf.h
new file mode 100644
index 00000000..af6a4f0f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zconf.h
@@ -0,0 +1,168 @@
+/* zconf.h (configuration of the zlib compression library) */
+
+/* Modified by Andrew Makhorin <mao@gnu.org>, April 2011 */
+
+/* Copyright (C) 1995-2010 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in
+ * zlib.h */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h. */
+
+#ifndef ZCONF_H
+#define ZCONF_H
+
+/* (file adler32.c) */
+#define adler32 _glp_zlib_adler32
+#define adler32_combine _glp_zlib_adler32_combine
+#define adler32_combine64 _glp_zlib_adler32_combine64
+
+/* (file compress.c) */
+#define compress2 _glp_zlib_compress2
+#define compress _glp_zlib_compress
+#define compressBound _glp_zlib_compressBound
+
+/* (file crc32.c) */
+#define get_crc_table _glp_zlib_get_crc_table
+#define crc32 _glp_zlib_crc32
+#define crc32_combine _glp_zlib_crc32_combine
+#define crc32_combine64 _glp_zlib_crc32_combine64
+
+/* (file deflate.c) */
+#define deflateInit_ _glp_zlib_deflateInit_
+#define deflateInit2_ _glp_zlib_deflateInit2_
+#define deflateSetDictionary _glp_zlib_deflateSetDictionary
+#define deflateReset _glp_zlib_deflateReset
+#define deflateSetHeader _glp_zlib_deflateSetHeader
+#define deflatePrime _glp_zlib_deflatePrime
+#define deflateParams _glp_zlib_deflateParams
+#define deflateTune _glp_zlib_deflateTune
+#define deflateBound _glp_zlib_deflateBound
+#define deflate _glp_zlib_deflate
+#define deflateEnd _glp_zlib_deflateEnd
+#define deflateCopy _glp_zlib_deflateCopy
+#define deflate_copyright _glp_zlib_deflate_copyright
+
+/* (file gzclose.c) */
+#define gzclose _glp_zlib_gzclose
+
+/* (file gzlib.c) */
+#define gzopen _glp_zlib_gzopen
+#define gzopen64 _glp_zlib_gzopen64
+#define gzdopen _glp_zlib_gzdopen
+#define gzbuffer _glp_zlib_gzbuffer
+#define gzrewind _glp_zlib_gzrewind
+#define gzseek64 _glp_zlib_gzseek64
+#define gzseek _glp_zlib_gzseek
+#define gztell64 _glp_zlib_gztell64
+#define gztell _glp_zlib_gztell
+#define gzoffset64 _glp_zlib_gzoffset64
+#define gzoffset _glp_zlib_gzoffset
+#define gzeof _glp_zlib_gzeof
+#define gzerror _glp_zlib_gzerror
+#define gzclearerr _glp_zlib_gzclearerr
+#define gz_error _glp_zlib_gz_error
+
+/* (file gzread.c) */
+#define gzread _glp_zlib_gzread
+#define gzgetc _glp_zlib_gzgetc
+#define gzungetc _glp_zlib_gzungetc
+#define gzgets _glp_zlib_gzgets
+#define gzdirect _glp_zlib_gzdirect
+#define gzclose_r _glp_zlib_gzclose_r
+
+/* (file gzwrite.c) */
+#define gzwrite _glp_zlib_gzwrite
+#define gzputc _glp_zlib_gzputc
+#define gzputs _glp_zlib_gzputs
+#define gzprintf _glp_zlib_gzprintf
+#define gzflush _glp_zlib_gzflush
+#define gzsetparams _glp_zlib_gzsetparams
+#define gzclose_w _glp_zlib_gzclose_w
+
+/* (file infback.c) */
+#define inflateBackInit_ _glp_zlib_inflateBackInit_
+#define inflateBack _glp_zlib_inflateBack
+#define inflateBackEnd _glp_zlib_inflateBackEnd
+
+/* (file inffast.c) */
+#define inflate_fast _glp_zlib_inflate_fast
+
+/* (file inflate.c) */
+#define inflateReset _glp_zlib_inflateReset
+#define inflateReset2 _glp_zlib_inflateReset2
+#define inflateInit2_ _glp_zlib_inflateInit2_
+#define inflateInit_ _glp_zlib_inflateInit_
+#define inflatePrime _glp_zlib_inflatePrime
+#define inflate _glp_zlib_inflate
+#define inflateEnd _glp_zlib_inflateEnd
+#define inflateSetDictionary _glp_zlib_inflateSetDictionary
+#define inflateGetHeader _glp_zlib_inflateGetHeader
+#define inflateSync _glp_zlib_inflateSync
+#define inflateSyncPoint _glp_zlib_inflateSyncPoint
+#define inflateCopy _glp_zlib_inflateCopy
+#define inflateUndermine _glp_zlib_inflateUndermine
+#define inflateMark _glp_zlib_inflateMark
+
+/* (file inftrees.c) */
+#define inflate_table _glp_zlib_inflate_table
+#define inflate_copyright _glp_zlib_inflate_copyright
+
+/* (file trees.c) */
+#define _tr_init _glp_zlib_tr_init
+#define _tr_stored_block _glp_zlib_tr_stored_block
+#define _tr_align _glp_zlib_tr_align
+#define _tr_flush_block _glp_zlib_tr_flush_block
+#define _tr_tally _glp_zlib_tr_tally
+#define _dist_code _glp_zlib_dist_code
+#define _length_code _glp_zlib_length_code
+
+/* (file uncompr.c) */
+#define uncompress _glp_zlib_uncompress
+
+/* (file zutil.c) */
+#define zlibVersion _glp_zlib_zlibVersion
+#define zlibCompileFlags _glp_zlib_zlibCompileFlags
+#define zError _glp_zlib_zError
+#define zcalloc _glp_zlib_zcalloc
+#define zcfree _glp_zlib_zcfree
+#define z_errmsg _glp_zlib_z_errmsg
+
+#define STDC 1
+
+#define MAX_MEM_LEVEL 9
+
+#define MAX_WBITS 15
+
+#define OF(args) args
+
+#define ZEXTERN extern
+#define ZEXPORT
+#define ZEXPORTVA
+
+#define FAR
+
+typedef unsigned char Byte;
+typedef unsigned int uInt;
+typedef unsigned long uLong;
+
+typedef Byte Bytef;
+typedef char charf;
+typedef int intf;
+typedef uInt uIntf;
+typedef uLong uLongf;
+
+typedef void const *voidpc;
+typedef void *voidpf;
+typedef void *voidp;
+
+#define z_off_t long
+
+#define z_off64_t z_off_t
+
+#define NO_vsnprintf 1
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/zlib/zio.c b/test/monniaux/glpk-4.65/src/zlib/zio.c
new file mode 100644
index 00000000..a55b258a
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zio.c
@@ -0,0 +1,92 @@
+/* zio.c (simulation of non-standard low-level i/o functions) */
+
+/* Written by Andrew Makhorin <mao@gnu.org>, April 2011
+ * For conditions of distribution and use, see copyright notice in
+ * zlib.h */
+
+/* (reserved for copyright notice) */
+
+#include <assert.h>
+#include <stdio.h>
+#include "zio.h"
+
+static FILE *file[FOPEN_MAX];
+static int initialized = 0;
+
+static void initialize(void)
+{ int fd;
+ assert(!initialized);
+ file[0] = stdin;
+ file[1] = stdout;
+ file[2] = stderr;
+ for (fd = 3; fd < FOPEN_MAX; fd++)
+ file[fd] = NULL;
+ initialized = 1;
+ return;
+}
+
+int open(const char *path, int oflag, ...)
+{ FILE *fp;
+ int fd;
+ if (!initialized) initialize();
+ /* see file gzlib.c, function gz_open */
+ if (oflag == O_RDONLY)
+ fp = fopen(path, "rb");
+ else if (oflag == (O_WRONLY | O_CREAT | O_TRUNC))
+ fp = fopen(path, "wb");
+ else if (oflag == (O_WRONLY | O_CREAT | O_APPEND))
+ fp = fopen(path, "ab");
+ else
+ assert(oflag != oflag);
+ if (fp == NULL)
+ return -1;
+ for (fd = 0; fd < FOPEN_MAX; fd++)
+ if (file[fd] == NULL) break;
+ assert(fd < FOPEN_MAX);
+ file[fd] = fp;
+ return fd;
+}
+
+long read(int fd, void *buf, unsigned long nbyte)
+{ unsigned long count;
+ if (!initialized) initialize();
+ assert(0 <= fd && fd < FOPEN_MAX);
+ assert(file[fd] != NULL);
+ count = fread(buf, 1, nbyte, file[fd]);
+ if (ferror(file[fd]))
+ return -1;
+ return count;
+}
+
+long write(int fd, const void *buf, unsigned long nbyte)
+{ unsigned long count;
+ if (!initialized) initialize();
+ assert(0 <= fd && fd < FOPEN_MAX);
+ assert(file[fd] != NULL);
+ count = fwrite(buf, 1, nbyte, file[fd]);
+ if (count != nbyte)
+ return -1;
+ if (fflush(file[fd]) != 0)
+ return -1;
+ return count;
+}
+
+long lseek(int fd, long offset, int whence)
+{ if (!initialized) initialize();
+ assert(0 <= fd && fd < FOPEN_MAX);
+ assert(file[fd] != NULL);
+ if (fseek(file[fd], offset, whence) != 0)
+ return -1;
+ return ftell(file[fd]);
+}
+
+int close(int fd)
+{ if (!initialized) initialize();
+ assert(0 <= fd && fd < FOPEN_MAX);
+ assert(file[fd] != NULL);
+ fclose(file[fd]);
+ file[fd] = NULL;
+ return 0;
+}
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/zlib/zio.h b/test/monniaux/glpk-4.65/src/zlib/zio.h
new file mode 100644
index 00000000..1626c4ae
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zio.h
@@ -0,0 +1,37 @@
+/* zio.h (simulation of non-standard low-level i/o functions) */
+
+/* Written by Andrew Makhorin <mao@gnu.org>, April 2011
+ * For conditions of distribution and use, see copyright notice in
+ * zlib.h */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h. */
+
+#ifndef ZIO_H
+#define ZIO_H
+
+#define O_RDONLY 0x00
+#define O_WRONLY 0x01
+#define O_CREAT 0x10
+#define O_TRUNC 0x20
+#define O_APPEND 0x30
+
+#define open _glp_zlib_open
+int open(const char *path, int oflag, ...);
+
+#define read _glp_zlib_read
+long read(int fd, void *buf, unsigned long nbyte);
+
+#define write _glp_zlib_write
+long write(int fd, const void *buf, unsigned long nbyte);
+
+#define lseek _glp_zlib_lseek
+long lseek(int fd, long offset, int whence);
+
+#define close _glp_zlib_close
+int close(int fd);
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/glpk-4.65/src/zlib/zlib.h b/test/monniaux/glpk-4.65/src/zlib/zlib.h
new file mode 100644
index 00000000..bfbba83e
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zlib.h
@@ -0,0 +1,1613 @@
+/* zlib.h -- interface of the 'zlib' general purpose compression library
+ version 1.2.5, April 19th, 2010
+
+ Copyright (C) 1995-2010 Jean-loup Gailly and Mark Adler
+
+ This software is provided 'as-is', without any express or implied
+ warranty. In no event will the authors be held liable for any damages
+ arising from the use of this software.
+
+ Permission is granted to anyone to use this software for any purpose,
+ including commercial applications, and to alter it and redistribute it
+ freely, subject to the following restrictions:
+
+ 1. The origin of this software must not be misrepresented; you must not
+ claim that you wrote the original software. If you use this software
+ in a product, an acknowledgment in the product documentation would be
+ appreciated but is not required.
+ 2. Altered source versions must be plainly marked as such, and must not be
+ misrepresented as being the original software.
+ 3. This notice may not be removed or altered from any source distribution.
+
+ Jean-loup Gailly Mark Adler
+ jloup@gzip.org madler@alumni.caltech.edu
+
+
+ The data format used by the zlib library is described by RFCs (Request for
+ Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt
+ (zlib format), rfc1951.txt (deflate format) and rfc1952.txt (gzip format).
+*/
+
+#ifndef ZLIB_H
+#define ZLIB_H
+
+#include "zconf.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define ZLIB_VERSION "1.2.5"
+#define ZLIB_VERNUM 0x1250
+#define ZLIB_VER_MAJOR 1
+#define ZLIB_VER_MINOR 2
+#define ZLIB_VER_REVISION 5
+#define ZLIB_VER_SUBREVISION 0
+
+/*
+ The 'zlib' compression library provides in-memory compression and
+ decompression functions, including integrity checks of the uncompressed data.
+ This version of the library supports only one compression method (deflation)
+ but other algorithms will be added later and will have the same stream
+ interface.
+
+ Compression can be done in a single step if the buffers are large enough,
+ or can be done by repeated calls of the compression function. In the latter
+ case, the application must provide more input and/or consume the output
+ (providing more output space) before each call.
+
+ The compressed data format used by default by the in-memory functions is
+ the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped
+ around a deflate stream, which is itself documented in RFC 1951.
+
+ The library also supports reading and writing files in gzip (.gz) format
+ with an interface similar to that of stdio using the functions that start
+ with "gz". The gzip format is different from the zlib format. gzip is a
+ gzip wrapper, documented in RFC 1952, wrapped around a deflate stream.
+
+ This library can optionally read and write gzip streams in memory as well.
+
+ The zlib format was designed to be compact and fast for use in memory
+ and on communications channels. The gzip format was designed for single-
+ file compression on file systems, has a larger header than zlib to maintain
+ directory information, and uses a different, slower check method than zlib.
+
+ The library does not install any signal handler. The decoder checks
+ the consistency of the compressed data, so the library should never crash
+ even in case of corrupted input.
+*/
+
+typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));
+typedef void (*free_func) OF((voidpf opaque, voidpf address));
+
+struct internal_state;
+
+typedef struct z_stream_s {
+ Bytef *next_in; /* next input byte */
+ uInt avail_in; /* number of bytes available at next_in */
+ uLong total_in; /* total nb of input bytes read so far */
+
+ Bytef *next_out; /* next output byte should be put there */
+ uInt avail_out; /* remaining free space at next_out */
+ uLong total_out; /* total nb of bytes output so far */
+
+ char *msg; /* last error message, NULL if no error */
+ struct internal_state FAR *state; /* not visible by applications */
+
+ alloc_func zalloc; /* used to allocate the internal state */
+ free_func zfree; /* used to free the internal state */
+ voidpf opaque; /* private data object passed to zalloc and zfree */
+
+ int data_type; /* best guess about the data type: binary or text */
+ uLong adler; /* adler32 value of the uncompressed data */
+ uLong reserved; /* reserved for future use */
+} z_stream;
+
+typedef z_stream FAR *z_streamp;
+
+/*
+ gzip header information passed to and from zlib routines. See RFC 1952
+ for more details on the meanings of these fields.
+*/
+typedef struct gz_header_s {
+ int text; /* true if compressed data believed to be text */
+ uLong time; /* modification time */
+ int xflags; /* extra flags (not used when writing a gzip file) */
+ int os; /* operating system */
+ Bytef *extra; /* pointer to extra field or Z_NULL if none */
+ uInt extra_len; /* extra field length (valid if extra != Z_NULL) */
+ uInt extra_max; /* space at extra (only when reading header) */
+ Bytef *name; /* pointer to zero-terminated file name or Z_NULL */
+ uInt name_max; /* space at name (only when reading header) */
+ Bytef *comment; /* pointer to zero-terminated comment or Z_NULL */
+ uInt comm_max; /* space at comment (only when reading header) */
+ int hcrc; /* true if there was or will be a header crc */
+ int done; /* true when done reading gzip header (not used
+ when writing a gzip file) */
+} gz_header;
+
+typedef gz_header FAR *gz_headerp;
+
+/*
+ The application must update next_in and avail_in when avail_in has dropped
+ to zero. It must update next_out and avail_out when avail_out has dropped
+ to zero. The application must initialize zalloc, zfree and opaque before
+ calling the init function. All other fields are set by the compression
+ library and must not be updated by the application.
+
+ The opaque value provided by the application will be passed as the first
+ parameter for calls of zalloc and zfree. This can be useful for custom
+ memory management. The compression library attaches no meaning to the
+ opaque value.
+
+ zalloc must return Z_NULL if there is not enough memory for the object.
+ If zlib is used in a multi-threaded application, zalloc and zfree must be
+ thread safe.
+
+ On 16-bit systems, the functions zalloc and zfree must be able to allocate
+ exactly 65536 bytes, but will not be required to allocate more than this if
+ the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, pointers
+ returned by zalloc for objects of exactly 65536 bytes *must* have their
+ offset normalized to zero. The default allocation function provided by this
+ library ensures this (see zutil.c). To reduce memory requirements and avoid
+ any allocation of 64K objects, at the expense of compression ratio, compile
+ the library with -DMAX_WBITS=14 (see zconf.h).
+
+ The fields total_in and total_out can be used for statistics or progress
+ reports. After compression, total_in holds the total size of the
+ uncompressed data and may be saved for use in the decompressor (particularly
+ if the decompressor wants to decompress everything in a single step).
+*/
+
+ /* constants */
+
+#define Z_NO_FLUSH 0
+#define Z_PARTIAL_FLUSH 1
+#define Z_SYNC_FLUSH 2
+#define Z_FULL_FLUSH 3
+#define Z_FINISH 4
+#define Z_BLOCK 5
+#define Z_TREES 6
+/* Allowed flush values; see deflate() and inflate() below for details */
+
+#define Z_OK 0
+#define Z_STREAM_END 1
+#define Z_NEED_DICT 2
+#define Z_ERRNO (-1)
+#define Z_STREAM_ERROR (-2)
+#define Z_DATA_ERROR (-3)
+#define Z_MEM_ERROR (-4)
+#define Z_BUF_ERROR (-5)
+#define Z_VERSION_ERROR (-6)
+/* Return codes for the compression/decompression functions. Negative values
+ * are errors, positive values are used for special but normal events.
+ */
+
+#define Z_NO_COMPRESSION 0
+#define Z_BEST_SPEED 1
+#define Z_BEST_COMPRESSION 9
+#define Z_DEFAULT_COMPRESSION (-1)
+/* compression levels */
+
+#define Z_FILTERED 1
+#define Z_HUFFMAN_ONLY 2
+#define Z_RLE 3
+#define Z_FIXED 4
+#define Z_DEFAULT_STRATEGY 0
+/* compression strategy; see deflateInit2() below for details */
+
+#define Z_BINARY 0
+#define Z_TEXT 1
+#define Z_ASCII Z_TEXT /* for compatibility with 1.2.2 and earlier */
+#define Z_UNKNOWN 2
+/* Possible values of the data_type field (though see inflate()) */
+
+#define Z_DEFLATED 8
+/* The deflate compression method (the only one supported in this version) */
+
+#define Z_NULL 0 /* for initializing zalloc, zfree, opaque */
+
+#define zlib_version zlibVersion()
+/* for compatibility with versions < 1.0.2 */
+
+
+ /* basic functions */
+
+ZEXTERN const char * ZEXPORT zlibVersion OF((void));
+/* The application can compare zlibVersion and ZLIB_VERSION for consistency.
+ If the first character differs, the library code actually used is not
+ compatible with the zlib.h header file used by the application. This check
+ is automatically made by deflateInit and inflateInit.
+ */
+
+/*
+ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level));
+
+ Initializes the internal stream state for compression. The fields
+ zalloc, zfree and opaque must be initialized before by the caller. If
+ zalloc and zfree are set to Z_NULL, deflateInit updates them to use default
+ allocation functions.
+
+ The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:
+ 1 gives best speed, 9 gives best compression, 0 gives no compression at all
+ (the input data is simply copied a block at a time). Z_DEFAULT_COMPRESSION
+ requests a default compromise between speed and compression (currently
+ equivalent to level 6).
+
+ deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_STREAM_ERROR if level is not a valid compression level, or
+ Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible
+ with the version assumed by the caller (ZLIB_VERSION). msg is set to null
+ if there is no error message. deflateInit does not perform any compression:
+ this will be done by deflate().
+*/
+
+
+ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));
+/*
+ deflate compresses as much data as possible, and stops when the input
+ buffer becomes empty or the output buffer becomes full. It may introduce
+ some output latency (reading input without producing any output) except when
+ forced to flush.
+
+ The detailed semantics are as follows. deflate performs one or both of the
+ following actions:
+
+ - Compress more input starting at next_in and update next_in and avail_in
+ accordingly. If not all input can be processed (because there is not
+ enough room in the output buffer), next_in and avail_in are updated and
+ processing will resume at this point for the next call of deflate().
+
+ - Provide more output starting at next_out and update next_out and avail_out
+ accordingly. This action is forced if the parameter flush is non zero.
+ Forcing flush frequently degrades the compression ratio, so this parameter
+ should be set only when necessary (in interactive applications). Some
+ output may be provided even if flush is not set.
+
+ Before the call of deflate(), the application should ensure that at least
+ one of the actions is possible, by providing more input and/or consuming more
+ output, and updating avail_in or avail_out accordingly; avail_out should
+ never be zero before the call. The application can consume the compressed
+ output when it wants, for example when the output buffer is full (avail_out
+ == 0), or after each call of deflate(). If deflate returns Z_OK and with
+ zero avail_out, it must be called again after making room in the output
+ buffer because there might be more output pending.
+
+ Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to
+ decide how much data to accumulate before producing output, in order to
+ maximize compression.
+
+ If the parameter flush is set to Z_SYNC_FLUSH, all pending output is
+ flushed to the output buffer and the output is aligned on a byte boundary, so
+ that the decompressor can get all input data available so far. (In
+ particular avail_in is zero after the call if enough output space has been
+ provided before the call.) Flushing may degrade compression for some
+ compression algorithms and so it should be used only when necessary. This
+ completes the current deflate block and follows it with an empty stored block
+ that is three bits plus filler bits to the next byte, followed by four bytes
+ (00 00 ff ff).
+
+ If flush is set to Z_PARTIAL_FLUSH, all pending output is flushed to the
+ output buffer, but the output is not aligned to a byte boundary. All of the
+ input data so far will be available to the decompressor, as for Z_SYNC_FLUSH.
+ This completes the current deflate block and follows it with an empty fixed
+ codes block that is 10 bits long. This assures that enough bytes are output
+ in order for the decompressor to finish the block before the empty fixed code
+ block.
+
+ If flush is set to Z_BLOCK, a deflate block is completed and emitted, as
+ for Z_SYNC_FLUSH, but the output is not aligned on a byte boundary, and up to
+ seven bits of the current block are held to be written as the next byte after
+ the next deflate block is completed. In this case, the decompressor may not
+ be provided enough bits at this point in order to complete decompression of
+ the data provided so far to the compressor. It may need to wait for the next
+ block to be emitted. This is for advanced applications that need to control
+ the emission of deflate blocks.
+
+ If flush is set to Z_FULL_FLUSH, all output is flushed as with
+ Z_SYNC_FLUSH, and the compression state is reset so that decompression can
+ restart from this point if previous compressed data has been damaged or if
+ random access is desired. Using Z_FULL_FLUSH too often can seriously degrade
+ compression.
+
+ If deflate returns with avail_out == 0, this function must be called again
+ with the same value of the flush parameter and more output space (updated
+ avail_out), until the flush is complete (deflate returns with non-zero
+ avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that
+ avail_out is greater than six to avoid repeated flush markers due to
+ avail_out == 0 on return.
+
+ If the parameter flush is set to Z_FINISH, pending input is processed,
+ pending output is flushed and deflate returns with Z_STREAM_END if there was
+ enough output space; if deflate returns with Z_OK, this function must be
+ called again with Z_FINISH and more output space (updated avail_out) but no
+ more input data, until it returns with Z_STREAM_END or an error. After
+ deflate has returned Z_STREAM_END, the only possible operations on the stream
+ are deflateReset or deflateEnd.
+
+ Z_FINISH can be used immediately after deflateInit if all the compression
+ is to be done in a single step. In this case, avail_out must be at least the
+ value returned by deflateBound (see below). If deflate does not return
+ Z_STREAM_END, then it must be called again as described above.
+
+ deflate() sets strm->adler to the adler32 checksum of all input read
+ so far (that is, total_in bytes).
+
+ deflate() may update strm->data_type if it can make a good guess about
+ the input data type (Z_BINARY or Z_TEXT). In doubt, the data is considered
+ binary. This field is only for information purposes and does not affect the
+ compression algorithm in any manner.
+
+ deflate() returns Z_OK if some progress has been made (more input
+ processed or more output produced), Z_STREAM_END if all input has been
+ consumed and all output has been produced (only when flush is set to
+ Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example
+ if next_in or next_out was Z_NULL), Z_BUF_ERROR if no progress is possible
+ (for example avail_in or avail_out was zero). Note that Z_BUF_ERROR is not
+ fatal, and deflate() can be called again with more input and more output
+ space to continue compressing.
+*/
+
+
+ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));
+/*
+ All dynamically allocated data structures for this stream are freed.
+ This function discards any unprocessed input and does not flush any pending
+ output.
+
+ deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the
+ stream state was inconsistent, Z_DATA_ERROR if the stream was freed
+ prematurely (some input or output was discarded). In the error case, msg
+ may be set but then points to a static string (which must not be
+ deallocated).
+*/
+
+
+/*
+ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm));
+
+ Initializes the internal stream state for decompression. The fields
+ next_in, avail_in, zalloc, zfree and opaque must be initialized before by
+ the caller. If next_in is not Z_NULL and avail_in is large enough (the
+ exact value depends on the compression method), inflateInit determines the
+ compression method from the zlib header and allocates all data structures
+ accordingly; otherwise the allocation will be deferred to the first call of
+ inflate. If zalloc and zfree are set to Z_NULL, inflateInit updates them to
+ use default allocation functions.
+
+ inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+ version assumed by the caller, or Z_STREAM_ERROR if the parameters are
+ invalid, such as a null pointer to the structure. msg is set to null if
+ there is no error message. inflateInit does not perform any decompression
+ apart from possibly reading the zlib header if present: actual decompression
+ will be done by inflate(). (So next_in and avail_in may be modified, but
+ next_out and avail_out are unused and unchanged.) The current implementation
+ of inflateInit() does not process any header information -- that is deferred
+ until inflate() is called.
+*/
+
+
+ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));
+/*
+ inflate decompresses as much data as possible, and stops when the input
+ buffer becomes empty or the output buffer becomes full. It may introduce
+ some output latency (reading input without producing any output) except when
+ forced to flush.
+
+ The detailed semantics are as follows. inflate performs one or both of the
+ following actions:
+
+ - Decompress more input starting at next_in and update next_in and avail_in
+ accordingly. If not all input can be processed (because there is not
+ enough room in the output buffer), next_in is updated and processing will
+ resume at this point for the next call of inflate().
+
+ - Provide more output starting at next_out and update next_out and avail_out
+ accordingly. inflate() provides as much output as possible, until there is
+ no more input data or no more space in the output buffer (see below about
+ the flush parameter).
+
+ Before the call of inflate(), the application should ensure that at least
+ one of the actions is possible, by providing more input and/or consuming more
+ output, and updating the next_* and avail_* values accordingly. The
+ application can consume the uncompressed output when it wants, for example
+ when the output buffer is full (avail_out == 0), or after each call of
+ inflate(). If inflate returns Z_OK and with zero avail_out, it must be
+ called again after making room in the output buffer because there might be
+ more output pending.
+
+ The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FINISH,
+ Z_BLOCK, or Z_TREES. Z_SYNC_FLUSH requests that inflate() flush as much
+ output as possible to the output buffer. Z_BLOCK requests that inflate()
+ stop if and when it gets to the next deflate block boundary. When decoding
+ the zlib or gzip format, this will cause inflate() to return immediately
+ after the header and before the first block. When doing a raw inflate,
+ inflate() will go ahead and process the first block, and will return when it
+ gets to the end of that block, or when it runs out of data.
+
+ The Z_BLOCK option assists in appending to or combining deflate streams.
+ Also to assist in this, on return inflate() will set strm->data_type to the
+ number of unused bits in the last byte taken from strm->next_in, plus 64 if
+ inflate() is currently decoding the last block in the deflate stream, plus
+ 128 if inflate() returned immediately after decoding an end-of-block code or
+ decoding the complete header up to just before the first byte of the deflate
+ stream. The end-of-block will not be indicated until all of the uncompressed
+ data from that block has been written to strm->next_out. The number of
+ unused bits may in general be greater than seven, except when bit 7 of
+ data_type is set, in which case the number of unused bits will be less than
+ eight. data_type is set as noted here every time inflate() returns for all
+ flush options, and so can be used to determine the amount of currently
+ consumed input in bits.
+
+ The Z_TREES option behaves as Z_BLOCK does, but it also returns when the
+ end of each deflate block header is reached, before any actual data in that
+ block is decoded. This allows the caller to determine the length of the
+ deflate block header for later use in random access within a deflate block.
+ 256 is added to the value of strm->data_type when inflate() returns
+ immediately after reaching the end of the deflate block header.
+
+ inflate() should normally be called until it returns Z_STREAM_END or an
+ error. However if all decompression is to be performed in a single step (a
+ single call of inflate), the parameter flush should be set to Z_FINISH. In
+ this case all pending input is processed and all pending output is flushed;
+ avail_out must be large enough to hold all the uncompressed data. (The size
+ of the uncompressed data may have been saved by the compressor for this
+ purpose.) The next operation on this stream must be inflateEnd to deallocate
+ the decompression state. The use of Z_FINISH is never required, but can be
+ used to inform inflate that a faster approach may be used for the single
+ inflate() call.
+
+ In this implementation, inflate() always flushes as much output as
+ possible to the output buffer, and always uses the faster approach on the
+ first call. So the only effect of the flush parameter in this implementation
+ is on the return value of inflate(), as noted below, or when it returns early
+ because Z_BLOCK or Z_TREES is used.
+
+ If a preset dictionary is needed after this call (see inflateSetDictionary
+ below), inflate sets strm->adler to the adler32 checksum of the dictionary
+ chosen by the compressor and returns Z_NEED_DICT; otherwise it sets
+ strm->adler to the adler32 checksum of all output produced so far (that is,
+ total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described
+ below. At the end of the stream, inflate() checks that its computed adler32
+ checksum is equal to that saved by the compressor and returns Z_STREAM_END
+ only if the checksum is correct.
+
+ inflate() can decompress and check either zlib-wrapped or gzip-wrapped
+ deflate data. The header type is detected automatically, if requested when
+ initializing with inflateInit2(). Any information contained in the gzip
+ header is not retained, so applications that need that information should
+ instead use raw inflate, see inflateInit2() below, or inflateBack() and
+ perform their own processing of the gzip header and trailer.
+
+ inflate() returns Z_OK if some progress has been made (more input processed
+ or more output produced), Z_STREAM_END if the end of the compressed data has
+ been reached and all uncompressed output has been produced, Z_NEED_DICT if a
+ preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
+ corrupted (input stream not conforming to the zlib format or incorrect check
+ value), Z_STREAM_ERROR if the stream structure was inconsistent (for example
+ next_in or next_out was Z_NULL), Z_MEM_ERROR if there was not enough memory,
+ Z_BUF_ERROR if no progress is possible or if there was not enough room in the
+ output buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and
+ inflate() can be called again with more input and more output space to
+ continue decompressing. If Z_DATA_ERROR is returned, the application may
+ then call inflateSync() to look for a good compression block if a partial
+ recovery of the data is desired.
+*/
+
+
+ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));
+/*
+ All dynamically allocated data structures for this stream are freed.
+ This function discards any unprocessed input and does not flush any pending
+ output.
+
+ inflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state
+ was inconsistent. In the error case, msg may be set but then points to a
+ static string (which must not be deallocated).
+*/
+
+
+ /* Advanced functions */
+
+/*
+ The following functions are needed only in some special applications.
+*/
+
+/*
+ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm,
+ int level,
+ int method,
+ int windowBits,
+ int memLevel,
+ int strategy));
+
+ This is another version of deflateInit with more compression options. The
+ fields next_in, zalloc, zfree and opaque must be initialized before by the
+ caller.
+
+ The method parameter is the compression method. It must be Z_DEFLATED in
+ this version of the library.
+
+ The windowBits parameter is the base two logarithm of the window size
+ (the size of the history buffer). It should be in the range 8..15 for this
+ version of the library. Larger values of this parameter result in better
+ compression at the expense of memory usage. The default value is 15 if
+ deflateInit is used instead.
+
+ windowBits can also be -8..-15 for raw deflate. In this case, -windowBits
+ determines the window size. deflate() will then generate raw deflate data
+ with no zlib header or trailer, and will not compute an adler32 check value.
+
+ windowBits can also be greater than 15 for optional gzip encoding. Add
+ 16 to windowBits to write a simple gzip header and trailer around the
+ compressed data instead of a zlib wrapper. The gzip header will have no
+ file name, no extra data, no comment, no modification time (set to zero), no
+ header crc, and the operating system will be set to 255 (unknown). If a
+ gzip stream is being written, strm->adler is a crc32 instead of an adler32.
+
+ The memLevel parameter specifies how much memory should be allocated
+ for the internal compression state. memLevel=1 uses minimum memory but is
+ slow and reduces compression ratio; memLevel=9 uses maximum memory for
+ optimal speed. The default value is 8. See zconf.h for total memory usage
+ as a function of windowBits and memLevel.
+
+ The strategy parameter is used to tune the compression algorithm. Use the
+ value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a
+ filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no
+ string match), or Z_RLE to limit match distances to one (run-length
+ encoding). Filtered data consists mostly of small values with a somewhat
+ random distribution. In this case, the compression algorithm is tuned to
+ compress them better. The effect of Z_FILTERED is to force more Huffman
+ coding and less string matching; it is somewhat intermediate between
+ Z_DEFAULT_STRATEGY and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as
+ fast as Z_HUFFMAN_ONLY, but give better compression for PNG image data. The
+ strategy parameter only affects the compression ratio but not the
+ correctness of the compressed output even if it is not set appropriately.
+ Z_FIXED prevents the use of dynamic Huffman codes, allowing for a simpler
+ decoder for special applications.
+
+ deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_STREAM_ERROR if any parameter is invalid (such as an invalid
+ method), or Z_VERSION_ERROR if the zlib library version (zlib_version) is
+ incompatible with the version assumed by the caller (ZLIB_VERSION). msg is
+ set to null if there is no error message. deflateInit2 does not perform any
+ compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+/*
+ Initializes the compression dictionary from the given byte sequence
+ without producing any compressed output. This function must be called
+ immediately after deflateInit, deflateInit2 or deflateReset, before any call
+ of deflate. The compressor and decompressor must use exactly the same
+ dictionary (see inflateSetDictionary).
+
+ The dictionary should consist of strings (byte sequences) that are likely
+ to be encountered later in the data to be compressed, with the most commonly
+ used strings preferably put towards the end of the dictionary. Using a
+ dictionary is most useful when the data to be compressed is short and can be
+ predicted with good accuracy; the data can then be compressed better than
+ with the default empty dictionary.
+
+ Depending on the size of the compression data structures selected by
+ deflateInit or deflateInit2, a part of the dictionary may in effect be
+ discarded, for example if the dictionary is larger than the window size
+ provided in deflateInit or deflateInit2. Thus the strings most likely to be
+ useful should be put at the end of the dictionary, not at the front. In
+ addition, the current implementation of deflate will use at most the window
+ size minus 262 bytes of the provided dictionary.
+
+ Upon return of this function, strm->adler is set to the adler32 value
+ of the dictionary; the decompressor may later use this value to determine
+ which dictionary has been used by the compressor. (The adler32 value
+ applies to the whole dictionary even if only a subset of the dictionary is
+ actually used by the compressor.) If a raw deflate was requested, then the
+ adler32 value is not computed and strm->adler is not set.
+
+ deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a
+ parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is
+ inconsistent (for example if deflate has already been called for this stream
+ or if the compression method is bsort). deflateSetDictionary does not
+ perform any compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,
+ z_streamp source));
+/*
+ Sets the destination stream as a complete copy of the source stream.
+
+ This function can be useful when several compression strategies will be
+ tried, for example when there are several ways of pre-processing the input
+ data with a filter. The streams that will be discarded should then be freed
+ by calling deflateEnd. Note that deflateCopy duplicates the internal
+ compression state which can be quite large, so this strategy is slow and can
+ consume lots of memory.
+
+ deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+ (such as zalloc being Z_NULL). msg is left unchanged in both source and
+ destination.
+*/
+
+ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));
+/*
+ This function is equivalent to deflateEnd followed by deflateInit,
+ but does not free and reallocate all the internal compression state. The
+ stream will keep the same compression level and any other attributes that
+ may have been set by deflateInit2.
+
+ deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL).
+*/
+
+ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,
+ int level,
+ int strategy));
+/*
+ Dynamically update the compression level and compression strategy. The
+ interpretation of level and strategy is as in deflateInit2. This can be
+ used to switch between compression and straight copy of the input data, or
+ to switch to a different kind of input data requiring a different strategy.
+ If the compression level is changed, the input available so far is
+ compressed with the old level (and may be flushed); the new level will take
+ effect only at the next call of deflate().
+
+ Before the call of deflateParams, the stream state must be set as for
+ a call of deflate(), since the currently available input may have to be
+ compressed and flushed. In particular, strm->avail_out must be non-zero.
+
+ deflateParams returns Z_OK if success, Z_STREAM_ERROR if the source
+ stream state was inconsistent or if a parameter was invalid, Z_BUF_ERROR if
+ strm->avail_out was zero.
+*/
+
+ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm,
+ int good_length,
+ int max_lazy,
+ int nice_length,
+ int max_chain));
+/*
+ Fine tune deflate's internal compression parameters. This should only be
+ used by someone who understands the algorithm used by zlib's deflate for
+ searching for the best matching string, and even then only by the most
+ fanatic optimizer trying to squeeze out the last compressed bit for their
+ specific input data. Read the deflate.c source code for the meaning of the
+ max_lazy, good_length, nice_length, and max_chain parameters.
+
+ deflateTune() can be called after deflateInit() or deflateInit2(), and
+ returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream.
+ */
+
+ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm,
+ uLong sourceLen));
+/*
+ deflateBound() returns an upper bound on the compressed size after
+ deflation of sourceLen bytes. It must be called after deflateInit() or
+ deflateInit2(), and after deflateSetHeader(), if used. This would be used
+ to allocate an output buffer for deflation in a single pass, and so would be
+ called before deflate().
+*/
+
+ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+/*
+ deflatePrime() inserts bits in the deflate output stream. The intent
+ is that this function is used to start off the deflate output with the bits
+ leftover from a previous deflate stream when appending to it. As such, this
+ function can only be used for raw deflate, and must be used before the first
+ deflate() call after a deflateInit2() or deflateReset(). bits must be less
+ than or equal to 16, and that many of the least significant bits of value
+ will be inserted in the output.
+
+ deflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm,
+ gz_headerp head));
+/*
+ deflateSetHeader() provides gzip header information for when a gzip
+ stream is requested by deflateInit2(). deflateSetHeader() may be called
+ after deflateInit2() or deflateReset() and before the first call of
+ deflate(). The text, time, os, extra field, name, and comment information
+ in the provided gz_header structure are written to the gzip header (xflag is
+ ignored -- the extra flags are set according to the compression level). The
+ caller must assure that, if not Z_NULL, name and comment are terminated with
+ a zero byte, and that if extra is not Z_NULL, that extra_len bytes are
+ available there. If hcrc is true, a gzip header crc is included. Note that
+ the current versions of the command-line version of gzip (up through version
+ 1.3.x) do not support header crc's, and will report that it is a "multi-part
+ gzip file" and give up.
+
+ If deflateSetHeader is not used, the default gzip header has text false,
+ the time set to zero, and os set to 255, with no extra, name, or comment
+ fields. The gzip header is returned to the default state by deflateReset().
+
+ deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm,
+ int windowBits));
+
+ This is another version of inflateInit with an extra parameter. The
+ fields next_in, avail_in, zalloc, zfree and opaque must be initialized
+ before by the caller.
+
+ The windowBits parameter is the base two logarithm of the maximum window
+ size (the size of the history buffer). It should be in the range 8..15 for
+ this version of the library. The default value is 15 if inflateInit is used
+ instead. windowBits must be greater than or equal to the windowBits value
+ provided to deflateInit2() while compressing, or it must be equal to 15 if
+ deflateInit2() was not used. If a compressed stream with a larger window
+ size is given as input, inflate() will return with the error code
+ Z_DATA_ERROR instead of trying to allocate a larger window.
+
+ windowBits can also be zero to request that inflate use the window size in
+ the zlib header of the compressed stream.
+
+ windowBits can also be -8..-15 for raw inflate. In this case, -windowBits
+ determines the window size. inflate() will then process raw deflate data,
+ not looking for a zlib or gzip header, not generating a check value, and not
+ looking for any check values for comparison at the end of the stream. This
+ is for use with other formats that use the deflate compressed data format
+ such as zip. Those formats provide their own check values. If a custom
+ format is developed using the raw deflate format for compressed data, it is
+ recommended that a check value such as an adler32 or a crc32 be applied to
+ the uncompressed data as is done in the zlib, gzip, and zip formats. For
+ most applications, the zlib format should be used as is. Note that comments
+ above on the use in deflateInit2() applies to the magnitude of windowBits.
+
+ windowBits can also be greater than 15 for optional gzip decoding. Add
+ 32 to windowBits to enable zlib and gzip decoding with automatic header
+ detection, or add 16 to decode only the gzip format (the zlib format will
+ return a Z_DATA_ERROR). If a gzip stream is being decoded, strm->adler is a
+ crc32 instead of an adler32.
+
+ inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+ version assumed by the caller, or Z_STREAM_ERROR if the parameters are
+ invalid, such as a null pointer to the structure. msg is set to null if
+ there is no error message. inflateInit2 does not perform any decompression
+ apart from possibly reading the zlib header if present: actual decompression
+ will be done by inflate(). (So next_in and avail_in may be modified, but
+ next_out and avail_out are unused and unchanged.) The current implementation
+ of inflateInit2() does not process any header information -- that is
+ deferred until inflate() is called.
+*/
+
+ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+/*
+ Initializes the decompression dictionary from the given uncompressed byte
+ sequence. This function must be called immediately after a call of inflate,
+ if that call returned Z_NEED_DICT. The dictionary chosen by the compressor
+ can be determined from the adler32 value returned by that call of inflate.
+ The compressor and decompressor must use exactly the same dictionary (see
+ deflateSetDictionary). For raw inflate, this function can be called
+ immediately after inflateInit2() or inflateReset() and before any call of
+ inflate() to set the dictionary. The application must insure that the
+ dictionary that was used for compression is provided.
+
+ inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
+ parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is
+ inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
+ expected one (incorrect adler32 value). inflateSetDictionary does not
+ perform any decompression: this will be done by subsequent calls of
+ inflate().
+*/
+
+ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));
+/*
+ Skips invalid compressed data until a full flush point (see above the
+ description of deflate with Z_FULL_FLUSH) can be found, or until all
+ available input is skipped. No output is provided.
+
+ inflateSync returns Z_OK if a full flush point has been found, Z_BUF_ERROR
+ if no more input was provided, Z_DATA_ERROR if no flush point has been
+ found, or Z_STREAM_ERROR if the stream structure was inconsistent. In the
+ success case, the application may save the current current value of total_in
+ which indicates where valid compressed data was found. In the error case,
+ the application may repeatedly call inflateSync, providing more input each
+ time, until success or end of the input data.
+*/
+
+ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest,
+ z_streamp source));
+/*
+ Sets the destination stream as a complete copy of the source stream.
+
+ This function can be useful when randomly accessing a large stream. The
+ first pass through the stream can periodically record the inflate state,
+ allowing restarting inflate at those points when randomly accessing the
+ stream.
+
+ inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+ (such as zalloc being Z_NULL). msg is left unchanged in both source and
+ destination.
+*/
+
+ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));
+/*
+ This function is equivalent to inflateEnd followed by inflateInit,
+ but does not free and reallocate all the internal decompression state. The
+ stream will keep attributes that may have been set by inflateInit2.
+
+ inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL).
+*/
+
+ZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm,
+ int windowBits));
+/*
+ This function is the same as inflateReset, but it also permits changing
+ the wrap and window size requests. The windowBits parameter is interpreted
+ the same as it is for inflateInit2.
+
+ inflateReset2 returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL), or if
+ the windowBits parameter is invalid.
+*/
+
+ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+/*
+ This function inserts bits in the inflate input stream. The intent is
+ that this function is used to start inflating at a bit position in the
+ middle of a byte. The provided bits will be used before any bytes are used
+ from next_in. This function should only be used with raw inflate, and
+ should be used before the first inflate() call after inflateInit2() or
+ inflateReset(). bits must be less than or equal to 16, and that many of the
+ least significant bits of value will be inserted in the input.
+
+ If bits is negative, then the input stream bit buffer is emptied. Then
+ inflatePrime() can be called again to put bits in the buffer. This is used
+ to clear out bits leftover after feeding inflate a block description prior
+ to feeding inflate codes.
+
+ inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+ZEXTERN long ZEXPORT inflateMark OF((z_streamp strm));
+/*
+ This function returns two values, one in the lower 16 bits of the return
+ value, and the other in the remaining upper bits, obtained by shifting the
+ return value down 16 bits. If the upper value is -1 and the lower value is
+ zero, then inflate() is currently decoding information outside of a block.
+ If the upper value is -1 and the lower value is non-zero, then inflate is in
+ the middle of a stored block, with the lower value equaling the number of
+ bytes from the input remaining to copy. If the upper value is not -1, then
+ it is the number of bits back from the current bit position in the input of
+ the code (literal or length/distance pair) currently being processed. In
+ that case the lower value is the number of bytes already emitted for that
+ code.
+
+ A code is being processed if inflate is waiting for more input to complete
+ decoding of the code, or if it has completed decoding but is waiting for
+ more output space to write the literal or match data.
+
+ inflateMark() is used to mark locations in the input data for random
+ access, which may be at bit positions, and to note those cases where the
+ output of a code may span boundaries of random access blocks. The current
+ location in the input stream can be determined from avail_in and data_type
+ as noted in the description for the Z_BLOCK flush parameter for inflate.
+
+ inflateMark returns the value noted above or -1 << 16 if the provided
+ source stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm,
+ gz_headerp head));
+/*
+ inflateGetHeader() requests that gzip header information be stored in the
+ provided gz_header structure. inflateGetHeader() may be called after
+ inflateInit2() or inflateReset(), and before the first call of inflate().
+ As inflate() processes the gzip stream, head->done is zero until the header
+ is completed, at which time head->done is set to one. If a zlib stream is
+ being decoded, then head->done is set to -1 to indicate that there will be
+ no gzip header information forthcoming. Note that Z_BLOCK or Z_TREES can be
+ used to force inflate() to return immediately after header processing is
+ complete and before any actual data is decompressed.
+
+ The text, time, xflags, and os fields are filled in with the gzip header
+ contents. hcrc is set to true if there is a header CRC. (The header CRC
+ was valid if done is set to one.) If extra is not Z_NULL, then extra_max
+ contains the maximum number of bytes to write to extra. Once done is true,
+ extra_len contains the actual extra field length, and extra contains the
+ extra field, or that field truncated if extra_max is less than extra_len.
+ If name is not Z_NULL, then up to name_max characters are written there,
+ terminated with a zero unless the length is greater than name_max. If
+ comment is not Z_NULL, then up to comm_max characters are written there,
+ terminated with a zero unless the length is greater than comm_max. When any
+ of extra, name, or comment are not Z_NULL and the respective field is not
+ present in the header, then that field is set to Z_NULL to signal its
+ absence. This allows the use of deflateSetHeader() with the returned
+ structure to duplicate the header. However if those fields are set to
+ allocated memory, then the application will need to save those pointers
+ elsewhere so that they can be eventually freed.
+
+ If inflateGetHeader is not used, then the header information is simply
+ discarded. The header is always checked for validity, including the header
+ CRC if present. inflateReset() will reset the process to discard the header
+ information. The application would need to call inflateGetHeader() again to
+ retrieve the header from the next gzip stream.
+
+ inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits,
+ unsigned char FAR *window));
+
+ Initialize the internal stream state for decompression using inflateBack()
+ calls. The fields zalloc, zfree and opaque in strm must be initialized
+ before the call. If zalloc and zfree are Z_NULL, then the default library-
+ derived memory allocation routines are used. windowBits is the base two
+ logarithm of the window size, in the range 8..15. window is a caller
+ supplied buffer of that size. Except for special applications where it is
+ assured that deflate was used with small window sizes, windowBits must be 15
+ and a 32K byte window must be supplied to be able to decompress general
+ deflate streams.
+
+ See inflateBack() for the usage of these routines.
+
+ inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of
+ the paramaters are invalid, Z_MEM_ERROR if the internal state could not be
+ allocated, or Z_VERSION_ERROR if the version of the library does not match
+ the version of the header file.
+*/
+
+typedef unsigned (*in_func) OF((void FAR *, unsigned char FAR * FAR *));
+typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned));
+
+ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm,
+ in_func in, void FAR *in_desc,
+ out_func out, void FAR *out_desc));
+/*
+ inflateBack() does a raw inflate with a single call using a call-back
+ interface for input and output. This is more efficient than inflate() for
+ file i/o applications in that it avoids copying between the output and the
+ sliding window by simply making the window itself the output buffer. This
+ function trusts the application to not change the output buffer passed by
+ the output function, at least until inflateBack() returns.
+
+ inflateBackInit() must be called first to allocate the internal state
+ and to initialize the state with the user-provided window buffer.
+ inflateBack() may then be used multiple times to inflate a complete, raw
+ deflate stream with each call. inflateBackEnd() is then called to free the
+ allocated state.
+
+ A raw deflate stream is one with no zlib or gzip header or trailer.
+ This routine would normally be used in a utility that reads zip or gzip
+ files and writes out uncompressed files. The utility would decode the
+ header and process the trailer on its own, hence this routine expects only
+ the raw deflate stream to decompress. This is different from the normal
+ behavior of inflate(), which expects either a zlib or gzip header and
+ trailer around the deflate stream.
+
+ inflateBack() uses two subroutines supplied by the caller that are then
+ called by inflateBack() for input and output. inflateBack() calls those
+ routines until it reads a complete deflate stream and writes out all of the
+ uncompressed data, or until it encounters an error. The function's
+ parameters and return types are defined above in the in_func and out_func
+ typedefs. inflateBack() will call in(in_desc, &buf) which should return the
+ number of bytes of provided input, and a pointer to that input in buf. If
+ there is no input available, in() must return zero--buf is ignored in that
+ case--and inflateBack() will return a buffer error. inflateBack() will call
+ out(out_desc, buf, len) to write the uncompressed data buf[0..len-1]. out()
+ should return zero on success, or non-zero on failure. If out() returns
+ non-zero, inflateBack() will return with an error. Neither in() nor out()
+ are permitted to change the contents of the window provided to
+ inflateBackInit(), which is also the buffer that out() uses to write from.
+ The length written by out() will be at most the window size. Any non-zero
+ amount of input may be provided by in().
+
+ For convenience, inflateBack() can be provided input on the first call by
+ setting strm->next_in and strm->avail_in. If that input is exhausted, then
+ in() will be called. Therefore strm->next_in must be initialized before
+ calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called
+ immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in
+ must also be initialized, and then if strm->avail_in is not zero, input will
+ initially be taken from strm->next_in[0 .. strm->avail_in - 1].
+
+ The in_desc and out_desc parameters of inflateBack() is passed as the
+ first parameter of in() and out() respectively when they are called. These
+ descriptors can be optionally used to pass any information that the caller-
+ supplied in() and out() functions need to do their job.
+
+ On return, inflateBack() will set strm->next_in and strm->avail_in to
+ pass back any unused input that was provided by the last in() call. The
+ return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR
+ if in() or out() returned an error, Z_DATA_ERROR if there was a format error
+ in the deflate stream (in which case strm->msg is set to indicate the nature
+ of the error), or Z_STREAM_ERROR if the stream was not properly initialized.
+ In the case of Z_BUF_ERROR, an input or output error can be distinguished
+ using strm->next_in which will be Z_NULL only if in() returned an error. If
+ strm->next_in is not Z_NULL, then the Z_BUF_ERROR was due to out() returning
+ non-zero. (in() will always be called before out(), so strm->next_in is
+ assured to be defined if out() returns non-zero.) Note that inflateBack()
+ cannot return Z_OK.
+*/
+
+ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm));
+/*
+ All memory allocated by inflateBackInit() is freed.
+
+ inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream
+ state was inconsistent.
+*/
+
+ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void));
+/* Return flags indicating compile-time options.
+
+ Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other:
+ 1.0: size of uInt
+ 3.2: size of uLong
+ 5.4: size of voidpf (pointer)
+ 7.6: size of z_off_t
+
+ Compiler, assembler, and debug options:
+ 8: DEBUG
+ 9: ASMV or ASMINF -- use ASM code
+ 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention
+ 11: 0 (reserved)
+
+ One-time table building (smaller code, but not thread-safe if true):
+ 12: BUILDFIXED -- build static block decoding tables when needed
+ 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed
+ 14,15: 0 (reserved)
+
+ Library content (indicates missing functionality):
+ 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking
+ deflate code when not needed)
+ 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect
+ and decode gzip streams (to avoid linking crc code)
+ 18-19: 0 (reserved)
+
+ Operation variations (changes in library functionality):
+ 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate
+ 21: FASTEST -- deflate algorithm with only one, lowest compression level
+ 22,23: 0 (reserved)
+
+ The sprintf variant used by gzprintf (zero is best):
+ 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format
+ 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure!
+ 26: 0 = returns value, 1 = void -- 1 means inferred string length returned
+
+ Remainder:
+ 27-31: 0 (reserved)
+ */
+
+
+ /* utility functions */
+
+/*
+ The following utility functions are implemented on top of the basic
+ stream-oriented functions. To simplify the interface, some default options
+ are assumed (compression level and memory usage, standard memory allocation
+ functions). The source code of these utility functions can be modified if
+ you need special options.
+*/
+
+ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+/*
+ Compresses the source buffer into the destination buffer. sourceLen is
+ the byte length of the source buffer. Upon entry, destLen is the total size
+ of the destination buffer, which must be at least the value returned by
+ compressBound(sourceLen). Upon exit, destLen is the actual size of the
+ compressed buffer.
+
+ compress returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_BUF_ERROR if there was not enough room in the output
+ buffer.
+*/
+
+ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen,
+ int level));
+/*
+ Compresses the source buffer into the destination buffer. The level
+ parameter has the same meaning as in deflateInit. sourceLen is the byte
+ length of the source buffer. Upon entry, destLen is the total size of the
+ destination buffer, which must be at least the value returned by
+ compressBound(sourceLen). Upon exit, destLen is the actual size of the
+ compressed buffer.
+
+ compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+ Z_STREAM_ERROR if the level parameter is invalid.
+*/
+
+ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
+/*
+ compressBound() returns an upper bound on the compressed size after
+ compress() or compress2() on sourceLen bytes. It would be used before a
+ compress() or compress2() call to allocate the destination buffer.
+*/
+
+ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+/*
+ Decompresses the source buffer into the destination buffer. sourceLen is
+ the byte length of the source buffer. Upon entry, destLen is the total size
+ of the destination buffer, which must be large enough to hold the entire
+ uncompressed data. (The size of the uncompressed data must have been saved
+ previously by the compressor and transmitted to the decompressor by some
+ mechanism outside the scope of this compression library.) Upon exit, destLen
+ is the actual size of the uncompressed buffer.
+
+ uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_BUF_ERROR if there was not enough room in the output
+ buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete.
+*/
+
+
+ /* gzip file access functions */
+
+/*
+ This library supports reading and writing files in gzip (.gz) format with
+ an interface similar to that of stdio, using the functions that start with
+ "gz". The gzip format is different from the zlib format. gzip is a gzip
+ wrapper, documented in RFC 1952, wrapped around a deflate stream.
+*/
+
+typedef voidp gzFile; /* opaque gzip file descriptor */
+
+/*
+ZEXTERN gzFile ZEXPORT gzopen OF((const char *path, const char *mode));
+
+ Opens a gzip (.gz) file for reading or writing. The mode parameter is as
+ in fopen ("rb" or "wb") but can also include a compression level ("wb9") or
+ a strategy: 'f' for filtered data as in "wb6f", 'h' for Huffman-only
+ compression as in "wb1h", 'R' for run-length encoding as in "wb1R", or 'F'
+ for fixed code compression as in "wb9F". (See the description of
+ deflateInit2 for more information about the strategy parameter.) Also "a"
+ can be used instead of "w" to request that the gzip stream that will be
+ written be appended to the file. "+" will result in an error, since reading
+ and writing to the same gzip file is not supported.
+
+ gzopen can be used to read a file which is not in gzip format; in this
+ case gzread will directly read from the file without decompression.
+
+ gzopen returns NULL if the file could not be opened, if there was
+ insufficient memory to allocate the gzFile state, or if an invalid mode was
+ specified (an 'r', 'w', or 'a' was not provided, or '+' was provided).
+ errno can be checked to determine if the reason gzopen failed was that the
+ file could not be opened.
+*/
+
+ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode));
+/*
+ gzdopen associates a gzFile with the file descriptor fd. File descriptors
+ are obtained from calls like open, dup, creat, pipe or fileno (if the file
+ has been previously opened with fopen). The mode parameter is as in gzopen.
+
+ The next call of gzclose on the returned gzFile will also close the file
+ descriptor fd, just like fclose(fdopen(fd, mode)) closes the file descriptor
+ fd. If you want to keep fd open, use fd = dup(fd_keep); gz = gzdopen(fd,
+ mode);. The duplicated descriptor should be saved to avoid a leak, since
+ gzdopen does not close fd if it fails.
+
+ gzdopen returns NULL if there was insufficient memory to allocate the
+ gzFile state, if an invalid mode was specified (an 'r', 'w', or 'a' was not
+ provided, or '+' was provided), or if fd is -1. The file descriptor is not
+ used until the next gz* read, write, seek, or close operation, so gzdopen
+ will not detect if fd is invalid (unless fd is -1).
+*/
+
+ZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size));
+/*
+ Set the internal buffer size used by this library's functions. The
+ default buffer size is 8192 bytes. This function must be called after
+ gzopen() or gzdopen(), and before any other calls that read or write the
+ file. The buffer memory allocation is always deferred to the first read or
+ write. Two buffers are allocated, either both of the specified size when
+ writing, or one of the specified size and the other twice that size when
+ reading. A larger buffer size of, for example, 64K or 128K bytes will
+ noticeably increase the speed of decompression (reading).
+
+ The new buffer size also affects the maximum length for gzprintf().
+
+ gzbuffer() returns 0 on success, or -1 on failure, such as being called
+ too late.
+*/
+
+ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));
+/*
+ Dynamically update the compression level or strategy. See the description
+ of deflateInit2 for the meaning of these parameters.
+
+ gzsetparams returns Z_OK if success, or Z_STREAM_ERROR if the file was not
+ opened for writing.
+*/
+
+ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len));
+/*
+ Reads the given number of uncompressed bytes from the compressed file. If
+ the input file was not in gzip format, gzread copies the given number of
+ bytes into the buffer.
+
+ After reaching the end of a gzip stream in the input, gzread will continue
+ to read, looking for another gzip stream, or failing that, reading the rest
+ of the input file directly without decompression. The entire input file
+ will be read if gzread is called until it returns less than the requested
+ len.
+
+ gzread returns the number of uncompressed bytes actually read, less than
+ len for end of file, or -1 for error.
+*/
+
+ZEXTERN int ZEXPORT gzwrite OF((gzFile file,
+ voidpc buf, unsigned len));
+/*
+ Writes the given number of uncompressed bytes into the compressed file.
+ gzwrite returns the number of uncompressed bytes written or 0 in case of
+ error.
+*/
+
+ZEXTERN int ZEXPORTVA gzprintf OF((gzFile file, const char *format, ...));
+/*
+ Converts, formats, and writes the arguments to the compressed file under
+ control of the format string, as in fprintf. gzprintf returns the number of
+ uncompressed bytes actually written, or 0 in case of error. The number of
+ uncompressed bytes written is limited to 8191, or one less than the buffer
+ size given to gzbuffer(). The caller should assure that this limit is not
+ exceeded. If it is exceeded, then gzprintf() will return an error (0) with
+ nothing written. In this case, there may also be a buffer overflow with
+ unpredictable consequences, which is possible only if zlib was compiled with
+ the insecure functions sprintf() or vsprintf() because the secure snprintf()
+ or vsnprintf() functions were not available. This can be determined using
+ zlibCompileFlags().
+*/
+
+ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));
+/*
+ Writes the given null-terminated string to the compressed file, excluding
+ the terminating null character.
+
+ gzputs returns the number of characters written, or -1 in case of error.
+*/
+
+ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));
+/*
+ Reads bytes from the compressed file until len-1 characters are read, or a
+ newline character is read and transferred to buf, or an end-of-file
+ condition is encountered. If any characters are read or if len == 1, the
+ string is terminated with a null character. If no characters are read due
+ to an end-of-file or len < 1, then the buffer is left untouched.
+
+ gzgets returns buf which is a null-terminated string, or it returns NULL
+ for end-of-file or in case of error. If there was an error, the contents at
+ buf are indeterminate.
+*/
+
+ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c));
+/*
+ Writes c, converted to an unsigned char, into the compressed file. gzputc
+ returns the value that was written, or -1 in case of error.
+*/
+
+ZEXTERN int ZEXPORT gzgetc OF((gzFile file));
+/*
+ Reads one byte from the compressed file. gzgetc returns this byte or -1
+ in case of end of file or error.
+*/
+
+ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file));
+/*
+ Push one character back onto the stream to be read as the first character
+ on the next read. At least one character of push-back is allowed.
+ gzungetc() returns the character pushed, or -1 on failure. gzungetc() will
+ fail if c is -1, and may fail if a character has been pushed but not read
+ yet. If gzungetc is used immediately after gzopen or gzdopen, at least the
+ output buffer size of pushed characters is allowed. (See gzbuffer above.)
+ The pushed character will be discarded if the stream is repositioned with
+ gzseek() or gzrewind().
+*/
+
+ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush));
+/*
+ Flushes all pending output into the compressed file. The parameter flush
+ is as in the deflate() function. The return value is the zlib error number
+ (see function gzerror below). gzflush is only permitted when writing.
+
+ If the flush parameter is Z_FINISH, the remaining data is written and the
+ gzip stream is completed in the output. If gzwrite() is called again, a new
+ gzip stream will be started in the output. gzread() is able to read such
+ concatented gzip streams.
+
+ gzflush should be called only when strictly necessary because it will
+ degrade compression if called too often.
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile file,
+ z_off_t offset, int whence));
+
+ Sets the starting position for the next gzread or gzwrite on the given
+ compressed file. The offset represents a number of bytes in the
+ uncompressed data stream. The whence parameter is defined as in lseek(2);
+ the value SEEK_END is not supported.
+
+ If the file is opened for reading, this function is emulated but can be
+ extremely slow. If the file is opened for writing, only forward seeks are
+ supported; gzseek then compresses a sequence of zeroes up to the new
+ starting position.
+
+ gzseek returns the resulting offset location as measured in bytes from
+ the beginning of the uncompressed stream, or -1 in case of error, in
+ particular if the file is opened for writing and the new starting position
+ would be before the current position.
+*/
+
+ZEXTERN int ZEXPORT gzrewind OF((gzFile file));
+/*
+ Rewinds the given file. This function is supported only for reading.
+
+ gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gztell OF((gzFile file));
+
+ Returns the starting position for the next gzread or gzwrite on the given
+ compressed file. This position represents a number of bytes in the
+ uncompressed data stream, and is zero when starting, even if appending or
+ reading a gzip stream from the middle of a file using gzdopen().
+
+ gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile file));
+
+ Returns the current offset in the file being read or written. This offset
+ includes the count of bytes that precede the gzip stream, for example when
+ appending or when using gzdopen() for reading. When reading, the offset
+ does not include as yet unused buffered input. This information can be used
+ for a progress indicator. On error, gzoffset() returns -1.
+*/
+
+ZEXTERN int ZEXPORT gzeof OF((gzFile file));
+/*
+ Returns true (1) if the end-of-file indicator has been set while reading,
+ false (0) otherwise. Note that the end-of-file indicator is set only if the
+ read tried to go past the end of the input, but came up short. Therefore,
+ just like feof(), gzeof() may return false even if there is no more data to
+ read, in the event that the last read request was for the exact number of
+ bytes remaining in the input file. This will happen if the input file size
+ is an exact multiple of the buffer size.
+
+ If gzeof() returns true, then the read functions will return no more data,
+ unless the end-of-file indicator is reset by gzclearerr() and the input file
+ has grown since the previous end of file was detected.
+*/
+
+ZEXTERN int ZEXPORT gzdirect OF((gzFile file));
+/*
+ Returns true (1) if file is being copied directly while reading, or false
+ (0) if file is a gzip stream being decompressed. This state can change from
+ false to true while reading the input file if the end of a gzip stream is
+ reached, but is followed by data that is not another gzip stream.
+
+ If the input file is empty, gzdirect() will return true, since the input
+ does not contain a gzip stream.
+
+ If gzdirect() is used immediately after gzopen() or gzdopen() it will
+ cause buffers to be allocated to allow reading the file to determine if it
+ is a gzip file. Therefore if gzbuffer() is used, it should be called before
+ gzdirect().
+*/
+
+ZEXTERN int ZEXPORT gzclose OF((gzFile file));
+/*
+ Flushes all pending output if necessary, closes the compressed file and
+ deallocates the (de)compression state. Note that once file is closed, you
+ cannot call gzerror with file, since its structures have been deallocated.
+ gzclose must not be called more than once on the same file, just as free
+ must not be called more than once on the same allocation.
+
+ gzclose will return Z_STREAM_ERROR if file is not valid, Z_ERRNO on a
+ file operation error, or Z_OK on success.
+*/
+
+ZEXTERN int ZEXPORT gzclose_r OF((gzFile file));
+ZEXTERN int ZEXPORT gzclose_w OF((gzFile file));
+/*
+ Same as gzclose(), but gzclose_r() is only for use when reading, and
+ gzclose_w() is only for use when writing or appending. The advantage to
+ using these instead of gzclose() is that they avoid linking in zlib
+ compression or decompression code that is not used when only reading or only
+ writing respectively. If gzclose() is used, then both compression and
+ decompression code will be included the application when linking to a static
+ zlib library.
+*/
+
+ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));
+/*
+ Returns the error message for the last error which occurred on the given
+ compressed file. errnum is set to zlib error number. If an error occurred
+ in the file system and not in the compression library, errnum is set to
+ Z_ERRNO and the application may consult errno to get the exact error code.
+
+ The application must not modify the returned string. Future calls to
+ this function may invalidate the previously returned string. If file is
+ closed, then the string previously returned by gzerror will no longer be
+ available.
+
+ gzerror() should be used to distinguish errors from end-of-file for those
+ functions above that do not distinguish those cases in their return values.
+*/
+
+ZEXTERN void ZEXPORT gzclearerr OF((gzFile file));
+/*
+ Clears the error and end-of-file flags for file. This is analogous to the
+ clearerr() function in stdio. This is useful for continuing to read a gzip
+ file that is being written concurrently.
+*/
+
+
+ /* checksum functions */
+
+/*
+ These functions are not related to compression but are exported
+ anyway because they might be useful in applications using the compression
+ library.
+*/
+
+ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));
+/*
+ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
+ return the updated checksum. If buf is Z_NULL, this function returns the
+ required initial value for the checksum.
+
+ An Adler-32 checksum is almost as reliable as a CRC32 but can be computed
+ much faster.
+
+ Usage example:
+
+ uLong adler = adler32(0L, Z_NULL, 0);
+
+ while (read_buffer(buffer, length) != EOF) {
+ adler = adler32(adler, buffer, length);
+ }
+ if (adler != original_adler) error();
+*/
+
+/*
+ZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2,
+ z_off_t len2));
+
+ Combine two Adler-32 checksums into one. For two sequences of bytes, seq1
+ and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for
+ each, adler1 and adler2. adler32_combine() returns the Adler-32 checksum of
+ seq1 and seq2 concatenated, requiring only adler1, adler2, and len2.
+*/
+
+ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len));
+/*
+ Update a running CRC-32 with the bytes buf[0..len-1] and return the
+ updated CRC-32. If buf is Z_NULL, this function returns the required
+ initial value for the for the crc. Pre- and post-conditioning (one's
+ complement) is performed within this function so it shouldn't be done by the
+ application.
+
+ Usage example:
+
+ uLong crc = crc32(0L, Z_NULL, 0);
+
+ while (read_buffer(buffer, length) != EOF) {
+ crc = crc32(crc, buffer, length);
+ }
+ if (crc != original_crc) error();
+*/
+
+/*
+ZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2));
+
+ Combine two CRC-32 check values into one. For two sequences of bytes,
+ seq1 and seq2 with lengths len1 and len2, CRC-32 check values were
+ calculated for each, crc1 and crc2. crc32_combine() returns the CRC-32
+ check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and
+ len2.
+*/
+
+
+ /* various hacks, don't look :) */
+
+/* deflateInit and inflateInit are macros to allow checking the zlib version
+ * and the compiler's view of z_stream:
+ */
+ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method,
+ int windowBits, int memLevel,
+ int strategy, const char *version,
+ int stream_size));
+ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits,
+ unsigned char FAR *window,
+ const char *version,
+ int stream_size));
+#define deflateInit(strm, level) \
+ deflateInit_((strm), (level), ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit(strm) \
+ inflateInit_((strm), ZLIB_VERSION, sizeof(z_stream))
+#define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+ (strategy), ZLIB_VERSION, sizeof(z_stream))
+#define inflateInit2(strm, windowBits) \
+ inflateInit2_((strm), (windowBits), ZLIB_VERSION, sizeof(z_stream))
+#define inflateBackInit(strm, windowBits, window) \
+ inflateBackInit_((strm), (windowBits), (window), \
+ ZLIB_VERSION, sizeof(z_stream))
+
+/* provide 64-bit offset functions if _LARGEFILE64_SOURCE defined, and/or
+ * change the regular functions to 64 bits if _FILE_OFFSET_BITS is 64 (if
+ * both are true, the application gets the *64 functions, and the regular
+ * functions are changed to 64 bits) -- in case these are set on systems
+ * without large file support, _LFS64_LARGEFILE must also be true
+ */
+#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int));
+ ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t));
+#endif
+
+#if !defined(ZLIB_INTERNAL) && _FILE_OFFSET_BITS-0 == 64 && _LFS64_LARGEFILE-0
+# define gzopen gzopen64
+# define gzseek gzseek64
+# define gztell gztell64
+# define gzoffset gzoffset64
+# define adler32_combine adler32_combine64
+# define crc32_combine crc32_combine64
+# ifdef _LARGEFILE64_SOURCE
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));
+# endif
+#else
+ ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t));
+#endif
+
+/* hack for buggy compilers */
+#if !defined(ZUTIL_H) && !defined(NO_DUMMY_DECL)
+ struct internal_state {int dummy;};
+#endif
+
+/* undocumented functions */
+ZEXTERN const char * ZEXPORT zError OF((int));
+ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp));
+ZEXTERN const uLongf * ZEXPORT get_crc_table OF((void));
+ZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int));
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* ZLIB_H */
diff --git a/test/monniaux/glpk-4.65/src/zlib/zutil.c b/test/monniaux/glpk-4.65/src/zlib/zutil.c
new file mode 100644
index 00000000..898ed345
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zutil.c
@@ -0,0 +1,318 @@
+/* zutil.c -- target dependent utility functions for the compression library
+ * Copyright (C) 1995-2005, 2010 Jean-loup Gailly.
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#include "zutil.h"
+
+#ifndef NO_DUMMY_DECL
+struct internal_state {int dummy;}; /* for buggy compilers */
+#endif
+
+const char * const z_errmsg[10] = {
+"need dictionary", /* Z_NEED_DICT 2 */
+"stream end", /* Z_STREAM_END 1 */
+"", /* Z_OK 0 */
+"file error", /* Z_ERRNO (-1) */
+"stream error", /* Z_STREAM_ERROR (-2) */
+"data error", /* Z_DATA_ERROR (-3) */
+"insufficient memory", /* Z_MEM_ERROR (-4) */
+"buffer error", /* Z_BUF_ERROR (-5) */
+"incompatible version",/* Z_VERSION_ERROR (-6) */
+""};
+
+
+const char * ZEXPORT zlibVersion()
+{
+ return ZLIB_VERSION;
+}
+
+uLong ZEXPORT zlibCompileFlags()
+{
+ uLong flags;
+
+ flags = 0;
+ switch ((int)(sizeof(uInt))) {
+ case 2: break;
+ case 4: flags += 1; break;
+ case 8: flags += 2; break;
+ default: flags += 3;
+ }
+ switch ((int)(sizeof(uLong))) {
+ case 2: break;
+ case 4: flags += 1 << 2; break;
+ case 8: flags += 2 << 2; break;
+ default: flags += 3 << 2;
+ }
+ switch ((int)(sizeof(voidpf))) {
+ case 2: break;
+ case 4: flags += 1 << 4; break;
+ case 8: flags += 2 << 4; break;
+ default: flags += 3 << 4;
+ }
+ switch ((int)(sizeof(z_off_t))) {
+ case 2: break;
+ case 4: flags += 1 << 6; break;
+ case 8: flags += 2 << 6; break;
+ default: flags += 3 << 6;
+ }
+#ifdef DEBUG
+ flags += 1 << 8;
+#endif
+#if defined(ASMV) || defined(ASMINF)
+ flags += 1 << 9;
+#endif
+#ifdef ZLIB_WINAPI
+ flags += 1 << 10;
+#endif
+#ifdef BUILDFIXED
+ flags += 1 << 12;
+#endif
+#ifdef DYNAMIC_CRC_TABLE
+ flags += 1 << 13;
+#endif
+#ifdef NO_GZCOMPRESS
+ flags += 1L << 16;
+#endif
+#ifdef NO_GZIP
+ flags += 1L << 17;
+#endif
+#ifdef PKZIP_BUG_WORKAROUND
+ flags += 1L << 20;
+#endif
+#ifdef FASTEST
+ flags += 1L << 21;
+#endif
+#ifdef STDC
+# ifdef NO_vsnprintf
+ flags += 1L << 25;
+# ifdef HAS_vsprintf_void
+ flags += 1L << 26;
+# endif
+# else
+# ifdef HAS_vsnprintf_void
+ flags += 1L << 26;
+# endif
+# endif
+#else
+ flags += 1L << 24;
+# ifdef NO_snprintf
+ flags += 1L << 25;
+# ifdef HAS_sprintf_void
+ flags += 1L << 26;
+# endif
+# else
+# ifdef HAS_snprintf_void
+ flags += 1L << 26;
+# endif
+# endif
+#endif
+ return flags;
+}
+
+#ifdef DEBUG
+
+# ifndef verbose
+# define verbose 0
+# endif
+int ZLIB_INTERNAL z_verbose = verbose;
+
+void ZLIB_INTERNAL z_error (m)
+ char *m;
+{
+ fprintf(stderr, "%s\n", m);
+ exit(1);
+}
+#endif
+
+/* exported to allow conversion of error code to string for compress() and
+ * uncompress()
+ */
+const char * ZEXPORT zError(err)
+ int err;
+{
+ return ERR_MSG(err);
+}
+
+#if defined(_WIN32_WCE)
+ /* The Microsoft C Run-Time Library for Windows CE doesn't have
+ * errno. We define it as a global variable to simplify porting.
+ * Its value is always 0 and should not be used.
+ */
+ int errno = 0;
+#endif
+
+#ifndef HAVE_MEMCPY
+
+void ZLIB_INTERNAL zmemcpy(dest, source, len)
+ Bytef* dest;
+ const Bytef* source;
+ uInt len;
+{
+ if (len == 0) return;
+ do {
+ *dest++ = *source++; /* ??? to be unrolled */
+ } while (--len != 0);
+}
+
+int ZLIB_INTERNAL zmemcmp(s1, s2, len)
+ const Bytef* s1;
+ const Bytef* s2;
+ uInt len;
+{
+ uInt j;
+
+ for (j = 0; j < len; j++) {
+ if (s1[j] != s2[j]) return 2*(s1[j] > s2[j])-1;
+ }
+ return 0;
+}
+
+void ZLIB_INTERNAL zmemzero(dest, len)
+ Bytef* dest;
+ uInt len;
+{
+ if (len == 0) return;
+ do {
+ *dest++ = 0; /* ??? to be unrolled */
+ } while (--len != 0);
+}
+#endif
+
+
+#ifdef SYS16BIT
+
+#ifdef __TURBOC__
+/* Turbo C in 16-bit mode */
+
+# define MY_ZCALLOC
+
+/* Turbo C malloc() does not allow dynamic allocation of 64K bytes
+ * and farmalloc(64K) returns a pointer with an offset of 8, so we
+ * must fix the pointer. Warning: the pointer must be put back to its
+ * original form in order to free it, use zcfree().
+ */
+
+#define MAX_PTR 10
+/* 10*64K = 640K */
+
+local int next_ptr = 0;
+
+typedef struct ptr_table_s {
+ voidpf org_ptr;
+ voidpf new_ptr;
+} ptr_table;
+
+local ptr_table table[MAX_PTR];
+/* This table is used to remember the original form of pointers
+ * to large buffers (64K). Such pointers are normalized with a zero offset.
+ * Since MSDOS is not a preemptive multitasking OS, this table is not
+ * protected from concurrent access. This hack doesn't work anyway on
+ * a protected system like OS/2. Use Microsoft C instead.
+ */
+
+voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, unsigned items, unsigned size)
+{
+ voidpf buf = opaque; /* just to make some compilers happy */
+ ulg bsize = (ulg)items*size;
+
+ /* If we allocate less than 65520 bytes, we assume that farmalloc
+ * will return a usable pointer which doesn't have to be normalized.
+ */
+ if (bsize < 65520L) {
+ buf = farmalloc(bsize);
+ if (*(ush*)&buf != 0) return buf;
+ } else {
+ buf = farmalloc(bsize + 16L);
+ }
+ if (buf == NULL || next_ptr >= MAX_PTR) return NULL;
+ table[next_ptr].org_ptr = buf;
+
+ /* Normalize the pointer to seg:0 */
+ *((ush*)&buf+1) += ((ush)((uch*)buf-0) + 15) >> 4;
+ *(ush*)&buf = 0;
+ table[next_ptr++].new_ptr = buf;
+ return buf;
+}
+
+void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr)
+{
+ int n;
+ if (*(ush*)&ptr != 0) { /* object < 64K */
+ farfree(ptr);
+ return;
+ }
+ /* Find the original pointer */
+ for (n = 0; n < next_ptr; n++) {
+ if (ptr != table[n].new_ptr) continue;
+
+ farfree(table[n].org_ptr);
+ while (++n < next_ptr) {
+ table[n-1] = table[n];
+ }
+ next_ptr--;
+ return;
+ }
+ ptr = opaque; /* just to make some compilers happy */
+ Assert(0, "zcfree: ptr not found");
+}
+
+#endif /* __TURBOC__ */
+
+
+#ifdef M_I86
+/* Microsoft C in 16-bit mode */
+
+# define MY_ZCALLOC
+
+#if (!defined(_MSC_VER) || (_MSC_VER <= 600))
+# define _halloc halloc
+# define _hfree hfree
+#endif
+
+voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, uInt items, uInt size)
+{
+ if (opaque) opaque = 0; /* to make compiler happy */
+ return _halloc((long)items, size);
+}
+
+void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr)
+{
+ if (opaque) opaque = 0; /* to make compiler happy */
+ _hfree(ptr);
+}
+
+#endif /* M_I86 */
+
+#endif /* SYS16BIT */
+
+
+#ifndef MY_ZCALLOC /* Any system without a special alloc function */
+
+#ifndef STDC
+extern voidp malloc OF((uInt size));
+extern voidp calloc OF((uInt items, uInt size));
+extern void free OF((voidpf ptr));
+#endif
+
+voidpf ZLIB_INTERNAL zcalloc (opaque, items, size)
+ voidpf opaque;
+ unsigned items;
+ unsigned size;
+{
+ if (opaque) items += size - size; /* make compiler happy */
+ return sizeof(uInt) > 2 ? (voidpf)malloc(items * size) :
+ (voidpf)calloc(items, size);
+}
+
+void ZLIB_INTERNAL zcfree (opaque, ptr)
+ voidpf opaque;
+ voidpf ptr;
+{
+ free(ptr);
+ if (opaque) return; /* make compiler happy */
+}
+
+#endif /* MY_ZCALLOC */
diff --git a/test/monniaux/glpk-4.65/src/zlib/zutil.h b/test/monniaux/glpk-4.65/src/zlib/zutil.h
new file mode 100644
index 00000000..737bd38f
--- /dev/null
+++ b/test/monniaux/glpk-4.65/src/zlib/zutil.h
@@ -0,0 +1,93 @@
+/* zutil.h (internal interface of the zlib compression library) */
+
+/* Modified by Andrew Makhorin <mao@gnu.org>, April 2011 */
+
+/* Copyright (C) 1995-2010 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in
+ * zlib.h */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h. */
+
+#ifndef ZUTIL_H
+#define ZUTIL_H
+
+#define ZLIB_INTERNAL
+
+#include "zlib.h"
+
+#include <stddef.h>
+#include <string.h>
+#include <stdlib.h>
+
+#define local static
+
+typedef unsigned char uch;
+typedef uch uchf;
+typedef unsigned short ush;
+typedef ush ushf;
+typedef unsigned long ulg;
+
+extern const char * const z_errmsg[10];
+
+#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)]
+
+#define ERR_RETURN(strm, err) \
+ return (strm->msg = (char *)ERR_MSG(err), (err))
+
+#define DEF_WBITS MAX_WBITS
+
+#if MAX_MEM_LEVEL >= 8
+#define DEF_MEM_LEVEL 8
+#else
+#define DEF_MEM_LEVEL MAX_MEM_LEVEL
+#endif
+
+#define STORED_BLOCK 0
+#define STATIC_TREES 1
+#define DYN_TREES 2
+
+#define MIN_MATCH 3
+#define MAX_MATCH 258
+
+#define PRESET_DICT 0x20
+
+#define OS_CODE 0x03 /* assume Unix */
+
+#define HAVE_MEMCPY 1
+#define zmemcpy memcpy
+#define zmemzero(dest, len) memset(dest, 0, len)
+
+#ifdef DEBUG
+#include <stdio.h>
+extern int ZLIB_INTERNAL z_verbose;
+extern void ZLIB_INTERNAL z_error OF((char *m));
+#define Assert(cond, msg) { if(!(cond)) z_error(msg); }
+#define Trace(x) { if (z_verbose >= 0) fprintf x; }
+#define Tracev(x) { if (z_verbose > 0) fprintf x; }
+#define Tracevv(x) {if (z_verbose > 1) fprintf x; }
+#define Tracec(c, x) {if (z_verbose > 0 && (c)) fprintf x; }
+#define Tracecv(c, x) {if (z_verbose > 1 && (c)) fprintf x; }
+#else
+#define Assert(cond, msg)
+#define Trace(x)
+#define Tracev(x)
+#define Tracevv(x)
+#define Tracec(c, x)
+#define Tracecv(c, x)
+#endif
+
+voidpf ZLIB_INTERNAL zcalloc OF((voidpf opaque, unsigned items,
+ unsigned size));
+void ZLIB_INTERNAL zcfree OF((voidpf opaque, voidpf ptr));
+
+#define ZALLOC(strm, items, size) \
+ (*((strm)->zalloc))((strm)->opaque, (items), (size))
+#define ZFREE(strm, addr) \
+ (*((strm)->zfree))((strm)->opaque, (voidpf)(addr))
+#define TRY_FREE(s, p) { if (p) ZFREE(s, p); }
+
+#endif
+
+/* eof */
diff --git a/test/monniaux/heapsort/Makefile b/test/monniaux/heapsort/Makefile
new file mode 100644
index 00000000..69f0c3ca
--- /dev/null
+++ b/test/monniaux/heapsort/Makefile
@@ -0,0 +1,3 @@
+TARGET=heapsort
+
+include ../rules.mk
diff --git a/test/monniaux/heapsort/heapsort_run.c b/test/monniaux/heapsort/heapsort_run.c
index 053822a3..8f2d3fe0 100644
--- a/test/monniaux/heapsort/heapsort_run.c
+++ b/test/monniaux/heapsort/heapsort_run.c
@@ -13,7 +13,7 @@ int main (void) {
heapsort(vec, len);
heapsort_time = get_cycle() - heapsort_time;
printf("sorted=%s\n"
- "heapsort_time:%" PRIu64 "\n",
+ "time cycles:%" PRIu64 "\n",
data_vec_is_sorted(vec, len)?"true":"false",
heapsort_time);
free(vec);
diff --git a/test/monniaux/heapsort/make.proto b/test/monniaux/heapsort/make.proto
deleted file mode 100644
index 0b5972d6..00000000
--- a/test/monniaux/heapsort/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-objdeps: [{name: heapsort_run, compiler: gcc}]
-target: heapsort
-measures: [heapsort_time]
diff --git a/test/monniaux/heptagon_radio_transmitter/Makefile b/test/monniaux/heptagon_radio_transmitter/Makefile
new file mode 100644
index 00000000..75420a10
--- /dev/null
+++ b/test/monniaux/heptagon_radio_transmitter/Makefile
@@ -0,0 +1,3 @@
+TARGET=radiotrans
+
+include ../rules.mk
diff --git a/test/monniaux/idea/Makefile b/test/monniaux/idea/Makefile
new file mode 100644
index 00000000..96e1999d
--- /dev/null
+++ b/test/monniaux/idea/Makefile
@@ -0,0 +1,3 @@
+TARGET=idea
+
+include ../rules.mk
diff --git a/test/monniaux/idea/make.proto b/test/monniaux/idea/make.proto
deleted file mode 100644
index 0e147514..00000000
--- a/test/monniaux/idea/make.proto
+++ /dev/null
@@ -1,2 +0,0 @@
-target: idea
-measures: [cycles]
diff --git a/test/monniaux/jpeg-6b/Makefile b/test/monniaux/jpeg-6b/Makefile
index bd4ba992..2bec9bb7 100644
--- a/test/monniaux/jpeg-6b/Makefile
+++ b/test/monniaux/jpeg-6b/Makefile
@@ -1,319 +1,60 @@
-# Generated automatically from makefile.cfg by configure.
-# Makefile for Independent JPEG Group's software
+TARGET=jpeg-6b
-# makefile.cfg is edited by configure to produce a custom Makefile.
-
-# Read installation instructions before saying "make" !!
-
-# For compiling with source and object files in different directories.
-srcdir = .
-
-# Where to install the programs and man pages.
-prefix = /usr/local
-exec_prefix = ${prefix}
-bindir = $(exec_prefix)/bin
-libdir = $(exec_prefix)/lib
-includedir = $(prefix)/include
-binprefix =
-manprefix =
-manext = 1
-mandir = $(prefix)/man/man$(manext)
-
-# The name of your C compiler:
-CC= gcc
-
-# You may need to adjust these cc options:
-CFLAGS= -O2 -I$(srcdir)
-# Generally, we recommend defining any configuration symbols in jconfig.h,
-# NOT via -D switches here.
-# However, any special defines for ansi2knr.c may be included here:
-ANSI2KNRFLAGS=
-
-# Link-time cc options:
-LDFLAGS=
-
-# To link any special libraries, add the necessary -l commands here.
-LDLIBS=
-
-# If using GNU libtool, LIBTOOL references it; if not, LIBTOOL is empty.
-LIBTOOL =
-# $(O) expands to "lo" if using libtool, plain "o" if not.
-# Similarly, $(A) expands to "la" or "a".
-O = o
-A = a
-
-# Library version ID; libtool uses this for the shared library version number.
-# Note: we suggest this match the macro of the same name in jpeglib.h.
-JPEG_LIB_VERSION = 62
-
-# Put here the object file name for the correct system-dependent memory
-# manager file. For Unix this is usually jmemnobs.o, but you may want
-# to use jmemansi.o or jmemname.o if you have limited swap space.
-SYSDEPMEM= jmemnobs.$(O)
-
-# miscellaneous OS-dependent stuff
-SHELL= /bin/sh
-# linker
-LN= $(CC)
-# file deletion command
-RM= rm -f
-# directory creation command
-MKDIR= mkdir
-# library (.a) file creation command
-AR= ar rc
-# second step in .a creation (use "touch" if not needed)
-AR2= ranlib
-# installation program
-INSTALL= /usr/bin/install -c
-INSTALL_PROGRAM= ${INSTALL}
-INSTALL_LIB= ${INSTALL} -m 644
-INSTALL_DATA= ${INSTALL} -m 644
-
-# End of configurable options.
-
-
-# source files: JPEG library proper
-LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \
+ALL_CFILES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \
jcinit.c jcmainct.c jcmarker.c jcmaster.c jcomapi.c jcparam.c \
jcphuff.c jcprepct.c jcsample.c jctrans.c jdapimin.c jdapistd.c \
jdatadst.c jdatasrc.c jdcoefct.c jdcolor.c jddctmgr.c jdhuff.c \
jdinput.c jdmainct.c jdmarker.c jdmaster.c jdmerge.c jdphuff.c \
jdpostct.c jdsample.c jdtrans.c jerror.c jfdctflt.c jfdctfst.c \
jfdctint.c jidctflt.c jidctfst.c jidctint.c jidctred.c jquant1.c \
- jquant2.c jutils.c jmemmgr.c
-# memmgr back ends: compile only one of these into a working library
-SYSDEPSOURCES= jmemansi.c jmemname.c jmemnobs.c jmemdos.c jmemmac.c
-# source files: cjpeg/djpeg/jpegtran applications, also rdjpgcom/wrjpgcom
-APPSOURCES= cjpeg.c djpeg.c jpegtran.c rdjpgcom.c wrjpgcom.c cdjpeg.c \
- rdcolmap.c rdswitch.c transupp.c rdppm.c wrppm.c rdgif.c wrgif.c \
- rdtarga.c wrtarga.c rdbmp.c wrbmp.c rdrle.c wrrle.c
-SOURCES= $(LIBSOURCES) $(SYSDEPSOURCES) $(APPSOURCES)
-# files included by source files
-INCLUDES= jchuff.h jdhuff.h jdct.h jerror.h jinclude.h jmemsys.h jmorecfg.h \
- jpegint.h jpeglib.h jversion.h cdjpeg.h cderror.h transupp.h
-# documentation, test, and support files
-DOCS= README install.doc usage.doc cjpeg.1 djpeg.1 jpegtran.1 rdjpgcom.1 \
- wrjpgcom.1 wizard.doc example.c libjpeg.doc structure.doc \
- coderules.doc filelist.doc change.log
-MKFILES= configure makefile.cfg makefile.ansi makefile.unix makefile.bcc \
- makefile.mc6 makefile.dj makefile.wat makefile.vc makelib.ds \
- makeapps.ds makeproj.mac makcjpeg.st makdjpeg.st makljpeg.st \
- maktjpeg.st makefile.manx makefile.sas makefile.mms makefile.vms \
- makvms.opt
-CONFIGFILES= jconfig.cfg jconfig.bcc jconfig.mc6 jconfig.dj jconfig.wat \
- jconfig.vc jconfig.mac jconfig.st jconfig.manx jconfig.sas \
- jconfig.vms
-CONFIGUREFILES= config.guess config.sub install-sh ltconfig ltmain.sh
-OTHERFILES= jconfig.doc ckconfig.c ansi2knr.c ansi2knr.1 jmemdosa.asm
-TESTFILES= testorig.jpg testimg.ppm testimg.bmp testimg.jpg testprog.jpg \
- testimgp.jpg
-DISTFILES= $(DOCS) $(MKFILES) $(CONFIGFILES) $(SOURCES) $(INCLUDES) \
- $(CONFIGUREFILES) $(OTHERFILES) $(TESTFILES)
-# library object files common to compression and decompression
-COMOBJECTS= jcomapi.$(O) jutils.$(O) jerror.$(O) jmemmgr.$(O) $(SYSDEPMEM)
-# compression library object files
-CLIBOBJECTS= jcapimin.$(O) jcapistd.$(O) jctrans.$(O) jcparam.$(O) \
- jdatadst.$(O) jcinit.$(O) jcmaster.$(O) jcmarker.$(O) jcmainct.$(O) \
- jcprepct.$(O) jccoefct.$(O) jccolor.$(O) jcsample.$(O) jchuff.$(O) \
- jcphuff.$(O) jcdctmgr.$(O) jfdctfst.$(O) jfdctflt.$(O) \
- jfdctint.$(O)
-# decompression library object files
-DLIBOBJECTS= jdapimin.$(O) jdapistd.$(O) jdtrans.$(O) jdatasrc.$(O) \
- jdmaster.$(O) jdinput.$(O) jdmarker.$(O) jdhuff.$(O) jdphuff.$(O) \
- jdmainct.$(O) jdcoefct.$(O) jdpostct.$(O) jddctmgr.$(O) \
- jidctfst.$(O) jidctflt.$(O) jidctint.$(O) jidctred.$(O) \
- jdsample.$(O) jdcolor.$(O) jquant1.$(O) jquant2.$(O) jdmerge.$(O)
-# These objectfiles are included in libjpeg.a
-LIBOBJECTS= $(CLIBOBJECTS) $(DLIBOBJECTS) $(COMOBJECTS)
-# object files for sample applications (excluding library files)
-COBJECTS= cjpeg.$(O) rdppm.$(O) rdgif.$(O) rdtarga.$(O) rdrle.$(O) \
- rdbmp.$(O) rdswitch.$(O) cdjpeg.$(O)
-DOBJECTS= djpeg.$(O) wrppm.$(O) wrgif.$(O) wrtarga.$(O) wrrle.$(O) \
- wrbmp.$(O) rdcolmap.$(O) cdjpeg.$(O)
-TROBJECTS= jpegtran.$(O) rdswitch.$(O) cdjpeg.$(O) transupp.$(O)
-
-
-all: libjpeg.$(A) cjpeg djpeg jpegtran rdjpgcom wrjpgcom
-
-# Special compilation rules to support ansi2knr and libtool.
-.SUFFIXES: .lo .la
-
-# How to compile with libtool.
-# .c.lo:
-# $(LIBTOOL) --mode=compile $(CC) $(CFLAGS) -c $(srcdir)/$*.c
-
-# How to use ansi2knr, when not using libtool.
-# .c.o:
-# ./ansi2knr $(srcdir)/$*.c knr/$*.c
-# $(CC) $(CFLAGS) -c knr/$*.c
-# $(RM) knr/$*.c
-
-# How to use ansi2knr AND libtool.
-# .c.lo:
-# ./ansi2knr $(srcdir)/$*.c knr/$*.c
-# $(LIBTOOL) --mode=compile $(CC) $(CFLAGS) -c knr/$*.c
-# $(RM) knr/$*.c
-
-ansi2knr: ansi2knr.c
- $(CC) $(CFLAGS) $(ANSI2KNRFLAGS) -o ansi2knr $(srcdir)/ansi2knr.c
- $(MKDIR) knr
-
-# the library:
-
-# without libtool:
-libjpeg.a: $(LIBOBJECTS)
- $(RM) libjpeg.a
- $(AR) libjpeg.a $(LIBOBJECTS)
- $(AR2) libjpeg.a
-
-# with libtool:
-libjpeg.la: $(LIBOBJECTS)
- $(LIBTOOL) --mode=link $(CC) -o libjpeg.la $(LIBOBJECTS) \
- -rpath $(libdir) -version-info $(JPEG_LIB_VERSION)
-
-# sample programs:
-
-cjpeg: $(COBJECTS) libjpeg.$(A)
- $(LN) $(LDFLAGS) -o cjpeg $(COBJECTS) libjpeg.$(A) $(LDLIBS)
-
-djpeg: $(DOBJECTS) libjpeg.$(A)
- $(LN) $(LDFLAGS) -o djpeg $(DOBJECTS) libjpeg.$(A) $(LDLIBS)
-
-jpegtran: $(TROBJECTS) libjpeg.$(A)
- $(LN) $(LDFLAGS) -o jpegtran $(TROBJECTS) libjpeg.$(A) $(LDLIBS)
-
-rdjpgcom: rdjpgcom.$(O)
- $(LN) $(LDFLAGS) -o rdjpgcom rdjpgcom.$(O) $(LDLIBS)
-
-wrjpgcom: wrjpgcom.$(O)
- $(LN) $(LDFLAGS) -o wrjpgcom wrjpgcom.$(O) $(LDLIBS)
-
-# Installation rules:
-
-install: cjpeg djpeg jpegtran rdjpgcom wrjpgcom
- $(INSTALL_PROGRAM) cjpeg $(bindir)/$(binprefix)cjpeg
- $(INSTALL_PROGRAM) djpeg $(bindir)/$(binprefix)djpeg
- $(INSTALL_PROGRAM) jpegtran $(bindir)/$(binprefix)jpegtran
- $(INSTALL_PROGRAM) rdjpgcom $(bindir)/$(binprefix)rdjpgcom
- $(INSTALL_PROGRAM) wrjpgcom $(bindir)/$(binprefix)wrjpgcom
- $(INSTALL_DATA) $(srcdir)/cjpeg.1 $(mandir)/$(manprefix)cjpeg.$(manext)
- $(INSTALL_DATA) $(srcdir)/djpeg.1 $(mandir)/$(manprefix)djpeg.$(manext)
- $(INSTALL_DATA) $(srcdir)/jpegtran.1 $(mandir)/$(manprefix)jpegtran.$(manext)
- $(INSTALL_DATA) $(srcdir)/rdjpgcom.1 $(mandir)/$(manprefix)rdjpgcom.$(manext)
- $(INSTALL_DATA) $(srcdir)/wrjpgcom.1 $(mandir)/$(manprefix)wrjpgcom.$(manext)
-
-install-lib: libjpeg.$(A) install-headers
- $(INSTALL_LIB) libjpeg.$(A) $(libdir)/$(binprefix)libjpeg.$(A)
-
-install-headers: jconfig.h
- $(INSTALL_DATA) jconfig.h $(includedir)/jconfig.h
- $(INSTALL_DATA) $(srcdir)/jpeglib.h $(includedir)/jpeglib.h
- $(INSTALL_DATA) $(srcdir)/jmorecfg.h $(includedir)/jmorecfg.h
- $(INSTALL_DATA) $(srcdir)/jerror.h $(includedir)/jerror.h
-
-clean:
- $(RM) *.o *.lo libjpeg.a libjpeg.la
- $(RM) cjpeg djpeg jpegtran rdjpgcom wrjpgcom
- $(RM) ansi2knr core testout* config.log config.status
- $(RM) -r knr .libs _libs
-
-distclean: clean
- $(RM) Makefile jconfig.h libtool config.cache
-
-test: cjpeg djpeg jpegtran
- $(RM) testout*
- ./djpeg -dct int -ppm -outfile testout.ppm $(srcdir)/testorig.jpg
- ./djpeg -dct int -bmp -colors 256 -outfile testout.bmp $(srcdir)/testorig.jpg
- ./cjpeg -dct int -outfile testout.jpg $(srcdir)/testimg.ppm
- ./djpeg -dct int -ppm -outfile testoutp.ppm $(srcdir)/testprog.jpg
- ./cjpeg -dct int -progressive -opt -outfile testoutp.jpg $(srcdir)/testimg.ppm
- ./jpegtran -outfile testoutt.jpg $(srcdir)/testprog.jpg
- cmp $(srcdir)/testimg.ppm testout.ppm
- cmp $(srcdir)/testimg.bmp testout.bmp
- cmp $(srcdir)/testimg.jpg testout.jpg
- cmp $(srcdir)/testimg.ppm testoutp.ppm
- cmp $(srcdir)/testimgp.jpg testoutp.jpg
- cmp $(srcdir)/testorig.jpg testoutt.jpg
-
-check: test
-
-# Mistake catcher:
-
-jconfig.h: jconfig.doc
- echo You must prepare a system-dependent jconfig.h file.
- echo Please read the installation directions in install.doc.
- exit 1
-
-# GNU Make likes to know which target names are not really files to be made:
-.PHONY: all install install-lib install-headers clean distclean test check
-
-
-jcapimin.$(O): jcapimin.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcapistd.$(O): jcapistd.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jccoefct.$(O): jccoefct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jccolor.$(O): jccolor.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcdctmgr.$(O): jcdctmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jchuff.$(O): jchuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jchuff.h
-jcinit.$(O): jcinit.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcmainct.$(O): jcmainct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcmarker.$(O): jcmarker.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcmaster.$(O): jcmaster.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcomapi.$(O): jcomapi.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcparam.$(O): jcparam.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcphuff.$(O): jcphuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jchuff.h
-jcprepct.$(O): jcprepct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jcsample.$(O): jcsample.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jctrans.$(O): jctrans.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdapimin.$(O): jdapimin.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdapistd.$(O): jdapistd.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdatadst.$(O): jdatadst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h
-jdatasrc.$(O): jdatasrc.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h
-jdcoefct.$(O): jdcoefct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdcolor.$(O): jdcolor.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jddctmgr.$(O): jddctmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jdhuff.$(O): jdhuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdhuff.h
-jdinput.$(O): jdinput.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdmainct.$(O): jdmainct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdmarker.$(O): jdmarker.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdmaster.$(O): jdmaster.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdmerge.$(O): jdmerge.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdphuff.$(O): jdphuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdhuff.h
-jdpostct.$(O): jdpostct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdsample.$(O): jdsample.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jdtrans.$(O): jdtrans.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jerror.$(O): jerror.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jversion.h jerror.h
-jfdctflt.$(O): jfdctflt.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jfdctfst.$(O): jfdctfst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jfdctint.$(O): jfdctint.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jidctflt.$(O): jidctflt.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jidctfst.$(O): jidctfst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jidctint.$(O): jidctint.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jidctred.$(O): jidctred.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
-jquant1.$(O): jquant1.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jquant2.$(O): jquant2.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jutils.$(O): jutils.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
-jmemmgr.$(O): jmemmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-jmemansi.$(O): jmemansi.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-jmemname.$(O): jmemname.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-jmemnobs.$(O): jmemnobs.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-jmemdos.$(O): jmemdos.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-jmemmac.$(O): jmemmac.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
-cjpeg.$(O): cjpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h jversion.h
-djpeg.$(O): djpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h jversion.h
-jpegtran.$(O): jpegtran.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h transupp.h jversion.h
-rdjpgcom.$(O): rdjpgcom.c jinclude.h jconfig.h
-wrjpgcom.$(O): wrjpgcom.c jinclude.h jconfig.h
-cdjpeg.$(O): cdjpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdcolmap.$(O): rdcolmap.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdswitch.$(O): rdswitch.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-transupp.$(O): transupp.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h transupp.h
-rdppm.$(O): rdppm.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-wrppm.$(O): wrppm.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdgif.$(O): rdgif.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-wrgif.$(O): wrgif.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdtarga.$(O): rdtarga.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-wrtarga.$(O): wrtarga.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdbmp.$(O): rdbmp.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-wrbmp.$(O): wrbmp.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-rdrle.$(O): rdrle.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
-wrrle.$(O): wrrle.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+ jquant2.c jutils.c jmemmgr.c jmemansi.c
+ALL_CFILES+=rdppm.c rdgif.c rdtarga.c rdrle.c rdbmp.c rdswitch.c cdjpeg.c wrppm.c wrgif.c wrtarga.c wrrle.c wrbmp.c rdcolmap.c
+ALL_CFILES+=cjpeg.c
+
+EXECUTE_ARGS=-dct int -outfile __BASE__.jpg testimg.ppm 2> __BASE__.out
+
+include ../rules.mk
+
+#all: cjpeg.gcc.k1c.out djpeg.gcc.k1c.out cjpeg.gcc.o1.k1c.out djpeg.gcc.o1.k1c.out cjpeg.ccomp.k1c.out djpeg.ccomp.k1c.out
+#
+#LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \
+# jcinit.c jcmainct.c jcmarker.c jcmaster.c jcomapi.c jcparam.c \
+# jcphuff.c jcprepct.c jcsample.c jctrans.c jdapimin.c jdapistd.c \
+# jdatadst.c jdatasrc.c jdcoefct.c jdcolor.c jddctmgr.c jdhuff.c \
+# jdinput.c jdmainct.c jdmarker.c jdmaster.c jdmerge.c jdphuff.c \
+# jdpostct.c jdsample.c jdtrans.c jerror.c jfdctflt.c jfdctfst.c \
+# jfdctint.c jidctflt.c jidctfst.c jidctint.c jidctred.c jquant1.c \
+# jquant2.c jutils.c jmemmgr.c jmemansi.c
+#CSOURCES=$(LIBSOURCES) rdppm.c rdgif.c rdtarga.c rdrle.c rdbmp.c rdswitch.c cdjpeg.c wrppm.c wrgif.c wrtarga.c wrrle.c wrbmp.c rdcolmap.c
+#
+#LIB_K1C_GCC_OFILES=$(CSOURCES:.c=.gcc.k1c.o)
+#LIB_K1C_GCC_O1_OFILES=$(CSOURCES:.c=.gcc.o1.k1c.o)
+#LIB_K1C_CCOMP_OFILES=$(CSOURCES:.c=.ccomp.k1c.o)
+#
+#include ../rules.mk
+#
+#cjpeg.gcc.k1c: $(LIB_K1C_GCC_OFILES) cjpeg.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ ../clock.gcc.k1c.o
+#djpeg.gcc.k1c: $(LIB_K1C_GCC_OFILES) djpeg.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ ../clock.gcc.k1c.o
+#
+#cjpeg.gcc.o1.k1c: $(LIB_K1C_GCC_O1_OFILES) cjpeg.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ ../clock.gcc.k1c.o
+#djpeg.gcc.o1.k1c: $(LIB_K1C_GCC_O1_OFILES) djpeg.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ ../clock.gcc.k1c.o
+#
+#cjpeg.ccomp.k1c: $(LIB_K1C_CCOMP_OFILES) cjpeg.gcc.k1c.o
+# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ ../clock.gcc.k1c.o
+#djpeg.ccomp.k1c: $(LIB_K1C_CCOMP_OFILES) djpeg.gcc.k1c.o
+# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ ../clock.gcc.k1c.o
+#
+#
+#djpeg.%.out: djpeg.%
+# $(EXECUTE_CYCLES) $< -dct int -ppm -outfile $@.ppm testorig.jpg 2> $@
+# cmp $@.ppm testimg.ppm 2>> $@
+#
+#cjpeg.%.out: cjpeg.%
+# $(EXECUTE_CYCLES) $< -dct int -outfile $@.jpg testimg.ppm 2> $@
+# cmp $@.jpg testimg.jpg 2>> $@
+#
+#.SECONDARY:
diff --git a/test/monniaux/jpeg-6b/Makefile.orig b/test/monniaux/jpeg-6b/Makefile.orig
new file mode 100644
index 00000000..bd4ba992
--- /dev/null
+++ b/test/monniaux/jpeg-6b/Makefile.orig
@@ -0,0 +1,319 @@
+# Generated automatically from makefile.cfg by configure.
+# Makefile for Independent JPEG Group's software
+
+# makefile.cfg is edited by configure to produce a custom Makefile.
+
+# Read installation instructions before saying "make" !!
+
+# For compiling with source and object files in different directories.
+srcdir = .
+
+# Where to install the programs and man pages.
+prefix = /usr/local
+exec_prefix = ${prefix}
+bindir = $(exec_prefix)/bin
+libdir = $(exec_prefix)/lib
+includedir = $(prefix)/include
+binprefix =
+manprefix =
+manext = 1
+mandir = $(prefix)/man/man$(manext)
+
+# The name of your C compiler:
+CC= gcc
+
+# You may need to adjust these cc options:
+CFLAGS= -O2 -I$(srcdir)
+# Generally, we recommend defining any configuration symbols in jconfig.h,
+# NOT via -D switches here.
+# However, any special defines for ansi2knr.c may be included here:
+ANSI2KNRFLAGS=
+
+# Link-time cc options:
+LDFLAGS=
+
+# To link any special libraries, add the necessary -l commands here.
+LDLIBS=
+
+# If using GNU libtool, LIBTOOL references it; if not, LIBTOOL is empty.
+LIBTOOL =
+# $(O) expands to "lo" if using libtool, plain "o" if not.
+# Similarly, $(A) expands to "la" or "a".
+O = o
+A = a
+
+# Library version ID; libtool uses this for the shared library version number.
+# Note: we suggest this match the macro of the same name in jpeglib.h.
+JPEG_LIB_VERSION = 62
+
+# Put here the object file name for the correct system-dependent memory
+# manager file. For Unix this is usually jmemnobs.o, but you may want
+# to use jmemansi.o or jmemname.o if you have limited swap space.
+SYSDEPMEM= jmemnobs.$(O)
+
+# miscellaneous OS-dependent stuff
+SHELL= /bin/sh
+# linker
+LN= $(CC)
+# file deletion command
+RM= rm -f
+# directory creation command
+MKDIR= mkdir
+# library (.a) file creation command
+AR= ar rc
+# second step in .a creation (use "touch" if not needed)
+AR2= ranlib
+# installation program
+INSTALL= /usr/bin/install -c
+INSTALL_PROGRAM= ${INSTALL}
+INSTALL_LIB= ${INSTALL} -m 644
+INSTALL_DATA= ${INSTALL} -m 644
+
+# End of configurable options.
+
+
+# source files: JPEG library proper
+LIBSOURCES= jcapimin.c jcapistd.c jccoefct.c jccolor.c jcdctmgr.c jchuff.c \
+ jcinit.c jcmainct.c jcmarker.c jcmaster.c jcomapi.c jcparam.c \
+ jcphuff.c jcprepct.c jcsample.c jctrans.c jdapimin.c jdapistd.c \
+ jdatadst.c jdatasrc.c jdcoefct.c jdcolor.c jddctmgr.c jdhuff.c \
+ jdinput.c jdmainct.c jdmarker.c jdmaster.c jdmerge.c jdphuff.c \
+ jdpostct.c jdsample.c jdtrans.c jerror.c jfdctflt.c jfdctfst.c \
+ jfdctint.c jidctflt.c jidctfst.c jidctint.c jidctred.c jquant1.c \
+ jquant2.c jutils.c jmemmgr.c
+# memmgr back ends: compile only one of these into a working library
+SYSDEPSOURCES= jmemansi.c jmemname.c jmemnobs.c jmemdos.c jmemmac.c
+# source files: cjpeg/djpeg/jpegtran applications, also rdjpgcom/wrjpgcom
+APPSOURCES= cjpeg.c djpeg.c jpegtran.c rdjpgcom.c wrjpgcom.c cdjpeg.c \
+ rdcolmap.c rdswitch.c transupp.c rdppm.c wrppm.c rdgif.c wrgif.c \
+ rdtarga.c wrtarga.c rdbmp.c wrbmp.c rdrle.c wrrle.c
+SOURCES= $(LIBSOURCES) $(SYSDEPSOURCES) $(APPSOURCES)
+# files included by source files
+INCLUDES= jchuff.h jdhuff.h jdct.h jerror.h jinclude.h jmemsys.h jmorecfg.h \
+ jpegint.h jpeglib.h jversion.h cdjpeg.h cderror.h transupp.h
+# documentation, test, and support files
+DOCS= README install.doc usage.doc cjpeg.1 djpeg.1 jpegtran.1 rdjpgcom.1 \
+ wrjpgcom.1 wizard.doc example.c libjpeg.doc structure.doc \
+ coderules.doc filelist.doc change.log
+MKFILES= configure makefile.cfg makefile.ansi makefile.unix makefile.bcc \
+ makefile.mc6 makefile.dj makefile.wat makefile.vc makelib.ds \
+ makeapps.ds makeproj.mac makcjpeg.st makdjpeg.st makljpeg.st \
+ maktjpeg.st makefile.manx makefile.sas makefile.mms makefile.vms \
+ makvms.opt
+CONFIGFILES= jconfig.cfg jconfig.bcc jconfig.mc6 jconfig.dj jconfig.wat \
+ jconfig.vc jconfig.mac jconfig.st jconfig.manx jconfig.sas \
+ jconfig.vms
+CONFIGUREFILES= config.guess config.sub install-sh ltconfig ltmain.sh
+OTHERFILES= jconfig.doc ckconfig.c ansi2knr.c ansi2knr.1 jmemdosa.asm
+TESTFILES= testorig.jpg testimg.ppm testimg.bmp testimg.jpg testprog.jpg \
+ testimgp.jpg
+DISTFILES= $(DOCS) $(MKFILES) $(CONFIGFILES) $(SOURCES) $(INCLUDES) \
+ $(CONFIGUREFILES) $(OTHERFILES) $(TESTFILES)
+# library object files common to compression and decompression
+COMOBJECTS= jcomapi.$(O) jutils.$(O) jerror.$(O) jmemmgr.$(O) $(SYSDEPMEM)
+# compression library object files
+CLIBOBJECTS= jcapimin.$(O) jcapistd.$(O) jctrans.$(O) jcparam.$(O) \
+ jdatadst.$(O) jcinit.$(O) jcmaster.$(O) jcmarker.$(O) jcmainct.$(O) \
+ jcprepct.$(O) jccoefct.$(O) jccolor.$(O) jcsample.$(O) jchuff.$(O) \
+ jcphuff.$(O) jcdctmgr.$(O) jfdctfst.$(O) jfdctflt.$(O) \
+ jfdctint.$(O)
+# decompression library object files
+DLIBOBJECTS= jdapimin.$(O) jdapistd.$(O) jdtrans.$(O) jdatasrc.$(O) \
+ jdmaster.$(O) jdinput.$(O) jdmarker.$(O) jdhuff.$(O) jdphuff.$(O) \
+ jdmainct.$(O) jdcoefct.$(O) jdpostct.$(O) jddctmgr.$(O) \
+ jidctfst.$(O) jidctflt.$(O) jidctint.$(O) jidctred.$(O) \
+ jdsample.$(O) jdcolor.$(O) jquant1.$(O) jquant2.$(O) jdmerge.$(O)
+# These objectfiles are included in libjpeg.a
+LIBOBJECTS= $(CLIBOBJECTS) $(DLIBOBJECTS) $(COMOBJECTS)
+# object files for sample applications (excluding library files)
+COBJECTS= cjpeg.$(O) rdppm.$(O) rdgif.$(O) rdtarga.$(O) rdrle.$(O) \
+ rdbmp.$(O) rdswitch.$(O) cdjpeg.$(O)
+DOBJECTS= djpeg.$(O) wrppm.$(O) wrgif.$(O) wrtarga.$(O) wrrle.$(O) \
+ wrbmp.$(O) rdcolmap.$(O) cdjpeg.$(O)
+TROBJECTS= jpegtran.$(O) rdswitch.$(O) cdjpeg.$(O) transupp.$(O)
+
+
+all: libjpeg.$(A) cjpeg djpeg jpegtran rdjpgcom wrjpgcom
+
+# Special compilation rules to support ansi2knr and libtool.
+.SUFFIXES: .lo .la
+
+# How to compile with libtool.
+# .c.lo:
+# $(LIBTOOL) --mode=compile $(CC) $(CFLAGS) -c $(srcdir)/$*.c
+
+# How to use ansi2knr, when not using libtool.
+# .c.o:
+# ./ansi2knr $(srcdir)/$*.c knr/$*.c
+# $(CC) $(CFLAGS) -c knr/$*.c
+# $(RM) knr/$*.c
+
+# How to use ansi2knr AND libtool.
+# .c.lo:
+# ./ansi2knr $(srcdir)/$*.c knr/$*.c
+# $(LIBTOOL) --mode=compile $(CC) $(CFLAGS) -c knr/$*.c
+# $(RM) knr/$*.c
+
+ansi2knr: ansi2knr.c
+ $(CC) $(CFLAGS) $(ANSI2KNRFLAGS) -o ansi2knr $(srcdir)/ansi2knr.c
+ $(MKDIR) knr
+
+# the library:
+
+# without libtool:
+libjpeg.a: $(LIBOBJECTS)
+ $(RM) libjpeg.a
+ $(AR) libjpeg.a $(LIBOBJECTS)
+ $(AR2) libjpeg.a
+
+# with libtool:
+libjpeg.la: $(LIBOBJECTS)
+ $(LIBTOOL) --mode=link $(CC) -o libjpeg.la $(LIBOBJECTS) \
+ -rpath $(libdir) -version-info $(JPEG_LIB_VERSION)
+
+# sample programs:
+
+cjpeg: $(COBJECTS) libjpeg.$(A)
+ $(LN) $(LDFLAGS) -o cjpeg $(COBJECTS) libjpeg.$(A) $(LDLIBS)
+
+djpeg: $(DOBJECTS) libjpeg.$(A)
+ $(LN) $(LDFLAGS) -o djpeg $(DOBJECTS) libjpeg.$(A) $(LDLIBS)
+
+jpegtran: $(TROBJECTS) libjpeg.$(A)
+ $(LN) $(LDFLAGS) -o jpegtran $(TROBJECTS) libjpeg.$(A) $(LDLIBS)
+
+rdjpgcom: rdjpgcom.$(O)
+ $(LN) $(LDFLAGS) -o rdjpgcom rdjpgcom.$(O) $(LDLIBS)
+
+wrjpgcom: wrjpgcom.$(O)
+ $(LN) $(LDFLAGS) -o wrjpgcom wrjpgcom.$(O) $(LDLIBS)
+
+# Installation rules:
+
+install: cjpeg djpeg jpegtran rdjpgcom wrjpgcom
+ $(INSTALL_PROGRAM) cjpeg $(bindir)/$(binprefix)cjpeg
+ $(INSTALL_PROGRAM) djpeg $(bindir)/$(binprefix)djpeg
+ $(INSTALL_PROGRAM) jpegtran $(bindir)/$(binprefix)jpegtran
+ $(INSTALL_PROGRAM) rdjpgcom $(bindir)/$(binprefix)rdjpgcom
+ $(INSTALL_PROGRAM) wrjpgcom $(bindir)/$(binprefix)wrjpgcom
+ $(INSTALL_DATA) $(srcdir)/cjpeg.1 $(mandir)/$(manprefix)cjpeg.$(manext)
+ $(INSTALL_DATA) $(srcdir)/djpeg.1 $(mandir)/$(manprefix)djpeg.$(manext)
+ $(INSTALL_DATA) $(srcdir)/jpegtran.1 $(mandir)/$(manprefix)jpegtran.$(manext)
+ $(INSTALL_DATA) $(srcdir)/rdjpgcom.1 $(mandir)/$(manprefix)rdjpgcom.$(manext)
+ $(INSTALL_DATA) $(srcdir)/wrjpgcom.1 $(mandir)/$(manprefix)wrjpgcom.$(manext)
+
+install-lib: libjpeg.$(A) install-headers
+ $(INSTALL_LIB) libjpeg.$(A) $(libdir)/$(binprefix)libjpeg.$(A)
+
+install-headers: jconfig.h
+ $(INSTALL_DATA) jconfig.h $(includedir)/jconfig.h
+ $(INSTALL_DATA) $(srcdir)/jpeglib.h $(includedir)/jpeglib.h
+ $(INSTALL_DATA) $(srcdir)/jmorecfg.h $(includedir)/jmorecfg.h
+ $(INSTALL_DATA) $(srcdir)/jerror.h $(includedir)/jerror.h
+
+clean:
+ $(RM) *.o *.lo libjpeg.a libjpeg.la
+ $(RM) cjpeg djpeg jpegtran rdjpgcom wrjpgcom
+ $(RM) ansi2knr core testout* config.log config.status
+ $(RM) -r knr .libs _libs
+
+distclean: clean
+ $(RM) Makefile jconfig.h libtool config.cache
+
+test: cjpeg djpeg jpegtran
+ $(RM) testout*
+ ./djpeg -dct int -ppm -outfile testout.ppm $(srcdir)/testorig.jpg
+ ./djpeg -dct int -bmp -colors 256 -outfile testout.bmp $(srcdir)/testorig.jpg
+ ./cjpeg -dct int -outfile testout.jpg $(srcdir)/testimg.ppm
+ ./djpeg -dct int -ppm -outfile testoutp.ppm $(srcdir)/testprog.jpg
+ ./cjpeg -dct int -progressive -opt -outfile testoutp.jpg $(srcdir)/testimg.ppm
+ ./jpegtran -outfile testoutt.jpg $(srcdir)/testprog.jpg
+ cmp $(srcdir)/testimg.ppm testout.ppm
+ cmp $(srcdir)/testimg.bmp testout.bmp
+ cmp $(srcdir)/testimg.jpg testout.jpg
+ cmp $(srcdir)/testimg.ppm testoutp.ppm
+ cmp $(srcdir)/testimgp.jpg testoutp.jpg
+ cmp $(srcdir)/testorig.jpg testoutt.jpg
+
+check: test
+
+# Mistake catcher:
+
+jconfig.h: jconfig.doc
+ echo You must prepare a system-dependent jconfig.h file.
+ echo Please read the installation directions in install.doc.
+ exit 1
+
+# GNU Make likes to know which target names are not really files to be made:
+.PHONY: all install install-lib install-headers clean distclean test check
+
+
+jcapimin.$(O): jcapimin.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcapistd.$(O): jcapistd.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jccoefct.$(O): jccoefct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jccolor.$(O): jccolor.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcdctmgr.$(O): jcdctmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jchuff.$(O): jchuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jchuff.h
+jcinit.$(O): jcinit.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcmainct.$(O): jcmainct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcmarker.$(O): jcmarker.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcmaster.$(O): jcmaster.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcomapi.$(O): jcomapi.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcparam.$(O): jcparam.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcphuff.$(O): jcphuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jchuff.h
+jcprepct.$(O): jcprepct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jcsample.$(O): jcsample.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jctrans.$(O): jctrans.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdapimin.$(O): jdapimin.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdapistd.$(O): jdapistd.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdatadst.$(O): jdatadst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h
+jdatasrc.$(O): jdatasrc.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h
+jdcoefct.$(O): jdcoefct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdcolor.$(O): jdcolor.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jddctmgr.$(O): jddctmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jdhuff.$(O): jdhuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdhuff.h
+jdinput.$(O): jdinput.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdmainct.$(O): jdmainct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdmarker.$(O): jdmarker.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdmaster.$(O): jdmaster.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdmerge.$(O): jdmerge.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdphuff.$(O): jdphuff.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdhuff.h
+jdpostct.$(O): jdpostct.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdsample.$(O): jdsample.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jdtrans.$(O): jdtrans.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jerror.$(O): jerror.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jversion.h jerror.h
+jfdctflt.$(O): jfdctflt.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jfdctfst.$(O): jfdctfst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jfdctint.$(O): jfdctint.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jidctflt.$(O): jidctflt.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jidctfst.$(O): jidctfst.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jidctint.$(O): jidctint.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jidctred.$(O): jidctred.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jdct.h
+jquant1.$(O): jquant1.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jquant2.$(O): jquant2.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jutils.$(O): jutils.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h
+jmemmgr.$(O): jmemmgr.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+jmemansi.$(O): jmemansi.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+jmemname.$(O): jmemname.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+jmemnobs.$(O): jmemnobs.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+jmemdos.$(O): jmemdos.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+jmemmac.$(O): jmemmac.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h jmemsys.h
+cjpeg.$(O): cjpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h jversion.h
+djpeg.$(O): djpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h jversion.h
+jpegtran.$(O): jpegtran.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h transupp.h jversion.h
+rdjpgcom.$(O): rdjpgcom.c jinclude.h jconfig.h
+wrjpgcom.$(O): wrjpgcom.c jinclude.h jconfig.h
+cdjpeg.$(O): cdjpeg.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdcolmap.$(O): rdcolmap.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdswitch.$(O): rdswitch.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+transupp.$(O): transupp.c jinclude.h jconfig.h jpeglib.h jmorecfg.h jpegint.h jerror.h transupp.h
+rdppm.$(O): rdppm.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+wrppm.$(O): wrppm.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdgif.$(O): rdgif.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+wrgif.$(O): wrgif.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdtarga.$(O): rdtarga.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+wrtarga.$(O): wrtarga.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdbmp.$(O): rdbmp.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+wrbmp.$(O): wrbmp.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+rdrle.$(O): rdrle.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
+wrrle.$(O): wrrle.c cdjpeg.h jinclude.h jconfig.h jpeglib.h jmorecfg.h jerror.h cderror.h
diff --git a/test/monniaux/jpeg-6b/cjpeg.c b/test/monniaux/jpeg-6b/cjpeg.c
index f2a929f0..deade36d 100644
--- a/test/monniaux/jpeg-6b/cjpeg.c
+++ b/test/monniaux/jpeg-6b/cjpeg.c
@@ -23,6 +23,11 @@
* works regardless of which command line style is used.
*/
+#define VERIMAG
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
#include "cdjpeg.h" /* Common decls for cjpeg/djpeg applications */
#include "jversion.h" /* for version message */
@@ -576,6 +581,10 @@ main (int argc, char **argv)
/* Specify data destination for compression */
jpeg_stdio_dest(&cinfo, output_file);
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
/* Start compressor */
jpeg_start_compress(&cinfo, TRUE);
@@ -584,6 +593,10 @@ main (int argc, char **argv)
num_scanlines = (*src_mgr->get_pixel_rows) (&cinfo, src_mgr);
(void) jpeg_write_scanlines(&cinfo, src_mgr->buffer, num_scanlines);
}
+#ifdef VERIMAG
+ clock_stop();
+ printerr_total_clock();
+#endif
/* Finish compression and release memory */
(*src_mgr->finish_input) (&cinfo, src_mgr);
diff --git a/test/monniaux/jpeg-6b/djpeg.c b/test/monniaux/jpeg-6b/djpeg.c
index e099e90a..e3793a4f 100644
--- a/test/monniaux/jpeg-6b/djpeg.c
+++ b/test/monniaux/jpeg-6b/djpeg.c
@@ -23,6 +23,11 @@
* works regardless of which command line style is used.
*/
+#define VERIMAG
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
#include "cdjpeg.h" /* Common decls for cjpeg/djpeg applications */
#include "jversion.h" /* for version message */
@@ -572,6 +577,11 @@ main (int argc, char **argv)
}
dest_mgr->output_file = output_file;
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+
/* Start decompressor */
(void) jpeg_start_decompress(&cinfo);
@@ -584,6 +594,10 @@ main (int argc, char **argv)
dest_mgr->buffer_height);
(*dest_mgr->put_pixel_rows) (&cinfo, dest_mgr, num_scanlines);
}
+#ifdef VERIMAG
+ clock_stop();
+ printerr_total_clock();
+#endif
#ifdef PROGRESS_REPORT
/* Hack: count final pass as done in case finish_output does an extra pass.
diff --git a/test/monniaux/latency/latency.s b/test/monniaux/latency/latency.s
deleted file mode 100644
index 494f9f77..00000000
--- a/test/monniaux/latency/latency.s
+++ /dev/null
@@ -1,27 +0,0 @@
-# File generated by CompCert 3.4
-# Command line: -S latency.c
- .text
- .balign 2
- .globl latency
-latency:
- make $r2 = 100
-;;
- loopdo $r2, .exitloop
-;;
- lws $r1 = 0[$r0]
-;;
- addw $r0 = $r0, 0
-;;
- addw $r0 = $r0, 0
-;;
- addw $r0 = $r0, 0
-;;
- addw $r1 = $r1, 1
-;;
- sw 0[$r0] = $r1
-;;
-.exitloop:
- ret
-;;
- .type latency, @function
- .size latency, . - latency
diff --git a/test/monniaux/lustrev4_lustrec_heater_control/Makefile b/test/monniaux/lustrev4_lustrec_heater_control/Makefile
new file mode 100644
index 00000000..df7c9e0a
--- /dev/null
+++ b/test/monniaux/lustrev4_lustrec_heater_control/Makefile
@@ -0,0 +1,3 @@
+TARGET=lustrec_heater_control
+
+include ../rules.mk
diff --git a/test/monniaux/lustrev4_lustrec_heater_control/arrow.h b/test/monniaux/lustrev4_lustrec_heater_control/arrow.h
new file mode 100644
index 00000000..802057da
--- /dev/null
+++ b/test/monniaux/lustrev4_lustrec_heater_control/arrow.h
@@ -0,0 +1,34 @@
+
+#ifndef _ARROW
+#define _ARROW
+
+struct _arrow_mem {struct _arrow_reg {_Bool _first; } _reg; };
+
+extern struct _arrow_mem *_arrow_alloc ();
+
+extern void _arrow_dealloc (struct _arrow_mem *);
+
+#define _arrow_DECLARE(attr, inst)\
+ attr struct _arrow_mem inst;
+
+#define _arrow_LINK(inst) do {\
+ ;\
+} while (0)
+
+#define _arrow_ALLOC(attr, inst)\
+ _arrow_DECLARE(attr, inst);\
+ _arrow_LINK(inst)
+
+#define _arrow_init(self) {}
+
+#define _arrow_clear(self) {}
+
+#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))
+
+#define _arrow_reset(self) {(self)->_reg._first = 1;}
+
+/* Step macro for specialized arrows of the form: (true -> false) */
+
+#define _once_step(output,self) { *output = (self)->_reg._first; if ((self)->_reg._first) { (self)->_reg._first=0; }; }
+
+#endif
diff --git a/test/monniaux/lustrev4_lustrec_heater_control/heater_control.h b/test/monniaux/lustrev4_lustrec_heater_control/heater_control.h
index d25a7d52..405f9a74 100644
--- a/test/monniaux/lustrev4_lustrec_heater_control/heater_control.h
+++ b/test/monniaux/lustrev4_lustrec_heater_control/heater_control.h
@@ -8,7 +8,7 @@
/* Imports standard library */
#include <stdint.h>
-#include "/opt/lustrec/1.6/include/lustrec/arrow.h"
+#include "arrow.h"
/* Import dependencies */
diff --git a/test/monniaux/lustrev4_lustrec_heater_control/heater_control.lus b/test/monniaux/lustrev4_lustrec_heater_control/heater_control.lus
deleted file mode 100644
index 9a668a47..00000000
--- a/test/monniaux/lustrev4_lustrec_heater_control/heater_control.lus
+++ /dev/null
@@ -1,126 +0,0 @@
---
--- A fault-tolerant heater controller with 3 sensors.
---
--- To guess the temperature (T),
---
--- (1) It compares the value of the 3 sensors 2 by 2 to determine
--- which ones seem are broken -- we consider then broken if they
--- differ too much.
---
--- (2) then, it performs a vote:
--- o If the tree sensors are broken, it does not heat;
--- o If the temperature is bigger than TMAX, it does not heat;
--- o If the temperature is smaller than TMIN, it heats;
--- o Otherwise, it keeps its previous state.
-
-
-const FAILURE = -999.0; -- a fake temperature given when all sensors are broken
-const TMIN = 6.0;
-const TMAX = 9.0;
-
-
-const DELTA = 0.5;
--- const DELTA : real;
-
------------------------------------------------------------------------
------------------------------------------------------------------------
-node heater_control(T, T1, T2, T3 : real) returns (Heat_on:bool);
--- T is supposed to be the real temperature and is not
--- used in the controller; we add it here in oder to test the
--- controller to be able to write a sensible oracle.
-
-
-var
- V12, V13, V23 : bool;
- Tguess : real;
-
-let
- V12 = abs(T1-T2) < DELTA; -- Are T1 and T2 valid?
- V13 = abs(T1-T3) < DELTA; -- Are T1 and T3 valid?
- V23 = abs(T2-T3) < DELTA; -- Are T2 and T3 valid?
-
- Tguess =
- if noneoftree(V12, V13, V23) then FAILURE else
- if oneoftree(V12, V13, V23) then Median(T1, T2, T3) else
- if alloftree(V12, V13, V23) then Median(T1, T2, T3) else
- -- 2 among V1, V2, V3 are false
- if V12 then Average(T1, T2) else
- if V13 then Average(T1, T3) else
- -- V23 is necessarily true, hence T1 is wrong
- Average(T2, T3) ;
-
- Heat_on = true ->
- if Tguess = FAILURE then false else
- if Tguess < TMIN then true else
- if Tguess > TMAX then false else
- pre Heat_on;
-tel
-
-
------------------------------------------------------------------------
------------------------------------------------------------------------
-node not_a_sauna(T, T1, T2, T3 : real; Heat_on: bool) returns (ok:bool);
-
-let
- ok = true -> pre T < TMAX + 1.0 ;
-tel
-
-node not_a_sauna2(T, T1, T2, T3 : real; Heat_on: bool) returns (ok:bool);
-
-let
- ok = true -> pre T < TMAX - 6.0 ;
-tel
-
-
-
------------------------------------------------------------------------
------------------------------------------------------------------------
-
--- returns the absolute value of 2 reals
-function abs (v : real) returns (a : real) ;
-let
- a = if v >= 0.0 then v else -v ;
-tel
-
--- returns the average values of 2 reals
-function Average(a, b: real) returns (z : real);
-let
- z = (a+b)/2.0 ;
-tel
-
--- returns the median values of 3 reals
-function Median(a, b, c : real) returns (z : real);
-let
- z = a + b + c - min2 (a, min2(b,c)) - max2 (a, max2(b,c)) ;
-tel
-
-
--- returns the maximum values of 2 reals
-function max2 (one, two : real) returns (m : real) ;
-let
- m = if one > two then one else two ;
-tel
-
--- returns the minimum values of 2 reals
-function min2 (one, two : real) returns (m : real) ;
-let
- m = if one < two then one else two ;
-tel
-
-
-function noneoftree (f1, f2, f3 : bool) returns (r : bool)
-let
- r = not f1 and not f2 and not f3 ;
-tel
-
-function alloftree (f1, f2, f3 : bool) returns (r : bool)
-let
- r = f1 and f2 and f3 ;
-tel
-
-function oneoftree (f1, f2, f3 : bool) returns (r : bool)
-let
- r = f1 and not f2 and not f3 or
- f2 and not f1 and not f3 or
- f3 and not f1 and not f2 ;
-tel
diff --git a/test/monniaux/lustrev4_lv4_heater_control/Makefile b/test/monniaux/lustrev4_lv4_heater_control/Makefile
new file mode 100644
index 00000000..cfd37921
--- /dev/null
+++ b/test/monniaux/lustrev4_lv4_heater_control/Makefile
@@ -0,0 +1,3 @@
+TARGET=lv4_heater_control
+
+include ../rules.mk
diff --git a/test/monniaux/lustrev4_lv4_heater_control/make.proto b/test/monniaux/lustrev4_lv4_heater_control/make.proto
new file mode 100644
index 00000000..f19fec0f
--- /dev/null
+++ b/test/monniaux/lustrev4_lv4_heater_control/make.proto
@@ -0,0 +1,3 @@
+sources: "$(wildcard *.c)"
+target: lv4_heater_control
+measures: [cycles]
diff --git a/test/monniaux/lustrev4_lv6-en-2cgc_heater_control/Makefile b/test/monniaux/lustrev4_lv6-en-2cgc_heater_control/Makefile
new file mode 100644
index 00000000..90d0a4c9
--- /dev/null
+++ b/test/monniaux/lustrev4_lv6-en-2cgc_heater_control/Makefile
@@ -0,0 +1,3 @@
+TARGET=lv6-en-2cgc_heater_control
+
+include ../rules.mk
diff --git a/test/monniaux/lustrev6-convertible-en-2cgc/Makefile b/test/monniaux/lustrev6-convertible-en-2cgc/Makefile
new file mode 100644
index 00000000..009f7f35
--- /dev/null
+++ b/test/monniaux/lustrev6-convertible-en-2cgc/Makefile
@@ -0,0 +1,3 @@
+TARGET=lv6-en-2cgc_convertible
+
+include ../rules.mk
diff --git a/test/monniaux/minisat/LICENSE b/test/monniaux/minisat/LICENSE
new file mode 100644
index 00000000..8a6b9f36
--- /dev/null
+++ b/test/monniaux/minisat/LICENSE
@@ -0,0 +1,20 @@
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+
+Permission is hereby granted, free of charge, to any person obtaining a
+copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be included
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
diff --git a/test/monniaux/minisat/Makefile b/test/monniaux/minisat/Makefile
new file mode 100644
index 00000000..f98b69b7
--- /dev/null
+++ b/test/monniaux/minisat/Makefile
@@ -0,0 +1,36 @@
+
+include ../rules.mk
+
+EXECUTE_ARGS=sudoku.sat
+
+src=main.c solver.c
+
+PRODUCTS?=minisat.gcc.host minisat.ccomp.host minisat.gcc.k1c minisat.gcc.o1.k1c minisat.ccomp.k1c
+PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS))
+
+all: $(PRODUCTS)
+
+.PHONY:
+run: measures.csv
+
+LIBS=-lm
+
+minisat.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o
+ $(CC) $(CFLAGS) $+ $(LIBS) -o $@
+minisat.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o
+ $(CCOMP) $(CCOMPFLAGS) $+ $(LIBS) -o $@
+minisat.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o
+ $(K1C_CC) $(K1C_CFLAGS) $+ $(LIBS) -o $@
+minisat.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o
+ $(K1C_CC) $(K1C_CFLAGS_O1) $+ $(LIBS) -o $@
+minisat.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o
+ $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ $(LIBS) -o $@
+measures.csv: $(PRODUCTS_OUT)
+ echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@
+
+.SECONDARY:
+
+.PHONY:
+clean:
+ rm -f *.o *.s *.k1c *.csv
+
diff --git a/test/monniaux/minisat/README b/test/monniaux/minisat/README
new file mode 100644
index 00000000..b31e850b
--- /dev/null
+++ b/test/monniaux/minisat/README
@@ -0,0 +1,15 @@
+MiniSat-C v1.14.1
+========================================
+
+* Fixed some serious bugs.
+* Tweaked to be Visual Studio friendly (by Alan Mishchenko).
+ This disabled reading of gzipped DIMACS files and signal handling, but none
+ of these features are essential (and easy to re-enable, if wanted).
+
+MiniSat-C v1.14
+========================================
+
+Ok, we get it. You hate C++. You hate templates. We agree; C++ is a
+seriously messed up language. Although we are more pragmatic about the
+quirks and maldesigns in C++, we sympathize with you. So here is a
+pure C version of MiniSat, put together by Niklas Sörensson.
diff --git a/test/monniaux/minisat/main.c b/test/monniaux/minisat/main.c
new file mode 100644
index 00000000..abd3a03a
--- /dev/null
+++ b/test/monniaux/minisat/main.c
@@ -0,0 +1,222 @@
+/**************************************************************************************************
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
+associated documentation files (the "Software"), to deal in the Software without restriction,
+including without limitation the rights to use, copy, modify, merge, publish, distribute,
+sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or
+substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT
+NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
+OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+**************************************************************************************************/
+// Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko
+
+#include "solver.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+#include <inttypes.h> // DM
+//#include <unistd.h>
+//#include <signal.h>
+//#include <zlib.h>
+//#include <sys/time.h>
+//#include <sys/resource.h>
+
+#define VERIMAG
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
+//=================================================================================================
+// Helpers:
+
+
+// Reads an input stream to end-of-file and returns the result as a 'char*' terminated by '\0'
+// (dynamic allocation in case 'in' is standard input).
+//
+char* readFile(FILE * in)
+{
+ char* data = malloc(65536);
+ int cap = 65536;
+ int size = 0;
+
+ while (!feof(in)){
+ if (size == cap){
+ cap *= 2;
+ data = realloc(data, cap); }
+ size += fread(&data[size], 1, 65536, in);
+ }
+ data = realloc(data, size+1);
+ data[size] = '\0';
+
+ return data;
+}
+
+//static inline double cpuTime(void) {
+// struct rusage ru;
+// getrusage(RUSAGE_SELF, &ru);
+// return (double)ru.ru_utime.tv_sec + (double)ru.ru_utime.tv_usec / 1000000; }
+
+
+//=================================================================================================
+// DIMACS Parser:
+
+
+static inline void skipWhitespace(char** in) {
+ while ((**in >= 9 && **in <= 13) || **in == 32)
+ (*in)++; }
+
+static inline void skipLine(char** in) {
+ for (;;){
+ if (**in == 0) return;
+ if (**in == '\n') { (*in)++; return; }
+ (*in)++; } }
+
+static inline int parseInt(char** in) {
+ int val = 0;
+ int _neg = 0;
+ skipWhitespace(in);
+ if (**in == '-') _neg = 1, (*in)++;
+ else if (**in == '+') (*in)++;
+ if (**in < '0' || **in > '9') fprintf(stderr, "PARSE ERROR! Unexpected char: %c\n", **in), exit(1);
+ while (**in >= '0' && **in <= '9')
+ val = val*10 + (**in - '0'),
+ (*in)++;
+ return _neg ? -val : val; }
+
+static void readClause(char** in, solver* s, veci* lits) {
+ int parsed_lit, var;
+ veci_resize(lits,0);
+ for (;;){
+ parsed_lit = parseInt(in);
+ if (parsed_lit == 0) break;
+ var = abs(parsed_lit)-1;
+ veci_push(lits, (parsed_lit > 0 ? toLit(var) : lit_neg(toLit(var))));
+ }
+}
+
+static lbool parse_DIMACS_main(char* in, solver* s) {
+ veci lits;
+ veci_new(&lits);
+
+ for (;;){
+ skipWhitespace(&in);
+ if (*in == 0)
+ break;
+ else if (*in == 'c' || *in == 'p')
+ skipLine(&in);
+ else{
+ lit* begin;
+ readClause(&in, s, &lits);
+ begin = veci_begin(&lits);
+ if (!solver_addclause(s, begin, begin+veci_size(&lits))){
+ veci_delete(&lits);
+ return l_False;
+ }
+ }
+ }
+ veci_delete(&lits);
+ return solver_simplify(s);
+}
+
+
+// Inserts problem into solver. Returns FALSE upon immediate conflict.
+//
+static lbool parse_DIMACS(FILE * in, solver* s) {
+ char* text = readFile(in);
+ lbool ret = parse_DIMACS_main(text, s);
+ free(text);
+ return ret; }
+
+
+//=================================================================================================
+
+
+void printStats(stats* stats, int cpu_time)
+{
+ double Time = (float)(cpu_time)/(float)(CLOCKS_PER_SEC);
+ printf("restarts : %12" PRIu64 "\n", stats->starts); // DM
+ printf("conflicts : %12.0f (%9.0f / sec )\n", (double)stats->conflicts , (double)stats->conflicts /Time);
+ printf("decisions : %12.0f (%9.0f / sec )\n", (double)stats->decisions , (double)stats->decisions /Time);
+ printf("propagations : %12.0f (%9.0f / sec )\n", (double)stats->propagations, (double)stats->propagations/Time);
+ printf("inspects : %12.0f (%9.0f / sec )\n", (double)stats->inspects , (double)stats->inspects /Time);
+ printf("conflict literals : %12.0f (%9.2f %% deleted )\n", (double)stats->tot_literals, (double)(stats->max_literals - stats->tot_literals) * 100.0 / (double)stats->max_literals);
+ printf("CPU time : %12.2f sec\n", Time);
+}
+
+//solver* slv;
+//static void SIGINT_handler(int signum) {
+// printf("\n"); printf("*** INTERRUPTED ***\n");
+// printStats(&slv->stats, cpuTime());
+// printf("\n"); printf("*** INTERRUPTED ***\n");
+// exit(0); }
+
+
+//=================================================================================================
+
+
+int main(int argc, char** argv)
+{
+ solver* s = solver_new();
+ lbool st;
+ FILE * in;
+ int clk = clock();
+
+ if (argc != 2)
+ fprintf(stderr, "ERROR! Not enough command line arguments.\n"),
+ exit(1);
+
+ in = fopen(argv[1], "rb");
+ if (in == NULL)
+ fprintf(stderr, "ERROR! Could not open file: %s\n", argc == 1 ? "<stdin>" : argv[1]),
+ exit(1);
+ st = parse_DIMACS(in, s);
+ fclose(in);
+
+ if (st == l_False){
+ solver_delete(s);
+ printf("Trivial problem\nUNSATISFIABLE\n");
+ exit(20);
+ }
+
+ s->verbosity = 1;
+// slv = s;
+// signal(SIGINT,SIGINT_handler);
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+ st = solver_solve(s,0,0);
+#ifdef VERIMAG
+ clock_stop();
+#endif
+ printStats(&s->stats, clock() - clk);
+ printf("\n");
+ printf(st == l_True ? "SATISFIABLE\n" : "UNSATISFIABLE\n");
+
+ // print the sat assignment
+ if ( st == l_True )
+ {
+ int k;
+ printf( "\nSatisfying solution: " );
+ for ( k = 0; k < s->model.size; k++ )
+ printf( "x%d=%d ", k, s->model.ptr[k] == l_True );
+ printf( "\n" );
+ }
+
+#ifdef VERIMAG
+ print_total_clock();
+#endif
+
+ solver_delete(s);
+ return 0;
+}
diff --git a/test/monniaux/minisat/make.proto b/test/monniaux/minisat/make.proto
new file mode 100644
index 00000000..d86da4de
--- /dev/null
+++ b/test/monniaux/minisat/make.proto
@@ -0,0 +1,2 @@
+sources: main.c solver.c
+target: minisat \ No newline at end of file
diff --git a/test/monniaux/minisat/solver.c b/test/monniaux/minisat/solver.c
new file mode 100644
index 00000000..d3b99c9d
--- /dev/null
+++ b/test/monniaux/minisat/solver.c
@@ -0,0 +1,1191 @@
+/**************************************************************************************************
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
+associated documentation files (the "Software"), to deal in the Software without restriction,
+including without limitation the rights to use, copy, modify, merge, publish, distribute,
+sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or
+substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT
+NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
+OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+**************************************************************************************************/
+// Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko
+
+#include <stdio.h>
+#include <assert.h>
+#include <math.h>
+
+#include "solver.h"
+
+//=================================================================================================
+// Debug:
+
+//#define VERBOSEDEBUG
+
+// For derivation output (verbosity level 2)
+#define L_IND "%-*d"
+#define L_ind solver_dlevel(s)*3+3,solver_dlevel(s)
+#define L_LIT "%sx%d"
+#define L_lit(p) lit_sign(p)?"~":"", (lit_var(p))
+
+// Just like 'assert()' but expression will be evaluated in the release version as well.
+static inline void check(int expr) { assert(expr); }
+
+static void printlits(lit* begin, lit* end)
+{
+ int i;
+ for (i = 0; i < end - begin; i++)
+ printf(L_LIT" ",L_lit(begin[i]));
+}
+
+//=================================================================================================
+// Random numbers:
+
+
+// Returns a random float 0 <= x < 1. Seed must never be 0.
+static inline double drand(double* seed) {
+ int q;
+ *seed *= 1389796;
+ q = (int)(*seed / 2147483647);
+ *seed -= (double)q * 2147483647;
+ return *seed / 2147483647; }
+
+
+// Returns a random integer 0 <= x < size. Seed must never be 0.
+static inline int irand(double* seed, int size) {
+ return (int)(drand(seed) * size); }
+
+
+//=================================================================================================
+// Predeclarations:
+
+void sort(void** array, int size, int(*comp)(const void *, const void *));
+
+//=================================================================================================
+// Clause datatype + minor functions:
+
+struct clause_t
+{
+ int size_learnt;
+ lit lits[0];
+};
+
+static inline int clause_size (clause* c) { return c->size_learnt >> 1; }
+static inline lit* clause_begin (clause* c) { return c->lits; }
+static inline int clause_learnt (clause* c) { return c->size_learnt & 1; }
+static inline float clause_activity (clause* c) { return *((float*)&c->lits[c->size_learnt>>1]); }
+static inline void clause_setactivity(clause* c, float a) { *((float*)&c->lits[c->size_learnt>>1]) = a; }
+
+//=================================================================================================
+// Encode literals in clause pointers:
+
+clause* clause_from_lit (lit l) { return (clause*)((unsigned long)l + (unsigned long)l + 1); }
+bool clause_is_lit (clause* c) { return ((unsigned long)c & 1); }
+lit clause_read_lit (clause* c) { return (lit)((unsigned long)c >> 1); }
+
+//=================================================================================================
+// Simple helpers:
+
+static inline int solver_dlevel(solver* s) { return veci_size(&s->trail_lim); }
+static inline vecp* solver_read_wlist (solver* s, lit l){ return &s->wlists[l]; }
+static inline void vecp_remove(vecp* v, void* e)
+{
+ void** ws = vecp_begin(v);
+ int j = 0;
+
+ for (; ws[j] != e ; j++);
+ assert(j < vecp_size(v));
+ for (; j < vecp_size(v)-1; j++) ws[j] = ws[j+1];
+ vecp_resize(v,vecp_size(v)-1);
+}
+
+//=================================================================================================
+// Variable order functions:
+
+static inline void order_update(solver* s, int v) // updateorder
+{
+ int* orderpos = s->orderpos;
+ double* activity = s->activity;
+ int* heap = veci_begin(&s->order);
+ int i = orderpos[v];
+ int x = heap[i];
+ int parent = (i - 1) / 2;
+
+ assert(s->orderpos[v] != -1);
+
+ while (i != 0 && activity[x] > activity[heap[parent]]){
+ heap[i] = heap[parent];
+ orderpos[heap[i]] = i;
+ i = parent;
+ parent = (i - 1) / 2;
+ }
+ heap[i] = x;
+ orderpos[x] = i;
+}
+
+static inline void order_assigned(solver* s, int v)
+{
+}
+
+static inline void order_unassigned(solver* s, int v) // undoorder
+{
+ int* orderpos = s->orderpos;
+ if (orderpos[v] == -1){
+ orderpos[v] = veci_size(&s->order);
+ veci_push(&s->order,v);
+ order_update(s,v);
+ }
+}
+
+static int order_select(solver* s, float random_var_freq) // selectvar
+{
+ int* heap;
+ double* activity;
+ int* orderpos;
+
+ lbool* values = s->assigns;
+
+ // Random decision:
+ if (drand(&s->random_seed) < random_var_freq){
+ int next = irand(&s->random_seed,s->size);
+ assert(next >= 0 && next < s->size);
+ if (values[next] == l_Undef)
+ return next;
+ }
+
+ // Activity based decision:
+
+ heap = veci_begin(&s->order);
+ activity = s->activity;
+ orderpos = s->orderpos;
+
+
+ while (veci_size(&s->order) > 0){
+ int next = heap[0];
+ int size = veci_size(&s->order)-1;
+ int x = heap[size];
+
+ veci_resize(&s->order,size);
+
+ orderpos[next] = -1;
+
+ if (size > 0){
+ double act = activity[x];
+
+ int i = 0;
+ int child = 1;
+
+
+ while (child < size){
+ if (child+1 < size && activity[heap[child]] < activity[heap[child+1]])
+ child++;
+
+ assert(child < size);
+
+ if (act >= activity[heap[child]])
+ break;
+
+ heap[i] = heap[child];
+ orderpos[heap[i]] = i;
+ i = child;
+ child = 2 * child + 1;
+ }
+ heap[i] = x;
+ orderpos[heap[i]] = i;
+ }
+
+ if (values[next] == l_Undef)
+ return next;
+ }
+
+ return var_Undef;
+}
+
+//=================================================================================================
+// Activity functions:
+
+static inline void act_var_rescale(solver* s) {
+ double* activity = s->activity;
+ int i;
+ for (i = 0; i < s->size; i++)
+ activity[i] *= 1e-100;
+ s->var_inc *= 1e-100;
+}
+
+static inline void act_var_bump(solver* s, int v) {
+ double* activity = s->activity;
+ if ((activity[v] += s->var_inc) > 1e100)
+ act_var_rescale(s);
+
+ //printf("bump %d %f\n", v-1, activity[v]);
+
+ if (s->orderpos[v] != -1)
+ order_update(s,v);
+
+}
+
+static inline void act_var_decay(solver* s) { s->var_inc *= s->var_decay; }
+
+static inline void act_clause_rescale(solver* s) {
+ clause** cs = (clause**)vecp_begin(&s->learnts);
+ int i;
+ for (i = 0; i < vecp_size(&s->learnts); i++){
+ float a = clause_activity(cs[i]);
+ clause_setactivity(cs[i], a * (float)1e-20);
+ }
+ s->cla_inc *= (float)1e-20;
+}
+
+
+static inline void act_clause_bump(solver* s, clause *c) {
+ float a = clause_activity(c) + s->cla_inc;
+ clause_setactivity(c,a);
+ if (a > 1e20) act_clause_rescale(s);
+}
+
+static inline void act_clause_decay(solver* s) { s->cla_inc *= s->cla_decay; }
+
+
+//=================================================================================================
+// Clause functions:
+
+/* pre: size > 1 && no variable occurs twice
+ */
+static clause* clause_new(solver* s, lit* begin, lit* end, int learnt)
+{
+ int size;
+ clause* c;
+ int i;
+
+ assert(end - begin > 1);
+ assert(learnt >= 0 && learnt < 2);
+ size = end - begin;
+ c = (clause*)malloc(sizeof(clause) + sizeof(lit) * size + learnt * sizeof(float));
+ c->size_learnt = (size << 1) | learnt;
+ assert(((unsigned int)c & 1) == 0);
+
+ for (i = 0; i < size; i++)
+ c->lits[i] = begin[i];
+
+ if (learnt)
+ *((float*)&c->lits[size]) = 0.0;
+
+ assert(begin[0] >= 0);
+ assert(begin[0] < s->size*2);
+ assert(begin[1] >= 0);
+ assert(begin[1] < s->size*2);
+
+ assert(lit_neg(begin[0]) < s->size*2);
+ assert(lit_neg(begin[1]) < s->size*2);
+
+ //vecp_push(solver_read_wlist(s,lit_neg(begin[0])),(void*)c);
+ //vecp_push(solver_read_wlist(s,lit_neg(begin[1])),(void*)c);
+
+ vecp_push(solver_read_wlist(s,lit_neg(begin[0])),(void*)(size > 2 ? c : clause_from_lit(begin[1])));
+ vecp_push(solver_read_wlist(s,lit_neg(begin[1])),(void*)(size > 2 ? c : clause_from_lit(begin[0])));
+
+ return c;
+}
+
+
+static void clause_remove(solver* s, clause* c)
+{
+ lit* lits = clause_begin(c);
+ assert(lit_neg(lits[0]) < s->size*2);
+ assert(lit_neg(lits[1]) < s->size*2);
+
+ //vecp_remove(solver_read_wlist(s,lit_neg(lits[0])),(void*)c);
+ //vecp_remove(solver_read_wlist(s,lit_neg(lits[1])),(void*)c);
+
+ assert(lits[0] < s->size*2);
+ vecp_remove(solver_read_wlist(s,lit_neg(lits[0])),(void*)(clause_size(c) > 2 ? c : clause_from_lit(lits[1])));
+ vecp_remove(solver_read_wlist(s,lit_neg(lits[1])),(void*)(clause_size(c) > 2 ? c : clause_from_lit(lits[0])));
+
+ if (clause_learnt(c)){
+ s->stats.learnts--;
+ s->stats.learnts_literals -= clause_size(c);
+ }else{
+ s->stats.clauses--;
+ s->stats.clauses_literals -= clause_size(c);
+ }
+
+ free(c);
+}
+
+
+static lbool clause_simplify(solver* s, clause* c)
+{
+ lit* lits = clause_begin(c);
+ lbool* values = s->assigns;
+ int i;
+
+ assert(solver_dlevel(s) == 0);
+
+ for (i = 0; i < clause_size(c); i++){
+ lbool sig = !lit_sign(lits[i]); sig += sig - 1;
+ if (values[lit_var(lits[i])] == sig)
+ return l_True;
+ }
+ return l_False;
+}
+
+//=================================================================================================
+// Minor (solver) functions:
+
+void solver_setnvars(solver* s,int n)
+{
+ int var;
+
+ if (s->cap < n){
+
+ while (s->cap < n) s->cap = s->cap*2+1;
+
+ s->wlists = (vecp*) realloc(s->wlists, sizeof(vecp)*s->cap*2);
+ s->activity = (double*) realloc(s->activity, sizeof(double)*s->cap);
+ s->assigns = (lbool*) realloc(s->assigns, sizeof(lbool)*s->cap);
+ s->orderpos = (int*) realloc(s->orderpos, sizeof(int)*s->cap);
+ s->reasons = (clause**)realloc(s->reasons, sizeof(clause*)*s->cap);
+ s->levels = (int*) realloc(s->levels, sizeof(int)*s->cap);
+ s->tags = (lbool*) realloc(s->tags, sizeof(lbool)*s->cap);
+ s->trail = (lit*) realloc(s->trail, sizeof(lit)*s->cap);
+ }
+
+ for (var = s->size; var < n; var++){
+ vecp_new(&s->wlists[2*var]);
+ vecp_new(&s->wlists[2*var+1]);
+ s->activity [var] = 0;
+ s->assigns [var] = l_Undef;
+ s->orderpos [var] = veci_size(&s->order);
+ s->reasons [var] = (clause*)0;
+ s->levels [var] = 0;
+ s->tags [var] = l_Undef;
+
+ /* does not hold because variables enqueued at top level will not be reinserted in the heap
+ assert(veci_size(&s->order) == var);
+ */
+ veci_push(&s->order,var);
+ order_update(s, var);
+ }
+
+ s->size = n > s->size ? n : s->size;
+}
+
+
+static inline bool enqueue(solver* s, lit l, clause* from)
+{
+ lbool* values = s->assigns;
+ int v = lit_var(l);
+ lbool val = values[v];
+#ifdef VERBOSEDEBUG
+ printf(L_IND"enqueue("L_LIT")\n", L_ind, L_lit(l));
+#endif
+
+ lbool sig = !lit_sign(l); sig += sig - 1;
+ if (val != l_Undef){
+ return val == sig;
+ }else{
+ // New fact -- store it.
+#ifdef VERBOSEDEBUG
+ printf(L_IND"bind("L_LIT")\n", L_ind, L_lit(l));
+#endif
+ int* levels = s->levels;
+ clause** reasons = s->reasons;
+
+ values [v] = sig;
+ levels [v] = solver_dlevel(s);
+ reasons[v] = from;
+ s->trail[s->qtail++] = l;
+
+ order_assigned(s, v);
+ return true;
+ }
+}
+
+
+static inline void assume(solver* s, lit l){
+ assert(s->qtail == s->qhead);
+ assert(s->assigns[lit_var(l)] == l_Undef);
+#ifdef VERBOSEDEBUG
+ printf(L_IND"assume("L_LIT")\n", L_ind, L_lit(l));
+#endif
+ veci_push(&s->trail_lim,s->qtail);
+ enqueue(s,l,(clause*)0);
+}
+
+
+static inline void solver_canceluntil(solver* s, int level) {
+ lit* trail;
+ lbool* values;
+ clause** reasons;
+ int bound;
+ int c;
+
+ if (solver_dlevel(s) <= level)
+ return;
+
+ trail = s->trail;
+ values = s->assigns;
+ reasons = s->reasons;
+ bound = (veci_begin(&s->trail_lim))[level];
+
+ for (c = s->qtail-1; c >= bound; c--) {
+ int x = lit_var(trail[c]);
+ values [x] = l_Undef;
+ reasons[x] = (clause*)0;
+ }
+
+ for (c = s->qhead-1; c >= bound; c--)
+ order_unassigned(s,lit_var(trail[c]));
+
+ s->qhead = s->qtail = bound;
+ veci_resize(&s->trail_lim,level);
+}
+
+static void solver_record(solver* s, veci* cls)
+{
+ lit* begin = veci_begin(cls);
+ lit* end = begin + veci_size(cls);
+ clause* c = (veci_size(cls) > 1) ? clause_new(s,begin,end,1) : (clause*)0;
+ enqueue(s,*begin,c);
+
+ assert(veci_size(cls) > 0);
+
+ if (c != 0) {
+ vecp_push(&s->learnts,c);
+ act_clause_bump(s,c);
+ s->stats.learnts++;
+ s->stats.learnts_literals += veci_size(cls);
+ }
+}
+
+
+static double solver_progress(solver* s)
+{
+ lbool* values = s->assigns;
+ int* levels = s->levels;
+ int i;
+
+ double progress = 0;
+ double F = 1.0 / s->size;
+ for (i = 0; i < s->size; i++)
+ if (values[i] != l_Undef)
+ progress += pow(F, levels[i]);
+ return progress / s->size;
+}
+
+//=================================================================================================
+// Major methods:
+
+static bool solver_lit_removable(solver* s, lit l, int minl)
+{
+ lbool* tags = s->tags;
+ clause** reasons = s->reasons;
+ int* levels = s->levels;
+ int top = veci_size(&s->tagged);
+
+ assert(lit_var(l) >= 0 && lit_var(l) < s->size);
+ assert(reasons[lit_var(l)] != 0);
+ veci_resize(&s->stack,0);
+ veci_push(&s->stack,lit_var(l));
+
+ while (veci_size(&s->stack) > 0){
+ clause* c;
+ int v = veci_begin(&s->stack)[veci_size(&s->stack)-1];
+ assert(v >= 0 && v < s->size);
+ veci_resize(&s->stack,veci_size(&s->stack)-1);
+ assert(reasons[v] != 0);
+ c = reasons[v];
+
+ if (clause_is_lit(c)){
+ int v = lit_var(clause_read_lit(c));
+ if (tags[v] == l_Undef && levels[v] != 0){
+ if (reasons[v] != 0 && ((1 << (levels[v] & 31)) & minl)){
+ veci_push(&s->stack,v);
+ tags[v] = l_True;
+ veci_push(&s->tagged,v);
+ }else{
+ int* tagged = veci_begin(&s->tagged);
+ int j;
+ for (j = top; j < veci_size(&s->tagged); j++)
+ tags[tagged[j]] = l_Undef;
+ veci_resize(&s->tagged,top);
+ return false;
+ }
+ }
+ }else{
+ lit* lits = clause_begin(c);
+ int i, j;
+
+ for (i = 1; i < clause_size(c); i++){
+ int v = lit_var(lits[i]);
+ if (tags[v] == l_Undef && levels[v] != 0){
+ if (reasons[v] != 0 && ((1 << (levels[v] & 31)) & minl)){
+
+ veci_push(&s->stack,lit_var(lits[i]));
+ tags[v] = l_True;
+ veci_push(&s->tagged,v);
+ }else{
+ int* tagged = veci_begin(&s->tagged);
+ for (j = top; j < veci_size(&s->tagged); j++)
+ tags[tagged[j]] = l_Undef;
+ veci_resize(&s->tagged,top);
+ return false;
+ }
+ }
+ }
+ }
+ }
+
+ return true;
+}
+
+static void solver_analyze(solver* s, clause* c, veci* learnt)
+{
+ lit* trail = s->trail;
+ lbool* tags = s->tags;
+ clause** reasons = s->reasons;
+ int* levels = s->levels;
+ int cnt = 0;
+ lit p = lit_Undef;
+ int ind = s->qtail-1;
+ lit* lits;
+ int i, j, minl;
+ int* tagged;
+
+ veci_push(learnt,lit_Undef);
+
+ do{
+ assert(c != 0);
+
+ if (clause_is_lit(c)){
+ lit q = clause_read_lit(c);
+ assert(lit_var(q) >= 0 && lit_var(q) < s->size);
+ if (tags[lit_var(q)] == l_Undef && levels[lit_var(q)] > 0){
+ tags[lit_var(q)] = l_True;
+ veci_push(&s->tagged,lit_var(q));
+ act_var_bump(s,lit_var(q));
+ if (levels[lit_var(q)] == solver_dlevel(s))
+ cnt++;
+ else
+ veci_push(learnt,q);
+ }
+ }else{
+
+ if (clause_learnt(c))
+ act_clause_bump(s,c);
+
+ lits = clause_begin(c);
+ //printlits(lits,lits+clause_size(c)); printf("\n");
+ for (j = (p == lit_Undef ? 0 : 1); j < clause_size(c); j++){
+ lit q = lits[j];
+ assert(lit_var(q) >= 0 && lit_var(q) < s->size);
+ if (tags[lit_var(q)] == l_Undef && levels[lit_var(q)] > 0){
+ tags[lit_var(q)] = l_True;
+ veci_push(&s->tagged,lit_var(q));
+ act_var_bump(s,lit_var(q));
+ if (levels[lit_var(q)] == solver_dlevel(s))
+ cnt++;
+ else
+ veci_push(learnt,q);
+ }
+ }
+ }
+
+ while (tags[lit_var(trail[ind--])] == l_Undef);
+
+ p = trail[ind+1];
+ c = reasons[lit_var(p)];
+ cnt--;
+
+ }while (cnt > 0);
+
+ *veci_begin(learnt) = lit_neg(p);
+
+ lits = veci_begin(learnt);
+ minl = 0;
+ for (i = 1; i < veci_size(learnt); i++){
+ int lev = levels[lit_var(lits[i])];
+ minl |= 1 << (lev & 31);
+ }
+
+ // simplify (full)
+ for (i = j = 1; i < veci_size(learnt); i++){
+ if (reasons[lit_var(lits[i])] == 0 || !solver_lit_removable(s,lits[i],minl))
+ lits[j++] = lits[i];
+ }
+
+ // update size of learnt + statistics
+ s->stats.max_literals += veci_size(learnt);
+ veci_resize(learnt,j);
+ s->stats.tot_literals += j;
+
+ // clear tags
+ tagged = veci_begin(&s->tagged);
+ for (i = 0; i < veci_size(&s->tagged); i++)
+ tags[tagged[i]] = l_Undef;
+ veci_resize(&s->tagged,0);
+
+#ifdef DEBUG
+ for (i = 0; i < s->size; i++)
+ assert(tags[i] == l_Undef);
+#endif
+
+#ifdef VERBOSEDEBUG
+ printf(L_IND"Learnt {", L_ind);
+ for (i = 0; i < veci_size(learnt); i++) printf(" "L_LIT, L_lit(lits[i]));
+#endif
+ if (veci_size(learnt) > 1){
+ int max_i = 1;
+ int max = levels[lit_var(lits[1])];
+ lit tmp;
+
+ for (i = 2; i < veci_size(learnt); i++)
+ if (levels[lit_var(lits[i])] > max){
+ max = levels[lit_var(lits[i])];
+ max_i = i;
+ }
+
+ tmp = lits[1];
+ lits[1] = lits[max_i];
+ lits[max_i] = tmp;
+ }
+#ifdef VERBOSEDEBUG
+ {
+ int lev = veci_size(learnt) > 1 ? levels[lit_var(lits[1])] : 0;
+ printf(" } at level %d\n", lev);
+ }
+#endif
+}
+
+
+clause* solver_propagate(solver* s)
+{
+ lbool* values = s->assigns;
+ clause* confl = (clause*)0;
+ lit* lits;
+
+ //printf("solver_propagate\n");
+ while (confl == 0 && s->qtail - s->qhead > 0){
+ lit p = s->trail[s->qhead++];
+ vecp* ws = solver_read_wlist(s,p);
+ clause **begin = (clause**)vecp_begin(ws);
+ clause **end = begin + vecp_size(ws);
+ clause **i, **j;
+
+ s->stats.propagations++;
+ s->simpdb_props--;
+
+ //printf("checking lit %d: "L_LIT"\n", veci_size(ws), L_lit(p));
+ for (i = j = begin; i < end; ){
+ if (clause_is_lit(*i)){
+ *j++ = *i;
+ if (!enqueue(s,clause_read_lit(*i),clause_from_lit(p))){
+ confl = s->binary;
+ (clause_begin(confl))[1] = lit_neg(p);
+ (clause_begin(confl))[0] = clause_read_lit(*i++);
+
+ // Copy the remaining watches:
+ while (i < end)
+ *j++ = *i++;
+ }
+ }else{
+ lit false_lit;
+ lbool sig;
+
+ lits = clause_begin(*i);
+
+ // Make sure the false literal is data[1]:
+ false_lit = lit_neg(p);
+ if (lits[0] == false_lit){
+ lits[0] = lits[1];
+ lits[1] = false_lit;
+ }
+ assert(lits[1] == false_lit);
+ //printf("checking clause: "); printlits(lits, lits+clause_size(*i)); printf("\n");
+
+ // If 0th watch is true, then clause is already satisfied.
+ sig = !lit_sign(lits[0]); sig += sig - 1;
+ if (values[lit_var(lits[0])] == sig){
+ *j++ = *i;
+ }else{
+ // Look for new watch:
+ lit* stop = lits + clause_size(*i);
+ lit* k;
+ for (k = lits + 2; k < stop; k++){
+ lbool sig = lit_sign(*k); sig += sig - 1;
+ if (values[lit_var(*k)] != sig){
+ lits[1] = *k;
+ *k = false_lit;
+ vecp_push(solver_read_wlist(s,lit_neg(lits[1])),*i);
+ goto next; }
+ }
+
+ *j++ = *i;
+ // Clause is unit under assignment:
+ if (!enqueue(s,lits[0], *i)){
+ confl = *i++;
+ // Copy the remaining watches:
+ while (i < end)
+ *j++ = *i++;
+ }
+ }
+ }
+ next:
+ i++;
+ }
+
+ s->stats.inspects += j - (clause**)vecp_begin(ws);
+ vecp_resize(ws,j - (clause**)vecp_begin(ws));
+ }
+
+ return confl;
+}
+
+static inline int clause_cmp (const void* x, const void* y) {
+ return clause_size((clause*)x) > 2 && (clause_size((clause*)y) == 2 || clause_activity((clause*)x) < clause_activity((clause*)y)) ? -1 : 1; }
+
+void solver_reducedb(solver* s)
+{
+ int i, j;
+ double extra_lim = s->cla_inc / vecp_size(&s->learnts); // Remove any clause below this activity
+ clause** learnts = (clause**)vecp_begin(&s->learnts);
+ clause** reasons = s->reasons;
+
+ sort(vecp_begin(&s->learnts), vecp_size(&s->learnts), &clause_cmp);
+
+ for (i = j = 0; i < vecp_size(&s->learnts) / 2; i++){
+ if (clause_size(learnts[i]) > 2 && reasons[lit_var(*clause_begin(learnts[i]))] != learnts[i])
+ clause_remove(s,learnts[i]);
+ else
+ learnts[j++] = learnts[i];
+ }
+ for (; i < vecp_size(&s->learnts); i++){
+ if (clause_size(learnts[i]) > 2 && reasons[lit_var(*clause_begin(learnts[i]))] != learnts[i] && clause_activity(learnts[i]) < extra_lim)
+ clause_remove(s,learnts[i]);
+ else
+ learnts[j++] = learnts[i];
+ }
+
+ //printf("reducedb deleted %d\n", vecp_size(&s->learnts) - j);
+
+
+ vecp_resize(&s->learnts,j);
+}
+
+static lbool solver_search(solver* s, int nof_conflicts, int nof_learnts)
+{
+ int* levels = s->levels;
+ double var_decay = 0.95;
+ double clause_decay = 0.999;
+ double random_var_freq = 0.02;
+
+ int conflictC = 0;
+ veci learnt_clause;
+
+ assert(s->root_level == solver_dlevel(s));
+
+ s->stats.starts++;
+ s->var_decay = (float)(1 / var_decay );
+ s->cla_decay = (float)(1 / clause_decay);
+ veci_resize(&s->model,0);
+ veci_new(&learnt_clause);
+
+ for (;;){
+ clause* confl = solver_propagate(s);
+ if (confl != 0){
+ // CONFLICT
+ int blevel;
+
+#ifdef VERBOSEDEBUG
+ printf(L_IND"**CONFLICT**\n", L_ind);
+#endif
+ s->stats.conflicts++; conflictC++;
+ if (solver_dlevel(s) == s->root_level){
+ veci_delete(&learnt_clause);
+ return l_False;
+ }
+
+ veci_resize(&learnt_clause,0);
+ solver_analyze(s, confl, &learnt_clause);
+ blevel = veci_size(&learnt_clause) > 1 ? levels[lit_var(veci_begin(&learnt_clause)[1])] : s->root_level;
+ blevel = s->root_level > blevel ? s->root_level : blevel;
+ solver_canceluntil(s,blevel);
+ solver_record(s,&learnt_clause);
+ act_var_decay(s);
+ act_clause_decay(s);
+
+ }else{
+ // NO CONFLICT
+ int next;
+
+ if (nof_conflicts >= 0 && conflictC >= nof_conflicts){
+ // Reached bound on number of conflicts:
+ s->progress_estimate = solver_progress(s);
+ solver_canceluntil(s,s->root_level);
+ veci_delete(&learnt_clause);
+ return l_Undef; }
+
+ if (solver_dlevel(s) == 0)
+ // Simplify the set of problem clauses:
+ solver_simplify(s);
+
+ if (nof_learnts >= 0 && vecp_size(&s->learnts) - s->qtail >= nof_learnts)
+ // Reduce the set of learnt clauses:
+ solver_reducedb(s);
+
+ // New variable decision:
+ s->stats.decisions++;
+ next = order_select(s,(float)random_var_freq);
+
+ if (next == var_Undef){
+ // Model found:
+ lbool* values = s->assigns;
+ int i;
+ for (i = 0; i < s->size; i++) veci_push(&s->model,(int)values[i]);
+ solver_canceluntil(s,s->root_level);
+ veci_delete(&learnt_clause);
+
+ /*
+ veci apa; veci_new(&apa);
+ for (i = 0; i < s->size; i++)
+ veci_push(&apa,(int)(s->model.ptr[i] == l_True ? toLit(i) : lit_neg(toLit(i))));
+ printf("model: "); printlits((lit*)apa.ptr, (lit*)apa.ptr + veci_size(&apa)); printf("\n");
+ veci_delete(&apa);
+ */
+
+ return l_True;
+ }
+
+ assume(s,lit_neg(toLit(next)));
+ }
+ }
+
+ return l_Undef; // cannot happen
+}
+
+//=================================================================================================
+// External solver functions:
+
+solver* solver_new(void)
+{
+ solver* s = (solver*)malloc(sizeof(solver));
+
+ // initialize vectors
+ vecp_new(&s->clauses);
+ vecp_new(&s->learnts);
+ veci_new(&s->order);
+ veci_new(&s->trail_lim);
+ veci_new(&s->tagged);
+ veci_new(&s->stack);
+ veci_new(&s->model);
+
+ // initialize arrays
+ s->wlists = 0;
+ s->activity = 0;
+ s->assigns = 0;
+ s->orderpos = 0;
+ s->reasons = 0;
+ s->levels = 0;
+ s->tags = 0;
+ s->trail = 0;
+
+
+ // initialize other vars
+ s->size = 0;
+ s->cap = 0;
+ s->qhead = 0;
+ s->qtail = 0;
+ s->cla_inc = 1;
+ s->cla_decay = 1;
+ s->var_inc = 1;
+ s->var_decay = 1;
+ s->root_level = 0;
+ s->simpdb_assigns = 0;
+ s->simpdb_props = 0;
+ s->random_seed = 91648253;
+ s->progress_estimate = 0;
+ s->binary = (clause*)malloc(sizeof(clause) + sizeof(lit)*2);
+ s->binary->size_learnt = (2 << 1);
+ s->verbosity = 0;
+
+ s->stats.starts = 0;
+ s->stats.decisions = 0;
+ s->stats.propagations = 0;
+ s->stats.inspects = 0;
+ s->stats.conflicts = 0;
+ s->stats.clauses = 0;
+ s->stats.clauses_literals = 0;
+ s->stats.learnts = 0;
+ s->stats.learnts_literals = 0;
+ s->stats.max_literals = 0;
+ s->stats.tot_literals = 0;
+
+ return s;
+}
+
+
+void solver_delete(solver* s)
+{
+ int i;
+ for (i = 0; i < vecp_size(&s->clauses); i++)
+ free(vecp_begin(&s->clauses)[i]);
+
+ for (i = 0; i < vecp_size(&s->learnts); i++)
+ free(vecp_begin(&s->learnts)[i]);
+
+ // delete vectors
+ vecp_delete(&s->clauses);
+ vecp_delete(&s->learnts);
+ veci_delete(&s->order);
+ veci_delete(&s->trail_lim);
+ veci_delete(&s->tagged);
+ veci_delete(&s->stack);
+ veci_delete(&s->model);
+ free(s->binary);
+
+ // delete arrays
+ if (s->wlists != 0){
+ int i;
+ for (i = 0; i < s->size*2; i++)
+ vecp_delete(&s->wlists[i]);
+
+ // if one is different from null, all are
+ free(s->wlists);
+ free(s->activity );
+ free(s->assigns );
+ free(s->orderpos );
+ free(s->reasons );
+ free(s->levels );
+ free(s->trail );
+ free(s->tags );
+ }
+
+ free(s);
+}
+
+
+bool solver_addclause(solver* s, lit* begin, lit* end)
+{
+ lit *i,*j;
+ int maxvar;
+ lbool* values;
+ lit last;
+
+ if (begin == end) return false;
+
+ //printlits(begin,end); printf("\n");
+ // insertion sort
+ maxvar = lit_var(*begin);
+ for (i = begin + 1; i < end; i++){
+ lit l = *i;
+ maxvar = lit_var(l) > maxvar ? lit_var(l) : maxvar;
+ for (j = i; j > begin && *(j-1) > l; j--)
+ *j = *(j-1);
+ *j = l;
+ }
+ solver_setnvars(s,maxvar+1);
+
+ //printlits(begin,end); printf("\n");
+ values = s->assigns;
+
+ // delete duplicates
+ last = lit_Undef;
+ for (i = j = begin; i < end; i++){
+ //printf("lit: "L_LIT", value = %d\n", L_lit(*i), (lit_sign(*i) ? -values[lit_var(*i)] : values[lit_var(*i)]));
+ lbool sig = !lit_sign(*i); sig += sig - 1;
+ if (*i == lit_neg(last) || sig == values[lit_var(*i)])
+ return true; // tautology
+ else if (*i != last && values[lit_var(*i)] == l_Undef)
+ last = *j++ = *i;
+ }
+
+ //printf("final: "); printlits(begin,j); printf("\n");
+
+ if (j == begin) // empty clause
+ return false;
+ else if (j - begin == 1) // unit clause
+ return enqueue(s,*begin,(clause*)0);
+
+ // create new clause
+ vecp_push(&s->clauses,clause_new(s,begin,j,0));
+
+
+ s->stats.clauses++;
+ s->stats.clauses_literals += j - begin;
+
+ return true;
+}
+
+
+bool solver_simplify(solver* s)
+{
+ clause** reasons;
+ int type;
+
+ assert(solver_dlevel(s) == 0);
+
+ if (solver_propagate(s) != 0)
+ return false;
+
+ if (s->qhead == s->simpdb_assigns || s->simpdb_props > 0)
+ return true;
+
+ reasons = s->reasons;
+ for (type = 0; type < 2; type++){
+ vecp* cs = type ? &s->learnts : &s->clauses;
+ clause** cls = (clause**)vecp_begin(cs);
+
+ int i, j;
+ for (j = i = 0; i < vecp_size(cs); i++){
+ if (reasons[lit_var(*clause_begin(cls[i]))] != cls[i] &&
+ clause_simplify(s,cls[i]) == l_True)
+ clause_remove(s,cls[i]);
+ else
+ cls[j++] = cls[i];
+ }
+ vecp_resize(cs,j);
+ }
+
+ s->simpdb_assigns = s->qhead;
+ // (shouldn't depend on 'stats' really, but it will do for now)
+ s->simpdb_props = (int)(s->stats.clauses_literals + s->stats.learnts_literals);
+
+ return true;
+}
+
+
+bool solver_solve(solver* s, lit* begin, lit* end)
+{
+ double nof_conflicts = 100;
+ double nof_learnts = solver_nclauses(s) / 3;
+ lbool status = l_Undef;
+ lbool* values = s->assigns;
+ lit* i;
+
+ //printf("solve: "); printlits(begin, end); printf("\n");
+ for (i = begin; i < end; i++){
+ switch (lit_sign(*i) ? -values[lit_var(*i)] : values[lit_var(*i)]){
+ case 1: /* l_True: */
+ break;
+ case 0: /* l_Undef */
+ assume(s, *i);
+ if (solver_propagate(s) == NULL)
+ break;
+ // falltrough
+ case -1: /* l_False */
+ solver_canceluntil(s, 0);
+ return false;
+ }
+ }
+
+ s->root_level = solver_dlevel(s);
+
+ if (s->verbosity >= 1){
+ printf("==================================[MINISAT]===================================\n");
+ printf("| Conflicts | ORIGINAL | LEARNT | Progress |\n");
+ printf("| | Clauses Literals | Limit Clauses Literals Lit/Cl | |\n");
+ printf("==============================================================================\n");
+ }
+
+ while (status == l_Undef){
+ double Ratio = (s->stats.learnts == 0)? 0.0 :
+ s->stats.learnts_literals / (double)s->stats.learnts;
+
+ if (s->verbosity >= 1){
+ printf("| %9.0f | %7.0f %8.0f | %7.0f %7.0f %8.0f %7.1f | %6.3f %% |\n",
+ (double)s->stats.conflicts,
+ (double)s->stats.clauses,
+ (double)s->stats.clauses_literals,
+ (double)nof_learnts,
+ (double)s->stats.learnts,
+ (double)s->stats.learnts_literals,
+ Ratio,
+ s->progress_estimate*100);
+ fflush(stdout);
+ }
+ status = solver_search(s,(int)nof_conflicts, (int)nof_learnts);
+ nof_conflicts *= 1.5;
+ nof_learnts *= 1.1;
+ }
+ if (s->verbosity >= 1)
+ printf("==============================================================================\n");
+
+ solver_canceluntil(s,0);
+ return status != l_False;
+}
+
+
+int solver_nvars(solver* s)
+{
+ return s->size;
+}
+
+
+int solver_nclauses(solver* s)
+{
+ return vecp_size(&s->clauses);
+}
+
+
+int solver_nconflicts(solver* s)
+{
+ return (int)s->stats.conflicts;
+}
+
+//=================================================================================================
+// Sorting functions (sigh):
+
+static inline void selectionsort(void** array, int size, int(*comp)(const void *, const void *))
+{
+ int i, j, best_i;
+ void* tmp;
+
+ for (i = 0; i < size-1; i++){
+ best_i = i;
+ for (j = i+1; j < size; j++){
+ if (comp(array[j], array[best_i]) < 0)
+ best_i = j;
+ }
+ tmp = array[i]; array[i] = array[best_i]; array[best_i] = tmp;
+ }
+}
+
+
+static void sortrnd(void** array, int size, int(*comp)(const void *, const void *), double* seed)
+{
+ if (size <= 15)
+ selectionsort(array, size, comp);
+
+ else{
+ void* pivot = array[irand(seed, size)];
+ void* tmp;
+ int i = -1;
+ int j = size;
+
+ for(;;){
+ do i++; while(comp(array[i], pivot)<0);
+ do j--; while(comp(pivot, array[j])<0);
+
+ if (i >= j) break;
+
+ tmp = array[i]; array[i] = array[j]; array[j] = tmp;
+ }
+
+ sortrnd(array , i , comp, seed);
+ sortrnd(&array[i], size-i, comp, seed);
+ }
+}
+
+void sort(void** array, int size, int(*comp)(const void *, const void *))
+{
+ double seed = 91648253;
+ sortrnd(array,size,comp,&seed);
+}
diff --git a/test/monniaux/minisat/solver.h b/test/monniaux/minisat/solver.h
new file mode 100644
index 00000000..c9ce0219
--- /dev/null
+++ b/test/monniaux/minisat/solver.h
@@ -0,0 +1,137 @@
+/**************************************************************************************************
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
+associated documentation files (the "Software"), to deal in the Software without restriction,
+including without limitation the rights to use, copy, modify, merge, publish, distribute,
+sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or
+substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT
+NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
+OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+**************************************************************************************************/
+// Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko
+
+#ifndef solver_h
+#define solver_h
+
+#ifdef _WIN32
+#define inline __inline // compatible with MS VS 6.0
+#endif
+
+#include "vec.h"
+
+//=================================================================================================
+// Simple types:
+
+// does not work for c++
+typedef int bool;
+static const bool true = 1;
+static const bool false = 0;
+
+typedef int lit;
+typedef char lbool;
+
+#ifdef _WIN32
+typedef signed __int64 uint64; // compatible with MS VS 6.0
+#else
+typedef unsigned long long uint64;
+#endif
+
+static const int var_Undef = -1;
+static const lit lit_Undef = -2;
+
+static const lbool l_Undef = 0;
+static const lbool l_True = 1;
+static const lbool l_False = -1;
+
+static inline lit toLit (int v) { return v + v; }
+static inline lit lit_neg (lit l) { return l ^ 1; }
+static inline int lit_var (lit l) { return l >> 1; }
+static inline int lit_sign(lit l) { return (l & 1); }
+
+
+//=================================================================================================
+// Public interface:
+
+struct solver_t;
+typedef struct solver_t solver;
+
+extern solver* solver_new(void);
+extern void solver_delete(solver* s);
+
+extern bool solver_addclause(solver* s, lit* begin, lit* end);
+extern bool solver_simplify(solver* s);
+extern bool solver_solve(solver* s, lit* begin, lit* end);
+
+extern int solver_nvars(solver* s);
+extern int solver_nclauses(solver* s);
+extern int solver_nconflicts(solver* s);
+
+extern void solver_setnvars(solver* s,int n);
+
+struct stats_t
+{
+ uint64 starts, decisions, propagations, inspects, conflicts;
+ uint64 clauses, clauses_literals, learnts, learnts_literals, max_literals, tot_literals;
+};
+typedef struct stats_t stats;
+
+//=================================================================================================
+// Solver representation:
+
+struct clause_t;
+typedef struct clause_t clause;
+
+struct solver_t
+{
+ int size; // nof variables
+ int cap; // size of varmaps
+ int qhead; // Head index of queue.
+ int qtail; // Tail index of queue.
+
+ // clauses
+ vecp clauses; // List of problem constraints. (contains: clause*)
+ vecp learnts; // List of learnt clauses. (contains: clause*)
+
+ // activities
+ double var_inc; // Amount to bump next variable with.
+ double var_decay; // INVERSE decay factor for variable activity: stores 1/decay.
+ float cla_inc; // Amount to bump next clause with.
+ float cla_decay; // INVERSE decay factor for clause activity: stores 1/decay.
+
+ vecp* wlists; //
+ double* activity; // A heuristic measurement of the activity of a variable.
+ lbool* assigns; // Current values of variables.
+ int* orderpos; // Index in variable order.
+ clause** reasons; //
+ int* levels; //
+ lit* trail;
+
+ clause* binary; // A temporary binary clause
+ lbool* tags; //
+ veci tagged; // (contains: var)
+ veci stack; // (contains: var)
+
+ veci order; // Variable order. (heap) (contains: var)
+ veci trail_lim; // Separator indices for different decision levels in 'trail'. (contains: int)
+ veci model; // If problem is solved, this vector contains the model (contains: lbool).
+
+ int root_level; // Level of first proper decision.
+ int simpdb_assigns;// Number of top-level assignments at last 'simplifyDB()'.
+ int simpdb_props; // Number of propagations before next 'simplifyDB()'.
+ double random_seed;
+ double progress_estimate;
+ int verbosity; // Verbosity level. 0=silent, 1=some progress report, 2=everything
+
+ stats stats;
+};
+
+#endif
diff --git a/test/monniaux/minisat/sudoku.sat b/test/monniaux/minisat/sudoku.sat
new file mode 120000
index 00000000..1b78bb27
--- /dev/null
+++ b/test/monniaux/minisat/sudoku.sat
@@ -0,0 +1 @@
+../picosat-965/sudoku.sat \ No newline at end of file
diff --git a/test/monniaux/minisat/vec.h b/test/monniaux/minisat/vec.h
new file mode 100644
index 00000000..5ccf5fc2
--- /dev/null
+++ b/test/monniaux/minisat/vec.h
@@ -0,0 +1,84 @@
+/**************************************************************************************************
+MiniSat -- Copyright (c) 2005, Niklas Sorensson
+http://www.cs.chalmers.se/Cs/Research/FormalMethods/MiniSat/
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
+associated documentation files (the "Software"), to deal in the Software without restriction,
+including without limitation the rights to use, copy, modify, merge, publish, distribute,
+sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all copies or
+substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT
+NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
+DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT
+OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+**************************************************************************************************/
+// Modified to compile with MS Visual Studio 6.0 by Alan Mishchenko
+
+#ifndef vec_h
+#define vec_h
+
+#include <stdlib.h>
+
+
+// vector of 32-bit intergers (added for 64-bit portability)
+struct veci_t {
+ int size;
+ int cap;
+ int* ptr;
+};
+typedef struct veci_t veci;
+
+static inline void veci_new (veci* v) {
+ v->size = 0;
+ v->cap = 4;
+ v->ptr = (int*)malloc(sizeof(int)*v->cap);
+}
+
+static inline void veci_delete (veci* v) { free(v->ptr); }
+static inline int* veci_begin (veci* v) { return v->ptr; }
+static inline int veci_size (veci* v) { return v->size; }
+static inline void veci_resize (veci* v, int k) { v->size = k; } // only safe to shrink !!
+static inline void veci_push (veci* v, int e)
+{
+ if (v->size == v->cap) {
+ int newsize = v->cap * 2+1;
+ v->ptr = (int*)realloc(v->ptr,sizeof(int)*newsize);
+ v->cap = newsize; }
+ v->ptr[v->size++] = e;
+}
+
+
+// vector of 32- or 64-bit pointers
+struct vecp_t {
+ int size;
+ int cap;
+ void** ptr;
+};
+typedef struct vecp_t vecp;
+
+static inline void vecp_new (vecp* v) {
+ v->size = 0;
+ v->cap = 4;
+ v->ptr = (void**)malloc(sizeof(void*)*v->cap);
+}
+
+static inline void vecp_delete (vecp* v) { free(v->ptr); }
+static inline void** vecp_begin (vecp* v) { return v->ptr; }
+static inline int vecp_size (vecp* v) { return v->size; }
+static inline void vecp_resize (vecp* v, int k) { v->size = k; } // only safe to shrink !!
+static inline void vecp_push (vecp* v, void* e)
+{
+ if (v->size == v->cap) {
+ int newsize = v->cap * 2+1;
+ v->ptr = (void**)realloc(v->ptr,sizeof(void*)*newsize);
+ v->cap = newsize; }
+ v->ptr[v->size++] = e;
+}
+
+
+#endif
diff --git a/test/monniaux/moves/array.c b/test/monniaux/moves/array.c
new file mode 100644
index 00000000..faa1d96b
--- /dev/null
+++ b/test/monniaux/moves/array.c
@@ -0,0 +1,18 @@
+void incr_double_array(double *t) {
+ double x0 = 1.0;
+ double t0 = t[0];
+ double x1 = 1.0;
+ double t1 = t[1];
+ double x2 = 1.0;
+ double t2 = t[2];
+ double x3 = 1.0;
+ double t3 = t[3];
+ t0 = t0 + x0;
+ t1 = t1 + x1;
+ t2 = t2 + x2;
+ t3 = t3 + x3;
+ t[0] = t0;
+ t[1] = t1;
+ t[2] = t2;
+ t[3] = t3;
+}
diff --git a/test/monniaux/ncompress/Makefile b/test/monniaux/ncompress/Makefile
index cf543976..14a99d0b 100644
--- a/test/monniaux/ncompress/Makefile
+++ b/test/monniaux/ncompress/Makefile
@@ -1,52 +1,4 @@
-include ../rules.mk
-
-all: check
-
-
-all: compress.gcc.host compress.ccomp.host compress.gcc.k1c compress.ccomp.k1c
-
-compress.gcc.host : compress42.c ../clock.gcc.host.o
- $(CC) $(CFLAGS) $+ -o $@
-
-compress.ccomp.host : compress42.c ../clock.gcc.host.o
- $(CCOMP) $(CCOMPFLAGS) $+ -o $@
-
-compress.gcc.k1c : compress42.gcc.k1c.o ../clock.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
-
-compress.ccomp.k1c : compress42.ccomp.k1c.o ../clock.gcc.k1c.o
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
-
-INFILE=Makefile
-COMPRESSED=foo.gcc.host.Z
-
-foo.gcc.host.Z: compress.gcc.host $(INFILE)
- ./compress.gcc.host <$(INFILE) >foo.gcc.host.Z 2> foo.gcc.host.Z.out
+TARGET=compress
+EXECUTE_ARGS= < Makefile > __BASE__.Z 2> __BASE__.out
-foo.ccomp.k1c.Z: compress.ccomp.k1c $(INFILE)
- $(EXECUTE) ./compress.ccomp.k1c <$(INFILE) >foo.ccomp.k1c.Z 2> foo.ccomp.k1c.Z.out
-
-foo.gcc.k1c.Z: compress.gcc.k1c $(INFILE)
- $(EXECUTE) ./compress.gcc.k1c <$(INFILE) >foo.gcc.k1c.Z 2> foo.gcc.k1c.Z.out
-
-foo.gcc.host.txt: compress.gcc.host $(COMPRESSED)
- ./compress.gcc.host -d <$(COMPRESSED) >foo.gcc.host.txt 2> foo.gcc.host.txt.out
-
-foo.ccomp.k1c.txt: compress.gcc.host $(COMPRESSED)
- $(EXECUTE) ./compress.ccomp.k1c -d <$(COMPRESSED) >foo.ccomp.k1c.txt 2> foo.ccomp.k1c.txt.out
-
-foo.gcc.k1c.txt: compress.gcc.host $(COMPRESSED)
- $(EXECUTE) ./compress.gcc.k1c -d <$(COMPRESSED) >foo.gcc.k1c.txt 2> foo.gcc.k1c.txt.out
-
-check: foo.gcc.host.Z foo.gcc.host.txt foo.ccomp.k1c.Z foo.ccomp.k1c.txt foo.gcc.k1c.Z foo.gcc.k1c.txt
- cmp foo.gcc.host.Z foo.ccomp.k1c.Z
- cmp foo.gcc.host.Z foo.gcc.k1c.Z
- cmp foo.gcc.host.txt foo.ccomp.k1c.txt
- cmp foo.gcc.host.txt foo.gcc.k1c.txt
-
-clean:
- rm -f *.Z *.txt *.out *.o *.s *.host *.k1c
-
-.PHONY: clean
-
-.SECONDARY: %.s
+include ../rules.mk
diff --git a/test/monniaux/number_theoretic_transform/Makefile b/test/monniaux/number_theoretic_transform/Makefile
new file mode 100644
index 00000000..bd70b946
--- /dev/null
+++ b/test/monniaux/number_theoretic_transform/Makefile
@@ -0,0 +1,3 @@
+TARGET=ntt
+
+include ../rules.mk
diff --git a/test/monniaux/number_theoretic_transform/make.proto b/test/monniaux/number_theoretic_transform/make.proto
deleted file mode 100644
index e1844226..00000000
--- a/test/monniaux/number_theoretic_transform/make.proto
+++ /dev/null
@@ -1,2 +0,0 @@
-target: ntt
-measures: [cycles]
diff --git a/test/monniaux/ocaml/Makefile b/test/monniaux/ocaml/Makefile
index 0ae7c22f..20f32b65 100644
--- a/test/monniaux/ocaml/Makefile
+++ b/test/monniaux/ocaml/Makefile
@@ -1,29 +1,6 @@
-ALL_CFLAGS=-Ibyterun
+TARGET=ocaml
+ALL_CFLAGS=-Ibyterun -lm
+ALL_CFILES=$(wildcard byterun/*.c)
EXECUTE_ARGS=examples/quicksort
include ../rules.mk
-
-ALL_CCOMPFLAGS=
-LDLIBS=-lm
-
-CFILES=$(wildcard byterun/*.c)
-
-CCOMP_K1C_S=$(patsubst %.c,%.ccomp.k1c.s,$(CFILES))
-CCOMP_HOST_S=$(patsubst %.c,%.ccomp.host.s,$(CFILES))
-
-GCC_K1C_S=$(patsubst %.c,%.gcc.k1c.s,$(CFILES))
-GCC_HOST_S=$(patsubst %.c,%.gcc.host.s,$(CFILES))
-
-all: $(CCOMP_K1C_S) $(GCC_K1C_S) ocamlrun.ccomp.k1c.out ocamlrun.gcc.k1c.out
-
-ocamlrun.ccomp.k1c : $(CCOMP_K1C_S) ../clock.gcc.k1c.o
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@ $(LDLIBS)
-
-ocamlrun.ccomp.host : $(CCOMP_HOST_S) ../clock.gcc.host.o
- $(CCOMP) $(CCOMPFLAGS) $+ -o $@ $(LDLIBS)
-
-ocamlrun.gcc.k1c : $(GCC_K1C_S) ../clock.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS) $+ -o $@ $(LDLIBS)
-
-ocamlrun.gcc.host : $(GCC_HOST_S) ../clock.gcc.host.o
- $(CC) $(CFLAGS) $+ -o $@ $(LDLIBS)
diff --git a/test/monniaux/ocaml/byterun/caml/version.h b/test/monniaux/ocaml/byterun/caml/version.h
new file mode 100644
index 00000000..68d7000e
--- /dev/null
+++ b/test/monniaux/ocaml/byterun/caml/version.h
@@ -0,0 +1,6 @@
+#define OCAML_VERSION_MAJOR 4
+#define OCAML_VERSION_MINOR 7
+#define OCAML_VERSION_PATCHLEVEL 1
+#undef OCAML_VERSION_ADDITIONAL
+#define OCAML_VERSION 40701
+#define OCAML_VERSION_STRING "4.07.1"
diff --git a/test/monniaux/ocaml/byterun/prims.c b/test/monniaux/ocaml/byterun/prims.c
new file mode 100644
index 00000000..15ebf593
--- /dev/null
+++ b/test/monniaux/ocaml/byterun/prims.c
@@ -0,0 +1,1153 @@
+#define CAML_INTERNALS
+#include "caml/mlvalues.h"
+#include "caml/prims.h"
+extern value caml_abs_float();
+extern value caml_acos_float();
+extern value caml_add_debug_info();
+extern value caml_add_float();
+extern value caml_alloc_dummy();
+extern value caml_alloc_dummy_float();
+extern value caml_alloc_dummy_function();
+extern value caml_array_append();
+extern value caml_array_blit();
+extern value caml_array_concat();
+extern value caml_array_get();
+extern value caml_array_get_addr();
+extern value caml_array_get_float();
+extern value caml_array_set();
+extern value caml_array_set_addr();
+extern value caml_array_set_float();
+extern value caml_array_sub();
+extern value caml_array_unsafe_get();
+extern value caml_array_unsafe_get_float();
+extern value caml_array_unsafe_set();
+extern value caml_array_unsafe_set_addr();
+extern value caml_array_unsafe_set_float();
+extern value caml_asin_float();
+extern value caml_atan2_float();
+extern value caml_atan_float();
+extern value caml_ba_blit();
+extern value caml_ba_change_layout();
+extern value caml_ba_create();
+extern value caml_ba_dim();
+extern value caml_ba_dim_1();
+extern value caml_ba_dim_2();
+extern value caml_ba_dim_3();
+extern value caml_ba_fill();
+extern value caml_ba_get_1();
+extern value caml_ba_get_2();
+extern value caml_ba_get_3();
+extern value caml_ba_get_generic();
+extern value caml_ba_kind();
+extern value caml_ba_layout();
+extern value caml_ba_num_dims();
+extern value caml_ba_reshape();
+extern value caml_ba_set_1();
+extern value caml_ba_set_2();
+extern value caml_ba_set_3();
+extern value caml_ba_set_generic();
+extern value caml_ba_slice();
+extern value caml_ba_sub();
+extern value caml_ba_uint8_get16();
+extern value caml_ba_uint8_get32();
+extern value caml_ba_uint8_get64();
+extern value caml_ba_uint8_set16();
+extern value caml_ba_uint8_set32();
+extern value caml_ba_uint8_set64();
+extern value caml_backtrace_status();
+extern value caml_blit_bytes();
+extern value caml_blit_string();
+extern value caml_bswap16();
+extern value caml_bytes_compare();
+extern value caml_bytes_equal();
+extern value caml_bytes_get();
+extern value caml_bytes_get16();
+extern value caml_bytes_get32();
+extern value caml_bytes_get64();
+extern value caml_bytes_greaterequal();
+extern value caml_bytes_greaterthan();
+extern value caml_bytes_lessequal();
+extern value caml_bytes_lessthan();
+extern value caml_bytes_notequal();
+extern value caml_bytes_of_string();
+extern value caml_bytes_set();
+extern value caml_bytes_set16();
+extern value caml_bytes_set32();
+extern value caml_bytes_set64();
+extern value caml_ceil_float();
+extern value caml_channel_descriptor();
+extern value caml_classify_float();
+extern value caml_compare();
+extern value caml_convert_raw_backtrace();
+extern value caml_convert_raw_backtrace_slot();
+extern value caml_copysign_float();
+extern value caml_cos_float();
+extern value caml_cosh_float();
+extern value caml_create_bytes();
+extern value caml_create_string();
+extern value caml_div_float();
+extern value caml_dynlink_add_primitive();
+extern value caml_dynlink_close_lib();
+extern value caml_dynlink_get_current_libs();
+extern value caml_dynlink_lookup_symbol();
+extern value caml_dynlink_open_lib();
+extern value caml_ensure_stack_capacity();
+extern value caml_ephe_blit_data();
+extern value caml_ephe_blit_key();
+extern value caml_ephe_check_data();
+extern value caml_ephe_check_key();
+extern value caml_ephe_create();
+extern value caml_ephe_get_data();
+extern value caml_ephe_get_data_copy();
+extern value caml_ephe_get_key();
+extern value caml_ephe_get_key_copy();
+extern value caml_ephe_set_data();
+extern value caml_ephe_set_key();
+extern value caml_ephe_unset_data();
+extern value caml_ephe_unset_key();
+extern value caml_eq_float();
+extern value caml_equal();
+extern value caml_exp_float();
+extern value caml_expm1_float();
+extern value caml_fill_bytes();
+extern value caml_fill_string();
+extern value caml_final_register();
+extern value caml_final_register_called_without_value();
+extern value caml_final_release();
+extern value caml_float_compare();
+extern value caml_float_of_int();
+extern value caml_float_of_string();
+extern value caml_floatarray_create();
+extern value caml_floatarray_get();
+extern value caml_floatarray_set();
+extern value caml_floatarray_unsafe_get();
+extern value caml_floatarray_unsafe_set();
+extern value caml_floor_float();
+extern value caml_fmod_float();
+extern value caml_format_float();
+extern value caml_format_int();
+extern value caml_fresh_oo_id();
+extern value caml_frexp_float();
+extern value caml_gc_compaction();
+extern value caml_gc_counters();
+extern value caml_gc_full_major();
+extern value caml_gc_get();
+extern value caml_gc_huge_fallback_count();
+extern value caml_gc_major();
+extern value caml_gc_major_slice();
+extern value caml_gc_minor();
+extern value caml_gc_minor_words();
+extern value caml_gc_quick_stat();
+extern value caml_gc_set();
+extern value caml_gc_stat();
+extern value caml_ge_float();
+extern value caml_get_current_callstack();
+extern value caml_get_current_environment();
+extern value caml_get_exception_backtrace();
+extern value caml_get_exception_raw_backtrace();
+extern value caml_get_global_data();
+extern value caml_get_major_bucket();
+extern value caml_get_major_credit();
+extern value caml_get_minor_free();
+extern value caml_get_public_method();
+extern value caml_get_section_table();
+extern value caml_greaterequal();
+extern value caml_greaterthan();
+extern value caml_gt_float();
+extern value caml_hash();
+extern value caml_hash_univ_param();
+extern value caml_hexstring_of_float();
+extern value caml_hypot_float();
+extern value caml_input_value();
+extern value caml_input_value_from_bytes();
+extern value caml_input_value_from_string();
+extern value caml_input_value_to_outside_heap();
+extern value caml_install_signal_handler();
+extern value caml_int32_add();
+extern value caml_int32_and();
+extern value caml_int32_bits_of_float();
+extern value caml_int32_bswap();
+extern value caml_int32_compare();
+extern value caml_int32_div();
+extern value caml_int32_float_of_bits();
+extern value caml_int32_format();
+extern value caml_int32_mod();
+extern value caml_int32_mul();
+extern value caml_int32_neg();
+extern value caml_int32_of_float();
+extern value caml_int32_of_int();
+extern value caml_int32_of_string();
+extern value caml_int32_or();
+extern value caml_int32_shift_left();
+extern value caml_int32_shift_right();
+extern value caml_int32_shift_right_unsigned();
+extern value caml_int32_sub();
+extern value caml_int32_to_float();
+extern value caml_int32_to_int();
+extern value caml_int32_xor();
+extern value caml_int64_add();
+extern value caml_int64_and();
+extern value caml_int64_bits_of_float();
+extern value caml_int64_bswap();
+extern value caml_int64_compare();
+extern value caml_int64_div();
+extern value caml_int64_float_of_bits();
+extern value caml_int64_format();
+extern value caml_int64_mod();
+extern value caml_int64_mul();
+extern value caml_int64_neg();
+extern value caml_int64_of_float();
+extern value caml_int64_of_int();
+extern value caml_int64_of_int32();
+extern value caml_int64_of_nativeint();
+extern value caml_int64_of_string();
+extern value caml_int64_or();
+extern value caml_int64_shift_left();
+extern value caml_int64_shift_right();
+extern value caml_int64_shift_right_unsigned();
+extern value caml_int64_sub();
+extern value caml_int64_to_float();
+extern value caml_int64_to_int();
+extern value caml_int64_to_int32();
+extern value caml_int64_to_nativeint();
+extern value caml_int64_xor();
+extern value caml_int_as_pointer();
+extern value caml_int_compare();
+extern value caml_int_of_float();
+extern value caml_int_of_string();
+extern value caml_invoke_traced_function();
+extern value caml_lazy_follow_forward();
+extern value caml_lazy_make_forward();
+extern value caml_ldexp_float();
+extern value caml_le_float();
+extern value caml_lessequal();
+extern value caml_lessthan();
+extern value caml_lex_engine();
+extern value caml_log10_float();
+extern value caml_log1p_float();
+extern value caml_log_float();
+extern value caml_lt_float();
+extern value caml_make_array();
+extern value caml_make_float_vect();
+extern value caml_make_vect();
+extern value caml_marshal_data_size();
+extern value caml_md5_chan();
+extern value caml_md5_string();
+extern value caml_ml_bytes_length();
+extern value caml_ml_channel_size();
+extern value caml_ml_channel_size_64();
+extern value caml_ml_close_channel();
+extern value caml_ml_enable_runtime_warnings();
+extern value caml_ml_flush();
+extern value caml_ml_flush_partial();
+extern value caml_ml_input();
+extern value caml_ml_input_char();
+extern value caml_ml_input_int();
+extern value caml_ml_input_scan_line();
+extern value caml_ml_open_descriptor_in();
+extern value caml_ml_open_descriptor_out();
+extern value caml_ml_out_channels_list();
+extern value caml_ml_output();
+extern value caml_ml_output_bytes();
+extern value caml_ml_output_char();
+extern value caml_ml_output_int();
+extern value caml_ml_output_partial();
+extern value caml_ml_pos_in();
+extern value caml_ml_pos_in_64();
+extern value caml_ml_pos_out();
+extern value caml_ml_pos_out_64();
+extern value caml_ml_runtime_warnings_enabled();
+extern value caml_ml_seek_in();
+extern value caml_ml_seek_in_64();
+extern value caml_ml_seek_out();
+extern value caml_ml_seek_out_64();
+extern value caml_ml_set_binary_mode();
+extern value caml_ml_set_channel_name();
+extern value caml_ml_string_length();
+extern value caml_modf_float();
+extern value caml_mul_float();
+extern value caml_nativeint_add();
+extern value caml_nativeint_and();
+extern value caml_nativeint_bswap();
+extern value caml_nativeint_compare();
+extern value caml_nativeint_div();
+extern value caml_nativeint_format();
+extern value caml_nativeint_mod();
+extern value caml_nativeint_mul();
+extern value caml_nativeint_neg();
+extern value caml_nativeint_of_float();
+extern value caml_nativeint_of_int();
+extern value caml_nativeint_of_int32();
+extern value caml_nativeint_of_string();
+extern value caml_nativeint_or();
+extern value caml_nativeint_shift_left();
+extern value caml_nativeint_shift_right();
+extern value caml_nativeint_shift_right_unsigned();
+extern value caml_nativeint_sub();
+extern value caml_nativeint_to_float();
+extern value caml_nativeint_to_int();
+extern value caml_nativeint_to_int32();
+extern value caml_nativeint_xor();
+extern value caml_neg_float();
+extern value caml_neq_float();
+extern value caml_new_lex_engine();
+extern value caml_notequal();
+extern value caml_obj_add_offset();
+extern value caml_obj_block();
+extern value caml_obj_dup();
+extern value caml_obj_is_block();
+extern value caml_obj_reachable_words();
+extern value caml_obj_set_tag();
+extern value caml_obj_tag();
+extern value caml_obj_truncate();
+extern value caml_output_value();
+extern value caml_output_value_to_buffer();
+extern value caml_output_value_to_bytes();
+extern value caml_output_value_to_string();
+extern value caml_parse_engine();
+extern value caml_power_float();
+extern value caml_raw_backtrace_length();
+extern value caml_raw_backtrace_next_slot();
+extern value caml_raw_backtrace_slot();
+extern value caml_realloc_global();
+extern value caml_record_backtrace();
+extern value caml_register_channel_for_spacetime();
+extern value caml_register_code_fragment();
+extern value caml_register_named_value();
+extern value caml_reify_bytecode();
+extern value caml_remove_debug_info();
+extern value caml_reset_afl_instrumentation();
+extern value caml_restore_raw_backtrace();
+extern value caml_runtime_parameters();
+extern value caml_runtime_variant();
+extern value caml_set_oo_id();
+extern value caml_set_parser_trace();
+extern value caml_setup_afl();
+extern value caml_sin_float();
+extern value caml_sinh_float();
+extern value caml_spacetime_enabled();
+extern value caml_spacetime_only_works_for_native_code();
+extern value caml_sqrt_float();
+extern value caml_static_alloc();
+extern value caml_static_free();
+extern value caml_static_release_bytecode();
+extern value caml_static_resize();
+extern value caml_string_compare();
+extern value caml_string_equal();
+extern value caml_string_get();
+extern value caml_string_get16();
+extern value caml_string_get32();
+extern value caml_string_get64();
+extern value caml_string_greaterequal();
+extern value caml_string_greaterthan();
+extern value caml_string_lessequal();
+extern value caml_string_lessthan();
+extern value caml_string_notequal();
+extern value caml_string_of_bytes();
+extern value caml_string_set();
+extern value caml_sub_float();
+extern value caml_sys_chdir();
+extern value caml_sys_close();
+extern value caml_sys_const_backend_type();
+extern value caml_sys_const_big_endian();
+extern value caml_sys_const_int_size();
+extern value caml_sys_const_max_wosize();
+extern value caml_sys_const_ostype_cygwin();
+extern value caml_sys_const_ostype_unix();
+extern value caml_sys_const_ostype_win32();
+extern value caml_sys_const_word_size();
+extern value caml_sys_exit();
+extern value caml_sys_file_exists();
+extern value caml_sys_get_argv();
+extern value caml_sys_get_config();
+extern value caml_sys_getcwd();
+extern value caml_sys_getenv();
+extern value caml_sys_is_directory();
+extern value caml_sys_isatty();
+extern value caml_sys_open();
+extern value caml_sys_random_seed();
+extern value caml_sys_read_directory();
+extern value caml_sys_remove();
+extern value caml_sys_rename();
+extern value caml_sys_system_command();
+extern value caml_sys_time();
+extern value caml_sys_time_include_children();
+extern value caml_sys_unsafe_getenv();
+extern value caml_tan_float();
+extern value caml_tanh_float();
+extern value caml_terminfo_rows();
+extern value caml_update_dummy();
+extern value caml_weak_blit();
+extern value caml_weak_check();
+extern value caml_weak_create();
+extern value caml_weak_get();
+extern value caml_weak_get_copy();
+extern value caml_weak_set();
+c_primitive caml_builtin_cprim[] = {
+ caml_abs_float,
+ caml_acos_float,
+ caml_add_debug_info,
+ caml_add_float,
+ caml_alloc_dummy,
+ caml_alloc_dummy_float,
+ caml_alloc_dummy_function,
+ caml_array_append,
+ caml_array_blit,
+ caml_array_concat,
+ caml_array_get,
+ caml_array_get_addr,
+ caml_array_get_float,
+ caml_array_set,
+ caml_array_set_addr,
+ caml_array_set_float,
+ caml_array_sub,
+ caml_array_unsafe_get,
+ caml_array_unsafe_get_float,
+ caml_array_unsafe_set,
+ caml_array_unsafe_set_addr,
+ caml_array_unsafe_set_float,
+ caml_asin_float,
+ caml_atan2_float,
+ caml_atan_float,
+ caml_ba_blit,
+ caml_ba_change_layout,
+ caml_ba_create,
+ caml_ba_dim,
+ caml_ba_dim_1,
+ caml_ba_dim_2,
+ caml_ba_dim_3,
+ caml_ba_fill,
+ caml_ba_get_1,
+ caml_ba_get_2,
+ caml_ba_get_3,
+ caml_ba_get_generic,
+ caml_ba_kind,
+ caml_ba_layout,
+ caml_ba_num_dims,
+ caml_ba_reshape,
+ caml_ba_set_1,
+ caml_ba_set_2,
+ caml_ba_set_3,
+ caml_ba_set_generic,
+ caml_ba_slice,
+ caml_ba_sub,
+ caml_ba_uint8_get16,
+ caml_ba_uint8_get32,
+ caml_ba_uint8_get64,
+ caml_ba_uint8_set16,
+ caml_ba_uint8_set32,
+ caml_ba_uint8_set64,
+ caml_backtrace_status,
+ caml_blit_bytes,
+ caml_blit_string,
+ caml_bswap16,
+ caml_bytes_compare,
+ caml_bytes_equal,
+ caml_bytes_get,
+ caml_bytes_get16,
+ caml_bytes_get32,
+ caml_bytes_get64,
+ caml_bytes_greaterequal,
+ caml_bytes_greaterthan,
+ caml_bytes_lessequal,
+ caml_bytes_lessthan,
+ caml_bytes_notequal,
+ caml_bytes_of_string,
+ caml_bytes_set,
+ caml_bytes_set16,
+ caml_bytes_set32,
+ caml_bytes_set64,
+ caml_ceil_float,
+ caml_channel_descriptor,
+ caml_classify_float,
+ caml_compare,
+ caml_convert_raw_backtrace,
+ caml_convert_raw_backtrace_slot,
+ caml_copysign_float,
+ caml_cos_float,
+ caml_cosh_float,
+ caml_create_bytes,
+ caml_create_string,
+ caml_div_float,
+ caml_dynlink_add_primitive,
+ caml_dynlink_close_lib,
+ caml_dynlink_get_current_libs,
+ caml_dynlink_lookup_symbol,
+ caml_dynlink_open_lib,
+ caml_ensure_stack_capacity,
+ caml_ephe_blit_data,
+ caml_ephe_blit_key,
+ caml_ephe_check_data,
+ caml_ephe_check_key,
+ caml_ephe_create,
+ caml_ephe_get_data,
+ caml_ephe_get_data_copy,
+ caml_ephe_get_key,
+ caml_ephe_get_key_copy,
+ caml_ephe_set_data,
+ caml_ephe_set_key,
+ caml_ephe_unset_data,
+ caml_ephe_unset_key,
+ caml_eq_float,
+ caml_equal,
+ caml_exp_float,
+ caml_expm1_float,
+ caml_fill_bytes,
+ caml_fill_string,
+ caml_final_register,
+ caml_final_register_called_without_value,
+ caml_final_release,
+ caml_float_compare,
+ caml_float_of_int,
+ caml_float_of_string,
+ caml_floatarray_create,
+ caml_floatarray_get,
+ caml_floatarray_set,
+ caml_floatarray_unsafe_get,
+ caml_floatarray_unsafe_set,
+ caml_floor_float,
+ caml_fmod_float,
+ caml_format_float,
+ caml_format_int,
+ caml_fresh_oo_id,
+ caml_frexp_float,
+ caml_gc_compaction,
+ caml_gc_counters,
+ caml_gc_full_major,
+ caml_gc_get,
+ caml_gc_huge_fallback_count,
+ caml_gc_major,
+ caml_gc_major_slice,
+ caml_gc_minor,
+ caml_gc_minor_words,
+ caml_gc_quick_stat,
+ caml_gc_set,
+ caml_gc_stat,
+ caml_ge_float,
+ caml_get_current_callstack,
+ caml_get_current_environment,
+ caml_get_exception_backtrace,
+ caml_get_exception_raw_backtrace,
+ caml_get_global_data,
+ caml_get_major_bucket,
+ caml_get_major_credit,
+ caml_get_minor_free,
+ caml_get_public_method,
+ caml_get_section_table,
+ caml_greaterequal,
+ caml_greaterthan,
+ caml_gt_float,
+ caml_hash,
+ caml_hash_univ_param,
+ caml_hexstring_of_float,
+ caml_hypot_float,
+ caml_input_value,
+ caml_input_value_from_bytes,
+ caml_input_value_from_string,
+ caml_input_value_to_outside_heap,
+ caml_install_signal_handler,
+ caml_int32_add,
+ caml_int32_and,
+ caml_int32_bits_of_float,
+ caml_int32_bswap,
+ caml_int32_compare,
+ caml_int32_div,
+ caml_int32_float_of_bits,
+ caml_int32_format,
+ caml_int32_mod,
+ caml_int32_mul,
+ caml_int32_neg,
+ caml_int32_of_float,
+ caml_int32_of_int,
+ caml_int32_of_string,
+ caml_int32_or,
+ caml_int32_shift_left,
+ caml_int32_shift_right,
+ caml_int32_shift_right_unsigned,
+ caml_int32_sub,
+ caml_int32_to_float,
+ caml_int32_to_int,
+ caml_int32_xor,
+ caml_int64_add,
+ caml_int64_and,
+ caml_int64_bits_of_float,
+ caml_int64_bswap,
+ caml_int64_compare,
+ caml_int64_div,
+ caml_int64_float_of_bits,
+ caml_int64_format,
+ caml_int64_mod,
+ caml_int64_mul,
+ caml_int64_neg,
+ caml_int64_of_float,
+ caml_int64_of_int,
+ caml_int64_of_int32,
+ caml_int64_of_nativeint,
+ caml_int64_of_string,
+ caml_int64_or,
+ caml_int64_shift_left,
+ caml_int64_shift_right,
+ caml_int64_shift_right_unsigned,
+ caml_int64_sub,
+ caml_int64_to_float,
+ caml_int64_to_int,
+ caml_int64_to_int32,
+ caml_int64_to_nativeint,
+ caml_int64_xor,
+ caml_int_as_pointer,
+ caml_int_compare,
+ caml_int_of_float,
+ caml_int_of_string,
+ caml_invoke_traced_function,
+ caml_lazy_follow_forward,
+ caml_lazy_make_forward,
+ caml_ldexp_float,
+ caml_le_float,
+ caml_lessequal,
+ caml_lessthan,
+ caml_lex_engine,
+ caml_log10_float,
+ caml_log1p_float,
+ caml_log_float,
+ caml_lt_float,
+ caml_make_array,
+ caml_make_float_vect,
+ caml_make_vect,
+ caml_marshal_data_size,
+ caml_md5_chan,
+ caml_md5_string,
+ caml_ml_bytes_length,
+ caml_ml_channel_size,
+ caml_ml_channel_size_64,
+ caml_ml_close_channel,
+ caml_ml_enable_runtime_warnings,
+ caml_ml_flush,
+ caml_ml_flush_partial,
+ caml_ml_input,
+ caml_ml_input_char,
+ caml_ml_input_int,
+ caml_ml_input_scan_line,
+ caml_ml_open_descriptor_in,
+ caml_ml_open_descriptor_out,
+ caml_ml_out_channels_list,
+ caml_ml_output,
+ caml_ml_output_bytes,
+ caml_ml_output_char,
+ caml_ml_output_int,
+ caml_ml_output_partial,
+ caml_ml_pos_in,
+ caml_ml_pos_in_64,
+ caml_ml_pos_out,
+ caml_ml_pos_out_64,
+ caml_ml_runtime_warnings_enabled,
+ caml_ml_seek_in,
+ caml_ml_seek_in_64,
+ caml_ml_seek_out,
+ caml_ml_seek_out_64,
+ caml_ml_set_binary_mode,
+ caml_ml_set_channel_name,
+ caml_ml_string_length,
+ caml_modf_float,
+ caml_mul_float,
+ caml_nativeint_add,
+ caml_nativeint_and,
+ caml_nativeint_bswap,
+ caml_nativeint_compare,
+ caml_nativeint_div,
+ caml_nativeint_format,
+ caml_nativeint_mod,
+ caml_nativeint_mul,
+ caml_nativeint_neg,
+ caml_nativeint_of_float,
+ caml_nativeint_of_int,
+ caml_nativeint_of_int32,
+ caml_nativeint_of_string,
+ caml_nativeint_or,
+ caml_nativeint_shift_left,
+ caml_nativeint_shift_right,
+ caml_nativeint_shift_right_unsigned,
+ caml_nativeint_sub,
+ caml_nativeint_to_float,
+ caml_nativeint_to_int,
+ caml_nativeint_to_int32,
+ caml_nativeint_xor,
+ caml_neg_float,
+ caml_neq_float,
+ caml_new_lex_engine,
+ caml_notequal,
+ caml_obj_add_offset,
+ caml_obj_block,
+ caml_obj_dup,
+ caml_obj_is_block,
+ caml_obj_reachable_words,
+ caml_obj_set_tag,
+ caml_obj_tag,
+ caml_obj_truncate,
+ caml_output_value,
+ caml_output_value_to_buffer,
+ caml_output_value_to_bytes,
+ caml_output_value_to_string,
+ caml_parse_engine,
+ caml_power_float,
+ caml_raw_backtrace_length,
+ caml_raw_backtrace_next_slot,
+ caml_raw_backtrace_slot,
+ caml_realloc_global,
+ caml_record_backtrace,
+ caml_register_channel_for_spacetime,
+ caml_register_code_fragment,
+ caml_register_named_value,
+ caml_reify_bytecode,
+ caml_remove_debug_info,
+ caml_reset_afl_instrumentation,
+ caml_restore_raw_backtrace,
+ caml_runtime_parameters,
+ caml_runtime_variant,
+ caml_set_oo_id,
+ caml_set_parser_trace,
+ caml_setup_afl,
+ caml_sin_float,
+ caml_sinh_float,
+ caml_spacetime_enabled,
+ caml_spacetime_only_works_for_native_code,
+ caml_sqrt_float,
+ caml_static_alloc,
+ caml_static_free,
+ caml_static_release_bytecode,
+ caml_static_resize,
+ caml_string_compare,
+ caml_string_equal,
+ caml_string_get,
+ caml_string_get16,
+ caml_string_get32,
+ caml_string_get64,
+ caml_string_greaterequal,
+ caml_string_greaterthan,
+ caml_string_lessequal,
+ caml_string_lessthan,
+ caml_string_notequal,
+ caml_string_of_bytes,
+ caml_string_set,
+ caml_sub_float,
+ caml_sys_chdir,
+ caml_sys_close,
+ caml_sys_const_backend_type,
+ caml_sys_const_big_endian,
+ caml_sys_const_int_size,
+ caml_sys_const_max_wosize,
+ caml_sys_const_ostype_cygwin,
+ caml_sys_const_ostype_unix,
+ caml_sys_const_ostype_win32,
+ caml_sys_const_word_size,
+ caml_sys_exit,
+ caml_sys_file_exists,
+ caml_sys_get_argv,
+ caml_sys_get_config,
+ caml_sys_getcwd,
+ caml_sys_getenv,
+ caml_sys_is_directory,
+ caml_sys_isatty,
+ caml_sys_open,
+ caml_sys_random_seed,
+ caml_sys_read_directory,
+ caml_sys_remove,
+ caml_sys_rename,
+ caml_sys_system_command,
+ caml_sys_time,
+ caml_sys_time_include_children,
+ caml_sys_unsafe_getenv,
+ caml_tan_float,
+ caml_tanh_float,
+ caml_terminfo_rows,
+ caml_update_dummy,
+ caml_weak_blit,
+ caml_weak_check,
+ caml_weak_create,
+ caml_weak_get,
+ caml_weak_get_copy,
+ caml_weak_set,
+ 0 };
+char * caml_names_of_builtin_cprim[] = {
+ "caml_abs_float",
+ "caml_acos_float",
+ "caml_add_debug_info",
+ "caml_add_float",
+ "caml_alloc_dummy",
+ "caml_alloc_dummy_float",
+ "caml_alloc_dummy_function",
+ "caml_array_append",
+ "caml_array_blit",
+ "caml_array_concat",
+ "caml_array_get",
+ "caml_array_get_addr",
+ "caml_array_get_float",
+ "caml_array_set",
+ "caml_array_set_addr",
+ "caml_array_set_float",
+ "caml_array_sub",
+ "caml_array_unsafe_get",
+ "caml_array_unsafe_get_float",
+ "caml_array_unsafe_set",
+ "caml_array_unsafe_set_addr",
+ "caml_array_unsafe_set_float",
+ "caml_asin_float",
+ "caml_atan2_float",
+ "caml_atan_float",
+ "caml_ba_blit",
+ "caml_ba_change_layout",
+ "caml_ba_create",
+ "caml_ba_dim",
+ "caml_ba_dim_1",
+ "caml_ba_dim_2",
+ "caml_ba_dim_3",
+ "caml_ba_fill",
+ "caml_ba_get_1",
+ "caml_ba_get_2",
+ "caml_ba_get_3",
+ "caml_ba_get_generic",
+ "caml_ba_kind",
+ "caml_ba_layout",
+ "caml_ba_num_dims",
+ "caml_ba_reshape",
+ "caml_ba_set_1",
+ "caml_ba_set_2",
+ "caml_ba_set_3",
+ "caml_ba_set_generic",
+ "caml_ba_slice",
+ "caml_ba_sub",
+ "caml_ba_uint8_get16",
+ "caml_ba_uint8_get32",
+ "caml_ba_uint8_get64",
+ "caml_ba_uint8_set16",
+ "caml_ba_uint8_set32",
+ "caml_ba_uint8_set64",
+ "caml_backtrace_status",
+ "caml_blit_bytes",
+ "caml_blit_string",
+ "caml_bswap16",
+ "caml_bytes_compare",
+ "caml_bytes_equal",
+ "caml_bytes_get",
+ "caml_bytes_get16",
+ "caml_bytes_get32",
+ "caml_bytes_get64",
+ "caml_bytes_greaterequal",
+ "caml_bytes_greaterthan",
+ "caml_bytes_lessequal",
+ "caml_bytes_lessthan",
+ "caml_bytes_notequal",
+ "caml_bytes_of_string",
+ "caml_bytes_set",
+ "caml_bytes_set16",
+ "caml_bytes_set32",
+ "caml_bytes_set64",
+ "caml_ceil_float",
+ "caml_channel_descriptor",
+ "caml_classify_float",
+ "caml_compare",
+ "caml_convert_raw_backtrace",
+ "caml_convert_raw_backtrace_slot",
+ "caml_copysign_float",
+ "caml_cos_float",
+ "caml_cosh_float",
+ "caml_create_bytes",
+ "caml_create_string",
+ "caml_div_float",
+ "caml_dynlink_add_primitive",
+ "caml_dynlink_close_lib",
+ "caml_dynlink_get_current_libs",
+ "caml_dynlink_lookup_symbol",
+ "caml_dynlink_open_lib",
+ "caml_ensure_stack_capacity",
+ "caml_ephe_blit_data",
+ "caml_ephe_blit_key",
+ "caml_ephe_check_data",
+ "caml_ephe_check_key",
+ "caml_ephe_create",
+ "caml_ephe_get_data",
+ "caml_ephe_get_data_copy",
+ "caml_ephe_get_key",
+ "caml_ephe_get_key_copy",
+ "caml_ephe_set_data",
+ "caml_ephe_set_key",
+ "caml_ephe_unset_data",
+ "caml_ephe_unset_key",
+ "caml_eq_float",
+ "caml_equal",
+ "caml_exp_float",
+ "caml_expm1_float",
+ "caml_fill_bytes",
+ "caml_fill_string",
+ "caml_final_register",
+ "caml_final_register_called_without_value",
+ "caml_final_release",
+ "caml_float_compare",
+ "caml_float_of_int",
+ "caml_float_of_string",
+ "caml_floatarray_create",
+ "caml_floatarray_get",
+ "caml_floatarray_set",
+ "caml_floatarray_unsafe_get",
+ "caml_floatarray_unsafe_set",
+ "caml_floor_float",
+ "caml_fmod_float",
+ "caml_format_float",
+ "caml_format_int",
+ "caml_fresh_oo_id",
+ "caml_frexp_float",
+ "caml_gc_compaction",
+ "caml_gc_counters",
+ "caml_gc_full_major",
+ "caml_gc_get",
+ "caml_gc_huge_fallback_count",
+ "caml_gc_major",
+ "caml_gc_major_slice",
+ "caml_gc_minor",
+ "caml_gc_minor_words",
+ "caml_gc_quick_stat",
+ "caml_gc_set",
+ "caml_gc_stat",
+ "caml_ge_float",
+ "caml_get_current_callstack",
+ "caml_get_current_environment",
+ "caml_get_exception_backtrace",
+ "caml_get_exception_raw_backtrace",
+ "caml_get_global_data",
+ "caml_get_major_bucket",
+ "caml_get_major_credit",
+ "caml_get_minor_free",
+ "caml_get_public_method",
+ "caml_get_section_table",
+ "caml_greaterequal",
+ "caml_greaterthan",
+ "caml_gt_float",
+ "caml_hash",
+ "caml_hash_univ_param",
+ "caml_hexstring_of_float",
+ "caml_hypot_float",
+ "caml_input_value",
+ "caml_input_value_from_bytes",
+ "caml_input_value_from_string",
+ "caml_input_value_to_outside_heap",
+ "caml_install_signal_handler",
+ "caml_int32_add",
+ "caml_int32_and",
+ "caml_int32_bits_of_float",
+ "caml_int32_bswap",
+ "caml_int32_compare",
+ "caml_int32_div",
+ "caml_int32_float_of_bits",
+ "caml_int32_format",
+ "caml_int32_mod",
+ "caml_int32_mul",
+ "caml_int32_neg",
+ "caml_int32_of_float",
+ "caml_int32_of_int",
+ "caml_int32_of_string",
+ "caml_int32_or",
+ "caml_int32_shift_left",
+ "caml_int32_shift_right",
+ "caml_int32_shift_right_unsigned",
+ "caml_int32_sub",
+ "caml_int32_to_float",
+ "caml_int32_to_int",
+ "caml_int32_xor",
+ "caml_int64_add",
+ "caml_int64_and",
+ "caml_int64_bits_of_float",
+ "caml_int64_bswap",
+ "caml_int64_compare",
+ "caml_int64_div",
+ "caml_int64_float_of_bits",
+ "caml_int64_format",
+ "caml_int64_mod",
+ "caml_int64_mul",
+ "caml_int64_neg",
+ "caml_int64_of_float",
+ "caml_int64_of_int",
+ "caml_int64_of_int32",
+ "caml_int64_of_nativeint",
+ "caml_int64_of_string",
+ "caml_int64_or",
+ "caml_int64_shift_left",
+ "caml_int64_shift_right",
+ "caml_int64_shift_right_unsigned",
+ "caml_int64_sub",
+ "caml_int64_to_float",
+ "caml_int64_to_int",
+ "caml_int64_to_int32",
+ "caml_int64_to_nativeint",
+ "caml_int64_xor",
+ "caml_int_as_pointer",
+ "caml_int_compare",
+ "caml_int_of_float",
+ "caml_int_of_string",
+ "caml_invoke_traced_function",
+ "caml_lazy_follow_forward",
+ "caml_lazy_make_forward",
+ "caml_ldexp_float",
+ "caml_le_float",
+ "caml_lessequal",
+ "caml_lessthan",
+ "caml_lex_engine",
+ "caml_log10_float",
+ "caml_log1p_float",
+ "caml_log_float",
+ "caml_lt_float",
+ "caml_make_array",
+ "caml_make_float_vect",
+ "caml_make_vect",
+ "caml_marshal_data_size",
+ "caml_md5_chan",
+ "caml_md5_string",
+ "caml_ml_bytes_length",
+ "caml_ml_channel_size",
+ "caml_ml_channel_size_64",
+ "caml_ml_close_channel",
+ "caml_ml_enable_runtime_warnings",
+ "caml_ml_flush",
+ "caml_ml_flush_partial",
+ "caml_ml_input",
+ "caml_ml_input_char",
+ "caml_ml_input_int",
+ "caml_ml_input_scan_line",
+ "caml_ml_open_descriptor_in",
+ "caml_ml_open_descriptor_out",
+ "caml_ml_out_channels_list",
+ "caml_ml_output",
+ "caml_ml_output_bytes",
+ "caml_ml_output_char",
+ "caml_ml_output_int",
+ "caml_ml_output_partial",
+ "caml_ml_pos_in",
+ "caml_ml_pos_in_64",
+ "caml_ml_pos_out",
+ "caml_ml_pos_out_64",
+ "caml_ml_runtime_warnings_enabled",
+ "caml_ml_seek_in",
+ "caml_ml_seek_in_64",
+ "caml_ml_seek_out",
+ "caml_ml_seek_out_64",
+ "caml_ml_set_binary_mode",
+ "caml_ml_set_channel_name",
+ "caml_ml_string_length",
+ "caml_modf_float",
+ "caml_mul_float",
+ "caml_nativeint_add",
+ "caml_nativeint_and",
+ "caml_nativeint_bswap",
+ "caml_nativeint_compare",
+ "caml_nativeint_div",
+ "caml_nativeint_format",
+ "caml_nativeint_mod",
+ "caml_nativeint_mul",
+ "caml_nativeint_neg",
+ "caml_nativeint_of_float",
+ "caml_nativeint_of_int",
+ "caml_nativeint_of_int32",
+ "caml_nativeint_of_string",
+ "caml_nativeint_or",
+ "caml_nativeint_shift_left",
+ "caml_nativeint_shift_right",
+ "caml_nativeint_shift_right_unsigned",
+ "caml_nativeint_sub",
+ "caml_nativeint_to_float",
+ "caml_nativeint_to_int",
+ "caml_nativeint_to_int32",
+ "caml_nativeint_xor",
+ "caml_neg_float",
+ "caml_neq_float",
+ "caml_new_lex_engine",
+ "caml_notequal",
+ "caml_obj_add_offset",
+ "caml_obj_block",
+ "caml_obj_dup",
+ "caml_obj_is_block",
+ "caml_obj_reachable_words",
+ "caml_obj_set_tag",
+ "caml_obj_tag",
+ "caml_obj_truncate",
+ "caml_output_value",
+ "caml_output_value_to_buffer",
+ "caml_output_value_to_bytes",
+ "caml_output_value_to_string",
+ "caml_parse_engine",
+ "caml_power_float",
+ "caml_raw_backtrace_length",
+ "caml_raw_backtrace_next_slot",
+ "caml_raw_backtrace_slot",
+ "caml_realloc_global",
+ "caml_record_backtrace",
+ "caml_register_channel_for_spacetime",
+ "caml_register_code_fragment",
+ "caml_register_named_value",
+ "caml_reify_bytecode",
+ "caml_remove_debug_info",
+ "caml_reset_afl_instrumentation",
+ "caml_restore_raw_backtrace",
+ "caml_runtime_parameters",
+ "caml_runtime_variant",
+ "caml_set_oo_id",
+ "caml_set_parser_trace",
+ "caml_setup_afl",
+ "caml_sin_float",
+ "caml_sinh_float",
+ "caml_spacetime_enabled",
+ "caml_spacetime_only_works_for_native_code",
+ "caml_sqrt_float",
+ "caml_static_alloc",
+ "caml_static_free",
+ "caml_static_release_bytecode",
+ "caml_static_resize",
+ "caml_string_compare",
+ "caml_string_equal",
+ "caml_string_get",
+ "caml_string_get16",
+ "caml_string_get32",
+ "caml_string_get64",
+ "caml_string_greaterequal",
+ "caml_string_greaterthan",
+ "caml_string_lessequal",
+ "caml_string_lessthan",
+ "caml_string_notequal",
+ "caml_string_of_bytes",
+ "caml_string_set",
+ "caml_sub_float",
+ "caml_sys_chdir",
+ "caml_sys_close",
+ "caml_sys_const_backend_type",
+ "caml_sys_const_big_endian",
+ "caml_sys_const_int_size",
+ "caml_sys_const_max_wosize",
+ "caml_sys_const_ostype_cygwin",
+ "caml_sys_const_ostype_unix",
+ "caml_sys_const_ostype_win32",
+ "caml_sys_const_word_size",
+ "caml_sys_exit",
+ "caml_sys_file_exists",
+ "caml_sys_get_argv",
+ "caml_sys_get_config",
+ "caml_sys_getcwd",
+ "caml_sys_getenv",
+ "caml_sys_is_directory",
+ "caml_sys_isatty",
+ "caml_sys_open",
+ "caml_sys_random_seed",
+ "caml_sys_read_directory",
+ "caml_sys_remove",
+ "caml_sys_rename",
+ "caml_sys_system_command",
+ "caml_sys_time",
+ "caml_sys_time_include_children",
+ "caml_sys_unsafe_getenv",
+ "caml_tan_float",
+ "caml_tanh_float",
+ "caml_terminfo_rows",
+ "caml_update_dummy",
+ "caml_weak_blit",
+ "caml_weak_check",
+ "caml_weak_create",
+ "caml_weak_get",
+ "caml_weak_get_copy",
+ "caml_weak_set",
+ 0 };
diff --git a/test/monniaux/ocaml/config/Makefile b/test/monniaux/ocaml/config/Makefile
index 26b14670..161d8a1b 100644
--- a/test/monniaux/ocaml/config/Makefile
+++ b/test/monniaux/ocaml/config/Makefile
@@ -22,7 +22,7 @@ X11_LINK=-lX11
LIBBFD_LINK=
LIBBFD_INCLUDE=
# DM CC=k1-mbr-gcc
-CC=/home/monniaux/work/Kalray/mppa-xsaddr/ccomp
+CC=/home/monniaux/work/Kalray/mppa-work/ccomp
CPP=$(CC) -E
CFLAGS=-O -Wall -fall
# DM CFLAGS=-O3 -Wall
diff --git a/test/monniaux/pcre2-10.32/Makefile b/test/monniaux/pcre2-10.32/Makefile
index 35f1e049..b6b66c37 100644
--- a/test/monniaux/pcre2-10.32/Makefile
+++ b/test/monniaux/pcre2-10.32/Makefile
@@ -1,4 +1,7 @@
-CFILES = \
+TARGET=pcre2
+ALL_CFLAGS = -DHAVE_CONFIG_H -DPCRE2_CODE_UNIT_WIDTH=8
+EXECUTE_ARGS=testdata/testinput6 > /dev/null 2> __BASE__.out
+ALL_CFILES = \
pcre2_auto_possess.c \
pcre2_chartables.c \
pcre2_compile.c \
@@ -26,38 +29,7 @@ CFILES = \
pcre2_valid_utf.c \
pcre2_xclass.c \
pcre2posix.c \
- pcre2test.c \
- bsp_frequency.c
-
-HFILES = config.h pcre2_internal.h pcre2posix.h \
-pcre2.h pcre2_intmodedep.h pcre2_ucp.h
-
-K1C_GCC_OFILES=$(CFILES:.c=.gcc.k1c.o)
-K1C_GCC_OFILES_O1=$(CFILES:.c=.gcc.o1.k1c.o)
-K1C_CCOMP_OFILES=$(CFILES:.c=.ccomp.k1c.o)
-K1C_GCC_SFILES=$(CFILES:.c=.gcc.k1c.s)
-K1C_CCOMP_SFILES=$(CFILES:.c=.ccomp.k1c.s)
-
-all: pcre2test.gcc.o1.k1c.out pcre2test.gcc.k1c.out pcre2test.ccomp.k1c.out $(K1C_GCC_SFILES) $(K1C_CCOMP_SFILES)
-
-ALL_CFLAGS = -DHAVE_CONFIG_H -DPCRE2_CODE_UNIT_WIDTH=8
-EXECUTE_ARGS = testdata/testinput6
+ pcre2test.c
include ../rules.mk
-
-$(K1C_GCC_SFILES) $(K1C_CCOMP_SFILES): $(HFILES)
-
-pcre2test.gcc.k1c: $(K1C_GCC_OFILES)
- $(K1C_CC) $(K1C_CFLAGS) -o $@ $+ ../clock.gcc.k1c.o
-
-pcre2test.gcc.o1.k1c: $(K1C_GCC_OFILES_O1)
- $(K1C_CC) $(K1C_CFLAGS_O1) -o $@ $+ ../clock.gcc.k1c.o
-
-pcre2test.ccomp.k1c: $(K1C_CCOMP_OFILES)
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -o $@ $+ ../clock.gcc.k1c.o
-
-.PHONY: clean
-
-clean:
- rm -f *.s *.o *.k1c
diff --git a/test/monniaux/pcre2-10.32/bsp_frequency.c b/test/monniaux/pcre2-10.32/bsp_frequency.c
deleted file mode 100644
index 058739e2..00000000
--- a/test/monniaux/pcre2-10.32/bsp_frequency.c
+++ /dev/null
@@ -1 +0,0 @@
-unsigned long __bsp_frequency = 400000000;
diff --git a/test/monniaux/pcre2-10.32/pcre2test.c b/test/monniaux/pcre2-10.32/pcre2test.c
index 25a7c4a1..a1fb64cb 100644
--- a/test/monniaux/pcre2-10.32/pcre2test.c
+++ b/test/monniaux/pcre2-10.32/pcre2test.c
@@ -8792,7 +8792,7 @@ FREECONTEXTS;
#endif
clock_stop();
- print_total_clock();
+ printerr_total_clock();
return yield;
}
diff --git a/test/monniaux/pcre2-10.32/testdata/testinput6 b/test/monniaux/pcre2-10.32/testdata/testinput6
index f7dedb21..c1a08348 100644
--- a/test/monniaux/pcre2-10.32/testdata/testinput6
+++ b/test/monniaux/pcre2-10.32/testdata/testinput6
@@ -4870,17 +4870,17 @@
aaa\=allcaptures
a\=allcaptures
-/(*LIMIT_DEPTH=100)^((.)(?1)|.)$/
-\= Expect depth limit exceeded
- a[00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]
+#/(*LIMIT_DEPTH=100)^((.)(?1)|.)$/
+#\= Expect depth limit exceeded
+# a[00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]
/(*LIMIT_HEAP=0)^((.)(?1)|.)$/
\= Expect heap limit exceeded
a[00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]
-/(*LIMIT_HEAP=50000)^((.)(?1)|.)$/
-\= Expect success
- a[00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]
+#/(*LIMIT_HEAP=50000)^((.)(?1)|.)$/
+#\= Expect success
+# a[00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]([00]
/(02-)?[0-9]{3}-[0-9]{3}/
02-123-123
@@ -4937,9 +4937,9 @@
/(?<=|abc)/endanchored
abcde\=aftertext
-/(*LIMIT_MATCH=100).*(?![|H]?.*(?![|H]?););.*(?![|H]?.*(?![|H]?););\x00\x00\x00\x00\x00\x00\x00(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?![|);)?.*(![|H]?);)?.*(?![|H]?);)?.*(?![|H]?);)?.*(?![|H]););![|H]?););[|H]?);|H]?);)\x00\x00\x00 \x00\x00\x00H]?););?![|H]?);)?.*(?![|H]?););[||H]?);)?.*(?![|H]?););[|H]?);(?![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););;[\x00\x00\x00\x00\x00\x00\x00![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););/no_dotstar_anchor
-\= Expect limit exceeded
-.*(?![|H]?.*(?![|H]?););.*(?![|H]?.*(?![|H]?););\x00\x00\x00\x00\x00\x00\x00(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?![|);)?.*(![|H]?);)?.*(?![|H]?);)?.*(?![|H]?);)?.*(?![|H]););![|H]?););[|H]?);|H]?);)\x00\x00\x00 \x00\x00\x00H]?););?![|H]?);)?.*(?![|H]?););[||H]?);)?.*(?![|H]?););[|H]?);(?![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););;[\x00\x00\x00\x00\x00\x00\x00![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););
+#/(*LIMIT_MATCH=100).*(?![|H]?.*(?![|H]?););.*(?![|H]?.*(?![|H]?););\x00\x00\x00\x00\x00\x00\x00(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?![|);)?.*(![|H]?);)?.*(?![|H]?);)?.*(?![|H]?);)?.*(?![|H]););![|H]?););[|H]?);|H]?);)\x00\x00\x00 \x00\x00\x00H]?););?![|H]?);)?.*(?![|H]?););[||H]?);)?.*(?![|H]?););[|H]?);(?![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););;[\x00\x00\x00\x00\x00\x00\x00![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););/no_dotstar_anchor
+#\= Expect limit exceeded
+#.*(?![|H]?.*(?![|H]?););.*(?![|H]?.*(?![|H]?););\x00\x00\x00\x00\x00\x00\x00(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?!(?![|);)?.*(![|H]?);)?.*(?![|H]?);)?.*(?![|H]?);)?.*(?![|H]););![|H]?););[|H]?);|H]?);)\x00\x00\x00 \x00\x00\x00H]?););?![|H]?);)?.*(?![|H]?););[||H]?);)?.*(?![|H]?););[|H]?);(?![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););;[\x00\x00\x00\x00\x00\x00\x00![|H]?););![|H]?););[|H]?);|H]?);)?.*(?![|H]?););
/\n/firstline
xyz\nabc
diff --git a/test/monniaux/picosat-965/Makefile b/test/monniaux/picosat-965/Makefile
index d3322bcb..a887c0de 100644
--- a/test/monniaux/picosat-965/Makefile
+++ b/test/monniaux/picosat-965/Makefile
@@ -1,37 +1,11 @@
EXECUTE_ARGS=sudoku.sat
-
-include ../rules.mk
-
-#ALL_CFLAGS = -DNDEBUG
ALL_CFLAGS = -DNALARM -DNZIP -DNGETRUSAGE -DNDEBUG
-K1C_CFLAGS += $(EMBEDDED_CFLAGS)
-K1C_CCOMPFLAGS += $(EMBEDDED_CFLAGS)
-CCOMPFLAGS += -fbitfields
-K1C_CCOMPFLAGS += -fbitfields
-
-K1C_CFLAGS += $(ALL_CFLAGS)
-K1C_CCOMPFLAGS += $(ALL_CFLAGS)
-CCOMPFLAGS += $(ALL_CFLAGS)
-CFLAGS += $(ALL_CFLAGS)
-
-all: picosat.ccomp.k1c.s version.ccomp.k1c.s app.ccomp.k1c.s main.ccomp.k1c.s picosat.gcc.k1c.s version.gcc.k1c.s app.gcc.k1c.s main.gcc.k1c.s picosat.ccomp.k1c.out picosat.gcc.o1.k1c.out picosat.gcc.k1c.out picosat picosat.ccomp.host.out picosat.gcc.host.out
-
-picosat.ccomp.k1c : picosat.ccomp.k1c.s version.ccomp.k1c.s app.ccomp.k1c.s main.ccomp.k1c.s ../clock.gcc.k1c.o
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
+ALL_CCOMPFLAGS += -fbitfields # -fno-if-conversion
+TARGET=picosat
+ALL_CFILES=picosat.c version.c app.c main.c
-picosat.gcc.k1c : picosat.gcc.k1c.s version.gcc.k1c.s app.gcc.k1c.s main.gcc.k1c.s ../clock.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
-
-picosat.gcc.o1.k1c : picosat.gcc.o1.k1c.s version.gcc.o1.k1c.s app.gcc.o1.k1c.s main.gcc.o1.k1c.s ../clock.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS_O1) $+ -o $@
-
-picosat.ccomp.host : picosat.ccomp.host.s version.ccomp.host.s app.ccomp.host.s main.ccomp.host.s ../clock.gcc.host.o
- $(CCOMP) $(CCOMPFLAGS) $+ -o $@
-
-picosat.gcc.host : picosat.gcc.host.s version.gcc.host.s app.gcc.host.s main.gcc.host.s ../clock.gcc.host.o
- $(CC) $(FLAGS) $+ -o $@
-
-clean:
- -rm -f *.s *.k1c *.out
+include ../rules.mk
-.PHONY: clean
+# FIXME - what were these for?
+#K1C_CFLAGS += $(EMBEDDED_CFLAGS)
+#K1C_CCOMPFLAGS += $(EMBEDDED_CFLAGS)
diff --git a/test/monniaux/predicated/predicated.s b/test/monniaux/predicated/predicated.s
deleted file mode 100644
index f11606c2..00000000
--- a/test/monniaux/predicated/predicated.s
+++ /dev/null
@@ -1,13 +0,0 @@
- .text
-
- .globl predicated_write
-predicated_write:
- sd.wnez $r0? 8[$r1] = $r2
- ret
- ;;
-
- .globl predicated_read
-predicated_read:
- ld.wnez $r1? $r0 = 8[$r2]
- ret
- ;;
diff --git a/test/monniaux/quicksort/Makefile b/test/monniaux/quicksort/Makefile
new file mode 100644
index 00000000..719cd755
--- /dev/null
+++ b/test/monniaux/quicksort/Makefile
@@ -0,0 +1,3 @@
+TARGET=quicksort
+
+include ../rules.mk
diff --git a/test/monniaux/quicksort/make.proto b/test/monniaux/quicksort/make.proto
deleted file mode 100644
index fe2f906b..00000000
--- a/test/monniaux/quicksort/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-objdeps: [{name: quicksort_run, compiler: gcc}]
-target: quicksort
-measures: [quicksort_time]
diff --git a/test/monniaux/quicksort/quicksort_run.c b/test/monniaux/quicksort/quicksort_run.c
index 88747d17..3c640b24 100644
--- a/test/monniaux/quicksort/quicksort_run.c
+++ b/test/monniaux/quicksort/quicksort_run.c
@@ -13,7 +13,7 @@ int main (void) {
quicksort(vec, len);
quicksort_time = get_cycle() - quicksort_time;
printf("sorted=%s\n"
- "quicksort_time:%" PRIu64 "\n",
+ "time cycles:%" PRcycle "\n",
data_vec_is_sorted(vec, len)?"true":"false",
quicksort_time);
free(vec);
diff --git a/test/monniaux/rules.mk b/test/monniaux/rules.mk
index 781b94c7..2de2c466 100644
--- a/test/monniaux/rules.mk
+++ b/test/monniaux/rules.mk
@@ -1,63 +1,162 @@
-ALL_CCOMPFLAGS=-fno-unprototyped
-CCOMP=ccomp-x86
-CCOMPFLAGS=-g -O3 -Wall $(ALL_CCOMPFLAGS) $(ALL_CFLAGS)
+# This Makefile does not depend on ../rules.mk
+SHELL=bash
+
+# You can modify ALL_CFILES to include the files that should be linked
+ALL_CFILES?=$(wildcard *.c)
+
+# Name of the target
+TARGET?=toto
+
+# Arguments of execution
+EXECUTE_ARGS?=
+
+# Name of the clock object
+CLOCK=../clock
+
+# Maximum amount of time measures (see cycles.h)
+MAX_MEASURES=10
+MEASURES?=time
+
+# Flags common to both compilers, then to gcc, then to ccomp
+ALL_CFLAGS+=-Wall -D__K1C_COS__ -DMAX_MEASURES=$(MAX_MEASURES)
+#ALL_CFLAGS+=-g
+ALL_GCCFLAGS+=$(ALL_CFLAGS) -std=c99 -Wextra -Werror=implicit
+ALL_CCOMPFLAGS+=$(ALL_CFLAGS)
+
+# The compilers
+K1C_CC?=k1-cos-gcc
+K1C_CCOMP?=ccomp
+
+# Command to execute
+#EXECUTE_CYCLES?=timeout --signal=SIGTERM 3m k1-cluster --syscall=libstd_scalls.so --cycle-based --
+EXECUTE_CYCLES?=k1-cluster --syscall=libstd_scalls.so --cycle-based --
+
+# You can define up to GCC4FLAGS and CCOMP4FLAGS
+GCC0FLAGS?=$(ALL_GCCFLAGS) -O0
+GCC1FLAGS?=$(ALL_GCCFLAGS) -O1
+GCC2FLAGS?=$(ALL_GCCFLAGS) -O2
+GCC3FLAGS?=$(ALL_GCCFLAGS) -O3
+GCC4FLAGS?=
+CCOMP0FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-postpass
+CCOMP1FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fpostpass= greedy
+CCOMP2FLAGS?=$(ALL_CCOMPFLAGS) -O2 -fno-if-conversion
+CCOMP3FLAGS?=$(ALL_CCOMPFLAGS) -O2
+CCOMP4FLAGS?=
+
+# Prefix names
+GCC0PREFIX?=.gcc.o0
+GCC1PREFIX?=.gcc.o1
+GCC2PREFIX?=.gcc.o2
+GCC3PREFIX?=.gcc.o3
+GCC4PREFIX?=
+CCOMP0PREFIX?=.ccomp.nobundle
+CCOMP1PREFIX?=.ccomp.greedy
+CCOMP2PREFIX?=.ccomp.noif
+CCOMP3PREFIX?=.ccomp
+CCOMP4PREFIX?=
+
+# List of outfiles, updated by gen_rules
+OUTFILES:=
+BINFILES:=
+
+# First line of the CSV file, completed later
+FIRSTLINE:=benches
+
+firstrule: all
+
+# $1: compiler
+# $2: compilation flags
+# $3: extension prefix
+define gen_rules
+
+.SECONDARY:
+asm/%$(3).s: %.c
+ @mkdir -p $$(@D)
+ $(1) $(2) -S $$< -o $$@
+
+.SECONDARY:
+bin/$(TARGET)$(3).bin: $(addprefix obj/,$(ALL_CFILES:.c=$(3).o)) $(CLOCK).gcc.k1c.o
+ @mkdir -p $$(@D)
+ $(1) $$+ -lm -o $$@
+
+BINFILES:=$(BINFILES) bin/$(TARGET)$(3).bin
+OUTFILES:=$(OUTFILES) out/$(TARGET)$(3).out
+FIRSTLINE:=$(FIRSTLINE), $(3)
+
+endef
+
+# Clock generation
+$(CLOCK).gcc.k1c.o: $(CLOCK).c
+ $(K1C_CC) $(ALL_GCCFLAGS) -O3 $< -c -o $@
+
+# Generic rules
+obj/%.o: asm/%.s
+ @mkdir -p $(@D)
+ $(K1C_CC) $< -c -o $@
+
+out/%.out: bin/%.bin
+ @mkdir -p $(@D)
+ @rm -f $@
+ $(EXECUTE_CYCLES) $< $(subst __BASE__,$(patsubst %.out,%,$@),$(EXECUTE_ARGS)) | tee -a $@
+
+##
+# Generating the rules for all the compiler/flags..
+##
+
+ifneq ($(GCC0FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC0FLAGS),$(GCC0PREFIX)))
+endif
+ifneq ($(GCC1FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC1FLAGS),$(GCC1PREFIX)))
+endif
+ifneq ($(GCC2FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC2FLAGS),$(GCC2PREFIX)))
+endif
+ifneq ($(GCC3FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC3FLAGS),$(GCC3PREFIX)))
+endif
+ifneq ($(GCC4FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC4FLAGS),$(GCC4PREFIX)))
+endif
+
+ifneq ($(CCOMP0FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX)))
+endif
+ifneq ($(CCOMP1FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX)))
+endif
+ifneq ($(CCOMP2FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX)))
+endif
+ifneq ($(CCOMP3FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX)))
+endif
+ifneq ($(CCOMP4FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX)))
+endif
+
+measures.csv: $(OUTFILES)
+ @echo $(FIRSTLINE) > $@
+ @for i in "$(MEASURES)"; do\
+ first=$$(grep "$$i cycles" $(firstword $(OUTFILES)));\
+ if test ! -z "$$first"; then\
+ if [ "$$i" != "time" ]; then\
+ line="$(TARGET) $$i";\
+ else\
+ line="$(TARGET)";\
+ fi;\
+ $(foreach outfile,$(OUTFILES),line="$$line, $$(grep "$$i cycles" $(outfile) | cut -d':' -f2)"; ):;\
+ echo "$$line" >> $@;\
+ fi;\
+ done;\
+ echo "$@ created!"
+
+.PHONY: all clean run
+all: $(BINFILES)
+
+run: measures.csv
+
+clean:
+ rm -f *.o *.s *.bin *.out
+ rm -rf asm/ bin/ obj/ out/
-CFLAGS=-g -std=c99 -O3 -Wall -Wextra -Werror=implicit $(ALL_CFLAGS)
-
-K1C_CC=k1-cos-gcc
-K1C_CFLAGS = -D__K1C_COS__ -std=c99 -O3 -Wall -Wextra -Werror=implicit $(ALL_CFLAGS)
-K1C_CFLAGS_O1 =-std=c99 -O1 -fschedule-insns2 -Wall -Wextra -Werror=implicit $(ALL_CFLAGS)
-
-K1C_CCOMP = ../../../ccomp
-K1C_CCOMPFLAGS=-O3 -Wall $(ALL_CCOMPFLAGS) $(ALL_CFLAGS) # -fpostpass-ilp
-
-EXECUTE=k1-cluster --syscall=libstd_scalls.so --
-EXECUTE_CYCLES=k1-cluster --syscall=libstd_scalls.so --cycle-based --
-
-%.gcc.host.o : %.gcc.host.s
- $(CC) $(CFLAGS) -c -o $@ $<
-
-%.ccomp.host.o : %.ccomp.host.s
- $(CCOMP) $(CCOMPFLAGS) -c -o $@ $<
-
-%.gcc.host.s : %.c
- $(CC) $(CFLAGS) -S -o $@ $<
-
-%.ccomp.host.s : %.c
- $(CCOMP) $(CCOMPFLAGS) -S -o $@ $<
-
-%.gcc.o1.k1c.s: %.c
- $(K1C_CC) $(K1C_CFLAGS_O1) -S $< -o $@
-
-%.gcc.o1.k1c.o: %.gcc.o1.k1c.s
- $(K1C_CC) $(K1C_CFLAGS_O1) -c $< -o $@
-
-%.gcc.k1c.s: %.c
- $(K1C_CC) $(K1C_CFLAGS) -S $< -o $@
-
-%.gcc.k1c.o: %.gcc.k1c.s
- $(K1C_CC) $(K1C_CFLAGS) -c $< -o $@
-
-%.ccomp.k1c.s: %.c
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -S $< -o $@
-
-%.ccomp.k1c.o: %.ccomp.k1c.s
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) -c $< -o $@
-
-# %.gcc.k1c : %.gcc.k1c.o
-# $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
-
-# %.ccomp.k1c : %.ccomp.k1c.o
-# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
-
-# %.gcc.host : %.gcc.host.o
-# $(CC) $(CFLAGS) $+ -o $@
-
-# %.ccomp.host : %.ccomp.host.o
-# $(CCOMP) $(CCOMPFLAGS) $+ -o $@
-
-%.k1c.out : %.k1c
- $(EXECUTE_CYCLES) $< $(EXECUTE_ARGS) |tee $@
-
-%.host.out : %.host
- ./$< $(EXECUTE_ARGS) |tee $@
diff --git a/test/monniaux/run_benches.sh b/test/monniaux/run_benches.sh
index 479d09eb..2b2e28d6 100755
--- a/test/monniaux/run_benches.sh
+++ b/test/monniaux/run_benches.sh
@@ -1,12 +1,16 @@
source benches.sh
+cores=$(grep -c ^processor /proc/cpuinfo)
+processes=$((cores/4))
+
rm -f commands.txt
for bench in $benches; do
- echo "(cd $bench && make -j5 run)" >> commands.txt
+ echo "(cd $bench && echo \"Running $bench..\" &&\
+ make -j4 run > /dev/null && echo \"$bench DONE\")" >> commands.txt
done
-cat commands.txt | xargs -n1 -I{} -P4 bash -c '{}'
+cat commands.txt | xargs -n1 -I{} -P$processes bash -c '{}'
##
# Gather all the CSV files
@@ -19,8 +23,5 @@ for bench in $benches; do
fi
done
-nawk 'FNR==1 && NR!=1{next;}{print}' $benches_csv > measures.csv
-echo "measures.csv done"
-
-./gengraphs.py measures.csv
-echo "Graphs done"
+nawk 'FNR==1 && NR!=1{next;}{print}' $benches_csv > $1
+echo "$1 done"
diff --git a/test/monniaux/sandbox/Makefile b/test/monniaux/sandbox/Makefile
new file mode 100644
index 00000000..0fa2a2ae
--- /dev/null
+++ b/test/monniaux/sandbox/Makefile
@@ -0,0 +1,148 @@
+# This Makefile does not depend on ../rules.mk
+SHELL=bash
+
+# You can modify ALL_CFILES to include the files that should be linked
+ALL_CFILES=$(wildcard *.c)
+
+# Name of the target
+TARGET=toto
+
+# Name of the clock object
+CLOCK=../clock.gcc.k1c.o
+
+# Maximum amount of time measures (see cycles.h)
+MAX_MEASURES=10
+
+# Flags common to both compilers, then to gcc, then to ccomp
+ALL_CFLAGS=-Wall -D__K1C_COS__ -DMAX_MEASURES=$(MAX_MEASURES)
+#ALL_CFLAGS+=-g
+ALL_GCCFLAGS=$(ALL_CFLAGS) -std=c99 -Wextra -Werror=implicit
+ALL_CCOMPFLAGS=$(ALL_CFLAGS)
+
+# The compilers
+K1C_CC=k1-cos-gcc
+K1C_CCOMP=ccomp
+
+# Command to execute
+EXECUTE_CYCLES=k1-cluster --syscall=libstd_scalls.so --cycle-based --
+
+# You can define up to GCC4FLAGS and CCOMP4FLAGS
+GCC0FLAGS=
+GCC1FLAGS=$(ALL_GCCFLAGS) -O1
+GCC2FLAGS=$(ALL_GCCFLAGS) -O2
+GCC3FLAGS=$(ALL_GCCFLAGS) -O3
+GCC4FLAGS=
+CCOMP0FLAGS=
+CCOMP1FLAGS=$(ALL_CCOMPFLAGS) -fno-postpass
+CCOMP2FLAGS=$(ALL_CCOMPFLAGS)
+CCOMP3FLAGS=
+CCOMP4FLAGS=
+
+# Prefix names
+GCC0PREFIX=
+GCC1PREFIX=.gcc.o1
+GCC2PREFIX=.gcc.o2
+GCC3PREFIX=.gcc.o3
+GCC4PREFIX=
+CCOMP0PREFIX=.ccomp.o0
+CCOMP1PREFIX=.ccomp.o1
+CCOMP2PREFIX=.ccomp.o2
+CCOMP3PREFIX=
+CCOMP4PREFIX=
+
+# List of outfiles, updated by gen_rules
+OUTFILES:=
+BINFILES:=
+
+# First line of the CSV file
+FIRSTLINE:=benches
+
+firstrule: all
+
+# $1: compiler
+# $2: compilation flags
+# $3: extension prefix
+define gen_rules
+
+.SECONDARY:
+asm/%$(3).s: %.c
+ @mkdir -p $$(@D)
+ $(1) $(2) -S $$< -o $$@
+
+.SECONDARY:
+bin/$(TARGET)$(3).bin: $(addprefix obj/,$(ALL_CFILES:.c=$(3).o)) $(CLOCK)
+ @mkdir -p $$(@D)
+ $(K1C_CC) $$+ -lm -o $$@
+
+BINFILES:=$(BINFILES) bin/$(TARGET)$(3).bin
+OUTFILES:=$(OUTFILES) out/$(TARGET)$(3).out
+FIRSTLINE:=$(FIRSTLINE), $(3)
+
+endef
+
+# Generic rules
+obj/%.o: asm/%.s
+ @mkdir -p $(@D)
+ $(K1C_CC) $< -c -o $@
+
+out/%.out: bin/%.bin
+ @mkdir -p $(@D)
+ $(EXECUTE_CYCLES) $< | tee $@
+
+##
+# Generating the rules for all the compiler/flags..
+##
+
+ifneq ($(GCC0FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC0FLAGS),$(GCC0PREFIX)))
+endif
+ifneq ($(GCC1FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC1FLAGS),$(GCC1PREFIX)))
+endif
+ifneq ($(GCC2FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC2FLAGS),$(GCC2PREFIX)))
+endif
+ifneq ($(GCC3FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC3FLAGS),$(GCC3PREFIX)))
+endif
+ifneq ($(GCC4FLAGS),)
+$(eval $(call gen_rules,$(K1C_CC),$(GCC4FLAGS),$(GCC4PREFIX)))
+endif
+
+ifneq ($(CCOMP0FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP0FLAGS),$(CCOMP0PREFIX)))
+endif
+ifneq ($(CCOMP1FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP1FLAGS),$(CCOMP1PREFIX)))
+endif
+ifneq ($(CCOMP2FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP2FLAGS),$(CCOMP2PREFIX)))
+endif
+ifneq ($(CCOMP3FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP3FLAGS),$(CCOMP3PREFIX)))
+endif
+ifneq ($(CCOMP4FLAGS),)
+$(eval $(call gen_rules,$(K1C_CCOMP),$(CCOMP4FLAGS),$(CCOMP4PREFIX)))
+endif
+
+measures.csv: $(OUTFILES)
+ @echo $(FIRSTLINE) > $@
+ @for ((i=0;i<=$(MAX_MEASURES);i++)) do\
+ first=$$(grep "($$i) cycles" $(firstword $(OUTFILES)));\
+ if test ! -z "$$first"; then\
+ line="$(TARGET) $$i";\
+ $(foreach outfile,$(OUTFILES),line="$$line, $$(grep "($$i) cycles" $(outfile) | cut -d':' -f2)"; ):;\
+ echo "$$line" >> $@;\
+ fi;\
+ done;\
+ echo "$@ created!"
+
+.PHONY: all clean run
+all: $(BINFILES)
+
+run: measures.csv
+
+clean:
+ rm -f *.o *.s *.bin *.out
+ rm -f asm/*.s bin/*.bin obj/*.o out/*.out
+
diff --git a/test/monniaux/sandbox/example.c b/test/monniaux/sandbox/example.c
new file mode 100644
index 00000000..2b8fc8c5
--- /dev/null
+++ b/test/monniaux/sandbox/example.c
@@ -0,0 +1,42 @@
+#include <stdio.h>
+#include "f.h"
+#include "../cycles.h"
+
+#if 0
+int main(void){
+ cycle_count_config();
+
+ int i;
+ int S = 0;
+
+ TIMEINIT
+ for (i = 0; i < 1000; i++){
+ S += f(i, i*2);
+ }
+ TIMESTOP(0)
+
+ printf("Final value: %d\n", S);
+ TIMESTOP(1)
+
+ TIMEPRINT(1)
+ return 0;
+}
+#endif
+
+#if 0
+int main(void){
+ cycle_count_config();
+
+ TIMEINIT
+ int a = 42;
+ int b = 21;
+ int c = 42+b;
+ TIMESTOP(0)
+ int d = a + b;
+ int e = a + b + c + d;
+ TIMESTOP(1)
+
+ TIMEPRINT(1)
+ return e;
+}
+#endif
diff --git a/test/monniaux/sandbox/f.c b/test/monniaux/sandbox/f.c
new file mode 100644
index 00000000..7705c4f7
--- /dev/null
+++ b/test/monniaux/sandbox/f.c
@@ -0,0 +1,3 @@
+int f(int x, int y){
+ return x+y;
+}
diff --git a/test/monniaux/sandbox/f.h b/test/monniaux/sandbox/f.h
new file mode 100644
index 00000000..6ecab534
--- /dev/null
+++ b/test/monniaux/sandbox/f.h
@@ -0,0 +1 @@
+int f(int, int);
diff --git a/test/monniaux/sandbox/sha-256.c b/test/monniaux/sandbox/sha-256.c
new file mode 100644
index 00000000..9a9e7802
--- /dev/null
+++ b/test/monniaux/sandbox/sha-256.c
@@ -0,0 +1,387 @@
+#include <stdint.h>
+#include <string.h>
+#if 0 /* __COMPCERT__ */
+#define my_memcpy(dst, src, size) __builtin_memcpy_aligned(dst, src, size, 1)
+#else
+#define my_memcpy(dst, src, size) memcpy(dst, src, size)
+#endif
+
+#include "../cycles.h"
+
+#include "sha-256.h"
+
+#define USE_ORIGINAL 1
+#define AUTOINCREMENT 1
+
+#define CHUNK_SIZE 64
+#define TOTAL_LEN_LEN 8
+
+/*
+ * ABOUT bool: this file does not use bool in order to be as pre-C99 compatible as possible.
+ */
+
+/*
+ * Comments from pseudo-code at https://en.wikipedia.org/wiki/SHA-2 are reproduced here.
+ * When useful for clarification, portions of the pseudo-code are reproduced here too.
+ */
+
+/*
+ * Initialize array of round constants:
+ * (first 32 bits of the fractional parts of the cube roots of the first 64 primes 2..311):
+ */
+static const uint32_t k[] = {
+ 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,
+ 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,
+ 0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,
+ 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,
+ 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,
+ 0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,
+ 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,
+ 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2
+};
+
+struct buffer_state {
+ const uint8_t * p;
+ size_t len;
+ size_t total_len;
+ int single_one_delivered; /* bool */
+ int total_len_delivered; /* bool */
+};
+
+static inline uint32_t right_rot(uint32_t value, unsigned int count)
+{
+ /*
+ * Defined behaviour in standard C for all count where 0 < count < 32,
+ * which is what we need here.
+ */
+ return value >> count | value << (32 - count);
+}
+
+/* BEGIN DM */
+#define DEF_ROT(n) \
+static inline uint32_t right_rot##n(uint32_t value) \
+{ \
+ return value >> n | value << (32 - n); \
+}
+DEF_ROT(2)
+DEF_ROT(6)
+DEF_ROT(7)
+DEF_ROT(11)
+DEF_ROT(13)
+DEF_ROT(17)
+DEF_ROT(18)
+DEF_ROT(19)
+DEF_ROT(22)
+DEF_ROT(25)
+/* END DM */
+
+static void init_buf_state(struct buffer_state * state, const void * input, size_t len)
+{
+ state->p = input;
+ state->len = len;
+ state->total_len = len;
+ state->single_one_delivered = 0;
+ state->total_len_delivered = 0;
+}
+
+/* Return value: bool */
+static int calc_chunk(uint8_t chunk[CHUNK_SIZE], struct buffer_state * state)
+{
+ size_t space_in_chunk;
+
+ if (state->total_len_delivered) {
+ return 0;
+ }
+
+ if (state->len >= CHUNK_SIZE) {
+ my_memcpy(chunk, state->p, CHUNK_SIZE);
+ state->p += CHUNK_SIZE;
+ state->len -= CHUNK_SIZE;
+ return 1;
+ }
+
+ memcpy(chunk, state->p, state->len);
+ chunk += state->len;
+ space_in_chunk = CHUNK_SIZE - state->len;
+ state->p += state->len;
+ state->len = 0;
+
+ /* If we are here, space_in_chunk is one at minimum. */
+ if (!state->single_one_delivered) {
+ *chunk++ = 0x80;
+ space_in_chunk -= 1;
+ state->single_one_delivered = 1;
+ }
+
+ /*
+ * Now:
+ * - either there is enough space left for the total length, and we can conclude,
+ * - or there is too little space left, and we have to pad the rest of this chunk with zeroes.
+ * In the latter case, we will conclude at the next invokation of this function.
+ */
+ if (space_in_chunk >= TOTAL_LEN_LEN) {
+ const size_t left = space_in_chunk - TOTAL_LEN_LEN;
+ size_t len = state->total_len;
+ int i;
+ memset(chunk, 0x00, left);
+ chunk += left;
+
+ /* Storing of len * 8 as a big endian 64-bit without overflow. */
+ chunk[7] = (uint8_t) (len << 3);
+ len >>= 5;
+ for (i = 6; i >= 0; i--) {
+ chunk[i] = (uint8_t) len;
+ len >>= 8;
+ }
+ state->total_len_delivered = 1;
+ } else {
+ memset(chunk, 0x00, space_in_chunk);
+ }
+
+ return 1;
+}
+
+/*
+ * Limitations:
+ * - Since input is a pointer in RAM, the data to hash should be in RAM, which could be a problem
+ * for large data sizes.
+ * - SHA algorithms theoretically operate on bit strings. However, this implementation has no support
+ * for bit string lengths that are not multiples of eight, and it really operates on arrays of bytes.
+ * In particular, the len parameter is a number of bytes.
+ */
+
+#if USE_ORIGINAL
+void calc_sha_256(uint8_t hash[32], const void * input, size_t len)
+{
+ TIMEINIT(3)
+ /*
+ * Note 1: All integers (expect indexes) are 32-bit unsigned integers and addition is calculated modulo 2^32.
+ * Note 2: For each round, there is one round constant k[i] and one entry in the message schedule array w[i], 0 = i = 63
+ * Note 3: The compression function uses 8 working variables, a through h
+ * Note 4: Big-endian convention is used when expressing the constants in this pseudocode,
+ * and when parsing message block data from bytes to words, for example,
+ * the first word of the input message "abc" after padding is 0x61626380
+ */
+
+ /*
+ * Initialize hash values:
+ * (first 32 bits of the fractional parts of the square roots of the first 8 primes 2..19):
+ */
+ uint32_t h[] = { 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 };
+ int i, j;
+
+ /* 512-bit chunks is what we will operate on. */
+ uint8_t chunk[64];
+
+ struct buffer_state state;
+
+ init_buf_state(&state, input, len);
+ TIMEINIT(0)
+ while (calc_chunk(chunk, &state)) {
+ uint32_t ah[8];
+
+ /*
+ * create a 64-entry message schedule array w[0..63] of 32-bit words
+ * (The initial values in w[0..63] don't matter, so many implementations zero them here)
+ * copy chunk into first 16 words w[0..15] of the message schedule array
+ */
+ uint32_t w[64];
+ const uint8_t *p = chunk;
+
+ memset(w, 0x00, sizeof w);
+ for (i = 0; i < 16; i++) {
+ w[i] = (uint32_t) p[0] << 24 | (uint32_t) p[1] << 16 |
+ (uint32_t) p[2] << 8 | (uint32_t) p[3];
+ p += 4;
+ }
+
+ /* Extend the first 16 words into the remaining 48 words w[16..63] of the message schedule array: */
+ for (i = 16; i < 64; i++) {
+ const uint32_t s0 = right_rot7(w[i - 15]) ^ right_rot18(w[i - 15]) ^ (w[i - 15] >> 3);
+ const uint32_t s1 = right_rot17(w[i - 2]) ^ right_rot19(w[i - 2]) ^ (w[i - 2] >> 10);
+ w[i] = w[i - 16] + s0 + w[i - 7] + s1;
+ }
+
+ /* Initialize working variables to current hash value: */
+ for (i = 0; i < 8; i++)
+ ah[i] = h[i];
+
+ /* Compression function main loop: */
+ for (i = 0; i < 64; i++) {
+ //TIMEINIT(4)
+ const uint32_t s1 = right_rot6(ah[4]) ^ right_rot11(ah[4]) ^ right_rot25(ah[4]);
+ const uint32_t ch = (ah[4] & ah[5]) ^ (~ah[4] & ah[6]);
+ const uint32_t temp1 = ah[7] + s1 + ch + k[i] + w[i];
+ const uint32_t s0 = right_rot2(ah[0]) ^ right_rot13(ah[0]) ^ right_rot22(ah[0]);
+ const uint32_t maj = (ah[0] & ah[1]) ^ (ah[0] & ah[2]) ^ (ah[1] & ah[2]);
+ const uint32_t temp2 = s0 + maj;
+ //TIMESTOP(4) TIMEINIT(5)
+ ah[7] = ah[6];
+ ah[6] = ah[5];
+ ah[5] = ah[4];
+ ah[4] = ah[3] + temp1;
+ ah[3] = ah[2];
+ ah[2] = ah[1];
+ ah[1] = ah[0];
+ ah[0] = temp1 + temp2;
+ //TIMESTOP(5)
+ }
+
+ /* Add the compressed chunk to the current hash value: */
+ for (i = 0; i < 8; i++)
+ h[i] += ah[i];
+ TIMESTOP(0)
+ }
+
+ TIMEINIT(2)
+ /* Produce the final hash value (big-endian): */
+ for (i = 0, j = 0; i < 8; i++)
+ {
+ hash[j++] = (uint8_t) (h[i] >> 24);
+ hash[j++] = (uint8_t) (h[i] >> 16);
+ hash[j++] = (uint8_t) (h[i] >> 8);
+ hash[j++] = (uint8_t) h[i];
+ TIMESTOP(2)
+ }
+ TIMESTOP(3)
+}
+#else
+/* Modified by D. Monniaux */
+void calc_sha_256(uint8_t hash[32], const void * input, size_t len)
+{
+ /*
+ * Note 1: All integers (expect indexes) are 32-bit unsigned integers and addition is calculated modulo 2^32.
+ * Note 2: For each round, there is one round constant k[i] and one entry in the message schedule array w[i], 0 = i = 63
+ * Note 3: The compression function uses 8 working variables, a through h
+ * Note 4: Big-endian convention is used when expressing the constants in this pseudocode,
+ * and when parsing message block data from bytes to words, for example,
+ * the first word of the input message "abc" after padding is 0x61626380
+ */
+
+ /*
+ * Initialize hash values:
+ * (first 32 bits of the fractional parts of the square roots of the first 8 primes 2..19):
+ */
+ uint32_t h[] = { 0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a, 0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19 };
+ uint32_t h0 = h[0];
+ uint32_t h1 = h[1];
+ uint32_t h2 = h[2];
+ uint32_t h3 = h[3];
+ uint32_t h4 = h[4];
+ uint32_t h5 = h[5];
+ uint32_t h6 = h[6];
+ uint32_t h7 = h[7];
+ int i, j;
+
+ /* 512-bit chunks is what we will operate on. */
+ uint8_t chunk[64];
+
+ struct buffer_state state;
+
+ init_buf_state(&state, input, len);
+
+ while (calc_chunk(chunk, &state)) {
+ uint32_t ah0, ah1, ah2, ah3, ah4, ah5, ah6, ah7;
+
+ /*
+ * create a 64-entry message schedule array w[0..63] of 32-bit words
+ * (The initial values in w[0..63] don't matter, so many implementations zero them here)
+ * copy chunk into first 16 words w[0..15] of the message schedule array
+ */
+ uint32_t w[64];
+ const uint8_t *p = chunk;
+
+ memset(w, 0x00, sizeof w);
+#ifndef SKIP_SLOW_PARTS
+ for (i = 0; i < 16; i++) {
+ w[i] = (uint32_t) p[0] << 24 | (uint32_t) p[1] << 16 |
+ (uint32_t) p[2] << 8 | (uint32_t) p[3];
+ p += 4;
+ }
+
+ /* Extend the first 16 words into the remaining 48 words w[16..63] of the message schedule array: */
+ /* DM this is a SLOW part with ccomp; awkward address computations. */
+ for (i = 16; i < 64; i++) {
+ const uint32_t s0 = right_rot7(w[i - 15]) ^ right_rot18(w[i - 15]) ^ (w[i - 15] >> 3);
+ const uint32_t s1 = right_rot17(w[i - 2]) ^ right_rot19(w[i - 2]) ^ (w[i - 2] >> 10);
+ w[i] = w[i - 16] + s0 + w[i - 7] + s1;
+ }
+#endif
+ /* Initialize working variables to current hash value: */
+ ah0 = h0;
+ ah1 = h1;
+ ah2 = h2;
+ ah3 = h3;
+ ah4 = h4;
+ ah5 = h5;
+ ah6 = h6;
+ ah7 = h7;
+
+ /* Compression function main loop: */
+#if AUTOINCREMENT
+ const uint32_t *ki=k, *wi=w;
+#define KI *ki
+#define WI *wi
+#define STEP i++; ki++; wi++;
+#else
+#define KI k[i]
+#define WI w[i]
+#define STEP i++;
+#endif
+ for (i = 0; i < 64; ) {
+#define CHUNK \
+ { \
+ const uint32_t s1 = right_rot6(ah4) ^ right_rot11(ah4) ^ right_rot25(ah4); \
+ const uint32_t ch = (ah4 & ah5) ^ (~ah4 & ah6); \
+ const uint32_t temp1 = ah7 + s1 + ch + KI + WI; \
+ const uint32_t s0 = right_rot2(ah0) ^ right_rot13(ah0) ^ right_rot22(ah0); \
+ const uint32_t maj = (ah0 & ah1) ^ (ah0 & ah2) ^ (ah1 & ah2); \
+ const uint32_t temp2 = s0 + maj; \
+ \
+ ah7 = ah6; \
+ ah6 = ah5; \
+ ah5 = ah4; \
+ ah4 = ah3 + temp1; \
+ ah3 = ah2; \
+ ah2 = ah1; \
+ ah1 = ah0; \
+ ah0 = temp1 + temp2; \
+ STEP \
+ }
+ CHUNK
+ CHUNK
+ }
+
+ /* Add the compressed chunk to the current hash value: */
+ h0 += ah0;
+ h1 += ah1;
+ h2 += ah2;
+ h3 += ah3;
+ h4 += ah4;
+ h5 += ah5;
+ h6 += ah6;
+ h7 += ah7;
+ }
+ h[0]=h0;
+ h[1]=h1;
+ h[2]=h2;
+ h[3]=h3;
+ h[4]=h4;
+ h[5]=h5;
+ h[6]=h6;
+ h[7]=h7;
+
+ /* Produce the final hash value (big-endian): */
+ for (i = 0, j = 0; i < 8; i++)
+ {
+ hash[j++] = (uint8_t) (h[i] >> 24);
+ hash[j++] = (uint8_t) (h[i] >> 16);
+ hash[j++] = (uint8_t) (h[i] >> 8);
+ hash[j++] = (uint8_t) h[i];
+ }
+}
+#endif
+
+void print_all(void){
+ TIMEPRINT(5)
+}
diff --git a/test/monniaux/sandbox/sha-256.h b/test/monniaux/sandbox/sha-256.h
new file mode 100644
index 00000000..0753ea9e
--- /dev/null
+++ b/test/monniaux/sandbox/sha-256.h
@@ -0,0 +1,2 @@
+void calc_sha_256(uint8_t hash[32], const void *input, size_t len);
+void print_all(void);
diff --git a/test/monniaux/sandbox/sha-256_run.c b/test/monniaux/sandbox/sha-256_run.c
new file mode 100644
index 00000000..a1631bc6
--- /dev/null
+++ b/test/monniaux/sandbox/sha-256_run.c
@@ -0,0 +1,286 @@
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <inttypes.h>
+#include "../cycles.h"
+#include "sha-256.h"
+
+struct string_vector {
+ const char *input;
+ const char *output;
+};
+
+static const struct string_vector STRING_VECTORS[] = {
+ {
+ "",
+ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"
+ },
+ {
+ "abc",
+ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
+ },
+ {
+ "0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef",
+ "a8ae6e6ee929abea3afcfc5258c8ccd6f85273e0d4626d26c7279f3250f77c8e"
+ },
+ {
+ "0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcde",
+ "057ee79ece0b9a849552ab8d3c335fe9a5f1c46ef5f1d9b190c295728628299c"
+ },
+ {
+ "0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0",
+ "2a6ad82f3620d3ebe9d678c812ae12312699d673240d5be8fac0910a70000d93"
+ },
+ {
+ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
+ "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
+ },
+ {
+ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmno"
+ "ijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu",
+ "cf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1"
+ }
+};
+
+#define LARGE_MESSAGES 1
+#define LARGER_MESSAGES 0
+
+static uint8_t data1[] = { 0xbd };
+static uint8_t data2[] = { 0xc9, 0x8c, 0x8e, 0x55 };
+static uint8_t data7[1000];
+static uint8_t data8[1000];
+static uint8_t data9[1005];
+#if LARGE_MESSAGES
+#define SIZEOF_DATA11 536870912
+#define SIZEOF_DATA12 1090519040
+#define SIZEOF_DATA13 1610612798
+static uint8_t * data11;
+static uint8_t * data12;
+static uint8_t * data13;
+#endif
+
+struct vector {
+ const uint8_t *input;
+ size_t input_len;
+ const char *output;
+};
+
+static struct vector vectors[] = {
+ {
+ data1,
+ sizeof data1,
+ "68325720aabd7c82f30f554b313d0570c95accbb7dc4b5aae11204c08ffe732b"
+ },
+ {
+ data2,
+ sizeof data2,
+ "7abc22c0ae5af26ce93dbb94433a0e0b2e119d014f8e7f65bd56c61ccccd9504"
+ },
+ {
+ data7,
+ 55,
+ "02779466cdec163811d078815c633f21901413081449002f24aa3e80f0b88ef7"
+ },
+ {
+ data7,
+ 56,
+ "d4817aa5497628e7c77e6b606107042bbba3130888c5f47a375e6179be789fbb"
+ },
+ {
+ data7,
+ 57,
+ "65a16cb7861335d5ace3c60718b5052e44660726da4cd13bb745381b235a1785"
+ },
+ {
+ data7,
+ 64,
+ "f5a5fd42d16a20302798ef6ed309979b43003d2320d9f0e8ea9831a92759fb4b"
+ },
+ {
+ data7,
+ sizeof data7,
+ "541b3e9daa09b20bf85fa273e5cbd3e80185aa4ec298e765db87742b70138a53"
+ },
+ {
+ data8,
+ sizeof data8,
+ "c2e686823489ced2017f6059b8b239318b6364f6dcd835d0a519105a1eadd6e4"
+ },
+ {
+ data9,
+ sizeof data9,
+ "f4d62ddec0f3dd90ea1380fa16a5ff8dc4c54b21740650f24afc4120903552b0"
+ },
+#if LARGE_MESSAGES
+ {
+ NULL,
+ /* too big
+ 1000000,
+ "d29751f2649b32ff572b5e0a9f541ea660a50f94ff0beedfb0b692b924cc8025"
+ */
+ 50000,
+ "5b4b67b5d68e02c992760de07640472efe53a7f7553865f83262d0a74efc3e5d"
+ },
+#if LARGER_MESSAGES
+ {
+ NULL,
+ SIZEOF_DATA11,
+ "15a1868c12cc53951e182344277447cd0979536badcc512ad24c67e9b2d4f3dd"
+ },
+ {
+ NULL,
+ SIZEOF_DATA12,
+ "461c19a93bd4344f9215f5ec64357090342bc66b15a148317d276e31cbc20b53"
+ },
+ {
+ NULL,
+ SIZEOF_DATA13,
+ "c23ce8a7895f4b21ec0daf37920ac0a262a220045a03eb2dfed48ef9b05aabea"
+ }
+#endif
+#endif
+};
+
+#if LARGE_MESSAGES
+static void *my_malloc(size_t size) {
+ void *p=malloc(size);
+ if (p==0) {
+ fprintf(stderr, "malloc(%zu) failed\n", size);
+ abort();
+ }
+ return p;
+}
+#endif
+
+static void construct_binary_messages(void)
+{
+ memset(data7, 0x00, sizeof data7);
+ memset(data8, 0x41, sizeof data8);
+ memset(data9, 0x55, sizeof data9);
+#if LARGE_MESSAGES
+#if LARGER_MESSAGES
+ /*
+ * Heap allocation as a workaround for some linkers not liking
+ * large BSS segments.
+ */
+ data11 = my_malloc(SIZEOF_DATA11);
+ data12 = my_malloc(SIZEOF_DATA12);
+ data13 = my_malloc(SIZEOF_DATA13);
+ memset(data11, 0x5a, SIZEOF_DATA11);
+ memset(data12, 0x00, SIZEOF_DATA12);
+ memset(data13, 0x42, SIZEOF_DATA13);
+ vectors[9].input = data12;
+ vectors[10].input = data11;
+ vectors[11].input = data12;
+ vectors[12].input = data13;
+#else
+ vectors[9].input = data12 = my_malloc(vectors[9].input_len);
+ memset(data12, 0x00, vectors[9].input_len);
+#endif
+#endif
+}
+
+static void destruct_binary_messages(void)
+{
+#if LARGE_MESSAGES
+#if LARGER_MESSAGES
+ free(data11);
+ free(data12);
+ free(data13);
+#else
+ free(data12);
+#endif
+#endif
+}
+
+static void hash_to_string(char string[65], const uint8_t hash[32])
+{
+ size_t i;
+ for (i = 0; i < 32; i++) {
+ string += sprintf(string, "%02x", hash[i]);
+ }
+}
+
+static cycle_t cycle_total, cycle_start_time;
+
+static void cycle_count_start(void) {
+ cycle_start_time=get_cycle();
+}
+
+static void cycle_count_end(void) {
+ cycle_total += get_cycle()-cycle_start_time;
+}
+
+static int string_test(const char input[], const char output[])
+{
+ uint8_t hash[32];
+ char hash_string[65];
+
+ cycle_count_start();
+ calc_sha_256(hash, input, strlen(input));
+ cycle_count_end();
+
+ hash_to_string(hash_string, hash);
+ printf("input: %s\n", input);
+ printf("hash : %s\n", hash_string);
+ if (strcmp(output, hash_string)) {
+ printf("FAILURE!\n\n");
+ return 1;
+ } else {
+ printf("SUCCESS!\n\n");
+ return 0;
+ }
+}
+
+/*
+ * Limitation:
+ * - The variable input_len will be truncated to its LONG_BIT least
+ * significant bits in the print output. This will never be a problem
+ * for values that in practice are less than 2^32 - 1. Rationale: ANSI
+ * C-compatibility and keeping it simple.
+ */
+static int test(const uint8_t * input, size_t input_len, const char output[])
+{
+ uint8_t hash[32];
+ char hash_string[65];
+
+ cycle_count_start();
+ calc_sha_256(hash, input, input_len);
+ cycle_count_end();
+
+ hash_to_string(hash_string, hash);
+ printf("input starts with 0x%02x, length %lu\n", *input, (unsigned long) input_len);
+ printf("hash : %s\n", hash_string);
+ if (strcmp(output, hash_string)) {
+ printf("FAILURE!\n\n");
+ return 1;
+ } else {
+ printf("SUCCESS!\n\n");
+ return 0;
+ }
+}
+
+int main(void)
+{
+ cycle_count_config();
+ size_t i;
+ for (i = 0; i < (sizeof STRING_VECTORS / sizeof (struct string_vector)); i++) {
+ const struct string_vector *vector = &STRING_VECTORS[i];
+ if (string_test(vector->input, vector->output))
+ {} /* DM return 1; */
+ }
+ construct_binary_messages();
+ for (i = 0; i < (sizeof vectors / sizeof (struct vector)); i++) {
+ const struct vector *vector = &vectors[i];
+ if (test(vector->input, vector->input_len, vector->output))
+ { /* DM
+ destruct_binary_messages();
+ return 1; */
+ }
+ }
+ destruct_binary_messages();
+ printf("total cycles : %" PRIu64 "\n", cycle_total);
+ print_all();
+ return 0;
+}
diff --git a/test/monniaux/sha-2/Makefile b/test/monniaux/sha-2/Makefile
new file mode 100644
index 00000000..a043d89f
--- /dev/null
+++ b/test/monniaux/sha-2/Makefile
@@ -0,0 +1,3 @@
+TARGET=sha-256
+
+include ../rules.mk
diff --git a/test/monniaux/sha-2/make.proto b/test/monniaux/sha-2/make.proto
deleted file mode 100644
index f776565e..00000000
--- a/test/monniaux/sha-2/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-objdeps: [{name: sha-256_run, compiler: gcc}]
-target: sha-256
-measures: ["total cycles"]
diff --git a/test/monniaux/sha-2/sha-256_run.c b/test/monniaux/sha-2/sha-256_run.c
index 05a69d6b..1b6f7372 100644
--- a/test/monniaux/sha-2/sha-256_run.c
+++ b/test/monniaux/sha-2/sha-256_run.c
@@ -280,6 +280,6 @@ int main(void)
}
}
destruct_binary_messages();
- printf("total cycles : %" PRIu64 "\n", cycle_total);
+ printf("time cycles: %" PRIu64 "\n", cycle_total);
return 0;
}
diff --git a/test/monniaux/tacle-bench-lift/Makefile b/test/monniaux/tacle-bench-lift/Makefile
new file mode 100644
index 00000000..2e1db080
--- /dev/null
+++ b/test/monniaux/tacle-bench-lift/Makefile
@@ -0,0 +1,4 @@
+ALL_CFLAGS:=-include kill_pragma.h
+TARGET=lift
+
+include ../rules.mk
diff --git a/test/monniaux/tacle-bench-lift/make.proto b/test/monniaux/tacle-bench-lift/make.proto
deleted file mode 100644
index c4849bab..00000000
--- a/test/monniaux/tacle-bench-lift/make.proto
+++ /dev/null
@@ -1,4 +0,0 @@
-intro: "ALL_CFLAGS = -include kill_pragma.h"
-objdeps: [{name: liftlibcontrol, compiler: both}, {name: liftlibio, compiler: both}]
-target: lift
-measures: [cycles]
diff --git a/test/monniaux/tacle-bench-powerwindow/Makefile b/test/monniaux/tacle-bench-powerwindow/Makefile
new file mode 100644
index 00000000..3417cd4c
--- /dev/null
+++ b/test/monniaux/tacle-bench-powerwindow/Makefile
@@ -0,0 +1,4 @@
+ALL_CFLAGS:=-include kill_pragma.h
+TARGET=powerwindow
+
+include ../rules.mk
diff --git a/test/monniaux/tacle-bench-powerwindow/make.proto b/test/monniaux/tacle-bench-powerwindow/make.proto
deleted file mode 100644
index 21e07941..00000000
--- a/test/monniaux/tacle-bench-powerwindow/make.proto
+++ /dev/null
@@ -1,8 +0,0 @@
-intro: "ALL_CFLAGS = -include kill_pragma.h"
-objdeps: [{name: powerwindow_const_params, compiler: both}, {name: powerwindow_controlexclusion, compiler: both},
- {name: powerwindow_debounce, compiler: both}, {name: powerwindow_inputs, compiler: both},
- {name: powerwindow_powerwindow_control, compiler: both}, {name: powerwindow_PW_Control_DRV, compiler: both},
- {name: powerwindow_PW_Control_PSG_BackL, compiler: both}, {name: powerwindow_PW_Control_PSG_BackR, compiler: both},
- {name: powerwindow_PW_Control_PSG_Front, compiler: both}]
-target: powerwindow
-measures: [cycles]
diff --git a/test/monniaux/ternary.h b/test/monniaux/ternary.h
deleted file mode 100644
index 43cdbd12..00000000
--- a/test/monniaux/ternary.h
+++ /dev/null
@@ -1,23 +0,0 @@
-#include <stdint.h>
-
-static inline int32_t ternary_int32(int32_t a, int32_t b, int32_t c) {
- return (((-((a) == 0)) & (c)) | ((-((a) != 0)) & (b)));
-}
-static inline uint32_t ternary_uint32(uint32_t a, uint32_t b, uint32_t c) {
- return ternary_int32(a, b, c);
-}
-
-static inline int64_t ternary_int64(int64_t a, int64_t b, int64_t c) {
- return (((-((a) == 0)) & (c)) | ((-((a) != 0)) & (b)));
-}
-static inline uint64_t ternary_uint64(uint64_t a, uint64_t b, uint64_t c) {
- return ternary_int64(a, b, c);
-}
-
-#if defined(__COMPCERT__) && defined(__K1C__)
-#define TERNARY32(a, b, c) ternary_uint32((a), (b), (c))
-#define TERNARY64(a, b, c) ternary_uint64((a), (b), (c))
-#else
-#define TERNARY32(a, b, c) ((a) ? (b) : (c))
-#define TERNARY64(a, b, c) ((a) ? (b) : (c))
-#endif
diff --git a/test/monniaux/tiff-4.0.10/Makefile b/test/monniaux/tiff-4.0.10/Makefile
new file mode 100644
index 00000000..ac1aa276
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/Makefile
@@ -0,0 +1,7 @@
+TARGET=ppm2tiff
+ALL_CFLAGS=-lm
+ALL_CCOMPFLAGS = -flongdouble
+EXECUTE_ARGS= -c g3 __BASE__.g3.tif < example_bw.pbm
+
+include ../rules.mk
+
diff --git a/test/monniaux/tiff-4.0.10/example_bw.pbm b/test/monniaux/tiff-4.0.10/example_bw.pbm
new file mode 100644
index 00000000..971a82bb
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/example_bw.pbm
Binary files differ
diff --git a/test/monniaux/tiff-4.0.10/example_bw.pbm.bz2 b/test/monniaux/tiff-4.0.10/example_bw.pbm.bz2
new file mode 100644
index 00000000..ebf0ede0
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/example_bw.pbm.bz2
Binary files differ
diff --git a/test/monniaux/tiff-4.0.10/make.proto b/test/monniaux/tiff-4.0.10/make.proto
new file mode 100644
index 00000000..3a072b4c
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/make.proto
@@ -0,0 +1,4 @@
+sources: "$(wildcard *.c)"
+target: ppm2tiff
+measures: [cycles]
+name: ppm2tiff
diff --git a/test/monniaux/tiff-4.0.10/ppm2tiff.c b/test/monniaux/tiff-4.0.10/ppm2tiff.c
new file mode 100644
index 00000000..4fcee53e
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/ppm2tiff.c
@@ -0,0 +1,411 @@
+/*
+ * Copyright (c) 1991-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+// VERIMAG
+#define _POSIX_C_SOURCE 2
+#define VERIMAG 1
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
+#include "tif_config.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+
+#ifdef HAVE_IO_H
+# include <io.h>
+#endif
+
+#ifdef NEED_LIBPORT
+# include "libport.h"
+#endif
+
+#include "tiffio.h"
+
+#ifndef HAVE_GETOPT
+extern int getopt(int, char**, char*);
+#endif
+
+#define streq(a,b) (strcmp(a,b) == 0)
+#define strneq(a,b,n) (strncmp(a,b,n) == 0)
+
+static uint16 compression = COMPRESSION_PACKBITS;
+static uint16 predictor = 0;
+static int quality = 75; /* JPEG quality */
+static int jpegcolormode = JPEGCOLORMODE_RGB;
+static uint32 g3opts;
+
+static void usage(void);
+static int processCompressOptions(char*);
+
+static void
+BadPPM(char* file)
+{
+ fprintf(stderr, "%s: Not a PPM file.\n", file);
+ exit(-2);
+}
+
+
+#define TIFF_SIZE_T_MAX ((size_t) ~ ((size_t)0))
+#define TIFF_TMSIZE_T_MAX (tmsize_t)(TIFF_SIZE_T_MAX >> 1)
+
+static tmsize_t
+multiply_ms(tmsize_t m1, tmsize_t m2)
+{
+ if( m1 == 0 || m2 > TIFF_TMSIZE_T_MAX / m1 )
+ return 0;
+ return m1 * m2;
+}
+
+int
+main(int argc, char* argv[])
+{
+ uint16 photometric = 0;
+ uint32 rowsperstrip = (uint32) -1;
+ double resolution = -1;
+ unsigned char *buf = NULL;
+ tmsize_t linebytes = 0;
+ uint16 spp = 1;
+ uint16 bpp = 8;
+ TIFF *out;
+ FILE *in;
+ unsigned int w, h, prec, row;
+ char *infile;
+ int c;
+#if !HAVE_DECL_OPTARG
+ extern int optind;
+ extern char* optarg;
+#endif
+ tmsize_t scanline_size;
+
+ if (argc < 2) {
+ fprintf(stderr, "%s: Too few arguments\n", argv[0]);
+ usage();
+ }
+ while ((c = getopt(argc, argv, "c:r:R:")) != -1)
+ switch (c) {
+ case 'c': /* compression scheme */
+ if (!processCompressOptions(optarg))
+ usage();
+ break;
+ case 'r': /* rows/strip */
+ rowsperstrip = atoi(optarg);
+ break;
+ case 'R': /* resolution */
+ resolution = atof(optarg);
+ break;
+ case '?':
+ usage();
+ /*NOTREACHED*/
+ }
+
+ if (optind + 2 < argc) {
+ fprintf(stderr, "%s: Too many arguments\n", argv[0]);
+ usage();
+ }
+
+ /*
+ * If only one file is specified, read input from
+ * stdin; otherwise usage is: ppm2tiff input output.
+ */
+ if (argc - optind > 1) {
+ infile = argv[optind++];
+ in = fopen(infile, "rb");
+ if (in == NULL) {
+ fprintf(stderr, "%s: Can not open.\n", infile);
+ return (-1);
+ }
+ } else {
+ infile = "<stdin>";
+ in = stdin;
+#if defined(HAVE_SETMODE) && defined(O_BINARY)
+ setmode(fileno(stdin), O_BINARY);
+#endif
+ }
+
+ if (fgetc(in) != 'P')
+ BadPPM(infile);
+ switch (fgetc(in)) {
+ case '4': /* it's a PBM file */
+ bpp = 1;
+ spp = 1;
+ photometric = PHOTOMETRIC_MINISWHITE;
+ break;
+ case '5': /* it's a PGM file */
+ bpp = 8;
+ spp = 1;
+ photometric = PHOTOMETRIC_MINISBLACK;
+ break;
+ case '6': /* it's a PPM file */
+ bpp = 8;
+ spp = 3;
+ photometric = PHOTOMETRIC_RGB;
+ if (compression == COMPRESSION_JPEG &&
+ jpegcolormode == JPEGCOLORMODE_RGB)
+ photometric = PHOTOMETRIC_YCBCR;
+ break;
+ default:
+ BadPPM(infile);
+ }
+
+ /* Parse header */
+ while(1) {
+ if (feof(in))
+ BadPPM(infile);
+ c = fgetc(in);
+ /* Skip whitespaces (blanks, TABs, CRs, LFs) */
+ if (strchr(" \t\r\n", c))
+ continue;
+
+ /* Check for comment line */
+ if (c == '#') {
+ do {
+ c = fgetc(in);
+ } while(!(strchr("\r\n", c) || feof(in)));
+ continue;
+ }
+
+ ungetc(c, in);
+ break;
+ }
+ switch (bpp) {
+ case 1:
+ if (fscanf(in, " %u %u", &w, &h) != 2)
+ BadPPM(infile);
+ if (fgetc(in) != '\n')
+ BadPPM(infile);
+ break;
+ case 8:
+ if (fscanf(in, " %u %u %u", &w, &h, &prec) != 3)
+ BadPPM(infile);
+ if (fgetc(in) != '\n' || prec != 255)
+ BadPPM(infile);
+ break;
+ }
+ out = TIFFOpen(argv[optind], "w");
+ if (out == NULL)
+ return (-4);
+ TIFFSetField(out, TIFFTAG_IMAGEWIDTH, (uint32) w);
+ TIFFSetField(out, TIFFTAG_IMAGELENGTH, (uint32) h);
+ TIFFSetField(out, TIFFTAG_ORIENTATION, ORIENTATION_TOPLEFT);
+ TIFFSetField(out, TIFFTAG_SAMPLESPERPIXEL, spp);
+ TIFFSetField(out, TIFFTAG_BITSPERSAMPLE, bpp);
+ TIFFSetField(out, TIFFTAG_PLANARCONFIG, PLANARCONFIG_CONTIG);
+ TIFFSetField(out, TIFFTAG_PHOTOMETRIC, photometric);
+ TIFFSetField(out, TIFFTAG_COMPRESSION, compression);
+ switch (compression) {
+ case COMPRESSION_JPEG:
+ TIFFSetField(out, TIFFTAG_JPEGQUALITY, quality);
+ TIFFSetField(out, TIFFTAG_JPEGCOLORMODE, jpegcolormode);
+ break;
+ case COMPRESSION_LZW:
+ case COMPRESSION_DEFLATE:
+ if (predictor != 0)
+ TIFFSetField(out, TIFFTAG_PREDICTOR, predictor);
+ break;
+ case COMPRESSION_CCITTFAX3:
+ TIFFSetField(out, TIFFTAG_GROUP3OPTIONS, g3opts);
+ break;
+ }
+ switch (bpp) {
+ case 1:
+ /* if round-up overflows, result will be zero, OK */
+ linebytes = (multiply_ms(spp, w) + (8 - 1)) / 8;
+ if (rowsperstrip == (uint32) -1) {
+ TIFFSetField(out, TIFFTAG_ROWSPERSTRIP, h);
+ } else {
+ TIFFSetField(out, TIFFTAG_ROWSPERSTRIP,
+ TIFFDefaultStripSize(out, rowsperstrip));
+ }
+ break;
+ case 8:
+ linebytes = multiply_ms(spp, w);
+ TIFFSetField(out, TIFFTAG_ROWSPERSTRIP,
+ TIFFDefaultStripSize(out, rowsperstrip));
+ break;
+ }
+ if (linebytes == 0) {
+ fprintf(stderr, "%s: scanline size overflow\n", infile);
+ (void) TIFFClose(out);
+ exit(-2);
+ }
+ scanline_size = TIFFScanlineSize(out);
+ if (scanline_size == 0) {
+ /* overflow - TIFFScanlineSize already printed a message */
+ (void) TIFFClose(out);
+ exit(-2);
+ }
+ if (scanline_size < linebytes)
+ buf = (unsigned char *)_TIFFmalloc(linebytes);
+ else
+ buf = (unsigned char *)_TIFFmalloc(scanline_size);
+ if (buf == NULL) {
+ fprintf(stderr, "%s: Not enough memory\n", infile);
+ (void) TIFFClose(out);
+ exit(-2);
+ }
+ if (resolution > 0) {
+ TIFFSetField(out, TIFFTAG_XRESOLUTION, resolution);
+ TIFFSetField(out, TIFFTAG_YRESOLUTION, resolution);
+ TIFFSetField(out, TIFFTAG_RESOLUTIONUNIT, RESUNIT_INCH);
+ }
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+ for (row = 0; row < h; row++) {
+ if (fread(buf, linebytes, 1, in) != 1) {
+ fprintf(stderr, "%s: scanline %lu: Read error.\n",
+ infile, (unsigned long) row);
+ break;
+ }
+ if (TIFFWriteScanline(out, buf, row, 0) < 0)
+ break;
+ }
+#ifdef VERIMAG
+ clock_stop();
+ print_total_clock();
+#endif
+ (void) TIFFClose(out);
+ if (buf)
+ _TIFFfree(buf);
+ return (0);
+}
+
+static void
+processG3Options(char* cp)
+{
+ g3opts = 0;
+ if( (cp = strchr(cp, ':')) ) {
+ do {
+ cp++;
+ if (strneq(cp, "1d", 2))
+ g3opts &= ~GROUP3OPT_2DENCODING;
+ else if (strneq(cp, "2d", 2))
+ g3opts |= GROUP3OPT_2DENCODING;
+ else if (strneq(cp, "fill", 4))
+ g3opts |= GROUP3OPT_FILLBITS;
+ else
+ usage();
+ } while( (cp = strchr(cp, ':')) );
+ }
+}
+
+static int
+processCompressOptions(char* opt)
+{
+ if (streq(opt, "none"))
+ compression = COMPRESSION_NONE;
+ else if (streq(opt, "packbits"))
+ compression = COMPRESSION_PACKBITS;
+ else if (strneq(opt, "jpeg", 4)) {
+ char* cp = strchr(opt, ':');
+
+ compression = COMPRESSION_JPEG;
+ while (cp)
+ {
+ if (isdigit((int)cp[1]))
+ quality = atoi(cp+1);
+ else if (cp[1] == 'r' )
+ jpegcolormode = JPEGCOLORMODE_RAW;
+ else
+ usage();
+
+ cp = strchr(cp+1,':');
+ }
+ } else if (strneq(opt, "g3", 2)) {
+ processG3Options(opt);
+ compression = COMPRESSION_CCITTFAX3;
+ } else if (streq(opt, "g4")) {
+ compression = COMPRESSION_CCITTFAX4;
+ } else if (strneq(opt, "lzw", 3)) {
+ char* cp = strchr(opt, ':');
+ if (cp)
+ predictor = atoi(cp+1);
+ compression = COMPRESSION_LZW;
+ } else if (strneq(opt, "zip", 3)) {
+ char* cp = strchr(opt, ':');
+ if (cp)
+ predictor = atoi(cp+1);
+ compression = COMPRESSION_DEFLATE;
+ } else
+ return (0);
+ return (1);
+}
+
+char* stuff[] = {
+"usage: ppm2tiff [options] input.ppm output.tif",
+"where options are:",
+" -r # make each strip have no more than # rows",
+" -R # set x&y resolution (dpi)",
+"",
+" -c jpeg[:opts] compress output with JPEG encoding",
+" -c lzw[:opts] compress output with Lempel-Ziv & Welch encoding",
+" -c zip[:opts] compress output with deflate encoding",
+" -c packbits compress output with packbits encoding (the default)",
+" -c g3[:opts] compress output with CCITT Group 3 encoding",
+" -c g4 compress output with CCITT Group 4 encoding",
+" -c none use no compression algorithm on output",
+"",
+"JPEG options:",
+" # set compression quality level (0-100, default 75)",
+" r output color image as RGB rather than YCbCr",
+"LZW and deflate options:",
+" # set predictor value",
+"For example, -c lzw:2 to get LZW-encoded data with horizontal differencing",
+NULL
+};
+
+static void
+usage(void)
+{
+ char buf[BUFSIZ];
+ int i;
+
+ setbuf(stderr, buf);
+ fprintf(stderr, "%s\n\n", TIFFGetVersion());
+ for (i = 0; stuff[i] != NULL; i++)
+ fprintf(stderr, "%s\n", stuff[i]);
+ exit(-1);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/t4.h b/test/monniaux/tiff-4.0.10/t4.h
new file mode 100644
index 00000000..fb0951a1
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/t4.h
@@ -0,0 +1,290 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _T4_
+#define _T4_
+/*
+ * CCITT T.4 1D Huffman runlength codes and
+ * related definitions. Given the small sizes
+ * of these tables it does not seem
+ * worthwhile to make code & length 8 bits.
+ */
+typedef struct tableentry {
+ unsigned short length; /* bit length of g3 code */
+ unsigned short code; /* g3 code */
+ short runlen; /* run length in bits */
+} tableentry;
+
+#define EOL 0x001 /* EOL code value - 0000 0000 0000 1 */
+
+/* status values returned instead of a run length */
+#define G3CODE_EOL -1 /* NB: ACT_EOL - ACT_WRUNT */
+#define G3CODE_INVALID -2 /* NB: ACT_INVALID - ACT_WRUNT */
+#define G3CODE_EOF -3 /* end of input data */
+#define G3CODE_INCOMP -4 /* incomplete run code */
+
+/*
+ * Note that these tables are ordered such that the
+ * index into the table is known to be either the
+ * run length, or (run length / 64) + a fixed offset.
+ *
+ * NB: The G3CODE_INVALID entries are only used
+ * during state generation (see mkg3states.c).
+ */
+#ifdef G3CODES
+const tableentry TIFFFaxWhiteCodes[] = {
+ { 8, 0x35, 0 }, /* 0011 0101 */
+ { 6, 0x7, 1 }, /* 0001 11 */
+ { 4, 0x7, 2 }, /* 0111 */
+ { 4, 0x8, 3 }, /* 1000 */
+ { 4, 0xB, 4 }, /* 1011 */
+ { 4, 0xC, 5 }, /* 1100 */
+ { 4, 0xE, 6 }, /* 1110 */
+ { 4, 0xF, 7 }, /* 1111 */
+ { 5, 0x13, 8 }, /* 1001 1 */
+ { 5, 0x14, 9 }, /* 1010 0 */
+ { 5, 0x7, 10 }, /* 0011 1 */
+ { 5, 0x8, 11 }, /* 0100 0 */
+ { 6, 0x8, 12 }, /* 0010 00 */
+ { 6, 0x3, 13 }, /* 0000 11 */
+ { 6, 0x34, 14 }, /* 1101 00 */
+ { 6, 0x35, 15 }, /* 1101 01 */
+ { 6, 0x2A, 16 }, /* 1010 10 */
+ { 6, 0x2B, 17 }, /* 1010 11 */
+ { 7, 0x27, 18 }, /* 0100 111 */
+ { 7, 0xC, 19 }, /* 0001 100 */
+ { 7, 0x8, 20 }, /* 0001 000 */
+ { 7, 0x17, 21 }, /* 0010 111 */
+ { 7, 0x3, 22 }, /* 0000 011 */
+ { 7, 0x4, 23 }, /* 0000 100 */
+ { 7, 0x28, 24 }, /* 0101 000 */
+ { 7, 0x2B, 25 }, /* 0101 011 */
+ { 7, 0x13, 26 }, /* 0010 011 */
+ { 7, 0x24, 27 }, /* 0100 100 */
+ { 7, 0x18, 28 }, /* 0011 000 */
+ { 8, 0x2, 29 }, /* 0000 0010 */
+ { 8, 0x3, 30 }, /* 0000 0011 */
+ { 8, 0x1A, 31 }, /* 0001 1010 */
+ { 8, 0x1B, 32 }, /* 0001 1011 */
+ { 8, 0x12, 33 }, /* 0001 0010 */
+ { 8, 0x13, 34 }, /* 0001 0011 */
+ { 8, 0x14, 35 }, /* 0001 0100 */
+ { 8, 0x15, 36 }, /* 0001 0101 */
+ { 8, 0x16, 37 }, /* 0001 0110 */
+ { 8, 0x17, 38 }, /* 0001 0111 */
+ { 8, 0x28, 39 }, /* 0010 1000 */
+ { 8, 0x29, 40 }, /* 0010 1001 */
+ { 8, 0x2A, 41 }, /* 0010 1010 */
+ { 8, 0x2B, 42 }, /* 0010 1011 */
+ { 8, 0x2C, 43 }, /* 0010 1100 */
+ { 8, 0x2D, 44 }, /* 0010 1101 */
+ { 8, 0x4, 45 }, /* 0000 0100 */
+ { 8, 0x5, 46 }, /* 0000 0101 */
+ { 8, 0xA, 47 }, /* 0000 1010 */
+ { 8, 0xB, 48 }, /* 0000 1011 */
+ { 8, 0x52, 49 }, /* 0101 0010 */
+ { 8, 0x53, 50 }, /* 0101 0011 */
+ { 8, 0x54, 51 }, /* 0101 0100 */
+ { 8, 0x55, 52 }, /* 0101 0101 */
+ { 8, 0x24, 53 }, /* 0010 0100 */
+ { 8, 0x25, 54 }, /* 0010 0101 */
+ { 8, 0x58, 55 }, /* 0101 1000 */
+ { 8, 0x59, 56 }, /* 0101 1001 */
+ { 8, 0x5A, 57 }, /* 0101 1010 */
+ { 8, 0x5B, 58 }, /* 0101 1011 */
+ { 8, 0x4A, 59 }, /* 0100 1010 */
+ { 8, 0x4B, 60 }, /* 0100 1011 */
+ { 8, 0x32, 61 }, /* 0011 0010 */
+ { 8, 0x33, 62 }, /* 0011 0011 */
+ { 8, 0x34, 63 }, /* 0011 0100 */
+ { 5, 0x1B, 64 }, /* 1101 1 */
+ { 5, 0x12, 128 }, /* 1001 0 */
+ { 6, 0x17, 192 }, /* 0101 11 */
+ { 7, 0x37, 256 }, /* 0110 111 */
+ { 8, 0x36, 320 }, /* 0011 0110 */
+ { 8, 0x37, 384 }, /* 0011 0111 */
+ { 8, 0x64, 448 }, /* 0110 0100 */
+ { 8, 0x65, 512 }, /* 0110 0101 */
+ { 8, 0x68, 576 }, /* 0110 1000 */
+ { 8, 0x67, 640 }, /* 0110 0111 */
+ { 9, 0xCC, 704 }, /* 0110 0110 0 */
+ { 9, 0xCD, 768 }, /* 0110 0110 1 */
+ { 9, 0xD2, 832 }, /* 0110 1001 0 */
+ { 9, 0xD3, 896 }, /* 0110 1001 1 */
+ { 9, 0xD4, 960 }, /* 0110 1010 0 */
+ { 9, 0xD5, 1024 }, /* 0110 1010 1 */
+ { 9, 0xD6, 1088 }, /* 0110 1011 0 */
+ { 9, 0xD7, 1152 }, /* 0110 1011 1 */
+ { 9, 0xD8, 1216 }, /* 0110 1100 0 */
+ { 9, 0xD9, 1280 }, /* 0110 1100 1 */
+ { 9, 0xDA, 1344 }, /* 0110 1101 0 */
+ { 9, 0xDB, 1408 }, /* 0110 1101 1 */
+ { 9, 0x98, 1472 }, /* 0100 1100 0 */
+ { 9, 0x99, 1536 }, /* 0100 1100 1 */
+ { 9, 0x9A, 1600 }, /* 0100 1101 0 */
+ { 6, 0x18, 1664 }, /* 0110 00 */
+ { 9, 0x9B, 1728 }, /* 0100 1101 1 */
+ { 11, 0x8, 1792 }, /* 0000 0001 000 */
+ { 11, 0xC, 1856 }, /* 0000 0001 100 */
+ { 11, 0xD, 1920 }, /* 0000 0001 101 */
+ { 12, 0x12, 1984 }, /* 0000 0001 0010 */
+ { 12, 0x13, 2048 }, /* 0000 0001 0011 */
+ { 12, 0x14, 2112 }, /* 0000 0001 0100 */
+ { 12, 0x15, 2176 }, /* 0000 0001 0101 */
+ { 12, 0x16, 2240 }, /* 0000 0001 0110 */
+ { 12, 0x17, 2304 }, /* 0000 0001 0111 */
+ { 12, 0x1C, 2368 }, /* 0000 0001 1100 */
+ { 12, 0x1D, 2432 }, /* 0000 0001 1101 */
+ { 12, 0x1E, 2496 }, /* 0000 0001 1110 */
+ { 12, 0x1F, 2560 }, /* 0000 0001 1111 */
+ { 12, 0x1, G3CODE_EOL }, /* 0000 0000 0001 */
+ { 9, 0x1, G3CODE_INVALID }, /* 0000 0000 1 */
+ { 10, 0x1, G3CODE_INVALID }, /* 0000 0000 01 */
+ { 11, 0x1, G3CODE_INVALID }, /* 0000 0000 001 */
+ { 12, 0x0, G3CODE_INVALID }, /* 0000 0000 0000 */
+};
+
+const tableentry TIFFFaxBlackCodes[] = {
+ { 10, 0x37, 0 }, /* 0000 1101 11 */
+ { 3, 0x2, 1 }, /* 010 */
+ { 2, 0x3, 2 }, /* 11 */
+ { 2, 0x2, 3 }, /* 10 */
+ { 3, 0x3, 4 }, /* 011 */
+ { 4, 0x3, 5 }, /* 0011 */
+ { 4, 0x2, 6 }, /* 0010 */
+ { 5, 0x3, 7 }, /* 0001 1 */
+ { 6, 0x5, 8 }, /* 0001 01 */
+ { 6, 0x4, 9 }, /* 0001 00 */
+ { 7, 0x4, 10 }, /* 0000 100 */
+ { 7, 0x5, 11 }, /* 0000 101 */
+ { 7, 0x7, 12 }, /* 0000 111 */
+ { 8, 0x4, 13 }, /* 0000 0100 */
+ { 8, 0x7, 14 }, /* 0000 0111 */
+ { 9, 0x18, 15 }, /* 0000 1100 0 */
+ { 10, 0x17, 16 }, /* 0000 0101 11 */
+ { 10, 0x18, 17 }, /* 0000 0110 00 */
+ { 10, 0x8, 18 }, /* 0000 0010 00 */
+ { 11, 0x67, 19 }, /* 0000 1100 111 */
+ { 11, 0x68, 20 }, /* 0000 1101 000 */
+ { 11, 0x6C, 21 }, /* 0000 1101 100 */
+ { 11, 0x37, 22 }, /* 0000 0110 111 */
+ { 11, 0x28, 23 }, /* 0000 0101 000 */
+ { 11, 0x17, 24 }, /* 0000 0010 111 */
+ { 11, 0x18, 25 }, /* 0000 0011 000 */
+ { 12, 0xCA, 26 }, /* 0000 1100 1010 */
+ { 12, 0xCB, 27 }, /* 0000 1100 1011 */
+ { 12, 0xCC, 28 }, /* 0000 1100 1100 */
+ { 12, 0xCD, 29 }, /* 0000 1100 1101 */
+ { 12, 0x68, 30 }, /* 0000 0110 1000 */
+ { 12, 0x69, 31 }, /* 0000 0110 1001 */
+ { 12, 0x6A, 32 }, /* 0000 0110 1010 */
+ { 12, 0x6B, 33 }, /* 0000 0110 1011 */
+ { 12, 0xD2, 34 }, /* 0000 1101 0010 */
+ { 12, 0xD3, 35 }, /* 0000 1101 0011 */
+ { 12, 0xD4, 36 }, /* 0000 1101 0100 */
+ { 12, 0xD5, 37 }, /* 0000 1101 0101 */
+ { 12, 0xD6, 38 }, /* 0000 1101 0110 */
+ { 12, 0xD7, 39 }, /* 0000 1101 0111 */
+ { 12, 0x6C, 40 }, /* 0000 0110 1100 */
+ { 12, 0x6D, 41 }, /* 0000 0110 1101 */
+ { 12, 0xDA, 42 }, /* 0000 1101 1010 */
+ { 12, 0xDB, 43 }, /* 0000 1101 1011 */
+ { 12, 0x54, 44 }, /* 0000 0101 0100 */
+ { 12, 0x55, 45 }, /* 0000 0101 0101 */
+ { 12, 0x56, 46 }, /* 0000 0101 0110 */
+ { 12, 0x57, 47 }, /* 0000 0101 0111 */
+ { 12, 0x64, 48 }, /* 0000 0110 0100 */
+ { 12, 0x65, 49 }, /* 0000 0110 0101 */
+ { 12, 0x52, 50 }, /* 0000 0101 0010 */
+ { 12, 0x53, 51 }, /* 0000 0101 0011 */
+ { 12, 0x24, 52 }, /* 0000 0010 0100 */
+ { 12, 0x37, 53 }, /* 0000 0011 0111 */
+ { 12, 0x38, 54 }, /* 0000 0011 1000 */
+ { 12, 0x27, 55 }, /* 0000 0010 0111 */
+ { 12, 0x28, 56 }, /* 0000 0010 1000 */
+ { 12, 0x58, 57 }, /* 0000 0101 1000 */
+ { 12, 0x59, 58 }, /* 0000 0101 1001 */
+ { 12, 0x2B, 59 }, /* 0000 0010 1011 */
+ { 12, 0x2C, 60 }, /* 0000 0010 1100 */
+ { 12, 0x5A, 61 }, /* 0000 0101 1010 */
+ { 12, 0x66, 62 }, /* 0000 0110 0110 */
+ { 12, 0x67, 63 }, /* 0000 0110 0111 */
+ { 10, 0xF, 64 }, /* 0000 0011 11 */
+ { 12, 0xC8, 128 }, /* 0000 1100 1000 */
+ { 12, 0xC9, 192 }, /* 0000 1100 1001 */
+ { 12, 0x5B, 256 }, /* 0000 0101 1011 */
+ { 12, 0x33, 320 }, /* 0000 0011 0011 */
+ { 12, 0x34, 384 }, /* 0000 0011 0100 */
+ { 12, 0x35, 448 }, /* 0000 0011 0101 */
+ { 13, 0x6C, 512 }, /* 0000 0011 0110 0 */
+ { 13, 0x6D, 576 }, /* 0000 0011 0110 1 */
+ { 13, 0x4A, 640 }, /* 0000 0010 0101 0 */
+ { 13, 0x4B, 704 }, /* 0000 0010 0101 1 */
+ { 13, 0x4C, 768 }, /* 0000 0010 0110 0 */
+ { 13, 0x4D, 832 }, /* 0000 0010 0110 1 */
+ { 13, 0x72, 896 }, /* 0000 0011 1001 0 */
+ { 13, 0x73, 960 }, /* 0000 0011 1001 1 */
+ { 13, 0x74, 1024 }, /* 0000 0011 1010 0 */
+ { 13, 0x75, 1088 }, /* 0000 0011 1010 1 */
+ { 13, 0x76, 1152 }, /* 0000 0011 1011 0 */
+ { 13, 0x77, 1216 }, /* 0000 0011 1011 1 */
+ { 13, 0x52, 1280 }, /* 0000 0010 1001 0 */
+ { 13, 0x53, 1344 }, /* 0000 0010 1001 1 */
+ { 13, 0x54, 1408 }, /* 0000 0010 1010 0 */
+ { 13, 0x55, 1472 }, /* 0000 0010 1010 1 */
+ { 13, 0x5A, 1536 }, /* 0000 0010 1101 0 */
+ { 13, 0x5B, 1600 }, /* 0000 0010 1101 1 */
+ { 13, 0x64, 1664 }, /* 0000 0011 0010 0 */
+ { 13, 0x65, 1728 }, /* 0000 0011 0010 1 */
+ { 11, 0x8, 1792 }, /* 0000 0001 000 */
+ { 11, 0xC, 1856 }, /* 0000 0001 100 */
+ { 11, 0xD, 1920 }, /* 0000 0001 101 */
+ { 12, 0x12, 1984 }, /* 0000 0001 0010 */
+ { 12, 0x13, 2048 }, /* 0000 0001 0011 */
+ { 12, 0x14, 2112 }, /* 0000 0001 0100 */
+ { 12, 0x15, 2176 }, /* 0000 0001 0101 */
+ { 12, 0x16, 2240 }, /* 0000 0001 0110 */
+ { 12, 0x17, 2304 }, /* 0000 0001 0111 */
+ { 12, 0x1C, 2368 }, /* 0000 0001 1100 */
+ { 12, 0x1D, 2432 }, /* 0000 0001 1101 */
+ { 12, 0x1E, 2496 }, /* 0000 0001 1110 */
+ { 12, 0x1F, 2560 }, /* 0000 0001 1111 */
+ { 12, 0x1, G3CODE_EOL }, /* 0000 0000 0001 */
+ { 9, 0x1, G3CODE_INVALID }, /* 0000 0000 1 */
+ { 10, 0x1, G3CODE_INVALID }, /* 0000 0000 01 */
+ { 11, 0x1, G3CODE_INVALID }, /* 0000 0000 001 */
+ { 12, 0x0, G3CODE_INVALID }, /* 0000 0000 0000 */
+};
+#else
+extern const tableentry TIFFFaxWhiteCodes[];
+extern const tableentry TIFFFaxBlackCodes[];
+#endif
+#endif /* _T4_ */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_aux.c b/test/monniaux/tiff-4.0.10/tif_aux.c
new file mode 100644
index 00000000..4ece162f
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_aux.c
@@ -0,0 +1,374 @@
+/*
+ * Copyright (c) 1991-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Auxiliary Support Routines.
+ */
+#include "tiffiop.h"
+#include "tif_predict.h"
+#include <math.h>
+
+uint32
+_TIFFMultiply32(TIFF* tif, uint32 first, uint32 second, const char* where)
+{
+ uint32 bytes = first * second;
+
+ if (second && bytes / second != first) {
+ TIFFErrorExt(tif->tif_clientdata, where, "Integer overflow in %s", where);
+ bytes = 0;
+ }
+
+ return bytes;
+}
+
+uint64
+_TIFFMultiply64(TIFF* tif, uint64 first, uint64 second, const char* where)
+{
+ uint64 bytes = first * second;
+
+ if (second && bytes / second != first) {
+ TIFFErrorExt(tif->tif_clientdata, where, "Integer overflow in %s", where);
+ bytes = 0;
+ }
+
+ return bytes;
+}
+
+void*
+_TIFFCheckRealloc(TIFF* tif, void* buffer,
+ tmsize_t nmemb, tmsize_t elem_size, const char* what)
+{
+ void* cp = NULL;
+ tmsize_t bytes = nmemb * elem_size;
+
+ /*
+ * XXX: Check for integer overflow.
+ */
+ if (nmemb && elem_size && bytes / elem_size == nmemb)
+ cp = _TIFFrealloc(buffer, bytes);
+
+ if (cp == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Failed to allocate memory for %s "
+ "(%ld elements of %ld bytes each)",
+ what,(long) nmemb, (long) elem_size);
+ }
+
+ return cp;
+}
+
+void*
+_TIFFCheckMalloc(TIFF* tif, tmsize_t nmemb, tmsize_t elem_size, const char* what)
+{
+ return _TIFFCheckRealloc(tif, NULL, nmemb, elem_size, what);
+}
+
+static int
+TIFFDefaultTransferFunction(TIFFDirectory* td)
+{
+ uint16 **tf = td->td_transferfunction;
+ tmsize_t i, n, nbytes;
+
+ tf[0] = tf[1] = tf[2] = 0;
+ if (td->td_bitspersample >= sizeof(tmsize_t) * 8 - 2)
+ return 0;
+
+ n = ((tmsize_t)1)<<td->td_bitspersample;
+ nbytes = n * sizeof (uint16);
+ tf[0] = (uint16 *)_TIFFmalloc(nbytes);
+ if (tf[0] == NULL)
+ return 0;
+ tf[0][0] = 0;
+ for (i = 1; i < n; i++) {
+ double t = (double)i/((double) n-1.);
+ tf[0][i] = (uint16)floor(65535.*pow(t, 2.2) + .5);
+ }
+
+ if (td->td_samplesperpixel - td->td_extrasamples > 1) {
+ tf[1] = (uint16 *)_TIFFmalloc(nbytes);
+ if(tf[1] == NULL)
+ goto bad;
+ _TIFFmemcpy(tf[1], tf[0], nbytes);
+ tf[2] = (uint16 *)_TIFFmalloc(nbytes);
+ if (tf[2] == NULL)
+ goto bad;
+ _TIFFmemcpy(tf[2], tf[0], nbytes);
+ }
+ return 1;
+
+bad:
+ if (tf[0])
+ _TIFFfree(tf[0]);
+ if (tf[1])
+ _TIFFfree(tf[1]);
+ if (tf[2])
+ _TIFFfree(tf[2]);
+ tf[0] = tf[1] = tf[2] = 0;
+ return 0;
+}
+
+static int
+TIFFDefaultRefBlackWhite(TIFFDirectory* td)
+{
+ int i;
+
+ td->td_refblackwhite = (float *)_TIFFmalloc(6*sizeof (float));
+ if (td->td_refblackwhite == NULL)
+ return 0;
+ if (td->td_photometric == PHOTOMETRIC_YCBCR) {
+ /*
+ * YCbCr (Class Y) images must have the ReferenceBlackWhite
+ * tag set. Fix the broken images, which lacks that tag.
+ */
+ td->td_refblackwhite[0] = 0.0F;
+ td->td_refblackwhite[1] = td->td_refblackwhite[3] =
+ td->td_refblackwhite[5] = 255.0F;
+ td->td_refblackwhite[2] = td->td_refblackwhite[4] = 128.0F;
+ } else {
+ /*
+ * Assume RGB (Class R)
+ */
+ for (i = 0; i < 3; i++) {
+ td->td_refblackwhite[2*i+0] = 0;
+ td->td_refblackwhite[2*i+1] =
+ (float)((1L<<td->td_bitspersample)-1L);
+ }
+ }
+ return 1;
+}
+
+/*
+ * Like TIFFGetField, but return any default
+ * value if the tag is not present in the directory.
+ *
+ * NB: We use the value in the directory, rather than
+ * explicit values so that defaults exist only one
+ * place in the library -- in TIFFDefaultDirectory.
+ */
+int
+TIFFVGetFieldDefaulted(TIFF* tif, uint32 tag, va_list ap)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (TIFFVGetField(tif, tag, ap))
+ return (1);
+ switch (tag) {
+ case TIFFTAG_SUBFILETYPE:
+ *va_arg(ap, uint32 *) = td->td_subfiletype;
+ return (1);
+ case TIFFTAG_BITSPERSAMPLE:
+ *va_arg(ap, uint16 *) = td->td_bitspersample;
+ return (1);
+ case TIFFTAG_THRESHHOLDING:
+ *va_arg(ap, uint16 *) = td->td_threshholding;
+ return (1);
+ case TIFFTAG_FILLORDER:
+ *va_arg(ap, uint16 *) = td->td_fillorder;
+ return (1);
+ case TIFFTAG_ORIENTATION:
+ *va_arg(ap, uint16 *) = td->td_orientation;
+ return (1);
+ case TIFFTAG_SAMPLESPERPIXEL:
+ *va_arg(ap, uint16 *) = td->td_samplesperpixel;
+ return (1);
+ case TIFFTAG_ROWSPERSTRIP:
+ *va_arg(ap, uint32 *) = td->td_rowsperstrip;
+ return (1);
+ case TIFFTAG_MINSAMPLEVALUE:
+ *va_arg(ap, uint16 *) = td->td_minsamplevalue;
+ return (1);
+ case TIFFTAG_MAXSAMPLEVALUE:
+ *va_arg(ap, uint16 *) = td->td_maxsamplevalue;
+ return (1);
+ case TIFFTAG_PLANARCONFIG:
+ *va_arg(ap, uint16 *) = td->td_planarconfig;
+ return (1);
+ case TIFFTAG_RESOLUTIONUNIT:
+ *va_arg(ap, uint16 *) = td->td_resolutionunit;
+ return (1);
+ case TIFFTAG_PREDICTOR:
+ {
+ TIFFPredictorState* sp = (TIFFPredictorState*) tif->tif_data;
+ if( sp == NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Cannot get \"Predictor\" tag as plugin is not configured");
+ *va_arg(ap, uint16*) = 0;
+ return 0;
+ }
+ *va_arg(ap, uint16*) = (uint16) sp->predictor;
+ return 1;
+ }
+ case TIFFTAG_DOTRANGE:
+ *va_arg(ap, uint16 *) = 0;
+ *va_arg(ap, uint16 *) = (1<<td->td_bitspersample)-1;
+ return (1);
+ case TIFFTAG_INKSET:
+ *va_arg(ap, uint16 *) = INKSET_CMYK;
+ return 1;
+ case TIFFTAG_NUMBEROFINKS:
+ *va_arg(ap, uint16 *) = 4;
+ return (1);
+ case TIFFTAG_EXTRASAMPLES:
+ *va_arg(ap, uint16 *) = td->td_extrasamples;
+ *va_arg(ap, uint16 **) = td->td_sampleinfo;
+ return (1);
+ case TIFFTAG_MATTEING:
+ *va_arg(ap, uint16 *) =
+ (td->td_extrasamples == 1 &&
+ td->td_sampleinfo[0] == EXTRASAMPLE_ASSOCALPHA);
+ return (1);
+ case TIFFTAG_TILEDEPTH:
+ *va_arg(ap, uint32 *) = td->td_tiledepth;
+ return (1);
+ case TIFFTAG_DATATYPE:
+ *va_arg(ap, uint16 *) = td->td_sampleformat-1;
+ return (1);
+ case TIFFTAG_SAMPLEFORMAT:
+ *va_arg(ap, uint16 *) = td->td_sampleformat;
+ return(1);
+ case TIFFTAG_IMAGEDEPTH:
+ *va_arg(ap, uint32 *) = td->td_imagedepth;
+ return (1);
+ case TIFFTAG_YCBCRCOEFFICIENTS:
+ {
+ /* defaults are from CCIR Recommendation 601-1 */
+ static float ycbcrcoeffs[] = { 0.299f, 0.587f, 0.114f };
+ *va_arg(ap, float **) = ycbcrcoeffs;
+ return 1;
+ }
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ *va_arg(ap, uint16 *) = td->td_ycbcrsubsampling[0];
+ *va_arg(ap, uint16 *) = td->td_ycbcrsubsampling[1];
+ return (1);
+ case TIFFTAG_YCBCRPOSITIONING:
+ *va_arg(ap, uint16 *) = td->td_ycbcrpositioning;
+ return (1);
+ case TIFFTAG_WHITEPOINT:
+ {
+ static float whitepoint[2];
+
+ /* TIFF 6.0 specification tells that it is no default
+ value for the WhitePoint, but AdobePhotoshop TIFF
+ Technical Note tells that it should be CIE D50. */
+ whitepoint[0] = D50_X0 / (D50_X0 + D50_Y0 + D50_Z0);
+ whitepoint[1] = D50_Y0 / (D50_X0 + D50_Y0 + D50_Z0);
+ *va_arg(ap, float **) = whitepoint;
+ return 1;
+ }
+ case TIFFTAG_TRANSFERFUNCTION:
+ if (!td->td_transferfunction[0] &&
+ !TIFFDefaultTransferFunction(td)) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name, "No space for \"TransferFunction\" tag");
+ return (0);
+ }
+ *va_arg(ap, uint16 **) = td->td_transferfunction[0];
+ if (td->td_samplesperpixel - td->td_extrasamples > 1) {
+ *va_arg(ap, uint16 **) = td->td_transferfunction[1];
+ *va_arg(ap, uint16 **) = td->td_transferfunction[2];
+ }
+ return (1);
+ case TIFFTAG_REFERENCEBLACKWHITE:
+ if (!td->td_refblackwhite && !TIFFDefaultRefBlackWhite(td))
+ return (0);
+ *va_arg(ap, float **) = td->td_refblackwhite;
+ return (1);
+ }
+ return 0;
+}
+
+/*
+ * Like TIFFGetField, but return any default
+ * value if the tag is not present in the directory.
+ */
+int
+TIFFGetFieldDefaulted(TIFF* tif, uint32 tag, ...)
+{
+ int ok;
+ va_list ap;
+
+ va_start(ap, tag);
+ ok = TIFFVGetFieldDefaulted(tif, tag, ap);
+ va_end(ap);
+ return (ok);
+}
+
+struct _Int64Parts {
+ int32 low, high;
+};
+
+typedef union {
+ struct _Int64Parts part;
+ int64 value;
+} _Int64;
+
+float
+_TIFFUInt64ToFloat(uint64 ui64)
+{
+ _Int64 i;
+
+ i.value = ui64;
+ if (i.part.high >= 0) {
+ return (float)i.value;
+ } else {
+ long double df;
+ df = (long double)i.value;
+ df += 18446744073709551616.0; /* adding 2**64 */
+ return (float)df;
+ }
+}
+
+double
+_TIFFUInt64ToDouble(uint64 ui64)
+{
+ _Int64 i;
+
+ i.value = ui64;
+ if (i.part.high >= 0) {
+ return (double)i.value;
+ } else {
+ long double df;
+ df = (long double)i.value;
+ df += 18446744073709551616.0; /* adding 2**64 */
+ return (double)df;
+ }
+}
+
+int _TIFFSeekOK(TIFF* tif, toff_t off)
+{
+ /* Huge offsets, especially -1 / UINT64_MAX, can cause issues */
+ /* See http://bugzilla.maptools.org/show_bug.cgi?id=2726 */
+ return off <= (~(uint64)0)/2 && TIFFSeekFile(tif,off,SEEK_SET)==off;
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_close.c b/test/monniaux/tiff-4.0.10/tif_close.c
new file mode 100644
index 00000000..e4228df9
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_close.c
@@ -0,0 +1,138 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ */
+#include "tiffiop.h"
+#include <string.h>
+
+/************************************************************************/
+/* TIFFCleanup() */
+/************************************************************************/
+
+/**
+ * Auxiliary function to free the TIFF structure. Given structure will be
+ * completely freed, so you should save opened file handle and pointer
+ * to the close procedure in external variables before calling
+ * _TIFFCleanup(), if you will need these ones to close the file.
+ *
+ * @param tif A TIFF pointer.
+ */
+
+void
+TIFFCleanup(TIFF* tif)
+{
+ /*
+ * Flush buffered data and directory (if dirty).
+ */
+ if (tif->tif_mode != O_RDONLY)
+ TIFFFlush(tif);
+ (*tif->tif_cleanup)(tif);
+ TIFFFreeDirectory(tif);
+
+ if (tif->tif_dirlist)
+ _TIFFfree(tif->tif_dirlist);
+
+ /*
+ * Clean up client info links.
+ */
+ while( tif->tif_clientinfo )
+ {
+ TIFFClientInfoLink *psLink = tif->tif_clientinfo;
+
+ tif->tif_clientinfo = psLink->next;
+ _TIFFfree( psLink->name );
+ _TIFFfree( psLink );
+ }
+
+ if (tif->tif_rawdata && (tif->tif_flags&TIFF_MYBUFFER))
+ _TIFFfree(tif->tif_rawdata);
+ if (isMapped(tif))
+ TIFFUnmapFileContents(tif, tif->tif_base, (toff_t)tif->tif_size);
+
+ /*
+ * Clean up custom fields.
+ */
+ if (tif->tif_fields && tif->tif_nfields > 0) {
+ uint32 i;
+
+ for (i = 0; i < tif->tif_nfields; i++) {
+ TIFFField *fld = tif->tif_fields[i];
+ if (fld->field_bit == FIELD_CUSTOM &&
+ strncmp("Tag ", fld->field_name, 4) == 0) {
+ _TIFFfree(fld->field_name);
+ _TIFFfree(fld);
+ }
+ }
+
+ _TIFFfree(tif->tif_fields);
+ }
+
+ if (tif->tif_nfieldscompat > 0) {
+ uint32 i;
+
+ for (i = 0; i < tif->tif_nfieldscompat; i++) {
+ if (tif->tif_fieldscompat[i].allocated_size)
+ _TIFFfree(tif->tif_fieldscompat[i].fields);
+ }
+ _TIFFfree(tif->tif_fieldscompat);
+ }
+
+ _TIFFfree(tif);
+}
+
+/************************************************************************/
+/* TIFFClose() */
+/************************************************************************/
+
+/**
+ * Close a previously opened TIFF file.
+ *
+ * TIFFClose closes a file that was previously opened with TIFFOpen().
+ * Any buffered data are flushed to the file, including the contents of
+ * the current directory (if modified); and all resources are reclaimed.
+ *
+ * @param tif A TIFF pointer.
+ */
+
+void
+TIFFClose(TIFF* tif)
+{
+ TIFFCloseProc closeproc = tif->tif_closeproc;
+ thandle_t fd = tif->tif_clientdata;
+
+ TIFFCleanup(tif);
+ (void) (*closeproc)(fd);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_codec.c b/test/monniaux/tiff-4.0.10/tif_codec.c
new file mode 100644
index 00000000..b6c04f01
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_codec.c
@@ -0,0 +1,171 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library
+ *
+ * Builtin Compression Scheme Configuration Support.
+ */
+#include "tiffiop.h"
+
+static int NotConfigured(TIFF*, int);
+
+#ifndef LZW_SUPPORT
+#define TIFFInitLZW NotConfigured
+#endif
+#ifndef PACKBITS_SUPPORT
+#define TIFFInitPackBits NotConfigured
+#endif
+#ifndef THUNDER_SUPPORT
+#define TIFFInitThunderScan NotConfigured
+#endif
+#ifndef NEXT_SUPPORT
+#define TIFFInitNeXT NotConfigured
+#endif
+#ifndef JPEG_SUPPORT
+#define TIFFInitJPEG NotConfigured
+#endif
+#ifndef OJPEG_SUPPORT
+#define TIFFInitOJPEG NotConfigured
+#endif
+#ifndef CCITT_SUPPORT
+#define TIFFInitCCITTRLE NotConfigured
+#define TIFFInitCCITTRLEW NotConfigured
+#define TIFFInitCCITTFax3 NotConfigured
+#define TIFFInitCCITTFax4 NotConfigured
+#endif
+#ifndef JBIG_SUPPORT
+#define TIFFInitJBIG NotConfigured
+#endif
+#ifndef ZIP_SUPPORT
+#define TIFFInitZIP NotConfigured
+#endif
+#ifndef PIXARLOG_SUPPORT
+#define TIFFInitPixarLog NotConfigured
+#endif
+#ifndef LOGLUV_SUPPORT
+#define TIFFInitSGILog NotConfigured
+#endif
+#ifndef LZMA_SUPPORT
+#define TIFFInitLZMA NotConfigured
+#endif
+#ifndef ZSTD_SUPPORT
+#define TIFFInitZSTD NotConfigured
+#endif
+#ifndef WEBP_SUPPORT
+#define TIFFInitWebP NotConfigured
+#endif
+
+/*
+ * Compression schemes statically built into the library.
+ */
+#ifdef VMS
+const TIFFCodec _TIFFBuiltinCODECS[] = {
+#else
+TIFFCodec _TIFFBuiltinCODECS[] = {
+#endif
+ { "None", COMPRESSION_NONE, TIFFInitDumpMode },
+ { "LZW", COMPRESSION_LZW, TIFFInitLZW },
+ { "PackBits", COMPRESSION_PACKBITS, TIFFInitPackBits },
+ { "ThunderScan", COMPRESSION_THUNDERSCAN,TIFFInitThunderScan },
+ { "NeXT", COMPRESSION_NEXT, TIFFInitNeXT },
+ { "JPEG", COMPRESSION_JPEG, TIFFInitJPEG },
+ { "Old-style JPEG", COMPRESSION_OJPEG, TIFFInitOJPEG },
+ { "CCITT RLE", COMPRESSION_CCITTRLE, TIFFInitCCITTRLE },
+ { "CCITT RLE/W", COMPRESSION_CCITTRLEW, TIFFInitCCITTRLEW },
+ { "CCITT Group 3", COMPRESSION_CCITTFAX3, TIFFInitCCITTFax3 },
+ { "CCITT Group 4", COMPRESSION_CCITTFAX4, TIFFInitCCITTFax4 },
+ { "ISO JBIG", COMPRESSION_JBIG, TIFFInitJBIG },
+ { "Deflate", COMPRESSION_DEFLATE, TIFFInitZIP },
+ { "AdobeDeflate", COMPRESSION_ADOBE_DEFLATE , TIFFInitZIP },
+ { "PixarLog", COMPRESSION_PIXARLOG, TIFFInitPixarLog },
+ { "SGILog", COMPRESSION_SGILOG, TIFFInitSGILog },
+ { "SGILog24", COMPRESSION_SGILOG24, TIFFInitSGILog },
+ { "LZMA", COMPRESSION_LZMA, TIFFInitLZMA },
+ { "ZSTD", COMPRESSION_ZSTD, TIFFInitZSTD },
+ { "WEBP", COMPRESSION_WEBP, TIFFInitWebP },
+ { NULL, 0, NULL }
+};
+
+static int
+_notConfigured(TIFF* tif)
+{
+ const TIFFCodec* c = TIFFFindCODEC(tif->tif_dir.td_compression);
+ char compression_code[20];
+
+ sprintf(compression_code, "%d",tif->tif_dir.td_compression );
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%s compression support is not configured",
+ c ? c->name : compression_code );
+ return (0);
+}
+
+static int
+NotConfigured(TIFF* tif, int scheme)
+{
+ (void) scheme;
+
+ tif->tif_fixuptags = _notConfigured;
+ tif->tif_decodestatus = FALSE;
+ tif->tif_setupdecode = _notConfigured;
+ tif->tif_encodestatus = FALSE;
+ tif->tif_setupencode = _notConfigured;
+ return (1);
+}
+
+/************************************************************************/
+/* TIFFIsCODECConfigured() */
+/************************************************************************/
+
+/**
+ * Check whether we have working codec for the specific coding scheme.
+ *
+ * @return returns 1 if the codec is configured and working. Otherwise
+ * 0 will be returned.
+ */
+
+int
+TIFFIsCODECConfigured(uint16 scheme)
+{
+ const TIFFCodec* codec = TIFFFindCODEC(scheme);
+
+ if(codec == NULL) {
+ return 0;
+ }
+ if(codec->init == NULL) {
+ return 0;
+ }
+ if(codec->init != NotConfigured){
+ return 1;
+ }
+ return 0;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_color.c b/test/monniaux/tiff-4.0.10/tif_color.c
new file mode 100644
index 00000000..8fae40ea
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_color.c
@@ -0,0 +1,307 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * CIE L*a*b* to CIE XYZ and CIE XYZ to RGB conversion routines are taken
+ * from the VIPS library (http://www.vips.ecs.soton.ac.uk) with
+ * the permission of John Cupitt, the VIPS author.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Color space conversion routines.
+ */
+
+#include "tiffiop.h"
+#include <math.h>
+
+/*
+ * Convert color value from the CIE L*a*b* 1976 space to CIE XYZ.
+ */
+void
+TIFFCIELabToXYZ(TIFFCIELabToRGB *cielab, uint32 l, int32 a, int32 b,
+ float *X, float *Y, float *Z)
+{
+ float L = (float)l * 100.0F / 255.0F;
+ float cby, tmp;
+
+ if( L < 8.856F ) {
+ *Y = (L * cielab->Y0) / 903.292F;
+ cby = 7.787F * (*Y / cielab->Y0) + 16.0F / 116.0F;
+ } else {
+ cby = (L + 16.0F) / 116.0F;
+ *Y = cielab->Y0 * cby * cby * cby;
+ }
+
+ tmp = (float)a / 500.0F + cby;
+ if( tmp < 0.2069F )
+ *X = cielab->X0 * (tmp - 0.13793F) / 7.787F;
+ else
+ *X = cielab->X0 * tmp * tmp * tmp;
+
+ tmp = cby - (float)b / 200.0F;
+ if( tmp < 0.2069F )
+ *Z = cielab->Z0 * (tmp - 0.13793F) / 7.787F;
+ else
+ *Z = cielab->Z0 * tmp * tmp * tmp;
+}
+
+#define RINT(R) ((uint32)((R)>0?((R)+0.5):((R)-0.5)))
+/*
+ * Convert color value from the XYZ space to RGB.
+ */
+void
+TIFFXYZToRGB(TIFFCIELabToRGB *cielab, float X, float Y, float Z,
+ uint32 *r, uint32 *g, uint32 *b)
+{
+ int i;
+ float Yr, Yg, Yb;
+ float *matrix = &cielab->display.d_mat[0][0];
+
+ /* Multiply through the matrix to get luminosity values. */
+ Yr = matrix[0] * X + matrix[1] * Y + matrix[2] * Z;
+ Yg = matrix[3] * X + matrix[4] * Y + matrix[5] * Z;
+ Yb = matrix[6] * X + matrix[7] * Y + matrix[8] * Z;
+
+ /* Clip input */
+ Yr = TIFFmax(Yr, cielab->display.d_Y0R);
+ Yg = TIFFmax(Yg, cielab->display.d_Y0G);
+ Yb = TIFFmax(Yb, cielab->display.d_Y0B);
+
+ /* Avoid overflow in case of wrong input values */
+ Yr = TIFFmin(Yr, cielab->display.d_YCR);
+ Yg = TIFFmin(Yg, cielab->display.d_YCG);
+ Yb = TIFFmin(Yb, cielab->display.d_YCB);
+
+ /* Turn luminosity to colour value. */
+ i = (int)((Yr - cielab->display.d_Y0R) / cielab->rstep);
+ i = TIFFmin(cielab->range, i);
+ *r = RINT(cielab->Yr2r[i]);
+
+ i = (int)((Yg - cielab->display.d_Y0G) / cielab->gstep);
+ i = TIFFmin(cielab->range, i);
+ *g = RINT(cielab->Yg2g[i]);
+
+ i = (int)((Yb - cielab->display.d_Y0B) / cielab->bstep);
+ i = TIFFmin(cielab->range, i);
+ *b = RINT(cielab->Yb2b[i]);
+
+ /* Clip output. */
+ *r = TIFFmin(*r, cielab->display.d_Vrwr);
+ *g = TIFFmin(*g, cielab->display.d_Vrwg);
+ *b = TIFFmin(*b, cielab->display.d_Vrwb);
+}
+#undef RINT
+
+/*
+ * Allocate conversion state structures and make look_up tables for
+ * the Yr,Yb,Yg <=> r,g,b conversions.
+ */
+int
+TIFFCIELabToRGBInit(TIFFCIELabToRGB* cielab,
+ const TIFFDisplay *display, float *refWhite)
+{
+ int i;
+ double dfGamma;
+
+ cielab->range = CIELABTORGB_TABLE_RANGE;
+
+ _TIFFmemcpy(&cielab->display, display, sizeof(TIFFDisplay));
+
+ /* Red */
+ dfGamma = 1.0 / cielab->display.d_gammaR ;
+ cielab->rstep =
+ (cielab->display.d_YCR - cielab->display.d_Y0R) / cielab->range;
+ for(i = 0; i <= cielab->range; i++) {
+ cielab->Yr2r[i] = cielab->display.d_Vrwr
+ * ((float)pow((double)i / cielab->range, dfGamma));
+ }
+
+ /* Green */
+ dfGamma = 1.0 / cielab->display.d_gammaG ;
+ cielab->gstep =
+ (cielab->display.d_YCR - cielab->display.d_Y0R) / cielab->range;
+ for(i = 0; i <= cielab->range; i++) {
+ cielab->Yg2g[i] = cielab->display.d_Vrwg
+ * ((float)pow((double)i / cielab->range, dfGamma));
+ }
+
+ /* Blue */
+ dfGamma = 1.0 / cielab->display.d_gammaB ;
+ cielab->bstep =
+ (cielab->display.d_YCR - cielab->display.d_Y0R) / cielab->range;
+ for(i = 0; i <= cielab->range; i++) {
+ cielab->Yb2b[i] = cielab->display.d_Vrwb
+ * ((float)pow((double)i / cielab->range, dfGamma));
+ }
+
+ /* Init reference white point */
+ cielab->X0 = refWhite[0];
+ cielab->Y0 = refWhite[1];
+ cielab->Z0 = refWhite[2];
+
+ return 0;
+}
+
+/*
+ * Convert color value from the YCbCr space to RGB.
+ * The colorspace conversion algorithm comes from the IJG v5a code;
+ * see below for more information on how it works.
+ */
+#define SHIFT 16
+#define FIX(x) ((int32)((x) * (1L<<SHIFT) + 0.5))
+#define ONE_HALF ((int32)(1<<(SHIFT-1)))
+#define Code2V(c, RB, RW, CR) ((((c)-(int32)(RB))*(float)(CR))/(float)(((RW)-(RB)!=0) ? ((RW)-(RB)) : 1))
+#define CLAMP(f,min,max) ((f)<(min)?(min):(f)>(max)?(max):(f))
+#define HICLAMP(f,max) ((f)>(max)?(max):(f))
+
+void
+TIFFYCbCrtoRGB(TIFFYCbCrToRGB *ycbcr, uint32 Y, int32 Cb, int32 Cr,
+ uint32 *r, uint32 *g, uint32 *b)
+{
+ int32 i;
+
+ /* XXX: Only 8-bit YCbCr input supported for now */
+ Y = HICLAMP(Y, 255);
+ Cb = CLAMP(Cb, 0, 255);
+ Cr = CLAMP(Cr, 0, 255);
+
+ i = ycbcr->Y_tab[Y] + ycbcr->Cr_r_tab[Cr];
+ *r = CLAMP(i, 0, 255);
+ i = ycbcr->Y_tab[Y]
+ + (int)((ycbcr->Cb_g_tab[Cb] + ycbcr->Cr_g_tab[Cr]) >> SHIFT);
+ *g = CLAMP(i, 0, 255);
+ i = ycbcr->Y_tab[Y] + ycbcr->Cb_b_tab[Cb];
+ *b = CLAMP(i, 0, 255);
+}
+
+/* Clamp function for sanitization purposes. Normally clamping should not */
+/* occur for well behaved chroma and refBlackWhite coefficients */
+static float CLAMPw(float v, float vmin, float vmax)
+{
+ if( v < vmin )
+ {
+ /* printf("%f clamped to %f\n", v, vmin); */
+ return vmin;
+ }
+ if( v > vmax )
+ {
+ /* printf("%f clamped to %f\n", v, vmax); */
+ return vmax;
+ }
+ return v;
+}
+
+/*
+ * Initialize the YCbCr->RGB conversion tables. The conversion
+ * is done according to the 6.0 spec:
+ *
+ * R = Y + Cr*(2 - 2*LumaRed)
+ * B = Y + Cb*(2 - 2*LumaBlue)
+ * G = Y
+ * - LumaBlue*Cb*(2-2*LumaBlue)/LumaGreen
+ * - LumaRed*Cr*(2-2*LumaRed)/LumaGreen
+ *
+ * To avoid floating point arithmetic the fractional constants that
+ * come out of the equations are represented as fixed point values
+ * in the range 0...2^16. We also eliminate multiplications by
+ * pre-calculating possible values indexed by Cb and Cr (this code
+ * assumes conversion is being done for 8-bit samples).
+ */
+int
+TIFFYCbCrToRGBInit(TIFFYCbCrToRGB* ycbcr, float *luma, float *refBlackWhite)
+{
+ TIFFRGBValue* clamptab;
+ int i;
+
+#define LumaRed luma[0]
+#define LumaGreen luma[1]
+#define LumaBlue luma[2]
+
+ clamptab = (TIFFRGBValue*)(
+ (uint8*) ycbcr+TIFFroundup_32(sizeof (TIFFYCbCrToRGB), sizeof (long)));
+ _TIFFmemset(clamptab, 0, 256); /* v < 0 => 0 */
+ ycbcr->clamptab = (clamptab += 256);
+ for (i = 0; i < 256; i++)
+ clamptab[i] = (TIFFRGBValue) i;
+ _TIFFmemset(clamptab+256, 255, 2*256); /* v > 255 => 255 */
+ ycbcr->Cr_r_tab = (int*) (clamptab + 3*256);
+ ycbcr->Cb_b_tab = ycbcr->Cr_r_tab + 256;
+ ycbcr->Cr_g_tab = (int32*) (ycbcr->Cb_b_tab + 256);
+ ycbcr->Cb_g_tab = ycbcr->Cr_g_tab + 256;
+ ycbcr->Y_tab = ycbcr->Cb_g_tab + 256;
+
+ { float f1 = 2-2*LumaRed; int32 D1 = FIX(CLAMP(f1,0.0F,2.0F));
+ float f2 = LumaRed*f1/LumaGreen; int32 D2 = -FIX(CLAMP(f2,0.0F,2.0F));
+ float f3 = 2-2*LumaBlue; int32 D3 = FIX(CLAMP(f3,0.0F,2.0F));
+ float f4 = LumaBlue*f3/LumaGreen; int32 D4 = -FIX(CLAMP(f4,0.0F,2.0F));
+ int x;
+
+#undef LumaBlue
+#undef LumaGreen
+#undef LumaRed
+
+ /*
+ * i is the actual input pixel value in the range 0..255
+ * Cb and Cr values are in the range -128..127 (actually
+ * they are in a range defined by the ReferenceBlackWhite
+ * tag) so there is some range shifting to do here when
+ * constructing tables indexed by the raw pixel data.
+ */
+ for (i = 0, x = -128; i < 256; i++, x++) {
+ int32 Cr = (int32)CLAMPw(Code2V(x, refBlackWhite[4] - 128.0F,
+ refBlackWhite[5] - 128.0F, 127),
+ -128.0F * 32, 128.0F * 32);
+ int32 Cb = (int32)CLAMPw(Code2V(x, refBlackWhite[2] - 128.0F,
+ refBlackWhite[3] - 128.0F, 127),
+ -128.0F * 32, 128.0F * 32);
+
+ ycbcr->Cr_r_tab[i] = (int32)((D1*Cr + ONE_HALF)>>SHIFT);
+ ycbcr->Cb_b_tab[i] = (int32)((D3*Cb + ONE_HALF)>>SHIFT);
+ ycbcr->Cr_g_tab[i] = D2*Cr;
+ ycbcr->Cb_g_tab[i] = D4*Cb + ONE_HALF;
+ ycbcr->Y_tab[i] =
+ (int32)CLAMPw(Code2V(x + 128, refBlackWhite[0], refBlackWhite[1], 255),
+ -128.0F * 32, 128.0F * 32);
+ }
+ }
+
+ return 0;
+}
+#undef HICLAMP
+#undef CLAMP
+#undef Code2V
+#undef SHIFT
+#undef ONE_HALF
+#undef FIX
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_compress.c b/test/monniaux/tiff-4.0.10/tif_compress.c
new file mode 100644
index 00000000..8130ef08
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_compress.c
@@ -0,0 +1,302 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library
+ *
+ * Compression Scheme Configuration Support.
+ */
+#include "tiffiop.h"
+
+static int
+TIFFNoEncode(TIFF* tif, const char* method)
+{
+ const TIFFCodec* c = TIFFFindCODEC(tif->tif_dir.td_compression);
+
+ if (c) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%s %s encoding is not implemented",
+ c->name, method);
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Compression scheme %u %s encoding is not implemented",
+ tif->tif_dir.td_compression, method);
+ }
+ return (-1);
+}
+
+int
+_TIFFNoRowEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoEncode(tif, "scanline"));
+}
+
+int
+_TIFFNoStripEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoEncode(tif, "strip"));
+}
+
+int
+_TIFFNoTileEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoEncode(tif, "tile"));
+}
+
+static int
+TIFFNoDecode(TIFF* tif, const char* method)
+{
+ const TIFFCodec* c = TIFFFindCODEC(tif->tif_dir.td_compression);
+
+ if (c)
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%s %s decoding is not implemented",
+ c->name, method);
+ else
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Compression scheme %u %s decoding is not implemented",
+ tif->tif_dir.td_compression, method);
+ return (0);
+}
+
+static int
+_TIFFNoFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+int
+_TIFFNoRowDecode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoDecode(tif, "scanline"));
+}
+
+int
+_TIFFNoStripDecode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoDecode(tif, "strip"));
+}
+
+int
+_TIFFNoTileDecode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) pp; (void) cc; (void) s;
+ return (TIFFNoDecode(tif, "tile"));
+}
+
+int
+_TIFFNoSeek(TIFF* tif, uint32 off)
+{
+ (void) off;
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Compression algorithm does not support random access");
+ return (0);
+}
+
+int
+_TIFFNoPreCode(TIFF* tif, uint16 s)
+{
+ (void) tif; (void) s;
+ return (1);
+}
+
+static int _TIFFtrue(TIFF* tif) { (void) tif; return (1); }
+static void _TIFFvoid(TIFF* tif) { (void) tif; }
+
+void
+_TIFFSetDefaultCompressionState(TIFF* tif)
+{
+ tif->tif_fixuptags = _TIFFNoFixupTags;
+ tif->tif_decodestatus = TRUE;
+ tif->tif_setupdecode = _TIFFtrue;
+ tif->tif_predecode = _TIFFNoPreCode;
+ tif->tif_decoderow = _TIFFNoRowDecode;
+ tif->tif_decodestrip = _TIFFNoStripDecode;
+ tif->tif_decodetile = _TIFFNoTileDecode;
+ tif->tif_encodestatus = TRUE;
+ tif->tif_setupencode = _TIFFtrue;
+ tif->tif_preencode = _TIFFNoPreCode;
+ tif->tif_postencode = _TIFFtrue;
+ tif->tif_encoderow = _TIFFNoRowEncode;
+ tif->tif_encodestrip = _TIFFNoStripEncode;
+ tif->tif_encodetile = _TIFFNoTileEncode;
+ tif->tif_close = _TIFFvoid;
+ tif->tif_seek = _TIFFNoSeek;
+ tif->tif_cleanup = _TIFFvoid;
+ tif->tif_defstripsize = _TIFFDefaultStripSize;
+ tif->tif_deftilesize = _TIFFDefaultTileSize;
+ tif->tif_flags &= ~(TIFF_NOBITREV|TIFF_NOREADRAW);
+}
+
+int
+TIFFSetCompressionScheme(TIFF* tif, int scheme)
+{
+ const TIFFCodec *c = TIFFFindCODEC((uint16) scheme);
+
+ _TIFFSetDefaultCompressionState(tif);
+ /*
+ * Don't treat an unknown compression scheme as an error.
+ * This permits applications to open files with data that
+ * the library does not have builtin support for, but which
+ * may still be meaningful.
+ */
+ return (c ? (*c->init)(tif, scheme) : 1);
+}
+
+/*
+ * Other compression schemes may be registered. Registered
+ * schemes can also override the builtin versions provided
+ * by this library.
+ */
+typedef struct _codec {
+ struct _codec* next;
+ TIFFCodec* info;
+} codec_t;
+static codec_t* registeredCODECS = NULL;
+
+const TIFFCodec*
+TIFFFindCODEC(uint16 scheme)
+{
+ const TIFFCodec* c;
+ codec_t* cd;
+
+ for (cd = registeredCODECS; cd; cd = cd->next)
+ if (cd->info->scheme == scheme)
+ return ((const TIFFCodec*) cd->info);
+ for (c = _TIFFBuiltinCODECS; c->name; c++)
+ if (c->scheme == scheme)
+ return (c);
+ return ((const TIFFCodec*) 0);
+}
+
+TIFFCodec*
+TIFFRegisterCODEC(uint16 scheme, const char* name, TIFFInitMethod init)
+{
+ codec_t* cd = (codec_t*)
+ _TIFFmalloc((tmsize_t)(sizeof (codec_t) + sizeof (TIFFCodec) + strlen(name)+1));
+
+ if (cd != NULL) {
+ cd->info = (TIFFCodec*) ((uint8*) cd + sizeof (codec_t));
+ cd->info->name = (char*)
+ ((uint8*) cd->info + sizeof (TIFFCodec));
+ strcpy(cd->info->name, name);
+ cd->info->scheme = scheme;
+ cd->info->init = init;
+ cd->next = registeredCODECS;
+ registeredCODECS = cd;
+ } else {
+ TIFFErrorExt(0, "TIFFRegisterCODEC",
+ "No space to register compression scheme %s", name);
+ return NULL;
+ }
+ return (cd->info);
+}
+
+void
+TIFFUnRegisterCODEC(TIFFCodec* c)
+{
+ codec_t* cd;
+ codec_t** pcd;
+
+ for (pcd = &registeredCODECS; (cd = *pcd) != NULL; pcd = &cd->next)
+ if (cd->info == c) {
+ *pcd = cd->next;
+ _TIFFfree(cd);
+ return;
+ }
+ TIFFErrorExt(0, "TIFFUnRegisterCODEC",
+ "Cannot remove compression scheme %s; not registered", c->name);
+}
+
+/************************************************************************/
+/* TIFFGetConfisuredCODECs() */
+/************************************************************************/
+
+/**
+ * Get list of configured codecs, both built-in and registered by user.
+ * Caller is responsible to free this structure.
+ *
+ * @return returns array of TIFFCodec records (the last record should be NULL)
+ * or NULL if function failed.
+ */
+
+TIFFCodec*
+TIFFGetConfiguredCODECs()
+{
+ int i = 1;
+ codec_t *cd;
+ const TIFFCodec* c;
+ TIFFCodec* codecs = NULL;
+ TIFFCodec* new_codecs;
+
+ for (cd = registeredCODECS; cd; cd = cd->next) {
+ new_codecs = (TIFFCodec *)
+ _TIFFrealloc(codecs, i * sizeof(TIFFCodec));
+ if (!new_codecs) {
+ _TIFFfree (codecs);
+ return NULL;
+ }
+ codecs = new_codecs;
+ _TIFFmemcpy(codecs + i - 1, cd, sizeof(TIFFCodec));
+ i++;
+ }
+ for (c = _TIFFBuiltinCODECS; c->name; c++) {
+ if (TIFFIsCODECConfigured(c->scheme)) {
+ new_codecs = (TIFFCodec *)
+ _TIFFrealloc(codecs, i * sizeof(TIFFCodec));
+ if (!new_codecs) {
+ _TIFFfree (codecs);
+ return NULL;
+ }
+ codecs = new_codecs;
+ _TIFFmemcpy(codecs + i - 1, (const void*)c, sizeof(TIFFCodec));
+ i++;
+ }
+ }
+
+ new_codecs = (TIFFCodec *) _TIFFrealloc(codecs, i * sizeof(TIFFCodec));
+ if (!new_codecs) {
+ _TIFFfree (codecs);
+ return NULL;
+ }
+ codecs = new_codecs;
+ _TIFFmemset(codecs + i - 1, 0, sizeof(TIFFCodec));
+
+ return codecs;
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_config.h b/test/monniaux/tiff-4.0.10/tif_config.h
new file mode 100644
index 00000000..ade947e6
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_config.h
@@ -0,0 +1,369 @@
+/* libtiff/tif_config.h. Generated from tif_config.h.in by configure. */
+/* libtiff/tif_config.h.in. Generated from configure.ac by autoheader. */
+
+/* Define if building universal (internal helper macro) */
+/* #undef AC_APPLE_UNIVERSAL_BUILD */
+
+/* Support CCITT Group 3 & 4 algorithms */
+#define CCITT_SUPPORT 1
+
+/* Pick up YCbCr subsampling info from the JPEG data stream to support files
+ lacking the tag (default enabled). */
+#define CHECK_JPEG_YCBCR_SUBSAMPLING 1
+
+/* enable partial strip reading for large strips (experimental) */
+/* #undef CHUNKY_STRIP_READ_SUPPORT */
+
+/* Support C++ stream API (requires C++ compiler) */
+/* #undef CXX_SUPPORT */
+
+/* Treat extra sample as alpha (default enabled). The RGBA interface will
+ treat a fourth sample with no EXTRASAMPLE_ value as being ASSOCALPHA. Many
+ packages produce RGBA files but don't mark the alpha properly. */
+#define DEFAULT_EXTRASAMPLE_AS_ALPHA 1
+
+/* enable deferred strip/tile offset/size loading (experimental) */
+/* #undef DEFER_STRILE_LOAD */
+
+/* Define to 1 if you have the <assert.h> header file. */
+#define HAVE_ASSERT_H 1
+
+/* Define to 1 if you have the declaration of `optarg', and to 0 if you don't.
+ */
+#define HAVE_DECL_OPTARG 1
+
+/* Define to 1 if you have the <dlfcn.h> header file. */
+/* #undef HAVE_DLFCN_H */
+
+/* Define to 1 if you have the <fcntl.h> header file. */
+#define HAVE_FCNTL_H 1
+
+/* Define to 1 if fseeko (and presumably ftello) exists and is declared. */
+/* #undef HAVE_FSEEKO */
+
+/* Define to 1 if you have the `getopt' function. */
+#define HAVE_GETOPT 1
+
+/* Define to 1 if you have the <GLUT/glut.h> header file. */
+/* #undef HAVE_GLUT_GLUT_H */
+
+/* Define to 1 if you have the <GL/glut.h> header file. */
+/* #undef HAVE_GL_GLUT_H */
+
+/* Define to 1 if you have the <GL/glu.h> header file. */
+/* #undef HAVE_GL_GLU_H */
+
+/* Define to 1 if you have the <GL/gl.h> header file. */
+/* #undef HAVE_GL_GL_H */
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#define HAVE_INTTYPES_H 1
+
+/* Define to 1 if you have the <io.h> header file. */
+/* #undef HAVE_IO_H */
+
+/* Define to 1 if you have the `jbg_newlen' function. */
+/* #undef HAVE_JBG_NEWLEN */
+
+/* Define to 1 if you have the `lfind' function. */
+/* #undef HAVE_LFIND */
+
+/* Define to 1 if you have the <memory.h> header file. */
+#define HAVE_MEMORY_H 1
+
+/* Define to 1 if you have the `mmap' function. */
+/* #undef HAVE_MMAP */
+
+/* Define to 1 if you have the <OpenGL/glu.h> header file. */
+/* #undef HAVE_OPENGL_GLU_H */
+
+/* Define to 1 if you have the <OpenGL/gl.h> header file. */
+/* #undef HAVE_OPENGL_GL_H */
+
+/* Define if you have POSIX threads libraries and header files. */
+/* #undef HAVE_PTHREAD */
+
+/* Define to 1 if you have the <search.h> header file. */
+#define HAVE_SEARCH_H 1
+
+/* Define to 1 if you have the `setmode' function. */
+/* #undef HAVE_SETMODE */
+
+/* Define to 1 if you have the `snprintf' function. */
+#define HAVE_SNPRINTF 1
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#define HAVE_STDINT_H 1
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#define HAVE_STDLIB_H 1
+
+/* Define to 1 if you have the `strcasecmp' function. */
+#define HAVE_STRCASECMP 1
+
+/* Define to 1 if you have the <strings.h> header file. */
+#define HAVE_STRINGS_H 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if you have the `strtol' function. */
+#define HAVE_STRTOL 1
+
+/* Define to 1 if you have the `strtoll' function. */
+#define HAVE_STRTOLL 1
+
+/* Define to 1 if you have the `strtoul' function. */
+#define HAVE_STRTOUL 1
+
+/* Define to 1 if you have the `strtoull' function. */
+#define HAVE_STRTOULL 1
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#define HAVE_SYS_STAT_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#define HAVE_UNISTD_H 1
+
+/* Use nonstandard varargs form for the GLU tesselator callback */
+/* #undef HAVE_VARARGS_GLU_TESSCB */
+
+/* Define to 1 if you have the <windows.h> header file. */
+/* #undef HAVE_WINDOWS_H */
+
+/* Native cpu byte order: 1 if big-endian (Motorola) or 0 if little-endian
+ (Intel) */
+#define HOST_BIGENDIAN 0
+
+/* Set the native cpu bit order (FILLORDER_LSB2MSB or FILLORDER_MSB2LSB) */
+#define HOST_FILLORDER FILLORDER_MSB2LSB
+
+/* Support ISO JBIG compression (requires JBIG-KIT library) */
+/* #undef JBIG_SUPPORT */
+
+/* 8/12 bit libjpeg dual mode enabled */
+/* #undef JPEG_DUAL_MODE_8_12 */
+
+/* Support JPEG compression (requires IJG JPEG library) */
+/* #undef JPEG_SUPPORT */
+
+/* 12bit libjpeg primary include file with path */
+/* #undef LIBJPEG_12_PATH */
+
+/* Support LogLuv high dynamic range encoding */
+#define LOGLUV_SUPPORT 1
+
+/* Define to the sub-directory where libtool stores uninstalled libraries. */
+#define LT_OBJDIR ".libs/"
+
+/* Support LZMA2 compression */
+/* #undef LZMA_SUPPORT */
+
+/* Support LZW algorithm */
+#define LZW_SUPPORT 1
+
+/* Support Microsoft Document Imaging format */
+#define MDI_SUPPORT 1
+
+/* Support NeXT 2-bit RLE algorithm */
+#define NEXT_SUPPORT 1
+
+/* Support Old JPEG compresson (read-only) */
+/* #undef OJPEG_SUPPORT */
+
+/* Name of package */
+#define PACKAGE "tiff"
+
+/* Define to the address where bug reports for this package should be sent. */
+#define PACKAGE_BUGREPORT "tiff@lists.maptools.org"
+
+/* Define to the full name of this package. */
+#define PACKAGE_NAME "LibTIFF Software"
+
+/* Define to the full name and version of this package. */
+#define PACKAGE_STRING "LibTIFF Software 4.0.10"
+
+/* Define to the one symbol short name of this package. */
+#define PACKAGE_TARNAME "tiff"
+
+/* Define to the home page for this package. */
+#define PACKAGE_URL ""
+
+/* Define to the version of this package. */
+#define PACKAGE_VERSION "4.0.10"
+
+/* Support Macintosh PackBits algorithm */
+#define PACKBITS_SUPPORT 1
+
+/* Support Pixar log-format algorithm (requires Zlib) */
+/* #undef PIXARLOG_SUPPORT */
+
+/* Define to necessary symbol if this constant uses a non-standard name on
+ your system. */
+/* #undef PTHREAD_CREATE_JOINABLE */
+
+/* The size of `signed int', as computed by sizeof. */
+#define SIZEOF_SIGNED_INT 4
+
+/* The size of `signed long', as computed by sizeof. */
+#define SIZEOF_SIGNED_LONG 8
+
+/* The size of `signed long long', as computed by sizeof. */
+#define SIZEOF_SIGNED_LONG_LONG 8
+
+/* The size of `size_t', as computed by sizeof. */
+#define SIZEOF_SIZE_T 8
+
+/* The size of `unsigned char *', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_CHAR_P 8
+
+/* The size of `unsigned int', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_INT 4
+
+/* The size of `unsigned long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG 8
+
+/* The size of `unsigned long long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG_LONG 8
+
+/* Define to 1 if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Support strip chopping (whether or not to convert single-strip uncompressed
+ images to mutiple strips of specified size to reduce memory usage) */
+#define STRIPCHOP_DEFAULT TIFF_STRIPCHOP
+
+/* Default size of the strip in bytes (when strip chopping enabled) */
+#define STRIP_SIZE_DEFAULT 8192
+
+/* Enable SubIFD tag (330) support */
+#define SUBIFD_SUPPORT 1
+
+/* Support ThunderScan 4-bit RLE algorithm */
+#define THUNDER_SUPPORT 1
+
+/* Signed 16-bit type */
+#define TIFF_INT16_T signed short
+
+/* Signed 32-bit type formatter */
+#define TIFF_INT32_FORMAT "%d"
+
+/* Signed 32-bit type */
+#define TIFF_INT32_T signed int
+
+/* Signed 64-bit type formatter */
+#define TIFF_INT64_FORMAT "%ld"
+
+/* Signed 64-bit type */
+#define TIFF_INT64_T signed long
+
+/* Signed 8-bit type */
+#define TIFF_INT8_T signed char
+
+/* Pointer difference type formatter */
+#define TIFF_PTRDIFF_FORMAT "%ld"
+
+/* Pointer difference type */
+#define TIFF_PTRDIFF_T ptrdiff_t
+
+/* Size type formatter */
+#define TIFF_SIZE_FORMAT "%lu"
+
+/* Unsigned size type */
+#define TIFF_SIZE_T unsigned long
+
+/* Signed size type formatter */
+#define TIFF_SSIZE_FORMAT "%ld"
+
+/* Signed size type */
+#define TIFF_SSIZE_T signed long
+
+/* Unsigned 16-bit type */
+#define TIFF_UINT16_T unsigned short
+
+/* Unsigned 32-bit type formatter */
+#define TIFF_UINT32_FORMAT "%u"
+
+/* Unsigned 32-bit type */
+#define TIFF_UINT32_T unsigned int
+
+/* Unsigned 64-bit type formatter */
+#define TIFF_UINT64_FORMAT "%lu"
+
+/* Unsigned 64-bit type */
+#define TIFF_UINT64_T unsigned long
+
+/* Unsigned 8-bit type */
+#define TIFF_UINT8_T unsigned char
+
+/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
+#define TIME_WITH_SYS_TIME 1
+
+/* Define to 1 if your <sys/time.h> declares `struct tm'. */
+/* #undef TM_IN_SYS_TIME */
+
+/* define to use win32 IO system */
+/* #undef USE_WIN32_FILEIO */
+
+/* Version number of package */
+#define VERSION "4.0.10"
+
+/* Support webp compression */
+/* #undef WEBP_SUPPORT */
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+ significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+# define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+/* # undef WORDS_BIGENDIAN */
+# endif
+#endif
+
+/* Define to 1 if the X Window System is missing or not being used. */
+#define X_DISPLAY_MISSING 1
+
+/* Support Deflate compression */
+/* #undef ZIP_SUPPORT */
+
+/* Support zstd compression */
+/* #undef ZSTD_SUPPORT */
+
+/* Enable large inode numbers on Mac OS X 10.5. */
+#ifndef _DARWIN_USE_64_BIT_INODE
+# define _DARWIN_USE_64_BIT_INODE 1
+#endif
+
+/* Number of bits in a file offset, on hosts where this is settable. */
+/* #undef _FILE_OFFSET_BITS */
+
+/* Define to 1 to make fseeko visible on some hosts (e.g. glibc 2.2). */
+/* #undef _LARGEFILE_SOURCE */
+
+/* Define for large files, on AIX-style hosts. */
+/* #undef _LARGE_FILES */
+
+/* Define to empty if `const' does not conform to ANSI C. */
+/* #undef const */
+
+/* Define to `__inline__' or `__inline' if that's what the C compiler
+ calls it, or to nothing if 'inline' is not supported under any name. */
+#ifndef __cplusplus
+/* #undef inline */
+#endif
+
+/* Define to `long int' if <sys/types.h> does not define. */
+/* #undef off_t */
+
+/* Define to `unsigned int' if <sys/types.h> does not define. */
+/* #undef size_t */
diff --git a/test/monniaux/tiff-4.0.10/tif_config.vc.h b/test/monniaux/tiff-4.0.10/tif_config.vc.h
new file mode 100644
index 00000000..5cebfa02
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_config.vc.h
@@ -0,0 +1,137 @@
+#ifndef _TIF_CONFIG_H_
+#define _TIF_CONFIG_H_
+
+/* Define to 1 if you have the <assert.h> header file. */
+#define HAVE_ASSERT_H 1
+
+/* Define to 1 if you have the <fcntl.h> header file. */
+#define HAVE_FCNTL_H 1
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Define to 1 if you have the `jbg_newlen' function. */
+#define HAVE_JBG_NEWLEN 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the <io.h> header file. */
+#define HAVE_IO_H 1
+
+/* Define to 1 if you have the <search.h> header file. */
+#define HAVE_SEARCH_H 1
+
+/* Define to 1 if you have the `setmode' function. */
+#define HAVE_SETMODE 1
+
+/* Define to 1 if you have the declaration of `optarg', and to 0 if you don't. */
+#define HAVE_DECL_OPTARG 0
+
+/* The size of a `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* The size of a `long', as computed by sizeof. */
+#define SIZEOF_LONG 4
+
+/* Signed 64-bit type formatter */
+#define TIFF_INT64_FORMAT "%I64d"
+
+/* Signed 64-bit type */
+#define TIFF_INT64_T signed __int64
+
+/* Unsigned 64-bit type formatter */
+#define TIFF_UINT64_FORMAT "%I64u"
+
+/* Unsigned 64-bit type */
+#define TIFF_UINT64_T unsigned __int64
+
+#if _WIN64
+/*
+ Windows 64-bit build
+*/
+
+/* Pointer difference type */
+# define TIFF_PTRDIFF_T TIFF_INT64_T
+
+/* The size of `size_t', as computed by sizeof. */
+# define SIZEOF_SIZE_T 8
+
+/* Size type formatter */
+# define TIFF_SIZE_FORMAT TIFF_INT64_FORMAT
+
+/* Unsigned size type */
+# define TIFF_SIZE_T TIFF_UINT64_T
+
+/* Signed size type formatter */
+# define TIFF_SSIZE_FORMAT TIFF_INT64_FORMAT
+
+/* Signed size type */
+# define TIFF_SSIZE_T TIFF_INT64_T
+
+#else
+/*
+ Windows 32-bit build
+*/
+
+/* Pointer difference type */
+# define TIFF_PTRDIFF_T signed int
+
+/* The size of `size_t', as computed by sizeof. */
+# define SIZEOF_SIZE_T 4
+
+/* Size type formatter */
+# define TIFF_SIZE_FORMAT "%u"
+
+/* Size type formatter */
+# define TIFF_SIZE_FORMAT "%u"
+
+/* Unsigned size type */
+# define TIFF_SIZE_T unsigned int
+
+/* Signed size type formatter */
+# define TIFF_SSIZE_FORMAT "%d"
+
+/* Signed size type */
+# define TIFF_SSIZE_T signed int
+
+#endif
+
+/* Set the native cpu bit order */
+#define HOST_FILLORDER FILLORDER_LSB2MSB
+
+/* Visual Studio 2015 / VC 14 / MSVC 19.00 finally has snprintf() */
+#if defined(_MSC_VER) && _MSC_VER < 1900
+#define snprintf _snprintf
+#else
+#define HAVE_SNPRINTF 1
+#endif
+
+/* Define to 1 if your processor stores words with the most significant byte
+ first (like Motorola and SPARC, unlike Intel and VAX). */
+/* #undef WORDS_BIGENDIAN */
+
+/* Define to `__inline__' or `__inline' if that's what the C compiler
+ calls it, or to nothing if 'inline' is not supported under any name. */
+#ifndef __cplusplus
+# ifndef inline
+# define inline __inline
+# endif
+#endif
+
+#define lfind _lfind
+
+#pragma warning(disable : 4996) /* function deprecation warnings */
+
+#endif /* _TIF_CONFIG_H_ */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_config.wince.h b/test/monniaux/tiff-4.0.10/tif_config.wince.h
new file mode 100644
index 00000000..e85e2e62
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_config.wince.h
@@ -0,0 +1,69 @@
+/*
+ * TIFF library configuration header for Windows CE platform.
+ */
+#ifndef _WIN32_WCE
+# error This version of tif_config.h header is dedicated for Windows CE platform!
+#endif
+
+/* Define to 1 if you have the <assert.h> header file. */
+#define HAVE_ASSERT_H 1
+
+/* Define to 1 if you have the <fcntl.h> header file. */
+#define HAVE_FCNTL_H 1
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Define to 1 if you have the `jbg_newlen' function. */
+#define HAVE_JBG_NEWLEN 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#undef HAVE_SYS_TYPES_H
+
+/* Define to 1 if you have the <io.h> header file. */
+#define HAVE_IO_H 1
+
+/* Define to 1 if you have the <search.h> header file. */
+#define HAVE_SEARCH_H 1
+
+/* Define to 1 if you have the `setmode' function. */
+#define HAVE_SETMODE 1
+
+/* Define to 1 if you have the `bsearch' function. */
+#define HAVE_BSEARCH 1
+#define bsearch wceex_bsearch
+
+/* Define to 1 if you have the `lfind' function. */
+#define HAVE_LFIND 1
+#define lfind wceex_lfind
+
+/* The size of a `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* Set the native cpu bit order */
+#define HOST_FILLORDER FILLORDER_LSB2MSB
+
+/* Define to 1 if your processor stores words with the most significant byte
+ first (like Motorola and SPARC, unlike Intel and VAX). */
+/* #undef WORDS_BIGENDIAN */
+
+/* Define to `__inline__' or `__inline' if that's what the C compiler
+ calls it, or to nothing if 'inline' is not supported under any name. */
+#ifndef __cplusplus
+# ifndef inline
+# define inline __inline
+# endif
+#endif
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dir.c b/test/monniaux/tiff-4.0.10/tif_dir.c
new file mode 100644
index 00000000..6f0b4879
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dir.c
@@ -0,0 +1,1768 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Directory Tag Get & Set Routines.
+ * (and also some miscellaneous stuff)
+ */
+#include "tiffiop.h"
+#include <float.h>
+
+/*
+ * These are used in the backwards compatibility code...
+ */
+#define DATATYPE_VOID 0 /* !untyped data */
+#define DATATYPE_INT 1 /* !signed integer data */
+#define DATATYPE_UINT 2 /* !unsigned integer data */
+#define DATATYPE_IEEEFP 3 /* !IEEE floating point data */
+
+static void
+setByteArray(void** vpp, void* vp, size_t nmemb, size_t elem_size)
+{
+ if (*vpp) {
+ _TIFFfree(*vpp);
+ *vpp = 0;
+ }
+ if (vp) {
+ tmsize_t bytes = (tmsize_t)(nmemb * elem_size);
+ if (elem_size && bytes / elem_size == nmemb)
+ *vpp = (void*) _TIFFmalloc(bytes);
+ if (*vpp)
+ _TIFFmemcpy(*vpp, vp, bytes);
+ }
+}
+void _TIFFsetByteArray(void** vpp, void* vp, uint32 n)
+ { setByteArray(vpp, vp, n, 1); }
+void _TIFFsetString(char** cpp, char* cp)
+ { setByteArray((void**) cpp, (void*) cp, strlen(cp)+1, 1); }
+static void _TIFFsetNString(char** cpp, char* cp, uint32 n)
+ { setByteArray((void**) cpp, (void*) cp, n, 1); }
+void _TIFFsetShortArray(uint16** wpp, uint16* wp, uint32 n)
+ { setByteArray((void**) wpp, (void*) wp, n, sizeof (uint16)); }
+void _TIFFsetLongArray(uint32** lpp, uint32* lp, uint32 n)
+ { setByteArray((void**) lpp, (void*) lp, n, sizeof (uint32)); }
+static void _TIFFsetLong8Array(uint64** lpp, uint64* lp, uint32 n)
+ { setByteArray((void**) lpp, (void*) lp, n, sizeof (uint64)); }
+void _TIFFsetFloatArray(float** fpp, float* fp, uint32 n)
+ { setByteArray((void**) fpp, (void*) fp, n, sizeof (float)); }
+void _TIFFsetDoubleArray(double** dpp, double* dp, uint32 n)
+ { setByteArray((void**) dpp, (void*) dp, n, sizeof (double)); }
+
+static void
+setDoubleArrayOneValue(double** vpp, double value, size_t nmemb)
+{
+ if (*vpp)
+ _TIFFfree(*vpp);
+ *vpp = _TIFFmalloc(nmemb*sizeof(double));
+ if (*vpp)
+ {
+ while (nmemb--)
+ ((double*)*vpp)[nmemb] = value;
+ }
+}
+
+/*
+ * Install extra samples information.
+ */
+static int
+setExtraSamples(TIFFDirectory* td, va_list ap, uint32* v)
+{
+/* XXX: Unassociated alpha data == 999 is a known Corel Draw bug, see below */
+#define EXTRASAMPLE_COREL_UNASSALPHA 999
+
+ uint16* va;
+ uint32 i;
+
+ *v = (uint16) va_arg(ap, uint16_vap);
+ if ((uint16) *v > td->td_samplesperpixel)
+ return 0;
+ va = va_arg(ap, uint16*);
+ if (*v > 0 && va == NULL) /* typically missing param */
+ return 0;
+ for (i = 0; i < *v; i++) {
+ if (va[i] > EXTRASAMPLE_UNASSALPHA) {
+ /*
+ * XXX: Corel Draw is known to produce incorrect
+ * ExtraSamples tags which must be patched here if we
+ * want to be able to open some of the damaged TIFF
+ * files:
+ */
+ if (va[i] == EXTRASAMPLE_COREL_UNASSALPHA)
+ va[i] = EXTRASAMPLE_UNASSALPHA;
+ else
+ return 0;
+ }
+ }
+ td->td_extrasamples = (uint16) *v;
+ _TIFFsetShortArray(&td->td_sampleinfo, va, td->td_extrasamples);
+ return 1;
+
+#undef EXTRASAMPLE_COREL_UNASSALPHA
+}
+
+/*
+ * Confirm we have "samplesperpixel" ink names separated by \0. Returns
+ * zero if the ink names are not as expected.
+ */
+static uint32
+checkInkNamesString(TIFF* tif, uint32 slen, const char* s)
+{
+ TIFFDirectory* td = &tif->tif_dir;
+ uint16 i = td->td_samplesperpixel;
+
+ if (slen > 0) {
+ const char* ep = s+slen;
+ const char* cp = s;
+ for (; i > 0; i--) {
+ for (; cp < ep && *cp != '\0'; cp++) {}
+ if (cp >= ep)
+ goto bad;
+ cp++; /* skip \0 */
+ }
+ return ((uint32)(cp-s));
+ }
+bad:
+ TIFFErrorExt(tif->tif_clientdata, "TIFFSetField",
+ "%s: Invalid InkNames value; expecting %d names, found %d",
+ tif->tif_name,
+ td->td_samplesperpixel,
+ td->td_samplesperpixel-i);
+ return (0);
+}
+
+static float TIFFClampDoubleToFloat( double val )
+{
+ if( val > FLT_MAX )
+ return FLT_MAX;
+ if( val < -FLT_MAX )
+ return -FLT_MAX;
+ return (float)val;
+}
+
+static int
+_TIFFVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "_TIFFVSetField";
+
+ TIFFDirectory* td = &tif->tif_dir;
+ int status = 1;
+ uint32 v32, i, v;
+ double dblval;
+ char* s;
+ const TIFFField *fip = TIFFFindField(tif, tag, TIFF_ANY);
+ uint32 standard_tag = tag;
+ if( fip == NULL ) /* cannot happen since OkToChangeTag() already checks it */
+ return 0;
+ /*
+ * We want to force the custom code to be used for custom
+ * fields even if the tag happens to match a well known
+ * one - important for reinterpreted handling of standard
+ * tag values in custom directories (i.e. EXIF)
+ */
+ if (fip->field_bit == FIELD_CUSTOM) {
+ standard_tag = 0;
+ }
+
+ switch (standard_tag) {
+ case TIFFTAG_SUBFILETYPE:
+ td->td_subfiletype = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_IMAGEWIDTH:
+ td->td_imagewidth = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_IMAGELENGTH:
+ td->td_imagelength = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_BITSPERSAMPLE:
+ td->td_bitspersample = (uint16) va_arg(ap, uint16_vap);
+ /*
+ * If the data require post-decoding processing to byte-swap
+ * samples, set it up here. Note that since tags are required
+ * to be ordered, compression code can override this behaviour
+ * in the setup method if it wants to roll the post decoding
+ * work in with its normal work.
+ */
+ if (tif->tif_flags & TIFF_SWAB) {
+ if (td->td_bitspersample == 8)
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ else if (td->td_bitspersample == 16)
+ tif->tif_postdecode = _TIFFSwab16BitData;
+ else if (td->td_bitspersample == 24)
+ tif->tif_postdecode = _TIFFSwab24BitData;
+ else if (td->td_bitspersample == 32)
+ tif->tif_postdecode = _TIFFSwab32BitData;
+ else if (td->td_bitspersample == 64)
+ tif->tif_postdecode = _TIFFSwab64BitData;
+ else if (td->td_bitspersample == 128) /* two 64's */
+ tif->tif_postdecode = _TIFFSwab64BitData;
+ }
+ break;
+ case TIFFTAG_COMPRESSION:
+ v = (uint16) va_arg(ap, uint16_vap);
+ /*
+ * If we're changing the compression scheme, the notify the
+ * previous module so that it can cleanup any state it's
+ * setup.
+ */
+ if (TIFFFieldSet(tif, FIELD_COMPRESSION)) {
+ if ((uint32)td->td_compression == v)
+ break;
+ (*tif->tif_cleanup)(tif);
+ tif->tif_flags &= ~TIFF_CODERSETUP;
+ }
+ /*
+ * Setup new compression routine state.
+ */
+ if( (status = TIFFSetCompressionScheme(tif, v)) != 0 )
+ td->td_compression = (uint16) v;
+ else
+ status = 0;
+ break;
+ case TIFFTAG_PHOTOMETRIC:
+ td->td_photometric = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_THRESHHOLDING:
+ td->td_threshholding = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_FILLORDER:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v != FILLORDER_LSB2MSB && v != FILLORDER_MSB2LSB)
+ goto badvalue;
+ td->td_fillorder = (uint16) v;
+ break;
+ case TIFFTAG_ORIENTATION:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v < ORIENTATION_TOPLEFT || ORIENTATION_LEFTBOT < v)
+ goto badvalue;
+ else
+ td->td_orientation = (uint16) v;
+ break;
+ case TIFFTAG_SAMPLESPERPIXEL:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v == 0)
+ goto badvalue;
+ if( v != td->td_samplesperpixel )
+ {
+ /* See http://bugzilla.maptools.org/show_bug.cgi?id=2500 */
+ if( td->td_sminsamplevalue != NULL )
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "SamplesPerPixel tag value is changing, "
+ "but SMinSampleValue tag was read with a different value. Cancelling it");
+ TIFFClrFieldBit(tif,FIELD_SMINSAMPLEVALUE);
+ _TIFFfree(td->td_sminsamplevalue);
+ td->td_sminsamplevalue = NULL;
+ }
+ if( td->td_smaxsamplevalue != NULL )
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "SamplesPerPixel tag value is changing, "
+ "but SMaxSampleValue tag was read with a different value. Cancelling it");
+ TIFFClrFieldBit(tif,FIELD_SMAXSAMPLEVALUE);
+ _TIFFfree(td->td_smaxsamplevalue);
+ td->td_smaxsamplevalue = NULL;
+ }
+ }
+ td->td_samplesperpixel = (uint16) v;
+ break;
+ case TIFFTAG_ROWSPERSTRIP:
+ v32 = (uint32) va_arg(ap, uint32);
+ if (v32 == 0)
+ goto badvalue32;
+ td->td_rowsperstrip = v32;
+ if (!TIFFFieldSet(tif, FIELD_TILEDIMENSIONS)) {
+ td->td_tilelength = v32;
+ td->td_tilewidth = td->td_imagewidth;
+ }
+ break;
+ case TIFFTAG_MINSAMPLEVALUE:
+ td->td_minsamplevalue = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_MAXSAMPLEVALUE:
+ td->td_maxsamplevalue = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_SMINSAMPLEVALUE:
+ if (tif->tif_flags & TIFF_PERSAMPLE)
+ _TIFFsetDoubleArray(&td->td_sminsamplevalue, va_arg(ap, double*), td->td_samplesperpixel);
+ else
+ setDoubleArrayOneValue(&td->td_sminsamplevalue, va_arg(ap, double), td->td_samplesperpixel);
+ break;
+ case TIFFTAG_SMAXSAMPLEVALUE:
+ if (tif->tif_flags & TIFF_PERSAMPLE)
+ _TIFFsetDoubleArray(&td->td_smaxsamplevalue, va_arg(ap, double*), td->td_samplesperpixel);
+ else
+ setDoubleArrayOneValue(&td->td_smaxsamplevalue, va_arg(ap, double), td->td_samplesperpixel);
+ break;
+ case TIFFTAG_XRESOLUTION:
+ dblval = va_arg(ap, double);
+ if( dblval < 0 )
+ goto badvaluedouble;
+ td->td_xresolution = TIFFClampDoubleToFloat( dblval );
+ break;
+ case TIFFTAG_YRESOLUTION:
+ dblval = va_arg(ap, double);
+ if( dblval < 0 )
+ goto badvaluedouble;
+ td->td_yresolution = TIFFClampDoubleToFloat( dblval );
+ break;
+ case TIFFTAG_PLANARCONFIG:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v != PLANARCONFIG_CONTIG && v != PLANARCONFIG_SEPARATE)
+ goto badvalue;
+ td->td_planarconfig = (uint16) v;
+ break;
+ case TIFFTAG_XPOSITION:
+ td->td_xposition = TIFFClampDoubleToFloat( va_arg(ap, double) );
+ break;
+ case TIFFTAG_YPOSITION:
+ td->td_yposition = TIFFClampDoubleToFloat( va_arg(ap, double) );
+ break;
+ case TIFFTAG_RESOLUTIONUNIT:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v < RESUNIT_NONE || RESUNIT_CENTIMETER < v)
+ goto badvalue;
+ td->td_resolutionunit = (uint16) v;
+ break;
+ case TIFFTAG_PAGENUMBER:
+ td->td_pagenumber[0] = (uint16) va_arg(ap, uint16_vap);
+ td->td_pagenumber[1] = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_HALFTONEHINTS:
+ td->td_halftonehints[0] = (uint16) va_arg(ap, uint16_vap);
+ td->td_halftonehints[1] = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_COLORMAP:
+ v32 = (uint32)(1L<<td->td_bitspersample);
+ _TIFFsetShortArray(&td->td_colormap[0], va_arg(ap, uint16*), v32);
+ _TIFFsetShortArray(&td->td_colormap[1], va_arg(ap, uint16*), v32);
+ _TIFFsetShortArray(&td->td_colormap[2], va_arg(ap, uint16*), v32);
+ break;
+ case TIFFTAG_EXTRASAMPLES:
+ if (!setExtraSamples(td, ap, &v))
+ goto badvalue;
+ break;
+ case TIFFTAG_MATTEING:
+ td->td_extrasamples = (((uint16) va_arg(ap, uint16_vap)) != 0);
+ if (td->td_extrasamples) {
+ uint16 sv = EXTRASAMPLE_ASSOCALPHA;
+ _TIFFsetShortArray(&td->td_sampleinfo, &sv, 1);
+ }
+ break;
+ case TIFFTAG_TILEWIDTH:
+ v32 = (uint32) va_arg(ap, uint32);
+ if (v32 % 16) {
+ if (tif->tif_mode != O_RDONLY)
+ goto badvalue32;
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "Nonstandard tile width %d, convert file", v32);
+ }
+ td->td_tilewidth = v32;
+ tif->tif_flags |= TIFF_ISTILED;
+ break;
+ case TIFFTAG_TILELENGTH:
+ v32 = (uint32) va_arg(ap, uint32);
+ if (v32 % 16) {
+ if (tif->tif_mode != O_RDONLY)
+ goto badvalue32;
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "Nonstandard tile length %d, convert file", v32);
+ }
+ td->td_tilelength = v32;
+ tif->tif_flags |= TIFF_ISTILED;
+ break;
+ case TIFFTAG_TILEDEPTH:
+ v32 = (uint32) va_arg(ap, uint32);
+ if (v32 == 0)
+ goto badvalue32;
+ td->td_tiledepth = v32;
+ break;
+ case TIFFTAG_DATATYPE:
+ v = (uint16) va_arg(ap, uint16_vap);
+ switch (v) {
+ case DATATYPE_VOID: v = SAMPLEFORMAT_VOID; break;
+ case DATATYPE_INT: v = SAMPLEFORMAT_INT; break;
+ case DATATYPE_UINT: v = SAMPLEFORMAT_UINT; break;
+ case DATATYPE_IEEEFP: v = SAMPLEFORMAT_IEEEFP;break;
+ default: goto badvalue;
+ }
+ td->td_sampleformat = (uint16) v;
+ break;
+ case TIFFTAG_SAMPLEFORMAT:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if (v < SAMPLEFORMAT_UINT || SAMPLEFORMAT_COMPLEXIEEEFP < v)
+ goto badvalue;
+ td->td_sampleformat = (uint16) v;
+
+ /* Try to fix up the SWAB function for complex data. */
+ if( td->td_sampleformat == SAMPLEFORMAT_COMPLEXINT
+ && td->td_bitspersample == 32
+ && tif->tif_postdecode == _TIFFSwab32BitData )
+ tif->tif_postdecode = _TIFFSwab16BitData;
+ else if( (td->td_sampleformat == SAMPLEFORMAT_COMPLEXINT
+ || td->td_sampleformat == SAMPLEFORMAT_COMPLEXIEEEFP)
+ && td->td_bitspersample == 64
+ && tif->tif_postdecode == _TIFFSwab64BitData )
+ tif->tif_postdecode = _TIFFSwab32BitData;
+ break;
+ case TIFFTAG_IMAGEDEPTH:
+ td->td_imagedepth = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_SUBIFD:
+ if ((tif->tif_flags & TIFF_INSUBIFD) == 0) {
+ td->td_nsubifd = (uint16) va_arg(ap, uint16_vap);
+ _TIFFsetLong8Array(&td->td_subifd, (uint64*) va_arg(ap, uint64*),
+ (uint32) td->td_nsubifd);
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Sorry, cannot nest SubIFDs",
+ tif->tif_name);
+ status = 0;
+ }
+ break;
+ case TIFFTAG_YCBCRPOSITIONING:
+ td->td_ycbcrpositioning = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ td->td_ycbcrsubsampling[0] = (uint16) va_arg(ap, uint16_vap);
+ td->td_ycbcrsubsampling[1] = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_TRANSFERFUNCTION:
+ v = (td->td_samplesperpixel - td->td_extrasamples) > 1 ? 3 : 1;
+ for (i = 0; i < v; i++)
+ _TIFFsetShortArray(&td->td_transferfunction[i],
+ va_arg(ap, uint16*), 1U<<td->td_bitspersample);
+ break;
+ case TIFFTAG_REFERENCEBLACKWHITE:
+ /* XXX should check for null range */
+ _TIFFsetFloatArray(&td->td_refblackwhite, va_arg(ap, float*), 6);
+ break;
+ case TIFFTAG_INKNAMES:
+ v = (uint16) va_arg(ap, uint16_vap);
+ s = va_arg(ap, char*);
+ v = checkInkNamesString(tif, v, s);
+ status = v > 0;
+ if( v > 0 ) {
+ _TIFFsetNString(&td->td_inknames, s, v);
+ td->td_inknameslen = v;
+ }
+ break;
+ case TIFFTAG_PERSAMPLE:
+ v = (uint16) va_arg(ap, uint16_vap);
+ if( v == PERSAMPLE_MULTI )
+ tif->tif_flags |= TIFF_PERSAMPLE;
+ else
+ tif->tif_flags &= ~TIFF_PERSAMPLE;
+ break;
+ default: {
+ TIFFTagValue *tv;
+ int tv_size, iCustom;
+
+ /*
+ * This can happen if multiple images are open with different
+ * codecs which have private tags. The global tag information
+ * table may then have tags that are valid for one file but not
+ * the other. If the client tries to set a tag that is not valid
+ * for the image's codec then we'll arrive here. This
+ * happens, for example, when tiffcp is used to convert between
+ * compression schemes and codec-specific tags are blindly copied.
+ */
+ if(fip->field_bit != FIELD_CUSTOM) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Invalid %stag \"%s\" (not supported by codec)",
+ tif->tif_name, isPseudoTag(tag) ? "pseudo-" : "",
+ fip->field_name);
+ status = 0;
+ break;
+ }
+
+ /*
+ * Find the existing entry for this custom value.
+ */
+ tv = NULL;
+ for (iCustom = 0; iCustom < td->td_customValueCount; iCustom++) {
+ if (td->td_customValues[iCustom].info->field_tag == tag) {
+ tv = td->td_customValues + iCustom;
+ if (tv->value != NULL) {
+ _TIFFfree(tv->value);
+ tv->value = NULL;
+ }
+ break;
+ }
+ }
+
+ /*
+ * Grow the custom list if the entry was not found.
+ */
+ if(tv == NULL) {
+ TIFFTagValue *new_customValues;
+
+ td->td_customValueCount++;
+ new_customValues = (TIFFTagValue *)
+ _TIFFrealloc(td->td_customValues,
+ sizeof(TIFFTagValue) * td->td_customValueCount);
+ if (!new_customValues) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Failed to allocate space for list of custom values",
+ tif->tif_name);
+ status = 0;
+ goto end;
+ }
+
+ td->td_customValues = new_customValues;
+
+ tv = td->td_customValues + (td->td_customValueCount - 1);
+ tv->info = fip;
+ tv->value = NULL;
+ tv->count = 0;
+ }
+
+ /*
+ * Set custom value ... save a copy of the custom tag value.
+ */
+ tv_size = _TIFFDataSize(fip->field_type);
+ if (tv_size == 0) {
+ status = 0;
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Bad field type %d for \"%s\"",
+ tif->tif_name, fip->field_type,
+ fip->field_name);
+ goto end;
+ }
+
+ if (fip->field_type == TIFF_ASCII)
+ {
+ uint32 ma;
+ char* mb;
+ if (fip->field_passcount)
+ {
+ assert(fip->field_writecount==TIFF_VARIABLE2);
+ ma=(uint32)va_arg(ap,uint32);
+ mb=(char*)va_arg(ap,char*);
+ }
+ else
+ {
+ mb=(char*)va_arg(ap,char*);
+ ma=(uint32)(strlen(mb)+1);
+ }
+ tv->count=ma;
+ setByteArray(&tv->value,mb,ma,1);
+ }
+ else
+ {
+ if (fip->field_passcount) {
+ if (fip->field_writecount == TIFF_VARIABLE2)
+ tv->count = (uint32) va_arg(ap, uint32);
+ else
+ tv->count = (int) va_arg(ap, int);
+ } else if (fip->field_writecount == TIFF_VARIABLE
+ || fip->field_writecount == TIFF_VARIABLE2)
+ tv->count = 1;
+ else if (fip->field_writecount == TIFF_SPP)
+ tv->count = td->td_samplesperpixel;
+ else
+ tv->count = fip->field_writecount;
+
+ if (tv->count == 0) {
+ status = 0;
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Null count for \"%s\" (type "
+ "%d, writecount %d, passcount %d)",
+ tif->tif_name,
+ fip->field_name,
+ fip->field_type,
+ fip->field_writecount,
+ fip->field_passcount);
+ goto end;
+ }
+
+ tv->value = _TIFFCheckMalloc(tif, tv->count, tv_size,
+ "custom tag binary object");
+ if (!tv->value) {
+ status = 0;
+ goto end;
+ }
+
+ if (fip->field_tag == TIFFTAG_DOTRANGE
+ && strcmp(fip->field_name,"DotRange") == 0) {
+ /* TODO: This is an evil exception and should not have been
+ handled this way ... likely best if we move it into
+ the directory structure with an explicit field in
+ libtiff 4.1 and assign it a FIELD_ value */
+ uint16 v2[2];
+ v2[0] = (uint16)va_arg(ap, int);
+ v2[1] = (uint16)va_arg(ap, int);
+ _TIFFmemcpy(tv->value, &v2, 4);
+ }
+
+ else if (fip->field_passcount
+ || fip->field_writecount == TIFF_VARIABLE
+ || fip->field_writecount == TIFF_VARIABLE2
+ || fip->field_writecount == TIFF_SPP
+ || tv->count > 1) {
+ _TIFFmemcpy(tv->value, va_arg(ap, void *),
+ tv->count * tv_size);
+ } else {
+ char *val = (char *)tv->value;
+ assert( tv->count == 1 );
+
+ switch (fip->field_type) {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ {
+ uint8 v2 = (uint8)va_arg(ap, int);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8 v2 = (int8)va_arg(ap, int);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16 v2 = (uint16)va_arg(ap, int);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16 v2 = (int16)va_arg(ap, int);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_LONG:
+ case TIFF_IFD:
+ {
+ uint32 v2 = va_arg(ap, uint32);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32 v2 = va_arg(ap, int32);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_LONG8:
+ case TIFF_IFD8:
+ {
+ uint64 v2 = va_arg(ap, uint64);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64 v2 = va_arg(ap, int64);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ {
+ float v2 = TIFFClampDoubleToFloat(va_arg(ap, double));
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ case TIFF_DOUBLE:
+ {
+ double v2 = va_arg(ap, double);
+ _TIFFmemcpy(val, &v2, tv_size);
+ }
+ break;
+ default:
+ _TIFFmemset(val, 0, tv_size);
+ status = 0;
+ break;
+ }
+ }
+ }
+ }
+ }
+ if (status) {
+ const TIFFField* fip2=TIFFFieldWithTag(tif,tag);
+ if (fip2)
+ TIFFSetFieldBit(tif, fip2->field_bit);
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+ }
+
+end:
+ va_end(ap);
+ return (status);
+badvalue:
+ {
+ const TIFFField* fip2=TIFFFieldWithTag(tif,tag);
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Bad value %u for \"%s\" tag",
+ tif->tif_name, v,
+ fip2 ? fip2->field_name : "Unknown");
+ va_end(ap);
+ }
+ return (0);
+badvalue32:
+ {
+ const TIFFField* fip2=TIFFFieldWithTag(tif,tag);
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Bad value %u for \"%s\" tag",
+ tif->tif_name, v32,
+ fip2 ? fip2->field_name : "Unknown");
+ va_end(ap);
+ }
+ return (0);
+badvaluedouble:
+ {
+ const TIFFField* fip2=TIFFFieldWithTag(tif,tag);
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Bad value %f for \"%s\" tag",
+ tif->tif_name, dblval,
+ fip2 ? fip2->field_name : "Unknown");
+ va_end(ap);
+ }
+ return (0);
+}
+
+/*
+ * Return 1/0 according to whether or not
+ * it is permissible to set the tag's value.
+ * Note that we allow ImageLength to be changed
+ * so that we can append and extend to images.
+ * Any other tag may not be altered once writing
+ * has commenced, unless its value has no effect
+ * on the format of the data that is written.
+ */
+static int
+OkToChangeTag(TIFF* tif, uint32 tag)
+{
+ const TIFFField* fip = TIFFFindField(tif, tag, TIFF_ANY);
+ if (!fip) { /* unknown tag */
+ TIFFErrorExt(tif->tif_clientdata, "TIFFSetField", "%s: Unknown %stag %u",
+ tif->tif_name, isPseudoTag(tag) ? "pseudo-" : "", tag);
+ return (0);
+ }
+ if (tag != TIFFTAG_IMAGELENGTH && (tif->tif_flags & TIFF_BEENWRITING) &&
+ !fip->field_oktochange) {
+ /*
+ * Consult info table to see if tag can be changed
+ * after we've started writing. We only allow changes
+ * to those tags that don't/shouldn't affect the
+ * compression and/or format of the data.
+ */
+ TIFFErrorExt(tif->tif_clientdata, "TIFFSetField",
+ "%s: Cannot modify tag \"%s\" while writing",
+ tif->tif_name, fip->field_name);
+ return (0);
+ }
+ return (1);
+}
+
+/*
+ * Record the value of a field in the
+ * internal directory structure. The
+ * field will be written to the file
+ * when/if the directory structure is
+ * updated.
+ */
+int
+TIFFSetField(TIFF* tif, uint32 tag, ...)
+{
+ va_list ap;
+ int status;
+
+ va_start(ap, tag);
+ status = TIFFVSetField(tif, tag, ap);
+ va_end(ap);
+ return (status);
+}
+
+/*
+ * Clear the contents of the field in the internal structure.
+ */
+int
+TIFFUnsetField(TIFF* tif, uint32 tag)
+{
+ const TIFFField *fip = TIFFFieldWithTag(tif, tag);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ if( !fip )
+ return 0;
+
+ if( fip->field_bit != FIELD_CUSTOM )
+ TIFFClrFieldBit(tif, fip->field_bit);
+ else
+ {
+ TIFFTagValue *tv = NULL;
+ int i;
+
+ for (i = 0; i < td->td_customValueCount; i++) {
+
+ tv = td->td_customValues + i;
+ if( tv->info->field_tag == tag )
+ break;
+ }
+
+ if( i < td->td_customValueCount )
+ {
+ _TIFFfree(tv->value);
+ for( ; i < td->td_customValueCount-1; i++) {
+ td->td_customValues[i] = td->td_customValues[i+1];
+ }
+ td->td_customValueCount--;
+ }
+ }
+
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+
+ return (1);
+}
+
+/*
+ * Like TIFFSetField, but taking a varargs
+ * parameter list. This routine is useful
+ * for building higher-level interfaces on
+ * top of the library.
+ */
+int
+TIFFVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ return OkToChangeTag(tif, tag) ?
+ (*tif->tif_tagmethods.vsetfield)(tif, tag, ap) : 0;
+}
+
+static int
+_TIFFVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ TIFFDirectory* td = &tif->tif_dir;
+ int ret_val = 1;
+ uint32 standard_tag = tag;
+ const TIFFField* fip = TIFFFindField(tif, tag, TIFF_ANY);
+ if( fip == NULL ) /* cannot happen since TIFFGetField() already checks it */
+ return 0;
+
+ /*
+ * We want to force the custom code to be used for custom
+ * fields even if the tag happens to match a well known
+ * one - important for reinterpreted handling of standard
+ * tag values in custom directories (i.e. EXIF)
+ */
+ if (fip->field_bit == FIELD_CUSTOM) {
+ standard_tag = 0;
+ }
+
+ if( standard_tag == TIFFTAG_NUMBEROFINKS )
+ {
+ int i;
+ for (i = 0; i < td->td_customValueCount; i++) {
+ uint16 val;
+ TIFFTagValue *tv = td->td_customValues + i;
+ if (tv->info->field_tag != standard_tag)
+ continue;
+ if( tv->value == NULL )
+ return 0;
+ val = *(uint16 *)tv->value;
+ /* Truncate to SamplesPerPixel, since the */
+ /* setting code for INKNAMES assume that there are SamplesPerPixel */
+ /* inknames. */
+ /* Fixes http://bugzilla.maptools.org/show_bug.cgi?id=2599 */
+ if( val > td->td_samplesperpixel )
+ {
+ TIFFWarningExt(tif->tif_clientdata,"_TIFFVGetField",
+ "Truncating NumberOfInks from %u to %u",
+ val, td->td_samplesperpixel);
+ val = td->td_samplesperpixel;
+ }
+ *va_arg(ap, uint16*) = val;
+ return 1;
+ }
+ return 0;
+ }
+
+ switch (standard_tag) {
+ case TIFFTAG_SUBFILETYPE:
+ *va_arg(ap, uint32*) = td->td_subfiletype;
+ break;
+ case TIFFTAG_IMAGEWIDTH:
+ *va_arg(ap, uint32*) = td->td_imagewidth;
+ break;
+ case TIFFTAG_IMAGELENGTH:
+ *va_arg(ap, uint32*) = td->td_imagelength;
+ break;
+ case TIFFTAG_BITSPERSAMPLE:
+ *va_arg(ap, uint16*) = td->td_bitspersample;
+ break;
+ case TIFFTAG_COMPRESSION:
+ *va_arg(ap, uint16*) = td->td_compression;
+ break;
+ case TIFFTAG_PHOTOMETRIC:
+ *va_arg(ap, uint16*) = td->td_photometric;
+ break;
+ case TIFFTAG_THRESHHOLDING:
+ *va_arg(ap, uint16*) = td->td_threshholding;
+ break;
+ case TIFFTAG_FILLORDER:
+ *va_arg(ap, uint16*) = td->td_fillorder;
+ break;
+ case TIFFTAG_ORIENTATION:
+ *va_arg(ap, uint16*) = td->td_orientation;
+ break;
+ case TIFFTAG_SAMPLESPERPIXEL:
+ *va_arg(ap, uint16*) = td->td_samplesperpixel;
+ break;
+ case TIFFTAG_ROWSPERSTRIP:
+ *va_arg(ap, uint32*) = td->td_rowsperstrip;
+ break;
+ case TIFFTAG_MINSAMPLEVALUE:
+ *va_arg(ap, uint16*) = td->td_minsamplevalue;
+ break;
+ case TIFFTAG_MAXSAMPLEVALUE:
+ *va_arg(ap, uint16*) = td->td_maxsamplevalue;
+ break;
+ case TIFFTAG_SMINSAMPLEVALUE:
+ if (tif->tif_flags & TIFF_PERSAMPLE)
+ *va_arg(ap, double**) = td->td_sminsamplevalue;
+ else
+ {
+ /* libtiff historically treats this as a single value. */
+ uint16 i;
+ double v = td->td_sminsamplevalue[0];
+ for (i=1; i < td->td_samplesperpixel; ++i)
+ if( td->td_sminsamplevalue[i] < v )
+ v = td->td_sminsamplevalue[i];
+ *va_arg(ap, double*) = v;
+ }
+ break;
+ case TIFFTAG_SMAXSAMPLEVALUE:
+ if (tif->tif_flags & TIFF_PERSAMPLE)
+ *va_arg(ap, double**) = td->td_smaxsamplevalue;
+ else
+ {
+ /* libtiff historically treats this as a single value. */
+ uint16 i;
+ double v = td->td_smaxsamplevalue[0];
+ for (i=1; i < td->td_samplesperpixel; ++i)
+ if( td->td_smaxsamplevalue[i] > v )
+ v = td->td_smaxsamplevalue[i];
+ *va_arg(ap, double*) = v;
+ }
+ break;
+ case TIFFTAG_XRESOLUTION:
+ *va_arg(ap, float*) = td->td_xresolution;
+ break;
+ case TIFFTAG_YRESOLUTION:
+ *va_arg(ap, float*) = td->td_yresolution;
+ break;
+ case TIFFTAG_PLANARCONFIG:
+ *va_arg(ap, uint16*) = td->td_planarconfig;
+ break;
+ case TIFFTAG_XPOSITION:
+ *va_arg(ap, float*) = td->td_xposition;
+ break;
+ case TIFFTAG_YPOSITION:
+ *va_arg(ap, float*) = td->td_yposition;
+ break;
+ case TIFFTAG_RESOLUTIONUNIT:
+ *va_arg(ap, uint16*) = td->td_resolutionunit;
+ break;
+ case TIFFTAG_PAGENUMBER:
+ *va_arg(ap, uint16*) = td->td_pagenumber[0];
+ *va_arg(ap, uint16*) = td->td_pagenumber[1];
+ break;
+ case TIFFTAG_HALFTONEHINTS:
+ *va_arg(ap, uint16*) = td->td_halftonehints[0];
+ *va_arg(ap, uint16*) = td->td_halftonehints[1];
+ break;
+ case TIFFTAG_COLORMAP:
+ *va_arg(ap, uint16**) = td->td_colormap[0];
+ *va_arg(ap, uint16**) = td->td_colormap[1];
+ *va_arg(ap, uint16**) = td->td_colormap[2];
+ break;
+ case TIFFTAG_STRIPOFFSETS:
+ case TIFFTAG_TILEOFFSETS:
+ _TIFFFillStriles( tif );
+ *va_arg(ap, uint64**) = td->td_stripoffset;
+ break;
+ case TIFFTAG_STRIPBYTECOUNTS:
+ case TIFFTAG_TILEBYTECOUNTS:
+ _TIFFFillStriles( tif );
+ *va_arg(ap, uint64**) = td->td_stripbytecount;
+ break;
+ case TIFFTAG_MATTEING:
+ *va_arg(ap, uint16*) =
+ (td->td_extrasamples == 1 &&
+ td->td_sampleinfo[0] == EXTRASAMPLE_ASSOCALPHA);
+ break;
+ case TIFFTAG_EXTRASAMPLES:
+ *va_arg(ap, uint16*) = td->td_extrasamples;
+ *va_arg(ap, uint16**) = td->td_sampleinfo;
+ break;
+ case TIFFTAG_TILEWIDTH:
+ *va_arg(ap, uint32*) = td->td_tilewidth;
+ break;
+ case TIFFTAG_TILELENGTH:
+ *va_arg(ap, uint32*) = td->td_tilelength;
+ break;
+ case TIFFTAG_TILEDEPTH:
+ *va_arg(ap, uint32*) = td->td_tiledepth;
+ break;
+ case TIFFTAG_DATATYPE:
+ switch (td->td_sampleformat) {
+ case SAMPLEFORMAT_UINT:
+ *va_arg(ap, uint16*) = DATATYPE_UINT;
+ break;
+ case SAMPLEFORMAT_INT:
+ *va_arg(ap, uint16*) = DATATYPE_INT;
+ break;
+ case SAMPLEFORMAT_IEEEFP:
+ *va_arg(ap, uint16*) = DATATYPE_IEEEFP;
+ break;
+ case SAMPLEFORMAT_VOID:
+ *va_arg(ap, uint16*) = DATATYPE_VOID;
+ break;
+ }
+ break;
+ case TIFFTAG_SAMPLEFORMAT:
+ *va_arg(ap, uint16*) = td->td_sampleformat;
+ break;
+ case TIFFTAG_IMAGEDEPTH:
+ *va_arg(ap, uint32*) = td->td_imagedepth;
+ break;
+ case TIFFTAG_SUBIFD:
+ *va_arg(ap, uint16*) = td->td_nsubifd;
+ *va_arg(ap, uint64**) = td->td_subifd;
+ break;
+ case TIFFTAG_YCBCRPOSITIONING:
+ *va_arg(ap, uint16*) = td->td_ycbcrpositioning;
+ break;
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ *va_arg(ap, uint16*) = td->td_ycbcrsubsampling[0];
+ *va_arg(ap, uint16*) = td->td_ycbcrsubsampling[1];
+ break;
+ case TIFFTAG_TRANSFERFUNCTION:
+ *va_arg(ap, uint16**) = td->td_transferfunction[0];
+ if (td->td_samplesperpixel - td->td_extrasamples > 1) {
+ *va_arg(ap, uint16**) = td->td_transferfunction[1];
+ *va_arg(ap, uint16**) = td->td_transferfunction[2];
+ } else {
+ *va_arg(ap, uint16**) = NULL;
+ *va_arg(ap, uint16**) = NULL;
+ }
+ break;
+ case TIFFTAG_REFERENCEBLACKWHITE:
+ *va_arg(ap, float**) = td->td_refblackwhite;
+ break;
+ case TIFFTAG_INKNAMES:
+ *va_arg(ap, char**) = td->td_inknames;
+ break;
+ default:
+ {
+ int i;
+
+ /*
+ * This can happen if multiple images are open
+ * with different codecs which have private
+ * tags. The global tag information table may
+ * then have tags that are valid for one file
+ * but not the other. If the client tries to
+ * get a tag that is not valid for the image's
+ * codec then we'll arrive here.
+ */
+ if( fip->field_bit != FIELD_CUSTOM )
+ {
+ TIFFErrorExt(tif->tif_clientdata, "_TIFFVGetField",
+ "%s: Invalid %stag \"%s\" "
+ "(not supported by codec)",
+ tif->tif_name,
+ isPseudoTag(tag) ? "pseudo-" : "",
+ fip->field_name);
+ ret_val = 0;
+ break;
+ }
+
+ /*
+ * Do we have a custom value?
+ */
+ ret_val = 0;
+ for (i = 0; i < td->td_customValueCount; i++) {
+ TIFFTagValue *tv = td->td_customValues + i;
+
+ if (tv->info->field_tag != tag)
+ continue;
+
+ if (fip->field_passcount) {
+ if (fip->field_readcount == TIFF_VARIABLE2)
+ *va_arg(ap, uint32*) = (uint32)tv->count;
+ else /* Assume TIFF_VARIABLE */
+ *va_arg(ap, uint16*) = (uint16)tv->count;
+ *va_arg(ap, void **) = tv->value;
+ ret_val = 1;
+ } else if (fip->field_tag == TIFFTAG_DOTRANGE
+ && strcmp(fip->field_name,"DotRange") == 0) {
+ /* TODO: This is an evil exception and should not have been
+ handled this way ... likely best if we move it into
+ the directory structure with an explicit field in
+ libtiff 4.1 and assign it a FIELD_ value */
+ *va_arg(ap, uint16*) = ((uint16 *)tv->value)[0];
+ *va_arg(ap, uint16*) = ((uint16 *)tv->value)[1];
+ ret_val = 1;
+ } else {
+ if (fip->field_type == TIFF_ASCII
+ || fip->field_readcount == TIFF_VARIABLE
+ || fip->field_readcount == TIFF_VARIABLE2
+ || fip->field_readcount == TIFF_SPP
+ || tv->count > 1) {
+ *va_arg(ap, void **) = tv->value;
+ ret_val = 1;
+ } else {
+ char *val = (char *)tv->value;
+ assert( tv->count == 1 );
+ switch (fip->field_type) {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ *va_arg(ap, uint8*) =
+ *(uint8 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_SBYTE:
+ *va_arg(ap, int8*) =
+ *(int8 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_SHORT:
+ *va_arg(ap, uint16*) =
+ *(uint16 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_SSHORT:
+ *va_arg(ap, int16*) =
+ *(int16 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_LONG:
+ case TIFF_IFD:
+ *va_arg(ap, uint32*) =
+ *(uint32 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_SLONG:
+ *va_arg(ap, int32*) =
+ *(int32 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_LONG8:
+ case TIFF_IFD8:
+ *va_arg(ap, uint64*) =
+ *(uint64 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_SLONG8:
+ *va_arg(ap, int64*) =
+ *(int64 *)val;
+ ret_val = 1;
+ break;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ *va_arg(ap, float*) =
+ *(float *)val;
+ ret_val = 1;
+ break;
+ case TIFF_DOUBLE:
+ *va_arg(ap, double*) =
+ *(double *)val;
+ ret_val = 1;
+ break;
+ default:
+ ret_val = 0;
+ break;
+ }
+ }
+ }
+ break;
+ }
+ }
+ }
+ return(ret_val);
+}
+
+/*
+ * Return the value of a field in the
+ * internal directory structure.
+ */
+int
+TIFFGetField(TIFF* tif, uint32 tag, ...)
+{
+ int status;
+ va_list ap;
+
+ va_start(ap, tag);
+ status = TIFFVGetField(tif, tag, ap);
+ va_end(ap);
+ return (status);
+}
+
+/*
+ * Like TIFFGetField, but taking a varargs
+ * parameter list. This routine is useful
+ * for building higher-level interfaces on
+ * top of the library.
+ */
+int
+TIFFVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ const TIFFField* fip = TIFFFindField(tif, tag, TIFF_ANY);
+ return (fip && (isPseudoTag(tag) || TIFFFieldSet(tif, fip->field_bit)) ?
+ (*tif->tif_tagmethods.vgetfield)(tif, tag, ap) : 0);
+}
+
+#define CleanupField(member) { \
+ if (td->member) { \
+ _TIFFfree(td->member); \
+ td->member = 0; \
+ } \
+}
+
+/*
+ * Release storage associated with a directory.
+ */
+void
+TIFFFreeDirectory(TIFF* tif)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ int i;
+
+ _TIFFmemset(td->td_fieldsset, 0, FIELD_SETLONGS);
+ CleanupField(td_sminsamplevalue);
+ CleanupField(td_smaxsamplevalue);
+ CleanupField(td_colormap[0]);
+ CleanupField(td_colormap[1]);
+ CleanupField(td_colormap[2]);
+ CleanupField(td_sampleinfo);
+ CleanupField(td_subifd);
+ CleanupField(td_inknames);
+ CleanupField(td_refblackwhite);
+ CleanupField(td_transferfunction[0]);
+ CleanupField(td_transferfunction[1]);
+ CleanupField(td_transferfunction[2]);
+ CleanupField(td_stripoffset);
+ CleanupField(td_stripbytecount);
+ TIFFClrFieldBit(tif, FIELD_YCBCRSUBSAMPLING);
+ TIFFClrFieldBit(tif, FIELD_YCBCRPOSITIONING);
+
+ /* Cleanup custom tag values */
+ for( i = 0; i < td->td_customValueCount; i++ ) {
+ if (td->td_customValues[i].value)
+ _TIFFfree(td->td_customValues[i].value);
+ }
+
+ td->td_customValueCount = 0;
+ CleanupField(td_customValues);
+
+#if defined(DEFER_STRILE_LOAD)
+ _TIFFmemset( &(td->td_stripoffset_entry), 0, sizeof(TIFFDirEntry));
+ _TIFFmemset( &(td->td_stripbytecount_entry), 0, sizeof(TIFFDirEntry));
+#endif
+}
+#undef CleanupField
+
+/*
+ * Client Tag extension support (from Niles Ritter).
+ */
+static TIFFExtendProc _TIFFextender = (TIFFExtendProc) NULL;
+
+TIFFExtendProc
+TIFFSetTagExtender(TIFFExtendProc extender)
+{
+ TIFFExtendProc prev = _TIFFextender;
+ _TIFFextender = extender;
+ return (prev);
+}
+
+/*
+ * Setup for a new directory. Should we automatically call
+ * TIFFWriteDirectory() if the current one is dirty?
+ *
+ * The newly created directory will not exist on the file till
+ * TIFFWriteDirectory(), TIFFFlush() or TIFFClose() is called.
+ */
+int
+TIFFCreateDirectory(TIFF* tif)
+{
+ TIFFDefaultDirectory(tif);
+ tif->tif_diroff = 0;
+ tif->tif_nextdiroff = 0;
+ tif->tif_curoff = 0;
+ tif->tif_row = (uint32) -1;
+ tif->tif_curstrip = (uint32) -1;
+
+ return 0;
+}
+
+int
+TIFFCreateCustomDirectory(TIFF* tif, const TIFFFieldArray* infoarray)
+{
+ TIFFDefaultDirectory(tif);
+
+ /*
+ * Reset the field definitions to match the application provided list.
+ * Hopefully TIFFDefaultDirectory() won't have done anything irreversable
+ * based on it's assumption this is an image directory.
+ */
+ _TIFFSetupFields(tif, infoarray);
+
+ tif->tif_diroff = 0;
+ tif->tif_nextdiroff = 0;
+ tif->tif_curoff = 0;
+ tif->tif_row = (uint32) -1;
+ tif->tif_curstrip = (uint32) -1;
+
+ return 0;
+}
+
+int
+TIFFCreateEXIFDirectory(TIFF* tif)
+{
+ const TIFFFieldArray* exifFieldArray;
+ exifFieldArray = _TIFFGetExifFields();
+ return TIFFCreateCustomDirectory(tif, exifFieldArray);
+}
+
+/*
+ * Setup a default directory structure.
+ */
+int
+TIFFDefaultDirectory(TIFF* tif)
+{
+ register TIFFDirectory* td = &tif->tif_dir;
+ const TIFFFieldArray* tiffFieldArray;
+
+ tiffFieldArray = _TIFFGetFields();
+ _TIFFSetupFields(tif, tiffFieldArray);
+
+ _TIFFmemset(td, 0, sizeof (*td));
+ td->td_fillorder = FILLORDER_MSB2LSB;
+ td->td_bitspersample = 1;
+ td->td_threshholding = THRESHHOLD_BILEVEL;
+ td->td_orientation = ORIENTATION_TOPLEFT;
+ td->td_samplesperpixel = 1;
+ td->td_rowsperstrip = (uint32) -1;
+ td->td_tilewidth = 0;
+ td->td_tilelength = 0;
+ td->td_tiledepth = 1;
+ td->td_stripbytecountsorted = 1; /* Our own arrays always sorted. */
+ td->td_resolutionunit = RESUNIT_INCH;
+ td->td_sampleformat = SAMPLEFORMAT_UINT;
+ td->td_imagedepth = 1;
+ td->td_ycbcrsubsampling[0] = 2;
+ td->td_ycbcrsubsampling[1] = 2;
+ td->td_ycbcrpositioning = YCBCRPOSITION_CENTERED;
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ tif->tif_foundfield = NULL;
+ tif->tif_tagmethods.vsetfield = _TIFFVSetField;
+ tif->tif_tagmethods.vgetfield = _TIFFVGetField;
+ tif->tif_tagmethods.printdir = NULL;
+ /*
+ * Give client code a chance to install their own
+ * tag extensions & methods, prior to compression overloads,
+ * but do some prior cleanup first. (http://trac.osgeo.org/gdal/ticket/5054)
+ */
+ if (tif->tif_nfieldscompat > 0) {
+ uint32 i;
+
+ for (i = 0; i < tif->tif_nfieldscompat; i++) {
+ if (tif->tif_fieldscompat[i].allocated_size)
+ _TIFFfree(tif->tif_fieldscompat[i].fields);
+ }
+ _TIFFfree(tif->tif_fieldscompat);
+ tif->tif_nfieldscompat = 0;
+ tif->tif_fieldscompat = NULL;
+ }
+ if (_TIFFextender)
+ (*_TIFFextender)(tif);
+ (void) TIFFSetField(tif, TIFFTAG_COMPRESSION, COMPRESSION_NONE);
+ /*
+ * NB: The directory is marked dirty as a result of setting
+ * up the default compression scheme. However, this really
+ * isn't correct -- we want TIFF_DIRTYDIRECT to be set only
+ * if the user does something. We could just do the setup
+ * by hand, but it seems better to use the normal mechanism
+ * (i.e. TIFFSetField).
+ */
+ tif->tif_flags &= ~TIFF_DIRTYDIRECT;
+
+ /*
+ * As per http://bugzilla.remotesensing.org/show_bug.cgi?id=19
+ * we clear the ISTILED flag when setting up a new directory.
+ * Should we also be clearing stuff like INSUBIFD?
+ */
+ tif->tif_flags &= ~TIFF_ISTILED;
+
+ return (1);
+}
+
+static int
+TIFFAdvanceDirectory(TIFF* tif, uint64* nextdir, uint64* off)
+{
+ static const char module[] = "TIFFAdvanceDirectory";
+ if (isMapped(tif))
+ {
+ uint64 poff=*nextdir;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ tmsize_t poffa,poffb,poffc,poffd;
+ uint16 dircount;
+ uint32 nextdir32;
+ poffa=(tmsize_t)poff;
+ poffb=poffa+sizeof(uint16);
+ if (((uint64)poffa!=poff)||(poffb<poffa)||(poffb<(tmsize_t)sizeof(uint16))||(poffb>tif->tif_size))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Error fetching directory count");
+ *nextdir=0;
+ return(0);
+ }
+ _TIFFmemcpy(&dircount,tif->tif_base+poffa,sizeof(uint16));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(&dircount);
+ poffc=poffb+dircount*12;
+ poffd=poffc+sizeof(uint32);
+ if ((poffc<poffb)||(poffc<dircount*12)||(poffd<poffc)||(poffd<(tmsize_t)sizeof(uint32))||(poffd>tif->tif_size))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Error fetching directory link");
+ return(0);
+ }
+ if (off!=NULL)
+ *off=(uint64)poffc;
+ _TIFFmemcpy(&nextdir32,tif->tif_base+poffc,sizeof(uint32));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&nextdir32);
+ *nextdir=nextdir32;
+ }
+ else
+ {
+ tmsize_t poffa,poffb,poffc,poffd;
+ uint64 dircount64;
+ uint16 dircount16;
+ poffa=(tmsize_t)poff;
+ poffb=poffa+sizeof(uint64);
+ if (((uint64)poffa!=poff)||(poffb<poffa)||(poffb<(tmsize_t)sizeof(uint64))||(poffb>tif->tif_size))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Error fetching directory count");
+ return(0);
+ }
+ _TIFFmemcpy(&dircount64,tif->tif_base+poffa,sizeof(uint64));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>0xFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Sanity check on directory count failed");
+ return(0);
+ }
+ dircount16=(uint16)dircount64;
+ poffc=poffb+dircount16*20;
+ poffd=poffc+sizeof(uint64);
+ if ((poffc<poffb)||(poffc<dircount16*20)||(poffd<poffc)||(poffd<(tmsize_t)sizeof(uint64))||(poffd>tif->tif_size))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Error fetching directory link");
+ return(0);
+ }
+ if (off!=NULL)
+ *off=(uint64)poffc;
+ _TIFFmemcpy(nextdir,tif->tif_base+poffc,sizeof(uint64));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(nextdir);
+ }
+ return(1);
+ }
+ else
+ {
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint16 dircount;
+ uint32 nextdir32;
+ if (!SeekOK(tif, *nextdir) ||
+ !ReadOK(tif, &dircount, sizeof (uint16))) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s: Error fetching directory count",
+ tif->tif_name);
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount);
+ if (off != NULL)
+ *off = TIFFSeekFile(tif,
+ dircount*12, SEEK_CUR);
+ else
+ (void) TIFFSeekFile(tif,
+ dircount*12, SEEK_CUR);
+ if (!ReadOK(tif, &nextdir32, sizeof (uint32))) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s: Error fetching directory link",
+ tif->tif_name);
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&nextdir32);
+ *nextdir=nextdir32;
+ }
+ else
+ {
+ uint64 dircount64;
+ uint16 dircount16;
+ if (!SeekOK(tif, *nextdir) ||
+ !ReadOK(tif, &dircount64, sizeof (uint64))) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s: Error fetching directory count",
+ tif->tif_name);
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>0xFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Error fetching directory count");
+ return(0);
+ }
+ dircount16 = (uint16)dircount64;
+ if (off != NULL)
+ *off = TIFFSeekFile(tif,
+ dircount16*20, SEEK_CUR);
+ else
+ (void) TIFFSeekFile(tif,
+ dircount16*20, SEEK_CUR);
+ if (!ReadOK(tif, nextdir, sizeof (uint64))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Error fetching directory link",
+ tif->tif_name);
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(nextdir);
+ }
+ return (1);
+ }
+}
+
+/*
+ * Count the number of directories in a file.
+ */
+uint16
+TIFFNumberOfDirectories(TIFF* tif)
+{
+ static const char module[] = "TIFFNumberOfDirectories";
+ uint64 nextdir;
+ uint16 n;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ nextdir = tif->tif_header.classic.tiff_diroff;
+ else
+ nextdir = tif->tif_header.big.tiff_diroff;
+ n = 0;
+ while (nextdir != 0 && TIFFAdvanceDirectory(tif, &nextdir, NULL))
+ {
+ if (n != 65535) {
+ ++n;
+ }
+ else
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Directory count exceeded 65535 limit,"
+ " giving up on counting.");
+ return (65535);
+ }
+ }
+ return (n);
+}
+
+/*
+ * Set the n-th directory as the current directory.
+ * NB: Directories are numbered starting at 0.
+ */
+int
+TIFFSetDirectory(TIFF* tif, uint16 dirn)
+{
+ uint64 nextdir;
+ uint16 n;
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ nextdir = tif->tif_header.classic.tiff_diroff;
+ else
+ nextdir = tif->tif_header.big.tiff_diroff;
+ for (n = dirn; n > 0 && nextdir != 0; n--)
+ if (!TIFFAdvanceDirectory(tif, &nextdir, NULL))
+ return (0);
+ tif->tif_nextdiroff = nextdir;
+ /*
+ * Set curdir to the actual directory index. The
+ * -1 is because TIFFReadDirectory will increment
+ * tif_curdir after successfully reading the directory.
+ */
+ tif->tif_curdir = (dirn - n) - 1;
+ /*
+ * Reset tif_dirnumber counter and start new list of seen directories.
+ * We need this to prevent IFD loops.
+ */
+ tif->tif_dirnumber = 0;
+ return (TIFFReadDirectory(tif));
+}
+
+/*
+ * Set the current directory to be the directory
+ * located at the specified file offset. This interface
+ * is used mainly to access directories linked with
+ * the SubIFD tag (e.g. thumbnail images).
+ */
+int
+TIFFSetSubDirectory(TIFF* tif, uint64 diroff)
+{
+ tif->tif_nextdiroff = diroff;
+ /*
+ * Reset tif_dirnumber counter and start new list of seen directories.
+ * We need this to prevent IFD loops.
+ */
+ tif->tif_dirnumber = 0;
+ return (TIFFReadDirectory(tif));
+}
+
+/*
+ * Return file offset of the current directory.
+ */
+uint64
+TIFFCurrentDirOffset(TIFF* tif)
+{
+ return (tif->tif_diroff);
+}
+
+/*
+ * Return an indication of whether or not we are
+ * at the last directory in the file.
+ */
+int
+TIFFLastDirectory(TIFF* tif)
+{
+ return (tif->tif_nextdiroff == 0);
+}
+
+/*
+ * Unlink the specified directory from the directory chain.
+ */
+int
+TIFFUnlinkDirectory(TIFF* tif, uint16 dirn)
+{
+ static const char module[] = "TIFFUnlinkDirectory";
+ uint64 nextdir;
+ uint64 off;
+ uint16 n;
+
+ if (tif->tif_mode == O_RDONLY) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not unlink directory in read-only file");
+ return (0);
+ }
+ /*
+ * Go to the directory before the one we want
+ * to unlink and nab the offset of the link
+ * field we'll need to patch.
+ */
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ nextdir = tif->tif_header.classic.tiff_diroff;
+ off = 4;
+ }
+ else
+ {
+ nextdir = tif->tif_header.big.tiff_diroff;
+ off = 8;
+ }
+ for (n = dirn-1; n > 0; n--) {
+ if (nextdir == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Directory %d does not exist", dirn);
+ return (0);
+ }
+ if (!TIFFAdvanceDirectory(tif, &nextdir, &off))
+ return (0);
+ }
+ /*
+ * Advance to the directory to be unlinked and fetch
+ * the offset of the directory that follows.
+ */
+ if (!TIFFAdvanceDirectory(tif, &nextdir, NULL))
+ return (0);
+ /*
+ * Go back and patch the link field of the preceding
+ * directory to point to the offset of the directory
+ * that follows.
+ */
+ (void) TIFFSeekFile(tif, off, SEEK_SET);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 nextdir32;
+ nextdir32=(uint32)nextdir;
+ assert((uint64)nextdir32==nextdir);
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&nextdir32);
+ if (!WriteOK(tif, &nextdir32, sizeof (uint32))) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Error writing directory link");
+ return (0);
+ }
+ }
+ else
+ {
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&nextdir);
+ if (!WriteOK(tif, &nextdir, sizeof (uint64))) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Error writing directory link");
+ return (0);
+ }
+ }
+ /*
+ * Leave directory state setup safely. We don't have
+ * facilities for doing inserting and removing directories,
+ * so it's safest to just invalidate everything. This
+ * means that the caller can only append to the directory
+ * chain.
+ */
+ (*tif->tif_cleanup)(tif);
+ if ((tif->tif_flags & TIFF_MYBUFFER) && tif->tif_rawdata) {
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = NULL;
+ tif->tif_rawcc = 0;
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = 0;
+ }
+ tif->tif_flags &= ~(TIFF_BEENWRITING|TIFF_BUFFERSETUP|TIFF_POSTENCODE|TIFF_BUF4WRITE);
+ TIFFFreeDirectory(tif);
+ TIFFDefaultDirectory(tif);
+ tif->tif_diroff = 0; /* force link on next write */
+ tif->tif_nextdiroff = 0; /* next write must be at end */
+ tif->tif_curoff = 0;
+ tif->tif_row = (uint32) -1;
+ tif->tif_curstrip = (uint32) -1;
+ return (1);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dir.h b/test/monniaux/tiff-4.0.10/tif_dir.h
new file mode 100644
index 00000000..b2f5e694
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dir.h
@@ -0,0 +1,311 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _TIFFDIR_
+#define _TIFFDIR_
+
+#include "tiff.h"
+#include "tiffio.h"
+
+/*
+ * ``Library-private'' Directory-related Definitions.
+ */
+
+typedef struct {
+ const TIFFField *info;
+ int count;
+ void *value;
+} TIFFTagValue;
+
+/*
+ * TIFF Image File Directories are comprised of a table of field
+ * descriptors of the form shown below. The table is sorted in
+ * ascending order by tag. The values associated with each entry are
+ * disjoint and may appear anywhere in the file (so long as they are
+ * placed on a word boundary).
+ *
+ * If the value is 4 bytes or less, in ClassicTIFF, or 8 bytes or less in
+ * BigTIFF, then it is placed in the offset field to save space. If so,
+ * it is left-justified in the offset field.
+ */
+typedef struct {
+ uint16 tdir_tag; /* see below */
+ uint16 tdir_type; /* data type; see below */
+ uint64 tdir_count; /* number of items; length in spec */
+ union {
+ uint16 toff_short;
+ uint32 toff_long;
+ uint64 toff_long8;
+ } tdir_offset; /* either offset or the data itself if fits */
+} TIFFDirEntry;
+
+/*
+ * Internal format of a TIFF directory entry.
+ */
+typedef struct {
+#define FIELD_SETLONGS 4
+ /* bit vector of fields that are set */
+ unsigned long td_fieldsset[FIELD_SETLONGS];
+
+ uint32 td_imagewidth, td_imagelength, td_imagedepth;
+ uint32 td_tilewidth, td_tilelength, td_tiledepth;
+ uint32 td_subfiletype;
+ uint16 td_bitspersample;
+ uint16 td_sampleformat;
+ uint16 td_compression;
+ uint16 td_photometric;
+ uint16 td_threshholding;
+ uint16 td_fillorder;
+ uint16 td_orientation;
+ uint16 td_samplesperpixel;
+ uint32 td_rowsperstrip;
+ uint16 td_minsamplevalue, td_maxsamplevalue;
+ double* td_sminsamplevalue;
+ double* td_smaxsamplevalue;
+ float td_xresolution, td_yresolution;
+ uint16 td_resolutionunit;
+ uint16 td_planarconfig;
+ float td_xposition, td_yposition;
+ uint16 td_pagenumber[2];
+ uint16* td_colormap[3];
+ uint16 td_halftonehints[2];
+ uint16 td_extrasamples;
+ uint16* td_sampleinfo;
+ /* even though the name is misleading, td_stripsperimage is the number
+ * of striles (=strips or tiles) per plane, and td_nstrips the total
+ * number of striles */
+ uint32 td_stripsperimage;
+ uint32 td_nstrips; /* size of offset & bytecount arrays */
+ uint64* td_stripoffset;
+ uint64* td_stripbytecount;
+ int td_stripbytecountsorted; /* is the bytecount array sorted ascending? */
+#if defined(DEFER_STRILE_LOAD)
+ TIFFDirEntry td_stripoffset_entry; /* for deferred loading */
+ TIFFDirEntry td_stripbytecount_entry; /* for deferred loading */
+#endif
+ uint16 td_nsubifd;
+ uint64* td_subifd;
+ /* YCbCr parameters */
+ uint16 td_ycbcrsubsampling[2];
+ uint16 td_ycbcrpositioning;
+ /* Colorimetry parameters */
+ uint16* td_transferfunction[3];
+ float* td_refblackwhite;
+ /* CMYK parameters */
+ int td_inknameslen;
+ char* td_inknames;
+
+ int td_customValueCount;
+ TIFFTagValue *td_customValues;
+} TIFFDirectory;
+
+/*
+ * Field flags used to indicate fields that have been set in a directory, and
+ * to reference fields when manipulating a directory.
+ */
+
+/*
+ * FIELD_IGNORE is used to signify tags that are to be processed but otherwise
+ * ignored. This permits antiquated tags to be quietly read and discarded.
+ * Note that a bit *is* allocated for ignored tags; this is understood by the
+ * directory reading logic which uses this fact to avoid special-case handling
+ */
+#define FIELD_IGNORE 0
+
+/* multi-item fields */
+#define FIELD_IMAGEDIMENSIONS 1
+#define FIELD_TILEDIMENSIONS 2
+#define FIELD_RESOLUTION 3
+#define FIELD_POSITION 4
+
+/* single-item fields */
+#define FIELD_SUBFILETYPE 5
+#define FIELD_BITSPERSAMPLE 6
+#define FIELD_COMPRESSION 7
+#define FIELD_PHOTOMETRIC 8
+#define FIELD_THRESHHOLDING 9
+#define FIELD_FILLORDER 10
+#define FIELD_ORIENTATION 15
+#define FIELD_SAMPLESPERPIXEL 16
+#define FIELD_ROWSPERSTRIP 17
+#define FIELD_MINSAMPLEVALUE 18
+#define FIELD_MAXSAMPLEVALUE 19
+#define FIELD_PLANARCONFIG 20
+#define FIELD_RESOLUTIONUNIT 22
+#define FIELD_PAGENUMBER 23
+#define FIELD_STRIPBYTECOUNTS 24
+#define FIELD_STRIPOFFSETS 25
+#define FIELD_COLORMAP 26
+#define FIELD_EXTRASAMPLES 31
+#define FIELD_SAMPLEFORMAT 32
+#define FIELD_SMINSAMPLEVALUE 33
+#define FIELD_SMAXSAMPLEVALUE 34
+#define FIELD_IMAGEDEPTH 35
+#define FIELD_TILEDEPTH 36
+#define FIELD_HALFTONEHINTS 37
+#define FIELD_YCBCRSUBSAMPLING 39
+#define FIELD_YCBCRPOSITIONING 40
+#define FIELD_REFBLACKWHITE 41
+#define FIELD_TRANSFERFUNCTION 44
+#define FIELD_INKNAMES 46
+#define FIELD_SUBIFD 49
+/* FIELD_CUSTOM (see tiffio.h) 65 */
+/* end of support for well-known tags; codec-private tags follow */
+#define FIELD_CODEC 66 /* base of codec-private tags */
+
+
+/*
+ * Pseudo-tags don't normally need field bits since they are not written to an
+ * output file (by definition). The library also has express logic to always
+ * query a codec for a pseudo-tag so allocating a field bit for one is a
+ * waste. If codec wants to promote the notion of a pseudo-tag being ``set''
+ * or ``unset'' then it can do using internal state flags without polluting
+ * the field bit space defined for real tags.
+ */
+#define FIELD_PSEUDO 0
+
+#define FIELD_LAST (32*FIELD_SETLONGS-1)
+
+#define BITn(n) (((unsigned long)1L)<<((n)&0x1f))
+#define BITFIELDn(tif, n) ((tif)->tif_dir.td_fieldsset[(n)/32])
+#define TIFFFieldSet(tif, field) (BITFIELDn(tif, field) & BITn(field))
+#define TIFFSetFieldBit(tif, field) (BITFIELDn(tif, field) |= BITn(field))
+#define TIFFClrFieldBit(tif, field) (BITFIELDn(tif, field) &= ~BITn(field))
+
+#define FieldSet(fields, f) (fields[(f)/32] & BITn(f))
+#define ResetFieldBit(fields, f) (fields[(f)/32] &= ~BITn(f))
+
+typedef enum {
+ TIFF_SETGET_UNDEFINED = 0,
+ TIFF_SETGET_ASCII = 1,
+ TIFF_SETGET_UINT8 = 2,
+ TIFF_SETGET_SINT8 = 3,
+ TIFF_SETGET_UINT16 = 4,
+ TIFF_SETGET_SINT16 = 5,
+ TIFF_SETGET_UINT32 = 6,
+ TIFF_SETGET_SINT32 = 7,
+ TIFF_SETGET_UINT64 = 8,
+ TIFF_SETGET_SINT64 = 9,
+ TIFF_SETGET_FLOAT = 10,
+ TIFF_SETGET_DOUBLE = 11,
+ TIFF_SETGET_IFD8 = 12,
+ TIFF_SETGET_INT = 13,
+ TIFF_SETGET_UINT16_PAIR = 14,
+ TIFF_SETGET_C0_ASCII = 15,
+ TIFF_SETGET_C0_UINT8 = 16,
+ TIFF_SETGET_C0_SINT8 = 17,
+ TIFF_SETGET_C0_UINT16 = 18,
+ TIFF_SETGET_C0_SINT16 = 19,
+ TIFF_SETGET_C0_UINT32 = 20,
+ TIFF_SETGET_C0_SINT32 = 21,
+ TIFF_SETGET_C0_UINT64 = 22,
+ TIFF_SETGET_C0_SINT64 = 23,
+ TIFF_SETGET_C0_FLOAT = 24,
+ TIFF_SETGET_C0_DOUBLE = 25,
+ TIFF_SETGET_C0_IFD8 = 26,
+ TIFF_SETGET_C16_ASCII = 27,
+ TIFF_SETGET_C16_UINT8 = 28,
+ TIFF_SETGET_C16_SINT8 = 29,
+ TIFF_SETGET_C16_UINT16 = 30,
+ TIFF_SETGET_C16_SINT16 = 31,
+ TIFF_SETGET_C16_UINT32 = 32,
+ TIFF_SETGET_C16_SINT32 = 33,
+ TIFF_SETGET_C16_UINT64 = 34,
+ TIFF_SETGET_C16_SINT64 = 35,
+ TIFF_SETGET_C16_FLOAT = 36,
+ TIFF_SETGET_C16_DOUBLE = 37,
+ TIFF_SETGET_C16_IFD8 = 38,
+ TIFF_SETGET_C32_ASCII = 39,
+ TIFF_SETGET_C32_UINT8 = 40,
+ TIFF_SETGET_C32_SINT8 = 41,
+ TIFF_SETGET_C32_UINT16 = 42,
+ TIFF_SETGET_C32_SINT16 = 43,
+ TIFF_SETGET_C32_UINT32 = 44,
+ TIFF_SETGET_C32_SINT32 = 45,
+ TIFF_SETGET_C32_UINT64 = 46,
+ TIFF_SETGET_C32_SINT64 = 47,
+ TIFF_SETGET_C32_FLOAT = 48,
+ TIFF_SETGET_C32_DOUBLE = 49,
+ TIFF_SETGET_C32_IFD8 = 50,
+ TIFF_SETGET_OTHER = 51
+} TIFFSetGetFieldType;
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+extern const TIFFFieldArray* _TIFFGetFields(void);
+extern const TIFFFieldArray* _TIFFGetExifFields(void);
+extern void _TIFFSetupFields(TIFF* tif, const TIFFFieldArray* infoarray);
+extern void _TIFFPrintFieldInfo(TIFF*, FILE*);
+
+extern int _TIFFFillStriles(TIFF*);
+
+typedef enum {
+ tfiatImage,
+ tfiatExif,
+ tfiatOther
+} TIFFFieldArrayType;
+
+struct _TIFFFieldArray {
+ TIFFFieldArrayType type; /* array type, will be used to determine if IFD is image and such */
+ uint32 allocated_size; /* 0 if array is constant, other if modified by future definition extension support */
+ uint32 count; /* number of elements in fields array */
+ TIFFField* fields; /* actual field info */
+};
+
+struct _TIFFField {
+ uint32 field_tag; /* field's tag */
+ short field_readcount; /* read count/TIFF_VARIABLE/TIFF_SPP */
+ short field_writecount; /* write count/TIFF_VARIABLE */
+ TIFFDataType field_type; /* type of associated data */
+ uint32 reserved; /* reserved for future extension */
+ TIFFSetGetFieldType set_field_type; /* type to be passed to TIFFSetField */
+ TIFFSetGetFieldType get_field_type; /* type to be passed to TIFFGetField */
+ unsigned short field_bit; /* bit in fieldsset bit vector */
+ unsigned char field_oktochange; /* if true, can change while writing */
+ unsigned char field_passcount; /* if true, pass dir count on set */
+ char* field_name; /* ASCII name */
+ TIFFFieldArray* field_subfields; /* if field points to child ifds, child ifd field definition array */
+};
+
+extern int _TIFFMergeFields(TIFF*, const TIFFField[], uint32);
+extern const TIFFField* _TIFFFindOrRegisterField(TIFF *, uint32, TIFFDataType);
+extern TIFFField* _TIFFCreateAnonField(TIFF *, uint32, TIFFDataType);
+extern int _TIFFCheckFieldIsValidForCodec(TIFF *tif, ttag_t tag);
+
+#if defined(__cplusplus)
+}
+#endif
+#endif /* _TIFFDIR_ */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dirinfo.c b/test/monniaux/tiff-4.0.10/tif_dirinfo.c
new file mode 100644
index 00000000..e1f6b23e
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dirinfo.c
@@ -0,0 +1,1081 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Core Directory Tag Support.
+ */
+#include "tiffiop.h"
+#include <stdlib.h>
+
+/*
+ * NOTE: THIS ARRAY IS ASSUMED TO BE SORTED BY TAG.
+ *
+ * NOTE: The second field (field_readcount) and third field (field_writecount)
+ * sometimes use the values TIFF_VARIABLE (-1), TIFF_VARIABLE2 (-3)
+ * and TIFF_SPP (-2). The macros should be used but would throw off
+ * the formatting of the code, so please interpret the -1, -2 and -3
+ * values accordingly.
+ */
+
+/* const object should be initialized */
+#ifdef _MSC_VER
+#pragma warning( push )
+#pragma warning( disable : 4132 )
+#endif
+static const TIFFFieldArray tiffFieldArray;
+static const TIFFFieldArray exifFieldArray;
+#ifdef _MSC_VER
+#pragma warning( pop )
+#endif
+
+static const TIFFField
+tiffFields[] = {
+ { TIFFTAG_SUBFILETYPE, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_SUBFILETYPE, 1, 0, "SubfileType", NULL },
+ { TIFFTAG_OSUBFILETYPE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_SUBFILETYPE, 1, 0, "OldSubfileType", NULL },
+ { TIFFTAG_IMAGEWIDTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_IMAGEDIMENSIONS, 0, 0, "ImageWidth", NULL },
+ { TIFFTAG_IMAGELENGTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_IMAGEDIMENSIONS, 1, 0, "ImageLength", NULL },
+ { TIFFTAG_BITSPERSAMPLE, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_BITSPERSAMPLE, 0, 0, "BitsPerSample", NULL },
+ { TIFFTAG_COMPRESSION, -1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_COMPRESSION, 0, 0, "Compression", NULL },
+ { TIFFTAG_PHOTOMETRIC, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_PHOTOMETRIC, 0, 0, "PhotometricInterpretation", NULL },
+ { TIFFTAG_THRESHHOLDING, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_THRESHHOLDING, 1, 0, "Threshholding", NULL },
+ { TIFFTAG_CELLWIDTH, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 1, 0, "CellWidth", NULL },
+ { TIFFTAG_CELLLENGTH, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 1, 0, "CellLength", NULL },
+ { TIFFTAG_FILLORDER, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_FILLORDER, 0, 0, "FillOrder", NULL },
+ { TIFFTAG_DOCUMENTNAME, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "DocumentName", NULL },
+ { TIFFTAG_IMAGEDESCRIPTION, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ImageDescription", NULL },
+ { TIFFTAG_MAKE, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Make", NULL },
+ { TIFFTAG_MODEL, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Model", NULL },
+ { TIFFTAG_STRIPOFFSETS, -1, -1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_STRIPOFFSETS, 0, 0, "StripOffsets", NULL },
+ { TIFFTAG_ORIENTATION, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_ORIENTATION, 0, 0, "Orientation", NULL },
+ { TIFFTAG_SAMPLESPERPIXEL, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_SAMPLESPERPIXEL, 0, 0, "SamplesPerPixel", NULL },
+ { TIFFTAG_ROWSPERSTRIP, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_ROWSPERSTRIP, 0, 0, "RowsPerStrip", NULL },
+ { TIFFTAG_STRIPBYTECOUNTS, -1, -1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_STRIPBYTECOUNTS, 0, 0, "StripByteCounts", NULL },
+ { TIFFTAG_MINSAMPLEVALUE, -2, -1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_MINSAMPLEVALUE, 1, 0, "MinSampleValue", NULL },
+ { TIFFTAG_MAXSAMPLEVALUE, -2, -1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_MAXSAMPLEVALUE, 1, 0, "MaxSampleValue", NULL },
+ { TIFFTAG_XRESOLUTION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_RESOLUTION, 1, 0, "XResolution", NULL },
+ { TIFFTAG_YRESOLUTION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_RESOLUTION, 1, 0, "YResolution", NULL },
+ { TIFFTAG_PLANARCONFIG, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_PLANARCONFIG, 0, 0, "PlanarConfiguration", NULL },
+ { TIFFTAG_PAGENAME, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "PageName", NULL },
+ { TIFFTAG_XPOSITION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_POSITION, 1, 0, "XPosition", NULL },
+ { TIFFTAG_YPOSITION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_POSITION, 1, 0, "YPosition", NULL },
+ { TIFFTAG_FREEOFFSETS, -1, -1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 0, 0, "FreeOffsets", NULL },
+ { TIFFTAG_FREEBYTECOUNTS, -1, -1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 0, 0, "FreeByteCounts", NULL },
+ { TIFFTAG_GRAYRESPONSEUNIT, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 1, 0, "GrayResponseUnit", NULL },
+ { TIFFTAG_GRAYRESPONSECURVE, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 1, 0, "GrayResponseCurve", NULL },
+ { TIFFTAG_RESOLUTIONUNIT, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_RESOLUTIONUNIT, 1, 0, "ResolutionUnit", NULL },
+ { TIFFTAG_PAGENUMBER, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_UINT16_PAIR, TIFF_SETGET_UNDEFINED, FIELD_PAGENUMBER, 1, 0, "PageNumber", NULL },
+ { TIFFTAG_COLORRESPONSEUNIT, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_IGNORE, 1, 0, "ColorResponseUnit", NULL },
+ { TIFFTAG_TRANSFERFUNCTION, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_OTHER, TIFF_SETGET_UNDEFINED, FIELD_TRANSFERFUNCTION, 1, 0, "TransferFunction", NULL },
+ { TIFFTAG_SOFTWARE, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Software", NULL },
+ { TIFFTAG_DATETIME, 20, 20, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "DateTime", NULL },
+ { TIFFTAG_ARTIST, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Artist", NULL },
+ { TIFFTAG_HOSTCOMPUTER, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "HostComputer", NULL },
+ { TIFFTAG_WHITEPOINT, 2, 2, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "WhitePoint", NULL },
+ { TIFFTAG_PRIMARYCHROMATICITIES, 6, 6, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "PrimaryChromaticities", NULL },
+ { TIFFTAG_COLORMAP, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_OTHER, TIFF_SETGET_UNDEFINED, FIELD_COLORMAP, 1, 0, "ColorMap", NULL },
+ { TIFFTAG_HALFTONEHINTS, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_UINT16_PAIR, TIFF_SETGET_UNDEFINED, FIELD_HALFTONEHINTS, 1, 0, "HalftoneHints", NULL },
+ { TIFFTAG_TILEWIDTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_TILEDIMENSIONS, 0, 0, "TileWidth", NULL },
+ { TIFFTAG_TILELENGTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_TILEDIMENSIONS, 0, 0, "TileLength", NULL },
+ { TIFFTAG_TILEOFFSETS, -1, 1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_STRIPOFFSETS, 0, 0, "TileOffsets", NULL },
+ { TIFFTAG_TILEBYTECOUNTS, -1, 1, TIFF_LONG8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_STRIPBYTECOUNTS, 0, 0, "TileByteCounts", NULL },
+ { TIFFTAG_SUBIFD, -1, -1, TIFF_IFD8, 0, TIFF_SETGET_C16_IFD8, TIFF_SETGET_UNDEFINED, FIELD_SUBIFD, 1, 1, "SubIFD", (TIFFFieldArray*) &tiffFieldArray },
+ { TIFFTAG_INKSET, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "InkSet", NULL },
+ { TIFFTAG_INKNAMES, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_C16_ASCII, TIFF_SETGET_UNDEFINED, FIELD_INKNAMES, 1, 1, "InkNames", NULL },
+ { TIFFTAG_NUMBEROFINKS, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "NumberOfInks", NULL },
+ { TIFFTAG_DOTRANGE, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_UINT16_PAIR, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DotRange", NULL },
+ { TIFFTAG_TARGETPRINTER, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "TargetPrinter", NULL },
+ { TIFFTAG_EXTRASAMPLES, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_C16_UINT16, TIFF_SETGET_UNDEFINED, FIELD_EXTRASAMPLES, 0, 1, "ExtraSamples", NULL },
+ { TIFFTAG_SAMPLEFORMAT, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_SAMPLEFORMAT, 0, 0, "SampleFormat", NULL },
+ { TIFFTAG_SMINSAMPLEVALUE, -2, -1, TIFF_ANY, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_SMINSAMPLEVALUE, 1, 0, "SMinSampleValue", NULL },
+ { TIFFTAG_SMAXSAMPLEVALUE, -2, -1, TIFF_ANY, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_SMAXSAMPLEVALUE, 1, 0, "SMaxSampleValue", NULL },
+ { TIFFTAG_CLIPPATH, -1, -3, TIFF_BYTE, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ClipPath", NULL },
+ { TIFFTAG_XCLIPPATHUNITS, 1, 1, TIFF_SLONG, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "XClipPathUnits", NULL },
+ { TIFFTAG_XCLIPPATHUNITS, 1, 1, TIFF_SBYTE, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "XClipPathUnits", NULL },
+ { TIFFTAG_YCLIPPATHUNITS, 1, 1, TIFF_SLONG, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "YClipPathUnits", NULL },
+ { TIFFTAG_YCBCRCOEFFICIENTS, 3, 3, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "YCbCrCoefficients", NULL },
+ { TIFFTAG_YCBCRSUBSAMPLING, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_UINT16_PAIR, TIFF_SETGET_UNDEFINED, FIELD_YCBCRSUBSAMPLING, 0, 0, "YCbCrSubsampling", NULL },
+ { TIFFTAG_YCBCRPOSITIONING, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_YCBCRPOSITIONING, 0, 0, "YCbCrPositioning", NULL },
+ { TIFFTAG_REFERENCEBLACKWHITE, 6, 6, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_REFBLACKWHITE, 1, 0, "ReferenceBlackWhite", NULL },
+ { TIFFTAG_XMLPACKET, -3, -3, TIFF_BYTE, 0, TIFF_SETGET_C32_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "XMLPacket", NULL },
+ /* begin SGI tags */
+ { TIFFTAG_MATTEING, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_EXTRASAMPLES, 0, 0, "Matteing", NULL },
+ { TIFFTAG_DATATYPE, -2, -1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_SAMPLEFORMAT, 0, 0, "DataType", NULL },
+ { TIFFTAG_IMAGEDEPTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_IMAGEDEPTH, 0, 0, "ImageDepth", NULL },
+ { TIFFTAG_TILEDEPTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_TILEDEPTH, 0, 0, "TileDepth", NULL },
+ /* end SGI tags */
+ /* begin Pixar tags */
+ { TIFFTAG_PIXAR_IMAGEFULLWIDTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ImageFullWidth", NULL },
+ { TIFFTAG_PIXAR_IMAGEFULLLENGTH, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ImageFullLength", NULL },
+ { TIFFTAG_PIXAR_TEXTUREFORMAT, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "TextureFormat", NULL },
+ { TIFFTAG_PIXAR_WRAPMODES, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "TextureWrapModes", NULL },
+ { TIFFTAG_PIXAR_FOVCOT, 1, 1, TIFF_FLOAT, 0, TIFF_SETGET_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FieldOfViewCotangent", NULL },
+ { TIFFTAG_PIXAR_MATRIX_WORLDTOSCREEN, 16, 16, TIFF_FLOAT, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "MatrixWorldToScreen", NULL },
+ { TIFFTAG_PIXAR_MATRIX_WORLDTOCAMERA, 16, 16, TIFF_FLOAT, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "MatrixWorldToCamera", NULL },
+ { TIFFTAG_CFAREPEATPATTERNDIM, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_C0_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CFARepeatPatternDim", NULL },
+ { TIFFTAG_CFAPATTERN, 4, 4, TIFF_BYTE, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CFAPattern" , NULL},
+ { TIFFTAG_COPYRIGHT, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Copyright", NULL },
+ /* end Pixar tags */
+ { TIFFTAG_RICHTIFFIPTC, -3, -3, TIFF_LONG, 0, TIFF_SETGET_C32_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "RichTIFFIPTC", NULL },
+ { TIFFTAG_PHOTOSHOP, -3, -3, TIFF_BYTE, 0, TIFF_SETGET_C32_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "Photoshop", NULL },
+ { TIFFTAG_EXIFIFD, 1, 1, TIFF_IFD8, 0, TIFF_SETGET_IFD8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "EXIFIFDOffset", (TIFFFieldArray*) &exifFieldArray },
+ { TIFFTAG_ICCPROFILE, -3, -3, TIFF_UNDEFINED, 0, TIFF_SETGET_C32_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ICC Profile", NULL },
+ { TIFFTAG_GPSIFD, 1, 1, TIFF_IFD8, 0, TIFF_SETGET_IFD8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "GPSIFDOffset", NULL },
+ { TIFFTAG_FAXRECVPARAMS, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_CUSTOM, TRUE, FALSE, "FaxRecvParams", NULL },
+ { TIFFTAG_FAXSUBADDRESS, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_ASCII, FIELD_CUSTOM, TRUE, FALSE, "FaxSubAddress", NULL },
+ { TIFFTAG_FAXRECVTIME, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_CUSTOM, TRUE, FALSE, "FaxRecvTime", NULL },
+ { TIFFTAG_FAXDCS, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_ASCII, FIELD_CUSTOM, TRUE, FALSE, "FaxDcs", NULL },
+ { TIFFTAG_STONITS, 1, 1, TIFF_DOUBLE, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "StoNits", NULL },
+ { TIFFTAG_INTEROPERABILITYIFD, 1, 1, TIFF_IFD8, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "InteroperabilityIFDOffset", NULL },
+ /* begin DNG tags */
+ { TIFFTAG_DNGVERSION, 4, 4, TIFF_BYTE, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DNGVersion", NULL },
+ { TIFFTAG_DNGBACKWARDVERSION, 4, 4, TIFF_BYTE, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DNGBackwardVersion", NULL },
+ { TIFFTAG_UNIQUECAMERAMODEL, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "UniqueCameraModel", NULL },
+ { TIFFTAG_LOCALIZEDCAMERAMODEL, -1, -1, TIFF_BYTE, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "LocalizedCameraModel", NULL },
+ { TIFFTAG_CFAPLANECOLOR, -1, -1, TIFF_BYTE, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "CFAPlaneColor", NULL },
+ { TIFFTAG_CFALAYOUT, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CFALayout", NULL },
+ { TIFFTAG_LINEARIZATIONTABLE, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_C16_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "LinearizationTable", NULL },
+ { TIFFTAG_BLACKLEVELREPEATDIM, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_C0_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BlackLevelRepeatDim", NULL },
+ { TIFFTAG_BLACKLEVEL, -1, -1, TIFF_RATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "BlackLevel", NULL },
+ { TIFFTAG_BLACKLEVELDELTAH, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "BlackLevelDeltaH", NULL },
+ { TIFFTAG_BLACKLEVELDELTAV, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "BlackLevelDeltaV", NULL },
+ { TIFFTAG_WHITELEVEL, -1, -1, TIFF_LONG, 0, TIFF_SETGET_C16_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "WhiteLevel", NULL },
+ { TIFFTAG_DEFAULTSCALE, 2, 2, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DefaultScale", NULL },
+ { TIFFTAG_BESTQUALITYSCALE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BestQualityScale", NULL },
+ { TIFFTAG_DEFAULTCROPORIGIN, 2, 2, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DefaultCropOrigin", NULL },
+ { TIFFTAG_DEFAULTCROPSIZE, 2, 2, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "DefaultCropSize", NULL },
+ { TIFFTAG_COLORMATRIX1, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ColorMatrix1", NULL },
+ { TIFFTAG_COLORMATRIX2, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ColorMatrix2", NULL },
+ { TIFFTAG_CAMERACALIBRATION1, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "CameraCalibration1", NULL },
+ { TIFFTAG_CAMERACALIBRATION2, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "CameraCalibration2", NULL },
+ { TIFFTAG_REDUCTIONMATRIX1, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ReductionMatrix1", NULL },
+ { TIFFTAG_REDUCTIONMATRIX2, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ReductionMatrix2", NULL },
+ { TIFFTAG_ANALOGBALANCE, -1, -1, TIFF_RATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "AnalogBalance", NULL },
+ { TIFFTAG_ASSHOTNEUTRAL, -1, -1, TIFF_RATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "AsShotNeutral", NULL },
+ { TIFFTAG_ASSHOTWHITEXY, 2, 2, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "AsShotWhiteXY", NULL },
+ { TIFFTAG_BASELINEEXPOSURE, 1, 1, TIFF_SRATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BaselineExposure", NULL },
+ { TIFFTAG_BASELINENOISE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BaselineNoise", NULL },
+ { TIFFTAG_BASELINESHARPNESS, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BaselineSharpness", NULL },
+ { TIFFTAG_BAYERGREENSPLIT, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "BayerGreenSplit", NULL },
+ { TIFFTAG_LINEARRESPONSELIMIT, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "LinearResponseLimit", NULL },
+ { TIFFTAG_CAMERASERIALNUMBER, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "CameraSerialNumber", NULL },
+ { TIFFTAG_LENSINFO, 4, 4, TIFF_RATIONAL, 0, TIFF_SETGET_C0_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "LensInfo", NULL },
+ { TIFFTAG_CHROMABLURRADIUS, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ChromaBlurRadius", NULL },
+ { TIFFTAG_ANTIALIASSTRENGTH, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "AntiAliasStrength", NULL },
+ { TIFFTAG_SHADOWSCALE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ShadowScale", NULL },
+ { TIFFTAG_DNGPRIVATEDATA, -1, -1, TIFF_BYTE, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "DNGPrivateData", NULL },
+ { TIFFTAG_MAKERNOTESAFETY, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "MakerNoteSafety", NULL },
+ { TIFFTAG_CALIBRATIONILLUMINANT1, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CalibrationIlluminant1", NULL },
+ { TIFFTAG_CALIBRATIONILLUMINANT2, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CalibrationIlluminant2", NULL },
+ { TIFFTAG_RAWDATAUNIQUEID, 16, 16, TIFF_BYTE, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "RawDataUniqueID", NULL },
+ { TIFFTAG_ORIGINALRAWFILENAME, -1, -1, TIFF_BYTE, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "OriginalRawFileName", NULL },
+ { TIFFTAG_ORIGINALRAWFILEDATA, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "OriginalRawFileData", NULL },
+ { TIFFTAG_ACTIVEAREA, 4, 4, TIFF_LONG, 0, TIFF_SETGET_C0_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ActiveArea", NULL },
+ { TIFFTAG_MASKEDAREAS, -1, -1, TIFF_LONG, 0, TIFF_SETGET_C16_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "MaskedAreas", NULL },
+ { TIFFTAG_ASSHOTICCPROFILE, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "AsShotICCProfile", NULL },
+ { TIFFTAG_ASSHOTPREPROFILEMATRIX, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "AsShotPreProfileMatrix", NULL },
+ { TIFFTAG_CURRENTICCPROFILE, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "CurrentICCProfile", NULL },
+ { TIFFTAG_CURRENTPREPROFILEMATRIX, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "CurrentPreProfileMatrix", NULL },
+ { TIFFTAG_PERSAMPLE, 0, 0, TIFF_SHORT, 0, TIFF_SETGET_UNDEFINED, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, TRUE, FALSE, "PerSample", NULL},
+ /* end DNG tags */
+ /* begin TIFF/FX tags */
+ { TIFFTAG_INDEXED, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "Indexed", NULL },
+ { TIFFTAG_GLOBALPARAMETERSIFD, 1, 1, TIFF_IFD8, 0, TIFF_SETGET_IFD8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "GlobalParametersIFD", NULL },
+ { TIFFTAG_PROFILETYPE, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ProfileType", NULL },
+ { TIFFTAG_FAXPROFILE, 1, 1, TIFF_BYTE, 0, TIFF_SETGET_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "FaxProfile", NULL },
+ { TIFFTAG_CODINGMETHODS, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "CodingMethods", NULL },
+ { TIFFTAG_VERSIONYEAR, 4, 4, TIFF_BYTE, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "VersionYear", NULL },
+ { TIFFTAG_MODENUMBER, 1, 1, TIFF_BYTE, 0, TIFF_SETGET_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ModeNumber", NULL },
+ { TIFFTAG_DECODE, -1, -1, TIFF_SRATIONAL, 0, TIFF_SETGET_C16_FLOAT, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "Decode", NULL },
+ { TIFFTAG_IMAGEBASECOLOR, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_C16_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "ImageBaseColor", NULL },
+ { TIFFTAG_T82OPTIONS, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "T82Options", NULL },
+ { TIFFTAG_STRIPROWCOUNTS, -1, -1, TIFF_LONG, 0, TIFF_SETGET_C16_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 1, "StripRowCounts", NULL },
+ { TIFFTAG_IMAGELAYER, 2, 2, TIFF_LONG, 0, TIFF_SETGET_C0_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 0, 0, "ImageLayer", NULL },
+ /* end TIFF/FX tags */
+ /* begin pseudo tags */
+};
+
+static const TIFFField
+exifFields[] = {
+ { EXIFTAG_EXPOSURETIME, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExposureTime", NULL },
+ { EXIFTAG_FNUMBER, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FNumber", NULL },
+ { EXIFTAG_EXPOSUREPROGRAM, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExposureProgram", NULL },
+ { EXIFTAG_SPECTRALSENSITIVITY, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SpectralSensitivity", NULL },
+ { EXIFTAG_ISOSPEEDRATINGS, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_C16_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "ISOSpeedRatings", NULL },
+ { EXIFTAG_OECF, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "OptoelectricConversionFactor", NULL },
+ { EXIFTAG_EXIFVERSION, 4, 4, TIFF_UNDEFINED, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExifVersion", NULL },
+ { EXIFTAG_DATETIMEORIGINAL, 20, 20, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "DateTimeOriginal", NULL },
+ { EXIFTAG_DATETIMEDIGITIZED, 20, 20, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "DateTimeDigitized", NULL },
+ { EXIFTAG_COMPONENTSCONFIGURATION, 4, 4, TIFF_UNDEFINED, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ComponentsConfiguration", NULL },
+ { EXIFTAG_COMPRESSEDBITSPERPIXEL, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "CompressedBitsPerPixel", NULL },
+ { EXIFTAG_SHUTTERSPEEDVALUE, 1, 1, TIFF_SRATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ShutterSpeedValue", NULL },
+ { EXIFTAG_APERTUREVALUE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ApertureValue", NULL },
+ { EXIFTAG_BRIGHTNESSVALUE, 1, 1, TIFF_SRATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "BrightnessValue", NULL },
+ { EXIFTAG_EXPOSUREBIASVALUE, 1, 1, TIFF_SRATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExposureBiasValue", NULL },
+ { EXIFTAG_MAXAPERTUREVALUE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "MaxApertureValue", NULL },
+ { EXIFTAG_SUBJECTDISTANCE, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubjectDistance", NULL },
+ { EXIFTAG_METERINGMODE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "MeteringMode", NULL },
+ { EXIFTAG_LIGHTSOURCE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "LightSource", NULL },
+ { EXIFTAG_FLASH, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Flash", NULL },
+ { EXIFTAG_FOCALLENGTH, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FocalLength", NULL },
+ { EXIFTAG_SUBJECTAREA, -1, -1, TIFF_SHORT, 0, TIFF_SETGET_C16_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "SubjectArea", NULL },
+ { EXIFTAG_MAKERNOTE, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "MakerNote", NULL },
+ { EXIFTAG_USERCOMMENT, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "UserComment", NULL },
+ { EXIFTAG_SUBSECTIME, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubSecTime", NULL },
+ { EXIFTAG_SUBSECTIMEORIGINAL, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubSecTimeOriginal", NULL },
+ { EXIFTAG_SUBSECTIMEDIGITIZED, -1, -1, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubSecTimeDigitized", NULL },
+ { EXIFTAG_FLASHPIXVERSION, 4, 4, TIFF_UNDEFINED, 0, TIFF_SETGET_C0_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FlashpixVersion", NULL },
+ { EXIFTAG_COLORSPACE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ColorSpace", NULL },
+ { EXIFTAG_PIXELXDIMENSION, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "PixelXDimension", NULL },
+ { EXIFTAG_PIXELYDIMENSION, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "PixelYDimension", NULL },
+ { EXIFTAG_RELATEDSOUNDFILE, 13, 13, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "RelatedSoundFile", NULL },
+ { EXIFTAG_FLASHENERGY, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FlashEnergy", NULL },
+ { EXIFTAG_SPATIALFREQUENCYRESPONSE, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "SpatialFrequencyResponse", NULL },
+ { EXIFTAG_FOCALPLANEXRESOLUTION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FocalPlaneXResolution", NULL },
+ { EXIFTAG_FOCALPLANEYRESOLUTION, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FocalPlaneYResolution", NULL },
+ { EXIFTAG_FOCALPLANERESOLUTIONUNIT, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FocalPlaneResolutionUnit", NULL },
+ { EXIFTAG_SUBJECTLOCATION, 2, 2, TIFF_SHORT, 0, TIFF_SETGET_C0_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubjectLocation", NULL },
+ { EXIFTAG_EXPOSUREINDEX, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExposureIndex", NULL },
+ { EXIFTAG_SENSINGMETHOD, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SensingMethod", NULL },
+ { EXIFTAG_FILESOURCE, 1, 1, TIFF_UNDEFINED, 0, TIFF_SETGET_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FileSource", NULL },
+ { EXIFTAG_SCENETYPE, 1, 1, TIFF_UNDEFINED, 0, TIFF_SETGET_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SceneType", NULL },
+ { EXIFTAG_CFAPATTERN, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "CFAPattern", NULL },
+ { EXIFTAG_CUSTOMRENDERED, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "CustomRendered", NULL },
+ { EXIFTAG_EXPOSUREMODE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ExposureMode", NULL },
+ { EXIFTAG_WHITEBALANCE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "WhiteBalance", NULL },
+ { EXIFTAG_DIGITALZOOMRATIO, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "DigitalZoomRatio", NULL },
+ { EXIFTAG_FOCALLENGTHIN35MMFILM, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "FocalLengthIn35mmFilm", NULL },
+ { EXIFTAG_SCENECAPTURETYPE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SceneCaptureType", NULL },
+ { EXIFTAG_GAINCONTROL, 1, 1, TIFF_RATIONAL, 0, TIFF_SETGET_DOUBLE, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "GainControl", NULL },
+ { EXIFTAG_CONTRAST, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Contrast", NULL },
+ { EXIFTAG_SATURATION, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Saturation", NULL },
+ { EXIFTAG_SHARPNESS, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "Sharpness", NULL },
+ { EXIFTAG_DEVICESETTINGDESCRIPTION, -1, -1, TIFF_UNDEFINED, 0, TIFF_SETGET_C16_UINT8, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 1, "DeviceSettingDescription", NULL },
+ { EXIFTAG_SUBJECTDISTANCERANGE, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "SubjectDistanceRange", NULL },
+ { EXIFTAG_IMAGEUNIQUEID, 33, 33, TIFF_ASCII, 0, TIFF_SETGET_ASCII, TIFF_SETGET_UNDEFINED, FIELD_CUSTOM, 1, 0, "ImageUniqueID", NULL }
+};
+
+static const TIFFFieldArray
+tiffFieldArray = { tfiatImage, 0, TIFFArrayCount(tiffFields), (TIFFField*) tiffFields };
+static const TIFFFieldArray
+exifFieldArray = { tfiatExif, 0, TIFFArrayCount(exifFields), (TIFFField*) exifFields };
+
+/*
+ * We have our own local lfind() equivalent to avoid subtle differences
+ * in types passed to lfind() on different systems.
+ */
+
+static void *
+td_lfind(const void *key, const void *base, size_t *nmemb, size_t size,
+ int(*compar)(const void *, const void *))
+{
+ char *element, *end;
+
+ end = (char *)base + *nmemb * size;
+ for (element = (char *)base; element < end; element += size)
+ if (!compar(key, element)) /* key found */
+ return element;
+
+ return NULL;
+}
+
+const TIFFFieldArray*
+_TIFFGetFields(void)
+{
+ return(&tiffFieldArray);
+}
+
+const TIFFFieldArray*
+_TIFFGetExifFields(void)
+{
+ return(&exifFieldArray);
+}
+
+void
+_TIFFSetupFields(TIFF* tif, const TIFFFieldArray* fieldarray)
+{
+ if (tif->tif_fields && tif->tif_nfields > 0) {
+ uint32 i;
+
+ for (i = 0; i < tif->tif_nfields; i++) {
+ TIFFField *fld = tif->tif_fields[i];
+ if (fld->field_bit == FIELD_CUSTOM &&
+ strncmp("Tag ", fld->field_name, 4) == 0) {
+ _TIFFfree(fld->field_name);
+ _TIFFfree(fld);
+ }
+ }
+
+ _TIFFfree(tif->tif_fields);
+ tif->tif_fields = NULL;
+ tif->tif_nfields = 0;
+ }
+ if (!_TIFFMergeFields(tif, fieldarray->fields, fieldarray->count)) {
+ TIFFErrorExt(tif->tif_clientdata, "_TIFFSetupFields",
+ "Setting up field info failed");
+ }
+}
+
+static int
+tagCompare(const void* a, const void* b)
+{
+ const TIFFField* ta = *(const TIFFField**) a;
+ const TIFFField* tb = *(const TIFFField**) b;
+ /* NB: be careful of return values for 16-bit platforms */
+ if (ta->field_tag != tb->field_tag)
+ return (int)ta->field_tag - (int)tb->field_tag;
+ else
+ return (ta->field_type == TIFF_ANY) ?
+ 0 : ((int)tb->field_type - (int)ta->field_type);
+}
+
+static int
+tagNameCompare(const void* a, const void* b)
+{
+ const TIFFField* ta = *(const TIFFField**) a;
+ const TIFFField* tb = *(const TIFFField**) b;
+ int ret = strcmp(ta->field_name, tb->field_name);
+
+ if (ret)
+ return ret;
+ else
+ return (ta->field_type == TIFF_ANY) ?
+ 0 : ((int)tb->field_type - (int)ta->field_type);
+}
+
+int
+_TIFFMergeFields(TIFF* tif, const TIFFField info[], uint32 n)
+{
+ static const char module[] = "_TIFFMergeFields";
+ static const char reason[] = "for fields array";
+ /* TIFFField** tp; */
+ uint32 i;
+
+ tif->tif_foundfield = NULL;
+
+ if (tif->tif_fields && tif->tif_nfields > 0) {
+ tif->tif_fields = (TIFFField**)
+ _TIFFCheckRealloc(tif, tif->tif_fields,
+ (tif->tif_nfields + n),
+ sizeof(TIFFField *), reason);
+ } else {
+ tif->tif_fields = (TIFFField **)
+ _TIFFCheckMalloc(tif, n, sizeof(TIFFField *),
+ reason);
+ }
+ if (!tif->tif_fields) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Failed to allocate fields array");
+ return 0;
+ }
+
+ /* tp = tif->tif_fields + tif->tif_nfields; */
+ for (i = 0; i < n; i++) {
+ const TIFFField *fip =
+ TIFFFindField(tif, info[i].field_tag, TIFF_ANY);
+
+ /* only add definitions that aren't already present */
+ if (!fip) {
+ tif->tif_fields[tif->tif_nfields] = (TIFFField *) (info+i);
+ tif->tif_nfields++;
+ }
+ }
+
+ /* Sort the field info by tag number */
+ qsort(tif->tif_fields, tif->tif_nfields,
+ sizeof(TIFFField *), tagCompare);
+
+ return n;
+}
+
+void
+_TIFFPrintFieldInfo(TIFF* tif, FILE* fd)
+{
+ uint32 i;
+
+ fprintf(fd, "%s: \n", tif->tif_name);
+ for (i = 0; i < tif->tif_nfields; i++) {
+ const TIFFField* fip = tif->tif_fields[i];
+ fprintf(fd, "field[%2d] %5lu, %2d, %2d, %d, %2d, %5s, %5s, %s\n"
+ , (int)i
+ , (unsigned long) fip->field_tag
+ , fip->field_readcount, fip->field_writecount
+ , fip->field_type
+ , fip->field_bit
+ , fip->field_oktochange ? "TRUE" : "FALSE"
+ , fip->field_passcount ? "TRUE" : "FALSE"
+ , fip->field_name
+ );
+ }
+}
+
+/*
+ * Return size of TIFFDataType in bytes
+ */
+int
+TIFFDataWidth(TIFFDataType type)
+{
+ switch(type)
+ {
+ case 0: /* nothing */
+ case TIFF_BYTE:
+ case TIFF_ASCII:
+ case TIFF_SBYTE:
+ case TIFF_UNDEFINED:
+ return 1;
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ return 2;
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_FLOAT:
+ case TIFF_IFD:
+ return 4;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_DOUBLE:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ case TIFF_IFD8:
+ return 8;
+ default:
+ return 0; /* will return 0 for unknown types */
+ }
+}
+
+/*
+ * Return size of TIFFDataType in bytes.
+ *
+ * XXX: We need a separate function to determine the space needed
+ * to store the value. For TIFF_RATIONAL values TIFFDataWidth() returns 8,
+ * but we use 4-byte float to represent rationals.
+ */
+int
+_TIFFDataSize(TIFFDataType type)
+{
+ switch (type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_ASCII:
+ case TIFF_UNDEFINED:
+ return 1;
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ return 2;
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_FLOAT:
+ case TIFF_IFD:
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ return 4;
+ case TIFF_DOUBLE:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ case TIFF_IFD8:
+ return 8;
+ default:
+ return 0;
+ }
+}
+
+const TIFFField*
+TIFFFindField(TIFF* tif, uint32 tag, TIFFDataType dt)
+{
+ TIFFField key = {0, 0, 0, TIFF_NOTYPE, 0, 0, 0, 0, 0, 0, NULL, NULL};
+ TIFFField* pkey = &key;
+ const TIFFField **ret;
+ if (tif->tif_foundfield && tif->tif_foundfield->field_tag == tag &&
+ (dt == TIFF_ANY || dt == tif->tif_foundfield->field_type))
+ return tif->tif_foundfield;
+
+ /* If we are invoked with no field information, then just return. */
+ if (!tif->tif_fields)
+ return NULL;
+
+ /* NB: use sorted search (e.g. binary search) */
+
+ key.field_tag = tag;
+ key.field_type = dt;
+
+ ret = (const TIFFField **) bsearch(&pkey, tif->tif_fields,
+ tif->tif_nfields,
+ sizeof(TIFFField *), tagCompare);
+ return tif->tif_foundfield = (ret ? *ret : NULL);
+}
+
+static const TIFFField*
+_TIFFFindFieldByName(TIFF* tif, const char *field_name, TIFFDataType dt)
+{
+ TIFFField key = {0, 0, 0, TIFF_NOTYPE, 0, 0, 0, 0, 0, 0, NULL, NULL};
+ TIFFField* pkey = &key;
+ const TIFFField **ret;
+ if (tif->tif_foundfield
+ && streq(tif->tif_foundfield->field_name, field_name)
+ && (dt == TIFF_ANY || dt == tif->tif_foundfield->field_type))
+ return (tif->tif_foundfield);
+
+ /* If we are invoked with no field information, then just return. */
+ if (!tif->tif_fields)
+ return NULL;
+
+ /* NB: use linear search since list is sorted by key#, not name */
+
+ key.field_name = (char *)field_name;
+ key.field_type = dt;
+
+ ret = (const TIFFField **)
+ td_lfind(&pkey, tif->tif_fields, &tif->tif_nfields,
+ sizeof(TIFFField *), tagNameCompare);
+
+ return tif->tif_foundfield = (ret ? *ret : NULL);
+}
+
+const TIFFField*
+TIFFFieldWithTag(TIFF* tif, uint32 tag)
+{
+ const TIFFField* fip = TIFFFindField(tif, tag, TIFF_ANY);
+ if (!fip) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFFieldWithTag",
+ "Internal error, unknown tag 0x%x",
+ (unsigned int) tag);
+ }
+ return (fip);
+}
+
+const TIFFField*
+TIFFFieldWithName(TIFF* tif, const char *field_name)
+{
+ const TIFFField* fip =
+ _TIFFFindFieldByName(tif, field_name, TIFF_ANY);
+ if (!fip) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFFieldWithName",
+ "Internal error, unknown tag %s", field_name);
+ }
+ return (fip);
+}
+
+uint32
+TIFFFieldTag(const TIFFField* fip)
+{
+ return fip->field_tag;
+}
+
+const char *
+TIFFFieldName(const TIFFField* fip)
+{
+ return fip->field_name;
+}
+
+TIFFDataType
+TIFFFieldDataType(const TIFFField* fip)
+{
+ return fip->field_type;
+}
+
+int
+TIFFFieldPassCount(const TIFFField* fip)
+{
+ return fip->field_passcount;
+}
+
+int
+TIFFFieldReadCount(const TIFFField* fip)
+{
+ return fip->field_readcount;
+}
+
+int
+TIFFFieldWriteCount(const TIFFField* fip)
+{
+ return fip->field_writecount;
+}
+
+const TIFFField*
+_TIFFFindOrRegisterField(TIFF *tif, uint32 tag, TIFFDataType dt)
+
+{
+ const TIFFField *fld;
+
+ fld = TIFFFindField(tif, tag, dt);
+ if (fld == NULL) {
+ fld = _TIFFCreateAnonField(tif, tag, dt);
+ if (!_TIFFMergeFields(tif, fld, 1))
+ return NULL;
+ }
+
+ return fld;
+}
+
+TIFFField*
+_TIFFCreateAnonField(TIFF *tif, uint32 tag, TIFFDataType field_type)
+{
+ TIFFField *fld;
+ (void) tif;
+
+ fld = (TIFFField *) _TIFFmalloc(sizeof (TIFFField));
+ if (fld == NULL)
+ return NULL;
+ _TIFFmemset(fld, 0, sizeof(TIFFField));
+
+ fld->field_tag = tag;
+ fld->field_readcount = TIFF_VARIABLE2;
+ fld->field_writecount = TIFF_VARIABLE2;
+ fld->field_type = field_type;
+ fld->reserved = 0;
+ switch (field_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ fld->set_field_type = TIFF_SETGET_C32_UINT8;
+ fld->get_field_type = TIFF_SETGET_C32_UINT8;
+ break;
+ case TIFF_ASCII:
+ fld->set_field_type = TIFF_SETGET_C32_ASCII;
+ fld->get_field_type = TIFF_SETGET_C32_ASCII;
+ break;
+ case TIFF_SHORT:
+ fld->set_field_type = TIFF_SETGET_C32_UINT16;
+ fld->get_field_type = TIFF_SETGET_C32_UINT16;
+ break;
+ case TIFF_LONG:
+ fld->set_field_type = TIFF_SETGET_C32_UINT32;
+ fld->get_field_type = TIFF_SETGET_C32_UINT32;
+ break;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ fld->set_field_type = TIFF_SETGET_C32_FLOAT;
+ fld->get_field_type = TIFF_SETGET_C32_FLOAT;
+ break;
+ case TIFF_SBYTE:
+ fld->set_field_type = TIFF_SETGET_C32_SINT8;
+ fld->get_field_type = TIFF_SETGET_C32_SINT8;
+ break;
+ case TIFF_SSHORT:
+ fld->set_field_type = TIFF_SETGET_C32_SINT16;
+ fld->get_field_type = TIFF_SETGET_C32_SINT16;
+ break;
+ case TIFF_SLONG:
+ fld->set_field_type = TIFF_SETGET_C32_SINT32;
+ fld->get_field_type = TIFF_SETGET_C32_SINT32;
+ break;
+ case TIFF_DOUBLE:
+ fld->set_field_type = TIFF_SETGET_C32_DOUBLE;
+ fld->get_field_type = TIFF_SETGET_C32_DOUBLE;
+ break;
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ fld->set_field_type = TIFF_SETGET_C32_IFD8;
+ fld->get_field_type = TIFF_SETGET_C32_IFD8;
+ break;
+ case TIFF_LONG8:
+ fld->set_field_type = TIFF_SETGET_C32_UINT64;
+ fld->get_field_type = TIFF_SETGET_C32_UINT64;
+ break;
+ case TIFF_SLONG8:
+ fld->set_field_type = TIFF_SETGET_C32_SINT64;
+ fld->get_field_type = TIFF_SETGET_C32_SINT64;
+ break;
+ default:
+ fld->set_field_type = TIFF_SETGET_UNDEFINED;
+ fld->get_field_type = TIFF_SETGET_UNDEFINED;
+ break;
+ }
+ fld->field_bit = FIELD_CUSTOM;
+ fld->field_oktochange = TRUE;
+ fld->field_passcount = TRUE;
+ fld->field_name = (char *) _TIFFmalloc(32);
+ if (fld->field_name == NULL) {
+ _TIFFfree(fld);
+ return NULL;
+ }
+ fld->field_subfields = NULL;
+
+ /*
+ * note that this name is a special sign to TIFFClose() and
+ * _TIFFSetupFields() to free the field
+ */
+ (void) snprintf(fld->field_name, 32, "Tag %d", (int) tag);
+
+ return fld;
+}
+
+/****************************************************************************
+ * O B S O L E T E D I N T E R F A C E S
+ *
+ * Don't use this stuff in your applications, it may be removed in the future
+ * libtiff versions.
+ ****************************************************************************/
+
+static TIFFSetGetFieldType
+_TIFFSetGetType(TIFFDataType type, short count, unsigned char passcount)
+{
+ if (type == TIFF_ASCII && count == TIFF_VARIABLE && passcount == 0)
+ return TIFF_SETGET_ASCII;
+
+ else if (count == 1 && passcount == 0) {
+ switch (type)
+ {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ return TIFF_SETGET_UINT8;
+ case TIFF_ASCII:
+ return TIFF_SETGET_ASCII;
+ case TIFF_SHORT:
+ return TIFF_SETGET_UINT16;
+ case TIFF_LONG:
+ return TIFF_SETGET_UINT32;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ return TIFF_SETGET_FLOAT;
+ case TIFF_SBYTE:
+ return TIFF_SETGET_SINT8;
+ case TIFF_SSHORT:
+ return TIFF_SETGET_SINT16;
+ case TIFF_SLONG:
+ return TIFF_SETGET_SINT32;
+ case TIFF_DOUBLE:
+ return TIFF_SETGET_DOUBLE;
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ return TIFF_SETGET_IFD8;
+ case TIFF_LONG8:
+ return TIFF_SETGET_UINT64;
+ case TIFF_SLONG8:
+ return TIFF_SETGET_SINT64;
+ default:
+ return TIFF_SETGET_UNDEFINED;
+ }
+ }
+
+ else if (count >= 1 && passcount == 0) {
+ switch (type)
+ {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ return TIFF_SETGET_C0_UINT8;
+ case TIFF_ASCII:
+ return TIFF_SETGET_C0_ASCII;
+ case TIFF_SHORT:
+ return TIFF_SETGET_C0_UINT16;
+ case TIFF_LONG:
+ return TIFF_SETGET_C0_UINT32;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ return TIFF_SETGET_C0_FLOAT;
+ case TIFF_SBYTE:
+ return TIFF_SETGET_C0_SINT8;
+ case TIFF_SSHORT:
+ return TIFF_SETGET_C0_SINT16;
+ case TIFF_SLONG:
+ return TIFF_SETGET_C0_SINT32;
+ case TIFF_DOUBLE:
+ return TIFF_SETGET_C0_DOUBLE;
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ return TIFF_SETGET_C0_IFD8;
+ case TIFF_LONG8:
+ return TIFF_SETGET_C0_UINT64;
+ case TIFF_SLONG8:
+ return TIFF_SETGET_C0_SINT64;
+ default:
+ return TIFF_SETGET_UNDEFINED;
+ }
+ }
+
+ else if (count == TIFF_VARIABLE && passcount == 1) {
+ switch (type)
+ {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ return TIFF_SETGET_C16_UINT8;
+ case TIFF_ASCII:
+ return TIFF_SETGET_C16_ASCII;
+ case TIFF_SHORT:
+ return TIFF_SETGET_C16_UINT16;
+ case TIFF_LONG:
+ return TIFF_SETGET_C16_UINT32;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ return TIFF_SETGET_C16_FLOAT;
+ case TIFF_SBYTE:
+ return TIFF_SETGET_C16_SINT8;
+ case TIFF_SSHORT:
+ return TIFF_SETGET_C16_SINT16;
+ case TIFF_SLONG:
+ return TIFF_SETGET_C16_SINT32;
+ case TIFF_DOUBLE:
+ return TIFF_SETGET_C16_DOUBLE;
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ return TIFF_SETGET_C16_IFD8;
+ case TIFF_LONG8:
+ return TIFF_SETGET_C16_UINT64;
+ case TIFF_SLONG8:
+ return TIFF_SETGET_C16_SINT64;
+ default:
+ return TIFF_SETGET_UNDEFINED;
+ }
+ }
+
+ else if (count == TIFF_VARIABLE2 && passcount == 1) {
+ switch (type)
+ {
+ case TIFF_BYTE:
+ case TIFF_UNDEFINED:
+ return TIFF_SETGET_C32_UINT8;
+ case TIFF_ASCII:
+ return TIFF_SETGET_C32_ASCII;
+ case TIFF_SHORT:
+ return TIFF_SETGET_C32_UINT16;
+ case TIFF_LONG:
+ return TIFF_SETGET_C32_UINT32;
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ return TIFF_SETGET_C32_FLOAT;
+ case TIFF_SBYTE:
+ return TIFF_SETGET_C32_SINT8;
+ case TIFF_SSHORT:
+ return TIFF_SETGET_C32_SINT16;
+ case TIFF_SLONG:
+ return TIFF_SETGET_C32_SINT32;
+ case TIFF_DOUBLE:
+ return TIFF_SETGET_C32_DOUBLE;
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ return TIFF_SETGET_C32_IFD8;
+ case TIFF_LONG8:
+ return TIFF_SETGET_C32_UINT64;
+ case TIFF_SLONG8:
+ return TIFF_SETGET_C32_SINT64;
+ default:
+ return TIFF_SETGET_UNDEFINED;
+ }
+ }
+
+ return TIFF_SETGET_UNDEFINED;
+}
+
+int
+TIFFMergeFieldInfo(TIFF* tif, const TIFFFieldInfo info[], uint32 n)
+{
+ static const char module[] = "TIFFMergeFieldInfo";
+ static const char reason[] = "for fields array";
+ TIFFField *tp;
+ size_t nfields;
+ uint32 i;
+
+ if (tif->tif_nfieldscompat > 0) {
+ tif->tif_fieldscompat = (TIFFFieldArray *)
+ _TIFFCheckRealloc(tif, tif->tif_fieldscompat,
+ tif->tif_nfieldscompat + 1,
+ sizeof(TIFFFieldArray), reason);
+ } else {
+ tif->tif_fieldscompat = (TIFFFieldArray *)
+ _TIFFCheckMalloc(tif, 1, sizeof(TIFFFieldArray),
+ reason);
+ }
+ if (!tif->tif_fieldscompat) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Failed to allocate fields array");
+ return -1;
+ }
+ nfields = tif->tif_nfieldscompat++;
+
+ tif->tif_fieldscompat[nfields].type = tfiatOther;
+ tif->tif_fieldscompat[nfields].allocated_size = n;
+ tif->tif_fieldscompat[nfields].count = n;
+ tif->tif_fieldscompat[nfields].fields =
+ (TIFFField *)_TIFFCheckMalloc(tif, n, sizeof(TIFFField),
+ reason);
+ if (!tif->tif_fieldscompat[nfields].fields) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Failed to allocate fields array");
+ return -1;
+ }
+
+ tp = tif->tif_fieldscompat[nfields].fields;
+ for (i = 0; i < n; i++) {
+ tp->field_tag = info[i].field_tag;
+ tp->field_readcount = info[i].field_readcount;
+ tp->field_writecount = info[i].field_writecount;
+ tp->field_type = info[i].field_type;
+ tp->reserved = 0;
+ tp->set_field_type =
+ _TIFFSetGetType(info[i].field_type,
+ info[i].field_readcount,
+ info[i].field_passcount);
+ tp->get_field_type =
+ _TIFFSetGetType(info[i].field_type,
+ info[i].field_readcount,
+ info[i].field_passcount);
+ tp->field_bit = info[i].field_bit;
+ tp->field_oktochange = info[i].field_oktochange;
+ tp->field_passcount = info[i].field_passcount;
+ tp->field_name = info[i].field_name;
+ tp->field_subfields = NULL;
+ tp++;
+ }
+
+ if (!_TIFFMergeFields(tif, tif->tif_fieldscompat[nfields].fields, n)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Setting up field info failed");
+ return -1;
+ }
+
+ return 0;
+}
+
+int
+_TIFFCheckFieldIsValidForCodec(TIFF *tif, ttag_t tag)
+{
+ /* Filter out non-codec specific tags */
+ switch (tag) {
+ /* Shared tags */
+ case TIFFTAG_PREDICTOR:
+ /* JPEG tags */
+ case TIFFTAG_JPEGTABLES:
+ /* OJPEG tags */
+ case TIFFTAG_JPEGIFOFFSET:
+ case TIFFTAG_JPEGIFBYTECOUNT:
+ case TIFFTAG_JPEGQTABLES:
+ case TIFFTAG_JPEGDCTABLES:
+ case TIFFTAG_JPEGACTABLES:
+ case TIFFTAG_JPEGPROC:
+ case TIFFTAG_JPEGRESTARTINTERVAL:
+ /* CCITT* */
+ case TIFFTAG_BADFAXLINES:
+ case TIFFTAG_CLEANFAXDATA:
+ case TIFFTAG_CONSECUTIVEBADFAXLINES:
+ case TIFFTAG_GROUP3OPTIONS:
+ case TIFFTAG_GROUP4OPTIONS:
+ /* LERC */
+ case TIFFTAG_LERC_PARAMETERS:
+ break;
+ default:
+ return 1;
+ }
+ /* Check if codec specific tags are allowed for the current
+ * compression scheme (codec) */
+ switch (tif->tif_dir.td_compression) {
+ case COMPRESSION_LZW:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ case COMPRESSION_PACKBITS:
+ /* No codec-specific tags */
+ break;
+ case COMPRESSION_THUNDERSCAN:
+ /* No codec-specific tags */
+ break;
+ case COMPRESSION_NEXT:
+ /* No codec-specific tags */
+ break;
+ case COMPRESSION_JPEG:
+ if (tag == TIFFTAG_JPEGTABLES)
+ return 1;
+ break;
+ case COMPRESSION_OJPEG:
+ switch (tag) {
+ case TIFFTAG_JPEGIFOFFSET:
+ case TIFFTAG_JPEGIFBYTECOUNT:
+ case TIFFTAG_JPEGQTABLES:
+ case TIFFTAG_JPEGDCTABLES:
+ case TIFFTAG_JPEGACTABLES:
+ case TIFFTAG_JPEGPROC:
+ case TIFFTAG_JPEGRESTARTINTERVAL:
+ return 1;
+ }
+ break;
+ case COMPRESSION_CCITTRLE:
+ case COMPRESSION_CCITTRLEW:
+ case COMPRESSION_CCITTFAX3:
+ case COMPRESSION_CCITTFAX4:
+ switch (tag) {
+ case TIFFTAG_BADFAXLINES:
+ case TIFFTAG_CLEANFAXDATA:
+ case TIFFTAG_CONSECUTIVEBADFAXLINES:
+ return 1;
+ case TIFFTAG_GROUP3OPTIONS:
+ if (tif->tif_dir.td_compression == COMPRESSION_CCITTFAX3)
+ return 1;
+ break;
+ case TIFFTAG_GROUP4OPTIONS:
+ if (tif->tif_dir.td_compression == COMPRESSION_CCITTFAX4)
+ return 1;
+ break;
+ }
+ break;
+ case COMPRESSION_JBIG:
+ /* No codec-specific tags */
+ break;
+ case COMPRESSION_DEFLATE:
+ case COMPRESSION_ADOBE_DEFLATE:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ case COMPRESSION_PIXARLOG:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ case COMPRESSION_SGILOG:
+ case COMPRESSION_SGILOG24:
+ /* No codec-specific tags */
+ break;
+ case COMPRESSION_LZMA:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ case COMPRESSION_ZSTD:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ case COMPRESSION_LERC:
+ if (tag == TIFFTAG_LERC_PARAMETERS)
+ return 1;
+ break;
+ case COMPRESSION_WEBP:
+ if (tag == TIFFTAG_PREDICTOR)
+ return 1;
+ break;
+ }
+ return 0;
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dirread.c b/test/monniaux/tiff-4.0.10/tif_dirread.c
new file mode 100644
index 00000000..e80a3b13
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dirread.c
@@ -0,0 +1,5874 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Directory Read Support Routines.
+ */
+
+/* Suggested pending improvements:
+ * - add a field 'ignore' to the TIFFDirEntry structure, to flag status,
+ * eliminating current use of the IGNORE value, and therefore eliminating
+ * current irrational behaviour on tags with tag id code 0
+ * - add a field 'field_info' to the TIFFDirEntry structure, and set that with
+ * the pointer to the appropriate TIFFField structure early on in
+ * TIFFReadDirectory, so as to eliminate current possibly repetitive lookup.
+ */
+
+#include "tiffiop.h"
+#include <float.h>
+#include <stdlib.h>
+
+#define IGNORE 0 /* tag placeholder used below */
+#define FAILED_FII ((uint32) -1)
+
+#ifdef HAVE_IEEEFP
+# define TIFFCvtIEEEFloatToNative(tif, n, fp)
+# define TIFFCvtIEEEDoubleToNative(tif, n, dp)
+#else
+extern void TIFFCvtIEEEFloatToNative(TIFF*, uint32, float*);
+extern void TIFFCvtIEEEDoubleToNative(TIFF*, uint32, double*);
+#endif
+
+enum TIFFReadDirEntryErr {
+ TIFFReadDirEntryErrOk = 0,
+ TIFFReadDirEntryErrCount = 1,
+ TIFFReadDirEntryErrType = 2,
+ TIFFReadDirEntryErrIo = 3,
+ TIFFReadDirEntryErrRange = 4,
+ TIFFReadDirEntryErrPsdif = 5,
+ TIFFReadDirEntryErrSizesan = 6,
+ TIFFReadDirEntryErrAlloc = 7,
+};
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryByte(TIFF* tif, TIFFDirEntry* direntry, uint8* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong(TIFF* tif, TIFFDirEntry* direntry, uint32* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong8(TIFF* tif, TIFFDirEntry* direntry, uint64* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryFloat(TIFF* tif, TIFFDirEntry* direntry, float* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryDouble(TIFF* tif, TIFFDirEntry* direntry, double* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryIfd8(TIFF* tif, TIFFDirEntry* direntry, uint64* value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryArray(TIFF* tif, TIFFDirEntry* direntry, uint32* count, uint32 desttypesize, void** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryByteArray(TIFF* tif, TIFFDirEntry* direntry, uint8** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySbyteArray(TIFF* tif, TIFFDirEntry* direntry, int8** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryShortArray(TIFF* tif, TIFFDirEntry* direntry, uint16** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySshortArray(TIFF* tif, TIFFDirEntry* direntry, int16** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLongArray(TIFF* tif, TIFFDirEntry* direntry, uint32** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySlongArray(TIFF* tif, TIFFDirEntry* direntry, int32** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong8Array(TIFF* tif, TIFFDirEntry* direntry, uint64** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySlong8Array(TIFF* tif, TIFFDirEntry* direntry, int64** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryFloatArray(TIFF* tif, TIFFDirEntry* direntry, float** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryDoubleArray(TIFF* tif, TIFFDirEntry* direntry, double** value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryIfd8Array(TIFF* tif, TIFFDirEntry* direntry, uint64** value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryPersampleShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value);
+#if 0
+static enum TIFFReadDirEntryErr TIFFReadDirEntryPersampleDouble(TIFF* tif, TIFFDirEntry* direntry, double* value);
+#endif
+
+static void TIFFReadDirEntryCheckedByte(TIFF* tif, TIFFDirEntry* direntry, uint8* value);
+static void TIFFReadDirEntryCheckedSbyte(TIFF* tif, TIFFDirEntry* direntry, int8* value);
+static void TIFFReadDirEntryCheckedShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value);
+static void TIFFReadDirEntryCheckedSshort(TIFF* tif, TIFFDirEntry* direntry, int16* value);
+static void TIFFReadDirEntryCheckedLong(TIFF* tif, TIFFDirEntry* direntry, uint32* value);
+static void TIFFReadDirEntryCheckedSlong(TIFF* tif, TIFFDirEntry* direntry, int32* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedLong8(TIFF* tif, TIFFDirEntry* direntry, uint64* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedSlong8(TIFF* tif, TIFFDirEntry* direntry, int64* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedRational(TIFF* tif, TIFFDirEntry* direntry, double* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedSrational(TIFF* tif, TIFFDirEntry* direntry, double* value);
+static void TIFFReadDirEntryCheckedFloat(TIFF* tif, TIFFDirEntry* direntry, float* value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedDouble(TIFF* tif, TIFFDirEntry* direntry, double* value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSbyte(int8 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteShort(uint16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSshort(int16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteLong(uint32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSlong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteByte(uint8 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteShort(uint16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSshort(int16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteLong(uint32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSlong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSbyte(int8 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSshort(int16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortLong(uint32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSlong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortShort(uint16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortLong(uint32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortSlong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSbyte(int8 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSshort(int16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSlong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSlongLong(uint32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSlongLong8(uint64 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSlongSlong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLong8Sbyte(int8 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLong8Sshort(int16 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLong8Slong(int32 value);
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLong8Slong8(int64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSlong8Long8(uint64 value);
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryData(TIFF* tif, uint64 offset, tmsize_t size, void* dest);
+static void TIFFReadDirEntryOutputErr(TIFF* tif, enum TIFFReadDirEntryErr err, const char* module, const char* tagname, int recover);
+
+static void TIFFReadDirectoryCheckOrder(TIFF* tif, TIFFDirEntry* dir, uint16 dircount);
+static TIFFDirEntry* TIFFReadDirectoryFindEntry(TIFF* tif, TIFFDirEntry* dir, uint16 dircount, uint16 tagid);
+static void TIFFReadDirectoryFindFieldInfo(TIFF* tif, uint16 tagid, uint32* fii);
+
+static int EstimateStripByteCounts(TIFF* tif, TIFFDirEntry* dir, uint16 dircount);
+static void MissingRequired(TIFF*, const char*);
+static int TIFFCheckDirOffset(TIFF* tif, uint64 diroff);
+static int CheckDirCount(TIFF*, TIFFDirEntry*, uint32);
+static uint16 TIFFFetchDirectory(TIFF* tif, uint64 diroff, TIFFDirEntry** pdir, uint64* nextdiroff);
+static int TIFFFetchNormalTag(TIFF*, TIFFDirEntry*, int recover);
+static int TIFFFetchStripThing(TIFF* tif, TIFFDirEntry* dir, uint32 nstrips, uint64** lpp);
+static int TIFFFetchSubjectDistance(TIFF*, TIFFDirEntry*);
+static void ChopUpSingleUncompressedStrip(TIFF*);
+static uint64 TIFFReadUInt64(const uint8 *value);
+static int _TIFFGetMaxColorChannels(uint16 photometric);
+
+static int _TIFFFillStrilesInternal( TIFF *tif, int loadStripByteCount );
+
+typedef union _UInt64Aligned_t
+{
+ double d;
+ uint64 l;
+ uint32 i[2];
+ uint16 s[4];
+ uint8 c[8];
+} UInt64Aligned_t;
+
+/*
+ Unaligned safe copy of a uint64 value from an octet array.
+*/
+static uint64 TIFFReadUInt64(const uint8 *value)
+{
+ UInt64Aligned_t result;
+
+ result.c[0]=value[0];
+ result.c[1]=value[1];
+ result.c[2]=value[2];
+ result.c[3]=value[3];
+ result.c[4]=value[4];
+ result.c[5]=value[5];
+ result.c[6]=value[6];
+ result.c[7]=value[7];
+
+ return result.l;
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryByte(TIFF* tif, TIFFDirEntry* direntry, uint8* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ TIFFReadDirEntryCheckedByte(tif,direntry,value);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeByteSbyte(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ {
+ uint16 m;
+ TIFFReadDirEntryCheckedShort(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeByteShort(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeByteSshort(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeByteLong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeByteSlong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ {
+ uint64 m;
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeByteLong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeByteSlong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint8)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8 m;
+ TIFFReadDirEntryCheckedByte(tif,direntry,&m);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeShortSbyte(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ TIFFReadDirEntryCheckedShort(tif,direntry,value);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeShortSshort(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeShortLong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeShortSlong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ {
+ uint64 m;
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeShortLong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeShortSlong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint16)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong(TIFF* tif, TIFFDirEntry* direntry, uint32* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8 m;
+ TIFFReadDirEntryCheckedByte(tif,direntry,&m);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLongSbyte(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ {
+ uint16 m;
+ TIFFReadDirEntryCheckedShort(tif,direntry,&m);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLongSshort(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ TIFFReadDirEntryCheckedLong(tif,direntry,value);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLongSlong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ {
+ uint64 m;
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeLongLong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeLongSlong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint32)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong8(TIFF* tif, TIFFDirEntry* direntry, uint64* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8 m;
+ TIFFReadDirEntryCheckedByte(tif,direntry,&m);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLong8Sbyte(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ {
+ uint16 m;
+ TIFFReadDirEntryCheckedShort(tif,direntry,&m);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLong8Sshort(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ err=TIFFReadDirEntryCheckRangeLong8Slong(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,value);
+ return(err);
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ err=TIFFReadDirEntryCheckRangeLong8Slong8(m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryFloat(TIFF* tif, TIFFDirEntry* direntry, float* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8 m;
+ TIFFReadDirEntryCheckedByte(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ {
+ uint16 m;
+ TIFFReadDirEntryCheckedShort(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ {
+ uint64 m;
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+#if defined(__WIN32__) && (_MSC_VER < 1500)
+ /*
+ * XXX: MSVC 6.0 does not support conversion
+ * of 64-bit integers into floating point
+ * values.
+ */
+ *value = _TIFFUInt64ToFloat(m);
+#else
+ *value=(float)m;
+#endif
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_RATIONAL:
+ {
+ double m;
+ err=TIFFReadDirEntryCheckedRational(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SRATIONAL:
+ {
+ double m;
+ err=TIFFReadDirEntryCheckedSrational(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_FLOAT:
+ TIFFReadDirEntryCheckedFloat(tif,direntry,value);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_DOUBLE:
+ {
+ double m;
+ err=TIFFReadDirEntryCheckedDouble(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ if ((m > FLT_MAX) || (m < FLT_MIN))
+ return(TIFFReadDirEntryErrRange);
+ *value=(float)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryDouble(TIFF* tif, TIFFDirEntry* direntry, double* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8 m;
+ TIFFReadDirEntryCheckedByte(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ {
+ int8 m;
+ TIFFReadDirEntryCheckedSbyte(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SHORT:
+ {
+ uint16 m;
+ TIFFReadDirEntryCheckedShort(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ {
+ int16 m;
+ TIFFReadDirEntryCheckedSshort(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ {
+ int32 m;
+ TIFFReadDirEntryCheckedSlong(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ {
+ uint64 m;
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+#if defined(__WIN32__) && (_MSC_VER < 1500)
+ /*
+ * XXX: MSVC 6.0 does not support conversion
+ * of 64-bit integers into floating point
+ * values.
+ */
+ *value = _TIFFUInt64ToDouble(m);
+#else
+ *value = (double)m;
+#endif
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ {
+ int64 m;
+ err=TIFFReadDirEntryCheckedSlong8(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_RATIONAL:
+ err=TIFFReadDirEntryCheckedRational(tif,direntry,value);
+ return(err);
+ case TIFF_SRATIONAL:
+ err=TIFFReadDirEntryCheckedSrational(tif,direntry,value);
+ return(err);
+ case TIFF_FLOAT:
+ {
+ float m;
+ TIFFReadDirEntryCheckedFloat(tif,direntry,&m);
+ *value=(double)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_DOUBLE:
+ err=TIFFReadDirEntryCheckedDouble(tif,direntry,value);
+ return(err);
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryIfd8(TIFF* tif, TIFFDirEntry* direntry, uint64* value)
+{
+ enum TIFFReadDirEntryErr err;
+ if (direntry->tdir_count!=1)
+ return(TIFFReadDirEntryErrCount);
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG:
+ case TIFF_IFD:
+ {
+ uint32 m;
+ TIFFReadDirEntryCheckedLong(tif,direntry,&m);
+ *value=(uint64)m;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_LONG8:
+ case TIFF_IFD8:
+ err=TIFFReadDirEntryCheckedLong8(tif,direntry,value);
+ return(err);
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+}
+
+
+#define INITIAL_THRESHOLD (1024 * 1024)
+#define THRESHOLD_MULTIPLIER 10
+#define MAX_THRESHOLD (THRESHOLD_MULTIPLIER * THRESHOLD_MULTIPLIER * THRESHOLD_MULTIPLIER * INITIAL_THRESHOLD)
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryDataAndRealloc(
+ TIFF* tif, uint64 offset, tmsize_t size, void** pdest)
+{
+#if SIZEOF_SIZE_T == 8
+ tmsize_t threshold = INITIAL_THRESHOLD;
+#endif
+ tmsize_t already_read = 0;
+
+ assert( !isMapped(tif) );
+
+ if (!SeekOK(tif,offset))
+ return(TIFFReadDirEntryErrIo);
+
+ /* On 64 bit processes, read first a maximum of 1 MB, then 10 MB, etc */
+ /* so as to avoid allocating too much memory in case the file is too */
+ /* short. We could ask for the file size, but this might be */
+ /* expensive with some I/O layers (think of reading a gzipped file) */
+ /* Restrict to 64 bit processes, so as to avoid reallocs() */
+ /* on 32 bit processes where virtual memory is scarce. */
+ while( already_read < size )
+ {
+ void* new_dest;
+ tmsize_t bytes_read;
+ tmsize_t to_read = size - already_read;
+#if SIZEOF_SIZE_T == 8
+ if( to_read >= threshold && threshold < MAX_THRESHOLD )
+ {
+ to_read = threshold;
+ threshold *= THRESHOLD_MULTIPLIER;
+ }
+#endif
+
+ new_dest = (uint8*) _TIFFrealloc(
+ *pdest, already_read + to_read);
+ if( new_dest == NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Failed to allocate memory for %s "
+ "(%ld elements of %ld bytes each)",
+ "TIFFReadDirEntryArray",
+ (long) 1, (long) (already_read + to_read));
+ return TIFFReadDirEntryErrAlloc;
+ }
+ *pdest = new_dest;
+
+ bytes_read = TIFFReadFile(tif,
+ (char*)*pdest + already_read, to_read);
+ already_read += bytes_read;
+ if (bytes_read != to_read) {
+ return TIFFReadDirEntryErrIo;
+ }
+ }
+ return TIFFReadDirEntryErrOk;
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryArrayWithLimit(
+ TIFF* tif, TIFFDirEntry* direntry, uint32* count, uint32 desttypesize,
+ void** value, uint64 maxcount)
+{
+ int typesize;
+ uint32 datasize;
+ void* data;
+ uint64 target_count64;
+ typesize=TIFFDataWidth(direntry->tdir_type);
+
+ target_count64 = (direntry->tdir_count > maxcount) ?
+ maxcount : direntry->tdir_count;
+
+ if ((target_count64==0)||(typesize==0))
+ {
+ *value=0;
+ return(TIFFReadDirEntryErrOk);
+ }
+ (void) desttypesize;
+
+ /*
+ * As a sanity check, make sure we have no more than a 2GB tag array
+ * in either the current data type or the dest data type. This also
+ * avoids problems with overflow of tmsize_t on 32bit systems.
+ */
+ if ((uint64)(2147483647/typesize)<target_count64)
+ return(TIFFReadDirEntryErrSizesan);
+ if ((uint64)(2147483647/desttypesize)<target_count64)
+ return(TIFFReadDirEntryErrSizesan);
+
+ *count=(uint32)target_count64;
+ datasize=(*count)*typesize;
+ assert((tmsize_t)datasize>0);
+
+ if( isMapped(tif) && datasize > (uint32)tif->tif_size )
+ return TIFFReadDirEntryErrIo;
+
+ if( !isMapped(tif) &&
+ (((tif->tif_flags&TIFF_BIGTIFF) && datasize > 8) ||
+ (!(tif->tif_flags&TIFF_BIGTIFF) && datasize > 4)) )
+ {
+ data = NULL;
+ }
+ else
+ {
+ data=_TIFFCheckMalloc(tif, *count, typesize, "ReadDirEntryArray");
+ if (data==0)
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (datasize<=4)
+ _TIFFmemcpy(data,&direntry->tdir_offset,datasize);
+ else
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ if( isMapped(tif) )
+ err=TIFFReadDirEntryData(tif,(uint64)offset,(tmsize_t)datasize,data);
+ else
+ err=TIFFReadDirEntryDataAndRealloc(tif,(uint64)offset,(tmsize_t)datasize,&data);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ }
+ }
+ else
+ {
+ if (datasize<=8)
+ _TIFFmemcpy(data,&direntry->tdir_offset,datasize);
+ else
+ {
+ enum TIFFReadDirEntryErr err;
+ uint64 offset = direntry->tdir_offset.toff_long8;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(&offset);
+ if( isMapped(tif) )
+ err=TIFFReadDirEntryData(tif,(uint64)offset,(tmsize_t)datasize,data);
+ else
+ err=TIFFReadDirEntryDataAndRealloc(tif,(uint64)offset,(tmsize_t)datasize,&data);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ }
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryArray(TIFF* tif, TIFFDirEntry* direntry, uint32* count, uint32 desttypesize, void** value)
+{
+ return TIFFReadDirEntryArrayWithLimit(tif, direntry, count,
+ desttypesize, value, ~((uint64)0));
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryByteArray(TIFF* tif, TIFFDirEntry* direntry, uint8** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ uint8* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_ASCII:
+ case TIFF_UNDEFINED:
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,1,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_ASCII:
+ case TIFF_UNDEFINED:
+ case TIFF_BYTE:
+ *value=(uint8*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SBYTE:
+ {
+ int8* m;
+ uint32 n;
+ m=(int8*)origdata;
+ for (n=0; n<count; n++)
+ {
+ err=TIFFReadDirEntryCheckRangeByteSbyte(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(uint8*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ }
+ data=(uint8*)_TIFFmalloc(count);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ err=TIFFReadDirEntryCheckRangeByteShort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ err=TIFFReadDirEntryCheckRangeByteSshort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ err=TIFFReadDirEntryCheckRangeByteLong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ err=TIFFReadDirEntryCheckRangeByteSlong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeByteLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ uint8* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeByteSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint8)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySbyteArray(TIFF* tif, TIFFDirEntry* direntry, int8** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ int8* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_UNDEFINED:
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,1,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_UNDEFINED:
+ case TIFF_BYTE:
+ {
+ uint8* m;
+ uint32 n;
+ m=(uint8*)origdata;
+ for (n=0; n<count; n++)
+ {
+ err=TIFFReadDirEntryCheckRangeSbyteByte(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(int8*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SBYTE:
+ *value=(int8*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(int8*)_TIFFmalloc(count);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ int8* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ err=TIFFReadDirEntryCheckRangeSbyteShort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ int8* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ err=TIFFReadDirEntryCheckRangeSbyteSshort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ int8* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ err=TIFFReadDirEntryCheckRangeSbyteLong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ int8* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ err=TIFFReadDirEntryCheckRangeSbyteSlong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ int8* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeSbyteLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ int8* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeSbyteSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int8)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryShortArray(TIFF* tif, TIFFDirEntry* direntry, uint16** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ uint16* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,2,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_SHORT:
+ *value=(uint16*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfShort(*value,count);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SSHORT:
+ {
+ int16* m;
+ uint32 n;
+ m=(int16*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)m);
+ err=TIFFReadDirEntryCheckRangeShortSshort(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(uint16*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ }
+ data=(uint16*)_TIFFmalloc(count*2);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(uint16)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ err=TIFFReadDirEntryCheckRangeShortSbyte(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ err=TIFFReadDirEntryCheckRangeShortLong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ err=TIFFReadDirEntryCheckRangeShortSlong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeShortLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ uint16* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeShortSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint16)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySshortArray(TIFF* tif, TIFFDirEntry* direntry, int16** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ int16* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,2,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_SHORT:
+ {
+ uint16* m;
+ uint32 n;
+ m=(uint16*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(m);
+ err=TIFFReadDirEntryCheckRangeSshortShort(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(int16*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SSHORT:
+ *value=(int16*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfShort((uint16*)(*value),count);
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(int16*)_TIFFmalloc(count*2);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ int16* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int16)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ int16* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int16)(*ma++);
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ int16* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ err=TIFFReadDirEntryCheckRangeSshortLong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ int16* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ err=TIFFReadDirEntryCheckRangeSshortSlong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ int16* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeSshortLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int16)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ int16* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeSshortSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int16)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLongArray(TIFF* tif, TIFFDirEntry* direntry, uint32** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ uint32* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,4,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG:
+ *value=(uint32*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(*value,count);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SLONG:
+ {
+ int32* m;
+ uint32 n;
+ m=(int32*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)m);
+ err=TIFFReadDirEntryCheckRangeLongSlong(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(uint32*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ }
+ data=(uint32*)_TIFFmalloc(count*4);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(uint32)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ err=TIFFReadDirEntryCheckRangeLongSbyte(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(uint32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ err=TIFFReadDirEntryCheckRangeLongSshort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeLongLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ uint32* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeLongSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint32)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySlongArray(TIFF* tif, TIFFDirEntry* direntry, int32** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ int32* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,4,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG:
+ {
+ uint32* m;
+ uint32 n;
+ m=(uint32*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)m);
+ err=TIFFReadDirEntryCheckRangeSlongLong(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(int32*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG:
+ *value=(int32*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong((uint32*)(*value),count);
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(int32*)_TIFFmalloc(count*4);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ int32* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int32)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ int32* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int32)(*ma++);
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ int32* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(int32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ int32* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ *mb++=(int32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ int32* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+ err=TIFFReadDirEntryCheckRangeSlongLong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int32)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ int32* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ err=TIFFReadDirEntryCheckRangeSlongSlong8(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(int32)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong8ArrayWithLimit(
+ TIFF* tif, TIFFDirEntry* direntry, uint64** value, uint64 maxcount)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ uint64* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArrayWithLimit(tif,direntry,&count,8,&origdata,maxcount);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG8:
+ *value=(uint64*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8(*value,count);
+ return(TIFFReadDirEntryErrOk);
+ case TIFF_SLONG8:
+ {
+ int64* m;
+ uint32 n;
+ m=(int64*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)m);
+ err=TIFFReadDirEntryCheckRangeLong8Slong8(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(uint64*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ }
+ data=(uint64*)_TIFFmalloc(count*8);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(uint64)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ err=TIFFReadDirEntryCheckRangeLong8Sbyte(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ err=TIFFReadDirEntryCheckRangeLong8Sshort(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ err=TIFFReadDirEntryCheckRangeLong8Slong(*ma);
+ if (err!=TIFFReadDirEntryErrOk)
+ break;
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(data);
+ return(err);
+ }
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryLong8Array(TIFF* tif, TIFFDirEntry* direntry, uint64** value)
+{
+ return TIFFReadDirEntryLong8ArrayWithLimit(tif, direntry, value, ~((uint64)0));
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntrySlong8Array(TIFF* tif, TIFFDirEntry* direntry, int64** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ int64* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,8,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG8:
+ {
+ uint64* m;
+ uint32 n;
+ m=(uint64*)origdata;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(m);
+ err=TIFFReadDirEntryCheckRangeSlong8Long8(*m);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ _TIFFfree(origdata);
+ return(err);
+ }
+ m++;
+ }
+ *value=(int64*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ case TIFF_SLONG8:
+ *value=(int64*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8((uint64*)(*value),count);
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(int64*)_TIFFmalloc(count*8);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ int64* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int64)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ int64* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(int64)(*ma++);
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ int64* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(int64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ int64* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ *mb++=(int64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ int64* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ *mb++=(int64)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ int64* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ *mb++=(int64)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryFloatArray(TIFF* tif, TIFFDirEntry* direntry, float** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ float* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ case TIFF_DOUBLE:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,4,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_FLOAT:
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong((uint32*)origdata,count);
+ TIFFCvtIEEEDoubleToNative(tif,count,(float*)origdata);
+ *value=(float*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(float*)_TIFFmalloc(count*sizeof(float));
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ float* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(float)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ float* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(float)(*ma++);
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ float* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(float)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ float* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ *mb++=(float)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ float* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ *mb++=(float)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ float* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ *mb++=(float)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ float* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+#if defined(__WIN32__) && (_MSC_VER < 1500)
+ /*
+ * XXX: MSVC 6.0 does not support
+ * conversion of 64-bit integers into
+ * floating point values.
+ */
+ *mb++ = _TIFFUInt64ToFloat(*ma++);
+#else
+ *mb++ = (float)(*ma++);
+#endif
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ float* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ *mb++=(float)(*ma++);
+ }
+ }
+ break;
+ case TIFF_RATIONAL:
+ {
+ uint32* ma;
+ uint32 maa;
+ uint32 mab;
+ float* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ maa=*ma++;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ mab=*ma++;
+ if (mab==0)
+ *mb++=0.0;
+ else
+ *mb++=(float)maa/(float)mab;
+ }
+ }
+ break;
+ case TIFF_SRATIONAL:
+ {
+ uint32* ma;
+ int32 maa;
+ uint32 mab;
+ float* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ maa=*(int32*)ma;
+ ma++;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ mab=*ma++;
+ if (mab==0)
+ *mb++=0.0;
+ else
+ *mb++=(float)maa/(float)mab;
+ }
+ }
+ break;
+ case TIFF_DOUBLE:
+ {
+ double* ma;
+ float* mb;
+ uint32 n;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8((uint64*)origdata,count);
+ TIFFCvtIEEEDoubleToNative(tif,count,(double*)origdata);
+ ma=(double*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ double val = *ma++;
+ if( val > FLT_MAX )
+ val = FLT_MAX;
+ else if( val < -FLT_MAX )
+ val = -FLT_MAX;
+ *mb++=(float)val;
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryDoubleArray(TIFF* tif, TIFFDirEntry* direntry, double** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ double* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ case TIFF_SBYTE:
+ case TIFF_SHORT:
+ case TIFF_SSHORT:
+ case TIFF_LONG:
+ case TIFF_SLONG:
+ case TIFF_LONG8:
+ case TIFF_SLONG8:
+ case TIFF_RATIONAL:
+ case TIFF_SRATIONAL:
+ case TIFF_FLOAT:
+ case TIFF_DOUBLE:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,8,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_DOUBLE:
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8((uint64*)origdata,count);
+ TIFFCvtIEEEDoubleToNative(tif,count,(double*)origdata);
+ *value=(double*)origdata;
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(double*)_TIFFmalloc(count*sizeof(double));
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_BYTE:
+ {
+ uint8* ma;
+ double* mb;
+ uint32 n;
+ ma=(uint8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(double)(*ma++);
+ }
+ break;
+ case TIFF_SBYTE:
+ {
+ int8* ma;
+ double* mb;
+ uint32 n;
+ ma=(int8*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(double)(*ma++);
+ }
+ break;
+ case TIFF_SHORT:
+ {
+ uint16* ma;
+ double* mb;
+ uint32 n;
+ ma=(uint16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(ma);
+ *mb++=(double)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SSHORT:
+ {
+ int16* ma;
+ double* mb;
+ uint32 n;
+ ma=(int16*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ *mb++=(double)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG:
+ {
+ uint32* ma;
+ double* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ *mb++=(double)(*ma++);
+ }
+ }
+ break;
+ case TIFF_SLONG:
+ {
+ int32* ma;
+ double* mb;
+ uint32 n;
+ ma=(int32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ *mb++=(double)(*ma++);
+ }
+ }
+ break;
+ case TIFF_LONG8:
+ {
+ uint64* ma;
+ double* mb;
+ uint32 n;
+ ma=(uint64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(ma);
+#if defined(__WIN32__) && (_MSC_VER < 1500)
+ /*
+ * XXX: MSVC 6.0 does not support
+ * conversion of 64-bit integers into
+ * floating point values.
+ */
+ *mb++ = _TIFFUInt64ToDouble(*ma++);
+#else
+ *mb++ = (double)(*ma++);
+#endif
+ }
+ }
+ break;
+ case TIFF_SLONG8:
+ {
+ int64* ma;
+ double* mb;
+ uint32 n;
+ ma=(int64*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ *mb++=(double)(*ma++);
+ }
+ }
+ break;
+ case TIFF_RATIONAL:
+ {
+ uint32* ma;
+ uint32 maa;
+ uint32 mab;
+ double* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ maa=*ma++;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ mab=*ma++;
+ if (mab==0)
+ *mb++=0.0;
+ else
+ *mb++=(double)maa/(double)mab;
+ }
+ }
+ break;
+ case TIFF_SRATIONAL:
+ {
+ uint32* ma;
+ int32 maa;
+ uint32 mab;
+ double* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ maa=*(int32*)ma;
+ ma++;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ mab=*ma++;
+ if (mab==0)
+ *mb++=0.0;
+ else
+ *mb++=(double)maa/(double)mab;
+ }
+ }
+ break;
+ case TIFF_FLOAT:
+ {
+ float* ma;
+ double* mb;
+ uint32 n;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong((uint32*)origdata,count);
+ TIFFCvtIEEEFloatToNative(tif,count,(float*)origdata);
+ ma=(float*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ *mb++=(double)(*ma++);
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryIfd8Array(TIFF* tif, TIFFDirEntry* direntry, uint64** value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint32 count;
+ void* origdata;
+ uint64* data;
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG:
+ case TIFF_LONG8:
+ case TIFF_IFD:
+ case TIFF_IFD8:
+ break;
+ default:
+ return(TIFFReadDirEntryErrType);
+ }
+ err=TIFFReadDirEntryArray(tif,direntry,&count,8,&origdata);
+ if ((err!=TIFFReadDirEntryErrOk)||(origdata==0))
+ {
+ *value=0;
+ return(err);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG8:
+ case TIFF_IFD8:
+ *value=(uint64*)origdata;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8(*value,count);
+ return(TIFFReadDirEntryErrOk);
+ }
+ data=(uint64*)_TIFFmalloc(count*8);
+ if (data==0)
+ {
+ _TIFFfree(origdata);
+ return(TIFFReadDirEntryErrAlloc);
+ }
+ switch (direntry->tdir_type)
+ {
+ case TIFF_LONG:
+ case TIFF_IFD:
+ {
+ uint32* ma;
+ uint64* mb;
+ uint32 n;
+ ma=(uint32*)origdata;
+ mb=data;
+ for (n=0; n<count; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(ma);
+ *mb++=(uint64)(*ma++);
+ }
+ }
+ break;
+ }
+ _TIFFfree(origdata);
+ *value=data;
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryPersampleShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value)
+{
+ enum TIFFReadDirEntryErr err;
+ uint16* m;
+ uint16* na;
+ uint16 nb;
+ if (direntry->tdir_count<(uint64)tif->tif_dir.td_samplesperpixel)
+ return(TIFFReadDirEntryErrCount);
+ err=TIFFReadDirEntryShortArray(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk || m == NULL)
+ return(err);
+ na=m;
+ nb=tif->tif_dir.td_samplesperpixel;
+ *value=*na++;
+ nb--;
+ while (nb>0)
+ {
+ if (*na++!=*value)
+ {
+ err=TIFFReadDirEntryErrPsdif;
+ break;
+ }
+ nb--;
+ }
+ _TIFFfree(m);
+ return(err);
+}
+
+#if 0
+static enum TIFFReadDirEntryErr TIFFReadDirEntryPersampleDouble(TIFF* tif, TIFFDirEntry* direntry, double* value)
+{
+ enum TIFFReadDirEntryErr err;
+ double* m;
+ double* na;
+ uint16 nb;
+ if (direntry->tdir_count<(uint64)tif->tif_dir.td_samplesperpixel)
+ return(TIFFReadDirEntryErrCount);
+ err=TIFFReadDirEntryDoubleArray(tif,direntry,&m);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ na=m;
+ nb=tif->tif_dir.td_samplesperpixel;
+ *value=*na++;
+ nb--;
+ while (nb>0)
+ {
+ if (*na++!=*value)
+ {
+ err=TIFFReadDirEntryErrPsdif;
+ break;
+ }
+ nb--;
+ }
+ _TIFFfree(m);
+ return(err);
+}
+#endif
+
+static void TIFFReadDirEntryCheckedByte(TIFF* tif, TIFFDirEntry* direntry, uint8* value)
+{
+ (void) tif;
+ *value=*(uint8*)(&direntry->tdir_offset);
+}
+
+static void TIFFReadDirEntryCheckedSbyte(TIFF* tif, TIFFDirEntry* direntry, int8* value)
+{
+ (void) tif;
+ *value=*(int8*)(&direntry->tdir_offset);
+}
+
+static void TIFFReadDirEntryCheckedShort(TIFF* tif, TIFFDirEntry* direntry, uint16* value)
+{
+ *value = direntry->tdir_offset.toff_short;
+ /* *value=*(uint16*)(&direntry->tdir_offset); */
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(value);
+}
+
+static void TIFFReadDirEntryCheckedSshort(TIFF* tif, TIFFDirEntry* direntry, int16* value)
+{
+ *value=*(int16*)(&direntry->tdir_offset);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)value);
+}
+
+static void TIFFReadDirEntryCheckedLong(TIFF* tif, TIFFDirEntry* direntry, uint32* value)
+{
+ *value=*(uint32*)(&direntry->tdir_offset);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(value);
+}
+
+static void TIFFReadDirEntryCheckedSlong(TIFF* tif, TIFFDirEntry* direntry, int32* value)
+{
+ *value=*(int32*)(&direntry->tdir_offset);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)value);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedLong8(TIFF* tif, TIFFDirEntry* direntry, uint64* value)
+{
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,value);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ }
+ else
+ *value = direntry->tdir_offset.toff_long8;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(value);
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedSlong8(TIFF* tif, TIFFDirEntry* direntry, int64* value)
+{
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,value);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ }
+ else
+ *value=*(int64*)(&direntry->tdir_offset);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)value);
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedRational(TIFF* tif, TIFFDirEntry* direntry, double* value)
+{
+ UInt64Aligned_t m;
+
+ assert(sizeof(double)==8);
+ assert(sizeof(uint64)==8);
+ assert(sizeof(uint32)==4);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,m.i);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ }
+ else
+ m.l = direntry->tdir_offset.toff_long8;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(m.i,2);
+ /* Not completely sure what we should do when m.i[1]==0, but some */
+ /* sanitizers do not like division by 0.0: */
+ /* http://bugzilla.maptools.org/show_bug.cgi?id=2644 */
+ if (m.i[0]==0 || m.i[1]==0)
+ *value=0.0;
+ else
+ *value=(double)m.i[0]/(double)m.i[1];
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedSrational(TIFF* tif, TIFFDirEntry* direntry, double* value)
+{
+ UInt64Aligned_t m;
+ assert(sizeof(double)==8);
+ assert(sizeof(uint64)==8);
+ assert(sizeof(int32)==4);
+ assert(sizeof(uint32)==4);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,m.i);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ }
+ else
+ m.l=direntry->tdir_offset.toff_long8;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(m.i,2);
+ /* Not completely sure what we should do when m.i[1]==0, but some */
+ /* sanitizers do not like division by 0.0: */
+ /* http://bugzilla.maptools.org/show_bug.cgi?id=2644 */
+ if ((int32)m.i[0]==0 || m.i[1]==0)
+ *value=0.0;
+ else
+ *value=(double)((int32)m.i[0])/(double)m.i[1];
+ return(TIFFReadDirEntryErrOk);
+}
+
+static void TIFFReadDirEntryCheckedFloat(TIFF* tif, TIFFDirEntry* direntry, float* value)
+{
+ union
+ {
+ float f;
+ uint32 i;
+ } float_union;
+ assert(sizeof(float)==4);
+ assert(sizeof(uint32)==4);
+ assert(sizeof(float_union)==4);
+ float_union.i=*(uint32*)(&direntry->tdir_offset);
+ *value=float_union.f;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)value);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckedDouble(TIFF* tif, TIFFDirEntry* direntry, double* value)
+{
+ assert(sizeof(double)==8);
+ assert(sizeof(uint64)==8);
+ assert(sizeof(UInt64Aligned_t)==8);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 offset = direntry->tdir_offset.toff_long;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,value);
+ if (err!=TIFFReadDirEntryErrOk)
+ return(err);
+ }
+ else
+ {
+ UInt64Aligned_t uint64_union;
+ uint64_union.l=direntry->tdir_offset.toff_long8;
+ *value=uint64_union.d;
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)value);
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSbyte(int8 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteShort(uint16 value)
+{
+ if (value>0xFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSshort(int16 value)
+{
+ if ((value<0)||(value>0xFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteLong(uint32 value)
+{
+ if (value>0xFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSlong(int32 value)
+{
+ if ((value<0)||(value>0xFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteLong8(uint64 value)
+{
+ if (value>0xFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeByteSlong8(int64 value)
+{
+ if ((value<0)||(value>0xFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteByte(uint8 value)
+{
+ if (value>0x7F)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteShort(uint16 value)
+{
+ if (value>0x7F)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSshort(int16 value)
+{
+ if ((value<-0x80)||(value>0x7F))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteLong(uint32 value)
+{
+ if (value>0x7F)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSlong(int32 value)
+{
+ if ((value<-0x80)||(value>0x7F))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteLong8(uint64 value)
+{
+ if (value>0x7F)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSbyteSlong8(int64 value)
+{
+ if ((value<-0x80)||(value>0x7F))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSbyte(int8 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSshort(int16 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortLong(uint32 value)
+{
+ if (value>0xFFFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSlong(int32 value)
+{
+ if ((value<0)||(value>0xFFFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortLong8(uint64 value)
+{
+ if (value>0xFFFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeShortSlong8(int64 value)
+{
+ if ((value<0)||(value>0xFFFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortShort(uint16 value)
+{
+ if (value>0x7FFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortLong(uint32 value)
+{
+ if (value>0x7FFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortSlong(int32 value)
+{
+ if ((value<-0x8000)||(value>0x7FFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortLong8(uint64 value)
+{
+ if (value>0x7FFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeSshortSlong8(int64 value)
+{
+ if ((value<-0x8000)||(value>0x7FFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSbyte(int8 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSshort(int16 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr TIFFReadDirEntryCheckRangeLongSlong(int32 value)
+{
+ if (value<0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+/*
+ * Largest 32-bit unsigned integer value.
+ */
+#define TIFF_UINT32_MAX 0xFFFFFFFFU
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLongLong8(uint64 value)
+{
+ if (value > TIFF_UINT32_MAX)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLongSlong8(int64 value)
+{
+ if ((value < 0) || (value > (int64) TIFF_UINT32_MAX))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+#undef TIFF_UINT32_MAX
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeSlongLong(uint32 value)
+{
+ if (value > 0x7FFFFFFFUL)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+/* Check that the 8-byte unsigned value can fit in a 4-byte unsigned range */
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeSlongLong8(uint64 value)
+{
+ if (value > 0x7FFFFFFF)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+/* Check that the 8-byte signed value can fit in a 4-byte signed range */
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeSlongSlong8(int64 value)
+{
+ if ((value < 0-((int64) 0x7FFFFFFF+1)) || (value > 0x7FFFFFFF))
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLong8Sbyte(int8 value)
+{
+ if (value < 0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLong8Sshort(int16 value)
+{
+ if (value < 0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLong8Slong(int32 value)
+{
+ if (value < 0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeLong8Slong8(int64 value)
+{
+ if (value < 0)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+/*
+ * Largest 64-bit signed integer value.
+ */
+#define TIFF_INT64_MAX ((int64)(((uint64) ~0) >> 1))
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryCheckRangeSlong8Long8(uint64 value)
+{
+ if (value > TIFF_INT64_MAX)
+ return(TIFFReadDirEntryErrRange);
+ else
+ return(TIFFReadDirEntryErrOk);
+}
+
+#undef TIFF_INT64_MAX
+
+static enum TIFFReadDirEntryErr
+TIFFReadDirEntryData(TIFF* tif, uint64 offset, tmsize_t size, void* dest)
+{
+ assert(size>0);
+ if (!isMapped(tif)) {
+ if (!SeekOK(tif,offset))
+ return(TIFFReadDirEntryErrIo);
+ if (!ReadOK(tif,dest,size))
+ return(TIFFReadDirEntryErrIo);
+ } else {
+ size_t ma,mb;
+ ma=(size_t)offset;
+ mb=ma+size;
+ if (((uint64)ma!=offset)
+ || (mb < ma)
+ || (mb - ma != (size_t) size)
+ || (mb < (size_t)size)
+ || (mb > (size_t)tif->tif_size)
+ )
+ return(TIFFReadDirEntryErrIo);
+ _TIFFmemcpy(dest,tif->tif_base+ma,size);
+ }
+ return(TIFFReadDirEntryErrOk);
+}
+
+static void TIFFReadDirEntryOutputErr(TIFF* tif, enum TIFFReadDirEntryErr err, const char* module, const char* tagname, int recover)
+{
+ if (!recover) {
+ switch (err) {
+ case TIFFReadDirEntryErrCount:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Incorrect count for \"%s\"",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrType:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Incompatible type for \"%s\"",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrIo:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "IO error during reading of \"%s\"",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrRange:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Incorrect value for \"%s\"",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrPsdif:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot handle different values per sample for \"%s\"",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrSizesan:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on size of \"%s\" value failed",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrAlloc:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Out of memory reading of \"%s\"",
+ tagname);
+ break;
+ default:
+ assert(0); /* we should never get here */
+ break;
+ }
+ } else {
+ switch (err) {
+ case TIFFReadDirEntryErrCount:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Incorrect count for \"%s\"; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrType:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Incompatible type for \"%s\"; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrIo:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "IO error during reading of \"%s\"; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrRange:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Incorrect value for \"%s\"; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrPsdif:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Cannot handle different values per sample for \"%s\"; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrSizesan:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Sanity check on size of \"%s\" value failed; tag ignored",
+ tagname);
+ break;
+ case TIFFReadDirEntryErrAlloc:
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Out of memory reading of \"%s\"; tag ignored",
+ tagname);
+ break;
+ default:
+ assert(0); /* we should never get here */
+ break;
+ }
+ }
+}
+
+/*
+ * Return the maximum number of color channels specified for a given photometric
+ * type. 0 is returned if photometric type isn't supported or no default value
+ * is defined by the specification.
+ */
+static int _TIFFGetMaxColorChannels( uint16 photometric )
+{
+ switch (photometric) {
+ case PHOTOMETRIC_PALETTE:
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ return 1;
+ case PHOTOMETRIC_YCBCR:
+ case PHOTOMETRIC_RGB:
+ case PHOTOMETRIC_CIELAB:
+ case PHOTOMETRIC_LOGLUV:
+ case PHOTOMETRIC_ITULAB:
+ case PHOTOMETRIC_ICCLAB:
+ return 3;
+ case PHOTOMETRIC_SEPARATED:
+ case PHOTOMETRIC_MASK:
+ return 4;
+ case PHOTOMETRIC_LOGL:
+ case PHOTOMETRIC_CFA:
+ default:
+ return 0;
+ }
+}
+
+/*
+ * Read the next TIFF directory from a file and convert it to the internal
+ * format. We read directories sequentially.
+ */
+int
+TIFFReadDirectory(TIFF* tif)
+{
+ static const char module[] = "TIFFReadDirectory";
+ TIFFDirEntry* dir;
+ uint16 dircount;
+ TIFFDirEntry* dp;
+ uint16 di;
+ const TIFFField* fip;
+ uint32 fii=FAILED_FII;
+ toff_t nextdiroff;
+ int bitspersample_read = FALSE;
+ int color_channels;
+
+ tif->tif_diroff=tif->tif_nextdiroff;
+ if (!TIFFCheckDirOffset(tif,tif->tif_nextdiroff))
+ return 0; /* last offset or bad offset (IFD looping) */
+ (*tif->tif_cleanup)(tif); /* cleanup any previous compression state */
+ tif->tif_curdir++;
+ nextdiroff = tif->tif_nextdiroff;
+ dircount=TIFFFetchDirectory(tif,nextdiroff,&dir,&tif->tif_nextdiroff);
+ if (!dircount)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Failed to read directory at offset " TIFF_UINT64_FORMAT,nextdiroff);
+ return 0;
+ }
+ TIFFReadDirectoryCheckOrder(tif,dir,dircount);
+
+ /*
+ * Mark duplicates of any tag to be ignored (bugzilla 1994)
+ * to avoid certain pathological problems.
+ */
+ {
+ TIFFDirEntry* ma;
+ uint16 mb;
+ for (ma=dir, mb=0; mb<dircount; ma++, mb++)
+ {
+ TIFFDirEntry* na;
+ uint16 nb;
+ for (na=ma+1, nb=mb+1; nb<dircount; na++, nb++)
+ {
+ if (ma->tdir_tag==na->tdir_tag)
+ na->tdir_tag=IGNORE;
+ }
+ }
+ }
+
+ tif->tif_flags &= ~TIFF_BEENWRITING; /* reset before new dir */
+ tif->tif_flags &= ~TIFF_BUF4WRITE; /* reset before new dir */
+ /* free any old stuff and reinit */
+ TIFFFreeDirectory(tif);
+ TIFFDefaultDirectory(tif);
+ /*
+ * Electronic Arts writes gray-scale TIFF files
+ * without a PlanarConfiguration directory entry.
+ * Thus we setup a default value here, even though
+ * the TIFF spec says there is no default value.
+ */
+ TIFFSetField(tif,TIFFTAG_PLANARCONFIG,PLANARCONFIG_CONTIG);
+ /*
+ * Setup default value and then make a pass over
+ * the fields to check type and tag information,
+ * and to extract info required to size data
+ * structures. A second pass is made afterwards
+ * to read in everything not taken in the first pass.
+ * But we must process the Compression tag first
+ * in order to merge in codec-private tag definitions (otherwise
+ * we may get complaints about unknown tags). However, the
+ * Compression tag may be dependent on the SamplesPerPixel
+ * tag value because older TIFF specs permitted Compression
+ * to be written as a SamplesPerPixel-count tag entry.
+ * Thus if we don't first figure out the correct SamplesPerPixel
+ * tag value then we may end up ignoring the Compression tag
+ * value because it has an incorrect count value (if the
+ * true value of SamplesPerPixel is not 1).
+ */
+ dp=TIFFReadDirectoryFindEntry(tif,dir,dircount,TIFFTAG_SAMPLESPERPIXEL);
+ if (dp)
+ {
+ if (!TIFFFetchNormalTag(tif,dp,0))
+ goto bad;
+ dp->tdir_tag=IGNORE;
+ }
+ dp=TIFFReadDirectoryFindEntry(tif,dir,dircount,TIFFTAG_COMPRESSION);
+ if (dp)
+ {
+ /*
+ * The 5.0 spec says the Compression tag has one value, while
+ * earlier specs say it has one value per sample. Because of
+ * this, we accept the tag if one value is supplied with either
+ * count.
+ */
+ uint16 value;
+ enum TIFFReadDirEntryErr err;
+ err=TIFFReadDirEntryShort(tif,dp,&value);
+ if (err==TIFFReadDirEntryErrCount)
+ err=TIFFReadDirEntryPersampleShort(tif,dp,&value);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ TIFFReadDirEntryOutputErr(tif,err,module,"Compression",0);
+ goto bad;
+ }
+ if (!TIFFSetField(tif,TIFFTAG_COMPRESSION,value))
+ goto bad;
+ dp->tdir_tag=IGNORE;
+ }
+ else
+ {
+ if (!TIFFSetField(tif,TIFFTAG_COMPRESSION,COMPRESSION_NONE))
+ goto bad;
+ }
+ /*
+ * First real pass over the directory.
+ */
+ for (di=0, dp=dir; di<dircount; di++, dp++)
+ {
+ if (dp->tdir_tag!=IGNORE)
+ {
+ TIFFReadDirectoryFindFieldInfo(tif,dp->tdir_tag,&fii);
+ if (fii == FAILED_FII)
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Unknown field with tag %d (0x%x) encountered",
+ dp->tdir_tag,dp->tdir_tag);
+ /* the following knowingly leaks the
+ anonymous field structure */
+ if (!_TIFFMergeFields(tif,
+ _TIFFCreateAnonField(tif,
+ dp->tdir_tag,
+ (TIFFDataType) dp->tdir_type),
+ 1)) {
+ TIFFWarningExt(tif->tif_clientdata,
+ module,
+ "Registering anonymous field with tag %d (0x%x) failed",
+ dp->tdir_tag,
+ dp->tdir_tag);
+ dp->tdir_tag=IGNORE;
+ } else {
+ TIFFReadDirectoryFindFieldInfo(tif,dp->tdir_tag,&fii);
+ assert(fii != FAILED_FII);
+ }
+ }
+ }
+ if (dp->tdir_tag!=IGNORE)
+ {
+ fip=tif->tif_fields[fii];
+ if (fip->field_bit==FIELD_IGNORE)
+ dp->tdir_tag=IGNORE;
+ else
+ {
+ switch (dp->tdir_tag)
+ {
+ case TIFFTAG_STRIPOFFSETS:
+ case TIFFTAG_STRIPBYTECOUNTS:
+ case TIFFTAG_TILEOFFSETS:
+ case TIFFTAG_TILEBYTECOUNTS:
+ TIFFSetFieldBit(tif,fip->field_bit);
+ break;
+ case TIFFTAG_IMAGEWIDTH:
+ case TIFFTAG_IMAGELENGTH:
+ case TIFFTAG_IMAGEDEPTH:
+ case TIFFTAG_TILELENGTH:
+ case TIFFTAG_TILEWIDTH:
+ case TIFFTAG_TILEDEPTH:
+ case TIFFTAG_PLANARCONFIG:
+ case TIFFTAG_ROWSPERSTRIP:
+ case TIFFTAG_EXTRASAMPLES:
+ if (!TIFFFetchNormalTag(tif,dp,0))
+ goto bad;
+ dp->tdir_tag=IGNORE;
+ break;
+ default:
+ if( !_TIFFCheckFieldIsValidForCodec(tif, dp->tdir_tag) )
+ dp->tdir_tag=IGNORE;
+ break;
+ }
+ }
+ }
+ }
+ /*
+ * XXX: OJPEG hack.
+ * If a) compression is OJPEG, b) planarconfig tag says it's separate,
+ * c) strip offsets/bytecounts tag are both present and
+ * d) both contain exactly one value, then we consistently find
+ * that the buggy implementation of the buggy compression scheme
+ * matches contig planarconfig best. So we 'fix-up' the tag here
+ */
+ if ((tif->tif_dir.td_compression==COMPRESSION_OJPEG)&&
+ (tif->tif_dir.td_planarconfig==PLANARCONFIG_SEPARATE))
+ {
+ if (!_TIFFFillStriles(tif))
+ goto bad;
+ dp=TIFFReadDirectoryFindEntry(tif,dir,dircount,TIFFTAG_STRIPOFFSETS);
+ if ((dp!=0)&&(dp->tdir_count==1))
+ {
+ dp=TIFFReadDirectoryFindEntry(tif,dir,dircount,
+ TIFFTAG_STRIPBYTECOUNTS);
+ if ((dp!=0)&&(dp->tdir_count==1))
+ {
+ tif->tif_dir.td_planarconfig=PLANARCONFIG_CONTIG;
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Planarconfig tag value assumed incorrect, "
+ "assuming data is contig instead of chunky");
+ }
+ }
+ }
+ /*
+ * Allocate directory structure and setup defaults.
+ */
+ if (!TIFFFieldSet(tif,FIELD_IMAGEDIMENSIONS))
+ {
+ MissingRequired(tif,"ImageLength");
+ goto bad;
+ }
+ /*
+ * Setup appropriate structures (by strip or by tile)
+ */
+ if (!TIFFFieldSet(tif, FIELD_TILEDIMENSIONS)) {
+ tif->tif_dir.td_nstrips = TIFFNumberOfStrips(tif);
+ tif->tif_dir.td_tilewidth = tif->tif_dir.td_imagewidth;
+ tif->tif_dir.td_tilelength = tif->tif_dir.td_rowsperstrip;
+ tif->tif_dir.td_tiledepth = tif->tif_dir.td_imagedepth;
+ tif->tif_flags &= ~TIFF_ISTILED;
+ } else {
+ tif->tif_dir.td_nstrips = TIFFNumberOfTiles(tif);
+ tif->tif_flags |= TIFF_ISTILED;
+ }
+ if (!tif->tif_dir.td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot handle zero number of %s",
+ isTiled(tif) ? "tiles" : "strips");
+ goto bad;
+ }
+ tif->tif_dir.td_stripsperimage = tif->tif_dir.td_nstrips;
+ if (tif->tif_dir.td_planarconfig == PLANARCONFIG_SEPARATE)
+ tif->tif_dir.td_stripsperimage /= tif->tif_dir.td_samplesperpixel;
+ if (!TIFFFieldSet(tif, FIELD_STRIPOFFSETS)) {
+#ifdef OJPEG_SUPPORT
+ if ((tif->tif_dir.td_compression==COMPRESSION_OJPEG) &&
+ (isTiled(tif)==0) &&
+ (tif->tif_dir.td_nstrips==1)) {
+ /*
+ * XXX: OJPEG hack.
+ * If a) compression is OJPEG, b) it's not a tiled TIFF,
+ * and c) the number of strips is 1,
+ * then we tolerate the absence of stripoffsets tag,
+ * because, presumably, all required data is in the
+ * JpegInterchangeFormat stream.
+ */
+ TIFFSetFieldBit(tif, FIELD_STRIPOFFSETS);
+ } else
+#endif
+ {
+ MissingRequired(tif,
+ isTiled(tif) ? "TileOffsets" : "StripOffsets");
+ goto bad;
+ }
+ }
+ /*
+ * Second pass: extract other information.
+ */
+ for (di=0, dp=dir; di<dircount; di++, dp++)
+ {
+ switch (dp->tdir_tag)
+ {
+ case IGNORE:
+ break;
+ case TIFFTAG_MINSAMPLEVALUE:
+ case TIFFTAG_MAXSAMPLEVALUE:
+ case TIFFTAG_BITSPERSAMPLE:
+ case TIFFTAG_DATATYPE:
+ case TIFFTAG_SAMPLEFORMAT:
+ /*
+ * The MinSampleValue, MaxSampleValue, BitsPerSample
+ * DataType and SampleFormat tags are supposed to be
+ * written as one value/sample, but some vendors
+ * incorrectly write one value only -- so we accept
+ * that as well (yuck). Other vendors write correct
+ * value for NumberOfSamples, but incorrect one for
+ * BitsPerSample and friends, and we will read this
+ * too.
+ */
+ {
+ uint16 value;
+ enum TIFFReadDirEntryErr err;
+ err=TIFFReadDirEntryShort(tif,dp,&value);
+ if (err==TIFFReadDirEntryErrCount)
+ err=TIFFReadDirEntryPersampleShort(tif,dp,&value);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ fip = TIFFFieldWithTag(tif,dp->tdir_tag);
+ TIFFReadDirEntryOutputErr(tif,err,module,fip ? fip->field_name : "unknown tagname",0);
+ goto bad;
+ }
+ if (!TIFFSetField(tif,dp->tdir_tag,value))
+ goto bad;
+ if( dp->tdir_tag == TIFFTAG_BITSPERSAMPLE )
+ bitspersample_read = TRUE;
+ }
+ break;
+ case TIFFTAG_SMINSAMPLEVALUE:
+ case TIFFTAG_SMAXSAMPLEVALUE:
+ {
+
+ double *data = NULL;
+ enum TIFFReadDirEntryErr err;
+ uint32 saved_flags;
+ int m;
+ if (dp->tdir_count != (uint64)tif->tif_dir.td_samplesperpixel)
+ err = TIFFReadDirEntryErrCount;
+ else
+ err = TIFFReadDirEntryDoubleArray(tif, dp, &data);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ fip = TIFFFieldWithTag(tif,dp->tdir_tag);
+ TIFFReadDirEntryOutputErr(tif,err,module,fip ? fip->field_name : "unknown tagname",0);
+ goto bad;
+ }
+ saved_flags = tif->tif_flags;
+ tif->tif_flags |= TIFF_PERSAMPLE;
+ m = TIFFSetField(tif,dp->tdir_tag,data);
+ tif->tif_flags = saved_flags;
+ _TIFFfree(data);
+ if (!m)
+ goto bad;
+ }
+ break;
+ case TIFFTAG_STRIPOFFSETS:
+ case TIFFTAG_TILEOFFSETS:
+#if defined(DEFER_STRILE_LOAD)
+ _TIFFmemcpy( &(tif->tif_dir.td_stripoffset_entry),
+ dp, sizeof(TIFFDirEntry) );
+#else
+ if( tif->tif_dir.td_stripoffset != NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "tif->tif_dir.td_stripoffset is "
+ "already allocated. Likely duplicated "
+ "StripOffsets/TileOffsets tag");
+ goto bad;
+ }
+ if (!TIFFFetchStripThing(tif,dp,tif->tif_dir.td_nstrips,&tif->tif_dir.td_stripoffset))
+ goto bad;
+#endif
+ break;
+ case TIFFTAG_STRIPBYTECOUNTS:
+ case TIFFTAG_TILEBYTECOUNTS:
+#if defined(DEFER_STRILE_LOAD)
+ _TIFFmemcpy( &(tif->tif_dir.td_stripbytecount_entry),
+ dp, sizeof(TIFFDirEntry) );
+#else
+ if( tif->tif_dir.td_stripbytecount != NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "tif->tif_dir.td_stripbytecount is "
+ "already allocated. Likely duplicated "
+ "StripByteCounts/TileByteCounts tag");
+ goto bad;
+ }
+ if (!TIFFFetchStripThing(tif,dp,tif->tif_dir.td_nstrips,&tif->tif_dir.td_stripbytecount))
+ goto bad;
+#endif
+ break;
+ case TIFFTAG_COLORMAP:
+ case TIFFTAG_TRANSFERFUNCTION:
+ {
+ enum TIFFReadDirEntryErr err;
+ uint32 countpersample;
+ uint32 countrequired;
+ uint32 incrementpersample;
+ uint16* value=NULL;
+ /* It would be dangerous to instantiate those tag values */
+ /* since if td_bitspersample has not yet been read (due to */
+ /* unordered tags), it could be read afterwards with a */
+ /* values greater than the default one (1), which may cause */
+ /* crashes in user code */
+ if( !bitspersample_read )
+ {
+ fip = TIFFFieldWithTag(tif,dp->tdir_tag);
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Ignoring %s since BitsPerSample tag not found",
+ fip ? fip->field_name : "unknown tagname");
+ continue;
+ }
+ /* ColorMap or TransferFunction for high bit */
+ /* depths do not make much sense and could be */
+ /* used as a denial of service vector */
+ if (tif->tif_dir.td_bitspersample > 24)
+ {
+ fip = TIFFFieldWithTag(tif,dp->tdir_tag);
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Ignoring %s because BitsPerSample=%d>24",
+ fip ? fip->field_name : "unknown tagname",
+ tif->tif_dir.td_bitspersample);
+ continue;
+ }
+ countpersample=(1U<<tif->tif_dir.td_bitspersample);
+ if ((dp->tdir_tag==TIFFTAG_TRANSFERFUNCTION)&&(dp->tdir_count==(uint64)countpersample))
+ {
+ countrequired=countpersample;
+ incrementpersample=0;
+ }
+ else
+ {
+ countrequired=3*countpersample;
+ incrementpersample=countpersample;
+ }
+ if (dp->tdir_count!=(uint64)countrequired)
+ err=TIFFReadDirEntryErrCount;
+ else
+ err=TIFFReadDirEntryShortArray(tif,dp,&value);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ fip = TIFFFieldWithTag(tif,dp->tdir_tag);
+ TIFFReadDirEntryOutputErr(tif,err,module,fip ? fip->field_name : "unknown tagname",1);
+ }
+ else
+ {
+ TIFFSetField(tif,dp->tdir_tag,value,value+incrementpersample,value+2*incrementpersample);
+ _TIFFfree(value);
+ }
+ }
+ break;
+/* BEGIN REV 4.0 COMPATIBILITY */
+ case TIFFTAG_OSUBFILETYPE:
+ {
+ uint16 valueo;
+ uint32 value;
+ if (TIFFReadDirEntryShort(tif,dp,&valueo)==TIFFReadDirEntryErrOk)
+ {
+ switch (valueo)
+ {
+ case OFILETYPE_REDUCEDIMAGE: value=FILETYPE_REDUCEDIMAGE; break;
+ case OFILETYPE_PAGE: value=FILETYPE_PAGE; break;
+ default: value=0; break;
+ }
+ if (value!=0)
+ TIFFSetField(tif,TIFFTAG_SUBFILETYPE,value);
+ }
+ }
+ break;
+/* END REV 4.0 COMPATIBILITY */
+ default:
+ (void) TIFFFetchNormalTag(tif, dp, TRUE);
+ break;
+ }
+ }
+ /*
+ * OJPEG hack:
+ * - If a) compression is OJPEG, and b) photometric tag is missing,
+ * then we consistently find that photometric should be YCbCr
+ * - If a) compression is OJPEG, and b) photometric tag says it's RGB,
+ * then we consistently find that the buggy implementation of the
+ * buggy compression scheme matches photometric YCbCr instead.
+ * - If a) compression is OJPEG, and b) bitspersample tag is missing,
+ * then we consistently find bitspersample should be 8.
+ * - If a) compression is OJPEG, b) samplesperpixel tag is missing,
+ * and c) photometric is RGB or YCbCr, then we consistently find
+ * samplesperpixel should be 3
+ * - If a) compression is OJPEG, b) samplesperpixel tag is missing,
+ * and c) photometric is MINISWHITE or MINISBLACK, then we consistently
+ * find samplesperpixel should be 3
+ */
+ if (tif->tif_dir.td_compression==COMPRESSION_OJPEG)
+ {
+ if (!TIFFFieldSet(tif,FIELD_PHOTOMETRIC))
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Photometric tag is missing, assuming data is YCbCr");
+ if (!TIFFSetField(tif,TIFFTAG_PHOTOMETRIC,PHOTOMETRIC_YCBCR))
+ goto bad;
+ }
+ else if (tif->tif_dir.td_photometric==PHOTOMETRIC_RGB)
+ {
+ tif->tif_dir.td_photometric=PHOTOMETRIC_YCBCR;
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Photometric tag value assumed incorrect, "
+ "assuming data is YCbCr instead of RGB");
+ }
+ if (!TIFFFieldSet(tif,FIELD_BITSPERSAMPLE))
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "BitsPerSample tag is missing, assuming 8 bits per sample");
+ if (!TIFFSetField(tif,TIFFTAG_BITSPERSAMPLE,8))
+ goto bad;
+ }
+ if (!TIFFFieldSet(tif,FIELD_SAMPLESPERPIXEL))
+ {
+ if (tif->tif_dir.td_photometric==PHOTOMETRIC_RGB)
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "SamplesPerPixel tag is missing, "
+ "assuming correct SamplesPerPixel value is 3");
+ if (!TIFFSetField(tif,TIFFTAG_SAMPLESPERPIXEL,3))
+ goto bad;
+ }
+ if (tif->tif_dir.td_photometric==PHOTOMETRIC_YCBCR)
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "SamplesPerPixel tag is missing, "
+ "applying correct SamplesPerPixel value of 3");
+ if (!TIFFSetField(tif,TIFFTAG_SAMPLESPERPIXEL,3))
+ goto bad;
+ }
+ else if ((tif->tif_dir.td_photometric==PHOTOMETRIC_MINISWHITE)
+ || (tif->tif_dir.td_photometric==PHOTOMETRIC_MINISBLACK))
+ {
+ /*
+ * SamplesPerPixel tag is missing, but is not required
+ * by spec. Assume correct SamplesPerPixel value of 1.
+ */
+ if (!TIFFSetField(tif,TIFFTAG_SAMPLESPERPIXEL,1))
+ goto bad;
+ }
+ }
+ }
+
+ /*
+ * Make sure all non-color channels are extrasamples.
+ * If it's not the case, define them as such.
+ */
+ color_channels = _TIFFGetMaxColorChannels(tif->tif_dir.td_photometric);
+ if (color_channels && tif->tif_dir.td_samplesperpixel - tif->tif_dir.td_extrasamples > color_channels) {
+ uint16 old_extrasamples;
+ uint16 *new_sampleinfo;
+
+ TIFFWarningExt(tif->tif_clientdata,module, "Sum of Photometric type-related "
+ "color channels and ExtraSamples doesn't match SamplesPerPixel. "
+ "Defining non-color channels as ExtraSamples.");
+
+ old_extrasamples = tif->tif_dir.td_extrasamples;
+ tif->tif_dir.td_extrasamples = (uint16) (tif->tif_dir.td_samplesperpixel - color_channels);
+
+ // sampleinfo should contain information relative to these new extra samples
+ new_sampleinfo = (uint16*) _TIFFcalloc(tif->tif_dir.td_extrasamples, sizeof(uint16));
+ if (!new_sampleinfo) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Failed to allocate memory for "
+ "temporary new sampleinfo array (%d 16 bit elements)",
+ tif->tif_dir.td_extrasamples);
+ goto bad;
+ }
+
+ memcpy(new_sampleinfo, tif->tif_dir.td_sampleinfo, old_extrasamples * sizeof(uint16));
+ _TIFFsetShortArray(&tif->tif_dir.td_sampleinfo, new_sampleinfo, tif->tif_dir.td_extrasamples);
+ _TIFFfree(new_sampleinfo);
+ }
+
+ /*
+ * Verify Palette image has a Colormap.
+ */
+ if (tif->tif_dir.td_photometric == PHOTOMETRIC_PALETTE &&
+ !TIFFFieldSet(tif, FIELD_COLORMAP)) {
+ if ( tif->tif_dir.td_bitspersample>=8 && tif->tif_dir.td_samplesperpixel==3)
+ tif->tif_dir.td_photometric = PHOTOMETRIC_RGB;
+ else if (tif->tif_dir.td_bitspersample>=8)
+ tif->tif_dir.td_photometric = PHOTOMETRIC_MINISBLACK;
+ else {
+ MissingRequired(tif, "Colormap");
+ goto bad;
+ }
+ }
+ /*
+ * OJPEG hack:
+ * We do no further messing with strip/tile offsets/bytecounts in OJPEG
+ * TIFFs
+ */
+ if (tif->tif_dir.td_compression!=COMPRESSION_OJPEG)
+ {
+ /*
+ * Attempt to deal with a missing StripByteCounts tag.
+ */
+ if (!TIFFFieldSet(tif, FIELD_STRIPBYTECOUNTS)) {
+ /*
+ * Some manufacturers violate the spec by not giving
+ * the size of the strips. In this case, assume there
+ * is one uncompressed strip of data.
+ */
+ if ((tif->tif_dir.td_planarconfig == PLANARCONFIG_CONTIG &&
+ tif->tif_dir.td_nstrips > 1) ||
+ (tif->tif_dir.td_planarconfig == PLANARCONFIG_SEPARATE &&
+ tif->tif_dir.td_nstrips != (uint32)tif->tif_dir.td_samplesperpixel)) {
+ MissingRequired(tif, "StripByteCounts");
+ goto bad;
+ }
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "TIFF directory is missing required "
+ "\"StripByteCounts\" field, calculating from imagelength");
+ if (EstimateStripByteCounts(tif, dir, dircount) < 0)
+ goto bad;
+ /*
+ * Assume we have wrong StripByteCount value (in case
+ * of single strip) in following cases:
+ * - it is equal to zero along with StripOffset;
+ * - it is larger than file itself (in case of uncompressed
+ * image);
+ * - it is smaller than the size of the bytes per row
+ * multiplied on the number of rows. The last case should
+ * not be checked in the case of writing new image,
+ * because we may do not know the exact strip size
+ * until the whole image will be written and directory
+ * dumped out.
+ */
+ #define BYTECOUNTLOOKSBAD \
+ ( (tif->tif_dir.td_stripbytecount[0] == 0 && tif->tif_dir.td_stripoffset[0] != 0) || \
+ (tif->tif_dir.td_compression == COMPRESSION_NONE && \
+ (tif->tif_dir.td_stripoffset[0] <= TIFFGetFileSize(tif) && \
+ tif->tif_dir.td_stripbytecount[0] > TIFFGetFileSize(tif) - tif->tif_dir.td_stripoffset[0])) || \
+ (tif->tif_mode == O_RDONLY && \
+ tif->tif_dir.td_compression == COMPRESSION_NONE && \
+ tif->tif_dir.td_stripbytecount[0] < TIFFScanlineSize64(tif) * tif->tif_dir.td_imagelength) )
+
+ } else if (tif->tif_dir.td_nstrips == 1
+ && !(tif->tif_flags&TIFF_ISTILED)
+ && _TIFFFillStriles(tif)
+ && tif->tif_dir.td_stripoffset[0] != 0
+ && BYTECOUNTLOOKSBAD) {
+ /*
+ * XXX: Plexus (and others) sometimes give a value of
+ * zero for a tag when they don't know what the
+ * correct value is! Try and handle the simple case
+ * of estimating the size of a one strip image.
+ */
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Bogus \"StripByteCounts\" field, ignoring and calculating from imagelength");
+ if(EstimateStripByteCounts(tif, dir, dircount) < 0)
+ goto bad;
+
+#if !defined(DEFER_STRILE_LOAD)
+ } else if (tif->tif_dir.td_planarconfig == PLANARCONFIG_CONTIG
+ && tif->tif_dir.td_nstrips > 2
+ && tif->tif_dir.td_compression == COMPRESSION_NONE
+ && tif->tif_dir.td_stripbytecount[0] != tif->tif_dir.td_stripbytecount[1]
+ && tif->tif_dir.td_stripbytecount[0] != 0
+ && tif->tif_dir.td_stripbytecount[1] != 0 ) {
+ /*
+ * XXX: Some vendors fill StripByteCount array with
+ * absolutely wrong values (it can be equal to
+ * StripOffset array, for example). Catch this case
+ * here.
+ *
+ * We avoid this check if deferring strile loading
+ * as it would always force us to load the strip/tile
+ * information.
+ */
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Wrong \"StripByteCounts\" field, ignoring and calculating from imagelength");
+ if (EstimateStripByteCounts(tif, dir, dircount) < 0)
+ goto bad;
+#endif /* !defined(DEFER_STRILE_LOAD) */
+ }
+ }
+ if (dir)
+ {
+ _TIFFfree(dir);
+ dir=NULL;
+ }
+ if (!TIFFFieldSet(tif, FIELD_MAXSAMPLEVALUE))
+ {
+ if (tif->tif_dir.td_bitspersample>=16)
+ tif->tif_dir.td_maxsamplevalue=0xFFFF;
+ else
+ tif->tif_dir.td_maxsamplevalue = (uint16)((1L<<tif->tif_dir.td_bitspersample)-1);
+ }
+ /*
+ * XXX: We can optimize checking for the strip bounds using the sorted
+ * bytecounts array. See also comments for TIFFAppendToStrip()
+ * function in tif_write.c.
+ */
+#if !defined(DEFER_STRILE_LOAD)
+ if (tif->tif_dir.td_nstrips > 1) {
+ uint32 strip;
+
+ tif->tif_dir.td_stripbytecountsorted = 1;
+ for (strip = 1; strip < tif->tif_dir.td_nstrips; strip++) {
+ if (tif->tif_dir.td_stripoffset[strip - 1] >
+ tif->tif_dir.td_stripoffset[strip]) {
+ tif->tif_dir.td_stripbytecountsorted = 0;
+ break;
+ }
+ }
+ }
+#endif /* !defined(DEFER_STRILE_LOAD) */
+
+ /*
+ * An opportunity for compression mode dependent tag fixup
+ */
+ (*tif->tif_fixuptags)(tif);
+
+ /*
+ * Some manufacturers make life difficult by writing
+ * large amounts of uncompressed data as a single strip.
+ * This is contrary to the recommendations of the spec.
+ * The following makes an attempt at breaking such images
+ * into strips closer to the recommended 8k bytes. A
+ * side effect, however, is that the RowsPerStrip tag
+ * value may be changed.
+ */
+ if ((tif->tif_dir.td_planarconfig==PLANARCONFIG_CONTIG)&&
+ (tif->tif_dir.td_nstrips==1)&&
+ (tif->tif_dir.td_compression==COMPRESSION_NONE)&&
+ ((tif->tif_flags&(TIFF_STRIPCHOP|TIFF_ISTILED))==TIFF_STRIPCHOP))
+ {
+ if ( !_TIFFFillStriles(tif) || !tif->tif_dir.td_stripbytecount )
+ return 0;
+ ChopUpSingleUncompressedStrip(tif);
+ }
+
+ /*
+ * Clear the dirty directory flag.
+ */
+ tif->tif_flags &= ~TIFF_DIRTYDIRECT;
+ tif->tif_flags &= ~TIFF_DIRTYSTRIP;
+
+ /*
+ * Reinitialize i/o since we are starting on a new directory.
+ */
+ tif->tif_row = (uint32) -1;
+ tif->tif_curstrip = (uint32) -1;
+ tif->tif_col = (uint32) -1;
+ tif->tif_curtile = (uint32) -1;
+ tif->tif_tilesize = (tmsize_t) -1;
+
+ tif->tif_scanlinesize = TIFFScanlineSize(tif);
+ if (!tif->tif_scanlinesize) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot handle zero scanline size");
+ return (0);
+ }
+
+ if (isTiled(tif)) {
+ tif->tif_tilesize = TIFFTileSize(tif);
+ if (!tif->tif_tilesize) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot handle zero tile size");
+ return (0);
+ }
+ } else {
+ if (!TIFFStripSize(tif)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot handle zero strip size");
+ return (0);
+ }
+ }
+ return (1);
+bad:
+ if (dir)
+ _TIFFfree(dir);
+ return (0);
+}
+
+static void
+TIFFReadDirectoryCheckOrder(TIFF* tif, TIFFDirEntry* dir, uint16 dircount)
+{
+ static const char module[] = "TIFFReadDirectoryCheckOrder";
+ uint16 m;
+ uint16 n;
+ TIFFDirEntry* o;
+ m=0;
+ for (n=0, o=dir; n<dircount; n++, o++)
+ {
+ if (o->tdir_tag<m)
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Invalid TIFF directory; tags are not sorted in ascending order");
+ break;
+ }
+ m=o->tdir_tag+1;
+ }
+}
+
+static TIFFDirEntry*
+TIFFReadDirectoryFindEntry(TIFF* tif, TIFFDirEntry* dir, uint16 dircount, uint16 tagid)
+{
+ TIFFDirEntry* m;
+ uint16 n;
+ (void) tif;
+ for (m=dir, n=0; n<dircount; m++, n++)
+ {
+ if (m->tdir_tag==tagid)
+ return(m);
+ }
+ return(0);
+}
+
+static void
+TIFFReadDirectoryFindFieldInfo(TIFF* tif, uint16 tagid, uint32* fii)
+{
+ int32 ma,mb,mc;
+ ma=-1;
+ mc=(int32)tif->tif_nfields;
+ while (1)
+ {
+ if (ma+1==mc)
+ {
+ *fii = FAILED_FII;
+ return;
+ }
+ mb=(ma+mc)/2;
+ if (tif->tif_fields[mb]->field_tag==(uint32)tagid)
+ break;
+ if (tif->tif_fields[mb]->field_tag<(uint32)tagid)
+ ma=mb;
+ else
+ mc=mb;
+ }
+ while (1)
+ {
+ if (mb==0)
+ break;
+ if (tif->tif_fields[mb-1]->field_tag!=(uint32)tagid)
+ break;
+ mb--;
+ }
+ *fii=mb;
+}
+
+/*
+ * Read custom directory from the arbitrary offset.
+ * The code is very similar to TIFFReadDirectory().
+ */
+int
+TIFFReadCustomDirectory(TIFF* tif, toff_t diroff,
+ const TIFFFieldArray* infoarray)
+{
+ static const char module[] = "TIFFReadCustomDirectory";
+ TIFFDirEntry* dir;
+ uint16 dircount;
+ TIFFDirEntry* dp;
+ uint16 di;
+ const TIFFField* fip;
+ uint32 fii;
+ _TIFFSetupFields(tif, infoarray);
+ dircount=TIFFFetchDirectory(tif,diroff,&dir,NULL);
+ if (!dircount)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Failed to read custom directory at offset " TIFF_UINT64_FORMAT,diroff);
+ return 0;
+ }
+ TIFFFreeDirectory(tif);
+ _TIFFmemset(&tif->tif_dir, 0, sizeof(TIFFDirectory));
+ TIFFReadDirectoryCheckOrder(tif,dir,dircount);
+ for (di=0, dp=dir; di<dircount; di++, dp++)
+ {
+ TIFFReadDirectoryFindFieldInfo(tif,dp->tdir_tag,&fii);
+ if (fii == FAILED_FII)
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Unknown field with tag %d (0x%x) encountered",
+ dp->tdir_tag, dp->tdir_tag);
+ if (!_TIFFMergeFields(tif, _TIFFCreateAnonField(tif,
+ dp->tdir_tag,
+ (TIFFDataType) dp->tdir_type),
+ 1)) {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Registering anonymous field with tag %d (0x%x) failed",
+ dp->tdir_tag, dp->tdir_tag);
+ dp->tdir_tag=IGNORE;
+ } else {
+ TIFFReadDirectoryFindFieldInfo(tif,dp->tdir_tag,&fii);
+ assert( fii != FAILED_FII );
+ }
+ }
+ if (dp->tdir_tag!=IGNORE)
+ {
+ fip=tif->tif_fields[fii];
+ if (fip->field_bit==FIELD_IGNORE)
+ dp->tdir_tag=IGNORE;
+ else
+ {
+ /* check data type */
+ while ((fip->field_type!=TIFF_ANY)&&(fip->field_type!=dp->tdir_type))
+ {
+ fii++;
+ if ((fii==tif->tif_nfields)||
+ (tif->tif_fields[fii]->field_tag!=(uint32)dp->tdir_tag))
+ {
+ fii=0xFFFF;
+ break;
+ }
+ fip=tif->tif_fields[fii];
+ }
+ if (fii==0xFFFF)
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Wrong data type %d for \"%s\"; tag ignored",
+ dp->tdir_type,fip->field_name);
+ dp->tdir_tag=IGNORE;
+ }
+ else
+ {
+ /* check count if known in advance */
+ if ((fip->field_readcount!=TIFF_VARIABLE)&&
+ (fip->field_readcount!=TIFF_VARIABLE2))
+ {
+ uint32 expected;
+ if (fip->field_readcount==TIFF_SPP)
+ expected=(uint32)tif->tif_dir.td_samplesperpixel;
+ else
+ expected=(uint32)fip->field_readcount;
+ if (!CheckDirCount(tif,dp,expected))
+ dp->tdir_tag=IGNORE;
+ }
+ }
+ }
+ switch (dp->tdir_tag)
+ {
+ case IGNORE:
+ break;
+ case EXIFTAG_SUBJECTDISTANCE:
+ (void) TIFFFetchSubjectDistance(tif,dp);
+ break;
+ default:
+ (void) TIFFFetchNormalTag(tif, dp, TRUE);
+ break;
+ }
+ }
+ }
+ if (dir)
+ _TIFFfree(dir);
+ return 1;
+}
+
+/*
+ * EXIF is important special case of custom IFD, so we have a special
+ * function to read it.
+ */
+int
+TIFFReadEXIFDirectory(TIFF* tif, toff_t diroff)
+{
+ const TIFFFieldArray* exifFieldArray;
+ exifFieldArray = _TIFFGetExifFields();
+ return TIFFReadCustomDirectory(tif, diroff, exifFieldArray);
+}
+
+static int
+EstimateStripByteCounts(TIFF* tif, TIFFDirEntry* dir, uint16 dircount)
+{
+ static const char module[] = "EstimateStripByteCounts";
+
+ TIFFDirEntry *dp;
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 strip;
+
+ /* Do not try to load stripbytecount as we will compute it */
+ if( !_TIFFFillStrilesInternal( tif, 0 ) )
+ return -1;
+
+ if (td->td_stripbytecount)
+ _TIFFfree(td->td_stripbytecount);
+ td->td_stripbytecount = (uint64*)
+ _TIFFCheckMalloc(tif, td->td_nstrips, sizeof (uint64),
+ "for \"StripByteCounts\" array");
+ if( td->td_stripbytecount == NULL )
+ return -1;
+
+ if (td->td_compression != COMPRESSION_NONE) {
+ uint64 space;
+ uint64 filesize;
+ uint16 n;
+ filesize = TIFFGetFileSize(tif);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ space=sizeof(TIFFHeaderClassic)+2+dircount*12+4;
+ else
+ space=sizeof(TIFFHeaderBig)+8+dircount*20+8;
+ /* calculate amount of space used by indirect values */
+ for (dp = dir, n = dircount; n > 0; n--, dp++)
+ {
+ uint32 typewidth;
+ uint64 datasize;
+ typewidth = TIFFDataWidth((TIFFDataType) dp->tdir_type);
+ if (typewidth == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot determine size of unknown tag type %d",
+ dp->tdir_type);
+ return -1;
+ }
+ datasize=(uint64)typewidth*dp->tdir_count;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (datasize<=4)
+ datasize=0;
+ }
+ else
+ {
+ if (datasize<=8)
+ datasize=0;
+ }
+ space+=datasize;
+ }
+ if( filesize < space )
+ /* we should perhaps return in error ? */
+ space = filesize;
+ else
+ space = filesize - space;
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE)
+ space /= td->td_samplesperpixel;
+ for (strip = 0; strip < td->td_nstrips; strip++)
+ td->td_stripbytecount[strip] = space;
+ /*
+ * This gross hack handles the case were the offset to
+ * the last strip is past the place where we think the strip
+ * should begin. Since a strip of data must be contiguous,
+ * it's safe to assume that we've overestimated the amount
+ * of data in the strip and trim this number back accordingly.
+ */
+ strip--;
+ if (td->td_stripoffset[strip]+td->td_stripbytecount[strip] > filesize)
+ td->td_stripbytecount[strip] = filesize - td->td_stripoffset[strip];
+ } else if (isTiled(tif)) {
+ uint64 bytespertile = TIFFTileSize64(tif);
+
+ for (strip = 0; strip < td->td_nstrips; strip++)
+ td->td_stripbytecount[strip] = bytespertile;
+ } else {
+ uint64 rowbytes = TIFFScanlineSize64(tif);
+ uint32 rowsperstrip = td->td_imagelength/td->td_stripsperimage;
+ for (strip = 0; strip < td->td_nstrips; strip++)
+ td->td_stripbytecount[strip] = rowbytes * rowsperstrip;
+ }
+ TIFFSetFieldBit(tif, FIELD_STRIPBYTECOUNTS);
+ if (!TIFFFieldSet(tif, FIELD_ROWSPERSTRIP))
+ td->td_rowsperstrip = td->td_imagelength;
+ return 1;
+}
+
+static void
+MissingRequired(TIFF* tif, const char* tagname)
+{
+ static const char module[] = "MissingRequired";
+
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "TIFF directory is missing required \"%s\" field",
+ tagname);
+}
+
+/*
+ * Check the directory offset against the list of already seen directory
+ * offsets. This is a trick to prevent IFD looping. The one can create TIFF
+ * file with looped directory pointers. We will maintain a list of already
+ * seen directories and check every IFD offset against that list.
+ */
+static int
+TIFFCheckDirOffset(TIFF* tif, uint64 diroff)
+{
+ uint16 n;
+
+ if (diroff == 0) /* no more directories */
+ return 0;
+ if (tif->tif_dirnumber == 65535) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFCheckDirOffset",
+ "Cannot handle more than 65535 TIFF directories");
+ return 0;
+ }
+
+ for (n = 0; n < tif->tif_dirnumber && tif->tif_dirlist; n++) {
+ if (tif->tif_dirlist[n] == diroff)
+ return 0;
+ }
+
+ tif->tif_dirnumber++;
+
+ if (tif->tif_dirlist == NULL || tif->tif_dirnumber > tif->tif_dirlistsize) {
+ uint64* new_dirlist;
+
+ /*
+ * XXX: Reduce memory allocation granularity of the dirlist
+ * array.
+ */
+ new_dirlist = (uint64*)_TIFFCheckRealloc(tif, tif->tif_dirlist,
+ tif->tif_dirnumber, 2 * sizeof(uint64), "for IFD list");
+ if (!new_dirlist)
+ return 0;
+ if( tif->tif_dirnumber >= 32768 )
+ tif->tif_dirlistsize = 65535;
+ else
+ tif->tif_dirlistsize = 2 * tif->tif_dirnumber;
+ tif->tif_dirlist = new_dirlist;
+ }
+
+ tif->tif_dirlist[tif->tif_dirnumber - 1] = diroff;
+
+ return 1;
+}
+
+/*
+ * Check the count field of a directory entry against a known value. The
+ * caller is expected to skip/ignore the tag if there is a mismatch.
+ */
+static int
+CheckDirCount(TIFF* tif, TIFFDirEntry* dir, uint32 count)
+{
+ if ((uint64)count > dir->tdir_count) {
+ const TIFFField* fip = TIFFFieldWithTag(tif, dir->tdir_tag);
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "incorrect count for field \"%s\" (" TIFF_UINT64_FORMAT ", expecting %u); tag ignored",
+ fip ? fip->field_name : "unknown tagname",
+ dir->tdir_count, count);
+ return (0);
+ } else if ((uint64)count < dir->tdir_count) {
+ const TIFFField* fip = TIFFFieldWithTag(tif, dir->tdir_tag);
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "incorrect count for field \"%s\" (" TIFF_UINT64_FORMAT ", expecting %u); tag trimmed",
+ fip ? fip->field_name : "unknown tagname",
+ dir->tdir_count, count);
+ dir->tdir_count = count;
+ return (1);
+ }
+ return (1);
+}
+
+/*
+ * Read IFD structure from the specified offset. If the pointer to
+ * nextdiroff variable has been specified, read it too. Function returns a
+ * number of fields in the directory or 0 if failed.
+ */
+static uint16
+TIFFFetchDirectory(TIFF* tif, uint64 diroff, TIFFDirEntry** pdir,
+ uint64 *nextdiroff)
+{
+ static const char module[] = "TIFFFetchDirectory";
+
+ void* origdir;
+ uint16 dircount16;
+ uint32 dirsize;
+ TIFFDirEntry* dir;
+ uint8* ma;
+ TIFFDirEntry* mb;
+ uint16 n;
+
+ assert(pdir);
+
+ tif->tif_diroff = diroff;
+ if (nextdiroff)
+ *nextdiroff = 0;
+ if (!isMapped(tif)) {
+ if (!SeekOK(tif, tif->tif_diroff)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Seek error accessing TIFF directory",
+ tif->tif_name);
+ return 0;
+ }
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (!ReadOK(tif, &dircount16, sizeof (uint16))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not read TIFF directory count",
+ tif->tif_name);
+ return 0;
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount16);
+ if (dircount16>4096)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on directory count failed, this is probably not a valid IFD offset");
+ return 0;
+ }
+ dirsize = 12;
+ } else {
+ uint64 dircount64;
+ if (!ReadOK(tif, &dircount64, sizeof (uint64))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not read TIFF directory count",
+ tif->tif_name);
+ return 0;
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>4096)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on directory count failed, this is probably not a valid IFD offset");
+ return 0;
+ }
+ dircount16 = (uint16)dircount64;
+ dirsize = 20;
+ }
+ origdir = _TIFFCheckMalloc(tif, dircount16,
+ dirsize, "to read TIFF directory");
+ if (origdir == NULL)
+ return 0;
+ if (!ReadOK(tif, origdir, (tmsize_t)(dircount16*dirsize))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%.100s: Can not read TIFF directory",
+ tif->tif_name);
+ _TIFFfree(origdir);
+ return 0;
+ }
+ /*
+ * Read offset to next directory for sequential scans if
+ * needed.
+ */
+ if (nextdiroff)
+ {
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 nextdiroff32;
+ if (!ReadOK(tif, &nextdiroff32, sizeof(uint32)))
+ nextdiroff32 = 0;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&nextdiroff32);
+ *nextdiroff=nextdiroff32;
+ } else {
+ if (!ReadOK(tif, nextdiroff, sizeof(uint64)))
+ *nextdiroff = 0;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(nextdiroff);
+ }
+ }
+ } else {
+ tmsize_t m;
+ tmsize_t off = (tmsize_t) tif->tif_diroff;
+ if ((uint64)off!=tif->tif_diroff)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Can not read TIFF directory count");
+ return(0);
+ }
+
+ /*
+ * Check for integer overflow when validating the dir_off,
+ * otherwise a very high offset may cause an OOB read and
+ * crash the client. Make two comparisons instead of
+ *
+ * off + sizeof(uint16) > tif->tif_size
+ *
+ * to avoid overflow.
+ */
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ m=off+sizeof(uint16);
+ if ((m<off)||(m<(tmsize_t)sizeof(uint16))||(m>tif->tif_size)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not read TIFF directory count");
+ return 0;
+ } else {
+ _TIFFmemcpy(&dircount16, tif->tif_base + off,
+ sizeof(uint16));
+ }
+ off += sizeof (uint16);
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount16);
+ if (dircount16>4096)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on directory count failed, this is probably not a valid IFD offset");
+ return 0;
+ }
+ dirsize = 12;
+ }
+ else
+ {
+ uint64 dircount64;
+ m=off+sizeof(uint64);
+ if ((m<off)||(m<(tmsize_t)sizeof(uint64))||(m>tif->tif_size)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not read TIFF directory count");
+ return 0;
+ } else {
+ _TIFFmemcpy(&dircount64, tif->tif_base + off,
+ sizeof(uint64));
+ }
+ off += sizeof (uint64);
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>4096)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on directory count failed, this is probably not a valid IFD offset");
+ return 0;
+ }
+ dircount16 = (uint16)dircount64;
+ dirsize = 20;
+ }
+ if (dircount16 == 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on directory count failed, zero tag directories not supported");
+ return 0;
+ }
+ origdir = _TIFFCheckMalloc(tif, dircount16,
+ dirsize,
+ "to read TIFF directory");
+ if (origdir == NULL)
+ return 0;
+ m=off+dircount16*dirsize;
+ if ((m<off)||(m<(tmsize_t)(dircount16*dirsize))||(m>tif->tif_size)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not read TIFF directory");
+ _TIFFfree(origdir);
+ return 0;
+ } else {
+ _TIFFmemcpy(origdir, tif->tif_base + off,
+ dircount16 * dirsize);
+ }
+ if (nextdiroff) {
+ off += dircount16 * dirsize;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 nextdiroff32;
+ m=off+sizeof(uint32);
+ if ((m<off)||(m<(tmsize_t)sizeof(uint32))||(m>tif->tif_size))
+ nextdiroff32 = 0;
+ else
+ _TIFFmemcpy(&nextdiroff32, tif->tif_base + off,
+ sizeof (uint32));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&nextdiroff32);
+ *nextdiroff = nextdiroff32;
+ }
+ else
+ {
+ m=off+sizeof(uint64);
+ if ((m<off)||(m<(tmsize_t)sizeof(uint64))||(m>tif->tif_size))
+ *nextdiroff = 0;
+ else
+ _TIFFmemcpy(nextdiroff, tif->tif_base + off,
+ sizeof (uint64));
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(nextdiroff);
+ }
+ }
+ }
+ dir = (TIFFDirEntry*)_TIFFCheckMalloc(tif, dircount16,
+ sizeof(TIFFDirEntry),
+ "to read TIFF directory");
+ if (dir==0)
+ {
+ _TIFFfree(origdir);
+ return 0;
+ }
+ ma=(uint8*)origdir;
+ mb=dir;
+ for (n=0; n<dircount16; n++)
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ mb->tdir_tag=*(uint16*)ma;
+ ma+=sizeof(uint16);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)ma);
+ mb->tdir_type=*(uint16*)ma;
+ ma+=sizeof(uint16);
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)ma);
+ mb->tdir_count=(uint64)(*(uint32*)ma);
+ ma+=sizeof(uint32);
+ *(uint32*)(&mb->tdir_offset)=*(uint32*)ma;
+ ma+=sizeof(uint32);
+ }
+ else
+ {
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)ma);
+ mb->tdir_count=TIFFReadUInt64(ma);
+ ma+=sizeof(uint64);
+ mb->tdir_offset.toff_long8=TIFFReadUInt64(ma);
+ ma+=sizeof(uint64);
+ }
+ mb++;
+ }
+ _TIFFfree(origdir);
+ *pdir = dir;
+ return dircount16;
+}
+
+/*
+ * Fetch a tag that is not handled by special case code.
+ */
+static int
+TIFFFetchNormalTag(TIFF* tif, TIFFDirEntry* dp, int recover)
+{
+ static const char module[] = "TIFFFetchNormalTag";
+ enum TIFFReadDirEntryErr err;
+ uint32 fii;
+ const TIFFField* fip = NULL;
+ TIFFReadDirectoryFindFieldInfo(tif,dp->tdir_tag,&fii);
+ if( fii == FAILED_FII )
+ {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFFetchNormalTag",
+ "No definition found for tag %d",
+ dp->tdir_tag);
+ return 0;
+ }
+ fip=tif->tif_fields[fii];
+ assert(fip != NULL); /* should not happen */
+ assert(fip->set_field_type!=TIFF_SETGET_OTHER); /* if so, we shouldn't arrive here but deal with this in specialized code */
+ assert(fip->set_field_type!=TIFF_SETGET_INT); /* if so, we shouldn't arrive here as this is only the case for pseudo-tags */
+ err=TIFFReadDirEntryErrOk;
+ switch (fip->set_field_type)
+ {
+ case TIFF_SETGET_UNDEFINED:
+ break;
+ case TIFF_SETGET_ASCII:
+ {
+ uint8* data;
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ uint32 mb = 0;
+ int n;
+ if (data != NULL)
+ {
+ uint8* ma = data;
+ while (mb<(uint32)dp->tdir_count)
+ {
+ if (*ma==0)
+ break;
+ ma++;
+ mb++;
+ }
+ }
+ if (mb+1<(uint32)dp->tdir_count)
+ TIFFWarningExt(tif->tif_clientdata,module,"ASCII value for tag \"%s\" contains null byte in value; value incorrectly truncated during reading due to implementation limitations",fip->field_name);
+ else if (mb+1>(uint32)dp->tdir_count)
+ {
+ uint8* o;
+ TIFFWarningExt(tif->tif_clientdata,module,"ASCII value for tag \"%s\" does not end in null byte",fip->field_name);
+ if ((uint32)dp->tdir_count+1!=dp->tdir_count+1)
+ o=NULL;
+ else
+ o=_TIFFmalloc((uint32)dp->tdir_count+1);
+ if (o==NULL)
+ {
+ if (data!=NULL)
+ _TIFFfree(data);
+ return(0);
+ }
+ _TIFFmemcpy(o,data,(uint32)dp->tdir_count);
+ o[(uint32)dp->tdir_count]=0;
+ if (data!=0)
+ _TIFFfree(data);
+ data=o;
+ }
+ n=TIFFSetField(tif,dp->tdir_tag,data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!n)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_UINT8:
+ {
+ uint8 data=0;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryByte(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_UINT16:
+ {
+ uint16 data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryShort(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_UINT32:
+ {
+ uint32 data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryLong(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_UINT64:
+ {
+ uint64 data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryLong8(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_FLOAT:
+ {
+ float data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryFloat(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_DOUBLE:
+ {
+ double data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryDouble(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_IFD8:
+ {
+ uint64 data;
+ assert(fip->field_readcount==1);
+ assert(fip->field_passcount==0);
+ err=TIFFReadDirEntryIfd8(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ if (!TIFFSetField(tif,dp->tdir_tag,data))
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_UINT16_PAIR:
+ {
+ uint16* data;
+ assert(fip->field_readcount==2);
+ assert(fip->field_passcount==0);
+ if (dp->tdir_count!=2) {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "incorrect count for field \"%s\", expected 2, got %d",
+ fip->field_name,(int)dp->tdir_count);
+ return(0);
+ }
+ err=TIFFReadDirEntryShortArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,data[0],data[1]);
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C0_UINT8:
+ {
+ uint8* data;
+ assert(fip->field_readcount>=1);
+ assert(fip->field_passcount==0);
+ if (dp->tdir_count!=(uint64)fip->field_readcount) {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "incorrect count for field \"%s\", expected %d, got %d",
+ fip->field_name,(int) fip->field_readcount, (int)dp->tdir_count);
+ return 0;
+ }
+ else
+ {
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C0_UINT16:
+ {
+ uint16* data;
+ assert(fip->field_readcount>=1);
+ assert(fip->field_passcount==0);
+ if (dp->tdir_count!=(uint64)fip->field_readcount)
+ /* corrupt file */;
+ else
+ {
+ err=TIFFReadDirEntryShortArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C0_UINT32:
+ {
+ uint32* data;
+ assert(fip->field_readcount>=1);
+ assert(fip->field_passcount==0);
+ if (dp->tdir_count!=(uint64)fip->field_readcount)
+ /* corrupt file */;
+ else
+ {
+ err=TIFFReadDirEntryLongArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C0_FLOAT:
+ {
+ float* data;
+ assert(fip->field_readcount>=1);
+ assert(fip->field_passcount==0);
+ if (dp->tdir_count!=(uint64)fip->field_readcount)
+ /* corrupt file */;
+ else
+ {
+ err=TIFFReadDirEntryFloatArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_ASCII:
+ {
+ uint8* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ if( data != 0 && dp->tdir_count > 0 && data[dp->tdir_count-1] != '\0' )
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,"ASCII value for tag \"%s\" does not end in null byte. Forcing it to be null",fip->field_name);
+ data[dp->tdir_count-1] = '\0';
+ }
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_UINT8:
+ {
+ uint8* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_UINT16:
+ {
+ uint16* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryShortArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_UINT32:
+ {
+ uint32* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryLongArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_UINT64:
+ {
+ uint64* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryLong8Array(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_FLOAT:
+ {
+ float* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryFloatArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_DOUBLE:
+ {
+ double* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryDoubleArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C16_IFD8:
+ {
+ uint64* data;
+ assert(fip->field_readcount==TIFF_VARIABLE);
+ assert(fip->field_passcount==1);
+ if (dp->tdir_count>0xFFFF)
+ err=TIFFReadDirEntryErrCount;
+ else
+ {
+ err=TIFFReadDirEntryIfd8Array(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint16)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_ASCII:
+ {
+ uint8* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ if( data != 0 && dp->tdir_count > 0 && data[dp->tdir_count-1] != '\0' )
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,"ASCII value for tag \"%s\" does not end in null byte. Forcing it to be null",fip->field_name);
+ data[dp->tdir_count-1] = '\0';
+ }
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_UINT8:
+ {
+ uint8* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryByteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_SINT8:
+ {
+ int8* data = NULL;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntrySbyteArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_UINT16:
+ {
+ uint16* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryShortArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_SINT16:
+ {
+ int16* data = NULL;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntrySshortArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_UINT32:
+ {
+ uint32* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryLongArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_SINT32:
+ {
+ int32* data = NULL;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntrySlongArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_UINT64:
+ {
+ uint64* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryLong8Array(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_SINT64:
+ {
+ int64* data = NULL;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntrySlong8Array(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_FLOAT:
+ {
+ float* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryFloatArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_DOUBLE:
+ {
+ double* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryDoubleArray(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ case TIFF_SETGET_C32_IFD8:
+ {
+ uint64* data;
+ assert(fip->field_readcount==TIFF_VARIABLE2);
+ assert(fip->field_passcount==1);
+ err=TIFFReadDirEntryIfd8Array(tif,dp,&data);
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ int m;
+ m=TIFFSetField(tif,dp->tdir_tag,(uint32)(dp->tdir_count),data);
+ if (data!=0)
+ _TIFFfree(data);
+ if (!m)
+ return(0);
+ }
+ }
+ break;
+ default:
+ assert(0); /* we should never get here */
+ break;
+ }
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ TIFFReadDirEntryOutputErr(tif,err,module,fip->field_name,recover);
+ return(0);
+ }
+ return(1);
+}
+
+/*
+ * Fetch a set of offsets or lengths.
+ * While this routine says "strips", in fact it's also used for tiles.
+ */
+static int
+TIFFFetchStripThing(TIFF* tif, TIFFDirEntry* dir, uint32 nstrips, uint64** lpp)
+{
+ static const char module[] = "TIFFFetchStripThing";
+ enum TIFFReadDirEntryErr err;
+ uint64* data;
+ err=TIFFReadDirEntryLong8ArrayWithLimit(tif,dir,&data,nstrips);
+ if (err!=TIFFReadDirEntryErrOk)
+ {
+ const TIFFField* fip = TIFFFieldWithTag(tif,dir->tdir_tag);
+ TIFFReadDirEntryOutputErr(tif,err,module,fip ? fip->field_name : "unknown tagname",0);
+ return(0);
+ }
+ if (dir->tdir_count<(uint64)nstrips)
+ {
+ uint64* resizeddata;
+ const TIFFField* fip = TIFFFieldWithTag(tif,dir->tdir_tag);
+ const char* pszMax = getenv("LIBTIFF_STRILE_ARRAY_MAX_RESIZE_COUNT");
+ uint32 max_nstrips = 1000000;
+ if( pszMax )
+ max_nstrips = (uint32) atoi(pszMax);
+ TIFFReadDirEntryOutputErr(tif,TIFFReadDirEntryErrCount,
+ module,
+ fip ? fip->field_name : "unknown tagname",
+ ( nstrips <= max_nstrips ) );
+
+ if( nstrips > max_nstrips )
+ {
+ _TIFFfree(data);
+ return(0);
+ }
+
+ resizeddata=(uint64*)_TIFFCheckMalloc(tif,nstrips,sizeof(uint64),"for strip array");
+ if (resizeddata==0) {
+ _TIFFfree(data);
+ return(0);
+ }
+ _TIFFmemcpy(resizeddata,data,(uint32)dir->tdir_count*sizeof(uint64));
+ _TIFFmemset(resizeddata+(uint32)dir->tdir_count,0,(nstrips-(uint32)dir->tdir_count)*sizeof(uint64));
+ _TIFFfree(data);
+ data=resizeddata;
+ }
+ *lpp=data;
+ return(1);
+}
+
+/*
+ * Fetch and set the SubjectDistance EXIF tag.
+ */
+static int
+TIFFFetchSubjectDistance(TIFF* tif, TIFFDirEntry* dir)
+{
+ static const char module[] = "TIFFFetchSubjectDistance";
+ enum TIFFReadDirEntryErr err;
+ UInt64Aligned_t m;
+ m.l=0;
+ assert(sizeof(double)==8);
+ assert(sizeof(uint64)==8);
+ assert(sizeof(uint32)==4);
+ if (dir->tdir_count!=1)
+ err=TIFFReadDirEntryErrCount;
+ else if (dir->tdir_type!=TIFF_RATIONAL)
+ err=TIFFReadDirEntryErrType;
+ else
+ {
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 offset;
+ offset=*(uint32*)(&dir->tdir_offset);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&offset);
+ err=TIFFReadDirEntryData(tif,offset,8,m.i);
+ }
+ else
+ {
+ m.l=dir->tdir_offset.toff_long8;
+ err=TIFFReadDirEntryErrOk;
+ }
+ }
+ if (err==TIFFReadDirEntryErrOk)
+ {
+ double n;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(m.i,2);
+ if (m.i[0]==0)
+ n=0.0;
+ else if (m.i[0]==0xFFFFFFFF)
+ /*
+ * XXX: Numerator 0xFFFFFFFF means that we have infinite
+ * distance. Indicate that with a negative floating point
+ * SubjectDistance value.
+ */
+ n=-1.0;
+ else
+ n=(double)m.i[0]/(double)m.i[1];
+ return(TIFFSetField(tif,dir->tdir_tag,n));
+ }
+ else
+ {
+ TIFFReadDirEntryOutputErr(tif,err,module,"SubjectDistance",TRUE);
+ return(0);
+ }
+}
+
+/*
+ * Replace a single strip (tile) of uncompressed data by multiple strips
+ * (tiles), each approximately STRIP_SIZE_DEFAULT bytes. This is useful for
+ * dealing with large images or for dealing with machines with a limited
+ * amount memory.
+ */
+static void
+ChopUpSingleUncompressedStrip(TIFF* tif)
+{
+ register TIFFDirectory *td = &tif->tif_dir;
+ uint64 bytecount;
+ uint64 offset;
+ uint32 rowblock;
+ uint64 rowblockbytes;
+ uint64 stripbytes;
+ uint32 strip;
+ uint32 nstrips;
+ uint32 rowsperstrip;
+ uint64* newcounts;
+ uint64* newoffsets;
+
+ bytecount = td->td_stripbytecount[0];
+ /* On a newly created file, just re-opened to be filled, we */
+ /* don't want strip chop to trigger as it is going to cause issues */
+ /* later ( StripOffsets and StripByteCounts improperly filled) . */
+ if( bytecount == 0 && tif->tif_mode != O_RDONLY )
+ return;
+ offset = td->td_stripoffset[0];
+ assert(td->td_planarconfig == PLANARCONFIG_CONTIG);
+ if ((td->td_photometric == PHOTOMETRIC_YCBCR)&&
+ (!isUpSampled(tif)))
+ rowblock = td->td_ycbcrsubsampling[1];
+ else
+ rowblock = 1;
+ rowblockbytes = TIFFVTileSize64(tif, rowblock);
+ /*
+ * Make the rows hold at least one scanline, but fill specified amount
+ * of data if possible.
+ */
+ if (rowblockbytes > STRIP_SIZE_DEFAULT) {
+ stripbytes = rowblockbytes;
+ rowsperstrip = rowblock;
+ } else if (rowblockbytes > 0 ) {
+ uint32 rowblocksperstrip;
+ rowblocksperstrip = (uint32) (STRIP_SIZE_DEFAULT / rowblockbytes);
+ rowsperstrip = rowblocksperstrip * rowblock;
+ stripbytes = rowblocksperstrip * rowblockbytes;
+ }
+ else
+ return;
+
+ /*
+ * never increase the number of rows per strip
+ */
+ if (rowsperstrip >= td->td_rowsperstrip)
+ return;
+ nstrips = TIFFhowmany_32(td->td_imagelength, rowsperstrip);
+ if( nstrips == 0 )
+ return;
+
+ /* If we are going to allocate a lot of memory, make sure that the */
+ /* file is as big as needed */
+ if( tif->tif_mode == O_RDONLY &&
+ nstrips > 1000000 &&
+ (offset >= TIFFGetFileSize(tif) ||
+ stripbytes > (TIFFGetFileSize(tif) - offset) / (nstrips - 1)) )
+ {
+ return;
+ }
+
+ newcounts = (uint64*) _TIFFCheckMalloc(tif, nstrips, sizeof (uint64),
+ "for chopped \"StripByteCounts\" array");
+ newoffsets = (uint64*) _TIFFCheckMalloc(tif, nstrips, sizeof (uint64),
+ "for chopped \"StripOffsets\" array");
+ if (newcounts == NULL || newoffsets == NULL) {
+ /*
+ * Unable to allocate new strip information, give up and use
+ * the original one strip information.
+ */
+ if (newcounts != NULL)
+ _TIFFfree(newcounts);
+ if (newoffsets != NULL)
+ _TIFFfree(newoffsets);
+ return;
+ }
+ /*
+ * Fill the strip information arrays with new bytecounts and offsets
+ * that reflect the broken-up format.
+ */
+ for (strip = 0; strip < nstrips; strip++) {
+ if (stripbytes > bytecount)
+ stripbytes = bytecount;
+ newcounts[strip] = stripbytes;
+ newoffsets[strip] = stripbytes ? offset : 0;
+ offset += stripbytes;
+ bytecount -= stripbytes;
+ }
+ /*
+ * Replace old single strip info with multi-strip info.
+ */
+ td->td_stripsperimage = td->td_nstrips = nstrips;
+ TIFFSetField(tif, TIFFTAG_ROWSPERSTRIP, rowsperstrip);
+
+ _TIFFfree(td->td_stripbytecount);
+ _TIFFfree(td->td_stripoffset);
+ td->td_stripbytecount = newcounts;
+ td->td_stripoffset = newoffsets;
+ td->td_stripbytecountsorted = 1;
+}
+
+int _TIFFFillStriles( TIFF *tif )
+{
+ return _TIFFFillStrilesInternal( tif, 1 );
+}
+
+static int _TIFFFillStrilesInternal( TIFF *tif, int loadStripByteCount )
+{
+#if defined(DEFER_STRILE_LOAD)
+ register TIFFDirectory *td = &tif->tif_dir;
+ int return_value = 1;
+
+ if( td->td_stripoffset != NULL )
+ return 1;
+
+ if( td->td_stripoffset_entry.tdir_count == 0 )
+ return 0;
+
+ if (!TIFFFetchStripThing(tif,&(td->td_stripoffset_entry),
+ td->td_nstrips,&td->td_stripoffset))
+ {
+ return_value = 0;
+ }
+
+ if (loadStripByteCount &&
+ !TIFFFetchStripThing(tif,&(td->td_stripbytecount_entry),
+ td->td_nstrips,&td->td_stripbytecount))
+ {
+ return_value = 0;
+ }
+
+ _TIFFmemset( &(td->td_stripoffset_entry), 0, sizeof(TIFFDirEntry));
+ _TIFFmemset( &(td->td_stripbytecount_entry), 0, sizeof(TIFFDirEntry));
+
+ if (tif->tif_dir.td_nstrips > 1 && return_value == 1 ) {
+ uint32 strip;
+
+ tif->tif_dir.td_stripbytecountsorted = 1;
+ for (strip = 1; strip < tif->tif_dir.td_nstrips; strip++) {
+ if (tif->tif_dir.td_stripoffset[strip - 1] >
+ tif->tif_dir.td_stripoffset[strip]) {
+ tif->tif_dir.td_stripbytecountsorted = 0;
+ break;
+ }
+ }
+ }
+
+ return return_value;
+#else /* !defined(DEFER_STRILE_LOAD) */
+ (void) tif;
+ (void) loadStripByteCount;
+ return 1;
+#endif
+}
+
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dirwrite.c b/test/monniaux/tiff-4.0.10/tif_dirwrite.c
new file mode 100644
index 00000000..c15a28db
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dirwrite.c
@@ -0,0 +1,3025 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Directory Write Support Routines.
+ */
+#include "tiffiop.h"
+#include <float.h>
+
+#ifdef HAVE_IEEEFP
+#define TIFFCvtNativeToIEEEFloat(tif, n, fp)
+#define TIFFCvtNativeToIEEEDouble(tif, n, dp)
+#else
+extern void TIFFCvtNativeToIEEEFloat(TIFF* tif, uint32 n, float* fp);
+extern void TIFFCvtNativeToIEEEDouble(TIFF* tif, uint32 n, double* dp);
+#endif
+
+static int TIFFWriteDirectorySec(TIFF* tif, int isimage, int imagedone, uint64* pdiroff);
+
+static int TIFFWriteDirectoryTagSampleformatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value);
+#if 0
+static int TIFFWriteDirectoryTagSampleformatPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+#endif
+
+static int TIFFWriteDirectoryTagAscii(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, char* value);
+static int TIFFWriteDirectoryTagUndefinedArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagByte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value);
+#endif
+static int TIFFWriteDirectoryTagByteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value);
+#if 0
+static int TIFFWriteDirectoryTagBytePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value);
+#endif
+#ifdef notdef
+static int TIFFWriteDirectoryTagSbyte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value);
+#endif
+static int TIFFWriteDirectoryTagSbyteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int8* value);
+#if 0
+static int TIFFWriteDirectoryTagSbytePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value);
+#endif
+static int TIFFWriteDirectoryTagShort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value);
+static int TIFFWriteDirectoryTagShortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint16* value);
+static int TIFFWriteDirectoryTagShortPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagSshort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value);
+#endif
+static int TIFFWriteDirectoryTagSshortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int16* value);
+#if 0
+static int TIFFWriteDirectoryTagSshortPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value);
+#endif
+static int TIFFWriteDirectoryTagLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value);
+static int TIFFWriteDirectoryTagLongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value);
+#if 0
+static int TIFFWriteDirectoryTagLongPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value);
+#endif
+#ifdef notdef
+static int TIFFWriteDirectoryTagSlong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value);
+#endif
+static int TIFFWriteDirectoryTagSlongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int32* value);
+#if 0
+static int TIFFWriteDirectoryTagSlongPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value);
+#endif
+#ifdef notdef
+static int TIFFWriteDirectoryTagLong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint64 value);
+#endif
+static int TIFFWriteDirectoryTagLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagSlong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int64 value);
+#endif
+static int TIFFWriteDirectoryTagSlong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int64* value);
+static int TIFFWriteDirectoryTagRational(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+static int TIFFWriteDirectoryTagRationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+static int TIFFWriteDirectoryTagSrationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagFloat(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value);
+#endif
+static int TIFFWriteDirectoryTagFloatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+#if 0
+static int TIFFWriteDirectoryTagFloatPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value);
+#endif
+#ifdef notdef
+static int TIFFWriteDirectoryTagDouble(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+#endif
+static int TIFFWriteDirectoryTagDoubleArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value);
+#if 0
+static int TIFFWriteDirectoryTagDoublePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+#endif
+static int TIFFWriteDirectoryTagIfdArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+#endif
+static int TIFFWriteDirectoryTagShortLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value);
+static int TIFFWriteDirectoryTagLongLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+static int TIFFWriteDirectoryTagIfdIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagShortLongLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+#endif
+static int TIFFWriteDirectoryTagColormap(TIFF* tif, uint32* ndir, TIFFDirEntry* dir);
+static int TIFFWriteDirectoryTagTransferfunction(TIFF* tif, uint32* ndir, TIFFDirEntry* dir);
+static int TIFFWriteDirectoryTagSubifd(TIFF* tif, uint32* ndir, TIFFDirEntry* dir);
+
+static int TIFFWriteDirectoryTagCheckedAscii(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, char* value);
+static int TIFFWriteDirectoryTagCheckedUndefinedArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedByte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedByteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedSbyte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedSbyteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int8* value);
+static int TIFFWriteDirectoryTagCheckedShort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value);
+static int TIFFWriteDirectoryTagCheckedShortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint16* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedSshort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedSshortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int16* value);
+static int TIFFWriteDirectoryTagCheckedLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value);
+static int TIFFWriteDirectoryTagCheckedLongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedSlong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedSlongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int32* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedLong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint64 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedSlong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int64 value);
+#endif
+static int TIFFWriteDirectoryTagCheckedSlong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int64* value);
+static int TIFFWriteDirectoryTagCheckedRational(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+static int TIFFWriteDirectoryTagCheckedRationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+static int TIFFWriteDirectoryTagCheckedSrationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedFloat(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value);
+#endif
+static int TIFFWriteDirectoryTagCheckedFloatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value);
+#ifdef notdef
+static int TIFFWriteDirectoryTagCheckedDouble(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value);
+#endif
+static int TIFFWriteDirectoryTagCheckedDoubleArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value);
+static int TIFFWriteDirectoryTagCheckedIfdArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value);
+static int TIFFWriteDirectoryTagCheckedIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value);
+
+static int TIFFWriteDirectoryTagData(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 datatype, uint32 count, uint32 datalength, void* data);
+
+static int TIFFLinkDirectory(TIFF*);
+
+/*
+ * Write the contents of the current directory
+ * to the specified file. This routine doesn't
+ * handle overwriting a directory with auxiliary
+ * storage that's been changed.
+ */
+int
+TIFFWriteDirectory(TIFF* tif)
+{
+ return TIFFWriteDirectorySec(tif,TRUE,TRUE,NULL);
+}
+
+/*
+ * Similar to TIFFWriteDirectory(), writes the directory out
+ * but leaves all data structures in memory so that it can be
+ * written again. This will make a partially written TIFF file
+ * readable before it is successfully completed/closed.
+ */
+int
+TIFFCheckpointDirectory(TIFF* tif)
+{
+ int rc;
+ /* Setup the strips arrays, if they haven't already been. */
+ if (tif->tif_dir.td_stripoffset == NULL)
+ (void) TIFFSetupStrips(tif);
+ rc = TIFFWriteDirectorySec(tif,TRUE,FALSE,NULL);
+ (void) TIFFSetWriteOffset(tif, TIFFSeekFile(tif, 0, SEEK_END));
+ return rc;
+}
+
+int
+TIFFWriteCustomDirectory(TIFF* tif, uint64* pdiroff)
+{
+ return TIFFWriteDirectorySec(tif,FALSE,FALSE,pdiroff);
+}
+
+/*
+ * Similar to TIFFWriteDirectory(), but if the directory has already
+ * been written once, it is relocated to the end of the file, in case it
+ * has changed in size. Note that this will result in the loss of the
+ * previously used directory space.
+ */
+int
+TIFFRewriteDirectory( TIFF *tif )
+{
+ static const char module[] = "TIFFRewriteDirectory";
+
+ /* We don't need to do anything special if it hasn't been written. */
+ if( tif->tif_diroff == 0 )
+ return TIFFWriteDirectory( tif );
+
+ /*
+ * Find and zero the pointer to this directory, so that TIFFLinkDirectory
+ * will cause it to be added after this directories current pre-link.
+ */
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (tif->tif_header.classic.tiff_diroff == tif->tif_diroff)
+ {
+ tif->tif_header.classic.tiff_diroff = 0;
+ tif->tif_diroff = 0;
+
+ TIFFSeekFile(tif,4,SEEK_SET);
+ if (!WriteOK(tif, &(tif->tif_header.classic.tiff_diroff),4))
+ {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Error updating TIFF header");
+ return (0);
+ }
+ }
+ else
+ {
+ uint32 nextdir;
+ nextdir = tif->tif_header.classic.tiff_diroff;
+ while(1) {
+ uint16 dircount;
+ uint32 nextnextdir;
+
+ if (!SeekOK(tif, nextdir) ||
+ !ReadOK(tif, &dircount, 2)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory count");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount);
+ (void) TIFFSeekFile(tif,
+ nextdir+2+dircount*12, SEEK_SET);
+ if (!ReadOK(tif, &nextnextdir, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory link");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&nextnextdir);
+ if (nextnextdir==tif->tif_diroff)
+ {
+ uint32 m;
+ m=0;
+ (void) TIFFSeekFile(tif,
+ nextdir+2+dircount*12, SEEK_SET);
+ if (!WriteOK(tif, &m, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+ tif->tif_diroff=0;
+ break;
+ }
+ nextdir=nextnextdir;
+ }
+ }
+ }
+ else
+ {
+ if (tif->tif_header.big.tiff_diroff == tif->tif_diroff)
+ {
+ tif->tif_header.big.tiff_diroff = 0;
+ tif->tif_diroff = 0;
+
+ TIFFSeekFile(tif,8,SEEK_SET);
+ if (!WriteOK(tif, &(tif->tif_header.big.tiff_diroff),8))
+ {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Error updating TIFF header");
+ return (0);
+ }
+ }
+ else
+ {
+ uint64 nextdir;
+ nextdir = tif->tif_header.big.tiff_diroff;
+ while(1) {
+ uint64 dircount64;
+ uint16 dircount;
+ uint64 nextnextdir;
+
+ if (!SeekOK(tif, nextdir) ||
+ !ReadOK(tif, &dircount64, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory count");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>0xFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on tag count failed, likely corrupt TIFF");
+ return (0);
+ }
+ dircount=(uint16)dircount64;
+ (void) TIFFSeekFile(tif,
+ nextdir+8+dircount*20, SEEK_SET);
+ if (!ReadOK(tif, &nextnextdir, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory link");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&nextnextdir);
+ if (nextnextdir==tif->tif_diroff)
+ {
+ uint64 m;
+ m=0;
+ (void) TIFFSeekFile(tif,
+ nextdir+8+dircount*20, SEEK_SET);
+ if (!WriteOK(tif, &m, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+ tif->tif_diroff=0;
+ break;
+ }
+ nextdir=nextnextdir;
+ }
+ }
+ }
+
+ /*
+ * Now use TIFFWriteDirectory() normally.
+ */
+
+ return TIFFWriteDirectory( tif );
+}
+
+static int
+TIFFWriteDirectorySec(TIFF* tif, int isimage, int imagedone, uint64* pdiroff)
+{
+ static const char module[] = "TIFFWriteDirectorySec";
+ uint32 ndir;
+ TIFFDirEntry* dir;
+ uint32 dirsize;
+ void* dirmem;
+ uint32 m;
+ if (tif->tif_mode == O_RDONLY)
+ return (1);
+
+ _TIFFFillStriles( tif );
+
+ /*
+ * Clear write state so that subsequent images with
+ * different characteristics get the right buffers
+ * setup for them.
+ */
+ if (imagedone)
+ {
+ if (tif->tif_flags & TIFF_POSTENCODE)
+ {
+ tif->tif_flags &= ~TIFF_POSTENCODE;
+ if (!(*tif->tif_postencode)(tif))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Error post-encoding before directory write");
+ return (0);
+ }
+ }
+ (*tif->tif_close)(tif); /* shutdown encoder */
+ /*
+ * Flush any data that might have been written
+ * by the compression close+cleanup routines. But
+ * be careful not to write stuff if we didn't add data
+ * in the previous steps as the "rawcc" data may well be
+ * a previously read tile/strip in mixed read/write mode.
+ */
+ if (tif->tif_rawcc > 0
+ && (tif->tif_flags & TIFF_BEENWRITING) != 0 )
+ {
+ if( !TIFFFlushData1(tif) )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error flushing data before directory write");
+ return (0);
+ }
+ }
+ if ((tif->tif_flags & TIFF_MYBUFFER) && tif->tif_rawdata)
+ {
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = NULL;
+ tif->tif_rawcc = 0;
+ tif->tif_rawdatasize = 0;
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = 0;
+ }
+ tif->tif_flags &= ~(TIFF_BEENWRITING|TIFF_BUFFERSETUP);
+ }
+ dir=NULL;
+ dirmem=NULL;
+ dirsize=0;
+ while (1)
+ {
+ ndir=0;
+ if (isimage)
+ {
+ if (TIFFFieldSet(tif,FIELD_IMAGEDIMENSIONS))
+ {
+ if (!TIFFWriteDirectoryTagShortLong(tif,&ndir,dir,TIFFTAG_IMAGEWIDTH,tif->tif_dir.td_imagewidth))
+ goto bad;
+ if (!TIFFWriteDirectoryTagShortLong(tif,&ndir,dir,TIFFTAG_IMAGELENGTH,tif->tif_dir.td_imagelength))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_TILEDIMENSIONS))
+ {
+ if (!TIFFWriteDirectoryTagShortLong(tif,&ndir,dir,TIFFTAG_TILEWIDTH,tif->tif_dir.td_tilewidth))
+ goto bad;
+ if (!TIFFWriteDirectoryTagShortLong(tif,&ndir,dir,TIFFTAG_TILELENGTH,tif->tif_dir.td_tilelength))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_RESOLUTION))
+ {
+ if (!TIFFWriteDirectoryTagRational(tif,&ndir,dir,TIFFTAG_XRESOLUTION,tif->tif_dir.td_xresolution))
+ goto bad;
+ if (!TIFFWriteDirectoryTagRational(tif,&ndir,dir,TIFFTAG_YRESOLUTION,tif->tif_dir.td_yresolution))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_POSITION))
+ {
+ if (!TIFFWriteDirectoryTagRational(tif,&ndir,dir,TIFFTAG_XPOSITION,tif->tif_dir.td_xposition))
+ goto bad;
+ if (!TIFFWriteDirectoryTagRational(tif,&ndir,dir,TIFFTAG_YPOSITION,tif->tif_dir.td_yposition))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_SUBFILETYPE))
+ {
+ if (!TIFFWriteDirectoryTagLong(tif,&ndir,dir,TIFFTAG_SUBFILETYPE,tif->tif_dir.td_subfiletype))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_BITSPERSAMPLE))
+ {
+ if (!TIFFWriteDirectoryTagShortPerSample(tif,&ndir,dir,TIFFTAG_BITSPERSAMPLE,tif->tif_dir.td_bitspersample))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_COMPRESSION))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_COMPRESSION,tif->tif_dir.td_compression))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_PHOTOMETRIC))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_PHOTOMETRIC,tif->tif_dir.td_photometric))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_THRESHHOLDING))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_THRESHHOLDING,tif->tif_dir.td_threshholding))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_FILLORDER))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_FILLORDER,tif->tif_dir.td_fillorder))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_ORIENTATION))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_ORIENTATION,tif->tif_dir.td_orientation))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_SAMPLESPERPIXEL))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_SAMPLESPERPIXEL,tif->tif_dir.td_samplesperpixel))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_ROWSPERSTRIP))
+ {
+ if (!TIFFWriteDirectoryTagShortLong(tif,&ndir,dir,TIFFTAG_ROWSPERSTRIP,tif->tif_dir.td_rowsperstrip))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_MINSAMPLEVALUE))
+ {
+ if (!TIFFWriteDirectoryTagShortPerSample(tif,&ndir,dir,TIFFTAG_MINSAMPLEVALUE,tif->tif_dir.td_minsamplevalue))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_MAXSAMPLEVALUE))
+ {
+ if (!TIFFWriteDirectoryTagShortPerSample(tif,&ndir,dir,TIFFTAG_MAXSAMPLEVALUE,tif->tif_dir.td_maxsamplevalue))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_PLANARCONFIG))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_PLANARCONFIG,tif->tif_dir.td_planarconfig))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_RESOLUTIONUNIT))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_RESOLUTIONUNIT,tif->tif_dir.td_resolutionunit))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_PAGENUMBER))
+ {
+ if (!TIFFWriteDirectoryTagShortArray(tif,&ndir,dir,TIFFTAG_PAGENUMBER,2,&tif->tif_dir.td_pagenumber[0]))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_STRIPBYTECOUNTS))
+ {
+ if (!isTiled(tif))
+ {
+ if (!TIFFWriteDirectoryTagLongLong8Array(tif,&ndir,dir,TIFFTAG_STRIPBYTECOUNTS,tif->tif_dir.td_nstrips,tif->tif_dir.td_stripbytecount))
+ goto bad;
+ }
+ else
+ {
+ if (!TIFFWriteDirectoryTagLongLong8Array(tif,&ndir,dir,TIFFTAG_TILEBYTECOUNTS,tif->tif_dir.td_nstrips,tif->tif_dir.td_stripbytecount))
+ goto bad;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_STRIPOFFSETS))
+ {
+ if (!isTiled(tif))
+ {
+ /* td_stripoffset might be NULL in an odd OJPEG case. See
+ * tif_dirread.c around line 3634.
+ * XXX: OJPEG hack.
+ * If a) compression is OJPEG, b) it's not a tiled TIFF,
+ * and c) the number of strips is 1,
+ * then we tolerate the absence of stripoffsets tag,
+ * because, presumably, all required data is in the
+ * JpegInterchangeFormat stream.
+ * We can get here when using tiffset on such a file.
+ * See http://bugzilla.maptools.org/show_bug.cgi?id=2500
+ */
+ if (tif->tif_dir.td_stripoffset != NULL &&
+ !TIFFWriteDirectoryTagLongLong8Array(tif,&ndir,dir,TIFFTAG_STRIPOFFSETS,tif->tif_dir.td_nstrips,tif->tif_dir.td_stripoffset))
+ goto bad;
+ }
+ else
+ {
+ if (!TIFFWriteDirectoryTagLongLong8Array(tif,&ndir,dir,TIFFTAG_TILEOFFSETS,tif->tif_dir.td_nstrips,tif->tif_dir.td_stripoffset))
+ goto bad;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_COLORMAP))
+ {
+ if (!TIFFWriteDirectoryTagColormap(tif,&ndir,dir))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_EXTRASAMPLES))
+ {
+ if (tif->tif_dir.td_extrasamples)
+ {
+ uint16 na;
+ uint16* nb;
+ TIFFGetFieldDefaulted(tif,TIFFTAG_EXTRASAMPLES,&na,&nb);
+ if (!TIFFWriteDirectoryTagShortArray(tif,&ndir,dir,TIFFTAG_EXTRASAMPLES,na,nb))
+ goto bad;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_SAMPLEFORMAT))
+ {
+ if (!TIFFWriteDirectoryTagShortPerSample(tif,&ndir,dir,TIFFTAG_SAMPLEFORMAT,tif->tif_dir.td_sampleformat))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_SMINSAMPLEVALUE))
+ {
+ if (!TIFFWriteDirectoryTagSampleformatArray(tif,&ndir,dir,TIFFTAG_SMINSAMPLEVALUE,tif->tif_dir.td_samplesperpixel,tif->tif_dir.td_sminsamplevalue))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_SMAXSAMPLEVALUE))
+ {
+ if (!TIFFWriteDirectoryTagSampleformatArray(tif,&ndir,dir,TIFFTAG_SMAXSAMPLEVALUE,tif->tif_dir.td_samplesperpixel,tif->tif_dir.td_smaxsamplevalue))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_IMAGEDEPTH))
+ {
+ if (!TIFFWriteDirectoryTagLong(tif,&ndir,dir,TIFFTAG_IMAGEDEPTH,tif->tif_dir.td_imagedepth))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_TILEDEPTH))
+ {
+ if (!TIFFWriteDirectoryTagLong(tif,&ndir,dir,TIFFTAG_TILEDEPTH,tif->tif_dir.td_tiledepth))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_HALFTONEHINTS))
+ {
+ if (!TIFFWriteDirectoryTagShortArray(tif,&ndir,dir,TIFFTAG_HALFTONEHINTS,2,&tif->tif_dir.td_halftonehints[0]))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_YCBCRSUBSAMPLING))
+ {
+ if (!TIFFWriteDirectoryTagShortArray(tif,&ndir,dir,TIFFTAG_YCBCRSUBSAMPLING,2,&tif->tif_dir.td_ycbcrsubsampling[0]))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_YCBCRPOSITIONING))
+ {
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,TIFFTAG_YCBCRPOSITIONING,tif->tif_dir.td_ycbcrpositioning))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_REFBLACKWHITE))
+ {
+ if (!TIFFWriteDirectoryTagRationalArray(tif,&ndir,dir,TIFFTAG_REFERENCEBLACKWHITE,6,tif->tif_dir.td_refblackwhite))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_TRANSFERFUNCTION))
+ {
+ if (!TIFFWriteDirectoryTagTransferfunction(tif,&ndir,dir))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_INKNAMES))
+ {
+ if (!TIFFWriteDirectoryTagAscii(tif,&ndir,dir,TIFFTAG_INKNAMES,tif->tif_dir.td_inknameslen,tif->tif_dir.td_inknames))
+ goto bad;
+ }
+ if (TIFFFieldSet(tif,FIELD_SUBIFD))
+ {
+ if (!TIFFWriteDirectoryTagSubifd(tif,&ndir,dir))
+ goto bad;
+ }
+ {
+ uint32 n;
+ for (n=0; n<tif->tif_nfields; n++) {
+ const TIFFField* o;
+ o = tif->tif_fields[n];
+ if ((o->field_bit>=FIELD_CODEC)&&(TIFFFieldSet(tif,o->field_bit)))
+ {
+ switch (o->get_field_type)
+ {
+ case TIFF_SETGET_ASCII:
+ {
+ uint32 pa;
+ char* pb;
+ assert(o->field_type==TIFF_ASCII);
+ assert(o->field_readcount==TIFF_VARIABLE);
+ assert(o->field_passcount==0);
+ TIFFGetField(tif,o->field_tag,&pb);
+ pa=(uint32)(strlen(pb));
+ if (!TIFFWriteDirectoryTagAscii(tif,&ndir,dir,(uint16)o->field_tag,pa,pb))
+ goto bad;
+ }
+ break;
+ case TIFF_SETGET_UINT16:
+ {
+ uint16 p;
+ assert(o->field_type==TIFF_SHORT);
+ assert(o->field_readcount==1);
+ assert(o->field_passcount==0);
+ TIFFGetField(tif,o->field_tag,&p);
+ if (!TIFFWriteDirectoryTagShort(tif,&ndir,dir,(uint16)o->field_tag,p))
+ goto bad;
+ }
+ break;
+ case TIFF_SETGET_UINT32:
+ {
+ uint32 p;
+ assert(o->field_type==TIFF_LONG);
+ assert(o->field_readcount==1);
+ assert(o->field_passcount==0);
+ TIFFGetField(tif,o->field_tag,&p);
+ if (!TIFFWriteDirectoryTagLong(tif,&ndir,dir,(uint16)o->field_tag,p))
+ goto bad;
+ }
+ break;
+ case TIFF_SETGET_C32_UINT8:
+ {
+ uint32 pa;
+ void* pb;
+ assert(o->field_type==TIFF_UNDEFINED);
+ assert(o->field_readcount==TIFF_VARIABLE2);
+ assert(o->field_passcount==1);
+ TIFFGetField(tif,o->field_tag,&pa,&pb);
+ if (!TIFFWriteDirectoryTagUndefinedArray(tif,&ndir,dir,(uint16)o->field_tag,pa,pb))
+ goto bad;
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Cannot write tag %d (%s)",
+ TIFFFieldTag(o),
+ o->field_name ? o->field_name : "unknown");
+ goto bad;
+ }
+ }
+ }
+ }
+ }
+ for (m=0; m<(uint32)(tif->tif_dir.td_customValueCount); m++)
+ {
+ uint16 tag = (uint16)tif->tif_dir.td_customValues[m].info->field_tag;
+ uint32 count = tif->tif_dir.td_customValues[m].count;
+ switch (tif->tif_dir.td_customValues[m].info->field_type)
+ {
+ case TIFF_ASCII:
+ if (!TIFFWriteDirectoryTagAscii(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_UNDEFINED:
+ if (!TIFFWriteDirectoryTagUndefinedArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_BYTE:
+ if (!TIFFWriteDirectoryTagByteArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SBYTE:
+ if (!TIFFWriteDirectoryTagSbyteArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SHORT:
+ if (!TIFFWriteDirectoryTagShortArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SSHORT:
+ if (!TIFFWriteDirectoryTagSshortArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_LONG:
+ if (!TIFFWriteDirectoryTagLongArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SLONG:
+ if (!TIFFWriteDirectoryTagSlongArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_LONG8:
+ if (!TIFFWriteDirectoryTagLong8Array(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SLONG8:
+ if (!TIFFWriteDirectoryTagSlong8Array(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_RATIONAL:
+ if (!TIFFWriteDirectoryTagRationalArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_SRATIONAL:
+ if (!TIFFWriteDirectoryTagSrationalArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_FLOAT:
+ if (!TIFFWriteDirectoryTagFloatArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_DOUBLE:
+ if (!TIFFWriteDirectoryTagDoubleArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_IFD:
+ if (!TIFFWriteDirectoryTagIfdArray(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ case TIFF_IFD8:
+ if (!TIFFWriteDirectoryTagIfdIfd8Array(tif,&ndir,dir,tag,count,tif->tif_dir.td_customValues[m].value))
+ goto bad;
+ break;
+ default:
+ assert(0); /* we should never get here */
+ break;
+ }
+ }
+ if (dir!=NULL)
+ break;
+ dir=_TIFFmalloc(ndir*sizeof(TIFFDirEntry));
+ if (dir==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ goto bad;
+ }
+ if (isimage)
+ {
+ if ((tif->tif_diroff==0)&&(!TIFFLinkDirectory(tif)))
+ goto bad;
+ }
+ else
+ tif->tif_diroff=(TIFFSeekFile(tif,0,SEEK_END)+1)&(~((toff_t)1));
+ if (pdiroff!=NULL)
+ *pdiroff=tif->tif_diroff;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ dirsize=2+ndir*12+4;
+ else
+ dirsize=8+ndir*20+8;
+ tif->tif_dataoff=tif->tif_diroff+dirsize;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ tif->tif_dataoff=(uint32)tif->tif_dataoff;
+ if ((tif->tif_dataoff<tif->tif_diroff)||(tif->tif_dataoff<(uint64)dirsize))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Maximum TIFF file size exceeded");
+ goto bad;
+ }
+ if (tif->tif_dataoff&1)
+ tif->tif_dataoff++;
+ if (isimage)
+ tif->tif_curdir++;
+ }
+ if (isimage)
+ {
+ if (TIFFFieldSet(tif,FIELD_SUBIFD)&&(tif->tif_subifdoff==0))
+ {
+ uint32 na;
+ TIFFDirEntry* nb;
+ for (na=0, nb=dir; ; na++, nb++)
+ {
+ if( na == ndir )
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Cannot find SubIFD tag");
+ goto bad;
+ }
+ if (nb->tdir_tag==TIFFTAG_SUBIFD)
+ break;
+ }
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ tif->tif_subifdoff=tif->tif_diroff+2+na*12+8;
+ else
+ tif->tif_subifdoff=tif->tif_diroff+8+na*20+12;
+ }
+ }
+ dirmem=_TIFFmalloc(dirsize);
+ if (dirmem==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ goto bad;
+ }
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint8* n;
+ uint32 nTmp;
+ TIFFDirEntry* o;
+ n=dirmem;
+ *(uint16*)n=(uint16)ndir;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)n);
+ n+=2;
+ o=dir;
+ for (m=0; m<ndir; m++)
+ {
+ *(uint16*)n=o->tdir_tag;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)n);
+ n+=2;
+ *(uint16*)n=o->tdir_type;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)n);
+ n+=2;
+ nTmp = (uint32)o->tdir_count;
+ _TIFFmemcpy(n,&nTmp,4);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)n);
+ n+=4;
+ /* This is correct. The data has been */
+ /* swabbed previously in TIFFWriteDirectoryTagData */
+ _TIFFmemcpy(n,&o->tdir_offset,4);
+ n+=4;
+ o++;
+ }
+ nTmp = (uint32)tif->tif_nextdiroff;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&nTmp);
+ _TIFFmemcpy(n,&nTmp,4);
+ }
+ else
+ {
+ uint8* n;
+ TIFFDirEntry* o;
+ n=dirmem;
+ *(uint64*)n=ndir;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)n);
+ n+=8;
+ o=dir;
+ for (m=0; m<ndir; m++)
+ {
+ *(uint16*)n=o->tdir_tag;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)n);
+ n+=2;
+ *(uint16*)n=o->tdir_type;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)n);
+ n+=2;
+ _TIFFmemcpy(n,&o->tdir_count,8);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)n);
+ n+=8;
+ _TIFFmemcpy(n,&o->tdir_offset,8);
+ n+=8;
+ o++;
+ }
+ _TIFFmemcpy(n,&tif->tif_nextdiroff,8);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)n);
+ }
+ _TIFFfree(dir);
+ dir=NULL;
+ if (!SeekOK(tif,tif->tif_diroff))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"IO error writing directory");
+ goto bad;
+ }
+ if (!WriteOK(tif,dirmem,(tmsize_t)dirsize))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"IO error writing directory");
+ goto bad;
+ }
+ _TIFFfree(dirmem);
+ if (imagedone)
+ {
+ TIFFFreeDirectory(tif);
+ tif->tif_flags &= ~TIFF_DIRTYDIRECT;
+ tif->tif_flags &= ~TIFF_DIRTYSTRIP;
+ (*tif->tif_cleanup)(tif);
+ /*
+ * Reset directory-related state for subsequent
+ * directories.
+ */
+ TIFFCreateDirectory(tif);
+ }
+ return(1);
+bad:
+ if (dir!=NULL)
+ _TIFFfree(dir);
+ if (dirmem!=NULL)
+ _TIFFfree(dirmem);
+ return(0);
+}
+
+static float TIFFClampDoubleToFloat( double val )
+{
+ if( val > FLT_MAX )
+ return FLT_MAX;
+ if( val < -FLT_MAX )
+ return -FLT_MAX;
+ return (float)val;
+}
+
+static int8 TIFFClampDoubleToInt8( double val )
+{
+ if( val > 127 )
+ return 127;
+ if( val < -128 || val != val )
+ return -128;
+ return (int8)val;
+}
+
+static int16 TIFFClampDoubleToInt16( double val )
+{
+ if( val > 32767 )
+ return 32767;
+ if( val < -32768 || val != val )
+ return -32768;
+ return (int16)val;
+}
+
+static int32 TIFFClampDoubleToInt32( double val )
+{
+ if( val > 0x7FFFFFFF )
+ return 0x7FFFFFFF;
+ if( val < -0x7FFFFFFF-1 || val != val )
+ return -0x7FFFFFFF-1;
+ return (int32)val;
+}
+
+static uint8 TIFFClampDoubleToUInt8( double val )
+{
+ if( val < 0 )
+ return 0;
+ if( val > 255 || val != val )
+ return 255;
+ return (uint8)val;
+}
+
+static uint16 TIFFClampDoubleToUInt16( double val )
+{
+ if( val < 0 )
+ return 0;
+ if( val > 65535 || val != val )
+ return 65535;
+ return (uint16)val;
+}
+
+static uint32 TIFFClampDoubleToUInt32( double val )
+{
+ if( val < 0 )
+ return 0;
+ if( val > 0xFFFFFFFFU || val != val )
+ return 0xFFFFFFFFU;
+ return (uint32)val;
+}
+
+static int
+TIFFWriteDirectoryTagSampleformatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagSampleformatArray";
+ void* conv;
+ uint32 i;
+ int ok;
+ conv = _TIFFmalloc(count*sizeof(double));
+ if (conv == NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Out of memory");
+ return (0);
+ }
+
+ switch (tif->tif_dir.td_sampleformat)
+ {
+ case SAMPLEFORMAT_IEEEFP:
+ if (tif->tif_dir.td_bitspersample<=32)
+ {
+ for (i = 0; i < count; ++i)
+ ((float*)conv)[i] = TIFFClampDoubleToFloat(value[i]);
+ ok = TIFFWriteDirectoryTagFloatArray(tif,ndir,dir,tag,count,(float*)conv);
+ }
+ else
+ {
+ ok = TIFFWriteDirectoryTagDoubleArray(tif,ndir,dir,tag,count,value);
+ }
+ break;
+ case SAMPLEFORMAT_INT:
+ if (tif->tif_dir.td_bitspersample<=8)
+ {
+ for (i = 0; i < count; ++i)
+ ((int8*)conv)[i] = TIFFClampDoubleToInt8(value[i]);
+ ok = TIFFWriteDirectoryTagSbyteArray(tif,ndir,dir,tag,count,(int8*)conv);
+ }
+ else if (tif->tif_dir.td_bitspersample<=16)
+ {
+ for (i = 0; i < count; ++i)
+ ((int16*)conv)[i] = TIFFClampDoubleToInt16(value[i]);
+ ok = TIFFWriteDirectoryTagSshortArray(tif,ndir,dir,tag,count,(int16*)conv);
+ }
+ else
+ {
+ for (i = 0; i < count; ++i)
+ ((int32*)conv)[i] = TIFFClampDoubleToInt32(value[i]);
+ ok = TIFFWriteDirectoryTagSlongArray(tif,ndir,dir,tag,count,(int32*)conv);
+ }
+ break;
+ case SAMPLEFORMAT_UINT:
+ if (tif->tif_dir.td_bitspersample<=8)
+ {
+ for (i = 0; i < count; ++i)
+ ((uint8*)conv)[i] = TIFFClampDoubleToUInt8(value[i]);
+ ok = TIFFWriteDirectoryTagByteArray(tif,ndir,dir,tag,count,(uint8*)conv);
+ }
+ else if (tif->tif_dir.td_bitspersample<=16)
+ {
+ for (i = 0; i < count; ++i)
+ ((uint16*)conv)[i] = TIFFClampDoubleToUInt16(value[i]);
+ ok = TIFFWriteDirectoryTagShortArray(tif,ndir,dir,tag,count,(uint16*)conv);
+ }
+ else
+ {
+ for (i = 0; i < count; ++i)
+ ((uint32*)conv)[i] = TIFFClampDoubleToUInt32(value[i]);
+ ok = TIFFWriteDirectoryTagLongArray(tif,ndir,dir,tag,count,(uint32*)conv);
+ }
+ break;
+ default:
+ ok = 0;
+ }
+
+ _TIFFfree(conv);
+ return (ok);
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagSampleformatPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ switch (tif->tif_dir.td_sampleformat)
+ {
+ case SAMPLEFORMAT_IEEEFP:
+ if (tif->tif_dir.td_bitspersample<=32)
+ return(TIFFWriteDirectoryTagFloatPerSample(tif,ndir,dir,tag,(float)value));
+ else
+ return(TIFFWriteDirectoryTagDoublePerSample(tif,ndir,dir,tag,value));
+ case SAMPLEFORMAT_INT:
+ if (tif->tif_dir.td_bitspersample<=8)
+ return(TIFFWriteDirectoryTagSbytePerSample(tif,ndir,dir,tag,(int8)value));
+ else if (tif->tif_dir.td_bitspersample<=16)
+ return(TIFFWriteDirectoryTagSshortPerSample(tif,ndir,dir,tag,(int16)value));
+ else
+ return(TIFFWriteDirectoryTagSlongPerSample(tif,ndir,dir,tag,(int32)value));
+ case SAMPLEFORMAT_UINT:
+ if (tif->tif_dir.td_bitspersample<=8)
+ return(TIFFWriteDirectoryTagBytePerSample(tif,ndir,dir,tag,(uint8)value));
+ else if (tif->tif_dir.td_bitspersample<=16)
+ return(TIFFWriteDirectoryTagShortPerSample(tif,ndir,dir,tag,(uint16)value));
+ else
+ return(TIFFWriteDirectoryTagLongPerSample(tif,ndir,dir,tag,(uint32)value));
+ default:
+ return(1);
+ }
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagAscii(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, char* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedAscii(tif,ndir,dir,tag,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagUndefinedArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedUndefinedArray(tif,ndir,dir,tag,count,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagByte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedByte(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagByteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedByteArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagBytePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagBytePerSample";
+ uint8* m;
+ uint8* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(uint8));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedByteArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagSbyte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSbyte(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagSbyteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int8* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSbyteArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagSbytePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagSbytePerSample";
+ int8* m;
+ int8* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(int8));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedSbyteArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagShort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedShort(tif,ndir,dir,tag,value));
+}
+
+static int
+TIFFWriteDirectoryTagShortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint16* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedShortArray(tif,ndir,dir,tag,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagShortPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagShortPerSample";
+ uint16* m;
+ uint16* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(uint16));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedShortArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagSshort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSshort(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagSshortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int16* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSshortArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagSshortPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagSshortPerSample";
+ int16* m;
+ int16* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(int16));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedSshortArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedLong(tif,ndir,dir,tag,value));
+}
+
+static int
+TIFFWriteDirectoryTagLongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedLongArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagLongPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagLongPerSample";
+ uint32* m;
+ uint32* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(uint32));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedLongArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagSlong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSlong(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagSlongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int32* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSlongArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int
+TIFFWriteDirectoryTagSlongPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagSlongPerSample";
+ int32* m;
+ int32* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(int32));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedSlongArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagLong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint64 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedLong8(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedLong8Array(tif,ndir,dir,tag,count,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagSlong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int64 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSlong8(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagSlong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int64* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSlong8Array(tif,ndir,dir,tag,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagRational(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedRational(tif,ndir,dir,tag,value));
+}
+
+static int
+TIFFWriteDirectoryTagRationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedRationalArray(tif,ndir,dir,tag,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagSrationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedSrationalArray(tif,ndir,dir,tag,count,value));
+}
+
+#ifdef notdef
+static int TIFFWriteDirectoryTagFloat(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedFloat(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int TIFFWriteDirectoryTagFloatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedFloatArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int TIFFWriteDirectoryTagFloatPerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagFloatPerSample";
+ float* m;
+ float* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(float));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedFloatArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+#ifdef notdef
+static int TIFFWriteDirectoryTagDouble(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedDouble(tif,ndir,dir,tag,value));
+}
+#endif
+
+static int TIFFWriteDirectoryTagDoubleArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedDoubleArray(tif,ndir,dir,tag,count,value));
+}
+
+#if 0
+static int TIFFWriteDirectoryTagDoublePerSample(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagDoublePerSample";
+ double* m;
+ double* na;
+ uint16 nb;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=_TIFFmalloc(tif->tif_dir.td_samplesperpixel*sizeof(double));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=m, nb=0; nb<tif->tif_dir.td_samplesperpixel; na++, nb++)
+ *na=value;
+ o=TIFFWriteDirectoryTagCheckedDoubleArray(tif,ndir,dir,tag,tif->tif_dir.td_samplesperpixel,m);
+ _TIFFfree(m);
+ return(o);
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagIfdArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedIfdArray(tif,ndir,dir,tag,count,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ return(TIFFWriteDirectoryTagCheckedIfd8Array(tif,ndir,dir,tag,count,value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagShortLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value)
+{
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ if (value<=0xFFFF)
+ return(TIFFWriteDirectoryTagCheckedShort(tif,ndir,dir,tag,(uint16)value));
+ else
+ return(TIFFWriteDirectoryTagCheckedLong(tif,ndir,dir,tag,value));
+}
+
+/************************************************************************/
+/* TIFFWriteDirectoryTagLongLong8Array() */
+/* */
+/* Write out LONG8 array as LONG8 for BigTIFF or LONG for */
+/* Classic TIFF with some checking. */
+/************************************************************************/
+
+static int
+TIFFWriteDirectoryTagLongLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagLongLong8Array";
+ uint64* ma;
+ uint32 mb;
+ uint32* p;
+ uint32* q;
+ int o;
+
+ /* is this just a counting pass? */
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+
+ /* We always write LONG8 for BigTIFF, no checking needed. */
+ if( tif->tif_flags&TIFF_BIGTIFF )
+ return TIFFWriteDirectoryTagCheckedLong8Array(tif,ndir,dir,
+ tag,count,value);
+
+ /*
+ ** For classic tiff we want to verify everything is in range for LONG
+ ** and convert to long format.
+ */
+
+ p = _TIFFmalloc(count*sizeof(uint32));
+ if (p==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+
+ for (q=p, ma=value, mb=0; mb<count; ma++, mb++, q++)
+ {
+ if (*ma>0xFFFFFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Attempt to write value larger than 0xFFFFFFFF in Classic TIFF file.");
+ _TIFFfree(p);
+ return(0);
+ }
+ *q= (uint32)(*ma);
+ }
+
+ o=TIFFWriteDirectoryTagCheckedLongArray(tif,ndir,dir,tag,count,p);
+ _TIFFfree(p);
+
+ return(o);
+}
+
+/************************************************************************/
+/* TIFFWriteDirectoryTagIfdIfd8Array() */
+/* */
+/* Write either IFD8 or IFD array depending on file type. */
+/************************************************************************/
+
+static int
+TIFFWriteDirectoryTagIfdIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagIfdIfd8Array";
+ uint64* ma;
+ uint32 mb;
+ uint32* p;
+ uint32* q;
+ int o;
+
+ /* is this just a counting pass? */
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+
+ /* We always write IFD8 for BigTIFF, no checking needed. */
+ if( tif->tif_flags&TIFF_BIGTIFF )
+ return TIFFWriteDirectoryTagCheckedIfd8Array(tif,ndir,dir,
+ tag,count,value);
+
+ /*
+ ** For classic tiff we want to verify everything is in range for IFD
+ ** and convert to long format.
+ */
+
+ p = _TIFFmalloc(count*sizeof(uint32));
+ if (p==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+
+ for (q=p, ma=value, mb=0; mb<count; ma++, mb++, q++)
+ {
+ if (*ma>0xFFFFFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Attempt to write value larger than 0xFFFFFFFF in Classic TIFF file.");
+ _TIFFfree(p);
+ return(0);
+ }
+ *q= (uint32)(*ma);
+ }
+
+ o=TIFFWriteDirectoryTagCheckedIfdArray(tif,ndir,dir,tag,count,p);
+ _TIFFfree(p);
+
+ return(o);
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagShortLongLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagShortLongLong8Array";
+ uint64* ma;
+ uint32 mb;
+ uint8 n;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ n=0;
+ for (ma=value, mb=0; mb<count; ma++, mb++)
+ {
+ if ((n==0)&&(*ma>0xFFFF))
+ n=1;
+ if ((n==1)&&(*ma>0xFFFFFFFF))
+ {
+ n=2;
+ break;
+ }
+ }
+ if (n==0)
+ {
+ uint16* p;
+ uint16* q;
+ p=_TIFFmalloc(count*sizeof(uint16));
+ if (p==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (ma=value, mb=0, q=p; mb<count; ma++, mb++, q++)
+ *q=(uint16)(*ma);
+ o=TIFFWriteDirectoryTagCheckedShortArray(tif,ndir,dir,tag,count,p);
+ _TIFFfree(p);
+ }
+ else if (n==1)
+ {
+ uint32* p;
+ uint32* q;
+ p=_TIFFmalloc(count*sizeof(uint32));
+ if (p==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (ma=value, mb=0, q=p; mb<count; ma++, mb++, q++)
+ *q=(uint32)(*ma);
+ o=TIFFWriteDirectoryTagCheckedLongArray(tif,ndir,dir,tag,count,p);
+ _TIFFfree(p);
+ }
+ else
+ {
+ assert(n==2);
+ o=TIFFWriteDirectoryTagCheckedLong8Array(tif,ndir,dir,tag,count,value);
+ }
+ return(o);
+}
+#endif
+static int
+TIFFWriteDirectoryTagColormap(TIFF* tif, uint32* ndir, TIFFDirEntry* dir)
+{
+ static const char module[] = "TIFFWriteDirectoryTagColormap";
+ uint32 m;
+ uint16* n;
+ int o;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=(1<<tif->tif_dir.td_bitspersample);
+ n=_TIFFmalloc(3*m*sizeof(uint16));
+ if (n==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ _TIFFmemcpy(&n[0],tif->tif_dir.td_colormap[0],m*sizeof(uint16));
+ _TIFFmemcpy(&n[m],tif->tif_dir.td_colormap[1],m*sizeof(uint16));
+ _TIFFmemcpy(&n[2*m],tif->tif_dir.td_colormap[2],m*sizeof(uint16));
+ o=TIFFWriteDirectoryTagCheckedShortArray(tif,ndir,dir,TIFFTAG_COLORMAP,3*m,n);
+ _TIFFfree(n);
+ return(o);
+}
+
+static int
+TIFFWriteDirectoryTagTransferfunction(TIFF* tif, uint32* ndir, TIFFDirEntry* dir)
+{
+ static const char module[] = "TIFFWriteDirectoryTagTransferfunction";
+ uint32 m;
+ uint16 n;
+ uint16* o;
+ int p;
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=(1<<tif->tif_dir.td_bitspersample);
+ n=tif->tif_dir.td_samplesperpixel-tif->tif_dir.td_extrasamples;
+ /*
+ * Check if the table can be written as a single column,
+ * or if it must be written as 3 columns. Note that we
+ * write a 3-column tag if there are 2 samples/pixel and
+ * a single column of data won't suffice--hmm.
+ */
+ if (n>3)
+ n=3;
+ if (n==3)
+ {
+ if (!_TIFFmemcmp(tif->tif_dir.td_transferfunction[0],tif->tif_dir.td_transferfunction[2],m*sizeof(uint16)))
+ n=2;
+ }
+ if (n==2)
+ {
+ if (!_TIFFmemcmp(tif->tif_dir.td_transferfunction[0],tif->tif_dir.td_transferfunction[1],m*sizeof(uint16)))
+ n=1;
+ }
+ if (n==0)
+ n=1;
+ o=_TIFFmalloc(n*m*sizeof(uint16));
+ if (o==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ _TIFFmemcpy(&o[0],tif->tif_dir.td_transferfunction[0],m*sizeof(uint16));
+ if (n>1)
+ _TIFFmemcpy(&o[m],tif->tif_dir.td_transferfunction[1],m*sizeof(uint16));
+ if (n>2)
+ _TIFFmemcpy(&o[2*m],tif->tif_dir.td_transferfunction[2],m*sizeof(uint16));
+ p=TIFFWriteDirectoryTagCheckedShortArray(tif,ndir,dir,TIFFTAG_TRANSFERFUNCTION,n*m,o);
+ _TIFFfree(o);
+ return(p);
+}
+
+static int
+TIFFWriteDirectoryTagSubifd(TIFF* tif, uint32* ndir, TIFFDirEntry* dir)
+{
+ static const char module[] = "TIFFWriteDirectoryTagSubifd";
+ uint64 m;
+ int n;
+ if (tif->tif_dir.td_nsubifd==0)
+ return(1);
+ if (dir==NULL)
+ {
+ (*ndir)++;
+ return(1);
+ }
+ m=tif->tif_dataoff;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32* o;
+ uint64* pa;
+ uint32* pb;
+ uint16 p;
+ o=_TIFFmalloc(tif->tif_dir.td_nsubifd*sizeof(uint32));
+ if (o==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ pa=tif->tif_dir.td_subifd;
+ pb=o;
+ for (p=0; p < tif->tif_dir.td_nsubifd; p++)
+ {
+ assert(pa != 0);
+
+ /* Could happen if an classicTIFF has a SubIFD of type LONG8 (which is illegal) */
+ if( *pa > 0xFFFFFFFFUL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Illegal value for SubIFD tag");
+ _TIFFfree(o);
+ return(0);
+ }
+ *pb++=(uint32)(*pa++);
+ }
+ n=TIFFWriteDirectoryTagCheckedIfdArray(tif,ndir,dir,TIFFTAG_SUBIFD,tif->tif_dir.td_nsubifd,o);
+ _TIFFfree(o);
+ }
+ else
+ n=TIFFWriteDirectoryTagCheckedIfd8Array(tif,ndir,dir,TIFFTAG_SUBIFD,tif->tif_dir.td_nsubifd,tif->tif_dir.td_subifd);
+ if (!n)
+ return(0);
+ /*
+ * Total hack: if this directory includes a SubIFD
+ * tag then force the next <n> directories to be
+ * written as ``sub directories'' of this one. This
+ * is used to write things like thumbnails and
+ * image masks that one wants to keep out of the
+ * normal directory linkage access mechanism.
+ */
+ tif->tif_flags|=TIFF_INSUBIFD;
+ tif->tif_nsubifd=tif->tif_dir.td_nsubifd;
+ if (tif->tif_dir.td_nsubifd==1)
+ tif->tif_subifdoff=0;
+ else
+ tif->tif_subifdoff=m;
+ return(1);
+}
+
+static int
+TIFFWriteDirectoryTagCheckedAscii(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, char* value)
+{
+ assert(sizeof(char)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_ASCII,count,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedUndefinedArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value)
+{
+ assert(sizeof(uint8)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_UNDEFINED,count,count,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedByte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint8 value)
+{
+ assert(sizeof(uint8)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_BYTE,1,1,&value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedByteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint8* value)
+{
+ assert(sizeof(uint8)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_BYTE,count,count,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedSbyte(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int8 value)
+{
+ assert(sizeof(int8)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SBYTE,1,1,&value));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedSbyteArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int8* value)
+{
+ assert(sizeof(int8)==1);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SBYTE,count,count,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedShort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 value)
+{
+ uint16 m;
+ assert(sizeof(uint16)==2);
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort(&m);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SHORT,1,2,&m));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedShortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint16* value)
+{
+ assert(count<0x80000000);
+ assert(sizeof(uint16)==2);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfShort(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SHORT,count,count*2,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedSshort(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int16 value)
+{
+ int16 m;
+ assert(sizeof(int16)==2);
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort((uint16*)(&m));
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SSHORT,1,2,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedSshortArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int16* value)
+{
+ assert(count<0x80000000);
+ assert(sizeof(int16)==2);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfShort((uint16*)value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SSHORT,count,count*2,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedLong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 value)
+{
+ uint32 m;
+ assert(sizeof(uint32)==4);
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&m);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_LONG,1,4,&m));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedLongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value)
+{
+ assert(count<0x40000000);
+ assert(sizeof(uint32)==4);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_LONG,count,count*4,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedSlong(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int32 value)
+{
+ int32 m;
+ assert(sizeof(int32)==4);
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong((uint32*)(&m));
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SLONG,1,4,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedSlongArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int32* value)
+{
+ assert(count<0x40000000);
+ assert(sizeof(int32)==4);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong((uint32*)value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SLONG,count,count*4,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedLong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint64 value)
+{
+ uint64 m;
+ assert(sizeof(uint64)==8);
+ if( !(tif->tif_flags&TIFF_BIGTIFF) ) {
+ TIFFErrorExt(tif->tif_clientdata,"TIFFWriteDirectoryTagCheckedLong8","LONG8 not allowed for ClassicTIFF");
+ return(0);
+ }
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(&m);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_LONG8,1,8,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedLong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ assert(count<0x20000000);
+ assert(sizeof(uint64)==8);
+ if( !(tif->tif_flags&TIFF_BIGTIFF) ) {
+ TIFFErrorExt(tif->tif_clientdata,"TIFFWriteDirectoryTagCheckedLong8Array","LONG8 not allowed for ClassicTIFF");
+ return(0);
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_LONG8,count,count*8,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedSlong8(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, int64 value)
+{
+ int64 m;
+ assert(sizeof(int64)==8);
+ if( !(tif->tif_flags&TIFF_BIGTIFF) ) {
+ TIFFErrorExt(tif->tif_clientdata,"TIFFWriteDirectoryTagCheckedSlong8","SLONG8 not allowed for ClassicTIFF");
+ return(0);
+ }
+ m=value;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8((uint64*)(&m));
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SLONG8,1,8,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedSlong8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, int64* value)
+{
+ assert(count<0x20000000);
+ assert(sizeof(int64)==8);
+ if( !(tif->tif_flags&TIFF_BIGTIFF) ) {
+ TIFFErrorExt(tif->tif_clientdata,"TIFFWriteDirectoryTagCheckedSlong8Array","SLONG8 not allowed for ClassicTIFF");
+ return(0);
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8((uint64*)value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SLONG8,count,count*8,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedRational(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagCheckedRational";
+ uint32 m[2];
+ assert(sizeof(uint32)==4);
+ if( value < 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Negative value is illegal");
+ return 0;
+ }
+ else if( value != value )
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Not-a-number value is illegal");
+ return 0;
+ }
+ else if (value==0.0)
+ {
+ m[0]=0;
+ m[1]=1;
+ }
+ else if (value <= 0xFFFFFFFFU && value==(double)(uint32)value)
+ {
+ m[0]=(uint32)value;
+ m[1]=1;
+ }
+ else if (value<1.0)
+ {
+ m[0]=(uint32)(value*0xFFFFFFFF);
+ m[1]=0xFFFFFFFF;
+ }
+ else
+ {
+ m[0]=0xFFFFFFFF;
+ m[1]=(uint32)(0xFFFFFFFF/value);
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ {
+ TIFFSwabLong(&m[0]);
+ TIFFSwabLong(&m[1]);
+ }
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_RATIONAL,1,8,&m[0]));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedRationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagCheckedRationalArray";
+ uint32* m;
+ float* na;
+ uint32* nb;
+ uint32 nc;
+ int o;
+ assert(sizeof(uint32)==4);
+ m=_TIFFmalloc(count*2*sizeof(uint32));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=value, nb=m, nc=0; nc<count; na++, nb+=2, nc++)
+ {
+ if (*na<=0.0 || *na != *na)
+ {
+ nb[0]=0;
+ nb[1]=1;
+ }
+ else if (*na >= 0 && *na <= (float)0xFFFFFFFFU &&
+ *na==(float)(uint32)(*na))
+ {
+ nb[0]=(uint32)(*na);
+ nb[1]=1;
+ }
+ else if (*na<1.0)
+ {
+ nb[0]=(uint32)((double)(*na)*0xFFFFFFFF);
+ nb[1]=0xFFFFFFFF;
+ }
+ else
+ {
+ nb[0]=0xFFFFFFFF;
+ nb[1]=(uint32)((double)0xFFFFFFFF/(*na));
+ }
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(m,count*2);
+ o=TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_RATIONAL,count,count*8,&m[0]);
+ _TIFFfree(m);
+ return(o);
+}
+
+static int
+TIFFWriteDirectoryTagCheckedSrationalArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ static const char module[] = "TIFFWriteDirectoryTagCheckedSrationalArray";
+ int32* m;
+ float* na;
+ int32* nb;
+ uint32 nc;
+ int o;
+ assert(sizeof(int32)==4);
+ m=_TIFFmalloc(count*2*sizeof(int32));
+ if (m==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ for (na=value, nb=m, nc=0; nc<count; na++, nb+=2, nc++)
+ {
+ if (*na<0.0)
+ {
+ if (*na==(int32)(*na))
+ {
+ nb[0]=(int32)(*na);
+ nb[1]=1;
+ }
+ else if (*na>-1.0)
+ {
+ nb[0]=-(int32)((double)(-*na)*0x7FFFFFFF);
+ nb[1]=0x7FFFFFFF;
+ }
+ else
+ {
+ nb[0]=-0x7FFFFFFF;
+ nb[1]=(int32)((double)0x7FFFFFFF/(-*na));
+ }
+ }
+ else
+ {
+ if (*na==(int32)(*na))
+ {
+ nb[0]=(int32)(*na);
+ nb[1]=1;
+ }
+ else if (*na<1.0)
+ {
+ nb[0]=(int32)((double)(*na)*0x7FFFFFFF);
+ nb[1]=0x7FFFFFFF;
+ }
+ else
+ {
+ nb[0]=0x7FFFFFFF;
+ nb[1]=(int32)((double)0x7FFFFFFF/(*na));
+ }
+ }
+ }
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong((uint32*)m,count*2);
+ o=TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_SRATIONAL,count,count*8,&m[0]);
+ _TIFFfree(m);
+ return(o);
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedFloat(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, float value)
+{
+ float m;
+ assert(sizeof(float)==4);
+ m=value;
+ TIFFCvtNativeToIEEEFloat(tif,1,&m);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabFloat(&m);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_FLOAT,1,4,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedFloatArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, float* value)
+{
+ assert(count<0x40000000);
+ assert(sizeof(float)==4);
+ TIFFCvtNativeToIEEEFloat(tif,count,&value);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfFloat(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_FLOAT,count,count*4,value));
+}
+
+#ifdef notdef
+static int
+TIFFWriteDirectoryTagCheckedDouble(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, double value)
+{
+ double m;
+ assert(sizeof(double)==8);
+ m=value;
+ TIFFCvtNativeToIEEEDouble(tif,1,&m);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabDouble(&m);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_DOUBLE,1,8,&m));
+}
+#endif
+
+static int
+TIFFWriteDirectoryTagCheckedDoubleArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, double* value)
+{
+ assert(count<0x20000000);
+ assert(sizeof(double)==8);
+ TIFFCvtNativeToIEEEDouble(tif,count,&value);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfDouble(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_DOUBLE,count,count*8,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedIfdArray(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint32* value)
+{
+ assert(count<0x40000000);
+ assert(sizeof(uint32)==4);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_IFD,count,count*4,value));
+}
+
+static int
+TIFFWriteDirectoryTagCheckedIfd8Array(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint32 count, uint64* value)
+{
+ assert(count<0x20000000);
+ assert(sizeof(uint64)==8);
+ assert(tif->tif_flags&TIFF_BIGTIFF);
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabArrayOfLong8(value,count);
+ return(TIFFWriteDirectoryTagData(tif,ndir,dir,tag,TIFF_IFD8,count,count*8,value));
+}
+
+static int
+TIFFWriteDirectoryTagData(TIFF* tif, uint32* ndir, TIFFDirEntry* dir, uint16 tag, uint16 datatype, uint32 count, uint32 datalength, void* data)
+{
+ static const char module[] = "TIFFWriteDirectoryTagData";
+ uint32 m;
+ m=0;
+ while (m<(*ndir))
+ {
+ assert(dir[m].tdir_tag!=tag);
+ if (dir[m].tdir_tag>tag)
+ break;
+ m++;
+ }
+ if (m<(*ndir))
+ {
+ uint32 n;
+ for (n=*ndir; n>m; n--)
+ dir[n]=dir[n-1];
+ }
+ dir[m].tdir_tag=tag;
+ dir[m].tdir_type=datatype;
+ dir[m].tdir_count=count;
+ dir[m].tdir_offset.toff_long8 = 0;
+ if (datalength<=((tif->tif_flags&TIFF_BIGTIFF)?0x8U:0x4U))
+ _TIFFmemcpy(&dir[m].tdir_offset,data,datalength);
+ else
+ {
+ uint64 na,nb;
+ na=tif->tif_dataoff;
+ nb=na+datalength;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ nb=(uint32)nb;
+ if ((nb<na)||(nb<datalength))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Maximum TIFF file size exceeded");
+ return(0);
+ }
+ if (!SeekOK(tif,na))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"IO error writing tag data");
+ return(0);
+ }
+ assert(datalength<0x80000000UL);
+ if (!WriteOK(tif,data,(tmsize_t)datalength))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"IO error writing tag data");
+ return(0);
+ }
+ tif->tif_dataoff=nb;
+ if (tif->tif_dataoff&1)
+ tif->tif_dataoff++;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 o;
+ o=(uint32)na;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong(&o);
+ _TIFFmemcpy(&dir[m].tdir_offset,&o,4);
+ }
+ else
+ {
+ dir[m].tdir_offset.toff_long8 = na;
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8(&dir[m].tdir_offset.toff_long8);
+ }
+ }
+ (*ndir)++;
+ return(1);
+}
+
+/*
+ * Link the current directory into the directory chain for the file.
+ */
+static int
+TIFFLinkDirectory(TIFF* tif)
+{
+ static const char module[] = "TIFFLinkDirectory";
+
+ tif->tif_diroff = (TIFFSeekFile(tif,0,SEEK_END)+1) & (~((toff_t)1));
+
+ /*
+ * Handle SubIFDs
+ */
+ if (tif->tif_flags & TIFF_INSUBIFD)
+ {
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 m;
+ m = (uint32)tif->tif_diroff;
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&m);
+ (void) TIFFSeekFile(tif, tif->tif_subifdoff, SEEK_SET);
+ if (!WriteOK(tif, &m, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing SubIFD directory link");
+ return (0);
+ }
+ /*
+ * Advance to the next SubIFD or, if this is
+ * the last one configured, revert back to the
+ * normal directory linkage.
+ */
+ if (--tif->tif_nsubifd)
+ tif->tif_subifdoff += 4;
+ else
+ tif->tif_flags &= ~TIFF_INSUBIFD;
+ return (1);
+ }
+ else
+ {
+ uint64 m;
+ m = tif->tif_diroff;
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&m);
+ (void) TIFFSeekFile(tif, tif->tif_subifdoff, SEEK_SET);
+ if (!WriteOK(tif, &m, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing SubIFD directory link");
+ return (0);
+ }
+ /*
+ * Advance to the next SubIFD or, if this is
+ * the last one configured, revert back to the
+ * normal directory linkage.
+ */
+ if (--tif->tif_nsubifd)
+ tif->tif_subifdoff += 8;
+ else
+ tif->tif_flags &= ~TIFF_INSUBIFD;
+ return (1);
+ }
+ }
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 m;
+ uint32 nextdir;
+ m = (uint32)(tif->tif_diroff);
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&m);
+ if (tif->tif_header.classic.tiff_diroff == 0) {
+ /*
+ * First directory, overwrite offset in header.
+ */
+ tif->tif_header.classic.tiff_diroff = (uint32) tif->tif_diroff;
+ (void) TIFFSeekFile(tif,4, SEEK_SET);
+ if (!WriteOK(tif, &m, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Error writing TIFF header");
+ return (0);
+ }
+ return (1);
+ }
+ /*
+ * Not the first directory, search to the last and append.
+ */
+ nextdir = tif->tif_header.classic.tiff_diroff;
+ while(1) {
+ uint16 dircount;
+ uint32 nextnextdir;
+
+ if (!SeekOK(tif, nextdir) ||
+ !ReadOK(tif, &dircount, 2)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory count");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount);
+ (void) TIFFSeekFile(tif,
+ nextdir+2+dircount*12, SEEK_SET);
+ if (!ReadOK(tif, &nextnextdir, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory link");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&nextnextdir);
+ if (nextnextdir==0)
+ {
+ (void) TIFFSeekFile(tif,
+ nextdir+2+dircount*12, SEEK_SET);
+ if (!WriteOK(tif, &m, 4)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+ break;
+ }
+ nextdir=nextnextdir;
+ }
+ }
+ else
+ {
+ uint64 m;
+ uint64 nextdir;
+ m = tif->tif_diroff;
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&m);
+ if (tif->tif_header.big.tiff_diroff == 0) {
+ /*
+ * First directory, overwrite offset in header.
+ */
+ tif->tif_header.big.tiff_diroff = tif->tif_diroff;
+ (void) TIFFSeekFile(tif,8, SEEK_SET);
+ if (!WriteOK(tif, &m, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Error writing TIFF header");
+ return (0);
+ }
+ return (1);
+ }
+ /*
+ * Not the first directory, search to the last and append.
+ */
+ nextdir = tif->tif_header.big.tiff_diroff;
+ while(1) {
+ uint64 dircount64;
+ uint16 dircount;
+ uint64 nextnextdir;
+
+ if (!SeekOK(tif, nextdir) ||
+ !ReadOK(tif, &dircount64, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory count");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ if (dircount64>0xFFFF)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sanity check on tag count failed, likely corrupt TIFF");
+ return (0);
+ }
+ dircount=(uint16)dircount64;
+ (void) TIFFSeekFile(tif,
+ nextdir+8+dircount*20, SEEK_SET);
+ if (!ReadOK(tif, &nextnextdir, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error fetching directory link");
+ return (0);
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&nextnextdir);
+ if (nextnextdir==0)
+ {
+ (void) TIFFSeekFile(tif,
+ nextdir+8+dircount*20, SEEK_SET);
+ if (!WriteOK(tif, &m, 8)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+ break;
+ }
+ nextdir=nextnextdir;
+ }
+ }
+ return (1);
+}
+
+/************************************************************************/
+/* TIFFRewriteField() */
+/* */
+/* Rewrite a field in the directory on disk without regard to */
+/* updating the TIFF directory structure in memory. Currently */
+/* only supported for field that already exist in the on-disk */
+/* directory. Mainly used for updating stripoffset / */
+/* stripbytecount values after the directory is already on */
+/* disk. */
+/* */
+/* Returns zero on failure, and one on success. */
+/************************************************************************/
+
+int
+_TIFFRewriteField(TIFF* tif, uint16 tag, TIFFDataType in_datatype,
+ tmsize_t count, void* data)
+{
+ static const char module[] = "TIFFResetField";
+ /* const TIFFField* fip = NULL; */
+ uint16 dircount;
+ tmsize_t dirsize;
+ uint8 direntry_raw[20];
+ uint16 entry_tag = 0;
+ uint16 entry_type = 0;
+ uint64 entry_count = 0;
+ uint64 entry_offset = 0;
+ int value_in_entry = 0;
+ uint64 read_offset;
+ uint8 *buf_to_write = NULL;
+ TIFFDataType datatype;
+
+/* -------------------------------------------------------------------- */
+/* Find field definition. */
+/* -------------------------------------------------------------------- */
+ /*fip =*/ TIFFFindField(tif, tag, TIFF_ANY);
+
+/* -------------------------------------------------------------------- */
+/* Do some checking this is a straight forward case. */
+/* -------------------------------------------------------------------- */
+ if( isMapped(tif) )
+ {
+ TIFFErrorExt( tif->tif_clientdata, module,
+ "Memory mapped files not currently supported for this operation." );
+ return 0;
+ }
+
+ if( tif->tif_diroff == 0 )
+ {
+ TIFFErrorExt( tif->tif_clientdata, module,
+ "Attempt to reset field on directory not already on disk." );
+ return 0;
+ }
+
+/* -------------------------------------------------------------------- */
+/* Read the directory entry count. */
+/* -------------------------------------------------------------------- */
+ if (!SeekOK(tif, tif->tif_diroff)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Seek error accessing TIFF directory",
+ tif->tif_name);
+ return 0;
+ }
+
+ read_offset = tif->tif_diroff;
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if (!ReadOK(tif, &dircount, sizeof (uint16))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not read TIFF directory count",
+ tif->tif_name);
+ return 0;
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&dircount);
+ dirsize = 12;
+ read_offset += 2;
+ } else {
+ uint64 dircount64;
+ if (!ReadOK(tif, &dircount64, sizeof (uint64))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not read TIFF directory count",
+ tif->tif_name);
+ return 0;
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong8(&dircount64);
+ dircount = (uint16)dircount64;
+ dirsize = 20;
+ read_offset += 8;
+ }
+
+/* -------------------------------------------------------------------- */
+/* Read through directory to find target tag. */
+/* -------------------------------------------------------------------- */
+ while( dircount > 0 )
+ {
+ if (!ReadOK(tif, direntry_raw, dirsize)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not read TIFF directory entry.",
+ tif->tif_name);
+ return 0;
+ }
+
+ memcpy( &entry_tag, direntry_raw + 0, sizeof(uint16) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort( &entry_tag );
+
+ if( entry_tag == tag )
+ break;
+
+ read_offset += dirsize;
+ }
+
+ if( entry_tag != tag )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Could not find tag %d.",
+ tif->tif_name, tag );
+ return 0;
+ }
+
+/* -------------------------------------------------------------------- */
+/* Extract the type, count and offset for this entry. */
+/* -------------------------------------------------------------------- */
+ memcpy( &entry_type, direntry_raw + 2, sizeof(uint16) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort( &entry_type );
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 value;
+
+ memcpy( &value, direntry_raw + 4, sizeof(uint32) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong( &value );
+ entry_count = value;
+
+ memcpy( &value, direntry_raw + 8, sizeof(uint32) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong( &value );
+ entry_offset = value;
+ }
+ else
+ {
+ memcpy( &entry_count, direntry_raw + 4, sizeof(uint64) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8( &entry_count );
+
+ memcpy( &entry_offset, direntry_raw + 12, sizeof(uint64) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8( &entry_offset );
+ }
+
+/* -------------------------------------------------------------------- */
+/* What data type do we want to write this as? */
+/* -------------------------------------------------------------------- */
+ if( TIFFDataWidth(in_datatype) == 8 && !(tif->tif_flags&TIFF_BIGTIFF) )
+ {
+ if( in_datatype == TIFF_LONG8 )
+ datatype = TIFF_LONG;
+ else if( in_datatype == TIFF_SLONG8 )
+ datatype = TIFF_SLONG;
+ else if( in_datatype == TIFF_IFD8 )
+ datatype = TIFF_IFD;
+ else
+ datatype = in_datatype;
+ }
+ else
+ datatype = in_datatype;
+
+/* -------------------------------------------------------------------- */
+/* Prepare buffer of actual data to write. This includes */
+/* swabbing as needed. */
+/* -------------------------------------------------------------------- */
+ buf_to_write =
+ (uint8 *)_TIFFCheckMalloc(tif, count, TIFFDataWidth(datatype),
+ "for field buffer.");
+ if (!buf_to_write)
+ return 0;
+
+ if( datatype == in_datatype )
+ memcpy( buf_to_write, data, count * TIFFDataWidth(datatype) );
+ else if( datatype == TIFF_SLONG && in_datatype == TIFF_SLONG8 )
+ {
+ tmsize_t i;
+
+ for( i = 0; i < count; i++ )
+ {
+ ((int32 *) buf_to_write)[i] =
+ (int32) ((int64 *) data)[i];
+ if( (int64) ((int32 *) buf_to_write)[i] != ((int64 *) data)[i] )
+ {
+ _TIFFfree( buf_to_write );
+ TIFFErrorExt( tif->tif_clientdata, module,
+ "Value exceeds 32bit range of output type." );
+ return 0;
+ }
+ }
+ }
+ else if( (datatype == TIFF_LONG && in_datatype == TIFF_LONG8)
+ || (datatype == TIFF_IFD && in_datatype == TIFF_IFD8) )
+ {
+ tmsize_t i;
+
+ for( i = 0; i < count; i++ )
+ {
+ ((uint32 *) buf_to_write)[i] =
+ (uint32) ((uint64 *) data)[i];
+ if( (uint64) ((uint32 *) buf_to_write)[i] != ((uint64 *) data)[i] )
+ {
+ _TIFFfree( buf_to_write );
+ TIFFErrorExt( tif->tif_clientdata, module,
+ "Value exceeds 32bit range of output type." );
+ return 0;
+ }
+ }
+ }
+
+ if( TIFFDataWidth(datatype) > 1 && (tif->tif_flags&TIFF_SWAB) )
+ {
+ if( TIFFDataWidth(datatype) == 2 )
+ TIFFSwabArrayOfShort( (uint16 *) buf_to_write, count );
+ else if( TIFFDataWidth(datatype) == 4 )
+ TIFFSwabArrayOfLong( (uint32 *) buf_to_write, count );
+ else if( TIFFDataWidth(datatype) == 8 )
+ TIFFSwabArrayOfLong8( (uint64 *) buf_to_write, count );
+ }
+
+/* -------------------------------------------------------------------- */
+/* Is this a value that fits into the directory entry? */
+/* -------------------------------------------------------------------- */
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ if( TIFFDataWidth(datatype) * count <= 4 )
+ {
+ entry_offset = read_offset + 8;
+ value_in_entry = 1;
+ }
+ }
+ else
+ {
+ if( TIFFDataWidth(datatype) * count <= 8 )
+ {
+ entry_offset = read_offset + 12;
+ value_in_entry = 1;
+ }
+ }
+
+/* -------------------------------------------------------------------- */
+/* If the tag type, and count match, then we just write it out */
+/* over the old values without altering the directory entry at */
+/* all. */
+/* -------------------------------------------------------------------- */
+ if( entry_count == (uint64)count && entry_type == (uint16) datatype )
+ {
+ if (!SeekOK(tif, entry_offset)) {
+ _TIFFfree( buf_to_write );
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Seek error accessing TIFF directory",
+ tif->tif_name);
+ return 0;
+ }
+ if (!WriteOK(tif, buf_to_write, count*TIFFDataWidth(datatype))) {
+ _TIFFfree( buf_to_write );
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+
+ _TIFFfree( buf_to_write );
+ return 1;
+ }
+
+/* -------------------------------------------------------------------- */
+/* Otherwise, we write the new tag data at the end of the file. */
+/* -------------------------------------------------------------------- */
+ if( !value_in_entry )
+ {
+ entry_offset = TIFFSeekFile(tif,0,SEEK_END);
+
+ if (!WriteOK(tif, buf_to_write, count*TIFFDataWidth(datatype))) {
+ _TIFFfree( buf_to_write );
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error writing directory link");
+ return (0);
+ }
+ }
+ else
+ {
+ memcpy( &entry_offset, buf_to_write, count*TIFFDataWidth(datatype));
+ }
+
+ _TIFFfree( buf_to_write );
+ buf_to_write = 0;
+
+/* -------------------------------------------------------------------- */
+/* Adjust the directory entry. */
+/* -------------------------------------------------------------------- */
+ entry_type = datatype;
+ memcpy( direntry_raw + 2, &entry_type, sizeof(uint16) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabShort( (uint16 *) (direntry_raw + 2) );
+
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ uint32 value;
+
+ value = (uint32) entry_count;
+ memcpy( direntry_raw + 4, &value, sizeof(uint32) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong( (uint32 *) (direntry_raw + 4) );
+
+ value = (uint32) entry_offset;
+ memcpy( direntry_raw + 8, &value, sizeof(uint32) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong( (uint32 *) (direntry_raw + 8) );
+ }
+ else
+ {
+ memcpy( direntry_raw + 4, &entry_count, sizeof(uint64) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8( (uint64 *) (direntry_raw + 4) );
+
+ memcpy( direntry_raw + 12, &entry_offset, sizeof(uint64) );
+ if (tif->tif_flags&TIFF_SWAB)
+ TIFFSwabLong8( (uint64 *) (direntry_raw + 12) );
+ }
+
+/* -------------------------------------------------------------------- */
+/* Write the directory entry out to disk. */
+/* -------------------------------------------------------------------- */
+ if (!SeekOK(tif, read_offset )) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Seek error accessing TIFF directory",
+ tif->tif_name);
+ return 0;
+ }
+
+ if (!WriteOK(tif, direntry_raw,dirsize))
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: Can not write TIFF directory entry.",
+ tif->tif_name);
+ return 0;
+ }
+
+ return 1;
+}
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_dumpmode.c b/test/monniaux/tiff-4.0.10/tif_dumpmode.c
new file mode 100644
index 00000000..4a0b07f5
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_dumpmode.c
@@ -0,0 +1,141 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * "Null" Compression Algorithm Support.
+ */
+#include "tiffiop.h"
+
+static int
+DumpFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+/*
+ * Encode a hunk of pixels.
+ */
+static int
+DumpModeEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s)
+{
+ (void) s;
+ while (cc > 0) {
+ tmsize_t n;
+
+ n = cc;
+ if (tif->tif_rawcc + n > tif->tif_rawdatasize)
+ n = tif->tif_rawdatasize - tif->tif_rawcc;
+
+ assert( n > 0 );
+
+ /*
+ * Avoid copy if client has setup raw
+ * data buffer to avoid extra copy.
+ */
+ if (tif->tif_rawcp != pp)
+ _TIFFmemcpy(tif->tif_rawcp, pp, n);
+ tif->tif_rawcp += n;
+ tif->tif_rawcc += n;
+ pp += n;
+ cc -= n;
+ if (tif->tif_rawcc >= tif->tif_rawdatasize &&
+ !TIFFFlushData1(tif))
+ return (0);
+ }
+ return (1);
+}
+
+/*
+ * Decode a hunk of pixels.
+ */
+static int
+DumpModeDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "DumpModeDecode";
+ (void) s;
+ if (tif->tif_rawcc < cc) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+"Not enough data for scanline %lu, expected a request for at most %I64d bytes, got a request for %I64d bytes",
+ (unsigned long) tif->tif_row,
+ (signed __int64) tif->tif_rawcc,
+ (signed __int64) cc);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+"Not enough data for scanline %lu, expected a request for at most %lld bytes, got a request for %lld bytes",
+ (unsigned long) tif->tif_row,
+ (signed long long) tif->tif_rawcc,
+ (signed long long) cc);
+#endif
+ return (0);
+ }
+ /*
+ * Avoid copy if client has setup raw
+ * data buffer to avoid extra copy.
+ */
+ if (tif->tif_rawcp != buf)
+ _TIFFmemcpy(buf, tif->tif_rawcp, cc);
+ tif->tif_rawcp += cc;
+ tif->tif_rawcc -= cc;
+ return (1);
+}
+
+/*
+ * Seek forwards nrows in the current strip.
+ */
+static int
+DumpModeSeek(TIFF* tif, uint32 nrows)
+{
+ tif->tif_rawcp += nrows * tif->tif_scanlinesize;
+ tif->tif_rawcc -= nrows * tif->tif_scanlinesize;
+ return (1);
+}
+
+/*
+ * Initialize dump mode.
+ */
+int
+TIFFInitDumpMode(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ tif->tif_fixuptags = DumpFixupTags;
+ tif->tif_decoderow = DumpModeDecode;
+ tif->tif_decodestrip = DumpModeDecode;
+ tif->tif_decodetile = DumpModeDecode;
+ tif->tif_encoderow = DumpModeEncode;
+ tif->tif_encodestrip = DumpModeEncode;
+ tif->tif_encodetile = DumpModeEncode;
+ tif->tif_seek = DumpModeSeek;
+ return (1);
+}
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_error.c b/test/monniaux/tiff-4.0.10/tif_error.c
new file mode 100644
index 00000000..651168f7
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_error.c
@@ -0,0 +1,86 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ */
+#include "tiffiop.h"
+
+TIFFErrorHandlerExt _TIFFerrorHandlerExt = NULL;
+
+TIFFErrorHandler
+TIFFSetErrorHandler(TIFFErrorHandler handler)
+{
+ TIFFErrorHandler prev = _TIFFerrorHandler;
+ _TIFFerrorHandler = handler;
+ return (prev);
+}
+
+TIFFErrorHandlerExt
+TIFFSetErrorHandlerExt(TIFFErrorHandlerExt handler)
+{
+ TIFFErrorHandlerExt prev = _TIFFerrorHandlerExt;
+ _TIFFerrorHandlerExt = handler;
+ return (prev);
+}
+
+void
+TIFFError(const char* module, const char* fmt, ...)
+{
+ va_list ap;
+ if (_TIFFerrorHandler) {
+ va_start(ap, fmt);
+ (*_TIFFerrorHandler)(module, fmt, ap);
+ va_end(ap);
+ }
+ if (_TIFFerrorHandlerExt) {
+ va_start(ap, fmt);
+ (*_TIFFerrorHandlerExt)(0, module, fmt, ap);
+ va_end(ap);
+ }
+}
+
+void
+TIFFErrorExt(thandle_t fd, const char* module, const char* fmt, ...)
+{
+ va_list ap;
+ if (_TIFFerrorHandler) {
+ va_start(ap, fmt);
+ (*_TIFFerrorHandler)(module, fmt, ap);
+ va_end(ap);
+ }
+ if (_TIFFerrorHandlerExt) {
+ va_start(ap, fmt);
+ (*_TIFFerrorHandlerExt)(fd, module, fmt, ap);
+ va_end(ap);
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_extension.c b/test/monniaux/tiff-4.0.10/tif_extension.c
new file mode 100644
index 00000000..87d3cfcb
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_extension.c
@@ -0,0 +1,116 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Various routines support external extension of the tag set, and other
+ * application extension capabilities.
+ */
+
+#include "tiffiop.h"
+
+int TIFFGetTagListCount( TIFF *tif )
+
+{
+ TIFFDirectory* td = &tif->tif_dir;
+
+ return td->td_customValueCount;
+}
+
+uint32 TIFFGetTagListEntry( TIFF *tif, int tag_index )
+
+{
+ TIFFDirectory* td = &tif->tif_dir;
+
+ if( tag_index < 0 || tag_index >= td->td_customValueCount )
+ return (uint32)(-1);
+ else
+ return td->td_customValues[tag_index].info->field_tag;
+}
+
+/*
+** This provides read/write access to the TIFFTagMethods within the TIFF
+** structure to application code without giving access to the private
+** TIFF structure.
+*/
+TIFFTagMethods *TIFFAccessTagMethods( TIFF *tif )
+
+{
+ return &(tif->tif_tagmethods);
+}
+
+void *TIFFGetClientInfo( TIFF *tif, const char *name )
+
+{
+ TIFFClientInfoLink *psLink = tif->tif_clientinfo;
+
+ while( psLink != NULL && strcmp(psLink->name,name) != 0 )
+ psLink = psLink->next;
+
+ if( psLink != NULL )
+ return psLink->data;
+ else
+ return NULL;
+}
+
+void TIFFSetClientInfo( TIFF *tif, void *data, const char *name )
+
+{
+ TIFFClientInfoLink *psLink = tif->tif_clientinfo;
+
+ /*
+ ** Do we have an existing link with this name? If so, just
+ ** set it.
+ */
+ while( psLink != NULL && strcmp(psLink->name,name) != 0 )
+ psLink = psLink->next;
+
+ if( psLink != NULL )
+ {
+ psLink->data = data;
+ return;
+ }
+
+ /*
+ ** Create a new link.
+ */
+
+ psLink = (TIFFClientInfoLink *) _TIFFmalloc(sizeof(TIFFClientInfoLink));
+ assert (psLink != NULL);
+ psLink->next = tif->tif_clientinfo;
+ psLink->name = (char *) _TIFFmalloc((tmsize_t)(strlen(name)+1));
+ assert (psLink->name != NULL);
+ strcpy(psLink->name, name);
+ psLink->data = data;
+
+ tif->tif_clientinfo = psLink;
+}
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_fax3.c b/test/monniaux/tiff-4.0.10/tif_fax3.c
new file mode 100644
index 00000000..d11c9684
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_fax3.c
@@ -0,0 +1,1646 @@
+/*
+ * Copyright (c) 1990-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef CCITT_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * CCITT Group 3 (T.4) and Group 4 (T.6) Compression Support.
+ *
+ * This file contains support for decoding and encoding TIFF
+ * compression algorithms 2, 3, 4, and 32771.
+ *
+ * Decoder support is derived, with permission, from the code
+ * in Frank Cringle's viewfax program;
+ * Copyright (C) 1990, 1995 Frank D. Cringle.
+ */
+#include "tif_fax3.h"
+#define G3CODES
+#include "t4.h"
+#include <stdio.h>
+
+/*
+ * Compression+decompression state blocks are
+ * derived from this ``base state'' block.
+ */
+typedef struct {
+ int rw_mode; /* O_RDONLY for decode, else encode */
+ int mode; /* operating mode */
+ tmsize_t rowbytes; /* bytes in a decoded scanline */
+ uint32 rowpixels; /* pixels in a scanline */
+
+ uint16 cleanfaxdata; /* CleanFaxData tag */
+ uint32 badfaxrun; /* BadFaxRun tag */
+ uint32 badfaxlines; /* BadFaxLines tag */
+ uint32 groupoptions; /* Group 3/4 options tag */
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+ TIFFPrintMethod printdir; /* super-class method */
+} Fax3BaseState;
+#define Fax3State(tif) ((Fax3BaseState*) (tif)->tif_data)
+
+typedef enum { G3_1D, G3_2D } Ttag;
+typedef struct {
+ Fax3BaseState b;
+
+ /* Decoder state info */
+ const unsigned char* bitmap; /* bit reversal table */
+ uint32 data; /* current i/o byte/word */
+ int bit; /* current i/o bit in byte */
+ int EOLcnt; /* count of EOL codes recognized */
+ TIFFFaxFillFunc fill; /* fill routine */
+ uint32* runs; /* b&w runs for current/previous row */
+ uint32* refruns; /* runs for reference line */
+ uint32* curruns; /* runs for current line */
+
+ /* Encoder state info */
+ Ttag tag; /* encoding state */
+ unsigned char* refline; /* reference line for 2d decoding */
+ int k; /* #rows left that can be 2d encoded */
+ int maxk; /* max #rows that can be 2d encoded */
+
+ int line;
+} Fax3CodecState;
+#define DecoderState(tif) ((Fax3CodecState*) Fax3State(tif))
+#define EncoderState(tif) ((Fax3CodecState*) Fax3State(tif))
+
+#define is2DEncoding(sp) (sp->b.groupoptions & GROUP3OPT_2DENCODING)
+#define isAligned(p,t) ((((size_t)(p)) & (sizeof (t)-1)) == 0)
+
+/*
+ * Group 3 and Group 4 Decoding.
+ */
+
+/*
+ * These macros glue the TIFF library state to
+ * the state expected by Frank's decoder.
+ */
+#define DECLARE_STATE(tif, sp, mod) \
+ static const char module[] = mod; \
+ Fax3CodecState* sp = DecoderState(tif); \
+ int a0; /* reference element */ \
+ int lastx = sp->b.rowpixels; /* last element in row */ \
+ uint32 BitAcc; /* bit accumulator */ \
+ int BitsAvail; /* # valid bits in BitAcc */ \
+ int RunLength; /* length of current run */ \
+ unsigned char* cp; /* next byte of input data */ \
+ unsigned char* ep; /* end of input data */ \
+ uint32* pa; /* place to stuff next run */ \
+ uint32* thisrun; /* current row's run array */ \
+ int EOLcnt; /* # EOL codes recognized */ \
+ const unsigned char* bitmap = sp->bitmap; /* input data bit reverser */ \
+ const TIFFFaxTabEnt* TabEnt
+#define DECLARE_STATE_2D(tif, sp, mod) \
+ DECLARE_STATE(tif, sp, mod); \
+ int b1; /* next change on prev line */ \
+ uint32* pb /* next run in reference line */\
+/*
+ * Load any state that may be changed during decoding.
+ */
+#define CACHE_STATE(tif, sp) do { \
+ BitAcc = sp->data; \
+ BitsAvail = sp->bit; \
+ EOLcnt = sp->EOLcnt; \
+ cp = (unsigned char*) tif->tif_rawcp; \
+ ep = cp + tif->tif_rawcc; \
+} while (0)
+/*
+ * Save state possibly changed during decoding.
+ */
+#define UNCACHE_STATE(tif, sp) do { \
+ sp->bit = BitsAvail; \
+ sp->data = BitAcc; \
+ sp->EOLcnt = EOLcnt; \
+ tif->tif_rawcc -= (tmsize_t)((uint8*) cp - tif->tif_rawcp); \
+ tif->tif_rawcp = (uint8*) cp; \
+} while (0)
+
+/*
+ * Setup state for decoding a strip.
+ */
+static int
+Fax3PreDecode(TIFF* tif, uint16 s)
+{
+ Fax3CodecState* sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ sp->bit = 0; /* force initial read */
+ sp->data = 0;
+ sp->EOLcnt = 0; /* force initial scan for EOL */
+ /*
+ * Decoder assumes lsb-to-msb bit order. Note that we select
+ * this here rather than in Fax3SetupState so that viewers can
+ * hold the image open, fiddle with the FillOrder tag value,
+ * and then re-decode the image. Otherwise they'd need to close
+ * and open the image to get the state reset.
+ */
+ sp->bitmap =
+ TIFFGetBitRevTable(tif->tif_dir.td_fillorder != FILLORDER_LSB2MSB);
+ if (sp->refruns) { /* init reference line to white */
+ sp->refruns[0] = (uint32) sp->b.rowpixels;
+ sp->refruns[1] = 0;
+ }
+ sp->line = 0;
+ return (1);
+}
+
+/*
+ * Routine for handling various errors/conditions.
+ * Note how they are "glued into the decoder" by
+ * overriding the definitions used by the decoder.
+ */
+
+static void
+Fax3Unexpected(const char* module, TIFF* tif, uint32 line, uint32 a0)
+{
+ TIFFErrorExt(tif->tif_clientdata, module, "Bad code word at line %u of %s %u (x %u)",
+ line, isTiled(tif) ? "tile" : "strip",
+ (isTiled(tif) ? tif->tif_curtile : tif->tif_curstrip),
+ a0);
+}
+#define unexpected(table, a0) Fax3Unexpected(module, tif, sp->line, a0)
+
+static void
+Fax3Extension(const char* module, TIFF* tif, uint32 line, uint32 a0)
+{
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Uncompressed data (not supported) at line %u of %s %u (x %u)",
+ line, isTiled(tif) ? "tile" : "strip",
+ (isTiled(tif) ? tif->tif_curtile : tif->tif_curstrip),
+ a0);
+}
+#define extension(a0) Fax3Extension(module, tif, sp->line, a0)
+
+static void
+Fax3BadLength(const char* module, TIFF* tif, uint32 line, uint32 a0, uint32 lastx)
+{
+ TIFFWarningExt(tif->tif_clientdata, module, "%s at line %u of %s %u (got %u, expected %u)",
+ a0 < lastx ? "Premature EOL" : "Line length mismatch",
+ line, isTiled(tif) ? "tile" : "strip",
+ (isTiled(tif) ? tif->tif_curtile : tif->tif_curstrip),
+ a0, lastx);
+}
+#define badlength(a0,lastx) Fax3BadLength(module, tif, sp->line, a0, lastx)
+
+static void
+Fax3PrematureEOF(const char* module, TIFF* tif, uint32 line, uint32 a0)
+{
+ TIFFWarningExt(tif->tif_clientdata, module, "Premature EOF at line %u of %s %u (x %u)",
+ line, isTiled(tif) ? "tile" : "strip",
+ (isTiled(tif) ? tif->tif_curtile : tif->tif_curstrip),
+ a0);
+}
+#define prematureEOF(a0) Fax3PrematureEOF(module, tif, sp->line, a0)
+
+#define Nop
+
+/*
+ * Decode the requested amount of G3 1D-encoded data.
+ */
+static int
+Fax3Decode1D(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ DECLARE_STATE(tif, sp, "Fax3Decode1D");
+ (void) s;
+ if (occ % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (-1);
+ }
+ CACHE_STATE(tif, sp);
+ thisrun = sp->curruns;
+ while (occ > 0) {
+ a0 = 0;
+ RunLength = 0;
+ pa = thisrun;
+#ifdef FAX3_DEBUG
+ printf("\nBitAcc=%08X, BitsAvail = %d\n", BitAcc, BitsAvail);
+ printf("-------------------- %d\n", tif->tif_row);
+ fflush(stdout);
+#endif
+ SYNC_EOL(EOF1D);
+ EXPAND1D(EOF1Da);
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ buf += sp->b.rowbytes;
+ occ -= sp->b.rowbytes;
+ sp->line++;
+ continue;
+ EOF1D: /* premature EOF */
+ CLEANUP_RUNS();
+ EOF1Da: /* premature EOF */
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ UNCACHE_STATE(tif, sp);
+ return (-1);
+ }
+ UNCACHE_STATE(tif, sp);
+ return (1);
+}
+
+#define SWAP(t,a,b) { t x; x = (a); (a) = (b); (b) = x; }
+/*
+ * Decode the requested amount of G3 2D-encoded data.
+ */
+static int
+Fax3Decode2D(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ DECLARE_STATE_2D(tif, sp, "Fax3Decode2D");
+ int is1D; /* current line is 1d/2d-encoded */
+ (void) s;
+ if (occ % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (-1);
+ }
+ CACHE_STATE(tif, sp);
+ while (occ > 0) {
+ a0 = 0;
+ RunLength = 0;
+ pa = thisrun = sp->curruns;
+#ifdef FAX3_DEBUG
+ printf("\nBitAcc=%08X, BitsAvail = %d EOLcnt = %d",
+ BitAcc, BitsAvail, EOLcnt);
+#endif
+ SYNC_EOL(EOF2D);
+ NeedBits8(1, EOF2D);
+ is1D = GetBits(1); /* 1D/2D-encoding tag bit */
+ ClrBits(1);
+#ifdef FAX3_DEBUG
+ printf(" %s\n-------------------- %d\n",
+ is1D ? "1D" : "2D", tif->tif_row);
+ fflush(stdout);
+#endif
+ pb = sp->refruns;
+ b1 = *pb++;
+ if (is1D)
+ EXPAND1D(EOF2Da);
+ else
+ EXPAND2D(EOF2Da);
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ SETVALUE(0); /* imaginary change for reference */
+ SWAP(uint32*, sp->curruns, sp->refruns);
+ buf += sp->b.rowbytes;
+ occ -= sp->b.rowbytes;
+ sp->line++;
+ continue;
+ EOF2D: /* premature EOF */
+ CLEANUP_RUNS();
+ EOF2Da: /* premature EOF */
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ UNCACHE_STATE(tif, sp);
+ return (-1);
+ }
+ UNCACHE_STATE(tif, sp);
+ return (1);
+}
+#undef SWAP
+
+/*
+ * The ZERO & FILL macros must handle spans < 2*sizeof(long) bytes.
+ * For machines with 64-bit longs this is <16 bytes; otherwise
+ * this is <8 bytes. We optimize the code here to reflect the
+ * machine characteristics.
+ */
+#if SIZEOF_UNSIGNED_LONG == 8
+# define FILL(n, cp) \
+ switch (n) { \
+ case 15:(cp)[14] = 0xff; /*-fallthrough*/ \
+ case 14:(cp)[13] = 0xff; /*-fallthrough*/ \
+ case 13:(cp)[12] = 0xff; /*-fallthrough*/ \
+ case 12:(cp)[11] = 0xff; /*-fallthrough*/ \
+ case 11:(cp)[10] = 0xff; /*-fallthrough*/ \
+ case 10: (cp)[9] = 0xff; /*-fallthrough*/ \
+ case 9: (cp)[8] = 0xff; /*-fallthrough*/ \
+ case 8: (cp)[7] = 0xff; /*-fallthrough*/ \
+ case 7: (cp)[6] = 0xff; /*-fallthrough*/ \
+ case 6: (cp)[5] = 0xff; /*-fallthrough*/ \
+ case 5: (cp)[4] = 0xff; /*-fallthrough*/ \
+ case 4: (cp)[3] = 0xff; /*-fallthrough*/ \
+ case 3: (cp)[2] = 0xff; /*-fallthrough*/ \
+ case 2: (cp)[1] = 0xff; /*-fallthrough*/ \
+ case 1: (cp)[0] = 0xff; (cp) += (n); /*-fallthrough*/ \
+ case 0: ; \
+ }
+# define ZERO(n, cp) \
+ switch (n) { \
+ case 15:(cp)[14] = 0; /*-fallthrough*/ \
+ case 14:(cp)[13] = 0; /*-fallthrough*/ \
+ case 13:(cp)[12] = 0; /*-fallthrough*/ \
+ case 12:(cp)[11] = 0; /*-fallthrough*/ \
+ case 11:(cp)[10] = 0; /*-fallthrough*/ \
+ case 10: (cp)[9] = 0; /*-fallthrough*/ \
+ case 9: (cp)[8] = 0; /*-fallthrough*/ \
+ case 8: (cp)[7] = 0; /*-fallthrough*/ \
+ case 7: (cp)[6] = 0; /*-fallthrough*/ \
+ case 6: (cp)[5] = 0; /*-fallthrough*/ \
+ case 5: (cp)[4] = 0; /*-fallthrough*/ \
+ case 4: (cp)[3] = 0; /*-fallthrough*/ \
+ case 3: (cp)[2] = 0; /*-fallthrough*/ \
+ case 2: (cp)[1] = 0; /*-fallthrough*/ \
+ case 1: (cp)[0] = 0; (cp) += (n); /*-fallthrough*/ \
+ case 0: ; \
+ }
+#else
+# define FILL(n, cp) \
+ switch (n) { \
+ case 7: (cp)[6] = 0xff; /*-fallthrough*/ \
+ case 6: (cp)[5] = 0xff; /*-fallthrough*/ \
+ case 5: (cp)[4] = 0xff; /*-fallthrough*/ \
+ case 4: (cp)[3] = 0xff; /*-fallthrough*/ \
+ case 3: (cp)[2] = 0xff; /*-fallthrough*/ \
+ case 2: (cp)[1] = 0xff; /*-fallthrough*/ \
+ case 1: (cp)[0] = 0xff; (cp) += (n); /*-fallthrough*/ \
+ case 0: ; \
+ }
+# define ZERO(n, cp) \
+ switch (n) { \
+ case 7: (cp)[6] = 0; /*-fallthrough*/ \
+ case 6: (cp)[5] = 0; /*-fallthrough*/ \
+ case 5: (cp)[4] = 0; /*-fallthrough*/ \
+ case 4: (cp)[3] = 0; /*-fallthrough*/ \
+ case 3: (cp)[2] = 0; /*-fallthrough*/ \
+ case 2: (cp)[1] = 0; /*-fallthrough*/ \
+ case 1: (cp)[0] = 0; (cp) += (n); /*-fallthrough*/ \
+ case 0: ; \
+ }
+#endif
+
+/*
+ * Bit-fill a row according to the white/black
+ * runs generated during G3/G4 decoding.
+ */
+void
+_TIFFFax3fillruns(unsigned char* buf, uint32* runs, uint32* erun, uint32 lastx)
+{
+ static const unsigned char _fillmasks[] =
+ { 0x00, 0x80, 0xc0, 0xe0, 0xf0, 0xf8, 0xfc, 0xfe, 0xff };
+ unsigned char* cp;
+ uint32 x, bx, run;
+ int32 n, nw;
+ long* lp;
+
+ if ((erun-runs)&1)
+ *erun++ = 0;
+ x = 0;
+ for (; runs < erun; runs += 2) {
+ run = runs[0];
+ if (x+run > lastx || run > lastx )
+ run = runs[0] = (uint32) (lastx - x);
+ if (run) {
+ cp = buf + (x>>3);
+ bx = x&7;
+ if (run > 8-bx) {
+ if (bx) { /* align to byte boundary */
+ *cp++ &= 0xff << (8-bx);
+ run -= 8-bx;
+ }
+ if( (n = run >> 3) != 0 ) { /* multiple bytes to fill */
+ if ((n/sizeof (long)) > 1) {
+ /*
+ * Align to longword boundary and fill.
+ */
+ for (; n && !isAligned(cp, long); n--)
+ *cp++ = 0x00;
+ lp = (long*) cp;
+ nw = (int32)(n / sizeof (long));
+ n -= nw * sizeof (long);
+ do {
+ *lp++ = 0L;
+ } while (--nw);
+ cp = (unsigned char*) lp;
+ }
+ ZERO(n, cp);
+ run &= 7;
+ }
+ if (run)
+ cp[0] &= 0xff >> run;
+ } else
+ cp[0] &= ~(_fillmasks[run]>>bx);
+ x += runs[0];
+ }
+ run = runs[1];
+ if (x+run > lastx || run > lastx )
+ run = runs[1] = lastx - x;
+ if (run) {
+ cp = buf + (x>>3);
+ bx = x&7;
+ if (run > 8-bx) {
+ if (bx) { /* align to byte boundary */
+ *cp++ |= 0xff >> bx;
+ run -= 8-bx;
+ }
+ if( (n = run>>3) != 0 ) { /* multiple bytes to fill */
+ if ((n/sizeof (long)) > 1) {
+ /*
+ * Align to longword boundary and fill.
+ */
+ for (; n && !isAligned(cp, long); n--)
+ *cp++ = 0xff;
+ lp = (long*) cp;
+ nw = (int32)(n / sizeof (long));
+ n -= nw * sizeof (long);
+ do {
+ *lp++ = -1L;
+ } while (--nw);
+ cp = (unsigned char*) lp;
+ }
+ FILL(n, cp);
+ run &= 7;
+ }
+ /* Explicit 0xff masking to make icc -check=conversions happy */
+ if (run)
+ cp[0] = (unsigned char)((cp[0] | (0xff00 >> run))&0xff);
+ } else
+ cp[0] |= _fillmasks[run]>>bx;
+ x += runs[1];
+ }
+ }
+ assert(x == lastx);
+}
+#undef ZERO
+#undef FILL
+
+static int
+Fax3FixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+/*
+ * Setup G3/G4-related compression/decompression state
+ * before data is processed. This routine is called once
+ * per image -- it sets up different state based on whether
+ * or not decoding or encoding is being done and whether
+ * 1D- or 2D-encoded data is involved.
+ */
+static int
+Fax3SetupState(TIFF* tif)
+{
+ static const char module[] = "Fax3SetupState";
+ TIFFDirectory* td = &tif->tif_dir;
+ Fax3BaseState* sp = Fax3State(tif);
+ int needsRefLine;
+ Fax3CodecState* dsp = (Fax3CodecState*) Fax3State(tif);
+ tmsize_t rowbytes;
+ uint32 rowpixels, nruns;
+
+ if (td->td_bitspersample != 1) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Bits/sample must be 1 for Group 3/4 encoding/decoding");
+ return (0);
+ }
+ /*
+ * Calculate the scanline/tile widths.
+ */
+ if (isTiled(tif)) {
+ rowbytes = TIFFTileRowSize(tif);
+ rowpixels = td->td_tilewidth;
+ } else {
+ rowbytes = TIFFScanlineSize(tif);
+ rowpixels = td->td_imagewidth;
+ }
+ sp->rowbytes = rowbytes;
+ sp->rowpixels = rowpixels;
+ /*
+ * Allocate any additional space required for decoding/encoding.
+ */
+ needsRefLine = (
+ (sp->groupoptions & GROUP3OPT_2DENCODING) ||
+ td->td_compression == COMPRESSION_CCITTFAX4
+ );
+
+ /*
+ Assure that allocation computations do not overflow.
+
+ TIFFroundup and TIFFSafeMultiply return zero on integer overflow
+ */
+ dsp->runs=(uint32*) NULL;
+ nruns = TIFFroundup_32(rowpixels,32);
+ if (needsRefLine) {
+ nruns = TIFFSafeMultiply(uint32,nruns,2);
+ }
+ if ((nruns == 0) || (TIFFSafeMultiply(uint32,nruns,2) == 0)) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Row pixels integer overflow (rowpixels %u)",
+ rowpixels);
+ return (0);
+ }
+ dsp->runs = (uint32*) _TIFFCheckMalloc(tif,
+ TIFFSafeMultiply(uint32,nruns,2),
+ sizeof (uint32),
+ "for Group 3/4 run arrays");
+ if (dsp->runs == NULL)
+ return (0);
+ memset( dsp->runs, 0, TIFFSafeMultiply(uint32,nruns,2)*sizeof(uint32));
+ dsp->curruns = dsp->runs;
+ if (needsRefLine)
+ dsp->refruns = dsp->runs + nruns;
+ else
+ dsp->refruns = NULL;
+ if (td->td_compression == COMPRESSION_CCITTFAX3
+ && is2DEncoding(dsp)) { /* NB: default is 1D routine */
+ tif->tif_decoderow = Fax3Decode2D;
+ tif->tif_decodestrip = Fax3Decode2D;
+ tif->tif_decodetile = Fax3Decode2D;
+ }
+
+ if (needsRefLine) { /* 2d encoding */
+ Fax3CodecState* esp = EncoderState(tif);
+ /*
+ * 2d encoding requires a scanline
+ * buffer for the ``reference line''; the
+ * scanline against which delta encoding
+ * is referenced. The reference line must
+ * be initialized to be ``white'' (done elsewhere).
+ */
+ esp->refline = (unsigned char*) _TIFFmalloc(rowbytes);
+ if (esp->refline == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for Group 3/4 reference line");
+ return (0);
+ }
+ } else /* 1d encoding */
+ EncoderState(tif)->refline = NULL;
+
+ return (1);
+}
+
+/*
+ * CCITT Group 3 FAX Encoding.
+ */
+
+#define Fax3FlushBits(tif, sp) { \
+ if ((tif)->tif_rawcc >= (tif)->tif_rawdatasize) \
+ (void) TIFFFlushData1(tif); \
+ *(tif)->tif_rawcp++ = (uint8) (sp)->data; \
+ (tif)->tif_rawcc++; \
+ (sp)->data = 0, (sp)->bit = 8; \
+}
+#define _FlushBits(tif) { \
+ if ((tif)->tif_rawcc >= (tif)->tif_rawdatasize) \
+ (void) TIFFFlushData1(tif); \
+ *(tif)->tif_rawcp++ = (uint8) data; \
+ (tif)->tif_rawcc++; \
+ data = 0, bit = 8; \
+}
+static const int _msbmask[9] =
+ { 0x00, 0x01, 0x03, 0x07, 0x0f, 0x1f, 0x3f, 0x7f, 0xff };
+#define _PutBits(tif, bits, length) { \
+ while (length > bit) { \
+ data |= bits >> (length - bit); \
+ length -= bit; \
+ _FlushBits(tif); \
+ } \
+ assert( length < 9 ); \
+ data |= (bits & _msbmask[length]) << (bit - length); \
+ bit -= length; \
+ if (bit == 0) \
+ _FlushBits(tif); \
+}
+
+/*
+ * Write a variable-length bit-value to
+ * the output stream. Values are
+ * assumed to be at most 16 bits.
+ */
+static void
+Fax3PutBits(TIFF* tif, unsigned int bits, unsigned int length)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+ unsigned int bit = sp->bit;
+ int data = sp->data;
+
+ _PutBits(tif, bits, length);
+
+ sp->data = data;
+ sp->bit = bit;
+}
+
+/*
+ * Write a code to the output stream.
+ */
+#define putcode(tif, te) Fax3PutBits(tif, (te)->code, (te)->length)
+
+#ifdef FAX3_DEBUG
+#define DEBUG_COLOR(w) (tab == TIFFFaxWhiteCodes ? w "W" : w "B")
+#define DEBUG_PRINT(what,len) { \
+ int t; \
+ printf("%08X/%-2d: %s%5d\t", data, bit, DEBUG_COLOR(what), len); \
+ for (t = length-1; t >= 0; t--) \
+ putchar(code & (1<<t) ? '1' : '0'); \
+ putchar('\n'); \
+}
+#endif
+
+/*
+ * Write the sequence of codes that describes
+ * the specified span of zero's or one's. The
+ * appropriate table that holds the make-up and
+ * terminating codes is supplied.
+ */
+static void
+putspan(TIFF* tif, int32 span, const tableentry* tab)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+ unsigned int bit = sp->bit;
+ int data = sp->data;
+ unsigned int code, length;
+
+ while (span >= 2624) {
+ const tableentry* te = &tab[63 + (2560>>6)];
+ code = te->code;
+ length = te->length;
+#ifdef FAX3_DEBUG
+ DEBUG_PRINT("MakeUp", te->runlen);
+#endif
+ _PutBits(tif, code, length);
+ span -= te->runlen;
+ }
+ if (span >= 64) {
+ const tableentry* te = &tab[63 + (span>>6)];
+ assert(te->runlen == 64*(span>>6));
+ code = te->code;
+ length = te->length;
+#ifdef FAX3_DEBUG
+ DEBUG_PRINT("MakeUp", te->runlen);
+#endif
+ _PutBits(tif, code, length);
+ span -= te->runlen;
+ }
+ code = tab[span].code;
+ length = tab[span].length;
+#ifdef FAX3_DEBUG
+ DEBUG_PRINT(" Term", tab[span].runlen);
+#endif
+ _PutBits(tif, code, length);
+
+ sp->data = data;
+ sp->bit = bit;
+}
+
+/*
+ * Write an EOL code to the output stream. The zero-fill
+ * logic for byte-aligning encoded scanlines is handled
+ * here. We also handle writing the tag bit for the next
+ * scanline when doing 2d encoding.
+ */
+static void
+Fax3PutEOL(TIFF* tif)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+ unsigned int bit = sp->bit;
+ int data = sp->data;
+ unsigned int code, length, tparm;
+
+ if (sp->b.groupoptions & GROUP3OPT_FILLBITS) {
+ /*
+ * Force bit alignment so EOL will terminate on
+ * a byte boundary. That is, force the bit alignment
+ * to 16-12 = 4 before putting out the EOL code.
+ */
+ int align = 8 - 4;
+ if (align != sp->bit) {
+ if (align > sp->bit)
+ align = sp->bit + (8 - align);
+ else
+ align = sp->bit - align;
+ tparm=align;
+ _PutBits(tif, 0, tparm);
+ }
+ }
+ code = EOL;
+ length = 12;
+ if (is2DEncoding(sp)) {
+ code = (code<<1) | (sp->tag == G3_1D);
+ length++;
+ }
+ _PutBits(tif, code, length);
+
+ sp->data = data;
+ sp->bit = bit;
+}
+
+/*
+ * Reset encoding state at the start of a strip.
+ */
+static int
+Fax3PreEncode(TIFF* tif, uint16 s)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ sp->bit = 8;
+ sp->data = 0;
+ sp->tag = G3_1D;
+ /*
+ * This is necessary for Group 4; otherwise it isn't
+ * needed because the first scanline of each strip ends
+ * up being copied into the refline.
+ */
+ if (sp->refline)
+ _TIFFmemset(sp->refline, 0x00, sp->b.rowbytes);
+ if (is2DEncoding(sp)) {
+ float res = tif->tif_dir.td_yresolution;
+ /*
+ * The CCITT spec says that when doing 2d encoding, you
+ * should only do it on K consecutive scanlines, where K
+ * depends on the resolution of the image being encoded
+ * (2 for <= 200 lpi, 4 for > 200 lpi). Since the directory
+ * code initializes td_yresolution to 0, this code will
+ * select a K of 2 unless the YResolution tag is set
+ * appropriately. (Note also that we fudge a little here
+ * and use 150 lpi to avoid problems with units conversion.)
+ */
+ if (tif->tif_dir.td_resolutionunit == RESUNIT_CENTIMETER)
+ res *= 2.54f; /* convert to inches */
+ sp->maxk = (res > 150 ? 4 : 2);
+ sp->k = sp->maxk-1;
+ } else
+ sp->k = sp->maxk = 0;
+ sp->line = 0;
+ return (1);
+}
+
+static const unsigned char zeroruns[256] = {
+ 8, 7, 6, 6, 5, 5, 5, 5, 4, 4, 4, 4, 4, 4, 4, 4, /* 0x00 - 0x0f */
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, /* 0x10 - 0x1f */
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 0x20 - 0x2f */
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 0x30 - 0x3f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x40 - 0x4f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x50 - 0x5f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x60 - 0x6f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x70 - 0x7f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x80 - 0x8f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x90 - 0x9f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xa0 - 0xaf */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xb0 - 0xbf */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xc0 - 0xcf */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xd0 - 0xdf */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xe0 - 0xef */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0xf0 - 0xff */
+};
+static const unsigned char oneruns[256] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x00 - 0x0f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x10 - 0x1f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x20 - 0x2f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x30 - 0x3f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x40 - 0x4f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x50 - 0x5f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x60 - 0x6f */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x70 - 0x7f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x80 - 0x8f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x90 - 0x9f */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0xa0 - 0xaf */
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0xb0 - 0xbf */
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 0xc0 - 0xcf */
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, /* 0xd0 - 0xdf */
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, /* 0xe0 - 0xef */
+ 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7, 8, /* 0xf0 - 0xff */
+};
+
+/*
+ * On certain systems it pays to inline
+ * the routines that find pixel spans.
+ */
+#ifdef VAXC
+static int32 find0span(unsigned char*, int32, int32);
+static int32 find1span(unsigned char*, int32, int32);
+#pragma inline(find0span,find1span)
+#endif
+
+/*
+ * Find a span of ones or zeros using the supplied
+ * table. The ``base'' of the bit string is supplied
+ * along with the start+end bit indices.
+ */
+inline static int32
+find0span(unsigned char* bp, int32 bs, int32 be)
+{
+ int32 bits = be - bs;
+ int32 n, span;
+
+ bp += bs>>3;
+ /*
+ * Check partial byte on lhs.
+ */
+ if (bits > 0 && (n = (bs & 7)) != 0) {
+ span = zeroruns[(*bp << n) & 0xff];
+ if (span > 8-n) /* table value too generous */
+ span = 8-n;
+ if (span > bits) /* constrain span to bit range */
+ span = bits;
+ if (n+span < 8) /* doesn't extend to edge of byte */
+ return (span);
+ bits -= span;
+ bp++;
+ } else
+ span = 0;
+ if (bits >= (int32)(2 * 8 * sizeof(long))) {
+ long* lp;
+ /*
+ * Align to longword boundary and check longwords.
+ */
+ while (!isAligned(bp, long)) {
+ if (*bp != 0x00)
+ return (span + zeroruns[*bp]);
+ span += 8;
+ bits -= 8;
+ bp++;
+ }
+ lp = (long*) bp;
+ while ((bits >= (int32)(8 * sizeof(long))) && (0 == *lp)) {
+ span += 8*sizeof (long);
+ bits -= 8*sizeof (long);
+ lp++;
+ }
+ bp = (unsigned char*) lp;
+ }
+ /*
+ * Scan full bytes for all 0's.
+ */
+ while (bits >= 8) {
+ if (*bp != 0x00) /* end of run */
+ return (span + zeroruns[*bp]);
+ span += 8;
+ bits -= 8;
+ bp++;
+ }
+ /*
+ * Check partial byte on rhs.
+ */
+ if (bits > 0) {
+ n = zeroruns[*bp];
+ span += (n > bits ? bits : n);
+ }
+ return (span);
+}
+
+inline static int32
+find1span(unsigned char* bp, int32 bs, int32 be)
+{
+ int32 bits = be - bs;
+ int32 n, span;
+
+ bp += bs>>3;
+ /*
+ * Check partial byte on lhs.
+ */
+ if (bits > 0 && (n = (bs & 7)) != 0) {
+ span = oneruns[(*bp << n) & 0xff];
+ if (span > 8-n) /* table value too generous */
+ span = 8-n;
+ if (span > bits) /* constrain span to bit range */
+ span = bits;
+ if (n+span < 8) /* doesn't extend to edge of byte */
+ return (span);
+ bits -= span;
+ bp++;
+ } else
+ span = 0;
+ if (bits >= (int32)(2 * 8 * sizeof(long))) {
+ long* lp;
+ /*
+ * Align to longword boundary and check longwords.
+ */
+ while (!isAligned(bp, long)) {
+ if (*bp != 0xff)
+ return (span + oneruns[*bp]);
+ span += 8;
+ bits -= 8;
+ bp++;
+ }
+ lp = (long*) bp;
+ while ((bits >= (int32)(8 * sizeof(long))) && (~0 == *lp)) {
+ span += 8*sizeof (long);
+ bits -= 8*sizeof (long);
+ lp++;
+ }
+ bp = (unsigned char*) lp;
+ }
+ /*
+ * Scan full bytes for all 1's.
+ */
+ while (bits >= 8) {
+ if (*bp != 0xff) /* end of run */
+ return (span + oneruns[*bp]);
+ span += 8;
+ bits -= 8;
+ bp++;
+ }
+ /*
+ * Check partial byte on rhs.
+ */
+ if (bits > 0) {
+ n = oneruns[*bp];
+ span += (n > bits ? bits : n);
+ }
+ return (span);
+}
+
+/*
+ * Return the offset of the next bit in the range
+ * [bs..be] that is different from the specified
+ * color. The end, be, is returned if no such bit
+ * exists.
+ */
+#define finddiff(_cp, _bs, _be, _color) \
+ (_bs + (_color ? find1span(_cp,_bs,_be) : find0span(_cp,_bs,_be)))
+/*
+ * Like finddiff, but also check the starting bit
+ * against the end in case start > end.
+ */
+#define finddiff2(_cp, _bs, _be, _color) \
+ (_bs < _be ? finddiff(_cp,_bs,_be,_color) : _be)
+
+/*
+ * 1d-encode a row of pixels. The encoding is
+ * a sequence of all-white or all-black spans
+ * of pixels encoded with Huffman codes.
+ */
+static int
+Fax3Encode1DRow(TIFF* tif, unsigned char* bp, uint32 bits)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+ int32 span;
+ uint32 bs = 0;
+
+ for (;;) {
+ span = find0span(bp, bs, bits); /* white span */
+ putspan(tif, span, TIFFFaxWhiteCodes);
+ bs += span;
+ if (bs >= bits)
+ break;
+ span = find1span(bp, bs, bits); /* black span */
+ putspan(tif, span, TIFFFaxBlackCodes);
+ bs += span;
+ if (bs >= bits)
+ break;
+ }
+ if (sp->b.mode & (FAXMODE_BYTEALIGN|FAXMODE_WORDALIGN)) {
+ if (sp->bit != 8) /* byte-align */
+ Fax3FlushBits(tif, sp);
+ if ((sp->b.mode&FAXMODE_WORDALIGN) &&
+ !isAligned(tif->tif_rawcp, uint16))
+ Fax3FlushBits(tif, sp);
+ }
+ return (1);
+}
+
+static const tableentry horizcode =
+ { 3, 0x1, 0 }; /* 001 */
+static const tableentry passcode =
+ { 4, 0x1, 0 }; /* 0001 */
+static const tableentry vcodes[7] = {
+ { 7, 0x03, 0 }, /* 0000 011 */
+ { 6, 0x03, 0 }, /* 0000 11 */
+ { 3, 0x03, 0 }, /* 011 */
+ { 1, 0x1, 0 }, /* 1 */
+ { 3, 0x2, 0 }, /* 010 */
+ { 6, 0x02, 0 }, /* 0000 10 */
+ { 7, 0x02, 0 } /* 0000 010 */
+};
+
+/*
+ * 2d-encode a row of pixels. Consult the CCITT
+ * documentation for the algorithm.
+ */
+static int
+Fax3Encode2DRow(TIFF* tif, unsigned char* bp, unsigned char* rp, uint32 bits)
+{
+#define PIXEL(buf,ix) ((((buf)[(ix)>>3]) >> (7-((ix)&7))) & 1)
+ uint32 a0 = 0;
+ uint32 a1 = (PIXEL(bp, 0) != 0 ? 0 : finddiff(bp, 0, bits, 0));
+ uint32 b1 = (PIXEL(rp, 0) != 0 ? 0 : finddiff(rp, 0, bits, 0));
+ uint32 a2, b2;
+
+ for (;;) {
+ b2 = finddiff2(rp, b1, bits, PIXEL(rp,b1));
+ if (b2 >= a1) {
+ /* Naive computation triggers -fsanitize=undefined,unsigned-integer-overflow */
+ /* although it is correct unless the difference between both is < 31 bit */
+ /* int32 d = b1 - a1; */
+ int32 d = (b1 >= a1 && b1 - a1 <= 3U) ? (int32)(b1 - a1):
+ (b1 < a1 && a1 - b1 <= 3U) ? -(int32)(a1 - b1) : 0x7FFFFFFF;
+ if (!(-3 <= d && d <= 3)) { /* horizontal mode */
+ a2 = finddiff2(bp, a1, bits, PIXEL(bp,a1));
+ putcode(tif, &horizcode);
+ if (a0+a1 == 0 || PIXEL(bp, a0) == 0) {
+ putspan(tif, a1-a0, TIFFFaxWhiteCodes);
+ putspan(tif, a2-a1, TIFFFaxBlackCodes);
+ } else {
+ putspan(tif, a1-a0, TIFFFaxBlackCodes);
+ putspan(tif, a2-a1, TIFFFaxWhiteCodes);
+ }
+ a0 = a2;
+ } else { /* vertical mode */
+ putcode(tif, &vcodes[d+3]);
+ a0 = a1;
+ }
+ } else { /* pass mode */
+ putcode(tif, &passcode);
+ a0 = b2;
+ }
+ if (a0 >= bits)
+ break;
+ a1 = finddiff(bp, a0, bits, PIXEL(bp,a0));
+ b1 = finddiff(rp, a0, bits, !PIXEL(bp,a0));
+ b1 = finddiff(rp, b1, bits, PIXEL(bp,a0));
+ }
+ return (1);
+#undef PIXEL
+}
+
+/*
+ * Encode a buffer of pixels.
+ */
+static int
+Fax3Encode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "Fax3Encode";
+ Fax3CodecState* sp = EncoderState(tif);
+ (void) s;
+ if (cc % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be written");
+ return (0);
+ }
+ while (cc > 0) {
+ if ((sp->b.mode & FAXMODE_NOEOL) == 0)
+ Fax3PutEOL(tif);
+ if (is2DEncoding(sp)) {
+ if (sp->tag == G3_1D) {
+ if (!Fax3Encode1DRow(tif, bp, sp->b.rowpixels))
+ return (0);
+ sp->tag = G3_2D;
+ } else {
+ if (!Fax3Encode2DRow(tif, bp, sp->refline,
+ sp->b.rowpixels))
+ return (0);
+ sp->k--;
+ }
+ if (sp->k == 0) {
+ sp->tag = G3_1D;
+ sp->k = sp->maxk-1;
+ } else
+ _TIFFmemcpy(sp->refline, bp, sp->b.rowbytes);
+ } else {
+ if (!Fax3Encode1DRow(tif, bp, sp->b.rowpixels))
+ return (0);
+ }
+ bp += sp->b.rowbytes;
+ cc -= sp->b.rowbytes;
+ }
+ return (1);
+}
+
+static int
+Fax3PostEncode(TIFF* tif)
+{
+ Fax3CodecState* sp = EncoderState(tif);
+
+ if (sp->bit != 8)
+ Fax3FlushBits(tif, sp);
+ return (1);
+}
+
+static void
+Fax3Close(TIFF* tif)
+{
+ if ((Fax3State(tif)->mode & FAXMODE_NORTC) == 0 && tif->tif_rawcp) {
+ Fax3CodecState* sp = EncoderState(tif);
+ unsigned int code = EOL;
+ unsigned int length = 12;
+ int i;
+
+ if (is2DEncoding(sp)) {
+ code = (code<<1) | (sp->tag == G3_1D);
+ length++;
+ }
+ for (i = 0; i < 6; i++)
+ Fax3PutBits(tif, code, length);
+ Fax3FlushBits(tif, sp);
+ }
+}
+
+static void
+Fax3Cleanup(TIFF* tif)
+{
+ Fax3CodecState* sp = DecoderState(tif);
+
+ assert(sp != 0);
+
+ tif->tif_tagmethods.vgetfield = sp->b.vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->b.vsetparent;
+ tif->tif_tagmethods.printdir = sp->b.printdir;
+
+ if (sp->runs)
+ _TIFFfree(sp->runs);
+ if (sp->refline)
+ _TIFFfree(sp->refline);
+
+ _TIFFfree(tif->tif_data);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+#define FIELD_BADFAXLINES (FIELD_CODEC+0)
+#define FIELD_CLEANFAXDATA (FIELD_CODEC+1)
+#define FIELD_BADFAXRUN (FIELD_CODEC+2)
+
+#define FIELD_OPTIONS (FIELD_CODEC+7)
+
+static const TIFFField faxFields[] = {
+ { TIFFTAG_FAXMODE, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "FaxMode", NULL },
+ { TIFFTAG_FAXFILLFUNC, 0, 0, TIFF_ANY, 0, TIFF_SETGET_OTHER, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "FaxFillFunc", NULL },
+ { TIFFTAG_BADFAXLINES, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_BADFAXLINES, TRUE, FALSE, "BadFaxLines", NULL },
+ { TIFFTAG_CLEANFAXDATA, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UINT16, FIELD_CLEANFAXDATA, TRUE, FALSE, "CleanFaxData", NULL },
+ { TIFFTAG_CONSECUTIVEBADFAXLINES, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_BADFAXRUN, TRUE, FALSE, "ConsecutiveBadFaxLines", NULL }};
+static const TIFFField fax3Fields[] = {
+ { TIFFTAG_GROUP3OPTIONS, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_OPTIONS, FALSE, FALSE, "Group3Options", NULL },
+};
+static const TIFFField fax4Fields[] = {
+ { TIFFTAG_GROUP4OPTIONS, 1, 1, TIFF_LONG, 0, TIFF_SETGET_UINT32, TIFF_SETGET_UINT32, FIELD_OPTIONS, FALSE, FALSE, "Group4Options", NULL },
+};
+
+static int
+Fax3VSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ Fax3BaseState* sp = Fax3State(tif);
+ const TIFFField* fip;
+
+ assert(sp != 0);
+ assert(sp->vsetparent != 0);
+
+ switch (tag) {
+ case TIFFTAG_FAXMODE:
+ sp->mode = (int) va_arg(ap, int);
+ return 1; /* NB: pseudo tag */
+ case TIFFTAG_FAXFILLFUNC:
+ DecoderState(tif)->fill = va_arg(ap, TIFFFaxFillFunc);
+ return 1; /* NB: pseudo tag */
+ case TIFFTAG_GROUP3OPTIONS:
+ /* XXX: avoid reading options if compression mismatches. */
+ if (tif->tif_dir.td_compression == COMPRESSION_CCITTFAX3)
+ sp->groupoptions = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_GROUP4OPTIONS:
+ /* XXX: avoid reading options if compression mismatches. */
+ if (tif->tif_dir.td_compression == COMPRESSION_CCITTFAX4)
+ sp->groupoptions = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_BADFAXLINES:
+ sp->badfaxlines = (uint32) va_arg(ap, uint32);
+ break;
+ case TIFFTAG_CLEANFAXDATA:
+ sp->cleanfaxdata = (uint16) va_arg(ap, uint16_vap);
+ break;
+ case TIFFTAG_CONSECUTIVEBADFAXLINES:
+ sp->badfaxrun = (uint32) va_arg(ap, uint32);
+ break;
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+
+ if ((fip = TIFFFieldWithTag(tif, tag)) != NULL)
+ TIFFSetFieldBit(tif, fip->field_bit);
+ else
+ return 0;
+
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+ return 1;
+}
+
+static int
+Fax3VGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ Fax3BaseState* sp = Fax3State(tif);
+
+ assert(sp != 0);
+
+ switch (tag) {
+ case TIFFTAG_FAXMODE:
+ *va_arg(ap, int*) = sp->mode;
+ break;
+ case TIFFTAG_FAXFILLFUNC:
+ *va_arg(ap, TIFFFaxFillFunc*) = DecoderState(tif)->fill;
+ break;
+ case TIFFTAG_GROUP3OPTIONS:
+ case TIFFTAG_GROUP4OPTIONS:
+ *va_arg(ap, uint32*) = sp->groupoptions;
+ break;
+ case TIFFTAG_BADFAXLINES:
+ *va_arg(ap, uint32*) = sp->badfaxlines;
+ break;
+ case TIFFTAG_CLEANFAXDATA:
+ *va_arg(ap, uint16*) = sp->cleanfaxdata;
+ break;
+ case TIFFTAG_CONSECUTIVEBADFAXLINES:
+ *va_arg(ap, uint32*) = sp->badfaxrun;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return (1);
+}
+
+static void
+Fax3PrintDir(TIFF* tif, FILE* fd, long flags)
+{
+ Fax3BaseState* sp = Fax3State(tif);
+
+ assert(sp != 0);
+
+ (void) flags;
+ if (TIFFFieldSet(tif,FIELD_OPTIONS)) {
+ const char* sep = " ";
+ if (tif->tif_dir.td_compression == COMPRESSION_CCITTFAX4) {
+ fprintf(fd, " Group 4 Options:");
+ if (sp->groupoptions & GROUP4OPT_UNCOMPRESSED)
+ fprintf(fd, "%suncompressed data", sep);
+ } else {
+
+ fprintf(fd, " Group 3 Options:");
+ if (sp->groupoptions & GROUP3OPT_2DENCODING) {
+ fprintf(fd, "%s2-d encoding", sep);
+ sep = "+";
+ }
+ if (sp->groupoptions & GROUP3OPT_FILLBITS) {
+ fprintf(fd, "%sEOL padding", sep);
+ sep = "+";
+ }
+ if (sp->groupoptions & GROUP3OPT_UNCOMPRESSED)
+ fprintf(fd, "%suncompressed data", sep);
+ }
+ fprintf(fd, " (%lu = 0x%lx)\n",
+ (unsigned long) sp->groupoptions,
+ (unsigned long) sp->groupoptions);
+ }
+ if (TIFFFieldSet(tif,FIELD_CLEANFAXDATA)) {
+ fprintf(fd, " Fax Data:");
+ switch (sp->cleanfaxdata) {
+ case CLEANFAXDATA_CLEAN:
+ fprintf(fd, " clean");
+ break;
+ case CLEANFAXDATA_REGENERATED:
+ fprintf(fd, " receiver regenerated");
+ break;
+ case CLEANFAXDATA_UNCLEAN:
+ fprintf(fd, " uncorrected errors");
+ break;
+ }
+ fprintf(fd, " (%u = 0x%x)\n",
+ sp->cleanfaxdata, sp->cleanfaxdata);
+ }
+ if (TIFFFieldSet(tif,FIELD_BADFAXLINES))
+ fprintf(fd, " Bad Fax Lines: %lu\n",
+ (unsigned long) sp->badfaxlines);
+ if (TIFFFieldSet(tif,FIELD_BADFAXRUN))
+ fprintf(fd, " Consecutive Bad Fax Lines: %lu\n",
+ (unsigned long) sp->badfaxrun);
+ if (sp->printdir)
+ (*sp->printdir)(tif, fd, flags);
+}
+
+static int
+InitCCITTFax3(TIFF* tif)
+{
+ static const char module[] = "InitCCITTFax3";
+ Fax3BaseState* sp;
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, faxFields, TIFFArrayCount(faxFields))) {
+ TIFFErrorExt(tif->tif_clientdata, "InitCCITTFax3",
+ "Merging common CCITT Fax codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*)
+ _TIFFmalloc(sizeof (Fax3CodecState));
+
+ if (tif->tif_data == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for state block");
+ return (0);
+ }
+ _TIFFmemset(tif->tif_data, 0, sizeof (Fax3CodecState));
+
+ sp = Fax3State(tif);
+ sp->rw_mode = tif->tif_mode;
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = Fax3VGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = Fax3VSetField; /* hook for codec tags */
+ sp->printdir = tif->tif_tagmethods.printdir;
+ tif->tif_tagmethods.printdir = Fax3PrintDir; /* hook for codec tags */
+ sp->groupoptions = 0;
+
+ if (sp->rw_mode == O_RDONLY) /* FIXME: improve for in place update */
+ tif->tif_flags |= TIFF_NOBITREV; /* decoder does bit reversal */
+ DecoderState(tif)->runs = NULL;
+ TIFFSetField(tif, TIFFTAG_FAXFILLFUNC, _TIFFFax3fillruns);
+ EncoderState(tif)->refline = NULL;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = Fax3FixupTags;
+ tif->tif_setupdecode = Fax3SetupState;
+ tif->tif_predecode = Fax3PreDecode;
+ tif->tif_decoderow = Fax3Decode1D;
+ tif->tif_decodestrip = Fax3Decode1D;
+ tif->tif_decodetile = Fax3Decode1D;
+ tif->tif_setupencode = Fax3SetupState;
+ tif->tif_preencode = Fax3PreEncode;
+ tif->tif_postencode = Fax3PostEncode;
+ tif->tif_encoderow = Fax3Encode;
+ tif->tif_encodestrip = Fax3Encode;
+ tif->tif_encodetile = Fax3Encode;
+ tif->tif_close = Fax3Close;
+ tif->tif_cleanup = Fax3Cleanup;
+
+ return (1);
+}
+
+int
+TIFFInitCCITTFax3(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ if (InitCCITTFax3(tif)) {
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, fax3Fields,
+ TIFFArrayCount(fax3Fields))) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFInitCCITTFax3",
+ "Merging CCITT Fax 3 codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * The default format is Class/F-style w/o RTC.
+ */
+ return TIFFSetField(tif, TIFFTAG_FAXMODE, FAXMODE_CLASSF);
+ } else
+ return 01;
+}
+
+/*
+ * CCITT Group 4 (T.6) Facsimile-compatible
+ * Compression Scheme Support.
+ */
+
+#define SWAP(t,a,b) { t x; x = (a); (a) = (b); (b) = x; }
+/*
+ * Decode the requested amount of G4-encoded data.
+ */
+static int
+Fax4Decode(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ DECLARE_STATE_2D(tif, sp, "Fax4Decode");
+ (void) s;
+ if (occ % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (-1);
+ }
+ CACHE_STATE(tif, sp);
+ while (occ > 0) {
+ a0 = 0;
+ RunLength = 0;
+ pa = thisrun = sp->curruns;
+ pb = sp->refruns;
+ b1 = *pb++;
+#ifdef FAX3_DEBUG
+ printf("\nBitAcc=%08X, BitsAvail = %d\n", BitAcc, BitsAvail);
+ printf("-------------------- %d\n", tif->tif_row);
+ fflush(stdout);
+#endif
+ EXPAND2D(EOFG4);
+ if (EOLcnt)
+ goto EOFG4;
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ SETVALUE(0); /* imaginary change for reference */
+ SWAP(uint32*, sp->curruns, sp->refruns);
+ buf += sp->b.rowbytes;
+ occ -= sp->b.rowbytes;
+ sp->line++;
+ continue;
+ EOFG4:
+ NeedBits16( 13, BADG4 );
+ BADG4:
+#ifdef FAX3_DEBUG
+ if( GetBits(13) != 0x1001 )
+ fputs( "Bad EOFB\n", stderr );
+#endif
+ ClrBits( 13 );
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ UNCACHE_STATE(tif, sp);
+ return ( sp->line ? 1 : -1); /* don't error on badly-terminated strips */
+ }
+ UNCACHE_STATE(tif, sp);
+ return (1);
+}
+#undef SWAP
+
+/*
+ * Encode the requested amount of data.
+ */
+static int
+Fax4Encode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "Fax4Encode";
+ Fax3CodecState *sp = EncoderState(tif);
+ (void) s;
+ if (cc % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be written");
+ return (0);
+ }
+ while (cc > 0) {
+ if (!Fax3Encode2DRow(tif, bp, sp->refline, sp->b.rowpixels))
+ return (0);
+ _TIFFmemcpy(sp->refline, bp, sp->b.rowbytes);
+ bp += sp->b.rowbytes;
+ cc -= sp->b.rowbytes;
+ }
+ return (1);
+}
+
+static int
+Fax4PostEncode(TIFF* tif)
+{
+ Fax3CodecState *sp = EncoderState(tif);
+
+ /* terminate strip w/ EOFB */
+ Fax3PutBits(tif, EOL, 12);
+ Fax3PutBits(tif, EOL, 12);
+ if (sp->bit != 8)
+ Fax3FlushBits(tif, sp);
+ return (1);
+}
+
+int
+TIFFInitCCITTFax4(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ if (InitCCITTFax3(tif)) { /* reuse G3 support */
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, fax4Fields,
+ TIFFArrayCount(fax4Fields))) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFInitCCITTFax4",
+ "Merging CCITT Fax 4 codec-specific tags failed");
+ return 0;
+ }
+
+ tif->tif_decoderow = Fax4Decode;
+ tif->tif_decodestrip = Fax4Decode;
+ tif->tif_decodetile = Fax4Decode;
+ tif->tif_encoderow = Fax4Encode;
+ tif->tif_encodestrip = Fax4Encode;
+ tif->tif_encodetile = Fax4Encode;
+ tif->tif_postencode = Fax4PostEncode;
+ /*
+ * Suppress RTC at the end of each strip.
+ */
+ return TIFFSetField(tif, TIFFTAG_FAXMODE, FAXMODE_NORTC);
+ } else
+ return (0);
+}
+
+/*
+ * CCITT Group 3 1-D Modified Huffman RLE Compression Support.
+ * (Compression algorithms 2 and 32771)
+ */
+
+/*
+ * Decode the requested amount of RLE-encoded data.
+ */
+static int
+Fax3DecodeRLE(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ DECLARE_STATE(tif, sp, "Fax3DecodeRLE");
+ int mode = sp->b.mode;
+ (void) s;
+ if (occ % sp->b.rowbytes)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (-1);
+ }
+ CACHE_STATE(tif, sp);
+ thisrun = sp->curruns;
+ while (occ > 0) {
+ a0 = 0;
+ RunLength = 0;
+ pa = thisrun;
+#ifdef FAX3_DEBUG
+ printf("\nBitAcc=%08X, BitsAvail = %d\n", BitAcc, BitsAvail);
+ printf("-------------------- %d\n", tif->tif_row);
+ fflush(stdout);
+#endif
+ EXPAND1D(EOFRLE);
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ /*
+ * Cleanup at the end of the row.
+ */
+ if (mode & FAXMODE_BYTEALIGN) {
+ int n = BitsAvail - (BitsAvail &~ 7);
+ ClrBits(n);
+ } else if (mode & FAXMODE_WORDALIGN) {
+ int n = BitsAvail - (BitsAvail &~ 15);
+ ClrBits(n);
+ if (BitsAvail == 0 && !isAligned(cp, uint16))
+ cp++;
+ }
+ buf += sp->b.rowbytes;
+ occ -= sp->b.rowbytes;
+ sp->line++;
+ continue;
+ EOFRLE: /* premature EOF */
+ (*sp->fill)(buf, thisrun, pa, lastx);
+ UNCACHE_STATE(tif, sp);
+ return (-1);
+ }
+ UNCACHE_STATE(tif, sp);
+ return (1);
+}
+
+int
+TIFFInitCCITTRLE(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ if (InitCCITTFax3(tif)) { /* reuse G3 support */
+ tif->tif_decoderow = Fax3DecodeRLE;
+ tif->tif_decodestrip = Fax3DecodeRLE;
+ tif->tif_decodetile = Fax3DecodeRLE;
+ /*
+ * Suppress RTC+EOLs when encoding and byte-align data.
+ */
+ return TIFFSetField(tif, TIFFTAG_FAXMODE,
+ FAXMODE_NORTC|FAXMODE_NOEOL|FAXMODE_BYTEALIGN);
+ } else
+ return (0);
+}
+
+int
+TIFFInitCCITTRLEW(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ if (InitCCITTFax3(tif)) { /* reuse G3 support */
+ tif->tif_decoderow = Fax3DecodeRLE;
+ tif->tif_decodestrip = Fax3DecodeRLE;
+ tif->tif_decodetile = Fax3DecodeRLE;
+ /*
+ * Suppress RTC+EOLs when encoding and word-align data.
+ */
+ return TIFFSetField(tif, TIFFTAG_FAXMODE,
+ FAXMODE_NORTC|FAXMODE_NOEOL|FAXMODE_WORDALIGN);
+ } else
+ return (0);
+}
+#endif /* CCITT_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_fax3.h b/test/monniaux/tiff-4.0.10/tif_fax3.h
new file mode 100644
index 00000000..abadcd97
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_fax3.h
@@ -0,0 +1,538 @@
+/*
+ * Copyright (c) 1990-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _FAX3_
+#define _FAX3_
+/*
+ * TIFF Library.
+ *
+ * CCITT Group 3 (T.4) and Group 4 (T.6) Decompression Support.
+ *
+ * Decoder support is derived, with permission, from the code
+ * in Frank Cringle's viewfax program;
+ * Copyright (C) 1990, 1995 Frank D. Cringle.
+ */
+#include "tiff.h"
+
+/*
+ * To override the default routine used to image decoded
+ * spans one can use the pseudo tag TIFFTAG_FAXFILLFUNC.
+ * The routine must have the type signature given below;
+ * for example:
+ *
+ * fillruns(unsigned char* buf, uint32* runs, uint32* erun, uint32 lastx)
+ *
+ * where buf is place to set the bits, runs is the array of b&w run
+ * lengths (white then black), erun is the last run in the array, and
+ * lastx is the width of the row in pixels. Fill routines can assume
+ * the run array has room for at least lastx runs and can overwrite
+ * data in the run array as needed (e.g. to append zero runs to bring
+ * the count up to a nice multiple).
+ */
+typedef void (*TIFFFaxFillFunc)(unsigned char*, uint32*, uint32*, uint32);
+
+/*
+ * The default run filler; made external for other decoders.
+ */
+#if defined(__cplusplus)
+extern "C" {
+#endif
+extern void _TIFFFax3fillruns(unsigned char*, uint32*, uint32*, uint32);
+#if defined(__cplusplus)
+}
+#endif
+
+
+/* finite state machine codes */
+#define S_Null 0
+#define S_Pass 1
+#define S_Horiz 2
+#define S_V0 3
+#define S_VR 4
+#define S_VL 5
+#define S_Ext 6
+#define S_TermW 7
+#define S_TermB 8
+#define S_MakeUpW 9
+#define S_MakeUpB 10
+#define S_MakeUp 11
+#define S_EOL 12
+
+/* WARNING: do not change the layout of this structure as the HylaFAX software */
+/* really depends on it. See http://bugzilla.maptools.org/show_bug.cgi?id=2636 */
+typedef struct { /* state table entry */
+ unsigned char State; /* see above */
+ unsigned char Width; /* width of code in bits */
+ uint32 Param; /* unsigned 32-bit run length in bits (holds on 16 bit actually, but cannot be changed. See above warning) */
+} TIFFFaxTabEnt;
+
+extern const TIFFFaxTabEnt TIFFFaxMainTable[];
+extern const TIFFFaxTabEnt TIFFFaxWhiteTable[];
+extern const TIFFFaxTabEnt TIFFFaxBlackTable[];
+
+/*
+ * The following macros define the majority of the G3/G4 decoder
+ * algorithm using the state tables defined elsewhere. To build
+ * a decoder you need some setup code and some glue code. Note
+ * that you may also need/want to change the way the NeedBits*
+ * macros get input data if, for example, you know the data to be
+ * decoded is properly aligned and oriented (doing so before running
+ * the decoder can be a big performance win).
+ *
+ * Consult the decoder in the TIFF library for an idea of what you
+ * need to define and setup to make use of these definitions.
+ *
+ * NB: to enable a debugging version of these macros define FAX3_DEBUG
+ * before including this file. Trace output goes to stdout.
+ */
+
+#ifndef EndOfData
+#define EndOfData() (cp >= ep)
+#endif
+/*
+ * Need <=8 or <=16 bits of input data. Unlike viewfax we
+ * cannot use/assume a word-aligned, properly bit swizzled
+ * input data set because data may come from an arbitrarily
+ * aligned, read-only source such as a memory-mapped file.
+ * Note also that the viewfax decoder does not check for
+ * running off the end of the input data buffer. This is
+ * possible for G3-encoded data because it prescans the input
+ * data to count EOL markers, but can cause problems for G4
+ * data. In any event, we don't prescan and must watch for
+ * running out of data since we can't permit the library to
+ * scan past the end of the input data buffer.
+ *
+ * Finally, note that we must handle remaindered data at the end
+ * of a strip specially. The coder asks for a fixed number of
+ * bits when scanning for the next code. This may be more bits
+ * than are actually present in the data stream. If we appear
+ * to run out of data but still have some number of valid bits
+ * remaining then we makeup the requested amount with zeros and
+ * return successfully. If the returned data is incorrect then
+ * we should be called again and get a premature EOF error;
+ * otherwise we should get the right answer.
+ */
+#ifndef NeedBits8
+#define NeedBits8(n,eoflab) do { \
+ if (BitsAvail < (n)) { \
+ if (EndOfData()) { \
+ if (BitsAvail == 0) /* no valid bits */ \
+ goto eoflab; \
+ BitsAvail = (n); /* pad with zeros */ \
+ } else { \
+ BitAcc |= ((uint32) bitmap[*cp++])<<BitsAvail; \
+ BitsAvail += 8; \
+ } \
+ } \
+} while (0)
+#endif
+#ifndef NeedBits16
+#define NeedBits16(n,eoflab) do { \
+ if (BitsAvail < (n)) { \
+ if (EndOfData()) { \
+ if (BitsAvail == 0) /* no valid bits */ \
+ goto eoflab; \
+ BitsAvail = (n); /* pad with zeros */ \
+ } else { \
+ BitAcc |= ((uint32) bitmap[*cp++])<<BitsAvail; \
+ if ((BitsAvail += 8) < (n)) { \
+ if (EndOfData()) { \
+ /* NB: we know BitsAvail is non-zero here */ \
+ BitsAvail = (n); /* pad with zeros */ \
+ } else { \
+ BitAcc |= ((uint32) bitmap[*cp++])<<BitsAvail; \
+ BitsAvail += 8; \
+ } \
+ } \
+ } \
+ } \
+} while (0)
+#endif
+#define GetBits(n) (BitAcc & ((1<<(n))-1))
+#define ClrBits(n) do { \
+ BitsAvail -= (n); \
+ BitAcc >>= (n); \
+} while (0)
+
+#ifdef FAX3_DEBUG
+static const char* StateNames[] = {
+ "Null ",
+ "Pass ",
+ "Horiz ",
+ "V0 ",
+ "VR ",
+ "VL ",
+ "Ext ",
+ "TermW ",
+ "TermB ",
+ "MakeUpW",
+ "MakeUpB",
+ "MakeUp ",
+ "EOL ",
+};
+#define DEBUG_SHOW putchar(BitAcc & (1 << t) ? '1' : '0')
+#define LOOKUP8(wid,tab,eoflab) do { \
+ int t; \
+ NeedBits8(wid,eoflab); \
+ TabEnt = tab + GetBits(wid); \
+ printf("%08lX/%d: %s%5d\t", (long) BitAcc, BitsAvail, \
+ StateNames[TabEnt->State], TabEnt->Param); \
+ for (t = 0; t < TabEnt->Width; t++) \
+ DEBUG_SHOW; \
+ putchar('\n'); \
+ fflush(stdout); \
+ ClrBits(TabEnt->Width); \
+} while (0)
+#define LOOKUP16(wid,tab,eoflab) do { \
+ int t; \
+ NeedBits16(wid,eoflab); \
+ TabEnt = tab + GetBits(wid); \
+ printf("%08lX/%d: %s%5d\t", (long) BitAcc, BitsAvail, \
+ StateNames[TabEnt->State], TabEnt->Param); \
+ for (t = 0; t < TabEnt->Width; t++) \
+ DEBUG_SHOW; \
+ putchar('\n'); \
+ fflush(stdout); \
+ ClrBits(TabEnt->Width); \
+} while (0)
+
+#define SETVALUE(x) do { \
+ *pa++ = RunLength + (x); \
+ printf("SETVALUE: %d\t%d\n", RunLength + (x), a0); \
+ a0 += x; \
+ RunLength = 0; \
+} while (0)
+#else
+#define LOOKUP8(wid,tab,eoflab) do { \
+ NeedBits8(wid,eoflab); \
+ TabEnt = tab + GetBits(wid); \
+ ClrBits(TabEnt->Width); \
+} while (0)
+#define LOOKUP16(wid,tab,eoflab) do { \
+ NeedBits16(wid,eoflab); \
+ TabEnt = tab + GetBits(wid); \
+ ClrBits(TabEnt->Width); \
+} while (0)
+
+/*
+ * Append a run to the run length array for the
+ * current row and reset decoding state.
+ */
+#define SETVALUE(x) do { \
+ *pa++ = RunLength + (x); \
+ a0 += (x); \
+ RunLength = 0; \
+} while (0)
+#endif
+
+/*
+ * Synchronize input decoding at the start of each
+ * row by scanning for an EOL (if appropriate) and
+ * skipping any trash data that might be present
+ * after a decoding error. Note that the decoding
+ * done elsewhere that recognizes an EOL only consumes
+ * 11 consecutive zero bits. This means that if EOLcnt
+ * is non-zero then we still need to scan for the final flag
+ * bit that is part of the EOL code.
+ */
+#define SYNC_EOL(eoflab) do { \
+ if (EOLcnt == 0) { \
+ for (;;) { \
+ NeedBits16(11,eoflab); \
+ if (GetBits(11) == 0) \
+ break; \
+ ClrBits(1); \
+ } \
+ } \
+ for (;;) { \
+ NeedBits8(8,eoflab); \
+ if (GetBits(8)) \
+ break; \
+ ClrBits(8); \
+ } \
+ while (GetBits(1) == 0) \
+ ClrBits(1); \
+ ClrBits(1); /* EOL bit */ \
+ EOLcnt = 0; /* reset EOL counter/flag */ \
+} while (0)
+
+/*
+ * Cleanup the array of runs after decoding a row.
+ * We adjust final runs to insure the user buffer is not
+ * overwritten and/or undecoded area is white filled.
+ */
+#define CLEANUP_RUNS() do { \
+ if (RunLength) \
+ SETVALUE(0); \
+ if (a0 != lastx) { \
+ badlength(a0, lastx); \
+ while (a0 > lastx && pa > thisrun) \
+ a0 -= *--pa; \
+ if (a0 < lastx) { \
+ if (a0 < 0) \
+ a0 = 0; \
+ if ((pa-thisrun)&1) \
+ SETVALUE(0); \
+ SETVALUE(lastx - a0); \
+ } else if (a0 > lastx) { \
+ SETVALUE(lastx); \
+ SETVALUE(0); \
+ } \
+ } \
+} while (0)
+
+/*
+ * Decode a line of 1D-encoded data.
+ *
+ * The line expanders are written as macros so that they can be reused
+ * but still have direct access to the local variables of the "calling"
+ * function.
+ *
+ * Note that unlike the original version we have to explicitly test for
+ * a0 >= lastx after each black/white run is decoded. This is because
+ * the original code depended on the input data being zero-padded to
+ * insure the decoder recognized an EOL before running out of data.
+ */
+#define EXPAND1D(eoflab) do { \
+ for (;;) { \
+ for (;;) { \
+ LOOKUP16(12, TIFFFaxWhiteTable, eof1d); \
+ switch (TabEnt->State) { \
+ case S_EOL: \
+ EOLcnt = 1; \
+ goto done1d; \
+ case S_TermW: \
+ SETVALUE(TabEnt->Param); \
+ goto doneWhite1d; \
+ case S_MakeUpW: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ unexpected("WhiteTable", a0); \
+ goto done1d; \
+ } \
+ } \
+ doneWhite1d: \
+ if (a0 >= lastx) \
+ goto done1d; \
+ for (;;) { \
+ LOOKUP16(13, TIFFFaxBlackTable, eof1d); \
+ switch (TabEnt->State) { \
+ case S_EOL: \
+ EOLcnt = 1; \
+ goto done1d; \
+ case S_TermB: \
+ SETVALUE(TabEnt->Param); \
+ goto doneBlack1d; \
+ case S_MakeUpB: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ unexpected("BlackTable", a0); \
+ goto done1d; \
+ } \
+ } \
+ doneBlack1d: \
+ if (a0 >= lastx) \
+ goto done1d; \
+ if( *(pa-1) == 0 && *(pa-2) == 0 ) \
+ pa -= 2; \
+ } \
+eof1d: \
+ prematureEOF(a0); \
+ CLEANUP_RUNS(); \
+ goto eoflab; \
+done1d: \
+ CLEANUP_RUNS(); \
+} while (0)
+
+/*
+ * Update the value of b1 using the array
+ * of runs for the reference line.
+ */
+#define CHECK_b1 do { \
+ if (pa != thisrun) while (b1 <= a0 && b1 < lastx) { \
+ b1 += pb[0] + pb[1]; \
+ pb += 2; \
+ } \
+} while (0)
+
+/*
+ * Expand a row of 2D-encoded data.
+ */
+#define EXPAND2D(eoflab) do { \
+ while (a0 < lastx) { \
+ LOOKUP8(7, TIFFFaxMainTable, eof2d); \
+ switch (TabEnt->State) { \
+ case S_Pass: \
+ CHECK_b1; \
+ b1 += *pb++; \
+ RunLength += b1 - a0; \
+ a0 = b1; \
+ b1 += *pb++; \
+ break; \
+ case S_Horiz: \
+ if ((pa-thisrun)&1) { \
+ for (;;) { /* black first */ \
+ LOOKUP16(13, TIFFFaxBlackTable, eof2d); \
+ switch (TabEnt->State) { \
+ case S_TermB: \
+ SETVALUE(TabEnt->Param); \
+ goto doneWhite2da; \
+ case S_MakeUpB: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ goto badBlack2d; \
+ } \
+ } \
+ doneWhite2da:; \
+ for (;;) { /* then white */ \
+ LOOKUP16(12, TIFFFaxWhiteTable, eof2d); \
+ switch (TabEnt->State) { \
+ case S_TermW: \
+ SETVALUE(TabEnt->Param); \
+ goto doneBlack2da; \
+ case S_MakeUpW: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ goto badWhite2d; \
+ } \
+ } \
+ doneBlack2da:; \
+ } else { \
+ for (;;) { /* white first */ \
+ LOOKUP16(12, TIFFFaxWhiteTable, eof2d); \
+ switch (TabEnt->State) { \
+ case S_TermW: \
+ SETVALUE(TabEnt->Param); \
+ goto doneWhite2db; \
+ case S_MakeUpW: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ goto badWhite2d; \
+ } \
+ } \
+ doneWhite2db:; \
+ for (;;) { /* then black */ \
+ LOOKUP16(13, TIFFFaxBlackTable, eof2d); \
+ switch (TabEnt->State) { \
+ case S_TermB: \
+ SETVALUE(TabEnt->Param); \
+ goto doneBlack2db; \
+ case S_MakeUpB: \
+ case S_MakeUp: \
+ a0 += TabEnt->Param; \
+ RunLength += TabEnt->Param; \
+ break; \
+ default: \
+ goto badBlack2d; \
+ } \
+ } \
+ doneBlack2db:; \
+ } \
+ CHECK_b1; \
+ break; \
+ case S_V0: \
+ CHECK_b1; \
+ SETVALUE(b1 - a0); \
+ b1 += *pb++; \
+ break; \
+ case S_VR: \
+ CHECK_b1; \
+ SETVALUE(b1 - a0 + TabEnt->Param); \
+ b1 += *pb++; \
+ break; \
+ case S_VL: \
+ CHECK_b1; \
+ if (b1 <= (int) (a0 + TabEnt->Param)) { \
+ if (b1 < (int) (a0 + TabEnt->Param) || pa != thisrun) { \
+ unexpected("VL", a0); \
+ goto eol2d; \
+ } \
+ } \
+ SETVALUE(b1 - a0 - TabEnt->Param); \
+ b1 -= *--pb; \
+ break; \
+ case S_Ext: \
+ *pa++ = lastx - a0; \
+ extension(a0); \
+ goto eol2d; \
+ case S_EOL: \
+ *pa++ = lastx - a0; \
+ NeedBits8(4,eof2d); \
+ if (GetBits(4)) \
+ unexpected("EOL", a0); \
+ ClrBits(4); \
+ EOLcnt = 1; \
+ goto eol2d; \
+ default: \
+ badMain2d: \
+ unexpected("MainTable", a0); \
+ goto eol2d; \
+ badBlack2d: \
+ unexpected("BlackTable", a0); \
+ goto eol2d; \
+ badWhite2d: \
+ unexpected("WhiteTable", a0); \
+ goto eol2d; \
+ eof2d: \
+ prematureEOF(a0); \
+ CLEANUP_RUNS(); \
+ goto eoflab; \
+ } \
+ } \
+ if (RunLength) { \
+ if (RunLength + a0 < lastx) { \
+ /* expect a final V0 */ \
+ NeedBits8(1,eof2d); \
+ if (!GetBits(1)) \
+ goto badMain2d; \
+ ClrBits(1); \
+ } \
+ SETVALUE(0); \
+ } \
+eol2d: \
+ CLEANUP_RUNS(); \
+} while (0)
+#endif /* _FAX3_ */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_fax3sm.c b/test/monniaux/tiff-4.0.10/tif_fax3sm.c
new file mode 100644
index 00000000..822191ec
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_fax3sm.c
@@ -0,0 +1,1260 @@
+/* WARNING, this file was automatically generated by the
+ mkg3states program */
+#include "tiff.h"
+#include "tif_fax3.h"
+ const TIFFFaxTabEnt TIFFFaxMainTable[128] = {
+{12,7,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{1,4,0},{3,1,0},
+{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{5,6,2},{3,1,0},{5,3,1},{3,1,0},
+{2,3,0},{3,1,0},{4,3,1},{3,1,0},{1,4,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},
+{4,3,1},{3,1,0},{5,7,3},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},
+{1,4,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{4,6,2},{3,1,0},
+{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{1,4,0},{3,1,0},{5,3,1},{3,1,0},
+{2,3,0},{3,1,0},{4,3,1},{3,1,0},{6,7,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},
+{4,3,1},{3,1,0},{1,4,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},
+{5,6,2},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{1,4,0},{3,1,0},
+{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},{4,7,3},{3,1,0},{5,3,1},{3,1,0},
+{2,3,0},{3,1,0},{4,3,1},{3,1,0},{1,4,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},
+{4,3,1},{3,1,0},{4,6,2},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0},
+{1,4,0},{3,1,0},{5,3,1},{3,1,0},{2,3,0},{3,1,0},{4,3,1},{3,1,0}
+};
+ const TIFFFaxTabEnt TIFFFaxWhiteTable[4096] = {
+{12,11,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},
+{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},
+{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,960},{7,4,6},{7,8,31},{7,5,8},
+{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,11,1792},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},
+{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},
+{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1600},{7,4,5},
+{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},
+{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},
+{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},
+{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},
+{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1536},{7,4,5},{7,8,43},{7,6,17},
+{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},
+{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},
+{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,768},{7,4,6},
+{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,11,1856},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,896},{7,4,6},{7,7,19},{7,5,8},
+{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},
+{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},{7,8,44},{7,6,17},{9,9,1408},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},
+{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},
+{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},
+{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},
+{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},
+{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,960},{7,4,6},
+{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},
+{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{11,12,2112},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,40},{7,6,16},{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},
+{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1600},{7,4,5},{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},
+{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},{7,8,32},{7,5,8},
+{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},
+{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},
+{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1536},{7,4,5},
+{7,8,43},{7,6,17},{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},
+{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,9,768},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,12,2368},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,896},{7,4,6},
+{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},
+{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},
+{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},{7,8,44},{7,6,17},
+{9,9,1408},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},
+{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},
+{7,8,42},{7,6,16},{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},
+{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},
+{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},
+{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},
+{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},
+{9,9,960},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},
+{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{11,12,1984},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},
+{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1600},{7,4,5},{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},
+{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},
+{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},
+{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},
+{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1536},{7,4,5},{7,8,43},{7,6,17},{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},
+{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},
+{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,9,768},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,11,1920},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},
+{9,9,896},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},
+{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},
+{7,8,44},{7,6,17},{9,9,1408},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},
+{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},
+{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},
+{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},
+{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1472},{7,4,5},{7,8,43},{7,6,17},
+{9,9,1216},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},
+{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},
+{7,8,41},{7,6,16},{9,9,960},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,704},{7,4,6},
+{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,12,2240},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,832},{7,4,6},{7,7,19},{7,5,8},
+{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},
+{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1600},{7,4,5},{7,8,44},{7,6,17},{9,9,1344},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},
+{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},
+{9,9,1088},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},
+{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},
+{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1536},{7,4,5},{7,8,43},{7,6,17},{9,9,1280},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},
+{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,1024},{7,4,6},
+{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,768},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},
+{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{11,12,2496},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,40},{7,6,16},{9,9,896},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},
+{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1728},{7,4,5},{7,8,44},{7,6,17},{9,9,1408},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},
+{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1152},{7,4,6},{7,8,32},{7,5,8},
+{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{12,11,0},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},
+{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},
+{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1472},{7,4,5},
+{7,8,43},{7,6,17},{9,9,1216},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},
+{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,960},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,9,704},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,11,1792},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,832},{7,4,6},
+{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},
+{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},
+{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1600},{7,4,5},{7,8,44},{7,6,17},
+{9,9,1344},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},
+{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},
+{7,8,42},{7,6,16},{9,9,1088},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},
+{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},
+{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},
+{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1536},{7,4,5},{7,8,43},{7,6,17},{9,9,1280},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},
+{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},
+{9,9,1024},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,768},{7,4,6},{7,8,37},{9,5,128},
+{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{11,11,1856},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,896},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},
+{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1728},{7,4,5},{7,8,44},{7,6,17},{9,9,1408},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},
+{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1152},{7,4,6},
+{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},
+{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},
+{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},
+{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,960},{7,4,6},{7,8,31},{7,5,8},
+{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,12,2176},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},
+{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},
+{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1600},{7,4,5},
+{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},
+{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},
+{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},
+{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},
+{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1536},{7,4,5},{7,8,43},{7,6,17},
+{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},
+{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},
+{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,768},{7,4,6},
+{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,12,2432},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,896},{7,4,6},{7,7,19},{7,5,8},
+{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},
+{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},{7,8,44},{7,6,17},{9,9,1408},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},
+{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},
+{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},
+{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},
+{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},
+{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,960},{7,4,6},
+{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},
+{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{11,12,2048},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,40},{7,6,16},{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},
+{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1600},{7,4,5},{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},
+{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},{7,8,32},{7,5,8},
+{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},
+{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},
+{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1536},{7,4,5},
+{7,8,43},{7,6,17},{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},
+{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,9,768},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,11,1920},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},
+{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,896},{7,4,6},
+{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},
+{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},
+{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},{7,8,44},{7,6,17},
+{9,9,1408},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},
+{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},
+{7,8,42},{7,6,16},{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},
+{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},
+{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},
+{7,8,55},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},
+{7,8,53},{7,5,9},{9,8,448},{7,4,6},{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1472},{7,4,5},{7,8,43},{7,6,17},{9,9,1216},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},
+{7,8,61},{7,4,4},{7,4,2},{7,4,7},{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},
+{9,9,960},{7,4,6},{7,8,31},{7,5,8},{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,9,704},{7,4,6},{7,8,37},{9,5,128},
+{7,7,25},{7,6,15},{9,8,320},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},
+{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{11,12,2304},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,7,20},{9,5,128},{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},
+{7,7,27},{7,4,5},{7,8,40},{7,6,16},{9,9,832},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},
+{9,8,512},{7,4,6},{7,8,36},{9,5,128},{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{9,9,1600},{7,4,5},{7,8,44},{7,6,17},{9,9,1344},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},
+{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},
+{7,4,2},{7,4,7},{7,8,48},{7,4,3},{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1088},{7,4,6},
+{7,8,32},{7,5,8},{7,8,58},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},
+{7,5,11},{7,4,5},{7,7,26},{7,5,9},{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},
+{9,8,384},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},
+{9,7,256},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{0,0,0},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},
+{7,7,24},{7,6,14},{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},
+{7,8,39},{7,6,16},{9,8,576},{7,4,6},{7,7,19},{7,5,8},{7,8,55},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,45},{7,4,3},{7,5,11},{7,4,5},{7,8,53},{7,5,9},{9,8,448},{7,4,6},
+{7,8,35},{9,5,128},{7,8,51},{7,6,15},{7,8,63},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},
+{9,9,1536},{7,4,5},{7,8,43},{7,6,17},{9,9,1280},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,8,29},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},
+{9,6,1664},{7,4,6},{7,8,33},{9,5,128},{7,8,49},{7,6,14},{7,8,61},{7,4,4},{7,4,2},{7,4,7},
+{7,8,47},{7,4,3},{7,8,59},{7,4,5},{7,8,41},{7,6,16},{9,9,1024},{7,4,6},{7,8,31},{7,5,8},
+{7,8,57},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},
+{7,7,26},{7,5,9},{9,9,768},{7,4,6},{7,8,37},{9,5,128},{7,7,25},{7,6,15},{9,8,320},{7,4,4},
+{7,4,2},{7,4,7},{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},
+{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},{11,12,2560},{7,4,3},
+{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},{7,7,20},{9,5,128},{7,7,24},{7,6,14},
+{7,7,28},{7,4,4},{7,4,2},{7,4,7},{7,7,23},{7,4,3},{7,7,27},{7,4,5},{7,8,40},{7,6,16},
+{9,9,896},{7,4,6},{7,7,19},{7,5,8},{7,8,56},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7},
+{7,8,46},{7,4,3},{7,5,11},{7,4,5},{7,8,54},{7,5,9},{9,8,512},{7,4,6},{7,8,36},{9,5,128},
+{7,8,52},{7,6,15},{7,8,0},{7,4,4},{7,4,2},{7,4,7},{7,6,13},{7,4,3},{9,9,1728},{7,4,5},
+{7,8,44},{7,6,17},{9,9,1408},{7,4,6},{7,6,1},{7,5,8},{9,6,192},{9,5,64},{7,5,10},{7,4,4},
+{7,4,2},{7,4,7},{7,8,30},{7,4,3},{7,5,11},{7,4,5},{7,6,12},{7,5,9},{9,6,1664},{7,4,6},
+{7,8,34},{9,5,128},{7,8,50},{7,6,14},{7,8,62},{7,4,4},{7,4,2},{7,4,7},{7,8,48},{7,4,3},
+{7,8,60},{7,4,5},{7,8,42},{7,6,16},{9,9,1152},{7,4,6},{7,8,32},{7,5,8},{7,8,58},{9,5,64},
+{7,5,10},{7,4,4},{7,4,2},{7,4,7},{7,7,22},{7,4,3},{7,5,11},{7,4,5},{7,7,26},{7,5,9},
+{9,8,640},{7,4,6},{7,8,38},{9,5,128},{7,7,25},{7,6,15},{9,8,384},{7,4,4},{7,4,2},{7,4,7},
+{7,6,13},{7,4,3},{7,7,18},{7,4,5},{7,7,21},{7,6,17},{9,7,256},{7,4,6},{7,6,1},{7,5,8},
+{9,6,192},{9,5,64},{7,5,10},{7,4,4},{7,4,2},{7,4,7}
+};
+ const TIFFFaxTabEnt TIFFFaxBlackTable[8192] = {
+{12,11,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,18},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,17},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1792},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,23},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,20},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,11,25},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,128},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,56},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,30},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1856},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,57},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,11,21},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,54},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,52},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,48},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,12,2112},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,44},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,36},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,384},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,28},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,60},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,40},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2368},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,16},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,10,64},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,18},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,10,17},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,12,1984},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,50},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,34},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1664},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,26},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1408},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,32},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1920},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,61},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,42},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,13,1024},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,13,768},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,62},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2240},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,46},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,38},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,512},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,19},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,24},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,22},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,12,2496},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,16},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,10,64},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{12,11,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,18},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,17},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1792},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,23},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,20},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,25},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,12,192},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1280},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,31},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,11,1856},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,58},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,21},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,896},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,640},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,49},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2176},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,45},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,37},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,12,448},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,29},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,13,1536},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,41},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2432},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,16},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,10,64},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,18},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,17},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,12,2048},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,51},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,35},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,320},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,27},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,59},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,33},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1920},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,256},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,43},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,13,1152},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,55},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,63},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,12,2304},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,47},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,39},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,53},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,19},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,24},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,22},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2560},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,10,16},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,10,64},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{12,11,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,10,18},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,17},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1792},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,23},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,11,20},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,25},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,12,128},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,56},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,30},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,11,1856},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,57},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,21},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,54},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,52},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,48},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2112},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,44},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,36},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,12,384},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,28},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,60},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,40},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,12,2368},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,16},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,10,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,10,64},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,18},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,17},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,1984},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,50},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,34},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,13,1728},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,26},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,13,1472},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,32},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1920},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,61},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,42},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1088},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,832},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,62},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,12,2240},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,46},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,38},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,576},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,19},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,11,24},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,22},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2496},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,16},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,10,64},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{12,11,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,18},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,10,17},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,11,1792},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,23},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,20},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,25},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,192},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1344},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,31},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,11,1856},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,58},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,21},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{10,13,960},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,13,704},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,49},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2176},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,45},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,37},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,448},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,29},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1600},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,41},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{11,12,2432},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,16},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,10,64},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,18},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,17},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2048},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,51},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,35},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{10,12,320},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,27},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,59},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,33},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{11,11,1920},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,12,256},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,43},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,13,1216},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{0,0,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,8,13},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,9,15},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,55},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,63},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2304},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,12,47},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,12,39},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,12,53},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,12},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{0,0,0},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,8,13},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,11,19},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,11,24},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,11,22},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{11,12,2560},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,7,10},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,10,16},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2},{8,10,0},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},
+{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{10,10,64},{8,2,3},
+{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,9},{8,2,3},{8,3,1},{8,2,2},
+{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,11},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},
+{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},
+{8,8,14},{8,2,3},{8,3,1},{8,2,2},{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,6,8},{8,2,3},
+{8,3,1},{8,2,2},{8,4,5},{8,2,3},{8,3,4},{8,2,2},{8,7,12},{8,2,3},{8,3,1},{8,2,2},
+{8,4,6},{8,2,3},{8,3,4},{8,2,2},{8,5,7},{8,2,3},{8,3,1},{8,2,2},{8,4,5},{8,2,3},
+{8,3,4},{8,2,2}
+};
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_flush.c b/test/monniaux/tiff-4.0.10/tif_flush.c
new file mode 100644
index 00000000..881fac51
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_flush.c
@@ -0,0 +1,116 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ */
+#include "tiffiop.h"
+
+int
+TIFFFlush(TIFF* tif)
+{
+ if( tif->tif_mode == O_RDONLY )
+ return 1;
+
+ if (!TIFFFlushData(tif))
+ return (0);
+
+ /* In update (r+) mode we try to detect the case where
+ only the strip/tile map has been altered, and we try to
+ rewrite only that portion of the directory without
+ making any other changes */
+
+ if( (tif->tif_flags & TIFF_DIRTYSTRIP)
+ && !(tif->tif_flags & TIFF_DIRTYDIRECT)
+ && tif->tif_mode == O_RDWR )
+ {
+ uint64 *offsets=NULL, *sizes=NULL;
+
+ if( TIFFIsTiled(tif) )
+ {
+ if( TIFFGetField( tif, TIFFTAG_TILEOFFSETS, &offsets )
+ && TIFFGetField( tif, TIFFTAG_TILEBYTECOUNTS, &sizes )
+ && _TIFFRewriteField( tif, TIFFTAG_TILEOFFSETS, TIFF_LONG8,
+ tif->tif_dir.td_nstrips, offsets )
+ && _TIFFRewriteField( tif, TIFFTAG_TILEBYTECOUNTS, TIFF_LONG8,
+ tif->tif_dir.td_nstrips, sizes ) )
+ {
+ tif->tif_flags &= ~TIFF_DIRTYSTRIP;
+ tif->tif_flags &= ~TIFF_BEENWRITING;
+ return 1;
+ }
+ }
+ else
+ {
+ if( TIFFGetField( tif, TIFFTAG_STRIPOFFSETS, &offsets )
+ && TIFFGetField( tif, TIFFTAG_STRIPBYTECOUNTS, &sizes )
+ && _TIFFRewriteField( tif, TIFFTAG_STRIPOFFSETS, TIFF_LONG8,
+ tif->tif_dir.td_nstrips, offsets )
+ && _TIFFRewriteField( tif, TIFFTAG_STRIPBYTECOUNTS, TIFF_LONG8,
+ tif->tif_dir.td_nstrips, sizes ) )
+ {
+ tif->tif_flags &= ~TIFF_DIRTYSTRIP;
+ tif->tif_flags &= ~TIFF_BEENWRITING;
+ return 1;
+ }
+ }
+ }
+
+ if ((tif->tif_flags & (TIFF_DIRTYDIRECT|TIFF_DIRTYSTRIP))
+ && !TIFFRewriteDirectory(tif))
+ return (0);
+
+ return (1);
+}
+
+/*
+ * Flush buffered data to the file.
+ *
+ * Frank Warmerdam'2000: I modified this to return 1 if TIFF_BEENWRITING
+ * is not set, so that TIFFFlush() will proceed to write out the directory.
+ * The documentation says returning 1 is an error indicator, but not having
+ * been writing isn't exactly a an error. Hopefully this doesn't cause
+ * problems for other people.
+ */
+int
+TIFFFlushData(TIFF* tif)
+{
+ if ((tif->tif_flags & TIFF_BEENWRITING) == 0)
+ return (1);
+ if (tif->tif_flags & TIFF_POSTENCODE) {
+ tif->tif_flags &= ~TIFF_POSTENCODE;
+ if (!(*tif->tif_postencode)(tif))
+ return (0);
+ }
+ return (TIFFFlushData1(tif));
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_getimage.c b/test/monniaux/tiff-4.0.10/tif_getimage.c
new file mode 100644
index 00000000..6a9d5a7c
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_getimage.c
@@ -0,0 +1,3046 @@
+/*
+ * Copyright (c) 1991-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library
+ *
+ * Read and return a packed RGBA image.
+ */
+#include "tiffiop.h"
+#include <stdio.h>
+
+static int gtTileContig(TIFFRGBAImage*, uint32*, uint32, uint32);
+static int gtTileSeparate(TIFFRGBAImage*, uint32*, uint32, uint32);
+static int gtStripContig(TIFFRGBAImage*, uint32*, uint32, uint32);
+static int gtStripSeparate(TIFFRGBAImage*, uint32*, uint32, uint32);
+static int PickContigCase(TIFFRGBAImage*);
+static int PickSeparateCase(TIFFRGBAImage*);
+
+static int BuildMapUaToAa(TIFFRGBAImage* img);
+static int BuildMapBitdepth16To8(TIFFRGBAImage* img);
+
+static const char photoTag[] = "PhotometricInterpretation";
+
+/*
+ * Helper constants used in Orientation tag handling
+ */
+#define FLIP_VERTICALLY 0x01
+#define FLIP_HORIZONTALLY 0x02
+
+/*
+ * Color conversion constants. We will define display types here.
+ */
+
+static const TIFFDisplay display_sRGB = {
+ { /* XYZ -> luminance matrix */
+ { 3.2410F, -1.5374F, -0.4986F },
+ { -0.9692F, 1.8760F, 0.0416F },
+ { 0.0556F, -0.2040F, 1.0570F }
+ },
+ 100.0F, 100.0F, 100.0F, /* Light o/p for reference white */
+ 255, 255, 255, /* Pixel values for ref. white */
+ 1.0F, 1.0F, 1.0F, /* Residual light o/p for black pixel */
+ 2.4F, 2.4F, 2.4F, /* Gamma values for the three guns */
+};
+
+/*
+ * Check the image to see if TIFFReadRGBAImage can deal with it.
+ * 1/0 is returned according to whether or not the image can
+ * be handled. If 0 is returned, emsg contains the reason
+ * why it is being rejected.
+ */
+int
+TIFFRGBAImageOK(TIFF* tif, char emsg[1024])
+{
+ TIFFDirectory* td = &tif->tif_dir;
+ uint16 photometric;
+ int colorchannels;
+
+ if (!tif->tif_decodestatus) {
+ sprintf(emsg, "Sorry, requested compression method is not configured");
+ return (0);
+ }
+ switch (td->td_bitspersample) {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ break;
+ default:
+ sprintf(emsg, "Sorry, can not handle images with %d-bit samples",
+ td->td_bitspersample);
+ return (0);
+ }
+ if (td->td_sampleformat == SAMPLEFORMAT_IEEEFP) {
+ sprintf(emsg, "Sorry, can not handle images with IEEE floating-point samples");
+ return (0);
+ }
+ colorchannels = td->td_samplesperpixel - td->td_extrasamples;
+ if (!TIFFGetField(tif, TIFFTAG_PHOTOMETRIC, &photometric)) {
+ switch (colorchannels) {
+ case 1:
+ photometric = PHOTOMETRIC_MINISBLACK;
+ break;
+ case 3:
+ photometric = PHOTOMETRIC_RGB;
+ break;
+ default:
+ sprintf(emsg, "Missing needed %s tag", photoTag);
+ return (0);
+ }
+ }
+ switch (photometric) {
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ case PHOTOMETRIC_PALETTE:
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG
+ && td->td_samplesperpixel != 1
+ && td->td_bitspersample < 8 ) {
+ sprintf(emsg,
+ "Sorry, can not handle contiguous data with %s=%d, "
+ "and %s=%d and Bits/Sample=%d",
+ photoTag, photometric,
+ "Samples/pixel", td->td_samplesperpixel,
+ td->td_bitspersample);
+ return (0);
+ }
+ /*
+ * We should likely validate that any extra samples are either
+ * to be ignored, or are alpha, and if alpha we should try to use
+ * them. But for now we won't bother with this.
+ */
+ break;
+ case PHOTOMETRIC_YCBCR:
+ /*
+ * TODO: if at all meaningful and useful, make more complete
+ * support check here, or better still, refactor to let supporting
+ * code decide whether there is support and what meaningful
+ * error to return
+ */
+ break;
+ case PHOTOMETRIC_RGB:
+ if (colorchannels < 3) {
+ sprintf(emsg, "Sorry, can not handle RGB image with %s=%d",
+ "Color channels", colorchannels);
+ return (0);
+ }
+ break;
+ case PHOTOMETRIC_SEPARATED:
+ {
+ uint16 inkset;
+ TIFFGetFieldDefaulted(tif, TIFFTAG_INKSET, &inkset);
+ if (inkset != INKSET_CMYK) {
+ sprintf(emsg,
+ "Sorry, can not handle separated image with %s=%d",
+ "InkSet", inkset);
+ return 0;
+ }
+ if (td->td_samplesperpixel < 4) {
+ sprintf(emsg,
+ "Sorry, can not handle separated image with %s=%d",
+ "Samples/pixel", td->td_samplesperpixel);
+ return 0;
+ }
+ break;
+ }
+ case PHOTOMETRIC_LOGL:
+ if (td->td_compression != COMPRESSION_SGILOG) {
+ sprintf(emsg, "Sorry, LogL data must have %s=%d",
+ "Compression", COMPRESSION_SGILOG);
+ return (0);
+ }
+ break;
+ case PHOTOMETRIC_LOGLUV:
+ if (td->td_compression != COMPRESSION_SGILOG &&
+ td->td_compression != COMPRESSION_SGILOG24) {
+ sprintf(emsg, "Sorry, LogLuv data must have %s=%d or %d",
+ "Compression", COMPRESSION_SGILOG, COMPRESSION_SGILOG24);
+ return (0);
+ }
+ if (td->td_planarconfig != PLANARCONFIG_CONTIG) {
+ sprintf(emsg, "Sorry, can not handle LogLuv images with %s=%d",
+ "Planarconfiguration", td->td_planarconfig);
+ return (0);
+ }
+ if ( td->td_samplesperpixel != 3 || colorchannels != 3 ) {
+ sprintf(emsg,
+ "Sorry, can not handle image with %s=%d, %s=%d",
+ "Samples/pixel", td->td_samplesperpixel,
+ "colorchannels", colorchannels);
+ return 0;
+ }
+ break;
+ case PHOTOMETRIC_CIELAB:
+ if ( td->td_samplesperpixel != 3 || colorchannels != 3 || td->td_bitspersample != 8 ) {
+ sprintf(emsg,
+ "Sorry, can not handle image with %s=%d, %s=%d and %s=%d",
+ "Samples/pixel", td->td_samplesperpixel,
+ "colorchannels", colorchannels,
+ "Bits/sample", td->td_bitspersample);
+ return 0;
+ }
+ break;
+ default:
+ sprintf(emsg, "Sorry, can not handle image with %s=%d",
+ photoTag, photometric);
+ return (0);
+ }
+ return (1);
+}
+
+void
+TIFFRGBAImageEnd(TIFFRGBAImage* img)
+{
+ if (img->Map) {
+ _TIFFfree(img->Map);
+ img->Map = NULL;
+ }
+ if (img->BWmap) {
+ _TIFFfree(img->BWmap);
+ img->BWmap = NULL;
+ }
+ if (img->PALmap) {
+ _TIFFfree(img->PALmap);
+ img->PALmap = NULL;
+ }
+ if (img->ycbcr) {
+ _TIFFfree(img->ycbcr);
+ img->ycbcr = NULL;
+ }
+ if (img->cielab) {
+ _TIFFfree(img->cielab);
+ img->cielab = NULL;
+ }
+ if (img->UaToAa) {
+ _TIFFfree(img->UaToAa);
+ img->UaToAa = NULL;
+ }
+ if (img->Bitdepth16To8) {
+ _TIFFfree(img->Bitdepth16To8);
+ img->Bitdepth16To8 = NULL;
+ }
+
+ if( img->redcmap ) {
+ _TIFFfree( img->redcmap );
+ _TIFFfree( img->greencmap );
+ _TIFFfree( img->bluecmap );
+ img->redcmap = img->greencmap = img->bluecmap = NULL;
+ }
+}
+
+static int
+isCCITTCompression(TIFF* tif)
+{
+ uint16 compress;
+ TIFFGetField(tif, TIFFTAG_COMPRESSION, &compress);
+ return (compress == COMPRESSION_CCITTFAX3 ||
+ compress == COMPRESSION_CCITTFAX4 ||
+ compress == COMPRESSION_CCITTRLE ||
+ compress == COMPRESSION_CCITTRLEW);
+}
+
+int
+TIFFRGBAImageBegin(TIFFRGBAImage* img, TIFF* tif, int stop, char emsg[1024])
+{
+ uint16* sampleinfo;
+ uint16 extrasamples;
+ uint16 planarconfig;
+ uint16 compress;
+ int colorchannels;
+ uint16 *red_orig, *green_orig, *blue_orig;
+ int n_color;
+
+ if( !TIFFRGBAImageOK(tif, emsg) )
+ return 0;
+
+ /* Initialize to normal values */
+ img->row_offset = 0;
+ img->col_offset = 0;
+ img->redcmap = NULL;
+ img->greencmap = NULL;
+ img->bluecmap = NULL;
+ img->Map = NULL;
+ img->BWmap = NULL;
+ img->PALmap = NULL;
+ img->ycbcr = NULL;
+ img->cielab = NULL;
+ img->UaToAa = NULL;
+ img->Bitdepth16To8 = NULL;
+ img->req_orientation = ORIENTATION_BOTLEFT; /* It is the default */
+
+ img->tif = tif;
+ img->stoponerr = stop;
+ TIFFGetFieldDefaulted(tif, TIFFTAG_BITSPERSAMPLE, &img->bitspersample);
+ switch (img->bitspersample) {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ break;
+ default:
+ sprintf(emsg, "Sorry, can not handle images with %d-bit samples",
+ img->bitspersample);
+ goto fail_return;
+ }
+ img->alpha = 0;
+ TIFFGetFieldDefaulted(tif, TIFFTAG_SAMPLESPERPIXEL, &img->samplesperpixel);
+ TIFFGetFieldDefaulted(tif, TIFFTAG_EXTRASAMPLES,
+ &extrasamples, &sampleinfo);
+ if (extrasamples >= 1)
+ {
+ switch (sampleinfo[0]) {
+ case EXTRASAMPLE_UNSPECIFIED: /* Workaround for some images without */
+ if (img->samplesperpixel > 3) /* correct info about alpha channel */
+ img->alpha = EXTRASAMPLE_ASSOCALPHA;
+ break;
+ case EXTRASAMPLE_ASSOCALPHA: /* data is pre-multiplied */
+ case EXTRASAMPLE_UNASSALPHA: /* data is not pre-multiplied */
+ img->alpha = sampleinfo[0];
+ break;
+ }
+ }
+
+#ifdef DEFAULT_EXTRASAMPLE_AS_ALPHA
+ if( !TIFFGetField(tif, TIFFTAG_PHOTOMETRIC, &img->photometric))
+ img->photometric = PHOTOMETRIC_MINISWHITE;
+
+ if( extrasamples == 0
+ && img->samplesperpixel == 4
+ && img->photometric == PHOTOMETRIC_RGB )
+ {
+ img->alpha = EXTRASAMPLE_ASSOCALPHA;
+ extrasamples = 1;
+ }
+#endif
+
+ colorchannels = img->samplesperpixel - extrasamples;
+ TIFFGetFieldDefaulted(tif, TIFFTAG_COMPRESSION, &compress);
+ TIFFGetFieldDefaulted(tif, TIFFTAG_PLANARCONFIG, &planarconfig);
+ if (!TIFFGetField(tif, TIFFTAG_PHOTOMETRIC, &img->photometric)) {
+ switch (colorchannels) {
+ case 1:
+ if (isCCITTCompression(tif))
+ img->photometric = PHOTOMETRIC_MINISWHITE;
+ else
+ img->photometric = PHOTOMETRIC_MINISBLACK;
+ break;
+ case 3:
+ img->photometric = PHOTOMETRIC_RGB;
+ break;
+ default:
+ sprintf(emsg, "Missing needed %s tag", photoTag);
+ goto fail_return;
+ }
+ }
+ switch (img->photometric) {
+ case PHOTOMETRIC_PALETTE:
+ if (!TIFFGetField(tif, TIFFTAG_COLORMAP,
+ &red_orig, &green_orig, &blue_orig)) {
+ sprintf(emsg, "Missing required \"Colormap\" tag");
+ goto fail_return;
+ }
+
+ /* copy the colormaps so we can modify them */
+ n_color = (1U << img->bitspersample);
+ img->redcmap = (uint16 *) _TIFFmalloc(sizeof(uint16)*n_color);
+ img->greencmap = (uint16 *) _TIFFmalloc(sizeof(uint16)*n_color);
+ img->bluecmap = (uint16 *) _TIFFmalloc(sizeof(uint16)*n_color);
+ if( !img->redcmap || !img->greencmap || !img->bluecmap ) {
+ sprintf(emsg, "Out of memory for colormap copy");
+ goto fail_return;
+ }
+
+ _TIFFmemcpy( img->redcmap, red_orig, n_color * 2 );
+ _TIFFmemcpy( img->greencmap, green_orig, n_color * 2 );
+ _TIFFmemcpy( img->bluecmap, blue_orig, n_color * 2 );
+
+ /* fall through... */
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ if (planarconfig == PLANARCONFIG_CONTIG
+ && img->samplesperpixel != 1
+ && img->bitspersample < 8 ) {
+ sprintf(emsg,
+ "Sorry, can not handle contiguous data with %s=%d, "
+ "and %s=%d and Bits/Sample=%d",
+ photoTag, img->photometric,
+ "Samples/pixel", img->samplesperpixel,
+ img->bitspersample);
+ goto fail_return;
+ }
+ break;
+ case PHOTOMETRIC_YCBCR:
+ /* It would probably be nice to have a reality check here. */
+ if (planarconfig == PLANARCONFIG_CONTIG)
+ /* can rely on libjpeg to convert to RGB */
+ /* XXX should restore current state on exit */
+ switch (compress) {
+ case COMPRESSION_JPEG:
+ /*
+ * TODO: when complete tests verify complete desubsampling
+ * and YCbCr handling, remove use of TIFFTAG_JPEGCOLORMODE in
+ * favor of tif_getimage.c native handling
+ */
+ TIFFSetField(tif, TIFFTAG_JPEGCOLORMODE, JPEGCOLORMODE_RGB);
+ img->photometric = PHOTOMETRIC_RGB;
+ break;
+ default:
+ /* do nothing */;
+ break;
+ }
+ /*
+ * TODO: if at all meaningful and useful, make more complete
+ * support check here, or better still, refactor to let supporting
+ * code decide whether there is support and what meaningful
+ * error to return
+ */
+ break;
+ case PHOTOMETRIC_RGB:
+ if (colorchannels < 3) {
+ sprintf(emsg, "Sorry, can not handle RGB image with %s=%d",
+ "Color channels", colorchannels);
+ goto fail_return;
+ }
+ break;
+ case PHOTOMETRIC_SEPARATED:
+ {
+ uint16 inkset;
+ TIFFGetFieldDefaulted(tif, TIFFTAG_INKSET, &inkset);
+ if (inkset != INKSET_CMYK) {
+ sprintf(emsg, "Sorry, can not handle separated image with %s=%d",
+ "InkSet", inkset);
+ goto fail_return;
+ }
+ if (img->samplesperpixel < 4) {
+ sprintf(emsg, "Sorry, can not handle separated image with %s=%d",
+ "Samples/pixel", img->samplesperpixel);
+ goto fail_return;
+ }
+ }
+ break;
+ case PHOTOMETRIC_LOGL:
+ if (compress != COMPRESSION_SGILOG) {
+ sprintf(emsg, "Sorry, LogL data must have %s=%d",
+ "Compression", COMPRESSION_SGILOG);
+ goto fail_return;
+ }
+ TIFFSetField(tif, TIFFTAG_SGILOGDATAFMT, SGILOGDATAFMT_8BIT);
+ img->photometric = PHOTOMETRIC_MINISBLACK; /* little white lie */
+ img->bitspersample = 8;
+ break;
+ case PHOTOMETRIC_LOGLUV:
+ if (compress != COMPRESSION_SGILOG && compress != COMPRESSION_SGILOG24) {
+ sprintf(emsg, "Sorry, LogLuv data must have %s=%d or %d",
+ "Compression", COMPRESSION_SGILOG, COMPRESSION_SGILOG24);
+ goto fail_return;
+ }
+ if (planarconfig != PLANARCONFIG_CONTIG) {
+ sprintf(emsg, "Sorry, can not handle LogLuv images with %s=%d",
+ "Planarconfiguration", planarconfig);
+ return (0);
+ }
+ TIFFSetField(tif, TIFFTAG_SGILOGDATAFMT, SGILOGDATAFMT_8BIT);
+ img->photometric = PHOTOMETRIC_RGB; /* little white lie */
+ img->bitspersample = 8;
+ break;
+ case PHOTOMETRIC_CIELAB:
+ break;
+ default:
+ sprintf(emsg, "Sorry, can not handle image with %s=%d",
+ photoTag, img->photometric);
+ goto fail_return;
+ }
+ TIFFGetField(tif, TIFFTAG_IMAGEWIDTH, &img->width);
+ TIFFGetField(tif, TIFFTAG_IMAGELENGTH, &img->height);
+ TIFFGetFieldDefaulted(tif, TIFFTAG_ORIENTATION, &img->orientation);
+ img->isContig =
+ !(planarconfig == PLANARCONFIG_SEPARATE && img->samplesperpixel > 1);
+ if (img->isContig) {
+ if (!PickContigCase(img)) {
+ sprintf(emsg, "Sorry, can not handle image");
+ goto fail_return;
+ }
+ } else {
+ if (!PickSeparateCase(img)) {
+ sprintf(emsg, "Sorry, can not handle image");
+ goto fail_return;
+ }
+ }
+ return 1;
+
+ fail_return:
+ TIFFRGBAImageEnd( img );
+ return 0;
+}
+
+int
+TIFFRGBAImageGet(TIFFRGBAImage* img, uint32* raster, uint32 w, uint32 h)
+{
+ if (img->get == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, TIFFFileName(img->tif), "No \"get\" routine setup");
+ return (0);
+ }
+ if (img->put.any == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, TIFFFileName(img->tif),
+ "No \"put\" routine setupl; probably can not handle image format");
+ return (0);
+ }
+ return (*img->get)(img, raster, w, h);
+}
+
+/*
+ * Read the specified image into an ABGR-format rastertaking in account
+ * specified orientation.
+ */
+int
+TIFFReadRGBAImageOriented(TIFF* tif,
+ uint32 rwidth, uint32 rheight, uint32* raster,
+ int orientation, int stop)
+{
+ char emsg[1024] = "";
+ TIFFRGBAImage img;
+ int ok;
+
+ if (TIFFRGBAImageOK(tif, emsg) && TIFFRGBAImageBegin(&img, tif, stop, emsg)) {
+ img.req_orientation = (uint16)orientation;
+ /* XXX verify rwidth and rheight against width and height */
+ ok = TIFFRGBAImageGet(&img, raster+(rheight-img.height)*rwidth,
+ rwidth, img.height);
+ TIFFRGBAImageEnd(&img);
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "%s", emsg);
+ ok = 0;
+ }
+ return (ok);
+}
+
+/*
+ * Read the specified image into an ABGR-format raster. Use bottom left
+ * origin for raster by default.
+ */
+int
+TIFFReadRGBAImage(TIFF* tif,
+ uint32 rwidth, uint32 rheight, uint32* raster, int stop)
+{
+ return TIFFReadRGBAImageOriented(tif, rwidth, rheight, raster,
+ ORIENTATION_BOTLEFT, stop);
+}
+
+static int
+setorientation(TIFFRGBAImage* img)
+{
+ switch (img->orientation) {
+ case ORIENTATION_TOPLEFT:
+ case ORIENTATION_LEFTTOP:
+ if (img->req_orientation == ORIENTATION_TOPRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTTOP)
+ return FLIP_HORIZONTALLY;
+ else if (img->req_orientation == ORIENTATION_BOTRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTBOT)
+ return FLIP_HORIZONTALLY | FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_BOTLEFT ||
+ img->req_orientation == ORIENTATION_LEFTBOT)
+ return FLIP_VERTICALLY;
+ else
+ return 0;
+ case ORIENTATION_TOPRIGHT:
+ case ORIENTATION_RIGHTTOP:
+ if (img->req_orientation == ORIENTATION_TOPLEFT ||
+ img->req_orientation == ORIENTATION_LEFTTOP)
+ return FLIP_HORIZONTALLY;
+ else if (img->req_orientation == ORIENTATION_BOTRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTBOT)
+ return FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_BOTLEFT ||
+ img->req_orientation == ORIENTATION_LEFTBOT)
+ return FLIP_HORIZONTALLY | FLIP_VERTICALLY;
+ else
+ return 0;
+ case ORIENTATION_BOTRIGHT:
+ case ORIENTATION_RIGHTBOT:
+ if (img->req_orientation == ORIENTATION_TOPLEFT ||
+ img->req_orientation == ORIENTATION_LEFTTOP)
+ return FLIP_HORIZONTALLY | FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_TOPRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTTOP)
+ return FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_BOTLEFT ||
+ img->req_orientation == ORIENTATION_LEFTBOT)
+ return FLIP_HORIZONTALLY;
+ else
+ return 0;
+ case ORIENTATION_BOTLEFT:
+ case ORIENTATION_LEFTBOT:
+ if (img->req_orientation == ORIENTATION_TOPLEFT ||
+ img->req_orientation == ORIENTATION_LEFTTOP)
+ return FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_TOPRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTTOP)
+ return FLIP_HORIZONTALLY | FLIP_VERTICALLY;
+ else if (img->req_orientation == ORIENTATION_BOTRIGHT ||
+ img->req_orientation == ORIENTATION_RIGHTBOT)
+ return FLIP_HORIZONTALLY;
+ else
+ return 0;
+ default: /* NOTREACHED */
+ return 0;
+ }
+}
+
+/*
+ * Get an tile-organized image that has
+ * PlanarConfiguration contiguous if SamplesPerPixel > 1
+ * or
+ * SamplesPerPixel == 1
+ */
+static int
+gtTileContig(TIFFRGBAImage* img, uint32* raster, uint32 w, uint32 h)
+{
+ TIFF* tif = img->tif;
+ tileContigRoutine put = img->put.contig;
+ uint32 col, row, y, rowstoread;
+ tmsize_t pos;
+ uint32 tw, th;
+ unsigned char* buf = NULL;
+ int32 fromskew, toskew;
+ uint32 nrow;
+ int ret = 1, flip;
+ uint32 this_tw, tocol;
+ int32 this_toskew, leftmost_toskew;
+ int32 leftmost_fromskew;
+ uint32 leftmost_tw;
+ tmsize_t bufsize;
+
+ bufsize = TIFFTileSize(tif);
+ if (bufsize == 0) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "%s", "No space for tile buffer");
+ return (0);
+ }
+
+ TIFFGetField(tif, TIFFTAG_TILEWIDTH, &tw);
+ TIFFGetField(tif, TIFFTAG_TILELENGTH, &th);
+
+ flip = setorientation(img);
+ if (flip & FLIP_VERTICALLY) {
+ y = h - 1;
+ toskew = -(int32)(tw + w);
+ }
+ else {
+ y = 0;
+ toskew = -(int32)(tw - w);
+ }
+
+ /*
+ * Leftmost tile is clipped on left side if col_offset > 0.
+ */
+ leftmost_fromskew = img->col_offset % tw;
+ leftmost_tw = tw - leftmost_fromskew;
+ leftmost_toskew = toskew + leftmost_fromskew;
+ for (row = 0; ret != 0 && row < h; row += nrow)
+ {
+ rowstoread = th - (row + img->row_offset) % th;
+ nrow = (row + rowstoread > h ? h - row : rowstoread);
+ fromskew = leftmost_fromskew;
+ this_tw = leftmost_tw;
+ this_toskew = leftmost_toskew;
+ tocol = 0;
+ col = img->col_offset;
+ while (tocol < w)
+ {
+ if (_TIFFReadTileAndAllocBuffer(tif, (void**) &buf, bufsize, col,
+ row+img->row_offset, 0, 0)==(tmsize_t)(-1) &&
+ (buf == NULL || img->stoponerr))
+ {
+ ret = 0;
+ break;
+ }
+ pos = ((row+img->row_offset) % th) * TIFFTileRowSize(tif) + \
+ ((tmsize_t) fromskew * img->samplesperpixel);
+ if (tocol + this_tw > w)
+ {
+ /*
+ * Rightmost tile is clipped on right side.
+ */
+ fromskew = tw - (w - tocol);
+ this_tw = tw - fromskew;
+ this_toskew = toskew + fromskew;
+ }
+ (*put)(img, raster+y*w+tocol, tocol, y, this_tw, nrow, fromskew, this_toskew, buf + pos);
+ tocol += this_tw;
+ col += this_tw;
+ /*
+ * After the leftmost tile, tiles are no longer clipped on left side.
+ */
+ fromskew = 0;
+ this_tw = tw;
+ this_toskew = toskew;
+ }
+
+ y += ((flip & FLIP_VERTICALLY) ? -(int32) nrow : (int32) nrow);
+ }
+ _TIFFfree(buf);
+
+ if (flip & FLIP_HORIZONTALLY) {
+ uint32 line;
+
+ for (line = 0; line < h; line++) {
+ uint32 *left = raster + (line * w);
+ uint32 *right = left + w - 1;
+
+ while ( left < right ) {
+ uint32 temp = *left;
+ *left = *right;
+ *right = temp;
+ left++;
+ right--;
+ }
+ }
+ }
+
+ return (ret);
+}
+
+/*
+ * Get an tile-organized image that has
+ * SamplesPerPixel > 1
+ * PlanarConfiguration separated
+ * We assume that all such images are RGB.
+ */
+static int
+gtTileSeparate(TIFFRGBAImage* img, uint32* raster, uint32 w, uint32 h)
+{
+ TIFF* tif = img->tif;
+ tileSeparateRoutine put = img->put.separate;
+ uint32 col, row, y, rowstoread;
+ tmsize_t pos;
+ uint32 tw, th;
+ unsigned char* buf = NULL;
+ unsigned char* p0 = NULL;
+ unsigned char* p1 = NULL;
+ unsigned char* p2 = NULL;
+ unsigned char* pa = NULL;
+ tmsize_t tilesize;
+ tmsize_t bufsize;
+ int32 fromskew, toskew;
+ int alpha = img->alpha;
+ uint32 nrow;
+ int ret = 1, flip;
+ uint16 colorchannels;
+ uint32 this_tw, tocol;
+ int32 this_toskew, leftmost_toskew;
+ int32 leftmost_fromskew;
+ uint32 leftmost_tw;
+
+ tilesize = TIFFTileSize(tif);
+ bufsize = TIFFSafeMultiply(tmsize_t,alpha?4:3,tilesize);
+ if (bufsize == 0) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "Integer overflow in %s", "gtTileSeparate");
+ return (0);
+ }
+
+ TIFFGetField(tif, TIFFTAG_TILEWIDTH, &tw);
+ TIFFGetField(tif, TIFFTAG_TILELENGTH, &th);
+
+ flip = setorientation(img);
+ if (flip & FLIP_VERTICALLY) {
+ y = h - 1;
+ toskew = -(int32)(tw + w);
+ }
+ else {
+ y = 0;
+ toskew = -(int32)(tw - w);
+ }
+
+ switch( img->photometric )
+ {
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ case PHOTOMETRIC_PALETTE:
+ colorchannels = 1;
+ break;
+
+ default:
+ colorchannels = 3;
+ break;
+ }
+
+ /*
+ * Leftmost tile is clipped on left side if col_offset > 0.
+ */
+ leftmost_fromskew = img->col_offset % tw;
+ leftmost_tw = tw - leftmost_fromskew;
+ leftmost_toskew = toskew + leftmost_fromskew;
+ for (row = 0; ret != 0 && row < h; row += nrow)
+ {
+ rowstoread = th - (row + img->row_offset) % th;
+ nrow = (row + rowstoread > h ? h - row : rowstoread);
+ fromskew = leftmost_fromskew;
+ this_tw = leftmost_tw;
+ this_toskew = leftmost_toskew;
+ tocol = 0;
+ col = img->col_offset;
+ while (tocol < w)
+ {
+ if( buf == NULL )
+ {
+ if (_TIFFReadTileAndAllocBuffer(
+ tif, (void**) &buf, bufsize, col,
+ row+img->row_offset,0,0)==(tmsize_t)(-1)
+ && (buf == NULL || img->stoponerr))
+ {
+ ret = 0;
+ break;
+ }
+ p0 = buf;
+ if( colorchannels == 1 )
+ {
+ p2 = p1 = p0;
+ pa = (alpha?(p0+3*tilesize):NULL);
+ }
+ else
+ {
+ p1 = p0 + tilesize;
+ p2 = p1 + tilesize;
+ pa = (alpha?(p2+tilesize):NULL);
+ }
+ }
+ else if (TIFFReadTile(tif, p0, col,
+ row+img->row_offset,0,0)==(tmsize_t)(-1) && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (colorchannels > 1
+ && TIFFReadTile(tif, p1, col,
+ row+img->row_offset,0,1) == (tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (colorchannels > 1
+ && TIFFReadTile(tif, p2, col,
+ row+img->row_offset,0,2) == (tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (alpha
+ && TIFFReadTile(tif,pa,col,
+ row+img->row_offset,0,colorchannels) == (tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+
+ pos = ((row+img->row_offset) % th) * TIFFTileRowSize(tif) + \
+ ((tmsize_t) fromskew * img->samplesperpixel);
+ if (tocol + this_tw > w)
+ {
+ /*
+ * Rightmost tile is clipped on right side.
+ */
+ fromskew = tw - (w - tocol);
+ this_tw = tw - fromskew;
+ this_toskew = toskew + fromskew;
+ }
+ (*put)(img, raster+y*w+tocol, tocol, y, this_tw, nrow, fromskew, this_toskew, \
+ p0 + pos, p1 + pos, p2 + pos, (alpha?(pa+pos):NULL));
+ tocol += this_tw;
+ col += this_tw;
+ /*
+ * After the leftmost tile, tiles are no longer clipped on left side.
+ */
+ fromskew = 0;
+ this_tw = tw;
+ this_toskew = toskew;
+ }
+
+ y += ((flip & FLIP_VERTICALLY) ?-(int32) nrow : (int32) nrow);
+ }
+
+ if (flip & FLIP_HORIZONTALLY) {
+ uint32 line;
+
+ for (line = 0; line < h; line++) {
+ uint32 *left = raster + (line * w);
+ uint32 *right = left + w - 1;
+
+ while ( left < right ) {
+ uint32 temp = *left;
+ *left = *right;
+ *right = temp;
+ left++;
+ right--;
+ }
+ }
+ }
+
+ _TIFFfree(buf);
+ return (ret);
+}
+
+/*
+ * Get a strip-organized image that has
+ * PlanarConfiguration contiguous if SamplesPerPixel > 1
+ * or
+ * SamplesPerPixel == 1
+ */
+static int
+gtStripContig(TIFFRGBAImage* img, uint32* raster, uint32 w, uint32 h)
+{
+ TIFF* tif = img->tif;
+ tileContigRoutine put = img->put.contig;
+ uint32 row, y, nrow, nrowsub, rowstoread;
+ tmsize_t pos;
+ unsigned char* buf = NULL;
+ uint32 rowsperstrip;
+ uint16 subsamplinghor,subsamplingver;
+ uint32 imagewidth = img->width;
+ tmsize_t scanline;
+ int32 fromskew, toskew;
+ int ret = 1, flip;
+ tmsize_t maxstripsize;
+
+ TIFFGetFieldDefaulted(tif, TIFFTAG_YCBCRSUBSAMPLING, &subsamplinghor, &subsamplingver);
+ if( subsamplingver == 0 ) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "Invalid vertical YCbCr subsampling");
+ return (0);
+ }
+
+ maxstripsize = TIFFStripSize(tif);
+
+ flip = setorientation(img);
+ if (flip & FLIP_VERTICALLY) {
+ y = h - 1;
+ toskew = -(int32)(w + w);
+ } else {
+ y = 0;
+ toskew = -(int32)(w - w);
+ }
+
+ TIFFGetFieldDefaulted(tif, TIFFTAG_ROWSPERSTRIP, &rowsperstrip);
+
+ scanline = TIFFScanlineSize(tif);
+ fromskew = (w < imagewidth ? imagewidth - w : 0);
+ for (row = 0; row < h; row += nrow)
+ {
+ rowstoread = rowsperstrip - (row + img->row_offset) % rowsperstrip;
+ nrow = (row + rowstoread > h ? h - row : rowstoread);
+ nrowsub = nrow;
+ if ((nrowsub%subsamplingver)!=0)
+ nrowsub+=subsamplingver-nrowsub%subsamplingver;
+ if (_TIFFReadEncodedStripAndAllocBuffer(tif,
+ TIFFComputeStrip(tif,row+img->row_offset, 0),
+ (void**)(&buf),
+ maxstripsize,
+ ((row + img->row_offset)%rowsperstrip + nrowsub) * scanline)==(tmsize_t)(-1)
+ && (buf == NULL || img->stoponerr))
+ {
+ ret = 0;
+ break;
+ }
+
+ pos = ((row + img->row_offset) % rowsperstrip) * scanline + \
+ ((tmsize_t) img->col_offset * img->samplesperpixel);
+ (*put)(img, raster+y*w, 0, y, w, nrow, fromskew, toskew, buf + pos);
+ y += ((flip & FLIP_VERTICALLY) ? -(int32) nrow : (int32) nrow);
+ }
+
+ if (flip & FLIP_HORIZONTALLY) {
+ uint32 line;
+
+ for (line = 0; line < h; line++) {
+ uint32 *left = raster + (line * w);
+ uint32 *right = left + w - 1;
+
+ while ( left < right ) {
+ uint32 temp = *left;
+ *left = *right;
+ *right = temp;
+ left++;
+ right--;
+ }
+ }
+ }
+
+ _TIFFfree(buf);
+ return (ret);
+}
+
+/*
+ * Get a strip-organized image with
+ * SamplesPerPixel > 1
+ * PlanarConfiguration separated
+ * We assume that all such images are RGB.
+ */
+static int
+gtStripSeparate(TIFFRGBAImage* img, uint32* raster, uint32 w, uint32 h)
+{
+ TIFF* tif = img->tif;
+ tileSeparateRoutine put = img->put.separate;
+ unsigned char *buf = NULL;
+ unsigned char *p0 = NULL, *p1 = NULL, *p2 = NULL, *pa = NULL;
+ uint32 row, y, nrow, rowstoread;
+ tmsize_t pos;
+ tmsize_t scanline;
+ uint32 rowsperstrip, offset_row;
+ uint32 imagewidth = img->width;
+ tmsize_t stripsize;
+ tmsize_t bufsize;
+ int32 fromskew, toskew;
+ int alpha = img->alpha;
+ int ret = 1, flip;
+ uint16 colorchannels;
+
+ stripsize = TIFFStripSize(tif);
+ bufsize = TIFFSafeMultiply(tmsize_t,alpha?4:3,stripsize);
+ if (bufsize == 0) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "Integer overflow in %s", "gtStripSeparate");
+ return (0);
+ }
+
+ flip = setorientation(img);
+ if (flip & FLIP_VERTICALLY) {
+ y = h - 1;
+ toskew = -(int32)(w + w);
+ }
+ else {
+ y = 0;
+ toskew = -(int32)(w - w);
+ }
+
+ switch( img->photometric )
+ {
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ case PHOTOMETRIC_PALETTE:
+ colorchannels = 1;
+ break;
+
+ default:
+ colorchannels = 3;
+ break;
+ }
+
+ TIFFGetFieldDefaulted(tif, TIFFTAG_ROWSPERSTRIP, &rowsperstrip);
+ scanline = TIFFScanlineSize(tif);
+ fromskew = (w < imagewidth ? imagewidth - w : 0);
+ for (row = 0; row < h; row += nrow)
+ {
+ rowstoread = rowsperstrip - (row + img->row_offset) % rowsperstrip;
+ nrow = (row + rowstoread > h ? h - row : rowstoread);
+ offset_row = row + img->row_offset;
+ if( buf == NULL )
+ {
+ if (_TIFFReadEncodedStripAndAllocBuffer(
+ tif, TIFFComputeStrip(tif, offset_row, 0),
+ (void**) &buf, bufsize,
+ ((row + img->row_offset)%rowsperstrip + nrow) * scanline)==(tmsize_t)(-1)
+ && (buf == NULL || img->stoponerr))
+ {
+ ret = 0;
+ break;
+ }
+ p0 = buf;
+ if( colorchannels == 1 )
+ {
+ p2 = p1 = p0;
+ pa = (alpha?(p0+3*stripsize):NULL);
+ }
+ else
+ {
+ p1 = p0 + stripsize;
+ p2 = p1 + stripsize;
+ pa = (alpha?(p2+stripsize):NULL);
+ }
+ }
+ else if (TIFFReadEncodedStrip(tif, TIFFComputeStrip(tif, offset_row, 0),
+ p0, ((row + img->row_offset)%rowsperstrip + nrow) * scanline)==(tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (colorchannels > 1
+ && TIFFReadEncodedStrip(tif, TIFFComputeStrip(tif, offset_row, 1),
+ p1, ((row + img->row_offset)%rowsperstrip + nrow) * scanline) == (tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (colorchannels > 1
+ && TIFFReadEncodedStrip(tif, TIFFComputeStrip(tif, offset_row, 2),
+ p2, ((row + img->row_offset)%rowsperstrip + nrow) * scanline) == (tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ if (alpha)
+ {
+ if (TIFFReadEncodedStrip(tif, TIFFComputeStrip(tif, offset_row, colorchannels),
+ pa, ((row + img->row_offset)%rowsperstrip + nrow) * scanline)==(tmsize_t)(-1)
+ && img->stoponerr)
+ {
+ ret = 0;
+ break;
+ }
+ }
+
+ pos = ((row + img->row_offset) % rowsperstrip) * scanline + \
+ ((tmsize_t) img->col_offset * img->samplesperpixel);
+ (*put)(img, raster+y*w, 0, y, w, nrow, fromskew, toskew, p0 + pos, p1 + pos,
+ p2 + pos, (alpha?(pa+pos):NULL));
+ y += ((flip & FLIP_VERTICALLY) ? -(int32) nrow : (int32) nrow);
+ }
+
+ if (flip & FLIP_HORIZONTALLY) {
+ uint32 line;
+
+ for (line = 0; line < h; line++) {
+ uint32 *left = raster + (line * w);
+ uint32 *right = left + w - 1;
+
+ while ( left < right ) {
+ uint32 temp = *left;
+ *left = *right;
+ *right = temp;
+ left++;
+ right--;
+ }
+ }
+ }
+
+ _TIFFfree(buf);
+ return (ret);
+}
+
+/*
+ * The following routines move decoded data returned
+ * from the TIFF library into rasters filled with packed
+ * ABGR pixels (i.e. suitable for passing to lrecwrite.)
+ *
+ * The routines have been created according to the most
+ * important cases and optimized. PickContigCase and
+ * PickSeparateCase analyze the parameters and select
+ * the appropriate "get" and "put" routine to use.
+ */
+#define REPEAT8(op) REPEAT4(op); REPEAT4(op)
+#define REPEAT4(op) REPEAT2(op); REPEAT2(op)
+#define REPEAT2(op) op; op
+#define CASE8(x,op) \
+ switch (x) { \
+ case 7: op; /*-fallthrough*/ \
+ case 6: op; /*-fallthrough*/ \
+ case 5: op; /*-fallthrough*/ \
+ case 4: op; /*-fallthrough*/ \
+ case 3: op; /*-fallthrough*/ \
+ case 2: op; /*-fallthrough*/ \
+ case 1: op; \
+ }
+#define CASE4(x,op) switch (x) { case 3: op; /*-fallthrough*/ case 2: op; /*-fallthrough*/ case 1: op; }
+#define NOP
+
+#define UNROLL8(w, op1, op2) { \
+ uint32 _x; \
+ for (_x = w; _x >= 8; _x -= 8) { \
+ op1; \
+ REPEAT8(op2); \
+ } \
+ if (_x > 0) { \
+ op1; \
+ CASE8(_x,op2); \
+ } \
+}
+#define UNROLL4(w, op1, op2) { \
+ uint32 _x; \
+ for (_x = w; _x >= 4; _x -= 4) { \
+ op1; \
+ REPEAT4(op2); \
+ } \
+ if (_x > 0) { \
+ op1; \
+ CASE4(_x,op2); \
+ } \
+}
+#define UNROLL2(w, op1, op2) { \
+ uint32 _x; \
+ for (_x = w; _x >= 2; _x -= 2) { \
+ op1; \
+ REPEAT2(op2); \
+ } \
+ if (_x) { \
+ op1; \
+ op2; \
+ } \
+}
+
+#define SKEW(r,g,b,skew) { r += skew; g += skew; b += skew; }
+#define SKEW4(r,g,b,a,skew) { r += skew; g += skew; b += skew; a+= skew; }
+
+#define A1 (((uint32)0xffL)<<24)
+#define PACK(r,g,b) \
+ ((uint32)(r)|((uint32)(g)<<8)|((uint32)(b)<<16)|A1)
+#define PACK4(r,g,b,a) \
+ ((uint32)(r)|((uint32)(g)<<8)|((uint32)(b)<<16)|((uint32)(a)<<24))
+#define W2B(v) (((v)>>8)&0xff)
+/* TODO: PACKW should have be made redundant in favor of Bitdepth16To8 LUT */
+#define PACKW(r,g,b) \
+ ((uint32)W2B(r)|((uint32)W2B(g)<<8)|((uint32)W2B(b)<<16)|A1)
+#define PACKW4(r,g,b,a) \
+ ((uint32)W2B(r)|((uint32)W2B(g)<<8)|((uint32)W2B(b)<<16)|((uint32)W2B(a)<<24))
+
+#define DECLAREContigPutFunc(name) \
+static void name(\
+ TIFFRGBAImage* img, \
+ uint32* cp, \
+ uint32 x, uint32 y, \
+ uint32 w, uint32 h, \
+ int32 fromskew, int32 toskew, \
+ unsigned char* pp \
+)
+
+/*
+ * 8-bit palette => colormap/RGB
+ */
+DECLAREContigPutFunc(put8bitcmaptile)
+{
+ uint32** PALmap = img->PALmap;
+ int samplesperpixel = img->samplesperpixel;
+
+ (void) y;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x)
+ {
+ *cp++ = PALmap[*pp][0];
+ pp += samplesperpixel;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 4-bit palette => colormap/RGB
+ */
+DECLAREContigPutFunc(put4bitcmaptile)
+{
+ uint32** PALmap = img->PALmap;
+
+ (void) x; (void) y;
+ fromskew /= 2;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL2(w, bw = PALmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 2-bit palette => colormap/RGB
+ */
+DECLAREContigPutFunc(put2bitcmaptile)
+{
+ uint32** PALmap = img->PALmap;
+
+ (void) x; (void) y;
+ fromskew /= 4;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL4(w, bw = PALmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 1-bit palette => colormap/RGB
+ */
+DECLAREContigPutFunc(put1bitcmaptile)
+{
+ uint32** PALmap = img->PALmap;
+
+ (void) x; (void) y;
+ fromskew /= 8;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL8(w, bw = PALmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit greyscale => colormap/RGB
+ */
+DECLAREContigPutFunc(putgreytile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint32** BWmap = img->BWmap;
+
+ (void) y;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x)
+ {
+ *cp++ = BWmap[*pp][0];
+ pp += samplesperpixel;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit greyscale with associated alpha => colormap/RGBA
+ */
+DECLAREContigPutFunc(putagreytile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint32** BWmap = img->BWmap;
+
+ (void) y;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x)
+ {
+ *cp++ = BWmap[*pp][0] & ((uint32)*(pp+1) << 24 | ~A1);
+ pp += samplesperpixel;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 16-bit greyscale => colormap/RGB
+ */
+DECLAREContigPutFunc(put16bitbwtile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint32** BWmap = img->BWmap;
+
+ (void) y;
+ for( ; h > 0; --h) {
+ uint16 *wp = (uint16 *) pp;
+
+ for (x = w; x > 0; --x)
+ {
+ /* use high order byte of 16bit value */
+
+ *cp++ = BWmap[*wp >> 8][0];
+ pp += 2 * samplesperpixel;
+ wp += samplesperpixel;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 1-bit bilevel => colormap/RGB
+ */
+DECLAREContigPutFunc(put1bitbwtile)
+{
+ uint32** BWmap = img->BWmap;
+
+ (void) x; (void) y;
+ fromskew /= 8;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL8(w, bw = BWmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 2-bit greyscale => colormap/RGB
+ */
+DECLAREContigPutFunc(put2bitbwtile)
+{
+ uint32** BWmap = img->BWmap;
+
+ (void) x; (void) y;
+ fromskew /= 4;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL4(w, bw = BWmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 4-bit greyscale => colormap/RGB
+ */
+DECLAREContigPutFunc(put4bitbwtile)
+{
+ uint32** BWmap = img->BWmap;
+
+ (void) x; (void) y;
+ fromskew /= 2;
+ for( ; h > 0; --h) {
+ uint32* bw;
+ UNROLL2(w, bw = BWmap[*pp++], *cp++ = *bw++);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit packed samples, no Map => RGB
+ */
+DECLAREContigPutFunc(putRGBcontig8bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+
+ (void) x; (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ UNROLL8(w, NOP,
+ *cp++ = PACK(pp[0], pp[1], pp[2]);
+ pp += samplesperpixel);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit packed samples => RGBA w/ associated alpha
+ * (known to have Map == NULL)
+ */
+DECLAREContigPutFunc(putRGBAAcontig8bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+
+ (void) x; (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ UNROLL8(w, NOP,
+ *cp++ = PACK4(pp[0], pp[1], pp[2], pp[3]);
+ pp += samplesperpixel);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit packed samples => RGBA w/ unassociated alpha
+ * (known to have Map == NULL)
+ */
+DECLAREContigPutFunc(putRGBUAcontig8bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ uint32 r, g, b, a;
+ uint8* m;
+ for (x = w; x > 0; --x) {
+ a = pp[3];
+ m = img->UaToAa+((size_t) a<<8);
+ r = m[pp[0]];
+ g = m[pp[1]];
+ b = m[pp[2]];
+ *cp++ = PACK4(r,g,b,a);
+ pp += samplesperpixel;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 16-bit packed samples => RGB
+ */
+DECLAREContigPutFunc(putRGBcontig16bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint16 *wp = (uint16 *)pp;
+ (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x) {
+ *cp++ = PACK(img->Bitdepth16To8[wp[0]],
+ img->Bitdepth16To8[wp[1]],
+ img->Bitdepth16To8[wp[2]]);
+ wp += samplesperpixel;
+ }
+ cp += toskew;
+ wp += fromskew;
+ }
+}
+
+/*
+ * 16-bit packed samples => RGBA w/ associated alpha
+ * (known to have Map == NULL)
+ */
+DECLAREContigPutFunc(putRGBAAcontig16bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint16 *wp = (uint16 *)pp;
+ (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x) {
+ *cp++ = PACK4(img->Bitdepth16To8[wp[0]],
+ img->Bitdepth16To8[wp[1]],
+ img->Bitdepth16To8[wp[2]],
+ img->Bitdepth16To8[wp[3]]);
+ wp += samplesperpixel;
+ }
+ cp += toskew;
+ wp += fromskew;
+ }
+}
+
+/*
+ * 16-bit packed samples => RGBA w/ unassociated alpha
+ * (known to have Map == NULL)
+ */
+DECLAREContigPutFunc(putRGBUAcontig16bittile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint16 *wp = (uint16 *)pp;
+ (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ uint32 r,g,b,a;
+ uint8* m;
+ for (x = w; x > 0; --x) {
+ a = img->Bitdepth16To8[wp[3]];
+ m = img->UaToAa+((size_t) a<<8);
+ r = m[img->Bitdepth16To8[wp[0]]];
+ g = m[img->Bitdepth16To8[wp[1]]];
+ b = m[img->Bitdepth16To8[wp[2]]];
+ *cp++ = PACK4(r,g,b,a);
+ wp += samplesperpixel;
+ }
+ cp += toskew;
+ wp += fromskew;
+ }
+}
+
+/*
+ * 8-bit packed CMYK samples w/o Map => RGB
+ *
+ * NB: The conversion of CMYK->RGB is *very* crude.
+ */
+DECLAREContigPutFunc(putRGBcontig8bitCMYKtile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ uint16 r, g, b, k;
+
+ (void) x; (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ UNROLL8(w, NOP,
+ k = 255 - pp[3];
+ r = (k*(255-pp[0]))/255;
+ g = (k*(255-pp[1]))/255;
+ b = (k*(255-pp[2]))/255;
+ *cp++ = PACK(r, g, b);
+ pp += samplesperpixel);
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * 8-bit packed CMYK samples w/Map => RGB
+ *
+ * NB: The conversion of CMYK->RGB is *very* crude.
+ */
+DECLAREContigPutFunc(putRGBcontig8bitCMYKMaptile)
+{
+ int samplesperpixel = img->samplesperpixel;
+ TIFFRGBValue* Map = img->Map;
+ uint16 r, g, b, k;
+
+ (void) y;
+ fromskew *= samplesperpixel;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x) {
+ k = 255 - pp[3];
+ r = (k*(255-pp[0]))/255;
+ g = (k*(255-pp[1]))/255;
+ b = (k*(255-pp[2]))/255;
+ *cp++ = PACK(Map[r], Map[g], Map[b]);
+ pp += samplesperpixel;
+ }
+ pp += fromskew;
+ cp += toskew;
+ }
+}
+
+#define DECLARESepPutFunc(name) \
+static void name(\
+ TIFFRGBAImage* img,\
+ uint32* cp,\
+ uint32 x, uint32 y, \
+ uint32 w, uint32 h,\
+ int32 fromskew, int32 toskew,\
+ unsigned char* r, unsigned char* g, unsigned char* b, unsigned char* a\
+)
+
+/*
+ * 8-bit unpacked samples => RGB
+ */
+DECLARESepPutFunc(putRGBseparate8bittile)
+{
+ (void) img; (void) x; (void) y; (void) a;
+ for( ; h > 0; --h) {
+ UNROLL8(w, NOP, *cp++ = PACK(*r++, *g++, *b++));
+ SKEW(r, g, b, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 8-bit unpacked samples => RGBA w/ associated alpha
+ */
+DECLARESepPutFunc(putRGBAAseparate8bittile)
+{
+ (void) img; (void) x; (void) y;
+ for( ; h > 0; --h) {
+ UNROLL8(w, NOP, *cp++ = PACK4(*r++, *g++, *b++, *a++));
+ SKEW4(r, g, b, a, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 8-bit unpacked CMYK samples => RGBA
+ */
+DECLARESepPutFunc(putCMYKseparate8bittile)
+{
+ (void) img; (void) y;
+ for( ; h > 0; --h) {
+ uint32 rv, gv, bv, kv;
+ for (x = w; x > 0; --x) {
+ kv = 255 - *a++;
+ rv = (kv*(255-*r++))/255;
+ gv = (kv*(255-*g++))/255;
+ bv = (kv*(255-*b++))/255;
+ *cp++ = PACK4(rv,gv,bv,255);
+ }
+ SKEW4(r, g, b, a, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 8-bit unpacked samples => RGBA w/ unassociated alpha
+ */
+DECLARESepPutFunc(putRGBUAseparate8bittile)
+{
+ (void) img; (void) y;
+ for( ; h > 0; --h) {
+ uint32 rv, gv, bv, av;
+ uint8* m;
+ for (x = w; x > 0; --x) {
+ av = *a++;
+ m = img->UaToAa+((size_t) av<<8);
+ rv = m[*r++];
+ gv = m[*g++];
+ bv = m[*b++];
+ *cp++ = PACK4(rv,gv,bv,av);
+ }
+ SKEW4(r, g, b, a, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 16-bit unpacked samples => RGB
+ */
+DECLARESepPutFunc(putRGBseparate16bittile)
+{
+ uint16 *wr = (uint16*) r;
+ uint16 *wg = (uint16*) g;
+ uint16 *wb = (uint16*) b;
+ (void) img; (void) y; (void) a;
+ for( ; h > 0; --h) {
+ for (x = 0; x < w; x++)
+ *cp++ = PACK(img->Bitdepth16To8[*wr++],
+ img->Bitdepth16To8[*wg++],
+ img->Bitdepth16To8[*wb++]);
+ SKEW(wr, wg, wb, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 16-bit unpacked samples => RGBA w/ associated alpha
+ */
+DECLARESepPutFunc(putRGBAAseparate16bittile)
+{
+ uint16 *wr = (uint16*) r;
+ uint16 *wg = (uint16*) g;
+ uint16 *wb = (uint16*) b;
+ uint16 *wa = (uint16*) a;
+ (void) img; (void) y;
+ for( ; h > 0; --h) {
+ for (x = 0; x < w; x++)
+ *cp++ = PACK4(img->Bitdepth16To8[*wr++],
+ img->Bitdepth16To8[*wg++],
+ img->Bitdepth16To8[*wb++],
+ img->Bitdepth16To8[*wa++]);
+ SKEW4(wr, wg, wb, wa, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 16-bit unpacked samples => RGBA w/ unassociated alpha
+ */
+DECLARESepPutFunc(putRGBUAseparate16bittile)
+{
+ uint16 *wr = (uint16*) r;
+ uint16 *wg = (uint16*) g;
+ uint16 *wb = (uint16*) b;
+ uint16 *wa = (uint16*) a;
+ (void) img; (void) y;
+ for( ; h > 0; --h) {
+ uint32 r2,g2,b2,a2;
+ uint8* m;
+ for (x = w; x > 0; --x) {
+ a2 = img->Bitdepth16To8[*wa++];
+ m = img->UaToAa+((size_t) a2<<8);
+ r2 = m[img->Bitdepth16To8[*wr++]];
+ g2 = m[img->Bitdepth16To8[*wg++]];
+ b2 = m[img->Bitdepth16To8[*wb++]];
+ *cp++ = PACK4(r2,g2,b2,a2);
+ }
+ SKEW4(wr, wg, wb, wa, fromskew);
+ cp += toskew;
+ }
+}
+
+/*
+ * 8-bit packed CIE L*a*b 1976 samples => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitCIELab)
+{
+ float X, Y, Z;
+ uint32 r, g, b;
+ (void) y;
+ fromskew *= 3;
+ for( ; h > 0; --h) {
+ for (x = w; x > 0; --x) {
+ TIFFCIELabToXYZ(img->cielab,
+ (unsigned char)pp[0],
+ (signed char)pp[1],
+ (signed char)pp[2],
+ &X, &Y, &Z);
+ TIFFXYZToRGB(img->cielab, X, Y, Z, &r, &g, &b);
+ *cp++ = PACK(r, g, b);
+ pp += 3;
+ }
+ cp += toskew;
+ pp += fromskew;
+ }
+}
+
+/*
+ * YCbCr -> RGB conversion and packing routines.
+ */
+
+#define YCbCrtoRGB(dst, Y) { \
+ uint32 r, g, b; \
+ TIFFYCbCrtoRGB(img->ycbcr, (Y), Cb, Cr, &r, &g, &b); \
+ dst = PACK(r, g, b); \
+}
+
+/*
+ * 8-bit packed YCbCr samples => RGB
+ * This function is generic for different sampling sizes,
+ * and can handle blocks sizes that aren't multiples of the
+ * sampling size. However, it is substantially less optimized
+ * than the specific sampling cases. It is used as a fallback
+ * for difficult blocks.
+ */
+#ifdef notdef
+static void putcontig8bitYCbCrGenericTile(
+ TIFFRGBAImage* img,
+ uint32* cp,
+ uint32 x, uint32 y,
+ uint32 w, uint32 h,
+ int32 fromskew, int32 toskew,
+ unsigned char* pp,
+ int h_group,
+ int v_group )
+
+{
+ uint32* cp1 = cp+w+toskew;
+ uint32* cp2 = cp1+w+toskew;
+ uint32* cp3 = cp2+w+toskew;
+ int32 incr = 3*w+4*toskew;
+ int32 Cb, Cr;
+ int group_size = v_group * h_group + 2;
+
+ (void) y;
+ fromskew = (fromskew * group_size) / h_group;
+
+ for( yy = 0; yy < h; yy++ )
+ {
+ unsigned char *pp_line;
+ int y_line_group = yy / v_group;
+ int y_remainder = yy - y_line_group * v_group;
+
+ pp_line = pp + v_line_group *
+
+
+ for( xx = 0; xx < w; xx++ )
+ {
+ Cb = pp
+ }
+ }
+ for (; h >= 4; h -= 4) {
+ x = w>>2;
+ do {
+ Cb = pp[16];
+ Cr = pp[17];
+
+ YCbCrtoRGB(cp [0], pp[ 0]);
+ YCbCrtoRGB(cp [1], pp[ 1]);
+ YCbCrtoRGB(cp [2], pp[ 2]);
+ YCbCrtoRGB(cp [3], pp[ 3]);
+ YCbCrtoRGB(cp1[0], pp[ 4]);
+ YCbCrtoRGB(cp1[1], pp[ 5]);
+ YCbCrtoRGB(cp1[2], pp[ 6]);
+ YCbCrtoRGB(cp1[3], pp[ 7]);
+ YCbCrtoRGB(cp2[0], pp[ 8]);
+ YCbCrtoRGB(cp2[1], pp[ 9]);
+ YCbCrtoRGB(cp2[2], pp[10]);
+ YCbCrtoRGB(cp2[3], pp[11]);
+ YCbCrtoRGB(cp3[0], pp[12]);
+ YCbCrtoRGB(cp3[1], pp[13]);
+ YCbCrtoRGB(cp3[2], pp[14]);
+ YCbCrtoRGB(cp3[3], pp[15]);
+
+ cp += 4, cp1 += 4, cp2 += 4, cp3 += 4;
+ pp += 18;
+ } while (--x);
+ cp += incr, cp1 += incr, cp2 += incr, cp3 += incr;
+ pp += fromskew;
+ }
+}
+#endif
+
+/*
+ * 8-bit packed YCbCr samples w/ 4,4 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr44tile)
+{
+ uint32* cp1 = cp+w+toskew;
+ uint32* cp2 = cp1+w+toskew;
+ uint32* cp3 = cp2+w+toskew;
+ int32 incr = 3*w+4*toskew;
+
+ (void) y;
+ /* adjust fromskew */
+ fromskew = (fromskew / 4) * (4*2+2);
+ if ((h & 3) == 0 && (w & 3) == 0) {
+ for (; h >= 4; h -= 4) {
+ x = w>>2;
+ do {
+ int32 Cb = pp[16];
+ int32 Cr = pp[17];
+
+ YCbCrtoRGB(cp [0], pp[ 0]);
+ YCbCrtoRGB(cp [1], pp[ 1]);
+ YCbCrtoRGB(cp [2], pp[ 2]);
+ YCbCrtoRGB(cp [3], pp[ 3]);
+ YCbCrtoRGB(cp1[0], pp[ 4]);
+ YCbCrtoRGB(cp1[1], pp[ 5]);
+ YCbCrtoRGB(cp1[2], pp[ 6]);
+ YCbCrtoRGB(cp1[3], pp[ 7]);
+ YCbCrtoRGB(cp2[0], pp[ 8]);
+ YCbCrtoRGB(cp2[1], pp[ 9]);
+ YCbCrtoRGB(cp2[2], pp[10]);
+ YCbCrtoRGB(cp2[3], pp[11]);
+ YCbCrtoRGB(cp3[0], pp[12]);
+ YCbCrtoRGB(cp3[1], pp[13]);
+ YCbCrtoRGB(cp3[2], pp[14]);
+ YCbCrtoRGB(cp3[3], pp[15]);
+
+ cp += 4;
+ cp1 += 4;
+ cp2 += 4;
+ cp3 += 4;
+ pp += 18;
+ } while (--x);
+ cp += incr;
+ cp1 += incr;
+ cp2 += incr;
+ cp3 += incr;
+ pp += fromskew;
+ }
+ } else {
+ while (h > 0) {
+ for (x = w; x > 0;) {
+ int32 Cb = pp[16];
+ int32 Cr = pp[17];
+ switch (x) {
+ default:
+ switch (h) {
+ default: YCbCrtoRGB(cp3[3], pp[15]); /* FALLTHROUGH */
+ case 3: YCbCrtoRGB(cp2[3], pp[11]); /* FALLTHROUGH */
+ case 2: YCbCrtoRGB(cp1[3], pp[ 7]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [3], pp[ 3]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 3:
+ switch (h) {
+ default: YCbCrtoRGB(cp3[2], pp[14]); /* FALLTHROUGH */
+ case 3: YCbCrtoRGB(cp2[2], pp[10]); /* FALLTHROUGH */
+ case 2: YCbCrtoRGB(cp1[2], pp[ 6]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [2], pp[ 2]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 2:
+ switch (h) {
+ default: YCbCrtoRGB(cp3[1], pp[13]); /* FALLTHROUGH */
+ case 3: YCbCrtoRGB(cp2[1], pp[ 9]); /* FALLTHROUGH */
+ case 2: YCbCrtoRGB(cp1[1], pp[ 5]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [1], pp[ 1]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 1:
+ switch (h) {
+ default: YCbCrtoRGB(cp3[0], pp[12]); /* FALLTHROUGH */
+ case 3: YCbCrtoRGB(cp2[0], pp[ 8]); /* FALLTHROUGH */
+ case 2: YCbCrtoRGB(cp1[0], pp[ 4]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [0], pp[ 0]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ }
+ if (x < 4) {
+ cp += x; cp1 += x; cp2 += x; cp3 += x;
+ x = 0;
+ }
+ else {
+ cp += 4; cp1 += 4; cp2 += 4; cp3 += 4;
+ x -= 4;
+ }
+ pp += 18;
+ }
+ if (h <= 4)
+ break;
+ h -= 4;
+ cp += incr;
+ cp1 += incr;
+ cp2 += incr;
+ cp3 += incr;
+ pp += fromskew;
+ }
+ }
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ 4,2 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr42tile)
+{
+ uint32* cp1 = cp+w+toskew;
+ int32 incr = 2*toskew+w;
+
+ (void) y;
+ fromskew = (fromskew / 4) * (4*2+2);
+ if ((w & 3) == 0 && (h & 1) == 0) {
+ for (; h >= 2; h -= 2) {
+ x = w>>2;
+ do {
+ int32 Cb = pp[8];
+ int32 Cr = pp[9];
+
+ YCbCrtoRGB(cp [0], pp[0]);
+ YCbCrtoRGB(cp [1], pp[1]);
+ YCbCrtoRGB(cp [2], pp[2]);
+ YCbCrtoRGB(cp [3], pp[3]);
+ YCbCrtoRGB(cp1[0], pp[4]);
+ YCbCrtoRGB(cp1[1], pp[5]);
+ YCbCrtoRGB(cp1[2], pp[6]);
+ YCbCrtoRGB(cp1[3], pp[7]);
+
+ cp += 4;
+ cp1 += 4;
+ pp += 10;
+ } while (--x);
+ cp += incr;
+ cp1 += incr;
+ pp += fromskew;
+ }
+ } else {
+ while (h > 0) {
+ for (x = w; x > 0;) {
+ int32 Cb = pp[8];
+ int32 Cr = pp[9];
+ switch (x) {
+ default:
+ switch (h) {
+ default: YCbCrtoRGB(cp1[3], pp[ 7]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [3], pp[ 3]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 3:
+ switch (h) {
+ default: YCbCrtoRGB(cp1[2], pp[ 6]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [2], pp[ 2]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 2:
+ switch (h) {
+ default: YCbCrtoRGB(cp1[1], pp[ 5]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [1], pp[ 1]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ case 1:
+ switch (h) {
+ default: YCbCrtoRGB(cp1[0], pp[ 4]); /* FALLTHROUGH */
+ case 1: YCbCrtoRGB(cp [0], pp[ 0]); /* FALLTHROUGH */
+ } /* FALLTHROUGH */
+ }
+ if (x < 4) {
+ cp += x; cp1 += x;
+ x = 0;
+ }
+ else {
+ cp += 4; cp1 += 4;
+ x -= 4;
+ }
+ pp += 10;
+ }
+ if (h <= 2)
+ break;
+ h -= 2;
+ cp += incr;
+ cp1 += incr;
+ pp += fromskew;
+ }
+ }
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ 4,1 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr41tile)
+{
+ (void) y;
+ fromskew = (fromskew / 4) * (4*1+2);
+ do {
+ x = w>>2;
+ while(x>0) {
+ int32 Cb = pp[4];
+ int32 Cr = pp[5];
+
+ YCbCrtoRGB(cp [0], pp[0]);
+ YCbCrtoRGB(cp [1], pp[1]);
+ YCbCrtoRGB(cp [2], pp[2]);
+ YCbCrtoRGB(cp [3], pp[3]);
+
+ cp += 4;
+ pp += 6;
+ x--;
+ }
+
+ if( (w&3) != 0 )
+ {
+ int32 Cb = pp[4];
+ int32 Cr = pp[5];
+
+ switch( (w&3) ) {
+ case 3: YCbCrtoRGB(cp [2], pp[2]); /*-fallthrough*/
+ case 2: YCbCrtoRGB(cp [1], pp[1]); /*-fallthrough*/
+ case 1: YCbCrtoRGB(cp [0], pp[0]); /*-fallthrough*/
+ case 0: break;
+ }
+
+ cp += (w&3);
+ pp += 6;
+ }
+
+ cp += toskew;
+ pp += fromskew;
+ } while (--h);
+
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ 2,2 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr22tile)
+{
+ uint32* cp2;
+ int32 incr = 2*toskew+w;
+ (void) y;
+ fromskew = (fromskew / 2) * (2*2+2);
+ cp2 = cp+w+toskew;
+ while (h>=2) {
+ x = w;
+ while (x>=2) {
+ uint32 Cb = pp[4];
+ uint32 Cr = pp[5];
+ YCbCrtoRGB(cp[0], pp[0]);
+ YCbCrtoRGB(cp[1], pp[1]);
+ YCbCrtoRGB(cp2[0], pp[2]);
+ YCbCrtoRGB(cp2[1], pp[3]);
+ cp += 2;
+ cp2 += 2;
+ pp += 6;
+ x -= 2;
+ }
+ if (x==1) {
+ uint32 Cb = pp[4];
+ uint32 Cr = pp[5];
+ YCbCrtoRGB(cp[0], pp[0]);
+ YCbCrtoRGB(cp2[0], pp[2]);
+ cp ++ ;
+ cp2 ++ ;
+ pp += 6;
+ }
+ cp += incr;
+ cp2 += incr;
+ pp += fromskew;
+ h-=2;
+ }
+ if (h==1) {
+ x = w;
+ while (x>=2) {
+ uint32 Cb = pp[4];
+ uint32 Cr = pp[5];
+ YCbCrtoRGB(cp[0], pp[0]);
+ YCbCrtoRGB(cp[1], pp[1]);
+ cp += 2;
+ cp2 += 2;
+ pp += 6;
+ x -= 2;
+ }
+ if (x==1) {
+ uint32 Cb = pp[4];
+ uint32 Cr = pp[5];
+ YCbCrtoRGB(cp[0], pp[0]);
+ }
+ }
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ 2,1 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr21tile)
+{
+ (void) y;
+ fromskew = (fromskew / 2) * (2*1+2);
+ do {
+ x = w>>1;
+ while(x>0) {
+ int32 Cb = pp[2];
+ int32 Cr = pp[3];
+
+ YCbCrtoRGB(cp[0], pp[0]);
+ YCbCrtoRGB(cp[1], pp[1]);
+
+ cp += 2;
+ pp += 4;
+ x --;
+ }
+
+ if( (w&1) != 0 )
+ {
+ int32 Cb = pp[2];
+ int32 Cr = pp[3];
+
+ YCbCrtoRGB(cp[0], pp[0]);
+
+ cp += 1;
+ pp += 4;
+ }
+
+ cp += toskew;
+ pp += fromskew;
+ } while (--h);
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ 1,2 subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr12tile)
+{
+ uint32* cp2;
+ int32 incr = 2*toskew+w;
+ (void) y;
+ fromskew = (fromskew / 1) * (1 * 2 + 2);
+ cp2 = cp+w+toskew;
+ while (h>=2) {
+ x = w;
+ do {
+ uint32 Cb = pp[2];
+ uint32 Cr = pp[3];
+ YCbCrtoRGB(cp[0], pp[0]);
+ YCbCrtoRGB(cp2[0], pp[1]);
+ cp ++;
+ cp2 ++;
+ pp += 4;
+ } while (--x);
+ cp += incr;
+ cp2 += incr;
+ pp += fromskew;
+ h-=2;
+ }
+ if (h==1) {
+ x = w;
+ do {
+ uint32 Cb = pp[2];
+ uint32 Cr = pp[3];
+ YCbCrtoRGB(cp[0], pp[0]);
+ cp ++;
+ pp += 4;
+ } while (--x);
+ }
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ no subsampling => RGB
+ */
+DECLAREContigPutFunc(putcontig8bitYCbCr11tile)
+{
+ (void) y;
+ fromskew = (fromskew / 1) * (1 * 1 + 2);
+ do {
+ x = w; /* was x = w>>1; patched 2000/09/25 warmerda@home.com */
+ do {
+ int32 Cb = pp[1];
+ int32 Cr = pp[2];
+
+ YCbCrtoRGB(*cp++, pp[0]);
+
+ pp += 3;
+ } while (--x);
+ cp += toskew;
+ pp += fromskew;
+ } while (--h);
+}
+
+/*
+ * 8-bit packed YCbCr samples w/ no subsampling => RGB
+ */
+DECLARESepPutFunc(putseparate8bitYCbCr11tile)
+{
+ (void) y;
+ (void) a;
+ /* TODO: naming of input vars is still off, change obfuscating declaration inside define, or resolve obfuscation */
+ for( ; h > 0; --h) {
+ x = w;
+ do {
+ uint32 dr, dg, db;
+ TIFFYCbCrtoRGB(img->ycbcr,*r++,*g++,*b++,&dr,&dg,&db);
+ *cp++ = PACK(dr,dg,db);
+ } while (--x);
+ SKEW(r, g, b, fromskew);
+ cp += toskew;
+ }
+}
+#undef YCbCrtoRGB
+
+static int isInRefBlackWhiteRange(float f)
+{
+ return f > (float)(-0x7FFFFFFF + 128) && f < (float)0x7FFFFFFF;
+}
+
+static int
+initYCbCrConversion(TIFFRGBAImage* img)
+{
+ static const char module[] = "initYCbCrConversion";
+
+ float *luma, *refBlackWhite;
+
+ if (img->ycbcr == NULL) {
+ img->ycbcr = (TIFFYCbCrToRGB*) _TIFFmalloc(
+ TIFFroundup_32(sizeof (TIFFYCbCrToRGB), sizeof (long))
+ + 4*256*sizeof (TIFFRGBValue)
+ + 2*256*sizeof (int)
+ + 3*256*sizeof (int32)
+ );
+ if (img->ycbcr == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "No space for YCbCr->RGB conversion state");
+ return (0);
+ }
+ }
+
+ TIFFGetFieldDefaulted(img->tif, TIFFTAG_YCBCRCOEFFICIENTS, &luma);
+ TIFFGetFieldDefaulted(img->tif, TIFFTAG_REFERENCEBLACKWHITE,
+ &refBlackWhite);
+
+ /* Do some validation to avoid later issues. Detect NaN for now */
+ /* and also if lumaGreen is zero since we divide by it later */
+ if( luma[0] != luma[0] ||
+ luma[1] != luma[1] ||
+ luma[1] == 0.0 ||
+ luma[2] != luma[2] )
+ {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "Invalid values for YCbCrCoefficients tag");
+ return (0);
+ }
+
+ if( !isInRefBlackWhiteRange(refBlackWhite[0]) ||
+ !isInRefBlackWhiteRange(refBlackWhite[1]) ||
+ !isInRefBlackWhiteRange(refBlackWhite[2]) ||
+ !isInRefBlackWhiteRange(refBlackWhite[3]) ||
+ !isInRefBlackWhiteRange(refBlackWhite[4]) ||
+ !isInRefBlackWhiteRange(refBlackWhite[5]) )
+ {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "Invalid values for ReferenceBlackWhite tag");
+ return (0);
+ }
+
+ if (TIFFYCbCrToRGBInit(img->ycbcr, luma, refBlackWhite) < 0)
+ return(0);
+ return (1);
+}
+
+static tileContigRoutine
+initCIELabConversion(TIFFRGBAImage* img)
+{
+ static const char module[] = "initCIELabConversion";
+
+ float *whitePoint;
+ float refWhite[3];
+
+ TIFFGetFieldDefaulted(img->tif, TIFFTAG_WHITEPOINT, &whitePoint);
+ if (whitePoint[1] == 0.0f ) {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "Invalid value for WhitePoint tag.");
+ return NULL;
+ }
+
+ if (!img->cielab) {
+ img->cielab = (TIFFCIELabToRGB *)
+ _TIFFmalloc(sizeof(TIFFCIELabToRGB));
+ if (!img->cielab) {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "No space for CIE L*a*b*->RGB conversion state.");
+ return NULL;
+ }
+ }
+
+ refWhite[1] = 100.0F;
+ refWhite[0] = whitePoint[0] / whitePoint[1] * refWhite[1];
+ refWhite[2] = (1.0F - whitePoint[0] - whitePoint[1])
+ / whitePoint[1] * refWhite[1];
+ if (TIFFCIELabToRGBInit(img->cielab, &display_sRGB, refWhite) < 0) {
+ TIFFErrorExt(img->tif->tif_clientdata, module,
+ "Failed to initialize CIE L*a*b*->RGB conversion state.");
+ _TIFFfree(img->cielab);
+ return NULL;
+ }
+
+ return putcontig8bitCIELab;
+}
+
+/*
+ * Greyscale images with less than 8 bits/sample are handled
+ * with a table to avoid lots of shifts and masks. The table
+ * is setup so that put*bwtile (below) can retrieve 8/bitspersample
+ * pixel values simply by indexing into the table with one
+ * number.
+ */
+static int
+makebwmap(TIFFRGBAImage* img)
+{
+ TIFFRGBValue* Map = img->Map;
+ int bitspersample = img->bitspersample;
+ int nsamples = 8 / bitspersample;
+ int i;
+ uint32* p;
+
+ if( nsamples == 0 )
+ nsamples = 1;
+
+ img->BWmap = (uint32**) _TIFFmalloc(
+ 256*sizeof (uint32 *)+(256*nsamples*sizeof(uint32)));
+ if (img->BWmap == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, TIFFFileName(img->tif), "No space for B&W mapping table");
+ return (0);
+ }
+ p = (uint32*)(img->BWmap + 256);
+ for (i = 0; i < 256; i++) {
+ TIFFRGBValue c;
+ img->BWmap[i] = p;
+ switch (bitspersample) {
+#define GREY(x) c = Map[x]; *p++ = PACK(c,c,c);
+ case 1:
+ GREY(i>>7);
+ GREY((i>>6)&1);
+ GREY((i>>5)&1);
+ GREY((i>>4)&1);
+ GREY((i>>3)&1);
+ GREY((i>>2)&1);
+ GREY((i>>1)&1);
+ GREY(i&1);
+ break;
+ case 2:
+ GREY(i>>6);
+ GREY((i>>4)&3);
+ GREY((i>>2)&3);
+ GREY(i&3);
+ break;
+ case 4:
+ GREY(i>>4);
+ GREY(i&0xf);
+ break;
+ case 8:
+ case 16:
+ GREY(i);
+ break;
+ }
+#undef GREY
+ }
+ return (1);
+}
+
+/*
+ * Construct a mapping table to convert from the range
+ * of the data samples to [0,255] --for display. This
+ * process also handles inverting B&W images when needed.
+ */
+static int
+setupMap(TIFFRGBAImage* img)
+{
+ int32 x, range;
+
+ range = (int32)((1L<<img->bitspersample)-1);
+
+ /* treat 16 bit the same as eight bit */
+ if( img->bitspersample == 16 )
+ range = (int32) 255;
+
+ img->Map = (TIFFRGBValue*) _TIFFmalloc((range+1) * sizeof (TIFFRGBValue));
+ if (img->Map == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, TIFFFileName(img->tif),
+ "No space for photometric conversion table");
+ return (0);
+ }
+ if (img->photometric == PHOTOMETRIC_MINISWHITE) {
+ for (x = 0; x <= range; x++)
+ img->Map[x] = (TIFFRGBValue) (((range - x) * 255) / range);
+ } else {
+ for (x = 0; x <= range; x++)
+ img->Map[x] = (TIFFRGBValue) ((x * 255) / range);
+ }
+ if (img->bitspersample <= 16 &&
+ (img->photometric == PHOTOMETRIC_MINISBLACK ||
+ img->photometric == PHOTOMETRIC_MINISWHITE)) {
+ /*
+ * Use photometric mapping table to construct
+ * unpacking tables for samples <= 8 bits.
+ */
+ if (!makebwmap(img))
+ return (0);
+ /* no longer need Map, free it */
+ _TIFFfree(img->Map);
+ img->Map = NULL;
+ }
+ return (1);
+}
+
+static int
+checkcmap(TIFFRGBAImage* img)
+{
+ uint16* r = img->redcmap;
+ uint16* g = img->greencmap;
+ uint16* b = img->bluecmap;
+ long n = 1L<<img->bitspersample;
+
+ while (n-- > 0)
+ if (*r++ >= 256 || *g++ >= 256 || *b++ >= 256)
+ return (16);
+ return (8);
+}
+
+static void
+cvtcmap(TIFFRGBAImage* img)
+{
+ uint16* r = img->redcmap;
+ uint16* g = img->greencmap;
+ uint16* b = img->bluecmap;
+ long i;
+
+ for (i = (1L<<img->bitspersample)-1; i >= 0; i--) {
+#define CVT(x) ((uint16)((x)>>8))
+ r[i] = CVT(r[i]);
+ g[i] = CVT(g[i]);
+ b[i] = CVT(b[i]);
+#undef CVT
+ }
+}
+
+/*
+ * Palette images with <= 8 bits/sample are handled
+ * with a table to avoid lots of shifts and masks. The table
+ * is setup so that put*cmaptile (below) can retrieve 8/bitspersample
+ * pixel values simply by indexing into the table with one
+ * number.
+ */
+static int
+makecmap(TIFFRGBAImage* img)
+{
+ int bitspersample = img->bitspersample;
+ int nsamples = 8 / bitspersample;
+ uint16* r = img->redcmap;
+ uint16* g = img->greencmap;
+ uint16* b = img->bluecmap;
+ uint32 *p;
+ int i;
+
+ img->PALmap = (uint32**) _TIFFmalloc(
+ 256*sizeof (uint32 *)+(256*nsamples*sizeof(uint32)));
+ if (img->PALmap == NULL) {
+ TIFFErrorExt(img->tif->tif_clientdata, TIFFFileName(img->tif), "No space for Palette mapping table");
+ return (0);
+ }
+ p = (uint32*)(img->PALmap + 256);
+ for (i = 0; i < 256; i++) {
+ TIFFRGBValue c;
+ img->PALmap[i] = p;
+#define CMAP(x) c = (TIFFRGBValue) x; *p++ = PACK(r[c]&0xff, g[c]&0xff, b[c]&0xff);
+ switch (bitspersample) {
+ case 1:
+ CMAP(i>>7);
+ CMAP((i>>6)&1);
+ CMAP((i>>5)&1);
+ CMAP((i>>4)&1);
+ CMAP((i>>3)&1);
+ CMAP((i>>2)&1);
+ CMAP((i>>1)&1);
+ CMAP(i&1);
+ break;
+ case 2:
+ CMAP(i>>6);
+ CMAP((i>>4)&3);
+ CMAP((i>>2)&3);
+ CMAP(i&3);
+ break;
+ case 4:
+ CMAP(i>>4);
+ CMAP(i&0xf);
+ break;
+ case 8:
+ CMAP(i);
+ break;
+ }
+#undef CMAP
+ }
+ return (1);
+}
+
+/*
+ * Construct any mapping table used
+ * by the associated put routine.
+ */
+static int
+buildMap(TIFFRGBAImage* img)
+{
+ switch (img->photometric) {
+ case PHOTOMETRIC_RGB:
+ case PHOTOMETRIC_YCBCR:
+ case PHOTOMETRIC_SEPARATED:
+ if (img->bitspersample == 8)
+ break;
+ /* fall through... */
+ case PHOTOMETRIC_MINISBLACK:
+ case PHOTOMETRIC_MINISWHITE:
+ if (!setupMap(img))
+ return (0);
+ break;
+ case PHOTOMETRIC_PALETTE:
+ /*
+ * Convert 16-bit colormap to 8-bit (unless it looks
+ * like an old-style 8-bit colormap).
+ */
+ if (checkcmap(img) == 16)
+ cvtcmap(img);
+ else
+ TIFFWarningExt(img->tif->tif_clientdata, TIFFFileName(img->tif), "Assuming 8-bit colormap");
+ /*
+ * Use mapping table and colormap to construct
+ * unpacking tables for samples < 8 bits.
+ */
+ if (img->bitspersample <= 8 && !makecmap(img))
+ return (0);
+ break;
+ }
+ return (1);
+}
+
+/*
+ * Select the appropriate conversion routine for packed data.
+ */
+static int
+PickContigCase(TIFFRGBAImage* img)
+{
+ img->get = TIFFIsTiled(img->tif) ? gtTileContig : gtStripContig;
+ img->put.contig = NULL;
+ switch (img->photometric) {
+ case PHOTOMETRIC_RGB:
+ switch (img->bitspersample) {
+ case 8:
+ if (img->alpha == EXTRASAMPLE_ASSOCALPHA &&
+ img->samplesperpixel >= 4)
+ img->put.contig = putRGBAAcontig8bittile;
+ else if (img->alpha == EXTRASAMPLE_UNASSALPHA &&
+ img->samplesperpixel >= 4)
+ {
+ if (BuildMapUaToAa(img))
+ img->put.contig = putRGBUAcontig8bittile;
+ }
+ else if( img->samplesperpixel >= 3 )
+ img->put.contig = putRGBcontig8bittile;
+ break;
+ case 16:
+ if (img->alpha == EXTRASAMPLE_ASSOCALPHA &&
+ img->samplesperpixel >=4 )
+ {
+ if (BuildMapBitdepth16To8(img))
+ img->put.contig = putRGBAAcontig16bittile;
+ }
+ else if (img->alpha == EXTRASAMPLE_UNASSALPHA &&
+ img->samplesperpixel >=4 )
+ {
+ if (BuildMapBitdepth16To8(img) &&
+ BuildMapUaToAa(img))
+ img->put.contig = putRGBUAcontig16bittile;
+ }
+ else if( img->samplesperpixel >=3 )
+ {
+ if (BuildMapBitdepth16To8(img))
+ img->put.contig = putRGBcontig16bittile;
+ }
+ break;
+ }
+ break;
+ case PHOTOMETRIC_SEPARATED:
+ if (img->samplesperpixel >=4 && buildMap(img)) {
+ if (img->bitspersample == 8) {
+ if (!img->Map)
+ img->put.contig = putRGBcontig8bitCMYKtile;
+ else
+ img->put.contig = putRGBcontig8bitCMYKMaptile;
+ }
+ }
+ break;
+ case PHOTOMETRIC_PALETTE:
+ if (buildMap(img)) {
+ switch (img->bitspersample) {
+ case 8:
+ img->put.contig = put8bitcmaptile;
+ break;
+ case 4:
+ img->put.contig = put4bitcmaptile;
+ break;
+ case 2:
+ img->put.contig = put2bitcmaptile;
+ break;
+ case 1:
+ img->put.contig = put1bitcmaptile;
+ break;
+ }
+ }
+ break;
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ if (buildMap(img)) {
+ switch (img->bitspersample) {
+ case 16:
+ img->put.contig = put16bitbwtile;
+ break;
+ case 8:
+ if (img->alpha && img->samplesperpixel == 2)
+ img->put.contig = putagreytile;
+ else
+ img->put.contig = putgreytile;
+ break;
+ case 4:
+ img->put.contig = put4bitbwtile;
+ break;
+ case 2:
+ img->put.contig = put2bitbwtile;
+ break;
+ case 1:
+ img->put.contig = put1bitbwtile;
+ break;
+ }
+ }
+ break;
+ case PHOTOMETRIC_YCBCR:
+ if ((img->bitspersample==8) && (img->samplesperpixel==3))
+ {
+ if (initYCbCrConversion(img)!=0)
+ {
+ /*
+ * The 6.0 spec says that subsampling must be
+ * one of 1, 2, or 4, and that vertical subsampling
+ * must always be <= horizontal subsampling; so
+ * there are only a few possibilities and we just
+ * enumerate the cases.
+ * Joris: added support for the [1,2] case, nonetheless, to accommodate
+ * some OJPEG files
+ */
+ uint16 SubsamplingHor;
+ uint16 SubsamplingVer;
+ TIFFGetFieldDefaulted(img->tif, TIFFTAG_YCBCRSUBSAMPLING, &SubsamplingHor, &SubsamplingVer);
+ switch ((SubsamplingHor<<4)|SubsamplingVer) {
+ case 0x44:
+ img->put.contig = putcontig8bitYCbCr44tile;
+ break;
+ case 0x42:
+ img->put.contig = putcontig8bitYCbCr42tile;
+ break;
+ case 0x41:
+ img->put.contig = putcontig8bitYCbCr41tile;
+ break;
+ case 0x22:
+ img->put.contig = putcontig8bitYCbCr22tile;
+ break;
+ case 0x21:
+ img->put.contig = putcontig8bitYCbCr21tile;
+ break;
+ case 0x12:
+ img->put.contig = putcontig8bitYCbCr12tile;
+ break;
+ case 0x11:
+ img->put.contig = putcontig8bitYCbCr11tile;
+ break;
+ }
+ }
+ }
+ break;
+ case PHOTOMETRIC_CIELAB:
+ if (img->samplesperpixel == 3 && buildMap(img)) {
+ if (img->bitspersample == 8)
+ img->put.contig = initCIELabConversion(img);
+ break;
+ }
+ }
+ return ((img->get!=NULL) && (img->put.contig!=NULL));
+}
+
+/*
+ * Select the appropriate conversion routine for unpacked data.
+ *
+ * NB: we assume that unpacked single channel data is directed
+ * to the "packed routines.
+ */
+static int
+PickSeparateCase(TIFFRGBAImage* img)
+{
+ img->get = TIFFIsTiled(img->tif) ? gtTileSeparate : gtStripSeparate;
+ img->put.separate = NULL;
+ switch (img->photometric) {
+ case PHOTOMETRIC_MINISWHITE:
+ case PHOTOMETRIC_MINISBLACK:
+ /* greyscale images processed pretty much as RGB by gtTileSeparate */
+ case PHOTOMETRIC_RGB:
+ switch (img->bitspersample) {
+ case 8:
+ if (img->alpha == EXTRASAMPLE_ASSOCALPHA)
+ img->put.separate = putRGBAAseparate8bittile;
+ else if (img->alpha == EXTRASAMPLE_UNASSALPHA)
+ {
+ if (BuildMapUaToAa(img))
+ img->put.separate = putRGBUAseparate8bittile;
+ }
+ else
+ img->put.separate = putRGBseparate8bittile;
+ break;
+ case 16:
+ if (img->alpha == EXTRASAMPLE_ASSOCALPHA)
+ {
+ if (BuildMapBitdepth16To8(img))
+ img->put.separate = putRGBAAseparate16bittile;
+ }
+ else if (img->alpha == EXTRASAMPLE_UNASSALPHA)
+ {
+ if (BuildMapBitdepth16To8(img) &&
+ BuildMapUaToAa(img))
+ img->put.separate = putRGBUAseparate16bittile;
+ }
+ else
+ {
+ if (BuildMapBitdepth16To8(img))
+ img->put.separate = putRGBseparate16bittile;
+ }
+ break;
+ }
+ break;
+ case PHOTOMETRIC_SEPARATED:
+ if (img->bitspersample == 8 && img->samplesperpixel == 4)
+ {
+ img->alpha = 1; // Not alpha, but seems like the only way to get 4th band
+ img->put.separate = putCMYKseparate8bittile;
+ }
+ break;
+ case PHOTOMETRIC_YCBCR:
+ if ((img->bitspersample==8) && (img->samplesperpixel==3))
+ {
+ if (initYCbCrConversion(img)!=0)
+ {
+ uint16 hs, vs;
+ TIFFGetFieldDefaulted(img->tif, TIFFTAG_YCBCRSUBSAMPLING, &hs, &vs);
+ switch ((hs<<4)|vs) {
+ case 0x11:
+ img->put.separate = putseparate8bitYCbCr11tile;
+ break;
+ /* TODO: add other cases here */
+ }
+ }
+ }
+ break;
+ }
+ return ((img->get!=NULL) && (img->put.separate!=NULL));
+}
+
+static int
+BuildMapUaToAa(TIFFRGBAImage* img)
+{
+ static const char module[]="BuildMapUaToAa";
+ uint8* m;
+ uint16 na,nv;
+ assert(img->UaToAa==NULL);
+ img->UaToAa=_TIFFmalloc(65536);
+ if (img->UaToAa==NULL)
+ {
+ TIFFErrorExt(img->tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ m=img->UaToAa;
+ for (na=0; na<256; na++)
+ {
+ for (nv=0; nv<256; nv++)
+ *m++=(uint8)((nv*na+127)/255);
+ }
+ return(1);
+}
+
+static int
+BuildMapBitdepth16To8(TIFFRGBAImage* img)
+{
+ static const char module[]="BuildMapBitdepth16To8";
+ uint8* m;
+ uint32 n;
+ assert(img->Bitdepth16To8==NULL);
+ img->Bitdepth16To8=_TIFFmalloc(65536);
+ if (img->Bitdepth16To8==NULL)
+ {
+ TIFFErrorExt(img->tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ m=img->Bitdepth16To8;
+ for (n=0; n<65536; n++)
+ *m++=(uint8)((n+128)/257);
+ return(1);
+}
+
+
+/*
+ * Read a whole strip off data from the file, and convert to RGBA form.
+ * If this is the last strip, then it will only contain the portion of
+ * the strip that is actually within the image space. The result is
+ * organized in bottom to top form.
+ */
+
+
+int
+TIFFReadRGBAStrip(TIFF* tif, uint32 row, uint32 * raster )
+
+{
+ return TIFFReadRGBAStripExt(tif, row, raster, 0 );
+}
+
+int
+TIFFReadRGBAStripExt(TIFF* tif, uint32 row, uint32 * raster, int stop_on_error)
+
+{
+ char emsg[1024] = "";
+ TIFFRGBAImage img;
+ int ok;
+ uint32 rowsperstrip, rows_to_read;
+
+ if( TIFFIsTiled( tif ) )
+ {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif),
+ "Can't use TIFFReadRGBAStrip() with tiled file.");
+ return (0);
+ }
+
+ TIFFGetFieldDefaulted(tif, TIFFTAG_ROWSPERSTRIP, &rowsperstrip);
+ if( (row % rowsperstrip) != 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif),
+ "Row passed to TIFFReadRGBAStrip() must be first in a strip.");
+ return (0);
+ }
+
+ if (TIFFRGBAImageOK(tif, emsg) && TIFFRGBAImageBegin(&img, tif, stop_on_error, emsg)) {
+
+ img.row_offset = row;
+ img.col_offset = 0;
+
+ if( row + rowsperstrip > img.height )
+ rows_to_read = img.height - row;
+ else
+ rows_to_read = rowsperstrip;
+
+ ok = TIFFRGBAImageGet(&img, raster, img.width, rows_to_read );
+
+ TIFFRGBAImageEnd(&img);
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "%s", emsg);
+ ok = 0;
+ }
+
+ return (ok);
+}
+
+/*
+ * Read a whole tile off data from the file, and convert to RGBA form.
+ * The returned RGBA data is organized from bottom to top of tile,
+ * and may include zeroed areas if the tile extends off the image.
+ */
+
+int
+TIFFReadRGBATile(TIFF* tif, uint32 col, uint32 row, uint32 * raster)
+
+{
+ return TIFFReadRGBATileExt(tif, col, row, raster, 0 );
+}
+
+
+int
+TIFFReadRGBATileExt(TIFF* tif, uint32 col, uint32 row, uint32 * raster, int stop_on_error )
+{
+ char emsg[1024] = "";
+ TIFFRGBAImage img;
+ int ok;
+ uint32 tile_xsize, tile_ysize;
+ uint32 read_xsize, read_ysize;
+ uint32 i_row;
+
+ /*
+ * Verify that our request is legal - on a tile file, and on a
+ * tile boundary.
+ */
+
+ if( !TIFFIsTiled( tif ) )
+ {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif),
+ "Can't use TIFFReadRGBATile() with stripped file.");
+ return (0);
+ }
+
+ TIFFGetFieldDefaulted(tif, TIFFTAG_TILEWIDTH, &tile_xsize);
+ TIFFGetFieldDefaulted(tif, TIFFTAG_TILELENGTH, &tile_ysize);
+ if( (col % tile_xsize) != 0 || (row % tile_ysize) != 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif),
+ "Row/col passed to TIFFReadRGBATile() must be top"
+ "left corner of a tile.");
+ return (0);
+ }
+
+ /*
+ * Setup the RGBA reader.
+ */
+
+ if (!TIFFRGBAImageOK(tif, emsg)
+ || !TIFFRGBAImageBegin(&img, tif, stop_on_error, emsg)) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "%s", emsg);
+ return( 0 );
+ }
+
+ /*
+ * The TIFFRGBAImageGet() function doesn't allow us to get off the
+ * edge of the image, even to fill an otherwise valid tile. So we
+ * figure out how much we can read, and fix up the tile buffer to
+ * a full tile configuration afterwards.
+ */
+
+ if( row + tile_ysize > img.height )
+ read_ysize = img.height - row;
+ else
+ read_ysize = tile_ysize;
+
+ if( col + tile_xsize > img.width )
+ read_xsize = img.width - col;
+ else
+ read_xsize = tile_xsize;
+
+ /*
+ * Read the chunk of imagery.
+ */
+
+ img.row_offset = row;
+ img.col_offset = col;
+
+ ok = TIFFRGBAImageGet(&img, raster, read_xsize, read_ysize );
+
+ TIFFRGBAImageEnd(&img);
+
+ /*
+ * If our read was incomplete we will need to fix up the tile by
+ * shifting the data around as if a full tile of data is being returned.
+ *
+ * This is all the more complicated because the image is organized in
+ * bottom to top format.
+ */
+
+ if( read_xsize == tile_xsize && read_ysize == tile_ysize )
+ return( ok );
+
+ for( i_row = 0; i_row < read_ysize; i_row++ ) {
+ memmove( raster + (tile_ysize - i_row - 1) * tile_xsize,
+ raster + (read_ysize - i_row - 1) * read_xsize,
+ read_xsize * sizeof(uint32) );
+ _TIFFmemset( raster + (tile_ysize - i_row - 1) * tile_xsize+read_xsize,
+ 0, sizeof(uint32) * (tile_xsize - read_xsize) );
+ }
+
+ for( i_row = read_ysize; i_row < tile_ysize; i_row++ ) {
+ _TIFFmemset( raster + (tile_ysize - i_row - 1) * tile_xsize,
+ 0, sizeof(uint32) * tile_xsize );
+ }
+
+ return (ok);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_jbig.c b/test/monniaux/tiff-4.0.10/tif_jbig.c
new file mode 100644
index 00000000..7ffe8851
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_jbig.c
@@ -0,0 +1,232 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * JBIG Compression Algorithm Support.
+ * Contributed by Lee Howard <faxguy@deanox.com>
+ *
+ */
+
+#include "tiffiop.h"
+
+#ifdef JBIG_SUPPORT
+#include "jbig.h"
+
+static int JBIGSetupDecode(TIFF* tif)
+{
+ if (TIFFNumberOfStrips(tif) != 1)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "JBIG", "Multistrip images not supported in decoder");
+ return 0;
+ }
+
+ return 1;
+}
+
+static int JBIGDecode(TIFF* tif, uint8* buffer, tmsize_t size, uint16 s)
+{
+ struct jbg_dec_state decoder;
+ int decodeStatus = 0;
+ unsigned char* pImage = NULL;
+ unsigned long decodedSize;
+ (void) s;
+
+ if (isFillOrder(tif, tif->tif_dir.td_fillorder))
+ {
+ TIFFReverseBits(tif->tif_rawcp, tif->tif_rawcc);
+ }
+
+ jbg_dec_init(&decoder);
+
+#if defined(HAVE_JBG_NEWLEN)
+ jbg_newlen(tif->tif_rawcp, (size_t)tif->tif_rawcc);
+ /*
+ * I do not check the return status of jbg_newlen because even if this
+ * function fails it does not necessarily mean that decoding the image
+ * will fail. It is generally only needed for received fax images
+ * that do not contain the actual length of the image in the BIE
+ * header. I do not log when an error occurs because that will cause
+ * problems when converting JBIG encoded TIFF's to
+ * PostScript. As long as the actual image length is contained in the
+ * BIE header jbg_dec_in should succeed.
+ */
+#endif /* HAVE_JBG_NEWLEN */
+
+ decodeStatus = jbg_dec_in(&decoder, (unsigned char*)tif->tif_rawcp,
+ (size_t)tif->tif_rawcc, NULL);
+ if (JBG_EOK != decodeStatus)
+ {
+ /*
+ * XXX: JBG_EN constant was defined in pre-2.0 releases of the
+ * JBIG-KIT. Since the 2.0 the error reporting functions were
+ * changed. We will handle both cases here.
+ */
+ TIFFErrorExt(tif->tif_clientdata,
+ "JBIG", "Error (%d) decoding: %s",
+ decodeStatus,
+#if defined(JBG_EN)
+ jbg_strerror(decodeStatus, JBG_EN)
+#else
+ jbg_strerror(decodeStatus)
+#endif
+ );
+ jbg_dec_free(&decoder);
+ return 0;
+ }
+
+ decodedSize = jbg_dec_getsize(&decoder);
+ if( (tmsize_t)decodedSize < size )
+ {
+ TIFFWarningExt(tif->tif_clientdata, "JBIG",
+ "Only decoded %lu bytes, whereas %lu requested",
+ decodedSize, (unsigned long)size);
+ }
+ else if( (tmsize_t)decodedSize > size )
+ {
+ TIFFErrorExt(tif->tif_clientdata, "JBIG",
+ "Decoded %lu bytes, whereas %lu were requested",
+ decodedSize, (unsigned long)size);
+ jbg_dec_free(&decoder);
+ return 0;
+ }
+ pImage = jbg_dec_getimage(&decoder, 0);
+ _TIFFmemcpy(buffer, pImage, decodedSize);
+ jbg_dec_free(&decoder);
+
+ tif->tif_rawcp += tif->tif_rawcc;
+ tif->tif_rawcc = 0;
+
+ return 1;
+}
+
+static int JBIGSetupEncode(TIFF* tif)
+{
+ if (TIFFNumberOfStrips(tif) != 1)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "JBIG", "Multistrip images not supported in encoder");
+ return 0;
+ }
+
+ return 1;
+}
+
+static int JBIGCopyEncodedData(TIFF* tif, unsigned char* pp, size_t cc, uint16 s)
+{
+ (void) s;
+ while (cc > 0)
+ {
+ tmsize_t n = (tmsize_t)cc;
+
+ if (tif->tif_rawcc + n > tif->tif_rawdatasize)
+ {
+ n = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+
+ assert(n > 0);
+ _TIFFmemcpy(tif->tif_rawcp, pp, n);
+ tif->tif_rawcp += n;
+ tif->tif_rawcc += n;
+ pp += n;
+ cc -= (size_t)n;
+ if (tif->tif_rawcc >= tif->tif_rawdatasize &&
+ !TIFFFlushData1(tif))
+ {
+ return (-1);
+ }
+ }
+
+ return (1);
+}
+
+static void JBIGOutputBie(unsigned char* buffer, size_t len, void* userData)
+{
+ TIFF* tif = (TIFF*)userData;
+
+ if (isFillOrder(tif, tif->tif_dir.td_fillorder))
+ {
+ TIFFReverseBits(buffer, (tmsize_t)len);
+ }
+
+ JBIGCopyEncodedData(tif, buffer, len, 0);
+}
+
+static int JBIGEncode(TIFF* tif, uint8* buffer, tmsize_t size, uint16 s)
+{
+ TIFFDirectory* dir = &tif->tif_dir;
+ struct jbg_enc_state encoder;
+
+ (void) size, (void) s;
+
+ jbg_enc_init(&encoder,
+ dir->td_imagewidth,
+ dir->td_imagelength,
+ 1,
+ &buffer,
+ JBIGOutputBie,
+ tif);
+ /*
+ * jbg_enc_out does the "real" encoding. As data is encoded,
+ * JBIGOutputBie is called, which writes the data to the directory.
+ */
+ jbg_enc_out(&encoder);
+ jbg_enc_free(&encoder);
+
+ return 1;
+}
+
+int TIFFInitJBIG(TIFF* tif, int scheme)
+{
+ assert(scheme == COMPRESSION_JBIG);
+
+ /*
+ * These flags are set so the JBIG Codec can control when to reverse
+ * bits and when not to and to allow the jbig decoder and bit reverser
+ * to write to memory when necessary.
+ */
+ tif->tif_flags |= TIFF_NOBITREV;
+ tif->tif_flags &= ~TIFF_MAPPED;
+
+ /* Setup the function pointers for encode, decode, and cleanup. */
+ tif->tif_setupdecode = JBIGSetupDecode;
+ tif->tif_decodestrip = JBIGDecode;
+
+ tif->tif_setupencode = JBIGSetupEncode;
+ tif->tif_encodestrip = JBIGEncode;
+
+ return 1;
+}
+
+#endif /* JBIG_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_jpeg.c b/test/monniaux/tiff-4.0.10/tif_jpeg.c
new file mode 100644
index 00000000..f2ddc331
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_jpeg.c
@@ -0,0 +1,2599 @@
+/*
+ * Copyright (c) 1994-1997 Sam Leffler
+ * Copyright (c) 1994-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#define WIN32_LEAN_AND_MEAN
+#define VC_EXTRALEAN
+
+#include "tiffiop.h"
+#include <stdlib.h>
+
+#ifdef JPEG_SUPPORT
+
+/*
+ * TIFF Library
+ *
+ * JPEG Compression support per TIFF Technical Note #2
+ * (*not* per the original TIFF 6.0 spec).
+ *
+ * This file is simply an interface to the libjpeg library written by
+ * the Independent JPEG Group. You need release 5 or later of the IJG
+ * code, which you can find on the Internet at ftp.uu.net:/graphics/jpeg/.
+ *
+ * Contributed by Tom Lane <tgl@sss.pgh.pa.us>.
+ */
+#include <setjmp.h>
+
+int TIFFFillStrip(TIFF* tif, uint32 strip);
+int TIFFFillTile(TIFF* tif, uint32 tile);
+int TIFFReInitJPEG_12( TIFF *tif, int scheme, int is_encode );
+int TIFFJPEGIsFullStripRequired_12(TIFF* tif);
+
+/* We undefine FAR to avoid conflict with JPEG definition */
+
+#ifdef FAR
+#undef FAR
+#endif
+
+/*
+ Libjpeg's jmorecfg.h defines INT16 and INT32, but only if XMD_H is
+ not defined. Unfortunately, the MinGW and Borland compilers include
+ a typedef for INT32, which causes a conflict. MSVC does not include
+ a conflicting typedef given the headers which are included.
+*/
+#if defined(__BORLANDC__) || defined(__MINGW32__)
+# define XMD_H 1
+#endif
+
+/*
+ The windows RPCNDR.H file defines boolean, but defines it with the
+ unsigned char size. You should compile JPEG library using appropriate
+ definitions in jconfig.h header, but many users compile library in wrong
+ way. That causes errors of the following type:
+
+ "JPEGLib: JPEG parameter struct mismatch: library thinks size is 432,
+ caller expects 464"
+
+ For such users we will fix the problem here. See install.doc file from
+ the JPEG library distribution for details.
+*/
+
+/* Define "boolean" as unsigned char, not int, per Windows custom. */
+#if defined(__WIN32__) && !defined(__MINGW32__)
+# ifndef __RPCNDR_H__ /* don't conflict if rpcndr.h already read */
+ typedef unsigned char boolean;
+# endif
+# define HAVE_BOOLEAN /* prevent jmorecfg.h from redefining it */
+#endif
+
+#include "jpeglib.h"
+#include "jerror.h"
+
+/*
+ * Do we want to do special processing suitable for when JSAMPLE is a
+ * 16bit value?
+ */
+
+#if defined(JPEG_LIB_MK1)
+# define JPEG_LIB_MK1_OR_12BIT 1
+#elif BITS_IN_JSAMPLE == 12
+# define JPEG_LIB_MK1_OR_12BIT 1
+#endif
+
+/*
+ * We are using width_in_blocks which is supposed to be private to
+ * libjpeg. Unfortunately, the libjpeg delivered with Cygwin has
+ * renamed this member to width_in_data_units. Since the header has
+ * also renamed a define, use that unique define name in order to
+ * detect the problem header and adjust to suit.
+ */
+#if defined(D_MAX_DATA_UNITS_IN_MCU)
+#define width_in_blocks width_in_data_units
+#endif
+
+/*
+ * On some machines it may be worthwhile to use _setjmp or sigsetjmp
+ * in place of plain setjmp. These macros will make it easier.
+ */
+#define SETJMP(jbuf) setjmp(jbuf)
+#define LONGJMP(jbuf,code) longjmp(jbuf,code)
+#define JMP_BUF jmp_buf
+
+typedef struct jpeg_destination_mgr jpeg_destination_mgr;
+typedef struct jpeg_source_mgr jpeg_source_mgr;
+typedef struct jpeg_error_mgr jpeg_error_mgr;
+
+/*
+ * State block for each open TIFF file using
+ * libjpeg to do JPEG compression/decompression.
+ *
+ * libjpeg's visible state is either a jpeg_compress_struct
+ * or jpeg_decompress_struct depending on which way we
+ * are going. comm can be used to refer to the fields
+ * which are common to both.
+ *
+ * NB: cinfo is required to be the first member of JPEGState,
+ * so we can safely cast JPEGState* -> jpeg_xxx_struct*
+ * and vice versa!
+ */
+typedef struct {
+ union {
+ struct jpeg_compress_struct c;
+ struct jpeg_decompress_struct d;
+ struct jpeg_common_struct comm;
+ } cinfo; /* NB: must be first */
+ int cinfo_initialized;
+
+ jpeg_error_mgr err; /* libjpeg error manager */
+ JMP_BUF exit_jmpbuf; /* for catching libjpeg failures */
+
+ struct jpeg_progress_mgr progress;
+ /*
+ * The following two members could be a union, but
+ * they're small enough that it's not worth the effort.
+ */
+ jpeg_destination_mgr dest; /* data dest for compression */
+ jpeg_source_mgr src; /* data source for decompression */
+ /* private state */
+ TIFF* tif; /* back link needed by some code */
+ uint16 photometric; /* copy of PhotometricInterpretation */
+ uint16 h_sampling; /* luminance sampling factors */
+ uint16 v_sampling;
+ tmsize_t bytesperline; /* decompressed bytes per scanline */
+ /* pointers to intermediate buffers when processing downsampled data */
+ JSAMPARRAY ds_buffer[MAX_COMPONENTS];
+ int scancount; /* number of "scanlines" accumulated */
+ int samplesperclump;
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+ TIFFPrintMethod printdir; /* super-class method */
+ TIFFStripMethod defsparent; /* super-class method */
+ TIFFTileMethod deftparent; /* super-class method */
+ /* pseudo-tag fields */
+ void* jpegtables; /* JPEGTables tag value, or NULL */
+ uint32 jpegtables_length; /* number of bytes in same */
+ int jpegquality; /* Compression quality level */
+ int jpegcolormode; /* Auto RGB<=>YCbCr convert? */
+ int jpegtablesmode; /* What to put in JPEGTables */
+
+ int ycbcrsampling_fetched;
+ int max_allowed_scan_number;
+} JPEGState;
+
+#define JState(tif) ((JPEGState*)(tif)->tif_data)
+
+static int JPEGDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int JPEGDecodeRaw(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int JPEGEncode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int JPEGEncodeRaw(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int JPEGInitializeLibJPEG(TIFF * tif, int decode );
+static int DecodeRowError(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+
+#define FIELD_JPEGTABLES (FIELD_CODEC+0)
+
+static const TIFFField jpegFields[] = {
+ { TIFFTAG_JPEGTABLES, -3, -3, TIFF_UNDEFINED, 0, TIFF_SETGET_C32_UINT8, TIFF_SETGET_C32_UINT8, FIELD_JPEGTABLES, FALSE, TRUE, "JPEGTables", NULL },
+ { TIFFTAG_JPEGQUALITY, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, TRUE, FALSE, "", NULL },
+ { TIFFTAG_JPEGCOLORMODE, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "", NULL },
+ { TIFFTAG_JPEGTABLESMODE, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "", NULL }
+};
+
+/*
+ * libjpeg interface layer.
+ *
+ * We use setjmp/longjmp to return control to libtiff
+ * when a fatal error is encountered within the JPEG
+ * library. We also direct libjpeg error and warning
+ * messages through the appropriate libtiff handlers.
+ */
+
+/*
+ * Error handling routines (these replace corresponding
+ * IJG routines from jerror.c). These are used for both
+ * compression and decompression.
+ */
+static void
+TIFFjpeg_error_exit(j_common_ptr cinfo)
+{
+ JPEGState *sp = (JPEGState *) cinfo; /* NB: cinfo assumed first */
+ char buffer[JMSG_LENGTH_MAX];
+
+ (*cinfo->err->format_message) (cinfo, buffer);
+ TIFFErrorExt(sp->tif->tif_clientdata, "JPEGLib", "%s", buffer); /* display the error message */
+ jpeg_abort(cinfo); /* clean up libjpeg state */
+ LONGJMP(sp->exit_jmpbuf, 1); /* return to libtiff caller */
+}
+
+/*
+ * This routine is invoked only for warning messages,
+ * since error_exit does its own thing and trace_level
+ * is never set > 0.
+ */
+static void
+TIFFjpeg_output_message(j_common_ptr cinfo)
+{
+ char buffer[JMSG_LENGTH_MAX];
+
+ (*cinfo->err->format_message) (cinfo, buffer);
+ TIFFWarningExt(((JPEGState *) cinfo)->tif->tif_clientdata, "JPEGLib", "%s", buffer);
+}
+
+/* Avoid the risk of denial-of-service on crafted JPEGs with an insane */
+/* number of scans. */
+/* See http://www.libjpeg-turbo.org/pmwiki/uploads/About/TwoIssueswiththeJPEGStandard.pdf */
+static void
+TIFFjpeg_progress_monitor(j_common_ptr cinfo)
+{
+ JPEGState *sp = (JPEGState *) cinfo; /* NB: cinfo assumed first */
+ if (cinfo->is_decompressor)
+ {
+ const int scan_no =
+ ((j_decompress_ptr)cinfo)->input_scan_number;
+ if (scan_no >= sp->max_allowed_scan_number)
+ {
+ TIFFErrorExt(((JPEGState *) cinfo)->tif->tif_clientdata,
+ "TIFFjpeg_progress_monitor",
+ "Scan number %d exceeds maximum scans (%d). This limit "
+ "can be raised through the LIBTIFF_JPEG_MAX_ALLOWED_SCAN_NUMBER "
+ "environment variable.",
+ scan_no, sp->max_allowed_scan_number);
+
+ jpeg_abort(cinfo); /* clean up libjpeg state */
+ LONGJMP(sp->exit_jmpbuf, 1); /* return to libtiff caller */
+ }
+ }
+}
+
+
+/*
+ * Interface routines. This layer of routines exists
+ * primarily to limit side-effects from using setjmp.
+ * Also, normal/error returns are converted into return
+ * values per libtiff practice.
+ */
+#define CALLJPEG(sp, fail, op) (SETJMP((sp)->exit_jmpbuf) ? (fail) : (op))
+#define CALLVJPEG(sp, op) CALLJPEG(sp, 0, ((op),1))
+
+static int
+TIFFjpeg_create_compress(JPEGState* sp)
+{
+ /* initialize JPEG error handling */
+ sp->cinfo.c.err = jpeg_std_error(&sp->err);
+ sp->err.error_exit = TIFFjpeg_error_exit;
+ sp->err.output_message = TIFFjpeg_output_message;
+
+ /* set client_data to avoid UMR warning from tools like Purify */
+ sp->cinfo.c.client_data = NULL;
+
+ return CALLVJPEG(sp, jpeg_create_compress(&sp->cinfo.c));
+}
+
+static int
+TIFFjpeg_create_decompress(JPEGState* sp)
+{
+ /* initialize JPEG error handling */
+ sp->cinfo.d.err = jpeg_std_error(&sp->err);
+ sp->err.error_exit = TIFFjpeg_error_exit;
+ sp->err.output_message = TIFFjpeg_output_message;
+
+ /* set client_data to avoid UMR warning from tools like Purify */
+ sp->cinfo.d.client_data = NULL;
+
+ return CALLVJPEG(sp, jpeg_create_decompress(&sp->cinfo.d));
+}
+
+static int
+TIFFjpeg_set_defaults(JPEGState* sp)
+{
+ return CALLVJPEG(sp, jpeg_set_defaults(&sp->cinfo.c));
+}
+
+static int
+TIFFjpeg_set_colorspace(JPEGState* sp, J_COLOR_SPACE colorspace)
+{
+ return CALLVJPEG(sp, jpeg_set_colorspace(&sp->cinfo.c, colorspace));
+}
+
+static int
+TIFFjpeg_set_quality(JPEGState* sp, int quality, boolean force_baseline)
+{
+ return CALLVJPEG(sp,
+ jpeg_set_quality(&sp->cinfo.c, quality, force_baseline));
+}
+
+static int
+TIFFjpeg_suppress_tables(JPEGState* sp, boolean suppress)
+{
+ return CALLVJPEG(sp, jpeg_suppress_tables(&sp->cinfo.c, suppress));
+}
+
+static int
+TIFFjpeg_start_compress(JPEGState* sp, boolean write_all_tables)
+{
+ return CALLVJPEG(sp,
+ jpeg_start_compress(&sp->cinfo.c, write_all_tables));
+}
+
+static int
+TIFFjpeg_write_scanlines(JPEGState* sp, JSAMPARRAY scanlines, int num_lines)
+{
+ return CALLJPEG(sp, -1, (int) jpeg_write_scanlines(&sp->cinfo.c,
+ scanlines, (JDIMENSION) num_lines));
+}
+
+static int
+TIFFjpeg_write_raw_data(JPEGState* sp, JSAMPIMAGE data, int num_lines)
+{
+ return CALLJPEG(sp, -1, (int) jpeg_write_raw_data(&sp->cinfo.c,
+ data, (JDIMENSION) num_lines));
+}
+
+static int
+TIFFjpeg_finish_compress(JPEGState* sp)
+{
+ return CALLVJPEG(sp, jpeg_finish_compress(&sp->cinfo.c));
+}
+
+static int
+TIFFjpeg_write_tables(JPEGState* sp)
+{
+ return CALLVJPEG(sp, jpeg_write_tables(&sp->cinfo.c));
+}
+
+static int
+TIFFjpeg_read_header(JPEGState* sp, boolean require_image)
+{
+ return CALLJPEG(sp, -1, jpeg_read_header(&sp->cinfo.d, require_image));
+}
+
+static int
+TIFFjpeg_has_multiple_scans(JPEGState* sp)
+{
+ return CALLJPEG(sp, 0, jpeg_has_multiple_scans(&sp->cinfo.d));
+}
+
+static int
+TIFFjpeg_start_decompress(JPEGState* sp)
+{
+ const char* sz_max_allowed_scan_number;
+ /* progress monitor */
+ sp->cinfo.d.progress = &sp->progress;
+ sp->progress.progress_monitor = TIFFjpeg_progress_monitor;
+ sp->max_allowed_scan_number = 100;
+ sz_max_allowed_scan_number = getenv("LIBTIFF_JPEG_MAX_ALLOWED_SCAN_NUMBER");
+ if( sz_max_allowed_scan_number )
+ sp->max_allowed_scan_number = atoi(sz_max_allowed_scan_number);
+
+ return CALLVJPEG(sp, jpeg_start_decompress(&sp->cinfo.d));
+}
+
+static int
+TIFFjpeg_read_scanlines(JPEGState* sp, JSAMPARRAY scanlines, int max_lines)
+{
+ return CALLJPEG(sp, -1, (int) jpeg_read_scanlines(&sp->cinfo.d,
+ scanlines, (JDIMENSION) max_lines));
+}
+
+static int
+TIFFjpeg_read_raw_data(JPEGState* sp, JSAMPIMAGE data, int max_lines)
+{
+ return CALLJPEG(sp, -1, (int) jpeg_read_raw_data(&sp->cinfo.d,
+ data, (JDIMENSION) max_lines));
+}
+
+static int
+TIFFjpeg_finish_decompress(JPEGState* sp)
+{
+ return CALLJPEG(sp, -1, (int) jpeg_finish_decompress(&sp->cinfo.d));
+}
+
+static int
+TIFFjpeg_abort(JPEGState* sp)
+{
+ return CALLVJPEG(sp, jpeg_abort(&sp->cinfo.comm));
+}
+
+static int
+TIFFjpeg_destroy(JPEGState* sp)
+{
+ return CALLVJPEG(sp, jpeg_destroy(&sp->cinfo.comm));
+}
+
+static JSAMPARRAY
+TIFFjpeg_alloc_sarray(JPEGState* sp, int pool_id,
+ JDIMENSION samplesperrow, JDIMENSION numrows)
+{
+ return CALLJPEG(sp, (JSAMPARRAY) NULL,
+ (*sp->cinfo.comm.mem->alloc_sarray)
+ (&sp->cinfo.comm, pool_id, samplesperrow, numrows));
+}
+
+/*
+ * JPEG library destination data manager.
+ * These routines direct compressed data from libjpeg into the
+ * libtiff output buffer.
+ */
+
+static void
+std_init_destination(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+ TIFF* tif = sp->tif;
+
+ sp->dest.next_output_byte = (JOCTET*) tif->tif_rawdata;
+ sp->dest.free_in_buffer = (size_t) tif->tif_rawdatasize;
+}
+
+static boolean
+std_empty_output_buffer(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+ TIFF* tif = sp->tif;
+
+ /* the entire buffer has been filled */
+ tif->tif_rawcc = tif->tif_rawdatasize;
+
+#ifdef IPPJ_HUFF
+ /*
+ * The Intel IPP performance library does not necessarily fill up
+ * the whole output buffer on each pass, so only dump out the parts
+ * that have been filled.
+ * http://trac.osgeo.org/gdal/wiki/JpegIPP
+ */
+ if ( sp->dest.free_in_buffer >= 0 ) {
+ tif->tif_rawcc = tif->tif_rawdatasize - sp->dest.free_in_buffer;
+ }
+#endif
+
+ TIFFFlushData1(tif);
+ sp->dest.next_output_byte = (JOCTET*) tif->tif_rawdata;
+ sp->dest.free_in_buffer = (size_t) tif->tif_rawdatasize;
+
+ return (TRUE);
+}
+
+static void
+std_term_destination(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+ TIFF* tif = sp->tif;
+
+ tif->tif_rawcp = (uint8*) sp->dest.next_output_byte;
+ tif->tif_rawcc =
+ tif->tif_rawdatasize - (tmsize_t) sp->dest.free_in_buffer;
+ /* NB: libtiff does the final buffer flush */
+}
+
+static void
+TIFFjpeg_data_dest(JPEGState* sp, TIFF* tif)
+{
+ (void) tif;
+ sp->cinfo.c.dest = &sp->dest;
+ sp->dest.init_destination = std_init_destination;
+ sp->dest.empty_output_buffer = std_empty_output_buffer;
+ sp->dest.term_destination = std_term_destination;
+}
+
+/*
+ * Alternate destination manager for outputting to JPEGTables field.
+ */
+
+static void
+tables_init_destination(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+
+ /* while building, jpegtables_length is allocated buffer size */
+ sp->dest.next_output_byte = (JOCTET*) sp->jpegtables;
+ sp->dest.free_in_buffer = (size_t) sp->jpegtables_length;
+}
+
+static boolean
+tables_empty_output_buffer(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+ void* newbuf;
+
+ /* the entire buffer has been filled; enlarge it by 1000 bytes */
+ newbuf = _TIFFrealloc((void*) sp->jpegtables,
+ (tmsize_t) (sp->jpegtables_length + 1000));
+ if (newbuf == NULL)
+ ERREXIT1(cinfo, JERR_OUT_OF_MEMORY, 100);
+ sp->dest.next_output_byte = (JOCTET*) newbuf + sp->jpegtables_length;
+ sp->dest.free_in_buffer = (size_t) 1000;
+ sp->jpegtables = newbuf;
+ sp->jpegtables_length += 1000;
+ return (TRUE);
+}
+
+static void
+tables_term_destination(j_compress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+
+ /* set tables length to number of bytes actually emitted */
+ sp->jpegtables_length -= (uint32) sp->dest.free_in_buffer;
+}
+
+static int
+TIFFjpeg_tables_dest(JPEGState* sp, TIFF* tif)
+{
+ (void) tif;
+ /*
+ * Allocate a working buffer for building tables.
+ * Initial size is 1000 bytes, which is usually adequate.
+ */
+ if (sp->jpegtables)
+ _TIFFfree(sp->jpegtables);
+ sp->jpegtables_length = 1000;
+ sp->jpegtables = (void*) _TIFFmalloc((tmsize_t) sp->jpegtables_length);
+ if (sp->jpegtables == NULL) {
+ sp->jpegtables_length = 0;
+ TIFFErrorExt(sp->tif->tif_clientdata, "TIFFjpeg_tables_dest", "No space for JPEGTables");
+ return (0);
+ }
+ sp->cinfo.c.dest = &sp->dest;
+ sp->dest.init_destination = tables_init_destination;
+ sp->dest.empty_output_buffer = tables_empty_output_buffer;
+ sp->dest.term_destination = tables_term_destination;
+ return (1);
+}
+
+/*
+ * JPEG library source data manager.
+ * These routines supply compressed data to libjpeg.
+ */
+
+static void
+std_init_source(j_decompress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+ TIFF* tif = sp->tif;
+
+ sp->src.next_input_byte = (const JOCTET*) tif->tif_rawdata;
+ sp->src.bytes_in_buffer = (size_t) tif->tif_rawcc;
+}
+
+static boolean
+std_fill_input_buffer(j_decompress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState* ) cinfo;
+ static const JOCTET dummy_EOI[2] = { 0xFF, JPEG_EOI };
+
+#ifdef IPPJ_HUFF
+ /*
+ * The Intel IPP performance library does not necessarily read the whole
+ * input buffer in one pass, so it is possible to get here with data
+ * yet to read.
+ *
+ * We just return without doing anything, until the entire buffer has
+ * been read.
+ * http://trac.osgeo.org/gdal/wiki/JpegIPP
+ */
+ if( sp->src.bytes_in_buffer > 0 ) {
+ return (TRUE);
+ }
+#endif
+
+ /*
+ * Normally the whole strip/tile is read and so we don't need to do
+ * a fill. In the case of CHUNKY_STRIP_READ_SUPPORT we might not have
+ * all the data, but the rawdata is refreshed between scanlines and
+ * we push this into the io machinery in JPEGDecode().
+ * http://trac.osgeo.org/gdal/ticket/3894
+ */
+
+ WARNMS(cinfo, JWRN_JPEG_EOF);
+ /* insert a fake EOI marker */
+ sp->src.next_input_byte = dummy_EOI;
+ sp->src.bytes_in_buffer = 2;
+ return (TRUE);
+}
+
+static void
+std_skip_input_data(j_decompress_ptr cinfo, long num_bytes)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+
+ if (num_bytes > 0) {
+ if ((size_t)num_bytes > sp->src.bytes_in_buffer) {
+ /* oops, buffer overrun */
+ (void) std_fill_input_buffer(cinfo);
+ } else {
+ sp->src.next_input_byte += (size_t) num_bytes;
+ sp->src.bytes_in_buffer -= (size_t) num_bytes;
+ }
+ }
+}
+
+static void
+std_term_source(j_decompress_ptr cinfo)
+{
+ /* No work necessary here */
+ (void) cinfo;
+}
+
+static void
+TIFFjpeg_data_src(JPEGState* sp)
+{
+ sp->cinfo.d.src = &sp->src;
+ sp->src.init_source = std_init_source;
+ sp->src.fill_input_buffer = std_fill_input_buffer;
+ sp->src.skip_input_data = std_skip_input_data;
+ sp->src.resync_to_restart = jpeg_resync_to_restart;
+ sp->src.term_source = std_term_source;
+ sp->src.bytes_in_buffer = 0; /* for safety */
+ sp->src.next_input_byte = NULL;
+}
+
+/*
+ * Alternate source manager for reading from JPEGTables.
+ * We can share all the code except for the init routine.
+ */
+
+static void
+tables_init_source(j_decompress_ptr cinfo)
+{
+ JPEGState* sp = (JPEGState*) cinfo;
+
+ sp->src.next_input_byte = (const JOCTET*) sp->jpegtables;
+ sp->src.bytes_in_buffer = (size_t) sp->jpegtables_length;
+}
+
+static void
+TIFFjpeg_tables_src(JPEGState* sp)
+{
+ TIFFjpeg_data_src(sp);
+ sp->src.init_source = tables_init_source;
+}
+
+/*
+ * Allocate downsampled-data buffers needed for downsampled I/O.
+ * We use values computed in jpeg_start_compress or jpeg_start_decompress.
+ * We use libjpeg's allocator so that buffers will be released automatically
+ * when done with strip/tile.
+ * This is also a handy place to compute samplesperclump, bytesperline.
+ */
+static int
+alloc_downsampled_buffers(TIFF* tif, jpeg_component_info* comp_info,
+ int num_components)
+{
+ JPEGState* sp = JState(tif);
+ int ci;
+ jpeg_component_info* compptr;
+ JSAMPARRAY buf;
+ int samples_per_clump = 0;
+
+ for (ci = 0, compptr = comp_info; ci < num_components;
+ ci++, compptr++) {
+ samples_per_clump += compptr->h_samp_factor *
+ compptr->v_samp_factor;
+ buf = TIFFjpeg_alloc_sarray(sp, JPOOL_IMAGE,
+ compptr->width_in_blocks * DCTSIZE,
+ (JDIMENSION) (compptr->v_samp_factor*DCTSIZE));
+ if (buf == NULL)
+ return (0);
+ sp->ds_buffer[ci] = buf;
+ }
+ sp->samplesperclump = samples_per_clump;
+ return (1);
+}
+
+
+/*
+ * JPEG Decoding.
+ */
+
+#ifdef CHECK_JPEG_YCBCR_SUBSAMPLING
+
+#define JPEG_MARKER_SOF0 0xC0
+#define JPEG_MARKER_SOF1 0xC1
+#define JPEG_MARKER_SOF2 0xC2
+#define JPEG_MARKER_SOF9 0xC9
+#define JPEG_MARKER_SOF10 0xCA
+#define JPEG_MARKER_DHT 0xC4
+#define JPEG_MARKER_SOI 0xD8
+#define JPEG_MARKER_SOS 0xDA
+#define JPEG_MARKER_DQT 0xDB
+#define JPEG_MARKER_DRI 0xDD
+#define JPEG_MARKER_APP0 0xE0
+#define JPEG_MARKER_COM 0xFE
+struct JPEGFixupTagsSubsamplingData
+{
+ TIFF* tif;
+ void* buffer;
+ uint32 buffersize;
+ uint8* buffercurrentbyte;
+ uint32 bufferbytesleft;
+ uint64 fileoffset;
+ uint64 filebytesleft;
+ uint8 filepositioned;
+};
+static void JPEGFixupTagsSubsampling(TIFF* tif);
+static int JPEGFixupTagsSubsamplingSec(struct JPEGFixupTagsSubsamplingData* data);
+static int JPEGFixupTagsSubsamplingReadByte(struct JPEGFixupTagsSubsamplingData* data, uint8* result);
+static int JPEGFixupTagsSubsamplingReadWord(struct JPEGFixupTagsSubsamplingData* data, uint16* result);
+static void JPEGFixupTagsSubsamplingSkip(struct JPEGFixupTagsSubsamplingData* data, uint16 skiplength);
+
+#endif
+
+static int
+JPEGFixupTags(TIFF* tif)
+{
+#ifdef CHECK_JPEG_YCBCR_SUBSAMPLING
+ JPEGState* sp = JState(tif);
+ if ((tif->tif_dir.td_photometric==PHOTOMETRIC_YCBCR)&&
+ (tif->tif_dir.td_planarconfig==PLANARCONFIG_CONTIG)&&
+ (tif->tif_dir.td_samplesperpixel==3) &&
+ !sp->ycbcrsampling_fetched)
+ JPEGFixupTagsSubsampling(tif);
+#endif
+
+ return(1);
+}
+
+#ifdef CHECK_JPEG_YCBCR_SUBSAMPLING
+
+static void
+JPEGFixupTagsSubsampling(TIFF* tif)
+{
+ /*
+ * Some JPEG-in-TIFF produces do not emit the YCBCRSUBSAMPLING values in
+ * the TIFF tags, but still use non-default (2,2) values within the jpeg
+ * data stream itself. In order for TIFF applications to work properly
+ * - for instance to get the strip buffer size right - it is imperative
+ * that the subsampling be available before we start reading the image
+ * data normally. This function will attempt to analyze the first strip in
+ * order to get the sampling values from the jpeg data stream.
+ *
+ * Note that JPEGPreDeocode() will produce a fairly loud warning when the
+ * discovered sampling does not match the default sampling (2,2) or whatever
+ * was actually in the tiff tags.
+ *
+ * See the bug in bugzilla for details:
+ *
+ * http://bugzilla.remotesensing.org/show_bug.cgi?id=168
+ *
+ * Frank Warmerdam, July 2002
+ * Joris Van Damme, May 2007
+ */
+ static const char module[] = "JPEGFixupTagsSubsampling";
+ struct JPEGFixupTagsSubsamplingData m;
+
+ _TIFFFillStriles( tif );
+
+ if( tif->tif_dir.td_stripbytecount == NULL
+ || tif->tif_dir.td_stripoffset == NULL
+ || tif->tif_dir.td_stripbytecount[0] == 0 )
+ {
+ /* Do not even try to check if the first strip/tile does not
+ yet exist, as occurs when GDAL has created a new NULL file
+ for instance. */
+ return;
+ }
+
+ m.tif=tif;
+ m.buffersize=2048;
+ m.buffer=_TIFFmalloc(m.buffersize);
+ if (m.buffer==NULL)
+ {
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Unable to allocate memory for auto-correcting of subsampling values; auto-correcting skipped");
+ return;
+ }
+ m.buffercurrentbyte=NULL;
+ m.bufferbytesleft=0;
+ m.fileoffset=tif->tif_dir.td_stripoffset[0];
+ m.filepositioned=0;
+ m.filebytesleft=tif->tif_dir.td_stripbytecount[0];
+ if (!JPEGFixupTagsSubsamplingSec(&m))
+ TIFFWarningExt(tif->tif_clientdata,module,
+ "Unable to auto-correct subsampling values, likely corrupt JPEG compressed data in first strip/tile; auto-correcting skipped");
+ _TIFFfree(m.buffer);
+}
+
+static int
+JPEGFixupTagsSubsamplingSec(struct JPEGFixupTagsSubsamplingData* data)
+{
+ static const char module[] = "JPEGFixupTagsSubsamplingSec";
+ uint8 m;
+ while (1)
+ {
+ while (1)
+ {
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&m))
+ return(0);
+ if (m==255)
+ break;
+ }
+ while (1)
+ {
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&m))
+ return(0);
+ if (m!=255)
+ break;
+ }
+ switch (m)
+ {
+ case JPEG_MARKER_SOI:
+ /* this type of marker has no data and should be skipped */
+ break;
+ case JPEG_MARKER_COM:
+ case JPEG_MARKER_APP0:
+ case JPEG_MARKER_APP0+1:
+ case JPEG_MARKER_APP0+2:
+ case JPEG_MARKER_APP0+3:
+ case JPEG_MARKER_APP0+4:
+ case JPEG_MARKER_APP0+5:
+ case JPEG_MARKER_APP0+6:
+ case JPEG_MARKER_APP0+7:
+ case JPEG_MARKER_APP0+8:
+ case JPEG_MARKER_APP0+9:
+ case JPEG_MARKER_APP0+10:
+ case JPEG_MARKER_APP0+11:
+ case JPEG_MARKER_APP0+12:
+ case JPEG_MARKER_APP0+13:
+ case JPEG_MARKER_APP0+14:
+ case JPEG_MARKER_APP0+15:
+ case JPEG_MARKER_DQT:
+ case JPEG_MARKER_SOS:
+ case JPEG_MARKER_DHT:
+ case JPEG_MARKER_DRI:
+ /* this type of marker has data, but it has no use to us and should be skipped */
+ {
+ uint16 n;
+ if (!JPEGFixupTagsSubsamplingReadWord(data,&n))
+ return(0);
+ if (n<2)
+ return(0);
+ n-=2;
+ if (n>0)
+ JPEGFixupTagsSubsamplingSkip(data,n);
+ }
+ break;
+ case JPEG_MARKER_SOF0: /* Baseline sequential Huffman */
+ case JPEG_MARKER_SOF1: /* Extended sequential Huffman */
+ case JPEG_MARKER_SOF2: /* Progressive Huffman: normally not allowed by TechNote, but that doesn't hurt supporting it */
+ case JPEG_MARKER_SOF9: /* Extended sequential arithmetic */
+ case JPEG_MARKER_SOF10: /* Progressive arithmetic: normally not allowed by TechNote, but that doesn't hurt supporting it */
+ /* this marker contains the subsampling factors we're scanning for */
+ {
+ uint16 n;
+ uint16 o;
+ uint8 p;
+ uint8 ph,pv;
+ if (!JPEGFixupTagsSubsamplingReadWord(data,&n))
+ return(0);
+ if (n!=8+data->tif->tif_dir.td_samplesperpixel*3)
+ return(0);
+ JPEGFixupTagsSubsamplingSkip(data,7);
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&p))
+ return(0);
+ ph=(p>>4);
+ pv=(p&15);
+ JPEGFixupTagsSubsamplingSkip(data,1);
+ for (o=1; o<data->tif->tif_dir.td_samplesperpixel; o++)
+ {
+ JPEGFixupTagsSubsamplingSkip(data,1);
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&p))
+ return(0);
+ if (p!=0x11)
+ {
+ TIFFWarningExt(data->tif->tif_clientdata,module,
+ "Subsampling values inside JPEG compressed data have no TIFF equivalent, auto-correction of TIFF subsampling values failed");
+ return(1);
+ }
+ JPEGFixupTagsSubsamplingSkip(data,1);
+ }
+ if (((ph!=1)&&(ph!=2)&&(ph!=4))||((pv!=1)&&(pv!=2)&&(pv!=4)))
+ {
+ TIFFWarningExt(data->tif->tif_clientdata,module,
+ "Subsampling values inside JPEG compressed data have no TIFF equivalent, auto-correction of TIFF subsampling values failed");
+ return(1);
+ }
+ if ((ph!=data->tif->tif_dir.td_ycbcrsubsampling[0])||(pv!=data->tif->tif_dir.td_ycbcrsubsampling[1]))
+ {
+ TIFFWarningExt(data->tif->tif_clientdata,module,
+ "Auto-corrected former TIFF subsampling values [%d,%d] to match subsampling values inside JPEG compressed data [%d,%d]",
+ (int)data->tif->tif_dir.td_ycbcrsubsampling[0],
+ (int)data->tif->tif_dir.td_ycbcrsubsampling[1],
+ (int)ph,(int)pv);
+ data->tif->tif_dir.td_ycbcrsubsampling[0]=ph;
+ data->tif->tif_dir.td_ycbcrsubsampling[1]=pv;
+ }
+ }
+ return(1);
+ default:
+ return(0);
+ }
+ }
+}
+
+static int
+JPEGFixupTagsSubsamplingReadByte(struct JPEGFixupTagsSubsamplingData* data, uint8* result)
+{
+ if (data->bufferbytesleft==0)
+ {
+ uint32 m;
+ if (data->filebytesleft==0)
+ return(0);
+ if (!data->filepositioned)
+ {
+ TIFFSeekFile(data->tif,data->fileoffset,SEEK_SET);
+ data->filepositioned=1;
+ }
+ m=data->buffersize;
+ if ((uint64)m>data->filebytesleft)
+ m=(uint32)data->filebytesleft;
+ assert(m<0x80000000UL);
+ if (TIFFReadFile(data->tif,data->buffer,(tmsize_t)m)!=(tmsize_t)m)
+ return(0);
+ data->buffercurrentbyte=data->buffer;
+ data->bufferbytesleft=m;
+ data->fileoffset+=m;
+ data->filebytesleft-=m;
+ }
+ *result=*data->buffercurrentbyte;
+ data->buffercurrentbyte++;
+ data->bufferbytesleft--;
+ return(1);
+}
+
+static int
+JPEGFixupTagsSubsamplingReadWord(struct JPEGFixupTagsSubsamplingData* data, uint16* result)
+{
+ uint8 ma;
+ uint8 mb;
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&ma))
+ return(0);
+ if (!JPEGFixupTagsSubsamplingReadByte(data,&mb))
+ return(0);
+ *result=(ma<<8)|mb;
+ return(1);
+}
+
+static void
+JPEGFixupTagsSubsamplingSkip(struct JPEGFixupTagsSubsamplingData* data, uint16 skiplength)
+{
+ if ((uint32)skiplength<=data->bufferbytesleft)
+ {
+ data->buffercurrentbyte+=skiplength;
+ data->bufferbytesleft-=skiplength;
+ }
+ else
+ {
+ uint16 m;
+ m=(uint16)(skiplength-data->bufferbytesleft);
+ if (m<=data->filebytesleft)
+ {
+ data->bufferbytesleft=0;
+ data->fileoffset+=m;
+ data->filebytesleft-=m;
+ data->filepositioned=0;
+ }
+ else
+ {
+ data->bufferbytesleft=0;
+ data->filebytesleft=0;
+ }
+ }
+}
+
+#endif
+
+
+static int
+JPEGSetupDecode(TIFF* tif)
+{
+ JPEGState* sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+
+#if defined(JPEG_DUAL_MODE_8_12) && !defined(TIFFInitJPEG)
+ if( tif->tif_dir.td_bitspersample == 12 )
+ return TIFFReInitJPEG_12( tif, COMPRESSION_JPEG, 0 );
+#endif
+
+ JPEGInitializeLibJPEG( tif, TRUE );
+
+ assert(sp != NULL);
+ assert(sp->cinfo.comm.is_decompressor);
+
+ /* Read JPEGTables if it is present */
+ if (TIFFFieldSet(tif,FIELD_JPEGTABLES)) {
+ TIFFjpeg_tables_src(sp);
+ if(TIFFjpeg_read_header(sp,FALSE) != JPEG_HEADER_TABLES_ONLY) {
+ TIFFErrorExt(tif->tif_clientdata, "JPEGSetupDecode", "Bogus JPEGTables field");
+ return (0);
+ }
+ }
+
+ /* Grab parameters that are same for all strips/tiles */
+ sp->photometric = td->td_photometric;
+ switch (sp->photometric) {
+ case PHOTOMETRIC_YCBCR:
+ sp->h_sampling = td->td_ycbcrsubsampling[0];
+ sp->v_sampling = td->td_ycbcrsubsampling[1];
+ break;
+ default:
+ /* TIFF 6.0 forbids subsampling of all other color spaces */
+ sp->h_sampling = 1;
+ sp->v_sampling = 1;
+ break;
+ }
+
+ /* Set up for reading normal data */
+ TIFFjpeg_data_src(sp);
+ tif->tif_postdecode = _TIFFNoPostDecode; /* override byte swapping */
+ return (1);
+}
+
+/* Returns 1 if the full strip should be read, even when doing scanline per */
+/* scanline decoding. This happens when the JPEG stream uses multiple scans. */
+/* Currently only called in CHUNKY_STRIP_READ_SUPPORT mode through */
+/* scanline interface. */
+/* Only reads tif->tif_dir.td_bitspersample, tif->tif_rawdata and */
+/* tif->tif_rawcc members. */
+/* Can be called independently of the usual setup/predecode/decode states */
+int TIFFJPEGIsFullStripRequired(TIFF* tif)
+{
+ int ret;
+ JPEGState state;
+
+#if defined(JPEG_DUAL_MODE_8_12) && !defined(TIFFJPEGIsFullStripRequired)
+ if( tif->tif_dir.td_bitspersample == 12 )
+ return TIFFJPEGIsFullStripRequired_12( tif );
+#endif
+
+ memset(&state, 0, sizeof(JPEGState));
+ state.tif = tif;
+
+ TIFFjpeg_create_decompress(&state);
+
+ TIFFjpeg_data_src(&state);
+
+ if (TIFFjpeg_read_header(&state, TRUE) != JPEG_HEADER_OK)
+ {
+ TIFFjpeg_destroy(&state);
+ return (0);
+ }
+ ret = TIFFjpeg_has_multiple_scans(&state);
+
+ TIFFjpeg_destroy(&state);
+
+ return ret;
+}
+
+/*
+ * Set up for decoding a strip or tile.
+ */
+/*ARGSUSED*/ static int
+JPEGPreDecode(TIFF* tif, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+ static const char module[] = "JPEGPreDecode";
+ uint32 segment_width, segment_height;
+ int downsampled_output;
+ int ci;
+
+ assert(sp != NULL);
+
+ if (sp->cinfo.comm.is_decompressor == 0)
+ {
+ tif->tif_setupdecode( tif );
+ }
+
+ assert(sp->cinfo.comm.is_decompressor);
+ /*
+ * Reset decoder state from any previous strip/tile,
+ * in case application didn't read the whole strip.
+ */
+ if (!TIFFjpeg_abort(sp))
+ return (0);
+ /*
+ * Read the header for this strip/tile.
+ */
+
+ if (TIFFjpeg_read_header(sp, TRUE) != JPEG_HEADER_OK)
+ return (0);
+
+ tif->tif_rawcp = (uint8*) sp->src.next_input_byte;
+ tif->tif_rawcc = sp->src.bytes_in_buffer;
+
+ /*
+ * Check image parameters and set decompression parameters.
+ */
+ if (isTiled(tif)) {
+ segment_width = td->td_tilewidth;
+ segment_height = td->td_tilelength;
+ sp->bytesperline = TIFFTileRowSize(tif);
+ } else {
+ segment_width = td->td_imagewidth;
+ segment_height = td->td_imagelength - tif->tif_row;
+ if (segment_height > td->td_rowsperstrip)
+ segment_height = td->td_rowsperstrip;
+ sp->bytesperline = TIFFScanlineSize(tif);
+ }
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE && s > 0) {
+ /*
+ * For PC 2, scale down the expected strip/tile size
+ * to match a downsampled component
+ */
+ segment_width = TIFFhowmany_32(segment_width, sp->h_sampling);
+ segment_height = TIFFhowmany_32(segment_height, sp->v_sampling);
+ }
+ if (sp->cinfo.d.image_width < segment_width ||
+ sp->cinfo.d.image_height < segment_height) {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Improper JPEG strip/tile size, "
+ "expected %dx%d, got %dx%d",
+ segment_width, segment_height,
+ sp->cinfo.d.image_width,
+ sp->cinfo.d.image_height);
+ }
+ if( sp->cinfo.d.image_width == segment_width &&
+ sp->cinfo.d.image_height > segment_height &&
+ tif->tif_row + segment_height == td->td_imagelength &&
+ !isTiled(tif) ) {
+ /* Some files have a last strip, that should be truncated, */
+ /* but their JPEG codestream has still the maximum strip */
+ /* height. Warn about this as this is non compliant, but */
+ /* we can safely recover from that. */
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "JPEG strip size exceeds expected dimensions,"
+ " expected %dx%d, got %dx%d",
+ segment_width, segment_height,
+ sp->cinfo.d.image_width, sp->cinfo.d.image_height);
+ }
+ else if (sp->cinfo.d.image_width > segment_width ||
+ sp->cinfo.d.image_height > segment_height) {
+ /*
+ * This case could be dangerous, if the strip or tile size has
+ * been reported as less than the amount of data jpeg will
+ * return, some potential security issues arise. Catch this
+ * case and error out.
+ */
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "JPEG strip/tile size exceeds expected dimensions,"
+ " expected %dx%d, got %dx%d",
+ segment_width, segment_height,
+ sp->cinfo.d.image_width, sp->cinfo.d.image_height);
+ return (0);
+ }
+ if (sp->cinfo.d.num_components !=
+ (td->td_planarconfig == PLANARCONFIG_CONTIG ?
+ td->td_samplesperpixel : 1)) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Improper JPEG component count");
+ return (0);
+ }
+#ifdef JPEG_LIB_MK1
+ if (12 != td->td_bitspersample && 8 != td->td_bitspersample) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Improper JPEG data precision");
+ return (0);
+ }
+ sp->cinfo.d.data_precision = td->td_bitspersample;
+ sp->cinfo.d.bits_in_jsample = td->td_bitspersample;
+#else
+ if (sp->cinfo.d.data_precision != td->td_bitspersample) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Improper JPEG data precision");
+ return (0);
+ }
+#endif
+
+ /* In some cases, libjpeg needs to allocate a lot of memory */
+ /* http://www.libjpeg-turbo.org/pmwiki/uploads/About/TwoIssueswiththeJPEGStandard.pdf */
+ if( TIFFjpeg_has_multiple_scans(sp) )
+ {
+ /* In this case libjpeg will need to allocate memory or backing */
+ /* store for all coefficients */
+ /* See call to jinit_d_coef_controller() from master_selection() */
+ /* in libjpeg */
+ toff_t nRequiredMemory = (toff_t)sp->cinfo.d.image_width *
+ sp->cinfo.d.image_height *
+ sp->cinfo.d.num_components *
+ ((td->td_bitspersample+7)/8);
+ /* BLOCK_SMOOTHING_SUPPORTED is generally defined, so we need */
+ /* to replicate the logic of jinit_d_coef_controller() */
+ if( sp->cinfo.d.progressive_mode )
+ nRequiredMemory *= 3;
+
+#ifndef TIFF_LIBJPEG_LARGEST_MEM_ALLOC
+#define TIFF_LIBJPEG_LARGEST_MEM_ALLOC (100 * 1024 * 1024)
+#endif
+
+ if( nRequiredMemory > TIFF_LIBJPEG_LARGEST_MEM_ALLOC &&
+ getenv("LIBTIFF_ALLOW_LARGE_LIBJPEG_MEM_ALLOC") == NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Reading this strip would require libjpeg to allocate "
+ "at least %u bytes. "
+ "This is disabled since above the %u threshold. "
+ "You may override this restriction by defining the "
+ "LIBTIFF_ALLOW_LARGE_LIBJPEG_MEM_ALLOC environment variable, "
+ "or recompile libtiff by defining the "
+ "TIFF_LIBJPEG_LARGEST_MEM_ALLOC macro to a value greater "
+ "than %u",
+ (unsigned)nRequiredMemory,
+ (unsigned)TIFF_LIBJPEG_LARGEST_MEM_ALLOC,
+ (unsigned)TIFF_LIBJPEG_LARGEST_MEM_ALLOC);
+ return (0);
+ }
+ }
+
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG) {
+ /* Component 0 should have expected sampling factors */
+ if (sp->cinfo.d.comp_info[0].h_samp_factor != sp->h_sampling ||
+ sp->cinfo.d.comp_info[0].v_samp_factor != sp->v_sampling) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Improper JPEG sampling factors %d,%d\n"
+ "Apparently should be %d,%d.",
+ sp->cinfo.d.comp_info[0].h_samp_factor,
+ sp->cinfo.d.comp_info[0].v_samp_factor,
+ sp->h_sampling, sp->v_sampling);
+ return (0);
+ }
+ /* Rest should have sampling factors 1,1 */
+ for (ci = 1; ci < sp->cinfo.d.num_components; ci++) {
+ if (sp->cinfo.d.comp_info[ci].h_samp_factor != 1 ||
+ sp->cinfo.d.comp_info[ci].v_samp_factor != 1) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Improper JPEG sampling factors");
+ return (0);
+ }
+ }
+ } else {
+ /* PC 2's single component should have sampling factors 1,1 */
+ if (sp->cinfo.d.comp_info[0].h_samp_factor != 1 ||
+ sp->cinfo.d.comp_info[0].v_samp_factor != 1) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Improper JPEG sampling factors");
+ return (0);
+ }
+ }
+ downsampled_output = FALSE;
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG &&
+ sp->photometric == PHOTOMETRIC_YCBCR &&
+ sp->jpegcolormode == JPEGCOLORMODE_RGB) {
+ /* Convert YCbCr to RGB */
+ sp->cinfo.d.jpeg_color_space = JCS_YCbCr;
+ sp->cinfo.d.out_color_space = JCS_RGB;
+ } else {
+ /* Suppress colorspace handling */
+ sp->cinfo.d.jpeg_color_space = JCS_UNKNOWN;
+ sp->cinfo.d.out_color_space = JCS_UNKNOWN;
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG &&
+ (sp->h_sampling != 1 || sp->v_sampling != 1))
+ downsampled_output = TRUE;
+ /* XXX what about up-sampling? */
+ }
+ if (downsampled_output) {
+ /* Need to use raw-data interface to libjpeg */
+ sp->cinfo.d.raw_data_out = TRUE;
+#if JPEG_LIB_VERSION >= 70
+ sp->cinfo.d.do_fancy_upsampling = FALSE;
+#endif /* JPEG_LIB_VERSION >= 70 */
+ tif->tif_decoderow = DecodeRowError;
+ tif->tif_decodestrip = JPEGDecodeRaw;
+ tif->tif_decodetile = JPEGDecodeRaw;
+ } else {
+ /* Use normal interface to libjpeg */
+ sp->cinfo.d.raw_data_out = FALSE;
+ tif->tif_decoderow = JPEGDecode;
+ tif->tif_decodestrip = JPEGDecode;
+ tif->tif_decodetile = JPEGDecode;
+ }
+ /* Start JPEG decompressor */
+ if (!TIFFjpeg_start_decompress(sp))
+ return (0);
+ /* Allocate downsampled-data buffers if needed */
+ if (downsampled_output) {
+ if (!alloc_downsampled_buffers(tif, sp->cinfo.d.comp_info,
+ sp->cinfo.d.num_components))
+ return (0);
+ sp->scancount = DCTSIZE; /* mark buffer empty */
+ }
+ return (1);
+}
+
+/*
+ * Decode a chunk of pixels.
+ * "Standard" case: returned data is not downsampled.
+ */
+#if !JPEG_LIB_MK1_OR_12BIT
+static int
+JPEGDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ tmsize_t nrows;
+ (void) s;
+
+ /*
+ ** Update available information, buffer may have been refilled
+ ** between decode requests
+ */
+ sp->src.next_input_byte = (const JOCTET*) tif->tif_rawcp;
+ sp->src.bytes_in_buffer = (size_t) tif->tif_rawcc;
+
+ if( sp->bytesperline == 0 )
+ return 0;
+
+ nrows = cc / sp->bytesperline;
+ if (cc % sp->bytesperline)
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "fractional scanline not read");
+
+ if( nrows > (tmsize_t) sp->cinfo.d.image_height )
+ nrows = sp->cinfo.d.image_height;
+
+ /* data is expected to be read in multiples of a scanline */
+ if (nrows)
+ {
+ do
+ {
+ /*
+ * In the libjpeg6b-9a 8bit case. We read directly into
+ * the TIFF buffer.
+ */
+ JSAMPROW bufptr = (JSAMPROW)buf;
+
+ if (TIFFjpeg_read_scanlines(sp, &bufptr, 1) != 1)
+ return (0);
+
+ ++tif->tif_row;
+ buf += sp->bytesperline;
+ cc -= sp->bytesperline;
+ } while (--nrows > 0);
+ }
+
+ /* Update information on consumed data */
+ tif->tif_rawcp = (uint8*) sp->src.next_input_byte;
+ tif->tif_rawcc = sp->src.bytes_in_buffer;
+
+ /* Close down the decompressor if we've finished the strip or tile. */
+ return sp->cinfo.d.output_scanline < sp->cinfo.d.output_height
+ || TIFFjpeg_finish_decompress(sp);
+}
+#endif /* !JPEG_LIB_MK1_OR_12BIT */
+
+#if JPEG_LIB_MK1_OR_12BIT
+/*ARGSUSED*/ static int
+JPEGDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ tmsize_t nrows;
+ (void) s;
+
+ /*
+ ** Update available information, buffer may have been refilled
+ ** between decode requests
+ */
+ sp->src.next_input_byte = (const JOCTET*) tif->tif_rawcp;
+ sp->src.bytes_in_buffer = (size_t) tif->tif_rawcc;
+
+ if( sp->bytesperline == 0 )
+ return 0;
+
+ nrows = cc / sp->bytesperline;
+ if (cc % sp->bytesperline)
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "fractional scanline not read");
+
+ if( nrows > (tmsize_t) sp->cinfo.d.image_height )
+ nrows = sp->cinfo.d.image_height;
+
+ /* data is expected to be read in multiples of a scanline */
+ if (nrows)
+ {
+ JSAMPROW line_work_buf = NULL;
+
+ /*
+ * For 6B, only use temporary buffer for 12 bit imagery.
+ * For Mk1 always use it.
+ */
+ if( sp->cinfo.d.data_precision == 12 )
+ {
+ line_work_buf = (JSAMPROW)
+ _TIFFmalloc(sizeof(short) * sp->cinfo.d.output_width
+ * sp->cinfo.d.num_components );
+ }
+
+ do
+ {
+ if( line_work_buf != NULL )
+ {
+ /*
+ * In the MK1 case, we always read into a 16bit
+ * buffer, and then pack down to 12bit or 8bit.
+ * In 6B case we only read into 16 bit buffer
+ * for 12bit data, which we need to repack.
+ */
+ if (TIFFjpeg_read_scanlines(sp, &line_work_buf, 1) != 1)
+ return (0);
+
+ if( sp->cinfo.d.data_precision == 12 )
+ {
+ int value_pairs = (sp->cinfo.d.output_width
+ * sp->cinfo.d.num_components) / 2;
+ int iPair;
+
+ for( iPair = 0; iPair < value_pairs; iPair++ )
+ {
+ unsigned char *out_ptr =
+ ((unsigned char *) buf) + iPair * 3;
+ JSAMPLE *in_ptr = line_work_buf + iPair * 2;
+
+ out_ptr[0] = (unsigned char)((in_ptr[0] & 0xff0) >> 4);
+ out_ptr[1] = (unsigned char)(((in_ptr[0] & 0xf) << 4)
+ | ((in_ptr[1] & 0xf00) >> 8));
+ out_ptr[2] = (unsigned char)(((in_ptr[1] & 0xff) >> 0));
+ }
+ }
+ else if( sp->cinfo.d.data_precision == 8 )
+ {
+ int value_count = (sp->cinfo.d.output_width
+ * sp->cinfo.d.num_components);
+ int iValue;
+
+ for( iValue = 0; iValue < value_count; iValue++ )
+ {
+ ((unsigned char *) buf)[iValue] =
+ line_work_buf[iValue] & 0xff;
+ }
+ }
+ }
+
+ ++tif->tif_row;
+ buf += sp->bytesperline;
+ cc -= sp->bytesperline;
+ } while (--nrows > 0);
+
+ if( line_work_buf != NULL )
+ _TIFFfree( line_work_buf );
+ }
+
+ /* Update information on consumed data */
+ tif->tif_rawcp = (uint8*) sp->src.next_input_byte;
+ tif->tif_rawcc = sp->src.bytes_in_buffer;
+
+ /* Close down the decompressor if we've finished the strip or tile. */
+ return sp->cinfo.d.output_scanline < sp->cinfo.d.output_height
+ || TIFFjpeg_finish_decompress(sp);
+}
+#endif /* JPEG_LIB_MK1_OR_12BIT */
+
+/*ARGSUSED*/ static int
+DecodeRowError(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+
+{
+ (void) buf;
+ (void) cc;
+ (void) s;
+
+ TIFFErrorExt(tif->tif_clientdata, "TIFFReadScanline",
+ "scanline oriented access is not supported for downsampled JPEG compressed images, consider enabling TIFF_JPEGCOLORMODE as JPEGCOLORMODE_RGB." );
+ return 0;
+}
+
+/*
+ * Decode a chunk of pixels.
+ * Returned data is downsampled per sampling factors.
+ */
+/*ARGSUSED*/ static int
+JPEGDecodeRaw(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ tmsize_t nrows;
+ TIFFDirectory *td = &tif->tif_dir;
+ (void) s;
+
+ nrows = sp->cinfo.d.image_height;
+ /* For last strip, limit number of rows to its truncated height */
+ /* even if the codestream height is larger (which is not compliant, */
+ /* but that we tolerate) */
+ if( (uint32)nrows > td->td_imagelength - tif->tif_row && !isTiled(tif) )
+ nrows = td->td_imagelength - tif->tif_row;
+
+ /* data is expected to be read in multiples of a scanline */
+ if ( nrows != 0 ) {
+
+ /* Cb,Cr both have sampling factors 1, so this is correct */
+ JDIMENSION clumps_per_line = sp->cinfo.d.comp_info[1].downsampled_width;
+ int samples_per_clump = sp->samplesperclump;
+
+#if defined(JPEG_LIB_MK1_OR_12BIT)
+ unsigned short* tmpbuf = _TIFFmalloc(sizeof(unsigned short) *
+ sp->cinfo.d.output_width *
+ sp->cinfo.d.num_components);
+ if(tmpbuf==NULL) {
+ TIFFErrorExt(tif->tif_clientdata, "JPEGDecodeRaw",
+ "Out of memory");
+ return 0;
+ }
+#endif
+
+ do {
+ jpeg_component_info *compptr;
+ int ci, clumpoffset;
+
+ if( cc < sp->bytesperline ) {
+ TIFFErrorExt(tif->tif_clientdata, "JPEGDecodeRaw",
+ "application buffer not large enough for all data.");
+ return 0;
+ }
+
+ /* Reload downsampled-data buffer if needed */
+ if (sp->scancount >= DCTSIZE) {
+ int n = sp->cinfo.d.max_v_samp_factor * DCTSIZE;
+ if (TIFFjpeg_read_raw_data(sp, sp->ds_buffer, n) != n)
+ return (0);
+ sp->scancount = 0;
+ }
+ /*
+ * Fastest way to unseparate data is to make one pass
+ * over the scanline for each row of each component.
+ */
+ clumpoffset = 0; /* first sample in clump */
+ for (ci = 0, compptr = sp->cinfo.d.comp_info;
+ ci < sp->cinfo.d.num_components;
+ ci++, compptr++) {
+ int hsamp = compptr->h_samp_factor;
+ int vsamp = compptr->v_samp_factor;
+ int ypos;
+
+ for (ypos = 0; ypos < vsamp; ypos++) {
+ JSAMPLE *inptr = sp->ds_buffer[ci][sp->scancount*vsamp + ypos];
+ JDIMENSION nclump;
+#if defined(JPEG_LIB_MK1_OR_12BIT)
+ JSAMPLE *outptr = (JSAMPLE*)tmpbuf + clumpoffset;
+#else
+ JSAMPLE *outptr = (JSAMPLE*)buf + clumpoffset;
+ if (cc < (tmsize_t) (clumpoffset + samples_per_clump*(clumps_per_line-1) + hsamp)) {
+ TIFFErrorExt(tif->tif_clientdata, "JPEGDecodeRaw",
+ "application buffer not large enough for all data, possible subsampling issue");
+ return 0;
+ }
+#endif
+
+ if (hsamp == 1) {
+ /* fast path for at least Cb and Cr */
+ for (nclump = clumps_per_line; nclump-- > 0; ) {
+ outptr[0] = *inptr++;
+ outptr += samples_per_clump;
+ }
+ } else {
+ int xpos;
+
+ /* general case */
+ for (nclump = clumps_per_line; nclump-- > 0; ) {
+ for (xpos = 0; xpos < hsamp; xpos++)
+ outptr[xpos] = *inptr++;
+ outptr += samples_per_clump;
+ }
+ }
+ clumpoffset += hsamp;
+ }
+ }
+
+#if defined(JPEG_LIB_MK1_OR_12BIT)
+ {
+ if (sp->cinfo.d.data_precision == 8)
+ {
+ int i=0;
+ int len = sp->cinfo.d.output_width * sp->cinfo.d.num_components;
+ for (i=0; i<len; i++)
+ {
+ ((unsigned char*)buf)[i] = tmpbuf[i] & 0xff;
+ }
+ }
+ else
+ { /* 12-bit */
+ int value_pairs = (sp->cinfo.d.output_width
+ * sp->cinfo.d.num_components) / 2;
+ int iPair;
+ for( iPair = 0; iPair < value_pairs; iPair++ )
+ {
+ unsigned char *out_ptr = ((unsigned char *) buf) + iPair * 3;
+ JSAMPLE *in_ptr = (JSAMPLE *) (tmpbuf + iPair * 2);
+ out_ptr[0] = (unsigned char)((in_ptr[0] & 0xff0) >> 4);
+ out_ptr[1] = (unsigned char)(((in_ptr[0] & 0xf) << 4)
+ | ((in_ptr[1] & 0xf00) >> 8));
+ out_ptr[2] = (unsigned char)(((in_ptr[1] & 0xff) >> 0));
+ }
+ }
+ }
+#endif
+
+ sp->scancount ++;
+ tif->tif_row += sp->v_sampling;
+
+ buf += sp->bytesperline;
+ cc -= sp->bytesperline;
+
+ nrows -= sp->v_sampling;
+ } while (nrows > 0);
+
+#if defined(JPEG_LIB_MK1_OR_12BIT)
+ _TIFFfree(tmpbuf);
+#endif
+
+ }
+
+ /* Close down the decompressor if done. */
+ return sp->cinfo.d.output_scanline < sp->cinfo.d.output_height
+ || TIFFjpeg_finish_decompress(sp);
+}
+
+
+/*
+ * JPEG Encoding.
+ */
+
+static void
+unsuppress_quant_table (JPEGState* sp, int tblno)
+{
+ JQUANT_TBL* qtbl;
+
+ if ((qtbl = sp->cinfo.c.quant_tbl_ptrs[tblno]) != NULL)
+ qtbl->sent_table = FALSE;
+}
+
+static void
+suppress_quant_table (JPEGState* sp, int tblno)
+{
+ JQUANT_TBL* qtbl;
+
+ if ((qtbl = sp->cinfo.c.quant_tbl_ptrs[tblno]) != NULL)
+ qtbl->sent_table = TRUE;
+}
+
+static void
+unsuppress_huff_table (JPEGState* sp, int tblno)
+{
+ JHUFF_TBL* htbl;
+
+ if ((htbl = sp->cinfo.c.dc_huff_tbl_ptrs[tblno]) != NULL)
+ htbl->sent_table = FALSE;
+ if ((htbl = sp->cinfo.c.ac_huff_tbl_ptrs[tblno]) != NULL)
+ htbl->sent_table = FALSE;
+}
+
+static void
+suppress_huff_table (JPEGState* sp, int tblno)
+{
+ JHUFF_TBL* htbl;
+
+ if ((htbl = sp->cinfo.c.dc_huff_tbl_ptrs[tblno]) != NULL)
+ htbl->sent_table = TRUE;
+ if ((htbl = sp->cinfo.c.ac_huff_tbl_ptrs[tblno]) != NULL)
+ htbl->sent_table = TRUE;
+}
+
+static int
+prepare_JPEGTables(TIFF* tif)
+{
+ JPEGState* sp = JState(tif);
+
+ /* Initialize quant tables for current quality setting */
+ if (!TIFFjpeg_set_quality(sp, sp->jpegquality, FALSE))
+ return (0);
+ /* Mark only the tables we want for output */
+ /* NB: chrominance tables are currently used only with YCbCr */
+ if (!TIFFjpeg_suppress_tables(sp, TRUE))
+ return (0);
+ if (sp->jpegtablesmode & JPEGTABLESMODE_QUANT) {
+ unsuppress_quant_table(sp, 0);
+ if (sp->photometric == PHOTOMETRIC_YCBCR)
+ unsuppress_quant_table(sp, 1);
+ }
+ if (sp->jpegtablesmode & JPEGTABLESMODE_HUFF) {
+ unsuppress_huff_table(sp, 0);
+ if (sp->photometric == PHOTOMETRIC_YCBCR)
+ unsuppress_huff_table(sp, 1);
+ }
+ /* Direct libjpeg output into jpegtables */
+ if (!TIFFjpeg_tables_dest(sp, tif))
+ return (0);
+ /* Emit tables-only datastream */
+ if (!TIFFjpeg_write_tables(sp))
+ return (0);
+
+ return (1);
+}
+
+static int
+JPEGSetupEncode(TIFF* tif)
+{
+ JPEGState* sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+ static const char module[] = "JPEGSetupEncode";
+
+#if defined(JPEG_DUAL_MODE_8_12) && !defined(TIFFInitJPEG)
+ if( tif->tif_dir.td_bitspersample == 12 )
+ return TIFFReInitJPEG_12( tif, COMPRESSION_JPEG, 1 );
+#endif
+
+ JPEGInitializeLibJPEG( tif, FALSE );
+
+ assert(sp != NULL);
+ assert(!sp->cinfo.comm.is_decompressor);
+
+ sp->photometric = td->td_photometric;
+
+ /*
+ * Initialize all JPEG parameters to default values.
+ * Note that jpeg_set_defaults needs legal values for
+ * in_color_space and input_components.
+ */
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG) {
+ sp->cinfo.c.input_components = td->td_samplesperpixel;
+ if (sp->photometric == PHOTOMETRIC_YCBCR) {
+ if (sp->jpegcolormode == JPEGCOLORMODE_RGB) {
+ sp->cinfo.c.in_color_space = JCS_RGB;
+ } else {
+ sp->cinfo.c.in_color_space = JCS_YCbCr;
+ }
+ } else {
+ if ((td->td_photometric == PHOTOMETRIC_MINISWHITE || td->td_photometric == PHOTOMETRIC_MINISBLACK) && td->td_samplesperpixel == 1)
+ sp->cinfo.c.in_color_space = JCS_GRAYSCALE;
+ else if (td->td_photometric == PHOTOMETRIC_RGB && td->td_samplesperpixel == 3)
+ sp->cinfo.c.in_color_space = JCS_RGB;
+ else if (td->td_photometric == PHOTOMETRIC_SEPARATED && td->td_samplesperpixel == 4)
+ sp->cinfo.c.in_color_space = JCS_CMYK;
+ else
+ sp->cinfo.c.in_color_space = JCS_UNKNOWN;
+ }
+ } else {
+ sp->cinfo.c.input_components = 1;
+ sp->cinfo.c.in_color_space = JCS_UNKNOWN;
+ }
+ if (!TIFFjpeg_set_defaults(sp))
+ return (0);
+ /* Set per-file parameters */
+ switch (sp->photometric) {
+ case PHOTOMETRIC_YCBCR:
+ sp->h_sampling = td->td_ycbcrsubsampling[0];
+ sp->v_sampling = td->td_ycbcrsubsampling[1];
+ if( sp->h_sampling == 0 || sp->v_sampling == 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalig horizontal/vertical sampling value");
+ return (0);
+ }
+ if( td->td_bitspersample > 16 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "BitsPerSample %d not allowed for JPEG",
+ td->td_bitspersample);
+ return (0);
+ }
+
+ /*
+ * A ReferenceBlackWhite field *must* be present since the
+ * default value is inappropriate for YCbCr. Fill in the
+ * proper value if application didn't set it.
+ */
+ {
+ float *ref;
+ if (!TIFFGetField(tif, TIFFTAG_REFERENCEBLACKWHITE,
+ &ref)) {
+ float refbw[6];
+ long top = 1L << td->td_bitspersample;
+ refbw[0] = 0;
+ refbw[1] = (float)(top-1L);
+ refbw[2] = (float)(top>>1);
+ refbw[3] = refbw[1];
+ refbw[4] = refbw[2];
+ refbw[5] = refbw[1];
+ TIFFSetField(tif, TIFFTAG_REFERENCEBLACKWHITE,
+ refbw);
+ }
+ }
+ break;
+ case PHOTOMETRIC_PALETTE: /* disallowed by Tech Note */
+ case PHOTOMETRIC_MASK:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "PhotometricInterpretation %d not allowed for JPEG",
+ (int) sp->photometric);
+ return (0);
+ default:
+ /* TIFF 6.0 forbids subsampling of all other color spaces */
+ sp->h_sampling = 1;
+ sp->v_sampling = 1;
+ break;
+ }
+
+ /* Verify miscellaneous parameters */
+
+ /*
+ * This would need work if libtiff ever supports different
+ * depths for different components, or if libjpeg ever supports
+ * run-time selection of depth. Neither is imminent.
+ */
+#ifdef JPEG_LIB_MK1
+ /* BITS_IN_JSAMPLE now permits 8 and 12 --- dgilbert */
+ if (td->td_bitspersample != 8 && td->td_bitspersample != 12)
+#else
+ if (td->td_bitspersample != BITS_IN_JSAMPLE )
+#endif
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "BitsPerSample %d not allowed for JPEG",
+ (int) td->td_bitspersample);
+ return (0);
+ }
+ sp->cinfo.c.data_precision = td->td_bitspersample;
+#ifdef JPEG_LIB_MK1
+ sp->cinfo.c.bits_in_jsample = td->td_bitspersample;
+#endif
+ if (isTiled(tif)) {
+ if ((td->td_tilelength % (sp->v_sampling * DCTSIZE)) != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "JPEG tile height must be multiple of %d",
+ sp->v_sampling * DCTSIZE);
+ return (0);
+ }
+ if ((td->td_tilewidth % (sp->h_sampling * DCTSIZE)) != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "JPEG tile width must be multiple of %d",
+ sp->h_sampling * DCTSIZE);
+ return (0);
+ }
+ } else {
+ if (td->td_rowsperstrip < td->td_imagelength &&
+ (td->td_rowsperstrip % (sp->v_sampling * DCTSIZE)) != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "RowsPerStrip must be multiple of %d for JPEG",
+ sp->v_sampling * DCTSIZE);
+ return (0);
+ }
+ }
+
+ /* Create a JPEGTables field if appropriate */
+ if (sp->jpegtablesmode & (JPEGTABLESMODE_QUANT|JPEGTABLESMODE_HUFF)) {
+ if( sp->jpegtables == NULL
+ || memcmp(sp->jpegtables,"\0\0\0\0\0\0\0\0\0",8) == 0 )
+ {
+ if (!prepare_JPEGTables(tif))
+ return (0);
+ /* Mark the field present */
+ /* Can't use TIFFSetField since BEENWRITING is already set! */
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+ TIFFSetFieldBit(tif, FIELD_JPEGTABLES);
+ }
+ } else {
+ /* We do not support application-supplied JPEGTables, */
+ /* so mark the field not present */
+ TIFFClrFieldBit(tif, FIELD_JPEGTABLES);
+ }
+
+ /* Direct libjpeg output to libtiff's output buffer */
+ TIFFjpeg_data_dest(sp, tif);
+
+ return (1);
+}
+
+/*
+ * Set encoding state at the start of a strip or tile.
+ */
+static int
+JPEGPreEncode(TIFF* tif, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+ static const char module[] = "JPEGPreEncode";
+ uint32 segment_width, segment_height;
+ int downsampled_input;
+
+ assert(sp != NULL);
+
+ if (sp->cinfo.comm.is_decompressor == 1)
+ {
+ tif->tif_setupencode( tif );
+ }
+
+ assert(!sp->cinfo.comm.is_decompressor);
+ /*
+ * Set encoding parameters for this strip/tile.
+ */
+ if (isTiled(tif)) {
+ segment_width = td->td_tilewidth;
+ segment_height = td->td_tilelength;
+ sp->bytesperline = TIFFTileRowSize(tif);
+ } else {
+ segment_width = td->td_imagewidth;
+ segment_height = td->td_imagelength - tif->tif_row;
+ if (segment_height > td->td_rowsperstrip)
+ segment_height = td->td_rowsperstrip;
+ sp->bytesperline = TIFFScanlineSize(tif);
+ }
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE && s > 0) {
+ /* for PC 2, scale down the strip/tile size
+ * to match a downsampled component
+ */
+ segment_width = TIFFhowmany_32(segment_width, sp->h_sampling);
+ segment_height = TIFFhowmany_32(segment_height, sp->v_sampling);
+ }
+ if (segment_width > 65535 || segment_height > 65535) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Strip/tile too large for JPEG");
+ return (0);
+ }
+ sp->cinfo.c.image_width = segment_width;
+ sp->cinfo.c.image_height = segment_height;
+ downsampled_input = FALSE;
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG) {
+ sp->cinfo.c.input_components = td->td_samplesperpixel;
+ if (sp->photometric == PHOTOMETRIC_YCBCR) {
+ if (sp->jpegcolormode != JPEGCOLORMODE_RGB) {
+ if (sp->h_sampling != 1 || sp->v_sampling != 1)
+ downsampled_input = TRUE;
+ }
+ if (!TIFFjpeg_set_colorspace(sp, JCS_YCbCr))
+ return (0);
+ /*
+ * Set Y sampling factors;
+ * we assume jpeg_set_colorspace() set the rest to 1
+ */
+ sp->cinfo.c.comp_info[0].h_samp_factor = sp->h_sampling;
+ sp->cinfo.c.comp_info[0].v_samp_factor = sp->v_sampling;
+ } else {
+ if (!TIFFjpeg_set_colorspace(sp, sp->cinfo.c.in_color_space))
+ return (0);
+ /* jpeg_set_colorspace set all sampling factors to 1 */
+ }
+ } else {
+ if (!TIFFjpeg_set_colorspace(sp, JCS_UNKNOWN))
+ return (0);
+ sp->cinfo.c.comp_info[0].component_id = s;
+ /* jpeg_set_colorspace() set sampling factors to 1 */
+ if (sp->photometric == PHOTOMETRIC_YCBCR && s > 0) {
+ sp->cinfo.c.comp_info[0].quant_tbl_no = 1;
+ sp->cinfo.c.comp_info[0].dc_tbl_no = 1;
+ sp->cinfo.c.comp_info[0].ac_tbl_no = 1;
+ }
+ }
+ /* ensure libjpeg won't write any extraneous markers */
+ sp->cinfo.c.write_JFIF_header = FALSE;
+ sp->cinfo.c.write_Adobe_marker = FALSE;
+ /* set up table handling correctly */
+ /* calling TIFFjpeg_set_quality() causes quantization tables to be flagged */
+ /* as being to be emitted, which we don't want in the JPEGTABLESMODE_QUANT */
+ /* mode, so we must manually suppress them. However TIFFjpeg_set_quality() */
+ /* should really be called when dealing with files with directories with */
+ /* mixed qualities. see http://trac.osgeo.org/gdal/ticket/3539 */
+ if (!TIFFjpeg_set_quality(sp, sp->jpegquality, FALSE))
+ return (0);
+ if (sp->jpegtablesmode & JPEGTABLESMODE_QUANT) {
+ suppress_quant_table(sp, 0);
+ suppress_quant_table(sp, 1);
+ }
+ else {
+ unsuppress_quant_table(sp, 0);
+ unsuppress_quant_table(sp, 1);
+ }
+ if (sp->jpegtablesmode & JPEGTABLESMODE_HUFF)
+ {
+ /* Explicit suppression is only needed if we did not go through the */
+ /* prepare_JPEGTables() code path, which may be the case if updating */
+ /* an existing file */
+ suppress_huff_table(sp, 0);
+ suppress_huff_table(sp, 1);
+ sp->cinfo.c.optimize_coding = FALSE;
+ }
+ else
+ sp->cinfo.c.optimize_coding = TRUE;
+ if (downsampled_input) {
+ /* Need to use raw-data interface to libjpeg */
+ sp->cinfo.c.raw_data_in = TRUE;
+ tif->tif_encoderow = JPEGEncodeRaw;
+ tif->tif_encodestrip = JPEGEncodeRaw;
+ tif->tif_encodetile = JPEGEncodeRaw;
+ } else {
+ /* Use normal interface to libjpeg */
+ sp->cinfo.c.raw_data_in = FALSE;
+ tif->tif_encoderow = JPEGEncode;
+ tif->tif_encodestrip = JPEGEncode;
+ tif->tif_encodetile = JPEGEncode;
+ }
+ /* Start JPEG compressor */
+ if (!TIFFjpeg_start_compress(sp, FALSE))
+ return (0);
+ /* Allocate downsampled-data buffers if needed */
+ if (downsampled_input) {
+ if (!alloc_downsampled_buffers(tif, sp->cinfo.c.comp_info,
+ sp->cinfo.c.num_components))
+ return (0);
+ }
+ sp->scancount = 0;
+
+ return (1);
+}
+
+/*
+ * Encode a chunk of pixels.
+ * "Standard" case: incoming data is not downsampled.
+ */
+static int
+JPEGEncode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ tmsize_t nrows;
+ JSAMPROW bufptr[1];
+ short *line16 = NULL;
+ int line16_count = 0;
+
+ (void) s;
+ assert(sp != NULL);
+ /* data is expected to be supplied in multiples of a scanline */
+ nrows = cc / sp->bytesperline;
+ if (cc % sp->bytesperline)
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name,
+ "fractional scanline discarded");
+
+ /* The last strip will be limited to image size */
+ if( !isTiled(tif) && tif->tif_row+nrows > tif->tif_dir.td_imagelength )
+ nrows = tif->tif_dir.td_imagelength - tif->tif_row;
+
+ if( sp->cinfo.c.data_precision == 12 )
+ {
+ line16_count = (int)((sp->bytesperline * 2) / 3);
+ line16 = (short *) _TIFFmalloc(sizeof(short) * line16_count);
+ if (!line16)
+ {
+ TIFFErrorExt(tif->tif_clientdata,
+ "JPEGEncode",
+ "Failed to allocate memory");
+
+ return 0;
+ }
+ }
+
+ while (nrows-- > 0) {
+
+ if( sp->cinfo.c.data_precision == 12 )
+ {
+
+ int value_pairs = line16_count / 2;
+ int iPair;
+
+ bufptr[0] = (JSAMPROW) line16;
+
+ for( iPair = 0; iPair < value_pairs; iPair++ )
+ {
+ unsigned char *in_ptr =
+ ((unsigned char *) buf) + iPair * 3;
+ JSAMPLE *out_ptr = (JSAMPLE *) (line16 + iPair * 2);
+
+ out_ptr[0] = (in_ptr[0] << 4) | ((in_ptr[1] & 0xf0) >> 4);
+ out_ptr[1] = ((in_ptr[1] & 0x0f) << 8) | in_ptr[2];
+ }
+ }
+ else
+ {
+ bufptr[0] = (JSAMPROW) buf;
+ }
+ if (TIFFjpeg_write_scanlines(sp, bufptr, 1) != 1)
+ return (0);
+ if (nrows > 0)
+ tif->tif_row++;
+ buf += sp->bytesperline;
+ }
+
+ if( sp->cinfo.c.data_precision == 12 )
+ {
+ _TIFFfree( line16 );
+ }
+
+ return (1);
+}
+
+/*
+ * Encode a chunk of pixels.
+ * Incoming data is expected to be downsampled per sampling factors.
+ */
+static int
+JPEGEncodeRaw(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ JPEGState *sp = JState(tif);
+ JSAMPLE* inptr;
+ JSAMPLE* outptr;
+ tmsize_t nrows;
+ JDIMENSION clumps_per_line, nclump;
+ int clumpoffset, ci, xpos, ypos;
+ jpeg_component_info* compptr;
+ int samples_per_clump = sp->samplesperclump;
+ tmsize_t bytesperclumpline;
+
+ (void) s;
+ assert(sp != NULL);
+ /* data is expected to be supplied in multiples of a clumpline */
+ /* a clumpline is equivalent to v_sampling desubsampled scanlines */
+ /* TODO: the following calculation of bytesperclumpline, should substitute calculation of sp->bytesperline, except that it is per v_sampling lines */
+ bytesperclumpline = (((sp->cinfo.c.image_width+sp->h_sampling-1)/sp->h_sampling)
+ *(sp->h_sampling*sp->v_sampling+2)*sp->cinfo.c.data_precision+7)
+ /8;
+
+ nrows = ( cc / bytesperclumpline ) * sp->v_sampling;
+ if (cc % bytesperclumpline)
+ TIFFWarningExt(tif->tif_clientdata, tif->tif_name, "fractional scanline discarded");
+
+ /* Cb,Cr both have sampling factors 1, so this is correct */
+ clumps_per_line = sp->cinfo.c.comp_info[1].downsampled_width;
+
+ while (nrows > 0) {
+ /*
+ * Fastest way to separate the data is to make one pass
+ * over the scanline for each row of each component.
+ */
+ clumpoffset = 0; /* first sample in clump */
+ for (ci = 0, compptr = sp->cinfo.c.comp_info;
+ ci < sp->cinfo.c.num_components;
+ ci++, compptr++) {
+ int hsamp = compptr->h_samp_factor;
+ int vsamp = compptr->v_samp_factor;
+ int padding = (int) (compptr->width_in_blocks * DCTSIZE -
+ clumps_per_line * hsamp);
+ for (ypos = 0; ypos < vsamp; ypos++) {
+ inptr = ((JSAMPLE*) buf) + clumpoffset;
+ outptr = sp->ds_buffer[ci][sp->scancount*vsamp + ypos];
+ if (hsamp == 1) {
+ /* fast path for at least Cb and Cr */
+ for (nclump = clumps_per_line; nclump-- > 0; ) {
+ *outptr++ = inptr[0];
+ inptr += samples_per_clump;
+ }
+ } else {
+ /* general case */
+ for (nclump = clumps_per_line; nclump-- > 0; ) {
+ for (xpos = 0; xpos < hsamp; xpos++)
+ *outptr++ = inptr[xpos];
+ inptr += samples_per_clump;
+ }
+ }
+ /* pad each scanline as needed */
+ for (xpos = 0; xpos < padding; xpos++) {
+ *outptr = outptr[-1];
+ outptr++;
+ }
+ clumpoffset += hsamp;
+ }
+ }
+ sp->scancount++;
+ if (sp->scancount >= DCTSIZE) {
+ int n = sp->cinfo.c.max_v_samp_factor * DCTSIZE;
+ if (TIFFjpeg_write_raw_data(sp, sp->ds_buffer, n) != n)
+ return (0);
+ sp->scancount = 0;
+ }
+ tif->tif_row += sp->v_sampling;
+ buf += bytesperclumpline;
+ nrows -= sp->v_sampling;
+ }
+ return (1);
+}
+
+/*
+ * Finish up at the end of a strip or tile.
+ */
+static int
+JPEGPostEncode(TIFF* tif)
+{
+ JPEGState *sp = JState(tif);
+
+ if (sp->scancount > 0) {
+ /*
+ * Need to emit a partial bufferload of downsampled data.
+ * Pad the data vertically.
+ */
+ int ci, ypos, n;
+ jpeg_component_info* compptr;
+
+ for (ci = 0, compptr = sp->cinfo.c.comp_info;
+ ci < sp->cinfo.c.num_components;
+ ci++, compptr++) {
+ int vsamp = compptr->v_samp_factor;
+ tmsize_t row_width = compptr->width_in_blocks * DCTSIZE
+ * sizeof(JSAMPLE);
+ for (ypos = sp->scancount * vsamp;
+ ypos < DCTSIZE * vsamp; ypos++) {
+ _TIFFmemcpy((void*)sp->ds_buffer[ci][ypos],
+ (void*)sp->ds_buffer[ci][ypos-1],
+ row_width);
+
+ }
+ }
+ n = sp->cinfo.c.max_v_samp_factor * DCTSIZE;
+ if (TIFFjpeg_write_raw_data(sp, sp->ds_buffer, n) != n)
+ return (0);
+ }
+
+ return (TIFFjpeg_finish_compress(JState(tif)));
+}
+
+static void
+JPEGCleanup(TIFF* tif)
+{
+ JPEGState *sp = JState(tif);
+
+ assert(sp != 0);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+ tif->tif_tagmethods.printdir = sp->printdir;
+ if( sp->cinfo_initialized )
+ TIFFjpeg_destroy(sp); /* release libjpeg resources */
+ if (sp->jpegtables) /* tag value */
+ _TIFFfree(sp->jpegtables);
+ _TIFFfree(tif->tif_data); /* release local state */
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static void
+JPEGResetUpsampled( TIFF* tif )
+{
+ JPEGState* sp = JState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ /*
+ * Mark whether returned data is up-sampled or not so TIFFStripSize
+ * and TIFFTileSize return values that reflect the true amount of
+ * data.
+ */
+ tif->tif_flags &= ~TIFF_UPSAMPLED;
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG) {
+ if (td->td_photometric == PHOTOMETRIC_YCBCR &&
+ sp->jpegcolormode == JPEGCOLORMODE_RGB) {
+ tif->tif_flags |= TIFF_UPSAMPLED;
+ } else {
+#ifdef notdef
+ if (td->td_ycbcrsubsampling[0] != 1 ||
+ td->td_ycbcrsubsampling[1] != 1)
+ ; /* XXX what about up-sampling? */
+#endif
+ }
+ }
+
+ /*
+ * Must recalculate cached tile size in case sampling state changed.
+ * Should we really be doing this now if image size isn't set?
+ */
+ if( tif->tif_tilesize > 0 )
+ tif->tif_tilesize = isTiled(tif) ? TIFFTileSize(tif) : (tmsize_t)(-1);
+ if( tif->tif_scanlinesize > 0 )
+ tif->tif_scanlinesize = TIFFScanlineSize(tif);
+}
+
+static int
+JPEGVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ JPEGState* sp = JState(tif);
+ const TIFFField* fip;
+ uint32 v32;
+
+ assert(sp != NULL);
+
+ switch (tag) {
+ case TIFFTAG_JPEGTABLES:
+ v32 = (uint32) va_arg(ap, uint32);
+ if (v32 == 0) {
+ /* XXX */
+ return (0);
+ }
+ _TIFFsetByteArray(&sp->jpegtables, va_arg(ap, void*), v32);
+ sp->jpegtables_length = v32;
+ TIFFSetFieldBit(tif, FIELD_JPEGTABLES);
+ break;
+ case TIFFTAG_JPEGQUALITY:
+ sp->jpegquality = (int) va_arg(ap, int);
+ return (1); /* pseudo tag */
+ case TIFFTAG_JPEGCOLORMODE:
+ sp->jpegcolormode = (int) va_arg(ap, int);
+ JPEGResetUpsampled( tif );
+ return (1); /* pseudo tag */
+ case TIFFTAG_PHOTOMETRIC:
+ {
+ int ret_value = (*sp->vsetparent)(tif, tag, ap);
+ JPEGResetUpsampled( tif );
+ return ret_value;
+ }
+ case TIFFTAG_JPEGTABLESMODE:
+ sp->jpegtablesmode = (int) va_arg(ap, int);
+ return (1); /* pseudo tag */
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ /* mark the fact that we have a real ycbcrsubsampling! */
+ sp->ycbcrsampling_fetched = 1;
+ /* should we be recomputing upsampling info here? */
+ return (*sp->vsetparent)(tif, tag, ap);
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+
+ if ((fip = TIFFFieldWithTag(tif, tag)) != NULL) {
+ TIFFSetFieldBit(tif, fip->field_bit);
+ } else {
+ return (0);
+ }
+
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+ return (1);
+}
+
+static int
+JPEGVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ JPEGState* sp = JState(tif);
+
+ assert(sp != NULL);
+
+ switch (tag) {
+ case TIFFTAG_JPEGTABLES:
+ *va_arg(ap, uint32*) = sp->jpegtables_length;
+ *va_arg(ap, void**) = sp->jpegtables;
+ break;
+ case TIFFTAG_JPEGQUALITY:
+ *va_arg(ap, int*) = sp->jpegquality;
+ break;
+ case TIFFTAG_JPEGCOLORMODE:
+ *va_arg(ap, int*) = sp->jpegcolormode;
+ break;
+ case TIFFTAG_JPEGTABLESMODE:
+ *va_arg(ap, int*) = sp->jpegtablesmode;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return (1);
+}
+
+static void
+JPEGPrintDir(TIFF* tif, FILE* fd, long flags)
+{
+ JPEGState* sp = JState(tif);
+
+ assert(sp != NULL);
+ (void) flags;
+
+ if( sp != NULL ) {
+ if (TIFFFieldSet(tif,FIELD_JPEGTABLES))
+ fprintf(fd, " JPEG Tables: (%lu bytes)\n",
+ (unsigned long) sp->jpegtables_length);
+ if (sp->printdir)
+ (*sp->printdir)(tif, fd, flags);
+ }
+}
+
+static uint32
+JPEGDefaultStripSize(TIFF* tif, uint32 s)
+{
+ JPEGState* sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+
+ s = (*sp->defsparent)(tif, s);
+ if (s < td->td_imagelength)
+ s = TIFFroundup_32(s, td->td_ycbcrsubsampling[1] * DCTSIZE);
+ return (s);
+}
+
+static void
+JPEGDefaultTileSize(TIFF* tif, uint32* tw, uint32* th)
+{
+ JPEGState* sp = JState(tif);
+ TIFFDirectory *td = &tif->tif_dir;
+
+ (*sp->deftparent)(tif, tw, th);
+ *tw = TIFFroundup_32(*tw, td->td_ycbcrsubsampling[0] * DCTSIZE);
+ *th = TIFFroundup_32(*th, td->td_ycbcrsubsampling[1] * DCTSIZE);
+}
+
+/*
+ * The JPEG library initialized used to be done in TIFFInitJPEG(), but
+ * now that we allow a TIFF file to be opened in update mode it is necessary
+ * to have some way of deciding whether compression or decompression is
+ * desired other than looking at tif->tif_mode. We accomplish this by
+ * examining {TILE/STRIP}BYTECOUNTS to see if there is a non-zero entry.
+ * If so, we assume decompression is desired.
+ *
+ * This is tricky, because TIFFInitJPEG() is called while the directory is
+ * being read, and generally speaking the BYTECOUNTS tag won't have been read
+ * at that point. So we try to defer jpeg library initialization till we
+ * do have that tag ... basically any access that might require the compressor
+ * or decompressor that occurs after the reading of the directory.
+ *
+ * In an ideal world compressors or decompressors would be setup
+ * at the point where a single tile or strip was accessed (for read or write)
+ * so that stuff like update of missing tiles, or replacement of tiles could
+ * be done. However, we aren't trying to crack that nut just yet ...
+ *
+ * NFW, Feb 3rd, 2003.
+ */
+
+static int JPEGInitializeLibJPEG( TIFF * tif, int decompress )
+{
+ JPEGState* sp = JState(tif);
+
+ if(sp->cinfo_initialized)
+ {
+ if( !decompress && sp->cinfo.comm.is_decompressor )
+ TIFFjpeg_destroy( sp );
+ else if( decompress && !sp->cinfo.comm.is_decompressor )
+ TIFFjpeg_destroy( sp );
+ else
+ return 1;
+
+ sp->cinfo_initialized = 0;
+ }
+
+ /*
+ * Initialize libjpeg.
+ */
+ if ( decompress ) {
+ if (!TIFFjpeg_create_decompress(sp))
+ return (0);
+ } else {
+ if (!TIFFjpeg_create_compress(sp))
+ return (0);
+#ifndef TIFF_JPEG_MAX_MEMORY_TO_USE
+#define TIFF_JPEG_MAX_MEMORY_TO_USE (10 * 1024 * 1024)
+#endif
+ /* libjpeg turbo 1.5.2 honours max_memory_to_use, but has no backing */
+ /* store implementation, so better not set max_memory_to_use ourselves. */
+ /* See https://github.com/libjpeg-turbo/libjpeg-turbo/issues/162 */
+ if( sp->cinfo.c.mem->max_memory_to_use > 0 )
+ {
+ /* This is to address bug related in ticket GDAL #1795. */
+ if (getenv("JPEGMEM") == NULL)
+ {
+ /* Increase the max memory usable. This helps when creating files */
+ /* with "big" tile, without using libjpeg temporary files. */
+ /* For example a 512x512 tile with 3 bands */
+ /* requires 1.5 MB which is above libjpeg 1MB default */
+ if( sp->cinfo.c.mem->max_memory_to_use < TIFF_JPEG_MAX_MEMORY_TO_USE )
+ sp->cinfo.c.mem->max_memory_to_use = TIFF_JPEG_MAX_MEMORY_TO_USE;
+ }
+ }
+ }
+
+ sp->cinfo_initialized = TRUE;
+
+ return 1;
+}
+
+int
+TIFFInitJPEG(TIFF* tif, int scheme)
+{
+ JPEGState* sp;
+
+ assert(scheme == COMPRESSION_JPEG);
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, jpegFields, TIFFArrayCount(jpegFields))) {
+ TIFFErrorExt(tif->tif_clientdata,
+ "TIFFInitJPEG",
+ "Merging JPEG codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof (JPEGState));
+
+ if (tif->tif_data == NULL) {
+ TIFFErrorExt(tif->tif_clientdata,
+ "TIFFInitJPEG", "No space for JPEG state block");
+ return 0;
+ }
+ _TIFFmemset(tif->tif_data, 0, sizeof(JPEGState));
+
+ sp = JState(tif);
+ sp->tif = tif; /* back link */
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = JPEGVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = JPEGVSetField; /* hook for codec tags */
+ sp->printdir = tif->tif_tagmethods.printdir;
+ tif->tif_tagmethods.printdir = JPEGPrintDir; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->jpegtables = NULL;
+ sp->jpegtables_length = 0;
+ sp->jpegquality = 75; /* Default IJG quality */
+ sp->jpegcolormode = JPEGCOLORMODE_RAW;
+ sp->jpegtablesmode = JPEGTABLESMODE_QUANT | JPEGTABLESMODE_HUFF;
+ sp->ycbcrsampling_fetched = 0;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = JPEGFixupTags;
+ tif->tif_setupdecode = JPEGSetupDecode;
+ tif->tif_predecode = JPEGPreDecode;
+ tif->tif_decoderow = JPEGDecode;
+ tif->tif_decodestrip = JPEGDecode;
+ tif->tif_decodetile = JPEGDecode;
+ tif->tif_setupencode = JPEGSetupEncode;
+ tif->tif_preencode = JPEGPreEncode;
+ tif->tif_postencode = JPEGPostEncode;
+ tif->tif_encoderow = JPEGEncode;
+ tif->tif_encodestrip = JPEGEncode;
+ tif->tif_encodetile = JPEGEncode;
+ tif->tif_cleanup = JPEGCleanup;
+ sp->defsparent = tif->tif_defstripsize;
+ tif->tif_defstripsize = JPEGDefaultStripSize;
+ sp->deftparent = tif->tif_deftilesize;
+ tif->tif_deftilesize = JPEGDefaultTileSize;
+ tif->tif_flags |= TIFF_NOBITREV; /* no bit reversal, please */
+
+ sp->cinfo_initialized = FALSE;
+
+ /*
+ ** Create a JPEGTables field if no directory has yet been created.
+ ** We do this just to ensure that sufficient space is reserved for
+ ** the JPEGTables field. It will be properly created the right
+ ** size later.
+ */
+ if( tif->tif_diroff == 0 )
+ {
+#define SIZE_OF_JPEGTABLES 2000
+/*
+The following line assumes incorrectly that all JPEG-in-TIFF files will have
+a JPEGTABLES tag generated and causes null-filled JPEGTABLES tags to be written
+when the JPEG data is placed with TIFFWriteRawStrip. The field bit should be
+set, anyway, later when actual JPEGTABLES header is generated, so removing it
+here hopefully is harmless.
+ TIFFSetFieldBit(tif, FIELD_JPEGTABLES);
+*/
+ sp->jpegtables_length = SIZE_OF_JPEGTABLES;
+ sp->jpegtables = (void *) _TIFFmalloc(sp->jpegtables_length);
+ if (sp->jpegtables)
+ {
+ _TIFFmemset(sp->jpegtables, 0, SIZE_OF_JPEGTABLES);
+ }
+ else
+ {
+ TIFFErrorExt(tif->tif_clientdata,
+ "TIFFInitJPEG",
+ "Failed to allocate memory for JPEG tables");
+ return 0;
+ }
+#undef SIZE_OF_JPEGTABLES
+ }
+
+ return 1;
+}
+#endif /* JPEG_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_jpeg_12.c b/test/monniaux/tiff-4.0.10/tif_jpeg_12.c
new file mode 100644
index 00000000..b458c258
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_jpeg_12.c
@@ -0,0 +1,69 @@
+
+#include "tiffiop.h"
+
+#if defined(JPEG_DUAL_MODE_8_12)
+
+# define TIFFInitJPEG TIFFInitJPEG_12
+# define TIFFJPEGIsFullStripRequired TIFFJPEGIsFullStripRequired_12
+
+int
+TIFFInitJPEG_12(TIFF* tif, int scheme);
+
+# include LIBJPEG_12_PATH
+
+# include "tif_jpeg.c"
+
+int TIFFReInitJPEG_12( TIFF *tif, int scheme, int is_encode )
+
+{
+ JPEGState* sp;
+
+ assert(scheme == COMPRESSION_JPEG);
+
+ sp = JState(tif);
+ sp->tif = tif; /* back link */
+
+ /*
+ * Override parent get/set field methods.
+ */
+ tif->tif_tagmethods.vgetfield = JPEGVGetField; /* hook for codec tags */
+ tif->tif_tagmethods.vsetfield = JPEGVSetField; /* hook for codec tags */
+ tif->tif_tagmethods.printdir = JPEGPrintDir; /* hook for codec tags */
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = JPEGFixupTags;
+ tif->tif_setupdecode = JPEGSetupDecode;
+ tif->tif_predecode = JPEGPreDecode;
+ tif->tif_decoderow = JPEGDecode;
+ tif->tif_decodestrip = JPEGDecode;
+ tif->tif_decodetile = JPEGDecode;
+ tif->tif_setupencode = JPEGSetupEncode;
+ tif->tif_preencode = JPEGPreEncode;
+ tif->tif_postencode = JPEGPostEncode;
+ tif->tif_encoderow = JPEGEncode;
+ tif->tif_encodestrip = JPEGEncode;
+ tif->tif_encodetile = JPEGEncode;
+ tif->tif_cleanup = JPEGCleanup;
+ tif->tif_defstripsize = JPEGDefaultStripSize;
+ tif->tif_deftilesize = JPEGDefaultTileSize;
+ tif->tif_flags |= TIFF_NOBITREV; /* no bit reversal, please */
+
+ sp->cinfo_initialized = FALSE;
+
+ if( is_encode )
+ return JPEGSetupEncode(tif);
+ else
+ return JPEGSetupDecode(tif);
+}
+
+#endif /* defined(JPEG_DUAL_MODE_8_12) */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_luv.c b/test/monniaux/tiff-4.0.10/tif_luv.c
new file mode 100644
index 00000000..aa35ea07
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_luv.c
@@ -0,0 +1,1765 @@
+/*
+ * Copyright (c) 1997 Greg Ward Larson
+ * Copyright (c) 1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler, Greg Larson and Silicon Graphics may not be used in any
+ * advertising or publicity relating to the software without the specific,
+ * prior written permission of Sam Leffler, Greg Larson and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER, GREG LARSON OR SILICON GRAPHICS BE LIABLE
+ * FOR ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef LOGLUV_SUPPORT
+
+/*
+ * TIFF Library.
+ * LogLuv compression support for high dynamic range images.
+ *
+ * Contributed by Greg Larson.
+ *
+ * LogLuv image support uses the TIFF library to store 16 or 10-bit
+ * log luminance values with 8 bits each of u and v or a 14-bit index.
+ *
+ * The codec can take as input and produce as output 32-bit IEEE float values
+ * as well as 16-bit integer values. A 16-bit luminance is interpreted
+ * as a sign bit followed by a 15-bit integer that is converted
+ * to and from a linear magnitude using the transformation:
+ *
+ * L = 2^( (Le+.5)/256 - 64 ) # real from 15-bit
+ *
+ * Le = floor( 256*(log2(L) + 64) ) # 15-bit from real
+ *
+ * The actual conversion to world luminance units in candelas per sq. meter
+ * requires an additional multiplier, which is stored in the TIFFTAG_STONITS.
+ * This value is usually set such that a reasonable exposure comes from
+ * clamping decoded luminances above 1 to 1 in the displayed image.
+ *
+ * The 16-bit values for u and v may be converted to real values by dividing
+ * each by 32768. (This allows for negative values, which aren't useful as
+ * far as we know, but are left in case of future improvements in human
+ * color vision.)
+ *
+ * Conversion from (u,v), which is actually the CIE (u',v') system for
+ * you color scientists, is accomplished by the following transformation:
+ *
+ * u = 4*x / (-2*x + 12*y + 3)
+ * v = 9*y / (-2*x + 12*y + 3)
+ *
+ * x = 9*u / (6*u - 16*v + 12)
+ * y = 4*v / (6*u - 16*v + 12)
+ *
+ * This process is greatly simplified by passing 32-bit IEEE floats
+ * for each of three CIE XYZ coordinates. The codec then takes care
+ * of conversion to and from LogLuv, though the application is still
+ * responsible for interpreting the TIFFTAG_STONITS calibration factor.
+ *
+ * By definition, a CIE XYZ vector of [1 1 1] corresponds to a neutral white
+ * point of (x,y)=(1/3,1/3). However, most color systems assume some other
+ * white point, such as D65, and an absolute color conversion to XYZ then
+ * to another color space with a different white point may introduce an
+ * unwanted color cast to the image. It is often desirable, therefore, to
+ * perform a white point conversion that maps the input white to [1 1 1]
+ * in XYZ, then record the original white point using the TIFFTAG_WHITEPOINT
+ * tag value. A decoder that demands absolute color calibration may use
+ * this white point tag to get back the original colors, but usually it
+ * will be ignored and the new white point will be used instead that
+ * matches the output color space.
+ *
+ * Pixel information is compressed into one of two basic encodings, depending
+ * on the setting of the compression tag, which is one of COMPRESSION_SGILOG
+ * or COMPRESSION_SGILOG24. For COMPRESSION_SGILOG, greyscale data is
+ * stored as:
+ *
+ * 1 15
+ * |-+---------------|
+ *
+ * COMPRESSION_SGILOG color data is stored as:
+ *
+ * 1 15 8 8
+ * |-+---------------|--------+--------|
+ * S Le ue ve
+ *
+ * For the 24-bit COMPRESSION_SGILOG24 color format, the data is stored as:
+ *
+ * 10 14
+ * |----------|--------------|
+ * Le' Ce
+ *
+ * There is no sign bit in the 24-bit case, and the (u,v) chromaticity is
+ * encoded as an index for optimal color resolution. The 10 log bits are
+ * defined by the following conversions:
+ *
+ * L = 2^((Le'+.5)/64 - 12) # real from 10-bit
+ *
+ * Le' = floor( 64*(log2(L) + 12) ) # 10-bit from real
+ *
+ * The 10 bits of the smaller format may be converted into the 15 bits of
+ * the larger format by multiplying by 4 and adding 13314. Obviously,
+ * a smaller range of magnitudes is covered (about 5 orders of magnitude
+ * instead of 38), and the lack of a sign bit means that negative luminances
+ * are not allowed. (Well, they aren't allowed in the real world, either,
+ * but they are useful for certain types of image processing.)
+ *
+ * The desired user format is controlled by the setting the internal
+ * pseudo tag TIFFTAG_SGILOGDATAFMT to one of:
+ * SGILOGDATAFMT_FLOAT = IEEE 32-bit float XYZ values
+ * SGILOGDATAFMT_16BIT = 16-bit integer encodings of logL, u and v
+ * Raw data i/o is also possible using:
+ * SGILOGDATAFMT_RAW = 32-bit unsigned integer with encoded pixel
+ * In addition, the following decoding is provided for ease of display:
+ * SGILOGDATAFMT_8BIT = 8-bit default RGB gamma-corrected values
+ *
+ * For grayscale images, we provide the following data formats:
+ * SGILOGDATAFMT_FLOAT = IEEE 32-bit float Y values
+ * SGILOGDATAFMT_16BIT = 16-bit integer w/ encoded luminance
+ * SGILOGDATAFMT_8BIT = 8-bit gray monitor values
+ *
+ * Note that the COMPRESSION_SGILOG applies a simple run-length encoding
+ * scheme by separating the logL, u and v bytes for each row and applying
+ * a PackBits type of compression. Since the 24-bit encoding is not
+ * adaptive, the 32-bit color format takes less space in many cases.
+ *
+ * Further control is provided over the conversion from higher-resolution
+ * formats to final encoded values through the pseudo tag
+ * TIFFTAG_SGILOGENCODE:
+ * SGILOGENCODE_NODITHER = do not dither encoded values
+ * SGILOGENCODE_RANDITHER = apply random dithering during encoding
+ *
+ * The default value of this tag is SGILOGENCODE_NODITHER for
+ * COMPRESSION_SGILOG to maximize run-length encoding and
+ * SGILOGENCODE_RANDITHER for COMPRESSION_SGILOG24 to turn
+ * quantization errors into noise.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+
+/*
+ * State block for each open TIFF
+ * file using LogLuv compression/decompression.
+ */
+typedef struct logLuvState LogLuvState;
+
+struct logLuvState {
+ int encoder_state; /* 1 if encoder correctly initialized */
+ int user_datafmt; /* user data format */
+ int encode_meth; /* encoding method */
+ int pixel_size; /* bytes per pixel */
+
+ uint8* tbuf; /* translation buffer */
+ tmsize_t tbuflen; /* buffer length */
+ void (*tfunc)(LogLuvState*, uint8*, tmsize_t);
+
+ TIFFVSetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+};
+
+#define DecoderState(tif) ((LogLuvState*) (tif)->tif_data)
+#define EncoderState(tif) ((LogLuvState*) (tif)->tif_data)
+
+#define SGILOGDATAFMT_UNKNOWN -1
+
+#define MINRUN 4 /* minimum run length */
+
+/*
+ * Decode a string of 16-bit gray pixels.
+ */
+static int
+LogL16Decode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "LogL16Decode";
+ LogLuvState* sp = DecoderState(tif);
+ int shft;
+ tmsize_t i;
+ tmsize_t npixels;
+ unsigned char* bp;
+ int16* tp;
+ int16 b;
+ tmsize_t cc;
+ int rc;
+
+ assert(s == 0);
+ assert(sp != NULL);
+
+ npixels = occ / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_16BIT)
+ tp = (int16*) op;
+ else {
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ tp = (int16*) sp->tbuf;
+ }
+ _TIFFmemset((void*) tp, 0, npixels*sizeof (tp[0]));
+
+ bp = (unsigned char*) tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ /* get each byte string */
+ for (shft = 8; shft >= 0; shft -=8) {
+ for (i = 0; i < npixels && cc > 0; ) {
+ if (*bp >= 128) { /* run */
+ if( cc < 2 )
+ break;
+ rc = *bp++ + (2-128);
+ b = (int16)(*bp++ << shft);
+ cc -= 2;
+ while (rc-- && i < npixels)
+ tp[i++] |= b;
+ } else { /* non-run */
+ rc = *bp++; /* nul is noop */
+ while (--cc && rc-- && i < npixels)
+ tp[i++] |= (int16)*bp++ << shft;
+ }
+ }
+ if (i != npixels) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %I64d pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) (npixels - i));
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %llu pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) (npixels - i));
+#endif
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ return (0);
+ }
+ }
+ (*sp->tfunc)(sp, op, npixels);
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ return (1);
+}
+
+/*
+ * Decode a string of 24-bit pixels.
+ */
+static int
+LogLuvDecode24(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "LogLuvDecode24";
+ LogLuvState* sp = DecoderState(tif);
+ tmsize_t cc;
+ tmsize_t i;
+ tmsize_t npixels;
+ unsigned char* bp;
+ uint32* tp;
+
+ assert(s == 0);
+ assert(sp != NULL);
+
+ npixels = occ / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_RAW)
+ tp = (uint32 *)op;
+ else {
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ tp = (uint32 *) sp->tbuf;
+ }
+ /* copy to array of uint32 */
+ bp = (unsigned char*) tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ for (i = 0; i < npixels && cc >= 3; i++) {
+ tp[i] = bp[0] << 16 | bp[1] << 8 | bp[2];
+ bp += 3;
+ cc -= 3;
+ }
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ if (i != npixels) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %I64d pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) (npixels - i));
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %llu pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) (npixels - i));
+#endif
+ return (0);
+ }
+ (*sp->tfunc)(sp, op, npixels);
+ return (1);
+}
+
+/*
+ * Decode a string of 32-bit pixels.
+ */
+static int
+LogLuvDecode32(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "LogLuvDecode32";
+ LogLuvState* sp;
+ int shft;
+ tmsize_t i;
+ tmsize_t npixels;
+ unsigned char* bp;
+ uint32* tp;
+ uint32 b;
+ tmsize_t cc;
+ int rc;
+
+ assert(s == 0);
+ sp = DecoderState(tif);
+ assert(sp != NULL);
+
+ npixels = occ / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_RAW)
+ tp = (uint32*) op;
+ else {
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ tp = (uint32*) sp->tbuf;
+ }
+ _TIFFmemset((void*) tp, 0, npixels*sizeof (tp[0]));
+
+ bp = (unsigned char*) tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ /* get each byte string */
+ for (shft = 24; shft >= 0; shft -=8) {
+ for (i = 0; i < npixels && cc > 0; ) {
+ if (*bp >= 128) { /* run */
+ if( cc < 2 )
+ break;
+ rc = *bp++ + (2-128);
+ b = (uint32)*bp++ << shft;
+ cc -= 2;
+ while (rc-- && i < npixels)
+ tp[i++] |= b;
+ } else { /* non-run */
+ rc = *bp++; /* nul is noop */
+ while (--cc && rc-- && i < npixels)
+ tp[i++] |= (uint32)*bp++ << shft;
+ }
+ }
+ if (i != npixels) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %I64d pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) (npixels - i));
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at row %lu (short %llu pixels)",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) (npixels - i));
+#endif
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ return (0);
+ }
+ }
+ (*sp->tfunc)(sp, op, npixels);
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ return (1);
+}
+
+/*
+ * Decode a strip of pixels. We break it into rows to
+ * maintain synchrony with the encode algorithm, which
+ * is row by row.
+ */
+static int
+LogLuvDecodeStrip(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ tmsize_t rowlen = TIFFScanlineSize(tif);
+
+ if (rowlen == 0)
+ return 0;
+
+ assert(cc%rowlen == 0);
+ while (cc && (*tif->tif_decoderow)(tif, bp, rowlen, s)) {
+ bp += rowlen;
+ cc -= rowlen;
+ }
+ return (cc == 0);
+}
+
+/*
+ * Decode a tile of pixels. We break it into rows to
+ * maintain synchrony with the encode algorithm, which
+ * is row by row.
+ */
+static int
+LogLuvDecodeTile(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ tmsize_t rowlen = TIFFTileRowSize(tif);
+
+ if (rowlen == 0)
+ return 0;
+
+ assert(cc%rowlen == 0);
+ while (cc && (*tif->tif_decoderow)(tif, bp, rowlen, s)) {
+ bp += rowlen;
+ cc -= rowlen;
+ }
+ return (cc == 0);
+}
+
+/*
+ * Encode a row of 16-bit pixels.
+ */
+static int
+LogL16Encode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "LogL16Encode";
+ LogLuvState* sp = EncoderState(tif);
+ int shft;
+ tmsize_t i;
+ tmsize_t j;
+ tmsize_t npixels;
+ uint8* op;
+ int16* tp;
+ int16 b;
+ tmsize_t occ;
+ int rc=0, mask;
+ tmsize_t beg;
+
+ assert(s == 0);
+ assert(sp != NULL);
+ npixels = cc / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_16BIT)
+ tp = (int16*) bp;
+ else {
+ tp = (int16*) sp->tbuf;
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ (*sp->tfunc)(sp, bp, npixels);
+ }
+ /* compress each byte string */
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ for (shft = 8; shft >= 0; shft -=8) {
+ for (i = 0; i < npixels; i += rc) {
+ if (occ < 4) {
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+ mask = 0xff << shft; /* find next run */
+ for (beg = i; beg < npixels; beg += rc) {
+ b = (int16) (tp[beg] & mask);
+ rc = 1;
+ while (rc < 127+2 && beg+rc < npixels &&
+ (tp[beg+rc] & mask) == b)
+ rc++;
+ if (rc >= MINRUN)
+ break; /* long enough */
+ }
+ if (beg-i > 1 && beg-i < MINRUN) {
+ b = (int16) (tp[i] & mask);/*check short run */
+ j = i+1;
+ while ((tp[j++] & mask) == b)
+ if (j == beg) {
+ *op++ = (uint8)(128-2+j-i);
+ *op++ = (uint8)(b >> shft);
+ occ -= 2;
+ i = beg;
+ break;
+ }
+ }
+ while (i < beg) { /* write out non-run */
+ if ((j = beg-i) > 127) j = 127;
+ if (occ < j+3) {
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+ *op++ = (uint8) j; occ--;
+ while (j--) {
+ *op++ = (uint8) (tp[i++] >> shft & 0xff);
+ occ--;
+ }
+ }
+ if (rc >= MINRUN) { /* write out run */
+ *op++ = (uint8) (128-2+rc);
+ *op++ = (uint8) (tp[beg] >> shft & 0xff);
+ occ -= 2;
+ } else
+ rc = 0;
+ }
+ }
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+
+ return (1);
+}
+
+/*
+ * Encode a row of 24-bit pixels.
+ */
+static int
+LogLuvEncode24(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "LogLuvEncode24";
+ LogLuvState* sp = EncoderState(tif);
+ tmsize_t i;
+ tmsize_t npixels;
+ tmsize_t occ;
+ uint8* op;
+ uint32* tp;
+
+ assert(s == 0);
+ assert(sp != NULL);
+ npixels = cc / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_RAW)
+ tp = (uint32*) bp;
+ else {
+ tp = (uint32*) sp->tbuf;
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ (*sp->tfunc)(sp, bp, npixels);
+ }
+ /* write out encoded pixels */
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ for (i = npixels; i--; ) {
+ if (occ < 3) {
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+ *op++ = (uint8)(*tp >> 16);
+ *op++ = (uint8)(*tp >> 8 & 0xff);
+ *op++ = (uint8)(*tp++ & 0xff);
+ occ -= 3;
+ }
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+
+ return (1);
+}
+
+/*
+ * Encode a row of 32-bit pixels.
+ */
+static int
+LogLuvEncode32(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "LogLuvEncode32";
+ LogLuvState* sp = EncoderState(tif);
+ int shft;
+ tmsize_t i;
+ tmsize_t j;
+ tmsize_t npixels;
+ uint8* op;
+ uint32* tp;
+ uint32 b;
+ tmsize_t occ;
+ int rc=0, mask;
+ tmsize_t beg;
+
+ assert(s == 0);
+ assert(sp != NULL);
+
+ npixels = cc / sp->pixel_size;
+
+ if (sp->user_datafmt == SGILOGDATAFMT_RAW)
+ tp = (uint32*) bp;
+ else {
+ tp = (uint32*) sp->tbuf;
+ if(sp->tbuflen < npixels) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Translation buffer too short");
+ return (0);
+ }
+ (*sp->tfunc)(sp, bp, npixels);
+ }
+ /* compress each byte string */
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ for (shft = 24; shft >= 0; shft -=8) {
+ for (i = 0; i < npixels; i += rc) {
+ if (occ < 4) {
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+ mask = 0xff << shft; /* find next run */
+ for (beg = i; beg < npixels; beg += rc) {
+ b = tp[beg] & mask;
+ rc = 1;
+ while (rc < 127+2 && beg+rc < npixels &&
+ (tp[beg+rc] & mask) == b)
+ rc++;
+ if (rc >= MINRUN)
+ break; /* long enough */
+ }
+ if (beg-i > 1 && beg-i < MINRUN) {
+ b = tp[i] & mask; /* check short run */
+ j = i+1;
+ while ((tp[j++] & mask) == b)
+ if (j == beg) {
+ *op++ = (uint8)(128-2+j-i);
+ *op++ = (uint8)(b >> shft);
+ occ -= 2;
+ i = beg;
+ break;
+ }
+ }
+ while (i < beg) { /* write out non-run */
+ if ((j = beg-i) > 127) j = 127;
+ if (occ < j+3) {
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ occ = tif->tif_rawdatasize - tif->tif_rawcc;
+ }
+ *op++ = (uint8) j; occ--;
+ while (j--) {
+ *op++ = (uint8)(tp[i++] >> shft & 0xff);
+ occ--;
+ }
+ }
+ if (rc >= MINRUN) { /* write out run */
+ *op++ = (uint8) (128-2+rc);
+ *op++ = (uint8)(tp[beg] >> shft & 0xff);
+ occ -= 2;
+ } else
+ rc = 0;
+ }
+ }
+ tif->tif_rawcp = op;
+ tif->tif_rawcc = tif->tif_rawdatasize - occ;
+
+ return (1);
+}
+
+/*
+ * Encode a strip of pixels. We break it into rows to
+ * avoid encoding runs across row boundaries.
+ */
+static int
+LogLuvEncodeStrip(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ tmsize_t rowlen = TIFFScanlineSize(tif);
+
+ if (rowlen == 0)
+ return 0;
+
+ assert(cc%rowlen == 0);
+ while (cc && (*tif->tif_encoderow)(tif, bp, rowlen, s) == 1) {
+ bp += rowlen;
+ cc -= rowlen;
+ }
+ return (cc == 0);
+}
+
+/*
+ * Encode a tile of pixels. We break it into rows to
+ * avoid encoding runs across row boundaries.
+ */
+static int
+LogLuvEncodeTile(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ tmsize_t rowlen = TIFFTileRowSize(tif);
+
+ if (rowlen == 0)
+ return 0;
+
+ assert(cc%rowlen == 0);
+ while (cc && (*tif->tif_encoderow)(tif, bp, rowlen, s) == 1) {
+ bp += rowlen;
+ cc -= rowlen;
+ }
+ return (cc == 0);
+}
+
+/*
+ * Encode/Decode functions for converting to and from user formats.
+ */
+
+#include "uvcode.h"
+
+#ifndef UVSCALE
+#define U_NEU 0.210526316
+#define V_NEU 0.473684211
+#define UVSCALE 410.
+#endif
+
+#ifndef M_LN2
+#define M_LN2 0.69314718055994530942
+#endif
+#ifndef M_PI
+#define M_PI 3.14159265358979323846
+#endif
+#undef log2 /* Conflict with C'99 function */
+#define log2(x) ((1./M_LN2)*log(x))
+#undef exp2 /* Conflict with C'99 function */
+#define exp2(x) exp(M_LN2*(x))
+
+#define itrunc(x,m) ((m)==SGILOGENCODE_NODITHER ? \
+ (int)(x) : \
+ (int)((x) + rand()*(1./RAND_MAX) - .5))
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+double
+LogL16toY(int p16) /* compute luminance from 16-bit LogL */
+{
+ int Le = p16 & 0x7fff;
+ double Y;
+
+ if (!Le)
+ return (0.);
+ Y = exp(M_LN2/256.*(Le+.5) - M_LN2*64.);
+ return (!(p16 & 0x8000) ? Y : -Y);
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+int
+LogL16fromY(double Y, int em) /* get 16-bit LogL from Y */
+{
+ if (Y >= 1.8371976e19)
+ return (0x7fff);
+ if (Y <= -1.8371976e19)
+ return (0xffff);
+ if (Y > 5.4136769e-20)
+ return itrunc(256.*(log2(Y) + 64.), em);
+ if (Y < -5.4136769e-20)
+ return (~0x7fff | itrunc(256.*(log2(-Y) + 64.), em));
+ return (0);
+}
+
+static void
+L16toY(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ int16* l16 = (int16*) sp->tbuf;
+ float* yp = (float*) op;
+
+ while (n-- > 0)
+ *yp++ = (float)LogL16toY(*l16++);
+}
+
+static void
+L16toGry(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ int16* l16 = (int16*) sp->tbuf;
+ uint8* gp = (uint8*) op;
+
+ while (n-- > 0) {
+ double Y = LogL16toY(*l16++);
+ *gp++ = (uint8) ((Y <= 0.) ? 0 : (Y >= 1.) ? 255 : (int)(256.*sqrt(Y)));
+ }
+}
+
+static void
+L16fromY(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ int16* l16 = (int16*) sp->tbuf;
+ float* yp = (float*) op;
+
+ while (n-- > 0)
+ *l16++ = (int16) (LogL16fromY(*yp++, sp->encode_meth));
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+void
+XYZtoRGB24(float xyz[3], uint8 rgb[3])
+{
+ double r, g, b;
+ /* assume CCIR-709 primaries */
+ r = 2.690*xyz[0] + -1.276*xyz[1] + -0.414*xyz[2];
+ g = -1.022*xyz[0] + 1.978*xyz[1] + 0.044*xyz[2];
+ b = 0.061*xyz[0] + -0.224*xyz[1] + 1.163*xyz[2];
+ /* assume 2.0 gamma for speed */
+ /* could use integer sqrt approx., but this is probably faster */
+ rgb[0] = (uint8)((r<=0.) ? 0 : (r >= 1.) ? 255 : (int)(256.*sqrt(r)));
+ rgb[1] = (uint8)((g<=0.) ? 0 : (g >= 1.) ? 255 : (int)(256.*sqrt(g)));
+ rgb[2] = (uint8)((b<=0.) ? 0 : (b >= 1.) ? 255 : (int)(256.*sqrt(b)));
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+double
+LogL10toY(int p10) /* compute luminance from 10-bit LogL */
+{
+ if (p10 == 0)
+ return (0.);
+ return (exp(M_LN2/64.*(p10+.5) - M_LN2*12.));
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+int
+LogL10fromY(double Y, int em) /* get 10-bit LogL from Y */
+{
+ if (Y >= 15.742)
+ return (0x3ff);
+ else if (Y <= .00024283)
+ return (0);
+ else
+ return itrunc(64.*(log2(Y) + 12.), em);
+}
+
+#define NANGLES 100
+#define uv2ang(u, v) ( (NANGLES*.499999999/M_PI) \
+ * atan2((v)-V_NEU,(u)-U_NEU) + .5*NANGLES )
+
+static int
+oog_encode(double u, double v) /* encode out-of-gamut chroma */
+{
+ static int oog_table[NANGLES];
+ static int initialized = 0;
+ register int i;
+
+ if (!initialized) { /* set up perimeter table */
+ double eps[NANGLES], ua, va, ang, epsa;
+ int ui, vi, ustep;
+ for (i = NANGLES; i--; )
+ eps[i] = 2.;
+ for (vi = UV_NVS; vi--; ) {
+ va = UV_VSTART + (vi+.5)*UV_SQSIZ;
+ ustep = uv_row[vi].nus-1;
+ if (vi == UV_NVS-1 || vi == 0 || ustep <= 0)
+ ustep = 1;
+ for (ui = uv_row[vi].nus-1; ui >= 0; ui -= ustep) {
+ ua = uv_row[vi].ustart + (ui+.5)*UV_SQSIZ;
+ ang = uv2ang(ua, va);
+ i = (int) ang;
+ epsa = fabs(ang - (i+.5));
+ if (epsa < eps[i]) {
+ oog_table[i] = uv_row[vi].ncum + ui;
+ eps[i] = epsa;
+ }
+ }
+ }
+ for (i = NANGLES; i--; ) /* fill any holes */
+ if (eps[i] > 1.5) {
+ int i1, i2;
+ for (i1 = 1; i1 < NANGLES/2; i1++)
+ if (eps[(i+i1)%NANGLES] < 1.5)
+ break;
+ for (i2 = 1; i2 < NANGLES/2; i2++)
+ if (eps[(i+NANGLES-i2)%NANGLES] < 1.5)
+ break;
+ if (i1 < i2)
+ oog_table[i] =
+ oog_table[(i+i1)%NANGLES];
+ else
+ oog_table[i] =
+ oog_table[(i+NANGLES-i2)%NANGLES];
+ }
+ initialized = 1;
+ }
+ i = (int) uv2ang(u, v); /* look up hue angle */
+ return (oog_table[i]);
+}
+
+#undef uv2ang
+#undef NANGLES
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+int
+uv_encode(double u, double v, int em) /* encode (u',v') coordinates */
+{
+ register int vi, ui;
+
+ if (v < UV_VSTART)
+ return oog_encode(u, v);
+ vi = itrunc((v - UV_VSTART)*(1./UV_SQSIZ), em);
+ if (vi >= UV_NVS)
+ return oog_encode(u, v);
+ if (u < uv_row[vi].ustart)
+ return oog_encode(u, v);
+ ui = itrunc((u - uv_row[vi].ustart)*(1./UV_SQSIZ), em);
+ if (ui >= uv_row[vi].nus)
+ return oog_encode(u, v);
+
+ return (uv_row[vi].ncum + ui);
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+int
+uv_decode(double *up, double *vp, int c) /* decode (u',v') index */
+{
+ int upper, lower;
+ register int ui, vi;
+
+ if (c < 0 || c >= UV_NDIVS)
+ return (-1);
+ lower = 0; /* binary search */
+ upper = UV_NVS;
+ while (upper - lower > 1) {
+ vi = (lower + upper) >> 1;
+ ui = c - uv_row[vi].ncum;
+ if (ui > 0)
+ lower = vi;
+ else if (ui < 0)
+ upper = vi;
+ else {
+ lower = vi;
+ break;
+ }
+ }
+ vi = lower;
+ ui = c - uv_row[vi].ncum;
+ *up = uv_row[vi].ustart + (ui+.5)*UV_SQSIZ;
+ *vp = UV_VSTART + (vi+.5)*UV_SQSIZ;
+ return (0);
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+void
+LogLuv24toXYZ(uint32 p, float XYZ[3])
+{
+ int Ce;
+ double L, u, v, s, x, y;
+ /* decode luminance */
+ L = LogL10toY(p>>14 & 0x3ff);
+ if (L <= 0.) {
+ XYZ[0] = XYZ[1] = XYZ[2] = 0.;
+ return;
+ }
+ /* decode color */
+ Ce = p & 0x3fff;
+ if (uv_decode(&u, &v, Ce) < 0) {
+ u = U_NEU; v = V_NEU;
+ }
+ s = 1./(6.*u - 16.*v + 12.);
+ x = 9.*u * s;
+ y = 4.*v * s;
+ /* convert to XYZ */
+ XYZ[0] = (float)(x/y * L);
+ XYZ[1] = (float)L;
+ XYZ[2] = (float)((1.-x-y)/y * L);
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+uint32
+LogLuv24fromXYZ(float XYZ[3], int em)
+{
+ int Le, Ce;
+ double u, v, s;
+ /* encode luminance */
+ Le = LogL10fromY(XYZ[1], em);
+ /* encode color */
+ s = XYZ[0] + 15.*XYZ[1] + 3.*XYZ[2];
+ if (!Le || s <= 0.) {
+ u = U_NEU;
+ v = V_NEU;
+ } else {
+ u = 4.*XYZ[0] / s;
+ v = 9.*XYZ[1] / s;
+ }
+ Ce = uv_encode(u, v, em);
+ if (Ce < 0) /* never happens */
+ Ce = uv_encode(U_NEU, V_NEU, SGILOGENCODE_NODITHER);
+ /* combine encodings */
+ return (Le << 14 | Ce);
+}
+
+static void
+Luv24toXYZ(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ float* xyz = (float*) op;
+
+ while (n-- > 0) {
+ LogLuv24toXYZ(*luv, xyz);
+ xyz += 3;
+ luv++;
+ }
+}
+
+static void
+Luv24toLuv48(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ int16* luv3 = (int16*) op;
+
+ while (n-- > 0) {
+ double u, v;
+
+ *luv3++ = (int16)((*luv >> 12 & 0xffd) + 13314);
+ if (uv_decode(&u, &v, *luv&0x3fff) < 0) {
+ u = U_NEU;
+ v = V_NEU;
+ }
+ *luv3++ = (int16)(u * (1L<<15));
+ *luv3++ = (int16)(v * (1L<<15));
+ luv++;
+ }
+}
+
+static void
+Luv24toRGB(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ uint8* rgb = (uint8*) op;
+
+ while (n-- > 0) {
+ float xyz[3];
+
+ LogLuv24toXYZ(*luv++, xyz);
+ XYZtoRGB24(xyz, rgb);
+ rgb += 3;
+ }
+}
+
+static void
+Luv24fromXYZ(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ float* xyz = (float*) op;
+
+ while (n-- > 0) {
+ *luv++ = LogLuv24fromXYZ(xyz, sp->encode_meth);
+ xyz += 3;
+ }
+}
+
+static void
+Luv24fromLuv48(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ int16* luv3 = (int16*) op;
+
+ while (n-- > 0) {
+ int Le, Ce;
+
+ if (luv3[0] <= 0)
+ Le = 0;
+ else if (luv3[0] >= (1<<12)+3314)
+ Le = (1<<10) - 1;
+ else if (sp->encode_meth == SGILOGENCODE_NODITHER)
+ Le = (luv3[0]-3314) >> 2;
+ else
+ Le = itrunc(.25*(luv3[0]-3314.), sp->encode_meth);
+
+ Ce = uv_encode((luv3[1]+.5)/(1<<15), (luv3[2]+.5)/(1<<15),
+ sp->encode_meth);
+ if (Ce < 0) /* never happens */
+ Ce = uv_encode(U_NEU, V_NEU, SGILOGENCODE_NODITHER);
+ *luv++ = (uint32)Le << 14 | Ce;
+ luv3 += 3;
+ }
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+void
+LogLuv32toXYZ(uint32 p, float XYZ[3])
+{
+ double L, u, v, s, x, y;
+ /* decode luminance */
+ L = LogL16toY((int)p >> 16);
+ if (L <= 0.) {
+ XYZ[0] = XYZ[1] = XYZ[2] = 0.;
+ return;
+ }
+ /* decode color */
+ u = 1./UVSCALE * ((p>>8 & 0xff) + .5);
+ v = 1./UVSCALE * ((p & 0xff) + .5);
+ s = 1./(6.*u - 16.*v + 12.);
+ x = 9.*u * s;
+ y = 4.*v * s;
+ /* convert to XYZ */
+ XYZ[0] = (float)(x/y * L);
+ XYZ[1] = (float)L;
+ XYZ[2] = (float)((1.-x-y)/y * L);
+}
+
+#if !LOGLUV_PUBLIC
+static
+#endif
+uint32
+LogLuv32fromXYZ(float XYZ[3], int em)
+{
+ unsigned int Le, ue, ve;
+ double u, v, s;
+ /* encode luminance */
+ Le = (unsigned int)LogL16fromY(XYZ[1], em);
+ /* encode color */
+ s = XYZ[0] + 15.*XYZ[1] + 3.*XYZ[2];
+ if (!Le || s <= 0.) {
+ u = U_NEU;
+ v = V_NEU;
+ } else {
+ u = 4.*XYZ[0] / s;
+ v = 9.*XYZ[1] / s;
+ }
+ if (u <= 0.) ue = 0;
+ else ue = itrunc(UVSCALE*u, em);
+ if (ue > 255) ue = 255;
+ if (v <= 0.) ve = 0;
+ else ve = itrunc(UVSCALE*v, em);
+ if (ve > 255) ve = 255;
+ /* combine encodings */
+ return (Le << 16 | ue << 8 | ve);
+}
+
+static void
+Luv32toXYZ(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ float* xyz = (float*) op;
+
+ while (n-- > 0) {
+ LogLuv32toXYZ(*luv++, xyz);
+ xyz += 3;
+ }
+}
+
+static void
+Luv32toLuv48(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ int16* luv3 = (int16*) op;
+
+ while (n-- > 0) {
+ double u, v;
+
+ *luv3++ = (int16)(*luv >> 16);
+ u = 1./UVSCALE * ((*luv>>8 & 0xff) + .5);
+ v = 1./UVSCALE * ((*luv & 0xff) + .5);
+ *luv3++ = (int16)(u * (1L<<15));
+ *luv3++ = (int16)(v * (1L<<15));
+ luv++;
+ }
+}
+
+static void
+Luv32toRGB(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ uint8* rgb = (uint8*) op;
+
+ while (n-- > 0) {
+ float xyz[3];
+
+ LogLuv32toXYZ(*luv++, xyz);
+ XYZtoRGB24(xyz, rgb);
+ rgb += 3;
+ }
+}
+
+static void
+Luv32fromXYZ(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ float* xyz = (float*) op;
+
+ while (n-- > 0) {
+ *luv++ = LogLuv32fromXYZ(xyz, sp->encode_meth);
+ xyz += 3;
+ }
+}
+
+static void
+Luv32fromLuv48(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ uint32* luv = (uint32*) sp->tbuf;
+ int16* luv3 = (int16*) op;
+
+ if (sp->encode_meth == SGILOGENCODE_NODITHER) {
+ while (n-- > 0) {
+ *luv++ = (uint32)luv3[0] << 16 |
+ (luv3[1]*(uint32)(UVSCALE+.5) >> 7 & 0xff00) |
+ (luv3[2]*(uint32)(UVSCALE+.5) >> 15 & 0xff);
+ luv3 += 3;
+ }
+ return;
+ }
+ while (n-- > 0) {
+ *luv++ = (uint32)luv3[0] << 16 |
+ (itrunc(luv3[1]*(UVSCALE/(1<<15)), sp->encode_meth) << 8 & 0xff00) |
+ (itrunc(luv3[2]*(UVSCALE/(1<<15)), sp->encode_meth) & 0xff);
+ luv3 += 3;
+ }
+}
+
+static void
+_logLuvNop(LogLuvState* sp, uint8* op, tmsize_t n)
+{
+ (void) sp; (void) op; (void) n;
+}
+
+static int
+LogL16GuessDataFmt(TIFFDirectory *td)
+{
+#define PACK(s,b,f) (((b)<<6)|((s)<<3)|(f))
+ switch (PACK(td->td_samplesperpixel, td->td_bitspersample, td->td_sampleformat)) {
+ case PACK(1, 32, SAMPLEFORMAT_IEEEFP):
+ return (SGILOGDATAFMT_FLOAT);
+ case PACK(1, 16, SAMPLEFORMAT_VOID):
+ case PACK(1, 16, SAMPLEFORMAT_INT):
+ case PACK(1, 16, SAMPLEFORMAT_UINT):
+ return (SGILOGDATAFMT_16BIT);
+ case PACK(1, 8, SAMPLEFORMAT_VOID):
+ case PACK(1, 8, SAMPLEFORMAT_UINT):
+ return (SGILOGDATAFMT_8BIT);
+ }
+#undef PACK
+ return (SGILOGDATAFMT_UNKNOWN);
+}
+
+
+#define TIFF_SIZE_T_MAX ((size_t) ~ ((size_t)0))
+#define TIFF_TMSIZE_T_MAX (tmsize_t)(TIFF_SIZE_T_MAX >> 1)
+
+static tmsize_t
+multiply_ms(tmsize_t m1, tmsize_t m2)
+{
+ if( m1 == 0 || m2 > TIFF_TMSIZE_T_MAX / m1 )
+ return 0;
+ return m1 * m2;
+}
+
+static int
+LogL16InitState(TIFF* tif)
+{
+ static const char module[] = "LogL16InitState";
+ TIFFDirectory *td = &tif->tif_dir;
+ LogLuvState* sp = DecoderState(tif);
+
+ assert(sp != NULL);
+ assert(td->td_photometric == PHOTOMETRIC_LOGL);
+
+ if( td->td_samplesperpixel != 1 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Sorry, can not handle LogL image with %s=%d",
+ "Samples/pixel", td->td_samplesperpixel);
+ return 0;
+ }
+
+ /* for some reason, we can't do this in TIFFInitLogL16 */
+ if (sp->user_datafmt == SGILOGDATAFMT_UNKNOWN)
+ sp->user_datafmt = LogL16GuessDataFmt(td);
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->pixel_size = sizeof (float);
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->pixel_size = sizeof (int16);
+ break;
+ case SGILOGDATAFMT_8BIT:
+ sp->pixel_size = sizeof (uint8);
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No support for converting user data format to LogL");
+ return (0);
+ }
+ if( isTiled(tif) )
+ sp->tbuflen = multiply_ms(td->td_tilewidth, td->td_tilelength);
+ else if( td->td_rowsperstrip < td->td_imagelength )
+ sp->tbuflen = multiply_ms(td->td_imagewidth, td->td_rowsperstrip);
+ else
+ sp->tbuflen = multiply_ms(td->td_imagewidth, td->td_imagelength);
+ if (multiply_ms(sp->tbuflen, sizeof (int16)) == 0 ||
+ (sp->tbuf = (uint8*) _TIFFmalloc(sp->tbuflen * sizeof (int16))) == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module, "No space for SGILog translation buffer");
+ return (0);
+ }
+ return (1);
+}
+
+static int
+LogLuvGuessDataFmt(TIFFDirectory *td)
+{
+ int guess;
+
+ /*
+ * If the user didn't tell us their datafmt,
+ * take our best guess from the bitspersample.
+ */
+#define PACK(a,b) (((a)<<3)|(b))
+ switch (PACK(td->td_bitspersample, td->td_sampleformat)) {
+ case PACK(32, SAMPLEFORMAT_IEEEFP):
+ guess = SGILOGDATAFMT_FLOAT;
+ break;
+ case PACK(32, SAMPLEFORMAT_VOID):
+ case PACK(32, SAMPLEFORMAT_UINT):
+ case PACK(32, SAMPLEFORMAT_INT):
+ guess = SGILOGDATAFMT_RAW;
+ break;
+ case PACK(16, SAMPLEFORMAT_VOID):
+ case PACK(16, SAMPLEFORMAT_INT):
+ case PACK(16, SAMPLEFORMAT_UINT):
+ guess = SGILOGDATAFMT_16BIT;
+ break;
+ case PACK( 8, SAMPLEFORMAT_VOID):
+ case PACK( 8, SAMPLEFORMAT_UINT):
+ guess = SGILOGDATAFMT_8BIT;
+ break;
+ default:
+ guess = SGILOGDATAFMT_UNKNOWN;
+ break;
+#undef PACK
+ }
+ /*
+ * Double-check samples per pixel.
+ */
+ switch (td->td_samplesperpixel) {
+ case 1:
+ if (guess != SGILOGDATAFMT_RAW)
+ guess = SGILOGDATAFMT_UNKNOWN;
+ break;
+ case 3:
+ if (guess == SGILOGDATAFMT_RAW)
+ guess = SGILOGDATAFMT_UNKNOWN;
+ break;
+ default:
+ guess = SGILOGDATAFMT_UNKNOWN;
+ break;
+ }
+ return (guess);
+}
+
+static int
+LogLuvInitState(TIFF* tif)
+{
+ static const char module[] = "LogLuvInitState";
+ TIFFDirectory* td = &tif->tif_dir;
+ LogLuvState* sp = DecoderState(tif);
+
+ assert(sp != NULL);
+ assert(td->td_photometric == PHOTOMETRIC_LOGLUV);
+
+ /* for some reason, we can't do this in TIFFInitLogLuv */
+ if (td->td_planarconfig != PLANARCONFIG_CONTIG) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "SGILog compression cannot handle non-contiguous data");
+ return (0);
+ }
+ if (sp->user_datafmt == SGILOGDATAFMT_UNKNOWN)
+ sp->user_datafmt = LogLuvGuessDataFmt(td);
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->pixel_size = 3*sizeof (float);
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->pixel_size = 3*sizeof (int16);
+ break;
+ case SGILOGDATAFMT_RAW:
+ sp->pixel_size = sizeof (uint32);
+ break;
+ case SGILOGDATAFMT_8BIT:
+ sp->pixel_size = 3*sizeof (uint8);
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No support for converting user data format to LogLuv");
+ return (0);
+ }
+ if( isTiled(tif) )
+ sp->tbuflen = multiply_ms(td->td_tilewidth, td->td_tilelength);
+ else if( td->td_rowsperstrip < td->td_imagelength )
+ sp->tbuflen = multiply_ms(td->td_imagewidth, td->td_rowsperstrip);
+ else
+ sp->tbuflen = multiply_ms(td->td_imagewidth, td->td_imagelength);
+ if (multiply_ms(sp->tbuflen, sizeof (uint32)) == 0 ||
+ (sp->tbuf = (uint8*) _TIFFmalloc(sp->tbuflen * sizeof (uint32))) == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module, "No space for SGILog translation buffer");
+ return (0);
+ }
+ return (1);
+}
+
+static int
+LogLuvFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+static int
+LogLuvSetupDecode(TIFF* tif)
+{
+ static const char module[] = "LogLuvSetupDecode";
+ LogLuvState* sp = DecoderState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ switch (td->td_photometric) {
+ case PHOTOMETRIC_LOGLUV:
+ if (!LogLuvInitState(tif))
+ break;
+ if (td->td_compression == COMPRESSION_SGILOG24) {
+ tif->tif_decoderow = LogLuvDecode24;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = Luv24toXYZ;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->tfunc = Luv24toLuv48;
+ break;
+ case SGILOGDATAFMT_8BIT:
+ sp->tfunc = Luv24toRGB;
+ break;
+ }
+ } else {
+ tif->tif_decoderow = LogLuvDecode32;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = Luv32toXYZ;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->tfunc = Luv32toLuv48;
+ break;
+ case SGILOGDATAFMT_8BIT:
+ sp->tfunc = Luv32toRGB;
+ break;
+ }
+ }
+ return (1);
+ case PHOTOMETRIC_LOGL:
+ if (!LogL16InitState(tif))
+ break;
+ tif->tif_decoderow = LogL16Decode;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = L16toY;
+ break;
+ case SGILOGDATAFMT_8BIT:
+ sp->tfunc = L16toGry;
+ break;
+ }
+ return (1);
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Inappropriate photometric interpretation %d for SGILog compression; %s",
+ td->td_photometric, "must be either LogLUV or LogL");
+ break;
+ }
+ return (0);
+}
+
+static int
+LogLuvSetupEncode(TIFF* tif)
+{
+ static const char module[] = "LogLuvSetupEncode";
+ LogLuvState* sp = EncoderState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ switch (td->td_photometric) {
+ case PHOTOMETRIC_LOGLUV:
+ if (!LogLuvInitState(tif))
+ break;
+ if (td->td_compression == COMPRESSION_SGILOG24) {
+ tif->tif_encoderow = LogLuvEncode24;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = Luv24fromXYZ;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->tfunc = Luv24fromLuv48;
+ break;
+ case SGILOGDATAFMT_RAW:
+ break;
+ default:
+ goto notsupported;
+ }
+ } else {
+ tif->tif_encoderow = LogLuvEncode32;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = Luv32fromXYZ;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ sp->tfunc = Luv32fromLuv48;
+ break;
+ case SGILOGDATAFMT_RAW:
+ break;
+ default:
+ goto notsupported;
+ }
+ }
+ break;
+ case PHOTOMETRIC_LOGL:
+ if (!LogL16InitState(tif))
+ break;
+ tif->tif_encoderow = LogL16Encode;
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ sp->tfunc = L16fromY;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ break;
+ default:
+ goto notsupported;
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Inappropriate photometric interpretation %d for SGILog compression; %s",
+ td->td_photometric, "must be either LogLUV or LogL");
+ break;
+ }
+ sp->encoder_state = 1;
+ return (1);
+notsupported:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "SGILog compression supported only for %s, or raw data",
+ td->td_photometric == PHOTOMETRIC_LOGL ? "Y, L" : "XYZ, Luv");
+ return (0);
+}
+
+static void
+LogLuvClose(TIFF* tif)
+{
+ LogLuvState* sp = (LogLuvState*) tif->tif_data;
+ TIFFDirectory *td = &tif->tif_dir;
+
+ assert(sp != 0);
+ /*
+ * For consistency, we always want to write out the same
+ * bitspersample and sampleformat for our TIFF file,
+ * regardless of the data format being used by the application.
+ * Since this routine is called after tags have been set but
+ * before they have been recorded in the file, we reset them here.
+ * Note: this is really a nasty approach. See PixarLogClose
+ */
+ if( sp->encoder_state )
+ {
+ /* See PixarLogClose. Might avoid issues with tags whose size depends
+ * on those below, but not completely sure this is enough. */
+ td->td_samplesperpixel =
+ (td->td_photometric == PHOTOMETRIC_LOGL) ? 1 : 3;
+ td->td_bitspersample = 16;
+ td->td_sampleformat = SAMPLEFORMAT_INT;
+ }
+}
+
+static void
+LogLuvCleanup(TIFF* tif)
+{
+ LogLuvState* sp = (LogLuvState *)tif->tif_data;
+
+ assert(sp != 0);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->tbuf)
+ _TIFFfree(sp->tbuf);
+ _TIFFfree(sp);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+LogLuvVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "LogLuvVSetField";
+ LogLuvState* sp = DecoderState(tif);
+ int bps, fmt;
+
+ switch (tag) {
+ case TIFFTAG_SGILOGDATAFMT:
+ sp->user_datafmt = (int) va_arg(ap, int);
+ /*
+ * Tweak the TIFF header so that the rest of libtiff knows what
+ * size of data will be passed between app and library, and
+ * assume that the app knows what it is doing and is not
+ * confused by these header manipulations...
+ */
+ switch (sp->user_datafmt) {
+ case SGILOGDATAFMT_FLOAT:
+ bps = 32;
+ fmt = SAMPLEFORMAT_IEEEFP;
+ break;
+ case SGILOGDATAFMT_16BIT:
+ bps = 16;
+ fmt = SAMPLEFORMAT_INT;
+ break;
+ case SGILOGDATAFMT_RAW:
+ bps = 32;
+ fmt = SAMPLEFORMAT_UINT;
+ TIFFSetField(tif, TIFFTAG_SAMPLESPERPIXEL, 1);
+ break;
+ case SGILOGDATAFMT_8BIT:
+ bps = 8;
+ fmt = SAMPLEFORMAT_UINT;
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "Unknown data format %d for LogLuv compression",
+ sp->user_datafmt);
+ return (0);
+ }
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, bps);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, fmt);
+ /*
+ * Must recalculate sizes should bits/sample change.
+ */
+ tif->tif_tilesize = isTiled(tif) ? TIFFTileSize(tif) : (tmsize_t) -1;
+ tif->tif_scanlinesize = TIFFScanlineSize(tif);
+ return (1);
+ case TIFFTAG_SGILOGENCODE:
+ sp->encode_meth = (int) va_arg(ap, int);
+ if (sp->encode_meth != SGILOGENCODE_NODITHER &&
+ sp->encode_meth != SGILOGENCODE_RANDITHER) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Unknown encoding %d for LogLuv compression",
+ sp->encode_meth);
+ return (0);
+ }
+ return (1);
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+}
+
+static int
+LogLuvVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ LogLuvState *sp = (LogLuvState *)tif->tif_data;
+
+ switch (tag) {
+ case TIFFTAG_SGILOGDATAFMT:
+ *va_arg(ap, int*) = sp->user_datafmt;
+ return (1);
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+}
+
+static const TIFFField LogLuvFields[] = {
+ { TIFFTAG_SGILOGDATAFMT, 0, 0, TIFF_SHORT, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, TRUE, FALSE, "SGILogDataFmt", NULL},
+ { TIFFTAG_SGILOGENCODE, 0, 0, TIFF_SHORT, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, TRUE, FALSE, "SGILogEncode", NULL}
+};
+
+int
+TIFFInitSGILog(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitSGILog";
+ LogLuvState* sp;
+
+ assert(scheme == COMPRESSION_SGILOG24 || scheme == COMPRESSION_SGILOG);
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, LogLuvFields,
+ TIFFArrayCount(LogLuvFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging SGILog codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof (LogLuvState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = (LogLuvState*) tif->tif_data;
+ _TIFFmemset((void*)sp, 0, sizeof (*sp));
+ sp->user_datafmt = SGILOGDATAFMT_UNKNOWN;
+ sp->encode_meth = (scheme == COMPRESSION_SGILOG24) ?
+ SGILOGENCODE_RANDITHER : SGILOGENCODE_NODITHER;
+ sp->tfunc = _logLuvNop;
+
+ /*
+ * Install codec methods.
+ * NB: tif_decoderow & tif_encoderow are filled
+ * in at setup time.
+ */
+ tif->tif_fixuptags = LogLuvFixupTags;
+ tif->tif_setupdecode = LogLuvSetupDecode;
+ tif->tif_decodestrip = LogLuvDecodeStrip;
+ tif->tif_decodetile = LogLuvDecodeTile;
+ tif->tif_setupencode = LogLuvSetupEncode;
+ tif->tif_encodestrip = LogLuvEncodeStrip;
+ tif->tif_encodetile = LogLuvEncodeTile;
+ tif->tif_close = LogLuvClose;
+ tif->tif_cleanup = LogLuvCleanup;
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = LogLuvVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = LogLuvVSetField; /* hook for codec tags */
+
+ return (1);
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s: No space for LogLuv state block", tif->tif_name);
+ return (0);
+}
+#endif /* LOGLUV_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_lzma.c b/test/monniaux/tiff-4.0.10/tif_lzma.c
new file mode 100644
index 00000000..3f6096b6
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_lzma.c
@@ -0,0 +1,500 @@
+/*
+ * Copyright (c) 2010, Andrey Kiselev <dron@ak4719.spb.edu>
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef LZMA_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * LZMA2 Compression Support
+ *
+ * You need an LZMA2 SDK to link with. See http://tukaani.org/xz/ for details.
+ *
+ * The codec is derived from ZLIB codec (tif_zip.c).
+ */
+
+#include "tif_predict.h"
+#include "lzma.h"
+
+#include <stdio.h>
+
+/*
+ * State block for each open TIFF file using LZMA2 compression/decompression.
+ */
+typedef struct {
+ TIFFPredictorState predict;
+ lzma_stream stream;
+ lzma_filter filters[LZMA_FILTERS_MAX + 1];
+ lzma_options_delta opt_delta; /* delta filter options */
+ lzma_options_lzma opt_lzma; /* LZMA2 filter options */
+ int preset; /* compression level */
+ lzma_check check; /* type of the integrity check */
+ int state; /* state flags */
+#define LSTATE_INIT_DECODE 0x01
+#define LSTATE_INIT_ENCODE 0x02
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+} LZMAState;
+
+#define LState(tif) ((LZMAState*) (tif)->tif_data)
+#define DecoderState(tif) LState(tif)
+#define EncoderState(tif) LState(tif)
+
+static int LZMAEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int LZMADecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s);
+
+static const char *
+LZMAStrerror(lzma_ret ret)
+{
+ switch (ret) {
+ case LZMA_OK:
+ return "operation completed successfully";
+ case LZMA_STREAM_END:
+ return "end of stream was reached";
+ case LZMA_NO_CHECK:
+ return "input stream has no integrity check";
+ case LZMA_UNSUPPORTED_CHECK:
+ return "cannot calculate the integrity check";
+ case LZMA_GET_CHECK:
+ return "integrity check type is now available";
+ case LZMA_MEM_ERROR:
+ return "cannot allocate memory";
+ case LZMA_MEMLIMIT_ERROR:
+ return "memory usage limit was reached";
+ case LZMA_FORMAT_ERROR:
+ return "file format not recognized";
+ case LZMA_OPTIONS_ERROR:
+ return "invalid or unsupported options";
+ case LZMA_DATA_ERROR:
+ return "data is corrupt";
+ case LZMA_BUF_ERROR:
+ return "no progress is possible (stream is truncated or corrupt)";
+ case LZMA_PROG_ERROR:
+ return "programming error";
+ default:
+ return "unidentified liblzma error";
+ }
+}
+
+static int
+LZMAFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return 1;
+}
+
+static int
+LZMASetupDecode(TIFF* tif)
+{
+ LZMAState* sp = DecoderState(tif);
+
+ assert(sp != NULL);
+
+ /* if we were last encoding, terminate this mode */
+ if (sp->state & LSTATE_INIT_ENCODE) {
+ lzma_end(&sp->stream);
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_DECODE;
+ return 1;
+}
+
+/*
+ * Setup state for decoding a strip.
+ */
+static int
+LZMAPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "LZMAPreDecode";
+ LZMAState* sp = DecoderState(tif);
+ lzma_ret ret;
+
+ (void) s;
+ assert(sp != NULL);
+
+ if( (sp->state & LSTATE_INIT_DECODE) == 0 )
+ tif->tif_setupdecode(tif);
+
+ sp->stream.next_in = tif->tif_rawdata;
+ sp->stream.avail_in = (size_t) tif->tif_rawcc;
+ if ((tmsize_t)sp->stream.avail_in != tif->tif_rawcc) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Liblzma cannot deal with buffers this size");
+ return 0;
+ }
+
+ /*
+ * Disable memory limit when decoding. UINT64_MAX is a flag to disable
+ * the limit, we are passing (uint64_t)-1 which should be the same.
+ */
+ ret = lzma_stream_decoder(&sp->stream, (uint64_t)-1, 0);
+ if (ret != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error initializing the stream decoder, %s",
+ LZMAStrerror(ret));
+ return 0;
+ }
+ return 1;
+}
+
+static int
+LZMADecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "LZMADecode";
+ LZMAState* sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_DECODE);
+
+ sp->stream.next_in = tif->tif_rawcp;
+ sp->stream.avail_in = (size_t) tif->tif_rawcc;
+
+ sp->stream.next_out = op;
+ sp->stream.avail_out = (size_t) occ;
+ if ((tmsize_t)sp->stream.avail_out != occ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Liblzma cannot deal with buffers this size");
+ return 0;
+ }
+
+ do {
+ /*
+ * Save the current stream state to properly recover from the
+ * decoding errors later.
+ */
+ const uint8_t *next_in = sp->stream.next_in;
+ size_t avail_in = sp->stream.avail_in;
+
+ lzma_ret ret = lzma_code(&sp->stream, LZMA_RUN);
+ if (ret == LZMA_STREAM_END)
+ break;
+ if (ret == LZMA_MEMLIMIT_ERROR) {
+ lzma_ret r = lzma_stream_decoder(&sp->stream,
+ lzma_memusage(&sp->stream), 0);
+ if (r != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error initializing the stream decoder, %s",
+ LZMAStrerror(r));
+ break;
+ }
+ sp->stream.next_in = next_in;
+ sp->stream.avail_in = avail_in;
+ continue;
+ }
+ if (ret != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Decoding error at scanline %lu, %s",
+ (unsigned long) tif->tif_row, LZMAStrerror(ret));
+ break;
+ }
+ } while (sp->stream.avail_out > 0);
+ if (sp->stream.avail_out != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %lu (short %lu bytes)",
+ (unsigned long) tif->tif_row, (unsigned long) sp->stream.avail_out);
+ return 0;
+ }
+
+ tif->tif_rawcp = (uint8 *)sp->stream.next_in; /* cast away const */
+ tif->tif_rawcc = sp->stream.avail_in;
+
+ return 1;
+}
+
+static int
+LZMASetupEncode(TIFF* tif)
+{
+ LZMAState* sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ if (sp->state & LSTATE_INIT_DECODE) {
+ lzma_end(&sp->stream);
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_ENCODE;
+ return 1;
+}
+
+/*
+ * Reset encoding state at the start of a strip.
+ */
+static int
+LZMAPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "LZMAPreEncode";
+ LZMAState *sp = EncoderState(tif);
+ lzma_ret ret;
+
+ (void) s;
+ assert(sp != NULL);
+ if( sp->state != LSTATE_INIT_ENCODE )
+ tif->tif_setupencode(tif);
+
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (size_t)tif->tif_rawdatasize;
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Liblzma cannot deal with buffers this size");
+ return 0;
+ }
+ ret = lzma_stream_encoder(&sp->stream, sp->filters, sp->check);
+ if (ret != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in lzma_stream_encoder(): %s", LZMAStrerror(ret));
+ return 0;
+ }
+ return 1;
+}
+
+/*
+ * Encode a chunk of pixels.
+ */
+static int
+LZMAEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "LZMAEncode";
+ LZMAState *sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_ENCODE);
+
+ (void) s;
+ sp->stream.next_in = bp;
+ sp->stream.avail_in = (size_t) cc;
+ if ((tmsize_t)sp->stream.avail_in != cc) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Liblzma cannot deal with buffers this size");
+ return 0;
+ }
+ do {
+ lzma_ret ret = lzma_code(&sp->stream, LZMA_RUN);
+ if (ret != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Encoding error at scanline %lu, %s",
+ (unsigned long) tif->tif_row, LZMAStrerror(ret));
+ return 0;
+ }
+ if (sp->stream.avail_out == 0) {
+ tif->tif_rawcc = tif->tif_rawdatasize;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (size_t)tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in LZMAPreEncode */
+ }
+ } while (sp->stream.avail_in > 0);
+ return 1;
+}
+
+/*
+ * Finish off an encoded strip by flushing the last
+ * string and tacking on an End Of Information code.
+ */
+static int
+LZMAPostEncode(TIFF* tif)
+{
+ static const char module[] = "LZMAPostEncode";
+ LZMAState *sp = EncoderState(tif);
+ lzma_ret ret;
+
+ sp->stream.avail_in = 0;
+ do {
+ ret = lzma_code(&sp->stream, LZMA_FINISH);
+ switch (ret) {
+ case LZMA_STREAM_END:
+ case LZMA_OK:
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize) {
+ tif->tif_rawcc =
+ tif->tif_rawdatasize - sp->stream.avail_out;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (size_t)tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in ZIPPreEncode */
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module, "Liblzma error: %s",
+ LZMAStrerror(ret));
+ return 0;
+ }
+ } while (ret != LZMA_STREAM_END);
+ return 1;
+}
+
+static void
+LZMACleanup(TIFF* tif)
+{
+ LZMAState* sp = LState(tif);
+
+ assert(sp != 0);
+
+ (void)TIFFPredictorCleanup(tif);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->state) {
+ lzma_end(&sp->stream);
+ sp->state = 0;
+ }
+ _TIFFfree(sp);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+LZMAVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "LZMAVSetField";
+ LZMAState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_LZMAPRESET:
+ sp->preset = (int) va_arg(ap, int);
+ lzma_lzma_preset(&sp->opt_lzma, sp->preset);
+ if (sp->state & LSTATE_INIT_ENCODE) {
+ lzma_ret ret = lzma_stream_encoder(&sp->stream,
+ sp->filters,
+ sp->check);
+ if (ret != LZMA_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Liblzma error: %s",
+ LZMAStrerror(ret));
+ }
+ }
+ return 1;
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+ /*NOTREACHED*/
+}
+
+static int
+LZMAVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ LZMAState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_LZMAPRESET:
+ *va_arg(ap, int*) = sp->preset;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return 1;
+}
+
+static const TIFFField lzmaFields[] = {
+ { TIFFTAG_LZMAPRESET, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED,
+ FIELD_PSEUDO, TRUE, FALSE, "LZMA2 Compression Preset", NULL },
+};
+
+int
+TIFFInitLZMA(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitLZMA";
+ LZMAState* sp;
+ lzma_stream tmp_stream = LZMA_STREAM_INIT;
+
+ assert( scheme == COMPRESSION_LZMA );
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, lzmaFields, TIFFArrayCount(lzmaFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging LZMA2 codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof(LZMAState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = LState(tif);
+ memcpy(&sp->stream, &tmp_stream, sizeof(lzma_stream));
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = LZMAVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = LZMAVSetField; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->preset = LZMA_PRESET_DEFAULT; /* default comp. level */
+ sp->check = LZMA_CHECK_NONE;
+ sp->state = 0;
+
+ /* Data filters. So far we are using delta and LZMA2 filters only. */
+ sp->opt_delta.type = LZMA_DELTA_TYPE_BYTE;
+ /*
+ * The sample size in bytes seems to be reasonable distance for delta
+ * filter.
+ */
+ sp->opt_delta.dist = (tif->tif_dir.td_bitspersample % 8) ?
+ 1 : tif->tif_dir.td_bitspersample / 8;
+ sp->filters[0].id = LZMA_FILTER_DELTA;
+ sp->filters[0].options = &sp->opt_delta;
+
+ lzma_lzma_preset(&sp->opt_lzma, sp->preset);
+ sp->filters[1].id = LZMA_FILTER_LZMA2;
+ sp->filters[1].options = &sp->opt_lzma;
+
+ sp->filters[2].id = LZMA_VLI_UNKNOWN;
+ sp->filters[2].options = NULL;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = LZMAFixupTags;
+ tif->tif_setupdecode = LZMASetupDecode;
+ tif->tif_predecode = LZMAPreDecode;
+ tif->tif_decoderow = LZMADecode;
+ tif->tif_decodestrip = LZMADecode;
+ tif->tif_decodetile = LZMADecode;
+ tif->tif_setupencode = LZMASetupEncode;
+ tif->tif_preencode = LZMAPreEncode;
+ tif->tif_postencode = LZMAPostEncode;
+ tif->tif_encoderow = LZMAEncode;
+ tif->tif_encodestrip = LZMAEncode;
+ tif->tif_encodetile = LZMAEncode;
+ tif->tif_cleanup = LZMACleanup;
+ /*
+ * Setup predictor setup.
+ */
+ (void) TIFFPredictorInit(tif);
+ return 1;
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for LZMA2 state block");
+ return 0;
+}
+#endif /* LZMA_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
diff --git a/test/monniaux/tiff-4.0.10/tif_lzw.c b/test/monniaux/tiff-4.0.10/tif_lzw.c
new file mode 100644
index 00000000..ac685dd7
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_lzw.c
@@ -0,0 +1,1230 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef LZW_SUPPORT
+/*
+ * TIFF Library.
+ * Rev 5.0 Lempel-Ziv & Welch Compression Support
+ *
+ * This code is derived from the compress program whose code is
+ * derived from software contributed to Berkeley by James A. Woods,
+ * derived from original work by Spencer Thomas and Joseph Orost.
+ *
+ * The original Berkeley copyright notice appears below in its entirety.
+ */
+#include "tif_predict.h"
+
+#include <stdio.h>
+
+/*
+ * NB: The 5.0 spec describes a different algorithm than Aldus
+ * implements. Specifically, Aldus does code length transitions
+ * one code earlier than should be done (for real LZW).
+ * Earlier versions of this library implemented the correct
+ * LZW algorithm, but emitted codes in a bit order opposite
+ * to the TIFF spec. Thus, to maintain compatibility w/ Aldus
+ * we interpret MSB-LSB ordered codes to be images written w/
+ * old versions of this library, but otherwise adhere to the
+ * Aldus "off by one" algorithm.
+ *
+ * Future revisions to the TIFF spec are expected to "clarify this issue".
+ */
+#define LZW_COMPAT /* include backwards compatibility code */
+/*
+ * Each strip of data is supposed to be terminated by a CODE_EOI.
+ * If the following #define is included, the decoder will also
+ * check for end-of-strip w/o seeing this code. This makes the
+ * library more robust, but also slower.
+ */
+#define LZW_CHECKEOS /* include checks for strips w/o EOI code */
+
+#define MAXCODE(n) ((1L<<(n))-1)
+/*
+ * The TIFF spec specifies that encoded bit
+ * strings range from 9 to 12 bits.
+ */
+#define BITS_MIN 9 /* start with 9 bits */
+#define BITS_MAX 12 /* max of 12 bit strings */
+/* predefined codes */
+#define CODE_CLEAR 256 /* code to clear string table */
+#define CODE_EOI 257 /* end-of-information code */
+#define CODE_FIRST 258 /* first free code entry */
+#define CODE_MAX MAXCODE(BITS_MAX)
+#define HSIZE 9001L /* 91% occupancy */
+#define HSHIFT (13-8)
+#ifdef LZW_COMPAT
+/* NB: +1024 is for compatibility with old files */
+#define CSIZE (MAXCODE(BITS_MAX)+1024L)
+#else
+#define CSIZE (MAXCODE(BITS_MAX)+1L)
+#endif
+
+/*
+ * State block for each open TIFF file using LZW
+ * compression/decompression. Note that the predictor
+ * state block must be first in this data structure.
+ */
+typedef struct {
+ TIFFPredictorState predict; /* predictor super class */
+
+ unsigned short nbits; /* # of bits/code */
+ unsigned short maxcode; /* maximum code for lzw_nbits */
+ unsigned short free_ent; /* next free entry in hash table */
+ unsigned long nextdata; /* next bits of i/o */
+ long nextbits; /* # of valid bits in lzw_nextdata */
+
+ int rw_mode; /* preserve rw_mode from init */
+} LZWBaseState;
+
+#define lzw_nbits base.nbits
+#define lzw_maxcode base.maxcode
+#define lzw_free_ent base.free_ent
+#define lzw_nextdata base.nextdata
+#define lzw_nextbits base.nextbits
+
+/*
+ * Encoding-specific state.
+ */
+typedef uint16 hcode_t; /* codes fit in 16 bits */
+typedef struct {
+ long hash;
+ hcode_t code;
+} hash_t;
+
+/*
+ * Decoding-specific state.
+ */
+typedef struct code_ent {
+ struct code_ent *next;
+ unsigned short length; /* string len, including this token */
+ unsigned char value; /* data value */
+ unsigned char firstchar; /* first token of string */
+} code_t;
+
+typedef int (*decodeFunc)(TIFF*, uint8*, tmsize_t, uint16);
+
+typedef struct {
+ LZWBaseState base;
+
+ /* Decoding specific data */
+ long dec_nbitsmask; /* lzw_nbits 1 bits, right adjusted */
+ long dec_restart; /* restart count */
+#ifdef LZW_CHECKEOS
+ uint64 dec_bitsleft; /* available bits in raw data */
+ tmsize_t old_tif_rawcc; /* value of tif_rawcc at the end of the previous TIFLZWDecode() call */
+#endif
+ decodeFunc dec_decode; /* regular or backwards compatible */
+ code_t* dec_codep; /* current recognized code */
+ code_t* dec_oldcodep; /* previously recognized code */
+ code_t* dec_free_entp; /* next free entry */
+ code_t* dec_maxcodep; /* max available entry */
+ code_t* dec_codetab; /* kept separate for small machines */
+
+ /* Encoding specific data */
+ int enc_oldcode; /* last code encountered */
+ long enc_checkpoint; /* point at which to clear table */
+#define CHECK_GAP 10000 /* enc_ratio check interval */
+ long enc_ratio; /* current compression ratio */
+ long enc_incount; /* (input) data bytes encoded */
+ long enc_outcount; /* encoded (output) bytes */
+ uint8* enc_rawlimit; /* bound on tif_rawdata buffer */
+ hash_t* enc_hashtab; /* kept separate for small machines */
+} LZWCodecState;
+
+#define LZWState(tif) ((LZWBaseState*) (tif)->tif_data)
+#define DecoderState(tif) ((LZWCodecState*) LZWState(tif))
+#define EncoderState(tif) ((LZWCodecState*) LZWState(tif))
+
+static int LZWDecode(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s);
+#ifdef LZW_COMPAT
+static int LZWDecodeCompat(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s);
+#endif
+static void cl_hash(LZWCodecState*);
+
+/*
+ * LZW Decoder.
+ */
+
+#ifdef LZW_CHECKEOS
+/*
+ * This check shouldn't be necessary because each
+ * strip is suppose to be terminated with CODE_EOI.
+ */
+#define NextCode(_tif, _sp, _bp, _code, _get) { \
+ if ((_sp)->dec_bitsleft < (uint64)nbits) { \
+ TIFFWarningExt(_tif->tif_clientdata, module, \
+ "LZWDecode: Strip %d not terminated with EOI code", \
+ _tif->tif_curstrip); \
+ _code = CODE_EOI; \
+ } else { \
+ _get(_sp,_bp,_code); \
+ (_sp)->dec_bitsleft -= nbits; \
+ } \
+}
+#else
+#define NextCode(tif, sp, bp, code, get) get(sp, bp, code)
+#endif
+
+static int
+LZWFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+static int
+LZWSetupDecode(TIFF* tif)
+{
+ static const char module[] = "LZWSetupDecode";
+ LZWCodecState* sp = DecoderState(tif);
+ int code;
+
+ if( sp == NULL )
+ {
+ /*
+ * Allocate state block so tag methods have storage to record
+ * values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof(LZWCodecState));
+ if (tif->tif_data == NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "No space for LZW state block");
+ return (0);
+ }
+
+ DecoderState(tif)->dec_codetab = NULL;
+ DecoderState(tif)->dec_decode = NULL;
+
+ /*
+ * Setup predictor setup.
+ */
+ (void) TIFFPredictorInit(tif);
+
+ sp = DecoderState(tif);
+ }
+
+ assert(sp != NULL);
+
+ if (sp->dec_codetab == NULL) {
+ sp->dec_codetab = (code_t*)_TIFFmalloc(CSIZE*sizeof (code_t));
+ if (sp->dec_codetab == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for LZW code table");
+ return (0);
+ }
+ /*
+ * Pre-load the table.
+ */
+ code = 255;
+ do {
+ sp->dec_codetab[code].value = (unsigned char)code;
+ sp->dec_codetab[code].firstchar = (unsigned char)code;
+ sp->dec_codetab[code].length = 1;
+ sp->dec_codetab[code].next = NULL;
+ } while (code--);
+ /*
+ * Zero-out the unused entries
+ */
+ _TIFFmemset(&sp->dec_codetab[CODE_CLEAR], 0,
+ (CODE_FIRST - CODE_CLEAR) * sizeof (code_t));
+ }
+ return (1);
+}
+
+/*
+ * Setup state for decoding a strip.
+ */
+static int
+LZWPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "LZWPreDecode";
+ LZWCodecState *sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ if( sp->dec_codetab == NULL )
+ {
+ tif->tif_setupdecode( tif );
+ if( sp->dec_codetab == NULL )
+ return (0);
+ }
+
+ /*
+ * Check for old bit-reversed codes.
+ */
+ if (tif->tif_rawcc >= 2 &&
+ tif->tif_rawdata[0] == 0 && (tif->tif_rawdata[1] & 0x1)) {
+#ifdef LZW_COMPAT
+ if (!sp->dec_decode) {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Old-style LZW codes, convert file");
+ /*
+ * Override default decoding methods with
+ * ones that deal with the old coding.
+ * Otherwise the predictor versions set
+ * above will call the compatibility routines
+ * through the dec_decode method.
+ */
+ tif->tif_decoderow = LZWDecodeCompat;
+ tif->tif_decodestrip = LZWDecodeCompat;
+ tif->tif_decodetile = LZWDecodeCompat;
+ /*
+ * If doing horizontal differencing, must
+ * re-setup the predictor logic since we
+ * switched the basic decoder methods...
+ */
+ (*tif->tif_setupdecode)(tif);
+ sp->dec_decode = LZWDecodeCompat;
+ }
+ sp->lzw_maxcode = MAXCODE(BITS_MIN);
+#else /* !LZW_COMPAT */
+ if (!sp->dec_decode) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Old-style LZW codes not supported");
+ sp->dec_decode = LZWDecode;
+ }
+ return (0);
+#endif/* !LZW_COMPAT */
+ } else {
+ sp->lzw_maxcode = MAXCODE(BITS_MIN)-1;
+ sp->dec_decode = LZWDecode;
+ }
+ sp->lzw_nbits = BITS_MIN;
+ sp->lzw_nextbits = 0;
+ sp->lzw_nextdata = 0;
+
+ sp->dec_restart = 0;
+ sp->dec_nbitsmask = MAXCODE(BITS_MIN);
+#ifdef LZW_CHECKEOS
+ sp->dec_bitsleft = 0;
+ sp->old_tif_rawcc = 0;
+#endif
+ sp->dec_free_entp = sp->dec_codetab + CODE_FIRST;
+ /*
+ * Zero entries that are not yet filled in. We do
+ * this to guard against bogus input data that causes
+ * us to index into undefined entries. If you can
+ * come up with a way to safely bounds-check input codes
+ * while decoding then you can remove this operation.
+ */
+ _TIFFmemset(sp->dec_free_entp, 0, (CSIZE-CODE_FIRST)*sizeof (code_t));
+ sp->dec_oldcodep = &sp->dec_codetab[-1];
+ sp->dec_maxcodep = &sp->dec_codetab[sp->dec_nbitsmask-1];
+ return (1);
+}
+
+/*
+ * Decode a "hunk of data".
+ */
+#define GetNextCode(sp, bp, code) { \
+ nextdata = (nextdata<<8) | *(bp)++; \
+ nextbits += 8; \
+ if (nextbits < nbits) { \
+ nextdata = (nextdata<<8) | *(bp)++; \
+ nextbits += 8; \
+ } \
+ code = (hcode_t)((nextdata >> (nextbits-nbits)) & nbitsmask); \
+ nextbits -= nbits; \
+}
+
+static void
+codeLoop(TIFF* tif, const char* module)
+{
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Bogus encoding, loop in the code table; scanline %d",
+ tif->tif_row);
+}
+
+static int
+LZWDecode(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s)
+{
+ static const char module[] = "LZWDecode";
+ LZWCodecState *sp = DecoderState(tif);
+ char *op = (char*) op0;
+ long occ = (long) occ0;
+ char *tp;
+ unsigned char *bp;
+ hcode_t code;
+ int len;
+ long nbits, nextbits, nbitsmask;
+ unsigned long nextdata;
+ code_t *codep, *free_entp, *maxcodep, *oldcodep;
+
+ (void) s;
+ assert(sp != NULL);
+ assert(sp->dec_codetab != NULL);
+
+ /*
+ Fail if value does not fit in long.
+ */
+ if ((tmsize_t) occ != occ0)
+ return (0);
+ /*
+ * Restart interrupted output operation.
+ */
+ if (sp->dec_restart) {
+ long residue;
+
+ codep = sp->dec_codep;
+ residue = codep->length - sp->dec_restart;
+ if (residue > occ) {
+ /*
+ * Residue from previous decode is sufficient
+ * to satisfy decode request. Skip to the
+ * start of the decoded string, place decoded
+ * values in the output buffer, and return.
+ */
+ sp->dec_restart += occ;
+ do {
+ codep = codep->next;
+ } while (--residue > occ && codep);
+ if (codep) {
+ tp = op + occ;
+ do {
+ *--tp = codep->value;
+ codep = codep->next;
+ } while (--occ && codep);
+ }
+ return (1);
+ }
+ /*
+ * Residue satisfies only part of the decode request.
+ */
+ op += residue;
+ occ -= residue;
+ tp = op;
+ do {
+ int t;
+ --tp;
+ t = codep->value;
+ codep = codep->next;
+ *tp = (char)t;
+ } while (--residue && codep);
+ sp->dec_restart = 0;
+ }
+
+ bp = (unsigned char *)tif->tif_rawcp;
+#ifdef LZW_CHECKEOS
+ sp->dec_bitsleft += (((uint64)tif->tif_rawcc - sp->old_tif_rawcc) << 3);
+#endif
+ nbits = sp->lzw_nbits;
+ nextdata = sp->lzw_nextdata;
+ nextbits = sp->lzw_nextbits;
+ nbitsmask = sp->dec_nbitsmask;
+ oldcodep = sp->dec_oldcodep;
+ free_entp = sp->dec_free_entp;
+ maxcodep = sp->dec_maxcodep;
+
+ while (occ > 0) {
+ NextCode(tif, sp, bp, code, GetNextCode);
+ if (code == CODE_EOI)
+ break;
+ if (code == CODE_CLEAR) {
+ do {
+ free_entp = sp->dec_codetab + CODE_FIRST;
+ _TIFFmemset(free_entp, 0,
+ (CSIZE - CODE_FIRST) * sizeof (code_t));
+ nbits = BITS_MIN;
+ nbitsmask = MAXCODE(BITS_MIN);
+ maxcodep = sp->dec_codetab + nbitsmask-1;
+ NextCode(tif, sp, bp, code, GetNextCode);
+ } while (code == CODE_CLEAR); /* consecutive CODE_CLEAR codes */
+ if (code == CODE_EOI)
+ break;
+ if (code > CODE_CLEAR) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "LZWDecode: Corrupted LZW table at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+ *op++ = (char)code;
+ occ--;
+ oldcodep = sp->dec_codetab + code;
+ continue;
+ }
+ codep = sp->dec_codetab + code;
+
+ /*
+ * Add the new entry to the code table.
+ */
+ if (free_entp < &sp->dec_codetab[0] ||
+ free_entp >= &sp->dec_codetab[CSIZE]) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Corrupted LZW table at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+
+ free_entp->next = oldcodep;
+ if (free_entp->next < &sp->dec_codetab[0] ||
+ free_entp->next >= &sp->dec_codetab[CSIZE]) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Corrupted LZW table at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+ free_entp->firstchar = free_entp->next->firstchar;
+ free_entp->length = free_entp->next->length+1;
+ free_entp->value = (codep < free_entp) ?
+ codep->firstchar : free_entp->firstchar;
+ if (++free_entp > maxcodep) {
+ if (++nbits > BITS_MAX) /* should not happen */
+ nbits = BITS_MAX;
+ nbitsmask = MAXCODE(nbits);
+ maxcodep = sp->dec_codetab + nbitsmask-1;
+ }
+ oldcodep = codep;
+ if (code >= 256) {
+ /*
+ * Code maps to a string, copy string
+ * value to output (written in reverse).
+ */
+ if(codep->length == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Wrong length of decoded string: "
+ "data probably corrupted at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+ if (codep->length > occ) {
+ /*
+ * String is too long for decode buffer,
+ * locate portion that will fit, copy to
+ * the decode buffer, and setup restart
+ * logic for the next decoding call.
+ */
+ sp->dec_codep = codep;
+ do {
+ codep = codep->next;
+ } while (codep && codep->length > occ);
+ if (codep) {
+ sp->dec_restart = (long)occ;
+ tp = op + occ;
+ do {
+ *--tp = codep->value;
+ codep = codep->next;
+ } while (--occ && codep);
+ if (codep)
+ codeLoop(tif, module);
+ }
+ break;
+ }
+ len = codep->length;
+ tp = op + len;
+ do {
+ int t;
+ --tp;
+ t = codep->value;
+ codep = codep->next;
+ *tp = (char)t;
+ } while (codep && tp > op);
+ if (codep) {
+ codeLoop(tif, module);
+ break;
+ }
+ assert(occ >= len);
+ op += len;
+ occ -= len;
+ } else {
+ *op++ = (char)code;
+ occ--;
+ }
+ }
+
+ tif->tif_rawcc -= (tmsize_t)( (uint8*) bp - tif->tif_rawcp );
+ tif->tif_rawcp = (uint8*) bp;
+#ifdef LZW_CHECKEOS
+ sp->old_tif_rawcc = tif->tif_rawcc;
+#endif
+ sp->lzw_nbits = (unsigned short) nbits;
+ sp->lzw_nextdata = nextdata;
+ sp->lzw_nextbits = nextbits;
+ sp->dec_nbitsmask = nbitsmask;
+ sp->dec_oldcodep = oldcodep;
+ sp->dec_free_entp = free_entp;
+ sp->dec_maxcodep = maxcodep;
+
+ if (occ > 0) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %d (short %I64d bytes)",
+ tif->tif_row, (unsigned __int64) occ);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %d (short %llu bytes)",
+ tif->tif_row, (unsigned long long) occ);
+#endif
+ return (0);
+ }
+ return (1);
+}
+
+#ifdef LZW_COMPAT
+/*
+ * Decode a "hunk of data" for old images.
+ */
+#define GetNextCodeCompat(sp, bp, code) { \
+ nextdata |= (unsigned long) *(bp)++ << nextbits; \
+ nextbits += 8; \
+ if (nextbits < nbits) { \
+ nextdata |= (unsigned long) *(bp)++ << nextbits;\
+ nextbits += 8; \
+ } \
+ code = (hcode_t)(nextdata & nbitsmask); \
+ nextdata >>= nbits; \
+ nextbits -= nbits; \
+}
+
+static int
+LZWDecodeCompat(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s)
+{
+ static const char module[] = "LZWDecodeCompat";
+ LZWCodecState *sp = DecoderState(tif);
+ char *op = (char*) op0;
+ long occ = (long) occ0;
+ char *tp;
+ unsigned char *bp;
+ int code, nbits;
+ int len;
+ long nextbits, nextdata, nbitsmask;
+ code_t *codep, *free_entp, *maxcodep, *oldcodep;
+
+ (void) s;
+ assert(sp != NULL);
+
+ /*
+ Fail if value does not fit in long.
+ */
+ if ((tmsize_t) occ != occ0)
+ return (0);
+
+ /*
+ * Restart interrupted output operation.
+ */
+ if (sp->dec_restart) {
+ long residue;
+
+ codep = sp->dec_codep;
+ residue = codep->length - sp->dec_restart;
+ if (residue > occ) {
+ /*
+ * Residue from previous decode is sufficient
+ * to satisfy decode request. Skip to the
+ * start of the decoded string, place decoded
+ * values in the output buffer, and return.
+ */
+ sp->dec_restart += occ;
+ do {
+ codep = codep->next;
+ } while (--residue > occ);
+ tp = op + occ;
+ do {
+ *--tp = codep->value;
+ codep = codep->next;
+ } while (--occ);
+ return (1);
+ }
+ /*
+ * Residue satisfies only part of the decode request.
+ */
+ op += residue;
+ occ -= residue;
+ tp = op;
+ do {
+ *--tp = codep->value;
+ codep = codep->next;
+ } while (--residue);
+ sp->dec_restart = 0;
+ }
+
+ bp = (unsigned char *)tif->tif_rawcp;
+#ifdef LZW_CHECKEOS
+ sp->dec_bitsleft += (((uint64)tif->tif_rawcc - sp->old_tif_rawcc) << 3);
+#endif
+ nbits = sp->lzw_nbits;
+ nextdata = sp->lzw_nextdata;
+ nextbits = sp->lzw_nextbits;
+ nbitsmask = sp->dec_nbitsmask;
+ oldcodep = sp->dec_oldcodep;
+ free_entp = sp->dec_free_entp;
+ maxcodep = sp->dec_maxcodep;
+
+ while (occ > 0) {
+ NextCode(tif, sp, bp, code, GetNextCodeCompat);
+ if (code == CODE_EOI)
+ break;
+ if (code == CODE_CLEAR) {
+ do {
+ free_entp = sp->dec_codetab + CODE_FIRST;
+ _TIFFmemset(free_entp, 0,
+ (CSIZE - CODE_FIRST) * sizeof (code_t));
+ nbits = BITS_MIN;
+ nbitsmask = MAXCODE(BITS_MIN);
+ maxcodep = sp->dec_codetab + nbitsmask;
+ NextCode(tif, sp, bp, code, GetNextCodeCompat);
+ } while (code == CODE_CLEAR); /* consecutive CODE_CLEAR codes */
+ if (code == CODE_EOI)
+ break;
+ if (code > CODE_CLEAR) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "LZWDecode: Corrupted LZW table at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+ *op++ = (char)code;
+ occ--;
+ oldcodep = sp->dec_codetab + code;
+ continue;
+ }
+ codep = sp->dec_codetab + code;
+
+ /*
+ * Add the new entry to the code table.
+ */
+ if (free_entp < &sp->dec_codetab[0] ||
+ free_entp >= &sp->dec_codetab[CSIZE]) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Corrupted LZW table at scanline %d", tif->tif_row);
+ return (0);
+ }
+
+ free_entp->next = oldcodep;
+ if (free_entp->next < &sp->dec_codetab[0] ||
+ free_entp->next >= &sp->dec_codetab[CSIZE]) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Corrupted LZW table at scanline %d", tif->tif_row);
+ return (0);
+ }
+ free_entp->firstchar = free_entp->next->firstchar;
+ free_entp->length = free_entp->next->length+1;
+ free_entp->value = (codep < free_entp) ?
+ codep->firstchar : free_entp->firstchar;
+ if (++free_entp > maxcodep) {
+ if (++nbits > BITS_MAX) /* should not happen */
+ nbits = BITS_MAX;
+ nbitsmask = MAXCODE(nbits);
+ maxcodep = sp->dec_codetab + nbitsmask;
+ }
+ oldcodep = codep;
+ if (code >= 256) {
+ /*
+ * Code maps to a string, copy string
+ * value to output (written in reverse).
+ */
+ if(codep->length == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Wrong length of decoded "
+ "string: data probably corrupted at scanline %d",
+ tif->tif_row);
+ return (0);
+ }
+ if (codep->length > occ) {
+ /*
+ * String is too long for decode buffer,
+ * locate portion that will fit, copy to
+ * the decode buffer, and setup restart
+ * logic for the next decoding call.
+ */
+ sp->dec_codep = codep;
+ do {
+ codep = codep->next;
+ } while (codep->length > occ);
+ sp->dec_restart = occ;
+ tp = op + occ;
+ do {
+ *--tp = codep->value;
+ codep = codep->next;
+ } while (--occ);
+ break;
+ }
+ len = codep->length;
+ tp = op + len;
+ do {
+ int t;
+ --tp;
+ t = codep->value;
+ codep = codep->next;
+ *tp = (char)t;
+ } while (codep && tp > op);
+ assert(occ >= len);
+ op += len;
+ occ -= len;
+ } else {
+ *op++ = (char)code;
+ occ--;
+ }
+ }
+
+ tif->tif_rawcc -= (tmsize_t)( (uint8*) bp - tif->tif_rawcp );
+ tif->tif_rawcp = (uint8*) bp;
+#ifdef LZW_CHECKEOS
+ sp->old_tif_rawcc = tif->tif_rawcc;
+#endif
+ sp->lzw_nbits = (unsigned short)nbits;
+ sp->lzw_nextdata = nextdata;
+ sp->lzw_nextbits = nextbits;
+ sp->dec_nbitsmask = nbitsmask;
+ sp->dec_oldcodep = oldcodep;
+ sp->dec_free_entp = free_entp;
+ sp->dec_maxcodep = maxcodep;
+
+ if (occ > 0) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %d (short %I64d bytes)",
+ tif->tif_row, (unsigned __int64) occ);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %d (short %llu bytes)",
+ tif->tif_row, (unsigned long long) occ);
+#endif
+ return (0);
+ }
+ return (1);
+}
+#endif /* LZW_COMPAT */
+
+/*
+ * LZW Encoding.
+ */
+
+static int
+LZWSetupEncode(TIFF* tif)
+{
+ static const char module[] = "LZWSetupEncode";
+ LZWCodecState* sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ sp->enc_hashtab = (hash_t*) _TIFFmalloc(HSIZE*sizeof (hash_t));
+ if (sp->enc_hashtab == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for LZW hash table");
+ return (0);
+ }
+ return (1);
+}
+
+/*
+ * Reset encoding state at the start of a strip.
+ */
+static int
+LZWPreEncode(TIFF* tif, uint16 s)
+{
+ LZWCodecState *sp = EncoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+
+ if( sp->enc_hashtab == NULL )
+ {
+ tif->tif_setupencode( tif );
+ }
+
+ sp->lzw_nbits = BITS_MIN;
+ sp->lzw_maxcode = MAXCODE(BITS_MIN);
+ sp->lzw_free_ent = CODE_FIRST;
+ sp->lzw_nextbits = 0;
+ sp->lzw_nextdata = 0;
+ sp->enc_checkpoint = CHECK_GAP;
+ sp->enc_ratio = 0;
+ sp->enc_incount = 0;
+ sp->enc_outcount = 0;
+ /*
+ * The 4 here insures there is space for 2 max-sized
+ * codes in LZWEncode and LZWPostDecode.
+ */
+ sp->enc_rawlimit = tif->tif_rawdata + tif->tif_rawdatasize-1 - 4;
+ cl_hash(sp); /* clear hash table */
+ sp->enc_oldcode = (hcode_t) -1; /* generates CODE_CLEAR in LZWEncode */
+ return (1);
+}
+
+#define CALCRATIO(sp, rat) { \
+ if (incount > 0x007fffff) { /* NB: shift will overflow */\
+ rat = outcount >> 8; \
+ rat = (rat == 0 ? 0x7fffffff : incount/rat); \
+ } else \
+ rat = (incount<<8) / outcount; \
+}
+
+/* Explicit 0xff masking to make icc -check=conversions happy */
+#define PutNextCode(op, c) { \
+ nextdata = (nextdata << nbits) | c; \
+ nextbits += nbits; \
+ *op++ = (unsigned char)((nextdata >> (nextbits-8))&0xff); \
+ nextbits -= 8; \
+ if (nextbits >= 8) { \
+ *op++ = (unsigned char)((nextdata >> (nextbits-8))&0xff); \
+ nextbits -= 8; \
+ } \
+ outcount += nbits; \
+}
+
+/*
+ * Encode a chunk of pixels.
+ *
+ * Uses an open addressing double hashing (no chaining) on the
+ * prefix code/next character combination. We do a variant of
+ * Knuth's algorithm D (vol. 3, sec. 6.4) along with G. Knott's
+ * relatively-prime secondary probe. Here, the modular division
+ * first probe is gives way to a faster exclusive-or manipulation.
+ * Also do block compression with an adaptive reset, whereby the
+ * code table is cleared when the compression ratio decreases,
+ * but after the table fills. The variable-length output codes
+ * are re-sized at this point, and a CODE_CLEAR is generated
+ * for the decoder.
+ */
+static int
+LZWEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ register LZWCodecState *sp = EncoderState(tif);
+ register long fcode;
+ register hash_t *hp;
+ register int h, c;
+ hcode_t ent;
+ long disp;
+ long incount, outcount, checkpoint;
+ unsigned long nextdata;
+ long nextbits;
+ int free_ent, maxcode, nbits;
+ uint8* op;
+ uint8* limit;
+
+ (void) s;
+ if (sp == NULL)
+ return (0);
+
+ assert(sp->enc_hashtab != NULL);
+
+ /*
+ * Load local state.
+ */
+ incount = sp->enc_incount;
+ outcount = sp->enc_outcount;
+ checkpoint = sp->enc_checkpoint;
+ nextdata = sp->lzw_nextdata;
+ nextbits = sp->lzw_nextbits;
+ free_ent = sp->lzw_free_ent;
+ maxcode = sp->lzw_maxcode;
+ nbits = sp->lzw_nbits;
+ op = tif->tif_rawcp;
+ limit = sp->enc_rawlimit;
+ ent = (hcode_t)sp->enc_oldcode;
+
+ if (ent == (hcode_t) -1 && cc > 0) {
+ /*
+ * NB: This is safe because it can only happen
+ * at the start of a strip where we know there
+ * is space in the data buffer.
+ */
+ PutNextCode(op, CODE_CLEAR);
+ ent = *bp++; cc--; incount++;
+ }
+ while (cc > 0) {
+ c = *bp++; cc--; incount++;
+ fcode = ((long)c << BITS_MAX) + ent;
+ h = (c << HSHIFT) ^ ent; /* xor hashing */
+#ifdef _WINDOWS
+ /*
+ * Check hash index for an overflow.
+ */
+ if (h >= HSIZE)
+ h -= HSIZE;
+#endif
+ hp = &sp->enc_hashtab[h];
+ if (hp->hash == fcode) {
+ ent = hp->code;
+ continue;
+ }
+ if (hp->hash >= 0) {
+ /*
+ * Primary hash failed, check secondary hash.
+ */
+ disp = HSIZE - h;
+ if (h == 0)
+ disp = 1;
+ do {
+ /*
+ * Avoid pointer arithmetic because of
+ * wraparound problems with segments.
+ */
+ if ((h -= disp) < 0)
+ h += HSIZE;
+ hp = &sp->enc_hashtab[h];
+ if (hp->hash == fcode) {
+ ent = hp->code;
+ goto hit;
+ }
+ } while (hp->hash >= 0);
+ }
+ /*
+ * New entry, emit code and add to table.
+ */
+ /*
+ * Verify there is space in the buffer for the code
+ * and any potential Clear code that might be emitted
+ * below. The value of limit is setup so that there
+ * are at least 4 bytes free--room for 2 codes.
+ */
+ if (op > limit) {
+ tif->tif_rawcc = (tmsize_t)(op - tif->tif_rawdata);
+ if( !TIFFFlushData1(tif) )
+ return 0;
+ op = tif->tif_rawdata;
+ }
+ PutNextCode(op, ent);
+ ent = (hcode_t)c;
+ hp->code = (hcode_t)(free_ent++);
+ hp->hash = fcode;
+ if (free_ent == CODE_MAX-1) {
+ /* table is full, emit clear code and reset */
+ cl_hash(sp);
+ sp->enc_ratio = 0;
+ incount = 0;
+ outcount = 0;
+ free_ent = CODE_FIRST;
+ PutNextCode(op, CODE_CLEAR);
+ nbits = BITS_MIN;
+ maxcode = MAXCODE(BITS_MIN);
+ } else {
+ /*
+ * If the next entry is going to be too big for
+ * the code size, then increase it, if possible.
+ */
+ if (free_ent > maxcode) {
+ nbits++;
+ assert(nbits <= BITS_MAX);
+ maxcode = (int) MAXCODE(nbits);
+ } else if (incount >= checkpoint) {
+ long rat;
+ /*
+ * Check compression ratio and, if things seem
+ * to be slipping, clear the hash table and
+ * reset state. The compression ratio is a
+ * 24+8-bit fractional number.
+ */
+ checkpoint = incount+CHECK_GAP;
+ CALCRATIO(sp, rat);
+ if (rat <= sp->enc_ratio) {
+ cl_hash(sp);
+ sp->enc_ratio = 0;
+ incount = 0;
+ outcount = 0;
+ free_ent = CODE_FIRST;
+ PutNextCode(op, CODE_CLEAR);
+ nbits = BITS_MIN;
+ maxcode = MAXCODE(BITS_MIN);
+ } else
+ sp->enc_ratio = rat;
+ }
+ }
+ hit:
+ ;
+ }
+
+ /*
+ * Restore global state.
+ */
+ sp->enc_incount = incount;
+ sp->enc_outcount = outcount;
+ sp->enc_checkpoint = checkpoint;
+ sp->enc_oldcode = ent;
+ sp->lzw_nextdata = nextdata;
+ sp->lzw_nextbits = nextbits;
+ sp->lzw_free_ent = (unsigned short)free_ent;
+ sp->lzw_maxcode = (unsigned short)maxcode;
+ sp->lzw_nbits = (unsigned short)nbits;
+ tif->tif_rawcp = op;
+ return (1);
+}
+
+/*
+ * Finish off an encoded strip by flushing the last
+ * string and tacking on an End Of Information code.
+ */
+static int
+LZWPostEncode(TIFF* tif)
+{
+ register LZWCodecState *sp = EncoderState(tif);
+ uint8* op = tif->tif_rawcp;
+ long nextbits = sp->lzw_nextbits;
+ unsigned long nextdata = sp->lzw_nextdata;
+ long outcount = sp->enc_outcount;
+ int nbits = sp->lzw_nbits;
+
+ if (op > sp->enc_rawlimit) {
+ tif->tif_rawcc = (tmsize_t)(op - tif->tif_rawdata);
+ if( !TIFFFlushData1(tif) )
+ return 0;
+ op = tif->tif_rawdata;
+ }
+ if (sp->enc_oldcode != (hcode_t) -1) {
+ int free_ent = sp->lzw_free_ent;
+
+ PutNextCode(op, sp->enc_oldcode);
+ sp->enc_oldcode = (hcode_t) -1;
+ free_ent ++;
+
+ if (free_ent == CODE_MAX-1) {
+ /* table is full, emit clear code and reset */
+ outcount = 0;
+ PutNextCode(op, CODE_CLEAR);
+ nbits = BITS_MIN;
+ } else {
+ /*
+ * If the next entry is going to be too big for
+ * the code size, then increase it, if possible.
+ */
+ if (free_ent > sp->lzw_maxcode) {
+ nbits++;
+ assert(nbits <= BITS_MAX);
+ }
+ }
+ }
+ PutNextCode(op, CODE_EOI);
+ /* Explicit 0xff masking to make icc -check=conversions happy */
+ if (nextbits > 0)
+ *op++ = (unsigned char)((nextdata << (8-nextbits))&0xff);
+ tif->tif_rawcc = (tmsize_t)(op - tif->tif_rawdata);
+ return (1);
+}
+
+/*
+ * Reset encoding hash table.
+ */
+static void
+cl_hash(LZWCodecState* sp)
+{
+ register hash_t *hp = &sp->enc_hashtab[HSIZE-1];
+ register long i = HSIZE-8;
+
+ do {
+ i -= 8;
+ hp[-7].hash = -1;
+ hp[-6].hash = -1;
+ hp[-5].hash = -1;
+ hp[-4].hash = -1;
+ hp[-3].hash = -1;
+ hp[-2].hash = -1;
+ hp[-1].hash = -1;
+ hp[ 0].hash = -1;
+ hp -= 8;
+ } while (i >= 0);
+ for (i += 8; i > 0; i--, hp--)
+ hp->hash = -1;
+}
+
+static void
+LZWCleanup(TIFF* tif)
+{
+ (void)TIFFPredictorCleanup(tif);
+
+ assert(tif->tif_data != 0);
+
+ if (DecoderState(tif)->dec_codetab)
+ _TIFFfree(DecoderState(tif)->dec_codetab);
+
+ if (EncoderState(tif)->enc_hashtab)
+ _TIFFfree(EncoderState(tif)->enc_hashtab);
+
+ _TIFFfree(tif->tif_data);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+int
+TIFFInitLZW(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitLZW";
+ assert(scheme == COMPRESSION_LZW);
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof (LZWCodecState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ DecoderState(tif)->dec_codetab = NULL;
+ DecoderState(tif)->dec_decode = NULL;
+ EncoderState(tif)->enc_hashtab = NULL;
+ LZWState(tif)->rw_mode = tif->tif_mode;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = LZWFixupTags;
+ tif->tif_setupdecode = LZWSetupDecode;
+ tif->tif_predecode = LZWPreDecode;
+ tif->tif_decoderow = LZWDecode;
+ tif->tif_decodestrip = LZWDecode;
+ tif->tif_decodetile = LZWDecode;
+ tif->tif_setupencode = LZWSetupEncode;
+ tif->tif_preencode = LZWPreEncode;
+ tif->tif_postencode = LZWPostEncode;
+ tif->tif_encoderow = LZWEncode;
+ tif->tif_encodestrip = LZWEncode;
+ tif->tif_encodetile = LZWEncode;
+ tif->tif_cleanup = LZWCleanup;
+ /*
+ * Setup predictor setup.
+ */
+ (void) TIFFPredictorInit(tif);
+ return (1);
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for LZW state block");
+ return (0);
+}
+
+/*
+ * Copyright (c) 1985, 1986 The Regents of the University of California.
+ * All rights reserved.
+ *
+ * This code is derived from software contributed to Berkeley by
+ * James A. Woods, derived from original work by Spencer Thomas
+ * and Joseph Orost.
+ *
+ * Redistribution and use in source and binary forms are permitted
+ * provided that the above copyright notice and this paragraph are
+ * duplicated in all such forms and that any documentation,
+ * advertising materials, and other materials related to such
+ * distribution and use acknowledge that the software was developed
+ * by the University of California, Berkeley. The name of the
+ * University may not be used to endorse or promote products derived
+ * from this software without specific prior written permission.
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+#endif /* LZW_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_next.c b/test/monniaux/tiff-4.0.10/tif_next.c
new file mode 100644
index 00000000..0ba61aed
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_next.c
@@ -0,0 +1,187 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef NEXT_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * NeXT 2-bit Grey Scale Compression Algorithm Support
+ */
+
+#define SETPIXEL(op, v) { \
+ switch (npixels++ & 3) { \
+ case 0: op[0] = (unsigned char) ((v) << 6); break; \
+ case 1: op[0] |= (v) << 4; break; \
+ case 2: op[0] |= (v) << 2; break; \
+ case 3: *op++ |= (v); op_offset++; break; \
+ } \
+}
+
+#define LITERALROW 0x00
+#define LITERALSPAN 0x40
+#define WHITE ((1<<2)-1)
+
+static int
+NeXTDecode(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "NeXTDecode";
+ unsigned char *bp, *op;
+ tmsize_t cc;
+ uint8* row;
+ tmsize_t scanline, n;
+
+ (void) s;
+ /*
+ * Each scanline is assumed to start off as all
+ * white (we assume a PhotometricInterpretation
+ * of ``min-is-black'').
+ */
+ for (op = (unsigned char*) buf, cc = occ; cc-- > 0;)
+ *op++ = 0xff;
+
+ bp = (unsigned char *)tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ scanline = tif->tif_scanlinesize;
+ if (occ % scanline)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (0);
+ }
+ for (row = buf; cc > 0 && occ > 0; occ -= scanline, row += scanline) {
+ n = *bp++;
+ cc--;
+ switch (n) {
+ case LITERALROW:
+ /*
+ * The entire scanline is given as literal values.
+ */
+ if (cc < scanline)
+ goto bad;
+ _TIFFmemcpy(row, bp, scanline);
+ bp += scanline;
+ cc -= scanline;
+ break;
+ case LITERALSPAN: {
+ tmsize_t off;
+ /*
+ * The scanline has a literal span that begins at some
+ * offset.
+ */
+ if( cc < 4 )
+ goto bad;
+ off = (bp[0] * 256) + bp[1];
+ n = (bp[2] * 256) + bp[3];
+ if (cc < 4+n || off+n > scanline)
+ goto bad;
+ _TIFFmemcpy(row+off, bp+4, n);
+ bp += 4+n;
+ cc -= 4+n;
+ break;
+ }
+ default: {
+ uint32 npixels = 0, grey;
+ tmsize_t op_offset = 0;
+ uint32 imagewidth = tif->tif_dir.td_imagewidth;
+ if( isTiled(tif) )
+ imagewidth = tif->tif_dir.td_tilewidth;
+
+ /*
+ * The scanline is composed of a sequence of constant
+ * color ``runs''. We shift into ``run mode'' and
+ * interpret bytes as codes of the form
+ * <color><npixels> until we've filled the scanline.
+ */
+ op = row;
+ for (;;) {
+ grey = (uint32)((n>>6) & 0x3);
+ n &= 0x3f;
+ /*
+ * Ensure the run does not exceed the scanline
+ * bounds, potentially resulting in a security
+ * issue.
+ */
+ while (n-- > 0 && npixels < imagewidth && op_offset < scanline)
+ SETPIXEL(op, grey);
+ if (npixels >= imagewidth)
+ break;
+ if (op_offset >= scanline ) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Invalid data for scanline %ld",
+ (long) tif->tif_row);
+ return (0);
+ }
+ if (cc == 0)
+ goto bad;
+ n = *bp++;
+ cc--;
+ }
+ break;
+ }
+ }
+ }
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ return (1);
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module, "Not enough data for scanline %ld",
+ (long) tif->tif_row);
+ return (0);
+}
+
+static int
+NeXTPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "NeXTPreDecode";
+ TIFFDirectory *td = &tif->tif_dir;
+ (void)s;
+
+ if( td->td_bitspersample != 2 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Unsupported BitsPerSample = %d",
+ td->td_bitspersample);
+ return (0);
+ }
+ return (1);
+}
+
+int
+TIFFInitNeXT(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ tif->tif_predecode = NeXTPreDecode;
+ tif->tif_decoderow = NeXTDecode;
+ tif->tif_decodestrip = NeXTDecode;
+ tif->tif_decodetile = NeXTDecode;
+ return (1);
+}
+#endif /* NEXT_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_ojpeg.c b/test/monniaux/tiff-4.0.10/tif_ojpeg.c
new file mode 100644
index 00000000..27385d8c
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_ojpeg.c
@@ -0,0 +1,2561 @@
+/* WARNING: The type of JPEG encapsulation defined by the TIFF Version 6.0
+ specification is now totally obsolete and deprecated for new applications and
+ images. This file was was created solely in order to read unconverted images
+ still present on some users' computer systems. It will never be extended
+ to write such files. Writing new-style JPEG compressed TIFFs is implemented
+ in tif_jpeg.c.
+
+ The code is carefully crafted to robustly read all gathered JPEG-in-TIFF
+ testfiles, and anticipate as much as possible all other... But still, it may
+ fail on some. If you encounter problems, please report them on the TIFF
+ mailing list and/or to Joris Van Damme <info@awaresystems.be>.
+
+ Please read the file called "TIFF Technical Note #2" if you need to be
+ convinced this compression scheme is bad and breaks TIFF. That document
+ is linked to from the LibTiff site <http://www.remotesensing.org/libtiff/>
+ and from AWare Systems' TIFF section
+ <http://www.awaresystems.be/imaging/tiff.html>. It is also absorbed
+ in Adobe's specification supplements, marked "draft" up to this day, but
+ supported by the TIFF community.
+
+ This file interfaces with Release 6B of the JPEG Library written by the
+ Independent JPEG Group. Previous versions of this file required a hack inside
+ the LibJpeg library. This version no longer requires that. Remember to
+ remove the hack if you update from the old version.
+
+ Copyright (c) Joris Van Damme <info@awaresystems.be>
+ Copyright (c) AWare Systems <http://www.awaresystems.be/>
+
+ The licence agreement for this file is the same as the rest of the LibTiff
+ library.
+
+ IN NO EVENT SHALL JORIS VAN DAMME OR AWARE SYSTEMS BE LIABLE FOR
+ ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ OF THIS SOFTWARE.
+
+ Joris Van Damme and/or AWare Systems may be available for custom
+ development. If you like what you see, and need anything similar or related,
+ contact <info@awaresystems.be>.
+*/
+
+/* What is what, and what is not?
+
+ This decoder starts with an input stream, that is essentially the JpegInterchangeFormat
+ stream, if any, followed by the strile data, if any. This stream is read in
+ OJPEGReadByte and related functions.
+
+ It analyzes the start of this stream, until it encounters non-marker data, i.e.
+ compressed image data. Some of the header markers it sees have no actual content,
+ like the SOI marker, and APP/COM markers that really shouldn't even be there. Some
+ other markers do have content, and the valuable bits and pieces of information
+ in these markers are saved, checking all to verify that the stream is more or
+ less within expected bounds. This happens inside the OJPEGReadHeaderInfoSecStreamXxx
+ functions.
+
+ Some OJPEG imagery contains no valid JPEG header markers. This situation is picked
+ up on if we've seen no SOF marker when we're at the start of the compressed image
+ data. In this case, the tables are read from JpegXxxTables tags, and the other
+ bits and pieces of information is initialized to its most basic value. This is
+ implemented in the OJPEGReadHeaderInfoSecTablesXxx functions.
+
+ When this is complete, a good and valid JPEG header can be assembled, and this is
+ passed through to LibJpeg. When that's done, the remainder of the input stream, i.e.
+ the compressed image data, can be passed through unchanged. This is done in
+ OJPEGWriteStream functions.
+
+ LibTiff rightly expects to know the subsampling values before decompression. Just like
+ in new-style JPEG-in-TIFF, though, or even more so, actually, the YCbCrsubsampling
+ tag is notoriously unreliable. To correct these tag values with the ones inside
+ the JPEG stream, the first part of the input stream is pre-scanned in
+ OJPEGSubsamplingCorrect, making no note of any other data, reporting no warnings
+ or errors, up to the point where either these values are read, or it's clear they
+ aren't there. This means that some of the data is read twice, but we feel speed
+ in correcting these values is important enough to warrant this sacrifice. Although
+ there is currently no define or other configuration mechanism to disable this behaviour,
+ the actual header scanning is build to robustly respond with error report if it
+ should encounter an uncorrected mismatch of subsampling values. See
+ OJPEGReadHeaderInfoSecStreamSof.
+
+ The restart interval and restart markers are the most tricky part... The restart
+ interval can be specified in a tag. It can also be set inside the input JPEG stream.
+ It can be used inside the input JPEG stream. If reading from strile data, we've
+ consistently discovered the need to insert restart markers in between the different
+ striles, as is also probably the most likely interpretation of the original TIFF 6.0
+ specification. With all this setting of interval, and actual use of markers that is not
+ predictable at the time of valid JPEG header assembly, the restart thing may turn
+ out the Achilles heel of this implementation. Fortunately, most OJPEG writer vendors
+ succeed in reading back what they write, which may be the reason why we've been able
+ to discover ways that seem to work.
+
+ Some special provision is made for planarconfig separate OJPEG files. These seem
+ to consistently contain header info, a SOS marker, a plane, SOS marker, plane, SOS,
+ and plane. This may or may not be a valid JPEG configuration, we don't know and don't
+ care. We want LibTiff to be able to access the planes individually, without huge
+ buffering inside LibJpeg, anyway. So we compose headers to feed to LibJpeg, in this
+ case, that allow us to pass a single plane such that LibJpeg sees a valid
+ single-channel JPEG stream. Locating subsequent SOS markers, and thus subsequent
+ planes, is done inside OJPEGReadSecondarySos.
+
+ The benefit of the scheme is... that it works, basically. We know of no other that
+ does. It works without checking software tag, or otherwise going about things in an
+ OJPEG flavor specific manner. Instead, it is a single scheme, that covers the cases
+ with and without JpegInterchangeFormat, with and without striles, with part of
+ the header in JpegInterchangeFormat and remainder in first strile, etc. It is forgiving
+ and robust, may likely work with OJPEG flavors we've not seen yet, and makes most out
+ of the data.
+
+ Another nice side-effect is that a complete JPEG single valid stream is build if
+ planarconfig is not separate (vast majority). We may one day use that to build
+ converters to JPEG, and/or to new-style JPEG compression inside TIFF.
+
+ A disadvantage is the lack of random access to the individual striles. This is the
+ reason for much of the complicated restart-and-position stuff inside OJPEGPreDecode.
+ Applications would do well accessing all striles in order, as this will result in
+ a single sequential scan of the input stream, and no restarting of LibJpeg decoding
+ session.
+*/
+
+#define WIN32_LEAN_AND_MEAN
+#define VC_EXTRALEAN
+
+#include "tiffiop.h"
+#ifdef OJPEG_SUPPORT
+
+/* Configuration defines here are:
+ * JPEG_ENCAP_EXTERNAL: The normal way to call libjpeg, uses longjump. In some environments,
+ * like eg LibTiffDelphi, this is not possible. For this reason, the actual calls to
+ * libjpeg, with longjump stuff, are encapsulated in dedicated functions. When
+ * JPEG_ENCAP_EXTERNAL is defined, these encapsulating functions are declared external
+ * to this unit, and can be defined elsewhere to use stuff other then longjump.
+ * The default mode, without JPEG_ENCAP_EXTERNAL, implements the call encapsulators
+ * here, internally, with normal longjump.
+ * SETJMP, LONGJMP, JMP_BUF: On some machines/environments a longjump equivalent is
+ * conveniently available, but still it may be worthwhile to use _setjmp or sigsetjmp
+ * in place of plain setjmp. These macros will make it easier. It is useless
+ * to fiddle with these if you define JPEG_ENCAP_EXTERNAL.
+ * OJPEG_BUFFER: Define the size of the desired buffer here. Should be small enough so as to guarantee
+ * instant processing, optimal streaming and optimal use of processor cache, but also big
+ * enough so as to not result in significant call overhead. It should be at least a few
+ * bytes to accommodate some structures (this is verified in asserts), but it would not be
+ * sensible to make it this small anyway, and it should be at most 64K since it is indexed
+ * with uint16. We recommend 2K.
+ * EGYPTIANWALK: You could also define EGYPTIANWALK here, but it is not used anywhere and has
+ * absolutely no effect. That is why most people insist the EGYPTIANWALK is a bit silly.
+ */
+
+/* define LIBJPEG_ENCAP_EXTERNAL */
+#define SETJMP(jbuf) setjmp(jbuf)
+#define LONGJMP(jbuf,code) longjmp(jbuf,code)
+#define JMP_BUF jmp_buf
+#define OJPEG_BUFFER 2048
+/* define EGYPTIANWALK */
+
+#define JPEG_MARKER_SOF0 0xC0
+#define JPEG_MARKER_SOF1 0xC1
+#define JPEG_MARKER_SOF3 0xC3
+#define JPEG_MARKER_DHT 0xC4
+#define JPEG_MARKER_RST0 0XD0
+#define JPEG_MARKER_SOI 0xD8
+#define JPEG_MARKER_EOI 0xD9
+#define JPEG_MARKER_SOS 0xDA
+#define JPEG_MARKER_DQT 0xDB
+#define JPEG_MARKER_DRI 0xDD
+#define JPEG_MARKER_APP0 0xE0
+#define JPEG_MARKER_COM 0xFE
+
+#define FIELD_OJPEG_JPEGINTERCHANGEFORMAT (FIELD_CODEC+0)
+#define FIELD_OJPEG_JPEGINTERCHANGEFORMATLENGTH (FIELD_CODEC+1)
+#define FIELD_OJPEG_JPEGQTABLES (FIELD_CODEC+2)
+#define FIELD_OJPEG_JPEGDCTABLES (FIELD_CODEC+3)
+#define FIELD_OJPEG_JPEGACTABLES (FIELD_CODEC+4)
+#define FIELD_OJPEG_JPEGPROC (FIELD_CODEC+5)
+#define FIELD_OJPEG_JPEGRESTARTINTERVAL (FIELD_CODEC+6)
+
+static const TIFFField ojpegFields[] = {
+ {TIFFTAG_JPEGIFOFFSET,1,1,TIFF_LONG8,0,TIFF_SETGET_UINT64,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGINTERCHANGEFORMAT,TRUE,FALSE,"JpegInterchangeFormat",NULL},
+ {TIFFTAG_JPEGIFBYTECOUNT,1,1,TIFF_LONG8,0,TIFF_SETGET_UINT64,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGINTERCHANGEFORMATLENGTH,TRUE,FALSE,"JpegInterchangeFormatLength",NULL},
+ {TIFFTAG_JPEGQTABLES,TIFF_VARIABLE2,TIFF_VARIABLE2,TIFF_LONG8,0,TIFF_SETGET_C32_UINT64,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGQTABLES,FALSE,TRUE,"JpegQTables",NULL},
+ {TIFFTAG_JPEGDCTABLES,TIFF_VARIABLE2,TIFF_VARIABLE2,TIFF_LONG8,0,TIFF_SETGET_C32_UINT64,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGDCTABLES,FALSE,TRUE,"JpegDcTables",NULL},
+ {TIFFTAG_JPEGACTABLES,TIFF_VARIABLE2,TIFF_VARIABLE2,TIFF_LONG8,0,TIFF_SETGET_C32_UINT64,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGACTABLES,FALSE,TRUE,"JpegAcTables",NULL},
+ {TIFFTAG_JPEGPROC,1,1,TIFF_SHORT,0,TIFF_SETGET_UINT16,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGPROC,FALSE,FALSE,"JpegProc",NULL},
+ {TIFFTAG_JPEGRESTARTINTERVAL,1,1,TIFF_SHORT,0,TIFF_SETGET_UINT16,TIFF_SETGET_UNDEFINED,FIELD_OJPEG_JPEGRESTARTINTERVAL,FALSE,FALSE,"JpegRestartInterval",NULL},
+};
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+#include <setjmp.h>
+#endif
+
+/* We undefine FAR to avoid conflict with JPEG definition */
+
+#ifdef FAR
+#undef FAR
+#endif
+
+/*
+ Libjpeg's jmorecfg.h defines INT16 and INT32, but only if XMD_H is
+ not defined. Unfortunately, the MinGW and Borland compilers include
+ a typedef for INT32, which causes a conflict. MSVC does not include
+ a conflicting typedef given the headers which are included.
+*/
+#if defined(__BORLANDC__) || defined(__MINGW32__)
+# define XMD_H 1
+#endif
+
+/* Define "boolean" as unsigned char, not int, per Windows custom. */
+#if defined(__WIN32__) && !defined(__MINGW32__)
+# ifndef __RPCNDR_H__ /* don't conflict if rpcndr.h already read */
+ typedef unsigned char boolean;
+# endif
+# define HAVE_BOOLEAN /* prevent jmorecfg.h from redefining it */
+#endif
+
+#include "jpeglib.h"
+#include "jerror.h"
+
+typedef struct jpeg_error_mgr jpeg_error_mgr;
+typedef struct jpeg_common_struct jpeg_common_struct;
+typedef struct jpeg_decompress_struct jpeg_decompress_struct;
+typedef struct jpeg_source_mgr jpeg_source_mgr;
+
+typedef enum {
+ osibsNotSetYet,
+ osibsJpegInterchangeFormat,
+ osibsStrile,
+ osibsEof
+} OJPEGStateInBufferSource;
+
+typedef enum {
+ ososSoi,
+ ososQTable0,ososQTable1,ososQTable2,ososQTable3,
+ ososDcTable0,ososDcTable1,ososDcTable2,ososDcTable3,
+ ososAcTable0,ososAcTable1,ososAcTable2,ososAcTable3,
+ ososDri,
+ ososSof,
+ ososSos,
+ ososCompressed,
+ ososRst,
+ ososEoi
+} OJPEGStateOutState;
+
+typedef struct {
+ TIFF* tif;
+ int decoder_ok;
+ #ifndef LIBJPEG_ENCAP_EXTERNAL
+ JMP_BUF exit_jmpbuf;
+ #endif
+ TIFFVGetMethod vgetparent;
+ TIFFVSetMethod vsetparent;
+ TIFFPrintMethod printdir;
+ uint64 file_size;
+ uint32 image_width;
+ uint32 image_length;
+ uint32 strile_width;
+ uint32 strile_length;
+ uint32 strile_length_total;
+ uint8 samples_per_pixel;
+ uint8 plane_sample_offset;
+ uint8 samples_per_pixel_per_plane;
+ uint64 jpeg_interchange_format;
+ uint64 jpeg_interchange_format_length;
+ uint8 jpeg_proc;
+ uint8 subsamplingcorrect;
+ uint8 subsamplingcorrect_done;
+ uint8 subsampling_tag;
+ uint8 subsampling_hor;
+ uint8 subsampling_ver;
+ uint8 subsampling_force_desubsampling_inside_decompression;
+ uint8 qtable_offset_count;
+ uint8 dctable_offset_count;
+ uint8 actable_offset_count;
+ uint64 qtable_offset[3];
+ uint64 dctable_offset[3];
+ uint64 actable_offset[3];
+ uint8* qtable[4];
+ uint8* dctable[4];
+ uint8* actable[4];
+ uint16 restart_interval;
+ uint8 restart_index;
+ uint8 sof_log;
+ uint8 sof_marker_id;
+ uint32 sof_x;
+ uint32 sof_y;
+ uint8 sof_c[3];
+ uint8 sof_hv[3];
+ uint8 sof_tq[3];
+ uint8 sos_cs[3];
+ uint8 sos_tda[3];
+ struct {
+ uint8 log;
+ OJPEGStateInBufferSource in_buffer_source;
+ uint32 in_buffer_next_strile;
+ uint64 in_buffer_file_pos;
+ uint64 in_buffer_file_togo;
+ } sos_end[3];
+ uint8 readheader_done;
+ uint8 writeheader_done;
+ uint16 write_cursample;
+ uint32 write_curstrile;
+ uint8 libjpeg_session_active;
+ uint8 libjpeg_jpeg_query_style;
+ jpeg_error_mgr libjpeg_jpeg_error_mgr;
+ jpeg_decompress_struct libjpeg_jpeg_decompress_struct;
+ jpeg_source_mgr libjpeg_jpeg_source_mgr;
+ uint8 subsampling_convert_log;
+ uint32 subsampling_convert_ylinelen;
+ uint32 subsampling_convert_ylines;
+ uint32 subsampling_convert_clinelen;
+ uint32 subsampling_convert_clines;
+ uint32 subsampling_convert_ybuflen;
+ uint32 subsampling_convert_cbuflen;
+ uint32 subsampling_convert_ycbcrbuflen;
+ uint8* subsampling_convert_ycbcrbuf;
+ uint8* subsampling_convert_ybuf;
+ uint8* subsampling_convert_cbbuf;
+ uint8* subsampling_convert_crbuf;
+ uint32 subsampling_convert_ycbcrimagelen;
+ uint8** subsampling_convert_ycbcrimage;
+ uint32 subsampling_convert_clinelenout;
+ uint32 subsampling_convert_state;
+ uint32 bytes_per_line; /* if the codec outputs subsampled data, a 'line' in bytes_per_line */
+ uint32 lines_per_strile; /* and lines_per_strile means subsampling_ver desubsampled rows */
+ OJPEGStateInBufferSource in_buffer_source;
+ uint32 in_buffer_next_strile;
+ uint32 in_buffer_strile_count;
+ uint64 in_buffer_file_pos;
+ uint8 in_buffer_file_pos_log;
+ uint64 in_buffer_file_togo;
+ uint16 in_buffer_togo;
+ uint8* in_buffer_cur;
+ uint8 in_buffer[OJPEG_BUFFER];
+ OJPEGStateOutState out_state;
+ uint8 out_buffer[OJPEG_BUFFER];
+ uint8* skip_buffer;
+} OJPEGState;
+
+static int OJPEGVGetField(TIFF* tif, uint32 tag, va_list ap);
+static int OJPEGVSetField(TIFF* tif, uint32 tag, va_list ap);
+static void OJPEGPrintDir(TIFF* tif, FILE* fd, long flags);
+
+static int OJPEGFixupTags(TIFF* tif);
+static int OJPEGSetupDecode(TIFF* tif);
+static int OJPEGPreDecode(TIFF* tif, uint16 s);
+static int OJPEGPreDecodeSkipRaw(TIFF* tif);
+static int OJPEGPreDecodeSkipScanlines(TIFF* tif);
+static int OJPEGDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int OJPEGDecodeRaw(TIFF* tif, uint8* buf, tmsize_t cc);
+static int OJPEGDecodeScanlines(TIFF* tif, uint8* buf, tmsize_t cc);
+static void OJPEGPostDecode(TIFF* tif, uint8* buf, tmsize_t cc);
+static int OJPEGSetupEncode(TIFF* tif);
+static int OJPEGPreEncode(TIFF* tif, uint16 s);
+static int OJPEGEncode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s);
+static int OJPEGPostEncode(TIFF* tif);
+static void OJPEGCleanup(TIFF* tif);
+
+static void OJPEGSubsamplingCorrect(TIFF* tif);
+static int OJPEGReadHeaderInfo(TIFF* tif);
+static int OJPEGReadSecondarySos(TIFF* tif, uint16 s);
+static int OJPEGWriteHeaderInfo(TIFF* tif);
+static void OJPEGLibjpegSessionAbort(TIFF* tif);
+
+static int OJPEGReadHeaderInfoSec(TIFF* tif);
+static int OJPEGReadHeaderInfoSecStreamDri(TIFF* tif);
+static int OJPEGReadHeaderInfoSecStreamDqt(TIFF* tif);
+static int OJPEGReadHeaderInfoSecStreamDht(TIFF* tif);
+static int OJPEGReadHeaderInfoSecStreamSof(TIFF* tif, uint8 marker_id);
+static int OJPEGReadHeaderInfoSecStreamSos(TIFF* tif);
+static int OJPEGReadHeaderInfoSecTablesQTable(TIFF* tif);
+static int OJPEGReadHeaderInfoSecTablesDcTable(TIFF* tif);
+static int OJPEGReadHeaderInfoSecTablesAcTable(TIFF* tif);
+
+static int OJPEGReadBufferFill(OJPEGState* sp);
+static int OJPEGReadByte(OJPEGState* sp, uint8* byte);
+static int OJPEGReadBytePeek(OJPEGState* sp, uint8* byte);
+static void OJPEGReadByteAdvance(OJPEGState* sp);
+static int OJPEGReadWord(OJPEGState* sp, uint16* word);
+static int OJPEGReadBlock(OJPEGState* sp, uint16 len, void* mem);
+static void OJPEGReadSkip(OJPEGState* sp, uint16 len);
+
+static int OJPEGWriteStream(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamSoi(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamQTable(TIFF* tif, uint8 table_index, void** mem, uint32* len);
+static void OJPEGWriteStreamDcTable(TIFF* tif, uint8 table_index, void** mem, uint32* len);
+static void OJPEGWriteStreamAcTable(TIFF* tif, uint8 table_index, void** mem, uint32* len);
+static void OJPEGWriteStreamDri(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamSof(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamSos(TIFF* tif, void** mem, uint32* len);
+static int OJPEGWriteStreamCompressed(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamRst(TIFF* tif, void** mem, uint32* len);
+static void OJPEGWriteStreamEoi(TIFF* tif, void** mem, uint32* len);
+
+#ifdef LIBJPEG_ENCAP_EXTERNAL
+extern int jpeg_create_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo);
+extern int jpeg_read_header_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, uint8 require_image);
+extern int jpeg_start_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo);
+extern int jpeg_read_scanlines_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* scanlines, uint32 max_lines);
+extern int jpeg_read_raw_data_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* data, uint32 max_lines);
+extern void jpeg_encap_unwind(TIFF* tif);
+#else
+static int jpeg_create_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* j);
+static int jpeg_read_header_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, uint8 require_image);
+static int jpeg_start_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo);
+static int jpeg_read_scanlines_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* scanlines, uint32 max_lines);
+static int jpeg_read_raw_data_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* data, uint32 max_lines);
+static void jpeg_encap_unwind(TIFF* tif);
+#endif
+
+static void OJPEGLibjpegJpegErrorMgrOutputMessage(jpeg_common_struct* cinfo);
+static void OJPEGLibjpegJpegErrorMgrErrorExit(jpeg_common_struct* cinfo);
+static void OJPEGLibjpegJpegSourceMgrInitSource(jpeg_decompress_struct* cinfo);
+static boolean OJPEGLibjpegJpegSourceMgrFillInputBuffer(jpeg_decompress_struct* cinfo);
+static void OJPEGLibjpegJpegSourceMgrSkipInputData(jpeg_decompress_struct* cinfo, long num_bytes);
+static boolean OJPEGLibjpegJpegSourceMgrResyncToRestart(jpeg_decompress_struct* cinfo, int desired);
+static void OJPEGLibjpegJpegSourceMgrTermSource(jpeg_decompress_struct* cinfo);
+
+int
+TIFFInitOJPEG(TIFF* tif, int scheme)
+{
+ static const char module[]="TIFFInitOJPEG";
+ OJPEGState* sp;
+
+ assert(scheme==COMPRESSION_OJPEG);
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, ojpegFields, TIFFArrayCount(ojpegFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging Old JPEG codec-specific tags failed");
+ return 0;
+ }
+
+ /* state block */
+ sp=_TIFFmalloc(sizeof(OJPEGState));
+ if (sp==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"No space for OJPEG state block");
+ return(0);
+ }
+ _TIFFmemset(sp,0,sizeof(OJPEGState));
+ sp->tif=tif;
+ sp->jpeg_proc=1;
+ sp->subsampling_hor=2;
+ sp->subsampling_ver=2;
+ TIFFSetField(tif,TIFFTAG_YCBCRSUBSAMPLING,2,2);
+ /* tif codec methods */
+ tif->tif_fixuptags=OJPEGFixupTags;
+ tif->tif_setupdecode=OJPEGSetupDecode;
+ tif->tif_predecode=OJPEGPreDecode;
+ tif->tif_postdecode=OJPEGPostDecode;
+ tif->tif_decoderow=OJPEGDecode;
+ tif->tif_decodestrip=OJPEGDecode;
+ tif->tif_decodetile=OJPEGDecode;
+ tif->tif_setupencode=OJPEGSetupEncode;
+ tif->tif_preencode=OJPEGPreEncode;
+ tif->tif_postencode=OJPEGPostEncode;
+ tif->tif_encoderow=OJPEGEncode;
+ tif->tif_encodestrip=OJPEGEncode;
+ tif->tif_encodetile=OJPEGEncode;
+ tif->tif_cleanup=OJPEGCleanup;
+ tif->tif_data=(uint8*)sp;
+ /* tif tag methods */
+ sp->vgetparent=tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield=OJPEGVGetField;
+ sp->vsetparent=tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield=OJPEGVSetField;
+ sp->printdir=tif->tif_tagmethods.printdir;
+ tif->tif_tagmethods.printdir=OJPEGPrintDir;
+ /* Some OJPEG files don't have strip or tile offsets or bytecounts tags.
+ Some others do, but have totally meaningless or corrupt values
+ in these tags. In these cases, the JpegInterchangeFormat stream is
+ reliable. In any case, this decoder reads the compressed data itself,
+ from the most reliable locations, and we need to notify encapsulating
+ LibTiff not to read raw strips or tiles for us. */
+ tif->tif_flags|=TIFF_NOREADRAW;
+ return(1);
+}
+
+static int
+OJPEGVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ switch(tag)
+ {
+ case TIFFTAG_JPEGIFOFFSET:
+ *va_arg(ap,uint64*)=(uint64)sp->jpeg_interchange_format;
+ break;
+ case TIFFTAG_JPEGIFBYTECOUNT:
+ *va_arg(ap,uint64*)=(uint64)sp->jpeg_interchange_format_length;
+ break;
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ if (sp->subsamplingcorrect_done==0)
+ OJPEGSubsamplingCorrect(tif);
+ *va_arg(ap,uint16*)=(uint16)sp->subsampling_hor;
+ *va_arg(ap,uint16*)=(uint16)sp->subsampling_ver;
+ break;
+ case TIFFTAG_JPEGQTABLES:
+ *va_arg(ap,uint32*)=(uint32)sp->qtable_offset_count;
+ *va_arg(ap,void**)=(void*)sp->qtable_offset;
+ break;
+ case TIFFTAG_JPEGDCTABLES:
+ *va_arg(ap,uint32*)=(uint32)sp->dctable_offset_count;
+ *va_arg(ap,void**)=(void*)sp->dctable_offset;
+ break;
+ case TIFFTAG_JPEGACTABLES:
+ *va_arg(ap,uint32*)=(uint32)sp->actable_offset_count;
+ *va_arg(ap,void**)=(void*)sp->actable_offset;
+ break;
+ case TIFFTAG_JPEGPROC:
+ *va_arg(ap,uint16*)=(uint16)sp->jpeg_proc;
+ break;
+ case TIFFTAG_JPEGRESTARTINTERVAL:
+ *va_arg(ap,uint16*)=sp->restart_interval;
+ break;
+ default:
+ return (*sp->vgetparent)(tif,tag,ap);
+ }
+ return (1);
+}
+
+static int
+OJPEGVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[]="OJPEGVSetField";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint32 ma;
+ uint64* mb;
+ uint32 n;
+ const TIFFField* fip;
+
+ switch(tag)
+ {
+ case TIFFTAG_JPEGIFOFFSET:
+ sp->jpeg_interchange_format=(uint64)va_arg(ap,uint64);
+ break;
+ case TIFFTAG_JPEGIFBYTECOUNT:
+ sp->jpeg_interchange_format_length=(uint64)va_arg(ap,uint64);
+ break;
+ case TIFFTAG_YCBCRSUBSAMPLING:
+ sp->subsampling_tag=1;
+ sp->subsampling_hor=(uint8)va_arg(ap,uint16_vap);
+ sp->subsampling_ver=(uint8)va_arg(ap,uint16_vap);
+ tif->tif_dir.td_ycbcrsubsampling[0]=sp->subsampling_hor;
+ tif->tif_dir.td_ycbcrsubsampling[1]=sp->subsampling_ver;
+ break;
+ case TIFFTAG_JPEGQTABLES:
+ ma=(uint32)va_arg(ap,uint32);
+ if (ma!=0)
+ {
+ if (ma>3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JpegQTables tag has incorrect count");
+ return(0);
+ }
+ sp->qtable_offset_count=(uint8)ma;
+ mb=(uint64*)va_arg(ap,uint64*);
+ for (n=0; n<ma; n++)
+ sp->qtable_offset[n]=mb[n];
+ }
+ break;
+ case TIFFTAG_JPEGDCTABLES:
+ ma=(uint32)va_arg(ap,uint32);
+ if (ma!=0)
+ {
+ if (ma>3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JpegDcTables tag has incorrect count");
+ return(0);
+ }
+ sp->dctable_offset_count=(uint8)ma;
+ mb=(uint64*)va_arg(ap,uint64*);
+ for (n=0; n<ma; n++)
+ sp->dctable_offset[n]=mb[n];
+ }
+ break;
+ case TIFFTAG_JPEGACTABLES:
+ ma=(uint32)va_arg(ap,uint32);
+ if (ma!=0)
+ {
+ if (ma>3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JpegAcTables tag has incorrect count");
+ return(0);
+ }
+ sp->actable_offset_count=(uint8)ma;
+ mb=(uint64*)va_arg(ap,uint64*);
+ for (n=0; n<ma; n++)
+ sp->actable_offset[n]=mb[n];
+ }
+ break;
+ case TIFFTAG_JPEGPROC:
+ sp->jpeg_proc=(uint8)va_arg(ap,uint16_vap);
+ break;
+ case TIFFTAG_JPEGRESTARTINTERVAL:
+ sp->restart_interval=(uint16)va_arg(ap,uint16_vap);
+ break;
+ default:
+ return (*sp->vsetparent)(tif,tag,ap);
+ }
+ fip = TIFFFieldWithTag(tif,tag);
+ if( fip == NULL ) /* shouldn't happen */
+ return(0);
+ TIFFSetFieldBit(tif,fip->field_bit);
+ tif->tif_flags|=TIFF_DIRTYDIRECT;
+ return(1);
+}
+
+static void
+OJPEGPrintDir(TIFF* tif, FILE* fd, long flags)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ (void)flags;
+ assert(sp!=NULL);
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGINTERCHANGEFORMAT))
+ fprintf(fd," JpegInterchangeFormat: " TIFF_UINT64_FORMAT "\n",(TIFF_UINT64_T)sp->jpeg_interchange_format);
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGINTERCHANGEFORMATLENGTH))
+ fprintf(fd," JpegInterchangeFormatLength: " TIFF_UINT64_FORMAT "\n",(TIFF_UINT64_T)sp->jpeg_interchange_format_length);
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGQTABLES))
+ {
+ fprintf(fd," JpegQTables:");
+ for (m=0; m<sp->qtable_offset_count; m++)
+ fprintf(fd," " TIFF_UINT64_FORMAT,(TIFF_UINT64_T)sp->qtable_offset[m]);
+ fprintf(fd,"\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGDCTABLES))
+ {
+ fprintf(fd," JpegDcTables:");
+ for (m=0; m<sp->dctable_offset_count; m++)
+ fprintf(fd," " TIFF_UINT64_FORMAT,(TIFF_UINT64_T)sp->dctable_offset[m]);
+ fprintf(fd,"\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGACTABLES))
+ {
+ fprintf(fd," JpegAcTables:");
+ for (m=0; m<sp->actable_offset_count; m++)
+ fprintf(fd," " TIFF_UINT64_FORMAT,(TIFF_UINT64_T)sp->actable_offset[m]);
+ fprintf(fd,"\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGPROC))
+ fprintf(fd," JpegProc: %u\n",(unsigned int)sp->jpeg_proc);
+ if (TIFFFieldSet(tif,FIELD_OJPEG_JPEGRESTARTINTERVAL))
+ fprintf(fd," JpegRestartInterval: %u\n",(unsigned int)sp->restart_interval);
+ if (sp->printdir)
+ (*sp->printdir)(tif, fd, flags);
+}
+
+static int
+OJPEGFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return(1);
+}
+
+static int
+OJPEGSetupDecode(TIFF* tif)
+{
+ static const char module[]="OJPEGSetupDecode";
+ TIFFWarningExt(tif->tif_clientdata,module,"Depreciated and troublesome old-style JPEG compression mode, please convert to new-style JPEG compression and notify vendor of writing software");
+ return(1);
+}
+
+static int
+OJPEGPreDecode(TIFF* tif, uint16 s)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint32 m;
+ if (sp->subsamplingcorrect_done==0)
+ OJPEGSubsamplingCorrect(tif);
+ if (sp->readheader_done==0)
+ {
+ if (OJPEGReadHeaderInfo(tif)==0)
+ return(0);
+ }
+ if (sp->sos_end[s].log==0)
+ {
+ if (OJPEGReadSecondarySos(tif,s)==0)
+ return(0);
+ }
+ if isTiled(tif)
+ m=tif->tif_curtile;
+ else
+ m=tif->tif_curstrip;
+ if ((sp->writeheader_done!=0) && ((sp->write_cursample!=s) || (sp->write_curstrile>m)))
+ {
+ if (sp->libjpeg_session_active!=0)
+ OJPEGLibjpegSessionAbort(tif);
+ sp->writeheader_done=0;
+ }
+ if (sp->writeheader_done==0)
+ {
+ sp->plane_sample_offset=(uint8)s;
+ sp->write_cursample=s;
+ sp->write_curstrile=s*tif->tif_dir.td_stripsperimage;
+ if ((sp->in_buffer_file_pos_log==0) ||
+ (sp->in_buffer_file_pos-sp->in_buffer_togo!=sp->sos_end[s].in_buffer_file_pos))
+ {
+ sp->in_buffer_source=sp->sos_end[s].in_buffer_source;
+ sp->in_buffer_next_strile=sp->sos_end[s].in_buffer_next_strile;
+ sp->in_buffer_file_pos=sp->sos_end[s].in_buffer_file_pos;
+ sp->in_buffer_file_pos_log=0;
+ sp->in_buffer_file_togo=sp->sos_end[s].in_buffer_file_togo;
+ sp->in_buffer_togo=0;
+ sp->in_buffer_cur=0;
+ }
+ if (OJPEGWriteHeaderInfo(tif)==0)
+ return(0);
+ }
+ while (sp->write_curstrile<m)
+ {
+ if (sp->libjpeg_jpeg_query_style==0)
+ {
+ if (OJPEGPreDecodeSkipRaw(tif)==0)
+ return(0);
+ }
+ else
+ {
+ if (OJPEGPreDecodeSkipScanlines(tif)==0)
+ return(0);
+ }
+ sp->write_curstrile++;
+ }
+ sp->decoder_ok = 1;
+ return(1);
+}
+
+static int
+OJPEGPreDecodeSkipRaw(TIFF* tif)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint32 m;
+ m=sp->lines_per_strile;
+ if (sp->subsampling_convert_state!=0)
+ {
+ if (sp->subsampling_convert_clines-sp->subsampling_convert_state>=m)
+ {
+ sp->subsampling_convert_state+=m;
+ if (sp->subsampling_convert_state==sp->subsampling_convert_clines)
+ sp->subsampling_convert_state=0;
+ return(1);
+ }
+ m-=sp->subsampling_convert_clines-sp->subsampling_convert_state;
+ sp->subsampling_convert_state=0;
+ }
+ while (m>=sp->subsampling_convert_clines)
+ {
+ if (jpeg_read_raw_data_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),sp->subsampling_convert_ycbcrimage,sp->subsampling_ver*8)==0)
+ return(0);
+ m-=sp->subsampling_convert_clines;
+ }
+ if (m>0)
+ {
+ if (jpeg_read_raw_data_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),sp->subsampling_convert_ycbcrimage,sp->subsampling_ver*8)==0)
+ return(0);
+ sp->subsampling_convert_state=m;
+ }
+ return(1);
+}
+
+static int
+OJPEGPreDecodeSkipScanlines(TIFF* tif)
+{
+ static const char module[]="OJPEGPreDecodeSkipScanlines";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint32 m;
+ if (sp->skip_buffer==NULL)
+ {
+ sp->skip_buffer=_TIFFmalloc(sp->bytes_per_line);
+ if (sp->skip_buffer==NULL)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ }
+ for (m=0; m<sp->lines_per_strile; m++)
+ {
+ if (jpeg_read_scanlines_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),&sp->skip_buffer,1)==0)
+ return(0);
+ }
+ return(1);
+}
+
+static int
+OJPEGDecode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ static const char module[]="OJPEGDecode";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ (void)s;
+ if( !sp->decoder_ok )
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Cannot decode: decoder not correctly initialized");
+ return 0;
+ }
+ if (sp->libjpeg_jpeg_query_style==0)
+ {
+ if (OJPEGDecodeRaw(tif,buf,cc)==0)
+ return(0);
+ }
+ else
+ {
+ if (OJPEGDecodeScanlines(tif,buf,cc)==0)
+ return(0);
+ }
+ return(1);
+}
+
+static int
+OJPEGDecodeRaw(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ static const char module[]="OJPEGDecodeRaw";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8* m;
+ tmsize_t n;
+ uint8* oy;
+ uint8* ocb;
+ uint8* ocr;
+ uint8* p;
+ uint32 q;
+ uint8* r;
+ uint8 sx,sy;
+ if (cc%sp->bytes_per_line!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Fractional scanline not read");
+ return(0);
+ }
+ assert(cc>0);
+ m=buf;
+ n=cc;
+ do
+ {
+ if (sp->subsampling_convert_state==0)
+ {
+ if (jpeg_read_raw_data_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),sp->subsampling_convert_ycbcrimage,sp->subsampling_ver*8)==0)
+ return(0);
+ }
+ oy=sp->subsampling_convert_ybuf+sp->subsampling_convert_state*sp->subsampling_ver*sp->subsampling_convert_ylinelen;
+ ocb=sp->subsampling_convert_cbbuf+sp->subsampling_convert_state*sp->subsampling_convert_clinelen;
+ ocr=sp->subsampling_convert_crbuf+sp->subsampling_convert_state*sp->subsampling_convert_clinelen;
+ p=m;
+ for (q=0; q<sp->subsampling_convert_clinelenout; q++)
+ {
+ r=oy;
+ for (sy=0; sy<sp->subsampling_ver; sy++)
+ {
+ for (sx=0; sx<sp->subsampling_hor; sx++)
+ *p++=*r++;
+ r+=sp->subsampling_convert_ylinelen-sp->subsampling_hor;
+ }
+ oy+=sp->subsampling_hor;
+ *p++=*ocb++;
+ *p++=*ocr++;
+ }
+ sp->subsampling_convert_state++;
+ if (sp->subsampling_convert_state==sp->subsampling_convert_clines)
+ sp->subsampling_convert_state=0;
+ m+=sp->bytes_per_line;
+ n-=sp->bytes_per_line;
+ } while(n>0);
+ return(1);
+}
+
+static int
+OJPEGDecodeScanlines(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ static const char module[]="OJPEGDecodeScanlines";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8* m;
+ tmsize_t n;
+ if (cc%sp->bytes_per_line!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Fractional scanline not read");
+ return(0);
+ }
+ assert(cc>0);
+ m=buf;
+ n=cc;
+ do
+ {
+ if (jpeg_read_scanlines_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),&m,1)==0)
+ return(0);
+ m+=sp->bytes_per_line;
+ n-=sp->bytes_per_line;
+ } while(n>0);
+ return(1);
+}
+
+static void
+OJPEGPostDecode(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ (void)buf;
+ (void)cc;
+ sp->write_curstrile++;
+ if (sp->write_curstrile%tif->tif_dir.td_stripsperimage==0)
+ {
+ assert(sp->libjpeg_session_active!=0);
+ OJPEGLibjpegSessionAbort(tif);
+ sp->writeheader_done=0;
+ }
+}
+
+static int
+OJPEGSetupEncode(TIFF* tif)
+{
+ static const char module[]="OJPEGSetupEncode";
+ TIFFErrorExt(tif->tif_clientdata,module,"OJPEG encoding not supported; use new-style JPEG compression instead");
+ return(0);
+}
+
+static int
+OJPEGPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[]="OJPEGPreEncode";
+ (void)s;
+ TIFFErrorExt(tif->tif_clientdata,module,"OJPEG encoding not supported; use new-style JPEG compression instead");
+ return(0);
+}
+
+static int
+OJPEGEncode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ static const char module[]="OJPEGEncode";
+ (void)buf;
+ (void)cc;
+ (void)s;
+ TIFFErrorExt(tif->tif_clientdata,module,"OJPEG encoding not supported; use new-style JPEG compression instead");
+ return(0);
+}
+
+static int
+OJPEGPostEncode(TIFF* tif)
+{
+ static const char module[]="OJPEGPostEncode";
+ TIFFErrorExt(tif->tif_clientdata,module,"OJPEG encoding not supported; use new-style JPEG compression instead");
+ return(0);
+}
+
+static void
+OJPEGCleanup(TIFF* tif)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ if (sp!=0)
+ {
+ tif->tif_tagmethods.vgetfield=sp->vgetparent;
+ tif->tif_tagmethods.vsetfield=sp->vsetparent;
+ tif->tif_tagmethods.printdir=sp->printdir;
+ if (sp->qtable[0]!=0)
+ _TIFFfree(sp->qtable[0]);
+ if (sp->qtable[1]!=0)
+ _TIFFfree(sp->qtable[1]);
+ if (sp->qtable[2]!=0)
+ _TIFFfree(sp->qtable[2]);
+ if (sp->qtable[3]!=0)
+ _TIFFfree(sp->qtable[3]);
+ if (sp->dctable[0]!=0)
+ _TIFFfree(sp->dctable[0]);
+ if (sp->dctable[1]!=0)
+ _TIFFfree(sp->dctable[1]);
+ if (sp->dctable[2]!=0)
+ _TIFFfree(sp->dctable[2]);
+ if (sp->dctable[3]!=0)
+ _TIFFfree(sp->dctable[3]);
+ if (sp->actable[0]!=0)
+ _TIFFfree(sp->actable[0]);
+ if (sp->actable[1]!=0)
+ _TIFFfree(sp->actable[1]);
+ if (sp->actable[2]!=0)
+ _TIFFfree(sp->actable[2]);
+ if (sp->actable[3]!=0)
+ _TIFFfree(sp->actable[3]);
+ if (sp->libjpeg_session_active!=0)
+ OJPEGLibjpegSessionAbort(tif);
+ if (sp->subsampling_convert_ycbcrbuf!=0)
+ _TIFFfree(sp->subsampling_convert_ycbcrbuf);
+ if (sp->subsampling_convert_ycbcrimage!=0)
+ _TIFFfree(sp->subsampling_convert_ycbcrimage);
+ if (sp->skip_buffer!=0)
+ _TIFFfree(sp->skip_buffer);
+ _TIFFfree(sp);
+ tif->tif_data=NULL;
+ _TIFFSetDefaultCompressionState(tif);
+ }
+}
+
+static void
+OJPEGSubsamplingCorrect(TIFF* tif)
+{
+ static const char module[]="OJPEGSubsamplingCorrect";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 mh;
+ uint8 mv;
+ _TIFFFillStriles( tif );
+
+ assert(sp->subsamplingcorrect_done==0);
+ if ((tif->tif_dir.td_samplesperpixel!=3) || ((tif->tif_dir.td_photometric!=PHOTOMETRIC_YCBCR) &&
+ (tif->tif_dir.td_photometric!=PHOTOMETRIC_ITULAB)))
+ {
+ if (sp->subsampling_tag!=0)
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling tag not appropriate for this Photometric and/or SamplesPerPixel");
+ sp->subsampling_hor=1;
+ sp->subsampling_ver=1;
+ sp->subsampling_force_desubsampling_inside_decompression=0;
+ }
+ else
+ {
+ sp->subsamplingcorrect_done=1;
+ mh=sp->subsampling_hor;
+ mv=sp->subsampling_ver;
+ sp->subsamplingcorrect=1;
+ OJPEGReadHeaderInfoSec(tif);
+ if (sp->subsampling_force_desubsampling_inside_decompression!=0)
+ {
+ sp->subsampling_hor=1;
+ sp->subsampling_ver=1;
+ }
+ sp->subsamplingcorrect=0;
+ if (((sp->subsampling_hor!=mh) || (sp->subsampling_ver!=mv)) && (sp->subsampling_force_desubsampling_inside_decompression==0))
+ {
+ if (sp->subsampling_tag==0)
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling tag is not set, yet subsampling inside JPEG data [%d,%d] does not match default values [2,2]; assuming subsampling inside JPEG data is correct",sp->subsampling_hor,sp->subsampling_ver);
+ else
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling inside JPEG data [%d,%d] does not match subsampling tag values [%d,%d]; assuming subsampling inside JPEG data is correct",sp->subsampling_hor,sp->subsampling_ver,mh,mv);
+ }
+ if (sp->subsampling_force_desubsampling_inside_decompression!=0)
+ {
+ if (sp->subsampling_tag==0)
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling tag is not set, yet subsampling inside JPEG data does not match default values [2,2] (nor any other values allowed in TIFF); assuming subsampling inside JPEG data is correct and desubsampling inside JPEG decompression");
+ else
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling inside JPEG data does not match subsampling tag values [%d,%d] (nor any other values allowed in TIFF); assuming subsampling inside JPEG data is correct and desubsampling inside JPEG decompression",mh,mv);
+ }
+ if (sp->subsampling_force_desubsampling_inside_decompression==0)
+ {
+ if (sp->subsampling_hor<sp->subsampling_ver)
+ TIFFWarningExt(tif->tif_clientdata,module,"Subsampling values [%d,%d] are not allowed in TIFF",sp->subsampling_hor,sp->subsampling_ver);
+ }
+ }
+ sp->subsamplingcorrect_done=1;
+}
+
+static int
+OJPEGReadHeaderInfo(TIFF* tif)
+{
+ static const char module[]="OJPEGReadHeaderInfo";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(sp->readheader_done==0);
+ sp->image_width=tif->tif_dir.td_imagewidth;
+ sp->image_length=tif->tif_dir.td_imagelength;
+ if isTiled(tif)
+ {
+ sp->strile_width=tif->tif_dir.td_tilewidth;
+ sp->strile_length=tif->tif_dir.td_tilelength;
+ sp->strile_length_total=((sp->image_length+sp->strile_length-1)/sp->strile_length)*sp->strile_length;
+ }
+ else
+ {
+ sp->strile_width=sp->image_width;
+ sp->strile_length=tif->tif_dir.td_rowsperstrip;
+ sp->strile_length_total=sp->image_length;
+ }
+ if (tif->tif_dir.td_samplesperpixel==1)
+ {
+ sp->samples_per_pixel=1;
+ sp->plane_sample_offset=0;
+ sp->samples_per_pixel_per_plane=sp->samples_per_pixel;
+ sp->subsampling_hor=1;
+ sp->subsampling_ver=1;
+ }
+ else
+ {
+ if (tif->tif_dir.td_samplesperpixel!=3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"SamplesPerPixel %d not supported for this compression scheme",sp->samples_per_pixel);
+ return(0);
+ }
+ sp->samples_per_pixel=3;
+ sp->plane_sample_offset=0;
+ if (tif->tif_dir.td_planarconfig==PLANARCONFIG_CONTIG)
+ sp->samples_per_pixel_per_plane=3;
+ else
+ sp->samples_per_pixel_per_plane=1;
+ }
+ if (sp->strile_length<sp->image_length)
+ {
+ if (sp->strile_length%(sp->subsampling_ver*8)!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Incompatible vertical subsampling and image strip/tile length");
+ return(0);
+ }
+ sp->restart_interval=(uint16)(((sp->strile_width+sp->subsampling_hor*8-1)/(sp->subsampling_hor*8))*(sp->strile_length/(sp->subsampling_ver*8)));
+ }
+ if (OJPEGReadHeaderInfoSec(tif)==0)
+ return(0);
+ sp->sos_end[0].log=1;
+ sp->sos_end[0].in_buffer_source=sp->in_buffer_source;
+ sp->sos_end[0].in_buffer_next_strile=sp->in_buffer_next_strile;
+ sp->sos_end[0].in_buffer_file_pos=sp->in_buffer_file_pos-sp->in_buffer_togo;
+ sp->sos_end[0].in_buffer_file_togo=sp->in_buffer_file_togo+sp->in_buffer_togo;
+ sp->readheader_done=1;
+ return(1);
+}
+
+static int
+OJPEGReadSecondarySos(TIFF* tif, uint16 s)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ assert(s>0);
+ assert(s<3);
+ assert(sp->sos_end[0].log!=0);
+ assert(sp->sos_end[s].log==0);
+ sp->plane_sample_offset=(uint8)(s-1);
+ while(sp->sos_end[sp->plane_sample_offset].log==0)
+ sp->plane_sample_offset--;
+ sp->in_buffer_source=sp->sos_end[sp->plane_sample_offset].in_buffer_source;
+ sp->in_buffer_next_strile=sp->sos_end[sp->plane_sample_offset].in_buffer_next_strile;
+ sp->in_buffer_file_pos=sp->sos_end[sp->plane_sample_offset].in_buffer_file_pos;
+ sp->in_buffer_file_pos_log=0;
+ sp->in_buffer_file_togo=sp->sos_end[sp->plane_sample_offset].in_buffer_file_togo;
+ sp->in_buffer_togo=0;
+ sp->in_buffer_cur=0;
+ while(sp->plane_sample_offset<s)
+ {
+ do
+ {
+ if (OJPEGReadByte(sp,&m)==0)
+ return(0);
+ if (m==255)
+ {
+ do
+ {
+ if (OJPEGReadByte(sp,&m)==0)
+ return(0);
+ if (m!=255)
+ break;
+ } while(1);
+ if (m==JPEG_MARKER_SOS)
+ break;
+ }
+ } while(1);
+ sp->plane_sample_offset++;
+ if (OJPEGReadHeaderInfoSecStreamSos(tif)==0)
+ return(0);
+ sp->sos_end[sp->plane_sample_offset].log=1;
+ sp->sos_end[sp->plane_sample_offset].in_buffer_source=sp->in_buffer_source;
+ sp->sos_end[sp->plane_sample_offset].in_buffer_next_strile=sp->in_buffer_next_strile;
+ sp->sos_end[sp->plane_sample_offset].in_buffer_file_pos=sp->in_buffer_file_pos-sp->in_buffer_togo;
+ sp->sos_end[sp->plane_sample_offset].in_buffer_file_togo=sp->in_buffer_file_togo+sp->in_buffer_togo;
+ }
+ return(1);
+}
+
+static int
+OJPEGWriteHeaderInfo(TIFF* tif)
+{
+ static const char module[]="OJPEGWriteHeaderInfo";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8** m;
+ uint32 n;
+ /* if a previous attempt failed, don't try again */
+ if (sp->libjpeg_session_active != 0)
+ return 0;
+ sp->out_state=ososSoi;
+ sp->restart_index=0;
+ jpeg_std_error(&(sp->libjpeg_jpeg_error_mgr));
+ sp->libjpeg_jpeg_error_mgr.output_message=OJPEGLibjpegJpegErrorMgrOutputMessage;
+ sp->libjpeg_jpeg_error_mgr.error_exit=OJPEGLibjpegJpegErrorMgrErrorExit;
+ sp->libjpeg_jpeg_decompress_struct.err=&(sp->libjpeg_jpeg_error_mgr);
+ sp->libjpeg_jpeg_decompress_struct.client_data=(void*)tif;
+ if (jpeg_create_decompress_encap(sp,&(sp->libjpeg_jpeg_decompress_struct))==0)
+ return(0);
+ sp->libjpeg_session_active=1;
+ sp->libjpeg_jpeg_source_mgr.bytes_in_buffer=0;
+ sp->libjpeg_jpeg_source_mgr.init_source=OJPEGLibjpegJpegSourceMgrInitSource;
+ sp->libjpeg_jpeg_source_mgr.fill_input_buffer=OJPEGLibjpegJpegSourceMgrFillInputBuffer;
+ sp->libjpeg_jpeg_source_mgr.skip_input_data=OJPEGLibjpegJpegSourceMgrSkipInputData;
+ sp->libjpeg_jpeg_source_mgr.resync_to_restart=OJPEGLibjpegJpegSourceMgrResyncToRestart;
+ sp->libjpeg_jpeg_source_mgr.term_source=OJPEGLibjpegJpegSourceMgrTermSource;
+ sp->libjpeg_jpeg_decompress_struct.src=&(sp->libjpeg_jpeg_source_mgr);
+ if (jpeg_read_header_encap(sp,&(sp->libjpeg_jpeg_decompress_struct),1)==0)
+ return(0);
+ if ((sp->subsampling_force_desubsampling_inside_decompression==0) && (sp->samples_per_pixel_per_plane>1))
+ {
+ sp->libjpeg_jpeg_decompress_struct.raw_data_out=1;
+#if JPEG_LIB_VERSION >= 70
+ sp->libjpeg_jpeg_decompress_struct.do_fancy_upsampling=FALSE;
+#endif
+ sp->libjpeg_jpeg_query_style=0;
+ if (sp->subsampling_convert_log==0)
+ {
+ assert(sp->subsampling_convert_ycbcrbuf==0);
+ assert(sp->subsampling_convert_ycbcrimage==0);
+ sp->subsampling_convert_ylinelen=((sp->strile_width+sp->subsampling_hor*8-1)/(sp->subsampling_hor*8)*sp->subsampling_hor*8);
+ sp->subsampling_convert_ylines=sp->subsampling_ver*8;
+ sp->subsampling_convert_clinelen=sp->subsampling_convert_ylinelen/sp->subsampling_hor;
+ sp->subsampling_convert_clines=8;
+ sp->subsampling_convert_ybuflen=sp->subsampling_convert_ylinelen*sp->subsampling_convert_ylines;
+ sp->subsampling_convert_cbuflen=sp->subsampling_convert_clinelen*sp->subsampling_convert_clines;
+ sp->subsampling_convert_ycbcrbuflen=sp->subsampling_convert_ybuflen+2*sp->subsampling_convert_cbuflen;
+ sp->subsampling_convert_ycbcrbuf=_TIFFmalloc(sp->subsampling_convert_ycbcrbuflen);
+ if (sp->subsampling_convert_ycbcrbuf==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ sp->subsampling_convert_ybuf=sp->subsampling_convert_ycbcrbuf;
+ sp->subsampling_convert_cbbuf=sp->subsampling_convert_ybuf+sp->subsampling_convert_ybuflen;
+ sp->subsampling_convert_crbuf=sp->subsampling_convert_cbbuf+sp->subsampling_convert_cbuflen;
+ sp->subsampling_convert_ycbcrimagelen=3+sp->subsampling_convert_ylines+2*sp->subsampling_convert_clines;
+ sp->subsampling_convert_ycbcrimage=_TIFFmalloc(sp->subsampling_convert_ycbcrimagelen*sizeof(uint8*));
+ if (sp->subsampling_convert_ycbcrimage==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ m=sp->subsampling_convert_ycbcrimage;
+ *m++=(uint8*)(sp->subsampling_convert_ycbcrimage+3);
+ *m++=(uint8*)(sp->subsampling_convert_ycbcrimage+3+sp->subsampling_convert_ylines);
+ *m++=(uint8*)(sp->subsampling_convert_ycbcrimage+3+sp->subsampling_convert_ylines+sp->subsampling_convert_clines);
+ for (n=0; n<sp->subsampling_convert_ylines; n++)
+ *m++=sp->subsampling_convert_ybuf+n*sp->subsampling_convert_ylinelen;
+ for (n=0; n<sp->subsampling_convert_clines; n++)
+ *m++=sp->subsampling_convert_cbbuf+n*sp->subsampling_convert_clinelen;
+ for (n=0; n<sp->subsampling_convert_clines; n++)
+ *m++=sp->subsampling_convert_crbuf+n*sp->subsampling_convert_clinelen;
+ sp->subsampling_convert_clinelenout=((sp->strile_width+sp->subsampling_hor-1)/sp->subsampling_hor);
+ sp->subsampling_convert_state=0;
+ sp->bytes_per_line=sp->subsampling_convert_clinelenout*(sp->subsampling_ver*sp->subsampling_hor+2);
+ sp->lines_per_strile=((sp->strile_length+sp->subsampling_ver-1)/sp->subsampling_ver);
+ sp->subsampling_convert_log=1;
+ }
+ }
+ else
+ {
+ sp->libjpeg_jpeg_decompress_struct.jpeg_color_space=JCS_UNKNOWN;
+ sp->libjpeg_jpeg_decompress_struct.out_color_space=JCS_UNKNOWN;
+ sp->libjpeg_jpeg_query_style=1;
+ sp->bytes_per_line=sp->samples_per_pixel_per_plane*sp->strile_width;
+ sp->lines_per_strile=sp->strile_length;
+ }
+ if (jpeg_start_decompress_encap(sp,&(sp->libjpeg_jpeg_decompress_struct))==0)
+ return(0);
+ sp->writeheader_done=1;
+ return(1);
+}
+
+static void
+OJPEGLibjpegSessionAbort(TIFF* tif)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(sp->libjpeg_session_active!=0);
+ jpeg_destroy((jpeg_common_struct*)(&(sp->libjpeg_jpeg_decompress_struct)));
+ sp->libjpeg_session_active=0;
+}
+
+static int
+OJPEGReadHeaderInfoSec(TIFF* tif)
+{
+ static const char module[]="OJPEGReadHeaderInfoSec";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ uint16 n;
+ uint8 o;
+ if (sp->file_size==0)
+ sp->file_size=TIFFGetFileSize(tif);
+ if (sp->jpeg_interchange_format!=0)
+ {
+ if (sp->jpeg_interchange_format>=sp->file_size)
+ {
+ sp->jpeg_interchange_format=0;
+ sp->jpeg_interchange_format_length=0;
+ }
+ else
+ {
+ if ((sp->jpeg_interchange_format_length==0) || (sp->jpeg_interchange_format+sp->jpeg_interchange_format_length>sp->file_size))
+ sp->jpeg_interchange_format_length=sp->file_size-sp->jpeg_interchange_format;
+ }
+ }
+ sp->in_buffer_source=osibsNotSetYet;
+ sp->in_buffer_next_strile=0;
+ sp->in_buffer_strile_count=tif->tif_dir.td_nstrips;
+ sp->in_buffer_file_togo=0;
+ sp->in_buffer_togo=0;
+ do
+ {
+ if (OJPEGReadBytePeek(sp,&m)==0)
+ return(0);
+ if (m!=255)
+ break;
+ OJPEGReadByteAdvance(sp);
+ do
+ {
+ if (OJPEGReadByte(sp,&m)==0)
+ return(0);
+ } while(m==255);
+ switch(m)
+ {
+ case JPEG_MARKER_SOI:
+ /* this type of marker has no data, and should be skipped */
+ break;
+ case JPEG_MARKER_COM:
+ case JPEG_MARKER_APP0:
+ case JPEG_MARKER_APP0+1:
+ case JPEG_MARKER_APP0+2:
+ case JPEG_MARKER_APP0+3:
+ case JPEG_MARKER_APP0+4:
+ case JPEG_MARKER_APP0+5:
+ case JPEG_MARKER_APP0+6:
+ case JPEG_MARKER_APP0+7:
+ case JPEG_MARKER_APP0+8:
+ case JPEG_MARKER_APP0+9:
+ case JPEG_MARKER_APP0+10:
+ case JPEG_MARKER_APP0+11:
+ case JPEG_MARKER_APP0+12:
+ case JPEG_MARKER_APP0+13:
+ case JPEG_MARKER_APP0+14:
+ case JPEG_MARKER_APP0+15:
+ /* this type of marker has data, but it has no use to us (and no place here) and should be skipped */
+ if (OJPEGReadWord(sp,&n)==0)
+ return(0);
+ if (n<2)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt JPEG data");
+ return(0);
+ }
+ if (n>2)
+ OJPEGReadSkip(sp,n-2);
+ break;
+ case JPEG_MARKER_DRI:
+ if (OJPEGReadHeaderInfoSecStreamDri(tif)==0)
+ return(0);
+ break;
+ case JPEG_MARKER_DQT:
+ if (OJPEGReadHeaderInfoSecStreamDqt(tif)==0)
+ return(0);
+ break;
+ case JPEG_MARKER_DHT:
+ if (OJPEGReadHeaderInfoSecStreamDht(tif)==0)
+ return(0);
+ break;
+ case JPEG_MARKER_SOF0:
+ case JPEG_MARKER_SOF1:
+ case JPEG_MARKER_SOF3:
+ if (OJPEGReadHeaderInfoSecStreamSof(tif,m)==0)
+ return(0);
+ if (sp->subsamplingcorrect!=0)
+ return(1);
+ break;
+ case JPEG_MARKER_SOS:
+ if (sp->subsamplingcorrect!=0)
+ return(1);
+ assert(sp->plane_sample_offset==0);
+ if (OJPEGReadHeaderInfoSecStreamSos(tif)==0)
+ return(0);
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata,module,"Unknown marker type %d in JPEG data",m);
+ return(0);
+ }
+ } while(m!=JPEG_MARKER_SOS);
+ if (sp->subsamplingcorrect)
+ return(1);
+ if (sp->sof_log==0)
+ {
+ if (OJPEGReadHeaderInfoSecTablesQTable(tif)==0)
+ return(0);
+ sp->sof_marker_id=JPEG_MARKER_SOF0;
+ for (o=0; o<sp->samples_per_pixel; o++)
+ sp->sof_c[o]=o;
+ sp->sof_hv[0]=((sp->subsampling_hor<<4)|sp->subsampling_ver);
+ for (o=1; o<sp->samples_per_pixel; o++)
+ sp->sof_hv[o]=17;
+ sp->sof_x=sp->strile_width;
+ sp->sof_y=sp->strile_length_total;
+ sp->sof_log=1;
+ if (OJPEGReadHeaderInfoSecTablesDcTable(tif)==0)
+ return(0);
+ if (OJPEGReadHeaderInfoSecTablesAcTable(tif)==0)
+ return(0);
+ for (o=1; o<sp->samples_per_pixel; o++)
+ sp->sos_cs[o]=o;
+ }
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecStreamDri(TIFF* tif)
+{
+ /* This could easily cause trouble in some cases... but no such cases have
+ occurred so far */
+ static const char module[]="OJPEGReadHeaderInfoSecStreamDri";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint16 m;
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ if (m!=4)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DRI marker in JPEG data");
+ return(0);
+ }
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ sp->restart_interval=m;
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecStreamDqt(TIFF* tif)
+{
+ /* this is a table marker, and it is to be saved as a whole for exact pushing on the jpeg stream later on */
+ static const char module[]="OJPEGReadHeaderInfoSecStreamDqt";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint16 m;
+ uint32 na;
+ uint8* nb;
+ uint8 o;
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ if (m<=2)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DQT marker in JPEG data");
+ return(0);
+ }
+ if (sp->subsamplingcorrect!=0)
+ OJPEGReadSkip(sp,m-2);
+ else
+ {
+ m-=2;
+ do
+ {
+ if (m<65)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DQT marker in JPEG data");
+ return(0);
+ }
+ na=sizeof(uint32)+69;
+ nb=_TIFFmalloc(na);
+ if (nb==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ *(uint32*)nb=na;
+ nb[sizeof(uint32)]=255;
+ nb[sizeof(uint32)+1]=JPEG_MARKER_DQT;
+ nb[sizeof(uint32)+2]=0;
+ nb[sizeof(uint32)+3]=67;
+ if (OJPEGReadBlock(sp,65,&nb[sizeof(uint32)+4])==0) {
+ _TIFFfree(nb);
+ return(0);
+ }
+ o=nb[sizeof(uint32)+4]&15;
+ if (3<o)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DQT marker in JPEG data");
+ _TIFFfree(nb);
+ return(0);
+ }
+ if (sp->qtable[o]!=0)
+ _TIFFfree(sp->qtable[o]);
+ sp->qtable[o]=nb;
+ m-=65;
+ } while(m>0);
+ }
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecStreamDht(TIFF* tif)
+{
+ /* this is a table marker, and it is to be saved as a whole for exact pushing on the jpeg stream later on */
+ /* TODO: the following assumes there is only one table in this marker... but i'm not quite sure that assumption is guaranteed correct */
+ static const char module[]="OJPEGReadHeaderInfoSecStreamDht";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint16 m;
+ uint32 na;
+ uint8* nb;
+ uint8 o;
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ if (m<=2)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DHT marker in JPEG data");
+ return(0);
+ }
+ if (sp->subsamplingcorrect!=0)
+ {
+ OJPEGReadSkip(sp,m-2);
+ }
+ else
+ {
+ na=sizeof(uint32)+2+m;
+ nb=_TIFFmalloc(na);
+ if (nb==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ *(uint32*)nb=na;
+ nb[sizeof(uint32)]=255;
+ nb[sizeof(uint32)+1]=JPEG_MARKER_DHT;
+ nb[sizeof(uint32)+2]=(m>>8);
+ nb[sizeof(uint32)+3]=(m&255);
+ if (OJPEGReadBlock(sp,m-2,&nb[sizeof(uint32)+4])==0) {
+ _TIFFfree(nb);
+ return(0);
+ }
+ o=nb[sizeof(uint32)+4];
+ if ((o&240)==0)
+ {
+ if (3<o)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DHT marker in JPEG data");
+ _TIFFfree(nb);
+ return(0);
+ }
+ if (sp->dctable[o]!=0)
+ _TIFFfree(sp->dctable[o]);
+ sp->dctable[o]=nb;
+ }
+ else
+ {
+ if ((o&240)!=16)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DHT marker in JPEG data");
+ _TIFFfree(nb);
+ return(0);
+ }
+ o&=15;
+ if (3<o)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt DHT marker in JPEG data");
+ _TIFFfree(nb);
+ return(0);
+ }
+ if (sp->actable[o]!=0)
+ _TIFFfree(sp->actable[o]);
+ sp->actable[o]=nb;
+ }
+ }
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecStreamSof(TIFF* tif, uint8 marker_id)
+{
+ /* this marker needs to be checked, and part of its data needs to be saved for regeneration later on */
+ static const char module[]="OJPEGReadHeaderInfoSecStreamSof";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint16 m;
+ uint16 n;
+ uint8 o;
+ uint16 p;
+ uint16 q;
+ if (sp->sof_log!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt JPEG data");
+ return(0);
+ }
+ if (sp->subsamplingcorrect==0)
+ sp->sof_marker_id=marker_id;
+ /* Lf: data length */
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ if (m<11)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOF marker in JPEG data");
+ return(0);
+ }
+ m-=8;
+ if (m%3!=0)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOF marker in JPEG data");
+ return(0);
+ }
+ n=m/3;
+ if (sp->subsamplingcorrect==0)
+ {
+ if (n!=sp->samples_per_pixel)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected number of samples");
+ return(0);
+ }
+ }
+ /* P: Sample precision */
+ if (OJPEGReadByte(sp,&o)==0)
+ return(0);
+ if (o!=8)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected number of bits per sample");
+ return(0);
+ }
+ /* Y: Number of lines, X: Number of samples per line */
+ if (sp->subsamplingcorrect)
+ OJPEGReadSkip(sp,4);
+ else
+ {
+ /* Y: Number of lines */
+ if (OJPEGReadWord(sp,&p)==0)
+ return(0);
+ if (((uint32)p<sp->image_length) && ((uint32)p<sp->strile_length_total))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected height");
+ return(0);
+ }
+ sp->sof_y=p;
+ /* X: Number of samples per line */
+ if (OJPEGReadWord(sp,&p)==0)
+ return(0);
+ if (((uint32)p<sp->image_width) && ((uint32)p<sp->strile_width))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected width");
+ return(0);
+ }
+ if ((uint32)p>sp->strile_width)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data image width exceeds expected image width");
+ return(0);
+ }
+ sp->sof_x=p;
+ }
+ /* Nf: Number of image components in frame */
+ if (OJPEGReadByte(sp,&o)==0)
+ return(0);
+ if (o!=n)
+ {
+ if (sp->subsamplingcorrect==0)
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOF marker in JPEG data");
+ return(0);
+ }
+ /* per component stuff */
+ /* TODO: double-check that flow implies that n cannot be as big as to make us overflow sof_c, sof_hv and sof_tq arrays */
+ for (q=0; q<n; q++)
+ {
+ /* C: Component identifier */
+ if (OJPEGReadByte(sp,&o)==0)
+ return(0);
+ if (sp->subsamplingcorrect==0)
+ sp->sof_c[q]=o;
+ /* H: Horizontal sampling factor, and V: Vertical sampling factor */
+ if (OJPEGReadByte(sp,&o)==0)
+ return(0);
+ if (sp->subsamplingcorrect!=0)
+ {
+ if (q==0)
+ {
+ sp->subsampling_hor=(o>>4);
+ sp->subsampling_ver=(o&15);
+ if (((sp->subsampling_hor!=1) && (sp->subsampling_hor!=2) && (sp->subsampling_hor!=4)) ||
+ ((sp->subsampling_ver!=1) && (sp->subsampling_ver!=2) && (sp->subsampling_ver!=4)))
+ sp->subsampling_force_desubsampling_inside_decompression=1;
+ }
+ else
+ {
+ if (o!=17)
+ sp->subsampling_force_desubsampling_inside_decompression=1;
+ }
+ }
+ else
+ {
+ sp->sof_hv[q]=o;
+ if (sp->subsampling_force_desubsampling_inside_decompression==0)
+ {
+ if (q==0)
+ {
+ if (o!=((sp->subsampling_hor<<4)|sp->subsampling_ver))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected subsampling values");
+ return(0);
+ }
+ }
+ else
+ {
+ if (o!=17)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"JPEG compressed data indicates unexpected subsampling values");
+ return(0);
+ }
+ }
+ }
+ }
+ /* Tq: Quantization table destination selector */
+ if (OJPEGReadByte(sp,&o)==0)
+ return(0);
+ if (sp->subsamplingcorrect==0)
+ sp->sof_tq[q]=o;
+ }
+ if (sp->subsamplingcorrect==0)
+ sp->sof_log=1;
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecStreamSos(TIFF* tif)
+{
+ /* this marker needs to be checked, and part of its data needs to be saved for regeneration later on */
+ static const char module[]="OJPEGReadHeaderInfoSecStreamSos";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint16 m;
+ uint8 n;
+ uint8 o;
+ assert(sp->subsamplingcorrect==0);
+ if (sp->sof_log==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOS marker in JPEG data");
+ return(0);
+ }
+ /* Ls */
+ if (OJPEGReadWord(sp,&m)==0)
+ return(0);
+ if (m!=6+sp->samples_per_pixel_per_plane*2)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOS marker in JPEG data");
+ return(0);
+ }
+ /* Ns */
+ if (OJPEGReadByte(sp,&n)==0)
+ return(0);
+ if (n!=sp->samples_per_pixel_per_plane)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt SOS marker in JPEG data");
+ return(0);
+ }
+ /* Cs, Td, and Ta */
+ for (o=0; o<sp->samples_per_pixel_per_plane; o++)
+ {
+ /* Cs */
+ if (OJPEGReadByte(sp,&n)==0)
+ return(0);
+ sp->sos_cs[sp->plane_sample_offset+o]=n;
+ /* Td and Ta */
+ if (OJPEGReadByte(sp,&n)==0)
+ return(0);
+ sp->sos_tda[sp->plane_sample_offset+o]=n;
+ }
+ /* skip Ss, Se, Ah, en Al -> no check, as per Tom Lane recommendation, as per LibJpeg source */
+ OJPEGReadSkip(sp,3);
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecTablesQTable(TIFF* tif)
+{
+ static const char module[]="OJPEGReadHeaderInfoSecTablesQTable";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ uint8 n;
+ uint32 oa;
+ uint8* ob;
+ uint32 p;
+ if (sp->qtable_offset[0]==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Missing JPEG tables");
+ return(0);
+ }
+ sp->in_buffer_file_pos_log=0;
+ for (m=0; m<sp->samples_per_pixel; m++)
+ {
+ if ((sp->qtable_offset[m]!=0) && ((m==0) || (sp->qtable_offset[m]!=sp->qtable_offset[m-1])))
+ {
+ for (n=0; n<m-1; n++)
+ {
+ if (sp->qtable_offset[m]==sp->qtable_offset[n])
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt JpegQTables tag value");
+ return(0);
+ }
+ }
+ oa=sizeof(uint32)+69;
+ ob=_TIFFmalloc(oa);
+ if (ob==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ *(uint32*)ob=oa;
+ ob[sizeof(uint32)]=255;
+ ob[sizeof(uint32)+1]=JPEG_MARKER_DQT;
+ ob[sizeof(uint32)+2]=0;
+ ob[sizeof(uint32)+3]=67;
+ ob[sizeof(uint32)+4]=m;
+ TIFFSeekFile(tif,sp->qtable_offset[m],SEEK_SET);
+ p=(uint32)TIFFReadFile(tif,&ob[sizeof(uint32)+5],64);
+ if (p!=64)
+ {
+ _TIFFfree(ob);
+ return(0);
+ }
+ if (sp->qtable[m]!=0)
+ _TIFFfree(sp->qtable[m]);
+ sp->qtable[m]=ob;
+ sp->sof_tq[m]=m;
+ }
+ else
+ sp->sof_tq[m]=sp->sof_tq[m-1];
+ }
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecTablesDcTable(TIFF* tif)
+{
+ static const char module[]="OJPEGReadHeaderInfoSecTablesDcTable";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ uint8 n;
+ uint8 o[16];
+ uint32 p;
+ uint32 q;
+ uint32 ra;
+ uint8* rb;
+ if (sp->dctable_offset[0]==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Missing JPEG tables");
+ return(0);
+ }
+ sp->in_buffer_file_pos_log=0;
+ for (m=0; m<sp->samples_per_pixel; m++)
+ {
+ if ((sp->dctable_offset[m]!=0) && ((m==0) || (sp->dctable_offset[m]!=sp->dctable_offset[m-1])))
+ {
+ for (n=0; n<m-1; n++)
+ {
+ if (sp->dctable_offset[m]==sp->dctable_offset[n])
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt JpegDcTables tag value");
+ return(0);
+ }
+ }
+ TIFFSeekFile(tif,sp->dctable_offset[m],SEEK_SET);
+ p=(uint32)TIFFReadFile(tif,o,16);
+ if (p!=16)
+ return(0);
+ q=0;
+ for (n=0; n<16; n++)
+ q+=o[n];
+ ra=sizeof(uint32)+21+q;
+ rb=_TIFFmalloc(ra);
+ if (rb==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ *(uint32*)rb=ra;
+ rb[sizeof(uint32)]=255;
+ rb[sizeof(uint32)+1]=JPEG_MARKER_DHT;
+ rb[sizeof(uint32)+2]=(uint8)((19+q)>>8);
+ rb[sizeof(uint32)+3]=((19+q)&255);
+ rb[sizeof(uint32)+4]=m;
+ for (n=0; n<16; n++)
+ rb[sizeof(uint32)+5+n]=o[n];
+ p=(uint32)TIFFReadFile(tif,&(rb[sizeof(uint32)+21]),q);
+ if (p!=q)
+ {
+ _TIFFfree(rb);
+ return(0);
+ }
+ if (sp->dctable[m]!=0)
+ _TIFFfree(sp->dctable[m]);
+ sp->dctable[m]=rb;
+ sp->sos_tda[m]=(m<<4);
+ }
+ else
+ sp->sos_tda[m]=sp->sos_tda[m-1];
+ }
+ return(1);
+}
+
+static int
+OJPEGReadHeaderInfoSecTablesAcTable(TIFF* tif)
+{
+ static const char module[]="OJPEGReadHeaderInfoSecTablesAcTable";
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ uint8 n;
+ uint8 o[16];
+ uint32 p;
+ uint32 q;
+ uint32 ra;
+ uint8* rb;
+ if (sp->actable_offset[0]==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Missing JPEG tables");
+ return(0);
+ }
+ sp->in_buffer_file_pos_log=0;
+ for (m=0; m<sp->samples_per_pixel; m++)
+ {
+ if ((sp->actable_offset[m]!=0) && ((m==0) || (sp->actable_offset[m]!=sp->actable_offset[m-1])))
+ {
+ for (n=0; n<m-1; n++)
+ {
+ if (sp->actable_offset[m]==sp->actable_offset[n])
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Corrupt JpegAcTables tag value");
+ return(0);
+ }
+ }
+ TIFFSeekFile(tif,sp->actable_offset[m],SEEK_SET);
+ p=(uint32)TIFFReadFile(tif,o,16);
+ if (p!=16)
+ return(0);
+ q=0;
+ for (n=0; n<16; n++)
+ q+=o[n];
+ ra=sizeof(uint32)+21+q;
+ rb=_TIFFmalloc(ra);
+ if (rb==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Out of memory");
+ return(0);
+ }
+ *(uint32*)rb=ra;
+ rb[sizeof(uint32)]=255;
+ rb[sizeof(uint32)+1]=JPEG_MARKER_DHT;
+ rb[sizeof(uint32)+2]=(uint8)((19+q)>>8);
+ rb[sizeof(uint32)+3]=((19+q)&255);
+ rb[sizeof(uint32)+4]=(16|m);
+ for (n=0; n<16; n++)
+ rb[sizeof(uint32)+5+n]=o[n];
+ p=(uint32)TIFFReadFile(tif,&(rb[sizeof(uint32)+21]),q);
+ if (p!=q)
+ {
+ _TIFFfree(rb);
+ return(0);
+ }
+ if (sp->actable[m]!=0)
+ _TIFFfree(sp->actable[m]);
+ sp->actable[m]=rb;
+ sp->sos_tda[m]=(sp->sos_tda[m]|m);
+ }
+ else
+ sp->sos_tda[m]=(sp->sos_tda[m]|(sp->sos_tda[m-1]&15));
+ }
+ return(1);
+}
+
+static int
+OJPEGReadBufferFill(OJPEGState* sp)
+{
+ uint16 m;
+ tmsize_t n;
+ /* TODO: double-check: when subsamplingcorrect is set, no call to TIFFErrorExt or TIFFWarningExt should be made
+ * in any other case, seek or read errors should be passed through */
+ do
+ {
+ if (sp->in_buffer_file_togo!=0)
+ {
+ if (sp->in_buffer_file_pos_log==0)
+ {
+ TIFFSeekFile(sp->tif,sp->in_buffer_file_pos,SEEK_SET);
+ sp->in_buffer_file_pos_log=1;
+ }
+ m=OJPEG_BUFFER;
+ if ((uint64)m>sp->in_buffer_file_togo)
+ m=(uint16)sp->in_buffer_file_togo;
+ n=TIFFReadFile(sp->tif,sp->in_buffer,(tmsize_t)m);
+ if (n==0)
+ return(0);
+ assert(n>0);
+ assert(n<=OJPEG_BUFFER);
+ assert(n<65536);
+ assert((uint64)n<=sp->in_buffer_file_togo);
+ m=(uint16)n;
+ sp->in_buffer_togo=m;
+ sp->in_buffer_cur=sp->in_buffer;
+ sp->in_buffer_file_togo-=m;
+ sp->in_buffer_file_pos+=m;
+ break;
+ }
+ sp->in_buffer_file_pos_log=0;
+ switch(sp->in_buffer_source)
+ {
+ case osibsNotSetYet:
+ if (sp->jpeg_interchange_format!=0)
+ {
+ sp->in_buffer_file_pos=sp->jpeg_interchange_format;
+ sp->in_buffer_file_togo=sp->jpeg_interchange_format_length;
+ }
+ sp->in_buffer_source=osibsJpegInterchangeFormat;
+ break;
+ case osibsJpegInterchangeFormat:
+ sp->in_buffer_source=osibsStrile;
+ break;
+ case osibsStrile:
+ if (!_TIFFFillStriles( sp->tif )
+ || sp->tif->tif_dir.td_stripoffset == NULL
+ || sp->tif->tif_dir.td_stripbytecount == NULL)
+ return 0;
+
+ if (sp->in_buffer_next_strile==sp->in_buffer_strile_count)
+ sp->in_buffer_source=osibsEof;
+ else
+ {
+ sp->in_buffer_file_pos=sp->tif->tif_dir.td_stripoffset[sp->in_buffer_next_strile];
+ if (sp->in_buffer_file_pos!=0)
+ {
+ if (sp->in_buffer_file_pos>=sp->file_size)
+ sp->in_buffer_file_pos=0;
+ else if (sp->tif->tif_dir.td_stripbytecount==NULL)
+ sp->in_buffer_file_togo=sp->file_size-sp->in_buffer_file_pos;
+ else
+ {
+ if (sp->tif->tif_dir.td_stripbytecount == 0) {
+ TIFFErrorExt(sp->tif->tif_clientdata,sp->tif->tif_name,"Strip byte counts are missing");
+ return(0);
+ }
+ sp->in_buffer_file_togo=sp->tif->tif_dir.td_stripbytecount[sp->in_buffer_next_strile];
+ if (sp->in_buffer_file_togo==0)
+ sp->in_buffer_file_pos=0;
+ else if (sp->in_buffer_file_pos+sp->in_buffer_file_togo>sp->file_size)
+ sp->in_buffer_file_togo=sp->file_size-sp->in_buffer_file_pos;
+ }
+ }
+ sp->in_buffer_next_strile++;
+ }
+ break;
+ default:
+ return(0);
+ }
+ } while (1);
+ return(1);
+}
+
+static int
+OJPEGReadByte(OJPEGState* sp, uint8* byte)
+{
+ if (sp->in_buffer_togo==0)
+ {
+ if (OJPEGReadBufferFill(sp)==0)
+ return(0);
+ assert(sp->in_buffer_togo>0);
+ }
+ *byte=*(sp->in_buffer_cur);
+ sp->in_buffer_cur++;
+ sp->in_buffer_togo--;
+ return(1);
+}
+
+static int
+OJPEGReadBytePeek(OJPEGState* sp, uint8* byte)
+{
+ if (sp->in_buffer_togo==0)
+ {
+ if (OJPEGReadBufferFill(sp)==0)
+ return(0);
+ assert(sp->in_buffer_togo>0);
+ }
+ *byte=*(sp->in_buffer_cur);
+ return(1);
+}
+
+static void
+OJPEGReadByteAdvance(OJPEGState* sp)
+{
+ assert(sp->in_buffer_togo>0);
+ sp->in_buffer_cur++;
+ sp->in_buffer_togo--;
+}
+
+static int
+OJPEGReadWord(OJPEGState* sp, uint16* word)
+{
+ uint8 m;
+ if (OJPEGReadByte(sp,&m)==0)
+ return(0);
+ *word=(m<<8);
+ if (OJPEGReadByte(sp,&m)==0)
+ return(0);
+ *word|=m;
+ return(1);
+}
+
+static int
+OJPEGReadBlock(OJPEGState* sp, uint16 len, void* mem)
+{
+ uint16 mlen;
+ uint8* mmem;
+ uint16 n;
+ assert(len>0);
+ mlen=len;
+ mmem=mem;
+ do
+ {
+ if (sp->in_buffer_togo==0)
+ {
+ if (OJPEGReadBufferFill(sp)==0)
+ return(0);
+ assert(sp->in_buffer_togo>0);
+ }
+ n=mlen;
+ if (n>sp->in_buffer_togo)
+ n=sp->in_buffer_togo;
+ _TIFFmemcpy(mmem,sp->in_buffer_cur,n);
+ sp->in_buffer_cur+=n;
+ sp->in_buffer_togo-=n;
+ mlen-=n;
+ mmem+=n;
+ } while(mlen>0);
+ return(1);
+}
+
+static void
+OJPEGReadSkip(OJPEGState* sp, uint16 len)
+{
+ uint16 m;
+ uint16 n;
+ m=len;
+ n=m;
+ if (n>sp->in_buffer_togo)
+ n=sp->in_buffer_togo;
+ sp->in_buffer_cur+=n;
+ sp->in_buffer_togo-=n;
+ m-=n;
+ if (m>0)
+ {
+ assert(sp->in_buffer_togo==0);
+ n=m;
+ if ((uint64)n>sp->in_buffer_file_togo)
+ n=(uint16)sp->in_buffer_file_togo;
+ sp->in_buffer_file_pos+=n;
+ sp->in_buffer_file_togo-=n;
+ sp->in_buffer_file_pos_log=0;
+ /* we don't skip past jpeginterchangeformat/strile block...
+ * if that is asked from us, we're dealing with totally bazurk
+ * data anyway, and we've not seen this happening on any
+ * testfile, so we might as well likely cause some other
+ * meaningless error to be passed at some later time
+ */
+ }
+}
+
+static int
+OJPEGWriteStream(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ *len=0;
+ do
+ {
+ assert(sp->out_state<=ososEoi);
+ switch(sp->out_state)
+ {
+ case ososSoi:
+ OJPEGWriteStreamSoi(tif,mem,len);
+ break;
+ case ososQTable0:
+ OJPEGWriteStreamQTable(tif,0,mem,len);
+ break;
+ case ososQTable1:
+ OJPEGWriteStreamQTable(tif,1,mem,len);
+ break;
+ case ososQTable2:
+ OJPEGWriteStreamQTable(tif,2,mem,len);
+ break;
+ case ososQTable3:
+ OJPEGWriteStreamQTable(tif,3,mem,len);
+ break;
+ case ososDcTable0:
+ OJPEGWriteStreamDcTable(tif,0,mem,len);
+ break;
+ case ososDcTable1:
+ OJPEGWriteStreamDcTable(tif,1,mem,len);
+ break;
+ case ososDcTable2:
+ OJPEGWriteStreamDcTable(tif,2,mem,len);
+ break;
+ case ososDcTable3:
+ OJPEGWriteStreamDcTable(tif,3,mem,len);
+ break;
+ case ososAcTable0:
+ OJPEGWriteStreamAcTable(tif,0,mem,len);
+ break;
+ case ososAcTable1:
+ OJPEGWriteStreamAcTable(tif,1,mem,len);
+ break;
+ case ososAcTable2:
+ OJPEGWriteStreamAcTable(tif,2,mem,len);
+ break;
+ case ososAcTable3:
+ OJPEGWriteStreamAcTable(tif,3,mem,len);
+ break;
+ case ososDri:
+ OJPEGWriteStreamDri(tif,mem,len);
+ break;
+ case ososSof:
+ OJPEGWriteStreamSof(tif,mem,len);
+ break;
+ case ososSos:
+ OJPEGWriteStreamSos(tif,mem,len);
+ break;
+ case ososCompressed:
+ if (OJPEGWriteStreamCompressed(tif,mem,len)==0)
+ return(0);
+ break;
+ case ososRst:
+ OJPEGWriteStreamRst(tif,mem,len);
+ break;
+ case ososEoi:
+ OJPEGWriteStreamEoi(tif,mem,len);
+ break;
+ }
+ } while (*len==0);
+ return(1);
+}
+
+static void
+OJPEGWriteStreamSoi(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(OJPEG_BUFFER>=2);
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=JPEG_MARKER_SOI;
+ *len=2;
+ *mem=(void*)sp->out_buffer;
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamQTable(TIFF* tif, uint8 table_index, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ if (sp->qtable[table_index]!=0)
+ {
+ *mem=(void*)(sp->qtable[table_index]+sizeof(uint32));
+ *len=*((uint32*)sp->qtable[table_index])-sizeof(uint32);
+ }
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamDcTable(TIFF* tif, uint8 table_index, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ if (sp->dctable[table_index]!=0)
+ {
+ *mem=(void*)(sp->dctable[table_index]+sizeof(uint32));
+ *len=*((uint32*)sp->dctable[table_index])-sizeof(uint32);
+ }
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamAcTable(TIFF* tif, uint8 table_index, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ if (sp->actable[table_index]!=0)
+ {
+ *mem=(void*)(sp->actable[table_index]+sizeof(uint32));
+ *len=*((uint32*)sp->actable[table_index])-sizeof(uint32);
+ }
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamDri(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(OJPEG_BUFFER>=6);
+ if (sp->restart_interval!=0)
+ {
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=JPEG_MARKER_DRI;
+ sp->out_buffer[2]=0;
+ sp->out_buffer[3]=4;
+ sp->out_buffer[4]=(sp->restart_interval>>8);
+ sp->out_buffer[5]=(sp->restart_interval&255);
+ *len=6;
+ *mem=(void*)sp->out_buffer;
+ }
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamSof(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ assert(OJPEG_BUFFER>=2+8+sp->samples_per_pixel_per_plane*3);
+ assert(255>=8+sp->samples_per_pixel_per_plane*3);
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=sp->sof_marker_id;
+ /* Lf */
+ sp->out_buffer[2]=0;
+ sp->out_buffer[3]=8+sp->samples_per_pixel_per_plane*3;
+ /* P */
+ sp->out_buffer[4]=8;
+ /* Y */
+ sp->out_buffer[5]=(uint8)(sp->sof_y>>8);
+ sp->out_buffer[6]=(sp->sof_y&255);
+ /* X */
+ sp->out_buffer[7]=(uint8)(sp->sof_x>>8);
+ sp->out_buffer[8]=(sp->sof_x&255);
+ /* Nf */
+ sp->out_buffer[9]=sp->samples_per_pixel_per_plane;
+ for (m=0; m<sp->samples_per_pixel_per_plane; m++)
+ {
+ /* C */
+ sp->out_buffer[10+m*3]=sp->sof_c[sp->plane_sample_offset+m];
+ /* H and V */
+ sp->out_buffer[10+m*3+1]=sp->sof_hv[sp->plane_sample_offset+m];
+ /* Tq */
+ sp->out_buffer[10+m*3+2]=sp->sof_tq[sp->plane_sample_offset+m];
+ }
+ *len=10+sp->samples_per_pixel_per_plane*3;
+ *mem=(void*)sp->out_buffer;
+ sp->out_state++;
+}
+
+static void
+OJPEGWriteStreamSos(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ uint8 m;
+ assert(OJPEG_BUFFER>=2+6+sp->samples_per_pixel_per_plane*2);
+ assert(255>=6+sp->samples_per_pixel_per_plane*2);
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=JPEG_MARKER_SOS;
+ /* Ls */
+ sp->out_buffer[2]=0;
+ sp->out_buffer[3]=6+sp->samples_per_pixel_per_plane*2;
+ /* Ns */
+ sp->out_buffer[4]=sp->samples_per_pixel_per_plane;
+ for (m=0; m<sp->samples_per_pixel_per_plane; m++)
+ {
+ /* Cs */
+ sp->out_buffer[5+m*2]=sp->sos_cs[sp->plane_sample_offset+m];
+ /* Td and Ta */
+ sp->out_buffer[5+m*2+1]=sp->sos_tda[sp->plane_sample_offset+m];
+ }
+ /* Ss */
+ sp->out_buffer[5+sp->samples_per_pixel_per_plane*2]=0;
+ /* Se */
+ sp->out_buffer[5+sp->samples_per_pixel_per_plane*2+1]=63;
+ /* Ah and Al */
+ sp->out_buffer[5+sp->samples_per_pixel_per_plane*2+2]=0;
+ *len=8+sp->samples_per_pixel_per_plane*2;
+ *mem=(void*)sp->out_buffer;
+ sp->out_state++;
+}
+
+static int
+OJPEGWriteStreamCompressed(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ if (sp->in_buffer_togo==0)
+ {
+ if (OJPEGReadBufferFill(sp)==0)
+ return(0);
+ assert(sp->in_buffer_togo>0);
+ }
+ *len=sp->in_buffer_togo;
+ *mem=(void*)sp->in_buffer_cur;
+ sp->in_buffer_togo=0;
+ if (sp->in_buffer_file_togo==0)
+ {
+ switch(sp->in_buffer_source)
+ {
+ case osibsStrile:
+ if (sp->in_buffer_next_strile<sp->in_buffer_strile_count)
+ sp->out_state=ososRst;
+ else
+ sp->out_state=ososEoi;
+ break;
+ case osibsEof:
+ sp->out_state=ososEoi;
+ break;
+ default:
+ break;
+ }
+ }
+ return(1);
+}
+
+static void
+OJPEGWriteStreamRst(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(OJPEG_BUFFER>=2);
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=JPEG_MARKER_RST0+sp->restart_index;
+ sp->restart_index++;
+ if (sp->restart_index==8)
+ sp->restart_index=0;
+ *len=2;
+ *mem=(void*)sp->out_buffer;
+ sp->out_state=ososCompressed;
+}
+
+static void
+OJPEGWriteStreamEoi(TIFF* tif, void** mem, uint32* len)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ assert(OJPEG_BUFFER>=2);
+ sp->out_buffer[0]=255;
+ sp->out_buffer[1]=JPEG_MARKER_EOI;
+ *len=2;
+ *mem=(void*)sp->out_buffer;
+}
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static int
+jpeg_create_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo)
+{
+ if( SETJMP(sp->exit_jmpbuf) )
+ return 0;
+ else {
+ jpeg_create_decompress(cinfo);
+ return 1;
+ }
+}
+#endif
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static int
+jpeg_read_header_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, uint8 require_image)
+{
+ if( SETJMP(sp->exit_jmpbuf) )
+ return 0;
+ else {
+ jpeg_read_header(cinfo,require_image);
+ return 1;
+ }
+}
+#endif
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static int
+jpeg_start_decompress_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo)
+{
+ if( SETJMP(sp->exit_jmpbuf) )
+ return 0;
+ else {
+ jpeg_start_decompress(cinfo);
+ return 1;
+ }
+}
+#endif
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static int
+jpeg_read_scanlines_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* scanlines, uint32 max_lines)
+{
+ if( SETJMP(sp->exit_jmpbuf) )
+ return 0;
+ else {
+ jpeg_read_scanlines(cinfo,scanlines,max_lines);
+ return 1;
+ }
+}
+#endif
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static int
+jpeg_read_raw_data_encap(OJPEGState* sp, jpeg_decompress_struct* cinfo, void* data, uint32 max_lines)
+{
+ if( SETJMP(sp->exit_jmpbuf) )
+ return 0;
+ else {
+ jpeg_read_raw_data(cinfo,data,max_lines);
+ return 1;
+ }
+}
+#endif
+
+#ifndef LIBJPEG_ENCAP_EXTERNAL
+static void
+jpeg_encap_unwind(TIFF* tif)
+{
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ LONGJMP(sp->exit_jmpbuf,1);
+}
+#endif
+
+static void
+OJPEGLibjpegJpegErrorMgrOutputMessage(jpeg_common_struct* cinfo)
+{
+ char buffer[JMSG_LENGTH_MAX];
+ (*cinfo->err->format_message)(cinfo,buffer);
+ TIFFWarningExt(((TIFF*)(cinfo->client_data))->tif_clientdata,"LibJpeg","%s",buffer);
+}
+
+static void
+OJPEGLibjpegJpegErrorMgrErrorExit(jpeg_common_struct* cinfo)
+{
+ char buffer[JMSG_LENGTH_MAX];
+ (*cinfo->err->format_message)(cinfo,buffer);
+ TIFFErrorExt(((TIFF*)(cinfo->client_data))->tif_clientdata,"LibJpeg","%s",buffer);
+ jpeg_encap_unwind((TIFF*)(cinfo->client_data));
+}
+
+static void
+OJPEGLibjpegJpegSourceMgrInitSource(jpeg_decompress_struct* cinfo)
+{
+ (void)cinfo;
+}
+
+static boolean
+OJPEGLibjpegJpegSourceMgrFillInputBuffer(jpeg_decompress_struct* cinfo)
+{
+ TIFF* tif=(TIFF*)cinfo->client_data;
+ OJPEGState* sp=(OJPEGState*)tif->tif_data;
+ void* mem=0;
+ uint32 len=0U;
+ if (OJPEGWriteStream(tif,&mem,&len)==0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,"LibJpeg","Premature end of JPEG data");
+ jpeg_encap_unwind(tif);
+ }
+ sp->libjpeg_jpeg_source_mgr.bytes_in_buffer=len;
+ sp->libjpeg_jpeg_source_mgr.next_input_byte=mem;
+ return(1);
+}
+
+static void
+OJPEGLibjpegJpegSourceMgrSkipInputData(jpeg_decompress_struct* cinfo, long num_bytes)
+{
+ TIFF* tif=(TIFF*)cinfo->client_data;
+ (void)num_bytes;
+ TIFFErrorExt(tif->tif_clientdata,"LibJpeg","Unexpected error");
+ jpeg_encap_unwind(tif);
+}
+
+#ifdef _MSC_VER
+#pragma warning( push )
+#pragma warning( disable : 4702 ) /* unreachable code */
+#endif
+static boolean
+OJPEGLibjpegJpegSourceMgrResyncToRestart(jpeg_decompress_struct* cinfo, int desired)
+{
+ TIFF* tif=(TIFF*)cinfo->client_data;
+ (void)desired;
+ TIFFErrorExt(tif->tif_clientdata,"LibJpeg","Unexpected error");
+ jpeg_encap_unwind(tif);
+ return(0);
+}
+#ifdef _MSC_VER
+#pragma warning( pop )
+#endif
+
+static void
+OJPEGLibjpegJpegSourceMgrTermSource(jpeg_decompress_struct* cinfo)
+{
+ (void)cinfo;
+}
+
+#endif
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_open.c b/test/monniaux/tiff-4.0.10/tif_open.c
new file mode 100644
index 00000000..c574c452
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_open.c
@@ -0,0 +1,723 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ */
+#include "tiffiop.h"
+
+/*
+ * Dummy functions to fill the omitted client procedures.
+ */
+static int
+_tiffDummyMapProc(thandle_t fd, void** pbase, toff_t* psize)
+{
+ (void) fd; (void) pbase; (void) psize;
+ return (0);
+}
+
+static void
+_tiffDummyUnmapProc(thandle_t fd, void* base, toff_t size)
+{
+ (void) fd; (void) base; (void) size;
+}
+
+int
+_TIFFgetMode(const char* mode, const char* module)
+{
+ int m = -1;
+
+ switch (mode[0]) {
+ case 'r':
+ m = O_RDONLY;
+ if (mode[1] == '+')
+ m = O_RDWR;
+ break;
+ case 'w':
+ case 'a':
+ m = O_RDWR|O_CREAT;
+ if (mode[0] == 'w')
+ m |= O_TRUNC;
+ break;
+ default:
+ TIFFErrorExt(0, module, "\"%s\": Bad mode", mode);
+ break;
+ }
+ return (m);
+}
+
+TIFF*
+TIFFClientOpen(
+ const char* name, const char* mode,
+ thandle_t clientdata,
+ TIFFReadWriteProc readproc,
+ TIFFReadWriteProc writeproc,
+ TIFFSeekProc seekproc,
+ TIFFCloseProc closeproc,
+ TIFFSizeProc sizeproc,
+ TIFFMapFileProc mapproc,
+ TIFFUnmapFileProc unmapproc
+)
+{
+ static const char module[] = "TIFFClientOpen";
+ TIFF *tif;
+ int m;
+ const char* cp;
+
+ /* The following are configuration checks. They should be redundant, but should not
+ * compile to any actual code in an optimised release build anyway. If any of them
+ * fail, (makefile-based or other) configuration is not correct */
+ assert(sizeof(uint8)==1);
+ assert(sizeof(int8)==1);
+ assert(sizeof(uint16)==2);
+ assert(sizeof(int16)==2);
+ assert(sizeof(uint32)==4);
+ assert(sizeof(int32)==4);
+ assert(sizeof(uint64)==8);
+ assert(sizeof(int64)==8);
+ assert(sizeof(tmsize_t)==sizeof(void*));
+ {
+ union{
+ uint8 a8[2];
+ uint16 a16;
+ } n;
+ n.a8[0]=1;
+ n.a8[1]=0;
+ #ifdef WORDS_BIGENDIAN
+ assert(n.a16==256);
+ #else
+ assert(n.a16==1);
+ #endif
+ }
+
+ m = _TIFFgetMode(mode, module);
+ if (m == -1)
+ goto bad2;
+ tif = (TIFF *)_TIFFmalloc((tmsize_t)(sizeof (TIFF) + strlen(name) + 1));
+ if (tif == NULL) {
+ TIFFErrorExt(clientdata, module, "%s: Out of memory (TIFF structure)", name);
+ goto bad2;
+ }
+ _TIFFmemset(tif, 0, sizeof (*tif));
+ tif->tif_name = (char *)tif + sizeof (TIFF);
+ strcpy(tif->tif_name, name);
+ tif->tif_mode = m &~ (O_CREAT|O_TRUNC);
+ tif->tif_curdir = (uint16) -1; /* non-existent directory */
+ tif->tif_curoff = 0;
+ tif->tif_curstrip = (uint32) -1; /* invalid strip */
+ tif->tif_row = (uint32) -1; /* read/write pre-increment */
+ tif->tif_clientdata = clientdata;
+ if (!readproc || !writeproc || !seekproc || !closeproc || !sizeproc) {
+ TIFFErrorExt(clientdata, module,
+ "One of the client procedures is NULL pointer.");
+ goto bad2;
+ }
+ tif->tif_readproc = readproc;
+ tif->tif_writeproc = writeproc;
+ tif->tif_seekproc = seekproc;
+ tif->tif_closeproc = closeproc;
+ tif->tif_sizeproc = sizeproc;
+ if (mapproc)
+ tif->tif_mapproc = mapproc;
+ else
+ tif->tif_mapproc = _tiffDummyMapProc;
+ if (unmapproc)
+ tif->tif_unmapproc = unmapproc;
+ else
+ tif->tif_unmapproc = _tiffDummyUnmapProc;
+ _TIFFSetDefaultCompressionState(tif); /* setup default state */
+ /*
+ * Default is to return data MSB2LSB and enable the
+ * use of memory-mapped files and strip chopping when
+ * a file is opened read-only.
+ */
+ tif->tif_flags = FILLORDER_MSB2LSB;
+ if (m == O_RDONLY )
+ tif->tif_flags |= TIFF_MAPPED;
+
+ #ifdef STRIPCHOP_DEFAULT
+ if (m == O_RDONLY || m == O_RDWR)
+ tif->tif_flags |= STRIPCHOP_DEFAULT;
+ #endif
+
+ /*
+ * Process library-specific flags in the open mode string.
+ * The following flags may be used to control intrinsic library
+ * behaviour that may or may not be desirable (usually for
+ * compatibility with some application that claims to support
+ * TIFF but only supports some brain dead idea of what the
+ * vendor thinks TIFF is):
+ *
+ * 'l' use little-endian byte order for creating a file
+ * 'b' use big-endian byte order for creating a file
+ * 'L' read/write information using LSB2MSB bit order
+ * 'B' read/write information using MSB2LSB bit order
+ * 'H' read/write information using host bit order
+ * 'M' enable use of memory-mapped files when supported
+ * 'm' disable use of memory-mapped files
+ * 'C' enable strip chopping support when reading
+ * 'c' disable strip chopping support
+ * 'h' read TIFF header only, do not load the first IFD
+ * '4' ClassicTIFF for creating a file (default)
+ * '8' BigTIFF for creating a file
+ *
+ * The use of the 'l' and 'b' flags is strongly discouraged.
+ * These flags are provided solely because numerous vendors,
+ * typically on the PC, do not correctly support TIFF; they
+ * only support the Intel little-endian byte order. This
+ * support is not configured by default because it supports
+ * the violation of the TIFF spec that says that readers *MUST*
+ * support both byte orders. It is strongly recommended that
+ * you not use this feature except to deal with busted apps
+ * that write invalid TIFF. And even in those cases you should
+ * bang on the vendors to fix their software.
+ *
+ * The 'L', 'B', and 'H' flags are intended for applications
+ * that can optimize operations on data by using a particular
+ * bit order. By default the library returns data in MSB2LSB
+ * bit order for compatibility with older versions of this
+ * library. Returning data in the bit order of the native CPU
+ * makes the most sense but also requires applications to check
+ * the value of the FillOrder tag; something they probably do
+ * not do right now.
+ *
+ * The 'M' and 'm' flags are provided because some virtual memory
+ * systems exhibit poor behaviour when large images are mapped.
+ * These options permit clients to control the use of memory-mapped
+ * files on a per-file basis.
+ *
+ * The 'C' and 'c' flags are provided because the library support
+ * for chopping up large strips into multiple smaller strips is not
+ * application-transparent and as such can cause problems. The 'c'
+ * option permits applications that only want to look at the tags,
+ * for example, to get the unadulterated TIFF tag information.
+ */
+ for (cp = mode; *cp; cp++)
+ switch (*cp) {
+ case 'b':
+ #ifndef WORDS_BIGENDIAN
+ if (m&O_CREAT)
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ break;
+ case 'l':
+ #ifdef WORDS_BIGENDIAN
+ if ((m&O_CREAT))
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ break;
+ case 'B':
+ tif->tif_flags = (tif->tif_flags &~ TIFF_FILLORDER) |
+ FILLORDER_MSB2LSB;
+ break;
+ case 'L':
+ tif->tif_flags = (tif->tif_flags &~ TIFF_FILLORDER) |
+ FILLORDER_LSB2MSB;
+ break;
+ case 'H':
+ tif->tif_flags = (tif->tif_flags &~ TIFF_FILLORDER) |
+ HOST_FILLORDER;
+ break;
+ case 'M':
+ if (m == O_RDONLY)
+ tif->tif_flags |= TIFF_MAPPED;
+ break;
+ case 'm':
+ if (m == O_RDONLY)
+ tif->tif_flags &= ~TIFF_MAPPED;
+ break;
+ case 'C':
+ if (m == O_RDONLY)
+ tif->tif_flags |= TIFF_STRIPCHOP;
+ break;
+ case 'c':
+ if (m == O_RDONLY)
+ tif->tif_flags &= ~TIFF_STRIPCHOP;
+ break;
+ case 'h':
+ tif->tif_flags |= TIFF_HEADERONLY;
+ break;
+ case '8':
+ if (m&O_CREAT)
+ tif->tif_flags |= TIFF_BIGTIFF;
+ break;
+ }
+ /*
+ * Read in TIFF header.
+ */
+ if ((m & O_TRUNC) ||
+ !ReadOK(tif, &tif->tif_header, sizeof (TIFFHeaderClassic))) {
+ if (tif->tif_mode == O_RDONLY) {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Cannot read TIFF header");
+ goto bad;
+ }
+ /*
+ * Setup header and write.
+ */
+ #ifdef WORDS_BIGENDIAN
+ tif->tif_header.common.tiff_magic = (tif->tif_flags & TIFF_SWAB)
+ ? TIFF_LITTLEENDIAN : TIFF_BIGENDIAN;
+ #else
+ tif->tif_header.common.tiff_magic = (tif->tif_flags & TIFF_SWAB)
+ ? TIFF_BIGENDIAN : TIFF_LITTLEENDIAN;
+ #endif
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ {
+ tif->tif_header.common.tiff_version = TIFF_VERSION_CLASSIC;
+ tif->tif_header.classic.tiff_diroff = 0;
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&tif->tif_header.common.tiff_version);
+ tif->tif_header_size = sizeof(TIFFHeaderClassic);
+ }
+ else
+ {
+ tif->tif_header.common.tiff_version = TIFF_VERSION_BIG;
+ tif->tif_header.big.tiff_offsetsize = 8;
+ tif->tif_header.big.tiff_unused = 0;
+ tif->tif_header.big.tiff_diroff = 0;
+ if (tif->tif_flags & TIFF_SWAB)
+ {
+ TIFFSwabShort(&tif->tif_header.common.tiff_version);
+ TIFFSwabShort(&tif->tif_header.big.tiff_offsetsize);
+ }
+ tif->tif_header_size = sizeof (TIFFHeaderBig);
+ }
+ /*
+ * The doc for "fopen" for some STD_C_LIBs says that if you
+ * open a file for modify ("+"), then you must fseek (or
+ * fflush?) between any freads and fwrites. This is not
+ * necessary on most systems, but has been shown to be needed
+ * on Solaris.
+ */
+ TIFFSeekFile( tif, 0, SEEK_SET );
+ if (!WriteOK(tif, &tif->tif_header, (tmsize_t)(tif->tif_header_size))) {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Error writing TIFF header");
+ goto bad;
+ }
+ /*
+ * Setup the byte order handling.
+ */
+ if (tif->tif_header.common.tiff_magic == TIFF_BIGENDIAN) {
+ #ifndef WORDS_BIGENDIAN
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ } else {
+ #ifdef WORDS_BIGENDIAN
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ }
+ /*
+ * Setup default directory.
+ */
+ if (!TIFFDefaultDirectory(tif))
+ goto bad;
+ tif->tif_diroff = 0;
+ tif->tif_dirlist = NULL;
+ tif->tif_dirlistsize = 0;
+ tif->tif_dirnumber = 0;
+ return (tif);
+ }
+ /*
+ * Setup the byte order handling.
+ */
+ if (tif->tif_header.common.tiff_magic != TIFF_BIGENDIAN &&
+ tif->tif_header.common.tiff_magic != TIFF_LITTLEENDIAN
+ #if MDI_SUPPORT
+ &&
+ #if HOST_BIGENDIAN
+ tif->tif_header.common.tiff_magic != MDI_BIGENDIAN
+ #else
+ tif->tif_header.common.tiff_magic != MDI_LITTLEENDIAN
+ #endif
+ ) {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Not a TIFF or MDI file, bad magic number %d (0x%x)",
+ #else
+ ) {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Not a TIFF file, bad magic number %d (0x%x)",
+ #endif
+ tif->tif_header.common.tiff_magic,
+ tif->tif_header.common.tiff_magic);
+ goto bad;
+ }
+ if (tif->tif_header.common.tiff_magic == TIFF_BIGENDIAN) {
+ #ifndef WORDS_BIGENDIAN
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ } else {
+ #ifdef WORDS_BIGENDIAN
+ tif->tif_flags |= TIFF_SWAB;
+ #endif
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabShort(&tif->tif_header.common.tiff_version);
+ if ((tif->tif_header.common.tiff_version != TIFF_VERSION_CLASSIC)&&
+ (tif->tif_header.common.tiff_version != TIFF_VERSION_BIG)) {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Not a TIFF file, bad version number %d (0x%x)",
+ tif->tif_header.common.tiff_version,
+ tif->tif_header.common.tiff_version);
+ goto bad;
+ }
+ if (tif->tif_header.common.tiff_version == TIFF_VERSION_CLASSIC)
+ {
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabLong(&tif->tif_header.classic.tiff_diroff);
+ tif->tif_header_size = sizeof(TIFFHeaderClassic);
+ }
+ else
+ {
+ if (!ReadOK(tif, ((uint8*)(&tif->tif_header) + sizeof(TIFFHeaderClassic)), (sizeof(TIFFHeaderBig)-sizeof(TIFFHeaderClassic))))
+ {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Cannot read TIFF header");
+ goto bad;
+ }
+ if (tif->tif_flags & TIFF_SWAB)
+ {
+ TIFFSwabShort(&tif->tif_header.big.tiff_offsetsize);
+ TIFFSwabLong8(&tif->tif_header.big.tiff_diroff);
+ }
+ if (tif->tif_header.big.tiff_offsetsize != 8)
+ {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Not a TIFF file, bad BigTIFF offsetsize %d (0x%x)",
+ tif->tif_header.big.tiff_offsetsize,
+ tif->tif_header.big.tiff_offsetsize);
+ goto bad;
+ }
+ if (tif->tif_header.big.tiff_unused != 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, name,
+ "Not a TIFF file, bad BigTIFF unused %d (0x%x)",
+ tif->tif_header.big.tiff_unused,
+ tif->tif_header.big.tiff_unused);
+ goto bad;
+ }
+ tif->tif_header_size = sizeof(TIFFHeaderBig);
+ tif->tif_flags |= TIFF_BIGTIFF;
+ }
+ tif->tif_flags |= TIFF_MYBUFFER;
+ tif->tif_rawcp = tif->tif_rawdata = 0;
+ tif->tif_rawdatasize = 0;
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = 0;
+
+ switch (mode[0]) {
+ case 'r':
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ tif->tif_nextdiroff = tif->tif_header.classic.tiff_diroff;
+ else
+ tif->tif_nextdiroff = tif->tif_header.big.tiff_diroff;
+ /*
+ * Try to use a memory-mapped file if the client
+ * has not explicitly suppressed usage with the
+ * 'm' flag in the open mode (see above).
+ */
+ if (tif->tif_flags & TIFF_MAPPED)
+ {
+ toff_t n;
+ if (TIFFMapFileContents(tif,(void**)(&tif->tif_base),&n))
+ {
+ tif->tif_size=(tmsize_t)n;
+ assert((toff_t)tif->tif_size==n);
+ }
+ else
+ tif->tif_flags &= ~TIFF_MAPPED;
+ }
+ /*
+ * Sometimes we do not want to read the first directory (for example,
+ * it may be broken) and want to proceed to other directories. I this
+ * case we use the TIFF_HEADERONLY flag to open file and return
+ * immediately after reading TIFF header.
+ */
+ if (tif->tif_flags & TIFF_HEADERONLY)
+ return (tif);
+
+ /*
+ * Setup initial directory.
+ */
+ if (TIFFReadDirectory(tif)) {
+ tif->tif_rawcc = (tmsize_t)-1;
+ tif->tif_flags |= TIFF_BUFFERSETUP;
+ return (tif);
+ }
+ break;
+ case 'a':
+ /*
+ * New directories are automatically append
+ * to the end of the directory chain when they
+ * are written out (see TIFFWriteDirectory).
+ */
+ if (!TIFFDefaultDirectory(tif))
+ goto bad;
+ return (tif);
+ }
+bad:
+ tif->tif_mode = O_RDONLY; /* XXX avoid flush */
+ TIFFCleanup(tif);
+bad2:
+ return ((TIFF*)0);
+}
+
+/*
+ * Query functions to access private data.
+ */
+
+/*
+ * Return open file's name.
+ */
+const char *
+TIFFFileName(TIFF* tif)
+{
+ return (tif->tif_name);
+}
+
+/*
+ * Set the file name.
+ */
+const char *
+TIFFSetFileName(TIFF* tif, const char *name)
+{
+ const char* old_name = tif->tif_name;
+ tif->tif_name = (char *)name;
+ return (old_name);
+}
+
+/*
+ * Return open file's I/O descriptor.
+ */
+int
+TIFFFileno(TIFF* tif)
+{
+ return (tif->tif_fd);
+}
+
+/*
+ * Set open file's I/O descriptor, and return previous value.
+ */
+int
+TIFFSetFileno(TIFF* tif, int fd)
+{
+ int old_fd = tif->tif_fd;
+ tif->tif_fd = fd;
+ return old_fd;
+}
+
+/*
+ * Return open file's clientdata.
+ */
+thandle_t
+TIFFClientdata(TIFF* tif)
+{
+ return (tif->tif_clientdata);
+}
+
+/*
+ * Set open file's clientdata, and return previous value.
+ */
+thandle_t
+TIFFSetClientdata(TIFF* tif, thandle_t newvalue)
+{
+ thandle_t m = tif->tif_clientdata;
+ tif->tif_clientdata = newvalue;
+ return m;
+}
+
+/*
+ * Return read/write mode.
+ */
+int
+TIFFGetMode(TIFF* tif)
+{
+ return (tif->tif_mode);
+}
+
+/*
+ * Return read/write mode.
+ */
+int
+TIFFSetMode(TIFF* tif, int mode)
+{
+ int old_mode = tif->tif_mode;
+ tif->tif_mode = mode;
+ return (old_mode);
+}
+
+/*
+ * Return nonzero if file is organized in
+ * tiles; zero if organized as strips.
+ */
+int
+TIFFIsTiled(TIFF* tif)
+{
+ return (isTiled(tif));
+}
+
+/*
+ * Return current row being read/written.
+ */
+uint32
+TIFFCurrentRow(TIFF* tif)
+{
+ return (tif->tif_row);
+}
+
+/*
+ * Return index of the current directory.
+ */
+uint16
+TIFFCurrentDirectory(TIFF* tif)
+{
+ return (tif->tif_curdir);
+}
+
+/*
+ * Return current strip.
+ */
+uint32
+TIFFCurrentStrip(TIFF* tif)
+{
+ return (tif->tif_curstrip);
+}
+
+/*
+ * Return current tile.
+ */
+uint32
+TIFFCurrentTile(TIFF* tif)
+{
+ return (tif->tif_curtile);
+}
+
+/*
+ * Return nonzero if the file has byte-swapped data.
+ */
+int
+TIFFIsByteSwapped(TIFF* tif)
+{
+ return ((tif->tif_flags & TIFF_SWAB) != 0);
+}
+
+/*
+ * Return nonzero if the data is returned up-sampled.
+ */
+int
+TIFFIsUpSampled(TIFF* tif)
+{
+ return (isUpSampled(tif));
+}
+
+/*
+ * Return nonzero if the data is returned in MSB-to-LSB bit order.
+ */
+int
+TIFFIsMSB2LSB(TIFF* tif)
+{
+ return (isFillOrder(tif, FILLORDER_MSB2LSB));
+}
+
+/*
+ * Return nonzero if given file was written in big-endian order.
+ */
+int
+TIFFIsBigEndian(TIFF* tif)
+{
+ return (tif->tif_header.common.tiff_magic == TIFF_BIGENDIAN);
+}
+
+/*
+ * Return pointer to file read method.
+ */
+TIFFReadWriteProc
+TIFFGetReadProc(TIFF* tif)
+{
+ return (tif->tif_readproc);
+}
+
+/*
+ * Return pointer to file write method.
+ */
+TIFFReadWriteProc
+TIFFGetWriteProc(TIFF* tif)
+{
+ return (tif->tif_writeproc);
+}
+
+/*
+ * Return pointer to file seek method.
+ */
+TIFFSeekProc
+TIFFGetSeekProc(TIFF* tif)
+{
+ return (tif->tif_seekproc);
+}
+
+/*
+ * Return pointer to file close method.
+ */
+TIFFCloseProc
+TIFFGetCloseProc(TIFF* tif)
+{
+ return (tif->tif_closeproc);
+}
+
+/*
+ * Return pointer to file size requesting method.
+ */
+TIFFSizeProc
+TIFFGetSizeProc(TIFF* tif)
+{
+ return (tif->tif_sizeproc);
+}
+
+/*
+ * Return pointer to memory mapping method.
+ */
+TIFFMapFileProc
+TIFFGetMapFileProc(TIFF* tif)
+{
+ return (tif->tif_mapproc);
+}
+
+/*
+ * Return pointer to memory unmapping method.
+ */
+TIFFUnmapFileProc
+TIFFGetUnmapFileProc(TIFF* tif)
+{
+ return (tif->tif_unmapproc);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_packbits.c b/test/monniaux/tiff-4.0.10/tif_packbits.c
new file mode 100644
index 00000000..a8f29e87
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_packbits.c
@@ -0,0 +1,309 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef PACKBITS_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * PackBits Compression Algorithm Support
+ */
+#include <stdio.h>
+
+static int
+PackBitsPreEncode(TIFF* tif, uint16 s)
+{
+ (void) s;
+
+ tif->tif_data = (uint8*)_TIFFmalloc(sizeof(tmsize_t));
+ if (tif->tif_data == NULL)
+ return (0);
+ /*
+ * Calculate the scanline/tile-width size in bytes.
+ */
+ if (isTiled(tif))
+ *(tmsize_t*)tif->tif_data = TIFFTileRowSize(tif);
+ else
+ *(tmsize_t*)tif->tif_data = TIFFScanlineSize(tif);
+ return (1);
+}
+
+static int
+PackBitsPostEncode(TIFF* tif)
+{
+ if (tif->tif_data)
+ _TIFFfree(tif->tif_data);
+ return (1);
+}
+
+/*
+ * Encode a run of pixels.
+ */
+static int
+PackBitsEncode(TIFF* tif, uint8* buf, tmsize_t cc, uint16 s)
+{
+ unsigned char* bp = (unsigned char*) buf;
+ uint8* op;
+ uint8* ep;
+ uint8* lastliteral;
+ long n, slop;
+ int b;
+ enum { BASE, LITERAL, RUN, LITERAL_RUN } state;
+
+ (void) s;
+ op = tif->tif_rawcp;
+ ep = tif->tif_rawdata + tif->tif_rawdatasize;
+ state = BASE;
+ lastliteral = 0;
+ while (cc > 0) {
+ /*
+ * Find the longest string of identical bytes.
+ */
+ b = *bp++;
+ cc--;
+ n = 1;
+ for (; cc > 0 && b == *bp; cc--, bp++)
+ n++;
+ again:
+ if (op + 2 >= ep) { /* insure space for new data */
+ /*
+ * Be careful about writing the last
+ * literal. Must write up to that point
+ * and then copy the remainder to the
+ * front of the buffer.
+ */
+ if (state == LITERAL || state == LITERAL_RUN) {
+ slop = (long)(op - lastliteral);
+ tif->tif_rawcc += (tmsize_t)(lastliteral - tif->tif_rawcp);
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ while (slop-- > 0)
+ *op++ = *lastliteral++;
+ lastliteral = tif->tif_rawcp;
+ } else {
+ tif->tif_rawcc += (tmsize_t)(op - tif->tif_rawcp);
+ if (!TIFFFlushData1(tif))
+ return (0);
+ op = tif->tif_rawcp;
+ }
+ }
+ switch (state) {
+ case BASE: /* initial state, set run/literal */
+ if (n > 1) {
+ state = RUN;
+ if (n > 128) {
+ *op++ = (uint8) -127;
+ *op++ = (uint8) b;
+ n -= 128;
+ goto again;
+ }
+ *op++ = (uint8)(-(n-1));
+ *op++ = (uint8) b;
+ } else {
+ lastliteral = op;
+ *op++ = 0;
+ *op++ = (uint8) b;
+ state = LITERAL;
+ }
+ break;
+ case LITERAL: /* last object was literal string */
+ if (n > 1) {
+ state = LITERAL_RUN;
+ if (n > 128) {
+ *op++ = (uint8) -127;
+ *op++ = (uint8) b;
+ n -= 128;
+ goto again;
+ }
+ *op++ = (uint8)(-(n-1)); /* encode run */
+ *op++ = (uint8) b;
+ } else { /* extend literal */
+ if (++(*lastliteral) == 127)
+ state = BASE;
+ *op++ = (uint8) b;
+ }
+ break;
+ case RUN: /* last object was run */
+ if (n > 1) {
+ if (n > 128) {
+ *op++ = (uint8) -127;
+ *op++ = (uint8) b;
+ n -= 128;
+ goto again;
+ }
+ *op++ = (uint8)(-(n-1));
+ *op++ = (uint8) b;
+ } else {
+ lastliteral = op;
+ *op++ = 0;
+ *op++ = (uint8) b;
+ state = LITERAL;
+ }
+ break;
+ case LITERAL_RUN: /* literal followed by a run */
+ /*
+ * Check to see if previous run should
+ * be converted to a literal, in which
+ * case we convert literal-run-literal
+ * to a single literal.
+ */
+ if (n == 1 && op[-2] == (uint8) -1 &&
+ *lastliteral < 126) {
+ state = (((*lastliteral) += 2) == 127 ?
+ BASE : LITERAL);
+ op[-2] = op[-1]; /* replicate */
+ } else
+ state = RUN;
+ goto again;
+ }
+ }
+ tif->tif_rawcc += (tmsize_t)(op - tif->tif_rawcp);
+ tif->tif_rawcp = op;
+ return (1);
+}
+
+/*
+ * Encode a rectangular chunk of pixels. We break it up
+ * into row-sized pieces to insure that encoded runs do
+ * not span rows. Otherwise, there can be problems with
+ * the decoder if data is read, for example, by scanlines
+ * when it was encoded by strips.
+ */
+static int
+PackBitsEncodeChunk(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ tmsize_t rowsize = *(tmsize_t*)tif->tif_data;
+
+ while (cc > 0) {
+ tmsize_t chunk = rowsize;
+
+ if( cc < chunk )
+ chunk = cc;
+
+ if (PackBitsEncode(tif, bp, chunk, s) < 0)
+ return (-1);
+ bp += chunk;
+ cc -= chunk;
+ }
+ return (1);
+}
+
+static int
+PackBitsDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "PackBitsDecode";
+ char *bp;
+ tmsize_t cc;
+ long n;
+ int b;
+
+ (void) s;
+ bp = (char*) tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ while (cc > 0 && occ > 0) {
+ n = (long) *bp++;
+ cc--;
+ /*
+ * Watch out for compilers that
+ * don't sign extend chars...
+ */
+ if (n >= 128)
+ n -= 256;
+ if (n < 0) { /* replicate next byte -n+1 times */
+ if (n == -128) /* nop */
+ continue;
+ n = -n + 1;
+ if( occ < (tmsize_t)n )
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Discarding %lu bytes to avoid buffer overrun",
+ (unsigned long) ((tmsize_t)n - occ));
+ n = (long)occ;
+ }
+ if( cc == 0 )
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Terminating PackBitsDecode due to lack of data.");
+ break;
+ }
+ occ -= n;
+ b = *bp++;
+ cc--;
+ while (n-- > 0)
+ *op++ = (uint8) b;
+ } else { /* copy next n+1 bytes literally */
+ if (occ < (tmsize_t)(n + 1))
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Discarding %lu bytes to avoid buffer overrun",
+ (unsigned long) ((tmsize_t)n - occ + 1));
+ n = (long)occ - 1;
+ }
+ if (cc < (tmsize_t) (n+1))
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Terminating PackBitsDecode due to lack of data.");
+ break;
+ }
+ _TIFFmemcpy(op, bp, ++n);
+ op += n; occ -= n;
+ bp += n; cc -= n;
+ }
+ }
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ if (occ > 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data for scanline %lu",
+ (unsigned long) tif->tif_row);
+ return (0);
+ }
+ return (1);
+}
+
+int
+TIFFInitPackBits(TIFF* tif, int scheme)
+{
+ (void) scheme;
+ tif->tif_decoderow = PackBitsDecode;
+ tif->tif_decodestrip = PackBitsDecode;
+ tif->tif_decodetile = PackBitsDecode;
+ tif->tif_preencode = PackBitsPreEncode;
+ tif->tif_postencode = PackBitsPostEncode;
+ tif->tif_encoderow = PackBitsEncode;
+ tif->tif_encodestrip = PackBitsEncodeChunk;
+ tif->tif_encodetile = PackBitsEncodeChunk;
+ return (1);
+}
+#endif /* PACKBITS_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_pixarlog.c b/test/monniaux/tiff-4.0.10/tif_pixarlog.c
new file mode 100644
index 00000000..7438d692
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_pixarlog.c
@@ -0,0 +1,1483 @@
+/*
+ * Copyright (c) 1996-1997 Sam Leffler
+ * Copyright (c) 1996 Pixar
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Pixar, Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Pixar, Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL PIXAR, SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef PIXARLOG_SUPPORT
+
+/*
+ * TIFF Library.
+ * PixarLog Compression Support
+ *
+ * Contributed by Dan McCoy.
+ *
+ * PixarLog film support uses the TIFF library to store companded
+ * 11 bit values into a tiff file, which are compressed using the
+ * zip compressor.
+ *
+ * The codec can take as input and produce as output 32-bit IEEE float values
+ * as well as 16-bit or 8-bit unsigned integer values.
+ *
+ * On writing any of the above are converted into the internal
+ * 11-bit log format. In the case of 8 and 16 bit values, the
+ * input is assumed to be unsigned linear color values that represent
+ * the range 0-1. In the case of IEEE values, the 0-1 range is assumed to
+ * be the normal linear color range, in addition over 1 values are
+ * accepted up to a value of about 25.0 to encode "hot" highlights and such.
+ * The encoding is lossless for 8-bit values, slightly lossy for the
+ * other bit depths. The actual color precision should be better
+ * than the human eye can perceive with extra room to allow for
+ * error introduced by further image computation. As with any quantized
+ * color format, it is possible to perform image calculations which
+ * expose the quantization error. This format should certainly be less
+ * susceptible to such errors than standard 8-bit encodings, but more
+ * susceptible than straight 16-bit or 32-bit encodings.
+ *
+ * On reading the internal format is converted to the desired output format.
+ * The program can request which format it desires by setting the internal
+ * pseudo tag TIFFTAG_PIXARLOGDATAFMT to one of these possible values:
+ * PIXARLOGDATAFMT_FLOAT = provide IEEE float values.
+ * PIXARLOGDATAFMT_16BIT = provide unsigned 16-bit integer values
+ * PIXARLOGDATAFMT_8BIT = provide unsigned 8-bit integer values
+ *
+ * alternately PIXARLOGDATAFMT_8BITABGR provides unsigned 8-bit integer
+ * values with the difference that if there are exactly three or four channels
+ * (rgb or rgba) it swaps the channel order (bgr or abgr).
+ *
+ * PIXARLOGDATAFMT_11BITLOG provides the internal encoding directly
+ * packed in 16-bit values. However no tools are supplied for interpreting
+ * these values.
+ *
+ * "hot" (over 1.0) areas written in floating point get clamped to
+ * 1.0 in the integer data types.
+ *
+ * When the file is closed after writing, the bit depth and sample format
+ * are set always to appear as if 8-bit data has been written into it.
+ * That way a naive program unaware of the particulars of the encoding
+ * gets the format it is most likely able to handle.
+ *
+ * The codec does it's own horizontal differencing step on the coded
+ * values so the libraries predictor stuff should be turned off.
+ * The codec also handle byte swapping the encoded values as necessary
+ * since the library does not have the information necessary
+ * to know the bit depth of the raw unencoded buffer.
+ *
+ * NOTE: This decoder does not appear to update tif_rawcp, and tif_rawcc.
+ * This can cause problems with the implementation of CHUNKY_STRIP_READ_SUPPORT
+ * as noted in http://trac.osgeo.org/gdal/ticket/3894. FrankW - Jan'11
+ */
+
+#include "tif_predict.h"
+#include "zlib.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+
+/* Tables for converting to/from 11 bit coded values */
+
+#define TSIZE 2048 /* decode table size (11-bit tokens) */
+#define TSIZEP1 2049 /* Plus one for slop */
+#define ONE 1250 /* token value of 1.0 exactly */
+#define RATIO 1.004 /* nominal ratio for log part */
+
+#define CODE_MASK 0x7ff /* 11 bits. */
+
+static float Fltsize;
+static float LogK1, LogK2;
+
+#define REPEAT(n, op) { int i; i=n; do { i--; op; } while (i>0); }
+
+static void
+horizontalAccumulateF(uint16 *wp, int n, int stride, float *op,
+ float *ToLinearF)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+ register float t0, t1, t2, t3;
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ t0 = ToLinearF[cr = (wp[0] & mask)];
+ t1 = ToLinearF[cg = (wp[1] & mask)];
+ t2 = ToLinearF[cb = (wp[2] & mask)];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ n -= 3;
+ while (n > 0) {
+ wp += 3;
+ op += 3;
+ n -= 3;
+ t0 = ToLinearF[(cr += wp[0]) & mask];
+ t1 = ToLinearF[(cg += wp[1]) & mask];
+ t2 = ToLinearF[(cb += wp[2]) & mask];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ }
+ } else if (stride == 4) {
+ t0 = ToLinearF[cr = (wp[0] & mask)];
+ t1 = ToLinearF[cg = (wp[1] & mask)];
+ t2 = ToLinearF[cb = (wp[2] & mask)];
+ t3 = ToLinearF[ca = (wp[3] & mask)];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ n -= 4;
+ while (n > 0) {
+ wp += 4;
+ op += 4;
+ n -= 4;
+ t0 = ToLinearF[(cr += wp[0]) & mask];
+ t1 = ToLinearF[(cg += wp[1]) & mask];
+ t2 = ToLinearF[(cb += wp[2]) & mask];
+ t3 = ToLinearF[(ca += wp[3]) & mask];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ }
+ } else {
+ REPEAT(stride, *op = ToLinearF[*wp&mask]; wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; *op = ToLinearF[*wp&mask]; wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+static void
+horizontalAccumulate12(uint16 *wp, int n, int stride, int16 *op,
+ float *ToLinearF)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+ register float t0, t1, t2, t3;
+
+#define SCALE12 2048.0F
+#define CLAMP12(t) (((t) < 3071) ? (uint16) (t) : 3071)
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ t0 = ToLinearF[cr = (wp[0] & mask)] * SCALE12;
+ t1 = ToLinearF[cg = (wp[1] & mask)] * SCALE12;
+ t2 = ToLinearF[cb = (wp[2] & mask)] * SCALE12;
+ op[0] = CLAMP12(t0);
+ op[1] = CLAMP12(t1);
+ op[2] = CLAMP12(t2);
+ n -= 3;
+ while (n > 0) {
+ wp += 3;
+ op += 3;
+ n -= 3;
+ t0 = ToLinearF[(cr += wp[0]) & mask] * SCALE12;
+ t1 = ToLinearF[(cg += wp[1]) & mask] * SCALE12;
+ t2 = ToLinearF[(cb += wp[2]) & mask] * SCALE12;
+ op[0] = CLAMP12(t0);
+ op[1] = CLAMP12(t1);
+ op[2] = CLAMP12(t2);
+ }
+ } else if (stride == 4) {
+ t0 = ToLinearF[cr = (wp[0] & mask)] * SCALE12;
+ t1 = ToLinearF[cg = (wp[1] & mask)] * SCALE12;
+ t2 = ToLinearF[cb = (wp[2] & mask)] * SCALE12;
+ t3 = ToLinearF[ca = (wp[3] & mask)] * SCALE12;
+ op[0] = CLAMP12(t0);
+ op[1] = CLAMP12(t1);
+ op[2] = CLAMP12(t2);
+ op[3] = CLAMP12(t3);
+ n -= 4;
+ while (n > 0) {
+ wp += 4;
+ op += 4;
+ n -= 4;
+ t0 = ToLinearF[(cr += wp[0]) & mask] * SCALE12;
+ t1 = ToLinearF[(cg += wp[1]) & mask] * SCALE12;
+ t2 = ToLinearF[(cb += wp[2]) & mask] * SCALE12;
+ t3 = ToLinearF[(ca += wp[3]) & mask] * SCALE12;
+ op[0] = CLAMP12(t0);
+ op[1] = CLAMP12(t1);
+ op[2] = CLAMP12(t2);
+ op[3] = CLAMP12(t3);
+ }
+ } else {
+ REPEAT(stride, t0 = ToLinearF[*wp&mask] * SCALE12;
+ *op = CLAMP12(t0); wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; t0 = ToLinearF[wp[stride]&mask]*SCALE12;
+ *op = CLAMP12(t0); wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+static void
+horizontalAccumulate16(uint16 *wp, int n, int stride, uint16 *op,
+ uint16 *ToLinear16)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ op[0] = ToLinear16[cr = (wp[0] & mask)];
+ op[1] = ToLinear16[cg = (wp[1] & mask)];
+ op[2] = ToLinear16[cb = (wp[2] & mask)];
+ n -= 3;
+ while (n > 0) {
+ wp += 3;
+ op += 3;
+ n -= 3;
+ op[0] = ToLinear16[(cr += wp[0]) & mask];
+ op[1] = ToLinear16[(cg += wp[1]) & mask];
+ op[2] = ToLinear16[(cb += wp[2]) & mask];
+ }
+ } else if (stride == 4) {
+ op[0] = ToLinear16[cr = (wp[0] & mask)];
+ op[1] = ToLinear16[cg = (wp[1] & mask)];
+ op[2] = ToLinear16[cb = (wp[2] & mask)];
+ op[3] = ToLinear16[ca = (wp[3] & mask)];
+ n -= 4;
+ while (n > 0) {
+ wp += 4;
+ op += 4;
+ n -= 4;
+ op[0] = ToLinear16[(cr += wp[0]) & mask];
+ op[1] = ToLinear16[(cg += wp[1]) & mask];
+ op[2] = ToLinear16[(cb += wp[2]) & mask];
+ op[3] = ToLinear16[(ca += wp[3]) & mask];
+ }
+ } else {
+ REPEAT(stride, *op = ToLinear16[*wp&mask]; wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; *op = ToLinear16[*wp&mask]; wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+/*
+ * Returns the log encoded 11-bit values with the horizontal
+ * differencing undone.
+ */
+static void
+horizontalAccumulate11(uint16 *wp, int n, int stride, uint16 *op)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ op[0] = wp[0]; op[1] = wp[1]; op[2] = wp[2];
+ cr = wp[0]; cg = wp[1]; cb = wp[2];
+ n -= 3;
+ while (n > 0) {
+ wp += 3;
+ op += 3;
+ n -= 3;
+ op[0] = (uint16)((cr += wp[0]) & mask);
+ op[1] = (uint16)((cg += wp[1]) & mask);
+ op[2] = (uint16)((cb += wp[2]) & mask);
+ }
+ } else if (stride == 4) {
+ op[0] = wp[0]; op[1] = wp[1];
+ op[2] = wp[2]; op[3] = wp[3];
+ cr = wp[0]; cg = wp[1]; cb = wp[2]; ca = wp[3];
+ n -= 4;
+ while (n > 0) {
+ wp += 4;
+ op += 4;
+ n -= 4;
+ op[0] = (uint16)((cr += wp[0]) & mask);
+ op[1] = (uint16)((cg += wp[1]) & mask);
+ op[2] = (uint16)((cb += wp[2]) & mask);
+ op[3] = (uint16)((ca += wp[3]) & mask);
+ }
+ } else {
+ REPEAT(stride, *op = *wp&mask; wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; *op = *wp&mask; wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+static void
+horizontalAccumulate8(uint16 *wp, int n, int stride, unsigned char *op,
+ unsigned char *ToLinear8)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ op[0] = ToLinear8[cr = (wp[0] & mask)];
+ op[1] = ToLinear8[cg = (wp[1] & mask)];
+ op[2] = ToLinear8[cb = (wp[2] & mask)];
+ n -= 3;
+ while (n > 0) {
+ n -= 3;
+ wp += 3;
+ op += 3;
+ op[0] = ToLinear8[(cr += wp[0]) & mask];
+ op[1] = ToLinear8[(cg += wp[1]) & mask];
+ op[2] = ToLinear8[(cb += wp[2]) & mask];
+ }
+ } else if (stride == 4) {
+ op[0] = ToLinear8[cr = (wp[0] & mask)];
+ op[1] = ToLinear8[cg = (wp[1] & mask)];
+ op[2] = ToLinear8[cb = (wp[2] & mask)];
+ op[3] = ToLinear8[ca = (wp[3] & mask)];
+ n -= 4;
+ while (n > 0) {
+ n -= 4;
+ wp += 4;
+ op += 4;
+ op[0] = ToLinear8[(cr += wp[0]) & mask];
+ op[1] = ToLinear8[(cg += wp[1]) & mask];
+ op[2] = ToLinear8[(cb += wp[2]) & mask];
+ op[3] = ToLinear8[(ca += wp[3]) & mask];
+ }
+ } else {
+ REPEAT(stride, *op = ToLinear8[*wp&mask]; wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; *op = ToLinear8[*wp&mask]; wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+
+static void
+horizontalAccumulate8abgr(uint16 *wp, int n, int stride, unsigned char *op,
+ unsigned char *ToLinear8)
+{
+ register unsigned int cr, cg, cb, ca, mask;
+ register unsigned char t0, t1, t2, t3;
+
+ if (n >= stride) {
+ mask = CODE_MASK;
+ if (stride == 3) {
+ op[0] = 0;
+ t1 = ToLinear8[cb = (wp[2] & mask)];
+ t2 = ToLinear8[cg = (wp[1] & mask)];
+ t3 = ToLinear8[cr = (wp[0] & mask)];
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ n -= 3;
+ while (n > 0) {
+ n -= 3;
+ wp += 3;
+ op += 4;
+ op[0] = 0;
+ t1 = ToLinear8[(cb += wp[2]) & mask];
+ t2 = ToLinear8[(cg += wp[1]) & mask];
+ t3 = ToLinear8[(cr += wp[0]) & mask];
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ }
+ } else if (stride == 4) {
+ t0 = ToLinear8[ca = (wp[3] & mask)];
+ t1 = ToLinear8[cb = (wp[2] & mask)];
+ t2 = ToLinear8[cg = (wp[1] & mask)];
+ t3 = ToLinear8[cr = (wp[0] & mask)];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ n -= 4;
+ while (n > 0) {
+ n -= 4;
+ wp += 4;
+ op += 4;
+ t0 = ToLinear8[(ca += wp[3]) & mask];
+ t1 = ToLinear8[(cb += wp[2]) & mask];
+ t2 = ToLinear8[(cg += wp[1]) & mask];
+ t3 = ToLinear8[(cr += wp[0]) & mask];
+ op[0] = t0;
+ op[1] = t1;
+ op[2] = t2;
+ op[3] = t3;
+ }
+ } else {
+ REPEAT(stride, *op = ToLinear8[*wp&mask]; wp++; op++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[stride] += *wp; *op = ToLinear8[*wp&mask]; wp++; op++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+/*
+ * State block for each open TIFF
+ * file using PixarLog compression/decompression.
+ */
+typedef struct {
+ TIFFPredictorState predict;
+ z_stream stream;
+ tmsize_t tbuf_size; /* only set/used on reading for now */
+ uint16 *tbuf;
+ uint16 stride;
+ int state;
+ int user_datafmt;
+ int quality;
+#define PLSTATE_INIT 1
+
+ TIFFVSetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+
+ float *ToLinearF;
+ uint16 *ToLinear16;
+ unsigned char *ToLinear8;
+ uint16 *FromLT2;
+ uint16 *From14; /* Really for 16-bit data, but we shift down 2 */
+ uint16 *From8;
+
+} PixarLogState;
+
+static int
+PixarLogMakeTables(PixarLogState *sp)
+{
+
+/*
+ * We make several tables here to convert between various external
+ * representations (float, 16-bit, and 8-bit) and the internal
+ * 11-bit companded representation. The 11-bit representation has two
+ * distinct regions. A linear bottom end up through .018316 in steps
+ * of about .000073, and a region of constant ratio up to about 25.
+ * These floating point numbers are stored in the main table ToLinearF.
+ * All other tables are derived from this one. The tables (and the
+ * ratios) are continuous at the internal seam.
+ */
+
+ int nlin, lt2size;
+ int i, j;
+ double b, c, linstep, v;
+ float *ToLinearF;
+ uint16 *ToLinear16;
+ unsigned char *ToLinear8;
+ uint16 *FromLT2;
+ uint16 *From14; /* Really for 16-bit data, but we shift down 2 */
+ uint16 *From8;
+
+ c = log(RATIO);
+ nlin = (int)(1./c); /* nlin must be an integer */
+ c = 1./nlin;
+ b = exp(-c*ONE); /* multiplicative scale factor [b*exp(c*ONE) = 1] */
+ linstep = b*c*exp(1.);
+
+ LogK1 = (float)(1./c); /* if (v >= 2) token = k1*log(v*k2) */
+ LogK2 = (float)(1./b);
+ lt2size = (int)(2./linstep) + 1;
+ FromLT2 = (uint16 *)_TIFFmalloc(lt2size*sizeof(uint16));
+ From14 = (uint16 *)_TIFFmalloc(16384*sizeof(uint16));
+ From8 = (uint16 *)_TIFFmalloc(256*sizeof(uint16));
+ ToLinearF = (float *)_TIFFmalloc(TSIZEP1 * sizeof(float));
+ ToLinear16 = (uint16 *)_TIFFmalloc(TSIZEP1 * sizeof(uint16));
+ ToLinear8 = (unsigned char *)_TIFFmalloc(TSIZEP1 * sizeof(unsigned char));
+ if (FromLT2 == NULL || From14 == NULL || From8 == NULL ||
+ ToLinearF == NULL || ToLinear16 == NULL || ToLinear8 == NULL) {
+ if (FromLT2) _TIFFfree(FromLT2);
+ if (From14) _TIFFfree(From14);
+ if (From8) _TIFFfree(From8);
+ if (ToLinearF) _TIFFfree(ToLinearF);
+ if (ToLinear16) _TIFFfree(ToLinear16);
+ if (ToLinear8) _TIFFfree(ToLinear8);
+ sp->FromLT2 = NULL;
+ sp->From14 = NULL;
+ sp->From8 = NULL;
+ sp->ToLinearF = NULL;
+ sp->ToLinear16 = NULL;
+ sp->ToLinear8 = NULL;
+ return 0;
+ }
+
+ j = 0;
+
+ for (i = 0; i < nlin; i++) {
+ v = i * linstep;
+ ToLinearF[j++] = (float)v;
+ }
+
+ for (i = nlin; i < TSIZE; i++)
+ ToLinearF[j++] = (float)(b*exp(c*i));
+
+ ToLinearF[2048] = ToLinearF[2047];
+
+ for (i = 0; i < TSIZEP1; i++) {
+ v = ToLinearF[i]*65535.0 + 0.5;
+ ToLinear16[i] = (v > 65535.0) ? 65535 : (uint16)v;
+ v = ToLinearF[i]*255.0 + 0.5;
+ ToLinear8[i] = (v > 255.0) ? 255 : (unsigned char)v;
+ }
+
+ j = 0;
+ for (i = 0; i < lt2size; i++) {
+ if ((i*linstep)*(i*linstep) > ToLinearF[j]*ToLinearF[j+1])
+ j++;
+ FromLT2[i] = (uint16)j;
+ }
+
+ /*
+ * Since we lose info anyway on 16-bit data, we set up a 14-bit
+ * table and shift 16-bit values down two bits on input.
+ * saves a little table space.
+ */
+ j = 0;
+ for (i = 0; i < 16384; i++) {
+ while ((i/16383.)*(i/16383.) > ToLinearF[j]*ToLinearF[j+1])
+ j++;
+ From14[i] = (uint16)j;
+ }
+
+ j = 0;
+ for (i = 0; i < 256; i++) {
+ while ((i/255.)*(i/255.) > ToLinearF[j]*ToLinearF[j+1])
+ j++;
+ From8[i] = (uint16)j;
+ }
+
+ Fltsize = (float)(lt2size/2);
+
+ sp->ToLinearF = ToLinearF;
+ sp->ToLinear16 = ToLinear16;
+ sp->ToLinear8 = ToLinear8;
+ sp->FromLT2 = FromLT2;
+ sp->From14 = From14;
+ sp->From8 = From8;
+
+ return 1;
+}
+
+#define DecoderState(tif) ((PixarLogState*) (tif)->tif_data)
+#define EncoderState(tif) ((PixarLogState*) (tif)->tif_data)
+
+static int PixarLogEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int PixarLogDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s);
+
+#define PIXARLOGDATAFMT_UNKNOWN -1
+
+static int
+PixarLogGuessDataFmt(TIFFDirectory *td)
+{
+ int guess = PIXARLOGDATAFMT_UNKNOWN;
+ int format = td->td_sampleformat;
+
+ /* If the user didn't tell us his datafmt,
+ * take our best guess from the bitspersample.
+ */
+ switch (td->td_bitspersample) {
+ case 32:
+ if (format == SAMPLEFORMAT_IEEEFP)
+ guess = PIXARLOGDATAFMT_FLOAT;
+ break;
+ case 16:
+ if (format == SAMPLEFORMAT_VOID || format == SAMPLEFORMAT_UINT)
+ guess = PIXARLOGDATAFMT_16BIT;
+ break;
+ case 12:
+ if (format == SAMPLEFORMAT_VOID || format == SAMPLEFORMAT_INT)
+ guess = PIXARLOGDATAFMT_12BITPICIO;
+ break;
+ case 11:
+ if (format == SAMPLEFORMAT_VOID || format == SAMPLEFORMAT_UINT)
+ guess = PIXARLOGDATAFMT_11BITLOG;
+ break;
+ case 8:
+ if (format == SAMPLEFORMAT_VOID || format == SAMPLEFORMAT_UINT)
+ guess = PIXARLOGDATAFMT_8BIT;
+ break;
+ }
+
+ return guess;
+}
+
+#define TIFF_SIZE_T_MAX ((size_t) ~ ((size_t)0))
+#define TIFF_TMSIZE_T_MAX (tmsize_t)(TIFF_SIZE_T_MAX >> 1)
+
+static tmsize_t
+multiply_ms(tmsize_t m1, tmsize_t m2)
+{
+ if( m1 == 0 || m2 > TIFF_TMSIZE_T_MAX / m1 )
+ return 0;
+ return m1 * m2;
+}
+
+static tmsize_t
+add_ms(tmsize_t m1, tmsize_t m2)
+{
+ /* if either input is zero, assume overflow already occurred */
+ if (m1 == 0 || m2 == 0)
+ return 0;
+ else if (m1 > TIFF_TMSIZE_T_MAX - m2)
+ return 0;
+
+ return m1 + m2;
+}
+
+static int
+PixarLogFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+static int
+PixarLogSetupDecode(TIFF* tif)
+{
+ static const char module[] = "PixarLogSetupDecode";
+ TIFFDirectory *td = &tif->tif_dir;
+ PixarLogState* sp = DecoderState(tif);
+ tmsize_t tbuf_size;
+ uint32 strip_height;
+
+ assert(sp != NULL);
+
+ /* This function can possibly be called several times by */
+ /* PredictorSetupDecode() if this function succeeds but */
+ /* PredictorSetup() fails */
+ if( (sp->state & PLSTATE_INIT) != 0 )
+ return 1;
+
+ strip_height = td->td_rowsperstrip;
+ if( strip_height > td->td_imagelength )
+ strip_height = td->td_imagelength;
+
+ /* Make sure no byte swapping happens on the data
+ * after decompression. */
+ tif->tif_postdecode = _TIFFNoPostDecode;
+
+ /* for some reason, we can't do this in TIFFInitPixarLog */
+
+ sp->stride = (td->td_planarconfig == PLANARCONFIG_CONTIG ?
+ td->td_samplesperpixel : 1);
+ tbuf_size = multiply_ms(multiply_ms(multiply_ms(sp->stride, td->td_imagewidth),
+ strip_height), sizeof(uint16));
+ /* add one more stride in case input ends mid-stride */
+ tbuf_size = add_ms(tbuf_size, sizeof(uint16) * sp->stride);
+ if (tbuf_size == 0)
+ return (0); /* TODO: this is an error return without error report through TIFFErrorExt */
+ sp->tbuf = (uint16 *) _TIFFmalloc(tbuf_size);
+ if (sp->tbuf == NULL)
+ return (0);
+ sp->tbuf_size = tbuf_size;
+ if (sp->user_datafmt == PIXARLOGDATAFMT_UNKNOWN)
+ sp->user_datafmt = PixarLogGuessDataFmt(td);
+ if (sp->user_datafmt == PIXARLOGDATAFMT_UNKNOWN) {
+ _TIFFfree(sp->tbuf);
+ sp->tbuf = NULL;
+ sp->tbuf_size = 0;
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "PixarLog compression can't handle bits depth/data format combination (depth: %d)",
+ td->td_bitspersample);
+ return (0);
+ }
+
+ if (inflateInit(&sp->stream) != Z_OK) {
+ _TIFFfree(sp->tbuf);
+ sp->tbuf = NULL;
+ sp->tbuf_size = 0;
+ TIFFErrorExt(tif->tif_clientdata, module, "%s", sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ } else {
+ sp->state |= PLSTATE_INIT;
+ return (1);
+ }
+}
+
+/*
+ * Setup state for decoding a strip.
+ */
+static int
+PixarLogPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "PixarLogPreDecode";
+ PixarLogState* sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ sp->stream.next_in = tif->tif_rawdata;
+ assert(sizeof(sp->stream.avail_in)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_in = (uInt) tif->tif_rawcc;
+ if ((tmsize_t)sp->stream.avail_in != tif->tif_rawcc)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ return (inflateReset(&sp->stream) == Z_OK);
+}
+
+static int
+PixarLogDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "PixarLogDecode";
+ TIFFDirectory *td = &tif->tif_dir;
+ PixarLogState* sp = DecoderState(tif);
+ tmsize_t i;
+ tmsize_t nsamples;
+ int llen;
+ uint16 *up;
+
+ switch (sp->user_datafmt) {
+ case PIXARLOGDATAFMT_FLOAT:
+ nsamples = occ / sizeof(float); /* XXX float == 32 bits */
+ break;
+ case PIXARLOGDATAFMT_16BIT:
+ case PIXARLOGDATAFMT_12BITPICIO:
+ case PIXARLOGDATAFMT_11BITLOG:
+ nsamples = occ / sizeof(uint16); /* XXX uint16 == 16 bits */
+ break;
+ case PIXARLOGDATAFMT_8BIT:
+ case PIXARLOGDATAFMT_8BITABGR:
+ nsamples = occ;
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%d bit input not supported in PixarLog",
+ td->td_bitspersample);
+ return 0;
+ }
+
+ llen = sp->stride * td->td_imagewidth;
+
+ (void) s;
+ assert(sp != NULL);
+
+ sp->stream.next_in = tif->tif_rawcp;
+ sp->stream.avail_in = (uInt) tif->tif_rawcc;
+
+ sp->stream.next_out = (unsigned char *) sp->tbuf;
+ assert(sizeof(sp->stream.avail_out)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_out = (uInt) (nsamples * sizeof(uint16));
+ if (sp->stream.avail_out != nsamples * sizeof(uint16))
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ /* Check that we will not fill more than what was allocated */
+ if ((tmsize_t)sp->stream.avail_out > sp->tbuf_size)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "sp->stream.avail_out > sp->tbuf_size");
+ return (0);
+ }
+ do {
+ int state = inflate(&sp->stream, Z_PARTIAL_FLUSH);
+ if (state == Z_STREAM_END) {
+ break; /* XXX */
+ }
+ if (state == Z_DATA_ERROR) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Decoding error at scanline %lu, %s",
+ (unsigned long) tif->tif_row, sp->stream.msg ? sp->stream.msg : "(null)");
+ if (inflateSync(&sp->stream) != Z_OK)
+ return (0);
+ continue;
+ }
+ if (state != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib error: %s",
+ sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ }
+ } while (sp->stream.avail_out > 0);
+
+ /* hopefully, we got all the bytes we needed */
+ if (sp->stream.avail_out != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %lu (short " TIFF_UINT64_FORMAT " bytes)",
+ (unsigned long) tif->tif_row, (TIFF_UINT64_T) sp->stream.avail_out);
+ return (0);
+ }
+
+ tif->tif_rawcp = sp->stream.next_in;
+ tif->tif_rawcc = sp->stream.avail_in;
+
+ up = sp->tbuf;
+ /* Swap bytes in the data if from a different endian machine. */
+ if (tif->tif_flags & TIFF_SWAB)
+ TIFFSwabArrayOfShort(up, nsamples);
+
+ /*
+ * if llen is not an exact multiple of nsamples, the decode operation
+ * may overflow the output buffer, so truncate it enough to prevent
+ * that but still salvage as much data as possible.
+ */
+ if (nsamples % llen) {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "stride %lu is not a multiple of sample count, "
+ "%lu, data truncated.", (unsigned long) llen, (unsigned long) nsamples);
+ nsamples -= nsamples % llen;
+ }
+
+ for (i = 0; i < nsamples; i += llen, up += llen) {
+ switch (sp->user_datafmt) {
+ case PIXARLOGDATAFMT_FLOAT:
+ horizontalAccumulateF(up, llen, sp->stride,
+ (float *)op, sp->ToLinearF);
+ op += llen * sizeof(float);
+ break;
+ case PIXARLOGDATAFMT_16BIT:
+ horizontalAccumulate16(up, llen, sp->stride,
+ (uint16 *)op, sp->ToLinear16);
+ op += llen * sizeof(uint16);
+ break;
+ case PIXARLOGDATAFMT_12BITPICIO:
+ horizontalAccumulate12(up, llen, sp->stride,
+ (int16 *)op, sp->ToLinearF);
+ op += llen * sizeof(int16);
+ break;
+ case PIXARLOGDATAFMT_11BITLOG:
+ horizontalAccumulate11(up, llen, sp->stride,
+ (uint16 *)op);
+ op += llen * sizeof(uint16);
+ break;
+ case PIXARLOGDATAFMT_8BIT:
+ horizontalAccumulate8(up, llen, sp->stride,
+ (unsigned char *)op, sp->ToLinear8);
+ op += llen * sizeof(unsigned char);
+ break;
+ case PIXARLOGDATAFMT_8BITABGR:
+ horizontalAccumulate8abgr(up, llen, sp->stride,
+ (unsigned char *)op, sp->ToLinear8);
+ op += llen * sizeof(unsigned char);
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Unsupported bits/sample: %d",
+ td->td_bitspersample);
+ return (0);
+ }
+ }
+
+ return (1);
+}
+
+static int
+PixarLogSetupEncode(TIFF* tif)
+{
+ static const char module[] = "PixarLogSetupEncode";
+ TIFFDirectory *td = &tif->tif_dir;
+ PixarLogState* sp = EncoderState(tif);
+ tmsize_t tbuf_size;
+
+ assert(sp != NULL);
+
+ /* for some reason, we can't do this in TIFFInitPixarLog */
+
+ sp->stride = (td->td_planarconfig == PLANARCONFIG_CONTIG ?
+ td->td_samplesperpixel : 1);
+ tbuf_size = multiply_ms(multiply_ms(multiply_ms(sp->stride, td->td_imagewidth),
+ td->td_rowsperstrip), sizeof(uint16));
+ if (tbuf_size == 0)
+ return (0); /* TODO: this is an error return without error report through TIFFErrorExt */
+ sp->tbuf = (uint16 *) _TIFFmalloc(tbuf_size);
+ if (sp->tbuf == NULL)
+ return (0);
+ if (sp->user_datafmt == PIXARLOGDATAFMT_UNKNOWN)
+ sp->user_datafmt = PixarLogGuessDataFmt(td);
+ if (sp->user_datafmt == PIXARLOGDATAFMT_UNKNOWN) {
+ TIFFErrorExt(tif->tif_clientdata, module, "PixarLog compression can't handle %d bit linear encodings", td->td_bitspersample);
+ return (0);
+ }
+
+ if (deflateInit(&sp->stream, sp->quality) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s", sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ } else {
+ sp->state |= PLSTATE_INIT;
+ return (1);
+ }
+}
+
+/*
+ * Reset encoding state at the start of a strip.
+ */
+static int
+PixarLogPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "PixarLogPreEncode";
+ PixarLogState *sp = EncoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ sp->stream.next_out = tif->tif_rawdata;
+ assert(sizeof(sp->stream.avail_out)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_out = (uInt)tif->tif_rawdatasize;
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ return (deflateReset(&sp->stream) == Z_OK);
+}
+
+static void
+horizontalDifferenceF(float *ip, int n, int stride, uint16 *wp, uint16 *FromLT2)
+{
+ int32 r1, g1, b1, a1, r2, g2, b2, a2, mask;
+ float fltsize = Fltsize;
+
+#define CLAMP(v) ( (v<(float)0.) ? 0 \
+ : (v<(float)2.) ? FromLT2[(int)(v*fltsize)] \
+ : (v>(float)24.2) ? 2047 \
+ : LogK1*log(v*LogK2) + 0.5 )
+
+ mask = CODE_MASK;
+ if (n >= stride) {
+ if (stride == 3) {
+ r2 = wp[0] = (uint16) CLAMP(ip[0]);
+ g2 = wp[1] = (uint16) CLAMP(ip[1]);
+ b2 = wp[2] = (uint16) CLAMP(ip[2]);
+ n -= 3;
+ while (n > 0) {
+ n -= 3;
+ wp += 3;
+ ip += 3;
+ r1 = (int32) CLAMP(ip[0]); wp[0] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = (int32) CLAMP(ip[1]); wp[1] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = (int32) CLAMP(ip[2]); wp[2] = (uint16)((b1-b2) & mask); b2 = b1;
+ }
+ } else if (stride == 4) {
+ r2 = wp[0] = (uint16) CLAMP(ip[0]);
+ g2 = wp[1] = (uint16) CLAMP(ip[1]);
+ b2 = wp[2] = (uint16) CLAMP(ip[2]);
+ a2 = wp[3] = (uint16) CLAMP(ip[3]);
+ n -= 4;
+ while (n > 0) {
+ n -= 4;
+ wp += 4;
+ ip += 4;
+ r1 = (int32) CLAMP(ip[0]); wp[0] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = (int32) CLAMP(ip[1]); wp[1] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = (int32) CLAMP(ip[2]); wp[2] = (uint16)((b1-b2) & mask); b2 = b1;
+ a1 = (int32) CLAMP(ip[3]); wp[3] = (uint16)((a1-a2) & mask); a2 = a1;
+ }
+ } else {
+ REPEAT(stride, wp[0] = (uint16) CLAMP(ip[0]); wp++; ip++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[0] = (uint16)(((int32)CLAMP(ip[0])-(int32)CLAMP(ip[-stride])) & mask);
+ wp++; ip++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+static void
+horizontalDifference16(unsigned short *ip, int n, int stride,
+ unsigned short *wp, uint16 *From14)
+{
+ register int r1, g1, b1, a1, r2, g2, b2, a2, mask;
+
+/* assumption is unsigned pixel values */
+#undef CLAMP
+#define CLAMP(v) From14[(v) >> 2]
+
+ mask = CODE_MASK;
+ if (n >= stride) {
+ if (stride == 3) {
+ r2 = wp[0] = CLAMP(ip[0]); g2 = wp[1] = CLAMP(ip[1]);
+ b2 = wp[2] = CLAMP(ip[2]);
+ n -= 3;
+ while (n > 0) {
+ n -= 3;
+ wp += 3;
+ ip += 3;
+ r1 = CLAMP(ip[0]); wp[0] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = CLAMP(ip[1]); wp[1] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = CLAMP(ip[2]); wp[2] = (uint16)((b1-b2) & mask); b2 = b1;
+ }
+ } else if (stride == 4) {
+ r2 = wp[0] = CLAMP(ip[0]); g2 = wp[1] = CLAMP(ip[1]);
+ b2 = wp[2] = CLAMP(ip[2]); a2 = wp[3] = CLAMP(ip[3]);
+ n -= 4;
+ while (n > 0) {
+ n -= 4;
+ wp += 4;
+ ip += 4;
+ r1 = CLAMP(ip[0]); wp[0] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = CLAMP(ip[1]); wp[1] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = CLAMP(ip[2]); wp[2] = (uint16)((b1-b2) & mask); b2 = b1;
+ a1 = CLAMP(ip[3]); wp[3] = (uint16)((a1-a2) & mask); a2 = a1;
+ }
+ } else {
+ REPEAT(stride, wp[0] = CLAMP(ip[0]); wp++; ip++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[0] = (uint16)((CLAMP(ip[0])-CLAMP(ip[-stride])) & mask);
+ wp++; ip++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+
+static void
+horizontalDifference8(unsigned char *ip, int n, int stride,
+ unsigned short *wp, uint16 *From8)
+{
+ register int r1, g1, b1, a1, r2, g2, b2, a2, mask;
+
+#undef CLAMP
+#define CLAMP(v) (From8[(v)])
+
+ mask = CODE_MASK;
+ if (n >= stride) {
+ if (stride == 3) {
+ r2 = wp[0] = CLAMP(ip[0]); g2 = wp[1] = CLAMP(ip[1]);
+ b2 = wp[2] = CLAMP(ip[2]);
+ n -= 3;
+ while (n > 0) {
+ n -= 3;
+ r1 = CLAMP(ip[3]); wp[3] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = CLAMP(ip[4]); wp[4] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = CLAMP(ip[5]); wp[5] = (uint16)((b1-b2) & mask); b2 = b1;
+ wp += 3;
+ ip += 3;
+ }
+ } else if (stride == 4) {
+ r2 = wp[0] = CLAMP(ip[0]); g2 = wp[1] = CLAMP(ip[1]);
+ b2 = wp[2] = CLAMP(ip[2]); a2 = wp[3] = CLAMP(ip[3]);
+ n -= 4;
+ while (n > 0) {
+ n -= 4;
+ r1 = CLAMP(ip[4]); wp[4] = (uint16)((r1-r2) & mask); r2 = r1;
+ g1 = CLAMP(ip[5]); wp[5] = (uint16)((g1-g2) & mask); g2 = g1;
+ b1 = CLAMP(ip[6]); wp[6] = (uint16)((b1-b2) & mask); b2 = b1;
+ a1 = CLAMP(ip[7]); wp[7] = (uint16)((a1-a2) & mask); a2 = a1;
+ wp += 4;
+ ip += 4;
+ }
+ } else {
+ REPEAT(stride, wp[0] = CLAMP(ip[0]); wp++; ip++)
+ n -= stride;
+ while (n > 0) {
+ REPEAT(stride,
+ wp[0] = (uint16)((CLAMP(ip[0])-CLAMP(ip[-stride])) & mask);
+ wp++; ip++)
+ n -= stride;
+ }
+ }
+ }
+}
+
+/*
+ * Encode a chunk of pixels.
+ */
+static int
+PixarLogEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "PixarLogEncode";
+ TIFFDirectory *td = &tif->tif_dir;
+ PixarLogState *sp = EncoderState(tif);
+ tmsize_t i;
+ tmsize_t n;
+ int llen;
+ unsigned short * up;
+
+ (void) s;
+
+ switch (sp->user_datafmt) {
+ case PIXARLOGDATAFMT_FLOAT:
+ n = cc / sizeof(float); /* XXX float == 32 bits */
+ break;
+ case PIXARLOGDATAFMT_16BIT:
+ case PIXARLOGDATAFMT_12BITPICIO:
+ case PIXARLOGDATAFMT_11BITLOG:
+ n = cc / sizeof(uint16); /* XXX uint16 == 16 bits */
+ break;
+ case PIXARLOGDATAFMT_8BIT:
+ case PIXARLOGDATAFMT_8BITABGR:
+ n = cc;
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%d bit input not supported in PixarLog",
+ td->td_bitspersample);
+ return 0;
+ }
+
+ llen = sp->stride * td->td_imagewidth;
+ /* Check against the number of elements (of size uint16) of sp->tbuf */
+ if( n > (tmsize_t)(td->td_rowsperstrip * llen) )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Too many input bytes provided");
+ return 0;
+ }
+
+ for (i = 0, up = sp->tbuf; i < n; i += llen, up += llen) {
+ switch (sp->user_datafmt) {
+ case PIXARLOGDATAFMT_FLOAT:
+ horizontalDifferenceF((float *)bp, llen,
+ sp->stride, up, sp->FromLT2);
+ bp += llen * sizeof(float);
+ break;
+ case PIXARLOGDATAFMT_16BIT:
+ horizontalDifference16((uint16 *)bp, llen,
+ sp->stride, up, sp->From14);
+ bp += llen * sizeof(uint16);
+ break;
+ case PIXARLOGDATAFMT_8BIT:
+ horizontalDifference8((unsigned char *)bp, llen,
+ sp->stride, up, sp->From8);
+ bp += llen * sizeof(unsigned char);
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%d bit input not supported in PixarLog",
+ td->td_bitspersample);
+ return 0;
+ }
+ }
+
+ sp->stream.next_in = (unsigned char *) sp->tbuf;
+ assert(sizeof(sp->stream.avail_in)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_in = (uInt) (n * sizeof(uint16));
+ if ((sp->stream.avail_in / sizeof(uint16)) != (uInt) n)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+
+ do {
+ if (deflate(&sp->stream, Z_NO_FLUSH) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Encoder error: %s",
+ sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ }
+ if (sp->stream.avail_out == 0) {
+ tif->tif_rawcc = tif->tif_rawdatasize;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (uInt) tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in PixarLogPreEncode */
+ }
+ } while (sp->stream.avail_in > 0);
+ return (1);
+}
+
+/*
+ * Finish off an encoded strip by flushing the last
+ * string and tacking on an End Of Information code.
+ */
+
+static int
+PixarLogPostEncode(TIFF* tif)
+{
+ static const char module[] = "PixarLogPostEncode";
+ PixarLogState *sp = EncoderState(tif);
+ int state;
+
+ sp->stream.avail_in = 0;
+
+ do {
+ state = deflate(&sp->stream, Z_FINISH);
+ switch (state) {
+ case Z_STREAM_END:
+ case Z_OK:
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize) {
+ tif->tif_rawcc =
+ tif->tif_rawdatasize - sp->stream.avail_out;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (uInt) tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in PixarLogPreEncode */
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib error: %s",
+ sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ }
+ } while (state != Z_STREAM_END);
+ return (1);
+}
+
+static void
+PixarLogClose(TIFF* tif)
+{
+ PixarLogState* sp = (PixarLogState*) tif->tif_data;
+ TIFFDirectory *td = &tif->tif_dir;
+
+ assert(sp != 0);
+ /* In a really sneaky (and really incorrect, and untruthful, and
+ * troublesome, and error-prone) maneuver that completely goes against
+ * the spirit of TIFF, and breaks TIFF, on close, we covertly
+ * modify both bitspersample and sampleformat in the directory to
+ * indicate 8-bit linear. This way, the decode "just works" even for
+ * readers that don't know about PixarLog, or how to set
+ * the PIXARLOGDATFMT pseudo-tag.
+ */
+
+ if (sp->state&PLSTATE_INIT) {
+ /* We test the state to avoid an issue such as in
+ * http://bugzilla.maptools.org/show_bug.cgi?id=2604
+ * What appends in that case is that the bitspersample is 1 and
+ * a TransferFunction is set. The size of the TransferFunction
+ * depends on 1<<bitspersample. So if we increase it, an access
+ * out of the buffer will happen at directory flushing.
+ * Another option would be to clear those targs.
+ */
+ td->td_bitspersample = 8;
+ td->td_sampleformat = SAMPLEFORMAT_UINT;
+ }
+}
+
+static void
+PixarLogCleanup(TIFF* tif)
+{
+ PixarLogState* sp = (PixarLogState*) tif->tif_data;
+
+ assert(sp != 0);
+
+ (void)TIFFPredictorCleanup(tif);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->FromLT2) _TIFFfree(sp->FromLT2);
+ if (sp->From14) _TIFFfree(sp->From14);
+ if (sp->From8) _TIFFfree(sp->From8);
+ if (sp->ToLinearF) _TIFFfree(sp->ToLinearF);
+ if (sp->ToLinear16) _TIFFfree(sp->ToLinear16);
+ if (sp->ToLinear8) _TIFFfree(sp->ToLinear8);
+ if (sp->state&PLSTATE_INIT) {
+ if (tif->tif_mode == O_RDONLY)
+ inflateEnd(&sp->stream);
+ else
+ deflateEnd(&sp->stream);
+ }
+ if (sp->tbuf)
+ _TIFFfree(sp->tbuf);
+ _TIFFfree(sp);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+PixarLogVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "PixarLogVSetField";
+ PixarLogState *sp = (PixarLogState *)tif->tif_data;
+ int result;
+
+ switch (tag) {
+ case TIFFTAG_PIXARLOGQUALITY:
+ sp->quality = (int) va_arg(ap, int);
+ if (tif->tif_mode != O_RDONLY && (sp->state&PLSTATE_INIT)) {
+ if (deflateParams(&sp->stream,
+ sp->quality, Z_DEFAULT_STRATEGY) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib error: %s",
+ sp->stream.msg ? sp->stream.msg : "(null)");
+ return (0);
+ }
+ }
+ return (1);
+ case TIFFTAG_PIXARLOGDATAFMT:
+ sp->user_datafmt = (int) va_arg(ap, int);
+ /* Tweak the TIFF header so that the rest of libtiff knows what
+ * size of data will be passed between app and library, and
+ * assume that the app knows what it is doing and is not
+ * confused by these header manipulations...
+ */
+ switch (sp->user_datafmt) {
+ case PIXARLOGDATAFMT_8BIT:
+ case PIXARLOGDATAFMT_8BITABGR:
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, 8);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, SAMPLEFORMAT_UINT);
+ break;
+ case PIXARLOGDATAFMT_11BITLOG:
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, 16);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, SAMPLEFORMAT_UINT);
+ break;
+ case PIXARLOGDATAFMT_12BITPICIO:
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, 16);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, SAMPLEFORMAT_INT);
+ break;
+ case PIXARLOGDATAFMT_16BIT:
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, 16);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, SAMPLEFORMAT_UINT);
+ break;
+ case PIXARLOGDATAFMT_FLOAT:
+ TIFFSetField(tif, TIFFTAG_BITSPERSAMPLE, 32);
+ TIFFSetField(tif, TIFFTAG_SAMPLEFORMAT, SAMPLEFORMAT_IEEEFP);
+ break;
+ }
+ /*
+ * Must recalculate sizes should bits/sample change.
+ */
+ tif->tif_tilesize = isTiled(tif) ? TIFFTileSize(tif) : (tmsize_t)(-1);
+ tif->tif_scanlinesize = TIFFScanlineSize(tif);
+ result = 1; /* NB: pseudo tag */
+ break;
+ default:
+ result = (*sp->vsetparent)(tif, tag, ap);
+ }
+ return (result);
+}
+
+static int
+PixarLogVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ PixarLogState *sp = (PixarLogState *)tif->tif_data;
+
+ switch (tag) {
+ case TIFFTAG_PIXARLOGQUALITY:
+ *va_arg(ap, int*) = sp->quality;
+ break;
+ case TIFFTAG_PIXARLOGDATAFMT:
+ *va_arg(ap, int*) = sp->user_datafmt;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return (1);
+}
+
+static const TIFFField pixarlogFields[] = {
+ {TIFFTAG_PIXARLOGDATAFMT, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "", NULL},
+ {TIFFTAG_PIXARLOGQUALITY, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, FALSE, FALSE, "", NULL}
+};
+
+int
+TIFFInitPixarLog(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitPixarLog";
+
+ PixarLogState* sp;
+
+ assert(scheme == COMPRESSION_PIXARLOG);
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, pixarlogFields,
+ TIFFArrayCount(pixarlogFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging PixarLog codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof (PixarLogState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = (PixarLogState*) tif->tif_data;
+ _TIFFmemset(sp, 0, sizeof (*sp));
+ sp->stream.data_type = Z_BINARY;
+ sp->user_datafmt = PIXARLOGDATAFMT_UNKNOWN;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = PixarLogFixupTags;
+ tif->tif_setupdecode = PixarLogSetupDecode;
+ tif->tif_predecode = PixarLogPreDecode;
+ tif->tif_decoderow = PixarLogDecode;
+ tif->tif_decodestrip = PixarLogDecode;
+ tif->tif_decodetile = PixarLogDecode;
+ tif->tif_setupencode = PixarLogSetupEncode;
+ tif->tif_preencode = PixarLogPreEncode;
+ tif->tif_postencode = PixarLogPostEncode;
+ tif->tif_encoderow = PixarLogEncode;
+ tif->tif_encodestrip = PixarLogEncode;
+ tif->tif_encodetile = PixarLogEncode;
+ tif->tif_close = PixarLogClose;
+ tif->tif_cleanup = PixarLogCleanup;
+
+ /* Override SetField so we can handle our private pseudo-tag */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = PixarLogVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = PixarLogVSetField; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->quality = Z_DEFAULT_COMPRESSION; /* default comp. level */
+ sp->state = 0;
+
+ /* we don't wish to use the predictor,
+ * the default is none, which predictor value 1
+ */
+ (void) TIFFPredictorInit(tif);
+
+ /*
+ * build the companding tables
+ */
+ PixarLogMakeTables(sp);
+
+ return (1);
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for PixarLog state block");
+ return (0);
+}
+#endif /* PIXARLOG_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_predict.c b/test/monniaux/tiff-4.0.10/tif_predict.c
new file mode 100644
index 00000000..b775663a
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_predict.c
@@ -0,0 +1,879 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Predictor Tag Support (used by multiple codecs).
+ */
+#include "tiffiop.h"
+#include "tif_predict.h"
+
+#define PredictorState(tif) ((TIFFPredictorState*) (tif)->tif_data)
+
+static int horAcc8(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int horAcc16(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int horAcc32(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int swabHorAcc16(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int swabHorAcc32(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int horDiff8(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int horDiff16(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int horDiff32(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int swabHorDiff16(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int swabHorDiff32(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int fpAcc(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int fpDiff(TIFF* tif, uint8* cp0, tmsize_t cc);
+static int PredictorDecodeRow(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s);
+static int PredictorDecodeTile(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s);
+static int PredictorEncodeRow(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int PredictorEncodeTile(TIFF* tif, uint8* bp0, tmsize_t cc0, uint16 s);
+
+static int
+PredictorSetup(TIFF* tif)
+{
+ static const char module[] = "PredictorSetup";
+
+ TIFFPredictorState* sp = PredictorState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ switch (sp->predictor) /* no differencing */
+ {
+ case PREDICTOR_NONE:
+ return 1;
+ case PREDICTOR_HORIZONTAL:
+ if (td->td_bitspersample != 8
+ && td->td_bitspersample != 16
+ && td->td_bitspersample != 32) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Horizontal differencing \"Predictor\" not supported with %d-bit samples",
+ td->td_bitspersample);
+ return 0;
+ }
+ break;
+ case PREDICTOR_FLOATINGPOINT:
+ if (td->td_sampleformat != SAMPLEFORMAT_IEEEFP) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Floating point \"Predictor\" not supported with %d data format",
+ td->td_sampleformat);
+ return 0;
+ }
+ if (td->td_bitspersample != 16
+ && td->td_bitspersample != 24
+ && td->td_bitspersample != 32
+ && td->td_bitspersample != 64) { /* Should 64 be allowed? */
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Floating point \"Predictor\" not supported with %d-bit samples",
+ td->td_bitspersample);
+ return 0;
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "\"Predictor\" value %d not supported",
+ sp->predictor);
+ return 0;
+ }
+ sp->stride = (td->td_planarconfig == PLANARCONFIG_CONTIG ?
+ td->td_samplesperpixel : 1);
+ /*
+ * Calculate the scanline/tile-width size in bytes.
+ */
+ if (isTiled(tif))
+ sp->rowsize = TIFFTileRowSize(tif);
+ else
+ sp->rowsize = TIFFScanlineSize(tif);
+ if (sp->rowsize == 0)
+ return 0;
+
+ return 1;
+}
+
+static int
+PredictorSetupDecode(TIFF* tif)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ /* Note: when PredictorSetup() fails, the effets of setupdecode() */
+ /* will not be "cancelled" so setupdecode() might be robust to */
+ /* be called several times. */
+ if (!(*sp->setupdecode)(tif) || !PredictorSetup(tif))
+ return 0;
+
+ if (sp->predictor == 2) {
+ switch (td->td_bitspersample) {
+ case 8: sp->decodepfunc = horAcc8; break;
+ case 16: sp->decodepfunc = horAcc16; break;
+ case 32: sp->decodepfunc = horAcc32; break;
+ }
+ /*
+ * Override default decoding method with one that does the
+ * predictor stuff.
+ */
+ if( tif->tif_decoderow != PredictorDecodeRow )
+ {
+ sp->decoderow = tif->tif_decoderow;
+ tif->tif_decoderow = PredictorDecodeRow;
+ sp->decodestrip = tif->tif_decodestrip;
+ tif->tif_decodestrip = PredictorDecodeTile;
+ sp->decodetile = tif->tif_decodetile;
+ tif->tif_decodetile = PredictorDecodeTile;
+ }
+
+ /*
+ * If the data is horizontally differenced 16-bit data that
+ * requires byte-swapping, then it must be byte swapped before
+ * the accumulation step. We do this with a special-purpose
+ * routine and override the normal post decoding logic that
+ * the library setup when the directory was read.
+ */
+ if (tif->tif_flags & TIFF_SWAB) {
+ if (sp->decodepfunc == horAcc16) {
+ sp->decodepfunc = swabHorAcc16;
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ } else if (sp->decodepfunc == horAcc32) {
+ sp->decodepfunc = swabHorAcc32;
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ }
+ }
+ }
+
+ else if (sp->predictor == 3) {
+ sp->decodepfunc = fpAcc;
+ /*
+ * Override default decoding method with one that does the
+ * predictor stuff.
+ */
+ if( tif->tif_decoderow != PredictorDecodeRow )
+ {
+ sp->decoderow = tif->tif_decoderow;
+ tif->tif_decoderow = PredictorDecodeRow;
+ sp->decodestrip = tif->tif_decodestrip;
+ tif->tif_decodestrip = PredictorDecodeTile;
+ sp->decodetile = tif->tif_decodetile;
+ tif->tif_decodetile = PredictorDecodeTile;
+ }
+ /*
+ * The data should not be swapped outside of the floating
+ * point predictor, the accumulation routine should return
+ * byres in the native order.
+ */
+ if (tif->tif_flags & TIFF_SWAB) {
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ }
+ /*
+ * Allocate buffer to keep the decoded bytes before
+ * rearranging in the right order
+ */
+ }
+
+ return 1;
+}
+
+static int
+PredictorSetupEncode(TIFF* tif)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ if (!(*sp->setupencode)(tif) || !PredictorSetup(tif))
+ return 0;
+
+ if (sp->predictor == 2) {
+ switch (td->td_bitspersample) {
+ case 8: sp->encodepfunc = horDiff8; break;
+ case 16: sp->encodepfunc = horDiff16; break;
+ case 32: sp->encodepfunc = horDiff32; break;
+ }
+ /*
+ * Override default encoding method with one that does the
+ * predictor stuff.
+ */
+ if( tif->tif_encoderow != PredictorEncodeRow )
+ {
+ sp->encoderow = tif->tif_encoderow;
+ tif->tif_encoderow = PredictorEncodeRow;
+ sp->encodestrip = tif->tif_encodestrip;
+ tif->tif_encodestrip = PredictorEncodeTile;
+ sp->encodetile = tif->tif_encodetile;
+ tif->tif_encodetile = PredictorEncodeTile;
+ }
+
+ /*
+ * If the data is horizontally differenced 16-bit data that
+ * requires byte-swapping, then it must be byte swapped after
+ * the differentiation step. We do this with a special-purpose
+ * routine and override the normal post decoding logic that
+ * the library setup when the directory was read.
+ */
+ if (tif->tif_flags & TIFF_SWAB) {
+ if (sp->encodepfunc == horDiff16) {
+ sp->encodepfunc = swabHorDiff16;
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ } else if (sp->encodepfunc == horDiff32) {
+ sp->encodepfunc = swabHorDiff32;
+ tif->tif_postdecode = _TIFFNoPostDecode;
+ }
+ }
+ }
+
+ else if (sp->predictor == 3) {
+ sp->encodepfunc = fpDiff;
+ /*
+ * Override default encoding method with one that does the
+ * predictor stuff.
+ */
+ if( tif->tif_encoderow != PredictorEncodeRow )
+ {
+ sp->encoderow = tif->tif_encoderow;
+ tif->tif_encoderow = PredictorEncodeRow;
+ sp->encodestrip = tif->tif_encodestrip;
+ tif->tif_encodestrip = PredictorEncodeTile;
+ sp->encodetile = tif->tif_encodetile;
+ tif->tif_encodetile = PredictorEncodeTile;
+ }
+ }
+
+ return 1;
+}
+
+#define REPEAT4(n, op) \
+ switch (n) { \
+ default: { \
+ tmsize_t i; for (i = n-4; i > 0; i--) { op; } } /*-fallthrough*/ \
+ case 4: op; /*-fallthrough*/ \
+ case 3: op; /*-fallthrough*/ \
+ case 2: op; /*-fallthrough*/ \
+ case 1: op; /*-fallthrough*/ \
+ case 0: ; \
+ }
+
+/* Remarks related to C standard compliance in all below functions : */
+/* - to avoid any undefined behaviour, we only operate on unsigned types */
+/* since the behaviour of "overflows" is defined (wrap over) */
+/* - when storing into the byte stream, we explicitly mask with 0xff so */
+/* as to make icc -check=conversions happy (not necessary by the standard) */
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horAcc8(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ tmsize_t stride = PredictorState(tif)->stride;
+
+ unsigned char* cp = (unsigned char*) cp0;
+ if((cc%stride)!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horAcc8",
+ "%s", "(cc%stride)!=0");
+ return 0;
+ }
+
+ if (cc > stride) {
+ /*
+ * Pipeline the most common cases.
+ */
+ if (stride == 3) {
+ unsigned int cr = cp[0];
+ unsigned int cg = cp[1];
+ unsigned int cb = cp[2];
+ cc -= 3;
+ cp += 3;
+ while (cc>0) {
+ cp[0] = (unsigned char) ((cr += cp[0]) & 0xff);
+ cp[1] = (unsigned char) ((cg += cp[1]) & 0xff);
+ cp[2] = (unsigned char) ((cb += cp[2]) & 0xff);
+ cc -= 3;
+ cp += 3;
+ }
+ } else if (stride == 4) {
+ unsigned int cr = cp[0];
+ unsigned int cg = cp[1];
+ unsigned int cb = cp[2];
+ unsigned int ca = cp[3];
+ cc -= 4;
+ cp += 4;
+ while (cc>0) {
+ cp[0] = (unsigned char) ((cr += cp[0]) & 0xff);
+ cp[1] = (unsigned char) ((cg += cp[1]) & 0xff);
+ cp[2] = (unsigned char) ((cb += cp[2]) & 0xff);
+ cp[3] = (unsigned char) ((ca += cp[3]) & 0xff);
+ cc -= 4;
+ cp += 4;
+ }
+ } else {
+ cc -= stride;
+ do {
+ REPEAT4(stride, cp[stride] =
+ (unsigned char) ((cp[stride] + *cp) & 0xff); cp++)
+ cc -= stride;
+ } while (cc>0);
+ }
+ }
+ return 1;
+}
+
+static int
+swabHorAcc16(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ uint16* wp = (uint16*) cp0;
+ tmsize_t wc = cc / 2;
+
+ TIFFSwabArrayOfShort(wp, wc);
+ return horAcc16(tif, cp0, cc);
+}
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horAcc16(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ tmsize_t stride = PredictorState(tif)->stride;
+ uint16* wp = (uint16*) cp0;
+ tmsize_t wc = cc / 2;
+
+ if((cc%(2*stride))!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horAcc16",
+ "%s", "cc%(2*stride))!=0");
+ return 0;
+ }
+
+ if (wc > stride) {
+ wc -= stride;
+ do {
+ REPEAT4(stride, wp[stride] = (uint16)(((unsigned int)wp[stride] + (unsigned int)wp[0]) & 0xffff); wp++)
+ wc -= stride;
+ } while (wc > 0);
+ }
+ return 1;
+}
+
+static int
+swabHorAcc32(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ uint32* wp = (uint32*) cp0;
+ tmsize_t wc = cc / 4;
+
+ TIFFSwabArrayOfLong(wp, wc);
+ return horAcc32(tif, cp0, cc);
+}
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horAcc32(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ tmsize_t stride = PredictorState(tif)->stride;
+ uint32* wp = (uint32*) cp0;
+ tmsize_t wc = cc / 4;
+
+ if((cc%(4*stride))!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horAcc32",
+ "%s", "cc%(4*stride))!=0");
+ return 0;
+ }
+
+ if (wc > stride) {
+ wc -= stride;
+ do {
+ REPEAT4(stride, wp[stride] += wp[0]; wp++)
+ wc -= stride;
+ } while (wc > 0);
+ }
+ return 1;
+}
+
+/*
+ * Floating point predictor accumulation routine.
+ */
+static int
+fpAcc(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ tmsize_t stride = PredictorState(tif)->stride;
+ uint32 bps = tif->tif_dir.td_bitspersample / 8;
+ tmsize_t wc = cc / bps;
+ tmsize_t count = cc;
+ uint8 *cp = (uint8 *) cp0;
+ uint8 *tmp;
+
+ if(cc%(bps*stride)!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "fpAcc",
+ "%s", "cc%(bps*stride))!=0");
+ return 0;
+ }
+
+ tmp = (uint8 *)_TIFFmalloc(cc);
+ if (!tmp)
+ return 0;
+
+ while (count > stride) {
+ REPEAT4(stride, cp[stride] =
+ (unsigned char) ((cp[stride] + cp[0]) & 0xff); cp++)
+ count -= stride;
+ }
+
+ _TIFFmemcpy(tmp, cp0, cc);
+ cp = (uint8 *) cp0;
+ for (count = 0; count < wc; count++) {
+ uint32 byte;
+ for (byte = 0; byte < bps; byte++) {
+ #if WORDS_BIGENDIAN
+ cp[bps * count + byte] = tmp[byte * wc + count];
+ #else
+ cp[bps * count + byte] =
+ tmp[(bps - byte - 1) * wc + count];
+ #endif
+ }
+ }
+ _TIFFfree(tmp);
+ return 1;
+}
+
+/*
+ * Decode a scanline and apply the predictor routine.
+ */
+static int
+PredictorDecodeRow(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s)
+{
+ TIFFPredictorState *sp = PredictorState(tif);
+
+ assert(sp != NULL);
+ assert(sp->decoderow != NULL);
+ assert(sp->decodepfunc != NULL);
+
+ if ((*sp->decoderow)(tif, op0, occ0, s)) {
+ return (*sp->decodepfunc)(tif, op0, occ0);
+ } else
+ return 0;
+}
+
+/*
+ * Decode a tile/strip and apply the predictor routine.
+ * Note that horizontal differencing must be done on a
+ * row-by-row basis. The width of a "row" has already
+ * been calculated at pre-decode time according to the
+ * strip/tile dimensions.
+ */
+static int
+PredictorDecodeTile(TIFF* tif, uint8* op0, tmsize_t occ0, uint16 s)
+{
+ TIFFPredictorState *sp = PredictorState(tif);
+
+ assert(sp != NULL);
+ assert(sp->decodetile != NULL);
+
+ if ((*sp->decodetile)(tif, op0, occ0, s)) {
+ tmsize_t rowsize = sp->rowsize;
+ assert(rowsize > 0);
+ if((occ0%rowsize) !=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "PredictorDecodeTile",
+ "%s", "occ0%rowsize != 0");
+ return 0;
+ }
+ assert(sp->decodepfunc != NULL);
+ while (occ0 > 0) {
+ if( !(*sp->decodepfunc)(tif, op0, rowsize) )
+ return 0;
+ occ0 -= rowsize;
+ op0 += rowsize;
+ }
+ return 1;
+ } else
+ return 0;
+}
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horDiff8(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+ tmsize_t stride = sp->stride;
+ unsigned char* cp = (unsigned char*) cp0;
+
+ if((cc%stride)!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horDiff8",
+ "%s", "(cc%stride)!=0");
+ return 0;
+ }
+
+ if (cc > stride) {
+ cc -= stride;
+ /*
+ * Pipeline the most common cases.
+ */
+ if (stride == 3) {
+ unsigned int r1, g1, b1;
+ unsigned int r2 = cp[0];
+ unsigned int g2 = cp[1];
+ unsigned int b2 = cp[2];
+ do {
+ r1 = cp[3]; cp[3] = (unsigned char)((r1-r2)&0xff); r2 = r1;
+ g1 = cp[4]; cp[4] = (unsigned char)((g1-g2)&0xff); g2 = g1;
+ b1 = cp[5]; cp[5] = (unsigned char)((b1-b2)&0xff); b2 = b1;
+ cp += 3;
+ } while ((cc -= 3) > 0);
+ } else if (stride == 4) {
+ unsigned int r1, g1, b1, a1;
+ unsigned int r2 = cp[0];
+ unsigned int g2 = cp[1];
+ unsigned int b2 = cp[2];
+ unsigned int a2 = cp[3];
+ do {
+ r1 = cp[4]; cp[4] = (unsigned char)((r1-r2)&0xff); r2 = r1;
+ g1 = cp[5]; cp[5] = (unsigned char)((g1-g2)&0xff); g2 = g1;
+ b1 = cp[6]; cp[6] = (unsigned char)((b1-b2)&0xff); b2 = b1;
+ a1 = cp[7]; cp[7] = (unsigned char)((a1-a2)&0xff); a2 = a1;
+ cp += 4;
+ } while ((cc -= 4) > 0);
+ } else {
+ cp += cc - 1;
+ do {
+ REPEAT4(stride, cp[stride] = (unsigned char)((cp[stride] - cp[0])&0xff); cp--)
+ } while ((cc -= stride) > 0);
+ }
+ }
+ return 1;
+}
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horDiff16(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+ tmsize_t stride = sp->stride;
+ uint16 *wp = (uint16*) cp0;
+ tmsize_t wc = cc/2;
+
+ if((cc%(2*stride))!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horDiff8",
+ "%s", "(cc%(2*stride))!=0");
+ return 0;
+ }
+
+ if (wc > stride) {
+ wc -= stride;
+ wp += wc - 1;
+ do {
+ REPEAT4(stride, wp[stride] = (uint16)(((unsigned int)wp[stride] - (unsigned int)wp[0]) & 0xffff); wp--)
+ wc -= stride;
+ } while (wc > 0);
+ }
+ return 1;
+}
+
+static int
+swabHorDiff16(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ uint16* wp = (uint16*) cp0;
+ tmsize_t wc = cc / 2;
+
+ if( !horDiff16(tif, cp0, cc) )
+ return 0;
+
+ TIFFSwabArrayOfShort(wp, wc);
+ return 1;
+}
+
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+horDiff32(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+ tmsize_t stride = sp->stride;
+ uint32 *wp = (uint32*) cp0;
+ tmsize_t wc = cc/4;
+
+ if((cc%(4*stride))!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "horDiff32",
+ "%s", "(cc%(4*stride))!=0");
+ return 0;
+ }
+
+ if (wc > stride) {
+ wc -= stride;
+ wp += wc - 1;
+ do {
+ REPEAT4(stride, wp[stride] -= wp[0]; wp--)
+ wc -= stride;
+ } while (wc > 0);
+ }
+ return 1;
+}
+
+static int
+swabHorDiff32(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ uint32* wp = (uint32*) cp0;
+ tmsize_t wc = cc / 4;
+
+ if( !horDiff32(tif, cp0, cc) )
+ return 0;
+
+ TIFFSwabArrayOfLong(wp, wc);
+ return 1;
+}
+
+/*
+ * Floating point predictor differencing routine.
+ */
+TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+static int
+fpDiff(TIFF* tif, uint8* cp0, tmsize_t cc)
+{
+ tmsize_t stride = PredictorState(tif)->stride;
+ uint32 bps = tif->tif_dir.td_bitspersample / 8;
+ tmsize_t wc = cc / bps;
+ tmsize_t count;
+ uint8 *cp = (uint8 *) cp0;
+ uint8 *tmp;
+
+ if((cc%(bps*stride))!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "fpDiff",
+ "%s", "(cc%(bps*stride))!=0");
+ return 0;
+ }
+
+ tmp = (uint8 *)_TIFFmalloc(cc);
+ if (!tmp)
+ return 0;
+
+ _TIFFmemcpy(tmp, cp0, cc);
+ for (count = 0; count < wc; count++) {
+ uint32 byte;
+ for (byte = 0; byte < bps; byte++) {
+ #if WORDS_BIGENDIAN
+ cp[byte * wc + count] = tmp[bps * count + byte];
+ #else
+ cp[(bps - byte - 1) * wc + count] =
+ tmp[bps * count + byte];
+ #endif
+ }
+ }
+ _TIFFfree(tmp);
+
+ cp = (uint8 *) cp0;
+ cp += cc - stride - 1;
+ for (count = cc; count > stride; count -= stride)
+ REPEAT4(stride, cp[stride] = (unsigned char)((cp[stride] - cp[0])&0xff); cp--)
+ return 1;
+}
+
+static int
+PredictorEncodeRow(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ TIFFPredictorState *sp = PredictorState(tif);
+
+ assert(sp != NULL);
+ assert(sp->encodepfunc != NULL);
+ assert(sp->encoderow != NULL);
+
+ /* XXX horizontal differencing alters user's data XXX */
+ if( !(*sp->encodepfunc)(tif, bp, cc) )
+ return 0;
+ return (*sp->encoderow)(tif, bp, cc, s);
+}
+
+static int
+PredictorEncodeTile(TIFF* tif, uint8* bp0, tmsize_t cc0, uint16 s)
+{
+ static const char module[] = "PredictorEncodeTile";
+ TIFFPredictorState *sp = PredictorState(tif);
+ uint8 *working_copy;
+ tmsize_t cc = cc0, rowsize;
+ unsigned char* bp;
+ int result_code;
+
+ assert(sp != NULL);
+ assert(sp->encodepfunc != NULL);
+ assert(sp->encodetile != NULL);
+
+ /*
+ * Do predictor manipulation in a working buffer to avoid altering
+ * the callers buffer. http://trac.osgeo.org/gdal/ticket/1965
+ */
+ working_copy = (uint8*) _TIFFmalloc(cc0);
+ if( working_copy == NULL )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Out of memory allocating " TIFF_SSIZE_FORMAT " byte temp buffer.",
+ cc0 );
+ return 0;
+ }
+ memcpy( working_copy, bp0, cc0 );
+ bp = working_copy;
+
+ rowsize = sp->rowsize;
+ assert(rowsize > 0);
+ if((cc0%rowsize)!=0)
+ {
+ TIFFErrorExt(tif->tif_clientdata, "PredictorEncodeTile",
+ "%s", "(cc0%rowsize)!=0");
+ _TIFFfree( working_copy );
+ return 0;
+ }
+ while (cc > 0) {
+ (*sp->encodepfunc)(tif, bp, rowsize);
+ cc -= rowsize;
+ bp += rowsize;
+ }
+ result_code = (*sp->encodetile)(tif, working_copy, cc0, s);
+
+ _TIFFfree( working_copy );
+
+ return result_code;
+}
+
+#define FIELD_PREDICTOR (FIELD_CODEC+0) /* XXX */
+
+static const TIFFField predictFields[] = {
+ { TIFFTAG_PREDICTOR, 1, 1, TIFF_SHORT, 0, TIFF_SETGET_UINT16, TIFF_SETGET_UINT16, FIELD_PREDICTOR, FALSE, FALSE, "Predictor", NULL },
+};
+
+static int
+PredictorVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ TIFFPredictorState *sp = PredictorState(tif);
+
+ assert(sp != NULL);
+ assert(sp->vsetparent != NULL);
+
+ switch (tag) {
+ case TIFFTAG_PREDICTOR:
+ sp->predictor = (uint16) va_arg(ap, uint16_vap);
+ TIFFSetFieldBit(tif, FIELD_PREDICTOR);
+ break;
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+ return 1;
+}
+
+static int
+PredictorVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ TIFFPredictorState *sp = PredictorState(tif);
+
+ assert(sp != NULL);
+ assert(sp->vgetparent != NULL);
+
+ switch (tag) {
+ case TIFFTAG_PREDICTOR:
+ *va_arg(ap, uint16*) = (uint16)sp->predictor;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return 1;
+}
+
+static void
+PredictorPrintDir(TIFF* tif, FILE* fd, long flags)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+
+ (void) flags;
+ if (TIFFFieldSet(tif,FIELD_PREDICTOR)) {
+ fprintf(fd, " Predictor: ");
+ switch (sp->predictor) {
+ case 1: fprintf(fd, "none "); break;
+ case 2: fprintf(fd, "horizontal differencing "); break;
+ case 3: fprintf(fd, "floating point predictor "); break;
+ }
+ fprintf(fd, "%d (0x%x)\n", sp->predictor, sp->predictor);
+ }
+ if (sp->printdir)
+ (*sp->printdir)(tif, fd, flags);
+}
+
+int
+TIFFPredictorInit(TIFF* tif)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+
+ assert(sp != 0);
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, predictFields,
+ TIFFArrayCount(predictFields))) {
+ TIFFErrorExt(tif->tif_clientdata, "TIFFPredictorInit",
+ "Merging Predictor codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield =
+ PredictorVGetField;/* hook for predictor tag */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield =
+ PredictorVSetField;/* hook for predictor tag */
+ sp->printdir = tif->tif_tagmethods.printdir;
+ tif->tif_tagmethods.printdir =
+ PredictorPrintDir; /* hook for predictor tag */
+
+ sp->setupdecode = tif->tif_setupdecode;
+ tif->tif_setupdecode = PredictorSetupDecode;
+ sp->setupencode = tif->tif_setupencode;
+ tif->tif_setupencode = PredictorSetupEncode;
+
+ sp->predictor = 1; /* default value */
+ sp->encodepfunc = NULL; /* no predictor routine */
+ sp->decodepfunc = NULL; /* no predictor routine */
+ return 1;
+}
+
+int
+TIFFPredictorCleanup(TIFF* tif)
+{
+ TIFFPredictorState* sp = PredictorState(tif);
+
+ assert(sp != 0);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+ tif->tif_tagmethods.printdir = sp->printdir;
+ tif->tif_setupdecode = sp->setupdecode;
+ tif->tif_setupencode = sp->setupencode;
+
+ return 1;
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_predict.h b/test/monniaux/tiff-4.0.10/tif_predict.h
new file mode 100644
index 00000000..a326b9b8
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_predict.h
@@ -0,0 +1,81 @@
+/*
+ * Copyright (c) 1995-1997 Sam Leffler
+ * Copyright (c) 1995-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _TIFFPREDICT_
+#define _TIFFPREDICT_
+
+#include "tiffio.h"
+#include "tiffiop.h"
+
+/*
+ * ``Library-private'' Support for the Predictor Tag
+ */
+
+typedef int (*TIFFEncodeDecodeMethod)(TIFF* tif, uint8* buf, tmsize_t size);
+
+/*
+ * Codecs that want to support the Predictor tag must place
+ * this structure first in their private state block so that
+ * the predictor code can cast tif_data to find its state.
+ */
+typedef struct {
+ int predictor; /* predictor tag value */
+ tmsize_t stride; /* sample stride over data */
+ tmsize_t rowsize; /* tile/strip row size */
+
+ TIFFCodeMethod encoderow; /* parent codec encode/decode row */
+ TIFFCodeMethod encodestrip; /* parent codec encode/decode strip */
+ TIFFCodeMethod encodetile; /* parent codec encode/decode tile */
+ TIFFEncodeDecodeMethod encodepfunc; /* horizontal differencer */
+
+ TIFFCodeMethod decoderow; /* parent codec encode/decode row */
+ TIFFCodeMethod decodestrip; /* parent codec encode/decode strip */
+ TIFFCodeMethod decodetile; /* parent codec encode/decode tile */
+ TIFFEncodeDecodeMethod decodepfunc; /* horizontal accumulator */
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+ TIFFPrintMethod printdir; /* super-class method */
+ TIFFBoolMethod setupdecode; /* super-class method */
+ TIFFBoolMethod setupencode; /* super-class method */
+} TIFFPredictorState;
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+extern int TIFFPredictorInit(TIFF*);
+extern int TIFFPredictorCleanup(TIFF*);
+#if defined(__cplusplus)
+}
+#endif
+#endif /* _TIFFPREDICT_ */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_print.c b/test/monniaux/tiff-4.0.10/tif_print.c
new file mode 100644
index 00000000..1d86adbf
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_print.c
@@ -0,0 +1,720 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Directory Printing Support
+ */
+#include "tiffiop.h"
+#include <stdio.h>
+
+#include <ctype.h>
+
+static void
+_TIFFprintAsciiBounded(FILE* fd, const char* cp, size_t max_chars);
+
+static const char * const photoNames[] = {
+ "min-is-white", /* PHOTOMETRIC_MINISWHITE */
+ "min-is-black", /* PHOTOMETRIC_MINISBLACK */
+ "RGB color", /* PHOTOMETRIC_RGB */
+ "palette color (RGB from colormap)", /* PHOTOMETRIC_PALETTE */
+ "transparency mask", /* PHOTOMETRIC_MASK */
+ "separated", /* PHOTOMETRIC_SEPARATED */
+ "YCbCr", /* PHOTOMETRIC_YCBCR */
+ "7 (0x7)",
+ "CIE L*a*b*", /* PHOTOMETRIC_CIELAB */
+ "ICC L*a*b*", /* PHOTOMETRIC_ICCLAB */
+ "ITU L*a*b*" /* PHOTOMETRIC_ITULAB */
+};
+#define NPHOTONAMES (sizeof (photoNames) / sizeof (photoNames[0]))
+
+static const char * const orientNames[] = {
+ "0 (0x0)",
+ "row 0 top, col 0 lhs", /* ORIENTATION_TOPLEFT */
+ "row 0 top, col 0 rhs", /* ORIENTATION_TOPRIGHT */
+ "row 0 bottom, col 0 rhs", /* ORIENTATION_BOTRIGHT */
+ "row 0 bottom, col 0 lhs", /* ORIENTATION_BOTLEFT */
+ "row 0 lhs, col 0 top", /* ORIENTATION_LEFTTOP */
+ "row 0 rhs, col 0 top", /* ORIENTATION_RIGHTTOP */
+ "row 0 rhs, col 0 bottom", /* ORIENTATION_RIGHTBOT */
+ "row 0 lhs, col 0 bottom", /* ORIENTATION_LEFTBOT */
+};
+#define NORIENTNAMES (sizeof (orientNames) / sizeof (orientNames[0]))
+
+static void
+_TIFFPrintField(FILE* fd, const TIFFField *fip,
+ uint32 value_count, void *raw_data)
+{
+ uint32 j;
+
+ fprintf(fd, " %s: ", fip->field_name);
+
+ for(j = 0; j < value_count; j++) {
+ if(fip->field_type == TIFF_BYTE)
+ fprintf(fd, "%u", ((uint8 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_UNDEFINED)
+ fprintf(fd, "0x%x",
+ (unsigned int) ((unsigned char *) raw_data)[j]);
+ else if(fip->field_type == TIFF_SBYTE)
+ fprintf(fd, "%d", ((int8 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_SHORT)
+ fprintf(fd, "%u", ((uint16 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_SSHORT)
+ fprintf(fd, "%d", ((int16 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_LONG)
+ fprintf(fd, "%lu",
+ (unsigned long)((uint32 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_SLONG)
+ fprintf(fd, "%ld", (long)((int32 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_IFD)
+ fprintf(fd, "0x%lx",
+ (unsigned long)((uint32 *) raw_data)[j]);
+ else if(fip->field_type == TIFF_RATIONAL
+ || fip->field_type == TIFF_SRATIONAL
+ || fip->field_type == TIFF_FLOAT)
+ fprintf(fd, "%f", ((float *) raw_data)[j]);
+ else if(fip->field_type == TIFF_LONG8)
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, "%I64u",
+ (unsigned __int64)((uint64 *) raw_data)[j]);
+#else
+ fprintf(fd, "%llu",
+ (unsigned long long)((uint64 *) raw_data)[j]);
+#endif
+ else if(fip->field_type == TIFF_SLONG8)
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, "%I64d", (__int64)((int64 *) raw_data)[j]);
+#else
+ fprintf(fd, "%lld", (long long)((int64 *) raw_data)[j]);
+#endif
+ else if(fip->field_type == TIFF_IFD8)
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, "0x%I64x",
+ (unsigned __int64)((uint64 *) raw_data)[j]);
+#else
+ fprintf(fd, "0x%llx",
+ (unsigned long long)((uint64 *) raw_data)[j]);
+#endif
+ else if(fip->field_type == TIFF_FLOAT)
+ fprintf(fd, "%f", ((float *)raw_data)[j]);
+ else if(fip->field_type == TIFF_DOUBLE)
+ fprintf(fd, "%f", ((double *) raw_data)[j]);
+ else if(fip->field_type == TIFF_ASCII) {
+ fprintf(fd, "%s", (char *) raw_data);
+ break;
+ }
+ else {
+ fprintf(fd, "<unsupported data type in TIFFPrint>");
+ break;
+ }
+
+ if(j < value_count - 1)
+ fprintf(fd, ",");
+ }
+
+ fprintf(fd, "\n");
+}
+
+static int
+_TIFFPrettyPrintField(TIFF* tif, const TIFFField *fip, FILE* fd, uint32 tag,
+ uint32 value_count, void *raw_data)
+{
+ (void) tif;
+
+ /* do not try to pretty print auto-defined fields */
+ if (strncmp(fip->field_name,"Tag ", 4) == 0) {
+ return 0;
+ }
+
+ switch (tag)
+ {
+ case TIFFTAG_INKSET:
+ if (value_count == 2 && fip->field_type == TIFF_SHORT) {
+ fprintf(fd, " Ink Set: ");
+ switch (*((uint16*)raw_data)) {
+ case INKSET_CMYK:
+ fprintf(fd, "CMYK\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ *((uint16*)raw_data),
+ *((uint16*)raw_data));
+ break;
+ }
+ return 1;
+ }
+ return 0;
+
+ case TIFFTAG_DOTRANGE:
+ if (value_count == 2 && fip->field_type == TIFF_SHORT) {
+ fprintf(fd, " Dot Range: %u-%u\n",
+ ((uint16*)raw_data)[0], ((uint16*)raw_data)[1]);
+ return 1;
+ }
+ return 0;
+
+ case TIFFTAG_WHITEPOINT:
+ if (value_count == 2 && fip->field_type == TIFF_RATIONAL) {
+ fprintf(fd, " White Point: %g-%g\n",
+ ((float *)raw_data)[0], ((float *)raw_data)[1]);
+ return 1;
+ }
+ return 0;
+
+ case TIFFTAG_XMLPACKET:
+ {
+ uint32 i;
+
+ fprintf(fd, " XMLPacket (XMP Metadata):\n" );
+ for(i = 0; i < value_count; i++)
+ fputc(((char *)raw_data)[i], fd);
+ fprintf( fd, "\n" );
+ return 1;
+ }
+ case TIFFTAG_RICHTIFFIPTC:
+ /*
+ * XXX: for some weird reason RichTIFFIPTC tag
+ * defined as array of LONG values.
+ */
+ fprintf(fd,
+ " RichTIFFIPTC Data: <present>, %lu bytes\n",
+ (unsigned long) value_count * 4);
+ return 1;
+
+ case TIFFTAG_PHOTOSHOP:
+ fprintf(fd, " Photoshop Data: <present>, %lu bytes\n",
+ (unsigned long) value_count);
+ return 1;
+
+ case TIFFTAG_ICCPROFILE:
+ fprintf(fd, " ICC Profile: <present>, %lu bytes\n",
+ (unsigned long) value_count);
+ return 1;
+
+ case TIFFTAG_STONITS:
+ if (value_count == 1 && fip->field_type == TIFF_DOUBLE) {
+ fprintf(fd,
+ " Sample to Nits conversion factor: %.4e\n",
+ *((double*)raw_data));
+ return 1;
+ }
+ return 0;
+ }
+
+ return 0;
+}
+
+/*
+ * Print the contents of the current directory
+ * to the specified stdio file stream.
+ */
+void
+TIFFPrintDirectory(TIFF* tif, FILE* fd, long flags)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ char *sep;
+ long l, n;
+
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, "TIFF Directory at offset 0x%I64x (%I64u)\n",
+ (unsigned __int64) tif->tif_diroff,
+ (unsigned __int64) tif->tif_diroff);
+#else
+ fprintf(fd, "TIFF Directory at offset 0x%llx (%llu)\n",
+ (unsigned long long) tif->tif_diroff,
+ (unsigned long long) tif->tif_diroff);
+#endif
+ if (TIFFFieldSet(tif,FIELD_SUBFILETYPE)) {
+ fprintf(fd, " Subfile Type:");
+ sep = " ";
+ if (td->td_subfiletype & FILETYPE_REDUCEDIMAGE) {
+ fprintf(fd, "%sreduced-resolution image", sep);
+ sep = "/";
+ }
+ if (td->td_subfiletype & FILETYPE_PAGE) {
+ fprintf(fd, "%smulti-page document", sep);
+ sep = "/";
+ }
+ if (td->td_subfiletype & FILETYPE_MASK)
+ fprintf(fd, "%stransparency mask", sep);
+ fprintf(fd, " (%lu = 0x%lx)\n",
+ (unsigned long) td->td_subfiletype, (long) td->td_subfiletype);
+ }
+ if (TIFFFieldSet(tif,FIELD_IMAGEDIMENSIONS)) {
+ fprintf(fd, " Image Width: %lu Image Length: %lu",
+ (unsigned long) td->td_imagewidth, (unsigned long) td->td_imagelength);
+ if (TIFFFieldSet(tif,FIELD_IMAGEDEPTH))
+ fprintf(fd, " Image Depth: %lu",
+ (unsigned long) td->td_imagedepth);
+ fprintf(fd, "\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_TILEDIMENSIONS)) {
+ fprintf(fd, " Tile Width: %lu Tile Length: %lu",
+ (unsigned long) td->td_tilewidth, (unsigned long) td->td_tilelength);
+ if (TIFFFieldSet(tif,FIELD_TILEDEPTH))
+ fprintf(fd, " Tile Depth: %lu",
+ (unsigned long) td->td_tiledepth);
+ fprintf(fd, "\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_RESOLUTION)) {
+ fprintf(fd, " Resolution: %g, %g",
+ td->td_xresolution, td->td_yresolution);
+ if (TIFFFieldSet(tif,FIELD_RESOLUTIONUNIT)) {
+ switch (td->td_resolutionunit) {
+ case RESUNIT_NONE:
+ fprintf(fd, " (unitless)");
+ break;
+ case RESUNIT_INCH:
+ fprintf(fd, " pixels/inch");
+ break;
+ case RESUNIT_CENTIMETER:
+ fprintf(fd, " pixels/cm");
+ break;
+ default:
+ fprintf(fd, " (unit %u = 0x%x)",
+ td->td_resolutionunit,
+ td->td_resolutionunit);
+ break;
+ }
+ }
+ fprintf(fd, "\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_POSITION))
+ fprintf(fd, " Position: %g, %g\n",
+ td->td_xposition, td->td_yposition);
+ if (TIFFFieldSet(tif,FIELD_BITSPERSAMPLE))
+ fprintf(fd, " Bits/Sample: %u\n", td->td_bitspersample);
+ if (TIFFFieldSet(tif,FIELD_SAMPLEFORMAT)) {
+ fprintf(fd, " Sample Format: ");
+ switch (td->td_sampleformat) {
+ case SAMPLEFORMAT_VOID:
+ fprintf(fd, "void\n");
+ break;
+ case SAMPLEFORMAT_INT:
+ fprintf(fd, "signed integer\n");
+ break;
+ case SAMPLEFORMAT_UINT:
+ fprintf(fd, "unsigned integer\n");
+ break;
+ case SAMPLEFORMAT_IEEEFP:
+ fprintf(fd, "IEEE floating point\n");
+ break;
+ case SAMPLEFORMAT_COMPLEXINT:
+ fprintf(fd, "complex signed integer\n");
+ break;
+ case SAMPLEFORMAT_COMPLEXIEEEFP:
+ fprintf(fd, "complex IEEE floating point\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_sampleformat, td->td_sampleformat);
+ break;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_COMPRESSION)) {
+ const TIFFCodec* c = TIFFFindCODEC(td->td_compression);
+ fprintf(fd, " Compression Scheme: ");
+ if (c)
+ fprintf(fd, "%s\n", c->name);
+ else
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_compression, td->td_compression);
+ }
+ if (TIFFFieldSet(tif,FIELD_PHOTOMETRIC)) {
+ fprintf(fd, " Photometric Interpretation: ");
+ if (td->td_photometric < NPHOTONAMES)
+ fprintf(fd, "%s\n", photoNames[td->td_photometric]);
+ else {
+ switch (td->td_photometric) {
+ case PHOTOMETRIC_LOGL:
+ fprintf(fd, "CIE Log2(L)\n");
+ break;
+ case PHOTOMETRIC_LOGLUV:
+ fprintf(fd, "CIE Log2(L) (u',v')\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_photometric, td->td_photometric);
+ break;
+ }
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_EXTRASAMPLES) && td->td_extrasamples) {
+ uint16 i;
+ fprintf(fd, " Extra Samples: %u<", td->td_extrasamples);
+ sep = "";
+ for (i = 0; i < td->td_extrasamples; i++) {
+ switch (td->td_sampleinfo[i]) {
+ case EXTRASAMPLE_UNSPECIFIED:
+ fprintf(fd, "%sunspecified", sep);
+ break;
+ case EXTRASAMPLE_ASSOCALPHA:
+ fprintf(fd, "%sassoc-alpha", sep);
+ break;
+ case EXTRASAMPLE_UNASSALPHA:
+ fprintf(fd, "%sunassoc-alpha", sep);
+ break;
+ default:
+ fprintf(fd, "%s%u (0x%x)", sep,
+ td->td_sampleinfo[i], td->td_sampleinfo[i]);
+ break;
+ }
+ sep = ", ";
+ }
+ fprintf(fd, ">\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_INKNAMES)) {
+ char* cp;
+ uint16 i;
+ fprintf(fd, " Ink Names: ");
+ i = td->td_samplesperpixel;
+ sep = "";
+ for (cp = td->td_inknames;
+ i > 0 && cp < td->td_inknames + td->td_inknameslen;
+ cp = strchr(cp,'\0')+1, i--) {
+ size_t max_chars =
+ td->td_inknameslen - (cp - td->td_inknames);
+ fputs(sep, fd);
+ _TIFFprintAsciiBounded(fd, cp, max_chars);
+ sep = ", ";
+ }
+ fputs("\n", fd);
+ }
+ if (TIFFFieldSet(tif,FIELD_THRESHHOLDING)) {
+ fprintf(fd, " Thresholding: ");
+ switch (td->td_threshholding) {
+ case THRESHHOLD_BILEVEL:
+ fprintf(fd, "bilevel art scan\n");
+ break;
+ case THRESHHOLD_HALFTONE:
+ fprintf(fd, "halftone or dithered scan\n");
+ break;
+ case THRESHHOLD_ERRORDIFFUSE:
+ fprintf(fd, "error diffused\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_threshholding, td->td_threshholding);
+ break;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_FILLORDER)) {
+ fprintf(fd, " FillOrder: ");
+ switch (td->td_fillorder) {
+ case FILLORDER_MSB2LSB:
+ fprintf(fd, "msb-to-lsb\n");
+ break;
+ case FILLORDER_LSB2MSB:
+ fprintf(fd, "lsb-to-msb\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_fillorder, td->td_fillorder);
+ break;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_YCBCRSUBSAMPLING))
+ {
+ fprintf(fd, " YCbCr Subsampling: %u, %u\n",
+ td->td_ycbcrsubsampling[0], td->td_ycbcrsubsampling[1] );
+ }
+ if (TIFFFieldSet(tif,FIELD_YCBCRPOSITIONING)) {
+ fprintf(fd, " YCbCr Positioning: ");
+ switch (td->td_ycbcrpositioning) {
+ case YCBCRPOSITION_CENTERED:
+ fprintf(fd, "centered\n");
+ break;
+ case YCBCRPOSITION_COSITED:
+ fprintf(fd, "cosited\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_ycbcrpositioning, td->td_ycbcrpositioning);
+ break;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_HALFTONEHINTS))
+ fprintf(fd, " Halftone Hints: light %u dark %u\n",
+ td->td_halftonehints[0], td->td_halftonehints[1]);
+ if (TIFFFieldSet(tif,FIELD_ORIENTATION)) {
+ fprintf(fd, " Orientation: ");
+ if (td->td_orientation < NORIENTNAMES)
+ fprintf(fd, "%s\n", orientNames[td->td_orientation]);
+ else
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_orientation, td->td_orientation);
+ }
+ if (TIFFFieldSet(tif,FIELD_SAMPLESPERPIXEL))
+ fprintf(fd, " Samples/Pixel: %u\n", td->td_samplesperpixel);
+ if (TIFFFieldSet(tif,FIELD_ROWSPERSTRIP)) {
+ fprintf(fd, " Rows/Strip: ");
+ if (td->td_rowsperstrip == (uint32) -1)
+ fprintf(fd, "(infinite)\n");
+ else
+ fprintf(fd, "%lu\n", (unsigned long) td->td_rowsperstrip);
+ }
+ if (TIFFFieldSet(tif,FIELD_MINSAMPLEVALUE))
+ fprintf(fd, " Min Sample Value: %u\n", td->td_minsamplevalue);
+ if (TIFFFieldSet(tif,FIELD_MAXSAMPLEVALUE))
+ fprintf(fd, " Max Sample Value: %u\n", td->td_maxsamplevalue);
+ if (TIFFFieldSet(tif,FIELD_SMINSAMPLEVALUE)) {
+ int i;
+ int count = (tif->tif_flags & TIFF_PERSAMPLE) ? td->td_samplesperpixel : 1;
+ fprintf(fd, " SMin Sample Value:");
+ for (i = 0; i < count; ++i)
+ fprintf(fd, " %g", td->td_sminsamplevalue[i]);
+ fprintf(fd, "\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_SMAXSAMPLEVALUE)) {
+ int i;
+ int count = (tif->tif_flags & TIFF_PERSAMPLE) ? td->td_samplesperpixel : 1;
+ fprintf(fd, " SMax Sample Value:");
+ for (i = 0; i < count; ++i)
+ fprintf(fd, " %g", td->td_smaxsamplevalue[i]);
+ fprintf(fd, "\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_PLANARCONFIG)) {
+ fprintf(fd, " Planar Configuration: ");
+ switch (td->td_planarconfig) {
+ case PLANARCONFIG_CONTIG:
+ fprintf(fd, "single image plane\n");
+ break;
+ case PLANARCONFIG_SEPARATE:
+ fprintf(fd, "separate image planes\n");
+ break;
+ default:
+ fprintf(fd, "%u (0x%x)\n",
+ td->td_planarconfig, td->td_planarconfig);
+ break;
+ }
+ }
+ if (TIFFFieldSet(tif,FIELD_PAGENUMBER))
+ fprintf(fd, " Page Number: %u-%u\n",
+ td->td_pagenumber[0], td->td_pagenumber[1]);
+ if (TIFFFieldSet(tif,FIELD_COLORMAP)) {
+ fprintf(fd, " Color Map: ");
+ if (flags & TIFFPRINT_COLORMAP) {
+ fprintf(fd, "\n");
+ n = 1L<<td->td_bitspersample;
+ for (l = 0; l < n; l++)
+ fprintf(fd, " %5ld: %5u %5u %5u\n",
+ l,
+ td->td_colormap[0][l],
+ td->td_colormap[1][l],
+ td->td_colormap[2][l]);
+ } else
+ fprintf(fd, "(present)\n");
+ }
+ if (TIFFFieldSet(tif,FIELD_REFBLACKWHITE)) {
+ int i;
+ fprintf(fd, " Reference Black/White:\n");
+ for (i = 0; i < 3; i++)
+ fprintf(fd, " %2d: %5g %5g\n", i,
+ td->td_refblackwhite[2*i+0],
+ td->td_refblackwhite[2*i+1]);
+ }
+ if (TIFFFieldSet(tif,FIELD_TRANSFERFUNCTION)) {
+ fprintf(fd, " Transfer Function: ");
+ if (flags & TIFFPRINT_CURVES) {
+ fprintf(fd, "\n");
+ n = 1L<<td->td_bitspersample;
+ for (l = 0; l < n; l++) {
+ uint16 i;
+ fprintf(fd, " %2ld: %5u",
+ l, td->td_transferfunction[0][l]);
+ for (i = 1; i < td->td_samplesperpixel - td->td_extrasamples && i < 3; i++)
+ fprintf(fd, " %5u",
+ td->td_transferfunction[i][l]);
+ fputc('\n', fd);
+ }
+ } else
+ fprintf(fd, "(present)\n");
+ }
+ if (TIFFFieldSet(tif, FIELD_SUBIFD) && (td->td_subifd)) {
+ uint16 i;
+ fprintf(fd, " SubIFD Offsets:");
+ for (i = 0; i < td->td_nsubifd; i++)
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, " %5I64u",
+ (unsigned __int64) td->td_subifd[i]);
+#else
+ fprintf(fd, " %5llu",
+ (unsigned long long) td->td_subifd[i]);
+#endif
+ fputc('\n', fd);
+ }
+
+ /*
+ ** Custom tag support.
+ */
+ {
+ int i;
+ short count;
+
+ count = (short) TIFFGetTagListCount(tif);
+ for(i = 0; i < count; i++) {
+ uint32 tag = TIFFGetTagListEntry(tif, i);
+ const TIFFField *fip;
+ uint32 value_count;
+ int mem_alloc = 0;
+ void *raw_data;
+
+ fip = TIFFFieldWithTag(tif, tag);
+ if(fip == NULL)
+ continue;
+
+ if(fip->field_passcount) {
+ if (fip->field_readcount == TIFF_VARIABLE2 ) {
+ if(TIFFGetField(tif, tag, &value_count, &raw_data) != 1)
+ continue;
+ } else if (fip->field_readcount == TIFF_VARIABLE ) {
+ uint16 small_value_count;
+ if(TIFFGetField(tif, tag, &small_value_count, &raw_data) != 1)
+ continue;
+ value_count = small_value_count;
+ } else {
+ assert (fip->field_readcount == TIFF_VARIABLE
+ || fip->field_readcount == TIFF_VARIABLE2);
+ continue;
+ }
+ } else {
+ if (fip->field_readcount == TIFF_VARIABLE
+ || fip->field_readcount == TIFF_VARIABLE2)
+ value_count = 1;
+ else if (fip->field_readcount == TIFF_SPP)
+ value_count = td->td_samplesperpixel;
+ else
+ value_count = fip->field_readcount;
+ if (fip->field_tag == TIFFTAG_DOTRANGE
+ && strcmp(fip->field_name,"DotRange") == 0) {
+ /* TODO: This is an evil exception and should not have been
+ handled this way ... likely best if we move it into
+ the directory structure with an explicit field in
+ libtiff 4.1 and assign it a FIELD_ value */
+ static uint16 dotrange[2];
+ raw_data = dotrange;
+ TIFFGetField(tif, tag, dotrange+0, dotrange+1);
+ } else if (fip->field_type == TIFF_ASCII
+ || fip->field_readcount == TIFF_VARIABLE
+ || fip->field_readcount == TIFF_VARIABLE2
+ || fip->field_readcount == TIFF_SPP
+ || value_count > 1) {
+ if(TIFFGetField(tif, tag, &raw_data) != 1)
+ continue;
+ } else {
+ raw_data = _TIFFmalloc(
+ _TIFFDataSize(fip->field_type)
+ * value_count);
+ mem_alloc = 1;
+ if(TIFFGetField(tif, tag, raw_data) != 1) {
+ _TIFFfree(raw_data);
+ continue;
+ }
+ }
+ }
+
+ /*
+ * Catch the tags which needs to be specially handled
+ * and pretty print them. If tag not handled in
+ * _TIFFPrettyPrintField() fall down and print it as
+ * any other tag.
+ */
+ if (!_TIFFPrettyPrintField(tif, fip, fd, tag, value_count, raw_data))
+ _TIFFPrintField(fd, fip, value_count, raw_data);
+
+ if(mem_alloc)
+ _TIFFfree(raw_data);
+ }
+ }
+
+ if (tif->tif_tagmethods.printdir)
+ (*tif->tif_tagmethods.printdir)(tif, fd, flags);
+
+ _TIFFFillStriles( tif );
+
+ if ((flags & TIFFPRINT_STRIPS) &&
+ TIFFFieldSet(tif,FIELD_STRIPOFFSETS)) {
+ uint32 s;
+
+ fprintf(fd, " %lu %s:\n",
+ (unsigned long) td->td_nstrips,
+ isTiled(tif) ? "Tiles" : "Strips");
+ for (s = 0; s < td->td_nstrips; s++)
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ fprintf(fd, " %3lu: [%8I64u, %8I64u]\n",
+ (unsigned long) s,
+ td->td_stripoffset ? (unsigned __int64) td->td_stripoffset[s] : 0,
+ td->td_stripbytecount ? (unsigned __int64) td->td_stripbytecount[s] : 0);
+#else
+ fprintf(fd, " %3lu: [%8llu, %8llu]\n",
+ (unsigned long) s,
+ td->td_stripoffset ? (unsigned long long) td->td_stripoffset[s] : 0,
+ td->td_stripbytecount ? (unsigned long long) td->td_stripbytecount[s] : 0);
+#endif
+ }
+}
+
+void
+_TIFFprintAscii(FILE* fd, const char* cp)
+{
+ _TIFFprintAsciiBounded( fd, cp, strlen(cp));
+}
+
+static void
+_TIFFprintAsciiBounded(FILE* fd, const char* cp, size_t max_chars)
+{
+ for (; max_chars > 0 && *cp != '\0'; cp++, max_chars--) {
+ const char* tp;
+
+ if (isprint((int)*cp)) {
+ fputc(*cp, fd);
+ continue;
+ }
+ for (tp = "\tt\bb\rr\nn\vv"; *tp; tp++)
+ if (*tp++ == *cp)
+ break;
+ if (*tp)
+ fprintf(fd, "\\%c", *tp);
+ else
+ fprintf(fd, "\\%03o", *cp & 0xff);
+ }
+}
+
+void
+_TIFFprintAsciiTag(FILE* fd, const char* name, const char* value)
+{
+ fprintf(fd, " %s: \"", name);
+ _TIFFprintAscii(fd, value);
+ fprintf(fd, "\"\n");
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_read.c b/test/monniaux/tiff-4.0.10/tif_read.c
new file mode 100644
index 00000000..e63810cc
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_read.c
@@ -0,0 +1,1577 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ * Scanline-oriented Read Support
+ */
+#include "tiffiop.h"
+#include <stdio.h>
+
+#define TIFF_SIZE_T_MAX ((size_t) ~ ((size_t)0))
+#define TIFF_TMSIZE_T_MAX (tmsize_t)(TIFF_SIZE_T_MAX >> 1)
+
+int TIFFFillStrip(TIFF* tif, uint32 strip);
+int TIFFFillTile(TIFF* tif, uint32 tile);
+static int TIFFStartStrip(TIFF* tif, uint32 strip);
+static int TIFFStartTile(TIFF* tif, uint32 tile);
+static int TIFFCheckRead(TIFF*, int);
+static tmsize_t
+TIFFReadRawStrip1(TIFF* tif, uint32 strip, void* buf, tmsize_t size,const char* module);
+static tmsize_t
+TIFFReadRawTile1(TIFF* tif, uint32 tile, void* buf, tmsize_t size, const char* module);
+
+#define NOSTRIP ((uint32)(-1)) /* undefined state */
+#define NOTILE ((uint32)(-1)) /* undefined state */
+
+#define INITIAL_THRESHOLD (1024 * 1024)
+#define THRESHOLD_MULTIPLIER 10
+#define MAX_THRESHOLD (THRESHOLD_MULTIPLIER * THRESHOLD_MULTIPLIER * THRESHOLD_MULTIPLIER * INITIAL_THRESHOLD)
+
+/* Read 'size' bytes in tif_rawdata buffer starting at offset 'rawdata_offset'
+ * Returns 1 in case of success, 0 otherwise. */
+static int TIFFReadAndRealloc( TIFF* tif, tmsize_t size,
+ tmsize_t rawdata_offset,
+ int is_strip, uint32 strip_or_tile,
+ const char* module )
+{
+#if SIZEOF_SIZE_T == 8
+ tmsize_t threshold = INITIAL_THRESHOLD;
+#endif
+ tmsize_t already_read = 0;
+
+ /* On 64 bit processes, read first a maximum of 1 MB, then 10 MB, etc */
+ /* so as to avoid allocating too much memory in case the file is too */
+ /* short. We could ask for the file size, but this might be */
+ /* expensive with some I/O layers (think of reading a gzipped file) */
+ /* Restrict to 64 bit processes, so as to avoid reallocs() */
+ /* on 32 bit processes where virtual memory is scarce. */
+ while( already_read < size )
+ {
+ tmsize_t bytes_read;
+ tmsize_t to_read = size - already_read;
+#if SIZEOF_SIZE_T == 8
+ if( to_read >= threshold && threshold < MAX_THRESHOLD &&
+ already_read + to_read + rawdata_offset > tif->tif_rawdatasize )
+ {
+ to_read = threshold;
+ threshold *= THRESHOLD_MULTIPLIER;
+ }
+#endif
+ if (already_read + to_read + rawdata_offset > tif->tif_rawdatasize) {
+ uint8* new_rawdata;
+ assert((tif->tif_flags & TIFF_MYBUFFER) != 0);
+ tif->tif_rawdatasize = (tmsize_t)TIFFroundup_64(
+ (uint64)already_read + to_read + rawdata_offset, 1024);
+ if (tif->tif_rawdatasize==0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalid buffer size");
+ return 0;
+ }
+ new_rawdata = (uint8*) _TIFFrealloc(
+ tif->tif_rawdata, tif->tif_rawdatasize);
+ if( new_rawdata == 0 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for data buffer at scanline %lu",
+ (unsigned long) tif->tif_row);
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = 0;
+ tif->tif_rawdatasize = 0;
+ return 0;
+ }
+ tif->tif_rawdata = new_rawdata;
+ }
+
+ bytes_read = TIFFReadFile(tif,
+ tif->tif_rawdata + rawdata_offset + already_read, to_read);
+ already_read += bytes_read;
+ if (bytes_read != to_read) {
+ memset( tif->tif_rawdata + rawdata_offset + already_read, 0,
+ tif->tif_rawdatasize - rawdata_offset - already_read );
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ if( is_strip )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu; got %I64u bytes, "
+ "expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) already_read,
+ (unsigned __int64) size);
+ }
+ else
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at row %lu, col %lu, tile %lu; "
+ "got %I64u bytes, expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) strip_or_tile,
+ (unsigned __int64) already_read,
+ (unsigned __int64) size);
+ }
+#else
+ if( is_strip )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu; got %llu bytes, "
+ "expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) already_read,
+ (unsigned long long) size);
+ }
+ else
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at row %lu, col %lu, tile %lu; "
+ "got %llu bytes, expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) strip_or_tile,
+ (unsigned long long) already_read,
+ (unsigned long long) size);
+ }
+#endif
+ return 0;
+ }
+ }
+ return 1;
+}
+
+
+static int
+TIFFFillStripPartial( TIFF *tif, int strip, tmsize_t read_ahead, int restart )
+{
+ static const char module[] = "TIFFFillStripPartial";
+ register TIFFDirectory *td = &tif->tif_dir;
+ tmsize_t unused_data;
+ uint64 read_offset;
+ tmsize_t to_read;
+ tmsize_t read_ahead_mod;
+ /* tmsize_t bytecountm; */
+
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+
+ /*
+ * Expand raw data buffer, if needed, to hold data
+ * strip coming from file (perhaps should set upper
+ * bound on the size of a buffer we'll use?).
+ */
+
+ /* bytecountm=(tmsize_t) td->td_stripbytecount[strip]; */
+
+ /* Not completely sure where the * 2 comes from, but probably for */
+ /* an exponentional growth strategy of tif_rawdatasize */
+ if( read_ahead < TIFF_TMSIZE_T_MAX / 2 )
+ read_ahead_mod = read_ahead * 2;
+ else
+ read_ahead_mod = read_ahead;
+ if (read_ahead_mod > tif->tif_rawdatasize) {
+ assert( restart );
+
+ tif->tif_curstrip = NOSTRIP;
+ if ((tif->tif_flags & TIFF_MYBUFFER) == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Data buffer too small to hold part of strip %lu",
+ (unsigned long) strip);
+ return (0);
+ }
+ }
+
+ if( restart )
+ {
+ tif->tif_rawdataloaded = 0;
+ tif->tif_rawdataoff = 0;
+ }
+
+ /*
+ ** If we are reading more data, move any unused data to the
+ ** start of the buffer.
+ */
+ if( tif->tif_rawdataloaded > 0 )
+ unused_data = tif->tif_rawdataloaded - (tif->tif_rawcp - tif->tif_rawdata);
+ else
+ unused_data = 0;
+
+ if( unused_data > 0 )
+ {
+ assert((tif->tif_flags&TIFF_BUFFERMMAP)==0);
+ memmove( tif->tif_rawdata, tif->tif_rawcp, unused_data );
+ }
+
+ /*
+ ** Seek to the point in the file where more data should be read.
+ */
+ read_offset = td->td_stripoffset[strip]
+ + tif->tif_rawdataoff + tif->tif_rawdataloaded;
+
+ if (!SeekOK(tif, read_offset)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at scanline %lu, strip %lu",
+ (unsigned long) tif->tif_row, (unsigned long) strip);
+ return 0;
+ }
+
+ /*
+ ** How much do we want to read?
+ */
+ if( read_ahead_mod > tif->tif_rawdatasize )
+ to_read = read_ahead_mod - unused_data;
+ else
+ to_read = tif->tif_rawdatasize - unused_data;
+ if( (uint64) to_read > td->td_stripbytecount[strip]
+ - tif->tif_rawdataoff - tif->tif_rawdataloaded )
+ {
+ to_read = (tmsize_t) td->td_stripbytecount[strip]
+ - tif->tif_rawdataoff - tif->tif_rawdataloaded;
+ }
+
+ assert((tif->tif_flags&TIFF_BUFFERMMAP)==0);
+ if( !TIFFReadAndRealloc( tif, to_read, unused_data,
+ 1, /* is_strip */
+ 0, /* strip_or_tile */
+ module) )
+ {
+ return 0;
+ }
+
+ tif->tif_rawdataoff = tif->tif_rawdataoff + tif->tif_rawdataloaded - unused_data ;
+ tif->tif_rawdataloaded = unused_data + to_read;
+
+ tif->tif_rawcc = tif->tif_rawdataloaded;
+ tif->tif_rawcp = tif->tif_rawdata;
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0) {
+ assert((tif->tif_flags&TIFF_BUFFERMMAP)==0);
+ TIFFReverseBits(tif->tif_rawdata + unused_data, to_read );
+ }
+
+ /*
+ ** When starting a strip from the beginning we need to
+ ** restart the decoder.
+ */
+ if( restart )
+ {
+
+#ifdef JPEG_SUPPORT
+ /* A bit messy since breaks the codec abstraction. Ultimately */
+ /* there should be a function pointer for that, but it seems */
+ /* only JPEG is affected. */
+ /* For JPEG, if there are multiple scans (can generally be known */
+ /* with the read_ahead used), we need to read the whole strip */
+ if( tif->tif_dir.td_compression==COMPRESSION_JPEG &&
+ (uint64)tif->tif_rawcc < td->td_stripbytecount[strip] )
+ {
+ if( TIFFJPEGIsFullStripRequired(tif) )
+ {
+ return TIFFFillStrip(tif, strip);
+ }
+ }
+#endif
+
+ return TIFFStartStrip(tif, strip);
+ }
+ else
+ {
+ return 1;
+ }
+}
+
+/*
+ * Seek to a random row+sample in a file.
+ *
+ * Only used by TIFFReadScanline, and is only used on
+ * strip organized files. We do some tricky stuff to try
+ * and avoid reading the whole compressed raw data for big
+ * strips.
+ */
+static int
+TIFFSeek(TIFF* tif, uint32 row, uint16 sample )
+{
+ register TIFFDirectory *td = &tif->tif_dir;
+ uint32 strip;
+ int whole_strip;
+ tmsize_t read_ahead = 0;
+
+ /*
+ ** Establish what strip we are working from.
+ */
+ if (row >= td->td_imagelength) { /* out of range */
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Row out of range, max %lu",
+ (unsigned long) row,
+ (unsigned long) td->td_imagelength);
+ return (0);
+ }
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ if (sample >= td->td_samplesperpixel) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Sample out of range, max %lu",
+ (unsigned long) sample, (unsigned long) td->td_samplesperpixel);
+ return (0);
+ }
+ strip = (uint32)sample*td->td_stripsperimage + row/td->td_rowsperstrip;
+ } else
+ strip = row / td->td_rowsperstrip;
+
+ /*
+ * Do we want to treat this strip as one whole chunk or
+ * read it a few lines at a time?
+ */
+#if defined(CHUNKY_STRIP_READ_SUPPORT)
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+ whole_strip = tif->tif_dir.td_stripbytecount[strip] < 10
+ || isMapped(tif);
+ if( td->td_compression == COMPRESSION_LERC ||
+ td->td_compression == COMPRESSION_JBIG )
+ {
+ /* Ideally plugins should have a way to declare they don't support
+ * chunk strip */
+ whole_strip = 1;
+ }
+#else
+ whole_strip = 1;
+#endif
+
+ if( !whole_strip )
+ {
+ /* 16 is for YCbCr mode where we may need to read 16 */
+ /* lines at a time to get a decompressed line, and 5000 */
+ /* is some constant value, for example for JPEG tables */
+ if( tif->tif_scanlinesize < TIFF_TMSIZE_T_MAX / 16 &&
+ tif->tif_scanlinesize * 16 < TIFF_TMSIZE_T_MAX - 5000 )
+ {
+ read_ahead = tif->tif_scanlinesize * 16 + 5000;
+ }
+ else
+ {
+ read_ahead = tif->tif_scanlinesize;
+ }
+ }
+
+ /*
+ * If we haven't loaded this strip, do so now, possibly
+ * only reading the first part.
+ */
+ if (strip != tif->tif_curstrip) { /* different strip, refill */
+
+ if( whole_strip )
+ {
+ if (!TIFFFillStrip(tif, strip))
+ return (0);
+ }
+ else
+ {
+ if( !TIFFFillStripPartial(tif,strip,read_ahead,1) )
+ return 0;
+ }
+ }
+
+ /*
+ ** If we already have some data loaded, do we need to read some more?
+ */
+ else if( !whole_strip )
+ {
+ if( ((tif->tif_rawdata + tif->tif_rawdataloaded) - tif->tif_rawcp) < read_ahead
+ && (uint64) tif->tif_rawdataoff+tif->tif_rawdataloaded < td->td_stripbytecount[strip] )
+ {
+ if( !TIFFFillStripPartial(tif,strip,read_ahead,0) )
+ return 0;
+ }
+ }
+
+ if (row < tif->tif_row) {
+ /*
+ * Moving backwards within the same strip: backup
+ * to the start and then decode forward (below).
+ *
+ * NB: If you're planning on lots of random access within a
+ * strip, it's better to just read and decode the entire
+ * strip, and then access the decoded data in a random fashion.
+ */
+
+ if( tif->tif_rawdataoff != 0 )
+ {
+ if( !TIFFFillStripPartial(tif,strip,read_ahead,1) )
+ return 0;
+ }
+ else
+ {
+ if (!TIFFStartStrip(tif, strip))
+ return (0);
+ }
+ }
+
+ if (row != tif->tif_row) {
+ /*
+ * Seek forward to the desired row.
+ */
+
+ /* TODO: Will this really work with partial buffers? */
+
+ if (!(*tif->tif_seek)(tif, row - tif->tif_row))
+ return (0);
+ tif->tif_row = row;
+ }
+
+ return (1);
+}
+
+int
+TIFFReadScanline(TIFF* tif, void* buf, uint32 row, uint16 sample)
+{
+ int e;
+
+ if (!TIFFCheckRead(tif, 0))
+ return (-1);
+ if( (e = TIFFSeek(tif, row, sample)) != 0) {
+ /*
+ * Decompress desired row into user buffer.
+ */
+ e = (*tif->tif_decoderow)
+ (tif, (uint8*) buf, tif->tif_scanlinesize, sample);
+
+ /* we are now poised at the beginning of the next row */
+ tif->tif_row = row + 1;
+
+ if (e)
+ (*tif->tif_postdecode)(tif, (uint8*) buf,
+ tif->tif_scanlinesize);
+ }
+ return (e > 0 ? 1 : -1);
+}
+
+/*
+ * Calculate the strip size according to the number of
+ * rows in the strip (check for truncated last strip on any
+ * of the separations).
+ */
+static tmsize_t TIFFReadEncodedStripGetStripSize(TIFF* tif, uint32 strip, uint16* pplane)
+{
+ static const char module[] = "TIFFReadEncodedStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 rowsperstrip;
+ uint32 stripsperplane;
+ uint32 stripinplane;
+ uint32 rows;
+ tmsize_t stripsize;
+ if (!TIFFCheckRead(tif,0))
+ return((tmsize_t)(-1));
+ if (strip>=td->td_nstrips)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "%lu: Strip out of range, max %lu",(unsigned long)strip,
+ (unsigned long)td->td_nstrips);
+ return((tmsize_t)(-1));
+ }
+
+ rowsperstrip=td->td_rowsperstrip;
+ if (rowsperstrip>td->td_imagelength)
+ rowsperstrip=td->td_imagelength;
+ stripsperplane= TIFFhowmany_32_maxuint_compat(td->td_imagelength, rowsperstrip);
+ stripinplane=(strip%stripsperplane);
+ if( pplane ) *pplane=(uint16)(strip/stripsperplane);
+ rows=td->td_imagelength-stripinplane*rowsperstrip;
+ if (rows>rowsperstrip)
+ rows=rowsperstrip;
+ stripsize=TIFFVStripSize(tif,rows);
+ if (stripsize==0)
+ return((tmsize_t)(-1));
+ return stripsize;
+}
+
+/*
+ * Read a strip of data and decompress the specified
+ * amount into the user-supplied buffer.
+ */
+tmsize_t
+TIFFReadEncodedStrip(TIFF* tif, uint32 strip, void* buf, tmsize_t size)
+{
+ static const char module[] = "TIFFReadEncodedStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ tmsize_t stripsize;
+ uint16 plane;
+
+ stripsize=TIFFReadEncodedStripGetStripSize(tif, strip, &plane);
+ if (stripsize==((tmsize_t)(-1)))
+ return((tmsize_t)(-1));
+
+ /* shortcut to avoid an extra memcpy() */
+ if( td->td_compression == COMPRESSION_NONE &&
+ size!=(tmsize_t)(-1) && size >= stripsize &&
+ !isMapped(tif) &&
+ ((tif->tif_flags&TIFF_NOREADRAW)==0) )
+ {
+ if (TIFFReadRawStrip1(tif, strip, buf, stripsize, module) != stripsize)
+ return ((tmsize_t)(-1));
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits(buf,stripsize);
+
+ (*tif->tif_postdecode)(tif,buf,stripsize);
+ return (stripsize);
+ }
+
+ if ((size!=(tmsize_t)(-1))&&(size<stripsize))
+ stripsize=size;
+ if (!TIFFFillStrip(tif,strip))
+ return((tmsize_t)(-1));
+ if ((*tif->tif_decodestrip)(tif,buf,stripsize,plane)<=0)
+ return((tmsize_t)(-1));
+ (*tif->tif_postdecode)(tif,buf,stripsize);
+ return(stripsize);
+}
+
+/* Variant of TIFFReadEncodedStrip() that does
+ * * if *buf == NULL, *buf = _TIFFmalloc(bufsizetoalloc) only after TIFFFillStrip() has
+ * succeeded. This avoid excessive memory allocation in case of truncated
+ * file.
+ * * calls regular TIFFReadEncodedStrip() if *buf != NULL
+ */
+tmsize_t
+_TIFFReadEncodedStripAndAllocBuffer(TIFF* tif, uint32 strip,
+ void **buf, tmsize_t bufsizetoalloc,
+ tmsize_t size_to_read)
+{
+ tmsize_t this_stripsize;
+ uint16 plane;
+
+ if( *buf != NULL )
+ {
+ return TIFFReadEncodedStrip(tif, strip, *buf, size_to_read);
+ }
+
+ this_stripsize=TIFFReadEncodedStripGetStripSize(tif, strip, &plane);
+ if (this_stripsize==((tmsize_t)(-1)))
+ return((tmsize_t)(-1));
+
+ if ((size_to_read!=(tmsize_t)(-1))&&(size_to_read<this_stripsize))
+ this_stripsize=size_to_read;
+ if (!TIFFFillStrip(tif,strip))
+ return((tmsize_t)(-1));
+
+ *buf = _TIFFmalloc(bufsizetoalloc);
+ if (*buf == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif), "No space for strip buffer");
+ return((tmsize_t)(-1));
+ }
+ _TIFFmemset(*buf, 0, bufsizetoalloc);
+
+ if ((*tif->tif_decodestrip)(tif,*buf,this_stripsize,plane)<=0)
+ return((tmsize_t)(-1));
+ (*tif->tif_postdecode)(tif,*buf,this_stripsize);
+ return(this_stripsize);
+
+
+}
+
+static tmsize_t
+TIFFReadRawStrip1(TIFF* tif, uint32 strip, void* buf, tmsize_t size,
+ const char* module)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!_TIFFFillStriles( tif ))
+ return ((tmsize_t)(-1));
+
+ assert((tif->tif_flags&TIFF_NOREADRAW)==0);
+ if (!isMapped(tif)) {
+ tmsize_t cc;
+
+ if (!SeekOK(tif, td->td_stripoffset[strip])) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at scanline %lu, strip %lu",
+ (unsigned long) tif->tif_row, (unsigned long) strip);
+ return ((tmsize_t)(-1));
+ }
+ cc = TIFFReadFile(tif, buf, size);
+ if (cc != size) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu; got %I64u bytes, expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) cc,
+ (unsigned __int64) size);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu; got %llu bytes, expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) cc,
+ (unsigned long long) size);
+#endif
+ return ((tmsize_t)(-1));
+ }
+ } else {
+ tmsize_t ma = 0;
+ tmsize_t n;
+ if ((td->td_stripoffset[strip] > (uint64)TIFF_TMSIZE_T_MAX)||
+ ((ma=(tmsize_t)td->td_stripoffset[strip])>tif->tif_size))
+ {
+ n=0;
+ }
+ else if( ma > TIFF_TMSIZE_T_MAX - size )
+ {
+ n=0;
+ }
+ else
+ {
+ tmsize_t mb=ma+size;
+ if (mb>tif->tif_size)
+ n=tif->tif_size-ma;
+ else
+ n=size;
+ }
+ if (n!=size) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu, strip %lu; got %I64u bytes, expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned long) strip,
+ (unsigned __int64) n,
+ (unsigned __int64) size);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at scanline %lu, strip %lu; got %llu bytes, expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) strip,
+ (unsigned long long) n,
+ (unsigned long long) size);
+#endif
+ return ((tmsize_t)(-1));
+ }
+ _TIFFmemcpy(buf, tif->tif_base + ma,
+ size);
+ }
+ return (size);
+}
+
+static tmsize_t
+TIFFReadRawStripOrTile2(TIFF* tif, uint32 strip_or_tile, int is_strip,
+ tmsize_t size, const char* module)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ assert( !isMapped(tif) );
+ assert((tif->tif_flags&TIFF_NOREADRAW)==0);
+
+ if (!SeekOK(tif, td->td_stripoffset[strip_or_tile])) {
+ if( is_strip )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at scanline %lu, strip %lu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) strip_or_tile);
+ }
+ else
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at row %lu, col %lu, tile %lu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) strip_or_tile);
+ }
+ return ((tmsize_t)(-1));
+ }
+
+ if( !TIFFReadAndRealloc( tif, size, 0, is_strip,
+ strip_or_tile, module ) )
+ {
+ return ((tmsize_t)(-1));
+ }
+
+ return (size);
+}
+
+/*
+ * Read a strip of data from the file.
+ */
+tmsize_t
+TIFFReadRawStrip(TIFF* tif, uint32 strip, void* buf, tmsize_t size)
+{
+ static const char module[] = "TIFFReadRawStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 bytecount;
+ tmsize_t bytecountm;
+
+ if (!TIFFCheckRead(tif, 0))
+ return ((tmsize_t)(-1));
+ if (strip >= td->td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Strip out of range, max %lu",
+ (unsigned long) strip,
+ (unsigned long) td->td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+ if (tif->tif_flags&TIFF_NOREADRAW)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Compression scheme does not support access to raw uncompressed data");
+ return ((tmsize_t)(-1));
+ }
+ bytecount = td->td_stripbytecount[strip];
+ if ((int64)bytecount <= 0) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%I64u: Invalid strip byte count, strip %lu",
+ (unsigned __int64) bytecount,
+ (unsigned long) strip);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%llu: Invalid strip byte count, strip %lu",
+ (unsigned long long) bytecount,
+ (unsigned long) strip);
+#endif
+ return ((tmsize_t)(-1));
+ }
+ bytecountm = (tmsize_t)bytecount;
+ if ((uint64)bytecountm!=bytecount) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Integer overflow");
+ return ((tmsize_t)(-1));
+ }
+ if (size != (tmsize_t)(-1) && size < bytecountm)
+ bytecountm = size;
+ return (TIFFReadRawStrip1(tif, strip, buf, bytecountm, module));
+}
+
+/*
+ * Read the specified strip and setup for decoding. The data buffer is
+ * expanded, as necessary, to hold the strip's data.
+ */
+int
+TIFFFillStrip(TIFF* tif, uint32 strip)
+{
+ static const char module[] = "TIFFFillStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+
+ if ((tif->tif_flags&TIFF_NOREADRAW)==0)
+ {
+ uint64 bytecount = td->td_stripbytecount[strip];
+ if ((int64)bytecount <= 0) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalid strip byte count %I64u, strip %lu",
+ (unsigned __int64) bytecount,
+ (unsigned long) strip);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalid strip byte count %llu, strip %lu",
+ (unsigned long long) bytecount,
+ (unsigned long) strip);
+#endif
+ return (0);
+ }
+
+ /* To avoid excessive memory allocations: */
+ /* Byte count should normally not be larger than a number of */
+ /* times the uncompressed size plus some margin */
+ if( bytecount > 1024 * 1024 )
+ {
+ /* 10 and 4096 are just values that could be adjusted. */
+ /* Hopefully they are safe enough for all codecs */
+ tmsize_t stripsize = TIFFStripSize(tif);
+ if( stripsize != 0 &&
+ (bytecount - 4096) / 10 > (uint64)stripsize )
+ {
+ uint64 newbytecount = (uint64)stripsize * 10 + 4096;
+ if( (int64)newbytecount >= 0 )
+ {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Too large strip byte count %I64u, strip %lu. Limiting to %I64u",
+ (unsigned __int64) bytecount,
+ (unsigned long) strip,
+ (unsigned __int64) newbytecount);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Too large strip byte count %llu, strip %lu. Limiting to %llu",
+ (unsigned long long) bytecount,
+ (unsigned long) strip,
+ (unsigned long long) newbytecount);
+#endif
+ bytecount = newbytecount;
+ }
+ }
+ }
+
+ if (isMapped(tif)) {
+ /*
+ * We must check for overflow, potentially causing
+ * an OOB read. Instead of simple
+ *
+ * td->td_stripoffset[strip]+bytecount > tif->tif_size
+ *
+ * comparison (which can overflow) we do the following
+ * two comparisons:
+ */
+ if (bytecount > (uint64)tif->tif_size ||
+ td->td_stripoffset[strip] > (uint64)tif->tif_size - bytecount) {
+ /*
+ * This error message might seem strange, but
+ * it's what would happen if a read were done
+ * instead.
+ */
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+
+ "Read error on strip %lu; "
+ "got %I64u bytes, expected %I64u",
+ (unsigned long) strip,
+ (unsigned __int64) tif->tif_size - td->td_stripoffset[strip],
+ (unsigned __int64) bytecount);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+
+ "Read error on strip %lu; "
+ "got %llu bytes, expected %llu",
+ (unsigned long) strip,
+ (unsigned long long) tif->tif_size - td->td_stripoffset[strip],
+ (unsigned long long) bytecount);
+#endif
+ tif->tif_curstrip = NOSTRIP;
+ return (0);
+ }
+ }
+
+ if (isMapped(tif) &&
+ (isFillOrder(tif, td->td_fillorder)
+ || (tif->tif_flags & TIFF_NOBITREV))) {
+ /*
+ * The image is mapped into memory and we either don't
+ * need to flip bits or the compression routine is
+ * going to handle this operation itself. In this
+ * case, avoid copying the raw data and instead just
+ * reference the data from the memory mapped file
+ * image. This assumes that the decompression
+ * routines do not modify the contents of the raw data
+ * buffer (if they try to, the application will get a
+ * fault since the file is mapped read-only).
+ */
+ if ((tif->tif_flags & TIFF_MYBUFFER) && tif->tif_rawdata) {
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = NULL;
+ tif->tif_rawdatasize = 0;
+ }
+ tif->tif_flags &= ~TIFF_MYBUFFER;
+ tif->tif_rawdatasize = (tmsize_t)bytecount;
+ tif->tif_rawdata = tif->tif_base + (tmsize_t)td->td_stripoffset[strip];
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = (tmsize_t) bytecount;
+
+ /*
+ * When we have tif_rawdata reference directly into the memory mapped file
+ * we need to be pretty careful about how we use the rawdata. It is not
+ * a general purpose working buffer as it normally otherwise is. So we
+ * keep track of this fact to avoid using it improperly.
+ */
+ tif->tif_flags |= TIFF_BUFFERMMAP;
+ } else {
+ /*
+ * Expand raw data buffer, if needed, to hold data
+ * strip coming from file (perhaps should set upper
+ * bound on the size of a buffer we'll use?).
+ */
+ tmsize_t bytecountm;
+ bytecountm=(tmsize_t)bytecount;
+ if ((uint64)bytecountm!=bytecount)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ return(0);
+ }
+ if (bytecountm > tif->tif_rawdatasize) {
+ tif->tif_curstrip = NOSTRIP;
+ if ((tif->tif_flags & TIFF_MYBUFFER) == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Data buffer too small to hold strip %lu",
+ (unsigned long) strip);
+ return (0);
+ }
+ }
+ if (tif->tif_flags&TIFF_BUFFERMMAP) {
+ tif->tif_curstrip = NOSTRIP;
+ tif->tif_rawdata = NULL;
+ tif->tif_rawdatasize = 0;
+ tif->tif_flags &= ~TIFF_BUFFERMMAP;
+ }
+
+ if( isMapped(tif) )
+ {
+ if (bytecountm > tif->tif_rawdatasize &&
+ !TIFFReadBufferSetup(tif, 0, bytecountm))
+ {
+ return (0);
+ }
+ if (TIFFReadRawStrip1(tif, strip, tif->tif_rawdata,
+ bytecountm, module) != bytecountm)
+ {
+ return (0);
+ }
+ }
+ else
+ {
+ if (TIFFReadRawStripOrTile2(tif, strip, 1,
+ bytecountm, module) != bytecountm)
+ {
+ return (0);
+ }
+ }
+
+
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = bytecountm;
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits(tif->tif_rawdata, bytecountm);
+ }
+ }
+ return (TIFFStartStrip(tif, strip));
+}
+
+/*
+ * Tile-oriented Read Support
+ * Contributed by Nancy Cam (Silicon Graphics).
+ */
+
+/*
+ * Read and decompress a tile of data. The
+ * tile is selected by the (x,y,z,s) coordinates.
+ */
+tmsize_t
+TIFFReadTile(TIFF* tif, void* buf, uint32 x, uint32 y, uint32 z, uint16 s)
+{
+ if (!TIFFCheckRead(tif, 1) || !TIFFCheckTile(tif, x, y, z, s))
+ return ((tmsize_t)(-1));
+ return (TIFFReadEncodedTile(tif,
+ TIFFComputeTile(tif, x, y, z, s), buf, (tmsize_t)(-1)));
+}
+
+/*
+ * Read a tile of data and decompress the specified
+ * amount into the user-supplied buffer.
+ */
+tmsize_t
+TIFFReadEncodedTile(TIFF* tif, uint32 tile, void* buf, tmsize_t size)
+{
+ static const char module[] = "TIFFReadEncodedTile";
+ TIFFDirectory *td = &tif->tif_dir;
+ tmsize_t tilesize = tif->tif_tilesize;
+
+ if (!TIFFCheckRead(tif, 1))
+ return ((tmsize_t)(-1));
+ if (tile >= td->td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Tile out of range, max %lu",
+ (unsigned long) tile, (unsigned long) td->td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+
+ /* shortcut to avoid an extra memcpy() */
+ if( td->td_compression == COMPRESSION_NONE &&
+ size!=(tmsize_t)(-1) && size >= tilesize &&
+ !isMapped(tif) &&
+ ((tif->tif_flags&TIFF_NOREADRAW)==0) )
+ {
+ if (TIFFReadRawTile1(tif, tile, buf, tilesize, module) != tilesize)
+ return ((tmsize_t)(-1));
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits(buf,tilesize);
+
+ (*tif->tif_postdecode)(tif,buf,tilesize);
+ return (tilesize);
+ }
+
+ if (size == (tmsize_t)(-1))
+ size = tilesize;
+ else if (size > tilesize)
+ size = tilesize;
+ if (TIFFFillTile(tif, tile) && (*tif->tif_decodetile)(tif,
+ (uint8*) buf, size, (uint16)(tile/td->td_stripsperimage))) {
+ (*tif->tif_postdecode)(tif, (uint8*) buf, size);
+ return (size);
+ } else
+ return ((tmsize_t)(-1));
+}
+
+/* Variant of TIFFReadTile() that does
+ * * if *buf == NULL, *buf = _TIFFmalloc(bufsizetoalloc) only after TIFFFillTile() has
+ * succeeded. This avoid excessive memory allocation in case of truncated
+ * file.
+ * * calls regular TIFFReadEncodedTile() if *buf != NULL
+ */
+tmsize_t
+_TIFFReadTileAndAllocBuffer(TIFF* tif,
+ void **buf, tmsize_t bufsizetoalloc,
+ uint32 x, uint32 y, uint32 z, uint16 s)
+{
+ if (!TIFFCheckRead(tif, 1) || !TIFFCheckTile(tif, x, y, z, s))
+ return ((tmsize_t)(-1));
+ return (_TIFFReadEncodedTileAndAllocBuffer(tif,
+ TIFFComputeTile(tif, x, y, z, s),
+ buf, bufsizetoalloc,
+ (tmsize_t)(-1)));
+}
+
+/* Variant of TIFFReadEncodedTile() that does
+ * * if *buf == NULL, *buf = _TIFFmalloc(bufsizetoalloc) only after TIFFFillTile() has
+ * succeeded. This avoid excessive memory allocation in case of truncated
+ * file.
+ * * calls regular TIFFReadEncodedTile() if *buf != NULL
+ */
+tmsize_t
+_TIFFReadEncodedTileAndAllocBuffer(TIFF* tif, uint32 tile,
+ void **buf, tmsize_t bufsizetoalloc,
+ tmsize_t size_to_read)
+{
+ static const char module[] = "_TIFFReadEncodedTileAndAllocBuffer";
+ TIFFDirectory *td = &tif->tif_dir;
+ tmsize_t tilesize = tif->tif_tilesize;
+
+ if( *buf != NULL )
+ {
+ return TIFFReadEncodedTile(tif, tile, *buf, size_to_read);
+ }
+
+ if (!TIFFCheckRead(tif, 1))
+ return ((tmsize_t)(-1));
+ if (tile >= td->td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Tile out of range, max %lu",
+ (unsigned long) tile, (unsigned long) td->td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+
+ if (!TIFFFillTile(tif,tile))
+ return((tmsize_t)(-1));
+
+ *buf = _TIFFmalloc(bufsizetoalloc);
+ if (*buf == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, TIFFFileName(tif),
+ "No space for tile buffer");
+ return((tmsize_t)(-1));
+ }
+ _TIFFmemset(*buf, 0, bufsizetoalloc);
+
+ if (size_to_read == (tmsize_t)(-1))
+ size_to_read = tilesize;
+ else if (size_to_read > tilesize)
+ size_to_read = tilesize;
+ if( (*tif->tif_decodetile)(tif,
+ (uint8*) *buf, size_to_read, (uint16)(tile/td->td_stripsperimage))) {
+ (*tif->tif_postdecode)(tif, (uint8*) *buf, size_to_read);
+ return (size_to_read);
+ } else
+ return ((tmsize_t)(-1));
+}
+
+static tmsize_t
+TIFFReadRawTile1(TIFF* tif, uint32 tile, void* buf, tmsize_t size, const char* module)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!_TIFFFillStriles( tif ))
+ return ((tmsize_t)(-1));
+
+ assert((tif->tif_flags&TIFF_NOREADRAW)==0);
+ if (!isMapped(tif)) {
+ tmsize_t cc;
+
+ if (!SeekOK(tif, td->td_stripoffset[tile])) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at row %lu, col %lu, tile %lu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) tile);
+ return ((tmsize_t)(-1));
+ }
+ cc = TIFFReadFile(tif, buf, size);
+ if (cc != size) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at row %lu, col %lu; got %I64u bytes, expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned __int64) cc,
+ (unsigned __int64) size);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Read error at row %lu, col %lu; got %llu bytes, expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long long) cc,
+ (unsigned long long) size);
+#endif
+ return ((tmsize_t)(-1));
+ }
+ } else {
+ tmsize_t ma,mb;
+ tmsize_t n;
+ ma=(tmsize_t)td->td_stripoffset[tile];
+ mb=ma+size;
+ if ((td->td_stripoffset[tile] > (uint64)TIFF_TMSIZE_T_MAX)||(ma>tif->tif_size))
+ n=0;
+ else if ((mb<ma)||(mb<size)||(mb>tif->tif_size))
+ n=tif->tif_size-ma;
+ else
+ n=size;
+ if (n!=size) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+"Read error at row %lu, col %lu, tile %lu; got %I64u bytes, expected %I64u",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) tile,
+ (unsigned __int64) n,
+ (unsigned __int64) size);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+"Read error at row %lu, col %lu, tile %lu; got %llu bytes, expected %llu",
+ (unsigned long) tif->tif_row,
+ (unsigned long) tif->tif_col,
+ (unsigned long) tile,
+ (unsigned long long) n,
+ (unsigned long long) size);
+#endif
+ return ((tmsize_t)(-1));
+ }
+ _TIFFmemcpy(buf, tif->tif_base + ma, size);
+ }
+ return (size);
+}
+
+/*
+ * Read a tile of data from the file.
+ */
+tmsize_t
+TIFFReadRawTile(TIFF* tif, uint32 tile, void* buf, tmsize_t size)
+{
+ static const char module[] = "TIFFReadRawTile";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 bytecount64;
+ tmsize_t bytecountm;
+
+ if (!TIFFCheckRead(tif, 1))
+ return ((tmsize_t)(-1));
+ if (tile >= td->td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Tile out of range, max %lu",
+ (unsigned long) tile, (unsigned long) td->td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+ if (tif->tif_flags&TIFF_NOREADRAW)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Compression scheme does not support access to raw uncompressed data");
+ return ((tmsize_t)(-1));
+ }
+ bytecount64 = td->td_stripbytecount[tile];
+ if (size != (tmsize_t)(-1) && (uint64)size < bytecount64)
+ bytecount64 = (uint64)size;
+ bytecountm = (tmsize_t)bytecount64;
+ if ((uint64)bytecountm!=bytecount64)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ return ((tmsize_t)(-1));
+ }
+ return (TIFFReadRawTile1(tif, tile, buf, bytecountm, module));
+}
+
+/*
+ * Read the specified tile and setup for decoding. The data buffer is
+ * expanded, as necessary, to hold the tile's data.
+ */
+int
+TIFFFillTile(TIFF* tif, uint32 tile)
+{
+ static const char module[] = "TIFFFillTile";
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+
+ if ((tif->tif_flags&TIFF_NOREADRAW)==0)
+ {
+ uint64 bytecount = td->td_stripbytecount[tile];
+ if ((int64)bytecount <= 0) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%I64u: Invalid tile byte count, tile %lu",
+ (unsigned __int64) bytecount,
+ (unsigned long) tile);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%llu: Invalid tile byte count, tile %lu",
+ (unsigned long long) bytecount,
+ (unsigned long) tile);
+#endif
+ return (0);
+ }
+
+ /* To avoid excessive memory allocations: */
+ /* Byte count should normally not be larger than a number of */
+ /* times the uncompressed size plus some margin */
+ if( bytecount > 1024 * 1024 )
+ {
+ /* 10 and 4096 are just values that could be adjusted. */
+ /* Hopefully they are safe enough for all codecs */
+ tmsize_t stripsize = TIFFTileSize(tif);
+ if( stripsize != 0 &&
+ (bytecount - 4096) / 10 > (uint64)stripsize )
+ {
+ uint64 newbytecount = (uint64)stripsize * 10 + 4096;
+ if( (int64)newbytecount >= 0 )
+ {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "Too large tile byte count %I64u, tile %lu. Limiting to %I64u",
+ (unsigned __int64) bytecount,
+ (unsigned long) tile,
+ (unsigned __int64) newbytecount);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Too large tile byte count %llu, tile %lu. Limiting to %llu",
+ (unsigned long long) bytecount,
+ (unsigned long) tile,
+ (unsigned long long) newbytecount);
+#endif
+ bytecount = newbytecount;
+ }
+ }
+ }
+
+ if (isMapped(tif)) {
+ /*
+ * We must check for overflow, potentially causing
+ * an OOB read. Instead of simple
+ *
+ * td->td_stripoffset[tile]+bytecount > tif->tif_size
+ *
+ * comparison (which can overflow) we do the following
+ * two comparisons:
+ */
+ if (bytecount > (uint64)tif->tif_size ||
+ td->td_stripoffset[tile] > (uint64)tif->tif_size - bytecount) {
+ tif->tif_curtile = NOTILE;
+ return (0);
+ }
+ }
+
+ if (isMapped(tif) &&
+ (isFillOrder(tif, td->td_fillorder)
+ || (tif->tif_flags & TIFF_NOBITREV))) {
+ /*
+ * The image is mapped into memory and we either don't
+ * need to flip bits or the compression routine is
+ * going to handle this operation itself. In this
+ * case, avoid copying the raw data and instead just
+ * reference the data from the memory mapped file
+ * image. This assumes that the decompression
+ * routines do not modify the contents of the raw data
+ * buffer (if they try to, the application will get a
+ * fault since the file is mapped read-only).
+ */
+ if ((tif->tif_flags & TIFF_MYBUFFER) && tif->tif_rawdata) {
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = NULL;
+ tif->tif_rawdatasize = 0;
+ }
+ tif->tif_flags &= ~TIFF_MYBUFFER;
+
+ tif->tif_rawdatasize = (tmsize_t)bytecount;
+ tif->tif_rawdata =
+ tif->tif_base + (tmsize_t)td->td_stripoffset[tile];
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = (tmsize_t) bytecount;
+ tif->tif_flags |= TIFF_BUFFERMMAP;
+ } else {
+ /*
+ * Expand raw data buffer, if needed, to hold data
+ * tile coming from file (perhaps should set upper
+ * bound on the size of a buffer we'll use?).
+ */
+ tmsize_t bytecountm;
+ bytecountm=(tmsize_t)bytecount;
+ if ((uint64)bytecountm!=bytecount)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ return(0);
+ }
+ if (bytecountm > tif->tif_rawdatasize) {
+ tif->tif_curtile = NOTILE;
+ if ((tif->tif_flags & TIFF_MYBUFFER) == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Data buffer too small to hold tile %lu",
+ (unsigned long) tile);
+ return (0);
+ }
+ }
+ if (tif->tif_flags&TIFF_BUFFERMMAP) {
+ tif->tif_curtile = NOTILE;
+ tif->tif_rawdata = NULL;
+ tif->tif_rawdatasize = 0;
+ tif->tif_flags &= ~TIFF_BUFFERMMAP;
+ }
+
+ if( isMapped(tif) )
+ {
+ if (bytecountm > tif->tif_rawdatasize &&
+ !TIFFReadBufferSetup(tif, 0, bytecountm))
+ {
+ return (0);
+ }
+ if (TIFFReadRawTile1(tif, tile, tif->tif_rawdata,
+ bytecountm, module) != bytecountm)
+ {
+ return (0);
+ }
+ }
+ else
+ {
+ if (TIFFReadRawStripOrTile2(tif, tile, 0,
+ bytecountm, module) != bytecountm)
+ {
+ return (0);
+ }
+ }
+
+
+ tif->tif_rawdataoff = 0;
+ tif->tif_rawdataloaded = bytecountm;
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits(tif->tif_rawdata,
+ tif->tif_rawdataloaded);
+ }
+ }
+ return (TIFFStartTile(tif, tile));
+}
+
+/*
+ * Setup the raw data buffer in preparation for
+ * reading a strip of raw data. If the buffer
+ * is specified as zero, then a buffer of appropriate
+ * size is allocated by the library. Otherwise,
+ * the client must guarantee that the buffer is
+ * large enough to hold any individual strip of
+ * raw data.
+ */
+int
+TIFFReadBufferSetup(TIFF* tif, void* bp, tmsize_t size)
+{
+ static const char module[] = "TIFFReadBufferSetup";
+
+ assert((tif->tif_flags&TIFF_NOREADRAW)==0);
+ tif->tif_flags &= ~TIFF_BUFFERMMAP;
+
+ if (tif->tif_rawdata) {
+ if (tif->tif_flags & TIFF_MYBUFFER)
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_rawdata = NULL;
+ tif->tif_rawdatasize = 0;
+ }
+ if (bp) {
+ tif->tif_rawdatasize = size;
+ tif->tif_rawdata = (uint8*) bp;
+ tif->tif_flags &= ~TIFF_MYBUFFER;
+ } else {
+ tif->tif_rawdatasize = (tmsize_t)TIFFroundup_64((uint64)size, 1024);
+ if (tif->tif_rawdatasize==0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalid buffer size");
+ return (0);
+ }
+ /* Initialize to zero to avoid uninitialized buffers in case of */
+ /* short reads (http://bugzilla.maptools.org/show_bug.cgi?id=2651) */
+ tif->tif_rawdata = (uint8*) _TIFFcalloc(1, tif->tif_rawdatasize);
+ tif->tif_flags |= TIFF_MYBUFFER;
+ }
+ if (tif->tif_rawdata == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for data buffer at scanline %lu",
+ (unsigned long) tif->tif_row);
+ tif->tif_rawdatasize = 0;
+ return (0);
+ }
+ return (1);
+}
+
+/*
+ * Set state to appear as if a
+ * strip has just been read in.
+ */
+static int
+TIFFStartStrip(TIFF* tif, uint32 strip)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+
+ if ((tif->tif_flags & TIFF_CODERSETUP) == 0) {
+ if (!(*tif->tif_setupdecode)(tif))
+ return (0);
+ tif->tif_flags |= TIFF_CODERSETUP;
+ }
+ tif->tif_curstrip = strip;
+ tif->tif_row = (strip % td->td_stripsperimage) * td->td_rowsperstrip;
+ tif->tif_flags &= ~TIFF_BUF4WRITE;
+
+ if (tif->tif_flags&TIFF_NOREADRAW)
+ {
+ tif->tif_rawcp = NULL;
+ tif->tif_rawcc = 0;
+ }
+ else
+ {
+ tif->tif_rawcp = tif->tif_rawdata;
+ if( tif->tif_rawdataloaded > 0 )
+ tif->tif_rawcc = tif->tif_rawdataloaded;
+ else
+ tif->tif_rawcc = (tmsize_t)td->td_stripbytecount[strip];
+ }
+ return ((*tif->tif_predecode)(tif,
+ (uint16)(strip / td->td_stripsperimage)));
+}
+
+/*
+ * Set state to appear as if a
+ * tile has just been read in.
+ */
+static int
+TIFFStartTile(TIFF* tif, uint32 tile)
+{
+ static const char module[] = "TIFFStartTile";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 howmany32;
+
+ if (!_TIFFFillStriles( tif ) || !tif->tif_dir.td_stripbytecount)
+ return 0;
+
+ if ((tif->tif_flags & TIFF_CODERSETUP) == 0) {
+ if (!(*tif->tif_setupdecode)(tif))
+ return (0);
+ tif->tif_flags |= TIFF_CODERSETUP;
+ }
+ tif->tif_curtile = tile;
+ howmany32=TIFFhowmany_32(td->td_imagewidth, td->td_tilewidth);
+ if (howmany32 == 0) {
+ TIFFErrorExt(tif->tif_clientdata,module,"Zero tiles");
+ return 0;
+ }
+ tif->tif_row = (tile % howmany32) * td->td_tilelength;
+ howmany32=TIFFhowmany_32(td->td_imagelength, td->td_tilelength);
+ if (howmany32 == 0) {
+ TIFFErrorExt(tif->tif_clientdata,module,"Zero tiles");
+ return 0;
+ }
+ tif->tif_col = (tile % howmany32) * td->td_tilewidth;
+ tif->tif_flags &= ~TIFF_BUF4WRITE;
+ if (tif->tif_flags&TIFF_NOREADRAW)
+ {
+ tif->tif_rawcp = NULL;
+ tif->tif_rawcc = 0;
+ }
+ else
+ {
+ tif->tif_rawcp = tif->tif_rawdata;
+ if( tif->tif_rawdataloaded > 0 )
+ tif->tif_rawcc = tif->tif_rawdataloaded;
+ else
+ tif->tif_rawcc = (tmsize_t)td->td_stripbytecount[tile];
+ }
+ return ((*tif->tif_predecode)(tif,
+ (uint16)(tile/td->td_stripsperimage)));
+}
+
+static int
+TIFFCheckRead(TIFF* tif, int tiles)
+{
+ if (tif->tif_mode == O_WRONLY) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name, "File not open for reading");
+ return (0);
+ }
+ if (tiles ^ isTiled(tif)) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name, tiles ?
+ "Can not read tiles from a stripped image" :
+ "Can not read scanlines from a tiled image");
+ return (0);
+ }
+ return (1);
+}
+
+void
+_TIFFNoPostDecode(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ (void) tif; (void) buf; (void) cc;
+}
+
+void
+_TIFFSwab16BitData(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ (void) tif;
+ assert((cc & 1) == 0);
+ TIFFSwabArrayOfShort((uint16*) buf, cc/2);
+}
+
+void
+_TIFFSwab24BitData(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ (void) tif;
+ assert((cc % 3) == 0);
+ TIFFSwabArrayOfTriples((uint8*) buf, cc/3);
+}
+
+void
+_TIFFSwab32BitData(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ (void) tif;
+ assert((cc & 3) == 0);
+ TIFFSwabArrayOfLong((uint32*) buf, cc/4);
+}
+
+void
+_TIFFSwab64BitData(TIFF* tif, uint8* buf, tmsize_t cc)
+{
+ (void) tif;
+ assert((cc & 7) == 0);
+ TIFFSwabArrayOfDouble((double*) buf, cc/8);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_strip.c b/test/monniaux/tiff-4.0.10/tif_strip.c
new file mode 100644
index 00000000..5b76fba5
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_strip.c
@@ -0,0 +1,387 @@
+/*
+ * Copyright (c) 1991-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Strip-organized Image Support Routines.
+ */
+#include "tiffiop.h"
+
+/*
+ * Compute which strip a (row,sample) value is in.
+ */
+uint32
+TIFFComputeStrip(TIFF* tif, uint32 row, uint16 sample)
+{
+ static const char module[] = "TIFFComputeStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 strip;
+
+ strip = row / td->td_rowsperstrip;
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ if (sample >= td->td_samplesperpixel) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Sample out of range, max %lu",
+ (unsigned long) sample, (unsigned long) td->td_samplesperpixel);
+ return (0);
+ }
+ strip += (uint32)sample*td->td_stripsperimage;
+ }
+ return (strip);
+}
+
+/*
+ * Compute how many strips are in an image.
+ */
+uint32
+TIFFNumberOfStrips(TIFF* tif)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 nstrips;
+
+ nstrips = (td->td_rowsperstrip == (uint32) -1 ? 1 :
+ TIFFhowmany_32(td->td_imagelength, td->td_rowsperstrip));
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE)
+ nstrips = _TIFFMultiply32(tif, nstrips, (uint32)td->td_samplesperpixel,
+ "TIFFNumberOfStrips");
+ return (nstrips);
+}
+
+/*
+ * Compute the # bytes in a variable height, row-aligned strip.
+ */
+uint64
+TIFFVStripSize64(TIFF* tif, uint32 nrows)
+{
+ static const char module[] = "TIFFVStripSize64";
+ TIFFDirectory *td = &tif->tif_dir;
+ if (nrows==(uint32)(-1))
+ nrows=td->td_imagelength;
+ if ((td->td_planarconfig==PLANARCONFIG_CONTIG)&&
+ (td->td_photometric == PHOTOMETRIC_YCBCR)&&
+ (!isUpSampled(tif)))
+ {
+ /*
+ * Packed YCbCr data contain one Cb+Cr for every
+ * HorizontalSampling*VerticalSampling Y values.
+ * Must also roundup width and height when calculating
+ * since images that are not a multiple of the
+ * horizontal/vertical subsampling area include
+ * YCbCr data for the extended image.
+ */
+ uint16 ycbcrsubsampling[2];
+ uint16 samplingblock_samples;
+ uint32 samplingblocks_hor;
+ uint32 samplingblocks_ver;
+ uint64 samplingrow_samples;
+ uint64 samplingrow_size;
+ if(td->td_samplesperpixel!=3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Invalid td_samplesperpixel value");
+ return 0;
+ }
+ TIFFGetFieldDefaulted(tif,TIFFTAG_YCBCRSUBSAMPLING,ycbcrsubsampling+0,
+ ycbcrsubsampling+1);
+ if ((ycbcrsubsampling[0] != 1 && ycbcrsubsampling[0] != 2 && ycbcrsubsampling[0] != 4)
+ ||(ycbcrsubsampling[1] != 1 && ycbcrsubsampling[1] != 2 && ycbcrsubsampling[1] != 4))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Invalid YCbCr subsampling (%dx%d)",
+ ycbcrsubsampling[0],
+ ycbcrsubsampling[1] );
+ return 0;
+ }
+ samplingblock_samples=ycbcrsubsampling[0]*ycbcrsubsampling[1]+2;
+ samplingblocks_hor=TIFFhowmany_32(td->td_imagewidth,ycbcrsubsampling[0]);
+ samplingblocks_ver=TIFFhowmany_32(nrows,ycbcrsubsampling[1]);
+ samplingrow_samples=_TIFFMultiply64(tif,samplingblocks_hor,samplingblock_samples,module);
+ samplingrow_size=TIFFhowmany8_64(_TIFFMultiply64(tif,samplingrow_samples,td->td_bitspersample,module));
+ return(_TIFFMultiply64(tif,samplingrow_size,samplingblocks_ver,module));
+ }
+ else
+ return(_TIFFMultiply64(tif,nrows,TIFFScanlineSize64(tif),module));
+}
+tmsize_t
+TIFFVStripSize(TIFF* tif, uint32 nrows)
+{
+ static const char module[] = "TIFFVStripSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFVStripSize64(tif,nrows);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Compute the # bytes in a raw strip.
+ */
+uint64
+TIFFRawStripSize64(TIFF* tif, uint32 strip)
+{
+ static const char module[] = "TIFFRawStripSize64";
+ TIFFDirectory* td = &tif->tif_dir;
+ uint64 bytecount = td->td_stripbytecount[strip];
+
+ if (bytecount == 0)
+ {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%I64u: Invalid strip byte count, strip %lu",
+ (unsigned __int64) bytecount,
+ (unsigned long) strip);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%llu: Invalid strip byte count, strip %lu",
+ (unsigned long long) bytecount,
+ (unsigned long) strip);
+#endif
+ bytecount = (uint64) -1;
+ }
+
+ return bytecount;
+}
+tmsize_t
+TIFFRawStripSize(TIFF* tif, uint32 strip)
+{
+ static const char module[] = "TIFFRawStripSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFRawStripSize64(tif,strip);
+ if (m==(uint64)(-1))
+ n=(tmsize_t)(-1);
+ else
+ {
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ }
+ return(n);
+}
+
+/*
+ * Compute the # bytes in a (row-aligned) strip.
+ *
+ * Note that if RowsPerStrip is larger than the
+ * recorded ImageLength, then the strip size is
+ * truncated to reflect the actual space required
+ * to hold the strip.
+ */
+uint64
+TIFFStripSize64(TIFF* tif)
+{
+ TIFFDirectory* td = &tif->tif_dir;
+ uint32 rps = td->td_rowsperstrip;
+ if (rps > td->td_imagelength)
+ rps = td->td_imagelength;
+ return (TIFFVStripSize64(tif, rps));
+}
+tmsize_t
+TIFFStripSize(TIFF* tif)
+{
+ static const char module[] = "TIFFStripSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFStripSize64(tif);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Compute a default strip size based on the image
+ * characteristics and a requested value. If the
+ * request is <1 then we choose a strip size according
+ * to certain heuristics.
+ */
+uint32
+TIFFDefaultStripSize(TIFF* tif, uint32 request)
+{
+ return (*tif->tif_defstripsize)(tif, request);
+}
+
+uint32
+_TIFFDefaultStripSize(TIFF* tif, uint32 s)
+{
+ if ((int32) s < 1) {
+ /*
+ * If RowsPerStrip is unspecified, try to break the
+ * image up into strips that are approximately
+ * STRIP_SIZE_DEFAULT bytes long.
+ */
+ uint64 scanlinesize;
+ uint64 rows;
+ scanlinesize=TIFFScanlineSize64(tif);
+ if (scanlinesize==0)
+ scanlinesize=1;
+ rows=(uint64)STRIP_SIZE_DEFAULT/scanlinesize;
+ if (rows==0)
+ rows=1;
+ else if (rows>0xFFFFFFFF)
+ rows=0xFFFFFFFF;
+ s=(uint32)rows;
+ }
+ return (s);
+}
+
+/*
+ * Return the number of bytes to read/write in a call to
+ * one of the scanline-oriented i/o routines. Note that
+ * this number may be 1/samples-per-pixel if data is
+ * stored as separate planes.
+ * The ScanlineSize in case of YCbCrSubsampling is defined as the
+ * strip size divided by the strip height, i.e. the size of a pack of vertical
+ * subsampling lines divided by vertical subsampling. It should thus make
+ * sense when multiplied by a multiple of vertical subsampling.
+ */
+uint64
+TIFFScanlineSize64(TIFF* tif)
+{
+ static const char module[] = "TIFFScanlineSize64";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 scanline_size;
+ if (td->td_planarconfig==PLANARCONFIG_CONTIG)
+ {
+ if ((td->td_photometric==PHOTOMETRIC_YCBCR)&&
+ (td->td_samplesperpixel==3)&&
+ (!isUpSampled(tif)))
+ {
+ uint16 ycbcrsubsampling[2];
+ uint16 samplingblock_samples;
+ uint32 samplingblocks_hor;
+ uint64 samplingrow_samples;
+ uint64 samplingrow_size;
+ if(td->td_samplesperpixel!=3)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Invalid td_samplesperpixel value");
+ return 0;
+ }
+ TIFFGetFieldDefaulted(tif,TIFFTAG_YCBCRSUBSAMPLING,
+ ycbcrsubsampling+0,
+ ycbcrsubsampling+1);
+ if (((ycbcrsubsampling[0]!=1)&&(ycbcrsubsampling[0]!=2)&&(ycbcrsubsampling[0]!=4)) ||
+ ((ycbcrsubsampling[1]!=1)&&(ycbcrsubsampling[1]!=2)&&(ycbcrsubsampling[1]!=4)))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Invalid YCbCr subsampling");
+ return 0;
+ }
+ samplingblock_samples = ycbcrsubsampling[0]*ycbcrsubsampling[1]+2;
+ samplingblocks_hor = TIFFhowmany_32(td->td_imagewidth,ycbcrsubsampling[0]);
+ samplingrow_samples = _TIFFMultiply64(tif,samplingblocks_hor,samplingblock_samples,module);
+ samplingrow_size = TIFFhowmany_64(_TIFFMultiply64(tif,samplingrow_samples,td->td_bitspersample,module),8);
+ scanline_size = (samplingrow_size/ycbcrsubsampling[1]);
+ }
+ else
+ {
+ uint64 scanline_samples;
+ scanline_samples=_TIFFMultiply64(tif,td->td_imagewidth,td->td_samplesperpixel,module);
+ scanline_size=TIFFhowmany_64(_TIFFMultiply64(tif,scanline_samples,td->td_bitspersample,module),8);
+ }
+ }
+ else
+ {
+ scanline_size=TIFFhowmany_64(_TIFFMultiply64(tif,td->td_imagewidth,td->td_bitspersample,module),8);
+ }
+ if (scanline_size == 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Computed scanline size is zero");
+ return 0;
+ }
+ return(scanline_size);
+}
+tmsize_t
+TIFFScanlineSize(TIFF* tif)
+{
+ static const char module[] = "TIFFScanlineSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFScanlineSize64(tif);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m) {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer arithmetic overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Return the number of bytes required to store a complete
+ * decoded and packed raster scanline (as opposed to the
+ * I/O size returned by TIFFScanlineSize which may be less
+ * if data is store as separate planes).
+ */
+uint64
+TIFFRasterScanlineSize64(TIFF* tif)
+{
+ static const char module[] = "TIFFRasterScanlineSize64";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 scanline;
+
+ scanline = _TIFFMultiply64(tif, td->td_bitspersample, td->td_imagewidth, module);
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG) {
+ scanline = _TIFFMultiply64(tif, scanline, td->td_samplesperpixel, module);
+ return (TIFFhowmany8_64(scanline));
+ } else
+ return (_TIFFMultiply64(tif, TIFFhowmany8_64(scanline),
+ td->td_samplesperpixel, module));
+}
+tmsize_t
+TIFFRasterScanlineSize(TIFF* tif)
+{
+ static const char module[] = "TIFFRasterScanlineSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFRasterScanlineSize64(tif);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer arithmetic overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_swab.c b/test/monniaux/tiff-4.0.10/tif_swab.c
new file mode 100644
index 00000000..b174ba69
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_swab.c
@@ -0,0 +1,310 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library Bit & Byte Swapping Support.
+ *
+ * XXX We assume short = 16-bits and long = 32-bits XXX
+ */
+#include "tiffiop.h"
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabShort)
+void
+TIFFSwabShort(uint16* wp)
+{
+ register unsigned char* cp = (unsigned char*) wp;
+ unsigned char t;
+ assert(sizeof(uint16)==2);
+ t = cp[1]; cp[1] = cp[0]; cp[0] = t;
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabLong)
+void
+TIFFSwabLong(uint32* lp)
+{
+ register unsigned char* cp = (unsigned char*) lp;
+ unsigned char t;
+ assert(sizeof(uint32)==4);
+ t = cp[3]; cp[3] = cp[0]; cp[0] = t;
+ t = cp[2]; cp[2] = cp[1]; cp[1] = t;
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabLong8)
+void
+TIFFSwabLong8(uint64* lp)
+{
+ register unsigned char* cp = (unsigned char*) lp;
+ unsigned char t;
+ assert(sizeof(uint64)==8);
+ t = cp[7]; cp[7] = cp[0]; cp[0] = t;
+ t = cp[6]; cp[6] = cp[1]; cp[1] = t;
+ t = cp[5]; cp[5] = cp[2]; cp[2] = t;
+ t = cp[4]; cp[4] = cp[3]; cp[3] = t;
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfShort)
+void
+TIFFSwabArrayOfShort(register uint16* wp, tmsize_t n)
+{
+ register unsigned char* cp;
+ register unsigned char t;
+ assert(sizeof(uint16)==2);
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char*) wp;
+ t = cp[1]; cp[1] = cp[0]; cp[0] = t;
+ wp++;
+ }
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfTriples)
+void
+TIFFSwabArrayOfTriples(register uint8* tp, tmsize_t n)
+{
+ unsigned char* cp;
+ unsigned char t;
+
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char*) tp;
+ t = cp[2]; cp[2] = cp[0]; cp[0] = t;
+ tp += 3;
+ }
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfLong)
+void
+TIFFSwabArrayOfLong(register uint32* lp, tmsize_t n)
+{
+ register unsigned char *cp;
+ register unsigned char t;
+ assert(sizeof(uint32)==4);
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char *)lp;
+ t = cp[3]; cp[3] = cp[0]; cp[0] = t;
+ t = cp[2]; cp[2] = cp[1]; cp[1] = t;
+ lp++;
+ }
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfLong8)
+void
+TIFFSwabArrayOfLong8(register uint64* lp, tmsize_t n)
+{
+ register unsigned char *cp;
+ register unsigned char t;
+ assert(sizeof(uint64)==8);
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char *)lp;
+ t = cp[7]; cp[7] = cp[0]; cp[0] = t;
+ t = cp[6]; cp[6] = cp[1]; cp[1] = t;
+ t = cp[5]; cp[5] = cp[2]; cp[2] = t;
+ t = cp[4]; cp[4] = cp[3]; cp[3] = t;
+ lp++;
+ }
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabFloat)
+void
+TIFFSwabFloat(float* fp)
+{
+ register unsigned char* cp = (unsigned char*) fp;
+ unsigned char t;
+ assert(sizeof(float)==4);
+ t = cp[3]; cp[3] = cp[0]; cp[0] = t;
+ t = cp[2]; cp[2] = cp[1]; cp[1] = t;
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfFloat)
+void
+TIFFSwabArrayOfFloat(register float* fp, tmsize_t n)
+{
+ register unsigned char *cp;
+ register unsigned char t;
+ assert(sizeof(float)==4);
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char *)fp;
+ t = cp[3]; cp[3] = cp[0]; cp[0] = t;
+ t = cp[2]; cp[2] = cp[1]; cp[1] = t;
+ fp++;
+ }
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabDouble)
+void
+TIFFSwabDouble(double *dp)
+{
+ register unsigned char* cp = (unsigned char*) dp;
+ unsigned char t;
+ assert(sizeof(double)==8);
+ t = cp[7]; cp[7] = cp[0]; cp[0] = t;
+ t = cp[6]; cp[6] = cp[1]; cp[1] = t;
+ t = cp[5]; cp[5] = cp[2]; cp[2] = t;
+ t = cp[4]; cp[4] = cp[3]; cp[3] = t;
+}
+#endif
+
+#if defined(DISABLE_CHECK_TIFFSWABMACROS) || !defined(TIFFSwabArrayOfDouble)
+void
+TIFFSwabArrayOfDouble(double* dp, tmsize_t n)
+{
+ register unsigned char *cp;
+ register unsigned char t;
+ assert(sizeof(double)==8);
+ /* XXX unroll loop some */
+ while (n-- > 0) {
+ cp = (unsigned char *)dp;
+ t = cp[7]; cp[7] = cp[0]; cp[0] = t;
+ t = cp[6]; cp[6] = cp[1]; cp[1] = t;
+ t = cp[5]; cp[5] = cp[2]; cp[2] = t;
+ t = cp[4]; cp[4] = cp[3]; cp[3] = t;
+ dp++;
+ }
+}
+#endif
+
+/*
+ * Bit reversal tables. TIFFBitRevTable[<byte>] gives
+ * the bit reversed value of <byte>. Used in various
+ * places in the library when the FillOrder requires
+ * bit reversal of byte values (e.g. CCITT Fax 3
+ * encoding/decoding). TIFFNoBitRevTable is provided
+ * for algorithms that want an equivalent table that
+ * do not reverse bit values.
+ */
+static const unsigned char TIFFBitRevTable[256] = {
+ 0x00, 0x80, 0x40, 0xc0, 0x20, 0xa0, 0x60, 0xe0,
+ 0x10, 0x90, 0x50, 0xd0, 0x30, 0xb0, 0x70, 0xf0,
+ 0x08, 0x88, 0x48, 0xc8, 0x28, 0xa8, 0x68, 0xe8,
+ 0x18, 0x98, 0x58, 0xd8, 0x38, 0xb8, 0x78, 0xf8,
+ 0x04, 0x84, 0x44, 0xc4, 0x24, 0xa4, 0x64, 0xe4,
+ 0x14, 0x94, 0x54, 0xd4, 0x34, 0xb4, 0x74, 0xf4,
+ 0x0c, 0x8c, 0x4c, 0xcc, 0x2c, 0xac, 0x6c, 0xec,
+ 0x1c, 0x9c, 0x5c, 0xdc, 0x3c, 0xbc, 0x7c, 0xfc,
+ 0x02, 0x82, 0x42, 0xc2, 0x22, 0xa2, 0x62, 0xe2,
+ 0x12, 0x92, 0x52, 0xd2, 0x32, 0xb2, 0x72, 0xf2,
+ 0x0a, 0x8a, 0x4a, 0xca, 0x2a, 0xaa, 0x6a, 0xea,
+ 0x1a, 0x9a, 0x5a, 0xda, 0x3a, 0xba, 0x7a, 0xfa,
+ 0x06, 0x86, 0x46, 0xc6, 0x26, 0xa6, 0x66, 0xe6,
+ 0x16, 0x96, 0x56, 0xd6, 0x36, 0xb6, 0x76, 0xf6,
+ 0x0e, 0x8e, 0x4e, 0xce, 0x2e, 0xae, 0x6e, 0xee,
+ 0x1e, 0x9e, 0x5e, 0xde, 0x3e, 0xbe, 0x7e, 0xfe,
+ 0x01, 0x81, 0x41, 0xc1, 0x21, 0xa1, 0x61, 0xe1,
+ 0x11, 0x91, 0x51, 0xd1, 0x31, 0xb1, 0x71, 0xf1,
+ 0x09, 0x89, 0x49, 0xc9, 0x29, 0xa9, 0x69, 0xe9,
+ 0x19, 0x99, 0x59, 0xd9, 0x39, 0xb9, 0x79, 0xf9,
+ 0x05, 0x85, 0x45, 0xc5, 0x25, 0xa5, 0x65, 0xe5,
+ 0x15, 0x95, 0x55, 0xd5, 0x35, 0xb5, 0x75, 0xf5,
+ 0x0d, 0x8d, 0x4d, 0xcd, 0x2d, 0xad, 0x6d, 0xed,
+ 0x1d, 0x9d, 0x5d, 0xdd, 0x3d, 0xbd, 0x7d, 0xfd,
+ 0x03, 0x83, 0x43, 0xc3, 0x23, 0xa3, 0x63, 0xe3,
+ 0x13, 0x93, 0x53, 0xd3, 0x33, 0xb3, 0x73, 0xf3,
+ 0x0b, 0x8b, 0x4b, 0xcb, 0x2b, 0xab, 0x6b, 0xeb,
+ 0x1b, 0x9b, 0x5b, 0xdb, 0x3b, 0xbb, 0x7b, 0xfb,
+ 0x07, 0x87, 0x47, 0xc7, 0x27, 0xa7, 0x67, 0xe7,
+ 0x17, 0x97, 0x57, 0xd7, 0x37, 0xb7, 0x77, 0xf7,
+ 0x0f, 0x8f, 0x4f, 0xcf, 0x2f, 0xaf, 0x6f, 0xef,
+ 0x1f, 0x9f, 0x5f, 0xdf, 0x3f, 0xbf, 0x7f, 0xff
+};
+static const unsigned char TIFFNoBitRevTable[256] = {
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
+ 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
+ 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
+ 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27,
+ 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f,
+ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37,
+ 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f,
+ 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47,
+ 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f,
+ 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57,
+ 0x58, 0x59, 0x5a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f,
+ 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67,
+ 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f,
+ 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77,
+ 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f,
+ 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87,
+ 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f,
+ 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97,
+ 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f,
+ 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7,
+ 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf,
+ 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7,
+ 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf,
+ 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7,
+ 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf,
+ 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7,
+ 0xd8, 0xd9, 0xda, 0xdb, 0xdc, 0xdd, 0xde, 0xdf,
+ 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7,
+ 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef,
+ 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7,
+ 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff,
+};
+
+const unsigned char*
+TIFFGetBitRevTable(int reversed)
+{
+ return (reversed ? TIFFBitRevTable : TIFFNoBitRevTable);
+}
+
+void
+TIFFReverseBits(uint8* cp, tmsize_t n)
+{
+ for (; n > 8; n -= 8) {
+ cp[0] = TIFFBitRevTable[cp[0]];
+ cp[1] = TIFFBitRevTable[cp[1]];
+ cp[2] = TIFFBitRevTable[cp[2]];
+ cp[3] = TIFFBitRevTable[cp[3]];
+ cp[4] = TIFFBitRevTable[cp[4]];
+ cp[5] = TIFFBitRevTable[cp[5]];
+ cp[6] = TIFFBitRevTable[cp[6]];
+ cp[7] = TIFFBitRevTable[cp[7]];
+ cp += 8;
+ }
+ while (n-- > 0) {
+ *cp = TIFFBitRevTable[*cp];
+ cp++;
+ }
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_thunder.c b/test/monniaux/tiff-4.0.10/tif_thunder.c
new file mode 100644
index 00000000..2388dbb6
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_thunder.c
@@ -0,0 +1,206 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#include <assert.h>
+#ifdef THUNDER_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * ThunderScan 4-bit Compression Algorithm Support
+ */
+
+/*
+ * ThunderScan uses an encoding scheme designed for
+ * 4-bit pixel values. Data is encoded in bytes, with
+ * each byte split into a 2-bit code word and a 6-bit
+ * data value. The encoding gives raw data, runs of
+ * pixels, or pixel values encoded as a delta from the
+ * previous pixel value. For the latter, either 2-bit
+ * or 3-bit delta values are used, with the deltas packed
+ * into a single byte.
+ */
+#define THUNDER_DATA 0x3f /* mask for 6-bit data */
+#define THUNDER_CODE 0xc0 /* mask for 2-bit code word */
+/* code values */
+#define THUNDER_RUN 0x00 /* run of pixels w/ encoded count */
+#define THUNDER_2BITDELTAS 0x40 /* 3 pixels w/ encoded 2-bit deltas */
+#define DELTA2_SKIP 2 /* skip code for 2-bit deltas */
+#define THUNDER_3BITDELTAS 0x80 /* 2 pixels w/ encoded 3-bit deltas */
+#define DELTA3_SKIP 4 /* skip code for 3-bit deltas */
+#define THUNDER_RAW 0xc0 /* raw data encoded */
+
+static const int twobitdeltas[4] = { 0, 1, 0, -1 };
+static const int threebitdeltas[8] = { 0, 1, 2, 3, 0, -3, -2, -1 };
+
+#define SETPIXEL(op, v) { \
+ lastpixel = (v) & 0xf; \
+ if ( npixels < maxpixels ) \
+ { \
+ if (npixels++ & 1) \
+ *op++ |= lastpixel; \
+ else \
+ op[0] = (uint8) (lastpixel << 4); \
+ } \
+}
+
+static int
+ThunderSetupDecode(TIFF* tif)
+{
+ static const char module[] = "ThunderSetupDecode";
+
+ if( tif->tif_dir.td_bitspersample != 4 )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Wrong bitspersample value (%d), Thunder decoder only supports 4bits per sample.",
+ (int) tif->tif_dir.td_bitspersample );
+ return 0;
+ }
+
+
+ return (1);
+}
+
+static int
+ThunderDecode(TIFF* tif, uint8* op, tmsize_t maxpixels)
+{
+ static const char module[] = "ThunderDecode";
+ register unsigned char *bp;
+ register tmsize_t cc;
+ unsigned int lastpixel;
+ tmsize_t npixels;
+
+ bp = (unsigned char *)tif->tif_rawcp;
+ cc = tif->tif_rawcc;
+ lastpixel = 0;
+ npixels = 0;
+ while (cc > 0 && npixels < maxpixels) {
+ int n, delta;
+
+ n = *bp++;
+ cc--;
+ switch (n & THUNDER_CODE) {
+ case THUNDER_RUN: /* pixel run */
+ /*
+ * Replicate the last pixel n times,
+ * where n is the lower-order 6 bits.
+ */
+ if (npixels & 1) {
+ op[0] |= lastpixel;
+ lastpixel = *op++; npixels++; n--;
+ } else
+ lastpixel |= lastpixel << 4;
+ npixels += n;
+ if (npixels < maxpixels) {
+ for (; n > 0; n -= 2)
+ *op++ = (uint8) lastpixel;
+ }
+ if (n == -1)
+ *--op &= 0xf0;
+ lastpixel &= 0xf;
+ break;
+ case THUNDER_2BITDELTAS: /* 2-bit deltas */
+ if ((delta = ((n >> 4) & 3)) != DELTA2_SKIP)
+ SETPIXEL(op, lastpixel + twobitdeltas[delta]);
+ if ((delta = ((n >> 2) & 3)) != DELTA2_SKIP)
+ SETPIXEL(op, lastpixel + twobitdeltas[delta]);
+ if ((delta = (n & 3)) != DELTA2_SKIP)
+ SETPIXEL(op, lastpixel + twobitdeltas[delta]);
+ break;
+ case THUNDER_3BITDELTAS: /* 3-bit deltas */
+ if ((delta = ((n >> 3) & 7)) != DELTA3_SKIP)
+ SETPIXEL(op, lastpixel + threebitdeltas[delta]);
+ if ((delta = (n & 7)) != DELTA3_SKIP)
+ SETPIXEL(op, lastpixel + threebitdeltas[delta]);
+ break;
+ case THUNDER_RAW: /* raw data */
+ SETPIXEL(op, n);
+ break;
+ }
+ }
+ tif->tif_rawcp = (uint8*) bp;
+ tif->tif_rawcc = cc;
+ if (npixels != maxpixels) {
+#if defined(__WIN32__) && (defined(_MSC_VER) || defined(__MINGW32__))
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s data at scanline %lu (%I64u != %I64u)",
+ npixels < maxpixels ? "Not enough" : "Too much",
+ (unsigned long) tif->tif_row,
+ (unsigned __int64) npixels,
+ (unsigned __int64) maxpixels);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%s data at scanline %lu (%llu != %llu)",
+ npixels < maxpixels ? "Not enough" : "Too much",
+ (unsigned long) tif->tif_row,
+ (unsigned long long) npixels,
+ (unsigned long long) maxpixels);
+#endif
+ return (0);
+ }
+
+ return (1);
+}
+
+static int
+ThunderDecodeRow(TIFF* tif, uint8* buf, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "ThunderDecodeRow";
+ uint8* row = buf;
+
+ (void) s;
+ if (occ % tif->tif_scanlinesize)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Fractional scanlines cannot be read");
+ return (0);
+ }
+ while (occ > 0) {
+ if (!ThunderDecode(tif, row, tif->tif_dir.td_imagewidth))
+ return (0);
+ occ -= tif->tif_scanlinesize;
+ row += tif->tif_scanlinesize;
+ }
+ return (1);
+}
+
+int
+TIFFInitThunderScan(TIFF* tif, int scheme)
+{
+ (void) scheme;
+
+ tif->tif_setupdecode = ThunderSetupDecode;
+ tif->tif_decoderow = ThunderDecodeRow;
+ tif->tif_decodestrip = ThunderDecodeRow;
+ return (1);
+}
+#endif /* THUNDER_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_tile.c b/test/monniaux/tiff-4.0.10/tif_tile.c
new file mode 100644
index 00000000..58fe9354
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_tile.c
@@ -0,0 +1,320 @@
+/*
+ * Copyright (c) 1991-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Tiled Image Support Routines.
+ */
+#include "tiffiop.h"
+
+/*
+ * Compute which tile an (x,y,z,s) value is in.
+ */
+uint32
+TIFFComputeTile(TIFF* tif, uint32 x, uint32 y, uint32 z, uint16 s)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 dx = td->td_tilewidth;
+ uint32 dy = td->td_tilelength;
+ uint32 dz = td->td_tiledepth;
+ uint32 tile = 1;
+
+ if (td->td_imagedepth == 1)
+ z = 0;
+ if (dx == (uint32) -1)
+ dx = td->td_imagewidth;
+ if (dy == (uint32) -1)
+ dy = td->td_imagelength;
+ if (dz == (uint32) -1)
+ dz = td->td_imagedepth;
+ if (dx != 0 && dy != 0 && dz != 0) {
+ uint32 xpt = TIFFhowmany_32(td->td_imagewidth, dx);
+ uint32 ypt = TIFFhowmany_32(td->td_imagelength, dy);
+ uint32 zpt = TIFFhowmany_32(td->td_imagedepth, dz);
+
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE)
+ tile = (xpt*ypt*zpt)*s +
+ (xpt*ypt)*(z/dz) +
+ xpt*(y/dy) +
+ x/dx;
+ else
+ tile = (xpt*ypt)*(z/dz) + xpt*(y/dy) + x/dx;
+ }
+ return (tile);
+}
+
+/*
+ * Check an (x,y,z,s) coordinate
+ * against the image bounds.
+ */
+int
+TIFFCheckTile(TIFF* tif, uint32 x, uint32 y, uint32 z, uint16 s)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (x >= td->td_imagewidth) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Col out of range, max %lu",
+ (unsigned long) x,
+ (unsigned long) (td->td_imagewidth - 1));
+ return (0);
+ }
+ if (y >= td->td_imagelength) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Row out of range, max %lu",
+ (unsigned long) y,
+ (unsigned long) (td->td_imagelength - 1));
+ return (0);
+ }
+ if (z >= td->td_imagedepth) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Depth out of range, max %lu",
+ (unsigned long) z,
+ (unsigned long) (td->td_imagedepth - 1));
+ return (0);
+ }
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE &&
+ s >= td->td_samplesperpixel) {
+ TIFFErrorExt(tif->tif_clientdata, tif->tif_name,
+ "%lu: Sample out of range, max %lu",
+ (unsigned long) s,
+ (unsigned long) (td->td_samplesperpixel - 1));
+ return (0);
+ }
+ return (1);
+}
+
+/*
+ * Compute how many tiles are in an image.
+ */
+uint32
+TIFFNumberOfTiles(TIFF* tif)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ uint32 dx = td->td_tilewidth;
+ uint32 dy = td->td_tilelength;
+ uint32 dz = td->td_tiledepth;
+ uint32 ntiles;
+
+ if (dx == (uint32) -1)
+ dx = td->td_imagewidth;
+ if (dy == (uint32) -1)
+ dy = td->td_imagelength;
+ if (dz == (uint32) -1)
+ dz = td->td_imagedepth;
+ ntiles = (dx == 0 || dy == 0 || dz == 0) ? 0 :
+ _TIFFMultiply32(tif, _TIFFMultiply32(tif, TIFFhowmany_32(td->td_imagewidth, dx),
+ TIFFhowmany_32(td->td_imagelength, dy),
+ "TIFFNumberOfTiles"),
+ TIFFhowmany_32(td->td_imagedepth, dz), "TIFFNumberOfTiles");
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE)
+ ntiles = _TIFFMultiply32(tif, ntiles, td->td_samplesperpixel,
+ "TIFFNumberOfTiles");
+ return (ntiles);
+}
+
+/*
+ * Compute the # bytes in each row of a tile.
+ */
+uint64
+TIFFTileRowSize64(TIFF* tif)
+{
+ static const char module[] = "TIFFTileRowSize64";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 rowsize;
+ uint64 tilerowsize;
+
+ if (td->td_tilelength == 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Tile length is zero");
+ return 0;
+ }
+ if (td->td_tilewidth == 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Tile width is zero");
+ return (0);
+ }
+ rowsize = _TIFFMultiply64(tif, td->td_bitspersample, td->td_tilewidth,
+ "TIFFTileRowSize");
+ if (td->td_planarconfig == PLANARCONFIG_CONTIG)
+ {
+ if (td->td_samplesperpixel == 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Samples per pixel is zero");
+ return 0;
+ }
+ rowsize = _TIFFMultiply64(tif, rowsize, td->td_samplesperpixel,
+ "TIFFTileRowSize");
+ }
+ tilerowsize=TIFFhowmany8_64(rowsize);
+ if (tilerowsize == 0)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Computed tile row size is zero");
+ return 0;
+ }
+ return (tilerowsize);
+}
+tmsize_t
+TIFFTileRowSize(TIFF* tif)
+{
+ static const char module[] = "TIFFTileRowSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFTileRowSize64(tif);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Compute the # bytes in a variable length, row-aligned tile.
+ */
+uint64
+TIFFVTileSize64(TIFF* tif, uint32 nrows)
+{
+ static const char module[] = "TIFFVTileSize64";
+ TIFFDirectory *td = &tif->tif_dir;
+ if (td->td_tilelength == 0 || td->td_tilewidth == 0 ||
+ td->td_tiledepth == 0)
+ return (0);
+ if ((td->td_planarconfig==PLANARCONFIG_CONTIG)&&
+ (td->td_photometric==PHOTOMETRIC_YCBCR)&&
+ (td->td_samplesperpixel==3)&&
+ (!isUpSampled(tif)))
+ {
+ /*
+ * Packed YCbCr data contain one Cb+Cr for every
+ * HorizontalSampling*VerticalSampling Y values.
+ * Must also roundup width and height when calculating
+ * since images that are not a multiple of the
+ * horizontal/vertical subsampling area include
+ * YCbCr data for the extended image.
+ */
+ uint16 ycbcrsubsampling[2];
+ uint16 samplingblock_samples;
+ uint32 samplingblocks_hor;
+ uint32 samplingblocks_ver;
+ uint64 samplingrow_samples;
+ uint64 samplingrow_size;
+ TIFFGetFieldDefaulted(tif,TIFFTAG_YCBCRSUBSAMPLING,ycbcrsubsampling+0,
+ ycbcrsubsampling+1);
+ if ((ycbcrsubsampling[0] != 1 && ycbcrsubsampling[0] != 2 && ycbcrsubsampling[0] != 4)
+ ||(ycbcrsubsampling[1] != 1 && ycbcrsubsampling[1] != 2 && ycbcrsubsampling[1] != 4))
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,
+ "Invalid YCbCr subsampling (%dx%d)",
+ ycbcrsubsampling[0],
+ ycbcrsubsampling[1] );
+ return 0;
+ }
+ samplingblock_samples=ycbcrsubsampling[0]*ycbcrsubsampling[1]+2;
+ samplingblocks_hor=TIFFhowmany_32(td->td_tilewidth,ycbcrsubsampling[0]);
+ samplingblocks_ver=TIFFhowmany_32(nrows,ycbcrsubsampling[1]);
+ samplingrow_samples=_TIFFMultiply64(tif,samplingblocks_hor,samplingblock_samples,module);
+ samplingrow_size=TIFFhowmany8_64(_TIFFMultiply64(tif,samplingrow_samples,td->td_bitspersample,module));
+ return(_TIFFMultiply64(tif,samplingrow_size,samplingblocks_ver,module));
+ }
+ else
+ return(_TIFFMultiply64(tif,nrows,TIFFTileRowSize64(tif),module));
+}
+tmsize_t
+TIFFVTileSize(TIFF* tif, uint32 nrows)
+{
+ static const char module[] = "TIFFVTileSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFVTileSize64(tif,nrows);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Compute the # bytes in a row-aligned tile.
+ */
+uint64
+TIFFTileSize64(TIFF* tif)
+{
+ return (TIFFVTileSize64(tif, tif->tif_dir.td_tilelength));
+}
+tmsize_t
+TIFFTileSize(TIFF* tif)
+{
+ static const char module[] = "TIFFTileSize";
+ uint64 m;
+ tmsize_t n;
+ m=TIFFTileSize64(tif);
+ n=(tmsize_t)m;
+ if ((uint64)n!=m)
+ {
+ TIFFErrorExt(tif->tif_clientdata,module,"Integer overflow");
+ n=0;
+ }
+ return(n);
+}
+
+/*
+ * Compute a default tile size based on the image
+ * characteristics and a requested value. If a
+ * request is <1 then we choose a size according
+ * to certain heuristics.
+ */
+void
+TIFFDefaultTileSize(TIFF* tif, uint32* tw, uint32* th)
+{
+ (*tif->tif_deftilesize)(tif, tw, th);
+}
+
+void
+_TIFFDefaultTileSize(TIFF* tif, uint32* tw, uint32* th)
+{
+ (void) tif;
+ if (*(int32*) tw < 1)
+ *tw = 256;
+ if (*(int32*) th < 1)
+ *th = 256;
+ /* roundup to a multiple of 16 per the spec */
+ if (*tw & 0xf)
+ *tw = TIFFroundup_32(*tw, 16);
+ if (*th & 0xf)
+ *th = TIFFroundup_32(*th, 16);
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_unix.c b/test/monniaux/tiff-4.0.10/tif_unix.c
new file mode 100644
index 00000000..874f1feb
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_unix.c
@@ -0,0 +1,384 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library UNIX-specific Routines. These are should also work with the
+ * Windows Common RunTime Library.
+ */
+
+#include "tif_config.h"
+
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+
+#include <errno.h>
+
+#include <stdarg.h>
+#include <stdlib.h>
+#include <sys/stat.h>
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+
+#ifdef HAVE_IO_H
+# include <io.h>
+#endif
+
+#include "tiffiop.h"
+
+
+#define TIFF_IO_MAX 2147483647U
+
+
+typedef union fd_as_handle_union
+{
+ int fd;
+ thandle_t h;
+} fd_as_handle_union_t;
+
+static tmsize_t
+_tiffReadProc(thandle_t fd, void* buf, tmsize_t size)
+{
+ fd_as_handle_union_t fdh;
+ const size_t bytes_total = (size_t) size;
+ size_t bytes_read;
+ tmsize_t count = -1;
+ if ((tmsize_t) bytes_total != size)
+ {
+ errno=EINVAL;
+ return (tmsize_t) -1;
+ }
+ fdh.h = fd;
+ for (bytes_read=0; bytes_read < bytes_total; bytes_read+=count)
+ {
+ char *buf_offset = (char *) buf+bytes_read;
+ size_t io_size = bytes_total-bytes_read;
+ if (io_size > TIFF_IO_MAX)
+ io_size = TIFF_IO_MAX;
+ count=read(fdh.fd, buf_offset, (TIFFIOSize_t) io_size);
+ if (count <= 0)
+ break;
+ }
+ if (count < 0)
+ return (tmsize_t)-1;
+ return (tmsize_t) bytes_read;
+}
+
+static tmsize_t
+_tiffWriteProc(thandle_t fd, void* buf, tmsize_t size)
+{
+ fd_as_handle_union_t fdh;
+ const size_t bytes_total = (size_t) size;
+ size_t bytes_written;
+ tmsize_t count = -1;
+ if ((tmsize_t) bytes_total != size)
+ {
+ errno=EINVAL;
+ return (tmsize_t) -1;
+ }
+ fdh.h = fd;
+ for (bytes_written=0; bytes_written < bytes_total; bytes_written+=count)
+ {
+ const char *buf_offset = (char *) buf+bytes_written;
+ size_t io_size = bytes_total-bytes_written;
+ if (io_size > TIFF_IO_MAX)
+ io_size = TIFF_IO_MAX;
+ count=write(fdh.fd, buf_offset, (TIFFIOSize_t) io_size);
+ if (count <= 0)
+ break;
+ }
+ if (count < 0)
+ return (tmsize_t)-1;
+ return (tmsize_t) bytes_written;
+ /* return ((tmsize_t) write(fdh.fd, buf, bytes_total)); */
+}
+
+static uint64
+_tiffSeekProc(thandle_t fd, uint64 off, int whence)
+{
+ fd_as_handle_union_t fdh;
+ _TIFF_off_t off_io = (_TIFF_off_t) off;
+ if ((uint64) off_io != off)
+ {
+ errno=EINVAL;
+ return (uint64) -1; /* this is really gross */
+ }
+ fdh.h = fd;
+ return((uint64)_TIFF_lseek_f(fdh.fd,off_io,whence));
+}
+
+static int
+_tiffCloseProc(thandle_t fd)
+{
+ fd_as_handle_union_t fdh;
+ fdh.h = fd;
+ return(close(fdh.fd));
+}
+
+static uint64
+_tiffSizeProc(thandle_t fd)
+{
+ _TIFF_stat_s sb;
+ fd_as_handle_union_t fdh;
+ fdh.h = fd;
+ if (_TIFF_fstat_f(fdh.fd,&sb)<0)
+ return(0);
+ else
+ return((uint64)sb.st_size);
+}
+
+#ifdef HAVE_MMAP
+#include <sys/mman.h>
+
+static int
+_tiffMapProc(thandle_t fd, void** pbase, toff_t* psize)
+{
+ uint64 size64 = _tiffSizeProc(fd);
+ tmsize_t sizem = (tmsize_t)size64;
+ if ((uint64)sizem==size64) {
+ fd_as_handle_union_t fdh;
+ fdh.h = fd;
+ *pbase = (void*)
+ mmap(0, (size_t)sizem, PROT_READ, MAP_SHARED, fdh.fd, 0);
+ if (*pbase != (void*) -1) {
+ *psize = (tmsize_t)sizem;
+ return (1);
+ }
+ }
+ return (0);
+}
+
+static void
+_tiffUnmapProc(thandle_t fd, void* base, toff_t size)
+{
+ (void) fd;
+ (void) munmap(base, (off_t) size);
+}
+#else /* !HAVE_MMAP */
+static int
+_tiffMapProc(thandle_t fd, void** pbase, toff_t* psize)
+{
+ (void) fd; (void) pbase; (void) psize;
+ return (0);
+}
+
+static void
+_tiffUnmapProc(thandle_t fd, void* base, toff_t size)
+{
+ (void) fd; (void) base; (void) size;
+}
+#endif /* !HAVE_MMAP */
+
+/*
+ * Open a TIFF file descriptor for read/writing.
+ */
+TIFF*
+TIFFFdOpen(int fd, const char* name, const char* mode)
+{
+ TIFF* tif;
+
+ fd_as_handle_union_t fdh;
+ fdh.fd = fd;
+ tif = TIFFClientOpen(name, mode,
+ fdh.h,
+ _tiffReadProc, _tiffWriteProc,
+ _tiffSeekProc, _tiffCloseProc, _tiffSizeProc,
+ _tiffMapProc, _tiffUnmapProc);
+ if (tif)
+ tif->tif_fd = fd;
+ return (tif);
+}
+
+/*
+ * Open a TIFF file for read/writing.
+ */
+TIFF*
+TIFFOpen(const char* name, const char* mode)
+{
+ static const char module[] = "TIFFOpen";
+ int m, fd;
+ TIFF* tif;
+
+ m = _TIFFgetMode(mode, module);
+ if (m == -1)
+ return ((TIFF*)0);
+
+/* for cygwin and mingw */
+#ifdef O_BINARY
+ m |= O_BINARY;
+#endif
+
+ fd = open(name, m, 0666);
+ if (fd < 0) {
+ if (errno > 0 && strerror(errno) != NULL ) {
+ TIFFErrorExt(0, module, "%s: %s", name, strerror(errno) );
+ } else {
+ TIFFErrorExt(0, module, "%s: Cannot open", name);
+ }
+ return ((TIFF *)0);
+ }
+
+ tif = TIFFFdOpen((int)fd, name, mode);
+ if(!tif)
+ close(fd);
+ return tif;
+}
+
+#ifdef __WIN32__
+#include <windows.h>
+/*
+ * Open a TIFF file with a Unicode filename, for read/writing.
+ */
+TIFF*
+TIFFOpenW(const wchar_t* name, const char* mode)
+{
+ static const char module[] = "TIFFOpenW";
+ int m, fd;
+ int mbsize;
+ char *mbname;
+ TIFF* tif;
+
+ m = _TIFFgetMode(mode, module);
+ if (m == -1)
+ return ((TIFF*)0);
+
+/* for cygwin and mingw */
+#ifdef O_BINARY
+ m |= O_BINARY;
+#endif
+
+ fd = _wopen(name, m, 0666);
+ if (fd < 0) {
+ TIFFErrorExt(0, module, "%ls: Cannot open", name);
+ return ((TIFF *)0);
+ }
+
+ mbname = NULL;
+ mbsize = WideCharToMultiByte(CP_ACP, 0, name, -1, NULL, 0, NULL, NULL);
+ if (mbsize > 0) {
+ mbname = _TIFFmalloc(mbsize);
+ if (!mbname) {
+ TIFFErrorExt(0, module,
+ "Can't allocate space for filename conversion buffer");
+ return ((TIFF*)0);
+ }
+
+ WideCharToMultiByte(CP_ACP, 0, name, -1, mbname, mbsize,
+ NULL, NULL);
+ }
+
+ tif = TIFFFdOpen((int)fd, (mbname != NULL) ? mbname : "<unknown>",
+ mode);
+
+ _TIFFfree(mbname);
+
+ if(!tif)
+ close(fd);
+ return tif;
+}
+#endif
+
+void*
+_TIFFmalloc(tmsize_t s)
+{
+ if (s == 0)
+ return ((void *) NULL);
+
+ return (malloc((size_t) s));
+}
+
+void* _TIFFcalloc(tmsize_t nmemb, tmsize_t siz)
+{
+ if( nmemb == 0 || siz == 0 )
+ return ((void *) NULL);
+
+ return calloc((size_t) nmemb, (size_t)siz);
+}
+
+void
+_TIFFfree(void* p)
+{
+ free(p);
+}
+
+void*
+_TIFFrealloc(void* p, tmsize_t s)
+{
+ return (realloc(p, (size_t) s));
+}
+
+void
+_TIFFmemset(void* p, int v, tmsize_t c)
+{
+ memset(p, v, (size_t) c);
+}
+
+void
+_TIFFmemcpy(void* d, const void* s, tmsize_t c)
+{
+ memcpy(d, s, (size_t) c);
+}
+
+int
+_TIFFmemcmp(const void* p1, const void* p2, tmsize_t c)
+{
+ return (memcmp(p1, p2, (size_t) c));
+}
+
+static void
+unixWarningHandler(const char* module, const char* fmt, va_list ap)
+{
+ if (module != NULL)
+ fprintf(stderr, "%s: ", module);
+ fprintf(stderr, "Warning, ");
+ vfprintf(stderr, fmt, ap);
+ fprintf(stderr, ".\n");
+}
+TIFFErrorHandler _TIFFwarningHandler = unixWarningHandler;
+
+static void
+unixErrorHandler(const char* module, const char* fmt, va_list ap)
+{
+ if (module != NULL)
+ fprintf(stderr, "%s: ", module);
+ vfprintf(stderr, fmt, ap);
+ fprintf(stderr, ".\n");
+}
+TIFFErrorHandler _TIFFerrorHandler = unixErrorHandler;
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_version.c b/test/monniaux/tiff-4.0.10/tif_version.c
new file mode 100644
index 00000000..60875bbf
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_version.c
@@ -0,0 +1,39 @@
+/*
+ * Copyright (c) 1992-1997 Sam Leffler
+ * Copyright (c) 1992-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+#include "tiffiop.h"
+
+static const char TIFFVersion[] = TIFFLIB_VERSION_STR;
+
+const char*
+TIFFGetVersion(void)
+{
+ return (TIFFVersion);
+}
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_warning.c b/test/monniaux/tiff-4.0.10/tif_warning.c
new file mode 100644
index 00000000..c482785c
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_warning.c
@@ -0,0 +1,87 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ */
+#include "tiffiop.h"
+
+TIFFErrorHandlerExt _TIFFwarningHandlerExt = NULL;
+
+TIFFErrorHandler
+TIFFSetWarningHandler(TIFFErrorHandler handler)
+{
+ TIFFErrorHandler prev = _TIFFwarningHandler;
+ _TIFFwarningHandler = handler;
+ return (prev);
+}
+
+TIFFErrorHandlerExt
+TIFFSetWarningHandlerExt(TIFFErrorHandlerExt handler)
+{
+ TIFFErrorHandlerExt prev = _TIFFwarningHandlerExt;
+ _TIFFwarningHandlerExt = handler;
+ return (prev);
+}
+
+void
+TIFFWarning(const char* module, const char* fmt, ...)
+{
+ va_list ap;
+ if (_TIFFwarningHandler) {
+ va_start(ap, fmt);
+ (*_TIFFwarningHandler)(module, fmt, ap);
+ va_end(ap);
+ }
+ if (_TIFFwarningHandlerExt) {
+ va_start(ap, fmt);
+ (*_TIFFwarningHandlerExt)(0, module, fmt, ap);
+ va_end(ap);
+ }
+}
+
+void
+TIFFWarningExt(thandle_t fd, const char* module, const char* fmt, ...)
+{
+ va_list ap;
+ if (_TIFFwarningHandler) {
+ va_start(ap, fmt);
+ (*_TIFFwarningHandler)(module, fmt, ap);
+ va_end(ap);
+ }
+ if (_TIFFwarningHandlerExt) {
+ va_start(ap, fmt);
+ (*_TIFFwarningHandlerExt)(fd, module, fmt, ap);
+ va_end(ap);
+ }
+}
+
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_webp.c b/test/monniaux/tiff-4.0.10/tif_webp.c
new file mode 100644
index 00000000..a002f481
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_webp.c
@@ -0,0 +1,684 @@
+/*
+* Copyright (c) 2018, Mapbox
+* Author: <norman.barker at mapbox.com>
+*
+* Permission to use, copy, modify, distribute, and sell this software and
+* its documentation for any purpose is hereby granted without fee, provided
+* that (i) the above copyright notices and this permission notice appear in
+* all copies of the software and related documentation, and (ii) the names of
+* Sam Leffler and Silicon Graphics may not be used in any advertising or
+* publicity relating to the software without the specific, prior written
+* permission of Sam Leffler and Silicon Graphics.
+*
+* THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+* EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+* WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+*
+* IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+* ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+* LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+* OF THIS SOFTWARE.
+*/
+
+#include "tiffiop.h"
+#ifdef WEBP_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * WEBP Compression Support
+ *
+ */
+
+#include "webp/decode.h"
+#include "webp/encode.h"
+
+#include <stdio.h>
+
+#define LSTATE_INIT_DECODE 0x01
+#define LSTATE_INIT_ENCODE 0x02
+/*
+ * State block for each open TIFF
+ * file using WEBP compression/decompression.
+ */
+typedef struct {
+ uint16 nSamples; /* number of samples per pixel */
+
+ int lossless; /* lossy/lossless compression */
+ int quality_level; /* compression level */
+ WebPPicture sPicture; /* WebP Picture */
+ WebPConfig sEncoderConfig; /* WebP encoder config */
+ uint8* pBuffer; /* buffer to hold raw data on encoding */
+ unsigned int buffer_offset; /* current offset into the buffer */
+ unsigned int buffer_size;
+
+ WebPIDecoder* psDecoder; /* WebPIDecoder */
+ WebPDecBuffer sDecBuffer; /* Decoder buffer */
+ int last_y; /* Last row decoded */
+
+ int state; /* state flags */
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+} WebPState;
+
+#define LState(tif) ((WebPState*) (tif)->tif_data)
+#define DecoderState(tif) LState(tif)
+#define EncoderState(tif) LState(tif)
+
+static int TWebPEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int TWebPDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s);
+
+static
+int TWebPDatasetWriter(const uint8_t* data, size_t data_size,
+ const WebPPicture* const picture)
+{
+ static const char module[] = "TWebPDatasetWriter";
+ TIFF* tif = (TIFF*)(picture->custom_ptr);
+
+ if ( (tif->tif_rawcc + (tmsize_t)data_size) > tif->tif_rawdatasize ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Buffer too small by " TIFF_SIZE_FORMAT " bytes.",
+ (size_t) (tif->tif_rawcc + data_size - tif->tif_rawdatasize));
+ return 0;
+ } else {
+ _TIFFmemcpy(tif->tif_rawcp, data, data_size);
+ tif->tif_rawcc += data_size;
+ tif->tif_rawcp += data_size;
+ return 1;
+ }
+}
+
+/*
+ * Encode a chunk of pixels.
+ */
+static int
+TWebPEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "TWebPEncode";
+ WebPState *sp = EncoderState(tif);
+ (void) s;
+
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_ENCODE);
+
+ if( (uint64)sp->buffer_offset +
+ (uint64)cc > sp->buffer_size )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Too many bytes to be written");
+ return 0;
+ }
+
+ memcpy(sp->pBuffer + sp->buffer_offset,
+ bp, cc);
+ sp->buffer_offset += (unsigned)cc;
+
+ return 1;
+
+}
+
+static int
+TWebPDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "WebPDecode";
+ VP8StatusCode status = VP8_STATUS_OK;
+ WebPState *sp = DecoderState(tif);
+ (void) s;
+
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_DECODE);
+
+ if (occ % sp->sDecBuffer.u.RGBA.stride)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Fractional scanlines cannot be read");
+ return 0;
+ }
+
+ status = WebPIAppend(sp->psDecoder, tif->tif_rawcp, tif->tif_rawcc);
+
+ if (status != VP8_STATUS_OK && status != VP8_STATUS_SUSPENDED) {
+ if (status == VP8_STATUS_INVALID_PARAM) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Invalid parameter used.");
+ } else if (status == VP8_STATUS_OUT_OF_MEMORY) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Out of memory.");
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Unrecognized error.");
+ }
+ return 0;
+ } else {
+ int current_y, stride;
+ uint8_t* buf;
+
+ /* Returns the RGB/A image decoded so far */
+ buf = WebPIDecGetRGB(sp->psDecoder, &current_y, NULL, NULL, &stride);
+
+ if ((buf != NULL) &&
+ (occ <= stride * (current_y - sp->last_y))) {
+ memcpy(op,
+ buf + (sp->last_y * stride),
+ occ);
+
+ tif->tif_rawcp += tif->tif_rawcc;
+ tif->tif_rawcc = 0;
+ sp->last_y += occ / sp->sDecBuffer.u.RGBA.stride;
+ return 1;
+ } else {
+ TIFFErrorExt(tif->tif_clientdata, module, "Unable to decode WebP data.");
+ return 0;
+ }
+ }
+}
+
+static int
+TWebPFixupTags(TIFF* tif)
+{
+ (void) tif;
+ if (tif->tif_dir.td_planarconfig != PLANARCONFIG_CONTIG) {
+ static const char module[] = "TWebPFixupTags";
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "TIFF WEBP requires data to be stored contiguously in RGB e.g. RGBRGBRGB "
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ "or RGBARGBARGBA"
+#endif
+ );
+ return 0;
+ }
+ return 1;
+}
+
+static int
+TWebPSetupDecode(TIFF* tif)
+{
+ static const char module[] = "WebPSetupDecode";
+ uint16 nBitsPerSample = tif->tif_dir.td_bitspersample;
+ uint16 sampleFormat = tif->tif_dir.td_sampleformat;
+
+ WebPState* sp = DecoderState(tif);
+ assert(sp != NULL);
+
+ sp->nSamples = tif->tif_dir.td_samplesperpixel;
+
+ /* check band count */
+ if ( sp->nSamples != 3
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ && sp->nSamples != 4
+#endif
+ )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WEBP driver doesn't support %d bands. Must be 3 (RGB) "
+ #if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ "or 4 (RGBA) "
+ #endif
+ "bands.",
+ sp->nSamples );
+ return 0;
+ }
+
+ /* check bits per sample and data type */
+ if ((nBitsPerSample != 8) && (sampleFormat != 1)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WEBP driver requires 8 bit unsigned data");
+ return 0;
+ }
+
+ /* if we were last encoding, terminate this mode */
+ if (sp->state & LSTATE_INIT_ENCODE) {
+ WebPPictureFree(&sp->sPicture);
+ if (sp->pBuffer != NULL) {
+ _TIFFfree(sp->pBuffer);
+ sp->pBuffer = NULL;
+ }
+ sp->buffer_offset = 0;
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_DECODE;
+
+ return 1;
+}
+
+/*
+* Setup state for decoding a strip.
+*/
+static int
+TWebPPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "TWebPPreDecode";
+ uint32 segment_width, segment_height;
+ WebPState* sp = DecoderState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+ (void) s;
+ assert(sp != NULL);
+
+ if (isTiled(tif)) {
+ segment_width = td->td_tilewidth;
+ segment_height = td->td_tilelength;
+ } else {
+ segment_width = td->td_imagewidth;
+ segment_height = td->td_imagelength - tif->tif_row;
+ if (segment_height > td->td_rowsperstrip)
+ segment_height = td->td_rowsperstrip;
+ }
+
+ if( (sp->state & LSTATE_INIT_DECODE) == 0 )
+ tif->tif_setupdecode(tif);
+
+ if (sp->psDecoder != NULL) {
+ WebPIDelete(sp->psDecoder);
+ WebPFreeDecBuffer(&sp->sDecBuffer);
+ sp->psDecoder = NULL;
+ }
+
+ sp->last_y = 0;
+
+ WebPInitDecBuffer(&sp->sDecBuffer);
+
+ sp->sDecBuffer.is_external_memory = 0;
+ sp->sDecBuffer.width = segment_width;
+ sp->sDecBuffer.height = segment_height;
+ sp->sDecBuffer.u.RGBA.stride = segment_width * sp->nSamples;
+ sp->sDecBuffer.u.RGBA.size = segment_width * sp->nSamples * segment_height;
+
+ if (sp->nSamples > 3) {
+ sp->sDecBuffer.colorspace = MODE_RGBA;
+ } else {
+ sp->sDecBuffer.colorspace = MODE_RGB;
+ }
+
+ sp->psDecoder = WebPINewDecoder(&sp->sDecBuffer);
+
+ if (sp->psDecoder == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Unable to allocate WebP decoder.");
+ return 0;
+ }
+
+ return 1;
+}
+
+static int
+TWebPSetupEncode(TIFF* tif)
+{
+ static const char module[] = "WebPSetupEncode";
+ uint16 nBitsPerSample = tif->tif_dir.td_bitspersample;
+ uint16 sampleFormat = tif->tif_dir.td_sampleformat;
+
+ WebPState* sp = EncoderState(tif);
+ assert(sp != NULL);
+
+ sp->nSamples = tif->tif_dir.td_samplesperpixel;
+
+ /* check band count */
+ if ( sp->nSamples != 3
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ && sp->nSamples != 4
+#endif
+ )
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WEBP driver doesn't support %d bands. Must be 3 (RGB) "
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ "or 4 (RGBA) "
+#endif
+ "bands.",
+ sp->nSamples );
+ return 0;
+ }
+
+ /* check bits per sample and data type */
+ if ((nBitsPerSample != 8) && (sampleFormat != 1)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WEBP driver requires 8 bit unsigned data");
+ return 0;
+ }
+
+ if (sp->state & LSTATE_INIT_DECODE) {
+ WebPIDelete(sp->psDecoder);
+ WebPFreeDecBuffer(&sp->sDecBuffer);
+ sp->psDecoder = NULL;
+ sp->last_y = 0;
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_ENCODE;
+
+ if (!WebPConfigInitInternal(&sp->sEncoderConfig, WEBP_PRESET_DEFAULT,
+ sp->quality_level,
+ WEBP_ENCODER_ABI_VERSION)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error creating WebP encoder configuration.");
+ return 0;
+ }
+
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ sp->sEncoderConfig.lossless = sp->lossless;
+#endif
+
+ if (!WebPValidateConfig(&sp->sEncoderConfig)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error with WebP encoder configuration.");
+ return 0;
+ }
+
+ if (!WebPPictureInit(&sp->sPicture)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error initializing WebP picture.");
+ return 0;
+ }
+
+ return 1;
+}
+
+/*
+* Reset encoding state at the start of a strip.
+*/
+static int
+TWebPPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "TWebPPreEncode";
+ uint32 segment_width, segment_height;
+ WebPState *sp = EncoderState(tif);
+ TIFFDirectory* td = &tif->tif_dir;
+
+ (void) s;
+
+ assert(sp != NULL);
+ if( sp->state != LSTATE_INIT_ENCODE )
+ tif->tif_setupencode(tif);
+
+ /*
+ * Set encoding parameters for this strip/tile.
+ */
+ if (isTiled(tif)) {
+ segment_width = td->td_tilewidth;
+ segment_height = td->td_tilelength;
+ } else {
+ segment_width = td->td_imagewidth;
+ segment_height = td->td_imagelength - tif->tif_row;
+ if (segment_height > td->td_rowsperstrip)
+ segment_height = td->td_rowsperstrip;
+ }
+
+ if( segment_width > 16383 || segment_height > 16383 ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WEBP maximum image dimensions are 16383 x 16383.");
+ return 0;
+ }
+
+ /* set up buffer for raw data */
+ /* given above check and that nSamples <= 4, buffer_size is <= 1 GB */
+ sp->buffer_size = segment_width * segment_height * sp->nSamples;
+ sp->pBuffer = _TIFFmalloc(sp->buffer_size);
+ if( !sp->pBuffer) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Cannot allocate buffer");
+ return 0;
+ }
+ sp->buffer_offset = 0;
+
+ sp->sPicture.width = segment_width;
+ sp->sPicture.height = segment_height;
+ sp->sPicture.writer = TWebPDatasetWriter;
+ sp->sPicture.custom_ptr = tif;
+
+ return 1;
+}
+
+/*
+* Finish off an encoded strip by flushing it.
+*/
+static int
+TWebPPostEncode(TIFF* tif)
+{
+ static const char module[] = "WebPPostEncode";
+ int64_t stride;
+ WebPState *sp = EncoderState(tif);
+ assert(sp != NULL);
+
+ assert(sp->state == LSTATE_INIT_ENCODE);
+
+ stride = (int64_t)sp->sPicture.width * sp->nSamples;
+
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ if (sp->nSamples == 4) {
+ if (!WebPPictureImportRGBA(&sp->sPicture, sp->pBuffer, (int)stride)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WebPPictureImportRGBA() failed" );
+ return 0;
+ }
+ }
+ else
+#endif
+ if (!WebPPictureImportRGB(&sp->sPicture, sp->pBuffer, (int)stride)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WebPPictureImportRGB() failed");
+ return 0;
+ }
+
+ if (!WebPEncode(&sp->sEncoderConfig, &sp->sPicture)) {
+
+#if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ const char* pszErrorMsg = NULL;
+ switch(sp->sPicture.error_code) {
+ case VP8_ENC_ERROR_OUT_OF_MEMORY:
+ pszErrorMsg = "Out of memory"; break;
+ case VP8_ENC_ERROR_BITSTREAM_OUT_OF_MEMORY:
+ pszErrorMsg = "Out of memory while flushing bits"; break;
+ case VP8_ENC_ERROR_NULL_PARAMETER:
+ pszErrorMsg = "A pointer parameter is NULL"; break;
+ case VP8_ENC_ERROR_INVALID_CONFIGURATION:
+ pszErrorMsg = "Configuration is invalid"; break;
+ case VP8_ENC_ERROR_BAD_DIMENSION:
+ pszErrorMsg = "Picture has invalid width/height"; break;
+ case VP8_ENC_ERROR_PARTITION0_OVERFLOW:
+ pszErrorMsg = "Partition is bigger than 512k. Try using less "
+ "SEGMENTS, or increase PARTITION_LIMIT value";
+ break;
+ case VP8_ENC_ERROR_PARTITION_OVERFLOW:
+ pszErrorMsg = "Partition is bigger than 16M";
+ break;
+ case VP8_ENC_ERROR_BAD_WRITE:
+ pszErrorMsg = "Error while fludshing bytes"; break;
+ case VP8_ENC_ERROR_FILE_TOO_BIG:
+ pszErrorMsg = "File is bigger than 4G"; break;
+ case VP8_ENC_ERROR_USER_ABORT:
+ pszErrorMsg = "User interrupted";
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WebPEncode returned an unknown error code: %d",
+ sp->sPicture.error_code);
+ pszErrorMsg = "Unknown WebP error type.";
+ break;
+ }
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "WebPEncode() failed : %s", pszErrorMsg);
+#else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in WebPEncode()");
+#endif
+ return 0;
+ }
+
+ sp->sPicture.custom_ptr = NULL;
+
+ if (!TIFFFlushData1(tif))
+ {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error flushing TIFF WebP encoder.");
+ return 0;
+ }
+
+ return 1;
+}
+
+static void
+TWebPCleanup(TIFF* tif)
+{
+ WebPState* sp = LState(tif);
+
+ assert(sp != 0);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->state & LSTATE_INIT_ENCODE) {
+ WebPPictureFree(&sp->sPicture);
+ }
+
+ if (sp->psDecoder != NULL) {
+ WebPIDelete(sp->psDecoder);
+ WebPFreeDecBuffer(&sp->sDecBuffer);
+ sp->psDecoder = NULL;
+ sp->last_y = 0;
+ }
+
+ if (sp->pBuffer != NULL) {
+ _TIFFfree(sp->pBuffer);
+ sp->pBuffer = NULL;
+ }
+
+ if (tif->tif_data) {
+ _TIFFfree(tif->tif_data);
+ tif->tif_data = NULL;
+ }
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+TWebPVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "WebPVSetField";
+ WebPState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_WEBP_LEVEL:
+ sp->quality_level = (int) va_arg(ap, int);
+ if( sp->quality_level <= 0 ||
+ sp->quality_level > 100.0f ) {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "WEBP_LEVEL should be between 1 and 100");
+ }
+ return 1;
+ case TIFFTAG_WEBP_LOSSLESS:
+ #if WEBP_ENCODER_ABI_VERSION >= 0x0100
+ sp->lossless = va_arg(ap, int);
+ return 1;
+ #else
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Need to upgrade WEBP driver, this version doesn't support "
+ "lossless compression.");
+ return 0;
+ #endif
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+ /*NOTREACHED*/
+}
+
+static int
+TWebPVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ WebPState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_WEBP_LEVEL:
+ *va_arg(ap, int*) = sp->quality_level;
+ break;
+ case TIFFTAG_WEBP_LOSSLESS:
+ *va_arg(ap, int*) = sp->lossless;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return 1;
+}
+
+static const TIFFField TWebPFields[] = {
+ { TIFFTAG_WEBP_LEVEL, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT,
+ TIFF_SETGET_UNDEFINED,
+ FIELD_PSEUDO, TRUE, FALSE, "WEBP quality", NULL },
+ { TIFFTAG_WEBP_LOSSLESS, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT,
+ TIFF_SETGET_UNDEFINED,
+ FIELD_PSEUDO, TRUE, FALSE, "WEBP lossless/lossy", NULL
+ },
+};
+
+int
+TIFFInitWebP(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitWebP";
+ WebPState* sp;
+
+ assert( scheme == COMPRESSION_WEBP );
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if ( !_TIFFMergeFields(tif, TWebPFields, TIFFArrayCount(TWebPFields)) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging WebP codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof(WebPState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = LState(tif);
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = TWebPVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = TWebPVSetField; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->quality_level = 75.0f; /* default comp. level */
+ sp->lossless = 0; /* default to false */
+ sp->state = 0;
+ sp->nSamples = 0;
+ sp->psDecoder = NULL;
+ sp->last_y = 0;
+
+ sp->buffer_offset = 0;
+ sp->pBuffer = NULL;
+
+ /*
+ * Install codec methods.
+ * Notes:
+ * encoderow is not supported
+ */
+ tif->tif_fixuptags = TWebPFixupTags;
+ tif->tif_setupdecode = TWebPSetupDecode;
+ tif->tif_predecode = TWebPPreDecode;
+ tif->tif_decoderow = TWebPDecode;
+ tif->tif_decodestrip = TWebPDecode;
+ tif->tif_decodetile = TWebPDecode;
+ tif->tif_setupencode = TWebPSetupEncode;
+ tif->tif_preencode = TWebPPreEncode;
+ tif->tif_postencode = TWebPPostEncode;
+ tif->tif_encoderow = TWebPEncode;
+ tif->tif_encodestrip = TWebPEncode;
+ tif->tif_encodetile = TWebPEncode;
+ tif->tif_cleanup = TWebPCleanup;
+
+ return 1;
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for WebP state block");
+ return 0;
+}
+
+#endif /* WEBP_SUPPORT */
diff --git a/test/monniaux/tiff-4.0.10/tif_write.c b/test/monniaux/tiff-4.0.10/tif_write.c
new file mode 100644
index 00000000..a31ecd12
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_write.c
@@ -0,0 +1,834 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+/*
+ * TIFF Library.
+ *
+ * Scanline-oriented Write Support
+ */
+#include "tiffiop.h"
+#include <stdio.h>
+
+#define STRIPINCR 20 /* expansion factor on strip array */
+
+#define WRITECHECKSTRIPS(tif, module) \
+ (((tif)->tif_flags&TIFF_BEENWRITING) || TIFFWriteCheck((tif),0,module))
+#define WRITECHECKTILES(tif, module) \
+ (((tif)->tif_flags&TIFF_BEENWRITING) || TIFFWriteCheck((tif),1,module))
+#define BUFFERCHECK(tif) \
+ ((((tif)->tif_flags & TIFF_BUFFERSETUP) && tif->tif_rawdata) || \
+ TIFFWriteBufferSetup((tif), NULL, (tmsize_t) -1))
+
+static int TIFFGrowStrips(TIFF* tif, uint32 delta, const char* module);
+static int TIFFAppendToStrip(TIFF* tif, uint32 strip, uint8* data, tmsize_t cc);
+
+int
+TIFFWriteScanline(TIFF* tif, void* buf, uint32 row, uint16 sample)
+{
+ static const char module[] = "TIFFWriteScanline";
+ register TIFFDirectory *td;
+ int status, imagegrew = 0;
+ uint32 strip;
+
+ if (!WRITECHECKSTRIPS(tif, module))
+ return (-1);
+ /*
+ * Handle delayed allocation of data buffer. This
+ * permits it to be sized more intelligently (using
+ * directory information).
+ */
+ if (!BUFFERCHECK(tif))
+ return (-1);
+ tif->tif_flags |= TIFF_BUF4WRITE; /* not strictly sure this is right*/
+
+ td = &tif->tif_dir;
+ /*
+ * Extend image length if needed
+ * (but only for PlanarConfig=1).
+ */
+ if (row >= td->td_imagelength) { /* extend image */
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not change \"ImageLength\" when using separate planes");
+ return (-1);
+ }
+ td->td_imagelength = row+1;
+ imagegrew = 1;
+ }
+ /*
+ * Calculate strip and check for crossings.
+ */
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ if (sample >= td->td_samplesperpixel) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "%lu: Sample out of range, max %lu",
+ (unsigned long) sample, (unsigned long) td->td_samplesperpixel);
+ return (-1);
+ }
+ strip = sample*td->td_stripsperimage + row/td->td_rowsperstrip;
+ } else
+ strip = row / td->td_rowsperstrip;
+ /*
+ * Check strip array to make sure there's space. We don't support
+ * dynamically growing files that have data organized in separate
+ * bitplanes because it's too painful. In that case we require that
+ * the imagelength be set properly before the first write (so that the
+ * strips array will be fully allocated above).
+ */
+ if (strip >= td->td_nstrips && !TIFFGrowStrips(tif, 1, module))
+ return (-1);
+ if (strip != tif->tif_curstrip) {
+ /*
+ * Changing strips -- flush any data present.
+ */
+ if (!TIFFFlushData(tif))
+ return (-1);
+ tif->tif_curstrip = strip;
+ /*
+ * Watch out for a growing image. The value of strips/image
+ * will initially be 1 (since it can't be deduced until the
+ * imagelength is known).
+ */
+ if (strip >= td->td_stripsperimage && imagegrew)
+ td->td_stripsperimage =
+ TIFFhowmany_32(td->td_imagelength,td->td_rowsperstrip);
+ if (td->td_stripsperimage == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Zero strips per image");
+ return (-1);
+ }
+ tif->tif_row =
+ (strip % td->td_stripsperimage) * td->td_rowsperstrip;
+ if ((tif->tif_flags & TIFF_CODERSETUP) == 0) {
+ if (!(*tif->tif_setupencode)(tif))
+ return (-1);
+ tif->tif_flags |= TIFF_CODERSETUP;
+ }
+
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+
+ if( td->td_stripbytecount[strip] > 0 )
+ {
+ /* if we are writing over existing tiles, zero length */
+ td->td_stripbytecount[strip] = 0;
+
+ /* this forces TIFFAppendToStrip() to do a seek */
+ tif->tif_curoff = 0;
+ }
+
+ if (!(*tif->tif_preencode)(tif, sample))
+ return (-1);
+ tif->tif_flags |= TIFF_POSTENCODE;
+ }
+ /*
+ * Ensure the write is either sequential or at the
+ * beginning of a strip (or that we can randomly
+ * access the data -- i.e. no encoding).
+ */
+ if (row != tif->tif_row) {
+ if (row < tif->tif_row) {
+ /*
+ * Moving backwards within the same strip:
+ * backup to the start and then decode
+ * forward (below).
+ */
+ tif->tif_row = (strip % td->td_stripsperimage) *
+ td->td_rowsperstrip;
+ tif->tif_rawcp = tif->tif_rawdata;
+ }
+ /*
+ * Seek forward to the desired row.
+ */
+ if (!(*tif->tif_seek)(tif, row - tif->tif_row))
+ return (-1);
+ tif->tif_row = row;
+ }
+
+ /* swab if needed - note that source buffer will be altered */
+ tif->tif_postdecode( tif, (uint8*) buf, tif->tif_scanlinesize );
+
+ status = (*tif->tif_encoderow)(tif, (uint8*) buf,
+ tif->tif_scanlinesize, sample);
+
+ /* we are now poised at the beginning of the next row */
+ tif->tif_row = row + 1;
+ return (status);
+}
+
+/*
+ * Encode the supplied data and write it to the
+ * specified strip.
+ *
+ * NB: Image length must be setup before writing.
+ */
+tmsize_t
+TIFFWriteEncodedStrip(TIFF* tif, uint32 strip, void* data, tmsize_t cc)
+{
+ static const char module[] = "TIFFWriteEncodedStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint16 sample;
+
+ if (!WRITECHECKSTRIPS(tif, module))
+ return ((tmsize_t) -1);
+ /*
+ * Check strip array to make sure there's space.
+ * We don't support dynamically growing files that
+ * have data organized in separate bitplanes because
+ * it's too painful. In that case we require that
+ * the imagelength be set properly before the first
+ * write (so that the strips array will be fully
+ * allocated above).
+ */
+ if (strip >= td->td_nstrips) {
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not grow image by strips when using separate planes");
+ return ((tmsize_t) -1);
+ }
+ if (!TIFFGrowStrips(tif, 1, module))
+ return ((tmsize_t) -1);
+ td->td_stripsperimage =
+ TIFFhowmany_32(td->td_imagelength, td->td_rowsperstrip);
+ }
+ /*
+ * Handle delayed allocation of data buffer. This
+ * permits it to be sized according to the directory
+ * info.
+ */
+ if (!BUFFERCHECK(tif))
+ return ((tmsize_t) -1);
+
+ tif->tif_flags |= TIFF_BUF4WRITE;
+ tif->tif_curstrip = strip;
+
+ if (td->td_stripsperimage == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Zero strips per image");
+ return ((tmsize_t) -1);
+ }
+
+ tif->tif_row = (strip % td->td_stripsperimage) * td->td_rowsperstrip;
+ if ((tif->tif_flags & TIFF_CODERSETUP) == 0) {
+ if (!(*tif->tif_setupencode)(tif))
+ return ((tmsize_t) -1);
+ tif->tif_flags |= TIFF_CODERSETUP;
+ }
+
+ if( td->td_stripbytecount[strip] > 0 )
+ {
+ /* Make sure that at the first attempt of rewriting the tile, we will have */
+ /* more bytes available in the output buffer than the previous byte count, */
+ /* so that TIFFAppendToStrip() will detect the overflow when it is called the first */
+ /* time if the new compressed tile is bigger than the older one. (GDAL #4771) */
+ if( tif->tif_rawdatasize <= (tmsize_t)td->td_stripbytecount[strip] )
+ {
+ if( !(TIFFWriteBufferSetup(tif, NULL,
+ (tmsize_t)TIFFroundup_64((uint64)(td->td_stripbytecount[strip] + 1), 1024))) )
+ return ((tmsize_t)(-1));
+ }
+
+ /* Force TIFFAppendToStrip() to consider placing data at end
+ of file. */
+ tif->tif_curoff = 0;
+ }
+
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+
+ tif->tif_flags &= ~TIFF_POSTENCODE;
+
+ /* shortcut to avoid an extra memcpy() */
+ if( td->td_compression == COMPRESSION_NONE )
+ {
+ /* swab if needed - note that source buffer will be altered */
+ tif->tif_postdecode( tif, (uint8*) data, cc );
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits((uint8*) data, cc);
+
+ if (cc > 0 &&
+ !TIFFAppendToStrip(tif, strip, (uint8*) data, cc))
+ return ((tmsize_t) -1);
+ return (cc);
+ }
+
+ sample = (uint16)(strip / td->td_stripsperimage);
+ if (!(*tif->tif_preencode)(tif, sample))
+ return ((tmsize_t) -1);
+
+ /* swab if needed - note that source buffer will be altered */
+ tif->tif_postdecode( tif, (uint8*) data, cc );
+
+ if (!(*tif->tif_encodestrip)(tif, (uint8*) data, cc, sample))
+ return ((tmsize_t) -1);
+ if (!(*tif->tif_postencode)(tif))
+ return ((tmsize_t) -1);
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits(tif->tif_rawdata, tif->tif_rawcc);
+ if (tif->tif_rawcc > 0 &&
+ !TIFFAppendToStrip(tif, strip, tif->tif_rawdata, tif->tif_rawcc))
+ return ((tmsize_t) -1);
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+ return (cc);
+}
+
+/*
+ * Write the supplied data to the specified strip.
+ *
+ * NB: Image length must be setup before writing.
+ */
+tmsize_t
+TIFFWriteRawStrip(TIFF* tif, uint32 strip, void* data, tmsize_t cc)
+{
+ static const char module[] = "TIFFWriteRawStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+
+ if (!WRITECHECKSTRIPS(tif, module))
+ return ((tmsize_t) -1);
+ /*
+ * Check strip array to make sure there's space.
+ * We don't support dynamically growing files that
+ * have data organized in separate bitplanes because
+ * it's too painful. In that case we require that
+ * the imagelength be set properly before the first
+ * write (so that the strips array will be fully
+ * allocated above).
+ */
+ if (strip >= td->td_nstrips) {
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Can not grow image by strips when using separate planes");
+ return ((tmsize_t) -1);
+ }
+ /*
+ * Watch out for a growing image. The value of
+ * strips/image will initially be 1 (since it
+ * can't be deduced until the imagelength is known).
+ */
+ if (strip >= td->td_stripsperimage)
+ td->td_stripsperimage =
+ TIFFhowmany_32(td->td_imagelength,td->td_rowsperstrip);
+ if (!TIFFGrowStrips(tif, 1, module))
+ return ((tmsize_t) -1);
+ }
+ tif->tif_curstrip = strip;
+ if (td->td_stripsperimage == 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,"Zero strips per image");
+ return ((tmsize_t) -1);
+ }
+ tif->tif_row = (strip % td->td_stripsperimage) * td->td_rowsperstrip;
+ return (TIFFAppendToStrip(tif, strip, (uint8*) data, cc) ?
+ cc : (tmsize_t) -1);
+}
+
+/*
+ * Write and compress a tile of data. The
+ * tile is selected by the (x,y,z,s) coordinates.
+ */
+tmsize_t
+TIFFWriteTile(TIFF* tif, void* buf, uint32 x, uint32 y, uint32 z, uint16 s)
+{
+ if (!TIFFCheckTile(tif, x, y, z, s))
+ return ((tmsize_t)(-1));
+ /*
+ * NB: A tile size of -1 is used instead of tif_tilesize knowing
+ * that TIFFWriteEncodedTile will clamp this to the tile size.
+ * This is done because the tile size may not be defined until
+ * after the output buffer is setup in TIFFWriteBufferSetup.
+ */
+ return (TIFFWriteEncodedTile(tif,
+ TIFFComputeTile(tif, x, y, z, s), buf, (tmsize_t)(-1)));
+}
+
+/*
+ * Encode the supplied data and write it to the
+ * specified tile. There must be space for the
+ * data. The function clamps individual writes
+ * to a tile to the tile size, but does not (and
+ * can not) check that multiple writes to the same
+ * tile do not write more than tile size data.
+ *
+ * NB: Image length must be setup before writing; this
+ * interface does not support automatically growing
+ * the image on each write (as TIFFWriteScanline does).
+ */
+tmsize_t
+TIFFWriteEncodedTile(TIFF* tif, uint32 tile, void* data, tmsize_t cc)
+{
+ static const char module[] = "TIFFWriteEncodedTile";
+ TIFFDirectory *td;
+ uint16 sample;
+ uint32 howmany32;
+
+ if (!WRITECHECKTILES(tif, module))
+ return ((tmsize_t)(-1));
+ td = &tif->tif_dir;
+ if (tile >= td->td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Tile %lu out of range, max %lu",
+ (unsigned long) tile, (unsigned long) td->td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+ /*
+ * Handle delayed allocation of data buffer. This
+ * permits it to be sized more intelligently (using
+ * directory information).
+ */
+ if (!BUFFERCHECK(tif))
+ return ((tmsize_t)(-1));
+
+ tif->tif_flags |= TIFF_BUF4WRITE;
+ tif->tif_curtile = tile;
+
+ if( td->td_stripbytecount[tile] > 0 )
+ {
+ /* Make sure that at the first attempt of rewriting the tile, we will have */
+ /* more bytes available in the output buffer than the previous byte count, */
+ /* so that TIFFAppendToStrip() will detect the overflow when it is called the first */
+ /* time if the new compressed tile is bigger than the older one. (GDAL #4771) */
+ if( tif->tif_rawdatasize <= (tmsize_t) td->td_stripbytecount[tile] )
+ {
+ if( !(TIFFWriteBufferSetup(tif, NULL,
+ (tmsize_t)TIFFroundup_64((uint64)(td->td_stripbytecount[tile] + 1), 1024))) )
+ return ((tmsize_t)(-1));
+ }
+
+ /* Force TIFFAppendToStrip() to consider placing data at end
+ of file. */
+ tif->tif_curoff = 0;
+ }
+
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+
+ /*
+ * Compute tiles per row & per column to compute
+ * current row and column
+ */
+ howmany32=TIFFhowmany_32(td->td_imagelength, td->td_tilelength);
+ if (howmany32 == 0) {
+ TIFFErrorExt(tif->tif_clientdata,module,"Zero tiles");
+ return ((tmsize_t)(-1));
+ }
+ tif->tif_row = (tile % howmany32) * td->td_tilelength;
+ howmany32=TIFFhowmany_32(td->td_imagewidth, td->td_tilewidth);
+ if (howmany32 == 0) {
+ TIFFErrorExt(tif->tif_clientdata,module,"Zero tiles");
+ return ((tmsize_t)(-1));
+ }
+ tif->tif_col = (tile % howmany32) * td->td_tilewidth;
+
+ if ((tif->tif_flags & TIFF_CODERSETUP) == 0) {
+ if (!(*tif->tif_setupencode)(tif))
+ return ((tmsize_t)(-1));
+ tif->tif_flags |= TIFF_CODERSETUP;
+ }
+ tif->tif_flags &= ~TIFF_POSTENCODE;
+
+ /*
+ * Clamp write amount to the tile size. This is mostly
+ * done so that callers can pass in some large number
+ * (e.g. -1) and have the tile size used instead.
+ */
+ if ( cc < 1 || cc > tif->tif_tilesize)
+ cc = tif->tif_tilesize;
+
+ /* shortcut to avoid an extra memcpy() */
+ if( td->td_compression == COMPRESSION_NONE )
+ {
+ /* swab if needed - note that source buffer will be altered */
+ tif->tif_postdecode( tif, (uint8*) data, cc );
+
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits((uint8*) data, cc);
+
+ if (cc > 0 &&
+ !TIFFAppendToStrip(tif, tile, (uint8*) data, cc))
+ return ((tmsize_t) -1);
+ return (cc);
+ }
+
+ sample = (uint16)(tile/td->td_stripsperimage);
+ if (!(*tif->tif_preencode)(tif, sample))
+ return ((tmsize_t)(-1));
+ /* swab if needed - note that source buffer will be altered */
+ tif->tif_postdecode( tif, (uint8*) data, cc );
+
+ if (!(*tif->tif_encodetile)(tif, (uint8*) data, cc, sample))
+ return ((tmsize_t) -1);
+ if (!(*tif->tif_postencode)(tif))
+ return ((tmsize_t)(-1));
+ if (!isFillOrder(tif, td->td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits((uint8*)tif->tif_rawdata, tif->tif_rawcc);
+ if (tif->tif_rawcc > 0 && !TIFFAppendToStrip(tif, tile,
+ tif->tif_rawdata, tif->tif_rawcc))
+ return ((tmsize_t)(-1));
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+ return (cc);
+}
+
+/*
+ * Write the supplied data to the specified strip.
+ * There must be space for the data; we don't check
+ * if strips overlap!
+ *
+ * NB: Image length must be setup before writing; this
+ * interface does not support automatically growing
+ * the image on each write (as TIFFWriteScanline does).
+ */
+tmsize_t
+TIFFWriteRawTile(TIFF* tif, uint32 tile, void* data, tmsize_t cc)
+{
+ static const char module[] = "TIFFWriteRawTile";
+
+ if (!WRITECHECKTILES(tif, module))
+ return ((tmsize_t)(-1));
+ if (tile >= tif->tif_dir.td_nstrips) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Tile %lu out of range, max %lu",
+ (unsigned long) tile,
+ (unsigned long) tif->tif_dir.td_nstrips);
+ return ((tmsize_t)(-1));
+ }
+ return (TIFFAppendToStrip(tif, tile, (uint8*) data, cc) ?
+ cc : (tmsize_t)(-1));
+}
+
+#define isUnspecified(tif, f) \
+ (TIFFFieldSet(tif,f) && (tif)->tif_dir.td_imagelength == 0)
+
+int
+TIFFSetupStrips(TIFF* tif)
+{
+ TIFFDirectory* td = &tif->tif_dir;
+
+ if (isTiled(tif))
+ td->td_stripsperimage =
+ isUnspecified(tif, FIELD_TILEDIMENSIONS) ?
+ td->td_samplesperpixel : TIFFNumberOfTiles(tif);
+ else
+ td->td_stripsperimage =
+ isUnspecified(tif, FIELD_ROWSPERSTRIP) ?
+ td->td_samplesperpixel : TIFFNumberOfStrips(tif);
+ td->td_nstrips = td->td_stripsperimage;
+ if (td->td_planarconfig == PLANARCONFIG_SEPARATE)
+ td->td_stripsperimage /= td->td_samplesperpixel;
+ td->td_stripoffset = (uint64 *)
+ _TIFFCheckMalloc(tif, td->td_nstrips, sizeof (uint64),
+ "for \"StripOffsets\" array");
+ td->td_stripbytecount = (uint64 *)
+ _TIFFCheckMalloc(tif, td->td_nstrips, sizeof (uint64),
+ "for \"StripByteCounts\" array");
+ if (td->td_stripoffset == NULL || td->td_stripbytecount == NULL)
+ return (0);
+ /*
+ * Place data at the end-of-file
+ * (by setting offsets to zero).
+ */
+ _TIFFmemset(td->td_stripoffset, 0, td->td_nstrips*sizeof (uint64));
+ _TIFFmemset(td->td_stripbytecount, 0, td->td_nstrips*sizeof (uint64));
+ TIFFSetFieldBit(tif, FIELD_STRIPOFFSETS);
+ TIFFSetFieldBit(tif, FIELD_STRIPBYTECOUNTS);
+ return (1);
+}
+#undef isUnspecified
+
+/*
+ * Verify file is writable and that the directory
+ * information is setup properly. In doing the latter
+ * we also "freeze" the state of the directory so
+ * that important information is not changed.
+ */
+int
+TIFFWriteCheck(TIFF* tif, int tiles, const char* module)
+{
+ if (tif->tif_mode == O_RDONLY) {
+ TIFFErrorExt(tif->tif_clientdata, module, "File not open for writing");
+ return (0);
+ }
+ if (tiles ^ isTiled(tif)) {
+ TIFFErrorExt(tif->tif_clientdata, module, tiles ?
+ "Can not write tiles to a stripped image" :
+ "Can not write scanlines to a tiled image");
+ return (0);
+ }
+
+ _TIFFFillStriles( tif );
+
+ /*
+ * On the first write verify all the required information
+ * has been setup and initialize any data structures that
+ * had to wait until directory information was set.
+ * Note that a lot of our work is assumed to remain valid
+ * because we disallow any of the important parameters
+ * from changing after we start writing (i.e. once
+ * TIFF_BEENWRITING is set, TIFFSetField will only allow
+ * the image's length to be changed).
+ */
+ if (!TIFFFieldSet(tif, FIELD_IMAGEDIMENSIONS)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Must set \"ImageWidth\" before writing data");
+ return (0);
+ }
+ if (tif->tif_dir.td_samplesperpixel == 1) {
+ /*
+ * Planarconfiguration is irrelevant in case of single band
+ * images and need not be included. We will set it anyway,
+ * because this field is used in other parts of library even
+ * in the single band case.
+ */
+ if (!TIFFFieldSet(tif, FIELD_PLANARCONFIG))
+ tif->tif_dir.td_planarconfig = PLANARCONFIG_CONTIG;
+ } else {
+ if (!TIFFFieldSet(tif, FIELD_PLANARCONFIG)) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Must set \"PlanarConfiguration\" before writing data");
+ return (0);
+ }
+ }
+ if (tif->tif_dir.td_stripoffset == NULL && !TIFFSetupStrips(tif)) {
+ tif->tif_dir.td_nstrips = 0;
+ TIFFErrorExt(tif->tif_clientdata, module, "No space for %s arrays",
+ isTiled(tif) ? "tile" : "strip");
+ return (0);
+ }
+ if (isTiled(tif))
+ {
+ tif->tif_tilesize = TIFFTileSize(tif);
+ if (tif->tif_tilesize == 0)
+ return (0);
+ }
+ else
+ tif->tif_tilesize = (tmsize_t)(-1);
+ tif->tif_scanlinesize = TIFFScanlineSize(tif);
+ if (tif->tif_scanlinesize == 0)
+ return (0);
+ tif->tif_flags |= TIFF_BEENWRITING;
+ return (1);
+}
+
+/*
+ * Setup the raw data buffer used for encoding.
+ */
+int
+TIFFWriteBufferSetup(TIFF* tif, void* bp, tmsize_t size)
+{
+ static const char module[] = "TIFFWriteBufferSetup";
+
+ if (tif->tif_rawdata) {
+ if (tif->tif_flags & TIFF_MYBUFFER) {
+ _TIFFfree(tif->tif_rawdata);
+ tif->tif_flags &= ~TIFF_MYBUFFER;
+ }
+ tif->tif_rawdata = NULL;
+ }
+ if (size == (tmsize_t)(-1)) {
+ size = (isTiled(tif) ?
+ tif->tif_tilesize : TIFFStripSize(tif));
+ /*
+ * Make raw data buffer at least 8K
+ */
+ if (size < 8*1024)
+ size = 8*1024;
+ bp = NULL; /* NB: force malloc */
+ }
+ if (bp == NULL) {
+ bp = _TIFFmalloc(size);
+ if (bp == NULL) {
+ TIFFErrorExt(tif->tif_clientdata, module, "No space for output buffer");
+ return (0);
+ }
+ tif->tif_flags |= TIFF_MYBUFFER;
+ } else
+ tif->tif_flags &= ~TIFF_MYBUFFER;
+ tif->tif_rawdata = (uint8*) bp;
+ tif->tif_rawdatasize = size;
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+ tif->tif_flags |= TIFF_BUFFERSETUP;
+ return (1);
+}
+
+/*
+ * Grow the strip data structures by delta strips.
+ */
+static int
+TIFFGrowStrips(TIFF* tif, uint32 delta, const char* module)
+{
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64* new_stripoffset;
+ uint64* new_stripbytecount;
+
+ assert(td->td_planarconfig == PLANARCONFIG_CONTIG);
+ new_stripoffset = (uint64*)_TIFFrealloc(td->td_stripoffset,
+ (td->td_nstrips + delta) * sizeof (uint64));
+ new_stripbytecount = (uint64*)_TIFFrealloc(td->td_stripbytecount,
+ (td->td_nstrips + delta) * sizeof (uint64));
+ if (new_stripoffset == NULL || new_stripbytecount == NULL) {
+ if (new_stripoffset)
+ _TIFFfree(new_stripoffset);
+ if (new_stripbytecount)
+ _TIFFfree(new_stripbytecount);
+ td->td_nstrips = 0;
+ TIFFErrorExt(tif->tif_clientdata, module, "No space to expand strip arrays");
+ return (0);
+ }
+ td->td_stripoffset = new_stripoffset;
+ td->td_stripbytecount = new_stripbytecount;
+ _TIFFmemset(td->td_stripoffset + td->td_nstrips,
+ 0, delta*sizeof (uint64));
+ _TIFFmemset(td->td_stripbytecount + td->td_nstrips,
+ 0, delta*sizeof (uint64));
+ td->td_nstrips += delta;
+ tif->tif_flags |= TIFF_DIRTYDIRECT;
+
+ return (1);
+}
+
+/*
+ * Append the data to the specified strip.
+ */
+static int
+TIFFAppendToStrip(TIFF* tif, uint32 strip, uint8* data, tmsize_t cc)
+{
+ static const char module[] = "TIFFAppendToStrip";
+ TIFFDirectory *td = &tif->tif_dir;
+ uint64 m;
+ int64 old_byte_count = -1;
+
+ if (td->td_stripoffset[strip] == 0 || tif->tif_curoff == 0) {
+ assert(td->td_nstrips > 0);
+
+ if( td->td_stripbytecount[strip] != 0
+ && td->td_stripoffset[strip] != 0
+ && td->td_stripbytecount[strip] >= (uint64) cc )
+ {
+ /*
+ * There is already tile data on disk, and the new tile
+ * data we have will fit in the same space. The only
+ * aspect of this that is risky is that there could be
+ * more data to append to this strip before we are done
+ * depending on how we are getting called.
+ */
+ if (!SeekOK(tif, td->td_stripoffset[strip])) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Seek error at scanline %lu",
+ (unsigned long)tif->tif_row);
+ return (0);
+ }
+ }
+ else
+ {
+ /*
+ * Seek to end of file, and set that as our location to
+ * write this strip.
+ */
+ td->td_stripoffset[strip] = TIFFSeekFile(tif, 0, SEEK_END);
+ tif->tif_flags |= TIFF_DIRTYSTRIP;
+ }
+
+ tif->tif_curoff = td->td_stripoffset[strip];
+
+ /*
+ * We are starting a fresh strip/tile, so set the size to zero.
+ */
+ old_byte_count = td->td_stripbytecount[strip];
+ td->td_stripbytecount[strip] = 0;
+ }
+
+ m = tif->tif_curoff+cc;
+ if (!(tif->tif_flags&TIFF_BIGTIFF))
+ m = (uint32)m;
+ if ((m<tif->tif_curoff)||(m<(uint64)cc))
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "Maximum TIFF file size exceeded");
+ return (0);
+ }
+ if (!WriteOK(tif, data, cc)) {
+ TIFFErrorExt(tif->tif_clientdata, module, "Write error at scanline %lu",
+ (unsigned long) tif->tif_row);
+ return (0);
+ }
+ tif->tif_curoff = m;
+ td->td_stripbytecount[strip] += cc;
+
+ if( (int64) td->td_stripbytecount[strip] != old_byte_count )
+ tif->tif_flags |= TIFF_DIRTYSTRIP;
+
+ return (1);
+}
+
+/*
+ * Internal version of TIFFFlushData that can be
+ * called by ``encodestrip routines'' w/o concern
+ * for infinite recursion.
+ */
+int
+TIFFFlushData1(TIFF* tif)
+{
+ if (tif->tif_rawcc > 0 && tif->tif_flags & TIFF_BUF4WRITE ) {
+ if (!isFillOrder(tif, tif->tif_dir.td_fillorder) &&
+ (tif->tif_flags & TIFF_NOBITREV) == 0)
+ TIFFReverseBits((uint8*)tif->tif_rawdata,
+ tif->tif_rawcc);
+ if (!TIFFAppendToStrip(tif,
+ isTiled(tif) ? tif->tif_curtile : tif->tif_curstrip,
+ tif->tif_rawdata, tif->tif_rawcc))
+ {
+ /* We update those variables even in case of error since there's */
+ /* code that doesn't really check the return code of this */
+ /* function */
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+ return (0);
+ }
+ tif->tif_rawcc = 0;
+ tif->tif_rawcp = tif->tif_rawdata;
+ }
+ return (1);
+}
+
+/*
+ * Set the current write offset. This should only be
+ * used to set the offset to a known previous location
+ * (very carefully), or to 0 so that the next write gets
+ * appended to the end of the file.
+ */
+void
+TIFFSetWriteOffset(TIFF* tif, toff_t off)
+{
+ tif->tif_curoff = off;
+}
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_zip.c b/test/monniaux/tiff-4.0.10/tif_zip.c
new file mode 100644
index 00000000..9d4bceb1
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_zip.c
@@ -0,0 +1,474 @@
+/*
+ * Copyright (c) 1995-1997 Sam Leffler
+ * Copyright (c) 1995-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#include "tiffiop.h"
+#ifdef ZIP_SUPPORT
+/*
+ * TIFF Library.
+ *
+ * ZIP (aka Deflate) Compression Support
+ *
+ * This file is simply an interface to the zlib library written by
+ * Jean-loup Gailly and Mark Adler. You must use version 1.0 or later
+ * of the library: this code assumes the 1.0 API and also depends on
+ * the ability to write the zlib header multiple times (one per strip)
+ * which was not possible with versions prior to 0.95. Note also that
+ * older versions of this codec avoided this bug by suppressing the header
+ * entirely. This means that files written with the old library cannot
+ * be read; they should be converted to a different compression scheme
+ * and then reconverted.
+ *
+ * The data format used by the zlib library is described in the files
+ * zlib-3.1.doc, deflate-1.1.doc and gzip-4.1.doc, available in the
+ * directory ftp://ftp.uu.net/pub/archiving/zip/doc. The library was
+ * last found at ftp://ftp.uu.net/pub/archiving/zip/zlib/zlib-0.99.tar.gz.
+ */
+#include "tif_predict.h"
+#include "zlib.h"
+
+#include <stdio.h>
+
+/*
+ * Sigh, ZLIB_VERSION is defined as a string so there's no
+ * way to do a proper check here. Instead we guess based
+ * on the presence of #defines that were added between the
+ * 0.95 and 1.0 distributions.
+ */
+#if !defined(Z_NO_COMPRESSION) || !defined(Z_DEFLATED)
+#error "Antiquated ZLIB software; you must use version 1.0 or later"
+#endif
+
+#define SAFE_MSG(sp) ((sp)->stream.msg == NULL ? "" : (sp)->stream.msg)
+
+/*
+ * State block for each open TIFF
+ * file using ZIP compression/decompression.
+ */
+typedef struct {
+ TIFFPredictorState predict;
+ z_stream stream;
+ int zipquality; /* compression level */
+ int state; /* state flags */
+#define ZSTATE_INIT_DECODE 0x01
+#define ZSTATE_INIT_ENCODE 0x02
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+} ZIPState;
+
+#define ZState(tif) ((ZIPState*) (tif)->tif_data)
+#define DecoderState(tif) ZState(tif)
+#define EncoderState(tif) ZState(tif)
+
+static int ZIPEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int ZIPDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s);
+
+static int
+ZIPFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return (1);
+}
+
+static int
+ZIPSetupDecode(TIFF* tif)
+{
+ static const char module[] = "ZIPSetupDecode";
+ ZIPState* sp = DecoderState(tif);
+
+ assert(sp != NULL);
+
+ /* if we were last encoding, terminate this mode */
+ if (sp->state & ZSTATE_INIT_ENCODE) {
+ deflateEnd(&sp->stream);
+ sp->state = 0;
+ }
+
+ /* This function can possibly be called several times by */
+ /* PredictorSetupDecode() if this function succeeds but */
+ /* PredictorSetup() fails */
+ if ((sp->state & ZSTATE_INIT_DECODE) == 0 &&
+ inflateInit(&sp->stream) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s", SAFE_MSG(sp));
+ return (0);
+ } else {
+ sp->state |= ZSTATE_INIT_DECODE;
+ return (1);
+ }
+}
+
+/*
+ * Setup state for decoding a strip.
+ */
+static int
+ZIPPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "ZIPPreDecode";
+ ZIPState* sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+
+ if( (sp->state & ZSTATE_INIT_DECODE) == 0 )
+ tif->tif_setupdecode( tif );
+
+ sp->stream.next_in = tif->tif_rawdata;
+ assert(sizeof(sp->stream.avail_in)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_in = (uInt) tif->tif_rawcc;
+ if ((tmsize_t)sp->stream.avail_in != tif->tif_rawcc)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ return (inflateReset(&sp->stream) == Z_OK);
+}
+
+static int
+ZIPDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "ZIPDecode";
+ ZIPState* sp = DecoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ assert(sp->state == ZSTATE_INIT_DECODE);
+
+ sp->stream.next_in = tif->tif_rawcp;
+ sp->stream.avail_in = (uInt) tif->tif_rawcc;
+
+ sp->stream.next_out = op;
+ assert(sizeof(sp->stream.avail_out)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_out = (uInt) occ;
+ if ((tmsize_t)sp->stream.avail_out != occ)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ do {
+ int state = inflate(&sp->stream, Z_PARTIAL_FLUSH);
+ if (state == Z_STREAM_END)
+ break;
+ if (state == Z_DATA_ERROR) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Decoding error at scanline %lu, %s",
+ (unsigned long) tif->tif_row, SAFE_MSG(sp));
+ if (inflateSync(&sp->stream) != Z_OK)
+ return (0);
+ continue;
+ }
+ if (state != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "ZLib error: %s", SAFE_MSG(sp));
+ return (0);
+ }
+ } while (sp->stream.avail_out > 0);
+ if (sp->stream.avail_out != 0) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %lu (short " TIFF_UINT64_FORMAT " bytes)",
+ (unsigned long) tif->tif_row, (TIFF_UINT64_T) sp->stream.avail_out);
+ return (0);
+ }
+
+ tif->tif_rawcp = sp->stream.next_in;
+ tif->tif_rawcc = sp->stream.avail_in;
+
+ return (1);
+}
+
+static int
+ZIPSetupEncode(TIFF* tif)
+{
+ static const char module[] = "ZIPSetupEncode";
+ ZIPState* sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ if (sp->state & ZSTATE_INIT_DECODE) {
+ inflateEnd(&sp->stream);
+ sp->state = 0;
+ }
+
+ if (deflateInit(&sp->stream, sp->zipquality) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "%s", SAFE_MSG(sp));
+ return (0);
+ } else {
+ sp->state |= ZSTATE_INIT_ENCODE;
+ return (1);
+ }
+}
+
+/*
+ * Reset encoding state at the start of a strip.
+ */
+static int
+ZIPPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "ZIPPreEncode";
+ ZIPState *sp = EncoderState(tif);
+
+ (void) s;
+ assert(sp != NULL);
+ if( sp->state != ZSTATE_INIT_ENCODE )
+ tif->tif_setupencode( tif );
+
+ sp->stream.next_out = tif->tif_rawdata;
+ assert(sizeof(sp->stream.avail_out)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_out = (uInt)tif->tif_rawdatasize;
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ return (deflateReset(&sp->stream) == Z_OK);
+}
+
+/*
+ * Encode a chunk of pixels.
+ */
+static int
+ZIPEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "ZIPEncode";
+ ZIPState *sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ assert(sp->state == ZSTATE_INIT_ENCODE);
+
+ (void) s;
+ sp->stream.next_in = bp;
+ assert(sizeof(sp->stream.avail_in)==4); /* if this assert gets raised,
+ we need to simplify this code to reflect a ZLib that is likely updated
+ to deal with 8byte memory sizes, though this code will respond
+ appropriately even before we simplify it */
+ sp->stream.avail_in = (uInt) cc;
+ if ((tmsize_t)sp->stream.avail_in != cc)
+ {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib cannot deal with buffers this size");
+ return (0);
+ }
+ do {
+ if (deflate(&sp->stream, Z_NO_FLUSH) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Encoder error: %s",
+ SAFE_MSG(sp));
+ return (0);
+ }
+ if (sp->stream.avail_out == 0) {
+ tif->tif_rawcc = tif->tif_rawdatasize;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (uInt) tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in ZIPPreEncode */
+ }
+ } while (sp->stream.avail_in > 0);
+ return (1);
+}
+
+/*
+ * Finish off an encoded strip by flushing the last
+ * string and tacking on an End Of Information code.
+ */
+static int
+ZIPPostEncode(TIFF* tif)
+{
+ static const char module[] = "ZIPPostEncode";
+ ZIPState *sp = EncoderState(tif);
+ int state;
+
+ sp->stream.avail_in = 0;
+ do {
+ state = deflate(&sp->stream, Z_FINISH);
+ switch (state) {
+ case Z_STREAM_END:
+ case Z_OK:
+ if ((tmsize_t)sp->stream.avail_out != tif->tif_rawdatasize)
+ {
+ tif->tif_rawcc = tif->tif_rawdatasize - sp->stream.avail_out;
+ TIFFFlushData1(tif);
+ sp->stream.next_out = tif->tif_rawdata;
+ sp->stream.avail_out = (uInt) tif->tif_rawdatasize; /* this is a safe typecast, as check is made already in ZIPPreEncode */
+ }
+ break;
+ default:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "ZLib error: %s", SAFE_MSG(sp));
+ return (0);
+ }
+ } while (state != Z_STREAM_END);
+ return (1);
+}
+
+static void
+ZIPCleanup(TIFF* tif)
+{
+ ZIPState* sp = ZState(tif);
+
+ assert(sp != 0);
+
+ (void)TIFFPredictorCleanup(tif);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->state & ZSTATE_INIT_ENCODE) {
+ deflateEnd(&sp->stream);
+ sp->state = 0;
+ } else if( sp->state & ZSTATE_INIT_DECODE) {
+ inflateEnd(&sp->stream);
+ sp->state = 0;
+ }
+ _TIFFfree(sp);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+ZIPVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "ZIPVSetField";
+ ZIPState* sp = ZState(tif);
+
+ switch (tag) {
+ case TIFFTAG_ZIPQUALITY:
+ sp->zipquality = (int) va_arg(ap, int);
+ if ( sp->state&ZSTATE_INIT_ENCODE ) {
+ if (deflateParams(&sp->stream,
+ sp->zipquality, Z_DEFAULT_STRATEGY) != Z_OK) {
+ TIFFErrorExt(tif->tif_clientdata, module, "ZLib error: %s",
+ SAFE_MSG(sp));
+ return (0);
+ }
+ }
+ return (1);
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+ /*NOTREACHED*/
+}
+
+static int
+ZIPVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ ZIPState* sp = ZState(tif);
+
+ switch (tag) {
+ case TIFFTAG_ZIPQUALITY:
+ *va_arg(ap, int*) = sp->zipquality;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return (1);
+}
+
+static const TIFFField zipFields[] = {
+ { TIFFTAG_ZIPQUALITY, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT, TIFF_SETGET_UNDEFINED, FIELD_PSEUDO, TRUE, FALSE, "", NULL },
+};
+
+int
+TIFFInitZIP(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitZIP";
+ ZIPState* sp;
+
+ assert( (scheme == COMPRESSION_DEFLATE)
+ || (scheme == COMPRESSION_ADOBE_DEFLATE));
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, zipFields, TIFFArrayCount(zipFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging Deflate codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof (ZIPState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = ZState(tif);
+ sp->stream.zalloc = NULL;
+ sp->stream.zfree = NULL;
+ sp->stream.opaque = NULL;
+ sp->stream.data_type = Z_BINARY;
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = ZIPVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = ZIPVSetField; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->zipquality = Z_DEFAULT_COMPRESSION; /* default comp. level */
+ sp->state = 0;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = ZIPFixupTags;
+ tif->tif_setupdecode = ZIPSetupDecode;
+ tif->tif_predecode = ZIPPreDecode;
+ tif->tif_decoderow = ZIPDecode;
+ tif->tif_decodestrip = ZIPDecode;
+ tif->tif_decodetile = ZIPDecode;
+ tif->tif_setupencode = ZIPSetupEncode;
+ tif->tif_preencode = ZIPPreEncode;
+ tif->tif_postencode = ZIPPostEncode;
+ tif->tif_encoderow = ZIPEncode;
+ tif->tif_encodestrip = ZIPEncode;
+ tif->tif_encodetile = ZIPEncode;
+ tif->tif_cleanup = ZIPCleanup;
+ /*
+ * Setup predictor setup.
+ */
+ (void) TIFFPredictorInit(tif);
+ return (1);
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for ZIP state block");
+ return (0);
+}
+#endif /* ZIP_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tif_zstd.c b/test/monniaux/tiff-4.0.10/tif_zstd.c
new file mode 100644
index 00000000..21c935e2
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tif_zstd.c
@@ -0,0 +1,440 @@
+/*
+* Copyright (c) 2017, Planet Labs
+* Author: <even.rouault at spatialys.com>
+*
+* Permission to use, copy, modify, distribute, and sell this software and
+* its documentation for any purpose is hereby granted without fee, provided
+* that (i) the above copyright notices and this permission notice appear in
+* all copies of the software and related documentation, and (ii) the names of
+* Sam Leffler and Silicon Graphics may not be used in any advertising or
+* publicity relating to the software without the specific, prior written
+* permission of Sam Leffler and Silicon Graphics.
+*
+* THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+* EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+* WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+*
+* IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+* ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+* OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+* WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+* LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+* OF THIS SOFTWARE.
+*/
+
+#include "tiffiop.h"
+#ifdef ZSTD_SUPPORT
+/*
+* TIFF Library.
+*
+* ZSTD Compression Support
+*
+*/
+
+#include "tif_predict.h"
+#include "zstd.h"
+
+#include <stdio.h>
+
+/*
+* State block for each open TIFF file using ZSTD compression/decompression.
+*/
+typedef struct {
+ TIFFPredictorState predict;
+ ZSTD_DStream* dstream;
+ ZSTD_CStream* cstream;
+ int compression_level; /* compression level */
+ ZSTD_outBuffer out_buffer;
+ int state; /* state flags */
+#define LSTATE_INIT_DECODE 0x01
+#define LSTATE_INIT_ENCODE 0x02
+
+ TIFFVGetMethod vgetparent; /* super-class method */
+ TIFFVSetMethod vsetparent; /* super-class method */
+} ZSTDState;
+
+#define LState(tif) ((ZSTDState*) (tif)->tif_data)
+#define DecoderState(tif) LState(tif)
+#define EncoderState(tif) LState(tif)
+
+static int ZSTDEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s);
+static int ZSTDDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s);
+
+static int
+ZSTDFixupTags(TIFF* tif)
+{
+ (void) tif;
+ return 1;
+}
+
+static int
+ZSTDSetupDecode(TIFF* tif)
+{
+ ZSTDState* sp = DecoderState(tif);
+
+ assert(sp != NULL);
+
+ /* if we were last encoding, terminate this mode */
+ if (sp->state & LSTATE_INIT_ENCODE) {
+ ZSTD_freeCStream(sp->cstream);
+ sp->cstream = NULL;
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_DECODE;
+ return 1;
+}
+
+/*
+* Setup state for decoding a strip.
+*/
+static int
+ZSTDPreDecode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "ZSTDPreDecode";
+ ZSTDState* sp = DecoderState(tif);
+ size_t zstd_ret;
+
+ (void) s;
+ assert(sp != NULL);
+
+ if( (sp->state & LSTATE_INIT_DECODE) == 0 )
+ tif->tif_setupdecode(tif);
+
+ if( sp->dstream )
+ {
+ ZSTD_freeDStream(sp->dstream);
+ sp->dstream = NULL;
+ }
+
+ sp->dstream = ZSTD_createDStream();
+ if( sp->dstream == NULL ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot allocate decompression stream");
+ return 0;
+ }
+ zstd_ret = ZSTD_initDStream(sp->dstream);
+ if( ZSTD_isError(zstd_ret) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in ZSTD_initDStream(): %s",
+ ZSTD_getErrorName(zstd_ret));
+ return 0;
+ }
+
+ return 1;
+}
+
+static int
+ZSTDDecode(TIFF* tif, uint8* op, tmsize_t occ, uint16 s)
+{
+ static const char module[] = "ZSTDDecode";
+ ZSTDState* sp = DecoderState(tif);
+ ZSTD_inBuffer in_buffer;
+ ZSTD_outBuffer out_buffer;
+ size_t zstd_ret;
+
+ (void) s;
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_DECODE);
+
+ in_buffer.src = tif->tif_rawcp;
+ in_buffer.size = (size_t) tif->tif_rawcc;
+ in_buffer.pos = 0;
+
+ out_buffer.dst = op;
+ out_buffer.size = (size_t) occ;
+ out_buffer.pos = 0;
+
+ do {
+ zstd_ret = ZSTD_decompressStream(sp->dstream, &out_buffer,
+ &in_buffer);
+ if( ZSTD_isError(zstd_ret) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in ZSTD_decompressStream(): %s",
+ ZSTD_getErrorName(zstd_ret));
+ return 0;
+ }
+ } while( zstd_ret != 0 &&
+ in_buffer.pos < in_buffer.size &&
+ out_buffer.pos < out_buffer.size );
+
+ if (out_buffer.pos < (size_t)occ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Not enough data at scanline %lu (short %lu bytes)",
+ (unsigned long) tif->tif_row,
+ (unsigned long) (size_t)occ - out_buffer.pos);
+ return 0;
+ }
+
+ tif->tif_rawcp += in_buffer.pos;
+ tif->tif_rawcc -= in_buffer.pos;
+
+ return 1;
+}
+
+static int
+ZSTDSetupEncode(TIFF* tif)
+{
+ ZSTDState* sp = EncoderState(tif);
+
+ assert(sp != NULL);
+ if (sp->state & LSTATE_INIT_DECODE) {
+ ZSTD_freeDStream(sp->dstream);
+ sp->dstream = NULL;
+ sp->state = 0;
+ }
+
+ sp->state |= LSTATE_INIT_ENCODE;
+ return 1;
+}
+
+/*
+* Reset encoding state at the start of a strip.
+*/
+static int
+ZSTDPreEncode(TIFF* tif, uint16 s)
+{
+ static const char module[] = "ZSTDPreEncode";
+ ZSTDState *sp = EncoderState(tif);
+ size_t zstd_ret;
+
+ (void) s;
+ assert(sp != NULL);
+ if( sp->state != LSTATE_INIT_ENCODE )
+ tif->tif_setupencode(tif);
+
+ if (sp->cstream) {
+ ZSTD_freeCStream(sp->cstream);
+ sp->cstream = NULL;
+ }
+ sp->cstream = ZSTD_createCStream();
+ if( sp->cstream == NULL ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Cannot allocate compression stream");
+ return 0;
+ }
+
+ zstd_ret = ZSTD_initCStream(sp->cstream, sp->compression_level);
+ if( ZSTD_isError(zstd_ret) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in ZSTD_initCStream(): %s",
+ ZSTD_getErrorName(zstd_ret));
+ return 0;
+ }
+
+ sp->out_buffer.dst = tif->tif_rawdata;
+ sp->out_buffer.size = (size_t)tif->tif_rawdatasize;
+ sp->out_buffer.pos = 0;
+
+ return 1;
+}
+
+/*
+* Encode a chunk of pixels.
+*/
+static int
+ZSTDEncode(TIFF* tif, uint8* bp, tmsize_t cc, uint16 s)
+{
+ static const char module[] = "ZSTDEncode";
+ ZSTDState *sp = EncoderState(tif);
+ ZSTD_inBuffer in_buffer;
+ size_t zstd_ret;
+
+ assert(sp != NULL);
+ assert(sp->state == LSTATE_INIT_ENCODE);
+
+ (void) s;
+
+ in_buffer.src = bp;
+ in_buffer.size = (size_t)cc;
+ in_buffer.pos = 0;
+
+ do {
+ zstd_ret = ZSTD_compressStream(sp->cstream, &sp->out_buffer,
+ &in_buffer);
+ if( ZSTD_isError(zstd_ret) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in ZSTD_compressStream(): %s",
+ ZSTD_getErrorName(zstd_ret));
+ return 0;
+ }
+ if( sp->out_buffer.pos == sp->out_buffer.size ) {
+ tif->tif_rawcc = tif->tif_rawdatasize;
+ TIFFFlushData1(tif);
+ sp->out_buffer.dst = tif->tif_rawcp;
+ sp->out_buffer.pos = 0;
+ }
+ } while( in_buffer.pos < in_buffer.size );
+
+ return 1;
+}
+
+/*
+* Finish off an encoded strip by flushing it.
+*/
+static int
+ZSTDPostEncode(TIFF* tif)
+{
+ static const char module[] = "ZSTDPostEncode";
+ ZSTDState *sp = EncoderState(tif);
+ size_t zstd_ret;
+
+ do {
+ zstd_ret = ZSTD_endStream(sp->cstream, &sp->out_buffer);
+ if( ZSTD_isError(zstd_ret) ) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Error in ZSTD_endStream(): %s",
+ ZSTD_getErrorName(zstd_ret));
+ return 0;
+ }
+ if( sp->out_buffer.pos > 0 ) {
+ tif->tif_rawcc = sp->out_buffer.pos;
+ TIFFFlushData1(tif);
+ sp->out_buffer.dst = tif->tif_rawcp;
+ sp->out_buffer.pos = 0;
+ }
+ } while (zstd_ret != 0);
+ return 1;
+}
+
+static void
+ZSTDCleanup(TIFF* tif)
+{
+ ZSTDState* sp = LState(tif);
+
+ assert(sp != 0);
+
+ (void)TIFFPredictorCleanup(tif);
+
+ tif->tif_tagmethods.vgetfield = sp->vgetparent;
+ tif->tif_tagmethods.vsetfield = sp->vsetparent;
+
+ if (sp->dstream) {
+ ZSTD_freeDStream(sp->dstream);
+ sp->dstream = NULL;
+ }
+ if (sp->cstream) {
+ ZSTD_freeCStream(sp->cstream);
+ sp->cstream = NULL;
+ }
+ _TIFFfree(sp);
+ tif->tif_data = NULL;
+
+ _TIFFSetDefaultCompressionState(tif);
+}
+
+static int
+ZSTDVSetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ static const char module[] = "ZSTDVSetField";
+ ZSTDState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_ZSTD_LEVEL:
+ sp->compression_level = (int) va_arg(ap, int);
+ if( sp->compression_level <= 0 ||
+ sp->compression_level > ZSTD_maxCLevel() )
+ {
+ TIFFWarningExt(tif->tif_clientdata, module,
+ "ZSTD_LEVEL should be between 1 and %d",
+ ZSTD_maxCLevel());
+ }
+ return 1;
+ default:
+ return (*sp->vsetparent)(tif, tag, ap);
+ }
+ /*NOTREACHED*/
+}
+
+static int
+ZSTDVGetField(TIFF* tif, uint32 tag, va_list ap)
+{
+ ZSTDState* sp = LState(tif);
+
+ switch (tag) {
+ case TIFFTAG_ZSTD_LEVEL:
+ *va_arg(ap, int*) = sp->compression_level;
+ break;
+ default:
+ return (*sp->vgetparent)(tif, tag, ap);
+ }
+ return 1;
+}
+
+static const TIFFField ZSTDFields[] = {
+ { TIFFTAG_ZSTD_LEVEL, 0, 0, TIFF_ANY, 0, TIFF_SETGET_INT,
+ TIFF_SETGET_UNDEFINED,
+ FIELD_PSEUDO, TRUE, FALSE, "ZSTD compression_level", NULL },
+};
+
+int
+TIFFInitZSTD(TIFF* tif, int scheme)
+{
+ static const char module[] = "TIFFInitZSTD";
+ ZSTDState* sp;
+
+ assert( scheme == COMPRESSION_ZSTD );
+
+ /*
+ * Merge codec-specific tag information.
+ */
+ if (!_TIFFMergeFields(tif, ZSTDFields, TIFFArrayCount(ZSTDFields))) {
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "Merging ZSTD codec-specific tags failed");
+ return 0;
+ }
+
+ /*
+ * Allocate state block so tag methods have storage to record values.
+ */
+ tif->tif_data = (uint8*) _TIFFmalloc(sizeof(ZSTDState));
+ if (tif->tif_data == NULL)
+ goto bad;
+ sp = LState(tif);
+
+ /*
+ * Override parent get/set field methods.
+ */
+ sp->vgetparent = tif->tif_tagmethods.vgetfield;
+ tif->tif_tagmethods.vgetfield = ZSTDVGetField; /* hook for codec tags */
+ sp->vsetparent = tif->tif_tagmethods.vsetfield;
+ tif->tif_tagmethods.vsetfield = ZSTDVSetField; /* hook for codec tags */
+
+ /* Default values for codec-specific fields */
+ sp->compression_level = 9; /* default comp. level */
+ sp->state = 0;
+ sp->dstream = 0;
+ sp->cstream = 0;
+ sp->out_buffer.dst = NULL;
+ sp->out_buffer.size = 0;
+ sp->out_buffer.pos = 0;
+
+ /*
+ * Install codec methods.
+ */
+ tif->tif_fixuptags = ZSTDFixupTags;
+ tif->tif_setupdecode = ZSTDSetupDecode;
+ tif->tif_predecode = ZSTDPreDecode;
+ tif->tif_decoderow = ZSTDDecode;
+ tif->tif_decodestrip = ZSTDDecode;
+ tif->tif_decodetile = ZSTDDecode;
+ tif->tif_setupencode = ZSTDSetupEncode;
+ tif->tif_preencode = ZSTDPreEncode;
+ tif->tif_postencode = ZSTDPostEncode;
+ tif->tif_encoderow = ZSTDEncode;
+ tif->tif_encodestrip = ZSTDEncode;
+ tif->tif_encodetile = ZSTDEncode;
+ tif->tif_cleanup = ZSTDCleanup;
+ /*
+ * Setup predictor setup.
+ */
+ (void) TIFFPredictorInit(tif);
+ return 1;
+bad:
+ TIFFErrorExt(tif->tif_clientdata, module,
+ "No space for ZSTD state block");
+ return 0;
+}
+#endif /* ZSTD_SUPPORT */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
diff --git a/test/monniaux/tiff-4.0.10/tiff.h b/test/monniaux/tiff-4.0.10/tiff.h
new file mode 100644
index 00000000..5b0a0c90
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiff.h
@@ -0,0 +1,695 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _TIFF_
+#define _TIFF_
+
+#include "tiffconf.h"
+
+/*
+ * Tag Image File Format (TIFF)
+ *
+ * Based on Rev 6.0 from:
+ * Developer's Desk
+ * Aldus Corporation
+ * 411 First Ave. South
+ * Suite 200
+ * Seattle, WA 98104
+ * 206-622-5500
+ *
+ * (http://partners.adobe.com/asn/developer/PDFS/TN/TIFF6.pdf)
+ *
+ * For BigTIFF design notes see the following links
+ * http://www.remotesensing.org/libtiff/bigtiffdesign.html
+ * http://www.awaresystems.be/imaging/tiff/bigtiff.html
+ */
+
+#define TIFF_VERSION_CLASSIC 42
+#define TIFF_VERSION_BIG 43
+
+#define TIFF_BIGENDIAN 0x4d4d
+#define TIFF_LITTLEENDIAN 0x4949
+#define MDI_LITTLEENDIAN 0x5045
+#define MDI_BIGENDIAN 0x4550
+
+/*
+ * Intrinsic data types required by the file format:
+ *
+ * 8-bit quantities int8/uint8
+ * 16-bit quantities int16/uint16
+ * 32-bit quantities int32/uint32
+ * 64-bit quantities int64/uint64
+ * strings unsigned char*
+ */
+
+typedef TIFF_INT8_T int8;
+typedef TIFF_UINT8_T uint8;
+
+typedef TIFF_INT16_T int16;
+typedef TIFF_UINT16_T uint16;
+
+typedef TIFF_INT32_T int32;
+typedef TIFF_UINT32_T uint32;
+
+typedef TIFF_INT64_T int64;
+typedef TIFF_UINT64_T uint64;
+
+/*
+ * Some types as promoted in a variable argument list
+ * We use uint16_vap rather then directly using int, because this way
+ * we document the type we actually want to pass through, conceptually,
+ * rather then confusing the issue by merely stating the type it gets
+ * promoted to
+ */
+
+typedef int uint16_vap;
+
+/*
+ * TIFF header.
+ */
+typedef struct {
+ uint16 tiff_magic; /* magic number (defines byte order) */
+ uint16 tiff_version; /* TIFF version number */
+} TIFFHeaderCommon;
+typedef struct {
+ uint16 tiff_magic; /* magic number (defines byte order) */
+ uint16 tiff_version; /* TIFF version number */
+ uint32 tiff_diroff; /* byte offset to first directory */
+} TIFFHeaderClassic;
+typedef struct {
+ uint16 tiff_magic; /* magic number (defines byte order) */
+ uint16 tiff_version; /* TIFF version number */
+ uint16 tiff_offsetsize; /* size of offsets, should be 8 */
+ uint16 tiff_unused; /* unused word, should be 0 */
+ uint64 tiff_diroff; /* byte offset to first directory */
+} TIFFHeaderBig;
+
+
+/*
+ * NB: In the comments below,
+ * - items marked with a + are obsoleted by revision 5.0,
+ * - items marked with a ! are introduced in revision 6.0.
+ * - items marked with a % are introduced post revision 6.0.
+ * - items marked with a $ are obsoleted by revision 6.0.
+ * - items marked with a & are introduced by Adobe DNG specification.
+ */
+
+/*
+ * Tag data type information.
+ *
+ * Note: RATIONALs are the ratio of two 32-bit integer values.
+ */
+typedef enum {
+ TIFF_NOTYPE = 0, /* placeholder */
+ TIFF_BYTE = 1, /* 8-bit unsigned integer */
+ TIFF_ASCII = 2, /* 8-bit bytes w/ last byte null */
+ TIFF_SHORT = 3, /* 16-bit unsigned integer */
+ TIFF_LONG = 4, /* 32-bit unsigned integer */
+ TIFF_RATIONAL = 5, /* 64-bit unsigned fraction */
+ TIFF_SBYTE = 6, /* !8-bit signed integer */
+ TIFF_UNDEFINED = 7, /* !8-bit untyped data */
+ TIFF_SSHORT = 8, /* !16-bit signed integer */
+ TIFF_SLONG = 9, /* !32-bit signed integer */
+ TIFF_SRATIONAL = 10, /* !64-bit signed fraction */
+ TIFF_FLOAT = 11, /* !32-bit IEEE floating point */
+ TIFF_DOUBLE = 12, /* !64-bit IEEE floating point */
+ TIFF_IFD = 13, /* %32-bit unsigned integer (offset) */
+ TIFF_LONG8 = 16, /* BigTIFF 64-bit unsigned integer */
+ TIFF_SLONG8 = 17, /* BigTIFF 64-bit signed integer */
+ TIFF_IFD8 = 18 /* BigTIFF 64-bit unsigned integer (offset) */
+} TIFFDataType;
+
+/*
+ * TIFF Tag Definitions.
+ */
+#define TIFFTAG_SUBFILETYPE 254 /* subfile data descriptor */
+#define FILETYPE_REDUCEDIMAGE 0x1 /* reduced resolution version */
+#define FILETYPE_PAGE 0x2 /* one page of many */
+#define FILETYPE_MASK 0x4 /* transparency mask */
+#define TIFFTAG_OSUBFILETYPE 255 /* +kind of data in subfile */
+#define OFILETYPE_IMAGE 1 /* full resolution image data */
+#define OFILETYPE_REDUCEDIMAGE 2 /* reduced size image data */
+#define OFILETYPE_PAGE 3 /* one page of many */
+#define TIFFTAG_IMAGEWIDTH 256 /* image width in pixels */
+#define TIFFTAG_IMAGELENGTH 257 /* image height in pixels */
+#define TIFFTAG_BITSPERSAMPLE 258 /* bits per channel (sample) */
+#define TIFFTAG_COMPRESSION 259 /* data compression technique */
+#define COMPRESSION_NONE 1 /* dump mode */
+#define COMPRESSION_CCITTRLE 2 /* CCITT modified Huffman RLE */
+#define COMPRESSION_CCITTFAX3 3 /* CCITT Group 3 fax encoding */
+#define COMPRESSION_CCITT_T4 3 /* CCITT T.4 (TIFF 6 name) */
+#define COMPRESSION_CCITTFAX4 4 /* CCITT Group 4 fax encoding */
+#define COMPRESSION_CCITT_T6 4 /* CCITT T.6 (TIFF 6 name) */
+#define COMPRESSION_LZW 5 /* Lempel-Ziv & Welch */
+#define COMPRESSION_OJPEG 6 /* !6.0 JPEG */
+#define COMPRESSION_JPEG 7 /* %JPEG DCT compression */
+#define COMPRESSION_T85 9 /* !TIFF/FX T.85 JBIG compression */
+#define COMPRESSION_T43 10 /* !TIFF/FX T.43 colour by layered JBIG compression */
+#define COMPRESSION_NEXT 32766 /* NeXT 2-bit RLE */
+#define COMPRESSION_CCITTRLEW 32771 /* #1 w/ word alignment */
+#define COMPRESSION_PACKBITS 32773 /* Macintosh RLE */
+#define COMPRESSION_THUNDERSCAN 32809 /* ThunderScan RLE */
+/* codes 32895-32898 are reserved for ANSI IT8 TIFF/IT <dkelly@apago.com) */
+#define COMPRESSION_IT8CTPAD 32895 /* IT8 CT w/padding */
+#define COMPRESSION_IT8LW 32896 /* IT8 Linework RLE */
+#define COMPRESSION_IT8MP 32897 /* IT8 Monochrome picture */
+#define COMPRESSION_IT8BL 32898 /* IT8 Binary line art */
+/* compression codes 32908-32911 are reserved for Pixar */
+#define COMPRESSION_PIXARFILM 32908 /* Pixar companded 10bit LZW */
+#define COMPRESSION_PIXARLOG 32909 /* Pixar companded 11bit ZIP */
+#define COMPRESSION_DEFLATE 32946 /* Deflate compression */
+#define COMPRESSION_ADOBE_DEFLATE 8 /* Deflate compression,
+ as recognized by Adobe */
+/* compression code 32947 is reserved for Oceana Matrix <dev@oceana.com> */
+#define COMPRESSION_DCS 32947 /* Kodak DCS encoding */
+#define COMPRESSION_JBIG 34661 /* ISO JBIG */
+#define COMPRESSION_SGILOG 34676 /* SGI Log Luminance RLE */
+#define COMPRESSION_SGILOG24 34677 /* SGI Log 24-bit packed */
+#define COMPRESSION_JP2000 34712 /* Leadtools JPEG2000 */
+#define COMPRESSION_LERC 34887 /* ESRI Lerc codec: https://github.com/Esri/lerc */
+/* compression codes 34887-34889 are reserved for ESRI */
+#define COMPRESSION_LZMA 34925 /* LZMA2 */
+#define COMPRESSION_ZSTD 50000 /* ZSTD: WARNING not registered in Adobe-maintained registry */
+#define COMPRESSION_WEBP 50001 /* WEBP: WARNING not registered in Adobe-maintained registry */
+#define TIFFTAG_PHOTOMETRIC 262 /* photometric interpretation */
+#define PHOTOMETRIC_MINISWHITE 0 /* min value is white */
+#define PHOTOMETRIC_MINISBLACK 1 /* min value is black */
+#define PHOTOMETRIC_RGB 2 /* RGB color model */
+#define PHOTOMETRIC_PALETTE 3 /* color map indexed */
+#define PHOTOMETRIC_MASK 4 /* $holdout mask */
+#define PHOTOMETRIC_SEPARATED 5 /* !color separations */
+#define PHOTOMETRIC_YCBCR 6 /* !CCIR 601 */
+#define PHOTOMETRIC_CIELAB 8 /* !1976 CIE L*a*b* */
+#define PHOTOMETRIC_ICCLAB 9 /* ICC L*a*b* [Adobe TIFF Technote 4] */
+#define PHOTOMETRIC_ITULAB 10 /* ITU L*a*b* */
+#define PHOTOMETRIC_CFA 32803 /* color filter array */
+#define PHOTOMETRIC_LOGL 32844 /* CIE Log2(L) */
+#define PHOTOMETRIC_LOGLUV 32845 /* CIE Log2(L) (u',v') */
+#define TIFFTAG_THRESHHOLDING 263 /* +thresholding used on data */
+#define THRESHHOLD_BILEVEL 1 /* b&w art scan */
+#define THRESHHOLD_HALFTONE 2 /* or dithered scan */
+#define THRESHHOLD_ERRORDIFFUSE 3 /* usually floyd-steinberg */
+#define TIFFTAG_CELLWIDTH 264 /* +dithering matrix width */
+#define TIFFTAG_CELLLENGTH 265 /* +dithering matrix height */
+#define TIFFTAG_FILLORDER 266 /* data order within a byte */
+#define FILLORDER_MSB2LSB 1 /* most significant -> least */
+#define FILLORDER_LSB2MSB 2 /* least significant -> most */
+#define TIFFTAG_DOCUMENTNAME 269 /* name of doc. image is from */
+#define TIFFTAG_IMAGEDESCRIPTION 270 /* info about image */
+#define TIFFTAG_MAKE 271 /* scanner manufacturer name */
+#define TIFFTAG_MODEL 272 /* scanner model name/number */
+#define TIFFTAG_STRIPOFFSETS 273 /* offsets to data strips */
+#define TIFFTAG_ORIENTATION 274 /* +image orientation */
+#define ORIENTATION_TOPLEFT 1 /* row 0 top, col 0 lhs */
+#define ORIENTATION_TOPRIGHT 2 /* row 0 top, col 0 rhs */
+#define ORIENTATION_BOTRIGHT 3 /* row 0 bottom, col 0 rhs */
+#define ORIENTATION_BOTLEFT 4 /* row 0 bottom, col 0 lhs */
+#define ORIENTATION_LEFTTOP 5 /* row 0 lhs, col 0 top */
+#define ORIENTATION_RIGHTTOP 6 /* row 0 rhs, col 0 top */
+#define ORIENTATION_RIGHTBOT 7 /* row 0 rhs, col 0 bottom */
+#define ORIENTATION_LEFTBOT 8 /* row 0 lhs, col 0 bottom */
+#define TIFFTAG_SAMPLESPERPIXEL 277 /* samples per pixel */
+#define TIFFTAG_ROWSPERSTRIP 278 /* rows per strip of data */
+#define TIFFTAG_STRIPBYTECOUNTS 279 /* bytes counts for strips */
+#define TIFFTAG_MINSAMPLEVALUE 280 /* +minimum sample value */
+#define TIFFTAG_MAXSAMPLEVALUE 281 /* +maximum sample value */
+#define TIFFTAG_XRESOLUTION 282 /* pixels/resolution in x */
+#define TIFFTAG_YRESOLUTION 283 /* pixels/resolution in y */
+#define TIFFTAG_PLANARCONFIG 284 /* storage organization */
+#define PLANARCONFIG_CONTIG 1 /* single image plane */
+#define PLANARCONFIG_SEPARATE 2 /* separate planes of data */
+#define TIFFTAG_PAGENAME 285 /* page name image is from */
+#define TIFFTAG_XPOSITION 286 /* x page offset of image lhs */
+#define TIFFTAG_YPOSITION 287 /* y page offset of image lhs */
+#define TIFFTAG_FREEOFFSETS 288 /* +byte offset to free block */
+#define TIFFTAG_FREEBYTECOUNTS 289 /* +sizes of free blocks */
+#define TIFFTAG_GRAYRESPONSEUNIT 290 /* $gray scale curve accuracy */
+#define GRAYRESPONSEUNIT_10S 1 /* tenths of a unit */
+#define GRAYRESPONSEUNIT_100S 2 /* hundredths of a unit */
+#define GRAYRESPONSEUNIT_1000S 3 /* thousandths of a unit */
+#define GRAYRESPONSEUNIT_10000S 4 /* ten-thousandths of a unit */
+#define GRAYRESPONSEUNIT_100000S 5 /* hundred-thousandths */
+#define TIFFTAG_GRAYRESPONSECURVE 291 /* $gray scale response curve */
+#define TIFFTAG_GROUP3OPTIONS 292 /* 32 flag bits */
+#define TIFFTAG_T4OPTIONS 292 /* TIFF 6.0 proper name alias */
+#define GROUP3OPT_2DENCODING 0x1 /* 2-dimensional coding */
+#define GROUP3OPT_UNCOMPRESSED 0x2 /* data not compressed */
+#define GROUP3OPT_FILLBITS 0x4 /* fill to byte boundary */
+#define TIFFTAG_GROUP4OPTIONS 293 /* 32 flag bits */
+#define TIFFTAG_T6OPTIONS 293 /* TIFF 6.0 proper name */
+#define GROUP4OPT_UNCOMPRESSED 0x2 /* data not compressed */
+#define TIFFTAG_RESOLUTIONUNIT 296 /* units of resolutions */
+#define RESUNIT_NONE 1 /* no meaningful units */
+#define RESUNIT_INCH 2 /* english */
+#define RESUNIT_CENTIMETER 3 /* metric */
+#define TIFFTAG_PAGENUMBER 297 /* page numbers of multi-page */
+#define TIFFTAG_COLORRESPONSEUNIT 300 /* $color curve accuracy */
+#define COLORRESPONSEUNIT_10S 1 /* tenths of a unit */
+#define COLORRESPONSEUNIT_100S 2 /* hundredths of a unit */
+#define COLORRESPONSEUNIT_1000S 3 /* thousandths of a unit */
+#define COLORRESPONSEUNIT_10000S 4 /* ten-thousandths of a unit */
+#define COLORRESPONSEUNIT_100000S 5 /* hundred-thousandths */
+#define TIFFTAG_TRANSFERFUNCTION 301 /* !colorimetry info */
+#define TIFFTAG_SOFTWARE 305 /* name & release */
+#define TIFFTAG_DATETIME 306 /* creation date and time */
+#define TIFFTAG_ARTIST 315 /* creator of image */
+#define TIFFTAG_HOSTCOMPUTER 316 /* machine where created */
+#define TIFFTAG_PREDICTOR 317 /* prediction scheme w/ LZW */
+#define PREDICTOR_NONE 1 /* no prediction scheme used */
+#define PREDICTOR_HORIZONTAL 2 /* horizontal differencing */
+#define PREDICTOR_FLOATINGPOINT 3 /* floating point predictor */
+#define TIFFTAG_WHITEPOINT 318 /* image white point */
+#define TIFFTAG_PRIMARYCHROMATICITIES 319 /* !primary chromaticities */
+#define TIFFTAG_COLORMAP 320 /* RGB map for palette image */
+#define TIFFTAG_HALFTONEHINTS 321 /* !highlight+shadow info */
+#define TIFFTAG_TILEWIDTH 322 /* !tile width in pixels */
+#define TIFFTAG_TILELENGTH 323 /* !tile height in pixels */
+#define TIFFTAG_TILEOFFSETS 324 /* !offsets to data tiles */
+#define TIFFTAG_TILEBYTECOUNTS 325 /* !byte counts for tiles */
+#define TIFFTAG_BADFAXLINES 326 /* lines w/ wrong pixel count */
+#define TIFFTAG_CLEANFAXDATA 327 /* regenerated line info */
+#define CLEANFAXDATA_CLEAN 0 /* no errors detected */
+#define CLEANFAXDATA_REGENERATED 1 /* receiver regenerated lines */
+#define CLEANFAXDATA_UNCLEAN 2 /* uncorrected errors exist */
+#define TIFFTAG_CONSECUTIVEBADFAXLINES 328 /* max consecutive bad lines */
+#define TIFFTAG_SUBIFD 330 /* subimage descriptors */
+#define TIFFTAG_INKSET 332 /* !inks in separated image */
+#define INKSET_CMYK 1 /* !cyan-magenta-yellow-black color */
+#define INKSET_MULTIINK 2 /* !multi-ink or hi-fi color */
+#define TIFFTAG_INKNAMES 333 /* !ascii names of inks */
+#define TIFFTAG_NUMBEROFINKS 334 /* !number of inks */
+#define TIFFTAG_DOTRANGE 336 /* !0% and 100% dot codes */
+#define TIFFTAG_TARGETPRINTER 337 /* !separation target */
+#define TIFFTAG_EXTRASAMPLES 338 /* !info about extra samples */
+#define EXTRASAMPLE_UNSPECIFIED 0 /* !unspecified data */
+#define EXTRASAMPLE_ASSOCALPHA 1 /* !associated alpha data */
+#define EXTRASAMPLE_UNASSALPHA 2 /* !unassociated alpha data */
+#define TIFFTAG_SAMPLEFORMAT 339 /* !data sample format */
+#define SAMPLEFORMAT_UINT 1 /* !unsigned integer data */
+#define SAMPLEFORMAT_INT 2 /* !signed integer data */
+#define SAMPLEFORMAT_IEEEFP 3 /* !IEEE floating point data */
+#define SAMPLEFORMAT_VOID 4 /* !untyped data */
+#define SAMPLEFORMAT_COMPLEXINT 5 /* !complex signed int */
+#define SAMPLEFORMAT_COMPLEXIEEEFP 6 /* !complex ieee floating */
+#define TIFFTAG_SMINSAMPLEVALUE 340 /* !variable MinSampleValue */
+#define TIFFTAG_SMAXSAMPLEVALUE 341 /* !variable MaxSampleValue */
+#define TIFFTAG_CLIPPATH 343 /* %ClipPath
+ [Adobe TIFF technote 2] */
+#define TIFFTAG_XCLIPPATHUNITS 344 /* %XClipPathUnits
+ [Adobe TIFF technote 2] */
+#define TIFFTAG_YCLIPPATHUNITS 345 /* %YClipPathUnits
+ [Adobe TIFF technote 2] */
+#define TIFFTAG_INDEXED 346 /* %Indexed
+ [Adobe TIFF Technote 3] */
+#define TIFFTAG_JPEGTABLES 347 /* %JPEG table stream */
+#define TIFFTAG_OPIPROXY 351 /* %OPI Proxy [Adobe TIFF technote] */
+/* Tags 400-435 are from the TIFF/FX spec */
+#define TIFFTAG_GLOBALPARAMETERSIFD 400 /* ! */
+#define TIFFTAG_PROFILETYPE 401 /* ! */
+#define PROFILETYPE_UNSPECIFIED 0 /* ! */
+#define PROFILETYPE_G3_FAX 1 /* ! */
+#define TIFFTAG_FAXPROFILE 402 /* ! */
+#define FAXPROFILE_S 1 /* !TIFF/FX FAX profile S */
+#define FAXPROFILE_F 2 /* !TIFF/FX FAX profile F */
+#define FAXPROFILE_J 3 /* !TIFF/FX FAX profile J */
+#define FAXPROFILE_C 4 /* !TIFF/FX FAX profile C */
+#define FAXPROFILE_L 5 /* !TIFF/FX FAX profile L */
+#define FAXPROFILE_M 6 /* !TIFF/FX FAX profile LM */
+#define TIFFTAG_CODINGMETHODS 403 /* !TIFF/FX coding methods */
+#define CODINGMETHODS_T4_1D (1 << 1) /* !T.4 1D */
+#define CODINGMETHODS_T4_2D (1 << 2) /* !T.4 2D */
+#define CODINGMETHODS_T6 (1 << 3) /* !T.6 */
+#define CODINGMETHODS_T85 (1 << 4) /* !T.85 JBIG */
+#define CODINGMETHODS_T42 (1 << 5) /* !T.42 JPEG */
+#define CODINGMETHODS_T43 (1 << 6) /* !T.43 colour by layered JBIG */
+#define TIFFTAG_VERSIONYEAR 404 /* !TIFF/FX version year */
+#define TIFFTAG_MODENUMBER 405 /* !TIFF/FX mode number */
+#define TIFFTAG_DECODE 433 /* !TIFF/FX decode */
+#define TIFFTAG_IMAGEBASECOLOR 434 /* !TIFF/FX image base colour */
+#define TIFFTAG_T82OPTIONS 435 /* !TIFF/FX T.82 options */
+/*
+ * Tags 512-521 are obsoleted by Technical Note #2 which specifies a
+ * revised JPEG-in-TIFF scheme.
+ */
+#define TIFFTAG_JPEGPROC 512 /* !JPEG processing algorithm */
+#define JPEGPROC_BASELINE 1 /* !baseline sequential */
+#define JPEGPROC_LOSSLESS 14 /* !Huffman coded lossless */
+#define TIFFTAG_JPEGIFOFFSET 513 /* !pointer to SOI marker */
+#define TIFFTAG_JPEGIFBYTECOUNT 514 /* !JFIF stream length */
+#define TIFFTAG_JPEGRESTARTINTERVAL 515 /* !restart interval length */
+#define TIFFTAG_JPEGLOSSLESSPREDICTORS 517 /* !lossless proc predictor */
+#define TIFFTAG_JPEGPOINTTRANSFORM 518 /* !lossless point transform */
+#define TIFFTAG_JPEGQTABLES 519 /* !Q matrix offsets */
+#define TIFFTAG_JPEGDCTABLES 520 /* !DCT table offsets */
+#define TIFFTAG_JPEGACTABLES 521 /* !AC coefficient offsets */
+#define TIFFTAG_YCBCRCOEFFICIENTS 529 /* !RGB -> YCbCr transform */
+#define TIFFTAG_YCBCRSUBSAMPLING 530 /* !YCbCr subsampling factors */
+#define TIFFTAG_YCBCRPOSITIONING 531 /* !subsample positioning */
+#define YCBCRPOSITION_CENTERED 1 /* !as in PostScript Level 2 */
+#define YCBCRPOSITION_COSITED 2 /* !as in CCIR 601-1 */
+#define TIFFTAG_REFERENCEBLACKWHITE 532 /* !colorimetry info */
+#define TIFFTAG_STRIPROWCOUNTS 559 /* !TIFF/FX strip row counts */
+#define TIFFTAG_XMLPACKET 700 /* %XML packet
+ [Adobe XMP Specification,
+ January 2004 */
+#define TIFFTAG_OPIIMAGEID 32781 /* %OPI ImageID
+ [Adobe TIFF technote] */
+/* tags 32952-32956 are private tags registered to Island Graphics */
+#define TIFFTAG_REFPTS 32953 /* image reference points */
+#define TIFFTAG_REGIONTACKPOINT 32954 /* region-xform tack point */
+#define TIFFTAG_REGIONWARPCORNERS 32955 /* warp quadrilateral */
+#define TIFFTAG_REGIONAFFINE 32956 /* affine transformation mat */
+/* tags 32995-32999 are private tags registered to SGI */
+#define TIFFTAG_MATTEING 32995 /* $use ExtraSamples */
+#define TIFFTAG_DATATYPE 32996 /* $use SampleFormat */
+#define TIFFTAG_IMAGEDEPTH 32997 /* z depth of image */
+#define TIFFTAG_TILEDEPTH 32998 /* z depth/data tile */
+/* tags 33300-33309 are private tags registered to Pixar */
+/*
+ * TIFFTAG_PIXAR_IMAGEFULLWIDTH and TIFFTAG_PIXAR_IMAGEFULLLENGTH
+ * are set when an image has been cropped out of a larger image.
+ * They reflect the size of the original uncropped image.
+ * The TIFFTAG_XPOSITION and TIFFTAG_YPOSITION can be used
+ * to determine the position of the smaller image in the larger one.
+ */
+#define TIFFTAG_PIXAR_IMAGEFULLWIDTH 33300 /* full image size in x */
+#define TIFFTAG_PIXAR_IMAGEFULLLENGTH 33301 /* full image size in y */
+ /* Tags 33302-33306 are used to identify special image modes and data
+ * used by Pixar's texture formats.
+ */
+#define TIFFTAG_PIXAR_TEXTUREFORMAT 33302 /* texture map format */
+#define TIFFTAG_PIXAR_WRAPMODES 33303 /* s & t wrap modes */
+#define TIFFTAG_PIXAR_FOVCOT 33304 /* cotan(fov) for env. maps */
+#define TIFFTAG_PIXAR_MATRIX_WORLDTOSCREEN 33305
+#define TIFFTAG_PIXAR_MATRIX_WORLDTOCAMERA 33306
+/* tag 33405 is a private tag registered to Eastman Kodak */
+#define TIFFTAG_WRITERSERIALNUMBER 33405 /* device serial number */
+#define TIFFTAG_CFAREPEATPATTERNDIM 33421 /* dimensions of CFA pattern */
+#define TIFFTAG_CFAPATTERN 33422 /* color filter array pattern */
+/* tag 33432 is listed in the 6.0 spec w/ unknown ownership */
+#define TIFFTAG_COPYRIGHT 33432 /* copyright string */
+/* IPTC TAG from RichTIFF specifications */
+#define TIFFTAG_RICHTIFFIPTC 33723
+/* 34016-34029 are reserved for ANSI IT8 TIFF/IT <dkelly@apago.com) */
+#define TIFFTAG_IT8SITE 34016 /* site name */
+#define TIFFTAG_IT8COLORSEQUENCE 34017 /* color seq. [RGB,CMYK,etc] */
+#define TIFFTAG_IT8HEADER 34018 /* DDES Header */
+#define TIFFTAG_IT8RASTERPADDING 34019 /* raster scanline padding */
+#define TIFFTAG_IT8BITSPERRUNLENGTH 34020 /* # of bits in short run */
+#define TIFFTAG_IT8BITSPEREXTENDEDRUNLENGTH 34021/* # of bits in long run */
+#define TIFFTAG_IT8COLORTABLE 34022 /* LW colortable */
+#define TIFFTAG_IT8IMAGECOLORINDICATOR 34023 /* BP/BL image color switch */
+#define TIFFTAG_IT8BKGCOLORINDICATOR 34024 /* BP/BL bg color switch */
+#define TIFFTAG_IT8IMAGECOLORVALUE 34025 /* BP/BL image color value */
+#define TIFFTAG_IT8BKGCOLORVALUE 34026 /* BP/BL bg color value */
+#define TIFFTAG_IT8PIXELINTENSITYRANGE 34027 /* MP pixel intensity value */
+#define TIFFTAG_IT8TRANSPARENCYINDICATOR 34028 /* HC transparency switch */
+#define TIFFTAG_IT8COLORCHARACTERIZATION 34029 /* color character. table */
+#define TIFFTAG_IT8HCUSAGE 34030 /* HC usage indicator */
+#define TIFFTAG_IT8TRAPINDICATOR 34031 /* Trapping indicator
+ (untrapped=0, trapped=1) */
+#define TIFFTAG_IT8CMYKEQUIVALENT 34032 /* CMYK color equivalents */
+/* tags 34232-34236 are private tags registered to Texas Instruments */
+#define TIFFTAG_FRAMECOUNT 34232 /* Sequence Frame Count */
+/* tag 34377 is private tag registered to Adobe for PhotoShop */
+#define TIFFTAG_PHOTOSHOP 34377
+/* tags 34665, 34853 and 40965 are documented in EXIF specification */
+#define TIFFTAG_EXIFIFD 34665 /* Pointer to EXIF private directory */
+/* tag 34750 is a private tag registered to Adobe? */
+#define TIFFTAG_ICCPROFILE 34675 /* ICC profile data */
+#define TIFFTAG_IMAGELAYER 34732 /* !TIFF/FX image layer information */
+/* tag 34750 is a private tag registered to Pixel Magic */
+#define TIFFTAG_JBIGOPTIONS 34750 /* JBIG options */
+#define TIFFTAG_GPSIFD 34853 /* Pointer to GPS private directory */
+/* tags 34908-34914 are private tags registered to SGI */
+#define TIFFTAG_FAXRECVPARAMS 34908 /* encoded Class 2 ses. parms */
+#define TIFFTAG_FAXSUBADDRESS 34909 /* received SubAddr string */
+#define TIFFTAG_FAXRECVTIME 34910 /* receive time (secs) */
+#define TIFFTAG_FAXDCS 34911 /* encoded fax ses. params, Table 2/T.30 */
+/* tags 37439-37443 are registered to SGI <gregl@sgi.com> */
+#define TIFFTAG_STONITS 37439 /* Sample value to Nits */
+/* tag 34929 is a private tag registered to FedEx */
+#define TIFFTAG_FEDEX_EDR 34929 /* unknown use */
+#define TIFFTAG_INTEROPERABILITYIFD 40965 /* Pointer to Interoperability private directory */
+/* tags 50674 to 50677 are reserved for ESRI */
+#define TIFFTAG_LERC_PARAMETERS 50674 /* Stores LERC version and additional compression method */
+/* Adobe Digital Negative (DNG) format tags */
+#define TIFFTAG_DNGVERSION 50706 /* &DNG version number */
+#define TIFFTAG_DNGBACKWARDVERSION 50707 /* &DNG compatibility version */
+#define TIFFTAG_UNIQUECAMERAMODEL 50708 /* &name for the camera model */
+#define TIFFTAG_LOCALIZEDCAMERAMODEL 50709 /* &localized camera model
+ name */
+#define TIFFTAG_CFAPLANECOLOR 50710 /* &CFAPattern->LinearRaw space
+ mapping */
+#define TIFFTAG_CFALAYOUT 50711 /* &spatial layout of the CFA */
+#define TIFFTAG_LINEARIZATIONTABLE 50712 /* &lookup table description */
+#define TIFFTAG_BLACKLEVELREPEATDIM 50713 /* &repeat pattern size for
+ the BlackLevel tag */
+#define TIFFTAG_BLACKLEVEL 50714 /* &zero light encoding level */
+#define TIFFTAG_BLACKLEVELDELTAH 50715 /* &zero light encoding level
+ differences (columns) */
+#define TIFFTAG_BLACKLEVELDELTAV 50716 /* &zero light encoding level
+ differences (rows) */
+#define TIFFTAG_WHITELEVEL 50717 /* &fully saturated encoding
+ level */
+#define TIFFTAG_DEFAULTSCALE 50718 /* &default scale factors */
+#define TIFFTAG_DEFAULTCROPORIGIN 50719 /* &origin of the final image
+ area */
+#define TIFFTAG_DEFAULTCROPSIZE 50720 /* &size of the final image
+ area */
+#define TIFFTAG_COLORMATRIX1 50721 /* &XYZ->reference color space
+ transformation matrix 1 */
+#define TIFFTAG_COLORMATRIX2 50722 /* &XYZ->reference color space
+ transformation matrix 2 */
+#define TIFFTAG_CAMERACALIBRATION1 50723 /* &calibration matrix 1 */
+#define TIFFTAG_CAMERACALIBRATION2 50724 /* &calibration matrix 2 */
+#define TIFFTAG_REDUCTIONMATRIX1 50725 /* &dimensionality reduction
+ matrix 1 */
+#define TIFFTAG_REDUCTIONMATRIX2 50726 /* &dimensionality reduction
+ matrix 2 */
+#define TIFFTAG_ANALOGBALANCE 50727 /* &gain applied the stored raw
+ values*/
+#define TIFFTAG_ASSHOTNEUTRAL 50728 /* &selected white balance in
+ linear reference space */
+#define TIFFTAG_ASSHOTWHITEXY 50729 /* &selected white balance in
+ x-y chromaticity
+ coordinates */
+#define TIFFTAG_BASELINEEXPOSURE 50730 /* &how much to move the zero
+ point */
+#define TIFFTAG_BASELINENOISE 50731 /* &relative noise level */
+#define TIFFTAG_BASELINESHARPNESS 50732 /* &relative amount of
+ sharpening */
+#define TIFFTAG_BAYERGREENSPLIT 50733 /* &how closely the values of
+ the green pixels in the
+ blue/green rows track the
+ values of the green pixels
+ in the red/green rows */
+#define TIFFTAG_LINEARRESPONSELIMIT 50734 /* &non-linear encoding range */
+#define TIFFTAG_CAMERASERIALNUMBER 50735 /* &camera's serial number */
+#define TIFFTAG_LENSINFO 50736 /* info about the lens */
+#define TIFFTAG_CHROMABLURRADIUS 50737 /* &chroma blur radius */
+#define TIFFTAG_ANTIALIASSTRENGTH 50738 /* &relative strength of the
+ camera's anti-alias filter */
+#define TIFFTAG_SHADOWSCALE 50739 /* &used by Adobe Camera Raw */
+#define TIFFTAG_DNGPRIVATEDATA 50740 /* &manufacturer's private data */
+#define TIFFTAG_MAKERNOTESAFETY 50741 /* &whether the EXIF MakerNote
+ tag is safe to preserve
+ along with the rest of the
+ EXIF data */
+#define TIFFTAG_CALIBRATIONILLUMINANT1 50778 /* &illuminant 1 */
+#define TIFFTAG_CALIBRATIONILLUMINANT2 50779 /* &illuminant 2 */
+#define TIFFTAG_BESTQUALITYSCALE 50780 /* &best quality multiplier */
+#define TIFFTAG_RAWDATAUNIQUEID 50781 /* &unique identifier for
+ the raw image data */
+#define TIFFTAG_ORIGINALRAWFILENAME 50827 /* &file name of the original
+ raw file */
+#define TIFFTAG_ORIGINALRAWFILEDATA 50828 /* &contents of the original
+ raw file */
+#define TIFFTAG_ACTIVEAREA 50829 /* &active (non-masked) pixels
+ of the sensor */
+#define TIFFTAG_MASKEDAREAS 50830 /* &list of coordinates
+ of fully masked pixels */
+#define TIFFTAG_ASSHOTICCPROFILE 50831 /* &these two tags used to */
+#define TIFFTAG_ASSHOTPREPROFILEMATRIX 50832 /* map cameras's color space
+ into ICC profile space */
+#define TIFFTAG_CURRENTICCPROFILE 50833 /* & */
+#define TIFFTAG_CURRENTPREPROFILEMATRIX 50834 /* & */
+/* tag 65535 is an undefined tag used by Eastman Kodak */
+#define TIFFTAG_DCSHUESHIFTVALUES 65535 /* hue shift correction data */
+
+/*
+ * The following are ``pseudo tags'' that can be used to control
+ * codec-specific functionality. These tags are not written to file.
+ * Note that these values start at 0xffff+1 so that they'll never
+ * collide with Aldus-assigned tags.
+ *
+ * If you want your private pseudo tags ``registered'' (i.e. added to
+ * this file), please post a bug report via the tracking system at
+ * http://www.remotesensing.org/libtiff/bugs.html with the appropriate
+ * C definitions to add.
+ */
+#define TIFFTAG_FAXMODE 65536 /* Group 3/4 format control */
+#define FAXMODE_CLASSIC 0x0000 /* default, include RTC */
+#define FAXMODE_NORTC 0x0001 /* no RTC at end of data */
+#define FAXMODE_NOEOL 0x0002 /* no EOL code at end of row */
+#define FAXMODE_BYTEALIGN 0x0004 /* byte align row */
+#define FAXMODE_WORDALIGN 0x0008 /* word align row */
+#define FAXMODE_CLASSF FAXMODE_NORTC /* TIFF Class F */
+#define TIFFTAG_JPEGQUALITY 65537 /* Compression quality level */
+/* Note: quality level is on the IJG 0-100 scale. Default value is 75 */
+#define TIFFTAG_JPEGCOLORMODE 65538 /* Auto RGB<=>YCbCr convert? */
+#define JPEGCOLORMODE_RAW 0x0000 /* no conversion (default) */
+#define JPEGCOLORMODE_RGB 0x0001 /* do auto conversion */
+#define TIFFTAG_JPEGTABLESMODE 65539 /* What to put in JPEGTables */
+#define JPEGTABLESMODE_QUANT 0x0001 /* include quantization tbls */
+#define JPEGTABLESMODE_HUFF 0x0002 /* include Huffman tbls */
+/* Note: default is JPEGTABLESMODE_QUANT | JPEGTABLESMODE_HUFF */
+#define TIFFTAG_FAXFILLFUNC 65540 /* G3/G4 fill function */
+#define TIFFTAG_PIXARLOGDATAFMT 65549 /* PixarLogCodec I/O data sz */
+#define PIXARLOGDATAFMT_8BIT 0 /* regular u_char samples */
+#define PIXARLOGDATAFMT_8BITABGR 1 /* ABGR-order u_chars */
+#define PIXARLOGDATAFMT_11BITLOG 2 /* 11-bit log-encoded (raw) */
+#define PIXARLOGDATAFMT_12BITPICIO 3 /* as per PICIO (1.0==2048) */
+#define PIXARLOGDATAFMT_16BIT 4 /* signed short samples */
+#define PIXARLOGDATAFMT_FLOAT 5 /* IEEE float samples */
+/* 65550-65556 are allocated to Oceana Matrix <dev@oceana.com> */
+#define TIFFTAG_DCSIMAGERTYPE 65550 /* imager model & filter */
+#define DCSIMAGERMODEL_M3 0 /* M3 chip (1280 x 1024) */
+#define DCSIMAGERMODEL_M5 1 /* M5 chip (1536 x 1024) */
+#define DCSIMAGERMODEL_M6 2 /* M6 chip (3072 x 2048) */
+#define DCSIMAGERFILTER_IR 0 /* infrared filter */
+#define DCSIMAGERFILTER_MONO 1 /* monochrome filter */
+#define DCSIMAGERFILTER_CFA 2 /* color filter array */
+#define DCSIMAGERFILTER_OTHER 3 /* other filter */
+#define TIFFTAG_DCSINTERPMODE 65551 /* interpolation mode */
+#define DCSINTERPMODE_NORMAL 0x0 /* whole image, default */
+#define DCSINTERPMODE_PREVIEW 0x1 /* preview of image (384x256) */
+#define TIFFTAG_DCSBALANCEARRAY 65552 /* color balance values */
+#define TIFFTAG_DCSCORRECTMATRIX 65553 /* color correction values */
+#define TIFFTAG_DCSGAMMA 65554 /* gamma value */
+#define TIFFTAG_DCSTOESHOULDERPTS 65555 /* toe & shoulder points */
+#define TIFFTAG_DCSCALIBRATIONFD 65556 /* calibration file desc */
+/* Note: quality level is on the ZLIB 1-9 scale. Default value is -1 */
+#define TIFFTAG_ZIPQUALITY 65557 /* compression quality level */
+#define TIFFTAG_PIXARLOGQUALITY 65558 /* PixarLog uses same scale */
+/* 65559 is allocated to Oceana Matrix <dev@oceana.com> */
+#define TIFFTAG_DCSCLIPRECTANGLE 65559 /* area of image to acquire */
+#define TIFFTAG_SGILOGDATAFMT 65560 /* SGILog user data format */
+#define SGILOGDATAFMT_FLOAT 0 /* IEEE float samples */
+#define SGILOGDATAFMT_16BIT 1 /* 16-bit samples */
+#define SGILOGDATAFMT_RAW 2 /* uninterpreted data */
+#define SGILOGDATAFMT_8BIT 3 /* 8-bit RGB monitor values */
+#define TIFFTAG_SGILOGENCODE 65561 /* SGILog data encoding control*/
+#define SGILOGENCODE_NODITHER 0 /* do not dither encoded values*/
+#define SGILOGENCODE_RANDITHER 1 /* randomly dither encd values */
+#define TIFFTAG_LZMAPRESET 65562 /* LZMA2 preset (compression level) */
+#define TIFFTAG_PERSAMPLE 65563 /* interface for per sample tags */
+#define PERSAMPLE_MERGED 0 /* present as a single value */
+#define PERSAMPLE_MULTI 1 /* present as multiple values */
+#define TIFFTAG_ZSTD_LEVEL 65564 /* ZSTD compression level */
+#define TIFFTAG_LERC_VERSION 65565 /* LERC version */
+#define LERC_VERSION_2_4 4
+#define TIFFTAG_LERC_ADD_COMPRESSION 65566 /* LERC additional compression */
+#define LERC_ADD_COMPRESSION_NONE 0
+#define LERC_ADD_COMPRESSION_DEFLATE 1
+#define LERC_ADD_COMPRESSION_ZSTD 2
+#define TIFFTAG_LERC_MAXZERROR 65567 /* LERC maximum error */
+#define TIFFTAG_WEBP_LEVEL 65568 /* WebP compression level: WARNING not registered in Adobe-maintained registry */
+#define TIFFTAG_WEBP_LOSSLESS 65569 /* WebP lossless/lossy : WARNING not registered in Adobe-maintained registry */
+
+/*
+ * EXIF tags
+ */
+#define EXIFTAG_EXPOSURETIME 33434 /* Exposure time */
+#define EXIFTAG_FNUMBER 33437 /* F number */
+#define EXIFTAG_EXPOSUREPROGRAM 34850 /* Exposure program */
+#define EXIFTAG_SPECTRALSENSITIVITY 34852 /* Spectral sensitivity */
+#define EXIFTAG_ISOSPEEDRATINGS 34855 /* ISO speed rating */
+#define EXIFTAG_OECF 34856 /* Optoelectric conversion
+ factor */
+#define EXIFTAG_EXIFVERSION 36864 /* Exif version */
+#define EXIFTAG_DATETIMEORIGINAL 36867 /* Date and time of original
+ data generation */
+#define EXIFTAG_DATETIMEDIGITIZED 36868 /* Date and time of digital
+ data generation */
+#define EXIFTAG_COMPONENTSCONFIGURATION 37121 /* Meaning of each component */
+#define EXIFTAG_COMPRESSEDBITSPERPIXEL 37122 /* Image compression mode */
+#define EXIFTAG_SHUTTERSPEEDVALUE 37377 /* Shutter speed */
+#define EXIFTAG_APERTUREVALUE 37378 /* Aperture */
+#define EXIFTAG_BRIGHTNESSVALUE 37379 /* Brightness */
+#define EXIFTAG_EXPOSUREBIASVALUE 37380 /* Exposure bias */
+#define EXIFTAG_MAXAPERTUREVALUE 37381 /* Maximum lens aperture */
+#define EXIFTAG_SUBJECTDISTANCE 37382 /* Subject distance */
+#define EXIFTAG_METERINGMODE 37383 /* Metering mode */
+#define EXIFTAG_LIGHTSOURCE 37384 /* Light source */
+#define EXIFTAG_FLASH 37385 /* Flash */
+#define EXIFTAG_FOCALLENGTH 37386 /* Lens focal length */
+#define EXIFTAG_SUBJECTAREA 37396 /* Subject area */
+#define EXIFTAG_MAKERNOTE 37500 /* Manufacturer notes */
+#define EXIFTAG_USERCOMMENT 37510 /* User comments */
+#define EXIFTAG_SUBSECTIME 37520 /* DateTime subseconds */
+#define EXIFTAG_SUBSECTIMEORIGINAL 37521 /* DateTimeOriginal subseconds */
+#define EXIFTAG_SUBSECTIMEDIGITIZED 37522 /* DateTimeDigitized subseconds */
+#define EXIFTAG_FLASHPIXVERSION 40960 /* Supported Flashpix version */
+#define EXIFTAG_COLORSPACE 40961 /* Color space information */
+#define EXIFTAG_PIXELXDIMENSION 40962 /* Valid image width */
+#define EXIFTAG_PIXELYDIMENSION 40963 /* Valid image height */
+#define EXIFTAG_RELATEDSOUNDFILE 40964 /* Related audio file */
+#define EXIFTAG_FLASHENERGY 41483 /* Flash energy */
+#define EXIFTAG_SPATIALFREQUENCYRESPONSE 41484 /* Spatial frequency response */
+#define EXIFTAG_FOCALPLANEXRESOLUTION 41486 /* Focal plane X resolution */
+#define EXIFTAG_FOCALPLANEYRESOLUTION 41487 /* Focal plane Y resolution */
+#define EXIFTAG_FOCALPLANERESOLUTIONUNIT 41488 /* Focal plane resolution unit */
+#define EXIFTAG_SUBJECTLOCATION 41492 /* Subject location */
+#define EXIFTAG_EXPOSUREINDEX 41493 /* Exposure index */
+#define EXIFTAG_SENSINGMETHOD 41495 /* Sensing method */
+#define EXIFTAG_FILESOURCE 41728 /* File source */
+#define EXIFTAG_SCENETYPE 41729 /* Scene type */
+#define EXIFTAG_CFAPATTERN 41730 /* CFA pattern */
+#define EXIFTAG_CUSTOMRENDERED 41985 /* Custom image processing */
+#define EXIFTAG_EXPOSUREMODE 41986 /* Exposure mode */
+#define EXIFTAG_WHITEBALANCE 41987 /* White balance */
+#define EXIFTAG_DIGITALZOOMRATIO 41988 /* Digital zoom ratio */
+#define EXIFTAG_FOCALLENGTHIN35MMFILM 41989 /* Focal length in 35 mm film */
+#define EXIFTAG_SCENECAPTURETYPE 41990 /* Scene capture type */
+#define EXIFTAG_GAINCONTROL 41991 /* Gain control */
+#define EXIFTAG_CONTRAST 41992 /* Contrast */
+#define EXIFTAG_SATURATION 41993 /* Saturation */
+#define EXIFTAG_SHARPNESS 41994 /* Sharpness */
+#define EXIFTAG_DEVICESETTINGDESCRIPTION 41995 /* Device settings description */
+#define EXIFTAG_SUBJECTDISTANCERANGE 41996 /* Subject distance range */
+#define EXIFTAG_GAINCONTROL 41991 /* Gain control */
+#define EXIFTAG_GAINCONTROL 41991 /* Gain control */
+#define EXIFTAG_IMAGEUNIQUEID 42016 /* Unique image ID */
+
+#endif /* _TIFF_ */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tiffconf.h b/test/monniaux/tiff-4.0.10/tiffconf.h
new file mode 100644
index 00000000..d7a61a3f
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffconf.h
@@ -0,0 +1,119 @@
+/* libtiff/tiffconf.h. Generated from tiffconf.h.in by configure. */
+/*
+ Configuration defines for installed libtiff.
+ This file maintained for backward compatibility. Do not use definitions
+ from this file in your programs.
+*/
+
+#ifndef _TIFFCONF_
+#define _TIFFCONF_
+
+/* Signed 16-bit type */
+#define TIFF_INT16_T signed short
+
+/* Signed 32-bit type */
+#define TIFF_INT32_T signed int
+
+/* Signed 64-bit type */
+#define TIFF_INT64_T signed long
+
+/* Signed 8-bit type */
+#define TIFF_INT8_T signed char
+
+/* Unsigned 16-bit type */
+#define TIFF_UINT16_T unsigned short
+
+/* Unsigned 32-bit type */
+#define TIFF_UINT32_T unsigned int
+
+/* Unsigned 64-bit type */
+#define TIFF_UINT64_T unsigned long
+
+/* Unsigned 8-bit type */
+#define TIFF_UINT8_T unsigned char
+
+/* Signed size type */
+#define TIFF_SSIZE_T signed long
+
+/* Pointer difference type */
+#define TIFF_PTRDIFF_T ptrdiff_t
+
+/* Compatibility stuff. */
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Set the native cpu bit order (FILLORDER_LSB2MSB or FILLORDER_MSB2LSB) */
+#define HOST_FILLORDER FILLORDER_MSB2LSB
+
+/* Native cpu byte order: 1 if big-endian (Motorola) or 0 if little-endian
+ (Intel) */
+#define HOST_BIGENDIAN 0
+
+/* Support CCITT Group 3 & 4 algorithms */
+#define CCITT_SUPPORT 1
+
+/* Support JPEG compression (requires IJG JPEG library) */
+/* #undef JPEG_SUPPORT */
+
+/* Support JBIG compression (requires JBIG-KIT library) */
+/* #undef JBIG_SUPPORT */
+
+/* Support LogLuv high dynamic range encoding */
+#define LOGLUV_SUPPORT 1
+
+/* Support LZW algorithm */
+#define LZW_SUPPORT 1
+
+/* Support NeXT 2-bit RLE algorithm */
+#define NEXT_SUPPORT 1
+
+/* Support Old JPEG compresson (read contrib/ojpeg/README first! Compilation
+ fails with unpatched IJG JPEG library) */
+/* #undef OJPEG_SUPPORT */
+
+/* Support Macintosh PackBits algorithm */
+#define PACKBITS_SUPPORT 1
+
+/* Support Pixar log-format algorithm (requires Zlib) */
+/* #undef PIXARLOG_SUPPORT */
+
+/* Support ThunderScan 4-bit RLE algorithm */
+#define THUNDER_SUPPORT 1
+
+/* Support Deflate compression */
+/* #undef ZIP_SUPPORT */
+
+/* Support strip chopping (whether or not to convert single-strip uncompressed
+ images to mutiple strips of ~8Kb to reduce memory usage) */
+#define STRIPCHOP_DEFAULT TIFF_STRIPCHOP
+
+/* Enable SubIFD tag (330) support */
+#define SUBIFD_SUPPORT 1
+
+/* Treat extra sample as alpha (default enabled). The RGBA interface will
+ treat a fourth sample with no EXTRASAMPLE_ value as being ASSOCALPHA. Many
+ packages produce RGBA files but don't mark the alpha properly. */
+#define DEFAULT_EXTRASAMPLE_AS_ALPHA 1
+
+/* Pick up YCbCr subsampling info from the JPEG data stream to support files
+ lacking the tag (default enabled). */
+#define CHECK_JPEG_YCBCR_SUBSAMPLING 1
+
+/* Support MS MDI magic number files as TIFF */
+#define MDI_SUPPORT 1
+
+/*
+ * Feature support definitions.
+ * XXX: These macros are obsoleted. Don't use them in your apps!
+ * Macros stays here for backward compatibility and should be always defined.
+ */
+#define COLORIMETRY_SUPPORT
+#define YCBCR_SUPPORT
+#define CMYK_SUPPORT
+#define ICC_SUPPORT
+#define PHOTOSHOP_SUPPORT
+#define IPTC_SUPPORT
+
+#endif /* _TIFFCONF_ */
diff --git a/test/monniaux/tiff-4.0.10/tiffconf.vc.h b/test/monniaux/tiff-4.0.10/tiffconf.vc.h
new file mode 100644
index 00000000..fb37a755
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffconf.vc.h
@@ -0,0 +1,152 @@
+/*
+ Configuration defines for installed libtiff.
+ This file maintained for backward compatibility. Do not use definitions
+ from this file in your programs.
+*/
+
+#ifndef _TIFFCONF_
+#define _TIFFCONF_
+
+/* The size of a `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* Signed 8-bit type */
+#define TIFF_INT8_T signed char
+
+/* Unsigned 8-bit type */
+#define TIFF_UINT8_T unsigned char
+
+/* Signed 16-bit type */
+#define TIFF_INT16_T signed short
+
+/* Unsigned 16-bit type */
+#define TIFF_UINT16_T unsigned short
+
+/* Signed 32-bit type formatter */
+#define TIFF_INT32_FORMAT "%d"
+
+/* Signed 32-bit type */
+#define TIFF_INT32_T signed int
+
+/* Unsigned 32-bit type formatter */
+#define TIFF_UINT32_FORMAT "%u"
+
+/* Unsigned 32-bit type */
+#define TIFF_UINT32_T unsigned int
+
+/* Signed 64-bit type formatter */
+#define TIFF_INT64_FORMAT "%I64d"
+
+/* Signed 64-bit type */
+#define TIFF_INT64_T signed __int64
+
+/* Unsigned 64-bit type formatter */
+#define TIFF_UINT64_FORMAT "%I64u"
+
+/* Unsigned 64-bit type */
+#define TIFF_UINT64_T unsigned __int64
+
+#if _WIN64
+/*
+ Windows 64-bit build
+*/
+
+/* Signed size type */
+# define TIFF_SSIZE_T TIFF_INT64_T
+
+#else
+/*
+ Windows 32-bit build
+*/
+
+/* Signed size type */
+# define TIFF_SSIZE_T signed int
+
+#endif
+
+/* Compatibility stuff. */
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Set the native cpu bit order (FILLORDER_LSB2MSB or FILLORDER_MSB2LSB) */
+#define HOST_FILLORDER FILLORDER_LSB2MSB
+
+/* Native cpu byte order: 1 if big-endian (Motorola) or 0 if little-endian
+ (Intel) */
+#define HOST_BIGENDIAN 0
+
+/* Support CCITT Group 3 & 4 algorithms */
+#define CCITT_SUPPORT 1
+
+/* Support JPEG compression (requires IJG JPEG library) */
+/* #undef JPEG_SUPPORT */
+
+/* Support JBIG compression (requires JBIG-KIT library) */
+/* #undef JBIG_SUPPORT */
+
+/* Support LogLuv high dynamic range encoding */
+#define LOGLUV_SUPPORT 1
+
+/* Support LZW algorithm */
+#define LZW_SUPPORT 1
+
+/* Support NeXT 2-bit RLE algorithm */
+#define NEXT_SUPPORT 1
+
+/* Support Old JPEG compresson (read contrib/ojpeg/README first! Compilation
+ fails with unpatched IJG JPEG library) */
+/* #undef OJPEG_SUPPORT */
+
+/* Support Macintosh PackBits algorithm */
+#define PACKBITS_SUPPORT 1
+
+/* Support Pixar log-format algorithm (requires Zlib) */
+/* #undef PIXARLOG_SUPPORT */
+
+/* Support ThunderScan 4-bit RLE algorithm */
+#define THUNDER_SUPPORT 1
+
+/* Support Deflate compression */
+/* #undef ZIP_SUPPORT */
+
+/* Support strip chopping (whether or not to convert single-strip uncompressed
+ images to mutiple strips of ~8Kb to reduce memory usage) */
+#define STRIPCHOP_DEFAULT TIFF_STRIPCHOP
+
+/* Enable SubIFD tag (330) support */
+#define SUBIFD_SUPPORT 1
+
+/* Treat extra sample as alpha (default enabled). The RGBA interface will
+ treat a fourth sample with no EXTRASAMPLE_ value as being ASSOCALPHA. Many
+ packages produce RGBA files but don't mark the alpha properly. */
+#define DEFAULT_EXTRASAMPLE_AS_ALPHA 1
+
+/* Pick up YCbCr subsampling info from the JPEG data stream to support files
+ lacking the tag (default enabled). */
+#define CHECK_JPEG_YCBCR_SUBSAMPLING 1
+
+/* Support MS MDI magic number files as TIFF */
+/* #undef MDI_SUPPORT */
+
+/*
+ * Feature support definitions.
+ * XXX: These macros are obsoleted. Don't use them in your apps!
+ * Macros stays here for backward compatibility and should be always defined.
+ */
+#define COLORIMETRY_SUPPORT
+#define YCBCR_SUPPORT
+#define CMYK_SUPPORT
+#define ICC_SUPPORT
+#define PHOTOSHOP_SUPPORT
+#define IPTC_SUPPORT
+
+#endif /* _TIFFCONF_ */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tiffconf.wince.h b/test/monniaux/tiff-4.0.10/tiffconf.wince.h
new file mode 100644
index 00000000..013b0960
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffconf.wince.h
@@ -0,0 +1,110 @@
+/*
+ * Windows CE platform tiffconf.wince.h
+ * Created by Mateusz Loskot (mateusz@loskot.net)
+ *
+ * NOTE: Requires WCELIBCEX library with wceex_* functions,
+ * It's an extension to C library on Windows CE platform.
+ * For example, HAVE_STDIO_H definition indicates there are
+ * following files available:
+ * stdio.h - from Windows CE / Windows Mobile SDK
+ * wce_stdio.h - from WCELIBCEX library
+ */
+
+
+/*
+ Configuration defines for installed libtiff.
+ This file maintained for backward compatibility. Do not use definitions
+ from this file in your programs.
+*/
+
+#ifndef _WIN32_WCE
+# error This version of tif_config.h header is dedicated for Windows CE platform!
+#endif
+
+
+#ifndef _TIFFCONF_
+#define _TIFFCONF_
+
+/* The size of a `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* Compatibility stuff. */
+
+/* Define as 0 or 1 according to the floating point format suported by the
+ machine */
+#define HAVE_IEEEFP 1
+
+/* Set the native cpu bit order (FILLORDER_LSB2MSB or FILLORDER_MSB2LSB) */
+#define HOST_FILLORDER FILLORDER_LSB2MSB
+
+/* Native cpu byte order: 1 if big-endian (Motorola) or 0 if little-endian
+ (Intel) */
+#define HOST_BIGENDIAN 0
+
+/* Support CCITT Group 3 & 4 algorithms */
+#define CCITT_SUPPORT 1
+
+/* Support JPEG compression (requires IJG JPEG library) */
+/* #undef JPEG_SUPPORT */
+
+/* Support LogLuv high dynamic range encoding */
+#define LOGLUV_SUPPORT 1
+
+/* Support LZW algorithm */
+#define LZW_SUPPORT 1
+
+/* Support NeXT 2-bit RLE algorithm */
+#define NEXT_SUPPORT 1
+
+/* Support Old JPEG compresson (read contrib/ojpeg/README first! Compilation
+ fails with unpatched IJG JPEG library) */
+/* #undef OJPEG_SUPPORT */
+
+/* Support Macintosh PackBits algorithm */
+#define PACKBITS_SUPPORT 1
+
+/* Support Pixar log-format algorithm (requires Zlib) */
+/* #undef PIXARLOG_SUPPORT */
+
+/* Support ThunderScan 4-bit RLE algorithm */
+#define THUNDER_SUPPORT 1
+
+/* Support Deflate compression */
+/* #undef ZIP_SUPPORT */
+
+/* Support strip chopping (whether or not to convert single-strip uncompressed
+ images to mutiple strips of ~8Kb to reduce memory usage) */
+#define STRIPCHOP_DEFAULT TIFF_STRIPCHOP
+
+/* Enable SubIFD tag (330) support */
+#define SUBIFD_SUPPORT 1
+
+/* Treat extra sample as alpha (default enabled). The RGBA interface will
+ treat a fourth sample with no EXTRASAMPLE_ value as being ASSOCALPHA. Many
+ packages produce RGBA files but don't mark the alpha properly. */
+#define DEFAULT_EXTRASAMPLE_AS_ALPHA 1
+
+/* Pick up YCbCr subsampling info from the JPEG data stream to support files
+ lacking the tag (default enabled). */
+#define CHECK_JPEG_YCBCR_SUBSAMPLING 1
+
+/*
+ * Feature support definitions.
+ * XXX: These macros are obsoleted. Don't use them in your apps!
+ * Macros stays here for backward compatibility and should be always defined.
+ */
+#define COLORIMETRY_SUPPORT
+#define YCBCR_SUPPORT
+#define CMYK_SUPPORT
+#define ICC_SUPPORT
+#define PHOTOSHOP_SUPPORT
+#define IPTC_SUPPORT
+
+#endif /* _TIFFCONF_ */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tiffio.h b/test/monniaux/tiff-4.0.10/tiffio.h
new file mode 100644
index 00000000..31c2e676
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffio.h
@@ -0,0 +1,558 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _TIFFIO_
+#define _TIFFIO_
+
+/*
+ * TIFF I/O Library Definitions.
+ */
+#include "tiff.h"
+#include "tiffvers.h"
+
+/*
+ * TIFF is defined as an incomplete type to hide the
+ * library's internal data structures from clients.
+ */
+typedef struct tiff TIFF;
+
+/*
+ * The following typedefs define the intrinsic size of
+ * data types used in the *exported* interfaces. These
+ * definitions depend on the proper definition of types
+ * in tiff.h. Note also that the varargs interface used
+ * to pass tag types and values uses the types defined in
+ * tiff.h directly.
+ *
+ * NB: ttag_t is unsigned int and not unsigned short because
+ * ANSI C requires that the type before the ellipsis be a
+ * promoted type (i.e. one of int, unsigned int, pointer,
+ * or double) and because we defined pseudo-tags that are
+ * outside the range of legal Aldus-assigned tags.
+ * NB: tsize_t is signed and not unsigned because some functions
+ * return -1.
+ * NB: toff_t is not off_t for many reasons; TIFFs max out at
+ * 32-bit file offsets, and BigTIFF maxes out at 64-bit
+ * offsets being the most important, and to ensure use of
+ * a consistently unsigned type across architectures.
+ * Prior to libtiff 4.0, this was an unsigned 32 bit type.
+ */
+/*
+ * this is the machine addressing size type, only it's signed, so make it
+ * int32 on 32bit machines, int64 on 64bit machines
+ */
+typedef TIFF_SSIZE_T tmsize_t;
+typedef uint64 toff_t; /* file offset */
+/* the following are deprecated and should be replaced by their defining
+ counterparts */
+typedef uint32 ttag_t; /* directory tag */
+typedef uint16 tdir_t; /* directory index */
+typedef uint16 tsample_t; /* sample number */
+typedef uint32 tstrile_t; /* strip or tile number */
+typedef tstrile_t tstrip_t; /* strip number */
+typedef tstrile_t ttile_t; /* tile number */
+typedef tmsize_t tsize_t; /* i/o size in bytes */
+typedef void* tdata_t; /* image data ref */
+
+#if !defined(__WIN32__) && (defined(_WIN32) || defined(WIN32))
+#define __WIN32__
+#endif
+
+/*
+ * On windows you should define USE_WIN32_FILEIO if you are using tif_win32.c
+ * or AVOID_WIN32_FILEIO if you are using something else (like tif_unix.c).
+ *
+ * By default tif_unix.c is assumed.
+ */
+
+#if defined(_WINDOWS) || defined(__WIN32__) || defined(_Windows)
+# if !defined(__CYGWIN) && !defined(AVOID_WIN32_FILEIO) && !defined(USE_WIN32_FILEIO)
+# define AVOID_WIN32_FILEIO
+# endif
+#endif
+
+#if defined(USE_WIN32_FILEIO)
+# define VC_EXTRALEAN
+# include <windows.h>
+# ifdef __WIN32__
+DECLARE_HANDLE(thandle_t); /* Win32 file handle */
+# else
+typedef HFILE thandle_t; /* client data handle */
+# endif /* __WIN32__ */
+#else
+typedef void* thandle_t; /* client data handle */
+#endif /* USE_WIN32_FILEIO */
+
+/*
+ * Flags to pass to TIFFPrintDirectory to control
+ * printing of data structures that are potentially
+ * very large. Bit-or these flags to enable printing
+ * multiple items.
+ */
+#define TIFFPRINT_NONE 0x0 /* no extra info */
+#define TIFFPRINT_STRIPS 0x1 /* strips/tiles info */
+#define TIFFPRINT_CURVES 0x2 /* color/gray response curves */
+#define TIFFPRINT_COLORMAP 0x4 /* colormap */
+#define TIFFPRINT_JPEGQTABLES 0x100 /* JPEG Q matrices */
+#define TIFFPRINT_JPEGACTABLES 0x200 /* JPEG AC tables */
+#define TIFFPRINT_JPEGDCTABLES 0x200 /* JPEG DC tables */
+
+/*
+ * Colour conversion stuff
+ */
+
+/* reference white */
+#define D65_X0 (95.0470F)
+#define D65_Y0 (100.0F)
+#define D65_Z0 (108.8827F)
+
+#define D50_X0 (96.4250F)
+#define D50_Y0 (100.0F)
+#define D50_Z0 (82.4680F)
+
+/* Structure for holding information about a display device. */
+
+typedef unsigned char TIFFRGBValue; /* 8-bit samples */
+
+typedef struct {
+ float d_mat[3][3]; /* XYZ -> luminance matrix */
+ float d_YCR; /* Light o/p for reference white */
+ float d_YCG;
+ float d_YCB;
+ uint32 d_Vrwr; /* Pixel values for ref. white */
+ uint32 d_Vrwg;
+ uint32 d_Vrwb;
+ float d_Y0R; /* Residual light for black pixel */
+ float d_Y0G;
+ float d_Y0B;
+ float d_gammaR; /* Gamma values for the three guns */
+ float d_gammaG;
+ float d_gammaB;
+} TIFFDisplay;
+
+typedef struct { /* YCbCr->RGB support */
+ TIFFRGBValue* clamptab; /* range clamping table */
+ int* Cr_r_tab;
+ int* Cb_b_tab;
+ int32* Cr_g_tab;
+ int32* Cb_g_tab;
+ int32* Y_tab;
+} TIFFYCbCrToRGB;
+
+typedef struct { /* CIE Lab 1976->RGB support */
+ int range; /* Size of conversion table */
+#define CIELABTORGB_TABLE_RANGE 1500
+ float rstep, gstep, bstep;
+ float X0, Y0, Z0; /* Reference white point */
+ TIFFDisplay display;
+ float Yr2r[CIELABTORGB_TABLE_RANGE + 1]; /* Conversion of Yr to r */
+ float Yg2g[CIELABTORGB_TABLE_RANGE + 1]; /* Conversion of Yg to g */
+ float Yb2b[CIELABTORGB_TABLE_RANGE + 1]; /* Conversion of Yb to b */
+} TIFFCIELabToRGB;
+
+/*
+ * RGBA-style image support.
+ */
+typedef struct _TIFFRGBAImage TIFFRGBAImage;
+/*
+ * The image reading and conversion routines invoke
+ * ``put routines'' to copy/image/whatever tiles of
+ * raw image data. A default set of routines are
+ * provided to convert/copy raw image data to 8-bit
+ * packed ABGR format rasters. Applications can supply
+ * alternate routines that unpack the data into a
+ * different format or, for example, unpack the data
+ * and draw the unpacked raster on the display.
+ */
+typedef void (*tileContigRoutine)
+ (TIFFRGBAImage*, uint32*, uint32, uint32, uint32, uint32, int32, int32,
+ unsigned char*);
+typedef void (*tileSeparateRoutine)
+ (TIFFRGBAImage*, uint32*, uint32, uint32, uint32, uint32, int32, int32,
+ unsigned char*, unsigned char*, unsigned char*, unsigned char*);
+/*
+ * RGBA-reader state.
+ */
+struct _TIFFRGBAImage {
+ TIFF* tif; /* image handle */
+ int stoponerr; /* stop on read error */
+ int isContig; /* data is packed/separate */
+ int alpha; /* type of alpha data present */
+ uint32 width; /* image width */
+ uint32 height; /* image height */
+ uint16 bitspersample; /* image bits/sample */
+ uint16 samplesperpixel; /* image samples/pixel */
+ uint16 orientation; /* image orientation */
+ uint16 req_orientation; /* requested orientation */
+ uint16 photometric; /* image photometric interp */
+ uint16* redcmap; /* colormap palette */
+ uint16* greencmap;
+ uint16* bluecmap;
+ /* get image data routine */
+ int (*get)(TIFFRGBAImage*, uint32*, uint32, uint32);
+ /* put decoded strip/tile */
+ union {
+ void (*any)(TIFFRGBAImage*);
+ tileContigRoutine contig;
+ tileSeparateRoutine separate;
+ } put;
+ TIFFRGBValue* Map; /* sample mapping array */
+ uint32** BWmap; /* black&white map */
+ uint32** PALmap; /* palette image map */
+ TIFFYCbCrToRGB* ycbcr; /* YCbCr conversion state */
+ TIFFCIELabToRGB* cielab; /* CIE L*a*b conversion state */
+
+ uint8* UaToAa; /* Unassociated alpha to associated alpha conversion LUT */
+ uint8* Bitdepth16To8; /* LUT for conversion from 16bit to 8bit values */
+
+ int row_offset;
+ int col_offset;
+};
+
+/*
+ * Macros for extracting components from the
+ * packed ABGR form returned by TIFFReadRGBAImage.
+ */
+#define TIFFGetR(abgr) ((abgr) & 0xff)
+#define TIFFGetG(abgr) (((abgr) >> 8) & 0xff)
+#define TIFFGetB(abgr) (((abgr) >> 16) & 0xff)
+#define TIFFGetA(abgr) (((abgr) >> 24) & 0xff)
+
+/*
+ * A CODEC is a software package that implements decoding,
+ * encoding, or decoding+encoding of a compression algorithm.
+ * The library provides a collection of builtin codecs.
+ * More codecs may be registered through calls to the library
+ * and/or the builtin implementations may be overridden.
+ */
+typedef int (*TIFFInitMethod)(TIFF*, int);
+typedef struct {
+ char* name;
+ uint16 scheme;
+ TIFFInitMethod init;
+} TIFFCodec;
+
+#include <stdio.h>
+#include <stdarg.h>
+
+/* share internal LogLuv conversion routines? */
+#ifndef LOGLUV_PUBLIC
+#define LOGLUV_PUBLIC 1
+#endif
+
+#if !defined(__GNUC__) && !defined(__attribute__)
+# define __attribute__(x) /*nothing*/
+#endif
+
+#if defined(c_plusplus) || defined(__cplusplus)
+extern "C" {
+#endif
+typedef void (*TIFFErrorHandler)(const char*, const char*, va_list);
+typedef void (*TIFFErrorHandlerExt)(thandle_t, const char*, const char*, va_list);
+typedef tmsize_t (*TIFFReadWriteProc)(thandle_t, void*, tmsize_t);
+typedef toff_t (*TIFFSeekProc)(thandle_t, toff_t, int);
+typedef int (*TIFFCloseProc)(thandle_t);
+typedef toff_t (*TIFFSizeProc)(thandle_t);
+typedef int (*TIFFMapFileProc)(thandle_t, void** base, toff_t* size);
+typedef void (*TIFFUnmapFileProc)(thandle_t, void* base, toff_t size);
+typedef void (*TIFFExtendProc)(TIFF*);
+
+extern const char* TIFFGetVersion(void);
+
+extern const TIFFCodec* TIFFFindCODEC(uint16);
+extern TIFFCodec* TIFFRegisterCODEC(uint16, const char*, TIFFInitMethod);
+extern void TIFFUnRegisterCODEC(TIFFCodec*);
+extern int TIFFIsCODECConfigured(uint16);
+extern TIFFCodec* TIFFGetConfiguredCODECs(void);
+
+/*
+ * Auxiliary functions.
+ */
+
+extern void* _TIFFmalloc(tmsize_t s);
+extern void* _TIFFcalloc(tmsize_t nmemb, tmsize_t siz);
+extern void* _TIFFrealloc(void* p, tmsize_t s);
+extern void _TIFFmemset(void* p, int v, tmsize_t c);
+extern void _TIFFmemcpy(void* d, const void* s, tmsize_t c);
+extern int _TIFFmemcmp(const void* p1, const void* p2, tmsize_t c);
+extern void _TIFFfree(void* p);
+
+/*
+** Stuff, related to tag handling and creating custom tags.
+*/
+extern int TIFFGetTagListCount( TIFF * );
+extern uint32 TIFFGetTagListEntry( TIFF *, int tag_index );
+
+#define TIFF_ANY TIFF_NOTYPE /* for field descriptor searching */
+#define TIFF_VARIABLE -1 /* marker for variable length tags */
+#define TIFF_SPP -2 /* marker for SamplesPerPixel tags */
+#define TIFF_VARIABLE2 -3 /* marker for uint32 var-length tags */
+
+#define FIELD_CUSTOM 65
+
+typedef struct _TIFFField TIFFField;
+typedef struct _TIFFFieldArray TIFFFieldArray;
+
+extern const TIFFField* TIFFFindField(TIFF *, uint32, TIFFDataType);
+extern const TIFFField* TIFFFieldWithTag(TIFF*, uint32);
+extern const TIFFField* TIFFFieldWithName(TIFF*, const char *);
+
+extern uint32 TIFFFieldTag(const TIFFField*);
+extern const char* TIFFFieldName(const TIFFField*);
+extern TIFFDataType TIFFFieldDataType(const TIFFField*);
+extern int TIFFFieldPassCount(const TIFFField*);
+extern int TIFFFieldReadCount(const TIFFField*);
+extern int TIFFFieldWriteCount(const TIFFField*);
+
+typedef int (*TIFFVSetMethod)(TIFF*, uint32, va_list);
+typedef int (*TIFFVGetMethod)(TIFF*, uint32, va_list);
+typedef void (*TIFFPrintMethod)(TIFF*, FILE*, long);
+
+typedef struct {
+ TIFFVSetMethod vsetfield; /* tag set routine */
+ TIFFVGetMethod vgetfield; /* tag get routine */
+ TIFFPrintMethod printdir; /* directory print routine */
+} TIFFTagMethods;
+
+extern TIFFTagMethods *TIFFAccessTagMethods(TIFF *);
+extern void *TIFFGetClientInfo(TIFF *, const char *);
+extern void TIFFSetClientInfo(TIFF *, void *, const char *);
+
+extern void TIFFCleanup(TIFF* tif);
+extern void TIFFClose(TIFF* tif);
+extern int TIFFFlush(TIFF* tif);
+extern int TIFFFlushData(TIFF* tif);
+extern int TIFFGetField(TIFF* tif, uint32 tag, ...);
+extern int TIFFVGetField(TIFF* tif, uint32 tag, va_list ap);
+extern int TIFFGetFieldDefaulted(TIFF* tif, uint32 tag, ...);
+extern int TIFFVGetFieldDefaulted(TIFF* tif, uint32 tag, va_list ap);
+extern int TIFFReadDirectory(TIFF* tif);
+extern int TIFFReadCustomDirectory(TIFF* tif, toff_t diroff, const TIFFFieldArray* infoarray);
+extern int TIFFReadEXIFDirectory(TIFF* tif, toff_t diroff);
+extern uint64 TIFFScanlineSize64(TIFF* tif);
+extern tmsize_t TIFFScanlineSize(TIFF* tif);
+extern uint64 TIFFRasterScanlineSize64(TIFF* tif);
+extern tmsize_t TIFFRasterScanlineSize(TIFF* tif);
+extern uint64 TIFFStripSize64(TIFF* tif);
+extern tmsize_t TIFFStripSize(TIFF* tif);
+extern uint64 TIFFRawStripSize64(TIFF* tif, uint32 strip);
+extern tmsize_t TIFFRawStripSize(TIFF* tif, uint32 strip);
+extern uint64 TIFFVStripSize64(TIFF* tif, uint32 nrows);
+extern tmsize_t TIFFVStripSize(TIFF* tif, uint32 nrows);
+extern uint64 TIFFTileRowSize64(TIFF* tif);
+extern tmsize_t TIFFTileRowSize(TIFF* tif);
+extern uint64 TIFFTileSize64(TIFF* tif);
+extern tmsize_t TIFFTileSize(TIFF* tif);
+extern uint64 TIFFVTileSize64(TIFF* tif, uint32 nrows);
+extern tmsize_t TIFFVTileSize(TIFF* tif, uint32 nrows);
+extern uint32 TIFFDefaultStripSize(TIFF* tif, uint32 request);
+extern void TIFFDefaultTileSize(TIFF*, uint32*, uint32*);
+extern int TIFFFileno(TIFF*);
+extern int TIFFSetFileno(TIFF*, int);
+extern thandle_t TIFFClientdata(TIFF*);
+extern thandle_t TIFFSetClientdata(TIFF*, thandle_t);
+extern int TIFFGetMode(TIFF*);
+extern int TIFFSetMode(TIFF*, int);
+extern int TIFFIsTiled(TIFF*);
+extern int TIFFIsByteSwapped(TIFF*);
+extern int TIFFIsUpSampled(TIFF*);
+extern int TIFFIsMSB2LSB(TIFF*);
+extern int TIFFIsBigEndian(TIFF*);
+extern TIFFReadWriteProc TIFFGetReadProc(TIFF*);
+extern TIFFReadWriteProc TIFFGetWriteProc(TIFF*);
+extern TIFFSeekProc TIFFGetSeekProc(TIFF*);
+extern TIFFCloseProc TIFFGetCloseProc(TIFF*);
+extern TIFFSizeProc TIFFGetSizeProc(TIFF*);
+extern TIFFMapFileProc TIFFGetMapFileProc(TIFF*);
+extern TIFFUnmapFileProc TIFFGetUnmapFileProc(TIFF*);
+extern uint32 TIFFCurrentRow(TIFF*);
+extern uint16 TIFFCurrentDirectory(TIFF*);
+extern uint16 TIFFNumberOfDirectories(TIFF*);
+extern uint64 TIFFCurrentDirOffset(TIFF*);
+extern uint32 TIFFCurrentStrip(TIFF*);
+extern uint32 TIFFCurrentTile(TIFF* tif);
+extern int TIFFReadBufferSetup(TIFF* tif, void* bp, tmsize_t size);
+extern int TIFFWriteBufferSetup(TIFF* tif, void* bp, tmsize_t size);
+extern int TIFFSetupStrips(TIFF *);
+extern int TIFFWriteCheck(TIFF*, int, const char *);
+extern void TIFFFreeDirectory(TIFF*);
+extern int TIFFCreateDirectory(TIFF*);
+extern int TIFFCreateCustomDirectory(TIFF*,const TIFFFieldArray*);
+extern int TIFFCreateEXIFDirectory(TIFF*);
+extern int TIFFLastDirectory(TIFF*);
+extern int TIFFSetDirectory(TIFF*, uint16);
+extern int TIFFSetSubDirectory(TIFF*, uint64);
+extern int TIFFUnlinkDirectory(TIFF*, uint16);
+extern int TIFFSetField(TIFF*, uint32, ...);
+extern int TIFFVSetField(TIFF*, uint32, va_list);
+extern int TIFFUnsetField(TIFF*, uint32);
+extern int TIFFWriteDirectory(TIFF *);
+extern int TIFFWriteCustomDirectory(TIFF *, uint64 *);
+extern int TIFFCheckpointDirectory(TIFF *);
+extern int TIFFRewriteDirectory(TIFF *);
+
+#if defined(c_plusplus) || defined(__cplusplus)
+extern void TIFFPrintDirectory(TIFF*, FILE*, long = 0);
+extern int TIFFReadScanline(TIFF* tif, void* buf, uint32 row, uint16 sample = 0);
+extern int TIFFWriteScanline(TIFF* tif, void* buf, uint32 row, uint16 sample = 0);
+extern int TIFFReadRGBAImage(TIFF*, uint32, uint32, uint32*, int = 0);
+extern int TIFFReadRGBAImageOriented(TIFF*, uint32, uint32, uint32*,
+ int = ORIENTATION_BOTLEFT, int = 0);
+#else
+extern void TIFFPrintDirectory(TIFF*, FILE*, long);
+extern int TIFFReadScanline(TIFF* tif, void* buf, uint32 row, uint16 sample);
+extern int TIFFWriteScanline(TIFF* tif, void* buf, uint32 row, uint16 sample);
+extern int TIFFReadRGBAImage(TIFF*, uint32, uint32, uint32*, int);
+extern int TIFFReadRGBAImageOriented(TIFF*, uint32, uint32, uint32*, int, int);
+#endif
+
+extern int TIFFReadRGBAStrip(TIFF*, uint32, uint32 * );
+extern int TIFFReadRGBATile(TIFF*, uint32, uint32, uint32 * );
+extern int TIFFReadRGBAStripExt(TIFF*, uint32, uint32 *, int stop_on_error );
+extern int TIFFReadRGBATileExt(TIFF*, uint32, uint32, uint32 *, int stop_on_error );
+extern int TIFFRGBAImageOK(TIFF*, char [1024]);
+extern int TIFFRGBAImageBegin(TIFFRGBAImage*, TIFF*, int, char [1024]);
+extern int TIFFRGBAImageGet(TIFFRGBAImage*, uint32*, uint32, uint32);
+extern void TIFFRGBAImageEnd(TIFFRGBAImage*);
+extern TIFF* TIFFOpen(const char*, const char*);
+# ifdef __WIN32__
+extern TIFF* TIFFOpenW(const wchar_t*, const char*);
+# endif /* __WIN32__ */
+extern TIFF* TIFFFdOpen(int, const char*, const char*);
+extern TIFF* TIFFClientOpen(const char*, const char*,
+ thandle_t,
+ TIFFReadWriteProc, TIFFReadWriteProc,
+ TIFFSeekProc, TIFFCloseProc,
+ TIFFSizeProc,
+ TIFFMapFileProc, TIFFUnmapFileProc);
+extern const char* TIFFFileName(TIFF*);
+extern const char* TIFFSetFileName(TIFF*, const char *);
+extern void TIFFError(const char*, const char*, ...) __attribute__((__format__ (__printf__,2,3)));
+extern void TIFFErrorExt(thandle_t, const char*, const char*, ...) __attribute__((__format__ (__printf__,3,4)));
+extern void TIFFWarning(const char*, const char*, ...) __attribute__((__format__ (__printf__,2,3)));
+extern void TIFFWarningExt(thandle_t, const char*, const char*, ...) __attribute__((__format__ (__printf__,3,4)));
+extern TIFFErrorHandler TIFFSetErrorHandler(TIFFErrorHandler);
+extern TIFFErrorHandlerExt TIFFSetErrorHandlerExt(TIFFErrorHandlerExt);
+extern TIFFErrorHandler TIFFSetWarningHandler(TIFFErrorHandler);
+extern TIFFErrorHandlerExt TIFFSetWarningHandlerExt(TIFFErrorHandlerExt);
+extern TIFFExtendProc TIFFSetTagExtender(TIFFExtendProc);
+extern uint32 TIFFComputeTile(TIFF* tif, uint32 x, uint32 y, uint32 z, uint16 s);
+extern int TIFFCheckTile(TIFF* tif, uint32 x, uint32 y, uint32 z, uint16 s);
+extern uint32 TIFFNumberOfTiles(TIFF*);
+extern tmsize_t TIFFReadTile(TIFF* tif, void* buf, uint32 x, uint32 y, uint32 z, uint16 s);
+extern tmsize_t TIFFWriteTile(TIFF* tif, void* buf, uint32 x, uint32 y, uint32 z, uint16 s);
+extern uint32 TIFFComputeStrip(TIFF*, uint32, uint16);
+extern uint32 TIFFNumberOfStrips(TIFF*);
+extern tmsize_t TIFFReadEncodedStrip(TIFF* tif, uint32 strip, void* buf, tmsize_t size);
+extern tmsize_t TIFFReadRawStrip(TIFF* tif, uint32 strip, void* buf, tmsize_t size);
+extern tmsize_t TIFFReadEncodedTile(TIFF* tif, uint32 tile, void* buf, tmsize_t size);
+extern tmsize_t TIFFReadRawTile(TIFF* tif, uint32 tile, void* buf, tmsize_t size);
+extern tmsize_t TIFFWriteEncodedStrip(TIFF* tif, uint32 strip, void* data, tmsize_t cc);
+extern tmsize_t TIFFWriteRawStrip(TIFF* tif, uint32 strip, void* data, tmsize_t cc);
+extern tmsize_t TIFFWriteEncodedTile(TIFF* tif, uint32 tile, void* data, tmsize_t cc);
+extern tmsize_t TIFFWriteRawTile(TIFF* tif, uint32 tile, void* data, tmsize_t cc);
+extern int TIFFDataWidth(TIFFDataType); /* table of tag datatype widths */
+extern void TIFFSetWriteOffset(TIFF* tif, toff_t off);
+extern void TIFFSwabShort(uint16*);
+extern void TIFFSwabLong(uint32*);
+extern void TIFFSwabLong8(uint64*);
+extern void TIFFSwabFloat(float*);
+extern void TIFFSwabDouble(double*);
+extern void TIFFSwabArrayOfShort(uint16* wp, tmsize_t n);
+extern void TIFFSwabArrayOfTriples(uint8* tp, tmsize_t n);
+extern void TIFFSwabArrayOfLong(uint32* lp, tmsize_t n);
+extern void TIFFSwabArrayOfLong8(uint64* lp, tmsize_t n);
+extern void TIFFSwabArrayOfFloat(float* fp, tmsize_t n);
+extern void TIFFSwabArrayOfDouble(double* dp, tmsize_t n);
+extern void TIFFReverseBits(uint8* cp, tmsize_t n);
+extern const unsigned char* TIFFGetBitRevTable(int);
+
+#ifdef LOGLUV_PUBLIC
+#define U_NEU 0.210526316
+#define V_NEU 0.473684211
+#define UVSCALE 410.
+extern double LogL16toY(int);
+extern double LogL10toY(int);
+extern void XYZtoRGB24(float*, uint8*);
+extern int uv_decode(double*, double*, int);
+extern void LogLuv24toXYZ(uint32, float*);
+extern void LogLuv32toXYZ(uint32, float*);
+#if defined(c_plusplus) || defined(__cplusplus)
+extern int LogL16fromY(double, int = SGILOGENCODE_NODITHER);
+extern int LogL10fromY(double, int = SGILOGENCODE_NODITHER);
+extern int uv_encode(double, double, int = SGILOGENCODE_NODITHER);
+extern uint32 LogLuv24fromXYZ(float*, int = SGILOGENCODE_NODITHER);
+extern uint32 LogLuv32fromXYZ(float*, int = SGILOGENCODE_NODITHER);
+#else
+extern int LogL16fromY(double, int);
+extern int LogL10fromY(double, int);
+extern int uv_encode(double, double, int);
+extern uint32 LogLuv24fromXYZ(float*, int);
+extern uint32 LogLuv32fromXYZ(float*, int);
+#endif
+#endif /* LOGLUV_PUBLIC */
+
+extern int TIFFCIELabToRGBInit(TIFFCIELabToRGB*, const TIFFDisplay *, float*);
+extern void TIFFCIELabToXYZ(TIFFCIELabToRGB *, uint32, int32, int32,
+ float *, float *, float *);
+extern void TIFFXYZToRGB(TIFFCIELabToRGB *, float, float, float,
+ uint32 *, uint32 *, uint32 *);
+
+extern int TIFFYCbCrToRGBInit(TIFFYCbCrToRGB*, float*, float*);
+extern void TIFFYCbCrtoRGB(TIFFYCbCrToRGB *, uint32, int32, int32,
+ uint32 *, uint32 *, uint32 *);
+
+/****************************************************************************
+ * O B S O L E T E D I N T E R F A C E S
+ *
+ * Don't use this stuff in your applications, it may be removed in the future
+ * libtiff versions.
+ ****************************************************************************/
+typedef struct {
+ ttag_t field_tag; /* field's tag */
+ short field_readcount; /* read count/TIFF_VARIABLE/TIFF_SPP */
+ short field_writecount; /* write count/TIFF_VARIABLE */
+ TIFFDataType field_type; /* type of associated data */
+ unsigned short field_bit; /* bit in fieldsset bit vector */
+ unsigned char field_oktochange; /* if true, can change while writing */
+ unsigned char field_passcount; /* if true, pass dir count on set */
+ char *field_name; /* ASCII name */
+} TIFFFieldInfo;
+
+extern int TIFFMergeFieldInfo(TIFF*, const TIFFFieldInfo[], uint32);
+
+#if defined(c_plusplus) || defined(__cplusplus)
+}
+#endif
+
+#endif /* _TIFFIO_ */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tiffiop.h b/test/monniaux/tiff-4.0.10/tiffiop.h
new file mode 100644
index 00000000..186c291f
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffiop.h
@@ -0,0 +1,454 @@
+/*
+ * Copyright (c) 1988-1997 Sam Leffler
+ * Copyright (c) 1991-1997 Silicon Graphics, Inc.
+ *
+ * Permission to use, copy, modify, distribute, and sell this software and
+ * its documentation for any purpose is hereby granted without fee, provided
+ * that (i) the above copyright notices and this permission notice appear in
+ * all copies of the software and related documentation, and (ii) the names of
+ * Sam Leffler and Silicon Graphics may not be used in any advertising or
+ * publicity relating to the software without the specific, prior written
+ * permission of Sam Leffler and Silicon Graphics.
+ *
+ * THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
+ * WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * IN NO EVENT SHALL SAM LEFFLER OR SILICON GRAPHICS BE LIABLE FOR
+ * ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND,
+ * OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+ * WHETHER OR NOT ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF
+ * LIABILITY, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+ * OF THIS SOFTWARE.
+ */
+
+#ifndef _TIFFIOP_
+#define _TIFFIOP_
+/*
+ * ``Library-private'' definitions.
+ */
+
+#include "tif_config.h"
+
+#ifdef HAVE_FCNTL_H
+# include <fcntl.h>
+#endif
+
+#ifdef HAVE_SYS_TYPES_H
+# include <sys/types.h>
+#endif
+
+#ifdef HAVE_STRING_H
+# include <string.h>
+#endif
+
+#ifdef HAVE_ASSERT_H
+# include <assert.h>
+#else
+# define assert(x)
+#endif
+
+#ifdef HAVE_SEARCH_H
+# include <search.h>
+#else
+extern void *lfind(const void *, const void *, size_t *, size_t,
+ int (*)(const void *, const void *));
+#endif
+
+#if !defined(HAVE_SNPRINTF) && !defined(HAVE__SNPRINTF)
+#undef snprintf
+#define snprintf _TIFF_snprintf_f
+extern int snprintf(char* str, size_t size, const char* format, ...);
+#endif
+
+#include "tiffio.h"
+
+#include "tif_dir.h"
+
+#ifndef STRIP_SIZE_DEFAULT
+# define STRIP_SIZE_DEFAULT 8192
+#endif
+
+#define streq(a,b) (strcmp(a,b) == 0)
+#define strneq(a,b,n) (strncmp(a,b,n) == 0)
+
+#ifndef TRUE
+#define TRUE 1
+#define FALSE 0
+#endif
+
+typedef struct client_info {
+ struct client_info *next;
+ void *data;
+ char *name;
+} TIFFClientInfoLink;
+
+/*
+ * Typedefs for ``method pointers'' used internally.
+ * these are deprecated and provided only for backwards compatibility.
+ */
+typedef unsigned char tidataval_t; /* internal image data value type */
+typedef tidataval_t* tidata_t; /* reference to internal image data */
+
+typedef void (*TIFFVoidMethod)(TIFF*);
+typedef int (*TIFFBoolMethod)(TIFF*);
+typedef int (*TIFFPreMethod)(TIFF*, uint16);
+typedef int (*TIFFCodeMethod)(TIFF* tif, uint8* buf, tmsize_t size, uint16 sample);
+typedef int (*TIFFSeekMethod)(TIFF*, uint32);
+typedef void (*TIFFPostMethod)(TIFF* tif, uint8* buf, tmsize_t size);
+typedef uint32 (*TIFFStripMethod)(TIFF*, uint32);
+typedef void (*TIFFTileMethod)(TIFF*, uint32*, uint32*);
+
+struct tiff {
+ char* tif_name; /* name of open file */
+ int tif_fd; /* open file descriptor */
+ int tif_mode; /* open mode (O_*) */
+ uint32 tif_flags;
+ #define TIFF_FILLORDER 0x00003U /* natural bit fill order for machine */
+ #define TIFF_DIRTYHEADER 0x00004U /* header must be written on close */
+ #define TIFF_DIRTYDIRECT 0x00008U /* current directory must be written */
+ #define TIFF_BUFFERSETUP 0x00010U /* data buffers setup */
+ #define TIFF_CODERSETUP 0x00020U /* encoder/decoder setup done */
+ #define TIFF_BEENWRITING 0x00040U /* written 1+ scanlines to file */
+ #define TIFF_SWAB 0x00080U /* byte swap file information */
+ #define TIFF_NOBITREV 0x00100U /* inhibit bit reversal logic */
+ #define TIFF_MYBUFFER 0x00200U /* my raw data buffer; free on close */
+ #define TIFF_ISTILED 0x00400U /* file is tile, not strip- based */
+ #define TIFF_MAPPED 0x00800U /* file is mapped into memory */
+ #define TIFF_POSTENCODE 0x01000U /* need call to postencode routine */
+ #define TIFF_INSUBIFD 0x02000U /* currently writing a subifd */
+ #define TIFF_UPSAMPLED 0x04000U /* library is doing data up-sampling */
+ #define TIFF_STRIPCHOP 0x08000U /* enable strip chopping support */
+ #define TIFF_HEADERONLY 0x10000U /* read header only, do not process the first directory */
+ #define TIFF_NOREADRAW 0x20000U /* skip reading of raw uncompressed image data */
+ #define TIFF_INCUSTOMIFD 0x40000U /* currently writing a custom IFD */
+ #define TIFF_BIGTIFF 0x80000U /* read/write bigtiff */
+ #define TIFF_BUF4WRITE 0x100000U /* rawcc bytes are for writing */
+ #define TIFF_DIRTYSTRIP 0x200000U /* stripoffsets/stripbytecount dirty*/
+ #define TIFF_PERSAMPLE 0x400000U /* get/set per sample tags as arrays */
+ #define TIFF_BUFFERMMAP 0x800000U /* read buffer (tif_rawdata) points into mmap() memory */
+ uint64 tif_diroff; /* file offset of current directory */
+ uint64 tif_nextdiroff; /* file offset of following directory */
+ uint64* tif_dirlist; /* list of offsets to already seen directories to prevent IFD looping */
+ uint16 tif_dirlistsize; /* number of entries in offset list */
+ uint16 tif_dirnumber; /* number of already seen directories */
+ TIFFDirectory tif_dir; /* internal rep of current directory */
+ TIFFDirectory tif_customdir; /* custom IFDs are separated from the main ones */
+ union {
+ TIFFHeaderCommon common;
+ TIFFHeaderClassic classic;
+ TIFFHeaderBig big;
+ } tif_header;
+ uint16 tif_header_size; /* file's header block and its length */
+ uint32 tif_row; /* current scanline */
+ uint16 tif_curdir; /* current directory (index) */
+ uint32 tif_curstrip; /* current strip for read/write */
+ uint64 tif_curoff; /* current offset for read/write */
+ uint64 tif_dataoff; /* current offset for writing dir */
+ /* SubIFD support */
+ uint16 tif_nsubifd; /* remaining subifds to write */
+ uint64 tif_subifdoff; /* offset for patching SubIFD link */
+ /* tiling support */
+ uint32 tif_col; /* current column (offset by row too) */
+ uint32 tif_curtile; /* current tile for read/write */
+ tmsize_t tif_tilesize; /* # of bytes in a tile */
+ /* compression scheme hooks */
+ int tif_decodestatus;
+ TIFFBoolMethod tif_fixuptags; /* called in TIFFReadDirectory */
+ TIFFBoolMethod tif_setupdecode; /* called once before predecode */
+ TIFFPreMethod tif_predecode; /* pre- row/strip/tile decoding */
+ TIFFBoolMethod tif_setupencode; /* called once before preencode */
+ int tif_encodestatus;
+ TIFFPreMethod tif_preencode; /* pre- row/strip/tile encoding */
+ TIFFBoolMethod tif_postencode; /* post- row/strip/tile encoding */
+ TIFFCodeMethod tif_decoderow; /* scanline decoding routine */
+ TIFFCodeMethod tif_encoderow; /* scanline encoding routine */
+ TIFFCodeMethod tif_decodestrip; /* strip decoding routine */
+ TIFFCodeMethod tif_encodestrip; /* strip encoding routine */
+ TIFFCodeMethod tif_decodetile; /* tile decoding routine */
+ TIFFCodeMethod tif_encodetile; /* tile encoding routine */
+ TIFFVoidMethod tif_close; /* cleanup-on-close routine */
+ TIFFSeekMethod tif_seek; /* position within a strip routine */
+ TIFFVoidMethod tif_cleanup; /* cleanup state routine */
+ TIFFStripMethod tif_defstripsize; /* calculate/constrain strip size */
+ TIFFTileMethod tif_deftilesize; /* calculate/constrain tile size */
+ uint8* tif_data; /* compression scheme private data */
+ /* input/output buffering */
+ tmsize_t tif_scanlinesize; /* # of bytes in a scanline */
+ tmsize_t tif_scanlineskew; /* scanline skew for reading strips */
+ uint8* tif_rawdata; /* raw data buffer */
+ tmsize_t tif_rawdatasize; /* # of bytes in raw data buffer */
+ tmsize_t tif_rawdataoff; /* rawdata offset within strip */
+ tmsize_t tif_rawdataloaded;/* amount of data in rawdata */
+ uint8* tif_rawcp; /* current spot in raw buffer */
+ tmsize_t tif_rawcc; /* bytes unread from raw buffer */
+ /* memory-mapped file support */
+ uint8* tif_base; /* base of mapped file */
+ tmsize_t tif_size; /* size of mapped file region (bytes, thus tmsize_t) */
+ TIFFMapFileProc tif_mapproc; /* map file method */
+ TIFFUnmapFileProc tif_unmapproc; /* unmap file method */
+ /* input/output callback methods */
+ thandle_t tif_clientdata; /* callback parameter */
+ TIFFReadWriteProc tif_readproc; /* read method */
+ TIFFReadWriteProc tif_writeproc; /* write method */
+ TIFFSeekProc tif_seekproc; /* lseek method */
+ TIFFCloseProc tif_closeproc; /* close method */
+ TIFFSizeProc tif_sizeproc; /* filesize method */
+ /* post-decoding support */
+ TIFFPostMethod tif_postdecode; /* post decoding routine */
+ /* tag support */
+ TIFFField** tif_fields; /* sorted table of registered tags */
+ size_t tif_nfields; /* # entries in registered tag table */
+ const TIFFField* tif_foundfield; /* cached pointer to already found tag */
+ TIFFTagMethods tif_tagmethods; /* tag get/set/print routines */
+ TIFFClientInfoLink* tif_clientinfo; /* extra client information. */
+ /* Backward compatibility stuff. We need these two fields for
+ * setting up an old tag extension scheme. */
+ TIFFFieldArray* tif_fieldscompat;
+ size_t tif_nfieldscompat;
+};
+
+#define isPseudoTag(t) (t > 0xffff) /* is tag value normal or pseudo */
+
+#define isTiled(tif) (((tif)->tif_flags & TIFF_ISTILED) != 0)
+#define isMapped(tif) (((tif)->tif_flags & TIFF_MAPPED) != 0)
+#define isFillOrder(tif, o) (((tif)->tif_flags & (o)) != 0)
+#define isUpSampled(tif) (((tif)->tif_flags & TIFF_UPSAMPLED) != 0)
+#define TIFFReadFile(tif, buf, size) \
+ ((*(tif)->tif_readproc)((tif)->tif_clientdata,(buf),(size)))
+#define TIFFWriteFile(tif, buf, size) \
+ ((*(tif)->tif_writeproc)((tif)->tif_clientdata,(buf),(size)))
+#define TIFFSeekFile(tif, off, whence) \
+ ((*(tif)->tif_seekproc)((tif)->tif_clientdata,(off),(whence)))
+#define TIFFCloseFile(tif) \
+ ((*(tif)->tif_closeproc)((tif)->tif_clientdata))
+#define TIFFGetFileSize(tif) \
+ ((*(tif)->tif_sizeproc)((tif)->tif_clientdata))
+#define TIFFMapFileContents(tif, paddr, psize) \
+ ((*(tif)->tif_mapproc)((tif)->tif_clientdata,(paddr),(psize)))
+#define TIFFUnmapFileContents(tif, addr, size) \
+ ((*(tif)->tif_unmapproc)((tif)->tif_clientdata,(addr),(size)))
+
+/*
+ * Default Read/Seek/Write definitions.
+ */
+#ifndef ReadOK
+#define ReadOK(tif, buf, size) \
+ (TIFFReadFile((tif),(buf),(size))==(size))
+#endif
+#ifndef SeekOK
+#define SeekOK(tif, off) _TIFFSeekOK(tif, off)
+#endif
+#ifndef WriteOK
+#define WriteOK(tif, buf, size) \
+ (TIFFWriteFile((tif),(buf),(size))==(size))
+#endif
+
+/* NB: the uint32 casts are to silence certain ANSI-C compilers */
+#define TIFFhowmany_32(x, y) (((uint32)x < (0xffffffff - (uint32)(y-1))) ? \
+ ((((uint32)(x))+(((uint32)(y))-1))/((uint32)(y))) : \
+ 0U)
+/* Variant of TIFFhowmany_32() that doesn't return 0 if x close to MAXUINT. */
+/* Caution: TIFFhowmany_32_maxuint_compat(x,y)*y might overflow */
+#define TIFFhowmany_32_maxuint_compat(x, y) \
+ (((uint32)(x) / (uint32)(y)) + ((((uint32)(x) % (uint32)(y)) != 0) ? 1 : 0))
+#define TIFFhowmany8_32(x) (((x)&0x07)?((uint32)(x)>>3)+1:(uint32)(x)>>3)
+#define TIFFroundup_32(x, y) (TIFFhowmany_32(x,y)*(y))
+#define TIFFhowmany_64(x, y) ((((uint64)(x))+(((uint64)(y))-1))/((uint64)(y)))
+#define TIFFhowmany8_64(x) (((x)&0x07)?((uint64)(x)>>3)+1:(uint64)(x)>>3)
+#define TIFFroundup_64(x, y) (TIFFhowmany_64(x,y)*(y))
+
+/* Safe multiply which returns zero if there is an integer overflow */
+#define TIFFSafeMultiply(t,v,m) ((((t)(m) != (t)0) && (((t)(((v)*(m))/(m))) == (t)(v))) ? (t)((v)*(m)) : (t)0)
+
+#define TIFFmax(A,B) ((A)>(B)?(A):(B))
+#define TIFFmin(A,B) ((A)<(B)?(A):(B))
+
+#define TIFFArrayCount(a) (sizeof (a) / sizeof ((a)[0]))
+
+/*
+ Support for large files.
+
+ Windows read/write APIs support only 'unsigned int' rather than 'size_t'.
+ Windows off_t is only 32-bit, even in 64-bit builds.
+*/
+#if defined(HAVE_FSEEKO)
+/*
+ Use fseeko() and ftello() if they are available since they use
+ 'off_t' rather than 'long'. It is wrong to use fseeko() and
+ ftello() only on systems with special LFS support since some systems
+ (e.g. FreeBSD) support a 64-bit off_t by default.
+
+ For MinGW, __MSVCRT_VERSION__ must be at least 0x800 to expose these
+ interfaces. The MinGW compiler must support the requested version. MinGW
+ does not distribute the CRT (it is supplied by Microsoft) so the correct CRT
+ must be available on the target computer in order for the program to run.
+*/
+#if defined(HAVE_FSEEKO)
+# define fseek(stream,offset,whence) fseeko(stream,offset,whence)
+# define ftell(stream,offset,whence) ftello(stream,offset,whence)
+#endif
+#endif
+#if defined(__WIN32__) && \
+ !(defined(_MSC_VER) && _MSC_VER < 1400) && \
+ !(defined(__MSVCRT_VERSION__) && __MSVCRT_VERSION__ < 0x800)
+typedef unsigned int TIFFIOSize_t;
+#define _TIFF_lseek_f(fildes,offset,whence) _lseeki64(fildes,/* __int64 */ offset,whence)
+/* #define _TIFF_tell_f(fildes) /\* __int64 *\/ _telli64(fildes) */
+#define _TIFF_fseek_f(stream,offset,whence) _fseeki64(stream,/* __int64 */ offset,whence)
+#define _TIFF_fstat_f(fildes,stat_buff) _fstati64(fildes,/* struct _stati64 */ stat_buff)
+/* #define _TIFF_ftell_f(stream) /\* __int64 *\/ _ftelli64(stream) */
+/* #define _TIFF_stat_f(path,stat_buff) _stati64(path,/\* struct _stati64 *\/ stat_buff) */
+#define _TIFF_stat_s struct _stati64
+#define _TIFF_off_t __int64
+#else
+typedef size_t TIFFIOSize_t;
+#define _TIFF_lseek_f(fildes,offset,whence) lseek(fildes,offset,whence)
+/* #define _TIFF_tell_f(fildes) (_TIFF_lseek_f(fildes,0,SEEK_CUR)) */
+#define _TIFF_fseek_f(stream,offset,whence) fseek(stream,offset,whence)
+#define _TIFF_fstat_f(fildes,stat_buff) fstat(fildes,stat_buff)
+/* #define _TIFF_ftell_f(stream) ftell(stream) */
+/* #define _TIFF_stat_f(path,stat_buff) stat(path,stat_buff) */
+#define _TIFF_stat_s struct stat
+#define _TIFF_off_t off_t
+#endif
+
+#if defined(__has_attribute) && defined(__clang__)
+#if __has_attribute(no_sanitize)
+#define TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW __attribute__((no_sanitize("unsigned-integer-overflow")))
+#else
+#define TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+#endif
+#else
+#define TIFF_NOSANITIZE_UNSIGNED_INT_OVERFLOW
+#endif
+
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+extern int _TIFFgetMode(const char* mode, const char* module);
+extern int _TIFFNoRowEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s);
+extern int _TIFFNoStripEncode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s);
+extern int _TIFFNoTileEncode(TIFF*, uint8* pp, tmsize_t cc, uint16 s);
+extern int _TIFFNoRowDecode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s);
+extern int _TIFFNoStripDecode(TIFF* tif, uint8* pp, tmsize_t cc, uint16 s);
+extern int _TIFFNoTileDecode(TIFF*, uint8* pp, tmsize_t cc, uint16 s);
+extern void _TIFFNoPostDecode(TIFF* tif, uint8* buf, tmsize_t cc);
+extern int _TIFFNoPreCode(TIFF* tif, uint16 s);
+extern int _TIFFNoSeek(TIFF* tif, uint32 off);
+extern void _TIFFSwab16BitData(TIFF* tif, uint8* buf, tmsize_t cc);
+extern void _TIFFSwab24BitData(TIFF* tif, uint8* buf, tmsize_t cc);
+extern void _TIFFSwab32BitData(TIFF* tif, uint8* buf, tmsize_t cc);
+extern void _TIFFSwab64BitData(TIFF* tif, uint8* buf, tmsize_t cc);
+extern int TIFFFlushData1(TIFF* tif);
+extern int TIFFDefaultDirectory(TIFF* tif);
+extern void _TIFFSetDefaultCompressionState(TIFF* tif);
+extern int _TIFFRewriteField(TIFF *, uint16, TIFFDataType, tmsize_t, void *);
+extern int TIFFSetCompressionScheme(TIFF* tif, int scheme);
+extern int TIFFSetDefaultCompressionState(TIFF* tif);
+extern uint32 _TIFFDefaultStripSize(TIFF* tif, uint32 s);
+extern void _TIFFDefaultTileSize(TIFF* tif, uint32* tw, uint32* th);
+extern int _TIFFDataSize(TIFFDataType type);
+
+extern void _TIFFsetByteArray(void**, void*, uint32);
+extern void _TIFFsetString(char**, char*);
+extern void _TIFFsetShortArray(uint16**, uint16*, uint32);
+extern void _TIFFsetLongArray(uint32**, uint32*, uint32);
+extern void _TIFFsetFloatArray(float**, float*, uint32);
+extern void _TIFFsetDoubleArray(double**, double*, uint32);
+
+extern void _TIFFprintAscii(FILE*, const char*);
+extern void _TIFFprintAsciiTag(FILE*, const char*, const char*);
+
+extern TIFFErrorHandler _TIFFwarningHandler;
+extern TIFFErrorHandler _TIFFerrorHandler;
+extern TIFFErrorHandlerExt _TIFFwarningHandlerExt;
+extern TIFFErrorHandlerExt _TIFFerrorHandlerExt;
+
+extern uint32 _TIFFMultiply32(TIFF*, uint32, uint32, const char*);
+extern uint64 _TIFFMultiply64(TIFF*, uint64, uint64, const char*);
+extern void* _TIFFCheckMalloc(TIFF*, tmsize_t, tmsize_t, const char*);
+extern void* _TIFFCheckRealloc(TIFF*, void*, tmsize_t, tmsize_t, const char*);
+
+extern double _TIFFUInt64ToDouble(uint64);
+extern float _TIFFUInt64ToFloat(uint64);
+
+extern tmsize_t
+_TIFFReadEncodedStripAndAllocBuffer(TIFF* tif, uint32 strip,
+ void **buf, tmsize_t bufsizetoalloc,
+ tmsize_t size_to_read);
+extern tmsize_t
+_TIFFReadEncodedTileAndAllocBuffer(TIFF* tif, uint32 tile,
+ void **buf, tmsize_t bufsizetoalloc,
+ tmsize_t size_to_read);
+extern tmsize_t
+_TIFFReadTileAndAllocBuffer(TIFF* tif,
+ void **buf, tmsize_t bufsizetoalloc,
+ uint32 x, uint32 y, uint32 z, uint16 s);
+extern int _TIFFSeekOK(TIFF* tif, toff_t off);
+
+extern int TIFFInitDumpMode(TIFF*, int);
+#ifdef PACKBITS_SUPPORT
+extern int TIFFInitPackBits(TIFF*, int);
+#endif
+#ifdef CCITT_SUPPORT
+extern int TIFFInitCCITTRLE(TIFF*, int), TIFFInitCCITTRLEW(TIFF*, int);
+extern int TIFFInitCCITTFax3(TIFF*, int), TIFFInitCCITTFax4(TIFF*, int);
+#endif
+#ifdef THUNDER_SUPPORT
+extern int TIFFInitThunderScan(TIFF*, int);
+#endif
+#ifdef NEXT_SUPPORT
+extern int TIFFInitNeXT(TIFF*, int);
+#endif
+#ifdef LZW_SUPPORT
+extern int TIFFInitLZW(TIFF*, int);
+#endif
+#ifdef OJPEG_SUPPORT
+extern int TIFFInitOJPEG(TIFF*, int);
+#endif
+#ifdef JPEG_SUPPORT
+extern int TIFFInitJPEG(TIFF*, int);
+extern int TIFFJPEGIsFullStripRequired(TIFF*);
+#endif
+#ifdef JBIG_SUPPORT
+extern int TIFFInitJBIG(TIFF*, int);
+#endif
+#ifdef ZIP_SUPPORT
+extern int TIFFInitZIP(TIFF*, int);
+#endif
+#ifdef PIXARLOG_SUPPORT
+extern int TIFFInitPixarLog(TIFF*, int);
+#endif
+#ifdef LOGLUV_SUPPORT
+extern int TIFFInitSGILog(TIFF*, int);
+#endif
+#ifdef LZMA_SUPPORT
+extern int TIFFInitLZMA(TIFF*, int);
+#endif
+#ifdef ZSTD_SUPPORT
+extern int TIFFInitZSTD(TIFF*, int);
+#endif
+#ifdef WEBP_SUPPORT
+extern int TIFFInitWebP(TIFF*, int);
+#endif
+#ifdef VMS
+extern const TIFFCodec _TIFFBuiltinCODECS[];
+#else
+extern TIFFCodec _TIFFBuiltinCODECS[];
+#endif
+
+#if defined(__cplusplus)
+}
+#endif
+#endif /* _TIFFIOP_ */
+
+/* vim: set ts=8 sts=8 sw=8 noet: */
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/tiff-4.0.10/tiffvers.h b/test/monniaux/tiff-4.0.10/tiffvers.h
new file mode 100644
index 00000000..403d61be
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/tiffvers.h
@@ -0,0 +1,9 @@
+#define TIFFLIB_VERSION_STR "LIBTIFF, Version 4.0.10\nCopyright (c) 1988-1996 Sam Leffler\nCopyright (c) 1991-1996 Silicon Graphics, Inc."
+/*
+ * This define can be used in code that requires
+ * compilation-related definitions specific to a
+ * version or versions of the library. Runtime
+ * version checking should be done based on the
+ * string returned by TIFFGetVersion.
+ */
+#define TIFFLIB_VERSION 20181110
diff --git a/test/monniaux/tiff-4.0.10/uvcode.h b/test/monniaux/tiff-4.0.10/uvcode.h
new file mode 100644
index 00000000..6286cfbb
--- /dev/null
+++ b/test/monniaux/tiff-4.0.10/uvcode.h
@@ -0,0 +1,180 @@
+/* Version 1.0 generated April 7, 1997 by Greg Ward Larson, SGI */
+#define UV_SQSIZ (float)0.003500
+#define UV_NDIVS 16289
+#define UV_VSTART (float)0.016940
+#define UV_NVS 163
+static const struct {
+ float ustart;
+ short nus, ncum;
+} uv_row[UV_NVS] = {
+ { (float)0.247663, 4, 0 },
+ { (float)0.243779, 6, 4 },
+ { (float)0.241684, 7, 10 },
+ { (float)0.237874, 9, 17 },
+ { (float)0.235906, 10, 26 },
+ { (float)0.232153, 12, 36 },
+ { (float)0.228352, 14, 48 },
+ { (float)0.226259, 15, 62 },
+ { (float)0.222371, 17, 77 },
+ { (float)0.220410, 18, 94 },
+ { (float)0.214710, 21, 112 },
+ { (float)0.212714, 22, 133 },
+ { (float)0.210721, 23, 155 },
+ { (float)0.204976, 26, 178 },
+ { (float)0.202986, 27, 204 },
+ { (float)0.199245, 29, 231 },
+ { (float)0.195525, 31, 260 },
+ { (float)0.193560, 32, 291 },
+ { (float)0.189878, 34, 323 },
+ { (float)0.186216, 36, 357 },
+ { (float)0.186216, 36, 393 },
+ { (float)0.182592, 38, 429 },
+ { (float)0.179003, 40, 467 },
+ { (float)0.175466, 42, 507 },
+ { (float)0.172001, 44, 549 },
+ { (float)0.172001, 44, 593 },
+ { (float)0.168612, 46, 637 },
+ { (float)0.168612, 46, 683 },
+ { (float)0.163575, 49, 729 },
+ { (float)0.158642, 52, 778 },
+ { (float)0.158642, 52, 830 },
+ { (float)0.158642, 52, 882 },
+ { (float)0.153815, 55, 934 },
+ { (float)0.153815, 55, 989 },
+ { (float)0.149097, 58, 1044 },
+ { (float)0.149097, 58, 1102 },
+ { (float)0.142746, 62, 1160 },
+ { (float)0.142746, 62, 1222 },
+ { (float)0.142746, 62, 1284 },
+ { (float)0.138270, 65, 1346 },
+ { (float)0.138270, 65, 1411 },
+ { (float)0.138270, 65, 1476 },
+ { (float)0.132166, 69, 1541 },
+ { (float)0.132166, 69, 1610 },
+ { (float)0.126204, 73, 1679 },
+ { (float)0.126204, 73, 1752 },
+ { (float)0.126204, 73, 1825 },
+ { (float)0.120381, 77, 1898 },
+ { (float)0.120381, 77, 1975 },
+ { (float)0.120381, 77, 2052 },
+ { (float)0.120381, 77, 2129 },
+ { (float)0.112962, 82, 2206 },
+ { (float)0.112962, 82, 2288 },
+ { (float)0.112962, 82, 2370 },
+ { (float)0.107450, 86, 2452 },
+ { (float)0.107450, 86, 2538 },
+ { (float)0.107450, 86, 2624 },
+ { (float)0.107450, 86, 2710 },
+ { (float)0.100343, 91, 2796 },
+ { (float)0.100343, 91, 2887 },
+ { (float)0.100343, 91, 2978 },
+ { (float)0.095126, 95, 3069 },
+ { (float)0.095126, 95, 3164 },
+ { (float)0.095126, 95, 3259 },
+ { (float)0.095126, 95, 3354 },
+ { (float)0.088276, 100, 3449 },
+ { (float)0.088276, 100, 3549 },
+ { (float)0.088276, 100, 3649 },
+ { (float)0.088276, 100, 3749 },
+ { (float)0.081523, 105, 3849 },
+ { (float)0.081523, 105, 3954 },
+ { (float)0.081523, 105, 4059 },
+ { (float)0.081523, 105, 4164 },
+ { (float)0.074861, 110, 4269 },
+ { (float)0.074861, 110, 4379 },
+ { (float)0.074861, 110, 4489 },
+ { (float)0.074861, 110, 4599 },
+ { (float)0.068290, 115, 4709 },
+ { (float)0.068290, 115, 4824 },
+ { (float)0.068290, 115, 4939 },
+ { (float)0.068290, 115, 5054 },
+ { (float)0.063573, 119, 5169 },
+ { (float)0.063573, 119, 5288 },
+ { (float)0.063573, 119, 5407 },
+ { (float)0.063573, 119, 5526 },
+ { (float)0.057219, 124, 5645 },
+ { (float)0.057219, 124, 5769 },
+ { (float)0.057219, 124, 5893 },
+ { (float)0.057219, 124, 6017 },
+ { (float)0.050985, 129, 6141 },
+ { (float)0.050985, 129, 6270 },
+ { (float)0.050985, 129, 6399 },
+ { (float)0.050985, 129, 6528 },
+ { (float)0.050985, 129, 6657 },
+ { (float)0.044859, 134, 6786 },
+ { (float)0.044859, 134, 6920 },
+ { (float)0.044859, 134, 7054 },
+ { (float)0.044859, 134, 7188 },
+ { (float)0.040571, 138, 7322 },
+ { (float)0.040571, 138, 7460 },
+ { (float)0.040571, 138, 7598 },
+ { (float)0.040571, 138, 7736 },
+ { (float)0.036339, 142, 7874 },
+ { (float)0.036339, 142, 8016 },
+ { (float)0.036339, 142, 8158 },
+ { (float)0.036339, 142, 8300 },
+ { (float)0.032139, 146, 8442 },
+ { (float)0.032139, 146, 8588 },
+ { (float)0.032139, 146, 8734 },
+ { (float)0.032139, 146, 8880 },
+ { (float)0.027947, 150, 9026 },
+ { (float)0.027947, 150, 9176 },
+ { (float)0.027947, 150, 9326 },
+ { (float)0.023739, 154, 9476 },
+ { (float)0.023739, 154, 9630 },
+ { (float)0.023739, 154, 9784 },
+ { (float)0.023739, 154, 9938 },
+ { (float)0.019504, 158, 10092 },
+ { (float)0.019504, 158, 10250 },
+ { (float)0.019504, 158, 10408 },
+ { (float)0.016976, 161, 10566 },
+ { (float)0.016976, 161, 10727 },
+ { (float)0.016976, 161, 10888 },
+ { (float)0.016976, 161, 11049 },
+ { (float)0.012639, 165, 11210 },
+ { (float)0.012639, 165, 11375 },
+ { (float)0.012639, 165, 11540 },
+ { (float)0.009991, 168, 11705 },
+ { (float)0.009991, 168, 11873 },
+ { (float)0.009991, 168, 12041 },
+ { (float)0.009016, 170, 12209 },
+ { (float)0.009016, 170, 12379 },
+ { (float)0.009016, 170, 12549 },
+ { (float)0.006217, 173, 12719 },
+ { (float)0.006217, 173, 12892 },
+ { (float)0.005097, 175, 13065 },
+ { (float)0.005097, 175, 13240 },
+ { (float)0.005097, 175, 13415 },
+ { (float)0.003909, 177, 13590 },
+ { (float)0.003909, 177, 13767 },
+ { (float)0.002340, 177, 13944 },
+ { (float)0.002389, 170, 14121 },
+ { (float)0.001068, 164, 14291 },
+ { (float)0.001653, 157, 14455 },
+ { (float)0.000717, 150, 14612 },
+ { (float)0.001614, 143, 14762 },
+ { (float)0.000270, 136, 14905 },
+ { (float)0.000484, 129, 15041 },
+ { (float)0.001103, 123, 15170 },
+ { (float)0.001242, 115, 15293 },
+ { (float)0.001188, 109, 15408 },
+ { (float)0.001011, 103, 15517 },
+ { (float)0.000709, 97, 15620 },
+ { (float)0.000301, 89, 15717 },
+ { (float)0.002416, 82, 15806 },
+ { (float)0.003251, 76, 15888 },
+ { (float)0.003246, 69, 15964 },
+ { (float)0.004141, 62, 16033 },
+ { (float)0.005963, 55, 16095 },
+ { (float)0.008839, 47, 16150 },
+ { (float)0.010490, 40, 16197 },
+ { (float)0.016994, 31, 16237 },
+ { (float)0.023659, 21, 16268 },
+};
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 8
+ * fill-column: 78
+ * End:
+ */
diff --git a/test/monniaux/too_slow/Makefile b/test/monniaux/too_slow/Makefile
new file mode 100644
index 00000000..a1466d1d
--- /dev/null
+++ b/test/monniaux/too_slow/Makefile
@@ -0,0 +1,3 @@
+TARGET=memset_from_bitslices-aes
+
+include ../rules.mk
diff --git a/test/monniaux/too_slow/make.proto b/test/monniaux/too_slow/make.proto
deleted file mode 100644
index 852971fc..00000000
--- a/test/monniaux/too_slow/make.proto
+++ /dev/null
@@ -1,3 +0,0 @@
-target: memset_from_bitsliced-aes
-measures: [cycles]
-name: memset-aes
diff --git a/test/monniaux/vocabulary.sh b/test/monniaux/vocabulary.sh
new file mode 100755
index 00000000..5b76921e
--- /dev/null
+++ b/test/monniaux/vocabulary.sh
@@ -0,0 +1,2 @@
+cat *.gcc.k1c.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > gcc_vocabulary.txt
+cat *.ccomp.k1c.s|cut -f2|cut -d' ' -f1|sort -u|grep -v ':'|grep -v -F '.' > ccomp_vocabulary.txt
diff --git a/test/monniaux/xor_and_mat/Makefile b/test/monniaux/xor_and_mat/Makefile
index 005382de..e6c4db77 100644
--- a/test/monniaux/xor_and_mat/Makefile
+++ b/test/monniaux/xor_and_mat/Makefile
@@ -1,21 +1,4 @@
-include ../rules.mk
-
-PRODUCTS=int_mat.host int_mat.gcc.k1c.out int_mat.ccomp.k1c.out int_mat.ccomp.k1c.s int_mat.gcc.k1c.s int_mat.gcc.k1c int_mat.ccomp.k1c
-
-all: $(PRODUCTS)
-
-int_mat.host: int_mat.c int_mat_run.c xor_and.h
- $(CC) $(CFLAGS) int_mat.c int_mat_run.c -o $@
-
-int_mat.gcc.k1c.s int_mat.ccomp.k1c.s int_mat_run.gcc.k1c.s: xor_and.h
+TARGET=xor_and_mat
+MEASURES="c1 c2 c3 c4 c5 c6 c7"
-int_mat.gcc.k1c: int_mat.gcc.k1c.o int_mat_run.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
-
-int_mat.ccomp.k1c: int_mat.ccomp.k1c.o int_mat_run.gcc.k1c.o
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
-
-clean:
- $(RM) -f $(PRODUCTS) int_mat.gcc.k1c.o int_mat.ccomp.k1c.o int_mat_run.gcc.k1c.o
-
-.PHONY: clean
+include ../rules.mk
diff --git a/test/monniaux/xor_and_mat/int_mat_run.c b/test/monniaux/xor_and_mat/int_mat_run.c
index 53335de4..a6a821d9 100644
--- a/test/monniaux/xor_and_mat/int_mat_run.c
+++ b/test/monniaux/xor_and_mat/int_mat_run.c
@@ -3,50 +3,50 @@
#include <stdio.h>
#include <inttypes.h>
#include "xor_and.h"
-#include "../cycles.h"
+#include "../clock.h"
int main() {
const unsigned m = 60, n = 31, p = 50;
- cycle_count_config();
+ clock_prepare();
xor_and *a = malloc(sizeof(xor_and) * m * n);
xor_and_mat_random(m, n, a, n);
xor_and *b = malloc(sizeof(xor_and) * n * p);
xor_and_mat_random(n, p, b, p);
xor_and *c1 = malloc(sizeof(xor_and) * m * p);
- cycle_t c1_time = get_cycle();
+ cycle_t c1_time = get_current_cycle();
xor_and_mat_mul1(m, n, p, c1, p, a, n, b, p);
- c1_time = get_cycle()-c1_time;
+ c1_time = get_current_cycle()-c1_time;
xor_and *c2 = malloc(sizeof(xor_and) * m * p);
- cycle_t c2_time = get_cycle();
+ cycle_t c2_time = get_current_cycle();
xor_and_mat_mul2(m, n, p, c2, p, a, n, b, p);
- c2_time = get_cycle()-c2_time;
+ c2_time = get_current_cycle()-c2_time;
xor_and *c3 = malloc(sizeof(xor_and) * m * p);
- cycle_t c3_time = get_cycle();
+ cycle_t c3_time = get_current_cycle();
xor_and_mat_mul3(m, n, p, c3, p, a, n, b, p);
- c3_time = get_cycle()-c3_time;
+ c3_time = get_current_cycle()-c3_time;
xor_and *c4 = malloc(sizeof(xor_and) * m * p);
- cycle_t c4_time = get_cycle();
+ cycle_t c4_time = get_current_cycle();
xor_and_mat_mul4(m, n, p, c4, p, a, n, b, p);
- c4_time = get_cycle()-c4_time;
+ c4_time = get_current_cycle()-c4_time;
xor_and *c5 = malloc(sizeof(xor_and) * m * p);
- cycle_t c5_time = get_cycle();
+ cycle_t c5_time = get_current_cycle();
xor_and_mat_mul5(m, n, p, c5, p, a, n, b, p);
- c5_time = get_cycle()-c5_time;
+ c5_time = get_current_cycle()-c5_time;
xor_and *c6 = malloc(sizeof(xor_and) * m * p);
- cycle_t c6_time = get_cycle();
+ cycle_t c6_time = get_current_cycle();
xor_and_mat_mul6(m, n, p, c6, p, a, n, b, p);
- c6_time = get_cycle()-c6_time;
+ c6_time = get_current_cycle()-c6_time;
xor_and *c7 = malloc(sizeof(xor_and) * m * p);
- cycle_t c7_time = get_cycle();
+ cycle_t c7_time = get_current_cycle();
xor_and_mat_mul7(m, n, p, c7, p, a, n, b, p);
- c7_time = get_cycle()-c7_time;
+ c7_time = get_current_cycle()-c7_time;
printf("c1==c2: %s\n"
"c1==c3: %s\n"
@@ -54,13 +54,13 @@ int main() {
"c1==c5: %s\n"
"c1==c6: %s\n"
"c1==c7: %s\n"
- "c1_time = %" PRIu64 "\n"
- "c2_time = %" PRIu64 "\n"
- "c3_time = %" PRIu64 "\n"
- "c4_time = %" PRIu64 "\n"
- "c5_time = %" PRIu64 "\n"
- "c6_time = %" PRIu64 "\n"
- "c7_time = %" PRIu64 "\n",
+ "c1 cycles: %" PRIu64 "\n"
+ "c2 cycles: %" PRIu64 "\n"
+ "c3 cycles: %" PRIu64 "\n"
+ "c4 cycles: %" PRIu64 "\n"
+ "c5 cycles: %" PRIu64 "\n"
+ "c6 cycles: %" PRIu64 "\n"
+ "c7 cycles: %" PRIu64 "\n",
xor_and_mat_equal(m, n, c1, p, c2, p)?"true":"false",
xor_and_mat_equal(m, n, c1, p, c3, p)?"true":"false",
diff --git a/test/monniaux/yarpgen/Makefile b/test/monniaux/yarpgen/Makefile
index 9da82deb..28bd5ae0 100644
--- a/test/monniaux/yarpgen/Makefile
+++ b/test/monniaux/yarpgen/Makefile
@@ -1,52 +1,98 @@
-YARPGEN=yarpgen
-MAX=300
+TARGET_CCOMP=../../../ccomp
+TARGET_CC=gcc
+
+all:
+
+.SECONDARY:
+
+ifndef YARPGEN
+YARPGEN=./yarpgen
+GENERATOR=yarpgen
+endif
+
+ifdef BITS
+YARPGEN+=-m $(BITS)
+CFLAGS+=-m$(BITS)
+endif
+
+MAX=129
PREFIX=ran%06.f
-include ../rules.mk
-
-K1C_CCOMPFLAGS += -funprototyped -fbitfields
-CCOMPFLAGS += -funprototyped -fbitfields
-
-TARGETS_C=$(shell seq --format $(PREFIX)/func.c 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/driver.c 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/init.h 0 $(MAX))
-TARGETS_CCOMP_K1C_S=$(shell seq --format $(PREFIX)/func.ccomp.k1c.s 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/driver.ccomp.k1c.s 0 $(MAX))
-TARGETS_GCC_K1C_S=$(shell seq --format $(PREFIX)/func.gcc.k1c.s 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/driver.gcc.k1c.s 0 $(MAX))
-TARGETS_CCOMP_HOST_S=$(shell seq --format $(PREFIX)/func.ccomp.host.s 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/driver.ccomp.host.s 0 $(MAX))
-TARGETS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 0 $(MAX)) \
- $(shell seq --format $(PREFIX)/driver.gcc.host.s 0 $(MAX))
-TARGETS_CCOMP_K1C_OUT=$(shell seq --format $(PREFIX)/example.ccomp.k1c.out 0 $(MAX))
-TARGETS_GCC_K1C_OUT=$(shell seq --format $(PREFIX)/example.gcc.k1c.out 0 $(MAX))
-TARGETS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 0 $(MAX))
-TARGETS_CCOMP_HOST_OUT=$(shell seq --format $(PREFIX)/example.ccomp.host.out 0 $(MAX))
-TARGETS_CMP=$(shell seq --format $(PREFIX)/example.k1c.cmp 0 $(MAX))
-
-all: $(TARGETS_CCOMP_K1C_OUT) $(TARGETS_GCC_K1C_OUT) $(TARGETS_GCC_HOST_OUT) $(TARGETS_CCOMP_HOST_OUT) $(TARGETS_CCOMP_K1C_S) $(TARGETS_GCC_K1C_S) $(TARGETS_GCC_HOST_S) $(TARGETS_CCOMP_HOST_S) $(TARGETS_CMP) $(TARGETS_C)
-
-ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h
-
-ran%/example.ccomp.k1c: ran%/func.ccomp.k1c.o ran%/driver.ccomp.k1c.o
- $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
-
-ran%/example.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o
- $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
-
-ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o
- $(CC) $(CFLAGS) $+ -o $@
-ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o
- $(CCOMP) $(CCOMPFLAGS) $+ -o $@
+CCOMPOPTS=-static
+CCOMPFLAGS+=-funprototyped -fbitfields -fno-cse2 -stdlib ../../../runtime # FIXME
+
+TESTS_C=$(shell seq --format $(PREFIX)/func.c 1 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.c 1 $(MAX)) \
+ $(shell seq --format $(PREFIX)/init.c 1 $(MAX)) \
+ $(shell seq --format $(PREFIX)/hash.c 1 $(MAX)) \
+ $(shell seq --format $(PREFIX)/check.c 1 $(MAX)) \
+ $(shell seq --format $(PREFIX)/init.h 1 $(MAX))
+
+$(TESTS_C): $(GENERATOR)
+
+TESTS_CCOMP_TARGET_S=$(TEST_C:.c=.ccomp.target.s)
+TESTS_GCC_TARGET_S=$(TEST_C:.c=.gcc.target.s)
+TESTS_GCC_HOST_S=$(TEST_C:.c=.gcc.host.s)
+TESTS_CCOMP_TARGET_OUT=$(shell seq --format $(PREFIX)/example.ccomp.target.out 1 $(MAX))
+TESTS_GCC_TARGET_OUT=$(shell seq --format $(PREFIX)/example.gcc.target.out 1 $(MAX))
+TESTS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 1 $(MAX))
+TESTS_CMP=$(shell seq --format $(PREFIX)/example.target.cmp 1 $(MAX)) # $(shell seq --format $(PREFIX)/example.host_target.cmp 1 $(MAX))
+
+all: $(TESTS_CCOMP_TARGET_OUT) $(TESTS_GCC_TARGET_OUT) $(TESTS_CCOMP_TARGET_S) $(TESTS_GCC_TARGET_S) $(TESTS_CMP) $(TESTS_C)
+
+tests_c: $(TESTS_C)
+
+tests_s: $(TESTS_CCOMP_TARGET_S)
+
+%.ccomp.target.s : %.c
+ $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) -S -o $@ $<
+
+%.gcc.target.s : %.c
+ $(TARGET_CC) $(CCOMPOPTS) -S -o $@ $<
-ran%/driver.c ran%/func.c ran%/init.h:
- -mkdir ran$*
+%.gcc.host.s : %.c
+ $(CC) $(CFLAGS) -S -o $@ $<
+
+%.target.o : %.target.s
+ $(TARGET_CC) -c -o $@ $<
+
+%.host.o : %.host.s
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+%.target.out : %.target
+ $(EXECUTE) $< | tee $@
+
+%.host.out : %.host
+ ./$< | tee $@
+
+ran%/func.ccomp.target.s ran%/func.gcc.target.s ran%/func.ccomp.host.s ran%/func.gcc.host.s ran%/init.gcc.host.s : ran%/init.h
+
+ran%/example.ccomp.target: ran%/func.ccomp.target.o ran%/driver.ccomp.target.o ran%/init.ccomp.target.o ran%/check.ccomp.target.o ran%/hash.ccomp.target.o
+ $(TARGET_CCOMP) $(CCOMPOPTS) $(CCOMPFLAGS) $+ -o $@
+
+ran%/example.gcc.target: ran%/func.gcc.target.o ran%/driver.gcc.target.o ran%/init.gcc.target.o ran%/check.gcc.target.o ran%/hash.gcc.target.o
+ $(TARGET_CC) $(TARGET_CFLAGS) $+ -o $@
+
+ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o ran%/init.gcc.host.o ran%/check.gcc.host.o ran%/hash.gcc.host.o
+ $(CC) $(CFLAGS) $+ -o $@
+
+ran%/driver.c ran%/func.c ran%/init.c ran%/check.c ran%/hash.c ran%/init.h:
+ mkdir -p ran$*
$(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99
-ran%/example.k1c.cmp : ran%/example.gcc.k1c.out ran%/example.ccomp.k1c.out
+ran%/example.target.cmp : ran%/example.gcc.target.out ran%/example.ccomp.target.out
cmp $+ > $@
-.PHONY: all clean
+ran%/example.host_target.cmp : ran%/example.gcc.host.out ran%/example.ccomp.target.out
+ cmp $+ > $@
+
+yarpgen:
+ curl -L -o yarpgen_v1.1.tar.gz https://github.com/intel/yarpgen/archive/v1.1.tar.gz
+ tar xfz yarpgen_v1.1.tar.gz
+ $(MAKE) CXX=g++ -C yarpgen-1.1
+ cp yarpgen-1.1/yarpgen $@
+
+.PHONY: all clean tests_c tests_c
clean:
-rm -rf ran*
diff --git a/test/monniaux/yarpgen/Makefile.old b/test/monniaux/yarpgen/Makefile.old
new file mode 100644
index 00000000..9da82deb
--- /dev/null
+++ b/test/monniaux/yarpgen/Makefile.old
@@ -0,0 +1,52 @@
+YARPGEN=yarpgen
+MAX=300
+PREFIX=ran%06.f
+include ../rules.mk
+
+K1C_CCOMPFLAGS += -funprototyped -fbitfields
+CCOMPFLAGS += -funprototyped -fbitfields
+
+TARGETS_C=$(shell seq --format $(PREFIX)/func.c 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.c 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/init.h 0 $(MAX))
+TARGETS_CCOMP_K1C_S=$(shell seq --format $(PREFIX)/func.ccomp.k1c.s 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.ccomp.k1c.s 0 $(MAX))
+TARGETS_GCC_K1C_S=$(shell seq --format $(PREFIX)/func.gcc.k1c.s 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.gcc.k1c.s 0 $(MAX))
+TARGETS_CCOMP_HOST_S=$(shell seq --format $(PREFIX)/func.ccomp.host.s 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.ccomp.host.s 0 $(MAX))
+TARGETS_GCC_HOST_S=$(shell seq --format $(PREFIX)/func.gcc.host.s 0 $(MAX)) \
+ $(shell seq --format $(PREFIX)/driver.gcc.host.s 0 $(MAX))
+TARGETS_CCOMP_K1C_OUT=$(shell seq --format $(PREFIX)/example.ccomp.k1c.out 0 $(MAX))
+TARGETS_GCC_K1C_OUT=$(shell seq --format $(PREFIX)/example.gcc.k1c.out 0 $(MAX))
+TARGETS_GCC_HOST_OUT=$(shell seq --format $(PREFIX)/example.gcc.host.out 0 $(MAX))
+TARGETS_CCOMP_HOST_OUT=$(shell seq --format $(PREFIX)/example.ccomp.host.out 0 $(MAX))
+TARGETS_CMP=$(shell seq --format $(PREFIX)/example.k1c.cmp 0 $(MAX))
+
+all: $(TARGETS_CCOMP_K1C_OUT) $(TARGETS_GCC_K1C_OUT) $(TARGETS_GCC_HOST_OUT) $(TARGETS_CCOMP_HOST_OUT) $(TARGETS_CCOMP_K1C_S) $(TARGETS_GCC_K1C_S) $(TARGETS_GCC_HOST_S) $(TARGETS_CCOMP_HOST_S) $(TARGETS_CMP) $(TARGETS_C)
+
+ran%/func.ccomp.k1c.s ran%/func.gcc.k1c.s ran%/func.ccomp.host.s ran%/func.gcc.host.s : ran%/init.h
+
+ran%/example.ccomp.k1c: ran%/func.ccomp.k1c.o ran%/driver.ccomp.k1c.o
+ $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -o $@
+
+ran%/example.gcc.k1c: ran%/func.gcc.k1c.o ran%/driver.gcc.k1c.o
+ $(K1C_CC) $(K1C_CFLAGS) $+ -o $@
+
+ran%/example.gcc.host: ran%/func.gcc.host.o ran%/driver.gcc.host.o
+ $(CC) $(CFLAGS) $+ -o $@
+
+ran%/example.ccomp.host: ran%/func.ccomp.host.o ran%/driver.ccomp.host.o
+ $(CCOMP) $(CCOMPFLAGS) $+ -o $@
+
+ran%/driver.c ran%/func.c ran%/init.h:
+ -mkdir ran$*
+ $(YARPGEN) --seed=$* --out-dir=ran$*/ --std=c99
+
+ran%/example.k1c.cmp : ran%/example.gcc.k1c.out ran%/example.ccomp.k1c.out
+ cmp $+ > $@
+
+.PHONY: all clean
+
+clean:
+ -rm -rf ran*
diff --git a/test/monniaux/zlib-1.2.11/Makefile b/test/monniaux/zlib-1.2.11/Makefile
new file mode 100644
index 00000000..9e6920f5
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/Makefile
@@ -0,0 +1,62 @@
+TARGET=zlib
+
+ALL_CCOMPFLAGS=-faddx
+ALL_CFLAGS= -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__
+EXECUTE_ARGS=< zlib_small.txt > /dev/null 2> __BASE__.out
+
+include ../rules.mk
+
+
+#ALL_CCOMPFLAGS = -faddx
+#ALL_CFLAGS = -D_POSIX_C_SOURCE=2 -D_LARGEFILE64_SOURCE=1 -U__STRICT_ANSI__
+#
+#include ../rules.mk
+#
+#src=$(wildcard *.c)
+#
+#PRODUCTS?=minigzip.gcc.host minigzip.ccomp.host minigzip.gcc.k1c minigzip.gcc.o1.k1c minigzip.ccomp.k1c
+#PRODUCTS_OUT=$(addsuffix .out,$(PRODUCTS))
+#
+#all: $(PRODUCTS)
+#
+#.PHONY:
+#run: measures.csv
+#
+#
+#minigzip.gcc.host: $(src:.c=.gcc.host.o) ../clock.gcc.host.o
+# $(CC) $(CFLAGS) $+ -lm -o $@
+#minigzip.ccomp.host: $(src:.c=.ccomp.host.o) ../clock.gcc.host.o
+# $(CCOMP) $(CCOMPFLAGS) $+ -lm -o $@
+#minigzip.gcc.k1c: $(src:.c=.gcc.k1c.o) ../clock.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS) $+ -lm -o $@
+#minigzip.gcc.o1.k1c: $(src:.c=.gcc.o1.k1c.o) ../clock.gcc.k1c.o
+# $(K1C_CC) $(K1C_CFLAGS_O1) $+ -lm -o $@
+#minigzip.ccomp.k1c: $(src:.c=.ccomp.k1c.o) ../clock.gcc.k1c.o
+# $(K1C_CCOMP) $(K1C_CCOMPFLAGS) $+ -lm -o $@
+#measures.csv: $(PRODUCTS_OUT)
+# echo "benches, gcc host,ccomp host,gcc k1c,gcc o1 k1c,ccomp k1c" > $@
+# echo "zlib ", $$(grep 'cycles' minigzip.gcc.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.host.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.k1c.out | cut -d':' -f2), $$(grep 'cycles' minigzip.gcc.o1.k1c.out | cut -d':' -f2), $$(grep 'cycles' minigzip.ccomp.k1c.out | cut -d':' -f2)>> $@
+#
+#SAMPLE_FILE=zlib.h
+#
+#minigzip.gcc.host.out minigzip.gcc.host.output: minigzip.gcc.host
+# ./$< < $(SAMPLE_FILE) > $<.output 2> $@
+#
+#minigzip.ccomp.host.out minigzip.ccomp.host.output: minigzip.ccomp.host
+# ./$< < $(SAMPLE_FILE) > $<.output 2> $@
+#
+#minigzip.gcc.k1c.out minigzip.gcc.k1c.output: minigzip.gcc.k1c
+# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@
+#
+#minigzip.gcc.o1.k1c.out minigzip.gcc.o1.k1c.output: minigzip.gcc.o1.k1c
+# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@
+#
+#minigzip.ccomp.k1c.out minigzip.ccomp.k1c.output: minigzip.ccomp.k1c
+# $(EXECUTE_CYCLES) $< < $(SAMPLE_FILE) > $<.output 2> $@
+#
+#.SECONDARY:
+#
+#.PHONY:
+#clean:
+# rm -f *.o *.s *.k1c *.csv
+#
diff --git a/test/monniaux/zlib-1.2.11/adler32.c b/test/monniaux/zlib-1.2.11/adler32.c
new file mode 100644
index 00000000..d0be4380
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/adler32.c
@@ -0,0 +1,186 @@
+/* adler32.c -- compute the Adler-32 checksum of a data stream
+ * Copyright (C) 1995-2011, 2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#include "zutil.h"
+
+local uLong adler32_combine_ OF((uLong adler1, uLong adler2, z_off64_t len2));
+
+#define BASE 65521U /* largest prime smaller than 65536 */
+#define NMAX 5552
+/* NMAX is the largest n such that 255n(n+1)/2 + (n+1)(BASE-1) <= 2^32-1 */
+
+#define DO1(buf,i) {adler += (buf)[i]; sum2 += adler;}
+#define DO2(buf,i) DO1(buf,i); DO1(buf,i+1);
+#define DO4(buf,i) DO2(buf,i); DO2(buf,i+2);
+#define DO8(buf,i) DO4(buf,i); DO4(buf,i+4);
+#define DO16(buf) DO8(buf,0); DO8(buf,8);
+
+/* use NO_DIVIDE if your processor does not do division in hardware --
+ try it both ways to see which is faster */
+#ifdef NO_DIVIDE
+/* note that this assumes BASE is 65521, where 65536 % 65521 == 15
+ (thank you to John Reiser for pointing this out) */
+# define CHOP(a) \
+ do { \
+ unsigned long tmp = a >> 16; \
+ a &= 0xffffUL; \
+ a += (tmp << 4) - tmp; \
+ } while (0)
+# define MOD28(a) \
+ do { \
+ CHOP(a); \
+ if (a >= BASE) a -= BASE; \
+ } while (0)
+# define MOD(a) \
+ do { \
+ CHOP(a); \
+ MOD28(a); \
+ } while (0)
+# define MOD63(a) \
+ do { /* this assumes a is not negative */ \
+ z_off64_t tmp = a >> 32; \
+ a &= 0xffffffffL; \
+ a += (tmp << 8) - (tmp << 5) + tmp; \
+ tmp = a >> 16; \
+ a &= 0xffffL; \
+ a += (tmp << 4) - tmp; \
+ tmp = a >> 16; \
+ a &= 0xffffL; \
+ a += (tmp << 4) - tmp; \
+ if (a >= BASE) a -= BASE; \
+ } while (0)
+#else
+# define MOD(a) a %= BASE
+# define MOD28(a) a %= BASE
+# define MOD63(a) a %= BASE
+#endif
+
+/* ========================================================================= */
+uLong ZEXPORT adler32_z(adler, buf, len)
+ uLong adler;
+ const Bytef *buf;
+ z_size_t len;
+{
+ unsigned long sum2;
+ unsigned n;
+
+ /* split Adler-32 into component sums */
+ sum2 = (adler >> 16) & 0xffff;
+ adler &= 0xffff;
+
+ /* in case user likes doing a byte at a time, keep it fast */
+ if (len == 1) {
+ adler += buf[0];
+ if (adler >= BASE)
+ adler -= BASE;
+ sum2 += adler;
+ if (sum2 >= BASE)
+ sum2 -= BASE;
+ return adler | (sum2 << 16);
+ }
+
+ /* initial Adler-32 value (deferred check for len == 1 speed) */
+ if (buf == Z_NULL)
+ return 1L;
+
+ /* in case short lengths are provided, keep it somewhat fast */
+ if (len < 16) {
+ while (len--) {
+ adler += *buf++;
+ sum2 += adler;
+ }
+ if (adler >= BASE)
+ adler -= BASE;
+ MOD28(sum2); /* only added so many BASE's */
+ return adler | (sum2 << 16);
+ }
+
+ /* do length NMAX blocks -- requires just one modulo operation */
+ while (len >= NMAX) {
+ len -= NMAX;
+ n = NMAX / 16; /* NMAX is divisible by 16 */
+ do {
+ DO16(buf); /* 16 sums unrolled */
+ buf += 16;
+ } while (--n);
+ MOD(adler);
+ MOD(sum2);
+ }
+
+ /* do remaining bytes (less than NMAX, still just one modulo) */
+ if (len) { /* avoid modulos if none remaining */
+ while (len >= 16) {
+ len -= 16;
+ DO16(buf);
+ buf += 16;
+ }
+ while (len--) {
+ adler += *buf++;
+ sum2 += adler;
+ }
+ MOD(adler);
+ MOD(sum2);
+ }
+
+ /* return recombined sums */
+ return adler | (sum2 << 16);
+}
+
+/* ========================================================================= */
+uLong ZEXPORT adler32(adler, buf, len)
+ uLong adler;
+ const Bytef *buf;
+ uInt len;
+{
+ return adler32_z(adler, buf, len);
+}
+
+/* ========================================================================= */
+local uLong adler32_combine_(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off64_t len2;
+{
+ unsigned long sum1;
+ unsigned long sum2;
+ unsigned rem;
+
+ /* for negative len, return invalid adler32 as a clue for debugging */
+ if (len2 < 0)
+ return 0xffffffffUL;
+
+ /* the derivation of this formula is left as an exercise for the reader */
+ MOD63(len2); /* assumes len2 >= 0 */
+ rem = (unsigned)len2;
+ sum1 = adler1 & 0xffff;
+ sum2 = rem * sum1;
+ MOD(sum2);
+ sum1 += (adler2 & 0xffff) + BASE - 1;
+ sum2 += ((adler1 >> 16) & 0xffff) + ((adler2 >> 16) & 0xffff) + BASE - rem;
+ if (sum1 >= BASE) sum1 -= BASE;
+ if (sum1 >= BASE) sum1 -= BASE;
+ if (sum2 >= ((unsigned long)BASE << 1)) sum2 -= ((unsigned long)BASE << 1);
+ if (sum2 >= BASE) sum2 -= BASE;
+ return sum1 | (sum2 << 16);
+}
+
+/* ========================================================================= */
+uLong ZEXPORT adler32_combine(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off_t len2;
+{
+ return adler32_combine_(adler1, adler2, len2);
+}
+
+uLong ZEXPORT adler32_combine64(adler1, adler2, len2)
+ uLong adler1;
+ uLong adler2;
+ z_off64_t len2;
+{
+ return adler32_combine_(adler1, adler2, len2);
+}
diff --git a/test/monniaux/zlib-1.2.11/compress.c b/test/monniaux/zlib-1.2.11/compress.c
new file mode 100644
index 00000000..e2db404a
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/compress.c
@@ -0,0 +1,86 @@
+/* compress.c -- compress a memory buffer
+ * Copyright (C) 1995-2005, 2014, 2016 Jean-loup Gailly, Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#define ZLIB_INTERNAL
+#include "zlib.h"
+
+/* ===========================================================================
+ Compresses the source buffer into the destination buffer. The level
+ parameter has the same meaning as in deflateInit. sourceLen is the byte
+ length of the source buffer. Upon entry, destLen is the total size of the
+ destination buffer, which must be at least 0.1% larger than sourceLen plus
+ 12 bytes. Upon exit, destLen is the actual size of the compressed buffer.
+
+ compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+ Z_STREAM_ERROR if the level parameter is invalid.
+*/
+int ZEXPORT compress2 (dest, destLen, source, sourceLen, level)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+ int level;
+{
+ z_stream stream;
+ int err;
+ const uInt max = (uInt)-1;
+ uLong left;
+
+ left = *destLen;
+ *destLen = 0;
+
+ stream.zalloc = (alloc_func)0;
+ stream.zfree = (free_func)0;
+ stream.opaque = (voidpf)0;
+
+ err = deflateInit(&stream, level);
+ if (err != Z_OK) return err;
+
+ stream.next_out = dest;
+ stream.avail_out = 0;
+ stream.next_in = (z_const Bytef *)source;
+ stream.avail_in = 0;
+
+ do {
+ if (stream.avail_out == 0) {
+ stream.avail_out = left > (uLong)max ? max : (uInt)left;
+ left -= stream.avail_out;
+ }
+ if (stream.avail_in == 0) {
+ stream.avail_in = sourceLen > (uLong)max ? max : (uInt)sourceLen;
+ sourceLen -= stream.avail_in;
+ }
+ err = deflate(&stream, sourceLen ? Z_NO_FLUSH : Z_FINISH);
+ } while (err == Z_OK);
+
+ *destLen = stream.total_out;
+ deflateEnd(&stream);
+ return err == Z_STREAM_END ? Z_OK : err;
+}
+
+/* ===========================================================================
+ */
+int ZEXPORT compress (dest, destLen, source, sourceLen)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+{
+ return compress2(dest, destLen, source, sourceLen, Z_DEFAULT_COMPRESSION);
+}
+
+/* ===========================================================================
+ If the default memLevel or windowBits for deflateInit() is changed, then
+ this function needs to be updated.
+ */
+uLong ZEXPORT compressBound (sourceLen)
+ uLong sourceLen;
+{
+ return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) +
+ (sourceLen >> 25) + 13;
+}
diff --git a/test/monniaux/zlib-1.2.11/crc32.c b/test/monniaux/zlib-1.2.11/crc32.c
new file mode 100644
index 00000000..9580440c
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/crc32.c
@@ -0,0 +1,442 @@
+/* crc32.c -- compute the CRC-32 of a data stream
+ * Copyright (C) 1995-2006, 2010, 2011, 2012, 2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ *
+ * Thanks to Rodney Brown <rbrown64@csc.com.au> for his contribution of faster
+ * CRC methods: exclusive-oring 32 bits of data at a time, and pre-computing
+ * tables for updating the shift register in one step with three exclusive-ors
+ * instead of four steps with four exclusive-ors. This results in about a
+ * factor of two increase in speed on a Power PC G4 (PPC7455) using gcc -O3.
+ */
+
+/* @(#) $Id$ */
+
+/*
+ Note on the use of DYNAMIC_CRC_TABLE: there is no mutex or semaphore
+ protection on the static variables used to control the first-use generation
+ of the crc tables. Therefore, if you #define DYNAMIC_CRC_TABLE, you should
+ first call get_crc_table() to initialize the tables before allowing more than
+ one thread to use crc32().
+
+ DYNAMIC_CRC_TABLE and MAKECRCH can be #defined to write out crc32.h.
+ */
+
+#ifdef MAKECRCH
+# include <stdio.h>
+# ifndef DYNAMIC_CRC_TABLE
+# define DYNAMIC_CRC_TABLE
+# endif /* !DYNAMIC_CRC_TABLE */
+#endif /* MAKECRCH */
+
+#include "zutil.h" /* for STDC and FAR definitions */
+
+/* Definitions for doing the crc four data bytes at a time. */
+#if !defined(NOBYFOUR) && defined(Z_U4)
+# define BYFOUR
+#endif
+#ifdef BYFOUR
+ local unsigned long crc32_little OF((unsigned long,
+ const unsigned char FAR *, z_size_t));
+ local unsigned long crc32_big OF((unsigned long,
+ const unsigned char FAR *, z_size_t));
+# define TBLS 8
+#else
+# define TBLS 1
+#endif /* BYFOUR */
+
+/* Local functions for crc concatenation */
+local unsigned long gf2_matrix_times OF((unsigned long *mat,
+ unsigned long vec));
+local void gf2_matrix_square OF((unsigned long *square, unsigned long *mat));
+local uLong crc32_combine_ OF((uLong crc1, uLong crc2, z_off64_t len2));
+
+
+#ifdef DYNAMIC_CRC_TABLE
+
+local volatile int crc_table_empty = 1;
+local z_crc_t FAR crc_table[TBLS][256];
+local void make_crc_table OF((void));
+#ifdef MAKECRCH
+ local void write_table OF((FILE *, const z_crc_t FAR *));
+#endif /* MAKECRCH */
+/*
+ Generate tables for a byte-wise 32-bit CRC calculation on the polynomial:
+ x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x+1.
+
+ Polynomials over GF(2) are represented in binary, one bit per coefficient,
+ with the lowest powers in the most significant bit. Then adding polynomials
+ is just exclusive-or, and multiplying a polynomial by x is a right shift by
+ one. If we call the above polynomial p, and represent a byte as the
+ polynomial q, also with the lowest power in the most significant bit (so the
+ byte 0xb1 is the polynomial x^7+x^3+x+1), then the CRC is (q*x^32) mod p,
+ where a mod b means the remainder after dividing a by b.
+
+ This calculation is done using the shift-register method of multiplying and
+ taking the remainder. The register is initialized to zero, and for each
+ incoming bit, x^32 is added mod p to the register if the bit is a one (where
+ x^32 mod p is p+x^32 = x^26+...+1), and the register is multiplied mod p by
+ x (which is shifting right by one and adding x^32 mod p if the bit shifted
+ out is a one). We start with the highest power (least significant bit) of
+ q and repeat for all eight bits of q.
+
+ The first table is simply the CRC of all possible eight bit values. This is
+ all the information needed to generate CRCs on data a byte at a time for all
+ combinations of CRC register values and incoming bytes. The remaining tables
+ allow for word-at-a-time CRC calculation for both big-endian and little-
+ endian machines, where a word is four bytes.
+*/
+local void make_crc_table()
+{
+ z_crc_t c;
+ int n, k;
+ z_crc_t poly; /* polynomial exclusive-or pattern */
+ /* terms of polynomial defining this crc (except x^32): */
+ static volatile int first = 1; /* flag to limit concurrent making */
+ static const unsigned char p[] = {0,1,2,4,5,7,8,10,11,12,16,22,23,26};
+
+ /* See if another task is already doing this (not thread-safe, but better
+ than nothing -- significantly reduces duration of vulnerability in
+ case the advice about DYNAMIC_CRC_TABLE is ignored) */
+ if (first) {
+ first = 0;
+
+ /* make exclusive-or pattern from polynomial (0xedb88320UL) */
+ poly = 0;
+ for (n = 0; n < (int)(sizeof(p)/sizeof(unsigned char)); n++)
+ poly |= (z_crc_t)1 << (31 - p[n]);
+
+ /* generate a crc for every 8-bit value */
+ for (n = 0; n < 256; n++) {
+ c = (z_crc_t)n;
+ for (k = 0; k < 8; k++)
+ c = c & 1 ? poly ^ (c >> 1) : c >> 1;
+ crc_table[0][n] = c;
+ }
+
+#ifdef BYFOUR
+ /* generate crc for each value followed by one, two, and three zeros,
+ and then the byte reversal of those as well as the first table */
+ for (n = 0; n < 256; n++) {
+ c = crc_table[0][n];
+ crc_table[4][n] = ZSWAP32(c);
+ for (k = 1; k < 4; k++) {
+ c = crc_table[0][c & 0xff] ^ (c >> 8);
+ crc_table[k][n] = c;
+ crc_table[k + 4][n] = ZSWAP32(c);
+ }
+ }
+#endif /* BYFOUR */
+
+ crc_table_empty = 0;
+ }
+ else { /* not first */
+ /* wait for the other guy to finish (not efficient, but rare) */
+ while (crc_table_empty)
+ ;
+ }
+
+#ifdef MAKECRCH
+ /* write out CRC tables to crc32.h */
+ {
+ FILE *out;
+
+ out = fopen("crc32.h", "w");
+ if (out == NULL) return;
+ fprintf(out, "/* crc32.h -- tables for rapid CRC calculation\n");
+ fprintf(out, " * Generated automatically by crc32.c\n */\n\n");
+ fprintf(out, "local const z_crc_t FAR ");
+ fprintf(out, "crc_table[TBLS][256] =\n{\n {\n");
+ write_table(out, crc_table[0]);
+# ifdef BYFOUR
+ fprintf(out, "#ifdef BYFOUR\n");
+ for (k = 1; k < 8; k++) {
+ fprintf(out, " },\n {\n");
+ write_table(out, crc_table[k]);
+ }
+ fprintf(out, "#endif\n");
+# endif /* BYFOUR */
+ fprintf(out, " }\n};\n");
+ fclose(out);
+ }
+#endif /* MAKECRCH */
+}
+
+#ifdef MAKECRCH
+local void write_table(out, table)
+ FILE *out;
+ const z_crc_t FAR *table;
+{
+ int n;
+
+ for (n = 0; n < 256; n++)
+ fprintf(out, "%s0x%08lxUL%s", n % 5 ? "" : " ",
+ (unsigned long)(table[n]),
+ n == 255 ? "\n" : (n % 5 == 4 ? ",\n" : ", "));
+}
+#endif /* MAKECRCH */
+
+#else /* !DYNAMIC_CRC_TABLE */
+/* ========================================================================
+ * Tables of CRC-32s of all single-byte values, made by make_crc_table().
+ */
+#include "crc32.h"
+#endif /* DYNAMIC_CRC_TABLE */
+
+/* =========================================================================
+ * This function can be used by asm versions of crc32()
+ */
+const z_crc_t FAR * ZEXPORT get_crc_table()
+{
+#ifdef DYNAMIC_CRC_TABLE
+ if (crc_table_empty)
+ make_crc_table();
+#endif /* DYNAMIC_CRC_TABLE */
+ return (const z_crc_t FAR *)crc_table;
+}
+
+/* ========================================================================= */
+#define DO1 crc = crc_table[0][((int)crc ^ (*buf++)) & 0xff] ^ (crc >> 8)
+#define DO8 DO1; DO1; DO1; DO1; DO1; DO1; DO1; DO1
+
+/* ========================================================================= */
+unsigned long ZEXPORT crc32_z(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ z_size_t len;
+{
+ if (buf == Z_NULL) return 0UL;
+
+#ifdef DYNAMIC_CRC_TABLE
+ if (crc_table_empty)
+ make_crc_table();
+#endif /* DYNAMIC_CRC_TABLE */
+
+#ifdef BYFOUR
+ if (sizeof(void *) == sizeof(ptrdiff_t)) {
+ z_crc_t endian;
+
+ endian = 1;
+ if (*((unsigned char *)(&endian)))
+ return crc32_little(crc, buf, len);
+ else
+ return crc32_big(crc, buf, len);
+ }
+#endif /* BYFOUR */
+ crc = crc ^ 0xffffffffUL;
+ while (len >= 8) {
+ DO8;
+ len -= 8;
+ }
+ if (len) do {
+ DO1;
+ } while (--len);
+ return crc ^ 0xffffffffUL;
+}
+
+/* ========================================================================= */
+unsigned long ZEXPORT crc32(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ uInt len;
+{
+ return crc32_z(crc, buf, len);
+}
+
+#ifdef BYFOUR
+
+/*
+ This BYFOUR code accesses the passed unsigned char * buffer with a 32-bit
+ integer pointer type. This violates the strict aliasing rule, where a
+ compiler can assume, for optimization purposes, that two pointers to
+ fundamentally different types won't ever point to the same memory. This can
+ manifest as a problem only if one of the pointers is written to. This code
+ only reads from those pointers. So long as this code remains isolated in
+ this compilation unit, there won't be a problem. For this reason, this code
+ should not be copied and pasted into a compilation unit in which other code
+ writes to the buffer that is passed to these routines.
+ */
+
+/* ========================================================================= */
+#define DOLIT4 c ^= *buf4++; \
+ c = crc_table[3][c & 0xff] ^ crc_table[2][(c >> 8) & 0xff] ^ \
+ crc_table[1][(c >> 16) & 0xff] ^ crc_table[0][c >> 24]
+#define DOLIT32 DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4; DOLIT4
+
+/* ========================================================================= */
+local unsigned long crc32_little(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ z_size_t len;
+{
+ register z_crc_t c;
+ register const z_crc_t FAR *buf4;
+
+ c = (z_crc_t)crc;
+ c = ~c;
+ while (len && ((ptrdiff_t)buf & 3)) {
+ c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8);
+ len--;
+ }
+
+ buf4 = (const z_crc_t FAR *)(const void FAR *)buf;
+ while (len >= 32) {
+ DOLIT32;
+ len -= 32;
+ }
+ while (len >= 4) {
+ DOLIT4;
+ len -= 4;
+ }
+ buf = (const unsigned char FAR *)buf4;
+
+ if (len) do {
+ c = crc_table[0][(c ^ *buf++) & 0xff] ^ (c >> 8);
+ } while (--len);
+ c = ~c;
+ return (unsigned long)c;
+}
+
+/* ========================================================================= */
+#define DOBIG4 c ^= *buf4++; \
+ c = crc_table[4][c & 0xff] ^ crc_table[5][(c >> 8) & 0xff] ^ \
+ crc_table[6][(c >> 16) & 0xff] ^ crc_table[7][c >> 24]
+#define DOBIG32 DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4; DOBIG4
+
+/* ========================================================================= */
+local unsigned long crc32_big(crc, buf, len)
+ unsigned long crc;
+ const unsigned char FAR *buf;
+ z_size_t len;
+{
+ register z_crc_t c;
+ register const z_crc_t FAR *buf4;
+
+ c = ZSWAP32((z_crc_t)crc);
+ c = ~c;
+ while (len && ((ptrdiff_t)buf & 3)) {
+ c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8);
+ len--;
+ }
+
+ buf4 = (const z_crc_t FAR *)(const void FAR *)buf;
+ while (len >= 32) {
+ DOBIG32;
+ len -= 32;
+ }
+ while (len >= 4) {
+ DOBIG4;
+ len -= 4;
+ }
+ buf = (const unsigned char FAR *)buf4;
+
+ if (len) do {
+ c = crc_table[4][(c >> 24) ^ *buf++] ^ (c << 8);
+ } while (--len);
+ c = ~c;
+ return (unsigned long)(ZSWAP32(c));
+}
+
+#endif /* BYFOUR */
+
+#define GF2_DIM 32 /* dimension of GF(2) vectors (length of CRC) */
+
+/* ========================================================================= */
+local unsigned long gf2_matrix_times(mat, vec)
+ unsigned long *mat;
+ unsigned long vec;
+{
+ unsigned long sum;
+
+ sum = 0;
+ while (vec) {
+ if (vec & 1)
+ sum ^= *mat;
+ vec >>= 1;
+ mat++;
+ }
+ return sum;
+}
+
+/* ========================================================================= */
+local void gf2_matrix_square(square, mat)
+ unsigned long *square;
+ unsigned long *mat;
+{
+ int n;
+
+ for (n = 0; n < GF2_DIM; n++)
+ square[n] = gf2_matrix_times(mat, mat[n]);
+}
+
+/* ========================================================================= */
+local uLong crc32_combine_(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off64_t len2;
+{
+ int n;
+ unsigned long row;
+ unsigned long even[GF2_DIM]; /* even-power-of-two zeros operator */
+ unsigned long odd[GF2_DIM]; /* odd-power-of-two zeros operator */
+
+ /* degenerate case (also disallow negative lengths) */
+ if (len2 <= 0)
+ return crc1;
+
+ /* put operator for one zero bit in odd */
+ odd[0] = 0xedb88320UL; /* CRC-32 polynomial */
+ row = 1;
+ for (n = 1; n < GF2_DIM; n++) {
+ odd[n] = row;
+ row <<= 1;
+ }
+
+ /* put operator for two zero bits in even */
+ gf2_matrix_square(even, odd);
+
+ /* put operator for four zero bits in odd */
+ gf2_matrix_square(odd, even);
+
+ /* apply len2 zeros to crc1 (first square will put the operator for one
+ zero byte, eight zero bits, in even) */
+ do {
+ /* apply zeros operator for this bit of len2 */
+ gf2_matrix_square(even, odd);
+ if (len2 & 1)
+ crc1 = gf2_matrix_times(even, crc1);
+ len2 >>= 1;
+
+ /* if no more bits set, then done */
+ if (len2 == 0)
+ break;
+
+ /* another iteration of the loop with odd and even swapped */
+ gf2_matrix_square(odd, even);
+ if (len2 & 1)
+ crc1 = gf2_matrix_times(odd, crc1);
+ len2 >>= 1;
+
+ /* if no more bits set, then done */
+ } while (len2 != 0);
+
+ /* return combined crc */
+ crc1 ^= crc2;
+ return crc1;
+}
+
+/* ========================================================================= */
+uLong ZEXPORT crc32_combine(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off_t len2;
+{
+ return crc32_combine_(crc1, crc2, len2);
+}
+
+uLong ZEXPORT crc32_combine64(crc1, crc2, len2)
+ uLong crc1;
+ uLong crc2;
+ z_off64_t len2;
+{
+ return crc32_combine_(crc1, crc2, len2);
+}
diff --git a/test/monniaux/zlib-1.2.11/crc32.h b/test/monniaux/zlib-1.2.11/crc32.h
new file mode 100644
index 00000000..9e0c7781
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/crc32.h
@@ -0,0 +1,441 @@
+/* crc32.h -- tables for rapid CRC calculation
+ * Generated automatically by crc32.c
+ */
+
+local const z_crc_t FAR crc_table[TBLS][256] =
+{
+ {
+ 0x00000000UL, 0x77073096UL, 0xee0e612cUL, 0x990951baUL, 0x076dc419UL,
+ 0x706af48fUL, 0xe963a535UL, 0x9e6495a3UL, 0x0edb8832UL, 0x79dcb8a4UL,
+ 0xe0d5e91eUL, 0x97d2d988UL, 0x09b64c2bUL, 0x7eb17cbdUL, 0xe7b82d07UL,
+ 0x90bf1d91UL, 0x1db71064UL, 0x6ab020f2UL, 0xf3b97148UL, 0x84be41deUL,
+ 0x1adad47dUL, 0x6ddde4ebUL, 0xf4d4b551UL, 0x83d385c7UL, 0x136c9856UL,
+ 0x646ba8c0UL, 0xfd62f97aUL, 0x8a65c9ecUL, 0x14015c4fUL, 0x63066cd9UL,
+ 0xfa0f3d63UL, 0x8d080df5UL, 0x3b6e20c8UL, 0x4c69105eUL, 0xd56041e4UL,
+ 0xa2677172UL, 0x3c03e4d1UL, 0x4b04d447UL, 0xd20d85fdUL, 0xa50ab56bUL,
+ 0x35b5a8faUL, 0x42b2986cUL, 0xdbbbc9d6UL, 0xacbcf940UL, 0x32d86ce3UL,
+ 0x45df5c75UL, 0xdcd60dcfUL, 0xabd13d59UL, 0x26d930acUL, 0x51de003aUL,
+ 0xc8d75180UL, 0xbfd06116UL, 0x21b4f4b5UL, 0x56b3c423UL, 0xcfba9599UL,
+ 0xb8bda50fUL, 0x2802b89eUL, 0x5f058808UL, 0xc60cd9b2UL, 0xb10be924UL,
+ 0x2f6f7c87UL, 0x58684c11UL, 0xc1611dabUL, 0xb6662d3dUL, 0x76dc4190UL,
+ 0x01db7106UL, 0x98d220bcUL, 0xefd5102aUL, 0x71b18589UL, 0x06b6b51fUL,
+ 0x9fbfe4a5UL, 0xe8b8d433UL, 0x7807c9a2UL, 0x0f00f934UL, 0x9609a88eUL,
+ 0xe10e9818UL, 0x7f6a0dbbUL, 0x086d3d2dUL, 0x91646c97UL, 0xe6635c01UL,
+ 0x6b6b51f4UL, 0x1c6c6162UL, 0x856530d8UL, 0xf262004eUL, 0x6c0695edUL,
+ 0x1b01a57bUL, 0x8208f4c1UL, 0xf50fc457UL, 0x65b0d9c6UL, 0x12b7e950UL,
+ 0x8bbeb8eaUL, 0xfcb9887cUL, 0x62dd1ddfUL, 0x15da2d49UL, 0x8cd37cf3UL,
+ 0xfbd44c65UL, 0x4db26158UL, 0x3ab551ceUL, 0xa3bc0074UL, 0xd4bb30e2UL,
+ 0x4adfa541UL, 0x3dd895d7UL, 0xa4d1c46dUL, 0xd3d6f4fbUL, 0x4369e96aUL,
+ 0x346ed9fcUL, 0xad678846UL, 0xda60b8d0UL, 0x44042d73UL, 0x33031de5UL,
+ 0xaa0a4c5fUL, 0xdd0d7cc9UL, 0x5005713cUL, 0x270241aaUL, 0xbe0b1010UL,
+ 0xc90c2086UL, 0x5768b525UL, 0x206f85b3UL, 0xb966d409UL, 0xce61e49fUL,
+ 0x5edef90eUL, 0x29d9c998UL, 0xb0d09822UL, 0xc7d7a8b4UL, 0x59b33d17UL,
+ 0x2eb40d81UL, 0xb7bd5c3bUL, 0xc0ba6cadUL, 0xedb88320UL, 0x9abfb3b6UL,
+ 0x03b6e20cUL, 0x74b1d29aUL, 0xead54739UL, 0x9dd277afUL, 0x04db2615UL,
+ 0x73dc1683UL, 0xe3630b12UL, 0x94643b84UL, 0x0d6d6a3eUL, 0x7a6a5aa8UL,
+ 0xe40ecf0bUL, 0x9309ff9dUL, 0x0a00ae27UL, 0x7d079eb1UL, 0xf00f9344UL,
+ 0x8708a3d2UL, 0x1e01f268UL, 0x6906c2feUL, 0xf762575dUL, 0x806567cbUL,
+ 0x196c3671UL, 0x6e6b06e7UL, 0xfed41b76UL, 0x89d32be0UL, 0x10da7a5aUL,
+ 0x67dd4accUL, 0xf9b9df6fUL, 0x8ebeeff9UL, 0x17b7be43UL, 0x60b08ed5UL,
+ 0xd6d6a3e8UL, 0xa1d1937eUL, 0x38d8c2c4UL, 0x4fdff252UL, 0xd1bb67f1UL,
+ 0xa6bc5767UL, 0x3fb506ddUL, 0x48b2364bUL, 0xd80d2bdaUL, 0xaf0a1b4cUL,
+ 0x36034af6UL, 0x41047a60UL, 0xdf60efc3UL, 0xa867df55UL, 0x316e8eefUL,
+ 0x4669be79UL, 0xcb61b38cUL, 0xbc66831aUL, 0x256fd2a0UL, 0x5268e236UL,
+ 0xcc0c7795UL, 0xbb0b4703UL, 0x220216b9UL, 0x5505262fUL, 0xc5ba3bbeUL,
+ 0xb2bd0b28UL, 0x2bb45a92UL, 0x5cb36a04UL, 0xc2d7ffa7UL, 0xb5d0cf31UL,
+ 0x2cd99e8bUL, 0x5bdeae1dUL, 0x9b64c2b0UL, 0xec63f226UL, 0x756aa39cUL,
+ 0x026d930aUL, 0x9c0906a9UL, 0xeb0e363fUL, 0x72076785UL, 0x05005713UL,
+ 0x95bf4a82UL, 0xe2b87a14UL, 0x7bb12baeUL, 0x0cb61b38UL, 0x92d28e9bUL,
+ 0xe5d5be0dUL, 0x7cdcefb7UL, 0x0bdbdf21UL, 0x86d3d2d4UL, 0xf1d4e242UL,
+ 0x68ddb3f8UL, 0x1fda836eUL, 0x81be16cdUL, 0xf6b9265bUL, 0x6fb077e1UL,
+ 0x18b74777UL, 0x88085ae6UL, 0xff0f6a70UL, 0x66063bcaUL, 0x11010b5cUL,
+ 0x8f659effUL, 0xf862ae69UL, 0x616bffd3UL, 0x166ccf45UL, 0xa00ae278UL,
+ 0xd70dd2eeUL, 0x4e048354UL, 0x3903b3c2UL, 0xa7672661UL, 0xd06016f7UL,
+ 0x4969474dUL, 0x3e6e77dbUL, 0xaed16a4aUL, 0xd9d65adcUL, 0x40df0b66UL,
+ 0x37d83bf0UL, 0xa9bcae53UL, 0xdebb9ec5UL, 0x47b2cf7fUL, 0x30b5ffe9UL,
+ 0xbdbdf21cUL, 0xcabac28aUL, 0x53b39330UL, 0x24b4a3a6UL, 0xbad03605UL,
+ 0xcdd70693UL, 0x54de5729UL, 0x23d967bfUL, 0xb3667a2eUL, 0xc4614ab8UL,
+ 0x5d681b02UL, 0x2a6f2b94UL, 0xb40bbe37UL, 0xc30c8ea1UL, 0x5a05df1bUL,
+ 0x2d02ef8dUL
+#ifdef BYFOUR
+ },
+ {
+ 0x00000000UL, 0x191b3141UL, 0x32366282UL, 0x2b2d53c3UL, 0x646cc504UL,
+ 0x7d77f445UL, 0x565aa786UL, 0x4f4196c7UL, 0xc8d98a08UL, 0xd1c2bb49UL,
+ 0xfaefe88aUL, 0xe3f4d9cbUL, 0xacb54f0cUL, 0xb5ae7e4dUL, 0x9e832d8eUL,
+ 0x87981ccfUL, 0x4ac21251UL, 0x53d92310UL, 0x78f470d3UL, 0x61ef4192UL,
+ 0x2eaed755UL, 0x37b5e614UL, 0x1c98b5d7UL, 0x05838496UL, 0x821b9859UL,
+ 0x9b00a918UL, 0xb02dfadbUL, 0xa936cb9aUL, 0xe6775d5dUL, 0xff6c6c1cUL,
+ 0xd4413fdfUL, 0xcd5a0e9eUL, 0x958424a2UL, 0x8c9f15e3UL, 0xa7b24620UL,
+ 0xbea97761UL, 0xf1e8e1a6UL, 0xe8f3d0e7UL, 0xc3de8324UL, 0xdac5b265UL,
+ 0x5d5daeaaUL, 0x44469febUL, 0x6f6bcc28UL, 0x7670fd69UL, 0x39316baeUL,
+ 0x202a5aefUL, 0x0b07092cUL, 0x121c386dUL, 0xdf4636f3UL, 0xc65d07b2UL,
+ 0xed705471UL, 0xf46b6530UL, 0xbb2af3f7UL, 0xa231c2b6UL, 0x891c9175UL,
+ 0x9007a034UL, 0x179fbcfbUL, 0x0e848dbaUL, 0x25a9de79UL, 0x3cb2ef38UL,
+ 0x73f379ffUL, 0x6ae848beUL, 0x41c51b7dUL, 0x58de2a3cUL, 0xf0794f05UL,
+ 0xe9627e44UL, 0xc24f2d87UL, 0xdb541cc6UL, 0x94158a01UL, 0x8d0ebb40UL,
+ 0xa623e883UL, 0xbf38d9c2UL, 0x38a0c50dUL, 0x21bbf44cUL, 0x0a96a78fUL,
+ 0x138d96ceUL, 0x5ccc0009UL, 0x45d73148UL, 0x6efa628bUL, 0x77e153caUL,
+ 0xbabb5d54UL, 0xa3a06c15UL, 0x888d3fd6UL, 0x91960e97UL, 0xded79850UL,
+ 0xc7cca911UL, 0xece1fad2UL, 0xf5facb93UL, 0x7262d75cUL, 0x6b79e61dUL,
+ 0x4054b5deUL, 0x594f849fUL, 0x160e1258UL, 0x0f152319UL, 0x243870daUL,
+ 0x3d23419bUL, 0x65fd6ba7UL, 0x7ce65ae6UL, 0x57cb0925UL, 0x4ed03864UL,
+ 0x0191aea3UL, 0x188a9fe2UL, 0x33a7cc21UL, 0x2abcfd60UL, 0xad24e1afUL,
+ 0xb43fd0eeUL, 0x9f12832dUL, 0x8609b26cUL, 0xc94824abUL, 0xd05315eaUL,
+ 0xfb7e4629UL, 0xe2657768UL, 0x2f3f79f6UL, 0x362448b7UL, 0x1d091b74UL,
+ 0x04122a35UL, 0x4b53bcf2UL, 0x52488db3UL, 0x7965de70UL, 0x607eef31UL,
+ 0xe7e6f3feUL, 0xfefdc2bfUL, 0xd5d0917cUL, 0xcccba03dUL, 0x838a36faUL,
+ 0x9a9107bbUL, 0xb1bc5478UL, 0xa8a76539UL, 0x3b83984bUL, 0x2298a90aUL,
+ 0x09b5fac9UL, 0x10aecb88UL, 0x5fef5d4fUL, 0x46f46c0eUL, 0x6dd93fcdUL,
+ 0x74c20e8cUL, 0xf35a1243UL, 0xea412302UL, 0xc16c70c1UL, 0xd8774180UL,
+ 0x9736d747UL, 0x8e2de606UL, 0xa500b5c5UL, 0xbc1b8484UL, 0x71418a1aUL,
+ 0x685abb5bUL, 0x4377e898UL, 0x5a6cd9d9UL, 0x152d4f1eUL, 0x0c367e5fUL,
+ 0x271b2d9cUL, 0x3e001cddUL, 0xb9980012UL, 0xa0833153UL, 0x8bae6290UL,
+ 0x92b553d1UL, 0xddf4c516UL, 0xc4eff457UL, 0xefc2a794UL, 0xf6d996d5UL,
+ 0xae07bce9UL, 0xb71c8da8UL, 0x9c31de6bUL, 0x852aef2aUL, 0xca6b79edUL,
+ 0xd37048acUL, 0xf85d1b6fUL, 0xe1462a2eUL, 0x66de36e1UL, 0x7fc507a0UL,
+ 0x54e85463UL, 0x4df36522UL, 0x02b2f3e5UL, 0x1ba9c2a4UL, 0x30849167UL,
+ 0x299fa026UL, 0xe4c5aeb8UL, 0xfdde9ff9UL, 0xd6f3cc3aUL, 0xcfe8fd7bUL,
+ 0x80a96bbcUL, 0x99b25afdUL, 0xb29f093eUL, 0xab84387fUL, 0x2c1c24b0UL,
+ 0x350715f1UL, 0x1e2a4632UL, 0x07317773UL, 0x4870e1b4UL, 0x516bd0f5UL,
+ 0x7a468336UL, 0x635db277UL, 0xcbfad74eUL, 0xd2e1e60fUL, 0xf9ccb5ccUL,
+ 0xe0d7848dUL, 0xaf96124aUL, 0xb68d230bUL, 0x9da070c8UL, 0x84bb4189UL,
+ 0x03235d46UL, 0x1a386c07UL, 0x31153fc4UL, 0x280e0e85UL, 0x674f9842UL,
+ 0x7e54a903UL, 0x5579fac0UL, 0x4c62cb81UL, 0x8138c51fUL, 0x9823f45eUL,
+ 0xb30ea79dUL, 0xaa1596dcUL, 0xe554001bUL, 0xfc4f315aUL, 0xd7626299UL,
+ 0xce7953d8UL, 0x49e14f17UL, 0x50fa7e56UL, 0x7bd72d95UL, 0x62cc1cd4UL,
+ 0x2d8d8a13UL, 0x3496bb52UL, 0x1fbbe891UL, 0x06a0d9d0UL, 0x5e7ef3ecUL,
+ 0x4765c2adUL, 0x6c48916eUL, 0x7553a02fUL, 0x3a1236e8UL, 0x230907a9UL,
+ 0x0824546aUL, 0x113f652bUL, 0x96a779e4UL, 0x8fbc48a5UL, 0xa4911b66UL,
+ 0xbd8a2a27UL, 0xf2cbbce0UL, 0xebd08da1UL, 0xc0fdde62UL, 0xd9e6ef23UL,
+ 0x14bce1bdUL, 0x0da7d0fcUL, 0x268a833fUL, 0x3f91b27eUL, 0x70d024b9UL,
+ 0x69cb15f8UL, 0x42e6463bUL, 0x5bfd777aUL, 0xdc656bb5UL, 0xc57e5af4UL,
+ 0xee530937UL, 0xf7483876UL, 0xb809aeb1UL, 0xa1129ff0UL, 0x8a3fcc33UL,
+ 0x9324fd72UL
+ },
+ {
+ 0x00000000UL, 0x01c26a37UL, 0x0384d46eUL, 0x0246be59UL, 0x0709a8dcUL,
+ 0x06cbc2ebUL, 0x048d7cb2UL, 0x054f1685UL, 0x0e1351b8UL, 0x0fd13b8fUL,
+ 0x0d9785d6UL, 0x0c55efe1UL, 0x091af964UL, 0x08d89353UL, 0x0a9e2d0aUL,
+ 0x0b5c473dUL, 0x1c26a370UL, 0x1de4c947UL, 0x1fa2771eUL, 0x1e601d29UL,
+ 0x1b2f0bacUL, 0x1aed619bUL, 0x18abdfc2UL, 0x1969b5f5UL, 0x1235f2c8UL,
+ 0x13f798ffUL, 0x11b126a6UL, 0x10734c91UL, 0x153c5a14UL, 0x14fe3023UL,
+ 0x16b88e7aUL, 0x177ae44dUL, 0x384d46e0UL, 0x398f2cd7UL, 0x3bc9928eUL,
+ 0x3a0bf8b9UL, 0x3f44ee3cUL, 0x3e86840bUL, 0x3cc03a52UL, 0x3d025065UL,
+ 0x365e1758UL, 0x379c7d6fUL, 0x35dac336UL, 0x3418a901UL, 0x3157bf84UL,
+ 0x3095d5b3UL, 0x32d36beaUL, 0x331101ddUL, 0x246be590UL, 0x25a98fa7UL,
+ 0x27ef31feUL, 0x262d5bc9UL, 0x23624d4cUL, 0x22a0277bUL, 0x20e69922UL,
+ 0x2124f315UL, 0x2a78b428UL, 0x2bbade1fUL, 0x29fc6046UL, 0x283e0a71UL,
+ 0x2d711cf4UL, 0x2cb376c3UL, 0x2ef5c89aUL, 0x2f37a2adUL, 0x709a8dc0UL,
+ 0x7158e7f7UL, 0x731e59aeUL, 0x72dc3399UL, 0x7793251cUL, 0x76514f2bUL,
+ 0x7417f172UL, 0x75d59b45UL, 0x7e89dc78UL, 0x7f4bb64fUL, 0x7d0d0816UL,
+ 0x7ccf6221UL, 0x798074a4UL, 0x78421e93UL, 0x7a04a0caUL, 0x7bc6cafdUL,
+ 0x6cbc2eb0UL, 0x6d7e4487UL, 0x6f38fadeUL, 0x6efa90e9UL, 0x6bb5866cUL,
+ 0x6a77ec5bUL, 0x68315202UL, 0x69f33835UL, 0x62af7f08UL, 0x636d153fUL,
+ 0x612bab66UL, 0x60e9c151UL, 0x65a6d7d4UL, 0x6464bde3UL, 0x662203baUL,
+ 0x67e0698dUL, 0x48d7cb20UL, 0x4915a117UL, 0x4b531f4eUL, 0x4a917579UL,
+ 0x4fde63fcUL, 0x4e1c09cbUL, 0x4c5ab792UL, 0x4d98dda5UL, 0x46c49a98UL,
+ 0x4706f0afUL, 0x45404ef6UL, 0x448224c1UL, 0x41cd3244UL, 0x400f5873UL,
+ 0x4249e62aUL, 0x438b8c1dUL, 0x54f16850UL, 0x55330267UL, 0x5775bc3eUL,
+ 0x56b7d609UL, 0x53f8c08cUL, 0x523aaabbUL, 0x507c14e2UL, 0x51be7ed5UL,
+ 0x5ae239e8UL, 0x5b2053dfUL, 0x5966ed86UL, 0x58a487b1UL, 0x5deb9134UL,
+ 0x5c29fb03UL, 0x5e6f455aUL, 0x5fad2f6dUL, 0xe1351b80UL, 0xe0f771b7UL,
+ 0xe2b1cfeeUL, 0xe373a5d9UL, 0xe63cb35cUL, 0xe7fed96bUL, 0xe5b86732UL,
+ 0xe47a0d05UL, 0xef264a38UL, 0xeee4200fUL, 0xeca29e56UL, 0xed60f461UL,
+ 0xe82fe2e4UL, 0xe9ed88d3UL, 0xebab368aUL, 0xea695cbdUL, 0xfd13b8f0UL,
+ 0xfcd1d2c7UL, 0xfe976c9eUL, 0xff5506a9UL, 0xfa1a102cUL, 0xfbd87a1bUL,
+ 0xf99ec442UL, 0xf85cae75UL, 0xf300e948UL, 0xf2c2837fUL, 0xf0843d26UL,
+ 0xf1465711UL, 0xf4094194UL, 0xf5cb2ba3UL, 0xf78d95faUL, 0xf64fffcdUL,
+ 0xd9785d60UL, 0xd8ba3757UL, 0xdafc890eUL, 0xdb3ee339UL, 0xde71f5bcUL,
+ 0xdfb39f8bUL, 0xddf521d2UL, 0xdc374be5UL, 0xd76b0cd8UL, 0xd6a966efUL,
+ 0xd4efd8b6UL, 0xd52db281UL, 0xd062a404UL, 0xd1a0ce33UL, 0xd3e6706aUL,
+ 0xd2241a5dUL, 0xc55efe10UL, 0xc49c9427UL, 0xc6da2a7eUL, 0xc7184049UL,
+ 0xc25756ccUL, 0xc3953cfbUL, 0xc1d382a2UL, 0xc011e895UL, 0xcb4dafa8UL,
+ 0xca8fc59fUL, 0xc8c97bc6UL, 0xc90b11f1UL, 0xcc440774UL, 0xcd866d43UL,
+ 0xcfc0d31aUL, 0xce02b92dUL, 0x91af9640UL, 0x906dfc77UL, 0x922b422eUL,
+ 0x93e92819UL, 0x96a63e9cUL, 0x976454abUL, 0x9522eaf2UL, 0x94e080c5UL,
+ 0x9fbcc7f8UL, 0x9e7eadcfUL, 0x9c381396UL, 0x9dfa79a1UL, 0x98b56f24UL,
+ 0x99770513UL, 0x9b31bb4aUL, 0x9af3d17dUL, 0x8d893530UL, 0x8c4b5f07UL,
+ 0x8e0de15eUL, 0x8fcf8b69UL, 0x8a809decUL, 0x8b42f7dbUL, 0x89044982UL,
+ 0x88c623b5UL, 0x839a6488UL, 0x82580ebfUL, 0x801eb0e6UL, 0x81dcdad1UL,
+ 0x8493cc54UL, 0x8551a663UL, 0x8717183aUL, 0x86d5720dUL, 0xa9e2d0a0UL,
+ 0xa820ba97UL, 0xaa6604ceUL, 0xaba46ef9UL, 0xaeeb787cUL, 0xaf29124bUL,
+ 0xad6fac12UL, 0xacadc625UL, 0xa7f18118UL, 0xa633eb2fUL, 0xa4755576UL,
+ 0xa5b73f41UL, 0xa0f829c4UL, 0xa13a43f3UL, 0xa37cfdaaUL, 0xa2be979dUL,
+ 0xb5c473d0UL, 0xb40619e7UL, 0xb640a7beUL, 0xb782cd89UL, 0xb2cddb0cUL,
+ 0xb30fb13bUL, 0xb1490f62UL, 0xb08b6555UL, 0xbbd72268UL, 0xba15485fUL,
+ 0xb853f606UL, 0xb9919c31UL, 0xbcde8ab4UL, 0xbd1ce083UL, 0xbf5a5edaUL,
+ 0xbe9834edUL
+ },
+ {
+ 0x00000000UL, 0xb8bc6765UL, 0xaa09c88bUL, 0x12b5afeeUL, 0x8f629757UL,
+ 0x37def032UL, 0x256b5fdcUL, 0x9dd738b9UL, 0xc5b428efUL, 0x7d084f8aUL,
+ 0x6fbde064UL, 0xd7018701UL, 0x4ad6bfb8UL, 0xf26ad8ddUL, 0xe0df7733UL,
+ 0x58631056UL, 0x5019579fUL, 0xe8a530faUL, 0xfa109f14UL, 0x42acf871UL,
+ 0xdf7bc0c8UL, 0x67c7a7adUL, 0x75720843UL, 0xcdce6f26UL, 0x95ad7f70UL,
+ 0x2d111815UL, 0x3fa4b7fbUL, 0x8718d09eUL, 0x1acfe827UL, 0xa2738f42UL,
+ 0xb0c620acUL, 0x087a47c9UL, 0xa032af3eUL, 0x188ec85bUL, 0x0a3b67b5UL,
+ 0xb28700d0UL, 0x2f503869UL, 0x97ec5f0cUL, 0x8559f0e2UL, 0x3de59787UL,
+ 0x658687d1UL, 0xdd3ae0b4UL, 0xcf8f4f5aUL, 0x7733283fUL, 0xeae41086UL,
+ 0x525877e3UL, 0x40edd80dUL, 0xf851bf68UL, 0xf02bf8a1UL, 0x48979fc4UL,
+ 0x5a22302aUL, 0xe29e574fUL, 0x7f496ff6UL, 0xc7f50893UL, 0xd540a77dUL,
+ 0x6dfcc018UL, 0x359fd04eUL, 0x8d23b72bUL, 0x9f9618c5UL, 0x272a7fa0UL,
+ 0xbafd4719UL, 0x0241207cUL, 0x10f48f92UL, 0xa848e8f7UL, 0x9b14583dUL,
+ 0x23a83f58UL, 0x311d90b6UL, 0x89a1f7d3UL, 0x1476cf6aUL, 0xaccaa80fUL,
+ 0xbe7f07e1UL, 0x06c36084UL, 0x5ea070d2UL, 0xe61c17b7UL, 0xf4a9b859UL,
+ 0x4c15df3cUL, 0xd1c2e785UL, 0x697e80e0UL, 0x7bcb2f0eUL, 0xc377486bUL,
+ 0xcb0d0fa2UL, 0x73b168c7UL, 0x6104c729UL, 0xd9b8a04cUL, 0x446f98f5UL,
+ 0xfcd3ff90UL, 0xee66507eUL, 0x56da371bUL, 0x0eb9274dUL, 0xb6054028UL,
+ 0xa4b0efc6UL, 0x1c0c88a3UL, 0x81dbb01aUL, 0x3967d77fUL, 0x2bd27891UL,
+ 0x936e1ff4UL, 0x3b26f703UL, 0x839a9066UL, 0x912f3f88UL, 0x299358edUL,
+ 0xb4446054UL, 0x0cf80731UL, 0x1e4da8dfUL, 0xa6f1cfbaUL, 0xfe92dfecUL,
+ 0x462eb889UL, 0x549b1767UL, 0xec277002UL, 0x71f048bbUL, 0xc94c2fdeUL,
+ 0xdbf98030UL, 0x6345e755UL, 0x6b3fa09cUL, 0xd383c7f9UL, 0xc1366817UL,
+ 0x798a0f72UL, 0xe45d37cbUL, 0x5ce150aeUL, 0x4e54ff40UL, 0xf6e89825UL,
+ 0xae8b8873UL, 0x1637ef16UL, 0x048240f8UL, 0xbc3e279dUL, 0x21e91f24UL,
+ 0x99557841UL, 0x8be0d7afUL, 0x335cb0caUL, 0xed59b63bUL, 0x55e5d15eUL,
+ 0x47507eb0UL, 0xffec19d5UL, 0x623b216cUL, 0xda874609UL, 0xc832e9e7UL,
+ 0x708e8e82UL, 0x28ed9ed4UL, 0x9051f9b1UL, 0x82e4565fUL, 0x3a58313aUL,
+ 0xa78f0983UL, 0x1f336ee6UL, 0x0d86c108UL, 0xb53aa66dUL, 0xbd40e1a4UL,
+ 0x05fc86c1UL, 0x1749292fUL, 0xaff54e4aUL, 0x322276f3UL, 0x8a9e1196UL,
+ 0x982bbe78UL, 0x2097d91dUL, 0x78f4c94bUL, 0xc048ae2eUL, 0xd2fd01c0UL,
+ 0x6a4166a5UL, 0xf7965e1cUL, 0x4f2a3979UL, 0x5d9f9697UL, 0xe523f1f2UL,
+ 0x4d6b1905UL, 0xf5d77e60UL, 0xe762d18eUL, 0x5fdeb6ebUL, 0xc2098e52UL,
+ 0x7ab5e937UL, 0x680046d9UL, 0xd0bc21bcUL, 0x88df31eaUL, 0x3063568fUL,
+ 0x22d6f961UL, 0x9a6a9e04UL, 0x07bda6bdUL, 0xbf01c1d8UL, 0xadb46e36UL,
+ 0x15080953UL, 0x1d724e9aUL, 0xa5ce29ffUL, 0xb77b8611UL, 0x0fc7e174UL,
+ 0x9210d9cdUL, 0x2aacbea8UL, 0x38191146UL, 0x80a57623UL, 0xd8c66675UL,
+ 0x607a0110UL, 0x72cfaefeUL, 0xca73c99bUL, 0x57a4f122UL, 0xef189647UL,
+ 0xfdad39a9UL, 0x45115eccUL, 0x764dee06UL, 0xcef18963UL, 0xdc44268dUL,
+ 0x64f841e8UL, 0xf92f7951UL, 0x41931e34UL, 0x5326b1daUL, 0xeb9ad6bfUL,
+ 0xb3f9c6e9UL, 0x0b45a18cUL, 0x19f00e62UL, 0xa14c6907UL, 0x3c9b51beUL,
+ 0x842736dbUL, 0x96929935UL, 0x2e2efe50UL, 0x2654b999UL, 0x9ee8defcUL,
+ 0x8c5d7112UL, 0x34e11677UL, 0xa9362eceUL, 0x118a49abUL, 0x033fe645UL,
+ 0xbb838120UL, 0xe3e09176UL, 0x5b5cf613UL, 0x49e959fdUL, 0xf1553e98UL,
+ 0x6c820621UL, 0xd43e6144UL, 0xc68bceaaUL, 0x7e37a9cfUL, 0xd67f4138UL,
+ 0x6ec3265dUL, 0x7c7689b3UL, 0xc4caeed6UL, 0x591dd66fUL, 0xe1a1b10aUL,
+ 0xf3141ee4UL, 0x4ba87981UL, 0x13cb69d7UL, 0xab770eb2UL, 0xb9c2a15cUL,
+ 0x017ec639UL, 0x9ca9fe80UL, 0x241599e5UL, 0x36a0360bUL, 0x8e1c516eUL,
+ 0x866616a7UL, 0x3eda71c2UL, 0x2c6fde2cUL, 0x94d3b949UL, 0x090481f0UL,
+ 0xb1b8e695UL, 0xa30d497bUL, 0x1bb12e1eUL, 0x43d23e48UL, 0xfb6e592dUL,
+ 0xe9dbf6c3UL, 0x516791a6UL, 0xccb0a91fUL, 0x740cce7aUL, 0x66b96194UL,
+ 0xde0506f1UL
+ },
+ {
+ 0x00000000UL, 0x96300777UL, 0x2c610eeeUL, 0xba510999UL, 0x19c46d07UL,
+ 0x8ff46a70UL, 0x35a563e9UL, 0xa395649eUL, 0x3288db0eUL, 0xa4b8dc79UL,
+ 0x1ee9d5e0UL, 0x88d9d297UL, 0x2b4cb609UL, 0xbd7cb17eUL, 0x072db8e7UL,
+ 0x911dbf90UL, 0x6410b71dUL, 0xf220b06aUL, 0x4871b9f3UL, 0xde41be84UL,
+ 0x7dd4da1aUL, 0xebe4dd6dUL, 0x51b5d4f4UL, 0xc785d383UL, 0x56986c13UL,
+ 0xc0a86b64UL, 0x7af962fdUL, 0xecc9658aUL, 0x4f5c0114UL, 0xd96c0663UL,
+ 0x633d0ffaUL, 0xf50d088dUL, 0xc8206e3bUL, 0x5e10694cUL, 0xe44160d5UL,
+ 0x727167a2UL, 0xd1e4033cUL, 0x47d4044bUL, 0xfd850dd2UL, 0x6bb50aa5UL,
+ 0xfaa8b535UL, 0x6c98b242UL, 0xd6c9bbdbUL, 0x40f9bcacUL, 0xe36cd832UL,
+ 0x755cdf45UL, 0xcf0dd6dcUL, 0x593dd1abUL, 0xac30d926UL, 0x3a00de51UL,
+ 0x8051d7c8UL, 0x1661d0bfUL, 0xb5f4b421UL, 0x23c4b356UL, 0x9995bacfUL,
+ 0x0fa5bdb8UL, 0x9eb80228UL, 0x0888055fUL, 0xb2d90cc6UL, 0x24e90bb1UL,
+ 0x877c6f2fUL, 0x114c6858UL, 0xab1d61c1UL, 0x3d2d66b6UL, 0x9041dc76UL,
+ 0x0671db01UL, 0xbc20d298UL, 0x2a10d5efUL, 0x8985b171UL, 0x1fb5b606UL,
+ 0xa5e4bf9fUL, 0x33d4b8e8UL, 0xa2c90778UL, 0x34f9000fUL, 0x8ea80996UL,
+ 0x18980ee1UL, 0xbb0d6a7fUL, 0x2d3d6d08UL, 0x976c6491UL, 0x015c63e6UL,
+ 0xf4516b6bUL, 0x62616c1cUL, 0xd8306585UL, 0x4e0062f2UL, 0xed95066cUL,
+ 0x7ba5011bUL, 0xc1f40882UL, 0x57c40ff5UL, 0xc6d9b065UL, 0x50e9b712UL,
+ 0xeab8be8bUL, 0x7c88b9fcUL, 0xdf1ddd62UL, 0x492dda15UL, 0xf37cd38cUL,
+ 0x654cd4fbUL, 0x5861b24dUL, 0xce51b53aUL, 0x7400bca3UL, 0xe230bbd4UL,
+ 0x41a5df4aUL, 0xd795d83dUL, 0x6dc4d1a4UL, 0xfbf4d6d3UL, 0x6ae96943UL,
+ 0xfcd96e34UL, 0x468867adUL, 0xd0b860daUL, 0x732d0444UL, 0xe51d0333UL,
+ 0x5f4c0aaaUL, 0xc97c0dddUL, 0x3c710550UL, 0xaa410227UL, 0x10100bbeUL,
+ 0x86200cc9UL, 0x25b56857UL, 0xb3856f20UL, 0x09d466b9UL, 0x9fe461ceUL,
+ 0x0ef9de5eUL, 0x98c9d929UL, 0x2298d0b0UL, 0xb4a8d7c7UL, 0x173db359UL,
+ 0x810db42eUL, 0x3b5cbdb7UL, 0xad6cbac0UL, 0x2083b8edUL, 0xb6b3bf9aUL,
+ 0x0ce2b603UL, 0x9ad2b174UL, 0x3947d5eaUL, 0xaf77d29dUL, 0x1526db04UL,
+ 0x8316dc73UL, 0x120b63e3UL, 0x843b6494UL, 0x3e6a6d0dUL, 0xa85a6a7aUL,
+ 0x0bcf0ee4UL, 0x9dff0993UL, 0x27ae000aUL, 0xb19e077dUL, 0x44930ff0UL,
+ 0xd2a30887UL, 0x68f2011eUL, 0xfec20669UL, 0x5d5762f7UL, 0xcb676580UL,
+ 0x71366c19UL, 0xe7066b6eUL, 0x761bd4feUL, 0xe02bd389UL, 0x5a7ada10UL,
+ 0xcc4add67UL, 0x6fdfb9f9UL, 0xf9efbe8eUL, 0x43beb717UL, 0xd58eb060UL,
+ 0xe8a3d6d6UL, 0x7e93d1a1UL, 0xc4c2d838UL, 0x52f2df4fUL, 0xf167bbd1UL,
+ 0x6757bca6UL, 0xdd06b53fUL, 0x4b36b248UL, 0xda2b0dd8UL, 0x4c1b0aafUL,
+ 0xf64a0336UL, 0x607a0441UL, 0xc3ef60dfUL, 0x55df67a8UL, 0xef8e6e31UL,
+ 0x79be6946UL, 0x8cb361cbUL, 0x1a8366bcUL, 0xa0d26f25UL, 0x36e26852UL,
+ 0x95770cccUL, 0x03470bbbUL, 0xb9160222UL, 0x2f260555UL, 0xbe3bbac5UL,
+ 0x280bbdb2UL, 0x925ab42bUL, 0x046ab35cUL, 0xa7ffd7c2UL, 0x31cfd0b5UL,
+ 0x8b9ed92cUL, 0x1daede5bUL, 0xb0c2649bUL, 0x26f263ecUL, 0x9ca36a75UL,
+ 0x0a936d02UL, 0xa906099cUL, 0x3f360eebUL, 0x85670772UL, 0x13570005UL,
+ 0x824abf95UL, 0x147ab8e2UL, 0xae2bb17bUL, 0x381bb60cUL, 0x9b8ed292UL,
+ 0x0dbed5e5UL, 0xb7efdc7cUL, 0x21dfdb0bUL, 0xd4d2d386UL, 0x42e2d4f1UL,
+ 0xf8b3dd68UL, 0x6e83da1fUL, 0xcd16be81UL, 0x5b26b9f6UL, 0xe177b06fUL,
+ 0x7747b718UL, 0xe65a0888UL, 0x706a0fffUL, 0xca3b0666UL, 0x5c0b0111UL,
+ 0xff9e658fUL, 0x69ae62f8UL, 0xd3ff6b61UL, 0x45cf6c16UL, 0x78e20aa0UL,
+ 0xeed20dd7UL, 0x5483044eUL, 0xc2b30339UL, 0x612667a7UL, 0xf71660d0UL,
+ 0x4d476949UL, 0xdb776e3eUL, 0x4a6ad1aeUL, 0xdc5ad6d9UL, 0x660bdf40UL,
+ 0xf03bd837UL, 0x53aebca9UL, 0xc59ebbdeUL, 0x7fcfb247UL, 0xe9ffb530UL,
+ 0x1cf2bdbdUL, 0x8ac2bacaUL, 0x3093b353UL, 0xa6a3b424UL, 0x0536d0baUL,
+ 0x9306d7cdUL, 0x2957de54UL, 0xbf67d923UL, 0x2e7a66b3UL, 0xb84a61c4UL,
+ 0x021b685dUL, 0x942b6f2aUL, 0x37be0bb4UL, 0xa18e0cc3UL, 0x1bdf055aUL,
+ 0x8def022dUL
+ },
+ {
+ 0x00000000UL, 0x41311b19UL, 0x82623632UL, 0xc3532d2bUL, 0x04c56c64UL,
+ 0x45f4777dUL, 0x86a75a56UL, 0xc796414fUL, 0x088ad9c8UL, 0x49bbc2d1UL,
+ 0x8ae8effaUL, 0xcbd9f4e3UL, 0x0c4fb5acUL, 0x4d7eaeb5UL, 0x8e2d839eUL,
+ 0xcf1c9887UL, 0x5112c24aUL, 0x1023d953UL, 0xd370f478UL, 0x9241ef61UL,
+ 0x55d7ae2eUL, 0x14e6b537UL, 0xd7b5981cUL, 0x96848305UL, 0x59981b82UL,
+ 0x18a9009bUL, 0xdbfa2db0UL, 0x9acb36a9UL, 0x5d5d77e6UL, 0x1c6c6cffUL,
+ 0xdf3f41d4UL, 0x9e0e5acdUL, 0xa2248495UL, 0xe3159f8cUL, 0x2046b2a7UL,
+ 0x6177a9beUL, 0xa6e1e8f1UL, 0xe7d0f3e8UL, 0x2483dec3UL, 0x65b2c5daUL,
+ 0xaaae5d5dUL, 0xeb9f4644UL, 0x28cc6b6fUL, 0x69fd7076UL, 0xae6b3139UL,
+ 0xef5a2a20UL, 0x2c09070bUL, 0x6d381c12UL, 0xf33646dfUL, 0xb2075dc6UL,
+ 0x715470edUL, 0x30656bf4UL, 0xf7f32abbUL, 0xb6c231a2UL, 0x75911c89UL,
+ 0x34a00790UL, 0xfbbc9f17UL, 0xba8d840eUL, 0x79dea925UL, 0x38efb23cUL,
+ 0xff79f373UL, 0xbe48e86aUL, 0x7d1bc541UL, 0x3c2ade58UL, 0x054f79f0UL,
+ 0x447e62e9UL, 0x872d4fc2UL, 0xc61c54dbUL, 0x018a1594UL, 0x40bb0e8dUL,
+ 0x83e823a6UL, 0xc2d938bfUL, 0x0dc5a038UL, 0x4cf4bb21UL, 0x8fa7960aUL,
+ 0xce968d13UL, 0x0900cc5cUL, 0x4831d745UL, 0x8b62fa6eUL, 0xca53e177UL,
+ 0x545dbbbaUL, 0x156ca0a3UL, 0xd63f8d88UL, 0x970e9691UL, 0x5098d7deUL,
+ 0x11a9ccc7UL, 0xd2fae1ecUL, 0x93cbfaf5UL, 0x5cd76272UL, 0x1de6796bUL,
+ 0xdeb55440UL, 0x9f844f59UL, 0x58120e16UL, 0x1923150fUL, 0xda703824UL,
+ 0x9b41233dUL, 0xa76bfd65UL, 0xe65ae67cUL, 0x2509cb57UL, 0x6438d04eUL,
+ 0xa3ae9101UL, 0xe29f8a18UL, 0x21cca733UL, 0x60fdbc2aUL, 0xafe124adUL,
+ 0xeed03fb4UL, 0x2d83129fUL, 0x6cb20986UL, 0xab2448c9UL, 0xea1553d0UL,
+ 0x29467efbUL, 0x687765e2UL, 0xf6793f2fUL, 0xb7482436UL, 0x741b091dUL,
+ 0x352a1204UL, 0xf2bc534bUL, 0xb38d4852UL, 0x70de6579UL, 0x31ef7e60UL,
+ 0xfef3e6e7UL, 0xbfc2fdfeUL, 0x7c91d0d5UL, 0x3da0cbccUL, 0xfa368a83UL,
+ 0xbb07919aUL, 0x7854bcb1UL, 0x3965a7a8UL, 0x4b98833bUL, 0x0aa99822UL,
+ 0xc9fab509UL, 0x88cbae10UL, 0x4f5def5fUL, 0x0e6cf446UL, 0xcd3fd96dUL,
+ 0x8c0ec274UL, 0x43125af3UL, 0x022341eaUL, 0xc1706cc1UL, 0x804177d8UL,
+ 0x47d73697UL, 0x06e62d8eUL, 0xc5b500a5UL, 0x84841bbcUL, 0x1a8a4171UL,
+ 0x5bbb5a68UL, 0x98e87743UL, 0xd9d96c5aUL, 0x1e4f2d15UL, 0x5f7e360cUL,
+ 0x9c2d1b27UL, 0xdd1c003eUL, 0x120098b9UL, 0x533183a0UL, 0x9062ae8bUL,
+ 0xd153b592UL, 0x16c5f4ddUL, 0x57f4efc4UL, 0x94a7c2efUL, 0xd596d9f6UL,
+ 0xe9bc07aeUL, 0xa88d1cb7UL, 0x6bde319cUL, 0x2aef2a85UL, 0xed796bcaUL,
+ 0xac4870d3UL, 0x6f1b5df8UL, 0x2e2a46e1UL, 0xe136de66UL, 0xa007c57fUL,
+ 0x6354e854UL, 0x2265f34dUL, 0xe5f3b202UL, 0xa4c2a91bUL, 0x67918430UL,
+ 0x26a09f29UL, 0xb8aec5e4UL, 0xf99fdefdUL, 0x3accf3d6UL, 0x7bfde8cfUL,
+ 0xbc6ba980UL, 0xfd5ab299UL, 0x3e099fb2UL, 0x7f3884abUL, 0xb0241c2cUL,
+ 0xf1150735UL, 0x32462a1eUL, 0x73773107UL, 0xb4e17048UL, 0xf5d06b51UL,
+ 0x3683467aUL, 0x77b25d63UL, 0x4ed7facbUL, 0x0fe6e1d2UL, 0xccb5ccf9UL,
+ 0x8d84d7e0UL, 0x4a1296afUL, 0x0b238db6UL, 0xc870a09dUL, 0x8941bb84UL,
+ 0x465d2303UL, 0x076c381aUL, 0xc43f1531UL, 0x850e0e28UL, 0x42984f67UL,
+ 0x03a9547eUL, 0xc0fa7955UL, 0x81cb624cUL, 0x1fc53881UL, 0x5ef42398UL,
+ 0x9da70eb3UL, 0xdc9615aaUL, 0x1b0054e5UL, 0x5a314ffcUL, 0x996262d7UL,
+ 0xd85379ceUL, 0x174fe149UL, 0x567efa50UL, 0x952dd77bUL, 0xd41ccc62UL,
+ 0x138a8d2dUL, 0x52bb9634UL, 0x91e8bb1fUL, 0xd0d9a006UL, 0xecf37e5eUL,
+ 0xadc26547UL, 0x6e91486cUL, 0x2fa05375UL, 0xe836123aUL, 0xa9070923UL,
+ 0x6a542408UL, 0x2b653f11UL, 0xe479a796UL, 0xa548bc8fUL, 0x661b91a4UL,
+ 0x272a8abdUL, 0xe0bccbf2UL, 0xa18dd0ebUL, 0x62defdc0UL, 0x23efe6d9UL,
+ 0xbde1bc14UL, 0xfcd0a70dUL, 0x3f838a26UL, 0x7eb2913fUL, 0xb924d070UL,
+ 0xf815cb69UL, 0x3b46e642UL, 0x7a77fd5bUL, 0xb56b65dcUL, 0xf45a7ec5UL,
+ 0x370953eeUL, 0x763848f7UL, 0xb1ae09b8UL, 0xf09f12a1UL, 0x33cc3f8aUL,
+ 0x72fd2493UL
+ },
+ {
+ 0x00000000UL, 0x376ac201UL, 0x6ed48403UL, 0x59be4602UL, 0xdca80907UL,
+ 0xebc2cb06UL, 0xb27c8d04UL, 0x85164f05UL, 0xb851130eUL, 0x8f3bd10fUL,
+ 0xd685970dUL, 0xe1ef550cUL, 0x64f91a09UL, 0x5393d808UL, 0x0a2d9e0aUL,
+ 0x3d475c0bUL, 0x70a3261cUL, 0x47c9e41dUL, 0x1e77a21fUL, 0x291d601eUL,
+ 0xac0b2f1bUL, 0x9b61ed1aUL, 0xc2dfab18UL, 0xf5b56919UL, 0xc8f23512UL,
+ 0xff98f713UL, 0xa626b111UL, 0x914c7310UL, 0x145a3c15UL, 0x2330fe14UL,
+ 0x7a8eb816UL, 0x4de47a17UL, 0xe0464d38UL, 0xd72c8f39UL, 0x8e92c93bUL,
+ 0xb9f80b3aUL, 0x3cee443fUL, 0x0b84863eUL, 0x523ac03cUL, 0x6550023dUL,
+ 0x58175e36UL, 0x6f7d9c37UL, 0x36c3da35UL, 0x01a91834UL, 0x84bf5731UL,
+ 0xb3d59530UL, 0xea6bd332UL, 0xdd011133UL, 0x90e56b24UL, 0xa78fa925UL,
+ 0xfe31ef27UL, 0xc95b2d26UL, 0x4c4d6223UL, 0x7b27a022UL, 0x2299e620UL,
+ 0x15f32421UL, 0x28b4782aUL, 0x1fdeba2bUL, 0x4660fc29UL, 0x710a3e28UL,
+ 0xf41c712dUL, 0xc376b32cUL, 0x9ac8f52eUL, 0xada2372fUL, 0xc08d9a70UL,
+ 0xf7e75871UL, 0xae591e73UL, 0x9933dc72UL, 0x1c259377UL, 0x2b4f5176UL,
+ 0x72f11774UL, 0x459bd575UL, 0x78dc897eUL, 0x4fb64b7fUL, 0x16080d7dUL,
+ 0x2162cf7cUL, 0xa4748079UL, 0x931e4278UL, 0xcaa0047aUL, 0xfdcac67bUL,
+ 0xb02ebc6cUL, 0x87447e6dUL, 0xdefa386fUL, 0xe990fa6eUL, 0x6c86b56bUL,
+ 0x5bec776aUL, 0x02523168UL, 0x3538f369UL, 0x087faf62UL, 0x3f156d63UL,
+ 0x66ab2b61UL, 0x51c1e960UL, 0xd4d7a665UL, 0xe3bd6464UL, 0xba032266UL,
+ 0x8d69e067UL, 0x20cbd748UL, 0x17a11549UL, 0x4e1f534bUL, 0x7975914aUL,
+ 0xfc63de4fUL, 0xcb091c4eUL, 0x92b75a4cUL, 0xa5dd984dUL, 0x989ac446UL,
+ 0xaff00647UL, 0xf64e4045UL, 0xc1248244UL, 0x4432cd41UL, 0x73580f40UL,
+ 0x2ae64942UL, 0x1d8c8b43UL, 0x5068f154UL, 0x67023355UL, 0x3ebc7557UL,
+ 0x09d6b756UL, 0x8cc0f853UL, 0xbbaa3a52UL, 0xe2147c50UL, 0xd57ebe51UL,
+ 0xe839e25aUL, 0xdf53205bUL, 0x86ed6659UL, 0xb187a458UL, 0x3491eb5dUL,
+ 0x03fb295cUL, 0x5a456f5eUL, 0x6d2fad5fUL, 0x801b35e1UL, 0xb771f7e0UL,
+ 0xeecfb1e2UL, 0xd9a573e3UL, 0x5cb33ce6UL, 0x6bd9fee7UL, 0x3267b8e5UL,
+ 0x050d7ae4UL, 0x384a26efUL, 0x0f20e4eeUL, 0x569ea2ecUL, 0x61f460edUL,
+ 0xe4e22fe8UL, 0xd388ede9UL, 0x8a36abebUL, 0xbd5c69eaUL, 0xf0b813fdUL,
+ 0xc7d2d1fcUL, 0x9e6c97feUL, 0xa90655ffUL, 0x2c101afaUL, 0x1b7ad8fbUL,
+ 0x42c49ef9UL, 0x75ae5cf8UL, 0x48e900f3UL, 0x7f83c2f2UL, 0x263d84f0UL,
+ 0x115746f1UL, 0x944109f4UL, 0xa32bcbf5UL, 0xfa958df7UL, 0xcdff4ff6UL,
+ 0x605d78d9UL, 0x5737bad8UL, 0x0e89fcdaUL, 0x39e33edbUL, 0xbcf571deUL,
+ 0x8b9fb3dfUL, 0xd221f5ddUL, 0xe54b37dcUL, 0xd80c6bd7UL, 0xef66a9d6UL,
+ 0xb6d8efd4UL, 0x81b22dd5UL, 0x04a462d0UL, 0x33cea0d1UL, 0x6a70e6d3UL,
+ 0x5d1a24d2UL, 0x10fe5ec5UL, 0x27949cc4UL, 0x7e2adac6UL, 0x494018c7UL,
+ 0xcc5657c2UL, 0xfb3c95c3UL, 0xa282d3c1UL, 0x95e811c0UL, 0xa8af4dcbUL,
+ 0x9fc58fcaUL, 0xc67bc9c8UL, 0xf1110bc9UL, 0x740744ccUL, 0x436d86cdUL,
+ 0x1ad3c0cfUL, 0x2db902ceUL, 0x4096af91UL, 0x77fc6d90UL, 0x2e422b92UL,
+ 0x1928e993UL, 0x9c3ea696UL, 0xab546497UL, 0xf2ea2295UL, 0xc580e094UL,
+ 0xf8c7bc9fUL, 0xcfad7e9eUL, 0x9613389cUL, 0xa179fa9dUL, 0x246fb598UL,
+ 0x13057799UL, 0x4abb319bUL, 0x7dd1f39aUL, 0x3035898dUL, 0x075f4b8cUL,
+ 0x5ee10d8eUL, 0x698bcf8fUL, 0xec9d808aUL, 0xdbf7428bUL, 0x82490489UL,
+ 0xb523c688UL, 0x88649a83UL, 0xbf0e5882UL, 0xe6b01e80UL, 0xd1dadc81UL,
+ 0x54cc9384UL, 0x63a65185UL, 0x3a181787UL, 0x0d72d586UL, 0xa0d0e2a9UL,
+ 0x97ba20a8UL, 0xce0466aaUL, 0xf96ea4abUL, 0x7c78ebaeUL, 0x4b1229afUL,
+ 0x12ac6fadUL, 0x25c6adacUL, 0x1881f1a7UL, 0x2feb33a6UL, 0x765575a4UL,
+ 0x413fb7a5UL, 0xc429f8a0UL, 0xf3433aa1UL, 0xaafd7ca3UL, 0x9d97bea2UL,
+ 0xd073c4b5UL, 0xe71906b4UL, 0xbea740b6UL, 0x89cd82b7UL, 0x0cdbcdb2UL,
+ 0x3bb10fb3UL, 0x620f49b1UL, 0x55658bb0UL, 0x6822d7bbUL, 0x5f4815baUL,
+ 0x06f653b8UL, 0x319c91b9UL, 0xb48adebcUL, 0x83e01cbdUL, 0xda5e5abfUL,
+ 0xed3498beUL
+ },
+ {
+ 0x00000000UL, 0x6567bcb8UL, 0x8bc809aaUL, 0xeeafb512UL, 0x5797628fUL,
+ 0x32f0de37UL, 0xdc5f6b25UL, 0xb938d79dUL, 0xef28b4c5UL, 0x8a4f087dUL,
+ 0x64e0bd6fUL, 0x018701d7UL, 0xb8bfd64aUL, 0xddd86af2UL, 0x3377dfe0UL,
+ 0x56106358UL, 0x9f571950UL, 0xfa30a5e8UL, 0x149f10faUL, 0x71f8ac42UL,
+ 0xc8c07bdfUL, 0xada7c767UL, 0x43087275UL, 0x266fcecdUL, 0x707fad95UL,
+ 0x1518112dUL, 0xfbb7a43fUL, 0x9ed01887UL, 0x27e8cf1aUL, 0x428f73a2UL,
+ 0xac20c6b0UL, 0xc9477a08UL, 0x3eaf32a0UL, 0x5bc88e18UL, 0xb5673b0aUL,
+ 0xd00087b2UL, 0x6938502fUL, 0x0c5fec97UL, 0xe2f05985UL, 0x8797e53dUL,
+ 0xd1878665UL, 0xb4e03addUL, 0x5a4f8fcfUL, 0x3f283377UL, 0x8610e4eaUL,
+ 0xe3775852UL, 0x0dd8ed40UL, 0x68bf51f8UL, 0xa1f82bf0UL, 0xc49f9748UL,
+ 0x2a30225aUL, 0x4f579ee2UL, 0xf66f497fUL, 0x9308f5c7UL, 0x7da740d5UL,
+ 0x18c0fc6dUL, 0x4ed09f35UL, 0x2bb7238dUL, 0xc518969fUL, 0xa07f2a27UL,
+ 0x1947fdbaUL, 0x7c204102UL, 0x928ff410UL, 0xf7e848a8UL, 0x3d58149bUL,
+ 0x583fa823UL, 0xb6901d31UL, 0xd3f7a189UL, 0x6acf7614UL, 0x0fa8caacUL,
+ 0xe1077fbeUL, 0x8460c306UL, 0xd270a05eUL, 0xb7171ce6UL, 0x59b8a9f4UL,
+ 0x3cdf154cUL, 0x85e7c2d1UL, 0xe0807e69UL, 0x0e2fcb7bUL, 0x6b4877c3UL,
+ 0xa20f0dcbUL, 0xc768b173UL, 0x29c70461UL, 0x4ca0b8d9UL, 0xf5986f44UL,
+ 0x90ffd3fcUL, 0x7e5066eeUL, 0x1b37da56UL, 0x4d27b90eUL, 0x284005b6UL,
+ 0xc6efb0a4UL, 0xa3880c1cUL, 0x1ab0db81UL, 0x7fd76739UL, 0x9178d22bUL,
+ 0xf41f6e93UL, 0x03f7263bUL, 0x66909a83UL, 0x883f2f91UL, 0xed589329UL,
+ 0x546044b4UL, 0x3107f80cUL, 0xdfa84d1eUL, 0xbacff1a6UL, 0xecdf92feUL,
+ 0x89b82e46UL, 0x67179b54UL, 0x027027ecUL, 0xbb48f071UL, 0xde2f4cc9UL,
+ 0x3080f9dbUL, 0x55e74563UL, 0x9ca03f6bUL, 0xf9c783d3UL, 0x176836c1UL,
+ 0x720f8a79UL, 0xcb375de4UL, 0xae50e15cUL, 0x40ff544eUL, 0x2598e8f6UL,
+ 0x73888baeUL, 0x16ef3716UL, 0xf8408204UL, 0x9d273ebcUL, 0x241fe921UL,
+ 0x41785599UL, 0xafd7e08bUL, 0xcab05c33UL, 0x3bb659edUL, 0x5ed1e555UL,
+ 0xb07e5047UL, 0xd519ecffUL, 0x6c213b62UL, 0x094687daUL, 0xe7e932c8UL,
+ 0x828e8e70UL, 0xd49eed28UL, 0xb1f95190UL, 0x5f56e482UL, 0x3a31583aUL,
+ 0x83098fa7UL, 0xe66e331fUL, 0x08c1860dUL, 0x6da63ab5UL, 0xa4e140bdUL,
+ 0xc186fc05UL, 0x2f294917UL, 0x4a4ef5afUL, 0xf3762232UL, 0x96119e8aUL,
+ 0x78be2b98UL, 0x1dd99720UL, 0x4bc9f478UL, 0x2eae48c0UL, 0xc001fdd2UL,
+ 0xa566416aUL, 0x1c5e96f7UL, 0x79392a4fUL, 0x97969f5dUL, 0xf2f123e5UL,
+ 0x05196b4dUL, 0x607ed7f5UL, 0x8ed162e7UL, 0xebb6de5fUL, 0x528e09c2UL,
+ 0x37e9b57aUL, 0xd9460068UL, 0xbc21bcd0UL, 0xea31df88UL, 0x8f566330UL,
+ 0x61f9d622UL, 0x049e6a9aUL, 0xbda6bd07UL, 0xd8c101bfUL, 0x366eb4adUL,
+ 0x53090815UL, 0x9a4e721dUL, 0xff29cea5UL, 0x11867bb7UL, 0x74e1c70fUL,
+ 0xcdd91092UL, 0xa8beac2aUL, 0x46111938UL, 0x2376a580UL, 0x7566c6d8UL,
+ 0x10017a60UL, 0xfeaecf72UL, 0x9bc973caUL, 0x22f1a457UL, 0x479618efUL,
+ 0xa939adfdUL, 0xcc5e1145UL, 0x06ee4d76UL, 0x6389f1ceUL, 0x8d2644dcUL,
+ 0xe841f864UL, 0x51792ff9UL, 0x341e9341UL, 0xdab12653UL, 0xbfd69aebUL,
+ 0xe9c6f9b3UL, 0x8ca1450bUL, 0x620ef019UL, 0x07694ca1UL, 0xbe519b3cUL,
+ 0xdb362784UL, 0x35999296UL, 0x50fe2e2eUL, 0x99b95426UL, 0xfcdee89eUL,
+ 0x12715d8cUL, 0x7716e134UL, 0xce2e36a9UL, 0xab498a11UL, 0x45e63f03UL,
+ 0x208183bbUL, 0x7691e0e3UL, 0x13f65c5bUL, 0xfd59e949UL, 0x983e55f1UL,
+ 0x2106826cUL, 0x44613ed4UL, 0xaace8bc6UL, 0xcfa9377eUL, 0x38417fd6UL,
+ 0x5d26c36eUL, 0xb389767cUL, 0xd6eecac4UL, 0x6fd61d59UL, 0x0ab1a1e1UL,
+ 0xe41e14f3UL, 0x8179a84bUL, 0xd769cb13UL, 0xb20e77abUL, 0x5ca1c2b9UL,
+ 0x39c67e01UL, 0x80fea99cUL, 0xe5991524UL, 0x0b36a036UL, 0x6e511c8eUL,
+ 0xa7166686UL, 0xc271da3eUL, 0x2cde6f2cUL, 0x49b9d394UL, 0xf0810409UL,
+ 0x95e6b8b1UL, 0x7b490da3UL, 0x1e2eb11bUL, 0x483ed243UL, 0x2d596efbUL,
+ 0xc3f6dbe9UL, 0xa6916751UL, 0x1fa9b0ccUL, 0x7ace0c74UL, 0x9461b966UL,
+ 0xf10605deUL
+#endif
+ }
+};
diff --git a/test/monniaux/zlib-1.2.11/deflate.c b/test/monniaux/zlib-1.2.11/deflate.c
new file mode 100644
index 00000000..1ec76144
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/deflate.c
@@ -0,0 +1,2163 @@
+/* deflate.c -- compress data using the deflation algorithm
+ * Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * ALGORITHM
+ *
+ * The "deflation" process depends on being able to identify portions
+ * of the input text which are identical to earlier input (within a
+ * sliding window trailing behind the input currently being processed).
+ *
+ * The most straightforward technique turns out to be the fastest for
+ * most input files: try all possible matches and select the longest.
+ * The key feature of this algorithm is that insertions into the string
+ * dictionary are very simple and thus fast, and deletions are avoided
+ * completely. Insertions are performed at each input character, whereas
+ * string matches are performed only when the previous match ends. So it
+ * is preferable to spend more time in matches to allow very fast string
+ * insertions and avoid deletions. The matching algorithm for small
+ * strings is inspired from that of Rabin & Karp. A brute force approach
+ * is used to find longer strings when a small match has been found.
+ * A similar algorithm is used in comic (by Jan-Mark Wams) and freeze
+ * (by Leonid Broukhis).
+ * A previous version of this file used a more sophisticated algorithm
+ * (by Fiala and Greene) which is guaranteed to run in linear amortized
+ * time, but has a larger average cost, uses more memory and is patented.
+ * However the F&G algorithm may be faster for some highly redundant
+ * files if the parameter max_chain_length (described below) is too large.
+ *
+ * ACKNOWLEDGEMENTS
+ *
+ * The idea of lazy evaluation of matches is due to Jan-Mark Wams, and
+ * I found it in 'freeze' written by Leonid Broukhis.
+ * Thanks to many people for bug reports and testing.
+ *
+ * REFERENCES
+ *
+ * Deutsch, L.P.,"DEFLATE Compressed Data Format Specification".
+ * Available in http://tools.ietf.org/html/rfc1951
+ *
+ * A description of the Rabin and Karp algorithm is given in the book
+ * "Algorithms" by R. Sedgewick, Addison-Wesley, p252.
+ *
+ * Fiala,E.R., and Greene,D.H.
+ * Data Compression with Finite Windows, Comm.ACM, 32,4 (1989) 490-595
+ *
+ */
+
+/* @(#) $Id$ */
+
+#include "deflate.h"
+
+const char deflate_copyright[] =
+ " deflate 1.2.11 Copyright 1995-2017 Jean-loup Gailly and Mark Adler ";
+/*
+ If you use the zlib library in a product, an acknowledgment is welcome
+ in the documentation of your product. If for some reason you cannot
+ include such an acknowledgment, I would appreciate that you keep this
+ copyright string in the executable of your product.
+ */
+
+/* ===========================================================================
+ * Function prototypes.
+ */
+typedef enum {
+ need_more, /* block not completed, need more input or more output */
+ block_done, /* block flush performed */
+ finish_started, /* finish started, need only more output at next deflate */
+ finish_done /* finish done, accept no more input or output */
+} block_state;
+
+typedef block_state (*compress_func) OF((deflate_state *s, int flush));
+/* Compression function. Returns the block state after the call. */
+
+local int deflateStateCheck OF((z_streamp strm));
+local void slide_hash OF((deflate_state *s));
+local void fill_window OF((deflate_state *s));
+local block_state deflate_stored OF((deflate_state *s, int flush));
+local block_state deflate_fast OF((deflate_state *s, int flush));
+#ifndef FASTEST
+local block_state deflate_slow OF((deflate_state *s, int flush));
+#endif
+local block_state deflate_rle OF((deflate_state *s, int flush));
+local block_state deflate_huff OF((deflate_state *s, int flush));
+local void lm_init OF((deflate_state *s));
+local void putShortMSB OF((deflate_state *s, uInt b));
+local void flush_pending OF((z_streamp strm));
+local unsigned read_buf OF((z_streamp strm, Bytef *buf, unsigned size));
+#ifdef ASMV
+# pragma message("Assembler code may have bugs -- use at your own risk")
+ void match_init OF((void)); /* asm code initialization */
+ uInt longest_match OF((deflate_state *s, IPos cur_match));
+#else
+local uInt longest_match OF((deflate_state *s, IPos cur_match));
+#endif
+
+#ifdef ZLIB_DEBUG
+local void check_match OF((deflate_state *s, IPos start, IPos match,
+ int length));
+#endif
+
+/* ===========================================================================
+ * Local data
+ */
+
+#define NIL 0
+/* Tail of hash chains */
+
+#ifndef TOO_FAR
+# define TOO_FAR 4096
+#endif
+/* Matches of length 3 are discarded if their distance exceeds TOO_FAR */
+
+/* Values for max_lazy_match, good_match and max_chain_length, depending on
+ * the desired pack level (0..9). The values given below have been tuned to
+ * exclude worst case performance for pathological files. Better values may be
+ * found for specific files.
+ */
+typedef struct config_s {
+ ush good_length; /* reduce lazy search above this match length */
+ ush max_lazy; /* do not perform lazy search above this match length */
+ ush nice_length; /* quit search above this match length */
+ ush max_chain;
+ compress_func func;
+} config;
+
+#ifdef FASTEST
+local const config configuration_table[2] = {
+/* good lazy nice chain */
+/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */
+/* 1 */ {4, 4, 8, 4, deflate_fast}}; /* max speed, no lazy matches */
+#else
+local const config configuration_table[10] = {
+/* good lazy nice chain */
+/* 0 */ {0, 0, 0, 0, deflate_stored}, /* store only */
+/* 1 */ {4, 4, 8, 4, deflate_fast}, /* max speed, no lazy matches */
+/* 2 */ {4, 5, 16, 8, deflate_fast},
+/* 3 */ {4, 6, 32, 32, deflate_fast},
+
+/* 4 */ {4, 4, 16, 16, deflate_slow}, /* lazy matches */
+/* 5 */ {8, 16, 32, 32, deflate_slow},
+/* 6 */ {8, 16, 128, 128, deflate_slow},
+/* 7 */ {8, 32, 128, 256, deflate_slow},
+/* 8 */ {32, 128, 258, 1024, deflate_slow},
+/* 9 */ {32, 258, 258, 4096, deflate_slow}}; /* max compression */
+#endif
+
+/* Note: the deflate() code requires max_lazy >= MIN_MATCH and max_chain >= 4
+ * For deflate_fast() (levels <= 3) good is ignored and lazy has a different
+ * meaning.
+ */
+
+/* rank Z_BLOCK between Z_NO_FLUSH and Z_PARTIAL_FLUSH */
+#define RANK(f) (((f) * 2) - ((f) > 4 ? 9 : 0))
+
+/* ===========================================================================
+ * Update a hash value with the given input byte
+ * IN assertion: all calls to UPDATE_HASH are made with consecutive input
+ * characters, so that a running hash key can be computed from the previous
+ * key instead of complete recalculation each time.
+ */
+#define UPDATE_HASH(s,h,c) (h = (((h)<<s->hash_shift) ^ (c)) & s->hash_mask)
+
+
+/* ===========================================================================
+ * Insert string str in the dictionary and set match_head to the previous head
+ * of the hash chain (the most recent string with same hash key). Return
+ * the previous length of the hash chain.
+ * If this file is compiled with -DFASTEST, the compression level is forced
+ * to 1, and no hash chains are maintained.
+ * IN assertion: all calls to INSERT_STRING are made with consecutive input
+ * characters and the first MIN_MATCH bytes of str are valid (except for
+ * the last MIN_MATCH-1 bytes of the input file).
+ */
+#ifdef FASTEST
+#define INSERT_STRING(s, str, match_head) \
+ (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+ match_head = s->head[s->ins_h], \
+ s->head[s->ins_h] = (Pos)(str))
+#else
+#define INSERT_STRING(s, str, match_head) \
+ (UPDATE_HASH(s, s->ins_h, s->window[(str) + (MIN_MATCH-1)]), \
+ match_head = s->prev[(str) & s->w_mask] = s->head[s->ins_h], \
+ s->head[s->ins_h] = (Pos)(str))
+#endif
+
+/* ===========================================================================
+ * Initialize the hash table (avoiding 64K overflow for 16 bit systems).
+ * prev[] will be initialized on the fly.
+ */
+#define CLEAR_HASH(s) \
+ s->head[s->hash_size-1] = NIL; \
+ zmemzero((Bytef *)s->head, (unsigned)(s->hash_size-1)*sizeof(*s->head));
+
+/* ===========================================================================
+ * Slide the hash table when sliding the window down (could be avoided with 32
+ * bit values at the expense of memory usage). We slide even when level == 0 to
+ * keep the hash table consistent if we switch back to level > 0 later.
+ */
+local void slide_hash(s)
+ deflate_state *s;
+{
+ unsigned n, m;
+ Posf *p;
+ uInt wsize = s->w_size;
+
+ n = s->hash_size;
+ p = &s->head[n];
+ do {
+ m = *--p;
+ *p = (Pos)(m >= wsize ? m - wsize : NIL);
+ } while (--n);
+ n = wsize;
+#ifndef FASTEST
+ p = &s->prev[n];
+ do {
+ m = *--p;
+ *p = (Pos)(m >= wsize ? m - wsize : NIL);
+ /* If n is not on any hash chain, prev[n] is garbage but
+ * its value will never be used.
+ */
+ } while (--n);
+#endif
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateInit_(strm, level, version, stream_size)
+ z_streamp strm;
+ int level;
+ const char *version;
+ int stream_size;
+{
+ return deflateInit2_(strm, level, Z_DEFLATED, MAX_WBITS, DEF_MEM_LEVEL,
+ Z_DEFAULT_STRATEGY, version, stream_size);
+ /* To do: ignore strm->next_in if we use it as window */
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy,
+ version, stream_size)
+ z_streamp strm;
+ int level;
+ int method;
+ int windowBits;
+ int memLevel;
+ int strategy;
+ const char *version;
+ int stream_size;
+{
+ deflate_state *s;
+ int wrap = 1;
+ static const char my_version[] = ZLIB_VERSION;
+
+ ushf *overlay;
+ /* We overlay pending_buf and d_buf+l_buf. This works since the average
+ * output size for (length,distance) codes is <= 24 bits.
+ */
+
+ if (version == Z_NULL || version[0] != my_version[0] ||
+ stream_size != sizeof(z_stream)) {
+ return Z_VERSION_ERROR;
+ }
+ if (strm == Z_NULL) return Z_STREAM_ERROR;
+
+ strm->msg = Z_NULL;
+ if (strm->zalloc == (alloc_func)0) {
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zalloc = zcalloc;
+ strm->opaque = (voidpf)0;
+#endif
+ }
+ if (strm->zfree == (free_func)0)
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zfree = zcfree;
+#endif
+
+#ifdef FASTEST
+ if (level != 0) level = 1;
+#else
+ if (level == Z_DEFAULT_COMPRESSION) level = 6;
+#endif
+
+ if (windowBits < 0) { /* suppress zlib wrapper */
+ wrap = 0;
+ windowBits = -windowBits;
+ }
+#ifdef GZIP
+ else if (windowBits > 15) {
+ wrap = 2; /* write gzip wrapper instead */
+ windowBits -= 16;
+ }
+#endif
+ if (memLevel < 1 || memLevel > MAX_MEM_LEVEL || method != Z_DEFLATED ||
+ windowBits < 8 || windowBits > 15 || level < 0 || level > 9 ||
+ strategy < 0 || strategy > Z_FIXED || (windowBits == 8 && wrap != 1)) {
+ return Z_STREAM_ERROR;
+ }
+ if (windowBits == 8) windowBits = 9; /* until 256-byte window bug fixed */
+ s = (deflate_state *) ZALLOC(strm, 1, sizeof(deflate_state));
+ if (s == Z_NULL) return Z_MEM_ERROR;
+ strm->state = (struct internal_state FAR *)s;
+ s->strm = strm;
+ s->status = INIT_STATE; /* to pass state test in deflateReset() */
+
+ s->wrap = wrap;
+ s->gzhead = Z_NULL;
+ s->w_bits = (uInt)windowBits;
+ s->w_size = 1 << s->w_bits;
+ s->w_mask = s->w_size - 1;
+
+ s->hash_bits = (uInt)memLevel + 7;
+ s->hash_size = 1 << s->hash_bits;
+ s->hash_mask = s->hash_size - 1;
+ s->hash_shift = ((s->hash_bits+MIN_MATCH-1)/MIN_MATCH);
+
+ s->window = (Bytef *) ZALLOC(strm, s->w_size, 2*sizeof(Byte));
+ s->prev = (Posf *) ZALLOC(strm, s->w_size, sizeof(Pos));
+ s->head = (Posf *) ZALLOC(strm, s->hash_size, sizeof(Pos));
+
+ s->high_water = 0; /* nothing written to s->window yet */
+
+ s->lit_bufsize = 1 << (memLevel + 6); /* 16K elements by default */
+
+ overlay = (ushf *) ZALLOC(strm, s->lit_bufsize, sizeof(ush)+2);
+ s->pending_buf = (uchf *) overlay;
+ s->pending_buf_size = (ulg)s->lit_bufsize * (sizeof(ush)+2L);
+
+ if (s->window == Z_NULL || s->prev == Z_NULL || s->head == Z_NULL ||
+ s->pending_buf == Z_NULL) {
+ s->status = FINISH_STATE;
+ strm->msg = ERR_MSG(Z_MEM_ERROR);
+ deflateEnd (strm);
+ return Z_MEM_ERROR;
+ }
+ s->d_buf = overlay + s->lit_bufsize/sizeof(ush);
+ s->l_buf = s->pending_buf + (1+sizeof(ush))*s->lit_bufsize;
+
+ s->level = level;
+ s->strategy = strategy;
+ s->method = (Byte)method;
+
+ return deflateReset(strm);
+}
+
+/* =========================================================================
+ * Check for a valid deflate stream state. Return 0 if ok, 1 if not.
+ */
+local int deflateStateCheck (strm)
+ z_streamp strm;
+{
+ deflate_state *s;
+ if (strm == Z_NULL ||
+ strm->zalloc == (alloc_func)0 || strm->zfree == (free_func)0)
+ return 1;
+ s = strm->state;
+ if (s == Z_NULL || s->strm != strm || (s->status != INIT_STATE &&
+#ifdef GZIP
+ s->status != GZIP_STATE &&
+#endif
+ s->status != EXTRA_STATE &&
+ s->status != NAME_STATE &&
+ s->status != COMMENT_STATE &&
+ s->status != HCRC_STATE &&
+ s->status != BUSY_STATE &&
+ s->status != FINISH_STATE))
+ return 1;
+ return 0;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength)
+ z_streamp strm;
+ const Bytef *dictionary;
+ uInt dictLength;
+{
+ deflate_state *s;
+ uInt str, n;
+ int wrap;
+ unsigned avail;
+ z_const unsigned char *next;
+
+ if (deflateStateCheck(strm) || dictionary == Z_NULL)
+ return Z_STREAM_ERROR;
+ s = strm->state;
+ wrap = s->wrap;
+ if (wrap == 2 || (wrap == 1 && s->status != INIT_STATE) || s->lookahead)
+ return Z_STREAM_ERROR;
+
+ /* when using zlib wrappers, compute Adler-32 for provided dictionary */
+ if (wrap == 1)
+ strm->adler = adler32(strm->adler, dictionary, dictLength);
+ s->wrap = 0; /* avoid computing Adler-32 in read_buf */
+
+ /* if dictionary would fill window, just replace the history */
+ if (dictLength >= s->w_size) {
+ if (wrap == 0) { /* already empty otherwise */
+ CLEAR_HASH(s);
+ s->strstart = 0;
+ s->block_start = 0L;
+ s->insert = 0;
+ }
+ dictionary += dictLength - s->w_size; /* use the tail */
+ dictLength = s->w_size;
+ }
+
+ /* insert dictionary into window and hash */
+ avail = strm->avail_in;
+ next = strm->next_in;
+ strm->avail_in = dictLength;
+ strm->next_in = (z_const Bytef *)dictionary;
+ fill_window(s);
+ while (s->lookahead >= MIN_MATCH) {
+ str = s->strstart;
+ n = s->lookahead - (MIN_MATCH-1);
+ do {
+ UPDATE_HASH(s, s->ins_h, s->window[str + MIN_MATCH-1]);
+#ifndef FASTEST
+ s->prev[str & s->w_mask] = s->head[s->ins_h];
+#endif
+ s->head[s->ins_h] = (Pos)str;
+ str++;
+ } while (--n);
+ s->strstart = str;
+ s->lookahead = MIN_MATCH-1;
+ fill_window(s);
+ }
+ s->strstart += s->lookahead;
+ s->block_start = (long)s->strstart;
+ s->insert = s->lookahead;
+ s->lookahead = 0;
+ s->match_length = s->prev_length = MIN_MATCH-1;
+ s->match_available = 0;
+ strm->next_in = next;
+ strm->avail_in = avail;
+ s->wrap = wrap;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateGetDictionary (strm, dictionary, dictLength)
+ z_streamp strm;
+ Bytef *dictionary;
+ uInt *dictLength;
+{
+ deflate_state *s;
+ uInt len;
+
+ if (deflateStateCheck(strm))
+ return Z_STREAM_ERROR;
+ s = strm->state;
+ len = s->strstart + s->lookahead;
+ if (len > s->w_size)
+ len = s->w_size;
+ if (dictionary != Z_NULL && len)
+ zmemcpy(dictionary, s->window + s->strstart + s->lookahead - len, len);
+ if (dictLength != Z_NULL)
+ *dictLength = len;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateResetKeep (strm)
+ z_streamp strm;
+{
+ deflate_state *s;
+
+ if (deflateStateCheck(strm)) {
+ return Z_STREAM_ERROR;
+ }
+
+ strm->total_in = strm->total_out = 0;
+ strm->msg = Z_NULL; /* use zfree if we ever allocate msg dynamically */
+ strm->data_type = Z_UNKNOWN;
+
+ s = (deflate_state *)strm->state;
+ s->pending = 0;
+ s->pending_out = s->pending_buf;
+
+ if (s->wrap < 0) {
+ s->wrap = -s->wrap; /* was made negative by deflate(..., Z_FINISH); */
+ }
+ s->status =
+#ifdef GZIP
+ s->wrap == 2 ? GZIP_STATE :
+#endif
+ s->wrap ? INIT_STATE : BUSY_STATE;
+ strm->adler =
+#ifdef GZIP
+ s->wrap == 2 ? crc32(0L, Z_NULL, 0) :
+#endif
+ adler32(0L, Z_NULL, 0);
+ s->last_flush = Z_NO_FLUSH;
+
+ _tr_init(s);
+
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateReset (strm)
+ z_streamp strm;
+{
+ int ret;
+
+ ret = deflateResetKeep(strm);
+ if (ret == Z_OK)
+ lm_init(strm->state);
+ return ret;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateSetHeader (strm, head)
+ z_streamp strm;
+ gz_headerp head;
+{
+ if (deflateStateCheck(strm) || strm->state->wrap != 2)
+ return Z_STREAM_ERROR;
+ strm->state->gzhead = head;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflatePending (strm, pending, bits)
+ unsigned *pending;
+ int *bits;
+ z_streamp strm;
+{
+ if (deflateStateCheck(strm)) return Z_STREAM_ERROR;
+ if (pending != Z_NULL)
+ *pending = strm->state->pending;
+ if (bits != Z_NULL)
+ *bits = strm->state->bi_valid;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflatePrime (strm, bits, value)
+ z_streamp strm;
+ int bits;
+ int value;
+{
+ deflate_state *s;
+ int put;
+
+ if (deflateStateCheck(strm)) return Z_STREAM_ERROR;
+ s = strm->state;
+ if ((Bytef *)(s->d_buf) < s->pending_out + ((Buf_size + 7) >> 3))
+ return Z_BUF_ERROR;
+ do {
+ put = Buf_size - s->bi_valid;
+ if (put > bits)
+ put = bits;
+ s->bi_buf |= (ush)((value & ((1 << put) - 1)) << s->bi_valid);
+ s->bi_valid += put;
+ _tr_flush_bits(s);
+ value >>= put;
+ bits -= put;
+ } while (bits);
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateParams(strm, level, strategy)
+ z_streamp strm;
+ int level;
+ int strategy;
+{
+ deflate_state *s;
+ compress_func func;
+
+ if (deflateStateCheck(strm)) return Z_STREAM_ERROR;
+ s = strm->state;
+
+#ifdef FASTEST
+ if (level != 0) level = 1;
+#else
+ if (level == Z_DEFAULT_COMPRESSION) level = 6;
+#endif
+ if (level < 0 || level > 9 || strategy < 0 || strategy > Z_FIXED) {
+ return Z_STREAM_ERROR;
+ }
+ func = configuration_table[s->level].func;
+
+ if ((strategy != s->strategy || func != configuration_table[level].func) &&
+ s->high_water) {
+ /* Flush the last buffer: */
+ int err = deflate(strm, Z_BLOCK);
+ if (err == Z_STREAM_ERROR)
+ return err;
+ if (strm->avail_out == 0)
+ return Z_BUF_ERROR;
+ }
+ if (s->level != level) {
+ if (s->level == 0 && s->matches != 0) {
+ if (s->matches == 1)
+ slide_hash(s);
+ else
+ CLEAR_HASH(s);
+ s->matches = 0;
+ }
+ s->level = level;
+ s->max_lazy_match = configuration_table[level].max_lazy;
+ s->good_match = configuration_table[level].good_length;
+ s->nice_match = configuration_table[level].nice_length;
+ s->max_chain_length = configuration_table[level].max_chain;
+ }
+ s->strategy = strategy;
+ return Z_OK;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateTune(strm, good_length, max_lazy, nice_length, max_chain)
+ z_streamp strm;
+ int good_length;
+ int max_lazy;
+ int nice_length;
+ int max_chain;
+{
+ deflate_state *s;
+
+ if (deflateStateCheck(strm)) return Z_STREAM_ERROR;
+ s = strm->state;
+ s->good_match = (uInt)good_length;
+ s->max_lazy_match = (uInt)max_lazy;
+ s->nice_match = nice_length;
+ s->max_chain_length = (uInt)max_chain;
+ return Z_OK;
+}
+
+/* =========================================================================
+ * For the default windowBits of 15 and memLevel of 8, this function returns
+ * a close to exact, as well as small, upper bound on the compressed size.
+ * They are coded as constants here for a reason--if the #define's are
+ * changed, then this function needs to be changed as well. The return
+ * value for 15 and 8 only works for those exact settings.
+ *
+ * For any setting other than those defaults for windowBits and memLevel,
+ * the value returned is a conservative worst case for the maximum expansion
+ * resulting from using fixed blocks instead of stored blocks, which deflate
+ * can emit on compressed data for some combinations of the parameters.
+ *
+ * This function could be more sophisticated to provide closer upper bounds for
+ * every combination of windowBits and memLevel. But even the conservative
+ * upper bound of about 14% expansion does not seem onerous for output buffer
+ * allocation.
+ */
+uLong ZEXPORT deflateBound(strm, sourceLen)
+ z_streamp strm;
+ uLong sourceLen;
+{
+ deflate_state *s;
+ uLong complen, wraplen;
+
+ /* conservative upper bound for compressed data */
+ complen = sourceLen +
+ ((sourceLen + 7) >> 3) + ((sourceLen + 63) >> 6) + 5;
+
+ /* if can't get parameters, return conservative bound plus zlib wrapper */
+ if (deflateStateCheck(strm))
+ return complen + 6;
+
+ /* compute wrapper length */
+ s = strm->state;
+ switch (s->wrap) {
+ case 0: /* raw deflate */
+ wraplen = 0;
+ break;
+ case 1: /* zlib wrapper */
+ wraplen = 6 + (s->strstart ? 4 : 0);
+ break;
+#ifdef GZIP
+ case 2: /* gzip wrapper */
+ wraplen = 18;
+ if (s->gzhead != Z_NULL) { /* user-supplied gzip header */
+ Bytef *str;
+ if (s->gzhead->extra != Z_NULL)
+ wraplen += 2 + s->gzhead->extra_len;
+ str = s->gzhead->name;
+ if (str != Z_NULL)
+ do {
+ wraplen++;
+ } while (*str++);
+ str = s->gzhead->comment;
+ if (str != Z_NULL)
+ do {
+ wraplen++;
+ } while (*str++);
+ if (s->gzhead->hcrc)
+ wraplen += 2;
+ }
+ break;
+#endif
+ default: /* for compiler happiness */
+ wraplen = 6;
+ }
+
+ /* if not default parameters, return conservative bound */
+ if (s->w_bits != 15 || s->hash_bits != 8 + 7)
+ return complen + wraplen;
+
+ /* default settings: return tight bound for that case */
+ return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) +
+ (sourceLen >> 25) + 13 - 6 + wraplen;
+}
+
+/* =========================================================================
+ * Put a short in the pending buffer. The 16-bit value is put in MSB order.
+ * IN assertion: the stream state is correct and there is enough room in
+ * pending_buf.
+ */
+local void putShortMSB (s, b)
+ deflate_state *s;
+ uInt b;
+{
+ put_byte(s, (Byte)(b >> 8));
+ put_byte(s, (Byte)(b & 0xff));
+}
+
+/* =========================================================================
+ * Flush as much pending output as possible. All deflate() output, except for
+ * some deflate_stored() output, goes through this function so some
+ * applications may wish to modify it to avoid allocating a large
+ * strm->next_out buffer and copying into it. (See also read_buf()).
+ */
+local void flush_pending(strm)
+ z_streamp strm;
+{
+ unsigned len;
+ deflate_state *s = strm->state;
+
+ _tr_flush_bits(s);
+ len = s->pending;
+ if (len > strm->avail_out) len = strm->avail_out;
+ if (len == 0) return;
+
+ zmemcpy(strm->next_out, s->pending_out, len);
+ strm->next_out += len;
+ s->pending_out += len;
+ strm->total_out += len;
+ strm->avail_out -= len;
+ s->pending -= len;
+ if (s->pending == 0) {
+ s->pending_out = s->pending_buf;
+ }
+}
+
+/* ===========================================================================
+ * Update the header CRC with the bytes s->pending_buf[beg..s->pending - 1].
+ */
+#define HCRC_UPDATE(beg) \
+ do { \
+ if (s->gzhead->hcrc && s->pending > (beg)) \
+ strm->adler = crc32(strm->adler, s->pending_buf + (beg), \
+ s->pending - (beg)); \
+ } while (0)
+
+/* ========================================================================= */
+int ZEXPORT deflate (strm, flush)
+ z_streamp strm;
+ int flush;
+{
+ int old_flush; /* value of flush param for previous deflate call */
+ deflate_state *s;
+
+ if (deflateStateCheck(strm) || flush > Z_BLOCK || flush < 0) {
+ return Z_STREAM_ERROR;
+ }
+ s = strm->state;
+
+ if (strm->next_out == Z_NULL ||
+ (strm->avail_in != 0 && strm->next_in == Z_NULL) ||
+ (s->status == FINISH_STATE && flush != Z_FINISH)) {
+ ERR_RETURN(strm, Z_STREAM_ERROR);
+ }
+ if (strm->avail_out == 0) ERR_RETURN(strm, Z_BUF_ERROR);
+
+ old_flush = s->last_flush;
+ s->last_flush = flush;
+
+ /* Flush as much pending output as possible */
+ if (s->pending != 0) {
+ flush_pending(strm);
+ if (strm->avail_out == 0) {
+ /* Since avail_out is 0, deflate will be called again with
+ * more output space, but possibly with both pending and
+ * avail_in equal to zero. There won't be anything to do,
+ * but this is not an error situation so make sure we
+ * return OK instead of BUF_ERROR at next call of deflate:
+ */
+ s->last_flush = -1;
+ return Z_OK;
+ }
+
+ /* Make sure there is something to do and avoid duplicate consecutive
+ * flushes. For repeated and useless calls with Z_FINISH, we keep
+ * returning Z_STREAM_END instead of Z_BUF_ERROR.
+ */
+ } else if (strm->avail_in == 0 && RANK(flush) <= RANK(old_flush) &&
+ flush != Z_FINISH) {
+ ERR_RETURN(strm, Z_BUF_ERROR);
+ }
+
+ /* User must not provide more input after the first FINISH: */
+ if (s->status == FINISH_STATE && strm->avail_in != 0) {
+ ERR_RETURN(strm, Z_BUF_ERROR);
+ }
+
+ /* Write the header */
+ if (s->status == INIT_STATE) {
+ /* zlib header */
+ uInt header = (Z_DEFLATED + ((s->w_bits-8)<<4)) << 8;
+ uInt level_flags;
+
+ if (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2)
+ level_flags = 0;
+ else if (s->level < 6)
+ level_flags = 1;
+ else if (s->level == 6)
+ level_flags = 2;
+ else
+ level_flags = 3;
+ header |= (level_flags << 6);
+ if (s->strstart != 0) header |= PRESET_DICT;
+ header += 31 - (header % 31);
+
+ putShortMSB(s, header);
+
+ /* Save the adler32 of the preset dictionary: */
+ if (s->strstart != 0) {
+ putShortMSB(s, (uInt)(strm->adler >> 16));
+ putShortMSB(s, (uInt)(strm->adler & 0xffff));
+ }
+ strm->adler = adler32(0L, Z_NULL, 0);
+ s->status = BUSY_STATE;
+
+ /* Compression must start with an empty pending buffer */
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ }
+#ifdef GZIP
+ if (s->status == GZIP_STATE) {
+ /* gzip header */
+ strm->adler = crc32(0L, Z_NULL, 0);
+ put_byte(s, 31);
+ put_byte(s, 139);
+ put_byte(s, 8);
+ if (s->gzhead == Z_NULL) {
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, 0);
+ put_byte(s, s->level == 9 ? 2 :
+ (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ?
+ 4 : 0));
+ put_byte(s, OS_CODE);
+ s->status = BUSY_STATE;
+
+ /* Compression must start with an empty pending buffer */
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ }
+ else {
+ put_byte(s, (s->gzhead->text ? 1 : 0) +
+ (s->gzhead->hcrc ? 2 : 0) +
+ (s->gzhead->extra == Z_NULL ? 0 : 4) +
+ (s->gzhead->name == Z_NULL ? 0 : 8) +
+ (s->gzhead->comment == Z_NULL ? 0 : 16)
+ );
+ put_byte(s, (Byte)(s->gzhead->time & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 8) & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 16) & 0xff));
+ put_byte(s, (Byte)((s->gzhead->time >> 24) & 0xff));
+ put_byte(s, s->level == 9 ? 2 :
+ (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2 ?
+ 4 : 0));
+ put_byte(s, s->gzhead->os & 0xff);
+ if (s->gzhead->extra != Z_NULL) {
+ put_byte(s, s->gzhead->extra_len & 0xff);
+ put_byte(s, (s->gzhead->extra_len >> 8) & 0xff);
+ }
+ if (s->gzhead->hcrc)
+ strm->adler = crc32(strm->adler, s->pending_buf,
+ s->pending);
+ s->gzindex = 0;
+ s->status = EXTRA_STATE;
+ }
+ }
+ if (s->status == EXTRA_STATE) {
+ if (s->gzhead->extra != Z_NULL) {
+ ulg beg = s->pending; /* start of bytes to update crc */
+ uInt left = (s->gzhead->extra_len & 0xffff) - s->gzindex;
+ while (s->pending + left > s->pending_buf_size) {
+ uInt copy = s->pending_buf_size - s->pending;
+ zmemcpy(s->pending_buf + s->pending,
+ s->gzhead->extra + s->gzindex, copy);
+ s->pending = s->pending_buf_size;
+ HCRC_UPDATE(beg);
+ s->gzindex += copy;
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ beg = 0;
+ left -= copy;
+ }
+ zmemcpy(s->pending_buf + s->pending,
+ s->gzhead->extra + s->gzindex, left);
+ s->pending += left;
+ HCRC_UPDATE(beg);
+ s->gzindex = 0;
+ }
+ s->status = NAME_STATE;
+ }
+ if (s->status == NAME_STATE) {
+ if (s->gzhead->name != Z_NULL) {
+ ulg beg = s->pending; /* start of bytes to update crc */
+ int val;
+ do {
+ if (s->pending == s->pending_buf_size) {
+ HCRC_UPDATE(beg);
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ beg = 0;
+ }
+ val = s->gzhead->name[s->gzindex++];
+ put_byte(s, val);
+ } while (val != 0);
+ HCRC_UPDATE(beg);
+ s->gzindex = 0;
+ }
+ s->status = COMMENT_STATE;
+ }
+ if (s->status == COMMENT_STATE) {
+ if (s->gzhead->comment != Z_NULL) {
+ ulg beg = s->pending; /* start of bytes to update crc */
+ int val;
+ do {
+ if (s->pending == s->pending_buf_size) {
+ HCRC_UPDATE(beg);
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ beg = 0;
+ }
+ val = s->gzhead->comment[s->gzindex++];
+ put_byte(s, val);
+ } while (val != 0);
+ HCRC_UPDATE(beg);
+ }
+ s->status = HCRC_STATE;
+ }
+ if (s->status == HCRC_STATE) {
+ if (s->gzhead->hcrc) {
+ if (s->pending + 2 > s->pending_buf_size) {
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ }
+ put_byte(s, (Byte)(strm->adler & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 8) & 0xff));
+ strm->adler = crc32(0L, Z_NULL, 0);
+ }
+ s->status = BUSY_STATE;
+
+ /* Compression must start with an empty pending buffer */
+ flush_pending(strm);
+ if (s->pending != 0) {
+ s->last_flush = -1;
+ return Z_OK;
+ }
+ }
+#endif
+
+ /* Start a new block or continue the current one.
+ */
+ if (strm->avail_in != 0 || s->lookahead != 0 ||
+ (flush != Z_NO_FLUSH && s->status != FINISH_STATE)) {
+ block_state bstate;
+
+ bstate = s->level == 0 ? deflate_stored(s, flush) :
+ s->strategy == Z_HUFFMAN_ONLY ? deflate_huff(s, flush) :
+ s->strategy == Z_RLE ? deflate_rle(s, flush) :
+ (*(configuration_table[s->level].func))(s, flush);
+
+ if (bstate == finish_started || bstate == finish_done) {
+ s->status = FINISH_STATE;
+ }
+ if (bstate == need_more || bstate == finish_started) {
+ if (strm->avail_out == 0) {
+ s->last_flush = -1; /* avoid BUF_ERROR next call, see above */
+ }
+ return Z_OK;
+ /* If flush != Z_NO_FLUSH && avail_out == 0, the next call
+ * of deflate should use the same flush parameter to make sure
+ * that the flush is complete. So we don't have to output an
+ * empty block here, this will be done at next call. This also
+ * ensures that for a very small output buffer, we emit at most
+ * one empty block.
+ */
+ }
+ if (bstate == block_done) {
+ if (flush == Z_PARTIAL_FLUSH) {
+ _tr_align(s);
+ } else if (flush != Z_BLOCK) { /* FULL_FLUSH or SYNC_FLUSH */
+ _tr_stored_block(s, (char*)0, 0L, 0);
+ /* For a full flush, this empty block will be recognized
+ * as a special marker by inflate_sync().
+ */
+ if (flush == Z_FULL_FLUSH) {
+ CLEAR_HASH(s); /* forget history */
+ if (s->lookahead == 0) {
+ s->strstart = 0;
+ s->block_start = 0L;
+ s->insert = 0;
+ }
+ }
+ }
+ flush_pending(strm);
+ if (strm->avail_out == 0) {
+ s->last_flush = -1; /* avoid BUF_ERROR at next call, see above */
+ return Z_OK;
+ }
+ }
+ }
+
+ if (flush != Z_FINISH) return Z_OK;
+ if (s->wrap <= 0) return Z_STREAM_END;
+
+ /* Write the trailer */
+#ifdef GZIP
+ if (s->wrap == 2) {
+ put_byte(s, (Byte)(strm->adler & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 8) & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 16) & 0xff));
+ put_byte(s, (Byte)((strm->adler >> 24) & 0xff));
+ put_byte(s, (Byte)(strm->total_in & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 8) & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 16) & 0xff));
+ put_byte(s, (Byte)((strm->total_in >> 24) & 0xff));
+ }
+ else
+#endif
+ {
+ putShortMSB(s, (uInt)(strm->adler >> 16));
+ putShortMSB(s, (uInt)(strm->adler & 0xffff));
+ }
+ flush_pending(strm);
+ /* If avail_out is zero, the application will call deflate again
+ * to flush the rest.
+ */
+ if (s->wrap > 0) s->wrap = -s->wrap; /* write the trailer only once! */
+ return s->pending != 0 ? Z_OK : Z_STREAM_END;
+}
+
+/* ========================================================================= */
+int ZEXPORT deflateEnd (strm)
+ z_streamp strm;
+{
+ int status;
+
+ if (deflateStateCheck(strm)) return Z_STREAM_ERROR;
+
+ status = strm->state->status;
+
+ /* Deallocate in reverse order of allocations: */
+ TRY_FREE(strm, strm->state->pending_buf);
+ TRY_FREE(strm, strm->state->head);
+ TRY_FREE(strm, strm->state->prev);
+ TRY_FREE(strm, strm->state->window);
+
+ ZFREE(strm, strm->state);
+ strm->state = Z_NULL;
+
+ return status == BUSY_STATE ? Z_DATA_ERROR : Z_OK;
+}
+
+/* =========================================================================
+ * Copy the source state to the destination state.
+ * To simplify the source, this is not supported for 16-bit MSDOS (which
+ * doesn't have enough memory anyway to duplicate compression states).
+ */
+int ZEXPORT deflateCopy (dest, source)
+ z_streamp dest;
+ z_streamp source;
+{
+#ifdef MAXSEG_64K
+ return Z_STREAM_ERROR;
+#else
+ deflate_state *ds;
+ deflate_state *ss;
+ ushf *overlay;
+
+
+ if (deflateStateCheck(source) || dest == Z_NULL) {
+ return Z_STREAM_ERROR;
+ }
+
+ ss = source->state;
+
+ zmemcpy((voidpf)dest, (voidpf)source, sizeof(z_stream));
+
+ ds = (deflate_state *) ZALLOC(dest, 1, sizeof(deflate_state));
+ if (ds == Z_NULL) return Z_MEM_ERROR;
+ dest->state = (struct internal_state FAR *) ds;
+ zmemcpy((voidpf)ds, (voidpf)ss, sizeof(deflate_state));
+ ds->strm = dest;
+
+ ds->window = (Bytef *) ZALLOC(dest, ds->w_size, 2*sizeof(Byte));
+ ds->prev = (Posf *) ZALLOC(dest, ds->w_size, sizeof(Pos));
+ ds->head = (Posf *) ZALLOC(dest, ds->hash_size, sizeof(Pos));
+ overlay = (ushf *) ZALLOC(dest, ds->lit_bufsize, sizeof(ush)+2);
+ ds->pending_buf = (uchf *) overlay;
+
+ if (ds->window == Z_NULL || ds->prev == Z_NULL || ds->head == Z_NULL ||
+ ds->pending_buf == Z_NULL) {
+ deflateEnd (dest);
+ return Z_MEM_ERROR;
+ }
+ /* following zmemcpy do not work for 16-bit MSDOS */
+ zmemcpy(ds->window, ss->window, ds->w_size * 2 * sizeof(Byte));
+ zmemcpy((voidpf)ds->prev, (voidpf)ss->prev, ds->w_size * sizeof(Pos));
+ zmemcpy((voidpf)ds->head, (voidpf)ss->head, ds->hash_size * sizeof(Pos));
+ zmemcpy(ds->pending_buf, ss->pending_buf, (uInt)ds->pending_buf_size);
+
+ ds->pending_out = ds->pending_buf + (ss->pending_out - ss->pending_buf);
+ ds->d_buf = overlay + ds->lit_bufsize/sizeof(ush);
+ ds->l_buf = ds->pending_buf + (1+sizeof(ush))*ds->lit_bufsize;
+
+ ds->l_desc.dyn_tree = ds->dyn_ltree;
+ ds->d_desc.dyn_tree = ds->dyn_dtree;
+ ds->bl_desc.dyn_tree = ds->bl_tree;
+
+ return Z_OK;
+#endif /* MAXSEG_64K */
+}
+
+/* ===========================================================================
+ * Read a new buffer from the current input stream, update the adler32
+ * and total number of bytes read. All deflate() input goes through
+ * this function so some applications may wish to modify it to avoid
+ * allocating a large strm->next_in buffer and copying from it.
+ * (See also flush_pending()).
+ */
+local unsigned read_buf(strm, buf, size)
+ z_streamp strm;
+ Bytef *buf;
+ unsigned size;
+{
+ unsigned len = strm->avail_in;
+
+ if (len > size) len = size;
+ if (len == 0) return 0;
+
+ strm->avail_in -= len;
+
+ zmemcpy(buf, strm->next_in, len);
+ if (strm->state->wrap == 1) {
+ strm->adler = adler32(strm->adler, buf, len);
+ }
+#ifdef GZIP
+ else if (strm->state->wrap == 2) {
+ strm->adler = crc32(strm->adler, buf, len);
+ }
+#endif
+ strm->next_in += len;
+ strm->total_in += len;
+
+ return len;
+}
+
+/* ===========================================================================
+ * Initialize the "longest match" routines for a new zlib stream
+ */
+local void lm_init (s)
+ deflate_state *s;
+{
+ s->window_size = (ulg)2L*s->w_size;
+
+ CLEAR_HASH(s);
+
+ /* Set the default configuration parameters:
+ */
+ s->max_lazy_match = configuration_table[s->level].max_lazy;
+ s->good_match = configuration_table[s->level].good_length;
+ s->nice_match = configuration_table[s->level].nice_length;
+ s->max_chain_length = configuration_table[s->level].max_chain;
+
+ s->strstart = 0;
+ s->block_start = 0L;
+ s->lookahead = 0;
+ s->insert = 0;
+ s->match_length = s->prev_length = MIN_MATCH-1;
+ s->match_available = 0;
+ s->ins_h = 0;
+#ifndef FASTEST
+#ifdef ASMV
+ match_init(); /* initialize the asm code */
+#endif
+#endif
+}
+
+#ifndef FASTEST
+/* ===========================================================================
+ * Set match_start to the longest match starting at the given string and
+ * return its length. Matches shorter or equal to prev_length are discarded,
+ * in which case the result is equal to prev_length and match_start is
+ * garbage.
+ * IN assertions: cur_match is the head of the hash chain for the current
+ * string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1
+ * OUT assertion: the match length is not greater than s->lookahead.
+ */
+#ifndef ASMV
+/* For 80x86 and 680x0, an optimized version will be provided in match.asm or
+ * match.S. The code will be functionally equivalent.
+ */
+local uInt longest_match(s, cur_match)
+ deflate_state *s;
+ IPos cur_match; /* current match */
+{
+ unsigned chain_length = s->max_chain_length;/* max hash chain length */
+ register Bytef *scan = s->window + s->strstart; /* current string */
+ register Bytef *match; /* matched string */
+ register int len; /* length of current match */
+ int best_len = (int)s->prev_length; /* best match length so far */
+ int nice_match = s->nice_match; /* stop if match long enough */
+ IPos limit = s->strstart > (IPos)MAX_DIST(s) ?
+ s->strstart - (IPos)MAX_DIST(s) : NIL;
+ /* Stop when cur_match becomes <= limit. To simplify the code,
+ * we prevent matches with the string of window index 0.
+ */
+ Posf *prev = s->prev;
+ uInt wmask = s->w_mask;
+
+#ifdef UNALIGNED_OK
+ /* Compare two bytes at a time. Note: this is not always beneficial.
+ * Try with and without -DUNALIGNED_OK to check.
+ */
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1;
+ register ush scan_start = *(ushf*)scan;
+ register ush scan_end = *(ushf*)(scan+best_len-1);
+#else
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+ register Byte scan_end1 = scan[best_len-1];
+ register Byte scan_end = scan[best_len];
+#endif
+
+ /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ * It is easy to get rid of this optimization if necessary.
+ */
+ Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+ /* Do not waste too much time if we already have a good match: */
+ if (s->prev_length >= s->good_match) {
+ chain_length >>= 2;
+ }
+ /* Do not look for matches beyond the end of the input. This is necessary
+ * to make deflate deterministic.
+ */
+ if ((uInt)nice_match > s->lookahead) nice_match = (int)s->lookahead;
+
+ Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+ do {
+ Assert(cur_match < s->strstart, "no future");
+ match = s->window + cur_match;
+
+ /* Skip to next match if the match length cannot increase
+ * or if the match length is less than 2. Note that the checks below
+ * for insufficient lookahead only occur occasionally for performance
+ * reasons. Therefore uninitialized memory will be accessed, and
+ * conditional jumps will be made that depend on those values.
+ * However the length of the match is limited to the lookahead, so
+ * the output of deflate is not affected by the uninitialized values.
+ */
+#if (defined(UNALIGNED_OK) && MAX_MATCH == 258)
+ /* This code assumes sizeof(unsigned short) == 2. Do not use
+ * UNALIGNED_OK if your compiler uses a different size.
+ */
+ if (*(ushf*)(match+best_len-1) != scan_end ||
+ *(ushf*)match != scan_start) continue;
+
+ /* It is not necessary to compare scan[2] and match[2] since they are
+ * always equal when the other bytes match, given that the hash keys
+ * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at
+ * strstart+3, +5, ... up to strstart+257. We check for insufficient
+ * lookahead only every 4th comparison; the 128th check will be made
+ * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is
+ * necessary to put more guard bytes at the end of the window, or
+ * to check more often for insufficient lookahead.
+ */
+ Assert(scan[2] == match[2], "scan[2]?");
+ scan++, match++;
+ do {
+ } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ *(ushf*)(scan+=2) == *(ushf*)(match+=2) &&
+ scan < strend);
+ /* The funny "do {}" generates better code on most compilers */
+
+ /* Here, scan <= window+strstart+257 */
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+ if (*scan == *match) scan++;
+
+ len = (MAX_MATCH - 1) - (int)(strend-scan);
+ scan = strend - (MAX_MATCH-1);
+
+#else /* UNALIGNED_OK */
+
+ if (match[best_len] != scan_end ||
+ match[best_len-1] != scan_end1 ||
+ *match != *scan ||
+ *++match != scan[1]) continue;
+
+ /* The check at best_len-1 can be removed because it will be made
+ * again later. (This heuristic is not always a win.)
+ * It is not necessary to compare scan[2] and match[2] since they
+ * are always equal when the other bytes match, given that
+ * the hash keys are equal and that HASH_BITS >= 8.
+ */
+ scan += 2, match++;
+ Assert(*scan == *match, "match[2]?");
+
+ /* We check for insufficient lookahead only every 8th comparison;
+ * the 256th check will be made at strstart+258.
+ */
+ do {
+ } while (*++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ scan < strend);
+
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+ len = MAX_MATCH - (int)(strend - scan);
+ scan = strend - MAX_MATCH;
+
+#endif /* UNALIGNED_OK */
+
+ if (len > best_len) {
+ s->match_start = cur_match;
+ best_len = len;
+ if (len >= nice_match) break;
+#ifdef UNALIGNED_OK
+ scan_end = *(ushf*)(scan+best_len-1);
+#else
+ scan_end1 = scan[best_len-1];
+ scan_end = scan[best_len];
+#endif
+ }
+ } while ((cur_match = prev[cur_match & wmask]) > limit
+ && --chain_length != 0);
+
+ if ((uInt)best_len <= s->lookahead) return (uInt)best_len;
+ return s->lookahead;
+}
+#endif /* ASMV */
+
+#else /* FASTEST */
+
+/* ---------------------------------------------------------------------------
+ * Optimized version for FASTEST only
+ */
+local uInt longest_match(s, cur_match)
+ deflate_state *s;
+ IPos cur_match; /* current match */
+{
+ register Bytef *scan = s->window + s->strstart; /* current string */
+ register Bytef *match; /* matched string */
+ register int len; /* length of current match */
+ register Bytef *strend = s->window + s->strstart + MAX_MATCH;
+
+ /* The code is optimized for HASH_BITS >= 8 and MAX_MATCH-2 multiple of 16.
+ * It is easy to get rid of this optimization if necessary.
+ */
+ Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever");
+
+ Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead");
+
+ Assert(cur_match < s->strstart, "no future");
+
+ match = s->window + cur_match;
+
+ /* Return failure if the match length is less than 2:
+ */
+ if (match[0] != scan[0] || match[1] != scan[1]) return MIN_MATCH-1;
+
+ /* The check at best_len-1 can be removed because it will be made
+ * again later. (This heuristic is not always a win.)
+ * It is not necessary to compare scan[2] and match[2] since they
+ * are always equal when the other bytes match, given that
+ * the hash keys are equal and that HASH_BITS >= 8.
+ */
+ scan += 2, match += 2;
+ Assert(*scan == *match, "match[2]?");
+
+ /* We check for insufficient lookahead only every 8th comparison;
+ * the 256th check will be made at strstart+258.
+ */
+ do {
+ } while (*++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ *++scan == *++match && *++scan == *++match &&
+ scan < strend);
+
+ Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan");
+
+ len = MAX_MATCH - (int)(strend - scan);
+
+ if (len < MIN_MATCH) return MIN_MATCH - 1;
+
+ s->match_start = cur_match;
+ return (uInt)len <= s->lookahead ? (uInt)len : s->lookahead;
+}
+
+#endif /* FASTEST */
+
+#ifdef ZLIB_DEBUG
+
+#define EQUAL 0
+/* result of memcmp for equal strings */
+
+/* ===========================================================================
+ * Check that the match at match_start is indeed a match.
+ */
+local void check_match(s, start, match, length)
+ deflate_state *s;
+ IPos start, match;
+ int length;
+{
+ /* check that the match is indeed a match */
+ if (zmemcmp(s->window + match,
+ s->window + start, length) != EQUAL) {
+ fprintf(stderr, " start %u, match %u, length %d\n",
+ start, match, length);
+ do {
+ fprintf(stderr, "%c%c", s->window[match++], s->window[start++]);
+ } while (--length != 0);
+ z_error("invalid match");
+ }
+ if (z_verbose > 1) {
+ fprintf(stderr,"\\[%d,%d]", start-match, length);
+ do { putc(s->window[start++], stderr); } while (--length != 0);
+ }
+}
+#else
+# define check_match(s, start, match, length)
+#endif /* ZLIB_DEBUG */
+
+/* ===========================================================================
+ * Fill the window when the lookahead becomes insufficient.
+ * Updates strstart and lookahead.
+ *
+ * IN assertion: lookahead < MIN_LOOKAHEAD
+ * OUT assertions: strstart <= window_size-MIN_LOOKAHEAD
+ * At least one byte has been read, or avail_in == 0; reads are
+ * performed for at least two bytes (required for the zip translate_eol
+ * option -- not supported here).
+ */
+local void fill_window(s)
+ deflate_state *s;
+{
+ unsigned n;
+ unsigned more; /* Amount of free space at the end of the window. */
+ uInt wsize = s->w_size;
+
+ Assert(s->lookahead < MIN_LOOKAHEAD, "already enough lookahead");
+
+ do {
+ more = (unsigned)(s->window_size -(ulg)s->lookahead -(ulg)s->strstart);
+
+ /* Deal with !@#$% 64K limit: */
+ if (sizeof(int) <= 2) {
+ if (more == 0 && s->strstart == 0 && s->lookahead == 0) {
+ more = wsize;
+
+ } else if (more == (unsigned)(-1)) {
+ /* Very unlikely, but possible on 16 bit machine if
+ * strstart == 0 && lookahead == 1 (input done a byte at time)
+ */
+ more--;
+ }
+ }
+
+ /* If the window is almost full and there is insufficient lookahead,
+ * move the upper half to the lower one to make room in the upper half.
+ */
+ if (s->strstart >= wsize+MAX_DIST(s)) {
+
+ zmemcpy(s->window, s->window+wsize, (unsigned)wsize - more);
+ s->match_start -= wsize;
+ s->strstart -= wsize; /* we now have strstart >= MAX_DIST */
+ s->block_start -= (long) wsize;
+ slide_hash(s);
+ more += wsize;
+ }
+ if (s->strm->avail_in == 0) break;
+
+ /* If there was no sliding:
+ * strstart <= WSIZE+MAX_DIST-1 && lookahead <= MIN_LOOKAHEAD - 1 &&
+ * more == window_size - lookahead - strstart
+ * => more >= window_size - (MIN_LOOKAHEAD-1 + WSIZE + MAX_DIST-1)
+ * => more >= window_size - 2*WSIZE + 2
+ * In the BIG_MEM or MMAP case (not yet supported),
+ * window_size == input_size + MIN_LOOKAHEAD &&
+ * strstart + s->lookahead <= input_size => more >= MIN_LOOKAHEAD.
+ * Otherwise, window_size == 2*WSIZE so more >= 2.
+ * If there was sliding, more >= WSIZE. So in all cases, more >= 2.
+ */
+ Assert(more >= 2, "more < 2");
+
+ n = read_buf(s->strm, s->window + s->strstart + s->lookahead, more);
+ s->lookahead += n;
+
+ /* Initialize the hash value now that we have some input: */
+ if (s->lookahead + s->insert >= MIN_MATCH) {
+ uInt str = s->strstart - s->insert;
+ s->ins_h = s->window[str];
+ UPDATE_HASH(s, s->ins_h, s->window[str + 1]);
+#if MIN_MATCH != 3
+ Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+ while (s->insert) {
+ UPDATE_HASH(s, s->ins_h, s->window[str + MIN_MATCH-1]);
+#ifndef FASTEST
+ s->prev[str & s->w_mask] = s->head[s->ins_h];
+#endif
+ s->head[s->ins_h] = (Pos)str;
+ str++;
+ s->insert--;
+ if (s->lookahead + s->insert < MIN_MATCH)
+ break;
+ }
+ }
+ /* If the whole input has less than MIN_MATCH bytes, ins_h is garbage,
+ * but this is not important since only literal bytes will be emitted.
+ */
+
+ } while (s->lookahead < MIN_LOOKAHEAD && s->strm->avail_in != 0);
+
+ /* If the WIN_INIT bytes after the end of the current data have never been
+ * written, then zero those bytes in order to avoid memory check reports of
+ * the use of uninitialized (or uninitialised as Julian writes) bytes by
+ * the longest match routines. Update the high water mark for the next
+ * time through here. WIN_INIT is set to MAX_MATCH since the longest match
+ * routines allow scanning to strstart + MAX_MATCH, ignoring lookahead.
+ */
+ if (s->high_water < s->window_size) {
+ ulg curr = s->strstart + (ulg)(s->lookahead);
+ ulg init;
+
+ if (s->high_water < curr) {
+ /* Previous high water mark below current data -- zero WIN_INIT
+ * bytes or up to end of window, whichever is less.
+ */
+ init = s->window_size - curr;
+ if (init > WIN_INIT)
+ init = WIN_INIT;
+ zmemzero(s->window + curr, (unsigned)init);
+ s->high_water = curr + init;
+ }
+ else if (s->high_water < (ulg)curr + WIN_INIT) {
+ /* High water mark at or above current data, but below current data
+ * plus WIN_INIT -- zero out to current data plus WIN_INIT, or up
+ * to end of window, whichever is less.
+ */
+ init = (ulg)curr + WIN_INIT - s->high_water;
+ if (init > s->window_size - s->high_water)
+ init = s->window_size - s->high_water;
+ zmemzero(s->window + s->high_water, (unsigned)init);
+ s->high_water += init;
+ }
+ }
+
+ Assert((ulg)s->strstart <= s->window_size - MIN_LOOKAHEAD,
+ "not enough room for search");
+}
+
+/* ===========================================================================
+ * Flush the current block, with given end-of-file flag.
+ * IN assertion: strstart is set to the end of the current match.
+ */
+#define FLUSH_BLOCK_ONLY(s, last) { \
+ _tr_flush_block(s, (s->block_start >= 0L ? \
+ (charf *)&s->window[(unsigned)s->block_start] : \
+ (charf *)Z_NULL), \
+ (ulg)((long)s->strstart - s->block_start), \
+ (last)); \
+ s->block_start = s->strstart; \
+ flush_pending(s->strm); \
+ Tracev((stderr,"[FLUSH]")); \
+}
+
+/* Same but force premature exit if necessary. */
+#define FLUSH_BLOCK(s, last) { \
+ FLUSH_BLOCK_ONLY(s, last); \
+ if (s->strm->avail_out == 0) return (last) ? finish_started : need_more; \
+}
+
+/* Maximum stored block length in deflate format (not including header). */
+#define MAX_STORED 65535
+
+/* Minimum of a and b. */
+#define MIN(a, b) ((a) > (b) ? (b) : (a))
+
+/* ===========================================================================
+ * Copy without compression as much as possible from the input stream, return
+ * the current block state.
+ *
+ * In case deflateParams() is used to later switch to a non-zero compression
+ * level, s->matches (otherwise unused when storing) keeps track of the number
+ * of hash table slides to perform. If s->matches is 1, then one hash table
+ * slide will be done when switching. If s->matches is 2, the maximum value
+ * allowed here, then the hash table will be cleared, since two or more slides
+ * is the same as a clear.
+ *
+ * deflate_stored() is written to minimize the number of times an input byte is
+ * copied. It is most efficient with large input and output buffers, which
+ * maximizes the opportunites to have a single copy from next_in to next_out.
+ */
+local block_state deflate_stored(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ /* Smallest worthy block size when not flushing or finishing. By default
+ * this is 32K. This can be as small as 507 bytes for memLevel == 1. For
+ * large input and output buffers, the stored block size will be larger.
+ */
+ unsigned min_block = MIN(s->pending_buf_size - 5, s->w_size);
+
+ /* Copy as many min_block or larger stored blocks directly to next_out as
+ * possible. If flushing, copy the remaining available input to next_out as
+ * stored blocks, if there is enough space.
+ */
+ unsigned len, left, have, last = 0;
+ unsigned used = s->strm->avail_in;
+ do {
+ /* Set len to the maximum size block that we can copy directly with the
+ * available input data and output space. Set left to how much of that
+ * would be copied from what's left in the window.
+ */
+ len = MAX_STORED; /* maximum deflate stored block length */
+ have = (s->bi_valid + 42) >> 3; /* number of header bytes */
+ if (s->strm->avail_out < have) /* need room for header */
+ break;
+ /* maximum stored block length that will fit in avail_out: */
+ have = s->strm->avail_out - have;
+ left = s->strstart - s->block_start; /* bytes left in window */
+ if (len > (ulg)left + s->strm->avail_in)
+ len = left + s->strm->avail_in; /* limit len to the input */
+ if (len > have)
+ len = have; /* limit len to the output */
+
+ /* If the stored block would be less than min_block in length, or if
+ * unable to copy all of the available input when flushing, then try
+ * copying to the window and the pending buffer instead. Also don't
+ * write an empty block when flushing -- deflate() does that.
+ */
+ if (len < min_block && ((len == 0 && flush != Z_FINISH) ||
+ flush == Z_NO_FLUSH ||
+ len != left + s->strm->avail_in))
+ break;
+
+ /* Make a dummy stored block in pending to get the header bytes,
+ * including any pending bits. This also updates the debugging counts.
+ */
+ last = flush == Z_FINISH && len == left + s->strm->avail_in ? 1 : 0;
+ _tr_stored_block(s, (char *)0, 0L, last);
+
+ /* Replace the lengths in the dummy stored block with len. */
+ s->pending_buf[s->pending - 4] = len;
+ s->pending_buf[s->pending - 3] = len >> 8;
+ s->pending_buf[s->pending - 2] = ~len;
+ s->pending_buf[s->pending - 1] = ~len >> 8;
+
+ /* Write the stored block header bytes. */
+ flush_pending(s->strm);
+
+#ifdef ZLIB_DEBUG
+ /* Update debugging counts for the data about to be copied. */
+ s->compressed_len += len << 3;
+ s->bits_sent += len << 3;
+#endif
+
+ /* Copy uncompressed bytes from the window to next_out. */
+ if (left) {
+ if (left > len)
+ left = len;
+ zmemcpy(s->strm->next_out, s->window + s->block_start, left);
+ s->strm->next_out += left;
+ s->strm->avail_out -= left;
+ s->strm->total_out += left;
+ s->block_start += left;
+ len -= left;
+ }
+
+ /* Copy uncompressed bytes directly from next_in to next_out, updating
+ * the check value.
+ */
+ if (len) {
+ read_buf(s->strm, s->strm->next_out, len);
+ s->strm->next_out += len;
+ s->strm->avail_out -= len;
+ s->strm->total_out += len;
+ }
+ } while (last == 0);
+
+ /* Update the sliding window with the last s->w_size bytes of the copied
+ * data, or append all of the copied data to the existing window if less
+ * than s->w_size bytes were copied. Also update the number of bytes to
+ * insert in the hash tables, in the event that deflateParams() switches to
+ * a non-zero compression level.
+ */
+ used -= s->strm->avail_in; /* number of input bytes directly copied */
+ if (used) {
+ /* If any input was used, then no unused input remains in the window,
+ * therefore s->block_start == s->strstart.
+ */
+ if (used >= s->w_size) { /* supplant the previous history */
+ s->matches = 2; /* clear hash */
+ zmemcpy(s->window, s->strm->next_in - s->w_size, s->w_size);
+ s->strstart = s->w_size;
+ }
+ else {
+ if (s->window_size - s->strstart <= used) {
+ /* Slide the window down. */
+ s->strstart -= s->w_size;
+ zmemcpy(s->window, s->window + s->w_size, s->strstart);
+ if (s->matches < 2)
+ s->matches++; /* add a pending slide_hash() */
+ }
+ zmemcpy(s->window + s->strstart, s->strm->next_in - used, used);
+ s->strstart += used;
+ }
+ s->block_start = s->strstart;
+ s->insert += MIN(used, s->w_size - s->insert);
+ }
+ if (s->high_water < s->strstart)
+ s->high_water = s->strstart;
+
+ /* If the last block was written to next_out, then done. */
+ if (last)
+ return finish_done;
+
+ /* If flushing and all input has been consumed, then done. */
+ if (flush != Z_NO_FLUSH && flush != Z_FINISH &&
+ s->strm->avail_in == 0 && (long)s->strstart == s->block_start)
+ return block_done;
+
+ /* Fill the window with any remaining input. */
+ have = s->window_size - s->strstart - 1;
+ if (s->strm->avail_in > have && s->block_start >= (long)s->w_size) {
+ /* Slide the window down. */
+ s->block_start -= s->w_size;
+ s->strstart -= s->w_size;
+ zmemcpy(s->window, s->window + s->w_size, s->strstart);
+ if (s->matches < 2)
+ s->matches++; /* add a pending slide_hash() */
+ have += s->w_size; /* more space now */
+ }
+ if (have > s->strm->avail_in)
+ have = s->strm->avail_in;
+ if (have) {
+ read_buf(s->strm, s->window + s->strstart, have);
+ s->strstart += have;
+ }
+ if (s->high_water < s->strstart)
+ s->high_water = s->strstart;
+
+ /* There was not enough avail_out to write a complete worthy or flushed
+ * stored block to next_out. Write a stored block to pending instead, if we
+ * have enough input for a worthy block, or if flushing and there is enough
+ * room for the remaining input as a stored block in the pending buffer.
+ */
+ have = (s->bi_valid + 42) >> 3; /* number of header bytes */
+ /* maximum stored block length that will fit in pending: */
+ have = MIN(s->pending_buf_size - have, MAX_STORED);
+ min_block = MIN(have, s->w_size);
+ left = s->strstart - s->block_start;
+ if (left >= min_block ||
+ ((left || flush == Z_FINISH) && flush != Z_NO_FLUSH &&
+ s->strm->avail_in == 0 && left <= have)) {
+ len = MIN(left, have);
+ last = flush == Z_FINISH && s->strm->avail_in == 0 &&
+ len == left ? 1 : 0;
+ _tr_stored_block(s, (charf *)s->window + s->block_start, len, last);
+ s->block_start += len;
+ flush_pending(s->strm);
+ }
+
+ /* We've done all we can with the available input and output. */
+ return last ? finish_started : need_more;
+}
+
+/* ===========================================================================
+ * Compress as much as possible from the input stream, return the current
+ * block state.
+ * This function does not perform lazy evaluation of matches and inserts
+ * new strings in the dictionary only for unmatched strings or for short
+ * matches. It is used only for the fast compression options.
+ */
+local block_state deflate_fast(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ IPos hash_head; /* head of the hash chain */
+ int bflush; /* set if current block must be flushed */
+
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the next match, plus MIN_MATCH bytes to insert the
+ * string following the next match.
+ */
+ if (s->lookahead < MIN_LOOKAHEAD) {
+ fill_window(s);
+ if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* Insert the string window[strstart .. strstart+2] in the
+ * dictionary, and set hash_head to the head of the hash chain:
+ */
+ hash_head = NIL;
+ if (s->lookahead >= MIN_MATCH) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+
+ /* Find the longest match, discarding those <= prev_length.
+ * At this point we have always match_length < MIN_MATCH
+ */
+ if (hash_head != NIL && s->strstart - hash_head <= MAX_DIST(s)) {
+ /* To simplify the code, we prevent matches with the string
+ * of window index 0 (in particular we have to avoid a match
+ * of the string with itself at the start of the input file).
+ */
+ s->match_length = longest_match (s, hash_head);
+ /* longest_match() sets match_start */
+ }
+ if (s->match_length >= MIN_MATCH) {
+ check_match(s, s->strstart, s->match_start, s->match_length);
+
+ _tr_tally_dist(s, s->strstart - s->match_start,
+ s->match_length - MIN_MATCH, bflush);
+
+ s->lookahead -= s->match_length;
+
+ /* Insert new strings in the hash table only if the match length
+ * is not too large. This saves time but degrades compression.
+ */
+#ifndef FASTEST
+ if (s->match_length <= s->max_insert_length &&
+ s->lookahead >= MIN_MATCH) {
+ s->match_length--; /* string at strstart already in table */
+ do {
+ s->strstart++;
+ INSERT_STRING(s, s->strstart, hash_head);
+ /* strstart never exceeds WSIZE-MAX_MATCH, so there are
+ * always MIN_MATCH bytes ahead.
+ */
+ } while (--s->match_length != 0);
+ s->strstart++;
+ } else
+#endif
+ {
+ s->strstart += s->match_length;
+ s->match_length = 0;
+ s->ins_h = s->window[s->strstart];
+ UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]);
+#if MIN_MATCH != 3
+ Call UPDATE_HASH() MIN_MATCH-3 more times
+#endif
+ /* If lookahead < MIN_MATCH, ins_h is garbage, but it does not
+ * matter since it will be recomputed at next deflate call.
+ */
+ }
+ } else {
+ /* No match, output a literal byte */
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ }
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ s->insert = s->strstart < MIN_MATCH-1 ? s->strstart : MIN_MATCH-1;
+ if (flush == Z_FINISH) {
+ FLUSH_BLOCK(s, 1);
+ return finish_done;
+ }
+ if (s->last_lit)
+ FLUSH_BLOCK(s, 0);
+ return block_done;
+}
+
+#ifndef FASTEST
+/* ===========================================================================
+ * Same as above, but achieves better compression. We use a lazy
+ * evaluation for matches: a match is finally adopted only if there is
+ * no better match at the next window position.
+ */
+local block_state deflate_slow(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ IPos hash_head; /* head of hash chain */
+ int bflush; /* set if current block must be flushed */
+
+ /* Process the input block. */
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the next match, plus MIN_MATCH bytes to insert the
+ * string following the next match.
+ */
+ if (s->lookahead < MIN_LOOKAHEAD) {
+ fill_window(s);
+ if (s->lookahead < MIN_LOOKAHEAD && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* Insert the string window[strstart .. strstart+2] in the
+ * dictionary, and set hash_head to the head of the hash chain:
+ */
+ hash_head = NIL;
+ if (s->lookahead >= MIN_MATCH) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+
+ /* Find the longest match, discarding those <= prev_length.
+ */
+ s->prev_length = s->match_length, s->prev_match = s->match_start;
+ s->match_length = MIN_MATCH-1;
+
+ if (hash_head != NIL && s->prev_length < s->max_lazy_match &&
+ s->strstart - hash_head <= MAX_DIST(s)) {
+ /* To simplify the code, we prevent matches with the string
+ * of window index 0 (in particular we have to avoid a match
+ * of the string with itself at the start of the input file).
+ */
+ s->match_length = longest_match (s, hash_head);
+ /* longest_match() sets match_start */
+
+ if (s->match_length <= 5 && (s->strategy == Z_FILTERED
+#if TOO_FAR <= 32767
+ || (s->match_length == MIN_MATCH &&
+ s->strstart - s->match_start > TOO_FAR)
+#endif
+ )) {
+
+ /* If prev_match is also MIN_MATCH, match_start is garbage
+ * but we will ignore the current match anyway.
+ */
+ s->match_length = MIN_MATCH-1;
+ }
+ }
+ /* If there was a match at the previous step and the current
+ * match is not better, output the previous match:
+ */
+ if (s->prev_length >= MIN_MATCH && s->match_length <= s->prev_length) {
+ uInt max_insert = s->strstart + s->lookahead - MIN_MATCH;
+ /* Do not insert strings in hash table beyond this. */
+
+ check_match(s, s->strstart-1, s->prev_match, s->prev_length);
+
+ _tr_tally_dist(s, s->strstart -1 - s->prev_match,
+ s->prev_length - MIN_MATCH, bflush);
+
+ /* Insert in hash table all strings up to the end of the match.
+ * strstart-1 and strstart are already inserted. If there is not
+ * enough lookahead, the last two strings are not inserted in
+ * the hash table.
+ */
+ s->lookahead -= s->prev_length-1;
+ s->prev_length -= 2;
+ do {
+ if (++s->strstart <= max_insert) {
+ INSERT_STRING(s, s->strstart, hash_head);
+ }
+ } while (--s->prev_length != 0);
+ s->match_available = 0;
+ s->match_length = MIN_MATCH-1;
+ s->strstart++;
+
+ if (bflush) FLUSH_BLOCK(s, 0);
+
+ } else if (s->match_available) {
+ /* If there was no match at the previous position, output a
+ * single literal. If there was a match but the current match
+ * is longer, truncate the previous match to a single literal.
+ */
+ Tracevv((stderr,"%c", s->window[s->strstart-1]));
+ _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+ if (bflush) {
+ FLUSH_BLOCK_ONLY(s, 0);
+ }
+ s->strstart++;
+ s->lookahead--;
+ if (s->strm->avail_out == 0) return need_more;
+ } else {
+ /* There is no previous match to compare with, wait for
+ * the next step to decide.
+ */
+ s->match_available = 1;
+ s->strstart++;
+ s->lookahead--;
+ }
+ }
+ Assert (flush != Z_NO_FLUSH, "no flush?");
+ if (s->match_available) {
+ Tracevv((stderr,"%c", s->window[s->strstart-1]));
+ _tr_tally_lit(s, s->window[s->strstart-1], bflush);
+ s->match_available = 0;
+ }
+ s->insert = s->strstart < MIN_MATCH-1 ? s->strstart : MIN_MATCH-1;
+ if (flush == Z_FINISH) {
+ FLUSH_BLOCK(s, 1);
+ return finish_done;
+ }
+ if (s->last_lit)
+ FLUSH_BLOCK(s, 0);
+ return block_done;
+}
+#endif /* FASTEST */
+
+/* ===========================================================================
+ * For Z_RLE, simply look for runs of bytes, generate matches only of distance
+ * one. Do not maintain a hash table. (It will be regenerated if this run of
+ * deflate switches away from Z_RLE.)
+ */
+local block_state deflate_rle(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ int bflush; /* set if current block must be flushed */
+ uInt prev; /* byte at distance one to match */
+ Bytef *scan, *strend; /* scan goes up to strend for length of run */
+
+ for (;;) {
+ /* Make sure that we always have enough lookahead, except
+ * at the end of the input file. We need MAX_MATCH bytes
+ * for the longest run, plus one for the unrolled loop.
+ */
+ if (s->lookahead <= MAX_MATCH) {
+ fill_window(s);
+ if (s->lookahead <= MAX_MATCH && flush == Z_NO_FLUSH) {
+ return need_more;
+ }
+ if (s->lookahead == 0) break; /* flush the current block */
+ }
+
+ /* See how many times the previous byte repeats */
+ s->match_length = 0;
+ if (s->lookahead >= MIN_MATCH && s->strstart > 0) {
+ scan = s->window + s->strstart - 1;
+ prev = *scan;
+ if (prev == *++scan && prev == *++scan && prev == *++scan) {
+ strend = s->window + s->strstart + MAX_MATCH;
+ do {
+ } while (prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ prev == *++scan && prev == *++scan &&
+ scan < strend);
+ s->match_length = MAX_MATCH - (uInt)(strend - scan);
+ if (s->match_length > s->lookahead)
+ s->match_length = s->lookahead;
+ }
+ Assert(scan <= s->window+(uInt)(s->window_size-1), "wild scan");
+ }
+
+ /* Emit match if have run of MIN_MATCH or longer, else emit literal */
+ if (s->match_length >= MIN_MATCH) {
+ check_match(s, s->strstart, s->strstart - 1, s->match_length);
+
+ _tr_tally_dist(s, 1, s->match_length - MIN_MATCH, bflush);
+
+ s->lookahead -= s->match_length;
+ s->strstart += s->match_length;
+ s->match_length = 0;
+ } else {
+ /* No match, output a literal byte */
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ }
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ s->insert = 0;
+ if (flush == Z_FINISH) {
+ FLUSH_BLOCK(s, 1);
+ return finish_done;
+ }
+ if (s->last_lit)
+ FLUSH_BLOCK(s, 0);
+ return block_done;
+}
+
+/* ===========================================================================
+ * For Z_HUFFMAN_ONLY, do not look for matches. Do not maintain a hash table.
+ * (It will be regenerated if this run of deflate switches away from Huffman.)
+ */
+local block_state deflate_huff(s, flush)
+ deflate_state *s;
+ int flush;
+{
+ int bflush; /* set if current block must be flushed */
+
+ for (;;) {
+ /* Make sure that we have a literal to write. */
+ if (s->lookahead == 0) {
+ fill_window(s);
+ if (s->lookahead == 0) {
+ if (flush == Z_NO_FLUSH)
+ return need_more;
+ break; /* flush the current block */
+ }
+ }
+
+ /* Output a literal byte */
+ s->match_length = 0;
+ Tracevv((stderr,"%c", s->window[s->strstart]));
+ _tr_tally_lit (s, s->window[s->strstart], bflush);
+ s->lookahead--;
+ s->strstart++;
+ if (bflush) FLUSH_BLOCK(s, 0);
+ }
+ s->insert = 0;
+ if (flush == Z_FINISH) {
+ FLUSH_BLOCK(s, 1);
+ return finish_done;
+ }
+ if (s->last_lit)
+ FLUSH_BLOCK(s, 0);
+ return block_done;
+}
diff --git a/test/monniaux/zlib-1.2.11/deflate.h b/test/monniaux/zlib-1.2.11/deflate.h
new file mode 100644
index 00000000..23ecdd31
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/deflate.h
@@ -0,0 +1,349 @@
+/* deflate.h -- internal compression state
+ * Copyright (C) 1995-2016 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* @(#) $Id$ */
+
+#ifndef DEFLATE_H
+#define DEFLATE_H
+
+#include "zutil.h"
+
+/* define NO_GZIP when compiling if you want to disable gzip header and
+ trailer creation by deflate(). NO_GZIP would be used to avoid linking in
+ the crc code when it is not needed. For shared libraries, gzip encoding
+ should be left enabled. */
+#ifndef NO_GZIP
+# define GZIP
+#endif
+
+/* ===========================================================================
+ * Internal compression state.
+ */
+
+#define LENGTH_CODES 29
+/* number of length codes, not counting the special END_BLOCK code */
+
+#define LITERALS 256
+/* number of literal bytes 0..255 */
+
+#define L_CODES (LITERALS+1+LENGTH_CODES)
+/* number of Literal or Length codes, including the END_BLOCK code */
+
+#define D_CODES 30
+/* number of distance codes */
+
+#define BL_CODES 19
+/* number of codes used to transfer the bit lengths */
+
+#define HEAP_SIZE (2*L_CODES+1)
+/* maximum heap size */
+
+#define MAX_BITS 15
+/* All codes must not exceed MAX_BITS bits */
+
+#define Buf_size 16
+/* size of bit buffer in bi_buf */
+
+#define INIT_STATE 42 /* zlib header -> BUSY_STATE */
+#ifdef GZIP
+# define GZIP_STATE 57 /* gzip header -> BUSY_STATE | EXTRA_STATE */
+#endif
+#define EXTRA_STATE 69 /* gzip extra block -> NAME_STATE */
+#define NAME_STATE 73 /* gzip file name -> COMMENT_STATE */
+#define COMMENT_STATE 91 /* gzip comment -> HCRC_STATE */
+#define HCRC_STATE 103 /* gzip header CRC -> BUSY_STATE */
+#define BUSY_STATE 113 /* deflate -> FINISH_STATE */
+#define FINISH_STATE 666 /* stream complete */
+/* Stream status */
+
+
+/* Data structure describing a single value and its code string. */
+typedef struct ct_data_s {
+ union {
+ ush freq; /* frequency count */
+ ush code; /* bit string */
+ } fc;
+ union {
+ ush dad; /* father node in Huffman tree */
+ ush len; /* length of bit string */
+ } dl;
+} FAR ct_data;
+
+#define Freq fc.freq
+#define Code fc.code
+#define Dad dl.dad
+#define Len dl.len
+
+typedef struct static_tree_desc_s static_tree_desc;
+
+typedef struct tree_desc_s {
+ ct_data *dyn_tree; /* the dynamic tree */
+ int max_code; /* largest code with non zero frequency */
+ const static_tree_desc *stat_desc; /* the corresponding static tree */
+} FAR tree_desc;
+
+typedef ush Pos;
+typedef Pos FAR Posf;
+typedef unsigned IPos;
+
+/* A Pos is an index in the character window. We use short instead of int to
+ * save space in the various tables. IPos is used only for parameter passing.
+ */
+
+typedef struct internal_state {
+ z_streamp strm; /* pointer back to this zlib stream */
+ int status; /* as the name implies */
+ Bytef *pending_buf; /* output still pending */
+ ulg pending_buf_size; /* size of pending_buf */
+ Bytef *pending_out; /* next pending byte to output to the stream */
+ ulg pending; /* nb of bytes in the pending buffer */
+ int wrap; /* bit 0 true for zlib, bit 1 true for gzip */
+ gz_headerp gzhead; /* gzip header information to write */
+ ulg gzindex; /* where in extra, name, or comment */
+ Byte method; /* can only be DEFLATED */
+ int last_flush; /* value of flush param for previous deflate call */
+
+ /* used by deflate.c: */
+
+ uInt w_size; /* LZ77 window size (32K by default) */
+ uInt w_bits; /* log2(w_size) (8..16) */
+ uInt w_mask; /* w_size - 1 */
+
+ Bytef *window;
+ /* Sliding window. Input bytes are read into the second half of the window,
+ * and move to the first half later to keep a dictionary of at least wSize
+ * bytes. With this organization, matches are limited to a distance of
+ * wSize-MAX_MATCH bytes, but this ensures that IO is always
+ * performed with a length multiple of the block size. Also, it limits
+ * the window size to 64K, which is quite useful on MSDOS.
+ * To do: use the user input buffer as sliding window.
+ */
+
+ ulg window_size;
+ /* Actual size of window: 2*wSize, except when the user input buffer
+ * is directly used as sliding window.
+ */
+
+ Posf *prev;
+ /* Link to older string with same hash index. To limit the size of this
+ * array to 64K, this link is maintained only for the last 32K strings.
+ * An index in this array is thus a window index modulo 32K.
+ */
+
+ Posf *head; /* Heads of the hash chains or NIL. */
+
+ uInt ins_h; /* hash index of string to be inserted */
+ uInt hash_size; /* number of elements in hash table */
+ uInt hash_bits; /* log2(hash_size) */
+ uInt hash_mask; /* hash_size-1 */
+
+ uInt hash_shift;
+ /* Number of bits by which ins_h must be shifted at each input
+ * step. It must be such that after MIN_MATCH steps, the oldest
+ * byte no longer takes part in the hash key, that is:
+ * hash_shift * MIN_MATCH >= hash_bits
+ */
+
+ long block_start;
+ /* Window position at the beginning of the current output block. Gets
+ * negative when the window is moved backwards.
+ */
+
+ uInt match_length; /* length of best match */
+ IPos prev_match; /* previous match */
+ int match_available; /* set if previous match exists */
+ uInt strstart; /* start of string to insert */
+ uInt match_start; /* start of matching string */
+ uInt lookahead; /* number of valid bytes ahead in window */
+
+ uInt prev_length;
+ /* Length of the best match at previous step. Matches not greater than this
+ * are discarded. This is used in the lazy match evaluation.
+ */
+
+ uInt max_chain_length;
+ /* To speed up deflation, hash chains are never searched beyond this
+ * length. A higher limit improves compression ratio but degrades the
+ * speed.
+ */
+
+ uInt max_lazy_match;
+ /* Attempt to find a better match only when the current match is strictly
+ * smaller than this value. This mechanism is used only for compression
+ * levels >= 4.
+ */
+# define max_insert_length max_lazy_match
+ /* Insert new strings in the hash table only if the match length is not
+ * greater than this length. This saves time but degrades compression.
+ * max_insert_length is used only for compression levels <= 3.
+ */
+
+ int level; /* compression level (1..9) */
+ int strategy; /* favor or force Huffman coding*/
+
+ uInt good_match;
+ /* Use a faster search when the previous match is longer than this */
+
+ int nice_match; /* Stop searching when current match exceeds this */
+
+ /* used by trees.c: */
+ /* Didn't use ct_data typedef below to suppress compiler warning */
+ struct ct_data_s dyn_ltree[HEAP_SIZE]; /* literal and length tree */
+ struct ct_data_s dyn_dtree[2*D_CODES+1]; /* distance tree */
+ struct ct_data_s bl_tree[2*BL_CODES+1]; /* Huffman tree for bit lengths */
+
+ struct tree_desc_s l_desc; /* desc. for literal tree */
+ struct tree_desc_s d_desc; /* desc. for distance tree */
+ struct tree_desc_s bl_desc; /* desc. for bit length tree */
+
+ ush bl_count[MAX_BITS+1];
+ /* number of codes at each bit length for an optimal tree */
+
+ int heap[2*L_CODES+1]; /* heap used to build the Huffman trees */
+ int heap_len; /* number of elements in the heap */
+ int heap_max; /* element of largest frequency */
+ /* The sons of heap[n] are heap[2*n] and heap[2*n+1]. heap[0] is not used.
+ * The same heap array is used to build all trees.
+ */
+
+ uch depth[2*L_CODES+1];
+ /* Depth of each subtree used as tie breaker for trees of equal frequency
+ */
+
+ uchf *l_buf; /* buffer for literals or lengths */
+
+ uInt lit_bufsize;
+ /* Size of match buffer for literals/lengths. There are 4 reasons for
+ * limiting lit_bufsize to 64K:
+ * - frequencies can be kept in 16 bit counters
+ * - if compression is not successful for the first block, all input
+ * data is still in the window so we can still emit a stored block even
+ * when input comes from standard input. (This can also be done for
+ * all blocks if lit_bufsize is not greater than 32K.)
+ * - if compression is not successful for a file smaller than 64K, we can
+ * even emit a stored file instead of a stored block (saving 5 bytes).
+ * This is applicable only for zip (not gzip or zlib).
+ * - creating new Huffman trees less frequently may not provide fast
+ * adaptation to changes in the input data statistics. (Take for
+ * example a binary file with poorly compressible code followed by
+ * a highly compressible string table.) Smaller buffer sizes give
+ * fast adaptation but have of course the overhead of transmitting
+ * trees more frequently.
+ * - I can't count above 4
+ */
+
+ uInt last_lit; /* running index in l_buf */
+
+ ushf *d_buf;
+ /* Buffer for distances. To simplify the code, d_buf and l_buf have
+ * the same number of elements. To use different lengths, an extra flag
+ * array would be necessary.
+ */
+
+ ulg opt_len; /* bit length of current block with optimal trees */
+ ulg static_len; /* bit length of current block with static trees */
+ uInt matches; /* number of string matches in current block */
+ uInt insert; /* bytes at end of window left to insert */
+
+#ifdef ZLIB_DEBUG
+ ulg compressed_len; /* total bit length of compressed file mod 2^32 */
+ ulg bits_sent; /* bit length of compressed data sent mod 2^32 */
+#endif
+
+ ush bi_buf;
+ /* Output buffer. bits are inserted starting at the bottom (least
+ * significant bits).
+ */
+ int bi_valid;
+ /* Number of valid bits in bi_buf. All bits above the last valid bit
+ * are always zero.
+ */
+
+ ulg high_water;
+ /* High water mark offset in window for initialized bytes -- bytes above
+ * this are set to zero in order to avoid memory check warnings when
+ * longest match routines access bytes past the input. This is then
+ * updated to the new high water mark.
+ */
+
+} FAR deflate_state;
+
+/* Output a byte on the stream.
+ * IN assertion: there is enough room in pending_buf.
+ */
+#define put_byte(s, c) {s->pending_buf[s->pending++] = (Bytef)(c);}
+
+
+#define MIN_LOOKAHEAD (MAX_MATCH+MIN_MATCH+1)
+/* Minimum amount of lookahead, except at the end of the input file.
+ * See deflate.c for comments about the MIN_MATCH+1.
+ */
+
+#define MAX_DIST(s) ((s)->w_size-MIN_LOOKAHEAD)
+/* In order to simplify the code, particularly on 16 bit machines, match
+ * distances are limited to MAX_DIST instead of WSIZE.
+ */
+
+#define WIN_INIT MAX_MATCH
+/* Number of bytes after end of data in window to initialize in order to avoid
+ memory checker errors from longest match routines */
+
+ /* in trees.c */
+void ZLIB_INTERNAL _tr_init OF((deflate_state *s));
+int ZLIB_INTERNAL _tr_tally OF((deflate_state *s, unsigned dist, unsigned lc));
+void ZLIB_INTERNAL _tr_flush_block OF((deflate_state *s, charf *buf,
+ ulg stored_len, int last));
+void ZLIB_INTERNAL _tr_flush_bits OF((deflate_state *s));
+void ZLIB_INTERNAL _tr_align OF((deflate_state *s));
+void ZLIB_INTERNAL _tr_stored_block OF((deflate_state *s, charf *buf,
+ ulg stored_len, int last));
+
+#define d_code(dist) \
+ ((dist) < 256 ? _dist_code[dist] : _dist_code[256+((dist)>>7)])
+/* Mapping from a distance to a distance code. dist is the distance - 1 and
+ * must not have side effects. _dist_code[256] and _dist_code[257] are never
+ * used.
+ */
+
+#ifndef ZLIB_DEBUG
+/* Inline versions of _tr_tally for speed: */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+ extern uch ZLIB_INTERNAL _length_code[];
+ extern uch ZLIB_INTERNAL _dist_code[];
+#else
+ extern const uch ZLIB_INTERNAL _length_code[];
+ extern const uch ZLIB_INTERNAL _dist_code[];
+#endif
+
+# define _tr_tally_lit(s, c, flush) \
+ { uch cc = (c); \
+ s->d_buf[s->last_lit] = 0; \
+ s->l_buf[s->last_lit++] = cc; \
+ s->dyn_ltree[cc].Freq++; \
+ flush = (s->last_lit == s->lit_bufsize-1); \
+ }
+# define _tr_tally_dist(s, distance, length, flush) \
+ { uch len = (uch)(length); \
+ ush dist = (ush)(distance); \
+ s->d_buf[s->last_lit] = dist; \
+ s->l_buf[s->last_lit++] = len; \
+ dist--; \
+ s->dyn_ltree[_length_code[len]+LITERALS+1].Freq++; \
+ s->dyn_dtree[d_code(dist)].Freq++; \
+ flush = (s->last_lit == s->lit_bufsize-1); \
+ }
+#else
+# define _tr_tally_lit(s, c, flush) flush = _tr_tally(s, 0, c)
+# define _tr_tally_dist(s, distance, length, flush) \
+ flush = _tr_tally(s, distance, length)
+#endif
+
+#endif /* DEFLATE_H */
diff --git a/test/monniaux/zlib-1.2.11/gzclose.c b/test/monniaux/zlib-1.2.11/gzclose.c
new file mode 100644
index 00000000..caeb99a3
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/gzclose.c
@@ -0,0 +1,25 @@
+/* gzclose.c -- zlib gzclose() function
+ * Copyright (C) 2004, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* gzclose() is in a separate file so that it is linked in only if it is used.
+ That way the other gzclose functions can be used instead to avoid linking in
+ unneeded compression or decompression routines. */
+int ZEXPORT gzclose(file)
+ gzFile file;
+{
+#ifndef NO_GZCOMPRESS
+ gz_statep state;
+
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ return state->mode == GZ_READ ? gzclose_r(file) : gzclose_w(file);
+#else
+ return gzclose_r(file);
+#endif
+}
diff --git a/test/monniaux/zlib-1.2.11/gzguts.h b/test/monniaux/zlib-1.2.11/gzguts.h
new file mode 100644
index 00000000..990a4d25
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/gzguts.h
@@ -0,0 +1,218 @@
+/* gzguts.h -- zlib internal header definitions for gz* operations
+ * Copyright (C) 2004, 2005, 2010, 2011, 2012, 2013, 2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#ifdef _LARGEFILE64_SOURCE
+# ifndef _LARGEFILE_SOURCE
+# define _LARGEFILE_SOURCE 1
+# endif
+# ifdef _FILE_OFFSET_BITS
+# undef _FILE_OFFSET_BITS
+# endif
+#endif
+
+#ifdef HAVE_HIDDEN
+# define ZLIB_INTERNAL __attribute__((visibility ("hidden")))
+#else
+# define ZLIB_INTERNAL
+#endif
+
+#include <stdio.h>
+#include "zlib.h"
+#ifdef STDC
+# include <string.h>
+# include <stdlib.h>
+# include <limits.h>
+#endif
+
+#ifndef _POSIX_SOURCE
+# define _POSIX_SOURCE
+#endif
+#include <fcntl.h>
+
+#ifdef _WIN32
+# include <stddef.h>
+#endif
+
+#if defined(__TURBOC__) || defined(_MSC_VER) || defined(_WIN32)
+# include <io.h>
+#endif
+
+#if defined(_WIN32) || defined(__CYGWIN__)
+# define WIDECHAR
+#endif
+
+#ifdef WINAPI_FAMILY
+# define open _open
+# define read _read
+# define write _write
+# define close _close
+#endif
+
+#ifdef NO_DEFLATE /* for compatibility with old definition */
+# define NO_GZCOMPRESS
+#endif
+
+#if defined(STDC99) || (defined(__TURBOC__) && __TURBOC__ >= 0x550)
+# ifndef HAVE_VSNPRINTF
+# define HAVE_VSNPRINTF
+# endif
+#endif
+
+#if defined(__CYGWIN__)
+# ifndef HAVE_VSNPRINTF
+# define HAVE_VSNPRINTF
+# endif
+#endif
+
+#if defined(MSDOS) && defined(__BORLANDC__) && (BORLANDC > 0x410)
+# ifndef HAVE_VSNPRINTF
+# define HAVE_VSNPRINTF
+# endif
+#endif
+
+#ifndef HAVE_VSNPRINTF
+# ifdef MSDOS
+/* vsnprintf may exist on some MS-DOS compilers (DJGPP?),
+ but for now we just assume it doesn't. */
+# define NO_vsnprintf
+# endif
+# ifdef __TURBOC__
+# define NO_vsnprintf
+# endif
+# ifdef WIN32
+/* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */
+# if !defined(vsnprintf) && !defined(NO_vsnprintf)
+# if !defined(_MSC_VER) || ( defined(_MSC_VER) && _MSC_VER < 1500 )
+# define vsnprintf _vsnprintf
+# endif
+# endif
+# endif
+# ifdef __SASC
+# define NO_vsnprintf
+# endif
+# ifdef VMS
+# define NO_vsnprintf
+# endif
+# ifdef __OS400__
+# define NO_vsnprintf
+# endif
+# ifdef __MVS__
+# define NO_vsnprintf
+# endif
+#endif
+
+/* unlike snprintf (which is required in C99), _snprintf does not guarantee
+ null termination of the result -- however this is only used in gzlib.c where
+ the result is assured to fit in the space provided */
+#if defined(_MSC_VER) && _MSC_VER < 1900
+# define snprintf _snprintf
+#endif
+
+#ifndef local
+# define local static
+#endif
+/* since "static" is used to mean two completely different things in C, we
+ define "local" for the non-static meaning of "static", for readability
+ (compile with -Dlocal if your debugger can't find static symbols) */
+
+/* gz* functions always use library allocation functions */
+#ifndef STDC
+ extern voidp malloc OF((uInt size));
+ extern void free OF((voidpf ptr));
+#endif
+
+/* get errno and strerror definition */
+#if defined UNDER_CE
+# include <windows.h>
+# define zstrerror() gz_strwinerror((DWORD)GetLastError())
+#else
+# ifndef NO_STRERROR
+# include <errno.h>
+# define zstrerror() strerror(errno)
+# else
+# define zstrerror() "stdio error (consult errno)"
+# endif
+#endif
+
+/* provide prototypes for these when building zlib without LFS */
+#if !defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int));
+ ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile));
+#endif
+
+/* default memLevel */
+#if MAX_MEM_LEVEL >= 8
+# define DEF_MEM_LEVEL 8
+#else
+# define DEF_MEM_LEVEL MAX_MEM_LEVEL
+#endif
+
+/* default i/o buffer size -- double this for output when reading (this and
+ twice this must be able to fit in an unsigned type) */
+#define GZBUFSIZE 8192
+
+/* gzip modes, also provide a little integrity check on the passed structure */
+#define GZ_NONE 0
+#define GZ_READ 7247
+#define GZ_WRITE 31153
+#define GZ_APPEND 1 /* mode set to GZ_WRITE after the file is opened */
+
+/* values for gz_state how */
+#define LOOK 0 /* look for a gzip header */
+#define COPY 1 /* copy input directly */
+#define GZIP 2 /* decompress a gzip stream */
+
+/* internal gzip file state data structure */
+typedef struct {
+ /* exposed contents for gzgetc() macro */
+ struct gzFile_s x; /* "x" for exposed */
+ /* x.have: number of bytes available at x.next */
+ /* x.next: next output data to deliver or write */
+ /* x.pos: current position in uncompressed data */
+ /* used for both reading and writing */
+ int mode; /* see gzip modes above */
+ int fd; /* file descriptor */
+ char *path; /* path or fd for error messages */
+ unsigned size; /* buffer size, zero if not allocated yet */
+ unsigned want; /* requested buffer size, default is GZBUFSIZE */
+ unsigned char *in; /* input buffer (double-sized when writing) */
+ unsigned char *out; /* output buffer (double-sized when reading) */
+ int direct; /* 0 if processing gzip, 1 if transparent */
+ /* just for reading */
+ int how; /* 0: get header, 1: copy, 2: decompress */
+ z_off64_t start; /* where the gzip data started, for rewinding */
+ int eof; /* true if end of input file reached */
+ int past; /* true if read requested past end */
+ /* just for writing */
+ int level; /* compression level */
+ int strategy; /* compression strategy */
+ /* seek request */
+ z_off64_t skip; /* amount to skip (already rewound if backwards) */
+ int seek; /* true if seek request pending */
+ /* error information */
+ int err; /* error code */
+ char *msg; /* error message */
+ /* zlib inflate or deflate stream */
+ z_stream strm; /* stream structure in-place (not a pointer) */
+} gz_state;
+typedef gz_state FAR *gz_statep;
+
+/* shared functions */
+void ZLIB_INTERNAL gz_error OF((gz_statep, int, const char *));
+#if defined UNDER_CE
+char ZLIB_INTERNAL *gz_strwinerror OF((DWORD error));
+#endif
+
+/* GT_OFF(x), where x is an unsigned value, is true if x > maximum z_off64_t
+ value -- needed when comparing unsigned to z_off64_t, which is signed
+ (possible z_off64_t types off_t, off64_t, and long are all signed) */
+#ifdef INT_MAX
+# define GT_OFF(x) (sizeof(int) == sizeof(z_off64_t) && (x) > INT_MAX)
+#else
+unsigned ZLIB_INTERNAL gz_intmax OF((void));
+# define GT_OFF(x) (sizeof(int) == sizeof(z_off64_t) && (x) > gz_intmax())
+#endif
diff --git a/test/monniaux/zlib-1.2.11/gzlib.c b/test/monniaux/zlib-1.2.11/gzlib.c
new file mode 100644
index 00000000..4105e6af
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/gzlib.c
@@ -0,0 +1,637 @@
+/* gzlib.c -- zlib functions common to reading and writing gzip files
+ * Copyright (C) 2004-2017 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+#if defined(_WIN32) && !defined(__BORLANDC__) && !defined(__MINGW32__)
+# define LSEEK _lseeki64
+#else
+#if defined(_LARGEFILE64_SOURCE) && _LFS64_LARGEFILE-0
+# define LSEEK lseek64
+#else
+# define LSEEK lseek
+#endif
+#endif
+
+/* Local functions */
+local void gz_reset OF((gz_statep));
+local gzFile gz_open OF((const void *, int, const char *));
+
+#if defined UNDER_CE
+
+/* Map the Windows error number in ERROR to a locale-dependent error message
+ string and return a pointer to it. Typically, the values for ERROR come
+ from GetLastError.
+
+ The string pointed to shall not be modified by the application, but may be
+ overwritten by a subsequent call to gz_strwinerror
+
+ The gz_strwinerror function does not change the current setting of
+ GetLastError. */
+char ZLIB_INTERNAL *gz_strwinerror (error)
+ DWORD error;
+{
+ static char buf[1024];
+
+ wchar_t *msgbuf;
+ DWORD lasterr = GetLastError();
+ DWORD chars = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL,
+ error,
+ 0, /* Default language */
+ (LPVOID)&msgbuf,
+ 0,
+ NULL);
+ if (chars != 0) {
+ /* If there is an \r\n appended, zap it. */
+ if (chars >= 2
+ && msgbuf[chars - 2] == '\r' && msgbuf[chars - 1] == '\n') {
+ chars -= 2;
+ msgbuf[chars] = 0;
+ }
+
+ if (chars > sizeof (buf) - 1) {
+ chars = sizeof (buf) - 1;
+ msgbuf[chars] = 0;
+ }
+
+ wcstombs(buf, msgbuf, chars + 1);
+ LocalFree(msgbuf);
+ }
+ else {
+ sprintf(buf, "unknown win32 error (%ld)", error);
+ }
+
+ SetLastError(lasterr);
+ return buf;
+}
+
+#endif /* UNDER_CE */
+
+/* Reset gzip file state */
+local void gz_reset(state)
+ gz_statep state;
+{
+ state->x.have = 0; /* no output data available */
+ if (state->mode == GZ_READ) { /* for reading ... */
+ state->eof = 0; /* not at end of file */
+ state->past = 0; /* have not read past end yet */
+ state->how = LOOK; /* look for gzip header */
+ }
+ state->seek = 0; /* no seek request pending */
+ gz_error(state, Z_OK, NULL); /* clear error */
+ state->x.pos = 0; /* no uncompressed data yet */
+ state->strm.avail_in = 0; /* no input data yet */
+}
+
+/* Open a gzip file either by name or file descriptor. */
+local gzFile gz_open(path, fd, mode)
+ const void *path;
+ int fd;
+ const char *mode;
+{
+ gz_statep state;
+ z_size_t len;
+ int oflag;
+#ifdef O_CLOEXEC
+ int cloexec = 0;
+#endif
+#ifdef O_EXCL
+ int exclusive = 0;
+#endif
+
+ /* check input */
+ if (path == NULL)
+ return NULL;
+
+ /* allocate gzFile structure to return */
+ state = (gz_statep)malloc(sizeof(gz_state));
+ if (state == NULL)
+ return NULL;
+ state->size = 0; /* no buffers allocated yet */
+ state->want = GZBUFSIZE; /* requested buffer size */
+ state->msg = NULL; /* no error message yet */
+
+ /* interpret mode */
+ state->mode = GZ_NONE;
+ state->level = Z_DEFAULT_COMPRESSION;
+ state->strategy = Z_DEFAULT_STRATEGY;
+ state->direct = 0;
+ while (*mode) {
+ if (*mode >= '0' && *mode <= '9')
+ state->level = *mode - '0';
+ else
+ switch (*mode) {
+ case 'r':
+ state->mode = GZ_READ;
+ break;
+#ifndef NO_GZCOMPRESS
+ case 'w':
+ state->mode = GZ_WRITE;
+ break;
+ case 'a':
+ state->mode = GZ_APPEND;
+ break;
+#endif
+ case '+': /* can't read and write at the same time */
+ free(state);
+ return NULL;
+ case 'b': /* ignore -- will request binary anyway */
+ break;
+#ifdef O_CLOEXEC
+ case 'e':
+ cloexec = 1;
+ break;
+#endif
+#ifdef O_EXCL
+ case 'x':
+ exclusive = 1;
+ break;
+#endif
+ case 'f':
+ state->strategy = Z_FILTERED;
+ break;
+ case 'h':
+ state->strategy = Z_HUFFMAN_ONLY;
+ break;
+ case 'R':
+ state->strategy = Z_RLE;
+ break;
+ case 'F':
+ state->strategy = Z_FIXED;
+ break;
+ case 'T':
+ state->direct = 1;
+ break;
+ default: /* could consider as an error, but just ignore */
+ ;
+ }
+ mode++;
+ }
+
+ /* must provide an "r", "w", or "a" */
+ if (state->mode == GZ_NONE) {
+ free(state);
+ return NULL;
+ }
+
+ /* can't force transparent read */
+ if (state->mode == GZ_READ) {
+ if (state->direct) {
+ free(state);
+ return NULL;
+ }
+ state->direct = 1; /* for empty file */
+ }
+
+ /* save the path name for error messages */
+#ifdef WIDECHAR
+ if (fd == -2) {
+ len = wcstombs(NULL, path, 0);
+ if (len == (z_size_t)-1)
+ len = 0;
+ }
+ else
+#endif
+ len = strlen((const char *)path);
+ state->path = (char *)malloc(len + 1);
+ if (state->path == NULL) {
+ free(state);
+ return NULL;
+ }
+#ifdef WIDECHAR
+ if (fd == -2)
+ if (len)
+ wcstombs(state->path, path, len + 1);
+ else
+ *(state->path) = 0;
+ else
+#endif
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ (void)snprintf(state->path, len + 1, "%s", (const char *)path);
+#else
+ strcpy(state->path, path);
+#endif
+
+ /* compute the flags for open() */
+ oflag =
+#ifdef O_LARGEFILE
+ O_LARGEFILE |
+#endif
+#ifdef O_BINARY
+ O_BINARY |
+#endif
+#ifdef O_CLOEXEC
+ (cloexec ? O_CLOEXEC : 0) |
+#endif
+ (state->mode == GZ_READ ?
+ O_RDONLY :
+ (O_WRONLY | O_CREAT |
+#ifdef O_EXCL
+ (exclusive ? O_EXCL : 0) |
+#endif
+ (state->mode == GZ_WRITE ?
+ O_TRUNC :
+ O_APPEND)));
+
+ /* open the file with the appropriate flags (or just use fd) */
+ state->fd = fd > -1 ? fd : (
+#ifdef WIDECHAR
+ fd == -2 ? _wopen(path, oflag, 0666) :
+#endif
+ open((const char *)path, oflag, 0666));
+ if (state->fd == -1) {
+ free(state->path);
+ free(state);
+ return NULL;
+ }
+ if (state->mode == GZ_APPEND) {
+ LSEEK(state->fd, 0, SEEK_END); /* so gzoffset() is correct */
+ state->mode = GZ_WRITE; /* simplify later checks */
+ }
+
+ /* save the current position for rewinding (only if reading) */
+ if (state->mode == GZ_READ) {
+ state->start = LSEEK(state->fd, 0, SEEK_CUR);
+ if (state->start == -1) state->start = 0;
+ }
+
+ /* initialize stream */
+ gz_reset(state);
+
+ /* return stream */
+ return (gzFile)state;
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzopen(path, mode)
+ const char *path;
+ const char *mode;
+{
+ return gz_open(path, -1, mode);
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzopen64(path, mode)
+ const char *path;
+ const char *mode;
+{
+ return gz_open(path, -1, mode);
+}
+
+/* -- see zlib.h -- */
+gzFile ZEXPORT gzdopen(fd, mode)
+ int fd;
+ const char *mode;
+{
+ char *path; /* identifier for error messages */
+ gzFile gz;
+
+ if (fd == -1 || (path = (char *)malloc(7 + 3 * sizeof(int))) == NULL)
+ return NULL;
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ (void)snprintf(path, 7 + 3 * sizeof(int), "<fd:%d>", fd);
+#else
+ sprintf(path, "<fd:%d>", fd); /* for debugging */
+#endif
+ gz = gz_open(path, fd, mode);
+ free(path);
+ return gz;
+}
+
+/* -- see zlib.h -- */
+#ifdef WIDECHAR
+gzFile ZEXPORT gzopen_w(path, mode)
+ const wchar_t *path;
+ const char *mode;
+{
+ return gz_open(path, -2, mode);
+}
+#endif
+
+/* -- see zlib.h -- */
+int ZEXPORT gzbuffer(file, size)
+ gzFile file;
+ unsigned size;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* make sure we haven't already allocated memory */
+ if (state->size != 0)
+ return -1;
+
+ /* check and set requested size */
+ if ((size << 1) < size)
+ return -1; /* need to be able to double it */
+ if (size < 2)
+ size = 2; /* need two bytes to check magic header */
+ state->want = size;
+ return 0;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzrewind(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return -1;
+
+ /* back up and start over */
+ if (LSEEK(state->fd, state->start, SEEK_SET) == -1)
+ return -1;
+ gz_reset(state);
+ return 0;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gzseek64(file, offset, whence)
+ gzFile file;
+ z_off64_t offset;
+ int whence;
+{
+ unsigned n;
+ z_off64_t ret;
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* check that there's no error */
+ if (state->err != Z_OK && state->err != Z_BUF_ERROR)
+ return -1;
+
+ /* can only seek from start or relative to current position */
+ if (whence != SEEK_SET && whence != SEEK_CUR)
+ return -1;
+
+ /* normalize offset to a SEEK_CUR specification */
+ if (whence == SEEK_SET)
+ offset -= state->x.pos;
+ else if (state->seek)
+ offset += state->skip;
+ state->seek = 0;
+
+ /* if within raw area while reading, just go there */
+ if (state->mode == GZ_READ && state->how == COPY &&
+ state->x.pos + offset >= 0) {
+ ret = LSEEK(state->fd, offset - state->x.have, SEEK_CUR);
+ if (ret == -1)
+ return -1;
+ state->x.have = 0;
+ state->eof = 0;
+ state->past = 0;
+ state->seek = 0;
+ gz_error(state, Z_OK, NULL);
+ state->strm.avail_in = 0;
+ state->x.pos += offset;
+ return state->x.pos;
+ }
+
+ /* calculate skip amount, rewinding if needed for back seek when reading */
+ if (offset < 0) {
+ if (state->mode != GZ_READ) /* writing -- can't go backwards */
+ return -1;
+ offset += state->x.pos;
+ if (offset < 0) /* before start of file! */
+ return -1;
+ if (gzrewind(file) == -1) /* rewind, then skip to offset */
+ return -1;
+ }
+
+ /* if reading, skip what's in output buffer (one less gzgetc() check) */
+ if (state->mode == GZ_READ) {
+ n = GT_OFF(state->x.have) || (z_off64_t)state->x.have > offset ?
+ (unsigned)offset : state->x.have;
+ state->x.have -= n;
+ state->x.next += n;
+ state->x.pos += n;
+ offset -= n;
+ }
+
+ /* request skip (if not zero) */
+ if (offset) {
+ state->seek = 1;
+ state->skip = offset;
+ }
+ return state->x.pos + offset;
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gzseek(file, offset, whence)
+ gzFile file;
+ z_off_t offset;
+ int whence;
+{
+ z_off64_t ret;
+
+ ret = gzseek64(file, (z_off64_t)offset, whence);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gztell64(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* return position */
+ return state->x.pos + (state->seek ? state->skip : 0);
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gztell(file)
+ gzFile file;
+{
+ z_off64_t ret;
+
+ ret = gztell64(file);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+z_off64_t ZEXPORT gzoffset64(file)
+ gzFile file;
+{
+ z_off64_t offset;
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return -1;
+
+ /* compute and return effective offset in file */
+ offset = LSEEK(state->fd, 0, SEEK_CUR);
+ if (offset == -1)
+ return -1;
+ if (state->mode == GZ_READ) /* reading */
+ offset -= state->strm.avail_in; /* don't count buffered input */
+ return offset;
+}
+
+/* -- see zlib.h -- */
+z_off_t ZEXPORT gzoffset(file)
+ gzFile file;
+{
+ z_off64_t ret;
+
+ ret = gzoffset64(file);
+ return ret == (z_off_t)ret ? (z_off_t)ret : -1;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzeof(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return 0;
+
+ /* return end-of-file state */
+ return state->mode == GZ_READ ? state->past : 0;
+}
+
+/* -- see zlib.h -- */
+const char * ZEXPORT gzerror(file, errnum)
+ gzFile file;
+ int *errnum;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return NULL;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return NULL;
+
+ /* return error information */
+ if (errnum != NULL)
+ *errnum = state->err;
+ return state->err == Z_MEM_ERROR ? "out of memory" :
+ (state->msg == NULL ? "" : state->msg);
+}
+
+/* -- see zlib.h -- */
+void ZEXPORT gzclearerr(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure and check integrity */
+ if (file == NULL)
+ return;
+ state = (gz_statep)file;
+ if (state->mode != GZ_READ && state->mode != GZ_WRITE)
+ return;
+
+ /* clear error and end-of-file */
+ if (state->mode == GZ_READ) {
+ state->eof = 0;
+ state->past = 0;
+ }
+ gz_error(state, Z_OK, NULL);
+}
+
+/* Create an error message in allocated memory and set state->err and
+ state->msg accordingly. Free any previous error message already there. Do
+ not try to free or allocate space if the error is Z_MEM_ERROR (out of
+ memory). Simply save the error message as a static string. If there is an
+ allocation failure constructing the error message, then convert the error to
+ out of memory. */
+void ZLIB_INTERNAL gz_error(state, err, msg)
+ gz_statep state;
+ int err;
+ const char *msg;
+{
+ /* free previously allocated message and clear */
+ if (state->msg != NULL) {
+ if (state->err != Z_MEM_ERROR)
+ free(state->msg);
+ state->msg = NULL;
+ }
+
+ /* if fatal, set state->x.have to 0 so that the gzgetc() macro fails */
+ if (err != Z_OK && err != Z_BUF_ERROR)
+ state->x.have = 0;
+
+ /* set error code, and if no message, then done */
+ state->err = err;
+ if (msg == NULL)
+ return;
+
+ /* for an out of memory error, return literal string when requested */
+ if (err == Z_MEM_ERROR)
+ return;
+
+ /* construct error message with path */
+ if ((state->msg = (char *)malloc(strlen(state->path) + strlen(msg) + 3)) ==
+ NULL) {
+ state->err = Z_MEM_ERROR;
+ return;
+ }
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ (void)snprintf(state->msg, strlen(state->path) + strlen(msg) + 3,
+ "%s%s%s", state->path, ": ", msg);
+#else
+ strcpy(state->msg, state->path);
+ strcat(state->msg, ": ");
+ strcat(state->msg, msg);
+#endif
+}
+
+#ifndef INT_MAX
+/* portably return maximum value for an int (when limits.h presumed not
+ available) -- we need to do this to cover cases where 2's complement not
+ used, since C standard permits 1's complement and sign-bit representations,
+ otherwise we could just use ((unsigned)-1) >> 1 */
+unsigned ZLIB_INTERNAL gz_intmax()
+{
+ unsigned p, q;
+
+ p = 1;
+ do {
+ q = p;
+ p <<= 1;
+ p++;
+ } while (p > q);
+ return q >> 1;
+}
+#endif
diff --git a/test/monniaux/zlib-1.2.11/gzread.c b/test/monniaux/zlib-1.2.11/gzread.c
new file mode 100644
index 00000000..956b91ea
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/gzread.c
@@ -0,0 +1,654 @@
+/* gzread.c -- zlib functions for reading gzip files
+ * Copyright (C) 2004, 2005, 2010, 2011, 2012, 2013, 2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* Local functions */
+local int gz_load OF((gz_statep, unsigned char *, unsigned, unsigned *));
+local int gz_avail OF((gz_statep));
+local int gz_look OF((gz_statep));
+local int gz_decomp OF((gz_statep));
+local int gz_fetch OF((gz_statep));
+local int gz_skip OF((gz_statep, z_off64_t));
+local z_size_t gz_read OF((gz_statep, voidp, z_size_t));
+
+/* Use read() to load a buffer -- return -1 on error, otherwise 0. Read from
+ state->fd, and update state->eof, state->err, and state->msg as appropriate.
+ This function needs to loop on read(), since read() is not guaranteed to
+ read the number of bytes requested, depending on the type of descriptor. */
+local int gz_load(state, buf, len, have)
+ gz_statep state;
+ unsigned char *buf;
+ unsigned len;
+ unsigned *have;
+{
+ int ret;
+ unsigned get, max = ((unsigned)-1 >> 2) + 1;
+
+ *have = 0;
+ do {
+ get = len - *have;
+ if (get > max)
+ get = max;
+ ret = read(state->fd, buf + *have, get);
+ if (ret <= 0)
+ break;
+ *have += (unsigned)ret;
+ } while (*have < len);
+ if (ret < 0) {
+ gz_error(state, Z_ERRNO, zstrerror());
+ return -1;
+ }
+ if (ret == 0)
+ state->eof = 1;
+ return 0;
+}
+
+/* Load up input buffer and set eof flag if last data loaded -- return -1 on
+ error, 0 otherwise. Note that the eof flag is set when the end of the input
+ file is reached, even though there may be unused data in the buffer. Once
+ that data has been used, no more attempts will be made to read the file.
+ If strm->avail_in != 0, then the current data is moved to the beginning of
+ the input buffer, and then the remainder of the buffer is loaded with the
+ available data from the input file. */
+local int gz_avail(state)
+ gz_statep state;
+{
+ unsigned got;
+ z_streamp strm = &(state->strm);
+
+ if (state->err != Z_OK && state->err != Z_BUF_ERROR)
+ return -1;
+ if (state->eof == 0) {
+ if (strm->avail_in) { /* copy what's there to the start */
+ unsigned char *p = state->in;
+ unsigned const char *q = strm->next_in;
+ unsigned n = strm->avail_in;
+ do {
+ *p++ = *q++;
+ } while (--n);
+ }
+ if (gz_load(state, state->in + strm->avail_in,
+ state->size - strm->avail_in, &got) == -1)
+ return -1;
+ strm->avail_in += got;
+ strm->next_in = state->in;
+ }
+ return 0;
+}
+
+/* Look for gzip header, set up for inflate or copy. state->x.have must be 0.
+ If this is the first time in, allocate required memory. state->how will be
+ left unchanged if there is no more input data available, will be set to COPY
+ if there is no gzip header and direct copying will be performed, or it will
+ be set to GZIP for decompression. If direct copying, then leftover input
+ data from the input buffer will be copied to the output buffer. In that
+ case, all further file reads will be directly to either the output buffer or
+ a user buffer. If decompressing, the inflate state will be initialized.
+ gz_look() will return 0 on success or -1 on failure. */
+local int gz_look(state)
+ gz_statep state;
+{
+ z_streamp strm = &(state->strm);
+
+ /* allocate read buffers and inflate memory */
+ if (state->size == 0) {
+ /* allocate buffers */
+ state->in = (unsigned char *)malloc(state->want);
+ state->out = (unsigned char *)malloc(state->want << 1);
+ if (state->in == NULL || state->out == NULL) {
+ free(state->out);
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ state->size = state->want;
+
+ /* allocate inflate memory */
+ state->strm.zalloc = Z_NULL;
+ state->strm.zfree = Z_NULL;
+ state->strm.opaque = Z_NULL;
+ state->strm.avail_in = 0;
+ state->strm.next_in = Z_NULL;
+ if (inflateInit2(&(state->strm), 15 + 16) != Z_OK) { /* gunzip */
+ free(state->out);
+ free(state->in);
+ state->size = 0;
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ }
+
+ /* get at least the magic bytes in the input buffer */
+ if (strm->avail_in < 2) {
+ if (gz_avail(state) == -1)
+ return -1;
+ if (strm->avail_in == 0)
+ return 0;
+ }
+
+ /* look for gzip magic bytes -- if there, do gzip decoding (note: there is
+ a logical dilemma here when considering the case of a partially written
+ gzip file, to wit, if a single 31 byte is written, then we cannot tell
+ whether this is a single-byte file, or just a partially written gzip
+ file -- for here we assume that if a gzip file is being written, then
+ the header will be written in a single operation, so that reading a
+ single byte is sufficient indication that it is not a gzip file) */
+ if (strm->avail_in > 1 &&
+ strm->next_in[0] == 31 && strm->next_in[1] == 139) {
+ inflateReset(strm);
+ state->how = GZIP;
+ state->direct = 0;
+ return 0;
+ }
+
+ /* no gzip header -- if we were decoding gzip before, then this is trailing
+ garbage. Ignore the trailing garbage and finish. */
+ if (state->direct == 0) {
+ strm->avail_in = 0;
+ state->eof = 1;
+ state->x.have = 0;
+ return 0;
+ }
+
+ /* doing raw i/o, copy any leftover input to output -- this assumes that
+ the output buffer is larger than the input buffer, which also assures
+ space for gzungetc() */
+ state->x.next = state->out;
+ if (strm->avail_in) {
+ memcpy(state->x.next, strm->next_in, strm->avail_in);
+ state->x.have = strm->avail_in;
+ strm->avail_in = 0;
+ }
+ state->how = COPY;
+ state->direct = 1;
+ return 0;
+}
+
+/* Decompress from input to the provided next_out and avail_out in the state.
+ On return, state->x.have and state->x.next point to the just decompressed
+ data. If the gzip stream completes, state->how is reset to LOOK to look for
+ the next gzip stream or raw data, once state->x.have is depleted. Returns 0
+ on success, -1 on failure. */
+local int gz_decomp(state)
+ gz_statep state;
+{
+ int ret = Z_OK;
+ unsigned had;
+ z_streamp strm = &(state->strm);
+
+ /* fill output buffer up to end of deflate stream */
+ had = strm->avail_out;
+ do {
+ /* get more input for inflate() */
+ if (strm->avail_in == 0 && gz_avail(state) == -1)
+ return -1;
+ if (strm->avail_in == 0) {
+ gz_error(state, Z_BUF_ERROR, "unexpected end of file");
+ break;
+ }
+
+ /* decompress and handle errors */
+ ret = inflate(strm, Z_NO_FLUSH);
+ if (ret == Z_STREAM_ERROR || ret == Z_NEED_DICT) {
+ gz_error(state, Z_STREAM_ERROR,
+ "internal error: inflate stream corrupt");
+ return -1;
+ }
+ if (ret == Z_MEM_ERROR) {
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ if (ret == Z_DATA_ERROR) { /* deflate stream invalid */
+ gz_error(state, Z_DATA_ERROR,
+ strm->msg == NULL ? "compressed data error" : strm->msg);
+ return -1;
+ }
+ } while (strm->avail_out && ret != Z_STREAM_END);
+
+ /* update available output */
+ state->x.have = had - strm->avail_out;
+ state->x.next = strm->next_out - state->x.have;
+
+ /* if the gzip stream completed successfully, look for another */
+ if (ret == Z_STREAM_END)
+ state->how = LOOK;
+
+ /* good decompression */
+ return 0;
+}
+
+/* Fetch data and put it in the output buffer. Assumes state->x.have is 0.
+ Data is either copied from the input file or decompressed from the input
+ file depending on state->how. If state->how is LOOK, then a gzip header is
+ looked for to determine whether to copy or decompress. Returns -1 on error,
+ otherwise 0. gz_fetch() will leave state->how as COPY or GZIP unless the
+ end of the input file has been reached and all data has been processed. */
+local int gz_fetch(state)
+ gz_statep state;
+{
+ z_streamp strm = &(state->strm);
+
+ do {
+ switch(state->how) {
+ case LOOK: /* -> LOOK, COPY (only if never GZIP), or GZIP */
+ if (gz_look(state) == -1)
+ return -1;
+ if (state->how == LOOK)
+ return 0;
+ break;
+ case COPY: /* -> COPY */
+ if (gz_load(state, state->out, state->size << 1, &(state->x.have))
+ == -1)
+ return -1;
+ state->x.next = state->out;
+ return 0;
+ case GZIP: /* -> GZIP or LOOK (if end of gzip stream) */
+ strm->avail_out = state->size << 1;
+ strm->next_out = state->out;
+ if (gz_decomp(state) == -1)
+ return -1;
+ }
+ } while (state->x.have == 0 && (!state->eof || strm->avail_in));
+ return 0;
+}
+
+/* Skip len uncompressed bytes of output. Return -1 on error, 0 on success. */
+local int gz_skip(state, len)
+ gz_statep state;
+ z_off64_t len;
+{
+ unsigned n;
+
+ /* skip over len bytes or reach end-of-file, whichever comes first */
+ while (len)
+ /* skip over whatever is in output buffer */
+ if (state->x.have) {
+ n = GT_OFF(state->x.have) || (z_off64_t)state->x.have > len ?
+ (unsigned)len : state->x.have;
+ state->x.have -= n;
+ state->x.next += n;
+ state->x.pos += n;
+ len -= n;
+ }
+
+ /* output buffer empty -- return if we're at the end of the input */
+ else if (state->eof && state->strm.avail_in == 0)
+ break;
+
+ /* need more data to skip -- load up output buffer */
+ else {
+ /* get more output, looking for header if required */
+ if (gz_fetch(state) == -1)
+ return -1;
+ }
+ return 0;
+}
+
+/* Read len bytes into buf from file, or less than len up to the end of the
+ input. Return the number of bytes read. If zero is returned, either the
+ end of file was reached, or there was an error. state->err must be
+ consulted in that case to determine which. */
+local z_size_t gz_read(state, buf, len)
+ gz_statep state;
+ voidp buf;
+ z_size_t len;
+{
+ z_size_t got;
+ unsigned n;
+
+ /* if len is zero, avoid unnecessary operations */
+ if (len == 0)
+ return 0;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return 0;
+ }
+
+ /* get len bytes to buf, or less than len if at the end */
+ got = 0;
+ do {
+ /* set n to the maximum amount of len that fits in an unsigned int */
+ n = -1;
+ if (n > len)
+ n = len;
+
+ /* first just try copying data from the output buffer */
+ if (state->x.have) {
+ if (state->x.have < n)
+ n = state->x.have;
+ memcpy(buf, state->x.next, n);
+ state->x.next += n;
+ state->x.have -= n;
+ }
+
+ /* output buffer empty -- return if we're at the end of the input */
+ else if (state->eof && state->strm.avail_in == 0) {
+ state->past = 1; /* tried to read past end */
+ break;
+ }
+
+ /* need output data -- for small len or new stream load up our output
+ buffer */
+ else if (state->how == LOOK || n < (state->size << 1)) {
+ /* get more output, looking for header if required */
+ if (gz_fetch(state) == -1)
+ return 0;
+ continue; /* no progress yet -- go back to copy above */
+ /* the copy above assures that we will leave with space in the
+ output buffer, allowing at least one gzungetc() to succeed */
+ }
+
+ /* large len -- read directly into user buffer */
+ else if (state->how == COPY) { /* read directly */
+ if (gz_load(state, (unsigned char *)buf, n, &n) == -1)
+ return 0;
+ }
+
+ /* large len -- decompress directly into user buffer */
+ else { /* state->how == GZIP */
+ state->strm.avail_out = n;
+ state->strm.next_out = (unsigned char *)buf;
+ if (gz_decomp(state) == -1)
+ return 0;
+ n = state->x.have;
+ state->x.have = 0;
+ }
+
+ /* update progress */
+ len -= n;
+ buf = (char *)buf + n;
+ got += n;
+ state->x.pos += n;
+ } while (len);
+
+ /* return number of bytes read into user buffer */
+ return got;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzread(file, buf, len)
+ gzFile file;
+ voidp buf;
+ unsigned len;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no (serious) error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return -1;
+
+ /* since an int is returned, make sure len fits in one, otherwise return
+ with an error (this avoids a flaw in the interface) */
+ if ((int)len < 0) {
+ gz_error(state, Z_STREAM_ERROR, "request does not fit in an int");
+ return -1;
+ }
+
+ /* read len or fewer bytes to buf */
+ len = gz_read(state, buf, len);
+
+ /* check for an error */
+ if (len == 0 && state->err != Z_OK && state->err != Z_BUF_ERROR)
+ return -1;
+
+ /* return the number of bytes read (this is assured to fit in an int) */
+ return (int)len;
+}
+
+/* -- see zlib.h -- */
+z_size_t ZEXPORT gzfread(buf, size, nitems, file)
+ voidp buf;
+ z_size_t size;
+ z_size_t nitems;
+ gzFile file;
+{
+ z_size_t len;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no (serious) error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return 0;
+
+ /* compute bytes to read -- error on overflow */
+ len = nitems * size;
+ if (size && len / size != nitems) {
+ gz_error(state, Z_STREAM_ERROR, "request does not fit in a size_t");
+ return 0;
+ }
+
+ /* read len or fewer bytes to buf, return the number of full items read */
+ return len ? gz_read(state, buf, len) / size : 0;
+}
+
+/* -- see zlib.h -- */
+#ifdef Z_PREFIX_SET
+# undef z_gzgetc
+#else
+# undef gzgetc
+#endif
+int ZEXPORT gzgetc(file)
+ gzFile file;
+{
+ int ret;
+ unsigned char buf[1];
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no (serious) error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return -1;
+
+ /* try output buffer (no need to check for skip request) */
+ if (state->x.have) {
+ state->x.have--;
+ state->x.pos++;
+ return *(state->x.next)++;
+ }
+
+ /* nothing there -- try gz_read() */
+ ret = gz_read(state, buf, 1);
+ return ret < 1 ? -1 : buf[0];
+}
+
+int ZEXPORT gzgetc_(file)
+gzFile file;
+{
+ return gzgetc(file);
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzungetc(c, file)
+ int c;
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no (serious) error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return -1;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* can't push EOF */
+ if (c < 0)
+ return -1;
+
+ /* if output buffer empty, put byte at end (allows more pushing) */
+ if (state->x.have == 0) {
+ state->x.have = 1;
+ state->x.next = state->out + (state->size << 1) - 1;
+ state->x.next[0] = (unsigned char)c;
+ state->x.pos--;
+ state->past = 0;
+ return c;
+ }
+
+ /* if no room, give up (must have already done a gzungetc()) */
+ if (state->x.have == (state->size << 1)) {
+ gz_error(state, Z_DATA_ERROR, "out of room to push characters");
+ return -1;
+ }
+
+ /* slide output data if needed and insert byte before existing data */
+ if (state->x.next == state->out) {
+ unsigned char *src = state->out + state->x.have;
+ unsigned char *dest = state->out + (state->size << 1);
+ while (src > state->out)
+ *--dest = *--src;
+ state->x.next = dest;
+ }
+ state->x.have++;
+ state->x.next--;
+ state->x.next[0] = (unsigned char)c;
+ state->x.pos--;
+ state->past = 0;
+ return c;
+}
+
+/* -- see zlib.h -- */
+char * ZEXPORT gzgets(file, buf, len)
+ gzFile file;
+ char *buf;
+ int len;
+{
+ unsigned left, n;
+ char *str;
+ unsigned char *eol;
+ gz_statep state;
+
+ /* check parameters and get internal structure */
+ if (file == NULL || buf == NULL || len < 1)
+ return NULL;
+ state = (gz_statep)file;
+
+ /* check that we're reading and that there's no (serious) error */
+ if (state->mode != GZ_READ ||
+ (state->err != Z_OK && state->err != Z_BUF_ERROR))
+ return NULL;
+
+ /* process a skip request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_skip(state, state->skip) == -1)
+ return NULL;
+ }
+
+ /* copy output bytes up to new line or len - 1, whichever comes first --
+ append a terminating zero to the string (we don't check for a zero in
+ the contents, let the user worry about that) */
+ str = buf;
+ left = (unsigned)len - 1;
+ if (left) do {
+ /* assure that something is in the output buffer */
+ if (state->x.have == 0 && gz_fetch(state) == -1)
+ return NULL; /* error */
+ if (state->x.have == 0) { /* end of file */
+ state->past = 1; /* read past end */
+ break; /* return what we have */
+ }
+
+ /* look for end-of-line in current output buffer */
+ n = state->x.have > left ? left : state->x.have;
+ eol = (unsigned char *)memchr(state->x.next, '\n', n);
+ if (eol != NULL)
+ n = (unsigned)(eol - state->x.next) + 1;
+
+ /* copy through end-of-line, or remainder if not found */
+ memcpy(buf, state->x.next, n);
+ state->x.have -= n;
+ state->x.next += n;
+ state->x.pos += n;
+ left -= n;
+ buf += n;
+ } while (left && eol == NULL);
+
+ /* return terminated string, or if nothing, end of file */
+ if (buf == str)
+ return NULL;
+ buf[0] = 0;
+ return str;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzdirect(file)
+ gzFile file;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+
+ /* if the state is not known, but we can find out, then do so (this is
+ mainly for right after a gzopen() or gzdopen()) */
+ if (state->mode == GZ_READ && state->how == LOOK && state->x.have == 0)
+ (void)gz_look(state);
+
+ /* return 1 if transparent, 0 if processing a gzip stream */
+ return state->direct;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzclose_r(file)
+ gzFile file;
+{
+ int ret, err;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ /* check that we're reading */
+ if (state->mode != GZ_READ)
+ return Z_STREAM_ERROR;
+
+ /* free memory and close file */
+ if (state->size) {
+ inflateEnd(&(state->strm));
+ free(state->out);
+ free(state->in);
+ }
+ err = state->err == Z_BUF_ERROR ? Z_BUF_ERROR : Z_OK;
+ gz_error(state, Z_OK, NULL);
+ free(state->path);
+ ret = close(state->fd);
+ free(state);
+ return ret ? Z_ERRNO : err;
+}
diff --git a/test/monniaux/zlib-1.2.11/gzwrite.c b/test/monniaux/zlib-1.2.11/gzwrite.c
new file mode 100644
index 00000000..c7b5651d
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/gzwrite.c
@@ -0,0 +1,665 @@
+/* gzwrite.c -- zlib functions for writing gzip files
+ * Copyright (C) 2004-2017 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "gzguts.h"
+
+/* Local functions */
+local int gz_init OF((gz_statep));
+local int gz_comp OF((gz_statep, int));
+local int gz_zero OF((gz_statep, z_off64_t));
+local z_size_t gz_write OF((gz_statep, voidpc, z_size_t));
+
+/* Initialize state for writing a gzip file. Mark initialization by setting
+ state->size to non-zero. Return -1 on a memory allocation failure, or 0 on
+ success. */
+local int gz_init(state)
+ gz_statep state;
+{
+ int ret;
+ z_streamp strm = &(state->strm);
+
+ /* allocate input buffer (double size for gzprintf) */
+ state->in = (unsigned char *)malloc(state->want << 1);
+ if (state->in == NULL) {
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+
+ /* only need output buffer and deflate state if compressing */
+ if (!state->direct) {
+ /* allocate output buffer */
+ state->out = (unsigned char *)malloc(state->want);
+ if (state->out == NULL) {
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+
+ /* allocate deflate memory, set up for gzip compression */
+ strm->zalloc = Z_NULL;
+ strm->zfree = Z_NULL;
+ strm->opaque = Z_NULL;
+ ret = deflateInit2(strm, state->level, Z_DEFLATED,
+ MAX_WBITS + 16, DEF_MEM_LEVEL, state->strategy);
+ if (ret != Z_OK) {
+ free(state->out);
+ free(state->in);
+ gz_error(state, Z_MEM_ERROR, "out of memory");
+ return -1;
+ }
+ strm->next_in = NULL;
+ }
+
+ /* mark state as initialized */
+ state->size = state->want;
+
+ /* initialize write buffer if compressing */
+ if (!state->direct) {
+ strm->avail_out = state->size;
+ strm->next_out = state->out;
+ state->x.next = strm->next_out;
+ }
+ return 0;
+}
+
+/* Compress whatever is at avail_in and next_in and write to the output file.
+ Return -1 if there is an error writing to the output file or if gz_init()
+ fails to allocate memory, otherwise 0. flush is assumed to be a valid
+ deflate() flush value. If flush is Z_FINISH, then the deflate() state is
+ reset to start a new gzip stream. If gz->direct is true, then simply write
+ to the output file without compressing, and ignore flush. */
+local int gz_comp(state, flush)
+ gz_statep state;
+ int flush;
+{
+ int ret, writ;
+ unsigned have, put, max = ((unsigned)-1 >> 2) + 1;
+ z_streamp strm = &(state->strm);
+
+ /* allocate memory if this is the first time through */
+ if (state->size == 0 && gz_init(state) == -1)
+ return -1;
+
+ /* write directly if requested */
+ if (state->direct) {
+ while (strm->avail_in) {
+ put = strm->avail_in > max ? max : strm->avail_in;
+ writ = write(state->fd, strm->next_in, put);
+ if (writ < 0) {
+ gz_error(state, Z_ERRNO, zstrerror());
+ return -1;
+ }
+ strm->avail_in -= (unsigned)writ;
+ strm->next_in += writ;
+ }
+ return 0;
+ }
+
+ /* run deflate() on provided input until it produces no more output */
+ ret = Z_OK;
+ do {
+ /* write out current buffer contents if full, or if flushing, but if
+ doing Z_FINISH then don't write until we get to Z_STREAM_END */
+ if (strm->avail_out == 0 || (flush != Z_NO_FLUSH &&
+ (flush != Z_FINISH || ret == Z_STREAM_END))) {
+ while (strm->next_out > state->x.next) {
+ put = strm->next_out - state->x.next > (int)max ? max :
+ (unsigned)(strm->next_out - state->x.next);
+ writ = write(state->fd, state->x.next, put);
+ if (writ < 0) {
+ gz_error(state, Z_ERRNO, zstrerror());
+ return -1;
+ }
+ state->x.next += writ;
+ }
+ if (strm->avail_out == 0) {
+ strm->avail_out = state->size;
+ strm->next_out = state->out;
+ state->x.next = state->out;
+ }
+ }
+
+ /* compress */
+ have = strm->avail_out;
+ ret = deflate(strm, flush);
+ if (ret == Z_STREAM_ERROR) {
+ gz_error(state, Z_STREAM_ERROR,
+ "internal error: deflate stream corrupt");
+ return -1;
+ }
+ have -= strm->avail_out;
+ } while (have);
+
+ /* if that completed a deflate stream, allow another to start */
+ if (flush == Z_FINISH)
+ deflateReset(strm);
+
+ /* all done, no errors */
+ return 0;
+}
+
+/* Compress len zeros to output. Return -1 on a write error or memory
+ allocation failure by gz_comp(), or 0 on success. */
+local int gz_zero(state, len)
+ gz_statep state;
+ z_off64_t len;
+{
+ int first;
+ unsigned n;
+ z_streamp strm = &(state->strm);
+
+ /* consume whatever's left in the input buffer */
+ if (strm->avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return -1;
+
+ /* compress len zeros (len guaranteed > 0) */
+ first = 1;
+ while (len) {
+ n = GT_OFF(state->size) || (z_off64_t)state->size > len ?
+ (unsigned)len : state->size;
+ if (first) {
+ memset(state->in, 0, n);
+ first = 0;
+ }
+ strm->avail_in = n;
+ strm->next_in = state->in;
+ state->x.pos += n;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return -1;
+ len -= n;
+ }
+ return 0;
+}
+
+/* Write len bytes from buf to file. Return the number of bytes written. If
+ the returned value is less than len, then there was an error. */
+local z_size_t gz_write(state, buf, len)
+ gz_statep state;
+ voidpc buf;
+ z_size_t len;
+{
+ z_size_t put = len;
+
+ /* if len is zero, avoid unnecessary operations */
+ if (len == 0)
+ return 0;
+
+ /* allocate memory if this is the first time through */
+ if (state->size == 0 && gz_init(state) == -1)
+ return 0;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return 0;
+ }
+
+ /* for small len, copy to input buffer, otherwise compress directly */
+ if (len < state->size) {
+ /* copy to input buffer, compress when full */
+ do {
+ unsigned have, copy;
+
+ if (state->strm.avail_in == 0)
+ state->strm.next_in = state->in;
+ have = (unsigned)((state->strm.next_in + state->strm.avail_in) -
+ state->in);
+ copy = state->size - have;
+ if (copy > len)
+ copy = len;
+ memcpy(state->in + have, buf, copy);
+ state->strm.avail_in += copy;
+ state->x.pos += copy;
+ buf = (const char *)buf + copy;
+ len -= copy;
+ if (len && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+ } while (len);
+ }
+ else {
+ /* consume whatever's left in the input buffer */
+ if (state->strm.avail_in && gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+
+ /* directly compress user buffer to file */
+ state->strm.next_in = (z_const Bytef *)buf;
+ do {
+ unsigned n = (unsigned)-1;
+ if (n > len)
+ n = len;
+ state->strm.avail_in = n;
+ state->x.pos += n;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return 0;
+ len -= n;
+ } while (len);
+ }
+
+ /* input was all buffered or compressed */
+ return put;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzwrite(file, buf, len)
+ gzFile file;
+ voidpc buf;
+ unsigned len;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return 0;
+
+ /* since an int is returned, make sure len fits in one, otherwise return
+ with an error (this avoids a flaw in the interface) */
+ if ((int)len < 0) {
+ gz_error(state, Z_DATA_ERROR, "requested length does not fit in int");
+ return 0;
+ }
+
+ /* write len bytes from buf (the return value will fit in an int) */
+ return (int)gz_write(state, buf, len);
+}
+
+/* -- see zlib.h -- */
+z_size_t ZEXPORT gzfwrite(buf, size, nitems, file)
+ voidpc buf;
+ z_size_t size;
+ z_size_t nitems;
+ gzFile file;
+{
+ z_size_t len;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return 0;
+ state = (gz_statep)file;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return 0;
+
+ /* compute bytes to read -- error on overflow */
+ len = nitems * size;
+ if (size && len / size != nitems) {
+ gz_error(state, Z_STREAM_ERROR, "request does not fit in a size_t");
+ return 0;
+ }
+
+ /* write len bytes to buf, return the number of full items written */
+ return len ? gz_write(state, buf, len) / size : 0;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzputc(file, c)
+ gzFile file;
+ int c;
+{
+ unsigned have;
+ unsigned char buf[1];
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return -1;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return -1;
+ }
+
+ /* try writing to input buffer for speed (state->size == 0 if buffer not
+ initialized) */
+ if (state->size) {
+ if (strm->avail_in == 0)
+ strm->next_in = state->in;
+ have = (unsigned)((strm->next_in + strm->avail_in) - state->in);
+ if (have < state->size) {
+ state->in[have] = (unsigned char)c;
+ strm->avail_in++;
+ state->x.pos++;
+ return c & 0xff;
+ }
+ }
+
+ /* no room in buffer or not initialized, use gz_write() */
+ buf[0] = (unsigned char)c;
+ if (gz_write(state, buf, 1) != 1)
+ return -1;
+ return c & 0xff;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzputs(file, str)
+ gzFile file;
+ const char *str;
+{
+ int ret;
+ z_size_t len;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return -1;
+ state = (gz_statep)file;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return -1;
+
+ /* write string */
+ len = strlen(str);
+ ret = gz_write(state, str, len);
+ return ret == 0 && len != 0 ? -1 : ret;
+}
+
+#if defined(STDC) || defined(Z_HAVE_STDARG_H)
+#include <stdarg.h>
+
+/* -- see zlib.h -- */
+int ZEXPORTVA gzvprintf(gzFile file, const char *format, va_list va)
+{
+ int len;
+ unsigned left;
+ char *next;
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* make sure we have some buffer space */
+ if (state->size == 0 && gz_init(state) == -1)
+ return state->err;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return state->err;
+ }
+
+ /* do the printf() into the input buffer, put length in len -- the input
+ buffer is double-sized just for this function, so there is guaranteed to
+ be state->size bytes available after the current contents */
+ if (strm->avail_in == 0)
+ strm->next_in = state->in;
+ next = (char *)(state->in + (strm->next_in - state->in) + strm->avail_in);
+ next[state->size - 1] = 0;
+#ifdef NO_vsnprintf
+# ifdef HAS_vsprintf_void
+ (void)vsprintf(next, format, va);
+ for (len = 0; len < state->size; len++)
+ if (next[len] == 0) break;
+# else
+ len = vsprintf(next, format, va);
+# endif
+#else
+# ifdef HAS_vsnprintf_void
+ (void)vsnprintf(next, state->size, format, va);
+ len = strlen(next);
+# else
+ len = vsnprintf(next, state->size, format, va);
+# endif
+#endif
+
+ /* check that printf() results fit in buffer */
+ if (len == 0 || (unsigned)len >= state->size || next[state->size - 1] != 0)
+ return 0;
+
+ /* update buffer and position, compress first half if past that */
+ strm->avail_in += (unsigned)len;
+ state->x.pos += len;
+ if (strm->avail_in >= state->size) {
+ left = strm->avail_in - state->size;
+ strm->avail_in = state->size;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return state->err;
+ memcpy(state->in, state->in + state->size, left);
+ strm->next_in = state->in;
+ strm->avail_in = left;
+ }
+ return len;
+}
+
+int ZEXPORTVA gzprintf(gzFile file, const char *format, ...)
+{
+ va_list va;
+ int ret;
+
+ va_start(va, format);
+ ret = gzvprintf(file, format, va);
+ va_end(va);
+ return ret;
+}
+
+#else /* !STDC && !Z_HAVE_STDARG_H */
+
+/* -- see zlib.h -- */
+int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+ a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)
+ gzFile file;
+ const char *format;
+ int a1, a2, a3, a4, a5, a6, a7, a8, a9, a10,
+ a11, a12, a13, a14, a15, a16, a17, a18, a19, a20;
+{
+ unsigned len, left;
+ char *next;
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that can really pass pointer in ints */
+ if (sizeof(int) != sizeof(void *))
+ return Z_STREAM_ERROR;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* make sure we have some buffer space */
+ if (state->size == 0 && gz_init(state) == -1)
+ return state->error;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return state->error;
+ }
+
+ /* do the printf() into the input buffer, put length in len -- the input
+ buffer is double-sized just for this function, so there is guaranteed to
+ be state->size bytes available after the current contents */
+ if (strm->avail_in == 0)
+ strm->next_in = state->in;
+ next = (char *)(strm->next_in + strm->avail_in);
+ next[state->size - 1] = 0;
+#ifdef NO_snprintf
+# ifdef HAS_sprintf_void
+ sprintf(next, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12,
+ a13, a14, a15, a16, a17, a18, a19, a20);
+ for (len = 0; len < size; len++)
+ if (next[len] == 0)
+ break;
+# else
+ len = sprintf(next, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11,
+ a12, a13, a14, a15, a16, a17, a18, a19, a20);
+# endif
+#else
+# ifdef HAS_snprintf_void
+ snprintf(next, state->size, format, a1, a2, a3, a4, a5, a6, a7, a8, a9,
+ a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+ len = strlen(next);
+# else
+ len = snprintf(next, state->size, format, a1, a2, a3, a4, a5, a6, a7, a8,
+ a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20);
+# endif
+#endif
+
+ /* check that printf() results fit in buffer */
+ if (len == 0 || len >= state->size || next[state->size - 1] != 0)
+ return 0;
+
+ /* update buffer and position, compress first half if past that */
+ strm->avail_in += len;
+ state->x.pos += len;
+ if (strm->avail_in >= state->size) {
+ left = strm->avail_in - state->size;
+ strm->avail_in = state->size;
+ if (gz_comp(state, Z_NO_FLUSH) == -1)
+ return state->err;
+ memcpy(state->in, state->in + state->size, left);
+ strm->next_in = state->in;
+ strm->avail_in = left;
+ }
+ return (int)len;
+}
+
+#endif
+
+/* -- see zlib.h -- */
+int ZEXPORT gzflush(file, flush)
+ gzFile file;
+ int flush;
+{
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* check flush parameter */
+ if (flush < 0 || flush > Z_FINISH)
+ return Z_STREAM_ERROR;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return state->err;
+ }
+
+ /* compress remaining data with requested flush */
+ (void)gz_comp(state, flush);
+ return state->err;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzsetparams(file, level, strategy)
+ gzFile file;
+ int level;
+ int strategy;
+{
+ gz_statep state;
+ z_streamp strm;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+ strm = &(state->strm);
+
+ /* check that we're writing and that there's no error */
+ if (state->mode != GZ_WRITE || state->err != Z_OK)
+ return Z_STREAM_ERROR;
+
+ /* if no change is requested, then do nothing */
+ if (level == state->level && strategy == state->strategy)
+ return Z_OK;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ return state->err;
+ }
+
+ /* change compression parameters for subsequent input */
+ if (state->size) {
+ /* flush previous input with previous parameters before changing */
+ if (strm->avail_in && gz_comp(state, Z_BLOCK) == -1)
+ return state->err;
+ deflateParams(strm, level, strategy);
+ }
+ state->level = level;
+ state->strategy = strategy;
+ return Z_OK;
+}
+
+/* -- see zlib.h -- */
+int ZEXPORT gzclose_w(file)
+ gzFile file;
+{
+ int ret = Z_OK;
+ gz_statep state;
+
+ /* get internal structure */
+ if (file == NULL)
+ return Z_STREAM_ERROR;
+ state = (gz_statep)file;
+
+ /* check that we're writing */
+ if (state->mode != GZ_WRITE)
+ return Z_STREAM_ERROR;
+
+ /* check for seek request */
+ if (state->seek) {
+ state->seek = 0;
+ if (gz_zero(state, state->skip) == -1)
+ ret = state->err;
+ }
+
+ /* flush, free memory, and close file */
+ if (gz_comp(state, Z_FINISH) == -1)
+ ret = state->err;
+ if (state->size) {
+ if (!state->direct) {
+ (void)deflateEnd(&(state->strm));
+ free(state->out);
+ }
+ free(state->in);
+ }
+ gz_error(state, Z_OK, NULL);
+ free(state->path);
+ if (close(state->fd) == -1)
+ ret = Z_ERRNO;
+ free(state);
+ return ret;
+}
diff --git a/test/monniaux/zlib-1.2.11/infback.c b/test/monniaux/zlib-1.2.11/infback.c
new file mode 100644
index 00000000..59679ecb
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/infback.c
@@ -0,0 +1,640 @@
+/* infback.c -- inflate using a call-back interface
+ * Copyright (C) 1995-2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ This code is largely copied from inflate.c. Normally either infback.o or
+ inflate.o would be linked into an application--not both. The interface
+ with inffast.c is retained so that optimized assembler-coded versions of
+ inflate_fast() can be used with either inflate.c or infback.c.
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "inflate.h"
+#include "inffast.h"
+
+/* function prototypes */
+local void fixedtables OF((struct inflate_state FAR *state));
+
+/*
+ strm provides memory allocation functions in zalloc and zfree, or
+ Z_NULL to use the library memory allocation functions.
+
+ windowBits is in the range 8..15, and window is a user-supplied
+ window and output buffer that is 2**windowBits bytes.
+ */
+int ZEXPORT inflateBackInit_(strm, windowBits, window, version, stream_size)
+z_streamp strm;
+int windowBits;
+unsigned char FAR *window;
+const char *version;
+int stream_size;
+{
+ struct inflate_state FAR *state;
+
+ if (version == Z_NULL || version[0] != ZLIB_VERSION[0] ||
+ stream_size != (int)(sizeof(z_stream)))
+ return Z_VERSION_ERROR;
+ if (strm == Z_NULL || window == Z_NULL ||
+ windowBits < 8 || windowBits > 15)
+ return Z_STREAM_ERROR;
+ strm->msg = Z_NULL; /* in case we return an error */
+ if (strm->zalloc == (alloc_func)0) {
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zalloc = zcalloc;
+ strm->opaque = (voidpf)0;
+#endif
+ }
+ if (strm->zfree == (free_func)0)
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zfree = zcfree;
+#endif
+ state = (struct inflate_state FAR *)ZALLOC(strm, 1,
+ sizeof(struct inflate_state));
+ if (state == Z_NULL) return Z_MEM_ERROR;
+ Tracev((stderr, "inflate: allocated\n"));
+ strm->state = (struct internal_state FAR *)state;
+ state->dmax = 32768U;
+ state->wbits = (uInt)windowBits;
+ state->wsize = 1U << windowBits;
+ state->window = window;
+ state->wnext = 0;
+ state->whave = 0;
+ return Z_OK;
+}
+
+/*
+ Return state with length and distance decoding tables and index sizes set to
+ fixed code decoding. Normally this returns fixed tables from inffixed.h.
+ If BUILDFIXED is defined, then instead this routine builds the tables the
+ first time it's called, and returns those tables the first time and
+ thereafter. This reduces the size of the code by about 2K bytes, in
+ exchange for a little execution time. However, BUILDFIXED should not be
+ used for threaded applications, since the rewriting of the tables and virgin
+ may not be thread-safe.
+ */
+local void fixedtables(state)
+struct inflate_state FAR *state;
+{
+#ifdef BUILDFIXED
+ static int virgin = 1;
+ static code *lenfix, *distfix;
+ static code fixed[544];
+
+ /* build fixed huffman tables if first call (may not be thread safe) */
+ if (virgin) {
+ unsigned sym, bits;
+ static code *next;
+
+ /* literal/length table */
+ sym = 0;
+ while (sym < 144) state->lens[sym++] = 8;
+ while (sym < 256) state->lens[sym++] = 9;
+ while (sym < 280) state->lens[sym++] = 7;
+ while (sym < 288) state->lens[sym++] = 8;
+ next = fixed;
+ lenfix = next;
+ bits = 9;
+ inflate_table(LENS, state->lens, 288, &(next), &(bits), state->work);
+
+ /* distance table */
+ sym = 0;
+ while (sym < 32) state->lens[sym++] = 5;
+ distfix = next;
+ bits = 5;
+ inflate_table(DISTS, state->lens, 32, &(next), &(bits), state->work);
+
+ /* do this just once */
+ virgin = 0;
+ }
+#else /* !BUILDFIXED */
+# include "inffixed.h"
+#endif /* BUILDFIXED */
+ state->lencode = lenfix;
+ state->lenbits = 9;
+ state->distcode = distfix;
+ state->distbits = 5;
+}
+
+/* Macros for inflateBack(): */
+
+/* Load returned state from inflate_fast() */
+#define LOAD() \
+ do { \
+ put = strm->next_out; \
+ left = strm->avail_out; \
+ next = strm->next_in; \
+ have = strm->avail_in; \
+ hold = state->hold; \
+ bits = state->bits; \
+ } while (0)
+
+/* Set state from registers for inflate_fast() */
+#define RESTORE() \
+ do { \
+ strm->next_out = put; \
+ strm->avail_out = left; \
+ strm->next_in = next; \
+ strm->avail_in = have; \
+ state->hold = hold; \
+ state->bits = bits; \
+ } while (0)
+
+/* Clear the input bit accumulator */
+#define INITBITS() \
+ do { \
+ hold = 0; \
+ bits = 0; \
+ } while (0)
+
+/* Assure that some input is available. If input is requested, but denied,
+ then return a Z_BUF_ERROR from inflateBack(). */
+#define PULL() \
+ do { \
+ if (have == 0) { \
+ have = in(in_desc, &next); \
+ if (have == 0) { \
+ next = Z_NULL; \
+ ret = Z_BUF_ERROR; \
+ goto inf_leave; \
+ } \
+ } \
+ } while (0)
+
+/* Get a byte of input into the bit accumulator, or return from inflateBack()
+ with an error if there is no input available. */
+#define PULLBYTE() \
+ do { \
+ PULL(); \
+ have--; \
+ hold += (unsigned long)(*next++) << bits; \
+ bits += 8; \
+ } while (0)
+
+/* Assure that there are at least n bits in the bit accumulator. If there is
+ not enough available input to do that, then return from inflateBack() with
+ an error. */
+#define NEEDBITS(n) \
+ do { \
+ while (bits < (unsigned)(n)) \
+ PULLBYTE(); \
+ } while (0)
+
+/* Return the low n bits of the bit accumulator (n < 16) */
+#define BITS(n) \
+ ((unsigned)hold & ((1U << (n)) - 1))
+
+/* Remove n bits from the bit accumulator */
+#define DROPBITS(n) \
+ do { \
+ hold >>= (n); \
+ bits -= (unsigned)(n); \
+ } while (0)
+
+/* Remove zero to seven bits as needed to go to a byte boundary */
+#define BYTEBITS() \
+ do { \
+ hold >>= bits & 7; \
+ bits -= bits & 7; \
+ } while (0)
+
+/* Assure that some output space is available, by writing out the window
+ if it's full. If the write fails, return from inflateBack() with a
+ Z_BUF_ERROR. */
+#define ROOM() \
+ do { \
+ if (left == 0) { \
+ put = state->window; \
+ left = state->wsize; \
+ state->whave = left; \
+ if (out(out_desc, put, left)) { \
+ ret = Z_BUF_ERROR; \
+ goto inf_leave; \
+ } \
+ } \
+ } while (0)
+
+/*
+ strm provides the memory allocation functions and window buffer on input,
+ and provides information on the unused input on return. For Z_DATA_ERROR
+ returns, strm will also provide an error message.
+
+ in() and out() are the call-back input and output functions. When
+ inflateBack() needs more input, it calls in(). When inflateBack() has
+ filled the window with output, or when it completes with data in the
+ window, it calls out() to write out the data. The application must not
+ change the provided input until in() is called again or inflateBack()
+ returns. The application must not change the window/output buffer until
+ inflateBack() returns.
+
+ in() and out() are called with a descriptor parameter provided in the
+ inflateBack() call. This parameter can be a structure that provides the
+ information required to do the read or write, as well as accumulated
+ information on the input and output such as totals and check values.
+
+ in() should return zero on failure. out() should return non-zero on
+ failure. If either in() or out() fails, than inflateBack() returns a
+ Z_BUF_ERROR. strm->next_in can be checked for Z_NULL to see whether it
+ was in() or out() that caused in the error. Otherwise, inflateBack()
+ returns Z_STREAM_END on success, Z_DATA_ERROR for an deflate format
+ error, or Z_MEM_ERROR if it could not allocate memory for the state.
+ inflateBack() can also return Z_STREAM_ERROR if the input parameters
+ are not correct, i.e. strm is Z_NULL or the state was not initialized.
+ */
+int ZEXPORT inflateBack(strm, in, in_desc, out, out_desc)
+z_streamp strm;
+in_func in;
+void FAR *in_desc;
+out_func out;
+void FAR *out_desc;
+{
+ struct inflate_state FAR *state;
+ z_const unsigned char FAR *next; /* next input */
+ unsigned char FAR *put; /* next output */
+ unsigned have, left; /* available input and output */
+ unsigned long hold; /* bit buffer */
+ unsigned bits; /* bits in bit buffer */
+ unsigned copy; /* number of stored or match bytes to copy */
+ unsigned char FAR *from; /* where to copy match bytes from */
+ code here; /* current decoding table entry */
+ code last; /* parent table entry */
+ unsigned len; /* length to copy for repeats, bits to drop */
+ int ret; /* return code */
+ static const unsigned short order[19] = /* permutation of code lengths */
+ {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15};
+
+ /* Check that the strm exists and that the state was initialized */
+ if (strm == Z_NULL || strm->state == Z_NULL)
+ return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* Reset the state */
+ strm->msg = Z_NULL;
+ state->mode = TYPE;
+ state->last = 0;
+ state->whave = 0;
+ next = strm->next_in;
+ have = next != Z_NULL ? strm->avail_in : 0;
+ hold = 0;
+ bits = 0;
+ put = state->window;
+ left = state->wsize;
+
+ /* Inflate until end of block marked as last */
+ for (;;)
+ switch (state->mode) {
+ case TYPE:
+ /* determine and dispatch block type */
+ if (state->last) {
+ BYTEBITS();
+ state->mode = DONE;
+ break;
+ }
+ NEEDBITS(3);
+ state->last = BITS(1);
+ DROPBITS(1);
+ switch (BITS(2)) {
+ case 0: /* stored block */
+ Tracev((stderr, "inflate: stored block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = STORED;
+ break;
+ case 1: /* fixed block */
+ fixedtables(state);
+ Tracev((stderr, "inflate: fixed codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = LEN; /* decode codes */
+ break;
+ case 2: /* dynamic block */
+ Tracev((stderr, "inflate: dynamic codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = TABLE;
+ break;
+ case 3:
+ strm->msg = (char *)"invalid block type";
+ state->mode = BAD;
+ }
+ DROPBITS(2);
+ break;
+
+ case STORED:
+ /* get and verify stored block length */
+ BYTEBITS(); /* go to byte boundary */
+ NEEDBITS(32);
+ if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) {
+ strm->msg = (char *)"invalid stored block lengths";
+ state->mode = BAD;
+ break;
+ }
+ state->length = (unsigned)hold & 0xffff;
+ Tracev((stderr, "inflate: stored length %u\n",
+ state->length));
+ INITBITS();
+
+ /* copy stored block from input to output */
+ while (state->length != 0) {
+ copy = state->length;
+ PULL();
+ ROOM();
+ if (copy > have) copy = have;
+ if (copy > left) copy = left;
+ zmemcpy(put, next, copy);
+ have -= copy;
+ next += copy;
+ left -= copy;
+ put += copy;
+ state->length -= copy;
+ }
+ Tracev((stderr, "inflate: stored end\n"));
+ state->mode = TYPE;
+ break;
+
+ case TABLE:
+ /* get dynamic table entries descriptor */
+ NEEDBITS(14);
+ state->nlen = BITS(5) + 257;
+ DROPBITS(5);
+ state->ndist = BITS(5) + 1;
+ DROPBITS(5);
+ state->ncode = BITS(4) + 4;
+ DROPBITS(4);
+#ifndef PKZIP_BUG_WORKAROUND
+ if (state->nlen > 286 || state->ndist > 30) {
+ strm->msg = (char *)"too many length or distance symbols";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ Tracev((stderr, "inflate: table sizes ok\n"));
+
+ /* get code length code lengths (not a typo) */
+ state->have = 0;
+ while (state->have < state->ncode) {
+ NEEDBITS(3);
+ state->lens[order[state->have++]] = (unsigned short)BITS(3);
+ DROPBITS(3);
+ }
+ while (state->have < 19)
+ state->lens[order[state->have++]] = 0;
+ state->next = state->codes;
+ state->lencode = (code const FAR *)(state->next);
+ state->lenbits = 7;
+ ret = inflate_table(CODES, state->lens, 19, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid code lengths set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: code lengths ok\n"));
+
+ /* get length and distance code code lengths */
+ state->have = 0;
+ while (state->have < state->nlen + state->ndist) {
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.val < 16) {
+ DROPBITS(here.bits);
+ state->lens[state->have++] = here.val;
+ }
+ else {
+ if (here.val == 16) {
+ NEEDBITS(here.bits + 2);
+ DROPBITS(here.bits);
+ if (state->have == 0) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ len = (unsigned)(state->lens[state->have - 1]);
+ copy = 3 + BITS(2);
+ DROPBITS(2);
+ }
+ else if (here.val == 17) {
+ NEEDBITS(here.bits + 3);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 3 + BITS(3);
+ DROPBITS(3);
+ }
+ else {
+ NEEDBITS(here.bits + 7);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 11 + BITS(7);
+ DROPBITS(7);
+ }
+ if (state->have + copy > state->nlen + state->ndist) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ while (copy--)
+ state->lens[state->have++] = (unsigned short)len;
+ }
+ }
+
+ /* handle error breaks in while */
+ if (state->mode == BAD) break;
+
+ /* check for end-of-block code (better have one) */
+ if (state->lens[256] == 0) {
+ strm->msg = (char *)"invalid code -- missing end-of-block";
+ state->mode = BAD;
+ break;
+ }
+
+ /* build code tables -- note: do not change the lenbits or distbits
+ values here (9 and 6) without reading the comments in inftrees.h
+ concerning the ENOUGH constants, which depend on those values */
+ state->next = state->codes;
+ state->lencode = (code const FAR *)(state->next);
+ state->lenbits = 9;
+ ret = inflate_table(LENS, state->lens, state->nlen, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid literal/lengths set";
+ state->mode = BAD;
+ break;
+ }
+ state->distcode = (code const FAR *)(state->next);
+ state->distbits = 6;
+ ret = inflate_table(DISTS, state->lens + state->nlen, state->ndist,
+ &(state->next), &(state->distbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid distances set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: codes ok\n"));
+ state->mode = LEN;
+
+ case LEN:
+ /* use inflate_fast() if we have enough input and output */
+ if (have >= 6 && left >= 258) {
+ RESTORE();
+ if (state->whave < state->wsize)
+ state->whave = state->wsize - left;
+ inflate_fast(strm, state->wsize);
+ LOAD();
+ break;
+ }
+
+ /* get a literal, length, or end-of-block code */
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.op && (here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->lencode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ }
+ DROPBITS(here.bits);
+ state->length = (unsigned)here.val;
+
+ /* process literal */
+ if (here.op == 0) {
+ Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ?
+ "inflate: literal '%c'\n" :
+ "inflate: literal 0x%02x\n", here.val));
+ ROOM();
+ *put++ = (unsigned char)(state->length);
+ left--;
+ state->mode = LEN;
+ break;
+ }
+
+ /* process end of block */
+ if (here.op & 32) {
+ Tracevv((stderr, "inflate: end of block\n"));
+ state->mode = TYPE;
+ break;
+ }
+
+ /* invalid code */
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid literal/length code";
+ state->mode = BAD;
+ break;
+ }
+
+ /* length code -- get extra bits, if any */
+ state->extra = (unsigned)(here.op) & 15;
+ if (state->extra != 0) {
+ NEEDBITS(state->extra);
+ state->length += BITS(state->extra);
+ DROPBITS(state->extra);
+ }
+ Tracevv((stderr, "inflate: length %u\n", state->length));
+
+ /* get distance code */
+ for (;;) {
+ here = state->distcode[BITS(state->distbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if ((here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->distcode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ }
+ DROPBITS(here.bits);
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid distance code";
+ state->mode = BAD;
+ break;
+ }
+ state->offset = (unsigned)here.val;
+
+ /* get distance extra bits, if any */
+ state->extra = (unsigned)(here.op) & 15;
+ if (state->extra != 0) {
+ NEEDBITS(state->extra);
+ state->offset += BITS(state->extra);
+ DROPBITS(state->extra);
+ }
+ if (state->offset > state->wsize - (state->whave < state->wsize ?
+ left : 0)) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+ Tracevv((stderr, "inflate: distance %u\n", state->offset));
+
+ /* copy match from window to output */
+ do {
+ ROOM();
+ copy = state->wsize - state->offset;
+ if (copy < left) {
+ from = put + copy;
+ copy = left - copy;
+ }
+ else {
+ from = put - state->offset;
+ copy = left;
+ }
+ if (copy > state->length) copy = state->length;
+ state->length -= copy;
+ left -= copy;
+ do {
+ *put++ = *from++;
+ } while (--copy);
+ } while (state->length != 0);
+ break;
+
+ case DONE:
+ /* inflate stream terminated properly -- write leftover output */
+ ret = Z_STREAM_END;
+ if (left < state->wsize) {
+ if (out(out_desc, state->window, state->wsize - left))
+ ret = Z_BUF_ERROR;
+ }
+ goto inf_leave;
+
+ case BAD:
+ ret = Z_DATA_ERROR;
+ goto inf_leave;
+
+ default: /* can't happen, but makes compilers happy */
+ ret = Z_STREAM_ERROR;
+ goto inf_leave;
+ }
+
+ /* Return unused input */
+ inf_leave:
+ strm->next_in = next;
+ strm->avail_in = have;
+ return ret;
+}
+
+int ZEXPORT inflateBackEnd(strm)
+z_streamp strm;
+{
+ if (strm == Z_NULL || strm->state == Z_NULL || strm->zfree == (free_func)0)
+ return Z_STREAM_ERROR;
+ ZFREE(strm, strm->state);
+ strm->state = Z_NULL;
+ Tracev((stderr, "inflate: end\n"));
+ return Z_OK;
+}
diff --git a/test/monniaux/zlib-1.2.11/inffast.c b/test/monniaux/zlib-1.2.11/inffast.c
new file mode 100644
index 00000000..0dbd1dbc
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inffast.c
@@ -0,0 +1,323 @@
+/* inffast.c -- fast decoding
+ * Copyright (C) 1995-2017 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "inflate.h"
+#include "inffast.h"
+
+#ifdef ASMINF
+# pragma message("Assembler code may have bugs -- use at your own risk")
+#else
+
+/*
+ Decode literal, length, and distance codes and write out the resulting
+ literal and match bytes until either not enough input or output is
+ available, an end-of-block is encountered, or a data error is encountered.
+ When large enough input and output buffers are supplied to inflate(), for
+ example, a 16K input buffer and a 64K output buffer, more than 95% of the
+ inflate execution time is spent in this routine.
+
+ Entry assumptions:
+
+ state->mode == LEN
+ strm->avail_in >= 6
+ strm->avail_out >= 258
+ start >= strm->avail_out
+ state->bits < 8
+
+ On return, state->mode is one of:
+
+ LEN -- ran out of enough output space or enough available input
+ TYPE -- reached end of block code, inflate() to interpret next block
+ BAD -- error in block data
+
+ Notes:
+
+ - The maximum input bits used by a length/distance pair is 15 bits for the
+ length code, 5 bits for the length extra, 15 bits for the distance code,
+ and 13 bits for the distance extra. This totals 48 bits, or six bytes.
+ Therefore if strm->avail_in >= 6, then there is enough input to avoid
+ checking for available input while decoding.
+
+ - The maximum bytes that a single length/distance pair can output is 258
+ bytes, which is the maximum length that can be coded. inflate_fast()
+ requires strm->avail_out >= 258 for each loop to avoid checking for
+ output space.
+ */
+void ZLIB_INTERNAL inflate_fast(strm, start)
+z_streamp strm;
+unsigned start; /* inflate()'s starting value for strm->avail_out */
+{
+ struct inflate_state FAR *state;
+ z_const unsigned char FAR *in; /* local strm->next_in */
+ z_const unsigned char FAR *last; /* have enough input while in < last */
+ unsigned char FAR *out; /* local strm->next_out */
+ unsigned char FAR *beg; /* inflate()'s initial strm->next_out */
+ unsigned char FAR *end; /* while out < end, enough space available */
+#ifdef INFLATE_STRICT
+ unsigned dmax; /* maximum distance from zlib header */
+#endif
+ unsigned wsize; /* window size or zero if not using window */
+ unsigned whave; /* valid bytes in the window */
+ unsigned wnext; /* window write index */
+ unsigned char FAR *window; /* allocated sliding window, if wsize != 0 */
+ unsigned long hold; /* local strm->hold */
+ unsigned bits; /* local strm->bits */
+ code const FAR *lcode; /* local strm->lencode */
+ code const FAR *dcode; /* local strm->distcode */
+ unsigned lmask; /* mask for first level of length codes */
+ unsigned dmask; /* mask for first level of distance codes */
+ code here; /* retrieved table entry */
+ unsigned op; /* code bits, operation, extra bits, or */
+ /* window position, window bytes to copy */
+ unsigned len; /* match length, unused bytes */
+ unsigned dist; /* match distance */
+ unsigned char FAR *from; /* where to copy match from */
+
+ /* copy state to local variables */
+ state = (struct inflate_state FAR *)strm->state;
+ in = strm->next_in;
+ last = in + (strm->avail_in - 5);
+ out = strm->next_out;
+ beg = out - (start - strm->avail_out);
+ end = out + (strm->avail_out - 257);
+#ifdef INFLATE_STRICT
+ dmax = state->dmax;
+#endif
+ wsize = state->wsize;
+ whave = state->whave;
+ wnext = state->wnext;
+ window = state->window;
+ hold = state->hold;
+ bits = state->bits;
+ lcode = state->lencode;
+ dcode = state->distcode;
+ lmask = (1U << state->lenbits) - 1;
+ dmask = (1U << state->distbits) - 1;
+
+ /* decode literals and length/distances until end-of-block or not enough
+ input data or output space */
+ do {
+ if (bits < 15) {
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ }
+ here = lcode[hold & lmask];
+ dolen:
+ op = (unsigned)(here.bits);
+ hold >>= op;
+ bits -= op;
+ op = (unsigned)(here.op);
+ if (op == 0) { /* literal */
+ Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ?
+ "inflate: literal '%c'\n" :
+ "inflate: literal 0x%02x\n", here.val));
+ *out++ = (unsigned char)(here.val);
+ }
+ else if (op & 16) { /* length base */
+ len = (unsigned)(here.val);
+ op &= 15; /* number of extra bits */
+ if (op) {
+ if (bits < op) {
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ }
+ len += (unsigned)hold & ((1U << op) - 1);
+ hold >>= op;
+ bits -= op;
+ }
+ Tracevv((stderr, "inflate: length %u\n", len));
+ if (bits < 15) {
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ }
+ here = dcode[hold & dmask];
+ dodist:
+ op = (unsigned)(here.bits);
+ hold >>= op;
+ bits -= op;
+ op = (unsigned)(here.op);
+ if (op & 16) { /* distance base */
+ dist = (unsigned)(here.val);
+ op &= 15; /* number of extra bits */
+ if (bits < op) {
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ if (bits < op) {
+ hold += (unsigned long)(*in++) << bits;
+ bits += 8;
+ }
+ }
+ dist += (unsigned)hold & ((1U << op) - 1);
+#ifdef INFLATE_STRICT
+ if (dist > dmax) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ hold >>= op;
+ bits -= op;
+ Tracevv((stderr, "inflate: distance %u\n", dist));
+ op = (unsigned)(out - beg); /* max distance in output */
+ if (dist > op) { /* see if copy from window */
+ op = dist - op; /* distance back in window */
+ if (op > whave) {
+ if (state->sane) {
+ strm->msg =
+ (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ if (len <= op - whave) {
+ do {
+ *out++ = 0;
+ } while (--len);
+ continue;
+ }
+ len -= op - whave;
+ do {
+ *out++ = 0;
+ } while (--op > whave);
+ if (op == 0) {
+ from = out - dist;
+ do {
+ *out++ = *from++;
+ } while (--len);
+ continue;
+ }
+#endif
+ }
+ from = window;
+ if (wnext == 0) { /* very common case */
+ from += wsize - op;
+ if (op < len) { /* some from window */
+ len -= op;
+ do {
+ *out++ = *from++;
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ else if (wnext < op) { /* wrap around window */
+ from += wsize + wnext - op;
+ op -= wnext;
+ if (op < len) { /* some from end of window */
+ len -= op;
+ do {
+ *out++ = *from++;
+ } while (--op);
+ from = window;
+ if (wnext < len) { /* some from start of window */
+ op = wnext;
+ len -= op;
+ do {
+ *out++ = *from++;
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ }
+ else { /* contiguous in window */
+ from += wnext - op;
+ if (op < len) { /* some from window */
+ len -= op;
+ do {
+ *out++ = *from++;
+ } while (--op);
+ from = out - dist; /* rest from output */
+ }
+ }
+ while (len > 2) {
+ *out++ = *from++;
+ *out++ = *from++;
+ *out++ = *from++;
+ len -= 3;
+ }
+ if (len) {
+ *out++ = *from++;
+ if (len > 1)
+ *out++ = *from++;
+ }
+ }
+ else {
+ from = out - dist; /* copy direct from output */
+ do { /* minimum length is three */
+ *out++ = *from++;
+ *out++ = *from++;
+ *out++ = *from++;
+ len -= 3;
+ } while (len > 2);
+ if (len) {
+ *out++ = *from++;
+ if (len > 1)
+ *out++ = *from++;
+ }
+ }
+ }
+ else if ((op & 64) == 0) { /* 2nd level distance code */
+ here = dcode[here.val + (hold & ((1U << op) - 1))];
+ goto dodist;
+ }
+ else {
+ strm->msg = (char *)"invalid distance code";
+ state->mode = BAD;
+ break;
+ }
+ }
+ else if ((op & 64) == 0) { /* 2nd level length code */
+ here = lcode[here.val + (hold & ((1U << op) - 1))];
+ goto dolen;
+ }
+ else if (op & 32) { /* end-of-block */
+ Tracevv((stderr, "inflate: end of block\n"));
+ state->mode = TYPE;
+ break;
+ }
+ else {
+ strm->msg = (char *)"invalid literal/length code";
+ state->mode = BAD;
+ break;
+ }
+ } while (in < last && out < end);
+
+ /* return unused bytes (on entry, bits < 8, so in won't go too far back) */
+ len = bits >> 3;
+ in -= len;
+ bits -= len << 3;
+ hold &= (1U << bits) - 1;
+
+ /* update state and return */
+ strm->next_in = in;
+ strm->next_out = out;
+ strm->avail_in = (unsigned)(in < last ? 5 + (last - in) : 5 - (in - last));
+ strm->avail_out = (unsigned)(out < end ?
+ 257 + (end - out) : 257 - (out - end));
+ state->hold = hold;
+ state->bits = bits;
+ return;
+}
+
+/*
+ inflate_fast() speedups that turned out slower (on a PowerPC G3 750CXe):
+ - Using bit fields for code structure
+ - Different op definition to avoid & for extra bits (do & for table bits)
+ - Three separate decoding do-loops for direct, window, and wnext == 0
+ - Special case for distance > 1 copies to do overlapped load and store copy
+ - Explicit branch predictions (based on measured branch probabilities)
+ - Deferring match copy and interspersed it with decoding subsequent codes
+ - Swapping literal/length else
+ - Swapping window/direct else
+ - Larger unrolled copy loops (three is about right)
+ - Moving len -= 3 statement into middle of loop
+ */
+
+#endif /* !ASMINF */
diff --git a/test/monniaux/zlib-1.2.11/inffast.h b/test/monniaux/zlib-1.2.11/inffast.h
new file mode 100644
index 00000000..e5c1aa4c
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inffast.h
@@ -0,0 +1,11 @@
+/* inffast.h -- header to use inffast.c
+ * Copyright (C) 1995-2003, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+void ZLIB_INTERNAL inflate_fast OF((z_streamp strm, unsigned start));
diff --git a/test/monniaux/zlib-1.2.11/inffixed.h b/test/monniaux/zlib-1.2.11/inffixed.h
new file mode 100644
index 00000000..d6283277
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inffixed.h
@@ -0,0 +1,94 @@
+ /* inffixed.h -- table for decoding fixed codes
+ * Generated automatically by makefixed().
+ */
+
+ /* WARNING: this file should *not* be used by applications.
+ It is part of the implementation of this library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+ static const code lenfix[512] = {
+ {96,7,0},{0,8,80},{0,8,16},{20,8,115},{18,7,31},{0,8,112},{0,8,48},
+ {0,9,192},{16,7,10},{0,8,96},{0,8,32},{0,9,160},{0,8,0},{0,8,128},
+ {0,8,64},{0,9,224},{16,7,6},{0,8,88},{0,8,24},{0,9,144},{19,7,59},
+ {0,8,120},{0,8,56},{0,9,208},{17,7,17},{0,8,104},{0,8,40},{0,9,176},
+ {0,8,8},{0,8,136},{0,8,72},{0,9,240},{16,7,4},{0,8,84},{0,8,20},
+ {21,8,227},{19,7,43},{0,8,116},{0,8,52},{0,9,200},{17,7,13},{0,8,100},
+ {0,8,36},{0,9,168},{0,8,4},{0,8,132},{0,8,68},{0,9,232},{16,7,8},
+ {0,8,92},{0,8,28},{0,9,152},{20,7,83},{0,8,124},{0,8,60},{0,9,216},
+ {18,7,23},{0,8,108},{0,8,44},{0,9,184},{0,8,12},{0,8,140},{0,8,76},
+ {0,9,248},{16,7,3},{0,8,82},{0,8,18},{21,8,163},{19,7,35},{0,8,114},
+ {0,8,50},{0,9,196},{17,7,11},{0,8,98},{0,8,34},{0,9,164},{0,8,2},
+ {0,8,130},{0,8,66},{0,9,228},{16,7,7},{0,8,90},{0,8,26},{0,9,148},
+ {20,7,67},{0,8,122},{0,8,58},{0,9,212},{18,7,19},{0,8,106},{0,8,42},
+ {0,9,180},{0,8,10},{0,8,138},{0,8,74},{0,9,244},{16,7,5},{0,8,86},
+ {0,8,22},{64,8,0},{19,7,51},{0,8,118},{0,8,54},{0,9,204},{17,7,15},
+ {0,8,102},{0,8,38},{0,9,172},{0,8,6},{0,8,134},{0,8,70},{0,9,236},
+ {16,7,9},{0,8,94},{0,8,30},{0,9,156},{20,7,99},{0,8,126},{0,8,62},
+ {0,9,220},{18,7,27},{0,8,110},{0,8,46},{0,9,188},{0,8,14},{0,8,142},
+ {0,8,78},{0,9,252},{96,7,0},{0,8,81},{0,8,17},{21,8,131},{18,7,31},
+ {0,8,113},{0,8,49},{0,9,194},{16,7,10},{0,8,97},{0,8,33},{0,9,162},
+ {0,8,1},{0,8,129},{0,8,65},{0,9,226},{16,7,6},{0,8,89},{0,8,25},
+ {0,9,146},{19,7,59},{0,8,121},{0,8,57},{0,9,210},{17,7,17},{0,8,105},
+ {0,8,41},{0,9,178},{0,8,9},{0,8,137},{0,8,73},{0,9,242},{16,7,4},
+ {0,8,85},{0,8,21},{16,8,258},{19,7,43},{0,8,117},{0,8,53},{0,9,202},
+ {17,7,13},{0,8,101},{0,8,37},{0,9,170},{0,8,5},{0,8,133},{0,8,69},
+ {0,9,234},{16,7,8},{0,8,93},{0,8,29},{0,9,154},{20,7,83},{0,8,125},
+ {0,8,61},{0,9,218},{18,7,23},{0,8,109},{0,8,45},{0,9,186},{0,8,13},
+ {0,8,141},{0,8,77},{0,9,250},{16,7,3},{0,8,83},{0,8,19},{21,8,195},
+ {19,7,35},{0,8,115},{0,8,51},{0,9,198},{17,7,11},{0,8,99},{0,8,35},
+ {0,9,166},{0,8,3},{0,8,131},{0,8,67},{0,9,230},{16,7,7},{0,8,91},
+ {0,8,27},{0,9,150},{20,7,67},{0,8,123},{0,8,59},{0,9,214},{18,7,19},
+ {0,8,107},{0,8,43},{0,9,182},{0,8,11},{0,8,139},{0,8,75},{0,9,246},
+ {16,7,5},{0,8,87},{0,8,23},{64,8,0},{19,7,51},{0,8,119},{0,8,55},
+ {0,9,206},{17,7,15},{0,8,103},{0,8,39},{0,9,174},{0,8,7},{0,8,135},
+ {0,8,71},{0,9,238},{16,7,9},{0,8,95},{0,8,31},{0,9,158},{20,7,99},
+ {0,8,127},{0,8,63},{0,9,222},{18,7,27},{0,8,111},{0,8,47},{0,9,190},
+ {0,8,15},{0,8,143},{0,8,79},{0,9,254},{96,7,0},{0,8,80},{0,8,16},
+ {20,8,115},{18,7,31},{0,8,112},{0,8,48},{0,9,193},{16,7,10},{0,8,96},
+ {0,8,32},{0,9,161},{0,8,0},{0,8,128},{0,8,64},{0,9,225},{16,7,6},
+ {0,8,88},{0,8,24},{0,9,145},{19,7,59},{0,8,120},{0,8,56},{0,9,209},
+ {17,7,17},{0,8,104},{0,8,40},{0,9,177},{0,8,8},{0,8,136},{0,8,72},
+ {0,9,241},{16,7,4},{0,8,84},{0,8,20},{21,8,227},{19,7,43},{0,8,116},
+ {0,8,52},{0,9,201},{17,7,13},{0,8,100},{0,8,36},{0,9,169},{0,8,4},
+ {0,8,132},{0,8,68},{0,9,233},{16,7,8},{0,8,92},{0,8,28},{0,9,153},
+ {20,7,83},{0,8,124},{0,8,60},{0,9,217},{18,7,23},{0,8,108},{0,8,44},
+ {0,9,185},{0,8,12},{0,8,140},{0,8,76},{0,9,249},{16,7,3},{0,8,82},
+ {0,8,18},{21,8,163},{19,7,35},{0,8,114},{0,8,50},{0,9,197},{17,7,11},
+ {0,8,98},{0,8,34},{0,9,165},{0,8,2},{0,8,130},{0,8,66},{0,9,229},
+ {16,7,7},{0,8,90},{0,8,26},{0,9,149},{20,7,67},{0,8,122},{0,8,58},
+ {0,9,213},{18,7,19},{0,8,106},{0,8,42},{0,9,181},{0,8,10},{0,8,138},
+ {0,8,74},{0,9,245},{16,7,5},{0,8,86},{0,8,22},{64,8,0},{19,7,51},
+ {0,8,118},{0,8,54},{0,9,205},{17,7,15},{0,8,102},{0,8,38},{0,9,173},
+ {0,8,6},{0,8,134},{0,8,70},{0,9,237},{16,7,9},{0,8,94},{0,8,30},
+ {0,9,157},{20,7,99},{0,8,126},{0,8,62},{0,9,221},{18,7,27},{0,8,110},
+ {0,8,46},{0,9,189},{0,8,14},{0,8,142},{0,8,78},{0,9,253},{96,7,0},
+ {0,8,81},{0,8,17},{21,8,131},{18,7,31},{0,8,113},{0,8,49},{0,9,195},
+ {16,7,10},{0,8,97},{0,8,33},{0,9,163},{0,8,1},{0,8,129},{0,8,65},
+ {0,9,227},{16,7,6},{0,8,89},{0,8,25},{0,9,147},{19,7,59},{0,8,121},
+ {0,8,57},{0,9,211},{17,7,17},{0,8,105},{0,8,41},{0,9,179},{0,8,9},
+ {0,8,137},{0,8,73},{0,9,243},{16,7,4},{0,8,85},{0,8,21},{16,8,258},
+ {19,7,43},{0,8,117},{0,8,53},{0,9,203},{17,7,13},{0,8,101},{0,8,37},
+ {0,9,171},{0,8,5},{0,8,133},{0,8,69},{0,9,235},{16,7,8},{0,8,93},
+ {0,8,29},{0,9,155},{20,7,83},{0,8,125},{0,8,61},{0,9,219},{18,7,23},
+ {0,8,109},{0,8,45},{0,9,187},{0,8,13},{0,8,141},{0,8,77},{0,9,251},
+ {16,7,3},{0,8,83},{0,8,19},{21,8,195},{19,7,35},{0,8,115},{0,8,51},
+ {0,9,199},{17,7,11},{0,8,99},{0,8,35},{0,9,167},{0,8,3},{0,8,131},
+ {0,8,67},{0,9,231},{16,7,7},{0,8,91},{0,8,27},{0,9,151},{20,7,67},
+ {0,8,123},{0,8,59},{0,9,215},{18,7,19},{0,8,107},{0,8,43},{0,9,183},
+ {0,8,11},{0,8,139},{0,8,75},{0,9,247},{16,7,5},{0,8,87},{0,8,23},
+ {64,8,0},{19,7,51},{0,8,119},{0,8,55},{0,9,207},{17,7,15},{0,8,103},
+ {0,8,39},{0,9,175},{0,8,7},{0,8,135},{0,8,71},{0,9,239},{16,7,9},
+ {0,8,95},{0,8,31},{0,9,159},{20,7,99},{0,8,127},{0,8,63},{0,9,223},
+ {18,7,27},{0,8,111},{0,8,47},{0,9,191},{0,8,15},{0,8,143},{0,8,79},
+ {0,9,255}
+ };
+
+ static const code distfix[32] = {
+ {16,5,1},{23,5,257},{19,5,17},{27,5,4097},{17,5,5},{25,5,1025},
+ {21,5,65},{29,5,16385},{16,5,3},{24,5,513},{20,5,33},{28,5,8193},
+ {18,5,9},{26,5,2049},{22,5,129},{64,5,0},{16,5,2},{23,5,385},
+ {19,5,25},{27,5,6145},{17,5,7},{25,5,1537},{21,5,97},{29,5,24577},
+ {16,5,4},{24,5,769},{20,5,49},{28,5,12289},{18,5,13},{26,5,3073},
+ {22,5,193},{64,5,0}
+ };
diff --git a/test/monniaux/zlib-1.2.11/inflate.c b/test/monniaux/zlib-1.2.11/inflate.c
new file mode 100644
index 00000000..ac333e8c
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inflate.c
@@ -0,0 +1,1561 @@
+/* inflate.c -- zlib decompression
+ * Copyright (C) 1995-2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * Change history:
+ *
+ * 1.2.beta0 24 Nov 2002
+ * - First version -- complete rewrite of inflate to simplify code, avoid
+ * creation of window when not needed, minimize use of window when it is
+ * needed, make inffast.c even faster, implement gzip decoding, and to
+ * improve code readability and style over the previous zlib inflate code
+ *
+ * 1.2.beta1 25 Nov 2002
+ * - Use pointers for available input and output checking in inffast.c
+ * - Remove input and output counters in inffast.c
+ * - Change inffast.c entry and loop from avail_in >= 7 to >= 6
+ * - Remove unnecessary second byte pull from length extra in inffast.c
+ * - Unroll direct copy to three copies per loop in inffast.c
+ *
+ * 1.2.beta2 4 Dec 2002
+ * - Change external routine names to reduce potential conflicts
+ * - Correct filename to inffixed.h for fixed tables in inflate.c
+ * - Make hbuf[] unsigned char to match parameter type in inflate.c
+ * - Change strm->next_out[-state->offset] to *(strm->next_out - state->offset)
+ * to avoid negation problem on Alphas (64 bit) in inflate.c
+ *
+ * 1.2.beta3 22 Dec 2002
+ * - Add comments on state->bits assertion in inffast.c
+ * - Add comments on op field in inftrees.h
+ * - Fix bug in reuse of allocated window after inflateReset()
+ * - Remove bit fields--back to byte structure for speed
+ * - Remove distance extra == 0 check in inflate_fast()--only helps for lengths
+ * - Change post-increments to pre-increments in inflate_fast(), PPC biased?
+ * - Add compile time option, POSTINC, to use post-increments instead (Intel?)
+ * - Make MATCH copy in inflate() much faster for when inflate_fast() not used
+ * - Use local copies of stream next and avail values, as well as local bit
+ * buffer and bit count in inflate()--for speed when inflate_fast() not used
+ *
+ * 1.2.beta4 1 Jan 2003
+ * - Split ptr - 257 statements in inflate_table() to avoid compiler warnings
+ * - Move a comment on output buffer sizes from inffast.c to inflate.c
+ * - Add comments in inffast.c to introduce the inflate_fast() routine
+ * - Rearrange window copies in inflate_fast() for speed and simplification
+ * - Unroll last copy for window match in inflate_fast()
+ * - Use local copies of window variables in inflate_fast() for speed
+ * - Pull out common wnext == 0 case for speed in inflate_fast()
+ * - Make op and len in inflate_fast() unsigned for consistency
+ * - Add FAR to lcode and dcode declarations in inflate_fast()
+ * - Simplified bad distance check in inflate_fast()
+ * - Added inflateBackInit(), inflateBack(), and inflateBackEnd() in new
+ * source file infback.c to provide a call-back interface to inflate for
+ * programs like gzip and unzip -- uses window as output buffer to avoid
+ * window copying
+ *
+ * 1.2.beta5 1 Jan 2003
+ * - Improved inflateBack() interface to allow the caller to provide initial
+ * input in strm.
+ * - Fixed stored blocks bug in inflateBack()
+ *
+ * 1.2.beta6 4 Jan 2003
+ * - Added comments in inffast.c on effectiveness of POSTINC
+ * - Typecasting all around to reduce compiler warnings
+ * - Changed loops from while (1) or do {} while (1) to for (;;), again to
+ * make compilers happy
+ * - Changed type of window in inflateBackInit() to unsigned char *
+ *
+ * 1.2.beta7 27 Jan 2003
+ * - Changed many types to unsigned or unsigned short to avoid warnings
+ * - Added inflateCopy() function
+ *
+ * 1.2.0 9 Mar 2003
+ * - Changed inflateBack() interface to provide separate opaque descriptors
+ * for the in() and out() functions
+ * - Changed inflateBack() argument and in_func typedef to swap the length
+ * and buffer address return values for the input function
+ * - Check next_in and next_out for Z_NULL on entry to inflate()
+ *
+ * The history for versions after 1.2.0 are in ChangeLog in zlib distribution.
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+#include "inflate.h"
+#include "inffast.h"
+
+#ifdef MAKEFIXED
+# ifndef BUILDFIXED
+# define BUILDFIXED
+# endif
+#endif
+
+/* function prototypes */
+local int inflateStateCheck OF((z_streamp strm));
+local void fixedtables OF((struct inflate_state FAR *state));
+local int updatewindow OF((z_streamp strm, const unsigned char FAR *end,
+ unsigned copy));
+#ifdef BUILDFIXED
+ void makefixed OF((void));
+#endif
+local unsigned syncsearch OF((unsigned FAR *have, const unsigned char FAR *buf,
+ unsigned len));
+
+local int inflateStateCheck(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+ if (strm == Z_NULL ||
+ strm->zalloc == (alloc_func)0 || strm->zfree == (free_func)0)
+ return 1;
+ state = (struct inflate_state FAR *)strm->state;
+ if (state == Z_NULL || state->strm != strm ||
+ state->mode < HEAD || state->mode > SYNC)
+ return 1;
+ return 0;
+}
+
+int ZEXPORT inflateResetKeep(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ strm->total_in = strm->total_out = state->total = 0;
+ strm->msg = Z_NULL;
+ if (state->wrap) /* to support ill-conceived Java test suite */
+ strm->adler = state->wrap & 1;
+ state->mode = HEAD;
+ state->last = 0;
+ state->havedict = 0;
+ state->dmax = 32768U;
+ state->head = Z_NULL;
+ state->hold = 0;
+ state->bits = 0;
+ state->lencode = state->distcode = state->next = state->codes;
+ state->sane = 1;
+ state->back = -1;
+ Tracev((stderr, "inflate: reset\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateReset(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ state->wsize = 0;
+ state->whave = 0;
+ state->wnext = 0;
+ return inflateResetKeep(strm);
+}
+
+int ZEXPORT inflateReset2(strm, windowBits)
+z_streamp strm;
+int windowBits;
+{
+ int wrap;
+ struct inflate_state FAR *state;
+
+ /* get the state */
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* extract wrap request from windowBits parameter */
+ if (windowBits < 0) {
+ wrap = 0;
+ windowBits = -windowBits;
+ }
+ else {
+ wrap = (windowBits >> 4) + 5;
+#ifdef GUNZIP
+ if (windowBits < 48)
+ windowBits &= 15;
+#endif
+ }
+
+ /* set number of window bits, free window if different */
+ if (windowBits && (windowBits < 8 || windowBits > 15))
+ return Z_STREAM_ERROR;
+ if (state->window != Z_NULL && state->wbits != (unsigned)windowBits) {
+ ZFREE(strm, state->window);
+ state->window = Z_NULL;
+ }
+
+ /* update state and reset the rest of it */
+ state->wrap = wrap;
+ state->wbits = (unsigned)windowBits;
+ return inflateReset(strm);
+}
+
+int ZEXPORT inflateInit2_(strm, windowBits, version, stream_size)
+z_streamp strm;
+int windowBits;
+const char *version;
+int stream_size;
+{
+ int ret;
+ struct inflate_state FAR *state;
+
+ if (version == Z_NULL || version[0] != ZLIB_VERSION[0] ||
+ stream_size != (int)(sizeof(z_stream)))
+ return Z_VERSION_ERROR;
+ if (strm == Z_NULL) return Z_STREAM_ERROR;
+ strm->msg = Z_NULL; /* in case we return an error */
+ if (strm->zalloc == (alloc_func)0) {
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zalloc = zcalloc;
+ strm->opaque = (voidpf)0;
+#endif
+ }
+ if (strm->zfree == (free_func)0)
+#ifdef Z_SOLO
+ return Z_STREAM_ERROR;
+#else
+ strm->zfree = zcfree;
+#endif
+ state = (struct inflate_state FAR *)
+ ZALLOC(strm, 1, sizeof(struct inflate_state));
+ if (state == Z_NULL) return Z_MEM_ERROR;
+ Tracev((stderr, "inflate: allocated\n"));
+ strm->state = (struct internal_state FAR *)state;
+ state->strm = strm;
+ state->window = Z_NULL;
+ state->mode = HEAD; /* to pass state test in inflateReset2() */
+ ret = inflateReset2(strm, windowBits);
+ if (ret != Z_OK) {
+ ZFREE(strm, state);
+ strm->state = Z_NULL;
+ }
+ return ret;
+}
+
+int ZEXPORT inflateInit_(strm, version, stream_size)
+z_streamp strm;
+const char *version;
+int stream_size;
+{
+ return inflateInit2_(strm, DEF_WBITS, version, stream_size);
+}
+
+int ZEXPORT inflatePrime(strm, bits, value)
+z_streamp strm;
+int bits;
+int value;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (bits < 0) {
+ state->hold = 0;
+ state->bits = 0;
+ return Z_OK;
+ }
+ if (bits > 16 || state->bits + (uInt)bits > 32) return Z_STREAM_ERROR;
+ value &= (1L << bits) - 1;
+ state->hold += (unsigned)value << state->bits;
+ state->bits += (uInt)bits;
+ return Z_OK;
+}
+
+/*
+ Return state with length and distance decoding tables and index sizes set to
+ fixed code decoding. Normally this returns fixed tables from inffixed.h.
+ If BUILDFIXED is defined, then instead this routine builds the tables the
+ first time it's called, and returns those tables the first time and
+ thereafter. This reduces the size of the code by about 2K bytes, in
+ exchange for a little execution time. However, BUILDFIXED should not be
+ used for threaded applications, since the rewriting of the tables and virgin
+ may not be thread-safe.
+ */
+local void fixedtables(state)
+struct inflate_state FAR *state;
+{
+#ifdef BUILDFIXED
+ static int virgin = 1;
+ static code *lenfix, *distfix;
+ static code fixed[544];
+
+ /* build fixed huffman tables if first call (may not be thread safe) */
+ if (virgin) {
+ unsigned sym, bits;
+ static code *next;
+
+ /* literal/length table */
+ sym = 0;
+ while (sym < 144) state->lens[sym++] = 8;
+ while (sym < 256) state->lens[sym++] = 9;
+ while (sym < 280) state->lens[sym++] = 7;
+ while (sym < 288) state->lens[sym++] = 8;
+ next = fixed;
+ lenfix = next;
+ bits = 9;
+ inflate_table(LENS, state->lens, 288, &(next), &(bits), state->work);
+
+ /* distance table */
+ sym = 0;
+ while (sym < 32) state->lens[sym++] = 5;
+ distfix = next;
+ bits = 5;
+ inflate_table(DISTS, state->lens, 32, &(next), &(bits), state->work);
+
+ /* do this just once */
+ virgin = 0;
+ }
+#else /* !BUILDFIXED */
+# include "inffixed.h"
+#endif /* BUILDFIXED */
+ state->lencode = lenfix;
+ state->lenbits = 9;
+ state->distcode = distfix;
+ state->distbits = 5;
+}
+
+#ifdef MAKEFIXED
+#include <stdio.h>
+
+/*
+ Write out the inffixed.h that is #include'd above. Defining MAKEFIXED also
+ defines BUILDFIXED, so the tables are built on the fly. makefixed() writes
+ those tables to stdout, which would be piped to inffixed.h. A small program
+ can simply call makefixed to do this:
+
+ void makefixed(void);
+
+ int main(void)
+ {
+ makefixed();
+ return 0;
+ }
+
+ Then that can be linked with zlib built with MAKEFIXED defined and run:
+
+ a.out > inffixed.h
+ */
+void makefixed()
+{
+ unsigned low, size;
+ struct inflate_state state;
+
+ fixedtables(&state);
+ puts(" /* inffixed.h -- table for decoding fixed codes");
+ puts(" * Generated automatically by makefixed().");
+ puts(" */");
+ puts("");
+ puts(" /* WARNING: this file should *not* be used by applications.");
+ puts(" It is part of the implementation of this library and is");
+ puts(" subject to change. Applications should only use zlib.h.");
+ puts(" */");
+ puts("");
+ size = 1U << 9;
+ printf(" static const code lenfix[%u] = {", size);
+ low = 0;
+ for (;;) {
+ if ((low % 7) == 0) printf("\n ");
+ printf("{%u,%u,%d}", (low & 127) == 99 ? 64 : state.lencode[low].op,
+ state.lencode[low].bits, state.lencode[low].val);
+ if (++low == size) break;
+ putchar(',');
+ }
+ puts("\n };");
+ size = 1U << 5;
+ printf("\n static const code distfix[%u] = {", size);
+ low = 0;
+ for (;;) {
+ if ((low % 6) == 0) printf("\n ");
+ printf("{%u,%u,%d}", state.distcode[low].op, state.distcode[low].bits,
+ state.distcode[low].val);
+ if (++low == size) break;
+ putchar(',');
+ }
+ puts("\n };");
+}
+#endif /* MAKEFIXED */
+
+/*
+ Update the window with the last wsize (normally 32K) bytes written before
+ returning. If window does not exist yet, create it. This is only called
+ when a window is already in use, or when output has been written during this
+ inflate call, but the end of the deflate stream has not been reached yet.
+ It is also called to create a window for dictionary data when a dictionary
+ is loaded.
+
+ Providing output buffers larger than 32K to inflate() should provide a speed
+ advantage, since only the last 32K of output is copied to the sliding window
+ upon return from inflate(), and since all distances after the first 32K of
+ output will fall in the output data, making match copies simpler and faster.
+ The advantage may be dependent on the size of the processor's data caches.
+ */
+local int updatewindow(strm, end, copy)
+z_streamp strm;
+const Bytef *end;
+unsigned copy;
+{
+ struct inflate_state FAR *state;
+ unsigned dist;
+
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* if it hasn't been done already, allocate space for the window */
+ if (state->window == Z_NULL) {
+ state->window = (unsigned char FAR *)
+ ZALLOC(strm, 1U << state->wbits,
+ sizeof(unsigned char));
+ if (state->window == Z_NULL) return 1;
+ }
+
+ /* if window not in use yet, initialize */
+ if (state->wsize == 0) {
+ state->wsize = 1U << state->wbits;
+ state->wnext = 0;
+ state->whave = 0;
+ }
+
+ /* copy state->wsize or less output bytes into the circular window */
+ if (copy >= state->wsize) {
+ zmemcpy(state->window, end - state->wsize, state->wsize);
+ state->wnext = 0;
+ state->whave = state->wsize;
+ }
+ else {
+ dist = state->wsize - state->wnext;
+ if (dist > copy) dist = copy;
+ zmemcpy(state->window + state->wnext, end - copy, dist);
+ copy -= dist;
+ if (copy) {
+ zmemcpy(state->window, end - copy, copy);
+ state->wnext = copy;
+ state->whave = state->wsize;
+ }
+ else {
+ state->wnext += dist;
+ if (state->wnext == state->wsize) state->wnext = 0;
+ if (state->whave < state->wsize) state->whave += dist;
+ }
+ }
+ return 0;
+}
+
+/* Macros for inflate(): */
+
+/* check function to use adler32() for zlib or crc32() for gzip */
+#ifdef GUNZIP
+# define UPDATE(check, buf, len) \
+ (state->flags ? crc32(check, buf, len) : adler32(check, buf, len))
+#else
+# define UPDATE(check, buf, len) adler32(check, buf, len)
+#endif
+
+/* check macros for header crc */
+#ifdef GUNZIP
+# define CRC2(check, word) \
+ do { \
+ hbuf[0] = (unsigned char)(word); \
+ hbuf[1] = (unsigned char)((word) >> 8); \
+ check = crc32(check, hbuf, 2); \
+ } while (0)
+
+# define CRC4(check, word) \
+ do { \
+ hbuf[0] = (unsigned char)(word); \
+ hbuf[1] = (unsigned char)((word) >> 8); \
+ hbuf[2] = (unsigned char)((word) >> 16); \
+ hbuf[3] = (unsigned char)((word) >> 24); \
+ check = crc32(check, hbuf, 4); \
+ } while (0)
+#endif
+
+/* Load registers with state in inflate() for speed */
+#define LOAD() \
+ do { \
+ put = strm->next_out; \
+ left = strm->avail_out; \
+ next = strm->next_in; \
+ have = strm->avail_in; \
+ hold = state->hold; \
+ bits = state->bits; \
+ } while (0)
+
+/* Restore state from registers in inflate() */
+#define RESTORE() \
+ do { \
+ strm->next_out = put; \
+ strm->avail_out = left; \
+ strm->next_in = next; \
+ strm->avail_in = have; \
+ state->hold = hold; \
+ state->bits = bits; \
+ } while (0)
+
+/* Clear the input bit accumulator */
+#define INITBITS() \
+ do { \
+ hold = 0; \
+ bits = 0; \
+ } while (0)
+
+/* Get a byte of input into the bit accumulator, or return from inflate()
+ if there is no input available. */
+#define PULLBYTE() \
+ do { \
+ if (have == 0) goto inf_leave; \
+ have--; \
+ hold += (unsigned long)(*next++) << bits; \
+ bits += 8; \
+ } while (0)
+
+/* Assure that there are at least n bits in the bit accumulator. If there is
+ not enough available input to do that, then return from inflate(). */
+#define NEEDBITS(n) \
+ do { \
+ while (bits < (unsigned)(n)) \
+ PULLBYTE(); \
+ } while (0)
+
+/* Return the low n bits of the bit accumulator (n < 16) */
+#define BITS(n) \
+ ((unsigned)hold & ((1U << (n)) - 1))
+
+/* Remove n bits from the bit accumulator */
+#define DROPBITS(n) \
+ do { \
+ hold >>= (n); \
+ bits -= (unsigned)(n); \
+ } while (0)
+
+/* Remove zero to seven bits as needed to go to a byte boundary */
+#define BYTEBITS() \
+ do { \
+ hold >>= bits & 7; \
+ bits -= bits & 7; \
+ } while (0)
+
+/*
+ inflate() uses a state machine to process as much input data and generate as
+ much output data as possible before returning. The state machine is
+ structured roughly as follows:
+
+ for (;;) switch (state) {
+ ...
+ case STATEn:
+ if (not enough input data or output space to make progress)
+ return;
+ ... make progress ...
+ state = STATEm;
+ break;
+ ...
+ }
+
+ so when inflate() is called again, the same case is attempted again, and
+ if the appropriate resources are provided, the machine proceeds to the
+ next state. The NEEDBITS() macro is usually the way the state evaluates
+ whether it can proceed or should return. NEEDBITS() does the return if
+ the requested bits are not available. The typical use of the BITS macros
+ is:
+
+ NEEDBITS(n);
+ ... do something with BITS(n) ...
+ DROPBITS(n);
+
+ where NEEDBITS(n) either returns from inflate() if there isn't enough
+ input left to load n bits into the accumulator, or it continues. BITS(n)
+ gives the low n bits in the accumulator. When done, DROPBITS(n) drops
+ the low n bits off the accumulator. INITBITS() clears the accumulator
+ and sets the number of available bits to zero. BYTEBITS() discards just
+ enough bits to put the accumulator on a byte boundary. After BYTEBITS()
+ and a NEEDBITS(8), then BITS(8) would return the next byte in the stream.
+
+ NEEDBITS(n) uses PULLBYTE() to get an available byte of input, or to return
+ if there is no input available. The decoding of variable length codes uses
+ PULLBYTE() directly in order to pull just enough bytes to decode the next
+ code, and no more.
+
+ Some states loop until they get enough input, making sure that enough
+ state information is maintained to continue the loop where it left off
+ if NEEDBITS() returns in the loop. For example, want, need, and keep
+ would all have to actually be part of the saved state in case NEEDBITS()
+ returns:
+
+ case STATEw:
+ while (want < need) {
+ NEEDBITS(n);
+ keep[want++] = BITS(n);
+ DROPBITS(n);
+ }
+ state = STATEx;
+ case STATEx:
+
+ As shown above, if the next state is also the next case, then the break
+ is omitted.
+
+ A state may also return if there is not enough output space available to
+ complete that state. Those states are copying stored data, writing a
+ literal byte, and copying a matching string.
+
+ When returning, a "goto inf_leave" is used to update the total counters,
+ update the check value, and determine whether any progress has been made
+ during that inflate() call in order to return the proper return code.
+ Progress is defined as a change in either strm->avail_in or strm->avail_out.
+ When there is a window, goto inf_leave will update the window with the last
+ output written. If a goto inf_leave occurs in the middle of decompression
+ and there is no window currently, goto inf_leave will create one and copy
+ output to the window for the next call of inflate().
+
+ In this implementation, the flush parameter of inflate() only affects the
+ return code (per zlib.h). inflate() always writes as much as possible to
+ strm->next_out, given the space available and the provided input--the effect
+ documented in zlib.h of Z_SYNC_FLUSH. Furthermore, inflate() always defers
+ the allocation of and copying into a sliding window until necessary, which
+ provides the effect documented in zlib.h for Z_FINISH when the entire input
+ stream available. So the only thing the flush parameter actually does is:
+ when flush is set to Z_FINISH, inflate() cannot return Z_OK. Instead it
+ will return Z_BUF_ERROR if it has not reached the end of the stream.
+ */
+
+int ZEXPORT inflate(strm, flush)
+z_streamp strm;
+int flush;
+{
+ struct inflate_state FAR *state;
+ z_const unsigned char FAR *next; /* next input */
+ unsigned char FAR *put; /* next output */
+ unsigned have, left; /* available input and output */
+ unsigned long hold; /* bit buffer */
+ unsigned bits; /* bits in bit buffer */
+ unsigned in, out; /* save starting available input and output */
+ unsigned copy; /* number of stored or match bytes to copy */
+ unsigned char FAR *from; /* where to copy match bytes from */
+ code here; /* current decoding table entry */
+ code last; /* parent table entry */
+ unsigned len; /* length to copy for repeats, bits to drop */
+ int ret; /* return code */
+#ifdef GUNZIP
+ unsigned char hbuf[4]; /* buffer for gzip header crc calculation */
+#endif
+ static const unsigned short order[19] = /* permutation of code lengths */
+ {16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15};
+
+ if (inflateStateCheck(strm) || strm->next_out == Z_NULL ||
+ (strm->next_in == Z_NULL && strm->avail_in != 0))
+ return Z_STREAM_ERROR;
+
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->mode == TYPE) state->mode = TYPEDO; /* skip check */
+ LOAD();
+ in = have;
+ out = left;
+ ret = Z_OK;
+ for (;;)
+ switch (state->mode) {
+ case HEAD:
+ if (state->wrap == 0) {
+ state->mode = TYPEDO;
+ break;
+ }
+ NEEDBITS(16);
+#ifdef GUNZIP
+ if ((state->wrap & 2) && hold == 0x8b1f) { /* gzip header */
+ if (state->wbits == 0)
+ state->wbits = 15;
+ state->check = crc32(0L, Z_NULL, 0);
+ CRC2(state->check, hold);
+ INITBITS();
+ state->mode = FLAGS;
+ break;
+ }
+ state->flags = 0; /* expect zlib header */
+ if (state->head != Z_NULL)
+ state->head->done = -1;
+ if (!(state->wrap & 1) || /* check if zlib header allowed */
+#else
+ if (
+#endif
+ ((BITS(8) << 8) + (hold >> 8)) % 31) {
+ strm->msg = (char *)"incorrect header check";
+ state->mode = BAD;
+ break;
+ }
+ if (BITS(4) != Z_DEFLATED) {
+ strm->msg = (char *)"unknown compression method";
+ state->mode = BAD;
+ break;
+ }
+ DROPBITS(4);
+ len = BITS(4) + 8;
+ if (state->wbits == 0)
+ state->wbits = len;
+ if (len > 15 || len > state->wbits) {
+ strm->msg = (char *)"invalid window size";
+ state->mode = BAD;
+ break;
+ }
+ state->dmax = 1U << len;
+ Tracev((stderr, "inflate: zlib header ok\n"));
+ strm->adler = state->check = adler32(0L, Z_NULL, 0);
+ state->mode = hold & 0x200 ? DICTID : TYPE;
+ INITBITS();
+ break;
+#ifdef GUNZIP
+ case FLAGS:
+ NEEDBITS(16);
+ state->flags = (int)(hold);
+ if ((state->flags & 0xff) != Z_DEFLATED) {
+ strm->msg = (char *)"unknown compression method";
+ state->mode = BAD;
+ break;
+ }
+ if (state->flags & 0xe000) {
+ strm->msg = (char *)"unknown header flags set";
+ state->mode = BAD;
+ break;
+ }
+ if (state->head != Z_NULL)
+ state->head->text = (int)((hold >> 8) & 1);
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ CRC2(state->check, hold);
+ INITBITS();
+ state->mode = TIME;
+ case TIME:
+ NEEDBITS(32);
+ if (state->head != Z_NULL)
+ state->head->time = hold;
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ CRC4(state->check, hold);
+ INITBITS();
+ state->mode = OS;
+ case OS:
+ NEEDBITS(16);
+ if (state->head != Z_NULL) {
+ state->head->xflags = (int)(hold & 0xff);
+ state->head->os = (int)(hold >> 8);
+ }
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ CRC2(state->check, hold);
+ INITBITS();
+ state->mode = EXLEN;
+ case EXLEN:
+ if (state->flags & 0x0400) {
+ NEEDBITS(16);
+ state->length = (unsigned)(hold);
+ if (state->head != Z_NULL)
+ state->head->extra_len = (unsigned)hold;
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ CRC2(state->check, hold);
+ INITBITS();
+ }
+ else if (state->head != Z_NULL)
+ state->head->extra = Z_NULL;
+ state->mode = EXTRA;
+ case EXTRA:
+ if (state->flags & 0x0400) {
+ copy = state->length;
+ if (copy > have) copy = have;
+ if (copy) {
+ if (state->head != Z_NULL &&
+ state->head->extra != Z_NULL) {
+ len = state->head->extra_len - state->length;
+ zmemcpy(state->head->extra + len, next,
+ len + copy > state->head->extra_max ?
+ state->head->extra_max - len : copy);
+ }
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ state->length -= copy;
+ }
+ if (state->length) goto inf_leave;
+ }
+ state->length = 0;
+ state->mode = NAME;
+ case NAME:
+ if (state->flags & 0x0800) {
+ if (have == 0) goto inf_leave;
+ copy = 0;
+ do {
+ len = (unsigned)(next[copy++]);
+ if (state->head != Z_NULL &&
+ state->head->name != Z_NULL &&
+ state->length < state->head->name_max)
+ state->head->name[state->length++] = (Bytef)len;
+ } while (len && copy < have);
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ if (len) goto inf_leave;
+ }
+ else if (state->head != Z_NULL)
+ state->head->name = Z_NULL;
+ state->length = 0;
+ state->mode = COMMENT;
+ case COMMENT:
+ if (state->flags & 0x1000) {
+ if (have == 0) goto inf_leave;
+ copy = 0;
+ do {
+ len = (unsigned)(next[copy++]);
+ if (state->head != Z_NULL &&
+ state->head->comment != Z_NULL &&
+ state->length < state->head->comm_max)
+ state->head->comment[state->length++] = (Bytef)len;
+ } while (len && copy < have);
+ if ((state->flags & 0x0200) && (state->wrap & 4))
+ state->check = crc32(state->check, next, copy);
+ have -= copy;
+ next += copy;
+ if (len) goto inf_leave;
+ }
+ else if (state->head != Z_NULL)
+ state->head->comment = Z_NULL;
+ state->mode = HCRC;
+ case HCRC:
+ if (state->flags & 0x0200) {
+ NEEDBITS(16);
+ if ((state->wrap & 4) && hold != (state->check & 0xffff)) {
+ strm->msg = (char *)"header crc mismatch";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ }
+ if (state->head != Z_NULL) {
+ state->head->hcrc = (int)((state->flags >> 9) & 1);
+ state->head->done = 1;
+ }
+ strm->adler = state->check = crc32(0L, Z_NULL, 0);
+ state->mode = TYPE;
+ break;
+#endif
+ case DICTID:
+ NEEDBITS(32);
+ strm->adler = state->check = ZSWAP32(hold);
+ INITBITS();
+ state->mode = DICT;
+ case DICT:
+ if (state->havedict == 0) {
+ RESTORE();
+ return Z_NEED_DICT;
+ }
+ strm->adler = state->check = adler32(0L, Z_NULL, 0);
+ state->mode = TYPE;
+ case TYPE:
+ if (flush == Z_BLOCK || flush == Z_TREES) goto inf_leave;
+ case TYPEDO:
+ if (state->last) {
+ BYTEBITS();
+ state->mode = CHECK;
+ break;
+ }
+ NEEDBITS(3);
+ state->last = BITS(1);
+ DROPBITS(1);
+ switch (BITS(2)) {
+ case 0: /* stored block */
+ Tracev((stderr, "inflate: stored block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = STORED;
+ break;
+ case 1: /* fixed block */
+ fixedtables(state);
+ Tracev((stderr, "inflate: fixed codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = LEN_; /* decode codes */
+ if (flush == Z_TREES) {
+ DROPBITS(2);
+ goto inf_leave;
+ }
+ break;
+ case 2: /* dynamic block */
+ Tracev((stderr, "inflate: dynamic codes block%s\n",
+ state->last ? " (last)" : ""));
+ state->mode = TABLE;
+ break;
+ case 3:
+ strm->msg = (char *)"invalid block type";
+ state->mode = BAD;
+ }
+ DROPBITS(2);
+ break;
+ case STORED:
+ BYTEBITS(); /* go to byte boundary */
+ NEEDBITS(32);
+ if ((hold & 0xffff) != ((hold >> 16) ^ 0xffff)) {
+ strm->msg = (char *)"invalid stored block lengths";
+ state->mode = BAD;
+ break;
+ }
+ state->length = (unsigned)hold & 0xffff;
+ Tracev((stderr, "inflate: stored length %u\n",
+ state->length));
+ INITBITS();
+ state->mode = COPY_;
+ if (flush == Z_TREES) goto inf_leave;
+ case COPY_:
+ state->mode = COPY;
+ case COPY:
+ copy = state->length;
+ if (copy) {
+ if (copy > have) copy = have;
+ if (copy > left) copy = left;
+ if (copy == 0) goto inf_leave;
+ zmemcpy(put, next, copy);
+ have -= copy;
+ next += copy;
+ left -= copy;
+ put += copy;
+ state->length -= copy;
+ break;
+ }
+ Tracev((stderr, "inflate: stored end\n"));
+ state->mode = TYPE;
+ break;
+ case TABLE:
+ NEEDBITS(14);
+ state->nlen = BITS(5) + 257;
+ DROPBITS(5);
+ state->ndist = BITS(5) + 1;
+ DROPBITS(5);
+ state->ncode = BITS(4) + 4;
+ DROPBITS(4);
+#ifndef PKZIP_BUG_WORKAROUND
+ if (state->nlen > 286 || state->ndist > 30) {
+ strm->msg = (char *)"too many length or distance symbols";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ Tracev((stderr, "inflate: table sizes ok\n"));
+ state->have = 0;
+ state->mode = LENLENS;
+ case LENLENS:
+ while (state->have < state->ncode) {
+ NEEDBITS(3);
+ state->lens[order[state->have++]] = (unsigned short)BITS(3);
+ DROPBITS(3);
+ }
+ while (state->have < 19)
+ state->lens[order[state->have++]] = 0;
+ state->next = state->codes;
+ state->lencode = (const code FAR *)(state->next);
+ state->lenbits = 7;
+ ret = inflate_table(CODES, state->lens, 19, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid code lengths set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: code lengths ok\n"));
+ state->have = 0;
+ state->mode = CODELENS;
+ case CODELENS:
+ while (state->have < state->nlen + state->ndist) {
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.val < 16) {
+ DROPBITS(here.bits);
+ state->lens[state->have++] = here.val;
+ }
+ else {
+ if (here.val == 16) {
+ NEEDBITS(here.bits + 2);
+ DROPBITS(here.bits);
+ if (state->have == 0) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ len = state->lens[state->have - 1];
+ copy = 3 + BITS(2);
+ DROPBITS(2);
+ }
+ else if (here.val == 17) {
+ NEEDBITS(here.bits + 3);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 3 + BITS(3);
+ DROPBITS(3);
+ }
+ else {
+ NEEDBITS(here.bits + 7);
+ DROPBITS(here.bits);
+ len = 0;
+ copy = 11 + BITS(7);
+ DROPBITS(7);
+ }
+ if (state->have + copy > state->nlen + state->ndist) {
+ strm->msg = (char *)"invalid bit length repeat";
+ state->mode = BAD;
+ break;
+ }
+ while (copy--)
+ state->lens[state->have++] = (unsigned short)len;
+ }
+ }
+
+ /* handle error breaks in while */
+ if (state->mode == BAD) break;
+
+ /* check for end-of-block code (better have one) */
+ if (state->lens[256] == 0) {
+ strm->msg = (char *)"invalid code -- missing end-of-block";
+ state->mode = BAD;
+ break;
+ }
+
+ /* build code tables -- note: do not change the lenbits or distbits
+ values here (9 and 6) without reading the comments in inftrees.h
+ concerning the ENOUGH constants, which depend on those values */
+ state->next = state->codes;
+ state->lencode = (const code FAR *)(state->next);
+ state->lenbits = 9;
+ ret = inflate_table(LENS, state->lens, state->nlen, &(state->next),
+ &(state->lenbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid literal/lengths set";
+ state->mode = BAD;
+ break;
+ }
+ state->distcode = (const code FAR *)(state->next);
+ state->distbits = 6;
+ ret = inflate_table(DISTS, state->lens + state->nlen, state->ndist,
+ &(state->next), &(state->distbits), state->work);
+ if (ret) {
+ strm->msg = (char *)"invalid distances set";
+ state->mode = BAD;
+ break;
+ }
+ Tracev((stderr, "inflate: codes ok\n"));
+ state->mode = LEN_;
+ if (flush == Z_TREES) goto inf_leave;
+ case LEN_:
+ state->mode = LEN;
+ case LEN:
+ if (have >= 6 && left >= 258) {
+ RESTORE();
+ inflate_fast(strm, out);
+ LOAD();
+ if (state->mode == TYPE)
+ state->back = -1;
+ break;
+ }
+ state->back = 0;
+ for (;;) {
+ here = state->lencode[BITS(state->lenbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if (here.op && (here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->lencode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ state->back += last.bits;
+ }
+ DROPBITS(here.bits);
+ state->back += here.bits;
+ state->length = (unsigned)here.val;
+ if ((int)(here.op) == 0) {
+ Tracevv((stderr, here.val >= 0x20 && here.val < 0x7f ?
+ "inflate: literal '%c'\n" :
+ "inflate: literal 0x%02x\n", here.val));
+ state->mode = LIT;
+ break;
+ }
+ if (here.op & 32) {
+ Tracevv((stderr, "inflate: end of block\n"));
+ state->back = -1;
+ state->mode = TYPE;
+ break;
+ }
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid literal/length code";
+ state->mode = BAD;
+ break;
+ }
+ state->extra = (unsigned)(here.op) & 15;
+ state->mode = LENEXT;
+ case LENEXT:
+ if (state->extra) {
+ NEEDBITS(state->extra);
+ state->length += BITS(state->extra);
+ DROPBITS(state->extra);
+ state->back += state->extra;
+ }
+ Tracevv((stderr, "inflate: length %u\n", state->length));
+ state->was = state->length;
+ state->mode = DIST;
+ case DIST:
+ for (;;) {
+ here = state->distcode[BITS(state->distbits)];
+ if ((unsigned)(here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ if ((here.op & 0xf0) == 0) {
+ last = here;
+ for (;;) {
+ here = state->distcode[last.val +
+ (BITS(last.bits + last.op) >> last.bits)];
+ if ((unsigned)(last.bits + here.bits) <= bits) break;
+ PULLBYTE();
+ }
+ DROPBITS(last.bits);
+ state->back += last.bits;
+ }
+ DROPBITS(here.bits);
+ state->back += here.bits;
+ if (here.op & 64) {
+ strm->msg = (char *)"invalid distance code";
+ state->mode = BAD;
+ break;
+ }
+ state->offset = (unsigned)here.val;
+ state->extra = (unsigned)(here.op) & 15;
+ state->mode = DISTEXT;
+ case DISTEXT:
+ if (state->extra) {
+ NEEDBITS(state->extra);
+ state->offset += BITS(state->extra);
+ DROPBITS(state->extra);
+ state->back += state->extra;
+ }
+#ifdef INFLATE_STRICT
+ if (state->offset > state->dmax) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#endif
+ Tracevv((stderr, "inflate: distance %u\n", state->offset));
+ state->mode = MATCH;
+ case MATCH:
+ if (left == 0) goto inf_leave;
+ copy = out - left;
+ if (state->offset > copy) { /* copy from window */
+ copy = state->offset - copy;
+ if (copy > state->whave) {
+ if (state->sane) {
+ strm->msg = (char *)"invalid distance too far back";
+ state->mode = BAD;
+ break;
+ }
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ Trace((stderr, "inflate.c too far\n"));
+ copy -= state->whave;
+ if (copy > state->length) copy = state->length;
+ if (copy > left) copy = left;
+ left -= copy;
+ state->length -= copy;
+ do {
+ *put++ = 0;
+ } while (--copy);
+ if (state->length == 0) state->mode = LEN;
+ break;
+#endif
+ }
+ if (copy > state->wnext) {
+ copy -= state->wnext;
+ from = state->window + (state->wsize - copy);
+ }
+ else
+ from = state->window + (state->wnext - copy);
+ if (copy > state->length) copy = state->length;
+ }
+ else { /* copy from output */
+ from = put - state->offset;
+ copy = state->length;
+ }
+ if (copy > left) copy = left;
+ left -= copy;
+ state->length -= copy;
+ do {
+ *put++ = *from++;
+ } while (--copy);
+ if (state->length == 0) state->mode = LEN;
+ break;
+ case LIT:
+ if (left == 0) goto inf_leave;
+ *put++ = (unsigned char)(state->length);
+ left--;
+ state->mode = LEN;
+ break;
+ case CHECK:
+ if (state->wrap) {
+ NEEDBITS(32);
+ out -= left;
+ strm->total_out += out;
+ state->total += out;
+ if ((state->wrap & 4) && out)
+ strm->adler = state->check =
+ UPDATE(state->check, put - out, out);
+ out = left;
+ if ((state->wrap & 4) && (
+#ifdef GUNZIP
+ state->flags ? hold :
+#endif
+ ZSWAP32(hold)) != state->check) {
+ strm->msg = (char *)"incorrect data check";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ Tracev((stderr, "inflate: check matches trailer\n"));
+ }
+#ifdef GUNZIP
+ state->mode = LENGTH;
+ case LENGTH:
+ if (state->wrap && state->flags) {
+ NEEDBITS(32);
+ if (hold != (state->total & 0xffffffffUL)) {
+ strm->msg = (char *)"incorrect length check";
+ state->mode = BAD;
+ break;
+ }
+ INITBITS();
+ Tracev((stderr, "inflate: length matches trailer\n"));
+ }
+#endif
+ state->mode = DONE;
+ case DONE:
+ ret = Z_STREAM_END;
+ goto inf_leave;
+ case BAD:
+ ret = Z_DATA_ERROR;
+ goto inf_leave;
+ case MEM:
+ return Z_MEM_ERROR;
+ case SYNC:
+ default:
+ return Z_STREAM_ERROR;
+ }
+
+ /*
+ Return from inflate(), updating the total counts and the check value.
+ If there was no progress during the inflate() call, return a buffer
+ error. Call updatewindow() to create and/or update the window state.
+ Note: a memory error from inflate() is non-recoverable.
+ */
+ inf_leave:
+ RESTORE();
+ if (state->wsize || (out != strm->avail_out && state->mode < BAD &&
+ (state->mode < CHECK || flush != Z_FINISH)))
+ if (updatewindow(strm, strm->next_out, out - strm->avail_out)) {
+ state->mode = MEM;
+ return Z_MEM_ERROR;
+ }
+ in -= strm->avail_in;
+ out -= strm->avail_out;
+ strm->total_in += in;
+ strm->total_out += out;
+ state->total += out;
+ if ((state->wrap & 4) && out)
+ strm->adler = state->check =
+ UPDATE(state->check, strm->next_out - out, out);
+ strm->data_type = (int)state->bits + (state->last ? 64 : 0) +
+ (state->mode == TYPE ? 128 : 0) +
+ (state->mode == LEN_ || state->mode == COPY_ ? 256 : 0);
+ if (((in == 0 && out == 0) || flush == Z_FINISH) && ret == Z_OK)
+ ret = Z_BUF_ERROR;
+ return ret;
+}
+
+int ZEXPORT inflateEnd(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+ if (inflateStateCheck(strm))
+ return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->window != Z_NULL) ZFREE(strm, state->window);
+ ZFREE(strm, strm->state);
+ strm->state = Z_NULL;
+ Tracev((stderr, "inflate: end\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateGetDictionary(strm, dictionary, dictLength)
+z_streamp strm;
+Bytef *dictionary;
+uInt *dictLength;
+{
+ struct inflate_state FAR *state;
+
+ /* check state */
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+
+ /* copy dictionary */
+ if (state->whave && dictionary != Z_NULL) {
+ zmemcpy(dictionary, state->window + state->wnext,
+ state->whave - state->wnext);
+ zmemcpy(dictionary + state->whave - state->wnext,
+ state->window, state->wnext);
+ }
+ if (dictLength != Z_NULL)
+ *dictLength = state->whave;
+ return Z_OK;
+}
+
+int ZEXPORT inflateSetDictionary(strm, dictionary, dictLength)
+z_streamp strm;
+const Bytef *dictionary;
+uInt dictLength;
+{
+ struct inflate_state FAR *state;
+ unsigned long dictid;
+ int ret;
+
+ /* check state */
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (state->wrap != 0 && state->mode != DICT)
+ return Z_STREAM_ERROR;
+
+ /* check for correct dictionary identifier */
+ if (state->mode == DICT) {
+ dictid = adler32(0L, Z_NULL, 0);
+ dictid = adler32(dictid, dictionary, dictLength);
+ if (dictid != state->check)
+ return Z_DATA_ERROR;
+ }
+
+ /* copy dictionary to window using updatewindow(), which will amend the
+ existing dictionary if appropriate */
+ ret = updatewindow(strm, dictionary + dictLength, dictLength);
+ if (ret) {
+ state->mode = MEM;
+ return Z_MEM_ERROR;
+ }
+ state->havedict = 1;
+ Tracev((stderr, "inflate: dictionary set\n"));
+ return Z_OK;
+}
+
+int ZEXPORT inflateGetHeader(strm, head)
+z_streamp strm;
+gz_headerp head;
+{
+ struct inflate_state FAR *state;
+
+ /* check state */
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if ((state->wrap & 2) == 0) return Z_STREAM_ERROR;
+
+ /* save header structure */
+ state->head = head;
+ head->done = 0;
+ return Z_OK;
+}
+
+/*
+ Search buf[0..len-1] for the pattern: 0, 0, 0xff, 0xff. Return when found
+ or when out of input. When called, *have is the number of pattern bytes
+ found in order so far, in 0..3. On return *have is updated to the new
+ state. If on return *have equals four, then the pattern was found and the
+ return value is how many bytes were read including the last byte of the
+ pattern. If *have is less than four, then the pattern has not been found
+ yet and the return value is len. In the latter case, syncsearch() can be
+ called again with more data and the *have state. *have is initialized to
+ zero for the first call.
+ */
+local unsigned syncsearch(have, buf, len)
+unsigned FAR *have;
+const unsigned char FAR *buf;
+unsigned len;
+{
+ unsigned got;
+ unsigned next;
+
+ got = *have;
+ next = 0;
+ while (next < len && got < 4) {
+ if ((int)(buf[next]) == (got < 2 ? 0 : 0xff))
+ got++;
+ else if (buf[next])
+ got = 0;
+ else
+ got = 4 - got;
+ next++;
+ }
+ *have = got;
+ return next;
+}
+
+int ZEXPORT inflateSync(strm)
+z_streamp strm;
+{
+ unsigned len; /* number of bytes to look at or looked at */
+ unsigned long in, out; /* temporary to save total_in and total_out */
+ unsigned char buf[4]; /* to restore bit buffer to byte string */
+ struct inflate_state FAR *state;
+
+ /* check parameters */
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (strm->avail_in == 0 && state->bits < 8) return Z_BUF_ERROR;
+
+ /* if first time, start search in bit buffer */
+ if (state->mode != SYNC) {
+ state->mode = SYNC;
+ state->hold <<= state->bits & 7;
+ state->bits -= state->bits & 7;
+ len = 0;
+ while (state->bits >= 8) {
+ buf[len++] = (unsigned char)(state->hold);
+ state->hold >>= 8;
+ state->bits -= 8;
+ }
+ state->have = 0;
+ syncsearch(&(state->have), buf, len);
+ }
+
+ /* search available input */
+ len = syncsearch(&(state->have), strm->next_in, strm->avail_in);
+ strm->avail_in -= len;
+ strm->next_in += len;
+ strm->total_in += len;
+
+ /* return no joy or set up to restart inflate() on a new block */
+ if (state->have != 4) return Z_DATA_ERROR;
+ in = strm->total_in; out = strm->total_out;
+ inflateReset(strm);
+ strm->total_in = in; strm->total_out = out;
+ state->mode = TYPE;
+ return Z_OK;
+}
+
+/*
+ Returns true if inflate is currently at the end of a block generated by
+ Z_SYNC_FLUSH or Z_FULL_FLUSH. This function is used by one PPP
+ implementation to provide an additional safety check. PPP uses
+ Z_SYNC_FLUSH but removes the length bytes of the resulting empty stored
+ block. When decompressing, PPP checks that at the end of input packet,
+ inflate is waiting for these length bytes.
+ */
+int ZEXPORT inflateSyncPoint(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ return state->mode == STORED && state->bits == 0;
+}
+
+int ZEXPORT inflateCopy(dest, source)
+z_streamp dest;
+z_streamp source;
+{
+ struct inflate_state FAR *state;
+ struct inflate_state FAR *copy;
+ unsigned char FAR *window;
+ unsigned wsize;
+
+ /* check input */
+ if (inflateStateCheck(source) || dest == Z_NULL)
+ return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)source->state;
+
+ /* allocate space */
+ copy = (struct inflate_state FAR *)
+ ZALLOC(source, 1, sizeof(struct inflate_state));
+ if (copy == Z_NULL) return Z_MEM_ERROR;
+ window = Z_NULL;
+ if (state->window != Z_NULL) {
+ window = (unsigned char FAR *)
+ ZALLOC(source, 1U << state->wbits, sizeof(unsigned char));
+ if (window == Z_NULL) {
+ ZFREE(source, copy);
+ return Z_MEM_ERROR;
+ }
+ }
+
+ /* copy state */
+ zmemcpy((voidpf)dest, (voidpf)source, sizeof(z_stream));
+ zmemcpy((voidpf)copy, (voidpf)state, sizeof(struct inflate_state));
+ copy->strm = dest;
+ if (state->lencode >= state->codes &&
+ state->lencode <= state->codes + ENOUGH - 1) {
+ copy->lencode = copy->codes + (state->lencode - state->codes);
+ copy->distcode = copy->codes + (state->distcode - state->codes);
+ }
+ copy->next = copy->codes + (state->next - state->codes);
+ if (window != Z_NULL) {
+ wsize = 1U << state->wbits;
+ zmemcpy(window, state->window, wsize);
+ }
+ copy->window = window;
+ dest->state = (struct internal_state FAR *)copy;
+ return Z_OK;
+}
+
+int ZEXPORT inflateUndermine(strm, subvert)
+z_streamp strm;
+int subvert;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+#ifdef INFLATE_ALLOW_INVALID_DISTANCE_TOOFAR_ARRR
+ state->sane = !subvert;
+ return Z_OK;
+#else
+ (void)subvert;
+ state->sane = 1;
+ return Z_DATA_ERROR;
+#endif
+}
+
+int ZEXPORT inflateValidate(strm, check)
+z_streamp strm;
+int check;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm)) return Z_STREAM_ERROR;
+ state = (struct inflate_state FAR *)strm->state;
+ if (check)
+ state->wrap |= 4;
+ else
+ state->wrap &= ~4;
+ return Z_OK;
+}
+
+long ZEXPORT inflateMark(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+
+ if (inflateStateCheck(strm))
+ return -(1L << 16);
+ state = (struct inflate_state FAR *)strm->state;
+ return (long)(((unsigned long)((long)state->back)) << 16) +
+ (state->mode == COPY ? state->length :
+ (state->mode == MATCH ? state->was - state->length : 0));
+}
+
+unsigned long ZEXPORT inflateCodesUsed(strm)
+z_streamp strm;
+{
+ struct inflate_state FAR *state;
+ if (inflateStateCheck(strm)) return (unsigned long)-1;
+ state = (struct inflate_state FAR *)strm->state;
+ return (unsigned long)(state->next - state->codes);
+}
diff --git a/test/monniaux/zlib-1.2.11/inflate.h b/test/monniaux/zlib-1.2.11/inflate.h
new file mode 100644
index 00000000..a46cce6b
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inflate.h
@@ -0,0 +1,125 @@
+/* inflate.h -- internal inflate state definition
+ * Copyright (C) 1995-2016 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* define NO_GZIP when compiling if you want to disable gzip header and
+ trailer decoding by inflate(). NO_GZIP would be used to avoid linking in
+ the crc code when it is not needed. For shared libraries, gzip decoding
+ should be left enabled. */
+#ifndef NO_GZIP
+# define GUNZIP
+#endif
+
+/* Possible inflate modes between inflate() calls */
+typedef enum {
+ HEAD = 16180, /* i: waiting for magic header */
+ FLAGS, /* i: waiting for method and flags (gzip) */
+ TIME, /* i: waiting for modification time (gzip) */
+ OS, /* i: waiting for extra flags and operating system (gzip) */
+ EXLEN, /* i: waiting for extra length (gzip) */
+ EXTRA, /* i: waiting for extra bytes (gzip) */
+ NAME, /* i: waiting for end of file name (gzip) */
+ COMMENT, /* i: waiting for end of comment (gzip) */
+ HCRC, /* i: waiting for header crc (gzip) */
+ DICTID, /* i: waiting for dictionary check value */
+ DICT, /* waiting for inflateSetDictionary() call */
+ TYPE, /* i: waiting for type bits, including last-flag bit */
+ TYPEDO, /* i: same, but skip check to exit inflate on new block */
+ STORED, /* i: waiting for stored size (length and complement) */
+ COPY_, /* i/o: same as COPY below, but only first time in */
+ COPY, /* i/o: waiting for input or output to copy stored block */
+ TABLE, /* i: waiting for dynamic block table lengths */
+ LENLENS, /* i: waiting for code length code lengths */
+ CODELENS, /* i: waiting for length/lit and distance code lengths */
+ LEN_, /* i: same as LEN below, but only first time in */
+ LEN, /* i: waiting for length/lit/eob code */
+ LENEXT, /* i: waiting for length extra bits */
+ DIST, /* i: waiting for distance code */
+ DISTEXT, /* i: waiting for distance extra bits */
+ MATCH, /* o: waiting for output space to copy string */
+ LIT, /* o: waiting for output space to write literal */
+ CHECK, /* i: waiting for 32-bit check value */
+ LENGTH, /* i: waiting for 32-bit length (gzip) */
+ DONE, /* finished check, done -- remain here until reset */
+ BAD, /* got a data error -- remain here until reset */
+ MEM, /* got an inflate() memory error -- remain here until reset */
+ SYNC /* looking for synchronization bytes to restart inflate() */
+} inflate_mode;
+
+/*
+ State transitions between above modes -
+
+ (most modes can go to BAD or MEM on error -- not shown for clarity)
+
+ Process header:
+ HEAD -> (gzip) or (zlib) or (raw)
+ (gzip) -> FLAGS -> TIME -> OS -> EXLEN -> EXTRA -> NAME -> COMMENT ->
+ HCRC -> TYPE
+ (zlib) -> DICTID or TYPE
+ DICTID -> DICT -> TYPE
+ (raw) -> TYPEDO
+ Read deflate blocks:
+ TYPE -> TYPEDO -> STORED or TABLE or LEN_ or CHECK
+ STORED -> COPY_ -> COPY -> TYPE
+ TABLE -> LENLENS -> CODELENS -> LEN_
+ LEN_ -> LEN
+ Read deflate codes in fixed or dynamic block:
+ LEN -> LENEXT or LIT or TYPE
+ LENEXT -> DIST -> DISTEXT -> MATCH -> LEN
+ LIT -> LEN
+ Process trailer:
+ CHECK -> LENGTH -> DONE
+ */
+
+/* State maintained between inflate() calls -- approximately 7K bytes, not
+ including the allocated sliding window, which is up to 32K bytes. */
+struct inflate_state {
+ z_streamp strm; /* pointer back to this zlib stream */
+ inflate_mode mode; /* current inflate mode */
+ int last; /* true if processing last block */
+ int wrap; /* bit 0 true for zlib, bit 1 true for gzip,
+ bit 2 true to validate check value */
+ int havedict; /* true if dictionary provided */
+ int flags; /* gzip header method and flags (0 if zlib) */
+ unsigned dmax; /* zlib header max distance (INFLATE_STRICT) */
+ unsigned long check; /* protected copy of check value */
+ unsigned long total; /* protected copy of output count */
+ gz_headerp head; /* where to save gzip header information */
+ /* sliding window */
+ unsigned wbits; /* log base 2 of requested window size */
+ unsigned wsize; /* window size or zero if not using window */
+ unsigned whave; /* valid bytes in the window */
+ unsigned wnext; /* window write index */
+ unsigned char FAR *window; /* allocated sliding window, if needed */
+ /* bit accumulator */
+ unsigned long hold; /* input bit accumulator */
+ unsigned bits; /* number of bits in "in" */
+ /* for string and stored block copying */
+ unsigned length; /* literal or length of data to copy */
+ unsigned offset; /* distance back to copy string from */
+ /* for table and code decoding */
+ unsigned extra; /* extra bits needed */
+ /* fixed and dynamic code tables */
+ code const FAR *lencode; /* starting table for length/literal codes */
+ code const FAR *distcode; /* starting table for distance codes */
+ unsigned lenbits; /* index bits for lencode */
+ unsigned distbits; /* index bits for distcode */
+ /* dynamic table building */
+ unsigned ncode; /* number of code length code lengths */
+ unsigned nlen; /* number of length code lengths */
+ unsigned ndist; /* number of distance code lengths */
+ unsigned have; /* number of code lengths in lens[] */
+ code FAR *next; /* next available space in codes[] */
+ unsigned short lens[320]; /* temporary storage for code lengths */
+ unsigned short work[288]; /* work area for code table building */
+ code codes[ENOUGH]; /* space for code tables */
+ int sane; /* if false, allow invalid distance too far */
+ int back; /* bits back of last unprocessed length/lit */
+ unsigned was; /* initial length of match */
+};
diff --git a/test/monniaux/zlib-1.2.11/inftrees.c b/test/monniaux/zlib-1.2.11/inftrees.c
new file mode 100644
index 00000000..2ea08fc1
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inftrees.c
@@ -0,0 +1,304 @@
+/* inftrees.c -- generate Huffman trees for efficient decoding
+ * Copyright (C) 1995-2017 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+#include "zutil.h"
+#include "inftrees.h"
+
+#define MAXBITS 15
+
+const char inflate_copyright[] =
+ " inflate 1.2.11 Copyright 1995-2017 Mark Adler ";
+/*
+ If you use the zlib library in a product, an acknowledgment is welcome
+ in the documentation of your product. If for some reason you cannot
+ include such an acknowledgment, I would appreciate that you keep this
+ copyright string in the executable of your product.
+ */
+
+/*
+ Build a set of tables to decode the provided canonical Huffman code.
+ The code lengths are lens[0..codes-1]. The result starts at *table,
+ whose indices are 0..2^bits-1. work is a writable array of at least
+ lens shorts, which is used as a work area. type is the type of code
+ to be generated, CODES, LENS, or DISTS. On return, zero is success,
+ -1 is an invalid code, and +1 means that ENOUGH isn't enough. table
+ on return points to the next available entry's address. bits is the
+ requested root table index bits, and on return it is the actual root
+ table index bits. It will differ if the request is greater than the
+ longest code or if it is less than the shortest code.
+ */
+int ZLIB_INTERNAL inflate_table(type, lens, codes, table, bits, work)
+codetype type;
+unsigned short FAR *lens;
+unsigned codes;
+code FAR * FAR *table;
+unsigned FAR *bits;
+unsigned short FAR *work;
+{
+ unsigned len; /* a code's length in bits */
+ unsigned sym; /* index of code symbols */
+ unsigned min, max; /* minimum and maximum code lengths */
+ unsigned root; /* number of index bits for root table */
+ unsigned curr; /* number of index bits for current table */
+ unsigned drop; /* code bits to drop for sub-table */
+ int left; /* number of prefix codes available */
+ unsigned used; /* code entries in table used */
+ unsigned huff; /* Huffman code */
+ unsigned incr; /* for incrementing code, index */
+ unsigned fill; /* index for replicating entries */
+ unsigned low; /* low bits for current root entry */
+ unsigned mask; /* mask for low root bits */
+ code here; /* table entry for duplication */
+ code FAR *next; /* next available space in table */
+ const unsigned short FAR *base; /* base value table to use */
+ const unsigned short FAR *extra; /* extra bits table to use */
+ unsigned match; /* use base and extra for symbol >= match */
+ unsigned short count[MAXBITS+1]; /* number of codes of each length */
+ unsigned short offs[MAXBITS+1]; /* offsets in table for each length */
+ static const unsigned short lbase[31] = { /* Length codes 257..285 base */
+ 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
+ 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0};
+ static const unsigned short lext[31] = { /* Length codes 257..285 extra */
+ 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18,
+ 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 77, 202};
+ static const unsigned short dbase[32] = { /* Distance codes 0..29 base */
+ 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
+ 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
+ 8193, 12289, 16385, 24577, 0, 0};
+ static const unsigned short dext[32] = { /* Distance codes 0..29 extra */
+ 16, 16, 16, 16, 17, 17, 18, 18, 19, 19, 20, 20, 21, 21, 22, 22,
+ 23, 23, 24, 24, 25, 25, 26, 26, 27, 27,
+ 28, 28, 29, 29, 64, 64};
+
+ /*
+ Process a set of code lengths to create a canonical Huffman code. The
+ code lengths are lens[0..codes-1]. Each length corresponds to the
+ symbols 0..codes-1. The Huffman code is generated by first sorting the
+ symbols by length from short to long, and retaining the symbol order
+ for codes with equal lengths. Then the code starts with all zero bits
+ for the first code of the shortest length, and the codes are integer
+ increments for the same length, and zeros are appended as the length
+ increases. For the deflate format, these bits are stored backwards
+ from their more natural integer increment ordering, and so when the
+ decoding tables are built in the large loop below, the integer codes
+ are incremented backwards.
+
+ This routine assumes, but does not check, that all of the entries in
+ lens[] are in the range 0..MAXBITS. The caller must assure this.
+ 1..MAXBITS is interpreted as that code length. zero means that that
+ symbol does not occur in this code.
+
+ The codes are sorted by computing a count of codes for each length,
+ creating from that a table of starting indices for each length in the
+ sorted table, and then entering the symbols in order in the sorted
+ table. The sorted table is work[], with that space being provided by
+ the caller.
+
+ The length counts are used for other purposes as well, i.e. finding
+ the minimum and maximum length codes, determining if there are any
+ codes at all, checking for a valid set of lengths, and looking ahead
+ at length counts to determine sub-table sizes when building the
+ decoding tables.
+ */
+
+ /* accumulate lengths for codes (assumes lens[] all in 0..MAXBITS) */
+ for (len = 0; len <= MAXBITS; len++)
+ count[len] = 0;
+ for (sym = 0; sym < codes; sym++)
+ count[lens[sym]]++;
+
+ /* bound code lengths, force root to be within code lengths */
+ root = *bits;
+ for (max = MAXBITS; max >= 1; max--)
+ if (count[max] != 0) break;
+ if (root > max) root = max;
+ if (max == 0) { /* no symbols to code at all */
+ here.op = (unsigned char)64; /* invalid code marker */
+ here.bits = (unsigned char)1;
+ here.val = (unsigned short)0;
+ *(*table)++ = here; /* make a table to force an error */
+ *(*table)++ = here;
+ *bits = 1;
+ return 0; /* no symbols, but wait for decoding to report error */
+ }
+ for (min = 1; min < max; min++)
+ if (count[min] != 0) break;
+ if (root < min) root = min;
+
+ /* check for an over-subscribed or incomplete set of lengths */
+ left = 1;
+ for (len = 1; len <= MAXBITS; len++) {
+ left <<= 1;
+ left -= count[len];
+ if (left < 0) return -1; /* over-subscribed */
+ }
+ if (left > 0 && (type == CODES || max != 1))
+ return -1; /* incomplete set */
+
+ /* generate offsets into symbol table for each length for sorting */
+ offs[1] = 0;
+ for (len = 1; len < MAXBITS; len++)
+ offs[len + 1] = offs[len] + count[len];
+
+ /* sort symbols by length, by symbol order within each length */
+ for (sym = 0; sym < codes; sym++)
+ if (lens[sym] != 0) work[offs[lens[sym]]++] = (unsigned short)sym;
+
+ /*
+ Create and fill in decoding tables. In this loop, the table being
+ filled is at next and has curr index bits. The code being used is huff
+ with length len. That code is converted to an index by dropping drop
+ bits off of the bottom. For codes where len is less than drop + curr,
+ those top drop + curr - len bits are incremented through all values to
+ fill the table with replicated entries.
+
+ root is the number of index bits for the root table. When len exceeds
+ root, sub-tables are created pointed to by the root entry with an index
+ of the low root bits of huff. This is saved in low to check for when a
+ new sub-table should be started. drop is zero when the root table is
+ being filled, and drop is root when sub-tables are being filled.
+
+ When a new sub-table is needed, it is necessary to look ahead in the
+ code lengths to determine what size sub-table is needed. The length
+ counts are used for this, and so count[] is decremented as codes are
+ entered in the tables.
+
+ used keeps track of how many table entries have been allocated from the
+ provided *table space. It is checked for LENS and DIST tables against
+ the constants ENOUGH_LENS and ENOUGH_DISTS to guard against changes in
+ the initial root table size constants. See the comments in inftrees.h
+ for more information.
+
+ sym increments through all symbols, and the loop terminates when
+ all codes of length max, i.e. all codes, have been processed. This
+ routine permits incomplete codes, so another loop after this one fills
+ in the rest of the decoding tables with invalid code markers.
+ */
+
+ /* set up for code type */
+ switch (type) {
+ case CODES:
+ base = extra = work; /* dummy value--not used */
+ match = 20;
+ break;
+ case LENS:
+ base = lbase;
+ extra = lext;
+ match = 257;
+ break;
+ default: /* DISTS */
+ base = dbase;
+ extra = dext;
+ match = 0;
+ }
+
+ /* initialize state for loop */
+ huff = 0; /* starting code */
+ sym = 0; /* starting code symbol */
+ len = min; /* starting code length */
+ next = *table; /* current table to fill in */
+ curr = root; /* current table index bits */
+ drop = 0; /* current bits to drop from code for index */
+ low = (unsigned)(-1); /* trigger new sub-table when len > root */
+ used = 1U << root; /* use root table entries */
+ mask = used - 1; /* mask for comparing low */
+
+ /* check available table space */
+ if ((type == LENS && used > ENOUGH_LENS) ||
+ (type == DISTS && used > ENOUGH_DISTS))
+ return 1;
+
+ /* process all codes and make table entries */
+ for (;;) {
+ /* create table entry */
+ here.bits = (unsigned char)(len - drop);
+ if (work[sym] + 1U < match) {
+ here.op = (unsigned char)0;
+ here.val = work[sym];
+ }
+ else if (work[sym] >= match) {
+ here.op = (unsigned char)(extra[work[sym] - match]);
+ here.val = base[work[sym] - match];
+ }
+ else {
+ here.op = (unsigned char)(32 + 64); /* end of block */
+ here.val = 0;
+ }
+
+ /* replicate for those indices with low len bits equal to huff */
+ incr = 1U << (len - drop);
+ fill = 1U << curr;
+ min = fill; /* save offset to next table */
+ do {
+ fill -= incr;
+ next[(huff >> drop) + fill] = here;
+ } while (fill != 0);
+
+ /* backwards increment the len-bit code huff */
+ incr = 1U << (len - 1);
+ while (huff & incr)
+ incr >>= 1;
+ if (incr != 0) {
+ huff &= incr - 1;
+ huff += incr;
+ }
+ else
+ huff = 0;
+
+ /* go to next symbol, update count, len */
+ sym++;
+ if (--(count[len]) == 0) {
+ if (len == max) break;
+ len = lens[work[sym]];
+ }
+
+ /* create new sub-table if needed */
+ if (len > root && (huff & mask) != low) {
+ /* if first time, transition to sub-tables */
+ if (drop == 0)
+ drop = root;
+
+ /* increment past last table */
+ next += min; /* here min is 1 << curr */
+
+ /* determine length of next table */
+ curr = len - drop;
+ left = (int)(1 << curr);
+ while (curr + drop < max) {
+ left -= count[curr + drop];
+ if (left <= 0) break;
+ curr++;
+ left <<= 1;
+ }
+
+ /* check for enough space */
+ used += 1U << curr;
+ if ((type == LENS && used > ENOUGH_LENS) ||
+ (type == DISTS && used > ENOUGH_DISTS))
+ return 1;
+
+ /* point entry in root table to sub-table */
+ low = huff & mask;
+ (*table)[low].op = (unsigned char)curr;
+ (*table)[low].bits = (unsigned char)root;
+ (*table)[low].val = (unsigned short)(next - *table);
+ }
+ }
+
+ /* fill in remaining table entry if code is incomplete (guaranteed to have
+ at most one remaining entry, since if the code is incomplete, the
+ maximum code length that was allowed to get this far is one bit) */
+ if (huff != 0) {
+ here.op = (unsigned char)64; /* invalid code marker */
+ here.bits = (unsigned char)(len - drop);
+ here.val = (unsigned short)0;
+ next[huff] = here;
+ }
+
+ /* set return parameters */
+ *table += used;
+ *bits = root;
+ return 0;
+}
diff --git a/test/monniaux/zlib-1.2.11/inftrees.h b/test/monniaux/zlib-1.2.11/inftrees.h
new file mode 100644
index 00000000..baa53a0b
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/inftrees.h
@@ -0,0 +1,62 @@
+/* inftrees.h -- header to use inftrees.c
+ * Copyright (C) 1995-2005, 2010 Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* Structure for decoding tables. Each entry provides either the
+ information needed to do the operation requested by the code that
+ indexed that table entry, or it provides a pointer to another
+ table that indexes more bits of the code. op indicates whether
+ the entry is a pointer to another table, a literal, a length or
+ distance, an end-of-block, or an invalid code. For a table
+ pointer, the low four bits of op is the number of index bits of
+ that table. For a length or distance, the low four bits of op
+ is the number of extra bits to get after the code. bits is
+ the number of bits in this code or part of the code to drop off
+ of the bit buffer. val is the actual byte to output in the case
+ of a literal, the base length or distance, or the offset from
+ the current table to the next table. Each entry is four bytes. */
+typedef struct {
+ unsigned char op; /* operation, extra bits, table bits */
+ unsigned char bits; /* bits in this part of the code */
+ unsigned short val; /* offset in table or code value */
+} code;
+
+/* op values as set by inflate_table():
+ 00000000 - literal
+ 0000tttt - table link, tttt != 0 is the number of table index bits
+ 0001eeee - length or distance, eeee is the number of extra bits
+ 01100000 - end of block
+ 01000000 - invalid code
+ */
+
+/* Maximum size of the dynamic table. The maximum number of code structures is
+ 1444, which is the sum of 852 for literal/length codes and 592 for distance
+ codes. These values were found by exhaustive searches using the program
+ examples/enough.c found in the zlib distribtution. The arguments to that
+ program are the number of symbols, the initial root table size, and the
+ maximum bit length of a code. "enough 286 9 15" for literal/length codes
+ returns returns 852, and "enough 30 6 15" for distance codes returns 592.
+ The initial root table size (9 or 6) is found in the fifth argument of the
+ inflate_table() calls in inflate.c and infback.c. If the root table size is
+ changed, then these maximum sizes would be need to be recalculated and
+ updated. */
+#define ENOUGH_LENS 852
+#define ENOUGH_DISTS 592
+#define ENOUGH (ENOUGH_LENS+ENOUGH_DISTS)
+
+/* Type of code to build for inflate_table() */
+typedef enum {
+ CODES,
+ LENS,
+ DISTS
+} codetype;
+
+int ZLIB_INTERNAL inflate_table OF((codetype type, unsigned short FAR *lens,
+ unsigned codes, code FAR * FAR *table,
+ unsigned FAR *bits, unsigned short FAR *work));
diff --git a/test/monniaux/zlib-1.2.11/make.proto b/test/monniaux/zlib-1.2.11/make.proto
new file mode 100644
index 00000000..cb7cf3c2
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/make.proto
@@ -0,0 +1,4 @@
+sources: "$(wildcard *.c)"
+target: minigzip
+measures: [cycles]
+name: zlib
diff --git a/test/monniaux/zlib-1.2.11/minigzip.c b/test/monniaux/zlib-1.2.11/minigzip.c
new file mode 100644
index 00000000..0a88f14b
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/minigzip.c
@@ -0,0 +1,663 @@
+/* minigzip.c -- simulate gzip using the zlib compression library
+ * Copyright (C) 1995-2006, 2010, 2011, 2016 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * minigzip is a minimal implementation of the gzip utility. This is
+ * only an example of using zlib and isn't meant to replace the
+ * full-featured gzip. No attempt is made to deal with file systems
+ * limiting names to 14 or 8+3 characters, etc... Error checking is
+ * very limited. So use minigzip only for testing; use gzip for the
+ * real thing. On MSDOS, use only on file names without extension
+ * or in pipe mode.
+ */
+
+/* @(#) $Id$ */
+
+#define VERIMAG
+#ifdef VERIMAG
+#include "../clock.h"
+#endif
+
+#include "zlib.h"
+#include <stdio.h>
+
+#ifdef STDC
+# include <string.h>
+# include <stdlib.h>
+#endif
+
+#ifdef USE_MMAP
+# include <sys/types.h>
+# include <sys/mman.h>
+# include <sys/stat.h>
+#endif
+
+#if defined(MSDOS) || defined(OS2) || defined(WIN32) || defined(__CYGWIN__)
+# include <fcntl.h>
+# include <io.h>
+# ifdef UNDER_CE
+# include <stdlib.h>
+# endif
+# define SET_BINARY_MODE(file) setmode(fileno(file), O_BINARY)
+#else
+# define SET_BINARY_MODE(file)
+#endif
+
+#if defined(_MSC_VER) && _MSC_VER < 1900
+# define snprintf _snprintf
+#endif
+
+#ifdef VMS
+# define unlink delete
+# define GZ_SUFFIX "-gz"
+#endif
+#ifdef RISCOS
+# define unlink remove
+# define GZ_SUFFIX "-gz"
+# define fileno(file) file->__file
+#endif
+#if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os
+# include <unix.h> /* for fileno */
+#endif
+
+#if !defined(Z_HAVE_UNISTD_H) && !defined(_LARGEFILE64_SOURCE)
+#ifndef WIN32 /* unlink already in stdio.h for WIN32 */
+ extern int unlink OF((const char *));
+#endif
+#endif
+
+#if defined(UNDER_CE)
+# include <windows.h>
+# define perror(s) pwinerror(s)
+
+/* Map the Windows error number in ERROR to a locale-dependent error
+ message string and return a pointer to it. Typically, the values
+ for ERROR come from GetLastError.
+
+ The string pointed to shall not be modified by the application,
+ but may be overwritten by a subsequent call to strwinerror
+
+ The strwinerror function does not change the current setting
+ of GetLastError. */
+
+static char *strwinerror (error)
+ DWORD error;
+{
+ static char buf[1024];
+
+ wchar_t *msgbuf;
+ DWORD lasterr = GetLastError();
+ DWORD chars = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER,
+ NULL,
+ error,
+ 0, /* Default language */
+ (LPVOID)&msgbuf,
+ 0,
+ NULL);
+ if (chars != 0) {
+ /* If there is an \r\n appended, zap it. */
+ if (chars >= 2
+ && msgbuf[chars - 2] == '\r' && msgbuf[chars - 1] == '\n') {
+ chars -= 2;
+ msgbuf[chars] = 0;
+ }
+
+ if (chars > sizeof (buf) - 1) {
+ chars = sizeof (buf) - 1;
+ msgbuf[chars] = 0;
+ }
+
+ wcstombs(buf, msgbuf, chars + 1);
+ LocalFree(msgbuf);
+ }
+ else {
+ sprintf(buf, "unknown win32 error (%ld)", error);
+ }
+
+ SetLastError(lasterr);
+ return buf;
+}
+
+static void pwinerror (s)
+ const char *s;
+{
+ if (s && *s)
+ fprintf(stderr, "%s: %s\n", s, strwinerror(GetLastError ()));
+ else
+ fprintf(stderr, "%s\n", strwinerror(GetLastError ()));
+}
+
+#endif /* UNDER_CE */
+
+#ifndef GZ_SUFFIX
+# define GZ_SUFFIX ".gz"
+#endif
+#define SUFFIX_LEN (sizeof(GZ_SUFFIX)-1)
+
+#define BUFLEN 16384
+#define MAX_NAME_LEN 1024
+
+#ifdef MAXSEG_64K
+# define local static
+ /* Needed for systems with limitation on stack size. */
+#else
+# define local
+#endif
+
+#ifdef Z_SOLO
+/* for Z_SOLO, create simplified gz* functions using deflate and inflate */
+
+#if defined(Z_HAVE_UNISTD_H) || defined(Z_LARGE)
+# include <unistd.h> /* for unlink() */
+#endif
+
+void *myalloc OF((void *, unsigned, unsigned));
+void myfree OF((void *, void *));
+
+void *myalloc(q, n, m)
+ void *q;
+ unsigned n, m;
+{
+ (void)q;
+ return calloc(n, m);
+}
+
+void myfree(q, p)
+ void *q, *p;
+{
+ (void)q;
+ free(p);
+}
+
+typedef struct gzFile_s {
+ FILE *file;
+ int write;
+ int err;
+ char *msg;
+ z_stream strm;
+} *gzFile;
+
+gzFile gzopen OF((const char *, const char *));
+gzFile gzdopen OF((int, const char *));
+gzFile gz_open OF((const char *, int, const char *));
+
+gzFile gzopen(path, mode)
+const char *path;
+const char *mode;
+{
+ return gz_open(path, -1, mode);
+}
+
+gzFile gzdopen(fd, mode)
+int fd;
+const char *mode;
+{
+ return gz_open(NULL, fd, mode);
+}
+
+gzFile gz_open(path, fd, mode)
+ const char *path;
+ int fd;
+ const char *mode;
+{
+ gzFile gz;
+ int ret;
+
+ gz = malloc(sizeof(struct gzFile_s));
+ if (gz == NULL)
+ return NULL;
+ gz->write = strchr(mode, 'w') != NULL;
+ gz->strm.zalloc = myalloc;
+ gz->strm.zfree = myfree;
+ gz->strm.opaque = Z_NULL;
+ if (gz->write)
+ ret = deflateInit2(&(gz->strm), -1, 8, 15 + 16, 8, 0);
+ else {
+ gz->strm.next_in = 0;
+ gz->strm.avail_in = Z_NULL;
+ ret = inflateInit2(&(gz->strm), 15 + 16);
+ }
+ if (ret != Z_OK) {
+ free(gz);
+ return NULL;
+ }
+ gz->file = path == NULL ? fdopen(fd, gz->write ? "wb" : "rb") :
+ fopen(path, gz->write ? "wb" : "rb");
+ if (gz->file == NULL) {
+ gz->write ? deflateEnd(&(gz->strm)) : inflateEnd(&(gz->strm));
+ free(gz);
+ return NULL;
+ }
+ gz->err = 0;
+ gz->msg = "";
+ return gz;
+}
+
+int gzwrite OF((gzFile, const void *, unsigned));
+
+int gzwrite(gz, buf, len)
+ gzFile gz;
+ const void *buf;
+ unsigned len;
+{
+ z_stream *strm;
+ unsigned char out[BUFLEN];
+
+ if (gz == NULL || !gz->write)
+ return 0;
+ strm = &(gz->strm);
+ strm->next_in = (void *)buf;
+ strm->avail_in = len;
+ do {
+ strm->next_out = out;
+ strm->avail_out = BUFLEN;
+ (void)deflate(strm, Z_NO_FLUSH);
+ fwrite(out, 1, BUFLEN - strm->avail_out, gz->file);
+ } while (strm->avail_out == 0);
+ return len;
+}
+
+int gzread OF((gzFile, void *, unsigned));
+
+int gzread(gz, buf, len)
+ gzFile gz;
+ void *buf;
+ unsigned len;
+{
+ int ret;
+ unsigned got;
+ unsigned char in[1];
+ z_stream *strm;
+
+ if (gz == NULL || gz->write)
+ return 0;
+ if (gz->err)
+ return 0;
+ strm = &(gz->strm);
+ strm->next_out = (void *)buf;
+ strm->avail_out = len;
+ do {
+ got = fread(in, 1, 1, gz->file);
+ if (got == 0)
+ break;
+ strm->next_in = in;
+ strm->avail_in = 1;
+ ret = inflate(strm, Z_NO_FLUSH);
+ if (ret == Z_DATA_ERROR) {
+ gz->err = Z_DATA_ERROR;
+ gz->msg = strm->msg;
+ return 0;
+ }
+ if (ret == Z_STREAM_END)
+ inflateReset(strm);
+ } while (strm->avail_out);
+ return len - strm->avail_out;
+}
+
+int gzclose OF((gzFile));
+
+int gzclose(gz)
+ gzFile gz;
+{
+ z_stream *strm;
+ unsigned char out[BUFLEN];
+
+ if (gz == NULL)
+ return Z_STREAM_ERROR;
+ strm = &(gz->strm);
+ if (gz->write) {
+ strm->next_in = Z_NULL;
+ strm->avail_in = 0;
+ do {
+ strm->next_out = out;
+ strm->avail_out = BUFLEN;
+ (void)deflate(strm, Z_FINISH);
+ fwrite(out, 1, BUFLEN - strm->avail_out, gz->file);
+ } while (strm->avail_out == 0);
+ deflateEnd(strm);
+ }
+ else
+ inflateEnd(strm);
+ fclose(gz->file);
+ free(gz);
+ return Z_OK;
+}
+
+const char *gzerror OF((gzFile, int *));
+
+const char *gzerror(gz, err)
+ gzFile gz;
+ int *err;
+{
+ *err = gz->err;
+ return gz->msg;
+}
+
+#endif
+
+static char *prog;
+
+void error OF((const char *msg));
+void gz_compress OF((FILE *in, gzFile out));
+#ifdef USE_MMAP
+int gz_compress_mmap OF((FILE *in, gzFile out));
+#endif
+void gz_uncompress OF((gzFile in, FILE *out));
+void file_compress OF((char *file, char *mode));
+void file_uncompress OF((char *file));
+int main OF((int argc, char *argv[]));
+
+/* ===========================================================================
+ * Display error message and exit
+ */
+void error(msg)
+ const char *msg;
+{
+ fprintf(stderr, "%s: %s\n", prog, msg);
+ exit(1);
+}
+
+/* ===========================================================================
+ * Compress input to output then close both files.
+ */
+
+void gz_compress(in, out)
+ FILE *in;
+ gzFile out;
+{
+ local char buf[BUFLEN];
+ int len;
+ int err;
+
+#ifdef USE_MMAP
+ /* Try first compressing with mmap. If mmap fails (minigzip used in a
+ * pipe), use the normal fread loop.
+ */
+ if (gz_compress_mmap(in, out) == Z_OK) return;
+#endif
+ for (;;) {
+ len = (int)fread(buf, 1, sizeof(buf), in);
+ if (ferror(in)) {
+ perror("fread");
+ exit(1);
+ }
+ if (len == 0) break;
+
+ if (gzwrite(out, buf, (unsigned)len) != len) error(gzerror(out, &err));
+ }
+ fclose(in);
+ if (gzclose(out) != Z_OK) error("failed gzclose");
+}
+
+#ifdef USE_MMAP /* MMAP version, Miguel Albrecht <malbrech@eso.org> */
+
+/* Try compressing the input file at once using mmap. Return Z_OK if
+ * if success, Z_ERRNO otherwise.
+ */
+int gz_compress_mmap(in, out)
+ FILE *in;
+ gzFile out;
+{
+ int len;
+ int err;
+ int ifd = fileno(in);
+ caddr_t buf; /* mmap'ed buffer for the entire input file */
+ off_t buf_len; /* length of the input file */
+ struct stat sb;
+
+ /* Determine the size of the file, needed for mmap: */
+ if (fstat(ifd, &sb) < 0) return Z_ERRNO;
+ buf_len = sb.st_size;
+ if (buf_len <= 0) return Z_ERRNO;
+
+ /* Now do the actual mmap: */
+ buf = mmap((caddr_t) 0, buf_len, PROT_READ, MAP_SHARED, ifd, (off_t)0);
+ if (buf == (caddr_t)(-1)) return Z_ERRNO;
+
+ /* Compress the whole file at once: */
+ len = gzwrite(out, (char *)buf, (unsigned)buf_len);
+
+ if (len != (int)buf_len) error(gzerror(out, &err));
+
+ munmap(buf, buf_len);
+ fclose(in);
+ if (gzclose(out) != Z_OK) error("failed gzclose");
+ return Z_OK;
+}
+#endif /* USE_MMAP */
+
+/* ===========================================================================
+ * Uncompress input to output then close both files.
+ */
+void gz_uncompress(in, out)
+ gzFile in;
+ FILE *out;
+{
+ local char buf[BUFLEN];
+ int len;
+ int err;
+
+ for (;;) {
+ len = gzread(in, buf, sizeof(buf));
+ if (len < 0) error (gzerror(in, &err));
+ if (len == 0) break;
+
+ if ((int)fwrite(buf, 1, (unsigned)len, out) != len) {
+ error("failed fwrite");
+ }
+ }
+ if (fclose(out)) error("failed fclose");
+
+ if (gzclose(in) != Z_OK) error("failed gzclose");
+}
+
+
+/* ===========================================================================
+ * Compress the given file: create a corresponding .gz file and remove the
+ * original.
+ */
+void file_compress(file, mode)
+ char *file;
+ char *mode;
+{
+ local char outfile[MAX_NAME_LEN];
+ FILE *in;
+ gzFile out;
+
+ if (strlen(file) + strlen(GZ_SUFFIX) >= sizeof(outfile)) {
+ fprintf(stderr, "%s: filename too long\n", prog);
+ exit(1);
+ }
+
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ snprintf(outfile, sizeof(outfile), "%s%s", file, GZ_SUFFIX);
+#else
+ strcpy(outfile, file);
+ strcat(outfile, GZ_SUFFIX);
+#endif
+
+ in = fopen(file, "rb");
+ if (in == NULL) {
+ perror(file);
+ exit(1);
+ }
+ out = gzopen(outfile, mode);
+ if (out == NULL) {
+ fprintf(stderr, "%s: can't gzopen %s\n", prog, outfile);
+ exit(1);
+ }
+ gz_compress(in, out);
+
+ unlink(file);
+}
+
+
+/* ===========================================================================
+ * Uncompress the given file and remove the original.
+ */
+void file_uncompress(file)
+ char *file;
+{
+ local char buf[MAX_NAME_LEN];
+ char *infile, *outfile;
+ FILE *out;
+ gzFile in;
+ unsigned len = strlen(file);
+
+ if (len + strlen(GZ_SUFFIX) >= sizeof(buf)) {
+ fprintf(stderr, "%s: filename too long\n", prog);
+ exit(1);
+ }
+
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ snprintf(buf, sizeof(buf), "%s", file);
+#else
+ strcpy(buf, file);
+#endif
+
+ if (len > SUFFIX_LEN && strcmp(file+len-SUFFIX_LEN, GZ_SUFFIX) == 0) {
+ infile = file;
+ outfile = buf;
+ outfile[len-3] = '\0';
+ } else {
+ outfile = file;
+ infile = buf;
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ snprintf(buf + len, sizeof(buf) - len, "%s", GZ_SUFFIX);
+#else
+ strcat(infile, GZ_SUFFIX);
+#endif
+ }
+ in = gzopen(infile, "rb");
+ if (in == NULL) {
+ fprintf(stderr, "%s: can't gzopen %s\n", prog, infile);
+ exit(1);
+ }
+ out = fopen(outfile, "wb");
+ if (out == NULL) {
+ perror(file);
+ exit(1);
+ }
+
+ gz_uncompress(in, out);
+
+ unlink(infile);
+}
+
+
+/* ===========================================================================
+ * Usage: minigzip [-c] [-d] [-f] [-h] [-r] [-1 to -9] [files...]
+ * -c : write to standard output
+ * -d : decompress
+ * -f : compress with Z_FILTERED
+ * -h : compress with Z_HUFFMAN_ONLY
+ * -r : compress with Z_RLE
+ * -1 to -9 : compression level
+ */
+
+int main(argc, argv)
+ int argc;
+ char *argv[];
+{
+ int copyout = 0;
+ int uncompr = 0;
+ gzFile file;
+ char *bname, outmode[20];
+
+#if !defined(NO_snprintf) && !defined(NO_vsnprintf)
+ snprintf(outmode, sizeof(outmode), "%s", "wb6 ");
+#else
+ strcpy(outmode, "wb6 ");
+#endif
+
+ prog = argv[0];
+ bname = strrchr(argv[0], '/');
+ if (bname)
+ bname++;
+ else
+ bname = argv[0];
+ argc--, argv++;
+
+ if (!strcmp(bname, "gunzip"))
+ uncompr = 1;
+ else if (!strcmp(bname, "zcat"))
+ copyout = uncompr = 1;
+
+ while (argc > 0) {
+ if (strcmp(*argv, "-c") == 0)
+ copyout = 1;
+ else if (strcmp(*argv, "-d") == 0)
+ uncompr = 1;
+ else if (strcmp(*argv, "-f") == 0)
+ outmode[3] = 'f';
+ else if (strcmp(*argv, "-h") == 0)
+ outmode[3] = 'h';
+ else if (strcmp(*argv, "-r") == 0)
+ outmode[3] = 'R';
+ else if ((*argv)[0] == '-' && (*argv)[1] >= '1' && (*argv)[1] <= '9' &&
+ (*argv)[2] == 0)
+ outmode[2] = (*argv)[1];
+ else
+ break;
+ argc--, argv++;
+ }
+ if (outmode[3] == ' ')
+ outmode[3] = 0;
+ if (argc == 0) {
+ SET_BINARY_MODE(stdin);
+ SET_BINARY_MODE(stdout);
+ if (uncompr) {
+ file = gzdopen(fileno(stdin), "rb");
+ if (file == NULL) error("can't gzdopen stdin");
+ gz_uncompress(file, stdout);
+ } else {
+ file = gzdopen(fileno(stdout), outmode);
+ if (file == NULL) error("can't gzdopen stdout");
+#ifdef VERIMAG
+ clock_prepare();
+ clock_start();
+#endif
+ gz_compress(stdin, file);
+#ifdef VERIMAG
+ clock_stop();
+ printerr_total_clock();
+#endif
+ }
+ } else {
+ if (copyout) {
+ SET_BINARY_MODE(stdout);
+ }
+ do {
+ if (uncompr) {
+ if (copyout) {
+ file = gzopen(*argv, "rb");
+ if (file == NULL)
+ fprintf(stderr, "%s: can't gzopen %s\n", prog, *argv);
+ else
+ gz_uncompress(file, stdout);
+ } else {
+ file_uncompress(*argv);
+ }
+ } else {
+ if (copyout) {
+ FILE * in = fopen(*argv, "rb");
+
+ if (in == NULL) {
+ perror(*argv);
+ } else {
+ file = gzdopen(fileno(stdout), outmode);
+ if (file == NULL) error("can't gzdopen stdout");
+ gz_compress(in, file);
+ }
+
+ } else {
+ file_compress(*argv, outmode);
+ }
+ }
+ } while (argv++, --argc);
+ }
+ return 0;
+}
diff --git a/test/monniaux/zlib-1.2.11/trees.c b/test/monniaux/zlib-1.2.11/trees.c
new file mode 100644
index 00000000..50cf4b45
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/trees.c
@@ -0,0 +1,1203 @@
+/* trees.c -- output deflated data using Huffman coding
+ * Copyright (C) 1995-2017 Jean-loup Gailly
+ * detect_data_type() function provided freely by Cosmin Truta, 2006
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/*
+ * ALGORITHM
+ *
+ * The "deflation" process uses several Huffman trees. The more
+ * common source values are represented by shorter bit sequences.
+ *
+ * Each code tree is stored in a compressed form which is itself
+ * a Huffman encoding of the lengths of all the code strings (in
+ * ascending order by source values). The actual code strings are
+ * reconstructed from the lengths in the inflate process, as described
+ * in the deflate specification.
+ *
+ * REFERENCES
+ *
+ * Deutsch, L.P.,"'Deflate' Compressed Data Format Specification".
+ * Available in ftp.uu.net:/pub/archiving/zip/doc/deflate-1.1.doc
+ *
+ * Storer, James A.
+ * Data Compression: Methods and Theory, pp. 49-50.
+ * Computer Science Press, 1988. ISBN 0-7167-8156-5.
+ *
+ * Sedgewick, R.
+ * Algorithms, p290.
+ * Addison-Wesley, 1983. ISBN 0-201-06672-6.
+ */
+
+/* @(#) $Id$ */
+
+/* #define GEN_TREES_H */
+
+#include "deflate.h"
+
+#ifdef ZLIB_DEBUG
+# include <ctype.h>
+#endif
+
+/* ===========================================================================
+ * Constants
+ */
+
+#define MAX_BL_BITS 7
+/* Bit length codes must not exceed MAX_BL_BITS bits */
+
+#define END_BLOCK 256
+/* end of block literal code */
+
+#define REP_3_6 16
+/* repeat previous bit length 3-6 times (2 bits of repeat count) */
+
+#define REPZ_3_10 17
+/* repeat a zero length 3-10 times (3 bits of repeat count) */
+
+#define REPZ_11_138 18
+/* repeat a zero length 11-138 times (7 bits of repeat count) */
+
+local const int extra_lbits[LENGTH_CODES] /* extra bits for each length code */
+ = {0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,4,5,5,5,5,0};
+
+local const int extra_dbits[D_CODES] /* extra bits for each distance code */
+ = {0,0,0,0,1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10,11,11,12,12,13,13};
+
+local const int extra_blbits[BL_CODES]/* extra bits for each bit length code */
+ = {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,3,7};
+
+local const uch bl_order[BL_CODES]
+ = {16,17,18,0,8,7,9,6,10,5,11,4,12,3,13,2,14,1,15};
+/* The lengths of the bit length codes are sent in order of decreasing
+ * probability, to avoid transmitting the lengths for unused bit length codes.
+ */
+
+/* ===========================================================================
+ * Local data. These are initialized only once.
+ */
+
+#define DIST_CODE_LEN 512 /* see definition of array dist_code below */
+
+#if defined(GEN_TREES_H) || !defined(STDC)
+/* non ANSI compilers may not accept trees.h */
+
+local ct_data static_ltree[L_CODES+2];
+/* The static literal tree. Since the bit lengths are imposed, there is no
+ * need for the L_CODES extra codes used during heap construction. However
+ * The codes 286 and 287 are needed to build a canonical tree (see _tr_init
+ * below).
+ */
+
+local ct_data static_dtree[D_CODES];
+/* The static distance tree. (Actually a trivial tree since all codes use
+ * 5 bits.)
+ */
+
+uch _dist_code[DIST_CODE_LEN];
+/* Distance codes. The first 256 values correspond to the distances
+ * 3 .. 258, the last 256 values correspond to the top 8 bits of
+ * the 15 bit distances.
+ */
+
+uch _length_code[MAX_MATCH-MIN_MATCH+1];
+/* length code for each normalized match length (0 == MIN_MATCH) */
+
+local int base_length[LENGTH_CODES];
+/* First normalized length for each code (0 = MIN_MATCH) */
+
+local int base_dist[D_CODES];
+/* First normalized distance for each code (0 = distance of 1) */
+
+#else
+# include "trees.h"
+#endif /* GEN_TREES_H */
+
+struct static_tree_desc_s {
+ const ct_data *static_tree; /* static tree or NULL */
+ const intf *extra_bits; /* extra bits for each code or NULL */
+ int extra_base; /* base index for extra_bits */
+ int elems; /* max number of elements in the tree */
+ int max_length; /* max bit length for the codes */
+};
+
+local const static_tree_desc static_l_desc =
+{static_ltree, extra_lbits, LITERALS+1, L_CODES, MAX_BITS};
+
+local const static_tree_desc static_d_desc =
+{static_dtree, extra_dbits, 0, D_CODES, MAX_BITS};
+
+local const static_tree_desc static_bl_desc =
+{(const ct_data *)0, extra_blbits, 0, BL_CODES, MAX_BL_BITS};
+
+/* ===========================================================================
+ * Local (static) routines in this file.
+ */
+
+local void tr_static_init OF((void));
+local void init_block OF((deflate_state *s));
+local void pqdownheap OF((deflate_state *s, ct_data *tree, int k));
+local void gen_bitlen OF((deflate_state *s, tree_desc *desc));
+local void gen_codes OF((ct_data *tree, int max_code, ushf *bl_count));
+local void build_tree OF((deflate_state *s, tree_desc *desc));
+local void scan_tree OF((deflate_state *s, ct_data *tree, int max_code));
+local void send_tree OF((deflate_state *s, ct_data *tree, int max_code));
+local int build_bl_tree OF((deflate_state *s));
+local void send_all_trees OF((deflate_state *s, int lcodes, int dcodes,
+ int blcodes));
+local void compress_block OF((deflate_state *s, const ct_data *ltree,
+ const ct_data *dtree));
+local int detect_data_type OF((deflate_state *s));
+local unsigned bi_reverse OF((unsigned value, int length));
+local void bi_windup OF((deflate_state *s));
+local void bi_flush OF((deflate_state *s));
+
+#ifdef GEN_TREES_H
+local void gen_trees_header OF((void));
+#endif
+
+#ifndef ZLIB_DEBUG
+# define send_code(s, c, tree) send_bits(s, tree[c].Code, tree[c].Len)
+ /* Send a code of the given tree. c and tree must not have side effects */
+
+#else /* !ZLIB_DEBUG */
+# define send_code(s, c, tree) \
+ { if (z_verbose>2) fprintf(stderr,"\ncd %3d ",(c)); \
+ send_bits(s, tree[c].Code, tree[c].Len); }
+#endif
+
+/* ===========================================================================
+ * Output a short LSB first on the stream.
+ * IN assertion: there is enough room in pendingBuf.
+ */
+#define put_short(s, w) { \
+ put_byte(s, (uch)((w) & 0xff)); \
+ put_byte(s, (uch)((ush)(w) >> 8)); \
+}
+
+/* ===========================================================================
+ * Send a value on a given number of bits.
+ * IN assertion: length <= 16 and value fits in length bits.
+ */
+#ifdef ZLIB_DEBUG
+local void send_bits OF((deflate_state *s, int value, int length));
+
+local void send_bits(s, value, length)
+ deflate_state *s;
+ int value; /* value to send */
+ int length; /* number of bits */
+{
+ Tracevv((stderr," l %2d v %4x ", length, value));
+ Assert(length > 0 && length <= 15, "invalid length");
+ s->bits_sent += (ulg)length;
+
+ /* If not enough room in bi_buf, use (valid) bits from bi_buf and
+ * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid))
+ * unused bits in value.
+ */
+ if (s->bi_valid > (int)Buf_size - length) {
+ s->bi_buf |= (ush)value << s->bi_valid;
+ put_short(s, s->bi_buf);
+ s->bi_buf = (ush)value >> (Buf_size - s->bi_valid);
+ s->bi_valid += length - Buf_size;
+ } else {
+ s->bi_buf |= (ush)value << s->bi_valid;
+ s->bi_valid += length;
+ }
+}
+#else /* !ZLIB_DEBUG */
+
+#define send_bits(s, value, length) \
+{ int len = length;\
+ if (s->bi_valid > (int)Buf_size - len) {\
+ int val = (int)value;\
+ s->bi_buf |= (ush)val << s->bi_valid;\
+ put_short(s, s->bi_buf);\
+ s->bi_buf = (ush)val >> (Buf_size - s->bi_valid);\
+ s->bi_valid += len - Buf_size;\
+ } else {\
+ s->bi_buf |= (ush)(value) << s->bi_valid;\
+ s->bi_valid += len;\
+ }\
+}
+#endif /* ZLIB_DEBUG */
+
+
+/* the arguments must not have side effects */
+
+/* ===========================================================================
+ * Initialize the various 'constant' tables.
+ */
+local void tr_static_init()
+{
+#if defined(GEN_TREES_H) || !defined(STDC)
+ static int static_init_done = 0;
+ int n; /* iterates over tree elements */
+ int bits; /* bit counter */
+ int length; /* length value */
+ int code; /* code value */
+ int dist; /* distance index */
+ ush bl_count[MAX_BITS+1];
+ /* number of codes at each bit length for an optimal tree */
+
+ if (static_init_done) return;
+
+ /* For some embedded targets, global variables are not initialized: */
+#ifdef NO_INIT_GLOBAL_POINTERS
+ static_l_desc.static_tree = static_ltree;
+ static_l_desc.extra_bits = extra_lbits;
+ static_d_desc.static_tree = static_dtree;
+ static_d_desc.extra_bits = extra_dbits;
+ static_bl_desc.extra_bits = extra_blbits;
+#endif
+
+ /* Initialize the mapping length (0..255) -> length code (0..28) */
+ length = 0;
+ for (code = 0; code < LENGTH_CODES-1; code++) {
+ base_length[code] = length;
+ for (n = 0; n < (1<<extra_lbits[code]); n++) {
+ _length_code[length++] = (uch)code;
+ }
+ }
+ Assert (length == 256, "tr_static_init: length != 256");
+ /* Note that the length 255 (match length 258) can be represented
+ * in two different ways: code 284 + 5 bits or code 285, so we
+ * overwrite length_code[255] to use the best encoding:
+ */
+ _length_code[length-1] = (uch)code;
+
+ /* Initialize the mapping dist (0..32K) -> dist code (0..29) */
+ dist = 0;
+ for (code = 0 ; code < 16; code++) {
+ base_dist[code] = dist;
+ for (n = 0; n < (1<<extra_dbits[code]); n++) {
+ _dist_code[dist++] = (uch)code;
+ }
+ }
+ Assert (dist == 256, "tr_static_init: dist != 256");
+ dist >>= 7; /* from now on, all distances are divided by 128 */
+ for ( ; code < D_CODES; code++) {
+ base_dist[code] = dist << 7;
+ for (n = 0; n < (1<<(extra_dbits[code]-7)); n++) {
+ _dist_code[256 + dist++] = (uch)code;
+ }
+ }
+ Assert (dist == 256, "tr_static_init: 256+dist != 512");
+
+ /* Construct the codes of the static literal tree */
+ for (bits = 0; bits <= MAX_BITS; bits++) bl_count[bits] = 0;
+ n = 0;
+ while (n <= 143) static_ltree[n++].Len = 8, bl_count[8]++;
+ while (n <= 255) static_ltree[n++].Len = 9, bl_count[9]++;
+ while (n <= 279) static_ltree[n++].Len = 7, bl_count[7]++;
+ while (n <= 287) static_ltree[n++].Len = 8, bl_count[8]++;
+ /* Codes 286 and 287 do not exist, but we must include them in the
+ * tree construction to get a canonical Huffman tree (longest code
+ * all ones)
+ */
+ gen_codes((ct_data *)static_ltree, L_CODES+1, bl_count);
+
+ /* The static distance tree is trivial: */
+ for (n = 0; n < D_CODES; n++) {
+ static_dtree[n].Len = 5;
+ static_dtree[n].Code = bi_reverse((unsigned)n, 5);
+ }
+ static_init_done = 1;
+
+# ifdef GEN_TREES_H
+ gen_trees_header();
+# endif
+#endif /* defined(GEN_TREES_H) || !defined(STDC) */
+}
+
+/* ===========================================================================
+ * Genererate the file trees.h describing the static trees.
+ */
+#ifdef GEN_TREES_H
+# ifndef ZLIB_DEBUG
+# include <stdio.h>
+# endif
+
+# define SEPARATOR(i, last, width) \
+ ((i) == (last)? "\n};\n\n" : \
+ ((i) % (width) == (width)-1 ? ",\n" : ", "))
+
+void gen_trees_header()
+{
+ FILE *header = fopen("trees.h", "w");
+ int i;
+
+ Assert (header != NULL, "Can't open trees.h");
+ fprintf(header,
+ "/* header created automatically with -DGEN_TREES_H */\n\n");
+
+ fprintf(header, "local const ct_data static_ltree[L_CODES+2] = {\n");
+ for (i = 0; i < L_CODES+2; i++) {
+ fprintf(header, "{{%3u},{%3u}}%s", static_ltree[i].Code,
+ static_ltree[i].Len, SEPARATOR(i, L_CODES+1, 5));
+ }
+
+ fprintf(header, "local const ct_data static_dtree[D_CODES] = {\n");
+ for (i = 0; i < D_CODES; i++) {
+ fprintf(header, "{{%2u},{%2u}}%s", static_dtree[i].Code,
+ static_dtree[i].Len, SEPARATOR(i, D_CODES-1, 5));
+ }
+
+ fprintf(header, "const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {\n");
+ for (i = 0; i < DIST_CODE_LEN; i++) {
+ fprintf(header, "%2u%s", _dist_code[i],
+ SEPARATOR(i, DIST_CODE_LEN-1, 20));
+ }
+
+ fprintf(header,
+ "const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {\n");
+ for (i = 0; i < MAX_MATCH-MIN_MATCH+1; i++) {
+ fprintf(header, "%2u%s", _length_code[i],
+ SEPARATOR(i, MAX_MATCH-MIN_MATCH, 20));
+ }
+
+ fprintf(header, "local const int base_length[LENGTH_CODES] = {\n");
+ for (i = 0; i < LENGTH_CODES; i++) {
+ fprintf(header, "%1u%s", base_length[i],
+ SEPARATOR(i, LENGTH_CODES-1, 20));
+ }
+
+ fprintf(header, "local const int base_dist[D_CODES] = {\n");
+ for (i = 0; i < D_CODES; i++) {
+ fprintf(header, "%5u%s", base_dist[i],
+ SEPARATOR(i, D_CODES-1, 10));
+ }
+
+ fclose(header);
+}
+#endif /* GEN_TREES_H */
+
+/* ===========================================================================
+ * Initialize the tree data structures for a new zlib stream.
+ */
+void ZLIB_INTERNAL _tr_init(s)
+ deflate_state *s;
+{
+ tr_static_init();
+
+ s->l_desc.dyn_tree = s->dyn_ltree;
+ s->l_desc.stat_desc = &static_l_desc;
+
+ s->d_desc.dyn_tree = s->dyn_dtree;
+ s->d_desc.stat_desc = &static_d_desc;
+
+ s->bl_desc.dyn_tree = s->bl_tree;
+ s->bl_desc.stat_desc = &static_bl_desc;
+
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+#ifdef ZLIB_DEBUG
+ s->compressed_len = 0L;
+ s->bits_sent = 0L;
+#endif
+
+ /* Initialize the first block of the first file: */
+ init_block(s);
+}
+
+/* ===========================================================================
+ * Initialize a new block.
+ */
+local void init_block(s)
+ deflate_state *s;
+{
+ int n; /* iterates over tree elements */
+
+ /* Initialize the trees. */
+ for (n = 0; n < L_CODES; n++) s->dyn_ltree[n].Freq = 0;
+ for (n = 0; n < D_CODES; n++) s->dyn_dtree[n].Freq = 0;
+ for (n = 0; n < BL_CODES; n++) s->bl_tree[n].Freq = 0;
+
+ s->dyn_ltree[END_BLOCK].Freq = 1;
+ s->opt_len = s->static_len = 0L;
+ s->last_lit = s->matches = 0;
+}
+
+#define SMALLEST 1
+/* Index within the heap array of least frequent node in the Huffman tree */
+
+
+/* ===========================================================================
+ * Remove the smallest element from the heap and recreate the heap with
+ * one less element. Updates heap and heap_len.
+ */
+#define pqremove(s, tree, top) \
+{\
+ top = s->heap[SMALLEST]; \
+ s->heap[SMALLEST] = s->heap[s->heap_len--]; \
+ pqdownheap(s, tree, SMALLEST); \
+}
+
+/* ===========================================================================
+ * Compares to subtrees, using the tree depth as tie breaker when
+ * the subtrees have equal frequency. This minimizes the worst case length.
+ */
+#define smaller(tree, n, m, depth) \
+ (tree[n].Freq < tree[m].Freq || \
+ (tree[n].Freq == tree[m].Freq && depth[n] <= depth[m]))
+
+/* ===========================================================================
+ * Restore the heap property by moving down the tree starting at node k,
+ * exchanging a node with the smallest of its two sons if necessary, stopping
+ * when the heap property is re-established (each father smaller than its
+ * two sons).
+ */
+local void pqdownheap(s, tree, k)
+ deflate_state *s;
+ ct_data *tree; /* the tree to restore */
+ int k; /* node to move down */
+{
+ int v = s->heap[k];
+ int j = k << 1; /* left son of k */
+ while (j <= s->heap_len) {
+ /* Set j to the smallest of the two sons: */
+ if (j < s->heap_len &&
+ smaller(tree, s->heap[j+1], s->heap[j], s->depth)) {
+ j++;
+ }
+ /* Exit if v is smaller than both sons */
+ if (smaller(tree, v, s->heap[j], s->depth)) break;
+
+ /* Exchange v with the smallest son */
+ s->heap[k] = s->heap[j]; k = j;
+
+ /* And continue down the tree, setting j to the left son of k */
+ j <<= 1;
+ }
+ s->heap[k] = v;
+}
+
+/* ===========================================================================
+ * Compute the optimal bit lengths for a tree and update the total bit length
+ * for the current block.
+ * IN assertion: the fields freq and dad are set, heap[heap_max] and
+ * above are the tree nodes sorted by increasing frequency.
+ * OUT assertions: the field len is set to the optimal bit length, the
+ * array bl_count contains the frequencies for each bit length.
+ * The length opt_len is updated; static_len is also updated if stree is
+ * not null.
+ */
+local void gen_bitlen(s, desc)
+ deflate_state *s;
+ tree_desc *desc; /* the tree descriptor */
+{
+ ct_data *tree = desc->dyn_tree;
+ int max_code = desc->max_code;
+ const ct_data *stree = desc->stat_desc->static_tree;
+ const intf *extra = desc->stat_desc->extra_bits;
+ int base = desc->stat_desc->extra_base;
+ int max_length = desc->stat_desc->max_length;
+ int h; /* heap index */
+ int n, m; /* iterate over the tree elements */
+ int bits; /* bit length */
+ int xbits; /* extra bits */
+ ush f; /* frequency */
+ int overflow = 0; /* number of elements with bit length too large */
+
+ for (bits = 0; bits <= MAX_BITS; bits++) s->bl_count[bits] = 0;
+
+ /* In a first pass, compute the optimal bit lengths (which may
+ * overflow in the case of the bit length tree).
+ */
+ tree[s->heap[s->heap_max]].Len = 0; /* root of the heap */
+
+ for (h = s->heap_max+1; h < HEAP_SIZE; h++) {
+ n = s->heap[h];
+ bits = tree[tree[n].Dad].Len + 1;
+ if (bits > max_length) bits = max_length, overflow++;
+ tree[n].Len = (ush)bits;
+ /* We overwrite tree[n].Dad which is no longer needed */
+
+ if (n > max_code) continue; /* not a leaf node */
+
+ s->bl_count[bits]++;
+ xbits = 0;
+ if (n >= base) xbits = extra[n-base];
+ f = tree[n].Freq;
+ s->opt_len += (ulg)f * (unsigned)(bits + xbits);
+ if (stree) s->static_len += (ulg)f * (unsigned)(stree[n].Len + xbits);
+ }
+ if (overflow == 0) return;
+
+ Tracev((stderr,"\nbit length overflow\n"));
+ /* This happens for example on obj2 and pic of the Calgary corpus */
+
+ /* Find the first bit length which could increase: */
+ do {
+ bits = max_length-1;
+ while (s->bl_count[bits] == 0) bits--;
+ s->bl_count[bits]--; /* move one leaf down the tree */
+ s->bl_count[bits+1] += 2; /* move one overflow item as its brother */
+ s->bl_count[max_length]--;
+ /* The brother of the overflow item also moves one step up,
+ * but this does not affect bl_count[max_length]
+ */
+ overflow -= 2;
+ } while (overflow > 0);
+
+ /* Now recompute all bit lengths, scanning in increasing frequency.
+ * h is still equal to HEAP_SIZE. (It is simpler to reconstruct all
+ * lengths instead of fixing only the wrong ones. This idea is taken
+ * from 'ar' written by Haruhiko Okumura.)
+ */
+ for (bits = max_length; bits != 0; bits--) {
+ n = s->bl_count[bits];
+ while (n != 0) {
+ m = s->heap[--h];
+ if (m > max_code) continue;
+ if ((unsigned) tree[m].Len != (unsigned) bits) {
+ Tracev((stderr,"code %d bits %d->%d\n", m, tree[m].Len, bits));
+ s->opt_len += ((ulg)bits - tree[m].Len) * tree[m].Freq;
+ tree[m].Len = (ush)bits;
+ }
+ n--;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Generate the codes for a given tree and bit counts (which need not be
+ * optimal).
+ * IN assertion: the array bl_count contains the bit length statistics for
+ * the given tree and the field len is set for all tree elements.
+ * OUT assertion: the field code is set for all tree elements of non
+ * zero code length.
+ */
+local void gen_codes (tree, max_code, bl_count)
+ ct_data *tree; /* the tree to decorate */
+ int max_code; /* largest code with non zero frequency */
+ ushf *bl_count; /* number of codes at each bit length */
+{
+ ush next_code[MAX_BITS+1]; /* next code value for each bit length */
+ unsigned code = 0; /* running code value */
+ int bits; /* bit index */
+ int n; /* code index */
+
+ /* The distribution counts are first used to generate the code values
+ * without bit reversal.
+ */
+ for (bits = 1; bits <= MAX_BITS; bits++) {
+ code = (code + bl_count[bits-1]) << 1;
+ next_code[bits] = (ush)code;
+ }
+ /* Check that the bit counts in bl_count are consistent. The last code
+ * must be all ones.
+ */
+ Assert (code + bl_count[MAX_BITS]-1 == (1<<MAX_BITS)-1,
+ "inconsistent bit counts");
+ Tracev((stderr,"\ngen_codes: max_code %d ", max_code));
+
+ for (n = 0; n <= max_code; n++) {
+ int len = tree[n].Len;
+ if (len == 0) continue;
+ /* Now reverse the bits */
+ tree[n].Code = (ush)bi_reverse(next_code[len]++, len);
+
+ Tracecv(tree != static_ltree, (stderr,"\nn %3d %c l %2d c %4x (%x) ",
+ n, (isgraph(n) ? n : ' '), len, tree[n].Code, next_code[len]-1));
+ }
+}
+
+/* ===========================================================================
+ * Construct one Huffman tree and assigns the code bit strings and lengths.
+ * Update the total bit length for the current block.
+ * IN assertion: the field freq is set for all tree elements.
+ * OUT assertions: the fields len and code are set to the optimal bit length
+ * and corresponding code. The length opt_len is updated; static_len is
+ * also updated if stree is not null. The field max_code is set.
+ */
+local void build_tree(s, desc)
+ deflate_state *s;
+ tree_desc *desc; /* the tree descriptor */
+{
+ ct_data *tree = desc->dyn_tree;
+ const ct_data *stree = desc->stat_desc->static_tree;
+ int elems = desc->stat_desc->elems;
+ int n, m; /* iterate over heap elements */
+ int max_code = -1; /* largest code with non zero frequency */
+ int node; /* new node being created */
+
+ /* Construct the initial heap, with least frequent element in
+ * heap[SMALLEST]. The sons of heap[n] are heap[2*n] and heap[2*n+1].
+ * heap[0] is not used.
+ */
+ s->heap_len = 0, s->heap_max = HEAP_SIZE;
+
+ for (n = 0; n < elems; n++) {
+ if (tree[n].Freq != 0) {
+ s->heap[++(s->heap_len)] = max_code = n;
+ s->depth[n] = 0;
+ } else {
+ tree[n].Len = 0;
+ }
+ }
+
+ /* The pkzip format requires that at least one distance code exists,
+ * and that at least one bit should be sent even if there is only one
+ * possible code. So to avoid special checks later on we force at least
+ * two codes of non zero frequency.
+ */
+ while (s->heap_len < 2) {
+ node = s->heap[++(s->heap_len)] = (max_code < 2 ? ++max_code : 0);
+ tree[node].Freq = 1;
+ s->depth[node] = 0;
+ s->opt_len--; if (stree) s->static_len -= stree[node].Len;
+ /* node is 0 or 1 so it does not have extra bits */
+ }
+ desc->max_code = max_code;
+
+ /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree,
+ * establish sub-heaps of increasing lengths:
+ */
+ for (n = s->heap_len/2; n >= 1; n--) pqdownheap(s, tree, n);
+
+ /* Construct the Huffman tree by repeatedly combining the least two
+ * frequent nodes.
+ */
+ node = elems; /* next internal node of the tree */
+ do {
+ pqremove(s, tree, n); /* n = node of least frequency */
+ m = s->heap[SMALLEST]; /* m = node of next least frequency */
+
+ s->heap[--(s->heap_max)] = n; /* keep the nodes sorted by frequency */
+ s->heap[--(s->heap_max)] = m;
+
+ /* Create a new node father of n and m */
+ tree[node].Freq = tree[n].Freq + tree[m].Freq;
+ s->depth[node] = (uch)((s->depth[n] >= s->depth[m] ?
+ s->depth[n] : s->depth[m]) + 1);
+ tree[n].Dad = tree[m].Dad = (ush)node;
+#ifdef DUMP_BL_TREE
+ if (tree == s->bl_tree) {
+ fprintf(stderr,"\nnode %d(%d), sons %d(%d) %d(%d)",
+ node, tree[node].Freq, n, tree[n].Freq, m, tree[m].Freq);
+ }
+#endif
+ /* and insert the new node in the heap */
+ s->heap[SMALLEST] = node++;
+ pqdownheap(s, tree, SMALLEST);
+
+ } while (s->heap_len >= 2);
+
+ s->heap[--(s->heap_max)] = s->heap[SMALLEST];
+
+ /* At this point, the fields freq and dad are set. We can now
+ * generate the bit lengths.
+ */
+ gen_bitlen(s, (tree_desc *)desc);
+
+ /* The field len is now set, we can generate the bit codes */
+ gen_codes ((ct_data *)tree, max_code, s->bl_count);
+}
+
+/* ===========================================================================
+ * Scan a literal or distance tree to determine the frequencies of the codes
+ * in the bit length tree.
+ */
+local void scan_tree (s, tree, max_code)
+ deflate_state *s;
+ ct_data *tree; /* the tree to be scanned */
+ int max_code; /* and its largest code of non zero frequency */
+{
+ int n; /* iterates over all tree elements */
+ int prevlen = -1; /* last emitted length */
+ int curlen; /* length of current code */
+ int nextlen = tree[0].Len; /* length of next code */
+ int count = 0; /* repeat count of the current code */
+ int max_count = 7; /* max repeat count */
+ int min_count = 4; /* min repeat count */
+
+ if (nextlen == 0) max_count = 138, min_count = 3;
+ tree[max_code+1].Len = (ush)0xffff; /* guard */
+
+ for (n = 0; n <= max_code; n++) {
+ curlen = nextlen; nextlen = tree[n+1].Len;
+ if (++count < max_count && curlen == nextlen) {
+ continue;
+ } else if (count < min_count) {
+ s->bl_tree[curlen].Freq += count;
+ } else if (curlen != 0) {
+ if (curlen != prevlen) s->bl_tree[curlen].Freq++;
+ s->bl_tree[REP_3_6].Freq++;
+ } else if (count <= 10) {
+ s->bl_tree[REPZ_3_10].Freq++;
+ } else {
+ s->bl_tree[REPZ_11_138].Freq++;
+ }
+ count = 0; prevlen = curlen;
+ if (nextlen == 0) {
+ max_count = 138, min_count = 3;
+ } else if (curlen == nextlen) {
+ max_count = 6, min_count = 3;
+ } else {
+ max_count = 7, min_count = 4;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Send a literal or distance tree in compressed form, using the codes in
+ * bl_tree.
+ */
+local void send_tree (s, tree, max_code)
+ deflate_state *s;
+ ct_data *tree; /* the tree to be scanned */
+ int max_code; /* and its largest code of non zero frequency */
+{
+ int n; /* iterates over all tree elements */
+ int prevlen = -1; /* last emitted length */
+ int curlen; /* length of current code */
+ int nextlen = tree[0].Len; /* length of next code */
+ int count = 0; /* repeat count of the current code */
+ int max_count = 7; /* max repeat count */
+ int min_count = 4; /* min repeat count */
+
+ /* tree[max_code+1].Len = -1; */ /* guard already set */
+ if (nextlen == 0) max_count = 138, min_count = 3;
+
+ for (n = 0; n <= max_code; n++) {
+ curlen = nextlen; nextlen = tree[n+1].Len;
+ if (++count < max_count && curlen == nextlen) {
+ continue;
+ } else if (count < min_count) {
+ do { send_code(s, curlen, s->bl_tree); } while (--count != 0);
+
+ } else if (curlen != 0) {
+ if (curlen != prevlen) {
+ send_code(s, curlen, s->bl_tree); count--;
+ }
+ Assert(count >= 3 && count <= 6, " 3_6?");
+ send_code(s, REP_3_6, s->bl_tree); send_bits(s, count-3, 2);
+
+ } else if (count <= 10) {
+ send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count-3, 3);
+
+ } else {
+ send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count-11, 7);
+ }
+ count = 0; prevlen = curlen;
+ if (nextlen == 0) {
+ max_count = 138, min_count = 3;
+ } else if (curlen == nextlen) {
+ max_count = 6, min_count = 3;
+ } else {
+ max_count = 7, min_count = 4;
+ }
+ }
+}
+
+/* ===========================================================================
+ * Construct the Huffman tree for the bit lengths and return the index in
+ * bl_order of the last bit length code to send.
+ */
+local int build_bl_tree(s)
+ deflate_state *s;
+{
+ int max_blindex; /* index of last bit length code of non zero freq */
+
+ /* Determine the bit length frequencies for literal and distance trees */
+ scan_tree(s, (ct_data *)s->dyn_ltree, s->l_desc.max_code);
+ scan_tree(s, (ct_data *)s->dyn_dtree, s->d_desc.max_code);
+
+ /* Build the bit length tree: */
+ build_tree(s, (tree_desc *)(&(s->bl_desc)));
+ /* opt_len now includes the length of the tree representations, except
+ * the lengths of the bit lengths codes and the 5+5+4 bits for the counts.
+ */
+
+ /* Determine the number of bit length codes to send. The pkzip format
+ * requires that at least 4 bit length codes be sent. (appnote.txt says
+ * 3 but the actual value used is 4.)
+ */
+ for (max_blindex = BL_CODES-1; max_blindex >= 3; max_blindex--) {
+ if (s->bl_tree[bl_order[max_blindex]].Len != 0) break;
+ }
+ /* Update opt_len to include the bit length tree and counts */
+ s->opt_len += 3*((ulg)max_blindex+1) + 5+5+4;
+ Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld",
+ s->opt_len, s->static_len));
+
+ return max_blindex;
+}
+
+/* ===========================================================================
+ * Send the header for a block using dynamic Huffman trees: the counts, the
+ * lengths of the bit length codes, the literal tree and the distance tree.
+ * IN assertion: lcodes >= 257, dcodes >= 1, blcodes >= 4.
+ */
+local void send_all_trees(s, lcodes, dcodes, blcodes)
+ deflate_state *s;
+ int lcodes, dcodes, blcodes; /* number of codes for each tree */
+{
+ int rank; /* index in bl_order */
+
+ Assert (lcodes >= 257 && dcodes >= 1 && blcodes >= 4, "not enough codes");
+ Assert (lcodes <= L_CODES && dcodes <= D_CODES && blcodes <= BL_CODES,
+ "too many codes");
+ Tracev((stderr, "\nbl counts: "));
+ send_bits(s, lcodes-257, 5); /* not +255 as stated in appnote.txt */
+ send_bits(s, dcodes-1, 5);
+ send_bits(s, blcodes-4, 4); /* not -3 as stated in appnote.txt */
+ for (rank = 0; rank < blcodes; rank++) {
+ Tracev((stderr, "\nbl code %2d ", bl_order[rank]));
+ send_bits(s, s->bl_tree[bl_order[rank]].Len, 3);
+ }
+ Tracev((stderr, "\nbl tree: sent %ld", s->bits_sent));
+
+ send_tree(s, (ct_data *)s->dyn_ltree, lcodes-1); /* literal tree */
+ Tracev((stderr, "\nlit tree: sent %ld", s->bits_sent));
+
+ send_tree(s, (ct_data *)s->dyn_dtree, dcodes-1); /* distance tree */
+ Tracev((stderr, "\ndist tree: sent %ld", s->bits_sent));
+}
+
+/* ===========================================================================
+ * Send a stored block
+ */
+void ZLIB_INTERNAL _tr_stored_block(s, buf, stored_len, last)
+ deflate_state *s;
+ charf *buf; /* input block */
+ ulg stored_len; /* length of input block */
+ int last; /* one if this is the last block for a file */
+{
+ send_bits(s, (STORED_BLOCK<<1)+last, 3); /* send block type */
+ bi_windup(s); /* align on byte boundary */
+ put_short(s, (ush)stored_len);
+ put_short(s, (ush)~stored_len);
+ zmemcpy(s->pending_buf + s->pending, (Bytef *)buf, stored_len);
+ s->pending += stored_len;
+#ifdef ZLIB_DEBUG
+ s->compressed_len = (s->compressed_len + 3 + 7) & (ulg)~7L;
+ s->compressed_len += (stored_len + 4) << 3;
+ s->bits_sent += 2*16;
+ s->bits_sent += stored_len<<3;
+#endif
+}
+
+/* ===========================================================================
+ * Flush the bits in the bit buffer to pending output (leaves at most 7 bits)
+ */
+void ZLIB_INTERNAL _tr_flush_bits(s)
+ deflate_state *s;
+{
+ bi_flush(s);
+}
+
+/* ===========================================================================
+ * Send one empty static block to give enough lookahead for inflate.
+ * This takes 10 bits, of which 7 may remain in the bit buffer.
+ */
+void ZLIB_INTERNAL _tr_align(s)
+ deflate_state *s;
+{
+ send_bits(s, STATIC_TREES<<1, 3);
+ send_code(s, END_BLOCK, static_ltree);
+#ifdef ZLIB_DEBUG
+ s->compressed_len += 10L; /* 3 for block type, 7 for EOB */
+#endif
+ bi_flush(s);
+}
+
+/* ===========================================================================
+ * Determine the best encoding for the current block: dynamic trees, static
+ * trees or store, and write out the encoded block.
+ */
+void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last)
+ deflate_state *s;
+ charf *buf; /* input block, or NULL if too old */
+ ulg stored_len; /* length of input block */
+ int last; /* one if this is the last block for a file */
+{
+ ulg opt_lenb, static_lenb; /* opt_len and static_len in bytes */
+ int max_blindex = 0; /* index of last bit length code of non zero freq */
+
+ /* Build the Huffman trees unless a stored block is forced */
+ if (s->level > 0) {
+
+ /* Check if the file is binary or text */
+ if (s->strm->data_type == Z_UNKNOWN)
+ s->strm->data_type = detect_data_type(s);
+
+ /* Construct the literal and distance trees */
+ build_tree(s, (tree_desc *)(&(s->l_desc)));
+ Tracev((stderr, "\nlit data: dyn %ld, stat %ld", s->opt_len,
+ s->static_len));
+
+ build_tree(s, (tree_desc *)(&(s->d_desc)));
+ Tracev((stderr, "\ndist data: dyn %ld, stat %ld", s->opt_len,
+ s->static_len));
+ /* At this point, opt_len and static_len are the total bit lengths of
+ * the compressed block data, excluding the tree representations.
+ */
+
+ /* Build the bit length tree for the above two trees, and get the index
+ * in bl_order of the last bit length code to send.
+ */
+ max_blindex = build_bl_tree(s);
+
+ /* Determine the best encoding. Compute the block lengths in bytes. */
+ opt_lenb = (s->opt_len+3+7)>>3;
+ static_lenb = (s->static_len+3+7)>>3;
+
+ Tracev((stderr, "\nopt %lu(%lu) stat %lu(%lu) stored %lu lit %u ",
+ opt_lenb, s->opt_len, static_lenb, s->static_len, stored_len,
+ s->last_lit));
+
+ if (static_lenb <= opt_lenb) opt_lenb = static_lenb;
+
+ } else {
+ Assert(buf != (char*)0, "lost buf");
+ opt_lenb = static_lenb = stored_len + 5; /* force a stored block */
+ }
+
+#ifdef FORCE_STORED
+ if (buf != (char*)0) { /* force stored block */
+#else
+ if (stored_len+4 <= opt_lenb && buf != (char*)0) {
+ /* 4: two words for the lengths */
+#endif
+ /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE.
+ * Otherwise we can't have processed more than WSIZE input bytes since
+ * the last block flush, because compression would have been
+ * successful. If LIT_BUFSIZE <= WSIZE, it is never too late to
+ * transform a block into a stored block.
+ */
+ _tr_stored_block(s, buf, stored_len, last);
+
+#ifdef FORCE_STATIC
+ } else if (static_lenb >= 0) { /* force static trees */
+#else
+ } else if (s->strategy == Z_FIXED || static_lenb == opt_lenb) {
+#endif
+ send_bits(s, (STATIC_TREES<<1)+last, 3);
+ compress_block(s, (const ct_data *)static_ltree,
+ (const ct_data *)static_dtree);
+#ifdef ZLIB_DEBUG
+ s->compressed_len += 3 + s->static_len;
+#endif
+ } else {
+ send_bits(s, (DYN_TREES<<1)+last, 3);
+ send_all_trees(s, s->l_desc.max_code+1, s->d_desc.max_code+1,
+ max_blindex+1);
+ compress_block(s, (const ct_data *)s->dyn_ltree,
+ (const ct_data *)s->dyn_dtree);
+#ifdef ZLIB_DEBUG
+ s->compressed_len += 3 + s->opt_len;
+#endif
+ }
+ Assert (s->compressed_len == s->bits_sent, "bad compressed size");
+ /* The above check is made mod 2^32, for files larger than 512 MB
+ * and uLong implemented on 32 bits.
+ */
+ init_block(s);
+
+ if (last) {
+ bi_windup(s);
+#ifdef ZLIB_DEBUG
+ s->compressed_len += 7; /* align on byte boundary */
+#endif
+ }
+ Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len>>3,
+ s->compressed_len-7*last));
+}
+
+/* ===========================================================================
+ * Save the match info and tally the frequency counts. Return true if
+ * the current block must be flushed.
+ */
+int ZLIB_INTERNAL _tr_tally (s, dist, lc)
+ deflate_state *s;
+ unsigned dist; /* distance of matched string */
+ unsigned lc; /* match length-MIN_MATCH or unmatched char (if dist==0) */
+{
+ s->d_buf[s->last_lit] = (ush)dist;
+ s->l_buf[s->last_lit++] = (uch)lc;
+ if (dist == 0) {
+ /* lc is the unmatched char */
+ s->dyn_ltree[lc].Freq++;
+ } else {
+ s->matches++;
+ /* Here, lc is the match length - MIN_MATCH */
+ dist--; /* dist = match distance - 1 */
+ Assert((ush)dist < (ush)MAX_DIST(s) &&
+ (ush)lc <= (ush)(MAX_MATCH-MIN_MATCH) &&
+ (ush)d_code(dist) < (ush)D_CODES, "_tr_tally: bad match");
+
+ s->dyn_ltree[_length_code[lc]+LITERALS+1].Freq++;
+ s->dyn_dtree[d_code(dist)].Freq++;
+ }
+
+#ifdef TRUNCATE_BLOCK
+ /* Try to guess if it is profitable to stop the current block here */
+ if ((s->last_lit & 0x1fff) == 0 && s->level > 2) {
+ /* Compute an upper bound for the compressed length */
+ ulg out_length = (ulg)s->last_lit*8L;
+ ulg in_length = (ulg)((long)s->strstart - s->block_start);
+ int dcode;
+ for (dcode = 0; dcode < D_CODES; dcode++) {
+ out_length += (ulg)s->dyn_dtree[dcode].Freq *
+ (5L+extra_dbits[dcode]);
+ }
+ out_length >>= 3;
+ Tracev((stderr,"\nlast_lit %u, in %ld, out ~%ld(%ld%%) ",
+ s->last_lit, in_length, out_length,
+ 100L - out_length*100L/in_length));
+ if (s->matches < s->last_lit/2 && out_length < in_length/2) return 1;
+ }
+#endif
+ return (s->last_lit == s->lit_bufsize-1);
+ /* We avoid equality with lit_bufsize because of wraparound at 64K
+ * on 16 bit machines and because stored blocks are restricted to
+ * 64K-1 bytes.
+ */
+}
+
+/* ===========================================================================
+ * Send the block data compressed using the given Huffman trees
+ */
+local void compress_block(s, ltree, dtree)
+ deflate_state *s;
+ const ct_data *ltree; /* literal tree */
+ const ct_data *dtree; /* distance tree */
+{
+ unsigned dist; /* distance of matched string */
+ int lc; /* match length or unmatched char (if dist == 0) */
+ unsigned lx = 0; /* running index in l_buf */
+ unsigned code; /* the code to send */
+ int extra; /* number of extra bits to send */
+
+ if (s->last_lit != 0) do {
+ dist = s->d_buf[lx];
+ lc = s->l_buf[lx++];
+ if (dist == 0) {
+ send_code(s, lc, ltree); /* send a literal byte */
+ Tracecv(isgraph(lc), (stderr," '%c' ", lc));
+ } else {
+ /* Here, lc is the match length - MIN_MATCH */
+ code = _length_code[lc];
+ send_code(s, code+LITERALS+1, ltree); /* send the length code */
+ extra = extra_lbits[code];
+ if (extra != 0) {
+ lc -= base_length[code];
+ send_bits(s, lc, extra); /* send the extra length bits */
+ }
+ dist--; /* dist is now the match distance - 1 */
+ code = d_code(dist);
+ Assert (code < D_CODES, "bad d_code");
+
+ send_code(s, code, dtree); /* send the distance code */
+ extra = extra_dbits[code];
+ if (extra != 0) {
+ dist -= (unsigned)base_dist[code];
+ send_bits(s, dist, extra); /* send the extra distance bits */
+ }
+ } /* literal or match pair ? */
+
+ /* Check that the overlay between pending_buf and d_buf+l_buf is ok: */
+ Assert((uInt)(s->pending) < s->lit_bufsize + 2*lx,
+ "pendingBuf overflow");
+
+ } while (lx < s->last_lit);
+
+ send_code(s, END_BLOCK, ltree);
+}
+
+/* ===========================================================================
+ * Check if the data type is TEXT or BINARY, using the following algorithm:
+ * - TEXT if the two conditions below are satisfied:
+ * a) There are no non-portable control characters belonging to the
+ * "black list" (0..6, 14..25, 28..31).
+ * b) There is at least one printable character belonging to the
+ * "white list" (9 {TAB}, 10 {LF}, 13 {CR}, 32..255).
+ * - BINARY otherwise.
+ * - The following partially-portable control characters form a
+ * "gray list" that is ignored in this detection algorithm:
+ * (7 {BEL}, 8 {BS}, 11 {VT}, 12 {FF}, 26 {SUB}, 27 {ESC}).
+ * IN assertion: the fields Freq of dyn_ltree are set.
+ */
+local int detect_data_type(s)
+ deflate_state *s;
+{
+ /* black_mask is the bit mask of black-listed bytes
+ * set bits 0..6, 14..25, and 28..31
+ * 0xf3ffc07f = binary 11110011111111111100000001111111
+ */
+ unsigned long black_mask = 0xf3ffc07fUL;
+ int n;
+
+ /* Check for non-textual ("black-listed") bytes. */
+ for (n = 0; n <= 31; n++, black_mask >>= 1)
+ if ((black_mask & 1) && (s->dyn_ltree[n].Freq != 0))
+ return Z_BINARY;
+
+ /* Check for textual ("white-listed") bytes. */
+ if (s->dyn_ltree[9].Freq != 0 || s->dyn_ltree[10].Freq != 0
+ || s->dyn_ltree[13].Freq != 0)
+ return Z_TEXT;
+ for (n = 32; n < LITERALS; n++)
+ if (s->dyn_ltree[n].Freq != 0)
+ return Z_TEXT;
+
+ /* There are no "black-listed" or "white-listed" bytes:
+ * this stream either is empty or has tolerated ("gray-listed") bytes only.
+ */
+ return Z_BINARY;
+}
+
+/* ===========================================================================
+ * Reverse the first len bits of a code, using straightforward code (a faster
+ * method would use a table)
+ * IN assertion: 1 <= len <= 15
+ */
+local unsigned bi_reverse(code, len)
+ unsigned code; /* the value to invert */
+ int len; /* its bit length */
+{
+ register unsigned res = 0;
+ do {
+ res |= code & 1;
+ code >>= 1, res <<= 1;
+ } while (--len > 0);
+ return res >> 1;
+}
+
+/* ===========================================================================
+ * Flush the bit buffer, keeping at most 7 bits in it.
+ */
+local void bi_flush(s)
+ deflate_state *s;
+{
+ if (s->bi_valid == 16) {
+ put_short(s, s->bi_buf);
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+ } else if (s->bi_valid >= 8) {
+ put_byte(s, (Byte)s->bi_buf);
+ s->bi_buf >>= 8;
+ s->bi_valid -= 8;
+ }
+}
+
+/* ===========================================================================
+ * Flush the bit buffer and align the output on a byte boundary
+ */
+local void bi_windup(s)
+ deflate_state *s;
+{
+ if (s->bi_valid > 8) {
+ put_short(s, s->bi_buf);
+ } else if (s->bi_valid > 0) {
+ put_byte(s, (Byte)s->bi_buf);
+ }
+ s->bi_buf = 0;
+ s->bi_valid = 0;
+#ifdef ZLIB_DEBUG
+ s->bits_sent = (s->bits_sent+7) & ~7;
+#endif
+}
diff --git a/test/monniaux/zlib-1.2.11/trees.h b/test/monniaux/zlib-1.2.11/trees.h
new file mode 100644
index 00000000..d35639d8
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/trees.h
@@ -0,0 +1,128 @@
+/* header created automatically with -DGEN_TREES_H */
+
+local const ct_data static_ltree[L_CODES+2] = {
+{{ 12},{ 8}}, {{140},{ 8}}, {{ 76},{ 8}}, {{204},{ 8}}, {{ 44},{ 8}},
+{{172},{ 8}}, {{108},{ 8}}, {{236},{ 8}}, {{ 28},{ 8}}, {{156},{ 8}},
+{{ 92},{ 8}}, {{220},{ 8}}, {{ 60},{ 8}}, {{188},{ 8}}, {{124},{ 8}},
+{{252},{ 8}}, {{ 2},{ 8}}, {{130},{ 8}}, {{ 66},{ 8}}, {{194},{ 8}},
+{{ 34},{ 8}}, {{162},{ 8}}, {{ 98},{ 8}}, {{226},{ 8}}, {{ 18},{ 8}},
+{{146},{ 8}}, {{ 82},{ 8}}, {{210},{ 8}}, {{ 50},{ 8}}, {{178},{ 8}},
+{{114},{ 8}}, {{242},{ 8}}, {{ 10},{ 8}}, {{138},{ 8}}, {{ 74},{ 8}},
+{{202},{ 8}}, {{ 42},{ 8}}, {{170},{ 8}}, {{106},{ 8}}, {{234},{ 8}},
+{{ 26},{ 8}}, {{154},{ 8}}, {{ 90},{ 8}}, {{218},{ 8}}, {{ 58},{ 8}},
+{{186},{ 8}}, {{122},{ 8}}, {{250},{ 8}}, {{ 6},{ 8}}, {{134},{ 8}},
+{{ 70},{ 8}}, {{198},{ 8}}, {{ 38},{ 8}}, {{166},{ 8}}, {{102},{ 8}},
+{{230},{ 8}}, {{ 22},{ 8}}, {{150},{ 8}}, {{ 86},{ 8}}, {{214},{ 8}},
+{{ 54},{ 8}}, {{182},{ 8}}, {{118},{ 8}}, {{246},{ 8}}, {{ 14},{ 8}},
+{{142},{ 8}}, {{ 78},{ 8}}, {{206},{ 8}}, {{ 46},{ 8}}, {{174},{ 8}},
+{{110},{ 8}}, {{238},{ 8}}, {{ 30},{ 8}}, {{158},{ 8}}, {{ 94},{ 8}},
+{{222},{ 8}}, {{ 62},{ 8}}, {{190},{ 8}}, {{126},{ 8}}, {{254},{ 8}},
+{{ 1},{ 8}}, {{129},{ 8}}, {{ 65},{ 8}}, {{193},{ 8}}, {{ 33},{ 8}},
+{{161},{ 8}}, {{ 97},{ 8}}, {{225},{ 8}}, {{ 17},{ 8}}, {{145},{ 8}},
+{{ 81},{ 8}}, {{209},{ 8}}, {{ 49},{ 8}}, {{177},{ 8}}, {{113},{ 8}},
+{{241},{ 8}}, {{ 9},{ 8}}, {{137},{ 8}}, {{ 73},{ 8}}, {{201},{ 8}},
+{{ 41},{ 8}}, {{169},{ 8}}, {{105},{ 8}}, {{233},{ 8}}, {{ 25},{ 8}},
+{{153},{ 8}}, {{ 89},{ 8}}, {{217},{ 8}}, {{ 57},{ 8}}, {{185},{ 8}},
+{{121},{ 8}}, {{249},{ 8}}, {{ 5},{ 8}}, {{133},{ 8}}, {{ 69},{ 8}},
+{{197},{ 8}}, {{ 37},{ 8}}, {{165},{ 8}}, {{101},{ 8}}, {{229},{ 8}},
+{{ 21},{ 8}}, {{149},{ 8}}, {{ 85},{ 8}}, {{213},{ 8}}, {{ 53},{ 8}},
+{{181},{ 8}}, {{117},{ 8}}, {{245},{ 8}}, {{ 13},{ 8}}, {{141},{ 8}},
+{{ 77},{ 8}}, {{205},{ 8}}, {{ 45},{ 8}}, {{173},{ 8}}, {{109},{ 8}},
+{{237},{ 8}}, {{ 29},{ 8}}, {{157},{ 8}}, {{ 93},{ 8}}, {{221},{ 8}},
+{{ 61},{ 8}}, {{189},{ 8}}, {{125},{ 8}}, {{253},{ 8}}, {{ 19},{ 9}},
+{{275},{ 9}}, {{147},{ 9}}, {{403},{ 9}}, {{ 83},{ 9}}, {{339},{ 9}},
+{{211},{ 9}}, {{467},{ 9}}, {{ 51},{ 9}}, {{307},{ 9}}, {{179},{ 9}},
+{{435},{ 9}}, {{115},{ 9}}, {{371},{ 9}}, {{243},{ 9}}, {{499},{ 9}},
+{{ 11},{ 9}}, {{267},{ 9}}, {{139},{ 9}}, {{395},{ 9}}, {{ 75},{ 9}},
+{{331},{ 9}}, {{203},{ 9}}, {{459},{ 9}}, {{ 43},{ 9}}, {{299},{ 9}},
+{{171},{ 9}}, {{427},{ 9}}, {{107},{ 9}}, {{363},{ 9}}, {{235},{ 9}},
+{{491},{ 9}}, {{ 27},{ 9}}, {{283},{ 9}}, {{155},{ 9}}, {{411},{ 9}},
+{{ 91},{ 9}}, {{347},{ 9}}, {{219},{ 9}}, {{475},{ 9}}, {{ 59},{ 9}},
+{{315},{ 9}}, {{187},{ 9}}, {{443},{ 9}}, {{123},{ 9}}, {{379},{ 9}},
+{{251},{ 9}}, {{507},{ 9}}, {{ 7},{ 9}}, {{263},{ 9}}, {{135},{ 9}},
+{{391},{ 9}}, {{ 71},{ 9}}, {{327},{ 9}}, {{199},{ 9}}, {{455},{ 9}},
+{{ 39},{ 9}}, {{295},{ 9}}, {{167},{ 9}}, {{423},{ 9}}, {{103},{ 9}},
+{{359},{ 9}}, {{231},{ 9}}, {{487},{ 9}}, {{ 23},{ 9}}, {{279},{ 9}},
+{{151},{ 9}}, {{407},{ 9}}, {{ 87},{ 9}}, {{343},{ 9}}, {{215},{ 9}},
+{{471},{ 9}}, {{ 55},{ 9}}, {{311},{ 9}}, {{183},{ 9}}, {{439},{ 9}},
+{{119},{ 9}}, {{375},{ 9}}, {{247},{ 9}}, {{503},{ 9}}, {{ 15},{ 9}},
+{{271},{ 9}}, {{143},{ 9}}, {{399},{ 9}}, {{ 79},{ 9}}, {{335},{ 9}},
+{{207},{ 9}}, {{463},{ 9}}, {{ 47},{ 9}}, {{303},{ 9}}, {{175},{ 9}},
+{{431},{ 9}}, {{111},{ 9}}, {{367},{ 9}}, {{239},{ 9}}, {{495},{ 9}},
+{{ 31},{ 9}}, {{287},{ 9}}, {{159},{ 9}}, {{415},{ 9}}, {{ 95},{ 9}},
+{{351},{ 9}}, {{223},{ 9}}, {{479},{ 9}}, {{ 63},{ 9}}, {{319},{ 9}},
+{{191},{ 9}}, {{447},{ 9}}, {{127},{ 9}}, {{383},{ 9}}, {{255},{ 9}},
+{{511},{ 9}}, {{ 0},{ 7}}, {{ 64},{ 7}}, {{ 32},{ 7}}, {{ 96},{ 7}},
+{{ 16},{ 7}}, {{ 80},{ 7}}, {{ 48},{ 7}}, {{112},{ 7}}, {{ 8},{ 7}},
+{{ 72},{ 7}}, {{ 40},{ 7}}, {{104},{ 7}}, {{ 24},{ 7}}, {{ 88},{ 7}},
+{{ 56},{ 7}}, {{120},{ 7}}, {{ 4},{ 7}}, {{ 68},{ 7}}, {{ 36},{ 7}},
+{{100},{ 7}}, {{ 20},{ 7}}, {{ 84},{ 7}}, {{ 52},{ 7}}, {{116},{ 7}},
+{{ 3},{ 8}}, {{131},{ 8}}, {{ 67},{ 8}}, {{195},{ 8}}, {{ 35},{ 8}},
+{{163},{ 8}}, {{ 99},{ 8}}, {{227},{ 8}}
+};
+
+local const ct_data static_dtree[D_CODES] = {
+{{ 0},{ 5}}, {{16},{ 5}}, {{ 8},{ 5}}, {{24},{ 5}}, {{ 4},{ 5}},
+{{20},{ 5}}, {{12},{ 5}}, {{28},{ 5}}, {{ 2},{ 5}}, {{18},{ 5}},
+{{10},{ 5}}, {{26},{ 5}}, {{ 6},{ 5}}, {{22},{ 5}}, {{14},{ 5}},
+{{30},{ 5}}, {{ 1},{ 5}}, {{17},{ 5}}, {{ 9},{ 5}}, {{25},{ 5}},
+{{ 5},{ 5}}, {{21},{ 5}}, {{13},{ 5}}, {{29},{ 5}}, {{ 3},{ 5}},
+{{19},{ 5}}, {{11},{ 5}}, {{27},{ 5}}, {{ 7},{ 5}}, {{23},{ 5}}
+};
+
+const uch ZLIB_INTERNAL _dist_code[DIST_CODE_LEN] = {
+ 0, 1, 2, 3, 4, 4, 5, 5, 6, 6, 6, 6, 7, 7, 7, 7, 8, 8, 8, 8,
+ 8, 8, 8, 8, 9, 9, 9, 9, 9, 9, 9, 9, 10, 10, 10, 10, 10, 10, 10, 10,
+10, 10, 10, 10, 10, 10, 10, 10, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
+11, 11, 11, 11, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12,
+12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+13, 13, 13, 13, 13, 13, 13, 13, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 16, 17,
+18, 18, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 22, 22, 22, 22, 22, 22, 22, 22,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+28, 28, 28, 28, 28, 28, 28, 28, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29,
+29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29, 29
+};
+
+const uch ZLIB_INTERNAL _length_code[MAX_MATCH-MIN_MATCH+1]= {
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 12, 12,
+13, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15, 16, 16, 16, 16, 16, 16, 16, 16,
+17, 17, 17, 17, 17, 17, 17, 17, 18, 18, 18, 18, 18, 18, 18, 18, 19, 19, 19, 19,
+19, 19, 19, 19, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 22, 22, 22, 22,
+22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 22, 23, 23, 23, 23, 23, 23, 23, 23,
+23, 23, 23, 23, 23, 23, 23, 23, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24, 24,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26, 26,
+26, 26, 26, 26, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, 28
+};
+
+local const int base_length[LENGTH_CODES] = {
+0, 1, 2, 3, 4, 5, 6, 7, 8, 10, 12, 14, 16, 20, 24, 28, 32, 40, 48, 56,
+64, 80, 96, 112, 128, 160, 192, 224, 0
+};
+
+local const int base_dist[D_CODES] = {
+ 0, 1, 2, 3, 4, 6, 8, 12, 16, 24,
+ 32, 48, 64, 96, 128, 192, 256, 384, 512, 768,
+ 1024, 1536, 2048, 3072, 4096, 6144, 8192, 12288, 16384, 24576
+};
+
diff --git a/test/monniaux/zlib-1.2.11/uncompr.c b/test/monniaux/zlib-1.2.11/uncompr.c
new file mode 100644
index 00000000..f03a1a86
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/uncompr.c
@@ -0,0 +1,93 @@
+/* uncompr.c -- decompress a memory buffer
+ * Copyright (C) 1995-2003, 2010, 2014, 2016 Jean-loup Gailly, Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#define ZLIB_INTERNAL
+#include "zlib.h"
+
+/* ===========================================================================
+ Decompresses the source buffer into the destination buffer. *sourceLen is
+ the byte length of the source buffer. Upon entry, *destLen is the total size
+ of the destination buffer, which must be large enough to hold the entire
+ uncompressed data. (The size of the uncompressed data must have been saved
+ previously by the compressor and transmitted to the decompressor by some
+ mechanism outside the scope of this compression library.) Upon exit,
+ *destLen is the size of the decompressed data and *sourceLen is the number
+ of source bytes consumed. Upon return, source + *sourceLen points to the
+ first unused input byte.
+
+ uncompress returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_BUF_ERROR if there was not enough room in the output buffer, or
+ Z_DATA_ERROR if the input data was corrupted, including if the input data is
+ an incomplete zlib stream.
+*/
+int ZEXPORT uncompress2 (dest, destLen, source, sourceLen)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong *sourceLen;
+{
+ z_stream stream;
+ int err;
+ const uInt max = (uInt)-1;
+ uLong len, left;
+ Byte buf[1]; /* for detection of incomplete stream when *destLen == 0 */
+
+ len = *sourceLen;
+ if (*destLen) {
+ left = *destLen;
+ *destLen = 0;
+ }
+ else {
+ left = 1;
+ dest = buf;
+ }
+
+ stream.next_in = (z_const Bytef *)source;
+ stream.avail_in = 0;
+ stream.zalloc = (alloc_func)0;
+ stream.zfree = (free_func)0;
+ stream.opaque = (voidpf)0;
+
+ err = inflateInit(&stream);
+ if (err != Z_OK) return err;
+
+ stream.next_out = dest;
+ stream.avail_out = 0;
+
+ do {
+ if (stream.avail_out == 0) {
+ stream.avail_out = left > (uLong)max ? max : (uInt)left;
+ left -= stream.avail_out;
+ }
+ if (stream.avail_in == 0) {
+ stream.avail_in = len > (uLong)max ? max : (uInt)len;
+ len -= stream.avail_in;
+ }
+ err = inflate(&stream, Z_NO_FLUSH);
+ } while (err == Z_OK);
+
+ *sourceLen -= len + stream.avail_in;
+ if (dest != buf)
+ *destLen = stream.total_out;
+ else if (stream.total_out && err == Z_BUF_ERROR)
+ left = 1;
+
+ inflateEnd(&stream);
+ return err == Z_STREAM_END ? Z_OK :
+ err == Z_NEED_DICT ? Z_DATA_ERROR :
+ err == Z_BUF_ERROR && left + stream.avail_out ? Z_DATA_ERROR :
+ err;
+}
+
+int ZEXPORT uncompress (dest, destLen, source, sourceLen)
+ Bytef *dest;
+ uLongf *destLen;
+ const Bytef *source;
+ uLong sourceLen;
+{
+ return uncompress2(dest, destLen, source, &sourceLen);
+}
diff --git a/test/monniaux/zlib-1.2.11/zconf.h b/test/monniaux/zlib-1.2.11/zconf.h
new file mode 100644
index 00000000..5e1d68a0
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/zconf.h
@@ -0,0 +1,534 @@
+/* zconf.h -- configuration of the zlib compression library
+ * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#ifndef ZCONF_H
+#define ZCONF_H
+
+/*
+ * If you *really* need a unique prefix for all types and library functions,
+ * compile with -DZ_PREFIX. The "standard" zlib should be compiled without it.
+ * Even better than compiling with -DZ_PREFIX would be to use configure to set
+ * this permanently in zconf.h using "./configure --zprefix".
+ */
+#ifdef Z_PREFIX /* may be set to #if 1 by ./configure */
+# define Z_PREFIX_SET
+
+/* all linked symbols and init macros */
+# define _dist_code z__dist_code
+# define _length_code z__length_code
+# define _tr_align z__tr_align
+# define _tr_flush_bits z__tr_flush_bits
+# define _tr_flush_block z__tr_flush_block
+# define _tr_init z__tr_init
+# define _tr_stored_block z__tr_stored_block
+# define _tr_tally z__tr_tally
+# define adler32 z_adler32
+# define adler32_combine z_adler32_combine
+# define adler32_combine64 z_adler32_combine64
+# define adler32_z z_adler32_z
+# ifndef Z_SOLO
+# define compress z_compress
+# define compress2 z_compress2
+# define compressBound z_compressBound
+# endif
+# define crc32 z_crc32
+# define crc32_combine z_crc32_combine
+# define crc32_combine64 z_crc32_combine64
+# define crc32_z z_crc32_z
+# define deflate z_deflate
+# define deflateBound z_deflateBound
+# define deflateCopy z_deflateCopy
+# define deflateEnd z_deflateEnd
+# define deflateGetDictionary z_deflateGetDictionary
+# define deflateInit z_deflateInit
+# define deflateInit2 z_deflateInit2
+# define deflateInit2_ z_deflateInit2_
+# define deflateInit_ z_deflateInit_
+# define deflateParams z_deflateParams
+# define deflatePending z_deflatePending
+# define deflatePrime z_deflatePrime
+# define deflateReset z_deflateReset
+# define deflateResetKeep z_deflateResetKeep
+# define deflateSetDictionary z_deflateSetDictionary
+# define deflateSetHeader z_deflateSetHeader
+# define deflateTune z_deflateTune
+# define deflate_copyright z_deflate_copyright
+# define get_crc_table z_get_crc_table
+# ifndef Z_SOLO
+# define gz_error z_gz_error
+# define gz_intmax z_gz_intmax
+# define gz_strwinerror z_gz_strwinerror
+# define gzbuffer z_gzbuffer
+# define gzclearerr z_gzclearerr
+# define gzclose z_gzclose
+# define gzclose_r z_gzclose_r
+# define gzclose_w z_gzclose_w
+# define gzdirect z_gzdirect
+# define gzdopen z_gzdopen
+# define gzeof z_gzeof
+# define gzerror z_gzerror
+# define gzflush z_gzflush
+# define gzfread z_gzfread
+# define gzfwrite z_gzfwrite
+# define gzgetc z_gzgetc
+# define gzgetc_ z_gzgetc_
+# define gzgets z_gzgets
+# define gzoffset z_gzoffset
+# define gzoffset64 z_gzoffset64
+# define gzopen z_gzopen
+# define gzopen64 z_gzopen64
+# ifdef _WIN32
+# define gzopen_w z_gzopen_w
+# endif
+# define gzprintf z_gzprintf
+# define gzputc z_gzputc
+# define gzputs z_gzputs
+# define gzread z_gzread
+# define gzrewind z_gzrewind
+# define gzseek z_gzseek
+# define gzseek64 z_gzseek64
+# define gzsetparams z_gzsetparams
+# define gztell z_gztell
+# define gztell64 z_gztell64
+# define gzungetc z_gzungetc
+# define gzvprintf z_gzvprintf
+# define gzwrite z_gzwrite
+# endif
+# define inflate z_inflate
+# define inflateBack z_inflateBack
+# define inflateBackEnd z_inflateBackEnd
+# define inflateBackInit z_inflateBackInit
+# define inflateBackInit_ z_inflateBackInit_
+# define inflateCodesUsed z_inflateCodesUsed
+# define inflateCopy z_inflateCopy
+# define inflateEnd z_inflateEnd
+# define inflateGetDictionary z_inflateGetDictionary
+# define inflateGetHeader z_inflateGetHeader
+# define inflateInit z_inflateInit
+# define inflateInit2 z_inflateInit2
+# define inflateInit2_ z_inflateInit2_
+# define inflateInit_ z_inflateInit_
+# define inflateMark z_inflateMark
+# define inflatePrime z_inflatePrime
+# define inflateReset z_inflateReset
+# define inflateReset2 z_inflateReset2
+# define inflateResetKeep z_inflateResetKeep
+# define inflateSetDictionary z_inflateSetDictionary
+# define inflateSync z_inflateSync
+# define inflateSyncPoint z_inflateSyncPoint
+# define inflateUndermine z_inflateUndermine
+# define inflateValidate z_inflateValidate
+# define inflate_copyright z_inflate_copyright
+# define inflate_fast z_inflate_fast
+# define inflate_table z_inflate_table
+# ifndef Z_SOLO
+# define uncompress z_uncompress
+# define uncompress2 z_uncompress2
+# endif
+# define zError z_zError
+# ifndef Z_SOLO
+# define zcalloc z_zcalloc
+# define zcfree z_zcfree
+# endif
+# define zlibCompileFlags z_zlibCompileFlags
+# define zlibVersion z_zlibVersion
+
+/* all zlib typedefs in zlib.h and zconf.h */
+# define Byte z_Byte
+# define Bytef z_Bytef
+# define alloc_func z_alloc_func
+# define charf z_charf
+# define free_func z_free_func
+# ifndef Z_SOLO
+# define gzFile z_gzFile
+# endif
+# define gz_header z_gz_header
+# define gz_headerp z_gz_headerp
+# define in_func z_in_func
+# define intf z_intf
+# define out_func z_out_func
+# define uInt z_uInt
+# define uIntf z_uIntf
+# define uLong z_uLong
+# define uLongf z_uLongf
+# define voidp z_voidp
+# define voidpc z_voidpc
+# define voidpf z_voidpf
+
+/* all zlib structs in zlib.h and zconf.h */
+# define gz_header_s z_gz_header_s
+# define internal_state z_internal_state
+
+#endif
+
+#if defined(__MSDOS__) && !defined(MSDOS)
+# define MSDOS
+#endif
+#if (defined(OS_2) || defined(__OS2__)) && !defined(OS2)
+# define OS2
+#endif
+#if defined(_WINDOWS) && !defined(WINDOWS)
+# define WINDOWS
+#endif
+#if defined(_WIN32) || defined(_WIN32_WCE) || defined(__WIN32__)
+# ifndef WIN32
+# define WIN32
+# endif
+#endif
+#if (defined(MSDOS) || defined(OS2) || defined(WINDOWS)) && !defined(WIN32)
+# if !defined(__GNUC__) && !defined(__FLAT__) && !defined(__386__)
+# ifndef SYS16BIT
+# define SYS16BIT
+# endif
+# endif
+#endif
+
+/*
+ * Compile with -DMAXSEG_64K if the alloc function cannot allocate more
+ * than 64k bytes at a time (needed on systems with 16-bit int).
+ */
+#ifdef SYS16BIT
+# define MAXSEG_64K
+#endif
+#ifdef MSDOS
+# define UNALIGNED_OK
+#endif
+
+#ifdef __STDC_VERSION__
+# ifndef STDC
+# define STDC
+# endif
+# if __STDC_VERSION__ >= 199901L
+# ifndef STDC99
+# define STDC99
+# endif
+# endif
+#endif
+#if !defined(STDC) && (defined(__STDC__) || defined(__cplusplus))
+# define STDC
+#endif
+#if !defined(STDC) && (defined(__GNUC__) || defined(__BORLANDC__))
+# define STDC
+#endif
+#if !defined(STDC) && (defined(MSDOS) || defined(WINDOWS) || defined(WIN32))
+# define STDC
+#endif
+#if !defined(STDC) && (defined(OS2) || defined(__HOS_AIX__))
+# define STDC
+#endif
+
+#if defined(__OS400__) && !defined(STDC) /* iSeries (formerly AS/400). */
+# define STDC
+#endif
+
+#ifndef STDC
+# ifndef const /* cannot use !defined(STDC) && !defined(const) on Mac */
+# define const /* note: need a more gentle solution here */
+# endif
+#endif
+
+#if defined(ZLIB_CONST) && !defined(z_const)
+# define z_const const
+#else
+# define z_const
+#endif
+
+#ifdef Z_SOLO
+ typedef unsigned long z_size_t;
+#else
+# define z_longlong long long
+# if defined(NO_SIZE_T)
+ typedef unsigned NO_SIZE_T z_size_t;
+# elif defined(STDC)
+# include <stddef.h>
+ typedef size_t z_size_t;
+# else
+ typedef unsigned long z_size_t;
+# endif
+# undef z_longlong
+#endif
+
+/* Maximum value for memLevel in deflateInit2 */
+#ifndef MAX_MEM_LEVEL
+# ifdef MAXSEG_64K
+# define MAX_MEM_LEVEL 8
+# else
+# define MAX_MEM_LEVEL 9
+# endif
+#endif
+
+/* Maximum value for windowBits in deflateInit2 and inflateInit2.
+ * WARNING: reducing MAX_WBITS makes minigzip unable to extract .gz files
+ * created by gzip. (Files created by minigzip can still be extracted by
+ * gzip.)
+ */
+#ifndef MAX_WBITS
+# define MAX_WBITS 15 /* 32K LZ77 window */
+#endif
+
+/* The memory requirements for deflate are (in bytes):
+ (1 << (windowBits+2)) + (1 << (memLevel+9))
+ that is: 128K for windowBits=15 + 128K for memLevel = 8 (default values)
+ plus a few kilobytes for small objects. For example, if you want to reduce
+ the default memory requirements from 256K to 128K, compile with
+ make CFLAGS="-O -DMAX_WBITS=14 -DMAX_MEM_LEVEL=7"
+ Of course this will generally degrade compression (there's no free lunch).
+
+ The memory requirements for inflate are (in bytes) 1 << windowBits
+ that is, 32K for windowBits=15 (default value) plus about 7 kilobytes
+ for small objects.
+*/
+
+ /* Type declarations */
+
+#ifndef OF /* function prototypes */
+# ifdef STDC
+# define OF(args) args
+# else
+# define OF(args) ()
+# endif
+#endif
+
+#ifndef Z_ARG /* function prototypes for stdarg */
+# if defined(STDC) || defined(Z_HAVE_STDARG_H)
+# define Z_ARG(args) args
+# else
+# define Z_ARG(args) ()
+# endif
+#endif
+
+/* The following definitions for FAR are needed only for MSDOS mixed
+ * model programming (small or medium model with some far allocations).
+ * This was tested only with MSC; for other MSDOS compilers you may have
+ * to define NO_MEMCPY in zutil.h. If you don't need the mixed model,
+ * just define FAR to be empty.
+ */
+#ifdef SYS16BIT
+# if defined(M_I86SM) || defined(M_I86MM)
+ /* MSC small or medium model */
+# define SMALL_MEDIUM
+# ifdef _MSC_VER
+# define FAR _far
+# else
+# define FAR far
+# endif
+# endif
+# if (defined(__SMALL__) || defined(__MEDIUM__))
+ /* Turbo C small or medium model */
+# define SMALL_MEDIUM
+# ifdef __BORLANDC__
+# define FAR _far
+# else
+# define FAR far
+# endif
+# endif
+#endif
+
+#if defined(WINDOWS) || defined(WIN32)
+ /* If building or using zlib as a DLL, define ZLIB_DLL.
+ * This is not mandatory, but it offers a little performance increase.
+ */
+# ifdef ZLIB_DLL
+# if defined(WIN32) && (!defined(__BORLANDC__) || (__BORLANDC__ >= 0x500))
+# ifdef ZLIB_INTERNAL
+# define ZEXTERN extern __declspec(dllexport)
+# else
+# define ZEXTERN extern __declspec(dllimport)
+# endif
+# endif
+# endif /* ZLIB_DLL */
+ /* If building or using zlib with the WINAPI/WINAPIV calling convention,
+ * define ZLIB_WINAPI.
+ * Caution: the standard ZLIB1.DLL is NOT compiled using ZLIB_WINAPI.
+ */
+# ifdef ZLIB_WINAPI
+# ifdef FAR
+# undef FAR
+# endif
+# include <windows.h>
+ /* No need for _export, use ZLIB.DEF instead. */
+ /* For complete Windows compatibility, use WINAPI, not __stdcall. */
+# define ZEXPORT WINAPI
+# ifdef WIN32
+# define ZEXPORTVA WINAPIV
+# else
+# define ZEXPORTVA FAR CDECL
+# endif
+# endif
+#endif
+
+#if defined (__BEOS__)
+# ifdef ZLIB_DLL
+# ifdef ZLIB_INTERNAL
+# define ZEXPORT __declspec(dllexport)
+# define ZEXPORTVA __declspec(dllexport)
+# else
+# define ZEXPORT __declspec(dllimport)
+# define ZEXPORTVA __declspec(dllimport)
+# endif
+# endif
+#endif
+
+#ifndef ZEXTERN
+# define ZEXTERN extern
+#endif
+#ifndef ZEXPORT
+# define ZEXPORT
+#endif
+#ifndef ZEXPORTVA
+# define ZEXPORTVA
+#endif
+
+#ifndef FAR
+# define FAR
+#endif
+
+#if !defined(__MACTYPES__)
+typedef unsigned char Byte; /* 8 bits */
+#endif
+typedef unsigned int uInt; /* 16 bits or more */
+typedef unsigned long uLong; /* 32 bits or more */
+
+#ifdef SMALL_MEDIUM
+ /* Borland C/C++ and some old MSC versions ignore FAR inside typedef */
+# define Bytef Byte FAR
+#else
+ typedef Byte FAR Bytef;
+#endif
+typedef char FAR charf;
+typedef int FAR intf;
+typedef uInt FAR uIntf;
+typedef uLong FAR uLongf;
+
+#ifdef STDC
+ typedef void const *voidpc;
+ typedef void FAR *voidpf;
+ typedef void *voidp;
+#else
+ typedef Byte const *voidpc;
+ typedef Byte FAR *voidpf;
+ typedef Byte *voidp;
+#endif
+
+#if !defined(Z_U4) && !defined(Z_SOLO) && defined(STDC)
+# include <limits.h>
+# if (UINT_MAX == 0xffffffffUL)
+# define Z_U4 unsigned
+# elif (ULONG_MAX == 0xffffffffUL)
+# define Z_U4 unsigned long
+# elif (USHRT_MAX == 0xffffffffUL)
+# define Z_U4 unsigned short
+# endif
+#endif
+
+#ifdef Z_U4
+ typedef Z_U4 z_crc_t;
+#else
+ typedef unsigned long z_crc_t;
+#endif
+
+#ifdef HAVE_UNISTD_H /* may be set to #if 1 by ./configure */
+# define Z_HAVE_UNISTD_H
+#endif
+
+#ifdef HAVE_STDARG_H /* may be set to #if 1 by ./configure */
+# define Z_HAVE_STDARG_H
+#endif
+
+#ifdef STDC
+# ifndef Z_SOLO
+# include <sys/types.h> /* for off_t */
+# endif
+#endif
+
+#if defined(STDC) || defined(Z_HAVE_STDARG_H)
+# ifndef Z_SOLO
+# include <stdarg.h> /* for va_list */
+# endif
+#endif
+
+#ifdef _WIN32
+# ifndef Z_SOLO
+# include <stddef.h> /* for wchar_t */
+# endif
+#endif
+
+/* a little trick to accommodate both "#define _LARGEFILE64_SOURCE" and
+ * "#define _LARGEFILE64_SOURCE 1" as requesting 64-bit operations, (even
+ * though the former does not conform to the LFS document), but considering
+ * both "#undef _LARGEFILE64_SOURCE" and "#define _LARGEFILE64_SOURCE 0" as
+ * equivalently requesting no 64-bit operations
+ */
+#if defined(_LARGEFILE64_SOURCE) && -_LARGEFILE64_SOURCE - -1 == 1
+# undef _LARGEFILE64_SOURCE
+#endif
+
+#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H)
+# define Z_HAVE_UNISTD_H
+#endif
+#ifndef Z_SOLO
+# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE)
+# include <unistd.h> /* for SEEK_*, off_t, and _LFS64_LARGEFILE */
+# ifdef VMS
+# include <unixio.h> /* for off_t */
+# endif
+# ifndef z_off_t
+# define z_off_t off_t
+# endif
+# endif
+#endif
+
+#if defined(_LFS64_LARGEFILE) && _LFS64_LARGEFILE-0
+# define Z_LFS64
+#endif
+
+#if defined(_LARGEFILE64_SOURCE) && defined(Z_LFS64)
+# define Z_LARGE64
+#endif
+
+#if defined(_FILE_OFFSET_BITS) && _FILE_OFFSET_BITS-0 == 64 && defined(Z_LFS64)
+# define Z_WANT64
+#endif
+
+#if !defined(SEEK_SET) && !defined(Z_SOLO)
+# define SEEK_SET 0 /* Seek from beginning of file. */
+# define SEEK_CUR 1 /* Seek from current position. */
+# define SEEK_END 2 /* Set file pointer to EOF plus "offset" */
+#endif
+
+#ifndef z_off_t
+# define z_off_t long
+#endif
+
+#if !defined(_WIN32) && defined(Z_LARGE64)
+# define z_off64_t off64_t
+#else
+# if defined(_WIN32) && !defined(__GNUC__) && !defined(Z_SOLO)
+# define z_off64_t __int64
+# else
+# define z_off64_t z_off_t
+# endif
+#endif
+
+/* MVS linker does not support external names larger than 8 bytes */
+#if defined(__MVS__)
+ #pragma map(deflateInit_,"DEIN")
+ #pragma map(deflateInit2_,"DEIN2")
+ #pragma map(deflateEnd,"DEEND")
+ #pragma map(deflateBound,"DEBND")
+ #pragma map(inflateInit_,"ININ")
+ #pragma map(inflateInit2_,"ININ2")
+ #pragma map(inflateEnd,"INEND")
+ #pragma map(inflateSync,"INSY")
+ #pragma map(inflateSetDictionary,"INSEDI")
+ #pragma map(compressBound,"CMBND")
+ #pragma map(inflate_table,"INTABL")
+ #pragma map(inflate_fast,"INFA")
+ #pragma map(inflate_copyright,"INCOPY")
+#endif
+
+#endif /* ZCONF_H */
diff --git a/test/monniaux/zlib-1.2.11/zlib.h b/test/monniaux/zlib-1.2.11/zlib.h
new file mode 100644
index 00000000..f09cdaf1
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/zlib.h
@@ -0,0 +1,1912 @@
+/* zlib.h -- interface of the 'zlib' general purpose compression library
+ version 1.2.11, January 15th, 2017
+
+ Copyright (C) 1995-2017 Jean-loup Gailly and Mark Adler
+
+ This software is provided 'as-is', without any express or implied
+ warranty. In no event will the authors be held liable for any damages
+ arising from the use of this software.
+
+ Permission is granted to anyone to use this software for any purpose,
+ including commercial applications, and to alter it and redistribute it
+ freely, subject to the following restrictions:
+
+ 1. The origin of this software must not be misrepresented; you must not
+ claim that you wrote the original software. If you use this software
+ in a product, an acknowledgment in the product documentation would be
+ appreciated but is not required.
+ 2. Altered source versions must be plainly marked as such, and must not be
+ misrepresented as being the original software.
+ 3. This notice may not be removed or altered from any source distribution.
+
+ Jean-loup Gailly Mark Adler
+ jloup@gzip.org madler@alumni.caltech.edu
+
+
+ The data format used by the zlib library is described by RFCs (Request for
+ Comments) 1950 to 1952 in the files http://tools.ietf.org/html/rfc1950
+ (zlib format), rfc1951 (deflate format) and rfc1952 (gzip format).
+*/
+
+#ifndef ZLIB_H
+#define ZLIB_H
+
+#include "zconf.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define ZLIB_VERSION "1.2.11"
+#define ZLIB_VERNUM 0x12b0
+#define ZLIB_VER_MAJOR 1
+#define ZLIB_VER_MINOR 2
+#define ZLIB_VER_REVISION 11
+#define ZLIB_VER_SUBREVISION 0
+
+/*
+ The 'zlib' compression library provides in-memory compression and
+ decompression functions, including integrity checks of the uncompressed data.
+ This version of the library supports only one compression method (deflation)
+ but other algorithms will be added later and will have the same stream
+ interface.
+
+ Compression can be done in a single step if the buffers are large enough,
+ or can be done by repeated calls of the compression function. In the latter
+ case, the application must provide more input and/or consume the output
+ (providing more output space) before each call.
+
+ The compressed data format used by default by the in-memory functions is
+ the zlib format, which is a zlib wrapper documented in RFC 1950, wrapped
+ around a deflate stream, which is itself documented in RFC 1951.
+
+ The library also supports reading and writing files in gzip (.gz) format
+ with an interface similar to that of stdio using the functions that start
+ with "gz". The gzip format is different from the zlib format. gzip is a
+ gzip wrapper, documented in RFC 1952, wrapped around a deflate stream.
+
+ This library can optionally read and write gzip and raw deflate streams in
+ memory as well.
+
+ The zlib format was designed to be compact and fast for use in memory
+ and on communications channels. The gzip format was designed for single-
+ file compression on file systems, has a larger header than zlib to maintain
+ directory information, and uses a different, slower check method than zlib.
+
+ The library does not install any signal handler. The decoder checks
+ the consistency of the compressed data, so the library should never crash
+ even in the case of corrupted input.
+*/
+
+typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));
+typedef void (*free_func) OF((voidpf opaque, voidpf address));
+
+struct internal_state;
+
+typedef struct z_stream_s {
+ z_const Bytef *next_in; /* next input byte */
+ uInt avail_in; /* number of bytes available at next_in */
+ uLong total_in; /* total number of input bytes read so far */
+
+ Bytef *next_out; /* next output byte will go here */
+ uInt avail_out; /* remaining free space at next_out */
+ uLong total_out; /* total number of bytes output so far */
+
+ z_const char *msg; /* last error message, NULL if no error */
+ struct internal_state FAR *state; /* not visible by applications */
+
+ alloc_func zalloc; /* used to allocate the internal state */
+ free_func zfree; /* used to free the internal state */
+ voidpf opaque; /* private data object passed to zalloc and zfree */
+
+ int data_type; /* best guess about the data type: binary or text
+ for deflate, or the decoding state for inflate */
+ uLong adler; /* Adler-32 or CRC-32 value of the uncompressed data */
+ uLong reserved; /* reserved for future use */
+} z_stream;
+
+typedef z_stream FAR *z_streamp;
+
+/*
+ gzip header information passed to and from zlib routines. See RFC 1952
+ for more details on the meanings of these fields.
+*/
+typedef struct gz_header_s {
+ int text; /* true if compressed data believed to be text */
+ uLong time; /* modification time */
+ int xflags; /* extra flags (not used when writing a gzip file) */
+ int os; /* operating system */
+ Bytef *extra; /* pointer to extra field or Z_NULL if none */
+ uInt extra_len; /* extra field length (valid if extra != Z_NULL) */
+ uInt extra_max; /* space at extra (only when reading header) */
+ Bytef *name; /* pointer to zero-terminated file name or Z_NULL */
+ uInt name_max; /* space at name (only when reading header) */
+ Bytef *comment; /* pointer to zero-terminated comment or Z_NULL */
+ uInt comm_max; /* space at comment (only when reading header) */
+ int hcrc; /* true if there was or will be a header crc */
+ int done; /* true when done reading gzip header (not used
+ when writing a gzip file) */
+} gz_header;
+
+typedef gz_header FAR *gz_headerp;
+
+/*
+ The application must update next_in and avail_in when avail_in has dropped
+ to zero. It must update next_out and avail_out when avail_out has dropped
+ to zero. The application must initialize zalloc, zfree and opaque before
+ calling the init function. All other fields are set by the compression
+ library and must not be updated by the application.
+
+ The opaque value provided by the application will be passed as the first
+ parameter for calls of zalloc and zfree. This can be useful for custom
+ memory management. The compression library attaches no meaning to the
+ opaque value.
+
+ zalloc must return Z_NULL if there is not enough memory for the object.
+ If zlib is used in a multi-threaded application, zalloc and zfree must be
+ thread safe. In that case, zlib is thread-safe. When zalloc and zfree are
+ Z_NULL on entry to the initialization function, they are set to internal
+ routines that use the standard library functions malloc() and free().
+
+ On 16-bit systems, the functions zalloc and zfree must be able to allocate
+ exactly 65536 bytes, but will not be required to allocate more than this if
+ the symbol MAXSEG_64K is defined (see zconf.h). WARNING: On MSDOS, pointers
+ returned by zalloc for objects of exactly 65536 bytes *must* have their
+ offset normalized to zero. The default allocation function provided by this
+ library ensures this (see zutil.c). To reduce memory requirements and avoid
+ any allocation of 64K objects, at the expense of compression ratio, compile
+ the library with -DMAX_WBITS=14 (see zconf.h).
+
+ The fields total_in and total_out can be used for statistics or progress
+ reports. After compression, total_in holds the total size of the
+ uncompressed data and may be saved for use by the decompressor (particularly
+ if the decompressor wants to decompress everything in a single step).
+*/
+
+ /* constants */
+
+#define Z_NO_FLUSH 0
+#define Z_PARTIAL_FLUSH 1
+#define Z_SYNC_FLUSH 2
+#define Z_FULL_FLUSH 3
+#define Z_FINISH 4
+#define Z_BLOCK 5
+#define Z_TREES 6
+/* Allowed flush values; see deflate() and inflate() below for details */
+
+#define Z_OK 0
+#define Z_STREAM_END 1
+#define Z_NEED_DICT 2
+#define Z_ERRNO (-1)
+#define Z_STREAM_ERROR (-2)
+#define Z_DATA_ERROR (-3)
+#define Z_MEM_ERROR (-4)
+#define Z_BUF_ERROR (-5)
+#define Z_VERSION_ERROR (-6)
+/* Return codes for the compression/decompression functions. Negative values
+ * are errors, positive values are used for special but normal events.
+ */
+
+#define Z_NO_COMPRESSION 0
+#define Z_BEST_SPEED 1
+#define Z_BEST_COMPRESSION 9
+#define Z_DEFAULT_COMPRESSION (-1)
+/* compression levels */
+
+#define Z_FILTERED 1
+#define Z_HUFFMAN_ONLY 2
+#define Z_RLE 3
+#define Z_FIXED 4
+#define Z_DEFAULT_STRATEGY 0
+/* compression strategy; see deflateInit2() below for details */
+
+#define Z_BINARY 0
+#define Z_TEXT 1
+#define Z_ASCII Z_TEXT /* for compatibility with 1.2.2 and earlier */
+#define Z_UNKNOWN 2
+/* Possible values of the data_type field for deflate() */
+
+#define Z_DEFLATED 8
+/* The deflate compression method (the only one supported in this version) */
+
+#define Z_NULL 0 /* for initializing zalloc, zfree, opaque */
+
+#define zlib_version zlibVersion()
+/* for compatibility with versions < 1.0.2 */
+
+
+ /* basic functions */
+
+ZEXTERN const char * ZEXPORT zlibVersion OF((void));
+/* The application can compare zlibVersion and ZLIB_VERSION for consistency.
+ If the first character differs, the library code actually used is not
+ compatible with the zlib.h header file used by the application. This check
+ is automatically made by deflateInit and inflateInit.
+ */
+
+/*
+ZEXTERN int ZEXPORT deflateInit OF((z_streamp strm, int level));
+
+ Initializes the internal stream state for compression. The fields
+ zalloc, zfree and opaque must be initialized before by the caller. If
+ zalloc and zfree are set to Z_NULL, deflateInit updates them to use default
+ allocation functions.
+
+ The compression level must be Z_DEFAULT_COMPRESSION, or between 0 and 9:
+ 1 gives best speed, 9 gives best compression, 0 gives no compression at all
+ (the input data is simply copied a block at a time). Z_DEFAULT_COMPRESSION
+ requests a default compromise between speed and compression (currently
+ equivalent to level 6).
+
+ deflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_STREAM_ERROR if level is not a valid compression level, or
+ Z_VERSION_ERROR if the zlib library version (zlib_version) is incompatible
+ with the version assumed by the caller (ZLIB_VERSION). msg is set to null
+ if there is no error message. deflateInit does not perform any compression:
+ this will be done by deflate().
+*/
+
+
+ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));
+/*
+ deflate compresses as much data as possible, and stops when the input
+ buffer becomes empty or the output buffer becomes full. It may introduce
+ some output latency (reading input without producing any output) except when
+ forced to flush.
+
+ The detailed semantics are as follows. deflate performs one or both of the
+ following actions:
+
+ - Compress more input starting at next_in and update next_in and avail_in
+ accordingly. If not all input can be processed (because there is not
+ enough room in the output buffer), next_in and avail_in are updated and
+ processing will resume at this point for the next call of deflate().
+
+ - Generate more output starting at next_out and update next_out and avail_out
+ accordingly. This action is forced if the parameter flush is non zero.
+ Forcing flush frequently degrades the compression ratio, so this parameter
+ should be set only when necessary. Some output may be provided even if
+ flush is zero.
+
+ Before the call of deflate(), the application should ensure that at least
+ one of the actions is possible, by providing more input and/or consuming more
+ output, and updating avail_in or avail_out accordingly; avail_out should
+ never be zero before the call. The application can consume the compressed
+ output when it wants, for example when the output buffer is full (avail_out
+ == 0), or after each call of deflate(). If deflate returns Z_OK and with
+ zero avail_out, it must be called again after making room in the output
+ buffer because there might be more output pending. See deflatePending(),
+ which can be used if desired to determine whether or not there is more ouput
+ in that case.
+
+ Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to
+ decide how much data to accumulate before producing output, in order to
+ maximize compression.
+
+ If the parameter flush is set to Z_SYNC_FLUSH, all pending output is
+ flushed to the output buffer and the output is aligned on a byte boundary, so
+ that the decompressor can get all input data available so far. (In
+ particular avail_in is zero after the call if enough output space has been
+ provided before the call.) Flushing may degrade compression for some
+ compression algorithms and so it should be used only when necessary. This
+ completes the current deflate block and follows it with an empty stored block
+ that is three bits plus filler bits to the next byte, followed by four bytes
+ (00 00 ff ff).
+
+ If flush is set to Z_PARTIAL_FLUSH, all pending output is flushed to the
+ output buffer, but the output is not aligned to a byte boundary. All of the
+ input data so far will be available to the decompressor, as for Z_SYNC_FLUSH.
+ This completes the current deflate block and follows it with an empty fixed
+ codes block that is 10 bits long. This assures that enough bytes are output
+ in order for the decompressor to finish the block before the empty fixed
+ codes block.
+
+ If flush is set to Z_BLOCK, a deflate block is completed and emitted, as
+ for Z_SYNC_FLUSH, but the output is not aligned on a byte boundary, and up to
+ seven bits of the current block are held to be written as the next byte after
+ the next deflate block is completed. In this case, the decompressor may not
+ be provided enough bits at this point in order to complete decompression of
+ the data provided so far to the compressor. It may need to wait for the next
+ block to be emitted. This is for advanced applications that need to control
+ the emission of deflate blocks.
+
+ If flush is set to Z_FULL_FLUSH, all output is flushed as with
+ Z_SYNC_FLUSH, and the compression state is reset so that decompression can
+ restart from this point if previous compressed data has been damaged or if
+ random access is desired. Using Z_FULL_FLUSH too often can seriously degrade
+ compression.
+
+ If deflate returns with avail_out == 0, this function must be called again
+ with the same value of the flush parameter and more output space (updated
+ avail_out), until the flush is complete (deflate returns with non-zero
+ avail_out). In the case of a Z_FULL_FLUSH or Z_SYNC_FLUSH, make sure that
+ avail_out is greater than six to avoid repeated flush markers due to
+ avail_out == 0 on return.
+
+ If the parameter flush is set to Z_FINISH, pending input is processed,
+ pending output is flushed and deflate returns with Z_STREAM_END if there was
+ enough output space. If deflate returns with Z_OK or Z_BUF_ERROR, this
+ function must be called again with Z_FINISH and more output space (updated
+ avail_out) but no more input data, until it returns with Z_STREAM_END or an
+ error. After deflate has returned Z_STREAM_END, the only possible operations
+ on the stream are deflateReset or deflateEnd.
+
+ Z_FINISH can be used in the first deflate call after deflateInit if all the
+ compression is to be done in a single step. In order to complete in one
+ call, avail_out must be at least the value returned by deflateBound (see
+ below). Then deflate is guaranteed to return Z_STREAM_END. If not enough
+ output space is provided, deflate will not return Z_STREAM_END, and it must
+ be called again as described above.
+
+ deflate() sets strm->adler to the Adler-32 checksum of all input read
+ so far (that is, total_in bytes). If a gzip stream is being generated, then
+ strm->adler will be the CRC-32 checksum of the input read so far. (See
+ deflateInit2 below.)
+
+ deflate() may update strm->data_type if it can make a good guess about
+ the input data type (Z_BINARY or Z_TEXT). If in doubt, the data is
+ considered binary. This field is only for information purposes and does not
+ affect the compression algorithm in any manner.
+
+ deflate() returns Z_OK if some progress has been made (more input
+ processed or more output produced), Z_STREAM_END if all input has been
+ consumed and all output has been produced (only when flush is set to
+ Z_FINISH), Z_STREAM_ERROR if the stream state was inconsistent (for example
+ if next_in or next_out was Z_NULL or the state was inadvertently written over
+ by the application), or Z_BUF_ERROR if no progress is possible (for example
+ avail_in or avail_out was zero). Note that Z_BUF_ERROR is not fatal, and
+ deflate() can be called again with more input and more output space to
+ continue compressing.
+*/
+
+
+ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));
+/*
+ All dynamically allocated data structures for this stream are freed.
+ This function discards any unprocessed input and does not flush any pending
+ output.
+
+ deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the
+ stream state was inconsistent, Z_DATA_ERROR if the stream was freed
+ prematurely (some input or output was discarded). In the error case, msg
+ may be set but then points to a static string (which must not be
+ deallocated).
+*/
+
+
+/*
+ZEXTERN int ZEXPORT inflateInit OF((z_streamp strm));
+
+ Initializes the internal stream state for decompression. The fields
+ next_in, avail_in, zalloc, zfree and opaque must be initialized before by
+ the caller. In the current version of inflate, the provided input is not
+ read or consumed. The allocation of a sliding window will be deferred to
+ the first call of inflate (if the decompression does not complete on the
+ first call). If zalloc and zfree are set to Z_NULL, inflateInit updates
+ them to use default allocation functions.
+
+ inflateInit returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+ version assumed by the caller, or Z_STREAM_ERROR if the parameters are
+ invalid, such as a null pointer to the structure. msg is set to null if
+ there is no error message. inflateInit does not perform any decompression.
+ Actual decompression will be done by inflate(). So next_in, and avail_in,
+ next_out, and avail_out are unused and unchanged. The current
+ implementation of inflateInit() does not process any header information --
+ that is deferred until inflate() is called.
+*/
+
+
+ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));
+/*
+ inflate decompresses as much data as possible, and stops when the input
+ buffer becomes empty or the output buffer becomes full. It may introduce
+ some output latency (reading input without producing any output) except when
+ forced to flush.
+
+ The detailed semantics are as follows. inflate performs one or both of the
+ following actions:
+
+ - Decompress more input starting at next_in and update next_in and avail_in
+ accordingly. If not all input can be processed (because there is not
+ enough room in the output buffer), then next_in and avail_in are updated
+ accordingly, and processing will resume at this point for the next call of
+ inflate().
+
+ - Generate more output starting at next_out and update next_out and avail_out
+ accordingly. inflate() provides as much output as possible, until there is
+ no more input data or no more space in the output buffer (see below about
+ the flush parameter).
+
+ Before the call of inflate(), the application should ensure that at least
+ one of the actions is possible, by providing more input and/or consuming more
+ output, and updating the next_* and avail_* values accordingly. If the
+ caller of inflate() does not provide both available input and available
+ output space, it is possible that there will be no progress made. The
+ application can consume the uncompressed output when it wants, for example
+ when the output buffer is full (avail_out == 0), or after each call of
+ inflate(). If inflate returns Z_OK and with zero avail_out, it must be
+ called again after making room in the output buffer because there might be
+ more output pending.
+
+ The flush parameter of inflate() can be Z_NO_FLUSH, Z_SYNC_FLUSH, Z_FINISH,
+ Z_BLOCK, or Z_TREES. Z_SYNC_FLUSH requests that inflate() flush as much
+ output as possible to the output buffer. Z_BLOCK requests that inflate()
+ stop if and when it gets to the next deflate block boundary. When decoding
+ the zlib or gzip format, this will cause inflate() to return immediately
+ after the header and before the first block. When doing a raw inflate,
+ inflate() will go ahead and process the first block, and will return when it
+ gets to the end of that block, or when it runs out of data.
+
+ The Z_BLOCK option assists in appending to or combining deflate streams.
+ To assist in this, on return inflate() always sets strm->data_type to the
+ number of unused bits in the last byte taken from strm->next_in, plus 64 if
+ inflate() is currently decoding the last block in the deflate stream, plus
+ 128 if inflate() returned immediately after decoding an end-of-block code or
+ decoding the complete header up to just before the first byte of the deflate
+ stream. The end-of-block will not be indicated until all of the uncompressed
+ data from that block has been written to strm->next_out. The number of
+ unused bits may in general be greater than seven, except when bit 7 of
+ data_type is set, in which case the number of unused bits will be less than
+ eight. data_type is set as noted here every time inflate() returns for all
+ flush options, and so can be used to determine the amount of currently
+ consumed input in bits.
+
+ The Z_TREES option behaves as Z_BLOCK does, but it also returns when the
+ end of each deflate block header is reached, before any actual data in that
+ block is decoded. This allows the caller to determine the length of the
+ deflate block header for later use in random access within a deflate block.
+ 256 is added to the value of strm->data_type when inflate() returns
+ immediately after reaching the end of the deflate block header.
+
+ inflate() should normally be called until it returns Z_STREAM_END or an
+ error. However if all decompression is to be performed in a single step (a
+ single call of inflate), the parameter flush should be set to Z_FINISH. In
+ this case all pending input is processed and all pending output is flushed;
+ avail_out must be large enough to hold all of the uncompressed data for the
+ operation to complete. (The size of the uncompressed data may have been
+ saved by the compressor for this purpose.) The use of Z_FINISH is not
+ required to perform an inflation in one step. However it may be used to
+ inform inflate that a faster approach can be used for the single inflate()
+ call. Z_FINISH also informs inflate to not maintain a sliding window if the
+ stream completes, which reduces inflate's memory footprint. If the stream
+ does not complete, either because not all of the stream is provided or not
+ enough output space is provided, then a sliding window will be allocated and
+ inflate() can be called again to continue the operation as if Z_NO_FLUSH had
+ been used.
+
+ In this implementation, inflate() always flushes as much output as
+ possible to the output buffer, and always uses the faster approach on the
+ first call. So the effects of the flush parameter in this implementation are
+ on the return value of inflate() as noted below, when inflate() returns early
+ when Z_BLOCK or Z_TREES is used, and when inflate() avoids the allocation of
+ memory for a sliding window when Z_FINISH is used.
+
+ If a preset dictionary is needed after this call (see inflateSetDictionary
+ below), inflate sets strm->adler to the Adler-32 checksum of the dictionary
+ chosen by the compressor and returns Z_NEED_DICT; otherwise it sets
+ strm->adler to the Adler-32 checksum of all output produced so far (that is,
+ total_out bytes) and returns Z_OK, Z_STREAM_END or an error code as described
+ below. At the end of the stream, inflate() checks that its computed Adler-32
+ checksum is equal to that saved by the compressor and returns Z_STREAM_END
+ only if the checksum is correct.
+
+ inflate() can decompress and check either zlib-wrapped or gzip-wrapped
+ deflate data. The header type is detected automatically, if requested when
+ initializing with inflateInit2(). Any information contained in the gzip
+ header is not retained unless inflateGetHeader() is used. When processing
+ gzip-wrapped deflate data, strm->adler32 is set to the CRC-32 of the output
+ produced so far. The CRC-32 is checked against the gzip trailer, as is the
+ uncompressed length, modulo 2^32.
+
+ inflate() returns Z_OK if some progress has been made (more input processed
+ or more output produced), Z_STREAM_END if the end of the compressed data has
+ been reached and all uncompressed output has been produced, Z_NEED_DICT if a
+ preset dictionary is needed at this point, Z_DATA_ERROR if the input data was
+ corrupted (input stream not conforming to the zlib format or incorrect check
+ value, in which case strm->msg points to a string with a more specific
+ error), Z_STREAM_ERROR if the stream structure was inconsistent (for example
+ next_in or next_out was Z_NULL, or the state was inadvertently written over
+ by the application), Z_MEM_ERROR if there was not enough memory, Z_BUF_ERROR
+ if no progress was possible or if there was not enough room in the output
+ buffer when Z_FINISH is used. Note that Z_BUF_ERROR is not fatal, and
+ inflate() can be called again with more input and more output space to
+ continue decompressing. If Z_DATA_ERROR is returned, the application may
+ then call inflateSync() to look for a good compression block if a partial
+ recovery of the data is to be attempted.
+*/
+
+
+ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));
+/*
+ All dynamically allocated data structures for this stream are freed.
+ This function discards any unprocessed input and does not flush any pending
+ output.
+
+ inflateEnd returns Z_OK if success, or Z_STREAM_ERROR if the stream state
+ was inconsistent.
+*/
+
+
+ /* Advanced functions */
+
+/*
+ The following functions are needed only in some special applications.
+*/
+
+/*
+ZEXTERN int ZEXPORT deflateInit2 OF((z_streamp strm,
+ int level,
+ int method,
+ int windowBits,
+ int memLevel,
+ int strategy));
+
+ This is another version of deflateInit with more compression options. The
+ fields next_in, zalloc, zfree and opaque must be initialized before by the
+ caller.
+
+ The method parameter is the compression method. It must be Z_DEFLATED in
+ this version of the library.
+
+ The windowBits parameter is the base two logarithm of the window size
+ (the size of the history buffer). It should be in the range 8..15 for this
+ version of the library. Larger values of this parameter result in better
+ compression at the expense of memory usage. The default value is 15 if
+ deflateInit is used instead.
+
+ For the current implementation of deflate(), a windowBits value of 8 (a
+ window size of 256 bytes) is not supported. As a result, a request for 8
+ will result in 9 (a 512-byte window). In that case, providing 8 to
+ inflateInit2() will result in an error when the zlib header with 9 is
+ checked against the initialization of inflate(). The remedy is to not use 8
+ with deflateInit2() with this initialization, or at least in that case use 9
+ with inflateInit2().
+
+ windowBits can also be -8..-15 for raw deflate. In this case, -windowBits
+ determines the window size. deflate() will then generate raw deflate data
+ with no zlib header or trailer, and will not compute a check value.
+
+ windowBits can also be greater than 15 for optional gzip encoding. Add
+ 16 to windowBits to write a simple gzip header and trailer around the
+ compressed data instead of a zlib wrapper. The gzip header will have no
+ file name, no extra data, no comment, no modification time (set to zero), no
+ header crc, and the operating system will be set to the appropriate value,
+ if the operating system was determined at compile time. If a gzip stream is
+ being written, strm->adler is a CRC-32 instead of an Adler-32.
+
+ For raw deflate or gzip encoding, a request for a 256-byte window is
+ rejected as invalid, since only the zlib header provides a means of
+ transmitting the window size to the decompressor.
+
+ The memLevel parameter specifies how much memory should be allocated
+ for the internal compression state. memLevel=1 uses minimum memory but is
+ slow and reduces compression ratio; memLevel=9 uses maximum memory for
+ optimal speed. The default value is 8. See zconf.h for total memory usage
+ as a function of windowBits and memLevel.
+
+ The strategy parameter is used to tune the compression algorithm. Use the
+ value Z_DEFAULT_STRATEGY for normal data, Z_FILTERED for data produced by a
+ filter (or predictor), Z_HUFFMAN_ONLY to force Huffman encoding only (no
+ string match), or Z_RLE to limit match distances to one (run-length
+ encoding). Filtered data consists mostly of small values with a somewhat
+ random distribution. In this case, the compression algorithm is tuned to
+ compress them better. The effect of Z_FILTERED is to force more Huffman
+ coding and less string matching; it is somewhat intermediate between
+ Z_DEFAULT_STRATEGY and Z_HUFFMAN_ONLY. Z_RLE is designed to be almost as
+ fast as Z_HUFFMAN_ONLY, but give better compression for PNG image data. The
+ strategy parameter only affects the compression ratio but not the
+ correctness of the compressed output even if it is not set appropriately.
+ Z_FIXED prevents the use of dynamic Huffman codes, allowing for a simpler
+ decoder for special applications.
+
+ deflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_STREAM_ERROR if any parameter is invalid (such as an invalid
+ method), or Z_VERSION_ERROR if the zlib library version (zlib_version) is
+ incompatible with the version assumed by the caller (ZLIB_VERSION). msg is
+ set to null if there is no error message. deflateInit2 does not perform any
+ compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+/*
+ Initializes the compression dictionary from the given byte sequence
+ without producing any compressed output. When using the zlib format, this
+ function must be called immediately after deflateInit, deflateInit2 or
+ deflateReset, and before any call of deflate. When doing raw deflate, this
+ function must be called either before any call of deflate, or immediately
+ after the completion of a deflate block, i.e. after all input has been
+ consumed and all output has been delivered when using any of the flush
+ options Z_BLOCK, Z_PARTIAL_FLUSH, Z_SYNC_FLUSH, or Z_FULL_FLUSH. The
+ compressor and decompressor must use exactly the same dictionary (see
+ inflateSetDictionary).
+
+ The dictionary should consist of strings (byte sequences) that are likely
+ to be encountered later in the data to be compressed, with the most commonly
+ used strings preferably put towards the end of the dictionary. Using a
+ dictionary is most useful when the data to be compressed is short and can be
+ predicted with good accuracy; the data can then be compressed better than
+ with the default empty dictionary.
+
+ Depending on the size of the compression data structures selected by
+ deflateInit or deflateInit2, a part of the dictionary may in effect be
+ discarded, for example if the dictionary is larger than the window size
+ provided in deflateInit or deflateInit2. Thus the strings most likely to be
+ useful should be put at the end of the dictionary, not at the front. In
+ addition, the current implementation of deflate will use at most the window
+ size minus 262 bytes of the provided dictionary.
+
+ Upon return of this function, strm->adler is set to the Adler-32 value
+ of the dictionary; the decompressor may later use this value to determine
+ which dictionary has been used by the compressor. (The Adler-32 value
+ applies to the whole dictionary even if only a subset of the dictionary is
+ actually used by the compressor.) If a raw deflate was requested, then the
+ Adler-32 value is not computed and strm->adler is not set.
+
+ deflateSetDictionary returns Z_OK if success, or Z_STREAM_ERROR if a
+ parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is
+ inconsistent (for example if deflate has already been called for this stream
+ or if not at a block boundary for raw deflate). deflateSetDictionary does
+ not perform any compression: this will be done by deflate().
+*/
+
+ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm,
+ Bytef *dictionary,
+ uInt *dictLength));
+/*
+ Returns the sliding dictionary being maintained by deflate. dictLength is
+ set to the number of bytes in the dictionary, and that many bytes are copied
+ to dictionary. dictionary must have enough space, where 32768 bytes is
+ always enough. If deflateGetDictionary() is called with dictionary equal to
+ Z_NULL, then only the dictionary length is returned, and nothing is copied.
+ Similary, if dictLength is Z_NULL, then it is not set.
+
+ deflateGetDictionary() may return a length less than the window size, even
+ when more than the window size in input has been provided. It may return up
+ to 258 bytes less in that case, due to how zlib's implementation of deflate
+ manages the sliding window and lookahead for matches, where matches can be
+ up to 258 bytes long. If the application needs the last window-size bytes of
+ input, then that would need to be saved by the application outside of zlib.
+
+ deflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the
+ stream state is inconsistent.
+*/
+
+ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,
+ z_streamp source));
+/*
+ Sets the destination stream as a complete copy of the source stream.
+
+ This function can be useful when several compression strategies will be
+ tried, for example when there are several ways of pre-processing the input
+ data with a filter. The streams that will be discarded should then be freed
+ by calling deflateEnd. Note that deflateCopy duplicates the internal
+ compression state which can be quite large, so this strategy is slow and can
+ consume lots of memory.
+
+ deflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+ (such as zalloc being Z_NULL). msg is left unchanged in both source and
+ destination.
+*/
+
+ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));
+/*
+ This function is equivalent to deflateEnd followed by deflateInit, but
+ does not free and reallocate the internal compression state. The stream
+ will leave the compression level and any other attributes that may have been
+ set unchanged.
+
+ deflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL).
+*/
+
+ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,
+ int level,
+ int strategy));
+/*
+ Dynamically update the compression level and compression strategy. The
+ interpretation of level and strategy is as in deflateInit2(). This can be
+ used to switch between compression and straight copy of the input data, or
+ to switch to a different kind of input data requiring a different strategy.
+ If the compression approach (which is a function of the level) or the
+ strategy is changed, and if any input has been consumed in a previous
+ deflate() call, then the input available so far is compressed with the old
+ level and strategy using deflate(strm, Z_BLOCK). There are three approaches
+ for the compression levels 0, 1..3, and 4..9 respectively. The new level
+ and strategy will take effect at the next call of deflate().
+
+ If a deflate(strm, Z_BLOCK) is performed by deflateParams(), and it does
+ not have enough output space to complete, then the parameter change will not
+ take effect. In this case, deflateParams() can be called again with the
+ same parameters and more output space to try again.
+
+ In order to assure a change in the parameters on the first try, the
+ deflate stream should be flushed using deflate() with Z_BLOCK or other flush
+ request until strm.avail_out is not zero, before calling deflateParams().
+ Then no more input data should be provided before the deflateParams() call.
+ If this is done, the old level and strategy will be applied to the data
+ compressed before deflateParams(), and the new level and strategy will be
+ applied to the the data compressed after deflateParams().
+
+ deflateParams returns Z_OK on success, Z_STREAM_ERROR if the source stream
+ state was inconsistent or if a parameter was invalid, or Z_BUF_ERROR if
+ there was not enough output space to complete the compression of the
+ available input data before a change in the strategy or approach. Note that
+ in the case of a Z_BUF_ERROR, the parameters are not changed. A return
+ value of Z_BUF_ERROR is not fatal, in which case deflateParams() can be
+ retried with more output space.
+*/
+
+ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm,
+ int good_length,
+ int max_lazy,
+ int nice_length,
+ int max_chain));
+/*
+ Fine tune deflate's internal compression parameters. This should only be
+ used by someone who understands the algorithm used by zlib's deflate for
+ searching for the best matching string, and even then only by the most
+ fanatic optimizer trying to squeeze out the last compressed bit for their
+ specific input data. Read the deflate.c source code for the meaning of the
+ max_lazy, good_length, nice_length, and max_chain parameters.
+
+ deflateTune() can be called after deflateInit() or deflateInit2(), and
+ returns Z_OK on success, or Z_STREAM_ERROR for an invalid deflate stream.
+ */
+
+ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm,
+ uLong sourceLen));
+/*
+ deflateBound() returns an upper bound on the compressed size after
+ deflation of sourceLen bytes. It must be called after deflateInit() or
+ deflateInit2(), and after deflateSetHeader(), if used. This would be used
+ to allocate an output buffer for deflation in a single pass, and so would be
+ called before deflate(). If that first deflate() call is provided the
+ sourceLen input bytes, an output buffer allocated to the size returned by
+ deflateBound(), and the flush value Z_FINISH, then deflate() is guaranteed
+ to return Z_STREAM_END. Note that it is possible for the compressed size to
+ be larger than the value returned by deflateBound() if flush options other
+ than Z_FINISH or Z_NO_FLUSH are used.
+*/
+
+ZEXTERN int ZEXPORT deflatePending OF((z_streamp strm,
+ unsigned *pending,
+ int *bits));
+/*
+ deflatePending() returns the number of bytes and bits of output that have
+ been generated, but not yet provided in the available output. The bytes not
+ provided would be due to the available output space having being consumed.
+ The number of bits of output not provided are between 0 and 7, where they
+ await more bits to join them in order to fill out a full byte. If pending
+ or bits are Z_NULL, then those values are not set.
+
+ deflatePending returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+ */
+
+ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+/*
+ deflatePrime() inserts bits in the deflate output stream. The intent
+ is that this function is used to start off the deflate output with the bits
+ leftover from a previous deflate stream when appending to it. As such, this
+ function can only be used for raw deflate, and must be used before the first
+ deflate() call after a deflateInit2() or deflateReset(). bits must be less
+ than or equal to 16, and that many of the least significant bits of value
+ will be inserted in the output.
+
+ deflatePrime returns Z_OK if success, Z_BUF_ERROR if there was not enough
+ room in the internal buffer to insert the bits, or Z_STREAM_ERROR if the
+ source stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm,
+ gz_headerp head));
+/*
+ deflateSetHeader() provides gzip header information for when a gzip
+ stream is requested by deflateInit2(). deflateSetHeader() may be called
+ after deflateInit2() or deflateReset() and before the first call of
+ deflate(). The text, time, os, extra field, name, and comment information
+ in the provided gz_header structure are written to the gzip header (xflag is
+ ignored -- the extra flags are set according to the compression level). The
+ caller must assure that, if not Z_NULL, name and comment are terminated with
+ a zero byte, and that if extra is not Z_NULL, that extra_len bytes are
+ available there. If hcrc is true, a gzip header crc is included. Note that
+ the current versions of the command-line version of gzip (up through version
+ 1.3.x) do not support header crc's, and will report that it is a "multi-part
+ gzip file" and give up.
+
+ If deflateSetHeader is not used, the default gzip header has text false,
+ the time set to zero, and os set to 255, with no extra, name, or comment
+ fields. The gzip header is returned to the default state by deflateReset().
+
+ deflateSetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateInit2 OF((z_streamp strm,
+ int windowBits));
+
+ This is another version of inflateInit with an extra parameter. The
+ fields next_in, avail_in, zalloc, zfree and opaque must be initialized
+ before by the caller.
+
+ The windowBits parameter is the base two logarithm of the maximum window
+ size (the size of the history buffer). It should be in the range 8..15 for
+ this version of the library. The default value is 15 if inflateInit is used
+ instead. windowBits must be greater than or equal to the windowBits value
+ provided to deflateInit2() while compressing, or it must be equal to 15 if
+ deflateInit2() was not used. If a compressed stream with a larger window
+ size is given as input, inflate() will return with the error code
+ Z_DATA_ERROR instead of trying to allocate a larger window.
+
+ windowBits can also be zero to request that inflate use the window size in
+ the zlib header of the compressed stream.
+
+ windowBits can also be -8..-15 for raw inflate. In this case, -windowBits
+ determines the window size. inflate() will then process raw deflate data,
+ not looking for a zlib or gzip header, not generating a check value, and not
+ looking for any check values for comparison at the end of the stream. This
+ is for use with other formats that use the deflate compressed data format
+ such as zip. Those formats provide their own check values. If a custom
+ format is developed using the raw deflate format for compressed data, it is
+ recommended that a check value such as an Adler-32 or a CRC-32 be applied to
+ the uncompressed data as is done in the zlib, gzip, and zip formats. For
+ most applications, the zlib format should be used as is. Note that comments
+ above on the use in deflateInit2() applies to the magnitude of windowBits.
+
+ windowBits can also be greater than 15 for optional gzip decoding. Add
+ 32 to windowBits to enable zlib and gzip decoding with automatic header
+ detection, or add 16 to decode only the gzip format (the zlib format will
+ return a Z_DATA_ERROR). If a gzip stream is being decoded, strm->adler is a
+ CRC-32 instead of an Adler-32. Unlike the gunzip utility and gzread() (see
+ below), inflate() will not automatically decode concatenated gzip streams.
+ inflate() will return Z_STREAM_END at the end of the gzip stream. The state
+ would need to be reset to continue decoding a subsequent gzip stream.
+
+ inflateInit2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_VERSION_ERROR if the zlib library version is incompatible with the
+ version assumed by the caller, or Z_STREAM_ERROR if the parameters are
+ invalid, such as a null pointer to the structure. msg is set to null if
+ there is no error message. inflateInit2 does not perform any decompression
+ apart from possibly reading the zlib header if present: actual decompression
+ will be done by inflate(). (So next_in and avail_in may be modified, but
+ next_out and avail_out are unused and unchanged.) The current implementation
+ of inflateInit2() does not process any header information -- that is
+ deferred until inflate() is called.
+*/
+
+ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+/*
+ Initializes the decompression dictionary from the given uncompressed byte
+ sequence. This function must be called immediately after a call of inflate,
+ if that call returned Z_NEED_DICT. The dictionary chosen by the compressor
+ can be determined from the Adler-32 value returned by that call of inflate.
+ The compressor and decompressor must use exactly the same dictionary (see
+ deflateSetDictionary). For raw inflate, this function can be called at any
+ time to set the dictionary. If the provided dictionary is smaller than the
+ window and there is already data in the window, then the provided dictionary
+ will amend what's there. The application must insure that the dictionary
+ that was used for compression is provided.
+
+ inflateSetDictionary returns Z_OK if success, Z_STREAM_ERROR if a
+ parameter is invalid (e.g. dictionary being Z_NULL) or the stream state is
+ inconsistent, Z_DATA_ERROR if the given dictionary doesn't match the
+ expected one (incorrect Adler-32 value). inflateSetDictionary does not
+ perform any decompression: this will be done by subsequent calls of
+ inflate().
+*/
+
+ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm,
+ Bytef *dictionary,
+ uInt *dictLength));
+/*
+ Returns the sliding dictionary being maintained by inflate. dictLength is
+ set to the number of bytes in the dictionary, and that many bytes are copied
+ to dictionary. dictionary must have enough space, where 32768 bytes is
+ always enough. If inflateGetDictionary() is called with dictionary equal to
+ Z_NULL, then only the dictionary length is returned, and nothing is copied.
+ Similary, if dictLength is Z_NULL, then it is not set.
+
+ inflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the
+ stream state is inconsistent.
+*/
+
+ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));
+/*
+ Skips invalid compressed data until a possible full flush point (see above
+ for the description of deflate with Z_FULL_FLUSH) can be found, or until all
+ available input is skipped. No output is provided.
+
+ inflateSync searches for a 00 00 FF FF pattern in the compressed data.
+ All full flush points have this pattern, but not all occurrences of this
+ pattern are full flush points.
+
+ inflateSync returns Z_OK if a possible full flush point has been found,
+ Z_BUF_ERROR if no more input was provided, Z_DATA_ERROR if no flush point
+ has been found, or Z_STREAM_ERROR if the stream structure was inconsistent.
+ In the success case, the application may save the current current value of
+ total_in which indicates where valid compressed data was found. In the
+ error case, the application may repeatedly call inflateSync, providing more
+ input each time, until success or end of the input data.
+*/
+
+ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest,
+ z_streamp source));
+/*
+ Sets the destination stream as a complete copy of the source stream.
+
+ This function can be useful when randomly accessing a large stream. The
+ first pass through the stream can periodically record the inflate state,
+ allowing restarting inflate at those points when randomly accessing the
+ stream.
+
+ inflateCopy returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_STREAM_ERROR if the source stream state was inconsistent
+ (such as zalloc being Z_NULL). msg is left unchanged in both source and
+ destination.
+*/
+
+ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));
+/*
+ This function is equivalent to inflateEnd followed by inflateInit,
+ but does not free and reallocate the internal decompression state. The
+ stream will keep attributes that may have been set by inflateInit2.
+
+ inflateReset returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL).
+*/
+
+ZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm,
+ int windowBits));
+/*
+ This function is the same as inflateReset, but it also permits changing
+ the wrap and window size requests. The windowBits parameter is interpreted
+ the same as it is for inflateInit2. If the window size is changed, then the
+ memory allocated for the window is freed, and the window will be reallocated
+ by inflate() if needed.
+
+ inflateReset2 returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent (such as zalloc or state being Z_NULL), or if
+ the windowBits parameter is invalid.
+*/
+
+ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+/*
+ This function inserts bits in the inflate input stream. The intent is
+ that this function is used to start inflating at a bit position in the
+ middle of a byte. The provided bits will be used before any bytes are used
+ from next_in. This function should only be used with raw inflate, and
+ should be used before the first inflate() call after inflateInit2() or
+ inflateReset(). bits must be less than or equal to 16, and that many of the
+ least significant bits of value will be inserted in the input.
+
+ If bits is negative, then the input stream bit buffer is emptied. Then
+ inflatePrime() can be called again to put bits in the buffer. This is used
+ to clear out bits leftover after feeding inflate a block description prior
+ to feeding inflate codes.
+
+ inflatePrime returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+ZEXTERN long ZEXPORT inflateMark OF((z_streamp strm));
+/*
+ This function returns two values, one in the lower 16 bits of the return
+ value, and the other in the remaining upper bits, obtained by shifting the
+ return value down 16 bits. If the upper value is -1 and the lower value is
+ zero, then inflate() is currently decoding information outside of a block.
+ If the upper value is -1 and the lower value is non-zero, then inflate is in
+ the middle of a stored block, with the lower value equaling the number of
+ bytes from the input remaining to copy. If the upper value is not -1, then
+ it is the number of bits back from the current bit position in the input of
+ the code (literal or length/distance pair) currently being processed. In
+ that case the lower value is the number of bytes already emitted for that
+ code.
+
+ A code is being processed if inflate is waiting for more input to complete
+ decoding of the code, or if it has completed decoding but is waiting for
+ more output space to write the literal or match data.
+
+ inflateMark() is used to mark locations in the input data for random
+ access, which may be at bit positions, and to note those cases where the
+ output of a code may span boundaries of random access blocks. The current
+ location in the input stream can be determined from avail_in and data_type
+ as noted in the description for the Z_BLOCK flush parameter for inflate.
+
+ inflateMark returns the value noted above, or -65536 if the provided
+ source stream state was inconsistent.
+*/
+
+ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm,
+ gz_headerp head));
+/*
+ inflateGetHeader() requests that gzip header information be stored in the
+ provided gz_header structure. inflateGetHeader() may be called after
+ inflateInit2() or inflateReset(), and before the first call of inflate().
+ As inflate() processes the gzip stream, head->done is zero until the header
+ is completed, at which time head->done is set to one. If a zlib stream is
+ being decoded, then head->done is set to -1 to indicate that there will be
+ no gzip header information forthcoming. Note that Z_BLOCK or Z_TREES can be
+ used to force inflate() to return immediately after header processing is
+ complete and before any actual data is decompressed.
+
+ The text, time, xflags, and os fields are filled in with the gzip header
+ contents. hcrc is set to true if there is a header CRC. (The header CRC
+ was valid if done is set to one.) If extra is not Z_NULL, then extra_max
+ contains the maximum number of bytes to write to extra. Once done is true,
+ extra_len contains the actual extra field length, and extra contains the
+ extra field, or that field truncated if extra_max is less than extra_len.
+ If name is not Z_NULL, then up to name_max characters are written there,
+ terminated with a zero unless the length is greater than name_max. If
+ comment is not Z_NULL, then up to comm_max characters are written there,
+ terminated with a zero unless the length is greater than comm_max. When any
+ of extra, name, or comment are not Z_NULL and the respective field is not
+ present in the header, then that field is set to Z_NULL to signal its
+ absence. This allows the use of deflateSetHeader() with the returned
+ structure to duplicate the header. However if those fields are set to
+ allocated memory, then the application will need to save those pointers
+ elsewhere so that they can be eventually freed.
+
+ If inflateGetHeader is not used, then the header information is simply
+ discarded. The header is always checked for validity, including the header
+ CRC if present. inflateReset() will reset the process to discard the header
+ information. The application would need to call inflateGetHeader() again to
+ retrieve the header from the next gzip stream.
+
+ inflateGetHeader returns Z_OK if success, or Z_STREAM_ERROR if the source
+ stream state was inconsistent.
+*/
+
+/*
+ZEXTERN int ZEXPORT inflateBackInit OF((z_streamp strm, int windowBits,
+ unsigned char FAR *window));
+
+ Initialize the internal stream state for decompression using inflateBack()
+ calls. The fields zalloc, zfree and opaque in strm must be initialized
+ before the call. If zalloc and zfree are Z_NULL, then the default library-
+ derived memory allocation routines are used. windowBits is the base two
+ logarithm of the window size, in the range 8..15. window is a caller
+ supplied buffer of that size. Except for special applications where it is
+ assured that deflate was used with small window sizes, windowBits must be 15
+ and a 32K byte window must be supplied to be able to decompress general
+ deflate streams.
+
+ See inflateBack() for the usage of these routines.
+
+ inflateBackInit will return Z_OK on success, Z_STREAM_ERROR if any of
+ the parameters are invalid, Z_MEM_ERROR if the internal state could not be
+ allocated, or Z_VERSION_ERROR if the version of the library does not match
+ the version of the header file.
+*/
+
+typedef unsigned (*in_func) OF((void FAR *,
+ z_const unsigned char FAR * FAR *));
+typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned));
+
+ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm,
+ in_func in, void FAR *in_desc,
+ out_func out, void FAR *out_desc));
+/*
+ inflateBack() does a raw inflate with a single call using a call-back
+ interface for input and output. This is potentially more efficient than
+ inflate() for file i/o applications, in that it avoids copying between the
+ output and the sliding window by simply making the window itself the output
+ buffer. inflate() can be faster on modern CPUs when used with large
+ buffers. inflateBack() trusts the application to not change the output
+ buffer passed by the output function, at least until inflateBack() returns.
+
+ inflateBackInit() must be called first to allocate the internal state
+ and to initialize the state with the user-provided window buffer.
+ inflateBack() may then be used multiple times to inflate a complete, raw
+ deflate stream with each call. inflateBackEnd() is then called to free the
+ allocated state.
+
+ A raw deflate stream is one with no zlib or gzip header or trailer.
+ This routine would normally be used in a utility that reads zip or gzip
+ files and writes out uncompressed files. The utility would decode the
+ header and process the trailer on its own, hence this routine expects only
+ the raw deflate stream to decompress. This is different from the default
+ behavior of inflate(), which expects a zlib header and trailer around the
+ deflate stream.
+
+ inflateBack() uses two subroutines supplied by the caller that are then
+ called by inflateBack() for input and output. inflateBack() calls those
+ routines until it reads a complete deflate stream and writes out all of the
+ uncompressed data, or until it encounters an error. The function's
+ parameters and return types are defined above in the in_func and out_func
+ typedefs. inflateBack() will call in(in_desc, &buf) which should return the
+ number of bytes of provided input, and a pointer to that input in buf. If
+ there is no input available, in() must return zero -- buf is ignored in that
+ case -- and inflateBack() will return a buffer error. inflateBack() will
+ call out(out_desc, buf, len) to write the uncompressed data buf[0..len-1].
+ out() should return zero on success, or non-zero on failure. If out()
+ returns non-zero, inflateBack() will return with an error. Neither in() nor
+ out() are permitted to change the contents of the window provided to
+ inflateBackInit(), which is also the buffer that out() uses to write from.
+ The length written by out() will be at most the window size. Any non-zero
+ amount of input may be provided by in().
+
+ For convenience, inflateBack() can be provided input on the first call by
+ setting strm->next_in and strm->avail_in. If that input is exhausted, then
+ in() will be called. Therefore strm->next_in must be initialized before
+ calling inflateBack(). If strm->next_in is Z_NULL, then in() will be called
+ immediately for input. If strm->next_in is not Z_NULL, then strm->avail_in
+ must also be initialized, and then if strm->avail_in is not zero, input will
+ initially be taken from strm->next_in[0 .. strm->avail_in - 1].
+
+ The in_desc and out_desc parameters of inflateBack() is passed as the
+ first parameter of in() and out() respectively when they are called. These
+ descriptors can be optionally used to pass any information that the caller-
+ supplied in() and out() functions need to do their job.
+
+ On return, inflateBack() will set strm->next_in and strm->avail_in to
+ pass back any unused input that was provided by the last in() call. The
+ return values of inflateBack() can be Z_STREAM_END on success, Z_BUF_ERROR
+ if in() or out() returned an error, Z_DATA_ERROR if there was a format error
+ in the deflate stream (in which case strm->msg is set to indicate the nature
+ of the error), or Z_STREAM_ERROR if the stream was not properly initialized.
+ In the case of Z_BUF_ERROR, an input or output error can be distinguished
+ using strm->next_in which will be Z_NULL only if in() returned an error. If
+ strm->next_in is not Z_NULL, then the Z_BUF_ERROR was due to out() returning
+ non-zero. (in() will always be called before out(), so strm->next_in is
+ assured to be defined if out() returns non-zero.) Note that inflateBack()
+ cannot return Z_OK.
+*/
+
+ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm));
+/*
+ All memory allocated by inflateBackInit() is freed.
+
+ inflateBackEnd() returns Z_OK on success, or Z_STREAM_ERROR if the stream
+ state was inconsistent.
+*/
+
+ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void));
+/* Return flags indicating compile-time options.
+
+ Type sizes, two bits each, 00 = 16 bits, 01 = 32, 10 = 64, 11 = other:
+ 1.0: size of uInt
+ 3.2: size of uLong
+ 5.4: size of voidpf (pointer)
+ 7.6: size of z_off_t
+
+ Compiler, assembler, and debug options:
+ 8: ZLIB_DEBUG
+ 9: ASMV or ASMINF -- use ASM code
+ 10: ZLIB_WINAPI -- exported functions use the WINAPI calling convention
+ 11: 0 (reserved)
+
+ One-time table building (smaller code, but not thread-safe if true):
+ 12: BUILDFIXED -- build static block decoding tables when needed
+ 13: DYNAMIC_CRC_TABLE -- build CRC calculation tables when needed
+ 14,15: 0 (reserved)
+
+ Library content (indicates missing functionality):
+ 16: NO_GZCOMPRESS -- gz* functions cannot compress (to avoid linking
+ deflate code when not needed)
+ 17: NO_GZIP -- deflate can't write gzip streams, and inflate can't detect
+ and decode gzip streams (to avoid linking crc code)
+ 18-19: 0 (reserved)
+
+ Operation variations (changes in library functionality):
+ 20: PKZIP_BUG_WORKAROUND -- slightly more permissive inflate
+ 21: FASTEST -- deflate algorithm with only one, lowest compression level
+ 22,23: 0 (reserved)
+
+ The sprintf variant used by gzprintf (zero is best):
+ 24: 0 = vs*, 1 = s* -- 1 means limited to 20 arguments after the format
+ 25: 0 = *nprintf, 1 = *printf -- 1 means gzprintf() not secure!
+ 26: 0 = returns value, 1 = void -- 1 means inferred string length returned
+
+ Remainder:
+ 27-31: 0 (reserved)
+ */
+
+#ifndef Z_SOLO
+
+ /* utility functions */
+
+/*
+ The following utility functions are implemented on top of the basic
+ stream-oriented functions. To simplify the interface, some default options
+ are assumed (compression level and memory usage, standard memory allocation
+ functions). The source code of these utility functions can be modified if
+ you need special options.
+*/
+
+ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+/*
+ Compresses the source buffer into the destination buffer. sourceLen is
+ the byte length of the source buffer. Upon entry, destLen is the total size
+ of the destination buffer, which must be at least the value returned by
+ compressBound(sourceLen). Upon exit, destLen is the actual size of the
+ compressed data. compress() is equivalent to compress2() with a level
+ parameter of Z_DEFAULT_COMPRESSION.
+
+ compress returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_BUF_ERROR if there was not enough room in the output
+ buffer.
+*/
+
+ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen,
+ int level));
+/*
+ Compresses the source buffer into the destination buffer. The level
+ parameter has the same meaning as in deflateInit. sourceLen is the byte
+ length of the source buffer. Upon entry, destLen is the total size of the
+ destination buffer, which must be at least the value returned by
+ compressBound(sourceLen). Upon exit, destLen is the actual size of the
+ compressed data.
+
+ compress2 returns Z_OK if success, Z_MEM_ERROR if there was not enough
+ memory, Z_BUF_ERROR if there was not enough room in the output buffer,
+ Z_STREAM_ERROR if the level parameter is invalid.
+*/
+
+ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
+/*
+ compressBound() returns an upper bound on the compressed size after
+ compress() or compress2() on sourceLen bytes. It would be used before a
+ compress() or compress2() call to allocate the destination buffer.
+*/
+
+ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+/*
+ Decompresses the source buffer into the destination buffer. sourceLen is
+ the byte length of the source buffer. Upon entry, destLen is the total size
+ of the destination buffer, which must be large enough to hold the entire
+ uncompressed data. (The size of the uncompressed data must have been saved
+ previously by the compressor and transmitted to the decompressor by some
+ mechanism outside the scope of this compression library.) Upon exit, destLen
+ is the actual size of the uncompressed data.
+
+ uncompress returns Z_OK if success, Z_MEM_ERROR if there was not
+ enough memory, Z_BUF_ERROR if there was not enough room in the output
+ buffer, or Z_DATA_ERROR if the input data was corrupted or incomplete. In
+ the case where there is not enough room, uncompress() will fill the output
+ buffer with the uncompressed data up to that point.
+*/
+
+ZEXTERN int ZEXPORT uncompress2 OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong *sourceLen));
+/*
+ Same as uncompress, except that sourceLen is a pointer, where the
+ length of the source is *sourceLen. On return, *sourceLen is the number of
+ source bytes consumed.
+*/
+
+ /* gzip file access functions */
+
+/*
+ This library supports reading and writing files in gzip (.gz) format with
+ an interface similar to that of stdio, using the functions that start with
+ "gz". The gzip format is different from the zlib format. gzip is a gzip
+ wrapper, documented in RFC 1952, wrapped around a deflate stream.
+*/
+
+typedef struct gzFile_s *gzFile; /* semi-opaque gzip file descriptor */
+
+/*
+ZEXTERN gzFile ZEXPORT gzopen OF((const char *path, const char *mode));
+
+ Opens a gzip (.gz) file for reading or writing. The mode parameter is as
+ in fopen ("rb" or "wb") but can also include a compression level ("wb9") or
+ a strategy: 'f' for filtered data as in "wb6f", 'h' for Huffman-only
+ compression as in "wb1h", 'R' for run-length encoding as in "wb1R", or 'F'
+ for fixed code compression as in "wb9F". (See the description of
+ deflateInit2 for more information about the strategy parameter.) 'T' will
+ request transparent writing or appending with no compression and not using
+ the gzip format.
+
+ "a" can be used instead of "w" to request that the gzip stream that will
+ be written be appended to the file. "+" will result in an error, since
+ reading and writing to the same gzip file is not supported. The addition of
+ "x" when writing will create the file exclusively, which fails if the file
+ already exists. On systems that support it, the addition of "e" when
+ reading or writing will set the flag to close the file on an execve() call.
+
+ These functions, as well as gzip, will read and decode a sequence of gzip
+ streams in a file. The append function of gzopen() can be used to create
+ such a file. (Also see gzflush() for another way to do this.) When
+ appending, gzopen does not test whether the file begins with a gzip stream,
+ nor does it look for the end of the gzip streams to begin appending. gzopen
+ will simply append a gzip stream to the existing file.
+
+ gzopen can be used to read a file which is not in gzip format; in this
+ case gzread will directly read from the file without decompression. When
+ reading, this will be detected automatically by looking for the magic two-
+ byte gzip header.
+
+ gzopen returns NULL if the file could not be opened, if there was
+ insufficient memory to allocate the gzFile state, or if an invalid mode was
+ specified (an 'r', 'w', or 'a' was not provided, or '+' was provided).
+ errno can be checked to determine if the reason gzopen failed was that the
+ file could not be opened.
+*/
+
+ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode));
+/*
+ gzdopen associates a gzFile with the file descriptor fd. File descriptors
+ are obtained from calls like open, dup, creat, pipe or fileno (if the file
+ has been previously opened with fopen). The mode parameter is as in gzopen.
+
+ The next call of gzclose on the returned gzFile will also close the file
+ descriptor fd, just like fclose(fdopen(fd, mode)) closes the file descriptor
+ fd. If you want to keep fd open, use fd = dup(fd_keep); gz = gzdopen(fd,
+ mode);. The duplicated descriptor should be saved to avoid a leak, since
+ gzdopen does not close fd if it fails. If you are using fileno() to get the
+ file descriptor from a FILE *, then you will have to use dup() to avoid
+ double-close()ing the file descriptor. Both gzclose() and fclose() will
+ close the associated file descriptor, so they need to have different file
+ descriptors.
+
+ gzdopen returns NULL if there was insufficient memory to allocate the
+ gzFile state, if an invalid mode was specified (an 'r', 'w', or 'a' was not
+ provided, or '+' was provided), or if fd is -1. The file descriptor is not
+ used until the next gz* read, write, seek, or close operation, so gzdopen
+ will not detect if fd is invalid (unless fd is -1).
+*/
+
+ZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size));
+/*
+ Set the internal buffer size used by this library's functions. The
+ default buffer size is 8192 bytes. This function must be called after
+ gzopen() or gzdopen(), and before any other calls that read or write the
+ file. The buffer memory allocation is always deferred to the first read or
+ write. Three times that size in buffer space is allocated. A larger buffer
+ size of, for example, 64K or 128K bytes will noticeably increase the speed
+ of decompression (reading).
+
+ The new buffer size also affects the maximum length for gzprintf().
+
+ gzbuffer() returns 0 on success, or -1 on failure, such as being called
+ too late.
+*/
+
+ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));
+/*
+ Dynamically update the compression level or strategy. See the description
+ of deflateInit2 for the meaning of these parameters. Previously provided
+ data is flushed before the parameter change.
+
+ gzsetparams returns Z_OK if success, Z_STREAM_ERROR if the file was not
+ opened for writing, Z_ERRNO if there is an error writing the flushed data,
+ or Z_MEM_ERROR if there is a memory allocation error.
+*/
+
+ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len));
+/*
+ Reads the given number of uncompressed bytes from the compressed file. If
+ the input file is not in gzip format, gzread copies the given number of
+ bytes into the buffer directly from the file.
+
+ After reaching the end of a gzip stream in the input, gzread will continue
+ to read, looking for another gzip stream. Any number of gzip streams may be
+ concatenated in the input file, and will all be decompressed by gzread().
+ If something other than a gzip stream is encountered after a gzip stream,
+ that remaining trailing garbage is ignored (and no error is returned).
+
+ gzread can be used to read a gzip file that is being concurrently written.
+ Upon reaching the end of the input, gzread will return with the available
+ data. If the error code returned by gzerror is Z_OK or Z_BUF_ERROR, then
+ gzclearerr can be used to clear the end of file indicator in order to permit
+ gzread to be tried again. Z_OK indicates that a gzip stream was completed
+ on the last gzread. Z_BUF_ERROR indicates that the input file ended in the
+ middle of a gzip stream. Note that gzread does not return -1 in the event
+ of an incomplete gzip stream. This error is deferred until gzclose(), which
+ will return Z_BUF_ERROR if the last gzread ended in the middle of a gzip
+ stream. Alternatively, gzerror can be used before gzclose to detect this
+ case.
+
+ gzread returns the number of uncompressed bytes actually read, less than
+ len for end of file, or -1 for error. If len is too large to fit in an int,
+ then nothing is read, -1 is returned, and the error state is set to
+ Z_STREAM_ERROR.
+*/
+
+ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems,
+ gzFile file));
+/*
+ Read up to nitems items of size size from file to buf, otherwise operating
+ as gzread() does. This duplicates the interface of stdio's fread(), with
+ size_t request and return types. If the library defines size_t, then
+ z_size_t is identical to size_t. If not, then z_size_t is an unsigned
+ integer type that can contain a pointer.
+
+ gzfread() returns the number of full items read of size size, or zero if
+ the end of the file was reached and a full item could not be read, or if
+ there was an error. gzerror() must be consulted if zero is returned in
+ order to determine if there was an error. If the multiplication of size and
+ nitems overflows, i.e. the product does not fit in a z_size_t, then nothing
+ is read, zero is returned, and the error state is set to Z_STREAM_ERROR.
+
+ In the event that the end of file is reached and only a partial item is
+ available at the end, i.e. the remaining uncompressed data length is not a
+ multiple of size, then the final partial item is nevetheless read into buf
+ and the end-of-file flag is set. The length of the partial item read is not
+ provided, but could be inferred from the result of gztell(). This behavior
+ is the same as the behavior of fread() implementations in common libraries,
+ but it prevents the direct use of gzfread() to read a concurrently written
+ file, reseting and retrying on end-of-file, when size is not 1.
+*/
+
+ZEXTERN int ZEXPORT gzwrite OF((gzFile file,
+ voidpc buf, unsigned len));
+/*
+ Writes the given number of uncompressed bytes into the compressed file.
+ gzwrite returns the number of uncompressed bytes written or 0 in case of
+ error.
+*/
+
+ZEXTERN z_size_t ZEXPORT gzfwrite OF((voidpc buf, z_size_t size,
+ z_size_t nitems, gzFile file));
+/*
+ gzfwrite() writes nitems items of size size from buf to file, duplicating
+ the interface of stdio's fwrite(), with size_t request and return types. If
+ the library defines size_t, then z_size_t is identical to size_t. If not,
+ then z_size_t is an unsigned integer type that can contain a pointer.
+
+ gzfwrite() returns the number of full items written of size size, or zero
+ if there was an error. If the multiplication of size and nitems overflows,
+ i.e. the product does not fit in a z_size_t, then nothing is written, zero
+ is returned, and the error state is set to Z_STREAM_ERROR.
+*/
+
+ZEXTERN int ZEXPORTVA gzprintf Z_ARG((gzFile file, const char *format, ...));
+/*
+ Converts, formats, and writes the arguments to the compressed file under
+ control of the format string, as in fprintf. gzprintf returns the number of
+ uncompressed bytes actually written, or a negative zlib error code in case
+ of error. The number of uncompressed bytes written is limited to 8191, or
+ one less than the buffer size given to gzbuffer(). The caller should assure
+ that this limit is not exceeded. If it is exceeded, then gzprintf() will
+ return an error (0) with nothing written. In this case, there may also be a
+ buffer overflow with unpredictable consequences, which is possible only if
+ zlib was compiled with the insecure functions sprintf() or vsprintf()
+ because the secure snprintf() or vsnprintf() functions were not available.
+ This can be determined using zlibCompileFlags().
+*/
+
+ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));
+/*
+ Writes the given null-terminated string to the compressed file, excluding
+ the terminating null character.
+
+ gzputs returns the number of characters written, or -1 in case of error.
+*/
+
+ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));
+/*
+ Reads bytes from the compressed file until len-1 characters are read, or a
+ newline character is read and transferred to buf, or an end-of-file
+ condition is encountered. If any characters are read or if len == 1, the
+ string is terminated with a null character. If no characters are read due
+ to an end-of-file or len < 1, then the buffer is left untouched.
+
+ gzgets returns buf which is a null-terminated string, or it returns NULL
+ for end-of-file or in case of error. If there was an error, the contents at
+ buf are indeterminate.
+*/
+
+ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c));
+/*
+ Writes c, converted to an unsigned char, into the compressed file. gzputc
+ returns the value that was written, or -1 in case of error.
+*/
+
+ZEXTERN int ZEXPORT gzgetc OF((gzFile file));
+/*
+ Reads one byte from the compressed file. gzgetc returns this byte or -1
+ in case of end of file or error. This is implemented as a macro for speed.
+ As such, it does not do all of the checking the other functions do. I.e.
+ it does not check to see if file is NULL, nor whether the structure file
+ points to has been clobbered or not.
+*/
+
+ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file));
+/*
+ Push one character back onto the stream to be read as the first character
+ on the next read. At least one character of push-back is allowed.
+ gzungetc() returns the character pushed, or -1 on failure. gzungetc() will
+ fail if c is -1, and may fail if a character has been pushed but not read
+ yet. If gzungetc is used immediately after gzopen or gzdopen, at least the
+ output buffer size of pushed characters is allowed. (See gzbuffer above.)
+ The pushed character will be discarded if the stream is repositioned with
+ gzseek() or gzrewind().
+*/
+
+ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush));
+/*
+ Flushes all pending output into the compressed file. The parameter flush
+ is as in the deflate() function. The return value is the zlib error number
+ (see function gzerror below). gzflush is only permitted when writing.
+
+ If the flush parameter is Z_FINISH, the remaining data is written and the
+ gzip stream is completed in the output. If gzwrite() is called again, a new
+ gzip stream will be started in the output. gzread() is able to read such
+ concatenated gzip streams.
+
+ gzflush should be called only when strictly necessary because it will
+ degrade compression if called too often.
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile file,
+ z_off_t offset, int whence));
+
+ Sets the starting position for the next gzread or gzwrite on the given
+ compressed file. The offset represents a number of bytes in the
+ uncompressed data stream. The whence parameter is defined as in lseek(2);
+ the value SEEK_END is not supported.
+
+ If the file is opened for reading, this function is emulated but can be
+ extremely slow. If the file is opened for writing, only forward seeks are
+ supported; gzseek then compresses a sequence of zeroes up to the new
+ starting position.
+
+ gzseek returns the resulting offset location as measured in bytes from
+ the beginning of the uncompressed stream, or -1 in case of error, in
+ particular if the file is opened for writing and the new starting position
+ would be before the current position.
+*/
+
+ZEXTERN int ZEXPORT gzrewind OF((gzFile file));
+/*
+ Rewinds the given file. This function is supported only for reading.
+
+ gzrewind(file) is equivalent to (int)gzseek(file, 0L, SEEK_SET)
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gztell OF((gzFile file));
+
+ Returns the starting position for the next gzread or gzwrite on the given
+ compressed file. This position represents a number of bytes in the
+ uncompressed data stream, and is zero when starting, even if appending or
+ reading a gzip stream from the middle of a file using gzdopen().
+
+ gztell(file) is equivalent to gzseek(file, 0L, SEEK_CUR)
+*/
+
+/*
+ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile file));
+
+ Returns the current offset in the file being read or written. This offset
+ includes the count of bytes that precede the gzip stream, for example when
+ appending or when using gzdopen() for reading. When reading, the offset
+ does not include as yet unused buffered input. This information can be used
+ for a progress indicator. On error, gzoffset() returns -1.
+*/
+
+ZEXTERN int ZEXPORT gzeof OF((gzFile file));
+/*
+ Returns true (1) if the end-of-file indicator has been set while reading,
+ false (0) otherwise. Note that the end-of-file indicator is set only if the
+ read tried to go past the end of the input, but came up short. Therefore,
+ just like feof(), gzeof() may return false even if there is no more data to
+ read, in the event that the last read request was for the exact number of
+ bytes remaining in the input file. This will happen if the input file size
+ is an exact multiple of the buffer size.
+
+ If gzeof() returns true, then the read functions will return no more data,
+ unless the end-of-file indicator is reset by gzclearerr() and the input file
+ has grown since the previous end of file was detected.
+*/
+
+ZEXTERN int ZEXPORT gzdirect OF((gzFile file));
+/*
+ Returns true (1) if file is being copied directly while reading, or false
+ (0) if file is a gzip stream being decompressed.
+
+ If the input file is empty, gzdirect() will return true, since the input
+ does not contain a gzip stream.
+
+ If gzdirect() is used immediately after gzopen() or gzdopen() it will
+ cause buffers to be allocated to allow reading the file to determine if it
+ is a gzip file. Therefore if gzbuffer() is used, it should be called before
+ gzdirect().
+
+ When writing, gzdirect() returns true (1) if transparent writing was
+ requested ("wT" for the gzopen() mode), or false (0) otherwise. (Note:
+ gzdirect() is not needed when writing. Transparent writing must be
+ explicitly requested, so the application already knows the answer. When
+ linking statically, using gzdirect() will include all of the zlib code for
+ gzip file reading and decompression, which may not be desired.)
+*/
+
+ZEXTERN int ZEXPORT gzclose OF((gzFile file));
+/*
+ Flushes all pending output if necessary, closes the compressed file and
+ deallocates the (de)compression state. Note that once file is closed, you
+ cannot call gzerror with file, since its structures have been deallocated.
+ gzclose must not be called more than once on the same file, just as free
+ must not be called more than once on the same allocation.
+
+ gzclose will return Z_STREAM_ERROR if file is not valid, Z_ERRNO on a
+ file operation error, Z_MEM_ERROR if out of memory, Z_BUF_ERROR if the
+ last read ended in the middle of a gzip stream, or Z_OK on success.
+*/
+
+ZEXTERN int ZEXPORT gzclose_r OF((gzFile file));
+ZEXTERN int ZEXPORT gzclose_w OF((gzFile file));
+/*
+ Same as gzclose(), but gzclose_r() is only for use when reading, and
+ gzclose_w() is only for use when writing or appending. The advantage to
+ using these instead of gzclose() is that they avoid linking in zlib
+ compression or decompression code that is not used when only reading or only
+ writing respectively. If gzclose() is used, then both compression and
+ decompression code will be included the application when linking to a static
+ zlib library.
+*/
+
+ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));
+/*
+ Returns the error message for the last error which occurred on the given
+ compressed file. errnum is set to zlib error number. If an error occurred
+ in the file system and not in the compression library, errnum is set to
+ Z_ERRNO and the application may consult errno to get the exact error code.
+
+ The application must not modify the returned string. Future calls to
+ this function may invalidate the previously returned string. If file is
+ closed, then the string previously returned by gzerror will no longer be
+ available.
+
+ gzerror() should be used to distinguish errors from end-of-file for those
+ functions above that do not distinguish those cases in their return values.
+*/
+
+ZEXTERN void ZEXPORT gzclearerr OF((gzFile file));
+/*
+ Clears the error and end-of-file flags for file. This is analogous to the
+ clearerr() function in stdio. This is useful for continuing to read a gzip
+ file that is being written concurrently.
+*/
+
+#endif /* !Z_SOLO */
+
+ /* checksum functions */
+
+/*
+ These functions are not related to compression but are exported
+ anyway because they might be useful in applications using the compression
+ library.
+*/
+
+ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));
+/*
+ Update a running Adler-32 checksum with the bytes buf[0..len-1] and
+ return the updated checksum. If buf is Z_NULL, this function returns the
+ required initial value for the checksum.
+
+ An Adler-32 checksum is almost as reliable as a CRC-32 but can be computed
+ much faster.
+
+ Usage example:
+
+ uLong adler = adler32(0L, Z_NULL, 0);
+
+ while (read_buffer(buffer, length) != EOF) {
+ adler = adler32(adler, buffer, length);
+ }
+ if (adler != original_adler) error();
+*/
+
+ZEXTERN uLong ZEXPORT adler32_z OF((uLong adler, const Bytef *buf,
+ z_size_t len));
+/*
+ Same as adler32(), but with a size_t length.
+*/
+
+/*
+ZEXTERN uLong ZEXPORT adler32_combine OF((uLong adler1, uLong adler2,
+ z_off_t len2));
+
+ Combine two Adler-32 checksums into one. For two sequences of bytes, seq1
+ and seq2 with lengths len1 and len2, Adler-32 checksums were calculated for
+ each, adler1 and adler2. adler32_combine() returns the Adler-32 checksum of
+ seq1 and seq2 concatenated, requiring only adler1, adler2, and len2. Note
+ that the z_off_t type (like off_t) is a signed integer. If len2 is
+ negative, the result has no meaning or utility.
+*/
+
+ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len));
+/*
+ Update a running CRC-32 with the bytes buf[0..len-1] and return the
+ updated CRC-32. If buf is Z_NULL, this function returns the required
+ initial value for the crc. Pre- and post-conditioning (one's complement) is
+ performed within this function so it shouldn't be done by the application.
+
+ Usage example:
+
+ uLong crc = crc32(0L, Z_NULL, 0);
+
+ while (read_buffer(buffer, length) != EOF) {
+ crc = crc32(crc, buffer, length);
+ }
+ if (crc != original_crc) error();
+*/
+
+ZEXTERN uLong ZEXPORT crc32_z OF((uLong adler, const Bytef *buf,
+ z_size_t len));
+/*
+ Same as crc32(), but with a size_t length.
+*/
+
+/*
+ZEXTERN uLong ZEXPORT crc32_combine OF((uLong crc1, uLong crc2, z_off_t len2));
+
+ Combine two CRC-32 check values into one. For two sequences of bytes,
+ seq1 and seq2 with lengths len1 and len2, CRC-32 check values were
+ calculated for each, crc1 and crc2. crc32_combine() returns the CRC-32
+ check value of seq1 and seq2 concatenated, requiring only crc1, crc2, and
+ len2.
+*/
+
+
+ /* various hacks, don't look :) */
+
+/* deflateInit and inflateInit are macros to allow checking the zlib version
+ * and the compiler's view of z_stream:
+ */
+ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method,
+ int windowBits, int memLevel,
+ int strategy, const char *version,
+ int stream_size));
+ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits,
+ unsigned char FAR *window,
+ const char *version,
+ int stream_size));
+#ifdef Z_PREFIX_SET
+# define z_deflateInit(strm, level) \
+ deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_inflateInit(strm) \
+ inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+ (strategy), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_inflateInit2(strm, windowBits) \
+ inflateInit2_((strm), (windowBits), ZLIB_VERSION, \
+ (int)sizeof(z_stream))
+# define z_inflateBackInit(strm, windowBits, window) \
+ inflateBackInit_((strm), (windowBits), (window), \
+ ZLIB_VERSION, (int)sizeof(z_stream))
+#else
+# define deflateInit(strm, level) \
+ deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream))
+# define inflateInit(strm) \
+ inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream))
+# define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+ (strategy), ZLIB_VERSION, (int)sizeof(z_stream))
+# define inflateInit2(strm, windowBits) \
+ inflateInit2_((strm), (windowBits), ZLIB_VERSION, \
+ (int)sizeof(z_stream))
+# define inflateBackInit(strm, windowBits, window) \
+ inflateBackInit_((strm), (windowBits), (window), \
+ ZLIB_VERSION, (int)sizeof(z_stream))
+#endif
+
+#ifndef Z_SOLO
+
+/* gzgetc() macro and its supporting function and exposed data structure. Note
+ * that the real internal state is much larger than the exposed structure.
+ * This abbreviated structure exposes just enough for the gzgetc() macro. The
+ * user should not mess with these exposed elements, since their names or
+ * behavior could change in the future, perhaps even capriciously. They can
+ * only be used by the gzgetc() macro. You have been warned.
+ */
+struct gzFile_s {
+ unsigned have;
+ unsigned char *next;
+ z_off64_t pos;
+};
+ZEXTERN int ZEXPORT gzgetc_ OF((gzFile file)); /* backward compatibility */
+#ifdef Z_PREFIX_SET
+# undef z_gzgetc
+# define z_gzgetc(g) \
+ ((g)->have ? ((g)->have--, (g)->pos++, *((g)->next)++) : (gzgetc)(g))
+#else
+# define gzgetc(g) \
+ ((g)->have ? ((g)->have--, (g)->pos++, *((g)->next)++) : (gzgetc)(g))
+#endif
+
+/* provide 64-bit offset functions if _LARGEFILE64_SOURCE defined, and/or
+ * change the regular functions to 64 bits if _FILE_OFFSET_BITS is 64 (if
+ * both are true, the application gets the *64 functions, and the regular
+ * functions are changed to 64 bits) -- in case these are set on systems
+ * without large file support, _LFS64_LARGEFILE must also be true
+ */
+#ifdef Z_LARGE64
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int));
+ ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t));
+#endif
+
+#if !defined(ZLIB_INTERNAL) && defined(Z_WANT64)
+# ifdef Z_PREFIX_SET
+# define z_gzopen z_gzopen64
+# define z_gzseek z_gzseek64
+# define z_gztell z_gztell64
+# define z_gzoffset z_gzoffset64
+# define z_adler32_combine z_adler32_combine64
+# define z_crc32_combine z_crc32_combine64
+# else
+# define gzopen gzopen64
+# define gzseek gzseek64
+# define gztell gztell64
+# define gzoffset gzoffset64
+# define adler32_combine adler32_combine64
+# define crc32_combine crc32_combine64
+# endif
+# ifndef Z_LARGE64
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));
+# endif
+#else
+ ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t));
+#endif
+
+#else /* Z_SOLO */
+
+ ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t));
+
+#endif /* !Z_SOLO */
+
+/* undocumented functions */
+ZEXTERN const char * ZEXPORT zError OF((int));
+ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp));
+ZEXTERN const z_crc_t FAR * ZEXPORT get_crc_table OF((void));
+ZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int));
+ZEXTERN int ZEXPORT inflateValidate OF((z_streamp, int));
+ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF ((z_streamp));
+ZEXTERN int ZEXPORT inflateResetKeep OF((z_streamp));
+ZEXTERN int ZEXPORT deflateResetKeep OF((z_streamp));
+#if (defined(_WIN32) || defined(__CYGWIN__)) && !defined(Z_SOLO)
+ZEXTERN gzFile ZEXPORT gzopen_w OF((const wchar_t *path,
+ const char *mode));
+#endif
+#if defined(STDC) || defined(Z_HAVE_STDARG_H)
+# ifndef Z_SOLO
+ZEXTERN int ZEXPORTVA gzvprintf Z_ARG((gzFile file,
+ const char *format,
+ va_list va));
+# endif
+#endif
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif /* ZLIB_H */
diff --git a/test/monniaux/zlib-1.2.11/zlib_small.txt b/test/monniaux/zlib-1.2.11/zlib_small.txt
new file mode 100644
index 00000000..2c494200
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/zlib_small.txt
@@ -0,0 +1,539 @@
+
+
+
+#ifndef ZLIB_H
+#define ZLIB_H
+
+#include "zconf.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define ZLIB_VERSION "1.2.11"
+#define ZLIB_VERNUM 0x12b0
+#define ZLIB_VER_MAJOR 1
+#define ZLIB_VER_MINOR 2
+#define ZLIB_VER_REVISION 11
+#define ZLIB_VER_SUBREVISION 0
+
+
+
+
+typedef voidpf (*alloc_func) OF((voidpf opaque, uInt items, uInt size));
+typedef void (*free_func) OF((voidpf opaque, voidpf address));
+
+struct internal_state;
+
+typedef struct z_stream_s {
+ z_const Bytef *next_in;
+
+ uLong total_in;
+
+ uInt avail_out;
+
+
+ z_const char *msg;
+
+
+ alloc_func zalloc;
+
+ voidpf opaque;
+
+ uLong adler;
+
+} z_stream;
+
+typedef z_stream FAR *z_streamp;
+
+
+
+typedef struct gz_header_s {
+ int text;
+
+ int xflags;
+
+ Bytef *extra;
+
+ uInt extra_max;
+
+ uInt name_max;
+
+ uInt comm_max;
+
+ int done;
+
+} gz_header;
+
+typedef gz_header FAR *gz_headerp;
+
+
+
+
+
+
+
+#define Z_OK 0
+#define Z_STREAM_END 1
+#define Z_NEED_DICT 2
+#define Z_ERRNO (-1)
+#define Z_STREAM_ERROR (-2)
+#define Z_DATA_ERROR (-3)
+#define Z_MEM_ERROR (-4)
+#define Z_BUF_ERROR (-5)
+#define Z_VERSION_ERROR (-6)
+
+
+
+#define Z_NO_COMPRESSION 0
+#define Z_BEST_SPEED 1
+#define Z_BEST_COMPRESSION 9
+#define Z_DEFAULT_COMPRESSION (-1)
+
+
+
+#define Z_BINARY 0
+#define Z_TEXT 1
+#define Z_ASCII Z_TEXT
+
+
+#define Z_DEFLATED 8
+
+
+
+#define zlib_version zlibVersion()
+
+
+
+ZEXTERN const char * ZEXPORT zlibVersion OF((void));
+
+
+
+
+
+
+
+ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush));
+
+
+
+
+ZEXTERN int ZEXPORT deflateEnd OF((z_streamp strm));
+
+
+
+
+
+
+
+
+ZEXTERN int ZEXPORT inflate OF((z_streamp strm, int flush));
+
+
+
+
+ZEXTERN int ZEXPORT inflateEnd OF((z_streamp strm));
+
+
+
+
+
+
+
+
+
+
+ZEXTERN int ZEXPORT deflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+
+
+
+ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm,
+ Bytef *dictionary,
+ uInt *dictLength));
+
+
+
+ZEXTERN int ZEXPORT deflateCopy OF((z_streamp dest,
+ z_streamp source));
+
+
+
+ZEXTERN int ZEXPORT deflateReset OF((z_streamp strm));
+
+
+
+ZEXTERN int ZEXPORT deflateParams OF((z_streamp strm,
+ int level,
+ int strategy));
+
+
+
+ZEXTERN int ZEXPORT deflateTune OF((z_streamp strm,
+ int good_length,
+ int max_lazy,
+ int nice_length,
+ int max_chain));
+
+
+
+ZEXTERN uLong ZEXPORT deflateBound OF((z_streamp strm,
+ uLong sourceLen));
+
+
+
+ZEXTERN int ZEXPORT deflatePending OF((z_streamp strm,
+ unsigned *pending,
+ int *bits));
+
+
+
+ZEXTERN int ZEXPORT deflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+
+
+
+ZEXTERN int ZEXPORT deflateSetHeader OF((z_streamp strm,
+ gz_headerp head));
+
+
+
+
+
+
+ZEXTERN int ZEXPORT inflateSetDictionary OF((z_streamp strm,
+ const Bytef *dictionary,
+ uInt dictLength));
+
+
+
+ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm,
+ Bytef *dictionary,
+ uInt *dictLength));
+
+
+
+ZEXTERN int ZEXPORT inflateSync OF((z_streamp strm));
+
+
+
+ZEXTERN int ZEXPORT inflateCopy OF((z_streamp dest,
+ z_streamp source));
+
+
+
+ZEXTERN int ZEXPORT inflateReset OF((z_streamp strm));
+
+
+
+ZEXTERN int ZEXPORT inflateReset2 OF((z_streamp strm,
+ int windowBits));
+
+
+
+ZEXTERN int ZEXPORT inflatePrime OF((z_streamp strm,
+ int bits,
+ int value));
+
+
+
+ZEXTERN long ZEXPORT inflateMark OF((z_streamp strm));
+
+
+
+ZEXTERN int ZEXPORT inflateGetHeader OF((z_streamp strm,
+ gz_headerp head));
+
+
+
+
+
+
+typedef unsigned (*in_func) OF((void FAR *,
+ z_const unsigned char FAR * FAR *));
+typedef int (*out_func) OF((void FAR *, unsigned char FAR *, unsigned));
+
+ZEXTERN int ZEXPORT inflateBack OF((z_streamp strm,
+ in_func in, void FAR *in_desc,
+ out_func out, void FAR *out_desc));
+
+
+
+ZEXTERN int ZEXPORT inflateBackEnd OF((z_streamp strm));
+
+
+
+ZEXTERN uLong ZEXPORT zlibCompileFlags OF((void));
+
+
+
+#ifndef Z_SOLO
+
+
+
+
+ZEXTERN int ZEXPORT compress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+
+
+
+ZEXTERN int ZEXPORT compress2 OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen,
+ int level));
+
+
+
+ZEXTERN uLong ZEXPORT compressBound OF((uLong sourceLen));
+
+
+
+ZEXTERN int ZEXPORT uncompress OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong sourceLen));
+
+
+
+ZEXTERN int ZEXPORT uncompress2 OF((Bytef *dest, uLongf *destLen,
+ const Bytef *source, uLong *sourceLen));
+
+
+
+
+
+
+typedef struct gzFile_s *gzFile;
+
+
+ZEXTERN gzFile ZEXPORT gzdopen OF((int fd, const char *mode));
+
+
+
+ZEXTERN int ZEXPORT gzbuffer OF((gzFile file, unsigned size));
+
+
+
+ZEXTERN int ZEXPORT gzsetparams OF((gzFile file, int level, int strategy));
+
+
+
+ZEXTERN int ZEXPORT gzread OF((gzFile file, voidp buf, unsigned len));
+
+
+
+ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems,
+ gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzwrite OF((gzFile file,
+ voidpc buf, unsigned len));
+
+
+
+ZEXTERN z_size_t ZEXPORT gzfwrite OF((voidpc buf, z_size_t size,
+ z_size_t nitems, gzFile file));
+
+
+
+ZEXTERN int ZEXPORTVA gzprintf Z_ARG((gzFile file, const char *format, ...));
+
+
+
+ZEXTERN int ZEXPORT gzputs OF((gzFile file, const char *s));
+
+
+
+ZEXTERN char * ZEXPORT gzgets OF((gzFile file, char *buf, int len));
+
+
+
+ZEXTERN int ZEXPORT gzputc OF((gzFile file, int c));
+
+
+
+ZEXTERN int ZEXPORT gzgetc OF((gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzungetc OF((int c, gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzflush OF((gzFile file, int flush));
+
+
+
+
+
+
+ZEXTERN int ZEXPORT gzrewind OF((gzFile file));
+
+
+
+
+
+
+
+
+
+ZEXTERN int ZEXPORT gzeof OF((gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzdirect OF((gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzclose OF((gzFile file));
+
+
+
+ZEXTERN int ZEXPORT gzclose_r OF((gzFile file));
+ZEXTERN int ZEXPORT gzclose_w OF((gzFile file));
+
+
+
+ZEXTERN const char * ZEXPORT gzerror OF((gzFile file, int *errnum));
+
+
+
+ZEXTERN void ZEXPORT gzclearerr OF((gzFile file));
+
+
+
+#endif
+
+
+
+
+
+ZEXTERN uLong ZEXPORT adler32 OF((uLong adler, const Bytef *buf, uInt len));
+
+
+
+ZEXTERN uLong ZEXPORT adler32_z OF((uLong adler, const Bytef *buf,
+ z_size_t len));
+
+
+
+
+
+
+ZEXTERN uLong ZEXPORT crc32 OF((uLong crc, const Bytef *buf, uInt len));
+
+
+
+ZEXTERN uLong ZEXPORT crc32_z OF((uLong adler, const Bytef *buf,
+ z_size_t len));
+
+
+
+
+
+
+
+
+
+ZEXTERN int ZEXPORT deflateInit_ OF((z_streamp strm, int level,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateInit_ OF((z_streamp strm,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT deflateInit2_ OF((z_streamp strm, int level, int method,
+ int windowBits, int memLevel,
+ int strategy, const char *version,
+ int stream_size));
+ZEXTERN int ZEXPORT inflateInit2_ OF((z_streamp strm, int windowBits,
+ const char *version, int stream_size));
+ZEXTERN int ZEXPORT inflateBackInit_ OF((z_streamp strm, int windowBits,
+ unsigned char FAR *window,
+ const char *version,
+ int stream_size));
+#ifdef Z_PREFIX_SET
+# define z_deflateInit(strm, level) \
+ deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_inflateInit(strm) \
+ inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+ (strategy), ZLIB_VERSION, (int)sizeof(z_stream))
+# define z_inflateInit2(strm, windowBits) \
+ inflateInit2_((strm), (windowBits), ZLIB_VERSION, \
+ (int)sizeof(z_stream))
+# define z_inflateBackInit(strm, windowBits, window) \
+ inflateBackInit_((strm), (windowBits), (window), \
+ ZLIB_VERSION, (int)sizeof(z_stream))
+#else
+# define deflateInit(strm, level) \
+ deflateInit_((strm), (level), ZLIB_VERSION, (int)sizeof(z_stream))
+# define inflateInit(strm) \
+ inflateInit_((strm), ZLIB_VERSION, (int)sizeof(z_stream))
+# define deflateInit2(strm, level, method, windowBits, memLevel, strategy) \
+ deflateInit2_((strm),(level),(method),(windowBits),(memLevel),\
+ (strategy), ZLIB_VERSION, (int)sizeof(z_stream))
+# define inflateInit2(strm, windowBits) \
+ inflateInit2_((strm), (windowBits), ZLIB_VERSION, \
+ (int)sizeof(z_stream))
+# define inflateBackInit(strm, windowBits, window) \
+ inflateBackInit_((strm), (windowBits), (window), \
+ ZLIB_VERSION, (int)sizeof(z_stream))
+#endif
+
+#ifndef Z_SOLO
+
+
+
+struct gzFile_s {
+ unsigned have;
+ unsigned char *next;
+ z_off64_t pos;
+};
+ZEXTERN int ZEXPORT gzgetc_ OF((gzFile file));
+
+#ifdef Z_LARGE64
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off64_t ZEXPORT gzseek64 OF((gzFile, z_off64_t, int));
+ ZEXTERN z_off64_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off64_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off64_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off64_t));
+#endif
+
+#if !defined(ZLIB_INTERNAL) && defined(Z_WANT64)
+# ifdef Z_PREFIX_SET
+# define z_gzopen z_gzopen64
+# define z_gzseek z_gzseek64
+# define z_gztell z_gztell64
+# define z_gzoffset z_gzoffset64
+# define z_adler32_combine z_adler32_combine64
+# define z_crc32_combine z_crc32_combine64
+# else
+# define gzopen gzopen64
+# define gzseek gzseek64
+# define gztell gztell64
+# define gzoffset gzoffset64
+# define adler32_combine adler32_combine64
+# define crc32_combine crc32_combine64
+# endif
+# ifndef Z_LARGE64
+ ZEXTERN gzFile ZEXPORT gzopen64 OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek64 OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell64 OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset64 OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));
+# endif
+#else
+ ZEXTERN gzFile ZEXPORT gzopen OF((const char *, const char *));
+ ZEXTERN z_off_t ZEXPORT gzseek OF((gzFile, z_off_t, int));
+ ZEXTERN z_off_t ZEXPORT gztell OF((gzFile));
+ ZEXTERN z_off_t ZEXPORT gzoffset OF((gzFile));
+ ZEXTERN uLong ZEXPORT adler32_combine OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine OF((uLong, uLong, z_off_t));
+#endif
+
+#else
+
+
+
+
diff --git a/test/monniaux/zlib-1.2.11/zutil.c b/test/monniaux/zlib-1.2.11/zutil.c
new file mode 100644
index 00000000..a76c6b0c
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/zutil.c
@@ -0,0 +1,325 @@
+/* zutil.c -- target dependent utility functions for the compression library
+ * Copyright (C) 1995-2017 Jean-loup Gailly
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* @(#) $Id$ */
+
+#include "zutil.h"
+#ifndef Z_SOLO
+# include "gzguts.h"
+#endif
+
+z_const char * const z_errmsg[10] = {
+ (z_const char *)"need dictionary", /* Z_NEED_DICT 2 */
+ (z_const char *)"stream end", /* Z_STREAM_END 1 */
+ (z_const char *)"", /* Z_OK 0 */
+ (z_const char *)"file error", /* Z_ERRNO (-1) */
+ (z_const char *)"stream error", /* Z_STREAM_ERROR (-2) */
+ (z_const char *)"data error", /* Z_DATA_ERROR (-3) */
+ (z_const char *)"insufficient memory", /* Z_MEM_ERROR (-4) */
+ (z_const char *)"buffer error", /* Z_BUF_ERROR (-5) */
+ (z_const char *)"incompatible version",/* Z_VERSION_ERROR (-6) */
+ (z_const char *)""
+};
+
+
+const char * ZEXPORT zlibVersion()
+{
+ return ZLIB_VERSION;
+}
+
+uLong ZEXPORT zlibCompileFlags()
+{
+ uLong flags;
+
+ flags = 0;
+ switch ((int)(sizeof(uInt))) {
+ case 2: break;
+ case 4: flags += 1; break;
+ case 8: flags += 2; break;
+ default: flags += 3;
+ }
+ switch ((int)(sizeof(uLong))) {
+ case 2: break;
+ case 4: flags += 1 << 2; break;
+ case 8: flags += 2 << 2; break;
+ default: flags += 3 << 2;
+ }
+ switch ((int)(sizeof(voidpf))) {
+ case 2: break;
+ case 4: flags += 1 << 4; break;
+ case 8: flags += 2 << 4; break;
+ default: flags += 3 << 4;
+ }
+ switch ((int)(sizeof(z_off_t))) {
+ case 2: break;
+ case 4: flags += 1 << 6; break;
+ case 8: flags += 2 << 6; break;
+ default: flags += 3 << 6;
+ }
+#ifdef ZLIB_DEBUG
+ flags += 1 << 8;
+#endif
+#if defined(ASMV) || defined(ASMINF)
+ flags += 1 << 9;
+#endif
+#ifdef ZLIB_WINAPI
+ flags += 1 << 10;
+#endif
+#ifdef BUILDFIXED
+ flags += 1 << 12;
+#endif
+#ifdef DYNAMIC_CRC_TABLE
+ flags += 1 << 13;
+#endif
+#ifdef NO_GZCOMPRESS
+ flags += 1L << 16;
+#endif
+#ifdef NO_GZIP
+ flags += 1L << 17;
+#endif
+#ifdef PKZIP_BUG_WORKAROUND
+ flags += 1L << 20;
+#endif
+#ifdef FASTEST
+ flags += 1L << 21;
+#endif
+#if defined(STDC) || defined(Z_HAVE_STDARG_H)
+# ifdef NO_vsnprintf
+ flags += 1L << 25;
+# ifdef HAS_vsprintf_void
+ flags += 1L << 26;
+# endif
+# else
+# ifdef HAS_vsnprintf_void
+ flags += 1L << 26;
+# endif
+# endif
+#else
+ flags += 1L << 24;
+# ifdef NO_snprintf
+ flags += 1L << 25;
+# ifdef HAS_sprintf_void
+ flags += 1L << 26;
+# endif
+# else
+# ifdef HAS_snprintf_void
+ flags += 1L << 26;
+# endif
+# endif
+#endif
+ return flags;
+}
+
+#ifdef ZLIB_DEBUG
+#include <stdlib.h>
+# ifndef verbose
+# define verbose 0
+# endif
+int ZLIB_INTERNAL z_verbose = verbose;
+
+void ZLIB_INTERNAL z_error (m)
+ char *m;
+{
+ fprintf(stderr, "%s\n", m);
+ exit(1);
+}
+#endif
+
+/* exported to allow conversion of error code to string for compress() and
+ * uncompress()
+ */
+const char * ZEXPORT zError(err)
+ int err;
+{
+ return ERR_MSG(err);
+}
+
+#if defined(_WIN32_WCE)
+ /* The Microsoft C Run-Time Library for Windows CE doesn't have
+ * errno. We define it as a global variable to simplify porting.
+ * Its value is always 0 and should not be used.
+ */
+ int errno = 0;
+#endif
+
+#ifndef HAVE_MEMCPY
+
+void ZLIB_INTERNAL zmemcpy(dest, source, len)
+ Bytef* dest;
+ const Bytef* source;
+ uInt len;
+{
+ if (len == 0) return;
+ do {
+ *dest++ = *source++; /* ??? to be unrolled */
+ } while (--len != 0);
+}
+
+int ZLIB_INTERNAL zmemcmp(s1, s2, len)
+ const Bytef* s1;
+ const Bytef* s2;
+ uInt len;
+{
+ uInt j;
+
+ for (j = 0; j < len; j++) {
+ if (s1[j] != s2[j]) return 2*(s1[j] > s2[j])-1;
+ }
+ return 0;
+}
+
+void ZLIB_INTERNAL zmemzero(dest, len)
+ Bytef* dest;
+ uInt len;
+{
+ if (len == 0) return;
+ do {
+ *dest++ = 0; /* ??? to be unrolled */
+ } while (--len != 0);
+}
+#endif
+
+#ifndef Z_SOLO
+
+#ifdef SYS16BIT
+
+#ifdef __TURBOC__
+/* Turbo C in 16-bit mode */
+
+# define MY_ZCALLOC
+
+/* Turbo C malloc() does not allow dynamic allocation of 64K bytes
+ * and farmalloc(64K) returns a pointer with an offset of 8, so we
+ * must fix the pointer. Warning: the pointer must be put back to its
+ * original form in order to free it, use zcfree().
+ */
+
+#define MAX_PTR 10
+/* 10*64K = 640K */
+
+local int next_ptr = 0;
+
+typedef struct ptr_table_s {
+ voidpf org_ptr;
+ voidpf new_ptr;
+} ptr_table;
+
+local ptr_table table[MAX_PTR];
+/* This table is used to remember the original form of pointers
+ * to large buffers (64K). Such pointers are normalized with a zero offset.
+ * Since MSDOS is not a preemptive multitasking OS, this table is not
+ * protected from concurrent access. This hack doesn't work anyway on
+ * a protected system like OS/2. Use Microsoft C instead.
+ */
+
+voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, unsigned items, unsigned size)
+{
+ voidpf buf;
+ ulg bsize = (ulg)items*size;
+
+ (void)opaque;
+
+ /* If we allocate less than 65520 bytes, we assume that farmalloc
+ * will return a usable pointer which doesn't have to be normalized.
+ */
+ if (bsize < 65520L) {
+ buf = farmalloc(bsize);
+ if (*(ush*)&buf != 0) return buf;
+ } else {
+ buf = farmalloc(bsize + 16L);
+ }
+ if (buf == NULL || next_ptr >= MAX_PTR) return NULL;
+ table[next_ptr].org_ptr = buf;
+
+ /* Normalize the pointer to seg:0 */
+ *((ush*)&buf+1) += ((ush)((uch*)buf-0) + 15) >> 4;
+ *(ush*)&buf = 0;
+ table[next_ptr++].new_ptr = buf;
+ return buf;
+}
+
+void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr)
+{
+ int n;
+
+ (void)opaque;
+
+ if (*(ush*)&ptr != 0) { /* object < 64K */
+ farfree(ptr);
+ return;
+ }
+ /* Find the original pointer */
+ for (n = 0; n < next_ptr; n++) {
+ if (ptr != table[n].new_ptr) continue;
+
+ farfree(table[n].org_ptr);
+ while (++n < next_ptr) {
+ table[n-1] = table[n];
+ }
+ next_ptr--;
+ return;
+ }
+ Assert(0, "zcfree: ptr not found");
+}
+
+#endif /* __TURBOC__ */
+
+
+#ifdef M_I86
+/* Microsoft C in 16-bit mode */
+
+# define MY_ZCALLOC
+
+#if (!defined(_MSC_VER) || (_MSC_VER <= 600))
+# define _halloc halloc
+# define _hfree hfree
+#endif
+
+voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, uInt items, uInt size)
+{
+ (void)opaque;
+ return _halloc((long)items, size);
+}
+
+void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr)
+{
+ (void)opaque;
+ _hfree(ptr);
+}
+
+#endif /* M_I86 */
+
+#endif /* SYS16BIT */
+
+
+#ifndef MY_ZCALLOC /* Any system without a special alloc function */
+
+#ifndef STDC
+extern voidp malloc OF((uInt size));
+extern voidp calloc OF((uInt items, uInt size));
+extern void free OF((voidpf ptr));
+#endif
+
+voidpf ZLIB_INTERNAL zcalloc (opaque, items, size)
+ voidpf opaque;
+ unsigned items;
+ unsigned size;
+{
+ (void)opaque;
+ return sizeof(uInt) > 2 ? (voidpf)malloc(items * size) :
+ (voidpf)calloc(items, size);
+}
+
+void ZLIB_INTERNAL zcfree (opaque, ptr)
+ voidpf opaque;
+ voidpf ptr;
+{
+ (void)opaque;
+ free(ptr);
+}
+
+#endif /* MY_ZCALLOC */
+
+#endif /* !Z_SOLO */
diff --git a/test/monniaux/zlib-1.2.11/zutil.h b/test/monniaux/zlib-1.2.11/zutil.h
new file mode 100644
index 00000000..b079ea6a
--- /dev/null
+++ b/test/monniaux/zlib-1.2.11/zutil.h
@@ -0,0 +1,271 @@
+/* zutil.h -- internal interface and configuration of the compression library
+ * Copyright (C) 1995-2016 Jean-loup Gailly, Mark Adler
+ * For conditions of distribution and use, see copyright notice in zlib.h
+ */
+
+/* WARNING: this file should *not* be used by applications. It is
+ part of the implementation of the compression library and is
+ subject to change. Applications should only use zlib.h.
+ */
+
+/* @(#) $Id$ */
+
+#ifndef ZUTIL_H
+#define ZUTIL_H
+
+#ifdef HAVE_HIDDEN
+# define ZLIB_INTERNAL __attribute__((visibility ("hidden")))
+#else
+# define ZLIB_INTERNAL
+#endif
+
+#include "zlib.h"
+
+#if defined(STDC) && !defined(Z_SOLO)
+# if !(defined(_WIN32_WCE) && defined(_MSC_VER))
+# include <stddef.h>
+# endif
+# include <string.h>
+# include <stdlib.h>
+#endif
+
+#ifdef Z_SOLO
+ typedef long ptrdiff_t; /* guess -- will be caught if guess is wrong */
+#endif
+
+#ifndef local
+# define local static
+#endif
+/* since "static" is used to mean two completely different things in C, we
+ define "local" for the non-static meaning of "static", for readability
+ (compile with -Dlocal if your debugger can't find static symbols) */
+
+typedef unsigned char uch;
+typedef uch FAR uchf;
+typedef unsigned short ush;
+typedef ush FAR ushf;
+typedef unsigned long ulg;
+
+extern z_const char * const z_errmsg[10]; /* indexed by 2-zlib_error */
+/* (size given to avoid silly warnings with Visual C++) */
+
+#define ERR_MSG(err) z_errmsg[Z_NEED_DICT-(err)]
+
+#define ERR_RETURN(strm,err) \
+ return (strm->msg = ERR_MSG(err), (err))
+/* To be used only when the state is known to be valid */
+
+ /* common constants */
+
+#ifndef DEF_WBITS
+# define DEF_WBITS MAX_WBITS
+#endif
+/* default windowBits for decompression. MAX_WBITS is for compression only */
+
+#if MAX_MEM_LEVEL >= 8
+# define DEF_MEM_LEVEL 8
+#else
+# define DEF_MEM_LEVEL MAX_MEM_LEVEL
+#endif
+/* default memLevel */
+
+#define STORED_BLOCK 0
+#define STATIC_TREES 1
+#define DYN_TREES 2
+/* The three kinds of block type */
+
+#define MIN_MATCH 3
+#define MAX_MATCH 258
+/* The minimum and maximum match lengths */
+
+#define PRESET_DICT 0x20 /* preset dictionary flag in zlib header */
+
+ /* target dependencies */
+
+#if defined(MSDOS) || (defined(WINDOWS) && !defined(WIN32))
+# define OS_CODE 0x00
+# ifndef Z_SOLO
+# if defined(__TURBOC__) || defined(__BORLANDC__)
+# if (__STDC__ == 1) && (defined(__LARGE__) || defined(__COMPACT__))
+ /* Allow compilation with ANSI keywords only enabled */
+ void _Cdecl farfree( void *block );
+ void *_Cdecl farmalloc( unsigned long nbytes );
+# else
+# include <alloc.h>
+# endif
+# else /* MSC or DJGPP */
+# include <malloc.h>
+# endif
+# endif
+#endif
+
+#ifdef AMIGA
+# define OS_CODE 1
+#endif
+
+#if defined(VAXC) || defined(VMS)
+# define OS_CODE 2
+# define F_OPEN(name, mode) \
+ fopen((name), (mode), "mbc=60", "ctx=stm", "rfm=fix", "mrs=512")
+#endif
+
+#ifdef __370__
+# if __TARGET_LIB__ < 0x20000000
+# define OS_CODE 4
+# elif __TARGET_LIB__ < 0x40000000
+# define OS_CODE 11
+# else
+# define OS_CODE 8
+# endif
+#endif
+
+#if defined(ATARI) || defined(atarist)
+# define OS_CODE 5
+#endif
+
+#ifdef OS2
+# define OS_CODE 6
+# if defined(M_I86) && !defined(Z_SOLO)
+# include <malloc.h>
+# endif
+#endif
+
+#if defined(MACOS) || defined(TARGET_OS_MAC)
+# define OS_CODE 7
+# ifndef Z_SOLO
+# if defined(__MWERKS__) && __dest_os != __be_os && __dest_os != __win32_os
+# include <unix.h> /* for fdopen */
+# else
+# ifndef fdopen
+# define fdopen(fd,mode) NULL /* No fdopen() */
+# endif
+# endif
+# endif
+#endif
+
+#ifdef __acorn
+# define OS_CODE 13
+#endif
+
+#if defined(WIN32) && !defined(__CYGWIN__)
+# define OS_CODE 10
+#endif
+
+#ifdef _BEOS_
+# define OS_CODE 16
+#endif
+
+#ifdef __TOS_OS400__
+# define OS_CODE 18
+#endif
+
+#ifdef __APPLE__
+# define OS_CODE 19
+#endif
+
+#if defined(_BEOS_) || defined(RISCOS)
+# define fdopen(fd,mode) NULL /* No fdopen() */
+#endif
+
+#if (defined(_MSC_VER) && (_MSC_VER > 600)) && !defined __INTERIX
+# if defined(_WIN32_WCE)
+# define fdopen(fd,mode) NULL /* No fdopen() */
+# ifndef _PTRDIFF_T_DEFINED
+ typedef int ptrdiff_t;
+# define _PTRDIFF_T_DEFINED
+# endif
+# else
+# define fdopen(fd,type) _fdopen(fd,type)
+# endif
+#endif
+
+#if defined(__BORLANDC__) && !defined(MSDOS)
+ #pragma warn -8004
+ #pragma warn -8008
+ #pragma warn -8066
+#endif
+
+/* provide prototypes for these when building zlib without LFS */
+#if !defined(_WIN32) && \
+ (!defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0)
+ ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t));
+ ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t));
+#endif
+
+ /* common defaults */
+
+#ifndef OS_CODE
+# define OS_CODE 3 /* assume Unix */
+#endif
+
+#ifndef F_OPEN
+# define F_OPEN(name, mode) fopen((name), (mode))
+#endif
+
+ /* functions */
+
+#if defined(pyr) || defined(Z_SOLO)
+# define NO_MEMCPY
+#endif
+#if defined(SMALL_MEDIUM) && !defined(_MSC_VER) && !defined(__SC__)
+ /* Use our own functions for small and medium model with MSC <= 5.0.
+ * You may have to use the same strategy for Borland C (untested).
+ * The __SC__ check is for Symantec.
+ */
+# define NO_MEMCPY
+#endif
+#if defined(STDC) && !defined(HAVE_MEMCPY) && !defined(NO_MEMCPY)
+# define HAVE_MEMCPY
+#endif
+#ifdef HAVE_MEMCPY
+# ifdef SMALL_MEDIUM /* MSDOS small or medium model */
+# define zmemcpy _fmemcpy
+# define zmemcmp _fmemcmp
+# define zmemzero(dest, len) _fmemset(dest, 0, len)
+# else
+# define zmemcpy memcpy
+# define zmemcmp memcmp
+# define zmemzero(dest, len) memset(dest, 0, len)
+# endif
+#else
+ void ZLIB_INTERNAL zmemcpy OF((Bytef* dest, const Bytef* source, uInt len));
+ int ZLIB_INTERNAL zmemcmp OF((const Bytef* s1, const Bytef* s2, uInt len));
+ void ZLIB_INTERNAL zmemzero OF((Bytef* dest, uInt len));
+#endif
+
+/* Diagnostic functions */
+#ifdef ZLIB_DEBUG
+# include <stdio.h>
+ extern int ZLIB_INTERNAL z_verbose;
+ extern void ZLIB_INTERNAL z_error OF((char *m));
+# define Assert(cond,msg) {if(!(cond)) z_error(msg);}
+# define Trace(x) {if (z_verbose>=0) fprintf x ;}
+# define Tracev(x) {if (z_verbose>0) fprintf x ;}
+# define Tracevv(x) {if (z_verbose>1) fprintf x ;}
+# define Tracec(c,x) {if (z_verbose>0 && (c)) fprintf x ;}
+# define Tracecv(c,x) {if (z_verbose>1 && (c)) fprintf x ;}
+#else
+# define Assert(cond,msg)
+# define Trace(x)
+# define Tracev(x)
+# define Tracevv(x)
+# define Tracec(c,x)
+# define Tracecv(c,x)
+#endif
+
+#ifndef Z_SOLO
+ voidpf ZLIB_INTERNAL zcalloc OF((voidpf opaque, unsigned items,
+ unsigned size));
+ void ZLIB_INTERNAL zcfree OF((voidpf opaque, voidpf ptr));
+#endif
+
+#define ZALLOC(strm, items, size) \
+ (*((strm)->zalloc))((strm)->opaque, (items), (size))
+#define ZFREE(strm, addr) (*((strm)->zfree))((strm)->opaque, (voidpf)(addr))
+#define TRY_FREE(s, p) {if (p) ZFREE(s, p);}
+
+/* Reverse the bytes in a 32-bit value */
+#define ZSWAP32(q) ((((q) >> 24) & 0xff) + (((q) >> 8) & 0xff00) + \
+ (((q) & 0xff00) << 8) + (((q) & 0xff) << 24))
+
+#endif /* ZUTIL_H */
diff --git a/test/mppa/asm_coverage b/test/mppa/asm_coverage
deleted file mode 160000
-Subproject a9c62b61552a9e9fd0ebf43df5ee0d5b88bb094
diff --git a/test/mppa/check.sh b/test/mppa/check.sh
deleted file mode 100755
index f25c3e31..00000000
--- a/test/mppa/check.sh
+++ /dev/null
@@ -1,6 +0,0 @@
-#!/bin/bash
-# Tests the execution of the binaries produced by CompCert
-
-source do_test.sh
-
-do_test check $1
diff --git a/test/mppa/coverage.sh b/test/mppa/coverage.sh
index 0a057ff9..42ed4182 100644..100755
--- a/test/mppa/coverage.sh
+++ b/test/mppa/coverage.sh
@@ -1,17 +1,24 @@
-asmdir=$1
+#!/bin/bash
+
+printer=../../mppa_k1c/TargetPrinter.ml
+asmdir=instr/asm/
to_cover_raw=/tmp/to_cover_raw
to_cover=/tmp/to_cover
covered_raw=/tmp/covered_raw
covered=/tmp/covered
-sed -n "s/^.*fprintf oc \" \(.*\) .*/\1/p" ../../mppa_k1c/TargetPrinter.ml > $to_cover_raw
-sed -n "s/^.*fprintf oc \" \(.*\)\\n.*/\1/p" ../../mppa_k1c/TargetPrinter.ml >> $to_cover_raw
-python2.7 coverage_helper.py $to_cover_raw > $to_cover
+# Stop at any error
+set -e
+# Pipes do not mask errors
+set -o pipefail
+
+sed -n "s/^.*fprintf\s\+oc\s*\"\s*\([a-z][^[:space:]]*\)\s.*/\1/p" $printer > $to_cover_raw
+python2.7 coverage_helper.py $to_cover_raw | sort -u > $to_cover
rm -f $covered_raw
-for asm in $(ls $asmdir/*.s); do
- bash asm_coverage/asm-coverage.sh $asm >> $covered_raw
+for asm in $(ls $asmdir/*.ccomp.s); do
+ grep -v ":" $asm | sed -n "s/^\s*\([a-z][a-z0-9.]*\).*/\1/p" | sort -u >> $covered_raw
done
-python2.7 coverage_helper.py $covered_raw > $covered
+python2.7 coverage_helper.py $covered_raw | sort -u > $covered
vimdiff $to_cover $covered
diff --git a/test/mppa/coverage_helper.py b/test/mppa/coverage_helper.py
index b086aca9..e5b1907c 100644
--- a/test/mppa/coverage_helper.py
+++ b/test/mppa/coverage_helper.py
@@ -1,35 +1,45 @@
import fileinput
+import sys
-occurs = {}
+all_loads_stores = "lbs lbz lhz lo lq ld lhs lws sb sd sh so sq sw".split(" ")
+
+all_bconds = "wnez weqz wltz wgez wlez wgtz dnez deqz dltz dgez dlez dgtz".split(" ")
+
+all_iconds = "ne eq lt ge le gt ltu geu leu gtu".split(" ")
+
+all_fconds = "one ueq oeq une olt uge oge ult".split(" ")
+
+replaces_a = [(["cb.", "cmoved."], all_bconds),
+ (["compd.", "compw."], all_iconds),
+ (["fcompd.", "fcompw."], all_fconds),
+ (all_loads_stores, [".xs", ""])]
+replaces_dd = [(["addx", "sbfx"], ["2d", "4d", "8d", "16d"])]
+replaces_dw = [(["addx", "sbfx"], ["2w", "4w", "8w", "16w"])]
+
+macros_binds = {"%a": replaces_a, "%dd": replaces_dd, "%dw": replaces_dw}
+
+def expand_macro(fullinst, macro, replaceTable):
+ inst = fullinst.replace(macro, "")
+ for (searchlist, mods) in replaceTable:
+ if inst in searchlist:
+ return [fullinst.replace(macro, mod) for mod in mods]
+ raise NameError
+
+insts = []
for line in fileinput.input():
- line_noc = line.replace('\n', '')
- if line_noc not in occurs:
- occurs[line_noc] = 0
- occurs[line_noc] += 1
-
-# HACK: Removing all the instructions with "%a", replacing them with all their variations
-# Also removing all instructions starting with '.'
-pruned_occurs = dict(occurs)
-for inst in occurs:
- if inst[0] == '.':
- del pruned_occurs[inst]
- if "%a" not in inst:
- continue
- inst_no_a = inst.replace(".%a", "")
- if inst_no_a in ("compw", "compd"):
- del pruned_occurs[inst]
- for mod in ("ne", "eq", "lt", "gt", "le", "ge", "ltu", "leu", "geu",
- "gtu", "all", "any", "nall", "none"):
- pruned_occurs[inst_no_a + "." + mod] = 1
- elif inst_no_a in ("cb"):
- del pruned_occurs[inst]
- for mod in ("wnez", "weqz", "wltz", "wgez", "wlez", "wgtz", "deqz", "dnez",
- "dltz", "dgez", "dlez", "dgtz"):
- pruned_occurs[inst_no_a + "." + mod] = 1
- else:
- assert False, "Found instruction with %a: " + inst
-occurs = pruned_occurs
-
-for inst in sorted(occurs):
+ fullinst = line[:-1]
+ try:
+ for macro in macros_binds:
+ if macro in fullinst:
+ insts.extend(expand_macro(fullinst, macro, macros_binds[macro]))
+ break
+ else:
+ insts.append(fullinst)
+ except NameError:
+ print >> sys.stderr, fullinst + " could not be found any match for macro " + macro
+ sys.exit(1)
+
+for inst in insts:
print inst
+occurs = {}
diff --git a/test/mppa/hardcheck.sh b/test/mppa/hardcheck.sh
new file mode 100755
index 00000000..82b63182
--- /dev/null
+++ b/test/mppa/hardcheck.sh
@@ -0,0 +1,6 @@
+#!/bin/bash
+# Tests the execution of the binaries produced by CompCert, in hardware
+
+source do_test.sh
+
+do_test hardcheck
diff --git a/test/mppa/hardtest.sh b/test/mppa/hardtest.sh
new file mode 100755
index 00000000..09511da6
--- /dev/null
+++ b/test/mppa/hardtest.sh
@@ -0,0 +1,6 @@
+#!/bin/bash
+# Tests the validity of the tests, in hardware
+
+source do_test.sh
+
+do_test hardtest
diff --git a/test/mppa/instr/Makefile b/test/mppa/instr/Makefile
index ea86114c..37f7d0ab 100644
--- a/test/mppa/instr/Makefile
+++ b/test/mppa/instr/Makefile
@@ -1,11 +1,15 @@
-K1CC ?= k1-mbr-gcc
+SHELL := /bin/bash
+
+K1CC ?= k1-cos-gcc
CC ?= gcc
CCOMP ?= ccomp
OPTIM ?= -O2
CFLAGS ?= $(OPTIM)
+CCOMPFLAGS ?= $(CFLAGS)
SIMU ?= k1-mppa
TIMEOUT ?= --signal=SIGTERM 120s
DIFF ?= python2.7 floatcmp.py -reltol .00001
+HARDRUN ?= k1-jtag-runner
DIR=./
SRCDIR=$(DIR)
@@ -27,10 +31,11 @@ SIMUPATH=$(shell which $(SIMU))
TESTNAMES?=$(notdir $(subst .c,,$(wildcard $(DIR)/*.c)))
X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES)))
-GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES)))
-CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES)))
+GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES)))
+CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES)))
+GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES)))
+CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES)))
-OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT)
BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\
$(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\
$(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))
@@ -43,15 +48,52 @@ all: $(BIN)
GREEN=\033[0;32m
RED=\033[0;31m
+YELLOW=\033[0;33m
NC=\033[0m
+.PHONY:
+test: simutest
+
+.PHONY:
+check: simucheck
+
.PHONY:
-test: $(X86_GCC_OUT) $(GCC_OUT)
+simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT)
@echo "Comparing x86 gcc output to k1 gcc.."
+ for test in $(TESTNAMES); do\
+ x86out=$(OUTDIR)/$$test.x86-gcc.out;\
+ gccout=$(OUTDIR)/$$test.gcc.simu.out;\
+ if grep "__K1C__" -q $$test.c; then\
+ printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\n";\
+ elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\
+ >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\
+ fi;\
+ done
+
+.PHONY:
+simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT)
+ @echo "Comparing k1 gcc output to ccomp.."
@for test in $(TESTNAMES); do\
+ gccout=$(OUTDIR)/$$test.gcc.simu.out;\
+ ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\
+ if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\
+ >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\
+ fi;\
+ done
+
+.PHONY:
+hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT)
+ @echo "Comparing x86 gcc output to k1 gcc.."
+ for test in $(TESTNAMES); do\
x86out=$(OUTDIR)/$$test.x86-gcc.out;\
- gccout=$(OUTDIR)/$$test.gcc.out;\
- if $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\
+ gccout=$(OUTDIR)/$$test.gcc.hard.out;\
+ if grep "__K1C__" -q $$test.c; then\
+ printf "$(YELLOW)UNTESTED: $$test.c contains an \`#ifdef __K1C__\`\n";\
+ elif $(DIFF) $$x86out $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\
>&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\
else\
printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\
@@ -59,11 +101,11 @@ test: $(X86_GCC_OUT) $(GCC_OUT)
done
.PHONY:
-check: $(GCC_OUT) $(CCOMP_OUT)
+hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT)
@echo "Comparing k1 gcc output to ccomp.."
@for test in $(TESTNAMES); do\
- gccout=$(OUTDIR)/$$test.gcc.out;\
- ccompout=$(OUTDIR)/$$test.ccomp.out;\
+ gccout=$(OUTDIR)/$$test.gcc.hard.out;\
+ ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\
if $(DIFF) $$ccompout $$gccout > /dev/null; test $${PIPESTATUS[0]} -ne 0; then\
>&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\
else\
@@ -89,14 +131,22 @@ $(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
+$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
+$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
+$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
# Assembly to binary
$(BINDIR)/%.x86-gcc.bin: $(ASMDIR)/%.x86-gcc.s $(LIB) $(CCPATH)
@@ -109,7 +159,7 @@ $(BINDIR)/%.gcc.bin: $(ASMDIR)/%.gcc.s $(K1LIB) $(K1CCPATH)
$(BINDIR)/%.ccomp.bin: $(ASMDIR)/%.ccomp.s $(K1LIB) $(CCOMPPATH)
@mkdir -p $(@D)
- $(CCOMP) $(CFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@
+ $(CCOMP) $(CCOMPFLAGS) $(filter-out $(CCOMPPATH),$^) -o $@
# Source to assembly
@@ -123,4 +173,4 @@ $(ASMDIR)/%.gcc.s: $(SRCDIR)/%.c $(K1CCPATH)
$(ASMDIR)/%.ccomp.s: $(SRCDIR)/%.c $(CCOMPPATH)
@mkdir -p $(@D)
- $(CCOMP) $(CFLAGS) -S $< -o $@
+ $(CCOMP) $(CCOMPFLAGS) -S $< -o $@
diff --git a/test/mppa/instr/builtin32.c b/test/mppa/instr/builtin32.c
new file mode 100644
index 00000000..c7689dc8
--- /dev/null
+++ b/test/mppa/instr/builtin32.c
@@ -0,0 +1,12 @@
+#include "framework.h"
+
+BEGIN_TEST(int)
+ int *ptr = &c;
+#ifdef __K1C__
+ int d = c;
+ a = __builtin_k1_alclrw(ptr);
+ c = d;
+
+#endif
+END_TEST32()
+
diff --git a/test/mppa/instr/builtin64.c b/test/mppa/instr/builtin64.c
new file mode 100644
index 00000000..dbbb1886
--- /dev/null
+++ b/test/mppa/instr/builtin64.c
@@ -0,0 +1,17 @@
+#include "framework.h"
+
+BEGIN_TEST(long long)
+ long long *ptr = &c;
+#ifdef __K1C__
+ long long d = c;
+ a = __builtin_k1_alclrd(ptr);
+ c = d;
+ c += a;
+
+ c += __builtin_clzll(a);
+
+ /* Removed the AFADDD builtin who was incorrect in CompCert, see #157 */
+ // a = __builtin_k1_afaddd(ptr, a);
+ // a = __builtin_k1_afaddd(ptr, a);
+#endif
+END_TEST64()
diff --git a/test/mppa/instr/i32.c b/test/mppa/instr/i32.c
index c48531b1..e350931c 100644
--- a/test/mppa/instr/i32.c
+++ b/test/mppa/instr/i32.c
@@ -12,6 +12,14 @@ int tailsum(int a, int b){
return make(a+b);
}
+int fact(int a){
+ int r = 1;
+ int i;
+ for (i = 1; i < a; i++)
+ r *= i;
+ return r;
+}
+
float int2float(int v){
return v;
}
@@ -20,6 +28,52 @@ BEGIN_TEST(int)
c = a+b;
c += a&b;
+ /* testing if, cb version */
+ if ((a & 0x1) == 1)
+ c += fact(1);
+ else
+ c += fact(2);
+
+ if (a & 0x1 == 0)
+ c += fact(4);
+ else
+ c += fact(8);
+
+ if (a & 0x1 == 0)
+ c += fact(4);
+ else
+ c += fact(8);
+
+ b = !(a & 0x01);
+ if (!b)
+ c += fact(16);
+ else
+ c += fact(32);
+
+ c += sum(make(a), make(b));
+ c += (long long) a;
+
+ if (0 > (a & 0x1) - 1)
+ c += fact(64);
+ else
+ c += fact(128);
+
+ if (0 >= (a & 0x1))
+ c += fact(256);
+ else
+ c += fact(512);
+
+ if ((a & 0x1) > 0)
+ c += fact(1024);
+ else
+ c += fact(2048);
+
+ if ((a & 0x1) - 1 >= 0)
+ c += fact(4096);
+ else
+ c += fact(8192);
+
+ /* cmoved version */
if ((a & 0x1) == 1)
c += 1;
else
@@ -30,15 +84,17 @@ BEGIN_TEST(int)
else
c += 8;
+ if (a & 0x1 == 0)
+ c += 4;
+ else
+ c += 8;
+
b = !(a & 0x01);
if (!b)
c += 16;
else
c += 32;
- c += sum(make(a), make(b));
- c += (long long) a;
-
if (0 > (a & 0x1) - 1)
c += 64;
else
@@ -65,6 +121,12 @@ BEGIN_TEST(int)
c += (a < b);
c += (a + b) / 2;
c += (int) int2float(a) + (int) int2float(b) + (int) int2float(42.3);
+ c += (a << 4); // addx16w
+ c += (a << 3); // addx8w
+ c += (a << 2); // addx4w
+ c += (a << 1); // addx2w
+
+ c += ~a & b; // andnw
int j;
for (j = 0 ; j < 10 ; j++)
diff --git a/test/mppa/instr/i64.c b/test/mppa/instr/i64.c
index 00eb159d..e869d93c 100644
--- a/test/mppa/instr/i64.c
+++ b/test/mppa/instr/i64.c
@@ -30,6 +30,14 @@ long long random_op(long long a, long long b){
return op(a, b);
}
+long fact(long a){
+ long r = 1;
+ long i;
+ for (i = 1; i < a; i++)
+ r *= i;
+ return r;
+}
+
double long2double(long v){
return v;
}
@@ -43,6 +51,12 @@ BEGIN_TEST(long long)
c += a >> (b & 0x8LL);
c += a >> (b & 0x8ULL);
c += a % b;
+ c += (a << 4); // addx16d
+ c += (a << 3); // addx8d
+ c += (a << 2); // addx4d
+ c += (a << 1); // addx2d
+
+ c += ~a & b; // andnd
long long d = 3;
long long (*op)(long long, long long);
@@ -60,6 +74,49 @@ BEGIN_TEST(long long)
c += a^b;
c += (unsigned int) a;
+ /* Testing if, cb */
+ if (0 != (a & 0x1LL))
+ c += fact(1);
+ else
+ c += fact(2);
+
+ if (0 > (a & 0x1LL))
+ c += fact(4);
+ else
+ c += fact(8);
+
+ if (0 >= (a & 0x1LL) - 1)
+ c += fact(16);
+ else
+ c += fact(32);
+
+ if ((unsigned long long)(a & 0x1LL) >= 1)
+ c += fact(18);
+ else
+ c += fact(31);
+
+
+ if (a-41414141 > 0)
+ c += fact(13);
+ else
+ c += fact(31);
+
+ if (a & 0x1LL > 0)
+ c += fact(64);
+ else
+ c += fact(128);
+
+ if ((a & 0x1LL) - 1 >= 0)
+ c += fact(256);
+ else
+ c += fact(512);
+
+ if (0 == (a & 0x1LL))
+ c += fact(1024);
+ else
+ c += fact(2048);
+
+ /* Testing if, cmoved */
if (0 != (a & 0x1LL))
c += 1;
else
@@ -75,6 +132,11 @@ BEGIN_TEST(long long)
else
c += 32;
+ if (a-41414141 > 0)
+ c += 13;
+ else
+ c += 31;
+
if (a & 0x1LL > 0)
c += 64;
else
diff --git a/test/mppa/interop/Makefile b/test/mppa/interop/Makefile
index a405ebd6..3a83d51c 100644
--- a/test/mppa/interop/Makefile
+++ b/test/mppa/interop/Makefile
@@ -1,9 +1,12 @@
-K1CC ?= k1-mbr-gcc
+SHELL := /bin/bash
+
+K1CC ?= k1-cos-gcc
CC ?= gcc
CCOMP ?= ccomp
CFLAGS ?= -O2 -Wno-varargs
SIMU ?= k1-mppa
TIMEOUT ?= --signal=SIGTERM 120s
+HARDRUN ?= k1-jtag-runner
DIR=./
SRCDIR=$(DIR)
@@ -31,17 +34,23 @@ SIMUPATH=$(shell which $(SIMU))
TESTNAMES ?= $(filter-out $(VAARG_COMMON),$(filter-out $(COMMON),$(notdir $(subst .c,,$(wildcard $(DIR)/*.c)))))
X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.out,$(TESTNAMES)))
-GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.out,$(TESTNAMES)))
-GCC_REV_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.out,$(TESTNAMES)))
-CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.out,$(TESTNAMES)))
+GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.simu.out,$(TESTNAMES)))
+GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.simu.out,$(TESTNAMES)))
+CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.simu.out,$(TESTNAMES)))
+
+GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.hard.out,$(TESTNAMES)))
+GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.hard.out,$(TESTNAMES)))
+CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.hard.out,$(TESTNAMES)))
VAARG_X86_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .x86-gcc.vaarg.out,$(TESTNAMES)))
-VAARG_GCC_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.out,$(TESTNAMES)))
-VAARG_GCC_REV_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.out,$(TESTNAMES)))
-VAARG_CCOMP_OUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.out,$(TESTNAMES)))
+VAARG_GCC_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.simu.out,$(TESTNAMES)))
+VAARG_GCC_REV_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.simu.out,$(TESTNAMES)))
+VAARG_CCOMP_SIMUOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.simu.out,$(TESTNAMES)))
+
+VAARG_GCC_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.vaarg.hard.out,$(TESTNAMES)))
+VAARG_GCC_REV_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .gcc.rev.vaarg.hard.out,$(TESTNAMES)))
+VAARG_CCOMP_HARDOUT=$(addprefix $(OUTDIR)/,$(addsuffix .ccomp.vaarg.hard.out,$(TESTNAMES)))
-OUT=$(X86_GCC_OUT) $(GCC_OUT) $(CCOMP_OUT) $(GCC_REV_OUT)\
- $(VAARG_GCC_OUT) $(VAARG_GCC_OUT) $(VAARG_CCOMP_OUT) $(VAARG_GCC_REV_OUT)
BIN=$(addprefix $(BINDIR)/,$(addsuffix .x86-gcc.bin,$(TESTNAMES)))\
$(addprefix $(BINDIR)/,$(addsuffix .gcc.bin,$(TESTNAMES)))\
$(addprefix $(BINDIR)/,$(addsuffix .ccomp.bin,$(TESTNAMES)))\
@@ -61,14 +70,72 @@ GREEN=\033[0;32m
RED=\033[0;31m
NC=\033[0m
+.PHONY:
+test: simutest
+
+.PHONY:
+simutest: $(X86_GCC_OUT) $(GCC_SIMUOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_SIMUOUT)
+ @echo "Comparing x86 gcc output to k1 gcc.."
+ @for test in $(TESTNAMES); do\
+ x86out=$(OUTDIR)/$$test.x86-gcc.out;\
+ gccout=$(OUTDIR)/$$test.gcc.simu.out;\
+ vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\
+ vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\
+ if ! diff $$x86out $$gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$x86out and $$gccout concur$(NC)\n";\
+ fi;\
+ if ! diff $$vaarg_x86out $$vaarg_gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$vaarg_x86out and $$vaarg_gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$vaarg_x86out and $$vaarg_gccout concur$(NC)\n";\
+ fi;\
+ done
+
+.PHONY:
+check: simucheck
+
+.PHONY:
+simucheck: $(GCC_SIMUOUT) $(CCOMP_SIMUOUT) $(GCC_REV_SIMUOUT) $(VAARG_GCC_SIMUOUT) $(VAARG_CCOMP_SIMUOUT) $(VAARG_GCC_REV_SIMUOUT)
+ @echo "Comparing k1 gcc output to ccomp.."
+ @for test in $(TESTNAMES); do\
+ gccout=$(OUTDIR)/$$test.gcc.simu.out;\
+ ccompout=$(OUTDIR)/$$test.ccomp.simu.out;\
+ gccrevout=$(OUTDIR)/$$test.gcc.rev.simu.out;\
+ vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.simu.out;\
+ vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.simu.out;\
+ vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.simu.out;\
+ if ! diff $$ccompout $$gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$ccompout and $$gccout concur$(NC)\n";\
+ fi;\
+ if ! diff $$gccrevout $$gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$gccrevout and $$gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$gccrevout and $$gccout concur$(NC)\n";\
+ fi;\
+ if ! diff $$vaarg_ccompout $$vaarg_gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$vaarg_ccompout and $$vaarg_gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$vaarg_ccompout and $$vaarg_gccout concur$(NC)\n";\
+ fi;\
+ if ! diff $$vaarg_gccrevout $$vaarg_gccout > /dev/null; then\
+ >&2 printf "$(RED)ERROR: $$vaarg_gccrevout and $$vaarg_gccout differ$(NC)\n";\
+ else\
+ printf "$(GREEN)GOOD: $$vaarg_gccrevout and $$vaarg_gccout concur$(NC)\n";\
+ fi;\
+ done
+
.PHONY:
-test: $(X86_GCC_OUT) $(GCC_OUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_OUT)
+hardtest: $(X86_GCC_OUT) $(GCC_HARDOUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_HARDOUT)
@echo "Comparing x86 gcc output to k1 gcc.."
@for test in $(TESTNAMES); do\
x86out=$(OUTDIR)/$$test.x86-gcc.out;\
- gccout=$(OUTDIR)/$$test.gcc.out;\
+ gccout=$(OUTDIR)/$$test.gcc.hard.out;\
vaarg_x86out=$(OUTDIR)/$$test.x86-gcc.vaarg.out;\
- vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.out;\
+ vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\
if ! diff $$x86out $$gccout > /dev/null; then\
>&2 printf "$(RED)ERROR: $$x86out and $$gccout differ$(NC)\n";\
else\
@@ -82,15 +149,15 @@ test: $(X86_GCC_OUT) $(GCC_OUT) $(VAARG_X86_GCC_OUT) $(VAARG_GCC_OUT)
done
.PHONY:
-check: $(GCC_OUT) $(CCOMP_OUT) $(GCC_REV_OUT) $(VAARG_GCC_OUT) $(VAARG_CCOMP_OUT) $(VAARG_GCC_REV_OUT)
+hardcheck: $(GCC_HARDOUT) $(CCOMP_HARDOUT) $(GCC_REV_HARDOUT) $(VAARG_GCC_HARDOUT) $(VAARG_CCOMP_HARDOUT) $(VAARG_GCC_REV_HARDOUT)
@echo "Comparing k1 gcc output to ccomp.."
@for test in $(TESTNAMES); do\
- gccout=$(OUTDIR)/$$test.gcc.out;\
- ccompout=$(OUTDIR)/$$test.ccomp.out;\
- gccrevout=$(OUTDIR)/$$test.gcc.rev.out;\
- vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.out;\
- vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.out;\
- vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.out;\
+ gccout=$(OUTDIR)/$$test.gcc.hard.out;\
+ ccompout=$(OUTDIR)/$$test.ccomp.hard.out;\
+ gccrevout=$(OUTDIR)/$$test.gcc.rev.hard.out;\
+ vaarg_gccout=$(OUTDIR)/$$test.gcc.vaarg.hard.out;\
+ vaarg_ccompout=$(OUTDIR)/$$test.ccomp.vaarg.hard.out;\
+ vaarg_gccrevout=$(OUTDIR)/$$test.gcc.rev.vaarg.hard.out;\
if ! diff $$ccompout $$gccout > /dev/null; then\
>&2 printf "$(RED)ERROR: $$ccompout and $$gccout differ$(NC)\n";\
else\
@@ -142,36 +209,60 @@ $(OUTDIR)/%.x86-gcc.out: $(BINDIR)/%.x86-gcc.bin
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.gcc.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
+$(OUTDIR)/%.gcc.simu.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.gcc.rev.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH)
+$(OUTDIR)/%.gcc.rev.simu.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.ccomp.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
+$(OUTDIR)/%.ccomp.simu.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
+$(OUTDIR)/%.gcc.hard.out: $(BINDIR)/%.gcc.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.gcc.rev.hard.out: $(BINDIR)/%.gcc.rev.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.ccomp.hard.out: $(BINDIR)/%.ccomp.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
## With vaarg
$(OUTDIR)/%.x86-gcc.vaarg.out: $(BINDIR)/%.x86-gcc.vaarg.bin
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) ./$< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.gcc.vaarg.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH)
+$(OUTDIR)/%.gcc.vaarg.simu.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.gcc.rev.vaarg.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH)
+$(OUTDIR)/%.gcc.rev.vaarg.simu.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
-$(OUTDIR)/%.ccomp.vaarg.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH)
+$(OUTDIR)/%.ccomp.vaarg.simu.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH)
@mkdir -p $(@D)
ret=0; timeout $(TIMEOUT) $(SIMU) -- $< > $@ || { ret=$$?; }; echo $$ret >> $@
+$(OUTDIR)/%.gcc.vaarg.hard.out: $(BINDIR)/%.gcc.vaarg.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.gcc.rev.vaarg.hard.out: $(BINDIR)/%.gcc.rev.vaarg.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
+$(OUTDIR)/%.ccomp.vaarg.hard.out: $(BINDIR)/%.ccomp.vaarg.bin $(SIMUPATH)
+ @mkdir -p $(@D)
+ ret=0; timeout $(TIMEOUT) $(HARDRUN) --exec-file=Cluster0:$< > $@ || { ret=$$?; }; echo $$ret >> $@
+
##
# Object to binary
##
diff --git a/test/mppa/interop/common.c b/test/mppa/interop/common.c
index e939e0d1..05b49187 100644
--- a/test/mppa/interop/common.c
+++ b/test/mppa/interop/common.c
@@ -1,17 +1,21 @@
#define STACK int a[100];\
a[42] = 42;
-#define ONEARG_OP(arg) (3*arg+2)
+#define ONEARG_OP(arg) (3*magic(arg)+2)
-#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ arg2 << arg3 - arg4)
+#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4)
#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\
a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\
a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\
- (a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 *\
+ (a0 * a1 * a2 * magic(a3) * a4 * a5 * a6 * a7 * a8 * a9 *\
a10 * a11 * a12 * a13 * a14 * a15 * a16 * a17 * a18 * a19 *\
a20 * a21 * a22 * a23 * a24 * a25 * a26 * a27 * a28 * a29)
+int magic(long a){
+ return a*42 + 26;
+}
+
void void_void(){
STACK;
}
diff --git a/test/mppa/interop/vaarg_common.c b/test/mppa/interop/vaarg_common.c
index 9033893b..3314959f 100644
--- a/test/mppa/interop/vaarg_common.c
+++ b/test/mppa/interop/vaarg_common.c
@@ -3,20 +3,24 @@
#define STACK int a[100];\
a[42] = 42;
-#define ONEARG_OP(arg) (3*arg+2)
+#define ONEARG_OP(arg) (3*magic(arg)+2)
-#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ arg2 << arg3 - arg4)
+#define MULTIARG_OP(arg1, arg2, arg3, arg4) (arg1 ^ magic(arg2) << arg3 - arg4)
#define MANYARG_OP(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9,\
a10, a11, a12, a13, a14, a15, a16, a17, a18, a19,\
a20, a21, a22, a23, a24, a25, a26, a27, a28, a29)\
- (a0 + a1 * a2 + a3 * a4 + a5 + a6 + a7 - a8 + a9 +\
- a10 + a11 - a12 ^ a13 + a14 - a15 + a16 ^ a17 + a18 + a19 +\
+ (a0 + a1 * a2 + magic(a3) * a4 + a5 + a6 + a7 - a8 + a9 +\
+ a10 + a11 - a12 ^ a13 + a14 - magic(a15) + a16 ^ a17 + a18 + a19 +\
a20 + a21 + a22 * a23 + a24 + a25 << a26 & a27 + a28 + a29)
#define VA_START(vl, arg) va_list vl; va_start(vl, arg)
#define VA_END(vl) va_end(vl)
+int magic(long a){
+ return a*2 + 42;
+}
+
void void_void(void){
STACK;
}
diff --git a/test/mppa/lib/Makefile b/test/mppa/lib/Makefile
index affc1afd..08901db6 100644
--- a/test/mppa/lib/Makefile
+++ b/test/mppa/lib/Makefile
@@ -1,5 +1,5 @@
-K1CC ?= k1-mbr-gcc
-K1AR ?= k1-mbr-ar
+K1CC ?= k1-cos-gcc
+K1AR ?= k1-cos-ar
CC ?= gcc
AR ?= gcc-ar
CCOMP ?= ccomp
diff --git a/test/mppa/mmult/Makefile b/test/mppa/mmult/Makefile
index 5895ce3d..667faef8 100644
--- a/test/mppa/mmult/Makefile
+++ b/test/mppa/mmult/Makefile
@@ -1,4 +1,4 @@
-K1CC ?= k1-mbr-gcc
+K1CC ?= k1-cos-gcc
CC ?= gcc
CCOMP ?= ccomp
CFLAGS ?= -O2
diff --git a/test/mppa/prng/Makefile b/test/mppa/prng/Makefile
index 4770c901..9cbb3872 100644
--- a/test/mppa/prng/Makefile
+++ b/test/mppa/prng/Makefile
@@ -1,4 +1,4 @@
-K1CC ?= k1-mbr-gcc
+K1CC ?= k1-cos-gcc
CC ?= gcc
CCOMP ?= ccomp
CFLAGS ?= -O2
diff --git a/test/mppa/simucheck.sh b/test/mppa/simucheck.sh
new file mode 100755
index 00000000..25fb9947
--- /dev/null
+++ b/test/mppa/simucheck.sh
@@ -0,0 +1,6 @@
+#!/bin/bash
+# Tests the execution of the binaries produced by CompCert, by simulation
+
+source do_test.sh
+
+do_test check $1
diff --git a/test/mppa/test.sh b/test/mppa/simutest.sh
index 30806a6b..3b1021e6 100755
--- a/test/mppa/test.sh
+++ b/test/mppa/simutest.sh
@@ -1,5 +1,5 @@
#!/bin/bash
-# Tests the validity of the tests
+# Tests the validity of the tests, in simulator
source do_test.sh
diff --git a/test/mppa/sort/Makefile b/test/mppa/sort/Makefile
index 5173528c..0ae9d1f6 100644
--- a/test/mppa/sort/Makefile
+++ b/test/mppa/sort/Makefile
@@ -1,4 +1,4 @@
-K1CC ?= k1-mbr-gcc
+K1CC ?= k1-cos-gcc
CC ?= gcc
CCOMP ?= ccomp
CFLAGS ?= -O2
diff --git a/test/raytracer/Makefile b/test/raytracer/Makefile
index 8f6541a1..24461bd1 100644
--- a/test/raytracer/Makefile
+++ b/test/raytracer/Makefile
@@ -3,7 +3,7 @@ include ../../Makefile.config
CC=../../ccomp
CFLAGS=$(CCOMPOPTS) -stdlib ../../runtime -dparse -dclight -dasm -fstruct-return
LIBS=$(LIBMATH)
-TIME=xtime
+TIME=ocaml unix.cma ../../tools/xtime.ml -mintime 2.0 -minruns 4
OBJS=memory.o gmllexer.o gmlparser.o eval.o \
arrays.o vector.o matrix.o object.o intersect.o surface.o light.o \
@@ -30,4 +30,4 @@ test:
fi
bench:
- @echo -n "raytracer: "; $(TIME) sh -c './render < kal.gml'
+ @$(TIME) -name raytracer -- sh -c './render < kal.gml'
diff --git a/test/regression/Makefile b/test/regression/Makefile
index 0bcbcc1f..97c25f6c 100644
--- a/test/regression/Makefile
+++ b/test/regression/Makefile
@@ -10,26 +10,34 @@ LIBS=$(LIBMATH)
# Can run, both in compiled mode and in interpreter mode,
# and have reference output in Results
-TESTS=int32 int64 floats floats-basics \
+TESTS?=int32 int64 floats floats-basics floats-lit \
expr1 expr6 funptr2 initializers initializers2 initializers3 \
volatile1 volatile2 volatile3 volatile4 \
funct3 expr5 struct7 struct8 struct11 struct12 casts1 casts2 char1 \
sizeof1 sizeof2 binops bool for1 for2 switch switch2 compound \
decl1 interop1 bitfields9 ptrs3 \
- parsing krfun
+ parsing krfun ifconv
# Can run, but only in compiled mode, and have reference output in Results
-TESTS_COMP=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \
+TESTS_COMP?=attribs1 bitfields1 bitfields2 bitfields3 bitfields4 \
bitfields5 bitfields6 bitfields7 bitfields8 \
builtins-$(ARCH) alignas \
- varargs1 varargs2 varargs3 sections alias aligned
-# FIXME K1C : packedstruct1 packedstruct2
+ varargs1 varargs2 varargs3 sections alias aligned\
+ packedstruct1 packedstruct2
+
+ifeq ($(ARCH),mppa_k1c)
+ TESTS_COMP:=$(filter-out packedstruct1,$(TESTS_COMP))
+ TESTS_COMP:=$(filter-out packedstruct2,$(TESTS_COMP))
+endif
# Can run, both in compiled mode and in interpreter mode,
# but produce processor-dependent results, so no reference output in Results
TESTS_DIFF=NaNs
+# FIXME ifeq ($(ARCH),mppa_k1c)
+ TESTS_DIFF:=$(filter-out NaNs,$(TESTS_DIFF))
+# endif
# Other tests: should compile to .s without errors (but expect warnings)
diff --git a/test/regression/Results/builtins-aarch64 b/test/regression/Results/builtins-aarch64
new file mode 100644
index 00000000..c70432d8
--- /dev/null
+++ b/test/regression/Results/builtins-aarch64
@@ -0,0 +1,15 @@
+bswap(12345678) = 78563412
+bswap16(1234) = 3412
+bswap64(123456789abcdef0) = f0debc9a78563412
+clz(12345678) = 3
+clzll(12345678) = 35
+clzll(1234567812345678) = 3
+cls(1234567) = 10
+cls(-9999) = 17
+clsll(1234567) = 42
+clsll(-9999) = 49
+fsqrt(3.141590) = 1.772453
+fmadd(3.141590, 2.718000, 1.414000) = 9.952842
+fmsub(3.141590, 2.718000, 1.414000) = -7.124842
+fnmadd(3.141590, 2.718000, 1.414000) = -9.952842
+fnmsub(3.141590, 2.718000, 1.414000) = 7.124842
diff --git a/test/regression/Results/floats-lit b/test/regression/Results/floats-lit
new file mode 100644
index 00000000..6cde72fb
--- /dev/null
+++ b/test/regression/Results/floats-lit
@@ -0,0 +1,2 @@
+--- Double-precision test
+--- Single-precision test
diff --git a/test/regression/Results/ifconv b/test/regression/Results/ifconv
new file mode 100644
index 00000000..38019fe6
--- /dev/null
+++ b/test/regression/Results/ifconv
@@ -0,0 +1,26 @@
+test1(0,1,12,34) = 12
+test1(1,0,45,67) = 67
+test2(0,1,12,34) = 12
+test2(1,0,45,67) = 67
+test3(0,1,12,34) = 12
+test3(1,0,45,67) = 67
+test4(0,1,12,34) = 12
+test4(1,0,45,67) = 67
+test5(0,1,12) = 13
+test5(1,0,45) = 44
+test6(NULL) = 0
+test6(&i) = 1244
+test7(1,0) = -1
+test7(-100,4) = -25
+test8(0) = 0
+test8(1) = -72
+ltest1(-1, 0, 123LL, 456LL) = 124
+ltest1(1, 0, 123LL, 456LL) = 114
+dmax(0.0, 3.14) = 3.140000
+dmax(1.0, -2.718) = 1.000000
+dabs(1.0) = 1.000000
+dabs(-2.718) = 2.718000
+smin(0.0, 3.14) = 0.000000
+smin(1.0, -2.718) = -2.718000
+sdoz(1.0, 0.5) = 0.500000
+sdoz(0.0, 3.14) = 0.000000
diff --git a/test/regression/Results/int64 b/test/regression/Results/int64
index af444cf6..ae8a3cc1 100644
--- a/test/regression/Results/int64
+++ b/test/regression/Results/int64
@@ -335,6 +335,48 @@ utof x = 0
stof x = 0
x = 0
+y = 52ce6b4000000063
+-x = 0
+x + y = 52ce6b4000000063
+x - y = ad3194bfffffff9d
+x * y = 0
+x /u y = 0
+x %u y = 0
+x /s y = 0
+x %s y = 0
+x /u y2 = 0
+x %u y2 = 0
+x /s y3 = 0
+x %s y3 = 0
+x /u 3 = 0
+x %u 3 = 0
+x /s 3 = 0
+x %s 3 = 0
+x /u 5 = 0
+x %u 5 = 0
+x /s 5 = 0
+x %s 5 = 0
+x /u 11 = 0
+x %u 11 = 0
+x /s 11 = 0
+x %s 11 = 0
+~x = ffffffffffffffff
+x & y = 0
+x | y = 52ce6b4000000063
+x ^ y = 52ce6b4000000063
+x << i = 0
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = lt
+utod x = 0
+dtou f = 0
+stod x = 0
+dtos f = 0
+utof x = 0
+stof x = 0
+
+x = 0
y = 14057b7ef767814f
-x = 0
x + y = 14057b7ef767814f
@@ -755,6 +797,48 @@ utof x = 3f800000
stof x = 3f800000
x = 1
+y = 52ce6b4000000063
+-x = ffffffffffffffff
+x + y = 52ce6b4000000064
+x - y = ad3194bfffffff9e
+x * y = 52ce6b4000000063
+x /u y = 0
+x %u y = 1
+x /s y = 0
+x %s y = 1
+x /u y2 = 0
+x %u y2 = 1
+x /s y3 = 0
+x %s y3 = 1
+x /u 3 = 0
+x %u 3 = 1
+x /s 3 = 0
+x %s 3 = 1
+x /u 5 = 0
+x %u 5 = 1
+x /s 5 = 0
+x %s 5 = 1
+x /u 11 = 0
+x %u 11 = 1
+x /s 11 = 0
+x %s 11 = 1
+~x = fffffffffffffffe
+x & y = 1
+x | y = 52ce6b4000000063
+x ^ y = 52ce6b4000000062
+x << i = 800000000
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = lt
+utod x = 3ff0000000000000
+dtou f = 0
+stod x = 3ff0000000000000
+dtos f = 0
+utof x = 3f800000
+stof x = 3f800000
+
+x = 1
y = 9af678222e728119
-x = ffffffffffffffff
x + y = 9af678222e72811a
@@ -1175,6 +1259,48 @@ utof x = 5f800000
stof x = bf800000
x = ffffffffffffffff
+y = 52ce6b4000000063
+-x = 1
+x + y = 52ce6b4000000062
+x - y = ad3194bfffffff9c
+x * y = ad3194bfffffff9d
+x /u y = 3
+x %u y = 794be3ffffffed6
+x /s y = 0
+x %s y = ffffffffffffffff
+x /u y2 = 3176fe836
+x %u y2 = 3683607f
+x /s y3 = 0
+x %s y3 = ffffffffffffffff
+x /u 3 = 5555555555555555
+x %u 3 = 0
+x /s 3 = 0
+x %s 3 = ffffffffffffffff
+x /u 5 = 3333333333333333
+x %u 5 = 0
+x /s 5 = 0
+x %s 5 = ffffffffffffffff
+x /u 11 = 1745d1745d1745d1
+x %u 11 = 4
+x /s 11 = 0
+x %s 11 = ffffffffffffffff
+~x = 0
+x & y = 52ce6b4000000063
+x | y = ffffffffffffffff
+x ^ y = ad3194bfffffff9c
+x << i = fffffff800000000
+x >>u i = 1fffffff
+x >>s i = ffffffffffffffff
+x cmpu y = gt
+x cmps y = lt
+utod x = 43f0000000000000
+dtou f = 68db8bac710cb
+stod x = bff0000000000000
+dtos f = 0
+utof x = 5f800000
+stof x = bf800000
+
+x = ffffffffffffffff
y = 62354cda6226d1f3
-x = 1
x + y = 62354cda6226d1f2
@@ -1595,6 +1721,48 @@ utof x = 4f000000
stof x = 4f000000
x = 7fffffff
+y = 52ce6b4000000063
+-x = ffffffff80000001
+x + y = 52ce6b4080000062
+x - y = ad3194c07fffff9c
+x * y = ad3194f17fffff9d
+x /u y = 0
+x %u y = 7fffffff
+x /s y = 0
+x %s y = 7fffffff
+x /u y2 = 1
+x %u y2 = 2d3194bf
+x /s y3 = 1
+x %s y3 = 2d3194bf
+x /u 3 = 2aaaaaaa
+x %u 3 = 1
+x /s 3 = 2aaaaaaa
+x %s 3 = 1
+x /u 5 = 19999999
+x %u 5 = 2
+x /s 5 = 19999999
+x %s 5 = 2
+x /u 11 = ba2e8ba
+x %u 11 = 1
+x /s 11 = ba2e8ba
+x %s 11 = 1
+~x = ffffffff80000000
+x & y = 63
+x | y = 52ce6b407fffffff
+x ^ y = 52ce6b407fffff9c
+x << i = fffffff800000000
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = lt
+utod x = 41dfffffffc00000
+dtou f = 346dc
+stod x = 41dfffffffc00000
+dtos f = 346dc
+utof x = 4f000000
+stof x = 4f000000
+
+x = 7fffffff
y = 144093704fadba5d
-x = ffffffff80000001
x + y = 14409370cfadba5c
@@ -2015,6 +2183,48 @@ utof x = 4f000000
stof x = 4f000000
x = 80000000
+y = 52ce6b4000000063
+-x = ffffffff80000000
+x + y = 52ce6b4080000063
+x - y = ad3194c07fffff9d
+x * y = 3180000000
+x /u y = 0
+x %u y = 80000000
+x /s y = 0
+x %s y = 80000000
+x /u y2 = 1
+x %u y2 = 2d3194c0
+x /s y3 = 1
+x %s y3 = 2d3194c0
+x /u 3 = 2aaaaaaa
+x %u 3 = 2
+x /s 3 = 2aaaaaaa
+x %s 3 = 2
+x /u 5 = 19999999
+x %u 5 = 3
+x /s 5 = 19999999
+x %s 5 = 3
+x /u 11 = ba2e8ba
+x %u 11 = 2
+x /s 11 = ba2e8ba
+x %s 11 = 2
+~x = ffffffff7fffffff
+x & y = 0
+x | y = 52ce6b4080000063
+x ^ y = 52ce6b4080000063
+x << i = 0
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = lt
+utod x = 41e0000000000000
+dtou f = 346dc
+stod x = 41e0000000000000
+dtos f = 346dc
+utof x = 4f000000
+stof x = 4f000000
+
+x = 80000000
y = 7b985bc1e7bce4d7
-x = ffffffff80000000
x + y = 7b985bc267bce4d7
@@ -2435,6 +2645,48 @@ utof x = 5f000000
stof x = 5f000000
x = 7fffffffffffffff
+y = 52ce6b4000000063
+-x = 8000000000000001
+x + y = d2ce6b4000000062
+x - y = 2d3194bfffffff9c
+x * y = 2d3194bfffffff9d
+x /u y = 1
+x %u y = 2d3194bfffffff9c
+x /s y = 1
+x %s y = 2d3194bfffffff9c
+x /u y2 = 18bb7f41b
+x %u y2 = 1b41b03f
+x /s y3 = 18bb7f41b
+x %s y3 = 1b41b03f
+x /u 3 = 2aaaaaaaaaaaaaaa
+x %u 3 = 1
+x /s 3 = 2aaaaaaaaaaaaaaa
+x %s 3 = 1
+x /u 5 = 1999999999999999
+x %u 5 = 2
+x /s 5 = 1999999999999999
+x %s 5 = 2
+x /u 11 = ba2e8ba2e8ba2e8
+x %u 11 = 7
+x /s 11 = ba2e8ba2e8ba2e8
+x %s 11 = 7
+~x = 8000000000000000
+x & y = 52ce6b4000000063
+x | y = 7fffffffffffffff
+x ^ y = 2d3194bfffffff9c
+x << i = fffffff800000000
+x >>u i = fffffff
+x >>s i = fffffff
+x cmpu y = gt
+x cmps y = gt
+utod x = 43e0000000000000
+dtou f = 346dc5d638865
+stod x = 43e0000000000000
+dtos f = 346dc5d638865
+utof x = 5f000000
+stof x = 5f000000
+
+x = 7fffffffffffffff
y = a220229ec164ffe1
-x = 8000000000000001
x + y = 2220229ec164ffe0
@@ -2855,6 +3107,48 @@ utof x = 5f000000
stof x = df000000
x = 8000000000000000
+y = 52ce6b4000000063
+-x = 8000000000000000
+x + y = d2ce6b4000000063
+x - y = 2d3194bfffffff9d
+x * y = 8000000000000000
+x /u y = 1
+x %u y = 2d3194bfffffff9d
+x /s y = ffffffffffffffff
+x %s y = d2ce6b4000000063
+x /u y2 = 18bb7f41b
+x %u y2 = 1b41b040
+x /s y3 = fffffffe74480be5
+x %s y3 = ffffffffe4be4fc0
+x /u 3 = 2aaaaaaaaaaaaaaa
+x %u 3 = 2
+x /s 3 = d555555555555556
+x %s 3 = fffffffffffffffe
+x /u 5 = 1999999999999999
+x %u 5 = 3
+x /s 5 = e666666666666667
+x %s 5 = fffffffffffffffd
+x /u 11 = ba2e8ba2e8ba2e8
+x %u 11 = 8
+x /s 11 = f45d1745d1745d18
+x %s 11 = fffffffffffffff8
+~x = 7fffffffffffffff
+x & y = 0
+x | y = d2ce6b4000000063
+x ^ y = d2ce6b4000000063
+x << i = 0
+x >>u i = 10000000
+x >>s i = fffffffff0000000
+x cmpu y = gt
+x cmps y = lt
+utod x = 43e0000000000000
+dtou f = 346dc5d638865
+stod x = c3e0000000000000
+dtos f = fffcb923a29c779b
+utof x = 5f000000
+stof x = df000000
+
+x = 8000000000000000
y = c73aa0d9a415dfb
-x = 8000000000000000
x + y = 8c73aa0d9a415dfb
@@ -3275,6 +3569,48 @@ utof x = 4f800000
stof x = 4f800000
x = 100000003
+y = 52ce6b4000000063
+-x = fffffffefffffffd
+x + y = 52ce6b4100000066
+x - y = ad3194c0ffffffa0
+x * y = f86b422300000129
+x /u y = 0
+x %u y = 100000003
+x /s y = 0
+x %s y = 100000003
+x /u y2 = 3
+x %u y2 = 794be43
+x /s y3 = 3
+x %s y3 = 794be43
+x /u 3 = 55555556
+x %u 3 = 1
+x /s 3 = 55555556
+x %s 3 = 1
+x /u 5 = 33333333
+x %u 5 = 4
+x /s 5 = 33333333
+x %s 5 = 4
+x /u 11 = 1745d174
+x %u 11 = 7
+x /s 11 = 1745d174
+x %s 11 = 7
+~x = fffffffefffffffc
+x & y = 3
+x | y = 52ce6b4100000063
+x ^ y = 52ce6b4100000060
+x << i = 1800000000
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = lt
+utod x = 41f0000000300000
+dtou f = 68db8
+stod x = 41f0000000300000
+dtos f = 68db8
+utof x = 4f800000
+stof x = 4f800000
+
+x = 100000003
y = e9bcd26890f095a5
-x = fffffffefffffffd
x + y = e9bcd26990f095a8
@@ -3358,47 +3694,467 @@ dtos f = 14bb101261e18
utof x = 5e4a72c9
stof x = 5e4a72c9
-x = 8362aa9340fe215f
-y = f986342416ec8002
--x = 7c9d556cbf01dea1
-x + y = 7ce8deb757eaa161
-x - y = 89dc766f2a11a15d
-x * y = e4a2b426803fc2be
+x = 52ce6b4000000063
+y = 0
+-x = ad3194bfffffff9d
+x + y = 52ce6b4000000063
+x - y = 52ce6b4000000063
+x * y = 0
x /u y = 0
-x %u y = 8362aa9340fe215f
-x /s y = 13
-x %s y = fe6ccbe58d70a139
-x /u y2 = 86cb918b
-x %u y2 = 910b6dd3
-x /s y3 = 133e437097
-x %s y3 = fffffffffe99a023
-x /u 3 = 2bcb8e3115aa0b1f
-x %u 3 = 2
-x /s 3 = d67638dbc054b5cb
-x %s 3 = fffffffffffffffe
-x /u 5 = 1a46eeea4032d379
-x %u 5 = 2
-x /s 5 = e713bbb70cffa047
-x %s 5 = fffffffffffffffc
-x /u 11 = bf1b26a7a45a5f1
-x %u 11 = 4
-x /s 11 = f4abe0f61d2e6020
-x %s 11 = ffffffffffffffff
-~x = 7c9d556cbf01dea0
-x & y = 8102200000ec0002
-x | y = fbe6beb756fea15f
-x ^ y = 7ae49eb75612a15d
-x << i = d8aaa4d03f8857c
-x >>u i = 20d8aaa4d03f8857
-x >>s i = e0d8aaa4d03f8857
+x %u y = 0
+x /s y = 0
+x %s y = 0
+x /u y2 = 0
+x %u y2 = 0
+x /s y3 = 0
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 0
+x | y = 52ce6b4000000063
+x ^ y = 52ce6b4000000063
+x << i = 52ce6b4000000063
+x >>u i = 52ce6b4000000063
+x >>s i = 52ce6b4000000063
+x cmpu y = gt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 1
+-x = ad3194bfffffff9d
+x + y = 52ce6b4000000064
+x - y = 52ce6b4000000062
+x * y = 52ce6b4000000063
+x /u y = 52ce6b4000000063
+x %u y = 0
+x /s y = 52ce6b4000000063
+x %s y = 0
+x /u y2 = 0
+x %u y2 = 0
+x /s y3 = 0
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 1
+x | y = 52ce6b4000000063
+x ^ y = 52ce6b4000000062
+x << i = a59cd680000000c6
+x >>u i = 296735a000000031
+x >>s i = 296735a000000031
+x cmpu y = gt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = ffffffffffffffff
+-x = ad3194bfffffff9d
+x + y = 52ce6b4000000062
+x - y = 52ce6b4000000064
+x * y = ad3194bfffffff9d
+x /u y = 0
+x %u y = 52ce6b4000000063
+x /s y = ad3194bfffffff9d
+x %s y = 0
+x /u y2 = 52ce6b40
+x %u y2 = 52ce6ba3
+x /s y3 = ad3194bfffffff9d
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 52ce6b4000000063
+x | y = ffffffffffffffff
+x ^ y = ad3194bfffffff9c
+x << i = 8000000000000000
+x >>u i = 0
+x >>s i = 0
+x cmpu y = lt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 7fffffff
+-x = ad3194bfffffff9d
+x + y = 52ce6b4080000062
+x - y = 52ce6b3f80000064
+x * y = ad3194f17fffff9d
+x /u y = a59cd681
+x %u y = 259cd6e4
+x /s y = a59cd681
+x %s y = 259cd6e4
+x /u y2 = 0
+x %u y2 = 0
+x /s y3 = 0
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 63
+x | y = 52ce6b407fffffff
+x ^ y = 52ce6b407fffff9c
+x << i = 8000000000000000
+x >>u i = 0
+x >>s i = 0
+x cmpu y = gt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 80000000
+-x = ad3194bfffffff9d
+x + y = 52ce6b4080000063
+x - y = 52ce6b3f80000063
+x * y = 3180000000
+x /u y = a59cd680
+x %u y = 63
+x /s y = a59cd680
+x %s y = 63
+x /u y2 = 0
+x %u y2 = 0
+x /s y3 = 0
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 0
+x | y = 52ce6b4080000063
+x ^ y = 52ce6b4080000063
+x << i = 52ce6b4000000063
+x >>u i = 52ce6b4000000063
+x >>s i = 52ce6b4000000063
+x cmpu y = gt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 7fffffffffffffff
+-x = ad3194bfffffff9d
+x + y = d2ce6b4000000062
+x - y = d2ce6b4000000064
+x * y = 2d3194bfffffff9d
+x /u y = 0
+x %u y = 52ce6b4000000063
+x /s y = 0
+x %s y = 52ce6b4000000063
+x /u y2 = a59cd681
+x %u y2 = 259cd6e4
+x /s y3 = a59cd681
+x %s y3 = 259cd6e4
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 52ce6b4000000063
+x | y = 7fffffffffffffff
+x ^ y = 2d3194bfffffff9c
+x << i = 8000000000000000
+x >>u i = 0
+x >>s i = 0
x cmpu y = lt
x cmps y = lt
-utod x = 43e06c5552681fc4
-dtou f = 35d0c262d14d7
-stod x = c3df27555b2fc078
-dtos f = fffccf536b66040d
-utof x = 5f0362ab
-stof x = def93aab
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 8000000000000000
+-x = ad3194bfffffff9d
+x + y = d2ce6b4000000063
+x - y = d2ce6b4000000063
+x * y = 8000000000000000
+x /u y = 0
+x %u y = 52ce6b4000000063
+x /s y = 0
+x %s y = 52ce6b4000000063
+x /u y2 = a59cd680
+x %u y2 = 63
+x /s y3 = ffffffff5a632980
+x %s y3 = 63
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 0
+x | y = d2ce6b4000000063
+x ^ y = d2ce6b4000000063
+x << i = 52ce6b4000000063
+x >>u i = 52ce6b4000000063
+x >>s i = 52ce6b4000000063
+x cmpu y = lt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 100000003
+-x = ad3194bfffffff9d
+x + y = 52ce6b4100000066
+x - y = 52ce6b3f00000060
+x * y = f86b422300000129
+x /u y = 52ce6b3f
+x %u y = 794bea6
+x /s y = 52ce6b3f
+x %s y = 794bea6
+x /u y2 = 52ce6b4000000063
+x %u y2 = 0
+x /s y3 = 52ce6b4000000063
+x %s y3 = 0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 3
+x | y = 52ce6b4100000063
+x ^ y = 52ce6b4100000060
+x << i = 96735a0000000318
+x >>u i = a59cd680000000c
+x >>s i = a59cd680000000c
+x cmpu y = gt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 52ce6b4000000063
+-x = ad3194bfffffff9d
+x + y = a59cd680000000c6
+x - y = 0
+x * y = ba6f38000002649
+x /u y = 1
+x %u y = 0
+x /s y = 1
+x %s y = 0
+x /u y2 = 100000000
+x %u y2 = 63
+x /s y3 = 100000000
+x %s y3 = 63
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 52ce6b4000000063
+x | y = 52ce6b4000000063
+x ^ y = 0
+x << i = 31800000000
+x >>u i = a59cd68
+x >>s i = a59cd68
+x cmpu y = eq
+x cmps y = eq
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = 52ce6b4000000063
+y = 8362aa9340fe215f
+-x = ad3194bfffffff9d
+x + y = d63115d340fe21c2
+x - y = cf6bc0acbf01df04
+x * y = 8f1503b22246e7bd
+x /u y = 0
+x %u y = 52ce6b4000000063
+x /s y = 0
+x %s y = 52ce6b4000000063
+x /u y2 = a158656f
+x %u y2 = 5640ba6
+x /s y3 = ffffffff55e35d11
+x %s y3 = 5f2245a0
+x /u 3 = 1b9a23c000000021
+x %u 3 = 0
+x /s 3 = 1b9a23c000000021
+x %s 3 = 0
+x /u 5 = 108faf0ccccccce0
+x %u 5 = 3
+x /s 5 = 108faf0ccccccce0
+x %s 5 = 3
+x /u 11 = 7872105d1745d20
+x %u 11 = 3
+x /s 11 = 7872105d1745d20
+x %s 11 = 3
+~x = ad3194bfffffff9c
+x & y = 2422a0000000043
+x | y = d3eeebd340fe217f
+x ^ y = d1acc1d340fe213c
+x << i = 3180000000
+x >>u i = a59cd680
+x >>s i = a59cd680
+x cmpu y = lt
+x cmps y = gt
+utod x = 43d4b39ad0000000
+dtou f = 21eadf559b3d0
+stod x = 43d4b39ad0000000
+dtos f = 21eadf559b3d0
+utof x = 5ea59cd7
+stof x = 5ea59cd7
+
+x = f986342416ec8002
+y = 52ce6b4000000063
+-x = 679cbdbe9137ffe
+x + y = 4c549f6416ec8065
+x - y = a6b7c8e416ec7f9f
+x * y = b9230074dd7580c6
+x /u y = 3
+x %u y = 11af26416ec7ed9
+x /s y = 0
+x %s y = f986342416ec8002
+x /u y2 = 3036abea3
+x %u y2 = 164b642
+x /s y3 = ffffffffebfad66d
+x %s y3 = ffffffffcae155c2
+x /u 3 = 532cbc0c07a42aab
+x %u 3 = 1
+x /s 3 = fdd766b6b24ed556
+x %s 3 = 0
+x /u 5 = 31e7a40737c8e666
+x %u 5 = 4
+x /s 5 = feb470d40495b334
+x %s 5 = fffffffffffffffe
+x /u 11 = 16af1c0347e6f45d
+x %u 11 = 3
+x /s 11 = ff694a8eeacfae8c
+x %s 11 = fffffffffffffffe
+~x = 679cbdbe9137ffd
+x & y = 5086200000000002
+x | y = fbce7f6416ec8063
+x ^ y = ab485f6416ec8061
+x << i = b764001000000000
+x >>u i = 1f30c684
+x >>s i = ffffffffff30c684
+x cmpu y = gt
+x cmps y = lt
+utod x = 43ef30c68482dd90
+dtou f = 6634832136daf
+stod x = c399e72f6fa44e00
+dtos f = ffffd58f774c5ce4
+utof x = 5f798634
+stof x = dccf397b
x = 368083376ba4ffa9
y = 6912b247b79a4904
@@ -7558,3 +8314,45 @@ dtos f = b3fdf698d581
utof x = 5ddbb784
stof x = 5ddbb784
+x = ca9a47c1649d27a7
+y = d56d650045e652aa
+-x = 3565b83e9b62d859
+x + y = a007acc1aa837a51
+x - y = f52ce2c11eb6d4fd
+x * y = 630e3c88ca19d2e6
+x /u y = 0
+x %u y = ca9a47c1649d27a7
+x /s y = 1
+x %s y = f52ce2c11eb6d4fd
+x /u y2 = f3042098
+x %u y2 = 6b092fa7
+x /s y3 = 141176486
+x %s y3 = ffffffffdee649a7
+x /u 3 = 4388c295cc34628d
+x %u 3 = 0
+x /s 3 = ee336d4076df0d38
+x %s 3 = ffffffffffffffff
+x /u 5 = 2885418d141f6e54
+x %u 5 = 3
+x /s 5 = f5520e59e0ec3b22
+x %s 5 = fffffffffffffffd
+x /u 11 = 126b1dcbc3541ae0
+x %u 11 = 7
+x /s 11 = fb254c57663cd510
+x %s 11 = fffffffffffffff7
+~x = 3565b83e9b62d858
+x & y = c0084500448402a2
+x | y = dfff67c165ff77af
+x ^ y = 1ff722c1217b750d
+x << i = 749e9c0000000000
+x >>u i = 32a691
+x >>s i = fffffffffff2a691
+x cmpu y = lt
+x cmps y = lt
+utod x = 43e95348f82c93a5
+dtou f = 52fc6dac31674
+stod x = c3cab2dc1f4db16c
+dtos f = fffea20e1ffc05aa
+utof x = 5f4a9a48
+stof x = de5596e1
+
diff --git a/test/regression/Results/interop1 b/test/regression/Results/interop1
index 990dfe9d..6e32c1cb 100644
--- a/test/regression/Results/interop1
+++ b/test/regression/Results/interop1
@@ -1,4 +1,8 @@
--- CompCert calling native:
+si8u: 177
+si8s: -79
+si16u: 64305
+si16s: -1231
s1: { a = 'a' }
s2: { a = 'a', b = 'b' }
s3: { a = 'a', b = 'b', c = ' c' }
@@ -44,6 +48,10 @@ ru6: { a = 55555, b = 666 }
ru7: { a = -10001, b = -789, c = 'z' }
ru8: { a = 'x', b = 12345 }
--- native calling CompCert:
+si8u: 177
+si8s: -79
+si16u: 64305
+si16s: -1231
s1: { a = 'a' }
s2: { a = 'a', b = 'b' }
s3: { a = 'a', b = 'b', c = ' c' }
diff --git a/test/regression/Results/varargs2-mppa_k1c b/test/regression/Results/varargs2-mppa_k1c
new file mode 100644
index 00000000..f954927e
--- /dev/null
+++ b/test/regression/Results/varargs2-mppa_k1c
@@ -0,0 +1,11 @@
+An int: 42
+A long long: 123456789012345
+A string: Hello world
+A double: 3.141592654
+A mixture: x & Hello, world! & 42 & 123456789012345 & 3.141592654 & 2.718281746
+Twice: -1 1.23
+Twice: -1 1.23
+With va_copy: -1 1.23
+With va_copy: -1 1.23
+With extra args: x & Hello, world! & 42 & 123456789012345 & 3.141592654 & 2.718281746
+va_list compatibility: x & Hello, world! & 42 & 123456789012345 & 3.141592654 & 2.718281746
diff --git a/test/regression/builtins-aarch64.c b/test/regression/builtins-aarch64.c
new file mode 100644
index 00000000..2cfa2d09
--- /dev/null
+++ b/test/regression/builtins-aarch64.c
@@ -0,0 +1,47 @@
+/* Fun with builtin functions */
+
+#include <stdio.h>
+
+int main(int argc, char ** argv)
+{
+ unsigned int x = 0x12345678;
+ unsigned int y = 0xDEADBEEF;
+ unsigned long long xx = 0x1234567812345678ULL;
+ unsigned long long yy = 0x1234567800000000ULL;
+ unsigned long long zz = 0x123456789ABCDEF0ULL;
+ unsigned z;
+ double a = 3.14159;
+ double b = 2.718;
+ double c = 1.414;
+ unsigned short s = 0x1234;
+ signed int u = 1234567;
+ signed int v = -9999;
+
+ printf("bswap(%x) = %x\n", x, __builtin_bswap(x));
+ printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s));
+ printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz));
+ printf("clz(%x) = %d\n", x, __builtin_clz(x));
+ printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x));
+ printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx));
+ printf("cls(%d) = %d\n", u, __builtin_cls(u));
+ printf("cls(%d) = %d\n", v, __builtin_cls(v));
+ printf("clsll(%lld) = %d\n", (signed long long) u, __builtin_clsll(u));
+ printf("clsll(%lld) = %d\n", (signed long long) v, __builtin_clsll(v));
+
+ printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a));
+ printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c));
+ printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c));
+ printf("fnmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmadd(a, b, c));
+ printf("fnmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fnmsub(a, b, c));
+
+ /* Make sure that ignoring the result of a builtin
+ doesn't cause an internal error */
+ (void) __builtin_bswap(x);
+ (void) __builtin_fsqrt(a);
+ return 0;
+}
+
+
+
+
+
diff --git a/test/regression/builtins-arm.c b/test/regression/builtins-arm.c
index 709343ce..d06e8e5e 100644
--- a/test/regression/builtins-arm.c
+++ b/test/regression/builtins-arm.c
@@ -2,14 +2,15 @@
#include <stdio.h>
+unsigned int x = 0x12345678;
+unsigned int y = 0xDEADBEEF;
+unsigned long long xx = 0x1234567812345678ULL;
+double a = 3.14159;
+unsigned short s = 0x1234;
+
int main(int argc, char ** argv)
{
- unsigned int x = 0x12345678;
- unsigned int y = 0xDEADBEEF;
- unsigned long long xx = 0x1234567812345678ULL;
unsigned z;
- double a = 3.14159;
- unsigned short s = 0x1234;
printf("bswap(%x) = %x\n", x, __builtin_bswap(x));
printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s));
diff --git a/test/regression/builtins-mppa_k1c.c b/test/regression/builtins-mppa_k1c.c
new file mode 100644
index 00000000..cbf51387
--- /dev/null
+++ b/test/regression/builtins-mppa_k1c.c
@@ -0,0 +1,72 @@
+/* Fun with builtins */
+
+#include <stdio.h>
+#include <math.h>
+
+char * check_relative_error(double exact, double actual, double precision)
+{
+ double relative_error = (actual - exact) / exact;
+ return fabs(relative_error) <= precision ? "OK" : "ERROR";
+}
+
+//unsigned int x = 0x12345678;
+//unsigned int y = 0xDEADBEEF;
+//unsigned long long xx = 0x1234567812345678ULL;
+//double a = 3.14159;
+//double b = 2.718;
+//double c = 1.414;
+//unsigned short s = 0x1234;
+
+int main(int argc, char ** argv)
+{
+ unsigned z;
+
+ //printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y));
+ //printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y));
+ //printf("clz(%x) = %d\n", x, __builtin_clz(x));
+ //printf("clzll(%llx) = %d\n", (unsigned long long) x, __builtin_clzll(x));
+ //printf("clzll(%llx) = %d\n", xx, __builtin_clzll(xx));
+ //z = __builtin_bswap(x);
+ //printf("clzll(%lx) = %d\n", z, __builtin_clzll(z));
+ //printf("bswap(%x) = %x\n", x, __builtin_bswap(x));
+ //printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s));
+
+ //printf("fmadd(%f, %f, %f) = %f\n", a, b, c, __builtin_fmadd(a, b, c));
+ //printf("fmsub(%f, %f, %f) = %f\n", a, b, c, __builtin_fmsub(a, b, c));
+ //printf("fabs(%f) = %f\n", a, __builtin_fabs(a));
+ //printf("fabs(%f) = %f\n", -a, __builtin_fabs(-a));
+ //printf("fsqrt(%f) = %f\n", a, __builtin_fsqrt(a));
+ //printf("frsqrte(%f) = %s\n",
+ // a, check_relative_error(1.0 / sqrt(a), __builtin_frsqrte(a), 1./32.));
+ //printf("fres(%f) = %s\n",
+ // a, check_relative_error(1.0 / a, __builtin_fres(a), 1./256.));
+ //printf("fsel(%f, %f, %f) = %f\n", a, b, c, __builtin_fsel(a, b, c));
+ //printf("fsel(%f, %f, %f) = %f\n", -a, b, c, __builtin_fsel(-a, b, c));
+ //printf("fcti(%f) = %d\n", a, __builtin_fcti(a));
+ //printf("fcti(%f) = %d\n", b, __builtin_fcti(b));
+ //printf("fcti(%f) = %d\n", c, __builtin_fcti(c));
+ //__builtin_eieio();
+ //__builtin_sync();
+ //__builtin_isync();
+ //printf("isel(%d, %d, %d) = %d\n", 0, x, y, __builtin_isel(0, x, y));
+ //printf("isel(%d, %d, %d) = %d\n", 42, x, y, __builtin_isel(42, x, y));
+ //printf ("read_16_rev = %x\n", __builtin_read16_reversed(&s));
+ //printf ("read_32_rev = %x\n", __builtin_read32_reversed(&y));
+ //__builtin_write16_reversed(&s, 0x789A);
+ //printf ("after write_16_rev: %x\n", s);
+ //__builtin_write32_reversed(&y, 0x12345678);
+ //printf ("after write_32_rev: %x\n", y);
+ //y = 0;
+ //__builtin_write32_reversed(&y, 0x12345678);
+ //printf ("CSE write_32_rev: %s\n", y == 0x78563412 ? "ok" : "ERROR");
+ ///* Make sure that ignoring the result of a builtin
+ // doesn't cause an internal error */
+ //(void) __builtin_bswap(x);
+ //(void) __builtin_fsqrt(a);
+ return 0;
+}
+
+
+
+
+
diff --git a/test/regression/builtins-powerpc.c b/test/regression/builtins-powerpc.c
index 23e9d191..8fd5818b 100644
--- a/test/regression/builtins-powerpc.c
+++ b/test/regression/builtins-powerpc.c
@@ -9,16 +9,17 @@ char * check_relative_error(double exact, double actual, double precision)
return fabs(relative_error) <= precision ? "OK" : "ERROR";
}
+unsigned int x = 0x12345678;
+unsigned int y = 0xDEADBEEF;
+unsigned long long xx = 0x1234567812345678ULL;
+double a = 3.14159;
+double b = 2.718;
+double c = 1.414;
+unsigned short s = 0x1234;
+
int main(int argc, char ** argv)
{
- unsigned int x = 0x12345678;
- unsigned int y = 0xDEADBEEF;
- unsigned long long xx = 0x1234567812345678ULL;
unsigned z;
- double a = 3.14159;
- double b = 2.718;
- double c = 1.414;
- unsigned short s = 0x1234;
printf("mulhw(%x, %x) = %x\n", x, y, __builtin_mulhw(x, y));
printf("mulhwu(%x, %x) = %x\n", x, y, __builtin_mulhwu(x, y));
diff --git a/test/regression/builtins-riscV.c b/test/regression/builtins-riscV.c
index a302a6c4..c34fdf2c 100644
--- a/test/regression/builtins-riscV.c
+++ b/test/regression/builtins-riscV.c
@@ -2,15 +2,15 @@
#include <stdio.h>
+unsigned int x = 0x12345678;
+unsigned short s = 0x1234;
+unsigned long long zz = 0x123456789ABCDEF0ULL;
+double a = 3.14159;
+double b = 2.718;
+double c = 1.414;
+
int main(int argc, char ** argv)
{
- unsigned int x = 0x12345678;
- unsigned short s = 0x1234;
- unsigned long long zz = 0x123456789ABCDEF0ULL;
- double a = 3.14159;
- double b = 2.718;
- double c = 1.414;
-
printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s));
printf("bswap32(%x) = %x\n", x, __builtin_bswap32(x));
printf("bswap64(%llx) = %llx\n", zz, __builtin_bswap64(zz));
diff --git a/test/regression/builtins-x86.c b/test/regression/builtins-x86.c
index 1ba213e7..6233f9fd 100644
--- a/test/regression/builtins-x86.c
+++ b/test/regression/builtins-x86.c
@@ -2,18 +2,19 @@
#include <stdio.h>
+unsigned int x = 0x12345678;
+unsigned int y = 0xDEADBEEF;
+unsigned long long xx = 0x1234567812345678ULL;
+unsigned long long yy = 0x1234567800000000ULL;
+unsigned long long zz = 0x123456789ABCDEF0ULL;
+double a = 3.14159;
+double b = 2.718;
+double c = 1.414;
+unsigned short s = 0x1234;
+
int main(int argc, char ** argv)
{
- unsigned int x = 0x12345678;
- unsigned int y = 0xDEADBEEF;
- unsigned long long xx = 0x1234567812345678ULL;
- unsigned long long yy = 0x1234567800000000ULL;
- unsigned long long zz = 0x123456789ABCDEF0ULL;
unsigned z;
- double a = 3.14159;
- double b = 2.718;
- double c = 1.414;
- unsigned short s = 0x1234;
printf("bswap(%x) = %x\n", x, __builtin_bswap(x));
printf("bswap16(%x) = %x\n", s, __builtin_bswap16(s));
diff --git a/test/regression/extasm.c b/test/regression/extasm.c
index babc57f1..352b930b 100644
--- a/test/regression/extasm.c
+++ b/test/regression/extasm.c
@@ -5,14 +5,16 @@ int clobbers(int x, int z)
{
int y;
asm("TEST0 out:%0 in:%1" : "=r"(y) : "r"(x) : "cc"
-#if defined(__x86_64__)
+#if defined(ARCH_x86) && defined(MODEL_64)
, "rax", "rdx", "rbx"
-#elif defined(__i386__)
+#elif defined(ARCH_x86) && !defined(MODEL_64)
, "eax", "edx", "ebx"
-#elif defined(__arm__)
+#elif defined(ARCH_arm)
, "r0", "r1", "r4"
-#elif defined(__PPC__)
+#elif defined(ARCH_powerpc)
, "r0", "r3", "r4", "r31"
+#elif defined(ARCH_aarch64)
+ , "x0", "x1", "x16", "x29", "x30"
#endif
);
return y + z;
@@ -21,7 +23,9 @@ int clobbers(int x, int z)
#if (defined(ARCH_x86) && defined(MODEL_64)) \
|| (defined(ARCH_riscV) && defined(MODEL_64)) \
|| (defined(ARCH_powerpc) && defined(MODEL_ppc64)) \
- || (defined(ARCH_powerpc) && defined(MODEL_e5500))
+ || (defined(ARCH_powerpc) && defined(MODEL_e5500)) \
+ || (defined(ARCH_mppa_k1c) && defined(MODEL_64)) \
+ || defined(ARCH_aarch64)
#define SIXTYFOUR
#else
#undef SIXTYFOUR
@@ -33,6 +37,7 @@ int main()
void * y;
long long z;
double f;
+ float sf;
char c[16];
/* No inputs, no outputs */
@@ -72,6 +77,15 @@ int main()
#ifdef FAILURES
asm("FAIL4 a:%[a]" : "=r"(x) : [z]"i"(0));
#endif
+ /* One argument of each type */
+ asm("TEST15 int32 %0" : : "r" (x));
+#ifdef SIXTYFOUR
+ asm("TEST15 int64 %0" : : "r" (z));
+#else
+ asm("TEST15 int64 %Q0 / %R0" : : "r" (z));
+#endif
+ asm("TEST15 float64 %0" : : "r" (f));
+ asm("TEST15 float32 %0" : : "r" (sf));
/* Various failures */
#ifdef FAILURES
asm("FAIL5 out:%0,%1" : "=r"(x), "=r"(y));
diff --git a/test/regression/floats-basics.c b/test/regression/floats-basics.c
index a0225181..876a0d42 100644
--- a/test/regression/floats-basics.c
+++ b/test/regression/floats-basics.c
@@ -1,18 +1,10 @@
-#include<stdio.h>
-#include<stdlib.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "../endian.h"
#define STR_EXPAND(tok) #tok
#define STR(tok) STR_EXPAND(tok)
-#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__)
-#define ARCH_BIG_ENDIAN
-#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \
- || defined(__riscv) || defined(__K1C__)
-#undef ARCH_BIG_ENDIAN
-#else
-#error "unknown endianness"
-#endif
-
union converter64 {
double dbl;
struct {
diff --git a/test/regression/floats-lit.c b/test/regression/floats-lit.c
new file mode 100644
index 00000000..a1098faf
--- /dev/null
+++ b/test/regression/floats-lit.c
@@ -0,0 +1,559 @@
+#include <stdio.h>
+
+int error = 0;
+
+void dbl(double x, unsigned long long bits)
+{
+ union { double d; unsigned long long i; } u;
+ u.d = x;
+ if (u.i != bits) {
+ printf("Error: expected 0x%016llx, got 0x%016llx\n", bits, u.i);
+ error = 1;
+ }
+}
+
+void sng(float x, unsigned int bits)
+{
+ union { float f; unsigned int i; } u;
+ u.f = x;
+ if (u.i != bits) {
+ printf("Error: expected 0x%08x, got 0x%08x\n", bits, u.i);
+ error = 1;
+ }
+}
+
+void testdbl(void)
+{
+ printf("--- Double-precision test\n");
+ dbl(0.0, 0ULL);
+ dbl((-0.0), 0x8000000000000000ULL);
+ // The following are the "fmov immediate" of aarch64
+ // They include +1.0 and -1.0
+ dbl(0x1p-3, 0x3fc0000000000000ULL);
+ dbl(0x1.1p-3, 0x3fc1000000000000ULL);
+ dbl(0x1.2p-3, 0x3fc2000000000000ULL);
+ dbl(0x1.3p-3, 0x3fc3000000000000ULL);
+ dbl(0x1.4p-3, 0x3fc4000000000000ULL);
+ dbl(0x1.5p-3, 0x3fc5000000000000ULL);
+ dbl(0x1.6p-3, 0x3fc6000000000000ULL);
+ dbl(0x1.7p-3, 0x3fc7000000000000ULL);
+ dbl(0x1.8p-3, 0x3fc8000000000000ULL);
+ dbl(0x1.9p-3, 0x3fc9000000000000ULL);
+ dbl(0x1.ap-3, 0x3fca000000000000ULL);
+ dbl(0x1.bp-3, 0x3fcb000000000000ULL);
+ dbl(0x1.cp-3, 0x3fcc000000000000ULL);
+ dbl(0x1.dp-3, 0x3fcd000000000000ULL);
+ dbl(0x1.ep-3, 0x3fce000000000000ULL);
+ dbl(0x1.fp-3, 0x3fcf000000000000ULL);
+ dbl(0x1p-2, 0x3fd0000000000000ULL);
+ dbl(0x1.1p-2, 0x3fd1000000000000ULL);
+ dbl(0x1.2p-2, 0x3fd2000000000000ULL);
+ dbl(0x1.3p-2, 0x3fd3000000000000ULL);
+ dbl(0x1.4p-2, 0x3fd4000000000000ULL);
+ dbl(0x1.5p-2, 0x3fd5000000000000ULL);
+ dbl(0x1.6p-2, 0x3fd6000000000000ULL);
+ dbl(0x1.7p-2, 0x3fd7000000000000ULL);
+ dbl(0x1.8p-2, 0x3fd8000000000000ULL);
+ dbl(0x1.9p-2, 0x3fd9000000000000ULL);
+ dbl(0x1.ap-2, 0x3fda000000000000ULL);
+ dbl(0x1.bp-2, 0x3fdb000000000000ULL);
+ dbl(0x1.cp-2, 0x3fdc000000000000ULL);
+ dbl(0x1.dp-2, 0x3fdd000000000000ULL);
+ dbl(0x1.ep-2, 0x3fde000000000000ULL);
+ dbl(0x1.fp-2, 0x3fdf000000000000ULL);
+ dbl(0x1p-1, 0x3fe0000000000000ULL);
+ dbl(0x1.1p-1, 0x3fe1000000000000ULL);
+ dbl(0x1.2p-1, 0x3fe2000000000000ULL);
+ dbl(0x1.3p-1, 0x3fe3000000000000ULL);
+ dbl(0x1.4p-1, 0x3fe4000000000000ULL);
+ dbl(0x1.5p-1, 0x3fe5000000000000ULL);
+ dbl(0x1.6p-1, 0x3fe6000000000000ULL);
+ dbl(0x1.7p-1, 0x3fe7000000000000ULL);
+ dbl(0x1.8p-1, 0x3fe8000000000000ULL);
+ dbl(0x1.9p-1, 0x3fe9000000000000ULL);
+ dbl(0x1.ap-1, 0x3fea000000000000ULL);
+ dbl(0x1.bp-1, 0x3feb000000000000ULL);
+ dbl(0x1.cp-1, 0x3fec000000000000ULL);
+ dbl(0x1.dp-1, 0x3fed000000000000ULL);
+ dbl(0x1.ep-1, 0x3fee000000000000ULL);
+ dbl(0x1.fp-1, 0x3fef000000000000ULL);
+ dbl(0x1p+0, 0x3ff0000000000000ULL);
+ dbl(0x1.1p+0, 0x3ff1000000000000ULL);
+ dbl(0x1.2p+0, 0x3ff2000000000000ULL);
+ dbl(0x1.3p+0, 0x3ff3000000000000ULL);
+ dbl(0x1.4p+0, 0x3ff4000000000000ULL);
+ dbl(0x1.5p+0, 0x3ff5000000000000ULL);
+ dbl(0x1.6p+0, 0x3ff6000000000000ULL);
+ dbl(0x1.7p+0, 0x3ff7000000000000ULL);
+ dbl(0x1.8p+0, 0x3ff8000000000000ULL);
+ dbl(0x1.9p+0, 0x3ff9000000000000ULL);
+ dbl(0x1.ap+0, 0x3ffa000000000000ULL);
+ dbl(0x1.bp+0, 0x3ffb000000000000ULL);
+ dbl(0x1.cp+0, 0x3ffc000000000000ULL);
+ dbl(0x1.dp+0, 0x3ffd000000000000ULL);
+ dbl(0x1.ep+0, 0x3ffe000000000000ULL);
+ dbl(0x1.fp+0, 0x3fff000000000000ULL);
+ dbl(0x1p+1, 0x4000000000000000ULL);
+ dbl(0x1.1p+1, 0x4001000000000000ULL);
+ dbl(0x1.2p+1, 0x4002000000000000ULL);
+ dbl(0x1.3p+1, 0x4003000000000000ULL);
+ dbl(0x1.4p+1, 0x4004000000000000ULL);
+ dbl(0x1.5p+1, 0x4005000000000000ULL);
+ dbl(0x1.6p+1, 0x4006000000000000ULL);
+ dbl(0x1.7p+1, 0x4007000000000000ULL);
+ dbl(0x1.8p+1, 0x4008000000000000ULL);
+ dbl(0x1.9p+1, 0x4009000000000000ULL);
+ dbl(0x1.ap+1, 0x400a000000000000ULL);
+ dbl(0x1.bp+1, 0x400b000000000000ULL);
+ dbl(0x1.cp+1, 0x400c000000000000ULL);
+ dbl(0x1.dp+1, 0x400d000000000000ULL);
+ dbl(0x1.ep+1, 0x400e000000000000ULL);
+ dbl(0x1.fp+1, 0x400f000000000000ULL);
+ dbl(0x1p+2, 0x4010000000000000ULL);
+ dbl(0x1.1p+2, 0x4011000000000000ULL);
+ dbl(0x1.2p+2, 0x4012000000000000ULL);
+ dbl(0x1.3p+2, 0x4013000000000000ULL);
+ dbl(0x1.4p+2, 0x4014000000000000ULL);
+ dbl(0x1.5p+2, 0x4015000000000000ULL);
+ dbl(0x1.6p+2, 0x4016000000000000ULL);
+ dbl(0x1.7p+2, 0x4017000000000000ULL);
+ dbl(0x1.8p+2, 0x4018000000000000ULL);
+ dbl(0x1.9p+2, 0x4019000000000000ULL);
+ dbl(0x1.ap+2, 0x401a000000000000ULL);
+ dbl(0x1.bp+2, 0x401b000000000000ULL);
+ dbl(0x1.cp+2, 0x401c000000000000ULL);
+ dbl(0x1.dp+2, 0x401d000000000000ULL);
+ dbl(0x1.ep+2, 0x401e000000000000ULL);
+ dbl(0x1.fp+2, 0x401f000000000000ULL);
+ dbl(0x1p+3, 0x4020000000000000ULL);
+ dbl(0x1.1p+3, 0x4021000000000000ULL);
+ dbl(0x1.2p+3, 0x4022000000000000ULL);
+ dbl(0x1.3p+3, 0x4023000000000000ULL);
+ dbl(0x1.4p+3, 0x4024000000000000ULL);
+ dbl(0x1.5p+3, 0x4025000000000000ULL);
+ dbl(0x1.6p+3, 0x4026000000000000ULL);
+ dbl(0x1.7p+3, 0x4027000000000000ULL);
+ dbl(0x1.8p+3, 0x4028000000000000ULL);
+ dbl(0x1.9p+3, 0x4029000000000000ULL);
+ dbl(0x1.ap+3, 0x402a000000000000ULL);
+ dbl(0x1.bp+3, 0x402b000000000000ULL);
+ dbl(0x1.cp+3, 0x402c000000000000ULL);
+ dbl(0x1.dp+3, 0x402d000000000000ULL);
+ dbl(0x1.ep+3, 0x402e000000000000ULL);
+ dbl(0x1.fp+3, 0x402f000000000000ULL);
+ dbl(0x1p+4, 0x4030000000000000ULL);
+ dbl(0x1.1p+4, 0x4031000000000000ULL);
+ dbl(0x1.2p+4, 0x4032000000000000ULL);
+ dbl(0x1.3p+4, 0x4033000000000000ULL);
+ dbl(0x1.4p+4, 0x4034000000000000ULL);
+ dbl(0x1.5p+4, 0x4035000000000000ULL);
+ dbl(0x1.6p+4, 0x4036000000000000ULL);
+ dbl(0x1.7p+4, 0x4037000000000000ULL);
+ dbl(0x1.8p+4, 0x4038000000000000ULL);
+ dbl(0x1.9p+4, 0x4039000000000000ULL);
+ dbl(0x1.ap+4, 0x403a000000000000ULL);
+ dbl(0x1.bp+4, 0x403b000000000000ULL);
+ dbl(0x1.cp+4, 0x403c000000000000ULL);
+ dbl(0x1.dp+4, 0x403d000000000000ULL);
+ dbl(0x1.ep+4, 0x403e000000000000ULL);
+ dbl(0x1.fp+4, 0x403f000000000000ULL);
+ dbl((-0x1p-3), 0xbfc0000000000000ULL);
+ dbl((-0x1.1p-3), 0xbfc1000000000000ULL);
+ dbl((-0x1.2p-3), 0xbfc2000000000000ULL);
+ dbl((-0x1.3p-3), 0xbfc3000000000000ULL);
+ dbl((-0x1.4p-3), 0xbfc4000000000000ULL);
+ dbl((-0x1.5p-3), 0xbfc5000000000000ULL);
+ dbl((-0x1.6p-3), 0xbfc6000000000000ULL);
+ dbl((-0x1.7p-3), 0xbfc7000000000000ULL);
+ dbl((-0x1.8p-3), 0xbfc8000000000000ULL);
+ dbl((-0x1.9p-3), 0xbfc9000000000000ULL);
+ dbl((-0x1.ap-3), 0xbfca000000000000ULL);
+ dbl((-0x1.bp-3), 0xbfcb000000000000ULL);
+ dbl((-0x1.cp-3), 0xbfcc000000000000ULL);
+ dbl((-0x1.dp-3), 0xbfcd000000000000ULL);
+ dbl((-0x1.ep-3), 0xbfce000000000000ULL);
+ dbl((-0x1.fp-3), 0xbfcf000000000000ULL);
+ dbl((-0x1p-2), 0xbfd0000000000000ULL);
+ dbl((-0x1.1p-2), 0xbfd1000000000000ULL);
+ dbl((-0x1.2p-2), 0xbfd2000000000000ULL);
+ dbl((-0x1.3p-2), 0xbfd3000000000000ULL);
+ dbl((-0x1.4p-2), 0xbfd4000000000000ULL);
+ dbl((-0x1.5p-2), 0xbfd5000000000000ULL);
+ dbl((-0x1.6p-2), 0xbfd6000000000000ULL);
+ dbl((-0x1.7p-2), 0xbfd7000000000000ULL);
+ dbl((-0x1.8p-2), 0xbfd8000000000000ULL);
+ dbl((-0x1.9p-2), 0xbfd9000000000000ULL);
+ dbl((-0x1.ap-2), 0xbfda000000000000ULL);
+ dbl((-0x1.bp-2), 0xbfdb000000000000ULL);
+ dbl((-0x1.cp-2), 0xbfdc000000000000ULL);
+ dbl((-0x1.dp-2), 0xbfdd000000000000ULL);
+ dbl((-0x1.ep-2), 0xbfde000000000000ULL);
+ dbl((-0x1.fp-2), 0xbfdf000000000000ULL);
+ dbl((-0x1p-1), 0xbfe0000000000000ULL);
+ dbl((-0x1.1p-1), 0xbfe1000000000000ULL);
+ dbl((-0x1.2p-1), 0xbfe2000000000000ULL);
+ dbl((-0x1.3p-1), 0xbfe3000000000000ULL);
+ dbl((-0x1.4p-1), 0xbfe4000000000000ULL);
+ dbl((-0x1.5p-1), 0xbfe5000000000000ULL);
+ dbl((-0x1.6p-1), 0xbfe6000000000000ULL);
+ dbl((-0x1.7p-1), 0xbfe7000000000000ULL);
+ dbl((-0x1.8p-1), 0xbfe8000000000000ULL);
+ dbl((-0x1.9p-1), 0xbfe9000000000000ULL);
+ dbl((-0x1.ap-1), 0xbfea000000000000ULL);
+ dbl((-0x1.bp-1), 0xbfeb000000000000ULL);
+ dbl((-0x1.cp-1), 0xbfec000000000000ULL);
+ dbl((-0x1.dp-1), 0xbfed000000000000ULL);
+ dbl((-0x1.ep-1), 0xbfee000000000000ULL);
+ dbl((-0x1.fp-1), 0xbfef000000000000ULL);
+ dbl((-0x1p+0), 0xbff0000000000000ULL);
+ dbl((-0x1.1p+0), 0xbff1000000000000ULL);
+ dbl((-0x1.2p+0), 0xbff2000000000000ULL);
+ dbl((-0x1.3p+0), 0xbff3000000000000ULL);
+ dbl((-0x1.4p+0), 0xbff4000000000000ULL);
+ dbl((-0x1.5p+0), 0xbff5000000000000ULL);
+ dbl((-0x1.6p+0), 0xbff6000000000000ULL);
+ dbl((-0x1.7p+0), 0xbff7000000000000ULL);
+ dbl((-0x1.8p+0), 0xbff8000000000000ULL);
+ dbl((-0x1.9p+0), 0xbff9000000000000ULL);
+ dbl((-0x1.ap+0), 0xbffa000000000000ULL);
+ dbl((-0x1.bp+0), 0xbffb000000000000ULL);
+ dbl((-0x1.cp+0), 0xbffc000000000000ULL);
+ dbl((-0x1.dp+0), 0xbffd000000000000ULL);
+ dbl((-0x1.ep+0), 0xbffe000000000000ULL);
+ dbl((-0x1.fp+0), 0xbfff000000000000ULL);
+ dbl((-0x1p+1), 0xc000000000000000ULL);
+ dbl((-0x1.1p+1), 0xc001000000000000ULL);
+ dbl((-0x1.2p+1), 0xc002000000000000ULL);
+ dbl((-0x1.3p+1), 0xc003000000000000ULL);
+ dbl((-0x1.4p+1), 0xc004000000000000ULL);
+ dbl((-0x1.5p+1), 0xc005000000000000ULL);
+ dbl((-0x1.6p+1), 0xc006000000000000ULL);
+ dbl((-0x1.7p+1), 0xc007000000000000ULL);
+ dbl((-0x1.8p+1), 0xc008000000000000ULL);
+ dbl((-0x1.9p+1), 0xc009000000000000ULL);
+ dbl((-0x1.ap+1), 0xc00a000000000000ULL);
+ dbl((-0x1.bp+1), 0xc00b000000000000ULL);
+ dbl((-0x1.cp+1), 0xc00c000000000000ULL);
+ dbl((-0x1.dp+1), 0xc00d000000000000ULL);
+ dbl((-0x1.ep+1), 0xc00e000000000000ULL);
+ dbl((-0x1.fp+1), 0xc00f000000000000ULL);
+ dbl((-0x1p+2), 0xc010000000000000ULL);
+ dbl((-0x1.1p+2), 0xc011000000000000ULL);
+ dbl((-0x1.2p+2), 0xc012000000000000ULL);
+ dbl((-0x1.3p+2), 0xc013000000000000ULL);
+ dbl((-0x1.4p+2), 0xc014000000000000ULL);
+ dbl((-0x1.5p+2), 0xc015000000000000ULL);
+ dbl((-0x1.6p+2), 0xc016000000000000ULL);
+ dbl((-0x1.7p+2), 0xc017000000000000ULL);
+ dbl((-0x1.8p+2), 0xc018000000000000ULL);
+ dbl((-0x1.9p+2), 0xc019000000000000ULL);
+ dbl((-0x1.ap+2), 0xc01a000000000000ULL);
+ dbl((-0x1.bp+2), 0xc01b000000000000ULL);
+ dbl((-0x1.cp+2), 0xc01c000000000000ULL);
+ dbl((-0x1.dp+2), 0xc01d000000000000ULL);
+ dbl((-0x1.ep+2), 0xc01e000000000000ULL);
+ dbl((-0x1.fp+2), 0xc01f000000000000ULL);
+ dbl((-0x1p+3), 0xc020000000000000ULL);
+ dbl((-0x1.1p+3), 0xc021000000000000ULL);
+ dbl((-0x1.2p+3), 0xc022000000000000ULL);
+ dbl((-0x1.3p+3), 0xc023000000000000ULL);
+ dbl((-0x1.4p+3), 0xc024000000000000ULL);
+ dbl((-0x1.5p+3), 0xc025000000000000ULL);
+ dbl((-0x1.6p+3), 0xc026000000000000ULL);
+ dbl((-0x1.7p+3), 0xc027000000000000ULL);
+ dbl((-0x1.8p+3), 0xc028000000000000ULL);
+ dbl((-0x1.9p+3), 0xc029000000000000ULL);
+ dbl((-0x1.ap+3), 0xc02a000000000000ULL);
+ dbl((-0x1.bp+3), 0xc02b000000000000ULL);
+ dbl((-0x1.cp+3), 0xc02c000000000000ULL);
+ dbl((-0x1.dp+3), 0xc02d000000000000ULL);
+ dbl((-0x1.ep+3), 0xc02e000000000000ULL);
+ dbl((-0x1.fp+3), 0xc02f000000000000ULL);
+ dbl((-0x1p+4), 0xc030000000000000ULL);
+ dbl((-0x1.1p+4), 0xc031000000000000ULL);
+ dbl((-0x1.2p+4), 0xc032000000000000ULL);
+ dbl((-0x1.3p+4), 0xc033000000000000ULL);
+ dbl((-0x1.4p+4), 0xc034000000000000ULL);
+ dbl((-0x1.5p+4), 0xc035000000000000ULL);
+ dbl((-0x1.6p+4), 0xc036000000000000ULL);
+ dbl((-0x1.7p+4), 0xc037000000000000ULL);
+ dbl((-0x1.8p+4), 0xc038000000000000ULL);
+ dbl((-0x1.9p+4), 0xc039000000000000ULL);
+ dbl((-0x1.ap+4), 0xc03a000000000000ULL);
+ dbl((-0x1.bp+4), 0xc03b000000000000ULL);
+ dbl((-0x1.cp+4), 0xc03c000000000000ULL);
+ dbl((-0x1.dp+4), 0xc03d000000000000ULL);
+ dbl((-0x1.ep+4), 0xc03e000000000000ULL);
+ dbl((-0x1.fp+4), 0xc03f000000000000ULL);
+}
+
+void testsng(void)
+{
+ printf("--- Single-precision test\n");
+ sng(0x0p+0, 0x0U);
+ sng(-0x0p+0, 0x80000000U);
+ sng(0x1p-3, 0x3e000000U);
+ sng(0x1.1p-3, 0x3e080000U);
+ sng(0x1.2p-3, 0x3e100000U);
+ sng(0x1.3p-3, 0x3e180000U);
+ sng(0x1.4p-3, 0x3e200000U);
+ sng(0x1.5p-3, 0x3e280000U);
+ sng(0x1.6p-3, 0x3e300000U);
+ sng(0x1.7p-3, 0x3e380000U);
+ sng(0x1.8p-3, 0x3e400000U);
+ sng(0x1.9p-3, 0x3e480000U);
+ sng(0x1.ap-3, 0x3e500000U);
+ sng(0x1.bp-3, 0x3e580000U);
+ sng(0x1.cp-3, 0x3e600000U);
+ sng(0x1.dp-3, 0x3e680000U);
+ sng(0x1.ep-3, 0x3e700000U);
+ sng(0x1.fp-3, 0x3e780000U);
+ sng(0x1p-2, 0x3e800000U);
+ sng(0x1.1p-2, 0x3e880000U);
+ sng(0x1.2p-2, 0x3e900000U);
+ sng(0x1.3p-2, 0x3e980000U);
+ sng(0x1.4p-2, 0x3ea00000U);
+ sng(0x1.5p-2, 0x3ea80000U);
+ sng(0x1.6p-2, 0x3eb00000U);
+ sng(0x1.7p-2, 0x3eb80000U);
+ sng(0x1.8p-2, 0x3ec00000U);
+ sng(0x1.9p-2, 0x3ec80000U);
+ sng(0x1.ap-2, 0x3ed00000U);
+ sng(0x1.bp-2, 0x3ed80000U);
+ sng(0x1.cp-2, 0x3ee00000U);
+ sng(0x1.dp-2, 0x3ee80000U);
+ sng(0x1.ep-2, 0x3ef00000U);
+ sng(0x1.fp-2, 0x3ef80000U);
+ sng(0x1p-1, 0x3f000000U);
+ sng(0x1.1p-1, 0x3f080000U);
+ sng(0x1.2p-1, 0x3f100000U);
+ sng(0x1.3p-1, 0x3f180000U);
+ sng(0x1.4p-1, 0x3f200000U);
+ sng(0x1.5p-1, 0x3f280000U);
+ sng(0x1.6p-1, 0x3f300000U);
+ sng(0x1.7p-1, 0x3f380000U);
+ sng(0x1.8p-1, 0x3f400000U);
+ sng(0x1.9p-1, 0x3f480000U);
+ sng(0x1.ap-1, 0x3f500000U);
+ sng(0x1.bp-1, 0x3f580000U);
+ sng(0x1.cp-1, 0x3f600000U);
+ sng(0x1.dp-1, 0x3f680000U);
+ sng(0x1.ep-1, 0x3f700000U);
+ sng(0x1.fp-1, 0x3f780000U);
+ sng(0x1p+0, 0x3f800000U);
+ sng(0x1.1p+0, 0x3f880000U);
+ sng(0x1.2p+0, 0x3f900000U);
+ sng(0x1.3p+0, 0x3f980000U);
+ sng(0x1.4p+0, 0x3fa00000U);
+ sng(0x1.5p+0, 0x3fa80000U);
+ sng(0x1.6p+0, 0x3fb00000U);
+ sng(0x1.7p+0, 0x3fb80000U);
+ sng(0x1.8p+0, 0x3fc00000U);
+ sng(0x1.9p+0, 0x3fc80000U);
+ sng(0x1.ap+0, 0x3fd00000U);
+ sng(0x1.bp+0, 0x3fd80000U);
+ sng(0x1.cp+0, 0x3fe00000U);
+ sng(0x1.dp+0, 0x3fe80000U);
+ sng(0x1.ep+0, 0x3ff00000U);
+ sng(0x1.fp+0, 0x3ff80000U);
+ sng(0x1p+1, 0x40000000U);
+ sng(0x1.1p+1, 0x40080000U);
+ sng(0x1.2p+1, 0x40100000U);
+ sng(0x1.3p+1, 0x40180000U);
+ sng(0x1.4p+1, 0x40200000U);
+ sng(0x1.5p+1, 0x40280000U);
+ sng(0x1.6p+1, 0x40300000U);
+ sng(0x1.7p+1, 0x40380000U);
+ sng(0x1.8p+1, 0x40400000U);
+ sng(0x1.9p+1, 0x40480000U);
+ sng(0x1.ap+1, 0x40500000U);
+ sng(0x1.bp+1, 0x40580000U);
+ sng(0x1.cp+1, 0x40600000U);
+ sng(0x1.dp+1, 0x40680000U);
+ sng(0x1.ep+1, 0x40700000U);
+ sng(0x1.fp+1, 0x40780000U);
+ sng(0x1p+2, 0x40800000U);
+ sng(0x1.1p+2, 0x40880000U);
+ sng(0x1.2p+2, 0x40900000U);
+ sng(0x1.3p+2, 0x40980000U);
+ sng(0x1.4p+2, 0x40a00000U);
+ sng(0x1.5p+2, 0x40a80000U);
+ sng(0x1.6p+2, 0x40b00000U);
+ sng(0x1.7p+2, 0x40b80000U);
+ sng(0x1.8p+2, 0x40c00000U);
+ sng(0x1.9p+2, 0x40c80000U);
+ sng(0x1.ap+2, 0x40d00000U);
+ sng(0x1.bp+2, 0x40d80000U);
+ sng(0x1.cp+2, 0x40e00000U);
+ sng(0x1.dp+2, 0x40e80000U);
+ sng(0x1.ep+2, 0x40f00000U);
+ sng(0x1.fp+2, 0x40f80000U);
+ sng(0x1p+3, 0x41000000U);
+ sng(0x1.1p+3, 0x41080000U);
+ sng(0x1.2p+3, 0x41100000U);
+ sng(0x1.3p+3, 0x41180000U);
+ sng(0x1.4p+3, 0x41200000U);
+ sng(0x1.5p+3, 0x41280000U);
+ sng(0x1.6p+3, 0x41300000U);
+ sng(0x1.7p+3, 0x41380000U);
+ sng(0x1.8p+3, 0x41400000U);
+ sng(0x1.9p+3, 0x41480000U);
+ sng(0x1.ap+3, 0x41500000U);
+ sng(0x1.bp+3, 0x41580000U);
+ sng(0x1.cp+3, 0x41600000U);
+ sng(0x1.dp+3, 0x41680000U);
+ sng(0x1.ep+3, 0x41700000U);
+ sng(0x1.fp+3, 0x41780000U);
+ sng(0x1p+4, 0x41800000U);
+ sng(0x1.1p+4, 0x41880000U);
+ sng(0x1.2p+4, 0x41900000U);
+ sng(0x1.3p+4, 0x41980000U);
+ sng(0x1.4p+4, 0x41a00000U);
+ sng(0x1.5p+4, 0x41a80000U);
+ sng(0x1.6p+4, 0x41b00000U);
+ sng(0x1.7p+4, 0x41b80000U);
+ sng(0x1.8p+4, 0x41c00000U);
+ sng(0x1.9p+4, 0x41c80000U);
+ sng(0x1.ap+4, 0x41d00000U);
+ sng(0x1.bp+4, 0x41d80000U);
+ sng(0x1.cp+4, 0x41e00000U);
+ sng(0x1.dp+4, 0x41e80000U);
+ sng(0x1.ep+4, 0x41f00000U);
+ sng(0x1.fp+4, 0x41f80000U);
+ sng(-0x1p-3, 0xbe000000U);
+ sng(-0x1.1p-3, 0xbe080000U);
+ sng(-0x1.2p-3, 0xbe100000U);
+ sng(-0x1.3p-3, 0xbe180000U);
+ sng(-0x1.4p-3, 0xbe200000U);
+ sng(-0x1.5p-3, 0xbe280000U);
+ sng(-0x1.6p-3, 0xbe300000U);
+ sng(-0x1.7p-3, 0xbe380000U);
+ sng(-0x1.8p-3, 0xbe400000U);
+ sng(-0x1.9p-3, 0xbe480000U);
+ sng(-0x1.ap-3, 0xbe500000U);
+ sng(-0x1.bp-3, 0xbe580000U);
+ sng(-0x1.cp-3, 0xbe600000U);
+ sng(-0x1.dp-3, 0xbe680000U);
+ sng(-0x1.ep-3, 0xbe700000U);
+ sng(-0x1.fp-3, 0xbe780000U);
+ sng(-0x1p-2, 0xbe800000U);
+ sng(-0x1.1p-2, 0xbe880000U);
+ sng(-0x1.2p-2, 0xbe900000U);
+ sng(-0x1.3p-2, 0xbe980000U);
+ sng(-0x1.4p-2, 0xbea00000U);
+ sng(-0x1.5p-2, 0xbea80000U);
+ sng(-0x1.6p-2, 0xbeb00000U);
+ sng(-0x1.7p-2, 0xbeb80000U);
+ sng(-0x1.8p-2, 0xbec00000U);
+ sng(-0x1.9p-2, 0xbec80000U);
+ sng(-0x1.ap-2, 0xbed00000U);
+ sng(-0x1.bp-2, 0xbed80000U);
+ sng(-0x1.cp-2, 0xbee00000U);
+ sng(-0x1.dp-2, 0xbee80000U);
+ sng(-0x1.ep-2, 0xbef00000U);
+ sng(-0x1.fp-2, 0xbef80000U);
+ sng(-0x1p-1, 0xbf000000U);
+ sng(-0x1.1p-1, 0xbf080000U);
+ sng(-0x1.2p-1, 0xbf100000U);
+ sng(-0x1.3p-1, 0xbf180000U);
+ sng(-0x1.4p-1, 0xbf200000U);
+ sng(-0x1.5p-1, 0xbf280000U);
+ sng(-0x1.6p-1, 0xbf300000U);
+ sng(-0x1.7p-1, 0xbf380000U);
+ sng(-0x1.8p-1, 0xbf400000U);
+ sng(-0x1.9p-1, 0xbf480000U);
+ sng(-0x1.ap-1, 0xbf500000U);
+ sng(-0x1.bp-1, 0xbf580000U);
+ sng(-0x1.cp-1, 0xbf600000U);
+ sng(-0x1.dp-1, 0xbf680000U);
+ sng(-0x1.ep-1, 0xbf700000U);
+ sng(-0x1.fp-1, 0xbf780000U);
+ sng(-0x1p+0, 0xbf800000U);
+ sng(-0x1.1p+0, 0xbf880000U);
+ sng(-0x1.2p+0, 0xbf900000U);
+ sng(-0x1.3p+0, 0xbf980000U);
+ sng(-0x1.4p+0, 0xbfa00000U);
+ sng(-0x1.5p+0, 0xbfa80000U);
+ sng(-0x1.6p+0, 0xbfb00000U);
+ sng(-0x1.7p+0, 0xbfb80000U);
+ sng(-0x1.8p+0, 0xbfc00000U);
+ sng(-0x1.9p+0, 0xbfc80000U);
+ sng(-0x1.ap+0, 0xbfd00000U);
+ sng(-0x1.bp+0, 0xbfd80000U);
+ sng(-0x1.cp+0, 0xbfe00000U);
+ sng(-0x1.dp+0, 0xbfe80000U);
+ sng(-0x1.ep+0, 0xbff00000U);
+ sng(-0x1.fp+0, 0xbff80000U);
+ sng(-0x1p+1, 0xc0000000U);
+ sng(-0x1.1p+1, 0xc0080000U);
+ sng(-0x1.2p+1, 0xc0100000U);
+ sng(-0x1.3p+1, 0xc0180000U);
+ sng(-0x1.4p+1, 0xc0200000U);
+ sng(-0x1.5p+1, 0xc0280000U);
+ sng(-0x1.6p+1, 0xc0300000U);
+ sng(-0x1.7p+1, 0xc0380000U);
+ sng(-0x1.8p+1, 0xc0400000U);
+ sng(-0x1.9p+1, 0xc0480000U);
+ sng(-0x1.ap+1, 0xc0500000U);
+ sng(-0x1.bp+1, 0xc0580000U);
+ sng(-0x1.cp+1, 0xc0600000U);
+ sng(-0x1.dp+1, 0xc0680000U);
+ sng(-0x1.ep+1, 0xc0700000U);
+ sng(-0x1.fp+1, 0xc0780000U);
+ sng(-0x1p+2, 0xc0800000U);
+ sng(-0x1.1p+2, 0xc0880000U);
+ sng(-0x1.2p+2, 0xc0900000U);
+ sng(-0x1.3p+2, 0xc0980000U);
+ sng(-0x1.4p+2, 0xc0a00000U);
+ sng(-0x1.5p+2, 0xc0a80000U);
+ sng(-0x1.6p+2, 0xc0b00000U);
+ sng(-0x1.7p+2, 0xc0b80000U);
+ sng(-0x1.8p+2, 0xc0c00000U);
+ sng(-0x1.9p+2, 0xc0c80000U);
+ sng(-0x1.ap+2, 0xc0d00000U);
+ sng(-0x1.bp+2, 0xc0d80000U);
+ sng(-0x1.cp+2, 0xc0e00000U);
+ sng(-0x1.dp+2, 0xc0e80000U);
+ sng(-0x1.ep+2, 0xc0f00000U);
+ sng(-0x1.fp+2, 0xc0f80000U);
+ sng(-0x1p+3, 0xc1000000U);
+ sng(-0x1.1p+3, 0xc1080000U);
+ sng(-0x1.2p+3, 0xc1100000U);
+ sng(-0x1.3p+3, 0xc1180000U);
+ sng(-0x1.4p+3, 0xc1200000U);
+ sng(-0x1.5p+3, 0xc1280000U);
+ sng(-0x1.6p+3, 0xc1300000U);
+ sng(-0x1.7p+3, 0xc1380000U);
+ sng(-0x1.8p+3, 0xc1400000U);
+ sng(-0x1.9p+3, 0xc1480000U);
+ sng(-0x1.ap+3, 0xc1500000U);
+ sng(-0x1.bp+3, 0xc1580000U);
+ sng(-0x1.cp+3, 0xc1600000U);
+ sng(-0x1.dp+3, 0xc1680000U);
+ sng(-0x1.ep+3, 0xc1700000U);
+ sng(-0x1.fp+3, 0xc1780000U);
+ sng(-0x1p+4, 0xc1800000U);
+ sng(-0x1.1p+4, 0xc1880000U);
+ sng(-0x1.2p+4, 0xc1900000U);
+ sng(-0x1.3p+4, 0xc1980000U);
+ sng(-0x1.4p+4, 0xc1a00000U);
+ sng(-0x1.5p+4, 0xc1a80000U);
+ sng(-0x1.6p+4, 0xc1b00000U);
+ sng(-0x1.7p+4, 0xc1b80000U);
+ sng(-0x1.8p+4, 0xc1c00000U);
+ sng(-0x1.9p+4, 0xc1c80000U);
+ sng(-0x1.ap+4, 0xc1d00000U);
+ sng(-0x1.bp+4, 0xc1d80000U);
+ sng(-0x1.cp+4, 0xc1e00000U);
+ sng(-0x1.dp+4, 0xc1e80000U);
+ sng(-0x1.ep+4, 0xc1f00000U);
+ sng(-0x1.fp+4, 0xc1f80000U);
+}
+
+
+int main()
+{
+ testdbl();
+ testsng();
+ return error;
+}
diff --git a/test/regression/floats.c b/test/regression/floats.c
index 55c9fd26..58c202ae 100644
--- a/test/regression/floats.c
+++ b/test/regression/floats.c
@@ -1,17 +1,9 @@
-#include<stdio.h>
+#include <stdio.h>
+#include "../endian.h"
#define STR_EXPAND(tok) #tok
#define STR(tok) STR_EXPAND(tok)
-#if defined(__ppc__) || defined(__PPC__) || defined(__ARMEB__)
-#define ARCH_BIG_ENDIAN
-#elif defined(__i386__) || defined(__x86_64__) || defined(__ARMEL__) \
- || defined(__riscv) || defined(__K1C__)
-#undef ARCH_BIG_ENDIAN
-#else
-#error "unknown endianness"
-#endif
-
union converter64 {
double dbl;
struct {
diff --git a/test/regression/ifconv.c b/test/regression/ifconv.c
new file mode 100644
index 00000000..e12a394c
--- /dev/null
+++ b/test/regression/ifconv.c
@@ -0,0 +1,149 @@
+#include <stdio.h>
+
+/* Several equivalent forms that should be turned into cmov */
+
+int test1(int x, int y, int a, int b)
+{
+ return x < y ? a : b;
+}
+
+int test2(int x, int y, int a, int b)
+{
+ int r;
+ if (x < y) { r = a; } else { r = b; }
+ return r;
+}
+
+int test3(int x, int y, int a, int b)
+{
+ int r = b;
+ if (x < y) { r = a; }
+ return r;
+}
+
+int test4(int x, int y, int a, int b)
+{
+ int r = a;
+ if (x < y) { /*skip*/; } else { r = b; }
+ return r;
+}
+
+/* A more advanced example */
+
+int test5(int x, int y, int a)
+{
+ return x < y ? a + 1 : a - 1;
+}
+
+/* Unsafe operations should not be turned into cmov */
+
+int test6(int * p)
+{
+ return p == NULL ? 0 : *p + 10;
+}
+
+int test7(int a, int b)
+{
+ return b == 0 ? -1 : a / b;
+}
+
+/* Very large operations should not be turned into cmov */
+
+int test8(int a)
+{
+ return a == 0 ? 0 : a*a*a*a - 2*a*a*a + 10*a*a + 42*a - 123;
+}
+
+/* Some examples with 64-bit integers */
+
+long long ltest1(int x, int y, long long a, long long b)
+{
+ return x < y ? a + 1 : b >> 2;
+}
+
+/* Some examples with floating-point */
+
+double dmax(double x, double y)
+{
+ return x >= y ? x : y;
+}
+
+double dabs(double x)
+{
+ return x < 0.0 ? -x : x;
+}
+
+float smin(float x, float y)
+{
+ return x <= y ? x : y;
+}
+
+float sdoz(float x, float y)
+{
+ return x >= y ? x - y : 0.0f;
+}
+
+/* Examples where constant propagation should take place */
+
+int constprop1(int x)
+{
+ int n = 0;
+ return n ? x : 42;
+}
+
+int constprop2(int x)
+{
+ int n = 1;
+ return n ? x : 42;
+}
+
+int constprop3(int x, int y)
+{
+ int n = 0;
+ return x < n ? y - 1 : y + 1;
+}
+
+/* Test harness */
+
+#define TESTI(call) printf(#call " = %d\n", call)
+#define TESTL(call) printf(#call " = %lld\n", call)
+#define TESTF(call) printf(#call " = %f\n", call)
+
+
+int main()
+{
+ int i = 1234;
+ TESTI(test1(0,1,12,34));
+ TESTI(test1(1,0,45,67));
+ TESTI(test2(0,1,12,34));
+ TESTI(test2(1,0,45,67));
+ TESTI(test3(0,1,12,34));
+ TESTI(test3(1,0,45,67));
+ TESTI(test4(0,1,12,34));
+ TESTI(test4(1,0,45,67));
+ TESTI(test5(0,1,12));
+ TESTI(test5(1,0,45));
+ TESTI(test6(NULL));
+ TESTI(test6(&i));
+ TESTI(test7(1,0));
+ TESTI(test7(-100,4));
+ TESTI(test8(0));
+ TESTI(test8(1));
+
+ TESTL(ltest1(-1, 0, 123LL, 456LL));
+ TESTL(ltest1(1, 0, 123LL, 456LL));
+
+ TESTF(dmax(0.0, 3.14));
+ TESTF(dmax(1.0, -2.718));
+
+ TESTF(dabs(1.0));
+ TESTF(dabs(-2.718));
+
+ TESTF(smin(0.0, 3.14));
+ TESTF(smin(1.0, -2.718));
+
+ TESTF(sdoz(1.0, 0.5));
+ TESTF(sdoz(0.0, 3.14));
+
+ return 0;
+}
diff --git a/test/regression/int64.c b/test/regression/int64.c
index d9785e95..0da9602d 100644
--- a/test/regression/int64.c
+++ b/test/regression/int64.c
@@ -103,7 +103,8 @@ u64 special_values[] = {
0x80000000LLU,
0x7FFFFFFFFFFFFFFFLLU,
0x8000000000000000LLU,
- 0x100000003LLU
+ 0x100000003LLU,
+ 0x52ce6b4000000063LLU
};
#define NUM_SPECIAL_VALUES (sizeof(special_values) / sizeof(u64))
diff --git a/test/regression/interop1.c b/test/regression/interop1.c
index a39f449c..6836b89e 100644
--- a/test/regression/interop1.c
+++ b/test/regression/interop1.c
@@ -195,6 +195,17 @@ RETURN(ru6,U6,init_U6)
RETURN(ru7,U7,init_U7)
RETURN(ru8,U8,init_U8)
+/* Returning small integers */
+
+#define SMALLINT(name,ty) \
+extern ty THEM(name)(int); \
+ty US(name)(int x) { return x * x; }
+
+SMALLINT(si8u, unsigned char)
+SMALLINT(si8s, signed char)
+SMALLINT(si16u, unsigned short)
+SMALLINT(si16s, signed short)
+
/* Test function, calling the functions compiled by the other compiler */
#define CALLPRINT(name,ty,init) \
@@ -207,6 +218,10 @@ RETURN(ru8,U8,init_U8)
extern void THEM(test) (void);
void US(test) (void)
{
+ printf("si8u: %d\n", THEM(si8u)(12345));
+ printf("si8s: %d\n", THEM(si8s)(12345));
+ printf("si16u: %d\n", THEM(si16u)(1234567));
+ printf("si16s: %d\n", THEM(si16s)(1234567));
CALLPRINT(s1,S1,init_S1)
CALLPRINT(s2,S2,init_S2)
CALLPRINT(s3,S3,init_S3)
diff --git a/test/regression/packedstruct1.c b/test/regression/packedstruct1.c
index 5d3e7124..b805c92a 100644
--- a/test/regression/packedstruct1.c
+++ b/test/regression/packedstruct1.c
@@ -2,8 +2,8 @@
#include <stdio.h>
-/* offsetof is the offset computed by the verified front-end (cfrontend/) */
-#define offsetof(s,f) (int)&(((struct s *)0)->f)
+/* offsetOf is the offset computed by the verified front-end (cfrontend/) */
+#define offsetOf(s,f) (int)&(((struct s *)0)->f)
/* boffsetof is the offset computed by the elaborator (cparser/) */
#define boffsetof(s,f) (int)__builtin_offsetof(struct s, f)
@@ -24,7 +24,7 @@ void test1(void)
printf("sizeof(struct s1) = %d\n", szof(s1));
printf("precomputed sizeof(struct s1) = %d\n", bszof(s1));
printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
- offsetof(s1,x), offsetof(s1,y), offsetof(s1,z));
+ offsetOf(s1,x), offsetOf(s1,y), offsetOf(s1,z));
printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
boffsetof(s1,x), boffsetof(s1,y), boffsetof(s1,z));
s1.x = 123; s1.y = -456; s1.z = 3.14159;
@@ -45,7 +45,7 @@ void test2(void)
printf("precomputed sizeof(struct s2) = %d\n", bszof(s2));
printf("&s2 mod 16 = %d\n", ((int) &s2) & 0xF);
printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
- offsetof(s2,x), offsetof(s2,y), offsetof(s2,z));
+ offsetOf(s2,x), offsetOf(s2,y), offsetOf(s2,z));
printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
boffsetof(s2,x), boffsetof(s2,y), boffsetof(s2,z));
s2.x = 12345; s2.y = -456; s2.z = 3.14159;
@@ -73,7 +73,7 @@ void test3(void)
printf("sizeof(struct s3) = %d\n", szof(s3));
printf("precomputed sizeof(struct s3) = %d\n", bszof(s3));
- printf("offsetof(s) = %d\n", offsetof(s3,s));
+ printf("offsetof(s) = %d\n", offsetOf(s3,s));
printf("precomputed offsetof(s) = %d\n", boffsetof(s3,s));
s3.x = 123;
s3.y = 45678;
@@ -104,7 +104,7 @@ void test4(void)
printf("sizeof(struct s4) = %d\n", szof(s4));
printf("precomputed sizeof(struct s4) = %d\n", bszof(s4));
printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
- offsetof(s4,x), offsetof(s4,y), offsetof(s4,z));
+ offsetOf(s4,x), offsetOf(s4,y), offsetOf(s4,z));
printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
boffsetof(s4,x), boffsetof(s4,y), boffsetof(s4,z));
s4.x = 123; s4.y = -456; s4.z = 3.14159;
@@ -122,7 +122,7 @@ void test5(void)
printf("sizeof(struct s5) = %d\n", szof(s5));
printf("precomputed sizeof(struct s5) = %d\n", bszof(s5));
printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
- offsetof(s5,x), offsetof(s5,y), offsetof(s5,z));
+ offsetOf(s5,x), offsetOf(s5,y), offsetOf(s5,z));
printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
boffsetof(s5,x), boffsetof(s5,y), boffsetof(s5,z));
s5.x = 123; s5.y = -456; s5.z = 3.14159;
@@ -140,7 +140,7 @@ void test6(void)
printf("sizeof(struct s6) = %d\n", szof(s6));
printf("precomputed sizeof(struct s6) = %d\n", bszof(s6));
printf("offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
- offsetof(s6,x), offsetof(s6,y), offsetof(s6,z));
+ offsetOf(s6,x), offsetOf(s6,y), offsetOf(s6,z));
printf("precomputed offsetof(x) = %d, offsetof(y) = %d, offsetof(z) = %d\n",
boffsetof(s6,x), boffsetof(s6,y), boffsetof(s6,z));
s62.x = 123; s62.y = -456; s62.z = 3.14159;
diff --git a/test/regression/varargs2.c b/test/regression/varargs2.c
index b96d1940..84860ef3 100644
--- a/test/regression/varargs2.c
+++ b/test/regression/varargs2.c
@@ -115,15 +115,27 @@ void printf_compat(const char * fmt, ...)
}
/* The test harness */
-
int main()
{
miniprintf("An int: %d\n", 42);
miniprintf("A long long: %l\n", 123456789012345LL);
miniprintf("A string: %s\n", "Hello world");
miniprintf("A double: %e\n", 3.141592654);
+
+#ifndef __K1C__
miniprintf("A small struct: %y\n", (struct Y) { 'x', 12 });
miniprintf("A bigger struct: %z\n", (struct Z) { 123, 456, 789 });
+#endif
+
+#ifdef __K1C__
+ miniprintf("A mixture: %c & %s & %d & %l & %e & %f\n",
+ 'x',
+ "Hello, world!",
+ 42,
+ 123456789012345LL,
+ 3.141592654,
+ 2.71828182);
+#else
miniprintf("A mixture: %c & %s & %y & %d & %l & %e & %f\n",
'x',
"Hello, world!",
@@ -132,6 +144,8 @@ int main()
123456789012345LL,
3.141592654,
2.71828182);
+#endif
+
miniprintf2("Twice: %d %e\n", -1, 1.23);
miniprintf3("With va_copy: %d %e\n", -1, 1.23);
miniprintf_extra(0, 1, 2, 3, 4, 5, 6, 7,
diff --git a/test/spass/Makefile b/test/spass/Makefile
index 0e89d6d1..d512ea95 100644
--- a/test/spass/Makefile
+++ b/test/spass/Makefile
@@ -24,11 +24,10 @@ clean:
test:
$(SIMU) ./spass small_problem.dfg | grep 'Proof found'
-TIME=xtime -o /dev/null # Xavier's hack
-#TIME=time >/dev/null # Otherwise
+TIME=ocaml unix.cma ../../tools/xtime.ml -o /dev/null -mintime 5.0
bench:
- @echo -n "spass: "; $(TIME) ./spass problem.dfg
+ @$(TIME) -name spass -- ./spass problem.dfg
depend:
gcc -MM $(SRCS) > .depend
diff --git a/tools/ndfun.ml b/tools/ndfun.ml
index 2b8bcb19..b6a87ede 100644
--- a/tools/ndfun.ml
+++ b/tools/ndfun.ml
@@ -41,7 +41,9 @@ let trim s =
let str_match n re s =
if not (Str.string_match re s 0) then [||] else begin
let res = Array.make (n+1) "" in
- for i = 1 to n do res.(i) <- Str.matched_group i s done;
+ for i = 1 to n do
+ res.(i) <- (try Str.matched_group i s with Not_found -> "")
+ done;
for i = 1 to n do res.(i) <- trim res.(i) done;
res
end
@@ -87,6 +89,11 @@ let match_temps args =
let parenpats p =
"(" ^ Str.global_replace re_comma ") (" p ^ ")"
+(* "foo, bar, gee" -> "_ _ _" *)
+
+let underscores_for s =
+ Str.global_replace re_arg "_" (remove_commas s)
+
(* Extract the bound variables in a pattern. Heuristic: any identifier
that starts with a lowercase letter and is not "nil". *)
@@ -123,7 +130,7 @@ let re_nd = Str.regexp(
let re_split_cases = Str.regexp "|"
-let re_case = Str.regexp "\\(.*\\)=>\\(.*\\)"
+let re_case = Str.regexp "\\([^?]*\\)\\(\\?\\?\\(.*\\)\\)?=>\\(.*\\)"
let re_default_pat = Str.regexp "[ _,]*$"
@@ -165,16 +172,20 @@ let transl_ndfun filename lineno s =
(* Adding each case *)
let numcase = ref 0 in
let transl_case s =
- let res = str_match 2 re_case s in
+ let res = str_match 4 re_case s in
if Array.length res = 0 then
error filename lineno ("ill-formed case: " ^ s);
- let patlist = res.(1) and rhs = res.(2) in
+ let patlist = res.(1) and guard = res.(3) and rhs = res.(4) in
let bv = boundvarspat patlist in
if not (Str.string_match re_default_pat patlist 0) then begin
incr numcase;
bprintf a " | %s_case%d: forall %s, %s_cases %s\n"
name !numcase bv name (parenpats patlist);
- bprintf b " | %s => %s_case%d %s\n" patlist name !numcase bv;
+ if guard = "" then
+ bprintf b " | %s => %s_case%d %s\n" patlist name !numcase bv
+ else
+ bprintf b " | %s => if %s then %s_case%d %s else %s_default %s\n"
+ patlist guard name !numcase bv name (underscores_for args);
bprintf c " | %s_case%d %s => (* %s *) \n" name !numcase bv patlist;
bprintf c " %s\n" rhs
end else begin
diff --git a/tools/xtime.ml b/tools/xtime.ml
new file mode 100644
index 00000000..fbb25a49
--- /dev/null
+++ b/tools/xtime.ml
@@ -0,0 +1,101 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Timing the execution of a command, with more options than the
+ standard Unix "time" utility. *)
+
+open Printf
+
+let outfile = ref ""
+let errfile = ref ""
+let command_name = ref ""
+let num_runs = ref 1
+let min_runs = ref 0
+let min_time = ref 0.0
+let print_sys = ref false
+
+let error fmt =
+ eprintf "Error: "; kfprintf (fun _ -> exit 2) stderr fmt
+
+let open_file out dfl =
+ if out = ""
+ then dfl
+ else Unix.(openfile out [O_WRONLY; O_CREAT; O_TRUNC] 0o666)
+
+let close_file out fd =
+ if out <> "" then Unix.close fd
+
+let run1 (cmd, args) =
+ let fd_out = open_file !outfile Unix.stdout in
+ let fd_err = open_file !errfile Unix.stderr in
+ let pid =
+ Unix.create_process cmd (Array.of_list (cmd :: args))
+ Unix.stdin fd_out fd_err in
+ close_file !outfile fd_out;
+ close_file !errfile fd_err;
+ let (_, st) = Unix.waitpid [] pid in
+ match st with
+ | Unix.WEXITED 127 -> error "cannot execute '%s'\n" cmd
+ | Unix.WSIGNALED signo -> error "terminated by signal %d\n" signo
+ | _ -> ()
+
+let run (cmd, arg) =
+ let rec repeat n =
+ run1 (cmd, arg);
+ if (!min_time > 0.0 && Unix.((times()).tms_cutime) < !min_time)
+ || (!min_runs > 0 && n < !min_runs)
+ || n < !num_runs
+ then repeat (n + 1)
+ else n in
+ let n = repeat 1 in
+ let ts = Unix.times() in
+ let cmdname = if !command_name <> "" then !command_name else cmd in
+ if !print_sys then
+ Printf.printf "%.3f usr + %.3f sys %s\n"
+ (ts.Unix.tms_cutime /. float n)
+ (ts.Unix.tms_cstime /. float n)
+ cmdname
+ else
+ Printf.printf "%.3f %s\n"
+ (ts.Unix.tms_cutime /. float n)
+ cmdname
+
+let _ =
+ let cmd_and_args = ref [] in
+ Arg.parse [
+ "-o", Arg.Set_string outfile,
+ " <file> Redirect standard output of command to <file>";
+ "-e", Arg.Set_string outfile,
+ " <file> Redirect standard error of command to <file>";
+ "-name", Arg.Set_string command_name,
+ " <name> Name of command to report along with the time";
+ "-repeat", Arg.Int (fun n -> num_runs := n),
+ " <N> Run the command N times";
+ "-mintime", Arg.Float (fun f -> min_time := f),
+ " <T> Repeatedly run the command for a total duration of at least T seconds";
+ "-minruns", Arg.Int (fun n -> num_runs := n),
+ " <N> Run the command at least N times (to be used in conjunction with -mintime)";
+ "-sys", Arg.Set print_sys,
+ " Print system time (spent in the OS) in addition to user time (spent in the command)";
+ "--", Arg.Rest (fun s -> cmd_and_args := s :: !cmd_and_args),
+ " <executable> <arguments> Specify the executable to time, with its arguments"
+ ]
+ (fun s -> raise (Arg.Bad (sprintf "Don't know what to do with '%s'" s)))
+ "Usage: xtime [options] -- <executable> [arguments].\n\nOptions are:";
+ match List.rev !cmd_and_args with
+ | [] ->
+ error "No command to execute\n"
+ | cmd :: args ->
+ Unix.handle_unix_error run (cmd, args)
diff --git a/x86/Asm.v b/x86/Asm.v
index 32235c2d..58e28c40 100644
--- a/x86/Asm.v
+++ b/x86/Asm.v
@@ -851,11 +851,12 @@ Definition exec_instr (f: function) (i: instruction) (rs: regset) (m: mem) : out
| Ptestq_ri r1 n =>
Next (nextinstr (compare_longs (Val.andl (rs r1) (Vlong n)) (Vlong Int64.zero) rs m)) m
| Pcmov c rd r1 =>
- match eval_testcond c rs with
- | Some true => Next (nextinstr (rs#rd <- (rs#r1))) m
- | Some false => Next (nextinstr rs) m
- | None => Next (nextinstr (rs#rd <- Vundef)) m
- end
+ let v :=
+ match eval_testcond c rs with
+ | Some b => if b then rs#r1 else rs#rd
+ | None => Vundef
+ end in
+ Next (nextinstr (rs#rd <- v)) m
| Psetcc c rd =>
Next (nextinstr (rs#rd <- (Val.of_optbool (eval_testcond c rs)))) m
(** Arithmetic operations over double-precision floats *)
diff --git a/x86/Asmexpand.ml b/x86/Asmexpand.ml
index 16426ce3..b8353046 100644
--- a/x86/Asmexpand.ml
+++ b/x86/Asmexpand.ml
@@ -251,7 +251,7 @@ let expand_builtin_va_start_32 r =
invalid_arg "Fatal error: va_start used in non-vararg function";
let ofs =
Int32.(add (add !PrintAsmaux.current_function_stacksize 4l)
- (mul 4l (Z.to_int32 (Conventions1.size_arguments
+ (mul 4l (Z.to_int32 (Conventions.size_arguments
(get_current_function_sig ()))))) in
emit (Pleal (RAX, linear_addr RSP (Z.of_uint32 ofs)));
emit (Pmovl_mr (linear_addr r _0z, RAX))
@@ -506,7 +506,7 @@ let expand_instruction instr =
(* Save the registers *)
emit (Pleaq (R10, linear_addr RSP (Z.of_uint save_regs)));
emit (Pcall_s (intern_string "__compcert_va_saveregs",
- {sig_args = []; sig_res = None; sig_cc = cc_default}))
+ {sig_args = []; sig_res = Tvoid; sig_cc = cc_default}))
end;
(* Stack chaining *)
let fullsz = sz + 8 in
diff --git a/x86/Asmgen.v b/x86/Asmgen.v
index dedbfbe6..99e9fc2b 100644
--- a/x86/Asmgen.v
+++ b/x86/Asmgen.v
@@ -305,6 +305,35 @@ Definition mk_jcc (cond: extcond) (lbl: label) (k: code) :=
| Cond_or c1 c2 => Pjcc c1 lbl :: Pjcc c2 lbl :: k
end.
+Definition negate_testcond (c: testcond) : testcond :=
+ match c with
+ | Cond_e => Cond_ne | Cond_ne => Cond_e
+ | Cond_b => Cond_ae | Cond_be => Cond_a
+ | Cond_ae => Cond_b | Cond_a => Cond_be
+ | Cond_l => Cond_ge | Cond_le => Cond_g
+ | Cond_ge => Cond_l | Cond_g => Cond_le
+ | Cond_p => Cond_np | Cond_np => Cond_p
+ end.
+
+Definition mk_sel (cond: extcond) (rd r2: ireg) (k: code) :=
+ match cond with
+ | Cond_base c =>
+ OK (Pcmov (negate_testcond c) rd r2 :: k)
+ | Cond_and c1 c2 =>
+ OK (Pcmov (negate_testcond c1) rd r2 ::
+ Pcmov (negate_testcond c2) rd r2 :: k)
+ | Cond_or c1 c2 =>
+ Error (msg "Asmgen.mk_sel") (**r should never happen, see [SelectOp.select] *)
+ end.
+
+Definition transl_sel
+ (cond: condition) (args: list mreg) (rd r2: ireg) (k: code) : res code :=
+ if ireg_eq rd r2 then
+ OK (Pmov_rr rd r2 :: k) (* must generate one instruction... *)
+ else
+ do k1 <- mk_sel (testcond_for_condition cond) rd r2 k;
+ transl_cond cond args k1.
+
(** Translation of the arithmetic operation [r <- op(args)].
The corresponding instructions are prepended to [k]. *)
@@ -597,15 +626,24 @@ Definition transl_op
| Ocmp c, args =>
do r <- ireg_of res;
transl_cond c args (mk_setcc (testcond_for_condition c) r k)
+ | Osel c ty, a1 :: a2 :: args =>
+ assertion (mreg_eq a1 res);
+ do r <- ireg_of res; do r2 <- ireg_of a2;
+ transl_sel c args r r2 k
| _, _ =>
Error(msg "Asmgen.transl_op")
end.
(** Translation of memory loads and stores *)
-Definition transl_load (chunk: memory_chunk)
+Definition transl_load
+ (trap : trapping_mode)
+ (chunk: memory_chunk)
(addr: addressing) (args: list mreg) (dest: mreg)
(k: code) : res code :=
+ match trap with
+ | NOTRAP => Error (msg "Asmgen.transl_load x86 does not support non trapping loads")
+ | TRAP =>
do am <- transl_addressing addr args;
match chunk with
| Mint8unsigned =>
@@ -626,6 +664,7 @@ Definition transl_load (chunk: memory_chunk)
do r <- freg_of dest; OK(Pmovsd_fm r am :: k)
| _ =>
Error (msg "Asmgen.transl_load")
+ end
end.
Definition transl_store (chunk: memory_chunk)
@@ -666,8 +705,8 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction)
loadind RSP f.(fn_link_ofs) Tptr AX k1)
| Mop op args res =>
transl_op op args res k
- | Mload chunk addr args dst =>
- transl_load chunk addr args dst k
+ | Mload trap chunk addr args dst =>
+ transl_load trap chunk addr args dst k
| Mstore chunk addr args src =>
transl_store chunk addr args src k
| Mcall sig (inl reg) =>
diff --git a/x86/Asmgenproof.v b/x86/Asmgenproof.v
index 3aa87a4c..6886b2fd 100644
--- a/x86/Asmgenproof.v
+++ b/x86/Asmgenproof.v
@@ -194,6 +194,14 @@ Proof.
intros. destruct xc; simpl; TailNoLabel.
Qed.
+Remark mk_sel_label:
+ forall xc rd r2 k c,
+ mk_sel xc rd r2 k = OK c ->
+ tail_nolabel k c.
+Proof.
+ unfold mk_sel; intros; destruct xc; inv H; TailNoLabel.
+Qed.
+
Remark transl_cond_label:
forall cond args k c,
transl_cond cond args k = OK c ->
@@ -221,14 +229,17 @@ Proof.
destruct (Float32.eq_dec n Float32.zero); TailNoLabel.
destruct (normalize_addrmode_64 x) as [am' [delta|]]; TailNoLabel.
eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_setcc_label.
+ unfold transl_sel in EQ2. destruct (ireg_eq x x0); monadInv EQ2.
+ TailNoLabel.
+ eapply tail_nolabel_trans. eapply transl_cond_label; eauto. eapply mk_sel_label; eauto.
Qed.
Remark transl_load_label:
- forall chunk addr args dest k c,
- transl_load chunk addr args dest k = OK c ->
+ forall trap chunk addr args dest k c,
+ transl_load trap chunk addr args dest k = OK c ->
tail_nolabel k c.
Proof.
- intros. monadInv H. destruct chunk; TailNoLabel.
+ intros. destruct trap; try discriminate. monadInv H. destruct chunk; TailNoLabel.
Qed.
Remark transl_store_label:
@@ -556,6 +567,12 @@ Opaque loadind.
split. eapply agree_set_undef_mreg; eauto. congruence.
simpl; congruence.
+- (* Mload notrap *) (* isn't there a nicer way? *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
+- (* Mload notrap *)
+ inv AT. simpl in *. unfold bind in *. destruct (transl_code _ _ _) in *; discriminate.
+
- (* Mstore *)
assert (eval_addressing tge sp addr rs##args = Some a).
rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved.
@@ -706,7 +723,7 @@ Opaque loadind.
intros. simpl in TR.
destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
as [rs' [A [B C]]].
- rewrite EC in B.
+ rewrite EC in B. destruct B as [B _].
destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
exists (Pjcc c1 lbl); exists k; exists rs'.
@@ -744,7 +761,7 @@ Opaque loadind.
left; eapply exec_straight_steps; eauto. intros. simpl in TR.
destruct (transl_cond_correct tge tf cond args _ _ rs0 m' TR)
as [rs' [A [B C]]].
- rewrite EC in B.
+ rewrite EC in B. destruct B as [B _].
destruct (testcond_for_condition cond); simpl in *.
(* simple jcc *)
econstructor; split.
diff --git a/x86/Asmgenproof1.v b/x86/Asmgenproof1.v
index 904debdc..7cff1047 100644
--- a/x86/Asmgenproof1.v
+++ b/x86/Asmgenproof1.v
@@ -208,7 +208,8 @@ Proof.
set (x' := Int.add x tnm1).
set (rs2 := nextinstr (compare_ints (Vint x) (Vint Int.zero) rs1 m)).
set (rs3 := nextinstr (rs2#RCX <- (Vint x'))).
- set (rs4 := nextinstr (if Int.lt x Int.zero then rs3#RAX <- (Vint x') else rs3)).
+ set (v' := if Int.lt x Int.zero then Vint x' else Vint x).
+ set (rs4 := nextinstr (rs3#RAX <- v')).
set (rs5 := nextinstr_nf (rs4#RAX <- (Val.shr rs4#RAX (Vint n)))).
assert (rs3#RAX = Vint x). unfold rs3. Simplifs.
assert (rs3#RCX = Vint x'). unfold rs3. Simplifs.
@@ -218,13 +219,12 @@ Proof.
change (rs2 RAX) with (rs1 RAX). rewrite A. simpl.
rewrite Int.repr_unsigned. rewrite Int.add_zero_l. auto. auto.
apply exec_straight_step with rs4 m. simpl.
- rewrite Int.lt_sub_overflow. unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
- unfold rs4. destruct (Int.lt x Int.zero); simpl; auto.
+ rewrite Int.lt_sub_overflow. unfold rs4, v'. rewrite H, H0. destruct (Int.lt x Int.zero); simpl; auto.
+ auto.
apply exec_straight_one. auto. auto.
split. unfold rs5. Simplifs. unfold rs4. rewrite nextinstr_inv; auto with asmgen.
- destruct (Int.lt x Int.zero). rewrite Pregmap.gss. rewrite A; auto. rewrite A; rewrite H; auto.
+ rewrite Pregmap.gss. unfold v'. rewrite A. reflexivity.
intros. unfold rs5. Simplifs. unfold rs4. Simplifs.
- transitivity (rs3#r). destruct (Int.lt x Int.zero). Simplifs. auto.
unfold rs3. Simplifs. unfold rs2. Simplifs.
unfold compare_ints. Simplifs.
Qed.
@@ -913,6 +913,7 @@ Lemma transl_cond_correct:
/\ match eval_condition cond (map rs (map preg_of args)) m with
| None => True
| Some b => eval_extcond (testcond_for_condition cond) rs' = Some b
+ /\ eval_extcond (testcond_for_condition (negate_condition cond)) rs' = Some (negb b)
end
/\ forall r, data_preg r = true -> rs'#r = rs r.
Proof.
@@ -921,58 +922,78 @@ Proof.
- (* comp *)
simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto.
+ split. destruct (Val.cmp_bool c0 (rs x) (rs x0)) eqn:?; auto. split.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
eapply testcond_for_signed_comparison_32_correct; eauto.
+ rewrite Val.negate_cmp_bool, Heqo; auto.
intros. unfold compare_ints. Simplifs.
- (* compu *)
simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
+ split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. split.
eapply testcond_for_unsigned_comparison_32_correct; eauto.
+ eapply testcond_for_unsigned_comparison_32_correct; eauto.
+ rewrite Val.negate_cmpu_bool, Heqo; auto.
intros. unfold compare_ints. Simplifs.
- (* compimm *)
simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int.eq_dec n Int.zero).
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem.
+ split. destruct (rs x); simpl; auto. subst. rewrite Int.and_idem. split.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
eapply testcond_for_signed_comparison_32_correct; eauto.
+ rewrite Val.negate_cmp_bool; auto.
intros. unfold compare_ints. Simplifs.
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto.
+ split. destruct (Val.cmp_bool c0 (rs x) (Vint n)) eqn:?; auto. split.
eapply testcond_for_signed_comparison_32_correct; eauto.
+ eapply testcond_for_signed_comparison_32_correct; eauto.
+ rewrite Val.negate_cmp_bool, Heqo; auto.
intros. unfold compare_ints. Simplifs.
- (* compuimm *)
simpl. rewrite (ireg_of_eq _ _ EQ).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto.
+ split. destruct (Val.cmpu_bool (Mem.valid_pointer m) c0 (rs x) (Vint n)) eqn:?; auto; split.
+ eapply testcond_for_unsigned_comparison_32_correct; eauto.
eapply testcond_for_unsigned_comparison_32_correct; eauto.
+ rewrite Val.negate_cmpu_bool, Heqo; auto.
intros. unfold compare_ints. Simplifs.
- (* compl *)
simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto.
+ split. destruct (Val.cmpl_bool c0 (rs x) (rs x0)) eqn:?; auto. split.
eapply testcond_for_signed_comparison_64_correct; eauto.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
+ rewrite Val.negate_cmpl_bool, Heqo; auto.
intros. unfold compare_longs. Simplifs.
- (* complu *)
simpl. rewrite (ireg_of_eq _ _ EQ). rewrite (ireg_of_eq _ _ EQ1).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto.
+ split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (rs x0)) eqn:?; auto. split.
+ eapply testcond_for_unsigned_comparison_64_correct; eauto.
eapply testcond_for_unsigned_comparison_64_correct; eauto.
+ rewrite Val.negate_cmplu_bool, Heqo; auto.
intros. unfold compare_longs. Simplifs.
- (* compimm *)
simpl. rewrite (ireg_of_eq _ _ EQ). destruct (Int64.eq_dec n Int64.zero).
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem.
+ split. destruct (rs x); simpl; auto. subst. rewrite Int64.and_idem. split.
eapply testcond_for_signed_comparison_64_correct; eauto.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
+ rewrite Val.negate_cmpl_bool; auto.
intros. unfold compare_longs. Simplifs.
econstructor; split. apply exec_straight_one. simpl; eauto. auto.
- split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto.
+ split. destruct (Val.cmpl_bool c0 (rs x) (Vlong n)) eqn:?; auto. split.
+ eapply testcond_for_signed_comparison_64_correct; eauto.
eapply testcond_for_signed_comparison_64_correct; eauto.
+ rewrite Val.negate_cmpl_bool, Heqo; auto.
intros. unfold compare_longs. Simplifs.
- (* compuimm *)
simpl. rewrite (ireg_of_eq _ _ EQ).
econstructor. split. apply exec_straight_one. simpl. eauto. auto.
- split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto.
+ split. destruct (Val.cmplu_bool (Mem.valid_pointer m) c0 (rs x) (Vlong n)) eqn:?; auto. split.
eapply testcond_for_unsigned_comparison_64_correct; eauto.
+ eapply testcond_for_unsigned_comparison_64_correct; eauto.
+ rewrite Val.negate_cmplu_bool, Heqo; auto.
intros. unfold compare_longs. Simplifs.
- (* compf *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
@@ -981,7 +1002,9 @@ Proof.
destruct c0; simpl; auto.
unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
- repeat rewrite swap_floats_commut. apply testcond_for_float_comparison_correct.
+ repeat rewrite swap_floats_commut. split.
+ apply testcond_for_float_comparison_correct.
+ apply testcond_for_neg_float_comparison_correct.
intros. Simplifs. apply compare_floats_inv; auto with asmgen.
- (* notcompf *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
@@ -990,7 +1013,9 @@ Proof.
destruct c0; simpl; auto.
unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
- repeat rewrite swap_floats_commut. apply testcond_for_neg_float_comparison_correct.
+ repeat rewrite swap_floats_commut. split.
+ apply testcond_for_neg_float_comparison_correct.
+ rewrite negb_involutive. apply testcond_for_float_comparison_correct.
intros. Simplifs. apply compare_floats_inv; auto with asmgen.
- (* compfs *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
@@ -999,7 +1024,9 @@ Proof.
destruct c0; simpl; auto.
unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
- repeat rewrite swap_floats_commut. apply testcond_for_float32_comparison_correct.
+ repeat rewrite swap_floats_commut. split.
+ apply testcond_for_float32_comparison_correct.
+ apply testcond_for_neg_float32_comparison_correct.
intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
- (* notcompfs *)
simpl. rewrite (freg_of_eq _ _ EQ). rewrite (freg_of_eq _ _ EQ1).
@@ -1008,7 +1035,9 @@ Proof.
destruct c0; simpl; auto.
unfold nextinstr. rewrite Pregmap.gss. rewrite compare_floats32_inv; auto with asmgen.
split. destruct (rs x); destruct (rs x0); simpl; auto.
- repeat rewrite swap_floats_commut. apply testcond_for_neg_float32_comparison_correct.
+ repeat rewrite swap_floats_commut. split.
+ apply testcond_for_neg_float32_comparison_correct.
+ rewrite negb_involutive. apply testcond_for_float32_comparison_correct.
intros. Simplifs. apply compare_floats32_inv; auto with asmgen.
- (* maskzero *)
simpl. rewrite (ireg_of_eq _ _ EQ).
@@ -1133,6 +1162,94 @@ Proof.
intuition Simplifs.
Qed.
+Definition negate_extcond (xc: extcond) : extcond :=
+ match xc with
+ | Cond_base c => Cond_base (negate_testcond c)
+ | Cond_and c1 c2 => Cond_or (negate_testcond c1) (negate_testcond c2)
+ | Cond_or c1 c2 => Cond_and (negate_testcond c1) (negate_testcond c2)
+ end.
+
+Remark negate_testcond_for_condition:
+ forall cond,
+ negate_extcond (testcond_for_condition cond) = testcond_for_condition (negate_condition cond).
+Proof.
+ intros. destruct cond; try destruct c; reflexivity.
+Qed.
+
+Lemma mk_sel_correct:
+ forall xc ty rd r2 k c ob rs m,
+ mk_sel xc rd r2 k = OK c ->
+ rd <> r2 ->
+ match ob with
+ | Some b => eval_extcond xc rs = Some b /\ eval_extcond (negate_extcond xc) rs = Some (negb b)
+ | None => True
+ end ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef (Val.select ob rs#rd rs#r2 ty) rs'#rd
+ /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r.
+Proof.
+ intros. destruct xc; monadInv H; simpl in H1.
+- econstructor; split.
+ eapply exec_straight_one. reflexivity. reflexivity.
+ set (v := match eval_testcond (negate_testcond c0) rs with
+ | Some true => rs r2
+ | Some false => rs rd
+ | None => Vundef
+ end).
+ split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen.
+ destruct ob; simpl; auto. destruct H1 as [_ B]; unfold v; rewrite B.
+ destruct b; apply Val.lessdef_normalize.
+ intros; Simplifs.
+- econstructor; split.
+ eapply exec_straight_two.
+ reflexivity. reflexivity. reflexivity. reflexivity.
+ set (v1 := match eval_testcond (negate_testcond c1) rs with
+ | Some true => rs r2
+ | Some false => rs rd
+ | None => Vundef
+ end).
+ rewrite eval_testcond_nextinstr, eval_testcond_set_ireg.
+ set (v2 := match eval_testcond (negate_testcond c2) rs with
+ | Some true => nextinstr rs # rd <- v1 r2
+ | Some false => nextinstr rs # rd <- v1 rd
+ | None => Vundef
+ end).
+ split. rewrite nextinstr_inv, Pregmap.gss by eauto with asmgen.
+ destruct ob; simpl; auto.
+ destruct H1 as [_ B].
+ destruct (eval_testcond (negate_testcond c1) rs) as [b1|]; try discriminate.
+ destruct (eval_testcond (negate_testcond c2) rs) as [b2|]; try discriminate.
+ inv B. apply negb_sym in H1. subst b.
+ replace v2 with (if b2 then rs#r2 else v1).
+ unfold v1. destruct b1, b2; apply Val.lessdef_normalize.
+ unfold v2. destruct b2; symmetry; Simplifs.
+ intros; Simplifs.
+Qed.
+
+Lemma transl_sel_correct:
+ forall ty cond args rd r2 k c rs m,
+ transl_sel cond args rd r2 k = OK c ->
+ exists rs',
+ exec_straight ge fn c rs m k rs' m
+ /\ Val.lessdef (Val.select (eval_condition cond (map rs (map preg_of args)) m) rs#rd rs#r2 ty) rs'#rd
+ /\ forall r, data_preg r = true -> r <> rd -> rs'#r = rs r.
+Proof.
+ unfold transl_sel; intros. destruct (ireg_eq rd r2); monadInv H.
+- econstructor; split.
+ apply exec_straight_one; reflexivity.
+ split. rewrite nextinstr_inv, Pregmap.gss by auto with asmgen.
+ destruct eval_condition as [[]|]; simpl; auto using Val.lessdef_normalize.
+ intros; Simplifs.
+- destruct (transl_cond_correct _ _ _ _ rs m EQ0) as (rs1 & A & B & C).
+ rewrite <- negate_testcond_for_condition in B.
+ destruct (mk_sel_correct _ ty _ _ _ _ _ rs1 m EQ n B) as (rs2 & D & E & F).
+ exists rs2; split.
+ eapply exec_straight_trans; eauto.
+ split. rewrite ! C in E by auto with asmgen. exact E.
+ intros. rewrite F; auto.
+Qed.
+
(** Translation of arithmetic operations. *)
Ltac ArgsInv :=
@@ -1142,7 +1259,9 @@ Ltac ArgsInv :=
| [ H: bind _ _ = OK _ |- _ ] => monadInv H; ArgsInv
| [ H: match _ with left _ => _ | right _ => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
| [ H: match _ with true => _ | false => assertion_failed end = OK _ |- _ ] => monadInv H; ArgsInv
- | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *; clear H; ArgsInv
+ | [ H: ireg_of _ = OK _ |- _ ] => simpl in *; rewrite (ireg_of_eq _ _ H) in *;
+ let X := fresh "EQ" in generalize (ireg_of_eq _ _ H); intros X;
+ clear H; ArgsInv
| [ H: freg_of _ = OK _ |- _ ] => simpl in *; rewrite (freg_of_eq _ _ H) in *; clear H; ArgsInv
| _ => idtac
end.
@@ -1334,16 +1453,19 @@ Transparent destroyed_by_op.
exists rs3.
split. eapply exec_straight_trans. eexact P. eexact S.
split. rewrite T. destruct (eval_condition cond rs ## (preg_of ## args) m).
- rewrite Q. auto.
+ destruct Q as [Q _]. rewrite Q. auto.
simpl; auto.
intros. transitivity (rs2 r); auto.
+(* selection *)
+ rewrite EQ1. exploit transl_sel_correct; eauto. intros (rs' & A & B & C).
+ exists rs'; split. eexact A. eauto.
Qed.
(** Translation of memory loads. *)
Lemma transl_load_correct:
- forall chunk addr args dest k c (rs: regset) m a v,
- transl_load chunk addr args dest k = OK c ->
+ forall trap chunk addr args dest k c (rs: regset) m a v,
+ transl_load trap chunk addr args dest k = OK c ->
eval_addressing ge (rs#RSP) addr (map rs (map preg_of args)) = Some a ->
Mem.loadv chunk m a = Some v ->
exists rs',
@@ -1351,7 +1473,9 @@ Lemma transl_load_correct:
/\ rs'#(preg_of dest) = v
/\ forall r, data_preg r = true -> r <> preg_of dest -> rs'#r = rs#r.
Proof.
- unfold transl_load; intros. monadInv H.
+ unfold transl_load; intros.
+ destruct trap; simpl; try discriminate.
+ monadInv H.
exploit transl_addressing_mode_correct; eauto. intro EA.
assert (EA': eval_addrmode ge x rs = a). destruct a; simpl in H1; try discriminate; inv EA; auto.
set (rs2 := nextinstr_nf (rs#(preg_of dest) <- v)).
diff --git a/x86/Builtins1.v b/x86/Builtins1.v
new file mode 100644
index 00000000..f1d60961
--- /dev/null
+++ b/x86/Builtins1.v
@@ -0,0 +1,54 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, Collège de France and Inria Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Platform-specific built-in functions *)
+
+Require Import String Coqlib.
+Require Import AST Integers Floats Values.
+Require Import Builtins0.
+
+Inductive platform_builtin : Type :=
+ | BI_fmin
+ | BI_fmax.
+
+Local Open Scope string_scope.
+
+Definition platform_builtin_table : list (string * platform_builtin) :=
+ ("__builtin_fmin", BI_fmin)
+ :: ("__builtin_fmax", BI_fmax)
+ :: nil.
+
+Definition platform_builtin_sig (b: platform_builtin) : signature :=
+ match b with
+ | BI_fmin | BI_fmax =>
+ mksignature (Tfloat :: Tfloat :: nil) Tfloat cc_default
+ end.
+
+Definition platform_builtin_sem (b: platform_builtin) : builtin_sem (sig_res (platform_builtin_sig b)) :=
+ match b with
+ | BI_fmin =>
+ mkbuiltin_n2t Tfloat Tfloat Tfloat
+ (fun f1 f2 => match Float.compare f1 f2 with
+ | Some Eq | Some Lt => f1
+ | Some Gt | None => f2
+ end)
+ | BI_fmax =>
+ mkbuiltin_n2t Tfloat Tfloat Tfloat
+ (fun f1 f2 => match Float.compare f1 f2 with
+ | Some Eq | Some Gt => f1
+ | Some Lt | None => f2
+ end)
+ end.
+
diff --git a/x86/CBuiltins.ml b/x86/CBuiltins.ml
index 69a2eb64..e7f714c7 100644
--- a/x86/CBuiltins.ml
+++ b/x86/CBuiltins.ml
@@ -26,13 +26,11 @@ let (va_list_type, va_list_scalar, size_va_list) =
(TPtr(TVoid [], []), true, 4)
let builtins = {
- Builtins.typedefs = [
+ builtin_typedefs = [
"__builtin_va_list", va_list_type;
];
- Builtins.functions = [
+ builtin_functions = [
(* Integer arithmetic *)
- "__builtin_bswap64",
- (TInt(IULongLong, []), [TInt(IULongLong, [])], false);
"__builtin_clz",
(TInt(IInt, []), [TInt(IUInt, [])], false);
"__builtin_clzl",
@@ -75,9 +73,6 @@ let builtins = {
(TVoid [], [TPtr(TInt(IUShort, []), []); TInt(IUShort, [])], false);
"__builtin_write32_reversed",
(TVoid [], [TPtr(TInt(IUInt, []), []); TInt(IUInt, [])], false);
- (* no operation *)
- "__builtin_nop",
- (TVoid [], [], false);
]
}
diff --git a/x86/CSE2deps.v b/x86/CSE2deps.v
new file mode 100644
index 00000000..f4d9e254
--- /dev/null
+++ b/x86/CSE2deps.v
@@ -0,0 +1,24 @@
+Require Import BoolEqual Coqlib.
+Require Import AST Integers Floats.
+Require Import Values Memory Globalenvs Events.
+Require Import Op.
+
+Definition can_swap_accesses_ofs ofsr chunkr ofsw chunkw :=
+ (0 <=? ofsw) && (ofsw <=? (Ptrofs.modulus - largest_size_chunk))
+ && (0 <=? ofsr) && (ofsr <=? (Ptrofs.modulus - largest_size_chunk))
+ && ((ofsw + size_chunk chunkw <=? ofsr) ||
+ (ofsr + size_chunk chunkr <=? ofsw)).
+
+Definition may_overlap chunk addr args chunk' addr' args' :=
+ match addr, addr', args, args' with
+ | (Aindexed ofs), (Aindexed ofs'),
+ (base :: nil), (base' :: nil) =>
+ if peq base base'
+ then negb (can_swap_accesses_ofs ofs' chunk' ofs chunk)
+ else true
+ | (Aglobal symb ofs), (Aglobal symb' ofs'), nil, nil =>
+ if peq symb symb'
+ then negb (can_swap_accesses_ofs (Ptrofs.unsigned ofs') chunk' (Ptrofs.unsigned ofs) chunk)
+ else false
+ | _, _, _, _ => true
+ end.
diff --git a/x86/CSE2depsproof.v b/x86/CSE2depsproof.v
new file mode 100644
index 00000000..1e913254
--- /dev/null
+++ b/x86/CSE2depsproof.v
@@ -0,0 +1,253 @@
+Require Import Coqlib Maps Errors Integers Floats Lattice Kildall.
+Require Import AST Linking.
+Require Import Memory Registers Op RTL Maps.
+
+Require Import Globalenvs Values.
+Require Import Linking Values Memory Globalenvs Events Smallstep.
+Require Import Registers Op RTL.
+Require Import CSE2 CSE2deps.
+Require Import Lia.
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Section MEMORY_WRITE.
+ Variable m m2 : mem.
+ Variable chunkw chunkr : memory_chunk.
+ Variable base : val.
+
+ Variable addrw addrr valw : val.
+ Hypothesis STORE : Mem.storev chunkw m addrw valw = Some m2.
+
+ Section INDEXED_AWAY.
+ Variable ofsw ofsr : Z.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aindexed ofsw) (base :: nil) = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aindexed ofsr) (base :: nil) = Some addrr.
+
+ Lemma load_store_away1 :
+ forall RANGEW : 0 <= ofsw <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= ofsr <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : ofsw + size_chunk chunkw <= ofsr
+ \/ ofsr + size_chunk chunkr <= ofsw,
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *.
+ try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *.
+ destruct addrr ; simpl in * ; trivial.
+ unfold eval_addressing, eval_addressing32, eval_addressing64 in *.
+ destruct Archi.ptr64 eqn:PTR64; destruct base; simpl in *; try discriminate.
+ rewrite PTR64 in *.
+
+ inv ADDRR.
+ inv ADDRW.
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+
+ all: try (destruct (Ptrofs.unsigned_add_either i0
+ (Ptrofs.of_int (Int.repr ofsr))) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i0
+ (Ptrofs.of_int64 (Int64.repr ofsr))) as [OFSR | OFSR];
+ rewrite OFSR).
+ all: try (destruct (Ptrofs.unsigned_add_either i0
+ (Ptrofs.of_int (Int.repr ofsw))) as [OFSW | OFSW];
+ rewrite OFSW).
+ all: try (destruct (Ptrofs.unsigned_add_either i0
+ (Ptrofs.of_int64 (Int64.repr ofsw))) as [OFSW | OFSW];
+ rewrite OFSW).
+
+ all: unfold Ptrofs.of_int64.
+ all: unfold Ptrofs.of_int.
+
+
+ all: repeat rewrite Int.unsigned_repr by (change Int.max_unsigned with 4294967295; lia).
+ all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 4294967295; lia).
+ all: repeat rewrite Int64.unsigned_repr by (change Int64.max_unsigned with 18446744073709551615; lia).
+ all: repeat rewrite Ptrofs.unsigned_repr by (change Ptrofs.max_unsigned with 18446744073709551615; lia).
+
+ all: try change Ptrofs.modulus with 4294967296.
+ all: try change Ptrofs.modulus with 18446744073709551616.
+
+ all: intuition lia.
+ Qed.
+
+ Theorem load_store_away :
+ can_swap_accesses_ofs ofsr chunkr ofsw chunkw = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_away1.
+ all: tauto.
+ Qed.
+ End INDEXED_AWAY.
+
+ Section DIFFERENT_GLOBALS.
+ Variable ofsw ofsr : ptrofs.
+ Hypothesis symw symr : ident.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aglobal symw ofsw) nil = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aglobal symr ofsr) nil = Some addrr.
+
+ Lemma ptr64_cases:
+ forall {T : Type},
+ forall b : bool,
+ forall x y : T,
+ (if b then (if b then x else y) else (if b then y else x)) = x.
+ Proof.
+ destruct b; reflexivity.
+ Qed.
+
+ (* not needed
+ Lemma bool_cases_same:
+ forall {T : Type},
+ forall b : bool,
+ forall x : T,
+ (if b then x else x) = x.
+ Proof.
+ destruct b; reflexivity.
+ Qed.
+ *)
+
+ Lemma load_store_diff_globals :
+ symw <> symr ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+ unfold eval_addressing in *.
+ simpl in *.
+ rewrite ptr64_cases in ADDRR.
+ rewrite ptr64_cases in ADDRW.
+ unfold Genv.symbol_address in *.
+ unfold Genv.find_symbol in *.
+ destruct ((Genv.genv_symb genv) ! symw) as [bw |] eqn:SYMW; inv ADDRW.
+ 2: simpl in STORE; discriminate.
+ destruct ((Genv.genv_symb genv) ! symr) as [br |] eqn:SYMR; inv ADDRR.
+ 2: reflexivity.
+ assert (br <> bw).
+ {
+ intro EQ.
+ subst br.
+ assert (symr = symw).
+ {
+ eapply Genv.genv_vars_inj; eauto.
+ }
+ congruence.
+ }
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := bw).
+ - exact STORE.
+ - left. assumption.
+ Qed.
+ End DIFFERENT_GLOBALS.
+
+ Section SAME_GLOBALS.
+ Variable ofsw ofsr : ptrofs.
+ Hypothesis sym : ident.
+ Hypothesis ADDRW : eval_addressing genv sp
+ (Aglobal sym ofsw) nil = Some addrw.
+ Hypothesis ADDRR : eval_addressing genv sp
+ (Aglobal sym ofsr) nil = Some addrr.
+
+ Lemma load_store_glob_away1 :
+ forall RANGEW : 0 <= (Ptrofs.unsigned ofsw) <= Ptrofs.modulus - largest_size_chunk,
+ forall RANGER : 0 <= (Ptrofs.unsigned ofsr) <= Ptrofs.modulus - largest_size_chunk,
+ forall SWAPPABLE : (Ptrofs.unsigned ofsw) + size_chunk chunkw <= (Ptrofs.unsigned ofsr)
+ \/ (Ptrofs.unsigned ofsr) + size_chunk chunkr <= (Ptrofs.unsigned ofsw),
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intros.
+
+ pose proof (max_size_chunk chunkr) as size_chunkr_bounded.
+ pose proof (max_size_chunk chunkw) as size_chunkw_bounded.
+ unfold largest_size_chunk in size_chunkr_bounded, size_chunkw_bounded.
+ try change (Ptrofs.modulus - largest_size_chunk) with 4294967288 in *.
+ try change (Ptrofs.modulus - largest_size_chunk) with 18446744073709551608 in *.
+ unfold eval_addressing, eval_addressing32, eval_addressing64 in *.
+
+ rewrite ptr64_cases in ADDRR.
+ rewrite ptr64_cases in ADDRW.
+ unfold Genv.symbol_address in *.
+ inv ADDRR.
+ inv ADDRW.
+ destruct (Genv.find_symbol genv sym).
+ 2: discriminate.
+
+ eapply Mem.load_store_other with (chunk := chunkw) (v := valw) (b := b).
+ exact STORE.
+ right.
+ tauto.
+ Qed.
+
+ Lemma load_store_glob_away :
+ (can_swap_accesses_ofs (Ptrofs.unsigned ofsr) chunkr (Ptrofs.unsigned ofsw) chunkw) = true ->
+ Mem.loadv chunkr m2 addrr = Mem.loadv chunkr m addrr.
+ Proof.
+ intro SWAP.
+ unfold can_swap_accesses_ofs in SWAP.
+ repeat rewrite andb_true_iff in SWAP.
+ repeat rewrite orb_true_iff in SWAP.
+ repeat rewrite Z.leb_le in SWAP.
+ apply load_store_glob_away1.
+ all: tauto.
+ Qed.
+ End SAME_GLOBALS.
+End MEMORY_WRITE.
+End SOUNDNESS.
+
+
+Section SOUNDNESS.
+ Variable F V : Type.
+ Variable genv: Genv.t F V.
+ Variable sp : val.
+
+Lemma may_overlap_sound:
+ forall m m' : mem,
+ forall chunk addr args chunk' addr' args' v a a' rs,
+ (eval_addressing genv sp addr (rs ## args)) = Some a ->
+ (eval_addressing genv sp addr' (rs ## args')) = Some a' ->
+ (may_overlap chunk addr args chunk' addr' args') = false ->
+ (Mem.storev chunk m a v) = Some m' ->
+ (Mem.loadv chunk' m' a') = (Mem.loadv chunk' m a').
+Proof.
+ intros until rs.
+ intros ADDR ADDR' OVERLAP STORE.
+ destruct addr; destruct addr'; try discriminate.
+ { (* Aindexed / Aindexed *)
+ destruct args as [ | base [ | ]]. 1,3: discriminate.
+ destruct args' as [ | base' [ | ]]. 1,3: discriminate.
+ simpl in OVERLAP.
+ destruct (peq base base'). 2: discriminate.
+ subst base'.
+ destruct (can_swap_accesses_ofs z0 chunk' z chunk) eqn:SWAP.
+ 2: discriminate.
+ simpl in *.
+ eapply load_store_away; eassumption.
+ }
+ { (* Aglobal / Aglobal *)
+ destruct args. 2: discriminate.
+ destruct args'. 2: discriminate.
+ simpl in *.
+ destruct (peq i i1).
+ {
+ subst i1.
+ rewrite negb_false_iff in OVERLAP.
+ eapply load_store_glob_away; eassumption.
+ }
+ eapply load_store_diff_globals; eassumption.
+ }
+Qed.
+
+End SOUNDNESS.
diff --git a/x86/ConstpropOp.vp b/x86/ConstpropOp.vp
index f59b9dba..ada8d54a 100644
--- a/x86/ConstpropOp.vp
+++ b/x86/ConstpropOp.vp
@@ -16,7 +16,7 @@
Require Import Coqlib Compopts.
Require Import AST Integers Floats.
Require Import Op Registers.
-Require Import ValueDomain.
+Require Import ValueDomain ValueAOp.
(** * Converting known values to constants *)
@@ -98,6 +98,15 @@ Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
make_cmp_base c args vl
end.
+Definition make_select (c: condition) (ty: typ)
+ (r1 r2: reg) (args: list reg) (vl: list aval) :=
+ match resolve_branch (eval_static_condition c vl) with
+ | Some b => (Omove, (if b then r1 else r2) :: nil)
+ | None =>
+ let (c', args') := cond_strength_reduction c args vl in
+ (Osel c' ty, r1 :: r2 :: args')
+ end.
+
(** For addressing modes, we need to distinguish
- reductions that produce pointers (i.e. that produce [Aglobal], [Ainstack], [Abased] and [Abasedscaled] addressing modes), which are valid only if the pointer size is right;
- other reductions (producing [Aindexed] or [Aindexed2] modes), which are valid independently of the pointer size.
@@ -416,6 +425,7 @@ Nondetfunction op_strength_reduction
let (addr', args') := addr_strength_reduction_64 addr args vl in
(Oleal addr', args')
| Ocmp c, args, vl => make_cmp c args vl
+ | Osel c ty, r1 :: r2 :: args, v1 :: v2 :: vl => make_select c ty r1 r2 args vl
| Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
| Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
| Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
diff --git a/x86/ConstpropOpproof.v b/x86/ConstpropOpproof.v
index 3bb0f3cd..6d2df9c1 100644
--- a/x86/ConstpropOpproof.v
+++ b/x86/ConstpropOpproof.v
@@ -14,7 +14,7 @@
Require Import Coqlib Compopts.
Require Import Integers Floats Values Memory Globalenvs Events.
-Require Import Op Registers RTL ValueDomain.
+Require Import Op Registers RTL ValueDomain ValueAOp ValueAnalysis.
Require Import ConstpropOp.
Section STRENGTH_REDUCTION.
@@ -371,6 +371,28 @@ Proof.
- apply make_cmp_base_correct; auto.
Qed.
+Lemma make_select_correct:
+ forall c ty r1 r2 args vl,
+ vl = map (fun r => AE.get r ae) args ->
+ let (op', args') := make_select c ty r1 r2 args vl in
+ exists v, eval_operation ge (Vptr sp Ptrofs.zero) op' e##args' m = Some v
+ /\ Val.lessdef (Val.select (eval_condition c e##args m) e#r1 e#r2 ty) v.
+Proof.
+ unfold make_select; intros.
+ destruct (resolve_branch (eval_static_condition c vl)) as [b|] eqn:RB.
+- exists (if b then e#r1 else e#r2); split.
++ simpl. destruct b; auto.
++ destruct (eval_condition c e##args m) as [b'|] eqn:EC; simpl; auto.
+ assert (b = b').
+ { eapply resolve_branch_sound; eauto.
+ rewrite <- EC. apply eval_static_condition_sound with bc.
+ subst vl. exact (aregs_sound _ _ _ args MATCH). }
+ subst b'. apply Val.lessdef_normalize.
+- generalize (cond_strength_reduction_correct c args vl H).
+ destruct (cond_strength_reduction c args vl) as [cond' args']; intros EQ.
+ econstructor; split. simpl; eauto. rewrite EQ; auto.
+Qed.
+
Lemma make_addimm_correct:
forall n r,
let (op, args) := make_addimm n r in
@@ -905,6 +927,8 @@ Proof.
auto.
(* cond *)
inv H0. apply make_cmp_correct; auto.
+(* select *)
+ inv H0. apply make_select_correct; congruence.
(* mulf *)
InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) e#r2).
diff --git a/x86/Conventions1.v b/x86/Conventions1.v
index 35d555f9..d9f5b8fa 100644
--- a/x86/Conventions1.v
+++ b/x86/Conventions1.v
@@ -100,22 +100,20 @@ Definition is_float_reg (r: mreg) :=
function with one integer result. *)
Definition loc_result_32 (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One AX
- | Some (Tint | Tany32) => One AX
- | Some (Tfloat | Tsingle) => One FP0
- | Some Tany64 => One X0
- | Some Tlong => Twolong DX AX
+ match proj_sig_res s with
+ | Tint | Tany32 => One AX
+ | Tfloat | Tsingle => One FP0
+ | Tany64 => One X0
+ | Tlong => Twolong DX AX
end.
(** In 64 bit mode, he result value of a function is passed back to
the caller in registers [AX] or [X0]. *)
Definition loc_result_64 (s: signature) : rpair mreg :=
- match s.(sig_res) with
- | None => One AX
- | Some (Tint | Tlong | Tany32 | Tany64) => One AX
- | Some (Tfloat | Tsingle) => One X0
+ match proj_sig_res s with
+ | Tint | Tlong | Tany32 | Tany64 => One AX
+ | Tfloat | Tsingle => One X0
end.
Definition loc_result :=
@@ -127,8 +125,8 @@ Lemma loc_result_type:
forall sig,
subtype (proj_sig_res sig) (typ_rpair mreg_type (loc_result sig)) = true.
Proof.
- intros. unfold proj_sig_res, loc_result, loc_result_32, loc_result_64, mreg_type;
- destruct Archi.ptr64; destruct (sig_res sig) as [[]|]; auto.
+ intros. unfold loc_result, loc_result_32, loc_result_64, mreg_type;
+ destruct Archi.ptr64; destruct (proj_sig_res sig); auto.
Qed.
(** The result locations are caller-save registers *)
@@ -138,7 +136,7 @@ Lemma loc_result_caller_save:
forall_rpair (fun r => is_callee_save r = false) (loc_result s).
Proof.
intros. unfold loc_result, loc_result_32, loc_result_64, is_callee_save;
- destruct Archi.ptr64; destruct (sig_res s) as [[]|]; simpl; auto.
+ destruct Archi.ptr64; destruct (proj_sig_res s); simpl; auto.
Qed.
(** If the result is in a pair of registers, those registers are distinct and have type [Tint] at least. *)
@@ -148,14 +146,14 @@ Lemma loc_result_pair:
match loc_result sg with
| One _ => True
| Twolong r1 r2 =>
- r1 <> r2 /\ sg.(sig_res) = Some Tlong
+ r1 <> r2 /\ proj_sig_res sg = Tlong
/\ subtype Tint (mreg_type r1) = true /\ subtype Tint (mreg_type r2) = true
/\ Archi.ptr64 = false
end.
Proof.
intros.
unfold loc_result, loc_result_32, loc_result_64, mreg_type;
- destruct Archi.ptr64; destruct (sig_res sg) as [[]|]; auto.
+ destruct Archi.ptr64; destruct (proj_sig_res sg); auto.
split; auto. congruence.
Qed.
@@ -164,7 +162,7 @@ Qed.
Lemma loc_result_exten:
forall s1 s2, s1.(sig_res) = s2.(sig_res) -> loc_result s1 = loc_result s2.
Proof.
- intros. unfold loc_result, loc_result_32, loc_result_64.
+ intros. unfold loc_result, loc_result_32, loc_result_64, proj_sig_res.
destruct Archi.ptr64; rewrite H; auto.
Qed.
@@ -223,36 +221,6 @@ Definition loc_arguments (s: signature) : list (rpair loc) :=
then loc_arguments_64 s.(sig_args) 0 0 0
else loc_arguments_32 s.(sig_args) 0.
-(** [size_arguments s] returns the number of [Outgoing] slots used
- to call a function with signature [s]. *)
-
-Fixpoint size_arguments_32
- (tyl: list typ) (ofs: Z) {struct tyl} : Z :=
- match tyl with
- | nil => ofs
- | ty :: tys => size_arguments_32 tys (ofs + typesize ty)
- end.
-
-Fixpoint size_arguments_64 (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
- match tyl with
- | nil => ofs
- | (Tint | Tlong | Tany32 | Tany64) :: tys =>
- match list_nth_z int_param_regs ir with
- | None => size_arguments_64 tys ir fr (ofs + 2)
- | Some ireg => size_arguments_64 tys (ir + 1) fr ofs
- end
- | (Tfloat | Tsingle) :: tys =>
- match list_nth_z float_param_regs fr with
- | None => size_arguments_64 tys ir fr (ofs + 2)
- | Some freg => size_arguments_64 tys ir (fr + 1) ofs
- end
- end.
-
-Definition size_arguments (s: signature) : Z :=
- if Archi.ptr64
- then size_arguments_64 s.(sig_args) 0 0 0
- else size_arguments_32 s.(sig_args) 0.
-
(** Argument locations are either caller-save registers or [Outgoing]
stack slots at nonnegative offsets. *)
@@ -354,123 +322,22 @@ Qed.
Hint Resolve loc_arguments_acceptable: locs.
-(** The offsets of [Outgoing] arguments are below [size_arguments s]. *)
-
-Remark size_arguments_32_above:
- forall tyl ofs0, ofs0 <= size_arguments_32 tyl ofs0.
+Lemma loc_arguments_main:
+ loc_arguments signature_main = nil.
Proof.
- induction tyl; simpl; intros.
- omega.
- apply Z.le_trans with (ofs0 + typesize a); auto.
- generalize (typesize_pos a); omega.
+ unfold loc_arguments; destruct Archi.ptr64; reflexivity.
Qed.
-Remark size_arguments_64_above:
- forall tyl ir fr ofs0,
- ofs0 <= size_arguments_64 tyl ir fr ofs0.
-Proof.
- induction tyl; simpl; intros.
- omega.
- assert (A: ofs0 <=
- match list_nth_z int_param_regs ir with
- | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0
- | None => size_arguments_64 tyl ir fr (ofs0 + 2)
- end).
- { destruct (list_nth_z int_param_regs ir); eauto.
- apply Z.le_trans with (ofs0 + 2); auto. omega. }
- assert (B: ofs0 <=
- match list_nth_z float_param_regs fr with
- | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0
- | None => size_arguments_64 tyl ir fr (ofs0 + 2)
- end).
- { destruct (list_nth_z float_param_regs fr); eauto.
- apply Z.le_trans with (ofs0 + 2); auto. omega. }
- destruct a; auto.
-Qed.
+(** ** Normalization of function results *)
-Lemma size_arguments_above:
- forall s, size_arguments s >= 0.
-Proof.
- intros; unfold size_arguments. apply Z.le_ge.
- destruct Archi.ptr64; [apply size_arguments_64_above|apply size_arguments_32_above].
-Qed.
+(** In the x86 ABI, a return value of type "char" is returned in
+ register AL, leaving the top 24 bits of EAX unspecified.
+ Likewise, a return value of type "short" is returned in register
+ AH, leaving the top 16 bits of EAX unspecified. Hence, return
+ values of small integer types need re-normalization after calls. *)
-Lemma loc_arguments_32_bounded:
- forall ofs ty tyl ofs0,
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_32 tyl ofs0)) ->
- ofs + typesize ty <= size_arguments_32 tyl ofs0.
-Proof.
- induction tyl as [ | t l]; simpl; intros x IN.
-- contradiction.
-- rewrite in_app_iff in IN; destruct IN as [IN|IN].
-+ apply Z.le_trans with (x + typesize t); [|apply size_arguments_32_above].
- Ltac decomp :=
- match goal with
- | [ H: _ \/ _ |- _ ] => destruct H; decomp
- | [ H: S _ _ _ = S _ _ _ |- _ ] => inv H
- | [ H: False |- _ ] => contradiction
+Definition return_value_needs_normalization (t: rettype) : bool :=
+ match t with
+ | Tint8signed | Tint8unsigned | Tint16signed | Tint16unsigned => true
+ | _ => false
end.
- destruct t; simpl in IN; decomp; simpl; omega.
-+ apply IHl; auto.
-Qed.
-
-Lemma loc_arguments_64_bounded:
- forall ofs ty tyl ir fr ofs0,
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments_64 tyl ir fr ofs0)) ->
- ofs + typesize ty <= size_arguments_64 tyl ir fr ofs0.
-Proof.
- induction tyl; simpl; intros.
- contradiction.
- assert (T: forall ty0, typesize ty0 <= 2).
- { destruct ty0; simpl; omega. }
- assert (A: forall ty0,
- In (S Outgoing ofs ty) (regs_of_rpairs
- match list_nth_z int_param_regs ir with
- | Some ireg =>
- One (R ireg) :: loc_arguments_64 tyl (ir + 1) fr ofs0
- | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2)
- end) ->
- ofs + typesize ty <=
- match list_nth_z int_param_regs ir with
- | Some _ => size_arguments_64 tyl (ir + 1) fr ofs0
- | None => size_arguments_64 tyl ir fr (ofs0 + 2)
- end).
- { intros. destruct (list_nth_z int_param_regs ir); simpl in H0; destruct H0.
- - discriminate.
- - eapply IHtyl; eauto.
- - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above.
- - eapply IHtyl; eauto. }
- assert (B: forall ty0,
- In (S Outgoing ofs ty) (regs_of_rpairs
- match list_nth_z float_param_regs fr with
- | Some ireg =>
- One (R ireg) :: loc_arguments_64 tyl ir (fr + 1) ofs0
- | None => One (S Outgoing ofs0 ty0) :: loc_arguments_64 tyl ir fr (ofs0 + 2)
- end) ->
- ofs + typesize ty <=
- match list_nth_z float_param_regs fr with
- | Some _ => size_arguments_64 tyl ir (fr + 1) ofs0
- | None => size_arguments_64 tyl ir fr (ofs0 + 2)
- end).
- { intros. destruct (list_nth_z float_param_regs fr); simpl in H0; destruct H0.
- - discriminate.
- - eapply IHtyl; eauto.
- - inv H0. apply Z.le_trans with (ofs + 2). specialize (T ty). omega. apply size_arguments_64_above.
- - eapply IHtyl; eauto. }
- destruct a; eauto.
-Qed.
-
-Lemma loc_arguments_bounded:
- forall (s: signature) (ofs: Z) (ty: typ),
- In (S Outgoing ofs ty) (regs_of_rpairs (loc_arguments s)) ->
- ofs + typesize ty <= size_arguments s.
-Proof.
- unfold loc_arguments, size_arguments; intros.
- destruct Archi.ptr64; eauto using loc_arguments_32_bounded, loc_arguments_64_bounded.
-Qed.
-
-Lemma loc_arguments_main:
- loc_arguments signature_main = nil.
-Proof.
- unfold loc_arguments; destruct Archi.ptr64; reflexivity.
-Qed.
diff --git a/x86/DuplicateOpcodeHeuristic.ml b/x86/DuplicateOpcodeHeuristic.ml
new file mode 100644
index 00000000..2ec314c1
--- /dev/null
+++ b/x86/DuplicateOpcodeHeuristic.ml
@@ -0,0 +1,27 @@
+(* open Camlcoq *)
+open Op
+open Integers
+
+let opcode_heuristic code cond ifso ifnot is_loop_header =
+ match cond with
+ | Ccompimm (c, n) | Ccompuimm (c, n) -> if n == Integers.Int.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccomplimm (c, n) | Ccompluimm (c, n) -> if n == Integers.Int64.zero then (match c with
+ | Clt | Cle -> Some false
+ | Cgt | Cge -> Some true
+ | _ -> None
+ ) else None
+ | Ccompf c | Ccompfs c -> (match c with
+ | Ceq -> Some false
+ | Cne -> Some true
+ | _ -> None
+ )
+ | Cnotcompf c | Cnotcompfs c -> (match c with
+ | Ceq -> Some true
+ | Cne -> Some false
+ | _ -> None
+ )
+ | _ -> None
diff --git a/x86/Machregs.v b/x86/Machregs.v
index bdf492ed..6f3064b8 100644
--- a/x86/Machregs.v
+++ b/x86/Machregs.v
@@ -351,6 +351,7 @@ Definition two_address_op (op: operation) : bool :=
| Olongofsingle => false
| Osingleoflong => false
| Ocmp c => false
+ | Osel c op => true
end.
(* Constraints on constant propagation for builtins *)
diff --git a/x86/NeedOp.v b/x86/NeedOp.v
index 68ecc745..d9a58fbb 100644
--- a/x86/NeedOp.v
+++ b/x86/NeedOp.v
@@ -120,6 +120,7 @@ Definition needs_of_operation (op: operation) (nv: nval): list nval :=
| Ointoffloat | Ofloatofint | Ointofsingle | Osingleofint => op1 (default nv)
| Olongoffloat | Ofloatoflong | Olongofsingle | Osingleoflong => op1 (default nv)
| Ocmp c => needs_of_condition c
+ | Osel c ty => nv :: nv :: needs_of_condition c
end.
Definition operation_is_redundant (op: operation) (nv: nval): bool :=
@@ -231,6 +232,10 @@ Proof.
erewrite needs_of_condition_sound by eauto.
subst v; simpl. auto with na.
subst v; auto with na.
+- destruct (eval_condition c args m) as [b|] eqn:EC.
+ erewrite needs_of_condition_sound by eauto.
+ apply select_sound; auto.
+ simpl; auto with na.
Qed.
Lemma operation_is_redundant_sound:
diff --git a/x86/Op.v b/x86/Op.v
index 79c84ca2..15672bbe 100644
--- a/x86/Op.v
+++ b/x86/Op.v
@@ -167,7 +167,9 @@ Inductive operation : Type :=
| Olongofsingle (**r [rd = signed_long_of_float32(r1)] *)
| Osingleoflong (**r [rd = float32_of_signed_long(r1)] *)
(*c Boolean tests: *)
- | Ocmp (cond: condition). (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Ocmp (cond: condition) (**r [rd = 1] if condition holds, [rd = 0] otherwise. *)
+ | Osel: condition -> typ -> operation.
+ (**r [rd = rs1] if condition holds, [rd = rs2] otherwise. *)
(** Comparison functions (used in modules [CSE] and [Allocation]). *)
@@ -186,7 +188,7 @@ Defined.
Definition beq_operation: forall (x y: operation), bool.
Proof.
- generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec ident_eq eq_addressing eq_condition; boolean_equality.
+ generalize Int.eq_dec Int64.eq_dec Float.eq_dec Float32.eq_dec ident_eq typ_eq eq_addressing eq_condition; boolean_equality.
Defined.
Definition eq_operation: forall (x y: operation), {x=y} + {x<>y}.
@@ -407,6 +409,7 @@ Definition eval_operation
| Olongofsingle, v1::nil => Val.longofsingle v1
| Osingleoflong, v1::nil => Val.singleoflong v1
| Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m))
+ | Osel c ty, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2 ty)
| _, _ => None
end.
@@ -578,6 +581,7 @@ Definition type_of_operation (op: operation) : list typ * typ :=
| Olongofsingle => (Tsingle :: nil, Tlong)
| Osingleoflong => (Tlong :: nil, Tsingle)
| Ocmp c => (type_of_condition c, Tint)
+ | Osel c ty => (ty :: ty :: type_of_condition c, ty)
end.
(** Weak type soundness results for [eval_operation]:
@@ -735,8 +739,40 @@ Proof with (try exact I; try reflexivity).
destruct v0; simpl in H0; inv H0. destruct (Float32.to_long f); inv H2...
destruct v0; simpl in H0; inv H0...
destruct (eval_condition cond vl m); simpl... destruct b...
+ unfold Val.select. destruct (eval_condition c vl m). apply Val.normalize_type. exact I.
Qed.
+
+Definition is_trapping_op (op : operation) :=
+ match op with
+ | Odiv | Odivl | Odivu | Odivlu
+ | Omod | Omodl | Omodu | Omodlu
+ | Oshrximm _ | Oshrxlimm _
+ | Ointoffloat
+ | Ointofsingle
+ | Olongoffloat
+ | Olongofsingle
+ | Osingleofint
+ | Osingleoflong
+ | Ofloatofint
+ | Ofloatoflong
+ | Olea _ | Oleal _ (* TODO this is suboptimal *) => true
+ | _ => false
+ end.
+
+Lemma is_trapping_op_sound:
+ forall op vl sp m,
+ op <> Omove ->
+ is_trapping_op op = false ->
+ (List.length vl) = (List.length (fst (type_of_operation op))) ->
+ eval_operation genv sp op vl m <> None.
+Proof.
+ destruct op; intros; simpl in *; try congruence.
+ all: try (destruct vl as [ | vh1 vl1]; try discriminate).
+ all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
+ all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
+ all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
+Qed.
End SOUNDNESS.
(** * Manipulating and transforming operations *)
@@ -958,23 +994,42 @@ Definition is_trivial_op (op: operation) : bool :=
(** Operations that depend on the memory state. *)
+Definition condition_depends_on_memory (c: condition) : bool :=
+ match c with
+ | Ccompu _ => negb Archi.ptr64
+ | Ccompuimm _ _ => negb Archi.ptr64
+ | Ccomplu _ => Archi.ptr64
+ | Ccompluimm _ _ => Archi.ptr64
+ | _ => false
+ end.
+
Definition op_depends_on_memory (op: operation) : bool :=
match op with
- | Ocmp (Ccompu _) => negb Archi.ptr64
- | Ocmp (Ccompuimm _ _) => negb Archi.ptr64
- | Ocmp (Ccomplu _) => Archi.ptr64
- | Ocmp (Ccompluimm _ _) => Archi.ptr64
+ | Ocmp c => condition_depends_on_memory c
+ | Osel c ty => condition_depends_on_memory c
| _ => false
end.
+Lemma condition_depends_on_memory_correct:
+ forall c args m1 m2,
+ condition_depends_on_memory c = false ->
+ eval_condition c args m1 = eval_condition c args m2.
+Proof.
+ intros until m2.
+ destruct c; simpl; intros SF; auto; rewrite ? negb_false_iff in SF;
+ unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+Qed.
+
Lemma op_depends_on_memory_correct:
forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
op_depends_on_memory op = false ->
eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
- intros until m2. destruct op; simpl; try congruence.
- destruct cond; simpl; intros SF; auto; rewrite ? negb_false_iff in SF;
- unfold Val.cmpu_bool, Val.cmplu_bool; rewrite SF; reflexivity.
+ intros until m2. destruct op; simpl; try congruence; intros C.
+- f_equal; f_equal; apply condition_depends_on_memory_correct; auto.
+- destruct args; auto. destruct args; auto.
+ rewrite (condition_depends_on_memory_correct c args m1 m2 C).
+ auto.
Qed.
(** Global variables mentioned in an operation or addressing mode *)
@@ -1175,6 +1230,21 @@ Proof.
unfold eval_addressing; intros. destruct Archi.ptr64; eauto using eval_addressing32_inj, eval_addressing64_inj.
Qed.
+Lemma eval_addressing_inj_none:
+ forall addr sp1 vl1 sp2 vl2,
+ (forall id ofs,
+ In id (globals_addressing addr) ->
+ Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
+ Val.inject f sp1 sp2 ->
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing ge1 sp1 addr vl1 = None ->
+ eval_addressing ge2 sp2 addr vl2 = None.
+Proof.
+ intros until vl2. intros Hglobal Hinjsp Hinjvl.
+ destruct addr; simpl in *;
+ inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
+Qed.
+
Lemma eval_operation_inj:
forall op sp1 vl1 sp2 vl2 v1,
(forall id ofs,
@@ -1290,6 +1360,9 @@ Proof.
exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
destruct b; simpl; constructor.
simpl; constructor.
+ apply Val.select_inject; auto.
+ destruct (eval_condition c vl1 m1) eqn:?; auto.
+ right; symmetry; eapply eval_condition_inj; eauto.
Qed.
End EVAL_COMPAT.
@@ -1398,6 +1471,19 @@ Proof.
destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.
+Lemma eval_addressing_lessdef_none:
+ forall sp addr vl1 vl2,
+ Val.lessdef_list vl1 vl2 ->
+ eval_addressing genv sp addr vl1 = None ->
+ eval_addressing genv sp addr vl2 = None.
+Proof.
+ intros until vl2. intros Hlessdef Heval1.
+ destruct addr; simpl in *;
+ inv Hlessdef; trivial; try discriminate;
+ inv H0; trivial; try discriminate;
+ inv H2; trivial; try discriminate.
+Qed.
+
End EVAL_LESSDEF.
(** Compatibility of the evaluation functions with memory injections. *)
@@ -1450,6 +1536,19 @@ Proof.
econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.
+Lemma eval_addressing_inject_none:
+ forall addr vl1 vl2,
+ Val.inject_list f vl1 vl2 ->
+ eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
+ eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
+Proof.
+ intros.
+ rewrite eval_shift_stack_addressing.
+ eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
+ intros. apply symbol_address_inject.
+ econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
+Qed.
+
Lemma eval_operation_inject:
forall op vl1 vl2 v1 m1 m2,
Val.inject_list f vl1 vl2 ->
diff --git a/x86/PrintOp.ml b/x86/PrintOp.ml
index faa5bb5f..6aa4d450 100644
--- a/x86/PrintOp.ml
+++ b/x86/PrintOp.ml
@@ -164,6 +164,10 @@ let print_operation reg pp = function
| Olongofsingle, [r1] -> fprintf pp "longofsingle(%a)" reg r1
| Osingleoflong, [r1] -> fprintf pp "singleoflong(%a)" reg r1
| Ocmp c, args -> print_condition reg pp (c, args)
+ | Osel (c, ty), r1::r2::args ->
+ fprintf pp "%a ?%s %a : %a"
+ (print_condition reg) (c, args)
+ (PrintAST.name_of_type ty) reg r1 reg r2
| _ -> fprintf pp "<bad operator>"
diff --git a/x86/SelectOp.vp b/x86/SelectOp.vp
index eadda093..a23c37d5 100644
--- a/x86/SelectOp.vp
+++ b/x86/SelectOp.vp
@@ -38,9 +38,10 @@
Require Import Coqlib.
Require Import Compopts.
-Require Import AST Integers Floats.
+Require Import AST Integers Floats Builtins.
Require Import Op CminorSel.
Require Import OpHelpers.
+Require Archi.
Local Open Scope cminorsel_scope.
@@ -457,7 +458,35 @@ Nondetfunction cast16signed (e: expr) :=
Eop Ocast16signed (e ::: Enil)
end.
-(** Floating-point conversions *)
+(** ** Selection *)
+
+Definition select_supported (ty: typ) : bool :=
+ match ty with
+ | Tint => true
+ | Tlong => Archi.ptr64
+ | _ => false
+ end.
+
+(** [Asmgen.mk_sel] cannot always handle the conditions that are
+ implemented as a "and" of two processor flags. However it can
+ handle the negation of those conditions, which are implemented
+ as an "or". So, for the risky conditions we just take their
+ negation and swap the two arguments of the [select]. *)
+
+Definition select_swap (cond: condition) :=
+ match cond with
+ | Ccompf Cne | Ccompfs Cne | Cnotcompf Ceq | Cnotcompfs Ceq => true
+ | _ => false
+ end.
+
+Definition select (ty: typ) (cond: condition) (args: exprlist) (e1 e2: expr) :=
+ if select_supported ty then
+ if select_swap cond
+ then Some (Eop (Osel (negate_condition cond) ty) (e2 ::: e1 ::: args))
+ else Some (Eop (Osel cond ty) (e1 ::: e2 ::: args))
+ else None.
+
+(** ** Floating-point conversions *)
Definition singleoffloat (e: expr) := Eop Osingleoffloat (e ::: Enil).
Definition floatofsingle (e: expr) := Eop Ofloatofsingle (e ::: Enil).
@@ -471,21 +500,27 @@ Nondetfunction floatofint (e: expr) :=
end.
Definition intuoffloat (e: expr) :=
- Elet e
- (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil)
- (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil))
- (intoffloat (Eletvar 1))
- (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat.
+ if Archi.splitlong then
+ Elet e
+ (Elet (Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil)
+ (Econdition (CEcond (Ccompf Clt) (Eletvar 1 ::: Eletvar 0 ::: Enil))
+ (intoffloat (Eletvar 1))
+ (addimm Float.ox8000_0000 (intoffloat (subf (Eletvar 1) (Eletvar 0))))))%nat
+ else
+ Eop Olowlong (Eop Olongoffloat (e ::: Enil) ::: Enil).
Nondetfunction floatofintu (e: expr) :=
match e with
| Eop (Ointconst n) Enil => Eop (Ofloatconst (Float.of_intu n)) Enil
| _ =>
- let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in
- Elet e
- (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil))
- (floatofint (Eletvar O))
- (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f))
+ if Archi.splitlong then
+ let f := Eop (Ofloatconst (Float.of_intu Float.ox8000_0000)) Enil in
+ Elet e
+ (Econdition (CEcond (Ccompuimm Clt Float.ox8000_0000) (Eletvar O ::: Enil))
+ (floatofint (Eletvar O))
+ (addf (floatofint (addimm (Int.neg Float.ox8000_0000) (Eletvar O))) f))
+ else
+ Eop Ofloatoflong (Eop Ocast32unsigned (e ::: Enil) ::: Enil)
end.
Definition intofsingle (e: expr) := Eop Ointofsingle (e ::: Enil).
@@ -548,3 +583,8 @@ Definition divf_base (e1: expr) (e2: expr) :=
Definition divfs_base (e1: expr) (e2: expr) :=
Eop Odivfs (e1 ::: e2 ::: Enil).
+
+(** Platform-specific known builtins *)
+
+Definition platform_builtin (b: platform_builtin) (args: exprlist) : option expr :=
+ None.
diff --git a/x86/SelectOpproof.v b/x86/SelectOpproof.v
index 1eeb5906..af1d4e08 100644
--- a/x86/SelectOpproof.v
+++ b/x86/SelectOpproof.v
@@ -13,15 +13,9 @@
(** Correctness of instruction selection for operators *)
Require Import Coqlib.
-Require Import AST.
-Require Import Integers.
-Require Import Floats.
-Require Import Values.
-Require Import Memory.
-Require Import Globalenvs.
-Require Import Cminor.
-Require Import Op.
-Require Import CminorSel.
+Require Import AST Integers Floats.
+Require Import Values Memory Builtins Globalenvs.
+Require Import Cminor Op CminorSel.
Require Import SelectOp.
Require Import OpHelpers.
Require Import OpHelpersproof.
@@ -391,9 +385,9 @@ Proof.
- TrivialExists. simpl. rewrite Int.and_commut; auto.
- TrivialExists. simpl. rewrite Val.and_assoc. rewrite Int.and_commut. auto.
- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc.
- rewrite Int.and_commut. auto. compute; auto.
+ rewrite Int.and_commut. auto. omega.
- rewrite Val.zero_ext_and. TrivialExists. rewrite Val.and_assoc.
- rewrite Int.and_commut. auto. compute; auto.
+ rewrite Int.and_commut. auto. omega.
- TrivialExists.
Qed.
@@ -753,7 +747,7 @@ Proof.
red; intros until x. unfold cast8unsigned. destruct (cast8unsigned_match a); intros; InvEval.
TrivialExists.
subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc.
- rewrite Int.and_commut. apply eval_andimm; auto. compute; auto.
+ rewrite Int.and_commut. apply eval_andimm; auto. omega.
TrivialExists.
Qed.
@@ -769,10 +763,36 @@ Proof.
red; intros until x. unfold cast16unsigned. destruct (cast16unsigned_match a); intros; InvEval.
TrivialExists.
subst. rewrite Val.zero_ext_and. rewrite Val.and_assoc.
- rewrite Int.and_commut. apply eval_andimm; auto. compute; auto.
+ rewrite Int.and_commut. apply eval_andimm; auto. omega.
TrivialExists.
Qed.
+Theorem eval_select:
+ forall le ty cond al vl a1 v1 a2 v2 a b,
+ select ty cond al a1 a2 = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ eval_expr ge sp e m le a1 v1 ->
+ eval_expr ge sp e m le a2 v2 ->
+ eval_condition cond vl m = Some b ->
+ exists v,
+ eval_expr ge sp e m le a v
+ /\ Val.lessdef (Val.select (Some b) v1 v2 ty) v.
+Proof.
+ unfold select; intros.
+ destruct (select_supported ty); try discriminate.
+ destruct (select_swap cond); inv H.
+- exists (Val.select (Some (negb b)) v2 v1 ty); split.
+ apply eval_Eop with (v2 :: v1 :: vl).
+ constructor; auto. constructor; auto.
+ simpl. rewrite eval_negate_condition, H3; auto.
+ destruct b; auto.
+- exists (Val.select (Some b) v1 v2 ty); split.
+ apply eval_Eop with (v1 :: v2 :: vl).
+ constructor; auto. constructor; auto.
+ simpl. rewrite H3; auto.
+ auto.
+Qed.
+
Theorem eval_singleoffloat: unary_constructor_sound singleoffloat Val.singleoffloat.
Proof.
red; intros. unfold singleoffloat. TrivialExists.
@@ -812,7 +832,8 @@ Proof.
intros. destruct x; simpl in H0; try discriminate.
destruct (Float.to_intu f) as [n|] eqn:?; simpl in H0; inv H0.
exists (Vint n); split; auto. unfold intuoffloat.
- set (im := Int.repr Int.half_modulus).
+ destruct Archi.splitlong.
+- set (im := Int.repr Int.half_modulus).
set (fm := Float.of_intu im).
assert (eval_expr ge sp e m (Vfloat fm :: Vfloat f :: le) (Eletvar (S O)) (Vfloat f)).
constructor. auto.
@@ -839,6 +860,11 @@ Proof.
rewrite Int.add_neg_zero in A4.
rewrite Int.add_zero in A4.
auto.
+- apply Float.to_intu_to_long in Heqo. repeat econstructor. eauto.
+ simpl. rewrite Heqo; reflexivity.
+ simpl. unfold Int64.loword. rewrite Int64.unsigned_repr, Int.repr_unsigned; auto.
+ assert (Int.modulus < Int64.max_unsigned) by reflexivity.
+ generalize (Int.unsigned_range n); omega.
Qed.
Theorem eval_floatofintu:
@@ -848,10 +874,11 @@ Theorem eval_floatofintu:
exists v, eval_expr ge sp e m le (floatofintu a) v /\ Val.lessdef y v.
Proof.
intros until y; unfold floatofintu. case (floatofintu_match a); intros.
- InvEval. TrivialExists.
- destruct x; simpl in H0; try discriminate. inv H0.
+- InvEval. TrivialExists.
+- destruct x; simpl in H0; try discriminate. inv H0.
exists (Vfloat (Float.of_intu i)); split; auto.
- econstructor. eauto.
+ destruct Archi.splitlong.
++ econstructor. eauto.
set (fm := Float.of_intu Float.ox8000_0000).
assert (eval_expr ge sp e m (Vint i :: le) (Eletvar O) (Vint i)).
constructor. auto.
@@ -867,6 +894,7 @@ Proof.
constructor. EvalOp. simpl; eauto. constructor. simpl; eauto.
fold fm. rewrite Float.of_intu_of_int_2; auto.
rewrite Int.sub_add_opp. auto.
++ rewrite Float.of_intu_of_long. repeat econstructor. eauto. reflexivity.
Qed.
Theorem eval_intofsingle:
@@ -988,7 +1016,6 @@ Proof.
- constructor; auto.
Qed.
-
(* floating-point division without HELPERS *)
Theorem eval_divf_base:
forall le a b x y,
@@ -1009,4 +1036,17 @@ Proof.
intros; unfold divfs_base.
TrivialExists.
Qed.
+
+(** Platform-specific known builtins *)
+
+Theorem eval_platform_builtin:
+ forall bf al a vl v le,
+ platform_builtin bf al = Some a ->
+ eval_exprlist ge sp e m le al vl ->
+ platform_builtin_sem bf vl = Some v ->
+ exists v', eval_expr ge sp e m le a v' /\ Val.lessdef v v'.
+Proof.
+ intros. discriminate.
+Qed.
+
End CMCONSTR.
diff --git a/x86/TargetPrinter.ml b/x86/TargetPrinter.ml
index 3ac2f36e..6159437e 100644
--- a/x86/TargetPrinter.ml
+++ b/x86/TargetPrinter.ml
@@ -62,8 +62,8 @@ let ireg64 oc r = output_string oc (int64_reg_name r)
let ireg = if Archi.ptr64 then ireg64 else ireg32
let freg oc r = output_string oc (float_reg_name r)
-let preg oc = function
- | IR r -> ireg oc r
+let preg_asm oc ty = function
+ | IR r -> if ty = Tlong then ireg64 oc r else ireg32 oc r
| FR r -> freg oc r
| _ -> assert false
@@ -103,7 +103,7 @@ let rec log2 n =
assert (n > 0);
if n = 1 then 0 else 1 + log2 (n lsr 1)
-(* System dependend printer functions *)
+(* System dependent printer functions *)
module type SYSTEM =
sig
val raw_symbol: out_channel -> string -> unit
@@ -134,9 +134,9 @@ module ELF_System : SYSTEM =
let name_of_section = function
| Section_text -> ".text"
| Section_data i | Section_small_data i ->
- if i then ".data" else "COMM"
+ if i then ".data" else common_section ()
| Section_const i | Section_small_const i ->
- if i then ".section .rodata" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".section .rodata" else "COMM"
| Section_string -> ".section .rodata"
| Section_literal -> ".section .rodata.cst8,\"aM\",@progbits,8"
| Section_jumptable -> ".text"
@@ -192,9 +192,9 @@ module MacOS_System : SYSTEM =
let name_of_section = function
| Section_text -> ".text"
| Section_data i | Section_small_data i ->
- if i then ".data" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".data" else "COMM"
| Section_const i | Section_small_const i ->
- if i then ".const" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".const" else "COMM"
| Section_string -> ".const"
| Section_literal -> ".literal8"
| Section_jumptable -> ".text" (* needed in 64 bits, not a problem in 32 bits *)
@@ -269,9 +269,9 @@ module Cygwin_System : SYSTEM =
let name_of_section = function
| Section_text -> ".text"
| Section_data i | Section_small_data i ->
- if i then ".data" else "COMM"
+ if i then ".data" else common_section ()
| Section_const i | Section_small_const i ->
- if i then ".section .rdata,\"dr\"" else "COMM"
+ if i || (not !Clflags.option_fcommon) then ".section .rdata,\"dr\"" else "COMM"
| Section_string -> ".section .rdata,\"dr\""
| Section_literal -> ".section .rdata,\"dr\""
| Section_jumptable -> ".text"
@@ -399,7 +399,13 @@ module Target(System: SYSTEM):TARGET =
(* Printing of instructions *)
-(* Reminder on AT&T syntax: op source, dest *)
+(* Reminder on X86 assembly syntaxes:
+ AT&T syntax Intel syntax
+ (used by GNU as) (used in reference manuals)
+ dst <- op(src) op src, dst op dst, src
+ dst <- op(dst, src2) op src2, dst op dst, src2
+ dst <- op(dst, src2, src3) op src3, src2, dst op dst, src2, src3
+*)
let print_instruction oc = function
(* Moves *)
@@ -752,29 +758,29 @@ module Target(System: SYSTEM):TARGET =
| Pcfi_adjust sz ->
cfi_adjust oc (camlint_of_coqint sz)
| Pfmadd132 (res,a1,a2) ->
- fprintf oc " vfmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmadd132sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfmadd213 (res,a1,a2) ->
- fprintf oc " vfmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfmadd231 (res,a1,a2) ->
- fprintf oc " vfmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfmsub132 (res,a1,a2) ->
- fprintf oc " vfmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfmsub213 (res,a1,a2) ->
- fprintf oc " vfmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfmsub231 (res,a1,a2) ->
- fprintf oc " vfmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfmsub231sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmadd132 (res,a1,a2) ->
- fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmadd132sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmadd213 (res,a1,a2) ->
- fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmadd213sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmadd231 (res,a1,a2) ->
- fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmadd231sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmsub132 (res,a1,a2) ->
- fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmsub132sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmsub213 (res,a1,a2) ->
- fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmsub213sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pfnmsub231 (res,a1,a2) ->
- fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a1 freg a2 freg res
+ fprintf oc " vfnmsub231sd %a, %a, %a\n" freg a2 freg a1 freg res
| Pmaxsd (res,a1) ->
fprintf oc " maxsd %a, %a\n" freg a1 freg res
| Pminsd (res,a1) ->
@@ -826,7 +832,7 @@ module Target(System: SYSTEM):TARGET =
(P.to_int kind) (extern_atom txt) args
| EF_inline_asm(txt, sg, clob) ->
fprintf oc "%s begin inline assembly\n\t" comment;
- print_inline_asm preg oc (camlstring_of_coqstring txt) sg args res;
+ print_inline_asm preg_asm oc (camlstring_of_coqstring txt) sg args res;
fprintf oc "%s end inline assembly\n" comment
| _ ->
assert false
diff --git a/x86/ValueAOp.v b/x86/ValueAOp.v
index 1021a9c8..e5584b6a 100644
--- a/x86/ValueAOp.v
+++ b/x86/ValueAOp.v
@@ -160,6 +160,7 @@ Definition eval_static_operation (op: operation) (vl: list aval): aval :=
| Olongofsingle, v1::nil => longofsingle v1
| Osingleoflong, v1::nil => singleoflong v1
| Ocmp c, _ => of_optbool (eval_static_condition c vl)
+ | Osel c ty, v1::v2::vl => select (eval_static_condition c vl) v1 v2
| _, _ => Vbot
end.
@@ -258,7 +259,27 @@ Proof.
eapply eval_static_addressing_32_sound; eauto.
eapply eval_static_addressing_64_sound; eauto.
apply of_optbool_sound. eapply eval_static_condition_sound; eauto.
+ apply select_sound; auto. eapply eval_static_condition_sound; eauto.
Qed.
-
+(*
+Theorem eval_static_addressing_sound_none:
+ forall addr vargs aargs,
+ eval_addressing ge (Vptr sp Ptrofs.zero) addr vargs = None ->
+ list_forall2 (vmatch bc) vargs aargs ->
+ (eval_static_addressing addr aargs) = Vbot.
+Proof.
+ unfold eval_addressing, eval_static_addressing.
+ intros until aargs. intros Heval_none Hlist.
+ destruct (Archi.ptr64).
+ inv Hlist.
+ destruct addr; trivial; discriminate.
+ inv H0.
+ destruct addr; trivial; try discriminate. simpl in *.
+ inv H2.
+ destruct addr; trivial; discriminate.
+ inv H3;
+ destruct addr; trivial; discriminate.
+Qed.
+*)
End SOUNDNESS.
diff --git a/x86_32/Archi.v b/x86_32/Archi.v
index 8e96b4f1..e9d05c14 100644
--- a/x86_32/Archi.v
+++ b/x86_32/Archi.v
@@ -16,9 +16,9 @@
(** Architecture-dependent parameters for x86 in 32-bit mode *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
Definition ptr64 := false.
@@ -34,21 +34,33 @@ Proof.
unfold splitlong. destruct ptr64; simpl; congruence.
Qed.
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (true, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (true, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (true, iter_nat 22 _ xO xH).
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- false. (**r always choose first NaN *)
+(* Always choose the first NaN argument, if any *)
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (true, iter_nat 22 _ xO xH).
+Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_64 | n :: _ => n end.
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- false. (**r always choose first NaN *)
+Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_32 | n :: _ => n end.
+
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. auto. Qed.
+
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. auto. Qed.
+
+Definition fma_order {A: Type} (x y z: A) := (x, y, z).
+
+Definition fma_invalid_mul_is_nan := false.
Definition float_of_single_preserves_sNaN := false.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
float_of_single_preserves_sNaN.
diff --git a/x86_64/Archi.v b/x86_64/Archi.v
index 7b5301df..959d8dc1 100644
--- a/x86_64/Archi.v
+++ b/x86_64/Archi.v
@@ -16,9 +16,9 @@
(** Architecture-dependent parameters for x86 in 64-bit mode *)
-Require Import ZArith.
-Require Import Fappli_IEEE.
-Require Import Fappli_IEEE_bits.
+Require Import ZArith List.
+(*From Flocq*)
+Require Import Binary Bits.
Definition ptr64 := true.
@@ -34,21 +34,33 @@ Proof.
unfold splitlong. destruct ptr64; simpl; congruence.
Qed.
-Program Definition default_pl_64 : bool * nan_pl 53 :=
- (true, iter_nat 51 _ xO xH).
+Definition default_nan_64 := (true, iter_nat 51 _ xO xH).
+Definition default_nan_32 := (true, iter_nat 22 _ xO xH).
-Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
- false. (**r always choose first NaN *)
+(* Always choose the first NaN argument, if any *)
-Program Definition default_pl_32 : bool * nan_pl 24 :=
- (true, iter_nat 22 _ xO xH).
+Definition choose_nan_64 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_64 | n :: _ => n end.
-Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
- false. (**r always choose first NaN *)
+Definition choose_nan_32 (l: list (bool * positive)) : bool * positive :=
+ match l with nil => default_nan_32 | n :: _ => n end.
+
+Lemma choose_nan_64_idem: forall n,
+ choose_nan_64 (n :: n :: nil) = choose_nan_64 (n :: nil).
+Proof. auto. Qed.
+
+Lemma choose_nan_32_idem: forall n,
+ choose_nan_32 (n :: n :: nil) = choose_nan_32 (n :: nil).
+Proof. auto. Qed.
+
+Definition fma_order {A: Type} (x y z: A) := (x, y, z).
+
+Definition fma_invalid_mul_is_nan := false.
Definition float_of_single_preserves_sNaN := false.
Global Opaque ptr64 big_endian splitlong
- default_pl_64 choose_binop_pl_64
- default_pl_32 choose_binop_pl_32
+ default_nan_64 choose_nan_64
+ default_nan_32 choose_nan_32
+ fma_order fma_invalid_mul_is_nan
float_of_single_preserves_sNaN.